(*********************************************************************************

 Colimits of categories

 Contents:
 1. Initial object
 2. Coproducts
 3. Extensivity
 4. Kleisli objects

 *********************************************************************************)

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.categories.StandardCategories.
Require Import UniMath.CategoryTheory.categories.EilenbergMoore.
Require Import UniMath.CategoryTheory.categories.KleisliCategory.
Require Import UniMath.CategoryTheory.CategorySum.
Require Import UniMath.CategoryTheory.IsoCommaCategory.
Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.KleisliCategory.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Examples.Reindexing.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Subcategory.Core.
Require Import UniMath.CategoryTheory.Subcategory.Full.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.DisplayedBicats.Examples.MonadsLax.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.Examples.MorphismsInBicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Core.Examples.OpMorBicat.
Require Import UniMath.Bicategories.Colimits.Initial.
Require Import UniMath.Bicategories.Colimits.Coproducts.
Require Import UniMath.Bicategories.Colimits.Extensive.
Require Import UniMath.Bicategories.Colimits.KleisliObjects.
Require Import UniMath.Bicategories.Limits.Pullbacks.
Require Import UniMath.Bicategories.Limits.PullbackFunctions.
Require Import UniMath.Bicategories.Limits.CommaObjects.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfUnivCatsLimits.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInBicatOfUnivCats.
Require Import UniMath.Bicategories.Monads.Examples.MonadsInOp1Bicat.

Local Open Scope cat.

(**
 1. Initial object
 *)
Definition empty_category_is_biinitial
  : @is_biinitial bicat_of_univ_cats empty_category.
Proof.
  use make_is_biinitial.
  - exact (λ C, functor_from_empty (pr1 C)).
  - exact (λ _ F G, nat_trans_from_empty F G).
  - abstract
      (intros Y f g α β ;
       use nat_trans_eq ; [ apply homset_property | ] ;
       exact (λ z, fromempty z)).
Defined.

Definition biinitial_obj_bicat_of_univ_cats
  : biinitial_obj bicat_of_univ_cats
  := empty_category ,, empty_category_is_biinitial.

Definition strict_biinitial_univ_cats
  : @is_strict_biinitial_obj bicat_of_univ_cats empty_category.
Proof.
  refine (empty_category_is_biinitial ,, _).
  intros C F.
  use equiv_to_adjequiv.
  simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
  - exact (functor_from_empty _).
  - apply nat_trans_to_empty.
  - exact (nat_trans_from_empty _ _).
  - use is_nat_z_iso_to_is_invertible_2cell.
    apply nat_trans_to_empty_is_nat_z_iso.
  - use is_nat_z_iso_to_is_invertible_2cell.
    intro z.
    apply (fromempty z).
Defined.

(**
 2. Coproducts
 *)
Definition bincoprod_cocone_bicat_of_univ_cats
           (C₁ C₂ : bicat_of_univ_cats)
  : bincoprod_cocone C₁ C₂.
Proof.
  use make_bincoprod_cocone.
  - exact (bincoprod_of_univalent_category C₁ C₂).
  - exact (inl_functor (pr1 C₁) (pr1 C₂)).
  - exact (inr_functor (pr1 C₁) (pr1 C₂)).
Defined.

