(**
 Properties of composition

 Contents:
 1. Composition of equivalences
 2. Composition of adjoint equivalences
 3. Composition of faithful 1-cells
 4. Composition of fully faithful 1-cells
 5. Composition of discrete 1-cells
 6. Composition of pseudomonic 1-cells
 7. Composition of Street fibrations
 8. Composition of Street opfibrations
 9. Composition of adjunctions
 *)
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.Bicategories.Core.Bicat.
Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Unitors.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.AdjointUnique.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.FullyFaithful.
Require Import UniMath.Bicategories.Morphisms.DiscreteMorphisms.
Require Import UniMath.Bicategories.Morphisms.InternalStreetFibration.
Require Import UniMath.Bicategories.Morphisms.InternalStreetOpFibration.

Local Open Scope cat.

(**
 1. Composition of equivalences
 *)
Section CompositionEquivalence.
  Context {B : bicat}
          {a b c : B}
          (l₁ : a --> b)
          (l₂ : b --> c)
          (Hl₁ : left_equivalence l₁)
          (Hl₂ : left_equivalence l₂).

  Let r₁ : b --> a := left_adjoint_right_adjoint Hl₁.
  Let r₂ : c --> b := left_adjoint_right_adjoint Hl₂.

  Let η₁ : invertible_2cell (id₁ a) (l₁ · r₁)
    := left_equivalence_unit_iso Hl₁.
  Let η₂ : invertible_2cell (id₁ b) (l₂ · r₂)
    := left_equivalence_unit_iso Hl₂.

  Let ε₁ : invertible_2cell (r₁ · l₁) (id₁ b)
    := left_equivalence_counit_iso Hl₁.
  Let ε₂ : invertible_2cell (r₂ · l₂) (id₁ c)
    := left_equivalence_counit_iso Hl₂.

  Let ηc : id₁ a ==> l₁ · l₂ · (r₂ · r₁)
    := η₁
       • (rinvunitor _
          • (l₁ ◃ η₂)
          • lassociator _ _ _ ▹ r₁)
       • rassociator _ _ _.

  Let εc : r₂ · r₁ · (l₁ · l₂) ==> id₁ c
    := rassociator _ _ _
       • (r₂ ◃ (lassociator _ _ _
                • (ε₁ ▹ l₂)
                • lunitor _))
       • ε₂.

  Definition comp_equiv
    : left_equivalence (l₁ · l₂).
  Proof.
    simple refine ((_ ,, (_ ,, _)) ,, (_ ,, _)).
    - exact (r₂ · r₁).
    - exact ηc.
    - exact εc.
    - cbn ; unfold ηc.
      is_iso.
      + apply property_from_invertible_2cell.
      + apply property_from_invertible_2cell.
    - cbn ; unfold εc.
      is_iso.
      + apply property_from_invertible_2cell.
      + apply property_from_invertible_2cell.
  Defined.
End CompositionEquivalence.

(**
 2. Composition of adjoint equivalences
 *)
Definition comp_adjequiv
           {B : bicat}
           {a b c : B}
           (l₁ : adjoint_equivalence a b)
           (l₂ : adjoint_equivalence b c)
  : adjoint_equivalence a c.
Proof.
  use (equiv_to_adjequiv (l₁ · l₂)).
  use comp_equiv.
  - exact l₁.
  - exact l₂.
Defined.

Definition comp_left_adjoint_equivalence
           {B : bicat}
           {a b c : B}
           {l₁ : a --> b}
           (Hl₁ : left_adjoint_equivalence l₁)
           {l₂ : b --> c}
           (Hl₂ : left_adjoint_equivalence l₂)
  : left_adjoint_equivalence (l₁ · l₂).
Proof.
  exact (comp_adjequiv (l₁ ,, Hl₁) (l₂ ,, Hl₂)).
Defined.

Lemma unique_adjoint_equivalence_comp
      {B : bicat}
      (HB : is_univalent_2 B)
      {a b c : B}
  : ∏ (f : adjoint_equivalence a b) (g : adjoint_equivalence b c),
    comp_adjequiv f g = comp_adjoint_equivalence (pr1 HB) a b c f g.
Proof.
  use (J_2_0 (pr1 HB) (λ a b f, _)).
  intros x g; simpl.
  unfold comp_adjoint_equivalence.
  rewrite J_2_0_comp.
  use subtypePath.
  {
    intro.
    exact (isaprop_left_adjoint_equivalence _ (pr2 HB)).
  }
  cbn.
  apply (isotoid_2_1 (pr2 HB)).
  use make_invertible_2cell.
  - exact (lunitor (pr1 g)).
  - is_iso.
Qed.

(**
 3. Composition of faithful 1-cells
 *)
Definition comp_faithful
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           {g : b --> c}
           (Hf : faithful_1cell f)
           (Hg : faithful_1cell g)
  : faithful_1cell (f · g).
Proof.
  intros z g₁ g₂ α₁ α₂ p.
  apply (faithful_1cell_eq_cell Hf).
  apply (faithful_1cell_eq_cell Hg).
  use (vcomp_rcancel (rassociator _ _ _)).
  {
    is_iso.
  }
  rewrite !rwhisker_rwhisker_alt.
  rewrite p.
  apply idpath.
Qed.

(**
 4. Composition of fully faithful 1-cells
 *)
Definition comp_fully_faithful
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           {g : b --> c}
           (Hf : fully_faithful_1cell f)
           (Hg : fully_faithful_1cell g)
  : fully_faithful_1cell (f · g).
Proof.
  use make_fully_faithful.
  - exact (comp_faithful
             (fully_faithful_1cell_faithful Hf)
             (fully_faithful_1cell_faithful Hg)).
  - intros z g₁ g₂ αf.
    simple refine (_ ,, _).
    + apply (fully_faithful_1cell_inv_map Hf).
      apply (fully_faithful_1cell_inv_map Hg).
      exact (rassociator _ _ _ • αf • lassociator _ _ _).
    + abstract
        (cbn ;
         use (vcomp_rcancel (lassociator _ _ _)) ; [ is_iso | ] ;
         rewrite !vassocl ;
         rewrite <- rwhisker_rwhisker ;
         rewrite !fully_faithful_1cell_inv_map_eq ;
         rewrite !vassocr ;
         rewrite lassociator_rassociator ;
         rewrite id2_left ;
         apply idpath).
Defined.

(**
 5. Composition of conservative 1-cells
 *)
Definition comp_conservative
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           {g : b --> c}
           (Hf : conservative_1cell f)
           (Hg : conservative_1cell g)
  : conservative_1cell (f · g).
Proof.
  intros x g₁ g₂ α Hα.
  apply Hf.
  apply Hg.
  use eq_is_invertible_2cell.
  - exact (rassociator _ _ _ • (α ▹ f · g) • lassociator _ _ _).
  - abstract
      (rewrite !vassocl ;
       rewrite <- rwhisker_rwhisker ;
       rewrite !vassocr ;
       rewrite rassociator_lassociator ;
       apply id2_left).
  - use is_invertible_2cell_vcomp.
    + use is_invertible_2cell_vcomp.
      * is_iso.
      * exact Hα.
    + is_iso.
Defined.

(**
 5. Composition of discrete 1-cells
 *)
Definition comp_discrete
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           {g : b --> c}
           (Hf : discrete_1cell f)
           (Hg : discrete_1cell g)
  : discrete_1cell (f · g).
Proof.
  split.
  - apply comp_faithful.
    + exact (pr1 Hf).
    + exact (pr1 Hg).
  - apply comp_conservative.
    + exact (pr2 Hf).
    + exact (pr2 Hg).
Defined.

(**
 6. Composition of pseudomonic 1-cells
 *)
Definition comp_pseudomonic
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           {g : b --> c}
           (Hf : pseudomonic_1cell f)
           (Hg : pseudomonic_1cell g)
  : pseudomonic_1cell (f · g).
Proof.
  use make_pseudomonic.
  - apply comp_faithful.
    + apply pseudomonic_1cell_faithful.
      exact Hf.
    + apply pseudomonic_1cell_faithful.
      exact Hg.
  - intros z g₁ g₂ αf Hαf.
    simple refine (_ ,, _).
    + simple refine (pseudomonic_1cell_inv_map Hf _ _).
      * apply (pseudomonic_1cell_inv_map
                 Hg
                 (rassociator _ _ _ • αf • lassociator _ _ _)).
        is_iso.
      * apply is_invertible_2cell_pseudomonic_1cell_inv_map.
    + split.
      * apply is_invertible_2cell_pseudomonic_1cell_inv_map.
      * abstract
          (use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ] ;
           rewrite <- rwhisker_rwhisker_alt ;
           rewrite !pseudomonic_1cell_inv_map_eq ;
           rewrite !vassocl ;
           rewrite lassociator_rassociator ;
           rewrite id2_right ;
           apply idpath).
Defined.

(**
 7. Composition of Street fibrations
 *)
