Require Import CContext.
Require Import String.
Require Import Maps.

Definition struct_table := partial_map (partial_map nat).

(* TODO - must fix **)
Inductive context :=
| space (s: cstack) (st: stack sym_tbl) (h: cheap) (ht: sym_tbl)
        (H: valid_state s st) (s_tbl: struct_table).

Definition smart_lookup ctx var :=
  let '(space s st h ht _ _) := ctx in
  match lookup_s s st var with
  | Some val => Some val
  | None => match lookup_h h ht var with
            | Some val => Some val
            | None => None
            end
  end.

Definition decode_struct ctx s_name s_var :=
  let '(space _ _ _ _ _ s_tbl) := ctx in
  match s_tbl s_name with
  | Some s_map => match s_map s_var with
                  | Some offset =>

(* Internally translate each s_var to a pointer offset**)
Definition query_struct_space (ctx: context) (s_name s_var s_field: string) :=
  smart_lookup ctx (decode_struct ctx s_name s_var).

(* HOW DO I DEAL WITH TYPING DISTINCTIONS HERE? **)

Hint Unfold query_struct_space.


Set Warnings "-notation-overridden,-parsing".
Require Import Tweetnacl_verif.init_tweetnacl.
Require Import Tweetnacl_verif.spec_A.
Require Import Tweetnacl.Libs.Export.
Require Import Tweetnacl.ListsOp.Export.
Require Import Tweetnacl.Low.A.

Open Scope Z.

Definition Gprog : funspecs :=
      ltac:(with_library prog [A_spec]).

Import Low.

Lemma body_A: semax_body Vprog Gprog f_A A_spec.
Proof.
start_function.
unfold nm_overlap_array_sep_3, nm_overlap_array_sep_3' in *.
assert(HA: Zlength (A a b) = 16). rewrite A_Zlength ; omega.
assert(HmA: Zlength (mVI64 (A a b)) = 16). rewrite ?Zlength_map //.
assert(Forall (fun x : ℤ => amin + bmin < x < amax + bmax) (A a b)).  apply A_bound_Zlength_lt ; trivial ; omega.
assert(Htkdp: tkdp 16 (mVI64 (A a b)) o = mVI64 (A a b)). rewrite -HmA tkdp_all ; trivial ; rewrite ?Zlength_map; omega.
assert(Haux1: forall i, 0 <= i < 16 -> exists aux1, Vlong aux1 = Znth i (mVI64 a) Vundef). intros; erewrite (Znth_map Int64.zero) ; [eexists ; reflexivity | rewrite Zlength_map; omega].
assert(Haux2: forall i, 0 <= i < 16 -> exists aux2, Vlong aux2 = Znth i (mVI64 b) Vundef). intros; erewrite (Znth_map Int64.zero) ; [eexists ; reflexivity | rewrite Zlength_map; omega].
assert(Haux3: forall i, 0 <= i < 16 -> exists aux3, Vlong aux3 = Znth i (tkdp i (mVI64 (A a b)) (mVI64 a)) Vundef).
  intros ; rewrite /tkdp -?map_firstn -?map_skipn -?map_app ;
  erewrite (Znth_map Int64.zero);[eexists ; reflexivity | rewrite ?Zlength_map];
  change (firstn (nat_of_Z i) (A a b) ++ skipn (nat_of_Z i) a) with (tkdp i (A a b) a);
  rewrite tkdp_Zlength HA ; omega.
assert(Haux4: forall i, 0 <= i < 16 -> exists aux4, Vlong aux4 = Znth i (tkdp i (mVI64 (A a b)) (mVI64 b)) Vundef).
  intros ; rewrite /tkdp -?map_firstn -?map_skipn -?map_app ;
  erewrite (Znth_map Int64.zero);[eexists ; reflexivity | rewrite ?Zlength_map];
  change (firstn (nat_of_Z i) (A a b) ++ skipn (nat_of_Z i) a) with (tkdp i (A a b) a);
  rewrite tkdp_Zlength HA ; omega.

flatten ; Intros.
1: subst o v_a.
2: subst o v_b.
3: subst b v_b.
4: subst o a v_o v_a.