Section BincoprodUMP.
  Context (C₁ C₂ : bicat_of_univ_cats).

  Definition has_bincoprod_ump_1_bicat_of_univ_cats
    : bincoprod_ump_1 (bincoprod_cocone_bicat_of_univ_cats C₁ C₂).
  Proof.
    intros Q.
    use make_bincoprod_1cell.
    - exact (sum_of_functors
               (bincoprod_cocone_inl Q)
               (bincoprod_cocone_inr Q)).
    - use nat_z_iso_to_invertible_2cell.
      exact (sum_of_functor_inl_nat_z_iso
               (bincoprod_cocone_inl Q)
               (bincoprod_cocone_inr Q)).
    - use nat_z_iso_to_invertible_2cell.
      exact (sum_of_functor_inr_nat_z_iso
               (bincoprod_cocone_inl Q)
               (bincoprod_cocone_inr Q)).
  Defined.

  Definition has_bincoprod_ump_2_bicat_of_univ_cats_unique
             {Q : bicat_of_univ_cats}
             {F G : bincoprod_cocone_bicat_of_univ_cats C₁ C₂ --> Q}
             (α : bincoprod_cocone_inl (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · F
                  ==>
                  bincoprod_cocone_inl (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · G)
             (β : bincoprod_cocone_inr (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · F
                  ==>
                  bincoprod_cocone_inr (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) · G)
    : isaprop
        (∑ γ,
         bincoprod_cocone_inl (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) ◃ γ = α
         ×
         bincoprod_cocone_inr (bincoprod_cocone_bicat_of_univ_cats C₁ C₂) ◃ γ = β).
  Proof.
    use invproofirrelevance.
    intros φ₁ φ₂.
    use subtypePath ; [ intro ; apply isapropdirprod ; apply cellset_property | ].
    use nat_trans_eq ; [ apply homset_property | ].
    intro z ; induction z as [ x | y ].
    - exact (nat_trans_eq_pointwise (pr12 φ₁) x @ !(nat_trans_eq_pointwise (pr12 φ₂) x)).
    - exact (nat_trans_eq_pointwise (pr22 φ₁) y @ !(nat_trans_eq_pointwise (pr22 φ₂) y)).
  Qed.

  Definition has_bincoprod_ump_2_bicat_of_univ_cats
    : bincoprod_ump_2 (bincoprod_cocone_bicat_of_univ_cats C₁ C₂).
  Proof.
    intros Q F G α β.
    use iscontraprop1.
    - exact (has_bincoprod_ump_2_bicat_of_univ_cats_unique α β).
    - simple refine (_ ,, _ ,, _).
      + exact (sum_of_nat_trans α β).
      + exact (sum_of_nat_trans_inl α β).
      + exact (sum_of_nat_trans_inr α β).
  Defined.

  Definition has_bincoprod_ump_bicat_of_univ_cats
    : has_bincoprod_ump (bincoprod_cocone_bicat_of_univ_cats C₁ C₂).
  Proof.
    split.
    - exact has_bincoprod_ump_1_bicat_of_univ_cats.
    - exact has_bincoprod_ump_2_bicat_of_univ_cats.
  Defined.
End BincoprodUMP.

Definition bincoprod_bicat_of_univ_cats
  : has_bincoprod bicat_of_univ_cats
  := λ C₁ C₂,
     bincoprod_cocone_bicat_of_univ_cats C₁ C₂
     ,,
     has_bincoprod_ump_bicat_of_univ_cats C₁ C₂.

Definition bicat_of_univ_cats_with_biinitial_bincoprod
  : bicat_with_biinitial_bincoprod
  := bicat_of_univ_cats ,, biinitial_obj_bicat_of_univ_cats ,, bincoprod_bicat_of_univ_cats.

(**
 3. Extensivity
 *)
Section DisjointCoproducts.
  Context (C₁ C₂ : bicat_of_univ_cats_with_biinitial_bincoprod).

  Notation "∁" := bicat_of_univ_cats_with_biinitial_bincoprod.

  Let R := @biinitial_comma_cone
             ∁
             C₁ C₂
             (pr1 (bincoprod_of ∁ C₁ C₂))
             (inl_functor _ _)
             (inr_functor _ _).

  Section OneCell.
    Context (Q : @comma_cone
                   ∁
                   C₁ C₂
                   (pr1 (bincoprod_of ∁ C₁ C₂))
                   (inl_functor _ _)
                   (inr_functor _ _)).

    Definition bicat_of_univ_cats_inl_inr_1cell_functor_data
      : functor_data (pr11 Q) (pr11 R).
    Proof.
      use make_functor_data.
      - exact (λ q, pr1 (comma_cone_cell Q) q).
      - exact (λ q _ _, fromempty (pr1 (comma_cone_cell Q) q)).
    Defined.

    Definition bicat_of_univ_cats_inl_inr_1cell_functor_is_functor
      : is_functor bicat_of_univ_cats_inl_inr_1cell_functor_data.
    Proof.
      split.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
      - intros q ? ? ? ?.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
    Qed.

    Definition bicat_of_univ_cats_inl_inr_1cell_functor
      : Q --> R.
    Proof.
      use make_functor.
      - exact bicat_of_univ_cats_inl_inr_1cell_functor_data.
      - exact bicat_of_univ_cats_inl_inr_1cell_functor_is_functor.
    Defined.

    Definition bicat_of_univ_cats_inl_inr_1cell_pr1_nat_trans
      : bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr1 R
        ==>
        comma_cone_pr1 Q.
    Proof.
      use make_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
      - abstract
          (intros q ? ? ;
           exact (fromempty (pr1 (comma_cone_cell Q) q))).
    Defined.

    Definition bicat_of_univ_cats_inl_inr_1cell_pr1
      : nat_z_iso
          (bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr1 R)
          (comma_cone_pr1 Q).
    Proof.
      use make_nat_z_iso.
      - exact bicat_of_univ_cats_inl_inr_1cell_pr1_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
    Defined.

    Definition bicat_of_univ_cats_inl_inr_1cell_pr2_nat_trans
      : bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr2 R
        ==>
        comma_cone_pr2 Q.
    Proof.
      use make_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
      - abstract
          (intros q ? ? ;
           exact (fromempty (pr1 (comma_cone_cell Q) q))).
    Defined.

    Definition bicat_of_univ_cats_inl_inr_1cell_pr2
      : nat_z_iso
          (bicat_of_univ_cats_inl_inr_1cell_functor · comma_cone_pr2 R)
          (comma_cone_pr2 Q).
    Proof.
      use make_nat_z_iso.
      - exact bicat_of_univ_cats_inl_inr_1cell_pr2_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
    Defined.

    Definition bicat_of_univ_cats_inl_inr_1cell
      : comma_1cell Q R.
    Proof.
      use make_comma_1cell.
      + exact bicat_of_univ_cats_inl_inr_1cell_functor.
      + use nat_z_iso_to_invertible_2cell.
        exact bicat_of_univ_cats_inl_inr_1cell_pr1.
      + use nat_z_iso_to_invertible_2cell.
        exact bicat_of_univ_cats_inl_inr_1cell_pr2.
      + abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intro q ;
           exact (fromempty (pr1 (comma_cone_cell Q) q))).
    Defined.
  End OneCell.

  Definition bicat_of_univ_cats_inl_inr
    : has_comma_ump R.
  Proof.
    split.
    - exact bicat_of_univ_cats_inl_inr_1cell.
    - intros Q φ ψ α β p.
      use iscontraprop1.
      + abstract
          (use invproofirrelevance ;
           intros τ₁ τ₂ ;
           use subtypePath ;
           [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
           use nat_trans_eq ;
           [ apply homset_property | ] ;
           intros q ;
           exact (fromempty (pr1 φ q))).
      + simple refine (_ ,, _ ,, _).
        * use make_nat_trans.
          ** intros q.
             exact (fromempty (pr1 φ q)).
          ** abstract
               (intros q ? ? ;
                exact (fromempty (pr1 φ q))).
        * abstract
            (use nat_trans_eq ; [ apply homset_property | ] ;
             intros q ;
             exact (fromempty (pr1 φ q))).
        * abstract
            (use nat_trans_eq ; [ apply homset_property | ] ;
             intros q ;
             exact (fromempty (pr1 φ q))).
  Defined.

  Let R' := @biinitial_comma_cone
              ∁
              C₂ C₁
              (pr1 (bincoprod_of ∁ C₁ C₂))
              (inr_functor _ _)
              (inl_functor _ _).

  Section OneCell.
    Context (Q : @comma_cone
                   ∁
                   C₂ C₁
                   (pr1 (bincoprod_of ∁ C₁ C₂))
                   (inr_functor _ _)
                   (inl_functor _ _)).

    Definition bicat_of_univ_cats_inr_inl_1cell_functor_data
      : functor_data (pr11 Q) (pr11 R').
    Proof.
      use make_functor_data.
      - exact (λ q, pr1 (comma_cone_cell Q) q).
      - exact (λ q _ _, fromempty (pr1 (comma_cone_cell Q) q)).
    Defined.

    Definition bicat_of_univ_cats_inr_inl_1cell_functor_is_functor
      : is_functor bicat_of_univ_cats_inr_inl_1cell_functor_data.
    Proof.
      split.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
      - intros q ? ? ? ?.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
    Qed.

    Definition bicat_of_univ_cats_inr_inl_1cell_functor
      : Q --> R.
    Proof.
      use make_functor.
      - exact bicat_of_univ_cats_inr_inl_1cell_functor_data.
      - exact bicat_of_univ_cats_inr_inl_1cell_functor_is_functor.
    Defined.

    Definition bicat_of_univ_cats_inr_inl_1cell_pr1_nat_trans
      : bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr1 R'
        ==>
        comma_cone_pr1 Q.
    Proof.
      use make_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
      - abstract
          (intros q ? ? ;
           exact (fromempty (pr1 (comma_cone_cell Q) q))).
    Defined.

    Definition bicat_of_univ_cats_inr_inl_1cell_pr1
      : nat_z_iso
          (bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr1 R')
          (comma_cone_pr1 Q).
    Proof.
      use make_nat_z_iso.
      - exact bicat_of_univ_cats_inr_inl_1cell_pr1_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
    Defined.

    Definition bicat_of_univ_cats_inr_inl_1cell_pr2_nat_trans
      : bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr2 R'
        ==>
        comma_cone_pr2 Q.
    Proof.
      use make_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
      - abstract
          (intros q ? ? ;
           exact (fromempty (pr1 (comma_cone_cell Q) q))).
    Defined.

    Definition bicat_of_univ_cats_inr_inl_1cell_pr2
      : nat_z_iso
          (bicat_of_univ_cats_inr_inl_1cell_functor · comma_cone_pr2 R')
          (comma_cone_pr2 Q).
    Proof.
      use make_nat_z_iso.
      - exact bicat_of_univ_cats_inr_inl_1cell_pr2_nat_trans.
      - intro q.
        exact (fromempty (pr1 (comma_cone_cell Q) q)).
    Defined.

    Definition bicat_of_univ_cats_inr_inl_1cell
      : comma_1cell Q R'.
    Proof.
      use make_comma_1cell.
      + exact bicat_of_univ_cats_inr_inl_1cell_functor.
      + use nat_z_iso_to_invertible_2cell.
        exact bicat_of_univ_cats_inr_inl_1cell_pr1.
      + use nat_z_iso_to_invertible_2cell.
        exact bicat_of_univ_cats_inr_inl_1cell_pr2.
      + abstract
          (use nat_trans_eq ; [ apply homset_property | ] ;
           intro q ;
           exact (fromempty (pr1 (comma_cone_cell Q) q))).
    Defined.
  End OneCell.

  Definition bicat_of_univ_cats_inr_inl
    : has_comma_ump R'.
  Proof.
    split.
    - exact bicat_of_univ_cats_inr_inl_1cell.
    - intros Q φ ψ α β p.
      use iscontraprop1.
      + abstract
          (use invproofirrelevance ;
           intros τ₁ τ₂ ;
           use subtypePath ;
           [ intro ; apply isapropdirprod ; apply cellset_property | ] ;
           use nat_trans_eq ;
           [ apply homset_property | ] ;
           intros q ;
           exact (fromempty (pr1 φ q))).
      + simple refine (_ ,, _ ,, _).
        * use make_nat_trans.
          ** intros q.
             exact (fromempty (pr1 φ q)).
          ** abstract
               (intros q ? ? ;
                exact (fromempty (pr1 φ q))).
        * abstract
            (use nat_trans_eq ; [ apply homset_property | ] ;
             intros q ;
             exact (fromempty (pr1 φ q))).
        * abstract
            (use nat_trans_eq ; [ apply homset_property | ] ;
             intros q ;
             exact (fromempty (pr1 φ q))).
  Defined.
End DisjointCoproducts.

Section UniversalCoproducts.
  Notation "∁" := bicat_of_univ_cats_with_biinitial_bincoprod.

  Context {C₁ C₂ Z : ∁}
          (F : Z --> pr1 (bincoprod_of ∁ C₁ C₂)).

  Let ι₁ : C₁ --> pr1 (bincoprod_of ∁ C₁ C₂)
    := inl_functor (pr1 C₁) (pr1 C₂).
  Let ι₂ : C₂ --> pr1 (bincoprod_of ∁ C₁ C₂)
    := inr_functor (pr1 C₁) (pr1 C₂).

  Let κ₁ : bicat_of_univ_cats ⟦ univalent_iso_comma ι₁ F , Z ⟧
    := iso_comma_pr2 _ _.
  Let κ₂ : bicat_of_univ_cats ⟦ univalent_iso_comma ι₂ F , Z ⟧
    := iso_comma_pr2 _ _.

  Section UniversalCoproductsOne.
    Context (W : @bincoprod_cocone
                   bicat_of_univ_cats
                   (univalent_iso_comma ι₁ F)
                   (univalent_iso_comma ι₂ F)).

    Local Definition pb_of_sum_cats_ob
          {z : pr1 Z}
          {q : pr111 (bincoprod_of ∁ C₁ C₂)}
          (i : z_iso q (pr1 F z))
      : pr11 W.
    Proof.
      induction q as [ x | y ].
      - apply (bincoprod_cocone_inl W).
        exact ((x ,, z) ,, i).
      - apply (bincoprod_cocone_inr W).
        exact ((y ,, z) ,, i).
    Defined.

    Notation "'H₀'" := pb_of_sum_cats_ob.

    Local Definition pb_of_sum_cats_mor
          {z₁ z₂ : pr1 Z}
          (f : z₁ --> z₂)
          {q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)}
          (g : q₁ --> q₂)
          (i₁ : z_iso q₁ (pr1 F z₁))
          (i₂ : z_iso q₂ (pr1 F z₂))
          (p : g · i₂ = i₁ · # (pr1 F) f)
      : H₀ i₁ --> H₀ i₂.
    Proof.
      induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ] ; cbn.
      - use (#(pr1 (bincoprod_cocone_inl W))).
        exact ((g ,, f) ,, p).
      - exact (fromempty g).
      - exact (fromempty g).
      - use (#(pr1 (bincoprod_cocone_inr W))).
        exact ((g ,, f) ,, p).
    Defined.

    Local Notation "'H₁'" := pb_of_sum_cats_mor.

    Local Definition pb_of_sum_cats_mor_eq
          {z₁ z₂ : pr1 Z}
          (f : z₁ --> z₂)
          {q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)}
          {g₁ g₂ : q₁ --> q₂}
          (p : g₁ = g₂)
          (i₁ : z_iso q₁ (pr1 F z₁))
          (i₂ : z_iso q₂ (pr1 F z₂))
          (r₁ : g₁ · i₂ = i₁ · # (pr1 F) f)
          (r₂ : g₂ · i₂ = i₁ · # (pr1 F) f)
      : H₁ f g₁ i₁ i₂ r₁
        =
        H₁ f g₂ i₁ i₂ r₂.
    Proof.
      induction p ; cbn.
      apply maponpaths.
      apply homset_property.
    Qed.

    Local Definition pb_of_sum_cats_data
      : functor_data (pr1 Z) (pr11 W).
    Proof.
      use make_functor_data.
      - exact (λ z, H₀ (identity_z_iso (pr1 F z))).
      - refine (λ z₁ z₂ f,
                H₁ f (#(pr1 F) f) (identity_z_iso _) (identity_z_iso _) _).
        abstract
          (rewrite id_left, id_right ;
           apply idpath).
    Defined.

    Local Lemma pb_of_sum_cats_id
          (z : pr1 Z)
          (q : pr111 (bincoprod_of ∁ C₁ C₂))
          (i : z_iso q (pr1 F z))
          (p : id₁ q · i = i · # (pr1 F) (id₁ z))
      : H₁ (identity z) (identity q) i i p
        =
        identity _.
    Proof.
      induction q as [ x | y ] ; cbn.
      - refine (_ @ functor_id (bincoprod_cocone_inl W) _).
        apply maponpaths ; cbn.
        apply maponpaths.
        apply (homset_property
                 (pr111 (bincoprod_of ∁ C₁ C₂))
                 (inl x)
                 (pr1 F z)).
      - refine (_ @ functor_id (bincoprod_cocone_inr W) _).
        apply maponpaths ; cbn.
        apply maponpaths.
        apply (homset_property
                 (pr111 (bincoprod_of ∁ C₁ C₂))
                 (inr y)
                 (pr1 F z)).
    Qed.

    Local Lemma pb_of_sum_cats_comp
          {z₁ z₂ z₃ : pr1 Z}
          (f : z₁ --> z₂)
          (g : z₂ --> z₃)
          {q₁ q₂ q₃ : pr111 (bincoprod_of ∁ C₁ C₂)}
          (ff : q₁ --> q₂)
          (gg : q₂ --> q₃)
          (i₁ : z_iso q₁ (pr1 F z₁))
          (i₂ : z_iso q₂ (pr1 F z₂))
          (i₃ : z_iso q₃ (pr1 F z₃))
          (p₁ : ff · gg · i₃ = i₁ · # (pr1 F) (f · g))
          (p₂ : ff · i₂ = i₁ · # (pr1 F) f)
          (p₃ : gg · i₃ = i₂ · # (pr1 F) g)
      : H₁ (f · g) (ff · gg) i₁ i₃ p₁
        =
        H₁ f ff i₁ i₂ p₂ · H₁ g gg i₂ i₃ p₃.
    Proof.
      induction q₁ as [ x₁ | y₁ ] ;
      induction q₂ as [ x₂ | y₂ ] ;
      induction q₃ as [ x₃ | y₃ ] ; cbn.
      - refine (_ @ functor_comp _ _ _).
        apply maponpaths ; cbn.
        apply maponpaths.
        apply (homset_property (pr111 (bincoprod_of ∁ C₁ C₂)) (inl x₁)).
      - apply (fromempty gg).
      - apply (fromempty gg).
      - apply (fromempty ff).
      - apply (fromempty ff).
      - apply (fromempty gg).
      - apply (fromempty gg).
      - refine (_ @ functor_comp _ _ _).
        apply maponpaths ; cbn.
        apply maponpaths.
        apply (homset_property (pr111 (bincoprod_of ∁ C₁ C₂)) (inr y₁)).
    Qed.

    Local Lemma pb_of_sum_cats_is_functor
      : is_functor pb_of_sum_cats_data.
    Proof.
      split.
      - intro z ; cbn.
        simple refine (_ @ pb_of_sum_cats_id z (pr1 F z) (identity_z_iso _) _).
        + use pb_of_sum_cats_mor_eq.
          apply functor_id.
        + exact (id_left _ @ !(functor_id _ _) @ !(id_left _)).
      - intros z₁ z₂ z₃ f g ; cbn.
        simple refine (_ @ pb_of_sum_cats_comp _ _ _ _ _ _ _ _ _ _).
        + use pb_of_sum_cats_mor_eq.
          apply functor_comp.
        + refine (id_right _ @ !_ @ !(id_left _)).
          apply functor_comp.
    Qed.

    Local Definition pb_of_sum_cats
      : Z --> W.
    Proof.
      use make_functor.
      - exact pb_of_sum_cats_data.
      - exact pb_of_sum_cats_is_functor.
    Defined.

    Local Definition pb_of_cats_iso_mor
          (z : pr1 Z)
          (q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂))
          (i₁ : z_iso q₁ (pr1 F z))
          (i₂ : z_iso q₂ (pr1 F z))
          (k : q₁ --> q₂)
          (p : k · i₂ = i₁)
      : H₀ i₁ --> H₀ i₂.
    Proof.
      induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ].
      - cbn.
        refine (#(pr1 (bincoprod_cocone_inl W)) _).
        simple refine ((k ,, identity _) ,, _).
        abstract
          (simpl ;
           refine (_ @ maponpaths (λ z, i₁ · z) (!(functor_id F z))) ;
           refine (_ @ !(id_right _)) ;
           exact p).
      - apply fromempty.
        exact (pr1 i₁ · inv_from_z_iso i₂).
      - apply fromempty.
        exact (pr1 i₁ · inv_from_z_iso i₂).
      - cbn.
        refine (#(pr1 (bincoprod_cocone_inr W)) _).
        simple refine ((k ,, identity _) ,, _).
        abstract
          (simpl ;
           refine (_ @ maponpaths (λ z, i₁ · z) (!(functor_id F z))) ;
           refine (_ @ !(id_right _)) ;
           exact p).
    Defined.

    Local Definition pb_of_cats_is_z_iso
          (z : pr1 Z)
          (q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂))
          (i₁ : z_iso q₁ (pr1 F z))
          (i₂ : z_iso q₂ (pr1 F z))
          (k : z_iso q₁ q₂)
          (p : pr1 k · i₂ = i₁)
      : is_z_isomorphism (pb_of_cats_iso_mor z q₁ q₂ i₁ i₂ k p).
    Proof.
      induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ].
      - use functor_on_is_z_isomorphism.
        use is_z_iso_iso_comma.
        + cbn.
          use tpair; [ | split ].
          * exact (inv_from_z_iso k).
          * apply (z_iso_inv_after_z_iso k).
          * apply (z_iso_after_z_iso_inv k).
        + cbn.
          apply identity_is_z_iso.
      - apply fromempty.
        exact (pr1 i₁ · inv_from_z_iso i₂).
      - apply fromempty.
        exact (pr1 i₁ · inv_from_z_iso i₂).
      - use functor_on_is_z_isomorphism.
        use is_z_iso_iso_comma.
        + cbn.
          use tpair; [ | split ].
          * exact (inv_from_z_iso k).
          * apply (z_iso_inv_after_z_iso k).
          * apply (z_iso_after_z_iso_inv k).
        + cbn.
          apply identity_is_z_iso.
    Defined.

    Local Definition pb_of_sum_cats_z_iso
          (z : pr1 Z)
          (q : pr111 (bincoprod_of ∁ C₁ C₂))
          (i : z_iso q (pr1 F z))
      : z_iso (H₀ (identity_z_iso (pr1 F z))) (H₀ i).
    Proof.
      use make_z_iso'.
      - use pb_of_cats_iso_mor.
        + exact (z_iso_inv_from_z_iso i).
        + simpl.
          exact (z_iso_after_z_iso_inv i).
      - apply pb_of_cats_is_z_iso.
    Defined.

    Local Definition pb_of_sum_cats_inl_data
      : nat_trans_data
          (κ₁ ∙ pb_of_sum_cats)
          (pr1 (bincoprod_cocone_inl W))
      := λ z, pb_of_sum_cats_z_iso (pr21 z) _ (pr2 z).

    Local Lemma pb_of_sum_cats_nat_trans_help
          {z₁ z₂ : pr1 Z}
          (f : z₁ --> z₂)
          {q₁ q₂ q₃ q₄ : pr111 (bincoprod_of ∁ C₁ C₂)}
          (g₁ : q₁ --> q₂)
          (g₂ : q₂ --> q₃)
          (g₃ : q₃ --> q₄)
          (i₁ : z_iso q₁ (pr1 F z₁))
          (i₂ : z_iso q₂ (pr1 F z₁))
          (i₃ : z_iso q₃ (pr1 F z₂))
          (i₄ : z_iso q₄ (pr1 F z₂))
          (p₁ : g₁ · i₂ = i₁)
          (p₂ : g₃ · i₄ = i₃)
          (r₁ : g₁ · g₂ · i₃ = i₁ · # (pr1 F) f)
          (r₂ : g₂ · g₃ · i₄ = i₂ · # (pr1 F) f)
      : H₁ f (g₁ · g₂) i₁ i₃ r₁
        · pb_of_cats_iso_mor z₂ q₃ q₄ i₃ i₄ g₃ p₂
        =
        pb_of_cats_iso_mor z₁ q₁ q₂ i₁ i₂ g₁ p₁
        · H₁ f (g₂ · g₃) i₂ i₄ r₂.
    Proof.
      induction q₁, q₂, q₃, q₄ ; cbn.
      - refine (!functor_comp _ _ _ @ _ @ functor_comp _ _ _).
        apply maponpaths.
        use subtypePath ; [ intro ; apply homset_property | ].
        cbn.
        use pathsdirprod.
        + rewrite assoc.
          apply idpath.
        + rewrite id_left, id_right.
          apply idpath.
      - exact (fromempty g₃).
      - exact (fromempty g₂).
      - exact (fromempty g₂).
      - exact (fromempty g₂).
      - exact (fromempty g₂).
      - exact (fromempty g₁).
      - exact (fromempty g₁).
      - exact (fromempty g₁).
      - exact (fromempty g₁).
      - exact (fromempty g₁).
      - exact (fromempty g₁).
      - exact (fromempty g₂).
      - exact (fromempty g₂).
      - exact (fromempty g₃).
      - refine (!functor_comp _ _ _ @ _ @ functor_comp _ _ _).
        apply maponpaths.
        use subtypePath ; [ intro ; apply homset_property | ].
        cbn.
        use pathsdirprod.
        + rewrite assoc.
          apply idpath.
        + rewrite id_left, id_right.
          apply idpath.
    Qed.

    Local Lemma pb_of_sum_cats_inl_is_nat_trans
      : is_nat_trans _ _ pb_of_sum_cats_inl_data.
    Proof.
      intros x y f.
      cbn.
      simple refine (maponpaths (λ z, z · _) _
                     @ pb_of_sum_cats_nat_trans_help
                         (pr21 f)
                         (inv_from_z_iso (pr2 x))
                         (pr12 x · # (pr1 F) (pr21 f))
                         (inv_from_z_iso (pr2 y))
                         (identity_z_iso (pr1 F (pr21 x)))
                         (pr2 x)
                         (identity_z_iso (pr1 F (pr21 y)))
                         (pr2 y)
                         (z_iso_after_z_iso_inv _)
                         (z_iso_after_z_iso_inv _)
                         _
                         _
                     @ maponpaths (λ z, _ · z) _).
      - use pb_of_sum_cats_mor_eq.
        rewrite !assoc.
        rewrite z_iso_after_z_iso_inv.
        rewrite id_left.
        apply idpath.
      - abstract
          (rewrite id_left, id_right ;
           rewrite assoc ;
           rewrite z_iso_after_z_iso_inv ;
           apply id_left).
      - abstract
          (rewrite !assoc' ;
           rewrite z_iso_after_z_iso_inv ;
           rewrite id_right ;
           apply idpath).
      - use pb_of_sum_cats_mor_eq.
        pose (pr2 f) as p.
        simpl in p.
        etrans.
        {
          apply maponpaths_2.
          exact (!p).
        }
        rewrite !assoc'.
        rewrite z_iso_inv_after_z_iso.
        apply id_right.
    Qed.

    Local Definition pb_of_sum_cats_inl_nat_trans
      : κ₁ ∙ pb_of_sum_cats ⟹ pr1 (bincoprod_cocone_inl W).
    Proof.
      use make_nat_trans.
      - exact pb_of_sum_cats_inl_data.
      - exact pb_of_sum_cats_inl_is_nat_trans.
    Defined.

    Local Definition pb_of_sum_cats_inl
      : nat_z_iso
          (κ₁ ∙ pb_of_sum_cats)
          (bincoprod_cocone_inl W).
    Proof.
      use make_nat_z_iso.
      - exact pb_of_sum_cats_inl_nat_trans.
      - intro.
        apply z_iso_is_z_isomorphism.
    Defined.

    Local Definition pb_of_sum_cats_inr_data
      : nat_trans_data
          (κ₂ ∙ pb_of_sum_cats)
          (pr1 (bincoprod_cocone_inr W))
      := λ z, pb_of_sum_cats_z_iso (pr21 z) _ (pr2 z).

    Local Lemma pb_of_sum_cats_inr_is_nat_trans
      : is_nat_trans _ _ pb_of_sum_cats_inr_data.
    Proof.
      intros x y f.
      cbn.
      simple refine (maponpaths (λ z, z · _) _
                     @ pb_of_sum_cats_nat_trans_help
                         (pr21 f)
                         (inv_from_z_iso (pr2 x))
                         (pr12 x · # (pr1 F) (pr21 f))
                         (inv_from_z_iso (pr2 y))
                         (identity_z_iso (pr1 F (pr21 x)))
                         (pr2 x)
                         (identity_z_iso (pr1 F (pr21 y)))
                         (pr2 y)
                         (z_iso_after_z_iso_inv _)
                         (z_iso_after_z_iso_inv _)
                         _
                         _
                     @ maponpaths (λ z, _ · z) _).
      - use pb_of_sum_cats_mor_eq.
        rewrite !assoc.
        rewrite z_iso_after_z_iso_inv.
        rewrite id_left.
        apply idpath.
      - abstract
          (rewrite id_left, id_right ;
           rewrite assoc ;
           rewrite z_iso_after_z_iso_inv ;
           apply id_left).
      - abstract
          (rewrite !assoc' ;
           rewrite z_iso_after_z_iso_inv ;
           rewrite id_right ;
           apply idpath).
      - use pb_of_sum_cats_mor_eq.
        pose (pr2 f) as p.
        simpl in p.
        etrans.
        {
          apply maponpaths_2.
          exact (!p).
        }
        rewrite !assoc'.
        rewrite z_iso_inv_after_z_iso.
        apply id_right.
    Qed.

    Local Definition pb_of_sum_cats_inr_nat_trans
      : κ₂ ∙ pb_of_sum_cats ⟹ pr1 (bincoprod_cocone_inr W).
    Proof.
      use make_nat_trans.
      - exact pb_of_sum_cats_inr_data.
      - exact pb_of_sum_cats_inr_is_nat_trans.
    Defined.

    Local Definition pb_of_sum_cats_inr
      : nat_z_iso
          (κ₂ ∙ pb_of_sum_cats)
          (bincoprod_cocone_inr W).
    Proof.
      use make_nat_z_iso.
      - exact pb_of_sum_cats_inr_nat_trans.
      - intro.
        apply z_iso_is_z_isomorphism.
    Defined.
  End UniversalCoproductsOne.

  Section UniversalCoproductsTwo.
    Context {W : ∁}
            {φ ψ : ∁ ⟦ make_bincoprod_cocone Z κ₁ κ₂, W ⟧}
            (α : κ₁ · φ ==> κ₁ · ψ)
            (β : κ₂ · φ ==> κ₂ · ψ).

    Local Definition pb_of_sum_cats_nat_trans_ob
          (z : pr1 Z)
          (q : pr111 (bincoprod_of ∁ C₁ C₂))
          (i : z_iso q (pr1 F z))
      : pr1 φ z --> pr1 ψ z.
    Proof.
      induction q as [ x | y ].
      - exact (pr1 α ((x ,, z) ,, i)).
      - exact (pr1 β ((y ,, z) ,, i)).
    Defined.

    Local Definition pb_of_sum_cats_nat_trans_data
      : nat_trans_data (pr1 φ) (pr1 ψ)
      := λ z, pb_of_sum_cats_nat_trans_ob z (pr1 F z) (identity_z_iso _).

    Local Definition pb_of_sum_cats_is_nat_trans_help
          {z₁ z₂ : pr1 Z}
          (f : z₁ --> z₂)
          {q₁ q₂ : pr111 (bincoprod_of ∁ C₁ C₂)}
          (g : q₁ --> q₂)
          (i₁ : z_iso q₁ (pr1 F z₁))
          (i₂ : z_iso q₂ (pr1 F z₂))
          (p : g · i₂ = i₁ · # (pr1 F) f)
      : # (pr1 φ) f · pb_of_sum_cats_nat_trans_ob _ _ i₂
        =
        pb_of_sum_cats_nat_trans_ob _ _ i₁ · # (pr1 ψ) f.
    Proof.
      induction q₁ as [ x₁ | y₁ ] ; induction q₂ as [ x₂ | y₂ ] ; cbn.
      - exact (nat_trans_ax
                 α
                 ((x₁ ,, z₁) ,, i₁)
                 ((x₂ ,, z₂) ,, i₂)
                 ((g ,, _) ,, p)).
      - exact (fromempty (i₁ · # (pr1 F) f · inv_from_z_iso i₂)).
      - exact (fromempty (i₁ · # (pr1 F) f · inv_from_z_iso i₂)).
      - exact (nat_trans_ax
                 β
                 ((y₁ ,, z₁) ,, i₁)
                 ((y₂ ,, z₂) ,, i₂)
                 ((g ,, _) ,, p)).
    Qed.

    Local Lemma pb_of_sum_cats_is_nat_trans
      : is_nat_trans _ _ pb_of_sum_cats_nat_trans_data.
    Proof.
      intros x y f ; unfold pb_of_sum_cats_nat_trans_data ; cbn.
      use pb_of_sum_cats_is_nat_trans_help.
      - exact (# (pr1 F) f).
      - rewrite id_left, id_right.
        apply idpath.
    Qed.

    Local Definition pb_of_sum_cats_nat_trans
      : φ ==> ψ.
    Proof.
      use make_nat_trans.
      - exact pb_of_sum_cats_nat_trans_data.
      - exact pb_of_sum_cats_is_nat_trans.
    Defined.

    Local Lemma pb_of_sum_cats_nat_trans_ob_id
          (z : pr1 Z)
          (q : pr111 (bincoprod_of ∁ C₁ C₂))
          (i : z_iso q (pr1 F z))
      : pb_of_sum_cats_nat_trans_ob z _ (identity_z_iso _)
        =
        pb_of_sum_cats_nat_trans_ob z q i.
    Proof.
      refine (!(id_left _) @ _ @ id_right _).
      etrans.
      {
        apply maponpaths_2.
        refine (!_).
        apply functor_id.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply functor_id.
      }
      refine (!_).
      refine (pb_of_sum_cats_is_nat_trans_help
                (identity z)
                i
                i
                (identity_z_iso _)
                _).
      rewrite (functor_id F).
      rewrite !id_right.
      apply idpath.
    Qed.

    Local Definition pb_of_sum_cats_nat_trans_inl
      : κ₁ ◃ pb_of_sum_cats_nat_trans = α.
    Proof.
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro x ; cbn ; unfold pb_of_sum_cats_nat_trans_data.
      exact (pb_of_sum_cats_nat_trans_ob_id _ _ (pr2 x)).
    Qed.

    Local Definition pb_of_sum_cats_nat_trans_inr
      : κ₂ ◃ pb_of_sum_cats_nat_trans = β.
    Proof.
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro x ; cbn ; unfold pb_of_sum_cats_nat_trans_data.
      exact (pb_of_sum_cats_nat_trans_ob_id _ _ (pr2 x)).
    Qed.

    Local Lemma pb_of_sum_cats_nat_trans_unique
      : isaprop
          (∑ (γ : φ ==> ψ), κ₁ ◃ γ = α × κ₂ ◃ γ = β).
    Proof.
      use invproofirrelevance.
      intros τ₁ τ₂.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply cellset_property.
      }
      use nat_trans_eq.
      {
        apply homset_property.
      }
      intro z ; cbn in z.
      pose (q := pr1 F z).
      assert (i := identity_z_iso _ : z_iso q (pr1 F z)).
      induction q as [ x | y] ; cbn.
      - refine (nat_trans_eq_pointwise (pr12 τ₁) ((x ,, z) ,, i) @ !_).
        exact (nat_trans_eq_pointwise (pr12 τ₂) ((x ,, z) ,, i)).
      - refine (nat_trans_eq_pointwise (pr22 τ₁) ((y ,, z) ,, i) @ !_).
        exact (nat_trans_eq_pointwise (pr22 τ₂) ((y ,, z) ,, i)).
    Qed.
  End UniversalCoproductsTwo.

  Definition universal_bicat_of_univ_cats
    : has_bincoprod_ump (make_bincoprod_cocone Z κ₁ κ₂).
  Proof.
    split.
    - intro W.
      use make_bincoprod_1cell.
      + exact (pb_of_sum_cats W).
      + use nat_z_iso_to_invertible_2cell.
        exact (pb_of_sum_cats_inl W).
      + use nat_z_iso_to_invertible_2cell.
        exact (pb_of_sum_cats_inr W).
    - intros W φ ψ α β.
      use iscontraprop1.
      + exact (pb_of_sum_cats_nat_trans_unique α β).
      + simple refine (_ ,, _ ,, _).
        * exact (pb_of_sum_cats_nat_trans α β).
        * exact (pb_of_sum_cats_nat_trans_inl α β).
        * exact (pb_of_sum_cats_nat_trans_inr α β).
  Defined.
End UniversalCoproducts.

Definition is_extensive_bicat_of_univ_cats
  : is_extensive bicat_of_univ_cats_with_biinitial_bincoprod.
Proof.
  intros C₁ C₂.
  split.
  - refine (_ ,, _ ,, _ ,, _).
    + apply cat_fully_faithful_is_fully_faithful_1cell.
      apply fully_faithful_inl_functor.
    + apply cat_fully_faithful_is_fully_faithful_1cell.
      apply fully_faithful_inr_functor.
    + apply bicat_of_univ_cats_inl_inr.
    + apply bicat_of_univ_cats_inr_inl.
  - use is_universal_from_pb_alt.
    + apply has_pb_bicat_of_univ_cats.
    + intros Z F.
      exact (universal_bicat_of_univ_cats F).
Defined.

(**
 4. Kleisli objects
 *)
Section KleisliCategoryUMP.
  Context (m : mnd (op1_bicat bicat_of_univ_cats)).

  Let C : univalent_category := ob_of_mnd m.
  Let M : Monad C := mnd_bicat_of_univ_cats_to_Monad (mnd_op1_to_mnd m).

  Definition bicat_of_univ_cats_has_kleisli_cocone
    : kleisli_cocone m.
  Proof.
    use make_kleisli_cocone.
    - exact (univalent_kleisli_cat M).
    - exact (kleisli_incl M).
    - exact (kleisli_nat_trans M).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ;
         use eq_mor_kleisli_cat ;
         exact (@Monad_law2 _ M x)).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ;
         use eq_mor_kleisli_cat ;
         cbn ;
         rewrite id_left ;
         apply (!(@Monad_law3 _ M x))).
  Defined.

  Definition bicat_of_univ_cats_has_kleisli_ump_1
    : has_kleisli_ump_1 m bicat_of_univ_cats_has_kleisli_cocone.
  Proof.
    intro q.
    pose (F := mor_of_kleisli_cocone _ q).
    pose (γ := cell_of_kleisli_cocone _ q).
    pose (p₁ := nat_trans_eq_pointwise (kleisli_cocone_unit _ q)).
    assert (p₂ : ∏ (x : C), pr1 γ (M x) · pr1 γ x = # (pr1 F) (μ M x) · pr1 γ x).
    {
      intro x.
      pose (p₂ := nat_trans_eq_pointwise (kleisli_cocone_mult _ q) x).
      cbn in p₂.
      rewrite !id_left in p₂.
      exact p₂.
    }
    use make_kleisli_cocone_mor.
    - exact (functor_from_univalent_kleisli_cat M F γ p₁ p₂).
    - exact (functor_from_univalent_kleisli_cat_nat_trans M F γ p₁ p₂).
    - abstract
        (use nat_trans_eq ; [ apply homset_property | ] ;
         intro x ;
         refine (_ @ maponpaths (λ z, z · _) (!(id_left _))) ;
         exact (functor_from_univalent_kleisli_cat_eq M F γ p₁ p₂ x)).
    - use is_nat_z_iso_to_is_invertible_2cell.
      exact (functor_from_univalent_kleisli_cat_nat_trans_is_z_iso M F γ p₁ p₂).
  Defined.

  Definition bicat_of_univ_cats_has_kleisli_ump_2
    : has_kleisli_ump_2 m bicat_of_univ_cats_has_kleisli_cocone.
  Proof.
    intros C' G₁ G₂ α p.
    assert (p' : ∏ (x : C),
                 # (pr1 G₁) (kleisli_nat_trans M x) · pr1 α x
                 =
                 pr1 α (M x) · # (pr1 G₂) (kleisli_nat_trans M x)).
    {
      intro x.
      pose (q := nat_trans_eq_pointwise p x).
      cbn in q.
      rewrite !id_left, !id_right in q.
      exact q.
    }
    use iscontraprop1.
    - use invproofirrelevance.
      intros β₁ β₂.
      use subtypePath ; [ intro ; apply cellset_property | ].
      exact (nat_trans_from_univalent_kleisli_cat_unique M α (pr2 β₁) (pr2 β₂)).
    - simple refine (_ ,, _).
      + exact (nat_trans_from_univalent_kleisli_cat M α p').
      + exact (pre_whisker_nat_trans_from_univalent_kleisli_cat M α p').
  Defined.
End KleisliCategoryUMP.

Definition bicat_of_univ_cats_has_kleisli
  : has_kleisli bicat_of_univ_cats.
Proof.
  intro m.
  simple refine (_ ,, _ ,, _).
  - exact (bicat_of_univ_cats_has_kleisli_cocone m).
  - exact (bicat_of_univ_cats_has_kleisli_ump_1 m).
  - exact (bicat_of_univ_cats_has_kleisli_ump_2 m).
Defined.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation. *)

Require Import Coqlib.
Require Import Maps.
Require Import AST.
Require Import Integers.
Require Import Values.
Require Import Events.
Require Import Memory.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import Lattice.
Require Import Kildall.
Require Import ConstpropOp.
Require Import Constprop.
Require Import ConstpropOpproof.
Require Import BuiltinFunctions.

Section PRESERVATION.

Context `{Hcc: CompilerConfiguration}.
Variable prog: program.
Let tprog := transf_program prog.
Let ge := Genv.globalenv prog.
Let tge := Genv.globalenv tprog.
Let gapp := make_global_approx (PTree.empty _) prog.(prog_defs).

(** * Correctness of the static analysis *)

Section ANALYSIS.

Variable sp: val.

Definition regs_match_approx (a: D.t) (rs: regset) : Prop :=
  forall r, val_match_approx ge sp (D.get r a) rs#r.

Lemma regs_match_approx_top:
  forall rs, regs_match_approx D.top rs.
Proof.
  intros. red; intros. simpl. rewrite PTree.gempty.
  unfold Approx.top, val_match_approx. auto.
Qed.

Lemma val_match_approx_increasing:
  forall a1 a2 v,
  Approx.ge a1 a2 -> val_match_approx ge sp a2 v -> val_match_approx ge sp a1 v.
Proof.
  intros until v.
  intros [A|[B|C]].
  subst a1. simpl. auto.
  subst a2. simpl. tauto.
  subst a2. auto.
Qed.

Lemma regs_match_approx_increasing:
  forall a1 a2 rs,
  D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs.
Proof.
  unfold D.ge, regs_match_approx. intros.
  apply val_match_approx_increasing with (D.get r a2); auto.
Qed.

Lemma regs_match_approx_update:
  forall ra rs a v r,
  val_match_approx ge sp a v ->
  regs_match_approx ra rs ->
  regs_match_approx (D.set r a ra) (rs#r <- v).
Proof.
  intros; red; intros. rewrite Regmap.gsspec.
  case (peq r0 r); intro.
  subst r0. rewrite D.gss. auto.
  rewrite D.gso; auto.
Qed.

Lemma approx_regs_val_list:
  forall ra rs rl,
  regs_match_approx ra rs ->
  val_list_match_approx ge sp (approx_regs ra rl) rs##rl.
Proof.
  induction rl; simpl; intros.
  constructor.
  constructor. apply H. auto.
Qed.

(** The correctness of the static analysis follows from the results
  of module [ConstpropOpproof] and the fact that the result of
  the static analysis is a solution of the forward dataflow inequations. *)

Lemma analyze_correct_1:
  forall f pc rs pc' i,
  f.(fn_code)!pc = Some i ->
  In pc' (successors_instr i) ->
  regs_match_approx (transfer gapp f pc (analyze gapp f)!!pc) rs ->
  regs_match_approx (analyze gapp f)!!pc' rs.
Proof.
  intros until i. unfold analyze.
  caseEq (DS.fixpoint (successors f) (transfer gapp f)
                      ((fn_entrypoint f, D.top) :: nil)).
  intros approxs; intros.
  apply regs_match_approx_increasing with (transfer gapp f pc approxs!!pc).
  eapply DS.fixpoint_solution; eauto.
  unfold successors_list, successors. rewrite PTree.gmap1. rewrite H0. auto.
  auto.
  intros. rewrite PMap.gi. apply regs_match_approx_top.
Qed.

Lemma analyze_correct_3:
  forall f rs,
  regs_match_approx (analyze gapp f)!!(f.(fn_entrypoint)) rs.
Proof.
  intros. unfold analyze.
  caseEq (DS.fixpoint (successors f) (transfer gapp f)
                      ((fn_entrypoint f, D.top) :: nil)).
  intros approxs; intros.
  apply regs_match_approx_increasing with D.top.
  eapply DS.fixpoint_entry; eauto. auto with coqlib.
  apply regs_match_approx_top.
  intros. rewrite PMap.gi. apply regs_match_approx_top.
Qed.

(** eval_static_load *)

Definition mem_match_approx (m: mem) : Prop :=
  forall id il b,
  gapp!id = Some il -> Genv.find_symbol ge id = Some b ->
  Genv.load_store_init_data ge m b 0 il /\
  Mem.valid_block m b /\
  (forall ofs, ~Mem.perm m b ofs Max Writable).

Lemma eval_load_init_sound:
  forall chunk m b il base ofs pos v,
  Genv.load_store_init_data ge m b base il ->
  Mem.load chunk m b ofs = Some v ->
  ofs = base + pos ->
  val_match_approx ge sp (eval_load_init chunk pos il) v.
Proof.
  induction il; simpl; intros.
(* base case il = nil *)
  auto.
(* inductive case *)
  destruct a.
  (* Init_int8 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  rewrite Mem.load_int8_signed_unsigned in H0. rewrite H in H0. simpl in H0.
  inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_int16 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  rewrite Mem.load_int16_signed_unsigned in H0. rewrite H in H0. simpl in H0.
  inv H0. decEq. apply Int.sign_ext_zero_ext. compute; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_int32 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_float32 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_float64 *)
  destruct H. destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto. destruct (propagate_float_constants tt); simpl; auto.
  congruence.
  eapply IHil; eauto. omega.
  (* Init_space *)
  eapply IHil; eauto. omega.
  (* Init_symbol *)
  destruct H as [[b' [A B]] C].
  destruct (zeq pos 0). subst.  rewrite Zplus_0_r in H0.
  destruct chunk; simpl; auto.
  unfold symbol_address. rewrite A. congruence.
  eapply IHil; eauto. omega.
Qed.

Lemma eval_static_load_sound:
  forall chunk m addr vaddr v,
  Mem.loadv chunk m vaddr = Some v ->
  mem_match_approx m ->
  val_match_approx ge sp addr vaddr ->
  val_match_approx ge sp (eval_static_load gapp chunk addr) v.
Proof.
  intros. unfold eval_static_load. destruct addr; simpl; auto.
  destruct (gapp!i) as [il|] eqn:?; auto.
  red in H1. subst vaddr. unfold symbol_address in H.
  destruct (Genv.find_symbol ge i) as [b'|] eqn:?; simpl in H; try discriminate.
  exploit H0; eauto. intros [A [B C]].
  eapply eval_load_init_sound; eauto.
  red; auto.
Qed.

Lemma mem_match_approx_store:
  forall chunk m addr v m',
  mem_match_approx m ->
  Mem.storev chunk m addr v = Some m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  destruct addr; simpl in H0; try discriminate.
  exploit Mem.store_valid_access_3; eauto. intros [P Q].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_store_other; eauto. left; red; intro; subst b0.
  eapply C. apply Mem.perm_cur_max. eapply P. instantiate (1 := Int.unsigned i).
  generalize (size_chunk_pos chunk). omega.
  split. eauto with mem.
  intros; red; intros. eapply C. eapply Mem.perm_store_2; eauto.
Qed.

Lemma mem_match_approx_alloc:
  forall m lo hi b m',
  mem_match_approx m ->
  Mem.alloc m lo hi = (m', b) ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_alloc_unchanged; eauto.
  split. eauto with mem.
  intros; red; intros. exploit Mem.perm_alloc_inv; eauto.
  rewrite zeq_false. apply C. eapply Mem.valid_not_valid_diff; eauto with mem.
Qed.

Lemma mem_match_approx_free:
  forall m lo hi b m',
  mem_match_approx m ->
  Mem.free m b lo hi = Some m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply Mem.load_free; eauto.
  destruct (zeq b0 b); auto. subst b0.
  right. destruct (zlt lo hi); auto.
  elim (C lo). apply Mem.perm_cur_max.
  exploit Mem.free_range_perm; eauto. instantiate (1 := lo); omega.
  intros; eapply Mem.perm_implies; eauto with mem.
  split. eauto with mem.
  intros; red; intros. eapply C. eauto with mem.
Qed.

Lemma mem_match_approx_extcall:
  forall `{Hec: ExternalCalls _ (mem_ops := _) (inj_ops := _) (mm_ops := mm_ops)},
  forall ef vargs m t vres m',
  mem_match_approx m ->
  external_call ef ge vargs m t vres m' ->
  mem_match_approx m'.
Proof.
  intros; red; intros. exploit H; eauto. intros [A [B C]].
  split. apply Genv.load_store_init_data_invariant with m; auto.
  intros. eapply external_call_readonly; eauto.
  split. eapply external_call_valid_block; eauto.
  intros; red; intros. elim (C ofs). eapply external_call_max_perm; eauto.
Qed.

(* Show that mem_match_approx holds initially *)

Definition global_approx_charact (g: genv) (ga: global_approx) : Prop :=
  forall id il b,
  ga!id = Some il ->
  Genv.find_symbol g id = Some b ->
  Genv.find_var_info g b = Some (mkglobvar tt il true false).

Lemma make_global_approx_correct:
  forall gdl g ga,
  global_approx_charact g ga ->
  global_approx_charact (Genv.add_globals g gdl) (make_global_approx ga gdl).
Proof.
  induction gdl; simpl; intros.
  auto.
  destruct a as [id gd]. apply IHgdl.
  red; intros.
  assert (EITHER: id0 = id /\ gd = Gvar(mkglobvar tt il true false)
               \/ id0 <> id /\ ga!id0 = Some il).
  destruct gd.
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].
  destruct (gvar_readonly v && negb (gvar_volatile v)) eqn:?.
  rewrite PTree.gsspec in H0. destruct (peq id0 id).
  inv H0. left. split; auto.
  destruct v; simpl in *.
  destruct gvar_readonly; try discriminate.
  destruct gvar_volatile; try discriminate.
  destruct gvar_info. auto.
  auto.
  rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id); [discriminate|auto].

  unfold Genv.add_global, Genv.find_symbol, Genv.find_var_info in *;
  simpl in *.
  destruct EITHER as [[A B] | [A B]].
  subst id0. rewrite PTree.gss in H1. inv H1. rewrite ZMap.gss. auto.
  rewrite PTree.gso in H1; auto. destruct gd. eapply H; eauto.
  rewrite ZMap.gso. eapply H; eauto.
  exploit Genv.genv_symb_range; eauto. unfold ZIndexed.t. omega.
Qed.

Theorem mem_match_approx_init:
  forall m, Genv.init_mem prog = Some m -> mem_match_approx m.
Proof.
  intros.
  assert (global_approx_charact ge gapp).
    unfold ge, gapp.   unfold Genv.globalenv.
    apply make_global_approx_correct.
    red; intros. rewrite PTree.gempty in H0; discriminate.
  red; intros.
  exploit Genv.init_mem_characterization.
  unfold ge in H0. eapply H0; eauto. eauto.
  unfold Genv.perm_globvar; simpl.
  intros [A [B C]].
  split. auto. split. eapply Genv.find_symbol_not_fresh; eauto.
  intros; red; intros. exploit B; eauto. intros [P Q]. inv Q.
Qed.

End ANALYSIS.

(** * Correctness of the code transformation *)

(** We now show that the transformed code after constant propagation
  has the same semantics as the original code. *)

Lemma symbols_preserved:
  forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s.
Proof.
  intros; unfold ge, tge, tprog, transf_program.
  apply Genv.find_symbol_transf.
Qed.

Lemma varinfo_preserved:
  forall b, Genv.find_var_info tge b = Genv.find_var_info ge b.
Proof.
  intros; unfold ge, tge, tprog, transf_program.
  apply Genv.find_var_info_transf.
Qed.

Lemma functions_translated:
  forall (v: val) (f: fundef),
  Genv.find_funct ge v = Some f ->
  Genv.find_funct tge v = Some (transf_fundef gapp f).
Proof.
  intros.
  exact (Genv.find_funct_transf (transf_fundef gapp) _ _ H).
Qed.

Lemma function_ptr_translated:
  forall (b: block) (f: fundef),
  Genv.find_funct_ptr ge b = Some f ->
  Genv.find_funct_ptr tge b = Some (transf_fundef gapp f).
Proof.
  intros.
  exact (Genv.find_funct_ptr_transf (transf_fundef gapp) _ _ H).
Qed.

Lemma sig_function_translated:
  forall f,
  funsig (transf_fundef gapp f) = funsig f.
Proof.
  intros. destruct f; reflexivity.
Qed.

Definition regs_lessdef (rs1 rs2: regset) : Prop :=
  forall r, Val.lessdef (rs1#r) (rs2#r).

Lemma regs_lessdef_regs:
  forall rs1 rs2, regs_lessdef rs1 rs2 ->
  forall rl, Val.lessdef_list rs1##rl rs2##rl.
Proof.
  induction rl; constructor; auto.
Qed.

Lemma set_reg_lessdef:
  forall r v1 v2 rs1 rs2,
  Val.lessdef v1 v2 -> regs_lessdef rs1 rs2 -> regs_lessdef (rs1#r <- v1) (rs2#r <- v2).
Proof.
  intros; red; intros. repeat rewrite Regmap.gsspec.
  destruct (peq r0 r); auto.
Qed.

Lemma init_regs_lessdef:
  forall rl vl1 vl2,
  Val.lessdef_list vl1 vl2 ->
  regs_lessdef (init_regs vl1 rl) (init_regs vl2 rl).
Proof.
  induction rl; simpl; intros.
  red; intros. rewrite Regmap.gi. auto.
  inv H. red; intros. rewrite Regmap.gi. auto.
  apply set_reg_lessdef; auto.
Qed.

Lemma transf_ros_correct:
  forall sp ros rs rs' f approx,
  regs_match_approx sp approx rs ->
  find_function ge ros rs = Some f ->
  regs_lessdef rs rs' ->
  find_function tge (transf_ros approx ros) rs' = Some (transf_fundef gapp f).
Proof.
  intros. destruct ros; simpl in *.
  generalize (H r); intro MATCH. generalize (H1 r); intro LD.
  destruct (rs#r); simpl in H0; try discriminate.
  destruct (Int.eq_dec i Int.zero); try discriminate.
  inv LD.
  assert (find_function tge (inl _ r) rs' = Some (transf_fundef gapp f)).
    simpl. rewrite <- H4. simpl. rewrite dec_eq_true. apply function_ptr_translated. auto.
  destruct (D.get r approx); auto.
  predSpec Int.eq Int.eq_spec i0 Int.zero; intros; auto.
  simpl in *. unfold symbol_address in MATCH. rewrite symbols_preserved.
  destruct (Genv.find_symbol ge i); try discriminate.
  inv MATCH. apply function_ptr_translated; auto.
  rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try discriminate.
  apply function_ptr_translated; auto.
Qed.

Lemma const_for_result_correct:
  forall a op sp v m,
  const_for_result a = Some op ->
  val_match_approx ge sp a v ->
  eval_operation tge sp op nil m = Some v.
Proof.
  unfold const_for_result; intros.
  destruct a; inv H; simpl in H0.
  simpl. congruence.
  destruct (generate_float_constants tt); inv H2.  simpl. congruence.
  simpl. subst v. unfold symbol_address. rewrite symbols_preserved. auto.
  simpl. congruence.
Qed.

Inductive match_pc (f: function) (app: D.t): nat -> node -> node -> Prop :=
  | match_pc_base: forall n pc,
      match_pc f app n pc pc
  | match_pc_nop: forall n pc s pcx,
      f.(fn_code)!pc = Some (Inop s) ->
      match_pc f app n s pcx ->
      match_pc f app (Datatypes.S n) pc pcx
  | match_pc_cond: forall n pc cond args s1 s2 b,
      f.(fn_code)!pc = Some (Icond cond args s1 s2) ->
      eval_static_condition cond (approx_regs app args) = Some b ->
      match_pc f app (Datatypes.S n) pc (if b then s1 else s2).

Lemma match_successor_rec:
  forall f app n pc, match_pc f app n pc (successor_rec n f app pc).
Proof.
  induction n; simpl; intros.
  apply match_pc_base.
  destruct (fn_code f)!pc as [i|] eqn:?; try apply match_pc_base.
  destruct i; try apply match_pc_base.
  eapply match_pc_nop; eauto.
  destruct (eval_static_condition c (approx_regs app l)) as [b|] eqn:?.
  eapply match_pc_cond; eauto.
  apply match_pc_base.
Qed.

Lemma match_successor:
  forall f app pc, match_pc f app num_iter pc (successor f app pc).
Proof.
  unfold successor; intros. apply match_successor_rec.
Qed.

Section BUILTIN_STRENGTH_REDUCTION.
Variable app: D.t.
Variable sp: val.
Variable rs: regset.
Hypothesis MATCH: forall r, val_match_approx ge sp (approx_reg app r) rs#r.

Lemma annot_strength_reduction_correct:
  forall targs args targs' args' eargs,
  annot_strength_reduction app targs args = (targs', args') ->
  eventval_list_match ge eargs (annot_args_typ targs) rs##args ->
  exists eargs',
  eventval_list_match ge eargs' (annot_args_typ targs') rs##args'
  /\ annot_eventvals targs' eargs' = annot_eventvals targs eargs.
Proof.
  induction targs; simpl; intros.
- inv H. simpl. exists eargs; auto.
- destruct a.
  + destruct args as [ | arg args0]; simpl in H0; inv H0.
    destruct (annot_strength_reduction app targs args0) as [targs'' args''] eqn:E.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    assert (DFL:
      exists eargs',
      eventval_list_match ge eargs' (annot_args_typ (AA_arg ty :: targs'')) rs##(arg :: args'')
      /\ annot_eventvals (AA_arg ty :: targs'') eargs' = ev1 :: annot_eventvals targs evl).
    {
      exists (ev1 :: eargs''); split.
      simpl; constructor; auto. simpl. congruence.
    }
    destruct ty; destruct (approx_reg app arg) as [] eqn:E2; inv H; auto;
    exists eargs''; split; auto; simpl; f_equal; auto;
    generalize (MATCH arg); rewrite E2; simpl; intros E3;
    rewrite E3 in H5; inv H5; auto.
  + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
    inv H.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    exists eargs''; simpl; split; auto. congruence.
  + destruct (annot_strength_reduction app targs args) as [targs'' args''] eqn:E.
    inv H.
    exploit IHtargs; eauto. intros [eargs'' [A B]].
    exists eargs''; simpl; split; auto. congruence.
Qed.

Lemma builtin_strength_reduction_correct:
  forall ef args m t vres m',
  external_call ef ge rs##args m t vres m' ->
  let (ef', args') := builtin_strength_reduction app ef args in
  external_call ef' ge rs##args' m t vres m'.
Proof.
  intros until m'. functional induction (builtin_strength_reduction app ef args); intros; auto.
+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
  unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
  rewrite volatile_load_global_charact. exists b; auto.
  inv H.
+ generalize (MATCH r1); rewrite e1; simpl; intros E. simpl in H.
  unfold symbol_address in E. destruct (Genv.find_symbol ge symb) as [b|] eqn:?; rewrite E in H.
  rewrite volatile_store_global_charact. exists b; auto.
  inv H.
+ inv H. exploit annot_strength_reduction_correct; eauto.
  intros [eargs' [A B]].
  rewrite <- B. econstructor; eauto.
Qed.

End BUILTIN_STRENGTH_REDUCTION.

(** The proof of semantic preservation is a simulation argument
  based on "option" diagrams of the following form:
<<
                 n
       st1 --------------- st2
        |                   |
       t|                   |t or (? and n' < n)
        |                   |
        v                   v
       st1'--------------- st2'
                 n'
>>
  The left vertical arrow represents a transition in the
  original RTL code.  The top horizontal bar is the [match_states]
  invariant between the initial state [st1] in the original RTL code
  and an initial state [st2] in the transformed code.
  This invariant expresses that all code fragments appearing in [st2]
  are obtained by [transf_code] transformation of the corresponding
  fragments in [st1].  Moreover, the values of registers in [st1]
  must match their compile-time approximations at the current program
  point.
  These two parts of the diagram are the hypotheses.  In conclusions,
  we want to prove the other two parts: the right vertical arrow,
  which is a transition in the transformed RTL code, and the bottom
  horizontal bar, which means that the [match_state] predicate holds
  between the final states [st1'] and [st2']. *)

Inductive match_stackframes: stackframe -> stackframe -> Prop :=
   match_stackframe_intro:
      forall res sp pc rs f rs',
      regs_lessdef rs rs' ->
      (forall v, regs_match_approx sp (analyze gapp f)!!pc (rs#res <- v)) ->
    match_stackframes
        (Stackframe res f sp pc rs)
        (Stackframe res (transf_function gapp f) sp pc rs').

Inductive match_states: nat -> state -> state -> Prop :=
  | match_states_intro:
      forall s sp pc rs m f s' pc' rs' m' app n
           (MATCH1: regs_match_approx sp app rs)
           (MATCH2: regs_match_approx sp (analyze gapp f)!!pc rs)
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (PC: match_pc f app n pc pc')
           (REGS: regs_lessdef rs rs')
           (MEM: Mem.extends m m'),
      match_states n (State s f sp pc rs m)
                    (State s' (transf_function gapp f) sp pc' rs' m')
  | match_states_call:
      forall s f args m s' args' m'
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (ARGS: Val.lessdef_list args args')
           (MEM: Mem.extends m m'),
      match_states O (Callstate s f args m)
                    (Callstate s' (transf_fundef gapp f) args' m')
  | match_states_return:
      forall s v m s' v' m'
           (GMATCH: mem_match_approx m)
           (STACKS: list_forall2 match_stackframes s s')
           (RES: Val.lessdef v v')
           (MEM: Mem.extends m m'),
      list_forall2 match_stackframes s s' ->
      match_states O (Returnstate s v m)
                    (Returnstate s' v' m').

Lemma match_states_succ:
  forall s f sp pc2 rs m s' rs' m' pc1 i,
  f.(fn_code)!pc1 = Some i ->
  In pc2 (successors_instr i) ->
  regs_match_approx sp (transfer gapp f pc1 (analyze gapp f)!!pc1) rs ->
  mem_match_approx m ->
  list_forall2 match_stackframes s s' ->
  regs_lessdef rs rs' ->
  Mem.extends m m' ->
  match_states O (State s f sp pc2 rs m)
                (State s' (transf_function gapp f) sp pc2 rs' m').
Proof.
  intros.
  assert (regs_match_approx sp (analyze gapp f)!!pc2 rs).
    eapply analyze_correct_1; eauto.
  apply match_states_intro with (app := (analyze gapp f)!!pc2); auto.
  constructor.
Qed.

Lemma transf_instr_at:
  forall f pc i,
  f.(fn_code)!pc = Some i ->
  (transf_function gapp f).(fn_code)!pc = Some(transf_instr gapp f (analyze gapp f) pc i).
Proof.
  intros. simpl. unfold transf_code. rewrite PTree.gmap. rewrite H. auto.
Qed.

Ltac TransfInstr :=
  match goal with
  | H: (PTree.get ?pc (fn_code ?f) = Some ?instr) |- _ =>
      generalize (transf_instr_at _ _ _ H); simpl
  end.

(** The proof of simulation proceeds by case analysis on the transition
  taken in the source code. *)

Lemma transf_step_correct:
  forall s1 t s2,
  step ge s1 t s2 ->
  forall n1 s1' (MS: match_states n1 s1 s1'),
  (exists n2, exists s2', step tge s1' t s2' /\ match_states n2 s2 s2')
  \/ (exists n2, n2 < n1 /\ t = E0 /\ match_states n2 s2 s1')%nat.
Proof.
  induction 1; intros; inv MS; try (inv PC; try congruence);
  simpl in *.

  (* Inop, preserved *)
  rename pc'0 into pc. TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Inop; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. auto.

  (* Inop, skipped over *)
  rewrite H0 in H; inv H.
  right; exists n; split. omega. split. auto.
  apply match_states_intro with app; auto.
  eapply analyze_correct_1; eauto. simpl; auto.
  unfold transfer; rewrite H0. auto.

  (* Iop *)
  rename pc'0 into pc. TransfInstr.
  set (app_before := (analyze gapp f)#pc).
  set (a := eval_static_operation op (approx_regs app_before args)).
  set (app_after := D.set res a app_before).
  assert (VMATCH: val_match_approx ge sp a v).
    eapply eval_static_operation_correct; eauto.
    apply approx_regs_val_list; auto.
  assert (MATCH': regs_match_approx sp app_after rs#res <- v).
    apply regs_match_approx_update; auto.
  assert (MATCH'': regs_match_approx sp (analyze gapp f) # pc' rs # res <- v).
    eapply analyze_correct_1 with (pc := pc); eauto. simpl; auto.
    unfold transfer; rewrite H. auto.
  destruct (const_for_result a) as [cop|] eqn:?; intros.
  (* constant is propagated *)
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto.
  eapply const_for_result_correct; eauto.
  apply match_states_intro with app_after; auto.
  apply match_successor.
  apply set_reg_lessdef; auto.
  (* operator is strength-reduced *)
  exploit op_strength_reduction_correct. eexact MATCH2. reflexivity. eauto.
  fold app_before.
  destruct (op_strength_reduction op args (approx_regs app_before args)) as [op' args'].
  intros [v' [EV' LD']].
  assert (EV'': exists v'', eval_operation ge sp op' rs'##args' m' = Some v'' /\ Val.lessdef v' v'').
  eapply eval_operation_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct EV'' as [v'' [EV'' LD'']].
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto.
  erewrite eval_operation_preserved. eexact EV''. exact symbols_preserved.
  apply match_states_intro with app_after; auto.
  apply match_successor.
  apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto.

  (* Iload *)
  rename pc'0 into pc. TransfInstr.
  set (ap1 := eval_static_addressing addr
               (approx_regs (analyze gapp f) # pc args)).
  set (ap2 := eval_static_load gapp chunk ap1).
  assert (VM1: val_match_approx ge sp ap1 a).
    eapply eval_static_addressing_correct; eauto.
    eapply approx_regs_val_list; eauto.
  assert (VM2: val_match_approx ge sp ap2 v).
    eapply eval_static_load_sound; eauto.
  destruct (const_for_result ap2) as [cop|] eqn:?; intros.
  (* constant-propagated *)
  left; econstructor; econstructor; split.
  eapply exec_Iop; eauto. eapply const_for_result_correct; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. apply regs_match_approx_update; auto.
  apply set_reg_lessdef; auto.
  (* strength-reduced *)
  generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
                  MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
  rewrite H0. intros P.
  assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a').
    eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct ADDR' as [a' [A B]].
  assert (C: eval_addressing tge sp addr' rs'##args' = Some a').
    rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
  exploit Mem.loadv_extends; eauto. intros [v' [D E]].
  left; econstructor; econstructor; split.
  eapply exec_Iload; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. apply regs_match_approx_update; auto.
  apply set_reg_lessdef; auto.

  (* Istore *)
  rename pc'0 into pc. TransfInstr.
  generalize (addr_strength_reduction_correct ge sp (analyze gapp f)!!pc rs
                  MATCH2 addr args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (addr_strength_reduction addr args (approx_regs (analyze gapp f) # pc args)) as [addr' args'].
  intros P Q. rewrite H0 in P.
  assert (ADDR': exists a', eval_addressing ge sp addr' rs'##args' = Some a' /\ Val.lessdef a a').
    eapply eval_addressing_lessdef; eauto. eapply regs_lessdef_regs; eauto.
  destruct ADDR' as [a' [A B]].
  assert (C: eval_addressing tge sp addr' rs'##args' = Some a').
    rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
  exploit Mem.storev_extends; eauto. intros [m2' [D E]].
  left; econstructor; econstructor; split.
  eapply exec_Istore; eauto.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H. auto.
  eapply mem_match_approx_store; eauto.

  (* Icall *)
  rename pc'0 into pc.
  exploit transf_ros_correct; eauto. intro FIND'.
  TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Icall; eauto. apply sig_function_translated; auto.
  constructor; auto. constructor; auto.
  econstructor; eauto.
  intros. eapply analyze_correct_1; eauto. simpl; auto.
  unfold transfer; rewrite H.
  apply regs_match_approx_update; auto. simpl. auto.
  apply regs_lessdef_regs; auto.

  (* Itailcall *)
  exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
  exploit transf_ros_correct; eauto. intros FIND'.
  TransfInstr; intro.
  left; econstructor; econstructor; split.
  eapply exec_Itailcall; eauto. apply sig_function_translated; auto.
  constructor; auto.
  eapply mem_match_approx_free; eauto.
  apply regs_lessdef_regs; auto.

  (* Ibuiltin *)
  rename pc'0 into pc.
Opaque builtin_strength_reduction.
  exploit builtin_strength_reduction_correct; eauto.
  TransfInstr.
  destruct (builtin_strength_reduction (analyze gapp f)#pc ef args) as [ef' args'].
  intros P Q.
  exploit (external_call_mem_extends ef'); eauto.
  instantiate (1 := rs'##args'). apply regs_lessdef_regs; auto.
  intros [v' [m2' [A [B [C D]]]]].
  left; econstructor; econstructor; split.
  eapply exec_Ibuiltin. eauto.
  eapply (external_call_symbols_preserved ef'); eauto.
  exact symbols_preserved. exact varinfo_preserved.
  eapply match_states_succ; eauto. simpl; auto.
  unfold transfer; rewrite H.
  apply regs_match_approx_update; auto. simpl; auto.
  eapply (mem_match_approx_extcall ef'); eauto.
  apply set_reg_lessdef; auto.

  (* Icond, preserved *)
  rename pc'0 into pc. TransfInstr.
  generalize (cond_strength_reduction_correct ge sp (analyze gapp f)#pc rs m
                    MATCH2 cond args (approx_regs (analyze gapp f) # pc args) (refl_equal _)).
  destruct (cond_strength_reduction cond args (approx_regs (analyze gapp f) # pc args)) as [cond' args'].
  intros EV1 TCODE.
  left; exists O; exists (State s' (transf_function gapp f) sp (if b then ifso else ifnot) rs' m'); split.
  destruct (eval_static_condition cond (approx_regs (analyze gapp f) # pc args)) eqn:?.
  assert (eval_condition cond rs ## args m = Some b0).
    eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto.
  assert (b = b0) by congruence. subst b0.
  destruct b; eapply exec_Inop; eauto.
  eapply exec_Icond; eauto.
  eapply eval_condition_lessdef with (vl1 := rs##args'); eauto. eapply regs_lessdef_regs; eauto. congruence.
  eapply match_states_succ; eauto.
  destruct b; simpl; auto.
  unfold transfer; rewrite H. auto.

  (* Icond, skipped over *)
  rewrite H1 in H; inv H.
  assert (eval_condition cond rs ## args m = Some b0).
    eapply eval_static_condition_correct; eauto. eapply approx_regs_val_list; eauto.
  assert (b = b0) by congruence. subst b0.
  right; exists n; split. omega. split. auto.
  assert (MATCH': regs_match_approx sp (analyze gapp f) # (if b then ifso else ifnot) rs).
    eapply analyze_correct_1; eauto. destruct b; simpl; auto.
    unfold transfer; rewrite H1; auto.
  econstructor; eauto. constructor.

  (* Ijumptable *)
  rename pc'0 into pc.
  assert (A: (fn_code (transf_function gapp f))!pc = Some(Ijumptable arg tbl)
             \/ (fn_code (transf_function gapp f))!pc = Some(Inop pc')).
  TransfInstr. destruct (approx_reg (analyze gapp f) # pc arg) eqn:?; auto.
  generalize (MATCH2 arg). unfold approx_reg in Heqt. rewrite Heqt. rewrite H0.
  simpl. intro EQ; inv EQ. rewrite H1. auto.
  assert (B: rs'#arg = Vint n).
  generalize (REGS arg); intro LD; inv LD; congruence.
  left; exists O; exists (State s' (transf_function gapp f) sp pc' rs' m'); split.
  destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto.
  eapply match_states_succ; eauto.
  simpl. eapply list_nth_z_in; eauto.
  unfold transfer; rewrite  H; auto.

  (* Ireturn *)
  exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]].
  left; exists O; exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split.
  eapply exec_Ireturn; eauto. TransfInstr; auto.
  constructor; auto.
  eapply mem_match_approx_free; eauto.
  destruct or; simpl; auto.

  (* internal function *)
  exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl.
  intros [m2' [A B]].
  simpl. unfold transf_function.
  left; exists O; econstructor; split.
  eapply exec_function_internal; simpl; eauto.
  simpl. econstructor; eauto.
  apply analyze_correct_3; auto.
  apply analyze_correct_3; auto.
  eapply mem_match_approx_alloc; eauto.
  instantiate (1 := f). constructor.
  apply init_regs_lessdef; auto.

  (* external function *)
  exploit external_call_mem_extends; eauto.
  intros [v' [m2' [A [B [C D]]]]].
  simpl. left; econstructor; econstructor; split.
  eapply exec_function_external; eauto.
  eapply external_call_symbols_preserved; eauto.
  exact symbols_preserved. exact varinfo_preserved.
  constructor; auto.
  eapply mem_match_approx_extcall; eauto.

  (* return *)
  inv H4. inv H1.
  left; exists O; econstructor; split.
  eapply exec_return; eauto.
  econstructor; eauto. constructor. apply set_reg_lessdef; auto.
Qed.

Lemma transf_initial_states:
  forall st1, initial_state prog st1 ->
  exists n, exists st2, initial_state tprog st2 /\ match_states n st1 st2.
Proof.
  intros. inversion H.
  exploit function_ptr_translated; eauto. intro FIND.
  exists O; exists (Callstate nil (transf_fundef gapp f) nil m0); split.
  econstructor; eauto.
  apply Genv.init_mem_transf; auto.
  replace (prog_main tprog) with (prog_main prog).
  rewrite symbols_preserved. eauto.
  reflexivity.
  rewrite <- H3. apply sig_function_translated.
  constructor.
  eapply mem_match_approx_init; eauto.
  constructor. constructor. apply Mem.extends_refl.
Qed.

Lemma transf_final_states:
  forall n st1 st2 r,
  match_states n st1 st2 -> final_state st1 r -> final_state st2 r.
Proof.
  intros. inv H0. inv H. inv STACKS. inv RES. constructor.
Qed.

(** The preservation of the observable behavior of the program then
  follows. *)

Theorem transf_program_correct:
  forward_simulation (RTL.semantics prog) (RTL.semantics tprog).
Proof.
  eapply Forward_simulation with (fsim_order := lt); simpl.
  apply lt_wf.
  eexact transf_initial_states.
  eexact transf_final_states.
  fold ge; fold tge. intros.
    exploit transf_step_correct; eauto.
    intros [ [n2 [s2' [A B]]] | [n2 [A [B C]]]].
    exists n2; exists s2'; split; auto. left; apply plus_one; auto.
    exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl.
  eexact symbols_preserved.
Qed.

End PRESERVATION.


Require Import language.
Require Import msl.base.
Require Import msl.seplog.
Require Import msl.alg_seplog.
Require Import seplogic.
Require Import lseg.
Require Import msl.Coqlib2.
Require Import msl.log_normalize.
Require Import client_lemmas.

Local Open Scope logic.

Import Semax.

Section PROG.

Let a : var := 0.
Let s : var := 1.
Let p : var := 2.
Let r : var := 3.
Let START : adr := 0.
Let LOOP : adr := 1.
Let DONE : adr := 2.

Definition STARTbody := (a::nil,
                  Do Mem a := a .+ 1; Do Mem (a .+ 1) := a .+ 2; Do Mem (a .+ 2) := Const 0;
                  Go LOOP ((a.+3)::(Var a)::(Var a)::(Const DONE)::nil)).

Definition LOOPbody := (a::s::p::r::nil,
                If p Then (Do p := Mem p; Go LOOP (Var a::Var s::Var p::Var r::nil))
                      Else Go r (Var a::Var s::nil)).

Definition DONEbody := (a::s::nil,  Go DONE (Var a::Var s::nil)).

Definition myprog : program :=
   (START, STARTbody):: (LOOP,  LOOPbody) :: (DONE,   DONEbody) :: nil.

Definition STARTspec : funspec := (a::nil,
               fun s => allocpool (eval (Var a) s)).
Definition DONEspec: funspec := (a::s::nil,
               fun s' => lseg (eval (Var s) s') (eval (Const 0) s') * allocpool (eval (Var a) s')).
Definition LOOPspec: funspec :=  (a::s::p::r::nil,
              fun s' => lseg (eval (Var s) s') (eval (Var p) s')
               * lseg (eval (Var p) s') (eval (Const 0) s')
               * allocpool (eval (Var a) s')
               && cont DONEspec (eval (Var r) s')).

Definition myspec := (START, STARTspec):: ((LOOP, LOOPspec) :: (DONE, DONEspec) :: nil).

Lemma prove_START: semax_body myspec STARTspec STARTbody.
 eapply semax_pre; [intro ; call_tac; apply derives_refl |  simpl ].
 rewrite' alloc.
 apply semax_prop; auto; intros _.
 forward.
 rewrite' alloc. rewrite' @sepcon_comm.  rewrite' @sepcon_assoc.
 forward.
 rewrite' alloc. rewrite' @sepcon_comm. do 2  rewrite' @sepcon_assoc.
 forward.
 forward.
 rewrite lseg_eq. normalize.
 apply andp_derives;  [ | apply funassert_e; reflexivity].
 rewrite (sepcon_comm (allocpool _)). repeat rewrite <- sepcon_assoc.
 rewrite (sepcon_comm (next (S (S (s0 a))) _)).
 apply sepcon_derives; auto.
 repeat rewrite sepcon_assoc. rewrite (next_gt_0 (s0 a)).
 normalize.
 eapply derives_trans;  [ |  eapply lseg_cons; try omega].
 eapply sepcon_derives; [ apply derives_refl |].
 rewrite sepcon_comm.
 eapply derives_trans;  [ |  eapply lseg_cons; try omega].
 eapply sepcon_derives; [ apply derives_refl |].
 apply next_lseg;  omega.
Qed.

Lemma prove_LOOP: semax_body myspec LOOPspec LOOPbody.
  eapply semax_pre; [intro ; call_tac; apply derives_refl | simpl ].
 forward.
 apply semax_pre
   with  (fun s' => EX x: adr, (next (s' p) x * |>lseg x 0 * lseg (s' s) (s' p) * allocpool (s' a)) &&
     cont DONEspec (s' r)).
 intro s'. normalize.
 rewrite (lseg_neq (s' p)) by auto. normalize. apply exp_right with y.
 apply andp_derives; auto.
 apply sepcon_derives; auto.
 rewrite sepcon_comm. auto.
 apply (@semax_exp' _ 0). intro tail.
 do 2 rewrite' @sepcon_assoc.
 apply semax_pre with (fun s0 => next (eval (Var p) s0) tail * TT &&
      |> subst p tail (fun s1 =>
                               lseg (eval (Var p) s1) 0 * lseg (eval (Var s) s1) (eval (Var p) s1)
                             * allocpool (eval (Var a) s1)
                             && cont DONEspec (s1 r)) s0);
  [ | apply semax_load_next; auto 50].
 intro.
 unfold subst. simpl. rewrite env_gss.
 rewrite env_gso by (intro Hx; inv Hx).
 rewrite env_gso by (intro Hx; inv Hx).
 rewrite env_gso by (intro Hx; inv Hx).
 apply andp_right.
 apply andp_left1. apply sepcon_derives; auto.
 normalize.
 rewrite later_andp.
 apply andp_derives.
 rewrite sepcon_comm.
 rewrite sepcon_assoc. rewrite sepcon_comm.
 eapply derives_trans. apply sepcon_derives; [ apply now_later | apply derives_refl].
 rewrite <- later_sepcon.
 apply later_derives.
 rewrite sepcon_comm.
 rewrite (sepcon_assoc _ (allocpool _)).
 repeat rewrite <- sepcon_assoc.
 rewrite sepcon_comm.
 repeat rewrite <- sepcon_assoc.
 apply sepcon_derives; auto.
 rewrite sepcon_comm. rewrite (sepcon_comm (lseg tail 0)).
 rewrite <- sepcon_assoc.
 apply lseg_cons_in_list_context.
 apply now_later.

 forward. normalize.
 apply andp_left1.
 rewrite (sepcon_comm (lseg (s0 s) _)). auto.
 forward.
 normalize.
 apply andp_left1. apply andp_left2. apply derives_refl.
 simpl. normalize.
 autorewrite with args. rewrite H. rewrite lseg_eq. normalize.
 apply andp_left1.
 apply andp_left1. auto.
Qed.

Lemma prove_DONE: semax_body myspec DONEspec DONEbody.
  eapply semax_pre; [intro ; call_tac; apply derives_refl | simpl ].
 forward.
 apply andp_left1.
 apply derives_refl.
Qed.

Lemma prove_myspec:   semax_func myspec myprog myspec.
Proof.
 func_tac; [apply prove_START | ].
 func_tac; [apply prove_LOOP | ].
 func_tac; [apply prove_DONE | ].
 apply semax_func_nil.
Qed.

 Lemma myprog_safe:  forall n, run myprog n <> None.
 Proof. intros. apply semax_sound. exists myspec.
   split. apply prove_myspec. reflexivity.
 Qed.

Definition run' (p: program) (n: nat) : bool :=
 match
    stepN p (nil, initial_heap p, Go (Const 0) (Const (boundary p) :: nil)) n
  with None => false | _ => true
 end.

Compute run' myprog 100.

End PROG.


Require Import Iron.Language.SimpleData.Exp.
Require Export Iron.Data.Context.
Require Export Iron.Data.Chain.

(********************************************************************)
(*  Evaluation contexts for expressions.
    This describes a place in the exp AST where the sub-expression
    there is able to take an evaluation step *)
Inductive exp_ctx : (exp -> exp) -> Prop :=

 (* The top level context names the entire expression *)
 | XcTop
   : exp_ctx  (fun x => x)

 (* Left of an application *)
 | XcApp1
   :  forall x2
   ,  exp_ctx  (fun xx => XApp xx x2)

 (* The right of an application can step only when the left is
    already a value. *)
 | XcApp2
   :  forall v1
   ,  value v1
   -> exp_ctx  (fun xx => XApp v1 xx)

 (* As the XCon constructor contains a list of sub-expressions,
    we need an additional exps_ctx context to indicate which one
    we're talking about. *)
 | XcCon
   :  forall dc C
   ,  exps_ctx wnfX C
   -> exp_ctx  (fun xx => XCon dc (C xx))

 (* We need to reduce the discriminant of a case to a value. *)
 | XcCase
   :  forall alts
   ,  exp_ctx  (fun xx => XCase xx alts).

Hint Constructors exp_ctx.


Set Warnings "-notation-overridden".

Require Import Category.Theory.
Require Import Category.Structure.Monoidal.
Require Import Category.Lib.
Require Import Category.Structure.Monoidal.Proofs.

Require Import Enriched.Category.
Require Import Enriched.Functor.
Require Import Enriched.Forget.Lib.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Section NaturalTransformation.

Context {V0: Category} {V : Monoidal}.
Context {C D : EnrichedCategory}.
Context {F G : C ⟶ D}.

Class EnrichedTransform := {
  etransform {x} : I ~> ehom (F x) (G x);

  enaturality {x y} :
    (postcompose etransform ∘ efmap (EnrichedFunctor:=F) << ehom x y ~~> ehom (F x) (G y) >> precompose etransform ∘ efmap (EnrichedFunctor:=G))%morphism;
}.

End NaturalTransformation.

Bind Scope enriched_transform_scope with EnrichedTransform.
Delimit Scope enriched_transform_type_scope with enriched_transform_type.
Delimit Scope enriched_transform_scope with enriched_transform.
Open Scope enriched_transform_type_scope.
Open Scope enriched_transform_scope.

Notation "F ⟹ G" := (@EnrichedTransform _ _ _ _ F G)
  (at level 90, right associativity) : enriched_transform_type_scope.

Coercion etransform : EnrichedTransform >-> Funclass.

Section Equivalence.

Context {V0: Category} {V : Monoidal}.
Context {C D : EnrichedCategory}.

Program Definition enat_equiv {F G : C ⟶ D} : crelation (F ⟹ G) :=
  fun n m => ∀ A, n A ≈ m A.

Hint Unfold enat_equiv.

Global Program Definition enat_equiv_equivalence {F G : C ⟶ D} :
  Equivalence (@enat_equiv F G).
Proof.
  equivalence.
  transitivity (y A);auto.
Qed.

Global Program Instance enat_Setoid {F G : C ⟶ D} :
  Setoid (F ⟹ G) := {
  equiv := enat_equiv;
  setoid_equiv := enat_equiv_equivalence
}.

End Equivalence.

Section Compose.

Context {V0: Category} {V : Monoidal}.

Program Definition outside {C D : EnrichedCategory} {F G : C ⟶ D} (a : F ⟹ G)
 {E : EnrichedCategory} (H : E ⟶ C) : F ○ H ⟹ G ○ H := {|
  etransform := fun _ => etransform (EnrichedTransform:=a)%morphism;
|}.
Next Obligation.
  normal.
  rewrite enaturality.
  reflexivity.
Qed.

Program Definition inside {C D : EnrichedCategory} {F G : C ⟶ D} (a : F ⟹ G)
 {E : EnrichedCategory} (H : D ⟶ E) : H ○ F ⟹ H ○ G := {|
  etransform := fun _ => (efmap ∘ etransform (EnrichedTransform:=a))%morphism;
|}.
Next Obligation.
  normal.
  unfold postcompose, precompose.
  rewrite (comp_assoc_sym _ unit_left⁻¹).
  rewrite <- from_unit_left_natural.
  rewrite (comp_assoc_sym _ unit_right⁻¹).
  rewrite <- from_unit_right_natural.
  normal.
  assert ((efmap ∘ a y) ⨂ efmap << I ⨂ ehom (F x) (F y) ~~> ehom (H (F y)) (H (G y)) ⨂ ehom (H (F x)) (H (F y)) >> efmap ⨂ efmap ∘ a y ⨂ id)%morphism.
  {
    normal.
    reflexivity.
  }
  rewrite X;clear X.
  assert (efmap ⨂ (efmap ∘ a x) << ehom (G x) (G y) ⨂ I ~~> ehom (H (G x)) (H (G y)) ⨂ ehom (H (F x)) (H (G x)) >> efmap ⨂ efmap ∘ id ⨂ a x)%morphism.
  {
    normal.
    reflexivity.
  }
  rewrite X;clear X.
  repeat rewrite comp_assoc.
  do 2 rewrite efmap_comp.
  repeat rewrite comp_assoc_sym.
  f_equiv.
  repeat rewrite comp_assoc.
  fold (postcompose (a y) : ehom (F x) (F y) ~> ehom (F x) (G y)).
  fold (precompose (a x) : ehom (G x) (G y) ~> ehom (F x) (G y)).
  rewrite enaturality.
  reflexivity.
Qed.

Program Definition VerticalComposite {C D : EnrichedCategory} {F G H : C ⟶ D} (b : G ⟹ H) (a : F ⟹ G) : F ⟹ H := {|
  etransform := fun _ => ecompose0 (etransform (EnrichedTransform:=b)) (etransform (EnrichedTransform:=a));
|}.
Next Obligation.
  rewrite post_comp, pre_comp.
  rewrite comp_assoc_sym, enaturality, comp_assoc.
  rewrite pre_post_commute.
  rewrite comp_assoc_sym, enaturality, comp_assoc.
  reflexivity.
Qed.

Global Instance vert_comp_respects {C D : EnrichedCategory} {F G H : C ⟶ D} :
  Proper (equiv ==> equiv ==> equiv) (@VerticalComposite C D F G H).
Proof.
  proper.
  unfold ecompose0.
  rewrite (X A).
  rewrite (X0 A).
  reflexivity.
Qed.

Program Definition enat_id {C D : EnrichedCategory} {F : C ⟶ D} : F ⟹ F := {|
  etransform := fun _ => eid
|}.
Next Obligation.
  rewrite post_id.
  rewrite pre_id.
  reflexivity.
Qed.

Lemma vert_comp_id_right {C D : EnrichedCategory} {F G : C ⟶ D} {a : F ⟹ G} : VerticalComposite a enat_id ≈ a.
Proof.
  intro.
  simpl.
  apply ecomp0_id_right.
Qed.

Lemma vert_comp_id_left {C D : EnrichedCategory} {F G : C ⟶ D} {a : F ⟹ G} : VerticalComposite enat_id a ≈ a.
Proof.
  intro.
  simpl.
  apply ecomp0_id_left.
Qed.

Lemma vert_comp_assoc {C D : EnrichedCategory} {F G H K : C ⟶ D} (c : H  ⟹ K) (b : G  ⟹ H) (a : F ⟹ G) :
  VerticalComposite (VerticalComposite c b) a ≈ VerticalComposite c (VerticalComposite b a).
Proof.
  intro.
  simpl.
  apply ecomp0_assoc.
Qed.

Lemma inside_outside {C D E : EnrichedCategory} {F G : C ⟶ D} {H K : D ⟶ E} {a  : F ⟹ G} {b : H ⟹ K} : VerticalComposite (outside b G) (inside a H) ≈ VerticalComposite (inside a K) (outside b F).
Proof.
  intro.
  simpl.
  rewrite ecompose0_postcompose.
  rewrite ecompose0_precompose.
  normal.
  rewrite <- enaturality.
  reflexivity.
Qed.

Definition HorizontalComposite {C D E : EnrichedCategory} {F G : C ⟶ D} {H K : D ⟶ E} (b : H ⟹ K) (a  : F ⟹ G) : H ○ F ⟹ K ○ G := VerticalComposite (outside b G) (inside a H).

Lemma outside_id {C D E : EnrichedCategory} {F : C ⟶ D} {G : D ⟶ E} : outside enat_id F ≈ enat_id.
Proof.
  intro.
  simpl.
  reflexivity.
Qed.

Lemma inside_id {C D E : EnrichedCategory} {F : C ⟶ D} {G : E ⟶ C} : inside enat_id F ≈ enat_id.
Proof.
  intro.
  simpl.
  apply efmap_id.
Qed.

Lemma outside_vertical {C D E : EnrichedCategory} {F G H : C ⟶ D} {K : E ⟶ C} {a : F ⟹ G} {b : G ⟹ H} : outside (VerticalComposite b a) K ≈ VerticalComposite (outside b K) (outside a K).
Proof.
  intro.
  simpl.
  reflexivity.
Qed.

Lemma inside_vertical {C D E : EnrichedCategory} {F G H : C ⟶ D} {K : D ⟶ E} {a : F ⟹ G} {b : G ⟹ H} : inside (VerticalComposite b a) K ≈ VerticalComposite (inside b K) (inside a K).
Proof.
  intro.
  simpl.
  apply efmap_comp0.
Qed.

Lemma interchange_law {C D E : EnrichedCategory} {F G H : C ⟶ D} {K L M : D ⟶ E} {a : F ⟹ G} {b : G ⟹ H} {c : K ⟹ L} {d : L ⟹ M}
  : HorizontalComposite (VerticalComposite d c) (VerticalComposite b a) ≈ VerticalComposite (HorizontalComposite d b) (HorizontalComposite c a).

Proof.
  unfold HorizontalComposite.
  rewrite outside_vertical.
  rewrite inside_vertical.
  rewrite vert_comp_assoc.
  rewrite <- (vert_comp_assoc (outside c H)).
  rewrite inside_outside.
  repeat rewrite vert_comp_assoc.
  reflexivity.
Qed.

(*
Lemma hori_comp_id_right {C D : EnrichedCategory} {F G : C ⟶ D} {a : F ⟹ G} : HorizontalComposite a enat_id ≈ a.
*)

End Compose.

Notation "F ⊙ G" := (VerticalComposite F G) (at level 40, left associativity) : enriched_category_scope.


Require Import Fiat.Common Fiat.Computation
        Fiat.ADT.ADTSig Fiat.ADT.Core
        Fiat.ADTRefinement.Core Fiat.ADTRefinement.GeneralRefinements
        Fiat.ADTRefinement.SetoidMorphisms.

Section DelegateMethods.

  (* One way to implement some common functionality is to delegate it
     to the methods of some ADT.

     The first step in this process is to augment the representation
     of the delegating ADT with an instance of the ADT to delegate to.
     *)

  (* Signature of the ADT doing the delegating. *)
  Variable delegatorSig : ADTSig.

  (* ADT doing the delegating. *)
  Variable delegatorADT : ADT delegatorSig.

  (* Indices of the methods that will be delegated to. *)
  Variable delegateIndex : Type.

  (* Codomain of the new methods. *)
  Variable delegateCod : MethodIndex delegatorSig -> option Type.

  (* Signature of the ADT being delegated to. *)
  Definition delegateSig :=
    {| MethodIndex := MethodIndex delegatorSig;
       MethodDomCod idx :=
         (fst (MethodDomCod delegatorSig idx), delegateCod idx)
    |}.

  (* ADT being delegated to. *)
  Variable delegateADT : ADT delegateSig.

  Local Open Scope comp_scope.

  (*Definition ADTwDelegatedMethods : ADT delegatorSig :=
    {| Rep := Rep delegatorADT * Rep delegateADT;
       Constructors idx x :=
         (r1 <- Constructors delegatorADT idx x;
          r2 <- Constructors delegateADT idx x;
          ret (r1, r2));
       Methods idx r x :=
         (r1 <- Methods delegatorADT idx (fst r) x;
          r2 <- Methods delegateADT idx (snd r) x;
          ret ((fst r1, fst r2), snd r1 ))
    |}.

  Lemma refineADT_DelegatedMethods :
    refineADT delegatorADT ADTwDelegatedMethods.
  Proof.
    unfold ADTwDelegatedMethods; destruct delegatorADT;
    eapply refineADT_Build_ADT_Rep with
    (AbsR := fun or nr => or = fst nr); simpl; intros; subst.
    - unfold refine; intros; computes_to_inv; subst;
      computes_to_econstructor; eauto.
    - f_equiv; unfold pointwise_relation, refine; intros.
      computes_to_inv; subst.
      repeat computes_to_econstructor; eauto.
  Qed. *)

End DelegateMethods.