Section CompositionOfSFib.
  Context {B : bicat}
          {a b c : B}
          {f : a --> b}
          {g : b --> c}
          (Hf : internal_sfib f)
          (Hg : internal_sfib g).

  Section CompCartesian.
    Context {z : B}
            {h₁ h₂ : z --> a}
            (α : h₁ ==> h₂)
            (Hα₁ : is_cartesian_2cell_sfib f α)
            (Hα₂ : is_cartesian_2cell_sfib g (α ▹ f)).

    Section ToCartesianComp.
      Context {k : z --> a}
              {β : k ==> h₂}
              {δp : k · (f · g) ==> h₁ · (f · g)}
              (q : β ▹ f · g = δp • (α ▹ f · g)).

      Local Lemma to_is_cartesian_2cell_comp_factor_help
        : (β ▹ f) ▹ g
          =
          rassociator k f g • δp • lassociator h₁ f g • ((α ▹ f) ▹ g).
      Proof.
        rewrite !vassocl.
        use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
        rewrite rwhisker_rwhisker.
        rewrite q.
        rewrite !vassocl.
        rewrite rwhisker_rwhisker.
        apply idpath.
      Qed.

      Let ζ : k · f ==> h₁ · f
        := is_cartesian_2cell_sfib_factor
             _
             Hα₂
             (β ▹ f)
             (rassociator _ _ _ • δp • lassociator _ _ _)
             to_is_cartesian_2cell_comp_factor_help.

      Definition to_is_cartesian_2cell_comp_factor
        : k ==> h₁.
      Proof.
        simple refine (is_cartesian_2cell_sfib_factor _ Hα₁ β ζ _).
        abstract
          (unfold ζ ;
           rewrite is_cartesian_2cell_sfib_factor_comm ;
           apply idpath).
      Defined.

      Definition to_is_cartesian_2cell_comp_over
        : to_is_cartesian_2cell_comp_factor ▹ f · g = δp.
      Proof.
        unfold to_is_cartesian_2cell_comp_factor, ζ.
        use (vcomp_lcancel (rassociator _ _ _)) ; [ is_iso | ].
        rewrite <- rwhisker_rwhisker_alt.
        rewrite !is_cartesian_2cell_sfib_factor_over.
        rewrite !vassocl.
        rewrite lassociator_rassociator.
        rewrite id2_right.
        apply idpath.
      Qed.

      Definition to_is_cartesian_2cell_comp_comm
        : to_is_cartesian_2cell_comp_factor • α = β.
      Proof.
        unfold to_is_cartesian_2cell_comp_factor.
        rewrite is_cartesian_2cell_sfib_factor_comm.
        apply idpath.
      Qed.

      Definition to_is_cartesian_2cell_comp_unique
        : isaprop (∑ (δ : k ==> h₁), δ ▹ f · g = δp × δ • α = β).
      Proof.
        use invproofirrelevance.
        intros φ₁ φ₂.
        use subtypePath.
        {
          intro.
          apply isapropdirprod ; apply cellset_property.
        }
        use (is_cartesian_2cell_sfib_factor_unique _ Hα₁ _ β ζ).
        - unfold ζ.
          rewrite is_cartesian_2cell_sfib_factor_comm.
          apply idpath.
        - use (is_cartesian_2cell_sfib_factor_unique
                 _ Hα₂
                 _
                 (β ▹ f)
                 (rassociator _ _ _ • δp • lassociator _ _ _)
                 to_is_cartesian_2cell_comp_factor_help).
          + rewrite !vassocl.
            use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
            rewrite rwhisker_rwhisker.
            apply maponpaths_2.
            exact (pr12 φ₁).
          + apply is_cartesian_2cell_sfib_factor_over.
          + rewrite !rwhisker_vcomp.
            rewrite (pr22 φ₁).
            apply idpath.
          + apply is_cartesian_2cell_sfib_factor_comm.
        - use (is_cartesian_2cell_sfib_factor_unique
                 _ Hα₂
                 _
                 (β ▹ f)
                 (rassociator _ _ _ • δp • lassociator _ _ _)
                 to_is_cartesian_2cell_comp_factor_help).
          + rewrite !vassocl.
            use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
            rewrite rwhisker_rwhisker.
            apply maponpaths_2.
            exact (pr12 φ₂).
          + apply is_cartesian_2cell_sfib_factor_over.
          + rewrite !rwhisker_vcomp.
            rewrite (pr22 φ₂).
            apply idpath.
          + apply is_cartesian_2cell_sfib_factor_comm.
        - exact (pr22 φ₁).
        - exact (pr22 φ₂).
      Qed.
    End ToCartesianComp.

    Definition to_is_cartesian_2cell_comp
      : is_cartesian_2cell_sfib (f · g) α.
    Proof.
      intros k β δp q.
      use iscontraprop1.
      - exact (to_is_cartesian_2cell_comp_unique q).
      - exact (to_is_cartesian_2cell_comp_factor q
               ,,
               to_is_cartesian_2cell_comp_over q
               ,,
               to_is_cartesian_2cell_comp_comm q).
    Defined.
  End CompCartesian.

  Section CompCleaving.
    Context {z : B}
            {h₁ : z --> c}
            {h₂ : z --> a}
            (α : h₁ ==> h₂ · (f · g)).

    Let ℓ₁ : z --> b
      := pr1 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _)).
    Let γ₁ : ℓ₁ ==> h₂ · f
      := pr12 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _)).
    Let β₁ : invertible_2cell (ℓ₁ · g) h₁
      := pr122 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _)).
    Let Hγ₁ : is_cartesian_2cell_sfib g γ₁
      := pr1 (pr222 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _))).
    Let p₁ : γ₁ ▹ g = β₁ • (α • lassociator h₂ f g)
      := pr2 (pr222 (pr1 Hg z h₁ (h₂ · f) (α • lassociator _ _ _))).

    Let ℓ₂ : z --> a
      := pr1 (pr1 Hf z ℓ₁ h₂ γ₁).
    Let γ₂ : ℓ₂ ==> h₂
      := pr12 (pr1 Hf z ℓ₁ h₂ γ₁).
    Let β₂ : invertible_2cell (ℓ₂ · f) ℓ₁
      := pr122 (pr1 Hf z ℓ₁ h₂ γ₁).
    Let Hγ₂ : is_cartesian_2cell_sfib f γ₂
      := pr1 (pr222 (pr1 Hf z ℓ₁ h₂ γ₁)).
    Let p₂ : γ₂ ▹ f = β₂ • γ₁
      := pr2 (pr222 (pr1 Hf z ℓ₁ h₂ γ₁)).

    Definition comp_sfib_cleaving_lift
      : z --> a
      := ℓ₂.

    Definition comp_sfib_cleaving_cell
      : comp_sfib_cleaving_lift ==> h₂
      := γ₂.

    Definition comp_sfib_cleaving_cell_over_f
      : comp_sfib_cleaving_cell ▹ f = β₂ • γ₁
      := p₂.

    Definition comp_sfib_cleaving_cell_g_cartesian
      : is_cartesian_2cell_sfib g γ₁
      := Hγ₁.

    Definition comp_sfib_cleaving_cell_f_cartesian
      : is_cartesian_2cell_sfib f comp_sfib_cleaving_cell
      := Hγ₂.

    Definition comp_sfib_cleaving_over
      : invertible_2cell (comp_sfib_cleaving_lift · (f · g)) h₁
      := comp_of_invertible_2cell
           (comp_of_invertible_2cell
              (lassociator_invertible_2cell _ _ _)
              (rwhisker_of_invertible_2cell
                 _
                 β₂))
           β₁.

    Definition comp_sfib_cleaving_is_cartesian_2cell
      : is_cartesian_2cell_sfib (f · g) comp_sfib_cleaving_cell.
    Proof.
      use to_is_cartesian_2cell_comp.
      - exact Hγ₂.
      - unfold comp_sfib_cleaving_cell.
        use (is_cartesian_eq _ (!p₂)).
        use vcomp_is_cartesian_2cell_sfib.
        + apply invertible_is_cartesian_2cell_sfib.
          apply property_from_invertible_2cell.
        + exact Hγ₁.
    Defined.

    Definition comp_sfib_cleaving_comm
      : comp_sfib_cleaving_cell ▹ f · g
        =
        comp_sfib_cleaving_over • α.
    Proof.
      unfold comp_sfib_cleaving_cell, comp_sfib_cleaving_over ; cbn.
      rewrite !vassocl.
      use vcomp_move_L_pM ; [ is_iso | ] ; cbn.
      rewrite <- rwhisker_rwhisker_alt.
      etrans.
      {
        apply maponpaths_2.
        apply maponpaths.
        exact p₂.
      }
      rewrite <- rwhisker_vcomp.
      rewrite p₁.
      rewrite !vassocl.
      rewrite lassociator_rassociator.
      rewrite id2_right.
      apply idpath.
    Qed.
  End CompCleaving.

  Definition comp_sfib_cleaving
    : internal_sfib_cleaving (f · g)
    := λ z h₁ h₂ α,
       comp_sfib_cleaving_lift α
       ,,
       comp_sfib_cleaving_cell α
       ,,
       comp_sfib_cleaving_over α
       ,,
       comp_sfib_cleaving_is_cartesian_2cell α
       ,,
       comp_sfib_cleaving_comm α.

  Section FromCompCartesian.
    Context {z : B}
            {h₁ h₂ : z --> a}
            (α : h₁ ==> h₂)
            (Hα : is_cartesian_2cell_sfib (f · g) α).

    Local Lemma from_is_cartesian_2cell_eq
      : α ▹ f · g
        =
        (comp_sfib_cleaving_over (α ▹ f · g))^-1
        • (comp_sfib_cleaving_cell (α ▹ f · g) ▹ f · g).
    Proof.
      use vcomp_move_L_pM ; [ is_iso | ].
      rewrite comp_sfib_cleaving_comm.
      apply idpath.
    Qed.

    Let ζ : invertible_2cell h₁ (comp_sfib_cleaving_lift (α ▹ f · g))
      := invertible_between_cartesians
           Hα
           (comp_sfib_cleaving_is_cartesian_2cell (α ▹ (f · g)))
           (inv_of_invertible_2cell (comp_sfib_cleaving_over (α ▹ f · g)))
           from_is_cartesian_2cell_eq.

    Local Lemma from_is_cartesian_2cell_comp_eq
      : ζ • comp_sfib_cleaving_cell (α ▹ (f · g))
        =
        α.
    Proof.
      apply is_cartesian_2cell_sfib_factor_comm.
    Qed.

    Definition from_is_cartesian_2cell_comp
      : is_cartesian_2cell_sfib f α.
    Proof.
      use (is_cartesian_eq _ from_is_cartesian_2cell_comp_eq).
      use vcomp_is_cartesian_2cell_sfib.
      - use invertible_is_cartesian_2cell_sfib.
        apply property_from_invertible_2cell.
      - apply comp_sfib_cleaving_cell_f_cartesian.
    Defined.

    Local Lemma from_is_cartesian_2cell_comp_rwhisker_eq
      : ((ζ ▹ f) • (comp_sfib_cleaving_cell (α ▹ f · g) ▹ f))
        =
        α ▹ f.
    Proof.
      rewrite rwhisker_vcomp.
      rewrite from_is_cartesian_2cell_comp_eq.
      apply idpath.
    Qed.

    Definition from_is_cartesian_2cell_comp_rwhisker
      : is_cartesian_2cell_sfib g (α ▹ f).
    Proof.
      use (is_cartesian_eq _ from_is_cartesian_2cell_comp_rwhisker_eq).
      use vcomp_is_cartesian_2cell_sfib.
      - use invertible_is_cartesian_2cell_sfib.
        is_iso.
        apply property_from_invertible_2cell.
      - rewrite comp_sfib_cleaving_cell_over_f.
        use vcomp_is_cartesian_2cell_sfib.
        + use invertible_is_cartesian_2cell_sfib.
          apply property_from_invertible_2cell.
        + apply comp_sfib_cleaving_cell_g_cartesian.
    Defined.
  End FromCompCartesian.

  Definition comp_lwhisker_is_cartesian
    : lwhisker_is_cartesian (f · g).
  Proof.
    intros x y h k₁ k₂ γ Hγ.
    use to_is_cartesian_2cell_comp.
    - apply (pr2 Hf).
      exact (from_is_cartesian_2cell_comp _ Hγ).
    - assert (((h ◃ γ) ▹ f) • rassociator _ _ _
              =
              rassociator _ _ _ • (h ◃ (γ ▹ f)))
        as r.
      {
        abstract
          (rewrite rwhisker_lwhisker_rassociator ;
           apply idpath).
      }
      refine (is_cartesian_2cell_sfib_postcomp
                _
                ((h ◃ γ) ▹ f)
                _ _
                r).
      + apply invertible_is_cartesian_2cell_sfib.
        is_iso.
      + use vcomp_is_cartesian_2cell_sfib.
        * apply invertible_is_cartesian_2cell_sfib.
          is_iso.
        * apply Hg.
          apply from_is_cartesian_2cell_comp_rwhisker.
          exact Hγ.
  Defined.

  Definition comp_sfib
    : internal_sfib (f · g).
  Proof.
    split.
    - exact comp_sfib_cleaving.
    - exact comp_lwhisker_is_cartesian.
  Defined.
