Require Import Coq.Sets.Ensembles.
Require Import Coq.micromega.Lia.
Require Import VST.concurrency.conclib.
Require Import VST.floyd.library.
Require Import bst.puretree.
Require Import bst.bst_conc_cglock.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_tree := Tstruct _tree noattr.
Definition t_struct_tree_t := Tstruct _tree_t noattr.

Lemma unfold_data_at_tree: forall p k (v pa pb: val),
      data_at Ews t_struct_tree (vint k, (v, (pa, pb))) p =
        field_at Ews t_struct_tree (DOT _key) (vint k) p *
          spacer Ews 4 8 p *
          field_at Ews t_struct_tree (DOT _value) v p *
          field_at Ews t_struct_tree (DOT _left) pa p *
          field_at Ews t_struct_tree (DOT _right) pb p.
Proof. intros. apply pred_ext; unfold_data_at (data_at _ _ _ _); cancel. Qed.

(** TODO For some unknow reason, the tactic "unfold_data_at" does not
    work as expected after importing general_locks. So I have to prove
    the helper lemma above before general_locks. *)

Require Import VST.atomics.general_locks.
Import puretree.

Fixpoint tree_rep (t: tree val) (p: val): mpred :=
 match t with
 | E => !!(p=nullval) && emp
 | T a x v b => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
   EX pa:val, EX pb:val,
                    malloc_token Ews t_struct_tree p *
                    data_at Ews t_struct_tree (Vint (Int.repr x),(v,(pa,pb))) p *
                    tree_rep a pa * tree_rep b pb
 end.

Instance tree_ghost: Ghost := discrete_PCM (tree val).

Notation tree_info := (@G tree_ghost).

Definition treebox_rep (t: tree val) (b: val) :=
  EX p: val, data_at Ews (tptr t_struct_tree) p b * tree_rep t p.

Definition node_lock_inv g lock np :=
  (EX tr, my_half g Tsh tr *
          treebox_rep tr (field_address t_struct_tree_t [StructField _t] np)) *
  malloc_token Ews tlock lock * malloc_token Ews t_struct_tree_t np.

Definition nodebox_rep (g : gname)
           (sh : share) (lock : val) (nb: val) :=
  EX np: val,
     data_at sh (tptr t_struct_tree_t) np nb *
     field_at sh t_struct_tree_t [StructField _lock] lock np *
     lock_inv sh lock (node_lock_inv g lock np).

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
  WITH t:type, gv: globals
  PRE [ size_t ]
    PROP (0 <= sizeof t <= Int.max_unsigned;
          complete_legal_cosu_type t = true;
          natural_aligned natural_alignment t = true)
    PARAMS (Vptrofs (Ptrofs.repr (sizeof t))) GLOBALS (gv)
    SEP (mem_mgr gv)
  POST [ tptr tvoid ] EX p:_,
    PROP ()
    LOCAL (temp ret_temp p)
    SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Program Definition lookup_spec :=
  DECLARE _lookup
  ATOMIC TYPE (rmaps.ConstType (val * share * val * Z * globals * gname))
  OBJ BST INVS base.empty base.top
  WITH b, sh, lock, x, gv, g
  PRE [tptr (tptr t_struct_tree_t), tint]
   PROP (readable_share sh; Int.min_signed <= x <= Int.max_signed)
   PARAMS (b; Vint (Int.repr x)) GLOBALS (gv)
   SEP (mem_mgr gv; nodebox_rep g sh lock b) |
        (!! sorted_tree BST && public_half g BST)
  POST [tptr Tvoid]
   EX ret: val,
   PROP ()
   LOCAL (temp ret_temp ret)
   SEP (mem_mgr gv; nodebox_rep g sh lock b) |
         (!! (sorted_tree BST /\ ret = lookup nullval x BST) && public_half g BST).

Program Definition insert_spec :=
  DECLARE _insert
  ATOMIC TYPE (rmaps.ConstType (val * share * val * Z * val * globals * gname))
  OBJ BST INVS base.empty base.top
  WITH b, sh, lock, x, v, gv, g
  PRE [tptr (tptr t_struct_tree_t), tint, tptr tvoid]
   PROP (readable_share sh; Int.min_signed <= x <= Int.max_signed;
        is_pointer_or_null v)
   PARAMS (b; Vint (Int.repr x); v) GLOBALS (gv)
   SEP (mem_mgr gv; nodebox_rep g sh lock b) |
        (!! sorted_tree BST && public_half g BST)
  POST [tvoid]
   PROP ()
   LOCAL ()
   SEP (mem_mgr gv; nodebox_rep g sh lock b) |
        (!! sorted_tree (insert x v BST) && public_half g (insert x v BST)).

Definition turn_left_spec :=
 DECLARE _turn_left
  WITH ta: tree val, x: Z, vx: val, tb: tree val, y: Z, vy: val,
              tc: tree val, b: val, l: val, pa: val, r: val
  PRE  [ tptr (tptr t_struct_tree),
         tptr t_struct_tree,
         tptr t_struct_tree]
    PROP (Int.min_signed <= x <= Int.max_signed; is_pointer_or_null vx)
    PARAMS ( b; l; r) GLOBALS ()
    SEP (data_at Ews (tptr t_struct_tree) l b;
         data_at Ews t_struct_tree (Vint (Int.repr x), (vx, (pa, r))) l;
         malloc_token Ews t_struct_tree l; tree_rep ta pa; tree_rep (T tb y vy tc) r)
  POST [ Tvoid ]
    EX pc: val,
    PROP (Int.min_signed <= y <= Int.max_signed; is_pointer_or_null vy)
    LOCAL()
    SEP (data_at Ews (tptr t_struct_tree) r b;
         data_at Ews t_struct_tree (Vint (Int.repr y), (vy, (l, pc))) r;
         malloc_token Ews t_struct_tree r; tree_rep (T ta x vx tb) l; tree_rep tc pc).

Definition pushdown_left_spec :=
 DECLARE _pushdown_left
  WITH ta: tree val, x: Z, v: val, tb: tree val, b: val, p: val, gv: globals
  PRE  [ tptr (tptr (t_struct_tree)) ]
    PROP(Int.min_signed <= x <= Int.max_signed; tc_val (tptr Tvoid) v)
    PARAMS ( b ) GLOBALS (gv)
    SEP (mem_mgr gv; data_at Ews (tptr t_struct_tree) p b;
         malloc_token Ews t_struct_tree p;
         spacer Ews 4 8 p;
         field_at Ews t_struct_tree [StructField _key] (Vint (Int.repr x)) p;
         field_at Ews t_struct_tree [StructField _value] v p;
         treebox_rep ta (field_address t_struct_tree [StructField _left] p);
         treebox_rep tb (field_address t_struct_tree [StructField _right] p))
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (mem_mgr gv; treebox_rep (pushdown_left ta tb) b).

Program Definition delete_spec :=
 DECLARE _delete
 ATOMIC TYPE (rmaps.ConstType (_ * _ * _ * _ * _ * _))
         OBJ BST INVS base.empty base.top
 WITH b, x, lock, gv, sh, g
 PRE  [ tptr (tptr t_struct_tree_t), tint]
    PROP (Int.min_signed <= x <= Int.max_signed; readable_share sh)
    PARAMS ( b; Vint (Int.repr x)) GLOBALS (gv)
    SEP (mem_mgr gv; nodebox_rep g sh lock b) |
        (!!(sorted_tree BST) && public_half g BST)
  POST [ Tvoid ]
    PROP ()
    LOCAL ()
    SEP (mem_mgr gv; nodebox_rep g sh lock b) |
        (!!(sorted_tree (delete x BST)) && public_half g (delete x BST)).

Definition treebox_new_spec :=
  DECLARE _treebox_new
  WITH gv: globals
  PRE  [  ]
    PROP () PARAMS () GLOBALS (gv) SEP (mem_mgr gv)
  POST [ tptr (tptr t_struct_tree_t) ]
    EX v:val, EX lock:val, EX g:gname,
    PROP ()
    LOCAL (temp ret_temp v)
    SEP (mem_mgr gv; nodebox_rep g Ews lock v;
        malloc_token Ews (tptr t_struct_tree_t) v;
        public_half g E).

Definition tree_free_spec :=
 DECLARE _tree_free
  WITH t: tree val, p: val, gv: globals
  PRE  [ tptr t_struct_tree ]
       PROP() PARAMS ( p ) GLOBALS (gv) SEP (mem_mgr gv; tree_rep t p)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (mem_mgr gv).

Definition treebox_free_spec :=
 DECLARE _treebox_free
  WITH lock: val, b: val, gv: globals, g: gname
  PRE  [ tptr (tptr t_struct_tree_t) ]
       PROP()
       PARAMS (b) GLOBALS (gv)
       SEP (mem_mgr gv; nodebox_rep g Ews lock b;
           malloc_token Ews (tptr t_struct_tree_t) b)
  POST [ Tvoid ]
    PROP()
    LOCAL()
    SEP (mem_mgr gv).

Definition tree_inv g g1 g2 :=
  EX (b: bool) (v: val) (l1 l2 : list (key * val)),
  ghost_var gsh1 (b, v) g1 * ghost_var gsh1 (l1 ++ l2) g2 *
  public_half g (insert_seq_opt b v l1 l2).

Definition thread_lock_R sh lock g g1 b (gv: globals) :=
  ghost_var gsh2 (true, (gv ___stringlit_1)) g1 * mem_mgr gv *
  data_at sh (tptr (tptr (t_struct_tree_t))) b (gv _tb) *
  data_at Ers (tarray tschar 16)
          (map (Vint oo cast_int_int I8 Signed)
               [Int.repr 79; Int.repr 78; Int.repr 69;
               Int.repr 95; Int.repr 70; Int.repr 82;
               Int.repr 79; Int.repr 77; Int.repr 95;
               Int.repr 84; Int.repr 72; Int.repr 82;
               Int.repr 69; Int.repr 65; Int.repr 68;
               Int.repr 0]) (gv ___stringlit_1) * nodebox_rep g sh lock b.

Definition thread_lock_inv sh lock g g1 b gv lockt :=
  selflock (thread_lock_R sh lock g g1 b gv) sh lockt.

Definition thread_func_spec :=
 DECLARE _thread_func
  WITH y : val, x : iname * gname * gname * gname * share * val * val * globals * invG
    PRE [ tptr tvoid ]
         let '(i, g1, g2, g, sh, lock, b, gv, inv_names) := x in
         PROP  (readable_share sh)
         PARAMS ( y ) GLOBALS (gv)
         SEP   (invariant i (tree_inv g g1 g2); ghost_var gsh2 (false, nullval) g1;
               mem_mgr gv; data_at sh (tptr (tptr (t_struct_tree_t))) b (gv _tb);
               data_at Ers (tarray tschar 16)
                       (map (Vint oo cast_int_int I8 Signed)
                            [Int.repr 79; Int.repr 78; Int.repr 69;
                            Int.repr 95; Int.repr 70; Int.repr 82;
                            Int.repr 79; Int.repr 77; Int.repr 95;
                            Int.repr 84; Int.repr 72; Int.repr 82;
                            Int.repr 69; Int.repr 65; Int.repr 68;
                            Int.repr 0]) (gv ___stringlit_1);
               nodebox_rep g sh lock b;
               lock_inv sh (gv _thread_lock)
                        (thread_lock_inv sh lock g g1 b gv (gv _thread_lock)))
  POST [ tptr tvoid ]
         PROP ()
         LOCAL ()
         SEP ().

Definition main_spec :=
  DECLARE _main
          WITH gv : globals
                      PRE  [] main_pre prog tt gv
                      POST [ tint ] main_post prog gv.

