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

 Preservation of inserters by right biadjoints

 ******************************************************************)
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.categories.StandardCategories.
Require Import UniMath.CategoryTheory.categories.Dialgebras.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.Equivalences.CompositesAndInverses.
Require Import UniMath.Bicategories.Core.Bicat. Import Bicat.Notations.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.EquivToAdjequiv.
Require Import UniMath.Bicategories.Core.Examples.BicatOfUnivCats.
Require Import UniMath.Bicategories.Morphisms.Adjunctions.
Require Import UniMath.Bicategories.Morphisms.Properties.
Require Import UniMath.Bicategories.Morphisms.Properties.ClosedUnderInvertibles.
Require Import UniMath.Bicategories.Core.Univalence.
Require Import UniMath.Bicategories.Core.BicategoryLaws.
Require Import UniMath.Bicategories.PseudoFunctors.Display.PseudoFunctorBicat.
Require Import UniMath.Bicategories.PseudoFunctors.PseudoFunctor.
Import PseudoFunctor.Notations.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Identity.
Require Import UniMath.Bicategories.PseudoFunctors.Examples.Composition.
Require Import UniMath.Bicategories.PseudoFunctors.Biadjunction.
Require Import UniMath.Bicategories.PseudoFunctors.Preservation.Preservation.
Require Import UniMath.Bicategories.Transformations.PseudoTransformation.
Require Import UniMath.Bicategories.Modifications.Modification.
Require Import UniMath.Bicategories.Limits.Inserters.

Local Open Scope cat.

