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

 Composing a two-sided displayed category with a displayed category

 We show how to compose a two-sided displayed category with a displayed category.
 The idea is basically as follows: a two-sided displayed category represents a
 span and a displayed category represents a functor. Both legs of the span get
 composed with this functor to obtain a new span.

 More precisely, we have a two-sided displayed category and a displayed category
 over the total category of that two-sided displayed category. This displayed
 category represents structures/properties to be added to our two-sided displayed
 category. We then form a new two-sided displayed category by taking sigma-types.

 Contents
 1. The definition
 2. Isomorphisms
 3. Univalence and discreteness

 **********************************************************************************)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Projection.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.TwoSidedDispCat.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Isos.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Discrete.
Require Import UniMath.CategoryTheory.TwoSidedDisplayedCats.Total.

Local Open Scope cat.

Definition transportf_hset_eq
           {X : UU}
           {Y : X → UU}
           (Xisaset : isaset X)
           {x₁ x₂ : X}
           (p q : x₁ = x₂)
           (y : Y x₁)
  : transportf Y p y = transportf Y q y.
Proof.
  apply maponpaths_2.
  apply Xisaset.
Qed.

Section DispCatOnTwoSidedDispCat.
  Context {C₁ C₂ : category}
          (D₁ : twosided_disp_cat C₁ C₂)
          (D₂ : disp_cat (total_twosided_disp_category D₁)).

  (**
   1. The definition
   *)
  Definition sigma_twosided_disp_cat_ob_mor
    : twosided_disp_cat_ob_mor C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact (λ x y, ∑ (xy : D₁ x y), D₂ (x ,, y ,, xy)).
    - exact (λ x₁ x₂ y₁ y₂ xy₁ xy₂ f g,
             ∑ (fg : pr1 xy₁ -->[ f ][ g ] pr1 xy₂),
             pr2 xy₁ -->[ f ,, g ,, fg ] pr2 xy₂).
  Defined.

  Definition sigma_twosided_disp_cat_id_comp
    : twosided_disp_cat_id_comp sigma_twosided_disp_cat_ob_mor.
  Proof.
    simple refine (_ ,, _).
    - simple refine (λ x y xy, id_two_disp (pr1 xy) ,, _).
      apply (@id_disp (total_twosided_disp_category D₁) D₂).
    - exact (λ x₁ x₂ x₃ y₁ y₂ y₃ xy₁ xy₂ xy₃ f₁ f₂ g₁ g₂ fg₁ fg₂,
             pr1 fg₁ ;;2 pr1 fg₂
             ,,
             (pr2 fg₁ ;; pr2 fg₂)%mor_disp).
  Defined.

  Definition sigma_twosided_disp_cat_data
    : twosided_disp_cat_data C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact sigma_twosided_disp_cat_ob_mor.
    - exact sigma_twosided_disp_cat_id_comp.
  Defined.

  Definition sigma_twosided_disp_cat_mor_eq
             {x₁ x₂ : C₁}
             {y₁ y₂ : C₂}
             {f : x₁ --> x₂}
             {g : y₁ --> y₂}
             {xy₁ : sigma_twosided_disp_cat_data x₁ y₁}
             {xy₂ : sigma_twosided_disp_cat_data x₂ y₂}
             (fg₁ : xy₁ -->[ f ][ g ] xy₂)
             (fg₂ : xy₁ -->[ f ][ g ] xy₂)
             (p : pr1 fg₁ = pr1 fg₂)
             (q : transportf
                    (λ z, pr2 xy₁ -->[ z ] pr2 xy₂)
                    (maponpaths (λ z, f ,, g ,, z) p)
                    (pr2 fg₁)
                  =
                  pr2 fg₂)
    : fg₁ = fg₂.
  Proof.
    induction fg₁ as [ fg₁ fg₁' ].
    induction fg₂ as [ fg₂ fg₂' ].
    cbn in *.
    induction p.
    cbn in q.
    induction q.
    apply idpath.
  Qed.

  Section SigmaLeft.
    Context {x₁ x₂ : C₁}
            {f : x₁ --> x₂}
            {y₁ y₂ : C₂}
            {g₁ g₂ : y₁ --> y₂}
            (p : g₁ = g₂)
            {xy₁ : sigma_twosided_disp_cat_data x₁ y₁}
            {xy₂ : sigma_twosided_disp_cat_data x₂ y₂}
            (fg : xy₁ -->[ f ][ g₂ ] xy₂).

    Let q₁ : total_twosided_disp_category D₁ := x₁ ,, y₁ ,, pr1 xy₁.
    Let q₂ : total_twosided_disp_category D₁ := x₂ ,, y₂ ,, pr1 xy₂.
    Let h₁ : q₁ --> q₂ := f ,, g₂ ,, pr1 fg.
    Let h₂ : q₁ --> q₂ := f ,, g₁ ,, transportb (λ z, _ -->[ f ][ z ] _) p (pr1 fg).

    Definition sigma_transportb_left_path
      : h₁ = h₂.
    Proof.
      induction p.
      apply idpath.
    Defined.
  End SigmaLeft.

  Definition sigma_transportb_left
             {x₁ x₂ : C₁}
             {f : x₁ --> x₂}
             {y₁ y₂ : C₂}
             {g₁ g₂ : y₁ --> y₂}
             (p : g₁ = g₂)
             {xy₁ : sigma_twosided_disp_cat_data x₁ y₁}
             {xy₂ : sigma_twosided_disp_cat_data x₂ y₂}
             (fg : xy₁ -->[ f ][ g₂ ] xy₂)
      : transportb
          (λ z, xy₁ -->[ f ][ z ] xy₂)
          p
          fg
        =
        transportb
          (λ z, _ -->[ f ][ z ] _)
          p
          (pr1 fg)
        ,,
        transportf
          (λ z, @mor_disp _ D₂ _ _ (pr2 xy₁) (pr2 xy₂) z)
          (sigma_transportb_left_path p fg)
          (pr2 fg).
  Proof.
    induction p ; cbn.
    apply idpath.
  Qed.

  Section SigmaRight.
    Context {x₁ x₂ : C₁}
            {f₁ f₂ : x₁ --> x₂}
            (p : f₁ = f₂)
            {y₁ y₂ : C₂}
            {g : y₁ --> y₂}
            {xy₁ : sigma_twosided_disp_cat_data x₁ y₁}
            {xy₂ : sigma_twosided_disp_cat_data x₂ y₂}
            (fg : xy₁ -->[ f₂ ][ g ] xy₂).

    Let q₁ : total_twosided_disp_category D₁ := x₁ ,, y₁ ,, pr1 xy₁.
    Let q₂ : total_twosided_disp_category D₁ := x₂ ,, y₂ ,, pr1 xy₂.
    Let h₁ : q₁ --> q₂ := f₂ ,, g ,, pr1 fg.
    Let h₂ : q₁ --> q₂ := f₁ ,, g ,, transportb (λ z, _ -->[ z ][ g ] _) p (pr1 fg).

    Definition sigma_transportb_right_path
      : h₁ = h₂.
    Proof.
      induction p.
      apply idpath.
    Defined.
  End SigmaRight.

  Definition sigma_transportb_right
             {x₁ x₂ : C₁}
             {f₁ f₂ : x₁ --> x₂}
             (p : f₁ = f₂)
             {y₁ y₂ : C₂}
             {g : y₁ --> y₂}
             {xy₁ : sigma_twosided_disp_cat_data x₁ y₁}
             {xy₂ : sigma_twosided_disp_cat_data x₂ y₂}
             (fg : xy₁ -->[ f₂ ][ g ] xy₂)
    : transportb
        (λ z, xy₁ -->[ z ][ g ] xy₂)
        p
        fg
      =
      transportb
        (λ z, _ -->[ z ][ g ] _)
        p
        (pr1 fg)
      ,,
      transportf
        (λ z, @mor_disp _ D₂ _ _ (pr2 xy₁) (pr2 xy₂) z)
        (sigma_transportb_right_path p fg)
        (pr2 fg).
  Proof.
    induction p ; cbn.
    apply idpath.
  Qed.

  Definition sigma_twosided_disp_cat_axioms
    : twosided_disp_cat_axioms sigma_twosided_disp_cat_data.
  Proof.
    repeat split.
    - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg.
      rewrite sigma_transportb_left.
      rewrite sigma_transportb_right.
      use sigma_twosided_disp_cat_mor_eq.
      + apply id_two_disp_left.
      + cbn.
        unfold twosided_disp_cat_ob_mor_to_mor.
        etrans.
        {
          apply maponpaths.
          exact (@id_left_disp _ D₂ _ _ _ _ _ (pr2 fg)).
        }
        unfold transportb.
        rewrite !transport_f_f.
        apply transportf_hset_eq.
        apply (total_twosided_disp_category D₁).
    - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g fg.
      rewrite sigma_transportb_left.
      rewrite sigma_transportb_right.
      use sigma_twosided_disp_cat_mor_eq.
      + apply id_two_disp_right.
      + cbn.
        unfold twosided_disp_cat_ob_mor_to_mor.
        etrans.
        {
          apply maponpaths.
          exact (@id_right_disp _ D₂ _ _ _ _ _ (pr2 fg)).
        }
        unfold transportb.
        rewrite !transport_f_f.
        apply transportf_hset_eq.
        apply (total_twosided_disp_category D₁).
    - intros x₁ x₂ x₃ x₄ y₁ y₂ y₃ y₄ xy₁ xy₂ xy₃ xy₄ f₁ f₂ f₃ g₁ g₂ g₃ fg₁ fg₂ fg₃.
      rewrite sigma_transportb_left.
      rewrite sigma_transportb_right.
      use sigma_twosided_disp_cat_mor_eq.
      + apply assoc_two_disp.
      + cbn.
        unfold twosided_disp_cat_ob_mor_to_mor.
        etrans.
        {
          apply maponpaths.
          apply (@assoc_disp _ D₂ _ _ _ _ _ _ _ _ _ _ _ (pr2 fg₁) (pr2 fg₂) (pr2 fg₃)).
        }
        unfold transportb.
        rewrite !transport_f_f.
        apply transportf_hset_eq.
        apply (total_twosided_disp_category D₁).
    - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g.
      use isaset_total2.
      + apply isaset_disp_mor.
      + intro.
        apply homsets_disp.
  Qed.

  Definition sigma_twosided_disp_cat
    : twosided_disp_cat C₁ C₂.
  Proof.
    simple refine (_ ,, _).
    - exact sigma_twosided_disp_cat_data.
    - exact sigma_twosided_disp_cat_axioms.
  Defined.

  Definition sigma_mor_eq
             {x : C₁}
             {y : C₂}
             {xy : sigma_twosided_disp_cat x y}
             {f : x --> x}
             {g : y --> y}
             {fg₁ fg₂ : xy -->[ f ][ g ] xy}
             (p : fg₁ = fg₂)
    : pr2 fg₁
      =
      transportb
        (λ z, _ -->[ z ] _)
        (maponpaths _ (maponpaths (λ z, _ ,, z) (maponpaths pr1 p)))
        (pr2 fg₂).
  Proof.
    induction p.
    apply idpath.
  Qed.

  (**
   2. Isomorphisms
   *)
  Definition to_iso_sigma_of_twosided_disp_cat
             {x : C₁}
             {y : C₂}
             {xy₁ : sigma_twosided_disp_cat x y}
             {xy₂ : sigma_twosided_disp_cat x y}
             (f : iso_twosided_disp
                    (identity_z_iso x) (identity_z_iso y)
                    (pr1 xy₁) (pr1 xy₂))
             (g : z_iso_disp
                    (make_z_iso_total_twosided_disp_cat _ f)
                    (pr2 xy₁) (pr2 xy₂))
    : @iso_twosided_disp
        _ _
        sigma_twosided_disp_cat
        _ _ _ _
        (identity_z_iso x)
        (identity_z_iso y)
        xy₁
        xy₂.
  Proof.
    simple refine (_ ,, _ ,, _ ,, _).
    - exact (pr1 f ,, pr1 g).
    - exact (pr12 f ,, inv_mor_disp_from_z_iso g).
    - abstract
        (cbn ;
         refine (!_) ;
         etrans ;
         [ apply maponpaths ;
           apply sigma_transportb_left
         | ] ;
         etrans ;
         [ apply sigma_transportb_right | ] ;
         refine (!_) ;
         use sigma_twosided_disp_cat_mor_eq ; cbn ;
         [  exact (pr122 f) | ] ;
         etrans ;
         [ apply maponpaths ;
           exact (inv_mor_after_z_iso_disp g)
         | ] ;
         unfold transportb ;
         rewrite !transport_f_f ;
         apply transportf_hset_eq ;
         apply (total_twosided_disp_category D₁)).
    - abstract
        (cbn ;
         refine (!_) ;
         etrans ;
         [ apply maponpaths ;
           apply sigma_transportb_left
         | ] ;
         etrans ;
         [ apply sigma_transportb_right | ] ;
         refine (!_) ;
         use sigma_twosided_disp_cat_mor_eq ; cbn ;
         [  exact (pr222 f) | ] ;
         etrans ;
         [ apply maponpaths ;
           exact (z_iso_disp_after_inv_mor g)
         | ] ;
         unfold transportb ;
         rewrite !transport_f_f ;
         apply transportf_hset_eq ;
         apply (total_twosided_disp_category D₁)).
  Defined.

  Section FromSigmaIso.
    Context {x : C₁}
            {y : C₂}
            {xy₁ : sigma_twosided_disp_cat x y}
            {xy₂ : sigma_twosided_disp_cat x y}
            (f : @iso_twosided_disp
                    _ _
                    sigma_twosided_disp_cat
                    _ _ _ _
                    (identity_z_iso x)
                    (identity_z_iso y)
                    xy₁
                    xy₂).

    Let h : pr1 xy₁ -->[ identity_z_iso x ][ identity_z_iso y] pr1 xy₂ := pr11 f.
    Let hinv : pr1 xy₂ -->[ identity_z_iso x ][ identity_z_iso y] pr1 xy₁ := pr112 f.

    Local Lemma from_iso_sigma_of_twosided_disp_cat_inv₁
      : h ;;2 hinv
        =
        transportb
          (λ z, _ -->[ z ][ identity _ · identity _] _)
          (z_iso_inv_after_z_iso (identity_z_iso _))
          (transportb
             (λ z, _ -->[ identity x ][ z ] _)
             (z_iso_inv_after_z_iso (identity_z_iso _))
             (id_two_disp _)).
    Proof.
      refine (maponpaths pr1 (pr122 f) @ _).
      etrans.
      {
        do 2 apply maponpaths.
        apply sigma_transportb_left.
      }
      etrans.
      {
        apply maponpaths.
        apply sigma_transportb_right.
      }
      apply idpath.
    Qed.

    Local Lemma from_iso_sigma_of_twosided_disp_cat_inv₂
      : hinv ;;2 h
        =
        transportb
          (λ z, _ -->[ z ][ identity _ · identity _] _)
          (z_iso_inv_after_z_iso (identity_z_iso _))
          (transportb
             (λ z, _ -->[ identity x ][ z ] _)
             (z_iso_inv_after_z_iso (identity_z_iso _))
             (id_two_disp _)).
    Proof.
      refine (maponpaths pr1 (pr222 f) @ _).
      etrans.
      {
        do 2 apply maponpaths.
        apply sigma_transportb_left.
      }
      etrans.
      {
        apply maponpaths.
        apply sigma_transportb_right.
      }
      apply idpath.
    Qed.

    Definition from_iso_sigma_of_twosided_disp_cat_pr1
      : @iso_twosided_disp
          _ _
          D₁
          _ _ _ _
          (identity_z_iso x)
          (identity_z_iso y)
          (pr1 xy₁)
          (pr1 xy₂).
    Proof.
      simple refine (_ ,, _ ,, _ ,, _).
      - exact h.
      - exact hinv.
      - exact from_iso_sigma_of_twosided_disp_cat_inv₁.
      - exact from_iso_sigma_of_twosided_disp_cat_inv₂.
    Defined.

    Local Arguments transportf {_} _ {_ _ _} _.

    Definition from_iso_sigma_of_twosided_disp_cat_pr2
      : z_iso_disp
          (make_z_iso_total_twosided_disp_cat D₁
             from_iso_sigma_of_twosided_disp_cat_pr1)
          (pr2 xy₁)
          (pr2 xy₂).
    Proof.
      simple refine (_ ,, _ ,, _ ,, _).
      - exact (pr21 f).
      - exact (pr212 f).
      - abstract
          (assert (p := pr222 f
                        @ maponpaths _ (sigma_transportb_left _ _)
                        @ sigma_transportb_right _ _) ;
           cbn in p ;
           rewrite transport_f_f in p ;
           refine (sigma_mor_eq p @ _) ;
           cbn ;
           unfold transportb ;
           rewrite transport_f_f ;
           apply transportf_hset_eq ;
           apply (total_twosided_disp_category D₁)).
      - abstract
          (assert (p := pr122 f
                        @ maponpaths _ (sigma_transportb_left _ _)
                        @ sigma_transportb_right _ _) ;
           cbn in p ;
           rewrite transport_f_f in p ;
           refine (sigma_mor_eq p @ _) ;
           cbn ;
           unfold transportb ;
           rewrite transport_f_f ;
           apply transportf_hset_eq ;
           apply (total_twosided_disp_category D₁)).
    Defined.
  End FromSigmaIso.

  Definition weq_iso_sigma_of_twosided_disp_cat_help_eq
             {x : C₁}
             {y : C₂}
             {xy₁ : sigma_twosided_disp_cat x y}
             {xy₂ : sigma_twosided_disp_cat x y}
             (h₁ h₂ : ∑ (f : iso_twosided_disp
                               (identity_z_iso x) (identity_z_iso y)
                               (pr1 xy₁) (pr1 xy₂)),
                      z_iso_disp
                        (make_z_iso_total_twosided_disp_cat _ f)
                        (pr2 xy₁) (pr2 xy₂))
             (p : pr11 h₁ = pr11 h₂)
             (q : pr12 h₁
                  =
                  transportb
                    (λ z, pr2 xy₁ -->[ z ] pr2 xy₂)
                    (maponpaths
                       (λ (z : pr1 xy₁ -->[ identity _ ][ identity _ ] pr1 xy₂),
                        _ ,, _ ,, z)
                       p)
                    (pr12 h₂))
    : h₁ = h₂.
  Proof.
    induction h₁ as [ h₁ k₁ ].
    induction h₁ as [ h₁ Hh₁ ].
    induction k₁ as [ k₁ Hk₁ ].
    induction h₂ as [ h₂ k₂ ].
    induction h₂ as [ h₂ Hh₂ ].
    induction k₂ as [ k₂ Hk₂ ].
    cbn in *.
    induction p.
    cbn in q.
    induction q.
    assert (Hh₁ = Hh₂) as p.
    {
      apply isaprop_is_iso_twosided_disp.
    }
    induction p.
    do 2 apply maponpaths.
    apply (@isaprop_is_z_iso_disp _ D₂).
  Qed.

  Definition weq_iso_sigma_of_twosided_disp_cat
             {x : C₁}
             {y : C₂}
             (xy₁ : sigma_twosided_disp_cat x y)
             (xy₂ : sigma_twosided_disp_cat x y)
    : (∑ (f : iso_twosided_disp
                (identity_z_iso x) (identity_z_iso y)
                (pr1 xy₁) (pr1 xy₂)),
          z_iso_disp
            (make_z_iso_total_twosided_disp_cat _ f)
            (pr2 xy₁) (pr2 xy₂))
      ≃
      @iso_twosided_disp
         _ _
         sigma_twosided_disp_cat
         _ _ _ _
         (identity_z_iso x)
         (identity_z_iso y)
         xy₁
         xy₂.
  Proof.
    use weq_iso.
    - exact (λ f, to_iso_sigma_of_twosided_disp_cat (pr1 f) (pr2 f)).
    - intro f.
      simple refine (_ ,, _).
      + exact (from_iso_sigma_of_twosided_disp_cat_pr1 f).
      + exact (from_iso_sigma_of_twosided_disp_cat_pr2 f).
    - intro f.
      use weq_iso_sigma_of_twosided_disp_cat_help_eq ; apply idpath.
    - abstract
        (intro f ;
         use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ;
         apply idpath).
  Defined.

  (**
   3. Univalence and discreteness
   *)
  Definition is_univalent_sigma_of_twosided_disp_cat_help
             (HD₂ : is_univalent_disp D₂)
             {x₁ : C₁}
             {y₁ : C₂}
             (xy₁ xy₂ : sigma_twosided_disp_cat x₁ y₁)
             (p : pr1 xy₁ = pr1 xy₂)
    : (transportf (λ z, D₂ (x₁ ,, y₁ ,, z)) p (pr2 xy₁) = pr2 xy₂)
      ≃
      z_iso_disp
        (@make_z_iso_total_twosided_disp_cat
           _ _ D₁
           _ _ _ _ _ _
           _ _
           (idtoiso_twosided_disp (idpath _) (idpath _) _ _ p))
        (pr2 xy₁)
        (pr2 xy₂).
  Proof.
    induction xy₁ as [ z₁ z₂ ].
    induction xy₂ as [ z₃ z₄ ].
    cbn in *.
    induction p ; cbn.
    refine (_ ∘ (_ ,, HD₂ _ _ (idpath _) z₂ z₄))%weq.
    use weq_iso.
    - intro f.
      simple refine (pr1 f ,, pr12 f ,, _ ,, _).
      + abstract
          (refine (pr122 f @ _) ;
           apply transportf_hset_eq ;
           apply homset_property).
      + abstract
          (refine (pr222 f @ _) ;
           apply transportf_hset_eq ;
           apply homset_property).
    - intro f.
      simple refine (pr1 f ,, pr12 f ,, _ ,, _).
      + abstract
          (refine (pr122 f @ _) ;
           apply transportf_hset_eq ;
           apply (total_twosided_disp_category D₁)).
      + abstract
          (refine (pr222 f @ _) ;
           apply transportf_hset_eq ;
           apply (total_twosided_disp_category D₁)).
    - abstract
        (intro f ;
         use subtypePath ; [ intro ; apply isaprop_is_z_iso_disp | ] ;
         apply idpath).
    - abstract
        (intro f ;
         use subtypePath ; [ intro ; apply (@isaprop_is_z_iso_disp _ D₂) | ] ;
         apply idpath).
  Defined.

  Definition is_univalent_sigma_of_twosided_disp_cat
             (HD₁ : is_univalent_twosided_disp_cat D₁)
             (HD₂ : is_univalent_disp D₂)
    : is_univalent_twosided_disp_cat sigma_twosided_disp_cat.
  Proof.
    intros x₁ x₂ y₁ y₂ p₁ p₂ xy₁ xy₂.
    induction p₁, p₂.
    use weqhomot.
    - exact (weq_iso_sigma_of_twosided_disp_cat _ _
             ∘ weqtotal2
                 (make_weq _ (HD₁ x₁ x₁ y₁ y₁ (idpath _) (idpath _) (pr1 xy₁) (pr1 xy₂)))
                 (is_univalent_sigma_of_twosided_disp_cat_help HD₂ xy₁ xy₂)
             ∘ total2_paths_equiv _ _ _)%weq.
    - intro p.
      induction p.
      use subtypePath ; [ intro ; apply isaprop_is_iso_twosided_disp | ] ; cbn.
      apply idpath.
  Defined.

  Definition isaprop_disp_twosided_mor_sigma_twosided_disp_cat
             (HD₁ : isaprop_disp_twosided_mor D₁)
             (HD₂ : locally_propositional D₂)
    : isaprop_disp_twosided_mor sigma_twosided_disp_cat.
  Proof.
    intro ; intros.
    use total2_paths_f.
    - apply HD₁.
    - apply HD₂.
  Qed.

  Definition discrete_sigma_twosided_disp_cat
             (HD₁ : discrete_twosided_disp_cat D₁)
             (HD₂ : is_univalent_disp D₂)
             (HD₃ : locally_propositional D₂)
             (HD₄ : groupoidal_disp_cat D₂)
    : discrete_twosided_disp_cat sigma_twosided_disp_cat.
  Proof.
    use make_discrete_twosided_disp_cat.
    - use isaprop_disp_twosided_mor_sigma_twosided_disp_cat.
      + apply HD₁.
      + exact HD₃.
    - intros x₁ x₂ y₁ y₂ xy₁ xy₂ f g Hf Hg fg ; cbn.
      simple refine (_ ,, _).
      + apply HD₁.
        exact (pr1 fg).
      + cbn.
        pose (h := @make_z_iso_total_twosided_disp_cat
                      _ _
                      D₁
                      x₁ x₂
                      y₁ y₂
                      (pr1 xy₁) (pr1 xy₂)
                      (f ,, Hf) (g ,, Hg)
                      (pr1 fg ,, pr12 HD₁ _ _ _ _ _ _ _ _ _ _ _)).
        apply (HD₄ _ _ h (pr2 h)).
        apply fg.
    - use is_univalent_sigma_of_twosided_disp_cat.
      + apply HD₁.
      + exact HD₂.
  Qed.
End DispCatOnTwoSidedDispCat.


Require Export LimitFunctorTheorems SpecializedLaxCommaCategory.
Require Import Common DefinitionSimplification SpecializedCategory Functor NaturalTransformation Duals CanonicalStructureSimplification.

Set Implicit Arguments.

Generalizable All Variables.

Set Asymmetric Patterns.

Set Universe Polymorphism.

Section InducedFunctor.
  (* The components of the functor can be useful even if we don't have
     a category that we're coming from.  So prove them separately, so
     we can use them elsewhere, without assuming a full [HasLimits]. *)
  Variable I : Type.
  Context `(Index2Cat : forall i : I, @SpecializedCategory (@Index2Object i)).

  Local Coercion Index2Cat : I >-> SpecializedCategory.

  Local Notation "'CAT' ⇑ D" := (@LaxCosliceSpecializedCategory _ _ Index2Cat _ D).
  Local Notation "'CAT' ⇓ D" := (@LaxSliceSpecializedCategory _ _ Index2Cat _ D).

  Context `(D : @SpecializedCategory objD).
  Let DOp := OppositeCategory D.

  Section Limit.
    Definition InducedLimitFunctor_MorphismOf (s d : CAT ⇑ D) (limS : Limit (projT2 s)) (limD : Limit (projT2 d))
      (m : Morphism (CAT ⇑ D) s d) :
      Morphism D (LimitObject limS) (LimitObject limD)
      := InducedLimitMap (projT2 m) _ _.

    Lemma InducedLimitFunctor_FCompositionOf (s d d' : CAT ⇑ D) (limS : Limit (projT2 s)) (limD : Limit (projT2 d)) (limD' : Limit (projT2 d'))
      (m1 : Morphism _ s d) (m2 : Morphism _ d d') :
      InducedLimitFunctor_MorphismOf limS limD' (Compose m2 m1) =
      Compose (InducedLimitFunctor_MorphismOf limD limD' m2) (InducedLimitFunctor_MorphismOf limS limD m1).
    Proof.
      unfold InducedLimitFunctor_MorphismOf.
      unfold InducedLimitMap at 1; cbv zeta.
      match goal with
        | [ |- TerminalProperty_Morphism ?a ?b ?c = _ ] => apply (proj2 (TerminalProperty a b c))
      end (* 3 s *).
      nt_eq (* 4 s *).
      rsimplify_morphisms (* 11 s *).
      repeat rewrite Associativity (* 3 s *).
      match goal with
        | [ |- Compose ?a (Compose ?b ?c) = Compose ?a' (Compose ?b' ?c') ] =>
          eapply (@eq_trans _ _ (Compose a' (Compose _ c)) _);
            try_associativity ltac:(apply f_equal2; try reflexivity)
      end (* 13 s *);
      unfold InducedLimitMap;
      match goal with
        | [ |- appcontext[TerminalProperty_Morphism ?a ?b ?c] ] =>
          let H := constr:(TerminalProperty a) in
            let H' := fresh in
              pose proof (fun x Y f => f_equal (fun T => T.(ComponentsOf) x) (proj1 (H Y f))) as H';
                simpl in H';
                  unfold Object, Morphism in *;
                    simpl in *;
                      rewrite H';
                        clear H'
      end (* 7 s *);
      simpl;
      rsimplify_morphisms;
      reflexivity (* 6 s since [simpl] *).
    Qed.

    Lemma InducedLimitFunctor_FIdentityOf (x : CAT ⇑ D) (limX : Limit (projT2 x)) :
      InducedLimitFunctor_MorphismOf limX limX (Identity x) =
      Identity (LimitObject limX).
    Proof.
      unfold InducedLimitFunctor_MorphismOf.
      unfold InducedLimitMap at 1; cbv zeta.
      match goal with
        | [ |- TerminalProperty_Morphism ?a ?b ?c = _ ] => apply (proj2 (TerminalProperty a b c))
      end (* 3 s *).
      nt_eq (* 4 s *).
      rsimplify_morphisms;
      reflexivity. (* 2 s *)
    Qed.

    Variable HasLimits : forall C : CAT ⇑ D, Limit (projT2 C).

    Hint Resolve InducedLimitFunctor_FCompositionOf InducedLimitFunctor_FIdentityOf.

    Definition InducedLimitFunctor : SpecializedFunctor (CAT ⇑ D) D.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
            (fun x => LimitObject (HasLimits x))
            (fun s d => @InducedLimitFunctor_MorphismOf s d (HasLimits s) (HasLimits d))
            _
            _
          )
      end;
      abstract trivial.
    Defined.
  End Limit.

  Section Colimit.
    Definition InducedColimitFunctor_MorphismOf (s d : CAT ⇓ D) (colimS : Colimit (projT2 s)) (colimD : Colimit (projT2 d))
      (m : Morphism (CAT ⇓ D) s d) :
      Morphism D (ColimitObject colimS) (ColimitObject colimD)
      := InducedColimitMap (projT2 m) _ _.

    Lemma InducedColimitFunctor_FCompositionOf (s d d' : CAT ⇓ D) (colimS : Colimit (projT2 s)) (colimD : Colimit (projT2 d)) (colimD' : Colimit (projT2 d'))
      (m1 : Morphism _ s d) (m2 : Morphism _ d d') :
      InducedColimitFunctor_MorphismOf colimS colimD' (Compose m2 m1) =
      Compose (InducedColimitFunctor_MorphismOf colimD colimD' m2) (InducedColimitFunctor_MorphismOf colimS colimD m1).
    Proof.
      unfold InducedColimitFunctor_MorphismOf.
      unfold InducedColimitMap at 1; cbv zeta.
      match goal with
        | [ |- InitialProperty_Morphism ?a ?b ?c = _ ] => apply (proj2 (InitialProperty a b c))
      end (* 3 s *).
      nt_eq (* 4 s *).
      rsimplify_morphisms (* 8 s *).
      repeat rewrite Associativity (* 3 s *).
      match goal with
        | [ |- Compose ?a (Compose ?b ?c) = Compose ?a' (Compose ?b' ?c') ] =>
          symmetry; eapply (@eq_trans _ _ (Compose a (Compose _ c')) _);
            try_associativity ltac:(apply f_equal2; try reflexivity)
      end (* 13 s *);
      unfold InducedColimitMap;
      match goal with
        | [ |- appcontext[InitialProperty_Morphism ?a ?b ?c] ] =>
          let H := constr:(InitialProperty a) in
            let H' := fresh in
              pose proof (fun x Y f => f_equal (fun T => T.(ComponentsOf) x) (proj1 (H Y f))) as H';
                simpl in H';
                  unfold Object in *;
                    simpl in *;
                      try (rewrite H'; clear H')
      end (* 7 s *);
      simpl;
      rsimplify_morphisms;
      reflexivity (* 4 s since [simpl] *).
    Qed.

    Lemma InducedColimitFunctor_FIdentityOf (x : CAT ⇓ D) (colimX : Colimit (projT2 x)) :
      InducedColimitFunctor_MorphismOf colimX colimX (Identity x) =
      Identity (ColimitObject colimX).
    Proof.
      unfold InducedColimitFunctor_MorphismOf.
      unfold InducedColimitMap at 1; cbv zeta.
      match goal with
        | [ |- InitialProperty_Morphism ?a ?b ?c = _ ] => apply (proj2 (InitialProperty a b c))
      end (* 3 s *).
      nt_eq (* 4 s *).
      rsimplify_morphisms. (* 1.5 s *)
      reflexivity.
    Qed.

    Variable HasColimits : forall C : CAT ⇓ D, Colimit (projT2 C).

    Hint Resolve InducedColimitFunctor_FCompositionOf InducedColimitFunctor_FIdentityOf.

    Definition InducedColimitFunctor : SpecializedFunctor (CAT ⇓ D) D.
      match goal with
        | [ |- SpecializedFunctor ?C ?D ] =>
          refine (Build_SpecializedFunctor C D
            (fun x => ColimitObject (HasColimits x))
            (fun s d => @InducedColimitFunctor_MorphismOf s d (HasColimits s) (HasColimits d))
            _
            _
          )
      end;
      abstract trivial.
    Defined.
  End Colimit.
End InducedFunctor.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Stephane Le Roux, 2006-02-23

on the total completion of a relation: Consider a decidable
(resp. middle-excluding) relation over an arbitrary set.  Equality on
the set is decidable (resp. middle-excluding) and the relation is
acyclic iff its restriction to any finite set has a decidable
(resp. middle-excluding) irreflexive linear extension.
*)

From Coq Require Import Sumbool Arith.
From CoLoR Require Import RelDec RelUtil ListUtil RelSub Path LogicUtil.

Set Implicit Arguments.

Section On_relation_completion.

Variable A : Type.

(***********************************************************************)
(** total *)

Section total.

Variable R : relation A.

Definition trichotomy x y : Prop := R x y \/ x=y \/ R y x.

Definition total l : Prop := forall x y,  In x l -> In y l -> trichotomy x y.

End total.

Lemma trichotomy_preserved : forall R R' x y,
  R << R' -> trichotomy R x y -> trichotomy R' x y.

Proof.
unfold inclusion, trichotomy. intros. pose (H x y). pose (H y x). tauto.
Qed.

(***********************************************************************)
(** add *)

Section try_add_arc.

Variable R : relation A.

Inductive try_add_arc (x y : A) : relation A :=
| keep : forall z t, R z t -> try_add_arc x y z t
| try_add : x<>y -> ~R y x ->  try_add_arc x y x y.

Lemma sub_rel_try_add_arc : forall x y, R << try_add_arc x y.

Proof. unfold inclusion. intros. constructor. hyp.  Qed.

Lemma try_add_arc_sym :  forall x y z t,
  try_add_arc x y z t -> try_add_arc x y t z -> R z t.

Proof.
intros. inversion H. hyp. inversion H0. contr. rewrite H3 in H7. contr.
Qed.

Lemma not_try_add_arc : rel_midex R -> forall x y, x<>y ->
  ~try_add_arc x y x y -> R y x.

Proof.
intros. destruct (H y x). hyp. absurd (try_add_arc x y x y). hyp.
constructor 2; hyp.
Qed.

Lemma restricted_try_add_arc : forall x y l,
  In x l -> In y l -> is_restricted R l -> is_restricted (try_add_arc x y) l.

Proof.
unfold is_restricted. intros. inversion H2. apply H1. hyp.
rewrite <- H5, <- H6. tauto.
Qed.

Lemma try_add_arc_dec : eq_dec A -> forall x y,  rel_dec R ->
  rel_dec (try_add_arc x y).

Proof.
repeat intro. destruct (X0 x0 y0). do 2 constructor. hyp.
destruct (X x0 y0). constructor 2. intro. inversion H; contr.
destruct (X0 y0 x0). constructor 2. intro. inversion H; contr.
destruct (X x x0). destruct (X y y0). rewrite e, e0.
constructor. constructor 2; hyp.
constructor 2. intro. inversion H; contr.
constructor 2. intro. inversion H; contr.
Qed.

Lemma try_add_arc_midex : eq_midex A -> forall x y, rel_midex R ->
  rel_midex (try_add_arc x y).

Proof.
do 6 intro. destruct (H0 x0 y0). do 2 constructor. hyp.
destruct (H x0 y0). constructor 2. intro. inversion H3; contr.
destruct (H0 y0 x0). constructor 2. intro. inversion H4; contr.
destruct (H x x0). destruct (H y y0). rewrite H4, H5.
constructor. constructor 2; hyp.
constructor 2. intro. inversion H6; contr.
constructor 2. intro. inversion H5; contr.
Qed.

Lemma try_add_arc_trichotomy : eq_midex A -> rel_midex R ->
  forall x y, trichotomy (try_add_arc x y) x y.

Proof.
unfold trichotomy. intros. destruct (H x y). tauto. destruct (H0 x y).
do 2 constructor. hyp.
destruct (H0 y x). do 2 constructor 2. constructor. hyp. constructor.
constructor 2; hyp.
Qed.

Lemma trichotomy_restriction : forall x y l,
  In x l -> In y l -> trichotomy R x y -> trichotomy (restriction R l) x y.

Proof.
unfold trichotomy, restriction. intros. tauto.
Qed.

Lemma  path_try_add_arc_path : forall t x y l z,
  ~(x=z \/ In x l) \/ ~(y=t \/ In y l) -> path (try_add_arc x y) z t l ->
  path R z t l.

Proof.
induction l; simpl; intros. inversion H0; tauto.
destruct H0. split. inversion H0. hyp. rewrite H5 in H. tauto.
apply IHl. pose sym_equal. pose (e A x a). tauto. hyp.
Qed.

Lemma trans_try_add_arc_sym : forall x y z t,
  transitive R -> try_add_arc x y z t -> try_add_arc x y t z -> R z z.

Proof.
unfold transitive. intros.
apply H with t; apply try_add_arc_sym with x y; hyp.
Qed.

Lemma trans_bpath_try_add_arc : eq_midex A -> forall x y z n,
  transitive R -> bpath (try_add_arc x y ) n z z -> R z z.

Proof.
intros. induction n. inversion H1. destruct l. simpl in H2.
apply trans_try_add_arc_sym with x y z; hyp.
simpl in H1. pose (le_Sn_O (length l) H2). contr. apply IHn.
inversion H1. clear IHn H1 H4 H5 x0 y0.
(* nodup *)
destruct (path_nodup_length (try_add_arc x y) H z l z H3).
decompose [and] H1.
assert (length x0 <= S n). apply le_trans with (length l); hyp.
clear H1 H2 H3 H6 H7 H8.
(* x0=nil *)
destruct x0. exists (nil : list A). apply le_O_n. tauto.
(* length x0 = 1 *)
destruct x0; simpl in * |- . exists (nil : list A). apply le_O_n. simpl.
apply sub_rel_try_add_arc. apply trans_try_add_arc_sym with x y a; tauto.
(* length x0 >= 2*)
destruct H10.  destruct H2.
inversion H1; inversion H2.
exists (a0::x0). simpl. apply le_S_n. hyp.
simpl. split. apply (sub_rel_try_add_arc). apply H0 with a; hyp.
hyp.
(**)
absurd (R a0 a). tauto. apply trans_tc_incl. hyp.
apply path_clos_trans with (x0++(z::nil)). apply path_app.
apply path_try_add_arc_path with x y. rewrite H13. tauto. hyp. simpl.
hyp.
(**)
absurd (R a z). tauto. apply trans_tc_incl. hyp.
apply path_clos_trans with (a0::x0). split. hyp.
apply path_try_add_arc_path with x y. rewrite H10. tauto. hyp.
(**)
rewrite H8 in H13. tauto.
Qed.

Lemma try_add_arc_irrefl : eq_midex A -> forall x y,
  transitive R ->  irreflexive R -> irreflexive (clos_trans (try_add_arc x y)).

Proof.
do 7 intro. apply H1 with x0. destruct (clos_trans_path H2).
apply trans_bpath_try_add_arc with x y (length x1); try hyp.
apply bp_intro with x1; trivial.
Qed.

End try_add_arc.

(***********************************************************************)
(** try_add_arc_one_to_many: multiple try_add_arc with one list *)

Section try_add_arc_one_to_many.

Variable R : relation A.

Fixpoint try_add_arc_one_to_many (x : A) (l : list A) : relation A
  :=
  match l with
    | nil => R
    | y::l' => clos_trans (try_add_arc (try_add_arc_one_to_many x l') x y)
  end.

Lemma sub_rel_try_add_arc_one_to_many : forall x l,
  R << (try_add_arc_one_to_many x l).

Proof.
induction l; simpl; intros. refl.
trans (try_add_arc_one_to_many x l). hyp.
trans (try_add_arc (try_add_arc_one_to_many x l) x a).
apply sub_rel_try_add_arc. apply incl_tc. refl.
Qed.

Lemma restricted_try_add_arc_one_to_many : forall l x l',
  In x l -> incl l' l -> is_restricted R l ->
  is_restricted (try_add_arc_one_to_many x l') l.

Proof.
induction l'; simpl; intros. hyp. apply restricted_clos_trans.
apply restricted_try_add_arc. hyp. apply H0. simpl. tauto. apply IHl'.
hyp. exact (incl_cons_l_incl H0). hyp.
Qed.

Lemma try_add_arc_one_to_many_dec : eq_dec A -> forall x l l',
  In x l -> incl l' l -> is_restricted R l -> rel_dec R ->
  rel_dec (try_add_arc_one_to_many x l').

Proof.
induction l'; simpl; intros. hyp. pose (incl_cons_l_incl H0).
apply restricted_dec_clos_trans_dec with l. hyp.
apply try_add_arc_dec. hyp. apply IHl'; tauto.
apply restricted_try_add_arc. hyp. apply H0. simpl. tauto.
apply restricted_try_add_arc_one_to_many; simpl; tauto.
Qed.

Lemma try_add_arc_one_to_many_midex : eq_midex A -> forall x l l',
  In x l -> incl l' l -> is_restricted R l -> rel_midex R ->
  rel_midex (try_add_arc_one_to_many x l').

Proof.
induction l'; simpl; intros. hyp. pose (incl_cons_l_incl H1).
apply restricted_midex_clos_trans_midex with l. hyp.
apply try_add_arc_midex. hyp. apply IHl'; tauto.
apply restricted_try_add_arc. hyp. apply H1. simpl. tauto.
apply restricted_try_add_arc_one_to_many; simpl; tauto.
Qed.

Lemma try_add_arc_one_to_many_trichotomy : eq_midex A -> rel_midex R ->
  forall x y l l', In y l' -> In x l ->  incl l' l -> is_restricted R l ->
    trichotomy (try_add_arc_one_to_many x l') x y.

Proof.
induction l';  simpl; intros. contr. pose (incl_cons_l_incl H3).
apply trichotomy_preserved
  with (try_add_arc (try_add_arc_one_to_many x l') x a).
apply incl_tc. refl. destruct H1. rewrite H1.
apply try_add_arc_trichotomy. hyp.
apply try_add_arc_one_to_many_midex with l; hyp.
apply trichotomy_preserved with (try_add_arc_one_to_many x l').
apply sub_rel_try_add_arc. tauto.
Qed.

Lemma try_add_arc_one_to_many_irrefl : eq_midex A -> forall x l l',
  is_restricted R l -> transitive R -> irreflexive R ->
  irreflexive (try_add_arc_one_to_many x l').

Proof.
induction l'; simpl; intros. hyp.
apply try_add_arc_irrefl. hyp.
destruct l'; simpl. hyp. apply tc_trans. tauto.
Qed.

End try_add_arc_one_to_many.

(***********************************************************************)
(** try_add_arc_many_to_many: multiple try_add_arc with two lists *)

Section try_add_arc_many_to_many.

Variable R : relation A.

Fixpoint try_add_arc_many_to_many (l' l: list A) : relation A :=
  match l' with
    | nil => R
    | x::l'' => try_add_arc_one_to_many (try_add_arc_many_to_many l'' l) x l
  end.

Lemma sub_rel_try_add_arc_many_to_many : forall l l',
  R << (try_add_arc_many_to_many l' l).

Proof.
induction l'; simpl; intros. refl.
trans (try_add_arc_many_to_many l' l). hyp.
apply sub_rel_try_add_arc_one_to_many.
Qed.

Lemma restricted_try_add_arc_many_to_many : forall l l', incl l' l ->
  is_restricted R l -> is_restricted (try_add_arc_many_to_many l' l) l.

Proof.
induction l'; simpl; intros. hyp.
apply restricted_try_add_arc_one_to_many. apply H. simpl. tauto.
refl.
apply IHl'. exact (incl_cons_l_incl H). hyp.
Qed.

Lemma try_add_arc_many_to_many_dec : eq_dec A ->  forall l l',
  incl l' l -> is_restricted R l -> rel_dec R ->
  rel_dec (try_add_arc_many_to_many l' l).

Proof.
induction l'; simpl; intros. hyp. pose (incl_cons_l_incl H).
apply try_add_arc_one_to_many_dec with l. hyp. apply H. simpl. tauto.
refl.
apply  restricted_try_add_arc_many_to_many; hyp. tauto.
Qed.

Lemma try_add_arc_many_to_many_midex : eq_midex A ->  forall l l',
  incl l' l -> is_restricted R l -> rel_midex R ->
  rel_midex (try_add_arc_many_to_many l' l).

Proof.
induction l'; simpl; intros. hyp. pose (incl_cons_l_incl H0).
apply try_add_arc_one_to_many_midex with l. hyp. apply H0. simpl. tauto.
refl.
apply  restricted_try_add_arc_many_to_many; hyp. tauto.
Qed.

Lemma try_add_arc_many_to_many_trichotomy : eq_midex A -> rel_midex R ->
  forall x y l l', is_restricted R l -> incl l' l -> In y l -> In x l' ->
    trichotomy (try_add_arc_many_to_many l' l) x y.

Proof.
induction l';  simpl; intros. contr. pose (incl_cons_l_incl H2).
destruct H4. rewrite H4.
apply try_add_arc_one_to_many_trichotomy with l; try hyp.
apply try_add_arc_many_to_many_midex; hyp.
rewrite <- H4. apply H2. simpl. tauto. refl.
apply restricted_try_add_arc_many_to_many; hyp.
apply trichotomy_preserved with  (try_add_arc_many_to_many l' l).
apply sub_rel_try_add_arc_one_to_many. tauto.
Qed.

Lemma try_add_arc_many_to_many_irrefl : eq_midex A -> forall l l',
  incl l' l -> is_restricted R l -> transitive R -> irreflexive R ->
  irreflexive (try_add_arc_many_to_many l' l).

Proof.
induction l'; simpl; intros. hyp. pose (incl_cons_l_incl H0).
apply try_add_arc_one_to_many_irrefl with l. hyp.
apply restricted_try_add_arc_many_to_many; hyp.
destruct l'; simpl. hyp. destruct l. pose (i a0). simpl in i0. tauto.
simpl. apply tc_trans. tauto.
Qed.

End try_add_arc_many_to_many.

(***********************************************************************)
(** Linear Extension and Topological Sorting *)

Section LETS.

Variable R : relation A.
Variable l : list A.

Definition LETS := try_add_arc_many_to_many (clos_trans (restriction R l)) l l.

Lemma LETS_restriction_clos_trans : clos_trans (restriction R l) << LETS.

Proof.
intros. unfold LETS. apply sub_rel_try_add_arc_many_to_many.
Qed.

Lemma LETS_sub_rel : restriction R l << LETS.

Proof.
intros. unfold LETS.
trans (clos_trans (restriction R l)).
apply incl_tc. refl. apply  LETS_restriction_clos_trans.
Qed.

Lemma LETS_restricted : is_restricted LETS l.

Proof.
unfold LETS. intros. apply restricted_try_add_arc_many_to_many.
refl.
apply restricted_clos_trans. apply restricted_restriction.
Qed.

Lemma LETS_transitive : transitive LETS.

Proof.
intros. unfold LETS. destruct l; simpl; apply tc_trans.
Qed.

Lemma LETS_irrefl : eq_midex A ->
  (irreflexive (clos_trans (restriction R l)) <-> irreflexive LETS).

Proof.
split;intros. unfold LETS.
apply try_add_arc_many_to_many_irrefl; try hyp. refl.
apply restricted_clos_trans. apply restricted_restriction.
apply tc_trans.
apply irreflexive_incl with LETS. apply LETS_restriction_clos_trans.
hyp.
Qed.

Lemma LETS_total : eq_midex A -> rel_midex R -> total LETS l.

Proof.
unfold LETS, total. intros. pose (R_midex_clos_trans_restriction_midex H H0 l).
apply try_add_arc_many_to_many_trichotomy; try hyp.
apply restricted_clos_trans.
apply restricted_restriction. refl.
Qed.

Lemma LETS_dec : eq_dec A -> rel_dec R -> rel_dec LETS.

Proof.
intros. unfold LETS. apply try_add_arc_many_to_many_dec. hyp.
refl.
apply restricted_clos_trans. apply restricted_restriction.
apply R_dec_clos_trans_restriction_dec; hyp.
Qed.

Lemma LETS_midex : eq_midex A -> rel_midex R -> rel_midex LETS.

Proof.
intros. unfold LETS. apply try_add_arc_many_to_many_midex. hyp.
refl.
apply restricted_clos_trans. apply restricted_restriction.
apply R_midex_clos_trans_restriction_midex; hyp.
Qed.

End LETS.

(***********************************************************************)
(** Linear Extension *)

Definition linear_extension R l R' :=
  is_restricted R' l /\ (restriction R l) << R' /\
  transitive R' /\ irreflexive R' /\ total R' l.

Lemma local_global_acyclic : forall R : relation A,
  (forall l, exists R',
    (restriction R l) << R' /\ transitive R' /\ irreflexive R') ->
  irreflexive (clos_trans R).

Proof.
intros. do 2 intro. destruct (clos_trans_path H0).
assert (clos_trans (restriction R (x::x::x0)) x x).
apply path_clos_trans with x0.
apply path_restriction. hyp. destruct (H (x::x::x0)). destruct H3.
destruct H4.
apply H5 with x. apply trans_tc_incl. hyp.
apply tc_incl with (restriction R (x :: x :: x0)). hyp.
hyp.
Qed.

Lemma total_order_eq_midex:
  (forall l, exists R,
    transitive R /\ irreflexive R /\ total R l /\ rel_midex R) -> eq_midex A.

Proof.
do 3 intro. destruct (H (x::y::nil)). decompose [and] H0.
destruct (H5 x y); destruct (H5 y x).
absurd (x0 x x). apply H3. apply H1 with y; hyp.
constructor 2. intro. rewrite H7 in H4. rewrite H7 in H6. contr.
constructor 2. intro. rewrite H7 in H4. rewrite H7 in H6. contr.
destruct (H2 x y); simpl; try tauto.
Qed.

Lemma linearly_extendable :  forall R, rel_midex R ->
  (eq_midex A /\ irreflexive (clos_trans R) <->
    forall l, exists R', linear_extension R l R' /\ rel_midex R').

Proof.
unfold linear_extension. split; intros. exists (LETS R l). split. split.
apply LETS_restricted. split.
apply LETS_sub_rel. split. apply LETS_transitive. split.
destruct (LETS_irrefl R l).
tauto. apply H1. apply irreflexive_incl with (clos_trans R).
unfold inclusion. apply tc_incl. apply incl_restriction. tauto.
apply LETS_total; tauto. apply LETS_midex; tauto.
(**)
split. apply total_order_eq_midex. intro. destruct (H0 l). exists x. tauto.
apply local_global_acyclic. intro. destruct (H0 l). exists x. tauto.
Qed.

(***********************************************************************)
(** Topological Sorting *)

Definition topo_sortable R :=
  {F : list A -> A -> A -> bool |
    forall l, linear_extension R l (fun x y => F l x y = true)}.

Definition antisym R SC := forall x y : A, x<>y -> ~R x y -> ~R y x ->
  ~(SC (x::y::nil) x y /\ SC (y::x::nil) x y).

Definition antisym_topo_sortable R :=
  {F : list A -> A -> A -> bool |
    let G := (fun l x y => F l x y = true) in
      antisym R G /\ forall l, linear_extension R l (G l)}.

Lemma total_order_eq_dec :
  {F : list A -> A -> A -> bool |
    forall l, let G := fun x y => F l x y = true in
      transitive G /\ irreflexive G /\ total G l} -> eq_dec A.

Proof.
unfold transitive, irreflexive, total, trichotomy. intros H x y. destruct H.
pose (a (x::y::nil)).
assert ({x0 (x::y::nil) x y=true}+{x0  (x::y::nil) x y=false}).
case (x0 (x::y::nil) x y); tauto.
assert ({x0 (x::y::nil) y x=true}+{x0 (x::y::nil) y x=false}).
case (x0 (x::y::nil) y x); tauto.
destruct a0. destruct H2. pose (H3 x y). simpl in o.
destruct H. constructor 2. intro. rewrite H in e. rewrite H in H2.
exact (H2 y e).
destruct H0. constructor 2. intro. rewrite H in e0. rewrite H in H2.
exact (H2 y e0).
constructor. destruct o; try tauto. rewrite H in e. inversion e. destruct H.
hyp.
rewrite H in e0. inversion e0.
Qed.

Lemma LETS_antisym : forall R, antisym R (LETS R).

Proof.
unfold LETS. do 7 intro. simpl in *|- . destruct H2.
assert (is_restricted (restriction R (x :: y :: nil)) (x::y::nil)).
apply restricted_restriction.
assert (is_restricted
  (try_add_arc (clos_trans (restriction R (x :: y :: nil))) y y) (x::y::nil)).
apply restricted_try_add_arc; simpl; try tauto. apply restricted_clos_trans.
hyp.
assert (is_restricted
  (try_add_arc (clos_trans (try_add_arc
    (clos_trans (restriction R (x :: y :: nil))) y y)) y x) (x::y::nil)).
apply restricted_try_add_arc; simpl; try tauto. apply restricted_clos_trans.
hyp.
assert (is_restricted (try_add_arc (clos_trans
  (try_add_arc (clos_trans (try_add_arc
    (clos_trans (restriction R (x :: y :: nil))) y y)) y x)) x y) (x::y::nil)).
apply restricted_try_add_arc; simpl; try tauto. apply restricted_clos_trans.
hyp.
assert (is_restricted (try_add_arc (clos_trans (try_add_arc (clos_trans
  (try_add_arc (clos_trans (try_add_arc (clos_trans
    (restriction R (x :: y :: nil))) y y)) y x)) x y)) x x)  (x::y::nil)).
apply restricted_try_add_arc; simpl; try tauto. apply restricted_clos_trans.
hyp.
(**)
pose (clos_trans_restricted_pair H8 H2). inversion t; try tauto.
clear H10 H11 z t0.
pose (clos_trans_restricted_pair H7 H9). inversion t0. clear H11 H12 z t1.
pose (clos_trans_restricted_pair H6 H10). inversion t1; try tauto.
clear H12 H13 z t2.
pose (clos_trans_restricted_pair H5 H11). inversion t2. clear H13 H14 z t3.
assert (restriction R (x :: y :: nil) x y).
apply clos_trans_restricted_pair; hyp.
unfold restriction in H13. tauto. tauto.
(**)
absurd (clos_trans  (try_add_arc (clos_trans (try_add_arc (clos_trans
  (restriction R (x :: y :: nil))) y y)) y x) y x).
hyp. constructor. constructor 2. intro. rewrite H14 in H10. tauto.
intro. pose (clos_trans_restricted_pair H5 H14). inversion t1; try tauto.
clear H16 H17 z t2.
pose (clos_trans_restricted_pair H4 H15). unfold restriction in r. tauto.
Qed.

Lemma possible_antisym_topo_sort : forall R, eq_dec A -> rel_dec R ->
  irreflexive (clos_trans R) -> antisym_topo_sortable R.

Proof.
do 4 intro. assert (forall l, rel_dec (LETS R l)). intro.
apply LETS_dec; hyp.
pose (eq_dec_midex X). pose (rel_dec_midex X0).
exists (fun l x y => if (X1 l x y) then true else false). simpl. split.
do 5 intro. case (X1 (x :: y :: nil) x y). case (X1 (y :: x :: nil) x y).
do 2 intro. absurd (LETS R (x :: y :: nil) x y /\ LETS R (y :: x :: nil) x y).
apply LETS_antisym; hyp. tauto. do 3 intro. destruct H3. inversion H4.
do 2 intro. destruct H3. inversion H3. split.
do 3 intro. destruct (X1 l x y). apply (LETS_restricted R l x y). hyp.
inversion H0. split.
do 3 intro. destruct (X1 l x y). trivial. absurd (LETS R l x y). hyp.
apply LETS_restriction_clos_trans. eapply incl_tc. refl. hyp. split.
do 5 intro. destruct (X1 l x y). destruct (X1 l y z).
pose (LETS_transitive R l x y z l0 l1).
destruct (X1 l x z). trivial. contr. inversion H1. inversion H0. split.
do 2 intro. destruct (X1 l x x). absurd (LETS R l x x).
destruct (LETS_irrefl R l).
hyp. apply H1. apply irreflexive_incl with (clos_trans R).
apply tc_incl. apply incl_restriction. hyp. hyp.
inversion H0.
do 4 intro. unfold trichotomy. destruct (X1 l x y). tauto. destruct (X1 l y x).
tauto.
destruct (LETS_total l e r x y); tauto.
Qed.

Lemma antisym_topo_sortable_topo_sortable : forall R,
  antisym_topo_sortable R -> topo_sortable R.

Proof.
intros R H. exists (let (f,s):= H in f). intros. destruct H. destruct a.
pose (H0 l). unfold linear_extension in *|-* . tauto.
Qed.

Lemma antisym_topo_sortable_rel_dec : forall R,
  rel_midex R -> antisym_topo_sortable R -> rel_dec R.

Proof.
unfold antisym_topo_sortable, linear_extension.
intros R H H0. assert (irreflexive (clos_trans R)). apply local_global_acyclic.
intro. exists (fun x y => (let (f,s):= H0 in f) l x y=true). destruct H0.
destruct a. pose (H1 l). tauto.
assert (eq_dec A). apply total_order_eq_dec. exists (let (f,s):= H0 in f).
intro. destruct H0.
destruct a. pose (H2 l). split; tauto.
(**)
do 2 intro. destruct (X x y). rewrite e. constructor 2. intro. apply (H1 y).
constructor. hyp.
destruct H0. destruct a. pose (H0 x y). decompose [and] (H2 (x::y::nil)).
destruct (sumbool_of_bool (x0 (x::y::nil) x y)).
destruct (sumbool_of_bool (x0 (y::x::nil) x y)).
constructor. destruct (H x y). hyp. destruct (H y x).
absurd (x0 (x :: y :: nil) y x=true).
intro. apply (H6 x). apply H4 with y; hyp. apply H5. unfold restriction.
simpl. tauto. generalize n0 e e0.
case (x0 (x :: y :: nil) x y); case (x0 (y :: x :: nil) x y); tauto.
constructor 2. intro. absurd (x0 (y :: x :: nil) x y=true). intro.
rewrite e0 in H9. inversion H9.
pose (H2 (y::x::nil)). decompose [and] a. apply H11. unfold restriction. simpl.
tauto.
constructor 2. intro. absurd (x0 (x::y:: nil) x y=true). intro.
rewrite e in H9. inversion H9.
apply H5. unfold restriction. simpl. tauto.
Qed.

Lemma rel_dec_topo_sortable_eq_dec :  forall R,
  rel_dec R -> topo_sortable R -> eq_dec A.

Proof.
intros R Rd H. apply total_order_eq_dec. exists (let (first,second):=H in first).
destruct H. intro. pose (l l0). destruct l1. split; tauto.
Qed.

Lemma rel_dec_topo_sortable_acyclic :  forall R,
  rel_dec R -> topo_sortable R -> irreflexive (clos_trans R).

Proof.
intros R Rd H. apply local_global_acyclic. intro. destruct H.
exists (fun x0 y => x l x0 y=true). destruct (l0 l). tauto.
Qed.

End On_relation_completion.


Require Import Iron.Language.SystemF2Effect.Type.Operator.SubstTT.
Require Import Iron.Language.SystemF2Effect.Type.Operator.LiftTT.
Require Import Iron.Language.SystemF2Effect.Type.Relation.WfT.

(********************************************************************)
(* Type Enviroments *)
Definition tyenv := list ty.
Hint Unfold tyenv.

(* Lift type indices in type environments. *)
Definition liftTE d te    := map (liftTT 1 d) te.
Hint Unfold liftTE.

(* Substitution of types in type environments. *)
Definition substTE d t te := map (substTT d t) te.
Hint Unfold substTE.

(********************************************************************)
Lemma length_liftTE
 :  forall d te
 ,  length te = length (liftTE d te).
Proof.
 induction te; burn.
Qed.

Lemma liftTE_liftTE
 :  forall n n' te
 ,  liftTE n              (liftTE (n + n') te)
 =  liftTE (1 + (n + n')) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold liftTE.
  simpl. rewrite liftTT_liftTT_11.
  f_equal. burn.
Qed.

Lemma substTE_liftTE
 :  forall d te t2
 ,  substTE d t2 (liftTE d te) = te.
Proof.
 intros.
 unfold substTE. unfold liftTE.
 lists.
 induction te; simpl; burn.
Qed.

Lemma liftTE_substTE
 :  forall n n' t2 te
 ,  liftTE n (substTE (n + n') t2 te)
 =  substTE (1 + n + n') (liftTT 1 n t2) (liftTE n te).
Proof.
 intros. induction te; rip.
  unfold substTE. unfold liftTE.
   simpl. rewrite liftTT_substTT.
   unfold liftTE  in IHte.
   unfold substTE in IHte. rewrite IHte. auto.
Qed.

Lemma liftTE_closedT_id
 :  forall n se
 ,  Forall ClosedT se
 -> liftTE n se = se.
Proof.
 intros.
 unfold liftTE.
 induction se; rip.
  inverts H. snorm.
  rewritess.
  rrwrite (liftTT 1 n a = a).
  auto.
Qed.
Hint Resolve liftTE_closedT_id.

Lemma substTE_closedT_id
 :  forall n t2 se
 ,  Forall ClosedT se
 -> substTE n t2 se = se.
Proof.
 intros.
 unfold substTE.
 induction se; rip.
  inverts H. snorm.
  rewritess.
  rrwrite (substTT n t2 a = a).
  auto.
Qed.
Hint Resolve substTE_closedT_id.


(* LC = Languages and Calculi (N.K. Vereschagin, A.Shen) *)
Require Import FunctionalExtensionality.
Require Import Logic.Classical_Prop.
Require Import Logic.Classical_Pred_Type.
Require Import Logic.ChoiceFacts.
Require Import Logic.IndefiniteDescription.

Require Export Coq.Lists.List.
Definition InL { A : Type } :=
fix InL (a : A) (l : list A) {struct l} : Type :=
  match l with
  | Datatypes.nil => False
  | b :: m => (sum (b = a) (InL a m))
  end.

Require Import Relations. (*for transitive*)
Require Import Coq.Structures.Equalities.
Module Lang (PropVars : UsualDecidableTypeFull).
 (** Language of the propositional logic. **)
 Inductive Fo :=
 |Atom (p:PropVars.t) :> Fo
 |Bot :Fo
 |Conj:Fo->Fo->Fo
 |Disj:Fo->Fo->Fo
 |Impl:Fo->Fo->Fo
 .

Module PropFormulasNotationsASCII.
 Notation " x --> y ":=(Impl x y) (at level 80, right associativity):protxtnot.
 Notation " x -/\ y ":=(Conj x y) (at level 80):protxtnot.
 Notation " x -\/ y ":=(Disj x y) (at level 80):protxtnot.
 Notation " -. x " :=(Impl x Bot) (at level 80):protxtnot.
 Definition Neg (A:Fo):Fo := Impl A Bot.
 Definition Top:Fo := Neg Bot.
 Delimit Scope protxtnot with otd.
End PropFormulasNotationsASCII.
Export PropFormulasNotationsASCII.
Open Scope protxtnot.
 (* BEGIN experimental *)
 Section exper_1.
 Inductive PROCAI_1 : Fo -> Type :=
 | eHa1  (A B:PropVars.t) :  PROCAI_1 (A-->(B-->A))%otd
 | eHa2  (A B:PropVars.t): forall (C:PropVars.t),
          PROCAI_1 ((A-->(B-->C))-->((A-->B)-->(A-->C)))
 | eHa3  (A B:PropVars.t): PROCAI_1 ((A-/\ B)--> A)
 | eHa4  (A B:PropVars.t): PROCAI_1 ((A-/\ B)--> B)
 | eHa5  (A B:PropVars.t): PROCAI_1 (A-->(B-->(A-/\B)))
 | eHa6  (A B:PropVars.t): PROCAI_1 (A-->(A-\/ B))
 | eHa7  (A B:PropVars.t): PROCAI_1 (B-->(A-\/ B))
 | eHa8  (A B:PropVars.t): forall (C:PropVars.t),
          PROCAI_1 ((A-->C)-->((B-->C)-->((A-\/ B)-->C)))
 | eHa9  (A B:PropVars.t): PROCAI_1 (-.A --> (A --> B) )
 | eHa10 (A B:PropVars.t) : PROCAI_1 ((A-->B)-->(A -->-.B)-->-.A)
 .
 End exper_1.
 (* END experimental *)

 (** ==== Contexts ==== **)
 Theorem lf2ft :(list Fo) -> (Fo->Type).
 Proof. intros lf f. exact (InL f lf). Defined.
 (* Coercion lf2ft. : (list Fo) >-> (Fo->Type). *)

 Inductive empctx : Fo -> Type :=. (* empty context *)

 Definition add2ctx (A:Fo) (l:Fo->Type) : Fo->Type
 := fun f=> sum (A=f) (l f). (* add head *)

 Definition cnctctx (l1 l2:Fo->Type) : Fo->Type
 := fun f=> sum (l1 f) (l2 f). (* concat *)

 Lemma addempeqv (il:Fo->Type) : forall (f:Fo),
 (cnctctx il empctx) f -> il f.
 Proof. intros f q. destruct q. exact i. destruct e. Defined.

 (* Proposional calculus' axioms (Intuitionistic) *)
 Inductive PROCAI : Fo -> Type :=
 | Ha1  : forall A B, PROCAI (A-->(B-->A))
 | Ha2  : forall A B C, PROCAI ((A-->(B-->C))-->((A-->B)-->(A-->C)))
 | Ha3  : forall A B, PROCAI ((A-/\ B)--> A)
 | Ha4  : forall A B, PROCAI ((A-/\ B)--> B)
 | Ha5  : forall A B, PROCAI (A-->(B-->(A-/\B)))
 | Ha6  : forall A B, PROCAI (A-->(A-\/ B))
 | Ha7  : forall A B, PROCAI (B-->(A-\/ B))
 | Ha8  : forall A B C, PROCAI ((A-->C)-->((B-->C)-->((A-\/ B)-->C)))
 | Ha9  : forall A B, PROCAI (-.A --> (A --> B) )
 | Ha10  : forall A B, PROCAI ((A-->B)-->(A -->-.B)-->-.A)
 .

 Theorem exper1 (A:Fo): (PROCAI_1 A) -> (PROCAI A).
 Proof.
 intro H.
 destruct H; constructor.
 Defined.

 (* Proposional calculus' axioms (Classical) *)
 Inductive PROCA : Fo -> Type :=
 | Intui :> forall f, PROCAI f -> PROCA f
 | Ha11  : forall A, PROCA (A -\/ -.A)
 .

 Section PR.
  Context (axs:Fo -> Type).
  Context (ctx:Fo -> Type).
  Inductive PR : Fo -> Type :=
  | hyp (A : Fo) : (*InL A ctx*) ctx A -> PR A
  | Hax :> forall (A : Fo), (axs A) -> PR A
  | MP (A B: Fo) : (PR A)->(PR (A-->B))->(PR B)
  .
 End PR.

 Section LPR. (* Less than PR : no context *)
  Context (axs:Fo -> Type).
  Inductive LPR : Fo -> Type :=
  | lHax :> forall (A : Fo), (axs A) -> LPR A
  | lMP (A B: Fo) : (LPR A)->(LPR (A-->B))->(LPR B)
  .
 End LPR.

 (* trivial *)
 Theorem LPR2PR axs A : LPR axs A -> PR axs empctx A.
 Proof.
 intro H. induction H.
 + apply Hax. exact a.
 + apply MP with A; assumption.
 Defined.

 Theorem PR2LPR axs A : PR axs empctx A -> LPR axs A.
 Proof.
 intro H. induction H.
 + destruct c.
 + apply lHax. exact a.
 + apply lMP with A; assumption.
 Defined.

 Theorem experB1 {ctx} (A:Fo) :
  (PR PROCAI_1 ctx A) -> (PR PROCAI ctx A).
 Proof.
 intro H.
 induction H.
 apply hyp. exact c.
 apply Hax, exper1, a.
 eapply MP. exact IHPR1. exact IHPR2.
 Defined.

Section subst_sec.
 Context (p:PropVars.t) (B:Fo).

Check p.
Check PropVars.eq_dec p p.
Locate "+".
Check sumbool.
 Fixpoint Sub (A:Fo) : Fo
  := match A with
   | Atom q => match (PropVars.eq_dec p q) with
               | left u => B
               | right v => (Atom q)
               end
   | Bot => Bot
   | Conj x1 x2 => Conj (Sub x1) (Sub x2)
   | Disj x1 x2 => Disj (Sub x1) (Sub x2)
   | Impl x1 x2 => Impl (Sub x1) (Sub x2)
   end.

Section ctx_Sub_sec.
Context (wct:Fo->Type).
Inductive ctx_Sub : Fo->Type
:= | ctx_Sub_cons (f:Fo): wct f -> ctx_Sub (Sub f).
End ctx_Sub_sec.

(* REVERSE:
 Definition Sub_ctx :(Fo->Type)->(Fo->Type).
 Proof.
 intros wct f.
 exact (wct (Sub f)).
 Defined.*)

 Section MPR. (* More than PR : add substitution *)
  Context (axs:Fo -> Type).
  Inductive MPR : forall (ctx:Fo -> Type), Fo -> Type :=
  | mhyp (ctx:Fo -> Type) (A : Fo) : (*InL A ctx*) ctx A -> MPR ctx A
  | mHax (ctx:Fo -> Type) : forall (A : Fo), (axs A) -> MPR ctx A
  | mMP (ctx:Fo -> Type) (A B: Fo) :
     (MPR ctx A)->(MPR ctx (Impl A B))->(MPR ctx B)
  | mSub (ctx:Fo -> Type) (A B:Fo) (p:PropVars.t) :
    (MPR ctx A)->MPR (ctx_Sub ctx) (Sub A)
  .
 End MPR.
(*!!!
 Theorem MPR2PR axs ctx A : MPR axs ctx A -> PR axs ctx A.
 Proof.
 intro H. induction H.
 + apply mlHax. exact a.
 + apply mlMP with A; assumption.
 Defined.
*)

 Section MLPR. (* More than LPR : add substitution *)
  Context (axs:Fo -> Type).
  Inductive MLPR : Fo -> Type :=
  | mlHax :> forall (A : Fo), (axs A) -> MLPR A
  | mlMP (A B: Fo) : (MLPR A)->(MLPR (Impl A B))->(MLPR B)
  | mlSub (A B:Fo) (p:PropVars.t) : (MLPR A)->MLPR (Sub A)
  .
 End MLPR.

 (* trivial *)
 Theorem LPR2MLPR axs A : LPR axs A -> MLPR axs A.
 Proof.
 intro H. induction H.
 + apply mlHax. exact a.
 + apply mlMP with A; assumption.
 Defined.

 Lemma PROCAI_Sub (A : Fo) (a : PROCAI A) : PROCAI (Sub A).
 Proof.
 destruct a; simpl; constructor.
 Defined.

 Lemma PROCA_Sub (A : Fo) (a : PROCA A) : PROCA (Sub A).
 Proof.
 destruct a as [g p0| A].
 + apply Intui. eapply PROCAI_Sub, p0.
 + simpl. apply Ha11.
 Defined.

Section ghj_sec.
 Local Inductive ghj : Fo->Type := | ghj_c : ghj p.
 Context (jkl: (p:Fo)<>B).
 Local Lemma j1 : ~ forall (axs:Fo->Prop) (A : Fo), axs A -> axs (Sub A).
 Proof.
 intro H.
 assert (Q:=H (ghj) p ghj_c).
 inversion Q.
 destruct (PropVars.eq_dec p p).
 + compute in H1.
   simpl in H1.
   exact (jkl H1).
 + apply n.
   constructor.
 Defined.
End ghj_sec.

 (* Calculus with*)
 Section axs_resp_Sub.
 Context {axs:Fo -> Type} (j1:forall A, (axs A)->axs (Sub A)).
 Theorem  PR_Sub' {ctx} (A:Fo):
  (PR axs ctx A) -> (PR axs (ctx_Sub ctx) (Sub A)) .
 Proof.
 intro a.
 induction a.
 + apply hyp. constructor. exact c.
 + apply Hax. apply j1, a.
 + eapply MP. exact IHa1. exact IHa2.
 Defined.

 Theorem  LPR_Sub'  (A:Fo):
  (LPR axs A) -> (LPR axs (Sub A)) .
 Proof.
 intro a.
 induction a.
 + apply lHax. apply j1, a.
 + eapply lMP. exact IHa1. exact IHa2.
 Defined.

 Theorem MLPR2LPR A : MLPR axs A -> LPR axs A.
 Proof.
 intro H. induction H.
 + apply lHax. exact a.
 + apply lMP with A; assumption.
 + apply LPR_Sub'. assumption.
 Defined.
 End axs_resp_Sub.

 Theorem  PR_Sub {ctx} (A:Fo) :
  (PR PROCAI ctx A) -> (PR PROCAI (ctx_Sub ctx) (Sub A)) .
 Proof.
 intro a.
 induction a.
 + apply hyp. constructor. exact c.
 + apply Hax. destruct a; simpl; constructor.
 + eapply MP. exact IHa1. exact IHa2.
 Defined.

(* "ctx_Sub" preserve empty context *)
Theorem empctx_fix (f:Fo) : ((ctx_Sub empctx) f)->False.
Proof.
intro H.
destruct H as [g E].
destruct E.
Defined.

End subst_sec.

 Definition AtoA_I {ctx} (A:Fo) : PR PROCAI ctx (A-->A).
 Proof.
 apply MP with (A-->(A-->A)).
 apply Hax, Ha1. (* apply (Hax _ _ (Ha1 _ _)).*)
 apply MP with (A-->((A-->A)-->A)) (*1:=I*).
 apply Hax, Ha1.
 apply Hax, Ha2.
 Defined.

 Theorem subcalc {ctx} {B} : (PR PROCAI ctx B) -> (PR PROCA ctx B).
 Proof.
 intro m.
 induction m.
 + apply hyp. assumption.
 + apply Hax. apply Intui. assumption.
 + eapply MP. exact IHm1. exact IHm2.
 Defined.

 Definition AtoA {ctx} (A:Fo) : PR PROCA ctx (A-->A)
  := subcalc (AtoA_I A).

 Definition a1i_I (A B : Fo)(l : Fo->Type):
 (PR PROCAI l B)->(PR PROCAI l (Impl A B)).
 Proof.
 intros x.
 apply MP with (A:= B).
 exact x.
 eapply (*subcalc_OE,*) Hax,Ha1.
 Defined.

 Definition a1i (A B : Fo)(l : Fo->Type):
 (PR PROCA l B)->(PR PROCA l (Impl A B)).
 Proof.
 intros x.
 apply MP with (A:= B).
 exact x.
 eapply (*subcalc_OE,*) Hax, Intui, Ha1.
 Defined.

 (*Fixpoint *)
 Theorem weak (axs:Fo -> Type)
 (A F:Fo) (*l :list Fo*) (l:Fo->Type)
 (x: (PR axs l F)) : (PR axs (add2ctx A l) F).
 Proof.
 induction x.
 + apply hyp.
   right.
   assumption.
 + apply Hax, a.
 + exact (MP axs (add2ctx A l) A0 B IHx1 IHx2).
 Defined.

 (*Fixpoint*)
 Definition weaken axs (F:Fo) (li l :Fo->Type) (x: (PR axs l F))
 (*{struct li}*): (PR axs (cnctctx li l) F).
 Proof.
 induction x.
 + apply hyp.
   right.
   assumption.
 + apply Hax, a.
 + exact (MP _ (cnctctx li l) A B IHx1 IHx2).
 (*destruct li.
 simpl.
 exact x.
 simpl.
 simple refine (@weak _ f F (li ++ l)%list _).
 apply weaken.
 exact x.*)
 Defined.

 (* ==== Deduction ==== *)
 Theorem DedI (A B:Fo)(il:Fo->Type)(m:(PR PROCAI (add2ctx A il) B))
 :(PR PROCAI il (A-->B)).
 Proof.
 induction m.
 + (*unfold InL in c.*)
   simpl in c .
   destruct c .
   * rewrite <- e.
     pose (J:=weaken PROCAI _ il empctx (AtoA_I A )).
     (* rewrite app_nil_r in J.*)
     induction J.
     - destruct c.
       apply hyp. assumption.
       destruct e0.
     - apply Hax. assumption.
     - apply MP with (A:=A1); assumption.
     (*rewrite - addempeqv in J.
     exact J.*)
   * simpl in i.
     apply a1i_I.
     apply hyp with (ctx:=il) (1:=i).
 + apply a1i_I.
   apply Hax, a.
 + apply MP with (A-->A0).
   exact IHm1.
   apply MP with (A-->A0-->B).
   exact IHm2.
   apply Hax.
   apply Ha2.
 Defined.

 Theorem invDedI (A B:Fo)(il:Fo->Type)(m:(PR PROCAI il (A-->B)))
 :(PR PROCAI (add2ctx A il) B).
 Proof.
 pose(U:=(weak PROCAI A _ il m)).
 assert (N:PR PROCAI (add2ctx A il) A).
 apply hyp. simpl. left. reflexivity.
 apply MP with A.
 exact N.
 exact U.
 Defined.

 Theorem invDed (A B:Fo)(il:Fo->Type)(m:(PR PROCA il (A-->B)))
 :(PR PROCA (add2ctx A il) B).
 Proof.
 pose(U:=(weak PROCA A _ il m)).
 assert (N:PR PROCA (add2ctx A il) A).
 apply hyp. simpl. left. reflexivity.
 apply MP with A.
 exact N.
 exact U.
 Defined.

 Theorem Ded (A B:Fo)(il:Fo->Type)(m:(PR PROCA (add2ctx A il) B))
 :(PR PROCA il (A-->B)).
 Proof.
 induction m.
 + (*unfold InL in c.*)
   simpl in c .
   destruct c .
   * rewrite <- e.
     pose (J:=weaken PROCA _ il empctx (AtoA A)).
     (* rewrite app_nil_r in J.*)
     induction J.
     - destruct c.
       apply hyp. assumption.
       destruct e0.
     - apply Hax. assumption.
     - apply MP with (A:=A1); assumption.
     (*rewrite - addempeqv in J.
     exact J.*)
   * simpl in i.
     apply a1i.
     apply hyp with (ctx:=il) (1:=i).
 + apply a1i.
   apply Hax, a.
 + apply MP with (A-->A0).
   exact IHm1.
   apply MP with (A-->A0-->B).
   exact IHm2.
   apply Hax.
   apply Intui, Ha2.
 Defined.

 (* Order of the context is not important. *)
 Lemma permut axs L1 L2 A (H: forall x, L1 x -> L2 x)
 : (PR  axs L1 A) -> (PR axs L2 A).
 Proof.
 intro m.
 induction m.
 + apply hyp. apply (H A c).
 + apply Hax. apply a.
 + apply MP with A. exact IHm1. exact IHm2.
 Defined.

 Lemma PR_eqv C1 C2 A F (Q:forall x,C1 x <-> C2 x) (H:PR A C1 F)
  : PR A C2 F.
 Proof.
 eapply permut. 2 : exact H. intros x D. apply Q, D.
 (*induction H.
 - apply Q in c. apply hyp. assumption.
 - apply Hax. assumption.
 - apply MP with (A:=A0); assumption.*)
 Defined.

 (*
    Classical semantics for the classical
    propositional logic("CPRoL"). (definitions)
 *)
 Section foI_cl.
  Context (val:PropVars.t->Prop).
  Fixpoint foI_cl (f:Fo) : Prop :=
  match f with
   | Atom p => (val p)
   | Bot => False
   | f1 -/\ f2 => (foI_cl f1) /\ (foI_cl f2)
   | f1 -\/ f2 => (foI_cl f1) \/ (foI_cl f2)
   | f1 --> f2 => (foI_cl f1) -> (foI_cl f2)
  end.
 End foI_cl.

 (* Soundness of the classical semantics *) (*LC p.41 thm17*)
 Theorem sou_cl f (H:PR PROCA empctx f) :
    forall (val:PropVars.t->Prop), foI_cl val f.
 Proof. intro val.
  induction H;firstorder.
  + induction a;firstorder.
    * induction p; firstorder.
    * simpl.
      destruct (classic (foI_cl val A)); firstorder.
 Defined.

 (*
    Double negation semantics for the classical
    propositional logic("CPRoL"). (definitions)
 *)
 Section foI_dn. (* Entails for double negation. *)
  Context (val:PropVars.t->Prop).
  Fixpoint foI_dn (f:Fo) : Prop :=
  match f with
   | Atom p => (((val p)->False)->False)
   | Bot => False
   | f1 -/\ f2 => foI_dn f1 /\ foI_dn f2
   | f1 -\/ f2 => (((foI_dn f1 \/ foI_dn f2)->False)->False)
   | f1 --> f2 => (foI_dn f1) -> (foI_dn f2)
  end.
 End foI_dn.

 (* Soundness of the double-negation semantics *)
 Theorem sou_dn f (H:PR PROCA empctx f) :
    forall (val:PropVars.t->Prop), foI_dn val f.
 Proof. intro val.
  induction H;firstorder.
  + induction a;firstorder.
    * induction p; firstorder.
        simpl. intros.
        induction C ;firstorder.
 Defined.

 (* Boolean semantics for classical
    propositional logic. (definitions) *)
 Section foI_bo.
  Context (val:PropVars.t->bool).
  Fixpoint foI_bo (f:Fo) : bool :=
  match f with
   | Atom p => (val p)
   | Bot => false
   | f1 -/\ f2 => andb (foI_bo f1) (foI_bo f2)
   | f1 -\/ f2 => orb (foI_bo f1) (foI_bo f2)
   | f1 --> f2 => implb (foI_bo f1) (foI_bo f2)
  end.
 End foI_bo.

 (*Soundness of the boolean semantics *)
 Theorem sou_bo f (H:PR PROCA empctx f) :
    forall (val:PropVars.t->bool), (foI_bo val f)=true.
 Proof. intro val.
 induction H.
 + destruct c.
 + induction a.
   * induction p; simpl; destruct (foI_bo val A), (foI_bo val B);
     try destruct (foI_bo val C); firstorder.
   * simpl; destruct (foI_bo val A); firstorder.
 + simpl in * |- *; destruct (foI_bo val A), (foI_bo val B); firstorder.
 Defined.

 (*
   Kripke semantics for the intuitionistic
   proposition logic.
 *)
 Open Scope type_scope.
 Section WR.
 Context (W:Set) (R:W->W->Prop) (R_transitive : transitive W R)
 (R_reflexive : reflexive W R).
 Context (vf:PropVars.t -> W -> Prop)
 (mvf: forall (x y : W)(p:PropVars.t), vf p x -> R x y -> vf p y).

 Section foI_kr. (* Entails *)
 Fixpoint foI_kr (x:W) (f:Fo) : Prop :=
 match f with
   | Atom p => (vf p x)
   | Bot => False
   | f1 -/\ f2 => foI_kr x f1 /\ foI_kr x f2
   | f1 -\/ f2 => foI_kr x f1 \/ foI_kr x f2
   | f1 --> f2 =>
 (forall y:W, R x y -> ((foI_kr y f1) -> (foI_kr y f2)))
 end. (*foI x f1 =-> foI x f2*)
 End foI_kr.

 Theorem utv1 x f: foI_kr x (f-->Bot) <-> forall y, R x y -> not (foI_kr y f).
 Proof.
 simpl. unfold not. reflexivity.
 (* split.
 + intros.
 simpl in H. destruct (H y H0).
 * exact H1.
 * destruct H1.
 + intros. left. exact (H y H0).*)
 Defined.

 Theorem utv2 x y f : foI_kr x f -> R x y -> foI_kr y f.
 Proof.
 intros H1 H2.
 induction f.
 + simpl in * |- *.
   apply mvf with x. apply H1. apply H2. (* , H2, H1 *)
 + exact H1.
 + simpl in * |- *.
   destruct H1 as [u1 u2].
   exact (conj (IHf1 u1) (IHf2 u2)).
 + simpl in * |- *.
   destruct H1 as [u1|u2].
   left. exact (IHf1 u1).
   right. exact (IHf2 u2).
 + simpl in * |- *.
   intros.
   apply H1.
   * apply (R_transitive x y y0 H2 H). (* !!! "transitivity y." *)
   * exact H0.
 Defined.

 (* Soundness of the Kripke semantics of IPro *)
 Theorem sou_kr f (H:PR PROCAI empctx f) : forall x, foI_kr x f.
 Proof.
 induction H.
 + destruct c. (*simpl in i. destruct i.*)
 + induction a.
   * simpl. intros.
     simpl in * |- *.
     apply utv2 with (x:=y).
     - exact H0.
     - exact H1.
   * simpl. intros.
 eapply (H0 y1 _ _ y1).
 apply R_reflexive.
 apply H2.
 apply H3.
 apply H4.
 (*unshelve eapply (H0 y0 _ _ y1 H3).
 - exact H1.
 - apply utv2 with y1.
   exact H4.
 simpl in * |- *.
 admit.*)
   * simpl. intros. destruct H0 as [LH0 RH0]. exact LH0.
   * simpl. intros. destruct H0 as [LH0 RH0]. exact RH0.
   * simpl. intros x y pxy yA z pyz zB. split.
     exact (utv2 y z A yA pyz).
    exact zB.
   * simpl. intros x y pxy H. left. exact H.
   * simpl. intros x y pxy H. right. exact H.
   * simpl. intros.
     destruct H4.
     - unshelve eapply H0. 2: exact H4. exact (R_transitive y y0 y1 H1 H3).
     - unshelve eapply H2. exact H3. exact H4.
   * simpl. intros. exfalso. eapply H0 with y0. exact H1. exact H2.
   * simpl. intros.
     apply (H2 y1 H3 H4 y1).
     apply R_reflexive.
     apply H0.
     eapply R_transitive. exact H1. exact H3. exact H4.
 + simpl in * |- *.
   intro x.
   unshelve apply (IHPR2 x).
   unshelve apply R_reflexive.
   unshelve apply IHPR1.
   Unshelve.
   exact (R_transitive y y0 y1 H1 H3).
   exact H4.
 Defined.
 End WR.

 Lemma sile1 (A B:Prop) : (~~A)->A.
 Proof.
 intro H.
 destruct (classic A).
 trivial.
 destruct (H H0).
 Defined.

 Lemma sile0 A : PR PROCA empctx ((-.-.A) --> A).
 Proof.
 eapply MP.
 apply Hax, (Ha11 A).
 eapply MP. (* with ((-.A) --> (-.(-.A)) --> A).*)
 2 :  eapply MP. (* with (A --> (-.(-.A)) --> A). *)
 3 : {
eapply Hax, Intui.
Check Ha8 A (-.A) ((-.(-.A))-->A).
eapply Ha8.
(*eapply (Ha8 A (-.A) ((-.(-.A))-->A)).*)
}
 +
 eapply Ded, Ded.
 Abort.

 (*
 Lemma sile2 (A B:Prop) : ((A->B)->B)->A.
 Proof.
 intro H. PROCA
 destruct (classic A).
 trivial.
 destruct (classic B).
 *)
 Theorem propswap (A B C:Fo):
 PR PROCAI empctx ((A-->(B-->C))-->(B-->(A-->C))).
 Proof.
 eapply DedI, DedI, DedI.
 eapply MP.
 2 : {
 eapply MP.
 2 : {
 apply hyp.
 unfold add2ctx.
 right. right. left. reflexivity.
 }
 apply hyp.
 unfold add2ctx.
 left. reflexivity.
 }
 apply hyp.
 unfold add2ctx.
 right. left. reflexivity.
 Defined.
End Lang.