Definition acquire_spec := DECLARE _acquire acquire_spec.
Definition release_spec := DECLARE _release release_spec.
Definition release2_spec := DECLARE _release2 release2_spec.
Definition makelock_spec := DECLARE _makelock (makelock_spec _).
Definition freelock_spec := DECLARE _freelock (freelock_spec _).
Definition freelock2_spec := DECLARE _freelock2 (freelock2_spec _).
Definition spawn_spec := DECLARE _spawn spawn_spec.

Definition Gprog : funspecs :=
  ltac:(with_library prog [acquire_spec; release_spec; makelock_spec;
                          freelock2_spec; freelock_spec; release2_spec;
                          surely_malloc_spec;
                          lookup_spec; insert_spec;
                          turn_left_spec; pushdown_left_spec; delete_spec;
                          treebox_new_spec; tree_free_spec; treebox_free_spec;
                          spawn_spec; thread_func_spec; main_spec]).

Lemma field_at_value_eq : forall {cs : compspecs} sh1 sh2 t gfs v1 v2 p,
  readable_share sh1 -> readable_share sh2 ->
  repinject (nested_field_type t gfs) v1 <> Vundef ->
  repinject (nested_field_type t gfs) v2 <> Vundef ->
  type_is_by_value (nested_field_type t gfs) = true ->
  type_is_volatile (nested_field_type t gfs) = false ->
  field_at sh1 t gfs v1 p * field_at sh2 t gfs v2 p |-- !!(v1 = v2).
