(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Abstract Array Block.  *)

Set Implicit Arguments.

Require Import ZArith Morphisms.
Require Import hpattern vgtac DBin DLat DProd DMap DPow DomBasic.
Require Import VocabA.

Module ArrInfo <: LAT.

(** Abstract type of array information is unit. *)

Include Bin.

Definition make (_ : unit) : t := top.

Definition plus_offset (x : t) : t := x.

Lemma plus_offset_mor : Proper (eq ==> eq) plus_offset.
Proof. unfold plus_offset; by intros x1 x2 Hx. Qed.

Lemma plus_offset_non_bot :
  forall (x : t) (Hx : ~ eq x bot), ~ eq (plus_offset x) bot.
Proof. i; destruct x; by ss. Qed.

Definition minus_offset (x : t) : t := x.

Lemma minus_offset_mor : Proper (eq ==> eq) minus_offset.
Proof. unfold minus_offset; by intros x1 x2 Hx. Qed.

Lemma minus_offset_non_bot :
  forall (x : t) (Hx : ~ eq x bot), ~ eq (minus_offset x) bot.
Proof. i; destruct x; by ss. Qed.

End ArrInfo.

Module ArrayBlk <: LAT.

(** ArrayBlock is a map from allocsites to array informations. *)

Include Map Allocsite ArrInfo.

Definition make (a : Allocsite.t) : t := add a (ArrInfo.make tt) bot.

Definition extern (a : Allocsite.t) : t := add a ArrInfo.top empty.

Definition plus_offset (ab : t) : t :=
  map (fun a => ArrInfo.plus_offset a) ab.

Lemma plus_offset_mor : Proper (eq ==> eq) plus_offset.
Proof.
unfold eq, plus_offset; intros ab1 ab2 Hab.
intro a. specialize Hab with a.
unfold find, map in *.
do 2 rewrite M.P.F.map_o.
remember (M.find a ab1) as opt_v1; destruct opt_v1 as [v1|]
; remember (M.find a ab2) as opt_v2; destruct opt_v2 as [v2|]; s.
- by apply ArrInfo.plus_offset_mor.
- by unfold ArrInfo.plus_offset.
- by unfold ArrInfo.plus_offset.
- by apply ArrInfo.eq_refl.
Qed.

Definition minus_offset (ab : t) : t :=
  map (fun a => ArrInfo.minus_offset a) ab.

Lemma minus_offset_mor : Proper (eq ==> eq) minus_offset.
Proof.
unfold eq, minus_offset; intros ab1 ab2 Hab.
intro a. specialize Hab with a.
unfold find, map in *.
do 2 rewrite M.P.F.map_o.
remember (M.find a ab1) as opt_v1; destruct opt_v1 as [v1|]
; remember (M.find a ab2) as opt_v2; destruct opt_v2 as [v2|]; s.
- by apply ArrInfo.minus_offset_mor.
- by unfold ArrInfo.minus_offset.
- by unfold ArrInfo.minus_offset.
- by apply ArrInfo.eq_refl.
Qed.

Definition cast_array (ab : t) : t := ab.

Lemma cast_array_mor : Proper (eq ==> eq) cast_array.
Proof. unfold cast_array, eq; by intros ab1 ab2 Hab. Qed.

Definition cast_array_int (z : Z) (ab : t) : t := cast_array ab.

Lemma cast_array_int_mor (z : Z) : Proper (eq ==> eq) (cast_array_int z).
Proof. unfold cast_array_int; by intros ab1 ab2 Hab. Qed.

Definition pow_loc_of_array (ab : t) : PowLoc.t :=
  let add_array_to_pow_loc k v acc :=
      if ArrInfo.eq_dec ArrInfo.bot v then acc else
        PowLoc.add (loc_of_allocsite k) acc in
  foldi add_array_to_pow_loc ab PowLoc.empty.

Lemma pow_loc_of_array_mor : Proper (eq ==> PowLoc.eq) pow_loc_of_array.
Proof.
unfold pow_loc_of_array; intros ab1 ab2 Hab.
apply foldi_mor; [| | |by auto|by apply PowLoc.eq_refl].
- constructor.
  + intros x; by apply PowLoc.eq_refl.
  + intros x y z; by apply PowLoc.eq_trans.
  + intros x y; by apply PowLoc.eq_sym.
- intros k1 k2 Hk v1 v2 Hv acc1 acc2 Hacc.
  destruct (ArrInfo.eq_dec ArrInfo.bot v1), (ArrInfo.eq_dec ArrInfo.bot v2)
  ; [ by auto
    | elim f; apply ArrInfo.eq_trans with v1; by auto
    | elim f; apply ArrInfo.eq_trans with v2; by auto using ArrInfo.eq_sym |].
  apply PowLoc.add_mor; [|by auto].
  by apply loc_of_allocsite_mor.
- i. destruct (ArrInfo.eq_dec ArrInfo.bot v); [by apply PowLoc.eq_refl|tauto].
Qed.

Definition pow_loc_of_struct_w_field (ab : t) (f : Field.t) : PowLoc.t :=
  let add_to_pow_loc a v acc :=
    if ArrInfo.eq_dec v ArrInfo.bot then acc else
      PowLoc.add (append_field (loc_of_allocsite a) f) acc in
  foldi add_to_pow_loc ab PowLoc.bot.

Lemma pow_loc_of_struct_w_field_mor :
  Proper (eq ==> Field.eq ==> PowLoc.eq) pow_loc_of_struct_w_field.
Proof.
intros s1 s2 Hs f1 f2 Hf. unfold pow_loc_of_struct_w_field. apply foldi2_1.
- i; dest_if_dec. elim f; by apply ArrInfo.eq_sym.
- i; dest_if_dec. elim f; by apply ArrInfo.eq_sym.
- i; dest_if_dec.
  + dest_if_dec.
    elim f; apply ArrInfo.eq_trans with v1; [by apply ArrInfo.eq_sym|by auto].
  + dest_if_dec.
    * elim f; apply ArrInfo.eq_trans with v2; by auto.
    * apply PowLoc.add_mor; [|by auto].
      apply append_field_mor; [by apply loc_of_allocsite_mor|by auto].
- by apply PowLoc.eq_refl.
- by auto.
Qed.

End ArrayBlk.


(** The second isomorphism theorem [isomorphic_second_isomorphism]. *)

Require Import
  HoTT.Types.Sigma
  HoTT.Types.Universe
  HoTT.HSet
  HoTT.HIT.quotient
  HoTT.UnivalenceImpliesFunext
  HoTT.Classes.interfaces.canonical_names
  HoTT.Algebra.UniversalAlgebra.Finitary.ua_isomorphic
  HoTT.Algebra.UniversalAlgebra.Finitary.ua_subalgebra
  HoTT.Algebra.UniversalAlgebra.Finitary.ua_quotient_algebra.

Import
  algebra_notations
  quotient_algebra_notations
  subalgebra_notations
  isomorphic_notations.

Local Notation i := (hom_inc_subalgebra _ _).

(** This section defines [cong_trace] and proves that it is a
    congruence, the restriction of a congruence to a subalgebra. *)

Section cong_trace.
  Context
    {σ : Signature} {A : Algebra σ}
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}
    (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}.

  Definition cong_trace (s : Sort σ) (x : (A&P) s) (y : (A&P) s)
    := Φ s (i s x) (i s y).

  Global Instance equiv_rel_trace_congruence (s : Sort σ)
    : EquivRel (cong_trace s).
  Proof.
    unfold cong_trace.
    constructor.
    - intros [y Y]. reflexivity.
    - intros [y1 Y1] [y2 Y2] S. by symmetry.
    - intros [y1 Y1] [y2 Y2] [y3 Y3] S T. by transitivity y2.
  Qed.

  Lemma for_all_2_family_prod_trace_congruence {w : SymbolType σ}
    (a b : FamilyProd (A&P) (dom_symboltype w))
    (R : for_all_2_family_prod (A&P) (A&P) cong_trace a b)
    : for_all_2_family_prod A A Φ
        (map_family_prod i a) (map_family_prod i b).
  Proof with try assumption.
    induction w...
    destruct a as [x a], b as [y b], R as [C R].
    split...
    apply IHw...
  Qed.

  Global Instance ops_compatible_trace_trace
    : OpsCompatible (A&P) cong_trace.
  Proof.
    intros u a b R.
    refine (transport (λ X, Φ _ X _)
              (path_homomorphism_ap_operation i u a)^ _).
    refine (transport (λ X, Φ _ _ X)
              (path_homomorphism_ap_operation i u b)^ _).
    apply (ops_compatible_cong A Φ).
    exact (for_all_2_family_prod_trace_congruence a b R).
  Qed.

  Global Instance is_congruence_trace : IsCongruence (A&P) cong_trace.
  Proof.
    apply (@BuildIsCongruence _ (A&P) cong_trace);
      [intros; apply (is_mere_relation_cong A Φ) | exact _ ..].
  Qed.
End cong_trace.

(** The following section defines the [is_subalgebra_class] subalgebra
    predicate, which induces a subalgebra of [A/Φ]. *)

