From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C X1 X2 X3 D E F : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A E /\ (wd_ A F /\ (wd_ B D /\ (wd_ B F /\ (wd_ C D /\ (wd_ C E /\ (wd_ A X3 /\ (wd_ B X2 /\ (wd_ C X1 /\ (col_ D B X2 /\ (col_ D C X1 /\ (col_ E A X3 /\ (col_ E C X1 /\ (col_ F A X3 /\ col_ F B X2))))))))))))))))) -> col_ C D E)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.ALV1.CwF_SplitTypeCat_Defs.
Require Import TypeTheory.ALV1.CwF_SplitTypeCat_Maps.
Require Import TypeTheory.ALV1.CwF_SplitTypeCat_Equivalence.

Notation "'pr1121' x" := (pr1(pr1(pr2(pr1(x))))) (at level 30).
Notation "'pr2121' x" := (pr2(pr1(pr2(pr1(x))))) (at level 30).
Notation "'pr1111' x" := (pr1(pr1(pr1(pr1(x))))) (at level 30).
Notation "'pr2111' x" := (pr2(pr1(pr1(pr1(x))))) (at level 30).
Notation "'pr1122' x" := (pr1(pr1(pr2(pr2(x))))) (at level 30).
Notation "'pr2122' x" := (pr2(pr1(pr2(pr2(x))))) (at level 30).

Definition splTCwF_structure (C : category) : UU
:= ∑ (O : obj_ext_structure C) (TQ : term_fun_structure C O × qq_morphism_structure O),
 iscompatible_term_qq (pr1 TQ) (pr2 TQ).
Definition splTCwF : UU := ∑ C : category, splTCwF_structure C .

Section Equiv.
Context (C : category).
Definition Term_first : UU := ∑ O : obj_ext_structure C, T1 O.
Definition qq_first : UU := ∑ O : obj_ext_structure C, T2 O.

Lemma term_first_equiv : Term_first ≃ splTCwF_structure C.
Proof.
    use tpair.
    - intro a; exact (pr1 a,,((pr12 a,,pr122 a),,pr222 a)).
    - use gradth.
      -- intro a; exact (pr1 a,,(pr112 a,,(pr212 a,,pr22 a))).
      -- reflexivity.
      -- reflexivity.
Qed.

Lemma qq_first_equiv : qq_first ≃ splTCwF_structure C.
Proof.
    use tpair.
    - intro a; exact (pr1 a,,((pr122 a,,pr12 a),,pr222 a)).
    - use gradth.
      -- intro a; exact (pr1 a,,(pr212 a,,(pr112 a,,pr22 a))).
      -- reflexivity.
      -- reflexivity.
Qed.

End Equiv.

Section Coercion.

Coercion splTCwF_cat (C : splTCwF) : category := pr1 C.
Coercion structure_of_splTCwF (C : splTCwF) : splTCwF_structure C := pr2 C.
Coercion object_structure_of_splTCwF (C : splTCwF) : obj_ext_structure C := pr12 C.
Coercion term_structure_of_splTCwF (C : splTCwF) : term_fun_structure C C := pr1122 C.
Coercion qq_structure_of_splTCwF (C : splTCwF) : qq_morphism_structure C := pr2122 C.

End Coercion.

Section splTCwF.
Context {C : splTCwF}.

Section access.