Proof.
  intros; unfold field_at, at_offset; Intros.
  rewrite !by_value_data_at_rec_nonvolatile; auto.
  sep_apply mapsto_value_eq; Intros; apply prop_right.
  set (t' := nested_field_type t gfs) in *.
  pose proof (f_equal (valinject t') H6) as Heq.
  rewrite !valinject_repinject in Heq; auto.
Qed.

Lemma data_at_value_eq : forall {cs : compspecs} sh1 sh2 t v1 v2 p,
  readable_share sh1 -> readable_share sh2 ->
  repinject t v1 <> Vundef -> repinject t v2 <> Vundef ->
  type_is_by_value t = true -> type_is_volatile t = false ->
  data_at sh1 t v1 p * data_at sh2 t v2 p |-- !!(v1 = v2).
Proof. intros; unfold data_at; apply field_at_value_eq; auto. Qed.

Lemma nodebox_rep_share_join : forall g (sh1 sh2 sh : share) (lock : val) (nb : val),
    readable_share sh1 -> readable_share sh2 -> sepalg.join sh1 sh2 sh ->
    nodebox_rep g sh1 lock nb * nodebox_rep g sh2 lock nb = nodebox_rep g sh lock nb.
Proof.
  intros. unfold nodebox_rep. apply pred_ext.
  - Intros np1 np2. assert_PROP (np1 <> Vundef) by entailer!.
    assert_PROP (np2 <> Vundef) by entailer!.
    sep_apply data_at_value_eq; Intros; subst. Exists np2.
    rewrite <- (data_at_share_join sh1 sh2 sh), <- (field_at_share_join sh1 sh2 sh),
    <- (lock_inv_share_join sh1 sh2 sh); auto. cancel.
  - Intros np; Exists np np.
    rewrite <- (data_at_share_join sh1 sh2 sh), <- (field_at_share_join sh1 sh2 sh),
    <- (lock_inv_share_join sh1 sh2 sh); auto. cancel.
Qed.

Lemma tree_rep_saturate_local:
   forall t p, tree_rep t p |-- !! is_pointer_or_null p.
Proof. destruct t; simpl; intros. entailer!. Intros pa pb. entailer!. Qed.
Hint Resolve tree_rep_saturate_local: saturate_local.

Lemma tree_rep_valid_pointer:
  forall t p, tree_rep t p |-- valid_pointer p.
Proof. intros. destruct t; simpl; normalize; auto with valid_pointer. Qed.
Hint Resolve tree_rep_valid_pointer: valid_pointer.

Lemma if_trueb: forall {A: Type} b (a1 a2: A), b = true -> (if b then a1 else a2) = a1.
Proof. intros; subst; auto. Qed.

Lemma if_falseb: forall {A: Type} b (a1 a2: A), b = false -> (if b then a1 else a2) = a2.
Proof. intros; subst; auto. Qed.

Lemma node_lock_exclusive : forall g lock np,
    exclusive_mpred (node_lock_inv g lock np).
Proof.
  intros. unfold node_lock_inv. unfold exclusive_mpred. unfold treebox_rep.
  Intros tr1 tr2 tp1 tp2. sep_apply field_at_conflict; auto.
  rewrite sepcon_comm. rewrite sepcon_FF. auto.
Qed.
Hint Resolve node_lock_exclusive.

Lemma tree_rep_nullval: forall t, tree_rep t nullval |-- !! (t = E).
Proof.
  intros. destruct t; [entailer! |].
  simpl tree_rep. Intros pa pb. entailer!.
Qed.
Hint Resolve tree_rep_nullval: saturate_local.

Lemma treebox_rep_spec: forall (t: tree val) (b: val),
  treebox_rep t b =
  EX p: val,
  match t with
  | E => !!(p=nullval) && data_at Ews (tptr t_struct_tree) p b
  | T l x v r => !! (Int.min_signed <= x <= Int.max_signed /\ tc_val (tptr Tvoid) v) &&
      data_at Ews (tptr t_struct_tree) p b * malloc_token Ews t_struct_tree p *
      spacer Ews 4 8 p *
      field_at Ews t_struct_tree [StructField _key] (Vint (Int.repr x)) p *
      field_at Ews t_struct_tree [StructField _value] v p *
      treebox_rep l (field_address t_struct_tree [StructField _left] p) *
      treebox_rep r (field_address t_struct_tree [StructField _right] p)
  end.
Proof.
  intros.
  unfold treebox_rep at 1. f_equal. extensionality p.
  destruct t; simpl.
  - apply pred_ext; entailer!.
  - unfold treebox_rep. apply pred_ext; entailer!.
    + Intros pa pb. Exists pb pa. rewrite unfold_data_at_tree.
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]). cancel.
    + Intros pa pb. Exists pb pa. rewrite unfold_data_at_tree.
      rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
      rewrite (field_at_data_at _ t_struct_tree [StructField _right]). cancel.
Qed.

Lemma bst_left_entail: forall (t1 t1' t2: tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Ews (tptr t_struct_tree) p b * malloc_token Ews t_struct_tree p *
  data_at Ews t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t1 (field_address t_struct_tree [StructField _left] p) *
       (treebox_rep t1'
         (field_address t_struct_tree [StructField _left] p) -*
        treebox_rep (T t1' k v t2) b).
Proof.
  intros.
  rewrite unfold_data_at_tree.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  unfold treebox_rep at 1. Exists p1. cancel.
  rewrite <- wand_sepcon_adjoint.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p'.
  Exists p' p2.
  entailer!.
  rewrite unfold_data_at_tree.
  rewrite (field_at_data_at _ t_struct_tree [StructField _left]).
  cancel.
Qed.

Lemma bst_right_entail: forall (t1 t2 t2': tree val) k (v p1 p2 p b: val),
  Int.min_signed <= k <= Int.max_signed ->
  is_pointer_or_null v ->
  data_at Ews (tptr t_struct_tree) p b * malloc_token Ews t_struct_tree p *
  data_at Ews t_struct_tree (Vint (Int.repr k), (v, (p1, p2))) p *
  tree_rep t1 p1 * tree_rep t2 p2
  |-- treebox_rep t2 (field_address t_struct_tree [StructField _right] p) *
       (treebox_rep t2'
         (field_address t_struct_tree [StructField _right] p) -*
        treebox_rep (T t1 k v t2') b).
Proof.
  intros.
  rewrite unfold_data_at_tree.
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  unfold treebox_rep at 1. Exists p2. cancel.
  rewrite <- wand_sepcon_adjoint.
  clear p2.
  unfold treebox_rep.
  Exists p.
  simpl.
  Intros p2.
  Exists p1 p2.
  entailer!.
  rewrite unfold_data_at_tree.
  rewrite (field_at_data_at _ t_struct_tree [StructField _right]).
  cancel.
Qed.

Lemma insert_tree_inv_shift1: forall {inv_names : invG} i g g1 g2 l k v,
    invariant i (tree_inv g g1 g2) *
    ghost_var gsh2 l g2 |--
              atomic_shift (λ BST : tree val,
                              !! sorted_tree BST && public_half g BST) ∅ ⊤
              (λ (BST : tree val) (_ : ()),
               fold_right_sepcon
                 [!! sorted_tree (insert k v BST) && public_half g (insert k v BST)])
              (λ _ : (), ghost_var gsh2 (l ++ [(k, v)]) g2).
Proof.
  intros; apply inv_atomic_shift; auto. 1: apply empty_subseteq.
  unfold tree_inv. iIntros "t". iDestruct "t" as (b) ">t".
  iDestruct "t" as (v0) "t". iDestruct "t" as (l1 l2) "[[g1 g2] t]". iModIntro.
  iExists (insert_seq_opt b v0 l1 l2). rewrite sepcon_comm sepcon_andp_prop. iSplit.
  - iApply (prop_right with "t"). apply insert_seq_opt_sorted.
  - iFrame. iSplit.
    + iIntros "[% c] !>". iExists b, v0, l1, l2. iModIntro. iFrame.
    + iIntros (_) "(>g & [% c] & _)".
      iPoseProof (ghost_var_inj (A := list (key * val)) with "[$g2 $g]") as "%";
        auto with share; subst l.
      iMod (ghost_var_update with "[g2 g]") as "g2". {
        rewrite <- (ghost_var_share_join gsh1 gsh2 Tsh) by auto with share; iFrame. }
      rewrite <- (ghost_var_share_join gsh1 gsh2 Tsh) by auto with share.
      iDestruct "g2" as "[g2 $]".
      iExists b, v0, l1, (l2 ++ [(k, v)]). iModIntro. iModIntro.
      rewrite insert_seq_opt_assoc. rewrite <- app_assoc. iFrame.
Qed.

Lemma insert_tree_inv_shift2: forall {inv_names : invG} i g g1 g2 (v1 v2: val),
    invariant i (tree_inv g g1 g2) *
    ghost_var gsh2 (false, v1) g1 |--
              atomic_shift (λ BST : tree val, !! sorted_tree BST && public_half g BST) ∅ ⊤
              (λ (BST : tree val) (_ : ()),
               fold_right_sepcon
                 [!! sorted_tree (insert 1 v2 BST) && public_half g (insert 1 v2 BST)])
              (λ _ : (), ghost_var gsh2 (true, v2) g1).
Proof.
  intros; apply inv_atomic_shift; auto. 1: apply empty_subseteq.
  unfold tree_inv. iIntros "t". iDestruct "t" as (b) ">t".
  iDestruct "t" as (v0) "t". iDestruct "t" as (l1 l2) "[[g1 g2] t]". iModIntro.
  iExists (insert_seq_opt b v0 l1 l2). rewrite sepcon_comm sepcon_andp_prop. iSplit.
  - iApply (prop_right with "t"). apply insert_seq_opt_sorted.
  - iFrame. iSplit.
    + iIntros "[% c] !>". iExists b, v0, l1, l2. iModIntro. iFrame.
    + iIntros (_) "(>g & [% c] & _)".
      iPoseProof (ghost_var_inj (A := (bool * val)) with "[$g1 $g]") as "%";
        auto with share. inv H0.
      iMod (ghost_var_update with "[g1 g]") as "g1". {
        rewrite <- (ghost_var_share_join gsh1 gsh2 Tsh) by auto with share; iFrame. }
      rewrite <- (ghost_var_share_join gsh1 gsh2 Tsh) by auto with share.
      iDestruct "g1" as "[g1 $]".
      iExists true, v2, (l1 ++ l2), nil. iModIntro. iModIntro.
      simpl insert_seq_opt. rewrite insert_seq_assoc app_nil_r. iFrame.
Qed.

Lemma thread_inv_exclusive : forall sh lock g g1 b gv lockt,
    readable_share sh -> exclusive_mpred (thread_lock_inv sh lock g g1 b gv lockt).
Proof.
  intros; apply selflock_exclusive.
  unfold thread_lock_R. apply exclusive_sepcon1. apply exclusive_sepcon1.
  apply exclusive_sepcon2. apply data_at_exclusive; auto. simpl; lia.
Qed.
Hint Resolve thread_inv_exclusive.

Lemma body_thread_func : semax_body Vprog Gprog f_thread_func thread_func_spec.
Proof.
  start_function.
  unfold MORE_COMMANDS. unfold abbreviate.
  forward. (* _l = &_thread_lock; *)
  unfold nodebox_rep.
  Intros np.
  forward. (* _t'1 = _tb; *)
  assert_PROP (is_pointer_or_null (gv ___stringlit_1)) by entailer!.
  assert (Int.min_signed ≤ 1 ∧ 1 ≤ Int.max_signed) by (compute; split; intro; easy).
  forward_call (b, sh, lock, 1, (gv ___stringlit_1), gv, g,
                ghost_var gsh2 (true, gv ___stringlit_1) g1, inv_names). {
    sep_apply (insert_tree_inv_shift2 i g g1 g2 nullval (gv ___stringlit_1)).
    unfold nodebox_rep. Exists np. entailer!. }
  forward_call (gv _thread_lock, sh, thread_lock_R sh lock g g1 b gv,
                thread_lock_inv sh lock g g1 b gv (gv _thread_lock)). {
    lock_props. unfold thread_lock_inv at 2. unfold thread_lock_R.
    rewrite selflock_eq. unfold thread_lock_inv, thread_lock_R. entailer!. }
  forward.
Qed.

Lemma body_main: semax_body Vprog Gprog f_main main_spec.
Proof.
  start_function.
  sep_apply (create_mem_mgr gv).
  rewrite <- (emp_sepcon (mem_mgr _)); Intros.
  viewshift_SEP 0 (EX inv_names : invG, wsat) by (go_lower; apply make_wsat).
  Intros inv_names.
  ghost_alloc (ghost_var Tsh (false, nullval)). Intro g1.
  ghost_alloc (ghost_var Tsh (@nil (key * val))). Intro g2.
  rewrite <- 2 (ghost_var_share_join gsh1 gsh2 Tsh) by auto with share; Intros.
  forward_call (gv). (* _t'1 = _treebox_new([]); *)
  Intros v. destruct v as [[b lock] g]. simpl fst. simpl snd.
  forward. (* _tb = _t'1;   *)
  forward. (* _t_lock = &_thread_lock; *)
  forward. (* _t'6 = _tb; *)
  assert (readable_share Ews) by apply writable_readable, writable_Ews.
  assert_PROP (is_pointer_or_null (gv ___stringlit_2)) by entailer!.
  assert (Int.min_signed ≤ 3 ∧ 3 ≤ Int.max_signed) by (compute; split; intro; easy).
  gather_SEP wsat (ghost_var gsh1 _ g1) (ghost_var gsh1 _ g2) (public_half _ _).
  viewshift_SEP 0 (EX i, |> (wsat * invariant i (tree_inv g g1 g2))). {
    go_lower. rewrite !sepcon_assoc. apply make_inv'. unfold tree_inv.
    Exists false nullval (@nil (key * val)) (@nil (key * val)).
    simpl insert_seq_opt. simpl app. cancel. } Intros i.
  rewrite invariant_dup; Intros.
  forward_call (b, Ews, lock, 3, (gv ___stringlit_2), gv, g,
                ghost_var gsh2 [(3, (gv ___stringlit_2))] g2, inv_names). {
    sep_apply (insert_tree_inv_shift1 i g g1 g2 [] 3 (gv ___stringlit_2)).
    simpl app. apply sepcon_derives; [apply derives_refl | cancel]. }
  forward. (* _t'5 = _tb; *)
  assert_PROP (is_pointer_or_null (gv ___stringlit_3)) by entailer!.
  assert (Int.min_signed ≤ 1 ∧ 1 ≤ Int.max_signed) by (compute; split; intro; easy).
  rewrite invariant_dup; Intros.
  forward_call (b, Ews, lock, 1, (gv ___stringlit_3), gv, g,
                ghost_var gsh2 [(3, (gv ___stringlit_2));
                                (1, (gv ___stringlit_3))] g2, inv_names). {
    sep_apply (insert_tree_inv_shift1 i g g1 g2 [(3, (gv ___stringlit_2))]
                                     1 (gv ___stringlit_3)).
    simpl app. apply sepcon_derives; [apply derives_refl | cancel]. }
  forward. (* _t'4 = _tb;  *)
  assert_PROP (is_pointer_or_null (gv ___stringlit_4)) by entailer!.
  assert (Int.min_signed ≤ 4 ∧ 4 ≤ Int.max_signed) by (compute; split; intro; easy).
  rewrite invariant_dup; Intros.
  forward_call (b, Ews, lock, 4, (gv ___stringlit_4), gv, g,
                ghost_var gsh2 [(3, (gv ___stringlit_2));
                                (1, (gv ___stringlit_3));
                                (4, (gv ___stringlit_4))] g2, inv_names). {
    sep_apply (insert_tree_inv_shift1
                 i g g1 g2 [(3, gv ___stringlit_2); (1, gv ___stringlit_3)]
                 4 (gv ___stringlit_4)).
    simpl app. apply sepcon_derives; [apply derives_refl | cancel]. }
  destruct split_Ews as (sh1 & sh2 & ? & ? & Hsh).
  forward_call (gv _thread_lock, Ews,
                thread_lock_inv sh1 lock g g1 b gv (gv _thread_lock)).
  rewrite invariant_dup; Intros.
  forward_spawn _thread_func nullval (i, g1, g2, g, sh1, lock, b, gv, inv_names). {
    rewrite <- (lock_inv_share_join sh1 sh2 Ews); auto.
    rewrite <- (data_at_share_join sh1 sh2 Ews); auto.
    rewrite <- (nodebox_rep_share_join g sh1 sh2 Ews); auto. entailer!. }
  forward.
  sep_apply (create_mem_mgr gv).
  assert_PROP (is_pointer_or_null (gv ___stringlit_5)) by entailer!.
  rewrite invariant_dup; Intros.
  forward_call (b, sh2, lock, 1, (gv ___stringlit_5), gv, g,
                ghost_var gsh2 [(3, (gv ___stringlit_2));
                                (1, (gv ___stringlit_3));
                                (4, (gv ___stringlit_4));
                                (1, (gv ___stringlit_5))] g2, inv_names). {
    sep_apply (insert_tree_inv_shift1
                 i g g1 g2 [(3, gv ___stringlit_2); (1, gv ___stringlit_3);
                            (4, gv ___stringlit_4)]
                 1 (gv ___stringlit_5)).
    simpl app. apply sepcon_derives; [apply derives_refl | cancel]. }
  forward_call (gv _thread_lock, sh2,
                thread_lock_inv sh1 lock g g1 b gv (gv _thread_lock)).
  unfold thread_lock_inv at 2. rewrite selflock_eq. Intros.
  forward_call (gv _thread_lock, Ews, sh1, thread_lock_R sh1 lock g g1 b gv,
                thread_lock_inv sh1 lock g g1 b gv (gv _thread_lock)). {
    lock_props. unfold thread_lock_inv.
    rewrite <- (lock_inv_share_join sh1 sh2 Ews); auto. entailer!. }
  unfold thread_lock_R. Intros.
  gather_SEP (nodebox_rep g sh1 _ _) (nodebox_rep g sh2 _ _).
  rewrite (nodebox_rep_share_join g sh1 sh2 Ews lock b); auto.
  gather_SEP (data_at sh1 _ _ _) (data_at sh2 _ _ _).
  rewrite (data_at_share_join sh1 sh2 Ews); auto.
  forward.
  forward_call (lock, b, gv, g).
  forward.
Qed.

Lemma body_treebox_free: semax_body Vprog Gprog f_treebox_free treebox_free_spec.
Proof.
  start_function.
  unfold nodebox_rep.
  Intros np.
  forward.
  forward.
  forward_call (lock, Ews, node_lock_inv g lock np).
  forward_call (lock, Ews, node_lock_inv g lock np). (* _freelock(_l); *)
  - lock_props.
  - unfold node_lock_inv. unfold treebox_rep. Intros tr p.
    change (tptr t_struct_tree) with
        (nested_field_type t_struct_tree_t [StructField _t]).
    rewrite <- field_at_data_at.
    forward. (* _p = (_tgp -> _t); *)
    forward_call (tr, p, gv). (* _tree_free(_p); *)
    gather_SEP (my_half _ _ _).
    viewshift_SEP 0 (emp). { go_lower. apply own_dealloc. }
    forward_call (t_struct_tree_t, np, gv). (* _free(_tgp); *)
    + if_tac; entailer!.
      unfold_data_at_ np.
      unfold_data_at (data_at Ews t_struct_tree_t _ np). cancel.
    + forward_call (tlock, lock, gv). (* _free(_l); *)
      * if_tac; entailer!.
      * forward_call (tptr t_struct_tree_t, b, gv).
        -- if_tac; entailer!.
        -- entailer!.
Qed.

Lemma body_tree_free: semax_body Vprog Gprog f_tree_free tree_free_spec.
Proof.
  start_function.
  forward_if.
  - destruct t; simpl tree_rep. 1: Intros; contradiction.
    Intros pa pb.
    forward.
    forward.
    forward_call (t_struct_tree, p, gv).
    + rewrite if_false; auto. entailer!.
    + forward_call (t1, pa, gv).
      forward_call (t2, pb, gv).
      entailer!.
  - forward. subst.
    sep_apply tree_rep_nullval. Intros. subst. simpl tree_rep. entailer!.
Qed.

Lemma body_treebox_new: semax_body Vprog Gprog f_treebox_new treebox_new_spec.
Proof.
  start_function.
  forward_call (tptr t_struct_tree_t, gv).
  Intros p. (* treebox p *)
  forward_call (t_struct_tree_t, gv).
  Intros newt. (* tree_t *newt *)
  forward.
  forward_call (tarray (tptr tvoid) 2, gv).
  1: vm_compute; split; easy.
  Intros l. (* lock_t *l *)
  ghost_alloc (both_halves E). 1: apply @part_ref_valid.
  Intros g'. rewrite <- both_halves_join.
  forward_call (l, Ews, node_lock_inv g' l newt). Intros.
  forward.
  forward.
  assert_PROP (field_compatible t_struct_tree_t [] newt) by entailer!.
  forward_call (l, Ews, node_lock_inv g' l newt).
  - lock_props.
    unfold node_lock_inv. Exists (@E val).
    unfold_data_at (data_at Ews t_struct_tree_t _ _).
    unfold treebox_rep. Exists nullval.
    change (tptr t_struct_tree) with
        (nested_field_type t_struct_tree_t [StructField _t]).
    rewrite <- field_at_data_at. cancel. unfold tree_rep. entailer!.
  - forward. Exists p l g'. unfold nodebox_rep. Exists newt. entailer!.
Qed.

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (t, gv). Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p)).
  - if_tac. subst p. entailer!. entailer!.
  - forward_call 1. contradiction.
  - if_tac.
    + forward. subst p. congruence.
    + Intros. forward. entailer!.
  - forward. Exists p; entailer!.
Qed.

Definition pushdown_left_inv (b_res: val)
           (t_res: tree val) (gv: globals) : environ -> mpred :=
  EX b: val, EX ta: tree val, EX x: Z, EX v: val, EX tb: tree val,
  PROP  ()
  LOCAL (temp _t b; gvars gv)
  SEP   (mem_mgr gv; treebox_rep (T ta x v tb) b;
        (treebox_rep (pushdown_left ta tb) b -* treebox_rep t_res b_res)).

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  forward_loop (pushdown_left_inv b (pushdown_left ta tb) gv).
  - (* Precondition *)
    unfold pushdown_left_inv. Exists b ta x v tb. entailer!.
    apply derives_trans with (treebox_rep (T ta x v tb) b).
    2: cancel; apply -> wand_sepcon_adjoint; cancel.
    rewrite (treebox_rep_spec (T ta x v tb)). Exists p. entailer!.
  - (* Loop body *)
    unfold pushdown_left_inv. clear x v H H0. Intros b0 ta0 x vx tbc0.
    unfold treebox_rep at 1. Intros p0.
    forward. (* p = *t; *)
    simpl tree_rep. Intros pa pbc.
    forward. (* q = p->right *)
    forward_if.
    + subst. assert_PROP (tbc0 = E) by entailer!. subst.
      forward. (* q = p->left *)
      forward. (* *t=q *)
      forward_call (t_struct_tree, p0, gv). (* _free(_p); *)
      1: if_tac; entailer!.
      forward. (* return *)
      simpl tree_rep. simpl pushdown_left. cancel.
      apply modus_ponens_wand'. Exists pa. entailer!.
    + destruct tbc0 as [| tb0 y vy tc0]. 1: simpl tree_rep; Intros; easy.
      forward_call (ta0, x, vx, tb0, y, vy, tc0, b0, p0, pa, pbc).
      (* _turn_left(_t, _p, _q); *)
      Intros pc.
      forward. (* _t = &(_q -> _left); *)
      Exists (field_address t_struct_tree [StructField _left] pbc) ta0 x vx tb0.
      gather_SEP (data_at Ews _ _ b0) (malloc_token _ _ _). Intros.
      Opaque tree_rep. entailer!. Transparent tree_rep.
      apply RAMIF_PLAIN.trans'. now apply bst_left_entail.
Qed.

Lemma body_turn_left: semax_body Vprog Gprog f_turn_left turn_left_spec.
Proof.
  start_function.
  simpl tree_rep.
  Intros pb pc.
  forward. (* mid=r->left *)
  forward. (* l->right=mid *)
  forward. (* r->left=l *)
  forward. (* _l = r *)
  Exists pc.
  entailer!.
  simpl tree_rep.
  Exists pa pb.
  entailer!.
Qed.

Definition lookup_inv (b: val) (lock:val) (sh: share) (x: Z) gv (inv_names : invG)
           (Q : val -> mpred) (g:gname) (np tp: val)
           (root_t: tree_info) : environ -> mpred :=
  (EX tn: val, EX t : tree_info,
   PROP (lookup nullval x t = lookup nullval x root_t)
   LOCAL (temp _p tn; temp _tgt np; temp _t b; temp _l lock;
          temp _x (vint x); gvars gv)
   SEP (data_at sh (tptr t_struct_tree_t) np b;
       field_at sh t_struct_tree_t [StructField _lock] lock np;
       lock_inv sh lock (node_lock_inv g lock np);
       my_half g Tsh root_t; field_at Ews t_struct_tree_t [StructField _t] tp np;
       malloc_token Ews t_struct_tree_t np;
       tree_rep t tn; malloc_token Ews tlock lock;
       tree_rep t tn -* tree_rep root_t tp;
       atomic_shift
         (λ BST : tree val, !! sorted_tree BST && public_half g BST) ∅ ⊤
         (λ (BST : tree val) (ret : val),
          fold_right_sepcon
            [!! (sorted_tree BST ∧ ret = lookup nullval x BST) && public_half g BST])
         Q; mem_mgr gv))%assert.

Lemma body_lookup: semax_body Vprog Gprog f_lookup lookup_spec.
Proof.
  start_function.
  unfold nodebox_rep. Intros np.
  forward. (* _tgt = *_t; *)
  forward. (* _l = (_tgt -> _lock); *)
  forward_call (lock, sh, (node_lock_inv g lock np)). (* _acquire(_l); *)
  unfold node_lock_inv at 2. unfold treebox_rep. Intros a tp.
  change (tptr t_struct_tree) with
      (nested_field_type t_struct_tree_t [StructField _t]).
  rewrite <- field_at_data_at.
  forward. (* _p = (_tgt -> _t); *)
  forward_while (lookup_inv b lock sh x gv inv_names Q g np tp a).
  (* while (_p != (tptr tvoid) (0)) { *)
  - unfold lookup_inv. Exists tp a. entailer!. apply -> wand_sepcon_adjoint. cancel.
  - entailer!.
  - destruct t; unfold tree_rep at 1; fold tree_rep. 1: now Intros. Intros pa pb.
    forward. (* _y = (_p -> _key); *)
    forward_if; [|forward_if].
    + forward. Exists (pa, t1). simpl fst. simpl snd. entailer!.
      * rewrite <- H0; simpl. rewrite if_trueb; auto. now apply Z.ltb_lt.
      * apply RAMIF_PLAIN.trans''. apply -> wand_sepcon_adjoint. simpl.
        Exists pa pb. entailer!.
    + forward. Exists (pb, t2). simpl fst. simpl snd. entailer!.
      * rewrite <- H0. simpl. rewrite if_falseb. 2: apply Z.ltb_ge; lia.
        rewrite if_trueb; auto. now apply Z.ltb_lt.
      * apply RAMIF_PLAIN.trans''. apply -> wand_sepcon_adjoint. simpl.
        Exists pa pb. entailer!.
    + assert (x = k) by lia. subst x. clear H H3 H4. forward.
      gather_SEP (atomic_shift _ _ _ _ _) (my_half _ _ _).
      viewshift_SEP 0 (EX y, Q y * (!! (y = v) && (my_half g Tsh a))). {
        go_lower.
        rewrite <- (sepcon_emp
                      (atomic_shift (λ BST : tree_info, !! sorted_tree BST &&
                                                        public_half g BST) ∅ ⊤
                                    (λ (BST : tree_info) (ret : val),
                                     !! (sorted_tree BST ∧ ret = lookup nullval k BST)
                                     && public_half g BST * emp) Q *
                       my_half g Tsh a)).
        apply sync_commit_same. intro t. Intros.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists t. cancel.
        apply imp_andp_adjoint. Intros. rewrite if_true in H3; auto. subst t.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro].
        rewrite <- wand_sepcon_adjoint.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists v.
        entailer!. rewrite <- H0. simpl.
        now do 2 (rewrite if_falseb; [|apply Z.ltb_irrefl]). } Intros y. subst y.
      forward_call (lock, sh, node_lock_inv g lock np).
      * assert (Frame =
                [Q v; mem_mgr gv; data_at sh (tptr t_struct_tree_t) np b;
                 field_at sh t_struct_tree_t [StructField _lock] lock np]);
          subst Frame; [ reflexivity | clear H].
        lock_props. unfold node_lock_inv. unfold treebox_rep. Exists a tp.
        rewrite (field_at_data_at Ews _ _ _ _). simpl nested_field_type.
        simpl fold_right_sepcon. cancel.
        apply modus_ponens_wand'. simpl. Exists pa pb. entailer!.
      * forward. Exists v. unfold nodebox_rep. Exists np. entailer!.
  - subst tn. sep_apply tree_rep_nullval. Intros. subst t. simpl in H0.
    gather_SEP (atomic_shift _ _ _ _ _) (my_half _ _ _).
    viewshift_SEP 0 (EX y, Q y * (!! (y = nullval) && (my_half g Tsh a))). {
      go_lower.
        rewrite <- (sepcon_emp
                      (atomic_shift (λ BST : tree_info, !! sorted_tree BST &&
                                                        public_half g BST) ∅ ⊤
                                    (λ (BST : tree_info) (ret : val),
                                     !! (sorted_tree BST ∧ ret = lookup nullval x BST)
                                     && public_half g BST * emp) Q *
                       my_half g Tsh a)).
        apply sync_commit_same. intro tr. Intros.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr. cancel.
        apply imp_andp_adjoint. Intros. rewrite if_true in H2; auto. subst tr.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro].
        rewrite <- wand_sepcon_adjoint.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists nullval.
        entailer!. } Intros y. subst y.
    forward_call (lock, sh, node_lock_inv g lock np).
    + assert (Frame =
              [Q nullval; mem_mgr gv; data_at sh (tptr t_struct_tree_t) np b;
               field_at sh t_struct_tree_t [StructField _lock] lock np]);
        subst Frame; [ reflexivity | clear H1].
      lock_props. unfold node_lock_inv. unfold treebox_rep. Exists a tp.
      rewrite (field_at_data_at Ews _ _ _ _). simpl nested_field_type.
      simpl fold_right_sepcon. cancel. apply modus_ponens_wand.
    + forward. Exists nullval. unfold nodebox_rep. Exists np. entailer!.
Qed.

Definition insert_inv (b: val) (lock:val) (sh: share) (x: Z) (v: val)
           gv (inv_names : invG) (Q: mpred) (g:gname) (np: val)
           (root_t: tree_info) : environ -> mpred :=
  (EX tn: val, EX t : tree_info,
   PROP ()
   LOCAL (temp _tr tn; temp _tgt np; temp _t b; temp _l lock;
          temp _x (vint x); temp _value v; gvars gv)
   SEP (data_at sh (tptr t_struct_tree_t) np b;
       field_at sh t_struct_tree_t [StructField _lock] lock np;
       lock_inv sh lock (node_lock_inv g lock np);
       my_half g Tsh root_t;
       malloc_token Ews t_struct_tree_t np;
       treebox_rep t tn; malloc_token Ews tlock lock;
       treebox_rep (insert x v t) tn -* treebox_rep (insert x v root_t)
                   (field_address t_struct_tree_t [StructField _t] np);
       atomic_shift
         (λ BST : tree val, !! sorted_tree BST && public_half g BST)
         ∅ ⊤
         (λ (BST : tree val) (_ : ()),
          fold_right_sepcon
            [!! sorted_tree (insert x v BST) && public_half g (insert x v BST)])
         (λ _ : (), Q); mem_mgr gv))%assert.

Lemma body_insert: semax_body Vprog Gprog f_insert insert_spec.
Proof.
  start_function.
  unfold nodebox_rep. Intros np.
  forward. (* _tgt = *_t; *)
  forward. (* _l = (_tgt -> _lock); *)
  forward_call (lock, sh, (node_lock_inv g lock np)). (* _acquire(_l); *)
  unfold node_lock_inv at 2. unfold treebox_rep. Intros tr tp.
  forward. (* _tr = &(_tgt -> _t); *)
  forward_loop (insert_inv b lock sh x v gv inv_names Q g np tr).
  - unfold insert_inv. Exists (field_address t_struct_tree_t [StructField _t] np) tr.
    entailer!. unfold treebox_rep at 1.
    Exists tp. cancel. rewrite <- wand_sepcon_adjoint. cancel.
  - unfold insert_inv. Intros tn t. unfold treebox_rep at 1. Intros p.
    forward. (* _p = *_tr; *)
    forward_if. (* if (_p == (tptr tvoid) (0)) { *)
    + subst p.
      forward_call (t_struct_tree, gv).
      Intros p'.
      forward. (* *_tr = _p; *)
      forward. (* (_p -> _key) = _x; *)
      forward. (* (_p -> _value) = _value; *)
      forward. (* (_p -> _left) = (tptr tvoid) (0); *)
      forward. (* (_p -> _right) = (tptr tvoid) (0); *)
      assert_PROP (t = E) by entailer!. subst t. simpl tree_rep. Intros.
      gather_SEP (atomic_shift _ _ _ _ _) (my_half _ _ _).
      viewshift_SEP 0 (Q * my_half g Tsh (insert x v tr)). {
        go_lower.
        rewrite <- (sepcon_emp
                      (atomic_shift (λ BST : tree_info, !! sorted_tree BST &&
                                                        public_half g BST) ∅ ⊤
                                    (λ (BST : tree_info) (_ : ()),
                                     !! sorted_tree (insert x v BST) &&
                                     @public_half tree_ghost g (insert x v BST) * emp)
                                    (λ _ : (), Q) * my_half g Tsh tr)).
        apply sync_commit_gen1. intros tr1. Intros.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr1. cancel.
        apply imp_andp_adjoint. Intros. rewrite if_true in H2; auto. subst tr1.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr tr.
        entailer!. 2: exact tt. rewrite <- wand_sepcon_adjoint.
        sep_apply (public_update g tr tr (insert x v tr)). Intros.
        apply ghost_seplog.bupd_mono. entailer!. now apply insert_sorted. }
      forward_call (lock, sh, node_lock_inv g lock np). (* _release(_l); *)
      * assert (Frame =
                [Q; mem_mgr gv; data_at sh (tptr t_struct_tree_t) np b;
                 field_at sh t_struct_tree_t [StructField _lock] lock np]);
          subst Frame; [ reflexivity | clear H1].
        lock_props. unfold node_lock_inv. Exists (insert x v tr).
        simpl fold_right_sepcon. cancel. apply modus_ponens_wand'.
        unfold treebox_rep. Exists p'. simpl. Exists nullval nullval. entailer!.
      * forward. (* return; *) unfold nodebox_rep. Exists np. entailer!.
    + destruct t; simpl tree_rep. 1: now Intros. Intros pa pb.
      forward. (* _y = (_p -> _key); *)
      forward_if; [|forward_if].
      * forward. (* _tr = &(_p -> _left); *)
        unfold insert_inv.
        Exists (field_address t_struct_tree [StructField _left] p) t1.
        entailer!. simpl treebox_rep. rewrite if_trueb. 2: now apply Z.ltb_lt.
        apply RAMIF_PLAIN.trans'. now apply bst_left_entail.
      * forward. (* _tr = &(_p -> _right); *)
        unfold insert_inv.
        Exists (field_address t_struct_tree [StructField _right] p) t2.
        entailer!. simpl treebox_rep. rewrite if_falseb. 2: apply Z.ltb_ge; lia.
        rewrite if_trueb. 2: now apply Z.ltb_lt.
        apply RAMIF_PLAIN.trans'. now apply bst_right_entail.
      * assert (x = k) by lia. subst x. clear H2 H3 H4.
        forward. (* (_p -> _value) = _value; *)
        gather_SEP (atomic_shift _ _ _ _ _) (my_half _ _ _).
        viewshift_SEP 0 (Q * my_half g Tsh (insert k v tr)). {
        go_lower.
        rewrite <- (sepcon_emp
                      (atomic_shift (λ BST : tree_info, !! sorted_tree BST &&
                                                        public_half g BST) ∅ ⊤
                                    (λ (BST : tree_info) (_ : ()),
                                     !! sorted_tree (insert k v BST) &&
                                     @public_half tree_ghost g (insert k v BST) * emp)
                                    (λ _ : (), Q) * my_half g Tsh tr)).
        apply sync_commit_gen1. intros tr1. Intros.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr1. cancel.
        apply imp_andp_adjoint. Intros. rewrite if_true in H3; auto. subst tr1.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr tr.
        entailer!. 2: exact tt. rewrite <- wand_sepcon_adjoint.
        sep_apply (public_update g tr tr (insert k v tr)). Intros.
        apply ghost_seplog.bupd_mono. entailer!. now apply insert_sorted. }
        forward_call (lock, sh, node_lock_inv g lock np). (* _release(_l); *)
        -- assert (Frame =
                   [Q; mem_mgr gv; data_at sh (tptr t_struct_tree_t) np b;
                    field_at sh t_struct_tree_t [StructField _lock] lock np]);
             subst Frame; [ reflexivity | clear H2].
           lock_props. unfold node_lock_inv. Exists (insert k v tr).
           simpl fold_right_sepcon. cancel. apply modus_ponens_wand'.
           unfold treebox_rep. Exists p. simpl.
           do 2 (rewrite if_falseb; [|apply Z.ltb_irrefl]). simpl tree_rep.
           Exists pa pb. entailer!.
        -- forward. (* return; *) unfold nodebox_rep. Exists np. entailer!.
Qed.

Definition delete_inv (b: val) (lock:val) (sh: share) (x: Z)
           gv (inv_names : invG) (Q: mpred) (g:gname) (np: val)
           (root_t: tree_info) : environ -> mpred :=
  (EX tn: val, EX t : tree_info,
   PROP ()
   LOCAL (temp _tr tn; temp _tgt np; temp _t b; temp _l lock;
          temp _x (vint x); gvars gv)
   SEP (data_at sh (tptr t_struct_tree_t) np b;
       field_at sh t_struct_tree_t [StructField _lock] lock np;
       lock_inv sh lock (node_lock_inv g lock np);
       my_half g Tsh root_t;
       malloc_token Ews t_struct_tree_t np;
       treebox_rep t tn; malloc_token Ews tlock lock;
       treebox_rep (delete x t) tn -* treebox_rep (delete x root_t)
                   (field_address t_struct_tree_t [StructField _t] np);
       atomic_shift
         (λ BST : tree val, !! sorted_tree BST && public_half g BST)
         ∅ ⊤
         (λ (BST : tree val) (_ : ()),
          fold_right_sepcon
            [!! sorted_tree (delete x BST) && public_half g (delete x BST)])
         (λ _ : (), Q); mem_mgr gv))%assert.

Lemma body_delete: semax_body Vprog Gprog f_delete delete_spec.
Proof.
  start_function.
  unfold nodebox_rep. Intros np.
  forward. (* _tgt = *_t; *)
  forward. (* _l = (_tgt -> _lock); *)
  forward_call (lock, sh, (node_lock_inv g lock np)). (* _acquire(_l); *)
  unfold node_lock_inv at 2. unfold treebox_rep. Intros tr tp.
  forward. (* _tr = &(_tgt -> _t); *)
  forward_loop (delete_inv b lock sh x gv inv_names Q g np tr).
  - unfold delete_inv. Exists (field_address t_struct_tree_t [StructField _t] np) tr.
    entailer!. unfold treebox_rep at 1.
    Exists tp. cancel. rewrite <- wand_sepcon_adjoint. cancel.
  - unfold delete_inv. Intros tn t. unfold treebox_rep at 1. Intros p.
    forward. (* _p = *_tr; *)
    forward_if. (* if (_p == (tptr tvoid) (0)) { *)
    + subst p. assert_PROP (t = E) by entailer!. subst t.
      simpl tree_rep. Intros. simpl delete.
      gather_SEP (atomic_shift _ _ _ _ _) (my_half _ _ _).
      viewshift_SEP 0 (Q * my_half g Tsh (delete x tr)). {
        go_lower.
        rewrite <- (sepcon_emp
                      (atomic_shift (λ BST : tree_info, !! sorted_tree BST &&
                                                        public_half g BST) ∅ ⊤
                                    (λ (BST : tree_info) (_ : ()),
                                     !! sorted_tree (delete x BST) &&
                                     @public_half tree_ghost g (delete x BST) * emp)
                                    (λ _ : (), Q) * my_half g Tsh tr)).
        apply sync_commit_gen1. intros tr1. Intros.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr1. cancel.
        apply imp_andp_adjoint. Intros. rewrite if_true in H1; auto. subst tr1.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr tr.
        entailer!. 2: exact tt. rewrite <- wand_sepcon_adjoint.
        sep_apply (public_update g tr tr (delete x tr)). Intros.
        apply ghost_seplog.bupd_mono. entailer!. now apply delete_sorted. }
      forward_call (lock, sh, node_lock_inv g lock np). (* _release(_l); *)
      * assert (Frame =
                [Q; mem_mgr gv; data_at sh (tptr t_struct_tree_t) np b;
                 field_at sh t_struct_tree_t [StructField _lock] lock np]);
          subst Frame; [ reflexivity | clear H0].
        lock_props. unfold node_lock_inv. Exists (delete x tr).
        simpl fold_right_sepcon. cancel. apply modus_ponens_wand'.
        unfold treebox_rep. Exists nullval. simpl. entailer!.
      * forward. (* return; *) unfold nodebox_rep. Exists np. entailer!.
    + destruct t; simpl tree_rep. 1: now Intros. Intros pa pb.
      forward. (* _y = (_p -> _key); *)
      forward_if; [|forward_if].
      * forward. (* _tr = &(_p -> _left); *)
        unfold insert_inv.
        Exists (field_address t_struct_tree [StructField _left] p) t1.
        entailer!. simpl treebox_rep. rewrite if_trueb. 2: now apply Z.ltb_lt.
        apply RAMIF_PLAIN.trans'. now apply bst_left_entail.
      * forward. (* _tr = &(_p -> _right); *)
        unfold insert_inv.
        Exists (field_address t_struct_tree [StructField _right] p) t2.
        entailer!. simpl treebox_rep. rewrite if_falseb. 2: apply Z.ltb_ge; lia.
        rewrite if_trueb. 2: now apply Z.ltb_lt.
        apply RAMIF_PLAIN.trans'. now apply bst_right_entail.
      * assert (x = k) by lia. subst x. clear H1 H2 H3.
        rewrite unfold_data_at_tree. Intros.
        gather_SEP (field_at _ _ [StructField _left] _ _) (tree_rep _ pa).
        replace_SEP 0 (treebox_rep
                         t1 (field_address t_struct_tree [StructField _left] p)). {
          unfold treebox_rep; entailer!. Exists pa.
          rewrite field_at_data_at. simpl. entailer!. }
        gather_SEP (field_at _ _ [StructField _right] _ _) (tree_rep _ pb).
        replace_SEP 0 (treebox_rep
                         t2 (field_address t_struct_tree [StructField _right] p)). {
          unfold treebox_rep; entailer!. Exists pb.
          rewrite field_at_data_at. entailer!. }
        forward_call (t1, k, v, t2, tn, p, gv); [entailer! .. |].
        (* _pushdown_left(_tr); *)
        gather_SEP (atomic_shift _ _ _ _ _) (my_half _ _ _).
        viewshift_SEP 0 (Q * my_half g Tsh (delete k tr)). {
        go_lower.
        rewrite <- (sepcon_emp
                      (atomic_shift (λ BST : tree_info, !! sorted_tree BST &&
                                                        public_half g BST) ∅ ⊤
                                    (λ (BST : tree_info) (_ : ()),
                                     !! sorted_tree (delete k BST) &&
                                     @public_half tree_ghost g (delete k BST) * emp)
                                    (λ _ : (), Q) * my_half g Tsh tr)).
        apply sync_commit_gen1. intros tr1. Intros.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr1. cancel.
        apply imp_andp_adjoint. Intros. rewrite if_true in H2; auto. subst tr1.
        eapply derives_trans; [|apply ghost_seplog.bupd_intro]. Exists tr tr.
        entailer!. 2: exact tt. rewrite <- wand_sepcon_adjoint.
        sep_apply (public_update g tr tr (delete k tr)). Intros.
        apply ghost_seplog.bupd_mono. entailer!. now apply delete_sorted. }
        forward_call (lock, sh, node_lock_inv g lock np). (* _release(_l); *)
        -- assert (Frame =
                   [Q; mem_mgr gv; data_at sh (tptr t_struct_tree_t) np b;
                    field_at sh t_struct_tree_t [StructField _lock] lock np]);
             subst Frame; [ reflexivity | clear H1].
           lock_props. unfold node_lock_inv. Exists (delete k tr).
           simpl fold_right_sepcon. cancel. apply modus_ponens_wand'.
           unfold treebox_rep. Intros p'. Exists p'. simpl.
           do 2 (rewrite if_falseb; [|apply Z.ltb_irrefl]). cancel.
        -- forward. (* return; *) unfold nodebox_rep. Exists np. entailer!.
Qed.


Require Import Rewriter.Language.Language.
Require Import Rewriter.Language.Wf.
Require Import Crypto.Language.API.

Module Compilers.
  Import Language.Compilers.
  Import Language.Inversion.Compilers.
  Import Language.Wf.Compilers.
  Import Language.API.Compilers.
  Import Compilers.API.

  Create HintDb wf_extra discriminated.
  Create HintDb interp_extra discriminated.
#[global]
  Hint Constants Opaque : wf_extra interp_extra.

#[global]
  Hint Opaque expr.interp expr.Interp : interp_extra.
#[global]
  Hint Opaque expr.Wf expr.Wf3 : wf_extra interp_extra.

  Module expr.
    Import Language.Wf.Compilers.expr.
    Global Hint Constructors wf : wf_extra.
    Global Hint Resolve Wf_APP : wf_extra.
    Global Hint Opaque expr.APP : wf_extra interp_extra.
#[global]
    Hint Rewrite @expr.Interp_APP : interp_extra.
    Global Hint Immediate Wf_of_Wf3 : wf_extra.
    Global Hint Resolve Wf3_of_Wf : wf_extra.

    Definition Wf_base_Reify_as {t} v
      := @Wf_base_Reify_as base.type.base base.base_interp base.type.base_beq ident ident.buildIdent base.reflect_base_beq t v.

    Definition Wf_Reify_as {t} v
      := @Wf_Reify_as base.type.base base.base_interp base.type.base_beq ident ident.buildIdent base.reflect_base_beq t v.

    Definition Wf_base_reify {t} v
      := @Wf_base_reify base.type.base base.base_interp base.type.base_beq ident ident.buildIdent base.reflect_base_beq t v.

    Definition Wf_reify {t} v
      := @Wf_reify base.type.base base.base_interp base.type.base_beq ident ident.buildIdent base.reflect_base_beq t v.

    Definition Interp_Reify_as {t} v
      := @Interp_Reify_as base.type.base base.base_interp ident ident.buildIdent (@ident.interp) ident.buildInterpIdentCorrect t v.

    Definition Interp_reify {t} v
      := @Interp_reify base.type.base base.base_interp ident ident.buildIdent (@ident.interp) ident.buildInterpIdentCorrect t v.

    Definition interp_reify {t} v
      := @interp_reify base.type.base base.base_interp ident ident.buildIdent (@ident.interp) ident.buildInterpIdentCorrect t v.

    Definition interp_reify_list {t} v
      := @interp_reify_list base.type.base base.base_interp ident ident.buildIdent (@ident.interp) ident.buildInterpIdentCorrect t v.

    Definition interp_reify_option {t} v
      := @interp_reify_option base.type.base base.base_interp ident ident.buildIdent (@ident.interp) ident.buildInterpIdentCorrect t v.

    Definition Wf_Interp_Proper {t} e Hwf
      := @Wf_Interp_Proper_gen _ ident _ _ (@ident.interp) (@ident.interp_Proper) t e Hwf.
  End expr.

#[global]
  Hint Constructors expr.wf : wf_extra.
#[global]
  Hint Resolve expr.Wf_APP expr.Wf_Reify_as expr.Wf_base_Reify_as expr.Wf_reify expr.Wf_base_reify : wf_extra.
  (** Work around COQBUG(https://github.com/coq/coq/issues/11536) *)
#[global]
  Hint Extern 0 (expr.Wf (GallinaReify.base.Reify_as _ _)) => simple apply (@expr.Wf_base_Reify) : wf_extra.
#[global]
  Hint Extern 0 (expr.Wf (GallinaReify.Reify_as _ _)) => simple apply (@expr.Wf_Reify) : wf_extra.
  (** Work around COQBUG(https://github.com/coq/coq/issues/11536) *)
#[global]
  Hint Extern 0 (expr.Wf (fun var => GallinaReify.base.reify _)) => simple apply (@expr.Wf_base_reify) : wf_extra.
#[global]
  Hint Extern 0 (expr.Wf (fun var => GallinaReify.reify _)) => simple apply (@expr.Wf_reify) : wf_extra.
#[global]
  Hint Opaque expr.APP GallinaReify.Reify_as GallinaReify.base.reify : wf_extra interp_extra.
#[global]
  Hint Rewrite @expr.Interp_Reify_as @expr.interp_reify @expr.interp_reify_list @expr.interp_reify_option @expr.Interp_reify @expr.Interp_APP : interp_extra.

  Module GeneralizeVar.
    Import Language.Wf.Compilers.GeneralizeVar.

    Definition Wf_FromFlat_ToFlat {t} e Hwf
      := @Wf_FromFlat_ToFlat _ ident (@base.try_make_transport_cps _ base.try_make_base_transport_cps) (base.type.type_beq _ base.type.base_beq) base.reflect_type_beq base.try_make_transport_cps_correct _ t e Hwf.

    Definition Wf_GeneralizeVar {t} e Hwf
      := @Wf_GeneralizeVar _ ident (@base.try_make_transport_cps _ base.try_make_base_transport_cps) (base.type.type_beq _ base.type.base_beq) base.reflect_type_beq base.try_make_transport_cps_correct _ t e Hwf.

    Definition Interp_FromFlat_ToFlat {t} e Hwf
      := @Interp_gen1_FromFlat_ToFlat _ ident (@base.try_make_transport_cps _ base.try_make_base_transport_cps) (base.type.type_beq _ base.type.base_beq) base.reflect_type_beq base.try_make_transport_cps_correct _ _ (@ident.interp) _ (@ident.interp_Proper) t e Hwf.

    Definition Interp_GeneralizeVar {t} e Hwf
      := @Interp_gen1_GeneralizeVar _ ident (@base.try_make_transport_cps _ base.try_make_base_transport_cps) (base.type.type_beq _ base.type.base_beq) base.reflect_type_beq base.try_make_transport_cps_correct _ _ (@ident.interp) _ (@ident.interp_Proper) t e Hwf.
  End GeneralizeVar.

  Global Hint Extern 0 (?x == ?x) => apply expr.Wf_Interp_Proper_gen : wf_extra interp_extra.
#[global]
  Hint Resolve GeneralizeVar.Wf_FromFlat_ToFlat GeneralizeVar.Wf_GeneralizeVar : wf_extra.
#[global]
  Hint Opaque GeneralizeVar.FromFlat GeneralizeVar.ToFlat GeneralizeVar.GeneralizeVar : wf_extra interp_extra.
#[global]
  Hint Rewrite @GeneralizeVar.Interp_GeneralizeVar @GeneralizeVar.Interp_FromFlat_ToFlat : interp_extra.
End Compilers.


(**************************************************************************************************)
(* Total Constructor/Destructorization for Local (Co)pattern Matching.                                   *)
(*                                                                                *)
(* File: UtilsTypechecker.v                                                                       *)
(*                                                                                *)
(**************************************************************************************************)

Require Import Coq.Lists.List.
Require Import Coq.Arith.EqNat.
Require Import Coq.Arith.Minus.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Arith.PeanoNat.
Import ListNotations.
Require Import Coq.omega.Omega.

Require Import AST.
Require Import Names.
Require Import GenericLemmas.
Require Import GenericTactics.
Require Import Skeleton.
Require Import ProgramDef.
Require Import Eval.
Require Export Typechecker.

Lemma preservation_in_list : forall (p : program) (e e' : expr) (left right : list expr) (cargs : list TypeName),
    program_skeleton p // [] ||- (left ++ [e] ++ right) :: cargs ->
    Forall
      (fun e1 : expr =>
         forall t : TypeName,
           program_skeleton p / [] |- e1 : t -> forall e2 : expr, [p |- e1 ==> e2] -> program_skeleton p / [] |- e2 : t)
      (left ++ [e] ++ right) ->
    [ p |- e ==> e' ] ->
    program_skeleton p // [] ||- (left ++ [e'] ++ right) :: cargs.
Proof.
  intros p e e' left right cargs Ht Hall Heval.
  generalize dependent cargs.
  induction left.
  -intros. simpl. simpl in Ht.
   inversion Hall as [|_x _l Hhead Htail]; subst. inversion Ht; subst.
   apply ListTypeDeriv_Cons; try assumption.
   apply Hhead; try assumption.
  -intros. inversion Ht; subst.
   apply ListTypeDeriv_Cons; try assumption.
   apply IHleft; try assumption.
   inversion Hall. assumption.
Qed.

Lemma typeDerivList_lenghts_eq : forall (sk : skeleton) (exs : list expr) (ts : list TypeName),
    (sk // [] ||- exs :: ts) ->
    List.length exs = List.length ts.
Proof.
  intros. generalize dependent ts.
  induction exs.
  -intros. inversion H. reflexivity.
  -intros. induction ts; try solve [inversion H].
   simpl. f_equal. inversion H. apply IHexs; try assumption.
Qed.

Lemma weaken_nth_option : forall {X : Type} (xsBase xs : list X) (x : X) (n : nat),
    Some x = nth_option n xsBase ->
    Some x = nth_option n (xsBase ++ xs).
Proof.
  intros X xsBase xs x n H.
  generalize dependent n. induction xsBase; intros.
  -destruct n; try solve [inversion H].
  -destruct n; try solve [inversion H; reflexivity].
   simpl. simpl in H. apply IHxsBase. assumption.
Qed.

Lemma weaken_listDeriv:
  forall (sk : skeleton) (ls : list expr),
    Forall
      (fun e : expr =>
         forall (ctxBase ctx : list TypeName) (t : TypeName),
           sk / ctxBase |- e : t -> sk / (ctxBase ++ ctx) |- e : t) ls ->
    forall ctxBase ctx argts : list TypeName,
      sk // ctxBase ||- ls :: argts -> sk // (ctxBase ++ ctx) ||- ls :: argts.
Proof.
  intros sk ls H ctxBase ctx argts H7.
  generalize dependent argts; induction ls; intros;
    try solve [destruct argts; try solve [inversion H7]; apply ListTypeDeriv_Nil].
  destruct argts; try solve [inversion H7].
  inversion H. inversion H7. apply ListTypeDeriv_Cons.
  * apply H2. assumption.
  * apply IHls; try assumption.
Qed.

Lemma weaken_bindings:
  forall (sk : skeleton) (bindings_exprs : list expr) (bindings_types : list TypeName),
    Forall
      (fun e : expr =>
         forall (ctxBase ctx : list TypeName) (t : TypeName),
           sk / ctxBase |- e : t -> sk / (ctxBase ++ ctx) |- e : t)
      (map (fun et : expr * TypeName => let (e, _) := et in e) (combine bindings_exprs bindings_types)) ->
    forall ctxBase ctx : list TypeName,
      sk // ctxBase ||- bindings_exprs :: bindings_types ->
      sk // (ctxBase ++ ctx) ||- bindings_exprs :: bindings_types.
Proof.
  intros sk bindings_exprs bindings_types H_ind ctxBase ctx H.
  generalize dependent bindings_exprs; induction bindings_types; intros;
    destruct bindings_exprs; try solve [inversion H].
  - apply ListTypeDeriv_Nil.
  - inversion H. inversion H_ind. apply ListTypeDeriv_Cons.
    + apply H10; assumption.
    + apply IHbindings_types with (bindings_exprs := bindings_exprs); try assumption.
Qed.

Lemma weaken_typederiv : forall (sk : skeleton) (t : TypeName) (ctx ctxBase : list TypeName) (e : expr),
    (sk / ctxBase |- e : t) ->
    sk / (ctxBase ++ ctx) |- e : t.
Proof.
  intros sk t ctx ctxBase e H.
  generalize dependent t. generalize dependent ctx. generalize dependent ctxBase.
  induction e using expr_strong_ind; intros.
  (* E_Var *)
  - apply T_Var. inversion H. apply weaken_nth_option. assumption.
  (* E_Constr *)
  - inversion H0. subst.
    simpl. apply T_Constr with (cargs := cargs); try assumption; try reflexivity.
    clear H0 H3.
    generalize dependent cargs. induction ls; intros.
    + destruct cargs; try solve [inversion H6]. apply ListTypeDeriv_Nil.
    + destruct cargs; try solve [inversion H6]. apply ListTypeDeriv_Cons.
      * inversion H. apply H2 with (ctxBase := ctxBase) (ctx := ctx) (t := t).
        inversion H6. assumption.
      * inversion H. apply IHls; try assumption. inversion H6. assumption.
  (* E_DestrCall *)
  - inversion H0; subst.
    apply T_DestrCall with (dargs := dargs); try assumption.
    + apply IHe. assumption.
    + clear H0 H6.
      generalize dependent dargs. induction ls; intros.
      * destruct dargs; try solve [inversion H9]. apply ListTypeDeriv_Nil.
      * destruct dargs; try solve [inversion H9]. apply ListTypeDeriv_Cons.
        -- inversion H. apply H2 with (ctxBase := ctxBase). inversion H9. assumption.
        -- inversion H. apply IHls; try assumption. inversion H9. assumption.
  (* E_FunCall *)
  - inversion H0; subst.
    apply T_FunCall with (argts := argts); try assumption.
    apply weaken_listDeriv; assumption.
  (* E_MatchFunCall *)
  - let solve_tac :=
        (apply T_GlobalConsFunCall with (argts := argts) || apply T_LocalConsFunCall with (argts := argts)) ; try assumption;
          [> apply IHe; try assumption
          | apply weaken_listDeriv; assumption]
    in
    inversion H0; subst;
      [> solve_tac | solve_tac].
  (* E_MatchFunCall *)
  - inversion H0; subst;
      (apply T_GlobalGenFunCall with (argts := argts) || apply T_LocalGenFunCall with (argts := argts));
      try assumption;
    apply weaken_listDeriv; try assumption.
  (* E_Match *)
  - inversion H1; subst.
    apply T_Match with
        (bindings_exprs := bindings_exprs)
        (bindings_types := bindings_types)
        (ctorlist := ctorlist);
      try assumption; try reflexivity.
    + apply IHe; assumption.
    + apply weaken_bindings; assumption.
  (* E_CoMatch *)
  - inversion H1; subst.
    apply T_CoMatch with
        (bindings_exprs := bindings_exprs)
        (bindings_types := bindings_types)
        (dtorlist := dtorlist);
      try assumption; try reflexivity.
    apply weaken_bindings; assumption.
  (* E_Let *)
  - inversion H; subst.
    apply T_Let with (t1 := t1).
    + apply IHe1; assumption.
    + apply IHe2 with (ctxBase := t1 :: ctxBase); assumption.
Qed.

Lemma nth_option_eq : forall {X : Type} (xs xs': list X) (x : X),
    nth_option (List.length xs) (xs ++ [x] ++ xs') = Some x.
Proof.
  intros X xs x.
  induction xs; try reflexivity.
  simpl. apply IHxs.
Qed.

Lemma nth_option_lt : forall {X : Type} (xs xs' : list X) (x : X) (n : nat),
    List.length xs <? n = true ->
    nth_option n (xs ++ [x] ++ xs') = nth_option (n - 1) (xs ++ xs').
Proof.
  intros X xs xs' x n H.
  generalize dependent n; induction xs; intros; try reflexivity.
  -simpl. destruct n; try solve [inversion H].
   simpl. rewrite <- minus_n_O. reflexivity.
  -destruct n; try solve [inversion H]. simpl.
   assert (Hsimpl : nth_option (n - 0) (a :: xs ++ xs') = nth_option (n - 1) (xs ++ xs')).
   destruct n; try solve [inversion H]. simpl. rewrite <- minus_n_O. reflexivity.
   rewrite Hsimpl. apply IHxs. simpl in H. unfold Nat.ltb in H. simpl in H.
   destruct n; try discriminate H. apply Nat.ltb_lt. apply Nat.leb_le in H. unfold lt. inversion H.
   +apply le_n.
   +subst. apply le_n_S. assumption.
Qed.

Lemma nth_option_gt : forall {X : Type} (xs xs' : list X) (x : X) (n : nat),
    List.length xs <? n = false ->
    List.length xs =? n = false ->
    nth_option n (xs ++ [x] ++ xs') = nth_option n (xs ++ xs').
Proof.
  intros X xs xs' x n Hlt Heq.
  generalize dependent n; induction xs; intros.
  -destruct n; try solve [inversion Heq]; try solve [inversion Hlt].
  -simpl. destruct n.
   +reflexivity.
   +simpl. apply IHxs.
    *simpl in Hlt. assumption.
    *assumption.
Qed.

Ltac listTypeDeriv_tac argts ls := generalize dependent argts; induction ls; intros; destruct argts; try solve [inversion Ht_args]; try apply ListTypeDeriv_Nil.

Lemma subst_typing_cong : forall (sk : skeleton) (t t' : TypeName) (ctx_left ctx_right : list TypeName) (e e' : expr),
    (sk / [] |- e' : t') ->
    (sk / ctx_left ++ [t'] ++ ctx_right |- e : t) ->
    sk / ctx_left ++ ctx_right |- (substitute' (List.length ctx_left) e' e) : t.
Proof.
  intros sk t t' ctx_left ctx_right e e' He' He.
  generalize dependent t. generalize dependent ctx_left. generalize dependent ctx_right.
  induction e using expr_strong_ind; intros;
    let rec genfun_tac :=  subst; simpl;
                             match goal with
                             | [ _: _ // _ ||- _ :: ?argts  |- _ ] =>
                               (apply T_GlobalGenFunCall with (argts := argts) ||
                                                              apply T_LocalGenFunCall with (argts := argts))
                                 end;
                             try assumption;
                             clear Hin He;
                             listTypeDeriv_tac argts ls;
                             apply ListTypeDeriv_Cons;
                             [> inversion H; apply H2; inversion Ht_args; assumption
                             | inversion H; inversion Ht_args; subst; apply IHls; try assumption
                             ]
    in
    let rec consfun_tac := subst; simpl;
                             match goal with
                             | [ _: _ // _ ||- _ :: ?argts  |- _ ] =>
                               (apply T_GlobalConsFunCall with (argts := argts) ||
                                                               apply T_LocalConsFunCall with (argts := argts))
                             end;
                             try assumption;
                             [> apply IHe; assumption
                             | clear Hin He;
                               listTypeDeriv_tac argts ls;
                               apply ListTypeDeriv_Cons;
                               [> inversion H; apply H2; inversion Ht_args; assumption
                               | inversion H; inversion Ht_args; subst; apply IHls; try assumption
                               ]
                             ]
    in
  inversion He as [ sk' ctx' v' t''
                          | sk' ctx' args sn' cargs tn' HIn Ht_args tn_eq
                          | sk' ctx' args ex sn' dargs rtype Hin Ht_ex Ht_args
                          | sk' ctx' args n' argts rtype Hin Ht_args
                          | sk' ctx' args ex qn argts rtype Hin Ht_ex Ht_args (* E_ConsFunCallG *)
                          | sk' ctx' args ex qn argts rtype Hin Ht_ex Ht_args (* E_ConsFunCallL *)
                          | sk' ctx' args qn argts Hin Ht_args (* E_GenFunCallG *)
                          | sk' ctx' args qn argts Hin Ht_args (* E_GenFunCallL *)
                          | sk' ctx' qn ex  b_exs b_ts bs cs tn' ctorlist Ht_ex bs_comb Ht_bs HlookupConstr Hexhaustive Ht_cs
                          | sk' ctx' qn dtors b_exs b_ts bs cs bs_comb Ht_bs HlookupDestr Hexhaustive Ht_cs
                          | sk' ctx' e1' e2' t1 t2
                  ]; unfold substitute; [> | | | | consfun_tac | consfun_tac |  try genfun_tac | try genfun_tac | | | ].
  (* E_Var *)
  -subst. simpl. destruct (List.length ctx_left =? v) eqn:Elen.
   +apply beq_nat_true in Elen. rewrite <- Elen in H. rewrite nth_option_eq in H.
    inversion H. apply weaken_typederiv with (ctxBase := []). assumption.
   +destruct (List.length ctx_left <? v) eqn:Elenle.
    *destruct v. simpl.
     --induction ctx_left; try solve [inversion Elen].
       simpl. inversion Elenle.
     --rewrite  nth_option_lt in H; try assumption.
       apply T_Var; try assumption.
    *rewrite nth_option_gt in H; try assumption.
     apply T_Var; try assumption.
  (* E_Constr *)
  -simpl. apply T_Constr with (cargs := cargs); try assumption.
   subst. clear HIn He.
   listTypeDeriv_tac cargs ls.
   apply ListTypeDeriv_Cons.
   +inversion H. apply H2. inversion Ht_args. assumption.
   +inversion H. inversion Ht_args. subst. apply IHls; try assumption.
  (* E_DestrCall *)
  -subst. simpl. apply T_DestrCall with (dargs := dargs); try assumption.
   +apply IHe. assumption.
   +clear Hin He IHe.
   listTypeDeriv_tac dargs ls.
   apply ListTypeDeriv_Cons.
    *inversion H. apply H2. inversion Ht_args. assumption.
    *inversion H. inversion Ht_args. subst. apply IHls; try assumption.
  (* E_FunCall *)
  -subst. simpl. apply T_FunCall with (argts := argts); try assumption.
   clear Hin He.
   listTypeDeriv_tac argts ls.
   apply ListTypeDeriv_Cons.
   +inversion H. apply H2. inversion Ht_args. assumption.
   +inversion H. inversion Ht_args; subst. apply IHls; try assumption.
  (* E_Match *)
  -subst. simpl. rewrite map_combine_in_fst.
   apply T_Match with (bindings_exprs := map (substitute' (List.length ctx_left) e') b_exs)
                      (bindings_types := b_ts)
                      (ctorlist := ctorlist); try assumption; try reflexivity.
   +apply IHe. assumption.
   +clear - H0 Ht_bs. generalize dependent b_ts; induction b_exs; intros; destruct b_ts; try solve [inversion Ht_bs].
    *simpl. apply ListTypeDeriv_Nil.
    *inversion H0. apply ListTypeDeriv_Cons.
     --apply H2. inversion Ht_bs. assumption.
     --apply IHb_exs; try assumption. inversion Ht_bs. assumption.
  (* E_CoMatch *)
  -subst. simpl. rewrite map_combine_in_fst.
   apply T_CoMatch with (bindings_exprs := map (substitute' (List.length ctx_left) e') b_exs)
                        (bindings_types := b_ts)
                        (dtorlist := dtors); try assumption; try reflexivity.
   clear - H0 Ht_bs. generalize dependent b_ts; induction b_exs; intros; destruct b_ts; try solve [inversion Ht_bs].
   +apply ListTypeDeriv_Nil.
   +inversion H0. apply ListTypeDeriv_Cons; try assumption.
    *apply H2. inversion Ht_bs. assumption.
    *apply IHb_exs; try assumption.
     inversion Ht_bs. assumption.
  (* E_Let *)
  -subst; simpl. apply T_Let with (t1 := t1).
   +apply IHe1; try assumption.
   +assert (E : List.length ctx_left + 1 = List.length (t1 :: ctx_left)).
    simpl. rewrite <- plus_n_Sm. rewrite <- plus_n_O. reflexivity.
    rewrite E. apply IHe2 with (ctx_left := t1 :: ctx_left). assumption.
Qed.

Lemma subst_typing : forall (sk : skeleton) (t t' : TypeName) (ctx : list TypeName) (e e' : expr),
    (sk / [] |- e' : t') ->
    (sk / t' :: ctx |- e : t) ->
    sk / ctx |- (substitute e' e) : t.
Proof.
  intros. apply subst_typing_cong with (ctx_left := []) (t' := t'); try assumption.
Qed.

Lemma multisubst_typing : forall (sk : skeleton) (argts : list TypeName) (args : list expr) (e : expr) (t : TypeName),
    sk // [] ||- args :: argts ->
    (sk / argts |- e : t) ->
    sk / [] |- (multi_subst args e) : t.
Proof.
  intros sk argts args e t Hargs He.
  generalize dependent e.
  generalize dependent argts. induction args; intros; destruct argts; try solve [inversion Hargs]; try assumption.
  simpl. apply IHargs with (argts := argts).
  -inversion Hargs. assumption.
  -apply subst_typing with (t' := t0); try assumption.
   inversion Hargs. assumption.
Qed.

Lemma listTypeDeriv'_lemma : forall (prog : skeleton)(args : list expr)(argts : list TypeName)(ctxs: list ctxt),
    prog /// ctxs |||- args ::: argts ->
    length argts =? length args  = true.
Proof.
   intros prog args. induction args; intro argts; induction argts; intros ctxs H; try reflexivity; try inversion H; subst.
  simpl. eapply IHargs. eassumption.
Qed.

Lemma listTypeDeriv'_lemma_ctx: forall (prog : skeleton)(args : list expr)(argts : list TypeName)(ctxs: list ctxt),
    prog /// ctxs |||- args ::: argts ->
    length ctxs =? length args  = true.
Proof.
  intros prog args argts ctxs H.
  gen_induction (argts, ctxs) args; destruct ctxs; try solve [inversion H]; auto.
  simpl. inversion_clear H. IH_auto_tac.
Qed.

Fact index_list_typechecks : forall (s : skeleton) (l r : list TypeName) (n : nat),
    length r = n ->
    s // r ++ l ||- map fst (index_list n l) :: l.
Proof.
  intros s l r n H.
  gen_induction (r, n) l.
  - simpl. apply ListTypeDeriv_Nil.
  - simpl. apply ListTypeDeriv_Cons.
    + apply T_Var.
      gen_induction n r; destruct n; try solve [inversion H]; try reflexivity.
      simpl. apply IHr. inversion H; reflexivity.
    + specialize (IHl (S n) (r ++ [a])).
      simpl in IHl.
      assert ((r ++ [a]) ++ l = r ++ a :: l);
        [> clear; induction r; auto; simpl; f_equal; auto |].
      rewrite <- H0. IH_tac. rewrite app_length. simpl.
      rewrite Nat.add_1_r. f_equal. assumption.
Qed.


Require Import Coq.Strings.String.
From Mtac2 Require Import Base Logic Datatypes List MFix MTeleMatch.
Import M.notations.
Import Mtac2.lib.List.ListNotations.

Definition funs_of (T : Prop) : mlist Prop -> Prop :=
  fix f l :=
  match l with
  | [m: ] => T
  | X :m: l => X -> f l
  end.
  (* fun T l => fold_right (fun B X => B -> X) T l.  *)

Definition args_of : mlist Prop -> Prop :=
  fix f l :=
  match l with
  | [m: ] => True
  | X :m: l => (X * f l)%type
  end.

Definition apply_args_of {T} : forall {l}, funs_of T l -> args_of l -> T :=
  fix f l :=
  match l as l return funs_of T l -> args_of l -> T with
  | [m: ] => fun t _ => t
  | X :m: l => fun F '(x, a) => f l (F x) a
  end.

(* Compute funs_of (M nat) [m: True | False]. *)

Definition funs_bind {T X : Type} : forall {l},
  (X -> funs_of (M T) l) -> (M X -> funs_of (M T) l) :=
  fix f l :=
    match l return (X -> funs_of _ l) -> (M X -> funs_of _ l) with
    | [m:] => fun g mx => M.bind mx g
    | Y :m: l => fun g mx y => f _ (fun x => g x y) mx
    end.

(* Definition unify_within {T} {X:Prop} (x : X) : *)
(*   forall l, funs_of (M T) [m: X & l] -> funs_of (M T) [m: X & l] := *)
(*   fix f l := *)
(*     match l as l return funs_of _ [m: X & l] -> funs_of _ [m: X & l] with *)
(*     | nil => fun F x' => M.unify x x' UniEvarconv;; F x' *)
(*     | [m: Y & l] => fun F x' y => f l (fun x'' => F x'' y) x' *)
(*     end. *)

(* Eval cbn in unify_within (M.ret 2) [m: ] (fun x => M.ret x). *)
(* Eval cbn in ltac:(mrun ( *)
(*                       x <- M.evar nat; *)
(*                       unify_within (M.ret x) [m: ] (fun _ => M.ret x) (M.ret 2) *)
(*                  )). *)

Record Apply_Args (P T : Type) (t : T) :=
  APPLY_ARGS {
      apply_type: Type;
      apply_func: apply_type;
    }.

Definition remove_ret {V} {B} {Q : B -> Type} {A} : forall (v : V) b (m : Q b), (Q b -> M A) -> M A :=
  fun v b m cont =>
  m' <- M.remove v (M.ret m);
  oe <- M.unify m m' UniMatchNoRed;
  match oe with
  | mNone => M.failwith "Impossible branch."
  | mSome e =>
    match meq_sym e in _ =m= m'' return _ -> M A  with
    | meq_refl =>
      fun cont =>
        cont m'
    end cont
  end
.

Definition apply_type_of (P : Type) :
  forall {T} (t : T),
                      M (sigT (funs_of (M P))) :=
  mfix f (T : _) : T -> M (sigT (funs_of (M P))) :=
     mtmmatch T as T' return T' -> M (sigT (funs_of (M P))) with
     | (M P : Type) =c> fun t => M.ret (existT (funs_of (M P)) [m:] t)
     | [? X F] (forall x : X, F x) =c>
        fun ft =>
          M.nu (FreshFrom ft) mNone (fun x_nu : X =>
          x <- M.evar X;
          let F' := reduce (RedOneStep [rl:RedBeta]) (F x) in
          let f' := reduce (RedOneStep [rl:RedBeta]) (ft x) in
          r <- f F' f';
          mif M.is_evar x then
            o <- M.unify x_nu x UniEvarconv;
            let '(existT _ rl rp) := r in
             rp' <- M.abs_fun x_nu rp;
             mtry (M.remove x_nu (
                   let r' : sigT (funs_of (M P)) := existT _ (M X :m: rl) (funs_bind rp') in
                   M.ret r'
                 )) with
          | [?s] CannotRemoveVar s =>
            let err := (String.append "A hypothesis depends on " s) in
            M.failwith err
         end
       else M.remove x_nu (M.ret r)
       )
  | _ => fun _ =>
      M.failwith "The lemma's conclusion does not unify with the goal."
  end
.

(* Notation "'[apply_args_mtac' t 'in' P ]" := *)
(*   ( *)
(*     (* M.print "bla";; *) *)
(*     let t' := t in *)
(*     let P' := P in *)
(*     r <- apply_type_of P' t'; *)
(*     (* M.print_term r;; *) *)
(*     let '(existT _ rl rp) := r in *)
(*     M.ret (APPLY_ARGS P' _ t' _ rp) *)
(*   ). *)

(* Hint Extern 0 (Apply_Args ?P ?T ?t) => *)
(* mrun [apply_args_mtac t in P] : typeclass_instances. *)

(* Goal forall x y : nat, Apply_Args (x =m= x) _ (fun x => test_lemma True x y). *)
(*   intros. *)
(*   mrun [apply_args_mtac (fun x => test_lemma True x y) in x = x]. *)
(* Defined. *)
(* Eval vm_compute in Unnamed_thm. *)

(* Definition bla x y := Eval vm_compute in @apply_func _ _ _ (Unnamed_thm x y). *)
(* (* Notation "'[test' t ]" := (let f := ltac:(mrun t) in ltac:(let e := uconstr:(id f) in exact e)) (at level 0, t at level 11). *) *)

(* Notation "'[static_apply' t 'in' P ]" := *)
(*   ( *)
(*     let t' := t in (* WHY IS THIS NECESSARY? *) *)
(*     let F := M.eval [apply_args_mtac t' in P] in *)
(*     @apply_func _ _ _ F *)
(*   ) (at level 0, P, t at level 11). *)

(* (* Notation "'[bla' t ]" := (let F := ltac:(mrun (M.unify t 1 UniCoq)) in 0 ). *) *)
(* Notation "'[bla' t ]" := (let F := ltac:(let t := open_constr:(t) in unify t 1) in True). *)
(* Fail Goal [bla _]. *)
(* Goal 1=1. *)
(*   mrun ([static_apply (test_lemma _ _ _) in _=_] (M.ret I) (M.evar (1>0))). *)
(* Abort. *)

Notation "t '&s>' '[s' t1 ; .. ; tn ]" :=
  (
    let t' := t in
    let r := M.eval (apply_type_of _ t') in
    let args := M.eval ((* debug true [m:] *) (M.coerce (pair t1 .. (pair tn I) ..))) in
    apply_args_of (projT2 r) args
  ) (at level 41, left associativity,
     format "t  &s>  [s  t1 ;  .. ;  tn ]"
    ).

(* Definition test_lemma (T : Type) (x y : nat) : T -> y > 0 -> M (x =m= x) := *)
(*   fun t H => M.print_term (T, x, y, t, H);; M.ret meq_refl. *)

(* Goal 1=m=1. *)
(*   mrun ((test_lemma _ _ _) &s> [s M.ret I ; M.evar (1>0) ]). *)
(*   auto. *)
(* Qed. *)

(* Goal 1=m=1. *)
(*   mrun ( *)
(*       let f : M(1=1) := *)
(*           (test_lemma _ _ _) &s> [s M.ret I ; M.evar (1>0) ] in *)
(*       M.ret eq_refl). *)
(* Qed. *)