End CompositionOfSFib.

Definition comp_mor_preserves_cartesian
           {B : bicat}
           {x y z : B}
           {f : x --> y}
           (Hf : internal_sfib f)
           {g : y --> z}
           (Hg : internal_sfib g)
  : mor_preserves_cartesian (f · g) g f.
Proof.
  intros w h₁ h₂ γ Hγ.
  apply from_is_cartesian_2cell_comp_rwhisker.
  - exact Hf.
  - exact Hg.
  - exact Hγ.
Defined.

(**
 8. Composition of Street opfibrations
 *)
Definition from_is_opcartesian_2cell_comp_rwhisker
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           (Hf : internal_sopfib f)
           {g : b --> c}
           (Hg : internal_sopfib g)
           {z : B}
           {h₁ h₂ : z --> a}
           {α : h₁ ==> h₂}
           (Hα : is_opcartesian_2cell_sopfib (f · g) α)
  : is_opcartesian_2cell_sopfib g (α ▹ f).
Proof.
  use is_cartesian_to_is_opcartesian_sfib.
  use from_is_cartesian_2cell_comp_rwhisker.
  - apply internal_sopfib_is_internal_sfib.
    exact Hf.
  - apply internal_sopfib_is_internal_sfib.
    exact Hg.
  - use is_opcartesian_to_is_cartesian_sfib.
    exact Hα.
Defined.

Definition comp_sopfib
           {B : bicat}
           {a b c : B}
           {f : a --> b}
           {g : b --> c}
           (Hf : internal_sopfib f)
           (Hg : internal_sopfib g)
  : internal_sopfib (f · g).
Proof.
  apply internal_sfib_is_internal_sopfib.
  use comp_sfib.
  - apply internal_sopfib_is_internal_sfib.
    exact Hf.
  - apply internal_sopfib_is_internal_sfib.
    exact Hg.
Defined.

Definition comp_mor_preserves_opcartesian
           {B : bicat}
           {x y z : B}
           {f : x --> y}
           (Hf : internal_sopfib f)
           {g : y --> z}
           (Hg : internal_sopfib g)
  : mor_preserves_opcartesian (f · g) g f.
Proof.
  intros w h₁ h₂ γ Hγ.
  apply from_is_opcartesian_2cell_comp_rwhisker.
  - exact Hf.
  - exact Hg.
  - exact Hγ.
Defined.

(**
 9. Composition of adjunctions
 *)
