(** This file defines the syntactic category of our toy type theory, and the logical structure on it.

As a matter of organisation: all concrete lemmas involving derivations should live upstream in [TypingLemmas]; this file should simply package them up into the appropriate categorical structure. *)

Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.limits.graphs.terminal.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.Auxiliary.Partial.
Require Import TypeTheory.Auxiliary.SetQuotients.
Require Import TypeTheory.TypeCat.TypeCat.
Require Import TypeTheory.TypeCat.General.
Require Import TypeTheory.TypeCat.Contextual.
Require Import TypeTheory.Initiality.Syntax.
Require Import TypeTheory.Initiality.SyntaxLemmas.
Require Import TypeTheory.Initiality.Typing.
Require Import TypeTheory.Initiality.TypingLemmas.

Local Open Scope judgement.

Section Auxiliary.

(** Useful for getting computation on partially complete definitions (like how the [admit] tactic used to behave).
  BUT: keep commented out when not needed, so as not to have inconsistency lying around. *)
(*
  Lemma temp_admit {X} : X. Admitted.
*)

End Auxiliary.

(** The construction of the syntactic type-category is rather trickier than one might hope, because of the need to quotient by some form of context equality — which, as ever when quotienting objects of a category, is quite fiddly.

For just the _category_ this is unnecessary, but for the _type-category_, it is unavoidable: types must be modulo equality, in order to form a presheaf, but then so must contexts, in order for context extension to be well-defined.

At the same time, to get a _contextual_ type-category, one must stratify the objects: the flat contexts up to flat context equality form a type-category, but it will not in general contextual. *)

Section Stratified_Contexts.

(** The conventional version of contexts, as opposed to the “flat” notion we take as primitive. *)
  Fixpoint stratified_context_of_length (n:nat) : UU
  := match n with
    | O => unit
    | S n => (stratified_context_of_length n) × (ty_expr n)
  end.
  Arguments stratified_context_of_length : simpl nomatch.

  Definition empty_stratified_context
    := tt : stratified_context_of_length 0.
  Opaque empty_stratified_context.

  (** NOTE: [context_last] and [context_rest] are only defined for stratified
  contexts, so we don’t explicitly include “stratified” in their names. *)
  Definition context_last {n} (Γ : stratified_context_of_length (S n))
    : ty_expr n
  := pr2 Γ.

  Definition context_rest {n} (Γ : stratified_context_of_length (S n))
    : stratified_context_of_length n
  := pr1 Γ.

  Definition extend_stratified_context {n}
      (Γ : stratified_context_of_length n) (A : ty_expr n)
    : stratified_context_of_length (S n)
  := (Γ,,A).

  Fixpoint context_of_stratified_context
      {n} (Γ : stratified_context_of_length n) {struct n}
    : context_of_length n.
  Proof.
    destruct n as [ | n].
    - exact [::]%context.
    - exact (context_extend
               (context_of_stratified_context _ (context_rest Γ))
               (context_last Γ)).
  Defined.
  Global Arguments context_of_stratified_context : simpl never.
  (* TODO: this seems to often unfold too much.  Why??
   A workaround for now: manual folding, [fold @context_of_stratified_context]. *)

  Coercion context_of_stratified_context
    : stratified_context_of_length >-> context_of_length.

End Stratified_Contexts.

Delimit Scope stratified_context_scope with strat_cxt.
Bind Scope stratified_context_scope with stratified_context_of_length.
Notation "[: :]"
  := (empty_stratified_context) (format "[: :]") : stratified_context_scope.
Notation "Γ ;; A" := (extend_stratified_context Γ A)
               (at level 50, left associativity) : stratified_context_scope.
Notation "[: A ; .. ; Z :] " := (..([: :] ;; A) .. ;; Z)%strat_cxt
                                                 : stratified_context_scope.

Local Open Scope stratified_context_scope.

Section Stratified_Wellformed_Contexts.

  Fixpoint derivation_strat_cxt
      {n} (Γ : stratified_context_of_length n) {struct n}
    : UU.
  Proof.
    destruct n as [ | n].
    - exact unit.
    - exact (derivation_strat_cxt _ (context_rest Γ)
             × [! context_rest Γ |- context_last Γ !]).
  Defined.
  Arguments derivation_strat_cxt : simpl nomatch.

  Notation "[! |- Γ !]" := (derivation_strat_cxt Γ)
                    (format "[!  |-  Γ  !]") : judgement_scope.

  Definition derive_empty_stratified_context : [! |- [::] !] := tt.

  Definition derive_extend_stratified_context
      {n} {Γ : stratified_context_of_length n} {A : ty_expr Γ}
      (d_Γ : [! |- Γ !]) (d_A : [! Γ |- A !])
    : [! |- Γ;;A !]
  := (d_Γ,,d_A).

  Fixpoint derive_flat_cxt_from_strat
      {n} {Γ : stratified_context_of_length n} {struct n}
    : [! |- Γ !] -> [! |f- Γ !].
  Proof.
    destruct n as [ | n].
    - intro; intros [].
    - destruct Γ as [Γ A]. intros [d_Γ d_A].
      exact (derive_flat_extend_context
               (derive_flat_cxt_from_strat _ _ d_Γ) d_A).
  Defined.

  Coercion derive_flat_cxt_from_strat
    : derivation_strat_cxt >-> derivation_flat_context.
  (* TODO: rename a bit to be more consistent with [_cxt] vs [_context]. *)

End Stratified_Wellformed_Contexts.

Notation "[! |- Γ !]" := (derivation_strat_cxt Γ)
                    (format "[!  |-  Γ  !]") : judgement_scope.

Section Stratified_Context_Equality.

  Fixpoint derivation_cxteq
      {n} (Γ Δ : stratified_context_of_length n) {struct n}
    : UU.
  Proof.
    destruct n as [ | n].
    - exact unit.
    - exact (derivation_cxteq _ (context_rest Γ) (context_rest Δ)
             × [! context_rest Γ |- context_last Γ === context_last Δ !]).
  Defined.
  Arguments derivation_cxteq : simpl nomatch.

  Notation "[! |- Δ === Γ !]" := (derivation_cxteq Δ Γ)
                    (format "[!  |-  Δ  ===  Γ  !]") : judgement_scope.

  Fixpoint derive_flat_cxteq_from_cxteq
      {n} {Γ Δ : stratified_context_of_length n}
      (d_Γ : [! |- Γ !]) (d_Δ : [! |- Δ !]) {struct n}
    : [! |- Γ === Δ !] -> [! |f- Γ === Δ !].
  Proof.
    destruct n as [ | n].
    - intro; split; intros [].
    - destruct Γ as [Γ A], Δ as [Δ B], d_Γ as [? ?], d_Δ as [? ?].
      cbn; intros [? ?].
  (* TODO: how to stop [@context_of_stratified_context] unfolding here? *)
      apply derive_extend_flat_cxteq; fold @context_of_stratified_context;
        auto using derive_flat_cxt_from_strat.
  Defined.

  Coercion derive_flat_cxteq_from_cxteq
    : derivation_cxteq >-> derivation_flat_cxteq.

End Stratified_Context_Equality.

Notation "[! |- Δ === Γ !]" := (derivation_cxteq Δ Γ)
                          (format "[!  |-  Δ  ===  Γ  !]") : judgement_scope.