Section is_subalgebra_class.
  Context `{Univalence}
    {σ : Signature} {A : Algebra σ}
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}
    (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}.

  Definition is_subalgebra_class (s : Sort σ) (x : (A/Φ) s) : hProp
    := hexists (λ (y : (A&P) s), in_class (Φ s) x (i s y)).

  Lemma op_closed_subalgebra_is_subalgebra_class {w : SymbolType σ}
    (γ : Operation (A/Φ) w)
    (α : Operation A w)
    (Q : ComputeOpQuotient A Φ α γ)
    (C : ClosedUnderOp A P α)
    : ClosedUnderOp (A/Φ) is_subalgebra_class γ.
  Proof.
    induction w.
    - specialize (Q tt). apply tr.
      exists (α; C).
      cbn in Q. destruct Q^.
      exact (EquivRel_Reflexive α).
    - refine (quotient_ind_prop (Φ t) _ _). intro x.
      refine (Trunc_rec _).
      intros [y R].
      apply (IHw (γ (class_of (Φ t) x)) (α (i t y))).
      + intro a.
        destruct (related_classes_eq (Φ t) R)^.
        apply (Q (i t y,a)).
      + apply C. exact y.2.
  Qed.

  Definition is_closed_under_ops_is_subalgebra_class
    : IsClosedUnderOps (A/Φ) is_subalgebra_class.
  Proof.
    intro u.
    eapply op_closed_subalgebra_is_subalgebra_class.
    - apply compute_op_quotient.
    - apply is_closed_under_ops_subalgebra_predicate. exact _.
  Qed.

  Global Instance is_subalgebra_predicate_is_subalgebra_class
    : IsSubalgebraPredicate (A/Φ) is_subalgebra_class.
  Proof.
    apply BuildIsSubalgebraPredicate.
    apply is_closed_under_ops_is_subalgebra_class.
  Qed.
End is_subalgebra_class.

(** The next section proves the second isomorphism theorem,

    <<
      (A&P) / (cong_trace P Φ) ≅ (A/Φ) & (is_subalgebra_class P Φ).
    >>
*)

(* There is an alternative proof using the first isomorphism theorem,
   but the direct proof below seems simpler in HoTT. *)

Section second_isomorphism.
  Context `{Univalence}
    {σ : Signature} (A : Algebra σ)
    (P : ∀ s, A s → Type) `{!IsSubalgebraPredicate A P}
    (Φ : ∀ s, Relation (A s)) `{!IsCongruence A Φ}.

  Local Notation Ψ := (cong_trace P Φ).

  Local Notation Q := (is_subalgebra_class P Φ).

  Definition def_second_isomorphism (s : Sort σ)
    : ((A&P) / Ψ) s → ((A/Φ) & Q) s
    := quotient_rec (Ψ s)
        (λ (x : (A&P) s),
         (class_of (Φ s) (i s x); tr (x; EquivRel_Reflexive x)))
        (λ (x y : (A&P) s) (T : Ψ s x y),
         path_sigma_hprop (class_of (Φ s) (i s x); _)
           (class_of (Φ s) (i s y); _) (related_classes_eq (Φ s) T)).

  Lemma oppreserving_second_isomorphism {w : SymbolType σ}
    (α : Operation A w) (γ : Operation (A/Φ) w)
    (ζ : Operation ((A&P) / Ψ) w) (CA : ClosedUnderOp (A/Φ) Q γ)
    (CB : ClosedUnderOp A P α) (QA : ComputeOpQuotient A Φ α γ)
    (QB : ComputeOpQuotient (A&P) Ψ (op_subalgebra A P α CB) ζ)
    : OpPreserving def_second_isomorphism ζ (op_subalgebra (A/Φ) Q γ CA).
  Proof.
    unfold ComputeOpQuotient in *.
    induction w; cbn in *.
    - apply path_sigma_hprop.
      cbn. destruct (QB tt)^, (QA tt)^.
      by apply related_classes_eq.
    - refine (quotient_ind_prop (Ψ t) _ _). intro x.
      apply (IHw (α (i t x)) (γ (class_of (Φ t) (i t x)))
              (ζ (class_of (Ψ t) x))
              (CA (class_of (Φ t) (i t x)) (tr (x; _)))
              (CB (i t x) x.2)).
      + intro a. exact (QA (i t x, a)).
      + intro a. exact (QB (x, a)).
  Defined.

  Global Instance is_homomorphism_second_isomorphism
    : IsHomomorphism def_second_isomorphism.
  Proof.
    intro u.
    eapply oppreserving_second_isomorphism.
    - apply (compute_op_quotient A).
    - apply (compute_op_quotient (A&P)).
  Defined.

  Definition hom_second_isomorphism
    : Homomorphism ((A&P) / Ψ) ((A/Φ) & Q)
    := BuildHomomorphism def_second_isomorphism.

  Global Instance embedding_second_isomorphism (s : Sort σ)
    : IsEmbedding (hom_second_isomorphism s).
  Proof.
    apply isembedding_isinj_hset.
    refine (quotient_ind_prop (Ψ s) _ _). intro x.
    refine (quotient_ind_prop (Ψ s) _ _). intros y p.
    apply related_classes_eq.
    exact (classes_eq_related (Φ s) (i s x) (i s y) (p..1)).
  Qed.

  Global Instance surjection_second_isomorphism (s : Sort σ)
    : IsSurjection (hom_second_isomorphism s).
  Proof.
    apply BuildIsSurjection.
    intros [y S].
    generalize dependent S.
    generalize dependent y.
    refine (quotient_ind_prop (Φ s) _ _). intros y S.
    refine (Trunc_rec _ S). intros [y' S']. apply tr.
    exists (class_of _ y').
    apply path_sigma_hprop.
    by apply related_classes_eq.
  Qed.

  Theorem is_isomorphism_second_isomorphism
    : IsIsomorphism hom_second_isomorphism.
  Proof.
    intro s. apply isequiv_surj_emb; exact _.
  Qed.

  Global Existing Instance is_isomorphism_second_isomorphism.

  Theorem isomorphic_second_isomorphism : (A&P) / Ψ ≅ (A/Φ) & Q.
  Proof.
    exact (BuildIsomorphic def_second_isomorphism).
  Defined.

  Corollary id_second_isomorphism : (A&P) / Ψ = (A/Φ) & Q.
  Proof.
    exact (id_isomorphic isomorphic_second_isomorphism).
  Defined.
End second_isomorphism.


From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util Sorts SAst SLiftSubst SCommon Conversion ITyping
               ITypingInversions ITypingLemmata Uniqueness SubjectReduction.
Import ListNotations.

Section Admissible.

Context `{Sort_notion : Sorts.notion}.

Lemma sorts_in_sort :
  forall {Σ Γ s1 s2 s3},
    Σ ;;; Γ |-i sSort s1 : sSort s3 ->
    Σ ;;; Γ |-i sSort s2 : sSort s3 ->
    s1 = s2.
Proof.
  intros Σ Γ s1 s2 s3 h1 h2.
  ttinv h1. ttinv h2.
  pose proof (conv_trans h (conv_sym h0)) as eq.
  pose proof (sort_conv_inv eq).
  apply succ_inj. assumption.
Defined.

(* We state some admissible typing rules *)

Lemma heq_sort :
  forall {Σ Γ s1 s2 A B p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq (sSort s1) A (sSort s2) B ->
    Σ ;;; Γ |-i p : sHeq (sSort s1) A (sSort s1) B.
Proof.
  intros Σ Γ s1 s2 A B p hg h.
  destruct (istype_type hg h) as [? i].
  ttinv i.
  ttinv h1. ttinv h0.
  pose proof (conv_trans h4 (conv_sym h6)) as eq.
  pose proof (sort_conv_inv eq).
  assert (s1 = s2) by (apply succ_inj ; assumption).
  subst.
  assumption.
Defined.

Lemma type_HeqToEq' :
  forall {Σ Γ A u v p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A u A v ->
    Σ ;;; Γ |-i sHeqToEq p : sEq A u v.
Proof.
  intros Σ Γ A u v p hg h.
  destruct (istype_type hg h) as [? i].
  ttinv i.
  eapply type_HeqToEq ; eassumption.
Defined.

Fact sort_heq :
  forall {Σ Γ s1 s2 A B e},
    type_glob Σ ->
    Σ ;;; Γ |-i e : sHeq (sSort s1) A (sSort s2) B ->
    Σ ;;; Γ |-i sHeqToEq e : sEq (sSort s1) A B.
Proof.
  intros Σ Γ s1 s2 A B e hg h.
  destruct (istype_type hg h) as [? hty].
  ttinv hty.
  eapply type_HeqToEq' ; try assumption.
  eapply heq_sort ; eassumption.
Defined.

Corollary sort_heq_ex :
  forall {Σ Γ s1 s2 A B e},
    type_glob Σ ->
    Σ ;;; Γ |-i e : sHeq (sSort s1) A (sSort s2) B ->
    ∑ p, Σ ;;; Γ |-i p : sEq (sSort s1) A B.
Proof.
  intros Σ Γ s A B e hg h.
  eexists. now eapply sort_heq.
Defined.

Lemma type_HeqRefl' :
  forall {Σ Γ A a},
    type_glob Σ ->
    Σ ;;; Γ |-i a : A ->
    Σ ;;; Γ |-i sHeqRefl A a : sHeq A a A a.
Proof.
  intros Σ Γ A a hg h.
  destruct (istype_type hg h).
  eapply type_HeqRefl ; eassumption.
Defined.

Lemma type_HeqSym' :
  forall {Σ Γ A a B b p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A a B b ->
    Σ ;;; Γ |-i sHeqSym p : sHeq B b A a.
Proof.
  intros Σ Γ A a B b p hg h.
  destruct (istype_type hg h) as [? hty].
  ttinv hty.
  now eapply type_HeqSym.
Defined.

Lemma type_HeqTrans' :
  forall {Σ Γ A a B b C c p q},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A a B b ->
    Σ ;;; Γ |-i q : sHeq B b C c ->
    Σ ;;; Γ |-i sHeqTrans p q : sHeq A a C c.
Proof.
  intros Σ Γ A a B b C c p q hg h1 h2.
  destruct (istype_type hg h1) as [? i1].
  ttinv i1.
  destruct (istype_type hg h2) as [? i2].
  ttinv i2.
  eapply type_HeqTrans. all: try eassumption.
  eapply type_conv.
  - eassumption.
  - eapply type_Sort. eapply typing_wf ; eassumption.
  - apply (uniqueness hg h7 h).
Defined.

Lemma type_HeqTransport' :
  forall {Σ Γ s A B p t},
    type_glob Σ ->
    Σ ;;; Γ |-i t : A ->
    Σ ;;; Γ |-i p : sEq (sSort s) A B ->
    Σ ;;; Γ |-i sHeqTransport p t : sHeq A t B (sTransport A B p t).
Proof.
  intros Σ Γ s A B p t hg ht hp.
  destruct (istype_type hg hp) as [? i].
  ttinv i.
  eapply type_HeqTransport ; eassumption.
Defined.

Lemma type_Pair' :
  forall {Σ Γ A B u v n s},
    type_glob Σ ->
    Σ ;;; Γ |-i u : A ->
    Σ ;;; Γ |-i v : B{ 0 := u } ->
    Σ ;;; Γ ,, A |-i B : sSort s ->
    Σ ;;; Γ |-i sPair A B u v : sSum n A B.
Proof.
  intros Σ Γ A B u v n s hg hu hv hB.
  destruct (istype_type hg hu) as [? iu].
  eapply type_Pair ; eassumption.
Defined.

Lemma type_Pi1' :
  forall {Σ Γ p n A B},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sSum n A B ->
    Σ ;;; Γ |-i sPi1 A B p : A.
Proof.
  intros Σ Γ p n A B hg h.
  destruct (istype_type hg h) as [? ip]. ttinv ip.
  eapply type_Pi1 ; eassumption.
Defined.

Lemma type_Pi2' :
  forall {Σ Γ p n A B},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sSum n A B ->
    Σ ;;; Γ |-i sPi2 A B p : B{ 0 := sPi1 A B p }.
Proof.
  intros Σ Γ p n A B hg h.
  destruct (istype_type hg h) as [? ip]. ttinv ip.
  eapply type_Pi2 ; eassumption.
Defined.

Lemma type_CongProd'' :
  forall {Σ Γ s z nx ny A1 A2 B1 B2 pA pB},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ |-i sCongProd B1 B2 pA pB :
    sHeq (sSort (Sorts.prod_sort s z)) (sProd nx A1 B1)
         (sSort (Sorts.prod_sort s z)) (sProd ny A2 B2).
Proof.
  intros Σ Γ s z nx ny A1 A2 B1 B2 pA pB hg hpA hpB hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  eapply type_CongProd.
  all: eassumption.
Defined.

Lemma prod_sorts :
  forall {Σ Γ s1 s2 z1 z2 A1 A2 B1 B2 pA pB},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    (s1 = s2) * (z1 = z2).
Proof.
  intros Σ Γ s1 s2 z1 z2 A1 A2 B1 B2 pA pB hg hpA hpB.
  split.
  - destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
    eapply sorts_in_sort ; eassumption.
  - destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
    eapply sorts_in_sort ; eassumption.
Defined.

Lemma type_CongProd' :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 pA pB},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ |-i sCongProd B1 B2 pA pB :
    sHeq (sSort (Sorts.prod_sort s1 z1)) (sProd nx A1 B1)
         (sSort (Sorts.prod_sort s2 z2)) (sProd ny A2 B2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 pA pB hg hpA hpB hB1 hB2.
  destruct (prod_sorts hg hpA hpB) as [e1 e2].
  subst. rename z2 into z, s2 into s.
  eapply type_CongProd'' ; eassumption.
Defined.

Lemma type_CongLambda'' :
  forall {Σ Γ s z nx ny A1 A2 B1 B2 t1 t2 pA pB pt},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pt : sHeq ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 ((lift 1 1 t1){ 0 := sProjT1 (sRel 0) })
                 ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) })
                 ((lift 1 1 t2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ ,, A1 |-i t1 : B1 ->
    Σ ;;; Γ ,, A2 |-i t2 : B2 ->
    Σ ;;; Γ |-i sCongLambda B1 B2 t1 t2 pA pB pt :
               sHeq (sProd nx A1 B1) (sLambda nx A1 B1 t1)
                    (sProd ny A2 B2) (sLambda ny A2 B2 t2).
Proof.
  intros Σ Γ s z nx ny A1 A2 B1 B2 t1 t2 pA pB pt
         hg hpA hpB hpt hB1 hB2 ht1 ht2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpt) as [? ipt]. ttinv ipt.
  eapply type_CongLambda ; eassumption.
Defined.

Lemma type_CongLambda' :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 t1 t2 pA pB pt},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pt : sHeq ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 ((lift 1 1 t1){ 0 := sProjT1 (sRel 0) })
                 ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) })
                 ((lift 1 1 t2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ ,, A1 |-i t1 : B1 ->
    Σ ;;; Γ ,, A2 |-i t2 : B2 ->
    Σ ;;; Γ |-i sCongLambda B1 B2 t1 t2 pA pB pt :
               sHeq (sProd nx A1 B1) (sLambda nx A1 B1 t1)
                    (sProd ny A2 B2) (sLambda ny A2 B2 t2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 t1 t2 pA pB pt hg
         hpA hpB hpt hB1 hB2 ht1 ht2.
  destruct (prod_sorts hg hpA hpB) as [e1 e2].
  subst. rename s2 into s, z2 into z.
  eapply type_CongLambda'' ; eassumption.
Defined.

Lemma type_CongApp'' :
  forall {Σ Γ s z nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pu : sHeq (sProd nx A1 B1) u1 (sProd ny A2 B2) u2 ->
    Σ ;;; Γ |-i pv : sHeq A1 v1 A2 v2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ |-i sCongApp B1 B2 pu pA pB pv :
               sHeq (B1{0 := v1}) (sApp u1 A1 B1 v1)
                    (B2{0 := v2}) (sApp u2 A2 B2 v2).
Proof.
  intros Σ Γ s z nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv
         hg hpA hpB hpu hpv hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpu) as [? ipu]. ttinv ipu.
  destruct (istype_type hg hpv) as [? ipv]. ttinv ipv.
  eapply type_CongApp ; eassumption.
Defined.

Lemma type_CongApp' :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pu : sHeq (sProd nx A1 B1) u1 (sProd ny A2 B2) u2 ->
    Σ ;;; Γ |-i pv : sHeq A1 v1 A2 v2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ |-i sCongApp B1 B2 pu pA pB pv :
               sHeq (B1{0 := v1}) (sApp u1 A1 B1 v1)
                    (B2{0 := v2}) (sApp u2 A2 B2 v2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv
         hg hpA hpB hpu hpv hB1 hB2.
  destruct (prod_sorts hg hpA hpB).
  subst. rename s2 into s, z2 into z.
  eapply type_CongApp'' ; eassumption.
Defined.

Lemma type_CongSum'' :
  forall {Σ Γ s z nx ny A1 A2 B1 B2 pA pB},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ |-i sCongSum B1 B2 pA pB :
    sHeq (sSort (Sorts.sum_sort s z)) (sSum nx A1 B1)
         (sSort (Sorts.sum_sort s z)) (sSum ny A2 B2).
Proof.
  intros Σ Γ s z nx ny A1 A2 B1 B2 pA pB hg hpA hpB hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  eapply type_CongSum.
  all: eassumption.
Defined.

Lemma type_CongSum' :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 pA pB},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ |-i sCongSum B1 B2 pA pB :
    sHeq (sSort (Sorts.sum_sort s1 z1)) (sSum nx A1 B1)
         (sSort (Sorts.sum_sort s2 z2)) (sSum ny A2 B2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 pA pB hg hpA hpB hB1 hB2.
  destruct (prod_sorts hg hpA hpB) as [e1 e2].
  subst. rename z2 into z, s2 into s.
  eapply type_CongSum'' ; eassumption.
Defined.

Lemma type_CongPair'' :
  forall {Σ Γ s z nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ ;;; Γ |-i pv : sHeq (B1{ 0 := u1 }) v1 (B2{ 0 := u2 }) v2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ |-i sCongPair B1 B2 pA pB pu pv :
    sHeq (sSum nx A1 B1) (sPair A1 B1 u1 v1)
         (sSum ny A2 B2) (sPair A2 B2 u2 v2).
Proof.
  intros Σ Γ s z nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv
         hg hpA hpB hpu hpv hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpu) as [? ipu]. ttinv ipu.
  destruct (istype_type hg hpv) as [? ipv]. ttinv ipv.
  eapply type_CongPair.
  all: eassumption.
Defined.

Lemma type_CongPair' :
  forall {Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ ;;; Γ |-i pv : sHeq (B1{ 0 := u1 }) v1 (B2{ 0 := u2 }) v2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ |-i sCongPair B1 B2 pA pB pu pv :
    sHeq (sSum nx A1 B1) (sPair A1 B1 u1 v1)
         (sSum ny A2 B2) (sPair A2 B2 u2 v2).
Proof.
  intros Σ Γ s1 s2 z1 z2 nx ny A1 A2 B1 B2 u1 u2 v1 v2 pA pB pu pv
         hg hpA hpB hpu hpv hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpu) as [? ipu]. ttinv ipu.
  destruct (istype_type hg hpv) as [? ipv]. ttinv ipv.
  destruct (prod_sorts hg hpA hpB) as [e1 e2].
  subst.
  eapply type_CongPair''.
  all: eassumption.
Defined.

Lemma type_CongPi1'' :
  forall {Σ Γ nx ny pA s A1 A2 pB z B1 B2 pp p1 p2},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pp : sHeq (sSum nx A1 B1) p1 (sSum ny A2 B2) p2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ |-i sCongPi1 B1 B2 pA pB pp : sHeq A1 (sPi1 A1 B1 p1)
                                              A2 (sPi1 A2 B2 p2).
Proof.
  intros Σ Γ nx ny pA s A1 A2 pB z B1 B2 pp p1 p2 hg hpA hpB hpp hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpp) as [? ipp]. ttinv ipp.
  eapply type_CongPi1 ; eassumption.
Defined.

Lemma type_CongPi1' :
  forall {Σ Γ nx ny pA s1 s2 A1 A2 pB z1 z2 B1 B2 pp p1 p2},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pp : sHeq (sSum nx A1 B1) p1 (sSum ny A2 B2) p2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ |-i sCongPi1 B1 B2 pA pB pp : sHeq A1 (sPi1 A1 B1 p1)
                                              A2 (sPi1 A2 B2 p2).
Proof.
  intros Σ Γ nx ny pA s1 s2 A1 A2 pB z1 z2 B1 B2 pp p1 p2 hg hpA hpB hpp hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpp) as [? ipp]. ttinv ipp.
  pose proof (sorts_in_sort h5 h3). subst.
  pose proof (sorts_in_sort h0 h). subst.
  eapply type_CongPi1'' ; eassumption.
Defined.

Lemma type_CongPi2'' :
  forall {Σ Γ nx ny pA s A1 A2 pB z B1 B2 pp p1 p2},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pp : sHeq (sSum nx A1 B1) p1 (sSum ny A2 B2) p2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z ->
    Σ ;;; Γ |-i sCongPi2 B1 B2 pA pB pp :
               sHeq (B1{ 0 := sPi1 A1 B1 p1}) (sPi2 A1 B1 p1)
                    (B2{ 0 := sPi1 A2 B2 p2}) (sPi2 A2 B2 p2).
Proof.
  intros Σ Γ nx ny pA s A1 A2 pB z B1 B2 pp p1 p2 hg hpA hpB hpp hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpp) as [? ipp]. ttinv ipp.
  eapply type_CongPi2 ; eassumption.
Defined.

Lemma type_CongPi2' :
  forall {Σ Γ nx ny pA s1 s2 A1 A2 pB z1 z2 B1 B2 pp p1 p2},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ ,, (sPack A1 A2)
    |-i pB : sHeq (sSort z1) ((lift 1 1 B1){ 0 := sProjT1 (sRel 0) })
                 (sSort z2) ((lift 1 1 B2){ 0 := sProjT2 (sRel 0) }) ->
    Σ ;;; Γ |-i pp : sHeq (sSum nx A1 B1) p1 (sSum ny A2 B2) p2 ->
    Σ ;;; Γ ,, A1 |-i B1 : sSort z1 ->
    Σ ;;; Γ ,, A2 |-i B2 : sSort z2 ->
    Σ ;;; Γ |-i sCongPi2 B1 B2 pA pB pp :
               sHeq (B1{ 0 := sPi1 A1 B1 p1}) (sPi2 A1 B1 p1)
                    (B2{ 0 := sPi1 A2 B2 p2}) (sPi2 A2 B2 p2).
Proof.
  intros Σ Γ nx ny pA s1 s2 A1 A2 pB z1 z2 B1 B2 pp p1 p2 hg hpA hpB hpp hB1 hB2.
  destruct (istype_type hg hpA) as [? ipA]. ttinv ipA.
  destruct (istype_type hg hpB) as [? ipB]. ttinv ipB.
  destruct (istype_type hg hpp) as [? ipp]. ttinv ipp.
  pose proof (sorts_in_sort h5 h3). subst.
  pose proof (sorts_in_sort h0 h). subst.
  eapply type_CongPi2'' ; eassumption.
Defined.

Lemma type_CongEq'' :
  forall {Σ Γ s A1 A2 u1 u2 v1 v2 pA pu pv},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ ;;; Γ |-i pv : sHeq A1 v1 A2 v2 ->
    Σ ;;; Γ |-i sCongEq pA pu pv :
               sHeq (sSort (Sorts.eq_sort s)) (sEq A1 u1 v1)
                    (sSort (Sorts.eq_sort s)) (sEq A2 u2 v2).
Proof.
  intros Σ Γ s A1 A2 u1 u2 v1 v2 pA pu pv hg hpA hpu hpv.
  destruct (istype_type hg hpA) as [? iA]. ttinv iA.
  destruct (istype_type hg hpu) as [? iu]. ttinv iu.
  destruct (istype_type hg hpv) as [? iv]. ttinv iv.
  eapply type_CongEq.
  all: assumption.
Defined.

Lemma type_CongEq' :
  forall {Σ Γ s1 s2 A1 A2 u1 u2 v1 v2 pA pu pv},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ ;;; Γ |-i pv : sHeq A1 v1 A2 v2 ->
    Σ ;;; Γ |-i sCongEq pA pu pv
             : sHeq (sSort (Sorts.eq_sort s1)) (sEq A1 u1 v1)
                    (sSort (Sorts.eq_sort s2)) (sEq A2 u2 v2).
Proof.
  intros Σ Γ s1 s2 A1 A2 u1 u2 v1 v2 pA pu pv hg hpA hpu hpv.
  destruct (istype_type hg hpA) as [? iA]. ttinv iA.
  destruct (istype_type hg hpu) as [? iu]. ttinv iu.
  destruct (istype_type hg hpv) as [? iv]. ttinv iv.
  pose proof (sorts_in_sort h0 h). subst.
  eapply type_CongEq''.
  all: assumption.
Defined.

Lemma type_CongRefl'' :
  forall {Σ Γ s A1 A2 u1 u2 pA pu},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s) A1 (sSort s) A2 ->
    Σ ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ ;;; Γ |-i sCongRefl pA pu :
               sHeq (sEq A1 u1 u1) (sRefl A1 u1) (sEq A2 u2 u2) (sRefl A2 u2).
Proof.
  intros Σ Γ s A1 A2 u1 u2 pA pu hg hpA hpu.
  destruct (istype_type hg hpA) as [? iA]. ttinv iA.
  destruct (istype_type hg hpu) as [? iu]. ttinv iu.
  eapply type_CongRefl.
  all: eassumption.
Defined.

Lemma type_CongRefl' :
  forall {Σ Γ s1 s2 A1 A2 u1 u2 pA pu},
    type_glob Σ ->
    Σ ;;; Γ |-i pA : sHeq (sSort s1) A1 (sSort s2) A2 ->
    Σ ;;; Γ |-i pu : sHeq A1 u1 A2 u2 ->
    Σ ;;; Γ |-i sCongRefl pA pu :
               sHeq (sEq A1 u1 u1) (sRefl A1 u1) (sEq A2 u2 u2) (sRefl A2 u2).
Proof.
  intros Σ Γ s1 s2 A1 A2 u1 u2 pA pu hg hpA hpu.
  destruct (istype_type hg hpA) as [? iA]. ttinv iA.
  destruct (istype_type hg hpu) as [? iu]. ttinv iu.
  eapply type_CongRefl'' ; try eassumption.
  eapply heq_sort ; eassumption.
Defined.

Lemma type_EqToHeq' :
  forall {Σ Γ A u v p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sEq A u v ->
    Σ ;;; Γ |-i sEqToHeq p : sHeq A u A v.
Proof.
  intros Σ Γ A u v p hg h.
  destruct (istype_type hg h) as [? i]. ttinv i.
  eapply type_EqToHeq ; eassumption.
Defined.

Lemma type_ProjT1' :
  forall {Σ Γ A1 A2 p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sPack A1 A2 ->
    Σ ;;; Γ |-i sProjT1 p : A1.
Proof.
  intros Σ Γ A1 A2 p hg hp.
  destruct (istype_type hg hp) as [? i]. ttinv i.
  eapply type_ProjT1 ; [.. | eassumption] ; eassumption.
Defined.

Lemma type_ProjT2' :
  forall {Σ Γ A1 A2 p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sPack A1 A2 ->
    Σ ;;; Γ |-i sProjT2 p : A2.
Proof.
  intros Σ Γ A1 A2 p hg hp.
  destruct (istype_type hg hp) as [? i]. ttinv i.
  eapply type_ProjT2 ; [.. | eassumption] ; eassumption.
Defined.

Lemma type_ProjTe' :
  forall {Σ Γ A1 A2 p},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sPack A1 A2 ->
    Σ ;;; Γ |-i sProjTe p : sHeq A1 (sProjT1 p) A2 (sProjT2 p).
Proof.
  intros Σ Γ A1 A2 p hg hp.
  destruct (istype_type hg hp) as [? i]. ttinv i.
  eapply type_ProjTe ; [.. | eassumption] ; eassumption.
Defined.

Lemma type_Refl' :
  forall {Σ Γ A u},
    type_glob Σ ->
    Σ ;;; Γ |-i u : A ->
    Σ ;;; Γ |-i sRefl A u : sEq A u u.
Proof.
  intros Σ Γ A u hg h.
  destruct (istype_type hg h) as [? i].
  eapply type_Refl ; eassumption.
Defined.

Lemma type_Transport' :
  forall {Σ Γ s T1 T2 p t},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sEq (sSort s) T1 T2 ->
    Σ ;;; Γ |-i t : T1 ->
    Σ ;;; Γ |-i sTransport T1 T2 p t : T2.
Proof.
  intros Σ Γ s T1 T2 p t hg hp ht.
  destruct (istype_type hg hp) as [? i]. ttinv i.
  eapply type_Transport ; eassumption.
Defined.

Lemma type_HeqTypeEq' :
  forall {Σ Γ A u B v p s},
    type_glob Σ ->
    Σ ;;; Γ |-i p : sHeq A u B v ->
    Σ ;;; Γ |-i A : sSort s ->
    Σ ;;; Γ |-i sHeqTypeEq A B p : sEq (sSort s) A B.
Proof.
  intros Σ Γ A u B v p s hg hp hA.
  destruct (istype_type hg hp) as [? i]. ttinv i.
  eapply type_HeqTypeEq ; try eassumption.
  pose proof (uniqueness hg h0 hA).
  eapply type_conv ; try eassumption.
  eapply type_Sort. eapply typing_wf. eassumption.
Defined.

End Admissible.


From HypVeri.algebra Require Import base.

Section reg_rules.

  Context `{vmG :gen_VMG Σ}.

  Implicit Type σ : state.
  Implicit Type i : VMID.
  Implicit Type w : Word.

  Lemma reg_dupl_false r i w1 w2 :
    r @@ i ->r w1 -∗ r @@ i ->r w2 -∗ False.
  Proof using.
    rewrite reg_mapsto_eq /reg_mapsto_def.
    iIntros "Hr1 Hr2".
    iDestruct (ghost_map_elem_valid_2 with "Hr1 Hr2") as %?.
    destruct H.
    apply dfrac_valid_own_r in H.
    inversion H.
  Qed.

  Lemma reg_neq r1 r2 i j w1 w2:
    r1 @@ i ->r w1 -∗ r2 @@ j ->r w2 -∗ ⌜ r1 <> r2 ∨ i <> j⌝.
  Proof using.
    iIntros "Hr1 Hr2".
    destruct (decide (r1 = r2)).
    destruct (decide (i = j)).
    - simplify_eq /=.
      iDestruct (reg_dupl_false with "Hr1 Hr2") as %[].
    - iRight. done.
    - iLeft. done.
  Qed.

  Lemma gen_reg_valid_global1 {σ} r i w:
    ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
    r @@ i ->r w -∗
    ⌜(get_reg_global σ i r) = Some w⌝.
  Proof.
    iIntros "Hσ Hr".
    rewrite reg_mapsto_eq /reg_mapsto_def.
    iDestruct (ghost_map_lookup with "Hσ Hr") as "%Hlk".
    iPureIntro.
    rewrite /get_reg /get_reg_global.
    rewrite /get_reg_gmap in Hlk.
    apply elem_of_list_to_map_2 in Hlk.
    apply elem_of_list_In in Hlk.
    apply in_flat_map in Hlk.
    inversion Hlk as [? Hin]; clear Hlk.
    destruct Hin as [Hinv Hin].
    apply in_map_iff in Hin.
    destruct Hin as [? [Heqp Hin]].
    inversion Heqp;clear Heqp;subst.
    apply elem_of_list_In in Hin.
    apply elem_of_map_to_list' in Hin.
    done.
   Qed.

  Lemma gen_reg_valid1 {σ} r i w:
    (get_current_vm σ) = i ->
    ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
    r @@ i ->r w -∗
    ⌜(get_reg σ r) = Some w⌝.
  Proof.
    iIntros (Hcur) "Hσ Hr".
    rewrite /get_reg -Hcur.
    iApply (gen_reg_valid_global1 with "Hσ Hr").
  Qed.

  Lemma gen_reg_valid_Sep {σ} i (regs: gmap (reg_name * VMID) Word):
   (get_current_vm σ) = i ->
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   ([∗ map] r↦w ∈ regs, r.1 @@ r.2 ->r w)-∗
   ([∗ map] r↦w ∈ regs, ⌜r.2 = i -> (get_reg σ r.1) = Some w⌝).
  Proof.
    iIntros (Hcur) "Hσ Hregs".
    rewrite reg_mapsto_eq /reg_mapsto_def.
    iDestruct ((ghost_map_lookup_big regs) with "Hσ [Hregs]") as "%Hincl".
    iApply (big_sepM_proper (λ k x, (k.1, k.2)↪[gen_reg_name] x)%I);auto.
    intros k x Hlk.
    cbn.
    f_equiv.
    by destruct k.
    iApply big_sepM_pure.
    iIntros (?? Hlk Heqi).
    rewrite /get_reg /get_reg_global.
    apply (lookup_weaken _ (get_reg_gmap σ)) in Hlk;eauto.
    apply elem_of_list_to_map_2 in Hlk.
    apply elem_of_list_In in Hlk.
    apply in_flat_map in Hlk.
    destruct Hlk as [? [_ Hinp]].
    apply in_map_iff in Hinp.
    destruct Hinp as [? [Heqp Hinx]].
    inversion Heqp;subst.
    apply elem_of_list_In in Hinx.
    apply elem_of_map_to_list' in Hinx.
    by simplify_eq /=.
  Qed.

  Lemma gen_reg_valid2 {σ} i r1 w1 r2 w2:
    (get_current_vm σ) = i ->
    ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
    r1 @@ i ->r w1 -∗
    r2 @@ i ->r w2 -∗
    ⌜(get_reg σ r1) = Some w1⌝ ∗ ⌜(get_reg σ r2) = Some w2⌝.
  Proof.
    iIntros (Hcur) "Hreg Hr1 Hr2".
    iDestruct (reg_neq with "Hr1 Hr2") as %[Hneq|];[|contradiction].
    iDestruct ((gen_reg_valid_Sep i (<[(r1,i):=w1]>{[(r2,i):=w2]}))
                 with "Hreg [Hr1 Hr2]") as "%Hreg";eauto.
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iFrame.
    apply lookup_insert_None; split;eauto; intros P; by inversion P.
    iPureIntro.
    split.
    - by apply (Hreg (r1, i) w1 (lookup_insert _ (r1, i) w1)).
    - apply (Hreg (r2, i) w2);eauto.
      rewrite lookup_insert_Some;right;split;
      [intros P; inversion P; contradiction|];
      rewrite !lookup_insert //.
  Qed.

  Lemma gen_reg_valid3 {σ} i r1 w1 r2 w2 r3 w3:
   (get_current_vm σ) = i ->
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   r1 @@ i ->r w1 -∗
   r2 @@ i ->r w2 -∗
   r3 @@ i ->r w3 -∗
   ⌜(get_reg σ r1) = Some w1⌝ ∗ ⌜(get_reg σ r2) =Some w2⌝ ∗ ⌜(get_reg σ r3) = Some w3⌝.
  Proof.
    iIntros (Hcur ) "Hreg Hr1 Hr2 Hr3".
    iDestruct (reg_neq with "Hr1 Hr2") as %[Hneq1|];[|contradiction].
    iDestruct (reg_neq with "Hr2 Hr3") as %[Hneq2|];[|contradiction].
    iDestruct (reg_neq with "Hr1 Hr3") as %[Hneq3|];[|contradiction].
    iDestruct ((gen_reg_valid_Sep i ({[(r1,i):=w1;(r2,i):=w2;(r3,i):=w3]}))
                 with "Hreg [Hr1 Hr2 Hr3]") as "%Hreg";eauto.
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iFrame.
    apply lookup_insert_None; split;eauto; intros P; by inversion P.
    apply lookup_insert_None; split;eauto.
    apply lookup_insert_None; split;eauto; intros P; by inversion P.
    intros P; by inversion P.
    iPureIntro.
    split;[|split].
    - by apply (Hreg (r1, i) w1 (lookup_insert _ (r1, i) w1)).
    - apply (Hreg (r2, i) w2);eauto.
      rewrite lookup_insert_Some;right;split;
      [intros P; inversion P; contradiction|];
        by rewrite !lookup_insert.
    - apply (Hreg (r3, i) w3);eauto.
      rewrite !lookup_insert_Some.
      repeat (right;split;
      [intros P; inversion P; contradiction|]).
      left;done.
  Qed.

  Lemma gen_reg_valid4 {σ} i r1 w1 r2 w2 r3 w3 r4 w4:
   (get_current_vm σ) = i ->
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   r1 @@ i ->r w1 -∗
   r2 @@ i ->r w2 -∗
   r3 @@ i ->r w3 -∗
   r4 @@ i ->r w4 -∗
   ⌜(get_reg σ r1) = Some w1⌝ ∗ ⌜(get_reg σ r2) =Some w2⌝ ∗
   ⌜(get_reg σ r3) = Some w3⌝ ∗ ⌜(get_reg σ r4) = Some w4⌝.
  Proof.
    iIntros (Hi) "Hreg Hr1 Hr2 Hr3 Hr4".
    iDestruct (reg_neq with "Hr1 Hr2") as %[Hneq1|];[|contradiction].
    iDestruct (reg_neq with "Hr2 Hr3") as %[Hneq2|];[|contradiction].
    iDestruct (reg_neq with "Hr1 Hr3") as %[Hneq3|];[|contradiction].
    iDestruct (reg_neq with "Hr1 Hr4") as %[Hneq4|];[|contradiction].
    iDestruct (reg_neq with "Hr2 Hr4") as %[Hneq5|];[|contradiction].
    iDestruct (reg_neq with "Hr3 Hr4") as %[Hneq6|];[|contradiction].
    iDestruct ((gen_reg_valid_Sep i ({[(r1,i):=w1;(r2,i):=w2;(r3,i):=w3;(r4,i):=w4]}))
                 with "Hreg [Hr1 Hr2 Hr3 Hr4]") as "%Hreg";eauto.
    rewrite !big_sepM_insert ?big_sepM_empty;first iFrame;
    rewrite ?lookup_insert_None;repeat split;eauto;
    intros P; by inversion P.
    iPureIntro.
    split;[|split;[|split]].
    - by apply (Hreg (r1, i) w1 (lookup_insert _ (r1, i) w1)).
    - apply (Hreg (r2, i) w2);eauto.
      rewrite lookup_insert_Some;right;split;
      [intros P; inversion P; contradiction|];
        by rewrite !lookup_insert.
    - apply (Hreg (r3, i) w3);eauto.
      rewrite !lookup_insert_Some.
      repeat (right;split;
      [intros P; inversion P; contradiction|]).
      left;done.
    - apply (Hreg (r4, i) w4);eauto.
      rewrite !lookup_insert_Some.
      repeat (right;split;
      [intros P; inversion P; contradiction|]).
      left;done.
  Qed.

  Lemma gen_reg_update1_global {σ} r i w w':
    ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
    r @@ i ->r w ==∗
    ghost_map_auth gen_reg_name 1 (<[(r,i):=w']>(get_reg_gmap σ)) ∗
    r @@ i ->r w'.
  Proof.
    iIntros "Hσ Hr".
    rewrite reg_mapsto_eq /reg_mapsto_def.
    iDestruct (ghost_map_update w' with "Hσ Hr") as ">[Hσ Hr]".
      by iFrame.
  Qed.

  Lemma reg_proper {m: gmap (reg_name * VMID) Word}:
   ([∗ map] k ↦ x ∈ m, k↪[gen_reg_name] x) ⊣⊢ ([∗ map]k ↦ x ∈ m,  (k.1, k.2)↪[gen_reg_name] x).
  Proof.
    iApply (big_sepM_proper _ (λ k x, (k.1, k.2)↪[gen_reg_name] x)%I).
    intros.
    cbn.
    f_equiv.
    destruct k;done.
  Qed.

  Lemma gen_reg_update_Sep {σ} regs regs':
   dom regs = dom regs' ->
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   ([∗ map] r↦w ∈ regs,  r.1 @@ r.2 ->r w) ==∗
   ghost_map_auth gen_reg_name 1 (regs' ∪ (get_reg_gmap σ)) ∗
   ([∗ map] r↦w ∈ regs',  r.1 @@ r.2 ->r w).
  Proof.
    iIntros (Hdom) "Hσ Hr".
    rewrite reg_mapsto_eq /reg_mapsto_def.
    iDestruct (ghost_map_update_big regs regs' Hdom with "[Hσ] [Hr]") as ">[Hσ Hr]";eauto.
    by iApply reg_proper.
    rewrite reg_proper.
    by iFrame.
  Qed.

  Lemma gen_reg_update2_global {σ} r1 i1 w1 w1' r2 i2 w2 w2':
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   r1 @@ i1 ->r w1 -∗
   r2 @@ i2 ->r w2==∗
   ghost_map_auth gen_reg_name 1 (<[(r1,i1) := w1']> (<[(r2,i2) := w2']> (get_reg_gmap σ))) ∗
   r1 @@ i1 ->r w1' ∗ r2 @@ i2 ->r w2'.
  Proof.
    iIntros "Hreg Hr1 Hr2".
    iDestruct (reg_neq with "Hr1 Hr2") as %Hneq.
    iDestruct ((gen_reg_update_Sep {[(r1,i1):=w1; (r2,i2):=w2]}
                                   {[(r1,i1):=w1'; (r2,i2):=w2']}) with "Hreg [Hr1 Hr2]")
      as ">[Hreg Hr12]" ;eauto;[set_solver| | ].
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iFrame.
    destruct Hneq; apply lookup_insert_None; split;eauto; intros P; by inversion P.
    iModIntro.
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iDestruct "Hr12" as "(? & ? & _)".
    rewrite ?insert_union_singleton_l map_union_assoc.
    simplify_map_eq.
    by iFrame.
    destruct Hneq; apply lookup_insert_None; split;eauto; intros P; by inversion P.
  Qed.

  Lemma gen_reg_update3_global {σ w1 w2 w3} r1 i1 w1' r2 i2 w2' r3 i3 w3':
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   r1 @@ i1 ->r w1 -∗
   r2 @@ i2 ->r w2 -∗
   r3 @@ i3 ->r w3==∗
   ghost_map_auth gen_reg_name 1 (<[(r1,i1) := w1']> (<[(r2,i2) := w2']>
                                                            (<[(r3,i3):= w3']>(get_reg_gmap σ)))) ∗
   r1 @@ i1 ->r w1'  ∗ r2 @@ i2 ->r w2' ∗ r3 @@ i3 ->r w3'.
  Proof.
    iIntros "Hreg Hr1 Hr2 Hr3".
    iDestruct (reg_neq with "Hr1 Hr2") as %Hneq12.
    iDestruct (reg_neq with "Hr3 Hr2") as %Hneq32.
    iDestruct (reg_neq with "Hr1 Hr3") as %Hneq13.
    assert (Hlk: ∀ w3 ,  ({[(r3, i3) := w3]}: gmap _ _) !! (r2, i2) = None).
    intro. destruct Hneq32; rewrite !lookup_insert_None; split;eauto; intros P; by inversion P.
    assert (Hlk': ∀ w2 w3, ({[(r2, i2) := w2; (r3, i3) := w3]} : gmap _ _ ) !! (r1, i1) = None).
    intros. destruct Hneq12; rewrite !lookup_insert_None; repeat split;eauto;
    destruct Hneq13; intros P; by inversion P.
    iDestruct ((gen_reg_update_Sep  {[(r1,i1):=w1; (r2,i2):=w2 ;(r3,i3):=w3]}
                                   {[(r1,i1):=w1'; (r2,i2):=w2'; (r3,i3):=w3']}) with "Hreg [Hr1 Hr2 Hr3]")
      as ">[Hreg Hr123]" ;eauto;[set_solver| | ].
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iFrame.
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iDestruct "Hr123" as "(? & ? & ? & _)".
    rewrite ?insert_union_singleton_l !map_union_assoc.
    simplify_map_eq.
    by iFrame.
  Qed.

  Lemma gen_reg_update4_global {σ w1 w2 w3 w4} r1 i1 w1' r2 i2 w2' r3 i3 w3' r4 i4 w4':
   ghost_map_auth gen_reg_name 1 (get_reg_gmap σ) -∗
   r1 @@ i1 ->r w1 -∗
   r2 @@ i2 ->r w2 -∗
   r3 @@ i3 ->r w3 -∗
   r4 @@ i4 ->r w4==∗
   ghost_map_auth gen_reg_name 1 (<[(r1,i1) := w1']> (<[(r2,i2) := w2']>
                                                            (<[(r3,i3):= w3']> (<[(r4,i4):= w4']> (get_reg_gmap σ))))) ∗
   r1 @@ i1 ->r w1'  ∗ r2 @@ i2 ->r w2' ∗ r3 @@ i3 ->r w3' ∗ r4 @@ i4 ->r w4'.
  Proof.
    iIntros "Hreg Hr1 Hr2 Hr3 Hr4".
    iDestruct (reg_neq with "Hr1 Hr2") as %Hneq12.
    iDestruct (reg_neq with "Hr3 Hr2") as %Hneq32.
    iDestruct (reg_neq with "Hr1 Hr3") as %Hneq13.
    iDestruct (reg_neq with "Hr3 Hr4") as %Hneq34.
    iDestruct (reg_neq with "Hr2 Hr4") as %Hneq24.
    iDestruct (reg_neq with "Hr1 Hr4") as %Hneq14.
    assert (Hlk1 : ∀ w4, ({[(r4, i4) := w4]}: gmap _ _) !! (r3, i3) = None).
    intro. destruct Hneq34; rewrite !lookup_insert_None; split;eauto; intros P; by inversion P.
    assert (Hlk2 : ∀ w3 w4, ({[(r3, i3) := w3; (r4, i4) := w4]}: gmap _ _) !! (r2, i2) = None).
    intros. destruct Hneq32, Hneq24; rewrite !lookup_insert_None; split;eauto; set_solver.
    assert (Hlk3 : ∀ w2 w3 w4, ({[(r2, i2) := w2; (r3, i3) := w3; (r4, i4) := w4]}: gmap _ _) !! (r1, i1) = None).
    intros. destruct Hneq12, Hneq13, Hneq14; rewrite !lookup_insert_None; split;eauto; set_solver.
    assert (Hlk: ∀ w3 ,  ({[(r3, i3) := w3]}: gmap _ _) !! (r2, i2) = None).
    intro. destruct Hneq32; rewrite !lookup_insert_None; split;eauto; intros P; by inversion P.
    assert (Hlk': ∀ w2 w3, ({[(r2, i2) := w2; (r3, i3) := w3]} : gmap _ _ ) !! (r1, i1) = None).
    intros. destruct Hneq12; rewrite !lookup_insert_None; repeat split;eauto;
    destruct Hneq13; intros P; by inversion P.
    iDestruct ((gen_reg_update_Sep  {[(r1,i1):=w1; (r2,i2):=w2 ;(r3,i3):=w3;(r4,i4):=w4]}
                                   {[(r1,i1):=w1'; (r2,i2):=w2'; (r3,i3):=w3'; (r4, i4):=w4']}) with "Hreg [Hr1 Hr2 Hr3 Hr4]")
      as ">[Hreg Hr123]" ;eauto;[set_solver| | ].
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iFrame.
    rewrite !big_sepM_insert ?big_sepM_empty;eauto.
    iDestruct "Hr123" as "(? & ? & ? & ? & _)".
    rewrite ?insert_union_singleton_l !map_union_assoc.
    simplify_map_eq.
    by iFrame.
  Qed.

End reg_rules.


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 O E Eprime A B C Oprime Aprime Bprime Cprime A1 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ Oprime E /\ (wd_ B O /\ (wd_ Aprime O /\ (wd_ Aprime Oprime /\ (wd_ Bprime Oprime /\ (wd_ Oprime Cprime /\ (wd_ Bprime Cprime /\ (wd_ Aprime Cprime /\ (wd_ A Aprime /\ (wd_ C A /\ (wd_ C B /\ (wd_ O Oprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprime A1 /\ (col_ O A C /\ col_ O A B))))))))))))))))))))))))) -> col_ Bprime Oprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* $Id: CReals1.v,v 1.21 2003/03/13 12:06:24 lcf Exp $ *)

