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

 Cartesian  objects

 We define the notions of cartesian objects internal to
 arbitrary bicategories. To define this notion, we use two steps. We first
 define objects 'with terminal objects' and objects 'with products'.

 Each of these concepts can be defined in 2 ways. We can use a representable
 variation or we use adjunctions. This is similar for categories: we can
 define whether a category has limits/colimits by saying that a certain functor
 has a right or a left adjoint.

 Contents
 1. The representable definition of cartesian objects
 2. Being cartesian is a proposition
 3. The definitions of cartesian objects via adjunctions
 4. Equivalence of the two definitions of cartesian object

 *******************************************************************************)
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.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.limits.initial.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.Preservation.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Core.UnivalenceOp.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Products.

Local Open Scope cat.

(**
 1. The representable definition of cartesian objects
 *)
Definition cartesian_terminal
           {B : bicat}
           (b : B)
  : UU
  := (∏ (x : B), Terminal (hom x b))
     ×
     (∏ (x y : B) (f : x --> y), preserves_terminal (pre_comp b f)).

Definition cartesian_prod
           {B : bicat}
           (b : B)
  : UU
  := (∏ (x : B), BinProducts (hom x b))
     ×
     (∏ (x y : B) (f : x --> y), preserves_binproduct (pre_comp b f)).

Definition cartesian_ob
           {B : bicat}
           (b : B)
  : UU
  := cartesian_terminal b × cartesian_prod b.

(**
 2. Being cartesian is a proposition
 *)
Definition isaprop_cartesian_terminal
           {B : bicat}
           (HB : is_univalent_2_1 B)
           (b : B)
  : isaprop (cartesian_terminal b).
Proof.
  use isapropdirprod.
  - use impred ; intro.
    apply isaprop_Terminal.
    apply is_univ_hom.
    exact HB.
  - do 3 (use impred ; intro).
    apply isaprop_preserves_terminal.
Qed.

Definition isaprop_cartesian_prod
           {B : bicat}
           (HB : is_univalent_2_1 B)
           (b : B)
  : isaprop (cartesian_prod b).
Proof.
  use isapropdirprod.
  - do 3 (use impred ; intro).
    apply isaprop_BinProduct.
    apply is_univ_hom.
    exact HB.
  - do 3 (use impred ; intro).
    apply isaprop_preserves_binproduct.
Qed.

Definition isaprop_cartesian_ob
           {B : bicat}
           (HB : is_univalent_2_1 B)
           (b : B)
  : isaprop (cartesian_ob b).
Proof.
  use isapropdirprod.
  - apply isaprop_cartesian_terminal.
    exact HB.
  - apply isaprop_cartesian_prod.
    exact HB.
Qed.

(**
 3. The definitions of cartesian objects via adjunctions
 *)
Section CartesianViaAdjunction.
  Context {B : bicat}
          (b : B).

  Section Terminal.
    Context (T : bifinal_obj B).

    Let f : b --> pr1 T
      := is_bifinal_1cell_property (pr2 T) b.

    Definition cartesian_terminal_via_adj
      : UU
      := left_adjoint f.

    Definition isaprop_cartesian_terminal_via_adj
               (HB : is_univalent_2_1 B)
      : isaprop cartesian_terminal_via_adj.
    Proof.
      apply isaprop_left_adjoint.
      exact HB.
    Qed.
  End Terminal.

  Section Prod.
    Context (prod : has_binprod B).

    Let δ : b --> pr1 (prod b b)
      := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b).

    Definition cartesian_prod_via_adj
      : UU
      := left_adjoint δ.

    Definition isaprop_cartesian_prod_via_adj
               (HB : is_univalent_2_1 B)
      : isaprop cartesian_prod_via_adj.
    Proof.
      apply isaprop_left_adjoint.
      exact HB.
    Qed.
  End Prod.

  Section Cartesian.
    Context (T : bifinal_obj B)
            (prod : has_binprod B).

    Definition cartesian_ob_via_adj
      : UU
      := cartesian_terminal_via_adj T × cartesian_prod_via_adj prod.

    Definition isaprop_cartesian_ob_via_adj
               (HB : is_univalent_2_1 B)
      : isaprop cartesian_ob_via_adj.
    Proof.
      apply isapropdirprod.
      - apply isaprop_cartesian_terminal_via_adj.
        exact HB.
      - apply isaprop_cartesian_prod_via_adj.
        exact HB.
    Qed.
  End Cartesian.
End CartesianViaAdjunction.

(**
4. Equivalence of the two definitions of cartesian object
 *)