1: forward_for_simple_bound 16 (A_Inv sho sha shb v_o v_o v_b (mVI64 a) a amin amax b bmin bmax 0);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
2: forward_for_simple_bound 16 (A_Inv sho sha shb v_o v_a v_o (mVI64 b) a amin amax b bmin bmax 1);
[ unfold nm_overlap_array_sep_3' ; entailer! | |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
3: forward_for_simple_bound 16 (A_Inv sho sha shb v_o v_a v_a o a amin amax a amin amax 2);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
4: forward_for_simple_bound 16 (A_Inv sho sha shb v_b v_b v_b (mVI64 b) b bmin bmax b bmin bmax 3);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
5: forward_for_simple_bound 16 (A_Inv sho sha shb v_o v_a v_b o a amin amax b bmin bmax 4);
[ unfold nm_overlap_array_sep_3' ; entailer!| |
  rewrite Htkdp; forward; unfold nm_overlap_array_sep_3' ; entailer!].
all: unfold nm_overlap_array_sep_3' ; simpl ; Intros.
all: specialize Haux1 with i ; destruct (Haux1 H7) as [aux1 HHaux1].
all: specialize Haux2 with i ; destruct (Haux2 H7) as [aux2 HHaux2].
all: specialize Haux3 with i ; destruct (Haux3 H7) as [aux3 HHaux3].
all: specialize Haux4 with i ; destruct (Haux4 H7) as [aux4 HHaux4].
all: forward.
3,4,5,6,9,10: rewrite -HHaux1.
1,2,9,10: rewrite -HHaux3.
1,3,5,7,9: entailer!.
all: forward.
7,8: rewrite -HHaux1.
1,2,9,10: rewrite -HHaux2.
5,6: rewrite -HHaux3.
7,8: rewrite -HHaux4.
1,3,5,7,9: entailer!.
all: forward.
all: entailer!.
all: rewrite map_map in HHaux1.
all: rewrite map_map in HHaux2.
all: rewrite (Znth_map 0) in HHaux1; [ | omega ].
all: rewrite (Znth_map 0) in HHaux2; [ | omega ].
all: rewrite Znth_tkdp in HHaux3 ; [ | omega].
all: rewrite Znth_tkdp in HHaux4 ; [ | omega].
all: rewrite map_map in HHaux4.
all: rewrite map_map in HHaux3.
all: try (rewrite (Znth_map 0) in HHaux3; [ | omega ]).
all: try (rewrite (Znth_map 0) in HHaux4; [ | omega ]).
1,3,5,7,9: inversion HHaux1.
1,2,3,4,5: inversion HHaux2.
1,2,3,4,5: inversion HHaux3.
1,2,3,4,5: inversion HHaux4.
all: try assert(-2^62 < (Znth i a 0) < 2 ^ 62) by (solve_bounds_by_values_ H).
all: try assert(-2^62 < (Znth i b 0) < 2 ^ 62) by (solve_bounds_by_values_ H0).
all: try assert((-2^62) + (-2^62) <= Znth i a 0 + Znth i b 0 <= 2^62 + 2^62) by omega.
all: try assert((-2^62) + (-2^62) <= Znth i a 0 + Znth i a 0 <= 2^62 + 2^62) by omega.
all: try assert((-2^62) + (-2^62) <= Znth i b 0 + Znth i b 0 <= 2^62 + 2^62) by omega.
1,2,3,4,5: rewrite ?Int64.signed_repr ; solve_bounds_by_values.
all: unfold nm_overlap_array_sep_3' ; simpl ; data_atify ; cancel ; replace_cancel.
all: unfold A.
  (* postcond |-- loop invariant *)
all: clean_context_from_VST.
all: rewrite /tkdp -?map_firstn -?map_skipn -?map_app in HHaux3.
all: rewrite /tkdp -?map_firstn -?map_skipn -?map_app in HHaux4.
all: inv HHaux1 ; inv HHaux2 ; inv HHaux3 ; inv HHaux4.
all: rewrite add64_repr /nat_of_Z.
all: rewrite ?Znth_nth; try omega.
all: rewrite <- ZsubList_nth_Zlength ; try omega.
all: rewrite /tkdp ?simple_S_i ; try omega.
all: rewrite /A in HA, HmA.
all: rewrite (upd_Znth_app_step_Zlength _ _ _ Vundef); try omega.
all: f_equal ; rewrite map_map (Znth_map 0) ?Znth_nth ; try reflexivity.
all: omega.
Qed.

Close Scope Z.


From fae_gtlc_mu.refinements.static_gradual Require Export compat_cast.defs.
From fae_gtlc_mu.backtranslation Require Export general_def_lemmas.
From fae_gtlc_mu.cast_calculus Require Export lang.

Section compat_cast_tau_star.
  Context `{!implG Σ,!specG Σ}.
  Local Hint Resolve to_of_val : core.

  Lemma back_cast_ar_tau_star:
    ∀ (A : list (type * type)) (τ τG : type) (pτnG : Ground τ → False) (pτnStar : τ ≠ ⋆) (pτSτG : get_shape τ = Some τG) (pC1 : alternative_consistency A τ τG) (pC2 : alternative_consistency A τG ⋆),
      back_cast_ar pC1 → back_cast_ar pC2 → back_cast_ar (factorUp_Ground A τ τG pτnG pτnStar pτSτG pC1 pC2).
  Proof.
    intros A τ τG pτnG pτnStar pτSτG pC1 pC2 IHpC1 IHpC2.
    rewrite /back_cast_ar /𝓕c /𝓕. fold (𝓕 pC1). fold (𝓕 pC2).
    iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    (* get small lemma about length fs *)
    iDestruct "Hfs" as "[% Hfs']"; iAssert (rel_cast_functions A fs) with "[Hfs']" as "Hfs". iSplit; done. iClear "Hfs'".
    (* step in wp *)
    wp_head. asimpl.
    fold (𝓕c pC1 fs). fold (𝓕c pC2 fs). do 2 rewrite 𝓕c_rewrite.
    (* step in gradual side *)
    iApply (wp_bind (ectx_language.fill $ [stlc_mu.lang.AppRCtx _])).
    iApply (wp_wand with "[-]").
    iMod (step_pure _ ei' K'
                    (Cast v' τ ⋆)
                    (Cast (Cast v' τ τG) τG ⋆) with "[Hv']") as "Hv'"; auto.
    { eapply UpFactorization; auto. }
    (* apply first IH *)
    rewrite -𝓕c_rewrite.
    iApply (IHpC1 ei' (CastCtx τG ⋆ :: K') with "[Hv']"); auto.
    iIntros (w) "blaa".  iDestruct "blaa" as (w') "[Hw' #Hww']".
    simpl.
    rewrite -𝓕c_rewrite.
    (* apply second IH *)
    iApply (IHpC2 ei' K' with "[Hw']"); auto.
  Qed.

End compat_cast_tau_star.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableAux.Spec.
Require Import AbsAccessor.Spec.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsRef3.Spec.
Require Import TableAux.Specs.granule_fill_table.

Local Open Scope Z_scope.

Section Spec.

  Definition create_table (llt_gidx: Z) (idx: Z) (rtt_addr: Z) (rtt_gidx: Z) (rd_gidx: Z) (level: Z) (map_addr: Z) (adt: RData) :=
    let gn_llt := (gs (share adt)) @ llt_gidx in
    let gn_rtt := (gs (share adt)) @ rtt_gidx in
    rely (g_tag (ginfo gn_llt) =? GRANULE_STATE_TABLE);
    rely (gtype gn_llt =? GRANULE_STATE_TABLE);
    rely (gtype gn_rtt =? GRANULE_STATE_DELEGATED);
    rely prop_dec (glock gn_rtt = Some CPU_ID);
    rely (tbl_level (gaux gn_rtt) =? 0);
    let llt_pte := (g_data (gnorm gn_llt)) @ idx in
    rely is_int64 llt_pte;
    if __entry_is_table llt_pte then
      Some (adt {log: EVT CPU_ID (REL llt_gidx gn_llt {glock: Some CPU_ID}) :: log adt}, VZ64 1)
    else
      let ipa_state := PTE_TO_IPA_STATE llt_pte in
      if (ipa_state =? IPA_STATE_VACANT) || (ipa_state =? IPA_STATE_DESTROYED) then
        let pte_val := IPA_STATE_TO_PTE ipa_state in
        match fill_table (Z.to_nat PGTES_PER_TABLE) (g_data (gnorm gn_rtt)) 0 pte_val 0 with
        | (tbl', _, _) =>
          let llt' := (g_data (gnorm gn_llt)) # idx == (Z.lor rtt_addr PGTE_S2_TABLE) in
          let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_TABLE} {g_rd: rd_gidx} {g_refcount: (g_refcount (ginfo (gn_rtt))) + 1}}
                              {gnorm : (gnorm gn_rtt) {g_data : tbl'}} {gaux: mkAuxillaryVars level idx llt_gidx} in
          let gllt' := gn_llt {ginfo : (ginfo gn_llt) {g_refcount : g_refcount (ginfo gn_llt) + 1}}
                             {gnorm: (gnorm gn_llt) {g_data: llt'}} in
          Some (adt {log: EVT CPU_ID (REL llt_gidx gllt' {glock: Some CPU_ID}) :: log adt}
                    {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == grtt') # llt_gidx == gllt'}},
                VZ64 0)
        end
      else
        if ipa_state =? IPA_STATE_ABSENT then
          rely (level =? RTT_PAGE_LEVEL);
          let pa := __entry_to_phys llt_pte 2 in
          let pte_val := Z.lor (IPA_STATE_TO_PTE IPA_STATE_ABSENT) pa in
          match fill_table (Z.to_nat PGTES_PER_TABLE) (g_data (gnorm gn_rtt)) 0 pte_val GRANULE_SIZE with
          | (tbl', _, _) =>
            let llt' := (g_data (gnorm gn_llt)) # idx == (Z.lor rtt_addr PGTE_S2_TABLE) in
            let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_TABLE} {g_rd: rd_gidx}
                                                       {g_refcount: (g_refcount (ginfo (gn_rtt))) + PGTES_PER_TABLE + 1}}
                                {gnorm : (gnorm gn_rtt) {g_data : tbl'}} {gaux: mkAuxillaryVars level idx llt_gidx} in
            let gllt' := gn_llt {gnorm: (gnorm gn_llt) {g_data: llt'}} in
            Some (adt {log: EVT CPU_ID (REL llt_gidx gllt' {glock: Some CPU_ID}) :: log adt}
                      {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == grtt') # llt_gidx == gllt'}},
                  VZ64 0)
          end
        else if ipa_state =? IPA_STATE_PRESENT then
               rely (level =? RTT_PAGE_LEVEL);
               let pa := __entry_to_phys llt_pte 2 in
               let pte_val := Z.lor (Z.lor (IPA_STATE_TO_PTE IPA_STATE_PRESENT) pa) PGTE_S2_PAGE in
               match fill_table (Z.to_nat PGTES_PER_TABLE) (g_data (gnorm gn_rtt)) 0 pte_val GRANULE_SIZE with
               | (tbl', _, _) =>
                 let llt' := (g_data (gnorm gn_llt)) # idx == (Z.lor rtt_addr PGTE_S2_TABLE) in
                 let grtt' := gn_rtt {ginfo: (ginfo gn_rtt) {g_tag: GRANULE_STATE_TABLE} {g_rd: rd_gidx}
                                                             {g_refcount: (g_refcount (ginfo (gn_rtt))) + PGTES_PER_TABLE + 1}}
                                     {gnorm : (gnorm gn_rtt) {g_data : tbl'}} {gaux: mkAuxillaryVars level idx llt_gidx} in
                 let gllt' := gn_llt {gnorm: (gnorm gn_llt) {g_data: llt'}} in
                 let ipa_gidx := __addr_to_gidx map_addr in
                 let tlbs' := fun cpu gidx => if gidx =? ipa_gidx then 0 else tlbs (share adt) cpu gidx in
                 Some (adt {log: EVT CPU_ID (REL llt_gidx gllt' {glock: Some CPU_ID}) :: log adt}
                           {share : (share adt) {gs : ((gs (share adt)) # rtt_gidx == grtt') # llt_gidx == gllt'} {tlbs: tlbs'}},
                       VZ64 0)
               end
             else None.

  Definition smc_rtt_create_spec (rtt_addr: Z64) (rd_addr: Z64) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match rtt_addr, rd_addr, map_addr, level with
    | VZ64 rtt_addr, VZ64 rd_addr, VZ64 map_addr, VZ64 level =>
      rely is_int64 rtt_addr; rely is_int64 rd_addr; rely is_int64 map_addr; rely is_int64 level;
      if (level >=? 1) && (level <=? 3) && __addr_is_level_aligned map_addr 3 then
        let rtt_gidx := __addr_to_gidx rtt_addr in
        let rd_gidx := __addr_to_gidx rd_addr in
        rely GRANULE_ALIGNED rtt_addr; rely GRANULE_ALIGNED rd_addr;
       rely is_gidx rtt_gidx; rely is_gidx rd_gidx;
        when adt == query_oracle adt;
        let gn_rtt := (gs (share adt)) @ rtt_gidx in
        let gn_rd := (gs (share adt)) @ rd_gidx in
        rely prop_dec (glock gn_rtt = None);
        rely prop_dec (glock gn_rd = None);
        rely (g_tag (ginfo gn_rtt) =? GRANULE_STATE_DELEGATED);
        rely (g_tag (ginfo gn_rd) =? GRANULE_STATE_RD);
        rely (gtype gn_rd =? GRANULE_STATE_RD);
        let adt := adt {log: EVT CPU_ID (ACQ rd_gidx) :: EVT CPU_ID (ACQ rtt_gidx) :: log adt} in
        rely prop_dec ((buffer (priv adt)) @ SLOT_RD = None);
        rely prop_dec ((buffer (priv adt)) @ SLOT_TABLE = None);
        rely prop_dec ((buffer (priv adt)) @ SLOT_DELEGATED = None);
        let root_gidx := (g_rtt (gnorm gn_rd)) in
        rely is_gidx root_gidx;
        let idx0 := __addr_to_idx map_addr 0 in
        let idx1 := __addr_to_idx map_addr 1 in
        let idx2 := __addr_to_idx map_addr 2 in
        let idx3 := __addr_to_idx map_addr 3 in
        let ret_idx := (if level =? 1 then idx0 else if level =? 2 then idx1 else if level =? 3 then idx2 else idx3) in
        (* hold root lock *)
        let groot := (gs (share adt)) @ root_gidx in
        rely (tbl_level (gaux groot) =? 0);
        rely prop_dec (glock groot = None);
        if level =? 1 then
          (* walk until root *)
          let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 0) :: log adt} in
          let adt :=  adt {priv: (priv adt) {wi_llt: root_gidx} {wi_index: idx0}} in
          create_table root_gidx idx0 rtt_addr rtt_gidx rd_gidx 1 map_addr adt
        else
          (* walk deeper root *)
          rely (level >? 1);
          rely (g_tag (ginfo groot) =? GRANULE_STATE_TABLE);
          rely (gtype groot =? GRANULE_STATE_TABLE);
          let entry0 := (g_data (gnorm groot)) @ idx0 in
          rely is_int64 entry0;
          let phys0 := __entry_to_phys entry0 3 in
          let lv1_gidx := __addr_to_gidx phys0 in
          rely (__entry_is_table entry0) && (GRANULE_ALIGNED phys0) && (is_gidx lv1_gidx);
          (* level 1 valid, hold level 1 lock *)
          let glv1 := (gs (share adt)) @ lv1_gidx in
          rely prop_dec (glock glv1 = None);
          rely (tbl_level (gaux glv1) =? 1);
          if level =? 2 then
            (* walk until level 1 *)
            let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 1) :: log adt} in
            let adt :=  adt {priv: (priv adt) {wi_llt: lv1_gidx} {wi_index: idx1}} in
            create_table lv1_gidx idx1 rtt_addr rtt_gidx rd_gidx 2 map_addr adt
          else
            (* walk deeper level 1 *)
            rely (level >? 2);
            rely (g_tag (ginfo glv1) =? GRANULE_STATE_TABLE);
            rely (gtype glv1 =? GRANULE_STATE_TABLE);
            let entry1 := (g_data (gnorm glv1)) @ idx1 in
            rely is_int64 entry1;
            let phys1 := __entry_to_phys entry1 3 in
            let lv2_gidx := __addr_to_gidx phys1 in
            rely (__entry_is_table entry1) && (GRANULE_ALIGNED phys1) && (is_gidx lv2_gidx);
            (* level 2 valid, hold level 2 lock *)
            let glv2 := (gs (share adt)) @ lv2_gidx in
            rely (tbl_level (gaux glv2) =? 2);
            rely prop_dec (glock glv2 = None);
            if level =? 3 then
              (* walk until level 2 *)
              let adt := adt {log: EVT CPU_ID (RTT_WALK root_gidx map_addr 2) :: log adt} in
              let adt :=  adt {priv: (priv adt) {wi_llt: lv2_gidx} {wi_index: idx2}} in
              create_table lv2_gidx idx2 rtt_addr rtt_gidx rd_gidx 3 map_addr adt
            else None
      else Some (adt, VZ64 0)
    end.

End Spec.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Relation.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Dynamic.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Equivalence.
Require Import Equivalences.
Require Import DefsEquiv.
Require Import Dots.
Require Import Morphism.

Require Import Defined.
Require Import SumLemmas.
Require Import PageType.

Definition natcase {object} m n p : term object :=
  sumcase m (subst sh1 n) p.

Lemma def_nat : eq Defs.nat nattp.
Proof.
auto.
Qed.

Lemma def_succ :
  forall n,
    equiv (app Defs.succ n) (nsucc n).
Proof.
intros n.
unfold Defs.succ.
rewrite -> equiv_beta.
simpsub.
unfold Defs.inr.
simpsub.
rewrite -> equiv_beta.
simpsub.
apply equiv_refl.
Qed.

Lemma def_zero :
  equiv Defs.zero nzero.
Proof.
unfold Defs.zero.
unfold Defs.inl.
rewrite -> equiv_beta.
simpsub.
apply equiv_refl.
Qed.

Lemma def_natcase :
  forall m n p,
    equiv (app (app (app Defs.natcase m) n) (lam p)) (natcase m n p).
Proof.
intros m n p.
unfold Defs.natcase.
rewrite -> equiv_beta.
simpsub.
rewrite -> equiv_beta.
simpsub.
rewrite -> equiv_beta.
simpsub.
rewrite -> def_sumcase.
rewrite -> equiv_beta.
simpsub.
rewrite -> subst_var0_sh1.
apply equiv_refl.
Qed.

Lemma tr_positive_nattp_body :
  forall G, tr G (deq triv triv (ispositive (sumtype unittp (var 0)))).
Proof.
intros G.
apply (tr_positive_algorithm _ _ nil nil).
  {
  unfold sumtype.
  apply hpositive_sigma.
    {
    replace booltp with (@subst obj (under 0 sh1) booltp) by (simpsub; auto).
    apply hpositive_const.
    }
  replace (var 0) with (@subst obj (under 1 sh1) (var 0)) by (simpsub; auto).
  apply hpositive_bite.
    {
    simpsub.
    replace unittp with (@subst obj (under 1 sh1) unittp) by (simpsub; auto).
    apply hpositive_const.
    }

    {
    simpsub.
    cbn.
    apply hpositive_var.
    }
  }

  {
  intros x H.
  destruct H.
  }

  {
  intros x H.
  destruct H.
  }
Qed.

Lemma tr_nattp_formation :
  forall G, tr G (deqtype nattp nattp).
Proof.
intros G.
unfold nattp.
apply tr_mu_formation; auto using tr_positive_nattp_body.
apply tr_sumtype_formation.
  {
  apply tr_unittp_istype.
  }

  {
  apply tr_hyp_tp.
  apply index_0.
  }
Qed.

Lemma tr_nzero_nattp :
  forall G, tr G (deq nzero nzero nattp).
Proof.
intros G.
unfold nzero, nattp.
eapply tr_subtype_elim.
  {
  apply tr_mu_roll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      apply tr_hyp_tp.
      apply index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }
simpsub.
apply tr_sumtype_intro1.
  {
  apply tr_unittp_intro.
  }

  {
  apply tr_nattp_formation.
  }
Qed.

Lemma tr_nsucc_nattp :
  forall G m n,
    tr G (deq m n nattp)
    -> tr G (deq (nsucc m) (nsucc n) nattp).
Proof.
intros G m n Hmn.
apply (tr_subtype_elim _ (sumtype unittp nattp)).
  {
  replace (@sumtype obj unittp nattp) with (@subst1 obj nattp (sumtype unittp (var 0))) by (simpsub; auto).
  apply tr_mu_roll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      eapply tr_hyp_tp; eauto using index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }

  {
  unfold nsucc.
  apply tr_sumtype_intro2; auto.
  apply tr_unittp_istype.
  }
Qed.

Lemma tr_nattp_formation_univ :
  forall G, tr G (deq nattp nattp (univ nzero)).
Proof.
intros G.
unfold nattp.
apply tr_mu_formation_univ.
  {
  unfold pagetp.
  apply tr_nzero_nattp.
  }

  {
  simpsub.
  apply tr_sumtype_formation_univ.
    {
    apply tr_unittp_formation_univ.
    }

    {
    eapply hypothesis; eauto using index_0.
    }
  }

  {
  apply tr_positive_nattp_body.
  }

  {
  apply tr_positive_nattp_body.
  }
Qed.

Lemma tr_nattp_eta_hyp_triv :
  forall G1 G2 c,
    tr (substctx (dot nzero id) G2 ++ G1)
      (deq triv triv (subst (under (length G2) (dot nzero id)) c))
    -> tr (substctx (dot (nsucc (var 0)) sh1) G2 ++ hyp_tm nattp :: G1)
         (deq triv triv (subst (under (length G2) (dot (nsucc (var 0)) sh1)) c))
    -> tr (G2 ++ hyp_tm nattp :: G1) (deq triv triv c).
Proof.
intros G1 G2 c Hz Hs.
apply (tr_subtype_convert_hyp _ _ _ (sumtype unittp nattp)).
  {
  simpsub.
  apply (weakening _ [_] []).
    {
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  unfold nattp.
  apply tr_mu_unroll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      apply tr_hyp_tp.
      apply index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }

  {
  simpsub.
  apply (weakening _ [_] []).
    {
    simpsub.
    auto.
    }

    {
    cbn [length unlift].
    simpsub.
    auto.
    }
  cbn [length unlift].
  simpsub.
  cbn [List.app].
  unfold nattp.
  replace (sumtype unittp (mu (sumtype unittp (var 0)))) with (@subst1 obj (mu (sumtype unittp (var 0))) (sumtype unittp (var 0))) by (simpsub; auto).
  apply tr_mu_roll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      apply tr_hyp_tp.
      apply index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }
apply tr_sumtype_eta_hyp_triv; auto.
apply tr_unittp_eta_hyp_triv.
rewrite <- substctx_compose.
rewrite -> length_substctx.
rewrite <- subst_compose.
rewrite <- compose_under.
simpsub.
auto.
Qed.

Lemma tr_nsucc_nattp_invert :
  forall G m n,
    tr G (deq (nsucc m) (nsucc n) nattp)
    -> tr G (deq m n nattp).
Proof.
intros G m n Hsucc.
cut (tr G (deq (app (lam (sumcase (var 0) nzero (var 0))) (nsucc m)) (app (lam (sumcase (var 0) nzero (var 0))) (nsucc n)) nattp)).
  {
  intro H.
  rewrite -> !equiv_beta in H.
  simpsubin H.
  unfold nsucc in H.
  rewrite -> !sumcase_right in H.
  simpsubin H.
  exact H.
  }
apply (tr_pi_elim' _ nattp nattp); auto.
apply tr_pi_intro; auto using tr_nattp_formation.
apply tr_equal_elim.
eapply (tr_nattp_eta_hyp_triv _ []).
  {
  cbn [length].
  simpsub.
  cbn [List.app].
  apply tr_equal_intro.
  unfold nzero at 1 3.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_nzero_nattp.
  }

  {
  cbn [length].
  simpsub.
  cbn [List.app].
  apply tr_equal_intro.
  unfold nsucc.
  rewrite -> sumcase_right.
  simpsub.
  eapply hypothesis; eauto using index_0.
  }
Qed.

Lemma nat_case :
  forall G b m c,
    tr G (deq triv triv (subst1 nzero b))
    -> tr (hyp_tm nattp :: G) (deq triv triv (subst (dot (nsucc (var 0)) (sh 1)) b))
    -> tr G (deq m m nattp)
    -> c = subst1 m b
    -> tr G (deq triv triv c).
Proof.
intros G b m c Hzero Hsucc Hm ->.
apply (sum_case _ unittp nattp b m).
  {
  replace (@triv obj) with (@subst obj (under 0 sh1) triv) by (simpsub; auto).
  apply (tr_unittp_eta_hyp _ []).
  simpsub.
  cbn [List.app].
  exact Hzero.
  }

  {
  exact Hsucc.
  }

  {
  apply (tr_subtype_elim _ nattp); auto.
  apply tr_mu_unroll.
    {
    apply tr_sumtype_formation.
      {
      apply tr_unittp_istype.
      }

      {
      eapply tr_hyp_tp; eauto using index_0.
      }
    }

    {
    apply tr_positive_nattp_body.
    }
  }

  {
  reflexivity.
  }
Qed.

Lemma nat_induction :
  forall G b m c,
    tr G (deq triv triv (subst1 nzero b))
    -> tr
         (hyp_tm (pi (var 2) (subst (under 1 (sh 3)) b)) ::
          hyp_tm (subtype (var 1) nattp) ::
          hyp_tm (var 0) ::
          hyp_tp ::
          G)
         (deq triv triv (subst (dot (nsucc (var 2)) (sh 4)) b))
    -> tr G (deq m m nattp)
    -> c = subst1 m b
    -> tr G (deq triv triv c).
Proof.
intros G b m c Hzero Hsucc Hm ->.
apply (tr_mu_ind _ (sumtype unittp (var 0))).
  {
  apply tr_sumtype_formation.
    {
    apply tr_unittp_istype.
    }

    {
    apply tr_hyp_tp.
    apply index_0.
    }
  }

  {
  apply tr_positive_nattp_body.
  }

2:{
  exact Hm.
  }
replace (mu (subst (under 1 (sh 2)) (sumtype unittp (var 0)))) with (@nattp obj) by (simpsub; auto).
apply (tr_sumtype_eta_hyp_triv _ [_; _]).
  {
  cbn [length].
  simpsub.
  cbn [length Nat.add List.app].
  simpsub.
  cbn [Nat.add].
  replace triv with (@subst obj (under 2 sh1) triv) by (simpsub; auto).
  apply (tr_unittp_eta_hyp _ [_; _]).
  cbn [length].
  simpsub.
  cbn [length Nat.add List.app].
  simpsub.
  cbn [Nat.add].
  fold (@nzero obj).
  apply (weakening _ [_; _; _] []).
    {
    cbn [unlift length].
    simpsub.
    auto.
    }

    {
    cbn [unlift length].
    simpsub.
    auto.
    }
  cbn [unlift length].
  simpsub.
  cbn [List.app].
  exact Hzero.
  }

  {
  cbn [length].
  simpsub.
  cbn [length Nat.add List.app].
  simpsub.
  cbn [Nat.add].
  exact Hsucc.
  }
Qed.

Lemma tr_leqtp_type :
  forall G, tr G (deq leqtp leqtp (pi nattp (pi nattp (univ nzero)))).
Proof.
intros G.
eapply tr_pi_of_ext.
  {
  apply tr_nattp_formation.
  }

2:{
  unfold leqtp.
  rewrite -> theta_equiv.
  apply steps_equiv.
  eapply star_step.
    {
    apply step_app2.
    }
  simpsub.
  apply star_refl.
  }
simpsub.
apply tr_equal_elim.
match goal with
| |- tr _ (deq _ _ ?X) => eapply (nat_induction _ (subst (dot (var 0) (sh 2)) X))
end.
3:{
  eapply (hypothesis _ 0); eauto using index_0.
  }

  {
  simpsub.
  apply tr_equal_intro.
  eapply tr_pi_of_ext.
    {
    apply tr_nattp_formation.
    }

  2:{
    unfold leqtp.
    apply steps_equiv.
    eapply star_trans.
      {
      apply (star_map' _ _ (fun z => app z _)); eauto using step_app1.
      cbn [Nat.add].
      apply theta_fix.
      }
    eapply star_trans.
      {
      apply (star_map' _ _ (fun z => app z _)); eauto using step_app1.
      apply star_one.
      apply step_app2.
      }
    simpsub.
    cbn [Nat.add].
    eapply star_step.
      {
      apply step_app2.
      }
    simpsub.
    apply star_refl.
    }
  simpsub.
  rewrite -> unroll_leqtp.
  unfold nzero at 1 2.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_unittp_formation_univ.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply tr_equal_intro.
  eapply tr_pi_of_ext.
    {
    apply tr_nattp_formation.
    }

  2:{
    unfold leqtp.
    apply steps_equiv.
    eapply star_trans.
      {
      apply (star_map' _ _ (fun z => app z _)); eauto using step_app1.
      cbn [Nat.add].
      apply theta_fix.
      }
    eapply star_trans.
      {
      apply (star_map' _ _ (fun z => app z _)); eauto using step_app1.
      apply star_one.
      apply step_app2.
      }
    simpsub.
    cbn [Nat.add].
    eapply star_step.
      {
      apply step_app2.
      }
    simpsub.
    apply star_refl.
    }
  simpsub.
  cbn [Nat.add].
  setoid_rewrite -> unroll_leqtp.
  unfold nsucc.
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  apply tr_equal_elim.
  apply (tr_nattp_eta_hyp_triv _ []).
    {
    cbn [length].
    simpsub.
    cbn [Nat.add length List.app].
    apply tr_equal_intro.
    unfold nzero at 2 3.
    rewrite -> sumcase_left.
    simpsub.
    apply tr_voidtp_formation_univ.
    }

    {
    cbn [length].
    simpsub.
    cbn [Nat.add List.app].
    unfold nsucc.
    rewrite -> sumcase_right.
    simpsub.
    cbn [Nat.add].
    apply tr_equal_intro.
    eapply tr_pi_elim'.
    2:{
      eapply hypothesis; eauto using index_0.
      }

      {
      apply tr_equal_elim.
      apply (tr_equal_eta2 _#4 (app (var 1) (var 3)) (app (var 1) (var 3))).
      eapply tr_pi_elim'.
        {
        eapply hypothesis; eauto using index_0, index_S.
        simpsub.
        cbn [Nat.add].
        eauto.
        }

        {
        eapply hypothesis; eauto using index_0, index_S.
        }

        {
        simpsub.
        eauto.
        }
      }

      {
      simpsub.
      eauto.
      }
    }
  }

  {
  simpsub.
  eauto.
  }
Qed.

Lemma tr_leqtp_formation_univ :
  forall G m m' n n',
    tr G (deq m m' nattp)
    -> tr G (deq n n' nattp)
    -> tr G (deq (app (app leqtp m) n) (app (app leqtp m') n') (univ nzero)).
Proof.
intros G m m' n n' Hm Hn.
eapply tr_pi_elim'.
  {
  eapply tr_pi_elim'.
    {
    apply tr_leqtp_type.
    }

    {
    auto.
    }

    {
    simpsub; eauto.
    }
  }

  {
  auto.
  }

  {
  simpsub; eauto.
  }
Qed.

Lemma tr_leqtp_formation :
  forall G m m' n n',
    tr G (deq m m' nattp)
    -> tr G (deq n n' nattp)
    -> tr G (deqtype (app (app leqtp m) n) (app (app leqtp m') n')).
Proof.
intros G m m' n n' Hm Hn.
apply (tr_formation_weaken _ nzero).
apply tr_leqtp_formation_univ; auto.
Qed.

Lemma tr_leqtp_eta2 :
  forall G m n p q,
    tr G (deq m m nattp)
    -> tr G (deq n n nattp)
    -> tr G (deq p q (app (app leqtp m) n))
    -> tr G (deq triv triv (app (app leqtp m) n)).
Proof.
intros G m n p q Hm Hn Hleqtp.
apply tr_equal_elim.
apply (tr_equal_eta2 _#4
         (app (app (lam (lam triv)) n) p)
         (app (app (lam (lam triv)) n) q)).
apply (tr_pi_elim2' _
         nattp
         (app (app leqtp (subst sh1 m)) (var 0))
         (equal (app (app leqtp (subst (sh 2) m)) (var 1)) triv triv)); auto.
2:{
  simpsub.
  unfold subst1.
  auto.
  }

2:{
  simpsub.
  reflexivity.
  }
apply tr_equal_elim.
apply (nat_induction _
         (equal
            (pi nattp
               (pi (app (app leqtp (var 1)) (var 0))
                  (equal (app (app leqtp (var 2)) (var 1)) triv triv)))
            (lam (lam triv))
            (lam (lam triv)))
         m); auto.
3:{
  simpsub.
  reflexivity.
  }

(* 0 *)
{
simpsub.
cbn [Nat.add].
apply tr_equal_intro.
apply tr_pi_intro.
  {
  apply tr_nattp_formation.
  }
apply tr_pi_intro.
  {
  apply tr_leqtp_formation.
    {
    apply tr_nzero_nattp.
    }

    {
    eapply hypothesis; eauto using index_0.
    }
  }
apply tr_equal_intro.
setoid_rewrite -> unroll_leqtp at 2.
unfold nzero at 2.
rewrite -> sumcase_left.
simpsub.
apply tr_unittp_intro.
}

(* S *)
{
simpsub.
cbn [Nat.add].
apply tr_equal_intro.
apply tr_pi_intro.
  {
  apply tr_nattp_formation.
  }
apply tr_pi_intro.
  {
  apply tr_leqtp_formation.
    {
    apply tr_nsucc_nattp.
    apply (tr_subtype_elim _ (var 4)).
      {
      apply (tr_subtype_eta2 _ _ _ (var 2) (var 2)).
      eapply hypothesis; eauto using index_S, index_0.
      }
    eapply hypothesis; eauto using index_S, index_0.
    }

    {
    eapply hypothesis; eauto using index_0.
    }
  }
apply tr_equal_intro.
setoid_rewrite -> unroll_leqtp at 4.
unfold nsucc at 2.
rewrite -> sumcase_right.
simpsub.
cbn [Nat.add].
apply (tr_nattp_eta_hyp_triv _ [_]).
  {
  cbn [length].
  simpsub.
  cbn [Nat.add List.app].
  unfold subst1.
  apply (tr_voidtp_elim _ (var 0) (var 0)).
  rewrite -> unroll_leqtp.
  unfold nsucc at 1.
  rewrite -> sumcase_right.
  simpsub.
  unfold nzero at 1.
  rewrite -> sumcase_left.
  simpsub.
  eapply hypothesis; eauto using index_0.
  }

  {
  cbn [length].
  simpsub.
  cbn [Nat.add List.app].
  unfold nsucc.
  rewrite -> unroll_leqtp at 1.
  rewrite -> !sumcase_right.
  simpsub.
  cbn [Nat.add].
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  unfold subst1.
  apply tr_equal_elim.
  apply (tr_equal_eta2 _#4
           (app (app (lam (lam triv)) (var 1)) (var 0))
           (app (app (lam (lam triv)) (var 1)) (var 0))).
  apply (tr_pi_elim2' _ nattp (app (app leqtp (var 5)) (var 0))
           (equal (app (app leqtp (var 6)) (var 1)) triv triv)).
    {
    apply tr_equal_elim.
    apply (tr_equal_eta2 _#4
             (app (var 2) (var 4))
             (app (var 2) (var 4))).
    eapply (tr_pi_elim' _ (var 5) _).
      {
      eapply hypothesis; eauto using index_S, index_0.
      simpsub.
      cbn [Nat.add].
      reflexivity.
      }

      {
      eapply hypothesis; eauto using index_S, index_0.
      }

      {
      simpsub.
      cbn [Nat.add].
      reflexivity.
      }
    }

    {
    eapply hypothesis; eauto using index_S, index_0.
    }

    {
    eapply hypothesis; eauto using index_0.
    }

    {
    simpsub.
    reflexivity.
    }
  }
}
Qed.

Lemma equiv_lttp :
  forall i j, @equiv obj (app (app lttp i) j) (app (app leqtp (nsucc i)) j).
Proof.
intros i j.
unfold lttp.
apply equiv_app; auto using equiv_refl.
apply steps_equiv.
eapply star_step.
  {
  apply step_app2.
  }
simpsub.
unfold subst1.
apply star_refl.
Qed.

Lemma tr_leqtp_refl :
  forall G n,
    tr G (deq n n nattp)
    -> tr G (deq triv triv (app (app leqtp n) n)).
Proof.
intros G n H.
apply (nat_induction _ (app (app leqtp (var 0)) (var 0)) n); auto.
3:{
  simpsub.
  unfold subst1.
  reflexivity.
  }

  {
  simpsub.
  unfold subst1.
  rewrite -> unroll_leqtp.
  unfold nzero.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_unittp_intro.
  }

  {
  simpsub.
  unfold nsucc.
  setoid_rewrite -> unroll_leqtp at 2.
  rewrite -> sumcase_right.
  simpsub.
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  apply (tr_leqtp_eta2 _#3 (app (var 0) (var 2)) (app (var 0) (var 2))).
    {
    apply (tr_subtype_elim _ (var 3)).
      {
      apply (tr_subtype_eta2 _#3 (var 1) (var 1)).
      eapply hypothesis; eauto using index_0, index_S.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }

    {
    apply (tr_subtype_elim _ (var 3)).
      {
      apply (tr_subtype_eta2 _#3 (var 1) (var 1)).
      eapply hypothesis; eauto using index_0, index_S.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }
  eapply tr_pi_elim'.
    {
    eapply hypothesis; eauto using index_0.
    simpsub.
    cbn [Nat.add].
    reflexivity.
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }

    {
    simpsub.
    unfold subst1.
    reflexivity.
    }
  }
Qed.

Lemma tr_leqtp_succ :
  forall G n,
    tr G (deq n n nattp)
    -> tr G (deq triv triv (app (app leqtp n) (nsucc n))).
Proof.
intros G n Hn.
apply (nat_induction _ (app (app leqtp (var 0)) (nsucc (var 0))) n); auto.
3:{
  simpsub.
  unfold subst1.
  reflexivity.
  }

  {
  simpsub.
  unfold subst1.
  rewrite -> unroll_leqtp.
  unfold nzero.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_unittp_intro.
  }

  {
  simpsub.
  unfold nsucc at 2 3.
  setoid_rewrite -> unroll_leqtp at 2.
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  rewrite -> sumcase_right.
  fold (@nsucc obj (var 2)).
  simpsub.
  cbn [Nat.add].
  apply (tr_leqtp_eta2 _#3 (app (var 0) (var 2)) (app (var 0) (var 2))).
    {
    apply (tr_subtype_elim _ (var 3)).
      {
      apply (tr_subtype_eta2 _#3 (var 1) (var 1)).
      eapply hypothesis; eauto using index_0, index_S.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }

    {
    apply tr_nsucc_nattp.
    apply (tr_subtype_elim _ (var 3)).
      {
      apply (tr_subtype_eta2 _#3 (var 1) (var 1)).
      eapply hypothesis; eauto using index_0, index_S.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }
  eapply tr_pi_elim'.
    {
    eapply hypothesis; eauto using index_0.
    simpsub.
    cbn [Nat.add].
    reflexivity.
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }

    {
    simpsub.
    unfold subst1.
    reflexivity.
    }
  }
Qed.

Lemma tr_leqtp_trans :
  forall G m n p,
    tr G (deq m m nattp)
    -> tr G (deq n n nattp)
    -> tr G (deq p p nattp)
    -> tr G (deq triv triv (app (app leqtp m) n))
    -> tr G (deq triv triv (app (app leqtp n) p))
    -> tr G (deq triv triv (app (app leqtp m) p)).
Proof.
intros G m n p Hm Hn Hp Hmn Hnp.
apply (tr_leqtp_eta2 _ _ _ (app (app (app (app (lam (lam (lam (lam triv)))) n) p) triv) triv) (app (app (app (app (lam (lam (lam (lam triv)))) n) p) triv) triv)); auto.
apply (tr_pi_elim4' _ nattp nattp (app (app leqtp (subst (sh 2) m)) (var 1)) (app (app leqtp (var 2)) (var 1)) (app (app leqtp (subst (sh 4) m)) (var 2))); auto.
4:{
  simpsub.
  auto.
  }

2:{
  simpsub.
  auto.
  }

2:{
  simpsub.
  auto.
  }
apply tr_equal_elim.
apply (nat_induction _ (equal (pi nattp (pi nattp (pi (app (app leqtp (var 2)) (var 1)) (pi (app (app leqtp (var 2)) (var 1)) (app (app leqtp (var 4)) (var 2)))))) (lam (lam (lam (lam triv)))) (lam (lam (lam (lam triv))))) m); auto.
3:{
  simpsub.
  cbn [Nat.add].
  auto.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply tr_equal_intro.
  apply tr_pi_intro; auto using tr_nattp_formation.
  apply tr_pi_intro; auto using tr_nattp_formation.
  apply tr_pi_intro.
    {
    apply tr_leqtp_formation.
      {
      apply tr_nzero_nattp.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }
  apply tr_pi_intro.
    {
    apply tr_leqtp_formation.
      {
      eapply hypothesis; eauto using index_0, index_S.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }
  setoid_rewrite -> unroll_leqtp at 3.
  unfold nzero at 2.
  rewrite -> sumcase_left.
  simpsub.
  apply tr_unittp_intro.
  }

  {
  simpsub.
  cbn [Nat.add].
  apply tr_equal_intro.
  apply tr_pi_intro; auto using tr_nattp_formation.
  apply tr_pi_intro; auto using tr_nattp_formation.
  apply tr_pi_intro.
    {
    apply tr_leqtp_formation.
      {
      apply tr_nsucc_nattp.
      apply (tr_subtype_elim _ (var 5)).
        {
        apply (tr_subtype_eta2 _#3 (var 3) (var 3)).
        eapply hypothesis; eauto using index_0, index_S.
        }

        {
        eapply hypothesis; eauto using index_0, index_S.
        }
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }
  apply tr_pi_intro.
    {
    apply tr_leqtp_formation.
      {
      eapply hypothesis; eauto using index_0, index_S.
      }

      {
      eapply hypothesis; eauto using index_0, index_S.
      }
    }
  setoid_rewrite -> unroll_leqtp at 6.
  unfold nsucc at 2.
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  eapply (tr_nattp_eta_hyp_triv _ [_; _; _]).
    {
    simpsub.
    cbn [length].
    simpsub.
    cbn [Nat.add List.app].
    setoid_rewrite -> unroll_leqtp at 2.
    unfold nsucc at 1.
    rewrite -> sumcase_right.
    simpsub.
    unfold nzero at 2.
    rewrite -> sumcase_left.
    simpsub.
    apply (tr_voidtp_elim _ (var 1) (var 1)).
    eapply hypothesis; eauto using index_0, index_S.
    }
  cbn [length].
  simpsub.
  cbn [length].
  simpsub.
  cbn [Nat.add List.app].
  setoid_rewrite -> unroll_leqtp at 2.
  unfold nsucc at 2.
  rewrite -> sumcase_right.
  simpsub.
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  eapply (tr_nattp_eta_hyp_triv _ [_; _]).
    {
    simpsub.
    cbn [length].
    simpsub.
    cbn [Nat.add List.app].
    setoid_rewrite -> unroll_leqtp at 1.
    unfold nsucc at 1.
    rewrite -> sumcase_right.
    simpsub.
    unfold nzero at 1.
    rewrite -> sumcase_left.
    simpsub.
    apply (tr_voidtp_elim _ (var 0) (var 0)).
    eapply hypothesis; eauto using index_0.
    }
  cbn [length].
  simpsub.
  cbn [length].
  simpsub.
  cbn [Nat.add List.app].
  setoid_rewrite -> unroll_leqtp at 1.
  unfold nsucc.
  rewrite -> sumcase_right.
  simpsub.
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  rewrite -> sumcase_right.
  simpsub.
  cbn [Nat.add].
  apply (tr_leqtp_eta2 _#3 (app (app (app (app (lam (lam (lam (lam triv)))) (var 3)) (var 2)) (var 1)) (var 0)) (app (app (app (app (lam (lam (lam (lam triv)))) (var 3)) (var 2)) (var 1)) (var 0))).
    {
    apply (tr_subtype_elim _ (var 7)).
      {
      apply (tr_subtype_eta2 _#3 (var 5) (var 5)).
      eapply hypothesis; eauto 7 using index_0, index_S.
      }
    eapply hypothesis; eauto 7 using index_0, index_S.
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }
  eapply tr_pi_elim4'; eauto.
    {
    apply tr_equal_elim.
    eapply (tr_equal_eta2 _#4 (app (var 4) (var 6)) (app (var 4) (var 6))).
    eapply tr_pi_elim'; eauto.
      {
      eapply hypothesis; eauto using index_0, index_S.
      simpsub.
      cbn [Nat.add].
      reflexivity.
      }

      {
      eapply hypothesis; eauto 7 using index_0, index_S.
      }

      {
      simpsub.
      cbn [Nat.add].
      reflexivity.
      }
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }

    {
    eapply hypothesis; eauto using index_0, index_S.
    }

    {
    simpsub.
    auto.
    }
  }
Qed.

Definition natmax {object} m n : term object :=
  app (app (app theta
              (lam (lam (lam (natcase (var 1)
                                (var 0)
                                (natcase (var 1)
                                   (var 2)
                                   (nsucc
                                      (app (app (var 4) (var 1)) (var 0)))))))))
         m)
    n.

Lemma subst_natmax :
  forall object s m n,
    @subst object s (natmax m n) = natmax (subst s m) (subst s n).
Proof.
intros object s m n.
unfold natmax.
simpsub.
reflexivity.
Qed.

Lemma subst_natcase :
  forall object s m n p,
    @subst object s (natcase m n p) = natcase (subst s m) (subst s n) (subst (under 1 s) p).
Proof.
intros object s m n p.
unfold natcase.
simpsub.
reflexivity.
Qed.

Hint Rewrite subst_natcase subst_natmax : subst.

Lemma natcase_zero :
  forall n p,
    @equiv obj (natcase nzero n p) n.
Proof.
intros n p.
unfold natcase, nzero.
rewrite -> sumcase_left.
simpsub.
apply equiv_refl.
Qed.

Lemma natcase_succ :
  forall m n p,
    @equiv obj (natcase (nsucc m) n p) (subst1 m p).
Proof.
intros m n p.
unfold natcase, nsucc.
rewrite -> sumcase_right.
apply equiv_refl.
Qed.


From iris.algebra Require Import agree auth excl gmap dfrac max_prefix_list.
From iris.algebra Require Import updates local_updates.
From iris.algebra.lib Require Import mono_list.
From iris.base_logic Require Import invariants.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From aneris.lib Require Import gen_heap_light.
From aneris.aneris_lang Require Import lang resources inject tactics proofmode.
From aneris.aneris_lang.lib Require Import
     list_proof monitor_proof lock_proof map_proof assert_proof.
From aneris.examples.reliable_communication.lib.repdb
     Require Export log_code.
From aneris.examples.reliable_communication.lib.repdb.resources
     Require Import log_resources.

Import lock_proof.

Section Log.
  Context `{!anerisG Mdl Σ, !lockG Σ}.
  Context {Aty : Type}.
  Notation A := (leibnizO Aty).
  Context `{inG Σ (mono_listUR A)}.
  Context `[!Inject A val].

  Lemma wp_log_create ip :
    {{{ True }}}
      log_create #() @[ip]
    {{{ logL logV, RET #logL; logL ↦[ip] logV ∗ ⌜is_log [] logV⌝}}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_rec. wp_pures.
    wp_alloc l as "Hl".
    iApply "HΦ". iFrame. iPureIntro.
    by eexists.
    Qed.

  Lemma wp_log_add_entry ip logL logV logM (x : A) :
    {{{ ⌜is_log logM logV⌝ ∗ logL ↦[ip] logV }}}
      log_add_entry #logL $x @[ip]
    {{{ logV', RET #();
        ⌜is_log (logM ++ [x]) logV'⌝ ∗ logL ↦[ip] logV' }}}.
  Proof.
    iIntros (Φ) "(%Hl & Hp) HΦ".
    destruct Hl as (lV & -> & Hlst).
    wp_lam. wp_pures.
    wp_load. wp_pures.
    wp_apply (wp_list_cons _ []); first done.
    iIntros (v) "%Hl2".
    wp_apply wp_list_append; first done.
    iIntros (v') "%Hl'".
    wp_pures.
    wp_store.
    iApply "HΦ".
    iFrame.
    iPureIntro.
    eexists; rewrite app_length /=; split; last done.
    do 3 f_equal; lia.
  Qed.

  Lemma wp_log_next ip logL logV logM q :
    {{{ ⌜is_log logM logV⌝ ∗ logL ↦[ip]{q} logV }}}
      log_next #logL @[ip]
    {{{ n, RET #n;
        ⌜n = List.length logM⌝ ∗ ⌜is_log (logM) logV⌝ ∗ logL ↦[ip]{q} logV}}}.
  Proof.
    iIntros (Φ) "(%Hl & Hp) HΦ".
    destruct Hl as (lV & -> & Hlst).
    wp_lam.
    wp_load.
    wp_pures.
    iApply "HΦ".
    iFrame.
    iPureIntro.
    split; by eexists.
  Qed.

  Lemma wp_log_length ip logL logV logM q :
    {{{ ⌜is_log logM logV⌝ ∗ logL ↦[ip]{q} logV }}}
      log_length #logL @[ip]
    {{{ n, RET #n;
        ⌜n = List.length logM⌝ ∗ ⌜is_log (logM) logV⌝ ∗ logL ↦[ip]{q} logV}}}.
  Proof.
    iIntros (Φ) "(%Hl & Hp) HΦ".
    destruct Hl as (lV & -> & Hlst).
    wp_lam.
    wp_load.
    wp_pures.
    iApply "HΦ".
    iFrame.
    iPureIntro.
    split; by eexists.
  Qed.

Lemma wp_log_get ip logL logV logM i q :
    {{{ ⌜i < List.length logM⌝ ∗
        ⌜is_log logM logV⌝ ∗ logL ↦[ip]{q} logV }}}
      log_get #logL #i @[ip]
    {{{ x, RET (SOMEV $x);
        ⌜List.nth_error logM i = Some x⌝ ∗
        ⌜is_log (logM) logV⌝ ∗ logL ↦[ip]{q} logV}}}.
  Proof.
    iIntros (Φ) "(%Hi & %Hl & Hp) HΦ".
    destruct Hl as (lV & -> & Hlst).
    wp_lam.
    wp_pures.
    wp_load.
    wp_pures.
    wp_apply wp_list_nth_some; [eauto with lia|].
    iIntros (v (x & -> & Hsome)).
    iApply "HΦ".
    iFrame.
    iPureIntro.
    split; eauto; last by eexists.
  Qed.

  Lemma wp_log_wait_until ip
    γlog q logM (* created at the logical setup *)
    monN monγ monV monR logL logV i (* created at the allocation of physical data *):
    {{{ ⌜i ≤ List.length logM⌝ ∗ ⌜is_log logM logV⌝ ∗
        is_monitor monN ip monγ monV (log_monitor_inv_def ip γlog q logL monR) ∗
        locked monγ ∗ (monR logM) ∗ logL ↦[ip] logV ∗ own_log_auth γlog q logM }}}
      log_wait_until #logL monV #i @[ip]
    {{{ logV' logM', RET #();
        ⌜i < List.length logM'⌝ ∗ ⌜is_log logM' logV'⌝ ∗
        locked monγ ∗ (monR logM') ∗ logL ↦[ip] logV' ∗ own_log_auth γlog q logM' }}}.
  Proof.
    iIntros (Φ) "(%Hi & %Hl & #Hmon & Hlocked & Hres & Hp & Hown) HΦ".
    wp_lam.
    wp_pures.
    case_bool_decide as Hi2 ; first by lia.
    wp_pures.
    wp_apply (wp_log_next with "[$Hp //]").
    iIntros (n) "(-> & _ & Hp)".
    wp_pures.
    case_bool_decide as Hiz; first by lia.
    wp_pure _.
    clear Hiz Hi2.
    iDestruct (get_obs with "Hown") as "#Hobs".
    iLöb as "IH" forall (logV logM Hl Hi) "Hres Hp Hown Hobs".
    wp_pures.
    wp_apply (wp_log_next with "[$Hp //]").
    iIntros (n) "(-> & _ & Hp)".
    wp_pures.
    case_bool_decide as Hiz2.
    - wp_pure _.
      wp_apply (monitor_wait_spec with "[$Hmon Hres $Hlocked Hp Hown]").
      iExists _, _. iFrame. eauto.
      iIntros (v) "(-> & Hlocked & Hres)".
      iDestruct "Hres" as (logV' logM' Hlog') "(Hp & Hown & Hres)".
      do 2 wp_pure _.
      iDestruct (own_obs_prefix with "[$Hown][$Hobs]") as "%Hpre".
      assert (i ≤ length logM') as Hi'.
      list_simplifier.
      by apply prefix_length.
      iSpecialize ("IH" $! logV' logM' Hlog' Hi').
      iDestruct (get_obs with "Hown") as "#Hobs'".
      iApply ("IH" with "[$Hlocked][$HΦ][$Hres][$Hp][$Hown][$Hobs']").
    - wp_pure _.
      wp_apply wp_assert.
       wp_pures.
      iSplitR.
      iPureIntro.
      f_equal.
      case_bool_decide; eauto with lia.
      iNext.
      iApply "HΦ".
      iFrame.
      eauto with lia.
  Qed.

  End Log.


Require Import Fiat.Common Fiat.Computation.Core Fiat.ADT.Core Coq.Sets.Ensembles.

Section HideADT.

  Context {extSig : ADTSig}.
  (* The extended signature *)

  Context {resConstructorIndex : Type}.
  (* The restricted set of constructor indices *)

  Context {resMethodIndex : Type}.
  (* The restricted set of method indices *)

  Variable constructorMap : resConstructorIndex -> ConstructorIndex extSig.
  (* Map from restricted to extended constructor indices *)

  Variable methodMap : resMethodIndex -> MethodIndex extSig.
  (* Map from restricted to extended method indices *)

  Definition resSig :=
    {| ConstructorIndex := resConstructorIndex;
       MethodIndex := resMethodIndex;
       ConstructorDom idx := ConstructorDom extSig (constructorMap idx);
       MethodDomCod idx := MethodDomCod extSig (methodMap idx)
    |}.
  (* The signature of the ADT with restricted constructor and method indices *)

  Definition HideADT (extADT : ADT extSig) : ADT resSig :=
    match extADT with
        {| Rep := rep;
           Constructors := extConstructors;
           Methods := extMethods
        |} =>
        Build_ADT resSig
          (fun idx => extConstructors (constructorMap idx))
          (fun idx => extMethods (methodMap idx))
    end.

End HideADT.


From fae_gtlc_mu.refinements.gradual_static Require Export compat_cast.defs.
From fae_gtlc_mu.backtranslation Require Export general_def_lemmas.
From fae_gtlc_mu.cast_calculus Require Export types.
From fae_gtlc_mu.stlc_mu Require Export lang.

Section compat_cast_arrow_arrow.
  Context `{!implG Σ,!specG Σ}.

  Hint Extern 5 (AsVal _) => eexists; simpl; try done; eapply cast_calculus.lang.of_to_val; fast_done : typeclass_instances.

  (** The case `throughArrow` in our proof by induction on the alternative consistency relation. *)
  Lemma back_cast_ar_arrow_arrow:
    ∀ (A : list (type * type)) (τ1 τ1' τ2 τ2' : type) (pC1 : alternative_consistency A τ1' τ1) (pC2 : alternative_consistency A τ2 τ2')
      (IHpC1 : back_cast_ar pC1) (IHpC2 : back_cast_ar pC2),
      back_cast_ar (throughArrow A τ1 τ1' τ2 τ2' pC1 pC2).
  Proof.
    intros A τ1 τ1' τ2 τ2' pC1 pC2 IHpC1 IHpC2.
    rewrite /back_cast_ar. iIntros (ei' K' v v' fs) "(#Hfs & #Hvv' & #Hei' & Hv')".
    iDestruct "Hfs" as "[% Hfs']"; iAssert (rel_cast_functions A fs) with "[Hfs']" as "Hfs". iSplit; done. iClear "Hfs'".
    rewrite /𝓕c /𝓕. fold (𝓕 pC1) (𝓕 pC2). rewrite between_TArrow_subst_rewrite.
    rename v into f. rename v' into f'. iDestruct "Hv'" as "Hf'". iDestruct "Hvv'" as "Hff'".
    fold (𝓕c pC1 fs) (𝓕c pC2 fs).
    unfold between_TArrow.
    iMod ((step_lam _ ei' K') with "[Hf']") as "Hf'"; auto. asimpl.
    iApply wp_value.
    iExists (LamV _). iFrame "Hf'".
    do 2 rewrite interp_rw_TArrow. simpl.
    iModIntro.
    (** actual thing to prove *)
    (** ===================== *)
    iIntros ((a , a')) "#Haa'". simpl. clear K'.
    iIntros (K') "Hf'".
    simpl in *.
    (** implementation *)
    wp_head.
    (** specification *)
    iMod ((step_lam _ ei' K') with "[Hf']") as "Hf'"; auto. asimpl.
    (** IH for arguments *)
    iApply (wp_bind [cast_calculus.lang.AppRCtx f ; cast_calculus.lang.CastCtx _ _]).
    rewrite 𝓕c_rewrite.
    iApply (wp_wand with "[Hf']").
    iApply (IHpC1 ei' (AppRCtx f' :: AppRCtx _ :: K')); auto.
    (** ... *)
    iIntros (b) "HHH".
    iDestruct "HHH" as (b') "[Hb' #Hbb']". simpl.
    (** use relatedness of functions *)
    iApply (wp_bind [CastCtx _ _]).
    iApply (wp_wand with "[Hb']").
    iDestruct ("Hff'" with "Hbb'") as "Hfbf'b'/=".
    iApply ("Hfbf'b'" $! (AppRCtx _ :: K')). iFrame "Hb'".
    (** ... *)
    iIntros (r) "HHH". iDestruct "HHH" as (r') "[Hr' Hrr']". simpl.
    iApply (wp_wand with "[-]").
    rewrite -𝓕c_rewrite.
    (** second IH for the results *)
    iApply (IHpC2 ei' K' r r' with "[-]"). auto.
    (** ... *)
    iIntros; auto.
  Qed.

End compat_cast_arrow_arrow.


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.

Require Import Domains.basics.
Require Import Domains.preord.
Require Import Domains.categories.
Require Import Domains.sets.
Require Import Domains.finsets.
Require Import Domains.esets.
Require Import Domains.effective.
Require Import Domains.plotkin.
Require Import Domains.embed.
Require Import Domains.joinable.
Require Import Domains.approx_rels.
Require Import Domains.profinite.
Require Import Domains.profinite_adj.
Require Import Domains.cont_functors.

(**  * Continuous adjoint functors

     Here we lift the lifting and forgetful adjoint functors into the
     category of embeddings and prove that they are continuous.
  *)

Definition forgetEMBED_map (A B:ob PLT) (f:A ⇀ B) : forgetPLT_ob A ⇀ forgetPLT_ob B :=
  Embedding true (forgetPLT_ob A) (forgetPLT_ob B)
    (@embed_map false A B f)
    (@embed_mono false A B f)
    (@embed_reflects false A B f)
    (fun _ => I)
    (@embed_directed2 false A B f).

Program Definition forgetEMBED : functor (EMBED false) (EMBED true) :=
  Functor (EMBED false) (EMBED true) forgetPLT_ob forgetEMBED_map _ _ _.
Solve Obligations of forgetEMBED using auto.

Program Definition liftEMBED_map (A B:ob ∂PLT) (f:A ⇀ B) : liftPPLT_ob A ⇀ liftPPLT_ob B :=
  Embedding false (liftPPLT_ob A) (liftPPLT_ob B)
    (fun x => match x with None => None | Some a => Some (f a) end)
    _ _ _ _.
Next Obligation.
  simpl. intros.
  destruct a; destruct a'; simpl; auto.
  apply embed_mono. auto.
Qed.
Next Obligation.
  simpl. intros.
  destruct a; destruct a'; simpl; auto.
  apply embed_reflects with B f; auto.
Qed.
Next Obligation.
  intros. exists None. hnf. auto.
Qed.
Next Obligation.
  simpl. intros.
  destruct a; destruct b.
  destruct y.
  destruct embed_directed2 with true A B f c1 c c0 as [q [?[??]]]; auto.
  exists (Some q); auto.
  elim H.
  exists (Some c). auto.
  exists (Some c). auto.
  exists None. auto.
Qed.

Program Definition liftEMBED : functor (EMBED true) (EMBED false) :=
  Functor (EMBED true) (EMBED false) liftPPLT_ob liftEMBED_map _ _ _.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct x; simpl.
  destruct H. apply H. auto.
  destruct x; simpl.
  destruct H. apply H0. auto.
Qed.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct x. destruct H. apply H. auto.
  destruct x. destruct H. apply H0. auto.
Qed.
Next Obligation.
  intros. split; hnf; simpl; intros.
  destruct x. destruct H. apply H. auto.
  destruct x. destruct H. apply H0. auto.
Qed.

Require Import bilimit.

Lemma forgetEMBED_continuous : continuous_functor forgetEMBED.
Proof.
  hnf; intros.
  apply decompose_is_colimit; simpl.
  intros.
  destruct (colimit_decompose _ I DS CC X x) as [i [s H]].
  exists i. exists s. auto.
Qed.

Lemma liftEMBED_continuous : continuous_functor liftEMBED.
Proof.
  hnf; intros.
  apply decompose_is_colimit; simpl.
  intros.
  destruct x.
  destruct (colimit_decompose _ I DS CC X c) as [i [s H]].
  exists i. exists (Some s). auto.
  destruct (directed.choose_ub_set I nil) as [i0 ?].
  exists i0. exists None. auto.
Qed.


Require Import progs.conclib.
Require Import progs.conc_queue.
Require Import progs.conc_queue_specs.
Require Import floyd.library.

Set Bullet Behavior "Strict Subproofs".

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).
Definition makecond_spec := DECLARE _makecond (makecond_spec _).
Definition freecond_spec := DECLARE _freecond (freecond_spec _).
Definition wait_spec := DECLARE _waitcond (wait2_spec _).
Definition signal_spec := DECLARE _signalcond (signal_spec _).

Definition surely_malloc_spec := DECLARE _surely_malloc surely_malloc_spec'.
Definition q_new_spec := DECLARE _q_new q_new_spec'.
Definition q_del_spec := DECLARE _q_del q_del_spec'.
Definition q_add_spec := DECLARE _q_add q_add_spec'.
Definition q_remove_spec := DECLARE _q_remove q_remove_spec'.
Definition q_tryremove_spec := DECLARE _q_tryremove q_tryremove_spec'.

Definition Gprog : funspecs := ltac:(with_library prog
  [surely_malloc_spec; acquire_spec; release_spec; makelock_spec; freelock_spec;
   makecond_spec; freecond_spec; wait_spec; signal_spec;
   q_new_spec; q_del_spec; q_add_spec; q_remove_spec; q_tryremove_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  unfold surely_malloc_spec, surely_malloc_spec'; start_function.
  forward_call (* p = malloc(n); *)
     n.
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (malloc_token Tsh n p * memory_block Tsh n p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. inv H0.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma body_q_new : semax_body Vprog Gprog f_q_new q_new_spec.
Proof.
  unfold q_new_spec, q_new_spec'; start_function.
  forward_call (sizeof tqueue_t).
  { simpl; computable. }
  Intros p.
  assert (alignof tqueue_t | natural_alignment).
  { simpl; unfold align_attr; simpl.
    exists 2; auto. }
  rewrite malloc_compat; auto; Intros.
  rewrite memory_block_data_at_; auto.
  forward.
  Intros.
  assert (field_compatible tqueue [] p /\ field_compatible (tptr tlock) [] (offset_val 60 p)) as (? & ?).
  { unfold field_compatible in *; repeat match goal with H : _ /\ _ |- _ => destruct H end.
    destruct p as [| | | | | b o]; try contradiction.
    assert (Int.unsigned (Int.add o (Int.repr 60)) = Int.unsigned o + 60) as Ho.
    { rewrite Int.unsigned_add_carry.
      unfold Int.add_carry.
      rewrite Int.unsigned_repr, Int.unsigned_zero; [|computable].
      destruct (zlt _ Int.modulus); simpl in *; omega. }
    repeat split; auto; simpl in *; try omega.
    rewrite Ho; unfold align_attr in *; simpl in *.
    apply Z.divide_add_r; auto.
    exists 15; auto. }
  forward_for_simple_bound MAX (EX i : Z, PROP () LOCAL (temp _q p; temp _newq p)
    SEP (malloc_token Tsh (sizeof tqueue_t) p;
         @data_at CompSpecs Tsh tqueue (repeat (vint 0) (Z.to_nat i) ++ repeat Vundef (Z.to_nat (MAX - i)),
           (Vundef, (Vundef, (Vundef, (Vundef, Vundef))))) p;
         @data_at_ CompSpecs Tsh (tptr tlock) (offset_val 60 p))).
  { unfold MAX; computable. }
  { unfold MAX; computable. }
  { entailer!.
    unfold data_at_, field_at_; unfold_field_at 1%nat.
    unfold data_at, field_at, at_offset; simpl; entailer. }
  { forward.
    go_lower.
    apply andp_right; [apply prop_right; split; auto; omega|].
    apply andp_right; [apply prop_right; auto|].
    cancel.
    rewrite upd_Znth_app2; repeat rewrite Zlength_repeat; repeat rewrite Z2Nat.id; try omega.
    rewrite Zminus_diag, upd_Znth0, sublist_repeat; try rewrite Zlength_repeat, Z2Nat.id; try omega.
    rewrite Z2Nat.inj_add, repeat_plus; try omega; simpl.
    rewrite <- app_assoc; replace (MAX - i - 1) with (MAX - (i + 1)) by omega; cancel. }
  rewrite Zminus_diag, app_nil_r.
  forward.
  forward.
  forward.
  forward_call (sizeof tint).
  { simpl; computable. }
  Intros addc.
  rewrite malloc_compat with (p0 := addc); auto; Intros.
  rewrite memory_block_data_at_; auto.
  forward_call (addc, Tsh).
  { unfold tcond; cancel. }
  forward.
  forward_call (sizeof tint).
  { simpl; computable. }
  Intros remc.
  rewrite malloc_compat with (p0 := remc); auto; Intros.
  rewrite memory_block_data_at_; auto.
  forward_call (remc, Tsh).
  { unfold tcond; cancel. }
  forward.
  forward_call (sizeof tlock).
  { admit. } (* lock size broken *)
  { simpl; computable. }
  Intros lock.
  rewrite malloc_compat with (p0 := lock); auto; Intros.
  rewrite memory_block_data_at_; auto.
  destruct Q as (t, P).
  forward_call (lock, Tsh, q_lock_pred t P p lock gsh2).
  gather_SEP 7 8; replace_SEP 0 (data_at Tsh tqueue_t (repeat (vint 0) (Z.to_nat MAX),
           (vint 0, (vint 0, (vint 0, (addc, remc)))), Vundef) p).
  { go_lowerx.
    unfold_data_at 1%nat.
    unfold data_at_, field_at_, field_at, at_offset; simpl.
    rewrite !sem_cast_neutral_ptr; auto.
    rewrite !field_compatible_cons; simpl; Intros.
    apply andp_right; [apply prop_right; unfold in_members; simpl; split; [|split; [|split]]; auto|].
    rewrite sepcon_emp, !isptr_offset_val_zero; auto. }
  apply new_ghost with (t' := reptype t).
  forward.
  forward_call (lock, Tsh, q_lock_pred t P p lock gsh2).
  { lock_props.
    unfold q_lock_pred, q_lock_pred'; simpl.
    Exists ([] : list (val * reptype t)) 0 addc remc ([] : hist (reptype t)).
    rewrite Zlength_nil; simpl; cancel.
    rewrite sepcon_andp_prop'.
    apply andp_right; [apply prop_right|].
    { repeat split; auto; unfold MAX; try omega; try computable. }
    cancel.
    subst Frame; instantiate (1 := [field_at Tsh tqueue_t [StructField _lock] lock p; ghost gsh1 (Tsh, []) p]);
      simpl.
    unfold_field_at 1%nat.
    erewrite <- ghost_share_join with (h1 := []); eauto.
    simpl; cancel.
    rewrite (sepcon_comm _ (@ghost _ (reptype t) _ _)), !sepcon_assoc; apply sepcon_derives; auto.
    unfold data_at, field_at; simpl.
    rewrite !field_compatible_cons; simpl; Intros.
    apply andp_right; [apply prop_right; unfold in_members; simpl; split; [|split]; auto|].
    rewrite sem_cast_neutral_ptr; auto. }
  forward.
  Exists p lock.
  unfold lqueue; simpl; entailer!; auto.
Admitted.

Lemma body_q_del : semax_body Vprog Gprog f_q_del q_del_spec.
Proof.
  unfold q_del_spec, q_del_spec'; start_function.
  destruct Q as (t, (P, h)).
  unfold lqueue; rewrite lock_inv_isptr; Intros.
  forward.
  forward_call (lock, Tsh, q_lock_pred t P p lock gsh2).
  forward_call (lock, Tsh, q_lock_pred t P p lock gsh2).
  { lock_props. }
  unfold q_lock_pred, q_lock_pred'; Intros vals head addc remc h'.
  forward_call (lock, sizeof tlock).
  { simpl; cancel.
    rewrite !sepcon_assoc; apply sepcon_derives; [apply data_at__memory_block_cancel | cancel]. }
  forward.
  rewrite data_at_isptr, (cond_var_isptr _ addc), (cond_var_isptr _ remc); Intros.
  rewrite isptr_offset_val_zero; auto.
  forward.
  forward_call (addc, Tsh).
  forward_call (addc, sizeof tcond).
  { simpl; cancel.
    rewrite !sepcon_assoc; apply sepcon_derives; [apply data_at__memory_block_cancel | cancel]. }
  forward.
  forward_call (remc, Tsh).
  forward_call (remc, sizeof tcond).
  { simpl; cancel.
    repeat rewrite sepcon_assoc; apply sepcon_derives; [apply data_at__memory_block_cancel | cancel]. }
  gather_SEP 2 5; rewrite sepcon_comm.
  replace_SEP 0 (!!(h' = h) && ghost Tsh (Tsh, h) p).
  { go_lower.
    eapply derives_trans; [apply prop_and_same_derives, ghost_inj_Tsh|].
    Intros; subst.
    rewrite ghost_share_join; auto; entailer!. }
  Intros; subst.
  exploit (consistent_inj h [] [] vals); auto; intro; subst; simpl.
  rewrite Zlength_nil.
  gather_SEP 1 4; replace_SEP 0 (data_at Tsh tqueue_t (rotate (complete MAX []) head MAX,
     (vint 0, (vint head, (vint ((head + 0) mod MAX), (addc, remc)))), lock) p).
  { unfold_data_at 2%nat; entailer!.
    unfold data_at, field_at; Intros; simpl.
    apply andp_right; [|simple apply derives_refl].
    rewrite field_compatible_cons; unfold in_members; simpl; entailer!. }
  forward_call (p, sizeof tqueue_t).
  { rewrite (sepcon_comm (malloc_token _ _ _)).
    rewrite !sepcon_assoc; apply sepcon_derives; [apply data_at_memory_block | simpl; cancel]. }
  forward.
  (* Do we want to deallocate the ghost? *)
Admitted.

Lemma body_q_add : semax_body Vprog Gprog f_q_add q_add_spec.
Proof.
  unfold q_add_spec, q_add_spec'.
  start_function.
  destruct Q as (t, ((P, h), v)).
  unfold lqueue; rewrite lock_inv_isptr; Intros.
  forward.
  forward_call (lock, sh, q_lock_pred t P p lock gsh2).
  unfold q_lock_pred at 2; unfold q_lock_pred'; Intros vals head addc remc h'.
  forward.
  rewrite data_at_isptr; Intros; rewrite isptr_offset_val_zero; auto.
  forward.
  forward_while (EX vals : _, EX head : Z, EX addc : val, EX remc : val, EX h' : hist (reptype t),
   PROP ()
   LOCAL (temp _len (vint (Zlength vals)); temp _q p; temp _l lock; temp _tgt p; temp _r e)
   SEP (lock_inv sh lock (q_lock_pred t P p lock gsh2);
        q_lock_pred' t P p vals head addc remc lock gsh2 h';
        @field_at CompSpecs sh tqueue_t [StructField _lock] lock p;
        @data_at CompSpecs Tsh t v e; malloc_token Tsh (sizeof t) e; ghost gsh1 (sh, h) p)).
  { Exists vals head addc remc h'.
    unfold q_lock_pred'; entailer!.
    apply derives_refl. }
  { go_lower; entailer'. }
  { unfold q_lock_pred'; Intros.
    forward.
    { go_lower.
      rewrite cond_var_isptr; Intros; entailer'. }
    forward_call (addc0, lock, Tsh, sh, q_lock_pred t P p lock gsh2).
    { unfold q_lock_pred; unfold q_lock_pred'; simpl.
      Exists vals0 head0 addc0 remc0 h'0.
      subst Frame; instantiate (1 := [field_at sh tqueue_t [StructField _lock] lock p;
        data_at Tsh t v e; malloc_token Tsh (sizeof t) e; ghost gsh1 (sh, h) p]); simpl.
      repeat rewrite sepcon_assoc; repeat (apply sepcon_derives; [apply derives_refl|]).
      entailer!.
      apply andp_right; cancel. }
    unfold q_lock_pred at 2; unfold q_lock_pred'; Intros vals1 head1 addc1 remc1 h'1.
    forward.
    Exists (vals1, head1, addc1, remc1, h'1).
    unfold q_lock_pred'; entailer!. }
  unfold q_lock_pred'; Intros.
  rewrite Int.signed_repr, Zlength_correct in HRE.
  freeze [0; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13] FR; forward.
  exploit (Z_mod_lt (head0 + Zlength vals0) MAX); [omega | intro].
  forward.
  forward.
  { go_lower.
    repeat apply andp_right; apply prop_right; auto.
    rewrite andb_false_intro2; simpl; auto. }
  forward.
  thaw FR.
  rewrite (cond_var_isptr _ remc0); Intros.
  forward.
  freeze [0; 1; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13] FR; forward_call (remc0, Tsh).
  thaw FR.
  rewrite upd_rotate; auto; try rewrite Zlength_complete; try rewrite Zlength_map; auto.
  rewrite Zminus_mod_idemp_l, Z.add_simpl_l, (Zmod_small (Zlength vals0));
    [|rewrite Zlength_correct; unfold MAX; omega].
  erewrite <- Zlength_map, upd_complete; [|rewrite Zlength_map, Zlength_correct; auto].
  gather_SEP 7 12.
  rewrite sepcon_comm; replace_SEP 0 (!!(list_incl h h'0) && ghost Tsh (Tsh, h'0) p).
  { go_lower.
    eapply derives_trans; [apply prop_and_same_derives, ghost_inj|].
    Intros; rewrite ghost_share_join; auto; entailer!. }
  exploit (consistent_snoc_add h'0 [] vals0 e v); auto; intro.
  Intros; apply hist_add with (e0 := QAdd e v); [eauto|].
  erewrite <- ghost_share_join with (h1 := h ++ [QAdd e v])(sh := sh); try eassumption.
  time forward_call (lock, sh, q_lock_pred t P p lock gsh2). (* 37s *)
  { lock_props.
    unfold q_lock_pred, q_lock_pred'.
    Exists (vals0 ++ [(e, v)]) head0 addc0 remc0 (h'0 ++ [QAdd e v]).
    rewrite data_at_isptr; Intros.
    rewrite map_app, Zlength_app, Zlength_cons, Zlength_nil.
    unfold sem_mod; simpl sem_binarith.
    unfold both_int; simpl force_val.
    rewrite andb_false_intro2; [|simpl; auto].
    simpl force_val.
    rewrite !add_repr, mods_repr; try computable.
    repeat match goal with H : _ /\ _ |- _ => destruct H end.
    simpl; apply andp_right.
    { apply prop_right; split; [rewrite Zlength_correct; unfold MAX; omega|].
      split; [omega | auto]. }
    rewrite Zplus_mod_idemp_l, Z.add_assoc, Zlength_map.
    repeat rewrite map_app; repeat rewrite sepcon_app; simpl.
    rewrite sem_cast_neutral_ptr; auto; simpl.
    rewrite sepcon_andp_prop', !sepcon_andp_prop, sepcon_andp_prop'; apply andp_right;
      [apply prop_right; auto | cancel].
    { pose proof (Z_mod_lt (head0 + Zlength vals0) MAX).
      rewrite Zlength_map; split; try omega.
      transitivity MAX; simpl in *; [omega | unfold MAX; computable]. } }
  forward.
  { unfold lqueue; simpl; entailer!; auto. }
  { apply list_incl_app; auto. }
  { pose proof Int.min_signed_neg; split; [rewrite Zlength_correct; omega|].
    transitivity MAX; [auto | unfold MAX; computable]. }
Admitted.

Lemma body_q_remove : semax_body Vprog Gprog f_q_remove q_remove_spec.
Proof.
  unfold q_remove_spec, q_remove_spec'; start_function.
  destruct Q as (t, (P, h)).
  unfold lqueue; rewrite lock_inv_isptr; Intros.
  forward.
  forward_call (lock, sh, q_lock_pred t P p lock gsh2).
  unfold q_lock_pred at 2; unfold q_lock_pred'; Intros vals head addc remc h'.
  forward.
  rewrite data_at_isptr; Intros; rewrite isptr_offset_val_zero; auto.
  forward.
  forward_while (EX vals : list _, EX head : Z, EX addc : val, EX remc : val, EX h' : hist (reptype t), PROP ()
   LOCAL (temp _len (vint (Zlength vals)); temp _q p; temp _l lock; temp _tgt p)
   SEP (lock_inv sh lock (q_lock_pred t P p lock gsh2);
        q_lock_pred' t P p vals head addc remc lock gsh2 h';
        @field_at CompSpecs sh tqueue_t [StructField _lock] lock p; ghost gsh1 (sh, h) p)).
  { Exists vals head addc remc h'; unfold q_lock_pred'; entailer!. }
  { go_lower; entailer'. }
  { unfold q_lock_pred'; rewrite (cond_var_isptr _ remc0); Intros.
    forward.
    forward_call (remc0, lock, Tsh, sh, q_lock_pred t P p lock gsh2).
    { unfold q_lock_pred; unfold q_lock_pred'; simpl.
      Exists vals0 head0 addc0 remc0 h'0.
      subst Frame; instantiate (1 := [field_at sh tqueue_t [StructField _lock] lock p;
        ghost gsh1 (sh, h) p]); simpl.
      repeat rewrite sepcon_assoc; repeat (apply sepcon_derives; [apply derives_refl|]).
      entailer!.
      apply andp_right; [Intros; entailer! | entailer!]. }
    unfold q_lock_pred at 2; unfold q_lock_pred'; Intros vals1 head1 addc1 remc1 h'1.
    forward.
    Exists (vals1, head1, addc1, remc1, h'1).
    unfold q_lock_pred'; entailer!. }
  unfold q_lock_pred'; Intros.
  assert (Zlength vals0 > 0).
  { rewrite Zlength_correct in *.
    destruct (length vals0); [|rewrite Nat2Z.inj_succ; omega].
    contradiction HRE; auto. }
  evar (R : mpred).
  replace_SEP 9 (!!(Forall isptr (map fst vals0)) && R); subst R.
  { go_lower; apply prop_and_same_derives, all_ptrs. }
  forward.
  forward.
  { go_lower; Intros.
    rewrite Znth_head; try rewrite Zlength_map; try omega.
    repeat apply andp_right; apply prop_right; auto.
    apply Forall_Znth; [rewrite Zlength_map; omega|].
    eapply Forall_impl; [|eauto].
    destruct a; auto. }
  forward.
  forward.
  { go_lower; simpl.
    repeat apply andp_right; apply prop_right; auto.
    rewrite andb_false_intro2; simpl; auto. }
  forward.
  rewrite cond_var_isptr; Intros.
  forward.
  freeze [0; 1; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12] FR; forward_call (addc0, Tsh).
  thaw FR.
  rewrite upd_rotate; try rewrite Zlength_complete; try rewrite Zlength_map; auto.
  rewrite Zminus_diag, Zmod_0_l.
  destruct vals0; [contradiction HRE; auto|].
  rewrite Zlength_cons in *.
  simpl; rewrite rotate_1; try rewrite Zlength_map; try omega.
  unfold sem_mod; simpl sem_binarith.
  unfold both_int; simpl force_val.
  rewrite andb_false_intro2; [|simpl; auto].
  simpl force_val.
  rewrite !add_repr, mods_repr; try computable.
  destruct p0 as (e, v).
  exploit (consistent_cons_rem(t := reptype t)); eauto; intro.
  gather_SEP 8 11.
  rewrite sepcon_comm; replace_SEP 0 (!!(list_incl h h'0) && ghost Tsh (Tsh, h'0) p).
  { go_lower.
    eapply derives_trans; [apply prop_and_same_derives, ghost_inj|].
    Intros; rewrite ghost_share_join; auto; entailer!. }
  Intros; apply hist_add with (e0 := QRem e v); [eauto|].
  erewrite <- ghost_share_join with (h1 := h ++ [QRem e v])(sh := sh); try eassumption; try apply list_incl_app;
    auto.
  forward_call (lock, sh, q_lock_pred t P p lock gsh2).
  { lock_props.
    unfold q_lock_pred, q_lock_pred'; Exists vals0 ((head0 + 1) mod MAX) addc0 remc0 (h'0 ++ [QRem e v]).
    unfold Z.succ; rewrite sub_repr, Z.add_simpl_r, (Z.add_comm (Zlength vals0)), Z.add_assoc,
      Zplus_mod_idemp_l.
    simpl; entailer!.
    apply Z_mod_lt; omega. }
  forward.
  Exists e v; unfold lqueue; simpl; entailer!; auto.
  rewrite Znth_head; auto; rewrite Zlength_cons, Zlength_map; omega.
  { split; try omega.
    transitivity MAX; [omega | unfold MAX; computable]. }
Qed.

Lemma body_q_tryremove : semax_body Vprog Gprog f_q_tryremove q_tryremove_spec.
Proof.
  unfold q_tryremove_spec, q_tryremove_spec'; start_function.
  destruct Q as (t, (P, h)).
  unfold lqueue; rewrite lock_inv_isptr; Intros.
  forward.
  forward_call (lock, sh, q_lock_pred t P p lock gsh2).
  unfold q_lock_pred at 2; unfold q_lock_pred'; Intros vals head addc remc h'.
  forward.
  rewrite data_at_isptr; Intros; rewrite isptr_offset_val_zero; auto.
  forward.
  forward_if (PROP (Zlength vals <> 0)
   LOCAL (temp _len (vint (Zlength vals)); temp _q p; temp _l lock; temp _tgt p)
   SEP (lock_inv sh lock (q_lock_pred t P p lock gsh2);
   data_at Tsh tqueue
     (rotate (complete MAX (map fst vals)) head MAX,
     (vint (Zlength vals), (vint head, (vint ((head + Zlength vals) mod MAX), (addc, remc))))) p;
   cond_var Tsh addc; cond_var Tsh remc; malloc_token Tsh (sizeof tqueue_t) p;
   malloc_token Tsh (sizeof tcond) addc; malloc_token Tsh (sizeof tcond) remc;
   malloc_token Tsh (sizeof tlock) lock; ghost gsh2 (Tsh, h') p;
   fold_right sepcon emp (map (fun x => let '(p, v) := x in
     !!(P v) && (data_at Tsh t v p * malloc_token Tsh (sizeof t) p)) vals);
   field_at sh tqueue_t [StructField _lock] lock p; ghost gsh1 (sh, h) p)).
  { forward_call (lock, sh, q_lock_pred t P p lock gsh2).
    { simpl; lock_props.
      unfold q_lock_pred, q_lock_pred'; Exists vals head addc remc h'; simpl; entailer!. }
    forward.
    Exists (vint 0); entailer!.
    destruct (Memory.EqDec_val (vint 0) nullval); [|contradiction n; auto].
    unfold lqueue; simpl; entailer!. }
  { forward.
    entailer!.
    congruence. }
  Intros.
  assert (Zlength vals > 0).
  { rewrite Zlength_correct in *.
    destruct (length vals); [omega | rewrite Nat2Z.inj_succ; omega]. }
  evar (R : mpred).
  replace_SEP 9 (!!(Forall isptr (map fst vals)) && R); subst R.
  { go_lower; apply prop_and_same_derives, all_ptrs. }
  forward.
  forward.
  { go_lower; Intros.
    rewrite Znth_head; try rewrite Zlength_map; try omega.
    repeat apply andp_right; apply prop_right; auto.
    apply Forall_Znth; [rewrite Zlength_map; omega|].
    eapply Forall_impl; [|eauto].
    destruct a; auto. }
  forward.
  forward.
  { go_lower; simpl.
    repeat apply andp_right; apply prop_right; auto.
    rewrite andb_false_intro2; simpl; auto. }
  forward.
  rewrite cond_var_isptr; Intros.
  forward.
  freeze [0; 1; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12] FR; forward_call (addc, Tsh).
  thaw FR.
  rewrite upd_rotate; try rewrite Zlength_complete; try rewrite Zlength_map; auto.
  rewrite Zminus_diag, Zmod_0_l.
  destruct vals; [rewrite Zlength_nil in *; omega|].
  rewrite Zlength_cons in *.
  simpl; rewrite rotate_1; try rewrite Zlength_map; try omega.
  unfold sem_mod; simpl sem_binarith.
  unfold both_int; simpl force_val.
  rewrite andb_false_intro2; [|simpl; auto].
  simpl force_val.
  rewrite !add_repr, mods_repr; try computable.
  destruct p0 as (e, v).
  exploit (consistent_cons_rem(t := reptype t)); eauto; intro.
  gather_SEP 8 11.
  rewrite sepcon_comm; replace_SEP 0 (!!(list_incl h h') && ghost Tsh (Tsh, h') p).
  { go_lower.
    eapply derives_trans; [apply prop_and_same_derives, ghost_inj|].
    Intros; rewrite ghost_share_join; auto; entailer!. }
  Intros; apply hist_add with (e0 := QRem e v); [eauto|].
  erewrite <- ghost_share_join with (h1 := h ++ [QRem e v])(sh := sh); try eassumption; try apply list_incl_app;
    auto.
  forward_call (lock, sh, q_lock_pred t P p lock gsh2).
  { lock_props.
    unfold q_lock_pred, q_lock_pred'; Exists vals ((head + 1) mod MAX) addc remc (h' ++ [QRem e v]).
    unfold Z.succ; rewrite sub_repr, Z.add_simpl_r, (Z.add_comm (Zlength vals)), Z.add_assoc,
      Zplus_mod_idemp_l.
    simpl; entailer!.
    apply Z_mod_lt; omega. }
  forward.
  Exists e; entailer!.
  { rewrite Znth_head; auto; rewrite Zlength_cons, Zlength_map; omega. }
  destruct (Memory.EqDec_val e nullval).
  { rewrite data_at_isptr; Intros.
    subst; contradiction. }
  Exists v; unfold lqueue; simpl; entailer!; auto.
  { split; try omega.
    transitivity MAX; [omega | unfold MAX; computable]. }
Qed.

Definition extlink := ext_link_prog prog.

Definition Espec := add_funspecs (Concurrent_Espec unit _ extlink) extlink Gprog.
Existing Instance Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_exit.
semax_func_cons body_free.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
repeat semax_func_cons_ext.
semax_func_cons body_surely_malloc.
semax_func_cons body_q_new.
semax_func_cons body_q_del.
semax_func_cons body_q_add.
semax_func_cons body_q_tryremove.
semax_func_cons body_q_remove.
Qed.


Require Import
        List.

Require Import
        Events
        LibModel
        Maps
        Messages
        States
        Types.

Require Import
        ERC20.

(** Tier definition *)
Definition TIER1 : uint := 3.
Definition TIER2 : uint := 2.
Definition TIER3 : uint := 1.
Definition TIER4 : uint := 0.

(** * Constants *)
Definition BURN_BASE_PERCENTAGE : uint := 100 * 10. (* 100% *)
(* Cost of upgrading the tier level of a token in a percentage of the total LRC supply *)
Definition TIER_UPGRADE_COST_PERCENTAGE : uint := 5. (* 0.5% *)
(* Burn rates *)
Definition BURN_MATCHING_TIER1 : uint := 5 * 10. (* 5% *)
Definition BURN_MATCHING_TIER2 : uint := 20 * 10. (* 20% *)
Definition BURN_MATCHING_TIER3 : uint := 40 * 10. (* 40% *)
Definition BURN_MATCHING_TIER4 : uint := 60 * 10. (* 60% *)
(* P2P *)
Definition BURN_P2P_TIER1 : uint := 5. (* 0.5% *)
Definition BURN_P2P_TIER2 : uint := 2 * 10. (* 2% *)
Definition BURN_P2P_TIER3 : uint := 3 * 10. (* 3% *)
Definition BURN_P2P_TIER4 : uint := 6 * 10. (* 6% *)

(* Defining 0x10000 in nat causes stack overflow... *)
Parameter x10000 : uint.

Parameter YEAR_TO_SECONDS : uint.

(** Here I assumed the BurnRateTable is constructed using correct LRC and WETH addresses *)
(* LRC address, WETH address *)
Parameter lrcAddress : address.
Parameter wethAddress : address.

(** * Auxiliary definitions *)

(** It seems the [BurnRateTableState] should be added to WorldState. *)
Definition get_state (wst : WorldState) : BurnRateTableState :=
  wst_burn_rate_table_state wst.

Definition set_state : WorldState -> BurnRateTableState -> WorldState :=
  wst_update_burn_rate_table.

Definition this : WorldState -> address := wst_burn_rate_table_addr.

(** * Method call specs *)

Section getTokenTier_SPEC.

  Variable (sender: address).
  Variable (token: address).

  (* function body:
     function getTokenTier(
        address token
        )
        public
        view
        returns (uint tier)
    {
        TokenData storage tokenData = tokens[token];
        // Fall back to lowest tier
        tier = (now > tokenData.validUntil) ? TIER_4 : tokenData.tier;
    }
   *)

  Definition getTIER (wst: WorldState) : uint :=
    let tokens := (burnratetable_tokens (get_state wst)) in
    let data := TokenDataMap.get tokens token in
    if Nat.ltb data.(validUntil) (block_timestamp (wst_block_state wst))
    then TIER4
    else data.(tier).

  Definition getTokenTier_require : WorldState -> Prop := fun _ => True.

  Inductive getTokenTier_trans : WorldState -> WorldState -> RetVal -> Prop :=
  | getTokenTierTrans: forall wst, getTokenTier_trans wst wst (RetUint (getTIER wst)).

  Inductive getTokenTier_events : WorldState -> list Event -> Prop :=
  | getTokenTierEvents: forall wst, getTokenTier_events wst nil.

  Definition getTokenTier_spec : FSpec :=
    mk_fspec getTokenTier_require getTokenTier_trans getTokenTier_events.

End getTokenTier_SPEC.

Section getBurnRate_SPEC.
  Variable (sender: address).
  Variable (token: address).

  (* function body:
     function getBurnRate(
        address token
        )
        external
        view
        returns (uint32 burnRate)
    {
        uint tier = getTokenTier(token);
        if (tier == TIER_1) {
            burnRate = uint32(BURN_P2P_TIER1) * 0x10000 + BURN_MATCHING_TIER1;
        } else if (tier == TIER_2) {
            burnRate = uint32(BURN_P2P_TIER2) * 0x10000 + BURN_MATCHING_TIER2;
        } else if (tier == TIER_3) {
            burnRate = uint32(BURN_P2P_TIER3) * 0x10000 + BURN_MATCHING_TIER3;
        } else {
            burnRate = uint32(BURN_P2P_TIER4) * 0x10000 + BURN_MATCHING_TIER4;
        }
    }
   *)
  Definition getRate (TIER: uint) : uint :=
    match TIER with
    (* TIER 4 *)
    | O => BURN_P2P_TIER4 * x10000 + BURN_MATCHING_TIER4
    (* TIER 3 *)
    | S O => BURN_P2P_TIER3 * x10000 + BURN_MATCHING_TIER3
    (* TIER 2 *)
    | S (S O) => BURN_P2P_TIER2 * x10000 + BURN_MATCHING_TIER2
    (* TIER 1 *)
    | S (S (S O)) => BURN_P2P_TIER1 * x10000 + BURN_MATCHING_TIER1
    (* other cases *)
    | _ => BURN_P2P_TIER4 * x10000 + BURN_MATCHING_TIER4
    end.

  Definition getBurnRate_require : WorldState -> Prop := fun _ => True.

  Inductive getBurnRate_trans : WorldState -> WorldState -> RetVal -> Prop :=
  | getBurnRateTrans: forall wst,
      getBurnRate_trans wst wst (RetUint (getRate (getTIER token wst))).

  Inductive getBurnRate_events : WorldState -> list Event -> Prop :=
  | getBurnRateEvents: forall wst, getBurnRate_events wst nil.

  Definition getBurnRate_spec : FSpec :=
    mk_fspec getBurnRate_require getBurnRate_trans getBurnRate_events.

End getBurnRate_SPEC.

Section upgradeTokenTier_SPEC.

  Variable (sender: address).
  Variable (token: address).
  (* function body
     function upgradeTokenTier(
        address token
        )
        external
        returns (bool)
    {
        require(token != 0x0, ZERO_ADDRESS);
        require(token != lrcAddress, BURN_RATE_FROZEN);
        require(token != wethAddress, BURN_RATE_FROZEN);

        uint currentTier = getTokenTier(token);

        // Can't upgrade to a higher level than tier 1
        require(currentTier != TIER_1, BURN_RATE_MINIMIZED);

        // Burn TIER_UPGRADE_COST_PERCENTAGE of total LRC supply
        BurnableERC20 LRC = BurnableERC20(lrcAddress);
        uint totalSupply = LRC.totalSupply();
        uint amount = totalSupply.mul(TIER_UPGRADE_COST_PERCENTAGE) / BURN_BASE_PERCENTAGE;
        bool success = LRC.burnFrom(msg.sender, amount);
        require(success, BURN_FAILURE);

        // Upgrade tier
        TokenData storage tokenData = tokens[token];
        tokenData.validUntil = now.add(2 * YEAR_TO_SECONDS);
        tokenData.tier = currentTier + 1;

        emit TokenTierUpgraded(token, tokenData.tier);

        return true;
    }
   *)

  Definition burnamount (totalSupply: uint) : uint :=
    Nat.div (totalSupply * TIER_UPGRADE_COST_PERCENTAGE) BURN_BASE_PERCENTAGE.

  Definition upgradetier (wst: WorldState) : WorldState * uint :=
    let tokens := burnratetable_tokens (get_state wst) in
    let data := TokenDataMap.get tokens token in
    let NOW := (block_timestamp (wst_block_state wst)) in
    let data' := mk_token_data (data.(tier) + 1) (NOW + 2 * YEAR_TO_SECONDS) in
    let tokens' := TokenDataMap.upd tokens token data' in
    (set_state wst (mk_burn_rate_table_state tokens'), data.(tier) + 1) .

  Definition upgradeTokenTier_require (wst: WorldState) : Prop :=
    exists totalSupply wst' evts,
      token <> 0
      /\ token <> lrcAddress
      /\ token <> wethAddress
      /\ getTIER token wst <> TIER1
      /\ ERC20s.model wst (msg_totalSupply sender lrcAddress)
                     wst (RetUint totalSupply) nil
      /\ ERC20s.model wst (msg_burnFrom (this wst) lrcAddress sender (burnamount totalSupply))
                     wst' (RetBool true) evts.

  Inductive upgradeTokenTier_trans (wst : WorldState) : WorldState -> RetVal -> Prop :=
  | upgradeTokenTier_TRANS: forall totalSupply wst' evts TIER wst'' ,
      ERC20s.model wst (msg_totalSupply sender lrcAddress)
                   wst (RetUint totalSupply) nil ->
      ERC20s.model wst (msg_burnFrom (this wst) lrcAddress sender (burnamount totalSupply))
                   wst' (RetBool true) evts ->
      upgradetier wst' = (wst'', TIER) ->
      upgradeTokenTier_trans wst wst'' (RetBool true).

  Inductive upgradeTokenTier_events (wst : WorldState) : list Event -> Prop :=
  | upgradeTokenTier_EVENTS: forall totalSupply wst' evts TIER wst'' ,
      ERC20s.model wst (msg_totalSupply sender lrcAddress)
                   wst (RetUint totalSupply) nil ->
      ERC20s.model wst (msg_burnFrom (this wst) lrcAddress sender (burnamount totalSupply))
                   wst' (RetBool true) evts ->
      upgradetier wst' = (wst'', TIER) ->
      upgradeTokenTier_events wst (evts ++ EvtTokenTierUpgraded token TIER :: nil).

  Definition upgradeTokenTier_spec : FSpec :=
    mk_fspec upgradeTokenTier_require upgradeTokenTier_trans upgradeTokenTier_events.

End upgradeTokenTier_SPEC.

Definition get_spec (msg: BurnRateTableMsg) : FSpec :=
  match msg with
  | msg_getBurnRate sender token => getBurnRate_spec token
  | msg_getTokenTier sender token => getTokenTier_spec token
  | msg_upgradeTokenTier sender token => upgradeTokenTier_spec sender token
  end.

Definition model
           (wst: WorldState)
           (msg: BurnRateTableMsg)
           (wst': WorldState)
           (retval: RetVal)
           (events: list Event)
  : Prop :=
  fspec_sat (get_spec msg) wst wst' retval events.