Require Export Max_AbsIR.
Require Export Expon.

Section More_Cauchy_Props.

(* Tex_Prose
\section{More properties of Cauchy sequences}

We will now define some special Cauchy sequences and prove some more useful properties about them.

The sequence defined by $x_n=\frac2(n+1)$. (don't ask why!)
*)

(* Begin_Tex_Verb *)
Lemma twice_inv_seq_Lim :
  (!SeqLimit IR [n:nat]Two[*](one_div_succ n) Zero).
(* End_Tex_Verb *)
Red; Fold (Cauchy_Lim_prop2 [n:nat]Two[*](one_div_succ n) Zero).
Apply Cauchy_Lim_prop3_prop2.
Red; Intro.
Exists (mult (2) (S k)); Intros.
Stepr ((Two::IR)[*](one_div_succ m)).
Apply AbsIR_imp_AbsSmall.
Apply leEq_wdl with (Two::IR)[*](one_div_succ m).
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
Step (!one_div_succ IR m)[*]Two.
Unfold one_div_succ; Simpl; Fold (Two::IR).
Apply shift_mult_leEq with (two_ap_zero IR).
Apply pos_two.
Unfold Snring.
RStepr (One[/]((nring (S k))[*]Two)[//](mult_resp_ap_zero ??? (nring_ap_zero ? (S k) (sym_not_eq nat (0) (S k) (O_S k))) (two_ap_zero IR))).
Apply recip_resp_leEq.
Step (Zero::IR)[*]Zero; Apply mult_resp_less_both; Try Apply leEq_reflexive.
Apply pos_nring_S.
Apply pos_two.
Step (Two::IR)[*](nring (S k)).
Apply leEq_transitive with (!nring IR m).
Apply leEq_wdl with (!nring IR (mult (2) (S k))).
Apply nring_leEq.
Assumption.
Apply nring_comm_mult.
Simpl; Step (!nring IR m)[+]Zero; Apply plus_resp_leEq_lft; Apply less_leEq; Apply pos_one.
Step (Zero::IR)[*]Zero; Apply mult_resp_leEq_both; Try Apply leEq_reflexive.
Apply less_leEq; Apply pos_two.
Apply less_leEq; Apply one_div_succ_pos.
Qed.

(* Begin_Tex_Verb *)
Definition twice_inv_seq : (CauchySeq IR).
(* End_Tex_Verb *)
Apply Build_CauchySeq with [n:nat]Two[*](!one_div_succ IR n).
Apply Cauchy_prop2_prop.
Red; Exists (Zero::IR).
Red; Fold (SeqLimit [n:nat]Two[*](!one_div_succ IR n) Zero).
Apply twice_inv_seq_Lim.
Defined.

(* Tex_Prose
Next, we prove that the sequence of absolute values of a Cauchy sequence is also Cauchy.
*)

(* Begin_Tex_Verb *)
Lemma Cauchy_Lim_abs : (seq:nat->IR)(y:IR)(Cauchy_Lim_prop2 seq y)->
  (Cauchy_Lim_prop2 [n:nat](AbsIR (seq n)) (AbsIR y)).
(* End_Tex_Verb *)
Intros.
Red; Red in H.
Intros eps He.
Elim (H eps He); Clear H.
Intros N HN.
Exists N; Intros.
Apply AbsIR_imp_AbsSmall.
Cut (AbsIR (seq m)[-]y)[<=]eps.
Intro.
2: Apply AbsSmall_imp_AbsIR; Apply HN; Assumption.
Cut (seq m)[-]y[<=]eps.
2: EApply leEq_transitive; [Apply leEq_AbsIR | Apply H0].
Intro.
Cut y[-](seq m)[<=]eps.
2: EApply leEq_transitive; [Apply leEq_AbsIR | EApply leEq_wdl; [Apply H0 | Apply AbsIR_minus]].
Intro.
Simpl; Unfold ABSIR.
Apply Max_leEq.
Apply shift_minus_leEq.
Apply Max_leEq.
Apply shift_leEq_plus'.
Apply leEq_transitive with y.
Apply shift_minus_leEq; Apply shift_leEq_plus'; Assumption.
Apply lft_leEq_Max.
Apply shift_leEq_plus'.
Apply leEq_transitive with [--]y.
Apply shift_minus_leEq; Apply shift_leEq_plus'.
RStep y[-](seq m).
Assumption.
Apply rht_leEq_Max.
Stepr [--][--]eps; Apply inv_resp_leEq.
Apply shift_leEq_minus; Apply shift_plus_leEq'.
Apply leEq_wdr with (Max (seq m) [--](seq m))[+]eps.
Apply Max_leEq.
Apply leEq_transitive with (seq m)[+]eps.
Apply shift_leEq_plus'; Assumption.
Apply plus_resp_leEq.
Apply lft_leEq_Max.
Apply leEq_transitive with [--](seq m)[+]eps.
Apply shift_leEq_plus'; RStep (seq m)[-]y; Assumption.
Apply plus_resp_leEq.
Apply rht_leEq_Max.
Unfold cg_minus.
Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Cauchy_abs : (seq:(CauchySeq IR))
  (Cauchy_prop [n:nat](AbsIR (seq n))).
(* End_Tex_Verb *)
Intro.
Apply Cauchy_prop2_prop.
Exists (AbsIR (Lim seq)).
Apply Cauchy_Lim_abs.
Apply Cauchy_complete.
Qed.

(* Begin_Tex_Verb *)
Lemma Lim_abs : (seq:(CauchySeq IR))
  (Lim (Build_CauchySeq IR ? (Cauchy_abs seq)))[=](AbsIR (Lim seq)).
(* End_Tex_Verb *)
Intros.
Apply eq_symmetric_unfolded; Apply Limits_unique.
Simpl; Apply Cauchy_Lim_abs.
Apply Cauchy_complete.
Qed.

End More_Cauchy_Props.

Section Subsequences.

(* Tex_Prose
\section{Subsequences}

We will now examine (although without formalizing it) the concept of subsequence and some of its properties.

\begin{convention} Let \verb!seq1,seq2:nat->IR!.
\end{convention}

In order for \verb!seq1! to be a subsequence of \verb!seq2!, there must be an increasing function \verb!f! growing to infinity such that \verb!(n:nat)(seq1 n)[=](seq2 (f n))!.  We assume \verb!f! to be such a function.

Finally, for some of our results it is important to assume that \verb!seq2! is monotonous.  We will mark the lemmas where this hypothesis is actually used by comment marks.
*)

Variables seq1,seq2:nat->IR.
Variable f:nat->nat.

Hypothesis monF : (m,n:nat)(le m n)->(le (f m) (f n)).
Hypothesis crescF : (n:nat){m:nat | (lt n m)/\(lt (f n) (f m))}.
Hypothesis subseq : (n:nat)(seq1 n)[=](seq2 (f n)).

Hypothesis mon_seq2 : ((m,n:nat)(le m n)->(seq2 m)[<=](seq2 n))\/((m,n:nat)(le m n)->(seq2 n)[<=](seq2 m)).

(* Begin_Tex_Verb *)
Lemma unbnd_f : (m:nat){n:nat | (lt m (f n))}.
(* End_Tex_Verb *)
Induction m.
Elim (crescF O).
Intros n Hn.
Exists n.
Inversion_clear Hn.
Apply le_lt_trans with (f O); Auto with arith.
Intros.
Elim H; Clear H; Intros n' Hn'.
Elim (crescF n').
Intros i Hi; Elim Hi; Clear Hi; Intros Hi Hi'.
Exists i.
Apply le_lt_trans with (f n'); Auto.
Qed.

Local mon_F' : (m,n:nat)(lt (f m) (f n))->(lt m n).
Intros.
Cut ~(le n m).
Intro; Apply not_ge; Auto.
Intro.
Cut (le (f n) (f m)).
Apply lt_not_le; Auto.
Apply monF; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_subseq_imp_conv_seq :
  (Cauchy_prop seq1)->(Cauchy_prop seq2). (* *)
(* End_Tex_Verb *)
Intro.
Red; Red in H.
Intros.
Elim (H e H0).
Intros N HN.
Exists (f N).
Intros.
Elim (unbnd_f m); Intros i Hi.
Apply AbsIR_imp_AbsSmall.
Apply leEq_transitive with (AbsIR (seq2 (f i))[-](seq2 (f N))).
Elim mon_seq2; Intro.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
2: Apply shift_leEq_minus; Step (seq2 (f N)); Apply H2; Assumption.
EApply leEq_wdr.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
2: Apply shift_leEq_minus; Step (seq2 (f N)); Apply H2; Apply le_trans with m; Auto with arith.
Apply minus_resp_leEq.
Apply H2; Auto with arith.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_inv_x.
2: Apply shift_minus_leEq; Stepr (seq2 (f N)); Auto.
EApply leEq_wdr.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_inv_x.
2: Apply shift_minus_leEq; Stepr (seq2 (f N)); Apply H2; Apply le_trans with m; Auto with arith.
Apply inv_resp_leEq; Apply minus_resp_leEq.
Apply H2; Auto with arith.
Apply leEq_wdl with (AbsIR (seq1 i)[-](seq1 N)).
Apply AbsSmall_imp_AbsIR; Apply HN.
Apply lt_le_weak.
Apply mon_F'; Apply le_lt_trans with m; Auto.
Apply AbsIR_wd; Algebra.
Qed.

(* Begin_Tex_Verb *)
Lemma Cprop2_seq_imp_Cprop2_subseq : (a:IR)
  (Cauchy_Lim_prop2 seq2 a)->(Cauchy_Lim_prop2 seq1 a).
(* End_Tex_Verb *)
Intros.
Red; Red in H.
Intros.
Elim (H ? H0).
Intros N HN.
Elim (unbnd_f N); Intros i Hi.
Exists i.
Intros.
Stepr (seq2 (f m))[-]a.
Apply HN.
Cut (le (f i) (f m)).
Intros; Apply le_trans with (f i); Auto with arith.
Apply monF; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma conv_seq_imp_conv_subseq :
  (Cauchy_prop seq2)->(Cauchy_prop seq1).
(* End_Tex_Verb *)
Intro.
Apply Cauchy_prop2_prop.
Cut (Cauchy_prop2 (Build_CauchySeq ?? H)).
Intro.
Elim H0; Intros a Ha; Exists a.
Apply Cprop2_seq_imp_Cprop2_subseq.
Assumption.
Exists (Lim (Build_CauchySeq ?? H)).
Apply Lim_Cauchy.
Qed.

(* Begin_Tex_Verb *)
Lemma Cprop2_subseq_imp_Cprop2_seq : (a:IR)
  (Cauchy_Lim_prop2 seq1 a)->(Cauchy_Lim_prop2 seq2 a). (* *)
(* End_Tex_Verb *)
Intros.
Cut (Cauchy_prop seq1); Intros.
2: Apply Cauchy_prop2_prop.
2: Exists a; Assumption.
Cut (Cauchy_prop seq2); Intros.
2: Apply conv_subseq_imp_conv_seq; Assumption.
Cut (Cauchy_Lim_prop2 (Build_CauchySeq ?? H1) (Lim (Build_CauchySeq ?? H1))); Intros.
2: Apply Cauchy_complete.
Cut (Cauchy_Lim_prop2 seq1 (Lim (Build_CauchySeq ?? H1))); Intros.
2: Apply Cprop2_seq_imp_Cprop2_subseq; Assumption.
Cut (Lim (Build_CauchySeq ?? H1))[=]a.
Intro.
EApply Lim_wd.
Apply H4.
Assumption.
Apply Lim_unique with seq1; Assumption.
Qed.

End Subsequences.

Section Cauchy_Subsequences.

Variables seq1,seq2:(CauchySeq IR).
Variable f:nat->nat.

Hypothesis monF : (m,n:nat)(le m n)->(le (f m) (f n)).
Hypothesis crescF : (n:nat){m:nat | (lt n m)/\(lt (f n) (f m))}.
Hypothesis subseq : (n:nat)(seq1 n)[=](seq2 (f n)).

Hypothesis mon_seq2 : ((m,n:nat)(le m n)->(seq2 m)[<=](seq2 n))\/((m,n:nat)(le m n)->(seq2 n)[<=](seq2 m)).

(* Begin_Tex_Verb *)
Lemma Lim_seq_eq_Lim_subseq : (Lim seq1)[=](Lim seq2).
(* End_Tex_Verb *)
Cut (Cauchy_Lim_prop2 seq1 (Lim seq2)).
2: Apply Cprop2_seq_imp_Cprop2_subseq with (CS_seq ? seq2) f; Auto; Apply Cauchy_complete.
Intro.
Apply eq_symmetric_unfolded.
Apply Limits_unique; Assumption.
Qed.

(* Begin_Tex_Verb *)
Lemma Lim_subseq_eq_Lim_seq : (Lim seq1)[=](Lim seq2). (* *)
(* End_Tex_Verb *)
Cut (Cauchy_Lim_prop2 seq2 (Lim seq1)).
2: Exact (Cprop2_subseq_imp_Cprop2_seq seq1 seq2 f monF crescF subseq mon_seq2 ? (Cauchy_complete seq1)).
Intro.
Apply Limits_unique; Assumption.
Qed.

End Cauchy_Subsequences.

Section Properties_of_Exponentiation.

(* Tex_Prose
\section{More properties of Exponentiation}

Finally, we prove that $x^n$ grows to infinity if $x>1$.
*)

(* Begin_Tex_Verb *)
Lemma power_big' : (R:COrdField)(x:R; n:nat)(Zero [<=] x) ->
  One[+](nring n)[*]x [<=] (One[+]x)[^]n.
(* End_Tex_Verb *)
Intros.
Induction n; Intros.
RStep (One::R).
Stepr (One::R).
Apply leEq_reflexive.
Simpl.
Apply leEq_transitive with (One[+](nring n)[*]x)[*](One[+]x).
RStepr One[+]((nring n)[+]One)[*]x[+](nring n)[*]x[^](2).
Step One[+]((nring n)[+]One)[*]x[+]Zero.
Apply plus_resp_leEq_lft.
Apply mult_resp_nonneg.
Step ((nring (0))::R). Apply nring_leEq. Auto with arith.
Apply sqr_nonneg.
Apply mult_resp_leEq_rht.
Auto.
Apply less_leEq. Step (Zero::R)[+]Zero.
Apply plus_resp_less_leEq. Apply pos_one. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma power_big : (x,y:IR)(Zero [<=] x) -> (One [<] y) ->
  {N:nat | x [<=] y[^]N}.
(* End_Tex_Verb *)
Intros.
Cut Zero [<] y[-]One. Intro.
Cut y[-]One [#] Zero. Intro.
Elim (Archimedes (x[-]One)[/](y[-]One)[//]H2). Intro N. Intros. Exists N.
Apply leEq_transitive with One[+](nring N)[*](y[-]One).
Apply shift_leEq_plus'.
Stepr (y[-]One)[*](nring N).
Apply shift_leEq_mult' with H2. Auto.
Auto.
Apply leEq_wdr with (One[+](y[-]One))[^]N.
Apply power_big'. Apply less_leEq. Auto.
Apply un_op_wd_unfolded. Rational.
Apply Greater_imp_ap. Auto.
Apply shift_less_minus. Step (One::IR). Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma qi_yields_zero : (q:IR)(Zero[<=]q) -> (q[<]One) ->
  (e:IR)(Zero[<]e) -> {N:nat | q[^]N [<=] e}.
(* End_Tex_Verb *)
Intros.
Cut Zero [<] (One[+]q)[/]TwoNZ. Intro Haux.
Cut (One[+]q)[/]TwoNZ [#] Zero. Intro H2.
Cut e [#] Zero. Intro H3.
Elim (power_big One[/]e[//]H3 One[/]?[//]H2). Intro N. Intros H4. Exists N.
Cut Zero [<] ((One[+]q)[/]TwoNZ)[^]N. Intro.
Apply leEq_transitive with ((One[+]q)[/]TwoNZ)[^]N.
Apply nexp_resp_leEq.
Auto.
Apply shift_leEq_div.
Apply pos_two.
Apply shift_leEq_plus.
RStep q. Apply less_leEq. Auto.
Step One[*]((One[+]q)[/]TwoNZ)[^]N.
LetTac H6:=(pos_ap_zero ?? H5).
Apply shift_mult_leEq with H6. Auto.
RStepr e[*](One[/]?[//]H6).
Apply shift_leEq_mult' with H3. Auto.
Stepr (One[^]N)[/]?[//]H6.
Stepr (One[/]?[//]H2)[^]N. Auto.
Apply nexp_resp_pos. Apply pos_div_two.
Step Zero[+](Zero::IR). Apply plus_resp_less_leEq.
Apply pos_one. Auto.
Apply less_leEq. Apply recip_resp_pos. Auto.
Apply shift_less_div. Apply pos_div_two.
Step Zero[+](Zero::IR). Apply plus_resp_less_leEq.
Apply pos_one. Auto.
Step (One[+]q)[/]TwoNZ. Apply shift_div_less.
Apply pos_two. RStepr One[+](One::IR).
Apply plus_resp_less_lft. Auto.
Apply Greater_imp_ap. Auto.
Apply Greater_imp_ap. Auto.
Apply pos_div_two.
Step Zero[+](Zero::IR). Apply plus_resp_less_leEq.
Apply pos_one. Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma qi_lim_zero : (q:IR)(Zero [<=] q) -> (q [<] One)
	-> (SeqLimit [i:nat](q[^]i) Zero).
(* End_Tex_Verb *)
Intros.
Unfold SeqLimit. Unfold AbsSmall. Intros.
Elim (qi_yields_zero q H H0 e); Auto.
Intro N. Intros. Exists (S N). Intros. Split.
Apply less_leEq.
Apply less_leEq_trans with (Zero::IR).
Stepr [--](Zero::IR). Apply inv_resp_less. Auto.
Stepr q[^]m.
Apply nexp_resp_nonneg. Auto.
Step q[^]m.
Replace m with (plus N (minus m N)).
Step q[^]N[*]q[^](minus m N). Stepr e[*]One.
Apply mult_resp_leEq_both.
Apply nexp_resp_nonneg. Auto.
Apply nexp_resp_nonneg. Auto.
Auto.
Stepr (One::IR)[^](minus m N).
Apply nexp_resp_leEq. Auto. Apply less_leEq. Auto.
Auto with arith.
Qed.

End Properties_of_Exponentiation.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University
  Copyright 2017 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sovar.

Definition sonobnd {o} (t : @SOTerm o) : SOBTerm :=
  sobterm [] t.

Definition mk_so_equality {o} (t1 t2 T : @SOTerm o) : SOTerm :=
  soterm (Can NEquality) [sonobnd t1, sonobnd t2, sonobnd T].

Definition mk_so_apply {o} (t1 t2 : @SOTerm o) : SOTerm :=
  soterm (NCan NApply) [sonobnd t1, sonobnd t2].

Definition mk_so_isect {o} (t1 : @SOTerm o) v t2 : SOTerm :=
  soterm (Can NIsect) [sonobnd t1, sobterm [v] t2].

Definition mk_so_function {o} (t1 : @SOTerm o) v t2 : SOTerm :=
  soterm (Can NFunction) [sonobnd t1, sobterm [v] t2].

Definition mk_so_uni {o} (i : nat) : @SOTerm o :=
  soterm (Can (NUni i)) [].

Definition mk_so_abs {o} abs (l : list (@SOBTerm o)) : SOTerm :=
  soterm (Abs abs) l.

Definition mk_so_integer {o} n : @SOTerm o :=
  soterm (Can (Nint n)) [].

Definition mk_so_nat {o} (n : nat) : @SOTerm o :=
  mk_so_integer (Z_of_nat n).

Definition mk_so_int {o} : @SOTerm o :=
  soterm (Can NInt) [].

Definition mk_so_lam {o} (v : NVar) (b : @SOTerm o) : SOTerm :=
  soterm (Can NLambda) [sobterm [v] b].

Definition mk_so_spread {o} (t : @SOTerm o) (v1 v2 : NVar) (b : @SOTerm o) : SOTerm :=
  soterm (NCan NSpread) [sonobnd t, sobterm [v1,v2] b].


Universes i j.
Set Printing Universes.
Set Printing All.
Polymorphic Definition lt@{x y} : Type@{y} := Type@{x}.
Goal True.
evar (T:Type@{i}).
set (Z := nat : Type@{j}). simpl in Z.
let Tv:=eval cbv [T] in T in
pose (x:=Tv).
revert x.
refine (_ : let x:=Z in True).
(** This enforces i <= j *)
Fail pose (lt@{i j}).
let Zv:=eval cbv [Z] in Z in
let Tv:=eval cbv [T] in T in
constr_eq Zv Tv.
exact I.
Defined.

Goal True.
evar (T:nat).
pose (Z:=0).
let Tv:=eval cbv [T] in T in
pose (x:=Tv).
revert x.
refine (_ : let x:=Z in True).
let Zv:=eval cbv [Z] in Z in
let Tv:=eval cbv [T] in T in
constr_eq Zv Tv.
Abort.

Goal True.
evar (T:Set).
pose (Z:=nat).
let Tv:=eval cbv [T] in T in
pose (x:=Tv).
revert x.
refine (_ : let x:=Z in True).
let Zv:=eval cbv [Z] in Z in
let Tv:=eval cbv [T] in T in
constr_eq Zv Tv.
Abort.

Goal forall (A:Type)(a:A), True.
intros A a.
evar (T:A).
pose (Z:=a).
let Tv:=eval cbv delta [T] in T in
pose (x:=Tv).
revert x.
refine (_ : let x:=Z in True).
let Zv:=eval cbv [Z] in Z in
let Tv:=eval cbv [T] in T in
constr_eq Zv Tv.
Abort.

Goal True.
evar (T:Type).
pose (Z:=nat).
let Tv:=eval cbv [T] in T in
pose (x:=Tv).
revert x.
refine (_ : let x:=Z in True).
let Zv:=eval cbv [Z] in Z in
let Tv:=eval cbv [T] in T in
constr_eq Zv Tv.
Abort.


Require Import List.
Require Export Util EqDec Map Var Val.

(** *  Environments for Types and Values **)

(** ** Type Environments *)
(** Type environments are functions from var to option X for some type type X *)
Definition onv (X:Type) := var -> option X.

(** ** Value Environments *)
(** Value environments are functions from var to a value type X. *)
Definition env (X:Type) := var -> X.


Require Import Setoid Morphisms RelationClasses Program.Basics.
Require Import ILogic ILEmbed ILQuantTac.

Set Implicit Arguments.
Unset Strict Implicit.
Set Maximal Implicit Insertion.

Section BILogic.
  Definition BILogicType := Type.

  Context {A : BILogicType}.
  Context {HILOp: ILogicOps A}.

  Class BILOperators (A : BILogicType) := {
    empSP  : A;
    sepSP  : A -> A -> A;
    wandSP : A -> A -> A
  }.

  Class BILogic {BILOp: BILOperators A} := {
    bilil :> ILogic A;
    sepSPC1 P Q : sepSP P Q |-- sepSP Q P;
    sepSPA1 P Q R : sepSP (sepSP P Q) R |-- sepSP P (sepSP Q R);
    wandSepSPAdj P Q R : sepSP P Q |-- R <-> P |-- wandSP Q R;
    bilsep P Q R : P |-- Q -> sepSP P R |-- sepSP Q R;
    empSPR P : sepSP P empSP -|- P
  }.

End BILogic.

Implicit Arguments BILogic [[BILOp] [HILOp]].

Notation "a '**' b"  := (sepSP a b)
  (at level 58, right associativity).
Notation "a '-*' b"  := (wandSP a b)
  (at level 60, right associativity).

Section CoreInferenceRules.

  Context {A} `{HBIL: BILogic A}.

  Lemma wandSPAdj P Q C (HSep: C ** P |-- Q) : C |-- P -* Q.
  Proof.
    apply wandSepSPAdj; assumption.
  Qed.

  Lemma wandSPAdj' P Q C (HSep: P ** C |-- Q) : C |-- P -* Q.
  Proof.
    apply wandSepSPAdj. etransitivity; [apply sepSPC1|]. assumption.
  Qed.

  Lemma sepSPAdj P Q C (HWand: C |-- P -* Q) : C ** P |-- Q.
  Proof.
    apply wandSepSPAdj; assumption.
  Qed.

  Lemma sepSPAdj' P Q C (HWand: C |-- P -* Q) : P ** C |-- Q.
  Proof.
    etransitivity; [apply sepSPC1|]. apply wandSepSPAdj. assumption.
  Qed.

  Lemma sepSPC (P Q : A) : P ** Q -|- Q ** P.
  Proof.
    split; apply sepSPC1.
  Qed.

  Lemma sepSPA2 (P Q R : A) : P ** (Q ** R) |-- (P ** Q) ** R.
  Proof.
    rewrite sepSPC.
    etransitivity; [apply sepSPA1|].
    rewrite sepSPC.
    etransitivity; [apply sepSPA1|].
    rewrite sepSPC.
    reflexivity.
  Qed.

  Lemma sepSPA (P Q R : A) : (P ** Q) ** R -|- P ** (Q ** R).
  Proof.
    split; [apply sepSPA1 | apply sepSPA2].
  Qed.

  Lemma wandSPI (P Q R : A) (HQ : P ** Q |-- R) : (P |-- Q -* R).
  Proof.
    apply wandSPAdj; assumption.
  Qed.

  Lemma wandSPE (P Q R T : A) (HQR: Q |-- T -* R) (HP : P |-- Q ** T) : P |-- R.
  Proof.
    apply sepSPAdj in HQR.
    rewrite <- HQR, HP. reflexivity.
  Qed.

  Lemma empSPL P : empSP ** P -|- P.
  Proof.
    rewrite sepSPC; apply empSPR.
  Qed.

  Lemma bilexistsscL {T} (P : A) (Q : T -> A):
    Exists x : T, P ** Q x |-- P ** Exists x : T, Q x.
  Proof.
  	lexistsL x.
    rewrite sepSPC. etransitivity; [|rewrite <- sepSPC; reflexivity].
    apply bilsep. eapply lexistsR; reflexivity.
  Qed.

  Lemma bilexistsscR {T} (P : A) (Q : T -> A) :
    P ** (Exists x : T, Q x) |-- Exists x : T, P ** Q x.
  Proof.
    rewrite sepSPC; rewrite wandSepSPAdj.
    lexistsL x; erewrite <- wandSPAdj. reflexivity.
    eapply lexistsR; rewrite sepSPC; reflexivity.
  Qed.

  Lemma bilexistssc {T} (P : A) (Q : T -> A) :
    Exists x : T, P ** Q x -|- P ** Exists x : T, Q x.
  Proof.
    split; [apply bilexistsscL | apply bilexistsscR].
  Qed.

  Lemma bilforallscR {T} (P : A) (Q : T -> A) :
    P ** (Forall x : T, Q x) |-- Forall x : T, P ** Q x.
  Proof.
    lforallR x.
    rewrite sepSPC; etransitivity; [|rewrite <- sepSPC; reflexivity].
    apply bilsep. lforallL x; reflexivity.
  Qed.

  Lemma bilandscDL (P Q R : A) : (P //\\ Q) ** R |-- (P ** R) //\\ (Q ** R).
  Proof.
  	apply landR.
  	+ apply wandSepSPAdj; apply landL1; apply wandSepSPAdj; reflexivity.
  	+ apply wandSepSPAdj; apply landL2; apply wandSepSPAdj; reflexivity.
  Qed.

  Lemma bilorscDL (P Q R : A) : (P \\// Q) ** R -|- (P ** R) \\// (Q ** R).
  Proof.
  	split.
  	+ apply wandSepSPAdj; apply lorL; apply wandSepSPAdj;
  	  [apply lorR1 | apply lorR2]; reflexivity.
  	+ apply lorL; apply bilsep; [apply lorR1 | apply lorR2]; reflexivity.
  Qed.

End CoreInferenceRules.

Section BILogicMorphisms.
  Context {A : BILogicType} `{BIL: BILogic A}.

  Global Instance sepSP_lentails_m:
    Proper (lentails ++> lentails ++> lentails) sepSP.
  Proof.
    intros P P' HP Q Q' HQ.
    etransitivity; [eapply bilsep; exact HP|].
    rewrite -> sepSPC.
    etransitivity; [eapply bilsep; exact HQ|].
    rewrite -> sepSPC. reflexivity.
  Qed.

  Global Instance sepSP_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) sepSP.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply sepSP_lentails_m; (apply HP || apply HQ).
  Qed.

  Global Instance wandSP_lentails_m:
    Proper (lentails --> lentails ++> lentails) wandSP.
  Proof.
    intros P P' HP Q Q' HQ. red in HP.
    apply wandSPAdj. rewrite <- HQ, -> HP.
    apply sepSPAdj. reflexivity.
  Qed.

  Global Instance wandSP_lequiv_m:
    Proper (lequiv ==> lequiv ==> lequiv) wandSP.
  Proof.
    intros P P' HP Q Q' HQ.
    split; apply wandSP_lentails_m; (apply HP || apply HQ).
  Qed.

End BILogicMorphisms.

Section DerivedInferenceRules.

  Context {A : BILogicType} `{BILogic A}.

  Lemma sepSP_falseR P : P ** lfalse -|- lfalse.
  Proof.
    rewrite lfalse_is_exists, <- bilexistssc.
    split; apply lexistsL; intro x; destruct x.
  Qed.

  Lemma sepSP_falseL P : lfalse ** P -|- lfalse.
  Proof.
    rewrite -> sepSPC; apply sepSP_falseR.
  Qed.

  Lemma scME (P Q R S : A) (HPR: P |-- R) (HQS: Q |-- S) :
    P ** Q |-- R ** S.
  Proof.
    rewrite HPR, HQS; reflexivity.
  Qed.

  Lemma wandSPL P Q CL CR (HP: CL |-- P) (HR: Q |-- CR) :
    (P -* Q) ** CL |-- CR.
  Proof.
    rewrite <-HR, <-HP. apply sepSPAdj. reflexivity.
  Qed.

  Lemma siexistsE {T : Type} (P : T -> A) (Q : A) :
    (Exists x, P x) -* Q -|- Forall x, (P x -* Q).
  Proof.
    split.
	+ apply lforallR; intro x. apply wandSepSPAdj; eapply wandSPL; [|reflexivity].
	  lexistsR x. reflexivity.
	+ apply wandSepSPAdj. rewrite bilexistsscR. lexistsL.
	  rewrite sepSPC, bilforallscR. lforallL x. rewrite sepSPC.
	  apply wandSPL; reflexivity.
  Qed.

  Lemma septrue : forall p, p |-- p ** ltrue.
  Proof.
    intros. rewrite <- empSPR at 1.
    rewrite sepSPC. rewrite (sepSPC p).
    apply bilsep. apply ltrueR.
  Qed.

  Lemma wand_curry : forall a b c, (a ** b) -* c -|- a -* (b -* c).
  Proof.
    intros; split.
    { eapply wandSPAdj.
      eapply wandSPAdj.
      rewrite sepSPA.
      eapply sepSPAdj.
      reflexivity. }
    { eapply wandSPAdj.
      rewrite <- sepSPA.
      eapply sepSPAdj.
      eapply sepSPAdj. reflexivity. }
  Qed.

End DerivedInferenceRules.


(* Garbage collection definitions for L6. Part of the CertiCoq project.
 * Author: Zoe Paraskevopoulou, 2016
 *)

From Coq Require Import NArith.BinNat Relations.Relations MSets.MSets
         MSets.MSetRBT Lists.List omega.Omega Sets.Ensembles Relations.Relations
         Classes.Morphisms Sorting.Permutation Lists.SetoidPermutation.
From SFS Require Import cps cps_util set_util List_util Ensembles_util functions
     identifiers tactics map_util.
From SFS Require Import heap heap_defs heap_equiv.

From SFS Require Import Coqlib.

Import ListNotations.

Open Scope Ensembles_scope.
Close Scope Z_scope.

Module GC (H : Heap).

  Module Equiv := HeapEquiv H.

  Import H Equiv.Defs.HL Equiv.Defs Equiv.

  (** GC specs **)

  (** Using S as the set of roots, garbage collect H1 *)
  Definition collect (S : Ensemble loc) (H1 H2 : heap block) : Prop :=
    size_heap H2 <= size_heap H1 /\
    exists β,
      S |- H1 ≃_(β, id) H2 /\ (* locations outside S might be renamed! *)
          injective_subdomain (reach' H1 S) β.

  (** [live S H1 H2] iff H2 is the live portion of H1, using S as roots *)
  Definition live (S : Ensemble loc) (H1 H2 : heap block) β : Prop :=
    dom H2 \subset reach' H2 S /\
    S |- H1 ≃_(id, β) H2 /\
    injective_subdomain (reach' H2 S) β.

  Definition live' (S : Ensemble loc) (H1 H2 : heap block) β : Prop :=
    dom H2 \subset reach' H2 (image β S) /\
    S |- H1 ≃_(β, id) H2 /\
    injective_subdomain (reach' H1 S) β.

  (** * Lemmas about [collect] -- DEPRICATED *)

  (** The reachable part of the heap before and after collection are the same *)
  Lemma collect_heap_eq S H1 H2 :
    collect S H1 H2 ->
    exists β,
      S |- H1 ≃_(β, id) H2 /\
          injective_subdomain (reach' H1 S) β.
  Proof.
    firstorder.
  Qed.

  Lemma collect_size S H1 H2 :
    collect S H1 H2 ->
    size_heap H2 <= size_heap H1.
  Proof.
    now firstorder.
  Qed.

  (** * Lemmas about [live] *)

  Lemma heap_eq_res_approx_l P (k : nat) (H1 H2 : heap block) (v : value) :
    P |- H1 ≡ H2 ->
    reach' H1 (val_loc v) \subset P ->
    res_approx_fuel k (id, (v, H1)) (id, (v, H2)).
  Proof with (now eauto with Ensembles_DB).
    revert v. induction k as [k IHk] using lt_wf_rec1.
    intros v Heq Hsub.
    rewrite res_approx_fuel_eq.
    destruct v as [l|]; simpl; eauto.
    destruct (get l H1) as [b|] eqn:Hget; eauto. split; [ reflexivity |].
    destruct b as [c vs1 | v1 v2 | rho1].
    + eexists. split.
      erewrite <- Heq. eassumption. eapply Hsub. eapply reach'_extensive. reflexivity.
      intros.
      eapply Forall2_refl_strong.
      intros v HIn. eapply IHk; eauto. eapply Included_trans; [| eassumption ].
      simpl. rewrite (reach_unfold H1 [set l]). eapply Included_Union_preserv_r.
      rewrite post_Singleton; try eassumption. eapply reach'_set_monotonic.
      simpl. eapply In_Union_list. eapply in_map. eassumption.
    + do 2 eexists. split.
      rewrite <- Heq. eassumption. eapply Hsub. eapply reach'_extensive.
      reflexivity.
      intros. split; eapply IHk; eauto.
      eapply Included_trans; [| eassumption ].
      simpl. rewrite (reach_unfold H1 [set l]). eapply Included_Union_preserv_r.
      rewrite post_Singleton; try eassumption. eapply reach'_set_monotonic...
      eapply Included_trans; [| eassumption ].
      simpl. rewrite (reach_unfold H1 [set l]). eapply Included_Union_preserv_r.
      rewrite post_Singleton; try eassumption. eapply reach'_set_monotonic...
    + eexists. split.
      rewrite <- Heq. eassumption.
      eapply Hsub. eapply reach'_extensive. reflexivity.
      intros. destruct (M.get x rho1) eqn:Hgetx; eauto.
      left. do 2 eexists. split. reflexivity.
      split. reflexivity.
      intros i Hlt. eapply IHk; eauto.
      eapply Included_trans; [| eassumption ].
      simpl. rewrite (reach_unfold H1 [set l]). eapply Included_Union_preserv_r.
      rewrite post_Singleton; try eassumption. eapply reach'_set_monotonic.
      eapply get_In_env_locs; [| eassumption ]. now constructor.
  Qed.

  Lemma heap_eq_res_equiv P (H1 H2 : heap block) (v : value) :
    P |- H1 ≡ H2 ->
    reach' H1 (val_loc v) \subset P ->
    (v, H1) ≈_(id, id) (v, H2).
  Proof with (now eauto with Ensembles_DB).
    intros Heq Hsub i; split; eapply heap_eq_res_approx_l; try eassumption.
    symmetry. eassumption.
    eapply Included_trans; [| eassumption ].
    rewrite <- reach'_heap_eq. reflexivity.
    eapply heap_eq_antimon; [| eassumption ]. eassumption.
  Qed.

  Lemma live_exists S H (_ : ToMSet S) :
    exists H' b, live S H H' b.
  Proof.
    edestruct (restrict_exists _ (reach' H S) H) as [Hr Hres]. tci.
    assert (Hreq := Hres). eapply restrict_heap_eq in Hreq.

    eexists Hr, id.

    split; [| split ].
    - rewrite restrict_domain; [| | eassumption ]; tci.
      rewrite reach'_heap_eq; [| eassumption ].
      eapply Included_Intersection_r.
    - intros x Hin. eapply heap_eq_res_equiv; try eassumption.
      simpl. eapply reach'_set_monotonic. eapply Singleton_Included. eassumption.
    - clear. now firstorder.
  Qed.

  Lemma live_exists' S H (_ : ToMSet S) :
    exists H' b, live' S H H' b.
  Proof.
    edestruct (restrict_exists _ (reach' H S) H) as [Hr Hres]. tci.
    assert (Hreq := Hres). eapply restrict_heap_eq in Hreq.

    eexists Hr, id.

    split; [| split ].
    - rewrite restrict_domain; [| | eassumption ]; tci.
      rewrite reach'_heap_eq; [| eassumption ].
      rewrite image_id. eapply Included_Intersection_r.
    - intros x Hin. eapply heap_eq_res_equiv; try eassumption.
      simpl. eapply reach'_set_monotonic. eapply Singleton_Included. eassumption.
    - clear. now firstorder.
  Qed.

  Lemma Proper_live S1 S2 (HS1 : ToMSet S1) (HS2 : ToMSet S2) H1 H2 b1 :
    S1 <--> S2 ->
    live S1 H1 H2 b1 ->
    live S2 H1 H2 b1 .
  Proof.
    intros Heq Hl; unfold live in *. rewrite <- !Heq at 1.
    eassumption.
  Qed.

  Lemma live_live'_inv S b  H1 H2 :
    live S H1 H2 b ->
    exists b', live' (image b S) H1 H2 b' /\ inverse_subdomain (reach' H2 S) b b'.
  Abort.

  Lemma live'_live_inv S { _ : ToMSet S} b H1 H2 :
    live' S H1 H2 b ->
    exists b', live (image b S) H1 H2 b' /\ inverse_subdomain (reach' H1 S) b b'.
  Proof.
    intros [Hl1 [Hl2 Hl3]].
    edestruct inverse_exists as [b' [Hinv Hinj']]; [| eassumption | ].
    now tci.
    eexists b'. split; [| eassumption ].
    split; [| split ].
    + eassumption.
    + eapply heap_equiv_inverse_subdomain; eassumption.
    + rewrite <- heap_equiv_reach_eq. eassumption. eassumption.
  Qed.

  Instance Proper_live' : Proper (Same_set _ ==> eq ==> eq ==> eq ==> iff) live'.
  Proof.
    intros s1 s2 Hseq x1 x2 Hxeq y1 y2 Hyeq z1 z2 Hzeq; subst.
    unfold live'. rewrite !Hseq. reflexivity.
  Qed.

  Instance Proper_livei : Proper (Same_set _ ==> eq ==> eq ==> eq ==> iff) live.
  Proof.
    intros s1 s2 Hseq x1 x2 Hxeq y1 y2 Hyeq z1 z2 Hzeq; subst.
    unfold live. rewrite !Hseq. reflexivity.
  Qed.

  Lemma live_deterministic S (_ : set_util.ToMSet S) H1 H2 H2' b b' :
    live' S H1 H2 b ->
    live' S H1 H2' b' ->
    (exists b1, image b S |- H2 ≃_(b1, id) H2' /\
           injective_subdomain (reach' H2 (image b S)) b1).
  Proof.
    intros Hl1 Hl2.
    edestruct (live'_live_inv S b H1 H2) as [d [Hld [Heq1 Heq2]]].
    eassumption.
    revert Hl2 Hld .
    intros [Hl1' [Hl2' Hl3]] [Hl1'' [Hl2'' Hl3']].
    eexists (compose b' d).
    split. eapply heap_equiv_compose_l.
    eapply heap_equiv_symm. eassumption.
    eapply heap_equiv_antimon; [  eapply Hl2' | ].
    rewrite <- image_compose, image_f_eq_subdomain.
    rewrite image_id. reflexivity.
    eapply f_eq_subdomain_antimon; [| eassumption ].
    eapply reach'_extensive.

    eapply heap_equiv_symm in Hl2''. eapply heap_equiv_reach_eq in Hl2''.
    eapply injective_subdomain_compose. eassumption.
    eapply injective_subdomain_Proper_Same_set. eassumption.
    reflexivity. rewrite <- image_compose.
    eapply injective_subdomain_antimon. eassumption.
    rewrite image_f_eq_subdomain;
      [| eapply f_eq_subdomain_antimon ].
    rewrite image_id. reflexivity.
    reflexivity.
    eapply f_eq_subdomain_antimon; [| eassumption ].
    eapply reach'_extensive.
  Qed.

  Lemma res_equiv_subst_val (S : Ensemble var) (b1 b2 : loc -> loc) (H1 H2 : heap block)
        (v1 v2 : value):
    (v1, H1) ≈_( b1, b2) (v2, H2) ->
    subst_val b1 v1 = subst_val b2 v2.
  Proof.
    intros Heq. rewrite res_equiv_eq in Heq.
    destruct v1; destruct v2; try contradiction.
    - simpl. f_equal. eapply res_equiv_locs_eq. exact (Empty_set _).
      rewrite res_equiv_eq. eassumption.
    - simpl. inv Heq. reflexivity.
  Qed.

  (** Aux relation for showing the size lemmas *)

  Definition subst_block_rel b1 b2 (bl1 bl2 : block) : Prop :=
    match bl1, bl2 with
      | Constr c vs1, Constr c' vs2 => Forall2 (fun v1 v2 => subst_val b2 v2 = subst_val b1 v1)
                                              vs1 vs2
      | Clos v1 v2, Clos v1' v2' => subst_val b1 v1 = subst_val b2 v1' /\
                                   subst_val b1 v2 = subst_val b2 v2'
      | Env rho1, Env rho2 => key_set rho1 <--> key_set rho2
      | _, _ => False
    end.

  Lemma block_equiv_subst_block b1 b2 H1 H2 bl1 bl2 :
    block_equiv ((b1, H1), bl1) ((b2, H2), bl2) ->
    subst_block_rel b1 b2 bl1 bl2.
  Proof.
    intros Hb.
    destruct bl1 as [c1 vs1 | v1 v2 | rho1 ];
      destruct bl2 as [c2 vs2 | v1' v2' | rho2 ]; try contradiction.
    - destruct Hb as [Heq1 Hall]. subst. simpl.
      eapply Forall2_monotonic; [| eassumption ].
      simpl. intros v1 v2 Heq.
      symmetry.
      eapply res_equiv_subst_val. exact (Empty_set _). eassumption.
    - destruct Hb as [Hb Hb2]. simpl. split.
      eapply res_equiv_subst_val. exact (Empty_set _). eassumption.
      eapply res_equiv_subst_val. exact (Empty_set _). eassumption.
    - simpl in Hb.
      eapply heap_env_equiv_key_set.
      eassumption.
  Qed.

  Lemma heap_elements_filter_PermutationA S {Hs : ToMSet S} (R : relation block) {_ : PreOrder R} H1 H2 b1 :
    S |- H1 ≃_(b1, id) H2 ->
    injective_subdomain S b1 ->
    (forall bl1 bl2, block_equiv (b1, H1, bl1) (id, H2, bl2) -> R bl1 bl2) ->

    PermutationA
      (fun p1 p2 => let '(l1, bl1) := p1 in let '(l2, bl2) := p2 in
                 R bl1 bl2)
      (heap_elements_filter S H1)
      (heap_elements_filter (image b1 S) H2).
  Proof with (now eauto with Ensembles_DB).
    intros Heq Hinj Hr.
    pose (P := fun S => forall {Hs : ToMSet S},
                       S |- H1 ≃_(b1, id) H2 ->
                       injective_subdomain S b1 ->
                       PermutationA
                         (fun p1 p2 : loc * block =>
                            let '(_, bl1) := p1 in let '(_, bl2) := p2 in R bl1 bl2)
                         (heap_elements_filter S H1) (heap_elements_filter (image b1 S) H2)).
    assert (Hs' := Hs). revert Hs Heq Hinj.
    eapply Ensemble_ind with (P := P).
    - intros S1 S2 Heq. unfold P; split.

      intros Hp1 Hs Hseq Hinj.
      erewrite <- !(heap_elements_filter_set_Equal _ S1 S2); [| eassumption ].
      erewrite <- !(heap_elements_filter_set_Equal _ (image b1 S1) (image b1 S2)); [| ].
      rewrite <- !Heq in *. eapply Hp1; try eassumption. rewrite Heq. reflexivity.

      intros Hp1 Hs Hseq Hinj.
      erewrite !(heap_elements_filter_set_Equal _ S1 S2); [| eassumption ].
      erewrite !(heap_elements_filter_set_Equal _ (image b1 S1) (image b1 S2)); [| ].
      rewrite !Heq in *. eapply Hp1; try eassumption. rewrite Heq. reflexivity.

    - intros He Heq Hinj.
      erewrite heap_elements_filter_Empty_set.
      erewrite heap_elements_filter_set_Equal; [| rewrite image_Empty_set; reflexivity ].
      erewrite heap_elements_filter_Empty_set.
      now constructor.
    - unfold P. intros l S0 Hs0 Hnin IH HS Heq Hinj.

      assert (Hres : (Loc l, H1) ≈_(b1, id) (Loc (b1 l), H2)).
      { eapply Heq. now left. }

      assert (Hpre : PreOrder
                       (fun p1 p2 : loc * block =>
                          let '(_, bl1) := p1 in let '(_, bl2) := p2 in R bl1 bl2)).
      { constructor.
        - intros [l1 bl1]. reflexivity.
        - intros [l1 bl1] [l2 bl2] [l3 bl3]. eapply transitivity. }

      rewrite res_equiv_eq in Hres. destruct Hres as [_ Hres].

      destruct (get l H1) eqn:Hget1; destruct (get (b1 l) H2) eqn:Hget2; try contradiction.

      + eapply PermutationA_respects_Permutation_l; [ eassumption |
                                                    | symmetry; eapply heap_elements_filter_add; eassumption ].

        erewrite heap_elements_filter_set_Equal with (S1 := image b1 (l |: S0))
                                                       (S2 := (b1 l) |: image b1 S0).

        eapply PermutationA_respects_Permutation_r; [ eassumption |
                                                    | symmetry; eapply heap_elements_filter_add; try eassumption ].

        eapply permA_skip. now eauto.

        eapply IH. eapply heap_equiv_antimon. eassumption. now eauto with Ensembles_DB.

        eapply injective_subdomain_antimon; [ eassumption | ]...

        eapply injective_subdomain_Union_not_In_image in Hinj; [| eapply Disjoint_Singleton_l; eassumption ].

        intros Hc. eapply Hinj. constructor; eauto. rewrite image_Singleton. reflexivity.

        rewrite image_Union, image_Singleton. reflexivity.

      + eapply PermutationA_respects_Permutation_l; [ eassumption |
                                                    | symmetry; eapply heap_elements_filter_add_not_In; eassumption ].
        erewrite heap_elements_filter_set_Equal with
        (S1 := image b1 (l |: S0))
        (S2 := (b1 l) |: image b1 S0).

        eapply PermutationA_respects_Permutation_r; [ eassumption |
                                                    | symmetry; eapply heap_elements_filter_add_not_In;
                                                      try eassumption ].

        eapply IH. eapply heap_equiv_antimon. eassumption. now eauto with Ensembles_DB.

        eapply injective_subdomain_antimon; [ eassumption | ]...

        eapply injective_subdomain_Union_not_In_image in Hinj; [| eapply Disjoint_Singleton_l; eassumption ].

        intros Hc. eapply Hinj. constructor; eauto. rewrite image_Singleton. reflexivity.

        rewrite image_Union, image_Singleton. reflexivity.
    - tci.

      Grab Existential Variables.

      eapply ToMSet_Same_set. eassumption. tci.
      eapply ToMSet_Same_set. symmetry. eassumption. tci.
  Qed.

  Lemma block_equiv_size_val b bl1 bl2 H1 H2 :
    block_equiv (b, H1, bl1) (id, H2, bl2) ->
    size_val bl1 = size_val bl2.
  Proof.
    intros Hbl. eapply block_equiv_subst_block in Hbl.
    destruct bl1; destruct bl2; try contradiction.
    - simpl in *. f_equal. eapply Forall2_length. eassumption.
    - reflexivity.
    - simpl in Hbl. simpl.
      unfold size_env. rewrite !PS.cardinal_spec.
      do 2 f_equal. eapply elements_eq.
      eapply Same_set_From_set. rewrite <- !mset_eq. eassumption.
  Qed.

  Lemma heap_equiv_size_reachable S {_ : ToMSet S} H1 H2 b1 :
    reach' H1 S |- H1 ≃_(b1, id) H2 ->
    injective_subdomain (reach' H1 S) b1 ->
    size_reachable S H1 = size_reachable (image b1 S) H2.
  Proof.
    intros Heq Hinj. unfold size_reachable, size_with_measure_filter.
    erewrite heap_elements_filter_set_Equal with (S1 := reach' H2 (image b1 S))
                                                 (S2 := image b1 (reach' H1 S)).
    - eapply fold_permutationA; [ | | eapply heap_elements_filter_PermutationA; eauto;
                                      [| intros bl1 bl2 Hbl; eapply block_equiv_size_val; eassumption ]].
      + intros [x1 x2] [y1 y2] z. firstorder.
      + intros z [x1 x2] [y1 y2] Heqf. firstorder.
      + constructor.
        intros x1. reflexivity.
        intros x1 x2 x3 Hr1 Hr2; congruence.
    - symmetry. eapply heap_equiv_reach_eq.
      eapply heap_equiv_antimon. eassumption.
      now eapply reach'_extensive.
  Qed.

  Corollary heap_env_equiv_reach_size e  H1 H2 rho1 rho2 b1 :
    occurs_free e |- (H1, rho1) ⩪_( b1, id) (H2, rho2) ->
    injective_subdomain (reach' H1 (env_locs rho1 (occurs_free e))) b1 ->
    reach_size H1 rho1 e = reach_size H2 rho2 e.
  Proof.
    intros Heq Hinj. unfold reach_size.
    erewrite size_reachable_same_set with (S1 := (env_locs rho2 (occurs_free e)))
                                          (S2 := image b1 (env_locs rho1 (occurs_free e))).
    eapply heap_equiv_size_reachable.
    eapply heap_equiv_reach.
    eapply heap_env_approx_heap_equiv_r. eassumption.
    eassumption.

    eapply heap_env_equiv_image_post_n with (n := 0) in Heq.
    simpl in Heq. rewrite image_id in Heq. symmetry. eassumption.
  Qed.

  Lemma heap_equiv_preserves_closed S β1 H1 H2 :
    S |- H1 ≃_(β1, id) H2 ->
    closed (reach' H1 S) H1 ->
    closed (reach' H2 (image β1 S)) H2.
  Proof.
    intros Heq Hwf l2 [n [_ Hin]].
    assert (Hin2 := Hin).
    eapply heap_equiv_post_n_eq in Hin; [| eassumption ].
    edestruct Hin as [l1 [Heq' Hin']]. subst.

    edestruct Hwf as [b1 [Hget1 Hr1]].
    now eexists; split; eauto.

    eapply heap_equiv_post_n in Heq. eapply Heq in Heq'.
    rewrite res_equiv_eq in Heq'. destruct Heq' as [_ Heq'].
    unfold id in *. rewrite Hget1 in Heq'.
    edestruct (get (β1 l1) H2) as [b2 |] eqn:Hget2; try contradiction.
    eexists; split; eauto.
    intros x Hinx. eexists (1 + n). split. now constructor.
    simpl. do 2 eexists; split; eauto.
  Qed.

  Lemma GC_dom S H1 H2 b :
    live' S H1 H2 b ->
    closed (reach' H1 S) H1 ->
    dom H2 <--> reach' H2 (image b S).
  Proof.
    intros [Hsub [Heq Hinj]] Hcl.
    split. eassumption.

    eapply in_dom_closed. eapply heap_equiv_preserves_closed.
    eassumption. eassumption.
  Qed.

  Lemma GC_dom_subset S H1 H2 b :
    live' S H1 H2 b ->
    dom H2 \subset reach' H2 (image b S).
  Proof.
    intros [Hsub [Heq Hinj]].
    eassumption.
  Qed.

  (** Size after GC *)

  Lemma live_size_with_measure S {_ : ToMSet S} H1 H2 b f :
    live' S H1 H2 b ->
    (forall bl1 bl2, block_equiv (b, H1, bl1) (id, H2, bl2) -> f bl1 = f bl2) ->
    size_with_measure f H2 = size_with_measure_filter f (reach' H1 S) H1.
  Proof.
    intros Hl Heq.
    rewrite size_with_measure_filter_dom.
    assert (Hl' := Hl). destruct Hl as [Hdom [Hheq Hinj]].

    erewrite <- size_with_measure_filter_weaken with (S := reach' H2 (image b S));
      [| eassumption ].

    erewrite size_with_measure_Same_set with (S := reach' H2 (image b S))
                                               (S' := image b (reach' H1 S)).
    - eapply fold_permutationA with (R := fun p1 p2 : loc * block =>
                                            let '(_, bl1) := p1 in let '(_, bl2) := p2 in f bl1 = f bl2).
    + intros [x1 x2] [y1 y2] z. firstorder.
    + intros z [x1 x2] [y1 y2] Heqf. firstorder.
    + eapply PermutationA_symm.
      now intros [x1 y1] [x2 y2]; eauto.
      eapply heap_elements_filter_PermutationA; try eassumption.

      constructor; eauto. intros x1 x2 x3; congruence.

      eapply heap_equiv_reach. eassumption.

    - symmetry. eapply heap_equiv_reach_eq. eassumption.
  Qed.

  Lemma live_max_with_measure S {_ : ToMSet S} H1 H2 b f :
    live' S H1 H2 b ->
    (forall bl1 bl2, block_equiv (b, H1, bl1) (id, H2, bl2) -> f bl1 = f bl2) ->
    max_with_measure f H2 = max_with_measure_filter f (reach' H1 S) H1.
  Proof.
    intros Hl Heq.
    rewrite max_with_measure_filter_dom.
    assert (Hl' := Hl). destruct Hl as [Hdom [Hheq Hinj]].

    erewrite <- max_with_measure_filter_weaken with (S := reach' H2 (image b S));
      [| eassumption ].

    erewrite max_with_measure_Same_set with (S := reach' H2 (image b S))
                                               (S' := image b (reach' H1 S)).
    - eapply fold_permutationA with (R := fun p1 p2 : loc * block =>
                                            let '(_, bl1) := p1 in let '(_, bl2) := p2 in f bl1 = f bl2).
      + intros [x1 x2] [y1 y2] z.
        rewrite <- !Max.max_assoc. f_equal. rewrite Max.max_comm. reflexivity.
      + intros z [x1 x2] [y1 y2] Heqf. simpl. rewrite Heqf. reflexivity.
      + eapply PermutationA_symm.
        now intros [x1 y1] [x2 y2]; eauto.
        eapply heap_elements_filter_PermutationA; try eassumption.

        constructor; eauto. intros x1 x2 x3; congruence.

        eapply heap_equiv_reach. eassumption.

    - symmetry. eapply heap_equiv_reach_eq. eassumption.
  Qed.

  Lemma live_size_with_measure_leq S {_ : ToMSet S} H1 H2 b f :
    live' S H1 H2 b ->
    (forall bl1 bl2, block_equiv (b, H1, bl1) (id, H2, bl2) -> f bl1 = f bl2) ->
    size_with_measure f H2 <= size_with_measure f H1.
  Proof.
    intros Hl Heq. erewrite live_size_with_measure; [| eassumption | eassumption ].
    rewrite HL.size_with_measure_filter_dom.
    eapply HL.size_with_measure_filter_dom_sup.
  Qed.

  Lemma live_max_with_measure_leq S {_ : ToMSet S} H1 H2 b f :
    live' S H1 H2 b ->
    (forall bl1 bl2, block_equiv (b, H1, bl1) (id, H2, bl2) -> f bl1 = f bl2) ->
    max_with_measure f H2 <= max_with_measure f H1.
  Proof.
    intros Hl Heq. erewrite live_max_with_measure; [| eassumption | eassumption ].
    rewrite HL.max_with_measure_filter_dom.
    eapply HL.max_with_measure_filter_dom_sup.
  Qed.

End GC.