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

 The bicategory of univalent enriched categories

 We construct the bicategory of univalent enriched categories and
 we prove that this bicategory is univalent. Note that in order to
 prove the univalence, it is sufficient to assume that the
 involved monoidal category is univalent as well.

 To define this bicategory, we use displayed bicategories. The
 base bicategory is the bicategory of univalent categories. Note
 that we cannot split this displayed bicategory into smaller
 parts. That is because to define natural transformations, we
 need to use composition of enriched categories.

 Note that the construction of the bicategories of enriched
 categories as a displayed bicategory, provides some explanation
 of what the notion of enrichment means. With the usual definition
 of enriched category, one has a pseudofunctor `V-Cat -> Cat`,
 which sends every enriched category to its underlying category.
 The projection pseudofunctor of the displayed bicategory defined
 in this file, is precisely this pseudofunctor. The notion of
 enrichment given in `Enrichment.v` represents the fibers of the
 underlying category pseudofunctor.

 Contents
 1. The displayed bicategory
 2. Local univalence
 3. Global univalence

 *****************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.whiskering.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.EnrichedCats.Enrichment.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentFunctor.
Require Import UniMath.CategoryTheory.EnrichedCats.EnrichmentTransformation.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Import DispBicat.Notations.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.DisplayedBicats.DispAdjunctions.
Require Import UniMath.Bicategories.DisplayedBicats.DispUnivalence.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Projection.

Local Open Scope cat.
Local Open Scope moncat.

Opaque mon_linvunitor mon_rinvunitor.

