Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.
Require Import UniMath.Bicategories.Core.Examples.OneTypes.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.DispInvertibles.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.DisplayedBicats.CleavingOfBicat.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.Codomain.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.Examples.OneTypesLimits.

Local Open Scope cat.

(**
The codomain displayed bicategory has a cleaving
Here we assume that every 2-cell is invertible
 *)
Section CodomainCleaving.
  Context (B : bicat).

  Definition cod_local_iso_cleaving
    : local_iso_cleaving (cod_disp_bicat B).
  Proof.
    intros x y f g hx hy hf α.
    simple refine (_ ,, _).
    - refine (pr1 hf ,, _) ; cbn.
      exact (comp_of_invertible_2cell
               (lwhisker_of_invertible_2cell
                  _
                  α)
               (pr2 hf)).
    - simple refine ((id2 _ ,, _) ,, _) ; cbn.
      + abstract
          (rewrite id2_rwhisker, id2_right ;
           apply idpath).
      + use is_disp_invertible_2cell_cod.
        cbn.
        is_iso.
  Defined.

  Section CartesianOfSFibToCartesian.
    Context {c₁ c₂ : B}
            {s₁ s₂ : c₁ --> c₂}
            {α : s₁ ==> s₂}
            {t₁ : cod_disp_bicat B c₁}
            {t₂ : cod_disp_bicat B c₂}
            {ss₁ : t₁ -->[ s₁ ] t₂}
            {ss₂ : t₁ -->[ s₂ ] t₂}
            (αα : ss₁ ==>[ α ] ss₂)
            (Hαα : is_cartesian_2cell_sfib (pr2 t₂) (pr1 αα)).

    Section FixSome.
      Context {h : c₁ --> c₂}
              {hh : t₁ -->[ h] t₂}
              {γ : h ==> s₁}
              (γα : hh ==>[ γ • α] ss₂).

      Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell_unique
        : isaprop (∑ γγ : hh ==>[ γ] ss₁, γγ •• αα = γα).
      Proof.
        cbn in *.
        use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath ; [ intro ; apply cod_disp_bicat | ].
        use subtypePath ; [ intro ; apply cellset_property | ].
        use (is_cartesian_2cell_sfib_factor_unique _ Hαα).
        - exact (pr1 γα).
        - exact ((pr2 hh)^-1 • (_ ◃ γ) • pr2 ss₁).
        - abstract
            (rewrite !vassocl ;
             use vcomp_move_L_pM ; [ is_iso | ] ;
             refine (pr2 γα @ _) ;
             rewrite <- lwhisker_vcomp ;
             rewrite !vassocl ;
             apply maponpaths ;
             exact (!(pr2 αα))).
        - abstract
            (rewrite !vassocl ;
             use vcomp_move_L_pM ; [ is_iso | ] ;
             exact (pr21 φ₁)).
        - abstract
            (rewrite !vassocl ;
             use vcomp_move_L_pM ; [ is_iso | ] ;
             exact (pr21 φ₂)).
        - exact (maponpaths pr1 (pr2 φ₁)).
        - exact (maponpaths pr1 (pr2 φ₂)).
      Qed.

      Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell
        : hh ==>[ γ ] ss₁.
      Proof.
        cbn in *.
        use make_disp_2cell_cod.
        - use (is_cartesian_2cell_sfib_factor _ Hαα (pr1 γα)).
          + exact ((pr2 hh)^-1 • (_ ◃ γ) • pr2 ss₁).
          + abstract
              (rewrite !vassocl ;
               use vcomp_move_L_pM ; [ is_iso | ] ;
               refine (pr2 γα @ _) ;
               rewrite <- lwhisker_vcomp ;
               rewrite !vassocl ;
               apply maponpaths ;
               exact (!(pr2 αα))).
        - abstract
            (unfold coherent_homot ;
             rewrite is_cartesian_2cell_sfib_factor_over ;
             rewrite !vassocr ;
             rewrite vcomp_rinv ;
             rewrite id2_left ;
             apply idpath).
      Defined.

      Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell_comm
        : is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell •• αα = γα.
      Proof.
        cbn.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        apply is_cartesian_2cell_sfib_factor_comm.
      Qed.
    End FixSome.

    Definition is_cartesian_2cell_sfib_to_is_cartesian_2cell
      : is_cartesian_2cell (cod_disp_bicat B) αα.
    Proof.
      intros h hh γ γα.
      use iscontraprop1.
      - exact (is_cartesian_2cell_sfib_to_is_cartesian_2cell_unique γα).
      - simple refine (_ ,, _).
        + exact (is_cartesian_2cell_sfib_to_is_cartesian_2cell_cell γα).
        + exact (is_cartesian_2cell_sfib_to_is_cartesian_2cell_comm γα).
    Defined.
  End CartesianOfSFibToCartesian.

  Definition cod_invertible_is_cartesian_2cell
             {c₁ c₂ : B}
             {s₁ s₂ : c₁ --> c₂}
             {α : s₁ ==> s₂}
             {t₁ : cod_disp_bicat B c₁}
             {t₂ : cod_disp_bicat B c₂}
             {ss₁ : t₁ -->[ s₁ ] t₂}
             {ss₂ : t₁ -->[ s₂ ] t₂}
             (αα : ss₁ ==>[ α ] ss₂)
             (Hαα : is_invertible_2cell (pr1 αα))
    : is_cartesian_2cell (cod_disp_bicat B) αα.
  Proof.
    apply is_cartesian_2cell_sfib_to_is_cartesian_2cell.
    apply invertible_is_cartesian_2cell_sfib.
    exact Hαα.
  Defined.

  Section OpCartesianOfSOpFibToOpCartesian.
    Context {c₁ c₂ : B}
            {s₁ s₂ : c₁ --> c₂}
            {α : s₁ ==> s₂}
            {t₁ : cod_disp_bicat B c₁}
            {t₂ : cod_disp_bicat B c₂}
            {ss₁ : t₁ -->[ s₁ ] t₂}
            {ss₂ : t₁ -->[ s₂ ] t₂}
            (αα : ss₁ ==>[ α ] ss₂)
            (Hαα : is_opcartesian_2cell_sopfib (pr2 t₂) (pr1 αα)).

    Section FixSome.
      Context {h : c₁ --> c₂}
              {hh : t₁ -->[ h ] t₂}
              {γ : s₂ ==> h}
              (γα : ss₁ ==>[ α • γ ] hh).

      Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_unique
        : isaprop (∑ γγ : ss₂ ==>[ γ ] hh, αα •• γγ = γα).
      Proof.
        cbn in *.
        use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath ; [ intro ; apply cod_disp_bicat | ].
        use subtypePath ; [ intro ; apply cellset_property | ].
        use (is_opcartesian_2cell_sopfib_factor_unique _ Hαα).
        - exact (pr1 γα).
        - exact ((pr2 ss₂)^-1 • (_ ◃ γ) • pr2 hh).
        - abstract
              (use (vcomp_lcancel (pr12 ss₁)) ; [ apply (pr2 ss₁) | ] ;
               rewrite !vassocr ;
               rewrite !(pr2 γα) ;
               apply maponpaths_2 ;
               rewrite <- lwhisker_vcomp ;
               apply maponpaths_2 ;
               rewrite (pr2 αα) ;
               rewrite !vassocl ;
               rewrite vcomp_rinv ;
               rewrite id2_right ;
               apply idpath).
        - abstract
            (rewrite !vassocl ;
             use vcomp_move_L_pM ; [ is_iso | ] ;
             exact (pr21 φ₁)).
        - abstract
            (rewrite !vassocl ;
             use vcomp_move_L_pM ; [ is_iso | ] ;
             exact (pr21 φ₂)).
        - exact (maponpaths pr1 (pr2 φ₁)).
        - exact (maponpaths pr1 (pr2 φ₂)).
      Qed.

      Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell
        : ss₂ ==>[ γ ] hh.
      Proof.
        cbn in *.
        use make_disp_2cell_cod.
        - use (is_opcartesian_2cell_sopfib_factor _ Hαα (pr1 γα)).
          + exact ((pr2 ss₂)^-1 • (_ ◃ γ) • pr2 hh).
          + abstract
              (use (vcomp_lcancel (pr12 ss₁)) ; [ apply (pr2 ss₁) | ] ;
               rewrite !vassocr ;
               rewrite !(pr2 γα) ;
               apply maponpaths_2 ;
               rewrite <- lwhisker_vcomp ;
               apply maponpaths_2 ;
               rewrite (pr2 αα) ;
               rewrite !vassocl ;
               rewrite vcomp_rinv ;
               rewrite id2_right ;
               apply idpath).
        - abstract
            (unfold coherent_homot ;
             rewrite is_opcartesian_2cell_sopfib_factor_over ;
             rewrite !vassocr ;
             rewrite vcomp_rinv ;
             rewrite id2_left ;
             apply idpath).
      Defined.

      Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_comm
        : αα •• is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell = γα.
      Proof.
        cbn.
        use subtypePath.
        {
          intro.
          apply cellset_property.
        }
        apply is_opcartesian_2cell_sopfib_factor_comm.
      Qed.
    End FixSome.

    Definition is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell
      : is_opcartesian_2cell (cod_disp_bicat B) αα.
    Proof.
      intros h hh γ γα.
      use iscontraprop1.
      - exact (is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_unique γα).
      - simple refine (_ ,, _).
        + exact (is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_cell γα).
        + exact (is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell_comm γα).
    Defined.
  End OpCartesianOfSOpFibToOpCartesian.

  Definition cod_invertible_is_opcartesian_2cell
             {c₁ c₂ : B}
             {s₁ s₂ : c₁ --> c₂}
             {α : s₁ ==> s₂}
             {t₁ : cod_disp_bicat B c₁}
             {t₂ : cod_disp_bicat B c₂}
             {ss₁ : t₁ -->[ s₁ ] t₂}
             {ss₂ : t₁ -->[ s₂ ] t₂}
             (αα : ss₁ ==>[ α ] ss₂)
             (Hαα : is_invertible_2cell (pr1 αα))
    : is_opcartesian_2cell (cod_disp_bicat B) αα.
  Proof.
    apply is_opcartesian_2cell_sopfib_to_is_opcartesian_2cell.
    apply invertible_is_opcartesian_2cell_sopfib.
    exact Hαα.
  Defined.

  (** Characterization of cartesian 1-cells *)
  Section PullbackToCartesian.
    Context {x y : B}
            {f : x --> y}
            {hx : cod_disp_bicat B x}
            {hy : cod_disp_bicat B y}
            (π : pr1 hx --> pr1 hy)
            (p : invertible_2cell (pr2 hx · f) (π · pr2 hy))
            (pb := make_pb_cone (pr1 hx) (pr2 hx) π p)
            (pb_sqr : has_pb_ump pb).

    Section Lift1CellConeMor.
      Context {z : B}
              {hz : cod_disp_bicat B z}
              {g : z --> x}
              (hg : hz -->[ g · f] hy).

      Let other_cone : pb_cone f (pr2 hy)
        := make_pb_cone
             (pr1 hz)
             (pr2 hz · g)
             (pr1 hg)
             (comp_of_invertible_2cell
                (rassociator_invertible_2cell _ _ _)
                (pr2 hg)).

      Definition lift_1cell_to_pb_1cell
                 (Hg : lift_1cell_factor (cod_disp_bicat B) (π,, p) hg)
        : pb_1cell other_cone pb.
      Proof.
        use make_pb_1cell.
        - exact (pr11 Hg).
        - use inv_of_invertible_2cell.
          exact (pr21 Hg).
        - use make_invertible_2cell.
          + exact (pr112 Hg).
          + exact (pr21 (cod_disp_invertible_invertible_2_cell _ (pr2 Hg))).
        - abstract
            (pose (pr212 Hg) as q ;
             cbn ; cbn in q ;
             rewrite lwhisker_id2 in q ;
             rewrite id2_left in q ;
             rewrite !vassocl ;
             do 3 (use vcomp_move_L_pM ; [ is_iso | ] ; cbn) ;
             refine (_ @ maponpaths (λ z, z • _) q) ; clear q ;
             rewrite !vassocl ;
             do 3 apply maponpaths ;
             rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)) ;
             rewrite rwhisker_vcomp ;
             pose (maponpaths pr1 (disp_vcomp_rinv (pr2 Hg))) as q ;
             unfold transportb in q ;
             cbn in q ;
             rewrite pr1_transportf, transportf_const in q ;
             cbn in q ;
             refine (!_) ;
             etrans ;
             [ do 2 apply maponpaths ;
               apply maponpaths_2 ;
               apply maponpaths ;
               exact q
             | ] ;
             rewrite id2_rwhisker, id2_left ;
             rewrite lassociator_rassociator ;
             apply id2_right).
      Defined.

      Definition pb_1cell_to_lift_1cell
                 (Hg : pb_1cell other_cone pb)
        : lift_1cell_factor (cod_disp_bicat B) (π,, p) hg.
      Proof.
        simple refine ((_ ,, _) ,, ((_ ,, _) ,, _)).
        - exact (pb_1cell_1cell Hg).
        - exact (inv_of_invertible_2cell (pb_1cell_pr1 Hg)).
        - exact (pr1 (pb_1cell_pr2 Hg)).
        - abstract
            (cbn ;
             pose (pb_1cell_eq Hg) as q ;
             cbn in q ;
             rewrite lwhisker_id2, id2_left ;
             rewrite !vassocl ;
             do 3 (use vcomp_move_R_pM ; [ is_iso | ] ; cbn) ;
             refine (maponpaths (λ z, z • _) q @ _) ; clear q ;
             rewrite !vassocl ;
             do 3 apply maponpaths ;
             refine (_ @ id2_right _) ;
             apply maponpaths ;
             use vcomp_move_R_pM ; [ is_iso | ] ; cbn ;
             rewrite !vassocr ;
             rewrite rassociator_lassociator ;
             rewrite id2_left, id2_right ;
             apply idpath).
        - use is_disp_invertible_2cell_cod.
          exact (pr2 (pb_1cell_pr2 Hg)).
      Defined.
    End Lift1CellConeMor.

    Definition is_pb_to_cartesian_lift_1cell
               {z : B}
               {hz : cod_disp_bicat B z}
               {g : B ⟦ z, x ⟧}
               (hg : hz -->[ g · f] hy)
      : lift_1cell_factor (cod_disp_bicat B) (π,, p) hg.
    Proof.
      apply pb_1cell_to_lift_1cell.
      apply (has_pb_ump_1 pb_sqr).
    Defined.

    Section Lift2CellConeCell.
      Context {c : B}
              {cc : cod_disp_bicat B c}
              {h h' : c --> x}
              {gg : cc -->[ h · f] hy}
              {gg' : cc -->[ h' · f] hy}
              {δ : h ==> h'}
              (σσ : gg ==>[ δ ▹ f] gg')
              (Lh : lift_1cell_factor (cod_disp_bicat B) (π,, p) gg)
              (Lh' : lift_1cell_factor (cod_disp_bicat B) (π,, p) gg').

      Let ℓ : pr1 cc --> pr1 hx := pr11 Lh.
      Let ℓhx : invertible_2cell (pr2 cc · h) (ℓ · pr2 hx) := pr21 Lh.
      Let ℓπ
        : invertible_2cell (ℓ · π) (pr1 gg)
        := pr1 (cod_disp_invertible_invertible_2_cell _ (pr2 Lh)).
      Let ℓ' : pr1 cc --> pr1 hx := pr11 Lh'.
      Let ℓhx' : invertible_2cell (pr2 cc · h') (ℓ' · pr2 hx) := pr21 Lh'.
      Let ℓπ'
        : invertible_2cell (ℓ' · π) (pr1 gg')
        := pr1 (cod_disp_invertible_invertible_2_cell _ (pr2 Lh')).

      Definition is_pb_to_cartesian_lift_2cell_cell_eq
        : (ℓ ◃ p)
          • lassociator ℓ π (pr2 hy)
          • ((pr112 Lh • pr1 σσ • pr1 (disp_inv_cell (pr2 Lh'))) ▹ pr2 hy)
          • rassociator ℓ' π (pr2 hy)
          =
          lassociator ℓ (pr2 hx) f
          • ((ℓhx ^-1 • (pr2 cc ◃ δ) • ℓhx') ▹ f)
          • rassociator ℓ' (pr2 hx) f
          • (ℓ' ◃ p).
      Proof.
        pose (pr212 Lh) as d.
        pose (pr212 Lh') as d'.
        cbn in d, d'.
        rewrite lwhisker_id2, id2_left in d.
        rewrite lwhisker_id2, id2_left in d'.
        rewrite <- !rwhisker_vcomp.
        rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ].
        use vcomp_move_L_pM ; [ is_iso | ].
        cbn.
        use (vcomp_lcancel (lassociator _ _ _)) ; [ is_iso | ].
        rewrite !vassocr.
        etrans.
        {
          do 3 apply maponpaths_2.
          exact d.
        }
        clear d.
        rewrite <- rwhisker_lwhisker.
        use vcomp_move_R_Mp ; [ is_iso | ].
        cbn.
        use vcomp_move_R_Mp.
        {
          is_iso.
          apply (is_invertible_2cell_inv (pr2 ℓπ')).
        }
        cbn.
        rewrite !vassocl.
        rewrite !vassocl in d'.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          exact d'.
        }
        refine (!_).
        exact (pr2 σσ).
      Qed.

      Definition is_pb_to_cartesian_lift_2cell_cell
        : ℓ ==> ℓ'.
      Proof.
        use (pb_ump_cell pb_sqr) ; cbn.
        - exact (ℓhx^-1 • (_ ◃ δ) • ℓhx').
        - exact (ℓπ • pr1 σσ • (ℓπ')^-1).
        - exact is_pb_to_cartesian_lift_2cell_cell_eq.
      Defined.

      Definition is_pb_to_cartesian_lift_2cell_cell_homot
        : coherent_homot δ is_pb_to_cartesian_lift_2cell_cell.
      Proof.
        unfold coherent_homot.
        etrans.
        {
          apply maponpaths.
          apply (pb_ump_cell_pr1 pb_sqr).
        }
        rewrite !vassocr.
        rewrite vcomp_rinv, id2_left.
        apply idpath.
      Qed.

      Definition is_pb_to_cartesian_lift_2cell_disp_cell
        : Lh ==>[ δ ] Lh'.
      Proof.
        use make_disp_2cell_cod.
        - exact is_pb_to_cartesian_lift_2cell_cell.
        - exact is_pb_to_cartesian_lift_2cell_cell_homot.
      Defined.

      Definition is_pb_to_cartesian_lift_2cell_unique
        : isaprop (lift_2cell_factor_type (cod_disp_bicat B) (π,, p) σσ Lh Lh').
      Proof.
        use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply disp_cellset_property.
        }
        use subtypePath.
        {
          intro ; apply cellset_property.
        }
        use (pb_ump_eq pb_sqr).
        - exact (ℓhx^-1 • (_ ◃ δ) • ℓhx').
        - exact (ℓπ • pr1 σσ • (ℓπ')^-1).
        - apply is_pb_to_cartesian_lift_2cell_cell_eq.
        - rewrite !vassocl.
          use vcomp_move_L_pM ; [ is_iso | ].
          exact (pr21 φ₁).
        - pose (!(transportf_cell_of_cod_over (id2_right (δ ▹ f) @ ! id2_left (δ ▹ f)) _)
                @ maponpaths pr1 (pr2 φ₁)) as d.
          use vcomp_move_L_Mp ; [ is_iso | ].
          exact d.
        - rewrite !vassocl.
          use vcomp_move_L_pM ; [ is_iso | ].
          exact (pr21 φ₂).
        - pose (!(transportf_cell_of_cod_over (id2_right (δ ▹ f) @ ! id2_left (δ ▹ f)) _)
                @ maponpaths pr1 (pr2 φ₂)) as d.
          use vcomp_move_L_Mp ; [ is_iso | ].
          exact d.
      Qed.

      Definition is_pb_to_cartesian_lift_2cell
        : lift_2cell_factor (cod_disp_bicat B) (π,, p) σσ Lh Lh'.
      Proof.
        use iscontraprop1.
        - exact is_pb_to_cartesian_lift_2cell_unique.
        - simple refine (_ ,, _).
          + exact is_pb_to_cartesian_lift_2cell_disp_cell.
          + abstract
              (use subtypePath ; [ intro ; apply cellset_property | ] ;
               etrans ; [ exact (transportf_cell_of_cod_over _ _) | ] ;
               simpl ;
               etrans ; [ apply maponpaths_2 ; apply (pb_ump_cell_pr2 pb_sqr) | ] ;
               do 2 refine (vassocl _ _ _ @ _) ;
               apply maponpaths ;
               refine (_ @ id2_right _) ;
               apply maponpaths ;
               apply (pr2 ℓπ')).
      Defined.
    End Lift2CellConeCell.

    Definition is_pb_to_cartesian_1cell
      : cartesian_1cell (cod_disp_bicat B) (π ,, p).
    Proof.
      split.
      - exact @is_pb_to_cartesian_lift_1cell.
      - exact @is_pb_to_cartesian_lift_2cell.
    Defined.
  End PullbackToCartesian.

  Context (inv_B : locally_groupoid B).

  Section CartesianToPullback.
    Context {x y : B}
            {f : x --> y}
            {hx : cod_disp_bicat B x}
            {hy : cod_disp_bicat B y}
            (π : pr1 hx --> pr1 hy)
            (p : invertible_2cell (pr2 hx · f) (π · pr2 hy))
            (Hp : cartesian_1cell (cod_disp_bicat B) (π,, p)).

    Let pb := make_pb_cone (pr1 hx) (pr2 hx) π p.

    Definition cartesian_1cell_pb_ump_1
      : pb_ump_1 pb.
    Proof.
      intro q.
      pose (pr1 Hp x (make_ar (pb_cone_pr1 q)) (id₁ _)
                (pb_cone_pr2 q ,, comp_of_invertible_2cell
                             (lwhisker_of_invertible_2cell
                                _
                                (lunitor_invertible_2cell _))
                             (pb_cone_cell q))) as w.
      pose (lift_1cell_to_pb_1cell π p _ w) as r.
      use make_pb_1cell.
      - exact r.
      - exact (comp_of_invertible_2cell
                  (pb_1cell_pr1 r)
                  (runitor_invertible_2cell _)).
      - exact (pb_1cell_pr2 r).
      - abstract
          (refine (pb_1cell_eq r @ _) ; cbn ;
           rewrite <- !rwhisker_vcomp ;
           rewrite !vassocl ;
           apply maponpaths ;
           rewrite vassocl ;
           apply maponpaths ;
           rewrite !vassocr ;
           do 3 apply maponpaths_2 ;
           apply lunitor_lwhisker).
    Defined.

    Section PullbackUMP2.
      Context {q : B}
              {φ ψ : q --> pb}
              {α : φ · pb_cone_pr1 pb ==> ψ · pb_cone_pr1 pb}
              {β : φ · pb_cone_pr2 pb ==> ψ · pb_cone_pr2 pb}
              (r : (φ ◃ pb_cone_cell pb)
                   • lassociator φ (pb_cone_pr2 pb) (pr2 hy)
                   • (β ▹ pr2 hy)
                   • rassociator ψ (pb_cone_pr2 pb) (pr2 hy)
                   =
                   lassociator φ (pb_cone_pr1 pb) f
                   • (α ▹ f)
                   • rassociator ψ (pb_cone_pr1 pb) f
                   • (ψ ◃ pb_cone_cell pb)).

      Let φ_disp
        : make_ar φ -->[ pr2 hx · f] hy.
      Proof.
        use make_disp_1cell_cod.
        - exact (φ · π).
        - exact (comp_of_invertible_2cell
                   (lwhisker_of_invertible_2cell φ p)
                   (lassociator_invertible_2cell _ _ _)).
      Defined.

      Let φ_cone : pb_cone f (pr2 hy)
        := make_pb_cone
             q
             (φ · pr2 hx)
             (φ · π)
             (comp_of_invertible_2cell
                (rassociator_invertible_2cell _ _ _)
                (pr2 φ_disp)).

      Let φ_cell : pb_1cell φ_cone pb.
      Proof.
        use make_pb_1cell.
        - exact φ.
        - apply id2_invertible_2cell.
        - apply id2_invertible_2cell.
        - abstract
            (cbn ;
             rewrite !id2_rwhisker, !id2_right ;
             rewrite !vassocr ;
             rewrite lassociator_rassociator ;
             rewrite id2_left ;
             rewrite !vassocl ;
             rewrite lassociator_rassociator ;
             rewrite id2_right ;
             apply idpath).
      Defined.

      Let ψ_disp
        : make_ar φ -->[ pr2 hx · f] hy.
      Proof.
        use make_disp_1cell_cod.
        - exact (ψ · π).
        - use make_invertible_2cell.
          + exact (lassociator _ _ _
                   • (α ▹ f)
                   • rassociator _ _ _
                   • (ψ ◃ p)
                   • lassociator _ _ _).
          + is_iso.
            * apply inv_B.
            * apply property_from_invertible_2cell.
      Defined.

      Let σσ : φ_disp ==>[ id₂ (pr2 hx) ▹ f] ψ_disp.
      Proof.
        use make_disp_2cell_cod.
        - exact β.
        - abstract
            (unfold coherent_homot ;
             cbn ;
             rewrite id2_rwhisker, lwhisker_id2, id2_left ;
             use vcomp_move_L_Mp ; [ is_iso | ] ;
             exact r).
      Defined.

      Let ψ_cone : pb_cone f (pr2 hy)
        := make_pb_cone
             q
             (φ · pr2 hx)
             (ψ · π)
             (comp_of_invertible_2cell
                (rassociator_invertible_2cell φ (pr2 hx) f)
                (pr2 ψ_disp)).

      Let ψ_cell : pb_1cell ψ_cone pb.
      Proof.
        use make_pb_1cell.
        - exact ψ.
        - refine (inv_of_invertible_2cell _).
          use make_invertible_2cell.
          + exact α.
          + apply inv_B.
        - apply id2_invertible_2cell.
        - abstract
            (cbn ;
             rewrite id2_rwhisker, id2_right ;
             rewrite !vassocl ;
             rewrite lassociator_rassociator ;
             rewrite id2_right ;
             do 3 (use vcomp_move_L_pM ; [ is_iso | ]) ;
             cbn ;
             rewrite !vassocr ;
             apply idpath).
      Defined.

      Let φ_lift : lift_1cell_factor (cod_disp_bicat B) (π,, p) φ_disp
        := pb_1cell_to_lift_1cell π p φ_disp φ_cell.

      Let ψ_lift : lift_1cell_factor (cod_disp_bicat B) (π,, p) ψ_disp
        := pb_1cell_to_lift_1cell π p ψ_disp ψ_cell.

      Definition cartesian_1cell_pb_2cell
        : φ ==> ψ
        := pr1 (cartesian_1cell_lift_2cell _ _ Hp σσ φ_lift ψ_lift).

      Definition cartesian_1cell_pb_2cell_pr1
        : cartesian_1cell_pb_2cell ▹ pb_cone_pr1 pb = α.
      Proof.
        pose (pr2 (cartesian_1cell_lift_2cell _ _ Hp σσ φ_lift ψ_lift)) as d.
        cbn in d.
        rewrite lwhisker_id2, !id2_left in d.
        exact d.
      Qed.

      Definition cartesian_1cell_pb_2cell_pr2
        : cartesian_1cell_pb_2cell ▹ pb_cone_pr2 pb = β.
      Proof.
        pose (maponpaths
                pr1
                (cartesian_1cell_lift_2cell_commutes
                   _ _
                   Hp σσ
                   φ_lift ψ_lift))
          as d.
        cbn in d.
        rewrite pr1_transportf, transportf_const in d.
        cbn in d.
        rewrite id2_right, id2_left in d.
        exact d.
      Qed.

      Section Uniqueness.
        Context (τ₁ τ₂ : φ ==> ψ)
                (pr1τ₁ : τ₁ ▹ pb_cone_pr1 pb = α)
                (pr2τ₁ : τ₁ ▹ pb_cone_pr2 pb = β)
                (pr1τ₂ : τ₂ ▹ pb_cone_pr1 pb = α)
                (pr2τ₂ : τ₂ ▹ pb_cone_pr2 pb = β).

        Let lift_τ₁ : φ_lift ==>[ id₂ (pr2 hx)] ψ_lift.
        Proof.
          use make_disp_2cell_cod.
          - exact τ₁.
          - abstract
              (unfold coherent_homot ;
               cbn ;
               rewrite lwhisker_id2, !id2_left ;
               exact pr1τ₁).
        Defined.

        Let lift_τ₂ : φ_lift ==>[ id₂ (pr2 hx)] ψ_lift.
        Proof.
          use make_disp_2cell_cod.
          - exact τ₂.
          - abstract
              (unfold coherent_homot ;
               cbn ;
               rewrite lwhisker_id2, !id2_left ;
               exact pr1τ₂).
        Defined.

        Definition cartesian_1cell_pb_2cell_unique
          : τ₁ = τ₂.
        Proof.
          refine (maponpaths
                    pr1
                    (isaprop_lift_of_lift_2cell
                       _ _
                       (pr2 Hp _ _ _ _ _ _ _ σσ φ_lift ψ_lift)
                       lift_τ₁ lift_τ₂
                       _
                       _)) ;
            (use subtypePath ; [ intro ; apply cellset_property | ]) ;
            cbn ;
            rewrite pr1_transportf, transportf_const ;
            cbn.
          - rewrite id2_left, id2_right.
            exact pr2τ₁.
          - rewrite id2_left, id2_right.
            exact pr2τ₂.
        Qed.
      End Uniqueness.
    End PullbackUMP2.

    Definition cartesian_1cell_pb_ump_2
      : pb_ump_2 pb.
    Proof.
      intros q φ ψ α β r.
      apply iscontraprop1.
      - abstract
          (use invproofirrelevance ;
           intros τ₁ τ₂ ;
           use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
           exact (cartesian_1cell_pb_2cell_unique
                    r
                    _ _
                    (pr12 τ₁) (pr22 τ₁)
                    (pr12 τ₂) (pr22 τ₂))).
      - exact (cartesian_1cell_pb_2cell r
               ,,
               cartesian_1cell_pb_2cell_pr1 r
               ,,
               cartesian_1cell_pb_2cell_pr2 r).
    Defined.

    Definition cartesian_1cell_to_is_pb
      : has_pb_ump pb.
    Proof.
      split.
      - exact cartesian_1cell_pb_ump_1.
      - exact cartesian_1cell_pb_ump_2.
    Defined.
  End CartesianToPullback.

  Context (pb_B : has_pb B).

  Definition cod_global_cleaving
    : global_cleaving (cod_disp_bicat B).
  Proof.
    intros x y hx f ; cbn in *.
    pose (pb_B _ _ _ f (pr2 hx)) as pb.
    pose (pr1 pb) as pb₁.
    pose (pr2 pb) as pb₂.
    simple refine ((_ ,, _) ,, (_ ,, _) ,, _) ; cbn.
    - exact pb₁.
    - exact (pb_cone_pr1 pb₁).
    - exact (pb_cone_pr2 pb₁).
    - exact (pb_cone_cell pb₁).
    - apply is_pb_to_cartesian_1cell.
      exact pb₂.
  Defined.

  Definition cod_local_cleaving
    : local_cleaving (cod_disp_bicat B).
  Proof.
    intros x y hx hy f g hf hg.
    simple refine (_ ,, _).
    - simple refine (pr1 hf ,, pr2 hx ◃ hg • pr12 hf ,, _).
      cbn.
      is_iso.
      + apply inv_B.
      + apply (pr22 hf).
    - simple refine (_ ,, _).
      + simple refine (id2 _ ,, _).
        abstract
          (cbn ;
           rewrite id2_rwhisker ;
           rewrite id2_right ;
           apply idpath).
      + simpl.
        apply cod_invertible_is_cartesian_2cell ; cbn.
        is_iso.
  Defined.

  Definition cod_local_opcleaving
    : local_opcleaving (cod_disp_bicat B).
  Proof.
    intros x y hx hy f g hf hg.
    simple refine (_ ,, _).
    - cbn.
      simple refine (pr1 hf ,, (pr2 hx ◃ _^-1) • pr12 hf ,, _) ; cbn.
      + exact hg.
      + apply inv_B.
      + is_iso.
        apply (pr22 hf).
    - simple refine (_ ,, _).
      + simple refine (id2 _ ,, _).
        abstract
          (cbn ;
           rewrite id2_rwhisker ;
           rewrite id2_right ;
           rewrite !vassocr ;
           rewrite lwhisker_vcomp ;
           rewrite vcomp_rinv ;
           rewrite lwhisker_id2 ;
           rewrite id2_left ;
           apply idpath).
      + simpl.
        apply cod_invertible_is_opcartesian_2cell ; cbn.
        is_iso.
  Defined.

  Definition cod_cleaving_lwhisker_cartesian
    : lwhisker_cartesian (cod_disp_bicat B).
  Proof.
    intro ; intros.
    apply cod_invertible_is_cartesian_2cell.
    apply inv_B.
  Defined.

  Definition cod_cleaving_rwhisker_cartesian
    : rwhisker_cartesian (cod_disp_bicat B).
  Proof.
    intro ; intros.
    apply cod_invertible_is_cartesian_2cell.
    apply inv_B.
  Defined.

  Definition cod_cleaving_lwhisker_opcartesian
    : lwhisker_opcartesian (cod_disp_bicat B).
  Proof.
    intro ; intros.
    apply cod_invertible_is_opcartesian_2cell ; apply inv_B.
  Defined.

  Definition cod_cleaving_rwhisker_opcartesian
    : rwhisker_opcartesian (cod_disp_bicat B).
  Proof.
    intro ; intros.
    apply cod_invertible_is_opcartesian_2cell ; apply inv_B.
  Defined.

  Definition cod_cleaving_of_bicats
    : cleaving_of_bicats (cod_disp_bicat B).
  Proof.
    repeat split.
    - exact cod_local_cleaving.
    - exact cod_global_cleaving.
    - exact cod_cleaving_lwhisker_cartesian.
    - exact cod_cleaving_rwhisker_cartesian.
  Defined.
End CodomainCleaving.

Definition cod_fibration_one_types
  : cleaving_of_bicats (cod_disp_bicat one_types).
Proof.
  use cod_cleaving_of_bicats.
  - exact one_type_2cell_iso.
  - exact one_types_has_pb.
Defined.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e194m33_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition mul :
  { mul : feBW_loose -> feBW_loose -> feBW_tight
  | forall a b, phiBW_tight (mul a b) = F.mul (phiBW_loose a) (phiBW_loose b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_mul ().
  Show Ltac Profile.
Time Defined.

Print Assumptions mul.


Require Import List.
Import ListNotations.

Set Implicit Arguments.

Section list_util.
  Variables A : Type.

  Lemma NoDup_app3_not_in_2 :
    forall (xs ys zs : list A) b,
      NoDup (xs ++ ys ++ b :: zs) ->
      In b ys ->
      False.
  Proof using.
    intros.
    rewrite <- app_ass in *.
    apply NoDup_remove_2 in H.
    rewrite app_ass in *.
    auto 10 with *.
  Qed.
End list_util.


(** * Identity natural transformation *)
Require Import Category.Core Functor.Core NaturalTransformation.Core NaturalTransformation.Paths.
Require Import PathGroupoids.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope morphism_scope.
Local Open Scope path_scope.
Local Open Scope natural_transformation_scope.

Section identity.
  Variables C D : PreCategory.

  (** There is an identity natrual transformation.  We create a number
      of variants, for various uses. *)
  Section generalized.
    Variables F G : Functor C D.
    Hypothesis HO : object_of F = object_of G.
    Hypothesis HM : transport (fun GO => forall s d,
                                           morphism C s d
                                           -> morphism D (GO s) (GO d))
                              HO
                              (morphism_of F)
                    = morphism_of G.

    Local Notation CO c := (transport (fun GO => morphism D (F c) (GO c))
                                      HO
                                      (identity (F c))).

    Definition generalized_identity_commutes s d (m : morphism C s d)
    : CO d o F _1 m = G _1 m o CO s.
    Proof.
      case HM. case HO.
      exact (left_identity _ _ _ _ @ (right_identity _ _ _ _)^).
    Defined.

    Definition generalized_identity_commutes_sym s d (m : morphism C s d)
    : G _1 m o CO s = CO d o F _1 m.
    Proof.
      case HM. case HO.
      exact (right_identity _ _ _ _ @ (left_identity _ _ _ _)^).
    Defined.

    Definition generalized_identity
    : NaturalTransformation F G
      := Build_NaturalTransformation'
           F G
           (fun c => CO c)
           generalized_identity_commutes
           generalized_identity_commutes_sym.
  End generalized.

  Global Arguments generalized_identity_commutes / .
  Global Arguments generalized_identity_commutes_sym / .
  Global Arguments generalized_identity F G !HO !HM / .

  Section generalized'.
    Variables F G : Functor C D.
    Hypothesis H : F = G.

    Definition generalized_identity'
    : NaturalTransformation F G.
    Proof.
      apply (generalized_identity
               F G
               (ap (@object_of C D) H)).
      case H.
      reflexivity.
    Defined.
  End generalized'.

  Definition identity (F : Functor C D)
  : NaturalTransformation F F
    := Eval simpl in @generalized_identity F F 1 1.

  Global Arguments generalized_identity' F G !H / .
End identity.

Global Arguments generalized_identity_commutes : simpl never.
Global Arguments generalized_identity_commutes_sym : simpl never.

Module Export NaturalTransformationIdentityNotations.
  Notation "1" := (identity _) : natural_transformation_scope.
End NaturalTransformationIdentityNotations.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

From Coq Require Import List Lt Wf_nat Inverse_Image.
From Buchberger Require Import Bar OpenIndGoodRel Monomials.

Set Default Proof Using "Type".

Definition DecRel (A : Type) (R : Rel A) :=
  forall x y : A, {R x y} + {~ R x y}.

(* A computational double induction rule *)
Theorem nat_double_ind_set :
 forall R : nat -> nat -> Type,
 (forall n : nat, R 0 n) ->
 (forall n : nat, R (S n) 0) ->
 (forall n m : nat, R n m -> R (S n) (S m)) -> forall n m : nat, R n m.
Proof.
simple induction n; simple induction m; auto.
Qed.

Lemma dec_lt : DecRel nat lt.
Proof.
red in |- *; intros; pattern x, y in |- *.
apply nat_double_ind_set; auto with arith.
intros n; case n; auto with arith.
intros n m H'; case H'; auto with arith.
Qed.

Definition NegRel (A : Type) (R : Rel A) (x y : A) := ~ R x y.

Definition ProdRel (A B : Type) (R : Rel A) (S : Rel B)
  (x y : A * B) := R (fst x) (fst y) /\ S (snd x) (snd y).

Section Dickson.
Variable A B : Type.
Variable lt : Rel A.
Variable R : Rel B.
Variable wfgt : well_founded lt.
Variable declt : DecRel A lt.
Variable wR : WR B R.

Definition leq (a b : A) := ~ lt b a.

Definition GBarlR := GRBar (A * B) (ProdRel A B leq R).

Definition sndL := map (fun p : A * B => snd p).

Definition MinD :=
  Min (A * B) (fun p q : A * B => lt (fst p) (fst q)) (ProdRel A B leq R).

Definition prod_lt (a b : A * B) := lt (fst a) (fst b).

Lemma WFlem1 : well_founded prod_lt.
Proof using wfgt.
unfold prod_lt in |- *; apply wf_inverse_image with (B := A); auto.
Qed.

Lemma lem0 :
 forall (l : list (A * B)) (a : A * B),
 ExistsL B (fun x : B => R x (snd a)) (sndL l) -> MinD l -> GBarlR (a :: l).
Proof using declt.
intros l; elim l; simpl in |- *; auto.
intros a H' H'0; inversion H'.
intros a l0 H' a0 H'0 H'1; inversion H'0.
simpl in H0; simpl in H1; simpl in H.
case (declt (fst a0) (fst a)); intros LtE.
change (GBarlR ((a0 :: nil) ++ (a :: nil) ++ l0)) in |- *; auto.
red in |- *; apply monGRBar; simpl in |- *; auto.
inversion H'1; auto.
red in |- *; red in |- *; apply Base.
apply FoundG.
apply FoundE.
unfold ProdRel in |- *; split; auto.
change (GBarlR ((a0 :: nil) ++ (a :: nil) ++ l0)) in |- *; auto.
red in |- *; apply monGRBar; simpl in |- *; auto.
inversion H'1; simpl in |- *; auto.
apply H'; auto.
Qed.

Lemma lem1aux :
 forall l : list B,
 GoodR B R l -> forall us : list (A * B), l = sndL us -> MinD us -> GBarlR us.
Proof using declt.
intros l; elim l; auto.
intros H'; inversion H'.
intros a l0 H' H'0; inversion H'0; auto.
intros us; elim us; simpl in |- *; auto.
intros; discriminate.
intros a1 l2 H'1 H'2 H'3; inversion H'2.
apply lem0; auto.
rewrite <- H2; rewrite <- H3; auto.
inversion H'3; auto.
intros us; elim us; unfold sndL in |- *; simpl in |- *; auto.
intros; discriminate.
intros a1 l2 H'1 H'2 H'3; inversion H'2.
change (GBarlR (nil ++ (a1 :: nil) ++ l2)) in |- *.
red in |- *; apply monGRBar; simpl in |- *; auto.
apply H'; auto.
inversion H'3; auto.
Qed.

Lemma lem1 :
 forall us : list (A * B), GoodR B R (sndL us) -> MinD us -> GBarlR us.
Proof using declt.
intros us H' H'0.
apply lem1aux with (l := sndL us); auto.
Qed.

Lemma keylem :
 forall bs : list B,
 GRBar B R bs ->
 forall us : list (A * B), bs = sndL us -> MinD us -> GBarlR us.
Proof using wfgt declt.
intros bs H'; elim H'; auto.
intros l H'0 us H'1 H'2.
apply lem1; auto.
rewrite <- H'1; auto.
intros l H'0 H'1 us H'2 H'3; red in |- *.
apply OpenInd with (lt := prod_lt); auto.
exact WFlem1.
intros a H'4.
apply H'1 with (a := snd a); auto.
rewrite H'2; auto.
Qed.

Lemma keylem_cor : WR (A * B) (ProdRel A B leq R).
Proof using wfgt wR declt.
red in |- *; apply keylem with (bs := nil (A:=B)); auto.
red in |- *; auto.
apply nmin; auto.
Qed.

End Dickson.

(* Now we transfer this result to another representation: *)

Lemma leq2le : forall a b : nat, leq nat lt a b -> a <= b.
Proof.
intros.
destruct (Nat.le_gt_cases a b) as [Hlt|Hlt].
auto.
unfold leq in H.
unfold not in H.
case (H Hlt).
Qed.

Definition jj : forall d : nat, mon d :=
  (fix jj (d : nat) : mon d :=
     match d as n return (mon n) with
     | O => n_0
     | S n => c_n n 0 (jj n)
     end).

Theorem jjProp1 : forall (d : nat) (m : mon d), d = 0 -> m = jj d.
Proof.
intros d m; elim m.
simpl in |- *; auto.
intros d0 n m0 H' H'0; inversion H'0.
Qed.

Theorem jjProp2 : jj 0 = n_0.
Proof.
simpl in |- *; auto.
Qed.

Theorem monO_n0 : forall m : mon 0, m = n_0.
Proof.
intros m; rewrite <- jjProp2.
apply jjProp1; auto.
Qed.

Lemma zRV_WR : WR (mon 0) (mdiv 0).
Proof.
red in |- *; red in |- *; apply Ind.
intros a; apply Ind.
intros a0; rewrite (monO_n0 a); rewrite (monO_n0 a0).
apply Base; auto.
apply FoundG; auto.
apply FoundE; auto.
apply mdiv_nil; auto.
Qed.

Definition monLift (n : nat) (p : nat * mon n) :=
  match p with
  | (x, m) => c_n n x m
  end.

Lemma monLift_lem :
 forall (n0 : nat) (b : mon (S n0)) (x : nat) (m : mon n0),
 b = c_n n0 x m -> {a : nat * mon n0 | b = monLift n0 a}.
Proof.
intros.
rewrite H.
exists (x, m).
simpl in |- *.
auto.
Qed.

Lemma dicksonL : forall n : nat, WR (mon n) (mdiv n).
Proof.
intro.
unfold WR in |- *.
elim n.
apply zRV_WR.
intros.
cut (WR (nat * mon n0) (ProdRel nat (mon n0) (leq nat lt) (mdiv n0)));
 [ intros | exact (keylem_cor nat (mon n0) lt (mdiv n0) lt_wf dec_lt X) ].
unfold WR in X0.
change (GRBar (mon (S n0)) (mdiv (S n0)) (map (monLift n0) nil)) in |- *.
apply subRelGRBar with (R := ProdRel nat (mon n0) (leq nat lt) (mdiv n0));
 auto.
intros a b; case a; case b; simpl in |- *; auto.
intros n1 m n2 m0 H'; inversion H'; auto.
apply mdiv_cons; auto.
apply leq2le; auto.
intros b; exists (pmon1 (S n0) b, pmon2 (S n0) b); simpl in |- *.
apply sym_eq; apply proj_ok; auto.
Qed.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export RelationPairs SetoidList Orders EqualitiesFacts.

Set Implicit Arguments.
Unset Strict Implicit.

(** * Specialization of results about lists modulo. *)

Module OrderedTypeLists (O:OrderedType).

Local Notation In:=(InA O.eq).
Local Notation Inf:=(lelistA O.lt).
Local Notation Sort:=(sort O.lt).
Local Notation NoDup:=(NoDupA O.eq).

Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
Proof. intros. rewrite <- H; auto. Qed.

Lemma ListIn_In : forall l x, List.In x l -> In x l.
Proof. exact (In_InA O.eq_equiv). Qed.

Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l.
Proof. exact (InfA_ltA O.lt_strorder). Qed.

Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l.
Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed.

Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x.
Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed.

Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l.
Proof. exact (@In_InfA O.t O.lt). Qed.

Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l.
Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed.

Lemma Inf_alt :
 forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)).
Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed.

Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed.

Hint Resolve ListIn_In Sort_NoDup Inf_lt.
Hint Immediate In_eq Inf_lt.

End OrderedTypeLists.

(** * Results about keys and data as manipulated in the future MMaps. *)

Module KeyOrderedType(O:OrderedType).
 Include KeyDecidableType(O). (* provides eqk, eqke *)

 Local Notation key:=O.t.
 Local Open Scope signature_scope.

 Definition ltk {elt} : relation (key*elt) := O.lt @@1.

 Hint Unfold ltk.

 (* ltk is a strict order *)

 Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _.

 Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt).
 Proof. unfold eqk, ltk; auto with *. Qed.

 Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt).
 Proof. eapply subrelation_proper; eauto with *. Qed.

 (* Additional facts *)

 Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt).
 Proof. apply pair_compat. Qed.

 Section Elt.
  Variable elt : Type.
  Implicit Type p q : key*elt.
  Implicit Type l m : list (key*elt).

  Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q.
  Proof.
  intros LT EQ; rewrite EQ in LT.
  elim (StrictOrder_Irreflexive _ LT).
  Qed.

  Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q.
  Proof.
  intros LT EQ; rewrite EQ in LT.
  elim (StrictOrder_Irreflexive _ LT).
  Qed.

  Notation Sort := (sort ltk).
  Notation Inf := (lelistA ltk).

  Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l.
  Proof. now intros <-. Qed.

  Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l.
  Proof. apply InfA_ltA; auto with *. Qed.

  Hint Immediate Inf_eq.
  Hint Resolve Inf_lt.

  Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p.
  Proof. apply SortA_InfA_InA; auto with *. Qed.

  Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l ->  ~In k l.
  Proof.
    intros; red; intros.
    destruct H1 as [e' H2].
    elim (@ltk_not_eqk (k,e) (k,e')).
    eapply Sort_Inf_In; eauto.
    repeat red; reflexivity.
  Qed.

  Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l.
  Proof. apply SortA_NoDupA; auto with *. Qed.

  Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q.
  Proof.
   intros; invlist sort; eapply Sort_Inf_In; eauto.
  Qed.

  Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) ->
      ltk p q \/ eqk p q.
  Proof.
    intros; invlist InA; auto with relations.
    left; apply Sort_In_cons_1 with l; auto with relations.
  Qed.

  Lemma Sort_In_cons_3 x l k e :
    Sort ((k,e)::l) -> In x l -> ~O.eq x k.
  Proof.
    intros; invlist sort; red; intros.
    eapply Sort_Inf_NotIn; eauto using In_eq.
  Qed.

 End Elt.

 Hint Resolve ltk_not_eqk ltk_not_eqke.
 Hint Immediate Inf_eq.
 Hint Resolve Inf_lt.
 Hint Resolve Sort_Inf_NotIn.

End KeyOrderedType.


(*
  This is exercises for <Software Foundations> CH14.
  Author : Brethland, Late 2019.
*)

From Coq Require Import omega.Omega.
From Coq Require Import Arith.Arith.
Add LoadPath "C:\Users\ycy12\Documents\Workspace\LEARNING-STUFF\Coq".
Load Coq19.

Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).
Open Scope imp_scope.
Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (l !-> aeval st a1 ; st)
      | c1 ;; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.
Close Scope imp_scope.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None => None
  | Some st => Some (st X, st Y, st Z)
  end.

Compute
     (test_ceval empty_st
         (X ::= 2 ;;
          IFB X ≤ 1
            THEN Y ::= 3
            ELSE Z ::= 4
          FI)).

Definition pup_to_n' : com :=
  (Y ::= 0;;
    WHILE ~(X = 0) DO
      Y ::= Y + X;;
      X ::= X - 1
    END).

Example pup_to_n_1 :
  test_ceval (X !-> 5) pup_to_n'
  = Some (0, 15, 0).
Proof. auto. Qed.

Definition peven : com :=
  (Z ::= 0 ;;
    WHILE ~(X = 0) DO
      IFB Z = 0 THEN
        Z ::= 1
      ELSE Z ::= 0 FI ;;
      X ::= X - 1
    END).

Theorem ceval_step__ceval: ∀c st st',
      (∃i, ceval_step st c i = Some st') →
      st =[ c ]⇒ st'.
Proof.
  intros c st st' H.
  inversion H as [i E].
  clear H.
  generalize dependent st'.
  generalize dependent st.
  generalize dependent c.
  induction i;intros.
  - inversion E.
  - destruct c;inversion E;subst.
    + constructor.
    + constructor. auto.
    + destruct (ceval_step st c1 i) eqn:Hei.
      ++ apply E_Seq with s. apply IHi. auto. apply IHi. auto.
      ++ inversion H0.
    + destruct (beval st b) eqn:Heb.
      ++ constructor. auto. apply IHi. auto.
      ++ apply E_IfFalse. auto. apply IHi. auto.
    + destruct (beval st b) eqn:Heb.
      ++ destruct (ceval_step st c i) eqn : Hei.
          apply E_WhileTrue with s. auto. apply IHi.
          auto. apply IHi. auto. inversion H0.
      ++ inversion H0. apply E_WhileFalse. subst. auto.
Qed.

Theorem ceval_step_more: ∀i1 i2 st st' c,
  i1 ≤ i2 →
  ceval_step st c i1 = Some st' →
  ceval_step st c i2 = Some st'.
Proof.
  induction i1; intros.
  - inversion H0.
  - destruct i2 as [|i2']. inversion H.
    assert (Hle': i1 ≤ i2') by omega.
    destruct c.
    + auto.
    + inversion H0. auto.
    + simpl in *. destruct (ceval_step st c1 i1) eqn:Hei.
      ++ apply (IHi1 i2') in Hei. rewrite Hei. auto. auto.
      ++ inversion H0.
    + simpl in *. destruct (beval st b). auto. auto.
    + simpl in *. destruct (beval st b); try auto.
      destruct (ceval_step st c i1) eqn:Hei.
      ++ apply (IHi1 i2') in Hei. rewrite Hei. auto. auto.
      ++ inversion H0.
Qed.

Theorem ceval__ceval_step: ∀c st st',
      st =[ c ]⇒ st' →
      ∃i, ceval_step st c i = Some st'.
Proof.
  intros c st st' Hce.
  induction Hce.
  - exists 10. auto.
  - exists 10. simpl. rewrite H. auto.
  - destruct IHHce1. destruct IHHce2.
    destruct x. inversion H.
    exists (S x + x0). simpl. destruct x0. inversion H0.
    assert ( H' : S x <= x + S x0) by omega.
    remember (ceval_step_more _ _ _ _ _ H' H) as H1.
    rewrite H1. clear HeqH1. clear H'. clear H1.
    assert (H' : S x0 <= x + S x0) by omega.
    apply (ceval_step_more _ _ _ _ _ H' H0).
  - destruct IHHce. destruct x. inversion H0.
    exists (1 + x + 1). simpl. rewrite H.
    assert (H' : S x <= x + 1) by omega.
    apply (ceval_step_more _ _ _ _ _ H' H0).
  - destruct IHHce. destruct x. inversion H0.
    exists (1 + x + 1). simpl. rewrite H.
    assert (H' : S x <= x + 1) by omega.
    apply (ceval_step_more _ _ _ _ _ H' H0).
  - exists 1. simpl. rewrite H. auto.
  - destruct IHHce1. destruct IHHce2. destruct x. inversion H0.
    exists (S x + x0). simpl. destruct x0. inversion H1.
    rewrite H. assert ( H' : S x <= x + S x0) by omega.
    remember (ceval_step_more _ _ _ _ _ H' H0) as H2.
    rewrite H2. clear HeqH2. clear H'. clear H2.
    assert (H' : S x0 <= x + S x0) by omega.
    apply (ceval_step_more _ _ _ _ _ H' H1).
Qed.

Theorem ceval_deterministic' : ∀c st st1 st2,
     st =[ c ]⇒ st1 →
     st =[ c ]⇒ st2 →
     st1 = st2.
Proof.
  intros c st st1 st2 He1 He2.
  apply ceval__ceval_step in He1.
  apply ceval__ceval_step in He2.
  inversion He1 as [i1 E1].
  inversion He2 as [i2 E2].
  apply ceval_step_more with (i2 := i1 + i2) in E1.
  apply ceval_step_more with (i2 := i1 + i2) in E2.
  rewrite E1 in E2. inversion E2. reflexivity.
  omega. omega. Qed.


(**

 Ahrens, Lumsdaine, Voevodsky, 2015

  Contents:

    - Definition of a category with families
    - Proof that reindexing forms a pullback

  The definition is based on Pitts, *Nominal Presentations of the Cubical Sets
  Model of Type Theory*, Def. 3.1:
  http://www.cl.cam.ac.uk/~amp12/papers/nompcs/nompcs.pdf (page=9)

  This file is very similar to [TypeTheory.OtherDefs.CwF_1]; the main difference is that here the functor of types is split up into its separate components, whereas there it is bundled into an actual functor.

*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.

(** * A "preview" of the definition *)

Module Record_Preview.

Reserved Notation "C ⟨ Γ ⟩" (at level 60).
Reserved Notation "C ⟨ Γ ⊢ A ⟩" (at level 60).
Reserved Notation "A {{ γ }}" (at level 30).
Reserved Notation "a ⟦ γ ⟧" (at level 30).
Reserved Notation "Γ ∙ A" (at level 35).
Reserved Notation "'π' A" (at level 20).
Reserved Notation "'ν' A" (at level 15).
Reserved Notation "γ ♯ a" (at level 25).

Record cwf_record : Type := {
  C : category ;
  type : C → UU     where "C ⟨ Γ ⟩" := (type Γ) ;
  term : ∏ Γ : C, C⟨Γ⟩ → UU     where "C ⟨ Γ ⊢ A ⟩" := (term Γ A) ;
  rtype : ∏ {Γ Γ' : C} (A : C⟨Γ⟩) (γ : Γ' --> Γ), C⟨Γ'⟩ where "A {{ γ }}" := (rtype A γ) ;
  rterm : ∏ {Γ Γ' : C} {A : C⟨Γ⟩} (a : C⟨Γ⊢A⟩) (γ : Γ' --> Γ),
          C⟨Γ'⊢ (A{{γ}})⟩   where "a ⟦ γ ⟧" := (rterm a γ) ;
  reindx_type_id : ∏ Γ (A : C⟨Γ⟩), A {{identity Γ}} = A ;
  reindx_type_comp : ∏  {Γ Γ' Γ''} (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') (A : C⟨Γ⟩),
          A {{γ';;γ}}
          =
          A{{γ}}{{γ'}} ;
  reindx_term_id : ∏ Γ (A : C⟨Γ⟩) (a : C⟨Γ⊢A⟩),
          a⟦identity Γ⟧
          =
          transportf (λ B, C⟨Γ ⊢ B⟩) (! (reindx_type_id _ _)) a ;
  reindx_term_comp : ∏ {Γ Γ' Γ''} (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') {A : C⟨Γ⟩} (a : C⟨Γ⊢A⟩),
          a⟦γ';;γ⟧
          =
          transportf (λ B, C⟨Γ'' ⊢ B⟩) (!(reindx_type_comp  _ _ _ )) (a⟦γ⟧⟦γ'⟧) ;
  comp_obj : ∏ Γ (A : C⟨Γ⟩), C where "Γ ∙ A" := (comp_obj Γ A) ;
  proj_mor : ∏ Γ (A : C⟨Γ⟩), Γ ∙ A --> Γ where "'π' A" := (proj_mor _ A) ;
  gen_element : ∏ Γ (A : C⟨Γ⟩), C⟨Γ∙A ⊢ A{{π _ }}⟩ where "'ν' A" := (gen_element _ A) ;
  pairing : ∏ Γ (A : C⟨Γ⟩) Γ' (γ : Γ' --> Γ)(a : C⟨Γ'⊢ A{{γ}}⟩), Γ' --> Γ∙A
     where "γ ♯ a" := (pairing _ _ _  γ a) ;
  cwf_law_1 : ∏ Γ (A : C ⟨Γ⟩) Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢ A{{γ}}⟩),
          (γ ♯ a) ;; (π _)
          =
          γ ;
  cwf_law_2 : ∏ Γ (A : C ⟨Γ⟩) Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢ A{{γ}}⟩),
          transportf (λ ι, C⟨Γ'⊢ A {{ι}}⟩) (cwf_law_1 Γ A Γ' γ a)
             (transportf (λ B, C⟨Γ'⊢ B⟩) (!reindx_type_comp (π _ )(γ ♯ a) _ )
                ((ν A) ⟦γ ♯ a⟧))
          =
          a
}.

End Record_Preview.

(** * Type and terms of a [CwF] *)
(**
 A [tt_category] comes with a types, written [C⟨Γ⟩],
   and terms [C⟨Γ ⊢ A⟩]
*)

Definition tt_structure (C : category) :=
  ∑ f : C → UU, ∏ c : C, f c → UU.

Definition type {C : category} (TT : tt_structure C) : C → UU := pr1 TT.

Notation "C ⟨ Γ ⟩" := (type C Γ) (at level 60).
  (* \< and \> in Agda input method *)

Definition term {CC : category} (C : tt_structure CC) : ∏ Γ : CC, C⟨Γ⟩ → UU := pr2 C.

Notation "C ⟨ Γ ⊢ A ⟩" := (term C Γ A) (at level 60).
  (* \<, \>, and \|- or \vdash *)

(** * Reindexing of types [A{{γ]] and terms [a⟦γ⟧] along a morphism [γ : Γ' --> Γ] *)

Definition reindx_structure {CC : category}(C : tt_structure CC) :=
   ∑ (rtype : ∏ {Γ Γ' : CC} (A : C⟨Γ⟩) (γ : Γ' --> Γ), C⟨Γ'⟩),
        ∏ (Γ Γ' : CC) (A : C⟨Γ⟩) (a : C⟨Γ⊢A⟩) (γ : Γ' --> Γ), C⟨Γ'⊢rtype A γ⟩.

Definition tt_reindx_struct (CC : category) : UU
 :=
   ∑ C : tt_structure CC, reindx_structure C.

Coercion tt_from_tt_reindx CC (C : tt_reindx_struct CC) : tt_structure _ := pr1 C.
Coercion reindx_from_tt_reindx CC (C : tt_reindx_struct CC) : reindx_structure _ := pr2 C.

Definition rtype {CC : category}{C : tt_reindx_struct CC}
  : ∏ {Γ Γ' : CC} (A : C⟨Γ⟩) (γ : Γ' --> Γ), C⟨Γ'⟩
:=
   pr1 (pr2 C).

Notation "A {{ γ }}" := (rtype A γ) (at level 30).

Definition rterm {CC : category}{C : tt_reindx_struct CC}
  : ∏ {Γ Γ' : CC} {A : C⟨Γ⟩}  (a : C⟨Γ⊢A⟩) (γ : Γ' --> Γ), C⟨Γ'⊢ A {{γ}} ⟩
:=
    pr2 (pr2 C).

Notation "a ⟦ γ ⟧" := (rterm a γ) (at level 40).

(** *  Reindexing laws *)

(** Reindexing for types *)
Definition reindx_laws_type {CC : category}(C : tt_reindx_struct CC) : UU :=
    (∏ Γ (A : C⟨Γ⟩), A {{identity Γ}} = A) ×
    (∏ Γ Γ' Γ'' (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') (A : C⟨Γ⟩), A {{γ';;γ}} = A{{γ}}{{γ'}}).

(** Reindexing for terms needs transport along reindexing for types *)
Definition reindx_laws_terms {CC : category} {C : tt_reindx_struct CC}
    (T : reindx_laws_type C) :=
    (∏ Γ (A : C⟨Γ⟩) (a : C⟨Γ⊢A⟩), a⟦identity Γ⟧ =
          transportf (λ B, C⟨Γ ⊢ B⟩) (!pr1 T _ _) a) ×
    (∏ Γ Γ' Γ'' (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') (A : C⟨Γ⟩) (a : C⟨Γ⊢A⟩),
            a⟦γ';;γ⟧ =
          transportf (λ B, C⟨Γ'' ⊢ B⟩) (!pr2 T _ _ _ _ _ _ )  (a⟦γ⟧⟦γ'⟧)).

(** Package of reindexing for types and terms *)
Definition reindx_laws {CC : category} (C : tt_reindx_struct CC)  : UU :=
   ∑ T : reindx_laws_type C, reindx_laws_terms T.

Definition reindx_type_id {CC : category} {C : tt_reindx_struct CC}
    (T : reindx_laws C)
  : ∏ Γ (A : C⟨Γ⟩), A {{identity Γ}} = A
:=
  pr1 (pr1 T).

Definition reindx_type_comp {CC : category} {C : tt_reindx_struct CC}
    (T : reindx_laws C)
   {Γ Γ' Γ''} (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') (A : C⟨Γ⟩)
  : A {{γ';;γ}} = A{{γ}}{{γ'}}
:=
   pr2 (pr1 T) _ _ _ _ _ _ .

Definition reindx_term_id {CC : category} {C : tt_reindx_struct CC}
   (T : reindx_laws C)
  : ∏ Γ (A : C⟨Γ⟩) (a : C⟨Γ⊢A⟩), a⟦identity Γ⟧ =
          transportf (λ B, C⟨Γ ⊢ B⟩) (!pr1 (pr1 T) _ _) a
:= pr1 (pr2 T).

Definition reindx_term_comp {CC : category} {C : tt_reindx_struct CC}
    (T : reindx_laws C)
  : ∏ {Γ Γ' Γ''} (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') {A : C⟨Γ⟩} (a : C⟨Γ⊢A⟩),
            a⟦γ';;γ⟧ =
          transportf (λ B, C⟨Γ'' ⊢ B⟩) (!pr2 (pr1 T) _ _ _ _ _ _ )  (a⟦γ⟧⟦γ'⟧)
:=
   pr2 (pr2 T).

(** * Comprehension structure *)

(** ** Comprehension object and projection *)

Definition comp_1_struct {CC : category} (C : tt_reindx_struct CC) : UU
:=
  ∏ Γ (A : C⟨Γ⟩), ∑ ΓA, ΓA --> Γ.

Definition tt_reindx_comp_1_struct (CC : category) : UU
  :=
     ∑ C : tt_reindx_struct CC, comp_1_struct C.

Coercion tt_reindx_from_tt_reindx_comp_1 (CC : category) (C : tt_reindx_comp_1_struct CC)
  : tt_reindx_struct _ := pr1 C.

Definition comp_obj {CC : category} {C : tt_reindx_comp_1_struct CC} (Γ : CC) (A : C⟨Γ⟩)
  : CC
:=  (pr1 (pr2 C Γ A)).
Notation "Γ ∙ A" := (comp_obj Γ A) (at level 35).
  (* \. in Adga mode *)

Definition proj_mor {CC : category} {C : tt_reindx_comp_1_struct CC}
      {Γ : CC} (A : C⟨Γ⟩)
  : Γ ∙ A  --> Γ
:= (pr2 (pr2 C Γ A)).

Notation "'π' A" := (proj_mor A) (at level 20).

(** ** Generic element and pairing *)
Definition comp_2_struct {CC : category} (C : tt_reindx_comp_1_struct CC) : UU
:=
   ∏ Γ (A : C⟨Γ⟩),
     C⟨(Γ∙A) ⊢ (A {{π A}}) ⟩ ×
     (∏ Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢A{{γ}}⟩), Γ' --> Γ∙A).

Definition tt_reindx_type_struct (CC : category) : UU
:=
   ∑ C : tt_reindx_comp_1_struct CC, comp_2_struct C.

Coercion tt_reindx_comp_1_from_tt_reindx_comp (CC : category) (C : tt_reindx_type_struct CC)
  : tt_reindx_comp_1_struct _ := pr1 C.

Definition gen_elem  {CC : category} {C : tt_reindx_type_struct CC}
    {Γ : CC} (A : C⟨Γ⟩)
  : C⟨Γ∙A  ⊢ A{{π _ }}⟩
 :=
   pr1 (pr2 C Γ A).

Notation "'ν' A" := (gen_elem A) (at level 15).

Definition pairing  {CC : category} {C : tt_reindx_type_struct CC}
    {Γ : CC} {A : C⟨Γ⟩} {Γ'} (γ : Γ' --> Γ) (a : C⟨Γ'⊢A{{γ}}⟩)
  : Γ' --> Γ∙A
:= pr2 (pr2 C Γ A) Γ' γ a.

Notation "γ ♯ a" := (pairing γ a) (at level 25).
  (* \# in Adga mode *)

(** ** Laws satisfied by the comprehension structure *)

Definition comp_laws_1_2  {CC : category} {C : tt_reindx_type_struct CC}
   (L : reindx_laws C) : UU :=
   ∏ Γ (A : C ⟨Γ⟩) Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢ A{{γ}}⟩),
        ∑ h : (γ ♯ a) ;; (π _ ) = γ,
           transportf (λ ι, C⟨Γ'⊢ A {{ι}}⟩) h
             (transportf (λ B, C⟨Γ'⊢ B⟩) (!reindx_type_comp L (π _ )(γ ♯ a) _ )
               ((ν _ ) ⟦γ ♯ a⟧)) = a.

Definition comp_law_3  {CC : category} {C : tt_reindx_type_struct CC}
     (L : reindx_laws C) : UU
:=
   ∏ Γ (A : C ⟨Γ⟩) Γ' Γ'' (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') (a : C⟨Γ'⊢ A{{γ}}⟩),
    γ' ;; (γ ♯ a)
    =
    (γ' ;; γ) ♯ (transportf (λ B, C⟨Γ''⊢ B⟩) (!reindx_type_comp L γ γ' _ ) (a⟦γ'⟧)).

Definition comp_law_4  {CC : category} {C : tt_reindx_type_struct CC}
    (L : reindx_laws C) : UU
:=
   ∏ Γ (A : C⟨Γ⟩), π A ♯ ν A = identity _ .

Definition cwf_laws {CC : category} (C : tt_reindx_type_struct CC)
   :=
    (∑ T : reindx_laws C,
       (comp_laws_1_2 T × comp_law_3 T × comp_law_4 T))
    × (∏ Γ, isaset (C⟨Γ⟩))
    × ∏ Γ (A : C⟨Γ⟩), isaset (C⟨Γ⊢ A⟩).

(** * Definition of category with families *)
(** A category with families [cwf] is
  - a category
  - with type-and-term structure
  - with reindexing
  - with comprehension structure
  - satisfying the comprehension laws
  - where types and terms are hsets
*)

Definition cwf_struct (CC : category) : UU
  := ∑ C : tt_reindx_type_struct CC, cwf_laws C.

(** * Various access functions to the components *)
(** Also a few generalizations are proved, providing variants with
    generalized proofs of identity of types, terms (which form hsets)
*)

Coercion cwf_data_from_cwf_struct (CC : category) (C : cwf_struct CC) : _ CC := pr1 C.
Coercion cwf_laws_from_cwf_struct (CC : category) (C : cwf_struct CC) : cwf_laws C := pr2 C.

Coercion reindx_laws_from_cwf_struct (CC : category) (C : cwf_struct CC)
  : reindx_laws C
  := pr1 (pr1 (pr2 C)).

Definition cwf_comp_laws {CC : category} (C : cwf_struct CC)
  : (comp_laws_1_2 C × comp_law_3 C × comp_law_4 C)
  := pr2 (pr1 (pr2 C)).

Definition cwf_types_isaset {CC : category} (C : cwf_struct CC) Γ : isaset (C⟨Γ⟩)
  := pr1 (pr2 (pr2 C)) Γ.

Definition cwf_terms_isaset  {CC : category} (C : cwf_struct CC) : ∏ Γ A, isaset (C⟨Γ ⊢ A⟩)
  := pr2 (pr2 (pr2 C)).

Definition cwf_law_1 {CC : category} (C : cwf_struct CC)
  Γ (A : C ⟨Γ⟩) Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢ A{{γ}}⟩)
  : (γ ♯ a) ;; (π _) = γ
  :=  pr1 (pr1 (cwf_comp_laws C) Γ A Γ' γ a).

Definition cwf_law_2 {CC : category} (C : cwf_struct CC)
  Γ (A : C ⟨Γ⟩) Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢ A{{γ}}⟩)
  : transportf (λ ι, C⟨Γ'⊢ A {{ι}}⟩) (cwf_law_1 C Γ A Γ' γ a)
    (transportf (λ B, C⟨Γ'⊢ B⟩) (!reindx_type_comp C (π _)(γ ♯ a) _ )
      ((ν A) ⟦γ ♯ a⟧))
    = a
  := pr2 ((pr1 (cwf_comp_laws C)) Γ A Γ' γ a).

Definition cwf_law_2_gen {CC : category} (C : cwf_struct CC)
  Γ (A : C ⟨Γ⟩) Γ' (γ : Γ' --> Γ) (a : C⟨Γ'⊢ A{{γ}}⟩)
  :  ∏ (p : (A {{π A}}) {{γ ♯ a}} = A {{γ ♯ a;; π A}}) (p0 : γ ♯ a;; π A = γ),
   transportf (λ ι : Γ' --> Γ, C ⟨ Γ' ⊢ A {{ι}} ⟩) p0
     (transportf (λ B : C ⟨ Γ' ⟩, C ⟨ Γ' ⊢ B ⟩) p (ν A ⟦ γ ♯ a ⟧)) = a.
Proof.
  intros p p'.
  etrans; [ | apply cwf_law_2].
  match goal with | [ |- _ = transportf _ ?p1 _ ] => assert (T : p' = p1) end.
  { apply homset_property. }
  rewrite T; clear T. apply maponpaths.
  match goal with | [ |- _ = transportf _ ?p1 _ ] => assert (T : p = p1) end.
  { apply (cwf_types_isaset C). }
  rewrite T; apply idpath.
Qed.

Definition cwf_law_3 {CC : category} (C : cwf_struct CC) : comp_law_3 C
  :=  pr1 (pr2 (cwf_comp_laws C)).

Definition cwf_law_3_gen {CC : category} (C : cwf_struct CC)
  (Γ : CC) (A : C ⟨ Γ ⟩) (Γ' Γ'' : CC) (γ : Γ' --> Γ) (γ' : Γ'' --> Γ')
  (a : C ⟨ Γ' ⊢ A {{γ}} ⟩) (p : (A {{γ}}) {{γ'}} = A {{γ';; γ}}):
   γ';; γ ♯ a =
   (γ';; γ) ♯ transportf (λ B : C ⟨ Γ'' ⟩, C ⟨ Γ'' ⊢ B ⟩) p (a ⟦ γ' ⟧).
Proof.
  etrans. apply cwf_law_3.
  apply maponpaths.
  match goal with |[|- transportf _ ?e _ = _ ] => assert (T : e = p) end.
  { apply (cwf_types_isaset C). }
  rewrite T; apply idpath.
Qed.

Definition cwf_law_4 {CC : category} (C : cwf_struct CC) : comp_law_4 C
  := pr2 (pr2 (cwf_comp_laws C)).

Ltac imp := apply impred; intro.

Lemma isPredicate_cwf_laws (CC : category)
: isPredicate (@cwf_laws CC).
Proof.
  intros T.
  apply isofhlevelsn.
  intro H.
  set (X:= tpair _ T H : cwf_struct CC).
  apply (isofhleveltotal2).
  - apply isofhleveltotal2.
    + apply isofhleveltotal2.
      *
        {
          apply isofhleveltotal2.
          - do 2 imp.
            apply (cwf_types_isaset X).
          - intros.
            do 6 imp. apply (cwf_types_isaset X).
        }
      * intros.
        {
          apply isofhleveltotal2.
          - do 3 imp.
            apply (cwf_terms_isaset X).
          - intros. do 7 imp.
            apply (cwf_terms_isaset X).
        }
    + intros.
      repeat (apply isofhleveldirprod).
      *
        {
          do 5 imp.
          apply (isofhleveltotal2 1).
          - apply homset_property.
          - intros. apply (cwf_terms_isaset X).
        }
      * do 7 imp. apply homset_property.
      * do 2 imp. apply homset_property.
  - intros.
    apply isofhleveldirprod.
    + do 1 imp. apply isapropisaset.
    + do 2 imp. apply isapropisaset.
Qed.

(** * Lemmas about CwFs, in particular that reindexing forms pullback *)

Section CwF_lemmas.

Generalizable Variable CC.
Context `{C : cwf_struct CC}.

Lemma map_to_comp_as_pair_cwf {Γ} {A : C⟨Γ⟩} {Γ'} (f : Γ' --> Γ∙A)
  :   (f ;; π A) ♯ (transportb _ (reindx_type_comp C _ _ _) ((gen_elem A)⟦f⟧))
      =
      f.
Proof.
  sym.
  etrans.
  apply (!id_right _ ).
  etrans.
  refine (maponpaths (fun g => f ;; g) (!cwf_law_4 _ _ _)).
  apply cwf_law_3.
Qed.

Lemma retype_term_pi {Γ} {A A' : C ⟨ Γ ⟩ } (p : A = A') (t : C ⟨ Γ ∙ A ⊢ A {{π A}}⟩ ) :
  transportf (λ B : C ⟨Γ⟩, C ⟨ Γ ∙ A ⊢ B {{π A}}⟩) p t
  =
  transportf (term C (Γ ∙  A)) (maponpaths (λ x : C⟨Γ⟩, x {{π A}}) p) t.
Proof.
  destruct p.
  apply idpath.
Defined.

Lemma pairing_mapeq {Γ} {A : C⟨Γ⟩} {Γ'} (f f' : Γ' --> Γ) (e : f = f')
                     (a : C ⟨ Γ' ⊢ A {{f}} ⟩)
  : f ♯ a
    =
    f' ♯ (transportf (fun B => C⟨Γ' ⊢ B⟩ ) (maponpaths _ e) a).
Proof.
  destruct e. apply idpath.
Qed.

Lemma pairing_mapeq_gen {Γ} {Γ'} (f f' : Γ' --> Γ) {A : C⟨Γ⟩} (a : C ⟨ Γ' ⊢ A {{f}} ⟩)
         (e : f = f') (p : A {{f}} = A {{f'}})
  : f ♯ a
    =
    f' ♯ (transportf (fun B => C⟨Γ' ⊢ B⟩ ) p a).
Proof.
  assert (T : p = (maponpaths _ e)).
  { apply (cwf_types_isaset C). }
  rewrite T.
  apply pairing_mapeq.
Qed.

Lemma rterm_typeeq {Γ} {A A': C⟨Γ⟩} (e : A = A') {Γ'} (f : Γ' --> Γ) (x : C ⟨ Γ ⊢ A ⟩)
  : transportf _ (maponpaths (fun b => b{{f}}) e) (x⟦f⟧)
    = (transportf _ e x) ⟦f⟧.
Proof.
  destruct e. apply idpath.
Qed.

Lemma transportf_rtype_mapeq {Γ} {A : C⟨Γ⟩} {Γ'} (f f' : Γ' --> Γ) (e : f = f')
                     (t : C ⟨ Γ' ⊢ A{{f}} ⟩)
  : transportf (fun g => C ⟨ Γ' ⊢ A{{g}} ⟩) e t
  = transportf _ (maponpaths (fun g => A{{g}}) e) t.
Proof.
  apply functtransportf.
Qed.

Lemma rterm_mapeq {Γ} {A : C⟨Γ⟩} {Γ'} {f f' : Γ' --> Γ} (e : f = f') (t : C ⟨ Γ ⊢ A ⟩)
  : t ⟦ f ⟧
  = transportb _ (maponpaths (fun g => A{{g}}) e) (t ⟦ f'⟧ ).
Proof.
  destruct e. apply idpath.
Qed.

(* A slightly odd statement, but very often useful.

   TODO: consider naming!
   TODO: try to use in proofs, instead of [transport_f_f] *)
Lemma term_typeeq_transport_lemma {Γ} {A A' A'': C ⟨ Γ ⟩} (e : A = A'') (e' : A' = A'')
  (x : C ⟨ Γ ⊢ A ⟩) (x' : C ⟨ Γ ⊢ A' ⟩)
  : transportf _ (e @ !e') x = x'
  -> transportf _ e x = transportf _ e' x'.
Proof.
  apply transportf_comp_lemma.
Qed.

Lemma term_typeeq_transport_lemma_2 {Γ} {A : C ⟨ Γ ⟩} (e : A = A)
  {x x' : C ⟨ Γ ⊢ A ⟩}
  : x = x'
  -> transportf _ e x = x'.
Proof.
  apply transportf_comp_lemma_hset.
  apply cwf_types_isaset.
Qed.

Lemma reindx_term_comp' {Γ Γ' Γ''} (γ : Γ' --> Γ) (γ' : Γ'' --> Γ') {A} (a : C ⟨ Γ ⊢ A ⟩)
  : transportf _ (reindx_type_comp C _ _ _) (a ⟦ γ' ;; γ ⟧)
  = ((a ⟦ γ ⟧) ⟦ γ' ⟧).
Proof.
  eapply pathscomp0.
    apply maponpaths, (reindx_term_comp C).
  rew_trans_@.
  apply term_typeeq_transport_lemma_2.
  apply idpath.
Qed.

(* TODO: consider giving this instead of current [cwf_law_2] ? *)
Definition cwf_law_2' Γ (A : C ⟨ Γ ⟩) Γ' (γ : Γ' --> Γ) (a : C ⟨ Γ' ⊢ A{{γ}} ⟩)
  : (ν A) ⟦γ ♯ a⟧
  = transportf _ (reindx_type_comp C _ _ _)
      (transportb _ (maponpaths (fun g => A{{g}}) (cwf_law_1 _ _ _ _ _ _))
        a).
Proof.
  eapply pathscomp0.
  2: { apply maponpaths, maponpaths. exact (cwf_law_2 _ _ _ _ γ a). }
  apply pathsinv0.
  rew_trans_@.
  etrans. apply maponpaths, transportf_rtype_mapeq.
  rew_trans_@.
  (* TODO: try simplyfying with [term_typeeq_transport_lemma] *)
  refine (@maponpaths _ _ (fun e => transportf _ e _) _ (idpath _) _).
  apply cwf_types_isaset.
Qed.

Definition pairing_transport  {Γ} {A A' : C⟨Γ⟩} (e : A = A')
  {Γ'} (γ : Γ' --> Γ) (a : C ⟨Γ'⊢A{{γ}}⟩)
: (γ ♯ a) ;; idtoiso (maponpaths (fun (B : C⟨Γ⟩) => Γ∙B) e)
= (γ ♯ (transportf (fun B => C ⟨ Γ' ⊢ B {{γ}} ⟩) e a)).
Proof.
  destruct e; simpl.
  apply id_right.
Defined.

Definition q_cwf {Γ} (A : C ⟨ Γ ⟩ ) {Γ'} (f : Γ' --> Γ)
  : (comp_obj  Γ' (A{{f}})) --> (Γ ∙ A).
Proof.
  set (T:= @pairing _ C).
  apply T with (γ := π _ ;; f).
  refine (transportb (term C (Γ' ∙ (A {{f}})) ) (reindx_type_comp C _ _ A) _).
  apply gen_elem.
Defined.

Definition dpr_q_cwf
  {Γ} (A : C ⟨ Γ ⟩)
  {Γ'} (f : Γ' --> Γ)
: (q_cwf A f) ;; (π A) = (π (A{{f}})) ;; f.
Proof.
  unfold q_cwf.
  apply cwf_law_1.
Qed.

Lemma rterm_univ {Γ} {A : C ⟨ Γ ⟩} {Γ'} (f : Γ' --> Γ)
  : ν (A{{f}})
   = transportf _ (reindx_type_comp C _ _ _)
       (transportf _ (maponpaths (fun g => A{{g}}) (dpr_q_cwf A f))
         (transportb _ (reindx_type_comp C _ _ _)
            ((ν A)⟦q_cwf A f⟧))).
Proof.
  sym.
  rew_trans_@.
  etrans.
  - apply maponpaths.
    apply cwf_law_2'.
  - rew_trans_@.
    apply term_typeeq_transport_lemma_2.
    apply idpath.
Qed.

(** The biggest work is in showing that the square of dependent projections/reindexings is a pullback.

We split this up into several lemmas:

- construction of the pullback pairing function;
- proof that projections applied to the pairing recover the original maps;
- and proof that the pairing map is the unique such map.

*)

Definition dpr_q_pbpairing_cwf_aux
  {Γ} (A : C ⟨ Γ ⟩)
  {Γ'} (f : Γ' --> Γ)
  {X} (h : X --> Γ ∙ A) (k : X --> Γ') (H : h ;; π A = k ;; f)
: C ⟨ X ⊢ (A {{f}}) {{k}} ⟩
:= (transportf _ (reindx_type_comp C _ _ _)
      (transportf (fun g => C ⟨ X ⊢ A{{g}} ⟩) H
        (transportf _ (!reindx_type_comp C _ _ _)
          ((ν A)⟦h⟧)))).

Definition dpr_q_pbpairing_commutes
  {Γ} (A : C ⟨ Γ ⟩)
  {Γ'} (f : Γ' --> Γ)
  {X} (h : X --> Γ ∙ A) (k : X --> Γ') (H : h ;; π A = k ;; f)
  (hk := @pairing _ C Γ' (A{{f}}) X k (dpr_q_pbpairing_cwf_aux A f h k H))
: (hk ;; q_cwf A f = h) × (hk ;; π (A{{f}}) = k).
Proof.
  split. 2: { apply cwf_law_1. }
  unfold q_cwf.
  etrans.
  2: { apply map_to_comp_as_pair_cwf. }
  etrans.
  { apply cwf_law_3. }
  assert ((k ♯ (dpr_q_pbpairing_cwf_aux A f h k H)) ;; (π (A {{f}}) ;; f)
          = h ;; π A) as e1.
    eapply pathscomp0. apply assoc.
    refine (_ @ !H).
    apply (maponpaths (fun g => g ;; f)).
    apply cwf_law_1.
  eapply pathscomp0. apply (pairing_mapeq _ _ e1).
  apply maponpaths.
  eapply pathscomp0. apply transport_f_f.
  eapply pathscomp0. apply maponpaths. refine (! rterm_typeeq _ _ _).
  eapply pathscomp0. apply transport_f_f.
  eapply pathscomp0. apply maponpaths, cwf_law_2'.
  rew_trans_@.
  eapply pathscomp0. apply maponpaths, transportf_rtype_mapeq.
  repeat (eapply pathscomp0; [ apply transport_f_f | ]).
  refine (maponpaths (fun e => transportf _ e _) _).
  apply cwf_types_isaset.
Qed.

Definition dpr_q_pbpairing_cwf
  {Γ} (A : C ⟨ Γ ⟩)
  {Γ'} (f : Γ' --> Γ)
  {X} (h : X --> Γ ∙ A) (k : X --> Γ') (H : h ;; π A = k ;; f)
: ∑ (hk : X --> Γ' ∙ (A{{f}})),
    ( hk ;; q_cwf A f = h
    × hk ;; π (A{{f}}) = k).
Proof.
  exists (@pairing _ C Γ' (A{{f}}) X k (dpr_q_pbpairing_cwf_aux A f h k H)).
  apply dpr_q_pbpairing_commutes.
Defined.

Definition dpr_q_pbpairing_cwf_mapunique
  {Γ} (A : C⟨Γ⟩)
  {Γ'} (f : Γ' --> Γ)
  {X} {h : X --> Γ ∙ A} {k : X --> Γ'} (H : h ;; π A = k ;; f)
  (hk : X --> Γ' ∙ (A {{f}}))
  (e2 : hk ;; q_cwf A f = h)
  (e1 : hk ;; π (A{{f}}) = k)
: hk = pr1 (dpr_q_pbpairing_cwf A f h k H).
Proof.
  eapply pathscomp0.
    eapply pathsinv0. apply map_to_comp_as_pair_cwf.
  eapply pathscomp0.
    apply (pairing_mapeq _ _ e1 _).
  simpl. apply maponpaths.
  eapply pathscomp0.
    apply maponpaths, maponpaths.
    apply (@maponpaths (C ⟨ Γ' ∙ (A{{f}}) ⊢ A{{f}}{{π (A{{f}})}} ⟩) _ (fun t => t ⟦hk⟧)).
    apply rterm_univ.
  eapply pathscomp0.
    apply maponpaths, maponpaths.
    eapply pathscomp0.
      symmetry. apply rterm_typeeq.
    apply maponpaths.
    eapply pathscomp0.
      symmetry. apply rterm_typeeq.
    apply maponpaths.
    eapply pathscomp0.
      symmetry. apply rterm_typeeq.
    apply maponpaths.
    symmetry. apply reindx_term_comp'.
  apply term_typeeq_transport_lemma.
  repeat (eapply pathscomp0; [ apply transport_f_f |]).
  eapply pathscomp0.
    apply maponpaths, (rterm_mapeq e2).
  eapply pathscomp0. apply transport_f_f.
  eapply pathscomp0.
  2: { symmetry. apply transportf_rtype_mapeq. }
  repeat apply term_typeeq_transport_lemma.
  apply term_typeeq_transport_lemma_2.
  apply idpath.
Qed.

Definition dpr_q_pbpairing_cwf_unique
  {Γ} (A : C⟨Γ⟩)
  {Γ'} (f : Γ' --> Γ)
  {X} (h : X --> Γ ∙ A) (k : X --> Γ') (H : h ;; π A = k ;; f)
  (t : ∑ hk : X --> Γ' ∙ (A {{f}}),
       (hk ;; q_cwf A f = h) × (hk ;; π (A{{f}}) = k))
: t = dpr_q_pbpairing_cwf A f h k H.
Proof.
  destruct t as [hk [e2 e1]].
  refine (@total2_paths_f _ _ (tpair _ hk (tpair _ e2 e1)) _
    (dpr_q_pbpairing_cwf_mapunique A f H hk e2 e1) _).
  unshelve refine (total2_paths_f _ _); apply homset_property.
Qed.

Lemma is_pullback_reindx_cwf : ∏ (Γ : CC) (A : C⟨Γ⟩) (Γ' : CC)
   (f : Γ' --> Γ),
   isPullback (dpr_q_cwf A f).
Proof.
  intros.
  apply make_isPullback; try assumption.
  intros e h k H.
  exists (dpr_q_pbpairing_cwf _ _ h k H).
  apply dpr_q_pbpairing_cwf_unique.
Defined.

End CwF_lemmas.


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

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Cartesian.
(** Title "Categories." *)
Comments "Some basic category theory.".
Section Category_def.
Section Category_def1.
Variable Ob : Type.
Variable Hom : Ob -> Ob -> Setoid.
Variable
  Hom_comp : forall a b c : Ob, MAP (cart (Hom b c) (Hom a b)) (Hom a c).
Variable Hom_id : forall a : Ob, Hom a a.

Definition Hom_comp_assoc :=
  forall (a b c d : Ob) (f : Hom a b) (g : Hom b c) (h : Hom c d),
  Equal (Hom_comp a b d (couple (Hom_comp b c d (couple h g)) f))
    (Hom_comp a c d (couple h (Hom_comp a b c (couple g f)))).

Definition Hom_comp_unit_l :=
  forall (a b : Ob) (f : Hom a b),
  Equal (Hom_comp a b b (couple (Hom_id b) f)) f.

Definition Hom_comp_unit_r :=
  forall (a b : Ob) (f : Hom a b),
  Equal (Hom_comp a a b (couple f (Hom_id a))) f.
End Category_def1.

Record category : Type :=
  {Ob :> Type;
   Hom : Ob -> Ob -> Setoid;
   Hom_comp : forall a b c : Ob, MAP (cart (Hom b c) (Hom a b)) (Hom a c);
   Hom_id : forall a : Ob, Hom a a;
   Hom_comp_assoc_prf : Hom_comp_assoc Hom_comp;
   Hom_comp_unit_l_prf : Hom_comp_unit_l Hom_comp Hom_id;
   Hom_comp_unit_r_prf : Hom_comp_unit_r Hom_comp Hom_id}.
Section Category_comp.
Variable C : category.

Definition comp_hom (a b c : C) (g : Hom b c) (f : Hom a b) :=
  Hom_comp a b c (couple g f).

Lemma comp_hom_compatible :
 forall (a b c : C) (x x' : Hom b c) (y y' : Hom a b),
 Equal x x' -> Equal y y' -> Equal (comp_hom x y) (comp_hom x' y').
intros a b c x x' y y' H' H'0; try assumption.
unfold comp_hom in |- *; auto with algebra.
Qed.

Lemma comp_hom_assoc :
 forall (a b c d : C) (f : Hom a b) (g : Hom b c) (h : Hom c d),
 Equal (comp_hom (comp_hom h g) f) (comp_hom h (comp_hom g f)).
exact (Hom_comp_assoc_prf (c:=C)).
Qed.

Lemma comp_hom_unit_l :
 forall (a b : C) (f : Hom a b), Equal (comp_hom (Hom_id b) f) f.
exact (Hom_comp_unit_l_prf (c:=C)).
Qed.

Lemma comp_hom_unit_r :
 forall (a b : C) (f : Hom a b), Equal (comp_hom f (Hom_id a)) f.
exact (Hom_comp_unit_r_prf (c:=C)).
Qed.
End Category_comp.
Hint Resolve comp_hom_compatible comp_hom_assoc comp_hom_unit_l
  comp_hom_unit_r: algebra.
Section Full_subcat_def.
Variable C : category.
Variable C' : Type.
Variable i : C' -> C.

Definition fsubcat_Hom (a b : C') := Hom (i a) (i b).

Definition fsubcat_Hom_comp :
  forall a b c : C',
  MAP (cart (fsubcat_Hom b c) (fsubcat_Hom a b)) (fsubcat_Hom a c).
intros a b c; try assumption.
exact (Hom_comp (i a) (i b) (i c)).
Defined.

Definition fsubcat_Hom_id (a : C') := Hom_id (i a).

Definition full_subcat : category.
apply
 (Build_category (Ob:=C') (Hom:=fsubcat_Hom) (Hom_comp:=fsubcat_Hom_comp)
    (Hom_id:=fsubcat_Hom_id)).
red in |- *.
unfold fsubcat_Hom, fsubcat_Hom_comp in |- *; simpl in |- *.
intros a b c d f g h; try assumption.
apply (Hom_comp_assoc_prf (c:=C)).
red in |- *.
unfold fsubcat_Hom, fsubcat_Hom_comp, fsubcat_Hom_id in |- *; simpl in |- *.
intros a b f; try assumption.
apply (Hom_comp_unit_l_prf (c:=C)).
red in |- *.
unfold fsubcat_Hom, fsubcat_Hom_comp, fsubcat_Hom_id in |- *; simpl in |- *.
intros a b f; try assumption.
apply (Hom_comp_unit_r_prf (c:=C)).
Defined.
End Full_subcat_def.
End Category_def.
Hint Resolve comp_hom_compatible comp_hom_assoc comp_hom_unit_l
  comp_hom_unit_r: algebra.