(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

Require Grammar.
Require Export Alphabet.
From Coq Require Import Orders.
From Coq Require Export List Syntax.

Module Type AutInit.
  (** The grammar of the automaton. **)
  Declare Module Gram:Grammar.T.
  Export Gram.

  (** The set of non initial state is considered as an alphabet. **)
  Parameter noninitstate : Type.
  Global Declare Instance NonInitStateAlph : Alphabet noninitstate.

  Parameter initstate : Type.
  Global Declare Instance InitStateAlph : Alphabet initstate.

  (** When we are at this state, we know that this symbol is the top of the
     stack. **)
  Parameter last_symb_of_non_init_state: noninitstate -> symbol.
End AutInit.

Module Types(Import Init:AutInit).
  (** In many ways, the behaviour of the initial state is different from the
     behaviour of the other states. So we have chosen to explicitaly separate
     them: the user has to provide the type of non initial states. **)
  Inductive state :=
    | Init: initstate -> state
    | Ninit: noninitstate -> state.

  Global Program Instance StateAlph : Alphabet state :=
    { AlphabetComparable := {| compare := fun x y =>
        match x, y return comparison with
          | Init _, Ninit _ => Lt
          | Init x, Init y => compare x y
          | Ninit _, Init _ => Gt
          | Ninit x, Ninit y => compare x y
        end |};
      AlphabetFinite := {| all_list := map Init all_list ++ map Ninit all_list |} }.
  Local Obligation Tactic := intros.
  Next Obligation.
  destruct x, y; intuition; apply compare_antisym.
  Qed.
  Next Obligation.
  destruct x, y, z; intuition.
  apply (compare_trans _ i0); intuition.
  congruence.
  congruence.
  apply (compare_trans _ n0); intuition.
  Qed.
  Next Obligation.
  intros x y.
  destruct x, y; intuition; try discriminate.
  rewrite (compare_eq i i0); intuition.
  rewrite (compare_eq n n0); intuition.
  Qed.
  Next Obligation.
  apply in_or_app; destruct x; intuition;
    [left|right]; apply in_map; apply  all_list_forall.
  Qed.

  Coercion Ninit : noninitstate >-> state.
  Coercion Init : initstate >-> state.

  (** For an LR automaton, there are four kind of actions that can be done at a
     given state:
       - Shifting, that is reading a token and putting it into the stack,
       - Reducing a production, that is popping the right hand side of the
          production from the stack, and pushing the left hand side,
       - Failing
       - Accepting the word (special case of reduction)

     As in the menhir parser generator, we do not want our parser to read after
     the end of stream. That means that once the parser has read a word in the
     grammar language, it should stop without peeking the input stream. So, for
     the automaton to be complete, the grammar must be particular: if a word is
     in its language, then it is not a prefix of an other word of the language
     (otherwise, menhir reports an end of stream conflict).

     As a consequence of that, there is two notions of action: the first one is
     an action performed before having read the stream, the second one is after
  **)

  Inductive lookahead_action (term:terminal) :=
  | Shift_act: forall s:noninitstate,
                 T term = last_symb_of_non_init_state s -> lookahead_action term
  | Reduce_act: production -> lookahead_action term
  | Fail_act: lookahead_action term.
  Arguments Shift_act {term}.
  Arguments Reduce_act {term}.
  Arguments Fail_act {term}.

  Inductive action :=
  | Default_reduce_act: production -> action
  | Lookahead_act : (forall term:terminal, lookahead_action term) -> action.

  (** Types used for the annotations of the automaton. **)

  (** An item is a part of the annotations given to the validator.
     It is acually a set of LR(1) items sharing the same core. It is needed
     to validate completeness. **)
  Record item := {
  (** The pseudo-production of the item. **)
    prod_item: production;

  (** The position of the dot. **)
    dot_pos_item: nat;

  (** The lookahead symbol of the item. We are using a list, so we can store
     together multiple LR(1) items sharing the same core. **)
    lookaheads_item: list terminal
  }.
End Types.

Module Type T.
  Include AutInit <+ Types.
  Module Export GramDefs := Grammar.Defs Gram.

  (** For each initial state, the non terminal it recognizes. **)
  Parameter start_nt: initstate -> nonterminal.

  (** The action table maps a state to either a map terminal -> action. **)
  Parameter action_table:
    state -> action.
  (** The goto table of an LR(1) automaton. **)
  Parameter goto_table: state -> forall nt:nonterminal,
    option { s:noninitstate | NT nt = last_symb_of_non_init_state s }.

  (** Some annotations on the automaton to help the validation. **)

  (** When we are at this state, we know that these symbols are just below
     the top of the stack. The list is ordered such that the head correspond
     to the (almost) top of the stack. **)
  Parameter past_symb_of_non_init_state: noninitstate -> list symbol.

  (** When we are at this state, the (strictly) previous states verify these
     predicates. **)
  Parameter past_state_of_non_init_state: noninitstate -> list (state -> bool).

  (** The items of the state. **)
  Parameter items_of_state: state -> list item.

  (** The nullable predicate for non terminals :
     true if and only if the symbol produces the empty string **)
  Parameter nullable_nterm: nonterminal -> bool.

  (** The first predicates for non terminals, symbols or words of symbols. A
     terminal is in the returned list if, and only if the parameter produces a
     word that begins with the given terminal **)
  Parameter first_nterm: nonterminal -> list terminal.
End T.


(* 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 MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util Sorts SAst SLiftSubst Equality SCommon XTyping
               Conversion 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)
  | 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)
  | 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.