Section EnrichedCats.
  Context (V : monoidal_cat).

  (**
   1. The displayed bicategory
   *)
  Definition disp_cat_ob_mor_of_enriched_cats
    : disp_cat_ob_mor bicat_of_univ_cats.
  Proof.
    simple refine (_ ,, _).
    - exact (λ (C : univalent_category), enrichment C V).
    - exact (λ (C₁ C₂ : univalent_category)
               (E₁ : enrichment C₁ V)
               (E₂ : enrichment C₂ V)
               (F : C₁ ⟶ C₂),
             functor_enrichment F E₁ E₂).
  Defined.

  Definition disp_cat_id_comp_of_enriched_cats
    : disp_cat_id_comp bicat_of_univ_cats disp_cat_ob_mor_of_enriched_cats.
  Proof.
    simple refine (_ ,, _).
    - exact (λ C E, functor_id_enrichment E).
    - exact (λ C₁ C₂ C₃ F G E₁ E₂ E₃ EF EG, functor_comp_enrichment EF EG).
  Defined.

  Definition disp_cat_data_of_enriched_cats
    : disp_cat_data bicat_of_univ_cats.
  Proof.
    simple refine (_ ,, _).
    - exact disp_cat_ob_mor_of_enriched_cats.
    - exact disp_cat_id_comp_of_enriched_cats.
  Defined.

  Definition disp_prebicat_1_id_comp_cells_of_enriched_cats
    : disp_prebicat_1_id_comp_cells bicat_of_univ_cats.
  Proof.
    simple refine (_ ,, _).
    - exact disp_cat_data_of_enriched_cats.
    - exact (λ C₁ C₂ F G τ E₁ E₂ EF EG, nat_trans_enrichment (pr1 τ) EF EG).
  Defined.

  Definition disp_prebicat_ops_of_enriched_cats
    : disp_prebicat_ops disp_prebicat_1_id_comp_cells_of_enriched_cats.
  Proof.
    repeat split ; cbn.
    - exact (λ C₁ C₂ F E₁ E₂ FE, id_trans_enrichment FE).
    - exact (λ C₁ C₂ F E₁ E₂ FE, lunitor_enrichment FE).
    - exact (λ C₁ C₂ F E₁ E₂ FE, runitor_enrichment FE).
    - exact (λ C₁ C₂ F E₁ E₂ FE, linvunitor_enrichment FE).
    - exact (λ C₁ C₂ F E₁ E₂ FE, rinvunitor_enrichment FE).
    - exact (λ C₁ C₂ C₃ C₄ F G H E₁ E₂ E₃ E₄ FE GE HE,
             lassociator_enrichment FE GE HE).
    - exact (λ C₁ C₂ C₃ C₄ F G H E₁ E₂ E₃ E₄ FE GE HE,
             rassociator_enrichment FE GE HE).
    - exact (λ C₁ C₂ F G H τ τ' E₁ E₂ EF EG EH Eτ Eτ', comp_trans_enrichment Eτ Eτ').
    - exact (λ C₁ C₂ C₃ F G₁ G₂ τ E₁ E₂ E₃ EF EG₁ EG₂ Eτ, pre_whisker_enrichment EF Eτ).
    - exact (λ C₁ C₂ C₃ F₁ F₂ G τ E₁ E₂ E₃ EF₁ EF₂ EG Eτ, post_whisker_enrichment Eτ EG).
  Qed.

  Definition disp_prebicat_data_of_enriched_cats
    : disp_prebicat_data bicat_of_univ_cats.
  Proof.
    simple refine (_ ,, _).
    - exact disp_prebicat_1_id_comp_cells_of_enriched_cats.
    - exact disp_prebicat_ops_of_enriched_cats.
  Defined.

  Definition disp_prebicat_laws_of_enriched_cats
    : disp_prebicat_laws disp_prebicat_data_of_enriched_cats.
  Proof.
    repeat split ; intro ; intros ; cbn ; apply isaprop_nat_trans_enrichment.
  Qed.

  Definition disp_prebicat_of_enriched_cats
    : disp_prebicat bicat_of_univ_cats.
  Proof.
    simple refine (_ ,, _).
    - exact disp_prebicat_data_of_enriched_cats.
    - exact disp_prebicat_laws_of_enriched_cats.
  Defined.

  Definition disp_bicat_of_enriched_cats
    : disp_bicat bicat_of_univ_cats.
  Proof.
    simple refine (_ ,, _).
    - exact disp_prebicat_of_enriched_cats.
    - intros C₁ C₂ F G τ E₁ E₂ EF EG.
      apply isasetaprop.
      apply isaprop_nat_trans_enrichment.
  Defined.

  Definition disp_2cell_isapprop_enriched_cats
    : disp_2cells_isaprop disp_bicat_of_enriched_cats.
  Proof.
    intros C₁ C₂ F G τ E₁ E₂ EF EG.
    apply isaprop_nat_trans_enrichment.
  Qed.

  (**
   2. Local univalence
   *)
  Definition disp_univalent_2_1_enriched_cats
    : disp_univalent_2_1 disp_bicat_of_enriched_cats.
  Proof.
    use fiberwise_local_univalent_is_univalent_2_1.
    intros C F G E₁ E₂ FE GE.
    use isweqimplimpl.
    - cbn in * ; intro τ.
      use subtypePath.
      {
        intro.
        apply isaprop_is_functor_enrichment.
      }
      use funextsec ; intro x.
      use funextsec ; intro y.
      pose (p := pr1 τ x y).
      cbn in p.
      rewrite !enriched_from_arr_id in p.
      refine (_ @ !p @ _) ; clear p.
      + rewrite <- !(functor_enrichment_id FE).
        rewrite (tensor_comp_r_id_l _ _ (FE x y)).
        rewrite !assoc'.
        rewrite <- (functor_enrichment_comp FE).
        rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
        refine (!_).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          refine (!_).
          exact (enrichment_id_left E₁ x y).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_linvunitor_lunitor.
        }
        apply id_left.
      + rewrite <- !(functor_enrichment_id GE).
        rewrite (tensor_comp_l_id_l (GE x y)).
        rewrite !assoc'.
        rewrite <- (functor_enrichment_comp GE).
        rewrite !(maponpaths (λ z, _ · z) (assoc _ _ _)).
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          refine (!_).
          exact (enrichment_id_right E₁ x y).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          apply mon_rinvunitor_runitor.
        }
        apply id_left.
    - apply isaset_functor_enrichment.
    - use isaproptotal2.
      + intro.
        apply isaprop_is_disp_invertible_2cell.
      + intros.
        apply isaprop_nat_trans_enrichment.
  Qed.

  (**
   3. Global univalence
   *)
  Section DispAdjointEquivalence.
    Context {C : bicat_of_univ_cats}
            (E₁ E₂ : disp_bicat_of_enriched_cats C).

    Definition make_disp_adjequiv_enriched
               (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
               (F₂ : functor_enrichment (functor_identity _) E₂ E₁)
               (η : nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_id_enrichment E₁)
                      (functor_comp_enrichment F₁ F₂))
               (ηinv : nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_comp_enrichment F₁ F₂)
                      (functor_id_enrichment E₁))
               (ε : nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_comp_enrichment F₂ F₁)
                      (functor_id_enrichment E₂))
               (εinv : nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_id_enrichment E₂)
                      (functor_comp_enrichment F₂ F₁))
      : disp_adjoint_equivalence
          (internal_adjoint_equivalence_identity C)
          E₁ E₂.
    Proof.
      simple refine (F₁ ,, (F₂ ,, (η ,, ε)) ,, (_ ,, _)).
      - abstract
          (split ; apply disp_2cell_isapprop_enriched_cats).
      - split.
        + refine (ηinv ,, _ ,,  _) ; apply disp_2cell_isapprop_enriched_cats.
        + refine (εinv ,, _ ,,  _) ; apply disp_2cell_isapprop_enriched_cats.
    Defined.

    Definition from_disp_adjequiv_enriched
               (F : disp_adjoint_equivalence
                      (internal_adjoint_equivalence_identity C)
                      E₁ E₂)
      : ∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
          (F₂ : functor_enrichment (functor_identity _) E₂ E₁),
        (nat_trans_enrichment
           (nat_trans_id _)
           (functor_id_enrichment E₁)
           (functor_comp_enrichment F₁ F₂))
        ×
        (nat_trans_enrichment
           (nat_trans_id _)
           (functor_comp_enrichment F₂ F₁)
           (functor_id_enrichment E₂))
        ×
        (nat_trans_enrichment
           (nat_trans_id _)
           (functor_comp_enrichment F₁ F₂)
           (functor_id_enrichment E₁))
        ×
        (nat_trans_enrichment
           (nat_trans_id _)
           (functor_id_enrichment E₂)
           (functor_comp_enrichment F₂ F₁)).
    Proof.
      simple refine (_ ,, _ ,, _ ,, _ ,, _ ,, _).
      - exact (pr1 F).
      - exact (pr112 F).
      - exact (pr1 (pr212 F)).
      - exact (pr2 (pr212 F)).
      - exact (pr11 (pr222 F)).
      - exact (pr12 (pr222 F)).
    Defined.

    Definition weq_disp_adjequiv_enriched
      : (∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
           (F₂ : functor_enrichment (functor_identity _) E₂ E₁),
         (nat_trans_enrichment
            (nat_trans_id _)
            (functor_id_enrichment E₁)
            (functor_comp_enrichment F₁ F₂))
         ×
         (nat_trans_enrichment
            (nat_trans_id _)
            (functor_comp_enrichment F₂ F₁)
            (functor_id_enrichment E₂))
         ×
         (nat_trans_enrichment
            (nat_trans_id _)
            (functor_comp_enrichment F₁ F₂)
            (functor_id_enrichment E₁))
         ×
         (nat_trans_enrichment
            (nat_trans_id _)
            (functor_id_enrichment E₂)
            (functor_comp_enrichment F₂ F₁)))
        ≃
        disp_adjoint_equivalence
          (internal_adjoint_equivalence_identity C)
          E₁ E₂.
    Proof.
      use weq_iso.
      - exact (λ F,
               make_disp_adjequiv_enriched
                 (pr1 F)
                 (pr12 F) (pr122 F)
                 (pr12 (pr222 F))
                 (pr1 (pr222 F))
                 (pr22 (pr222 F))).
      - exact from_disp_adjequiv_enriched.
      - intros F.
        apply idpath.
      - abstract
          (intro F ;
           refine (maponpaths (λ z, _ ,, z) _) ;
           refine (maponpaths (λ z, _ ,, z) _) ;
           repeat (apply isapropdirprod) ;
           try (apply isaprop_is_disp_invertible_2cell) ;
           apply disp_bicat_of_enriched_cats).
    Defined.
  End DispAdjointEquivalence.

  Section FromEnrichmentPath.
    Context {C : bicat_of_univ_cats}
            {E₁ E₂ : disp_bicat_of_enriched_cats C}
            (F : enrichment_data_hom_path_help (pr1 E₁) (pr1 E₂)).

    Definition from_enrichment_path_functor_data
      : functor_enrichment_data (functor_identity _) E₁ E₂
      := λ x y, pr1 F x y.

    Definition from_enrichment_path_functor_is_functor
      : is_functor_enrichment from_enrichment_path_functor_data.
    Proof.
      repeat split.
      - intro x.
        exact (pr12 F x).
      - intros x y z.
        exact (pr122 F x y z).
      - intros x y f.
        exact (!(pr1 (pr222 F) x y f)).
    Qed.

    Definition from_enrichment_path_functor
      : functor_enrichment (functor_identity _) E₁ E₂
      := from_enrichment_path_functor_data
         ,,
         from_enrichment_path_functor_is_functor.

    Definition from_enrichment_path_functor_inv_data
      : functor_enrichment_data (functor_identity _) E₂ E₁
      := λ x y, inv_from_z_iso (pr1 F x y).

    Definition from_enrichment_path_functor_inv_is_functor
      : is_functor_enrichment from_enrichment_path_functor_inv_data.
    Proof.
      repeat split.
      - intros x.
        cbn ; unfold from_enrichment_path_functor_inv_data.
        refine (!_).
        use z_iso_inv_on_left.
        refine (!_).
        exact (pr12 F x).
      - intros x y z.
        cbn ; unfold from_enrichment_path_functor_inv_data.
        refine (!_).
        use z_iso_inv_on_left.
        rewrite !assoc'.
        refine (!_).
        etrans.
        {
          apply maponpaths.
          exact (pr122 F x y z).
        }
        rewrite !assoc.
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply tensor_comp_mor.
        }
        rewrite !z_iso_after_z_iso_inv.
        rewrite tensor_id_id.
        apply id_left.
      - intros x y f.
        cbn ; unfold from_enrichment_path_functor_inv_data.
        use z_iso_inv_on_left.
        refine (!_).
        exact (pr1 (pr222 F) x y f).
    Qed.

    Definition from_enrichment_path_functor_inv
      : functor_enrichment (functor_identity _) E₂ E₁
      := from_enrichment_path_functor_inv_data
         ,,
         from_enrichment_path_functor_inv_is_functor.

    Definition from_enrichment_path_unit
      : nat_trans_enrichment
          (nat_trans_id (functor_identity _))
          (functor_id_enrichment E₁)
          (functor_comp_enrichment
             from_enrichment_path_functor
             from_enrichment_path_functor_inv).
    Proof.
      intros x y.
      cbn.
      unfold from_enrichment_path_functor_data.
      unfold from_enrichment_path_functor_inv_data.
      rewrite !z_iso_inv_after_z_iso.
      rewrite !enriched_from_arr_id.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_right.
      }
      etrans.
      {
        apply mon_rinvunitor_runitor.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      apply mon_linvunitor_lunitor.
    Qed.

    Definition from_enrichment_path_unit_inv
      : nat_trans_enrichment
          (nat_trans_id (functor_identity _))
          (functor_comp_enrichment
             from_enrichment_path_functor
             from_enrichment_path_functor_inv)
          (functor_id_enrichment E₁).
    Proof.
      intros x y.
      cbn.
      unfold from_enrichment_path_functor_data.
      unfold from_enrichment_path_functor_inv_data.
      rewrite !z_iso_inv_after_z_iso.
      rewrite !enriched_from_arr_id.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_right.
      }
      etrans.
      {
        apply mon_rinvunitor_runitor.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      apply mon_linvunitor_lunitor.
    Qed.

    Definition from_enrichment_path_counit
      : nat_trans_enrichment
          (nat_trans_id _)
          (functor_comp_enrichment
             from_enrichment_path_functor_inv
             from_enrichment_path_functor)
          (functor_id_enrichment E₂).
    Proof.
      intros x y.
      cbn.
      unfold from_enrichment_path_functor_data.
      unfold from_enrichment_path_functor_inv_data.
      rewrite !enriched_from_arr_id.
      rewrite !assoc'.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_right.
      }
      etrans.
      {
        apply mon_rinvunitor_runitor.
      }
      refine (!_).
      rewrite z_iso_after_z_iso_inv.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      apply mon_linvunitor_lunitor.
    Qed.

    Definition from_enrichment_path_counit_inv
      : nat_trans_enrichment
          (nat_trans_id _)
          (functor_id_enrichment E₂)
          (functor_comp_enrichment
             from_enrichment_path_functor_inv
             from_enrichment_path_functor).
    Proof.
      intros x y.
      cbn.
      unfold from_enrichment_path_functor_data.
      unfold from_enrichment_path_functor_inv_data.
      rewrite !enriched_from_arr_id.
      rewrite !assoc'.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      etrans.
      {
        apply mon_linvunitor_lunitor.
      }
      refine (!_).
      rewrite z_iso_after_z_iso_inv.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_right.
      }
      apply mon_rinvunitor_runitor.
    Qed.

    Definition from_enrichment_path
      : ∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
          (F₂ : functor_enrichment (functor_identity _) E₂ E₁),
        nat_trans_enrichment
          (nat_trans_id (functor_identity _))
          (functor_id_enrichment E₁)
          (functor_comp_enrichment F₁ F₂)
        ×
        nat_trans_enrichment
          (nat_trans_id _)
          (functor_comp_enrichment F₂ F₁)
          (functor_id_enrichment E₂)
        ×
        nat_trans_enrichment
          (nat_trans_id _)
          (functor_comp_enrichment F₁ F₂)
          (functor_id_enrichment E₁)
        ×
        nat_trans_enrichment
          (nat_trans_id _)
          (functor_id_enrichment E₂)
          (functor_comp_enrichment F₂ F₁)
      := from_enrichment_path_functor
         ,,
         from_enrichment_path_functor_inv
         ,,
         from_enrichment_path_unit
         ,,
         from_enrichment_path_counit
         ,,
         from_enrichment_path_unit_inv
         ,,
         from_enrichment_path_counit_inv.
  End FromEnrichmentPath.

  Section ToEnrichmentPath.
    Context {C : bicat_of_univ_cats}
            {E₁ E₂ : disp_bicat_of_enriched_cats C}
            (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
            (F₂ : functor_enrichment (functor_identity _) E₂ E₁)
            (η : nat_trans_enrichment
                   (nat_trans_id (functor_identity _))
                   (functor_id_enrichment E₁)
                   (functor_comp_enrichment F₁ F₂))
            (ε : nat_trans_enrichment
                   (nat_trans_id _)
                   (functor_comp_enrichment F₂ F₁)
                   (functor_id_enrichment E₂)).

    Definition to_enrichment_path_inv_left
               (x y : (C : univalent_category))
      : pr1 F₁ x y · pr1 F₂ x y = identity _.
    Proof.
      pose (p := η x y).
      cbn in p.
      rewrite !enriched_from_arr_id in p.
      rewrite !assoc' in p.
      assert (mon_rinvunitor _
              · ((F₁ x y · F₂ x y) #⊗ enriched_id _ x
              · enriched_comp _ x x y)
              =
              identity _)
        as p'.
      {
        refine (p @ _).
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply enrichment_id_left.
        }
        apply mon_linvunitor_lunitor.
      }
      refine (_ @ p').
      rewrite tensor_comp_r_id_l.
      rewrite !assoc.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_rinvunitor.
      }
      rewrite !assoc' ; cbn.
      apply maponpaths.
      rewrite tensor_split'.
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_rinvunitor.
      }
      rewrite !assoc'.
      refine (_ @ id_right _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_right.
      }
      apply mon_rinvunitor_runitor.
    Qed.

    Definition to_enrichment_path_inv_right
               (x y : (C : univalent_category))
      : pr1 F₂ x y · pr1 F₁ x y = identity _.
    Proof.
      pose (p := ε x y).
      cbn in p.
      rewrite !enriched_from_arr_id in p.
      rewrite !assoc' in p.
      assert (mon_linvunitor _
              · (enriched_id _ y #⊗ (F₂ x y · F₁ x y)
              · enriched_comp _ x y y)
              =
              identity _)
        as p'.
      {
        refine (!p @ _).
        etrans.
        {
          apply maponpaths.
          refine (!_).
          apply enrichment_id_right.
        }
        apply mon_rinvunitor_runitor.
      }
      refine (_ @ p').
      rewrite tensor_comp_l_id_l.
      rewrite !assoc.
      refine (!_).
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_linvunitor.
      }
      rewrite !assoc' ; cbn.
      apply maponpaths.
      rewrite tensor_split.
      rewrite !assoc.
      etrans.
      {
        do 2 apply maponpaths_2.
        refine (!_).
        apply tensor_linvunitor.
      }
      rewrite !assoc'.
      refine (_ @ id_right _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        refine (!_).
        apply enrichment_id_left.
      }
      apply mon_linvunitor_lunitor.
    Qed.

    Definition to_enrichment_path
      : enrichment_data_hom_path_help (pr1 E₁) (pr1 E₂).
    Proof.
      simple refine (_ ,, _ ,, _ ,, _ ,, _).
      - refine (λ x y, _).
        use make_z_iso.
        + exact (pr1 F₁ x y).
        + exact (pr1 F₂ x y).
        + split.
          * exact (to_enrichment_path_inv_left x y).
          * exact (to_enrichment_path_inv_right x y).
      - abstract
          (intros x ; cbn ;
           exact (pr12 F₁ x)).
      - abstract
          (intros x y z ; cbn ;
           exact (pr122 F₁ x y z)).
      - abstract
          (intros x y f ; cbn ;
           exact (!(pr222 F₁ x y f))).
      - abstract
          (intros x y f ; cbn ;
           use (invmaponpathsweq (make_weq _ (isweq_enriched_from_arr E₂ x y))) ;
           cbn ;
           rewrite !(enriched_from_to_arr E₂) ;
           refine (pr222 F₁ x y (enriched_to_arr (pr1 E₁) f) @ _) ;
           apply maponpaths_2 ;
           rewrite !(enriched_from_to_arr E₁) ;
           apply idpath).
    Defined.
  End ToEnrichmentPath.

  Definition disp_univalent_2_0_enriched_cats_help_path
             {C : bicat_of_univ_cats}
             {E₁ E₂ : disp_bicat_of_enriched_cats C}
             (F G : ∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
                      (F₂ : functor_enrichment (functor_identity _) E₂ E₁),
                    nat_trans_enrichment
                      (nat_trans_id (functor_identity _))
                      (functor_id_enrichment E₁)
                      (functor_comp_enrichment F₁ F₂)
                    ×
                    nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_comp_enrichment F₂ F₁)
                      (functor_id_enrichment E₂)
                    ×
                    nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_comp_enrichment F₁ F₂)
                      (functor_id_enrichment E₁)
                    ×
                    nat_trans_enrichment
                      (nat_trans_id _)
                      (functor_id_enrichment E₂)
                      (functor_comp_enrichment F₂ F₁))
             (p : pr11 F = pr11 G)
             (q : pr112 F = pr112 G)
    : F = G.
  Proof.
    induction F as [ F₁ F₂ ].
    induction F₁ as [ F₁ HF₁ ].
    induction F₂ as [ F₂ R ].
    induction F₂ as [ F₂ HF₂ ].
    induction G as [ G₁ G₂ ].
    induction G₁ as [ G₁ HG₁ ].
    induction G₂ as [ G₂ Q ].
    induction G₂ as [ G₂ HG₂ ].
    cbn in *.
    induction p.
    induction q.
    assert (p : HF₁ = HG₁).
    {
      apply isaprop_is_functor_enrichment.
    }
    induction p.
    apply maponpaths.
    assert (p : HF₂ = HG₂).
    {
      apply isaprop_is_functor_enrichment.
    }
    induction p.
    apply maponpaths.
    repeat (apply isapropdirprod) ; apply isaprop_nat_trans_enrichment.
  Qed.

  Definition disp_univalent_2_0_enriched_cats_help
             {C : bicat_of_univ_cats}
             (E₁ E₂ : disp_bicat_of_enriched_cats C)
    : enrichment_data_hom_path_help (pr1 E₁) (pr1 E₂)
      ≃
      (∑ (F₁ : functor_enrichment (functor_identity _) E₁ E₂)
         (F₂ : functor_enrichment (functor_identity _) E₂ E₁),
       nat_trans_enrichment
         (nat_trans_id (functor_identity _))
         (functor_id_enrichment E₁)
         (functor_comp_enrichment F₁ F₂)
       ×
       nat_trans_enrichment
         (nat_trans_id _)
         (functor_comp_enrichment F₂ F₁)
         (functor_id_enrichment E₂)
       ×
       nat_trans_enrichment
         (nat_trans_id _)
         (functor_comp_enrichment F₁ F₂)
         (functor_id_enrichment E₁)
       ×
       nat_trans_enrichment
         (nat_trans_id _)
         (functor_id_enrichment E₂)
         (functor_comp_enrichment F₂ F₁)).
  Proof.
    use weq_iso.
    - exact from_enrichment_path.
    - exact (λ F, to_enrichment_path (pr1 F) (pr12 F) (pr122 F) (pr1 (pr222 F))).
    - abstract
        (intros F ;
         use subtypePath ;
         [ intro ;
           repeat (apply isapropdirprod) ;
           repeat (use impred ; intro) ;
           apply homset_property
         | ] ;
         use funextsec ; intro x ;
         use funextsec ; intro y ;
         use z_iso_eq ;
         apply idpath).
    - abstract
        (intros F ;
         use disp_univalent_2_0_enriched_cats_help_path ;
         apply idpath).
  Defined.

  Definition disp_univalent_2_0_enriched_cats
             (HV : is_univalent V)
    : disp_univalent_2_0 disp_bicat_of_enriched_cats.
  Proof.
    use fiberwise_univalent_2_0_to_disp_univalent_2_0.
    intros C₁ E₁ E₂.
    use weqhomot.
    - exact (weq_disp_adjequiv_enriched _ _
             ∘ disp_univalent_2_0_enriched_cats_help E₁ E₂
             ∘ enrichment_data_hom_path HV _ _
             ∘ total2_paths_equiv _ _ _
             ∘ path_sigma_hprop _ _ _ (isaprop_enrichment_laws _))%weq.
    - abstract
        (intro p ;
         cbn in p ;
         induction p ;
         use subtypePath ;
         [ intro ;
           apply isaprop_disp_left_adjoint_equivalence ;
           [ apply univalent_cat_is_univalent_2_1 | ] ;
           exact disp_univalent_2_1_enriched_cats
         | ] ;
         use subtypePath ;
         [ intro ; apply isaprop_is_functor_enrichment | ] ;
         apply idpath).
  Defined.

  Definition bicat_of_enriched_cats
    : bicat
    := total_bicat disp_bicat_of_enriched_cats.

  Definition is_univalent_2_1_bicat_of_enriched_cats
    : is_univalent_2_1 bicat_of_enriched_cats.
  Proof.
    use total_is_univalent_2_1.
    - exact univalent_cat_is_univalent_2_1.
    - exact disp_univalent_2_1_enriched_cats.
  Defined.

  Definition is_univalent_2_0_bicat_of_enriched_cats
             (HV : is_univalent V)
    : is_univalent_2_0 bicat_of_enriched_cats.
  Proof.
    use total_is_univalent_2_0.
    - exact univalent_cat_is_univalent_2_0.
    - use disp_univalent_2_0_enriched_cats.
      exact HV.
  Defined.

  Definition is_univalent_2_bicat_of_enriched_cats
             (HV : is_univalent V)
    : is_univalent_2 bicat_of_enriched_cats.
  Proof.
    split.
    - exact (is_univalent_2_0_bicat_of_enriched_cats HV).
    - exact is_univalent_2_1_bicat_of_enriched_cats.
  Defined.

  Definition underlying_cat
    : psfunctor bicat_of_enriched_cats bicat_of_univ_cats
    := pr1_psfunctor _.

  Definition eq_2cell_enriched
             {E₁ E₂ : bicat_of_enriched_cats}
             {F G : E₁ --> E₂}
             {τ₁ τ₂ : F ==> G}
             (p : ∏ x, pr11 τ₁ x = pr11 τ₂ x)
    : τ₁ = τ₂.
  Proof.
    use subtypePath.
    {
      intro.
      apply isaprop_nat_trans_enrichment.
    }
    use nat_trans_eq.
    {
      apply homset_property.
    }
    exact p.
  Qed.

  Definition from_is_invertible_2cell_enriched
             {E₁ E₂ : bicat_of_enriched_cats}
             {F G : E₁ --> E₂}
             (τ : invertible_2cell F G)
    : nat_z_iso (pr1 F) (pr1 G).
  Proof.
    use invertible_2cell_to_nat_z_iso.
    exact (_ ,, psfunctor_is_iso underlying_cat τ).
  Defined.

  Definition make_is_invertible_2cell_enriched
             (HV : faithful_moncat V)
             {E₁ E₂ : bicat_of_enriched_cats}
             {F G : E₁ --> E₂}
             (τ : F ==> G)
             (Hτ : is_nat_z_iso (pr11 τ))
    : is_invertible_2cell τ.
  Proof.
    use make_is_invertible_2cell.
    - simple refine (_ ,, _).
      + exact (pr1 (nat_z_iso_inv (make_nat_z_iso _ _ _ Hτ))).
      + apply (faithful_moncat_nat_trans_enrichment
                 HV
                 (pr1 (nat_z_iso_inv (make_nat_z_iso _ _ _ Hτ)))).
    - abstract
        (use eq_2cell_enriched ;
         intro x ;
         apply (z_iso_inv_after_z_iso (_ ,, Hτ x))).
    - abstract
        (use eq_2cell_enriched ;
         intro x ;
         apply (z_iso_after_z_iso_inv (_ ,, Hτ x))).
  Defined.
