(* Lifts for packing *)

From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From Translation
Require Import util Sorts SAst SLiftSubst Equality SCommon XTyping
               ITyping ITypingLemmata ITypingAdmissible.
Import ListNotations.

Section Pack.

Context `{Sort_notion : Sorts.notion}.

(* In order to do things properly we need to extend the context heterogenously,
   this is done by extending the context with packed triples
   (x : A, y : B, e : heq A x B y).
   We call Γm the mix of Γ1 and Γ2.
   We also need to define correspond lifts.

   If Γ, Γ1, Δ |- t : T then
   Γ, Γm, Δ↑ |- llift #|Γm| #|Δ| t : llift #|Γm| #|Δ| T
   If Γ, Γ2, Δ |- t : T then
   Γ, Γm, Δ↑ |- rlift #|Γm| #|Δ| t : rlift #|Γm| #|Δ| T
 *)

Fixpoint llift γ δ (t:sterm)  : sterm :=
  match t with
  | sRel i =>
    if i <? δ
    then sRel i
    else if i <? δ + γ
         then sProjT1 (sRel i)
         else sRel i
  | sLambda na A B b =>
    sLambda na (llift γ δ A) (llift γ (S δ) B) (llift γ (S δ) b)
  | sApp u A B v =>
    sApp (llift γ δ u) (llift γ δ A) (llift γ (S δ) B) (llift γ δ v)
  | sProd na A B => sProd na (llift γ δ A) (llift γ (S δ) B)
  | sSum na A B => sSum na (llift γ δ A) (llift γ (S δ) B)
  | sPair A B u v =>
    sPair (llift γ δ A) (llift γ (S δ) B) (llift γ δ u) (llift γ δ v)
  | sPi1 A B p => sPi1 (llift γ δ A) (llift γ (S δ) B) (llift γ δ p)
  | sPi2 A B p => sPi2 (llift γ δ A) (llift γ (S δ) B) (llift γ δ p)
  | sEq A u v => sEq (llift γ δ A) (llift γ δ u) (llift γ δ v)
  | sRefl A u => sRefl (llift γ δ A) (llift γ δ u)
  | sJ A u P w v p =>
    sJ (llift γ δ A)
       (llift γ δ u)
       (llift γ (S (S δ)) P)
       (llift γ δ w)
       (llift γ δ v)
       (llift γ δ p)
  | sTransport A B p t =>
    sTransport (llift γ δ A) (llift γ δ B) (llift γ δ p) (llift γ δ t)
  | sBeta t u => sBeta (llift γ (S δ) t) (llift γ δ u)
  | sHeq A a B b =>
    sHeq (llift γ δ A) (llift γ δ a) (llift γ δ B) (llift γ δ b)
  | sHeqToEq p => sHeqToEq (llift γ δ p)
  | sHeqRefl A a => sHeqRefl (llift γ δ A) (llift γ δ a)
  | sHeqSym p => sHeqSym (llift γ δ p)
  | sHeqTrans p q => sHeqTrans (llift γ δ p) (llift γ δ q)
  | sHeqTransport p t => sHeqTransport (llift γ δ p) (llift γ δ t)
  | sCongProd B1 B2 p q =>
    sCongProd (llift γ (S δ) B1) (llift γ (S δ) B2)
              (llift γ δ p) (llift γ (S δ) q)
  | sCongLambda B1 B2 t1 t2 pA pB pt =>
    sCongLambda (llift γ (S δ) B1) (llift γ (S δ) B2)
                (llift γ (S δ) t1) (llift γ (S δ) t2)
                (llift γ δ pA) (llift γ (S δ) pB) (llift γ (S δ) pt)
  | sCongApp B1 B2 pu pA pB pv =>
    sCongApp (llift γ (S δ) B1) (llift γ (S δ) B2)
             (llift γ δ pu) (llift γ δ pA) (llift γ (S δ) pB) (llift γ δ pv)
  | sCongSum B1 B2 p q =>
    sCongSum (llift γ (S δ) B1) (llift γ (S δ) B2)
             (llift γ δ p) (llift γ (S δ) q)
  | sCongPair B1 B2 pA pB pu pv =>
    sCongPair (llift γ (S δ) B1) (llift γ (S δ) B2)
             (llift γ δ pA) (llift γ (S δ) pB)
             (llift γ δ pu) (llift γ δ pv)
  | sCongPi1 B1 B2 pA pB pp =>
    sCongPi1 (llift γ (S δ) B1) (llift γ (S δ) B2)
             (llift γ δ pA) (llift γ (S δ) pB) (llift γ δ pp)
  | sCongPi2 B1 B2 pA pB pp =>
    sCongPi2 (llift γ (S δ) B1) (llift γ (S δ) B2)
             (llift γ δ pA) (llift γ (S δ) pB) (llift γ δ pp)
  | sCongEq pA pu pv => sCongEq (llift γ δ pA) (llift γ δ pu) (llift γ δ pv)
  | sCongRefl pA pu => sCongRefl (llift γ δ pA) (llift γ δ pu)
  | sEqToHeq p => sEqToHeq (llift γ δ p)
  | sHeqTypeEq A B p => sHeqTypeEq (llift γ δ A) (llift γ δ B) (llift γ δ p)
  | sSort x => sSort x
  | sPack A B => sPack (llift γ δ A) (llift γ δ B)
  | sProjT1 x => sProjT1 (llift γ δ x)
  | sProjT2 x => sProjT2 (llift γ δ x)
  | sProjTe x => sProjTe (llift γ δ x)
  | sAx id => sAx id
  end.

Fixpoint rlift γ δ t : sterm :=
  match t with
  | sRel i =>
    if i <? δ
    then sRel i
    else if i <? δ + γ
         then sProjT2 (sRel i)
         else sRel i
  | sLambda na A B b =>
    sLambda na (rlift γ δ A) (rlift γ (S δ) B) (rlift γ (S δ) b)
  | sApp u A B v =>
    sApp (rlift γ δ u) (rlift γ δ A) (rlift γ (S δ) B) (rlift γ δ v)
  | sProd na A B => sProd na (rlift γ δ A) (rlift γ (S δ) B)
  | sSum na A B => sSum na (rlift γ δ A) (rlift γ (S δ) B)
  | sPair A B u v =>
    sPair (rlift γ δ A) (rlift γ (S δ) B) (rlift γ δ u) (rlift γ δ v)
  | sPi1 A B p => sPi1 (rlift γ δ A) (rlift γ (S δ) B) (rlift γ δ p)
  | sPi2 A B p => sPi2 (rlift γ δ A) (rlift γ (S δ) B) (rlift γ δ p)
  | sEq A u v => sEq (rlift γ δ A) (rlift γ δ u) (rlift γ δ v)
  | sRefl A u => sRefl (rlift γ δ A) (rlift γ δ u)
  | sJ A u P w v p =>
    sJ (rlift γ δ A)
       (rlift γ δ u)
       (rlift γ (S (S δ)) P)
       (rlift γ δ w)
       (rlift γ δ v)
       (rlift γ δ p)
  | sTransport A B p t =>
    sTransport (rlift γ δ A) (rlift γ δ B) (rlift γ δ p) (rlift γ δ t)
  | sBeta t u => sBeta (rlift γ (S δ) t) (rlift γ δ u)
  | sHeq A a B b =>
    sHeq (rlift γ δ A) (rlift γ δ a) (rlift γ δ B) (rlift γ δ b)
  | sHeqToEq p => sHeqToEq (rlift γ δ p)
  | sHeqRefl A a => sHeqRefl (rlift γ δ A) (rlift γ δ a)
  | sHeqSym p => sHeqSym (rlift γ δ p)
  | sHeqTrans p q => sHeqTrans (rlift γ δ p) (rlift γ δ q)
  | sHeqTransport p t => sHeqTransport (rlift γ δ p) (rlift γ δ t)
  | sCongProd B1 B2 p q =>
    sCongProd (rlift γ (S δ) B1) (rlift γ (S δ) B2)
              (rlift γ δ p) (rlift γ (S δ) q)
  | sCongLambda B1 B2 t1 t2 pA pB pt =>
    sCongLambda (rlift γ (S δ) B1) (rlift γ (S δ) B2)
                (rlift γ (S δ) t1) (rlift γ (S δ) t2)
                (rlift γ δ pA) (rlift γ (S δ) pB) (rlift γ (S δ) pt)
  | sCongSum B1 B2 p q =>
    sCongSum (rlift γ (S δ) B1) (rlift γ (S δ) B2)
              (rlift γ δ p) (rlift γ (S δ) q)
  | sCongPair B1 B2 pA pB pu pv =>
    sCongPair (rlift γ (S δ) B1) (rlift γ (S δ) B2)
             (rlift γ δ pA) (rlift γ (S δ) pB)
             (rlift γ δ pu) (rlift γ δ pv)
  | sCongPi1 B1 B2 pA pB pp =>
    sCongPi1 (rlift γ (S δ) B1) (rlift γ (S δ) B2)
             (rlift γ δ pA) (rlift γ (S δ) pB) (rlift γ δ pp)
  | sCongPi2 B1 B2 pA pB pp =>
    sCongPi2 (rlift γ (S δ) B1) (rlift γ (S δ) B2)
             (rlift γ δ pA) (rlift γ (S δ) pB) (rlift γ δ pp)
  | sCongApp B1 B2 pu pA pB pv =>
    sCongApp (rlift γ (S δ) B1) (rlift γ (S δ) B2)
             (rlift γ δ pu) (rlift γ δ pA) (rlift γ (S δ) pB) (rlift γ δ pv)
  | sCongEq pA pu pv => sCongEq (rlift γ δ pA) (rlift γ δ pu) (rlift γ δ pv)
  | sCongRefl pA pu => sCongRefl (rlift γ δ pA) (rlift γ δ pu)
  | sEqToHeq p => sEqToHeq (rlift γ δ p)
  | sHeqTypeEq A B p => sHeqTypeEq (rlift γ δ A) (rlift γ δ B) (rlift γ δ p)
  | sSort x => sSort x
  | sPack A B => sPack (rlift γ δ A) (rlift γ δ B)
  | sProjT1 x => sProjT1 (rlift γ δ x)
  | sProjT2 x => sProjT2 (rlift γ δ x)
  | sProjTe x => sProjTe (rlift γ δ x)
  | sAx id => sAx id
  end.

End Pack.

Notation llift0 γ t := (llift γ 0 t).
Notation rlift0 γ t := (rlift γ 0 t).

Section Mix.

Context `{Sort_notion : Sorts.notion}.

