Require Export ComponentSM3.
Require Export ComponentSM4.

Section ComponentSM6.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pm  : @Msg }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : ContainedAuthData }.
  Context { gms : MsgStatus }.
  Context { dtc : @DTimeContext }.
  Context { qc  : @Quorum_context pn}.
  Context { iot : @IOTrustedFun }.

  Context { base_fun_io       : baseFunIO }.
  Context { base_state_fun    : baseStateFun }.
  Context { trusted_state_fun : trustedStateFun }.

  Fixpoint sm2update_p {n} {cn}
    : forall (sm : n_proc n cn), M_Update (pred n) cn (sf cn) :=
    match n with
    | 0 => fun sm => match sm with end
    | S m => fun sm =>
               match sm with
               | sm_or_at q => sm_update q
               | sm_or_sm q => fun s i => M_on_pred (sm2update_p q s i)
               end
    end.

  (* [k] is meant to be <= than [n] *)
  Definition M_to {n} k {O} (m : M_n n O) : M_n k O :=
    fun (ps : n_procs k) =>
      let (ps', o') := m (raise_to_n_procs _ ps)
      in (select_n_procs _ ps', o').

  (* [n] is meant to be <= than [k] *)
  Definition M_from {n} k {O} (m : M_n n O) : M_n k O :=
    fun (ps : n_procs k) =>
      let (ps', o') := m (select_n_procs _ ps)
      in (raise_to_n_procs _ ps', o').

  Lemma M_to_same :
    forall {n} {O} (m : M_n n O),
      M_to n m = m.
  Proof.
    introv.
    apply functional_extensionality; introv; simpl.
    unfold M_to; autorewrite with comp.
    dest_cases w; autorewrite with comp; auto.
  Qed.
  Hint Rewrite @M_to_same : comp.

  Lemma M_from_same :
    forall {n} {O} (m : M_n n O),
      M_from n m = m.
  Proof.
    introv.
    apply functional_extensionality; introv; simpl.
    unfold M_from; autorewrite with comp.
    dest_cases w; autorewrite with comp; auto.
  Qed.
  Hint Rewrite @M_from_same : comp.

  Lemma select_n_proc_incr_pred_n_proc :
    forall {cn} {k} n (sm : n_proc (pred k) cn),
      n <= pred k
      -> select_n_proc n (incr_pred_n_proc sm)
         = select_n_proc n sm.
  Proof.
    induction k; introv lek; simpl in *; tcsp;[].
    destruct n; auto;[].
    destruct (deq_nat k n); subst; auto;[].
    simpl; try omega.
  Qed.

  Lemma select_n_procs_incr_pred_n_procs :
    forall n k (l : n_procs (pred k)),
      n <= pred k
      -> select_n_procs n (incr_pred_n_procs l)
         = select_n_procs n l.
  Proof.
    induction l; introv len; simpl; tcsp;[].
    repeat (autodimp IHl hyp).
    unfold select_n_procs in *; simpl in *.
    destruct a as [cn p]; simpl.
    rewrite select_n_proc_incr_pred_n_proc; auto;[].
    remember (select_n_proc n p) as w; symmetry in Heqw.
    rewrite IHl; auto.
  Qed.

  Lemma M_to_M_on_pred :
    forall {n} {O} k (m : M_n (pred n) O),
      k <= pred n
      -> M_to k (M_on_pred m) = M_to k m.
  Proof.
    introv le.
    apply functional_extensionality; introv; simpl.
    unfold M_to, M_on_pred; simpl.
    autorewrite with comp.
    rewrite decr_n_procs_as_select_n_procs_pred.
    rewrite raise_to_n_procs_select_n_procs; try omega;[].
    remember (m (raise_to_n_procs (Init.Nat.pred n) x)) as p; repnd.
    rewrite select_n_procs_incr_pred_n_procs; auto.
  Qed.

  Lemma sm2update_as_sm2update_p :
    forall {n} {cn}
           (sm : n_proc n cn) s i,
      sm2update sm s i = M_to (sm2level sm) (sm2update_p sm s i).
  Proof.
    induction n; introv; simpl in *; tcsp.
    destruct sm as [sm|sm]; simpl in *; auto; autorewrite with comp; auto;[].
    rewrite IHn.
    pose proof (sm2level_le_pred _ _ sm) as q.
    rewrite M_to_M_on_pred; auto.
  Qed.

  Lemma sm2update_p_as_sm2update :
    forall {n} {cn}
           (sm : n_proc n cn) s i,
      sm2update_p sm s i = M_from (pred n) (sm2update sm s i).
  Proof.
    induction n; introv; simpl in *; tcsp.
    destruct sm as [sm|sm]; simpl in *; auto; autorewrite with comp; auto;[].
    rewrite IHn.
    pose proof (sm2level_le_pred _ _ sm) as q.

    apply functional_extensionality; introv; simpl.
    unfold M_on_pred, M_from.
    rewrite select_n_procs_decr_n_procs; auto.
    remember (sm2update sm s i (select_n_procs (sm2level sm) x)) as w; repnd; f_equal.
    rewrite incr_pred_n_procs_raise_to_n_procs; auto.
  Qed.

(*  Lemma app_m_proc_as_sm2update :
    forall {n} {cn}
           (sm : n_proc n cn)
           (i  : cio_I (fio cn)),
      app_m_proc sm i
      = ((sm2update_p sm (sm2state sm) i)
           >>>= fun s o => ret _ (update_state_or_halt_m sm s, o)).
  Proof.
    induction n; introv; simpl in *; tcsp.
    destruct sm as [sm|sm].

    { f_equal.
      apply functional_extensionality; introv; simpl.
      unfold lift_M_O, app_n_proc_at, bind_pair, bind; simpl.
      fold M_StateMachine in *.
      fold n_proc in *.
      remember (sm_update sm (sm_state sm) i x) as q; symmetry in Heqq; simpl in *; repnd; simpl.
      destruct q1; simpl; auto. }

    { rewrite IHn; simpl.
      f_equal.
      apply functional_extensionality; introv; simpl.
      unfold lift_M_O2, M_on_pred, bind_pair, bind; simpl.
      fold M_StateMachine in *.
      fold n_proc in *.
      remember (sm2update_p sm (sm2state sm) i (decr_n_procs x)) as q; repnd; simpl; auto.
      unfold update_state_or_halt_m; destruct q1; simpl; auto. }
  Qed.*)

  Lemma select_n_proc_raise :
    forall {n} {cn} i j (a : n_proc n cn) b,
      j <= i <= n
      -> select_n_proc j a = Some b
      -> select_n_proc i a = raise_to_n_proc i b.
  Proof.
    induction n; introv len sel; simpl in *; tcsp;[].
    destruct j; simpl in *; tcsp;[].
    destruct (deq_nat n j); subst; ginv.

    { assert (i = S j) by omega; subst.
      destruct (deq_nat j j); subst; simpl in *; tcsp.
      destruct (deq_nat j j); subst; simpl in *; tcsp.
      pose proof (UIP_refl_nat _ e) as z; subst; simpl in *.
      pose proof (UIP_refl_nat _ e0) as z; subst; simpl in *; auto. }

    destruct i; auto; simpl in *; auto; try omega;[].

    destruct (deq_nat n i); subst; simpl in *; try omega.

    { destruct (deq_nat j i); subst; simpl in *; auto;
        destruct a as [a|a]; ginv;[].

      pose proof (raise_to_n_proc_as_select_n_proc _ (S j) i a b) as q.
      autodimp q hyp; try omega.
      apply q in sel; clear q.
      rewrite sel; simpl; auto. }

    destruct (deq_nat j i); subst; try omega;
      destruct a as [a|a]; ginv;[].

    pose proof (IHn _ (S i) (S j) a b) as IHn.
    repeat (autodimp IHn hyp); try omega;[].
    rewrite IHn; simpl.
    destruct (deq_nat j i); subst; try omega; auto.
  Qed.

  Lemma select_n_nproc_raise :
    forall {n} i j (a : n_nproc n) b,
      j <= i <= n
      -> select_n_nproc j a = Some b
      -> select_n_nproc i a = raise_to_n_nproc i b.
  Proof.
    introv len sel.
    destruct a; simpl in *.
    apply option_map_Some in sel; exrepnd; subst; simpl in *.
    apply (select_n_proc_raise i) in sel1; auto.
    rewrite sel1; auto.
  Qed.

(*  Definition M_run_smat_on_inputs {n} {cn}
             (sm : n_proc_at n cn)
             (l  : list (cio_I (fio cn)))
             (i  : cio_I (fio cn))
    : M_n n (op_st_o cn) :=
    M_run_update_on_inputs (sm_state sm) (sm_update sm) l i.*)

(*  Definition halt_main_ls {L S} (ls : LocalSystem L S) : LocalSystem L S :=
    LocalSystem
      (halt_machine (ls_main ls))
      (ls_subs ls).*)

(*  Definition upd_ls_main_op_state_and_subs
             {L} {S}
             (ls : LocalSystem L S)
             (o  : option (sf _))
             (ss : n_procs _) : LocalSystem _ _ :=
    match o with
    | Some s => upd_ls_main_state_and_subs ls s ss
    | None => halt_main_ls (upd_ls_subs ls ss)
    end.*)

(*  Definition M_output_ls_on_input
             {Lv cn}
             (ls : LocalSystem Lv cn)
             (i  : cio_I (fio cn)) : LocalSystem _ _ * cio_O (fio cn) :=
    M_break
      (M_run_smat_on_inputs (ls_main ls) [] i)
      (ls_subs ls)
      (fun subs op =>
         match op with
         | Some (ops, o) => (upd_ls_main_op_state_and_subs ls ops subs, o)
         | None => (halt_main_ls (upd_ls_subs ls subs), cio_default_O (fio cn))
         end).*)

  Definition raise_to_n_proc_def {n} {cn} m (p : n_proc n cn) (d : n_proc m cn) : n_proc m cn :=
    opt_val (raise_to_n_proc m p) d.

  Lemma at2sm_update_state :
    forall n cn (p : n_proc_at n cn) s,
      at2sm (update_state p s)
      = update_state_m (at2sm p) s.
  Proof.
    tcsp.
  Qed.

(*  Lemma at2sm_halt_machine :
    forall n cn (p : n_proc_at n cn),
      at2sm (halt_machine p)
      = halt_machine_m (at2sm p).
  Proof.
    tcsp.
  Qed.*)

  Lemma raise_to_n_proc_update_state_m :
    forall m n cn (p : n_proc n cn) s,
      raise_to_n_proc m (update_state_m p s)
      = option_map
          (fun q => update_state_m q s)
          (raise_to_n_proc m p).
  Proof.
    induction m; introv; simpl in *; tcsp.

    { destruct (deq_nat n 0); subst; simpl in *; tcsp. }

    destruct (deq_nat n (S m)); subst; simpl in *; tcsp.
    rewrite IHm; clear IHm.
    repeat (rewrite option_map_option_map; unfold compose; simpl); auto.
  Qed.

(*  Lemma raise_to_n_proc_halt_machine_m :
    forall m n cn (p : n_proc n cn),
      raise_to_n_proc m (halt_machine_m p)
      = option_map halt_machine_m (raise_to_n_proc m p).
  Proof.
    induction m; introv; simpl in *; tcsp.

    { destruct (deq_nat n 0); subst; simpl in *; tcsp. }

    destruct (deq_nat n (S m)); subst; simpl in *; tcsp.
    rewrite IHm; clear IHm.
    repeat (rewrite option_map_option_map; unfold compose; simpl); auto.
  Qed.*)

  Lemma at2sm_sm2at :
    forall n cn (p : n_proc n cn),
      raise_to_n_proc n (at2sm (sm2at p)) = Some p.
  Proof.
    induction n; introv; simpl in *; tcsp;[].
    destruct p as [p|p]; simpl in *.

    { destruct (deq_nat n n); tcsp.
      pose proof (UIP_refl_nat _ e) as q; subst; simpl in *; auto. }

    destruct (deq_nat (sm2level p) n); subst; simpl in *; tcsp.

    { pose proof (sm2level_le_pred _ _ p) as q.
      rewrite e in q.
      destruct n; simpl in *; try omega. }

    rewrite IHn; simpl; auto.
  Qed.
  Hint Rewrite at2sm_sm2at : comp.

(*  Definition update_subs_with_sub_ls
             {n} {L} {cn}
             (subs : n_procs n)
             (sm   : n_proc n cn)
             (ls   : LocalSystem L cn) : n_procs n :=
    replace_subs
      (replace_name (raise_to_n_proc_def _ (at2sm (ls_main ls)) sm) subs)
      (raise_to_n_procs (pred n) (ls_subs ls)).*)