Section EquivalenceCartesian.
  Context {B : bicat}
          (T : bifinal_obj B)
          (prod : has_binprod B)
          (b : B).

  Section ToAdj.
    Context (Hb : cartesian_terminal b).

    Let term : Terminal (hom (pr1 T) b) := pr1 Hb (pr1 T).

    Let l : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b.
    Let r : pr1 T --> b := pr1 term.

    Local Definition cartesian_terminal_to_cartesian_terminal_via_adj_unit
      : id₁ b ==> l · r
      := TerminalArrow (_ ,, pr2 Hb _ _ l _ (pr2 term)) (id₁ b).

    Let η : id₁ b ==> l · r
      := cartesian_terminal_to_cartesian_terminal_via_adj_unit.

    Local Definition cartesian_terminal_to_cartesian_terminal_via_adj_counit
      : r · l ==> id₁ (pr1 T)
      := is_bifinal_2cell_property (pr2 T) (pr1 T) (r · l) (id₁ (pr1 T)).

    Let ε : r · l ==> id₁ (pr1 T)
      := cartesian_terminal_to_cartesian_terminal_via_adj_counit.

    Definition cartesian_terminal_to_cartesian_terminal_via_adj
      : cartesian_terminal_via_adj b T.
    Proof.
      simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
      - exact r.
      - exact η.
      - exact ε.
      - apply (is_bifinal_eq_property (pr2 T)).
      - apply (@TerminalArrowEq _ term).
    Defined.
  End ToAdj.

  Section FromAdj.
    Context (Hb : cartesian_terminal_via_adj b T).

    Let l : b --> pr1 T := is_bifinal_1cell_property (pr2 T) b.
    Let r : pr1 T --> b := left_adjoint_right_adjoint (pr1 Hb).
    Let η : id₁ b ==> l · r := left_adjoint_unit (pr1 Hb).
    Let ε : r · l ==> id₁ (pr1 T) := left_adjoint_counit (pr1 Hb).
    Let p
      : rinvunitor r • (r ◃ η) • lassociator r l r • (ε ▹ r) • lunitor r
        =
        id₂ r
      := internal_triangle2 (pr2 Hb).

    Definition cartesian_terminal_via_adj_to_cartesian_terminal_1cell
               (x : B)
      : x --> b
      := is_bifinal_1cell_property (pr2 T) x · r.

    Definition cartesian_terminal_via_adj_to_cartesian_terminal_2cell
               (x : B)
               (f : x --> b)
      : f ==> cartesian_terminal_via_adj_to_cartesian_terminal_1cell x
      := rinvunitor _
         • (_ ◃ η)
         • lassociator _ _ _
         • (is_bifinal_2cell_property (pr2 T) _ _ _ ▹ r).

    Definition cartesian_terminal_via_adj_to_cartesian_terminal_eq
               (x : B)
               (f : x --> b)
      : isaprop (f ==> cartesian_terminal_via_adj_to_cartesian_terminal_1cell x).
    Proof.
      use invproofirrelevance.
      intros α β.
      refine (!(id2_right _) @ _ @ id2_right _).
      unfold cartesian_terminal_via_adj_to_cartesian_terminal_1cell.
      rewrite <- lwhisker_id2.
      rewrite <- p.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite !left_unit_inv_assoc.
      rewrite !vassocr.
      rewrite !rinvunitor_natural.
      rewrite <- !rwhisker_hcomp.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
      rewrite !lwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      rewrite !vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
      rewrite !lwhisker_hcomp.
      rewrite inverse_pentagon_4.
      rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp.
      rewrite !vassocr.
      rewrite <- !rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !vassocr.
      do 4 apply maponpaths_2.
      apply maponpaths.
      apply (is_bifinal_eq_property (pr2 T)).
    Qed.

    Definition cartesian_terminal_via_adj_to_cartesian_terminal_obj
               (x : B)
      : Terminal (hom x b).
    Proof.
      use make_Terminal.
      - exact (cartesian_terminal_via_adj_to_cartesian_terminal_1cell x).
      - intro f.
        use iscontraprop1.
        + exact (cartesian_terminal_via_adj_to_cartesian_terminal_eq x f).
        + exact (cartesian_terminal_via_adj_to_cartesian_terminal_2cell x f).
    Defined.

    Definition cartesian_terminal_via_adj_to_cartesian_terminal_preserves
               {x y : B}
               (f : x --> y)
      : preserves_terminal (pre_comp b f).
    Proof.
      use preserves_terminal_if_preserves_chosen.
      - apply cartesian_terminal_via_adj_to_cartesian_terminal_obj.
      - use (iso_to_Terminal
               (cartesian_terminal_via_adj_to_cartesian_terminal_obj x)).
        use inv2cell_to_z_iso.
        refine (comp_of_invertible_2cell
                  (rwhisker_of_invertible_2cell
                     _
                     _)
                  (rassociator_invertible_2cell _ _ _)).
        apply (is_bifinal_invertible_2cell_property (pr2 T)).
    Defined.

    Definition cartesian_terminal_via_adj_to_cartesian_terminal
      : cartesian_terminal b.
    Proof.
      split.
      - exact cartesian_terminal_via_adj_to_cartesian_terminal_obj.
      - exact @cartesian_terminal_via_adj_to_cartesian_terminal_preserves.
    Defined.
  End FromAdj.

  Definition cartesian_terminal_weq_cartesian_terminal_via_adj
             (HB : is_univalent_2_1 B)
    : cartesian_terminal b ≃ cartesian_terminal_via_adj b T.
  Proof.
    use weqimplimpl.
    - exact cartesian_terminal_to_cartesian_terminal_via_adj.
    - exact cartesian_terminal_via_adj_to_cartesian_terminal.
    - apply isaprop_cartesian_terminal.
      exact HB.
    - apply isaprop_cartesian_terminal_via_adj.
      exact HB.
  Defined.

  Section ToAdj.
    Context (Hb : cartesian_prod b).

    Let δ : b --> pr1 (prod b b)
      := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b).

    Let product
      : BinProduct
          (hom (pr1 (prod b b)) b)
          (binprod_cone_pr1 (pr1 (prod b b)))
          (binprod_cone_pr2 (pr1 (prod b b)))
      := pr1 Hb (pr1 (prod b b))
                (binprod_cone_pr1 (pr1 (prod b b)))
                (binprod_cone_pr2 (pr1 (prod b b))).

    Let r : pr1 (prod b b) --> b
      := BinProductObject _ product.

    Local Definition cartesian_prod_to_cartesian_prod_via_adj_unit
      : id₁ b ==> δ · r.
    Proof.
      use (BinProductArrow
             _
             (make_BinProduct
                _ _ _ _ _ _
                (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))).
      - exact ((binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1).
      - exact ((binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1).
    Defined.

    Let η : id₁ b ==> δ · r
      := cartesian_prod_to_cartesian_prod_via_adj_unit.

    Local Definition cartesian_prod_to_cartesian_prod_via_adj_counit
      : r · δ ==> id₁ _.
    Proof.
      use (binprod_ump_2cell (pr2 (prod b b))).
      - exact (rassociator _ _ _
               • (r ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))
               • runitor _
               • BinProductPr1 _ product
               • linvunitor _).
      - exact (rassociator _ _ _
               • (r ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))
               • runitor _
               • BinProductPr2 _ product
               • linvunitor _).
    Defined.

    Let ε : r · δ ==> id₁ _
      := cartesian_prod_to_cartesian_prod_via_adj_counit.

    Local Lemma cartesian_prod_to_cartesian_prod_via_adj_triangle1
      : linvunitor δ • (η ▹ δ) • rassociator δ r δ • (δ ◃ ε) • runitor δ
        =
        id₂ δ.
    Proof.
      use (binprod_ump_2cell_unique_alt (pr2 (prod b b))).
      - rewrite id2_rwhisker.
        rewrite <- !rwhisker_vcomp.
        rewrite <- lunitor_lwhisker.
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          rewrite lwhisker_vcomp.
          do 2 apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply binprod_ump_2cell_pr1.
          }
          rewrite !vassocl.
          rewrite linvunitor_lunitor.
          rewrite id2_right.
          apply idpath.
        }
        rewrite <- !lwhisker_vcomp.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_rwhisker_alt.
          rewrite !vassocl.
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_lwhisker_rassociator.
            rewrite !vassocl.
            apply idpath.
          }
          rewrite !vassocr.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite runitor_triangle.
            apply idpath.
          }
          rewrite !vassocr.
          rewrite vcomp_runitor.
          rewrite !vassocl.
          apply maponpaths.
          apply (BinProductPr1Commutes
                   _ _ _
                   (make_BinProduct
                      _ _ _ _ _ _
                      (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))).
        }
        etrans.
        {
          rewrite !vassocr.
          rewrite <- linvunitor_assoc.
          rewrite lwhisker_hcomp.
          rewrite <- linvunitor_natural.
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite runitor_lunitor_identity.
            rewrite linvunitor_lunitor.
            apply id2_left.
          }
          apply vcomp_rinv.
        }
        apply idpath.
      - rewrite id2_rwhisker.
        rewrite <- !rwhisker_vcomp.
        rewrite <- lunitor_lwhisker.
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          rewrite lwhisker_vcomp.
          do 2 apply maponpaths.
          etrans.
          {
            apply maponpaths_2.
            apply binprod_ump_2cell_pr2.
          }
          rewrite !vassocl.
          rewrite linvunitor_lunitor.
          rewrite id2_right.
          apply idpath.
        }
        rewrite <- !lwhisker_vcomp.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_rwhisker_alt.
          rewrite !vassocl.
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lwhisker_lwhisker_rassociator.
            rewrite !vassocl.
            apply idpath.
          }
          rewrite !vassocr.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply maponpaths.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite runitor_triangle.
            apply idpath.
          }
          rewrite !vassocr.
          rewrite vcomp_runitor.
          rewrite !vassocl.
          apply maponpaths.
          apply (BinProductPr2Commutes
                   _ _ _
                   (make_BinProduct
                      _ _ _ _ _ _
                      (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))).
        }
        etrans.
        {
          rewrite !vassocr.
          rewrite <- linvunitor_assoc.
          rewrite lwhisker_hcomp.
          rewrite <- linvunitor_natural.
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite runitor_lunitor_identity.
            rewrite linvunitor_lunitor.
            apply id2_left.
          }
          apply vcomp_rinv.
        }
        apply idpath.
    Qed.

    Local Lemma cartesian_prod_to_cartesian_prod_via_adj_triangle2
      : rinvunitor r • (r ◃ η) • lassociator r δ r • (ε ▹ r) • lunitor r
        =
        id₂ r.
    Proof.
      use (BinProductArrowsEq _ _ _ (product)) ; cbn.
      - rewrite !vassocl.
        rewrite id2_left.
        rewrite <- vcomp_lunitor.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite <- lwhisker_lwhisker.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          do 3 apply maponpaths_2.
          rewrite lwhisker_vcomp.
          apply maponpaths.
          apply (BinProductPr1Commutes
                   _ _ _
                   (make_BinProduct
                      _ _ _ _ _ _
                      (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))).
        }
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr1.
        }
        rewrite !vassocl.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite lassociator_rassociator.
          rewrite id2_left.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_vcomp.
          rewrite vcomp_linv.
          rewrite lwhisker_id2.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rinvunitor_runitor.
        rewrite id2_left.
        rewrite !vassocl.
        rewrite linvunitor_lunitor.
        apply id2_right.
      - rewrite !vassocl.
        rewrite id2_left.
        rewrite <- vcomp_lunitor.
        etrans.
        {
          do 3 apply maponpaths.
          rewrite !vassocr.
          rewrite vcomp_whisker.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite <- lwhisker_lwhisker.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          do 3 apply maponpaths_2.
          rewrite lwhisker_vcomp.
          apply maponpaths.
          apply (BinProductPr2Commutes
                   _ _ _
                   (make_BinProduct
                      _ _ _ _ _ _
                      (pr2 Hb _ _ δ _ _ _ _ _ (pr2 product)))).
        }
        rewrite !vassocl.
        etrans.
        {
          do 3 apply maponpaths.
          apply maponpaths_2.
          apply binprod_ump_2cell_pr2.
        }
        rewrite !vassocl.
        etrans.
        {
          do 2 apply maponpaths.
          rewrite !vassocr.
          rewrite lassociator_rassociator.
          rewrite id2_left.
          rewrite !vassocl.
          apply idpath.
        }
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite lwhisker_vcomp.
          rewrite vcomp_linv.
          rewrite lwhisker_id2.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rinvunitor_runitor.
        rewrite id2_left.
        rewrite !vassocl.
        rewrite linvunitor_lunitor.
        apply id2_right.
    Qed.

    Definition cartesian_prod_to_cartesian_prod_via_adj
      : cartesian_prod_via_adj b prod.
    Proof.
      simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
      - exact r.
      - exact η.
      - exact ε.
      - exact cartesian_prod_to_cartesian_prod_via_adj_triangle1.
      - exact cartesian_prod_to_cartesian_prod_via_adj_triangle2.
    Defined.
  End ToAdj.

  Section FromAdj.
    Context (Hb : cartesian_prod_via_adj b prod).

    Let δ : b --> pr1 (prod b b)
      := binprod_ump_1cell (pr2 (prod b b)) (id₁ b) (id₁ b).
    Let r : pr1 (prod b b) --> b := left_adjoint_right_adjoint (pr1 Hb).
    Let η : id₁ b ==> δ · r := left_adjoint_unit (pr1 Hb).
    Let ε : r · δ ==> id₁ _ := left_adjoint_counit (pr1 Hb).
    Let p
      : rinvunitor r • (r ◃ η) • lassociator r δ r • (ε ▹ r) • lunitor r
        =
        id₂ r
      := internal_triangle2 (pr2 Hb).

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_1cell
                     {x : B}
                     (f g : x --> b)
      : x --> b
      := binprod_ump_1cell (pr2 (prod b b)) f g · r.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr1_help
      : r ==> binprod_cone_pr1 (pr1 (prod b b))
      := rinvunitor _
         • (r ◃ (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1)
         • lassociator _ _ _
         • (ε ▹ _)
         • lunitor _.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr1
                     {x : B}
                     (f g : x --> b)
      : cartesian_prod_via_adj_to_cartesian_prod_1cell f g ==> f
      := (_ ◃ cartesian_prod_via_adj_to_cartesian_prod_pr1_help)
         • binprod_ump_1cell_pr1 (pr2 (prod b b)) _ f g.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr2_help
      : r ==> binprod_cone_pr2 (pr1 (prod b b))
      := rinvunitor _
         • (r ◃ (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ (id₁ b) (id₁ b))^-1)
         • lassociator _ _ _
         • (ε ▹ _)
         • lunitor _.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_pr2
                     {x : B}
                     (f g : x --> b)
      : cartesian_prod_via_adj_to_cartesian_prod_1cell f g ==> g
      := (_ ◃ cartesian_prod_via_adj_to_cartesian_prod_pr2_help)
         • binprod_ump_1cell_pr2 (pr2 (prod b b)) _ f g.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_2cell
                     {x : B}
                     {f g k : x --> b}
                     (α : k ==> f)
                     (β : k ==> g)
      : k ==> cartesian_prod_via_adj_to_cartesian_prod_1cell f g.
    Proof.
      refine (rinvunitor _
              • (_ ◃ η)
              • lassociator _ _ _
              • (binprod_ump_2cell (pr2 (prod b b)) _ _ ▹ r)).
      - exact (rassociator _ _ _
               • (k ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)
               • runitor _
               • α
               • (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)^-1).
      - exact (rassociator _ _ _
               • (k ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)
               • runitor _
               • β
               • (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)^-1).
    Defined.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_2cell_pr1
                     {x : B}
                     {f g k : x --> b}
                     (α : k ==> f)
                     (β : k ==> g)
      : cartesian_prod_via_adj_to_cartesian_prod_2cell α β
        • cartesian_prod_via_adj_to_cartesian_prod_pr1 f g
        =
        α.
    Proof.
      unfold cartesian_prod_via_adj_to_cartesian_prod_2cell.
      unfold cartesian_prod_via_adj_to_cartesian_prod_pr1.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        refine (vcomp_whisker _ _ @ _).
        apply maponpaths.
        apply binprod_ump_2cell_pr1.
      }
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      refine (_ @ id2_left _).
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite id2_right.
      refine (_ @ id2_left _).
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !lwhisker_vcomp.
      refine (_ @ lwhisker_id2 _ _).
      apply maponpaths.
      unfold cartesian_prod_via_adj_to_cartesian_prod_pr1_help.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite left_unit_inv_assoc.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          do 3 apply maponpaths_2.
          rewrite lwhisker_hcomp.
          rewrite inverse_pentagon_4.
          rewrite <- rwhisker_hcomp.
          apply idpath.
        }
        rewrite !vassocl.
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_lwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite <- lunitor_V_id_is_left_unit_V_id.
      rewrite !vassocr.
      rewrite lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite id2_right.
      refine (_ @ id2_left _).
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !rwhisker_vcomp.
      refine (_ @ id2_rwhisker _ _).
      apply maponpaths.
      rewrite !vassocr.
      exact (pr12 Hb).
    Qed.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_2cell_pr2
                     {x : B}
                     {f g k : x --> b}
                     (α : k ==> f)
                     (β : k ==> g)
      : cartesian_prod_via_adj_to_cartesian_prod_2cell α β
        • cartesian_prod_via_adj_to_cartesian_prod_pr2 f g
        =
        β.
    Proof.
      unfold cartesian_prod_via_adj_to_cartesian_prod_2cell.
      unfold cartesian_prod_via_adj_to_cartesian_prod_pr2.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        refine (vcomp_whisker _ _ @ _).
        apply maponpaths.
        apply binprod_ump_2cell_pr2.
      }
      rewrite !vassocl.
      rewrite vcomp_linv.
      rewrite id2_right.
      refine (_ @ id2_left _).
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_rassociator.
        rewrite id2_left.
        apply idpath.
      }
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite id2_right.
      refine (_ @ id2_left _).
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !lwhisker_vcomp.
      refine (_ @ lwhisker_id2 _ _).
      apply maponpaths.
      unfold cartesian_prod_via_adj_to_cartesian_prod_pr2_help.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite left_unit_inv_assoc.
      rewrite !vassocl.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          do 3 apply maponpaths_2.
          rewrite lwhisker_hcomp.
          rewrite inverse_pentagon_4.
          rewrite <- rwhisker_hcomp.
          apply idpath.
        }
        rewrite !vassocl.
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_lwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rinvunitor_natural.
      rewrite <- rwhisker_hcomp.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite <- lunitor_V_id_is_left_unit_V_id.
      rewrite !vassocr.
      rewrite lwhisker_hcomp.
      rewrite <- linvunitor_natural.
      rewrite !vassocl.
      use vcomp_move_R_pM ; [ is_iso | ] ; cbn.
      rewrite id2_right.
      refine (_ @ id2_left _).
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !rwhisker_vcomp.
      refine (_ @ id2_rwhisker _ _).
      apply maponpaths.
      rewrite !vassocr.
      exact (pr12 Hb).
    Qed.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_eq
                     {x : B}
                     {f g k : x --> b}
                     (α : k ==> f)
                     (β : k ==> g)
                     (φ : ∑ (fg : k ==> cartesian_prod_via_adj_to_cartesian_prod_1cell f g),
                          fg • cartesian_prod_via_adj_to_cartesian_prod_pr1 f g = α
                          ×
                          fg • cartesian_prod_via_adj_to_cartesian_prod_pr2 f g = β)
      : φ
        =
        cartesian_prod_via_adj_to_cartesian_prod_2cell α β
        ,,
        cartesian_prod_via_adj_to_cartesian_prod_2cell_pr1 α β
        ,,
        cartesian_prod_via_adj_to_cartesian_prod_2cell_pr2 α β.
    Proof.
      use subtypePath.
      {
        intro.
        apply isapropdirprod ; apply cellset_property.
      }
      cbn.
      refine (!(id2_right _) @ _).
      unfold cartesian_prod_via_adj_to_cartesian_prod_1cell.
      rewrite <- lwhisker_id2.
      rewrite <- p.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      rewrite !left_unit_inv_assoc.
      rewrite !vassocr.
      rewrite !rinvunitor_natural.
      rewrite <- !rwhisker_hcomp.
      unfold cartesian_prod_via_adj_to_cartesian_prod_2cell.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
      rewrite !lwhisker_lwhisker_rassociator.
      rewrite !vassocr.
      rewrite !vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !(maponpaths (λ z, _ • z) (vassocr _ _ _)).
      rewrite !lwhisker_hcomp.
      rewrite inverse_pentagon_4.
      rewrite <- !lwhisker_hcomp, <- !rwhisker_hcomp.
      rewrite !vassocr.
      rewrite <- !rwhisker_rwhisker.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !(maponpaths (λ z, _ • (_ • z)) (vassocr _ _ _)).
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      rewrite lunitor_lwhisker.
      rewrite !rwhisker_vcomp.
      apply maponpaths.
      use (binprod_ump_2cell_unique_alt (pr2 (prod b b))).
      - rewrite binprod_ump_2cell_pr1.
        rewrite <- !rwhisker_vcomp.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn.
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        rewrite rwhisker_hcomp.
        rewrite <- rinvunitor_natural.
        rewrite !vassocl.
        use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
        refine (_ @ pr12 φ).
        unfold cartesian_prod_via_adj_to_cartesian_prod_pr1 ; cbn.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        unfold cartesian_prod_via_adj_to_cartesian_prod_pr1_help.
        rewrite !vassocl.
        rewrite <- rinvunitor_triangle.
        rewrite <- !lwhisker_vcomp.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          rewrite lassociator_rassociator.
          rewrite id2_rwhisker.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        apply runitor_rwhisker.
      - rewrite binprod_ump_2cell_pr2.
        rewrite <- !rwhisker_vcomp.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso ; apply property_from_invertible_2cell | ] ; cbn.
        rewrite !vassocr.
        rewrite <- vcomp_whisker.
        rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite !vassocr.
        rewrite rwhisker_hcomp.
        rewrite <- rinvunitor_natural.
        rewrite !vassocl.
        use vcomp_move_L_Mp ; [ is_iso | ] ; cbn.
        refine (_ @ pr22 φ).
        unfold cartesian_prod_via_adj_to_cartesian_prod_pr2 ; cbn.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        apply maponpaths_2.
        unfold cartesian_prod_via_adj_to_cartesian_prod_pr2_help.
        rewrite !vassocl.
        rewrite <- rinvunitor_triangle.
        rewrite <- !lwhisker_vcomp.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rwhisker_vcomp.
          rewrite lassociator_rassociator.
          rewrite id2_rwhisker.
          rewrite id2_left.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        apply runitor_rwhisker.
    Qed.

    Local Definition cartesian_prod_via_adj_to_cartesian_prod_obj
                     (x : B)
      : BinProducts (hom x b).
    Proof.
      intros f g.
      use make_BinProduct.
      - exact (cartesian_prod_via_adj_to_cartesian_prod_1cell f g).
      - exact (cartesian_prod_via_adj_to_cartesian_prod_pr1 f g).
      - exact (cartesian_prod_via_adj_to_cartesian_prod_pr2 f g).
      - intros k α β.
        use make_iscontr.
        + simple refine (_ ,, (_ ,, _)).
          * exact (cartesian_prod_via_adj_to_cartesian_prod_2cell α β).
          * exact (cartesian_prod_via_adj_to_cartesian_prod_2cell_pr1 α β).
          * exact (cartesian_prod_via_adj_to_cartesian_prod_2cell_pr2 α β).
        + apply cartesian_prod_via_adj_to_cartesian_prod_eq.
    Defined.

    Local Definition help_inv2cell
                     {x y : B}
                     (f : x --> y)
                     (h₁ h₂ : y --> b)
      : invertible_2cell
          (f
           · BinProductObject
               (hom y b)
               (cartesian_prod_via_adj_to_cartesian_prod_obj y h₁ h₂))
          (BinProductObject
             (hom x b)
             (cartesian_prod_via_adj_to_cartesian_prod_obj x (f · h₁) (f · h₂))).
    Proof.
      refine (comp_of_invertible_2cell
                (lassociator_invertible_2cell _ _ _)
                (rwhisker_of_invertible_2cell
                   _
                   _)).
      use make_invertible_2cell.
      - use (binprod_ump_2cell (pr2 (prod b b))).
        + exact (rassociator _ _ _
                 • (_ ◃ binprod_ump_1cell_pr1 (pr2 (prod b b)) _ h₁ h₂)
                 • (binprod_ump_1cell_pr1 (pr2 (prod b b)) _ _ _)^-1).
        + exact (rassociator _ _ _
                 • (_ ◃ binprod_ump_1cell_pr2 (pr2 (prod b b)) _ h₁ h₂)
                 • (binprod_ump_1cell_pr2 (pr2 (prod b b)) _ _ _)^-1).
      - use binprod_ump_2cell_invertible.
        + is_iso.
          apply property_from_invertible_2cell.
        + is_iso.
          apply property_from_invertible_2cell.
    Defined.

    Definition cartesian_prod_via_adj_to_cartesian_prod_preserves
               {x y : B}
               (f : x --> y)
      : preserves_binproduct (pre_comp b f).
    Proof.
      use preserves_binproduct_if_preserves_chosen.
      - apply cartesian_prod_via_adj_to_cartesian_prod_obj.
      - intros h₁ h₂.
        use (isBinProduct_eq_arrow
               _ _
               (pr2 (iso_to_BinProduct
                       _
                       (cartesian_prod_via_adj_to_cartesian_prod_obj x (f · h₁) (f · h₂))
                       (z_iso_to_iso
                          (inv2cell_to_z_iso
                             (help_inv2cell f h₁ h₂)))))).
        + cbn.
          unfold cartesian_prod_via_adj_to_cartesian_prod_pr1.
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            etrans.
            {
              apply maponpaths_2.
              apply vcomp_whisker.
            }
            rewrite !vassocl.
            etrans.
            {
              apply maponpaths.
              apply maponpaths_2.
              apply binprod_ump_2cell_pr1.
            }
            rewrite !vassocl.
            rewrite vcomp_linv.
            rewrite id2_right.
            apply idpath.
          }
          rewrite !vassocr.
          etrans.
          {
            do 2 apply maponpaths_2.
            refine (!_).
            apply lwhisker_lwhisker.
          }
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lassociator_rassociator.
            apply id2_left.
          }
          apply lwhisker_vcomp.
        + cbn.
          unfold cartesian_prod_via_adj_to_cartesian_prod_pr2.
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            etrans.
            {
              apply maponpaths_2.
              apply vcomp_whisker.
            }
            rewrite !vassocl.
            etrans.
            {
              apply maponpaths.
              apply maponpaths_2.
              apply binprod_ump_2cell_pr2.
            }
            rewrite !vassocl.
            rewrite vcomp_linv.
            rewrite id2_right.
            apply idpath.
          }
          rewrite !vassocr.
          etrans.
          {
            do 2 apply maponpaths_2.
            refine (!_).
            apply lwhisker_lwhisker.
          }
          rewrite !vassocl.
          etrans.
          {
            apply maponpaths.
            rewrite !vassocr.
            rewrite lassociator_rassociator.
            apply id2_left.
          }
          apply lwhisker_vcomp.
    Qed.

    Definition cartesian_prod_via_adj_to_cartesian_prod
      : cartesian_prod b.
    Proof.
      split.
      - exact cartesian_prod_via_adj_to_cartesian_prod_obj.
      - exact @cartesian_prod_via_adj_to_cartesian_prod_preserves.
    Defined.
  End FromAdj.

  Definition cartesian_prod_weq_cartesian_prod_via_adj
             (HB : is_univalent_2_1 B)
    : cartesian_prod b ≃ cartesian_prod_via_adj b prod.
  Proof.
    use weqimplimpl.
    - exact cartesian_prod_to_cartesian_prod_via_adj.
    - exact cartesian_prod_via_adj_to_cartesian_prod.
    - apply isaprop_cartesian_prod.
      exact HB.
    - apply isaprop_cartesian_prod_via_adj.
      exact HB.
  Defined.

  Definition cartesian_weq_cartesian_via_adj
             (HB : is_univalent_2_1 B)
    : cartesian_ob b ≃ cartesian_ob_via_adj b T prod.
  Proof.
    use weqdirprodf.
    - exact (cartesian_terminal_weq_cartesian_terminal_via_adj HB).
    - exact (cartesian_prod_weq_cartesian_prod_via_adj HB).
  Defined.
