Require Import UniMath.Foundations.Generalities.uu0.
Require Import UniMath.Foundations.hlevel1.hProp.
Require Import UniMath.Foundations.hlevel2.hSet.

Require Import UniMath.RezkCompletion.precategories.
Require Import UniMath.RezkCompletion.functor_categories.
Require Import SubstSystems.UnicodeNotations.
Require Import UniMath.RezkCompletion.whiskering.
Require Import UniMath.RezkCompletion.Monads.
Require Import UniMath.RezkCompletion.limits.products.
Require Import UniMath.RezkCompletion.limits.coproducts.
Require Import UniMath.RezkCompletion.limits.initial.
Require Import UniMath.RezkCompletion.FunctorAlgebras.
Require Import SubstSystems.Auxiliary.
Require Import SubstSystems.PointedFunctors.
Require Import SubstSystems.ProductPrecategory.
Require Import SubstSystems.HorizontalComposition.
Require Import SubstSystems.PointedFunctorsComposition.
Require Import SubstSystems.Signatures.
Require Import SubstSystems.SubstitutionSystems.
Require Import SubstSystems.FunctorsPointwiseCoproduct.
Require Import SubstSystems.GenMendlerIteration.
(* Require Import SubstSystems.FunctorAlgebraViews. *)
Require Import SubstSystems.RightKanExtension.
Require Import SubstSystems.GenMendlerIteration.
Require Import SubstSystems.EndofunctorsMonoidal.

Local Notation "# F" := (functor_on_morphisms F)(at level 3).
Local Notation "F ⟶ G" := (nat_trans F G) (at level 39).
Arguments functor_composite {_ _ _} _ _ .
Arguments nat_trans_comp {_ _ _ _ _} _ _ .
Local Notation "G ∙ F" := (functor_composite F G : [ _ , _ , _ ]) (at level 35).
Local Notation "α ∙∙ β" := (hor_comp β α) (at level 20).
Ltac pathvia b := (apply (@pathscomp0 _ _ b _ )).

Local Notation "α 'ø' Z" := (pre_whisker Z α)  (at level 25).
Local Notation "Z ∘ α" := (post_whisker _ _ _ _ α Z) (at level 35).
Local Notation "A ⊗ B" := (prodcatpair _ _ A B) (at level 10).
Local Notation "C ⟦ a , b ⟧" := (precategory_morphisms (C:=C) a b) (at level 50).

Local Coercion alg_carrier : algebra_ob >-> ob.

Arguments θ_source {_ _} _ .
Arguments θ_target {_ _} _ .
Arguments θ_Strength1 {_ _ _} _ .
Arguments θ_Strength2 {_ _ _} _ .

Section Precategory_Algebra.

Variable C : precategory.
Variable hs : has_homsets C.

Variable CP : Coproducts C.

Local Notation "'EndC'":= ([C, C, hs]) .
Local Notation "'Ptd'" := (precategory_Ptd C hs).
Local Notation "'U'" := (functor_ptd_forget C hs).

Let hsEndC : has_homsets EndC := functor_category_has_homsets C C hs.
Let CPEndC : Coproducts EndC := Coproducts_functor_precat _ _ CP hs.
Let EndEndC := [EndC, EndC, hsEndC].
Let CPEndEndC:= Coproducts_functor_precat _ _ CPEndC hsEndC: Coproducts EndEndC.
(*Opaque CPEndEndC.*)

Definition ℓ (X : EndC) : EndEndC := (pre_composition_functor C C C hs hs X).
(*   in Agda mode \ell *)

(*
Opaque hsEndC.
*)
(*Opaque CPEndC.*)

Variable KanExt : ∀ Z : Ptd, GlobalRightKanExtensionExists _ _ (U Z) _ hs hs.

Variable H : Signature C hs.
Let θ := theta H.

Definition Const_plus_H (X : EndC) : functor EndC EndC
  := coproduct_functor _ _ CPEndC
                       (constant_functor _ _ X)
                       H.

Definition Id_H := Const_plus_H (functor_identity _ : EndC).

Let Alg : precategory := precategory_FunctorAlg _ Id_H hsEndC.

Variable IA : Initial Alg.
Definition SpecializedGMIt (Z : Ptd) (X : EndC) :=
  SpecialGenMendlerIteration _ _ _ IA EndC hsEndC X _ (KanExt Z) .

Definition θ_in_first_arg (Z: Ptd) := nat_trans_fix_snd_arg _ _ _ _ _ θ Z.

Definition InitAlg : Alg := InitialObject _ IA.

(* original try in bracket_for_InitAlg with
  assert (iso_1 : functor_composite Id_H (pre_composition_functor C C C hs hs (U Z)) ⟶
                 coproduct_functor_data ([C, C] hs) ([C, C] hs) CPEndC
    (constant_functor ([C, C] hs) ([C, C] hs) (pr1 Z))
    (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z) : EndEndC ⟦ _ , _ ⟧ ).
  { admit. }
 *)

Lemma aux_iso_1_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (functor_composite Id_H (ℓ (U Z)))
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z))))
     (λ X : [C, C] hs,
      CoproductOfArrows ([C, C] hs)
        (CPEndC (functor_composite (U Z) (functor_identity C))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (ρ_functor C (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    eapply pathscomp0.
    apply CoproductOfArrows_comp.
    eapply pathscomp0.
Focus 2.
    eapply pathsinv0.
    apply CoproductOfArrows_comp.
    apply CoproductOfArrows_eq.
    + rewrite id_right.
      apply pathsinv0.
      apply id_right.
    + rewrite functor_id.
      do 2 rewrite id_right.
      apply pathsinv0.
      apply id_left.
Qed.

Definition aux_iso_1 (Z: Ptd): EndEndC ⟦ functor_composite Id_H
                                        (ℓ (U Z)),
                            CoproductObject EndEndC
           (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
              (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z))
                          ⟧.
Proof.
  refine (tpair _ _ _).
  - intro X.
    exact (CoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (ρ_functor _ (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))).
  - exact (aux_iso_1_is_nat_trans Z).
Defined.

Lemma aux_iso_1_inv_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z))) )
     (functor_composite Id_H (ℓ (U Z)))
     (λ X : [C, C] hs,
      CoproductOfArrows ([C, C] hs)
        (CPEndC (functor_composite (functor_identity C) (U Z))
           ((θ_source H) (X ⊗ Z))) (CPEndC (U Z) ((θ_source H) (X ⊗ Z)))
        (λ_functor C (U Z)) (nat_trans_id ((θ_source H) (X ⊗ Z):functor C C))).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    eapply pathscomp0.
    apply CoproductOfArrows_comp.
    eapply pathscomp0.
Focus 2.
    eapply pathsinv0.
    apply CoproductOfArrows_comp.
    apply CoproductOfArrows_eq.
    + rewrite id_right.
      apply pathsinv0.
      apply id_right.
    + rewrite functor_id.
      do 2 rewrite id_right.
      apply pathsinv0.
      apply id_left.
Qed.

Definition aux_iso_1_inv (Z: Ptd): EndEndC ⟦ CoproductObject EndEndC
           (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
              (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z)),
             functor_composite Id_H (ℓ (U Z)) ⟧.
Proof.
  refine (tpair _ _ _).
  - intro X.
    exact (CoproductOfArrows EndC (CPEndC _ _) (CPEndC _ _) (λ_functor _ (U Z)) (nat_trans_id (θ_source H (X⊗Z):functor C C))).
  - exact (aux_iso_1_inv_is_nat_trans Z).
Defined.

(*
Definition G_Thm15 (X : EndC) := coproduct_functor _ _ CPEndC
                       (constant_functor _ _ X)
                       H.
 *)

Lemma aux_iso_2_inv_is_nat_trans (Z : Ptd) :
   is_nat_trans
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z))) )
     (functor_composite (ℓ (U Z))
        (Const_plus_H (U Z)))
     (λ X : [C, C] hs,
      nat_trans_id
        (CoproductObject ([C, C] hs) (CPEndC (U Z) ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    rewrite (id_left EndC).
    rewrite (id_right EndC).
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    apply CoproductOfArrows_eq.
    + apply idpath.
    + unfold functor_fix_snd_arg_mor; simpl.
      unfold θ_target_mor; simpl.
      revert c.
      apply nat_trans_eq_pointwise.
      apply maponpaths.
      apply nat_trans_eq; try (exact hs).
      intro c.
      simpl.
      rewrite <- (nat_trans_ax α).
      rewrite functor_id.
      apply id_left.
Qed.

Definition aux_iso_2_inv (Z: Ptd): EndEndC ⟦
                           CoproductObject EndEndC
         (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
                    (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z)),

                       functor_composite (ℓ (U Z) )   (Const_plus_H (U Z)) ⟧.
  Proof.
  refine (tpair _ _ _).
  - intro X.
    exact (nat_trans_id ((@CoproductObject EndC (U Z) (θ_target H (X⊗Z)) (CPEndC _ _) ): functor C C)).
  - exact (aux_iso_2_inv_is_nat_trans Z).
Defined.

Definition θ'_Thm15 (Z: Ptd):= CoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _) (identity (constant_functor EndC _ (U Z): functor_precategory EndC EndC hsEndC)) (θ_in_first_arg Z).

Definition ρ_Thm15 (Z: Ptd)(f : Ptd ⟦ Z,  ptd_from_alg _ _ _ _ InitAlg ⟧):= @CoproductArrow EndC _ _  (CPEndC (U Z) (H (pr1 InitAlg))) (pr1 InitAlg) (#U f)(CoproductIn2 _ _ ;; (alg_map _ _ InitAlg)).

Definition SpecializedGMIt_Thm15 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) := SpecializedGMIt Z (pr1 InitAlg) (Const_plus_H (U Z)) (ρ_Thm15 Z f) (aux_iso_1 Z ;; θ'_Thm15 Z ;; aux_iso_2_inv Z).

Definition bracket_Thm15 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) :=
   pr1 (pr1 (SpecializedGMIt_Thm15 Z f)).

(* the property in h_eq in the Alg world has to be translated into the ALG setting *)
(* we prove the individual components for ease of compilation *)
Lemma bracket_Thm15_ok_part1 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
# U f =
 # (pr1 (ℓ (U Z)))
   (eta_from_alg _ _ _ _ (InitAlg));;
 bracket_Thm15 Z f.
Proof.
  apply nat_trans_eq; try (exact hs).
  intro c.
  assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))).
  assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (((aux_iso_1_inv Z):(_⟶_)) _);; m) h_eq); clear h_eq.
         simpl in h_eq'.
         assert (h_eq1' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (CoproductIn1 EndC (CPEndC _ _));; m) h_eq'); clear h_eq'.
         assert (h_eq1'_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h_eq1' c);
           clear h_eq1'.
(* match goal right in the beginning in contrast with earlier approach - suggestion by Benedikt *)
         match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.

  *      clear h_eq1'_inst.
         unfold coproduct_nat_trans_data; simpl.
         unfold coproduct_nat_trans_in1_data ; simpl.
         repeat rewrite <- assoc .
         apply CoproductIn1Commutes_right_in_ctx_dir.
         unfold λ_functor; simpl.
         rewrite id_left.
         apply CoproductIn1Commutes_right_in_ctx_dir.
         unfold ρ_functor; simpl.
         rewrite id_left.
         apply CoproductIn1Commutes_right_in_ctx_dir.
         rewrite (id_left EndC).
(*         rewrite (id_left EndC). *)
         rewrite id_left.
         apply CoproductIn1Commutes_right_in_ctx_dir.
         rewrite (id_left EndC).
         apply CoproductIn1Commutes_right_dir.
         apply idpath.
  *      rewrite <- h_eq1'_inst.
         clear h_eq1'_inst.

         apply CoproductIn1Commutes_left_in_ctx_dir.
         unfold λ_functor, nat_trans_id; simpl.
         rewrite id_left.
         repeat rewrite (id_left EndEndC).
         repeat rewrite (id_left EndC).
         unfold functor_fix_snd_arg_ob.
         repeat rewrite assoc.
         apply maponpaths.
         apply idpath.
Qed.   (* one may consider Admitted for speedup during development *)

(* produce some output to keep TRAVIS running *)
Check bracket_Thm15_ok_part1.