Inductive ismix Σ Γ : forall (Γ1 Γ2 Γm : scontext), Type :=
| mixnil : ismix Σ Γ [] [] []
| mixsnoc Γ1 Γ2 Γm s A1 A2 :
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γ1 |-i A1 : sSort s ->
    Σ ;;; Γ ,,, Γ2 |-i A2 : sSort s ->
    ismix Σ Γ
          (Γ1 ,, A1)
          (Γ2 ,, A2)
          (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
.

Fact mix_length1 :
  forall {Σ Γ Γ1 Γ2 Γm},
    ismix Σ Γ Γ1 Γ2 Γm ->
    #|Γm| = #|Γ1|.
Proof.
  intros Σ Γ Γ1 Γ2 Γm hm.
  dependent induction hm.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

Fact mix_length2 :
  forall {Σ Γ Γ1 Γ2 Γm},
    ismix Σ Γ Γ1 Γ2 Γm ->
    #|Γm| = #|Γ2|.
Proof.
  intros Σ Γ Γ1 Γ2 Γm hm.
  dependent induction hm.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

Lemma llift00 :
  forall {t δ}, llift 0 δ t = t.
Proof.
  intro t.
  induction t ; intro δ.
  all: try (cbn ; f_equal ; easy).
  cbn. case_eq δ.
  + intro h. cbn. f_equal.
  + intros m h. case_eq (n <=? m).
    * intro. reflexivity.
    * intro nlm. cbn.
      replace (m+0)%nat with m by mylia.
      rewrite nlm. f_equal.
Defined.

Lemma rlift00 :
  forall {t δ}, rlift 0 δ t = t.
Proof.
  intro t.
  induction t ; intro δ.
  all: try (cbn ; f_equal ; easy).
  cbn. case_eq δ.
  + intro h. cbn. f_equal.
  + intros m h. case_eq (n <=? m).
    * intro. reflexivity.
    * intro nlm. cbn.
      replace (m+0)%nat with m by mylia.
      rewrite nlm. f_equal.
Defined.

Lemma lift_llift :
  forall {t i j k},
    lift i k (llift j k t) = llift (i+j) k (lift i k t).
Proof.
  intro t. induction t ; intros i j k.
  all: try (cbn ; f_equal ; easy).
  unfold llift at 1. case_eq (n <? k) ; intro e ; bprop e.
  - unfold lift. case_eq (k <=? n) ; intro e1 ; bprop e1 ; try mylia.
    unfold llift. rewrite e. reflexivity.
  - case_eq (n <? k + j) ; intro e1 ; bprop e1.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift. case_eq (i + n <? k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + (i+j)) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift. case_eq (i + n <? k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + (i + j)) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_llift' :
  forall {t i j k},
    lift i k (llift j k t) = llift j (k+i) (lift i k t).
Proof.
  intro t. induction t ; intros i j k.
  all: try (cbn ; f_equal ;
            try replace (S (S (k + i))) with ((S (S k)) + i)%nat by mylia ;
            try replace (S (k + i)) with ((S k) + i)%nat by mylia ;
            easy).
  unfold llift at 1. case_eq (n <? k) ; intro e ; bprop e.
  - unfold lift. case_eq (k <=? n) ; intro e1 ; bprop e1 ; try mylia.
    unfold llift. case_eq (n <? k + i) ; intro e3 ; bprop e3 ; try mylia.
    reflexivity.
  - case_eq (n <? k + j) ; intro e1 ; bprop e1.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift.
      case_eq (i + n <? k + i) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + i + j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift.
      case_eq (i + n <? k + i) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + i + j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_llift3 :
  forall {t i j k l},
    l <= k ->
    lift i l (llift j k t) = llift j (i+k) (lift i l t).
Proof.
  intro t. induction t ; intros i j k l h.
  all: try (cbn ; f_equal ;
            try replace (S (S (i + k))) with (i + (S (S k)))%nat by mylia ;
            try replace (S (i + k)) with (i + (S k))%nat by mylia ;
            easy).
  unfold llift at 1.
  case_eq (n <? k) ; intro e ; bprop e.
  - cbn. case_eq (l <=? n) ; intro e1 ; bprop e1.
    + unfold llift. case_eq (i + n <? i + k) ; intro e3 ; bprop e3 ; try mylia.
      reflexivity.
    + unfold llift. case_eq (n <? i + k) ; intro e3 ; bprop e3 ; try mylia.
      reflexivity.
  - case_eq (n <? k + j) ; intro e1 ; bprop e1.
    + cbn. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift.
      case_eq (i + n <? i + k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? i + k + j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + cbn. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift. case_eq (i+n <? i+k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i+n <? i+k+j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_llift4 :
  forall {t i j k l},
    k < i ->
    i <= k + j ->
    lift i l (llift (j - (i - k)) l t) = llift j (k+l) (lift i l t).
Proof.
  intro t. induction t ; intros i j k l h1 h2.
  all: try (cbn ; f_equal ;
            try replace (S (S (k + l))) with (k + (S (S l)))%nat by mylia ;
            try replace (S (k + l)) with (k + (S l))%nat by mylia ;
            easy).
  unfold llift at 1.
  case_eq (n <? l) ; intro e ; bprop e ; try mylia.
  - unfold lift. case_eq (l <=? n) ; intro e1 ; bprop e1 ; try mylia.
    unfold llift. case_eq (n <? k + l) ; intro e3 ; bprop e3 ; try mylia.
    reflexivity.
  - case_eq (n <? l + (j - (i - k))) ; intro e1 ; bprop e1 ; try mylia.
    + unfold lift. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift. case_eq (i+n <? k+l) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i+n <? k+l+j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + unfold lift. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold llift. case_eq (i+n <? k+l) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i+n <? k+l+j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_llift5 :
  forall {t i j k l},
    j + k <= i + l ->
    l <= k ->
    llift j k (lift i l t) = lift i l t.
Proof.
  intro t; induction t ; intros i j k l h1 h2; cbn ; f_equal;
    try eapply IHt; try eapply IHt1; try eapply IHt2; try eapply IHt3;
    try eapply IHt4; try eapply IHt5; try eapply IHt6; try eapply IHt7;
    try mylia.
  unfold lift. case_eq (l <=? n) ; intro e ; bprop e.
  - unfold llift. case_eq (i+n <? k) ; intro e1 ; bprop e1 ; try mylia.
    case_eq (i+n <? k+j) ; intro e3 ; bprop e3 ; try mylia.
    reflexivity.
  - unfold llift. case_eq (n <? k) ; intro e1 ; bprop e1 ; try mylia.
    reflexivity.
Defined.

Lemma lift_rlift :
  forall {t i j k},
    lift i k (rlift j k t) = rlift (i+j) k (lift i k t).
Proof.
  intro t. induction t ; intros i j k.
  all: try (cbn ; f_equal ; easy).
  unfold rlift at 1. case_eq (n <? k) ; intro e ; bprop e.
  - unfold lift. case_eq (k <=? n) ; intro e1 ; bprop e1 ; try mylia.
    unfold rlift. rewrite e. reflexivity.
  - case_eq (n <? k + j) ; intro e1 ; bprop e1.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift. case_eq (i + n <? k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + (i+j)) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift. case_eq (i + n <? k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + (i + j)) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_rlift' :
  forall {t i j k},
    lift i k (rlift j k t) = rlift j (k+i) (lift i k t).
Proof.
  intro t. induction t ; intros i j k.
  all: try (cbn ; f_equal ;
            try replace (S (S (k + i))) with ((S (S k)) + i)%nat by mylia ;
            try replace (S (k + i)) with ((S k) + i)%nat by mylia ;
            easy).
  unfold rlift at 1. case_eq (n <? k) ; intro e ; bprop e.
  - unfold lift. case_eq (k <=? n) ; intro e1 ; bprop e1 ; try mylia.
    unfold rlift. case_eq (n <? k + i) ; intro e3 ; bprop e3 ; try mylia.
    reflexivity.
  - case_eq (n <? k + j) ; intro e1 ; bprop e1.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift.
      case_eq (i + n <? k + i) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + i + j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + unfold lift. case_eq (k <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift.
      case_eq (i + n <? k + i) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? k + i + j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_rlift3 :
  forall {t i j k l},
    l <= k ->
    lift i l (rlift j k t) = rlift j (i+k) (lift i l t).
Proof.
  intro t. induction t ; intros i j k l h.
  all: try (cbn ; f_equal ;
            try replace (S (S (i + k))) with (i + (S (S k)))%nat by mylia ;
            try replace (S (i + k)) with (i + (S k))%nat by mylia ;
            easy).
  unfold rlift at 1.
  case_eq (n <? k) ; intro e ; bprop e.
  - cbn. case_eq (l <=? n) ; intro e1 ; bprop e1.
    + unfold rlift. case_eq (i + n <? i + k) ; intro e3 ; bprop e3 ; try mylia.
      reflexivity.
    + unfold rlift. case_eq (n <? i + k) ; intro e3 ; bprop e3 ; try mylia.
      reflexivity.
  - case_eq (n <? k + j) ; intro e1 ; bprop e1.
    + cbn. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift.
      case_eq (i + n <? i + k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i + n <? i + k + j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + cbn. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift. case_eq (i+n <? i+k) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i+n <? i+k+j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_rlift4 :
  forall {t i j k l},
    k < i ->
    i <= k + j ->
    lift i l (rlift (j - (i - k)) l t) = rlift j (k+l) (lift i l t).
Proof.
  intro t. induction t ; intros i j k l h1 h2.
  all: try (cbn ; f_equal ;
            try replace (S (S (k + l))) with (k + (S (S l)))%nat by mylia ;
            try replace (S (k + l)) with (k + (S l))%nat by mylia ;
            easy).
  unfold rlift at 1.
  case_eq (n <? l) ; intro e ; bprop e ; try mylia.
  - unfold lift. case_eq (l <=? n) ; intro e1 ; bprop e1 ; try mylia.
    unfold rlift. case_eq (n <? k + l) ; intro e3 ; bprop e3 ; try mylia.
    reflexivity.
  - case_eq (n <? l + (j - (i - k))) ; intro e1 ; bprop e1 ; try mylia.
    + unfold lift. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift. case_eq (i+n <? k+l) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i+n <? k+l+j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
    + unfold lift. case_eq (l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      unfold rlift. case_eq (i+n <? k+l) ; intro e5 ; bprop e5 ; try mylia.
      case_eq (i+n <? k+l+j) ; intro e7 ; bprop e7 ; try mylia.
      reflexivity.
Defined.

Lemma lift_rlift5 :
  forall {t i j k l},
    j + k <= i + l ->
    l <= k ->
    rlift j k (lift i l t) = lift i l t.
Proof.
  intro t; induction t ; intros i j k l h1 h2; cbn; f_equal;
    try eapply IHt; try eapply IHt1; try eapply IHt2; try eapply IHt3;
    try eapply IHt4; try eapply IHt5; try eapply IHt6; try eapply IHt7;
    try mylia.
  unfold lift. case_eq (l <=? n) ; intro e ; bprop e.
  - unfold rlift. case_eq (i+n <? k) ; intro e1 ; bprop e1 ; try mylia.
    case_eq (i+n <? k+j) ; intro e3 ; bprop e3 ; try mylia.
    reflexivity.
  - unfold rlift. case_eq (n <? k) ; intro e1 ; bprop e1 ; try mylia.
    reflexivity.
Defined.

Fixpoint llift_context n (Δ : scontext) : scontext :=
  match Δ with
  | nil => nil
  | A :: Δ => (llift n #|Δ| A) :: (llift_context n Δ)
  end.

Fact llift_context_length :
  forall {n Δ}, #|llift_context n Δ| = #|Δ|.
Proof.
  intros n Δ.
  induction Δ.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

Fact llift_context0 :
  forall {Γ}, llift_context 0 Γ = Γ.
Proof.
  intro Γ. induction Γ.
  - reflexivity.
  - cbn. rewrite llift00. rewrite IHΓ. reflexivity.
Defined.

Fixpoint rlift_context n (Δ : scontext) : scontext :=
  match Δ with
  | nil => nil
  | A :: Δ => (rlift n #|Δ| A) :: (rlift_context n Δ)
  end.

Fact rlift_context_length :
  forall {n Δ}, #|rlift_context n Δ| = #|Δ|.
Proof.
  intros n Δ.
  induction Δ.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

Fact rlift_context0 :
  forall {Γ}, rlift_context 0 Γ = Γ.
Proof.
  intro Γ. induction Γ.
  - reflexivity.
  - cbn. rewrite rlift00. rewrite IHΓ. reflexivity.
Defined.

(* We introduce an alternate version of ismix that will be implied by ismix but
   will be used as an intermediary for the proof.
 *)
Inductive ismix' Σ Γ : forall (Γ1 Γ2 Γm : scontext), Type :=
| mixnil' : ismix' Σ Γ [] [] []
| mixsnoc' Γ1 Γ2 Γm s A1 A2 :
    ismix' Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm |-i llift0 #|Γm| A1 : sSort s ->
    Σ ;;; Γ ,,, Γm |-i rlift0 #|Γm|A2 : sSort s ->
    ismix' Σ Γ
          (Γ1 ,, A1)
          (Γ2 ,, A2)
          (Γm ,, (sPack (llift0 #|Γm| A1) (rlift0 #|Γm| A2)))
.

Lemma wf_mix {Σ Γ Γ1 Γ2 Γm} (h : wf Σ Γ) :
  ismix' Σ Γ Γ1 Γ2 Γm ->
  wf Σ (Γ ,,, Γm).
Proof.
  intro hm. induction hm.
  - cbn. assumption.
  - cbn. econstructor.
    + assumption.
    + eapply type_Pack with (s0 := s) ; assumption.
Defined.

Fact mix'_length1 :
  forall {Σ Γ Γ1 Γ2 Γm},
    ismix' Σ Γ Γ1 Γ2 Γm ->
    #|Γm| = #|Γ1|.
Proof.
  intros Σ Γ Γ1 Γ2 Γm hm.
  dependent induction hm.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

Fact mix'_length2 :
  forall {Σ Γ Γ1 Γ2 Γm},
    ismix' Σ Γ Γ1 Γ2 Γm ->
    #|Γm| = #|Γ2|.
Proof.
  intros Σ Γ Γ1 Γ2 Γm hm.
  dependent induction hm.
  - cbn. reflexivity.
  - cbn. f_equal. assumption.
Defined.

Definition llift_subst :
  forall (u t : sterm) (i j m : nat),
    llift j (i+m) (u {m := t}) = (llift j (S i+m) u) {m := llift j i t}.
Proof.
  induction u ; intros t i j m.
  all: try (cbn ; f_equal;
            try replace (S (S (S (j + m))))%nat with (j + (S (S (S m))))%nat by mylia ;
            try replace (S (S (j + m)))%nat with (j + (S (S m)))%nat by mylia ;
            try replace (S (j + m))%nat with (j + (S m))%nat by mylia ;
            try replace (S (S (S (i + m))))%nat with (i + (S (S (S m))))%nat by mylia ;
            try replace (S (S (i + m)))%nat with (i + (S (S m)))%nat by mylia ;
            try replace (S (i + m))%nat with (i + (S m))%nat by mylia;
            try  (rewrite IHu; cbn; repeat f_equal; mylia);
            try  (rewrite IHu1; cbn; repeat f_equal; mylia);
            try  (rewrite IHu2; cbn; repeat f_equal; mylia);
            try  (rewrite IHu3; cbn; repeat f_equal; mylia);
            try  (rewrite IHu4; cbn; repeat f_equal; mylia);
            try  (rewrite IHu5; cbn; repeat f_equal; mylia);
            try  (rewrite IHu6; cbn; repeat f_equal; mylia);
            try  (rewrite IHu7; cbn; repeat f_equal; mylia);
            try  (rewrite IHu8; cbn; repeat f_equal; mylia)).
  case_eq (m ?= n) ; intro e ; bprop e.
  - subst. case_eq (n <=? i + n) ; intro e1 ; bprop e1 ; try mylia.
    cbn. rewrite e. rewrite lift_llift3 by mylia.
    f_equal. mylia.
  - case_eq (n <=? i + m) ; intro e1 ; bprop e1.
    + unfold llift at 1.
      case_eq (Init.Nat.pred n <? i + m) ; intro e3 ; bprop e3 ; try mylia.
      cbn. rewrite e. reflexivity.
    + case_eq (n <=? i+m+j) ; intro e3 ; bprop e3.
      * unfold llift at 1.
        case_eq (Init.Nat.pred n <? i + m) ; intro e5 ; bprop e5 ; try mylia.
        case_eq (Init.Nat.pred n <? i+m+j) ; intro e7 ; bprop e7 ; try mylia.
        cbn. rewrite e. reflexivity.
      * unfold llift at 1.
        case_eq (Init.Nat.pred n <? i + m) ; intro e5 ; bprop e5 ; try mylia.
        case_eq (Init.Nat.pred n <? i+m+j) ; intro e7 ; bprop e7 ; try mylia.
        cbn. rewrite e. reflexivity.
  - case_eq (n <=? i+m) ; intro e1 ; bprop e1 ; try mylia.
    unfold llift at 1.
    case_eq (n <? i+m) ; intro e3 ; bprop e3 ; try mylia.
    cbn. rewrite e. reflexivity.
Defined.

Definition rlift_subst :
  forall (u t : sterm) (i j m : nat),
    rlift j (i+m) (u {m := t}) = (rlift j (S i+m) u) {m := rlift j i t}.
Proof.
  induction u ; intros t i j m.
  all: try (cbn ; f_equal;
            try replace (S (S (S (j + m))))%nat with (j + (S (S (S m))))%nat by mylia ;
            try replace (S (S (j + m)))%nat with (j + (S (S m)))%nat by mylia ;
            try replace (S (j + m))%nat with (j + (S m))%nat by mylia ;
            try replace (S (S (S (i + m))))%nat with (i + (S (S (S m))))%nat by mylia ;
            try replace (S (S (i + m)))%nat with (i + (S (S m)))%nat by mylia ;
            try replace (S (i + m))%nat with (i + (S m))%nat by mylia;
            try  (rewrite IHu; cbn; repeat f_equal; mylia);
            try  (rewrite IHu1; cbn; repeat f_equal; mylia);
            try  (rewrite IHu2; cbn; repeat f_equal; mylia);
            try  (rewrite IHu3; cbn; repeat f_equal; mylia);
            try  (rewrite IHu4; cbn; repeat f_equal; mylia);
            try  (rewrite IHu5; cbn; repeat f_equal; mylia);
            try  (rewrite IHu6; cbn; repeat f_equal; mylia);
            try  (rewrite IHu7; cbn; repeat f_equal; mylia);
            try  (rewrite IHu8; cbn; repeat f_equal; mylia)).
  case_eq (m ?= n) ; intro e ; bprop e.
  - subst. case_eq (n <=? i + n) ; intro e1 ; bprop e1 ; try mylia.
    cbn. rewrite e. rewrite lift_rlift3 by mylia.
    f_equal. mylia.
  - case_eq (n <=? i + m) ; intro e1 ; bprop e1.
    + unfold rlift at 1.
      case_eq (Init.Nat.pred n <? i + m) ; intro e3 ; bprop e3 ; try mylia.
      cbn. rewrite e. reflexivity.
    + case_eq (n <=? i+m+j) ; intro e3 ; bprop e3.
      * unfold rlift at 1.
        case_eq (Init.Nat.pred n <? i + m) ; intro e5 ; bprop e5 ; try mylia.
        case_eq (Init.Nat.pred n <? i+m+j) ; intro e7 ; bprop e7 ; try mylia.
        cbn. rewrite e. reflexivity.
      * unfold rlift at 1.
        case_eq (Init.Nat.pred n <? i + m) ; intro e5 ; bprop e5 ; try mylia.
        case_eq (Init.Nat.pred n <? i+m+j) ; intro e7 ; bprop e7 ; try mylia.
        cbn. rewrite e. reflexivity.
  - case_eq (n <=? i+m) ; intro e1 ; bprop e1 ; try mylia.
    unfold rlift at 1.
    case_eq (n <? i+m) ; intro e3 ; bprop e3 ; try mylia.
    cbn. rewrite e. reflexivity.
Defined.

(* Should be somewhere else. *)
Lemma inversion_wf_cat :
  forall {Σ Δ Γ},
    wf Σ (Γ ,,, Δ) ->
    wf Σ Γ.
Proof.
  intros Σ Δ. induction Δ ; intros Γ h.
  - assumption.
  - dependent destruction h.
    apply IHΔ. assumption.
Defined.

Fact nil_eq_cat :
  forall {Δ Γ},
    [] = Γ ,,, Δ ->
    ([] = Γ) * ([] = Δ).
Proof.
  intro Δ ; destruct Δ ; intros Γ e.
  - rewrite cat_nil in e. split ; easy.
  - cbn in e. inversion e.
Defined.

(* llift/rlift and closedness *)

Fact closed_above_llift_id :
  forall t n k l,
    closed_above l t = true ->
    k >= l ->
    llift n k t = t.
Proof.
  intro t. induction t ; intros m k l clo h.
  all: try (cbn ; cbn in clo ; repeat destruct_andb ;
            repeat erewrite_close_above_lift_id ;
            reflexivity).
  unfold closed in clo. unfold closed_above in clo.
  bprop clo. unfold llift.
  case_eq (n <? k) ; intro e ; bprop e ; try mylia.
  reflexivity.
Defined.

Fact closed_llift :
  forall t n k,
    closed t ->
    llift n k t = t.
Proof.
  intros t n k h.
  unfold closed in h.
  eapply closed_above_llift_id.
  - eassumption.
  - mylia.
Defined.

Fact closed_above_rlift_id :
  forall t n k l,
    closed_above l t = true ->
    k >= l ->
    rlift n k t = t.
Proof.
  intro t. induction t ; intros m k l clo h.
  all: try (cbn ; cbn in clo ; repeat destruct_andb ;
            repeat erewrite_close_above_lift_id ;
            reflexivity).
  unfold closed in clo. unfold closed_above in clo.
  bprop clo. unfold rlift.
  case_eq (n <? k) ; intro e ; bprop e ; try mylia.
  reflexivity.
Defined.

Fact closed_rlift :
  forall t n k,
    closed t ->
    rlift n k t = t.
Proof.
  intros t n k h.
  unfold closed in h.
  eapply closed_above_rlift_id.
  - eassumption.
  - mylia.
Defined.

Lemma nl_llift :
  forall {t u n k},
    nl t = nl u ->
    nl (llift n k t) = nl (llift n k u).
Proof.
  intros t u n k.
  case (nl_dec (nl t) (nl u)).
  - intros e _.
    revert u e n k.
    induction t ;
    intros u e m k ; destruct u ; cbn in e ; try discriminate e.
    all:
      try (cbn ; inversion e ;
           repeat (erewrite_assumption by eassumption) ; reflexivity).
  - intros h e. exfalso. apply h. apply e.
Defined.

Lemma nl_rlift :
  forall {t u n k},
    nl t = nl u ->
    nl (rlift n k t) = nl (rlift n k u).
Proof.
  intros t u n k.
  case (nl_dec (nl t) (nl u)).
  - intros e _.
    revert u e n k.
    induction t ;
    intros u e m k ; destruct u ; cbn in e ; try discriminate e.
    all:
      try (cbn ; inversion e ;
           repeat (erewrite_assumption by eassumption) ; reflexivity).
  - intros h e. exfalso. apply h. apply e.
Defined.

Fact llift_ax_type :
  forall {Σ},
    type_glob Σ ->
    forall {id ty},
      lookup_glob Σ id = Some ty ->
      forall n k, llift n k ty = ty.
Proof.
  intros Σ hg id ty isd n k.
  destruct (typed_ax_type hg isd).
  eapply closed_llift.
  eapply type_ctxempty_closed. eassumption.
Defined.

Fact rlift_ax_type :
  forall {Σ},
    type_glob Σ ->
    forall {id ty},
      lookup_glob Σ id = Some ty ->
      forall n k, rlift n k ty = ty.
Proof.
  intros Σ hg id ty isd n k.
  destruct (typed_ax_type hg isd).
  eapply closed_rlift.
  eapply type_ctxempty_closed. eassumption.
Defined.

Lemma nth_error_llift_context :
  forall Γ k n A,
    nth_error Γ n = Some A ->
    nth_error (llift_context k Γ) n = Some (llift k (#|Γ| - S n) A).
Proof.
  intros Γ k n A e.
  induction Γ in k, n, A, e |- *.
  1:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in e. inversion e. subst. clear e.
    cbn. f_equal. f_equal. mylia.
  - cbn. cbn in e. eapply IHΓ in e. rewrite e. reflexivity.
Defined.

Lemma nth_error_rlift_context :
  forall Γ k n A,
    nth_error Γ n = Some A ->
    nth_error (rlift_context k Γ) n = Some (rlift k (#|Γ| - S n) A).
Proof.
  intros Γ k n A e.
  induction Γ in k, n, A, e |- *.
  1:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in e. inversion e. subst. clear e.
    cbn. f_equal. f_equal. mylia.
  - cbn. cbn in e. eapply IHΓ in e. rewrite e. reflexivity.
Defined.

Lemma nth_error_ismix'_left :
  forall Σ Γ Γ1 Γ2 Γm n A,
    ismix' Σ Γ Γ1 Γ2 Γm ->
    nth_error Γ1 n = Some A ->
    ∑ B,
      nth_error Γ2 n = Some B /\
      nth_error Γm n =
      Some (sPack (llift0 (#|Γm| - S n) A) (rlift0 (#|Γm| - S n) B)).
Proof.
  intros Σ Γ Γ1 Γ2 Γm n A hm e.
  induction hm in A, n, e |- *.
  1:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in e. inversion e. subst. clear e.
    cbn. eexists. intuition eauto.
    f_equal. f_equal. all: f_equal. all: mylia.
  - cbn in e. eapply IHhm in e as [B [e2 em]].
    cbn. eexists. intuition eauto.
Defined.

Lemma nth_error_ismix'_right :
  forall Σ Γ Γ1 Γ2 Γm n A,
    ismix' Σ Γ Γ1 Γ2 Γm ->
    nth_error Γ2 n = Some A ->
    ∑ B,
      nth_error Γ1 n = Some B /\
      nth_error Γm n =
      Some (sPack (llift0 (#|Γm| - S n) B) (rlift0 (#|Γm| - S n) A)).
Proof.
  intros Σ Γ Γ1 Γ2 Γm n A hm e.
  induction hm in A, n, e |- *.
  1:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in e. inversion e. subst. clear e.
    cbn. eexists. intuition eauto.
    f_equal. f_equal. all: f_equal. all: mylia.
  - cbn in e. eapply IHhm in e as [B [e2 em]].
    cbn. eexists. intuition eauto.
Defined.

Ltac lh h :=
  lazymatch goal with
  | [ type_llift' :
        forall (Σ : sglobal_context) (Γ Γ1 Γ2 Γm Δ : scontext) (t A : sterm),
          Σ;;; Γ ,,, Γ1 ,,, Δ |-i t : A ->
          type_glob Σ ->
          ismix' Σ Γ Γ1 Γ2 Γm ->
          Σ;;; Γ ,,, Γm ,,, llift_context #|Γm| Δ
          |-i llift #|Γm| #|Δ| t : llift #|Γm| #|Δ| A
    |- _ ] =>
    lazymatch type of h with
    | _ ;;; ?Γ' ,,, ?Γ1' ,,, ?Δ' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_llift' with (Γ := Γ') (Γ1 := Γ1') (Δ := Δ') (A := T') ; [
            exact h
          | eassumption
          | eassumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,,, ?Γ1' ,,, ?Δ'),, ?d' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_llift' with (Γ := Γ') (Γ1 := Γ1') (Δ := Δ',, d') (A := T') ; [
            exact h
          | eassumption
          | eassumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,,, ?Γ1' ,,, ?Δ'),, ?d',, ?d'' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_llift' with (Γ := Γ') (Γ1 := Γ1') (Δ := (Δ',, d'),, d'') (A := T') ; [
            exact h
          | eassumption
          | eassumption
          ]
        | .. ]
      | .. ]
    end ; try (cbn ; reflexivity)
  | _ => fail "Cannot retrieve type_llift'"
  end.

Ltac rh h :=
  lazymatch goal with
  | [ type_rlift' :
        forall (Σ : sglobal_context) (Γ Γ1 Γ2 Γm Δ : scontext) (t A : sterm),
          Σ;;; Γ ,,, Γ2 ,,, Δ |-i t : A ->
          type_glob Σ ->
          ismix' Σ Γ Γ1 Γ2 Γm ->
          Σ;;; Γ ,,, Γm ,,, rlift_context #|Γm| Δ
          |-i rlift #|Γm| #|Δ| t : rlift #|Γm| #|Δ| A
    |- _ ] =>
    lazymatch type of h with
    | _ ;;; ?Γ' ,,, ?Γ2' ,,, ?Δ' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_rlift' with (Γ := Γ') (Γ2 := Γ2') (Δ := Δ') (A := T') ; [
            exact h
          | eassumption
          | eassumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,,, ?Γ2' ,,, ?Δ'),, ?d' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_rlift' with (Γ := Γ') (Γ2 := Γ2') (Δ := Δ',, d') (A := T') ; [
            exact h
          | eassumption
          | eassumption
          ]
        | .. ]
      | .. ]
    | _ ;;; (?Γ' ,,, ?Γ2' ,,, ?Δ'),, ?d',, ?d'' |-i _ : ?T' =>
      eapply meta_conv ; [
        eapply meta_ctx_conv ; [
          eapply type_rlift' with (Γ := Γ') (Γ2 := Γ2') (Δ := (Δ',, d'),, d'') (A := T') ; [
            exact h
          | eassumption
          | eassumption
          ]
        | .. ]
      | .. ]
    end ; try (cbn ; reflexivity)
  | _ => fail "Cannot retrieve type_rlift'"
  end.

Ltac emh :=
  lazymatch goal with
  | h : _ ;;; _ |-i ?t : _ |- _ ;;; _ |-i llift _ _ ?t : _ => lh h
  | h : _ ;;; _ |-i ?t : _ |- _ ;;; _ |-i rlift _ _ ?t : _ => rh h
  | _ => fail "Not a case for emh"
  end.

Fixpoint type_llift' {Σ Γ Γ1 Γ2 Γm Δ t A}
  (h : Σ ;;; Γ ,,, Γ1 ,,, Δ |-i t : A) {struct h} :
  type_glob Σ ->
  ismix' Σ Γ Γ1 Γ2 Γm ->
  Σ ;;; Γ ,,, Γm ,,, llift_context #|Γm| Δ
  |-i llift #|Γm| #|Δ| t : llift #|Γm| #|Δ| A

with type_rlift' {Σ Γ Γ1 Γ2 Γm Δ t A}
  (h : Σ ;;; Γ ,,, Γ2 ,,, Δ |-i t : A) {struct h} :
  type_glob Σ ->
  ismix' Σ Γ Γ1 Γ2 Γm ->
  Σ ;;; Γ ,,, Γm ,,, rlift_context #|Γm| Δ
  |-i rlift #|Γm| #|Δ| t : rlift #|Γm| #|Δ| A

with wf_llift' {Σ Γ Γ1 Γ2 Γm Δ} (h : wf Σ (Γ ,,, Γ1 ,,, Δ)) {struct h} :
  type_glob Σ ->
  ismix' Σ Γ Γ1 Γ2 Γm ->
  wf Σ (Γ ,,, Γm ,,, llift_context #|Γm| Δ)

with wf_rlift' {Σ Γ Γ1 Γ2 Γm Δ} (h : wf Σ (Γ ,,, Γ2 ,,, Δ)) {struct h} :
  type_glob Σ ->
  ismix' Σ Γ Γ1 Γ2 Γm ->
  wf Σ (Γ ,,, Γm ,,, rlift_context #|Γm| Δ)
.
Proof.
  (* type_llift' *)
  - { dependent destruction h ; intros hg hm.
      - unfold llift at 1.
        case_eq (n <? #|Δ|) ; intro e ; bprop e.
        + eapply meta_conv.
          * eapply type_Rel.
            1: eapply wf_llift' ; eassumption.
            unfold ",,,". rewrite nth_error_app1.
            2:{ rewrite llift_context_length. auto. }
            eapply nth_error_llift_context.
            unfold ",,," in H0. rewrite nth_error_app1 in H0 by auto.
            eassumption.
          * rewrite lift_llift3 by mylia.
            f_equal. mylia.
        + case_eq (n <? #|Δ| + #|Γm|) ; intro e1 ; bprop e1.
          * unfold ",,," in H0. rewrite nth_error_app2 in H0 by auto.
            apply mix'_length1 in hm as ?.
            rewrite nth_error_app1 in H0 by mylia.
            eapply nth_error_ismix'_left in H0 as [B [e' em]].
            2: eassumption.
            eapply type_ProjT1' ; try assumption.
            eapply meta_conv.
            -- eapply type_Rel.
               1: eapply wf_llift' ; eassumption.
               unfold ",,,". rewrite nth_error_app2.
               2:{ rewrite llift_context_length. auto. }
               rewrite llift_context_length.
               rewrite nth_error_app1 by mylia.
               eassumption.
            -- cbn. f_equal.
               replace #|Δ| with (#|Δ| + 0)%nat at 2 by mylia.
               rewrite <- lift_llift4 by mylia.
               f_equal. f_equal. mylia.
          * eapply meta_conv.
            -- eapply type_Rel.
               1: eapply wf_llift' ; eassumption.
               unfold ",,,". rewrite nth_error_app2.
               2:{ rewrite llift_context_length. auto. }
               rewrite llift_context_length.
               rewrite nth_error_app2 by mylia.
               unfold ",,," in H0. rewrite nth_error_app2 in H0 by auto.
               apply  mix'_length1 in hm as e'.
               rewrite nth_error_app2 in H0 by mylia.
               rewrite e'. eassumption.
            -- rewrite lift_llift5 by mylia. reflexivity.
      - cbn. eapply type_Sort. eapply wf_llift' ; eassumption.
      - cbn. eapply type_Prod ; emh.
      - cbn. eapply type_Lambda ; emh.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite llift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_App ; emh.
      - cbn. eapply type_Sum ; emh.
      - cbn. eapply type_Pair ; emh.
        replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite llift_subst.
        cbn. replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        reflexivity.
      - cbn. eapply type_Pi1 ; emh.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite llift_subst.
        cbn. replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_Pi2 ; emh.
      - cbn. eapply type_Eq ; emh.
      - cbn. eapply type_Refl ; emh.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite llift_subst.
        replace (S #|Δ| + 0)%nat with (#|Δ| + 1)%nat by mylia.
        rewrite llift_subst.
        cbn. replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        replace (S (#|Δ| + 1))%nat with (S (S #|Δ|)) by mylia.
        eapply type_J ; emh.
        + cbn. unfold ssnoc. cbn. f_equal. f_equal.
          * replace (S #|Δ|) with (1 + #|Δ|)%nat by mylia.
            rewrite lift_llift3 by mylia. reflexivity.
          * replace (S #|Δ|) with (1 + #|Δ|)%nat by mylia.
            rewrite lift_llift3 by mylia. reflexivity.
        + replace (S (S #|Δ|)) with ((S #|Δ|) + 1)%nat by mylia.
          rewrite <- llift_subst.
          change (sRefl (llift #|Γm| #|Δ| A0) (llift #|Γm| #|Δ| u))
            with (llift #|Γm| #|Δ| (sRefl A0 u)).
          replace (#|Δ| + 1)%nat with (S #|Δ| + 0)%nat by mylia.
          rewrite <- llift_subst. f_equal. mylia.
      - cbn. eapply type_Transport ; emh.
      - cbn.
        replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite 2!llift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_Beta ; emh.
      - cbn. eapply type_Heq ; emh.
      - cbn. eapply type_HeqToEq ; emh.
      - cbn. eapply type_HeqRefl ; emh.
      - cbn. eapply type_HeqSym ; emh.
      - cbn.
        eapply @type_HeqTrans
          with (B := llift #|Γm| #|Δ| B) (b := llift #|Γm| #|Δ| b) ; emh.
      - cbn. eapply type_HeqTransport ; emh.
      - cbn. eapply type_CongProd ; emh.
        cbn. f_equal.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
      - cbn. eapply type_CongLambda ; emh.
        + cbn. f_equal.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
        + cbn. f_equal.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite 2!llift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_CongApp ; emh.
        cbn. f_equal.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
      - cbn. eapply type_CongSum ; emh.
        cbn. f_equal.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
      - cbn. eapply type_CongPair ; emh.
        + cbn. f_equal.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
          * rewrite lift_llift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite llift_subst. cbn. reflexivity.
        + cbn. f_equal.
          * replace #|Δ| with (#|Δ| + 0)%nat by mylia.
            rewrite llift_subst. cbn.
            replace (#|Δ| + 0)%nat with #|Δ| by mylia.
            reflexivity.
          * replace #|Δ| with (#|Δ| + 0)%nat by mylia.
            rewrite llift_subst. cbn.
            replace (#|Δ| + 0)%nat with #|Δ| by mylia.
            reflexivity.
        + replace #|Δ| with (#|Δ| + 0)%nat by mylia.
          rewrite llift_subst. cbn.
          replace (#|Δ| + 0)%nat with #|Δ| by mylia.
          reflexivity.
        + replace #|Δ| with (#|Δ| + 0)%nat by mylia.
          rewrite llift_subst. cbn.
          replace (#|Δ| + 0)%nat with #|Δ| by mylia.
          reflexivity.
      - cbn. eapply type_CongPi1 ; emh.
        cbn. f_equal.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite 2!llift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_CongPi2 ; emh.
        cbn. f_equal.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
        + rewrite lift_llift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite llift_subst. cbn. reflexivity.
      - cbn. eapply type_CongEq ; emh.
      - cbn. eapply type_CongRefl ; emh.
      - cbn. eapply type_EqToHeq ; emh.
      - cbn. eapply type_HeqTypeEq ; emh.
      - cbn. eapply type_Pack ; emh.
      - cbn. eapply @type_ProjT1 with (A2 := llift #|Γm| #|Δ| A2) ; emh.
      - cbn. eapply @type_ProjT2 with (A1 := llift #|Γm| #|Δ| A1) ; emh.
      - cbn. eapply type_ProjTe ; emh.
      - cbn. erewrite llift_ax_type by eassumption.
        eapply type_Ax.
        + eapply wf_llift' ; eassumption.
        + assumption.
      - eapply type_rename.
        + emh.
        + eapply nl_llift. assumption.
    }

  (* type_rlift' *)
  - { dependent destruction h ; intros hg hm.
      - unfold rlift at 1.
        case_eq (n <? #|Δ|) ; intro e ; bprop e.
        + eapply meta_conv.
          * eapply type_Rel.
            1: eapply wf_rlift' ; eassumption.
            unfold ",,,". rewrite nth_error_app1.
            2:{ rewrite rlift_context_length. auto. }
            eapply nth_error_rlift_context.
            unfold ",,," in H0. rewrite nth_error_app1 in H0 by auto.
            eassumption.
          * rewrite lift_rlift3 by mylia.
            f_equal. mylia.
        + case_eq (n <? #|Δ| + #|Γm|) ; intro e1 ; bprop e1.
          * unfold ",,," in H0. rewrite nth_error_app2 in H0 by auto.
            apply mix'_length2 in hm as ?.
            rewrite nth_error_app1 in H0 by mylia.
            eapply nth_error_ismix'_right in H0 as [B [e' em]].
            2: eassumption.
            eapply type_ProjT2' ; try assumption.
            eapply meta_conv.
            -- eapply type_Rel.
               1: eapply wf_rlift' ; eassumption.
               unfold ",,,". rewrite nth_error_app2.
               2:{ rewrite rlift_context_length. auto. }
               rewrite rlift_context_length.
               rewrite nth_error_app1 by mylia.
               eassumption.
            -- cbn. f_equal.
               replace #|Δ| with (#|Δ| + 0)%nat at 2 by mylia.
               rewrite <- lift_rlift4 by mylia.
               f_equal. f_equal. mylia.
          * eapply meta_conv.
            -- eapply type_Rel.
               1: eapply wf_rlift' ; eassumption.
               unfold ",,,". rewrite nth_error_app2.
               2:{ rewrite rlift_context_length. auto. }
               rewrite rlift_context_length.
               rewrite nth_error_app2 by mylia.
               unfold ",,," in H0. rewrite nth_error_app2 in H0 by auto.
               apply  mix'_length2 in hm as e'.
               rewrite nth_error_app2 in H0 by mylia.
               rewrite e'. eassumption.
            -- rewrite lift_rlift5 by mylia. reflexivity.
      - cbn. eapply type_Sort. eapply wf_rlift' ; eassumption.
      - cbn. eapply type_Prod ; emh.
      - cbn. eapply type_Lambda ; emh.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite rlift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_App ; emh.
      - cbn. eapply type_Sum ; emh.
      - cbn. eapply type_Pair ; emh.
        replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite rlift_subst.
        cbn. replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        reflexivity.
      - cbn. eapply type_Pi1 ; emh.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite rlift_subst.
        cbn. replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_Pi2 ; emh.
      - cbn. eapply type_Eq ; emh.
      - cbn. eapply type_Refl ; emh.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite rlift_subst.
        replace (S #|Δ| + 0)%nat with (#|Δ| + 1)%nat by mylia.
        rewrite rlift_subst.
        cbn. replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        replace (S (#|Δ| + 1))%nat with (S (S #|Δ|)) by mylia.
        eapply type_J ; emh.
        + cbn. unfold ssnoc. cbn. f_equal. f_equal.
          * replace (S #|Δ|) with (1 + #|Δ|)%nat by mylia.
            rewrite lift_rlift3 by mylia. reflexivity.
          * replace (S #|Δ|) with (1 + #|Δ|)%nat by mylia.
            rewrite lift_rlift3 by mylia. reflexivity.
        + replace (S (S #|Δ|)) with ((S #|Δ|) + 1)%nat by mylia.
          rewrite <- rlift_subst.
          change (sRefl (rlift #|Γm| #|Δ| A0) (rlift #|Γm| #|Δ| u))
            with (rlift #|Γm| #|Δ| (sRefl A0 u)).
          replace (#|Δ| + 1)%nat with (S #|Δ| + 0)%nat by mylia.
          rewrite <- rlift_subst. f_equal. mylia.
      - cbn. eapply type_Transport ; emh.
      - cbn.
        replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite 2!rlift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_Beta ; emh.
      - cbn. eapply type_Heq ; emh.
      - cbn. eapply type_HeqToEq ; emh.
      - cbn. eapply type_HeqRefl ; emh.
      - cbn. eapply type_HeqSym ; emh.
      - cbn.
        eapply @type_HeqTrans
          with (B := rlift #|Γm| #|Δ| B) (b := rlift #|Γm| #|Δ| b) ; emh.
      - cbn. eapply type_HeqTransport ; emh.
      - cbn. eapply type_CongProd ; emh.
        cbn. f_equal.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
      - cbn. eapply type_CongLambda ; emh.
        + cbn. f_equal.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
        + cbn. f_equal.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite 2!rlift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_CongApp ; emh.
        cbn. f_equal.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
      - cbn. eapply type_CongSum ; emh.
        cbn. f_equal.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
      - cbn. eapply type_CongPair ; emh.
        + cbn. f_equal.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
          * rewrite lift_rlift3 by mylia.
            replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
            rewrite rlift_subst. cbn. reflexivity.
        + cbn. f_equal.
          * replace #|Δ| with (#|Δ| + 0)%nat by mylia.
            rewrite rlift_subst. cbn.
            replace (#|Δ| + 0)%nat with #|Δ| by mylia.
            reflexivity.
          * replace #|Δ| with (#|Δ| + 0)%nat by mylia.
            rewrite rlift_subst. cbn.
            replace (#|Δ| + 0)%nat with #|Δ| by mylia.
            reflexivity.
        + replace #|Δ| with (#|Δ| + 0)%nat by mylia.
          rewrite rlift_subst. cbn.
          replace (#|Δ| + 0)%nat with #|Δ| by mylia.
          reflexivity.
        + replace #|Δ| with (#|Δ| + 0)%nat by mylia.
          rewrite rlift_subst. cbn.
          replace (#|Δ| + 0)%nat with #|Δ| by mylia.
          reflexivity.
      - cbn. eapply type_CongPi1 ; emh.
        cbn. f_equal.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
      - cbn. replace #|Δ| with (#|Δ| + 0)%nat by mylia.
        rewrite 2!rlift_subst. cbn.
        replace (#|Δ| + 0)%nat with #|Δ| by mylia.
        eapply type_CongPi2 ; emh.
        cbn. f_equal.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
        + rewrite lift_rlift3 by mylia.
          replace (S #|Δ|) with ((S #|Δ|) + 0)%nat by mylia.
          rewrite rlift_subst. cbn. reflexivity.
      - cbn. eapply type_CongEq ; emh.
      - cbn. eapply type_CongRefl ; emh.
      - cbn. eapply type_EqToHeq ; emh.
      - cbn. eapply type_HeqTypeEq ; emh.
      - cbn. eapply type_Pack ; emh.
      - cbn. eapply @type_ProjT1 with (A2 := rlift #|Γm| #|Δ| A2) ; emh.
      - cbn. eapply @type_ProjT2 with (A1 := rlift #|Γm| #|Δ| A1) ; emh.
      - cbn. eapply type_ProjTe ; emh.
      - cbn. erewrite rlift_ax_type by eassumption.
        eapply type_Ax.
        + eapply wf_rlift' ; eassumption.
        + assumption.
      - eapply type_rename.
        + emh.
        + eapply nl_rlift. assumption.
    }

  (* wf_llift' *)
  - { destruct Δ.
      - cbn. rewrite cat_nil in h.
        intros hg hm. eapply wf_mix.
        + eapply inversion_wf_cat. eassumption.
        + eassumption.
      - cbn. intros hg hm. dependent destruction h.
        econstructor.
        + eapply wf_llift' ; eassumption.
        + eapply type_llift' with (A := sSort s0) ; eassumption.
    }

  (* wf_rlift' *)
  - { destruct Δ.
      - cbn. rewrite cat_nil in h.
        intros hg hm. eapply wf_mix.
        + eapply inversion_wf_cat. eassumption.
        + eassumption.
      - cbn. intros hg hm. dependent destruction h.
        econstructor.
        + eapply wf_rlift' ; eassumption.
        + eapply type_rlift' with (A := sSort s0) ; eassumption.
    }

  Unshelve.
  all: pose (mix'_length1 hm) ;
       pose (mix'_length2 hm) ;
       cbn ; try rewrite !length_cat ;
       try rewrite !llift_context_length ;
       try rewrite !rlift_context_length ;
       try rewrite !length_cat in isdecl ;
       try mylia.
Defined.

Lemma ismix_ismix' :
  forall {Σ Γ Γ1 Γ2 Γm},
    type_glob Σ ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    ismix' Σ Γ Γ1 Γ2 Γm.
Proof.
  intros Σ Γ Γ1 Γ2 Γm hg h.
  dependent induction h.
  - constructor.
  - econstructor.
    + assumption.
    + eapply @type_llift' with (A := sSort s) (Δ := []) ; eassumption.
    + eapply @type_rlift' with (A := sSort s) (Δ := []) ; eassumption.
Defined.

Corollary type_llift :
  forall {Σ Γ Γ1 Γ2 Γm Δ t A},
    type_glob Σ ->
    Σ ;;; Γ ,,, Γ1 ,,, Δ |-i t : A ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm ,,, llift_context #|Γm| Δ
    |-i llift #|Γm| #|Δ| t : llift #|Γm| #|Δ| A.
Proof.
  intros Σ Γ Γ1 Γ2 Γm Δ t A hg ht hm.
  eapply type_llift'.
  - eassumption.
  - assumption.
  - eapply ismix_ismix' ; eassumption.
Defined.

Corollary wf_llift :
  forall {Σ Γ Γ1 Γ2 Γm Δ},
    type_glob Σ ->
    wf Σ (Γ ,,, Γ1 ,,, Δ) ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    wf Σ (Γ ,,, Γm ,,, llift_context #|Γm| Δ).
Proof.
  intros Σ Γ Γ1 Γ2 Γm Δ hg hw hm.
  eapply wf_llift'.
  - eassumption.
  - assumption.
  - eapply ismix_ismix' ; eassumption.
Defined.

Corollary type_rlift :
  forall {Σ Γ Γ1 Γ2 Γm Δ t A},
    type_glob Σ ->
    Σ ;;; Γ ,,, Γ2 ,,, Δ |-i t : A ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm ,,, rlift_context #|Γm| Δ
    |-i rlift #|Γm| #|Δ| t : rlift #|Γm| #|Δ| A.
Proof.
  intros Σ Γ Γ1 Γ2 Γm Δ t A hg ht hm.
  eapply type_rlift'.
  - eassumption.
  - assumption.
  - eapply ismix_ismix' ; eassumption.
Defined.

Corollary wf_rlift :
  forall {Σ Γ Γ1 Γ2 Γm Δ},
    type_glob Σ ->
    wf Σ (Γ ,,, Γ2 ,,, Δ) ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    wf Σ (Γ ,,, Γm ,,, rlift_context #|Γm| Δ).
Proof.
  intros Σ Γ Γ1 Γ2 Γm Δ hg hw hm.
  eapply wf_rlift'.
  - eassumption.
  - assumption.
  - eapply ismix_ismix' ; eassumption.
Defined.

(* Lemma to use ismix knowledge about sorting. *)
Lemma ismix_nth_sort :
  forall {Σ Γ Γ1 Γ2 Γm},
    type_glob Σ ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    forall n A1 A2,
      nth_error Γ1 n = Some A1 ->
      nth_error Γ2 n = Some A2 ->
      ∑ s,
        (Σ;;; Γ ,,, Γ1 |-i lift0 (S n) A1 : sSort s) *
        (Σ;;; Γ ,,, Γ2 |-i lift0 (S n) A2 : sSort s).
Proof.
  intros Σ Γ Γ1 Γ2 Γm hg hm n A1 A2 e1 e2.
  induction hm in n, A1, A2, e1, e2 |- *.
  1:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in *. inversion e1. inversion e2. subst. clear e1 e2.
    exists s. split.
    all: eapply @typing_lift01 with (A := sSort s).
    all: eassumption.
  - cbn in *.
    specialize IHhm with (1 := e1) (2 := e2).
    destruct IHhm as [s' [h1 h2]].
    exists s'. split.
    + replace (S (S n)) with (1 + (S n))%nat by mylia.
      rewrite <- liftP3 with (k := 0) by mylia.
      eapply @typing_lift01 with (A := sSort s'). all: eassumption.
    + replace (S (S n)) with (1 + (S n))%nat by mylia.
      rewrite <- liftP3 with (k := 0) by mylia.
      eapply @typing_lift01 with (A := sSort s'). all: eassumption.
Defined.

(* Simpler to use corollaries *)

Corollary type_llift0 :
  forall {Σ Γ Γ1 Γ2 Γm t A},
    type_glob Σ ->
    Σ ;;; Γ ,,, Γ1 |-i t : A ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm |-i llift0 #|Γm| t : llift0 #|Γm| A.
Proof.
  intros Σ Γ Γ1 Γ2 Γm t A hg ? ?.
  eapply @type_llift with (Δ := nil) ; eassumption.
Defined.

Corollary type_llift1 :
  forall {Σ Γ Γ1 Γ2 Γm t A B},
    type_glob Σ ->
    Σ ;;; (Γ ,,, Γ1) ,, B |-i t : A ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm ,, (llift0 #|Γm| B)
    |-i llift #|Γm| 1 t : llift #|Γm| 1 A.
Proof.
  intros Σ Γ Γ1 Γ2 Γm t A B hg ht hm.
  eapply @type_llift with (Δ := [ B ]).
  - assumption.
  - exact ht.
  - eassumption.
Defined.

Corollary type_rlift0 :
  forall {Σ Γ Γ1 Γ2 Γm t A},
    type_glob Σ ->
    Σ ;;; Γ ,,, Γ2 |-i t : A ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm |-i rlift0 #|Γm| t : rlift0 #|Γm| A.
Proof.
  intros Σ Γ Γ1 Γ2 Γm t A ? ? ?.
  eapply @type_rlift with (Δ := nil) ; eassumption.
Defined.

Corollary type_rlift1 :
  forall {Σ Γ Γ1 Γ2 Γm t A B},
    type_glob Σ ->
    Σ ;;; (Γ ,,, Γ2) ,, B |-i t : A ->
    ismix Σ Γ Γ1 Γ2 Γm ->
    Σ ;;; Γ ,,, Γm ,, (rlift0 #|Γm| B)
    |-i rlift #|Γm| 1 t : rlift #|Γm| 1 A.
Proof.
  intros Σ Γ Γ1 Γ2 Γm t A B hg ht hm.
  eapply @type_rlift with (Δ := [ B ]).
  - assumption.
  - exact ht.
  - eassumption.
Defined.

(* More lemmata about exchange.
   They should go above with the others.
 *)

Lemma llift_substProj :
  forall {t γ l},
    (lift 1 (S l) (llift γ (S l) t)) {l := sProjT1 (sRel 0)} = llift (S γ) l t.
Proof.
  intro t. induction t ; intros γ l.
  all: try (cbn ; f_equal ; easy).
  unfold llift.
  case_eq (n <? S l) ; intro e ; bprop e ; try mylia.
  - case_eq (n <? l) ; intro e1 ; bprop e1 ; try mylia.
    + unfold lift. case_eq (S l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      cbn. case_eq (l ?= n) ; intro e5 ; bprop e5 ; try mylia.
      reflexivity.
    + case_eq (n <? l + S γ) ; intro e3 ; bprop e3 ; try mylia.
      unfold lift. case_eq (S l <=? n) ; intro e5 ; bprop e5 ; try mylia.
      cbn. case_eq (l ?= n) ; intro e7 ; bprop e7 ; try mylia.
      f_equal. f_equal. mylia.
  - case_eq (n <? l) ; intro e1 ; bprop e1 ; try mylia.
    case_eq (n <? S l + γ) ; intro e3 ; bprop e3 ; try mylia.
    + case_eq (n <? l + S γ) ; intro e5 ; bprop e5 ; try mylia.
      unfold lift. case_eq (S l <=? n) ; intro e7 ; bprop e7 ; try mylia.
      cbn. case_eq (l ?= S n) ; intro e9 ; bprop e9 ; try mylia.
      reflexivity.
    + case_eq (n <? l + S γ) ; intro e5 ; bprop e5 ; try mylia.
      unfold lift. case_eq (S l <=? n) ; intro e7 ; bprop e7 ; try mylia.
      cbn. case_eq (l ?= S n) ; intro e9 ; bprop e9 ; try mylia.
      reflexivity.
Defined.

Lemma rlift_substProj :
  forall {t γ l},
    (lift 1 (S l) (rlift γ (S l) t)) {l := sProjT2 (sRel 0)} = rlift (S γ) l t.
Proof.
  intro t. induction t ; intros γ l.
  all: try (cbn ; f_equal ; easy).
  unfold rlift.
  case_eq (n <? S l) ; intro e ; bprop e ; try mylia.
  - case_eq (n <? l) ; intro e1 ; bprop e1 ; try mylia.
    + unfold lift. case_eq (S l <=? n) ; intro e3 ; bprop e3 ; try mylia.
      cbn. case_eq (l ?= n) ; intro e5 ; bprop e5 ; try mylia.
      reflexivity.
    + case_eq (n <? l + S γ) ; intro e3 ; bprop e3 ; try mylia.
      unfold lift. case_eq (S l <=? n) ; intro e5 ; bprop e5 ; try mylia.
      cbn. case_eq (l ?= n) ; intro e7 ; bprop e7 ; try mylia.
      f_equal. f_equal. mylia.
  - case_eq (n <? l) ; intro e1 ; bprop e1 ; try mylia.
    case_eq (n <? S l + γ) ; intro e3 ; bprop e3 ; try mylia.
    + case_eq (n <? l + S γ) ; intro e5 ; bprop e5 ; try mylia.
      unfold lift. case_eq (S l <=? n) ; intro e7 ; bprop e7 ; try mylia.
      cbn. case_eq (l ?= S n) ; intro e9 ; bprop e9 ; try mylia.
      reflexivity.
    + case_eq (n <? l + S γ) ; intro e5 ; bprop e5 ; try mylia.
      unfold lift. case_eq (S l <=? n) ; intro e7 ; bprop e7 ; try mylia.
      cbn. case_eq (l ?= S n) ; intro e9 ; bprop e9 ; try mylia.
      reflexivity.
Defined.

Lemma nth_error_mix :
  forall Σ Γ Γ1 Γ2 Γm n A1 A2,
    ismix Σ Γ Γ1 Γ2 Γm ->
    nth_error Γ1 n = Some A1 ->
    nth_error Γ2 n = Some A2 ->
    nth_error Γm n =
    Some (sPack (llift0 (#|Γm| - S n) A1) (rlift0 (#|Γm| - S n) A2)).
Proof.
  intros Σ Γ Γ1 Γ2 Γm n A1 A2 hm e1 e2.
  induction hm in n, A1, A2, e1, e2 |- *.
  1:{ destruct n. all: discriminate. }
  destruct n.
  - cbn in *. inversion e1. inversion e2. subst. clear e1 e2.
    f_equal. f_equal. all: f_equal. all: mylia.
  - cbn in *. eapply IHhm. all: assumption.
Defined.

End Mix.


(* PREAMBLE *)

From compcert.common     Require Memory.
From compcert.lib        Require Coqlib.

From trancert.properties Require Env.
From trancert.lib        Require All.

Import Csem Memory Mem Coqlib Tac properties.Env Maps.PTree lib.All ContinuationQuant.

(** * High-level properties of [free] memory operation *)

(** ** [free_list] *)

(** When [free_list] accepts a concatenation of two lists, it can be broken into
two [free_list]s with an intermediate memory state. *)

Theorem free_list_app:
  forall xs ys m1 m2 ,
    free_list m1 (xs ++ ys) = Some m2 ->
    exists m3, free_list m1 xs = Some m3 /\ free_list m3 ys = Some m2.
Proof.
  induction xs.
  - by intros; simpl in *; eauto.
  - intros; simpl in *; repeat option_cases.
    subst; eauto.
Qed.

(** This is the inverse of [free_list_app]. *)

Theorem free_list_concat:
  forall xs ys m1 m2 m3 ,
    free_list m1 xs = Some m3 ->
    free_list m3 ys = Some m2 ->
    free_list m1 (xs ++ ys) = Some m2.
Proof.
  elim.
  - intros; simpl in *. by inv H.
  - intros; simpl in *; repeat option_cases; subst. by eauto.
Qed.

(** [free_list] does not change permissions for blocks outside the list.  *)
Theorem free_list_preserves_perm:
  forall b blocks m1 m2 ofs k p,
    free_list m1 blocks = Some m2 ->
    (forall l r, ~ In (b, l, r) blocks) ->
    perm m1 b ofs k p  ->
    perm m2 b ofs k p  .
Proof.
  induction blocks.
  - intros until p. inversion 1; auto.
  - intros m1 m2 ofs k p H Hblocks H1.
    simpl in *.
    repeat option_cases. subst.
    eapply IHblocks in H; eauto.
    + intros l r Hnot. eapply (Hblocks l r).
        by eauto.
    + eapply perm_free_1; eauto.
      left.
      intro Hb; subst.
      by eapply Hblocks; auto.
Qed.

(** A successful [free_list] means that all its address ranges were freeable. *)
Theorem free_list_preserves_range_perm:
  forall ls m1 m2 b lo hi,
    free_list m1 ls = Some m2 ->
    In (b, lo, hi) ls ->
    range_perm m1 b lo hi Memtype.Cur Memtype.Freeable.
Proof.
  unfold range_perm.
  induction ls.
  inversion 2.
  intros m1 m2 b lo hi H [Hfst | Hnext];
    simpl in *; repeat option_cases; subst.
  - inv Hfst.
    eapply free_range_perm; eauto.
  - intros ofs H0.
    eapply perm_free_3; eauto.
Qed.

(** [free_list] does not change the maximal block index. *)
Theorem free_list_nextblock:
  forall ls m1 m2,
    free_list m1 ls = Some m2 ->
    nextblock m2 = nextblock m1.
Proof.
  induction ls.
  - intros; inv H; reflexivity.
  - intros m1 m2 H. simpl in *. repeat option_cases.
    subst. apply nextblock_free in Heq1.
    rewrite <-Heq1.
    by apply IHls.
Qed.

(** For a list of unique ranges, if we can perform [free_list], then we can pick any of its elements and free it in the original memory state. *)
Theorem free_after_free_list_correct:
  forall hs m1 m2 a b c,
    list_norepet (List.map (fun x => fst (fst x)) (hs ++ (a,b,c)::nil)) ->
    free_list m1 (hs ++ (a,b,c)::nil) = Some m2 ->
    exists m2', free m1 a b c = Some m2'.
Proof.
  intros hs m1 m2 a b c H H0.
  simpl in *.
  edestruct range_perm_free; eauto.
  eapply free_list_preserves_range_perm; eauto.
  rewrite in_app.
  simpl; auto.
Qed.

(** *Local environment *)

(** Local environment is always freeable; this is the property of CompCert C semantics. *)

(** Performing a regular [free] on a local variable of the current environment
will not affect permissions of any local variable of a different function
instance.

Property [cont_envs_distinct_blocks] is required for this; it guarantees that all local variables of all functions are stored in different blocks.
 *)

Theorem free_env_freeable:
  forall (ge:Csem.genv) m1 m2 e  f k i id b t,
    get i e = Some (b,t) ->
    free m1 b 0%Z (Ctypes.sizeof ge t)= Some m2 ->
    econt_envs_distinct_blocks e k ->
    forall_envs_in_econt (fun _ _ => env_freeable ge m1) f id k ->
    forall_envs_in_econt (fun _ _ => env_freeable ge m2) f id k .
Proof.
  unfold forall_envs_in_econt.
  intros ge m1 m2 e f k i id b t0 Hget Hfree Hdistinct Hcont.
  generalize dependent f.
  generalize dependent id.
  induction k; intros; inv Hdistinct; inv Hcont; try solve [econstructor;  eauto 2].
  (* One non-trivial case: Kcall *)
  - econstructor; simpl in *; repeat clean; eauto.
    unfold env_freeable, range_perm, envs_distinct_blocks in *.
    intros; eapply perm_free_1; eauto.
    left; apply not_eq_sym. by eauto.
Qed.

Theorem free_list_env_freeable:
  forall (ge:Csem.genv) m1 m2 e  f k id,
    free_list m1 (blocks_of_env ge e) = Some m2 ->
    econt_envs_distinct_blocks e k ->
    forall_envs_in_econt (fun _ _ => env_freeable ge m1 ) f id k ->
    forall_envs_in_econt (fun _ _ => env_freeable ge m2 ) f id k .
Proof.
  unfold blocks_of_env, block_of_binding.
  intros ge m1 m2 e f k id H0 H1 H2.
  eapply cont_envs_distinct_blocks_equiv in H1.
  unfold econt_envs_distinct_blocks' in *.

  generalize dependent m1.
  generalize dependent m2.
  generalize dependent id.
  move: (elements_complete e).
  elim: (elements e).
  - by inversion 2.
  - simpl. move => [a1 [a2 a3]] l IH Hcomplete id m2 m1 H0 H2.
    repeat option_cases. inv Heq.
    eapply free_env_freeable in H2.
    + eapply IH; eauto.
    + eapply Hcomplete; eauto.
    + assumption.
    + by eapply cont_envs_distinct_blocks_equiv.
Qed.

Theorem free_of_different_env:
  forall (ge:Csem.genv) e ev m1 m2,
    envs_distinct_blocks e ev ->
    free_list m1 (blocks_of_env ge e) = Some m2 ->
    env_freeable ge m1 ev ->
    env_freeable ge m2 ev.
Proof.
  unfold blocks_of_env.
  move => ge e ev m1 m2 Hdistinct Hlist Hfreeable.
  apply env_freeable_equiv.
  apply env_freeable_equiv in Hfreeable.
  eapply distinct_blocks_equiv in Hdistinct.
  unfold env_freeable', envs_distinct_blocks' in *.
  generalize dependent m1.
  generalize dependent m2.
  generalize dependent ev.
  induction (elements e).
  - by inversion 2.
  - simpl.
    move => ev Hdistinct m2 m1 Hlist Hfreeable i b t0 H.
    simpl in *.
    repeat option_cases.
    subst. destruct a as (a1& a2& a3). inv Heq.
    eapply IHl; eauto.
    move => i0 b1 t2 Hinside2 ofs Hofs.
    eapply perm_free_1; eauto.
    + left; apply not_eq_sym. by eauto.
    + eapply Hfreeable; eauto.
Qed.

(** * Low-level [free] properties *)

(** CompCert does not expose the internals of [free] and it also does not
define enough properties to reason about allocations on the low level. These two
lemmas provide information about how the allocated memory is constructed.
 *)

Theorem free_mem_contents:
  forall m b lo hi m',
    free m b lo hi = Some m' ->
    mem_contents m = mem_contents m'.
Proof.
  intros m b lo hi m' H.

  change free with (fun (m: mem) (b: Values.block) (lo hi: Z) =>
                      if range_perm_dec m b lo hi Cur Freeable is left _
                      then Some(unchecked_free m b lo hi)
                      else None) in *.
  simpl in *.
  destruct (range_perm_dec _ _ _ _ _ _); [|discriminate].
  inv H.
  reflexivity.
Qed.


From stdpp Require Import coPset namespaces.
From iris.proofmode Require Import tactics.
Set Default Proof Using "Type".

Section accessor.
(* Just playing around a bit with a telescope version
   of accessors with just one binder list. *)
Definition accessor `{!BiFUpd PROP} {X : tele} (E1 E2 : coPset)
           (α β γ : X → PROP) : PROP :=
  (|={E1,E2}=> ∃.. x, α x ∗ (β x -∗ |={E2,E1}=> (γ x)))%I.

Notation "'ACC' @ E1 , E2 {{ ∃ x1 .. xn , α | β | γ } }" :=
  (accessor (X:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. ))
            E1 E2
            (tele_app (TT:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. )) $
                      fun x1 => .. (fun xn => α%I) ..)
            (tele_app (TT:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. )) $
                      fun x1 => .. (fun xn => β%I) ..)
            (tele_app (TT:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. )) $
                      fun x1 => .. (fun xn => γ%I) ..))
  (at level 20, α, β, γ at level 200, x1 binder, xn binder, only parsing).

(* Working with abstract telescopes. *)
Section tests.
Context `{!BiFUpd PROP} {X : tele}.
Implicit Types α β γ : X → PROP.

Lemma acc_mono E1 E2 α β γ1 γ2 :
  (∀.. x, γ1 x -∗ γ2 x) -∗
  accessor E1 E2 α β γ1 -∗ accessor E1 E2 α β γ2.
Proof.
  iIntros "Hγ12 >Hacc". iDestruct "Hacc" as (x') "[Hα Hclose]". Show.
  iModIntro. iExists x'. iFrame. iIntros "Hβ".
  iMod ("Hclose" with "Hβ") as "Hγ". iApply "Hγ12". auto.
Qed.
End tests.

Section printing_tests.
Context `{!BiFUpd PROP}.

(* Working with concrete telescopes: Testing the reduction into normal quantifiers. *)
Lemma acc_elim_test_1 E1 E2 :
  ACC @ E1, E2 {{ ∃ a b : nat, <affine> ⌜a = b⌝ | True | <affine> ⌜a ≠ b⌝ }}
    ⊢@{PROP} |={E1}=> False.
Proof.
  iIntros ">H". Show.
  iDestruct "H" as (a b) "[% Hclose]". iMod ("Hclose" with "[//]") as "%".
  done.
Qed.
End printing_tests.
End accessor.

(* Robbert's tests *)
Section telescopes_and_tactics.

Definition test1 {PROP : sbi} {X : tele} (α : X → PROP) : PROP :=
  (∃.. x, α x)%I.

Notation "'TEST1' {{ ∃ x1 .. xn , α } }" :=
  (test1 (X:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. ))
            (tele_app (TT:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. )) $
                      fun x1 => .. (fun xn => α%I) ..))
  (at level 20, α at level 200, x1 binder, xn binder, only parsing).

Definition test2 {PROP : sbi} {X : tele} (α : X → PROP) : PROP :=
  (▷ ∃.. x, α x)%I.

Notation "'TEST2' {{ ∃ x1 .. xn , α } }" :=
  (test2 (X:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. ))
            (tele_app (TT:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. )) $
                      fun x1 => .. (fun xn => α%I) ..))
  (at level 20, α at level 200, x1 binder, xn binder, only parsing).

Definition test3 {PROP : sbi} {X : tele} (α : X → PROP) : PROP :=
  (◇ ∃.. x, α x)%I.

Notation "'TEST3' {{ ∃ x1 .. xn , α } }" :=
  (test3 (X:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. ))
            (tele_app (TT:=TeleS (fun x1 => .. (TeleS (fun xn => TeleO)) .. )) $
                      fun x1 => .. (fun xn => α%I) ..))
  (at level 20, α at level 200, x1 binder, xn binder, only parsing).

Check "test1_test".
Lemma test1_test {PROP : sbi}  :
  TEST1 {{ ∃ a b : nat, <affine> ⌜a = b⌝ }} ⊢@{PROP} ▷ False.
Proof.
  iIntros "H". iDestruct "H" as (x) "H". Show.
Restart.
  iIntros "H". unfold test1. iDestruct "H" as (x) "H". Show.
Abort.

Check "test2_test".
Lemma test2_test {PROP : sbi}  :
  TEST2 {{ ∃ a b : nat, <affine> ⌜a = b⌝ }} ⊢@{PROP} ▷ False.
Proof.
  iIntros "H". iModIntro. Show.
  iDestruct "H" as (x) "H". Show.
Restart.
  iIntros "H". iDestruct "H" as (x) "H". Show.
Abort.

Check "test3_test".
Lemma test3_test {PROP : sbi}  :
  TEST3 {{ ∃ a b : nat, <affine> ⌜a = b⌝ }} ⊢@{PROP} ▷ False.
Proof.
  iIntros "H". iMod "H".
  iDestruct "H" as (x) "H".
  Show.
Restart.
  iIntros "H". iDestruct "H" as (x) "H". Show.
Abort.

End telescopes_and_tactics.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Event.

Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.

Set Implicit Arguments.

Variant covered (loc:Loc.t) (ts:Time.t) (mem:Memory.t): Prop :=
| covered_intro
    from to msg
    (GET: Memory.get loc to mem = Some (from, msg))
    (ITV: Interval.mem (from, to) ts)
.

Lemma covered_disjoint
      mem1 mem2 loc from to
      (COVER: forall loc ts, covered loc ts mem1 -> covered loc ts mem2)
      (DISJOINT: forall to2 from2 msg2
                   (GET2: Memory.get loc to2 mem2 = Some (from2, msg2)),
          Interval.disjoint (from, to) (from2, to2)):
  forall to2 from2 msg2
    (GET2: Memory.get loc to2 mem1 = Some (from2, msg2)),
    Interval.disjoint (from, to) (from2, to2).
Proof.
  ii. exploit COVER; eauto.
  { econs; eauto. }
  intros x0. inv x0. eapply DISJOINT; eauto.
Qed.

Lemma get_disjoint_covered_disjoint
      mem loc from to:
  (forall t f m, Memory.get loc t mem = Some (f, m) -> Interval.disjoint (from, to) (f, t)) ->
  (forall ts, covered loc ts mem -> ~ Interval.mem (from, to) ts).
Proof.
  ii. inv H0. eapply H; eauto.
Qed.

Lemma covered_disjoint_get_disjoint
      mem loc from to:
  (forall ts, covered loc ts mem -> ~ Interval.mem (from, to) ts) ->
  (forall t f m, Memory.get loc t mem = Some (f, m) -> Interval.disjoint (from, to) (f, t)).
Proof.
  ii. eapply H; eauto. econs; eauto.
Qed.

Lemma add_covered
      mem2 mem1 loc from to msg
      l t
      (ADD: Memory.add mem1 loc from to msg mem2):
  covered l t mem2 <->
  covered l t mem1 \/ (l = loc /\ Interval.mem (from, to) t).
Proof.
  econs; i.
  - inv H. revert GET. erewrite Memory.add_o; eauto. condtac; ss.
    + des. subst. i. inv GET. auto.
    + left. econs; eauto.
  - des.
    + inv H. econs; eauto.
      erewrite Memory.add_o; eauto. condtac; ss; eauto.
      des. subst. exploit Memory.add_get0; eauto. i. des. congr.
    + subst. econs; eauto. erewrite Memory.add_o; eauto. condtac; ss.
      des; congr.
Qed.

Lemma remove_covered
      mem2 mem1 loc from to msg
      l t
      (REMOVE: Memory.remove mem1 loc from to msg mem2):
  covered l t mem2 <->
  covered l t mem1 /\ (l <> loc \/ ~ Interval.mem (from, to) t).
Proof.
  split; i.
  - inv H. revert GET. erewrite Memory.remove_o; eauto.
    condtac; ss; eauto. i.
    split; try by (econs; eauto).
    destruct (Loc.eq_dec l loc); auto. subst.
    des; ss. right. ii.
    exploit Memory.remove_get0; eauto. i. des.
    exploit Memory.get_disjoint; [exact GET|exact GET0|]. i. des; ss.
    eapply x0; eauto.
  - inv H. inv H0. guardH H1.
    exploit Memory.remove_get1; try exact GET; eauto. i. des.
    + subst. inv H1; ss.
    + econs; eauto.
Qed.

Lemma cap_covered
      mem cap
      loc ts
      (CLOSED: Memory.closed mem)
      (CAP: Memory.cap mem cap)
      (ITV: Interval.mem (Time.bot, Time.incr (Memory.max_ts loc mem)) ts):
  covered loc ts cap.
Proof.
  specialize (Memory.max_exists (fun to => Time.le to ts) loc mem). i. des.
  { exfalso. eapply NONE; try apply CLOSED. apply Time.bot_spec. }
  inv SAT; cycle 1.
  { inv H. inv CAP. exploit SOUND; eauto. i.
    econs; eauto. econs; s; try refl.
    exploit Memory.get_ts; try exact GET. i. des; ss.
    subst. inv ITV. timetac.
  }
  specialize (Memory.min_exists (Time.le ts) loc mem). i. des.
  { exploit Memory.max_ts_spec; try apply CLOSED. i. des. clear MAX0.
    hexploit NONE; try exact GET0. i.
    inv CAP. exploit BACK; try exact GET0. i.
    econs; try exact x0.
    inv ITV. ss. econs; ss.
    destruct (TimeFacts.le_lt_dec ts (Memory.max_ts loc mem)); ss.
  }
  destruct (TimeFacts.le_lt_dec ts from_min); cycle 1.
  { inv CAP. exploit SOUND; try exact GET0. i.
    econs; try exact x0. econs; ss.
  }
  inv CAP. exploit MIDDLE.
  { econs; [exact GET|exact GET0|..].
    - eapply TimeFacts.lt_le_lt; try exact H. etrans; eauto.
      exploit Memory.get_ts; try exact GET0. i. des; timetac.
    - i. destruct (Memory.get loc ts0 mem) as [[]|] eqn:GET'; ss.
      destruct (TimeFacts.le_lt_dec ts0 ts).
      + exploit MAX; try exact GET'; ss. i. timetac.
      + exploit MIN; try exact GET'; timetac. i.
        rewrite TS2 in x0.
        exploit Memory.get_ts; try exact GET0. i. des; timetac.
        exploit TimeFacts.lt_le_lt; try exact TS1; try exact TS2. i. timetac.
  }
  { timetac. }
  i. econs; try exact x0. econs; ss.
Qed.


(* Distributed under the terms of the MIT license. *)
From Coq Require Import Morphisms.
From MetaCoq.Template Require Import config utils.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICCases PCUICInduction
     PCUICLiftSubst PCUICUnivSubst PCUICSigmaCalculus PCUICClosed
     PCUICOnFreeVars PCUICTyping PCUICReduction PCUICGlobalEnv PCUICWeakeningEnv
     PCUICEquality.

Require Import ssreflect ssrbool.
From Equations Require Import Equations.

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Lemma type_local_ctx_All_local_env {cf} P Σ Γ Δ s :
  All_local_env (lift_typing P Σ) Γ ->
  type_local_ctx (lift_typing P) Σ Γ Δ s ->
  All_local_env (lift_typing P Σ) (Γ ,,, Δ).
Proof.
  induction Δ; simpl; auto.
  destruct a as [na [b|] ty];
  intros wfΓ wfctx; constructor; intuition auto.
   exists s; auto.
Qed.

Lemma sorts_local_ctx_All_local_env {cf} P Σ Γ Δ s :
  All_local_env (lift_typing P Σ) Γ ->
  sorts_local_ctx (lift_typing P) Σ Γ Δ s ->
  All_local_env (lift_typing P Σ) (Γ ,,, Δ).
Proof.
  induction Δ in s |- *; simpl; eauto.
  destruct a as [na [b|] ty];
  intros wfΓ wfctx; constructor; intuition eauto.
  destruct s => //. destruct wfctx; eauto.
  destruct s => //. destruct wfctx. exists t; auto.
Qed.

Lemma type_local_ctx_Pclosed Σ Γ Δ s :
  type_local_ctx (lift_typing Pclosed) Σ Γ Δ s ->
  Alli (fun i d => closed_decl (#|Γ| + i) d) 0 (List.rev Δ).
Proof.
  induction Δ; simpl; auto; try constructor.
  destruct a as [? [] ?]; intuition auto.
  - apply Alli_app_inv; auto. constructor. simpl.
    rewrite List.rev_length. 2:constructor.
    unfold closed_decl. unfold Pclosed in b0. simpl.
    rewrite app_context_length in b0. now rewrite Nat.add_comm.
  - apply Alli_app_inv; auto. constructor. simpl.
    rewrite List.rev_length. 2:constructor.
    unfold closed_decl. unfold Pclosed in b. simpl.
    rewrite app_context_length in b. rewrite Nat.add_comm.
    now rewrite andb_true_r in b.
Qed.

Lemma sorts_local_ctx_Pclosed Σ Γ Δ s :
  sorts_local_ctx (lift_typing Pclosed) Σ Γ Δ s ->
  Alli (fun i d => closed_decl (#|Γ| + i) d) 0 (List.rev Δ).
Proof.
  induction Δ in s |- *; simpl; auto; try constructor.
  destruct a as [? [] ?]; intuition auto.
  - apply Alli_app_inv; eauto. constructor. simpl.
    rewrite List.rev_length. 2:constructor.
    unfold closed_decl. unfold Pclosed in b0. simpl.
    rewrite app_context_length in b0. now rewrite Nat.add_comm.
  - destruct s as [|u us]; auto. destruct X as [X b].
    apply Alli_app_inv; eauto. constructor. simpl.
    rewrite List.rev_length. 2:constructor.
    unfold closed_decl. unfold Pclosed in b. simpl.
    rewrite app_context_length in b. rewrite Nat.add_comm.
    now rewrite andb_true_r in b.
Qed.

Lemma All_local_env_Pclosed Σ Γ :
  All_local_env ( lift_typing Pclosed Σ) Γ ->
  Alli (fun i d => closed_decl i d) 0 (List.rev Γ).
Proof.
  induction Γ; simpl; auto; try constructor.
  intros all; depelim all; intuition auto.
  - apply Alli_app_inv; auto. constructor. simpl.
    rewrite List.rev_length. 2:constructor.
    unfold closed_decl. unfold Pclosed in l. simpl. red in l.
    destruct l as [s H].
    now rewrite andb_true_r in H.
  - apply Alli_app_inv; auto. constructor. simpl.
    rewrite List.rev_length. 2:constructor.
    now simpl.
Qed.

Lemma weaken_env_prop_closed {cf} :
  weaken_env_prop cumulSpec0 (lift_typing typing) (lift_typing (fun (_ : global_env_ext) (Γ : context) (t T : term) =>
  closedn #|Γ| t && closedn #|Γ| T)).
Proof. repeat red. intros. destruct t; red in X0; eauto. Qed.

Lemma closedn_ctx_alpha {k ctx ctx'} :
  eq_context_upto_names ctx ctx' ->
  closedn_ctx k ctx = closedn_ctx k ctx'.
Proof.
  induction 1 in k |- *; simpl; auto.
  rewrite IHX. f_equal.
  rewrite (All2_length X).
  destruct r; cbn; now subst.
Qed.

Lemma closedn_All_local_env (ctx : list context_decl) :
  All_local_env
    (fun (Γ : context) (b : term) (t : typ_or_sort) =>
      closedn #|Γ| b && typ_or_sort_default (closedn #|Γ|) t true) ctx ->
    closedn_ctx 0 ctx.
Proof.
  induction 1; auto; rewrite closedn_ctx_cons IHX /=; now move/andP: t0 => [].
Qed.

Lemma declared_minductive_closed_inds {cf} {Σ ind mdecl u} {wfΣ : wf Σ} :
  declared_minductive Σ (inductive_mind ind) mdecl ->
  forallb (closedn 0) (inds (inductive_mind ind) u (ind_bodies mdecl)).
Proof.
  intros h.
  red in h.
  eapply lookup_on_global_env in h. 2: eauto.
  destruct h as [Σ' [ext wfΣ' decl']].
  red in decl'. destruct decl' as [h ? ? ?].
  rewrite inds_spec. rewrite forallb_rev.
  unfold mapi.
  generalize 0 at 1. generalize 0. intros n m.
  induction h in n, m |- *.
  - reflexivity.
  - simpl. eauto.
Qed.

Lemma closed_cstr_branch_context_gen {cf : checker_flags} {Σ} {wfΣ : wf Σ} {c mdecl cdecl} :
  closed_inductive_decl mdecl ->
  closed_constructor_body mdecl cdecl ->
  closedn_ctx (context_assumptions mdecl.(ind_params)) (cstr_branch_context c mdecl cdecl).
Proof.
  intros cl clc.
  move/andP: cl => [] clpars _.
  move/andP: clc => [] /andP [] clargs clinds cltype.
  rewrite /cstr_branch_context /=.
  eapply (closedn_ctx_expand_lets 0) => // /=.
  eapply (closedn_ctx_subst 0). len. now rewrite Nat.add_comm.
  eapply closed_inds.
Qed.

Lemma closedn_All_local_closed:
  forall (cf : checker_flags) (Σ : global_env_ext) (Γ : context) (ctx : list context_decl)
         (wfΓ' : wf_local Σ (Γ ,,, ctx)),
    All_local_env_over typing
    (fun (Σ0 : global_env_ext) (Γ0 : context) (_ : wf_local Σ0 Γ0) (t T : term) (_ : Σ0;;; Γ0 |- t : T) =>
       closedn #|Γ0| t && closedn #|Γ0| T) Σ (Γ ,,, ctx) wfΓ' ->
    closedn_ctx 0 Γ && closedn_ctx #|Γ| ctx.
Proof.
  intros cf Σ Γ ctx wfΓ' al.
  remember (Γ ,,, ctx) as Γ'. revert Γ' wfΓ' ctx HeqΓ' al.
  induction Γ. simpl. intros. subst. unfold app_context in *. rewrite app_nil_r in wfΓ' al.
  induction al; try constructor;
  rewrite closedn_ctx_cons /=; cbn.
  move/andP: Hs => [] /= -> _. now rewrite IHal.
  now rewrite IHal /= /test_decl /=.
  intros.
  unfold app_context in *. subst Γ'.
  specialize (IHΓ (ctx ++ a :: Γ) wfΓ' (ctx ++ [a])).
  rewrite -app_assoc in IHΓ. specialize (IHΓ eq_refl al).
  rewrite closedn_ctx_app /= Nat.add_1_r andb_assoc in IHΓ.
  now rewrite closedn_ctx_cons /=.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Compile-time evaluation of initializers for global C variables. *)

Require Import Coqlib.
Require Import Errors.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import AST.
Require Import Memory.
Require Import Globalenvs.
Require Import Ctypes.
Require Import Cop.
Require Import Csyntax.

Open Scope error_monad_scope.

(** * Evaluation of compile-time constant expressions *)

(** To evaluate constant expressions at compile-time, we use the same [value]
  type and the same [sem_*] functions that are used in CompCert C's semantics
  (module [Csem]).  However, we interpret pointer values symbolically:
  [Vptr id ofs] represents the address of global variable [id]
  plus byte offset [ofs]. *)

(** [constval a] evaluates the constant expression [a].

If [a] is a r-value, the returned value denotes:
- [Vint n], [Vfloat f]: the corresponding number
- [Vptr id ofs]: address of global variable [id] plus byte offset [ofs]
- [Vundef]: erroneous expression

If [a] is a l-value, the returned value denotes:
- [Vptr id ofs]: global variable [id] plus byte offset [ofs]
*)

Definition do_cast (v: val) (t1 t2: type) : res val :=
  match sem_cast v t1 t2 with
  | Some v' => OK v'
  | None => Error(msg "undefined cast")
  end.

Fixpoint constval (a: expr) : res val :=
  match a with
  | Eval v ty =>
      match v with
      | Vint _ | Vfloat _ | Vsingle _ | Vlong _ => OK v
      | Vptr _ _ | Vundef => Error(msg "illegal constant")
      end
  | Evalof l ty =>
      match access_mode ty with
      | By_reference | By_copy => constval l
      | _ => Error(msg "dereferencing of an l-value")
      end
  | Eaddrof l ty =>
      constval l
  | Eunop op r1 ty =>
      do v1 <- constval r1;
      match sem_unary_operation op v1 (typeof r1) with
      | Some v => OK v
      | None => Error(msg "undefined unary operation")
      end
  | Ebinop op r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match sem_binary_operation op v1 (typeof r1) v2 (typeof r2) Mem.empty with
      | Some v => OK v
      | None => Error(msg "undefined binary operation")
      end
  | Ecast r ty =>
      do v1 <- constval r; do_cast v1 (typeof r) ty
  | Esizeof ty1 ty =>
      OK (Vint (Int.repr (sizeof ty1)))
  | Ealignof ty1 ty =>
      OK (Vint (Int.repr (alignof ty1)))
  | Eseqand r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match bool_val v1 (typeof r1) with
      | Some true => do_cast v2 (typeof r2) type_bool
      | Some false => OK (Vint Int.zero)
      | None => Error(msg "undefined && operation")
      end
  | Eseqor r1 r2 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      match bool_val v1 (typeof r1) with
      | Some false => do_cast v2 (typeof r2) type_bool
      | Some true => OK (Vint Int.one)
      | None => Error(msg "undefined || operation")
      end
  | Econdition r1 r2 r3 ty =>
      do v1 <- constval r1;
      do v2 <- constval r2;
      do v3 <- constval r3;
      match bool_val v1 (typeof r1) with
      | Some true => do_cast v2 (typeof r2) ty
      | Some false => do_cast v3 (typeof r3) ty
      | None => Error(msg "condition is undefined")
      end
  | Ecomma r1 r2 ty =>
      do v1 <- constval r1; constval r2
  | Evar x ty =>
      OK(Vptr x Int.zero)
  | Ederef r ty =>
      constval r
  | Efield l f ty =>
      match typeof l with
      | Tstruct id fList _ =>
          do delta <- field_offset f fList;
          do v <- constval l;
          OK (Val.add v (Vint (Int.repr delta)))
      | Tunion id fList _ =>
          constval l
      | _ =>
          Error(msg "ill-typed field access")
      end
  | Eparen r tycast ty =>
      do v <- constval r; do_cast v (typeof r) tycast
  | _ =>
    Error(msg "not a compile-time constant")
  end.

(** * Translation of initializers *)

Inductive initializer :=
  | Init_single (a: expr)
  | Init_array (il: initializer_list)
  | Init_struct (il: initializer_list)
  | Init_union (f: ident) (i: initializer)
with initializer_list :=
  | Init_nil
  | Init_cons (i: initializer) (il: initializer_list).

(** Translate an initializing expression [a] for a scalar variable
  of type [ty].  Return the corresponding initialization datum. *)

Definition transl_init_single (ty: type) (a: expr) : res init_data :=
  do v1 <- constval a;
  do v2 <- do_cast v1 (typeof a) ty;
  match v2, ty with
  | Vint n, Tint (I8|IBool) sg _ => OK(Init_int8 n)
  | Vint n, Tint I16 sg _ => OK(Init_int16 n)
  | Vint n, Tint I32 sg _ => OK(Init_int32 n)
  | Vint n, Tpointer _ _ => OK(Init_int32 n)
  | Vint n, Tcomp_ptr _ _ => OK(Init_int32 n)
  | Vlong n, Tlong _ _ => OK(Init_int64 n)
  | Vsingle f, Tfloat F32 _ => OK(Init_float32 f)
  | Vfloat f, Tfloat F64 _ => OK(Init_float64 f)
  | Vptr id ofs, Tint I32 sg _ => OK(Init_addrof id ofs)
  | Vptr id ofs, Tpointer _ _ => OK(Init_addrof id ofs)
  | Vptr id ofs, Tcomp_ptr _ _ => OK(Init_addrof id ofs)
  | Vundef, _ => Error(msg "undefined operation in initializer")
  | _, _ => Error (msg "type mismatch in initializer")
  end.

(** Translate an initializer [i] for a variable of type [ty].
  Return the corresponding list of initialization data. *)

Definition padding (frm to: Z) : list init_data :=
  if zlt frm to then Init_space (to - frm) :: nil else nil.

Fixpoint transl_init (ty: type) (i: initializer)
                     {struct i} : res (list init_data) :=
  match i, ty with
  | Init_single a, _ =>
      do d <- transl_init_single ty a; OK (d :: nil)
  | Init_array il, Tarray tyelt nelt _ =>
      transl_init_array tyelt il (Zmax 0 nelt)
  | Init_struct il, Tstruct id fl _ =>
      transl_init_struct id ty fl il 0
  | Init_union f i1, Tunion id fl _ =>
      do ty1 <- field_type f fl;
      do d <- transl_init ty1 i1;
      OK (d ++ padding (sizeof ty1) (sizeof ty))
  | _, _ =>
      Error (msg "wrong type for compound initializer")
  end

with transl_init_array (ty: type) (il: initializer_list) (sz: Z)
                       {struct il} : res (list init_data) :=
  match il with
  | Init_nil =>
      if zeq sz 0 then OK nil
      else if zle 0 sz then OK (Init_space (sz * sizeof ty) :: nil)
      else Error (msg "wrong number of elements in array initializer")
  | Init_cons i1 il' =>
      do d1 <- transl_init ty i1;
      do d2 <- transl_init_array ty il' (sz - 1);
      OK (d1 ++ d2)
  end

with transl_init_struct (id: ident) (ty: type)
                        (fl: fieldlist) (il: initializer_list) (pos: Z)
                        {struct il} : res (list init_data) :=
  match il, fl with
  | Init_nil, Fnil =>
      OK (padding pos (sizeof ty))
  | Init_cons i1 il', Fcons _ ty1 fl' =>
      let pos1 := align pos (alignof ty1) in
      do d1 <- transl_init ty1 i1;
      do d2 <- transl_init_struct id ty fl' il' (pos1 + sizeof ty1);
      OK (padding pos pos1 ++ d1 ++ d2)
  | _, _ =>
      Error (msg "wrong number of elements in struct initializer")
  end.


(*
 * 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.
 *)
(** Concrete key: pos.  *)

Set Implicit Arguments.

Require Import Pos DLat.

Module DPos <: KEY.
  Include Pos_as_OT.
  Definition eqb x y := if eq_dec x y then true else false.
  Definition zb_eq : zb_equiv eq :=
    {| zb_equiv_refl := eq_refl
     ; zb_equiv_sym := eq_sym
     ; zb_equiv_trans := eq_trans |}.
End DPos.