Fact safe_nth_mix :
  forall {Σ} {Γ Γ1 Γ2 Γm : scontext},
    ismix Σ Γ Γ1 Γ2 Γm ->
    forall {n isdecl isdecl1 isdecl2},
      safe_nth Γm (exist _ n isdecl) =
      sPack (llift0 (#|Γm| - S n)
                    (safe_nth Γ1 (exist _ n isdecl1)))
            (rlift0 (#|Γm| - S n)
                    (safe_nth Γ2 (exist _ n isdecl2))).
Proof.
  intros Σ Γ Γ1 Γ2 Γm hm.
  dependent induction hm.
  - cbn. easy.
  - intro n. destruct n ; intros isdecl isdecl1 isdecl2.
    + cbn. replace (#|Γm| - 0) with #|Γm| by mylia. reflexivity.
    + cbn. erewrite IHhm. reflexivity.
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.
  all: try (cbn ; f_equal ; easy).
  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.
  all: try (cbn ; f_equal ; easy).
  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.

Fact safe_nth_mix' :
  forall {Σ} {Γ Γ1 Γ2 Γm : scontext},
    ismix' Σ Γ Γ1 Γ2 Γm ->
    forall {n isdecl isdecl1 isdecl2},
      (safe_nth Γm (exist _ n isdecl)) =
      sPack (llift0 (#|Γm| - S n)
                    (safe_nth Γ1 (exist _ n isdecl1)))
            (rlift0 (#|Γm| - S n)
                    (safe_nth Γ2 (exist _ n isdecl2))).
Proof.
  intros Σ Γ Γ1 Γ2 Γm hm.
  dependent induction hm.
  - cbn. easy.
  - intro n. destruct n ; intros isdecl isdecl1 isdecl2.
    + cbn. replace (#|Γm| - 0) with #|Γm| by mylia. reflexivity.
    + cbn. erewrite IHhm. reflexivity.
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.

Fact safe_nth_llift :
  forall {Δ Γm : scontext} {n is1 is2},
    safe_nth (llift_context #|Γm| Δ) (exist _ n is1) =
    llift #|Γm| (#|Δ| - S n) (safe_nth Δ (exist _ n is2)).
Proof.
  intro Δ. induction Δ.
  - cbn. easy.
  - intro Γm. destruct n ; intros is1 is2.
    + cbn. replace (#|Δ| - 0) with #|Δ| by mylia. reflexivity.
    + cbn. erewrite IHΔ. reflexivity.
Defined.

Fact safe_nth_rlift :
  forall {Δ Γm : scontext} {n is1 is2},
    safe_nth (rlift_context #|Γm| Δ) (exist _ n is1) =
    rlift #|Γm| (#|Δ| - S n) (safe_nth Δ (exist _ n is2)).
Proof.
  intro Δ. induction Δ.
  - cbn. easy.
  - intro Γm. destruct n ; intros is1 is2.
    + cbn. replace (#|Δ| - 0) with #|Δ| by mylia. reflexivity.
    + cbn. erewrite IHΔ. 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.

Fixpoint llift_red1 {n k t1 t2} (h : t1 ▷ t2) :
  llift n k t1 ▷ llift n k t2.
Proof.
  destruct h ; cbn ;
    try match goal with
        | h : ?t ▷ _ |- ?tt ▷ _ =>
          match tt with
          | context [t] =>
            econstructor ;
              eapply llift_red1 ; [ exact h | .. ]
          end
        end.
  - eapply meta_red_eq ; [ econstructor |].
    replace k with (k + 0)%nat by mylia.
    rewrite llift_subst.
    replace (k + 0)%nat with k by mylia.
    replace (S k + 0)%nat with (S k) by mylia.
    reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
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 llift_conv :
  forall {n k t1 t2},
    t1 ≡ t2 ->
    llift n k t1 ≡ llift n k t2.
Proof.
  intros n k t1 t2 h.
  induction h.
  - apply conv_eq. apply nl_llift. assumption.
  - eapply conv_red_l.
    + eapply llift_red1. eassumption.
    + assumption.
  - eapply conv_red_r.
    + eassumption.
    + eapply llift_red1. eassumption.
Defined.

Fixpoint rlift_red1 {n k t1 t2} (h : t1 ▷ t2) :
  rlift n k t1 ▷ rlift n k t2.
Proof.
  destruct h ; cbn ;
    try match goal with
        | h : ?t ▷ _ |- ?tt ▷ _ =>
          match tt with
          | context [t] =>
            econstructor ;
              eapply rlift_red1 ; [ exact h | .. ]
          end
        end.
  - eapply meta_red_eq ; [ econstructor |].
    replace k with (k + 0)%nat by mylia.
    rewrite rlift_subst.
    replace (k + 0)%nat with k by mylia.
    replace (S k + 0)%nat with (S k) by mylia.
    reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
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.

Lemma rlift_conv :
  forall {n k t1 t2},
    t1 ≡ t2 ->
    rlift n k t1 ≡ rlift n k t2.
Proof.
  intros n k t1 t2 h.
  induction h.
  - apply conv_eq. apply nl_rlift. assumption.
  - eapply conv_red_l.
    + eapply rlift_red1. eassumption.
    + assumption.
  - eapply conv_red_r.
    + eassumption.
    + eapply rlift_red1. eassumption.
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.

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.
        + erewrite @safe_nth_lt with (isdecl' := e0).
          eapply meta_conv.
          * eapply type_Rel. eapply wf_llift' ; eassumption.
          * erewrite safe_nth_lt. erewrite safe_nth_llift.
            rewrite lift_llift3 by mylia.
            f_equal. mylia.
        + case_eq (n <? #|Δ| + #|Γm|) ; intro e1 ; bprop e1.
          * erewrite safe_nth_ge'. erewrite safe_nth_lt.
            eapply type_ProjT1' ; try assumption.
            eapply meta_conv.
            -- eapply type_Rel.
               eapply wf_llift' ; eassumption.
            -- erewrite safe_nth_ge'. erewrite safe_nth_lt.
               erewrite safe_nth_mix' by eassumption.
               cbn. f_equal.
               replace (S (n - #|llift_context #|Γm| Δ|))
                 with ((S n) - #|Δ|)
                 by (rewrite llift_context_length ; mylia).
               rewrite lift_llift4 by mylia. f_equal.
               ++ mylia.
               ++ f_equal. eapply safe_nth_cong_irr.
                  rewrite llift_context_length. reflexivity.
          * erewrite safe_nth_ge'. erewrite safe_nth_ge'.
            eapply meta_conv.
            -- eapply type_Rel.
               eapply wf_llift' ; eassumption.
            -- erewrite safe_nth_ge'. erewrite safe_nth_ge'.
               rewrite lift_llift5 by mylia.
               f_equal. eapply safe_nth_cong_irr.
               rewrite llift_context_length. rewrite (mix'_length1 hm). mylia.
      - 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. 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_conv ; try emh.
        eapply llift_conv. assumption.
    }

  (* type_rlift' *)
  - { dependent destruction h ; intros hg hm.
      - unfold rlift at 1.
        case_eq (n <? #|Δ|) ; intro e ; bprop e.
        + erewrite @safe_nth_lt with (isdecl' := e0).
          eapply meta_conv.
          * eapply type_Rel. eapply wf_rlift' ; eassumption.
          * erewrite safe_nth_lt. erewrite safe_nth_rlift.
            rewrite lift_rlift3 by mylia.
            f_equal. mylia.
        + case_eq (n <? #|Δ| + #|Γm|) ; intro e1 ; bprop e1.
          * erewrite safe_nth_ge'. erewrite safe_nth_lt.
            eapply type_ProjT2' ; try assumption.
            eapply meta_conv.
            -- eapply type_Rel.
               eapply wf_rlift' ; eassumption.
            -- erewrite safe_nth_ge'. erewrite safe_nth_lt.
               erewrite safe_nth_mix' by eassumption.
               cbn. f_equal.
               replace (S (n - #|rlift_context #|Γm| Δ|))
                 with ((S n) - #|Δ|)
                 by (rewrite rlift_context_length ; mylia).
               rewrite lift_rlift4 by mylia. f_equal.
               ++ mylia.
               ++ f_equal. eapply safe_nth_cong_irr.
                  rewrite rlift_context_length. reflexivity.
          * erewrite safe_nth_ge'. erewrite safe_nth_ge'.
            eapply meta_conv.
            -- eapply type_Rel.
               eapply wf_rlift' ; eassumption.
            -- erewrite safe_nth_ge'. erewrite safe_nth_ge'.
               rewrite lift_rlift5 by mylia.
               f_equal. eapply safe_nth_cong_irr.
               rewrite rlift_context_length. rewrite (mix'_length2 hm). mylia.
      - 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. 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_conv ; try emh.
        eapply rlift_conv. 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 x is1 is2,
      ∑ s,
        (Σ;;; Γ ,,, Γ1
         |-i lift0 (S x) (safe_nth Γ1 (exist _ x is1)) : sSort s) *
        (Σ;;; Γ ,,, Γ2
         |-i lift0 (S x) (safe_nth Γ2 (exist _ x is2)) : sSort s).
Proof.
  intros Σ Γ Γ1 Γ2 Γm hg hm.
  dependent induction hm.
  - intros x is1. cbn in is1. easy.
  - intro x. destruct x ; intros is1 is2.
    + cbn. exists s. split ; eapply @typing_lift01 with (A := sSort s) ; eassumption.
    + cbn. cbn in is1, is2.
      set (is1' := gt_le_S x #|Γ1| (gt_S_le (S x) #|Γ1| is1)).
      set (is2' := gt_le_S x #|Γ2| (gt_S_le (S x) #|Γ2| is2)).
      destruct (IHhm x is1' is2') as [s' [h1 h2]].
      exists s'. split.
      * replace (S (S x)) with (1 + (S x))%nat by mylia.
        rewrite <- liftP3 with (k := 0) by mylia.
        eapply @typing_lift01 with (A := sSort s') ; eassumption.
      * replace (S (S x)) with (1 + (S x))%nat by mylia.
        rewrite <- liftP3 with (k := 0) by mylia.
        eapply @typing_lift01 with (A := sSort s') ; 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.

End Mix.


(* Following http://adam.chlipala.net/theses/andreser.pdf chapter 3 *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Structures.Orders.
Require Import Coq.Lists.List.
Require Import Crypto.Algebra.Nsatz.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Decidable.Bool2Prop.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.CPSUtil.
Require Import Crypto.Util.CPSNotations.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Modulo.PullPush.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

Reserved Notation "'dlet_list_pair_only_snd' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list_pair_only_snd'  x  :=  v  'in' '//' f").
Reserved Notation "'dlet_list_pair' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list_pair'  x  :=  v  'in' '//' f").
Reserved Notation "'dlet_list' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list'  x  :=  v  'in' '//' f").
Declare Scope runtime_scope.
Delimit Scope runtime_scope with RT.
Import CPSBindNotations.
Local Open Scope cps_scope.

Module Type Runtime.
  Parameter Let_In : forall {A P} (x : A) (f : forall a : A, P a), P x.
  Parameter runtime_nth_default : forall {A}, A -> list A -> nat -> A.
  Parameter runtime_add : Z -> Z -> Z.
  Parameter runtime_sub : Z -> Z -> Z.
  Parameter runtime_mul : Z -> Z -> Z.
  Parameter runtime_div : Z -> Z -> Z.
  Parameter runtime_modulo : Z -> Z -> Z.
  Parameter runtime_opp : Z -> Z.
  Arguments runtime_add (_ _)%RT.
  Arguments runtime_sub (_ _)%RT.
  Arguments runtime_mul (_ _)%RT.
  Arguments runtime_div _%RT _%Z.
  Arguments runtime_modulo _%RT _%Z.
  Arguments runtime_opp _%RT.
  Infix "*" := runtime_mul : runtime_scope.
  Infix "+" := runtime_add : runtime_scope.
  Infix "-" := runtime_sub : runtime_scope.
  Infix "/" := runtime_div : runtime_scope.
  Notation "x 'mod' y" := (runtime_modulo x y) : runtime_scope.
  Notation "- x" := (runtime_opp x) : runtime_scope.
  Notation "'dlet_nd' x .. y := v 'in' f" := (Let_In (P:=fun _ => _) v (fun x => .. (fun y => f) .. )) (only parsing).
  Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).

  Module RT_Z.
    Parameter zselect : Z -> Z -> Z -> Z.
    Parameter add_get_carry_full : Z -> Z -> Z -> Z * Z.
    Parameter add_with_get_carry_full : Z -> Z -> Z -> Z -> Z * Z.
    Parameter mul_split : Z -> Z -> Z -> Z * Z.
    Parameter land : Z -> Z -> Z.
  End RT_Z.
End Runtime.

Module RuntimeDefinitions <: Runtime.
  Definition Let_In := @LetIn.Let_In.
  Definition runtime_nth_default := List.nth_default.
  Definition runtime_add := Z.add.
  Definition runtime_sub := Z.sub.
  Definition runtime_mul := Z.mul.
  Definition runtime_opp := Z.opp.
  Definition runtime_div := Z.div.
  Definition runtime_modulo := Z.modulo.
  Module RT_Z.
    Definition zselect := Z.zselect.
    Definition add_get_carry_full := Z.add_get_carry_full.
    Definition add_with_get_carry_full := Z.add_with_get_carry_full.
    Definition mul_split := Z.mul_split.
    Definition land := Z.land.
  End RT_Z.
End RuntimeDefinitions.

Module RuntimeAxioms : Runtime.
  Include RuntimeDefinitions.
End RuntimeAxioms.

Module Export RuntimeDefinitionsCbv.
  Import RuntimeDefinitions.
  Declare Reduction cbv_no_rt
    := cbv -[Let_In
               runtime_nth_default
               runtime_add
               runtime_sub
               runtime_mul
               runtime_opp
               runtime_div
               runtime_modulo
               RT_Z.add_get_carry_full
               RT_Z.add_with_get_carry_full
               RT_Z.mul_split].
  Declare Reduction lazy_no_rt
    := lazy -[Let_In
                runtime_nth_default
                runtime_add
                runtime_sub
                runtime_mul
                runtime_opp
                runtime_div
                runtime_modulo
                RT_Z.add_get_carry_full
                RT_Z.add_with_get_carry_full
                RT_Z.mul_split].
  Declare Reduction pattern_rt
    := pattern Let_In,
       runtime_nth_default,
       runtime_add,
       runtime_sub,
       runtime_mul,
       runtime_opp,
       runtime_div,
       runtime_modulo,
       RT_Z.add_get_carry_full,
       RT_Z.add_with_get_carry_full,
       RT_Z.mul_split.

  Import RuntimeAxioms.
  Declare Reduction pattern_ax_rt
    := pattern (@Let_In),
       (@runtime_nth_default),
       runtime_add,
       runtime_sub,
       runtime_mul,
       runtime_opp,
       runtime_div,
       runtime_modulo,
       RT_Z.add_get_carry_full,
       RT_Z.add_with_get_carry_full,
       RT_Z.mul_split.
End RuntimeDefinitionsCbv.

Module RT_Extra (Import RT : Runtime).
  Fixpoint dlet_nd_list_pair {A B} (ls : list (A * B)) {T} (f : list (A * B) -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x1 := fst x in dlet_nd x2 := snd x in @dlet_nd_list_pair A B xs T (fun xs => f ((x1, x2) :: xs))
       end.

  Fixpoint dlet_nd_list {A} (ls : list A) {T} (f : list A -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x := x in @dlet_nd_list A xs T (fun xs => f (x :: xs))
       end.

  Fixpoint dlet_nd_list_pair_only_snd {A B} (ls : list (A * B)) {T} (f : list (A * B) -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x2 := snd x in @dlet_nd_list_pair_only_snd A B xs T (fun xs => f ((fst x, x2) :: xs))
       end.

  Notation "'dlet_list_pair_only_snd' x := v 'in' f" := (dlet_nd_list_pair_only_snd v (fun x => f)).
  Notation "'dlet_list_pair' x := v 'in' f" := (dlet_nd_list_pair v (fun x => f)).
  Notation "'dlet_list' x := v 'in' f" := (dlet_nd_list v (fun x => f)).

  Definition expand_list_helper {A} (default : A) (ls : list A) (n : nat) (idx : nat) : list A
  := nat_rect
       (fun _ => nat -> list A)
       (fun _ => nil)
       (fun n' rec_call idx
        => cons (runtime_nth_default default ls idx) (rec_call (S idx)))
       n
       idx.
  Definition expand_list {A} (default : A) (ls : list A) (n : nat) : list A
    := expand_list_helper default ls n 0.
End RT_Extra.

Module Associational (Import RT : Runtime).
  Module Import Deps.
    Module Export RT_Extra := RT_Extra RT.
  End Deps.
  Definition eval (p:list (Z*Z)) : Z :=
    fold_right (fun x y => x + y) 0%Z (map (fun t => fst t * snd t) p).

  Definition mul (p q:list (Z*Z)) : list (Z*Z) :=
    flat_map (fun t =>
      map (fun t' =>
        (fst t * fst t', (snd t * snd t')%RT))
    q) p.

  Definition square_cps (p:list (Z*Z)) : ~> list (Z*Z) :=
    list_rect
      _
      (return nil)
      (fun t ts acc T k
       => (dlet two_t2 := (2 * snd t)%RT in
               acc
                 _
                 (fun acc
                  => k (((fst t * fst t, (snd t * snd t)%RT)
                           :: (map (fun t'
                                    => (fst t * fst t', (two_t2 * snd t')%RT))
                                   ts))
                          ++ acc))))
      p.

  Definition negate_snd (p:list (Z*Z)) : list (Z*Z) :=
    map (fun cx => (fst cx, (-snd cx)%RT)) p.

  Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => fst t mod s =? 0) p in
       (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)).

  Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) :=
    let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi).

  (* reduce at most [n] times, stopping early if the high list is nil at any point *)
  Definition repeat_reduce (n : nat) (s:Z) (c:list _) (p:list _) : list (Z * Z)
    := nat_rect
         _
         (fun p => p)
         (fun n' repeat_reduce_n' p
          => let lo_hi := split s p in
             if (length (snd lo_hi) =? 0)%nat
             then p
             else let p := fst lo_hi ++ mul c (snd lo_hi) in
                  repeat_reduce_n' p)
         n
         p.

  (* rough template (we actually have to do things a bit differently to account for duplicate weights):
[ dlet fi_c := c * fi in
   let (fj_high, fj_low) := split fj at s/fi.weight in
   dlet fi_2 := 2 * fi in
    dlet fi_2_c := 2 * fi_c in
    (if fi.weight^2 >= s then fi_c * fi else fi * fi)
       ++ fi_2_c * fj_high
       ++ fi_2 * fj_low
 | fi <- f , fj := (f weight less than i) ]
   *)
  (** N.B. We take advantage of dead code elimination to allow us to
      let-bind partial products that we don't end up using *)
  (** [v] -> [(v, v*c, v*c*2, v*2)] *)
  Definition let_bind_for_reduce_square_cps (c:list (Z*Z)) (p:list (Z*Z)) : ~> list ((Z*Z) * list(Z*Z) * list(Z*Z) * list(Z*Z)) :=
    fun T
    => let two := [(1,2)] (* (weight, value) *) in
       map_cps2 (fun t T k => dlet_list_pair_only_snd c_t := mul [t] c in dlet_list_pair_only_snd two_c_t := mul c_t two in dlet_list_pair_only_snd two_t := mul [t] two in k (t, c_t, two_c_t, two_t)) p.
  Definition reduce_square_cps (s:Z) (c:list (Z*Z)) (p:list (Z*Z)) : ~>list (Z*Z) :=
    (p <- let_bind_for_reduce_square_cps c p;
    let div_s := map (fun t => (fst t / s, snd t)) in
    return (list_rect
      _
      nil
      (fun t ts acc
       => (let '(t, c_t, two_c_t, two_t) := t in
           (if ((fst t * fst t) mod s =? 0)
            then div_s (mul [t] c_t)
            else mul [t] [t])
             ++ (flat_map
                   (fun '(t', c_t', two_c_t', two_t')
                    => if ((fst t * fst t') mod s =? 0)
                       then div_s
                              (if fst t' <=? fst t
                               then mul [t'] two_c_t
                               else mul [t] two_c_t')
                       else (if fst t' <=? fst t
                             then mul [t'] two_t
                             else mul [t] two_t'))
                   ts))
            ++ acc)
      p)).

  Definition bind_snd_cps (p : list (Z*Z)) : ~>list (Z * Z) :=
    @dlet_nd_list_pair_only_snd _ _ p.

  Section Carries.
    Definition carryterm_cps (w fw:Z) (t:Z * Z) : ~> list (Z * Z) :=
      fun T k
      => if (Z.eqb (fst t) w)
         then dlet_nd t2 := snd t in
              dlet_nd d2 := (t2 / fw)%RT in
              dlet_nd m2 := (t2 mod fw)%RT in
              k [(w * fw, d2);(w,m2)]
         else k [t].

    Definition carry_cps (w fw:Z) (p:list (Z * Z)) : ~> list (Z * Z):=
      fun T => flat_map_cps (carryterm_cps w fw) p.
  End Carries.
End Associational.

Module Positional (Import RT : Runtime).
  Module Import Deps.
    Module Associational := Associational RT.
  End Deps.
  Section Positional.
  Context (weight : nat -> Z).

  Definition to_associational (n:nat) (xs:list Z) : list (Z*Z)
    := combine (map weight (List.seq 0 n)) xs.
  Definition eval n x := Associational.eval (@to_associational n x).
  Definition zeros n : list Z := repeat 0 n.
  Definition add_to_nth i x (ls : list Z) : list Z
    := ListUtil.update_nth i (fun y => (x + y)%RT) ls.

  Definition place (t:Z*Z) (i:nat) : nat * Z :=
    nat_rect
      (fun _ => unit -> (nat * Z)%type)
      (fun _ => (O, if fst t =? 1 then snd t else (fst t * snd t)%RT))
      (fun i' place_i' _
       => let i := S i' in
          if (fst t mod weight i =? 0)
          then (i, let c := fst t / weight i in if c =? 1 then snd t else (c * snd t)%RT)
          else place_i' tt)
      i
      tt.

  Definition from_associational_cps n (p:list (Z*Z)) : ~> list Z :=
    fun T => fold_right_cps2 (fun t ls T k =>
      let '(p1, p2) := place t (pred n) in
      dlet_nd p2 := p2 in
      k (add_to_nth p1 p2 ls)) (zeros n) p.

  Definition extend_to_length (n_in n_out : nat) (p:list Z) : list Z :=
    p ++ zeros (n_out - n_in).

  Definition drop_high_to_length (n : nat) (p:list Z) : list Z :=
    firstn n p.

  Section mulmod.
    Context (s:Z)
            (c:list (Z*Z)).
    Definition mulmod_cps (n:nat) (a b:list Z) : ~> list Z
      := let a_a := to_associational n a in
         let b_a := to_associational n b in
         let ab_a := Associational.mul a_a b_a in
         let abm_a := Associational.repeat_reduce n s c ab_a in
         from_associational_cps n abm_a.

    Definition squaremod_cps (n:nat) (a:list Z) : ~> list Z
      := (let a_a := to_associational n a in
         aa_a <- Associational.reduce_square_cps s c a_a;
         let aam_a := Associational.repeat_reduce (pred n) s c aa_a in
         from_associational_cps n aam_a).
  End mulmod.

  Definition add_cps (n:nat) (a b:list Z) : ~> list Z
    := let a_a := to_associational n a in
       let b_a := to_associational n b in
       from_associational_cps n (a_a ++ b_a).

  Section Carries.
    Definition carry_cps n m (index:nat) (p:list Z) : ~> list Z :=
      (p <- @Associational.carry_cps (weight index)
         (weight (S index) / weight index)
         (to_associational n p);
       from_associational_cps
           m p).

    Definition carry_reduce_cps n (s:Z) (c:list (Z * Z))
               (index:nat) (p : list Z) : ~> list Z :=
      (p <- @carry_cps n (S n) index p;
         p <- from_associational_cps
           n (Associational.reduce
                s c (to_associational (S n) p));
       return p).

    (* N.B. It is important to reverse [idxs] here, because fold_right is
      written such that the first terms in the list are actually used
      last in the computation. For example, running:

      `Eval cbv - [Z.add] in (fun a b c d => fold_right Z.add d [a;b;c]).`

      will produce [fun a b c d => (a + (b + (c + d)))].*)
    Definition chained_carries_cps n s c p (idxs : list nat) : ~> _ :=
      fun T => fold_right_cps2 (fun a b => carry_reduce_cps n s c a b) p (rev idxs).

    (* carries without modular reduction; useful for converting between bases *)
    Definition chained_carries_no_reduce_cps n p (idxs : list nat) : ~> _ :=
      fun T => fold_right_cps2 (fun a b => carry_cps n n a b) p (rev idxs).

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying. *)
    Definition encode_cps n s c (x : Z) : ~> list Z :=
      (p <- from_associational_cps n [(1,x)]; chained_carries_cps n s c p (seq 0 n)).

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying, but without reduction. *)
    Definition encode_no_reduce_cps n (x : Z) : ~> list Z :=
      (p <- from_associational_cps n [(1,x)]; chained_carries_no_reduce_cps n p (seq 0 n)).
  End Carries.

  Section sub.
    Context (n:nat)
            (s:Z)
            (c:list (Z * Z))
            (coef:Z).

    Definition negate_snd_cps (a:list Z) : ~> list Z
      := let A := to_associational n a in
         let negA := Associational.negate_snd A in
         from_associational_cps n negA.

    Definition scmul_cps (x:Z) (a:list Z) : ~> list Z
      := let A := to_associational n a in
         let R := Associational.mul A [(1, x)] in
         from_associational_cps n R.

    Definition balance_cps : ~> list Z
      := (sc <- encode_cps n s c (s - Associational.eval c); v <- scmul_cps coef sc; return v).

    Definition sub_cps (a b:list Z) : ~> list Z
      := (balance <- balance_cps;
            ca <- add_cps n balance a;
            _b <- negate_snd_cps b;
            camb <- add_cps n ca _b;
            return camb).

    Definition opp_cps (a:list Z) : ~> list Z
      := sub_cps (zeros n) a.
  End sub.

  Section select.
    Definition zselect_cps (mask cond:Z) (p:list Z) : ~> _ :=
      fun T k => dlet t := RT_Z.zselect cond 0 mask in k (List.map (RT_Z.land t) p).

    Definition select (cond:Z) (if_zero if_nonzero:list Z) :=
      List.map (fun '(p, q) => RT_Z.zselect cond p q) (List.combine if_zero if_nonzero).
  End select.
End Positional.
End Positional.


From stdpp Require Import fin_maps gmap.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import saved_prop gen_heap.
From aneris.prelude Require Import collect.
From aneris.lib Require Import gen_heap_light.
From aneris.aneris_lang Require Export aneris_lang network resources.

From RecordUpdate Require Import RecordSet.
Set Default Proof Using "Type".

Import uPred.
Import RecordSetNotations.

Definition messages_history := prod message_soup message_soup.

Definition messages_history_map := gmap socket_address messages_history.

Implicit Types mh : messages_history_map.
Implicit Types rt : messages_history.

(* The set of all received messages *)
Definition messages_received mh := collect (λ _ rt, rt.1) mh.

Lemma elem_of_messages_received mh :
  ∀ m, m ∈ messages_received mh ↔
         ∃ sa rt, mh !! sa = Some rt ∧ m ∈ rt.1.
Proof. by apply elem_of_collect; eauto. Qed.

(* The set of all transmitted messages *)
Definition messages_sent mh := collect (λ _ rt, rt.2) mh.

Lemma elem_of_messages_sent mh :
  ∀ m, m ∈ messages_sent mh ↔
         ∃ sa rt, mh !! sa = Some rt ∧ m ∈ rt.2.
Proof. by apply elem_of_collect; eauto. Qed.

(** Definitions for the message history *)
Definition messages_received_sent mh : messages_history :=
  (messages_received mh, messages_sent mh).

(* [m] has been received *)
Definition message_received m mh := m ∈ (messages_received mh).

Lemma gset_to_gmap_singleton (v: message_soup * message_soup)
      (a : socket_address) : gset_to_gmap v {[ a ]} = {[a := v]}.
Proof.
  assert ({[a]} = {[a]} ∪ (∅: gset socket_address)) as -> by by set_solver.
    by rewrite (gset_to_gmap_union_singleton v a ∅) gset_to_gmap_empty.
Qed.

Lemma messages_received_init B :
  messages_received (gset_to_gmap (∅, ∅) B) = ∅.
Proof.
  rewrite /messages_received.
  apply collect_empty_f.
  intros ? [].
  rewrite lookup_gset_to_gmap_Some.
  by intros [? [=]].
Qed.

Lemma messages_sent_init B :
  messages_sent (gset_to_gmap (∅, ∅) B) = ∅.
Proof.
  rewrite /messages_sent.
  apply collect_empty_f.
  intros ? [].
  rewrite lookup_gset_to_gmap_Some.
  by intros [? [=]].
Qed.

Lemma messages_received_sent_init B :
  messages_received_sent (gset_to_gmap (∅, ∅) B) = (∅, ∅).
Proof.
  rewrite /messages_received_sent. f_equal.
  - apply messages_received_init.
  - apply messages_sent_init.
Qed.

Lemma messages_sent_insert a R T mh :
  messages_sent (<[a:=(R, T)]> mh) = T ∪ messages_sent (delete a mh).
Proof.
  rewrite /messages_sent.
  apply collect_insert.
Qed.

Lemma message_received_insert a msg R T mh :
  message_received msg (<[a:=(R, T)]> mh) ↔
                   msg ∈ R ∨ message_received msg (delete a mh).
Proof.
  rewrite /message_received /messages_received.
  rewrite collect_insert //= elem_of_union //.
Qed.

 Lemma messages_received_insert  a R T mh :
   messages_received (<[a:=(R, T)]> mh) = R ∪ messages_received (delete a mh).
 Proof.
   rewrite /messages_received.
   apply collect_insert.
 Qed.

Lemma messages_sent_split a R T mh :
  mh !! a = Some (R, T) →
  messages_sent mh =
  T ∪ messages_sent (delete a mh).
Proof.
  intros.
  assert (mh = <[a := (R,T)]>mh) as Heq by by rewrite insert_id.
  rewrite {1} Heq.
  apply collect_insert.
Qed.

(* The messages in the logical map mh, that tracks received and transmitted
   messages, have coherent addresses. *)
Definition messages_addresses_coh mh :=
  ∀ a R T, mh !! a = Some (R, T) →
    (∀ m, m ∈ R → m_destination m = a) ∧ (∀ m, m ∈ T → m_sender m = a).

Definition messages_received_from_sent_coh mh :=
  messages_received mh ⊆ messages_sent mh.

Definition messages_received_from_sent_coh_aux mh :=
  ∀ rt m,
    mh !! (m_destination m) = Some rt →
    m ∈ rt.1 →
    ∃ rt', mh !! (m_sender m) = Some rt' ∧ m ∈ rt'.2.

Lemma messages_received_from_sent_corrolary_coh mh :
  messages_addresses_coh mh →
  messages_received_from_sent_coh mh →
  messages_received_from_sent_coh_aux mh.
Proof.
  intros Hacoh Hrcoh.
  intros rt m Hrt Hm.
  assert (m ∈ messages_received mh) as Hmr.
  { by apply elem_of_collect; eauto. }
  apply Hrcoh, elem_of_collect in Hmr as (sa & rt' & Hrt' & Hmt).
  assert (mh !! sa = Some (rt'.1, rt'.2)) as Hgas by by destruct rt'.
  specialize (Hacoh sa rt'.1  rt'.2 Hgas) as (Hc1 & Hc2).
  specialize (Hc2 m Hmt). set_solver.
Qed.

Lemma messages_sent_dijsoint a R T mh :
  mh !! a = Some (R, T) →
  messages_addresses_coh mh →
  T ## messages_sent (delete a mh).
Proof.
  intros Ha Hmcoh.
  apply elem_of_disjoint.
  intros m HmT Hms.
  apply elem_of_collect in Hms as (a' & (R',T') & Ha' & Ht).
  simplify_map_eq.
  destruct (Hmcoh a R T Ha) as (_ & HT).
  specialize (HT m HmT).
  rewrite -HT in Ha'.
  destruct (decide (a' = (m_sender m))) as [->|Hneq].
  - by rewrite lookup_delete in Ha'.
  - rewrite lookup_delete_ne in Ha'; last done.
    destruct (Hmcoh a' R' T' Ha') as (_ & HT').
    specialize (HT' m Ht).
    done.
Qed.


Require Import FloydSeq.base2.
Require Import FloydSeq.forward.

Inductive FWD : Type :=
| FWD_end: FWD
| FWD_straight0: FWD -> FWD
| FWD_straight1: forall {A: Type}, (A -> FWD) -> FWD
| FWD_intro: forall {A: Type}, (A -> FWD) -> FWD
| FWD_while0: forall (P: environ->mpred), FWD -> FWD -> FWD
| FWD_while1: forall (P: environ->mpred) {A: Type}, (A -> FWD) -> FWD -> FWD.

Ltac go_FWD f :=
  match f with
  | FWD_end => idtac
  | FWD_straight0 ?f' => forward; [ .. | go_FWD f']
  | FWD_straight1 ?f1 =>
         let x := fresh "x" in forward x; [ .. |
         let y := constr:(f1 x) in let y' := (eval cbv beta in y) in
         go_FWD y']
  | FWD_intro ?f1 =>
         let x := fresh "x" in forward_intro x;
         let y := constr:(f1 x) in let y' := (eval cbv beta in y) in
         go_FWD y'
  | FWD_while0 ?P ?Q ?f1 ?f2 =>
          forward_while P (*Q*); [ | | | go_FWD f1 | go_FWD f2]
  | FWD_while1 ?P ?Q ?f1 ?f2 =>
            let x := fresh "x" in forward_while P (*x*);
             [ | |
             |  let y := constr:(f1 x) in let y' := (eval cbv beta in y) in
                 go_FWD y'
             | go_FWD f2]
  end.


Require Import
  ByteString.Lib.Tactics
  ByteString.Lib.Nomega
  ByteString.Lib.FMapExt
  ByteString.Lib.Fiat
  ByteString.Lib.FromADT
  ByteString.Memory
  ByteString.Heap
  Coq.FSets.FMapFacts
  Coq.Structures.DecidableTypeEx.

Module HeapCanonical (M : WSfun Ptr_as_DT).

Module Import Heap := Heap M.

Import HeapState.
Import FMapExt.

Open Scope N_scope.

(** In order to refine to a computable heap, we have to add the notion of
    "free memory", from which addresses may be allocated. A further
    optimization here would be to add a free list, to which free blocks are
    returned, in order avoid gaps in the heap. A yet further optimization
    would be to better manage the free space to avoid fragmentation. The
    implementation below simply grows the heap with every allocation. *)

Theorem HeapCanonical : FullySharpened HeapSpec.
Proof.
  start sharpening ADT.

  eapply transitivityT.
  eapply annotate_ADT with
    (methDefs' := icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|} inil ) ) ) ) ) ) ) ) ) )
    (AbsR := fun or nr =>
       M.Equal (resvs or) (resvs (snd nr)) /\
       M.Equal (bytes or) (bytes (snd nr)) /\
       P.for_all (fun addr sz => plusPtr addr sz <=? fst nr) (resvs (snd nr))).
  simpl; repeat apply Build_prim_prod; simpl;
  intros; try simplify with monad laws; set_evars.

  (* refine constructor emptyS *)
  {
    (*
    instantiate (1 := Build_prim_prod {| consBody := _ |} ());
    simpl; simplify with monad laws; set_refine_evar.
    (* tactic should do all this automatically. *)
    *)

    refine pick val (0%N, newHeapState).
      finish honing.

    intuition; simpl.
    apply for_all_empty; relational; nomega.
  }

  (* refine method allocS. *)
  {
    (*
    instantiate (1 := Build_prim_prod {| methBody := _ |} _); simpl;
    set_refine_evar; simplify with monad laws.
    (* tactic should do all this automatically. *)
   *)

    unfold find_free_block.

    refine pick val (fst r_n).
    {
      simplify with monad laws; simpl.

      refine pick val (plusPtr (A:=Word) (fst r_n) (` d),
                       {| resvs := M.add (fst r_n) (` d) (resvs (snd r_n))
                        ; bytes := bytes (snd r_n) |}).
        simplify with monad laws; simpl.

        finish honing.

      simpl in *; intuition.
      rewrite H2; reflexivity.
      apply for_all_add_true; relational; try nomega.
        rewrite <- H2.
        destruct d.
        eapply allocations_no_overlap_r; eauto.
        rewrite H2.
        eapply for_all_impl; eauto; relational;
        intros; nomega.
      split.
        eapply for_all_impl; eauto; relational;
        intros; nomega.
      nomega.
    }

    repeat breakdown; simpl in *.
    rewrite H0.
    eapply for_all_impl; eauto;
    relational; nomega.
  }
  (* And so on :) ....*)

  (* refine method freeS. *)
  {
    refine pick val (fst r_n,
                     {| resvs := M.remove d (resvs (snd r_n))
                      ; bytes := bytes (snd r_n) |}).
    try simplify with monad laws; simpl.
      finish honing.

    simpl in *; intuition.
    - rewrite H2; reflexivity.
    - apply for_all_remove; relational; nomega.
  }

  (* refine method reallocS. *)
  {
    unfold find_free_block.
    refine pick val (Ifopt M.find d (resvs (snd r_n)) as sz
                     Then If ` d0 <=? sz Then d Else fst r_n
                     Else fst r_n).
    {
      simplify with monad laws.

      refine pick val
        (Ifopt M.find d (resvs (snd r_n)) as sz
         Then If ` d0 <=? sz
              Then
                (fst r_n,
                 {| resvs := M.add d (` d0) (resvs (snd r_n)) (* update *)
                  ; bytes := bytes (snd r_n) |})
              Else
                (plusPtr (A:=Word) (fst r_n) (` d0),
                 {| resvs :=
                      M.add (fst r_n) (` d0) (M.remove d (resvs (snd r_n)))
                  ; bytes :=
                      copy_bytes d (fst r_n) sz (bytes (snd r_n))|})
         Else
           (plusPtr (A:=Word) (fst r_n) (` d0),
            {| resvs := M.add (fst r_n) (` d0) (resvs (snd r_n))
             ; bytes := bytes (snd r_n) |})).
        simplify with monad laws.
        simpl.
        finish honing.

      simpl in *; intuition; rewrite ?H2;
      (destruct (M.find d _) as [sz|] eqn:Heqe;
       [ destruct (` d0 <=? sz) eqn:Heqe1;
         simpl; rewrite ?Heqe1 |]); simpl.
      - rewrite remove_add; reflexivity.
      - reflexivity.
      - apply F.add_m; auto.
        apply F.Equal_mapsto_iff; split; intros.
          simplify_maps.
        simplify_maps; intuition.
        subst.
        apply F.find_mapsto_iff in H1.
        congruence.
      - rewrite copy_bytes_idem; assumption.
      - rewrite N.min_l.
          rewrite H0; reflexivity.
        nomega.
      - assumption.
      - normalize.
        apply_for_all; relational.
        rewrite <- remove_add.
        apply for_all_add_true; relational; try nomega.
          simplify_maps.
        split.
          apply for_all_remove; relational; nomega.
        nomega.
      - normalize.
        apply_for_all; relational.
        rewrite <- remove_add.
        apply for_all_add_true; relational; try nomega.
          simplify_maps.
        split.
          apply for_all_remove; relational; try nomega.
          apply for_all_remove; relational; try nomega.
          eapply for_all_impl; eauto;
          relational; nomega.
        nomega.
      - rewrite <- remove_add.
        apply for_all_add_true; relational; try nomega.
          simplify_maps.
        split.
          apply for_all_remove; relational; try nomega.
          eapply for_all_impl; eauto;
          relational; nomega.
        nomega.
    }

    simpl in *; intuition; rewrite ?H1;
    (destruct (M.find d _) as [sz|] eqn:Heqe;
     [ destruct (` d0 <=? sz) eqn:Heqe1;
       simpl; rewrite ?Heqe1 |]); simpl.
    - normalize.
      rewrite <- H2 in Heqe.
      pose proof (allocations_no_overlap H Heqe) as H2'.
      apply P.for_all_iff; relational; intros; try nomega.
      simplify_maps.
      specialize (H2' _ _ H5 H3).
      nomega.
    - normalize.
      apply_for_all; relational.
      apply for_all_remove; relational; try nomega.
      eapply for_all_impl; eauto;
      relational; try nomega.
      rewrite <- H2 in H4.
      auto.
    - apply for_all_remove; relational.
        nomega.
      remember (fun _ _ => _ <=? _) as P.
      remember (fun _ _ => negb _) as P'.
      apply for_all_impl with (P:=P) (P':=P');
      relational; try nomega.
      rewrite H2.
      assumption.
  }

  (* refine method peekS. *)
  {
    refine pick val (Ifopt M.find (plusPtr d d0) (bytes (snd r_n)) as v
                     Then v
                     Else Zero).
      simplify with monad laws.
      refine pick val r_n.
      simplify with monad laws.
      simpl; finish honing.
      simpl in *; intuition.

    clear H.
    simpl in *; intuition.
    destruct (M.find (plusPtr d d0) _) as [sz|] eqn:Heqe;
    simpl; normalize.
      left.
      rewrite H0.
      assumption.
    right.
    split; intuition.
    destruct H1.
    apply F.find_mapsto_iff in H1.
    rewrite H0 in H1.
    congruence.
  }

  (* refine method pokeS. *)
  {
    refine pick val (fst r_n,
                     {| resvs := resvs (snd r_n)
                      ; bytes := M.add (plusPtr d d0) d1 (bytes (snd r_n)) |}).
    simpl.
    finish honing.

    simpl in *; intuition;
    destruct (d <? fst r_n) eqn:Heqe; simpl; trivial;
    rewrite H0; reflexivity.
  }

  (* refine method memcpyS. *)
  {
    refine pick val (fst r_n,
                     {| resvs := resvs (snd r_n)
                      ; bytes := copy_bytes (plusPtr d d0) (plusPtr d1 d2)
                                            d3 (bytes (snd r_n)) |}).
      finish honing.

    simpl in *; intuition;
    rewrite H0; reflexivity.
  }

  (* refine method memsetS. *)
  {
    refine pick val
       (fst r_n,
        {| resvs := resvs (snd r_n)
         ; bytes :=
             P.update
               (bytes (snd r_n))
               (N.peano_rect
                  (fun _ => M.t Word)
                  (bytes (snd r_n))
                  (fun i => M.add (plusPtr(A:=Word) d (d0 + i))%N d2) d1) |}).
      simpl; finish honing.

    simpl in *; intuition.
    apply P.update_m; trivial.
    induction d1 using N.peano_ind; simpl; trivial.
    rewrite !N.peano_rect_succ.
    apply F.add_m; auto.
  }

  (* refine method readS. *)
  {
    refine pick eq.
    simplify with monad laws; simpl.
    refine pick val r_n.
      simplify with monad laws; simpl.
      destruct H0, H2.
      rewrite Npeano_rect_eq
        with (g := fun (i : N) (xs : list Word) =>
          match M.find (plusPtr d (d0 + i)) (bytes (snd r_n)) with
          | Some w => w
          | None => Zero
          end :: xs).
        finish honing.
      intros.
      f_equal.
      rewrite H2.
      reflexivity.

    simpl in *; intuition.
  }

  (* refine method writeS. *)
  {
    refine pick val
       (fst r_n,
        {| resvs := resvs (snd r_n)
         ; bytes := load_into_map (plusPtr d d0) d1 (bytes (snd r_n)) |}).
      finish honing.

    simpl in *; intuition.
    apply load_into_map_Proper; auto.
    reflexivity.
  }

  constructor.
  finish_SharpeningADT_WithoutDelegation.
Defined.

End HeapCanonical.