End EnrichedCats.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


(* Based on "An intuitionistic theory of types" by Per Martin-Loef, 1972 *)

(*
Some intuition for noChains:

~exists f, forall n, f (S n) < f n
~exists f, forall n, ~(f (S n) >= f n)
~exists f, ~exists n, f (S n) >= f n
forall f, exists n, f n =< f (S n)

one cannot arrange the elements in A, from left to right,
in such a way that they get monotonocally smaller as one
goes the to right.
*)

Class ordering := {
  A : Type;
  lt : A -> A -> Type;
  transitive x y z : lt x y -> lt y z -> lt x z;
  noChains (f:nat -> A) : (forall n, lt (f (S n)) (f n)) -> False
}.

Notation "x < y" := (lt x y).

Lemma irreflexive `{ordering} a : a < a -> False.
  intro h.
  apply (noChains (fun _ => a) (fun _ => h)).
Qed.

Class orderingLe (o:ordering) (o':ordering) : Type := {
  map : @A o -> @A o';
  max : @A o';
  mapOk x y : x < y -> map x < map y;
  maxOk x : map x < max
}.

Notation "x << y" := (orderingLe x y) (at level 45).

Lemma orderingLeTransitive o o' o'' : o << o' -> o' << o'' -> o << o''.
  intros h h'.
  refine {| map := fun x => map (map x) ; max := max |}.
  - intros x y h''.
    apply mapOk.
    apply mapOk.
    apply h''.
  - intro x.
    apply maxOk.
Qed.

Lemma orderingLeNoChains f : (forall n, f (S n) << f n) -> False.
  intro h.
  refine (
    let fix rec n' := match n' as n'' return @A (f n'') -> @A (f 0) with
    | 0 => fun a => a
    | S n'' => fun a => rec n'' (map a)
    end in _).
  refine (@noChains (f 0) (fun n => rec n (@max _ _ (h n))) _).
  cbn.
  intro n.
  enough (forall x y, x < y -> rec n x < rec n y) as h'. {
    apply h'.
    apply maxOk.
  }
  intros x y.
  induction n; cbn in *.
  - exact (fun a => a).
  - intro h'.
    apply IHn.
    apply mapOk.
    apply h'.
Qed.

(* this is where we get the universe inconsistency
   and have to run Coq with flag -type-in-type *)
Instance orderingOfOrderings : ordering.
  refine {| A := ordering; lt := orderingLe |}.
  - apply orderingLeTransitive.
  - apply orderingLeNoChains.
Defined.

Instance subOrdering (o:ordering) (a:@A o): ordering.
  refine {|
    A := {x:@A o & x < a};
    lt := fun x y => projT1 x < projT1 y
  |}.
  - intros [x ?] [y ?] [z ?].
    cbn.
    apply transitive.
  - intros f h.
    apply (noChains (fun n => projT1 (f n))).
    intro n.
    specialize (h n).
    apply h.
Defined.

Lemma orderingOfOrderingsMax o : o < orderingOfOrderings.
  cbn.
  refine {|
    map := fun a => subOrdering o a;
    max := o
  |}.
  - intros a b h.
    cbn.
    refine {|
      map := fun x => _;
      max := _
    |}.
    + cbn in *.
      refine (existT _ (projT1 x) _).
      specialize (projT2 x); intro h'.
      revert h.
      revert h'.
      apply transitive.
    + refine (existT _ a h).
    + cbn in *.
      intros [x ?] [y ?].
      cbn.
      exact (fun a => a).
    + cbn in *.
      intros [x h'].
      cbn.
      apply h'.
  - intro a.
    cbn.
    refine {|
      map := _;
      max := a
    |}.
    + exact (fun x => projT1 x).
    + intros [x ?] [y ?].
      cbn.
      exact (fun a => a).
    + intros [x h].
      cbn.
      apply h.
Qed.

Lemma orderingOfOrderingsReflexive : orderingOfOrderings < orderingOfOrderings.
  apply orderingOfOrderingsMax.
Qed.

Theorem false : False.
  apply (@irreflexive orderingOfOrderings orderingOfOrderings).
  apply orderingOfOrderingsReflexive.
Qed.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                   Solange Coupet-Grimal & Line Jakubiec                  *)
(*                                                                          *)
(*                                                                          *)
(*              Laboratoire d'Informatique de Marseille                     *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lim.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              May 30th 1996                               *)
(*                                                                          *)
(****************************************************************************)
(*                               Comp_Prog.v                                *)
(****************************************************************************)

Require Export Factorization_Prog.
Require Export Comparator_Relation.

Parameter BASE : BT.
Definition b := base BASE.
Definition Num := num BASE.
Definition Val_bound := val_bound BASE.
Definition Digit := digit BASE.
Definition Tl := tl Digit.

Theorem Specif_Comp :
 forall (n : nat) (o : order) (X Y : Num n),
 {o' : order | R (exp b n) o (Val_bound n X) (Val_bound n Y) o'}.
intros n o X Y.
unfold R in |- *; unfold b in |- *; unfold Val_bound in |- *.
apply factorization_for_realizer.
exact is_factorizable.
exact (is_proper BASE).
Qed.

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


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

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

Print Assumptions freeze.


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun.
Require Import AutosubstSsr ARS Context.
Require Import Program.Equality.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import ast.
Require Import smallstep.
Require Import confluence.
Require Import typing.

(* preservation *)

Theorem subject_reduction Gamma s A :
[ Gamma |- ] -> [ Gamma |- s :- A ] ->
forall t, pstep s t -> [ Gamma |- t :- A ].
Proof with eauto using has_type, context_ok.
move=> wf tp. elim: tp wf => {Gamma s A}.
- move=> Gamma x si wf t st. inv st...
- move=> Gamma wf t st. inv st...
- move=> Gamma A B tp1 ih1 tp2 ih2 wf t st. inv st.
apply: ty_pi. exact: ih1. eapply ty_ctx_conv1.
+ apply: ih2...
+ exact: conv1i.
+ exact: tp1.
- move=> Gamma A B s tp1 ih1 tp2 ih2 wf2 t st. inv st.
apply: ty_fun.
+ exact: tp1.
+ eapply ih2 => //.
  econstructor.
  replace (TT) with (TT.[ren (+1)]) by autosubst.
  exact: weakening.
  move: tp1 => /ty_pi_inv[tp _].
  econstructor => //.
- move=> Gamma A B s t tp1 ih1 tp2 ih2 wf t' st. inv st.
+ move: H2 => /pstep_fun.
  move: (wf) => /ih1 h => {tp1 ih1} /h tp1.
  move: (tp1) => /ty_fun_inv.
  move: (wf) (H4) => /ih2 h => {tp2 ih2} /h tp2 tp3.
  move: (tp1) => /weakening h1.
  move: tp3 => /ty_cut h2.
  move: (h2 _ (h1 A)) => {h1 h2} => h.
  move: h => /ty_cut h.
  move: (h _ tp2) => {h}. asimpl.
  apply: ty_conv.
  apply: conv_beta.
  exact: conv1i.
+ pose proof (conv1i H3).
  have: (B.[t2/] === B.[t/]) by apply conv_beta.
  move=> h.
  apply: ty_conv.
  apply: h.
  apply: ty_app.
  apply: ih1 => //.
  apply: ih2 => //.
- move=> Gamma A s tp ih wf t st. inv st.
+ apply ih => //.
+ apply: ty_conv.
  exact: (conv1i H3).
  apply: ty_cast.
  apply: ty_conv.
  exact: (conv_sym (conv1i H3)).
  apply ih => //.
- move=> Gamma A B s eq tp ih wf t st.
apply (ty_conv eq).
apply: ih => //.
Qed.

(* TODO likwise for small steps *)


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

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

Print Assumptions freeze.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas64_2e369m25_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas64_2e196m15_4limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas64_2e130m5_3limbs.Synthesis.

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

Print Assumptions add.


Require Import Basics Types.Bool Types.Paths Diagram Colimit.

Context `{Funext}.