Definition Ty : functor _ _ := TY C.
Definition reind_ty {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) := #Ty f A.
Notation "A ⌊ f ⌋" := (reind_ty A f) (at level 30, only parsing).
Definition ext Γ (A : Ty Γ : hSet) : C := comp_ext C Γ A.
Notation "Γ ¤ A" := (ext Γ A) (at level 30, only parsing).
Definition pi {Γ} (A : Ty Γ : hSet) : C⟦Γ¤A,Γ⟧ := π A .
Definition Tm : functor _ _ := TM C.
Definition p : nat_trans Tm Ty := pp C.
Definition tm {Γ} (A : Ty Γ : hSet) := ∑ a : Tm Γ : hSet, p _ a = A .
Coercion pr1_tm {Γ} {A : Ty Γ : hSet} (a : tm A) : Tm Γ : hSet := pr1 a.
Coercion pr2_tm {Γ} {A : Ty Γ : hSet} (a : tm A) : p _ a = A := pr2 a.
Lemma ppComp1 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A) :
  p _ (# Tm f a ) = # Ty f A.
Proof.
  apply pathsinv0, (pathscomp0(!(maponpaths (# Ty f) (pr2 a)))).
  apply pathsinv0, (toforallpaths _ _ _ (pr2 p _ _ _) a).
Qed.
Definition reind_tm {Γ : C} {A : Ty Γ : hSet} {Γ'} (f : C⟦Γ',Γ⟧) (a : tm A)
: tm (A ⌊f⌋) := #Tm f a,, ppComp1 f a .
Notation "a ⌈ f ⌉" := (reind_tm f a) (at level 30, only parsing).
Definition var' {Γ} (A : Ty Γ : hSet) : Tm (Γ¤A) : hSet := te C A.
Definition var_commut {Γ} (A : Ty Γ : hSet) : p _ (var' A) = A ⌊pi A⌋:= pp_te C A.
Definition var {Γ} (A : Ty Γ : hSet) : tm (A⌊pi A⌋) := (var' A,, var_commut A).

Definition Yo_var_commut {Γ} (A : Ty Γ : hSet) : #Yo (pi A) ;; yy A = yy(var A) ;; p
:= term_fun_str_square_comm (var A).
Definition term_pullback {Γ} (A : Ty Γ : hSet)
: isPullback _ _ _ _ (Yo_var_commut A)
:= isPullback_Q_pp C A.

Definition q {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : C⟦Δ¤(A⌊f⌋),Γ¤A⟧ := qq C f A.
Definition q_eq {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : pi _ ;; f = q A f ;; pi _ := !(qq_π C f A).
Definition q_pullback {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : isPullback _ _ _ _ (q_eq A f) := qq_π_Pb C f A.
Definition compatibility_splTCwF {Γ Δ : C} (A : Ty Γ : hSet) (f : C⟦Δ, Γ⟧) : # Tm (q A f) (var A) = var (A⌊f⌋) := !(pr222 C Γ Δ A f).

End access.

Notation "A ⌊ f ⌋" := (reind_ty A f) (at level 30, only parsing).
Notation "Γ ¤ A" := (ext Γ A) (at level 30, only parsing).
Notation "a ⌈ f ⌉" := (reind_tm f a) (at level 30, only parsing).

Section Yoneda.

(** * Few usefull lemma on yoneda **)

Lemma yonedainv {A B : C} (f : C⟦A,B⟧) : Yo^-1 (#Yo f) = f.
Proof.
  apply id_left.
Qed.

Lemma transportyo {A B : C} {f g : C⟦A,B⟧} (e : #Yo f = #Yo g) : f = g.
Proof.
  apply (pathscomp0 (!(yonedainv f))), pathsinv0
  ,(pathscomp0 (!(yonedainv g))), (!(maponpaths Yo^-1 e)).
Qed.

Lemma yonedacarac {Γ Δ : C} (f  : _ ⟦Yo Γ,Yo Δ⟧)
: # Yo ((f :nat_trans _ _) Γ (identity Γ)) = f.
Proof.
  assert (H : (# Yo ((f : nat_trans _ _) Γ (identity Γ)) : nat_trans _ _) Γ (identity Γ)
               = (f : nat_trans _ _) Γ (identity Γ)) by apply (id_left _).
  assert (Map1 : (f : nat_trans _ _) Γ (identity Γ) = yoneda_map_1 C (pr21 C) Γ (Yo(Δ)) f)
  by reflexivity.
  assert (Map2 : # Yo ((f : nat_trans _ _) Γ (identity Γ)) = yoneda_map_2 C (pr21 C) Γ (Yo(Δ))
         ((f : nat_trans _ _) Γ (identity Γ))).
  -  unfold yoneda_map_2; cbn; unfold yoneda_morphisms; unfold yoneda_morphisms_data; cbn.
     assert (nattrans : is_nat_trans_yoneda_morphisms_data C _ Γ Δ
         ((f :nat_trans _ _) Γ (identity Γ))
          = yoneda_map_2_ax C (pr21 C) Γ (yoneda_objects C _ Δ)
          ((f : nat_trans _ _) Γ (identity Γ))).
     --  assert (prop : isaprop(is_nat_trans (yoneda_objects C _ Γ)
         (yoneda_objects C (homset_property C) Δ)
         (yoneda_morphisms_data C _ Γ Δ
         ((f : nat_trans _ _) Γ (identity Γ))))) by (apply isaprop_is_nat_trans;exact (pr2 hset_category));
        exact (pr1 (prop _ _)).
     --  apply pair_path_in2; apply nattrans.
  -  rewrite Map2; rewrite Map1; apply yoneda_map_1_2.
Qed.

Lemma invyoneda {Γ Δ : C} (f  : _ ⟦Yo Γ,Yo Δ⟧) : #Yo (Yo^-1 f) = f.
Proof.
  apply yonedacarac.
Qed.

Lemma invyonedacarac {Γ Δ : C} (f  : _ ⟦Yo Γ,Yo Δ⟧) : (Yo^-1 f) = ((f :nat_trans _ _) Γ (identity Γ)).
Proof.
rewrite (!(yonedacarac _)). rewrite yonedainv ,yonedacarac. reflexivity.
Qed.

Lemma yyidentity {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
: B = (@yy (pr1 C) (pr21 C) Ty (Γ¤A) B : nat_trans _ _) (Γ¤A) (identity (Γ¤A)).
Proof.
  apply pathsinv0; eapply pathscomp0.
  -  apply (toforallpaths _ (# Ty _) _ (functor_id Ty (Γ¤A))).
  -  reflexivity.
Qed.

Lemma q_eq_yoneda {Γ Δ} (A : Ty Γ : hSet) (f : C^op⟦Γ,Δ⟧) : #Yo(pi _) ;; #Yo f = #Yo (q A f) ;; #Yo (pi _).
Proof.
    rewrite (!(pr22 Yo _ _ _ (q A f) _)),(!(pr22 Yo _ _ _ _ f)).
    rewrite q_eq.
    reflexivity.
Qed.

End Yoneda.

Section Ty_Tm_lemmas.

Lemma Ty_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Ty Γ'' : hSet)
: A ⌊f;;g⌋ =  (A ⌊ g ⌋) ⌊f⌋.
Proof.
  exact (!((toforallpaths _ _ _ (!(pr22 Ty _ _ _  g f))) A)).
Qed.

Lemma Tm_composition {Γ Γ' Γ'' : C} (f : C⟦Γ,Γ'⟧) (g : C⟦Γ',Γ''⟧) (A : Tm Γ'' : hSet)
: #Tm (f;;g) A = #Tm f (#Tm g A).
Proof.
  exact (!((toforallpaths _ _ _ (!(pr22 Tm _ _ _  g f))) A)).
Qed.

Lemma Ty_identity {Γ : C} (A : Ty Γ : hSet) : A = A ⌊identity Γ⌋ .
Proof.
  assert (eqA : A = (identity (pr1 Ty Γ) A)) by auto.
  rewrite eqA.
  apply (!((toforallpaths _ _ _ (pr12 Ty _ )) A)).
Qed.

Lemma compose_ty {Γ Δ Η : C} (A : Ty Γ : hSet) (f : C^op ⟦Γ,Δ⟧) (g : C^op ⟦Δ,Η⟧) : A ⌊f⌋ ⌊g⌋ = A ⌊f;;g⌋.
Proof.
unfold reind_ty.
assert (eqf : # Ty f = # (pr1 Ty) f) by auto; rewrite eqf.
assert (eqg : # Ty g = # (pr1 Ty) g) by auto; rewrite eqg.
assert (eqfg : # Ty (f;;g) = # (pr1 Ty) (f;;g)) by auto; rewrite eqfg.
rewrite (pr22 Ty _ _ _  f g).
reflexivity.
Qed.

End Ty_Tm_lemmas.

Section term_subtitution.

Lemma Subproof_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: identity (Yo Γ) ;; yy A = yy a ;;p.
Proof.
  apply pathsinv0, (pathscomp0(yy_comp_nat_trans Tm Ty p Γ a)) ,pathsinv0,
  (pathscomp0(id_left _ )), ((maponpaths yy) (!(pr2 a))).
Qed.

Definition γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : (preShv C)⟦Yo Γ,Yo (Γ¤A)⟧
:= pr11((term_pullback A) (Yo Γ) (identity _) (yy a) (Subproof_γ a)).

Lemma  γ_pull {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: γ a ;; yy (var A) = yy a.
Proof.
  exact (pr221((term_pullback _) (Yo _) (identity _) (yy _) (Subproof_γ _))).
Qed.

Lemma pull_γ {Γ : C} {A : Ty Γ : hSet} (a : tm A) : γ a ;; #Yo (pi A) = identity _.
Proof.
  apply pathsinv0, (pathscomp0(!(pr121 (term_pullback _
        (Yo Γ) (identity (Yo Γ)) (yy a)
        (Subproof_γ a))))); auto.
Qed.

Lemma γ_pi {Γ} {A : Ty Γ: hSet} (a : tm A) : Yo^-1 (γ a) ;; pi A = identity _.
Proof.
  assert (Yoeq : #Yo(Yo^-1 (γ a) ;; pi A) = #Yo(identity Γ)).
  -  apply (pathscomp0 (pr22 Yo _ _ _  _ _ )).
     apply pathsinv0 , (pathscomp0 (pr12 Yo _)).
     assert (simplman : identity (pr1 (yoneda C (homset_property C)) Γ)
     = identity (Yo Γ)) by auto.
     apply (pathscomp0 simplman).
     rewrite (!(pull_γ a)).
     apply cancel_postcomposition.
     assert (simplman2 : # (pr1 (yoneda C (homset_property C))) (Yo^-1 (γ a))
     = #Yo (Yo^-1 (γ a))) by auto.
     apply pathsinv0, (pathscomp0 simplman2), invyoneda.
  -  apply (maponpaths (Yo^-1) ) in Yoeq.
     rewrite yonedainv, yonedainv in Yoeq.
     exact Yoeq.
Qed.
Lemma γNat {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) (a : tm A)
: (f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ) =
  (γ (a ⌈f⌉) ;; #Yo (q A f) : nat_trans _ _) Δ (identity Δ).
Proof.
  assert (Yoγ : #Yo ((f : C⟦Δ,Γ⟧) ;; (γ a : nat_trans _ _) Γ (identity Γ)) =
  #Yo((γ (a ⌈f⌉) : nat_trans _ _) Δ (identity Δ) ;; q A f)).
  -  do 2 (rewrite (pr22 (yoneda C (pr21 C)) _ _ _); rewrite yonedacarac).
     refine (MorphismsIntoPullbackEqual (term_pullback A)
     (#Yo f ;; γ a) (γ (a ⌈f⌉) ;; #Yo (q A f)) _ _).
     --  rewrite <- assoc.
         eapply pathscomp0.
         *  rewrite (cancel_precomposition _ _ _ _ _ _ _
            (pr121((term_pullback _) (Yo Γ) (identity (Yo Γ)) (yy(a)) (Subproof_γ a )))).
            apply id_right.
         *  rewrite <- assoc.
            apply pathsinv0.
            eapply pathscomp0.
            **  rewrite (!(pr22 Yo _ _ _ (q A f) _)).
                rewrite (!(q_eq _ _)).
                rewrite (pr22 Yo _ _ _ _ f).
                rewrite assoc.
                rewrite  (cancel_postcomposition _ _ _
                (pr121 ((term_pullback _) (Yo Δ) (identity (Yo Δ))
                (yy(#Tm f a)) (Subproof_γ (a ⌈f⌉) )))).
                apply (pr1 (pr121 (preShv C)) _ (Yo Γ) (#Yo f)).
            **  reflexivity.
    --  rewrite <- assoc.
        apply (pathscomp0  (cancel_precomposition _ _ _ _ _ _ _
        (pr221((term_pullback _) (Yo Γ) (identity (Yo Γ)) (yy a) (Subproof_γ a ))))).
        rewrite <- assoc.
        rewrite (!(yy_natural _ _ _ _ (q A f))).
        rewrite compatibility_splTCwF.
        rewrite γ_pull.
        exact (!(yy_natural _ _ a _ f)).
  -  apply (transportyo Yoγ).
Qed.

Lemma γPullback1 {Γ : C} (A : Ty Γ : hSet)
: γ (var A) ;; #Yo (q A (pi A)) ;; yy(var A) = identity _;; yy (var A).
Proof.
  rewrite id_left.
  assert (γ (var A) ;; yy (var (A ⌊pi A⌋)) = yy(var A)) by apply (γ_pull (var A)).
  rewrite <- assoc, <- X.
  refine (cancel_precomposition _ _ _ _ _ _ _ _).
  rewrite X.
  rewrite (!(yy_natural _ _ (var A) _ _)).
  rewrite compatibility_splTCwF.
  reflexivity.
Qed.

Lemma  γPullback2 {Γ : C} (A : Ty Γ : hSet)
: γ (var A) ;; #Yo (q A (pi A)) ;; #Yo (pi A) = identity _;;(#Yo (pi A)).
Proof.
  rewrite <- assoc.
  apply (pathscomp0 (!(cancel_precomposition _ _ _ _ _ _ (γ (var A)) (q_eq_yoneda _ _)))).
  rewrite assoc.
  apply (pathscomp0 (cancel_postcomposition _ _ _ (pull_γ _ ))).
  reflexivity.
Qed.

(** term wiew as sections*)
Definition tm_sec {Γ : C} (A : Ty Γ : hSet) := ∑ a : C⟦Γ,Γ¤A⟧, a ;; pi A = identity _ .

Coercion tm_sec_pr1 {Γ: C} (A : Ty Γ : hSet) : tm_sec A -> C⟦Γ,Γ¤A⟧ := pr1.

Definition tm_sec_property {Γ : C} {A : Ty Γ : hSet} (a : tm_sec A)
: a ;; pi A = identity _
:= pr2 a.

Section tm_equiv.
(**equivalence between the possible definitions of term*)
Definition tm_map_1  {Γ: C} (A : Ty Γ : hSet) : tm A -> tm_sec A.
Proof.
  intro a ; exact (Yo^-1 (γ a),,γ_pi a).
Defined.

Definition tm_map_2  {Γ: C} (A : Ty Γ : hSet) : tm_sec A -> tm A.
Proof.
  intros [a  pa]; use tpair.
  -  exact (invmap (yy) (#Yo a;; yy(var A))).
  -  abstract (set (a' := invmap (yy) (#Yo a;; yy(var A))); simpl;
     assert (eqA : @yy _ (pr21 C) _ _ A = yy a' ;; p);
     [ apply (maponpaths (#Yo )) in pa;
        unfold a';
        rewrite homotweqinvweq;
        rewrite <- assoc;
        assert ( imp : #Yo (pi A);; yy A = yy(var A);;p)
        by exact (Yo_var_commut _);
     apply (cancel_precomposition _ _ _ _ _ _ (#Yo a)) in imp;
     rewrite assoc in imp;
     assert (simplman : # Yo (a ;; pi A) =
     # (pr1 Yo) (a ;; pi A)) by auto;
     rewrite simplman in pa;
     rewrite (pr22 Yo _ _ _ a (pi A)) in pa;
     assert (simplman2 : # Yo a =
     # (pr1 Yo) a ) by auto;
     rewrite simplman2 in imp;
     assert (simplman3 : # Yo (pi A) =
     # (pr1 Yo) (pi A) ) by auto;
     rewrite simplman3 in imp;
     apply (cancel_postcomposition _ _ (yy A)) in pa;
     assert (lem : #Yo(identity _);; yy A = # Yo a ;; (yy (var A) ;; p));
      [ apply (pathscomp0 (!pa));
        exact imp
      | apply (pathscomp0 (!(@id_left (preShv C) _ _ (yy A))));
        assert (simplman4 : identity _ ;; yy A = #Yo(identity _);; yy A);
        [ assert (simplman5 : identity (Yo Γ) = identity ((pr1 Yo) Γ)) by auto;
           apply (cancel_postcomposition _ _ (yy A)) in simplman5;
           apply (pathscomp0 simplman5);
          apply cancel_postcomposition;
          exact (!(pr12 Yo _))
          | apply (pathscomp0 simplman4);
             exact lem]]
  | assert (eqa' : @yy _ (pr21 C) _ _ (p _ a') = yy a';;p)
     by (rewrite yy_comp_nat_trans; reflexivity);
     rewrite <- eqa' in eqA;
     apply (maponpaths (invmap yy)) in eqA;
     do 2 rewrite homotinvweqweq in eqA;
     exact (!eqA)]).
Defined.

Lemma tm_map_12 {Γ: C} (A : Ty Γ : hSet) : ∏ a : tm A, tm_map_2 A (tm_map_1 A a) = a.
Proof.
intro a;
apply subtypePath.
- intro x; exact (setproperty (Ty Γ : hSet) _ _).
- assert (eqa : invmap yy (# (yoneda C (homset_property C)) (Yo^-1 (γ a)) ;; yy (var A)) = a)
   by (rewrite invyoneda,γ_pull, homotinvweqweq; reflexivity);  exact eqa.
Qed.

Lemma tm_map_21 {Γ: C} (A : Ty Γ : hSet) : ∏ a : tm_sec A, tm_map_1 A (tm_map_2 A a) = a.
Proof.
intro a;
apply subtypePath.
- intro x; apply (pr21 C).
- assert (eqa : (Yo^-1 (γ (invmap yy (# (yoneda C (homset_property C)) (pr1 a) ;; yy (var A)),,
    tm_map_2_subproof Γ A (pr1 a) (pr2 a)))) = a).
  rewrite <- (yonedainv a) ; apply maponpaths.
  refine (MorphismsIntoPullbackEqual _ _ _ _ _).
  -- exact (pr22(make_Pullback (yy A) p (yoneda C (homset_property C) (Γ¤A))
        (# (yoneda C (homset_property C)) (pi A)) (yy (var A))
        (Yo_var_commut _) (term_pullback A))).
  --  assert (eqpiA : pr121 (make_Pullback (yy A) p
      (yoneda C (homset_property C) (Γ¤A))
      (# (yoneda C (homset_property C))
      (pi A)) (yy (var A)) (Yo_var_commut _)
      (term_pullback A)) = #Yo(pi A)) by auto.
      rewrite eqpiA.
      apply (pathscomp0 (pull_γ _)).
      assert (simplman2 : # Yo a = # (pr1 Yo) a ) by auto;
      rewrite simplman2;
      assert (simplman3 : # Yo (pi A) = # (pr1 Yo) (pi A) ) by auto;
      rewrite simplman3;
      assert (simplman4 : identity(Yo Γ) = identity((pr1 Yo) Γ)) by auto;
      rewrite simplman4.
      apply (pathscomp0 (!(pr12 Yo _))).
      apply pathsinv0.
      apply (pathscomp0  (!(pr22 Yo _ _ _ a (pi A)))).
      apply maponpaths. exact (pr2 a).
  --  assert (eqteA : pr221 (make_Pullback (yy A) p
      (yoneda C (homset_property C)
      (Γ¤A)) (# (yoneda C (homset_property C))
      (pi A)) (yy (var A)) (Yo_var_commut _)
      (term_pullback A)) = yy(var A)) by auto.
      rewrite eqteA.
      rewrite γ_pull.
      apply homotweqinvweq.
  -- exact eqa.
Qed.

Definition tm_equiv {Γ: C} {A : Ty Γ : hSet} : tm A ≃ tm_sec A :=
  (tm_map_1 _,,
  gradth (tm_map_1 _) (tm_map_2 _) (tm_map_12 _) (tm_map_21 _)).

Coercion tm_equiv_coer {Γ: C} {A : Ty Γ : hSet} (a : tm A) : tm_sec A := tm_equiv a.

End tm_equiv.

End term_subtitution.

Section splTCwF_lemmas.

Section comp_ext.

Definition comp_ext_compare
{Γ : C} {A A' : Ty Γ : hSet} (e : A = A')
: iso (Γ ¤ A) (Γ ¤ A')
:= idtoiso (maponpaths (ext Γ) e).

Lemma comp_ext_compare_id
{Γ : C} (A : Ty Γ : hSet)
: (comp_ext_compare (idpath A) : _ --> _) = identity (Γ¤A).
Proof.
  apply idpath.
Qed.

Lemma comp_ext_compare_id_general
{Γ : C} {A : Ty Γ : hSet} (e : A = A)
: (comp_ext_compare e : _ --> _) = identity (Γ ¤ A).
Proof.
  apply @pathscomp0 with (comp_ext_compare (idpath _)).
  - apply maponpaths, maponpaths, (setproperty (Ty Γ : hSet)).
  - apply idpath.
Qed.

Lemma comp_ext_compare_comp
{Γ : C} {A A' A'' : Ty Γ : hSet} (e : A = A') (e' : A' = A'')
: (comp_ext_compare (e @ e') : _ --> _)
= comp_ext_compare e ;; comp_ext_compare e'.
Proof.
  apply pathsinv0.
  etrans. { apply idtoiso_concat_pr. }
  unfold comp_ext_compare. apply maponpaths, maponpaths.
  apply pathsinv0, maponpathscomp0.
Qed.

Lemma comp_ext_compare_irrelevant
{Γ : C} {A A' : Ty Γ : hSet} (e e' : A = A')
: (comp_ext_compare e : _ --> _) = comp_ext_compare e'.
Proof.
  apply maponpaths, maponpaths,(setproperty (Ty Γ : hSet)).
Qed.

End comp_ext.

Lemma q_typeeq {Γ:C}
{A A' : Ty Γ : hSet} (e : A = A')
{Δ : C} (f : C^op ⟦Γ,Δ⟧)
: comp_ext_compare (maponpaths (fun X => X ⌊f⌋) e) ;; q A' f
= q A f ;; comp_ext_compare e.
Proof.
  destruct e; cbn.
  rewrite id_right; apply id_left.
Qed.

Definition q_mapeq
{Γ Δ} {f f' : C^op ⟦Γ,Δ⟧} (e : f = f') (A : Ty Γ : hSet)
: comp_ext_compare (maponpaths _ e)
  ;; q A f'
= q A f.
Proof.
  destruct e; apply id_left.
Qed.

Definition q_q
  : ∏ Γ  Γ' Γ''  (f : C^op ⟦Γ,Γ'⟧)  (g : C^op ⟦Γ',Γ''⟧) (A : Ty Γ : hSet),
            q A (f;;g)
            =  idtoiso (maponpaths (fun b => Γ''¤b) (!compose_ty  A f g))
               ;; q (A ⌊f⌋) g
               ;; q A f.
Proof.
  intros.
  apply (pathscomp0 ((pr22 (qq_structure_of_splTCwF C)) _ _ _ _ _ _)).
  do 2 apply cancel_postcomposition.
  cbn.
  assert (eq :
  (toforallpaths (λ _ : Ty Γ : hSet, Ty Γ'' : hSet) (# Ty (f;;g))
        (λ x : Ty Γ : hSet, # Ty g (# Ty f x)) (functor_comp Ty f g) A) =
        (! compose_ty A f g)) by apply (setproperty (Ty _ : hSet)).
  assert (eq2 : maponpaths (λ b : Ty Γ'' : hSet, ext Γ'' b) (! compose_ty A f g) =
  maponpaths (λ A0 : Ty Γ'' : hSet, Γ''¤A0)
  (toforallpaths (λ _ : Ty Γ : hSet, Ty Γ'' : hSet) (# Ty (f;;g))
  (λ x : Ty Γ : hSet, # Ty g (# Ty f x)) (functor_comp Ty f g) A)) by (induction eq; reflexivity).
  apply pathsinv0.
  apply (maponpaths idtoiso) in eq2.
  eapply pathscomp0.
  exact (maponpaths pr1 eq2).
  reflexivity.
Qed.

Definition q_q'
: ∏ Γ (A : Ty Γ : hSet) Γ' (f : C^op ⟦Γ,Γ'⟧) Γ'' (g : C^op ⟦Γ',Γ''⟧),
  q (A ⌊f⌋) g ;; q A f
  = idtoiso (maponpaths (fun b => Γ''¤b) (compose_ty A f g))
    ;; q A (f;;g).
Proof.
intros. apply iso_inv_to_left, pathsinv0.
etrans. { apply q_q. }
repeat rewrite <- assoc; apply maponpaths_2.
etrans. 2: { apply comp_ext_compare_inv. }
apply comp_ext_compare_irrelevant.
Qed.

End splTCwF_lemmas.

Section tm_lemmas.

Definition tm_transportf {Γ} {A A' : Ty Γ : hSet} (e : A = A')
: tm A ≃ tm A'.
Proof.
  use weqbandf.
  -  exact (idweq (Tm Γ : hSet)).
  -  induction e; intro x; exact (idweq _).
Defined.

Definition tm_transportb {Γ} {A A' : Ty Γ : hSet} (e : A = A')
: tm A' ≃ tm A := invweq(tm_transportf e).

Lemma tm_transportf_idpath {Γ} {A : Ty Γ : hSet} (t : tm A)
: tm_transportf (idpath A) t = t.
Proof.
  reflexivity.
Qed.

Lemma tm_transportf_idpath_gen {Γ} {A : Ty Γ : hSet} (t : tm A) (e : A = A)
: tm_transportf e t = t.
Proof.
  assert (eqe : e = idpath A) by apply (setproperty (Ty Γ : hSet)).
  rewrite eqe.
  exact (tm_transportf_idpath _).
Qed.

Lemma tm_transportb_idpath {Γ} {A : Ty Γ : hSet} (t : tm A)
: tm_transportb (idpath A) t = t.
Proof.
  reflexivity.
Qed.

Lemma tm_transportbf {Γ} {A A' : Ty Γ : hSet} (e : A = A') : tm_transportb e = tm_transportf (!e).
Proof.
  induction e.
  refine (subtypePath isapropisweq _).
  apply (idpath _).
Qed.

Lemma reind_compose_tm
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
: a ⌈g ;; f⌉
= tm_transportb (Ty_composition _ _ _) (a ⌈f⌉ ⌈g⌉).
Proof.
  apply subtypePath.
  -  intro x; apply (setproperty (Ty Γ'' : hSet)).
  -  rewrite tm_transportbf; apply Tm_composition.
Qed.

Lemma maponpaths_2_reind_tm
{Γ Γ' : C} {f f' : C⟦Γ',Γ⟧} (e : f = f') {A : Ty Γ : hSet} (a : tm A)
: a ⌈f⌉ = tm_transportb (maponpaths (fun g => #Ty g A) e) (a ⌈f'⌉).
Proof.
  induction e.
  rewrite maponpaths_eq_idpath; [|apply idpath].
  now rewrite tm_transportb_idpath.
Qed.

Lemma tm_transportf_compose {Γ : C} {A A' A'' : Ty Γ : hSet} (e : A = A')
(e' : A' = A'') (a : tm A)
: tm_transportf (e @ e') a = tm_transportf e' (tm_transportf e a).
Proof.
  induction e; induction e'.
  reflexivity.
Qed.

Lemma tm_transportf_irrelevant {Γ} {A A' : Ty Γ : hSet} (e e' : A = A')
(t : tm A)
: tm_transportf e t = tm_transportf e' t.
Proof.
  apply (maponpaths (fun e => tm_transportf e t)).
  apply (setproperty (Ty Γ : hSet)).
Qed.

Lemma tm_transport_compose {Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) (A : Ty Γ : hSet) (a : tm A)
: tm_transportf ((Ty_composition g f A)) (a ⌈g;;f⌉) = a ⌈f⌉ ⌈g⌉.
Proof.
  rewrite reind_compose_tm.
  rewrite tm_transportbf.
  rewrite <- tm_transportf_compose ,pathsinv0l.
  reflexivity.
Qed.

Lemma tm_transportf_bind {Γ} {A A' A'': Ty Γ : hSet} {e : A' = A} {e' : A'' = A'}
{t} {t'} {t''} (ee : t = tm_transportf e t') (ee' : t' = tm_transportf e' t'')
: t = tm_transportf (e' @ e) t''.
Proof.
  etrans. 2: { apply pathsinv0, tm_transportf_compose. }
  etrans. { eassumption. }
  apply maponpaths; assumption.
Qed.
Definition tm_transportb_unfold
{Γ} {A A' : Ty Γ : hSet} (e : A = A') (a : tm A')
: (tm_transportb e a : _ --> _)
= a ;; comp_ext_compare (!e).
Proof.
  induction e.
  rewrite comp_ext_compare_id_general.
  rewrite tm_transportbf.
  rewrite tm_transportf_idpath_gen.
  apply (!(id_right _)).
Qed.

Definition tm_transportb_unfold_alter
{Γ} {A A' : Ty Γ : hSet} (e : A = A') (a : tm A')
: (tm_transportb e a : _ --> _) ;; comp_ext_compare (e)
= a .
Proof.
  rewrite tm_transportb_unfold, <- assoc, (!(comp_ext_compare_comp _ _)), comp_ext_compare_id_general, id_right.
  reflexivity.
Qed.

Lemma reind_compose_tm'
{Γ Γ' Γ'' : C} (f : C⟦Γ',Γ⟧) (g : C⟦Γ'',Γ'⟧) {A : Ty Γ : hSet} (a : tm A)
: tm_transportf (Ty_composition _ _ _) (a ⌈g;;f⌉) = a ⌈f⌉ ⌈g⌉.
Proof.
  rewrite reind_compose_tm. rewrite tm_transportbf.
  now rewrite <- tm_transportf_compose, pathsinv0l, tm_transportf_idpath.
Qed.

Lemma reind_id_tm {Γ : C}{A : Ty Γ : hSet} (a : tm A)
: a ⌈identity _⌉
= tm_transportb ((toforallpaths _ _ _ (pr12 Ty _ )) A) a.
Proof.
  apply subtypePath.
  -  intros x. apply (setproperty (Ty Γ : hSet)).
  -  apply ((toforallpaths _ _ _ (pr12 Tm _ )) a).
Qed.

Lemma reind_id_tm' {Γ : C} {A : Ty Γ : hSet}  (a : tm A) (b : tm A)
(e : A ⌊identity Γ⌋ = A ⌊b ;; pi A⌋)
: tm_transportf e (a ⌈identity _⌉)
= tm_transportf ((Ty_identity _) @ e) a.
Proof.
  apply subtypePath.
  -  intros x. apply (setproperty (Ty Γ : hSet)).
  -  apply ((toforallpaths _ _ _ (pr12 Tm _ )) a).
Qed.

Section term_subtitution_lemmas.

Definition γ_qq {Γ} {A : Ty Γ: hSet} {Γ'} (f : C⟦Γ',Γ⟧) (a : tm (A ⌊f⌋)) : C⟦Γ',Γ¤ A⟧ := (a ;; q A f).

Lemma γ_a  {Γ} {A : Ty Γ : hSet} (a : tm A) : #Yo a = γ a.
Proof.
  assert (eq : Yo^-1(γ a) = a) by auto.
  rewrite (!eq).
  apply invyoneda.
Qed.

Lemma Ty_γ_id {Γ : C} {A : Ty Γ : hSet} (a : tm A)
: A ⌊pi A⌋ ⌊a⌋ = A.
Proof.
  simple refine (!(Ty_composition _ _ _) @ _).
  apply (pathscomp0 ((toforallpaths  _ _ _ (maponpaths _ (γ_pi _)) )A)).
  apply ((toforallpaths _ _ _ (pr12 Ty _ )) A).
Qed.

Lemma var_subtitution {Γ} {A : Ty Γ : hSet} (a : tm A) : #Tm a (var A) = a.
Proof.
  assert (inter : @yy _ (pr21 C) _ _ (#Tm a (var A)) = yy a).
  -  assert (eqa : Yo^-1 (γ a) = a ) by auto.
     rewrite (!eqa), yy_natural, invyoneda.
     exact (pr221((term_pullback _) (Yo _) (identity _) (yy _) (Subproof_γ _))).
  -  apply (maponpaths (invmap yy) ) in inter.
     do 2 rewrite homotinvweqweq in inter.
     exact inter.
Qed.

Lemma reind_tm_q {Γ Δ} (f : C^op ⟦Γ,Δ⟧)
{A : Ty Γ : hSet} (a : tm A)
: a ⌈f⌉ ;; q A f = (f : C⟦Δ,Γ⟧) ;; a.
Proof.
  assert (eqYo : #Yo(a ⌈f⌉ ;; q A f) = #Yo((f : C⟦Δ,Γ⟧) ;; a)).
  -  simple refine (MorphismsIntoPullbackEqual
     (pr22(make_Pullback (yy A) p
     (yoneda C (pr21 C) (Γ¤A))
     (# (yoneda C (pr21 C)) (pi A))
     (yy (var A))
     (Yo_var_commut _)
     (term_pullback A)))
     (#Yo(a ⌈f⌉ ;; q A f)) (#Yo((f : C⟦Δ,Γ⟧) ;; a)) _ _).
     *  assert (triv : pr121
        (make_Pullback (yy A) p (yoneda C (pr21 C) (ext Γ A))
        (# (yoneda C (pr21 C)) (pi A)) (yy (var A)) (Yo_var_commut A)
        (term_pullback A)) = #Yo(pi A)) by auto.
        rewrite triv.
        rewrite (pr22 Yo _ _ _  _ a).
        rewrite (pr22 Yo _ _ _  _ (q A f)).
        do 2 rewrite <- assoc.
        rewrite (!(q_eq_yoneda _ _)).
        do 2 rewrite γ_a.
        rewrite assoc.
        do 2 rewrite pull_γ.
        rewrite id_left,id_right.
        reflexivity.
     *  assert (triv : pr221
        (make_Pullback (yy A) p (yoneda C (pr21 C) (ext Γ A))
        (# (yoneda C (pr21 C)) (pi A)) (yy (var A)) (Yo_var_commut A)
        (term_pullback A)) = @yy _ (pr21 C) _ _ (var A)) by auto.
        rewrite triv.
        rewrite (pr22 Yo _ _ _  _ a).
        rewrite (pr22 Yo _ _ _  _ (q A f)).
        do 2 rewrite <- assoc.
        assert (evidq : # (pr1 Yo) (q A f) = # Yo (q A f) ) by auto;
        rewrite evidq;
        assert (evida : # (pr1 Yo) a = # (@yoneda _ (pr21 C)) a ) by auto;
        rewrite evida.
        eapply pathscomp0.
        exact (cancel_precomposition _ _ _ _ _ _ _ (!(yy_natural _ _ (var A) _ (q A f)))).
        apply pathsinv0.
        eapply pathscomp0.
        exact (cancel_precomposition _ _ _ _ _ _ _ (!(yy_natural _ _ (var A) _ a))).
        rewrite compatibility_splTCwF.
        rewrite var_subtitution.
        assert (evidf : # (pr1 Yo) f = # Yo f) by auto;
        rewrite evidf;
        eapply pathscomp0.
        exact (!(yy_natural _ _ a _ f)).
        assert (evidfa : # (pr1 Yo) (a ⌈f⌉) = # Yo (a ⌈f⌉)) by auto;
        rewrite evidfa;
        apply pathsinv0.
        eapply pathscomp0.
        exact (!(yy_natural _ _ _ _ (a ⌈f⌉))).
        rewrite var_subtitution.
        reflexivity.
  - apply transportyo. exact eqYo.
Qed.

End term_subtitution_lemmas.

End tm_lemmas.

Section Familly_Of_Types.

Definition DepTypesType {Γ : C} {A : Ty Γ : hSet} (B : Ty(Γ¤A) : hSet)
(a : tm A)
: Ty Γ : hSet := ( γ a;;yy B : nat_trans _ _) Γ (identity Γ).

Lemma DepTypesType_eq {Γ : C} {A : Ty Γ : hSet} (B : Ty(Γ¤A) : hSet)
(a : tm A) : DepTypesType B a =  B ⌊a⌋.
Proof.
  reflexivity.
Qed.

Definition DepTypesElem_pr1 {Γ : C} {A : Ty Γ : hSet} {B : Ty(Γ¤A) : hSet}
(b : tm B) (a : tm A)
: Tm Γ : hSet := (γ a;;yy b : nat_trans _ _) Γ (identity Γ).

Lemma DepTypesComp {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ¤A) : hSet}
(b : tm B) (a : tm A)
: p Γ (DepTypesElem_pr1 b a) = DepTypesType B a.
Proof.
  apply pathsinv0,(pathscomp0(maponpaths _ (!(pr2 b)))),pathsinv0.
  apply (toforallpaths _ _ _ (pr2 p _ _ _) b).
Qed.

Definition DepTypesElems {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ¤A) : hSet}
(b : tm B) (a : tm A)
: tm (DepTypesType B a) := DepTypesElem_pr1 b a ,, DepTypesComp b a.

Lemma DepTypesElems_eq {Γ : C} { A : Ty Γ : hSet} {B : Ty(Γ¤A) : hSet}
(b : tm B) (a : tm A)
: DepTypesElems b a = b ⌈a⌉.
Proof.
  use subtypePath.
  -  intro x; apply (setproperty (Ty Γ : hSet)).
  - cbn.
    assert (eqγ : (yoneda_map_1 C (homset_property C) Γ
    (yoneda_objects C (homset_property C) (ext Γ A))
    (γ a)) = Yo^-1 (γ a)) by auto;
    rewrite eqγ;
    rewrite invyonedacarac.
    reflexivity.
Qed.

Lemma DepTypesNat {Γ Δ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤ A) : hSet)
(f : C^op ⟦Γ,Δ⟧) (a : tm A)
: #Ty f (DepTypesType B a) = DepTypesType (#Ty (q A f) B) (reind_tm f a).
Proof.
  unfold DepTypesType, reind_tm; rewrite yy_natural, assoc.
  assert (Fucn : (# (pr1 Ty) ((γ a :nat_trans _ _) Γ (identity Γ)) ;; # (pr1 Ty) f) B =
  # Ty f (# Ty ((γ a :nat_trans _ _) Γ (identity Γ)) B)) by auto.
  apply (pathscomp0 (!Fucn)),(pathscomp0(!((toforallpaths _ _ _
  ((pr22 Ty) _ _ _ ((γ a: nat_trans _ _) Γ (identity Γ) : C⟦Γ,Γ¤A⟧) f)) B))),
  (pathscomp0(toforallpaths _ _ _ (maponpaths (# Ty) (γNat f a)) B)).
  reflexivity.
Qed.

Lemma DepTypesNat_bis {Γ Δ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤ A) : hSet)
(f : C ⟦Δ,Γ⟧) (a : tm A)
: B ⌊a⌋ ⌊f⌋ = B ⌊q A f⌋ ⌊a ⌈f⌉⌋.
Proof.
  exact (DepTypesNat _ _ _).
Qed.

Lemma DepTypesEta {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
: DepTypesType (B ⌊q A (pi A)⌋) (var A) = B.
Proof.
  assert (Natu : @γ (Γ¤A) (A ⌊pi A⌋) (var A) ;; yy (B ⌊q A (pi A)⌋)
  = @γ (Γ¤A) (#Ty (pi A) A) (var A) ;; #Yo (q A (pi A)) ;;
  (@yy C (pr21 C) Ty (Γ¤A)) B).
  -  rewrite (cancel_precomposition _ _ _ _ (yy (B ⌊q A (pi A)⌋))
     (#Yo (q A (pi A));; yy B) _).
     *  rewrite assoc; reflexivity.
     *  unfold reind_ty; rewrite yy_natural; reflexivity.
  -  assert (Id: @γ (Γ¤A) (# Ty (@pi Γ A) A) (var A) ;; #Yo (q A (pi A))
     = identity _).
     *  refine (MorphismsIntoPullbackEqual
        (pr22(make_Pullback (yy A) p
        (yoneda C (homset_property C) (Γ¤A))
        (# (yoneda C (homset_property C)) (pi A))
        (yy (var A))
        (Yo_var_commut _)
        (term_pullback A)))
        (γ (var A) ;; #Yo (q A (pi A))) (identity _) (γPullback2 A) (γPullback1 A)).
     *  rewrite Id, (id_left _) in Natu.
        unfold DepTypesType.
        rewrite Natu; exact (!(yyidentity B)).
Qed.

Lemma DepTypesEta_bis {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
: B ⌊q A (pi A)⌋ ⌊var A⌋ = B.
Proof.
  exact (DepTypesEta _).
Qed.

Lemma DepTypesrewrite {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
(a b : tm A) (e : pr1 a = pr1 b)
: DepTypesType B a = DepTypesType B b.
Proof.
  destruct a as [a pa]; destruct b as [b pb].
  cbn in e; induction e.
  assert (ProofIrr : pa = pb) by apply (setproperty( Ty Γ : hSet)).
  rewrite ProofIrr.
  reflexivity.
Qed.

Lemma DepTypesrewrite_bis {Γ : C} {A : Ty Γ : hSet} (B : Ty (Γ¤A) : hSet)
(a b : tm A) (e : pr1 a = pr1 b)
: B ⌊a⌋ = B ⌊b⌋.
Proof.
  do 2 rewrite (!(DepTypesType_eq _ _)).
  exact (DepTypesrewrite _ _ _ e).
Qed.

End Familly_Of_Types.

Section Pi_structure.

Definition PiTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ¤A) : hSet), (Ty Γ : hSet).

Definition PiTypeNat (π : PiTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet),
  (π _ A B) ⌊f⌋  = π _ (A ⌊f⌋) (B ⌊q A f⌋).

Definition pi_form_struct : UU
:= ∑ pi : PiTypeFormer, PiTypeNat pi.

Definition pr1_PiFormer (π : pi_form_struct) : PiTypeFormer := pr1 π.
Coercion pr1_PiFormer : pi_form_struct >-> PiTypeFormer.

Lemma ppComp3 {Γ Δ : C} {A : Ty Γ : hSet} (f : C^op ⟦Γ,Δ⟧) {π : PiTypeFormer}
(nπ : PiTypeNat π) {B : Ty (Γ¤A) : hSet} (c : tm (π _ A B))
: p _ (c ⌈f⌉)  = (π Δ (A ⌊f⌋) (B ⌊q A f⌋)).
Proof.
  apply pathsinv0, (pathscomp0(!(nπ _ _ f A B))),
  (pathscomp0(!(maponpaths (# Ty f) (pr2 c)))),
   pathsinv0, (toforallpaths _ _ _ (pr2 p _ _ _) c) .
Qed.

Definition PiAbs (π : PiTypeFormer): UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ¤A) : hSet) (b : tm B), tm (π _ A B) .

Definition PiAbsNat (π : PiTypeFormer) (nπ : PiTypeNat π) (Λ : PiAbs π)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet)
(B : Ty (Γ ¤ A) : hSet) (b : tm B), (Λ Γ A B b) ⌈f⌉ =
tm_transportf (! (! ppComp1 f (Λ Γ A B b) @ ppComp3 f nπ (Λ Γ A B b)))
(Λ Δ (A ⌊f⌋) (B ⌊q A f⌋) (b ⌈q A f⌉)).

Definition Pi_intro_struct (π : pi_form_struct) : UU
:= ∑ Λ : PiAbs π, PiAbsNat π (pr2 π) Λ.

Definition PiApp (π : PiTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c : tm (π _ A B)) (a : tm A),
tm (B ⌊a⌋).

Definition PiAppNat  (π : PiTypeFormer) (nπ : PiTypeNat π) (app : PiApp π) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c : tm (π _ A B)) (a : tm A),
reind_tm f (app _ _ _ c a) = (tm_transportf  (!(DepTypesNat_bis B f a))
(app _ (A ⌊f⌋) (B ⌊q A f⌋) (tm_transportf (nπ _ _ f A B) (c ⌈f⌉)) (a ⌈f⌉))).

Definition Pi_app_struct (π : pi_form_struct) : UU
:= ∑ app : PiApp π, PiAppNat π (pr2 π) app.

Definition PiAppAbs (π : PiTypeFormer) (Λ : PiAbs π) (app : PiApp π)
:= ∏ Γ ( A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (b : tm B) (a : tm A),
app _ _ _ (Λ _ A _ b) a = b⌈a⌉.

Definition Pi_comp_struct (π : pi_form_struct)
(lam : Pi_intro_struct π) (app : Pi_app_struct π) : UU
:= PiAppAbs π (pr1 lam) (pr1 app).

Definition PiAbsAppComp (π : PiTypeFormer) (nπ : PiTypeNat π)
(Λ : PiAbs π) (app : PiApp π)
: UU
:= ∏ (Γ : C) (A : Ty Γ: hSet) (B : Ty (Γ ¤ A) : hSet) (c : tm (π Γ A B)),
c = Λ Γ A B (tm_transportf (DepTypesEta_bis B)
(app (Γ ¤ A) (A ⌊pi A⌋) (B ⌊q A (pi A)⌋)
(tm_transportf (nπ Γ (Γ ¤ A) (pi A) A B) (reind_tm (pi A) c)) (var A))).

End Pi_structure.

Section Sigma_structure.

Definition SigTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty (Γ¤A) : hSet), Ty Γ : hSet.

Definition SigTypeNat (σ : SigTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet),
(σ _ A B) ⌊f⌋ = σ _ (A ⌊f⌋) (B  ⌊q A f⌋).

Definition SigAbs (σ : SigTypeFormer) : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (a : tm A)
(b : tm (B ⌊a⌋) ), tm (σ _ A B).

Definition CwF_SigAbsNat (σ : SigTypeFormer) (nσ : SigTypeNat σ)
(pair : SigAbs σ)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ ¤ A) : hSet)
(a : tm A) (b : tm (B ⌊a⌋)), (pair Γ A B a b) ⌈f⌉=
tm_transportf (! nσ Γ Δ f A B)
(pair Δ (A ⌊f⌋) (B  ⌊q A f⌋) (a ⌈f⌉)
(tm_transportf (DepTypesNat B f a) (b ⌈f⌉))).

Definition SigPr1 (σ : SigTypeFormer) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c: tm (σ _ A B)), tm A.

Definition SigPr1Nat (σ : SigTypeFormer) (nσ : SigTypeNat σ) (p1 : SigPr1 σ) : UU
:= ∏ (Γ Δ : C)  (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c : tm (σ _ A B)),
(p1 _ _ _ c) ⌈f⌉=
p1 _ (A ⌊f⌋) (B  ⌊q A f⌋) (tm_transportf (nσ _ _ f _ _) (c ⌈f⌉)).

Definition SigPr2 (σ : SigTypeFormer) (p1 : SigPr1 σ) :UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet)
(c : tm (σ _ A B) ), tm (B ⌊(p1 _ _ _ c)⌋).

Definition SigPr2Nat (σ : SigTypeFormer) (nσ : SigTypeNat σ) (p1 : SigPr1 σ)
(np1 : SigPr1Nat σ nσ p1) (p2 : SigPr2 σ p1)
: UU := ∏ (Γ Δ : C) (f : C^op ⟦ Γ, Δ ⟧) (A : Ty Γ : hSet) (B : Ty (Γ¤A) : hSet)
(c : tm (σ Γ A B)),
(p2 Γ A B c) ⌈f⌉ = tm_transportf (! DepTypesNat B f (p1 Γ A B c))
(tm_transportf (DepTypesrewrite (B  ⌊q A f⌋)
(p1 Δ (A ⌊f⌋) (B  ⌊q A f⌋) (tm_transportf (nσ Γ Δ f A B) (c ⌈f⌉)))
((p1 Γ A B c) ⌈f⌉) (maponpaths pr1 (! np1 Γ Δ f A B c)))
(p2 Δ (A ⌊f⌋) (B  ⌊q A f⌋) (tm_transportf (nσ Γ Δ f A B) (c ⌈f⌉)))).

Definition SigAbsPr1 (σ : SigTypeFormer) (pair : SigAbs σ) (p1 : SigPr1 σ)
: UU := ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (a : tm A) (b : tm (B ⌊a⌋)),
p1 _ _ _ (pair _  _ _ a b) = a.

Definition SigAbsPr2 (σ : SigTypeFormer) (pair : SigAbs σ) (p1 : SigPr1 σ)
(p2 : SigPr2 σ p1) (Ap1 : SigAbsPr1 σ pair p1)
: UU := ∏ (Γ : C^op) (A : Ty Γ : hSet) (B : Ty (Γ ¤ A) : hSet)
(a : tm A) (b : tm (B ⌊a⌋)),
b = tm_transportf
(DepTypesrewrite B (p1 Γ A B (pair Γ A B a b)) a (maponpaths pr1 (Ap1 Γ A B a b)))
(p2 Γ A B (pair Γ A B a b)).

Definition SigAbsPr (σ : SigTypeFormer) (pair : SigAbs σ)
(p1 : SigPr1 σ) (p2 : SigPr2 σ p1) : UU
:= ∏ Γ (A : Ty Γ : hSet) (B : Ty(Γ¤A) : hSet) (c : tm (σ _ A B)),
pair _ _ _ (p1 _ _ _ c) (p2 _ _ _ c ) = c.

End Sigma_structure.

Section Identity_Structure.

Definition IdTypeFormer : UU
:= ∏ (Γ : C) (A : Ty Γ : hSet) (a b : tm A), Ty Γ : hSet.

Definition IdTypeNat (id : IdTypeFormer) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a b : tm A),
(id _ A a b) ⌊f⌋  = id _ (A ⌊f⌋) (a ⌈f⌉) (b ⌈f⌉).

Definition IdRefl (Id : IdTypeFormer) : UU
:= ∏ Γ (A : Ty Γ :hSet) (a : tm A), tm (Id _ _ a a).

Definition IdReflNat (Id : IdTypeFormer) (nid : IdTypeNat Id)
(refl : IdRefl Id) : UU
:= ∏ (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A),
(refl _ A a) ⌈f⌉ =
tm_transportf (!(nid _ _ f _ a a)) (refl _ (A ⌊f⌋) (a ⌈f⌉)).

Definition maponpathsIdForm {Id : IdTypeFormer}
{Γ} {A A'} (e_A : A = A')
{a} {a'} (e_a : a = tm_transportb e_A a')
{b} {b'} (e_b : b = tm_transportb e_A b')
: Id Γ A a b = Id Γ A' a' b'.
Proof.
  destruct e_A.
  rewrite (tm_transportbf _) in e_a, e_b;
   cbn in e_a, e_b.
  apply Auxiliary.maponpaths_12; assumption.
Qed.

Definition IdBasedFam (Id : IdTypeFormer) {Γ : C} (A : Ty Γ : hSet) (a : tm A)
: Ty (Γ¤A) : hSet := Id _ _ (a ⌈pi A⌉) (var A).

Definition IdBasedFamNatural (Id : IdTypeFormer) (nid : IdTypeNat Id)
{Γ Δ : C} (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A)
: (IdBasedFam Id A a) ⌊q A f⌋ = IdBasedFam Id _ (a ⌈f⌉).
Proof.
  unfold IdBasedFam.
  etrans.
  -  exact (nid _ _ (q A f) _ _ _).
  -  use maponpathsIdForm.
     --  refine (!(Ty_composition _ _ A) @ _).
         apply pathsinv0, (pathscomp0 (!(Ty_composition _ _ A))).
         refine ((toforallpaths _ _ _ _) A).
         exact (maponpaths _ (q_eq _ _)).
     --  etrans. {apply pathsinv0, tm_transport_compose. }
         etrans. 2: { apply maponpaths, tm_transport_compose. }
         etrans. 2: {rewrite tm_transportbf; apply  tm_transportf_compose. }
         etrans. {eapply maponpaths. refine (maponpaths_2_reind_tm _ _).
         apply (!(q_eq _ _)). }
         etrans. { rewrite tm_transportbf; apply (!(tm_transportf_compose _ _ _)). }
         apply tm_transportf_irrelevant.
     --  apply subtypePath; [intro x; apply (setproperty (Ty _ : hSet))|
         rewrite tm_transportbf ;apply compatibility_splTCwF].
Qed.

Definition Id_map {Id} (nid : IdTypeNat Id) {Γ} {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
: C⟦Γ,_¤IdBasedFam Id A a⟧.
Proof.
  simple refine (γ_qq b _). unfold IdBasedFam.
  simple refine (tm_transportb _ eqab).
  abstract(
  simple refine (nid  _ _ _ _ _ _ @ _);
  use maponpathsIdForm;
  [ apply Ty_γ_id
  | rewrite tm_transportbf ;
    refine (_ @ tm_transportf_irrelevant _ _ _);
    simple refine (tm_transportf_bind (!reind_compose_tm' _ _ _) _);
    [ apply (pathscomp0 (!(Ty_γ_id b))) , (!(Ty_composition _ _ _)) |
      simple refine (maponpaths_2_reind_tm _ _ @ _);
      [exact (identity _) | apply γ_pi |
      rewrite tm_transportbf; apply (pathscomp0 (reind_id_tm' _ _ _));
      apply tm_transportf_irrelevant ]]
  | apply subtypePath;
    [  intros x; apply (setproperty (Ty Γ : hSet))
     | rewrite tm_transportbf; apply var_subtitution]]).
Defined.

Definition id_intro_q {Id} (nid : IdTypeNat Id)
{Γ Δ} (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) a b (eqab : tm (Id _ A a b))
(eqab' : tm (Id _ _ (a ⌈f⌉) (b ⌈f⌉)) := (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)))
: (f : C⟦Δ,Γ⟧) ;; eqab
= eqab'
  ;; comp_ext_compare (!nid _ _ _ _ _ _)
  ;; q _ f.
Proof.
  etrans. { apply pathsinv0, reind_tm_q. }
  apply maponpaths_2.
  unfold eqab'.
  assert (eqnat :nid Γ Δ f A a b = !(!(nid Γ Δ f A a b)) ) by apply (!(pathsinv0inv0 _)).
  rewrite eqnat, (!(tm_transportbf _)).
  rewrite (pathsinv0inv0 _).
  apply (!(tm_transportb_unfold_alter _ _)).
Qed.

Definition Id_map_natural {Id} (nid : IdTypeNat Id)
{Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
(eqab' : tm (Id _ _ (a ⌈f⌉) (b ⌈f⌉)) := (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)))
: Id_map nid (a ⌈f⌉) (b ⌈f⌉) eqab'
  ;; (comp_ext_compare (!  IdBasedFamNatural Id nid  f A a)
  ;; q (IdBasedFam Id A a) (q A f))
= (f : C⟦Δ,Γ⟧) ;; Id_map nid a b eqab.
Proof.
  unfold Id_map, γ_qq.
  repeat rewrite tm_transportb_unfold.
  etrans. 2: { apply maponpaths, assoc. }
  etrans. 2: { apply pathsinv0, assoc. }
  etrans. 2: { eapply maponpaths_2, pathsinv0, id_intro_q. }
  etrans. { apply pathsinv0, assoc. }
  etrans. { apply pathsinv0, assoc. }
  etrans. 2: { apply assoc. }
  etrans. 2: { apply assoc. }
  apply maponpaths.
  etrans.
  { apply maponpaths.
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, q_typeeq. }
  etrans. { apply assoc'. }
  apply maponpaths, q_q'.
  }
  etrans.
  2: { apply pathsinv0, maponpaths.
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, q_typeeq. }
  etrans. { apply assoc'. }
  apply maponpaths, q_q'.
  }
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, comp_ext_compare_comp. }
  etrans. { apply assoc. }
  etrans. { apply maponpaths_2, pathsinv0, comp_ext_compare_comp. }
  etrans. 2: { apply assoc'. }
  etrans. 2: { apply maponpaths_2, comp_ext_compare_comp. }
  etrans. 2: { apply assoc'. }
  etrans. 2: { apply maponpaths_2, comp_ext_compare_comp. }
  etrans.
  2: { apply maponpaths.
    refine (q_mapeq _ _).
    apply pathsinv0, reind_tm_q.
  }
  etrans. 2: { apply assoc'. }
  etrans. 2: { apply maponpaths_2, comp_ext_compare_comp. }
  apply maponpaths_2, comp_ext_compare_irrelevant.
Qed.

Definition Id_map_natural_op {Id} (nid : IdTypeNat Id)
{Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} (a : tm A) (b : tm A) (eqab : tm (Id _ _ a b))
(eqab' : tm (Id _ _ (a ⌈f⌉) (b ⌈f⌉)) := (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)))
: (Id_map nid a b eqab : C^op ⟦_,_⟧ );; f =
((comp_ext_compare (! IdBasedFamNatural Id nid f A a)  ;; q (IdBasedFam Id A a) (q A f) ) : C^op ⟦_,_⟧ );;
(Id_map nid (a ⌈f⌉) (b ⌈f⌉) eqab' : C^op ⟦_,_⟧).
Proof.
  eapply pathscomp0.
  assert (eqop : (Id_map nid a b eqab : C^op ⟦_,_⟧ );; f = (f : C⟦Δ,Γ⟧) ;; Id_map nid a b eqab) by auto.
  exact (eqop @ (!(Id_map_natural _ _ _ _ _))).
  reflexivity.
Qed.

Definition IdBased_path_inducton {Id} (nid : IdTypeNat Id) (refl : IdRefl Id) := ∏ Γ (A : Ty Γ : hSet) (a : tm A)
(P : Ty (_ ¤ IdBasedFam Id A a) :  hSet)
(d : tm  (P ⌊Id_map nid a a (refl _ _ a)⌋ ))
(b : tm A) (eqab : tm (Id _ _ a b)),
tm (#Ty (Id_map nid a b eqab) P).

Definition d' {Id} {nid : IdTypeNat Id} {refl : IdRefl Id} (nrefl : IdReflNat Id nid refl)
 {Γ Δ} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} {a : tm A}
{P : Ty (_ ¤ IdBasedFam Id A a) :  hSet}
(P' :  Ty (_¤ (IdBasedFam Id (A ⌊f⌋) (a ⌈f⌉))) : hSet
:= P⌊ (comp_ext_compare (!  IdBasedFamNatural Id nid  f A a) ;; q (IdBasedFam Id A a) (q A f))⌋)
(d : tm  (P ⌊Id_map nid a a (refl _ _ a)⌋ ))
{b : tm A} (eqab : tm (Id _ _ a b)) :
tm (P' ⌊Id_map nid (a ⌈f⌉) (a ⌈f⌉) (refl _ _ (a ⌈f⌉))⌋).
Proof.
  refine ((tm_transportb _) (d ⌈f⌉)).
  apply (pathscomp0 (compose_ty _ _ _)).
  unfold P'.
  apply pathsinv0.
  apply (pathscomp0 (compose_ty _ _ _)).
  apply maponpaths.
  apply (pathscomp0 (Id_map_natural_op nid f a a (refl _ A a))).
  apply maponpaths.
  apply maponpaths.
  eapply pathscomp0.
  apply maponpaths.
  apply nrefl.
  apply (pathscomp0 (!(tm_transportf_compose _ _ _))).
  apply tm_transportf_idpath_gen.
Defined.

Lemma d_type_natural {Id} (nid : IdTypeNat Id) (refl : IdRefl Id) {Γ Δ : C} (f : C^op ⟦Γ,Δ⟧) {A : Ty Γ : hSet} {a : tm A}
(P : Ty (_ ¤ IdBasedFam Id A a) :  hSet) {b : tm A} (eqab : tm (Id _ _ a b)):
 P ⌊Id_map nid a b eqab⌋ ⌊f⌋  =
   P ⌊comp_ext_compare (! IdBasedFamNatural Id nid f A a) ;; q (IdBasedFam Id A a) (q A f)⌋ ⌊Id_map nid (reind_tm f a) (reind_tm f b)
   (tm_transportf (nid Γ Δ f A a b) (reind_tm f eqab))⌋.
Proof.
  do 2 rewrite compose_ty.
  apply maponpaths.
  apply Id_map_natural_op.
Qed.

Definition IdBased_path_induction_natural {Id} (nid : IdTypeNat Id) (refl : IdRefl Id) (nrefl : IdReflNat Id nid refl)
: UU :=
∏ (J : IdBased_path_inducton nid refl) (Γ Δ : C) (f : C^op ⟦Γ,Δ⟧) (A : Ty Γ : hSet) (a : tm A)
(P : Ty (_ ¤ IdBasedFam Id A a) :  hSet)
(d : tm  (P ⌊Id_map nid a a (refl _ _ a)⌋ ))
(b : tm A) (eqab : tm (Id _ _ a b)), (tm_transportf (d_type_natural nid refl f P eqab) ((J Γ A a P d b eqab) ⌈f⌉)) =
J Δ (A⌊f⌋) (a ⌈f⌉) (P⌊_⌋) (d' nrefl f d eqab) (b ⌈f⌉) (tm_transportf (nid _ _ _ _ _ _) (eqab ⌈f⌉)).

End Identity_Structure.

End splTCwF.


From stdpp Require Import coPset.
From iris.bi Require Import bi.

(** Definitions. *)
Structure biIndex :=
  BiIndex
    { bi_index_type :> Type;
      bi_index_inhabited : Inhabited bi_index_type;
      bi_index_rel : SqSubsetEq bi_index_type;
      bi_index_rel_preorder : PreOrder (⊑) }.
Existing Instances bi_index_inhabited bi_index_rel bi_index_rel_preorder.

(* We may want to instantiate monPred with the reflexivity relation in
   the case where there is no relevent order. In that case, there is
   no bottom element, so that we do not want to force any BI index to
   have one. *)
Class BiIndexBottom {I : biIndex} (bot : I) :=
  bi_index_bot i : bot ⊑ i.

Section Ofe_Cofe.
Context {I : biIndex} {PROP : bi}.
Implicit Types i : I.

Record monPred :=
  MonPred { monPred_at :> I → PROP;
            monPred_mono : Proper ((⊑) ==> (⊢)) monPred_at }.
Local Existing Instance monPred_mono.

Bind Scope monPred with bi.

Implicit Types P Q : monPred.

(** Ofe + Cofe instances  *)

Section Ofe_Cofe_def.
  Inductive monPred_equiv' P Q : Prop :=
    { monPred_in_equiv i : P i ≡ Q i } .
  Instance monPred_equiv : Equiv monPred := monPred_equiv'.
  Inductive monPred_dist' (n : nat) (P Q : monPred) : Prop :=
    { monPred_in_dist i : P i ≡{n}≡ Q i }.
  Instance monPred_dist : Dist monPred := monPred_dist'.

  Definition monPred_sig P : { f : I -c> PROP | Proper ((⊑) ==> (⊢)) f } :=
    exist _ (monPred_at P) (monPred_mono P).

  Definition sig_monPred (P' : { f : I -c> PROP | Proper ((⊑) ==> (⊢)) f })
    : monPred :=
    MonPred (proj1_sig P') (proj2_sig P').

  (* These two lemma use the wrong Equiv and Dist instance for
    monPred. so we make sure they are not accessible outside of the
    section by using Let. *)
  Let monPred_sig_equiv:
    ∀ P Q, P ≡ Q ↔ monPred_sig P ≡ monPred_sig Q.
  Proof. by split; [intros []|]. Qed.
  Let monPred_sig_dist:
    ∀ n, ∀ P Q : monPred, P ≡{n}≡ Q ↔ monPred_sig P ≡{n}≡ monPred_sig Q.
  Proof. by split; [intros []|]. Qed.

  Definition monPred_ofe_mixin : OfeMixin monPred.
  Proof. by apply (iso_ofe_mixin monPred_sig monPred_sig_equiv monPred_sig_dist). Qed.

  Canonical Structure monPredC := OfeT monPred monPred_ofe_mixin.

  Global Instance monPred_cofe `{Cofe PROP} : Cofe monPredC.
  Proof.
    unshelve refine (iso_cofe_subtype (A:=I-c>PROP) _ MonPred monPred_at _ _ _);
      [apply _|by apply monPred_sig_dist|done|].
    intros c i j Hij. apply @limit_preserving;
      [by apply bi.limit_preserving_entails; intros ??|]=>n. by rewrite Hij.
  Qed.
End Ofe_Cofe_def.

Lemma monPred_sig_monPred (P' : { f : I -c> PROP | Proper ((⊑) ==> (⊢)) f }) :
  monPred_sig (sig_monPred P') ≡ P'.
Proof. by change (P' ≡ P'). Qed.
Lemma sig_monPred_sig P : sig_monPred (monPred_sig P) ≡ P.
Proof. done. Qed.

Global Instance monPred_sig_ne : NonExpansive monPred_sig.
Proof. move=> ??? [?] ? //=. Qed.
Global Instance monPred_sig_proper : Proper ((≡) ==> (≡)) monPred_sig.
Proof. eapply (ne_proper _). Qed.
Global Instance sig_monPred_ne : NonExpansive (@sig_monPred).
Proof. split=>? //=. Qed.
Global Instance sig_monPred_proper : Proper ((≡) ==> (≡)) sig_monPred.
Proof. eapply (ne_proper _). Qed.

(* We generalize over the relation R which is morally the equivalence
   relation over B. That way, the BI index can use equality as an
   equivalence relation (and Coq is able to infer the Proper and
   Reflexive instances properly), or any other equivalence relation,
   provided it is compatible with (⊑). *)
Global Instance monPred_at_ne (R : relation I) :
  Proper (R ==> R ==> iff) (⊑) → Reflexive R →
  ∀ n, Proper (dist n ==> R ==> dist n) monPred_at.
Proof.
  intros ????? [Hd] ?? HR. rewrite Hd.
  apply equiv_dist, bi.equiv_spec; split; f_equiv; rewrite ->HR; done.
Qed.
Global Instance monPred_at_proper (R : relation I) :
  Proper (R ==> R ==> iff) (⊑) → Reflexive R →
  Proper ((≡) ==> R ==> (≡)) monPred_at.
Proof. repeat intro. apply equiv_dist=>?. f_equiv=>//. by apply equiv_dist. Qed.
End Ofe_Cofe.

Arguments monPred _ _ : clear implicits.
Arguments monPred_at {_ _} _%I _.
Local Existing Instance monPred_mono.
Arguments monPredC _ _ : clear implicits.

(** BI and SBI structures. *)

Section Bi.
Context {I : biIndex} {PROP : bi}.
Implicit Types i : I.
Notation monPred := (monPred I PROP).
Implicit Types P Q : monPred.

Inductive monPred_entails (P1 P2 : monPred) : Prop :=
  { monPred_in_entails i : P1 i ⊢ P2 i }.
Hint Immediate monPred_in_entails.

Program Definition monPred_upclosed (Φ : I → PROP) : monPred :=
  MonPred (λ i, (∀ j, ⌜i ⊑ j⌝ → Φ j)%I) _.
Next Obligation. solve_proper. Qed.

Definition monPred_embed_def (P : PROP) : monPred := MonPred (λ _, P) _.
Definition monPred_embed_aux : seal (@monPred_embed_def). by eexists. Qed.
Definition monPred_embed : Embed PROP monPred := monPred_embed_aux.(unseal).
Definition monPred_embed_eq : @embed _ _ monPred_embed = _ := monPred_embed_aux.(seal_eq).

Definition monPred_emp_def : monPred := MonPred (λ _, emp)%I _.
Definition monPred_emp_aux : seal (@monPred_emp_def). by eexists. Qed.
Definition monPred_emp := monPred_emp_aux.(unseal).
Definition monPred_emp_eq : @monPred_emp = _ := monPred_emp_aux.(seal_eq).

Definition monPred_pure_def (φ : Prop) : monPred := MonPred (λ _, ⌜φ⌝)%I _.
Definition monPred_pure_aux : seal (@monPred_pure_def). by eexists. Qed.
Definition monPred_pure := monPred_pure_aux.(unseal).
Definition monPred_pure_eq : @monPred_pure = _ := monPred_pure_aux.(seal_eq).

Definition monPred_objectively_def P : monPred := MonPred (λ _, ∀ i, P i)%I _.
Definition monPred_objectively_aux : seal (@monPred_objectively_def). by eexists. Qed.
Definition monPred_objectively := monPred_objectively_aux.(unseal).
Definition monPred_objectively_eq : @monPred_objectively = _ := monPred_objectively_aux.(seal_eq).

Definition monPred_subjectively_def P : monPred := MonPred (λ _, ∃ i, P i)%I _.
Definition monPred_subjectively_aux : seal (@monPred_subjectively_def). by eexists. Qed.
Definition monPred_subjectively := monPred_subjectively_aux.(unseal).
Definition monPred_subjectively_eq : @monPred_subjectively = _ := monPred_subjectively_aux.(seal_eq).

Program Definition monPred_and_def P Q : monPred :=
  MonPred (λ i, P i ∧ Q i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_and_aux : seal (@monPred_and_def). by eexists. Qed.
Definition monPred_and := monPred_and_aux.(unseal).
Definition monPred_and_eq : @monPred_and = _ := monPred_and_aux.(seal_eq).

Program Definition monPred_or_def P Q : monPred :=
  MonPred (λ i, P i ∨ Q i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_or_aux : seal (@monPred_or_def). by eexists. Qed.
Definition monPred_or := monPred_or_aux.(unseal).
Definition monPred_or_eq : @monPred_or = _ := monPred_or_aux.(seal_eq).

Definition monPred_impl_def P Q : monPred :=
  monPred_upclosed (λ i, P i → Q i)%I.
Definition monPred_impl_aux : seal (@monPred_impl_def). by eexists. Qed.
Definition monPred_impl := monPred_impl_aux.(unseal).
Definition monPred_impl_eq : @monPred_impl = _ := monPred_impl_aux.(seal_eq).

Program Definition monPred_forall_def A (Φ : A → monPred) : monPred :=
  MonPred (λ i, ∀ x : A, Φ x i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_forall_aux : seal (@monPred_forall_def). by eexists. Qed.
Definition monPred_forall := monPred_forall_aux.(unseal).
Definition monPred_forall_eq : @monPred_forall = _ := monPred_forall_aux.(seal_eq).

Program Definition monPred_exist_def A (Φ : A → monPred) : monPred :=
  MonPred (λ i, ∃ x : A, Φ x i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_exist_aux : seal (@monPred_exist_def). by eexists. Qed.
Definition monPred_exist := monPred_exist_aux.(unseal).
Definition monPred_exist_eq : @monPred_exist = _ := monPred_exist_aux.(seal_eq).

Program Definition monPred_sep_def P Q : monPred :=
  MonPred (λ i, P i ∗ Q i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_sep_aux : seal (@monPred_sep_def). by eexists. Qed.
Definition monPred_sep := monPred_sep_aux.(unseal).
Definition monPred_sep_eq : @monPred_sep = _ := monPred_sep_aux.(seal_eq).

Definition monPred_wand_def P Q : monPred :=
  monPred_upclosed (λ i, P i -∗ Q i)%I.
Definition monPred_wand_aux : seal (@monPred_wand_def). by eexists. Qed.
Definition monPred_wand := monPred_wand_aux.(unseal).
Definition monPred_wand_eq : @monPred_wand = _ := monPred_wand_aux.(seal_eq).

Program Definition monPred_persistently_def P : monPred :=
  MonPred (λ i, <pers> (P i))%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_persistently_aux : seal (@monPred_persistently_def). by eexists. Qed.
Definition monPred_persistently := monPred_persistently_aux.(unseal).
Definition monPred_persistently_eq : @monPred_persistently = _ := monPred_persistently_aux.(seal_eq).

Program Definition monPred_in_def (i0 : I) : monPred :=
  MonPred (λ i : I, ⌜i0 ⊑ i⌝%I) _.
Next Obligation. solve_proper. Qed.
Definition monPred_in_aux : seal (@monPred_in_def). by eexists. Qed.
Definition monPred_in := monPred_in_aux.(unseal).
Definition monPred_in_eq : @monPred_in = _ := monPred_in_aux.(seal_eq).
End Bi.

Arguments monPred_objectively {_ _} _%I.
Arguments monPred_subjectively {_ _} _%I.
Notation "'<obj>' P" := (monPred_objectively P) : bi_scope.
Notation "'<subj>' P" := (monPred_subjectively P) : bi_scope.

Section Sbi.
Context {I : biIndex} {PROP : sbi}.
Implicit Types i : I.
Notation monPred := (monPred I PROP).
Implicit Types P Q : monPred.

Definition monPred_internal_eq_def (A : ofeT) (a b : A) : monPred :=
  MonPred (λ _, a ≡ b)%I _.
Definition monPred_internal_eq_aux : seal (@monPred_internal_eq_def). by eexists. Qed.
Definition monPred_internal_eq := monPred_internal_eq_aux.(unseal).
Definition monPred_internal_eq_eq : @monPred_internal_eq = _ :=
  monPred_internal_eq_aux.(seal_eq).

Program Definition monPred_later_def P : monPred := MonPred (λ i, ▷ (P i))%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_later_aux : seal monPred_later_def. by eexists. Qed.
Definition monPred_later := monPred_later_aux.(unseal).
Definition monPred_later_eq : monPred_later = _ := monPred_later_aux.(seal_eq).
End Sbi.

Module MonPred.
Definition unseal_eqs :=
  (@monPred_and_eq, @monPred_or_eq, @monPred_impl_eq,
   @monPred_forall_eq, @monPred_exist_eq, @monPred_sep_eq, @monPred_wand_eq,
   @monPred_persistently_eq, @monPred_later_eq, @monPred_internal_eq_eq, @monPred_in_eq,
   @monPred_embed_eq, @monPred_emp_eq, @monPred_pure_eq,
   @monPred_objectively_eq, @monPred_subjectively_eq).
Ltac unseal :=
  unfold bi_affinely, bi_absorbingly, sbi_except_0, bi_pure, bi_emp,
         monPred_upclosed, bi_and, bi_or,
         bi_impl, bi_forall, bi_exist, sbi_internal_eq, bi_sep, bi_wand,
         bi_persistently, bi_affinely, sbi_later;
  simpl;
  unfold sbi_emp, sbi_pure, sbi_and, sbi_or, sbi_impl, sbi_forall, sbi_exist,
         sbi_internal_eq, sbi_sep, sbi_wand, sbi_persistently;
  simpl;
  rewrite !unseal_eqs /=.
End MonPred.
Import MonPred.

Section canonical_bi.
Context (I : biIndex) (PROP : bi).

Lemma monPred_bi_mixin : BiMixin (PROP:=monPred I PROP)
  monPred_entails monPred_emp monPred_pure monPred_and monPred_or
  monPred_impl monPred_forall monPred_exist monPred_sep monPred_wand
  monPred_persistently.
Proof.
  split; try unseal; try by (split=> ? /=; repeat f_equiv).
  - split.
    + intros P. by split.
    + intros P Q R [H1] [H2]. split => ?. by rewrite H1 H2.
  - split.
    + intros [HPQ]. split; split => i; move: (HPQ i); by apply bi.equiv_spec.
    + intros [[] []]. split=>i. by apply bi.equiv_spec.
  - intros P φ ?. split=> i. by apply bi.pure_intro.
  - intros φ P HP. split=> i. apply bi.pure_elim'=> ?. by apply HP.
  - intros A φ. split=> i. by apply bi.pure_forall_2.
  - intros P Q. split=> i. by apply bi.and_elim_l.
  - intros P Q. split=> i. by apply bi.and_elim_r.
  - intros P Q R [?] [?]. split=> i. by apply bi.and_intro.
  - intros P Q. split=> i. by apply bi.or_intro_l.
  - intros P Q. split=> i. by apply bi.or_intro_r.
  - intros P Q R [?] [?]. split=> i. by apply bi.or_elim.
  - intros P Q R [HR]. split=> i /=. setoid_rewrite bi.pure_impl_forall.
    apply bi.forall_intro=> j. apply bi.forall_intro=> Hij.
    apply bi.impl_intro_r. by rewrite -HR /= !Hij.
  - intros P Q R [HR]. split=> i /=.
     rewrite HR /= bi.forall_elim bi.pure_impl_forall bi.forall_elim //.
    apply bi.impl_elim_l.
  - intros A P Ψ HΨ. split=> i. apply bi.forall_intro => ?. by apply HΨ.
  - intros A Ψ. split=> i. by apply: bi.forall_elim.
  - intros A Ψ a. split=> i. by rewrite /= -bi.exist_intro.
  - intros A Ψ Q HΨ. split=> i. apply bi.exist_elim => a. by apply HΨ.
  - intros P P' Q Q' [?] [?]. split=> i. by apply bi.sep_mono.
  - intros P. split=> i. by apply bi.emp_sep_1.
  - intros P. split=> i. by apply bi.emp_sep_2.
  - intros P Q. split=> i. by apply bi.sep_comm'.
  - intros P Q R. split=> i. by apply bi.sep_assoc'.
  - intros P Q R [HR]. split=> i /=. setoid_rewrite bi.pure_impl_forall.
    apply bi.forall_intro=> j. apply bi.forall_intro=> Hij.
    apply bi.wand_intro_r. by rewrite -HR /= !Hij.
  - intros P Q R [HP]. split=> i. apply bi.wand_elim_l'.
    rewrite HP /= bi.forall_elim bi.pure_impl_forall bi.forall_elim //.
  - intros P Q [?]. split=> i /=. by f_equiv.
  - intros P. split=> i. by apply bi.persistently_idemp_2.
  - split=> i. by apply bi.persistently_emp_intro.
  - intros A Ψ. split=> i. by apply bi.persistently_forall_2.
  - intros A Ψ. split=> i. by apply bi.persistently_exist_1.
  - intros P Q. split=> i. apply bi.sep_elim_l, _.
  - intros P Q. split=> i. by apply bi.persistently_and_sep_elim.
Qed.

Canonical Structure monPredI : bi :=
  {| bi_ofe_mixin := monPred_ofe_mixin; bi_bi_mixin := monPred_bi_mixin |}.
End canonical_bi.

Section canonical_sbi.
Context (I : biIndex) (PROP : sbi).

Lemma monPred_sbi_mixin :
  SbiMixin (PROP:=monPred I PROP) monPred_entails monPred_pure
           monPred_or monPred_impl monPred_forall monPred_exist
           monPred_sep monPred_persistently monPred_internal_eq monPred_later.
Proof.
  split; unseal.
  - intros n P Q HPQ. split=> i /=.
    apply bi.later_contractive. destruct n as [|n]=> //. by apply HPQ.
  - by split=> ? /=; repeat f_equiv.
  - intros A P a. split=> i. by apply bi.internal_eq_refl.
  - intros A a b Ψ ?. split=> i /=.
    setoid_rewrite bi.pure_impl_forall. do 2 apply bi.forall_intro => ?.
    erewrite (bi.internal_eq_rewrite _ _ (flip Ψ _)) => //=. solve_proper.
  - intros A1 A2 f g. split=> i. by apply bi.fun_ext.
  - intros A P x y. split=> i. by apply bi.sig_eq.
  - intros A a b ?. split=> i. by apply bi.discrete_eq_1.
  - intros A x y. split=> i. by apply bi.later_eq_1.
  - intros A x y. split=> i. by apply bi.later_eq_2.
  - intros P Q [?]. split=> i. by apply bi.later_mono.
  - intros P. split=> i /=. by apply bi.later_intro.
  - intros A Ψ. split=> i. by apply bi.later_forall_2.
  - intros A Ψ. split=> i. by apply bi.later_exist_false.
  - intros P Q. split=> i. by apply bi.later_sep_1.
  - intros P Q. split=> i. by apply bi.later_sep_2.
  - intros P. split=> i. by apply bi.later_persistently_1.
  - intros P. split=> i. by apply bi.later_persistently_2.
  - intros P. split=> i /=. rewrite -bi.forall_intro. apply bi.later_false_em.
    intros j. rewrite bi.pure_impl_forall. apply bi.forall_intro=> Hij. by rewrite Hij.
Qed.

Canonical Structure monPredSI : sbi :=
  {| sbi_ofe_mixin := monPred_ofe_mixin; sbi_bi_mixin := monPred_bi_mixin I PROP;
     sbi_sbi_mixin := monPred_sbi_mixin |}.
End canonical_sbi.

Class Objective {I : biIndex} {PROP : bi} (P : monPred I PROP) :=
  objective_at i j : P i -∗ P j.
Arguments Objective {_ _} _%I.
Arguments objective_at {_ _} _%I {_}.
Hint Mode Objective + + ! : typeclass_instances.
Instance: Params (@Objective) 2.

(** Primitive facts that cannot be deduced from the BI structure. *)

Section bi_facts.
Context {I : biIndex} {PROP : bi}.
Local Notation monPred := (monPred I PROP).
Local Notation monPredI := (monPredI I PROP).
Local Notation monPred_at := (@monPred_at I PROP).
Local Notation BiIndexBottom := (@BiIndexBottom I).
Implicit Types i : I.
Implicit Types P Q : monPred.

(** Instances *)
Global Instance monPred_at_mono :
  Proper ((⊢) ==> (⊑) ==> (⊢)) monPred_at.
Proof. by move=> ?? [?] ?? ->. Qed.
Global Instance monPred_at_flip_mono :
  Proper (flip (⊢) ==> flip (⊑) ==> flip (⊢)) monPred_at.
Proof. solve_proper. Qed.

Global Instance monPred_in_proper (R : relation I) :
  Proper (R ==> R ==> iff) (⊑) → Reflexive R →
  Proper (R ==> (≡)) (@monPred_in I PROP).
Proof. unseal. split. solve_proper. Qed.
Global Instance monPred_in_mono : Proper (flip (⊑) ==> (⊢)) (@monPred_in I PROP).
Proof. unseal. split. solve_proper. Qed.
Global Instance monPred_in_flip_mono : Proper ((⊑) ==> flip (⊢)) (@monPred_in I PROP).
Proof. solve_proper. Qed.

Global Instance monPred_positive : BiPositive PROP → BiPositive monPredI.
Proof. split => ?. unseal. apply bi_positive. Qed.
Global Instance monPred_affine : BiAffine PROP → BiAffine monPredI.
Proof. split => ?. unseal. by apply affine. Qed.

Global Instance monPred_at_persistent P i : Persistent P → Persistent (P i).
Proof. move => [] /(_ i). by unseal. Qed.
Global Instance monPred_at_absorbing P i : Absorbing P → Absorbing (P i).
Proof. move => [] /(_ i). unfold Absorbing. by unseal. Qed.
Global Instance monPred_at_affine P i : Affine P → Affine (P i).
Proof. move => [] /(_ i). unfold Affine. by unseal. Qed.

(* Note that monPred_in is *not* Plain, because it does depend on the
   index. *)
Global Instance monPred_in_persistent i :
  Persistent (@monPred_in I PROP i).
Proof. unfold Persistent. unseal; split => ?. by apply bi.pure_persistent. Qed.
Global Instance monPred_in_absorbing i :
  Absorbing (@monPred_in I PROP i).
Proof. unfold Absorbing. unseal. split=> ? /=. apply absorbing, _. Qed.

Definition monPred_embedding_mixin : BiEmbedMixin PROP monPredI monPred_embed.
Proof.
  split; try apply _; rewrite /bi_emp_valid; unseal; try done.
  - move=> P /= [/(_ inhabitant) ?] //.
  - intros P Q. split=> i /=.
    by rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim.
  - intros P Q. split=> i /=.
    by rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim.
Qed.
Global Instance monPred_bi_embed : BiEmbed PROP monPredI :=
  {| bi_embed_mixin := monPred_embedding_mixin |}.
Global Instance monPred_bi_embed_emp : BiEmbedEmp PROP monPredI.
Proof. split. by unseal. Qed.

Lemma monPred_emp_unfold : emp%I = ⎡emp : PROP⎤%I.
Proof. by unseal. Qed.
Lemma monPred_pure_unfold : bi_pure = λ φ, ⎡ ⌜ φ ⌝ : PROP⎤%I.
Proof. by unseal. Qed.
Lemma monPred_objectively_unfold : monPred_objectively = λ P, ⎡∀ i, P i⎤%I.
Proof. by unseal. Qed.
Lemma monPred_subjectively_unfold : monPred_subjectively = λ P, ⎡∃ i, P i⎤%I.
Proof. by unseal. Qed.

Global Instance monPred_objectively_ne : NonExpansive (@monPred_objectively I PROP).
Proof. rewrite monPred_objectively_unfold. solve_proper. Qed.
Global Instance monPred_objectively_proper : Proper ((≡) ==> (≡)) (@monPred_objectively I PROP).
Proof. apply (ne_proper _). Qed.
Lemma monPred_objectively_mono P Q : (P ⊢ Q) → (<obj> P ⊢ <obj> Q).
Proof. rewrite monPred_objectively_unfold. solve_proper. Qed.
Global Instance monPred_objectively_mono' : Proper ((⊢) ==> (⊢)) (@monPred_objectively I PROP).
Proof. intros ???. by apply monPred_objectively_mono. Qed.
Global Instance monPred_objectively_flip_mono' :
  Proper (flip (⊢) ==> flip (⊢)) (@monPred_objectively I PROP).
Proof. intros ???. by apply monPred_objectively_mono. Qed.

Global Instance monPred_objectively_persistent P : Persistent P → Persistent (<obj> P).
Proof. rewrite monPred_objectively_unfold. apply _. Qed.
Global Instance monPred_objectively_absorbing P : Absorbing P → Absorbing (<obj> P).
Proof. rewrite monPred_objectively_unfold. apply _. Qed.
Global Instance monPred_objectively_affine P : Affine P → Affine (<obj> P).
Proof. rewrite monPred_objectively_unfold. apply _. Qed.

Global Instance monPred_subjectively_ne : NonExpansive (@monPred_subjectively I PROP).
Proof. rewrite monPred_subjectively_unfold. solve_proper. Qed.
Global Instance monPred_subjectively_proper : Proper ((≡) ==> (≡)) (@monPred_subjectively I PROP).
Proof. apply (ne_proper _). Qed.
Lemma monPred_subjectively_mono P Q : (P ⊢ Q) → <subj> P ⊢ <subj> Q.
Proof. rewrite monPred_subjectively_unfold. solve_proper. Qed.
Global Instance monPred_subjectively_mono' : Proper ((⊢) ==> (⊢)) (@monPred_subjectively I PROP).
Proof. intros ???. by apply monPred_subjectively_mono. Qed.
Global Instance monPred_subjectively_flip_mono' :
  Proper (flip (⊢) ==> flip (⊢)) (@monPred_subjectively I PROP).
Proof. intros ???. by apply monPred_subjectively_mono. Qed.

Global Instance monPred_subjectively_persistent P : Persistent P → Persistent (<subj> P).
Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
Global Instance monPred_subjectively_absorbing P : Absorbing P → Absorbing (<subj> P).
Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
Global Instance monPred_subjectively_affine P : Affine P → Affine (<subj> P).
Proof. rewrite monPred_subjectively_unfold. apply _. Qed.

(** monPred_at unfolding laws *)
Lemma monPred_at_embed i (P : PROP) : monPred_at ⎡P⎤ i ⊣⊢ P.
Proof. by unseal. Qed.
Lemma monPred_at_pure i (φ : Prop) : monPred_at ⌜φ⌝ i ⊣⊢ ⌜φ⌝.
Proof. by unseal. Qed.
Lemma monPred_at_emp i : monPred_at emp i ⊣⊢ emp.
Proof. by unseal. Qed.
Lemma monPred_at_and i P Q : (P ∧ Q) i ⊣⊢ P i ∧ Q i.
Proof. by unseal. Qed.
Lemma monPred_at_or i P Q : (P ∨ Q) i ⊣⊢ P i ∨ Q i.
Proof. by unseal. Qed.
Lemma monPred_at_impl i P Q : (P → Q) i ⊣⊢ ∀ j, ⌜i ⊑ j⌝ → P j → Q j.
Proof. by unseal. Qed.
Lemma monPred_at_forall {A} i (Φ : A → monPred) : (∀ x, Φ x) i ⊣⊢ ∀ x, Φ x i.
Proof. by unseal. Qed.
Lemma monPred_at_exist {A} i (Φ : A → monPred) : (∃ x, Φ x) i ⊣⊢ ∃ x, Φ x i.
Proof. by unseal. Qed.
Lemma monPred_at_sep i P Q : (P ∗ Q) i ⊣⊢ P i ∗ Q i.
Proof. by unseal. Qed.
Lemma monPred_at_wand i P Q : (P -∗ Q) i ⊣⊢ ∀ j, ⌜i ⊑ j⌝ → P j -∗ Q j.
Proof. by unseal. Qed.
Lemma monPred_at_persistently i P : (<pers> P) i ⊣⊢ <pers> (P i).
Proof. by unseal. Qed.
Lemma monPred_at_in i j : monPred_at (monPred_in j) i ⊣⊢ ⌜j ⊑ i⌝.
Proof. by unseal. Qed.
Lemma monPred_at_objectively i P : (<obj> P) i ⊣⊢ ∀ j, P j.
Proof. by unseal. Qed.
Lemma monPred_at_subjectively i P : (<subj> P) i ⊣⊢ ∃ j, P j.
Proof. by unseal. Qed.
Lemma monPred_at_persistently_if i p P : (<pers>?p P) i ⊣⊢ <pers>?p (P i).
Proof. destruct p=>//=. apply monPred_at_persistently. Qed.
Lemma monPred_at_affinely i P : (<affine> P) i ⊣⊢ <affine> (P i).
Proof. by rewrite /bi_affinely monPred_at_and monPred_at_emp. Qed.
Lemma monPred_at_affinely_if i p P : (<affine>?p P) i ⊣⊢ <affine>?p (P i).
Proof. destruct p=>//=. apply monPred_at_affinely. Qed.
Lemma monPred_at_intuitionistically i P : (□ P) i ⊣⊢ □ (P i).
Proof. by rewrite /bi_intuitionistically monPred_at_affinely monPred_at_persistently. Qed.
Lemma monPred_at_intuitionistically_if i p P : (□?p P) i ⊣⊢ □?p (P i).
Proof. destruct p=>//=. apply monPred_at_intuitionistically. Qed.

Lemma monPred_at_absorbingly i P : (<absorb> P) i ⊣⊢ <absorb> (P i).
Proof. by rewrite /bi_absorbingly monPred_at_sep monPred_at_pure. Qed.

Lemma monPred_wand_force i P Q : (P -∗ Q) i -∗ (P i -∗ Q i).
Proof. unseal. rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim //. Qed.
Lemma monPred_impl_force i P Q : (P → Q) i -∗ (P i → Q i).
Proof. unseal. rewrite bi.forall_elim bi.pure_impl_forall bi.forall_elim //. Qed.

(* Laws for monPred_objectively and of Objective. *)
Lemma monPred_objectively_elim P : <obj> P ⊢ P.
Proof. rewrite monPred_objectively_unfold. unseal. split=>?. apply bi.forall_elim. Qed.
Lemma monPred_objectively_idemp P : <obj> <obj> P ⊣⊢ <obj> P.
Proof.
  apply bi.equiv_spec; split; [by apply monPred_objectively_elim|].
  unseal. split=>i /=. by apply bi.forall_intro=>_.
Qed.

Lemma monPred_objectively_forall {A} (Φ : A → monPred) : <obj> (∀ x, Φ x) ⊣⊢ ∀ x, <obj> (Φ x).
Proof.
  unseal. split=>i. apply bi.equiv_spec; split=>/=;
    do 2 apply bi.forall_intro=>?; by do 2 rewrite bi.forall_elim.
Qed.
Lemma monPred_objectively_and P Q : <obj> (P ∧ Q) ⊣⊢ <obj> P ∧ <obj> Q.
Proof.
  unseal. split=>i. apply bi.equiv_spec; split=>/=.
  - apply bi.and_intro; do 2 f_equiv. apply bi.and_elim_l. apply bi.and_elim_r.
  - apply bi.forall_intro=>?. by rewrite !bi.forall_elim.
Qed.
Lemma monPred_objectively_exist {A} (Φ : A → monPred) :
  (∃ x, <obj> (Φ x)) ⊢ <obj> (∃ x, (Φ x)).
Proof. apply bi.exist_elim=>?. f_equiv. apply bi.exist_intro. Qed.
Lemma monPred_objectively_or P Q : <obj> P ∨ <obj> Q ⊢ <obj> (P ∨ Q).
Proof. apply bi.or_elim; f_equiv. apply bi.or_intro_l. apply bi.or_intro_r. Qed.

Lemma monPred_objectively_sep_2 P Q : <obj> P ∗ <obj> Q ⊢ <obj> (P ∗ Q).
Proof. unseal. split=>i /=. apply bi.forall_intro=>?. by rewrite !bi.forall_elim. Qed.
Lemma monPred_objectively_sep `{BiIndexBottom bot} P Q : <obj> (P ∗ Q) ⊣⊢ <obj> P ∗ <obj> Q.
Proof.
  apply bi.equiv_spec, conj, monPred_objectively_sep_2. unseal. split=>i /=.
  rewrite (bi.forall_elim bot). by f_equiv; apply bi.forall_intro=>j; f_equiv.
Qed.
Lemma monPred_objectively_embed (P : PROP) : <obj> ⎡P⎤ ⊣⊢ ⎡P⎤.
Proof.
  apply bi.equiv_spec; split; unseal; split=>i /=.
  by rewrite (bi.forall_elim inhabitant). by apply bi.forall_intro.
Qed.
Lemma monPred_objectively_emp : <obj> (emp : monPred) ⊣⊢ emp.
Proof. rewrite monPred_emp_unfold. apply monPred_objectively_embed. Qed.
Lemma monPred_objectively_pure φ : <obj> (⌜ φ ⌝ : monPred) ⊣⊢ ⌜ φ ⌝.
Proof. rewrite monPred_pure_unfold. apply monPred_objectively_embed. Qed.

Lemma monPred_subjectively_intro P : P ⊢ <subj> P.
Proof. unseal. split=>?. apply bi.exist_intro. Qed.

Lemma monPred_subjectively_forall {A} (Φ : A → monPred) :
  (<subj> (∀ x, Φ x)) ⊢ ∀ x, <subj> (Φ x).
Proof. apply bi.forall_intro=>?. f_equiv. apply bi.forall_elim. Qed.
Lemma monPred_subjectively_and P Q : <subj> (P ∧ Q) ⊢ <subj> P ∧ <subj> Q.
Proof. apply bi.and_intro; f_equiv. apply bi.and_elim_l. apply bi.and_elim_r. Qed.
Lemma monPred_subjectively_exist {A} (Φ : A → monPred) : <subj> (∃ x, Φ x) ⊣⊢ ∃ x, <subj> (Φ x).
Proof.
  unseal. split=>i. apply bi.equiv_spec; split=>/=;
    do 2 apply bi.exist_elim=>?; by do 2 rewrite -bi.exist_intro.
Qed.
Lemma monPred_subjectively_or P Q : <subj> (P ∨ Q) ⊣⊢ <subj> P ∨ <subj> Q.
Proof.
  unseal. split=>i. apply bi.equiv_spec; split=>/=.
  - apply bi.exist_elim=>?. by rewrite -!bi.exist_intro.
  - apply bi.or_elim; do 2 f_equiv. apply bi.or_intro_l. apply bi.or_intro_r.
Qed.

Lemma monPred_subjectively_sep P Q : <subj> (P ∗ Q) ⊢ <subj> P ∗ <subj> Q.
Proof. unseal. split=>i /=. apply bi.exist_elim=>?. by rewrite -!bi.exist_intro. Qed.

Lemma monPred_subjectively_idemp P : <subj> <subj> P ⊣⊢ <subj> P.
Proof.
  apply bi.equiv_spec; split; [|by apply monPred_subjectively_intro].
  unseal. split=>i /=. by apply bi.exist_elim=>_.
Qed.

Lemma objective_objectively P `{!Objective P} : P ⊢ <obj> P.
Proof.
  rewrite monPred_objectively_unfold /= embed_forall. apply bi.forall_intro=>?.
  split=>?. unseal. apply objective_at, _.
Qed.
Lemma objective_subjectively P `{!Objective P} : <subj> P ⊢ P.
Proof.
  rewrite monPred_subjectively_unfold /= embed_exist. apply bi.exist_elim=>?.
  split=>?. unseal. apply objective_at, _.
Qed.

Global Instance embed_objective (P : PROP) : @Objective I PROP ⎡P⎤.
Proof. intros ??. by unseal. Qed.
Global Instance pure_objective φ : @Objective I PROP ⌜φ⌝.
Proof. intros ??. by unseal. Qed.
Global Instance emp_objective : @Objective I PROP emp.
Proof. intros ??. by unseal. Qed.
Global Instance objectively_objective P : Objective (<obj> P).
Proof. intros ??. by unseal. Qed.
Global Instance subjectively_objective P : Objective (<subj> P).
Proof. intros ??. by unseal. Qed.

Global Instance and_objective P Q `{!Objective P, !Objective Q} : Objective (P ∧ Q).
Proof. intros i j. unseal. by rewrite !(objective_at _ i j). Qed.
Global Instance or_objective P Q `{!Objective P, !Objective Q} : Objective (P ∨ Q).
Proof. intros i j. by rewrite !monPred_at_or !(objective_at _ i j). Qed.
Global Instance impl_objective P Q `{!Objective P, !Objective Q} : Objective (P → Q).
Proof.
  intros i j. unseal. rewrite (bi.forall_elim i) bi.pure_impl_forall.
  rewrite bi.forall_elim //. apply bi.forall_intro=> k.
  rewrite bi.pure_impl_forall. apply bi.forall_intro=>_.
  rewrite (objective_at Q i). by rewrite (objective_at P k).
Qed.
Global Instance forall_objective {A} Φ {H : ∀ x : A, Objective (Φ x)} :
  @Objective I PROP (∀ x, Φ x)%I.
Proof. intros i j. unseal. do 2 f_equiv. by apply objective_at. Qed.
Global Instance exists_objective {A} Φ {H : ∀ x : A, Objective (Φ x)} :
  @Objective I PROP (∃ x, Φ x)%I.
Proof. intros i j. unseal. do 2 f_equiv. by apply objective_at. Qed.

Global Instance sep_objective P Q `{!Objective P, !Objective Q} : Objective (P ∗ Q).
Proof. intros i j. unseal. by rewrite !(objective_at _ i j). Qed.
Global Instance wand_objective P Q `{!Objective P, !Objective Q} : Objective (P -∗ Q).
Proof.
  intros i j. unseal. rewrite (bi.forall_elim i) bi.pure_impl_forall.
  rewrite bi.forall_elim //. apply bi.forall_intro=> k.
  rewrite bi.pure_impl_forall. apply bi.forall_intro=>_.
  rewrite (objective_at Q i). by rewrite (objective_at P k).
Qed.
Global Instance persistently_objective P `{!Objective P} : Objective (<pers> P).
Proof. intros i j. unseal. by rewrite objective_at. Qed.

Global Instance affinely_objective P `{!Objective P} : Objective (<affine> P).
Proof. rewrite /bi_affinely. apply _. Qed.
Global Instance intuitionistically_objective P `{!Objective P} : Objective (□ P).
Proof. rewrite /bi_intuitionistically. apply _. Qed.
Global Instance absorbingly_objective P `{!Objective P} : Objective (<absorb> P).
Proof. rewrite /bi_absorbingly. apply _. Qed.
Global Instance persistently_if_objective P p `{!Objective P} : Objective (<pers>?p P).
Proof. rewrite /bi_persistently_if. destruct p; apply _. Qed.
Global Instance affinely_if_objective P p `{!Objective P} : Objective (<affine>?p P).
Proof. rewrite /bi_affinely_if. destruct p; apply _. Qed.
Global Instance intuitionistically_if_objective P p `{!Objective P} : Objective (□?p P).
Proof. rewrite /bi_intuitionistically_if. destruct p; apply _. Qed.

(** monPred_in *)
Lemma monPred_in_intro P : P ⊢ ∃ i, monPred_in i ∧ ⎡P i⎤.
Proof.
  unseal. split=>i /=.
  rewrite /= -(bi.exist_intro i). apply bi.and_intro=>//. by apply bi.pure_intro.
Qed.
Lemma monPred_in_elim P i : monPred_in i -∗ ⎡P i⎤ → P .
Proof.
  apply bi.impl_intro_r. unseal. split=>i' /=.
  eapply bi.pure_elim; [apply bi.and_elim_l|]=>?. rewrite bi.and_elim_r. by f_equiv.
Qed.

(** Big op *)
Global Instance monPred_at_monoid_and_homomorphism i :
  MonoidHomomorphism bi_and bi_and (≡) (flip monPred_at i).
Proof. split; [split|]; try apply _. apply monPred_at_and. apply monPred_at_pure. Qed.
Global Instance monPred_at_monoid_or_homomorphism i :
  MonoidHomomorphism bi_or bi_or (≡) (flip monPred_at i).
Proof. split; [split|]; try apply _. apply monPred_at_or. apply monPred_at_pure. Qed.
Global Instance monPred_at_monoid_sep_homomorphism i :
  MonoidHomomorphism bi_sep bi_sep (≡) (flip monPred_at i).
Proof. split; [split|]; try apply _. apply monPred_at_sep. apply monPred_at_emp. Qed.

Lemma monPred_at_big_sepL {A} i (Φ : nat → A → monPred) l :
  ([∗ list] k↦x ∈ l, Φ k x) i ⊣⊢ [∗ list] k↦x ∈ l, Φ k x i.
Proof. apply (big_opL_commute (flip monPred_at i)). Qed.
Lemma monPred_at_big_sepM `{Countable K} {A} i (Φ : K → A → monPred) (m : gmap K A) :
  ([∗ map] k↦x ∈ m, Φ k x) i ⊣⊢ [∗ map] k↦x ∈ m, Φ k x i.
Proof. apply (big_opM_commute (flip monPred_at i)). Qed.
Lemma monPred_at_big_sepS `{Countable A} i (Φ : A → monPred) (X : gset A) :
  ([∗ set] y ∈ X, Φ y) i ⊣⊢ [∗ set] y ∈ X, Φ y i.
Proof. apply (big_opS_commute (flip monPred_at i)). Qed.
Lemma monPred_at_big_sepMS `{Countable A} i (Φ : A → monPred) (X : gmultiset A) :
  ([∗ mset] y ∈ X, Φ y) i ⊣⊢ ([∗ mset] y ∈ X, Φ y i).
Proof. apply (big_opMS_commute (flip monPred_at i)). Qed.

Global Instance monPred_objectively_monoid_and_homomorphism :
  MonoidHomomorphism bi_and bi_and (≡) (@monPred_objectively I PROP).
Proof.
  split; [split|]; try apply _. apply monPred_objectively_and.
  apply monPred_objectively_pure.
Qed.
Global Instance monPred_objectively_monoid_sep_entails_homomorphism :
  MonoidHomomorphism bi_sep bi_sep (flip (⊢)) (@monPred_objectively I PROP).
Proof.
  split; [split|]; try apply _. apply monPred_objectively_sep_2.
  by rewrite monPred_objectively_emp.
Qed.
Global Instance monPred_objectively_monoid_sep_homomorphism `{BiIndexBottom bot} :
  MonoidHomomorphism bi_sep bi_sep (≡) (@monPred_objectively I PROP).
Proof.
  split; [split|]; try apply _. apply monPred_objectively_sep.
  by rewrite monPred_objectively_emp.
Qed.

Lemma monPred_objectively_big_sepL_entails {A} (Φ : nat → A → monPred) l :
  ([∗ list] k↦x ∈ l, <obj> (Φ k x)) ⊢ <obj> ([∗ list] k↦x ∈ l, Φ k x).
Proof. apply (big_opL_commute monPred_objectively (R:=flip (⊢))). Qed.
Lemma monPred_objectively_big_sepM_entails
      `{Countable K} {A} (Φ : K → A → monPred) (m : gmap K A) :
  ([∗ map] k↦x ∈ m, <obj> (Φ k x)) ⊢ <obj> ([∗ map] k↦x ∈ m, Φ k x).
Proof. apply (big_opM_commute monPred_objectively (R:=flip (⊢))). Qed.
Lemma monPred_objectively_big_sepS_entails `{Countable A} (Φ : A → monPred) (X : gset A) :
  ([∗ set] y ∈ X, <obj> (Φ y)) ⊢ <obj> ([∗ set] y ∈ X, Φ y).
Proof. apply (big_opS_commute monPred_objectively (R:=flip (⊢))). Qed.
Lemma monPred_objectively_big_sepMS_entails `{Countable A} (Φ : A → monPred) (X : gmultiset A) :
  ([∗ mset] y ∈ X, <obj> (Φ y)) ⊢ <obj> ([∗ mset] y ∈ X, Φ y).
Proof. apply (big_opMS_commute monPred_objectively (R:=flip (⊢))). Qed.

Lemma monPred_objectively_big_sepL `{BiIndexBottom bot} {A} (Φ : nat → A → monPred) l :
  <obj> ([∗ list] k↦x ∈ l, Φ k x) ⊣⊢ ([∗ list] k↦x ∈ l, <obj> (Φ k x)).
Proof. apply (big_opL_commute _). Qed.
Lemma monPred_objectively_big_sepM `{BiIndexBottom bot} `{Countable K} {A}
      (Φ : K → A → monPred) (m : gmap K A) :
  <obj> ([∗ map] k↦x ∈ m, Φ k x) ⊣⊢ ([∗ map] k↦x ∈ m, <obj> (Φ k x)).
Proof. apply (big_opM_commute _). Qed.
Lemma monPred_objectively_big_sepS `{BiIndexBottom bot} `{Countable A}
      (Φ : A → monPred) (X : gset A) :
  <obj> ([∗ set] y ∈ X, Φ y) ⊣⊢ ([∗ set] y ∈ X, <obj> (Φ y)).
Proof. apply (big_opS_commute _). Qed.
Lemma monPred_objectively_big_sepMS `{BiIndexBottom bot} `{Countable A}
      (Φ : A → monPred) (X : gmultiset A) :
  <obj> ([∗ mset] y ∈ X, Φ y) ⊣⊢  ([∗ mset] y ∈ X, <obj> (Φ y)).
Proof. apply (big_opMS_commute _). Qed.

Global Instance big_sepL_objective {A} (l : list A) Φ `{∀ n x, Objective (Φ n x)} :
  @Objective I PROP ([∗ list] n↦x ∈ l, Φ n x)%I.
Proof. generalize dependent Φ. induction l=>/=; apply _. Qed.
Global Instance big_sepM_objective `{Countable K} {A}
       (Φ : K → A → monPred) (m : gmap K A) `{∀ k x, Objective (Φ k x)} :
  Objective ([∗ map] k↦x ∈ m, Φ k x)%I.
Proof. intros ??. rewrite !monPred_at_big_sepM. do 3 f_equiv. by apply objective_at. Qed.
Global Instance big_sepS_objective `{Countable A} (Φ : A → monPred)
       (X : gset A) `{∀ y, Objective (Φ y)} :
  Objective ([∗ set] y ∈ X, Φ y)%I.
Proof. intros ??. rewrite !monPred_at_big_sepS. do 2 f_equiv. by apply objective_at. Qed.
Global Instance big_sepMS_objective `{Countable A} (Φ : A → monPred)
       (X : gmultiset A) `{∀ y, Objective (Φ y)} :
  Objective ([∗ mset] y ∈ X, Φ y)%I.
Proof. intros ??. rewrite !monPred_at_big_sepMS. do 2 f_equiv. by apply objective_at. Qed.

(** BUpd *)
Program Definition monPred_bupd_def `{BiBUpd PROP} (P : monPred) : monPred :=
  MonPred (λ i, |==> P i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_bupd_aux `{BiBUpd PROP} : seal monPred_bupd_def. by eexists. Qed.
Definition monPred_bupd `{BiBUpd PROP} : BUpd _ := monPred_bupd_aux.(unseal).
Definition monPred_bupd_eq `{BiBUpd PROP} : @bupd _ monPred_bupd = _ :=
  monPred_bupd_aux.(seal_eq).

Lemma monPred_bupd_mixin `{BiBUpd PROP} : BiBUpdMixin monPredI monPred_bupd.
Proof.
  split; rewrite monPred_bupd_eq.
  - split=>/= i. solve_proper.
  - intros P. split=>/= i. apply bupd_intro.
  - intros P Q HPQ. split=>/= i. by rewrite HPQ.
  - intros P. split=>/= i. apply bupd_trans.
  - intros P Q. split=>/= i. rewrite !monPred_at_sep /=. apply bupd_frame_r.
Qed.
Global Instance monPred_bi_bupd `{BiBUpd PROP} : BiBUpd monPredI :=
  {| bi_bupd_mixin := monPred_bupd_mixin |}.

Lemma monPred_at_bupd `{BiBUpd PROP} i P : (|==> P) i ⊣⊢ |==> P i.
Proof. by rewrite monPred_bupd_eq. Qed.

Global Instance bupd_objective `{BiBUpd PROP} P `{!Objective P} :
  Objective (|==> P)%I.
Proof. intros ??. by rewrite !monPred_at_bupd objective_at. Qed.

Global Instance monPred_bi_embed_bupd `{BiBUpd PROP} :
  BiEmbedBUpd PROP monPredI.
Proof. split. split=>i /=. by rewrite monPred_at_bupd !monPred_at_embed. Qed.
End bi_facts.

Section sbi_facts.
Context {I : biIndex} {PROP : sbi}.
Local Notation monPred := (monPred I PROP).
Local Notation monPredSI := (monPredSI I PROP).
Implicit Types i : I.
Implicit Types P Q : monPred.

Global Instance monPred_at_timeless P i : Timeless P → Timeless (P i).
Proof. move => [] /(_ i). unfold Timeless. by unseal. Qed.
Global Instance monPred_in_timeless i0 : Timeless (@monPred_in I PROP i0).
Proof. split => ? /=. unseal. apply timeless, _. Qed.
Global Instance monPred_objectively_timeless P : Timeless P → Timeless (<obj> P).
Proof.
  move=>[]. unfold Timeless. unseal=>Hti. split=> ? /=.
  by apply timeless, bi.forall_timeless.
Qed.
Global Instance monPred_subjectively_timeless P : Timeless P → Timeless (<subj> P).
Proof.
  move=>[]. unfold Timeless. unseal=>Hti. split=> ? /=.
  by apply timeless, bi.exist_timeless.
Qed.

Global Instance monPred_sbi_embed : SbiEmbed PROP monPredSI.
Proof.
  split; unseal=> //. intros ? P Q.
  apply (@bi.f_equiv _ _ _ (λ P, monPred_at P inhabitant)); solve_proper.
Qed.

Lemma monPred_internal_eq_unfold : @sbi_internal_eq monPredSI = λ A x y, ⎡ x ≡ y ⎤%I.
Proof. by unseal. Qed.

(** Unfolding lemmas *)
Lemma monPred_at_internal_eq {A : ofeT} i (a b : A) :
  @monPred_at I PROP (a ≡ b) i ⊣⊢ a ≡ b.
Proof. rewrite monPred_internal_eq_unfold. by apply monPred_at_embed. Qed.
Lemma monPred_at_later i P : (▷ P) i ⊣⊢ ▷ P i.
Proof. by unseal. Qed.
Lemma monPred_at_laterN n i P : (▷^n P) i ⊣⊢ ▷^n P i.
Proof. induction n; first done. rewrite /= monPred_at_later IHn //. Qed.
Lemma monPred_at_except_0 i P : (◇ P) i ⊣⊢ ◇ P i.
Proof. by unseal. Qed.

Lemma monPred_equivI {PROP' : sbi} P Q :
  P ≡ Q ⊣⊢@{PROP'} ∀ i, P i ≡ Q i.
Proof.
  apply bi.equiv_spec. split.
  - apply bi.forall_intro=>?. apply (bi.f_equiv (flip monPred_at _)).
  - by rewrite -{2}(sig_monPred_sig P) -{2}(sig_monPred_sig Q)
               -bi.f_equiv -bi.sig_equivI !bi.ofe_fun_equivI.
Qed.

(** Objective  *)
Global Instance internal_eq_objective {A : ofeT} (x y : A) :
  @Objective I PROP (x ≡ y).
Proof. intros ??. by unseal. Qed.

Global Instance later_objective P `{!Objective P} : Objective (▷ P).
Proof. intros ??. unseal. by rewrite objective_at. Qed.
Global Instance laterN_objective P `{!Objective P} n : Objective (▷^n P).
Proof. induction n; apply _. Qed.
Global Instance except0_objective P `{!Objective P} : Objective (◇ P).
Proof. rewrite /sbi_except_0. apply _. Qed.

(** FUpd  *)
Program Definition monPred_fupd_def `{BiFUpd PROP} (E1 E2 : coPset)
        (P : monPred) : monPred :=
  MonPred (λ i, |={E1,E2}=> P i)%I _.
Next Obligation. solve_proper. Qed.
Definition monPred_fupd_aux `{BiFUpd PROP} : seal monPred_fupd_def. by eexists. Qed.
Definition monPred_fupd `{BiFUpd PROP} : FUpd _ := monPred_fupd_aux.(unseal).
Definition monPred_fupd_eq `{BiFUpd PROP} : @fupd _ monPred_fupd = _ :=
  monPred_fupd_aux.(seal_eq).

Lemma monPred_fupd_mixin `{BiFUpd PROP} : BiFUpdMixin monPredSI monPred_fupd.
Proof.
  split; rewrite monPred_fupd_eq.
  - split=>/= i. solve_proper.
  - intros E1 E2 P HE12. split=>/= i. by apply fupd_intro_mask.
  - intros E1 E2 P. split=>/= i. by rewrite monPred_at_except_0 except_0_fupd.
  - intros E1 E2 P Q HPQ. split=>/= i. by rewrite HPQ.
  - intros E1 E2 E3 P. split=>/= i. apply fupd_trans.
  - intros E1 E2 Ef P HE1f. split=>/= i.
    rewrite monPred_impl_force monPred_at_pure -fupd_mask_frame_r' //.
  - intros E1 E2 P Q. split=>/= i. by rewrite !monPred_at_sep /= fupd_frame_r.
Qed.
Global Instance monPred_bi_fupd `{BiFUpd PROP} : BiFUpd monPredSI :=
  {| bi_fupd_mixin := monPred_fupd_mixin |}.
Global Instance monPred_bi_bupd_fupd `{BiBUpdFUpd PROP} : BiBUpdFUpd monPredSI.
Proof.
  intros E P. split=>/= i. rewrite monPred_at_bupd monPred_fupd_eq bupd_fupd //=.
Qed.
Global Instance monPred_bi_embed_fupd `{BiFUpd PROP} : BiEmbedFUpd PROP monPredSI.
Proof. split. split=>i /=. by rewrite monPred_fupd_eq /= !monPred_at_embed. Qed.

Lemma monPred_at_fupd `{BiFUpd PROP} i E1 E2 P :
  (|={E1,E2}=> P) i ⊣⊢ |={E1,E2}=> P i.
Proof. by rewrite monPred_fupd_eq. Qed.

Global Instance fupd_objective E1 E2 P `{!Objective P} `{BiFUpd PROP} :
  Objective (|={E1,E2}=> P)%I.
Proof. intros ??. by rewrite !monPred_at_fupd objective_at. Qed.

(** Plainly *)
Definition monPred_plainly_def `{BiPlainly PROP} P : monPred :=
  MonPred (λ _, ∀ i, ■ (P i))%I _.
Definition monPred_plainly_aux `{BiPlainly PROP} : seal monPred_plainly_def. by eexists. Qed.
Definition monPred_plainly `{BiPlainly PROP} : Plainly _ := monPred_plainly_aux.(unseal).
Definition monPred_plainly_eq `{BiPlainly PROP} : @plainly _ monPred_plainly = _ := monPred_plainly_aux.(seal_eq).

Lemma monPred_plainly_mixin `{BiPlainly PROP} : BiPlainlyMixin monPredSI monPred_plainly.
Proof.
  split; rewrite monPred_plainly_eq; try unseal.
  - by (split=> ? /=; repeat f_equiv).
  - intros P Q [?]. split=> i /=. by do 3 f_equiv.
  - intros P. split=> i /=. by rewrite bi.forall_elim plainly_elim_persistently.
  - intros P. split=> i /=. repeat setoid_rewrite <-plainly_forall.
    rewrite -plainly_idemp_2. f_equiv. by apply bi.forall_intro=>_.
  - intros A Ψ. split=> i /=. apply bi.forall_intro=> j.
    rewrite plainly_forall. apply bi.forall_intro=> a. by rewrite !bi.forall_elim.
  - intros P Q. split=> i /=. repeat setoid_rewrite bi.pure_impl_forall.
    repeat setoid_rewrite <-plainly_forall.
    repeat setoid_rewrite bi.persistently_forall. do 4 f_equiv.
    apply persistently_impl_plainly.
  - intros P Q. split=> i /=.
    repeat setoid_rewrite bi.pure_impl_forall. rewrite 2!bi.forall_elim //.
    repeat setoid_rewrite <-plainly_forall.
    setoid_rewrite plainly_impl_plainly. f_equiv.
    do 3 apply bi.forall_intro => ?. f_equiv. rewrite bi.forall_elim //.
  - intros P. split=> i /=. apply bi.forall_intro=>_. by apply plainly_emp_intro.
  - intros P Q. split=> i. apply bi.sep_elim_l, _.
  - intros P Q. split=> i /=. rewrite (monPred_equivI P Q). f_equiv=> j.
    by rewrite -prop_ext !(bi.forall_elim j) !bi.pure_True // !bi.True_impl.
  - intros P. split=> i /=.
    rewrite bi.later_forall. f_equiv=> j. by rewrite -later_plainly_1.
  - intros P. split=> i /=.
    rewrite bi.later_forall. f_equiv=> j. by rewrite -later_plainly_2.
Qed.
Global Instance monPred_bi_plainly `{BiPlainly PROP} : BiPlainly monPredSI :=
  {| bi_plainly_mixin := monPred_plainly_mixin |}.

Global Instance monPred_bi_plainly_exist `{BiPlainly PROP} `{@BiIndexBottom I bot} :
  BiPlainlyExist PROP → BiPlainlyExist monPredSI.
Proof.
  split=>?/=. rewrite monPred_plainly_eq /=. repeat setoid_rewrite monPred_at_exist.
  rewrite (bi.forall_elim bot) plainly_exist_1. do 2 f_equiv.
  apply bi.forall_intro=>?. by do 2 f_equiv.
Qed.

Global Instance monPred_bi_embed_plainly `{BiPlainly PROP} :
  BiEmbedPlainly PROP monPredSI.
Proof. apply bi_embed_plainly_emp, _. Qed.

Lemma monPred_plainly_unfold `{BiPlainly PROP} : plainly = λ P, ⎡ ∀ i, ■ (P i) ⎤%I.
Proof. by rewrite monPred_plainly_eq monPred_embed_eq. Qed.
Lemma monPred_at_plainly `{BiPlainly PROP} i P : (■ P) i ⊣⊢ ∀ j, ■ (P j).
Proof. by rewrite monPred_plainly_eq. Qed.

Global Instance monPred_bi_bupd_plainly `{BiBUpdPlainly PROP} : BiBUpdPlainly monPredSI.
Proof.
  intros P. split=> /= i.
  rewrite monPred_at_bupd monPred_at_plainly bi.forall_elim. apply bupd_plainly.
Qed.

Global Instance monPred_at_plain `{BiPlainly PROP} P i : Plain P → Plain (P i).
Proof. move => [] /(_ i). rewrite /Plain monPred_at_plainly bi.forall_elim //. Qed.

Global Instance monPred_bi_fupd_plainly `{BiFUpdPlainly PROP} : BiFUpdPlainly monPredSI.
Proof.
  split; rewrite !monPred_fupd_eq; try unseal.
  - intros E P. split=>/= i.
    by rewrite monPred_at_plainly (bi.forall_elim i) fupd_plainly_mask_empty.
  - intros E P R. split=>/= i.
    rewrite (bi.forall_elim i) bi.pure_True // bi.True_impl.
    by rewrite monPred_at_plainly (bi.forall_elim i) fupd_plainly_keep_l.
  - intros E P. split=>/= i.
    by rewrite monPred_at_plainly (bi.forall_elim i) fupd_plainly_later.
  - intros E A Φ. split=>/= i.
    rewrite -fupd_plainly_forall_2. apply bi.forall_mono=> x.
    by rewrite monPred_at_plainly (bi.forall_elim i).
Qed.

Global Instance plainly_objective `{BiPlainly PROP} P : Objective (■ P).
Proof. rewrite monPred_plainly_unfold. apply _. Qed.
Global Instance plainly_if_objective `{BiPlainly PROP} P p `{!Objective P} :
  Objective (■?p P).
Proof. rewrite /plainly_if. destruct p; apply _. Qed.

Global Instance monPred_objectively_plain `{BiPlainly PROP} P : Plain P → Plain (<obj> P).
Proof. rewrite monPred_objectively_unfold. apply _. Qed.
Global Instance monPred_subjectively_plain `{BiPlainly PROP} P : Plain P → Plain (<subj> P).
Proof. rewrite monPred_subjectively_unfold. apply _. Qed.
End sbi_facts.


Require Import Examples.AutoSep.

(** * A trivial example to make sure the separation logic proof automation isn't completely borked *)

Definition readS : spec := SPEC("x") reserving 1
  Al v,
  PRE[V] V "x" =*> v
  POST[R] [| R = v |] * V "x" =*> v.

Definition read := bmodule "read" {{
  bfunction "read"("x", "y") [readS]
    "y" <-* "x";;
    If ("y" = 0) {
      "x" *<- 0
    } else {
      "x" *<- "y"
    } ;;
    "y" <-* "x";;
    Return "y"
  end
}}.

Theorem readOk : moduleOk read.
(*TIME  Clear Timing Profile. *)
  vcgen; abstract sep_auto.
(*TIME  Print Timing Profile. *)
Qed.


Require Import Coq.Strings.String Coq.Relations.Relation_Definitions Coq.Classes.RelationClasses.

Set Implicit Arguments.

Local Open Scope string_scope.

Class Serializable A :=
  { to_string : A -> string }.
Class Deserializable A :=
  { from_string : string -> option A * string }.

Definition option_lift_relation {A B} (f : A -> B -> Prop) (a : option A) (b : option B)
: Prop
  := match a, b with
       | Some a', Some b' => f a' b'
       | None, None => True
       | _, _ => False
     end.

Instance option_lift_relation_refl {A R} `{Reflexive A R} : Reflexive (option_lift_relation R).
Proof.
  repeat (intros [] || intro); hnf; eauto.
Defined.

Instance option_lift_relation_sym {A R} `{Symmetric A R} : Symmetric (option_lift_relation R).
Proof.
  repeat (intros [] || intro); hnf; eauto.
Defined.

Instance option_lift_relation_trans {A R} `{Transitive A R} : Transitive (option_lift_relation R).
Proof.
  repeat (intros [] || intro); hnf; eauto.
Defined.

Class PrefixSerializable A (R : relation A) :=
  { serialize :> Serializable A;
    deserialize :> Deserializable A;
    from_to_string : forall x, option_lift_relation R (fst (from_string (to_string x))) (Some x) /\ snd (from_string (to_string x)) = "";
    prefix_closed : forall s1 s2 x, option_lift_relation R (fst (from_string s1)) (Some x) -> option_lift_relation R (fst (from_string (s1 ++ s2))) (Some x) /\ snd (from_string (s1 ++ s2)) = snd (from_string s1) ++ s2 }.

Arguments PrefixSerializable : clear implicits.

Definition from_to_string_1 {A R} `{PrefixSerializable A R} x := proj1 (from_to_string x).
Definition from_to_string_2 {A R} `{PrefixSerializable A R} x := proj2 (from_to_string x).
Definition prefix_closed_1 {A R} `{PrefixSerializable A R} s1 s2 x H
  := proj1 (prefix_closed s1 s2 x H).
Definition prefix_closed_2 {A R} `{PrefixSerializable A R} s1 s2 x H
  := proj2 (prefix_closed s1 s2 x H).

Definition from_to_string_1_eq {A} `{PrefixSerializable A eq} x
: fst (from_string (to_string x)) = Some x.
Proof.
  pose proof (from_to_string_1 x) as H'.
  hnf in H'; simpl in *.
  destruct (fst (from_string (to_string x))); subst; tauto.
Qed.
Definition prefix_closed_1_eq {A} `{PrefixSerializable A eq} s1 s2 x
: fst (from_string s1) = Some x -> fst (from_string (s1 ++ s2)) = Some x.
Proof.
  intro H'.
  pose proof (prefix_closed_1 s1 s2 x).
  destruct (fst (from_string s1)); simpl in *; try congruence.
  destruct (fst (from_string (s1 ++ s2))); simpl in *; try congruence.
  inversion H'; intuition (subst; eauto).
Qed.
Definition prefix_closed_2_refl {A R} `{Reflexive A R} `{PrefixSerializable A R} s1 s2 x
: fst (from_string s1) = Some x -> snd (from_string (s1 ++ s2)) = snd (from_string s1) ++ s2.
Proof.
  intro H'.
  eapply prefix_closed_2.
  rewrite H'.
  reflexivity.
Qed.

Arguments serialize _ _ !_ / .
Arguments deserialize _ _ !_ / .


From isla Require Import opsem.

Definition a3c : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x8" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DefineConst 14%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 13%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x21" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.