(*  Lemma M_break_call_comp :
    forall (cn : CompName) n O
           (i    : cio_I (fio cn))
           (subs : n_procs n)
           (F    : n_procs n -> cio_O (fio cn) -> O),
      M_break (call_proc cn i) subs F
      = match find_name cn subs with
        | Some sm =>

          let ls1 := MkLocalSystem (sm2at sm) (select_n_procs _ subs) in
          let (ls2, o) := M_output_ls_on_input ls1 i in
          F (update_subs_with_sub_ls subs sm ls2) o

        | None => F subs (cio_default_O (fio cn))
        end.
  Proof.
    introv.
    unfold M_break, call_proc, M_output_ls_on_input, M_output_sm_on_inputs; simpl.
    unfold update_subs_with_sub_ls.
    unfold M_run_smat_on_inputs, M_run_update_on_inputs; simpl.
    remember (find_name cn subs) as find; symmetry in Heqfind; destruct find; auto;[].
    rename n0 into p.

    autorewrite with comp.
    unfold M_break; simpl.
    rewrite app_m_proc_as_sm2update.
    rewrite sm2update_p_as_sm2update.
    unfold M_from, bind_pair, bind; simpl.
    rewrite select_n_procs_decr_n_procs; eauto 3 with comp;[].

    remember (sm2update p (sm2state p) i (select_n_procs (sm2level p) subs)) as w; repnd; simpl in *.
    f_equal.

    destruct w1; simpl; f_equal; f_equal.

    { rewrite at2sm_update_state.
      unfold raise_to_n_proc_def.
      rewrite raise_to_n_proc_update_state_m.
      autorewrite with comp; simpl; auto. }

    { rewrite at2sm_halt_machine.
      unfold raise_to_n_proc_def.
      rewrite raise_to_n_proc_halt_machine_m.
      autorewrite with comp; simpl; auto. }
  Qed.*)

(*  Lemma ls_subs_upd_ls_main_op_state_and_subs :
    forall {L S} (ls : LocalSystem L S) ops subs,
      ls_subs (upd_ls_main_op_state_and_subs ls ops subs) = subs.
  Proof.
    introv.
    destruct ops; simpl; auto.
  Qed.
  Hint Rewrite @ls_subs_upd_ls_main_op_state_and_subs : comp.*)

(*  Lemma is_proc_n_proc_at_upd_ls_main_op_state_and_subs :
    forall {L S} (ls : LocalSystem L S) ops subs,
      is_proc_n_proc_at (ls_main ls)
      -> is_proc_n_proc_at (upd_ls_main_op_state_and_subs ls ops subs).
  Proof.
    introv; destruct ops; simpl; auto.
  Qed.
  Hint Resolve is_proc_n_proc_at_upd_ls_main_op_state_and_subs : comp.*)

  Lemma is_proc_n_proc_at_update_implies_some :
    forall cn n (p : n_proc_at n cn) s i subs1 subs2 sop out,
      is_proc_n_proc_at p
      -> sm_update p s i subs1 = (subs2, (sop, out))
      -> exists s, sop = Some s.
  Proof.
    introv isp e.
    unfold is_proc_n_proc_at in isp; exrepnd.
    rewrite isp0 in e; clear isp0.
    unfold proc2upd in *; simpl in *.
    unfold interp_s_proc, to_proc_some_state in *; simpl in *.
    unfold bind_pair, bind in *; simpl in *.
    remember (interp_proc (p0 s i) subs1) as w; repnd; simpl in *; ginv; eauto.
    inversion e; subst; eauto.
  Qed.