End EquivalenceCartesian.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


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

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

Print Assumptions mul.


Require Import Morphisms Coq.Floats.SpecFloat.
From FloatCohorts Require Import Option Arith FloatPair Cohorts Tactics.

Open Scope Z.

Section natural_normalization.

  Fixpoint maximize_e' (m : positive) (e : Z) {struct m} : (positive * Z) :=
    match m with
    | (m'~0)%positive => maximize_e' m' (e + 1)
    | _ => (m, e)
    end.

  (** maximize exponent [same as] minimize mantissa [same as] make mantissa odd **)
  Definition maximize_e (fp : float_pair) :=
    let '(m, e) := (FPnum fp, FPexp fp) in
    let '(m', e') := maximize_e' m e in
    FPair m' e'.

  Lemma maximize_e_is_inc_e_by (fp : float_pair) :
    maximize_e fp = fp \/ exists de, inc_e_by fp de = Some (maximize_e fp).
  Proof.
    destruct fp as (m, e).
    generalize dependent e.
    induction m; auto.
    intros.
    right.
    specialize (IHm (e + 1)).
    destruct IHm.
    -
      exists 1%positive.
      cbn in *.
      congruence.
    -
      destruct H as [de H].
      exists (de + 1)%positive.
      cbn in *.
      rewrite <-H.
      clear.
      unfold inc_e_by.
      rewrite Pos.iter_add.
      reflexivity.
  Qed.

  Lemma maximize_e_equiv (fp : float_pair) :
    maximize_e fp === fp.
  Proof.
    pose proof maximize_e_is_inc_e_by fp.
    destruct H.
    rewrite H; reflexivity.
    destruct H.
    enough (T : Some (maximize_e fp) === Some fp)
      by (inversion T; congruence).
    rewrite <-H.
    apply inc_e_by_equiv.
    rewrite H.
    constructor.
  Qed.

  Instance maximize_e_proper :
    Proper (equiv ==> equiv) maximize_e.
  Proof.
    intros fp1 fp2 EQ.
    repeat rewrite maximize_e_equiv.
    assumption.
  Qed.

End natural_normalization.

Section IEEE754_normalization.

  Variable prec emax : Z.
  Let emin := emin emax prec.
  Hypothesis prec_gt_0 : 0 < prec.
  Hypothesis Hmax : prec < emax.

  Definition normal_pair (fp : float_pair) :=
    let '(m, e) := (FPnum fp, FPexp fp) in
    bounded prec emax m e.

  Lemma bounded_arithmetic (m : positive) (e : Z) :
      bounded prec emax m e = true
      <->
      (Z.pos (Pos.size m) < prec /\ e = emin) \/
      (Z.pos (Pos.size m) = prec /\ emin <= e <= emax - prec).
  Proof.
    intros.
    unfold bounded, canonical_mantissa, fexp, emin, SpecFloat.emin.
    destruct (Z_lt_le_dec (Z.pos (digits2_pos m) + e - prec)
                               (3 - emax - prec)).
    all: try rewrite Z.max_r in * by lia.
    all: try rewrite Z.max_l in * by lia.
    all: split; intros.
    all: rewrite Bool.andb_true_iff in *.
    all: rewrite <-Zeq_is_eq_bool in *.
    all: replace (digits2_pos m) with (Pos.size m) in * by reflexivity.
    all: rewrite Z.leb_le in *.
    all: lia.
  Qed.

  (** ** normalization *)
  (* first try to satisfy the left side of [bounded_arithmetic],
     then try the right side if that doesn't work *)
  Definition normalize_pair (fp : float_pair)
    : option float_pair :=
    match set_e fp emin with
    | None => None
    | Some f1 => if Z.pos (Pos.size (FPnum f1)) <=? prec
                then Some f1
                else match set_digits_m fp (Z.to_pos prec) with
                     | None => None
                     | Some f2 => if andb
                                      (emin <=? FPexp f2)
                                      (FPexp f2 <=? emax - prec)
                                 then Some f2
                                 else None
                     end
    end.

  Lemma normalize_pair_equiv (fp : float_pair) :
    is_Some (normalize_pair fp) ->
    normalize_pair fp === Some fp.
  Proof.
    unfold normalize_pair.
    intros.
    repeat break_match; try (inversion H; fail).
    -
      rewrite <-Heqo.
      apply set_e_equiv.
      rewrite Heqo; constructor.
    -
      rewrite <-Heqo0.
      apply set_digits_m_equiv.
      rewrite Heqo0; constructor.
  Qed.

  Lemma normal_pair_unique (fp1 fp2 : float_pair) :
    normal_pair fp1 = true ->
    normal_pair fp2 = true ->
    fp1 === fp2 ->
    fp1 = fp2.
  Proof.
    intros.
    destruct fp1 as (m1, e1), fp2 as (m2, e2).
    unfold normal_pair in *.
    rewrite bounded_arithmetic in *.
    cbn in H, H0.
    destruct H as [[M1 E1] | [M1 E1]],
             H0 as [[M2 E2] | [M2 E2]].
    -
      apply exponent_unique; try assumption.
      subst; reflexivity.
    -
      subst.
      apply equiv_neq_m_digits in H1; [| cbn; lia].
      cbn in *; lia.
    -
      subst.
      symmetry in H1.
      apply equiv_neq_m_digits in H1; [| cbn; lia].
      cbn in *; lia.
    -
      apply digits_m_unique; try assumption.
      cbn.
      congruence.
  Qed.

  Lemma normalize_pair_normal (fp : float_pair) :
    forall fp', normalize_pair fp = Some fp' ->
    normal_pair fp' = true.
  Proof.
    intros.
    unfold normal_pair.
    apply bounded_arithmetic.
    unfold normalize_pair in H.
    repeat break_match; inversion H; subst; clear H.
    -
      apply Z.leb_le in Heqb.
      apply set_e_res in Heqo.
      rewrite Heqo; clear Heqo.
      unfold emin, SpecFloat.emin.
      lia.
    -
      clear Heqo Heqb.
      apply andb_prop in Heqb0.
      destruct Heqb0.
      rewrite Z.leb_le in *.
      apply set_digits_m_res in Heqo0.
      unfold digits_m in Heqo0.
      rewrite Heqo0; clear Heqo0.
      unfold emin, SpecFloat.emin in *.
      rewrite Z2Pos.id by assumption.
      lia.
  Qed.

  Theorem normalize_pair_None_inv (fp : float_pair) :
    normalize_pair fp = None
    ->
    forall fp', fp' === fp -> normal_pair fp' = false.
  Proof.
    intros.
    destruct (normal_pair fp') eqn:NP'; [| reflexivity].
    exfalso.
    unfold normal_pair in NP'.
    apply bounded_arithmetic in NP'.
    unfold normalize_pair in H.
    repeat break_match; inversion_clear H.
    -
      rewrite Bool.andb_false_iff in *.
      apply set_e_spec in Heqo; destruct Heqo.
      apply set_digits_m_spec in Heqo0; destruct Heqo0.

      (* cleanup *)
      replace (Pos.size (FPnum f))
        with (digits_m f)
        in *
        by reflexivity. (* poor man's fold 1 *)
      replace (Pos.size (FPnum fp'))
        with (digits_m fp')
        in *
        by reflexivity. (* poor man's fold 2 *)
      rename f into f1, f0 into f2, fp' into f.
      assert (EQ1 : f === f1) by (rewrite H, H0; reflexivity).
      assert (EQ2 : f === f2) by (rewrite H0, H2; reflexivity).
      clear H H2 H0 fp.
      move f before f1; move f2 before f1.
      rename H1 into E1, Heqb into M1, H3 into M2.

      destruct Heqb0 as [E2 | E2]; rewrite Z.leb_gt in *.
      +
        destruct NP' as [[M E] | [M E]].
        *
          clear - EQ1 M1 E1 M E.
          enough (FPexp f > FPexp f1) by lia.
          eapply equiv_neq_m_digits.
          assumption.
          lia.
        *
          clear - EQ2 M2 E2 M E.
          enough (digits_m f2 > digits_m f)%positive
            by (rewrite <-M, Pos2Z.id in M2; lia).
          eapply equiv_neq_e_digits.
          symmetry; assumption.
          lia.
      +
        destruct NP' as [[M E] | [M E]].
        *
          clear - EQ1 M1 E1 M E.
          enough (FPexp f > FPexp f1) by lia.
          eapply equiv_neq_m_digits.
          assumption.
          lia.
        *
          clear - EQ2 M2 E2 M E.
          enough (digits_m f > digits_m f2)%positive
            by (rewrite <-M, Pos2Z.id in M2; lia).
          eapply equiv_neq_e_digits.
          assumption.
          lia.
    -
      rewrite Z.leb_gt in *.
      apply set_e_spec in Heqo; destruct Heqo.
      apply set_digits_m_None_inv with (fp':=fp') in Heqo0; [ |assumption].
      unfold digits_m in *.
      destruct NP' as [[M E] | [M E]].
      +
        replace fp' with f in *.
        lia.
        apply exponent_unique.
        lia.
        rewrite H, H0; reflexivity.
      +
        rewrite <-M in Heqo0.
        rewrite Pos2Z.id in Heqo0.
        lia.
    -
      apply set_e_None_inv with (fp':=fp') in Heqo;
        [lia | assumption].
  Qed.

  Theorem normalize_pair_spec (fp nfp : float_pair) :
    normalize_pair fp = Some nfp
    <->
    (fp === nfp /\ normal_pair nfp = true).
  Proof.
    split; intros.
    -
      split.
      +
        assert (SN : is_Some (normalize_pair fp)) by (rewrite H; constructor).
        apply normalize_pair_equiv in SN.
        rewrite H in SN.
        inversion SN.
        symmetry; assumption.
      +
        eapply normalize_pair_normal.
        eassumption.
    -
      destruct H as [EQ N].
      destruct normalize_pair eqn:NP.
      +
        assert (SN : is_Some (normalize_pair fp)) by (rewrite NP; constructor).
        apply normalize_pair_equiv in SN.
        rewrite NP in SN.
        apply normalize_pair_normal in NP.
        f_equal.
        apply normal_pair_unique.
        assumption.
        assumption.
        rewrite <-EQ.
        inversion SN.
        assumption.
      +
        exfalso.
        apply normalize_pair_None_inv with (fp':=nfp) in NP.
        congruence.
        symmetry; assumption.
  Qed.

End IEEE754_normalization.


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

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

Print Assumptions carry.


Require Import HoTT.
Require Import setoid squot_properties.
From HoTT.Categories Require Import
  Category Functor NaturalTransformation FunctorCategory Adjoint.

Definition setoid_map (R₁ R₂ : setoid) : Type
  := {f : under R₁ -> under R₂ & forall (x₁ x₂ : under R₁),
              rel R₁ x₁ x₂ -> rel R₂ (f x₁) (f x₂)}.

Definition setoid_idmap (R : setoid) : setoid_map R R.
Proof.
  exists idmap.
  intros ? ? .
  exact idmap.
Defined.

Definition setoid_compose
           {R₁ R₂ R₃ : setoid}
           (g : setoid_map R₂ R₃) (f : setoid_map R₁ R₂)
  : setoid_map R₁ R₃.
Proof.
  exists (g.1 o f.1).
  intros x y p.
  exact (g.2 _ _ (f.2 _ _ p)).
Defined.

Global Instance setoid_map_hset
       (R₁ R₂ : setoid)
       `{Univalence}
  : IsHSet (setoid_map R₁ R₂)
  := _.

Definition setoids_precat `{Univalence} : PreCategory.
Proof.
  simple refine {|object := setoid ;
                  morphism := setoid_map ;
                  Core.identity := setoid_idmap ;
                  Category.Core.compose := @setoid_compose|}
  ; try reflexivity.
Defined.

Definition set_precat `{Univalence} : PreCategory.
Proof.
  simple refine {|object := hSet ;
                  morphism := fun X Y => BuildhSet(X -> Y) ;
                  Core.identity := fun _ x => x ;
                  Category.Core.compose := fun _ _ _ g f => g o f|}
  ; try reflexivity.
Defined.

Definition path_setoid_functor `{Univalence}
  : Functor set_precat setoids_precat.
Proof.
  unshelve esplit.
  - apply path_setoid.
  - intros X Y f ; cbn in *.
    exact (f;fun x y => ap f).
  - intros X Y Z g f ; cbn in *.
    simple refine (path_sigma' _ _ _).
    + reflexivity.
    + apply path_ishprop.
  - intros X ; cbn in *.
    simple refine (path_sigma' _ _ _).
    + reflexivity.
    + apply path_ishprop.
Defined.

Definition squot_functor `{Univalence}
  : Functor setoids_precat set_precat.
Proof.
  unshelve esplit.
  - exact (fun R => BuildhSet (squot R)).
  - intros R₁ R₂ f ; cbn in *.
    simple refine (quotient_rec _ _ _).
    + exact (class_of _ o f.1).
    + intros x y p; cbn in *.
      apply related_classes_eq.
      exact (f.2 x y p).
  - intros R₁ R₂ R₃ g f ; cbn in *.
    funext z ; cbn in * ; revert z.
    simple refine (quotient_ind _ _ _ _).
    + reflexivity.
    + intros ; apply path_ishprop.
  - intros X ; cbn in *.
    funext z ; cbn in * ; revert z.
    simple refine (quotient_ind _ _ _ _).
    + reflexivity.
    + intros ; apply path_ishprop.
Defined.

Definition adjunction_squot `{Univalence}
  : AdjunctionUnitCounit squot_functor path_setoid_functor.
Proof.
  unshelve esplit.
  - simple refine (Build_NaturalTransformation _ _ _ _).
    + intros R ; cbn in *.
      refine (class_of (rel R);_) ; cbn.
      exact (fun _ _ p => related_classes_eq (rel R) p).
    + intros R₁ R₂ f ; cbn in *.
      simple refine (path_sigma' _ _ _).
      * reflexivity.
      * apply path_ishprop.
  - simple refine (Build_NaturalTransformation _ _ _ _).
    + intros X ; cbn in *.
      simple refine (quotient_rec _ _ _).
      * exact idmap.
      * intros ; assumption.
    + intros X Y f ; cbn in *.
      funext z ; revert z.
      simple refine (quotient_ind _ _ _ _).
      * reflexivity.
      * intros ; apply path_ishprop.
  - intros X ; cbn.
    funext z ; revert z.
    simple refine (quotient_ind _ _ _ _).
    + reflexivity.
    + intros ; apply path_ishprop.
  - intros R ; cbn.
    simple refine (path_sigma' _ _ _).
    + reflexivity.
    + apply path_ishprop.
Defined.

Definition squot_path_setoid `{Univalence}
  : NaturalTransformation (squot_functor o path_setoid_functor) 1
  := counit adjunction_squot.

Global Instance squot_path_setoid_isiso `{Univalence}
  : @IsIsomorphism (set_precat -> set_precat) _ _ squot_path_setoid.
Proof.
  apply isisomorphism_natural_transformation.
  intros X ; cbn in *.
  unshelve esplit ; cbn.
  - exact (class_of _).
  - funext z ; revert z.
    simple refine (quotient_ind _ _ _ _).
    + reflexivity.
    + intros ; apply path_ishprop.
  - funext z ; revert z.
    reflexivity.
Defined.


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

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

Print Assumptions carry.


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

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (sub a b) = F.sub (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Export D.

(** **** Problem #6 : 2 stars (hd_opt) *)
(** Using the same idea, fix the [hd] function from earlier so we don't
   have to pass a default element for the [nil] case.  *)

Definition hd_opt (l : natlist) : natoption :=
  match l with
| [] => None
| hd::tl => Some hd
end.

Example test_hd_opt1 : hd_opt [] = None.
Proof. reflexivity. Qed.
Example test_hd_opt2 : hd_opt [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_opt3 : hd_opt [5;6] = Some 5.
Proof. reflexivity. Qed.

(** This exercise relates your new [hd_opt] to the old [hd]. *)
Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_opt l).
Proof.
 intros. induction l. simpl. reflexivity.
 simpl.  reflexivity.
Qed.


(*could parametrize by what is currently bool for more diverse return types*)

(** Definition of a machine, and some machines.*)
CoInductive oracle_machine {i o} :=
| Halts : bool -> oracle_machine
| Steps : oracle_machine -> oracle_machine
| Calls : i -> (o -> oracle_machine) -> oracle_machine
.

Definition machine := @oracle_machine Empty_set Empty_set.

(* The eval_machine proposition asserts that a machine halts with output bool b. *)
Inductive eval_oracle_machine {i o} (oracle: i -> o -> Prop) : @oracle_machine i o -> bool -> Prop :=
| EvalHalts b :
    eval_oracle_machine oracle (Halts b) b
| EvalSteps m b :
    eval_oracle_machine oracle m b ->
    eval_oracle_machine oracle (Steps m) b
| EvalCalls input output continuation b :
    oracle input output ->
    eval_oracle_machine oracle (continuation output) b ->
    eval_oracle_machine oracle (Calls input continuation) b
.

Definition eval_tm : machine -> bool -> Prop := eval_oracle_machine (fun i => fun o => True).

(* Some simple Turing machines: looper, collatz, dumb. *)
CoFixpoint looper : machine := Steps looper.

Require Import Nat.

CoFixpoint collatz (x:nat) :machine :=
  if leb x 1
  then Halts true
  else if even x
       then Steps (collatz (div2 x))
       else Steps (collatz (3*x+1))
.

Definition halter (b:bool) : machine := Halts b.

(** Definition of a language, and some languages.*)
Definition language input := input -> Prop.

Definition halt_tm : language machine := fun m => exists b, eval_tm m b.

Definition superhalt_tm : language oracle_machine := fun om => exists b, eval_oracle_machine (fun i : machine => fun o : bool => eval_tm i o) om b.

Definition a_tm : language machine := fun m => eval_tm m true.

Definition l_true : language bool := eq true.

(** Definition of deciding a language.*)
Definition decides {input} (im : input -> machine) (l:language input) : Prop :=
  forall i:input,
  exists b:bool,
    eval_tm (im i) b /\ (l i <-> b=true).

Definition decidable {input} (l : language input) : Prop :=
  exists (im : input -> machine),
    decides im l.

Hint Constructors eval_oracle_machine.

Theorem halter_decides_l_true: decides halter (l_true).
Proof.
  intro i.
  exists i.
  split.
  constructor.
  unfold l_true.
  firstorder.
Qed.

Definition isReduction {input0 input1} (f: (input1 -> machine) -> (input0 -> machine))
           (l0:language input0) (l1:language input1) : Prop :=
  forall (m1 : input1 -> machine),
    decides m1 l1
    -> decides (f m1) l0.

Definition hasReduction {input0 input1} (l0:language input0) (l1:language input1) : Prop :=
  exists (f: (input1 -> machine) -> (input0 -> machine)),
    isReduction f l0 l1.

Theorem reduction_decidable {input0 input1}:
  forall (l0 : language input0) (l1 : language input1),
    hasReduction l0 l1
    -> decidable l1
    -> decidable l0.
Proof.
  intros.
  inversion H0.
  inversion H.
  unfold decidable.
  exists (x0 x).
  apply H2.
  assumption.
Qed.

Definition undecidable {input} (l : language input) : Prop :=
  ~ decidable l.

Theorem reduction_undecidable {input0 input1}:
  forall (l0 : language input0) (l1 : language input1),
    hasReduction l0 l1
    -> undecidable l0
    -> undecidable l1.
Proof.
  intros.
  intro.
  apply H0.
  eapply reduction_decidable.
  eassumption.
  assumption.
Qed.

(** Proving the Halting Problem is undecidable.*)

Definition frob (m : machine) : machine :=
  match m with
    | Halts b => Halts b
    | Steps m' => Steps m'
    | Calls input continuation => Calls input continuation
  end.

Lemma frob_eq m : m = frob m.
Proof.
  destruct m; reflexivity.
Qed.

CoFixpoint invert_output (m: machine): machine :=
  match m with
    | Halts true => looper
    | Halts false => Halts true
    | Steps m => Steps (invert_output m)
    | Calls input continuation => Calls input (fun output => invert_output (continuation output))
  end.

Lemma looper_loops :
  forall b, ~ eval_tm looper b.
Proof.
  remember looper.
  rewrite (frob_eq looper) in Heqm.
  induction 1; intros.
  - discriminate.
  - injection Heqm.
    rewrite (frob_eq looper).
    assumption.
  - discriminate.
Qed.

Lemma invert_output_lemma:
  forall m,
    eval_tm m false
    <-> halt_tm (invert_output m).
Proof.
  split.
  { remember false.
    induction 1; subst.
    exists true.
    rewrite (frob_eq (invert_output _)).
    apply EvalHalts.
    destruct IHeval_oracle_machine.
    reflexivity.
    exists x.
    rewrite (frob_eq (invert_output _)).
    simpl.
    apply EvalSteps.
    assumption.
    destruct input. }
  { destruct 1.
    remember (invert_output m).
    rewrite (frob_eq (invert_output _)) in Heqm0.
    revert m Heqm0.
    induction H; intros.
    { destruct m.
      { destruct b0.
        { discriminate. }
        { apply EvalHalts. }
      }
      { discriminate. }
      { destruct e. }
    }
    { destruct m0.
      { apply IHeval_oracle_machine.
        destruct b0.
        { injection Heqm0.
          intro.
          rewrite (frob_eq looper) in H0.
          apply H0. }
        { discriminate. } }
      { injection Heqm0.
        intro.
        constructor.
        apply IHeval_oracle_machine.
        rewrite <- frob_eq.
        assumption.
      }
      { destruct e. }
    }
    { destruct input. }
  }
Qed.

Lemma only_one_value:
  forall m a b,
    eval_tm m a
    -> eval_tm m b
    -> a = b.
Proof.
  induction 1.
  inversion 1.
  reflexivity.
  inversion 1.
  subst.
  apply IHeval_oracle_machine.
  assumption.
  destruct input.
Qed.

Definition troll_machine (halt_solver: machine -> machine) (tested: machine): machine :=
  invert_output (halt_solver tested).

Axiom quineify: forall (pre_quine: machine -> machine), machine.
Axiom quine_behavior:
  forall (pre_quine: machine -> machine) (b: bool),
    eval_tm (quineify pre_quine) b <-> eval_tm (pre_quine (quineify pre_quine)) b.

(*CoFixpoint troll_quine (halt_solver: machine -> machine): machine :=
  (invert_output (halt_solver (troll_quine halt_solver))).*)

Require Import Coq.Setoids.Setoid.
Theorem halting_problem_undecidable: undecidable halt_tm.
Proof.
  intro.
  destruct H as [halt_solver Hd].
  pose (quineify (troll_machine halt_solver)) as quine.
  destruct Hd with quine.
  destruct H.
  pose proof (quine_behavior (troll_machine halt_solver)).
  pose proof (invert_output_lemma (halt_solver quine)).
  absurd (false = true).
  discriminate.
  destruct x.
  { eapply only_one_value.
    { apply <- H2.
      destruct (proj2 H0 eq_refl).
      exists x.
      apply H1.
      assumption. }
    { assumption. }
  }
  { apply H0.
    destruct (proj1 H2 H).
    exists x.
    apply <- H1.
    assumption. }
Qed.

(*Definition atm_undecidable: (undecidable atm).*)

Theorem superhalting_problem_undecidable: undecidable superhalt_tm.
Proof.

Theorem l_leq_superhalt

(*whatever!*)


Require Import logic IZF Relation BaseMap.

Definition OpenSets A :=
  SSet
    (PowerSet (PowerSet A))
    (fun O =>
       (In Empty O /\ In A O) /\ (
         (forall S, Subset S O -> In (Unions S) O) /\
         (forall X1 X2, In X1 O -> In X2 O -> In (Section X1 X2) O)
       )
    ).

Theorem OUnions_In :
  forall {A} (X : #(OpenSets A)) (S : #(PowerSet X)),
    In (Unions S) X.
Proof.
  intros A X S.
  put (SetProp X) InXO.
  apply SSetTheorem in InXO.
  apply (proj1 (proj2 (proj2 InXO))).
  apply PowersetTheorem.
  apply SetProp.
Qed.

Definition OSection_In :
  forall {A} (X : #(OpenSets A)) (O1 O2 : #X),
    In (Section O1 O2) X.
Proof.
  intros A X O1 O2.
  put (SetProp X) InXO.
  apply SSetTheorem in InXO.
  apply (proj2 (proj2 (proj2 InXO))); apply SetProp.
Qed.

Definition OpenBases A :=
  SSet
    (PowerSet (PowerSet A))
    (fun O =>
       (Unions O) == A /\ forall X1 X2, In X1 O -> In X2 O -> forall x, In x (Section X1 X2) -> exists X3, In X3 O /\ (In x X3 /\ Subset X3 (Section X1 X2))
    ).

Definition OpenBases_to_OpenSets_Fun {A} (B : #(OpenBases A)) := FunctionImageRistriction Unions (PowerSet B).

Theorem OpenBases_to_OpenSets_Fun_In :
  forall A (B : #(OpenBases A)),
    In (OpenBases_to_OpenSets_Fun B) (OpenSets A).
Proof.
  intros A B.
  put (SetProp B) InBBase.
  apply SSetTheorem in InBBase.
  destruct InBBase as [InBP [BaseCond1 BaseCond2]].
  apply SSetTheorem.
  split.
  {
    apply PowersetTheorem.
    intros S InSF.
    apply FunctionImageRistrictionTheorem in InSF.
    destruct InSF as [X' [InX'PB UEq]].
    apply PowersetTheorem.
    intros a InaS.
    rewrite <- UEq in InaS.
    apply UnionsTheorem in InaS.
    destruct InaS as [X [InXX' InaX]].
    apply PowersetTheorem in InX'PB.
    apply InX'PB in InXX'.
    apply PowersetTheorem in InBP.
    apply InBP in InXX'.
    apply PowersetTheorem in InXX'.
    apply InXX'.
    apply InaX.
  }
  split.
  {
    split.
    {
      (* Include Empty Set *)
      apply FunctionImageRistrictionTheorem.
      exists Empty.
      split.
      {
        apply PowersetTheorem.
        apply AllSetHasEmpty.
      } {
        apply EA.
        intro x.
        split.
        {
          intro InxUE.
          apply UnionsTheorem in InxUE.
          destruct InxUE as [a [InaE _]].
          apply EmptyTheorem in InaE.
          destruct InaE.
        } {
          intro InxE.
          apply EmptyTheorem in InxE.
          destruct InxE.
        }
      }
    } {
      (* Include Whole Set *)
      apply FunctionImageRistrictionTheorem.
      exists B.
      split.
      {
        apply PowersetTheorem.
        apply ReflexivitySubset.
      } {
        apply BaseCond1.
      }
    }
  }
  split.
  {
    (* Close Under Union *)
    intros S SubSF.
    apply FunctionImageRistrictionTheorem.
    exists (SSet B (fun O' => Subset O' (Unions S))).
    split.
    {
      apply PowersetTheorem.
      intros O InOS.
      apply SSetSubset in InOS.
      apply InOS.
    } {
      apply EA.
      intro a.
      split.
      {
        intro InaU.
        apply UnionsTheorem in InaU.
        destruct InaU as [O [InOS InaO]].
        apply SSetTheorem in InOS.
        destruct InOS as [InOB SubOS].
        apply SubOS.
        apply InaO.
      } {
        intros InaU.
        apply UnionsTheorem in InaU.
        destruct InaU as [O [InOS InaO]].
        put InOS InOS'.
        apply SubSF in InOS'.
        apply FunctionImageRistrictionTheorem in InOS'.
        destruct InOS' as [B' [InB'B UEq]].
        rewrite <- UEq in InOS.
        apply PowersetTheorem in InB'B.
        apply UnionsTheorem.
        rewrite <- UEq in InaO.
        apply UnionsTheorem in InaO.
        destruct InaO as [O' [InO'B' InaO']].
        exists O'.
        split.
        {
          apply SSetTheorem.
          split.
          {
            apply InB'B.
            apply InO'B'.
          }
          intros a' Ina'O'.
          apply UnionsTheorem.
          exists (Unions B').
          split.
          {
            apply InOS.
          }
          apply UnionsTheorem.
          exists O'.
          split; assumption.
        }
        apply InaO'.
      }
    }
  }
  {
    (* Close Under Intersection *)
    intros O1 O2 InOF1 InOF2.
    apply FunctionImageRistrictionTheorem in InOF1.
    apply FunctionImageRistrictionTheorem in InOF2.
    destruct InOF1 as [B1 [SubBB1 EqB1]].
    destruct InOF2 as [B2 [SubBB2 EqB2]].
    apply PowersetTheorem in SubBB1.
    apply PowersetTheorem in SubBB2.
    apply FunctionImageRistrictionTheorem.
    exists (SSet B (fun O => Subset O (Section O1 O2))).
    split.
    {
      apply PowersetTheorem.
      apply SSetSubset.
    }
    apply EA.
    intro a.
    split.
    {
      intros InaU.
      apply UnionsTheorem in InaU.
      destruct InaU as [O [InOS InaO]].
      apply SSetTheorem in InOS.
      destruct InOS as [InOB SOS].
      apply SOS.
      apply InaO.
    } {
      intros InaS.
      apply SectionTheorem in InaS.
      destruct InaS as [InaO1 InaO2].
      rewrite <- EqB1 in InaO1.
      rewrite <- EqB2 in InaO2.
      apply UnionsTheorem in InaO1.
      apply UnionsTheorem in InaO2.
      destruct InaO1 as [O1' [InOB1' InaO1']].
      destruct InaO2 as [O2' [InOB2' InaO2']].
      assert(ExsO3 : exists O3', In O3' B /\ (In a O3' /\ Subset O3' (Section O1' O2'))).
      {
        apply BaseCond2.
        {
          apply SubBB1.
          assumption.
        }
        {
          apply SubBB2.
          assumption.
        }
        {
          apply SectionTheorem.
          split; assumption.
        }
      }
      destruct ExsO3 as [O3' [InO3'B [InaO3' SubO3']]].
      apply UnionsTheorem.
      exists O3'.
      split.
      {
        apply SSetTheorem.
        split.
        exact InO3'B.
        apply (TransitivitySubset _ SubO3').
        cut (Subset O1' O1 /\ Subset O2' O2).
        {
          intros [Sub1 Sub2].
          apply (TransitivitySubset (Section O1 O2')).
          exact (SubsetInSectionL _ _ _ Sub1).
          exact (SubsetInSectionR _ _ _ Sub2).
        }
        split.
        {
          intros x Inx1.
          rewrite <- EqB1.
          apply UnionsTheorem.
          exists O1'.
          split; assumption.
        } {
          intros x Inx2.
          rewrite <- EqB2.
          apply UnionsTheorem.
          exists O2'.
          split; assumption.
        }
      }
      exact InaO3'.
    }
  }
Qed.

Definition OpenBases_to_OpenSets {A} (B : #(OpenBases A)) := { _ ! OpenBases_to_OpenSets_Fun_In _ B}.

Theorem OpenBases_to_OpenSetsTheorem1 :
  forall {A} (B : #(OpenBases A)),
    Subset B (OpenBases_to_OpenSets B).
Proof.
  intros A B.
  intros O InOB.
  apply FunctionImageRistrictionTheorem.
  exists (Singleton O).
  split.
  {
    apply PowersetTheorem.
    intros O' EqO.
    apply SingletonTheorem in EqO.
    rewrite EqO.
    exact InOB.
  }
  apply EA.
  intro x.
  split.
  {
    intro InxU.
    apply UnionsTheorem in InxU.
    destruct InxU as [O' [EqO InxO']].
    apply SingletonTheorem in EqO.
    rewrite <- EqO.
    exact InxO'.
  } {
    intro InxO.
    apply UnionsTheorem.
    exists O.
    split.
    {
      apply SingletonTheorem.
      reflexivity.
    }
    exact InxO.
  }
Qed.

Theorem OpenBases_to_OpenSetsTheorem2 :
  forall {A} (B : #(OpenBases A)) (X : #(OpenSets A)),
    Subset B X -> Subset (OpenBases_to_OpenSets B) X.
Proof.
  intros A B X SubH.
  intros O InOB'.
  unfold OpenBases_to_OpenSets in InOB'.
  rewrite DSETEq in InOB'.
  apply FunctionImageRistrictionTheorem in InOB'.
  destruct InOB' as [B' [InB'B EqB]].
  rewrite <- EqB.
  put (SetProp X) InXO.
  apply SSetTheorem in InXO.
  apply (proj1 (proj2 (proj2 InXO))).
  generalize SubH.
  apply TransitivitySubset.
  apply PowersetTheorem in InB'B.
  exact InB'B.
Qed.


Require Import HoTT.

Open Scope list_scope.
Open Scope type_scope.

(** Standard notations for lists.
In a special module to avoid conflicts. *)
Module ListNotations.
Notation " [ ] " := nil (format "[ ]") : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
End ListNotations.

Import ListNotations.

  Fixpoint list_code {A: Type}(l l': list A) :=
    match l, l' with
    | [], [] => Unit
    | x::xs, y::ys => (x = y) /\ (list_code xs ys)
    | _, _ => Empty
    end.

  Infix "=list" := list_code (at level 70, right associativity).

  Fixpoint list_code_id {A: Type}(l: list A): l =list l :=
    match l with
    | [] => tt
    | x :: xs => (idpath, list_code_id xs)
    end.

  Definition list_encode {A: Type}(l l': list A): (l = l') -> (l =list l')
    := fun p => match p with | idpath => list_code_id _ end.

  Fixpoint list_decode {A: Type}(l l': list A): (l =list l') -> (l = l').
    induction l, l'; induction 1.
    exact idpath.
    f_ap.
    exact (list_decode A l l' snd).
    Defined.

  Global Instance isequiv_list_encode {A: Type}{l l': list A}:
                                      IsEquiv (list_encode l l').
    refine (isequiv_adjointify (list_encode l l') (list_decode l l') _ _); revert l l'.
    - unfold Sect.
      (* Should make up some tactic to use here TODO *)
      pose (T := fun (l l' : list A) (x : l =list l') => list_encode l l' (list_decode l l' x) = x).
      refine (fix sect (l l': list A) (x : l =list l'): T l l' x:= _ ).
      unfold T; intros.
      induction l, l'; unfold list_encode, list_decode; simpl.
      * exact (path_contr _ _).
      * induction x.
      * induction x.
      * destruct x as [p Ix].
        apply (sect l l') in Ix.


Require Import Setoid.
Require Export Category NaturalTransformation CategoryIsomorphisms.
Require Import Common FunctorIsomorphisms.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Local Ltac intro_object_of :=
  repeat match goal with
           | [ |- appcontext[ObjectOf ?G ?x] ] => unique_pose_with_body (ObjectOf G x)
         end.

Section NaturalIsomorphism.
  Section NaturalIsomorphism.
    Context `(C : @SpecializedCategory objC).
    Context `(D : @SpecializedCategory objD).
    Variables F G : SpecializedFunctor C D.

    Record NaturalIsomorphism :=
      {
        NaturalIsomorphism_Transformation :> SpecializedNaturalTransformation F G;
        NaturalIsomorphism_Isomorphism : forall x : objC, IsomorphismOf (NaturalIsomorphism_Transformation x)
      }.
  End NaturalIsomorphism.

  Section Inverse.
    Context `(C : @SpecializedCategory objC).
    Context `(D : @SpecializedCategory objD).
    Variables F G : SpecializedFunctor C D.

    Definition InverseNaturalIsomorphism_NT (T : NaturalIsomorphism F G) : NaturalTransformation G F.
      exists (fun x => Inverse (NaturalIsomorphism_Isomorphism T x)).
      abstract (
          intros;
          repeat match goal with
                   | [ |- appcontext[?E] ] => match type of E with | IsomorphismOf _ => destruct E; simpl end
                   | [ H : _ |- _ ] => rewrite H
                 end;
          destruct T as [ [ ] ];
          simpl in *;
          pre_compose_to_identity; post_compose_to_identity;
          auto with functor
        ).
    Defined.

    Definition InverseNaturalIsomorphism (T : NaturalIsomorphism F G) : NaturalIsomorphism G F
      := {|
          NaturalIsomorphism_Transformation := InverseNaturalIsomorphism_NT T;
          NaturalIsomorphism_Isomorphism := (fun x => InverseOf (NaturalIsomorphism_Isomorphism T x))
        |}.
  End Inverse.

  Section Composition.
    Context `(C : @SpecializedCategory objC).
    Context `(D : @SpecializedCategory objD).
    Context `(E : @SpecializedCategory objE).
    Variables F F' F'' : SpecializedFunctor C D.
    Variables G G' : SpecializedFunctor D E.

    Local Ltac t :=
      simpl;
      compose4associativity;
      repeat match goal with
               | _ => reflexivity
               | [ H : _ |- _ ] => rewrite H
               | _ => progress (repeat rewrite LeftIdentity; repeat rewrite RightIdentity)
               | _ => progress repeat rewrite <- FCompositionOf
               | _ => progress repeat rewrite FIdentityOf
               | [ |- appcontext[?E] ] =>
                 match type of E with
                   | IsomorphismOf _ => destruct E; simpl
                 end
             end.

    Definition NIComposeT (T' : NaturalIsomorphism F' F'') (T : NaturalIsomorphism F F') : NaturalIsomorphism F F''
      := {|
          NaturalIsomorphism_Transformation := NTComposeT T' T;
          NaturalIsomorphism_Isomorphism := (fun x => ComposeIsomorphismOf (NaturalIsomorphism_Isomorphism T' x) (NaturalIsomorphism_Isomorphism T x))
        |}.

    Definition NIComposeF (U : NaturalIsomorphism G G') (T : NaturalIsomorphism F F') : NaturalIsomorphism (ComposeFunctors G F) (ComposeFunctors G' F').
      exists (NTComposeF U T).
      intro x.
      exists (Compose (Inverse (NaturalIsomorphism_Isomorphism U (F x)))
                      (MorphismOf G' (Inverse (NaturalIsomorphism_Isomorphism T x))));
        abstract t.
    Defined.
  End Composition.
End NaturalIsomorphism.

Section NaturalIsomorphismOfCategories.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).

  Local Reserved Notation "'F'".
  Local Reserved Notation "'G'".

  Record NaturalIsomorphismOfCategories := {
    NaturalIsomorphismOfCategories_F : SpecializedFunctor C D where "'F'" := NaturalIsomorphismOfCategories_F;
    NaturalIsomorphismOfCategories_G : SpecializedFunctor D C where "'G'" := NaturalIsomorphismOfCategories_G;
    NaturalIsomorphismOfCategories_Isomorphism_C :> NaturalIsomorphism (IdentityFunctor C) (ComposeFunctors G F);
    NaturalIsomorphismOfCategories_Isomorphism_D : NaturalIsomorphism (IdentityFunctor D) (ComposeFunctors F G)
  }.

  Record IsomorphismOfCategories := {
    IsomorphismOfCategories_F : SpecializedFunctor C D where "'F'" := IsomorphismOfCategories_F;
    IsomorphismOfCategories_G : SpecializedFunctor D C where "'G'" := IsomorphismOfCategories_G;
    IsomorphismOfCategories_Isomorphism_C : ComposeFunctors G F = IdentityFunctor C;
    IsomorphismOfCategories_Isomorphism_D : ComposeFunctors F G = IdentityFunctor D
  }.
End NaturalIsomorphismOfCategories.

Section NaturalEquivalence.
  Variable C : Category.
  Variable D : Category.
  Variable F G : Functor C D.

  Definition NaturalEquivalenceOf (T : NaturalTransformation F G) :=
    forall x : C.(Object), IsomorphismOf (T.(ComponentsOf) x).

  Definition FunctorsNaturallyEquivalent : Prop :=
    exists T : NaturalTransformation F G, exists NE : NaturalEquivalenceOf T, True.
End NaturalEquivalence.

(* grumble, grumble, grumble, [Functors] take [SpecializedCategories] and so we don't get type inference.
   Perhaps I should fix this?  But I don't like having to prefix so many things with [Specialized] and
   having duplicated code just so I get type inference.
   *)
Arguments NaturalEquivalenceOf [C D F G] T.
Arguments FunctorsNaturallyEquivalent [C D] F G.

Section Coercions.
  Context `(C : @SpecializedCategory objC).
  Context `(D : @SpecializedCategory objD).
  Variables F G : SpecializedFunctor C D.
  Variable C' : Category.
  Variable D' : Category.
  Variables F' G' : Functor C' D'.

  Definition NaturalEquivalence_of_NaturalIsomorphism (T : NaturalIsomorphism F G) : NaturalEquivalenceOf T
    := fun x => NaturalIsomorphism_Isomorphism T x.

  Definition NaturalIsomorphism_of_NaturalEquivalence (T : NaturalTransformation F' G') (NE : NaturalEquivalenceOf T) : NaturalIsomorphism F' G'.
    exists T.
    exact (fun x => NE x : IsomorphismOf _).
  Defined.
End Coercions.

Coercion NaturalEquivalence_of_NaturalIsomorphism : NaturalIsomorphism >-> NaturalEquivalenceOf.
Coercion NaturalIsomorphism_of_NaturalEquivalence : NaturalEquivalenceOf >-> NaturalIsomorphism.
(* gives "Ambiguous paths"... Is this bad? *)

Section NaturalEquivalenceOfCategories.
  Variable C : Category.
  Variable D : Category.

  Definition NaturalEquivalenceOfCategories (F : Functor C D) (G : Functor D C) : Prop :=
    (FunctorsNaturallyEquivalent (IdentityFunctor C) (ComposeFunctors G F)) /\
    (FunctorsNaturallyEquivalent (IdentityFunctor D) (ComposeFunctors F G)).

  Definition CategoriesNaturallyEquivalent : Prop :=
    exists F : Functor C D, exists G : Functor D C, NaturalEquivalenceOfCategories F G.
End NaturalEquivalenceOfCategories.

Arguments NaturalEquivalenceOfCategories [C D] F G.

Section NaturalTransformationInverse.
  Variable C : Category.
  Variable D : Category.
  Variable F G : Functor C D.
  Variable T : NaturalTransformation F G.

  Hint Unfold InverseOf.
  Hint Resolve f_equal f_equal2 @Commutes.
  Hint Rewrite @LeftIdentity @RightIdentity.

  Definition NaturalEquivalenceInverse : NaturalEquivalenceOf T -> NaturalTransformation G F.
    refine (fun X => {| ComponentsOf := (fun c => proj1_sig (X c)) |});
      abstract (
        intros; destruct (X s); destruct (X d);
          simpl; unfold InverseOf in *; destruct_hypotheses;
            pre_compose_to_identity; post_compose_to_identity;
            auto
      ).
    (*morphisms 2*)
  Defined.

  Lemma NaturalEquivalenceInverse_NaturalEquivalence (TE : NaturalEquivalenceOf T) : NaturalEquivalenceOf (NaturalEquivalenceInverse TE).
    intro; apply InverseOf.
  Qed.
End NaturalTransformationInverse.

Section IdentityNaturalTransformation.
  Variable C : Category.
  Variable D : Category.
  Variable F : Functor C D.

  Theorem IdentityNaturalEquivalence : NaturalEquivalenceOf (IdentityNaturalTransformation F).
    hnf; intros; hnf; simpl; unfold InverseOf in *; eexists; t_with ltac:(eauto with morphism).
    Grab Existential Variables.
    eauto with morphism.
  Qed.
End IdentityNaturalTransformation.

Arguments IdentityNaturalEquivalence [C D] F x.

Hint Resolve @IdentityNaturalEquivalence @NaturalEquivalenceInverse_NaturalEquivalence : category.
Hint Resolve @IdentityNaturalEquivalence @NaturalEquivalenceInverse_NaturalEquivalence : natural_transformation.

Section FunctorNaturalEquivalenceRelation.
  Variable C : Category.
  Variable D : Category.

  Lemma functors_naturally_equivalent_refl (F : Functor C D) : FunctorsNaturallyEquivalent F F.
    exists (IdentityNaturalTransformation F); eauto with category.
  Qed.

  Lemma functors_naturally_equivalent_sym (F G : Functor C D) :
    FunctorsNaturallyEquivalent F G -> FunctorsNaturallyEquivalent G F.
    destruct 1 as [ ? [ H ] ]; exists (NaturalEquivalenceInverse H); eauto with category.
  Qed.

  Lemma functors_naturally_equivalent_trans (F G H : Functor C D) :
    FunctorsNaturallyEquivalent F G -> FunctorsNaturallyEquivalent G H -> FunctorsNaturallyEquivalent F H.
    destruct 1 as [ T [ ] ]; destruct 1 as [ U [ ] ];
      exists (NTComposeT U T); eexists; hnf; simpl; eauto with category.
  Qed.
End FunctorNaturalEquivalenceRelation.

Add Parametric Relation (C D : Category) : _ (@FunctorsNaturallyEquivalent C D)
  reflexivity proved by (@functors_naturally_equivalent_refl _ _)
  symmetry proved by (@functors_naturally_equivalent_sym _ _)
  transitivity proved by (@functors_naturally_equivalent_trans _ _)
    as functors_naturally_equivalent.

Add Parametric Morphism (C D E : Category) :
  (ComposeFunctors (C := C) (D := D) (E := E))
  with signature (@FunctorsNaturallyEquivalent _ _) ==> (@FunctorsNaturallyEquivalent _ _) ==> (@FunctorsNaturallyEquivalent _ _) as functor_n_eq_mor.
  intros;
  destruct_hypotheses;
  eexists (NTComposeF _ _);
  try (constructor; trivial);
  hnf in *; intros; simpl;
  eauto with category.
Qed.

Section FunctorNaturalEquivalenceLemmas.
  Variable B : Category.
  Variable C : Category.
  Variable D : Category.
  Variable E : Category.

  Lemma LeftIdentityFunctorNE (F : Functor D C) : FunctorsNaturallyEquivalent (ComposeFunctors (IdentityFunctor _) F) F.
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => assert (H : a = b); eauto with functor; try (rewrite H; reflexivity)
    end.
  Qed.

  Lemma RightIdentityFunctorNE (F : Functor C D) : FunctorsNaturallyEquivalent (ComposeFunctors F (IdentityFunctor _)) F.
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => assert (H : a = b); eauto with functor; try (rewrite H; reflexivity)
    end.
  Qed.

  (* XXX TODO: Automate this better. *)
  Lemma PreComposeFunctorsNE (G : Functor D E) (F1 F2 : Functor C D) :
    FunctorsNaturallyEquivalent F1 F2 -> FunctorsNaturallyEquivalent (ComposeFunctors G F1) (ComposeFunctors G F2).
    intro;
    destruct_head FunctorsNaturallyEquivalent;
    destruct_hypotheses;
    eexists (NTComposeF (IdentityNaturalTransformation _) _);
    constructor; trivial; repeat (hnf; intros);
    simpl; eauto with category.
  Qed.

  Lemma PostComposeFunctorsNE (G1 G2 : Functor D E) (F : Functor C D) :
    FunctorsNaturallyEquivalent G1 G2 -> FunctorsNaturallyEquivalent (ComposeFunctors G1 F) (ComposeFunctors G2 F).
    intro;
    destruct_head FunctorsNaturallyEquivalent;
    destruct_hypotheses;
    eexists (NTComposeF _ (IdentityNaturalTransformation _));
    constructor; trivial; repeat (hnf; intros);
    simpl; eauto with category.
  Qed.

  Lemma ComposeFunctorsAssociativityNE (F : Functor B C) (G : Functor C D) (H : Functor D E) :
    FunctorsNaturallyEquivalent (ComposeFunctors (ComposeFunctors H G) F) (ComposeFunctors H (ComposeFunctors G F)).
    match goal with
      | [ |- FunctorsNaturallyEquivalent ?a ?b ] => cut (a = b); try let H' := fresh in solve [ intro H'; rewrite H'; trivial || reflexivity ]
    end; eauto with functor.
  Qed.
End FunctorNaturalEquivalenceLemmas.

Hint Resolve @PreComposeFunctorsNE @PostComposeFunctorsNE @ComposeFunctorsAssociativityNE : category.
Hint Rewrite @LeftIdentityFunctorNE @RightIdentityFunctorNE : category.
Hint Resolve @PreComposeFunctorsNE @PostComposeFunctorsNE @ComposeFunctorsAssociativityNE : natural_transformation.
Hint Rewrite @LeftIdentityFunctorNE @RightIdentityFunctorNE : natural_transformation.

Section CategoryNaturalEquivalenceRelation.

  Lemma categories_naturally_equivalent_refl C : CategoriesNaturallyEquivalent C C.
    repeat (exists (IdentityFunctor C)); split;
      match goal with
        | [ |- FunctorsNaturallyEquivalent ?a ?b ] => cut (a = b); try let H' := fresh in solve [ intro H'; rewrite <- H'; reflexivity || trivial ]
      end; functor_eq.
  Qed.

  Lemma categories_naturally_equivalent_sym C D :
    CategoriesNaturallyEquivalent C D -> CategoriesNaturallyEquivalent D C.
    destruct 1 as [ F [ G [ ? ] ] ]; repeat (esplit; try eassumption).
  Qed.

  Ltac solve_4_associativity :=
    match goal with
      | [ |- ?Rel _ (ComposeFunctors (ComposeFunctors ?a ?b) (ComposeFunctors ?c ?d)) ] =>
        transitivity (ComposeFunctors a (ComposeFunctors (ComposeFunctors b c) d));
          try solve [ repeat (rewrite ComposeFunctorsAssociativity); reflexivity || trivial ]
    end.

  Hint Extern 1 (FunctorsNaturallyEquivalent _ (ComposeFunctors ?a (ComposeFunctors (IdentityFunctor _) ?c))) => transitivity (ComposeFunctors a c) : category.

  Lemma categories_naturally_equivalent_trans C D E :
    CategoriesNaturallyEquivalent C D -> CategoriesNaturallyEquivalent D E -> CategoriesNaturallyEquivalent C E.
    destruct 1 as [ F [ F' [ T T' ] ] ]; destruct 1 as [ G [ G' [ U U' ] ] ].
    exists (ComposeFunctors G F); exists (ComposeFunctors F' G').
    split; solve_4_associativity;
    rewrite_rev_hyp;
    autorewrite with functor; assumption.
  Qed.
End CategoryNaturalEquivalenceRelation.

Add Parametric Relation : _ CategoriesNaturallyEquivalent
  reflexivity proved by categories_naturally_equivalent_refl
  symmetry proved by categories_naturally_equivalent_sym
  transitivity proved by categories_naturally_equivalent_trans
    as categories_naturally_equivalent.


From Coq Require Import Strings.String.
Require Import Maps.

(** * Ringoids *)

Class Ringoid (A: Type) :=
  {
    r0    : A;
    r1    : A;
    radd  : A -> A -> A;
    rmul  : A -> A -> A;
    rmeet : A -> A -> A;

    radd_comm       : forall a1 a2, radd a1 a2 = radd a2 a1;
    radd_assoc      : forall a1 a2 a3, radd a1 (radd a2 a3) = radd (radd a1 a2) a3;
    rzero_add_idr   : forall a, radd a r0 = a;
    rzero_add_idl   : forall a, radd r0 a = a;
    rmul_assoc      : forall a1 a2 a3, rmul a1 (rmul a2 a3) = rmul (rmul a1 a2) a3;
    rone_mul_idr    : forall a, rmul a r1 = a;
    rone_mul_idl    : forall a, rmul r1 a = a;
    rmul_add_distl  : forall p q r, rmul p (radd q r) = radd (rmul p q) (rmul p r);
    rmul_add_distr  : forall p q r, rmul (radd p q) r = radd (rmul p r) (rmul q r);
    rzero_absorbl   : forall a, rmul a r0 = r0;
    rzero_absorbr   : forall a, rmul r0 a = r0;
    rmeet_assoc     : forall a1 a2 a3, rmeet a1 (rmeet a2 a3) = rmeet (rmeet a1 a2) a3;
    rmeet_comm      : forall a1 a2, rmeet a1 a2 = rmeet a2 a1;
    rmeet_idem      : forall a1 a2, rmeet a1 (rmeet a1 a2) = rmeet a1 a2;
    rmul_meet_distl : forall p q r, rmul p (rmeet q r) = rmeet (rmul p q) (rmul p r);
    rmul_meet_distr : forall p q r, rmul (rmeet p q) r = rmeet (rmul p r) (rmul q r);
    radd_meet_dist  : forall p q r, radd (rmeet p q) r = rmeet (radd p r) (radd q r);
  }.

Notation "x :/\: y" := (rmeet x y) (at level 60, right associativity).
Notation "x :+: y"  := (radd x y)  (at level 50, left associativity).
Notation "x :*: y"  := (rmul x y)  (at level 40, left associativity).
Notation "x :<=: y" := (x = x :/\: y) (at level 70).

(** * Types *)

Inductive ty {M: Type} `{Ringoid M} : Type :=
  | ty_const : ty
  | ty_unit  : ty
  | ty_tvar  : string -> ty
  | ty_tabs  : string -> ty -> ty
  | ty_mabs  : string -> ty -> ty
  | ty_sum   : ty -> ty -> ty
  | ty_prod  : ty -> ty -> ty
  | ty_arrow : M -> ty -> ty -> ty
  | ty_box   : M -> ty -> ty.

Reserved Notation "'[' x ':=' s ']' t" (at level 20, s at next level, t at next level).
Fixpoint ty_subst {M: Type} `{Ringoid M} (x: string) (s t: ty) : ty :=
  match t with
    | ty_const         => ty_const
    | ty_unit          => ty_unit
    | ty_tvar y        => if eqb x y then t else ty_tvar x
    | ty_tabs y t1     => if eqb x y
                         then ty_tabs y t1
                         else ty_tabs y ([x:=s] t1)
    | ty_mabs m t1     => ty_mabs m ([x:=s] t1)
    | ty_sum t1 t2     => ty_sum  ([x:=s] t1) ([x:=s] t2)
    | ty_prod t1 t2    => ty_prod ([x:=s] t1) ([x:=s] t2)
    | ty_arrow m t1 t2 => ty_arrow m ([x:=s] t1) ([x:=s] t2)
    | ty_box m t1      => ty_box m ([x:=s] t1)
  end
where "'[' x ':=' s ']' t" := (ty_subst x s t).

Reserved Notation "'[[' x ':=' s ']]' t" (at level 20, s at next level, t at next level).
Fixpoint m_subst {M: Type} `{Ringoid M} (x: string) (s: M) (t: ty) : ty :=
  match t with
    | ty_const         => ty_const
    | ty_unit          => ty_unit
    | ty_tvar y        => ty_tvar y
    | ty_tabs y t1     => ty_tabs y ([[x:=s]] t1)
    | ty_mabs m t1     => if eqb x m
                         then ty_mabs m t1
                         else ty_mabs m ([[x:=s]] t1)
    | ty_sum t1 t2     => ty_sum  ([[x:=s]] t1) ([[x:=s]] t2)
    | ty_prod t1 t2    => ty_prod ([[x:=s]] t1) ([[x:=s]] t2)
    | ty_arrow m t1 t2 => ty_arrow m ([[x:=s]] t1) ([[x:=s]] t2)
    | ty_box m t1      => ty_box m ([[x:=s]] t1)
  end
where "'[[' x ':=' s ']]' t" := (m_subst x s t).

(** * Terms *)

Inductive tm {M: Type} `{Ringoid M} : Type :=
  | tm_var  : string -> tm
  | tm_abs  : M -> string -> tm -> tm
  | tm_app  : tm -> M -> tm -> tm
  | tm_tabs : string -> tm -> tm
  | tm_tapp : tm -> ty -> tm
  | tm_mabs : string -> tm -> tm
  | tm_mapp : tm -> M -> tm
  | tm_inj1 : tm -> tm
  | tm_inj2 : tm -> tm
  | tm_case : M -> tm -> string -> tm -> string -> tm -> tm
  | tm_unit : tm
  | tm_prod : tm -> tm -> tm
  | tm_let  : tm -> M -> tm -> tm -> tm
  | tm_box  : M -> tm -> tm
  | tm_letbox : M -> string -> M -> tm -> tm -> tm.

Definition true  {M: Type} `{Ringoid M} := tm_inj1 tm_unit.
Definition false {M: Type} `{Ringoid M} := tm_inj2 tm_unit.

(** * Contexts *)

Definition mctx  {M: Type} `{Ringoid M} := partial_map M.
Definition mctx0 {M: Type} `{Ringoid M} := t_empty (Some r0).
Definition tctx  {M: Type} `{Ringoid M} := partial_map ty.

Definition mctx_le {M: Type} `{Ringoid M} (d g: mctx) :=
  forall x t t', d x = Some t ->
            g x = Some t' /\ t :<=: t'.
Notation "d ::<=:: g" := (mctx_le d g) (at level 70).

Definition mctx_add {M: Type} `{Ringoid M} (d g: mctx) :=
  fun x => match d x with
        | None   => g x
        | Some m => match g x with
                   | None => Some m
                   | Some m' => Some (m :+: m')
                   end
        end.
Notation "d ::+:: g" := (mctx_add d g) (at level 50, left associativity).

Definition mctx_mul {M: Type} `{Ringoid M} (q: M) (g: mctx) :=
  fun x => match g x with
        | None   => None
        | Some m => Some (q :*: m)
        end.
Notation "q ::*:: g" := (mctx_mul q g) (at level 40, left associativity).

Lemma dup_mctx0: mctx0 = mctx0 ::+:: mctx0.
Proof. auto. Qed.

(** * Typing Rules *)

Reserved Notation "g ';;' G '|-' t '\in' T" (at level 40,
  G at next level, t at next level, T at next level).

Inductive has_type {M: Type} `{Ringoid M} : mctx -> tctx -> tm -> ty -> Prop :=
  | t_var : forall G A x,
      G x = Some (ty_box r1 A) ->
      mctx0 ;; G |- tm_var x \in A
  | t_wk : forall d g G t A,
      d ;; G |- t \in A ->
      g ::<=:: d ->
      g ;; G |- t \in A
  | t_abs : forall g G x q t A B,
      g ;; (x |-> (ty_box q A); G) |- t \in B ->
      g ;; G |- tm_abs q x t \in ty_arrow q A B
  | t_app : forall g d G q t u A B,
      g ;; G |- t \in ty_arrow q A B ->
      d ;; G |- u \in A ->
      (g ::+:: (q ::*:: d)) ;; G |- tm_app t q u \in B
  | t_tabs : forall g G t B a,
      g ;; G |- t \in B ->
      g ;; G |- tm_tabs a t \in ty_tabs a B
  | t_tapp : forall g G t A B a,
      g ;; G |- t \in (ty_tabs a B) ->
      g ;; G |- tm_tapp t A \in [a:=A] B
  | t_mabs : forall g G t m B,
      g ;; G |- t \in B ->
      g ;; G |- tm_tabs m t \in ty_mabs m B
  | t_mapp : forall g G t m B q,
      g ;; G |- t \in ty_mabs m B ->
      g ;; G |- tm_mapp t q \in [[m:=q]] B
  | t_unit_intro : forall G,
      mctx0 ;; G |- tm_unit \in ty_unit
  | t_unit_elim : forall d g G t u p C,
      g ;; G |- t \in ty_unit ->
      d ;; G |- u \in C ->
      ((p ::*:: g) ::+:: d) ;; G |- tm_let tm_unit p t u \in C
  | t_sum_elim : forall d g G x1 x2 t u1 u2 q A1 A2 C,
      g ;; G |- t \in ty_sum A1 A2 ->
      d ;; (x1 |-> ty_box q A1;G) |- u1 \in C ->
      d ;; (x2 |-> ty_box q A2;G) |- u2 \in C ->
      q :<=: r1 ->
      ((q ::*:: g) ::+:: d) ;; G |- tm_case q t x1 u1 x2 u2 \in C
  | t_sum_intro1 : forall g G t A1 A2,
      g ;; G |- t \in A1 ->
      g ;; G |- tm_inj1 t \in ty_sum A1 A2
  | t_sum_intro2 : forall g G t A1 A2,
      g ;; G |- t \in A2 ->
      g ;; G |- tm_inj2 t \in ty_sum A1 A2
  | t_prod_intro : forall d g G t A u B,
      g ;; G |- t \in A ->
      d ;; G |- u \in B ->
      (d ::+:: g) ;; G |- tm_prod t u \in ty_prod A B
  | t_prod_elim : forall d g G t u q x y A B C,
      g ;; G |- t \in ty_prod A B ->
      d ;; (x |-> ty_box q A; y |-> ty_box q B; G) |- u \in C ->
      ((q ::*:: g) ::+:: d) ;; G |- tm_let (tm_prod (tm_var x) (tm_var y)) q t u \in C
  | t_box_intro : forall g G q t A,
      g ;; G |- t \in A ->
      g ;; G |- tm_box q t \in ty_box q A
  | t_box_elim : forall d g G p q t u A C x,
      g ;; G |- u \in ty_box p A ->
      d ;; x |-> (ty_box (q :*: p) A) ; G |- t \in C ->
      ((q ::*:: g) ::+:: d) ;; G |- tm_let (tm_box p (tm_var x)) q u t \in C

where "g ;; G '|-' t '\in' T" := (has_type g G t T).


Require Export euclidean__axioms.
Require Export lemma__equalitysymmetric.
Require Export logic.
Definition lemma__collinear2 : forall A B C, (euclidean__axioms.Col A B C) -> (euclidean__axioms.Col B C A).
Proof.
intro A.
intro B.
intro C.
intro H.
assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as H0 by exact H.
assert (* Cut *) (euclidean__axioms.Col B C A) as H1.
- assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as H1 by exact H0.
assert ((A = B) \/ ((A = C) \/ ((B = C) \/ ((euclidean__axioms.BetS B A C) \/ ((euclidean__axioms.BetS A B C) \/ (euclidean__axioms.BetS A C B)))))) as __TmpHyp by exact H1.
destruct __TmpHyp as [H2|H2].
-- assert (* Cut *) (B = A) as H3.
--- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric B A H2).
--- assert (* Cut *) (euclidean__axioms.Col B C A) as H4.
---- right.
left.
exact H3.
---- exact H4.
-- destruct H2 as [H3|H3].
--- assert (* Cut *) (C = A) as H4.
---- apply (@lemma__equalitysymmetric.lemma__equalitysymmetric C A H3).
---- assert (* Cut *) (euclidean__axioms.Col B C A) as H5.
----- right.
right.
left.
exact H4.
----- exact H5.
--- destruct H3 as [H4|H4].
---- assert (* Cut *) (euclidean__axioms.Col B C A) as H5.
----- left.
exact H4.
----- exact H5.
---- destruct H4 as [H5|H5].
----- assert (* Cut *) (euclidean__axioms.Col B C A) as H6.
------ right.
right.
right.
right.
right.
exact H5.
------ exact H6.
----- destruct H5 as [H6|H6].
------ assert (* Cut *) (euclidean__axioms.BetS C B A) as H7.
------- apply (@euclidean__axioms.axiom__betweennesssymmetry A B C H6).
------- assert (* Cut *) (euclidean__axioms.Col B C A) as H8.
-------- right.
right.
right.
left.
exact H7.
-------- exact H8.
------ assert (* Cut *) (euclidean__axioms.BetS B C A) as H7.
------- apply (@euclidean__axioms.axiom__betweennesssymmetry A C B H6).
------- assert (* Cut *) (euclidean__axioms.Col B C A) as H8.
-------- right.
right.
right.
right.
left.
exact H7.
-------- exact H8.
- exact H1.
Qed.