Section CompositionAdjunction.
  Context {B : bicat}
          {x y z : B}
          (l₁ : x --> y)
          (l₂ : y --> z)
          (Hl₁ : left_adjoint l₁)
          (Hl₂ : left_adjoint l₂).

  Let r₁ : y --> x := left_adjoint_right_adjoint Hl₁.
  Let η₁ : id₁ x ==> l₁ · r₁ := left_adjoint_unit Hl₁.
  Let ε₁ : r₁ · l₁ ==> id₁ y := left_adjoint_counit Hl₁.

  Let r₂ : z --> y := left_adjoint_right_adjoint Hl₂.
  Let η₂ : id₁ y ==> l₂ · r₂ := left_adjoint_unit Hl₂.
  Let ε₂ : r₂ · l₂ ==> id₁ z := left_adjoint_counit Hl₂.

  Let ηη : id₁ x ==> l₁ · l₂ · (r₂ · r₁)
      := η₁
         • (_ ◃ (linvunitor _ • (η₂ ▹ _) • rassociator _ _ _))
         • lassociator _ _ _.

  Let εε : r₂ · r₁ · (l₁ · l₂) ==> id₁ z
      := rassociator _ _ _
         • (_ ◃ (lassociator _ _ _ • (ε₁ ▹ _) • lunitor _))
         • ε₂.

  Let trl₁ : linvunitor _ • (η₁ ▹ _) • rassociator _ _ _ • (_ ◃ ε₁) • runitor _ = id₂ _
      := pr12 Hl₁.
  Let trl₂ : linvunitor _ • (η₂ ▹ _) • rassociator _ _ _ • (_ ◃ ε₂) • runitor _ = id₂ _
      := pr12 Hl₂.

  Let trr₁ : rinvunitor _ • (_ ◃ η₁) • lassociator _ _ _ • (ε₁ ▹ _) • lunitor _ = id₂ _
      := pr22 Hl₁.
  Let trr₂ : rinvunitor _ • (_ ◃ η₂) • lassociator _ _ _ • (ε₂ ▹ _) • lunitor _ = id₂ _
      := pr22 Hl₂.

  Definition comp_left_adjoint_data
    : left_adjoint_data (l₁ · l₂)
    := r₂ · r₁ ,, (ηη ,, εε).

  Proposition comp_left_adjoint_axioms
    : left_adjoint_axioms comp_left_adjoint_data.
  Proof.
    split ; cbn.
    - unfold ηη, εε.
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      rewrite linvunitor_assoc.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply idpath.
      }
      refine (_ @ id2_rwhisker _ _).
      rewrite <- trl₁.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      do 2 apply maponpaths.
      refine (_ @ id2_right _).
      rewrite <- lwhisker_id2.
      rewrite <- trl₂.
      rewrite <- !lwhisker_vcomp.
      rewrite <- runitor_triangle.
      etrans.
      {
        do 10 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        apply idpath.
      }
      etrans.
      {
        do 9 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        apply idpath.
      }
      etrans.
      {
        do 8 apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !lwhisker_vcomp.
        apply idpath.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        do 6 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- lwhisker_lwhisker_rassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker_rassociator.
        apply idpath.
      }
      rewrite !vassocl.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite <- rassociator_rassociator.
        apply idpath.
      }
      rewrite !vassocl.
      etrans.
      {
        do 4 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_left.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <- rwhisker_lwhisker_rassociator.
          rewrite !vassocl.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !lwhisker_vcomp.
        apply maponpaths.
        rewrite <- !lwhisker_vcomp.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite rassociator_rassociator.
          rewrite !vassocl.
          apply maponpaths.
          rewrite !lwhisker_vcomp.
          rewrite lwhisker_lwhisker_rassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rwhisker_rwhisker_alt.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite vcomp_whisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rassociator_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite rwhisker_vcomp.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite !lwhisker_vcomp.
        rewrite <- rassociator_rassociator.
        rewrite !vassocl.
        rewrite !lwhisker_vcomp.
        rewrite !vassocr.
        rewrite rassociator_lassociator.
        rewrite id2_left.
        rewrite <- !lwhisker_vcomp.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply idpath.
      }
      etrans.
      {
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lwhisker_vcomp.
        rewrite <- linvunitor_assoc.
        rewrite <- rwhisker_lwhisker_rassociator.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !lwhisker_vcomp.
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite <- lwhisker_vcomp.
          rewrite !vassocr.
          rewrite rwhisker_lwhisker_rassociator.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lwhisker_hcomp.
        rewrite <- linvunitor_natural.
        apply idpath.
      }
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocr.
      rewrite rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lwhisker_vcomp.
        rewrite lunitor_V_id_is_left_unit_V_id.
        rewrite rwhisker_hcomp.
        rewrite <- triangle_r_inv.
        rewrite <- lwhisker_hcomp.
        rewrite !lwhisker_vcomp.
        rewrite linvunitor_lunitor.
        rewrite !lwhisker_id2.
        apply idpath.
      }
      rewrite id2_right.
      use vcomp_move_L_Mp ; [ is_iso | ].
      cbn.
      rewrite lunitor_lwhisker.
      apply idpath.
    - unfold εε, ηη.
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      rewrite !vassocl.
      rewrite <- rinvunitor_triangle.
      rewrite !vassocl.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      refine (_ @ lwhisker_id2 _ _).
      rewrite <- trr₁.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      do 2 apply maponpaths.
      refine (_ @ id2_right _).
      rewrite <- id2_rwhisker.
      rewrite <- trr₂.
      rewrite <- !rwhisker_vcomp.
      rewrite <- lunitor_triangle.
      rewrite !vassocl.
      etrans.
      {
        do 9 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          rewrite !vassocr.
          rewrite <-  rwhisker_rwhisker.
          apply idpath.
        }
        rewrite !vassocr.
        rewrite <-  rwhisker_rwhisker.
        apply idpath.
      }
      rewrite !vassocr.
      do 2 apply maponpaths_2.
      rewrite !vassocl.
      etrans.
      {
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- lassociator_lassociator.
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_vcomp.
        rewrite lassociator_rassociator.
        rewrite id2_rwhisker.
        rewrite id2_left.
        apply idpath.
      }
      rewrite !vassocl.
      etrans.
      {
        do 5 apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        apply maponpaths.
        rewrite rwhisker_rwhisker.
        rewrite !vassocr.
        rewrite <- rwhisker_lwhisker.
        rewrite !vassocl.
        rewrite <- lassociator_lassociator.
        apply idpath.
      }
      rewrite !vassocr.
      apply maponpaths_2.
      rewrite !lwhisker_vcomp.
      rewrite !vassocl.
      use vcomp_move_R_Mp ; [ is_iso | ].
      cbn.
      rewrite !vassocl.
      rewrite <- rwhisker_lwhisker_rassociator.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_hcomp.
        rewrite <- triangle_r_inv.
        rewrite <- lwhisker_hcomp.
        apply idpath.
      }
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      etrans.
      {
        rewrite !vassocl.
        do 2 apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_linvunitor.
        apply id2_left.
      }
      refine (!_).
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        do 3 apply maponpaths.
        rewrite !vassocr.
        rewrite lassociator_lassociator.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite !lwhisker_vcomp.
      rewrite lwhisker_lwhisker.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite rwhisker_rwhisker.
        rewrite !vassocl.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite <- vcomp_whisker.
      rewrite !vassocl.
      apply maponpaths.
      etrans.
      {
        apply maponpaths.
        rewrite !vassocr.
        rewrite lunitor_triangle.
        apply idpath.
      }
      rewrite !vassocr.
      rewrite vcomp_lunitor.
      rewrite !vassocl.
      rewrite rassociator_lassociator.
      rewrite id2_right.
      rewrite !vassocr.
      rewrite lunitor_linvunitor.
      apply id2_left.
  Qed.

  Definition comp_left_adjoint
    : left_adjoint (l₁ · l₂)
    := comp_left_adjoint_data ,, comp_left_adjoint_axioms.
End CompositionAdjunction.


From Hammer Require Import Hammer.

Require Import RIneq.

Section Arithmetical_dec.

Variable P : nat -> Prop.
Hypothesis HP : forall n, {P n} + {~P n}.