Section Contexts_Modulo_Equality.

  Definition wellformed_context_of_length (n : nat) : UU
  := ∑ (Γ : stratified_context_of_length n), ∥ [! |- Γ !] ∥.

  Coercion context_of_wellformed_context {n} (Γ : wellformed_context_of_length n)
    : stratified_context_of_length n
  := pr1 Γ.

  Definition context_derivable
      {n} (Γ : wellformed_context_of_length n)
  := pr2 Γ  : ∥ [! |- Γ !] ∥.
  Coercion context_derivable
    : wellformed_context_of_length >-> hProptoType.

  Definition context_derivable'
      {n} (Γ : wellformed_context_of_length n)
  := pr2 Γ  : hProptoType (∥ [! |- Γ !] ∥).
  Coercion context_derivable'
    : wellformed_context_of_length >-> hProptoType.
  (* NOTE: this is needed since [ ∥ _ ∥ ] sometimes desugars to [ pr1hSet … ] and sometimes to [ hProptoType … ]. *)

  Definition empty_wellformed_context_of_length : wellformed_context_of_length 0.
  Proof.
    exists tt.
    apply hinhpr.
    exact tt.
  Defined.

  Definition derivable_cxteq_hrel {n} : hrel (wellformed_context_of_length n)
  := fun Γ Δ => ∥ derivation_flat_cxteq Γ Δ ∥.

  Lemma derivable_cxteq_is_eqrel n : iseqrel (@derivable_cxteq_hrel n).
  Proof.
    repeat split.
    - intros Γ Δ Θ.
      refine (hinhfun5 _ Γ Δ Θ); intros.
      eauto using derive_flat_cxteq_trans, derive_flat_cxt_from_strat.
    - intros Γ. refine (hinhfun _ Γ).
      exact derive_flat_cxteq_refl.
    - intros Γ Δ.
      refine (hinhfun3 _ Γ Δ); intros.
      eauto using derive_flat_cxteq_sym, derive_flat_cxt_from_strat.
  Qed.

  Definition derivable_cxteq {n} : eqrel (wellformed_context_of_length n)
  := (_,,derivable_cxteq_is_eqrel n).

  Definition context_of_length_mod_eq n := setquot (@derivable_cxteq n).
  Identity Coercion id_context_of_length_mod_eq
    : context_of_length_mod_eq >-> setquot.

  Definition context_mod_eq
  := ∑ (n:nat), context_of_length_mod_eq n.

  Definition make_context_mod_eq {n} (ΓΓ : context_of_length_mod_eq n)
    : context_mod_eq
  := (n,,ΓΓ).
  Coercion make_context_mod_eq : context_of_length_mod_eq >-> context_mod_eq.

  Local Definition length : context_mod_eq -> nat := pr1.
  Coercion length : context_mod_eq >-> nat.
  Add Printing Coercion length.

  Definition pr2_context_mod_eq (ΓΓ : context_mod_eq)
    : context_of_length_mod_eq ΓΓ
  := pr2 ΓΓ.
  Coercion pr2_context_mod_eq : context_mod_eq >-> context_of_length_mod_eq.

  Definition context_class {n} (Γ : wellformed_context_of_length n)
    : context_mod_eq
  := (n,, setquotpr _ Γ).
  Coercion context_class : wellformed_context_of_length >-> context_mod_eq.

  Definition context_representative (ΓΓ : context_mod_eq) : UU
  := ∑ (Γ : wellformed_context_of_length (length ΓΓ)), setquotpr _ Γ = (pr2 ΓΓ).

  Definition context_representative_as_context
      {ΓΓ} (Γ : context_representative ΓΓ)
    : wellformed_context_of_length (length ΓΓ)
  := pr1 Γ.
  Coercion context_representative_as_context
    : context_representative >-> wellformed_context_of_length.

  Definition context_as_context_representative
      {n} (Γ : wellformed_context_of_length n)
    : context_representative Γ
  := (_,,idpath _).
  Coercion context_as_context_representative
    : wellformed_context_of_length >-> context_representative.

  Lemma cxteq_context_representatives
      {ΓΓ : context_mod_eq} (Γ Γ' : context_representative ΓΓ)
    : ∥ derivation_flat_cxteq Γ Γ' ∥.
  Proof.
    refine (invmap (weqpathsinsetquot (derivable_cxteq) Γ Γ') _).
    exact (pr2 Γ @ ! pr2 Γ').
  Defined.

  Lemma take_context_representative
      (ΓΓ : context_mod_eq) {X:UU} (h_X : isaprop X)
      (f : context_representative ΓΓ -> X)
    : X.
  Proof.
    refine (factor_through_squash _ f _). { assumption. }
    destruct ΓΓ as [n ΓΓ]. generalize ΓΓ.
    apply setquotunivprop'.
    { intros; apply isapropishinh. }
    intros Γ; apply hinhpr. exists Γ; apply idpath.
  Defined.

End Contexts_Modulo_Equality.

Section Context_Maps.
(** Definition of context maps, and basic auxiliary functions on them. *)

  (* TODO: will probably have to refactor the following to depend directly on [context_of_length_mod_eq], as with [type_over] etc below. *)

  (** Note: the truncation of the derivation part is mathematically redundant,
  since we will later quotient anyway.  However, it lets us get better
  computational behaviour on the map part, in compositions etc. *)
  (* NOTE: does it really? *)
  Local Definition map (ΓΓ ΔΔ : context_mod_eq) : UU
    := ∑ (f : raw_context_map ΓΓ ΔΔ),
       ∀ (Γ : context_representative ΓΓ) (Δ : context_representative ΔΔ),
         ∥ [! |- f ::: Γ ---> Δ !] ∥.

  Definition raw_of_context_map {ΓΓ ΔΔ} (f : map ΓΓ ΔΔ) : raw_context_map _ _
  := pr1 f.
  Coercion raw_of_context_map : map >-> raw_context_map.

  Local Definition map_derivable {ΓΓ ΔΔ} (f : map ΓΓ ΔΔ)
    : ∀ (Γ : context_representative ΓΓ) (Δ : context_representative ΔΔ),
      ∥ [! |- f ::: Γ ---> Δ !] ∥
  := pr2 f.

  Local Definition mapeq (ΓΓ ΔΔ : context_mod_eq) (f g : raw_context_map ΓΓ ΔΔ)
  := ∀ (Γ : context_representative ΓΓ) (Δ : context_representative ΔΔ),
      ∥ [! |- f === g ::: Γ ---> Δ !] ∥.

  Local Definition mapeq_hrel {ΓΓ ΔΔ} (f g : map ΓΓ ΔΔ)
  := mapeq ΓΓ ΔΔ f g.

  Local Definition mapeq_is_eqrel (ΓΓ ΔΔ : context_mod_eq)
    : iseqrel (@mapeq_hrel ΓΓ ΔΔ).
  Proof.
    repeat split.
    - intros f g h e1 e2 Γ Δ.
      unsquash from Γ Δ (map_derivable f Γ Δ) (map_derivable g Γ Δ)
                    (map_derivable h Γ Δ) (e1 Γ Δ) (e2 Γ Δ)
        as d_Γ d_Δ d_f d_g d_h d_fg d_gh; apply hinhpr.
      refine (derive_mapeq_trans _ _ _ d_g _ _ _);
        auto using derive_flat_cxt_from_strat.
    - intros f Γ Δ.
      unsquash from (map_derivable f Γ Δ) as H; apply hinhpr.
      apply derive_mapeq_refl; auto.
    - intros f g e Γ Δ.
      unsquash from Γ Δ (map_derivable f Γ Δ) (map_derivable g Γ Δ) (e Γ Δ)
        as ? ? ? ? ?. apply hinhpr; intro i.
      apply derive_mapeq_sym; auto using derive_flat_cxt_from_strat.
  Qed.

  Local Definition mapeq_eqrel ΓΓ ΔΔ : eqrel (map ΓΓ ΔΔ)
  := (_,,mapeq_is_eqrel ΓΓ ΔΔ).

  Local Definition map_mod_eq (ΓΓ ΔΔ : context_mod_eq) : UU
  := setquot (mapeq_eqrel ΓΓ ΔΔ).

  Local Definition map_representative {ΓΓ ΔΔ} (ff : map_mod_eq ΓΓ ΔΔ) : UU
  := ∑ (f : map ΓΓ ΔΔ), setquotpr _ f = ff.
  Coercion map_representative : map_mod_eq >-> UU.

  Local Definition map_representative_as_map
      {ΓΓ ΔΔ} {ff : map_mod_eq ΓΓ ΔΔ} (f : map_representative ff)
    : map ΓΓ ΔΔ
  := pr1 f.
  Coercion map_representative_as_map : map_representative >-> map.

  (* TODO: consider naming of this and other analogous lemmas *)

  (** Generally useful lemma: while the definition of map well-typedness is
  with respect to _all_ contexts representing of its source/target, it’s enough
  to show it with respect to _some_ such representatives. *)
  Lemma map_for_some_rep
      {ΓΓ ΔΔ : context_mod_eq} (f : raw_context_map ΓΓ ΔΔ)
    : (∃ (Γ:context_representative ΓΓ) (Δ:context_representative ΔΔ),
        ∥ [! |- f ::: Γ ---> Δ !] ∥)
    -> ∀ (Γ:context_representative ΓΓ) (Δ:context_representative ΔΔ),
        ∥ [! |- f ::: Γ ---> Δ !] ∥.
  Proof.
    intros H Γ Δ.
    unsquash H as [Γ' [Δ' d_f]]; unsquash d_f.
    unsquash from Γ Γ' Δ Δ' (cxteq_context_representatives Γ Γ')
                    (cxteq_context_representatives Δ Δ')
      as ? d_Γ' ? d_Δ' ? ?. apply hinhpr.
    apply (derive_map_conv_cxteq_dom d_Γ');
      auto using derive_flat_cxt_from_strat, derive_flat_cxteq_sym.
    use (derive_map_conv_cxteq_cod _ d_Δ');
      auto using derive_flat_cxt_from_strat, derive_flat_cxteq_sym.
  Qed.

  Lemma raw_mapeq_for_some_rep
      {ΓΓ ΔΔ : context_mod_eq} (f g : raw_context_map ΓΓ ΔΔ)

    : (∃ (Γ:context_representative ΓΓ) (Δ:context_representative ΔΔ),
        ∥ [! |- f ::: Γ ---> Δ !]
          × [! |- g ::: Γ ---> Δ !]
          × [! |- f === g ::: Γ ---> Δ !] ∥)
    -> ∀ (Γ:context_representative ΓΓ) (Δ:context_representative ΔΔ),
        ∥ [! |- f === g ::: Γ ---> Δ !] ∥.
  Proof.
    intros H Γ Δ.
    unsquash H as [Γ' [Δ' d_fg]].
    unsquash from Γ Γ' Δ Δ' d_fg
             (cxteq_context_representatives Γ Γ')
             (cxteq_context_representatives Δ Δ')
      as ? d_Γ' ? d_Δ' [? [? ?]] ? ?. apply hinhpr.
    apply (derive_mapeq_conv_cxteq_dom d_Γ');
      auto using derive_flat_cxt_from_strat, derive_flat_cxteq_sym,
         (derive_map_conv_cxteq_cod d_Γ' d_Δ').
    use (derive_mapeq_conv_cxteq_cod _ d_Δ');
      auto using derive_flat_cxt_from_strat, derive_flat_cxteq_sym.
  Qed.

  Lemma mapeq_for_some_rep
      {ΓΓ ΔΔ : context_mod_eq} (f g : map ΓΓ ΔΔ)
    : (∃ (Γ:context_representative ΓΓ) (Δ:context_representative ΔΔ),
        ∥ [! |- f === g ::: Γ ---> Δ !] ∥)
    -> ∀ (Γ:context_representative ΓΓ) (Δ:context_representative ΔΔ),
        ∥ [! |- f === g ::: Γ ---> Δ !] ∥.
  Proof.
    intros H. apply raw_mapeq_for_some_rep.
    unsquash H as [Γ [Δ H]]; unsquash H.
    apply hinhpr; exists Γ, Δ.
    unsquash from (map_derivable f Γ Δ) (map_derivable g Γ Δ) as ? ?.
    apply hinhpr. intros; repeat split; auto.
  Qed.

  Lemma mapeq_from_path
      {ΓΓ ΔΔ : context_mod_eq} (f g : map ΓΓ ΔΔ)
    : (forall i, f i = g i)
    -> mapeq ΓΓ ΔΔ f g.
  Proof.
    intros e_fg Γ Δ.
    unsquash from (map_derivable f Γ Δ) as d_f; apply hinhpr.
    intros i; rewrite <- (e_fg i).
    apply derive_tmeq_refl, d_f.
  Qed.

End Context_Maps.

Section Context_Map_Operations.

  Local Definition idmap ΓΓ : map_mod_eq ΓΓ ΓΓ.
  Proof.
    refine (setquotpr _ _).
    exists (idmap_raw_context _).
    abstract (
      apply map_for_some_rep;
      apply (take_context_representative ΓΓ);
      [ apply isapropishinh
      | intros Γ; apply hinhpr; exists Γ; exists Γ;
        refine (hinhfun _ Γ); intros;
        use derive_idmap; apply derive_flat_cxt_from_strat; assumption]).
  Defined.

  Local Definition compose
      {ΓΓ ΔΔ ΘΘ} (ff : map_mod_eq ΓΓ ΔΔ) (gg : map_mod_eq ΔΔ ΘΘ)
    : map_mod_eq ΓΓ ΘΘ.
  Proof.
    revert ff gg. use setquotfun2'; [ | split].
    - (* construction of the composite *)
      intros f g. exists (comp_raw_context f g).
      abstract (intros Γ Θ;
        apply (take_context_representative ΔΔ);
        [ apply isapropishinh |
          intros Δ;
          unsquash from Δ (map_derivable f Γ Δ) (map_derivable g Δ Θ)
            as d_Δ d_f d_g; apply hinhpr;
          eauto using (derive_comp d_f) ]).
    - (* respecting equality in [f] *)
      abstract ( intros f f' g e_f Γ Θ; cbn;
        apply (take_context_representative ΔΔ);
        [ apply isapropishinh |
          intros Δ;
          unsquash from Γ (e_f Γ Δ) (map_derivable f Γ Δ)
                       (map_derivable f' Γ Δ) (map_derivable g Δ Θ)
            as ? e ? ? ?; apply hinhpr;
          refine (comp_raw_context_cong_l _ _ _ e _);
          auto using derive_flat_cxt_from_strat ]).
    - (* respecting equality in [g] *)
      abstract ( cbn; intros f g g' e_g Γ Θ;
        apply (take_context_representative ΔΔ);
        [ apply isapropishinh |
          intros Δ;
          unsquash from Γ (e_g Δ Θ) (map_derivable f Γ Δ) as ? e ?;
          apply hinhpr; refine (comp_raw_context_cong_r _ _ e);
          auto using derive_flat_cxt_from_strat ]).
  Defined.

  (* TODO: “empty” and “extension” context maps. *)

End Context_Map_Operations.

Section Category.

  (* TODO: lemmas on associativity etc.  Should be immediate from the
  similar lemmas on raw ones in [SyntaxLemmas]. *)

  Lemma idmap_left {ΓΓ ΔΔ : context_mod_eq} (f : map_mod_eq ΓΓ ΔΔ)
    : compose (idmap _) f = f.
  Proof.
    revert f. apply setquotunivprop'. { intro; apply isasetsetquot. }
    intros f. cbn.
    apply maponpaths. apply subtypePath_prop.
    apply id_left_raw_context.
  Qed.

  Lemma idmap_right {ΓΓ ΔΔ : context_mod_eq} (f : map_mod_eq ΓΓ ΔΔ)
    : compose f (idmap _) = f.
  Proof.
    revert f. apply setquotunivprop'. { intro; apply isasetsetquot. }
    intros f. cbn.
    apply maponpaths. apply subtypePath_prop.
    apply id_right_raw_context.
  Qed.

  Lemma compose_assoc {ΓΓ0 ΓΓ1 ΓΓ2 ΓΓ3 : context_mod_eq} (f : map_mod_eq ΓΓ0 ΓΓ1)
    (g : map_mod_eq ΓΓ1 ΓΓ2) (h : map_mod_eq ΓΓ2 ΓΓ3)
    : compose f (compose g h) = compose (compose f g) h.
  Proof.
    revert f. apply setquotunivprop'. { intro; apply isasetsetquot. } intros f.
    revert g. apply setquotunivprop'. { intro; apply isasetsetquot. } intros g.
    revert h. apply setquotunivprop'. { intro; apply isasetsetquot. } intros h.
    cbn.
    apply maponpaths. apply subtypePath_prop.
    cbn. apply pathsinv0, assoc_raw_context.
  Qed.

  (* TODO: issue to raise in UniMath: [make_category] is constructor for a _univalent_ category! *)
  Definition syntactic_category : category.
  Proof.
    use tpair.
    - use make_precategory_one_assoc.
     + use ((context_mod_eq,,map_mod_eq),,_).
       exists idmap.
       intros Γ Δ Θ.
       apply compose.
     + repeat split.
       * intros ΓΓ ΔΔ f.
         exact (idmap_left f).
       * intros ΓΓ ΔΔ f.
         exact (idmap_right f).
       * intros ΓΓ0 ΓΓ1 ΓΓ2 ΓΓ3 f g h.
         apply (compose_assoc f g h).
    - intros ? ?; apply isasetsetquot.
  Defined.

End Category.

Section Syntactic_Types.

  (** NOTE: it is slightly subtle, but crucial, that the following definitions
  depend directly on [context_of_length_mod_eq] not on [context_mod_eq]: it is
  [context_of_length_mod_eq] that is directly a [setquot], and so we need this
  dependence in order to apply the dependent universal property of [setquot],
  i.e. for constructing functions whose first argument is a context and whose
  later arguments depend on the context, e.g. context extension or any of the
  logical structure on the syntactic category. *)

  Definition is_type_over {n} (ΓΓ : context_of_length_mod_eq n)
     (A : ty_expr n) : UU
  := ∀ Γ : context_representative (n,,ΓΓ), ∥ [! Γ |- A !] ∥.

  Definition id_is_type_over {n}
    {ΓΓ : context_of_length_mod_eq n} {A : ty_expr n} (d_A : is_type_over ΓΓ A)
  := d_A : ∏ Γ, _.
  Coercion id_is_type_over : is_type_over >-> Funclass.

  Local Definition type_over {n} (ΓΓ : context_of_length_mod_eq n)
  := ∑ A, is_type_over ΓΓ A.

  Coercion type_of_type_over {n} {ΓΓ : _ n} : type_over ΓΓ -> ty_expr ΓΓ := pr1.

  Definition type_derivable {n} {ΓΓ : _ n} (A : type_over ΓΓ)
  := pr2 A : is_type_over ΓΓ A.
  Coercion type_derivable : type_over >-> is_type_over.

  Definition typeeq_hrel {n} {ΓΓ : _ n} : hrel (type_over ΓΓ)
  := fun A B => ∀ Γ : context_representative ΓΓ, ∥ [! Γ |- A === B !] ∥.

  Proposition typeeq_is_eqrel {n} (ΓΓ : _ n) : iseqrel (@typeeq_hrel n ΓΓ).
  Proof.
    repeat split.
    - intros A B C e_AB e_BC Γ.
      apply (squash_to_hProp (A Γ)). intros d_A.
      apply (squash_to_hProp (B Γ)). intros d_B.
      apply (squash_to_hProp (C Γ)). intros d_C.
      apply (squash_to_hProp (e_AB Γ)). clear e_AB; intros e_AB.
      apply (squash_to_hProp (e_BC Γ)). clear e_BC; intros e_BC.
      now apply hinhpr, (derive_tyeq_trans Γ _ B).
    - intros A Γ.
      apply (squash_to_hProp (A Γ)). intros d_A.
      now apply hinhpr, derive_tyeq_refl.
    - intros A B e_AB Γ.
      apply (squash_to_hProp (e_AB Γ)). clear e_AB; intros e_AB.
      now apply hinhpr, derive_tyeq_sym.
  Defined.

  Definition typeeq_eqrel {n} {ΓΓ : _ n} : eqrel (type_over ΓΓ)
  := (_,, typeeq_is_eqrel ΓΓ).

  Local Definition type_mod_eq {n} (ΓΓ : context_of_length_mod_eq n) : UU
  := setquot (@typeeq_eqrel _ ΓΓ).

  Local Definition type_representative {n} {ΓΓ : _ n} (AA : type_mod_eq ΓΓ) : UU
  := ∑ (A : type_over ΓΓ), setquotpr _ A = AA.
  Coercion type_representative : type_mod_eq >-> UU.

  Local Definition type_representative_as_type
      {n} {ΓΓ : _ n} {AA : type_mod_eq ΓΓ} (A : type_representative AA)
  := pr1 A : type_over ΓΓ.
  Coercion type_representative_as_type : type_representative >-> type_over.

  (* TODO: perhaps generalise to “representatives” of arbitrary eqrel, and upstream? *)

  Lemma typeeq_type_representatives
      {n} {ΓΓ : _ n} {AA : type_mod_eq ΓΓ} (A A' : type_representative AA)
    : typeeq_eqrel A A'.
  Proof.
    refine (invmap (weqpathsinsetquot typeeq_eqrel A A') _).
    exact (pr2 A @ ! pr2 A').
  Defined.

  Lemma type_for_some_rep
      {ΓΓ : context_mod_eq} (A : ty_expr ΓΓ)
    : (∃ (Γ:context_representative ΓΓ), [! Γ |- A !])
    -> is_type_over ΓΓ A.
  Proof.
    intros H Γ.
    unsquash H as [Γ' d_A].
    unsquash from Γ Γ' (cxteq_context_representatives Γ Γ') as d_Γ d_Γ' e_Γ.
    apply hinhpr, (derive_ty_conv_cxteq Γ');
      eauto using derive_flat_cxteq_sym, derive_flat_cxt_from_strat.
  Qed.

  Lemma typeeq_for_some_rep
      {ΓΓ : context_mod_eq} (A B : type_over ΓΓ)
    : (∃ (Γ:context_representative ΓΓ), [! Γ |- A === B !])
    -> typeeq_hrel A B.
  Proof.
    intros H Γ.
    unsquash H as [Γ' d_AB].
    unsquash from Γ Γ' (cxteq_context_representatives Γ Γ') as d_Γ d_Γ' e_Γ.
    apply hinhpr, (derive_tyeq_conv_cxteq Γ');
      eauto using derive_flat_cxt_from_strat, derive_flat_cxteq_sym.
  Qed.

End Syntactic_Types.

Section Split_Typecat.

  Local Definition ext (ΓΓ : context_mod_eq) (AA : type_mod_eq ΓΓ)
    : context_mod_eq.
  Proof.
    exists (S (length ΓΓ)).
    (* TODO: can we do this with a non-dependent elimination principle
       (ideally, a non-dependent version of [take_representative_with_isaset])
       to get the syntax part computing?? *)
    use (take_representative_with_isaset ΓΓ); try apply isasetsetquot;
      change (representative ΓΓ) with (context_representative ΓΓ).
    - intros Γ.
      use (setquotfun _ _ _ _ AA).
      + intros A. exists (Γ ;; A)%strat_cxt.
        abstract (
          refine (hinhfun2 _ Γ (A Γ)); intros d_Γ d_ΓA;
          exact (derive_extend_stratified_context d_Γ d_ΓA)).
      + intros A A' e_A.
        abstract (
          refine (hinhfun2 _ Γ (e_A Γ)); clear e_A; intros d_Γ e_A;
          apply derive_extend_flat_cxteq;
          auto using derive_flat_cxt_from_strat, d_Γ;
          exact (derive_flat_cxteq_refl d_Γ)).
    - intros Γ Γ'; simpl; revert AA.
      abstract (
        use setquotunivprop'; [ intros; apply isasetsetquot |
        intros A;
        apply iscompsetquotpr;
        unsquash from Γ Γ' (A Γ) (cxteq_context_representatives Γ Γ')
          as ? ? ? ?;
        apply hinhpr, derive_extend_flat_cxteq;
        auto using derive_flat_cxt_from_strat, derive_tyeq_refl ]).
  Defined.

  Local Definition ext_representative
      {ΓΓ : context_mod_eq} (Γ : context_representative ΓΓ)
      (A : type_over ΓΓ)
    : context_representative (ext ΓΓ (setquotpr _ A)).
  Proof.
    use tpair.
    - exists (Γ ;; A)%strat_cxt. shelve.
    - apply pathsinv0. use take_representative_comp.
  Defined.

  Local Definition reind
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (ff : map_mod_eq ΓΓ' ΓΓ)
    : type_mod_eq ΓΓ'.
  Proof.
    simple refine (setquotfun2' _ _ ff AA); try split.
    - (* give the reindexed type *)
      intros f A.
      exists (subst_ty f A).
      intros Γ'.
      apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
      refine (hinhfun2 _ (map_derivable f Γ' Γ) (type_derivable A Γ)).
      intros d_f d_A.
      (* TODO: make [derive_subst_ty] etc. as specialisations of [subst_derivation], and replace [subst_derivation [! _ |- _ !] ] with them throughout? *)
      exact (subst_derivation _ d_A d_f).
    - (* respects equality in the map *)
      clear AA ff. intros f f' A e_f Γ'. cbn.
      apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
      refine (hinhfun5 _ (type_derivable A Γ) Γ'
                       (map_derivable f Γ' Γ) (map_derivable f' Γ' Γ)
                       (e_f Γ' Γ)).
      intros d_Γ_A d_Γ' d_f d_f' d_e_f.
      use (substeq_derivation _ d_Γ_A); auto using derive_flat_cxt_from_strat.
    - (* respects equality in the type *)
      clear AA ff. intros f A A' e_A Γ'. cbn.
      apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
      refine (hinhfun2 _ (map_derivable f Γ' Γ) (e_A Γ)).
      intros d_f d_e_A.
      exact (subst_derivation _ d_e_A d_f).
  Defined.

  Definition syntactic_typecat_structure1 : typecat_structure1 syntactic_category.
  Proof.
    repeat use tpair.
    - (* define the types *)
      intros ΓΓ; cbn in ΓΓ. exact (type_mod_eq ΓΓ).
    - (* context extension *)
      exact ext.
    - (* reindexing *)
      exact @reind.
  Defined.

  Local Definition dpr (ΓΓ : context_mod_eq) (AA : type_mod_eq ΓΓ)
    : map_mod_eq (ext ΓΓ AA) ΓΓ.
  Proof.
    use setquotpr.
    exists (dB_next_context_map _).
    apply map_for_some_rep.
    apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
    revert AA. use setquotunivprop'. { intros; apply isapropishinh. } intros A.
    cbn. apply hinhpr.
    exists (ext_representative Γ _); cbn.
    exists Γ.
    unsquash from Γ (A Γ) as d_Γ d_A; apply hinhpr;
    exact (derive_dB_next_context_map d_Γ d_A).
  Defined.

  Local Definition qmor_raw
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (f : raw_context_map ΓΓ' ΓΓ)
    : raw_context_map (S ΓΓ') (S ΓΓ).
  Proof.
    exact (weaken_raw_context_map f).
  Defined.

  Local Definition qmor_derivable
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (f : map ΓΓ' ΓΓ)
    : ∀ (Γ : context_representative (ext ΓΓ' (reind AA (setquotpr _ f))))
        (Δ : context_representative (ext ΓΓ AA)),
       ∥ [! |- qmor_raw AA f ::: Γ ---> Δ !] ∥.
  Proof.
    apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
    apply (take_context_representative ΓΓ'). { apply propproperty. } intros Γ'.
    revert AA. use setquotunivprop'. { intros; apply propproperty. } intros A.
    apply map_for_some_rep, hinhpr.
    exists (ext_representative Γ' _); cbn.
    exists (ext_representative Γ _); cbn.
    unsquash from Γ Γ' (A Γ) (map_derivable f Γ' Γ) as d_Γ d_Γ' d_A d_f;
      apply hinhpr.
    refine (derive_weaken_raw_context_map _ _ _ d_f);
      auto using derive_flat_cxt_from_strat.
  Qed.

  Local Definition qmor_eq
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq}
      {f g : map ΓΓ' ΓΓ} (e_fg : mapeq ΓΓ' ΓΓ f g)
    : mapeq (ext ΓΓ' (reind AA (setquotpr _ g))) (ext ΓΓ AA)
            (qmor_raw AA f) (qmor_raw AA g).
  Proof.
    refine (raw_mapeq_for_some_rep _ _ _).
    apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
    apply (take_context_representative ΓΓ'). { apply propproperty. } intros Γ'.
    revert AA. use setquotunivprop'. { intros; apply propproperty. } intros A.
    unsquash from Γ Γ' (A Γ)
             (map_derivable f Γ' Γ) (map_derivable g Γ' Γ) (e_fg Γ' Γ)
      as d_Γ d_Γ' d_A d_f d_g d_fg; apply hinhpr.
    exists (ext_representative Γ' _); simpl.
    exists (ext_representative Γ _); simpl.
    apply hinhpr; repeat split.
    + (* TODO: this should probably be abstracted to [TypingLemmas];
           but it seems such an unnatural lemma! *)
      refine (@derive_map_conv_cxteq_dom (S _)
                         (Γ';;subst_ty f A) (Γ';;subst_ty g A) _ _ _ _ _ _ _);
        try apply derive_flat_extend_context;
        try apply (subst_derivation [! Γ |- A !]);
        try apply derive_extend_flat_cxteq, (substeq_derivation [! Γ |- A !]);
        try refine (derive_flat_extend_context _ d_A);
        try refine (derive_weaken_raw_context_map _ _ _ d_f);
        auto using derive_flat_cxt_from_strat, (@derive_flat_cxteq_refl Γ').
    + refine (derive_weaken_raw_context_map _ _ _ d_g);
        auto using derive_flat_cxt_from_strat.
    + refine (derive_weaken_raw_context_mapeq _ _ _ _ _ d_fg);
        auto using derive_flat_cxt_from_strat.
  Qed.

  Local Definition qmor
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (ff : map_mod_eq ΓΓ' ΓΓ)
    : map_mod_eq (ext ΓΓ' (reind AA ff)) (ext ΓΓ AA).
  Proof.
    revert ff.
    simple refine (@setquot_to_dependent_subquotient _ _
              (raw_context_map (S _) _) _ _ _ _ _).
    - intros f. exact (qmor_raw AA f).
    - intros f. apply qmor_derivable.
    - intros f g e_fg. exact (qmor_eq AA e_fg).
  Defined.

  Local Definition dpr_q
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (ff : map_mod_eq ΓΓ' ΓΓ)
    : compose (qmor AA ff) (dpr _ AA) = compose (dpr _ (reind AA ff)) ff.
  Proof.
    revert ff; use setquotunivprop'. { intros; apply isasetsetquot. } intros f.
    simpl.
    apply iscompsetquotpr.
    use mapeq_from_path.
    intros i; simpl.
    apply rename_as_subst_tm.
  Qed.

  Local Definition reind_pb_raw
      {ΓΓ ΓΓ' ΔΔ: context_mod_eq}
      (g : raw_context_map ΔΔ ΓΓ') (h : raw_context_map ΔΔ (S ΓΓ))
    : raw_context_map ΔΔ (S ΓΓ').
  Proof.
    exact (extend_raw_context_map g (h dB_top)).
  Defined.

  Arguments reind_pb_raw {_ _ _} _ _ _/.

  Local Definition reind_pb_derivable
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (f : map ΓΓ' ΓΓ)
      {ΔΔ: context_mod_eq}
      (g : map ΔΔ ΓΓ') (h : map ΔΔ (ext ΓΓ AA))
      (H_e : mapeq ΔΔ ΓΓ (comp_raw_context g f)
                     (comp_raw_context h (dB_next_context_map _)))
    : ∀ (Δ : context_representative ΔΔ)
        (Γ'A : context_representative (ext ΓΓ' (reind AA (setquotpr _ f)))),
       ∥ [! |- reind_pb_raw g h ::: Δ ---> Γ'A !] ∥.
  Proof.
    apply (take_context_representative ΓΓ). { apply propproperty. } intros Γ.
    apply (take_context_representative ΓΓ'). { apply propproperty. } intros Γ'.
    apply (take_context_representative ΔΔ). { apply propproperty. } intros Δ.
    revert AA h H_e. use setquotunivprop'.
    { intros; repeat (apply impred_isaprop; intros); apply propproperty. }
    intros A h H_e.
    apply map_for_some_rep, hinhpr.
    exists Δ; simpl.
    exists (ext_representative Γ' _); simpl.
    refine (hinhpr _ ⊛ Γ ⊛ Γ' ⊛ Δ ⊛ (A Γ)
                     ⊛ (map_derivable f Γ' Γ) ⊛ (map_derivable g Δ Γ')
                     ⊛ (map_derivable h Δ (ext_representative Γ A))
                     ⊛ (H_e Δ Γ)).
    clear H_e; intros d_Γ d_Γ' d_Δ d_A d_f d_g d_h H_eq.
    (* TODO: abstract the following and upstream to [TypingLemmas] *)
    refine (derive_extend_context_map d_g _); simpl.
    assert (d_dpr_h
         : [! |- comp_raw_context h (dB_next_context_map Γ) ::: Δ ---> Γ !]).
    { refine (derive_comp d_h _).
      use derive_dB_next_context_map; auto using derive_flat_cxt_from_strat. }
    assert (d_g_f : [! |- comp_raw_context g f ::: Δ ---> Γ !]).
    { exact (derive_comp d_g d_f). }
    refine (derive_tm_conv _ _ _ _ _ _ _ (d_h dB_top)); simpl;
      change ((Γ;; A) dB_top) with (rename_ty dB_next A).
    - rewrite subst_rename_ty.
      refine (subst_derivation [! _ |- _ !] d_A d_dpr_h).
    - rewrite subst_subst_ty.
      refine (subst_derivation [! _ |- _ !] d_A d_g_f).
    - rewrite subst_rename_ty, subst_subst_ty.
      apply derive_tyeq_sym.
      refine (substeq_derivation [! Γ |- A !] _ _ _ _ _);
          auto using derive_flat_cxt_from_strat.
  Qed.

  (* TODO: [reind_pb_eq], analogous to [qmor_eq] *)

  Local Definition reind_pb
      {ΓΓ : context_mod_eq} (AA : type_mod_eq ΓΓ)
      {ΓΓ' : context_mod_eq} (ff : map_mod_eq ΓΓ' ΓΓ)
    : @isPullback syntactic_category _ _ _ _
           ff (dpr ΓΓ AA) (dpr ΓΓ' (reind AA ff)) (qmor AA ff)
           (! dpr_q AA ff).
  Proof.
    use make_isPullback; simpl.
    intros ΓΓ'' gg hh Heq.
    use unique_exists; simpl.
    3: { intros. apply isapropdirprod; apply isasetsetquot. }
    - admit.
    - split. (* hopefully straightforward with [mapeq_from_path]. *)
      + admit.
      + admit.
    - intros hh' [Hgg Hhh].
      admit.
  Admitted. (* [SyntacticCategory.reind_pb]: hopefully fairly local *)

  Definition syntactic_typecat_structure : typecat_structure syntactic_category.
  Proof.
    exists syntactic_typecat_structure1.
    repeat use tpair.
    - exact dpr.  (* dependent projection *)
    - exact @qmor. (* “q-morphisms” *)
    - exact @dpr_q. (* commutativity of q-morphisms*)
    - exact @reind_pb. (* pullback condition *)
  Defined.

  Lemma is_split_syntactic_typecat_structure
    : is_split_typecat syntactic_typecat_structure.
  Proof.
    repeat split.
    - intros Γ.
      apply isasetsetquot.
    - use tpair.
      + intros ΓΓ AA.
        revert AA; use setquotunivprop'; [intros; apply isasetsetquot|]; intros A.
        apply iscompsetquotpr; simpl; intros Γ.
        use (hinhfun _ (type_derivable A Γ)); intro d_A.
        rewrite subst_idmap_ty.
        now apply derive_tyeq_refl.
      + intros ΓΓ AA.
        unfold q_typecat; simpl; unfold qmor, identity, idmap; simpl.
        rewrite setquot_to_dependent_subquotient_comp.
        simpl.
        (* Should use [derive_idmap_gen]. *)
        (* TODO: state this in terms of syntactic category *)
        admit. (* How to approach this? *)
    - use tpair.
      + simpl.
        intros ΓΓ AA ΓΓ' ff ΓΓ'' gg.
        revert AA; use setquotunivprop'; [intros; apply isasetsetquot|]; intros A.
        revert ff; use setquotunivprop'; [intros; apply isasetsetquot|]; intros f.
        revert gg; use setquotunivprop'; [intros; apply isasetsetquot|]; intros g.
        apply (take_context_representative ΓΓ); [apply isasetsetquot|]; intros Γ.
        apply (take_context_representative ΓΓ'); [apply isasetsetquot|]; intros Γ'.
        apply iscompsetquotpr; cbn; intros Γ''.
        unsquash from (type_derivable A Γ) (map_derivable f Γ' Γ)
                      (map_derivable g Γ'' Γ')
          as hA hf hg; apply hinhpr.
        rewrite <- subst_subst_ty.
        apply derive_tyeq_refl.
        use (subst_derivation [! Γ' |- _ !] _ hg).
        exact (subst_derivation [! Γ |- _ !] hA hf).
      + simpl.
        admit. (* This should be provable once we know how to do the above admit *)
  Admitted. (* [is_split_syntactic_typecat_structure]: seems a bit harder than one might expect. *)

  Definition syntactic_typecat : split_typecat
  := ((syntactic_category,, syntactic_typecat_structure),,
       is_split_syntactic_typecat_structure).

End Split_Typecat.

Section Contextuality.

  (* TODO: Should some of these lemmas be upstreamed? *)

  Local Definition empty_context : syntactic_typecat.
  Proof.
    exists 0.
    apply setquotpr.
    exact empty_wellformed_context_of_length.
  Defined.

  Definition raw_context_map_0 (n : ℕ) : raw_context_map n 0.
  Proof.
    intros x; induction x.
  Defined.

  (* TODO: opacify parts of this *)
  Lemma isTerminal_empty_context : isTerminal syntactic_typecat empty_context.
  Proof.
    use make_isTerminal.
    intros x.
    use tpair.
    - apply setquotpr.
      use tpair.
      + apply raw_context_map_0.
      + simpl.
        intros xx xxx.
        apply hinhpr.
        intros e; induction e.
    - cbn; intros f.
      use (setquot_rect_isaprop (fun X => X = _)); clear f.
      + intros g.
        use (isasetsetquot (mapeq_eqrel x empty_context)).
      + cbn; intros g.
        apply (iscompsetquotpr (mapeq_eqrel x empty_context)).
        intros ? ?; apply hinhpr.
        intros e; induction e.
  Defined.

  (* This is maybe not needed *)
  Lemma wellformed_context_of_length_rest (n : ℕ) :
    wellformed_context_of_length (S n) → wellformed_context_of_length n.
  Proof.
    intros G.
    exists (pr11 G).
    apply (hinhfun pr1 (pr2 G)).
  Defined.

  Lemma syntactic_typecat_is_contextual : is_contextual syntactic_typecat.
  Proof.
    exists empty_context, isTerminal_empty_context.
    intros [n G].
    revert G.
    use setquot_rect_isaprop; intros [G HG].
    - apply isapropiscontr.
    - use unique_exists.
      + induction n.
        apply (0,,tt).
        exists (S (pr1 (IHn (context_rest G) (hinhfun pr1 HG)))).
        use extension_extend.
        apply (pr2 (IHn (context_rest G) (hinhfun pr1 HG))).
        apply setquotpr.
        admit.
      + admit.
      + simpl in *.
        admit.
      + admit.
  Admitted. (* [syntactic_typecat_is_contextual].  Self-contained, proof-irrelevant. *)

  Definition syntactic_contextual_cat : contextual_cat
    := (syntactic_typecat,, syntactic_typecat_is_contextual).

End Contextuality.

(** Miscellaneous lemmas and constructions, e.g. the correspondence between terms in the syntactic sense and terms of the syntactic typecat in the type-category sense *)
Section Misc.

  Definition raw_context_as_partial_object {n}
      (Γ : stratified_context_of_length n)
    : partial (syntactic_category).
  Proof.
    exists ( ∥ [! |- Γ !] ∥ ).
    exists n; apply setquotpr; exists Γ; assumption.
  Defined.

  Definition ty_expr_as_type
      {n} (Γ : wellformed_context_of_length n)
      {A : ty_expr n} (d_A : ∥ [! Γ |- A !] ∥)
    : type_mod_eq Γ.
  Proof.
    apply setquotpr; exists A.
    apply type_for_some_rep.
    refine (hinhfun _ d_A); clear d_A; intros d_A.
    exact (context_as_context_representative Γ,, d_A).
  Defined.

  Definition ty_expr_as_partial_type
      {n} (Γ : wellformed_context_of_length n) (A : ty_expr n)
    : partial (type_mod_eq Γ).
  Proof.
    exists (∥ [! Γ |- A !] ∥).
    apply ty_expr_as_type.
  Defined.

  Definition tm_expr_as_term
      {n} (Γ : wellformed_context_of_length n)
      {A : ty_expr n} (isd_A : ∥ [! Γ |- A !] ∥)
      {a : tm_expr n} (isd_a : ∥ [! Γ |- a ::: A !] ∥)
    : @tm syntactic_typecat _ (ty_expr_as_type Γ isd_A).
  Proof.
    use tpair.
    - (* morphism part *)
      apply setquotpr.
      exists (tm_as_raw_context_map a).
      abstract (
          apply map_for_some_rep, hinhpr;
          refine (context_as_context_representative _,,_);
          use tpair;
          [ apply ext_representative, context_as_context_representative
          | refine (hinhfun2 _ (context_derivable Γ) (isd_a)); intros d_Γ d_a; cbn;
            refine (derive_tm_as_raw_context_map _ _);
        auto using derive_flat_cxt_from_strat]).
    - (* section property *)
      apply iscompsetquotpr; cbn.
      (* TODO: adapt [mapeq_for_some_rep] to incorporate [iscompsetquotpr]? *)
      refine (raw_mapeq_for_some_rep _ _ _); apply hinhpr.
      refine (context_as_context_representative _,,_).
      refine (context_as_context_representative _,,_).
      refine (hinhfun3 _ (context_derivable Γ) isd_A isd_a); intros d_Γ d_A d_a.
      repeat split.
      + use (@derive_comp _ (Γ;;A)%context).
        * refine (derive_tm_as_raw_context_map _ _);
            auto using derive_flat_cxt_from_strat.
        * use derive_dB_next_context_map; auto using derive_flat_cxt_from_strat.
      + use derive_idmap; auto using derive_flat_cxt_from_strat.
      + apply derive_mapeq_refl.
        use (@derive_comp _ (Γ;;A)%context).
        * refine (derive_tm_as_raw_context_map _ _);
            auto using derive_flat_cxt_from_strat.
        * use derive_dB_next_context_map; auto using derive_flat_cxt_from_strat.
  Defined.

  Definition tm_expr_as_partial_term
      {n} (Γ : wellformed_context_of_length n)
      {A : ty_expr n} (isd_A : ∥ [! Γ |- A !] ∥)
      (a : tm_expr n)
    : partial (@tm syntactic_typecat _ (ty_expr_as_type Γ isd_A)).
  Proof.
    exists (∥ [! Γ |- a ::: A !] ∥).
    apply tm_expr_as_term.
  Defined.

  Lemma tm_transportf_tm_expr_as_term_gen
      {n} (Γ : wellformed_context_of_length n)
      {A : ty_expr n} (isd_A : ∥ [! Γ |- A !] ∥)
      {A' : ty_expr n} (isd_A' : ∥ [! Γ |- A' !] ∥)
      (e_A : ty_expr_as_type Γ isd_A = ty_expr_as_type Γ isd_A')
      {a : tm_expr n} (isd_a : ∥ [! Γ |- a ::: A !] ∥)
      (isd_a' : ∥ [! Γ |- a ::: A' !] ∥)
    : @tm_transportf syntactic_typecat _ (ty_expr_as_type Γ isd_A) _
        e_A (tm_expr_as_term Γ isd_A isd_a)
      = tm_expr_as_term Γ isd_A' isd_a'.
  Proof.
  Admitted. (* [tm_transportf_tm_expr_as_term_gen]: hopefully not too hard *)

End Misc.


Require Import Equivalence.
Require Import Morphisms.
Require Import Morphisms_Prop.
Require Import Classical.
Require Import Psatz.
Require Import Basics.

Module Sets.

Class SETS (T: Type): Type :=
{
  full: T;
  empty: T;
  prop_inj: Prop -> T;
  intersect: T -> T -> T;
  union: T -> T -> T;
  indexed_intersect: forall {I}, (I -> T) -> T;
  indexed_union: forall {I}, (I -> T) -> T;
  equiv: T -> T -> Prop;
  included: T -> T -> Prop;
  Taux: Type -> Type;
  Qaux: forall T0, (T0 -> Prop) -> Taux T0;
  Paux: forall T0, (T0 -> T) -> Taux T0;
  conj_aux: forall T0, Taux T0 -> Taux T0 -> Taux T0;
  imply_aux: forall T0, Taux T0 -> Taux T0 -> Taux T0;
  forall_aux: forall T0, Taux T0 -> T;
  exists_aux: forall T0, Taux T0 -> T;
  inj_aux: forall T0, T -> Taux T0;
  derives_aux: forall T0, Taux T0 -> Taux T0 -> T0 -> Prop
}.

Definition omega_intersect {T} {_SETS: SETS T}: (nat -> T) -> T :=
  indexed_intersect.

Definition omega_union {T} {_SETS: SETS T}: (nat -> T) -> T :=
  indexed_union.

Definition general_union {T} {_SETS: SETS T}: (T -> Prop) -> T :=
  fun P => exists_aux T (conj_aux T (Qaux T P) (Paux T (fun x => x))).

Definition general_intersect {T} {_SETS: SETS T}: (T -> Prop) -> T :=
  fun P => forall_aux T (imply_aux T (Qaux T P) (Paux T (fun x => x))).

Definition complement {A: Type} (X: A -> Prop) := fun a => ~ X a.

Definition lift_full {A B} {_SETS: SETS B}: A -> B := fun _ => full.

Definition lift_empty {A B} {_SETS: SETS B}: A -> B := fun _ => empty.

Definition lift_prop_inj {A B} {_SETS: SETS B}: Prop -> A -> B :=
  fun P _ => prop_inj P.

Definition lift_intersect {A B} {_SETS: SETS B}: (A -> B) -> (A -> B) -> (A -> B) :=
  fun x y a => intersect (x a) (y a).

Definition lift_union {A B} {_SETS: SETS B}: (A -> B) -> (A -> B) -> (A -> B) :=
  fun x y a => union (x a) (y a).

Definition lift_indexed_intersect {A B} {_SETS: SETS B}: forall {I}, (I -> A -> B) -> (A -> B) :=
  fun I x a => indexed_intersect (fun i => x i a).

Definition lift_indexed_union {A B} {_SETS: SETS B}: forall {I}, (I -> A -> B) -> (A -> B) :=
  fun I x a => indexed_union (fun i => x i a).

Definition lift_equiv {A B} {_SETS: SETS B}: (A -> B) -> (A -> B) -> Prop :=
  fun x y => forall a, equiv (x a) (y a).

Definition lift_included {A B} {_SETS: SETS B}: (A -> B) -> (A -> B) -> Prop :=
  fun x y => forall a, included (x a) (y a).

Definition lift_Taux {A B} {_SETS: SETS B}: Type -> Type :=
  fun T => A -> Taux T.

Definition lift_Qaux {A B} {_SETS: SETS B}:
  forall T0, (T0 -> Prop) -> A -> Taux T0 :=
  fun T0 X _ => Qaux T0 X.

Definition lift_Paux {A B} {_SETS: SETS B}:
  forall T0, (T0 -> (A -> B)) -> A -> Taux T0 :=
  fun T0 inj a => Paux T0 (fun t => inj t a).

Definition lift_conj_aux {A B} {_SETS: SETS B}:
  forall T0, (A -> Taux T0) -> (A -> Taux T0) -> (A -> Taux T0) :=
  fun T0 x y a => conj_aux T0 (x a) (y a).

Definition lift_imply_aux {A B} {_SETS: SETS B}:
  forall T0, (A -> Taux T0) -> (A -> Taux T0) -> (A -> Taux T0) :=
  fun T0 x y a => imply_aux T0 (x a) (y a).

Definition lift_forall_aux {A B} {_SETS: SETS B}:
  forall T0, (A -> Taux T0) -> (A -> B) :=
  fun T0 x a => forall_aux T0 (x a).

Definition lift_exists_aux {A B} {_SETS: SETS B}:
  forall T0, (A -> Taux T0) -> (A -> B) :=
  fun T0 x a => exists_aux T0 (x a).

Definition lift_derives_aux {A B} {_SETS: SETS B}:
  forall T0, (A -> Taux T0) -> (A -> Taux T0) -> T0 -> Prop :=
  fun T0 x y t0 => forall a, derives_aux T0 (x a) (y a) t0.

Definition lift_inj_aux {A B} {_SETS: SETS B}:
  forall T0, (A -> B) -> (A -> Taux T0) :=
  fun T0 x a => inj_aux T0 (x a).

Definition test1 {A B} {_SETS: SETS B}: (A -> Prop) -> (A -> B) :=
  fun P a => prop_inj (P a).

Definition lift1 {A B} {_SETS: SETS B}: B -> (A -> B) :=
  fun x _ => x.

Definition filter1 {A B} {_SETS: SETS B}: (A -> Prop) -> (A -> B) -> (A -> B) :=
  fun P x => lift_intersect (test1 P) x.

Definition projB {A B} (s: (A * B) -> Prop): B -> Prop:=
  fun b => exists a, s (a,b).

Definition singleton {A: Type} (a: A): A -> Prop := eq a.

Definition In {A: Type} (a: A) (X: A -> Prop): Prop := X a.

End Sets.

Arguments Sets.full: simpl never.
Arguments Sets.empty: simpl never.
Arguments Sets.prop_inj: simpl never.
Arguments Sets.intersect: simpl never.
Arguments Sets.union: simpl never.
Arguments Sets.omega_intersect: simpl never.
Arguments Sets.omega_union: simpl never.
Arguments Sets.general_intersect: simpl never.
Arguments Sets.general_union: simpl never.
Arguments Sets.equiv: simpl never.
Arguments Sets.included: simpl never.
Arguments Sets.singleton: simpl never.
Arguments Sets.In: simpl never.

#[export] Instance Prop_SETS: Sets.SETS Prop :=
  {|
    Sets.full := True;
    Sets.empty := False;
    Sets.prop_inj := fun P => P;
    Sets.intersect := and;
    Sets.union := or;
    Sets.indexed_intersect := fun I P => forall i, P i;
    Sets.indexed_union := @ex;
    Sets.equiv := iff;
    Sets.included := fun P Q => P -> Q;
    Sets.Taux := fun T => T -> Prop;
    Sets.Qaux := fun T0 X P => X P;
    Sets.Paux := fun T0 inj P => inj P;
    Sets.conj_aux := fun T0 x y a => x a /\ y a;
    Sets.imply_aux := fun T0 x y a => x a -> y a;
    Sets.forall_aux := fun T0 P => forall x, P x;
    Sets.exists_aux := fun T0 P => exists x, P x;
    Sets.inj_aux := fun T0 P _ => P;
    Sets.derives_aux := fun T0 x y t0 => x t0 -> y t0
  |}.

#[export] Instance lift_SETS (A B: Type) (_SETS: Sets.SETS B): Sets.SETS (A -> B) :=
  {|
    Sets.full := Sets.lift_full;
    Sets.empty := Sets.lift_empty;
    Sets.prop_inj := Sets.lift_prop_inj;
    Sets.intersect := Sets.lift_intersect;
    Sets.union := Sets.lift_union;
    Sets.indexed_intersect := @Sets.lift_indexed_intersect _ _ _;
    Sets.indexed_union := @Sets.lift_indexed_union _ _ _;
    Sets.equiv := Sets.lift_equiv;
    Sets.included := Sets.lift_included;
    Sets.Taux := @Sets.lift_Taux A B _;
    Sets.Qaux := Sets.lift_Qaux;
    Sets.Paux := Sets.lift_Paux;
    Sets.conj_aux := Sets.lift_conj_aux;
    Sets.imply_aux := Sets.lift_imply_aux;
    Sets.forall_aux := Sets.lift_forall_aux;
    Sets.exists_aux := Sets.lift_exists_aux;
    Sets.inj_aux := Sets.lift_inj_aux;
    Sets.derives_aux := Sets.lift_derives_aux
  |}.

Ltac SETS_unfold1 SETS :=
  match SETS with
  | lift_SETS _ _ _ =>
      let p := eval unfold lift_SETS at 1 in SETS in
      constr:(p)
  | Prop_SETS =>
      let p := eval unfold Prop_SETS in SETS in
      constr:(p)
  | @Sets.Build_SETS _
      _ _ _ _ _ _
      _ _ _ _ _ _
      _ _ _ _ _ _ =>
      constr:(SETS)
  end.

Ltac SETS_simplify T :=
  first
    [ match T with
      | ?op ?A ?SETS =>
        match T with
        | context [@Sets.test1] => fail 1
        | context [@Sets.lift1] => fail 1
        | context [@Sets.filter1] => fail 1
        | _ => idtac
        end;
        match SETS with
        | lift_SETS _ _ _ => idtac
        | Prop_SETS => idtac
        | @Sets.Build_SETS _
             _ _ _ _ _ _
             _ _ _ _ _ _
             _ _ _ _ _ _ => idtac
        end;
        let op1 := eval cbv delta
              [Sets.full
               Sets.empty
               Sets.prop_inj
               Sets.intersect
               Sets.union
               Sets.omega_intersect
               Sets.omega_union
               Sets.indexed_intersect
               Sets.indexed_union
               Sets.equiv
               Sets.included
               Sets.general_intersect
               Sets.general_union
               Sets.Taux
               Sets.Qaux
               Sets.Paux
               Sets.conj_aux
               Sets.imply_aux
               Sets.forall_aux
               Sets.exists_aux] in op in
        let SETS1 := SETS_unfold1 SETS in
        let T1 := eval cbv beta zeta iota in
              (op1 A SETS1) in
        let T2 := eval cbv delta
              [Sets.lift_full
               Sets.lift_empty
               Sets.lift_prop_inj
               Sets.lift_intersect
               Sets.lift_union
               Sets.lift_indexed_intersect
               Sets.lift_indexed_union
               Sets.lift_equiv
               Sets.lift_included
               Sets.lift_Taux
               Sets.lift_Qaux
               Sets.lift_Paux
               Sets.lift_conj_aux
               Sets.lift_imply_aux
               Sets.lift_forall_aux
               Sets.lift_exists_aux] in T1 in
        change T with T2;
        try SETS_simplify T2
      end
    | match T with
      | ?op ?A ?B ?SETS =>
        let op1 := eval cbv delta [Sets.filter1 Sets.lift1 Sets.test1] in op in
        let T1 := eval cbv beta zeta iota in
              (op1 A B SETS) in
        let T2 := eval cbv delta
              [Sets.lift_prop_inj
               Sets.lift_intersect] in T1 in
        change T with T2;
        try SETS_simplify T2
      end
    ].

Ltac unfold_SETS_tac :=
  repeat
  match goal with
  | |- context [@Sets.full ?T ?_SETS] =>
         SETS_simplify (@Sets.full T _SETS)
  | |- context [@Sets.empty ?T ?_SETS] =>
         SETS_simplify (@Sets.empty T _SETS)
  | |- context [@Sets.prop_inj ?T ?_SETS] =>
         SETS_simplify (@Sets.prop_inj T _SETS)
  | |- context [@Sets.equiv ?T ?_SETS] =>
         SETS_simplify (@Sets.equiv T _SETS)
  | |- context [@Sets.intersect ?T ?_SETS] =>
         SETS_simplify (@Sets.intersect T _SETS)
  | |- context [@Sets.union ?T ?_SETS] =>
         SETS_simplify (@Sets.union T _SETS)
  | |- context [@Sets.omega_intersect ?T ?_SETS] =>
         SETS_simplify (@Sets.omega_intersect T _SETS)
  | |- context [@Sets.omega_union ?T ?_SETS] =>
         SETS_simplify (@Sets.omega_union T _SETS)
  | |- context [@Sets.indexed_intersect ?T ?_SETS] =>
         SETS_simplify (@Sets.indexed_intersect T _SETS)
  | |- context [@Sets.indexed_union ?T ?_SETS] =>
         SETS_simplify (@Sets.indexed_union T _SETS)
  | |- context [@Sets.general_intersect ?T ?_SETS] =>
         SETS_simplify (@Sets.general_intersect T _SETS)
  | |- context [@Sets.general_union ?T ?_SETS] =>
         SETS_simplify (@Sets.general_union T _SETS)
  | |- context [@Sets.Taux ?T ?_SETS] =>
         SETS_simplify (@Sets.Taux T _SETS)
  | |- context [@Sets.Paux ?T ?_SETS] =>
         SETS_simplify (@Sets.Paux T _SETS)
  | |- context [@Sets.Qaux ?T ?_SETS] =>
         SETS_simplify (@Sets.Qaux T _SETS)
  | |- context [@Sets.conj_aux ?T ?_SETS] =>
         SETS_simplify (@Sets.conj_aux T _SETS)
  | |- context [@Sets.imply_aux ?T ?_SETS] =>
         SETS_simplify (@Sets.imply_aux T _SETS)
  | |- context [@Sets.exists_aux ?T ?_SETS] =>
         SETS_simplify (@Sets.exists_aux T _SETS)
  | |- context [@Sets.forall_aux ?T ?_SETS] =>
         SETS_simplify (@Sets.forall_aux T _SETS)
  | |- context [@Sets.included ?T ?_SETS] =>
         SETS_simplify (@Sets.included T _SETS)
  | |- context [@Sets.filter1 ?A ?T ?_SETS] =>
         SETS_simplify (@Sets.filter1 A T _SETS)
  | |- context [@Sets.lift1 ?A ?T ?_SETS] =>
         SETS_simplify (@Sets.lift1 A T _SETS)
  | |- context [@Sets.test1 ?A ?T ?_SETS] =>
         SETS_simplify (@Sets.test1 A T _SETS)
  | |- _ => progress cbv beta
  end.

Class SETS_Properties (T: Type) {_SETS: Sets.SETS T}: Prop :=
{
  Sets_included_refl: Reflexive Sets.included;
  Sets_included_trans: Transitive Sets.included;
  Sets_equiv_Sets_included: forall x y, Sets.equiv x y <-> (Sets.included x y /\ Sets.included y x);
  Sets_empty_included: forall x, Sets.included Sets.empty x;
  Sets_included_full: forall x, Sets.included x Sets.full;
  Sets_prop_inj_included: forall (P: Prop) x y, (P -> Sets.included x y) -> Sets.included (Sets.intersect (Sets.prop_inj P) x) y;
  Sets_included_prop_inj: forall (P: Prop) x, P -> Sets.included x (Sets.prop_inj P);
  Sets_intersect_included1: forall x y, Sets.included (Sets.intersect x y) x;
  Sets_intersect_included2: forall x y, Sets.included (Sets.intersect x y) y;
  Sets_included_intersect: forall x y z, Sets.included x y -> Sets.included x z -> Sets.included x (Sets.intersect y z);
  Sets_included_union1: forall x y, Sets.included x (Sets.union x y);
  Sets_included_union2: forall x y, Sets.included y (Sets.union x y);
  Sets_union_included_strong2: forall x y z u, Sets.included (Sets.intersect x u) z -> Sets.included (Sets.intersect y u) z -> Sets.included (Sets.intersect (Sets.union x y) u) z;
  Sets_indexed_union_included_strong2: forall {I: Type} (xs: I -> T) z u, (forall i, Sets.included (Sets.intersect (xs i) u) z) -> Sets.included (Sets.intersect (Sets.indexed_union xs) u) z;
  Sets_included_indexed_union: forall I (xs: I -> T) n, Sets.included (xs n) (Sets.indexed_union xs);
  Sets_indexed_union_included: forall I (xs: I -> T) y, (forall n, Sets.included (xs n) y) -> Sets.included (Sets.indexed_union xs) y;
  Sets_indexed_intersect_included: forall I (xs: I -> T) n, Sets.included (Sets.indexed_intersect xs) (xs n);
  Sets_included_indexed_intersect: forall I (xs: I -> T) y, (forall n, Sets.included y (xs n)) -> Sets.included y (Sets.indexed_intersect xs);
  Sets_included_derives_aux: forall T0 x y t0, Sets.included x y -> Sets.derives_aux T0 (Sets.inj_aux T0 x) (Sets.inj_aux T0 y) t0;
  Sets_derives_aux_trans: forall T0 t0, Transitive (fun x y => Sets.derives_aux T0 x y t0);
  Sets_Qaux_right: forall T0 t0 (Pr: T0 -> Prop) P,
    Pr t0 ->
    Sets.derives_aux T0 P (Sets.Qaux T0 Pr) t0;
  Sets_Paux_left: forall T0 t0 (inj: T0 -> T),
    Sets.derives_aux T0 (Sets.Paux T0 inj) (Sets.inj_aux T0 (inj t0)) t0;
  Sets_Paux_right: forall T0 t0 (inj: T0 -> T),
    Sets.derives_aux T0 (Sets.inj_aux T0 (inj t0)) (Sets.Paux T0 inj) t0;
  Sets_Qaux_left_extract: forall T0 t0 (Pr: T0 -> Prop) Q1 Q2,
    (Pr t0 -> Sets.derives_aux T0 Q1 Q2 t0) ->
    Sets.derives_aux T0 (Sets.conj_aux T0 (Sets.Qaux T0 Pr) Q1) Q2 t0;
  Sets_Qaux_right_extract: forall T0 t0 (Pr: T0 -> Prop) Q1 Q2,
    (Pr t0 -> Sets.derives_aux T0 Q1 Q2 t0) ->
    Sets.derives_aux T0 Q1 (Sets.imply_aux T0 (Sets.Qaux T0 Pr) Q2) t0;
  Sets_Qaux_implies_left: forall T0 t0 (Pr: T0 -> Prop) Q1 Q2,
    Pr t0 ->
    Sets.derives_aux T0 Q1 Q2 t0 ->
    Sets.derives_aux T0 (Sets.imply_aux T0 (Sets.Qaux T0 Pr) Q1) Q2 t0;
  Sets_conj_aux_right: forall T0 t0 P Q1 Q2,
    Sets.derives_aux T0 P Q1 t0 ->
    Sets.derives_aux T0 P Q2 t0 ->
    Sets.derives_aux T0 P (Sets.conj_aux T0 Q1 Q2) t0;
  Sets_exists_aux_left: forall T0 P Q,
    (forall t0, Sets.derives_aux T0 Q (Sets.inj_aux T0 P) t0) ->
    Sets.included (Sets.exists_aux T0 Q) P;
  Sets_exists_aux_right: forall T0 t0 P Q,
    Sets.derives_aux T0 (Sets.inj_aux T0 P) Q t0 ->
    Sets.included P (Sets.exists_aux T0 Q);
  Sets_forall_aux_left: forall T0 t0 P Q,
    Sets.derives_aux T0 Q (Sets.inj_aux T0 P) t0 ->
    Sets.included (Sets.forall_aux T0 Q) P;
  Sets_forall_aux_right: forall T0 P Q,
    (forall t0, Sets.derives_aux T0 (Sets.inj_aux T0 P) Q t0) ->
    Sets.included P (Sets.forall_aux T0 Q);
}.

#[export] Existing Instances Sets_included_refl Sets_included_trans.

Lemma Sets_included_omega_union: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} xs n, Sets.included (xs n) (Sets.omega_union xs).
Proof. intros. apply Sets_included_indexed_union. Qed.

Lemma Sets_omega_union_included: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} xs y, (forall n, Sets.included (xs n) y) -> Sets.included (Sets.omega_union xs) y.
Proof. intros. apply Sets_indexed_union_included; auto. Qed.

Lemma Sets_omega_intersect_included: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} xs n, Sets.included (Sets.omega_intersect xs) (xs n).
Proof. intros. apply Sets_indexed_intersect_included. Qed.

Lemma Sets_included_omega_intersect: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} xs y, (forall n, Sets.included y (xs n)) -> Sets.included y (Sets.omega_intersect xs).
Proof. intros. apply Sets_included_indexed_intersect; auto. Qed.

Lemma Sets_included_general_union: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} (xs: _ -> Prop) x, xs x -> Sets.included x (Sets.general_union xs).
Proof.
  intros.
  apply Sets_exists_aux_right with x.
  apply Sets_conj_aux_right.
  + apply Sets_Qaux_right; auto.
  + apply (Sets_Paux_right T x (fun x => x)).
Qed.

Lemma Sets_general_union_included: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} (xs: _ -> Prop) y, (forall x, xs x -> Sets.included x y) -> Sets.included (Sets.general_union xs) y.
Proof.
  intros.
  apply Sets_exists_aux_left; intros.
  apply Sets_Qaux_left_extract; intros.
  apply H in H0.
  eapply (Sets_included_derives_aux T) in H0.
  eapply Sets_derives_aux_trans; eauto.
  apply (Sets_Paux_left T t0 (fun x => x)).
Qed.

Lemma Sets_general_intersect_included: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} (xs: _ -> Prop) x, xs x -> Sets.included (Sets.general_intersect xs) x.
Proof.
  intros.
  apply Sets_forall_aux_left with x.
  apply Sets_Qaux_implies_left; auto.
  apply (Sets_Paux_left T x (fun x => x)).
Qed.

Lemma Sets_included_general_intersect: forall {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T} (xs: _ -> Prop) y, (forall x, xs x -> Sets.included y x) -> Sets.included y (Sets.general_intersect xs).
Proof.
  intros.
  apply Sets_forall_aux_right; intros.
  apply Sets_Qaux_right_extract; intros.
  apply H in H0.
  eapply (Sets_included_derives_aux T) in H0.
  eapply Sets_derives_aux_trans; eauto.
  apply (Sets_Paux_right T t0 (fun x => x)).
Qed.

Lemma Sets_filter1_defn: forall {S T} {_SETS: Sets.SETS T} (P: S -> Prop) (Q: S -> T),
  Sets.filter1 P Q = Sets.intersect (Sets.test1 P) Q.
Proof.
  intros.
  reflexivity.
Qed.

#[export] Instance Sets_equiv_refl {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Reflexive Sets.equiv.
Proof.
  hnf; intros.
  apply Sets_equiv_Sets_included.
  split; apply Sets_included_refl.
Qed.

#[export] Instance Sets_equiv_sym {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Symmetric Sets.equiv.
Proof.
  hnf; intros.
  rewrite Sets_equiv_Sets_included in H |- *.
  tauto.
Qed.

#[export] Instance Sets_equiv_trans {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Transitive Sets.equiv.
Proof.
  hnf; intros.
  rewrite Sets_equiv_Sets_included in H, H0 |- *.
  destruct H, H0.
  split; eapply Sets_included_trans; eauto.
Qed.

#[export] Instance Sets_equiv_equiv {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Equivalence Sets.equiv.
Proof.
  constructor; auto.
  + apply Sets_equiv_refl; auto.
  + apply Sets_equiv_sym; auto.
  + apply Sets_equiv_trans; auto.
Qed.

#[export] Instance Sets_included_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv ==> iff) Sets.included.
Proof.
  unfold Proper, respectful.
  intros.
  rewrite Sets_equiv_Sets_included in H, H0.
  destruct H, H0.
  split; intros;
  repeat (eapply Sets_included_trans; eauto).
Qed.

Lemma Sets_intersect_full {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x, Sets.equiv (Sets.intersect x Sets.full) x.
Proof.
  intros.
  apply Sets_equiv_Sets_included.
  split.
  + apply Sets_intersect_included1.
  + apply Sets_included_intersect.
    - reflexivity.
    - apply Sets_included_full.
Qed.

Lemma Sets_union_included {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y z, Sets.included x z -> Sets.included y z -> Sets.included (Sets.union x y) z.
Proof.
  intros.
  pose proof Sets_union_included_strong2 x y z Sets.full.
  rewrite !Sets_intersect_full in H1.
  auto.
Qed.

#[export] Instance Sets_union_mono {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included ==> Sets.included) Sets.union.
Proof.
  unfold Proper, respectful.
  intros.
  apply Sets_union_included.
  + apply Sets_included_trans with y; auto.
    apply Sets_included_union1.
  + apply Sets_included_trans with y0; auto.
    apply Sets_included_union2.
Qed.

#[export] Instance Sets_union_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv ==> Sets.equiv) Sets.union.
Proof.
  hnf; intros; hnf; intros.
  apply Sets_equiv_Sets_included in H.
  apply Sets_equiv_Sets_included in H0.
  apply Sets_equiv_Sets_included; split;
  apply Sets_union_mono; tauto.
Qed.

#[export] Instance Sets_intersect_mono {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included ==> Sets.included) Sets.intersect.
Proof.
  unfold Proper, respectful.
  intros.
  apply Sets_included_intersect.
  + rewrite <- H.
    apply Sets_intersect_included1.
  + rewrite <- H0.
    apply Sets_intersect_included2.
Qed.

#[export] Instance Sets_intersect_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv ==> Sets.equiv) Sets.intersect.
Proof.
  hnf; intros; hnf; intros.
  apply Sets_equiv_Sets_included in H.
  apply Sets_equiv_Sets_included in H0.
  apply Sets_equiv_Sets_included; split;
  apply Sets_intersect_mono; tauto.
Qed.

#[export] Instance Sets_indexed_union_mono {A T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) (@Sets.indexed_union _ _ A).
Proof.
  unfold Proper, respectful.
  intros.
  apply Sets_indexed_union_included.
  intros.
  apply Sets_included_trans with (y n); auto.
  apply Sets_included_indexed_union.
Qed.

#[export] Instance Sets_indexed_union_congr {A T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) (@Sets.indexed_union _ _ A).
Proof.
  hnf; intros.
  apply Sets_equiv_Sets_included; split;
  apply Sets_indexed_union_mono;
  intros n; specialize (H n);
  apply Sets_equiv_Sets_included in H; tauto.
Qed.

#[export] Instance Sets_indexed_intersect_mono {A T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) (@Sets.indexed_intersect _ _ A).
Proof.
  unfold Proper, respectful.
  intros.
  apply Sets_included_indexed_intersect.
  intros.
  apply Sets_included_trans with (x n); auto.
  apply Sets_indexed_intersect_included.
Qed.

#[export] Instance Sets_indexed_intersect_congr {A T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) (@Sets.indexed_intersect _ _ A).
Proof.
  hnf; intros.
  apply Sets_equiv_Sets_included; split;
  apply Sets_indexed_intersect_mono;
  intros n; specialize (H n);
  apply Sets_equiv_Sets_included in H; tauto.
Qed.

#[export] Instance Sets_omega_union_mono {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) Sets.omega_union.
Proof. apply Sets_indexed_union_mono. Qed.

#[export] Instance Sets_omega_union_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) Sets.omega_union.
Proof. apply Sets_indexed_union_congr. Qed.

#[export] Instance Sets_omega_intersect_mono {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) Sets.omega_intersect.
Proof. apply Sets_indexed_intersect_mono. Qed.

#[export] Instance Sets_omega_intersect_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) Sets.omega_intersect.
Proof. apply Sets_indexed_intersect_congr. Qed.

Lemma Sets_intersect_absorb1 {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y,
    Sets.included x y ->
    Sets.equiv (Sets.intersect x y) x.
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + apply Sets_intersect_included1.
  + apply Sets_included_intersect.
    - reflexivity.
    - auto.
Qed.

Lemma Sets_intersect_absorb2 {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y,
    Sets.included x y ->
    Sets.equiv (Sets.intersect y x) x.
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + apply Sets_intersect_included2.
  + apply Sets_included_intersect.
    - auto.
    - reflexivity.
Qed.

Lemma Sets_union_absorb1 {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y,
    Sets.included y x ->
    Sets.equiv (Sets.union x y) x.
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + apply Sets_union_included.
    - reflexivity.
    - auto.
  + apply Sets_included_union1.
Qed.

Lemma Sets_union_absorb2 {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y,
    Sets.included x y ->
    Sets.equiv (Sets.union x y) y.
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + apply Sets_union_included.
    - auto.
    - reflexivity.
  + apply Sets_included_union2.
Qed.

Lemma Sets_union_comm {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall x y,
  Sets.equiv (Sets.union x y) (Sets.union y x).
Proof.
  intros.
  rewrite Sets_equiv_Sets_included; split; apply Sets_union_included;
  first [ apply Sets_included_union1 | apply Sets_included_union2 ].
Qed.

Lemma Sets_union_assoc {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y z,
    Sets.equiv
      (Sets.union (Sets.union x y) z)
      (Sets.union x (Sets.union y z)).
Proof.
  intros.
  apply Sets_equiv_Sets_included; split;
    repeat apply Sets_union_included.
  + apply Sets_included_union1.
  + rewrite <- Sets_included_union2.
    apply Sets_included_union1.
  + rewrite <- Sets_included_union2.
    apply Sets_included_union2.
  + rewrite <- Sets_included_union1.
    apply Sets_included_union1.
  + rewrite <- Sets_included_union1.
    apply Sets_included_union2.
  + apply Sets_included_union2.
Qed.

Lemma Sets_intersect_comm {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall x y,
  Sets.equiv (Sets.intersect x y) (Sets.intersect y x).
Proof.
  intros.
  rewrite Sets_equiv_Sets_included; split; apply Sets_included_intersect;
  first [ apply Sets_intersect_included1 | apply Sets_intersect_included2 ].
Qed.

Lemma Sets_intersect_assoc {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y z,
    Sets.equiv
      (Sets.intersect (Sets.intersect x y) z)
      (Sets.intersect x (Sets.intersect y z)).
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + repeat apply Sets_included_intersect.
    - rewrite Sets_intersect_included1.
      apply Sets_intersect_included1.
    - rewrite Sets_intersect_included1.
      apply Sets_intersect_included2.
    - apply Sets_intersect_included2.
  + repeat apply Sets_included_intersect.
    - apply Sets_intersect_included1.
    - rewrite Sets_intersect_included2.
      apply Sets_intersect_included1.
    - rewrite Sets_intersect_included2.
      apply Sets_intersect_included2.
Qed.

Lemma Sets_union_included_strong1 {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y z u, Sets.included (Sets.intersect u x) z -> Sets.included (Sets.intersect u y) z -> Sets.included (Sets.intersect u (Sets.union x y)) z.
Proof.
  intros.
  rewrite Sets_intersect_comm in H, H0 |- *.
  apply Sets_union_included_strong2; auto.
Qed.

Lemma Sets_indexed_union_included_strong1 {I T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall (xs: I -> T) z u, (forall i, Sets.included (Sets.intersect u (xs i)) z) -> Sets.included (Sets.intersect u (Sets.indexed_union xs)) z.
Proof.
  intros.
  rewrite Sets_intersect_comm.
  apply Sets_indexed_union_included_strong2.
  intros.
  rewrite Sets_intersect_comm.
  apply H.
Qed.

Lemma Sets_union_empty {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall x,
  Sets.equiv (Sets.union x Sets.empty) x.
Proof.
  intros.
  rewrite Sets_equiv_Sets_included; split.
  + apply Sets_union_included.
    - reflexivity.
    - apply Sets_empty_included.
  + apply Sets_included_union1.
Qed.

Lemma Sets_empty_union {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall x,
  Sets.equiv (Sets.union Sets.empty x) x.
Proof.
  intros.
  rewrite Sets_equiv_Sets_included; split.
  + apply Sets_union_included.
    - apply Sets_empty_included.
    - reflexivity.
  + apply Sets_included_union2.
Qed.

Lemma Sets_prop_inj_included_prop_inj {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall (P Q: Prop),
  (P -> Q) ->
  Sets.included
    (Sets.prop_inj P)
    (Sets.prop_inj Q).
Proof.
  intros.
  rewrite <- Sets_intersect_full.
  apply Sets_prop_inj_included.
  intros.
  apply Sets_included_prop_inj.
  tauto.
Qed.

Lemma Sets_prop_inj_and {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall P Q,
  Sets.equiv
    (Sets.prop_inj (P /\ Q))
    (Sets.intersect (Sets.prop_inj P) (Sets.prop_inj Q)).
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + apply Sets_included_intersect.
    - apply Sets_prop_inj_included_prop_inj; tauto.
    - apply Sets_prop_inj_included_prop_inj; tauto.
  + apply Sets_prop_inj_included.
    intros.
    apply Sets_prop_inj_included_prop_inj; tauto.
Qed.

Lemma Sets_prop_inj_or {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall P Q,
  Sets.equiv
    (Sets.prop_inj (P \/ Q))
    (Sets.union (Sets.prop_inj P) (Sets.prop_inj Q)).
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + rewrite <- Sets_intersect_full.
    apply Sets_prop_inj_included.
    intros [? | ?].
    - rewrite <- Sets_included_union1.
      apply Sets_included_prop_inj, H.
    - rewrite <- Sets_included_union2.
      apply Sets_included_prop_inj, H.
  + apply Sets_union_included.
    - apply Sets_prop_inj_included_prop_inj; tauto.
    - apply Sets_prop_inj_included_prop_inj; tauto.
Qed.

Lemma Sets_prop_inj_ex {I T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall (P: I -> Prop),
  Sets.equiv
    (Sets.prop_inj (ex P))
    (Sets.indexed_union (fun i => Sets.prop_inj (P i))).
Proof.
  intros.
  apply Sets_equiv_Sets_included; split.
  + rewrite <- Sets_intersect_full.
    apply Sets_prop_inj_included.
    intros [? ?].
    rewrite <- Sets_included_indexed_union.
    apply Sets_included_prop_inj, H.
  + apply Sets_indexed_union_included.
    intros.
    apply Sets_prop_inj_included_prop_inj.
    intros; exists n; auto.
Qed.

Lemma Sets_test1_imply {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall (P Q: S -> Prop),
  (forall a, P a -> Q a) ->
  Sets.included (Sets.test1 P) (Sets.test1 Q).
Proof.
  intros.
  unfold_SETS_tac;intros.
  apply Sets_prop_inj_included_prop_inj.
  auto.
Qed.

Lemma Sets_test1_and {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall (P Q: S -> Prop),
  Sets.equiv
    (Sets.test1 (fun a => P a /\ Q a))
    (Sets.intersect (Sets.test1 P) (Sets.test1 Q)).
Proof.
  intros.
  unfold_SETS_tac; intros.
  apply Sets_prop_inj_and.
Qed.

Lemma Sets_test1_or {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall (P Q: S -> Prop),
  Sets.equiv
    (Sets.test1 (fun a => P a \/ Q a))
    (Sets.union (Sets.test1 P) (Sets.test1 Q)).
Proof.
  intros.
  unfold_SETS_tac; intros.
  apply Sets_prop_inj_or.
Qed.

Lemma omega_union_union {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall x y xs ys zs,
  (forall n, zs n = Sets.union (xs n) (ys n)) ->
  Sets.equiv x (Sets.omega_union xs) /\ (forall n, Sets.included (xs n) (xs (S n))) ->
  Sets.equiv y (Sets.omega_union ys) /\ (forall n, Sets.included (ys n) (ys (S n))) ->
  Sets.equiv (Sets.union x y) (Sets.omega_union zs) /\ (forall n, Sets.included (zs n) (zs (S n))).
Proof.
  intros ? ? ? ? ? Hzs [Hx Hxs] [Hy Hys].
  rewrite Hx, Hy; clear x y Hx Hy.
  split; [apply Sets_equiv_Sets_included; split |].
  + apply Sets_union_included; apply Sets_omega_union_included; intros n.
    - rewrite (Sets_included_union1 _ (ys n)), <- Hzs.
      apply Sets_included_omega_union.
    - rewrite (Sets_included_union2 (xs n)), <- Hzs.
      apply Sets_included_omega_union.
  + apply Sets_omega_union_included; intros n.
    rewrite Hzs.
    apply Sets_union_included.
    - rewrite <- Sets_included_union1.
      apply Sets_included_omega_union.
    - rewrite <- Sets_included_union2.
      apply Sets_included_omega_union.
  + intros; rewrite !Hzs.
    apply Sets_union_mono; auto.
Qed.

Lemma omega_union_const {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: forall x,
  Sets.equiv x (Sets.omega_union (fun _ => x)) /\ (forall n: nat, Sets.included x x).
Proof.
  intros.
  split; [apply Sets_equiv_Sets_included; split |].
  + change x with ((fun _ => x) O) at 1.
    apply Sets_included_omega_union.
  + apply Sets_omega_union_included; intros n.
    reflexivity.
  + intros.
    reflexivity.
Qed.

#[export] Instance Prop_SETS_Properties: SETS_Properties Prop.
Proof.
  constructor; unfold Proper, respectful; unfold_SETS_tac; simpl;
  hnf; intros; try tauto.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
  + firstorder.
Qed.

#[export] Instance lift_SETS_Properties (A B: Type) (_SETS: Sets.SETS B) (_SETS_Properties: SETS_Properties B): SETS_Properties (A -> B).
Proof.
  constructor; unfold Proper, respectful; unfold_SETS_tac; hnf; intros.
  + apply Sets_included_refl.
  + eapply Sets_included_trans; eauto.
  + split; intros.
    - split; intros; specialize (H a);
      rewrite Sets_equiv_Sets_included in H;
      tauto.
    - destruct H.
      intros.
      rewrite Sets_equiv_Sets_included; auto.
  + apply Sets_empty_included.
  + apply Sets_included_full.
  + apply Sets_prop_inj_included; auto.
  + apply Sets_included_prop_inj; auto.
  + apply Sets_intersect_included1.
  + apply Sets_intersect_included2.
  + apply Sets_included_intersect; auto.
  + apply Sets_included_union1.
  + apply Sets_included_union2.
  + apply Sets_union_included_strong2; auto.
  + apply Sets_indexed_union_included_strong2; auto.
  + apply (Sets_included_indexed_union I (fun n => xs n a)).
  + apply (Sets_indexed_union_included I (fun n => xs n a)).
    auto.
  + apply (Sets_indexed_intersect_included I (fun n => xs n a)).
  + apply (Sets_included_indexed_intersect I (fun n => xs n a)).
    auto.
  + intros a.
    apply Sets_included_derives_aux; auto.
  + intros ? ? ? ? ? a.
    eapply Sets_derives_aux_trans; auto.
  + intros a.
    apply Sets_Qaux_right.
    auto.
  + intros a.
    apply (Sets_Paux_left T0 t0 (fun t => inj t a)).
  + intros a.
    simpl.
    unfold Sets.lift_inj_aux.
    unfold Sets.lift_Paux.
    exact (Sets_Paux_right T0 t0 (fun t => inj t a)).
  + intros a.
    apply Sets_Qaux_left_extract.
    intros; apply H; auto.
  + intros a.
    apply Sets_Qaux_right_extract.
    intros; apply H; auto.
  + intros a.
    apply Sets_Qaux_implies_left; auto.
  + intros a.
    apply Sets_conj_aux_right; auto.
  + apply Sets_exists_aux_left.
    intros; apply H; auto.
  + apply (Sets_exists_aux_right _ t0).
    apply H.
  + apply (Sets_forall_aux_left _ t0).
    apply H.
  + apply Sets_forall_aux_right.
    intros; apply H; auto.
Qed.

#[export] Instance Sets_prop_inj_mono {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) (@Sets.prop_inj T _).
Proof.
  unfold Proper, respectful, Sets.test1.
  unfold_SETS_tac.
  intros.
  apply Sets_prop_inj_included_prop_inj.
  auto.
Qed.

#[export] Instance Sets_prop_inj_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) (@Sets.prop_inj T _).
Proof.
  unfold Proper, respectful.
  intros.
  apply Sets_equiv_Sets_included.
  rewrite Sets_equiv_Sets_included in H.
  split; apply Sets_prop_inj_mono; tauto.
Qed.

#[export] Instance Sets_test1_mono {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) (@Sets.test1 S T _).
Proof.
  unfold Proper, respectful, Sets.test1.
  intros; intros ?.
  rewrite (H a).
  reflexivity.
Qed.

#[export] Instance Sets_test1_congr {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) (@Sets.test1 S T _).
Proof.
  unfold Proper, respectful, Sets.test1.
  intros; intros ?.
  rewrite (H a).
  reflexivity.
Qed.

#[export] Instance Sets_filter1_mono {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included ==> Sets.included) (@Sets.filter1 S T _).
Proof.
  unfold Proper, respectful.
  intros.
  rewrite !Sets_filter1_defn.
  rewrite H, H0.
  reflexivity.
Qed.

#[export] Instance Sets_filter1_congr {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv ==> Sets.equiv) (@Sets.filter1 S T _).
Proof.
  unfold Proper, respectful.
  intros.
  rewrite !Sets_filter1_defn.
  rewrite H, H0.
  reflexivity.
Qed.

#[export] Instance Sets_lift1_mono {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.included ==> Sets.included) (@Sets.lift1 S T _).
Proof.
  unfold Proper, respectful.
  intros.
  unfold Sets.lift1; intros ?.
  auto.
Qed.

#[export] Instance Sets_lift1_congr {S T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) (@Sets.lift1 S T _).
Proof.
  unfold Proper, respectful.
  intros.
  unfold Sets.lift1; intros ?.
  auto.
Qed.

#[export] Instance Sets_general_union_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) Sets.general_union.
Proof.
  intros.
  hnf; intros.
  rewrite Sets_equiv_Sets_included.
  split.
  + apply Sets_general_union_included; intros.
    apply Sets_included_general_union.
    rewrite (H _) in H0.
    tauto.
  + apply Sets_general_union_included; intros.
    apply Sets_included_general_union.
    rewrite (H _).
    tauto.
Qed.

#[export] Instance Sets_general_intersect_congr {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}: Proper (Sets.equiv ==> Sets.equiv) Sets.general_intersect.
Proof.
  intros.
  hnf; intros.
  rewrite Sets_equiv_Sets_included.
  split.
  + apply Sets_included_general_intersect; intros.
    apply Sets_general_intersect_included.
    rewrite (H _).
    tauto.
  + apply Sets_included_general_intersect; intros.
    apply Sets_general_intersect_included.
    rewrite (H _) in H0.
    tauto.
Qed.

Lemma Sets_intersect_union_distr_r {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y z,
    Sets.equiv
      (Sets.intersect (Sets.union x y) z)
      (Sets.union (Sets.intersect x z) (Sets.intersect y z)).
Proof.
  intros.
  apply Sets_equiv_Sets_included.
  split.
  + apply Sets_union_included_strong2.
    - apply Sets_included_union1.
    - apply Sets_included_union2.
  + apply Sets_union_included.
    - apply Sets_intersect_mono; [| reflexivity].
      apply Sets_included_union1.
    - apply Sets_intersect_mono; [| reflexivity].
      apply Sets_included_union2.
Qed.

Lemma Sets_intersect_union_distr_l {T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x y z,
    Sets.equiv
      (Sets.intersect x (Sets.union y z))
      (Sets.union (Sets.intersect x y) (Sets.intersect x z)).
Proof.
  intros.
  apply Sets_equiv_Sets_included.
  split.
  + apply Sets_union_included_strong1.
    - apply Sets_included_union1.
    - apply Sets_included_union2.
  + apply Sets_union_included.
    - apply Sets_intersect_mono; [reflexivity |].
      apply Sets_included_union1.
    - apply Sets_intersect_mono; [reflexivity |].
      apply Sets_included_union2.
Qed.

Lemma Sets_intersect_indexed_union_distr_r {I T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall (xs: I -> T) y,
    Sets.equiv
      (Sets.intersect (Sets.indexed_union xs) y)
      (Sets.indexed_union (fun i => Sets.intersect (xs i) y)).
Proof.
  intros.
  apply Sets_equiv_Sets_included.
  split.
  + apply Sets_indexed_union_included_strong2.
    intros.
    rewrite <- Sets_included_indexed_union.
    reflexivity.
  + apply Sets_indexed_union_included.
    intros.
    apply Sets_intersect_mono; [| reflexivity].
    apply Sets_included_indexed_union.
Qed.

Lemma Sets_intersect_indexed_union_distr_l {I T} {_SETS: Sets.SETS T} {_SETS_Properties: SETS_Properties T}:
  forall x (ys: I -> T),
    Sets.equiv
      (Sets.intersect x (Sets.indexed_union ys))
      (Sets.indexed_union (fun i => Sets.intersect x (ys i))).
Proof.
  intros.
  apply Sets_equiv_Sets_included.
  split.
  + apply Sets_indexed_union_included_strong1.
    intros.
    rewrite <- Sets_included_indexed_union.
    reflexivity.
  + apply Sets_indexed_union_included.
    intros.
    apply Sets_intersect_mono; [reflexivity |].
    apply Sets_included_indexed_union.
Qed.

#[export] Instance Sets_complement_equiv A:
  Proper (Sets.equiv ==> Sets.equiv) (@Sets.complement A).
Proof.
  unfold_SETS_tac.
  unfold Sets.complement.
  intros S1 S2 ?.
  intros.
  rewrite H.
  reflexivity.
Qed.

Lemma Sets_complement_complement: forall A (S: A -> Prop),
  Sets.equiv (Sets.complement (Sets.complement S)) S.
Proof.
  intros.
  unfold Sets.complement; unfold_SETS_tac.
  intros.
  tauto.
Qed.

Ltac solve_mono tac :=
  match goal with
  | |- Proper _ _ =>
         cbv beta delta [Proper respectful flip]; intros; solve_mono tac
  | |- Sets.included ?A ?A =>
         reflexivity
  | |- Sets.included (Sets.union _ _) (Sets.union _ _) =>
         refine (Sets_union_mono _ _ _ _ _ _); solve_mono tac
  | |- Sets.included (Sets.intersect _ _) (Sets.intersect _ _) =>
         refine (Sets_intersect_mono _ _ _ _ _ _); solve_mono tac
  | |- Sets.included (Sets.prop_inj _) (Sets.prop_inj _) =>
         refine (Sets_prop_inj_mono _ _ _); solve_mono tac
  | |- Sets.included (Sets.test1 _) (Sets.test1 _) =>
         refine (Sets_test1_mono _ _ _); solve_mono tac
  | |- Sets.included (Sets.lift1 _) (Sets.lift1 _) =>
         refine (Sets_lift1_mono _ _ _); solve_mono tac
  | |- Sets.included (Sets.filter1 _ _) (Sets.filter1 _ _) =>
         refine (Sets_filter1_mono _ _ _ _ _ _); solve_mono tac
  | |- _ => first [assumption | tac]
  end.

Declare Scope sets_scope.
Delimit Scope sets_scope with sets.
Local Open Scope sets_scope.

Notation "[ ]":= Sets.empty (format "[ ]"): sets_scope.
Notation "∅":= Sets.empty (at level 5, no associativity): sets_scope.
Notation "[ x ]":= (Sets.singleton x) : sets_scope.
Notation "x ∩ y" := (Sets.intersect x y)(at level 11, left associativity): sets_scope.
Notation "x ∪ y" := (Sets.union x y)(at level 12, left associativity): sets_scope.
Notation "⋃ x" := (Sets.omega_union x)(at level 10, no associativity): sets_scope.
Notation "⋂ x" := (Sets.omega_intersect x)(at level 10, no associativity): sets_scope.
Notation "x == y" := (Sets.equiv x y) (at level 70, no associativity): sets_scope.
Notation "x ∈ y" := (Sets.In x y) (at level 70, no associativity): sets_scope.
Notation "x ⊆ y" := (Sets.included x y) (at level 70, no associativity): sets_scope.

Ltac sets_unfold := unfold Sets.In, Sets.singleton; unfold_SETS_tac.