(**  “Displayed equivalences” of displayed categories. *)

(** ** Contents:

    - Displayed adjunctions and equivalences
      - Displayed Adjunctions: [disp_adjunction]
      - Displayed Equivalences: [equiv_over]
    - Constructions
      - Equivalence from ess. split and ff
        (incomplete)

    - Adjunctions and equivalences displayed over an identity functor
      - Displayed Adjunctions over identity: [disp_adjunction_id]
      - Displayed Equivalences over identity: [equiv_over_id]
    - Constructions
      - Equivalence from ess. split and ff over identity
        [is_equiv_from_ff_ess_over_id]
      - Inverses and composition of displayed adjunctions/equivalences over identity
      - Induced adjunctions/equivalences of fiber categories over identity
        [fiber_equiv]
 *)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Local Open Scope cat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Fiber.

Local Open Scope type_scope.
Local Open Scope mor_disp_scope.

(** * General definition of displayed adjunctions and equivalences *)

Section DisplayedAdjunction.

  Definition disp_adjunction_data {C C' : category} (A : adjunction_data C C')
             (F := left_functor A) (G := right_functor A)
             (eta := adjunit A) (eps := adjcounit A)
             (D : disp_cat C) (D' : disp_cat C') : UU
    := ∑ (FF : disp_functor F D D') (GG : disp_functor G D' D),
      (disp_nat_trans eta (disp_functor_identity _ )
                      (disp_functor_composite FF GG))
        ×
        (disp_nat_trans eps (disp_functor_composite GG FF) (disp_functor_identity _ )).

  Section notation.

    Context {C C' : category} {A : adjunction_data C C'}
            {D D'} (X : disp_adjunction_data A D D').
    Definition left_adj_over : disp_functor _ _ _ := pr1 X.
    Definition right_adj_over : disp_functor _ _ _ := pr1 (pr2 X).
    Definition unit_over : disp_nat_trans _ _ _ := pr1 (pr2 (pr2 X)).
    Definition counit_over : disp_nat_trans _ _ _ := pr2 (pr2 (pr2 X)).

  End notation.

  Definition triangle_1_statement_over
             {C C' : category} {A : adjunction C C'}
             {D D'} (X : disp_adjunction_data A D D')
             (FF := left_adj_over X)
             (ηη := unit_over X)
             (εε := counit_over X) : UU
    := ∏ x xx, ♯ FF (ηη x xx) ;;  εε _ (FF _ xx)
               = transportb _ (triangle_id_left_ad A x ) (id_disp _) .

  Definition triangle_2_statement_over
             {C C' : category} {A : adjunction C C'}
             {D D'} (AA : disp_adjunction_data A D D')
             (GG := right_adj_over AA)
             (ηη := unit_over AA)
             (εε := counit_over AA) : UU
    := ∏ x xx, ηη _ (GG x xx) ;; ♯ GG (εε _ xx)
               = transportb _ (triangle_id_right_ad A _ ) (id_disp _).

  Definition form_disp_adjunction {C C' : category}
             (A : adjunction C C') {D : disp_cat C} {D' : disp_cat C'}
             (AA : disp_adjunction_data A D D')
    : UU
    := triangle_1_statement_over AA × triangle_2_statement_over AA.

  Definition disp_adjunction {C C' : category} (A : adjunction C C') D D' : UU
    := ∑ AA : disp_adjunction_data A D D',
        triangle_1_statement_over AA × triangle_2_statement_over AA.

  Coercion data_of_disp_adjunction (C C' : category) (A : adjunction C C')
           D D' (AA : disp_adjunction A D D') : disp_adjunction_data _ _ _ := pr1 AA.

  Definition triangle_1_over {C C' : category}
             {A : adjunction C C'} {D : disp_cat C}
             {D' : disp_cat C'} (AA : disp_adjunction A D D')
    : triangle_1_statement_over AA
    := pr1 (pr2 AA).

  Definition triangle_2_over {C C' : category}
             {A : adjunction C C'} {D : disp_cat C}
             {D' : disp_cat C'} (AA : disp_adjunction A D D')
    : triangle_2_statement_over AA
    := pr2 (pr2 AA).

  (** The terminology is difficult to choose here: the proposition “F is a left adjoint” is the same as the type of “right adjoints to F”, so should this type be called something more like [left_adjoint F] or [right_adjoint F]?

      Our choice here does _not_ agree with that of the base UniMath category theory library. TODO: consider these conventions, and eventually harmonise them by changing it either here or in UniMath. *)

  Definition right_adjoint_over_data {C C' : category}
             {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'}
             (FF : disp_functor (left_functor A) D D') : UU
    := ∑ (GG : disp_functor (right_functor A) D' D),
      (disp_nat_trans (adjunit A)
                      (disp_functor_identity _) (disp_functor_composite FF GG))
        × (disp_nat_trans (adjcounit A )
                          (disp_functor_composite GG FF) (disp_functor_identity _)).

  Definition functor_of_right_adjoint_over {C C' : category}
             {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'}
             {FF : disp_functor (left_functor A) D D'}
             (GG : right_adjoint_over_data FF)
    := pr1 GG.
  Coercion functor_of_right_adjoint_over
    : right_adjoint_over_data >-> disp_functor.

  Definition adjunction_of_right_adjoint_over_data {C C' : category}
             {A : adjunction_data C C'} {D : disp_cat C} {D' : disp_cat C'}
             {FF : disp_functor (left_functor A) D D'}
             (GG : right_adjoint_over_data FF)
    : disp_adjunction_data A D D'
    := (FF,, GG).
  Coercion adjunction_of_right_adjoint_over_data
    : right_adjoint_over_data >-> disp_adjunction_data.

  Definition right_adjoint_of_disp_adjunction_data
             {C C' : category} {A : adjunction_data C C'}
             {D : disp_cat C} {D' : disp_cat C'}
             (AA : disp_adjunction_data A D D')
    : right_adjoint_over_data (left_adj_over AA) (* coercion does not trigger *)
    := pr2 AA.

  Definition right_adjoint_over
             {C C' : category} {A : adjunction C C'}
             {D : disp_cat C} {D' : disp_cat C'}
             (FF : disp_functor (left_functor A) D D') : UU
    := ∑ GG : right_adjoint_over_data FF,
        form_disp_adjunction A GG.

  Definition data_of_right_adjoint_over
             {C C' : category} {A : adjunction C C'}
             {D : disp_cat C} {D' : disp_cat C'}
             {FF : disp_functor (left_functor A) D D'}
             (GG : right_adjoint_over FF)
    : right_adjoint_over_data FF
    := pr1 GG.
  Coercion data_of_right_adjoint_over
    : right_adjoint_over >-> right_adjoint_over_data.

  Definition adjunction_of_right_adjoint_over {C C' : category}
             {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'}
             (FF : disp_functor (left_functor A) D D')
             (GG : right_adjoint_over FF)
    : disp_adjunction A D D'
    := (adjunction_of_right_adjoint_over_data GG ,, pr2 GG).

  Definition right_adjoint_of_disp_adjunction {C C' : category}
             {A : adjunction C C'} {D : disp_cat C} {D' : disp_cat C'}
             (AA : disp_adjunction A D D')
    : right_adjoint_over (left_adj_over AA)
    := (right_adjoint_of_disp_adjunction_data AA ,, pr2 AA).

End DisplayedAdjunction.

Section DisplayedEquivalences.
  Definition form_equiv_over {C C' : category} {E : equivalence_of_cats C C'}
             {D : disp_cat C} {D' : disp_cat C'}
             (AA : disp_adjunction_data E D D') : UU
    := (∏ x xx, is_z_iso_disp (adjunitiso E x) (unit_over AA x xx))
         ×
         (∏ x xx, is_z_iso_disp (adjcounitiso E x) (counit_over AA x xx)).

  Definition is_z_iso_unit_over
             {C C' : category} (E : equivalence_of_cats C C') {D D'}
             (AA : disp_adjunction_data E D D')
             (EE : form_equiv_over AA)
    : ∏ (x : C) (xx : D x), is_z_iso_disp (adjunitiso E x) ((unit_over AA) x xx)
    := pr1 EE.

  Definition is_z_iso_counit_over
             {C C' : category} (E : equivalence_of_cats C C') {D D'}
             (AA : disp_adjunction_data E D D')
             (EE : form_equiv_over AA)
    :  ∏ (x0 : C') (xx : D' x0), is_z_iso_disp (adjcounitiso E x0) ((counit_over AA) x0 xx)
    := pr2 EE.

  Definition equiv_over {C C' : category} (E : adj_equiv C C')
             (D : disp_cat C) (D' : disp_cat C')
    : UU
    := ∑ AA : disp_adjunction E D D', @form_equiv_over _ _ E _  _ (pr1 AA).
  (* argument A is not inferred *)

  Coercion adjunction_of_equiv_over {C C' : category} (E : adj_equiv C C')
           {D : disp_cat C} {D': disp_cat C'} (EE : equiv_over E D D')
    : disp_adjunction _ _ _ := pr1 EE.

  Coercion axioms_of_equiv_over {C C' : category} (E : adj_equiv C C')
           {D : disp_cat C} {D': disp_cat C'}
           (EE : equiv_over E D D') : form_equiv_over _
    := pr2 EE.

  Definition is_equiv_over {C C' : category} (E : adj_equiv C C')
             {D : disp_cat C} {D': disp_cat C'}
             (FF : disp_functor (left_functor E) D D') : UU
    := ∑ GG : @right_adjoint_over _ _ E _ _ FF,
        @form_equiv_over _ _ E _ _ GG.
  (* argument E is not inferred *)

  Definition right_adjoint_of_is_equiv_over {C C' : category} (E : adj_equiv C C')
             {D : disp_cat C} {D': disp_cat C'}
             {FF : disp_functor (left_functor E) D D'}
             (EE : is_equiv_over E FF) := pr1 EE.
  Coercion right_adjoint_of_is_equiv_over
    : is_equiv_over >-> right_adjoint_over.

  Definition equiv_of_is_equiv_over {C C' : category} (E : adj_equiv C C')
             {D : disp_cat C} {D': disp_cat C'}
             {FF : disp_functor (left_functor E) D D'}
             (EE : is_equiv_over E FF)
    : equiv_over E D D'
    := (adjunction_of_right_adjoint_over _ EE ,, pr2 EE).
  Coercion equiv_of_is_equiv_over
    : is_equiv_over >-> equiv_over.
  (* Again, don’t worry about the ambiguous path generated here. *)

  (** ** Lemmas on the triangle identities *)

  Local Open Scope hide_transport_scope.

  Lemma triangle_2_from_1_for_equiv_over
        {C C' : category} (E : adj_equiv C C')
        {D : disp_cat C} {D' : disp_cat C'}
        (AA : disp_adjunction_data E D D')
        (EE : form_equiv_over (E:=E) AA)
    : triangle_1_statement_over (A:=E) AA -> triangle_2_statement_over (A:=E) AA.
  Proof.
    destruct AA as [FF [GG [η ε]]].
    destruct EE as [Hη Hε]; cbn in Hη, Hε.
    unfold triangle_1_statement_over, triangle_2_statement_over; cbn.
    intros T1 x yy.
    (* Algebraically, this goes as follows:
    η G ; G ε
    = G ε^ ; η^ G ; η G ; G ε ; η G ; G ε          [by inverses, 1]
    = G ε^ ; η^ G ; η G ; η G F G ; G F G ε ; G ε  [by naturality, 2]
    = G ε^ ; η^ G ; η G ; η G F G ; G ε F G ; G ε  [by naturality, 3]
    = G ε^ ; η^ G ; η G ; G F η G ; G ε F G ; G ε  [by naturality, 4]
    = G ε^ ; η^ G ; η G ; G (F η ; ε F ) G ; G ε   [by functoriality, 5]
    = G ε^ ; η^ G ; η G ; G ε                      [by T1, 6]
    = 1                                            [by inverses, 7]

    It’s perhaps most readable when written in string diagrams. *)
    etrans. apply id_left_disp_var.
    etrans. eapply transportf_bind.
      eapply cancel_postcomposition_disp.
      etrans. eapply transportf_transpose_right. apply @pathsinv0.
        refine (z_iso_disp_after_inv_mor _).
        refine (disp_functor_on_is_z_iso_disp GG _).
        apply Hε. (*1a*)
      eapply transportf_bind.
      eapply cancel_postcomposition_disp.
      etrans. apply id_right_disp_var.
      eapply transportf_bind.
      etrans. eapply cancel_precomposition_disp.
      eapply transportf_transpose_right. apply @pathsinv0.
        refine (z_iso_disp_after_inv_mor _).
        apply (Hη). (*1b*)
      eapply transportf_bind, assoc_disp.
    etrans. eapply transportf_bind.
      etrans. apply assoc_disp_var.
      eapply transportf_bind.
      etrans. apply assoc_disp_var.
      eapply transportf_bind.
      eapply cancel_precomposition_disp.
      etrans. eapply cancel_precomposition_disp.
        etrans. apply assoc_disp.
        eapply transportf_bind.
        etrans. eapply cancel_postcomposition_disp.
          exact (disp_nat_trans_ax η (♯ GG (ε x yy))). (*2*)
        eapply transportf_bind.
        etrans. apply assoc_disp_var.
        eapply transportf_bind.
        eapply cancel_precomposition_disp.
        cbn.
        etrans. eapply transportf_transpose_right.
          apply @pathsinv0, (disp_functor_comp GG).
        eapply transportf_bind.
        etrans. apply maponpaths.
          apply (disp_nat_trans_ax ε). (*3*)
        cbn.
        etrans. apply (disp_functor_transportf _ GG).
        eapply transportf_bind.
        apply (disp_functor_comp GG).
      eapply transportf_bind.
      etrans. apply assoc_disp.
      eapply transportf_bind.
      etrans. eapply cancel_postcomposition_disp.
        apply (disp_nat_trans_ax η (η _ (GG x yy))). (*4*)
      cbn.
      eapply transportf_bind.
      etrans. apply assoc_disp_var.
      eapply transportf_bind.
      eapply cancel_precomposition_disp.
      etrans. apply assoc_disp.
      eapply transportf_bind.
      etrans. eapply cancel_postcomposition_disp.
        etrans. eapply transportf_transpose_right.
          apply @pathsinv0, (disp_functor_comp GG). (*5*)
        eapply transportf_bind.
        etrans. apply maponpaths, T1. (*6*)
        etrans. apply (disp_functor_transportf _ GG).
        eapply transportf_bind. apply (disp_functor_id GG).
      eapply transportf_bind. apply id_left_disp.
    etrans. eapply transportf_bind.
      etrans. apply assoc_disp_var.
      eapply transportf_bind.
      etrans. eapply cancel_precomposition_disp.
        etrans. apply assoc_disp.
        eapply transportf_bind.
        etrans. eapply cancel_postcomposition_disp.
          exact (z_iso_disp_after_inv_mor _). (*7a*)
        eapply transportf_bind. apply id_left_disp.
      apply maponpaths. exact (z_iso_disp_after_inv_mor _). (*7b*)
    etrans. apply transport_f_f.
    unfold transportb. apply maponpaths_2, homset_property.
  Time Qed.

  Lemma triangle_1_from_2_for_equiv_over
        {C C' : category} (E : adj_equiv C C')
        {D : disp_cat C} {D' : disp_cat C'}
        (AA : disp_adjunction_data E D D')
        (EE : form_equiv_over (E:=E) AA)
    : triangle_2_statement_over (A:=E) AA -> triangle_1_statement_over (A:=E) AA.
  Proof.
    (* dual to previous lemma *)
  Abort.

  Definition is_equiv_of_equiv_over {C C' : category} (E : adj_equiv C C')
             {D : disp_cat C} {D': disp_cat C'}
             (EE : equiv_over E D D')
    : is_equiv_over E (left_adj_over EE).
  Proof.
    use tpair.
    - apply (right_adjoint_of_disp_adjunction EE).
    - apply (axioms_of_equiv_over E EE).
  Defined.

  (* TODO: adjointification of a quasi-equivalence. *)

End DisplayedEquivalences.

Section Constructions.
  (** * Constructions on and of displayed equivalences *)

  (** ** Full + faithful + ess split => equivalence *)
  Local Open Scope cat.
  Section Equiv_from_ff_plus_ess_split.
    (* TODO: consider naming throughout this section!  Especially: anything with [ses] should be fixed. *)

    Context {C C' : category}
            {F : functor C C'}
            {D : disp_cat C}
            {D' : disp_cat C'}
            (FF : disp_functor F D D')
            (FF_split : disp_functor_disp_ess_split_surj FF)
            (FF_ff : disp_functor_ff FF).

    (** *** Utility lemmas from fullness+faithfulness *)

    (* TODO: inline throughout? *)
    Let FFweq {x y} xx yy (f : x --> y) : xx -->[ f] yy ≃ FF x xx -->[#F f] FF y yy
        := disp_functor_ff_weq _ FF_ff xx yy f.
    Let FFinv {x y} {xx} {yy} {f} : FF x xx -->[#F f] FF y yy → xx -->[ f] yy
        := @disp_functor_ff_inv _ _ _ _ _ _ FF_ff x y xx yy f.

    (* TODO: once [disp_functor_ff_transportf_gen] is done, replace this with that. *)
    Lemma FFinv_transportf
          {x y : C} {f f' : x --> y} (e : f = f')
          {xx : D x} {yy : D y} (ff : FF _ xx -->[#F f] FF _ yy)
      : FFinv (transportf (λ f', _ -->[#F f'] _ ) e ff) = transportf _ e (FFinv ff).
    Proof.
      destruct e. apply idpath.
    Qed.

    Definition disp_functor_ff_reflects_isos
               {x y} {xx : D x} {yy : D y} {f : z_iso x y}
               (ff : xx -->[ f ] yy) (isiso: is_z_iso_disp (functor_on_z_iso F f) (♯ FF ff))
      : is_z_iso_disp _ ff.
    Proof.
      set (FFffinv := inv_mor_disp_from_z_iso isiso).
      set (FFffinv':= transportf (λ f', _ -->[ _ ] _ ) (functor_on_inv_from_z_iso F f) FFffinv).
      cbn in FFffinv'.
      set (ffinv := FFinv FFffinv').
      exists ffinv.
      split.
      - abstract
          (unfold ffinv, FFffinv'; clear ffinv FFffinv' ;
           apply (invmaponpathsweq (@FFweq _ _ _ _ _ )) ; cbn ;
           etrans ; [ apply (disp_functor_comp FF) | ] ;
           etrans ; [ apply maponpaths ;
                      apply maponpaths_2 ;
                      apply (homotweqinvweq (@FFweq _ _ _ _ _ ))
                    | ] ;
           rewrite transportf_const ; unfold idfun ;
           unfold FFffinv ; clear FFffinv ;
           etrans ; [ apply maponpaths ; apply (z_iso_disp_after_inv_mor isiso) | ] ;
           etrans ; [ apply transport_f_f | ] ;
           apply pathsinv0 ;
           etrans ; [ apply (disp_functor_transportf _ FF) | ] ;
           etrans ; [ apply maponpaths ; apply disp_functor_id | ] ;
           etrans ; [ apply transport_f_f | ] ;
           apply maponpaths_2 ; apply homset_property).
      - abstract
          (unfold ffinv, FFffinv'; clear ffinv FFffinv' ;
           apply (invmaponpathsweq (@FFweq _ _ _ _ _ )) ; cbn ;
           etrans ; [ apply (disp_functor_comp FF) | ] ;
           etrans ; [ apply maponpaths ;
                      apply maponpaths ;
                      apply (homotweqinvweq (@FFweq _ _ _ _ _ )) | ] ;
           etrans ; [ apply maponpaths ;
                      eapply maponpaths ;
                      apply (eqtohomot (transportf_const _ _))
                    | ] ;
           etrans ; [ apply maponpaths ;
                      unfold FFffinv ;
                      apply (inv_mor_after_z_iso_disp isiso)
                    | ] ;
           etrans ; [ apply transport_f_f | ] ;
           apply pathsinv0 ;
           etrans ; [ apply (disp_functor_transportf _ FF) | ] ;
           etrans ; [ apply maponpaths ; apply disp_functor_id | ] ;
           etrans ; [ apply transport_f_f | ] ;
           apply maponpaths_2 ;
           apply homset_property).
    Defined.

    Definition FFinv_on_z_iso_is_z_iso {x y} {xx : D x} {yy : D y} {f : z_iso x y}
               (ff : FF _ xx -->[ (#F)%cat f ] FF _ yy) (Hff: is_z_iso_disp (functor_on_z_iso F f) ff)
      : is_z_iso_disp _ (FFinv ff).
    Proof.
      apply disp_functor_ff_reflects_isos.
      use (transportf _ _ Hff).
      apply @pathsinv0. use homotweqinvweq.
    Qed.

    (* TODO: The converse functor. *)

  End Equiv_from_ff_plus_ess_split.

  (* TODO: Induced adjunctions / equivalences of fiber cats. *)
End Constructions.

(** * Displayed equivalences and adjunctions over identity *)

(** ** Adjunctions *)
Section AdjunctionsOverId.

(** In general, one can define displayed equivalences/adjunctions over any equivalences/adjunctions between the bases (and probably more generally still).  For now we just give the case over a single base precategory — i.e. over an identity functor.

We give the “bidirectional” version first, and then the “handed” versions afterwards, with enough coercions between the two to (hopefully) make it easy to work with both versions. *)

(* TODO: consider carefully the graph of coercions in this section; make them more systematic, and whatever we decide on, DOCUMENT the system clearly. *)

Definition disp_adjunction_id_data {C} (D D' : disp_cat C) : UU
:= ∑ (FF : disp_functor (functor_identity _) D D')
     (GG : disp_functor (functor_identity _) D' D),
     (disp_nat_trans (nat_trans_id _)
            (disp_functor_identity _) (disp_functor_composite FF GG))
   × (disp_nat_trans (nat_trans_id _ )
            (disp_functor_composite GG FF) (disp_functor_identity _)).

(* TODO: consider naming of these access functions *)
Definition left_adj_over_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id_data D D')
  : disp_functor _ D D'
:= pr1 A.
Coercion left_adj_over_id
  : disp_adjunction_id_data >-> disp_functor.

Definition right_adj_over_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id_data D D')
  : disp_functor _ D' D
:= pr1 (pr2 A).

Definition unit_over_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id_data D D')
:= pr1 (pr2 (pr2 A)).

Definition counit_over_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id_data D D')
:= pr2 (pr2 (pr2 A)).

(** Triangle identies for an adjunction *)

(** Note: the statements of these axioms include [_statement_] to distinguish them from the _instances_ of these statements given by the access functions of [form_adjunction].

This roughly follows the pattern of [univalenceStatement], [funextfunStatement], etc., but departs from it slightly to follow our more general convention of using underscores instead of camelcase.
*)

Definition triangle_1_statement_over_id  {C} {D D' : disp_cat C}
    (A : disp_adjunction_id_data D D')
    (FF := left_adj_over_id A)
    (η := unit_over_id A)
    (ε := counit_over_id A)
  : UU
:= ∏ x xx, ♯ FF ( η x xx) ;;  ε _ (FF _ xx)
            = transportb _ (id_left _ ) (id_disp _) .

Definition triangle_2_statement_over_id  {C} {D D' : disp_cat C}
    (A : disp_adjunction_id_data D D')
    (GG := right_adj_over_id A)
    (η := unit_over_id A)
    (ε := counit_over_id A)
  : UU
:= ∏ x xx, η _ (GG x xx) ;; ♯ GG (ε _ xx)
           = transportb _ (id_left _ ) (id_disp _).

Definition form_disp_adjunction_id {C} {D D' : disp_cat C}
    (A : disp_adjunction_id_data D D')
  : UU
:= triangle_1_statement_over_id A × triangle_2_statement_over_id A.

Definition disp_adjunction_id {C} (D D' : disp_cat C) : UU
:= ∑ A : disp_adjunction_id_data D D', form_disp_adjunction_id A.

Definition data_of_disp_adjunction_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id D D')
:= pr1 A.
Coercion data_of_disp_adjunction_id
  : disp_adjunction_id >-> disp_adjunction_id_data.

Definition triangle_1_over_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id D D')
:= pr1 (pr2 A).

Definition triangle_2_over_id {C} {D D' : disp_cat C}
  (A : disp_adjunction_id D D')
:= pr2 (pr2 A).

(** The “left-handed” version: right adjoints to a given functor *)

(** The terminology is difficult to choose here: the proposition “F is a left adjoint” is the same as the type of “right adjoints to F”, so should this type be called something more like [left_adjoint F] or [right_adjoint F]?

Our choice here does _not_ agree with that of the base UniMath category theory library. TODO: consider these conventions, and eventually harmonise them by changing it either here or in UniMath. *)

Definition right_adjoint_over_id_data {C} {D D' : disp_cat C}
  (FF : disp_functor (functor_identity _) D D') : UU
:= ∑ (GG : disp_functor (functor_identity _) D' D),
     (disp_nat_trans (nat_trans_id _)
            (disp_functor_identity _) (disp_functor_composite FF GG))
   × (disp_nat_trans (nat_trans_id _ )
            (disp_functor_composite GG FF) (disp_functor_identity _)).

Definition functor_of_right_adjoint_over_id {C} {D D' : disp_cat C}
  {FF : disp_functor _ D D'}
  (GG : right_adjoint_over_id_data FF)
:= pr1 GG.
Coercion functor_of_right_adjoint_over_id
  : right_adjoint_over_id_data >-> disp_functor.

Definition adjunction_of_right_adjoint_over_id_data {C} {D D' : disp_cat C}
    {FF : disp_functor _ D D'}
    (GG : right_adjoint_over_id_data FF)
  : disp_adjunction_id_data D D'
:= (FF,, GG).
Coercion adjunction_of_right_adjoint_over_id_data
  : right_adjoint_over_id_data >-> disp_adjunction_id_data.

Definition right_adjoint_of_disp_adjunction_id_data {C} {D D' : disp_cat C}
    (A : disp_adjunction_id_data D D')
  : right_adjoint_over_id_data A
:= pr2 A.

Definition right_adjoint_over_id {C} {D D' : disp_cat C}
  (FF : disp_functor (functor_identity _) D D') : UU
:= ∑ GG : right_adjoint_over_id_data FF,
   form_disp_adjunction_id GG.

Definition data_of_right_adjoint_over_id {C} {D D' : disp_cat C}
  {FF : disp_functor _ D D'}
  (GG : right_adjoint_over_id FF)
:= pr1 GG.
Coercion data_of_right_adjoint_over_id
  : right_adjoint_over_id >-> right_adjoint_over_id_data.

Definition adjunction_of_right_adjoint_over_id {C} {D D' : disp_cat C}
    {FF : disp_functor _ D D'}
    (GG : right_adjoint_over_id FF)
  : disp_adjunction_id D D'
:= (adjunction_of_right_adjoint_over_id_data GG ,, pr2 GG).

Definition right_adjoint_of_disp_adjunction_id {C} {D D' : disp_cat C}
    (A : disp_adjunction_id D D')
  : right_adjoint_over_id A
:= (right_adjoint_of_disp_adjunction_id_data A,, pr2 A).

(* TODO: add the dual-handedness version, i.e. indexed over GG instead of FF. *)
End AdjunctionsOverId.

Section EquivalencesOverId.
(** ** Displayed equivalences over id (adjoint and quasi) *)

Definition form_equiv_over_id {C} {D D' : disp_cat C}
    (A : disp_adjunction_id_data D D')
    (η := unit_over_id A)
    (ε := counit_over_id A)
  : UU
:= (∏ x xx, is_z_iso_disp (identity_z_iso _ ) (η x xx))
 × (∏ x xx, is_z_iso_disp (identity_z_iso _ ) (ε x xx)).

Definition is_z_iso_unit_over_id {C} {D D' : disp_cat C}
  {A : disp_adjunction_id_data D D'}
  (E : form_equiv_over_id A)
:= pr1 E.

Definition is_z_iso_counit_over_id {C} {D D' : disp_cat C}
  {A : disp_adjunction_id_data D D'}
  (E : form_equiv_over_id A)
:= pr2 E.

Definition equiv_over_id {C} (D D' : disp_cat C) : UU
:= ∑ A : disp_adjunction_id D D', form_equiv_over_id A.

Definition adjunction_of_equiv_over_id {C} {D D' : disp_cat C}
  (A : equiv_over_id D D')
:= pr1 A.
Coercion adjunction_of_equiv_over_id
  : equiv_over_id >-> disp_adjunction_id.

Definition axioms_of_equiv_over_id {C} {D D' : disp_cat C}
  (A : equiv_over_id D D')
:= pr2 A.
Coercion axioms_of_equiv_over_id
  : equiv_over_id >-> form_equiv_over_id.

Definition is_equiv_over_id {C} {D D' : disp_cat C}
  (FF : disp_functor (functor_identity _) D D') : UU
:= ∑ GG : right_adjoint_over_id FF,
   form_equiv_over_id GG.

Definition right_adjoint_of_is_equiv_over_id {C} {D D' : disp_cat C}
  {FF : disp_functor _ D D'}
  (E : is_equiv_over_id FF)
:= pr1 E.
Coercion right_adjoint_of_is_equiv_over_id
  : is_equiv_over_id >-> right_adjoint_over_id.

Definition equiv_of_is_equiv_over_id {C} {D D' : disp_cat C}
    {FF : disp_functor _ D D'}
    (E : is_equiv_over_id FF)
  : equiv_over_id D D'
:= (adjunction_of_right_adjoint_over_id E ,, pr2 E).
Coercion equiv_of_is_equiv_over_id
  : is_equiv_over_id >-> equiv_over_id.
(* Again, don’t worry about the ambiguous path generated here. *)

Definition is_equiv_of_equiv_over_id {CC} {DD DD' : disp_cat CC}
    (E : equiv_over_id DD DD')
  : is_equiv_over_id E
:= (right_adjoint_of_disp_adjunction_id E,, axioms_of_equiv_over_id E).

(* TODO: right-handed versions *)

(* TODO: [quasi_equiv_over_id] (without triangle identities). *)

(** ** Lemmas on the triangle identities *)

Local Open Scope hide_transport_scope.

Lemma triangle_2_from_1_for_equiv_over_id
  {C} {D D' : disp_cat C}
  (A : disp_adjunction_id_data D D')
  (E : form_equiv_over_id A)
: triangle_1_statement_over_id A -> triangle_2_statement_over_id A.
Proof.
  destruct A as [FF [GG [η ε]]].
  destruct E as [Hη Hε]; cbn in Hη, Hε.
  unfold triangle_1_statement_over_id, triangle_2_statement_over_id; cbn.
  intros T1 x yy.
  (* Algebraically, this goes as follows:
  η G ; G ε
  = G ε^ ; η^ G ; η G ; G ε ; η G ; G ε          [by inverses, 1]
  = G ε^ ; η^ G ; η G ; η G F G ; G F G ε ; G ε  [by naturality, 2]
  = G ε^ ; η^ G ; η G ; η G F G ; G ε F G ; G ε  [by naturality, 3]
  = G ε^ ; η^ G ; η G ; G F η G ; G ε F G ; G ε  [by naturality, 4]
  = G ε^ ; η^ G ; η G ; G (F η ; ε F ) G ; G ε   [by functoriality, 5]
  = G ε^ ; η^ G ; η G ; G ε                      [by T1, 6]
  = 1                                            [by inverses, 7]

  It’s perhaps most readable when written in string diagrams. *)
  etrans. apply id_left_disp_var.
  etrans. eapply transportf_bind.
    eapply cancel_postcomposition_disp.
    etrans. eapply transportf_transpose_right. apply @pathsinv0.
      refine (z_iso_disp_after_inv_mor _).
      refine (disp_functor_on_is_z_iso_disp GG _).
      apply Hε. (*1a*)
    eapply transportf_bind.
    eapply cancel_postcomposition_disp.
    etrans. apply id_right_disp_var.
    eapply transportf_bind.
    etrans. eapply cancel_precomposition_disp.
    eapply transportf_transpose_right. apply @pathsinv0.
      refine (z_iso_disp_after_inv_mor _).
      apply (Hη). (*1b*)
    eapply transportf_bind, assoc_disp.
  etrans. eapply transportf_bind.
    etrans. apply assoc_disp_var.
    eapply transportf_bind.
    etrans. apply assoc_disp_var.
    eapply transportf_bind.
    eapply cancel_precomposition_disp.
    etrans. eapply cancel_precomposition_disp.
      etrans. apply assoc_disp.
      eapply transportf_bind.
      etrans. eapply cancel_postcomposition_disp.
        exact (disp_nat_trans_ax η (♯ GG (ε x yy))). (*2*)
      eapply transportf_bind.
      etrans. apply assoc_disp_var.
      eapply transportf_bind.
      eapply cancel_precomposition_disp.
      cbn.
      etrans. eapply transportf_transpose_right.
        apply @pathsinv0, (disp_functor_comp GG).
      eapply transportf_bind.
      etrans. apply maponpaths.
        apply (disp_nat_trans_ax ε). (*3*)
      cbn.
      etrans. apply (disp_functor_transportf _ GG).
      eapply transportf_bind.
      apply (disp_functor_comp GG).
    eapply transportf_bind.
    etrans. apply assoc_disp.
    eapply transportf_bind.
    etrans. eapply cancel_postcomposition_disp.
      apply (disp_nat_trans_ax η (η x (GG x yy))). (*4*)
    cbn.
    eapply transportf_bind.
    etrans. apply assoc_disp_var.
    eapply transportf_bind.
    eapply cancel_precomposition_disp.
    etrans. apply assoc_disp.
    eapply transportf_bind.
    etrans. eapply cancel_postcomposition_disp.
      etrans. eapply transportf_transpose_right.
        apply @pathsinv0, (disp_functor_comp GG). (*5*)
      eapply transportf_bind.
      etrans. apply maponpaths, T1. (*6*)
      etrans. apply (disp_functor_transportf _ GG).
      eapply transportf_bind. apply (disp_functor_id GG).
    eapply transportf_bind. apply id_left_disp.
  etrans. eapply transportf_bind.
    etrans. apply assoc_disp_var.
    eapply transportf_bind.
    etrans. eapply cancel_precomposition_disp.
      etrans. apply assoc_disp.
      eapply transportf_bind.
      etrans. eapply cancel_postcomposition_disp.
        exact (z_iso_disp_after_inv_mor _). (*7a*)
      eapply transportf_bind. apply id_left_disp.
    apply maponpaths. exact (z_iso_disp_after_inv_mor _). (*7b*)
  etrans. apply transport_f_f.
  unfold transportb. apply maponpaths_2, homset_property.
Time Qed.
(* TODO: [Qed.] takes about 30sec!  [etrans_dep] + [etrans_disp] make it shorter and more readable (see commit 7c1f411a), but make the typechecking time even worse. *)

Lemma triangle_1_from_2_for_equiv_over_id
  {C} {D D' : disp_cat C}
  (A : disp_adjunction_id_data D D')
  (E : form_equiv_over_id A)
: triangle_2_statement_over_id A -> triangle_1_statement_over_id A.
Proof.
  (* dual to previous lemma *)
Abort.

(* TODO: adjointification of a quasi-equivalence. *)

End EquivalencesOverId.

(** * Constructions on and of displayed equivalences over identity *)

(** ** Full + faithful + ess split => equivalence *)
Section Equiv_from_ff_plus_ess_split.
(* TODO: consider naming throughout this section!  Especially: anything with [ses] should be fixed. *)

Context {C : category} {D' D : disp_cat C}
        (FF : disp_functor (functor_identity _) D' D)
        (FF_split : disp_functor_disp_ess_split_surj FF)
        (FF_ff : disp_functor_ff FF).

(** *** Utility lemmas from fullness+faithfulness *)

(* TODO: inline throughout? *)
Let FFweq {x y} xx yy (f : x --> y) := disp_functor_ff_weq _ FF_ff xx yy f.
Let FFinv {x y} {xx} {yy} {f}
  := @disp_functor_ff_inv _ _ _ _ _ _ FF_ff x y xx yy f.

(* TODO: once [disp_functor_ff_transportf_gen] is done, replace this with that. *)
Lemma FFinv_over_id_transportf
    {x y : C} {f f' : x --> y} (e : f = f')
    {xx : D' x} {yy : D' y} (ff : FF _ xx -->[f] FF _ yy)
  : FFinv (transportf _ e ff) = transportf _ e (FFinv ff).
Proof.
  destruct e. apply idpath.
Qed.

Definition disp_functor_id_ff_reflects_isos
  {x y} {xx : D' x} {yy : D' y} {f : z_iso x y}
  (ff : xx -->[ f ] yy) (isiso: is_z_iso_disp f (♯ FF ff))
  : is_z_iso_disp _ ff.
Proof.
  use (disp_functor_ff_reflects_isos FF FF_ff).
  exact (disp_functor_on_is_z_iso_disp (disp_functor_identity _) isiso).
Qed.

Definition FFinv_over_id_on_z_iso_is_z_iso   {x y} {xx : D' x} {yy : D' y} {f : z_iso x y}
  (ff : FF _ xx -->[ f ] FF _ yy) (Hff: is_z_iso_disp f ff)
  : is_z_iso_disp _ (FFinv ff).
Proof.
  apply disp_functor_id_ff_reflects_isos.
  use (transportf _ _ Hff).
  apply @pathsinv0. use homotweqinvweq.
Qed.

(** *** Converse functor *)

(* TODO: does [Local Definition] actually keep it local?  It seems not — e.g. [Print GG_data] still works after the section closes. Is there a way to actually keep them local?  If not, find less generic names for [GG] and its components. *)
Local Definition GG_data : disp_functor_data (functor_identity _ ) D D'.
Proof.
  use tpair.
  + intros x xx. exact (pr1 (FF_split x xx)).
  + intros x y xx yy f ff; simpl.
    set (Hxx := FF_split x xx).
    set (Hyy := FF_split y yy).
    apply FFinv.
    refine (transportf (mor_disp _ _) _ _).
    2: exact ((pr2 Hxx ;; ff) ;; inv_mor_disp_from_z_iso (pr2 Hyy)).
    cbn. etrans. apply id_right. apply id_left.
Defined.

Local Lemma GG_ax : disp_functor_axioms GG_data.
Proof.
  split; simpl.
  + intros x xx.
    apply invmap_eq. cbn.
    etrans. 2: apply @pathsinv0, (disp_functor_id FF).
    etrans. apply maponpaths.
      etrans. apply maponpaths_2, id_right_disp.
      etrans. apply mor_disp_transportf_postwhisker.
      apply maponpaths, (inv_mor_after_z_iso_disp (pr2 (FF_split _ _))).
    etrans. apply transport_f_f.
    etrans. apply transport_f_f.
    unfold transportb. apply maponpaths_2, homset_property.
  + intros x y z xx yy zz f g ff gg.
    apply invmap_eq. cbn.
    etrans.
    2: { apply @pathsinv0.
         etrans. apply (disp_functor_comp FF).
         etrans. apply maponpaths.
           etrans. apply maponpaths; use homotweqinvweq.
           apply maponpaths_2; use homotweqinvweq.
         etrans. apply maponpaths.
           etrans. apply mor_disp_transportf_prewhisker.
           apply maponpaths.
           etrans. apply mor_disp_transportf_postwhisker.
           apply maponpaths.
           etrans. apply maponpaths, assoc_disp_var.
           etrans. apply mor_disp_transportf_prewhisker.
           apply maponpaths.
           etrans. apply assoc_disp.
           apply maponpaths.
           etrans. apply maponpaths_2.
             etrans. apply assoc_disp_var.
             apply maponpaths.
             etrans. apply maponpaths.
               exact (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))).
             etrans. apply mor_disp_transportf_prewhisker.
             etrans. apply maponpaths, id_right_disp.
             apply transport_f_f.
           etrans. apply maponpaths_2, transport_f_f.
           apply mor_disp_transportf_postwhisker.
         etrans. apply transport_f_f.
         etrans. apply transport_f_f.
         etrans. apply transport_f_f.
         etrans. apply transport_f_f.
         etrans. apply transport_f_f.
         (* A trick to hide the huge equality term: *)
         apply maponpaths_2. shelve.
       }
    etrans. apply maponpaths.
      etrans. apply maponpaths_2, assoc_disp.
      etrans. apply mor_disp_transportf_postwhisker.
      apply maponpaths. apply assoc_disp_var.
    etrans. apply transport_f_f.
    etrans. apply transport_f_f.
    apply maponpaths_2, homset_property.
    Unshelve. 2: apply idpath.
Qed.

Definition GG : disp_functor _ _ _ := (_ ,, GG_ax).

Definition ε_ses_ff_data
  : disp_nat_trans_data (nat_trans_id _ )
      (disp_functor_composite GG FF) (disp_functor_identity _ )
:= λ x xx, (pr2 (FF_split x xx)).

Lemma ε_ses_ff_ax : disp_nat_trans_axioms ε_ses_ff_data.
Proof.
  intros x y f xx yy ff. cbn. unfold ε_ses_ff_data.
  etrans. apply maponpaths_2; use homotweqinvweq.
  etrans. apply mor_disp_transportf_postwhisker.
  etrans. apply maponpaths.
    etrans. apply assoc_disp_var.
    apply maponpaths.
    etrans. apply maponpaths.
      apply (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))).
    etrans. apply mor_disp_transportf_prewhisker.
    apply maponpaths, id_right_disp.
  etrans. apply transport_f_f.
  etrans. apply transport_f_f.
  etrans. apply transport_f_f.
  unfold transportb. apply maponpaths_2, homset_property.
Qed.

Definition ε_ses_ff
  : disp_nat_trans (nat_trans_id _ )
      (disp_functor_composite GG FF) (disp_functor_identity _ )
:= (ε_ses_ff_data,, ε_ses_ff_ax).

Definition η_ses_ff_data
  : disp_nat_trans_data (nat_trans_id _)
      (disp_functor_identity _ ) (disp_functor_composite FF GG).
Proof.
  intros x xx. cbn.
  apply FFinv.
  exact (inv_mor_disp_from_z_iso (pr2 (FF_split _ _))).
Defined.

Definition η_ses_ff_ax
  : disp_nat_trans_axioms η_ses_ff_data.
Proof.
  intros x y f xx yy ff. cbn. unfold η_ses_ff_data.
  (* This feels a bit roundabout.  Can it be simplified? *)
  apply @pathsinv0.
  etrans. eapply maponpaths.
    etrans. apply @pathsinv0, disp_functor_ff_inv_compose.
    apply maponpaths.
    etrans. apply mor_disp_transportf_prewhisker.
    apply maponpaths.
    etrans. apply assoc_disp.
    apply maponpaths.
    etrans. apply maponpaths_2.
      etrans. apply assoc_disp.
      apply maponpaths.
      etrans.
        apply maponpaths_2, (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))).
      etrans. apply mor_disp_transportf_postwhisker.
      etrans. apply maponpaths, id_left_disp.
      apply transport_f_f.
    etrans. apply maponpaths_2, transport_f_f.
    apply mor_disp_transportf_postwhisker.
  etrans. apply maponpaths.
    etrans. apply maponpaths.
      etrans. apply transport_f_f.
      apply transport_f_f.
    apply FFinv_over_id_transportf.
  etrans. apply transport_f_f.
  apply transportf_comp_lemma_hset.
    apply homset_property.
  etrans. apply (disp_functor_ff_inv_compose _ FF_ff).
  apply maponpaths_2, homotinvweqweq.
Qed.

Definition η_ses_ff
  : disp_nat_trans (nat_trans_id _)
      (disp_functor_identity _ ) (disp_functor_composite FF GG)
:= (_ ,, η_ses_ff_ax).

Definition GGεη : right_adjoint_over_id_data FF
  := (GG,, (η_ses_ff,, ε_ses_ff)).

Lemma form_equiv_GGεη : form_equiv_over_id GGεη.
Proof.
  split; intros x xx; cbn.
  - unfold η_ses_ff_data.
    apply (@FFinv_over_id_on_z_iso_is_z_iso _ _ _ _ (identity_z_iso _)).
    eapply is_z_iso_disp_independent_of_is_z_iso.
    exact (@is_z_iso_inv_from_z_iso_disp _ _ _ _ (identity_z_iso _) _ _ _).
  - unfold ε_ses_ff_data.
    apply is_z_iso_disp_from_z_iso.
Qed.

Lemma tri_1_GGεη : triangle_1_statement_over_id GGεη.
Proof.
  intros x xx; cbn.
  unfold ε_ses_ff_data, η_ses_ff_data.
  etrans. apply maponpaths_2; use homotweqinvweq.
  etrans. exact (z_iso_disp_after_inv_mor (pr2 (FF_split _ _))).
  apply maponpaths_2, homset_property.
Qed.

Lemma tri_2_GGεη : triangle_2_statement_over_id GGεη.
Proof.
  apply triangle_2_from_1_for_equiv_over_id.
  apply form_equiv_GGεη.
  apply tri_1_GGεη.
Qed.

Theorem is_equiv_from_ff_ess_over_id : is_equiv_over_id FF.
Proof.
  use ((GGεη,, _) ,, _).
  split. apply tri_1_GGεη. apply tri_2_GGεη.
  apply form_equiv_GGεη.
Defined.

End Equiv_from_ff_plus_ess_split.

(** ** Inverses and composition of adjunctions/equivalences *)

Section Nat_Trans_Disp_Inv.

Context {C : category} {D' D : disp_cat C}
        {FF GG : disp_functor (functor_identity _) D' D}
        (alpha : disp_nat_trans (nat_trans_id _ ) FF GG)
        (Ha : ∏ x xx, is_z_iso_disp (identity_z_iso _ ) (alpha x xx)).

(*
Lemma inv_ax : disp_nat_trans_axioms
    (λ (x : C) (xx : D' x), @inv_mor_disp_from_iso _ _ _ _ (identity_iso _ ) _  _ _ (Ha x xx)).
*)

Local Lemma inv_ax : @disp_nat_trans_axioms C C (functor_identity_data C)
    (functor_identity_data C) (@nat_trans_id C C (functor_identity_data C))
    D' D GG FF
    (λ (x : C) (xx : D' x),
     @inv_mor_disp_from_z_iso C D ((functor_identity C) x)
       ((functor_identity C) x) (@identity_z_iso C ((functor_identity C) x))
       (FF x xx) (GG x xx) (alpha x xx) (Ha x xx)).
Proof.
   intros x y f xx yy ff.
    apply pathsinv0.
    apply transportf_pathsinv0.
    apply pathsinv0.
    set (XR := @z_iso_disp_precomp).
    specialize (XR _ _ _ _ (identity_z_iso _ ) _ _ (alpha x xx ,, Ha x xx) ).
    match goal with |[|- ?EE = _ ] => set (E := EE) end. cbn in E.
    specialize (XR _ (identity x · f) (FF y yy)).
    set (R := make_weq _ XR).
    apply (invmaponpathsweq R).
    unfold R. unfold E. cbn.
    etrans. apply assoc_disp.
    etrans. apply maponpaths. apply maponpaths_2.
            apply (inv_mor_after_z_iso_disp (Ha x xx)).
    etrans. apply maponpaths.
            apply mor_disp_transportf_postwhisker.
    etrans. apply transport_f_f.
    etrans. apply maponpaths. apply id_left_disp.
    etrans. apply transport_f_f.
    apply pathsinv0.
    etrans. apply mor_disp_transportf_prewhisker.
    etrans. apply maponpaths.
            apply assoc_disp.
    etrans. apply transport_f_f.
    etrans. apply maponpaths. apply maponpaths_2.
            apply (disp_nat_trans_ax_var alpha).
    etrans. apply maponpaths.
            apply mor_disp_transportf_postwhisker.
    etrans. apply transport_f_f.
    etrans. apply maponpaths. apply assoc_disp_var.
    etrans. apply transport_f_f.
    etrans. apply maponpaths. apply maponpaths.
            apply (inv_mor_after_z_iso_disp (Ha _ _ )).
    etrans. apply maponpaths.
            apply mor_disp_transportf_prewhisker.

     etrans. apply transport_f_f.
    etrans. apply maponpaths. apply id_right_disp.
    etrans. apply transport_f_f.
    apply maponpaths_2.
    apply homset_property.
Qed.

Local Definition inv : disp_nat_trans (nat_trans_id _ ) GG FF.
Proof.
  use tpair.
  - intros x xx.
    apply (inv_mor_disp_from_z_iso (Ha _ _ )).
  - apply inv_ax.
Defined.

End Nat_Trans_Disp_Inv.

Section Displayed_Equiv_Inv.

Context {C : category} {D' D : disp_cat C}
        (FF : disp_functor (functor_identity _) D' D)
        (isEquiv : is_equiv_over_id FF).

Let GG : disp_functor _ D D' := right_adjoint_of_is_equiv_over_id isEquiv.
Let η : disp_nat_trans (nat_trans_id (functor_identity C))
                       (disp_functor_identity D')
                       (disp_functor_composite FF GG)
  := unit_over_id isEquiv.

Let ε :  disp_nat_trans
           (nat_trans_id (functor_identity C))
           (disp_functor_composite GG FF)
           (disp_functor_identity D)
  := counit_over_id isEquiv.

Definition η_inv : disp_nat_trans (nat_trans_id (functor_identity C))
    (disp_functor_identity D) (disp_functor_composite GG FF).
Proof.
  apply (inv ε).
  apply (is_z_iso_counit_over_id isEquiv).
Defined.

Definition ε_inv :
 disp_nat_trans
    (nat_trans_id
       (functor_identity C))
    (disp_functor_composite FF GG) (disp_functor_identity D').
Proof.
  apply (inv η). cbn.
  apply (is_z_iso_unit_over_id isEquiv).
Defined.

Definition inv_adjunction_data : disp_adjunction_id_data D D'.
Proof.
  exists GG.
  exists FF.
  exists η_inv.
  exact ε_inv.
Defined.

Lemma form_equiv_inv_adjunction_data : form_equiv_over_id inv_adjunction_data.
Proof.
  cbn. use tpair.
    + intros. cbn.
      set (XR:= @is_z_iso_inv_from_is_z_iso_disp).
      specialize (XR _ D _  _ _ _ _ _ (is_z_iso_counit_over_id (pr2 isEquiv) x xx)).
      cbn in XR.
      eapply is_z_iso_disp_independent_of_is_z_iso.
      apply XR.
    + cbn. intros.
      set (XR:= @is_z_iso_inv_from_is_z_iso_disp).
      specialize (XR _ D' _  _ _ _ _ _ (is_z_iso_unit_over_id (pr2 isEquiv) x xx)).
      cbn in XR.
      eapply is_z_iso_disp_independent_of_is_z_iso.
      apply XR.
Qed.

Lemma inv_triangle_1_statement_over_id
  : triangle_1_statement_over_id inv_adjunction_data.
Proof.
  intros x xx. cbn.
        set (XR:= @z_iso_disp_precomp).
        set (Gepsxxx := (♯ GG (ε x xx))).
        set (RG := @disp_functor_on_is_z_iso_disp _ _ (functor_identity C)).
        specialize (RG _ _ GG).
        specialize (RG _ _ _ _ (identity_z_iso _ )  (ε x xx)).
        specialize (RG (is_z_iso_counit_over_id (pr2 isEquiv) x xx)).
        transparent assert (Ge : (z_iso_disp (identity_z_iso x)
                                  (GG _ (FF _ (GG _ xx))) (GG _ xx))).
        { apply (make_z_iso_disp (f:=identity_z_iso _ ) Gepsxxx).
          eapply is_z_iso_disp_independent_of_is_z_iso.
          apply RG.
        }

        match goal with |[|- ?EE = _ ] => set (E := EE) end. cbn in E.
        specialize (XR _ _ _ _ _ _ _ Ge).
        specialize (XR _ (identity x · identity x ) (GG x xx)).
        apply (invmaponpathsweq (make_weq _ XR)).
        unfold E; clear E.
        cbn.
        clear RG XR Ge.
        unfold Gepsxxx.
        etrans. apply assoc_disp.
        etrans. apply maponpaths. apply maponpaths_2.
                eapply pathsinv0. apply (disp_functor_comp_var GG).
        etrans. apply maponpaths. apply mor_disp_transportf_postwhisker.
        etrans. apply transport_f_f.
        etrans. apply maponpaths. apply maponpaths_2.
                apply maponpaths.
                apply (inv_mor_after_z_iso_disp (is_z_iso_counit_over_id (pr2 isEquiv) x xx)).
        etrans. apply maponpaths. apply maponpaths_2.
                apply (disp_functor_transportf _ GG).
        etrans. apply maponpaths. apply  mor_disp_transportf_postwhisker.
        etrans. apply ( transport_f_f _ _ _ _ ).
        etrans. apply maponpaths. apply maponpaths_2.
                apply (disp_functor_id GG).
        etrans. apply maponpaths. apply  mor_disp_transportf_postwhisker.
        etrans. apply transport_f_f.
        etrans. apply maponpaths. apply id_left_disp.
        etrans. apply transport_f_f.

        match goal with |[|- transportf _ ?EE _ = _ ] => generalize EE end.
        intro EE.

        set (XR:= @z_iso_disp_precomp).
        set (etaGxxx := η _ (GG x xx)).
        transparent assert (Ge : (z_iso_disp (identity_z_iso x)
                                  (GG _ xx) (GG _ (FF _ (GG _ xx))) )).
        { apply (make_z_iso_disp (f:=identity_z_iso _ ) etaGxxx).
          eapply is_z_iso_disp_independent_of_is_z_iso.
          apply (is_z_iso_unit_over_id (pr2 isEquiv) ).
        }

        match goal with |[|- ?EE = _ ] => set (E := EE) end. cbn in E.
        specialize (XR _ _ _ _ _ _ _ Ge).
        specialize (XR _ (identity x · (identity x · identity x) )  (GG x xx)).
        apply (invmaponpathsweq (make_weq _ XR)).

        cbn. unfold etaGxxx.
        unfold E.
        clear E. clear XR Ge etaGxxx.
        clear Gepsxxx.

        etrans. apply  mor_disp_transportf_prewhisker.
        etrans. apply maponpaths.
           apply (inv_mor_after_z_iso_disp (is_z_iso_unit_over_id (pr2 isEquiv) x _ )).
        etrans. apply transport_f_f.
        apply pathsinv0.
        etrans. apply maponpaths. apply  mor_disp_transportf_prewhisker.
        etrans. apply mor_disp_transportf_prewhisker.
        etrans. apply maponpaths.
                apply maponpaths. apply id_right_disp.
        etrans. apply maponpaths. apply  mor_disp_transportf_prewhisker.
        etrans. apply transport_f_f.
        set (XR := triangle_2_over_id isEquiv).
        unfold triangle_1_statement_over_id in XR.
        cbn in XR.
        etrans. apply maponpaths. apply XR.
        etrans. apply transport_f_f.
        apply maponpaths_2.
        apply homset_property.
Qed.

Lemma inv_triangle_2_statement_over_id
  : triangle_2_statement_over_id inv_adjunction_data.
Proof.
  apply triangle_2_from_1_for_equiv_over_id.
  - apply form_equiv_inv_adjunction_data.
  - apply inv_triangle_1_statement_over_id.
Qed.

Definition equiv_inv : is_equiv_over_id GG.
Proof.
  use tpair.
  - use tpair.
    + exact (FF,, (η_inv,, ε_inv)).
    + use tpair. cbn. apply inv_triangle_1_statement_over_id.
      apply inv_triangle_2_statement_over_id.
  - apply form_equiv_inv_adjunction_data.
Defined.

End Displayed_Equiv_Inv.

Section Displayed_Equiv_Compose.

(* TODO: give composites of displayed equivalences. *)

End Displayed_Equiv_Compose.

(** ** Induced adjunctions/equivalences of fiber precats *)
Section Equiv_Fibers.

Context {C : category}.

Definition fiber_is_left_adj {D D' : disp_cat C}
  {FF : disp_functor (functor_identity _) D D'}
  (EFF : right_adjoint_over_id FF)
  (c : C)
: is_left_adjoint (fiber_functor FF c).
Proof.
  destruct EFF as [[GG [η ε]] axs]; simpl in axs.
  exists (fiber_functor GG _).
  exists (fiber_nat_trans η _,,
          fiber_nat_trans ε _).
  use tpair; cbn.
  + unfold triangle_1_statement.
    intros d; cbn.
    set (thisax := pr1 axs c d); clearbody thisax; clear axs.
    etrans. apply maponpaths, thisax.
    etrans. apply transport_f_b.
    use (@maponpaths_2 _ _ _ _ _ (paths_refl _)).
    apply homset_property.
  + unfold triangle_2_statement.
    intros d; cbn.
    set (thisax := pr2 axs c d); clearbody thisax; clear axs.
    etrans. apply maponpaths, thisax.
    etrans. apply transport_f_b.
    use (@maponpaths_2 _ _ _ _ _ (paths_refl _)).
    apply homset_property.
Defined.

Definition fiber_equiv {D D' : disp_cat C}
  {FF : disp_functor (functor_identity _) D D'}
  (EFF : is_equiv_over_id FF)
  (c : C)
: adj_equivalence_of_cats (fiber_functor FF c).
Proof.
  exists (fiber_is_left_adj EFF c).
  destruct EFF as [[[GG [η ε]] tris] isos]; cbn in isos; cbn.
  use tpair.
  + intros d.
    apply is_z_iso_fiber_from_is_z_iso_disp.
    apply (is_z_iso_unit_over_id isos).
  + intros d.
    apply is_z_iso_fiber_from_is_z_iso_disp.
    apply (is_z_iso_counit_over_id isos).
Defined.

End Equiv_Fibers.


(* An example with constr subentries *)

Module A.

Declare Custom Entry myconstr.

Notation "[ x ]" := x (x custom myconstr at level 6).
Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5).
Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4).
Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10).
Check [ < 0 > + < 1 > * < 2 >].

Axiom a : nat.
Notation b := a.
Check [ < b > + < a > * < 2 >].

Declare Custom Entry anotherconstr.

Notation "[ x ]" := x (x custom myconstr at level 6).
Notation "<< x >>" := x (in custom myconstr at level 3, x custom anotherconstr at level 10).
Notation "# x" := (Some x) (in custom anotherconstr at level 8, x constr at level 9).
Check [ << # 0 >> ].

End A.

Module B.

Inductive Expr :=
 | Mul : Expr -> Expr -> Expr
 | Add : Expr -> Expr -> Expr
 | One : Expr.

Declare Custom Entry expr.
Notation "[ expr ]" := expr (expr custom expr at level 2).
Notation "1" := One (in custom expr at level 0).
Notation "x y" := (Mul x y) (in custom expr at level 1, left associativity).
Notation "x + y" := (Add x y) (in custom expr at level 2, left associativity).
Notation "( x )" := x (in custom expr at level 0, x at level 2).
Notation "{ x }" := x (in custom expr at level 0, x constr).
Notation "x" := x (in custom expr at level 0, x ident).

Axiom f : nat -> Expr.
Check [1 {f 1}].
Check fun x y z => [1 + y z + {f x}].
Check fun e => match e with
| [x y + z] => [x + y z]
| [1 + 1] => [1]
| y => [y + e]
end.

End B.

Module C.

Inductive Expr :=
 | Add : Expr -> Expr -> Expr
 | One : Expr.

Declare Custom Entry expr.
Notation "[ expr ]" := expr (expr custom expr at level 1).
Notation "1" := One (in custom expr at level 0).
Notation "x + y" := (Add x y) (in custom expr at level 2, left associativity).
Notation "( x )" := x (in custom expr at level 0, x at level 2).

(* Check the use of a two-steps coercion from constr to expr 1 then
   from expr 0 to expr 2 (note that camlp5 parsing is more tolerant
   and does not require parentheses to parse from level 2 while at
   level 1) *)

Check [1 + 1].

End C.


(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
(*    FullAtomicJl:
        Decidable, Tag-Based Semantic Subtyping
        for Nominal Types, Pairs, and Unions.  *)

(** * FullAtomicJl: Definitions *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)

Add LoadPath "../..". (* root directory of the repo *)

Require Import  Mechanization.Aux.Identifier.

Require Import Coq.Lists.List.
Import ListNotations.
Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.

(** Our goal is to define "semantic" subtyping on
    nominal types, covariant pairs, and unions.
    We are going to interpret types as sets of type tags
    (i.e. types that have direct instances).
    When interpreting abstract nominal types, we also account for
    their future subtypes.
 *)

(* ################################################################# *)
(** ** Types *)
(* ################################################################# *)

(** We start with the full grammar of types:

    [τ ::= cname | aname | τ1×τ2 | τ1∪τ2 | Ext<aname> ]

    where [cname] is a _concrete_ nominal (named) type,
    that is a type of a user-defined/built-in value,
    [aname] is an _abstract_ nominal type,
    and [Ext<aname>] is an extension type,
    i.e. "future" concrete nominal subtype of
    an abstract nominal type.
    Extension types cannot be used by the user.
 *)

(*
  τ,σ ::=
        | Int | Flt
        | Real
        | Cmplx
        | Num
        | Str
        | τ1×τ2
        | τ1∪τ2
        | E_Real
        | E_Num
*)

(** Concrete nominal type *)
Inductive cname : Type := NInt | NFlt | NCmplx | NStr.

(** Abstract nominal type *)
Inductive aname : Type := NReal | NNum.

(** MiniJl type *)
Inductive ty : Type :=
| TCName : cname -> ty                    (* concrete type *)
| TAName : aname -> ty                    (* abstract type *)
| TPair  : ty -> ty -> ty                 (* ty1×ty2, covariant pair *)
| TUnion : ty -> ty -> ty                 (* ty1∪ty2, union type *)
| TExt   : aname -> ty                    (* Ext<an>, extension type *)
.

(* ================================================================= *)
(** *** Valid types *)
(* ================================================================= *)

(** Extension types are only for defining semantic subtyping,
    they are not considered "valid" types. *)

Inductive valid : ty -> Prop :=
| TY_CName : forall (cn : cname),
    valid (TCName cn)
| TY_AName : forall (an : aname),
    valid (TAName an)
| TY_Pair : forall (t1 t2 : ty),
    valid t1 -> valid t2 ->
    valid (TPair t1 t2)
| TY_Union : forall (t1 t2 : ty),
    valid t1 -> valid t2 ->
    valid (TUnion t1 t2)
.

(* ================================================================= *)
(** *** Examples *)
(* ================================================================= *)

Definition tint   := TCName NInt.
Definition tflt   := TCName NFlt.
Definition tcmplx := TCName NCmplx.
Definition tstr   := TCName NStr.

Definition treal  := TAName NReal.
Definition tnum   := TAName NNum.

Definition tIntInt := TPair (TCName NInt) (TCName NInt).
Definition tNumNum := TPair (TAName NNum) (TAName NNum).

(* ################################################################# *)
(** ** Value Types *)
(* ################################################################# *)

(** Types such as [Str] ([cname]), [Flt×Flt] ([cname×cname]),
    or [Int×(Flt×Flt)] we call _value types_ because they represent
    type tags of run-time values.
    Value types are either concrete named types
    or pairs of value types
    or extension types, as they represent potential values.

    Note that types such as [Int∪Int] are not value types,
    though [Int∪Int] should be equivalent to a value type [Int].

    We will denote value types with [v].
 *)

(** Value type (type tag that can be instantiated) *)
Inductive value_type : ty -> Prop :=
| VT_CName : forall (cn : cname),
    value_type (TCName cn)
| VT_Pair  : forall (v1 v2 : ty),
    value_type v1 ->
    value_type v2 ->
    value_type (TPair v1 v2)
| VT_Ext : forall (an : aname),
    value_type (TExt an)
.

Hint Constructors value_type.

(* ################################################################# *)
(** ** Matching Relation *)
(* ################################################################# *)

(** As we consider all values to be tagged with value types,
    we interpret types as sets of value types:

        [[τ]] = 2^V where V is the set of value types.

    Namely:

        [[cname]] = {cname}
        [[real]]  = {int, flt, Ext<real>}
        [[num]]   = {int, flt, cmplx, Ext<real>, Ext<num>}
        [[τ1×τ2]] = [[τ1]] × [[τ2]]
        [[τ1∪τ2]] = [[τ1]] ∪ [[τ2]]

    Note that extension types are used in the interpretation
    of abstract nominal types.

    Below, we define a _matching relation_ [⊢ v <$ τ],
    which is equivalent to [v \in [[τ]]].
 *)

(*
  ----------------------- MT-CName
   ⊢ CName c <$ CName c

  ---------------- MT-IntReal     ---------------- MT-FltReal
   ⊢ Int <$ Real                   ⊢ Flt <$ Real

  --------------- MT-IntNum     --------------- MT-FltNum     ----------------- MT-CmplxNum
   ⊢ Int <$ Num                  ⊢ Flt <$ Num                  ⊢ Cmplx <$ Num

  --------------------- MT-ExtExt     ------------------ MT-ExtAName
   ⊢ Ext<an> <$ Ext<an>                ⊢ Ext<an> <$ an

  --------------------- MT-ExtRealNum
   ⊢ Ext<Real> <$ Num

   ⊢ τ1 <$ τ1'  ⊢ τ2 <$ τ2'
  -------------------------- MT-Pair
      ⊢ τ1×τ2 <$ τ1'×τ2'

     ⊢ τ1 <$ τ1'                      ⊢ τ2 <$ τ2'
  ----------------- MT-Union1     ------------------ MT-Union2
   ⊢ τ1 <$ τ1'∪τ2'                  ⊢ τ2 <$ τ1'∪τ2'

*)

Reserved Notation "'|-' t1 '<$' t2" (at level 50).

(** Matching of value types *)
Inductive match_ty : ty -> ty -> Prop :=
(* CName *)
| MT_CName : forall (c : cname),
    |- TCName c <$ TCName c

(* Real *)
| MT_IntReal : |- tint <$ treal
| MT_FltReal : |- tflt <$ treal
(* Num *)
| MT_IntNum   : |- tint <$ tnum
| MT_FltNum   : |- tflt <$ tnum
| MT_CmplxNum : |- tcmplx <$ tnum
(* Ext *)
| MT_ExtExt   : forall (a : aname),
    |- TExt a <$ TExt a
| MT_ExtAName : forall (a : aname),
    |- TExt a <$ TAName a
| MT_ExtRealNum  : |- TExt NReal <$ tnum

(* Pair *)
| MT_Pair : forall t1 t2 t1' t2',
    |- t1 <$ t1' ->
    |- t2 <$ t2' ->
    |- TPair t1 t2 <$ TPair t1' t2'

(* Union *)
| MT_Union1 : forall t1 t1' t2',
    |- t1 <$ t1' ->
    |- t1 <$ TUnion t1' t2'
| MT_Union2 : forall t2 t1' t2',
    |- t2 <$ t2' ->
    |- t2 <$ TUnion t1' t2'

where "|- t1 '<$' t2" := (match_ty t1 t2) : btjm_scope.

Hint Constructors match_ty.

Open Scope btjm_scope.

(** Our _tag-based semantic subtyping_ is defined in terms of
    the matching relation. *)
(** [t1] <= [t2] *)
Definition sem_sub (t1 t2 : ty) :=
  forall (v : ty), value_type v -> |- v <$ t1 -> |- v <$ t2.

Notation "'||-' '[' t1 ']' '<=' '[' t2 ']'" := (sem_sub t1 t2) (at level 50) : btjm_scope.

Hint Unfold sem_sub.

Delimit Scope btjm_scope with btjm.

(* ################################################################# *)
(** ** Normal Form of Types *)
(* ################################################################# *)

(** We are going to use normalized types in the definition of
    reductive subtyping (i.e. syntax-directed algorithmic subtyping)
    as well as in proofs about declarative subtyping.

    Normalized type is a union of atoms, where atoms are
    nominal types or pairs of atoms. Atom types are valid.
    Semantically, an atom type cannot be represented as a finite
    union of valid types, for an abstract nominal type
    "contains" extension types.
 *)

(* ================================================================= *)
(** *** Definition *)
(* ================================================================= *)

Inductive atom_type : ty -> Prop :=
| AT_CName : forall (n : cname),
    atom_type (TCName n)
| AT_AName : forall (n : aname),
    atom_type (TAName n)
| AT_Pair : forall (ta1 ta2 : ty),
    atom_type ta1 ->
    atom_type ta2 ->
    atom_type (TPair ta1 ta2)
.

Hint Constructors atom_type.

Inductive in_nf : ty -> Prop :=
| NF_Atom : forall (ta : ty),
    atom_type ta ->
    in_nf ta
| NF_Union : forall (t1 t2 : ty),
    in_nf t1 ->
    in_nf t2 ->
    in_nf (TUnion t1 t2)
.

Notation "'InNF(' t ')'" := (in_nf t) (at level 30) : btjnf_scope.

Hint Constructors in_nf.

Open Scope btjnf_scope.

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

Example innf_1 : InNF(tint).
Proof. repeat constructor. Qed.

Example innf_2 : InNF(TPair tint tstr).
Proof. repeat constructor. Qed.

Example innf_3 : InNF(TUnion (TPair tint tstr) tint).
Proof. apply NF_Union; repeat constructor. Qed.

Example innf_4 : InNF(TPair tint (TUnion tint tstr)) -> False.
Proof. intros Hcontra; inversion Hcontra. inversion H. inversion H4. Qed.

(* ================================================================= *)
(** *** Computing Normal Form *)
(* ================================================================= *)

Fixpoint unite_pairs (t1 : ty) := fix unprs (t2 : ty) :=
  match t1, t2 with
  | TUnion t11 t12, _ => TUnion (unite_pairs t11 t2) (unite_pairs t12 t2)
  | _, TUnion t21 t22 => TUnion (unprs t21)          (unprs t22)
  | _, _              => TPair t1 t2
  end.

Fixpoint mk_nf (t : ty) :=
  match t with
  | TCName n  => t
  | TAName n  => t
  | TPair t1 t2 =>
    let t1' := mk_nf t1 in
    let t2' := mk_nf t2 in
    unite_pairs t1' t2'
  | TUnion t1 t2 =>
    TUnion (mk_nf t1) (mk_nf t2)
  | TExt _    => t   (* we will not use extension types in the surface language *)
  end.

Notation "'MkNF(' t ')'" := (mk_nf t) (at level 30) : btjnf_scope.

(*
Eval compute in (mk_nf tint).
Eval compute in (mk_nf (TPair (TUnion tint tflt) tstr)).
Eval compute in (mk_nf (TPair (TPair (TUnion tint tflt) tstr) tstr)).
*)

Delimit Scope btjnf_scope with btjnf.

(* ################################################################# *)
(** ** Subtyping *)
(* ################################################################# *)

(* ================================================================= *)
(** *** Declarative *)
(* ================================================================= *)

(*
  ---------- SD-Refl
   ⊢ τ << τ

   ⊢ τ1 << τ2   ⊢ τ2 << τ3
  -------------------------- SD-Trans
          ⊢ τ1 << τ3

  --------------- SD-IntReal      ---------------- SD-FltReal
   ⊢ Int << Real                   ⊢ Flt << Real

  ---------------- SD-RealNum     ----------------- SD-CmplxNum
   ⊢ Real << Num                   ⊢ Cmplx << Num

   ⊢ τ1 << τ1'  ⊢ τ2 << τ2'
  -------------------------- SD-Pair
      ⊢ τ1×τ2 << τ1'×τ2'

  --------------- SD-UnionR1     --------------- SD-UnionR2
   ⊢ τ1 << τ1∪τ2                  ⊢ τ2 << τ1∪τ2

   ⊢ τ1 << τ'  ⊢ τ2 << τ'
  ------------------------ SD-UnionL
        ⊢ τ1∪τ2 << τ'

  ------------------------------------ SD-Distr1
   ⊢ (τ11∪τ12)×τ2 << τ11×τ2 ∪ τ12×τ2

  ------------------------------------ SD-Distr2
   ⊢ τ1×(τ21∪τ22) << τ1×τ21 ∪ τ1×τ22
*)

Reserved Notation "'|-' t1 '<<' t2" (at level 50).

Inductive sub_d : ty -> ty -> Prop :=
(* Reflexivity *)
| SD_Refl : forall t,
    |- t << t
(* Transitivity *)
| SD_Trans : forall t1 t2 t3,
    |- t1 << t2 ->
    |- t2 << t3 ->
    |- t1 << t3

(* User-Defined Types *)
| SD_IntReal :
  |- tint   << treal
| SD_FltReal :
  |- tflt   << treal
| SD_RealNum :
  |- treal  << tnum
| SD_CmplxNum :
  |- tcmplx << tnum

(* Pair *)
| SD_Pair : forall t1 t2 t1' t2',
    |- t1 << t1' ->
    |- t2 << t2' ->
    |- TPair t1 t2 << TPair t1' t2'

(* Union *)
| SD_UnionL : forall t1 t2 t,
    |- t1 << t ->
    |- t2 << t ->
    |- TUnion t1 t2 << t
| SD_UnionR1 : forall t1 t2,
    |- t1 << TUnion t1 t2
| SD_UnionR2 : forall t1 t2,
    |- t2 << TUnion t1 t2

(* Distributivity *)
| SD_Distr1 : forall t11 t12 t2,
    |- TPair (TUnion t11 t12) t2 << TUnion (TPair t11 t2) (TPair t12 t2)
| SD_Distr2 : forall t1 t21 t22,
    |- TPair t1 (TUnion t21 t22) << TUnion (TPair t1 t21) (TPair t1 t22)

where "|- t1 '<<' t2" := (sub_d t1 t2) : btj_scope.

Hint Constructors sub_d.

Open Scope btj_scope.

(* ----------------------------------------------------------------- *)
(** **** Union Right *)
(* ----------------------------------------------------------------- *)

Lemma union_right_1 : forall (t t1 t2 : ty),
    |- t << t1 ->
    |- t << (TUnion t1 t2).
Proof.
  intros t t1 t2 H.
  eapply SD_Trans. eassumption. constructor.
Qed.

Lemma union_right_2 : forall (t t1 t2 : ty),
    |- t << t2 ->
    |- t << (TUnion t1 t2).
Proof.
  intros t t1 t2 H.
  eapply SD_Trans. eassumption. constructor.
Qed.

Hint Resolve union_right_1.
Hint Resolve union_right_2.

(* ----------------------------------------------------------------- *)
(** **** Aux Tactics for Transitivity *)
(* ----------------------------------------------------------------- *)

Ltac solve_trans :=
  eapply SD_Trans; eassumption.

Delimit Scope btj_scope with btj.

(* ================================================================= *)
(** *** Reductive Subtyping (no Transitivity and Distributivity) *)
(* ================================================================= *)

(*
  ----------------------- SR-BaseRefl
   ⊢ CName n << CName n

  --------------- SR-IntReal     --------------- SR-FltReal
   ⊢ Int << Real                  ⊢ Flt << Real

  --------------- SR-RealNum
   ⊢ Real << Num

  ----------------- SR-CmplxNum
   ⊢ Cmplx << Num

  -------------- SR-IntNum     --------------- SR-FltNum
   ⊢ Int << Num                 ⊢ Flt << Num

   ⊢ τ1 << τ1'  ⊢ τ2 << τ2'
  -------------------------- SR-Pair
      ⊢ τ1×τ2 << τ1'×τ2'

     ⊢ τ1 << τ1'                      ⊢ τ2 << τ2'
  ----------------- SR-UnionR1     ----------------- SR-UnionR2
   ⊢ τ1 << τ1'∪τ2'                  ⊢ τ2 << τ1'∪τ2'

   ⊢ τ1 << τ'  ⊢ τ2 << τ'
  ------------------------ SR-UnionL
        ⊢ τ1∪τ2 << τ'

   ⊢ NF(τ) << τ'
  --------------- SR-NormalForm
    ⊢ τ << τ'

 *)

Open Scope btjm_scope.

Reserved Notation "'|-' t1 '<<' t2" (at level 50).

Inductive sub_r : ty -> ty -> Prop :=
(* Reflexivity *)
| SR_CNameRefl : forall (c : cname),
    |- TCName c << TCName c
| SR_ANameRefl : forall (a : aname),
    |- TAName a << TAName a

(* User-Defined Types *)
| SR_IntReal :
  |- tint   << treal
| SR_FltReal :
  |- tflt   << treal
| SR_RealNum :
  |- treal  << tnum
| SR_CmplxNum :
  |- tcmplx << tnum
(* Transitivity *)
| SR_IntNum :
  |- tint   << tnum
| SR_FltNum :
  |- tflt   << tnum

(* Pair *)
| SR_Pair : forall t1 t2 t1' t2',
    |- t1 << t1' ->
    |- t2 << t2' ->
    |- TPair t1 t2 << TPair t1' t2'

(* Union *)
| SR_UnionL : forall t1 t2 t',
    |- t1 << t' ->
    |- t2 << t' ->
    |- TUnion t1 t2 << t'
| SR_UnionR1 : forall t1 t1' t2',
    |- t1 << t1' ->
    |- t1 << TUnion t1' t2'
| SR_UnionR2 : forall t2 t1' t2',
    |- t2 << t2' ->
    |- t2 << TUnion t1' t2'

(* Distributivity *)
| SR_NormalForm : forall t t',
    |- MkNF(t) << t' ->
    |- t << t'

where "|- t1 '<<' t2" := (sub_r t1 t2) : btjr_scope.

Hint Constructors sub_r.

Delimit Scope btjr_scope with btjr.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Definition unit  := unit.

Parameter qtmark : Type.

Parameter at1: forall (a:Type), a -> qtmark -> a.

Implicit Arguments at1.

Parameter old: forall (a:Type), a -> a.

Implicit Arguments old.

Definition implb(x:bool) (y:bool): bool := match (x,
  y) with
  | (true, false) => false
  | (_, _) => true
  end.

Inductive datatype  :=
  | Tint : datatype
  | Tbool : datatype .

Inductive operator  :=
  | Oplus : operator
  | Ominus : operator
  | Omult : operator
  | Ole : operator .

Definition ident  := Z.

Inductive term  :=
  | Tconst : Z -> term
  | Tvar : Z -> term
  | Tderef : Z -> term
  | Tbin : term -> operator -> term -> term .

Inductive fmla  :=
  | Fterm : term -> fmla
  | Fand : fmla -> fmla -> fmla
  | Fnot : fmla -> fmla
  | Fimplies : fmla -> fmla -> fmla .

Inductive value  :=
  | Vint : Z -> value
  | Vbool : bool -> value .

Parameter map : forall (a:Type) (b:Type), Type.

Parameter get: forall (a:Type) (b:Type), (map a b) -> a -> b.

Implicit Arguments get.

Parameter set: forall (a:Type) (b:Type), (map a b) -> a -> b -> (map a b).

Implicit Arguments set.

Axiom Select_eq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) -> ((get (set m a1 b1)
  a2) = b1).

Axiom Select_neq : forall (a:Type) (b:Type), forall (m:(map a b)),
  forall (a1:a) (a2:a), forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1)
  a2) = (get m a2)).

Parameter const: forall (b:Type) (a:Type), b -> (map a b).

Set Contextual Implicit.
Implicit Arguments const.
Unset Contextual Implicit.

Axiom Const : forall (b:Type) (a:Type), forall (b1:b) (a1:a), ((get (const(
  b1):(map a b)) a1) = b1).

Definition env  := (map Z value).

Definition var_env  := (map Z value).

Definition ref_env  := (map Z value).

Inductive state  :=
  | mk_state : (map Z value) -> (map Z value) -> state .

Definition ref_env1(u:state): (map Z value) :=
  match u with
  | (mk_state _ ref_env2) => ref_env2
  end.

Definition var_env1(u:state): (map Z value) :=
  match u with
  | (mk_state var_env2 _) => var_env2
  end.

Parameter eval_bin: value -> operator -> value -> value.

Axiom eval_bin_def : forall (x:value) (op:operator) (y:value), match (x,
  y) with
  | ((Vint x1), (Vint y1)) =>
      match op with
      | Oplus => ((eval_bin x op y) = (Vint (x1 + y1)%Z))
      | Ominus => ((eval_bin x op y) = (Vint (x1 - y1)%Z))
      | Omult => ((eval_bin x op y) = (Vint (x1 * y1)%Z))
      | Ole => ((x1 <= y1)%Z -> ((eval_bin x op y) = (Vbool true))) /\
          ((~ (x1 <= y1)%Z) -> ((eval_bin x op y) = (Vbool false)))
      end
  | (_, _) => ((eval_bin x op y) = (Vbool false))
  end.

Set Implicit Arguments.
Fixpoint eval_term(s:state) (t:term) {struct t}: value :=
  match t with
  | (Tconst n) => (Vint n)
  | (Tvar id) => (get (var_env1 s) id)
  | (Tderef id) => (get (ref_env1 s) id)
  | (Tbin t1 op t2) => (eval_bin (eval_term s t1) op (eval_term s t2))
  end.
Unset Implicit Arguments.

Set Implicit Arguments.
Fixpoint eval_fmla(s:state) (f:fmla) {struct f}: Prop :=
  match f with
  | (Fterm t) => ((eval_term s t) = (Vbool true))
  | (Fand f1 f2) => (eval_fmla s f1) /\ (eval_fmla s f2)
  | (Fnot f1) => ~ (eval_fmla s f1)
  | (Fimplies f1 f2) => (eval_fmla s f1) -> (eval_fmla s f2)
  end.
Unset Implicit Arguments.

Parameter subst_term: term -> Z -> term -> term.

Axiom subst_term_def : forall (e:term) (x:Z) (t:term),
  match e with
  | (Tconst _) => ((subst_term e x t) = e)
  | (Tvar _) => ((subst_term e x t) = e)
  | (Tderef y) => ((x = y) -> ((subst_term e x t) = t)) /\ ((~ (x = y)) ->
      ((subst_term e x t) = e))
  | (Tbin e1 op e2) => ((subst_term e x t) = (Tbin (subst_term e1 x t) op
      (subst_term e2 x t)))
  end.

Axiom eval_subst_term : forall (s:state) (e:term) (x:Z) (t:term),
  ((eval_term s (subst_term e x t)) = (eval_term (mk_state (var_env1 s)
  (set (ref_env1 s) x (eval_term s t))) e)).

Set Implicit Arguments.
Fixpoint subst(f:fmla) (x:Z) (t:term) {struct f}: fmla :=
  match f with
  | (Fterm e) => (Fterm (subst_term e x t))
  | (Fand f1 f2) => (Fand (subst f1 x t) (subst f2 x t))
  | (Fnot f1) => (Fnot (subst f1 x t))
  | (Fimplies f1 f2) => (Fimplies (subst f1 x t) (subst f2 x t))
  end.
Unset Implicit Arguments.

Axiom eval_subst : forall (f:fmla) (s:state) (x:Z) (t:term), (eval_fmla s
  (subst f x t)) <-> (eval_fmla (mk_state (var_env1 s) (set (ref_env1 s) x
  (eval_term s t))) f).

Inductive stmt  :=
  | Sskip : stmt
  | Sassign : Z -> term -> stmt
  | Sseq : stmt -> stmt -> stmt
  | Sif : term -> stmt -> stmt -> stmt
  | Swhile : term -> fmla -> stmt -> stmt .

Axiom check_skip : forall (s:stmt), (s = Sskip) \/ ~ (s = Sskip).

Inductive one_step : state -> stmt -> state -> stmt -> Prop :=
  | one_step_assign : forall (s:state) (x:Z) (e:term), (one_step s (Sassign x
      e) (mk_state (var_env1 s) (set (ref_env1 s) x (eval_term s e))) Sskip)
  | one_step_seq : forall (s:state) (sqt:state) (i1:stmt) (i1qt:stmt)
      (i2:stmt), (one_step s i1 sqt i1qt) -> (one_step s (Sseq i1 i2) sqt
      (Sseq i1qt i2))
  | one_step_seq_skip : forall (s:state) (i:stmt), (one_step s (Sseq Sskip i)
      s i)
  | one_step_if_true : forall (s:state) (e:term) (i1:stmt) (i2:stmt),
      ((eval_term s e) = (Vbool true)) -> (one_step s (Sif e i1 i2) s i1)
  | one_step_if_false : forall (s:state) (e:term) (i1:stmt) (i2:stmt),
      ((eval_term s e) = (Vbool false)) -> (one_step s (Sif e i1 i2) s i2)
  | one_step_while_true : forall (s:state) (e:term) (inv:fmla) (i:stmt),
      (eval_fmla s inv) -> (((eval_term s e) = (Vbool true)) -> (one_step s
      (Swhile e inv i) s (Sseq i (Swhile e inv i))))
  | one_step_while_false : forall (s:state) (e:term) (inv:fmla) (i:stmt),
      (eval_fmla s inv) -> (((eval_term s e) = (Vbool false)) -> (one_step s
      (Swhile e inv i) s Sskip)).

Inductive many_steps : state -> stmt -> state -> stmt -> Z -> Prop :=
  | many_steps_refl : forall (s:state) (i:stmt), (many_steps s i s i 0%Z)
  | many_steps_trans : forall (s1:state) (s2:state) (s3:state) (i1:stmt)
      (i2:stmt) (i3:stmt) (n:Z), (one_step s1 i1 s2 i2) -> ((many_steps s2 i2
      s3 i3 n) -> (many_steps s1 i1 s3 i3 (n + 1%Z)%Z)).

Axiom steps_non_neg : forall (s1:state) (s2:state) (i1:stmt) (i2:stmt) (n:Z),
  (many_steps s1 i1 s2 i2 n) -> (0%Z <= n)%Z.

Axiom many_steps_seq : forall (s1:state) (s3:state) (i1:stmt) (i2:stmt)
  (n:Z), (many_steps s1 (Sseq i1 i2) s3 Sskip n) -> exists s2:state,
  exists n1:Z, exists n2:Z, (many_steps s1 i1 s2 Sskip n1) /\ ((many_steps s2
  i2 s3 Sskip n2) /\ (n = ((1%Z + n1)%Z + n2)%Z)).

Definition valid_fmla(p:fmla): Prop := forall (s:state), (eval_fmla s p).

Definition valid_triple(p:fmla) (i:stmt) (q:fmla): Prop := forall (s:state),
  (eval_fmla s p) -> forall (sqt:state) (n:Z), (many_steps s i sqt Sskip
  n) -> (eval_fmla sqt q).

Axiom skip_rule : forall (q:fmla), (valid_triple q Sskip q).

Axiom assign_rule : forall (q:fmla) (x:Z) (e:term), (valid_triple (subst q x
  e) (Sassign x e) q).

Axiom seq_rule : forall (p:fmla) (q:fmla) (r:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple p i1 r) /\ (valid_triple r i2 q)) -> (valid_triple p
  (Sseq i1 i2) q).

Axiom if_rule : forall (e:term) (p:fmla) (q:fmla) (i1:stmt) (i2:stmt),
  ((valid_triple (Fand p (Fterm e)) i1 q) /\ (valid_triple (Fand p
  (Fnot (Fterm e))) i2 q)) -> (valid_triple p (Sif e i1 i2) q).

Axiom while_rule : forall (e:term) (inv:fmla) (i:stmt),
  (valid_triple (Fand (Fterm e) inv) i inv) -> (valid_triple inv (Swhile e
  inv i) (Fand (Fnot (Fterm e)) inv)).

Axiom while_rule_ext : forall (e:term) (inv:fmla) (invqt:fmla) (i:stmt),
  (valid_fmla (Fimplies invqt inv)) -> ((valid_triple (Fand (Fterm e) invqt)
  i invqt) -> (valid_triple invqt (Swhile e inv i) (Fand (Fnot (Fterm e))
  invqt))).

Axiom consequence_rule : forall (p:fmla) (pqt:fmla) (q:fmla) (qqt:fmla)
  (i:stmt), (valid_fmla (Fimplies pqt p)) -> ((valid_triple p i q) ->
  ((valid_fmla (Fimplies q qqt)) -> (valid_triple pqt i qqt))).

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem WP_parameter_wp : forall (i:stmt), forall (q:fmla),
  match i with
  | Sskip => (valid_triple q i q)
  | (Sseq i1 i2) => forall (result:fmla), (valid_triple result i2 q) ->
      forall (result1:fmla), (valid_triple result1 i1 result) ->
      (valid_triple result1 i q)
  | (Sassign x e) => (valid_triple (subst q x e) i q)
  | (Sif e i1 i2) => forall (result:fmla), (valid_triple result i1 q) ->
      forall (result1:fmla), (valid_triple result1 i2 q) ->
      (valid_triple (Fand (Fimplies (Fterm e) result)
      (Fimplies (Fnot (Fterm e)) result1)) i q)
  | (Swhile e inv i1) => forall (result:fmla), (valid_triple result i1
      inv) -> (valid_triple (Fand inv (Fand (Fimplies (Fand (Fterm e) inv)
      result) (Fimplies (Fand (Fnot (Fterm e)) inv) q))) i q)
  end.
(* YOU MAY EDIT THE PROOF BELOW *)
destruct i.
intros; apply skip_rule.
intros; apply assign_rule.
intros; eapply seq_rule; eauto.
intros; apply if_rule.
split.
apply consequence_rule with (2:=H); red; simpl; intuition.
apply consequence_rule with (2:=H0); red; simpl; intuition.

rename f into inv.
intros q wp_i_inv H.
(* goal:
   { inv /\ (t /\ inv -> wp_i_inv) /\ (~t /\ inv -> q) }
   while t inv i
   { q }
*)
eapply consequence_rule with (p:=(Fand inv
     (Fand (Fimplies (Fand (Fterm t) inv) wp_i_inv)
        (Fimplies (Fand (Fnot (Fterm t)) inv) q)))).
red; simpl; intuition.

eapply while_rule_ext.
red; simpl; intuition.
apply consequence_rule with (2:=H).
red; simpl; intuition.

intros; eapply while_rule.
Qed.
(* DO NOT EDIT BELOW *)


Require Export CatSem.PCF.PCF_types.
Require Export CatSem.CAT.cat_INDEXED_TYPE.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Notation "^ f" := (lift (M:= opt_monad _) f) (at level 5).

(*
Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin; simpl;
	try reflexivity.
*)

Section close_notation.

Notation "'TY'" := PCF.Sorts.
Notation "'Bool'" := PCF.Bool.
Notation "'Nat'" := PCF.Nat.

Notation "'IT'" := (ITYPE TY).
Notation "a '~>' b" := (PCF.Arrow a b)
   (at level 69, right associativity).

(** Module PCF defines the syntax of PCF according to
    "On full abstraction for PCF" (Hyland, Ong) *)

(** Notations:
    - [^f := opt_TP_map u f]    (similar to (option_map f))
    - [v //- f := rename f v]
    - [$ f := shift f ]
    - [v >>- f := shift f v ]
    - [v >>= f := subst v f ]
    - [v // N := substar v N ]   (substitution of one variable only) *)

(**

    we define at first morphisms in (TY -> Type),
    these morphisms are named with an underscore "_" at the end
    after defining beta reduction we upgrade them to morphisms in
    the category of preorders over TY
*)

Ltac fin := simpl in *; intros;
   autorewrite with fin; auto with fin; simpl;
	try reflexivity.

Hint Unfold lift : fin.
Hint Extern 1 (_ = _) => f_equal : fin.

(** PCF constants *)
Inductive Consts : TY -> Type :=
 | Nats : nat -> Consts Nat
 | ttt : Consts Bool
 | fff : Consts Bool
 | succ : Consts (Nat ~> Nat)
 | preds : Consts (Nat ~> Nat)
 | zero : Consts (Nat ~> Bool)
 | condN: Consts (Bool ~> Nat ~> Nat ~> Nat)
 | condB: Consts (Bool ~> Bool ~> Bool ~> Bool).

(*Notation "V '*'" := (opt _ V) (at level 5).*)
(*Notation "V '**' u":= (opt_TP u V) (at level 5).*)

(** PCF terms *)
Inductive PCF (V: TY -> Type) : TY -> Type:=
 | Bottom : forall t, PCF V t
 | Const : forall t, Consts t -> PCF V t
 | Var : forall t, V t -> PCF V t
 | App : forall t s, PCF V (s ~> t) -> PCF V s -> PCF V t
 | Lam : forall t s, PCF (opt t V) s -> PCF V (t ~> s)
 | Rec : forall t, PCF V (t ~> t) -> PCF V t.

Notation "a @ b" := (App a b)(at level 43, left associativity).
Notation "M '" := (Const _ M) (at level 15).

SubClass Consts' (V : TY -> Type) (t : TY) := Consts t.

Definition Const' : forall V t, Consts' V t -> PCF V t :=
          fun V t x => Const _ x.
Coercion Const' : Consts' >-> PCF.
(*
Coercion Const : Consts >-> PCF.
*)
(*
Definition Consts' := fun (V : TY -> Type) (t : TY) => Consts t.
*)

Identity Coercion _co : Consts' >-> Consts.

(*
Definition Id_Consts'_Consts :
 forall (V : TY -> Type) (t : TY), Consts' V t -> Consts t:=
  fun V t (x : Consts' V t) => x.
Check Id_Consts'_Consts.
Coercion Id_Consts'_Consts : Consts' >-> Consts.
Definition Const' : forall V t, Consts' V t -> PCF V t :=
          fun V t x => Const _ x.
Coercion Const' : Consts' >-> PCF.

 *)

(** a nicer name for morphisms of families of preorders *)
(*Notation "'varmap'" := ipo_mor.*)

Reserved Notation "x //- f" (at level 42, left associativity).

(** functoriality of PCF (without order) *)
Fixpoint rename (V W: TY -> Type) (f: V ---> W)
         (t:TY)(v:PCF V t): PCF W t :=
    match v with
    | Bottom t => Bottom W t
    | c '  => c '
    | Var t v => Var (f t v)
    | u @ v => u //- f @ v //- f
    | Lam t s u => Lam (u //- (^f))
    | Rec t u => Rec (u //- f)
    end
where "v //- f" := (@rename _ _ f _ v).

(** injection of terms into terms with one variable more, of type u *)
Definition inj (u:TY)(V : TY -> Type)(t:TY)(v:PCF V t): PCF (opt u V) t :=
      v //- (@some TY u V) .

(** inject term in PCF V t in PCF (V* ) t *)
Definition _shift :=
fun (u : TY) (V W : TY -> Type) (f : forall t : TY, V t -> PCF W t)
  (t : TY) (v : opt u V t) =>
match v in (opt _ _ y) return (PCF (opt u W) y) with
| some t0 p => inj u (f t0 p)
| none => Var (V:=opt u W) (t:=u) (none u W)
end.

Notation "'$' f" := (@_shift _ _ _ f) (at level 30).

Notation "y >>- f" := (_shift f y) (at level 44).

(**  substitution *)
Reserved Notation "y >>= f" (at level  42, left associativity).

Fixpoint subst (V W: TY -> Type)(f: forall t, V t -> PCF W t)
           (t:TY)(v:PCF V t) : PCF W t :=
    match v with
    | Bottom t => Bottom W t
    | c ' => c '
    | Var t v => f t v
    | u @ v => u >>= f @ v >>= f
    | Lam t s u => Lam (u >>= $ f)
    | Rec t u => Rec (u >>= f)
    end
where "y >>= f" := (@subst _ _ f _ y).

(** substitution of one variable *)
Definition substar (u:TY) (V:TY -> Type) (M:PCF V u)
       (*PCF V t0 := subst_  *) := subst
  (fun t (x0: opt u V t) => match x0 in (opt _ _ r )
                              return (PCF V r )with
            | none => M
            | some _ v0 => Var v0
            end)  .

Notation "M [*:= N ]" := (substar N M) (at level 50).

(** now a lot of lemmata about interactions between the defined functions *)

Lemma rename_eq (V: TY -> Type)(t:TY)(v: PCF V t)
  (W: TY -> Type) (f g: V ---> W)(H: forall t y, f t y = g t y):
           v //- f  = v //- g .
Proof.
  intros V t v;
  induction v; simpl; auto.
  intros; rewrite H; auto.

  intros.
  rewrite (IHv1 W f g); auto.
  rewrite (IHv2 W f g); auto.

  intros.
  apply f_equal.
  apply IHv.
  intros.
  elim_opt;
  unfold lift;
  simpl;
  auto.
  apply f_equal.
  auto.
  intros;
  simpl;
  apply f_equal;
  apply (IHv);
  auto.
Qed.

Lemma rename_id (V:TY -> Type)(t:TY)(v: PCF V t)
  (f: V ---> V)(H: forall t y, f t y = y):
           v //- f = v.
Proof.
  intros V t v; induction v;
  intros f H;
  simpl; auto.
  rewrite H; auto.
  rewrite IHv1; try rewrite IHv2; auto.
  rewrite IHv; auto.
  unfold lift.
  intros t0 y; destruct y; simpl; try rewrite H; auto.
  rewrite IHv; auto.
Qed.

Hint Resolve rename_eq : fin.
Hint Rewrite rename_eq : fin.

Lemma rename_comp (V: TY -> Type) (t: TY) (v: PCF V t)
      (W Z: TY -> Type) (f: V ---> W) (g: W ---> Z):
      v //- (f ;; g) =
           v //- f //- g.
Proof.
  intros V t v; induction v;
  simpl in *; auto.
  intros;
  rewrite IHv1;
  rewrite IHv2; auto.
  intros W Z f g.
  apply f_equal.
  rewrite <- (IHv _ (opt t Z)).
  apply rename_eq.
  intros;
  elim_opt.
  intros; rewrite IHv; auto.
Qed.

Lemma shift_eq (u:TY) (V:TY -> Type )(t:TY)(v:opt u V t)
          (W: TY -> Type)(f g: forall t, V t -> PCF W t)
          (H: forall t z, f t z = g t z):
          v >>- f  = v >>- g .
Proof.
  intros u V t v;
  induction v;
  simpl; intros;
  try rewrite H; auto.
Qed.

Hint Resolve  rename_id shift_eq : fin.
Hint Rewrite  rename_id shift_eq : fin.

Lemma shift_var (u:TY)(V:TY -> Type)(t:TY)(v: opt u V t):
       v >>- (fun t z => Var z)  = Var v.
Proof.
  induction v;
  intros; simpl;
  auto.
Qed.

Hint Resolve shift_var : fin.
Hint Rewrite shift_var : fin.

Lemma var_lift_shift_eq (u:TY) (V:TY -> Type) (t: TY) (v: opt u V t)
     (W:TY -> Type) (f: V ---> W):
    Var (^f t v) = v >>- (fun t z => Var (f t z)).
Proof.
  induction v;
  simpl; intros;
  auto.
Qed.

Hint Resolve var_lift_shift_eq : fin.

Lemma shift_lift (u:TY) (V: TY -> Type) (t:TY)(v:opt u V t)
           (W Z:TY -> Type)(f: V ---> W)
           (g: forall t, W t -> PCF Z t):
   ^f t v >>- g =
    v >>- (fun t x0 => g t (f t x0)).
Proof.
  induction v;
  simpl; intros;
  auto.
Qed.

Hint Resolve shift_lift : fin.
Hint Rewrite shift_lift : fin.

Lemma subst_eq (V: TY -> Type)(t:TY)(v:PCF V t) (W:TY -> Type)
       (f g: forall t, V t -> PCF W t)
       (H: forall t z, f t z = g t z) :
       v >>= f = v >>= g.
Proof.
  induction v;
  intros; simpl;  auto.

  try rewrite (IHv1 W f g);
  try rewrite (IHv2 W f g);
  try rewrite (IHv W f g); auto.

  rewrite (IHv _ (_shift f) (_shift g)); auto.
  intros; apply shift_eq; auto.

  rewrite (IHv W f g); auto.
Qed.

Hint Resolve subst_eq : fin.
Hint Rewrite subst_eq : fin.

Program Instance subst_oid (V W : IT) :
 Proper (equiv (Setoid:=mor_oid V (PCF W))==>
         equiv (Setoid:=mor_oid (PCF V) (PCF W)))
                (@subst V W).
Next Obligation.
Proof.
  red;
  fin.
Qed.

Lemma subst_var (V:TY -> Type)(t:TY)(v:PCF V t):
        v >>= (@Var V) = v.
Proof.
  induction v;
  intros; simpl; auto.
  rewrite IHv1. rewrite IHv2; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv; auto.
Qed.

Lemma subst_var_eta (V:TY -> Type)(t:TY)(v:PCF V t):
        v >>= (fun t z => Var z) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1. rewrite IHv2; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv; auto.
Qed.

Lemma subst_var_eta2 (V:TY -> Type)(t:TY)(v:PCF V t):
        v >>= (fun t => @Var V t) = v.
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1. rewrite IHv2; auto.
  rewrite <- IHv at 2.
  apply f_equal. apply subst_eq.
  intros; apply shift_var.
  rewrite IHv; auto.
Qed.

Lemma subst_eq_rename (V:TY -> Type)(t:TY)(v:PCF V t)
      (W:TY -> Type) (f: V ---> W):
        v //- f  = v >>= fun t z => Var (f t z).
Proof.
  induction v; intros; simpl; auto.
  rewrite IHv1; rewrite IHv2; auto.
  rewrite IHv. apply f_equal.
  apply subst_eq.
  intros.
  assert (H:=var_lift_shift_eq).
  simpl in H.
  apply H.
  rewrite IHv; auto.
Qed.

Lemma rename_term_inj (u:TY)(V:TY -> Type)(t:TY)(v:PCF V t)
    (W: TY -> Type) (g: V ---> W):
      inj u v //- ^g  =  inj u (v //- g).
Proof.
  induction v; simpl in *; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.
  unfold inj. simpl.
  apply f_equal.
  rewrite <- rename_comp.
  rewrite <- rename_comp.
  apply rename_eq.
  induction y; simpl; auto.
  rewrite IHv. unfold inj.
  simpl. auto.
Qed.

Lemma rename_subst (V:TY -> Type) (t:TY)(v: PCF V t)
     (W Z: TY -> Type)(f: V ---> PCF W)
     (g: W ---> Z):
   v >>= f //- g =
           v >>= fun t z => f t z //- g .
Proof.
  induction v; intros; simpl in *; auto.
  rewrite IHv1; rewrite IHv2; auto.

  rewrite IHv.
  apply f_equal.
  apply subst_eq.
  intros.
  elim_opt.
  rew rename_term_inj.
  rewrite IHv. auto.
Qed.

Hint Unfold inj : fin.

Lemma subst_rename (V:TY -> Type) (t:TY)(v: PCF V t)
     (W Z : TY -> Type) (f: V ---> W)
     (g: W ---> PCF Z):
    v //- f >>= g =
            v >>= fun t z =>  g t (f t z).
Proof.
  induction v; simpl; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.

  rewrite IHv. apply f_equal.
  apply subst_eq. intros.
  apply shift_lift.

  rewrite IHv. auto.
Qed.

Hint Rewrite subst_rename rename_subst : fin.

Lemma rename_substar (V: TY -> Type)(s t:TY) (v:PCF (opt s V) t)
   (W:TY -> Type) (f: V ---> W) N:
       v [*:= N]  //- f =
         (v //- ^f) [*:= (N //- f)].
Proof.
  intros. unfold substar.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  simpl; intros;
  elim_opt.
Qed.

Ltac opt := simpl; intros; elim_opt.

Lemma subst_term_inj (u:TY)(V:TY -> Type)(t:TY)(v:PCF V t)
      (W:TY -> Type)
      (g: V ---> PCF W):
    (inj u v) >>= $ g = inj  _ (v >>= g).
Proof.
  induction v; simpl; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.

  unfold inj. simpl. apply f_equal.
  rewrite rename_subst.
  rewrite subst_rename.
  apply subst_eq.
  opt.
  rew (rename_term_inj).
  rewrite IHv; auto.
Qed.

Lemma subst_shift_shift (u:TY) (V:TY -> Type) (t:TY)(v:opt u V t)
 (W Z : TY -> Type)
 (f: V ---> PCF W)
 (g: W ---> PCF Z):
   (v >>- f)  >>= $ g =
          v >>- fun t z => f t z >>= g .
Proof.
  induction v;
  simpl; intros;
  try apply subst_term_inj; auto.
Qed.

Hint Resolve subst_shift_shift subst_var subst_var_eta : fin.
Hint Rewrite subst_shift_shift subst_var subst_var_eta : fin.

Lemma subst_subst (V:TY -> Type)(t:TY)(v:PCF V t)
         (W Z : TY -> Type)
         (f:V ---> PCF W)(g:W ---> PCF Z):
  v >>= f >>= g =
      v >>= fun t z => f t z >>= g.
Proof.
  induction v; simpl; intros; auto.
  rewrite IHv1; rewrite IHv2; auto.

  rewrite IHv. apply f_equal.
  apply subst_eq.
  intros; simpl.
  apply subst_shift_shift.

  rewrite IHv; auto.
Qed.

Hint Resolve subst_var subst_subst : fin.
Hint Rewrite subst_subst : fin.

Lemma subst_substar (V W : IT)
      (s t:TY) (M: PCF (opt s V) t) (N:PCF V s)
      (f:forall t, V t -> PCF W t):
   M [*:=N]  >>= f = (M >>= _shift f) [*:= (N >>= f)].
Proof.
  intros V W s t M N f.
  unfold substar. simpl.
  repeat rewrite subst_subst.
  apply subst_eq.
  opt.
  unfold inj.
  simpl.
  rewrite subst_rename. simpl.
  rewrite subst_var_eta. auto.
Qed.

Lemma lift_rename V t (s : PCF V t) W (f : V ---> W) :
          s //- f = s >>= (f ;; @Var _).
Proof.
  intros V t s.
  induction s;
  simpl;
  fin.
  apply f_equal.
  rewrite IHs.
  apply subst_eq.
  clear dependent s0.
  intros r z;
  destruct z as [r z | ];
  fin.
Qed.

Hint Rewrite lift_rename : fin.

End close_notation.

Existing Instance subst_oid.


Require Export Program.Basics. Open Scope program_scope.
From Paco Require Import paconotation_internal paco_internal pacotac_internal.
From Paco Require Export paconotation.
Set Implicit Arguments.

Section PACO4.

Variable T0 : Type.
Variable T1 : forall (x0: @T0), Type.
Variable T2 : forall (x0: @T0) (x1: @T1 x0), Type.
Variable T3 : forall (x0: @T0) (x1: @T1 x0) (x2: @T2 x0 x1), Type.

(** ** Signatures *)

Record sig4T  :=
  exist4T {
      proj4T0: @T0;
      proj4T1: @T1 proj4T0;
      proj4T2: @T2 proj4T0 proj4T1;
      proj4T3: @T3 proj4T0 proj4T1 proj4T2;
    }.
Definition uncurry4  (R: rel4 T0 T1 T2 T3): rel1 sig4T :=
  fun x => R (proj4T0 x) (proj4T1 x) (proj4T2 x) (proj4T3 x).
Definition curry4  (R: rel1 sig4T): rel4 T0 T1 T2 T3 :=
  fun x0 x1 x2 x3 => R (@exist4T x0 x1 x2 x3).

Lemma uncurry_map4 r0 r1 (LE : r0 <4== r1) : uncurry4 r0 <1== uncurry4 r1.
Proof. intros [] H. apply LE. apply H. Qed.

Lemma uncurry_map_rev4 r0 r1 (LE: uncurry4 r0 <1== uncurry4 r1) : r0 <4== r1.
Proof.
  red; intros. apply (LE (@exist4T x0 x1 x2 x3) PR).
Qed.

Lemma curry_map4 r0 r1 (LE: r0 <1== r1) : curry4 r0 <4== curry4 r1.
Proof.
  red; intros. apply (LE (@exist4T x0 x1 x2 x3) PR).
Qed.

Lemma curry_map_rev4 r0 r1 (LE: curry4 r0 <4== curry4 r1) : r0 <1== r1.
Proof.
  intros [] H. apply LE. apply H.
Qed.

Lemma uncurry_bij1_4 r : curry4 (uncurry4 r) <4== r.
Proof. unfold le4. intros. apply PR. Qed.

Lemma uncurry_bij2_4 r : r <4== curry4 (uncurry4 r).
Proof. unfold le4. intros. apply PR. Qed.

Lemma curry_bij1_4 r : uncurry4 (curry4 r) <1== r.
Proof. intros [] H. apply H. Qed.

Lemma curry_bij2_4 r : r <1== uncurry4 (curry4 r).
Proof. intros [] H. apply H. Qed.

Lemma uncurry_adjoint1_4 r0 r1 (LE: uncurry4 r0 <1== r1) : r0 <4== curry4 r1.
Proof.
  apply uncurry_map_rev4. eapply le1_trans; [apply LE|]. apply curry_bij2_4.
Qed.

Lemma uncurry_adjoint2_4 r0 r1 (LE: r0 <4== curry4 r1) : uncurry4 r0 <1== r1.
Proof.
  apply curry_map_rev4. eapply le4_trans; [|apply LE]. apply uncurry_bij2_4.
Qed.

Lemma curry_adjoint1_4 r0 r1 (LE: curry4 r0 <4== r1) : r0 <1== uncurry4 r1.
Proof.
  apply curry_map_rev4. eapply le4_trans; [apply LE|]. apply uncurry_bij2_4.
Qed.

Lemma curry_adjoint2_4 r0 r1 (LE: r0 <1== uncurry4 r1) : curry4 r0 <4== r1.
Proof.
  apply uncurry_map_rev4. eapply le1_trans; [|apply LE]. apply curry_bij1_4.
Qed.

(** ** Predicates of Arity 4
*)

Definition paco4(gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)(r: rel4 T0 T1 T2 T3) : rel4 T0 T1 T2 T3 :=
  curry4 (paco (fun R0 => uncurry4 (gf (curry4 R0))) (uncurry4 r)).

Definition upaco4(gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)(r: rel4 T0 T1 T2 T3) := paco4 gf r \4/ r.
Arguments paco4 : clear implicits.
Arguments upaco4 : clear implicits.
Hint Unfold upaco4.

Definition monotone4 (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) :=
  forall x0 x1 x2 x3 r r' (IN: gf r x0 x1 x2 x3) (LE: r <4= r'), gf r' x0 x1 x2 x3.

Definition _monotone4 (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) :=
  forall r r'(LE: r <4= r'), gf r <4== gf r'.

Lemma monotone4_eq (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) :
  monotone4 gf <-> _monotone4 gf.
Proof. unfold monotone4, _monotone4, le4. split; intros; eapply H; eassumption. Qed.

Lemma monotone4_map (gf: rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)
      (MON: _monotone4 gf) :
  _monotone (fun R0 => uncurry4 (gf (curry4 R0))).
Proof.
  red; intros. apply uncurry_map4. apply MON; apply curry_map4; assumption.
Qed.

Lemma monotone4_compose (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)
      (MON1: monotone4 gf)
      (MON2: monotone4 gf'):
  monotone4 (compose gf gf').
Proof.
  red; intros. eapply MON1. apply IN.
  intros. eapply MON2. apply PR. apply LE.
Qed.

Lemma monotone4_union (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3)
      (MON1: monotone4 gf)
      (MON2: monotone4 gf'):
  monotone4 (gf \5/ gf').
Proof.
  red; intros. destruct IN.
  - left. eapply MON1. apply H. apply LE.
  - right. eapply MON2. apply H. apply LE.
Qed.

Lemma _paco4_mon_gen (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r r'
    (LEgf: gf <5= gf')
    (LEr: r <4= r'):
  paco4 gf r <4== paco4 gf' r'.
Proof.
  apply curry_map4. red; intros. eapply paco_mon_gen. apply PR.
  - intros. apply LEgf, PR0.
  - intros. apply LEr, PR0.
Qed.

Lemma paco4_mon_gen (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r r' x0 x1 x2 x3
    (REL: paco4 gf r x0 x1 x2 x3)
    (LEgf: gf <5= gf')
    (LEr: r <4= r'):
  paco4 gf' r' x0 x1 x2 x3.
Proof.
  eapply _paco4_mon_gen; [apply LEgf | apply LEr | apply REL].
Qed.

Lemma paco4_mon_bot (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r' x0 x1 x2 x3
    (REL: paco4 gf bot4 x0 x1 x2 x3)
    (LEgf: gf <5= gf'):
  paco4 gf' r' x0 x1 x2 x3.
Proof.
  eapply paco4_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Lemma upaco4_mon_gen (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r r' x0 x1 x2 x3
    (REL: upaco4 gf r x0 x1 x2 x3)
    (LEgf: gf <5= gf')
    (LEr: r <4= r'):
  upaco4 gf' r' x0 x1 x2 x3.
Proof.
  destruct REL.
  - left. eapply paco4_mon_gen; [apply H | apply LEgf | apply LEr].
  - right. apply LEr, H.
Qed.

Lemma upaco4_mon_bot (gf gf': rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3) r' x0 x1 x2 x3
    (REL: upaco4 gf bot4 x0 x1 x2 x3)
    (LEgf: gf <5= gf'):
  upaco4 gf' r' x0 x1 x2 x3.
Proof.
  eapply upaco4_mon_gen; [apply REL | apply LEgf | intros; contradiction PR].
Qed.

Section Arg4.

Variable gf : rel4 T0 T1 T2 T3 -> rel4 T0 T1 T2 T3.
Arguments gf : clear implicits.

Theorem _paco4_mon: _monotone4 (paco4 gf).
Proof.
  red; intros. eapply curry_map4, _paco_mon; apply uncurry_map4; assumption.
Qed.

Theorem _paco4_acc: forall
  l r (OBG: forall rr (INC: r <4== rr) (CIH: l <4== rr), l <4== paco4 gf rr),
  l <4== paco4 gf r.
Proof.
  intros. apply uncurry_adjoint1_4.
  eapply _paco_acc. intros.
  apply uncurry_adjoint1_4 in INC. apply uncurry_adjoint1_4 in CIH.
  apply uncurry_adjoint2_4.
  eapply le4_trans. eapply (OBG _ INC CIH).
  apply curry_map4.
  apply _paco_mon; try apply le1_refl; apply curry_bij1_4.
Qed.

Theorem _paco4_mult_strong: forall r,
  paco4 gf (upaco4 gf r) <4== paco4 gf r.
Proof.
  intros. apply curry_map4.
  eapply le1_trans; [| eapply _paco_mult_strong].
  apply _paco_mon; intros [] H; apply H.
Qed.

Theorem _paco4_fold: forall r,
  gf (upaco4 gf r) <4== paco4 gf r.
Proof.
  intros. apply uncurry_adjoint1_4.
  eapply le1_trans; [| apply _paco_fold]. apply le1_refl.
Qed.

Theorem _paco4_unfold: forall (MON: _monotone4 gf) r,
  paco4 gf r <4== gf (upaco4 gf r).
Proof.
  intros. apply curry_adjoint2_4.
  eapply _paco_unfold; apply monotone4_map; assumption.
Qed.

Theorem paco4_acc: forall
  l r (OBG: forall rr (INC: r <4= rr) (CIH: l <4= rr), l <4= paco4 gf rr),
  l <4= paco4 gf r.
Proof.
  apply _paco4_acc.
Qed.

Theorem paco4_mon: monotone4 (paco4 gf).
Proof.
  apply monotone4_eq.
  apply _paco4_mon.
Qed.

Theorem upaco4_mon: monotone4 (upaco4 gf).
Proof.
  red; intros.
  destruct IN.
  - left. eapply paco4_mon. apply H. apply LE.
  - right. apply LE, H.
Qed.

Theorem paco4_mult_strong: forall r,
  paco4 gf (upaco4 gf r) <4= paco4 gf r.
Proof.
  apply _paco4_mult_strong.
Qed.

Corollary paco4_mult: forall r,
  paco4 gf (paco4 gf r) <4= paco4 gf r.
Proof. intros; eapply paco4_mult_strong, paco4_mon; [apply PR|..]; intros; left; assumption. Qed.

Theorem paco4_fold: forall r,
  gf (upaco4 gf r) <4= paco4 gf r.
Proof.
  apply _paco4_fold.
Qed.

Theorem paco4_unfold: forall (MON: monotone4 gf) r,
  paco4 gf r <4= gf (upaco4 gf r).
Proof.
  intro. eapply _paco4_unfold; apply monotone4_eq; assumption.
Qed.

End Arg4.

Arguments paco4_acc : clear implicits.
Arguments paco4_mon : clear implicits.
Arguments upaco4_mon : clear implicits.
Arguments paco4_mult_strong : clear implicits.
Arguments paco4_mult : clear implicits.
Arguments paco4_fold : clear implicits.
Arguments paco4_unfold : clear implicits.

Global Instance paco4_inst  (gf : rel4 T0 T1 T2 T3->_) r x0 x1 x2 x3 : paco_class (paco4 gf r x0 x1 x2 x3) :=
{ pacoacc    := paco4_acc gf;
  pacomult   := paco4_mult gf;
  pacofold   := paco4_fold gf;
  pacounfold := paco4_unfold gf }.

End PACO4.

Global Opaque paco4.

Hint Unfold upaco4.
Hint Resolve paco4_fold.
Hint Unfold monotone4.