Lemma sig_forall_dec : {n | ~P n} + {forall n, P n}.
Proof. hammer_hook "Rlogic" "Rlogic.sig_forall_dec".
assert (Hi: (forall n, 0 < INR n + 1)%R).
intros n.
apply Rle_lt_0_plus_1, pos_INR.
set (u n := (if HP n then 0 else / (INR n + 1))%R).
assert (Bu: forall n, (u n <= 1)%R).
intros n.
unfold u.
case HP ; intros _.
apply Rle_0_1.
rewrite <- S_INR, <- Rinv_1.
apply Rinv_le_contravar with (1 := Rlt_0_1).
apply (le_INR 1), le_n_S, le_0_n.
set (E y := exists n, y = u n).
destruct (completeness E) as [l [ub lub]].
exists R1.
intros y [n ->].
apply Bu.
exists (u O).
now exists O.
assert (Hnp: forall n, not (P n) -> ((/ (INR n + 1) <= l)%R)).
intros n Hp.
apply ub.
exists n.
unfold u.
now destruct (HP n).
destruct (Rle_lt_dec l 0) as [Hl|Hl].
right.
intros n.
destruct (HP n) as [H|H].
exact H.
exfalso.
apply Rle_not_lt with (1 := Hl).
apply Rlt_le_trans with (/ (INR n + 1))%R.
now apply Rinv_0_lt_compat.
now apply Hnp.
left.
set (N := Zabs_nat (up (/l) - 2)).
assert (H1l: (1 <= /l)%R).
rewrite <- Rinv_1.
apply Rinv_le_contravar with (1 := Hl).
apply lub.
now intros y [m ->].
assert (HN: (INR N + 1 = IZR (up (/ l)) - 1)%R).
unfold N.
rewrite INR_IZR_INZ.
rewrite inj_Zabs_nat.
replace (IZR (up (/ l)) - 1)%R with (IZR (up (/ l) - 2) + 1)%R.
apply (f_equal (fun v => IZR v + 1)%R).
apply Zabs_eq.
apply Zle_minus_le_0.
apply (Zlt_le_succ 1).
apply lt_IZR.
apply Rle_lt_trans with (1 := H1l).
apply archimed.
rewrite minus_IZR.
simpl.
ring.
assert (Hl': (/ (INR (S N) + 1) < l)%R).
rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
apply Rinv_1_lt_contravar with (1 := H1l).
rewrite S_INR.
rewrite HN.
ring_simplify.
apply archimed.
exists N.
intros H.
apply Rle_not_lt with (2 := Hl').
apply lub.
intros y [n ->].
unfold u.
destruct (HP n) as [_|Hp].
apply Rlt_le.
now apply Rinv_0_lt_compat.
apply Rinv_le_contravar.
apply Hi.
apply Rplus_le_compat_r.
apply le_INR.
destruct (le_or_lt n N) as [Hn|Hn].
2: now apply lt_le_S.
exfalso.
destruct (le_lt_or_eq _ _ Hn) as [Hn'| ->].
2: now apply Hp.
apply Rlt_not_le with (2 := Hnp _ Hp).
rewrite <- (Rinv_involutive l) by now apply Rgt_not_eq.
apply Rinv_1_lt_contravar.
rewrite <- S_INR.
apply (le_INR 1), le_n_S, le_0_n.
apply Rlt_le_trans with (INR N + 1)%R.
apply Rplus_lt_compat_r.
now apply lt_INR.
rewrite HN.
apply Rplus_le_reg_r with (-/l + 1)%R.
ring_simplify.
apply archimed.
Qed.

End Arithmetical_dec.

Theorem not_not_archimedean :
forall r : R, ~ (forall n : nat, (INR n <= r)%R).
Proof. hammer_hook "Rlogic" "Rlogic.not_not_archimedean".
intros r H.
set (E := fun r => exists n : nat, r = INR n).
assert (exists x : R, E x) by
(exists 0%R; simpl; red; exists 0%nat; reflexivity).
assert (bound E) by (exists r; intros x (m,H2); rewrite H2; apply H).
destruct (completeness E) as (M,(H3,H4)); try assumption.
set (M' := (M + -1)%R).
assert (H2 : ~ is_upper_bound E M').
intro H5.
assert (M <= M')%R by (apply H4; exact H5).
apply (Rlt_not_le M M').
unfold M'.
pattern M at 2.
rewrite <- Rplus_0_l.
pattern (0 + M)%R.
rewrite Rplus_comm.
rewrite <- (Rplus_opp_r 1).
apply Rplus_lt_compat_l.
rewrite Rplus_comm.
apply Rlt_plus_1.
assumption.
apply H2.
intros N (n,H7).
rewrite H7.
unfold M'.
assert (H5 : (INR (S n) <= M)%R) by (apply H3; exists (S n); reflexivity).
rewrite S_INR in H5.
assert (H6 : (INR n + 1 + -1 <= M + -1)%R).
apply Rplus_le_compat_r.
assumption.
rewrite Rplus_assoc in H6.
rewrite Rplus_opp_r in H6.
rewrite (Rplus_comm (INR n) 0) in H6.
rewrite Rplus_0_l in H6.
assumption.
Qed.

Lemma sig_not_dec : forall P : Prop, {not (not P)} + {not P}.
Proof. hammer_hook "Rlogic" "Rlogic.sig_not_dec".
intros P.
set (E := fun x => x = R0 \/ (x = R1 /\ P)).
destruct (completeness E) as [x H].
exists R1.
intros x [->|[-> _]].
apply Rle_0_1.
apply Rle_refl.
exists R0.
now left.
destruct (Rle_lt_dec 1 x) as [H'|H'].
- left.
intros HP.
elim Rle_not_lt with (1 := H').
apply Rle_lt_trans with (2 := Rlt_0_1).
apply H.
intros y [->|[_ Hy]].
apply Rle_refl.
now elim HP.
- right.
intros HP.
apply Rlt_not_le with (1 := H').
apply H.
right.
now split.
Qed.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Set Automatic Coercions Import.
Require Export PredomAll.

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

(*Section Utils.

Lemma lem00 D (x y : D _BOT) :
  (forall n, pred_nth x n = pred_nth y n) -> x =-= y.
Proof.
move => H. split => /=.
- apply: DLless_cond => d Ex.
  elim: (eqValpred Ex) => k [d' [Hx e]].
  have Hy : pred_nth y k = Val d' by rewrite -H.
  have Ey : y =-= Val d' by rewrite -Hy pred_nth_eq.
  rewrite Ex Ey. by apply: Val_le_compat; auto.
- apply: DLless_cond => d Ey.
  elim: (eqValpred Ey) => k [d' [Hy e]].
  have Hx : pred_nth x k = Val d' by rewrite H.
  have Ex : x =-= Val d' by rewrite -Hx pred_nth_eq.
  rewrite Ex Ey. by apply: Val_le_compat; auto.
Qed.

Lemma pred_nth_bot (A : cpoType) :
  forall n, pred_nth (PBot : A _BOT) n = PBot.
elim => [//= | n IH].
change (pred_nth (DL_bot A) n.+1 = PBot).
by rewrite DL_bot_eq /=.
Qed.

End Utils.*)

Lemma forallEps_eq_bot D (x : D _BOT) :
  (forall n, exists s, pred_nth x n = Eps s) -> x =-= PBot.
Proof.
move => H. split => /=; last by apply: leastP.
apply: DLless_cond => d Ex.
elim: (eqValpred Ex) => {d Ex} k [d' [Hx _]].
elim: (H k) => s. by rewrite Hx.
Qed.

Require Import Classical.

(* non-constructive axiom *)
Lemma axiom_liftCpo_dec D (x : D _BOT) :
  x =-= PBot \/ exists d, x =-= Val d.
Proof.
elim: (classic (forall n, exists s, pred_nth x n = Eps s)) => H.
- left. by apply: forallEps_eq_bot.
- right.
  have H1 := not_all_ex_not _ _ H.
  elim: H1 => {H} k H.
  elim: (isEps_dec (pred_nth x k)) => [[d Ex] | Hnot].
  - exists d. by rewrite -Ex pred_nth_eq.
  - destruct (pred_nth x k) => //.
    by have H1 : exists s0, Eps s = Eps s0 by eauto.
Qed.

Section Mu1.
Variable A : cpoType.
Variable B : cppoType.
Variable f : A =-> B.

Definition chainF (s : A _BOT) : natO -> B
  := fun n =>
       match (pred_nth s n) with
         | Eps s => PBot
         | Val d => f d
       end.

Lemma chainF_mono s : monotonic (chainF s).
move => n m H.
rewrite /chainF.
case E : (pred_nth s n) => [sn | d].
- by apply: leastP.
- rewrite natO_le in H.
  have H1 := subnKC H. move/eqP : H1 => H1. rewrite eq_sym in H1.
  by rewrite (pred_nth_comp _ H1) E pred_nth_val.
Qed.

Definition ChainF (s : A _BOT) := Eval hnf in mk_fmono (@chainF_mono s).

Definition ChainF_lub (s : A _BOT) := lub (ChainF s).

Lemma ChainF_lub_bot (s : A _BOT) :
  s =-= PBot -> lub (ChainF s) =-= PBot.
Proof.
move => e. split; last by apply: leastP.
apply: lub_le => n /=.
rewrite /chainF.
elim: (isEps_dec (pred_nth s n)) => [[d P] | H].
- move: e => [le _]. rewrite /= in le.
  have H : DLle (Val d) s by apply: (DLleVal P).
  have Hfalse : DLle (Val d) PBot by apply: (Ole_trans H).
  by elim: (PBot_incon Hfalse).
- rewrite /isEps in H. by destruct (pred_nth s n).
Qed.

Lemma pred_nth_ChainF_lub (s : A _BOT) d n :
  pred_nth s n = Val d -> ChainF_lub s =-= f d.
Proof.
move => H.
rewrite /ChainF /= /chainF in H.
have H1 : mseq_lift_left (ChainF s) n =-= fmon_cte _ (f d).
  apply: fmon_eq_intro => m /=.
  rewrite /chainF. by rewrite pred_nth_sum H pred_nth_val.
rewrite /ChainF_lub. rewrite (lub_lift_left _ n). rewrite H1. by apply: lub_const.
Qed.

Lemma ChainF_lub_Val (s : A _BOT) d :
  s =-= Val d -> lub (ChainF s) =-= f d.
Proof.
move => e.
elim: (eqValpred e) => [n [d' [Hn Hdd']]].
have e' : s =-= Val d'
  by apply: (Oeq_trans e); apply: Val_eq_compat.
rewrite Hdd' => {e Hdd' d}. rename d' into d.
by apply: (pred_nth_ChainF_lub Hn).
Qed.

Lemma ChainF_lub_mono : monotonic (ChainF_lub).
Proof.
move => s1 s2 Hle.
rewrite /ChainF_lub.
case: (axiom_liftCpo_dec s1) => [e1 | [d1 e1]]. (* non-constructive step! *)
- rewrite (ChainF_lub_bot e1). by apply: leastP.
- case: (axiom_liftCpo_dec s2) => [e2 | [d2 e2]]. (* non-constructive step! *)
  + have Hfalse : DLle (Val d1) PBot.
      rewrite -e1 /=. apply: (Ole_trans Hle). by elim: e2.
    by elim: (PBot_incon Hfalse).
  + rewrite (ChainF_lub_Val e1). rewrite (ChainF_lub_Val e2).
    apply: fmonotonic. apply: DLleVal_leq.
    elim: e1 => _ e1. elim: e2 => e2 _.
    apply: (Ole_trans e1). by apply: (Ole_trans Hle).
Qed.

Definition ChainF_lub_mon := Eval hnf in mk_fmono (@ChainF_lub_mono).

Lemma lem01 D (c : natO =-> D _BOT) d (Hlubc : lub c =-= Val d) :
  exists k, exists dk,
    c k =-= Val dk /\ dk <= d /\
    exists c' : natO =-> D _BOT,
      c' = mseq_lift_left c k /\
      lub c' =-= Val d /\
      (forall i, exists d', c' i =-= Val d' /\
        dk <= d' /\ d' <= d) /\
      exists dc : natO =-> D,
        lub dc =-= d /\
        forall i, c' i =-= Val (dc i).
Proof.
elim: (lubval Hlubc) => k [dk [Hdk le]].
exists k. exists dk. split; [ | split] => //.
pose c' := mseq_lift_left c k. exists c'. split => //.
have Hlubc' : lub c' =-= Val d
  by rewrite /c' -lub_lift_left Hlubc.
split => //.
have H :
  forall i, exists d', c' i =-= Val d' /\ dk <= d' /\ d' <= d.
  move => i. rewrite /c' /mseq_lift_left /=.
  elim: (allvalsfromhere i Hdk) => d' [Hd' le'].
  exists d'. split; [ | split] => //.
  apply: vleinj. rewrite -Hd' -Hlubc'.
  change (c' i <= lub c'). by apply: le_lub.
split => //.
elim: (DLvalgetchain Hdk) => [dc Hdc].
exists dc.
split => //.
apply: vinj. change (eta (lub dc) =-= Val d).
rewrite lub_comp_eq. rewrite -Hlubc'.
apply: lub_eq_compat. apply: fmon_eq_intro => n /=.
by rewrite Hdc.
Qed.

Lemma ChainF_lub_cont : continuous (ChainF_lub_mon).
Proof.
move => c /=. rewrite /ChainF_lub.
case: (axiom_liftCpo_dec (lub c)) => [e | [d e]]. (* non-constructive step! *)
- rewrite (ChainF_lub_bot e). by apply: leastP.
- rewrite (ChainF_lub_Val e).
  elim: (lem01 e) => [k [dk [Hdk [ledk [c' [Hdefc' [Hlubc' [Hc' [dc [Hlubdc Hdc]]]]]]]]]].
  rewrite (lub_lift_left _ k).
  have H : mseq_lift_left (ChainF_lub_mon << c) k =-= (f : fmono _ _) << dc.
    apply: fmon_eq_intro => n /=.
    suff : (ChainF_lub (c' n) =-= f (dc n)); first by rewrite Hdefc'.
    by apply: (Oeq_trans (ChainF_lub_Val (Hdc n))).
  rewrite H => {H}.
  rewrite -lub_comp_eq. by rewrite Hlubdc.
Qed.

Definition mu1aux := Eval hnf in mk_fcont (@ChainF_lub_cont).
Definition mu1 := locked mu1aux.

Lemma mu1axiom1 : mu1 PBot =-= PBot.
Proof.
unlock mu1. rewrite /= /ChainF_lub.
by rewrite ChainF_lub_bot => //.
Qed.

Lemma mu1axiom2 d : mu1 (Val d) =-= f d.
Proof.
unlock mu1. rewrite /= /ChainF_lub.
by rewrite ChainF_lub_Val => //.
Qed.

End Mu1.


From Undecidability Require Import L.Prelim.MoreBase.

Require Import smpl.Smpl.
Require Export Lia Arith Ring.

From Coq Require Import Setoid.
From Coq Require Import CRelationClasses CMorphisms.
Import CMorphisms.ProperNotations.
From Undecidability.Shared.Libs.PSL Require FinTypes.

Record leUpToC {X} (f g : X -> nat) : Type :=
  { c__leUpToC : nat;
    correct__leUpToC : forall x, f x <= c__leUpToC * g x
  }.

Arguments c__leUpToC {_ _ _ H} : rename.

Notation "f <=c g" := (@leUpToC _ f g) (at level 70, g at next level).

#[global]
Instance leUpToC_preorder X: PreOrder (@leUpToC X).
Proof.
  split.
  -exists 1. intros. lia.
  -hnf. intros ? ? ? [c Hc] [c' Hc']. exists (c*c'). intros. rewrite Hc,Hc'. nia.
Qed.

#[global]
Instance leUpToC_proper_eq X: Proper (Morphisms.pointwise_relation X eq ==> Morphisms.pointwise_relation X eq ==> arrow) (@leUpToC X).
Proof.
  intros ? ? H ? ? H0 H1. cbv - [iff] in *. destruct H1. eexists. intro. rewrite <-H, <- H0. easy.
Qed.

#[global]
Instance leUpToC_proper_eq_flip X: Proper (Morphisms.pointwise_relation X eq ==> Morphisms.pointwise_relation X eq ==> flip arrow) (@leUpToC X).
Proof.
  intros ? ? H ? ? H0 H1. cbv - [iff] in *. destruct H1. eexists. intro. rewrite H, H0. easy.
Qed.

#[global]
Instance le_leUpToC_subrelation X: subrelation (pointwise_relation X le) leUpToC.
Proof.
  intros ? ? H. exists 1. intros. hnf in H. setoid_rewrite H. nia.
Qed.

#[global]
Instance eq_leUpToC_subrelation X: subrelation (pointwise_relation X eq) leUpToC.
Proof.
  intros ? ? H. exists 1. hnf in H. setoid_rewrite H. intros;nia.
Qed.

(* A record for easily expressing the subtype of functions up to some multiplicative constant. *)
Record UpToC {X} (F : X -> nat) : Type :=
  mkUpToC
  {
    f__UpToC :> X -> nat;
    correct__UpToC :> f__UpToC <=c F
  }.

Add Printing Coercion f__UpToC.
Arguments f__UpToC : clear implicits.
Arguments f__UpToC {_} _ {_}.

Lemma UpToC_le X F (f : @UpToC X F) :
  (forall x, f x <= (c__leUpToC (H:=f))*F x).
Proof.
  destruct f as [? []];cbn. easy.
Qed.

Lemma upToC_add X (F f1 f2 :X->nat) :
  f1 <=c F
  -> f2 <=c F
  -> (fun x => f1 x + f2 x) <=c F.
Proof.
  intros [c H] [c' H'].
  exists (c+c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_max X (F f1 f2 :X->nat) :
  f1 <=c F
  -> f2 <=c F
  -> (fun x => max (f1 x) (f2 x)) <=c F.
Proof.
  intros [c H] [c' H'].
  exists (c+c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_min X (F f1 f2 :X->nat) :
  f1 <=c F
  -> f2 <=c F
  -> (fun x => min (f1 x) (f2 x)) <=c F.
Proof.
  intros [c H] [c' H'].
  exists (c+c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_mul_c_l X c (f F : X -> nat):
  f <=c F -> (fun x => c * f x) <=c F.
Proof.
  intros (c'&H). exists (c'*c). intros. rewrite H. nia.
Qed.

Lemma upToC_mul_c_r X c (f F : X -> nat):
  f <=c F -> (fun x => f x * c) <=c F.
Proof.
  intros (c'&H). exists (c'*c). intros. rewrite H. nia.
Qed.

Lemma upToC_c X c (F : X -> nat):
  (fun _ => 1) <=c F ->
  (fun _ => c ) <=c F.
Proof.
  intros H'.
  assert (H:c<= 1*c) by lia.
  setoid_rewrite H. eapply upToC_mul_c_r. easy.
Qed.

Lemma upToC_S X (F f :X->nat) :
  (fun _ => 1) <=c F
  -> f <=c F
  -> (fun x => S (f x)) <=c F.
Proof.
  intros. apply upToC_add with (f1:=(fun _ => 1)). 2:easy. now apply upToC_c.
Qed.

Lemma upToC_mul X (F1 F2 f1 f2 :X->nat) :
  f1 <=c F1
  -> f2 <=c F2
  -> (fun x => f1 x * f2 x) <=c (fun x => F1 x * F2 x).
Proof.
  intros [c H] [c' H'].
  exists (c*c'). intro. rewrite H,H'. all:nia.
Qed.

Lemma upToC_pow_r_drop X c (f F : X -> nat):
  0 < c -> f <=c F -> f <=c (fun x => F x ^ c).
Proof.
  intros ? (c'&Hc'). exists c'. intros x. decide (F x = 0) as [H'|H'].
  { rewrite Hc',H'. nia. }
  rewrite <- (Nat.pow_le_mono_r) with (b:=1). 2,3:nia. cbn. rewrite Hc'. nia.
Qed.

Lemma upToC_pow_le_compat X c c' (f f' : X -> nat):
  0 < c -> c <= c' -> f <=c f' -> (fun x => f x ^ c)<=c (fun x => f' x ^ c').
Proof.
  intros ? ? (c''&Hc'). exists (c''^c). intros x. decide (f' x = 0) as [H'|H'].
  { rewrite Hc',H'. rewrite Nat.mul_0_r. destruct c; cbn;nia. }
  { setoid_rewrite <- (Nat.pow_le_mono_r) with (b:=c). 2,3:nia.
    rewrite Hc'. rewrite Nat.pow_mul_l. nia.
  }
Qed.

Tactic Notation  "_applyIfNotConst_nat" tactic(t):=
  once (match goal with
        | |- ?R (fun x => ?c) _ =>  tryif let b := isnatcst c in unify b true then fail 1 else t
        end).

Lemma upToC_le X f (F : X -> nat):
  (forall x, f x <= F x)
  -> f <=c F.
Proof.
  intros H'. change f with (fun x => f x). setoid_rewrite H'. reflexivity.
Qed.

Lemma upToC_f__UpToC X (F G: X -> nat) (H : UpToC G):
  G <=c F
  -> H <=c F.
Proof.
  now rewrite correct__UpToC.
Qed.

Smpl Create upToC.

Smpl Add 2 assumption : upToC.
Smpl Add 5 first [simple apply upToC_add | simple apply upToC_mul_c_l | simple apply upToC_mul_c_r
                  | simple apply upToC_max | simple apply upToC_min
                  | progress (simple apply upToC_c)
                 | _applyIfNotConst_nat (simple apply upToC_S)] : upToC.
Smpl Add 4 simple eapply upToC_f__UpToC : upToC.

Ltac smpl_upToC := repeat smpl upToC.

Ltac upToC_le_solve := apply upToC_le;intros ?;nia.

Smpl Create upToC_solve.
Smpl Add upToC_le_solve : upToC_solve.

Ltac smpl_upToC_solve := solve [repeat (smpl upToC);repeat (smpl upToC_solve)].

Tactic Notation "exists_UpToC" uconstr(f) :=
  unshelve (eexists (mkUpToC (f__UpToC:=f) _));cycle 1;[unfold f__UpToC| ].

Tactic Notation "eexists_UpToC" ident(f) :=
        match goal with
          |- ?Ex (@UpToC ?X ?F) ?P =>
          evar (f : X -> nat);exists_UpToC f
        end.

Goal (fun x => S x) <=c (fun x => x + 1).
Proof.
  timeout 3 (smpl_upToC_solve). (* If this times out, most likely the upToC_S hint is applied wrongly. *)
Qed.

(* Tests *)
Goal ( { f : UpToC (fun x => x + 1) | forall x, 3 * x + 10 <= f x}).
Proof.
  eexists_UpToC f.
  - [f]:intros x. unfold f. reflexivity.
  - unfold f. smpl_upToC_solve.
Qed.

From Coq Require Strings.String.

Section bla.
  Import FinTypes.
  Lemma leUpToC_finCases X (Y:finType) Z__case (cases : forall (y:Y), Z__case y -> X) (f F : X -> nat) :
  (forall x, exists y (z : Z__case y), cases y z = x)
  -> (forall y, (fun z => f (cases y z)) <=c (fun z => F (cases y z)))
  -> f <=c F.
Proof.
  intros Hinj Hcase. exists (maxl (map (fun y => c__leUpToC (H:=Hcase y)) (elem Y))).
  intros x. specialize (Hinj x) as (y&z&<-).
  specialize @correct__leUpToC with (l:=Hcase y) as H'.
  erewrite <- maxl_leq. now apply H'.
  rewrite in_map_iff. do 2 eexists. easy. apply elem_spec.
Qed.
End bla.


Require Import MyTactics.
Require Import DCSyntax.

(* This technical lemma states that the renaming [lift 1] is injective. *)

Lemma lift_inj_Var:
  forall t x,
  lift 1 t = Var (S x) <-> t = Var x.
Proof.
  split; intros.
  { eauto using lift_inj. }
  { subst. eauto. }
Qed.

(* -------------------------------------------------------------------------- *)

(* The predicate [fv] is characterized by the following lemmas. *)

Lemma fv_Var_eq:
  forall k x,
  fv k (Var x) <-> x < k.
Proof.
  unfold fv. asimpl. induction k; intros.
  (* Base case. *)
  { asimpl. split; intros; false.
    { unfold ids, Ids_term in *. injections.
      (* In Coq 8.12, this goal is solved by [lia], but not in Coq 8.10. *)
      eapply Nat.neq_succ_diag_l. eauto. }
    { lia. }
  }
  (* Step. *)
  { destruct x; asimpl.
    { split; intros. { lia. } { reflexivity. } }
    rewrite lift_inj_Var. rewrite IHk. lia. }
Qed.

Lemma fv_Lam_eq:
  forall k t,
  fv k (Lam t) <-> fv (S k) t.
Proof.
  unfold fv. intros. asimpl. split; intros.
  { injections. eauto. }
  { unpack. congruence. }
Qed.

Lemma fv_App_eq:
  forall k t1 t2,
  fv k (App t1 t2) <-> fv k t1 /\ fv k t2.
Proof.
  unfold fv. intros. asimpl. split; intros.
  { injections. eauto. }
  { unpack. congruence. }
Qed.

Lemma fv_Let_eq:
  forall k t1 t2,
  fv k (Let t1 t2) <-> fv k t1 /\ fv (S k) t2.
Proof.
  unfold fv. intros. asimpl. split; intros.
  { injections. eauto. }
  { unpack. congruence. }
Qed.

Lemma bidule {A}: forall (h1 h2: A) t1 t2,
  h1 = h2 -> t1 = t2 -> (cons h1 t1 = cons h2 t2).
Proof.
  intros; rewrite H; rewrite H0; reflexivity.
Qed.

Lemma thing: forall ts sigma,
  ts..[sigma] = ts <-> List.Forall (fun ti : term => ti.[sigma] = ti) ts.
Proof.
  induction ts.
  * split; intros; eauto.
  * split; intros; msimpl in *.
    - injections.
      econstructor; eauto.
      { apply IHts. eauto. }
    - inverts H.
      f_equal; [eauto | now eapply IHts].
Qed.

Lemma fv_Default_eq:
  forall k ts tj tc,
  fv k (Default ts tj tc) <->
    (List.Forall (fun ti => fv k ti) ts) /\ fv k tj /\ fv k tc.
Proof.
  unfold fv. intros. asimpl. split; intros.
  { injections. repeat split; eauto.
    { apply thing; assumption. }
  }
  { unpack. rewrite H0; rewrite H1.
    remember (thing ts (upn k (ren (+1)))).
    destruct i.
    remember (e H).
    rewrite e0.
    reflexivity. }
Qed.

Global Hint Rewrite fv_Var_eq fv_Lam_eq fv_App_eq fv_Let_eq fv_Default_eq : fv.

(* -------------------------------------------------------------------------- *)

(* The following lemmas allow decomposing a closedness hypothesis.
   Because [closed] is not an inductive notion, there is no lemma
   for [Lam] and for the right-hand side of [Let]. *)

Lemma closed_Var:
  forall x,
  closed (Var x) ->
  False.
Proof.
  unfold closed; intros; fv. lia.
Qed.

Lemma closed_AppL:
  forall t1 t2,
  closed (App t1 t2) ->
  closed t1.
Proof.
  unfold closed; intros; fv. tauto.
Qed.

Lemma closed_AppR:
  forall t1 t2,
  closed (App t1 t2) ->
  closed t2.
Proof.
  unfold closed; intros; fv. tauto.
Qed.

Lemma closed_LetL:
  forall t1 t2,
  closed (Let t1 t2) ->
  closed t1.
Proof.
  unfold closed; intros; fv. tauto.
Qed.

Lemma closed_DefaultJ:
  forall ts tj tc,
  closed (Default ts tj tc) ->
  closed tj.
Proof.
  unfold closed; intros; fv. tauto.
Qed.

Lemma closed_DefaultC:
  forall ts tj tc,
  closed (Default ts tj tc) ->
  closed tc.
Proof.
  unfold closed; intros; fv. tauto.
Qed.

Lemma closed_DefaultE:
  forall ts tj tc,
  closed (Default ts tj tc) ->
  List.Forall (fun ti => closed ti) ts.
Proof.
  unfold closed; intros; fv. tauto.
Qed.

Lemma closed_DefaultE0:
  forall ti ts tj tc,
  closed (Default (ti::ts) tj tc) ->
  closed ti.
Proof.
  unfold closed; intros; fv.
  destruct H as [H1 [H2 H3]].
  now invert H1.
Qed.

Lemma closed_DefaultEi:
  forall ts1 ti ts2 tj tc,
  closed (Default (ts1++ti::ts2) tj tc) ->
  closed ti.
Proof.
  unfold closed; intros; fv.
  destruct H as [H1 [H2 H3]].
  eapply List.Forall_elt; eauto.
Qed.

Lemma closed_DefaultEin:
  forall ti ts tj tc,
  List.In ti ts ->
  closed (Default ts tj tc) ->
  closed ti.
Proof.
  unfold closed; intros ti ts tj tc Hin H; fv.
  destruct H as [H1 [H2 H3]].
  eapply List.Forall_forall; eauto.
Qed.

Global Hint Resolve
  closed_Var
  closed_AppL
  closed_AppR
  closed_LetL
  closed_DefaultC
  closed_DefaultJ
  closed_DefaultE
  closed_DefaultE0
  closed_DefaultEi
  closed_DefaultEin
: closed.

(* -------------------------------------------------------------------------- *)

(* If the free variables of the term [t] are below [k], then [t] is unaffected
   by a substitution of the form [upn k sigma]. *)

Lemma fv_unaffected:
  forall t k sigma,
  fv k t ->
  t.[upn k sigma] = t.
Proof.
  induction t using term_ind'; intros; fv; unpack; asimpl;
  try solve [ eauto using upn_k_sigma_x with typeclass_instances
            | f_equal; eauto ].
  { f_equal; eauto using upn_k_sigma_x with typeclass_instances.
    { apply thing.
      induction ts; econstructor.
      * rename a into ti.
        inverts H0; inverts H.
        eauto.
      * inverts H0; inverts H.
        eapply IHts; eauto.
    }
  }
Qed.

(* If the term [t] is closed, then [t] is unaffected by any substitution. *)

Lemma closed_unaffected:
  forall t sigma,
  closed t ->
  t.[sigma] = t.
Proof.
  intros. eapply fv_unaffected with (k := 0). eauto.
Qed.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** Provides a tactic for proving the uniqueness of objects. *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.Eqdep_dec.

Require Import Coq.omega.Omega.

(* *********************************************************************** *)
(** * Auxiliary definitions *)

(** From a list of types, compute the type of a curried function whose
    arguments are those types. *)

Fixpoint arrow (xs : list Type) (res : Type) : Type :=
  match xs with
    | nil => res
    | cons y ys => y -> arrow ys res
  end.

(** From a list of types, compute the type of a heterogeneous list
    whose elements are of those types.  Heterogeneous lists are
    represented as nested tuples. *)

Fixpoint tuple (xs : list Type) : Type :=
  match xs with
    | nil => unit
    | cons y ys => (y * tuple ys)%type
  end.

(** Apply a curried function to a heterogeneous list of arguments. *)

Definition apply_tuple
  (xs : list Type) (res : Type) (f : arrow xs res) (arg : tuple xs)
  : res.
(* begin show *)
Proof.
  induction xs as [ | ? ? IH ]; simpl; intros res f arg.
  exact f.
  exact (IH res (f (fst arg)) (snd arg)).
Defined.
(* end show *)

(** Reverse a list onto the given accumulator.  Compared to
    [List.rev], this definition simplifies the implementation of
    heterogeneous list reversal (see below). *)

Fixpoint tr_list_rev (A : Type) (xs : list A) (acc : list A) : list A :=
  match xs with
    | nil => acc
    | cons y ys => tr_list_rev A ys (cons y acc)
  end.

Implicit Arguments tr_list_rev [ A ].

(** Reverse a list. *)

Definition list_rev (A : Type) (xs : list A) : list A :=
  tr_list_rev xs nil.

Implicit Arguments list_rev [ A ].

(** Reverse a heterogeneous list onto the given accumulator. *)

Definition tr_tuple_rev
  (xs : list Type) (ab : tuple xs)
  (acc : list Type) (acc' : tuple acc)
  : tuple (tr_list_rev xs acc).
(* begin show *)
Proof.
  induction xs as [ | ? ? IH ]; simpl; intros ab acc acc'.
  exact acc'.
  exact (IH (snd ab) (cons a acc) (fst ab, acc')).
Defined.
(* end show *)

(** Reverse a heterogenous list. *)

Definition tuple_rev
  (xs : list Type) (ab : tuple xs) : tuple (list_rev xs) :=
  tr_tuple_rev xs ab nil tt.

(* *********************************************************************** *)
(** * Auxiliary facts *)

(** This is the minimum set of facts about decidable equality that the
    [uniqueness] tactic (defined below) requires. *)

Lemma eq_unit_dec : forall (x y : unit),
  {x = y} + {x <> y}.
Proof. decide equality. Qed.

Lemma eq_pair_dec : forall (A B : Type),
  (forall x y : A, {x = y} + {x <> y}) ->
  (forall x y : B, {x = y} + {x <> y}) ->
  (forall x y : A * B, {x = y} + {x <> y}).
Proof. decide equality. Qed.

Hint Resolve eq_unit_dec eq_pair_dec : eq_dec.

(* *********************************************************************** *)
(** * Tactic for proving the uniqueness of objects *)

(** [uniqueness] analyzes goals of the form [C x1 .. xn = q] by
    destructing [q] using the [case] tactic.  It is mainly useful when
    [q] is an object of an indexed inductive type [Q], since it
    generalizes the goal such that [case] will succeed.  The argument
    should be the number of indices to [Q], and the indices should not
    depend on each other.

    Subgoals generated by the tactic will require one of three things:
    showing that the goal state is impossible, proving that equality
    at some type is decidable, and proving that any two objects of
    some type are equal.  The tactic [auto with eq_dec] is used to
    discharge subgoals of the second form.  The tactic [auto] is used
    to discharge subgoals of the third form. *)

Ltac uniqueness icount :=
  (** Expose the conclusion. *)
  intros;

  (** If the right hand side looks like a function application, flip
      the equality around.  This is merely so that the remainder of
      this tactic can assume that the goal is in a certain form. *)
  try (match goal with |- _ = ?f _ => symmetry end);

  (** Record the proof on the left hand side of the equality. *)
  let lhs := match goal with |- ?lhs = _ => constr:(lhs) end in

  (** Record the proof on the right hand side of the equality. *)
  let rhs := match goal with |- _ = ?rhs => constr:(rhs) end in

  (** Record the sort of the predicate. *)
  let sort := match type of rhs with
                | ?pred => match type of pred with ?sort => sort end
              end
  in

  (** Extract out the predicate applied only to its parameters.  We
      use the value of [icount] to determine the number of indices. *)
  let rec get_pred_type i pred :=
    match i with
      | O => pred
      | S ?n => match pred with ?f ?x => get_pred_type n f end
    end
  in
  let pred := get_pred_type icount ltac:(type of rhs) in

  (** Extract out the types of the predicate's indices.  We use the
      value of [icount] to determine the number of indices. *)
  let rec get_ind_types i pred acc :=
    match i with
      | O => acc
      | S ?n => match pred with
                  | ?f ?x => let ind := type of x in
                             get_ind_types n f (@cons Type ind acc)
                end
    end
  in
  let ind_types := get_ind_types icount ltac:(type of rhs) (@nil Type) in

  (** Extract out the predicate's indices.  We use the value of
      [icount] to determine the number of indices. *)
  let rec get_inds i pred acc :=
    match i with
      | O => acc
      | S ?n => match pred with ?f ?x => get_inds n f (x, acc) end
    end
  in
  let inds := get_inds icount ltac:(type of rhs) tt in

  (** For technical reasons that will become clear later in this
      tactic, we record reversed versions of the list of types of the
      predicate's indices and of the list of indices. *)
  let rind_types := constr:(list_rev ind_types) in
  let rinds := constr:(tuple_rev ind_types inds) in

  (** Now the real fun begins.  We need massage the goal so that it
      looks like [P index1 ... indexN rhs].  The trick is to define
      [P] appropriately.  The definition of [core] below is the first
      step in defining [P].  Compared to what we want, it is uncurried
      and the indices are in reverse order. *)
  let core :=
    constr:(fun (ainds : tuple rind_types)
                (rhs   : apply_tuple (list_rev rind_types)
                                     sort
                                     pred
                                     (tuple_rev rind_types ainds))
            =>
            forall eqpf : rinds = ainds,
              @eq (apply_tuple (list_rev rind_types)
                               sort
                               pred
                               (tuple_rev rind_types ainds))
                  (@eq_rect (tuple rind_types)
                            rinds
                            (fun rinds =>
                              apply_tuple (list_rev rind_types)
                                          sort
                                          pred
                                          (tuple_rev rind_types rinds))
                            lhs
                            ainds
                            eqpf)
                 rhs)
  in
  let core := eval simpl in core in

  (** Now, we take [core] and curry it.  When we curry [core], we end
      up "reversing" the order of arguments.  Because they started out
      reversed, what we end up with is function that takes the
      predicate's indices in the correct order when compared to the
      predicate's elimination principle.

      Implementation note (BEA): I don't see how to arrive at this
      curried form with out going through the "reversed list" stage. *)
  let rec curry f :=
    match type of f with
      | forall _ : (unit), _ => constr:(f tt)
      | forall _ : (_ * unit), _ => constr:(fun a => f (a, tt))
      | forall _ : (_ * _), _ =>
        let f' := constr:(fun b a => f (a, b)) in curry f'
    end
  in
  let core := curry core in
  let core := eval simpl in core in

  (** Now we supply to [core] the indices and the proof on the right
      hand side of the equality (the one we want to apply [case] to). *)
  let rec apply_core f args :=
    match args with
      | tt => constr:(f)
      | (?x, ?xs) => apply_core (f x) xs
    end
  in
  let core := apply_core core inds in
  let core := constr:(core rhs) in

  (** In order to make [core] convertible with the goal, we need to
      introduce an equality for the predicate's indices and generalize
      over that equality. *)
  change lhs with (@eq_rect (tuple rind_types)
                            rinds
                            (fun rinds =>
                              apply_tuple (list_rev rind_types)
                                          sort
                                          pred
                                          (tuple_rev rind_types rinds))
                            lhs
                            rinds
                            (refl_equal rinds));
  generalize (refl_equal rinds);

  (** We now have everything we need in order to use the [case] tactic. *)
  change core;
  case rhs;

  (** At this point, all that remains is to simplify everything.
      We begin by making sure all functions have reduced. *)
  unfold list_rev, tuple_rev in *;
  simpl tr_list_rev in *;
  simpl tr_tuple_rev in *;

  (** Next, we simplify the equality that we introduced earlier,
      checking for "obvious" contradictions in the process. *)
  repeat (match goal with
            | |- (_, _) = (_, _) -> _ =>
              let H := fresh in intros H; try discriminate; injection H
            | _ => progress intro
          end);
  subst;

  (** All that is left now is to use [eq_rect_eq_dec] to simplify
      occurrences of [eq_rect].  Since we have an equality between
      constructors, we can use [f_equal] to safely make progress from
      there.  We use [auto] and [auto with eq_dec] to clean up any
      subgoals. *)
  try (rewrite <- eq_rect_eq_dec; [ f_equal; auto | auto with eq_dec ]).


Require Import FunctionalExtensionality.
Require Export FunctionalExtensionality.

(** Useful tactic to deal with with records that contain function fields, such
    as [state]. *)
Ltac unwrap_layer := apply f_equal; apply functional_extensionality; intros.

(** Dives into a function and rewrites the input hypothesis in its body. *)
Theorem fun_ext_with_nested :
  forall {S T U} {f g : S -> T} (h : T -> U),
    (forall s, f s = g s) -> (fun s => h (f s)) = (fun s => h (g s)).
Proof.
  intros.
  apply functional_extensionality.
  intros.
  now rewrite H.
Qed.

(** Same as [fun_ext_with], but reversing the hypothesis. *)
Theorem fun_ext_with_nested' :
  forall {S T U} {f g : S -> T} (h : T -> U),
    (forall s, g s = f s) -> (fun s => h (f s)) = (fun s => h (g s)).
Proof.
  intros.
  symmetry in H.
  now rewrite (fun_ext_with_nested h H).
Qed.

(** Dives into a function and rewrites the whole body with the input
    hypothesis. *)
Theorem fun_ext_with :
  forall {S T} {f g : S -> T},
    (forall s, f s = g s) -> (fun s => f s) = (fun s => g s).
Proof.
  intros.
  apply (@fun_ext_with_nested S T T f g (fun x => x) H).
Qed.

(** Same as [fun_ext_with], but reversing the hypothesis. *)
Theorem fun_ext_with' :
  forall {S T} {f g : S -> T},
    (forall s, g s = f s) -> (fun s => f s) = (fun s => g s).
Proof.
  intros.
  symmetry in H.
  now rewrite (fun_ext_with H).
Qed.