Section MappingTelescope.

  Definition mappingtelescope_graph : graph.
    simple refine (Build_graph _ _).
    - exact nat.
    - intros n m; exact (S n = m).
  Defined.

  Definition equiv_mappingtelescope_diag (D1 D2: diagram mappingtelescope_graph)
             (H0: (D1 0) <~> (D2 0))
             (Hn: forall n (e: (D1 n) <~> (D2 n)),
                   {e' : (D1 n.+1) <~> (D2 n.+1) & (D2 _f idpath) o e == e' o (D1 _f idpath)})
  : D1 ≃ D2.
    simple refine (Build_diagram_equiv (Build_diagram_map _ _) _).
    - intros n. apply equiv_fun. induction n. apply H0. exact (Hn n IHn).1.
    - intros n m q; destruct q. induction n; simpl. exact (Hn 0 H0).2.
      simple refine (Hn n.+1 _).2.
    - intros n; simpl. induction n; simpl. apply H0. apply (Hn n _ ).1.
  Defined.

End MappingTelescope.


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

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas64_2e198m17_5limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas64_2e336m17_7limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas32_2e158m15_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight 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.solinas64_2e150m3_3limbs.Synthesis.

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

Print Assumptions add.


Require Import List Bool.
Require Import Reflection.

Set Implicit Arguments.
Set Strict Implicit.