Section BiadjunctionPreservation.
  Context {B₁ B₂ : bicat}
          {L : psfunctor B₁ B₂}
          (R : left_biadj_data L).

  Section PreserveInsertersCommute.
    Context {y₁ y₂ : B₂}
            (f : y₁ --> y₂)
            (x : B₁).

    Definition inserter_commute_nat_trans_data
      : nat_trans_data
          (biadj_right_hom R x y₁ ∙ post_comp x (# R f))
          (post_comp (L x) f ∙ biadj_right_hom R x y₂)
      := λ h, rassociator _ _ _ • (_ ◃ psfunctor_comp R _ _).

    Definition inserter_commute_is_nat_trans
      : is_nat_trans
          _ _
          inserter_commute_nat_trans_data.
    Proof.
      intros h₁ h₂ α ; cbn.
      unfold inserter_commute_nat_trans_data.
      rewrite !vassocr.
      rewrite <- rwhisker_lwhisker_rassociator.
      rewrite !vassocl.
      apply maponpaths.
      rewrite !lwhisker_vcomp.
      apply maponpaths.
      refine (!_).
      apply psfunctor_rwhisker.
    Qed.

    Definition inserter_commute_nat_trans
      : biadj_right_hom R x y₁ ∙ post_comp x (# R f)
        ⟹
        post_comp (L x) f ∙ biadj_right_hom R x y₂.
    Proof.
      use make_nat_trans.
      - exact inserter_commute_nat_trans_data.
      - exact inserter_commute_is_nat_trans.
    Defined.

    Definition inserter_commute_nat_z_iso
      : nat_z_iso
          (biadj_right_hom R x y₁ ∙ post_comp x (# R f))
          (post_comp (L x) f ∙ biadj_right_hom R x y₂).
    Proof.
      use make_nat_z_iso.
      - exact inserter_commute_nat_trans.
      - intro h.
        apply is_inv2cell_to_is_z_iso.
        cbn ; unfold inserter_commute_nat_trans_data.
        is_iso.
        apply property_from_invertible_2cell.
    Defined.
  End PreserveInsertersCommute.

  Section PreserveInserterNatIso.
    Context {y₁ y₂ : B₂}
            {f g : y₁ --> y₂}
            (i : inserter_cone f g)
            (x : B₁).

    Definition right_biadj_preserves_inserters_nat_trans_cell
               (h : x --> R i)
      : biadj_unit R x · # R (# L h · biadj_counit R i · inserter_cone_pr1 i)
        ==>
        h · # R (inserter_cone_pr1 i)
      := (_ ◃ ((psfunctor_comp R _ _)^-1
               • ((psfunctor_comp R _ _)^-1 ▹ _)))
         • lassociator _ _ _
         • (lassociator _ _ _ ▹ _)
         • (((psnaturality_of (biadj_unit R) h) ▹ _) ▹ _)
         • rassociator _ _ _
         • rassociator _ _ _
         • (_ ◃ (lassociator _ _ _
                 • ((linvunitor _
                 • (_ ◃ (_ ◃ (linvunitor _ • (_ ◃ rinvunitor _))))
                 • invertible_modcomponent_of (biadj_triangle_r R) i) ▹ _)
                 • lunitor _)).

    Opaque psfunctor_comp.

    Local Notation "'lα'" := (lassociator _ _ _).
    Local Notation "'rα'" := (rassociator _ _ _).
    Local Notation "'lu'" := (lunitor _).
    Local Notation "'lui'" := (linvunitor _).
    Local Notation "'ru'" := (runitor _).
    Local Notation "'rui'" := (rinvunitor _).

    Definition right_biadj_preserves_inserters_nat_trans_path
               (h : x --> R i)
      : @dialgebra_mor_path
          _ _ _ _
          ((biadj_left_hom R x i
            ∙ inserter_cone_functor i (L x)
            ∙ dialgebra_equivalence_of_cats_functor
                (inserter_commute_nat_z_iso f x)
                (inserter_commute_nat_z_iso g x))
             h)
          (inserter_cone_functor (psfunctor_inserter_cone R i) x h)
          (right_biadj_preserves_inserters_nat_trans_cell h).
    Proof.
      unfold dialgebra_mor_path.
      cbn.
      unfold inserter_commute_nat_trans_data.
      unfold right_biadj_preserves_inserters_nat_trans_cell.
      rewrite <- !lwhisker_vcomp.
      rewrite <- !rwhisker_vcomp.
      do 3 refine (vassocl _ _ _ @ _).
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocl _ _ _ @ _).
        do 2 apply maponpaths.
        do 6 refine (vassocl _ _ _ @ _).
        do 7 apply maponpaths.
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        apply maponpaths_2.
        do 2 apply maponpaths.
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        apply vassocl.
      }
      etrans.
      {
        do 2 apply maponpaths.
        apply maponpaths_2.
        do 2 apply maponpaths.
        apply vassocl.
      }
      do 7 refine (_ @ vassocr _ _ _).
      refine (!_).
      etrans.
      {
        do 7 apply maponpaths.
        do 2 refine (vassocl _ _ _ @ _).
        do 3 apply maponpaths.
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        do 2 refine (vassocl _ _ _ @ _).
        apply idpath.
      }
      etrans.
      {
        do 8 apply maponpaths.
        apply maponpaths_2.
        do 2 apply maponpaths.
        refine (vassocl _ _ _ @ _) ; apply maponpaths.
        apply vassocl.
      }
      refine (!_).
      use vcomp_move_R_pM ; [ is_iso | ].
      refine (!_).
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (!_).
        apply rwhisker_lwhisker.
      }
      refine (vassocl _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (!_).
        apply rwhisker_lwhisker.
      }
      etrans.
      {
        apply maponpaths.
        apply vassocl.
      }
      use vcomp_move_R_pM ; [ is_iso | ].
      use vcomp_move_R_pM ; [ is_iso | ].
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        cbn.
        apply idpath.
      }
      etrans.
      {
        apply maponpaths ; apply maponpaths_2.
        cbn.
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          apply rwhisker_vcomp.
        }
        etrans.
        {
          apply maponpaths.
          apply rwhisker_rwhisker_alt.
        }
        exact (!(rwhisker_vcomp _ _ _)).
      }
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocl _ _ _ @ _).
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        do 3 apply maponpaths.
        apply maponpaths_2.
        etrans.
        {
          apply maponpaths.
          apply psfunctor_vcomp.
        }
        exact (!(lwhisker_vcomp _ _ _)).
      }
      etrans.
      {
        do 3 refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          do 2 refine (vassocl _ _ _ @ _).
          apply maponpaths.
          refine (maponpaths (λ z, _ • z) (lwhisker_vcomp _ _ _) @ _).
          refine (lwhisker_vcomp _ _ _ @ _).
          etrans.
          {
            apply maponpaths.
            refine (vassocr _ _ _ @ _).
            apply (psfunctor_rassociator R).
          }
          apply idpath.
        }
        refine (lwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          apply maponpaths.
          refine (vassocr _ _ _ @ _).
          etrans.
          {
            apply maponpaths_2.
            refine (vassocr _ _ _ @ _).
            etrans.
            {
              apply maponpaths_2.
              apply rwhisker_rwhisker_alt.
            }
            refine (vassocl _ _ _ @ _).
            apply idpath.
          }
          refine (vassocl _ _ _ @ _).
          apply maponpaths.
          apply vassocl.
        }
        do 3 (refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
        apply idpath.
      }
      do 2 refine (vassocl _ _ _ @ _).
      use vcomp_move_R_pM ; [ is_iso | ].
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        cbn.
        apply idpath.
      }
      etrans.
      {
        do 4 refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        etrans.
        {
          do 2 apply maponpaths_2.
          apply lassociator_lassociator.
        }
        do 2 refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_rwhisker.
        }
        refine (vassocl _ _ _ @ _).
        apply idpath.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        apply maponpaths_2.
        apply maponpaths.
        apply psfunctor_vcomp.
      }
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply rwhisker_lwhisker.
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (!_).
          apply rwhisker_lwhisker.
        }
        apply vassocl.
      }
      etrans.
      {
        do 5 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply pentagon_6.
        }
        do 2 refine (vassocl _ _ _ @ _).
        do 2 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_rwhisker.
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_rwhisker.
        }
        refine (vassocl _ _ _ @ _).
        apply idpath.
      }
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          do 4 refine (vassocr _ _ _ @ _).
          apply maponpaths_2.
          refine (maponpaths (λ z, ((z • _) • _) • _) (lwhisker_vcomp _ _ _) @ _).
          refine (maponpaths (λ z, (z • _) • _) (lwhisker_vcomp _ _ _) @ _).
          refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _).
          refine (lwhisker_vcomp _ _ _ @ _).
          apply maponpaths.
          do 4 refine (vassocl _ _ _ @ _).
          apply maponpaths.
          etrans.
          {
            do 3 apply maponpaths.
            apply rwhisker_rwhisker_alt.
          }
          do 3 refine (vassocr _ _ _ @ _).
          apply maponpaths_2.
          apply psfunctor_lassociator_alt'.
        }
        apply maponpaths_2.
        do 2 apply maponpaths.
        apply vassocl.
      }
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (maponpaths (λ z, (_ • z) • _) (lwhisker_vcomp _ _ _) @ _).
        refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _).
        refine (lwhisker_vcomp _ _ _ @ _).
        apply maponpaths.
        refine (vassocl _ _ _ @ _).
        refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _).
        etrans.
        {
          do 2 apply maponpaths.
          refine (vassocr _ _ _ @ _).
          etrans.
          {
            apply maponpaths_2.
            apply psfunctor_lwhisker.
          }
          refine (vassocl _ _ _ @ _).
          apply maponpaths.
          refine (vassocr _ _ _ @ _).
          etrans.
          {
            apply maponpaths_2.
            apply vcomp_rinv.
          }
          apply id2_left.
        }
        etrans.
        {
          refine (vassocr _ _ _ @ _).
          refine (maponpaths (λ z, z • _) (vcomp_whisker _ _) @ _).
          refine (vassocl _ _ _ @ _).
          apply maponpaths.
          refine (vassocr _ _ _ @ _).
          refine (maponpaths (λ z, z • _) (vcomp_whisker _ _) @ _).
          refine (vassocl _ _ _ @ _).
          apply maponpaths.
          refine (vassocr _ _ _ @ _).
          refine (maponpaths (λ z, z • _) (vcomp_whisker _ _) @ _).
          refine (vassocl _ _ _ @ _).
          etrans.
          {
            apply maponpaths.
            refine (rwhisker_vcomp _ _ _ @ _).
            refine (maponpaths (λ z, z ▹ _) (vcomp_rinv _) @ _).
            apply id2_rwhisker.
          }
          apply id2_right.
        }
        refine (maponpaths (λ z, _ • z) (lwhisker_vcomp _ _ _) @ _).
        apply lwhisker_vcomp.
      }
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply lwhisker_lwhisker.
      }
      refine (vassocl _ _ _ @ _ @ vassocr _ _ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        exact (!(vcomp_whisker _ _)).
      }
      refine (vassocl _ _ _ @ _).
      refine (_ @ vassocr _ _ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (!_).
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      refine (!_).
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (vassocl _ _ _ @ _).
        refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
        refine (maponpaths (λ z, _ • (z ▹ _)) (!(rwhisker_rwhisker_alt _ _ _)) @ _).
        refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _).
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        apply vassocl.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        apply maponpaths_2.
        apply inverse_pentagon_7.
      }
      do 2 refine (vassocl _ _ _ @ _).
      use vcomp_move_R_pM ; [ is_iso | ].
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        cbn.
        apply idpath.
      }
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        exact (!(lwhisker_lwhisker _ _ _)).
      }
      refine (vassocl _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          exact (!(lassociator_lassociator _ _ _ _)).
        }
        do 2 refine (vassocl _ _ _ @ _).
        do 2 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (rwhisker_vcomp _ _ _ @ _).
          refine (maponpaths (λ z, z ▹ _) (lassociator_rassociator _ _ _) @ _).
          apply id2_rwhisker.
        }
        apply id2_left.
      }
      etrans.
      {
        do 3 apply maponpaths.
        refine (maponpaths (λ z, _ • (_ • z)) (rwhisker_vcomp _ _ _) @ _).
        refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
        refine (rwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          do 3 apply maponpaths.
          apply maponpaths_2.
          apply maponpaths.
          refine (maponpaths (λ z, _ • (_ • z)) (rwhisker_vcomp _ _ _) @ _).
          refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
          apply rwhisker_vcomp.
        }
        do 2 apply maponpaths.
        refine (maponpaths (λ z, _ • z) (lwhisker_vcomp _ _ _) @ _).
        apply lwhisker_vcomp.
      }
      refine (!_).
      etrans.
      {
        do 3 apply maponpaths.
        do 3 refine (vassocr _ _ _ @ _).
        etrans.
        {
          do 2 apply maponpaths_2.
          refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _).
          apply rwhisker_vcomp.
        }
        etrans.
        {
          do 2 apply maponpaths_2.
          apply maponpaths.
          refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _).
          apply lwhisker_vcomp.
        }
        etrans.
        {
          apply maponpaths_2.
          exact (!(rwhisker_lwhisker_rassociator _ _ _ _ _ _ _ _ _)).
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        do 3 refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (maponpaths (λ z, (z • _) • _) (lwhisker_vcomp _ _ _) @ _).
          refine (maponpaths (λ z, z • _) (lwhisker_vcomp _ _ _) @ _).
          apply lwhisker_vcomp.
        }
        apply maponpaths_2.
        apply maponpaths.
        do 2 refine (vassocl _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (!(rwhisker_vcomp _ _ _) @ maponpaths (λ z, z • _) _).
          do 3 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
          exact (!(rwhisker_vcomp _ _ _)).
        }
        do 2 refine (vassocl _ _ _ @ _) ; apply maponpaths.
        do 2 (refine (vassocl _ _ _ @ _) ; apply maponpaths).
        apply vassocl.
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (maponpaths (λ z, z • _) (lwhisker_hcomp _ _) @ _).
          apply pentagon_2.
        }
        etrans.
        {
          apply maponpaths_2.
          do 2 apply maponpaths.
          exact (!(rwhisker_hcomp _ _)).
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        apply rwhisker_vcomp.
      }
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply lwhisker_lwhisker.
      }
      refine (vassocl _ _ _ @ _).
      use vcomp_move_R_pM ; [ is_iso | ].
      refine (!_).
      etrans.
      {
        apply maponpaths_2.
        cbn.
        apply idpath.
      }
      do 2 refine (vassocr _ _ _ @ _).
      etrans.
      {
        apply maponpaths_2.
        exact (!(inverse_pentagon_7 _  _ _ _)).
      }
      refine (vassocl _ _ _ @ _).
      refine (!_).
      etrans.
      {
        apply maponpaths.
        etrans.
        {
          apply maponpaths.
          do 2 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
          etrans.
          {
            apply maponpaths.
            refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths.
            exact (!(lwhisker_vcomp _ _ _)).
          }
          refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths.
          exact (!(rwhisker_vcomp _ _ _)).
        }
        etrans.
        {
          do 4 apply maponpaths.
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            etrans.
            {
              apply maponpaths.
              do 2 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
              exact (!(rwhisker_vcomp _ _ _)).
            }
            do 2 (refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
            exact (!(lwhisker_vcomp _ _ _)).
          }
          do 2 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
          exact (!(rwhisker_vcomp _ _ _)).
        }
        do 4 refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        do 3 refine (vassocr _ _ _ @ _).
        do 5 apply maponpaths_2.
        refine (vassocl _ _ _ @ _).
        refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
        refine (maponpaths (λ z, _ • (z ▹ _)) (!(rassociator_rassociator _ _ _ _)) @ _).
        etrans.
        {
          apply maponpaths.
          refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths_2.
          exact (!(rwhisker_vcomp _ _ _)).
        }
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (vassocr _ _ _) @ _).
        refine (maponpaths (λ z, (z • _) • _) (rwhisker_rwhisker _ _ _) @ _).
        refine (vassocl _ _ _ @ _).
        cbn.
        apply idpath.
      }
      etrans.
      {
        etrans.
        {
          apply maponpaths.
          do 7 refine (vassocl _ _ _ @ _) ; do 2 apply maponpaths.
          apply vassocl.
        }
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          exact (!(vcomp_whisker _ _)).
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        do 2 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          refine (rwhisker_vcomp _ _ _ @ _).
          etrans.
          {
            apply maponpaths.
            refine (lwhisker_vcomp _ _ _ @ _).
            etrans.
            {
              apply maponpaths.
              apply rassociator_lassociator.
            }
            apply lwhisker_id2.
          }
          apply id2_rwhisker.
        }
        apply id2_left.
      }
      etrans.
      {
        apply maponpaths.
        refine (vassocl _ _ _ @ _) ; do 2 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (rwhisker_vcomp _ _ _ @ _).
        apply maponpaths.
        cbn.
        apply rwhisker_lwhisker_rassociator.
      }
      etrans.
      {
        do 2 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          apply maponpaths_2.
          exact (!(rwhisker_vcomp _ _ _)).
        }
        refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _).
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_rwhisker.
      }
      etrans.
      {
        apply maponpaths.
        refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _).
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        exact (!(vcomp_whisker _ _)).
      }
      refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _).
      etrans.
      {
        do 4 apply maponpaths.
        do 3 refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, ((z • _) • _) • _) (rwhisker_vcomp _ _ _) @ _).
        refine (maponpaths (λ z, (z • _) • _) (rwhisker_vcomp _ _ _) @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _).
        refine (rwhisker_vcomp _ _ _ @ _).
        apply maponpaths.
        etrans.
        {
          do 3 apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        do 3 refine (vassocl _ _ _ @ _).
        apply maponpaths.
        do 2 refine (vassocr _ _ _ @ _).
        etrans.
        {
          do 2 apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        do 2 refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        apply vassocl.
      }
      etrans.
      {
        do 3 apply maponpaths.
        etrans.
        {
          apply maponpaths.
          do 3 (refine (!(rwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
          exact (!(rwhisker_vcomp _ _ _)).
        }
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        apply vassocl.
      }
      etrans.
      {
        do 2 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (!(vcomp_whisker _ _)) @ _).
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        etrans.
        {
          do 3 apply maponpaths.
          refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
          do 2 apply maponpaths.
          apply lunitor_lwhisker.
        }
        do 3 apply maponpaths.
        apply rwhisker_rwhisker.
      }
      do 6 refine (vassocr _ _ _ @ _).
      do 4 refine (_ @ vassocl _ _ _).
      apply maponpaths_2.
      do 5 refine (vassocl _ _ _ @ _).
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (!(vcomp_whisker _ _)) @ _).
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (!(vcomp_whisker _ _)) @ _).
        refine (vassocl _ _ _ @ _).
        exact (maponpaths (λ z, _ • z) (!(vcomp_whisker _ _))).
      }
      refine (!_).
      etrans.
      {
        apply maponpaths.
        do 5 (refine (!(lwhisker_vcomp _ _ _) @ _) ; apply maponpaths).
        exact (!(lwhisker_vcomp _ _ _)).
      }
      do 5 refine (_ @ vassocl _ _ _).
      do 6 refine (vassocr _ _ _ @ _).
      apply maponpaths_2.
      do 8 refine (vassocl _ _ _ @ _).
      do 4 refine (_ @ vassocr _ _ _).
      refine (!_).
      etrans.
      {
        do 4 apply maponpaths.
        apply rwhisker_vcomp.
      }
      refine (!_).
      etrans.
      {
        do 8 apply maponpaths.
        refine (lwhisker_vcomp _ _ _ @ _).
        apply maponpaths.
        apply rwhisker_vcomp.
      }
      etrans.
      {
        do 3 apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (vassocr _ _ _ @ _).
        etrans.
        {
          apply maponpaths_2.
          apply rwhisker_lwhisker_rassociator.
        }
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        etrans.
        {
          apply rwhisker_lwhisker_rassociator.
        }
        etrans.
        {
          apply maponpaths_2.
          etrans.
          {
            apply maponpaths.
            exact (!(lwhisker_vcomp _ _ _)).
          }
          exact (!(rwhisker_vcomp _ _ _)).
        }
        apply vassocl.
      }
      do 8 refine (vassocr _ _ _ @ _).
      use vcomp_move_R_Mp ; [ is_iso | ].
      do 7 refine (vassocl _ _ _ @ _).
      refine (!_).
      refine (vassocl _ _ _ @ _).
      etrans.
      {
        apply maponpaths.
        do 2 (refine (vassocl _ _ _ @ _) ; apply maponpaths).
        apply vassocl.
      }
      etrans.
      {
        do 5 apply maponpaths.
        cbn.
        apply idpath.
      }
      etrans.
      {
        do 4 apply maponpaths.
        refine (maponpaths (λ z, z • _) (!(rwhisker_vcomp _ _ _)) @ _).
        refine (vassocl _ _ _ @ _).
        refine (maponpaths (λ z, _ • z) (!(rwhisker_rwhisker _ _ _)) @ _).
        pose (maponpaths
                (λ z, rassociator _ _ _ • z)
                (runitor_rwhisker h (# R (inserter_cone_pr1 i))))
          as p.
        cbn in p.
        rewrite !vassocr in p.
        rewrite rassociator_lassociator, id2_left in p.
        etrans.
        {
          do 3 apply maponpaths.
          exact p.
        }
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (!(rwhisker_rwhisker _ _ _)) @ _).
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _).
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _).
        etrans.
        {
          apply maponpaths_2.
          apply maponpaths.
          refine (!_).
          apply rwhisker_lwhisker_rassociator.
        }
        exact (maponpaths (λ z, z • _) (!(rwhisker_vcomp _ _ _))).
      }
      do 5 refine (vassocr _ _ _ @ _).
      do 7 refine (_ @ vassocl _ _ _).
      apply maponpaths_2.
      refine (vassocr _ _ _ @ _).
      apply maponpaths_2.
      do 4 refine (vassocl _ _ _ @ _).
      do 5 refine (_ @ vassocr _ _ _).
      cbn.
      refine (!_).
      etrans.
      {
        apply maponpaths.
        do 2 refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (maponpaths (λ z, z • _) (rwhisker_vcomp _ _ _) @ _).
        refine (rwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          apply maponpaths.
          refine (maponpaths (λ z, z • _) (!(rassociator_rassociator _ _ _ _)) @ _).
          refine (vassocl _ _ _ @ _).
          etrans.
          {
            apply maponpaths.
            refine (lwhisker_vcomp _ _ _ @ _).
            refine (maponpaths (λ z, _ ◃ z) (rassociator_lassociator _ _ _) @ _).
            apply lwhisker_id2.
          }
          apply id2_right.
        }
        exact (!(rwhisker_vcomp _ _ _)).
      }
      etrans.
      {
        refine (maponpaths (λ z, _ • z) (vassocl _ _ _) @ _).
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        refine (vassocl _ _ _ @ _).
        apply idpath.
      }
      apply maponpaths.
      etrans.
      {
        do 2 refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (vassocl _ _ _ @ _).
        refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
        etrans.
        {
          do 2 apply maponpaths.
          apply rwhisker_lwhisker_rassociator.
        }
        refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _).
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        apply vassocl.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      refine (vassocl _ _ _ @ _).
      etrans.
      {
        do 2 refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (vassocl _ _ _ @ _).
        refine (maponpaths (λ z, _ • z) (rwhisker_vcomp _ _ _) @ _).
        etrans.
        {
          do 2 apply maponpaths.
          apply rwhisker_lwhisker_rassociator.
        }
        refine (maponpaths (λ z, _ • z) (!(rwhisker_vcomp _ _ _)) @ _).
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (rwhisker_rwhisker _ _ _) @ _).
        apply vassocl.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      refine (!_).
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        refine (maponpaths (λ z, z • _) (!(rwhisker_rwhisker _ _ _)) @ _).
        refine (vassocl _ _ _ @ _).
        apply maponpaths.
        refine (rwhisker_vcomp _ _ _ @ !_).
        apply maponpaths.
        apply rwhisker_lwhisker_rassociator.
      }
      refine (_ @ vassocr _ _ _).
      apply maponpaths.
      refine (!_).
      apply rwhisker_vcomp.
    Qed.

    Transparent psfunctor_comp.

    Definition right_biadj_preserves_inserters_nat_trans_data
      : nat_trans_data
          (biadj_left_hom R x i
           ∙ inserter_cone_functor i (L x)
           ∙ dialgebra_equivalence_of_cats_functor
               (inserter_commute_nat_z_iso f x)
               (inserter_commute_nat_z_iso g x))
          (inserter_cone_functor (psfunctor_inserter_cone R i) x).
    Proof.
      intro h.
      use make_dialgebra_mor.
      - exact (right_biadj_preserves_inserters_nat_trans_cell h).
      - exact (right_biadj_preserves_inserters_nat_trans_path h).
    Defined.

    Definition right_biadj_preserves_inserters_is_nat_trans
      : is_nat_trans
          _ _
          right_biadj_preserves_inserters_nat_trans_data.
    Proof.
      intros h₁ h₂ α.
      use eq_dialgebra.
      cbn.
      unfold right_biadj_preserves_inserters_nat_trans_cell.
      rewrite <- !rwhisker_vcomp.
      rewrite <- !lwhisker_vcomp.
      rewrite !vassocl.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        rewrite lwhisker_vcomp.
        etrans.
        {
          apply maponpaths.
          assert (## R ((## L α ▹ biadj_counit R i) ▹ inserter_cone_pr1 i)
                  • (psfunctor_comp R _ _)^-1
                  =
                  (psfunctor_comp R _ _)^-1
                  • (## R (## L α ▹ biadj_counit R i) ▹ # R (inserter_cone_pr1 i)))
            as H.
          {
            use vcomp_move_R_Mp ; [ is_iso | ].
            rewrite !vassocl.
            use vcomp_move_L_pM ; [ is_iso | ].
            exact (psfunctor_rwhisker
                     R
                     (inserter_cone_pr1 i)
                     (## L α ▹ biadj_counit R i)).
          }
          exact H.
        }
        rewrite <- lwhisker_vcomp.
        apply idpath.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        rewrite lwhisker_vcomp.
        rewrite rwhisker_vcomp.
        etrans.
        {
          do 2 apply maponpaths.
          assert (## R (## L α ▹ biadj_counit R i)
                  • ( psfunctor_comp R _ _)^-1
                  =
                  (psfunctor_comp R _ _)^-1
                  • (## R (## L α) ▹ # R (biadj_counit R i)))
            as H.
          {
            use vcomp_move_R_Mp ; [ is_iso | ].
            rewrite !vassocl.
            use vcomp_move_L_pM ; [ is_iso | ].
            exact (psfunctor_rwhisker R (biadj_counit R i) (##L α)).
          }
          exact H.
        }
        rewrite <- rwhisker_vcomp.
        rewrite <- lwhisker_vcomp.
        apply idpath.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_lwhisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (rwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          apply maponpaths.
          apply rwhisker_lwhisker.
        }
        exact (!(rwhisker_vcomp _ _ _)).
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        refine (rwhisker_vcomp _ _ _ @ _).
        etrans.
        {
          apply maponpaths.
          refine (rwhisker_vcomp _ _ _ @ _).
          etrans.
          {
            apply maponpaths.
            exact (psnaturality_natural (biadj_unit R) _ _ _ _ α).
          }
          cbn.
          exact (!(rwhisker_vcomp _ _ _)).
        }
        exact (!(rwhisker_vcomp _ _ _)).
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_rwhisker_alt.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply rwhisker_rwhisker_alt.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      etrans.
      {
        refine (vassocr _ _ _ @ _).
        apply maponpaths_2.
        apply vcomp_whisker.
      }
      refine (vassocl _ _ _ @ _).
      apply maponpaths.
      apply vcomp_whisker.
    Qed.

    Definition right_biadj_preserves_inserters_nat_trans
      : biadj_left_hom R x i
        ∙ inserter_cone_functor i (L x)
        ∙ dialgebra_equivalence_of_cats_functor
            (inserter_commute_nat_z_iso f x)
            (inserter_commute_nat_z_iso g x)
        ⟹
        inserter_cone_functor (psfunctor_inserter_cone R i) x.
    Proof.
      use make_nat_trans.
      - exact right_biadj_preserves_inserters_nat_trans_data.
      - exact right_biadj_preserves_inserters_is_nat_trans.
    Defined.

    Definition right_biadj_preserves_inserters_is_nat_z_iso
      : is_nat_z_iso right_biadj_preserves_inserters_nat_trans.
    Proof.
      intro h.
      use is_z_iso_dialgebra.
      use is_inv2cell_to_is_z_iso.
      cbn ; unfold right_biadj_preserves_inserters_nat_trans_cell.
      is_iso.
      - apply property_from_invertible_2cell.
      - apply property_from_invertible_2cell.
    Defined.
  End PreserveInserterNatIso.

  Definition right_biadj_preserves_inserters
             (HB₁ : is_univalent_2_1 B₁)
             (HB₂ : is_univalent_2_1 B₂)
    : preserves_inserters R.
  Proof.
    intros y₁ y₂ f g i Hi.
    use universal_inserter_cone_has_ump.
    intro x.
    use nat_iso_adj_equivalence_of_cats.
    - refine (biadj_left_hom R x i
              ∙ inserter_cone_functor i (L x)
              ∙ _).
      use dialgebra_equivalence_of_cats_functor.
      + exact (biadj_right_hom R x y₁).
      + exact (biadj_right_hom R x y₂).
      + exact (inserter_commute_nat_z_iso f x).
      + exact (inserter_commute_nat_z_iso g x).
    - exact (right_biadj_preserves_inserters_nat_trans i x).
    - exact (right_biadj_preserves_inserters_is_nat_z_iso i x).
    - use comp_adj_equivalence_of_cats.
      + use comp_adj_equivalence_of_cats.
        * exact (biadj_hom_equiv R x i).
        * apply (make_is_universal_inserter_cone HB₂ _ Hi).
      + use dialgebra_adj_equivalence_of_cats.
        * exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₁)).
        * exact (adj_equivalence_of_cats_inv (biadj_hom_equiv R x y₂)).
  Defined.
End BiadjunctionPreservation.


(* Written by Sosuke Moriguchi (chiguri), Kwansei Gakuin University *)

(** * Network sample : simple network with only 7 nodes (bound) *)
(** * Content Management sample : each node can store only one content *)

Require Import List.
Import ListNotations.

Require CCNProtocol.
Require CCNContentManagement.
Require Import CCNSimpleNetwork.

Module CCN_SimpleNetworkFIFO <: CCNContentManagement.CCN_Content_Management.

Module Topology := CCN_SimpleNetwork.
Import Topology.

Module OldProtocol := CCNProtocol.CCN_Protocol Topology.
Import OldProtocol.

Fixpoint FIFO_1 (v : Node) (c : Content_Name) (es : list Event) : option (Content c) :=
match es with
| nil => None
| StoreData v' c' C :: es' =>
   match Node_eq_dec v v' with
   | left _ => match Content_Name_eq_dec c c' with
               | left x => eq_rec_r (fun t => option (Content t)) (Some C) x
               | _ => None (* Because v uses its storage for c' *)
               end
   | _ => FIFO_1 v c es'
   end
| _ :: es' => FIFO_1 v c es'
end.

Definition CMF (v : Node) (c : Content_Name) (es : list Event) : option (Content c) :=
match InitCS_dec v c with
| left x => Some (InitContent_Data v c x)
| _ => FIFO_1 v c es
end.

(** InitCS should keep its own resources. *)
Lemma CMF_keep_InitCS :
  forall (v : Node) (c : Content_Name), InitCS v c -> forall es : list Event, exists C : Content c, CMF v c es = Some C.
intros.
unfold CMF.
destruct InitCS_dec with v c.
+eexists; eauto.
+elim n; now auto.
Qed.

(** Nodes other than InitCS does not have contents initially. *)
Lemma CMF_not_create_content :
  forall (v : Node) (c : Content_Name), ~InitCS v c -> CMF v c [] = None.
intros.
unfold CMF.
destruct InitCS_dec with v c.
+elim H; now auto.
+simpl; now auto.
Qed.

Definition CMF_reply_consistency (es : list Event) :=
  forall (v : Node) (c : Content_Name) (es1 es2 : list Event),
   es = es1 ++ ReplyData v c :: es2 -> CMF v c es2 <> None.

(** If once the node seems not to have requested contents, it will not have until it will receive and store the contents. *)
Lemma CMF_consistency :
  forall (v : Node) (c : Content_Name) (es es' : list Event), CMF_reply_consistency (es' ++ es) -> CMF v c es = None -> (forall C : Content c, ~In (StoreData v c C) es') -> CMF v c (es' ++ es) = None.
intros v c es es' _ H H0.
unfold CMF in *.
destruct InitCS_dec with v c.
+now auto.
+induction es'.
 -simpl; now auto.
 -destruct a; try (apply IHes'; intros C ?; apply H0 with C; right; now auto).
  simpl.
  destruct Node_eq_dec with v n0.
  *destruct Content_Name_eq_dec with c c0; subst.
    elim (H0 c3).
     left; now auto.
    now auto.
  *apply IHes'.
   intros C ?.
   apply H0 with C.
   right; now auto.
Qed.

End CCN_SimpleNetworkFIFO.

Require CCNVerificationWithCM.

Module CCN_SimpleNetwork_Verification := CCNVerificationWithCM.CCN_Protocol_Verification_CM CCN_SimpleNetworkFIFO.
Import CCN_SimpleNetwork_Verification.


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

(** This file provides classical logic and unique choice; this is
    weaker than providing iota operator and classical logic as the
    definite descriptions provided by the axiom of unique choice can
    be used only in a propositional context (especially, they cannot
    be used to build functions outside the scope of a theorem proof) *)

(** Classical logic and unique choice, as shown in
    [[ChicliPottierSimpson02]], implies the double-negation of
    excluded-middle in [Set], hence it implies a strongly classical
    world. Especially it conflicts with the impredicativity of [Set].

    [[ChicliPottierSimpson02]] Laurent Chicli, Loïc Pottier, Carlos
    Simpson, Mathematical Quotients and Quotient Types in Coq,
    Proceedings of TYPES 2002, Lecture Notes in Computer Science 2646,
    Springer Verlag.  *)

Require Export Classical.

Axiom
  dependent_unique_choice :
    forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
      (forall x : A, exists! y : B x, R x y) ->
      (exists f : (forall x:A, B x), forall x:A, R x (f x)).

(** Unique choice reifies functional relations into functions *)

Theorem unique_choice :
 forall (A B:Type) (R:A -> B -> Prop),
   (forall x:A,  exists! y : B, R x y) ->
   (exists f:A->B, forall x:A, R x (f x)).
Proof.
intros A B.
apply (dependent_unique_choice A (fun _ => B)).
Qed.

(** The following proof comes from [[ChicliPottierSimpson02]] *)
Require Import Setoid.

Theorem classic_set_in_prop_context :
  forall C:Prop, ((forall P:Prop, {P} + {~ P}) -> C) -> C.
Proof.
intros C HnotEM.
set (R := fun A b => A /\ true = b \/ ~ A /\ false = b).
assert (H :  exists f : Prop -> bool, (forall A:Prop, R A (f A))).
apply unique_choice.
intro A.
destruct (classic A) as [Ha| Hnota].
  exists true; split.
    left; split; [ assumption | reflexivity ].
    intros y [[_ Hy]| [Hna _]].
      assumption.
      contradiction.
  exists false; split.
    right; split; [ assumption | reflexivity ].
    intros y [[Ha _]| [_ Hy]].
      contradiction.
      assumption.
destruct H as [f Hf].
apply HnotEM.
intro P.
assert (HfP := Hf P).
(* Elimination from Hf to Set is not allowed but from f to Set yes ! *)
destruct (f P).
  left.
  destruct HfP as [[Ha _]| [_ Hfalse]].
    assumption.
    discriminate.
  right.
  destruct HfP as [[_ Hfalse]| [Hna _]].
    discriminate.
    assumption.
Qed.

Corollary not_not_classic_set :
  ((forall P:Prop, {P} + {~ P}) -> False) -> False.
Proof.
apply classic_set_in_prop_context.
Qed.

(* Compatibility *)
Notation classic_set := not_not_classic_set (only parsing).


Require Import List.
Require Import ZArith.
Require Import Utils.
Require Import Semantics.
Require Import Instr.
Require Import Concrete.
Require Import ConcreteMachine.
Require Import Determinism.
Require TINI.
Open Scope Z_scope.

Set Implicit Arguments.

(** Some alternative predicates for expressing execution of kernel-mode
code. Used in the specification of the fault handler *)

Section CExec.

(** [runsUntilUser s1 s2] says that the machine starts in some kernel
states [s1], makes some steps while staying in kernel mode, and
finally ends in state [s2] in user mode. *)

Inductive runsUntilUser : CS -> CS -> Prop :=
| ruu_end : forall s s',
              priv s = true ->
              priv s' = false ->
              cstep s Silent s' ->
              runsUntilUser s s'
| ruu_step : forall s s' s'',
               priv s = true ->
               cstep s Silent s' ->
               runsUntilUser s' s'' ->
               runsUntilUser s s''.
Hint Constructors runsUntilUser : core.

Lemma runsUntilUser_l : forall s s',
                                  runsUntilUser s s' ->
                                  priv s = true.
Proof.
  intros. inv H; trivial.
Qed.
Hint Resolve runsUntilUser_l : core.

Lemma runsUntilUser_r : forall s s',
                                  runsUntilUser s s' ->
                                  priv s' = false.
Proof.
  intros. induction H; auto.
Qed.

Lemma runsUntilUser_star :
  forall cs cs',
    runsUntilUser cs cs' ->
    star cstep cs nil cs'.
Proof. induction 1; eauto. Qed.
Hint Resolve runsUntilUser_star : core.

Lemma runsUntilUser_determ :
  forall s1 s21 s22
         (RUN1 : runsUntilUser s1 s21)
         (RUN2 : runsUntilUser s1 s22),
    s21 = s22.
Proof.
  intros.
  induction RUN1; inv RUN2;
  try match goal with
        | [ H1 : cstep ?s _ _,
            H2 : cstep ?s _ _
            |- _ ] =>
          let H := fresh "H" in
          generalize (cmach_determ H1 H2);
          intros [? ?]; subst
      end; eauto;
  try match goal with
        | [ H : runsUntilUser _ _ |- _ ] =>
          generalize (runsUntilUser_l H);
          intros
      end;
  congruence.
Qed.

(** [runsToEnd] is similar to [runsUntilUser], but we end the execution
in kernel mode instead of user mode *)

Inductive runsToEnd : CS -> CS -> Prop :=
| rte_refl : forall s, priv s = true -> runsToEnd s s
| rte_step : forall s s' s'',
               priv s = true ->
               cstep s Silent s' -> (* slippery to put Silent, but justified *)
               runsToEnd s' s'' ->
               runsToEnd s s''.
Hint Constructors runsToEnd : core.

Lemma runsToEnd_l : forall s s',
                       runsToEnd s s' ->
                       priv s = true.
Proof.
  intros. inv H; trivial.
Qed.

Lemma runsToEnd_r : forall s s',
                       runsToEnd s s' ->
                       priv s' = true.
Proof.
  intros. induction H; auto.
Qed.

Lemma runsToEnd_star :
  forall cs cs',
    runsToEnd cs cs' ->
    star cstep cs nil cs'.
Proof. induction 1; eauto. Qed.
Hint Resolve runsToEnd_star : core.

Lemma runsToEnd_trans : forall cs1 cs2 cs3,
                           runsToEnd cs1 cs2 ->
                           runsToEnd cs2 cs3 ->
                           runsToEnd cs1 cs3.
Proof. induction 1; eauto. Qed.
Hint Resolve runsToEnd_trans : core.

Lemma runsUntilUser_trans : forall s1 s2 s3,
                                      runsToEnd s1 s2 ->
                                      runsUntilUser s2 s3 ->
                                      runsUntilUser s1 s3.
Proof. induction 1; eauto. Qed.

(** Finally, [runsToEscape] is also similar to [runsToEnd] and
[runsUntilUser], but the final state can either be in user mode or in
kernel mode with an invalid pc, representing the fact that the
execution was stopped by the kernel code. *)

Inductive runsToEscape : CS -> CS -> Prop :=
| rte_success: (* executing until a return to user mode, all state in priv mode *)
    forall cs cs',
    forall (STAR: runsUntilUser cs cs' ),
      runsToEscape cs cs'
| rte_fail : (* executing the tmu until it fails at a neg. pc in priv mode, all in priv mode *)
    forall cs cs',
    forall (STAR: runsToEnd cs cs')
           (FAIL: fst (pc cs') < 0),
      runsToEscape cs cs'.

Lemma runsToEscape_plus: forall s1 s2,
 runsToEscape s1 s2 ->
 s1 <> s2 ->
 plus cstep s1 nil s2.
Proof.
  induction 1 ; intros; eauto.
Qed.

Lemma runsToEscape_star: forall s1 s2,
 runsToEscape s1 s2 ->
 star cstep s1 nil s2.
Proof.
  inversion 1; eauto.
Qed.

End CExec.

Hint Constructors runsUntilUser runsToEnd : core.
Hint Resolve runsUntilUser_l runsUntilUser_r : core.


Require Import Coq.omega.Omega.
Require Export BoilerplateSemantics.
Set Implicit Arguments.

(******************************************************************************)
(* Well-formedness                                                            *)
(******************************************************************************)

Lemma tyeq_kinding {Γ T U K} : TyEq Γ T U K → Kinding Γ T K ∧ Kinding Γ U K.
Proof.
  induction 1; destruct_conjs; repeat econstructor;
    eauto using subst_etvar_kinding.
Qed.

Lemma tyeq_kinding_left {Γ T U K} : TyEq Γ T U K → Kinding Γ T K.
Proof. apply tyeq_kinding. Qed.

Lemma tyeq_kinding_right {Γ T U K} : TyEq Γ T U K → Kinding Γ U K.
Proof. apply tyeq_kinding. Qed.

Lemma tred_tyeq {Γ S T K} : TRed Γ S T K → TyEq Γ S T K.
Proof.
  induction 1; try (econstructor; eauto using K_TVar; fail); eapply Q_Trans;
    [ eauto using Q_App, Q_Abs | eauto using Q_AppAbs, tyeq_kinding_right ].
Qed.

Lemma tredstar_tyeq {Γ S T K} : TRedStar Γ S T K → TyEq Γ S T K.
Proof.
  induction 1; try (econstructor; eauto; fail); eauto using Q_Trans, tred_tyeq.
Qed.

Hint Extern 2 (Kinding _ _ _) =>
  match goal with
    | H: TyEq     _ _ _ _ |- _ =>
      destruct (tyeq_kinding H); clear H
    | H: TRed     _ _ _ _ |- _ =>
      destruct (tyeq_kinding (tred_tyeq H)); clear H
    | H: TRedStar _ _ _ _ |- _ =>
      destruct (tyeq_kinding (tredstar_tyeq H)); clear H
  end.

Lemma tred_kinding_left {Γ T U K} : TRed Γ T U K → Kinding Γ T K.
Proof. eauto. Qed.

Lemma tred_kinding_right {Γ T U K} : TRed Γ T U K → Kinding Γ U K.
Proof. eauto. Qed.

(* Definition 30.3.18 *)
Inductive wf_env : Env → Prop :=
  | wf_empty                      : wf_env empty
  | wf_evar  {Γ T} (wΓ: wf_env Γ) : Kinding Γ T star → wf_env (evar Γ T)
  | wf_etvar {Γ K} (wΓ: wf_env Γ) : wf_env (etvar Γ K).

(* 30.3.19 *)
Lemma lookup_evar_kinding {Γ} (wΓ: wf_env Γ) :
  ∀ {x T}, lookup_evar Γ x T → Kinding Γ T star.
Proof.
  induction wΓ; inversion 1; subst; simpl;
    eauto using shift_etvar_kinding, shift_evar_kinding.
Qed.

Lemma typing_kinding {Γ t T} (wfΓ : wf_env Γ) (wt: Typing Γ t T) :
  Kinding Γ T star.
Proof.
  induction wt; eauto using lookup_evar_kinding;
    try (econstructor; eauto; fail).
  - constructor; auto.
    specialize (IHwt (wf_evar wfΓ H)).
    eauto using strengthening_var_kinding.
  - specialize (IHwt1 wfΓ).
    dependent destruction IHwt1; auto.
  - constructor; eauto using wf_env.
  - specialize (IHwt wfΓ).
    dependent destruction IHwt.
    eauto using subst_etvar_kinding.
Qed.

Lemma QR_Refl {Γ T K} (wT: Kinding Γ T K) : TRed Γ T T K.
Proof.
  induction wT; econstructor; eauto.
Qed.

Lemma QRS_Trans {Γ S T U K} :
  TRedStar Γ S T K → TRedStar Γ T U K → TRedStar Γ S U K.
Proof.
  intros P Q; revert S P; induction Q; simpl; eauto using QRS_Cons.
Qed.

Lemma QRS_Arrow1 {Γ S1 S2} (r: TRedStar Γ S1 S2 star) :
  ∀ {T}, Kinding Γ T star → TRedStar Γ (tarr S1 T) (tarr S2 T) star.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_Arrow2 {Γ T1 T2} (r: TRedStar Γ T1 T2 star) :
  ∀ {S}, Kinding Γ S star → TRedStar Γ (tarr S T1) (tarr S T2) star.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_Arrow {Γ S1 S2 T1 T2} :
  TRedStar Γ S1 S2 star → TRedStar Γ T1 T2 star →
  TRedStar Γ (tarr S1 T1) (tarr S2 T2) star.
Proof.
  intros; eapply QRS_Trans;
  [ eauto using QRS_Arrow1 | eauto using QRS_Arrow2 ].
Qed.

Lemma QRS_Abs {Γ K K2 S T} (r: TRedStar (etvar Γ K) S T K2) :
  TRedStar Γ (tabs K S) (tabs K T) (karr K K2).
Proof.
  depind r; econstructor; eauto using Kinding, TRed.
Qed.

Lemma QRS_App1 {Γ S T K K2} (r: TRedStar Γ S T (karr K K2)) :
  ∀ U, Kinding Γ U K → TRedStar Γ (tapp S U) (tapp T U) K2.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_App2 {Γ T U K K2} (r: TRedStar Γ T U K) :
  ∀ S, Kinding Γ S (karr K K2) → TRedStar Γ (tapp S T) (tapp S U) K2.
Proof.
  depind r; simpl; econstructor; eauto using QR_Refl, Kinding, TRed.
Qed.

Lemma QRS_App {Γ S1 T1 S2 T2 K K2} :
  TRedStar Γ S1 T1 (karr K K2) → TRedStar Γ S2 T2 K →
  TRedStar Γ (tapp S1 S2) (tapp T1 T2) K2.
Proof.
  intros; eapply QRS_Trans;
  [ eauto using QRS_App1 | eauto using QRS_App2 ].
Qed.

Lemma QRS_All {Γ K S T} (r: TRedStar (etvar Γ K) S T star) :
  TRedStar Γ (tall K S) (tall K T) star.
Proof.
  depind r; simpl; econstructor; eauto using Kinding, TRed.
Qed.

(******************************************************************************)
(* Confluence                                                                 *)
(******************************************************************************)

(* Lemma 30.3.6 *)
Inductive subst_tred : nat → Ty → Ty → Env → Env → Prop :=
  | sr_here {Γ T U K} :
      TRed Γ T U K → subst_tred 0 T U (etvar Γ K) Γ
  | sr_tvar {Γ1 Γ2 X T U K} :
      subst_tred X T U Γ1 Γ2 →
      subst_tred (S X) T U (etvar Γ1 K) (etvar Γ2 K).
Hint Constructors subst_tred.

Lemma subst_tred_index {Γ1 Γ2 X S1 S2} (esub: subst_tred X S1 S2 Γ1 Γ2) :
  ∀ {Y K}, lookup_etvar Γ1 Y K →
    TRed Γ2 (tsubstIndex X S1 Y) (tsubstIndex X S2 Y) K.
Proof.
  induction esub; inversion 1; subst; simpl; repeat constructor;
    eauto using shift_etvar_tred.
Qed.

(* Lemma 30.3.7 *)
Lemma subst_tred_tred {S1 S2 Γ1 T1 T2 K} (r: TRed Γ1 T1 T2 K) :
  ∀ {Y Γ2}, subst_tred Y S1 S2 Γ1 Γ2 →
    TRed Γ2 (tsubstTy Y S1 T1) (tsubstTy Y S2 T2) K.
Proof.
  induction r; simpl; intros; try rewrite tsubstTy_tsubstTy_comm;
    try econstructor; eauto using subst_tred_index.
Qed.

Fixpoint tred_complete (T : Ty) : Ty :=
  match T with
    | tvar X              => tvar X
    | tabs K T            => tabs K (tred_complete T)
    | tapp (tabs K T1) T2 => tsubstTy 0 (tred_complete T2) (tred_complete T1)
    | tapp T1 T2          => tapp (tred_complete T1) (tred_complete T2)
    | tarr T1 T2          => tarr (tred_complete T1) (tred_complete T2)
    | tall K T            => tall K (tred_complete T)
  end.

Lemma tred_triangle {Γ S T K} (r : TRed Γ S T K) : TRed Γ T (tred_complete S) K.
Proof with simpl; eauto using QR_Refl, TRed.
  induction r; intros...
  - dependent destruction r1...
    dependent destruction IHr1...
  - eauto using subst_tred_tred.
Qed.

(* Lemma 30.3.8 *)
Lemma tred_single_step_diamond :
  ∀ {Γ S T U K}, TRed Γ S T K → TRed Γ S U K →
    ∃ V, TRed Γ T V K ∧ TRed Γ U V K.
Proof.
  intros; exists (tred_complete S); eauto using tred_triangle.
Qed.

(* Lemma 30.3.9 *)
Lemma tred_strip {Γ S U K} (r: TRedStar Γ S U K) :
  ∀ V, TRed Γ S V K → ∃ W, TRed Γ U W K ∧ TRedStar Γ V W K.
Proof.
  induction r; simpl; intros V SV.
  - eauto using QRS_Nil.
  - destruct (IHr V SV) as (W & TV & VW).
    destruct (tred_single_step_diamond TV H) as (Z & UZ & VZ).
    eauto using QRS_Cons.
Qed.

Lemma tred_confluence {Γ S T V K} :
  TRedStar Γ S T K → TRedStar Γ S V K →
  ∃ W, TRedStar Γ T W K ∧ TRedStar Γ V W K.
Proof.
  intros ST; revert V; induction ST; intros V SV.
  - eauto using TRedStar.
  - destruct (IHST _ SV) as (W & TW & VW).
    destruct (tred_strip TW H) as (Z & WZ & UZ).
    eauto using QRS_Cons.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

(* Lemma 30.3.11 *)
Lemma teq_tred {Γ S T K} (eq : TyEq Γ S T K) :
  ∃ U, TRedStar Γ S U K ∧ TRedStar Γ T U K.
Proof.
  induction eq.
  - destruct_conjs; eauto using QRS_Arrow.
  - destruct_conjs; eauto using QRS_Abs.
  - destruct_conjs; eauto using QRS_App.
  - destruct_conjs; eauto using QRS_All.
  - exists (tsubstTy 0 T2 T12); split.
    + eauto 10 using TRedStar, TRed, K_App, K_Abs, QR_Refl.
    + eauto using QRS_Nil, subst_etvar_kinding.
  - eauto using QRS_Nil.
  - destruct_conjs; eauto.
  - destruct IHeq1 as [V1 [SV1 UV1]].
    destruct IHeq2 as [V2 [UV2 TV2]].
    destruct (tred_confluence UV1 UV2) as [V [V1V V2V]].
    eauto using QRS_Trans.
Qed.

(* Lemma 30.3.12.1 *)
Lemma tred_tarr_preservation {Γ S1 S2 T} (H : TRedStar Γ (tarr S1 S2) T star) :
  ∃ T1 T2, T = tarr T1 T2 ∧ TRedStar Γ S1 T1 star ∧ TRedStar Γ S2 T2 star.
Proof.
  depind H; simpl; intros.
  - dependent destruction H. eauto 10 using TRedStar.
  - destruct (IHTRedStar) as [T1 [T2 [Teq [S1T1 S2T2]]]]; subst.
    dependent destruction H0; eauto 10 using TRedStar.
Qed.

(* Lemma 30.3.12.2 *)
Lemma tred_tall_preservation {Γ K1 S2 T} (H : TRedStar Γ (tall K1 S2) T star) :
  ∃ T2, T = tall K1 T2 ∧ TRedStar (etvar Γ K1) S2 T2 star.
Proof.
  depind H; simpl; intros.
  - dependent destruction H.
    exists S2; repeat split; auto; constructor; auto.
  - destruct (IHTRedStar) as [T1 [Teq S2T2]]; subst.
    dependent destruction H0.
    exists T2; repeat split; auto.
    apply (QRS_Cons S2T2 H0).
Qed.

Lemma can_form_tarr' {t S T1 T2} (v: Value t) (wt: Typing empty t S) :
  TyEq empty S (tarr T1 T2) star → ∃ t' T1', t = abs T1' t'.
Proof.
  depind wt; intros; try contradiction; eauto using Q_Trans.
  - destruct (teq_tred H) as [V [H1 H2]].
    destruct (tred_tarr_preservation H2) as [T3 [T4 [Teq]]].
    destruct (tred_tall_preservation H1) as [T5 [Teq2]].
    subst; discriminate.
Qed.

Lemma can_form_tarr {t T1 T2} (v: Value t) (wt: Typing empty t (tarr T1 T2)) :
  ∃ t' T1', t = abs T1' t'.
Proof.
  eapply (can_form_tarr' v wt).
  eauto using Q_Refl, wf_empty, typing_kinding.
Qed.

Lemma can_form_tall' {t S} (v: Value t) (wt: Typing empty t S) :
  ∀ K1 T2, TyEq empty S (tall K1 T2) star →
  ∃ t' K1', t = tyabs K1' t'.
Proof.
  depind wt; intros; try contradiction; eauto using Q_Trans.
  - destruct (teq_tred H0) as [V [H1 H2]].
    destruct (tred_tarr_preservation H1) as [T3 [T4 [Teq]]].
    destruct (tred_tall_preservation H2) as [T5 [Teq2]].
    subst; discriminate.
Qed.

Lemma can_form_tall {t K1 T2} (v: Value t) (wt: Typing empty t (tall K1 T2)) :
  ∃ t' K1', t = tyabs K1' t'.
Proof.
  eapply (can_form_tall' v wt).
  eauto using Q_Refl, wf_empty, typing_kinding.
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with destruct_conjs; subst; eauto using red.
  depind wt; simpl; auto.
  - inversion H.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [v1|[t1' r1]]...
    destruct (can_form_tall v1 wt)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma tyeq_tarr_inversion {Γ S1 S2 T1 T2} :
  TyEq Γ (tarr S1 S2) (tarr T1 T2) star →
  TyEq Γ S1 T1 star ∧ TyEq Γ S2 T2 star.
Proof.
  intro q; destruct (teq_tred q) as [V [SV TV]].
  destruct (tred_tarr_preservation TV) as [V1' [V2' [Veq' [T1V1 T2V2]]]].
  destruct (tred_tarr_preservation SV) as [V1 [V2 [Veq [S1V1 S2V2]]]]; subst.
  dependent destruction Veq; split; eapply Q_Trans;
    eauto using tredstar_tyeq, Q_Symm.
Qed.

Lemma abs_inversion' {Γ S S1 s2} (wt: Typing Γ (abs S1 s2) S) :
  ∀ {T1 T2}, TyEq Γ S (tarr T1 T2) star →
        TyEq Γ T1 S1 star ∧ Typing (evar Γ S1) s2 T2.
Proof.
  depind wt; simpl; intros; eauto using Q_Trans.
  - destruct (tyeq_tarr_inversion H0);
      eauto using Q_Symm, T_Eq.
Qed.

Lemma abs_inversion {Γ S1 T1 T2 s2} (wΓ: wf_env Γ)
  (wt: Typing Γ (abs S1 s2) (tarr T1 T2)) :
  TyEq Γ T1 S1 star ∧ Typing (evar Γ S1) s2 T2.
Proof.
  apply abs_inversion' with (1 := wt);
    eauto using Q_Refl, typing_kinding.
Qed.

Lemma tyeq_tall_inversion {Γ J1 K1 S2 T2} :
  TyEq Γ (tall J1 S2) (tall K1 T2) star →
  J1 = K1 ∧ TyEq (etvar Γ K1) S2 T2 star.
Proof.
  intro q; destruct (teq_tred q) as [V [SV TV]].
  destruct (tred_tall_preservation TV) as [V2' [Veq' T2V2]].
  destruct (tred_tall_preservation SV) as [V2  [Veq S2V2]]; subst.
  dependent destruction Veq; split; auto; eapply Q_Trans;
    eauto using tredstar_tyeq, Q_Symm.
Qed.

Lemma tabs_inversion' {Γ S J1 s2} (wt: Typing Γ (tyabs J1 s2) S) :
  ∀ K1 T2, TyEq Γ S (tall K1 T2) star → J1 = K1 ∧ Typing (etvar Γ K1) s2 T2.
Proof.
  depind wt; simpl; intros.
  - destruct (tyeq_tall_inversion H); subst; eauto using T_Eq.
  - apply IHwt; eauto using Q_Trans.
Qed.

Lemma tabs_inversion {Γ J1 K1 T2 s2} (wΓ: wf_env Γ)
  (wt: Typing Γ (tyabs J1 s2) (tall K1 T2)) :
  J1 = K1 ∧ Typing (etvar Γ J1) s2 T2.
Proof.
  assert (J1 = K1 ∧ Typing (etvar Γ K1) s2 T2).
  apply (tabs_inversion' wt); eauto using Q_Refl, typing_kinding.
  destruct_conjs; subst; auto.
Qed.

Lemma preservation {Γ t U} (wΓ: wf_env Γ) (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - destruct (abs_inversion wΓ wt1) as [eq11 wt12].
    eauto using T_Eq.
  - destruct (tabs_inversion wΓ wt) as [e11 wt12]; subst; eauto.
Qed.


(* * Prenex Normal Form *)
From Undecidability.FOL.Syntax Require Import Core Facts Asimpl.
From Undecidability.FOL.Semantics.Tarski Require Import FullCore FullFacts.
From Undecidability.FOL.Arithmetics Require Import Signature.
Require Import Lia Vector List.
Import Vector.VectorNotations.
Import List.ListNotations.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

Local Notation vec := Vector.t.

Section PNFrules.
  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {D: Type} {i: interp D}.

  Definition DN := forall P, ~~P -> P.
  Definition IndependenceOfGeneralPremises :=
    forall (d : D) (P:D -> Prop) (Q:Prop),
      (Q -> exists x, P x) -> exists x, (Q -> P x).

  Lemma DN_to_IndependenceOfGeneralPremises :
    DN -> IndependenceOfGeneralPremises.
  Proof. intros DN. unfold IndependenceOfGeneralPremises.
        intros d P Q H. apply DN. intros nH. apply nH.
        exists d. intros q. exfalso. apply nH.
        specialize (H q) as [x Px]. now exists x.
  Qed.

  Lemma up_equiv {b:falsity_flag}:
    forall ρ ϕ x, sat ρ ϕ <-> sat (x.:ρ) ϕ[↑].
  Proof.
    intros. split.
    - intros. apply sat_comp. eapply sat_ext; eauto.
    - intros H%sat_comp. eapply sat_ext; eauto.
  Qed.

  Lemma PNF_allAnd {b:falsity_flag}:
    forall ρ ϕ ψ, sat ρ ((∀ ϕ) ∧ ψ ↔ ∀ ϕ ∧ ψ[↑]).
  Proof.
    split; cbn.
    - intros []. split; [auto | now apply up_equiv].
    - intros H. split.
      + intros. now specialize (H d) as [H1 H2%sat_comp].
      + destruct (H (ρ 42)). eapply up_equiv, H1.
  Qed.

  Lemma PNF_andAll {b:falsity_flag}:
    forall ρ ϕ ψ, sat ρ (ϕ ∧ (∀ ψ) ↔ ∀ ϕ[↑] ∧ ψ).
  Proof.
    intros ρ ϕ ψ. specialize (PNF_allAnd ρ ψ ϕ) as H. cbn in *. firstorder.
  Qed.

  Lemma PNF_all_Or1 {b:falsity_flag}:
    forall ρ ϕ ψ, sat ρ ((∀ ϕ) ∨ ψ → ∀ ϕ ∨ ψ[↑]).
  Proof.
    cbn.
    intros ρ ϕ ψ [] d.
    + now left.
    + right. now apply up_equiv.
  Qed.

  Lemma PNF_all_Or2 {b:falsity_flag}:
    DN -> forall ρ ϕ ψ, sat ρ ((∀ ϕ ∨ ψ[↑]) → ((∀ ϕ) ∨ ψ)) .
  Proof.
    cbn. intros DN ρ ϕ ψ H. (* TODO vlt. de Morgan = wxm*)
      apply DN. intros nH. apply nH. left. intros d. specialize (H d) as [H | H].
        + auto.
        + exfalso. apply nH. right. eapply up_equiv, H.
  Qed.

  Lemma PNF_allOr {b:falsity_flag}:
    DN -> forall ρ ϕ ψ, sat ρ (((∀ ϕ) ∨ ψ) ↔ (∀ ϕ ∨ ψ[↑])).
  Proof.
    intros DN. split; [apply PNF_all_Or1|apply PNF_all_Or2, DN].
  Qed.

  Lemma PNF_orAll {b:falsity_flag}:
    DN -> forall ρ ϕ ψ, sat ρ ((ϕ ∨ (∀ψ) ↔ (∀ ϕ[↑] ∨ ψ))).
  Proof.
    intros DN ρ ϕ ψ. specialize (PNF_allOr DN ρ ψ ϕ) as H. cbn in *. revert H. clear. firstorder.
  Qed.

  Lemma PNF_existsAnd {b:falsity_flag}:
    forall ρ ϕ ψ, sat ρ (((∃ ϕ) ∧ ψ) ↔ (∃ ϕ ∧ ψ[↑])).
  Proof.
    split; cbn.
    - intros [[]]. eexists. split; [eauto | now apply up_equiv].
    - intros [? []]. split; [|eapply up_equiv]; eauto.
  Qed.

  Lemma PNF_andExists {b: falsity_flag}:
    forall ρ ϕ ψ, sat ρ ((ϕ ∧ ∃ ψ) ↔ (∃ ϕ[↑] ∧ ψ)).
  Proof.
    intros ρ ϕ ψ. specialize (PNF_existsAnd ρ ψ ϕ) as H. cbn in *. revert H. clear. firstorder.
  Qed.

  Lemma PNF_existsOr {b:falsity_flag}:
    forall ρ ϕ ψ, sat ρ ((∃ ϕ) ∨ ψ ↔ ∃ ϕ ∨ ψ[↑]).
  Proof.
    split; cbn.
    - intros [[d H]|H].
      + exists d. now left.
      + exists (ρ 1337). right. now apply up_equiv.
    - intros [d [H|H]].
      + left. eauto.
      + right. eapply up_equiv, H.
  Qed.

  Lemma PNF_orExists {b:falsity_flag}:
    forall ρ ϕ ψ, sat ρ (ϕ ∨ (∃ ψ) ↔ ∃ ϕ[↑] ∨ ψ).
  Proof.
    intros ρ ϕ ψ. specialize (PNF_existsOr ρ ψ ϕ) as H. cbn in *. revert H. clear. firstorder.
  Qed.

  Lemma PNF_allImpl1 {b: falsity_flag}:
    DN -> forall ρ ϕ ψ, sat ρ (((∀ ϕ) → ψ) → (∃ ϕ → ψ[↑])).
  Proof.
    cbn.
    intros DN ρ ϕ ψ A. apply DN. intros nE.
    apply nE. exists (ρ 27). intros H. apply up_equiv. apply A. intros d.
    apply DN. intros nH. apply nE. exists d. contradiction.
  Qed.

  Lemma PNF_allImpl2 {b: falsity_flag}:
    forall ρ ϕ ψ, sat ρ ((∃ ϕ → ψ[↑]) → ((∀ ϕ) → ψ)).
  Proof.
    cbn. intros ? ? ? [] ?. eapply up_equiv. eauto.
  Qed.

  Lemma PNF_allImpl {b: falsity_flag}:
    DN -> forall ρ ϕ ψ, sat ρ (((∀ ϕ) → ψ) ↔ (∃ ϕ → ψ[↑])).
  Proof.
    intros DN. split; [apply PNF_allImpl1, DN| apply PNF_allImpl2].
  Qed.

  Lemma PNF_existsImpl {b: falsity_flag}:
    forall ρ ϕ ψ, sat ρ (((∃ ϕ) → ψ) ↔ (∀ ϕ → ψ[↑])).
  Proof.
    split; cbn.
    - intros. apply up_equiv. eauto.
    - intros ? []. eapply up_equiv. eauto.
  Qed.

  Lemma PNF_implAll {b: falsity_flag}:
    forall ρ ϕ ψ, sat ρ ((ϕ → ∀ ψ) ↔ (∀ ϕ[↑] → ψ)).
  Proof.
    split; cbn.
    - intros ? ? ?%up_equiv. auto.
    - intros H ? d. apply H. now apply up_equiv.
  Qed.

  Lemma PNF_implExists {b: falsity_flag}:
  IndependenceOfGeneralPremises -> forall ρ ϕ ψ, sat ρ ((ϕ → ∃ ψ) ↔ ∃ ϕ[↑] → ψ).
  Proof.
    intros IndependenceOfGeneralPremises.
    split; cbn. (* todo indepentence of premise *) (* markov **)
    - intros H.
      assert (exists d : D, ((forall d, (d .: ρ) ⊨ ϕ[↑]) -> (d .: ρ) ⊨ ψ)) as [d H']. {
        apply (IndependenceOfGeneralPremises (ρ 42)).
        intros H'. apply H. specialize (H' (ρ 27)). apply sat_comp in H'.
          eapply sat_ext. 2: exact H'. reflexivity.
      }
      exists d. intros H''. apply H'. intros d'. apply sat_comp. apply sat_comp in H''.
      eapply sat_ext. 2: exact H''. reflexivity.
    - intros [d H] ?. eexists. apply H. now apply up_equiv.
  Qed.

  Lemma equivTrans {ff: falsity_flag} ρ a b c :
    ρ ⊨ (a ↔ b) -> ρ ⊨ (c ↔ b) -> ρ ⊨ (a ↔ c).
  Proof. firstorder. Qed.

  Lemma equivToCoq {ff: falsity_flag} ρ a b :
    ρ ⊨ (a ↔ b) -> ρ ⊨ a <-> ρ ⊨ b.
  Proof. firstorder. Qed.

  Lemma PNF_notExists:
    forall ρ ϕ, sat ρ ((¬∃ ϕ) ↔ (∀ ¬ϕ)).
  Proof.
    intros ? ?.
    eapply equivTrans; [apply PNF_existsImpl | now cbn].
  Qed.

  Lemma PNF_notAll:
    DN -> forall ρ ϕ, sat ρ (¬∀ ϕ) <-> sat ρ (∃ ¬ϕ).
  Proof.
    intros DN ? ?.
    eapply equivTrans; [apply (PNF_allImpl DN) | now cbn].
  Qed.

End PNFrules.

Section PrenexNormalForm.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {D: Type} {i: interp D}.

  Fixpoint noQuant_bool `{falsity_flag} (f: form) : bool :=
    match f with
    | falsity => true
    | atom P v => true
    | bin op ϕ1 ϕ2 => noQuant_bool ϕ1 && noQuant_bool ϕ2
    | quant op ϕ => false
    end.

  Fixpoint isPNF_bool `{falsity_flag} (f: form) : bool :=
    match f with
    | falsity => true
    | atom P v => true
    | bin op ϕ1 ϕ2 => noQuant_bool ϕ1 && noQuant_bool ϕ2
    | quant op ϕ => isPNF_bool ϕ
    end.

  Inductive noQuant_ind : forall b, form b -> Prop :=
  | nQ_false : noQuant_ind falsity
  | nQ_atom {b} P v : noQuant_ind ((atom P v): form b)
  | nQ_bin {b} op (ϕ1 ϕ2: form b) : noQuant_ind ϕ1 -> noQuant_ind ϕ2 -> noQuant_ind (bin op ϕ1 ϕ2).

  Inductive PNF_ind : forall b, form b -> Prop :=
  | PNF_noQuant {b} ϕ : @noQuant_ind b ϕ -> PNF_ind ϕ
  | PNF_quant {b} op (ϕ: form b) : PNF_ind ϕ -> PNF_ind (quant op ϕ).

  #[local] Hint Constructors noQuant_ind : core.
  #[local] Hint Constructors PNF_ind : core.

  Lemma noQuand_ind_inv {ff: falsity_flag} {ϕ} (nQ : noQuant_ind ϕ) :
    match ϕ with
    | bin op φ1 φ2 => noQuant_ind φ1 /\ noQuant_ind φ2
    | quant _ _ => False
    | _ => True
    end.
  Proof.
    induction nQ; easy.
  Qed.

  Lemma PNF_ind_inversion {ff: falsity_flag} {ϕ} (pnf : PNF_ind ϕ) :
    match ϕ with
    | quant op φ => PNF_ind φ
    | _ => noQuant_ind ϕ
    end.
  Proof.
    induction pnf; destruct ϕ; easy.
  Qed.

  Fixpoint noQuant_ind_rec
    (P : forall b : falsity_flag, form -> Type)
    (H0 : P falsity_on ⊥)
    (H1 : forall (b : falsity_flag) (P0 : Σ_preds) (v : vec term (ar_preds P0)), P b (atom P0 v : form))
    (H2 : forall (b : falsity_flag) (op : binop) (ϕ1 ϕ2 : form), noQuant_ind ϕ1 -> P b ϕ1 -> noQuant_ind ϕ2 -> P b ϕ2 -> P b (bin op ϕ1 ϕ2))
    {b : falsity_flag} (f : form) (nQ : noQuant_ind f)
    : P b f.
  Proof.
    destruct f.
    - apply H0.
    - apply H1.
    - apply H2.
      + now destruct (noQuand_ind_inv nQ).
      + apply noQuant_ind_rec; try assumption. now destruct (noQuand_ind_inv nQ).
      + now destruct (noQuand_ind_inv nQ).
      + apply noQuant_ind_rec; try assumption. now destruct (noQuand_ind_inv nQ).
    - now destruct (noQuand_ind_inv nQ).
  Defined.

  Fixpoint PNF_ind_rec
    (P : forall b : falsity_flag, form -> Type)
    (H0 : forall (b : falsity_flag) (ϕ : form), noQuant_ind ϕ -> P b ϕ)
    (H1 : forall (b : falsity_flag) (op : quantop) (ϕ : form), PNF_ind ϕ -> P b ϕ -> P b (quant op ϕ))
    {b : falsity_flag} (f : form) (p : PNF_ind f)
    : P b f.
  Proof.
    destruct f.
    - apply H0. constructor.
    - apply H0. now constructor.
    - apply H0. apply (PNF_ind_inversion p).
    - apply PNF_ind_inversion in p.
      apply H1.
      + assumption.
      + now apply PNF_ind_rec.
  Defined.

  Lemma noQuant_agree (b: falsity_flag) (ϕ: form b):
    noQuant_ind ϕ <-> noQuant_bool ϕ = true.
  Proof.
    split.
    - intros nQi. induction nQi as [|b P v|b op ϕ1 ϕ2 nQi1 IH1 nQi2 IH2].
      + cbn. reflexivity.
      + cbn. reflexivity.
      + cbn. rewrite IH1, IH2. reflexivity.
    - induction ϕ as [|b P v|b op ϕ1 IH1 ϕ2 IH2|]; cbn in *.
      + constructor.
      + constructor.
      + destruct (noQuant_bool ϕ1), (noQuant_bool ϕ2); constructor; auto.
      + intros [=].
  Qed.

  Lemma PNF_agree (b: falsity_flag) (ϕ: form b):
    PNF_ind ϕ <-> isPNF_bool ϕ = true.
  Proof.
    induction ϕ as [|b P v|b op ϕ1 IH1 ϕ2 IH2|b op ϕ IHϕ]; cbn in *; split.
    - reflexivity.
    - econstructor. constructor.
    - reflexivity.
    - econstructor. constructor.
    - intros H.
      destruct (noQuand_ind_inv (PNF_ind_inversion H)).
      apply andb_true_intro. split; now apply noQuant_agree.
    - intros []%andb_prop. constructor. constructor; now apply noQuant_agree.
    - intros H. apply PNF_ind_inversion in H. now apply IHϕ.
    - intros. apply PNF_quant. now apply IHϕ.
  Qed.

  (** convert PNF definiton ***)
  Notation upN := (iter up) (only parsing).

  Notation shift k := (iter S k >> var).
  Definition shift_quant n k := upN n (shift k).

  Lemma iter_add_S a : iter S a = Nat.add a.
  Proof.
    induction a.
    - easy.
    - cbn. now rewrite IHa.
  Qed.

  Lemma upNup sig n :
    upN n (up sig) = up (upN n sig).
  Proof.
    now rewrite iter_switch.
  Qed.

  Lemma upN_explicit n sig j :
    upN n sig j = if Compare_dec.lt_dec j n then $j else (sig (j - n))`[shift n].
  Proof.
    destruct Compare_dec.lt_dec as [lt | geq].
    - induction j in lt, n |-*.
      + destruct n as [|n]; [lia|]. now cbn.
      + destruct n as [|n]; [lia|]. cbn.
        unfold funcomp. now rewrite IHj by lia.
    - induction n as [|n IH] in geq, j |-*.
      + replace (j - 0) with j by lia. now asimpl.
      + destruct j.
        * lia.
        * cbn. unfold funcomp. rewrite IH by lia. now asimpl.
  Qed.

  Lemma shift_quant_explicit n k j :
    shift_quant n k j = if Compare_dec.lt_dec j n then $j else $(k + j).
  Proof.
    unfold shift_quant.
    rewrite upN_explicit.
    destruct Compare_dec.lt_dec.
    - reflexivity.
    - cbn. unfold shift. f_equal. repeat rewrite iter_add_S. lia.
  Qed.

  Goal forall x, upN 4 (shift 38) x = ($0 .: $1 .: $2 .: $3 .: (shift 42)) x.
    unfold scons, funcomp. cbn.
    destruct x; [reflexivity|].
    destruct x; [reflexivity|].
    destruct x; [reflexivity|].
    destruct x; [reflexivity|].
    reflexivity.
  Qed.

  Open Scope list_scope.

  Fixpoint swap_quant (qs: list full_logic_quant): list full_logic_quant :=
    match qs with
    | [] => []
    | q::qs =>
      match q with
      | All => Ex::(swap_quant qs)
      | Ex => All::(swap_quant qs)
      end
    end.

  Fixpoint quant_list_to_form `{falsity_flag} (qs : list full_logic_quant) (f : form) : form :=
    match qs with
      | [] => f
      | q::qs => @quant _ _ full_operators _ q (quant_list_to_form qs f)
    end.

  Fixpoint conv_list `{falsity_flag} (f: form) : list full_logic_quant :=
    match f with
    | falsity => []
    | atom P v => []
    | bin op ϕ1 ϕ2 =>
      match op with
      | Impl => (swap_quant (conv_list ϕ1)) ++ (conv_list ϕ2)
      | _ => (conv_list ϕ1) ++ (conv_list ϕ2)
      end
    | quant op φ => op::(conv_list φ)
    end.

  Fixpoint conv_form `{falsity_flag} (f: form) : form :=
    match f with
    | falsity => falsity
    | atom P v => atom P v
    | bin op φ1 φ2 =>
        bin op
          ((conv_form φ1)[shift (length (conv_list φ2))])
          ((conv_form φ2)[shift_quant (length (conv_list φ2)) (length (conv_list φ1))])
    | quant op φ => conv_form φ
    end.

  Definition convert_PNF `{falsity_flag} (f : form) : form :=
    quant_list_to_form (conv_list f) (conv_form f).

  (** prove result is in PNF ***)

  Lemma noQuant_ind_subst `{falsity_flag} :
    forall φ s, noQuant_ind φ -> noQuant_ind φ[s].
  Proof.
    intros φ s. induction 1; cbn; now constructor.
  Qed.

  Lemma conv_form_noQuant `{falsity_flag} φ :
    noQuant_ind (conv_form φ).
  Proof.
    induction φ as [|b P v|b op ϕ1 IH1 ϕ2 IH2|b op ϕ IHφ]; cbn.
    - constructor.
    - constructor.
    - destruct op; constructor; now apply noQuant_ind_subst.
    - exact IHφ.
  Qed.

  Lemma list_noQuant_PNF `{b: falsity_flag} qs ϕ :
    noQuant_ind ϕ -> PNF_ind (quant_list_to_form qs ϕ).
  Proof.
    induction qs as [|q qs].
    - now constructor.
    - intros H. cbn. apply PNF_quant. auto.
  Qed.

  Lemma convert_PNF_PNF `{falsity_flag} : forall ϕ, PNF_ind (convert_PNF ϕ).
  Proof.
    intros ϕ. unfold convert_PNF.
    apply list_noQuant_PNF, conv_form_noQuant.
  Qed.

  (** prove result in PNF is equivilant ***)

  Lemma quant_list_to_form_equiv {b: falsity_flag} qs ϕ1 ϕ2:
    (forall ρ, sat ρ ϕ1 <-> sat ρ ϕ2) -> forall ρ, sat ρ (quant_list_to_form qs ϕ1) <-> sat ρ (quant_list_to_form qs ϕ2).
  Proof.
    induction qs as [|[] ? ?]; firstorder.
  Qed.

  Lemma shift_one_more {b: falsity_flag} φ n :
    φ[shift (S n)] = φ[↑][shift n].
  Proof.
    asimpl. apply subst_ext. intros m. unfold shift, funcomp.
    now rewrite iter_switch.
  Qed.

  Lemma shift_quant_0 n : feq (shift_quant n 0) var.
  Proof.
    unfold shift_quant. intros x.
    enough (forall sigma, (forall x, sigma x = $x) -> (forall x, upN n sigma x = $x)) by auto.
    induction n.
    - now intros.
    - intros sig Hsig. cbn. rewrite iter_switch.
      apply IHn. unfold up.
      unfold scons. intros [|y]; [reflexivity|].
      unfold funcomp. now rewrite Hsig.
  Qed.

  Lemma shift_quant_add n a b x :
    (shift_quant n a x)`[shift_quant n b] = shift_quant n (a+b) x.
  Proof.
  unfold shift_quant, shift. induction n in a,b,x|-*.
  - cbn. f_equal. rewrite !iter_add_S. lia.
  - destruct x as [|x].
    + easy.
    + cbn. unfold funcomp at 3. rewrite <- IHn.
      rewrite !iter_add_S. unfold funcomp. rewrite !subst_term_comp.
      easy.
  Qed.

  Lemma shift_quant_1 {b: falsity_flag} φ n m:
    φ[shift_quant n 1][shift_quant n m] =
    φ[shift_quant n (S m)].
  Proof.
    asimpl. apply subst_ext.
    intros p. unfold funcomp. apply shift_quant_add.
  Qed.

  Lemma quant_list_to_form_rename_free {b: falsity_flag} sigma qs φ:
  quant_list_to_form qs φ [upN (length qs) sigma]
  = (quant_list_to_form qs φ)[sigma].
  Proof.
    induction qs as [|q qs IH] in sigma |-*.
    - now apply subst_ext.
    - cbn [quant_list_to_form]. cbn. f_equal. rewrite iter_switch. apply IH.
  Qed.

  Lemma quant_list_to_form_rename_free_up {b: falsity_flag} qs φ:
    quant_list_to_form qs φ [shift_quant (length qs) 1] = (quant_list_to_form qs φ)[↑].
  Proof.
    now erewrite <- (quant_list_to_form_rename_free).
  Qed.

  Lemma AllEquivAll :
    forall p q: D -> Prop, (forall d, (p d) <-> (q d)) -> ((forall d, (p d)) <-> forall d, (q d)).
  Proof. firstorder. Qed.

  Lemma ExEquivEx :
    forall p q: D -> Prop, (forall d, (p d) <-> (q d)) -> ((exists d, (p d)) <-> exists d, (q d)).
  Proof. firstorder. Qed.

  Lemma PNF_equiv_bin_op {b: falsity_flag} (DN: DN) ρ op φ1 φ2:
    ρ ⊨ ((convert_PNF (bin op φ1 φ2)) ↔ (bin op (convert_PNF φ1) (convert_PNF φ2))).
  Proof.
    unfold convert_PNF in *. cbn [conv_list conv_form].
    remember (conv_list φ1) as qs1. remember (conv_list φ2) as qs2.
    remember (conv_form φ1) as ψ1. remember (conv_form φ2) as ψ2.
    clear Heqqs1 Heqqs2 Heqψ1 φ1 Heqψ2 φ2.
    revert ρ ψ1 ψ2. induction qs1 as [| q1 qs1 IH1]; [induction qs2 as [|q2 qs2 IH2]|]; intros ρ φ1 φ2.
      + destruct op. all: cbn; split. all: repeat rewrite sat_comp. all: now setoid_rewrite (@sat_ext _ _ _ _ _ ρ ((shift 0 >> eval ρ))).
      + destruct op; destruct q2; cbn [app quant_list_to_form length].
        all: setoid_rewrite shift_quant_0.
        all: eapply equivTrans; [|apply PNF_andAll + apply PNF_andExists + apply (PNF_orAll DN) + apply PNF_orExists + apply PNF_implAll + apply (PNF_implExists (DN_to_IndependenceOfGeneralPremises DN))].
        all: assert (forall ρ a b, (ρ ⊨ (a ↔ b)) <-> (ρ ⊨ a <-> ρ ⊨ b)) as eqEquiv by firstorder.
        all: setoid_rewrite eqEquiv in IH2.
        all: cbn in *; apply AllEquivAll + apply ExEquivEx.
        all: intros d; rewrite <- IH2; apply quant_list_to_form_equiv.
        all: now setoid_rewrite shift_one_more; setoid_rewrite shift_quant_0.
      + destruct op; destruct q1; cbn [app quant_list_to_form].
        all: eapply equivTrans; [|apply PNF_allAnd + apply PNF_existsAnd + apply (PNF_allOr DN) + apply PNF_existsOr + apply (PNF_allImpl DN) + apply PNF_existsImpl].
        all: assert (forall ρ a b, (ρ ⊨ (a ↔ b)) <-> (ρ ⊨ a <-> ρ ⊨ b)) as eqEquiv by firstorder.
        all: setoid_rewrite eqEquiv in IH1.
        all: cbn in *; apply AllEquivAll + apply ExEquivEx.
        all: rewrite <- quant_list_to_form_rename_free_up; cbn in *.
        all: now intros d; rewrite <- IH1, shift_quant_1.
  Qed.

  Lemma PNF_equiv `{falsity_flag}:
    DN -> forall f ρ, sat ρ (f ↔ (convert_PNF f)).
  Proof.
    intros DN f ρ.
    induction f as [|b P v|b op ϕ1 IH1 ϕ2 IH2|b op ϕ IHϕ] in ρ |-*.
    - easy.
    - easy.
    - eapply equivTrans. 2: apply (PNF_equiv_bin_op DN).
      clear DN.
      destruct op; cbn in *.
      all: firstorder.
    - unfold convert_PNF in *. cbn.
      destruct op; firstorder.
  Qed.

End PrenexNormalForm.

(* PNF_equiv -> DN *)

Lemma PNF_equiv_DN : (forall (D : Type) (Σ_preds : preds_signature) (Σ_funcs : funcs_signature) (i : interp D) (ff : falsity_flag),
  forall (f : form) (ρ : env D), ρ ⊨ (f ↔ convert_PNF f)) -> DN.
Proof.
  intros H P nnP.
  specialize (H (option P) PA_preds_signature PA_funcs_signature).
  pose ({|
    i_func :=
      fun (_tmp : PA_funcs_signature) (_ : vec (option P) (ar_syms _tmp)) =>
      None;
    i_atom :=
      fun P0 : PA_preds_signature =>
      match P0 as p return (vec (option P) (ar_preds p) -> Prop) with
      | Eq =>
          fun v : vec (option P) (ar_preds Eq) =>
          Vector.hd v = Vector.hd (Vector.tl v)
      end
  |}) as i.
  specialize (H i falsity_on (¬(∀ ($0 == $1))) (fun _ => None)). cbn in H.
  destruct H as [[x H] _].
  - intros A. apply nnP. intros p. specialize (A (Some p)) as [=].
  - destruct x.
    + exact p.
    + contradiction.
Qed.


Inductive Either : Type -> Type -> Type :=
| Left : forall {A B : Type}, A -> Either A B
| Right : forall {A B : Type}, B -> Either A B.