(*  Lemma M_output_ls_on_input_preserves :
    forall {L S} (ls1 ls2 : LocalSystem L S) i o,
      wf_ls ls1
      -> are_procs_ls ls1
      -> M_output_ls_on_input ls1 i = (ls2, o)
      -> wf_ls ls2
         /\ are_procs_ls ls2
         /\ similar_sms_at (ls_main ls1) (ls_main ls2)
         /\ similar_subs (ls_subs ls1) (ls_subs ls2).
  Proof.
    introv wf aps out.
    unfold M_output_ls_on_input, M_break in out; simpl in *.
    dest_cases w; symmetry in Heqw.
    unfold M_run_smat_on_inputs in Heqw; simpl in *.
    unfold M_run_update_on_inputs, bind_some, bind in Heqw; simpl in *.
    unfold bind in Heqw; simpl in *.
    repeat (dest_cases w; repnd); ginv.
    inversion Heqw; subst; simpl in *; GC.
    clear Heqw.
    symmetry in Heqw1.
    destruct aps as [aps1 aps2].
    destruct wf as [wf1 wf2].
    pose proof (are_procs_implies_preserves_sub
                  (ls_main ls1)
                  (sm_state (ls_main ls1))
                  i
                  (ls_subs ls1)) as q.
    repeat (autodimp q hyp).
    unfold M_break in q.
    rewrite Heqw1 in q; simpl in *.
    repnd.
    unfold wf_ls, are_procs_ls; simpl.
    autorewrite with comp.
    applydup is_proc_n_proc_at_update_implies_some in Heqw1; auto;[].
    exrepd; subst; simpl in *.
    dands; eauto 3 with comp;[].
    apply similar_subs_preserves_procs_names in q0.
    rewrite <- q0; auto.
  Qed.*)

  Lemma M_break_snd_eq :
    forall {n} {A} {B}
           (m : M_n n (A * B))
           (subs : n_procs n),
      M_break m subs (fun _ out => snd out)
      = snd (M_break m subs (fun _ out => out)).
  Proof.
    introv.
    unfold M_break.
    destruct (m subs); auto.
  Qed.

  Lemma M_break_fst_eq :
    forall {n} {A} {B}
           (m : M_n n (A * B))
           (subs : n_procs n),
      M_break m subs (fun _ out => fst out)
      = fst (M_break m subs (fun _ out => out)).
  Proof.
    introv.
    unfold M_break.
    destruct (m subs); auto.
  Qed.

  Lemma M_break_fst_eq2 :
    forall {n} {A} {B}
           (m : M_n n (A * B))
           (subs : n_procs n),
      M_break m subs (fun _ out => fst out)
      = fst (snd (M_break m subs (fun subs out => (subs, out)))).
  Proof.
    introv.
    unfold M_break.
    destruct (m subs); auto.
  Qed.

  Lemma M_break_snd_eq2 :
    forall {n} {A} {B}
           (m : M_n n (A * B))
           (subs : n_procs n),
      M_break m subs (fun _ out => snd out)
      = snd (snd (M_break m subs (fun subs out => (subs, out)))).
  Proof.
    introv.
    unfold M_break.
    destruct (m subs); auto.
  Qed.

  Lemma M_break_option_map_fst_eq :
    forall {n} {A} {B} {O}
           (m : M_n n (option A * B))
           (subs : n_procs n) (F : n_procs n -> A -> O),
      M_break m subs (fun subs' out => option_map (F subs') (fst out))
      = let (subs',out) := M_break m subs (fun subs' out => (subs', out)) in
        option_map (F subs') (fst out).
  Proof.
    introv.
    unfold M_break.
    destruct (m subs); auto.
  Qed.

  Lemma similar_subs_nil_l :
    forall {n} (subs : n_procs n),
      similar_subs ([] : n_procs n) subs <-> subs = [].
  Proof.
    introv; split; intro q; subst; auto.
    inversion q; auto.
  Qed.
  Hint Rewrite @similar_subs_nil_l : comp.

  Definition sm2p0 {cn} (sm : MP_StateMachine (fun _ => False) cn) : n_proc_at 0 cn := sm.

  Lemma fold_build_m_sm :
    forall {n} {nm} (upd : M_Update n nm (sf nm)) (s : sf nm),
      at2sm (build_mp_sm upd s) = build_m_sm upd s.
  Proof.
    tcsp.
  Qed.
  Hint Rewrite @fold_build_m_sm : comp.

  Lemma update_state_m_sm_or_at_build_mp_sm :
    forall {cn} (upd : M_Update 0 cn (sf cn)) (s s' : sf cn),
      @update_state_m _ _ _ _ _ _ _ _ 1 cn (@sm_or_at _ False (build_mp_sm upd s)) s'
      = build_m_sm upd s'.
  Proof.
    tcsp.
  Qed.
  Hint Rewrite @update_state_m_sm_or_at_build_mp_sm : comp.

  Lemma lower_head_incr_n_procs :
    forall i {n} (l : n_procs n),
      lower_head i (incr_n_procs l)
      = lower_head i l.
  Proof.
    destruct l; simpl; auto.
    destruct n0; simpl in *; tcsp.
  Qed.
  Hint Rewrite lower_head_incr_n_procs : comp.

  Lemma ordered_subs_incr_n_procs :
    forall {n} (l : n_procs n),
      ordered_subs (incr_n_procs l)
      = ordered_subs l.
  Proof.
    unfold incr_n_procs; induction l; introv; simpl in *; tcsp.
    rewrite IHl; f_equal.
    destruct a; simpl.
    fold (incr_n_procs l); autorewrite with comp; auto.
  Qed.
  Hint Rewrite @ordered_subs_incr_n_procs : comp.

  Lemma get_names_incr_n_procs :
    forall {n} (l : n_procs n),
      get_names (incr_n_procs l)
      = get_names l.
  Proof.
    induction l; introv; simpl in *; tcsp.
    rewrite IHl.
    destruct a; simpl in *; tcsp.
  Qed.
  Hint Rewrite @get_names_incr_n_procs : comp.

  Lemma are_procs_n_procs_incr_n_procs :
    forall {n} (l : n_procs n),
      are_procs_n_procs l
      -> are_procs_n_procs (incr_n_procs l).
  Proof.
    introv aps i; apply in_map_iff in i; exrepnd; subst; simpl in *.
    apply aps in i0.
    destruct x; simpl in *; tcsp.
  Qed.
  Hint Resolve are_procs_n_procs_incr_n_procs : comp.

  Lemma similar_procs_incr_n_nproc_left_implies :
    forall {n} (p : n_nproc n) (k : n_nproc (S n)),
      similar_procs (incr_n_nproc p) k
      -> exists j, k = incr_n_nproc j /\ similar_procs p j.
  Proof.
    introv sim.
    inversion sim as [? ? ? ? sims]; clear sim; subst.
    match goal with
    | [ H : context[p1] |- _ ] => rename H into h1
    end.
    match goal with
    | [ H : context[p2] |- _ ] => rename H into h2
    end.
    apply Eqdep.EqdepTheory.inj_pair2 in h1; subst; eauto 3 with comp.
    apply Eqdep.EqdepTheory.inj_pair2 in h2; subst; eauto 3 with comp.
    simpl in *.
    destruct p, p1, p2; simpl in *; tcsp; inversion h1; subst; simpl in *.
    match goal with
    | [ H : context[b] |- _ ] => rename H into h3
    end.
    apply Eqdep.EqdepTheory.inj_pair2 in h3; subst; eauto 3 with comp.
    exists (MkPProc pp_name b0); simpl; tcsp.
  Qed.

  Lemma similar_subs_incr_n_procs_left_implies :
    forall {n} (l : n_procs n) (k : n_procs (S n)),
      similar_subs (incr_n_procs l) k
      -> exists j, k = incr_n_procs j /\ similar_subs l j.
  Proof.
    induction l; destruct k; introv sim; simpl in *; tcsp;
      inversion sim; subst; clear sim.
    { exists ([] : n_procs n); simpl; tcsp. }
    apply IHl in sims; clear IHl; exrepnd; subst; simpl in *.
    apply similar_procs_incr_n_nproc_left_implies in simp; exrepnd; subst.
    exists (j0 :: j); simpl; tcsp.
  Qed.

End ComponentSM6.

Hint Rewrite @M_to_same : comp.
Hint Rewrite @M_from_same : comp.
Hint Rewrite @at2sm_sm2at : comp.
(*Hint Rewrite @ls_subs_upd_ls_main_op_state_and_subs : comp.*)
Hint Rewrite @similar_subs_nil_l : comp.
Hint Rewrite @fold_build_m_sm : comp.
Hint Rewrite @update_state_m_sm_or_at_build_mp_sm : comp.
Hint Rewrite @lower_head_incr_n_procs : comp.
Hint Rewrite @ordered_subs_incr_n_procs : comp.
Hint Rewrite @get_names_incr_n_procs : comp.

Hint Resolve are_procs_n_procs_incr_n_procs : comp.

(*Hint Resolve is_proc_n_proc_at_upd_ls_main_op_state_and_subs : comp.*)

Ltac prove_wf :=
  match goal with
  | [ |- wf_procs _ ] =>
    repeat constructor; simpl; tcsp
  end.

Ltac prove_are_procs :=
  match goal with
  | [ |- are_procs_n_procs _ ] =>
    repeat constructor;
    [unfold is_proc_n_proc_at; eexists; introv; reflexivity
    |introv xx; simpl in *; tcsp]
  end.

(*Ltac m_output_ls_on_input_preserves H out :=
  match type of H with
  | M_output_ls_on_input ?ls1 ?i = (?ls2, ?o) =>
    let wf   := fresh "wf"   in
    let wf1  := fresh "wf1"  in
    let wf2  := fresh "wf2"  in
    let wf3  := fresh "wf3"  in
    let wf4  := fresh "wf4"  in
    let main := fresh "main" in
    let subs := fresh "subs" in
    autorewrite with comp minbft in H;
    applydup @M_output_ls_on_input_preserves in H as wf;
    try prove_wf;
    try prove_are_procs;
    destruct ls2 as [main subs]; simpl in *;
    simpl in wf;
    autorewrite with comp minbft in wf;
    destruct wf as [wf1 [wf2 [wf3 wf4]]];
    exrepnd; subst; simpl in *;
    rename o into out
  end.*)

(*Ltac abstract_m_output_ls_on_input H out :=
  match type of H with
  | context[M_output_ls_on_input ?ls ?i] =>
    let o := fresh "out" in
    remember (M_output_ls_on_input ls i) as o;
    repnd;
    match goal with
    | [ G : (_,_) = M_output_ls_on_input _ _ |- _ ] =>
      symmetry in G;
      simpl in H;
      m_output_ls_on_input_preserves G out
    end
  end.*)

(*Ltac use_m_break_call_comp out :=
  match goal with
  | [ H : context[call_proc ?n ?i] |- _ ] =>
    let h  := fresh "h" in
    let xx := fresh "xx" in
    pose proof (M_break_call_comp n) as h;
    rewrite h in H; clear h;
    remember @M_output_ls_on_input as xx;
    simpl in H; subst xx;
    abstract_m_output_ls_on_input H out
  end.*)


From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import memkv.

From Perennial.program_proof.memkv Require Export memkv_shard_definitions memkv_coord_definitions common_proof.
From Perennial.program_proof.memkv Require Import memkv_shard_clerk_proof.

(* Needed for ShardClerkSet GetClerk *)
From Perennial.program_proof.memkv Require Import memkv_coord_clerk_proof.

Section memkv_coord_start_proof.

Context `{!heapGS Σ, erpcG Σ, urpcregG Σ, kvMapG Σ}.

Lemma wp_encodeShardMap s (shardMap_sl : Slice.t) (shardMapping : list u64) :
  length shardMapping = int.nat uNSHARD →
  {{{ "Hs_ptr" ∷ s ↦[slice.T HostName] (slice_val shardMap_sl) ∗
      "HshardMap_sl" ∷ typed_slice.is_slice_small (V:=u64) shardMap_sl HostName 1 shardMapping
  }}}
    encodeShardMap #s
  {{{ (sl: Slice.t) (data: list u8), RET (slice_val sl);
      "%Henc" ∷ ⌜ has_encoding_shardMapping data shardMapping ⌝ ∗
      "Hdata" ∷  typed_slice.is_slice sl byteT 1 data ∗
      "Hs_ptr" ∷ s ↦[slice.T HostName] (slice_val shardMap_sl) ∗
      "HshardMap_sl" ∷ typed_slice.is_slice_small (V:=u64) shardMap_sl HostName 1 shardMapping
  }}}.
Proof.
  wp_pures. iIntros (Hshards Φ) "H HΦ".
  iNamed "H".
  wp_lam.

  wp_pures.
  wp_apply (wp_new_enc).
  iIntros (enc) "Henc".
  wp_pures.
  change (int.Z (word.mul 8 65536)) with (8 * 65536).

  wp_load.
  wp_apply (wp_Enc__PutInts with "[$Henc $HshardMap_sl]").
  { rewrite /uNSHARD in Hshards. rewrite Hshards. word. }
  iIntros "[Henc HshardMap_sl]".

  wp_apply (wp_Enc__Finish with "Henc").
  iIntros (rep_sl repData).
  iIntros "(%Henc & %Hlen & Hrep_sl)".
  iApply "HΦ". rewrite /named. iFrame. iPureIntro.
  rewrite /has_encoding_shardMapping. done.
Qed.

Lemma wp_KVCoord__AddServerRPC s x γ γsh :
  {{{ "#His_memkv" ∷ is_KVCoordServer s γ ∗
      "#His_shard" ∷ is_shard_server x γsh ∗
      "%Heq_kv_gn" ∷ ⌜γsh.(kv_gn) = γ.(coord_kv_gn)⌝
  }}}
    KVCoord__AddServerRPC #s #x
  {{{ RET #(); True%I }}}.
Proof.
  iIntros (Φ) "H HΦ".
  iNamed "H".
  wp_lam.
  wp_pures.
  iNamed "His_memkv".
  wp_loadField.
  wp_apply (acquire_spec with "[$HmuInv]").
  iIntros "[Hlocked Hown]".
  iNamed "Hown".
  wp_pures.
  wp_loadField.
  wp_apply (wp_MapInsert with "[$]").
  { eauto. }
  iIntros "Hmap".
  wp_pures.
  wp_loadField.
  wp_apply (wp_MapLen (V:=u64) with "[$Hmap]").
  remember (size (typed_map.map_insert hostShards x 0)) as num_shards eqn:Heq_num_shards.
  iIntros "(%Hmap_size&Hmap)".
  wp_pures.
  wp_apply (wp_ref_of_zero _ _ (uint64T)).
  { econstructor. }
  iIntros (nf_left_ptr) "Hnf_left".
  wp_pures.
  wp_apply (wp_StoreAt with "[$]").
  { naive_solver. }
  iIntros "Hnf_left".
  wp_pures.
  wp_loadField.
  iDestruct (typed_slice.is_slice_small_acc with "HshardMap_sl") as "(HshardMap_sl&HshardMap_clo)".
  wp_bind (forSlice _ _ _).
  rewrite /forSlice.
  wp_pures.
  wp_apply (wp_slice_len).
  (* wp_pures would reduce too far *)
  wp_pure (goose_lang.Rec _ _ _).
  wp_pure (goose_lang.App _ _).
  wp_pure (goose_lang.Rec _ _ _).

  (* We want to generalize over the loop argument, which is 0, but there are many occurrences of 0.
     This is a hack to only eplace that one occurence. *)
  pose (k' := U64 0).
  assert (k' = 0) as Heqk by auto.
  iEval (rewrite -{-1}Heqk).
  clear Heqk. remember k' as k eqn:Heqk. clear Heqk.

  remember ((word.sub (word.sub num_shards 65536)
                                          (word.divu (word.mul num_shards 65536) num_shards)))
           as nf_left eqn:Hnf_left.
  clear Hnf_left.

  remember ((typed_map.map_insert hostShards x 0)) as hostShards'.
  clear HeqhostShards'.
  clear Heq_num_shards.
  iLöb as "IH" forall (k hostShards' nf_left shardMapping Hlen_shardMapping HshardMapping_dom) "HshardServers".
  wp_pures.
  iFreeze "IH".
  wp_if_destruct; last first.
  { iClear "IH". wp_pures. wp_loadField. wp_apply (release_spec with "[-HΦ]").
    { iFrame "Hlocked HmuInv". iNext. iExists _, _, _, _, _.
      iDestruct ("HshardMap_clo" with "[$]") as "$".
      iFrame. iSplit; eauto. }
    wp_pures. iApply "HΦ". eauto. }
  iDestruct (typed_slice.is_slice_small_sz (V:=u64) with "[$]") as %Hsz.
  edestruct (list_lookup_lt _ (shardMapping) (int.nat k)) as (v&Heq).
  { word_cleanup. }
  wp_apply (typed_slice.wp_SliceGet (V:=u64) with "[HshardMap_sl]").
  { rewrite /HostName. iFrame "HshardMap_sl". iPureIntro. eauto. }
  iIntros "HshardMap_sl". wp_pures.
  wp_loadField. wp_apply (wp_MapGet with "[$]").
  iIntros (v' ok) "(%Hget&Hmap)".
  wp_pures.
  wp_if_destruct; last first.
  { wp_pure (goose_lang.Rec _ _ _).
    wp_pure (goose_lang.App _ _).
    iThaw "IH".
    wp_pure (_ + _)%E.
    iApply ("IH" $! _ with "[//] [//] [$] [$] [$] [$] [$] [$] [$] [$] [$] [$] [$]").
  }
  wp_pures.
  wp_if_destruct.
  {
    wp_apply (wp_LoadAt with "[$]").
    iIntros "Hnf_left_ptr". wp_pures.
    wp_if_destruct.
    {
      wp_apply (wp_LoadAt with "[$]").
      iIntros "Hnf_left_ptr". wp_pures.
      wp_apply (wp_StoreAt with "[$]").
      { naive_solver. }
      iIntros "Hnf_left_ptr". wp_pures.
      wp_loadField.
      rewrite /all_are_shard_servers.
      iDestruct ("HshardServers" $! _ _ with "[//]") as (γh) "(His_shard_host&Heq)".
      wp_apply (wp_ShardClerkSet__GetClerk with "[$]").
      iIntros (ck_ptr) "(Hclerk&Hclerk_clo)".
      wp_bind (KVShardClerk__MoveShard #ck_ptr #_ #x).
      wp_apply (wp_KVShardClerk__MoveShard with "[$Hclerk]").
      { iFrame "#His_shard". iPureIntro.
        eapply lookup_lt_Some in Heq. lia. }
      iIntros "Hclerk".
      wp_pures.
      wp_loadField.
      wp_apply (wp_MapInsert with "[$]").
      { naive_solver. }
      iIntros "Hmap".
      wp_pures.
      wp_loadField.
      wp_apply (wp_MapGet with "[$]").
      iIntros (v' ok') "(%Hget'&Hmap)".
      wp_pures. wp_loadField.
      wp_apply (wp_MapInsert with "[$]").
      { naive_solver. }
      iIntros "Hmap".
      wp_pures.
      wp_loadField.
      wp_apply (typed_slice.wp_SliceSet (V:=u64) with "[$HshardMap_sl]").
      { eauto. }
      iIntros "HshardMap_sl".
      wp_pure (goose_lang.Rec _ _ _).
      wp_pure (goose_lang.App _ _).
      iThaw "IH".
      wp_pure (_ + _)%E.
      iDestruct ("Hclerk_clo" with "[$]") as "Hclerk".
      iApply ("IH" $! _ (typed_map.map_insert
                  (typed_map.map_insert hostShards' v (word.sub (word.add (word.divu 65536 _) 1) 1))
                  x (word.add v' 1)) with "[] [] [$] [$] [$] [$] [$] [$] [$] [$] [$] [$]").
      { iPureIntro. rewrite insert_length. eauto. }
      { iPureIntro. intros i Hlt.
        destruct (decide (i = k)).
        { subst. rewrite list_lookup_insert; eauto.
          word. }
        { rewrite list_lookup_insert_ne; eauto.
          intros Heq'.
          apply Z2Nat.inj in Heq'; try word.
          eapply (int_Z_inj) in Heq'; eauto. apply _.
        }
      }
      iModIntro. iIntros (? Hin Hlookup').
      destruct (decide (sid = int.nat k)).
      {
        subst. rewrite list_lookup_insert in Hlookup'; last by word.
        iExists _. inversion Hlookup'; subst. iFrame "His_shard".
        eauto.
      }
      iClear "IH".
      rewrite list_lookup_insert_ne in Hlookup'; last by word.
      iApply "HshardServers"; eauto.
    }
    wp_pure (goose_lang.Rec _ _ _).
    wp_pure (goose_lang.App _ _).
    wp_pure (_ + _)%E.
    iThaw "IH".
    iApply ("IH" $! _ _ with "[//] [//] [$] [$] [$] [$] [$] [$] [$] [$] [$] [$] [$]").
  }
  {
    wp_loadField.
      rewrite /all_are_shard_servers.
      iDestruct ("HshardServers" $! _ _ with "[//]") as (γh) "(His_shard_host&Heq)".
      wp_apply (wp_ShardClerkSet__GetClerk with "[$]").
      iIntros (ck_ptr) "(Hclerk&Hclerk_clo)".
      wp_bind (KVShardClerk__MoveShard #ck_ptr #_ #x).
      wp_apply (wp_KVShardClerk__MoveShard with "[$Hclerk]").
      { iFrame "#His_shard". iPureIntro.
        eapply lookup_lt_Some in Heq. lia. }
      iIntros "Hclerk".
      wp_pures.
      wp_loadField.
      wp_apply (wp_MapInsert with "[$]").
      { naive_solver. }
      iIntros "Hmap".
      wp_pures.
      wp_loadField.
      wp_apply (wp_MapGet with "[$]").
      iIntros (v'' ok'') "(%Hget'&Hmap)".
      wp_pures. wp_loadField.
      wp_apply (wp_MapInsert with "[$]").
      { naive_solver. }
      iIntros "Hmap".
      wp_pures.
      wp_loadField.
      wp_apply (typed_slice.wp_SliceSet (V:=u64) with "[$HshardMap_sl]").
      { eauto. }
      iIntros "HshardMap_sl".
      wp_pure (goose_lang.Rec _ _ _).
      wp_pure (goose_lang.App _ _).
      iThaw "IH".
      wp_pure (_ + _)%E.
      iDestruct ("Hclerk_clo" with "[$]") as "Hclerk".
      iApply ("IH" $! _ _ with "[] [] [$] [$] [$] [$] [$] [$] [$] [$] [$] [$]").
      { iPureIntro. rewrite insert_length. eauto. }
      { iPureIntro. intros i Hlt.
        destruct (decide (i = k)).
        { subst. rewrite list_lookup_insert; eauto.
          word. }
        { rewrite list_lookup_insert_ne; eauto.
          intros Heq'.
          apply Z2Nat.inj in Heq'; try word.
          eapply (int_Z_inj) in Heq'; eauto. apply _.
        }
      }
      iModIntro. iIntros (? Hin Hlookup').
      destruct (decide (sid = int.nat k)).
      {
        subst. rewrite list_lookup_insert in Hlookup'; last by word.
        iExists _. inversion Hlookup'; subst. iFrame "His_shard".
        eauto.
      }
      iClear "IH".
      rewrite list_lookup_insert_ne in Hlookup'; last by word.
      iApply "HshardServers"; eauto.
    }
Qed.

Lemma wp_KVCoordServer__Start (s:loc) (host : u64) γ :
handlers_dom γ.(coord_urpc_gn) {[ U64 1; U64 2 ]} -∗
is_coord_server host γ -∗
is_KVCoordServer s γ -∗
  {{{
       True
  }}}
    KVCoord__Start #s #host
  {{{
       RET #(); True
  }}}.
Proof.
  iIntros "#Hdom #His_coord #His_memkv !#" (Φ) "_ HΦ".
  wp_lam.
  wp_pures.
  wp_apply map.wp_NewMap.
  iIntros (handlers_ptr) "Hmap".
  wp_pures.

  wp_apply (map.wp_MapInsert with "Hmap").
  iIntros "Hmap".
  wp_pures.
  rewrite /KVCoord__GetShardMapRPC.

  wp_apply (map.wp_MapInsert with "Hmap").
  iIntros "Hmap".
  wp_pures.

  wp_apply (wp_MakeServer with "[$Hmap]").
  iIntros (rs) "Hsown".
  wp_pures.

  iNamed "His_coord".
  wp_apply (wp_StartServer with "[$Hsown]").
  { rewrite ?dom_insert_L; set_solver. }
  {
    iSplitL "".
    { rewrite /handlers_complete.
      rewrite ?dom_insert_L dom_empty_L. iExactEq "Hdom". f_equal. set_solver. }
    iApply (big_sepM_insert_2 with "").
    { (* GetShardMapping RPC handler_is *)
      iExists _.
      iFrame "#HgetSpec".

      clear Φ.
      rewrite /impl_handler_spec.
      iIntros (??????) "!#".
      iIntros (Φ) "Hpre HΦ".
      wp_pures.
      iDestruct "Hpre" as "(Hreq_sl & Hrep & _ & Hpre)".
      simpl.
      iDestruct "Hpre" as (_) "[_ Hpost]".
      iNamed "His_memkv".
      wp_loadField.
      wp_apply (acquire_spec with "[$HmuInv]").
      iIntros "[Hlocked Hown]".
      iNamed "Hown".
      wp_pures.
      wp_apply (wp_struct_fieldRef_mapsto with "[$shardMap]").
      { eauto. }
      iIntros (fl) "(H1&H2)".
      iDestruct (typed_slice.is_slice_small_acc with "HshardMap_sl") as "[HshardMap_sl HshardMap_close]".
      wp_apply (wp_encodeShardMap with "[$]").
      { word_cleanup. rewrite wrap_small; last (rewrite /uNSHARD; lia).
        rewrite -Hlen_shardMapping. lia. }
      iIntros (sl data) "(%Henc&H)".
      wp_apply (wp_StoreAt with "[$]").
      { apply slice_val_ty. }
      iIntros "Hrep".
      iNamed "H".
      iDestruct ("HshardMap_close" with "HshardMap_sl") as "HshardMap_sl".
      iDestruct (is_slice_to_small with "Hdata") as "Hdata".
      wp_pures.
      wp_loadField.
      wp_apply (release_spec with "[-HΦ Hpost Hrep Hdata]").
      { iFrame "Hlocked HmuInv".
        iNext. iExists _, _, _, _, _. iFrame. iFrame "#". iFrame "%".
        iDestruct "H1" as %Hequiv. iApply Hequiv. iFrame. }
      wp_pures. iApply "HΦ". iFrame. iApply "Hpost". iModIntro. iExists _. iFrame "% #".
    }
    iApply (big_sepM_insert_2 with "").
    { (* AddServerRPC *)
      iExists _.
      iFrame "#HaddSpec".

      clear Φ.
      rewrite /impl_handler_spec.
      iIntros (??????) "!#".
      iIntros (Φ) "Hpre HΦ".
      wp_pures.
      iDestruct "Hpre" as "(Hreq_sl & Hrep & Hrep_sl & Hpre)".
      iDestruct (is_slice_to_small with "Hrep_sl") as "Hrep_sl".
      simpl.
      iDestruct "Hpre" as (x) "[Hpre Hpost]".
      iDestruct "Hpre" as "(%Henc&Hshard)".
      iDestruct "Hshard" as (γsh Heq) "#His_shard".
      wp_apply (wp_DecodeUint64' with "[$Hreq_sl]"); first by eauto.
      wp_pures.
      simpl in x.
      wp_apply (wp_KVCoord__AddServerRPC with "[]").
      { iSplitL "".
        { rewrite /named. iExactEq "His_memkv". eauto. }
        iFrame "His_shard". eauto.
      }
      wp_pures. iApply "HΦ". iFrame. iApply "Hpost". eauto.
    }
    rewrite big_sepM_empty. eauto.
  }
  wp_pures. iApply "HΦ".
  auto.
Qed.

End memkv_coord_start_proof.


Set Implicit Arguments.
Require Import Metalib.Metatheory.
Require Import Program.Equality.
Require Export Antisymmetry.

Lemma label_transform3: forall (X X0:atom) T D,
    X \notin fl_tt T \u {{X0}} ->
    type D ->
    open_tt (subst_label X (subst_tt X (typ_label X D) T))
             (typ_label X0 (open_tt (subst_label X (subst_tt X (typ_label X D) T)) X0))
      = subst_label X (subst_tt X (typ_label X D) (open_tt T (typ_label X0 (open_tt T X0)))).
Proof with auto.
  intros.
  rewrite  subst_tt_open_tt ...
  rewrite subst_label_open_tt ...
  f_equal...
  rewrite drop_label_reverse_type...
  rewrite drop_label_reverse_type...
  solve_notin.
Qed.

Lemma label_transform4 : forall (X X0:atom) T D,
    X \notin fl_tt T \u {{X0}} ->
    type D ->
    (open_tt (subst_label X (subst_tt X (typ_label X D) T)) X0) = (subst_label X (subst_tt X (typ_label X D) (open_tt T X0))).
Proof with auto.
  intros.
  rewrite <- subst_label_open_tt_var...
  f_equal...
  rewrite subst_tt_open_tt_var...
Qed.

Lemma binds_subst_label_existial : forall E X Y T U,
    binds X (bind_sub U) (map (drop_label Y) (map (subst_tb Y (typ_label Y T)) E)) ->
    exists Q,
      binds X (bind_sub Q) E.
Proof with auto.
  induction E;intros;simpl in *...
  analyze_binds H...
  destruct a.
  analyze_binds H...
  2: {
    destruct IHE with (X:=X) (Y:=Y) (U:=U) (T:=T)...
    exists x...
  }
  destruct b;simpl in *.
  dependent destruction BindsTacVal.
  exists t...
  inversion BindsTacVal.
Qed.

Lemma WF_narrowing_env_subst_inv: forall E1 E2 (X:atom) Y S,
    WF (map (subst_tb Y S) E1 ++ Y ~ bind_sub typ_top ++ E2) X ->
    WF (E1 ++ Y ~ bind_sub typ_top ++ E2) X.
Proof with auto.
  induction E1;intros...
  simpl in *.
  destruct a.
  dependent destruction H...
  analyze_binds H...
  -
    destruct b.
    apply WF_var with (U:=t)...
    simpl in *.
    inversion BindsTacVal...
  -
    rewrite_env (nil ++ (a~ b) ++ E1 ++ (Y, bind_sub typ_top) :: E2).
    apply WF_weakening...
    apply IHE1  with (S:=S)...
    apply WF_var with (U:=U)...
  -
    apply WF_var with (U:=typ_top)...
  -
    apply WF_var with (U:=U)...
Qed.

Lemma binds_subst_extensial: forall E S T X0 X U,
    binds X0 (bind_sub U) (map (subst_tb X S) E) ->
    exists A,
      binds X0 (bind_sub A) (map (subst_tb X T) E).
Proof with auto.
  induction E;intros...
  simpl in *.
  analyze_binds H.
  simpl in *.
  destruct a.
  analyze_binds H.
  -
    destruct b;simpl in *; inversion BindsTacVal.
    exists (subst_tt X T t)...
  -
    apply IHE with (T:=T) in BindsTac...
    destruct_hypos.
    exists x...
Qed.

Lemma WF_narrowing_env: forall E1 E E2 A S T X,
    WF (E1 ++ map (subst_tb X S) E ++ E2) A ->
    WF (E1 ++ map (subst_tb X T) E ++ E2) A.
Proof with auto.
  intros.
  dependent induction H;try solve [analyze_binds H;eauto]...
  -
    analyze_binds H; try solve [apply WF_var with (U:=U);auto].
    apply binds_subst_extensial with (T:=T) in BindsTac0.
    destruct_hypos.
    apply WF_var with (U:=x)...
  -
    apply WF_all with (L:=L )...
    apply IHWF with (S0:=S)...
    intros.
    rewrite_env ((X0 ~ bind_sub T1 ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H1 with (S0:=S)...
  -
    apply WF_rec with (L:=L );intros...
    rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H0 with (S0:=S)...
    rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ map (subst_tb X T) E ++ E2).
    eapply H2 with (S0:=S)...
Qed.

Lemma sub_map_inv_var: forall X Y X0 C E1 E2,
    X <> Y -> X0 <> Y ->
  sub (map (subst_tb Y C) E1 ++ (Y, bind_sub typ_top) :: E2) X X0 ->
  sub (map (subst_tb Y C) E1 ++ (Y, bind_sub typ_top) :: E2) X0 X ->
  wf_env (E1 ++ (Y, bind_sub typ_top) :: E2) ->
  sub (E1 ++ (Y, bind_sub typ_top) :: E2) X X0.
Proof with auto.
  intros.
  pose proof suba_sub_tvar_chain H1.
  pose proof suba_sub_tvar_chain H2.
  destruct H4 as [W1 ?].
  destruct H5 as [W2 ?].
  pose proof sub_tvar_chain_antisym H4 H5.
  subst.
  apply sa_fvar...
  get_well_form.
  apply WF_narrowing_env_subst_inv in H6...
Qed.

Lemma subst_label_collect3': forall T i X,
    rt_type T -> type T ->
    i `in` collectLabel T ->
    i `in` collectLabel (subst_label X T).
Proof with auto.
  intros.
  induction H0;try solve [inversion H]...
  simpl in *.
  apply union_iff in H1. apply union_iff.
  destruct H1...
Qed.

Lemma subst_tt_collect2': forall T i X A,
    i `in` collectLabel T ->
    rt_type T ->
    type T ->
    i `in` collectLabel (subst_tt X A T).
Proof with auto.
  intros.
  induction H1;try solve [inversion H0]...
  simpl in *.
  apply union_iff in H. apply union_iff.
  destruct H...
Qed.

Lemma drop_label_reverse_wf: forall E1 E2 C D A X,
    WF (map (drop_label X) (map (subst_tb X (typ_label X C)) E1) ++
            (X, bind_sub typ_top) :: E2)
       (subst_label X (subst_tt X (typ_label X D) A)) ->
    X \notin fl_tt A -> type D ->
    WF (E1 ++ (X, bind_sub typ_top) :: E2) A.
Proof with auto.
  intros.
  assert (type A) as HA.
  get_type...
  rewrite drop_label_reverse_type in H...
  apply type_to_rec in HA.
  generalize dependent E1.
  generalize dependent E2.
  generalize dependent C.
  generalize dependent D.
  generalize dependent X.
  induction HA;intros;simpl in *;try solve [dependent destruction H;auto]...
  -
    destruct (X==X0);subst...
    +
      apply WF_var with (U:=typ_top)...
    +
      simpl in H...
      dependent destruction H...
      analyze_binds H...
      apply binds_subst_label_existial in BindsTac.
      destruct_hypos.
      apply WF_var with (U:=x)...
      apply WF_var with (U:=U)...
  -
    dependent destruction H.
    constructor...
    apply IHHA1 with (C:=C) (D:=D)...
    apply IHHA2 with (C:=C) (D:=D)...
  -
    dependent destruction H5.
    apply WF_rec with (L:=L \u L0 \u {{X}});intros...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H2 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- subst_tt_open_tt_var...
      rewrite  subst_label_open_tt_var...
      apply H5...
    +
      rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- label_transform3...
      apply H6...
  -
    dependent destruction H3.
    apply WF_all with (L:=L \u L0 \u {{X}});intros...
    +
      apply IHHA with (C:=C) (D:=D)...
    +
      rewrite_env ((X0 ~ bind_sub T1 ++ E1) ++ (X, bind_sub typ_top) :: E2).
      apply H0 with (C:=C) (D:=D)...
      solve_notin.
      rewrite <- label_transform4...
      simpl.
      rewrite drop_label_reverse_type...
      assert (T1 = subst_label X (subst_tt X (typ_label X D) T1)).
      rewrite drop_label_reverse_type ...
      rewrite H6.
      apply H4...
  -
    destruct (l==X);subst...
    +
      apply notin_union  in H0.
      destruct_hypos.
      apply test_solve_notin_7 in H0.
      destruct H0.
    +
      dependent destruction H.
      constructor...
      apply IHHA with (C:=C) (D:=D)...
  -
    dependent destruction H2...
    apply WF_rcd_cons...
    + apply IHHA1 with (D:=D) (C:=C)...
    + apply IHHA2 with (D:=D) (C:=C)...
    + intros Hc.
      apply H3.
      apply subst_label_collect3' with (X:=X)...
      { apply Infrastructure.subst_tt_rt_type... }
      { apply subst_tt_type... apply type4rec_to_type... }
      apply subst_tt_collect2'...
      apply type4rec_to_type...
Qed.

Lemma WF_nominal_inversion: forall E1 E2 X A (X0:atom) D C,
    WF (X0 ~ bind_sub typ_top ++
           map (subst_tb X (typ_label X (open_tt C X))) E1 ++ (X, bind_sub typ_top) :: E2)
          (open_tt (subst_tt X (typ_label X (open_tt D X)) A) X0)->
    X \notin {{X0}} \u fl_tt A  ->
    wf_env (X0 ~ bind_sub typ_top ++
           map (subst_tb X (typ_label X (open_tt C X))) E1 ++ (X, bind_sub typ_top) :: E2) ->
    type (open_tt D X) ->
    WF (X0 ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2) (open_tt A X0) .
Proof with auto.
  intros.
  rewrite subst_tt_open_tt_var in H...
  rewrite_env ((X0 ~ bind_sub typ_top ++
           map (subst_tb X (typ_label X (open_tt C X))) E1) ++ (X, bind_sub typ_top) :: E2) in H.
  apply WF_drop_label in H...
  simpl in H...
  rewrite_env ((X0 ~ bind_sub typ_top ++ E1) ++ (X, bind_sub typ_top) :: E2).
  apply drop_label_reverse_wf with (C:=open_tt C X) (D:=open_tt D X)...
  solve_notin.
Qed.

Ltac inv_rt :=
  try solve [
    repeat match goal with
    | [ H : rt_type ?T |- _ ] => inversion H;clear H
    end
      ].

Lemma Tlookup_first_element: forall i T1 T2,
    Tlookup i (typ_rcd_cons i T1 T2) = Some T1.
Proof with auto.
  intros.
  simpl.
  destruct (i==i);subst...
  destruct n...
Qed.

Lemma dropLable_notin: forall T2 i E,
    WF E T2 ->
    rt_type T2 ->
    i `notin` collectLabel T2 ->
    dropLabel i T2 = T2.
Proof with eauto.
  intros.
  induction H;try solve [inversion H0]...
  simpl in *.
  destruct (i0==i);subst...
  apply notin_union in H1.
  destruct_hypos.
  apply test_solve_notin_7 in H1...
  destruct H1.
  f_equal...
Qed.

Lemma dropLabel_first_element: forall E i T1 T2,
    WF E (typ_rcd_cons i T1 T2) ->
    dropLabel i (typ_rcd_cons i T1 T2) = T2.
Proof with auto.
  intros.
  dependent destruction H...
  simpl...
  destruct (i==i)...
  apply dropLable_notin with (E:=E)...
  destruct n...
Qed.

Lemma dom_add_subset: forall a E T,
    a \notin E \u T ->
    add a E [<=] add a T ->
    E [<=] T.
Proof with auto.
  intros.
  unfold "[<=]" in *.
  intros.
  specialize (H0 a0).
  assert (a0 \in add a E).
  apply AtomSetImpl.add_2...
  apply H0 in H2.
  apply KeySetProperties.FM.add_iff in H2...
  destruct H2...
  subst...
  assert (False).
  apply H...
  destruct H2.
Qed.

Lemma dom_notin_in: forall (X Y:atom) E,
    X \notin E ->
    Y \in E ->
          X <> Y.
Proof with auto.
  intros...
  unfold "\notin" in *...
  intros.
  apply H...
  subst...
Qed.

Lemma union_swap_assoc: forall A B C,
    A \u B \u C [=] B \u A \u C.
Proof with auto.
  intros.
  rewrite <- AtomSetProperties.union_assoc...
  rewrite <- AtomSetProperties.union_assoc...
  assert (union A B [=] union B A).
  apply AtomSetProperties.union_sym...
  rewrite H...
  apply AtomSetProperties.equal_refl...
Qed.

Lemma drop_collect_flip: forall E A i,
    WF E A ->
    rt_type A ->
    i \in collectLabel A ->
    {{i}} \u collectLabel (dropLabel i A) [=] collectLabel A.
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  -
    simpl in *.
    apply empty_iff in H1.
    destruct H1.
  -
    simpl in *...
    destruct (i0==i);subst.
    +
      apply KeySetProperties.union_equal_2...
      rewrite <- notin_drop_collect_self...
      apply AtomSetProperties.equal_refl...
    +
      simpl in *.
      rewrite union_swap_assoc...
      apply KeySetProperties.union_equal_2...
      apply IHWF2...
      apply AtomSetImpl.union_1 in H1.
      destruct H1...
      apply AtomSetImpl.singleton_1 in H1...
      destruct n...
Qed.

Lemma record_permutation: forall S2 T2 E i j T1 S1,
    equiv E (typ_rcd_cons i T1 T2) (typ_rcd_cons j S1 S2) ->
    j \in collectLabel (typ_rcd_cons i T1 T2) /\
          (exists T0, Tlookup j (typ_rcd_cons i T1 T2) = Some T0 /\ equiv E T0 S1) /\
          equiv E (dropLabel j (typ_rcd_cons i T1 T2)) S2.
Proof with auto.
  unfold equiv.
  intros.
  destruct_hypos.
  dependent destruction H.
  dependent destruction H6.
  destruct (j==i);subst...
  -
    repeat split...
    +
      apply label_belong with (B:=T1)...
      apply Tlookup_first_element...
    +
      exists T1.
      repeat split...
      apply Tlookup_first_element...
      apply H5 with (i0:=i)...
      apply Tlookup_first_element...
      apply Tlookup_first_element...
      apply H12 with (i0:=i)...
      apply Tlookup_first_element...
      apply Tlookup_first_element...
    +
      rewrite dropLabel_first_element with (E:=E)...
      dependent destruction H3.
      dependent destruction H6.
      dependent destruction H3;dependent destruction H6.
      *
        apply Reflexivity...
      *
        simpl in H2...
        simpl in H7.
        rewrite <- KeySetProperties.add_union_singleton in H2.
        rewrite <- KeySetProperties.add_union_singleton in H2.
        rewrite <- KeySetProperties.add_union_singleton in H2.
        apply dom_add_subset in H2...
        rewrite KeySetProperties.add_union_singleton in H2.
        apply union_empty in H2...
        destruct H2.
      *
        simpl in H12...
        simpl in H4.
        rewrite <- KeySetProperties.add_union_singleton in H12.
        rewrite <- KeySetProperties.add_union_singleton in H12.
        rewrite <- KeySetProperties.add_union_singleton in H12.
        apply dom_add_subset in H12...
        rewrite KeySetProperties.add_union_singleton in H12.
        apply union_empty in H12...
        destruct H12.
      *
        constructor...
        --
          simpl in *...
          rewrite <- KeySetProperties.add_union_singleton in H2.
          rewrite <- KeySetProperties.add_union_singleton in H2.
          rewrite <- KeySetProperties.add_union_singleton in H2.
          rewrite <- KeySetProperties.add_union_singleton in H2.
          apply dom_add_subset in H2...
          rewrite <- KeySetProperties.add_union_singleton.
          rewrite <- KeySetProperties.add_union_singleton...
        --
          intros.
          apply H5 with (i2:=i2)...
          ++
            assert (Hq1:=H3).
            assert (Hq2:=H6).
            apply label_belong in Hq1.
            apply label_belong in Hq2.
            apply dom_notin_in with (X:=i) in Hq1...
            apply dom_notin_in with (X:=i) in Hq2...
            simpl...
            destruct (i==i2);subst...
            destruct Hq1...
          ++
            assert (Hq1:=H3).
            assert (Hq2:=H6).
            apply label_belong in Hq1.
            apply label_belong in Hq2.
            apply dom_notin_in with (X:=i) in Hq1...
            apply dom_notin_in with (X:=i) in Hq2...
            simpl...
            destruct (i==i2);subst...
            destruct Hq1...
    +
      rewrite dropLabel_first_element with (E:=E)...
      dependent destruction H3.
      dependent destruction H6.
      dependent destruction H3;dependent destruction H6.
      *
        apply Reflexivity...
      *
        simpl in H2...
        simpl in H7.
        rewrite <- KeySetProperties.add_union_singleton in H2.
        rewrite <- KeySetProperties.add_union_singleton in H2.
        rewrite <- KeySetProperties.add_union_singleton in H2.
        apply dom_add_subset in H2...
        rewrite KeySetProperties.add_union_singleton in H2.
        apply union_empty in H2...
        destruct H2.
      *
        simpl in H12...
        simpl in H4.
        rewrite <- KeySetProperties.add_union_singleton in H12.
        rewrite <- KeySetProperties.add_union_singleton in H12.
        rewrite <- KeySetProperties.add_union_singleton in H12.
        apply dom_add_subset in H12...
        rewrite KeySetProperties.add_union_singleton in H12.
        apply union_empty in H12...
        destruct H12.
      *
        constructor...
        --
          simpl in *...
          rewrite <- KeySetProperties.add_union_singleton in H12.
          rewrite <- KeySetProperties.add_union_singleton in H12.
          rewrite <- KeySetProperties.add_union_singleton in H12.
          rewrite <- KeySetProperties.add_union_singleton in H12.
          apply dom_add_subset in H12...
          rewrite <- KeySetProperties.add_union_singleton.
          rewrite <- KeySetProperties.add_union_singleton...
        --
          intros.
          apply H14 with (i2:=i2)...
          ++
            assert (Hq1:=H3).
            assert (Hq2:=H6).
            apply label_belong in Hq1.
            apply label_belong in Hq2.
            apply dom_notin_in with (X:=i) in Hq1...
            apply dom_notin_in with (X:=i) in Hq2...
            simpl...
            destruct (i==i2);subst...
            destruct Hq1...
          ++
            assert (Hq1:=H3).
            assert (Hq2:=H6).
            apply label_belong in Hq1.
            apply label_belong in Hq2.
            apply dom_notin_in with (X:=i) in Hq1...
            apply dom_notin_in with (X:=i) in Hq2...
            simpl...
            destruct (i==i2);subst...
            destruct Hq1...
  -
    simpl in H2...
    assert (j \in collectLabel T2) as Hj.
    {
      assert (j `in` collectLabel (typ_rcd_cons i T1 T2)) as HH.
      auto.
      simpl in HH.
      apply AtomSetImpl.union_1 in HH...
      destruct HH...
      apply AtomSetImpl.singleton_1 in H13.
      destruct n...
    }
    repeat split...
    +
      apply lookup_some in Hj...
      destruct Hj.
      exists x...
      repeat split...
      *
        simpl...
        destruct (i==j);subst...
        destruct n...
      *
        apply H5 with (i0:=j)...
        simpl...
        destruct (i==j);subst...
        destruct n...
        simpl...
        destruct (j==j);subst...
        destruct n0...
      *
        apply H12 with (i0:=j)...
        simpl...
        destruct (j==j);subst...
        destruct n0...
        simpl...
        destruct (i==j);subst...
        destruct n...
    +
      dependent destruction H3.
      dependent destruction H5.
      constructor...
      *
        apply rt_type_drop with (E:=E)...
      *
        simpl in *.
        destruct (i==j);subst...
        destruct n...
        clear H7 H14.
        simpl.
        apply dom_add_subset with (a:=j)...
        solve_notin.
        apply notin_drop_self...
        rewrite  KeySetProperties.add_union_singleton.
        rewrite  KeySetProperties.add_union_singleton...
        rewrite union_swap_assoc...
        rewrite drop_collect_flip with (E:=E)...
      *
        apply WF_drop...
      *
        intros.
        apply H7 with (i0:=i0)...
        --
          apply Tlookup_drop in H15...
        --
          assert (Ht:=H16).
          apply label_belong in Ht.
          apply dom_notin_in with (Y:=i0) in H6...
          simpl...
          destruct (j==i0);subst...
          destruct H6...
    +
      dependent destruction H3.
      dependent destruction H5.
      constructor...
      *
        apply rt_type_drop with (E:=E)...
      *
        simpl in *.
        destruct (i==j);subst...
        destruct n...
        clear H7 H14.
        simpl.
        apply dom_add_subset with (a:=j)...
        solve_notin.
        apply notin_drop_self...
        rewrite  KeySetProperties.add_union_singleton.
        rewrite  KeySetProperties.add_union_singleton...
        rewrite union_swap_assoc...
        rewrite drop_collect_flip with (E:=E)...
      *
        apply WF_drop...
      *
        intros.
        apply H14 with (i0:=i0)...
        --
          assert (Ht:=H15).
          apply label_belong in Ht.
          apply dom_notin_in with (Y:=i0) in H6...
          simpl...
          destruct (j==i0);subst...
          destruct H6...
        --
          apply Tlookup_drop in H16...
Qed.

Lemma lookup_some_in_fl_tt : forall i A x E,
    WF E A -> rt_type A ->
    Tlookup i A = Some x->
    fl_tt x [<=] fl_tt A.
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  inversion H1...
  simpl in *.
  destruct (i0==i);subst...
  inversion H1;subst...
  rewrite union_swap_assoc...
  apply KeySetProperties.union_subset_1...
  apply IHWF2 in H1...
  rewrite KeySetProperties.union_sym...
  apply union_subset_6...
  rewrite KeySetProperties.union_sym...
  apply union_subset_6...
Qed.

Lemma lookup_some_subst: forall i A T E X B,
    WF E A -> rt_type A ->
    Tlookup i A = Some T->
    Tlookup i (subst_tt X B A) = Some (subst_tt X B T).
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  inversion H1...
  simpl in *.
  destruct (i0==i);subst...
  inversion H1...
Qed.

Lemma fl_tt_dropLabel : forall E i T,
    WF E T -> rt_type T ->
    fl_tt (dropLabel i T) [<=] fl_tt T.
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  simpl in *...
  apply AtomSetProperties.FM.Subset_refl...
  simpl in *...
  destruct (i0==i);subst...
  -
    apply IHWF2 in H2...
    rewrite KeySetProperties.union_sym...
    apply union_subset_6...
    rewrite KeySetProperties.union_sym...
    apply union_subset_6...
  -
    simpl in *.
    apply union_subset_x...
    apply union_subset_x...
Qed.

Lemma subst_tt_rcd_cons: forall i X B A D,
    typ_rcd_cons i (subst_tt X D A) (subst_tt X D B) = subst_tt X D (typ_rcd_cons i A B).
Proof with auto.
  intros...
Qed.

Lemma subst_tt_collectLabel_in: forall E T X i D,
    WF E T -> rt_type T ->
    i \in  collectLabel T ->
           i `in` collectLabel (subst_tt X D T).
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  simpl in *...
  apply AtomSetImpl.union_1 in H1.
  destruct H1...
Qed.

Lemma subst_tt_dropLabel: forall i T X A E,
    WF E T -> rt_type T ->
    subst_tt X A (dropLabel i T) = dropLabel i (subst_tt X A T).
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  simpl in *...
  destruct (i0==i);subst...
  simpl...
  f_equal...
Qed.

Lemma dropLabel_fv_tt : forall E T A i,
    WF E T -> rt_type T ->
    Tlookup i T = Some A ->
    fv_tt T [=] union (fv_tt A) (fv_tt (dropLabel i T)).
Proof with auto.
  intros.
  induction H;try solve [inversion H0]...
  simpl in *...
  inversion H1...
  simpl in *.
  destruct (i0==i);subst...
  -
    rewrite dropLable_notin with (E:=E)...
    inversion H1;subst...
    apply KeySetProperties.equal_refl...
  -
    simpl...
    apply IHWF2 in H1...
    rewrite H1.
    rewrite union_swap_assoc...
    apply KeySetProperties.equal_refl...
Qed.

Lemma subst_reverse_equiv: forall A,
    type4rec A -> forall B, type4rec B ->
    forall X C D E1 E2 S,
    X \notin fl_tt A \u fl_tt B \u fv_tt S \u fv_tt C \u fv_tt D->
    equiv (map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2 ) (subst_tt X (typ_label X (open_tt C X)) A) (subst_tt X (typ_label X (open_tt D X)) B) ->
    equiv (E1 ++ (X, bind_sub typ_top) :: E2) A B ->
    WF ((X, bind_sub typ_top) :: E2) (open_tt C X) ->
    WF ((X, bind_sub typ_top) :: E2) (open_tt D X) ->
    WF ((X, bind_sub typ_top) :: E2) (open_tt S X) ->
    wf_env (E1 ++ (X, bind_sub typ_top) :: E2) ->
    (equiv ((X, bind_sub typ_top) ::E2) (open_tt C X)  (open_tt D X) \/ (X \notin fv_tt A \u fv_tt B )) .
Proof with auto.
  unfold equiv.
  intros A HA;induction HA;
    intros B HB;induction HB;intros;destruct_hypos;simpl in *;try solve [
      inversion H0;inv_rt|
      inversion H1;inv_rt|
      inversion H2;inv_rt|
      inversion H3;inv_rt|
      inversion H4;inv_rt|
      inversion H5;inv_rt|
      inversion H6;inv_rt|
      inversion H7;inv_rt|
      inversion H8;inv_rt|
      inversion H9;inv_rt|
      inversion H10;inv_rt|
      destruct (X==X0);subst;auto;inversion H0;inv_rt]...
  - destruct (X==X1);destruct (X0==X1);subst...
    +
      dependent destruction H0;inv_rt.
      dependent destruction H7;inv_rt.
      left.
      apply wf_env_cons in H5...
      apply sub_strengthening_env in H0...
      apply sub_strengthening_env in H7...
    +
      inversion H0;inv_rt...
    +
      inversion H7;inv_rt...
  -
    dependent destruction H0;inv_rt.
    dependent destruction H7;inv_rt.
    dependent destruction H1;inv_rt.
    dependent destruction H6;inv_rt.
    clear IHHB1 IHHB2.
    destruct IHHA1 with (B:=T0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S)...
    destruct IHHA2 with (B:=T3) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S)...
  -
    clear H4 H6.
    dependent destruction H8;inv_rt.
    dependent destruction H15;inv_rt.
    dependent destruction H12;inv_rt.
    dependent destruction H15;inv_rt.
    pick fresh Y.
    assert (type (open_tt C X)) by (get_type;auto).
    assert (type (open_tt D X)) by (get_type;auto).
    destruct H0 with (X:=Y) (X0:=X) (B:=open_tt T0 (typ_label Y (open_tt T0 Y))) (C:=C) (D:=D) (E1:=Y~bind_sub typ_top ++E1) (E2:=E2) (S:=S)...
    +
      solve_notin.
    +
      split.
      *
        rewrite_env (Y ~ bind_sub typ_top ++
                     map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
      rewrite subst_tt_open_tt_twice...
      rewrite subst_tt_open_tt_twice...
      *
        rewrite_env (Y ~ bind_sub typ_top ++
                     map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
      rewrite subst_tt_open_tt_twice...
      rewrite subst_tt_open_tt_twice...
    +
      split.
      *
        apply H14...
      *
        apply H17...
    +
      rewrite_env (Y ~ bind_sub typ_top ++ E1 ++ (X, bind_sub typ_top) :: E2)...
    +
      right.
      apply notin_union in H24.
      destruct_hypos.
      apply notin_fv_open_inv in H24.
      apply notin_fv_open_inv in H25...
  -
    clear H2 IHHB.
    dependent destruction H4;inv_rt.
    dependent destruction H11;inv_rt.
    dependent destruction H5;inv_rt.
    dependent destruction H10;inv_rt.
    destruct IHHA with (B:=T0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:= E2) (S:=S)...
    clear IHHA.
    pick fresh Y.
    destruct H0 with (B:=open_tt T3 Y) (X:=Y) (X0:=X) (C:=C) (D:=D) (E1:=Y ~ bind_sub T1 ++E1) (E2:=E2) (S:=S);clear H0...
    +
      solve_notin.
    +
      split.
      *
        rewrite <- subst_tt_open_tt_var...
        rewrite <- subst_tt_open_tt_var...
        rewrite_env (nil ++ Y ~ bind_sub (subst_tt X (typ_label X (open_tt S X)) T1) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing with (Q:=subst_tt X (typ_label X (open_tt D X)) T0)...
        --
          clear Fr.
          assert (subst_tt X (typ_label X (open_tt D X)) T0 = subst_tt X (typ_label X (open_tt S X)) T0).
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite H0.
          assert (equiv (X ~ bind_sub typ_top ++ E2) (typ_label X (open_tt S X)) (typ_label X (open_tt S X))).
          {
            apply wf_env_cons in H10.
            unfold equiv;split;constructor;
            apply Reflexivity...
          }
          apply equiv_sub_subst...
        --
          apply H2...
        --
          get_type...
        --
          get_type...
      *
        rewrite <- subst_tt_open_tt_var...
        rewrite <- subst_tt_open_tt_var...
        rewrite_env (nil ++ Y ~ bind_sub (subst_tt X (typ_label X (open_tt S X)) T1) ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing with (Q:=subst_tt X (typ_label X (open_tt C X)) T1)...
        --
          clear Fr.
          assert (subst_tt X (typ_label X (open_tt C X)) T1 = subst_tt X (typ_label X (open_tt S X)) T1).
          {
            rewrite <- subst_tt_fresh...
            rewrite <- subst_tt_fresh...
          }
          rewrite H0.
          assert (equiv (X ~ bind_sub typ_top ++ E2) (typ_label X (open_tt S X)) (typ_label X (open_tt S X))).
          {
            apply wf_env_cons in H10.
            unfold equiv;split;constructor;
            apply Reflexivity...
          }
          apply equiv_sub_subst_refl...
          get_well_form...
        --
          apply H4...
        --
          get_type...
        --
          get_type...
    +
      split.
      *
        rewrite_env (nil ++ Y ~ bind_sub T1 ++ E1 ++ (X, bind_sub typ_top) :: E2).
        apply sub_narrowing with (Q:=T0)...
        apply H5...
      *
        rewrite_env (Y ~ bind_sub T1 ++ E1 ++ (X, bind_sub typ_top) :: E2).
        apply H6...
    +
      rewrite_env (Y ~ bind_sub T1 ++ E1 ++ (X, bind_sub typ_top) :: E2)...
      constructor...
      get_well_form...
    +
      right.
      apply notin_union in H12.
      destruct_hypos.
      apply notin_fv_open_inv in H0.
      apply notin_fv_open_inv in H12.
      solve_notin.
  -
    dependent destruction H0;inv_rt...
    dependent destruction H7;inv_rt...
    dependent destruction H1;inv_rt.
    dependent destruction H6;inv_rt.
    clear IHHB.
    destruct IHHA with (B:=A0) (X:=X) (C:=C) (D:=D) (E1:=E1) (E2:=E2) (S:=S)...
  -
    dependent destruction H2...
    collect_nil H5.
  -
    dependent destruction H7...
    collect_nil H6.
  -
    clear IHHB1 IHHB2.
    assert (equiv (E1 ++ (X, bind_sub typ_top) :: E2) (typ_rcd_cons i0 T0 T3)  (typ_rcd_cons i T1 T2)) as HE.
    { unfold equiv;split... }
    apply record_permutation in HE...
    unfold equiv in *.
    destruct_hypos.
    destruct IHHA1 with (B:=x) (X:=X) (E1:=E1) (E2:=E2) (C:=C) (D:=D) (S:=S)...
    +
      apply type_to_rec.
      get_type...
    +
      solve_notin.
      apply lookup_some_in_fl_tt with (E:=(E1 ++ (X, bind_sub typ_top) :: E2)) in H11...
      simpl in *.
      apply notin_partial with (E2:=union (singleton i0) (union (fl_tt T0) (fl_tt T3)))...
      get_well_form...
    +
      split.
      *
        clear IHHA1 IHHA2 H9.
        dependent destruction H2.
        apply H8 with (i1:=i)...
        --
          simpl...
          destruct (i==i);subst...
          destruct n...
        --
          rewrite subst_tt_rcd_cons...
          apply lookup_some_subst with (E:=(E1 ++ (X, bind_sub typ_top) :: E2))...
          get_well_form...
      *
        clear IHHA1 IHHA2 H2.
        dependent destruction H9.
        apply H8 with (i1:=i)...
        --
          rewrite subst_tt_rcd_cons...
          apply lookup_some_subst with (E:=(E1 ++ (X, bind_sub typ_top) :: E2))...
          get_well_form...
        --
          simpl...
          destruct (i==i);subst...
          destruct n...
    +
      destruct IHHA2 with (B:=dropLabel i (typ_rcd_cons i0 T0 T3)) (X:=X) (E1:=E1) (E2:=E2) (C:=C) (D:=D) (S:=S)...
      *
        apply type_to_rec.
        get_type...
      *
        solve_notin.
        destruct (i0==i);subst...
        --
          apply notin_partial with (E2:=fl_tt T3)...
          apply fl_tt_dropLabel with (E:=(E1 ++ (X, bind_sub typ_top) :: E2))...
          get_well_form...
          dependent destruction H30...
        --
          simpl.
          solve_notin.
          apply notin_partial with (E2:=fl_tt T3)...
          apply fl_tt_dropLabel with (E:=(E1 ++ (X, bind_sub typ_top) :: E2))...
          get_well_form...
          dependent destruction H25...
      *
        clear IHHA1 IHHA2.
        split.
        --
          clear H9.
          dependent destruction H2.
          constructor...
          ++
            apply subst_tt_rt_type with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_weakening...
            get_well_form...
          ++
            apply subst_tt_rt_type with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_weakening...
            apply rt_type_drop with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            get_well_form...
            apply WF_drop...
            get_well_form...
          ++
            simpl in *...
            destruct (i0==i);subst...
            **
              apply union_subset_x2 in H5...
              apply KeySetFacts.Subset_trans with (s':=collectLabel (subst_tt X (typ_label X (open_tt D X)) T3))...
              rewrite subst_tt_dropLabel with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              simpl...
              apply drop_coolect_less...
              get_well_form.
              dependent destruction H31...
              dependent destruction H7...
            **
              assert ( WF (E1 ++ (X, bind_sub typ_top) :: E2) T3).
              {
                get_well_form.
                dependent destruction H33...
              }
              simpl in *...
              rewrite subst_tt_dropLabel with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              apply union_subset_x2 with (a:=i).
              rewrite union_swap_assoc...
              rewrite drop_collect_flip with (E:=E1 ++ (X, bind_sub typ_top) :: E2) ...
              apply subst_tt_wf...
              rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
              apply WF_weakening...
              apply subst_tt_rt_type with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
              rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
              apply WF_weakening...
              apply subst_tt_collectLabel_in with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
              apply  union_iff in H15.
              destruct H15...
              apply F.singleton_iff in H15...
              destruct n...
              solve_notin.
              apply notin_drop_self...
          ++
            rewrite_env (nil ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_narrowing_env with (S:=typ_label X (open_tt C X)).
            simpl.
            apply subst_tb_wf2 with (Q:=bind_sub typ_top)...
            get_well_form...
          ++
            rewrite_env (nil ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_narrowing_env with (S:=typ_label X (open_tt D X)).
            apply subst_tb_wf2 with (Q:=bind_sub typ_top)...
            get_well_form...
          ++
            intros.
            assert (Ht:=H23).
            apply label_belong in Ht.
            simpl...
            apply H8 with (i1:=i1)...
            **
              rewrite subst_tt_dropLabel with (E:=E1 ++ (X, bind_sub typ_top) :: E2) in Ht...
              apply dom_notin_in with (X:=i) in Ht...
              simpl...
              destruct (i==i1);subst...
              destruct Ht...
              apply notin_drop_self...
              get_well_form...
            **
              rewrite subst_tt_dropLabel with (E:=E1 ++ (X, bind_sub typ_top) :: E2) in H23...
              apply Tlookup_drop in H23...
              get_well_form...
        --
          clear H2.
          dependent destruction H9.
          constructor...
          ++
            apply subst_tt_rt_type with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_weakening...
            apply rt_type_drop with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            get_well_form...
            apply WF_drop...
            get_well_form...
          ++
            apply subst_tt_rt_type with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_weakening...
            get_well_form...
          ++
            simpl in *...
            destruct (i0==i);subst...
            **
              get_well_form.
              dependent destruction H30.
              dependent destruction H32.
              apply union_subset_x2 in H5...
              rewrite subst_tt_dropLabel with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              rewrite dropLable_notin with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              apply subst_tt_wf...
              rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
              apply WF_weakening...
              apply subst_tt_rt_type with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
              apply WF_weakening...
              apply subst_tt_collect with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              apply subst_tt_collect with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
            **
              assert ( WF (E1 ++ (X, bind_sub typ_top) :: E2) T3).
              {
                get_well_form.
                dependent destruction H33...
              }
              simpl in *...
              rewrite subst_tt_dropLabel with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
              apply union_subset_x2 with (a:=i).
              rewrite union_swap_assoc...
              rewrite drop_collect_flip with (E:=E1 ++ (X, bind_sub typ_top) :: E2) ...
              apply subst_tt_wf...
              rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
              apply WF_weakening...
              apply subst_tt_rt_type with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
              rewrite_env (nil ++ E1 ++ (X, bind_sub typ_top) :: E2).
              apply WF_weakening...
              apply subst_tt_collectLabel_in with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
              apply  union_iff in H15.
              destruct H15...
              apply F.singleton_iff in H15...
              destruct n...
              solve_notin.
              get_well_form.
              dependent destruction H32.
              apply subst_tt_collect with (E:= E1 ++ (X, bind_sub typ_top) :: E2)...
          ++
            rewrite_env (nil ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_narrowing_env with (S:=typ_label X (open_tt D X)).
            simpl.
            apply subst_tb_wf2 with (Q:=bind_sub typ_top)...
            get_well_form...
          ++
            rewrite_env (nil ++ map (subst_tb X (typ_label X (open_tt S X))) E1 ++ (X, bind_sub typ_top) :: E2).
            apply WF_narrowing_env with (S:=typ_label X (open_tt C X)).
            apply subst_tb_wf2 with (Q:=bind_sub typ_top)...
            get_well_form...
          ++
            intros.
            assert (Ht:=H22).
            apply label_belong in Ht.
            apply H8 with (i1:=i1)...
            **
              rewrite subst_tt_dropLabel with (E:=E1 ++ (X, bind_sub typ_top) :: E2) in H22...
              apply Tlookup_drop in H22...
              get_well_form...
            **
              rewrite subst_tt_dropLabel with (E:=E1 ++ (X, bind_sub typ_top) :: E2) in Ht...
              apply dom_notin_in with (X:=i) in Ht...
              simpl...
              destruct (i==i1);subst...
              destruct Ht...
              apply notin_drop_self...
              get_well_form...
      *
        clear IHHA1 IHHA2.
        right.
        simpl in *.
        destruct (i0==i);subst.
        --
          inversion H11;subst.
          get_well_form.
          dependent destruction H26.
          rewrite dropLable_notin  with (E:=E1 ++ (X, bind_sub typ_top) :: E2) in H34...
        --
          simpl in *.
          assert (fv_tt T3 [=] fv_tt x \u fv_tt (dropLabel i T3)).
          {
            rewrite <- dropLabel_fv_tt with (E:=E1 ++ (X, bind_sub typ_top) :: E2)...
            apply  KeySetProperties.equal_refl...
            get_well_form.
            dependent destruction H26...
          }
          rewrite H18...
Qed.


From DeepWeb Require Export
     Observe.

CoFixpoint match_event {T R} (e0 : observeE R) (r : R) (m : itree oE T)
  : itree oE T :=
  match observe m with
  | RetF x  => Ret x
  | TauF m' => Tau (match_event e0 r m')
  | VisF e k =>
    match e with
    | (||||oe) =>
      match oe in observeE Y, e0 in observeE R return (Y -> _) -> R -> _ with
      | Observe__Send c0, Observe__Send c =>
        if (c0 =? c)%nat
        then
          fun k pkt =>
            (* embed Log ("Match Send " ++ to_string pkt);; *)
            k pkt
        else fun _ _ =>
               (* embed Log ("Mismatch Send: expect to " ++ to_string c *)
               (*         ++ ", but observed to " ++ to_string c0);; *)
               throw "Sent from different connection"
      | Observe__Select, Observe__Select =>
        fun k cs =>
          k cs
      | Observe__Recv, Observe__Recv =>
        fun k pkt =>
          (* embed Log ("Match Recv " ++ to_string pkt);; *)
          k pkt
      | _, _ => fun _ _ => throw "Unexpected event"
      end k r
    | _ => vis e (match_event e0 r ∘ k)
    end
  end.

Definition match_observe {T R} (e : observeE T) (r : T) (l : list (itree oE R))
  : list (itree oE R) := map (match_event e r) l.

Variant genE : Type -> Set :=
  Gen : connT -> genE packetT.

Class Is__tE E `{genE -< E} `{nondetE -< E}
      `{failureE -< E} `{logE -< E} `{netE -< E}.
Notation tE := (genE +' nondetE +' failureE +' logE +' netE).
Instance tE_Is__tE : Is__tE tE. Defined.

CoFixpoint tester' {E R} `{Is__tE E} (others : list (itree oE R)) (m : itree oE R)
  : itree E R :=
  match observe m with
  | RetF r  => ret r
  | TauF m' => Tau (tester' others m')
  | VisF e k =>
    let catch (err : string) : itree E R :=
      embed Log ("Catch " ++ err ++ " with " ++ to_string (List.length others)
                          ++ " other branches");;
      match others with
      | [] => throw err
      | other :: others' =>
        Tau (tester' others' other)
      end in
    match e with
    | (Throw err|) => catch err
    | (|ne|) =>
      match ne in nondetE Y return (Y -> _) -> _ with
      | Or => fun k => b <- trigger Or;;
                   Tau (tester' others (k b))
      end k
    | (||de|) =>
      match de in decideE Y return (Y -> _) -> _ with
      | Decide =>
        fun k => b <- trigger Or;;
              Tau (tester' (others ++ [k (negb b)]) (k b))
      end k
    | (|||le|) =>
      match le in logE Y return (Y -> _) -> _ with
      | Log str => fun k => embed Log ("Observer: " ++ str);;
                        Tau (tester' others (k tt))
      end k
    | (||||oe) =>
      match oe in observeE Y return (Y -> _) -> _ with
      | Observe__Select =>
        fun k =>
          cs <- fst <$> sublist conns;;
          Tau (tester' (match_observe Observe__Select cs others) (k cs))
      | Observe__Send c =>
        fun k =>
          pkt <- embed Gen c;;
          embed Net__Send pkt;;
          (* embed Log ("Sent " ++ to_string pkt);; *)
          Tau (tester' (match_observe (Observe__Send c) pkt others) (k pkt))
      | Observe__Recv =>
        fun k =>
          conns <- trigger Net__Select;;
          match conns with
          | [] =>
            match others with
            | [] => Tau (tester' [] m)
            | other :: others' =>
              (* embed Log ("Not ready to receive, try other " *)
              (*         ++ to_string (List.length others') ++ " branches");; *)
              Tau (tester' (others' ++ [m]) other)
            end
          | c :: _ =>
            pkt <- embed Net__Recv c;;
            (* embed Log ("Recv " ++ to_string pkt);; *)
            Tau (tester' (match_observe Observe__Recv pkt others) (k pkt))
          end
      end k
    end
  end.

Definition tester {E R} `{Is__tE E} : itree oE R -> itree E R := tester' [].


From iris.algebra Require Import frac.
From iris.proofmode Require Import tactics.
Require Import Eqdep_dec List.
From cap_machine Require Import rules.
From cap_machine Require Export iris_extra addr_reg_sample region_macros contiguous stack_macros_helpers.

Section stack_macros.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ}
          `{MP: MachineParameters}.

  (* --------------------------------------------------------------------------------- *)
  (* ------------------------------------- FETCH ------------------------------------- *)
  (* --------------------------------------------------------------------------------- *)

  Definition fetch_instrs (f : Z) :=
    [move_r r_t1 PC;
    getb r_t2 r_t1;
    geta r_t3 r_t1;
    sub_r_r r_t2 r_t2 r_t3;
    lea_r r_t1 r_t2;
    load_r r_t1 r_t1;
    lea_z r_t1 f;
    move_z r_t2 0;
    move_z r_t3 0;
    load_r r_t1 r_t1].

  Definition fetch f a : iProp Σ :=
    ([∗ list] a_i;w_i ∈ a;(fetch_instrs f), a_i ↦ₐ w_i)%I.

  (* fetch spec *)
  Lemma fetch_spec f a pc_p pc_g pc_b pc_e a_first a_last b_link e_link a_link entry_a wentry φ w1 w2 w3:
    isCorrectPC_range pc_p pc_g pc_b pc_e a_first a_last ->
    contiguous_between a a_first a_last ->
    withinBounds (RW, Global, b_link, e_link, entry_a) = true ->
    (a_link + f)%a = Some entry_a ->

      ▷ fetch f a
    ∗ ▷ PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_first)
    ∗ ▷ pc_b ↦ₐ inr (RO,Global,b_link,e_link,a_link)
    ∗ ▷ entry_a ↦ₐ wentry
    ∗ ▷ r_t1 ↦ᵣ w1
    ∗ ▷ r_t2 ↦ᵣ w2
    ∗ ▷ r_t3 ↦ᵣ w3
    (* if the capability is global, we want to be able to continue *)
    (* if w is not a global capability, we will fail, and must now show that Phi holds at failV *)
    ∗ ▷ (PC ↦ᵣ inr (pc_p,pc_g,pc_b,pc_e,a_last) ∗ fetch f a
            (* the newly allocated region *)
            ∗ r_t1 ↦ᵣ wentry ∗ r_t2 ↦ᵣ inl 0%Z ∗ r_t3 ↦ᵣ inl 0%Z
            ∗ pc_b ↦ₐ inr (RO,Global,b_link,e_link,a_link)
            ∗ entry_a ↦ₐ wentry
            -∗ WP Seq (Instr Executable) {{ φ }})
    ⊢
      WP Seq (Instr Executable) {{ φ }}.
  Proof.
    iIntros (Hvpc Hcont Hwb Hentry) "(>Hprog & >HPC & >Hpc_b & >Ha_entry & >Hr_t1 & >Hr_t2 & >Hr_t3 & Hφ)".
    iDestruct (big_sepL2_length with "Hprog") as %Hlength.
    destruct a as [|a l];[inversion Hlength|].
    apply contiguous_between_cons_inv_first in Hcont as Heq. subst.
    (* move r_t1 PC *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_move_success_reg_fromPC with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 0|auto|..].
    iEpilogue "(HPC & Hprog_done & Hr_t1)".
    (* getb r_t2 r_t1 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr_t2 $Hr_t1]");
      [apply decode_encode_instrW_inv|auto|iCorrectPC a_first a_last|iContiguous_next Hcont 1|auto..].
    iEpilogue "(HPC & Hi & Hr_t1 & Hr_t2) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* geta r_t3 r_t1 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_Get_success with "[$HPC $Hi $Hr_t3 $Hr_t1]");
      [apply decode_encode_instrW_inv|auto|iCorrectPC a_first a_last|iContiguous_next Hcont 2|auto..].
    iEpilogue "(HPC & Hi & Hr_t1 & Hr_t3) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* sub r_t2 r_t2 r_t3 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_add_sub_lt_success_dst_r with "[$HPC $Hi $Hr_t3 $Hr_t2]");
      [apply decode_encode_instrW_inv|auto|iContiguous_next Hcont 3|iCorrectPC a_first a_last|..].
    iEpilogue "(HPC & Hi & Hr_t3 & Hr_t2) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* lea r_t1 r_t2 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    assert ((a_first + (pc_b - a_first))%a = Some pc_b) as Hlea;[solve_addr|].
    iApply (wp_lea_success_reg with "[$HPC $Hi $Hr_t1 $Hr_t2]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 4|apply Hlea|auto..].
    { apply contiguous_between_length in Hcont.
      apply isCorrectPC_range_perm in Hvpc; [|revert Hcont; clear; solve_addr].
      destruct Hvpc as [-> | [-> | ->] ]; auto. }
    { apply contiguous_between_length in Hcont.
      assert (a_first < a_last)%Z as Hlt;[simpl in Hcont;solve_addr|].
      apply isCorrectPC_inrange with (a:=a_first) in Hvpc;[|lia].
      destruct pc_p;auto;inversion Hvpc;solve_addr. }
    iEpilogue "(HPC & Hi & Hr_t2 & Hr_t1) /="; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* load r_t1 r_t1 *)
    destruct l;[inversion Hlength|].
    assert (readAllowed pc_p = true) as Hra.
    { eapply pc_range_readA;eauto. }
    iPrologue "Hprog".
    iAssert (⌜(pc_b ≠ a3)%Z⌝)%I as %Hneq.
    { iIntros (Hcontr);subst.
      iDestruct (addr_dupl_false with "Hi Hpc_b") as %Hne; auto. }
    iApply (wp_load_success_same with "[$HPC $Hi $Hr_t1 Hpc_b]");
      [|apply decode_encode_instrW_inv|iCorrectPC a_first a_last|auto| |iContiguous_next Hcont 5|..].
    { exact (inr (RW, Global, b_link, e_link, a_link)). }
    { apply contiguous_between_length in Hcont as Hlen.
      assert (pc_b < pc_e)%Z as Hle.
      { eapply isCorrectPC_contiguous_range in Hvpc as Hwb';[|eauto|apply elem_of_cons;left;eauto].
        inversion Hwb'. solve_addr. }
      apply isCorrectPC_range_perm in Hvpc as Heq; [|revert Hlen; clear; solve_addr].
      apply andb_true_intro. split;[apply Z.leb_le;solve_addr|apply Z.ltb_lt;auto].
    }
    { destruct (pc_b =? a3)%a; [done|iFrame]. }
    destruct ((pc_b =? a3)%a) eqn:Hcontr;[apply Z.eqb_eq in Hcontr;apply z_of_eq in Hcontr;congruence|clear Hcontr].
    iEpilogue "(HPC & Hr_t1 & Hi & Hpc_b)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* lea r_t1 f *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_lea_success_z with "[$HPC $Hi $Hr_t1]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 6|apply Hentry|simpl;auto..].
    iEpilogue "(HPC & Hi & Hr_t1)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t2 0 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t2]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 7|auto|..].
    iEpilogue "(HPC & Hi & Hr_t2)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* move r_t3 0 *)
    destruct l;[inversion Hlength|].
    iPrologue "Hprog".
    iApply (wp_move_success_z with "[$HPC $Hi $Hr_t3]");
      [apply decode_encode_instrW_inv|iCorrectPC a_first a_last|iContiguous_next Hcont 8|auto|..].
    iEpilogue "(HPC & Hi & Hr_t3)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* load r_t1 r_t1 *)
    destruct l;[|inversion Hlength].
    apply contiguous_between_last with (ai:=a7) in Hcont as Hlink;[|auto].
    iPrologue "Hprog".
    iAssert (⌜(entry_a ≠ a7)%Z⌝)%I as %Hneq'.
    { iIntros (Hcontr);subst.
      iDestruct (addr_dupl_false with "Hi Ha_entry") as %Hne; auto. }
    iApply (wp_load_success_same with "[$HPC $Hi $Hr_t1 Ha_entry]");
      [exact wentry|apply decode_encode_instrW_inv|iCorrectPC a_first a_last|auto|auto|apply Hlink|..].
    { destruct (entry_a =? a7)%a; auto. }
    destruct ((entry_a =? a7)%a) eqn:Hcontr;[apply Z.eqb_eq in Hcontr;apply z_of_eq in Hcontr;congruence|clear Hcontr].
    iEpilogue "(HPC & Hr_t1 & Hi & Hentry_a)"; iCombine "Hi" "Hprog_done" as "Hprog_done".
    (* continuation *)
    iApply "Hφ".
    iFrame.
    iDestruct "Hprog_done" as "($&$&$&$&$&$&$&$&$&$)".
  Qed.

End stack_macros.


From st.prelude Require Import autosubst.
From st.STLCmuVS Require Import lang typing tactics.
From st.STLCmu Require Import types.
From st.STLCmuVS.lib Require Import fixarrow omega.
From st.backtranslations.un_syn Require Import universe.base.

Inductive direction :=
  | Embed
  | Project.

Definition FstSnd (ep : direction) : expr → expr :=
  match ep with
  | Embed => Fst
  | Project => Snd
  end.

Definition opp_direction (ep : direction) :=
  match ep with
  | Embed => Project
  | Project => Embed
  end.

Definition fixgenTRec (eb pb : val) : val :=
  (LamV (* 1 → ((τ → U) × (U → τ)) *) (
       LamV (* 1 *) (
           ( LamV (inject TCRec (Fold (eb.{ren (+2)} (Unfold %0)))) , (* τ → U *)
             LamV (Fold (pb.{ren (+2)} (Unfold (extract TCRec %0)))) (* U → τ *)
           )
         )
     )
  )%Eₙₒ.

Lemma fixgenTRec_subst (eb pb : val) (σ : var → expr) : (fixgenTRec eb pb).{σ} = fixgenTRec eb.{up σ} pb.{up σ}.
Proof. rewrite /fixgenTRec. simpl. rewrite inject_Closed extract_Closed. repeat rewrite -val_subst_valid. by asimpl. Qed.

Lemma fixgenTRec_typed (eb pb : val) Γ τb
      (peb : (TUnit ⟶ ((TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb)))%Tₙₒ :: Γ ⊢ₙₒ eb : τb.[TRec τb/] ⟶ TUniverse)
      (ppb : (TUnit ⟶ ((TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb)))%Tₙₒ :: Γ ⊢ₙₒ pb : TUniverse ⟶ τb.[TRec τb/]) :
  Γ ⊢ₙₒ fixgenTRec eb pb :
    (TUnit ⟶ ((TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb))) ⟶ (TUnit ⟶ ((TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb))).
Proof.
  assert (TUniverse = TUniverse.[TRec TUniverse/]) as eq; first by asimpl.
  constructor. constructor. constructor. constructor. apply App_typed with (τ1 := TRec TUniverse). apply inject_typed.
  constructor. apply App_typed with (τ1 := τb.[TRec τb/]).
  change (TRec τb :: TUnit :: (TUnit ⟶ (TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb))%Tₙₒ :: Γ) with
      ([TRec τb ; TUnit] ++ ((TUnit ⟶ (TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb))%Tₙₒ :: Γ)).
  rewrite -val_subst_valid. apply context_weakening. rewrite -eq. apply peb.
  constructor. by constructor.
  constructor. constructor. apply App_typed with (τ1 := TUniverse).
  change (TUniverse :: TUnit :: (TUnit ⟶ (TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb))%Tₙₒ :: Γ) with
      ([TUniverse ; TUnit] ++ ((TUnit ⟶ (TRec τb ⟶ TUniverse) × (TUniverse ⟶ TRec τb))%Tₙₒ :: Γ)).
  rewrite -val_subst_valid. apply context_weakening. apply ppb.
  rewrite eq. constructor. apply App_typed with (τ1 := TUniverse).
  apply extract_typed. rewrite -eq. by constructor.
Qed.

Global Opaque fixgenTRec.

Fixpoint ep_pair (dir : direction) (τ : type) : val :=
  (match τ with
   | TUnit => match dir with
             | Embed => inject TCUnit
             | Project => extract TCUnit
             end
   | TBool => match dir with
             | Embed => inject TCBool
             | downward => extract TCBool
             end
   | TInt => match dir with
            | Embed => inject TCInt
            | Project => extract TCInt
            end
   | TProd τ1 τ2 => match dir with
                   | Embed => LamV (LetIn (Fst %0)
                                        (LetIn (Snd %1)
                                               (inject TCProd ((ep_pair Embed τ1).{ren (+3)} %1, (ep_pair Embed τ2).{ren (+3)} %0))))
                   | Project => LamV (LetIn (extract TCProd %0)
                                          (LetIn (Fst %0)
                                                 (LetIn (Snd %1)
                                                        ((ep_pair Project τ1).{ren (+4)} %1 , (ep_pair Project τ2).{ren (+4)} %0))))
     end
   | TSum τ1 τ2 => match dir with
                  | Embed => LamV (Case %0
                                      (inject TCSum (InjL ((ep_pair Embed τ1).{ren (+2)} %0)))
                                      (inject TCSum (InjR ((ep_pair Embed τ2).{ren (+2)} %0))))
                  | Project => LamV (Case (extract TCSum %0)
                                        (InjL ((ep_pair Project τ1).{ren (+2)} %0))
                                        (InjR ((ep_pair Project τ2).{ren (+2)} %0)))
                  end
   | TArrow τ1 τ2 => match dir with
                    | Embed => LamV (inject TCArrow (Lam ((ep_pair Embed τ2).{ren (+2)} (%1 ((ep_pair Project τ1).{ren (+2)} %0)))))
                    | Project => LamV (Lam ((ep_pair Project τ2).{ren (+2)} (extract TCArrow %1 ((ep_pair Embed τ1).{ren (+2)} %0))))
                    end
   | TRec τb => let β := fixgenTRec (ep_pair Embed τb) (ep_pair Project τb) in
               LamV (FstSnd dir (LamV (FixArrow β.{ren (+2)} %0(*_*)) ()) %0)
   | TVar X => LamV (FstSnd dir (Var (S X) ()) %0)
  end)%Eₙₒ.

Definition direction_type dir τ :=
  match dir with
  | Embed => TArrow τ TUniverse
  | Project => TArrow TUniverse τ
  end.

Lemma ep_pair_typed_gen (τ : type) (τs : list type) (pτn : Closed_n (length τs) τ) (dir : direction) :
  map (fun τ => (TUnit ⟶ (τ ⟶ TUniverse) × (TUniverse ⟶ τ))%Tₙₒ) τs ⊢ₙₒ (ep_pair dir τ) : (direction_type dir τ.[subst_list τs]).
Proof.
  generalize dependent dir.
  generalize dependent τs.
  induction τ as [ | | | τ1 IHτ1 τ2 IHτ2 | τ1 IHτ1 τ2 IHτ2 | τ1 IHτ1 τ2 IHτ2 | τb IHτb | X ];
    intros τs Cnτ dir; try by (destruct dir; (apply inject_typed || apply extract_typed)).
  - (* TProd *) destruct dir.
    + repeat ((rewrite -val_subst_valid; apply context_weakening3) || apply IHτ1 with (dir := Embed) || apply IHτ2 with (dir := Embed) || closed_solver || apply inject_typed || econstructor).
    + repeat ((rewrite -val_subst_valid; apply context_weakening4) || apply IHτ1 with (dir := Project) || apply IHτ2 with (dir := Project) || closed_solver || apply extract_typed || econstructor).
  - (* TSum *) destruct dir.
    + repeat ((rewrite -val_subst_valid; apply context_weakening2) || apply IHτ1 with (dir := Embed) || apply IHτ2 with (dir := Embed) || closed_solver || apply inject_typed || econstructor).
    + repeat ((rewrite -val_subst_valid; apply context_weakening2) || apply IHτ1 with (dir := Project) || apply IHτ2 with (dir := Project) || closed_solver || apply (extract_typed TCSum) || econstructor).
  - (* TArrow *) destruct dir.
    + repeat ((rewrite -val_subst_valid; apply context_weakening2) || apply IHτ1 with (dir := Project) || apply IHτ2 with (dir := Embed) || closed_solver || apply inject_typed || econstructor).
    + repeat ((rewrite -val_subst_valid; apply context_weakening2) || apply IHτ1 with (dir := Embed) || apply IHτ2 with (dir := Project) || closed_solver || apply (extract_typed TCArrow) || econstructor).
  - (* TRec *) destruct dir.
    + constructor. fold ep_pair.
      apply App_typed with (τ1 := (TRec τb).[subst_list τs]). 2: by constructor.
      apply Fst_typed with (τ2 := (TUniverse ⟶ (TRec τb).[subst_list τs])%Tₙₒ).
      apply App_typed with (τ1 := TUnit). 2: by constructor. apply Lam_typed.
      apply App_typed with (τ1 := TUnit). 2: by constructor.
      apply FixArrow_typed.
      rewrite -val_subst_valid. apply context_weakening2.
      apply fixgenTRec_typed.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (dir := Embed). closed_solver.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (dir := Project). closed_solver.
    + constructor. fold ep_pair.
      apply App_typed with (τ1 := TUniverse). 2: by constructor.
      apply Snd_typed with (τ1 := ((TRec τb).[subst_list τs] ⟶ TUniverse)%Tₙₒ).
      apply App_typed with (τ1 := TUnit). 2: by constructor. apply Lam_typed.
      apply App_typed with (τ1 := TUnit). 2: by constructor.
      apply FixArrow_typed.
      rewrite -val_subst_valid. apply context_weakening2.
      apply fixgenTRec_typed.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (dir := Embed). closed_solver.
      * asimpl. change (TRec τb.[up (subst_list τs)] .: subst_list τs) with (subst_list (TRec τb.[up (subst_list τs)] :: τs)).
        rewrite -map_cons. apply IHτb with (dir := Project). closed_solver.
  - (* TVar *)
    destruct (TVar_subst_list_closed_n_length _ _ Cnτ) as [τ [eq ->]].
    destruct dir; repeat econstructor; simpl; by rewrite list_lookup_fmap eq /=.
Qed.

Lemma ep_pair_typed (τ : type) (pτ : Closed τ) dir :
  [] ⊢ₙₒ (ep_pair dir τ) : (direction_type dir τ).
Proof. cut (fmap (fun τ => (TUnit ⟶ (τ ⟶ TUniverse) × (TUniverse ⟶ τ))%Tₙₒ) [] ⊢ₙₒ ep_pair dir τ : direction_type dir τ.[subst_list []]). by asimpl. by apply ep_pair_typed_gen. Qed.

Lemma ep_pair_Closed (τ : type) (pτ : Closed τ) dir :
  Closed (of_val $ ep_pair dir τ).
Proof.
  intro σ. replace (of_val $ ep_pair dir τ) with (of_val $ ep_pair dir τ).[ids] at 2 by by asimpl.
  erewrite (typed_subst_invariant [] _ _ σ ids). auto. apply ep_pair_typed.
  auto. simpl. lia.
Qed.