Lemma bracket_Thm15_ok_part2 (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
 (theta H) ((pr1 InitAlg) ⊗ Z);;
   # H (bracket_Thm15 Z f);;
   tau_from_alg  _ _ _ _ InitAlg =
   # (pr1 (ℓ (U Z)))
     (tau_from_alg  _ _ _ _  InitAlg);;
   bracket_Thm15 Z f.
Proof.
  apply nat_trans_eq; try (exact hs).
  intro c.
  assert (h_eq := pr2 (pr1 (SpecializedGMIt_Thm15 Z f))).
  assert (h_eq' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (((aux_iso_1_inv Z):(_⟶_)) _);; m) h_eq); clear h_eq.
 (*        simpl in h_eq'. (* until here same as in previous lemma *) *)

         assert (h_eq2' := maponpaths (fun m:EndC⟦_,pr1 InitAlg⟧ => (CoproductIn2 EndC (CPEndC _ _));; m) h_eq').
         clear h_eq'.
         assert (h_eq2'_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h_eq2' c).
         clear h_eq2'.
 (*        simpl in h_eq2'_inst. *)
         match goal with |[ H1 : _  = ?f |- _ = _   ] =>
         pathvia (f) end.
         + clear h_eq2'_inst.
 (*          unfold coproduct_nat_trans_data.
           unfold coproduct_nat_trans_in2_data.
*)
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold aux_iso_1; simpl.
           rewrite id_right.
           rewrite id_left.
           do 3 rewrite <- assoc.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold nat_trans_id; simpl. rewrite id_left.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold nat_trans_fix_snd_arg_data.
           apply CoproductIn2Commutes_right_in_double_ctx_dir.
           rewrite <- assoc.
           apply maponpaths.
           eapply pathscomp0. Focus 2. apply assoc.
           apply maponpaths.
           apply pathsinv0.
           apply CoproductIn2Commutes.

(* alternative with slightly less precise control:
           do 4 rewrite <- assoc.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           rewrite id_left.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           apply CoproductIn2Commutes_right_in_ctx_dir.
           unfold nat_trans_fix_snd_arg_data.
           rewrite id_left.
           apply CoproductIn2Commutes_right_in_double_ctx_dir.
           do 2 rewrite <- assoc.
           apply maponpaths.
           apply maponpaths.
           apply pathsinv0.
           apply CoproductIn2Commutes.
*)
         + rewrite <- h_eq2'_inst. clear h_eq2'_inst.
           apply CoproductIn2Commutes_left_in_ctx_dir.
           (* unfold Coproducts_functor_precat.
              unfold functor_precat_coproduct_cocone. *)
(*           simpl. *)
           (* unfold coproduct_nat_trans_in2_data. *)
           repeat rewrite id_left.
           apply assoc.
(*           repeat rewrite <- assoc.
           (* apply maponpaths.
              apply maponpaths. *)
           apply idpath. *)
Qed. (* Qed works fine but takes quite some time, hence Admitted for the purpose of development *)

(* produce some output to keep TRAVIS running *)
Check bracket_Thm15_ok_part2.

Lemma bracket_Thm15_ok (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
 bracket_property_parts _ hs CP H InitAlg f (bracket_Thm15 Z f).
Proof.
  split.
  + exact (bracket_Thm15_ok_part1 Z f).
  + exact (bracket_Thm15_ok_part2 Z f).
Qed.

Lemma bracket_Thm15_ok_cor (Z: Ptd)(f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧):
 bracket_property _ hs CP H InitAlg f (bracket_Thm15 Z f).
Proof.
  apply whole_from_parts.
  apply bracket_Thm15_ok.
Qed.

(* we will directly need the later lemma foo'
Lemma foo (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) :
 ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z) (pr1  InitAlg),
            pr1 InitAlg ⟧,
       bracket_property_parts _ hs CP H InitAlg f h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
      bracket_property_parts _ hs CP H InitAlg f h)
     (bracket_Thm15 Z f) (bracket_Thm15_ok Z f).
(*
   ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z) (pr1  InitAlg),
            pr1 InitAlg ⟧,
       # U f =
       # (pre_composition_functor_data C C C hs hs (U Z))
         (eta_from_alg _ _ _ _  InitAlg);; h
       × (theta H) ((pr1 InitAlg) ⊗ Z);; # H h;;
         tau_from_alg _ _ _ _  InitAlg =
         # (pre_composition_functor_data C C C hs hs (U Z))
           (tau_from_alg _ _ _ _  InitAlg);; h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
      # U f =
      # (pre_composition_functor_data C C C hs hs (U Z))
        (eta_from_alg _ _ _  _ InitAlg);; h
      × (theta H) ((pr1 InitAlg) ⊗ Z);; # H h;;
        tau_from_alg _ _ _ _  InitAlg =
        # (pre_composition_functor_data C C C hs hs (U Z))
          (tau_from_alg _ _ _ _  InitAlg);; h)
     (bracket_Thm15 Z f) (bracket_Thm15_ok Z f).
*)
Proof.
  intros [h' [h'_eq1 h'_eq2]].
    (* simpl in *. *)
    apply total2_paths_second_isaprop.
    + apply isofhleveltotal2.
      * apply isaset_nat_trans. exact hs.
      * intro Hyp. apply isaset_nat_trans. exact hs.
    + simpl.
      unfold bracket_Thm15.
      apply path_to_ctr.
      apply nat_trans_eq; try (exact hs).
      intro c; simpl.
      unfold coproduct_nat_trans_data.
      repeat rewrite (id_left EndC).
      rewrite id_right.
      repeat rewrite <- assoc.
      eapply pathscomp0.
Focus 2.
      eapply pathsinv0.
      apply postcompWithCoproductArrow.
      apply CoproductArrowUnique.
      * simpl.
        clear h'_eq2.
        rewrite (id_left C).
(*        unfold coproduct_nat_trans_in1_data; simpl. *)
        assert (h'_eq1_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h'_eq1 c);
          clear h'_eq1.
        simpl in h'_eq1_inst.
        unfold coproduct_nat_trans_in1_data in h'_eq1_inst; simpl in h'_eq1_inst.
        rewrite <- assoc in h'_eq1_inst.
        eapply pathscomp0.
          eapply pathsinv0.
          exact h'_eq1_inst.
        clear h'_eq1_inst.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_dir.
        apply idpath.
      * clear h'_eq1.
        (*simpl.
        unfold coproduct_nat_trans_in2_data; simpl. *)
        assert (h'_eq2_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h'_eq2 c);
          clear h'_eq2.
        simpl in h'_eq2_inst.
        unfold coproduct_nat_trans_in2_data in h'_eq2_inst; simpl in h'_eq2_inst.
        apply pathsinv0 in h'_eq2_inst.
        rewrite <- assoc in h'_eq2_inst.
        eapply pathscomp0.
          exact h'_eq2_inst. clear h'_eq2_inst.

        apply CoproductIn2Commutes_right_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_double_ctx_dir.
        unfold nat_trans_fix_snd_arg_data; simpl.
        do 2 rewrite <- assoc.
        apply maponpaths.
        rewrite <- assoc.
        apply maponpaths.
        apply pathsinv0.
        apply CoproductIn2Commutes.
Qed.
*)

Lemma foo' (Z : Ptd) (f : Ptd ⟦ Z, ptd_from_alg _ _ _ _  InitAlg ⟧) :
 ∀
   t : Σ
       h : [C, C] hs
           ⟦ functor_composite (U Z) (pr1  InitAlg),
            pr1 InitAlg ⟧,
       bracket_property _ hs CP H InitAlg f h,
   t =
   tpair
     (λ h : [C, C] hs
            ⟦ functor_composite (U Z) (pr1 InitAlg),
              pr1 InitAlg ⟧,
      bracket_property _ hs CP H InitAlg f h)
     (bracket_Thm15 Z f) (bracket_Thm15_ok_cor Z f).
Proof.
   intros [h' h'_eq].
    (* simpl in *. *)
    apply total2_paths_second_isaprop.
    + unfold bracket_property.
      apply isaset_nat_trans. exact hs.
    + simpl.
      apply parts_from_whole in h'_eq.
      destruct h'_eq as [h'_eq1 h'_eq2].
      unfold bracket_Thm15.
      apply path_to_ctr.
      apply nat_trans_eq; try (exact hs).
      intro c; simpl.
      unfold coproduct_nat_trans_data.
      repeat rewrite (id_left EndC).
      rewrite id_right.
      repeat rewrite <- assoc.
      eapply pathscomp0.
Focus 2.
      eapply pathsinv0.
      apply postcompWithCoproductArrow.
      apply CoproductArrowUnique.
      * simpl.
        clear h'_eq2.
        rewrite (id_left C).
(*        unfold coproduct_nat_trans_in1_data; simpl. *)
        assert (h'_eq1_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h'_eq1 c);
          clear h'_eq1.
        simpl in h'_eq1_inst.
        unfold coproduct_nat_trans_in1_data in h'_eq1_inst; simpl in h'_eq1_inst.
        rewrite <- assoc in h'_eq1_inst.
        eapply pathscomp0.
          eapply pathsinv0.
          exact h'_eq1_inst.
        clear h'_eq1_inst.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        apply CoproductIn1Commutes_right_dir.
        apply idpath.
      * clear h'_eq1.
        (*simpl.
        unfold coproduct_nat_trans_in2_data; simpl. *)
        assert (h'_eq2_inst := nat_trans_eq_pointwise _ _ _ _ _ _ h'_eq2 c);
          clear h'_eq2.
        simpl in h'_eq2_inst.
        unfold coproduct_nat_trans_in2_data in h'_eq2_inst; simpl in h'_eq2_inst.
        apply pathsinv0 in h'_eq2_inst.
        rewrite <- assoc in h'_eq2_inst.
        eapply pathscomp0.
          exact h'_eq2_inst. clear h'_eq2_inst.

        apply CoproductIn2Commutes_right_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_double_ctx_dir.
        unfold nat_trans_fix_snd_arg_data; simpl.
        do 2 rewrite <- assoc.
        apply maponpaths.
        rewrite <- assoc.
        apply maponpaths.
        apply pathsinv0.
        apply CoproductIn2Commutes.
Qed.

Definition bracket_for_InitAlg : bracket _ _ CP H (InitAlg).
Proof.
  intros Z f.
  refine (tpair _ _ _ ).
  - refine (tpair _ _ _ ).
    + exact (bracket_Thm15 Z f).
    + exact (bracket_Thm15_ok_cor Z f).
       (* B: better to prove the whole outside, and apply it here *)
     (* when the first components were not opaque, the following proof
        became extremely slow *)
  - apply foo'.
Defined.

(* produce some output to keep TRAVIS running *)
Check bracket_for_InitAlg.

Definition InitHSS : hss_precategory CP H.
Proof.
 (*
  red. (* FORBIDDEN, otherwise universe problem when checking the definition *)
  unfold hss_precategory; simpl.
*)
  exists (InitAlg).
  exact bracket_for_InitAlg.
Defined.

Definition Ghat : EndEndC := Const_plus_H (pr1 InitAlg).

Definition constant_nat_trans (C' D : precategory) (hsD : has_homsets D) (d d' : D) (m : d ⇒ d')
    : [C', D, hsD] ⟦constant_functor C' D d, constant_functor C' D d'⟧.
Proof.
  exists (fun _ => m).
  abstract (
    intros ? ? ? ;
    pathvia m ;
    [
    apply id_left |
    apply pathsinv0 ;
  apply id_right] ).
Defined.

Definition thetahat_0 (Z : Ptd) (f : Z ⇒ ptd_from_alg _ _ _ _ InitAlg):
EndEndC
⟦ CoproductObject EndEndC
    (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
       (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z)),
CoproductObject EndEndC
  (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (pr1 InitAlg))
             (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z)) ⟧ .
Proof.
  exact (CoproductOfArrows EndEndC (CPEndEndC _ _) (CPEndEndC _ _)
                           (constant_nat_trans _ _ hsEndC _ _ (#U f))
                           (θ_in_first_arg Z)).
Defined.

Definition iso1' (Z : Ptd) :  EndEndC ⟦ functor_composite Id_H
                                        (ℓ (U Z)),
 CoproductObject EndEndC
    (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (U Z))
               (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_source H) Z)) ⟧.
Proof.
  exact (aux_iso_1 Z).
Defined.

Lemma is_nat_trans_iso2' (Z : Ptd) :
   is_nat_trans
     (pr1 (CoproductObject EndEndC
        (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (pr1 InitAlg))
           (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z))))
     (functor_composite (ℓ (U Z)) Ghat)
     (λ X : [C, C] hs,
      nat_trans_id
        (CoproductObject ([C, C] hs)
           (CPEndC
              ((constant_functor ([C, C] hs) ([C, C] hs) (pr1 InitAlg)) X)
              ((θ_target H) (X ⊗ Z)))
         :functor C C)).
Proof.
  unfold is_nat_trans; simpl.
    intros X X' α.
    rewrite (id_left EndC).
    rewrite (id_right EndC).
    apply nat_trans_eq; try (exact hs).
    intro c; simpl.
    unfold coproduct_nat_trans_data; simpl.
    unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data; simpl.
    apply CoproductOfArrows_eq.
    + apply idpath.
    + unfold functor_fix_snd_arg_mor; simpl.
      unfold θ_target_mor; simpl.
      revert c.
      apply nat_trans_eq_pointwise.
      apply maponpaths.
      apply nat_trans_eq; try (exact hs).
      intro c.
      simpl.
      rewrite <- (nat_trans_ax α).
      rewrite functor_id.
      apply id_left.
Qed.

Definition iso2' (Z : Ptd) : EndEndC ⟦
  CoproductObject EndEndC
  (CPEndEndC (constant_functor ([C, C] hs) ([C, C] hs) (pr1 InitAlg))
             (functor_fix_snd_arg ([C, C] hs) Ptd ([C, C] hs) (θ_target H) Z)),
  functor_composite (ℓ (U Z) ) (Ghat) ⟧.
Proof.
    refine (tpair _ _ _).
  - intro X.
    exact (nat_trans_id ((@CoproductObject EndC _ (θ_target H (X⊗Z)) (CPEndC _ _) ): functor C C)).
  - exact (is_nat_trans_iso2' Z).
Defined.

Definition thetahat (Z : Ptd)  (f : Z ⇒ ptd_from_alg _ _ _ _ InitAlg)
           : EndEndC ⟦ functor_composite Id_H
                                        (ℓ (U Z)),
                     functor_composite (ℓ (U Z)) (Ghat) ⟧.
Proof.
  exact (iso1' Z ;; thetahat_0 Z f ;; iso2' Z).
Defined.

Require Import UniMath.RezkCompletion.opp_precat.
Require Import UniMath.RezkCompletion.yoneda.
Require Import UniMath.RezkCompletion.category_hset.

Local Notation "C '^op'" := (opp_precat C) (at level 3, format "C ^op").

Let Yon (X : EndC) : functor EndC^op HSET := yoneda_objects EndC hsEndC X.

Definition Phi_fusion (Z : Ptd) (X : EndC) (b : pr1 InitAlg ⇒ X) :
  functor_composite (functor_opp (ℓ (U Z))) (Yon (pr1 InitAlg))
   ⟶
  functor_composite (functor_opp (ℓ (U Z))) (Yon X) .
Proof.
  refine (tpair _ _ _ ).
  - intro Y.
    intro a.
    exact (a ;; b).
  - abstract (
    intros ? ? ? ; simpl ;
    apply funextsec ;
    intro ;
    unfold yoneda_objects_ob ; simpl ;
    unfold compose ;
    simpl ;
    apply nat_trans_eq ;
    [
      assumption
        |
      simpl ; intros ? ;
      apply pathsinv0, assoc ]).
Defined.

Lemma ishssMor_InitAlg (T' : hss CP H) :
  @ishssMor C hs CP H
        InitHSS T'
           (InitialArrow Alg IA (pr1 T') : algebra_mor EndC Id_H InitAlg T' ).
Proof.
  unfold ishssMor.
  unfold isbracketMor.
  intros Z f.
  set (β0 := InitialArrow Alg IA (pr1 T')).
  match goal with | [|- _ ;; ?b = _ ] => set (β := b) end.
  set ( rhohat := CoproductArrow EndC  (CPEndC _ _ )  β (tau_from_alg _ _ _ _ T')
                  :  pr1 Ghat T' ⇒ T').
  set (X:= SpecializedGMIt Z _ Ghat rhohat (thetahat Z f)).
  pathvia (pr1 (pr1 X)).
  - set (TT:= fusion_law _ _ _ IA _ hsEndC (pr1 InitAlg) T' _ (KanExt Z)).
    set (Psi := ψ_from_comps _ (Id_H) _ hsEndC _ (ℓ (U Z)) (Const_plus_H (U Z)) (ρ_Thm15 Z f)
                             (aux_iso_1 Z ;; θ'_Thm15 Z ;; aux_iso_2_inv Z) ).
    set (T2 := TT Psi).
    set (T3 := T2 (ℓ (U Z)) (KanExt Z)).
    set (Psi' := ψ_from_comps _ (Id_H) _ hsEndC _ (ℓ (U Z)) (Ghat) (rhohat)
                             (iso1' Z ;; thetahat_0 Z f ;; iso2' Z) ).
    set (T4 := T3 Psi').
    set (Φ := (Phi_fusion Z T' β)).
    set (T5 := T4 Φ).
    pathvia (Φ _ (fbracket InitHSS f)).
      apply idpath.
    eapply pathscomp0.
      Focus 2.
        eapply T5.
      (* hypothesis of fusion law *)
      apply funextsec. intro.
      simpl.
      unfold compose. simpl.
      apply nat_trans_eq. assumption.
      simpl.
      intro c.
      rewrite id_right.
      rewrite id_right.
      (* should be decomposed into two diagrams *)
      apply CoproductArrow_eq_cor.
      * (* first diagram *)
        clear TT T2 T3 T4 T5.
        do 5 rewrite <- assoc.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_left_in_ctx_dir.
        rewrite <- assoc.
        apply maponpaths.
        apply CoproductIn1Commutes_right_in_ctx_dir.
        simpl.
        rewrite id_left.
        apply CoproductIn1Commutes_right_dir.
        apply idpath.
      * (* a bit out of order what follows *)
        apply cancel_postcomposition.
        apply idpath.
      * (* second diagram *)
        clear TT T2 T3 T4 T5.
        do 5 rewrite <- assoc.
        apply CoproductIn2Commutes_left_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_ctx_dir.
        rewrite (id_left EndC).
        apply CoproductIn2Commutes_left_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_ctx_dir.
        simpl.
        unfold nat_trans_fix_snd_arg_data.
        repeat rewrite <- assoc.
        apply maponpaths.
        apply CoproductIn2Commutes_left_in_ctx_dir.
        apply CoproductIn2Commutes_right_in_ctx_dir.
        simpl.
        assert (H_nat_inst := functor_comp H _ _ _ t β).
        assert (H_nat_inst_c := nat_trans_eq_pointwise _ _ _ _ _ _ H_nat_inst c); clear H_nat_inst.
        match goal with |[ H1 : _  = ?f |- _ = _;; ?g ;; ?h  ] =>
         pathvia (f;;g;;h) end.
        + clear H_nat_inst_c.
          simpl.
          repeat rewrite <- assoc.
          apply maponpaths.
          apply CoproductIn2Commutes_left_in_ctx_dir.
          simpl.
          unfold coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
          assert (Hyp := τ_part_of_alg_mor _ hs CP _ _ _ (InitialArrow Alg IA (pr1 T'))).
          assert (Hyp_c := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
          simpl in Hyp_c.
          eapply pathscomp0.
            eapply pathsinv0.
            exact Hyp_c.
          clear Hyp_c.
          apply maponpaths.
          apply pathsinv0.
          apply CoproductIn2Commutes.
        + rewrite <- H_nat_inst_c.
          apply idpath.
  - apply pathsinv0.
    apply path_to_ctr.
    (* now a lot of serious verification work to be done *)
    apply nat_trans_eq; try (exact hs).
    intro c.
    simpl.
    rewrite id_right.
    (* look at type:
       match goal with | [ |- ?l = _ ] => let ty:= (type of l) in idtac ty end. *)
    apply CoproductArrow_eq_cor.
    + repeat rewrite <- assoc.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
      rewrite id_left.
      apply CoproductIn1Commutes_right_in_ctx_dir.

      simpl.
      repeat rewrite <- assoc.

      eapply pathscomp0.
Focus 2.
      apply maponpaths.
      apply CoproductIn1Commutes_right_in_ctx_dir.
      rewrite id_left.
      apply CoproductIn1Commutes_right_dir.
      apply idpath.

      do 2 rewrite assoc.
      eapply pathscomp0.
        apply cancel_postcomposition.
        assert (ptd_mor_commutes_inst := ptd_mor_commutes _ (ptd_from_alg_mor _ hs CP H β0) ((pr1 Z) c)).
        apply ptd_mor_commutes_inst.

      eapply pathscomp0.
        eapply pathsinv0.
        assert (fbracket_η_inst := fbracket_η T' (f;; ptd_from_alg_mor _ hs CP H β0)).
        assert (fbracket_η_inst_c := nat_trans_eq_pointwise _ _ _ _ _ _ fbracket_η_inst c); clear fbracket_η_inst.
        apply fbracket_η_inst_c.

      rewrite functor_comp.
      apply idpath.
    + (* now the difficult case *)
      repeat rewrite <- assoc.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      simpl.
      unfold coproduct_nat_trans_in1_data, coproduct_nat_trans_in2_data, coproduct_nat_trans_data.
      rewrite id_left.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      unfold nat_trans_fix_snd_arg_data.
      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.

      eapply pathscomp0.
Focus 2.
      apply maponpaths.
      apply CoproductIn2Commutes_right_in_ctx_dir.
      rewrite <- assoc.
      apply maponpaths.
      apply CoproductIn2Commutes_right_dir.
      apply idpath.

      do 2 rewrite assoc.
      eapply pathscomp0.
        apply cancel_postcomposition.
        eapply pathsinv0.
        assert (τ_part_of_alg_mor_inst := τ_part_of_alg_mor _ hs CP H _ _ β0).
        assert (τ_part_of_alg_mor_inst_Zc := nat_trans_eq_pointwise _ _ _ _ _ _  τ_part_of_alg_mor_inst ((pr1 Z) c)); clear τ_part_of_alg_mor_inst.
        apply τ_part_of_alg_mor_inst_Zc.

      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite <- assoc.
      eapply pathscomp0.
        apply maponpaths.
        rewrite assoc.
        eapply pathsinv0.
        assert (fbracket_τ_inst := fbracket_τ T' (f;; ptd_from_alg_mor _ hs CP H β0)).
        assert (fbracket_τ_inst_c := nat_trans_eq_pointwise _ _ _ _ _ _ fbracket_τ_inst c); clear fbracket_τ_inst.
        apply fbracket_τ_inst_c.

      simpl.
      unfold coproduct_nat_trans_in2_data.
      repeat rewrite assoc.
      apply cancel_postcomposition.
      apply cancel_postcomposition.
      assert (Hyp: ((# (pr1 (ℓ(U Z))) (# H β));; (theta H) ((alg_carrier _ _  T') ⊗ Z);; # H (fbracket T' (f;; ptd_from_alg_mor C hs CP H β0)) = θ (tpair (λ _ : functor C C, ptd_obj C) (pr1 (pr1 IA)) Z) ;; # H (# (pr1 (ℓ(U Z))) β ;; fbracket T' (f;; ptd_from_alg_mor C hs CP H β0)))).

Focus 2.
      assert (Hyp_c := nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c); clear Hyp.
      exact Hyp_c.

      clear c.
      rewrite (functor_comp H).
      rewrite assoc.
      apply cancel_postcomposition.
      fold θ.
      apply nat_trans_eq; try (exact hs).
      intro c.
      assert (θ_nat_1_pointwise_inst := θ_nat_1_pointwise _ hs H θ _ _ β Z c).
      eapply pathscomp0 ; [exact θ_nat_1_pointwise_inst | ].
      clear θ_nat_1_pointwise_inst.
      simpl.
      apply maponpaths.
      assert (Hyp: # H (β ∙∙ nat_trans_id (pr1 Z)) = # H (# (pr1 (ℓ(U Z))) β)).
      { apply maponpaths.
        apply nat_trans_eq; try (exact hs).
        intro c'.
        simpl.
        rewrite functor_id.
        apply id_right. }
      apply (nat_trans_eq_pointwise _ _ _ _ _ _ Hyp c).
Qed.

Definition hss_InitMor : ∀ T' : hss CP H, hssMor InitHSS T'.
Proof.
  intro T'.
  exists (InitialArrow Alg IA (pr1 T')).
  apply ishssMor_InitAlg.
Defined.

Lemma hss_InitMor_unique (T' : hss_precategory CP H):
  ∀ t : hss_precategory CP H ⟦ InitHSS, T' ⟧, t = hss_InitMor T'.
Proof.
  intro t.
  (* show lemma that says that two hss morphisms are equal if their underlying alg morphisms are *)
  apply (invmap (hssMor_eq1 _ _ _ _ _ _ _ _ )).
  set (T2:= pr2 IA).
  simpl in T2.
  set (T3 := T2 (pr1 T')).
  simpl.
  set (T4 := pr2 T3).
  simpl in T4.
  set (T5 := T4 (pr1 t)).
  apply T5.
Qed.

Lemma isInitial_InitHSS : isInitial (hss_precategory CP H) InitHSS.
Proof.
  intro T.
  exists (hss_InitMor T).
  apply hss_InitMor_unique.
Defined.

(*
  simpl.
  set (T' :=  (pr1 T)).
*)
(*
  assert (auxT' : ALG_from_Alg C hs CP H T' = pr1 T).
Focus 2.
 *)
(*
  set (β := InitialArrow _ IA T').
  (*set (β' := ALG_mor_from_Alg_mor _ hs CP _ β). *)
  refine (tpair _ _ _ ).
  - refine (tpair _ _ _ ).
    apply β.
    unfold ishssMor.
    unfold isbracketMor.
    intros Z f.
*)

(*

    + refine (tpair _ _ _ ).
      * apply β.
      * destruct β as [β βalg].
        assert (β_is_ptd := pr2 (pr1 β')).
        simpl in β_is_ptd.
        unfold is_ptd_mor in β_is_ptd. simpl in *.
        unfold is_ptd_mor. simpl.
        (* does not work: apply β_is_ptd.*)
        intro c.
        assert (β_is_ptd_inst := β_is_ptd c); clear β_is_ptd.
        eapply pathscomp0.
          exact  β_is_ptd_inst.
        clear β_is_ptd_inst.
        apply CoproductIn1Commutes.
 *)
(*
   + destruct β as [β βalg].
      simpl in *.
      unfold ishssMor.
      split.
      * assert (β_isALGMor := pr2 β').
        unfold isALGMor. simpl.
        unfold isALGMor in β_isALGMor. simpl in β_isALGMor.
        eapply pathscomp0. Focus 2. apply β_isALGMor.
        apply maponpaths.
        apply pathsinv0.
        eapply pathscomp0.
        apply (CoproductIn2Commutes EndC). apply idpath.
      * simpl.
        unfold isbracketMor. simpl.
        intros Z f.
(*        destruct β as [β βalg]; simpl in *.
        unfold isbracketMor. simpl.
        intros Z f.
*)
*)

        (* now define Ψ for fusion law *)

Lemma Ihss : Initial (hss_precategory CP H).
Proof.
  exists InitHSS.
  apply isInitial_InitHSS.
Defined.

End Precategory_Algebra.

(*

(** Define the precategory of Id+H-algebras.

    We could define this precategory before that of hss, and
    define hss as a sub-precategory of that of Id+H-algebras
    As a consequence, we would have faithfulness of the forgetful
    functor for free.
    Also, composition and identity would be inherited instead of
    having to be defined twice.

    On the other hand, the category of hss is the main object of
    investigation, so maybe it is better to give it more explicitly.
    Working with sub-precategories is a pain in the butt.

*)

Local Notation "'Alg_obj'" := (Alg H).

Definition Alg_mor (A B : Alg_obj) : UU
  := Σ f : Ptd ⟦A, B⟧, isAlgMor C hs H f.

(* explicit coercion not necessary, this works, too:
Definition Alg_mor' (A B : Alg_obj) : UU
  := Σ f : A ⇒ pr1 B, isAlgMor C hs H f.
*)

Coercion Ptd_mor_from_Alg_mor (A B : Alg_obj)(f : Alg_mor A B) : Ptd ⟦A, B⟧ := pr1 f.

Definition isAlgMor_Alg_mor (A B : Alg_obj)(f : Alg_mor A B) : isAlgMor _ _ _ f := pr2 f.

Definition Alg_mor_eq_weq (A B : Alg_obj) (f g : Alg_mor A B)
  : f = g ≃ #U f = #U g.
Proof.
  eapply weqcomp.
  - apply total2_paths_isaprop_equiv.
    intro h. apply isaprop_isAlgMor.
  - apply eq_ptd_mor.
    apply hs.
Defined.

Definition isAlgMor_id (A : Alg_obj) : isAlgMor C hs H (identity A : Ptd⟦A,A⟧).
Proof.
  unfold isAlgMor.
  rewrite functor_id.
  rewrite functor_id.
  rewrite id_left.
  set (H2 := id_right ([C,C,hs])).
  apply pathsinv0, H2.
Qed.

Definition AlgMor_id (A : Alg_obj) : Alg_mor A A := tpair _ _ (isAlgMor_id A).

Definition isAlgMor_comp (A B D : Alg_obj) (f : Alg_mor A B) (g : Alg_mor B D)
  : isAlgMor C hs H (f ;; g : Ptd⟦A, D⟧).
Proof.
  unfold isAlgMor.
  rewrite functor_comp.
  rewrite functor_comp.
  rewrite <- assoc.
  rewrite isAlgMor_Alg_mor.
  rewrite assoc.
  rewrite isAlgMor_Alg_mor.
  apply pathsinv0, assoc.
Qed.

Definition AlgMor_comp (A B D : Alg_obj) (f : Alg_mor A B) (g : Alg_mor B D) : Alg_mor A D
  := tpair _ _ (isAlgMor_comp A B D f g).

Definition Alg_precategory_ob_mor : precategory_ob_mor.
Proof.
  exists Alg_obj.
  exact (Alg_mor).
Defined.

Definition Alg_precategory_data : precategory_data.
Proof.
  exists Alg_precategory_ob_mor.
  split.
  - exact AlgMor_id.
  - exact AlgMor_comp.
Defined.

Lemma is_precategory_Alg : is_precategory Alg_precategory_data.
Proof.
  repeat split; intros.
  - apply (invmap (Alg_mor_eq_weq _ _ _ _ )).
    apply (id_left EndC).
  - apply (invmap (Alg_mor_eq_weq _ _ _ _ )).
    apply (id_right EndC).
  - apply (invmap (Alg_mor_eq_weq _ _ _ _ )).
    apply (assoc EndC).
Qed.

Definition precategory_Alg : precategory := tpair _ _ is_precategory_Alg.

Local Notation "'ALG'" := precategory_Alg.
 *)


(** * Colim -| Diag -| Lim **)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Generalizable All Variables.

Set Primitive Projections.
Set Universe Polymorphism.

Require Import
        COC.Base.Main
        COC.Limit.Main
        COC.Adj.Adjunction.

Program Definition Diagonal_functor (J C: Category)
  : C --> (C^J) :=
  [Functor by f :-> [X in J :=> f]
   with X :-> [ * in J |-> X in C ]].
Next Obligation.
  now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.

Program Definition Colimit_functor (J C: Category)(colim: forall (D: J --> C), Colimit D)
  : (C^J) --> C :=
  [Functor by (fun D D' S => colimit_univ (colim D) [Cocone by i :-> (colim D') i \o S i] )
   with `(colim D)].
Next Obligation.
  rewrite cat_comp_assoc, natrans_naturality.
  rewrite <- cat_comp_assoc.
  now rewrite (cocone_commute (IsCocone:=colim D')).
Qed.
Next Obligation.
  - rename X into D, Y into D'.
    intros S T Heq; simpl.
    apply (colimit_uniqueness (IsColimit:=colim D)(c:=[ Cocone by i :-> (colim D') i \o T i])(u:=colimit_univ (colim D) [ Cocone by i :-> (colim D') i \o S i])); simpl.
    intros j; simpl.
    rewrite <- (Heq j).
    now rewrite (colimit_universality (IsColimit:=colim D)[Cocone by i :-> colim D' i \o S i]).

  - rename X into D, Y into D', Z into D''.
    rename f into S, g into T.
    symmetry.
    apply (colimit_uniqueness (IsColimit:=colim D)(c:=[ Cocone by i :-> (colim D'') i \o T i \o S i])).
    simpl; intros i.
    rewrite cat_comp_assoc.
    rewrite (colimit_universality (IsColimit:=colim D)[ Cocone by i :-> (colim D') i \o S i]); simpl.
    rewrite <- cat_comp_assoc.
    rewrite (colimit_universality (IsColimit:=colim D')[ Cocone by i :-> (colim D'') i \o T i]); simpl.
    now rewrite cat_comp_assoc.
  - symmetry.
    rename X into D.
    apply (colimit_uniqueness (IsColimit:=colim D)(c:=[ Cocone by i :-> (colim D) i \o Id (D i)])); simpl.
    intros i.
    now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.

Program Definition colimit_diag_adjunction
        (J C: Category)
        (colim: forall (D: J --> C), Colimit D)
  : Colimit_functor colim -| Diagonal_functor J C :=
  [Adj by (fun D c => [f :-> [i in J :=> f \o colim D i]]),
          (fun D c => [g :-> colimit_univ (colim D) [Cocone by g to c]])].
Next Obligation.
  rename X into i, Y into j, f0 into u.
  rewrite cat_comp_assoc, (cocone_commute (IsCocone:=colim D)).
  now rewrite cat_comp_id_cod.
Qed.
Next Obligation.
  intros f g Heq i; simpl.
  now rewrite Heq.
Qed.
Next Obligation.
  rewrite (natrans_naturality (IsNatrans:=g)); simpl.
  now rewrite cat_comp_id_cod.
Qed.
Next Obligation.
  intros S T Heq; simpl.
  apply (colimit_uniqueness (IsColimit:=colim D)(c:=[Cocone by T to c])(u:=colimit_univ (colim D) [Cocone by S to c])); simpl.
  intros i.
  rewrite <- (Heq i).
  now rewrite (colimit_universality (IsColimit:=colim D) [Cocone by S to c]).
Qed.
Next Obligation.
  - symmetry.
    now apply (colimit_uniqueness (IsColimit:=colim c)(c:=[Cocone by i :-> f \o (colim c) i])); simpl.
  - now rewrite (colimit_universality (IsColimit:=colim c) [Cocone by g to d]).
  - rewrite !cat_comp_assoc.
    now rewrite (colimit_universality (IsColimit:=colim c')[Cocone by i :-> (colim c) i \o f i]).
Qed.

Program Definition Limit_functor (J C: Category)(lim: forall (D: J --> C), Limit D)
  : (C^J) --> C :=
  [Functor by (fun D D' S => limit_univ (lim D') [Cone by i :-> S i \o (lim D) i] )
   with `(lim D)].
Next Obligation.
  rewrite <- cat_comp_assoc, <- natrans_naturality.
  rewrite cat_comp_assoc.
  now rewrite (cone_commute (IsCone:=lim D)).
Qed.
Next Obligation.
  - rename X into D, Y into D'.
    intros S T Heq; simpl.
    apply (limit_uniqueness (IsLimit:=lim D')(c:=[ Cone by i :-> T i \o (lim D) i])(u:=limit_univ (lim D') [ Cone by i :-> S i \o (lim D) i])); simpl.
    intros j; simpl.
    rewrite <- (Heq j).
    now rewrite (limit_universality (IsLimit:=lim D')[Cone by i :-> S i \o lim D i]).
  - rename X into D, Y into D', Z into D''.
    rename f into S, g into T.
    symmetry.
    apply (limit_uniqueness (IsLimit:=lim D'')(c:=[ Cone by i :-> (T i \o S i) \o (lim D i)])).
    simpl; intros i.
    rewrite <- cat_comp_assoc.
    rewrite (limit_universality (IsLimit:=lim D'')[ Cone by i :-> T i \o (lim D') i]); simpl.
    rewrite cat_comp_assoc.
    rewrite (limit_universality (IsLimit:=lim D')[ Cone by i :-> S i \o (lim D) i]); simpl.
    now rewrite cat_comp_assoc.
  - symmetry.
    rename X into D.
    apply (limit_uniqueness (IsLimit:=lim D)(c:=[ Cone by i :-> Id (D i) \o (lim D) i])); simpl.
    intros i.
    now rewrite cat_comp_id_dom, cat_comp_id_cod.
Qed.

Program Definition diag_limit_adjunction
        (J C: Category)
        (lim: forall (D: J --> C), Limit D)
  : Diagonal_functor J C -| Limit_functor lim :=
  [Adj by (fun c D => [g :-> limit_univ (lim D) [Cone by g from c]]),
          (fun c D => [f :-> [i in J :=> lim D i \o f]])].
Next Obligation.
  rewrite <- (natrans_naturality (IsNatrans:=g)); simpl.
  now rewrite cat_comp_id_dom.
Qed.
Next Obligation.
  intros S T Heq; simpl.
  apply (limit_uniqueness (IsLimit:=lim D)(c:=[Cone by T from c])(u:=limit_univ (lim D) [Cone by S from c])); simpl.
  intros i.
  rewrite <- (Heq i).
  now rewrite (limit_universality (IsLimit:=lim D) [Cone by S from c]).
Qed.
Next Obligation.
  rename X into i, Y into j, f0 into u.
  rewrite <- cat_comp_assoc, (cone_commute (IsCone:=lim D)).
  now rewrite cat_comp_id_dom.
Qed.
Next Obligation.
  intros f g Heq i; simpl.
  now rewrite Heq.
Qed.
Next Obligation.
  - now rewrite (limit_universality (IsLimit:=lim d)[Cone by f from c]).
  - symmetry.
    now apply (limit_uniqueness (IsLimit:=lim d)(c:=[Cone by i :-> (lim d) i \o g])); simpl.
  - rename d into D, d' into D', g into S, h into T.
    symmetry.
    apply (limit_uniqueness (IsLimit:=lim D')(c:=[ Cone by X :-> S X \o T X \o f])); simpl.
    intros i.
    rewrite <- !cat_comp_assoc.
    apply cat_comp_proper; try now idtac.
    rewrite (limit_universality (IsLimit:=lim D')[ Cone by i :-> S i \o (lim D) i]); simpl.
    rewrite cat_comp_assoc.
    now rewrite (limit_universality (IsLimit:=lim D) [ Cone by T from c]); simpl.
Qed.


Require Import List.
Import ListNotations.
Require Import Sumbool.

Ltac break_let :=
  match goal with
    | [ H : context [ (let (_,_) := ?X in _) ] |- _ ] => destruct X eqn:?
    | [ |- context [ (let (_,_) := ?X in _) ] ] => destruct X eqn:?
  end.

Ltac find_injection :=
  match goal with
    | [ H : ?X _ _ = ?X _ _ |- _ ] => injection H; intros; subst
  end.

Ltac break_and :=
  repeat match goal with
           | [H : _ /\ _ |- _ ] => destruct H
         end.

Ltac break_if :=
  match goal with
    | [ |- context [ if ?X then _ else _ ] ] =>
      match type of X with
        | sumbool _ _ => destruct X
        | _ => destruct X eqn:?
      end
  end.

Definition update2 {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (f : A -> A -> B) (x y : A) (v : B) :=
  fun x' y' => if sumbool_and _ _ _ _ (A_eq_dec x x') (A_eq_dec y y') then v else f x' y'.

Fixpoint collate {A B : Type} (A_eq_dec : forall x y : A, {x = y} + {x <> y}) (from : A) (f : A -> A -> list B) (ms : list (A * B)) :=
  match ms with
   | [] => f
   | (to, m) :: ms' => collate A_eq_dec from (update2 A_eq_dec f from to (f from to ++ [m])) ms'
  end.

Section Update2.
  Variables A B : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Lemma collate_f_eq :
    forall (f : A -> A -> list B) g h n n' l,
      f n n' = g n n' ->
      collate A_eq_dec h f l n n' = collate A_eq_dec h g l n n'.
  Proof using.
    intros f g h n n' l.
    generalize f g; clear f g.
    induction l; auto.
    intros.
    simpl in *.
    break_let.
    destruct a.
    find_injection.
    set (f' := update2 _ _ _ _ _).
    set (g' := update2 _ _ _ _ _).
    rewrite (IHl f' g'); auto.
    unfold f', g', update2.
    break_if; auto.
    break_and.
    subst.
    rewrite H.
    trivial.
  Qed.
End Update2.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2020 Guillaume Melquiond

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

From Coq Require Import Reals ssreflect.

Require Import Rbar Hierarchy RInt Lim_seq Continuity Derive Rcomplements RInt_analysis.

(** This file describes improper integrals, such as integrals with an
infinity endpoint or integrals of a function with a singularity. A few
properties are given: Chasles, operations, composition, derivation.*)

Open Scope R_scope.

(** * Improper Riemann integral *)

Section is_RInt_gen.

Context {V : NormedModule R_AbsRing}.

Definition is_RInt_gen (f : R -> V) (Fa Fb : (R -> Prop) -> Prop) (l : V) :=
  filterlimi (fun ab => is_RInt f (fst ab) (snd ab)) (filter_prod Fa Fb) (locally l).
Definition ex_RInt_gen (f : R -> V) (Fa Fb : (R -> Prop) -> Prop) :=
  exists l : V, is_RInt_gen f Fa Fb l.

Definition is_RInt_gen_at_point f a b l :
  is_RInt_gen f (at_point a) (at_point b) l
    <-> is_RInt f a b l.
Proof.
split.
- intros H P HP.
  apply locally_locally in HP.
  specialize (H _ HP).
  destruct H as [Q R Qa Rb H].
  destruct (H a b Qa Rb) as [y [Hy1 Hy2]].
  now apply Hy1.
- intros Hl P HP.
  exists (fun x => x = a) (fun x => x = b) ; try easy.
  intros x y -> ->.
  exists l.
  apply (conj Hl).
  exact: locally_singleton.
Qed.

(** * Basic properties of integrals *)

Lemma is_RInt_gen_ext {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) (l : V) :
  filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab)
                               -> f x = g x) ->
  is_RInt_gen f Fa Fb l -> is_RInt_gen g Fa Fb l.
Proof.
intros Heq.
apply: filterlimi_ext_loc.
apply: filter_imp Heq.
intros [a b] Heq y.
split.
now apply is_RInt_ext.
apply is_RInt_ext.
intros x Hx.
now apply sym_eq, Heq.
Qed.

Lemma ex_RInt_gen_ext {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) :
  filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab)
                               -> f x = g x) ->
  ex_RInt_gen f Fa Fb -> ex_RInt_gen g Fa Fb.
Proof.
move => Heq.
case => I HI.
exists I.
exact: (is_RInt_gen_ext f g).
Qed.

Lemma ex_RInt_gen_ext_eq {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) :
  (forall x, f x = g x) -> ex_RInt_gen f Fa Fb -> ex_RInt_gen g Fa Fb.
Proof.
move => Heq.
apply: ex_RInt_gen_ext.
exact: filter_forall => bds x _.
Qed.

Lemma is_RInt_gen_point (f : R -> V) (a : R) :
  is_RInt_gen f (at_point a) (at_point a) zero.
Proof.
  apply is_RInt_gen_at_point.
  exact: is_RInt_point.
Qed.

Lemma is_RInt_gen_swap {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (l : V) :
  is_RInt_gen f Fb Fa l -> is_RInt_gen f Fa Fb (opp l).
Proof.
intros Hf P HP.
specialize (Hf (fun y => P (opp y))).
destruct Hf as [Q R HQ HR H].
  exact: filterlim_opp.
apply: Filter_prod HR HQ _ => a b Ha Hb.
specialize (H b a Hb Ha).
destruct H as [y [Hy1 Hy2]].
exists (opp y).
split.
exact: is_RInt_swap.
exact Hy2.
Qed.

Lemma is_RInt_gen_Chasles {Fa Fc : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFc : Filter Fc}
  (f : R -> V) (b : R) (l1 l2 : V) :
  is_RInt_gen f Fa (at_point b) l1 -> is_RInt_gen f (at_point b) Fc l2
  -> is_RInt_gen f Fa Fc (plus l1 l2).
Proof.
intros Hab Hbc P HP.
specialize (filterlim_plus _ _ P HP).
intros [Q R HQ HR H].
specialize (Hab Q HQ).
specialize (Hbc R HR).
destruct Hab as [Qa Ra HQa HRa Hab].
destruct Hbc as [Qc Rc HQc HRc Hbc].
apply: Filter_prod HQa HRc _.
intros a c Ha Hc.
specialize (Hab _ _ Ha HRa).
specialize (Hbc _ _ HQc Hc).
destruct Hab as [ya [Hya1 Hya2]].
destruct Hbc as [yc [Hyc1 Hyc2]].
exists (plus ya yc).
split.
apply: is_RInt_Chasles Hya1 Hyc1.
now apply H.
Qed.

Lemma ex_RInt_gen_Chasles :
  forall {Fa Fc : (R -> Prop) -> Prop},
  forall {FFa : Filter Fa} {FFc : Filter Fc},
  forall (f : R -> V) (b : R),
  ex_RInt_gen f Fa (at_point b) ->
  ex_RInt_gen f (at_point b) Fc ->
  ex_RInt_gen f Fa Fc.
Proof.
intros Fa Fc FFa FFc f b [Iab Hab] [Ibc Hbc].
exists (plus Iab Ibc).
now apply is_RInt_gen_Chasles with b.
Qed.

(** * Composition *)

(*
Lemma is_RInt_gen_comp_opp {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (l : V) :
  is_RInt_gen f (filtermap opp Fa) (filtermap opp Fb) l ->
  is_RInt_gen (fun y => opp (f (- y))) Fa Fb l.
Proof.
intros H.
apply: filterlimi_ext.
unfold is_RInt_gen.
apply: filterlimi_comp_2.
apply filterlim_fst.
apply filterlim_snd.
SearchAbout fst filter_prod.

  case => If [Hf Hl].
  exists (fun x => If (opp x)) ; split.
  case: Hf => P Q ;
  unfold filtermap => Pa Qb H.
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply is_RInt_comp_opp, H.
  eapply filterlim_comp, Hl.
  intros P [Q1 Q2 Q1a Q2b H].
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply H.
Qed.

Lemma is_RInt_gen_comp_lin {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (u v : R) (l : V) :
  is_RInt_gen f (filtermap (fun a => u * a + v) Fa) (filtermap (fun b => u * b + v) Fb) l
    -> is_RInt_gen (fun y => scal u (f (u * y + v))) Fa Fb l.
Proof.
  case => If [Hf Hl].
  exists (fun x => If (plus (scal u x) (v,v))) ; split.
  case: Hf => P Q ;
  unfold filtermap => Pa Qb H.
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply is_RInt_comp_lin, H.
  eapply filterlim_comp, Hl.
  intros P [Q1 Q2 Q1a Q2b H].
  eexists ; try eassumption.
  move => /= a b Ha Hb.
  by apply H.
Qed.
*)

(** * Operations *)

Lemma is_RInt_gen_scal {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (k : R) (l : V) :
  is_RInt_gen f Fa Fb l ->
  is_RInt_gen (fun y => scal k (f y)) Fa Fb (scal k l).
Proof.
intros H P HP.
move /filterlim_scal_r in HP.
specialize (H _ HP).
unfold filtermapi in H |- *.
apply: filter_imp H.
move => [a b] /= [y [Hy1 Hy2]].
exists (scal k y).
apply: conj Hy2.
exact: is_RInt_scal.
Qed.

Lemma is_RInt_gen_opp {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f : R -> V) (l : V) :
  is_RInt_gen f Fa Fb l ->
  is_RInt_gen (fun y => opp (f y)) Fa Fb (opp l).
Proof.
intros H P HP.
move /filterlim_opp in HP.
specialize (H _ HP).
unfold filtermapi in H |- *.
apply: filter_imp H.
move => [a b] /= [y [Hy1 Hy2]].
exists (opp y).
apply: conj Hy2.
exact: is_RInt_opp.
Qed.

Lemma is_RInt_gen_plus {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) (lf lg : V) :
  is_RInt_gen f Fa Fb lf ->
  is_RInt_gen g Fa Fb lg ->
  is_RInt_gen (fun y => plus (f y) (g y)) Fa Fb (plus lf lg).
Proof.
intros Hf Hg P HP.
move /filterlim_plus in HP.
destruct HP as [Q R HQ HR H].
specialize (Hf _ HQ).
specialize (Hg _ HR).
unfold filtermapi in Hf, Hg |- *.
apply: filter_imp (filter_and _ _ Hf Hg).
move => [a b] /= [[If [HIf1 HIf2]] [Ig [HIg1 HIg2]]].
exists (plus If Ig).
apply: conj (H _ _ HIf2 HIg2).
exact: is_RInt_plus.
Qed.

Lemma is_RInt_gen_minus {Fa Fb : (R -> Prop) -> Prop}
  {FFa : Filter Fa} {FFb : Filter Fb} (f g : R -> V) (lf lg : V) :
  is_RInt_gen f Fa Fb lf ->
  is_RInt_gen g Fa Fb lg ->
  is_RInt_gen (fun y => minus (f y) (g y)) Fa Fb (minus lf lg).
Proof.
intros Hf Hg.
apply: is_RInt_gen_plus Hf _.
exact: is_RInt_gen_opp.
Qed.

End is_RInt_gen.

Section RInt_gen.

Context {V : CompleteNormedModule R_AbsRing}.

Definition RInt_gen (f : R -> V) (a b : (R -> Prop) -> Prop) :=
  iota (is_RInt_gen f a b).

Lemma is_RInt_gen_unique {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter' Fa} {FFb : ProperFilter' Fb} (f : R -> V) (l : V) :
  is_RInt_gen f Fa Fb l -> RInt_gen f Fa Fb = l.
Proof.
apply iota_filterlimi_locally.
apply filter_forall.
intros [a b] y1 u2 H1 H2.
rewrite -(is_RInt_unique _ _ _ _ H1).
now apply is_RInt_unique.
Qed.

Lemma RInt_gen_correct {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter' Fa} {FFb : ProperFilter' Fb} (f : R -> V) :
  ex_RInt_gen f Fa Fb -> is_RInt_gen f Fa Fb (RInt_gen f Fa Fb).
Proof.
intros [If HIf].
erewrite is_RInt_gen_unique ; exact HIf.
Qed.

Lemma RInt_gen_norm {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f : R -> V) (g : R -> R) (lf : V) (lg : R) :
  filter_prod Fa Fb (fun ab => fst ab <= snd ab) ->
  filter_prod Fa Fb (fun ab => forall x, fst ab <= x <= snd ab -> norm (f x) <= g x) ->
  is_RInt_gen f Fa Fb lf -> is_RInt_gen g Fa Fb lg ->
  norm lf <= lg.
Proof.
intros Hab Hle Hf Hg.
apply (filterlim_le (F := filter_prod Fa Fb) (fun ab => norm (RInt f (fst ab) (snd ab))) (fun ab => RInt g (fst ab) (snd ab)) (norm lf) lg).
- specialize (Hf _ (locally_ball lf (mkposreal _ Rlt_0_1))).
  specialize (Hg _ (locally_ball lg (mkposreal _ Rlt_0_1))).
  unfold filtermapi in Hf, Hg.
  apply: filter_imp (filter_and _ _ (filter_and  _ _ Hf Hg) (filter_and _ _ Hab Hle)) => {Hf Hg Hab Hle}.
  move => [a b] /= [[[If [Hf1 Hf2]] [Ig [Hg1 Hg2]]] [H H']].
  apply: norm_RInt_le H H' _ _.
  apply: RInt_correct.
  now exists If.
  apply: RInt_correct.
  now exists Ig.
- eapply filterlim_comp, filterlim_norm.
  intros P HP.
  specialize (Hf P HP).
  unfold filtermapi, filtermap in Hf |- *.
  apply: filter_imp Hf.
  move => [a b] /= [y [Hy1 Hy2]].
  now rewrite (is_RInt_unique _ a b y Hy1).
- intros P HP.
  specialize (Hg P HP).
  unfold filtermapi, filtermap in Hg |- *.
  apply: filter_imp Hg.
  move => [a b] /= [y [Hy1 Hy2]].
  now rewrite (is_RInt_unique _ a b y Hy1).
Qed.

Lemma RInt_gen_ext {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f g : R -> V) :
  filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab)
                               -> f x = g x) ->
  ex_RInt_gen f Fa Fb -> RInt_gen f Fa Fb = RInt_gen g Fa Fb.
Proof.
move => Heq [I HI].
rewrite (is_RInt_gen_unique f I HI); symmetry.
apply is_RInt_gen_unique. (* 'apply:' does not work *)
by apply: is_RInt_gen_ext; first exact: Heq.
Qed.

Lemma RInt_gen_ext_eq {Fa Fb : (R -> Prop) -> Prop}
  {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f g : R -> V):
  (forall x, f x = g x) ->
  ex_RInt_gen f Fa Fb -> RInt_gen f Fa Fb = RInt_gen g Fa Fb.
Proof.
move => Heq.
apply: (RInt_gen_ext f g).
exact: filter_forall => bnds x _.
Qed.

Lemma RInt_gen_Chasles :
  forall {Fa Fc : (R -> Prop) -> Prop},
  forall {FFa : ProperFilter' Fa} {FFc : ProperFilter' Fc},
  forall (f : R -> V) (b : R),
  ex_RInt_gen f Fa (at_point b) ->
  ex_RInt_gen f (at_point b) Fc ->
  plus (RInt_gen f Fa (at_point b)) (RInt_gen f (at_point b) Fc) = RInt_gen f Fa Fc.
Proof.
intros Fa Fc FFa FFc f b Hab Hbc.
apply eq_sym, is_RInt_gen_unique.
apply: is_RInt_gen_Chasles.
now apply RInt_gen_correct.
now apply RInt_gen_correct.
Qed.

End RInt_gen.

Lemma is_RInt_gen_Derive {Fa Fb : (R -> Prop) -> Prop} {FFa : Filter Fa} {FFb : Filter Fb}
  (f : R -> R) (la lb : R) :
  filter_prod Fa Fb
    (fun ab => forall x : R, Rmin (fst ab) (snd ab) <= x <= Rmax (fst ab) (snd ab) -> ex_derive f x)
  -> filter_prod Fa Fb
    (fun ab => forall x : R, Rmin (fst ab) (snd ab) <= x <= Rmax (fst ab) (snd ab) -> continuous (Derive f) x)
  -> filterlim f Fa (locally la) -> filterlim f Fb (locally lb)
  -> is_RInt_gen (Derive f) Fa Fb (lb - la).
Proof.
intros Df Cf Lfa Lfb P HP.
assert (HP': filter_prod Fa Fb (fun ab => P (f (snd ab) - f (fst ab)))).
  unfold Rminus.
  eapply filterlim_comp_2.
  eapply filterlim_comp, Lfb.
  by apply filterlim_snd.
  eapply filterlim_comp, @filterlim_opp.
  eapply filterlim_comp, Lfa.
  by apply filterlim_fst.
  exact: (filterlim_plus lb (- la)).
  exact HP.
apply: filter_imp (filter_and _ _ (filter_and _ _ Df Cf) HP').
move => [a b] /= {Df Cf HP HP'} [[Df Cf] HP].
eexists.
apply: conj HP.
apply: is_RInt_derive => x Hx.
now apply Derive_correct, Df.
exact: Cf.
Qed.

Section Complements_RInt_gen.

Context {V : CompleteNormedModule R_AbsRing}.

Lemma ex_RInt_gen_at_point f a b : @ex_RInt_gen V f (at_point a) (at_point b) <-> ex_RInt f a b.
Proof.
split;  case => I.
  rewrite is_RInt_gen_at_point => HI.
  by exists I.
rewrite -is_RInt_gen_at_point => HI.
  by exists I.
Qed.

Lemma RInt_gen_at_point f a b :
  ex_RInt f a b -> @RInt_gen V f (at_point a) (at_point b) = RInt f a b.
Proof.
move => Hfint.
apply is_RInt_gen_unique.
apply is_RInt_gen_at_point.
exact: RInt_correct.
Qed.

End Complements_RInt_gen.


(* This program 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 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(* Notation management revised in December 2002 *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*  Absz.v                                                                  *)
(*                                                                          *)
(*  Definition of the absolute value on integers                            *)
(*                                                                          *)
(*                                                                          *)
(*  Samuel Boutin                                                           *)
(*  Coq V5.10                                                               *)
(*  June  1995                                                              *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                               Absz.v                                     *)
(****************************************************************************)

Require Import quotient.
Require Import Arith.

Section AbsZ.

Require Import integer.

Lemma ABSZ : forall z : Z, Z.

intro z.
elim (Constructive_Z_partition z).
simple induction 1.
intro.
exact (- z)%INT.
intro.
exact z.
intro.
exact z.
Defined.

(* On a construit le terme:

ABSZ_O < Print ABSZ.
ABSZ =
[z:Z]
 (sumor_rec {(leZ z |((O,(S O)))|)}+{z=|((O,O))|} (leZ |(((S O),O))| z)
   [_:({(leZ z |((O,(S O)))|)}+{z=|((O,O))|})+{(leZ |(((S O),O))| z)}]Z
   [y:{(leZ z |((O,(S O)))|)}+{z=|((O,O))|}]
    (sumbool_rec (leZ z |((O,(S O)))|) z=|((O,O))|
      [_:{(leZ z |((O,(S O)))|)}+{z=|((O,O))|}]Z
      [_:(leZ z |((O,(S O)))|)](unary_minus z) [_:z=|((O,O))|]z y)
   [_:(leZ |(((S O),O))| z)]z (Constructive_Z_partition z))
     : Z->Z

Rappel:

( Syntax sumbool "{_}+{_}". )
Inductive sumbool [A,B:Prop] : Set
    := left  : A -> ({A}+{B})
     | right : B -> ({A}+{B}).

*)

Open Scope INT_scope.

Lemma ABSZ_neg : forall z : Z, z <= - 1 -> ABSZ z = - z.

intros.
elim (z_lt_O z H).
intros.
unfold ABSZ in |- *.
rewrite H0; simpl in |- *.
auto with arith.
Qed.

Lemma ABSZ_O : forall z : Z, z = 0 -> ABSZ z = z.

intros.
elim (z_eq_O z H).
intros.
unfold ABSZ in |- *.
rewrite H0; simpl in |- *.
auto with arith.
Qed.

Lemma ABSZ_pos : forall z : Z, 1 <= z -> ABSZ z = z.

intros.
elim (O_lt_z z H).
intros.
unfold ABSZ in |- *.
rewrite H0; simpl in |- *.
auto with arith.
Qed.

Opaque ABSZ.

End AbsZ.


(* This file formalises some basic facts about coinductively defined equality == (bisimulation). *)

Require Import defs.
Require Import tactics.

(************************************************************************************************)

Definition peek (t : term) :=
  match t with
  | bot => bot
  | var n => var n
  | app x y => app x y
  | abs x => abs x
  end.

Lemma lem_peek_eq : forall t, t = peek t.
Proof.
  unfold peek; sauto.
Qed.

Lemma lem_peek_eq_match :
  forall t, match t with
            | bot => bot
            | var n => var n
            | app x y => app x y
            | abs x => abs x
            end = t.
Proof.
  sauto.
Qed.

Ltac peek_on t :=
  replace t with (peek t); [ unfold peek; simpl; rewrite lem_peek_eq_match |
                             rewrite <- lem_peek_eq; reflexivity ].
Ltac peek_at n :=
  rewrite lem_peek_eq at n; unfold peek; simpl; rewrite lem_peek_eq_match.

Ltac peek_tac := intros; rewrite lem_peek_eq at 1; unfold peek; sauto.

Tactic Notation "peek" constr(t) := peek_on t.
Tactic Notation "peek" "at" integer(n) := peek_at n.

Lemma lem_shift_simpl_bot : forall d c, shift d c bot = bot.
Proof.
  peek_tac.
Qed.

Lemma lem_shift_simpl_var : forall d c n, shift d c (var n) = var (if c <=? n then n + d else n).
Proof.
  peek_tac.
Qed.

Lemma lem_shift_simpl_app : forall d c t1 t2, shift d c (app t1 t2) = app (shift d c t1) (shift d c t2).
Proof.
  peek_tac.
Qed.

Lemma lem_shift_simpl_abs : forall d c t, shift d c (abs t) = abs (shift d (c+1) t).
Proof.
  peek_tac.
Qed.

Hint Rewrite lem_shift_simpl_bot lem_shift_simpl_var lem_shift_simpl_app lem_shift_simpl_abs : shints.

Lemma lem_subst_simpl_bot : forall n x, subst n x bot = bot.
Proof.
  peek_tac.
Qed.

Lemma lem_subst_simpl_var :
  forall n s m, subst n s (var m) =
                if n <? m then var (m - 1) else if n =? m then shift n 0 s else var m.
Proof.
  peek_tac.
Qed.

Lemma lem_subst_simpl_app : forall n x t1 t2, subst n x (app t1 t2) = app (subst n x t1) (subst n x t2).
Proof.
  peek_tac.
Qed.

Lemma lem_subst_simpl_abs : forall n x t, subst n x (abs t) = abs (subst (n + 1) x t).
Proof.
  peek_tac.
Qed.

Hint Rewrite lem_subst_simpl_bot lem_subst_simpl_var lem_subst_simpl_app lem_subst_simpl_abs : shints.

(************************************************************************************************)

Lemma lem_par_clos_refl : forall R x y, x == y -> par_clos R x y.
Proof.
  coinduction.
Qed.

Lemma lem_par_clos_refl_0 : forall R, reflexive term (par_clos R).
Proof.
  coinduction on 1.
Qed.

Lemma lem_par_clos_sym : forall R, symmetric term R -> symmetric term (par_clos R).
Proof.
  coinduction.
Qed.

Lemma lem_term_eq_refl : reflexive term term_eq.
Proof.
  apply lem_par_clos_refl_0.
Qed.

Lemma lem_term_eq_sym : symmetric term term_eq.
Proof.
  assert (symmetric term (fun _ _ => False)) by scrush.
  pose lem_par_clos_sym; scrush.
Qed.

Lemma lem_term_eq_trans : transitive term term_eq.
Proof.
  coinduction.
Qed.

Lemma lem_term_eq_app : forall x y x' y', x == x' -> y == y' -> app x y == app x' y'.
Proof.
  coinduction.
Qed.

Lemma lem_term_eq_abs : forall x y, x == y -> abs x == abs y.
Proof.
  coinduction.
Qed.

Ltac pose_term_eq := pose proof lem_term_eq_app; pose proof lem_term_eq_abs;
                     pose proof lem_term_eq_refl; pose proof lem_term_eq_sym; pose proof lem_term_eq_trans;
                     autounfold with shints in *.

Add Parametric Relation : term term_eq
    reflexivity proved by (lem_term_eq_refl)
    symmetry proved by (lem_term_eq_sym)
    transitivity proved by (lem_term_eq_trans)
as term_eq_rel.

Add Parametric Morphism : app with
    signature term_eq ==> term_eq ==> term_eq as app_mor.
Proof.
  eauto using lem_term_eq_app.
Qed.

Add Parametric Morphism : abs with
    signature term_eq ==> term_eq as abs_mor.
Proof.
  eauto using lem_term_eq_abs.
Qed.

Add Parametric Morphism : beta_redex with
    signature term_eq ==> term_eq ==> iff as beta_redex_mor.
Proof.
  pose_term_eq; sauto; eapply beta_redex_c; eauto.
Qed.

Lemma lem_beta_redex_morphism : morphism beta_redex.
Proof.
  unfold morphism; intros.
  rewrite <- H0.
  rewrite <- H1.
  auto.
Qed.

Lemma lem_shift_mor : forall d c t t', t == t' -> shift d c t == shift d c t'.
Proof.
  coinduction.
Qed.

Lemma lem_subst_mor_0 : forall n t s s', s == s' -> t[n := s] == t[n := s'].
Proof.
  pose lem_shift_mor; coinduction on 1.
Qed.

Lemma lem_subst_mor : forall n t s t' s', t == t' -> s == s' -> t[n := s] == t'[n := s'].
Proof.
  coinduction CH.
  clear CH; intro; apply lem_subst_mor_0; auto.
Qed.

Add Parametric Morphism (n m : nat) : (shift n m) with
    signature term_eq ==> term_eq as shift_mor.
Proof.
  eauto using lem_shift_mor.
Qed.

Add Parametric Morphism (n : nat) : (subst n) with
    signature term_eq ==> term_eq ==> term_eq as subst_mor.
Proof.
  eauto using lem_subst_mor.
Qed.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Integers                                                                *
**************************************************************************)

Set Implicit Arguments.
Require Export Coq.ZArith.ZArith.
From TLC Require Import LibTactics LibLogic LibReflect LibRelation.
Export LibTacticsCompatibility.
From TLC Require Export LibNat.

(* --LATER: rename [plus] to [add] everywhere? *)

(* ********************************************************************** *)
(** * Parsing of integers and operations *)

(* ---------------------------------------------------------------------- *)
(** ** Notation for type and operation *)

(** Define [int] as an alias for [Z], the type of integers from Coq's stdlib.
    Create a scope called [Int_scope] for notation on integers. *)

Notation "'int'" := Z : Int_scope.

Infix "+" := Zplus : Int_scope.
Notation "- x" := (Zopp x) : Int_scope.
Infix "-" := Zminus : Int_scope.
Infix "*" := Zmult : Int_scope.

Bind Scope Int_scope with Z.
Delimit Scope Int_scope with I.
Open Scope Int_scope.

(* ---------------------------------------------------------------------- *)
(** ** Inhabited type *)

Instance Inhab_int : Inhab int.
Proof using. intros. apply (Inhab_of_val 0%Z). Qed.

(* ---------------------------------------------------------------------- *)
(** ** Coercion from nat *)

(** Remark: we cannot simply use the coercion:
      Coercion Z_of_nat : nat >-> Z.
   because otherwise when we try to make the coercion opaque using:
      Opaque Z_of_nat.
   the omega fails to work.
   Thus, we introduce an alias, called [nat_to_Z] for [Z_of_nat],
   and we register [nat_to_Z] as coercion.
*)

Definition nat_to_Z := Z_of_nat.

Lemma nat_to_Z_eq_Z_of_nat : nat_to_Z = Z_of_nat.
Proof using. reflexivity. Qed.

Global Opaque nat_to_Z.

Coercion nat_to_Z : nat >-> Z.

(* --TODO: check this coercion is actually the one in use *)

(* ---------------------------------------------------------------------- *)
(** ** Order relation *)

(** The comparison operators on integers are those from [LibOrder],
    not the ones from Coq's [ZArith]. *)

Open Scope Z_scope.
Open Scope comp_scope.

(** The typeclass [le] on type [int] is bound to [Zle], from Coq's
    standard library *)

Instance le_int_inst : Le int := Build_Le Zle.

(* ********************************************************************** *)
(** * Conversion to natural numbers, for tactic programming *)

(** These tactics are helpful to convert a number passed to a Ltac tactic
    into a [nat], regardless of whether it is a [nat] or an [int]. *)

Definition ltac_int_to_nat (x:Z) : nat :=
  match x with
  | Z0 => 0%nat
  | Zpos p => nat_of_P p
  | Zneg p => 0%nat
  end.

Ltac number_to_nat N ::=
  match type of N with
  | nat => constr:(N)
  | int => let N' := constr:(ltac_int_to_nat N) in eval compute in N'
  | Z => let N' := constr:(ltac_int_to_nat N) in eval compute in N'
  (*todo: last case not needed*)
  end.

(* ********************************************************************** *)
(** * Decision procedure *)

(** A lot of hacks to allow calling the [omega] tactic *)

(* ---------------------------------------------------------------------- *)
(** ** Translation from typeclass order to ZArith, for using [omega] *)

Lemma le_zarith : le = Zle.
Proof using. extens*. Qed.

Global Opaque le_int_inst.

Lemma lt_zarith : lt = Zlt.
Proof using.
  extens. rew_to_le. rewrite le_zarith.
  unfold strict. intros. omega.
Qed.

Lemma ge_zarith : ge = Zge.
Proof using.
  extens. rew_to_le. rewrite le_zarith.
  unfold inverse. intros. omega.
Qed.

Lemma gt_zarith : gt = Zgt.
Proof using.
  extens. rew_to_le. rewrite le_zarith.
  unfold strict, inverse. intros. omega.
Qed.

Hint Rewrite le_zarith lt_zarith ge_zarith gt_zarith : rew_int_comp.

Ltac int_comp_to_zarith :=
  autorewrite with rew_int_comp in *.

(* ---------------------------------------------------------------------- *)
(** ** Hypothesis selection *)

(** [is_arity_type T] returns a boolean indicating whether
    [T] is equal to [nat] or [int] *)

Ltac is_arith_type T :=
  match T with
  | nat => constr:(true)
  | int => constr:(true)
  | _ => constr:(false)
  end.

(** [is_arity E] returns a boolean indicating whether
    [E] is an arithmetic expression *)

Ltac is_arith E :=
  match E with
  | _ = _ :> ?T => is_arith_type T
  | _ <> _ :> ?T => is_arith_type T
  | ~ ?E' => is_arith E'
  | ?E' -> False => is_arith E'
  | @le ?T _ _ _ => is_arith_type T
  | @ge ?T _ _ _ => is_arith_type T
  | @lt ?T _ _ _ => is_arith_type T
  | @gt ?T _ _ _ => is_arith_type T
  | (_ <= _)%Z => constr:(true)
  | (_ >= _)%Z => constr:(true)
  | (_ < _)%Z => constr:(true)
  | (_ > _)%Z => constr:(true)
  | (_ <= _)%nat => constr:(true)
  | (_ >= _)%nat => constr:(true)
  | (_ < _)%nat => constr:(true)
  | (_ > _)%nat => constr:(true)
  | _ => constr:(false)
  end.

(** [arith_goal_or_false] looks at the current goal and
    replaces it with [False] if it is not an arithmetic goal*)

Ltac arith_goal_or_false :=
  match goal with |- ?E =>
    match is_arith E with
    | true => idtac
    | false => false
    end
  end.

(** [generalize_arith] generalizes all hypotheses which correspond
    to some arithmetic goal. It destructs conjunctions on the fly. *)

Lemma istrue_isTrue_forw : forall (P:Prop),
  istrue (isTrue P) ->
  P.
Proof using. introv H. rew_istrue~ in H. Qed.

Ltac generalize_arith :=
  repeat match goal with
  | H: istrue (isTrue _) |- _ => generalize (@istrue_isTrue_forw _ H); clear H; intro
  | H:?E1 /\ ?E2 |- _ => destruct H
  | H: ?E -> False |- _ =>
    match is_arith E with
    | true => change (E -> False) with (~ E) in H
    | false => clear H
    end
  | H:?E |- _ =>
    match is_arith E with
    | true => generalize H; clear H (* --todo: revert H? *)
    | false => clear H
    end
  end.

(* --TODO:
Ltac split_if_eq_bool :=
  let go _ := apply eq_bool_prove; intros in
  match goal with
  | |- @eq bool _ _ => go tt
  | |- istrue (@eqb bool _ _ _) => apply eq_to_equ; go tt
  end.
*)

(* ---------------------------------------------------------------------- *)
(** ** Normalization of arithmetic expressions *)

(** Two lemmas to help omega out *)

Lemma Z_of_nat_O :
  Z_of_nat O = 0.
Proof using. reflexivity. Qed.

Lemma Z_of_nat_S : forall n,
  Z_of_nat (S n) = Zsucc (Z_of_nat n).
Proof using. intros. rewrite~ <- Zpos_P_of_succ_nat. Qed.

Lemma Z_of_nat_plus1 : forall n,
  Z_of_nat (1 + n) = Zsucc (Z_of_nat n).
Proof using. intros. rewrite <- Z_of_nat_S. fequals~. Qed.

(** [rew_maths] rewrite any lemma in the base [rew_maths].
    The goal should not contain any evar, otherwise tactic might loop. *)

Hint Rewrite nat_to_Z_eq_Z_of_nat Z_of_nat_O Z_of_nat_S Z_of_nat_plus1 : rew_maths.

Ltac rew_maths :=
  autorewrite with rew_maths in *.

(* ---------------------------------------------------------------------- *)
(** ** Setting up the goal for [omega] *)

(** [math_setup_goal] does introduction, splits, and replace
    the goal by [False] if it is not arithmetic. If the goal
    is of the form [P1 = P2 :> Prop], then the goal is
    changed to [P1 <-> P2]. *)

Ltac math_setup_goal_step tt :=
  match goal with
  | |- _ -> _ => intro
  | |- _ <-> _ => iff
  | |- forall _, _  => intro
  | |- _ /\ _ => split
  | |- _ = _ :> Prop => apply prop_ext; iff
  end.

Ltac math_setup_goal :=
  repeat (math_setup_goal_step tt);
  arith_goal_or_false.

  (* DEPRECATED
  Ltac math_setup_goal :=
    intros;
    try match goal with |- _ /\ _ => split end;
    try match goal with |- _ = _ :> Prop => apply prop_ext; iff end;
    arith_goal_or_false.
    (* try split_if_eq_bool. *)
  *)

(* --TODO; [int_nat_conv]
Lemma int_nat_plus : forall (n m:nat),
  (n + m)%nat = (n + m)%Z :> int.
Proof using. applys inj_plus. Qed.
Hint Rewrite int_nat_plus : int_nat_conv.
*)

(** [math] tactics performs several preprocessing step,
    selects all arithmetic hypotheses, and the call omega. *)
(* --TODO: autorewrite with int_nat_conv in *. after int_comp_to_zarith *)

(* ---------------------------------------------------------------------- *)
(** ** Main driver for the set up process to goal [omega] *)

(* --TODO: this probably is no longer necessary, since
     LibTactic version seems equivalent *)
Ltac check_noevar_goal ::=
  match goal with |- ?G => first [ has_evar G; fail 1 | idtac ] end.

Ltac math_0 := idtac.
Ltac math_1 := intros; generalize_arith.
(* Work around for the slow [autorewrite in *] *)
Ltac math_2 := instantiate; check_noevar_goal.
Ltac math_3 := autorewrite with rew_maths rew_int_comp rew_nat_comp; intros.
(* original:
Ltac math_2 := instantiate; check_noevar_goal; intros.
Ltac math_3 := rew_maths; nat_comp_to_peano; int_comp_to_zarith.
*)
Ltac math_4 := math_setup_goal.
Ltac math_5 := omega.

Ltac math_setup := math_0; math_1; math_2; math_3; math_4.
Ltac math_base := math_setup; math_5.

Tactic Notation "math" := math_base.

Tactic Notation "math" simple_intropattern(I) ":" constr(E) :=
  asserts I: E; [ math | ].
Tactic Notation "maths" constr(E) :=
  let H := fresh "H" in asserts H: E; [ math | ].
(* --TODO: parsing conflit *)

(* ---------------------------------------------------------------------- *)
(** ** [math] tactic restricted to arithmetic goals *)

(** [math_only] calls [math] but only on goals which
    have an arithmetic form. Thus, contracty to [math],
    it does not attempt to look for a contradiction in
    the hypotheses if the conclusion is not an arithmetic
    goal. Useful for efficiency. *)

Ltac math_only_if_arith_core tt :=
  match goal with |- ?T =>
    match is_arith T with true => math end end.

Tactic Notation "math_only_if_arith" :=
  math_only_if_arith_core tt.

(* ---------------------------------------------------------------------- *)
(** ** Elimination of multiplication, to call omega *)

(* In order to use [math] with simple multiplications, add the command:
     Hint Rewrite mult_2_eq_plus mult_3_eq_plus : rew_maths.
   TEMPORARY: these lemmas should go away as [omega] is able to inline
   trivial multiplication by itself
*)

Lemma mult_2_eq_plus : forall x, 2 * x = x + x.
Proof using. intros. ring. Qed.

Lemma mult_3_eq_plus : forall x, 3 * x = x + x + x.
Proof using. intros. ring. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Hint externs for calling math in the hint base [maths] *)

(* --TODO: rename [maths] database to [math] *)

Ltac math_hint := math.

Hint Extern 3 (_ = _ :> nat) => math_hint : maths.
Hint Extern 3 (_ = _ :> int) => math_hint : maths.
Hint Extern 3 (_ <> _ :> nat) => math_hint : maths.
Hint Extern 3 (_ <> _ :> int) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ = _ :> nat))) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ = _ :> int))) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ <> _ :> nat))) => math_hint : maths.
Hint Extern 3 (istrue (isTrue (_ <> _ :> int))) => math_hint : maths.
Hint Extern 3 ((_ <= _)%nat) => math_hint : maths.
Hint Extern 3 ((_ >= _)%nat) => math_hint : maths.
Hint Extern 3 ((_ < _)%nat) => math_hint : maths.
Hint Extern 3 ((_ > _)%nat) => math_hint : maths.
Hint Extern 3 ((_ <= _)%Z) => math_hint : maths.
Hint Extern 3 ((_ >= _)%Z) => math_hint : maths.
Hint Extern 3 ((_ < _)%Z) => math_hint : maths.
Hint Extern 3 ((_ > _)%Z) => math_hint : maths.
Hint Extern 3 (@le nat _ _ _) => math_hint : maths.
Hint Extern 3 (@lt nat _ _ _) => math_hint : maths.
Hint Extern 3 (@ge nat _ _ _) => math_hint : maths.
Hint Extern 3 (@gt nat _ _ _) => math_hint : maths.
Hint Extern 3 (@le int _ _ _) => math_hint : maths.
Hint Extern 3 (@lt int _ _ _) => math_hint : maths.
Hint Extern 3 (@ge int _ _ _) => math_hint : maths.
Hint Extern 3 (@gt int _ _ _) => math_hint : maths.
Hint Extern 3 (~ @le int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @lt int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @ge int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @gt int _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @eq int _ _) => unfold not; math_hint : maths.
Hint Extern 3 (@le int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@lt int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@ge int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@gt int _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@eq int _ _ -> False) => math_hint : maths.
Hint Extern 3 (~ @le nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @lt nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @ge nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @gt nat _ _ _) => unfold not; math_hint : maths.
Hint Extern 3 (~ @eq nat _ _) => unfold not; math_hint : maths.
Hint Extern 3 (@le nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@lt nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@ge nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@gt nat _ _ _ -> False) => math_hint : maths.
Hint Extern 3 (@eq nat _ _ -> False) => math_hint : maths.

(* ********************************************************************** *)
(** * Rewriting on arithmetic expressions *)

(* ---------------------------------------------------------------------- *)
(** ** Rewriting equalities provable by the [math] tactic *)

(** [math_rewrite (E = F)] replaces all occurences of [E]
    with the expression [F]. It produces the equality [E = F]
    as subgoal, and tries to solve it using the tactic [math] *)

Tactic Notation "math_rewrite" constr(E) :=
  asserts_rewrite E; [ try math | ].
Tactic Notation "math_rewrite" constr(E) "in" hyp(H) :=
  asserts_rewrite E in H; [ try math | ].
Tactic Notation "math_rewrite" constr(E) "in" "*" :=
  asserts_rewrite E in *; [ try math | ].

Tactic Notation "math_rewrite" "~" constr(E) :=
  math_rewrite E; auto_tilde.
Tactic Notation "math_rewrite" "~" constr(E) "in" hyp(H) :=
  math_rewrite E in H; auto_tilde.
Tactic Notation "math_rewrite" "~" constr(E) "in" "*" :=
  math_rewrite E in *; auto_tilde.

Tactic Notation "math_rewrite" "*" constr(E) :=
  math_rewrite E; auto_star.
Tactic Notation "math_rewrite" "*" constr(E) "in" hyp(H) :=
  math_rewrite E in H; auto_star.
Tactic Notation "math_rewrite" "*" constr(E) "in" "*" :=
  math_rewrite E in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Addition and substraction *)

Lemma plus_zero_r : forall n,
  n + 0 = n.
Proof using. math. Qed.

Lemma plus_zero_l : forall n,
  0 + n = n.
Proof using. math. Qed.

Lemma minus_zero_r : forall n,
  n - 0 = n.
Proof using. math. Qed.

Lemma minus_zero_l : forall n,
  0 - n = (-n).
Proof using. math. Qed.

Lemma mult_zero_l : forall n,
  0 * n = 0.
Proof using. math. Qed.

Lemma mult_zero_r : forall n,
  n * 0 = 0.
Proof using. math. Qed.

Lemma mult_one_l : forall n,
  1 * n = n.
Proof using. math. Qed.

Lemma mult_one_r : forall n,
  n * 1 = n.
Proof using. math. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Simplification tactic *)

(** [rew_int] performs some basic simplification on
    expressions involving integers *)

Hint Rewrite plus_zero_r plus_zero_l minus_zero_r minus_zero_l
  mult_zero_l mult_zero_r mult_one_l mult_one_r : rew_nat.

Tactic Notation "rew_int" :=
  autorewrite with rew_int.
Tactic Notation "rew_int" "~" :=
  rew_int; auto_tilde.
Tactic Notation "rew_int" "*" :=
  rew_int; auto_star.
Tactic Notation "rew_int" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_int).
  (* autorewrite with rew_int in *. *)
Tactic Notation "rew_int" "~" "in" "*" :=
  rew_int in *; auto_tilde.
Tactic Notation "rew_int" "*" "in" "*" :=
  rew_int in *; auto_star.
Tactic Notation "rew_int" "in" hyp(H) :=
  autorewrite with rew_int in H.
Tactic Notation "rew_int" "~" "in" hyp(H) :=
  rew_int in H; auto_tilde.
Tactic Notation "rew_int" "*" "in" hyp(H) :=
  rew_int in H; auto_star.

(* ********************************************************************** *)
(** * Conversions of operations from [nat] to [int] and back *)

(** -- LATER: make proofs below no longer depend on Coq's stdlib *)

(* ---------------------------------------------------------------------- *)
(** ** Lifting of comparisons from [nat] to [int] *)

(* --TODO: perhaps only state those as equalities? *)

Lemma eq_nat_of_eq_int : forall (n m:nat),
  (n:int) = (m:int) ->
  n = m :> nat.
Proof using. math. Qed.

Lemma neq_nat_of_neq_int : forall (n m:nat),
  (n:int) <> (m:int) ->
  (n <> m)%nat.
Proof using. math. Qed.

Lemma eq_int_of_eq_nat : forall (n m:nat),
  n = m :> nat ->
  (n:int) = (m:int).
Proof using. math. Qed.

Lemma neq_int_of_neq_nat : forall (n m:nat),
  (n <> m)%nat ->
  (n:int) <> (m:int).
Proof using. math. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Lifting of inequalities from [nat] to [int] *)

Lemma le_nat_of_le_int : forall (n m:nat),
  (n:int) <= (m:int) ->
  (n <= m).
Proof using. math. Qed.

Lemma le_int_of_le_nat : forall (n m:nat),
  (n <= m) ->
  (n:int) <= (m:int).
Proof using. math. Qed.

Lemma lt_nat_of_lt_int : forall (n m:nat),
  (n:int) < (m:int) ->
  (n < m).
Proof using. math. Qed.

Lemma lt_int_of_lt_nat : forall (n m:nat),
  (n < m) ->
  (n:int) < (m:int).
Proof using. math. Qed.

Lemma ge_nat_of_ge_int : forall (n m:nat),
  (n:int) >= (m:int) ->
  (n >= m).
Proof using. math. Qed.

Lemma ge_int_of_ge_nat : forall (n m:nat),
  (n >= m) ->
  (n:int) >= (m:int).
Proof using. math. Qed.

Lemma gt_nat_of_gt_int : forall (n m:nat),
  (n:int) > (m:int) ->
  (n > m).
Proof using. math. Qed.

Lemma gt_int_of_gt_nat : forall (n m:nat),
  (n > m) ->
  (n:int) > (m:int).
Proof using. math. Qed.

(* ---------------------------------------------------------------------- *)
(** ** Lifting of operations from [nat] to [int] *)

Lemma plus_nat_eq_plus_int : forall (n m:nat),
  (n+m)%nat = (n:int) + (m:int) :> int.
Proof using.
  Transparent nat_to_Z.
  intros. unfold nat_to_Z. applys Nat2Z.inj_add.
Qed.

Lemma minus_nat_eq_minus_int : forall (n m:nat),
  (n >= m)%nat ->
  (n-m)%nat = (n:int) - (m:int) :> int.
Proof using.
  Transparent nat_to_Z.
  intros. unfold nat_to_Z. applys Nat2Z.inj_sub. math.
Qed.

(* -- LATER: tactic for lifting all operators and comparisons into Z *)

(* -- LATER: complete with other operators *)

(* -- LATER: is the hint below really necessary?
     if so, there should probably be other hints similar to it *)

Hint Rewrite plus_nat_eq_plus_int : rew_maths.

(* ---------------------------------------------------------------------- *)
(** ** Absolute function in [nat] *)

Notation "'abs'" := Zabs_nat (at level 0).

Global Opaque Zabs Zabs_nat.

Lemma abs_nat : forall (n:nat),
  abs n = n.
Proof using. exact Zabs_nat_Z_of_nat. Qed.

Lemma abs_nonneg : forall (x:int),
  x >= 0 ->
  abs x = x :> int.
Proof using.
  intros. rewrite inj_Zabs_nat.
  rewrite Zabs_eq. math. math.
Qed.

Lemma abs_eq_nat_eq : forall (x:int) (y:nat),
  x >= 0 ->
  (abs x = y :> nat) = (x = Z_of_nat y :> int).
Proof using.
  introv M. extens. iff E.
  { subst. rewrite Zabs2Nat.id_abs, Z.abs_eq; math. }
  { subst. rewrite~ Zabs2Nat.id. }
Qed.

Lemma lt_abs_abs : forall (n m : int),
  (0 <= n) ->
  (n < m) ->
  (abs n < abs m).
Proof using.
  intros. nat_comp_to_peano. apply Zabs_nat_lt. math.
Qed.

(** -- TODO: many useful lemmas missing *)

(* ---------------------------------------------------------------------- *)
(** ** [abs] distribute on constants and operators *)

Lemma abs_0 : abs 0 = 0%nat :> nat.
Proof using. reflexivity. Qed.

Lemma abs_1 : abs 1 = 1%nat :> nat.
Proof using. reflexivity. Qed.

Lemma abs_plus : forall (x y:int),
  (x >= 0) ->
  (y >= 0) ->
  abs (x + y) = (abs x + abs y)%nat :> nat.
Proof using. intros. applys Zabs2Nat.inj_add; math. Qed.

Lemma abs_minus : forall (x y:int),
  (x >= y) ->
  (y >= 0) ->
  abs (x - y) = (abs x - abs y)%nat :> nat.
Proof using. intros. applys Zabs2Nat.inj_sub; math. Qed.

Lemma abs_nat_plus_nonneg : forall (n:nat) (x:int),
  x >= 0 ->
 abs (n + x)%Z = (n + abs x)%nat.
Proof using.
  introv N. applys eq_nat_of_eq_int.
  rewrite plus_nat_eq_plus_int.
  do 2 (rewrite abs_nonneg; [|math]). auto.
Qed.

Lemma abs_gt_minus_nat : forall (n:nat) (x:int),
  (x >= n)%Z ->
 abs (x - n)%Z = (abs x - n)%nat.
Proof using.
  introv N. applys eq_nat_of_eq_int.
  rewrite minus_nat_eq_minus_int.
  do 2 (rewrite abs_nonneg; [|math]). auto.
  applys ge_nat_of_ge_int. rewrite abs_nonneg; math.
Qed.

Lemma succ_abs_eq_abs_one_plus : forall (x:int),
  x >= 0 ->
  S (abs x) = abs (1 + x) :> nat.
Proof using.
  intros x. pattern x. applys (@measure_induction _ abs). clear x.
  intros x IH Pos. rewrite <- Zabs_nat_Zsucc. fequals. math. math.
Qed.

Lemma abs_eq_succ_abs_minus_one : forall (x:int),
  x > 0 ->
  abs x = S (abs (x - 1)) :> nat.
Proof using.
  intros. apply eq_nat_of_eq_int.
  rewrite abs_nonneg; try math.
  rewrite succ_abs_eq_abs_one_plus; try math.
  rewrite abs_nonneg; math.
Qed.

(* ---------------------------------------------------------------------- *)
(** ** Tactic [rew_abs_nonneg] to normalize expressions involving [abs]
       issuing side-conditions that arguments are nonnegative *)

Hint Rewrite abs_nat abs_0 abs_1 abs_plus abs_nonneg : rew_abs_nonneg.

Tactic Notation "rew_abs_nonneg" :=
  autorewrite with rew_abs_nonneg.
Tactic Notation "rew_abs_nonneg" "~" :=
  autorewrite with rew_abs_nonneg; try math; autos~.


Require Export euclidean__axioms.
Require Export euclidean__tactics.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__doublereverse.
Require Export lemma__inequalitysymmetric.
Require Export lemma__localextension.
Require Export logic.
Definition lemma__differenceofparts : forall A B C a b c, (euclidean__axioms.Cong A B a b) -> ((euclidean__axioms.Cong A C a c) -> ((euclidean__axioms.BetS A B C) -> ((euclidean__axioms.BetS a b c) -> (euclidean__axioms.Cong B C b c)))).
Proof.
intro A.
intro B.
intro C.
intro a.
intro b.
intro c.
intro H.
intro H0.
intro H1.
intro H2.
assert (* Cut *) (euclidean__axioms.Cong B C b c) as H3.
- assert (* Cut *) ((B = A) \/ (euclidean__axioms.neq B A)) as H3.
-- apply (@euclidean__tactics.eq__or__neq B A).
-- assert ((B = A) \/ (euclidean__axioms.neq B A)) as H4 by exact H3.
assert ((B = A) \/ (euclidean__axioms.neq B A)) as __TmpHyp by exact H4.
destruct __TmpHyp as [H5|H5].
--- assert (* Cut *) (euclidean__axioms.Cong A A a b) as H6.
---- apply (@eq__ind__r euclidean__axioms.Point A (fun B0 => (euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.BetS A B0 C) -> (euclidean__axioms.Cong A A a b)))) with (x := B).
-----intro H6.
intro H7.
exact H6.

----- exact H5.
----- exact H.
----- exact H1.
---- assert (* Cut *) (euclidean__axioms.Cong a b A A) as H7.
----- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a A A b H6).
----- assert (* Cut *) (~(euclidean__axioms.neq a b)) as H8.
------ intro H8.
assert (* Cut *) (euclidean__axioms.neq A A) as H9.
------- apply (@euclidean__axioms.axiom__nocollapse a b A A H8 H7).
------- assert (* Cut *) (A = A) as H10.
-------- assert (* Cut *) (False) as H10.
--------- assert (* Cut *) (A = A) as H10.
---------- apply (@logic.eq__refl Point A).
---------- apply (@H9 H10).
--------- assert (False) as H11 by exact H10.
apply (@logic.eq__refl Point A).
-------- apply (@H9 H10).
------ assert (* Cut *) (euclidean__axioms.Cong A C A C) as H9.
------- apply (@euclidean__axioms.cn__congruencereflexive A C).
------- assert (* Cut *) (euclidean__axioms.Cong B C A C) as H10.
-------- apply (@eq__ind__r euclidean__axioms.Point A (fun B0 => (euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.BetS A B0 C) -> (euclidean__axioms.Cong B0 C A C)))) with (x := B).
---------intro H10.
intro H11.
exact H9.

--------- exact H5.
--------- exact H.
--------- exact H1.
-------- assert (* Cut *) (euclidean__axioms.Cong B C a c) as H11.
--------- apply (@eq__ind__r euclidean__axioms.Point A (fun B0 => (euclidean__axioms.Cong A B0 a b) -> ((euclidean__axioms.BetS A B0 C) -> ((euclidean__axioms.Cong B0 C A C) -> (euclidean__axioms.Cong B0 C a c))))) with (x := B).
----------intro H11.
intro H12.
intro H13.
exact H0.

---------- exact H5.
---------- exact H.
---------- exact H1.
---------- exact H10.
--------- assert (* Cut *) (euclidean__axioms.Cong b c b c) as H12.
---------- apply (@euclidean__axioms.cn__congruencereflexive b c).
---------- assert (* Cut *) (euclidean__axioms.Cong b c a c) as H13.
----------- apply (@eq__ind__r euclidean__axioms.Point b (fun X => euclidean__axioms.Cong b c X c)) with (x := a).
------------ exact H12.
------------apply (@euclidean__tactics.NNPP (a = b) H8).

----------- assert (* Cut *) (euclidean__axioms.Cong a c b c) as H14.
------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a b c c H13).
------------ assert (* Cut *) (euclidean__axioms.Cong B C b c) as H15.
------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive B C a c b c H11 H14).
------------- exact H15.
--- assert (* Cut *) (~(C = A)) as H6.
---- intro H6.
assert (* Cut *) (euclidean__axioms.BetS A B A) as H7.
----- apply (@eq__ind__r euclidean__axioms.Point A (fun C0 => (euclidean__axioms.Cong A C0 a c) -> ((euclidean__axioms.BetS A B C0) -> (euclidean__axioms.BetS A B A)))) with (x := C).
------intro H7.
intro H8.
exact H8.

------ exact H6.
------ exact H0.
------ exact H1.
----- assert (* Cut *) (~(euclidean__axioms.BetS A B A)) as H8.
------ apply (@euclidean__axioms.axiom__betweennessidentity A B).
------ apply (@H8 H7).
---- assert (* Cut *) (euclidean__axioms.neq A C) as H7.
----- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric C A H6).
----- assert (* Cut *) (exists E, (euclidean__axioms.BetS C A E) /\ (euclidean__axioms.Cong A E A C)) as H8.
------ apply (@lemma__localextension.lemma__localextension C A C H6 H7).
------ destruct H8 as [E H9].
destruct H9 as [H10 H11].
assert (euclidean__axioms.neq A C) as H12 by exact H7.
assert (* Cut *) (euclidean__axioms.neq a c) as H13.
------- apply (@euclidean__axioms.axiom__nocollapse A C a c H12 H0).
------- assert (* Cut *) (euclidean__axioms.neq c a) as H14.
-------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric a c H13).
-------- assert (* Cut *) (exists e, (euclidean__axioms.BetS c a e) /\ (euclidean__axioms.Cong a e a c)) as H15.
--------- apply (@lemma__localextension.lemma__localextension c a c H14 H13).
--------- destruct H15 as [e H16].
destruct H16 as [H17 H18].
assert (* Cut *) (euclidean__axioms.Cong E A A E) as H19.
---------- apply (@euclidean__axioms.cn__equalityreverse E A).
---------- assert (* Cut *) (euclidean__axioms.Cong E A A C) as H20.
----------- apply (@lemma__congruencetransitive.lemma__congruencetransitive E A A E A C H19 H11).
----------- assert (* Cut *) (euclidean__axioms.Cong E A a c) as H21.
------------ apply (@lemma__congruencetransitive.lemma__congruencetransitive E A A C a c H20 H0).
------------ assert (* Cut *) (euclidean__axioms.Cong e a a e) as H22.
------------- apply (@euclidean__axioms.cn__equalityreverse e a).
------------- assert (* Cut *) (euclidean__axioms.Cong e a a c) as H23.
-------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive e a a e a c H22 H18).
-------------- assert (* Cut *) (euclidean__axioms.Cong a c e a) as H24.
--------------- apply (@lemma__congruencesymmetric.lemma__congruencesymmetric a e a c H23).
--------------- assert (euclidean__axioms.Cong E A a c) as H25 by exact H21.
assert (* Cut *) (euclidean__axioms.Cong E A e a) as H26.
---------------- apply (@lemma__congruencetransitive.lemma__congruencetransitive E A a c e a H25 H24).
---------------- assert (* Cut *) (euclidean__axioms.BetS E A C) as H27.
----------------- apply (@euclidean__axioms.axiom__betweennesssymmetry C A E H10).
----------------- assert (* Cut *) (euclidean__axioms.BetS e a c) as H28.
------------------ apply (@euclidean__axioms.axiom__betweennesssymmetry c a e H17).
------------------ assert (* Cut *) (euclidean__axioms.Cong E C e c) as H29.
------------------- apply (@euclidean__axioms.cn__sumofparts E A C e a c H26 H0 H27 H28).
------------------- assert (* Cut *) (euclidean__axioms.BetS E A B) as H30.
-------------------- apply (@euclidean__axioms.axiom__innertransitivity E A B C H27 H1).
-------------------- assert (* Cut *) (euclidean__axioms.BetS e a b) as H31.
--------------------- apply (@euclidean__axioms.axiom__innertransitivity e a b c H28 H2).
--------------------- assert (* Cut *) (euclidean__axioms.Cong C B c b) as H32.
---------------------- apply (@euclidean__axioms.axiom__5__line E A B C e a b c H H29 H0 H30 H31 H26).
---------------------- assert (* Cut *) (euclidean__axioms.Cong b c B C) as H33.
----------------------- assert (* Cut *) ((euclidean__axioms.Cong b c B C) /\ (euclidean__axioms.Cong B C b c)) as H33.
------------------------ apply (@lemma__doublereverse.lemma__doublereverse C B c b H32).
------------------------ destruct H33 as [H34 H35].
exact H34.
----------------------- assert (* Cut *) (euclidean__axioms.Cong B C b c) as H34.
------------------------ apply (@lemma__congruencesymmetric.lemma__congruencesymmetric B b c C H33).
------------------------ exact H34.
- exact H3.
Qed.