Section fold_left2_opt.
  Variable T U V : Type.
  Variable F : T -> V -> U -> option U.

  Fixpoint fold_left_2_opt (ls : list T) (ls' : list V) (acc : U) : option U :=
    match ls, ls' with
      | nil , nil => Some acc
      | x :: xs , y :: ys =>
        match F x y acc with
          | None => None
          | Some acc => fold_left_2_opt xs ys acc
        end
      | _ , _ => None
    end.
End fold_left2_opt.

Section fold_left3_opt.
  Variable T U V A : Type.
  Variable F : T -> U -> V -> A -> option A.

  Fixpoint fold_left_3_opt (ls : list T) (ls' : list U) (ls'' : list V)
    (acc : A) : option A :=
    match ls, ls', ls'' with
      | nil , nil , nil => Some acc
      | x :: xs , y :: ys , z :: zs =>
        match F x y z acc with
          | None => None
          | Some acc => fold_left_3_opt xs ys zs acc
        end
      | _ , _ , _ => None
    end.
End fold_left3_opt.

Section All2.
  Variable X Y : Type.
  Variable F : X -> Y -> bool.

  Fixpoint all2 (xs : list X) (ys : list Y) : bool :=
    match xs , ys with
      | nil , nil => true
      | x :: xs, y :: ys => if F x y then all2 xs ys else false
      | _ , _ => false
    end.

  Variable P : X -> Y -> Prop.
  Inductive Forall2 : list X -> list Y -> Prop :=
  | Forall2_nil : Forall2 nil nil
  | Forall2_cons : forall l ls r rs,
    P l r ->
    Forall2 ls rs -> Forall2 (l :: ls) (r :: rs).

  Hypothesis F_P : forall x y, F x y = true -> P x y.

  Theorem all2_Forall2 : forall a b,
    all2 a b = true -> Forall2 a b.
  Proof.
    induction a; destruct b; simpl; intros; try congruence; try solve [ econstructor ].
      specialize (@F_P a y). destruct (F a y); eauto; try congruence; econstructor; eauto.
  Qed.

  Hypothesis P_F : forall x y, P x y -> F x y = true.

  Theorem Forall2_all2 : forall a b,
    Forall2 a b -> all2 a b = true.
  Proof.
    induction 1; simpl; auto.
    rewrite P_F; auto.
  Qed.
End All2.

Lemma Forall_app : forall A (P : A -> Prop) ls1 ls2,
  Forall P ls1
  -> Forall P ls2
  -> Forall P (ls1 ++ ls2).
Proof.
  induction 1; simpl; auto.
Qed.

Lemma all2_map_2 : forall T U V (P : T -> U -> bool) (F : V -> _) l1 l2,
  all2 P l1 (map F l2) = all2 (fun x y => P x (F y)) l1 l2.
Proof.
  clear. induction l1; destruct l2; simpl; auto.
  destruct (P a (F v)); auto.
Qed.
Lemma all2_map_1 : forall T U V (P : T -> U -> bool) (F : V -> _) l1 l2,
  all2 P (map F l1) l2 = all2 (fun x y => P (F x) y) l1 l2.
Proof.
  clear. induction l1; destruct l2; simpl; auto.
  destruct (P (F a) u); auto.
Qed.

Lemma all2_impl : forall T U (P P' : T -> U -> bool) l1 l2,
  all2 P' l1 l2 = true ->
  (forall x y, P' x y = true -> P x y = true) ->
  all2 P l1 l2 = true .
Proof.
  clear; induction l1; destruct l2; simpl; intros; auto.
  consider (P' a u); intros. rewrite H0; eauto.
Qed.

Section allb.
  Variable A : Type.
  Variable P : A -> bool.

  Fixpoint allb (ls : list A) : bool :=
    match ls with
      | nil => true
      | x :: ls' => if P x then allb ls' else false
    end.
End allb.

Lemma allb_app : forall T (P : T -> _) a b,
  allb P (a ++ b) = allb P a && allb P b.
Proof.
  induction a; simpl; intros; auto. destruct (P a); auto.
Qed.

Lemma all2_eq : forall (T U : Type) (P P' : T -> U -> bool)
  (l1 : list T) (l2 : list U),
  (forall (x : T) (y : U), P' x y = P x y) ->
  all2 P' l1 l2 = all2 P l1 l2.
Proof.
  clear. induction l1; destruct l2; simpl; intros; auto.
  rewrite H. rewrite IHl1. auto. auto.
Qed.

Lemma allb_ext : forall T (P P' : T -> _) ls,
  (forall x, P x = P' x) ->
  allb P ls = allb P' ls.
Proof.
  clear; induction ls; simpl; intros; auto.
  rewrite H. rewrite IHls; auto.
Qed.

Lemma allb_map : forall T U (F : T -> U) P ls,
  allb P (map F ls) = allb (fun x => P (F x)) ls.
Proof.
  clear. induction ls; simpl; intros; auto.
  rewrite IHls; auto.
Qed.

Lemma allb_impl : forall T (P P' : T -> _) ls,
  allb P' ls = true ->
  (forall x, P' x = true -> P x = true) ->
  allb P ls = true.
Proof.
  induction ls; simpl; intros; auto. consider (P' a); auto; intros;
  rewrite H0; auto.
Qed.


From Coq Require Import Arith Psatz Bool String List Nat Program.Equality.

Local Open Scope string_scope.
Local Open Scope nat_scope.
Local Open Scope list_scope.

Require Import DanTrick.StackLanguage DanTrick.StackLangEval DanTrick.LogicProp DanTrick.StackPure DanTrick.StackLangTheorems DanTrick.StackSemanticsMutInd.
Require Import DanTrick.StackFrame1.

Lemma max_helper :
  forall (x x0 frame' frame frame'': nat),
    max x (max x0 (max ((x + frame') - frame) ((x0 + frame'') - frame'))) +
      ((x + (frame' - frame))) - x =
      max x (max x0 (max ((x + frame') - frame) ((x0 + frame'') - frame'))) +
        (frame' - frame).
Proof.
  induction x, x0, frame', frame; intros; simpl; repeat rewrite Nat.sub_0_r; repeat rewrite Nat.add_0_r; try reflexivity.
  - rewrite Nat.add_comm. rewrite minus_plus. reflexivity.
  - rewrite Nat.add_comm. rewrite minus_plus. reflexivity.
  - rewrite <- Nat.add_sub_assoc; [ | lia ].
    rewrite <- Nat.add_succ_l. rewrite minus_plus. reflexivity.
  - rewrite <- Nat.add_sub_assoc; [ | lia ]. rewrite <- Nat.add_succ_l.
    rewrite minus_plus. reflexivity.
  - rewrite <- Nat.add_sub_assoc; [ | lia ]. assert (S x - x = S 0) by lia. rewrite H. rewrite Nat.add_1_r. reflexivity.
  - rewrite Nat.add_sub. reflexivity.
  - rewrite <- Nat.add_sub_assoc; [ | lia ]. rewrite <- Nat.add_succ_l. rewrite minus_plus. reflexivity.
  - rewrite <- Nat.add_sub_assoc; [ | lia ]. rewrite <- Nat.add_succ_l. rewrite minus_plus. reflexivity.
Qed.

Lemma max3_3 :
  forall (x x0 frame' frame: nat),
    frame' >= frame ->
    max x (max x0 (max x x0 + frame' - frame)) = max x x0 + frame' - frame.
Proof.
  lia.
Qed.

Lemma max3 :
  forall (x x0 frame' frame: nat),
    frame' <= frame ->
    max x (max x0 (max x x0 + frame' - frame)) = max x x0.
Proof.
  lia.
Qed.

Lemma destruct_max3 :
  forall (n1 n2 n3: nat),
    max n1 (max n2 n3) = n1 \/ max n1 (max n2 n3) = n2 \/ max n1 (max n2 n3) = n3.
Proof.
  lia.
Qed.

Lemma destruct_max2 :
  forall (n1 n2: nat),
    max n1 n2 = n1 \/ max n1 n2 = n2.
Proof.
  lia.
Qed.

Lemma add_add_sub :
  forall n1 n2 n3,
    n1 + (n3 + n2) - n3 = n1 + n2.
Proof.
  destruct n1; intros.
  - simpl. rewrite minus_plus. reflexivity.
  - simpl. destruct n3.
    + simpl. reflexivity.
    + rewrite Nat.add_assoc. rewrite Nat.add_comm. rewrite Nat.add_assoc.
      rewrite <- (Nat.add_1_l n3).
      rewrite Nat.add_assoc. rewrite Nat.add_sub. rewrite Nat.add_1_r.
      rewrite Nat.add_comm. reflexivity.
Qed.

Lemma add_add_sub' :
  forall n1 n2 n3,
    n1 + (n2 + n3) - n1 = n2 + n3.
Proof.
  induction n1; intros.
  - simpl. rewrite Nat.sub_0_r. reflexivity.
  - simpl. eapply IHn1.
Qed.

Lemma max_silly :
  forall (n1 n2 n3: nat),
    (max n1 (max n2 (max n1 n2 + n3))) = max n1 n2 + n3.
Proof.
  intros. lia.
Qed.

Lemma destruct_max_min :
  forall (n1 n2 n3: nat),
    max n1 (min n2 n3) = n1 \/ max n1 (min n2 n3) = n2 \/ max n1 (min n2 n3) = n3.
Proof.
  lia.
Qed.

Lemma max_min1 :
  forall (n1 n2 n3: nat),
    max n1 (min n2 n3) = n1 ->
    min n2 n3 <= n1 /\ ((n2 <= n3 /\ n2 <= n1) \/ (n2 >= n3 /\ n3 <= n1)).
Proof.
  intros. split.
  - lia.
  - assert (min n2 n3 <= n1) by lia.
    pose proof (le_ge_dec n2 n3).
    destruct H1.
    + left. lia.
    + right. lia.
Qed.


Require Export List.
Require Export Bool.
Require Export Arith.
Require Export Peano_dec.
Require Export Coq.Arith.PeanoNat.
Require Export Coq.Program.Wf.
Require Export Coq.Program.Tactics.
Require Export Coq.Logic.FunctionalExtensionality.
Require Export Recdef.

Require Import common.CpdtTactics.
Require Import common.wyv_common.
Require Import common.rhs_mat_tree.

Import WfExtensionality.

Lemma subtype_sel_equ_sel_low_reduce :
  forall T1 x1 L1 T1', T1 = (t_sel_equ x1 L1 T1') ->
                  forall T2 x2 L2 T2', T2 = (t_sel_low x2 L2 T2') ->
                                  subtype T1 T2 = orb (andb (eq_var x1 x2)
                                                            (eq_label L1 L2))
                                                      (orb (subtype T1' T2)
                                                           (subtype T1 T2')).
Proof.
  intros.

  remember (subtype T1 T2) as sub_fn; subst T1 T2.

  unfold subtype, subtype_func in Heqsub_fn;
    simpl in Heqsub_fn;
    rewrite fix_sub_eq_ext in Heqsub_fn;
    simpl in Heqsub_fn;
    fold subtype_func in Heqsub_fn;
    auto.
Qed.


(**************************************************************)
(**************************************************************)
(****                                                      ****)
(****   An admissibility graph which implements a module   ****)
(****                                                      ****)
(**************************************************************)
(**************************************************************)

Require Import Coq.Relations.Operators_Properties.
Require Import Coq.Relations.Relation_Operators.
Require Import Main.AdmissibilityGraph.AdmissibilityGraph.
Require Import Main.AdmissibilityGraph.AdmissibilityGraphTheorems.
Require Import Main.Tactics.

Module SingleModule <: AdmissibilityGraph.
  #[local] Arguments clos_trans {A} _ _ _.
  #[local] Arguments clos_trans_1n {A} _ _ _.
  #[local] Arguments clos_trans_n1 {A} _ _ _.
  #[local] Hint Constructors clos_trans : main.
  #[local] Hint Constructors clos_trans_1n : main.
  #[local] Hint Constructors clos_trans_n1 : main.
  #[local] Hint Resolve clos_t1n_trans : main.
  #[local] Hint Resolve clos_trans_t1n : main.
  #[local] Hint Resolve clos_tn1_trans : main.
  #[local] Hint Resolve clos_trans_tn1 : main.

  Inductive nodeLabels := Ingress | Egress | A | B | C.

  #[export] Hint Constructors nodeLabels : main.

  Definition node : Type := nodeLabels.

  #[export] Hint Unfold node : main.

  Definition dependency (n1 n2 : node) :=
    match n1, n2 with
    | Ingress, Ingress => True
    | Ingress, Egress => True
    | Ingress, A => True
    | Ingress, B => True
    | Ingress, C => True
    | Egress, Ingress => False
    | Egress, Egress => True
    | Egress, A => True
    | Egress, B => True
    | Egress, C => True
    | A, Ingress => True
    | A, Egress => True
    | A, A => True
    | A, B => True
    | A, C => True
    | B, Ingress => True
    | B, Egress => True
    | B, A => True
    | B, B => True
    | B, C => True
    | C, Ingress => True
    | C, Egress => True
    | C, A => True
    | C, B => True
    | C, C => True
    end.

  #[export] Hint Unfold dependency : main.

  Definition parent (n1 : node) (n2 : node) :=
    match n1, n2 with
    | Ingress, Ingress => True
    | Egress , Ingress => False
    | A, Ingress => False
    | B, Ingress => False
    | C, Ingress => False
    | Ingress, Egress => False
    | Egress , Egress => True
    | A, Egress => True
    | B, Egress => True
    | C, Egress => True
    | Ingress, A => True
    | Egress , A => False
    | A, A => True
    | B, A => False
    | C, A => False
    | Ingress, B => True
    | Egress , B => False
    | A, B => False
    | B, B => True
    | C, B => False
    | Ingress, C => True
    | Egress , C => False
    | A, C => False
    | B, C => False
    | C, C => True
    end.

  #[export] Hint Unfold parent : main.

  (* Coq requires that we copy this verbatim from `AdmissibilityGraph`. *)
  Definition ancestor := clos_trans parent.

  #[export] Hint Unfold ancestor : main.

  (* Coq requires that we copy this verbatim from `AdmissibilityGraph`. *)
  Definition admissible n1 n2 :=
    exists n3 n4, ancestor n1 n3 /\ parent n4 n3 /\ ancestor n4 n2.

  #[export] Hint Unfold admissible : main.

  Theorem reflexivity : forall n, parent n n.
  Proof.
    clean.
    destruct n; search.
  Qed.

  #[export] Hint Resolve reflexivity : main.

  Theorem antisymmetry :
    forall n1 n2, ancestor n1 n2 -> ancestor n2 n1 -> n1 = n2.
  Proof.
    #[local] Ltac eliminate H :=
      match type of H with
      | clos_trans_n1 parent ?n1 ?n2 =>
        remember n2; induction H; repeat match goal with
        | [n : node |- _] => destruct n; search
        end
      end.

    clean.
    apply clos_trans_tn1 in H, H0.
    destruct n1, n2; solve [
      reflexivity + eliminate H + eliminate H0; solve [eliminate H1]
    ].
  Qed.

  #[export] Hint Resolve antisymmetry : main.

  Theorem admissibility : forall n1 n2, dependency n1 n2 -> admissible n1 n2.
  Proof.
    clean.
    unfold admissible.
    destruct n1, n2; search; try (
      exists Ingress + exists Egress + exists A + exists B + exists C;
      exists Ingress + exists Egress + exists A + exists B + exists C;
      split; search; solve [
        apply t_trans with (y := Ingress) +
        apply t_trans with (y := Egress) +
        apply t_trans with (y := A) +
        apply t_trans with (y := B) +
        apply t_trans with (y := C);
        solve [search]
      ]
    ).
  Qed.

  #[export] Hint Resolve admissibility : main.
End SingleModule.

Module ModuleTheorems := AdmissibilityGraphTheorems SingleModule.


Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Import Strings.String.
Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Appsub.
Require Import Value.
Require Import PrincipalTyping.

Import ListNotations.

(** * Definition *)

Inductive mode : Set :=
| Inf
| Chk.

Inductive typing : ctx -> term -> mode -> type -> Prop :=
| Ty_Int : forall T n,
    uniq T ->
    typing T (Lit n) Inf Int
| Ty_Var : forall T x A,
    uniq T -> binds x A T ->
    typing T (Fvar x) Inf A
| Ty_Lam : forall L T A B e,
    (forall x, x \notin L ->
          typing ((one (x, A)) ++ T) (open e (Fvar x)) Chk B) ->
    typing T (Lam A e B) Inf (Arr A B)
| Ty_Ann : forall T A e,
    typing T e Chk A ->
    typing T (Ann e A) Inf A
| Ty_App : forall T A B C e1 e2,
    typing T e1 Inf A ->
    typing T e2 Inf B ->
    uunisub A (uP (Avt B)) (Some C) ->
    typing T (App e1 e2) Inf C
| Ty_Mrg : forall T A B e1 e2,
    typing T e1 Inf A ->
    typing T e2 Inf B ->
    typing T (Mrg e1 e2) Inf (And A B)
| Ty_Sub : forall T e A B,
    typing T e Inf A ->
    sub A B ->
    typing T e Chk B.

Hint Constructors typing : core.

Notation "T ⊢ e ⇒ A" := (typing T e Inf A) (at level 50).
Notation "T ⊢ e ⇐ A" := (typing T e Chk A) (at level 50).

(** * Typing & PrincipalTyping *)

Lemma typing_to_ptype :
  forall u A,
    value u ->
    typing nil u Inf A ->
    ptype u A.
Proof.
  introv Val Typ. gen A.
  induction Val; intros.
  - dependent destruction Typ; eauto.
  - dependent destruction Typ; eauto.
Qed.

Hint Resolve typing_to_ptype : core.

(** * Typing & LC *)

Lemma typing_to_lc :
  forall T e A,
    typing T e Inf A -> lc e.
Proof.
  introv Typ.
  induction Typ; eauto 3; try solve [econstructor; eauto].
Qed.

Hint Resolve typing_to_lc : core.

(** * Check Subsumption *)

Lemma typing_chk_sub :
  forall A B e T,
    typing T e Chk A ->
    sub A B ->
    typing T e Chk B.
Proof.
  introv Typ Sub.
  dependent destruction Typ.
  eapply Ty_Sub; eauto.
  eapply sub_transitivity; eauto.
Qed.


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

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

Print Assumptions freeze.


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

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

Print Assumptions freeze.


Require Import Category.
Require Import FunctionalExtensionality.

Set Universe Polymorphism.

Instance co `(Category) : Category := {|
  object := object;
  morphism a b := morphism b a;
  id a := id;
  composition a b c f g := g ∘ f
|}.
Proof.
  - intros.
    apply Category.rightId.
  - intros.
    apply Category.leftId.
  - intros.
    symmetry.
    apply Category.assoc.
Defined.

Definition coCoEqId C : co (co C) = C.
  unfold co.
  cbn.
  destruct C.
  f_equal.
  repeat (let x:=fresh in extensionality x).
  cbn.
  rewrite eq_sym_involutive.
  reflexivity.
Defined.


(************************************************************)
(* ** Grammar of simple types *)

Definition tconstr := var.

CoInductive typ :=
  | typ_exn : typ
  | typ_bool : typ
  | typ_int : typ
  | typ_arrow : typ -> typ -> typ
  | typ_tconstr : tconstr -> list typ -> typ
  | typ_tuple : list typ -> typ
  | typ_record : list (lab*typ) -> typ.

Implicit Types T : typ.

Notation "T1 --> t2" := (typ_arrow T1 T2, right associativity) (at level 60).

(************************************************************)
(* ** Typing of constructors *)

Parameter constr_typing : constr -> list typ -> typ -> Prop.

(************************************************************)
(* ** Typing of environments and memory stores *)

Definition env := LibEnv.env typ.

Definition sto := LibEnv.env typ.

(************************************************************)
(* ** Typing of constants *)

Inductive cst_typing : cst -> typ -> Prop :=
   | cst_typing_bool : forall b,
       cst_typing (cst_bool b) typ_bool.
   | cst_typing_int : forall n,
       cst_typing (cst_int n) typ_int.

(************************************************************)
(* ** Typing of primitives *)

Inductive primtyping : prim -> typ -> Prop :=
  | prim_typing_eq : forall T,
      prim_typing prim_eq (T --> T --> typ_bool)
  | prim_typing_not :
      prim_typing prim_not (typ_bool --> typ_bool)
  | prim_typing_and :
      prim_typing prim_and (typ_bool --> typ_bool -> typ_bool)
  | prim_typing_or :
      prim_typing prim_or (typ_bool --> typ_bool --> typ_bool)
  | prim_typing_neg :
      prim_typing prim_neg (typ_int --> typ_int)
  | prim_typing_add :
      prim_typing prim_add (typ_int --> typ_int --> typ_int)
  | prim_typing_sub :
      prim_typing prim_sub (typ_int --> typ_int --> typ_int)
  | prim_typing_mul :
      prim_typing prim_mul (typ_int --> typ_int --> typ_int)
  | prim_typing_div :
      prim_typing prim_div (typ_int --> typ_int --> typ_int).

(************************************************************)
(* ** Typing of patterns *)

Inductive pat_typing : env -> pat -> typ -> Prop :=
  | pat_typing_var : forall E x T,
      binds E x T ->
      pat_typing E (pat_var x) T
  | pat_typing_wild : forall E T,
      pat_typing E pat_wild T
  | pat_typing_alias : forall E p x T,
      pat_typing E p T ->
      binds E x T ->
      pat_typing E (pat_alias p x) T
  | pat_typing_or : forall E p1 p2 T,
      pat_typing E p1 T ->
      pat_typing E p2 T ->
      pat_typing E (pat_or p1 p2) T
  | pat_typing_cst : forall E c T,
      cst_typing c T ->
      pat_typing E c T
  | pat_typing_constr : forall E k ps Ts T,
      constr_typing k Ts T ->
      Forall2 (pat_typing E) ps Ts ->
      pat_typing E (pat_constr k ps) T
  | pat_typing_tuple : forall E ps Ts,
      Forall2 (pat_typing E) ps Ts ->
      pat_typing E (pat_tuple ps) (typ_tuple Ts)
(* TODO
  | pat_typing_record : forall E aps aTs,
      Forall2 (pat_typing E) aps aTs ->
      pat_typing E (pat_record aps) (typ_record aTs)
  | pat_typing_record_weaken : forall E aps aTs,
      pat_typing E (pat_record aps) (typ_record aTs) ->
      pat_typing E (pat_record aps) (typ_record aTs) ->

  | matching_record_nil : forall avs,
      matching i (val_tuple avs) (pat_tuple nil)
  | matching_record_cons : forall avs a v p aps,
      LibListAssoc.Assoc a v avs ->
      matching i v p ->
      matching i (val_record avs) (pat_record aps) ->
      matching i (val_record avs) (pat_record ((a,p)::aps)).
*)

(************************************************************)
(* ** Typing of terms *)

Inductive trm_typing : env -> trm -> typ -> Prop :=
(*  | trm_typing_int : forall E k,
      ok E ->
      typing E (val_int k) typ_int
  | trm_typing_clo : forall E x T1 T2 t1,
      ok E ->
      typing (empty & x ~~ T1) t1 T2 ->
      typing E (val_clo x t1) (typ_arrow T1 T2)
  | trm_typing_var : forall E x T,
      ok E ->
      binds x T E ->
      typing E (trm_var x) T
  | trm_typing_abs : forall x E U T t1,
      typing (E & x ~~ U) t1 T ->
      typing E (trm_abs x t1) (typ_arrow U T)
  | trm_typing_app : forall T1 T2 E t1 t2,
      typing E t1 (typ_arrow T1 T2) ->
      typing E t2 T1 ->
      typing E (trm_app t1 t2) T2.

Inductive trm : Type :=
  | trm_var : var -> trm
  | trm_cst : cst -> trm
  | trm_abs : option var -> pat -> trm -> trm
  | trm_constr : constr -> list trm -> trm
  | trm_tuple : list trm -> trm
  | trm_record : list (lab*trm) -> trm
  | trm_unary : prim -> trm -> trm
  | trm_binary : prim -> trm -> trm -> trm
  | trm_lazy_binary : prim -> trm -> trm -> trm
  | trm_app : trm -> trm -> trm
  | trm_seq : trm -> trm -> trm
  | trm_let : pat -> trm -> trm -> trm
  | trm_get : trm -> lab -> trm
  | trm_set : trm -> lab -> trm -> trm
  | trm_if : trm -> trm -> option trm -> trm
  | trm_while : trm -> trm -> trm
  | trm_for : var -> dir -> trm -> trm -> trm -> trm
  | trm_match : trm -> list branch -> trm
  | trm_try : trm -> list branch -> trm
  | trm_assert : trm -> trm

*)

with branch_typing : env -> typ -> branch -> typ -> Prop :=
  | branch_typing_intro : forall E F Tp T p ot1 t2,
      pat_typing F p Tp ->
      (forall t1, ot1 = Some t1 -> trm_typing (E & F) t1 typ_bool) ->
      trm_typing (E & F) t2 T
      branch_typing E Tp (branch_intro p ot1 t2) T.

(************************************************************)
(* ** Typing of values *)

Definition ctx := LibEnv.env val. (* todo: move *)

Inductive val_typing : sto -> val -> typ -> Prop :=
  | val_typing_cst : forall c T,
      cst_typing c T ->
      val_typing S (val_cst c) T
  | val_typing_loc : forall S l T,
      binds S l T ->
      val_typing S (val_loc l) T
  | val_typing_abs : forall (* TODO oy*) S p t C E T1 T2,
      ctx_typing C E ->
      pat_typing p T1 ->
      trm_typing E t T2 ->
      val_typing S (val_clo C None p t) (T1 --> T2)
  | val_typing_constr : forall E k vs Ts T,
      constr_typing k Ts T ->
      Forall2 (val_typing E) vs Ts ->
      val_typing E (val_constr k vs) T
  | val_typing_tuple : forall E vs Ts,
      Forall2 (val_typing E) vs Ts ->
      pat_typing E (val_tuple vs) (typ_tuple Ts)
  | val_typing_record : forall E avs As vs Ts avs aTs,
      (As,vs) = LibList.split avs ->
      (As,Ts) = LibList.split aTs ->
      Forall2 (val_typing E) vs Ts ->
      pat_typing E (val_record avs) (typ_record aTs)

(*
with ctx_typing : sto -> ctx -> env -> Prop :=
  | ctx_typing_empty : forall S,
      ctx_typing S empty empty
  | ctx_typing_push : forall S C E v T,
      ctx_typing S C E ->
      val_typing S v T ->
      ctx_typing S (C & x ~ v) (E & x ~ T).
*)

with ctx_typing : sto -> ctx -> env :=
  | ctx_typing_intro : forall S C E v,
      binds S x v ->
      exists T, binds E x T /\ val_typing S v T.

(************************************************************)
(* ** Typing of memory *)

Definition mem_typing S m :=
  forall l v, Heap.binds m l v ->
  exists T, Heap.binds S l T /\ val_typing S v T.

(************************************************************)
(* ** Typing of behaviors *)

Inductive beh_typing : sto -> beh -> Typ -> Prop :=
  | beh_typing_ret : forall S v T,
      val_typing S v T ->
      beh_typing S (beh_ret v) T
  | beh_typing_exn : forall S v T,
      val_typing S v typ_exn ->
      beh_typing S (beh_exn v) T.

(************************************************************)
(* ** Typing of outcomes *)

Inductive out_typing : sto -> out -> Typ -> Prop :=
  | out_typing_beh : forall S B T,
      mem_typing S m ->
      beh_typing S B T ->
      out_typing S (out_ter m B) T
  | out_typing_div : forall S T,
      out_typing S out_div T.

(************************************************************)
(* ** Typing of extended terms *)

(** TODO: stack? *)

Inductive ext_typing : sto -> ext -> typ -> Prop :=
  | ext_typing_trm : forall t T,
      trm_typing empty t T ->
      ext_typing S (ext_trm t) T
  | ext_typing_app_1 : forall S t T1 T2,
      out_typing S o1 (T1 --> T2) ->
      trm_typing S t2 T1 ->
      ext_typing S (ext_app_1 o1 t2) T2
  | ext_typing_list_1 : forall S ts vs Ts1 Ts2 T,
      Forall2 (trm_typing empty) ts Ts1 ->
      Forall2 (val_typing S) vs Ts2 ->
      (forall S' vs', Forall2 (val_typing S') vs' (Ts1++Ts2) -> ext_typing S' (K vs') T) ->
      ext_typing S (ext_list_1 ts vs K) T

.
(*
Inductive ext : Type :=
  | ext_trm : trm -> ext
  | ext_constr_1 : constr -> vals -> ext
  | ext_tuple_1 : vals -> ext
  | ext_record_1 : labvals -> ext
  | ext_unary_1 : prim -> out -> ext
  | ext_binary_1 : prim -> out -> trm -> ext
  | ext_binary_2 : prim -> val -> out -> ext
  | ext_lazy_binary_1 : prim -> out -> trm -> ext
  | ext_app_1 : out -> trm -> ext
  | ext_app_2 : val -> out -> ext
  | ext_seq_1 : out -> trm -> ext
  | ext_let_1 : pat -> out -> trm -> ext
  | ext_get_1 : out -> lab -> ext
  | ext_set_1 : out -> lab -> trm -> ext
  | ext_set_2 : val -> lab -> out -> ext
  | ext_if_1 : out -> trm -> option trm -> ext
  | ext_for_1 : var -> dir -> out -> trm -> trm -> ext
  | ext_for_2 : var -> dir -> int -> out -> trm -> ext
  | ext_for_3 : var -> dir -> int -> int -> trm -> ext
  | ext_match_1 : out -> branches -> ext
  | ext_try_1 : out -> branches -> ext
  | ext_assert_1 : out -> ext
  | ext_list_1 : trms -> vals -> (vals -> ext) -> ext
  | ext_list_2 : out -> trms -> vals -> (vals -> ext) -> ext
  | ext_lablist_1 : labtrms -> labvals -> (labvals -> ext) -> ext
  | ext_lablist_2 : out -> lab -> labtrms -> labvals -> (labvals -> ext) -> ext
  | ext_branches_1 : beh -> val -> branches -> ext
  | ext_branches_2 : beh -> val -> branches -> out -> trm -> ext.
*)


Require Import CertiGraph.dijkstra.dijkstra_env.
Require Export CertiGraph.graph.MathAdjMatGraph.

Local Open Scope logic.
Local Open Scope Z_scope.

Section MathDijkGraph.

  Context {size : Z}.
  Context {inf : Z}.
  Context {V_EqDec : EqDec V eq}.
  Context {E_EqDec : EqDec E eq}.

  (* Here is the LabeledGraph *)
  Definition DijkLG := AdjMatLG.

  (* The soundness condition *)
  Class SoundDijk (g: DijkLG) :=
    {
    basic:
      (* first, we can take AdjMat's soundness wholesale *)
      @SoundAdjMat size inf g;

    veb:
      (* from the AdjMat soundness above we already know
         e is representable,
         but for Dijkstra we need a further constraint.
       *)
      forall e,
        evalid g e ->
        0 <= elabel g e <= (Int.max_signed / size) - 1;

    cts: (* cost_to_self *)
      forall v, vvalid g v -> elabel g (v, v) = 0;

    sfr: (* size is further restricted *)
      size * 4 <= Int.max_signed;
    (* because sizeof tint = 4 *)

    ifr: (* inf is further restricted *)
      (Int.max_signed / size) - 1 < inf <= Int.max_signed - (Int.max_signed / size) + 1

    }.

  (* And here is the GeneralGraph that we will use *)
  Definition DijkGG := (GeneralGraph V E DV DE DG (fun g => SoundDijk g)).

  (* Some handy coercions: *)
  Identity Coercion AdjMatLG_DijkLG: DijkLG >-> AdjMatLG.
  Identity Coercion LabeledGraph_AdjMatLG: AdjMatLG >-> LabeledGraph.

  (* We can drag out the soundness condition *)
  Definition SoundDijk_DijkGG (g: DijkGG) := (@sound_gg _ _ _ _ _ _ _ _ g).

  (* We can always drag out SoundAdjMat *)
  Definition SoundAdjMat_DijkGG (g: DijkGG) :=
    @basic g (SoundDijk_DijkGG g).

  (* A DijkGG can be weakened into an AdjMatGG *)
  Definition AdjMatGG_DijkGG (g: DijkGG) : AdjMatGG :=
    Build_GeneralGraph DV DE DG SoundAdjMat g (SoundAdjMat_DijkGG g).

  Coercion AdjMatGG_DijkGG: DijkGG >-> AdjMatGG.

  (* Great! So now when we want to access an AdjMat
     plugin, we can simply use the AdjMat getter
     and pass it a DijkGG. The coercion will be seamless.
   *)

  (* For the four Dijkstra-specific plugins, we create getters: *)
  Definition valid_edge_bounds (g: DijkGG) :=
    @veb g (SoundDijk_DijkGG g).

  Definition cost_to_self (g: DijkGG) :=
    @cts g (SoundDijk_DijkGG g).

  Definition size_further_restricted (g: DijkGG) :=
    @sfr g (SoundDijk_DijkGG g).

  Definition inf_further_restricted (g: DijkGG) :=
    @ifr g (SoundDijk_DijkGG g).

  Lemma inf_bounds:
    forall (g: DijkGG),
      0 < inf < Int.max_signed.
  Proof.
    intros.
    apply (inf_representable g).
  Qed.

  (* And now some lemmas that come from soundness plugins. *)

  Lemma edge_cost_pos:
    forall (g: DijkGG) e,
      0 <= elabel g e.
  Proof.
    intros.
    pose proof (valid_edge_bounds g e).
    pose proof (invalid_edge_weight g e).
    destruct (@evalid_dec _ _ _ _ g (finGraph g) e).
    - apply H; trivial.
    - rewrite H0 in n.
      replace (elabel g e) with inf by trivial.
      pose proof (@inf_representable _ _ g). lia.
  Qed.

  Lemma div_pos_le:
    forall a b,
      0 <= a ->
      0 < b ->
      a / b <= a.
  Proof.
    intros.
    rewrite <- (Z2Nat.id a); trivial.
    rewrite <- (Z2Nat.id b); [|lia].
    remember (Z.to_nat a) as n1.
    remember (Z.to_nat b) as n2.
    rewrite <- div_Zdiv by lia.
    apply inj_le.
    replace n1 with (Nat.div n1 1) at 2.
    2: apply Nat.div_1_r.
    apply Nat.div_le_compat_l.
    lia.
  Qed.

  Lemma edge_representable:
    forall (g: DijkGG) e,
      Int.min_signed <= elabel g e <= Int.max_signed.
  Proof.
    intros.
    pose proof (valid_edge_bounds g e).
    pose proof (invalid_edge_weight g e).
    pose proof (edge_cost_pos g e).
    destruct (@evalid_dec _ _ _ _ g (finGraph g) e).
    - specialize (H e0).
      split; trivial. rep_lia.
      apply Z.le_trans with (m := (Int.max_signed / size) - 1); trivial.
      apply H.
      pose proof (size_representable g).
      apply Z.le_trans with (m := Int.max_signed / size).
      lia.
      apply div_pos_le; lia.
    - rewrite H0 in n.
      replace (elabel g e) with inf by trivial.
      pose proof (inf_representable g).
      split; rep_lia.
  Qed.

  Lemma strong_evalid_dijk:
    forall (g: DijkGG) a b,
      vvalid g a ->
      vvalid g b ->
      elabel g (a, b) < inf ->
      strong_evalid g (a,b).
  Proof.
    intros.
    split3;
      [rewrite (evalid_meaning g) |
       rewrite (edge_src_fst g) |
       rewrite (edge_dst_snd g)]; trivial.
    split; trivial.
    apply edge_representable.
  Qed.

End MathDijkGraph.


Require Import List.
Require Import ListSet.
Require Import String.
Require Import Basics.
Require Import MyBase.
Require Import lang.
Import ListNotations.

Reserved Notation "a '∈f' b" (at level 1, no associativity).
Reserved Notation "a '∉f' b" (at level 1, no associativity).
Reserved Notation "a '∈b' b" (at level 1, no associativity).

Inductive NotInFV : string -> 𝔼 -> Prop :=
| NotFVVarExpr {s1 s2} (neq : s1 <> s2) : s1 ∉f s2
| NotFVNatExpr {s} {n : nat} : s ∉f n
| NotFVAddExpr {s e1 e2} (notInLeft : s ∉f e1) (notInRight : s ∉f e2) : s ∉f (e1 + e2)
| NotFVAppExpr {s e1 e2} (notInLeft : s ∉f e1) (notInRight : s ∉f e2) : s ∉f (AppExpr e1 e2)
| NotFVAbsExpru f x τ body {s} (notF : f <> s) (notX : x <> s) (notInBody : s ∉f body) : s ∉f (AbsExpr f x τ body)
| NotFVAbsExprx f x τ body : x ∉f (AbsExpr f x τ body)
| NotFVAbsExprf f x τ body : f ∉f (AbsExpr f x τ body)
where "s ∉f e" := (NotInFV s e) : FV_scope.

Inductive InFV : string -> 𝔼 -> Prop :=
| FVVarExpr {s} : s ∈f s
| FVAddExprL {s e1 e2} (inSub: s ∈f e1) : s ∈f (e1 + e2)
| FVAddExprR {s e1 e2} (inSub: s ∈f e2) : s ∈f (e1 + e2)
| FVAbsExpr {f x τ body s} (notF : f <> s) (notX : x <> s) (inSub : s ∈f body) : s ∈f (AbsExpr f x τ body)
| FVAppExprL {s e1 e2} (inSub: s ∈f e1) : s ∈f (AppExpr e1 e2)
| FVAppExprR {s e1 e2} (inSub: s ∈f e2) : s ∈f (AppExpr e1 e2)
where "s ∈f e" := (InFV s e) : FV_scope.

Open Scope FV_scope.

Lemma InFVExclusive {s e} : s ∈f e -> s ∉f e -> False.
  induction e.
  all: intros ine notine; inversion ine; inversion notine; done.
Qed.

Lemma InFVOptions s e : s ∈f e \/ s ∉f e.
Proof with done.
  induction e.
  - destruct (string_dec s x)...
  - done.
  - decompose [or] IHe1; decompose [or] IHe2...
  - decompose [or] IHe; destruct (string_dec f s); destruct (string_dec x s)...
  - decompose [or] IHe1; decompose [or] IHe2...
Qed.

Inductive InBV : string -> 𝔼 -> Prop :=
| BVFName {f x τ body} : f ∈b (AbsExpr f x τ body)
| BVArg {f x τ body} : x ∈b (AbsExpr f x τ body)
| BVAddExprL {s e1 e2} (inSub: s ∈b e1) : s ∈b (e1 + e2)
| BVAddExprR {s e1 e2} (inSub: s ∈b e2) : s ∈b (e1 + e2)
| BVAppExprL {s e1 e2} (inSub: s ∈b e1) : s ∈b (AppExpr e1 e2)
| BVAppExprR {s e1 e2} (inSub: s ∈b e2) : s ∈b (AppExpr e1 e2)
where "x ∈b e" := (InBV x e).

Reserved Notation "[ a / s ] b = c" (at level 1, no associativity,
                                     a at next level, s at next level,
                                     b at next level, c at next level).

Inductive CAS : 𝔼 -> string -> 𝔼 -> 𝔼 -> Prop :=
| VarCASeq {s1 s2 e} (eq : s1 = s2) : [e / s1] s2 = e
| VarCASneq {s1 s2 e} (neq : s1 <> s2) : [e / s1] s2 = s2
| NatCAS {e s} (n : nat) : [e / s] n = n
| AddCAS {e s e1 e1' e2 e2'}
          (LeftAddCAS : [e / s] e1 = e1')
          (RightAddCAS : [e / s] e2 = e2')
  : [e / s] (e1 + e2) = (e1' + e2')
| AppCAS {e s e1 e1' e2 e2'}
          (LeftAppCAS : [e / s] e1 = e1')
          (RightAppCAS : [e / s] e2 = e2')
  : [e / s] (AppExpr e1 e2) = (AppExpr e1' e2')
| AbsCASUnbound {e s f x τ body body'}
                (notF : s <> f)
                (notX : s <> x)
                (fNotIn : f ∉f e)
                (xNotIn : x ∉f e)
                (bodyCAS : [e / s] body = body')
  : [e / s] (AbsExpr f x τ body) = (AbsExpr f x τ body')
| AbsCASF {e f x τ body} : [e / f] (AbsExpr f x τ body) = (AbsExpr f x τ body)
| AbsCASX {e f x τ body} : [e / x] (AbsExpr f x τ body) = (AbsExpr f x τ body)
where "[ a / s ] b = c" := (CAS a s b c).

Inductive SafeToSubInto (e : 𝔼) : 𝔼 -> Prop :=
| SafeToSubIntoVarExpr {s : string} : SafeToSubInto e s
| SafeToSubIntoNatExpr {n : nat} : SafeToSubInto e n
| SafeToSubIntoAddExpr (e0 e1 : 𝔼)
                       (safe1 : SafeToSubInto e e0)
                       (safe2 : SafeToSubInto e e1)
  : SafeToSubInto e (e0 + e1)
| SafeToSubIntoAppExpr (e0 e1 : 𝔼)
                       (safe1 : SafeToSubInto e e0)
                       (safe2 : SafeToSubInto e e1)
  : SafeToSubInto e (AppExpr e0 e1)
| SafeToSubIntoAbExpr {f x τ body}
                      (notFIn : f ∉f e)
                      (notXIn : x ∉f e)
                      (safe : SafeToSubInto e body)
  : SafeToSubInto e (AbsExpr f x τ body).

Axiom AlwaysSafeToSubInto : forall e1 e2, SafeToSubInto e1 e2.

Lemma CASAlways {e1 x e} : SafeToSubInto e1 e -> exists e2, [e1 / x] e = e2.
  intros H.
  induction e.
  - destruct (string_dec x x0) as [-> | neq].
    + exists e1; done.
    + exists x0; done.
  - exists n; done.
  - inversion H.
    destruct (IHe1 safe1).
    destruct (IHe2 safe2).
    exists (AddExpr x0 x1).
    done.
  - inversion H.
    destruct (IHe safe).
    destruct (string_dec x f) as [-> | nef].
    + exists (AbsExpr f x0 τ e).
      done.
    + destruct (string_dec x x0) as [-> | nex0].
      * exists (AbsExpr f x0 τ e).
        done.
      * exists (AbsExpr f x0 τ x2).
        done.
  - inversion H.
    destruct (IHe1 safe1).
    destruct (IHe2 safe2).
    exists (AppExpr x0 x1).
    done.
Qed.

Definition substitution_list := list (𝔼 * string).

Definition sub_dec (sub1 sub2 : (𝔼 * string)) : ({sub1 = sub2} + {sub1 <> sub2}).
Proof.
  decide equality.
  - apply string_dec.
  - decide equality.
    + apply string_dec.
    + decide equality.
    + decide equality.
    + apply string_dec.
    + apply string_dec.
Qed.

Inductive MultiCAS : substitution_list -> 𝔼 -> 𝔼 -> Prop :=
| MultiCASNull {e} : MultiCAS nil e e
| MultiCASCons {e s subs e' e'' e'''}
                (MultiCASe'' : (MultiCAS subs e' e''))
                (CASe' : (CAS e s e'' e'''))
  : MultiCAS ((e,s)::subs) e' e'''.

Reserved Notation "a '≡α' b" (at level 1, no associativity).

Inductive AlphaEquiv : 𝔼 -> 𝔼 -> Prop :=
| RAE {e} : e ≡α e
| AAE {a b c d}
      (AEQac : a ≡α c)
      (AEQbd : b ≡α d)
  : (a + b) ≡α (c + d)
| PAE {a b c d}
      (AEQac : a ≡α c)
      (AEQbd : b ≡α d)
  : (AppExpr a b) ≡α (AppExpr c d)
| BAE {f f1 f2 x x1 x2 τ body1 body1' body2 body2'}
      (FXDiff : f <> x)
      (FFresh1 : f ∉f body1)
      (FFresh2 : f ∉f body2)
      (XFresh1 : x ∉f body1)
      (XFresh2 : x ∉f body2)
      (FCAS1 : [f / f1] body1 = body1')
      (FCAS2 : [f / f2] body2 = body2')
      (AEQ12 : body1' ≡α body2')
  : (AbsExpr f1 x1 τ body1) ≡α (AbsExpr f2 x2 τ body2)
where "a ≡α b" := (AlphaEquiv a b).

Theorem AlphaEquivSymm {e1 e2} : e1 ≡α e2 -> e2 ≡α e1.
  induction 1; done.
Qed.