Universe i j.

Goal False.
Proof.
  Check Type@{i} : Type@{j}.
  Fail constr_eq_strict Type@{i} Type@{j}.
  assert_succeeds constr_eq Type@{i} Type@{j}. (* <- i=j is forgotten after assert_succeeds *)
  Fail constr_eq_strict Type@{i} Type@{j}.

  constr_eq Type@{i} Type@{j}. (* <- i=j is retained *)
  constr_eq_strict Type@{i} Type@{j}.
  Fail Check Type@{i} : Type@{j}.

  Fail constr_eq Prop Set.
  Fail constr_eq Prop Type.

  Fail constr_eq_strict Type Type.
  constr_eq Type Type.

  constr_eq_strict Set Set.
  constr_eq Set Set.
  constr_eq Prop Prop.

  let x := constr:(Type) in constr_eq_strict x x.
  let x := constr:(Type) in constr_eq x x.

  Fail lazymatch type of prod with
       | ?A -> ?B -> _ => constr_eq_strict A B
       end.
  lazymatch type of prod with
  | ?A -> ?B -> _ => constr_eq A B
  end.
  lazymatch type of prod with
  | ?A -> ?B -> ?C => constr_eq A C
  end.

Abort.


Require Import Coq.Lists.List.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.Reify.ReifyClass.

Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.PList.

Set Implicit Arguments.
Set Strict Implicit.

Inductive list_typ : nat -> Set :=
| tList : list_typ 1.

Definition list_typ_dec {n} (a : list_typ n) : forall b, {a = b} + {a <> b} :=
  match a as a in list_typ n
        return forall b : list_typ n, {a = b} + {a <> b}
  with
  | tList =>
    fun b =>
      match b as b in list_typ 1 return {tList = b} + {tList <> b} with
      | tList => left eq_refl
      end
  end.

Definition list_typD {n} (t : list_typ n) : type_for_arity n :=
  match t with
  | tList => list
  end.

Section FuncView_list_type.
  Context {typ : Set}.
  Context {FV : PartialView typ (list_typ 1 * typ)}.

  Definition tyList t := f_insert (tList, t).

  Definition ptrn_tyList {T : Type} (p : Ptrns.ptrn typ T)
  : ptrn (list_typ 1 * typ) T :=
    fun f U good bad => p (snd f) U good (fun x => bad f).

  Global Instance ptrn_tyList_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p}
  : ptrn_ok (ptrn_tyList p).
  Proof.
    red; intros.
    destruct x; simpl; [destruct (Hok t)].
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl;
      unfold ptrn_tyList; rewrite H; reflexivity. }
  Qed.

End FuncView_list_type.

Section RelDec_list_type.

  Global Instance RelDec_list_typ (x : nat) : RelDec (@eq (list_typ x)) := {
    rel_dec := fun a b =>
                 match x with
                 | 1 => true
                 | _ => false
                 end
  }.

  Definition list_typ_eq (x y : list_typ 1) : x = y :=
    match x, y with
    | tList, tList => eq_refl
    end.

  Global Instance RelDecOk_list_typ (x : nat) : RelDec_Correct (RelDec_list_typ x).
  Proof.
    split; intros.
    destruct x; simpl in *; [inversion y|].
    inversion x0; subst.
    unfold rel_dec. simpl.
    split; intros; [|reflexivity].
    apply list_typ_eq.
  Qed.

End RelDec_list_type.

Section TSym_list_type.

  Global Instance TSym_list_typ : TSym list_typ := {
    symbolD n := list_typD (n := n);
    symbol_dec n := list_typ_dec (n := n)
  }.

End TSym_list_type.

Section ListTypeReify.
  Context {typ : Set} {FV : PartialView typ (list_typ 1 * typ)}.

  Definition reify_tyList : Command typ :=
    CPattern (ls := @cons Type typ nil) (RApp (RExact (@list)) (RGet 0 RIgnore))
             (fun (x : function (CRec 0)) => tyList x).

  Definition reify_list_typ : Command typ :=
    CFirst (reify_tyList :: nil).

End ListTypeReify.

Arguments reify_list_typ _ {_}.


From ITree Require Import ITree.
From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.
From Paco Require Import paco.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import NWSysModel OSNodes OSModel.
Require Import ProgSem.
Require Import SyncSysModel.
Require Import CProgEventSem.
Require Import ProgSim.
Require Import RTSysEnv MWITree.

(* Require Import SystemParams. *)
(* Require Import SystemDefs ITreeSpec. *)
(* Require Import SystemEventSem. *)
(* Require Import main_p main_pi. *)
Require Import config_prm main_prm SystemProgs.
Require Import LinkLemmas.

Require Export CompcertLemmas.
Require Import CProgSimLemmas.

Require Import Arith ZArith Bool.
Require Import String List Lia.

Import ITreeNotations.
Import Clight Clightdefs.

Set Nested Proofs Allowed.

Local Transparent Archi.ptr64.

Arguments Z.mul : simpl nomatch.
Arguments Z.add: simpl nomatch.
Arguments Z.sub: simpl nomatch.

Arguments Nat.add: simpl nomatch.
Arguments Nat.sub: simpl nomatch.
Arguments Nat.mul: simpl nomatch.

Arguments PTree.get : simpl nomatch.
Arguments PTree.set: simpl never.

Arguments firstn: simpl nomatch.
Arguments skipn: simpl nomatch.

(* general lemmas (TODO: move) *)

(* Local Open Scope Z. *)

Local Opaque Z.to_nat Z.of_nat Zlength.

Local Open Scope Z.

Section INBOX.
  Context `{SystemEnv}.

  (* Definition empty_msg_entry : bool * bytes := *)
  (*   (false, List.repeat Byte.zero msg_size). *)

  (* effective size *)
  Definition mentry_nsz: nat := max_msg_size + 1.
  Notation mentry_sz := (Z.of_nat mentry_nsz).

  Lemma mentry_sz_eq
    : mentry_sz = msg_entry_sz (Z.of_nat msg_size_k).
  Proof.
    (* unfold mentry_sz, msg_entry_sz. *)
    unfold msg_entry_sz.
    unfold mentry_nsz. unfold max_msg_size.
    nia.
  Qed.

  Lemma range_mentry_nsz_precise
    : (mentry_nsz < Packet.maxlen)%nat.
  Proof.
    assert (mentry_nsz < max_pld_size)%nat.
    { unfold mentry_nsz, max_pld_size. nia. }
    pose proof packet_length_bound.
    unfold max_pld_size, max_msg_size in *.
    nia.
  Qed.

  Lemma range_mentry_sz_precise
    : (0 <= mentry_sz < Z.of_nat Packet.maxlen)%Z.
  Proof.
    (* unfold mentry_sz. *)
    pose proof range_mentry_nsz_precise. nia.
  Qed.

  Lemma range_mentry_nsz
    : IntRange.sint mentry_nsz.
  Proof.
    pose proof range_mentry_nsz_precise.
    pose proof range_packet_maxlen.
    range_stac.
  Qed.

  Definition mentry_ensz: nat := (msg_size + 1).
  Notation mentry_esz := (Z.of_nat mentry_ensz).

  Lemma range_mentry_ensz
    : (0 <= mentry_ensz <= mentry_nsz)%nat.
  Proof.
    unfold mentry_ensz, mentry_nsz.
    pose proof msg_size_bound.
    fold max_msg_size in *. nia.
  Qed.

  (* = 6 * 8 = 48 *)
  Definition inb_nsz: nat := mentry_nsz * max_num_tasks.

  Notation inb_sz := (Z.of_nat inb_nsz).

  Lemma inb_sz_eq
    : inb_sz = inbox_sz (Z.of_nat msg_size_k)
                        (Z.of_nat max_num_tasks).
  Proof.
    unfold inbox_sz.
    unfold inb_nsz.
    rewrite <- mentry_sz_eq. nia.
  Qed.

  Lemma within_inb_nsz1
        i
        (VALID_TID: (i < num_tasks)%nat)
    : (mentry_nsz * i <= inb_nsz)%nat.
  Proof.
    unfold inb_nsz.
    pose proof num_tasks_bound.
    fold num_tasks in *. nia.
  Qed.

  Lemma within_inb_nsz2
        i ofs
        (VALID_TID: (i < num_tasks)%nat)
        (VALID_ENTRY_AREA: (ofs <= mentry_nsz)%nat)
    : (mentry_nsz * i + ofs <= inb_nsz)%nat.
  Proof.
    unfold inb_nsz.
    pose proof num_tasks_bound.
    fold num_tasks in *.
    unfold mentry_nsz in *. nia.
  Qed.

  Lemma maxlen_byte_aux
    : (Z.of_nat Packet.maxlen * Byte.max_signed
       < Int.max_signed)%Z.
  Proof.
    unfold Packet.maxlen.
    rewrite Z2Nat.id by nia. ss.
  Qed.

  Lemma range_inb_sz_precise
    : (inb_sz < Z.of_nat Packet.maxlen * Byte.max_signed)%Z.
  Proof.
    unfold inb_nsz.
    pose proof range_max_num_tasks as R_MNT.
    pose proof range_mentry_nsz_precise as PR_ENT.
    pose proof maxlen_byte_aux.
    range_stac.
  Qed.

  Lemma range_inb_nsz
    : IntRange.sint inb_nsz.
  Proof.
    r.
    pose proof range_inb_sz_precise.
    pose proof maxlen_byte_aux.
    range_stac.
  Qed.

  Lemma ptr_range_inb_sz
    : (0 <= inb_sz < Ptrofs.max_unsigned)%Z.
  Proof.
    pose proof range_inb_nsz.
    range_stac.
  Qed.

  Lemma ptr_range_mstore
    : (Z.of_nat (4 + inb_nsz + inb_nsz) <= Ptrofs.max_unsigned)%Z.
  Proof.
    pose proof range_inb_sz_precise.
    pose proof maxlen_byte_aux.
    assert (4 + Int.max_signed + Int.max_signed <
            Ptrofs.max_unsigned)%Z by ss.
    nia.
  Qed.

  (* Definition mentry_to_bytes (ment: bool * bytes): bytes := *)
  (*   let (rcv, cont) := ment in *)
  (*   let b_hd := if rcv then Byte.one else Byte.zero in *)
  (*   b_hd :: cont. *)

End INBOX.

Notation cglobvar := (globvar type).
Notation mentry_sz := (Z.of_nat mentry_nsz).
Notation mentry_esz := (Z.of_nat mentry_ensz).
Notation inb_sz := (Z.of_nat inb_nsz).

Class genv_props (ge: genv)
      (gvar_ilist: list (ident * cglobvar))
      (gfun_ilist: list (ident * fundef))
      (cenv_ilist: list (ident * composite))
  : Prop :=
  { in_gvar_ilist: forall i gv,
      In (i, gv) gvar_ilist -> exists b_gvar,
        <<GVAR_SYMB: Genv.find_symbol ge i = Some b_gvar>> /\
        <<GVAR_VINFO: Genv.find_var_info ge b_gvar = Some gv>> ;

    (* in_gvar_ids: forall i, *)
    (*   In i gvar_ids -> exists b_gvar, *)
    (*     Genv.find_symbol ge i = Some b_gvar; *)

    in_gfun_ilist: forall i fd,
        In (i, fd) gfun_ilist -> exists b_fdef,
          <<FDEF_SYMB: Genv.find_symbol ge i = Some b_fdef>> /\
          <<FDEF_FPTR: Genv.find_funct ge (Vptr b_fdef Ptrofs.zero) = Some fd>> ;

    in_cenv_ilist:
      forall i co, In (i, co) cenv_ilist ->
              (genv_cenv ge) ! i = Some co ;
  }.

Definition genv_props_incl (ge: genv)
           (gvs1 gvs2: list (ident * cglobvar))
           (gfs1 gfs2: list (ident * fundef))
           (cos1 cos2: list (ident * composite))
           (GENV_P: genv_props ge gvs2 gfs2 cos2)
           (INCL_GVS: List.incl gvs1 gvs2)
           (INCL_GFS: List.incl gfs1 gfs2)
           (INCL_COS: List.incl cos1 cos2)
  : genv_props ge gvs1 gfs1 cos1.
Proof.
  inv GENV_P.
  econs; eauto.
Qed.

Lemma in_gvar_ids ge gvs gfs ces
      `{genv_props ge gvs gfs ces}
      i
      (IN: In i (map fst gvs))
  : exists b_gvar,
    Genv.find_symbol ge i = Some b_gvar.
Proof.
  cut (exists gv, In (i, gv) gvs).
  { clear IN. i. des.
    hexploit in_gvar_ilist; eauto.
    i. des. eauto.
  }

  ss. eapply Coqlib.list_in_map_inv in IN.
  des.
  destruct x; subst. ss. eauto.
Qed.

Arguments in_gvar_ids {ge gvs gfs ces _} i.

(* tactics *)

Ltac red_idx idx' :=
  match goal with
  | |- paco3 (_sim_itree ?p) _ _ _ _ =>
    eapply (sim_itree_red_idx p) with (idx_small:= idx');
    [nia|]
  end.

Ltac fold_cenv :=
  match goal with
  | |- context[(prog_comp_env ?p)] =>
    change (prog_comp_env p) with
        (genv_cenv (globalenv p))
  end.

Ltac sIn :=
  s;
  match goal with
  | |- In _ _ => eauto
  | |- (_ = _ \/ _) =>
    try (left; eauto; fail);
    right; sIn
  | |- _ => ss; fail
  end.

Ltac solve_norepet :=
  match goal with
  | |- Coqlib.list_norepet ?l =>
    let x := eval simpl in (Coqlib.list_norepet_dec ident_eq l) in
        match x with
        | left ?P => exact P
        | _ => fail
        end
  end.

Ltac solve_disjoint :=
  try by (clear;
          r; s;
          let X := fresh "X" in
          let Y := fresh "Y" in
          intros ? ? X Y;
          des; subst; ss).

  (* match goal with *)
  (* | |- Coqlib.list_disjoint ?l1 ?l2 => *)
  (*   let x := eval simpl in (Coqlib.list_disjoint_dec ident_eq l1 l2) in *)
  (*       match x with *)
  (*       | left ?P => exact P *)
  (*       | _ => fail *)
  (*       end *)
  (* end. *)

Ltac eval_comput1 :=
  match goal with
  | |- eval_expr _ _ _ _ _ _ =>
    apply eval_expr_comput
  | |- eval_lvalue _ _ _ _ _ _ _ =>
    apply eval_lvalue_comput
  | |- eval_exprlist _ _ _ _ _ _ _ =>
    apply eval_exprlist_comput
  | |- assign_loc _ _ _ _ _ _ _ =>
    apply assign_loc_comput
  | |- Cop.sem_add _ _ _ _ _ _ = _ =>
    unfold Cop.sem_add
  | |- Cop.sem_cmp _ _ _ _ _ _  = _ =>
    unfold Cop.sem_cmp
  | |- Cop.sem_cast _ _ _ _ = _ =>
    unfold Cop.sem_cast
  | |- Cop.sem_binarith _ _ _ _ _ _ _ _ _ = _ =>
    unfold Cop.sem_binarith
  | |- context[ (?x ! ?id)] =>
    match type of x with
    | composite_env =>
      fold_cenv;
      erewrite (in_cenv_ilist id) by sIn
    | _ =>
      match goal with
      | H: ptree_equiv ?x _ |- _ => rewrite H
      end
    end
  end.

Ltac eval_comput := repeat (eval_comput1; cbn).

Ltac pre_start_func :=
  match goal with
  | H: genv_props ?ge _ _ _ |-
    context[ Callstate (Internal ?f) _ _ ?m0 ] =>
    assert (ALLOC_STACK: exists e m1 es blks_env,
               alloc_variables ge empty_env m0
                               (fn_vars f) e m1 /\
               env_equiv e es /\
               blocks_of_env ge e = blks_env)
  end.

Ltac start_func :=
  match goal with
  | H: genv_props ?ge _ _ _ |-
    paco3 _ _ _ _ (Callstate (Internal ?f) ?args ?k ?m) =>
    hexploit (clight_function_entry ge f args k m)
  end;
  [solve_norepet | solve_norepet | solve_norepet
   | solve_disjoint | eauto | ss | i; des ].

(* Omit 2nd stmt *)
Notation SeqAbbr s := (Ssequence s _).

Ltac simpl_idx :=
  repeat
    (first [rewrite <- Nat.sub_add_distr by nia |
            rewrite <- Nat.add_sub_assoc by nia]; ss).

Ltac fw :=
  eapply sim_itree_clight_silent;
  [nia| simpl in *; econs; simpl in *; eauto; try by econs |
   left; simpl_idx; simpl in *].

Ltac fw_tau idx :=
  eapply sim_itree_clight_silent_tau with (idx_n:=idx);
  [simpl in *; econs; simpl in *; eauto; try by econs | ss | left];
  simpl_idx; s.

Ltac fw_r :=
  eapply sim_itree_clight_silent;
  [nia| simpl in *; econs; simpl in *; eauto; try by econs |
   right; simpl_idx; simpl in *].

Ltac upd_lenv :=
  match goal with
  | H: lenv_equiv ?le_c _ |-
    context[State _ _ _ _ (PTree.set ?i ?v ?le_c) _] =>
    let le_p := fresh "le_p" in
    let LE := fresh "LE" in
    rename le_c into le_p;
    remember (PTree.set i v le_p) as le_c eqn: LE;
    eapply update_lenv_equiv in H;
    try (apply LE || reflexivity);
    clear dependent le_p;
    (* simpl in H *)
    cbn in H
  end.

Ltac unf_resum :=
  unfold resum, ReSum_id, id_, Id_IFun in *.

Ltac step_fptr_tac :=
  match goal with
  | |- context [Evar ?fid] =>
    hexploit (in_gfun_ilist fid); [sIn|]; [];
    intros (b_fdef & FDEF_SYMB & FDEF_FPTR); des;
    econs; [ss| eval_comput; try rewrite FDEF_SYMB; ss | eval_comput; ss | eauto | ss]
  end.

(**)

Section COMPOSITES.
  Context `{SystemEnv}.

  Program Definition co_pals_msg_t: composite :=
    {|
    co_su := Struct;
    co_members := [(_period_base_time, Tlong Unsigned {| attr_volatile := false; attr_alignas := None |});
                  (_sender, Tint I8 Signed {| attr_volatile := false; attr_alignas := None |});
                  (_content,
                   Tarray (Tint I8 Signed {| attr_volatile := false; attr_alignas := None |}) (Z.of_nat max_msg_size)
                          {| attr_volatile := false; attr_alignas := None |})];
    co_attr := {| attr_volatile := false; attr_alignas := None |};
    co_sizeof := Z.of_nat max_pld_size ; (* 16 *)
    co_alignof := 8;
    co_rank := 1;
    co_sizeof_pos := _ ;
    co_sizeof_alignof := _ ;
    |}.
  Next Obligation.
    unfold max_pld_size. nia.
  Qed.
  Next Obligation.
    exists 3%nat. ss.
  Qed.
  Next Obligation.
    unfold max_pld_size. unfold max_msg_size.
    replace (Z.of_nat (msg_size_k * 8 + 7 + 9)) with
        (Z.of_nat msg_size_k * 8 + 16)%Z by nia.
    solve_divide.
  Qed.

  Program Definition co_inbox_t: composite :=
    {|
    co_su := Struct;
    co_members := [(_entry,
                    Tarray (Tstruct _msg_entry_t {| attr_volatile := false; attr_alignas := None |})
                           (Z.of_nat max_num_tasks)
                           {| attr_volatile := false; attr_alignas := None |})];
    co_attr := {| attr_volatile := false; attr_alignas := None |};
    co_sizeof := Z.of_nat inb_nsz;
    co_alignof := 1;
    co_rank := 3;
    co_sizeof_pos := _ ;
    co_alignof_two_p := _;
    |}.
  Next Obligation.
    pose proof range_inb_sz_precise. nia.
  Qed.
  Next Obligation.
    exists O. ss.
  Qed.
  Next Obligation.
    solve_divide.
  Qed.

  Program Definition co_msg_entry_t: composite :=
    {|
    co_su := Struct;
    co_members := [(_received, Tint I8 Signed {| attr_volatile := false; attr_alignas := None |});
                  (_content,
                   Tarray (Tint I8 Signed {| attr_volatile := false; attr_alignas := None |})
                          (Z.of_nat max_msg_size)
                          {| attr_volatile := false; attr_alignas := None |})];
    co_attr := {| attr_volatile := false; attr_alignas := None |};
    co_sizeof := Z.of_nat mentry_nsz;
    co_alignof := 1;
    co_rank := 1;
    co_sizeof_pos := _ ;
    co_alignof_two_p := _ ;
    |}.
  Next Obligation.
    unfold mentry_nsz. nia.
  Qed.
  Next Obligation.
    exists O. ss.
  Qed.
  Next Obligation.
    solve_divide.
  Qed.

  Program Definition co_msg_store_t: composite :=
    {|
    co_su := Struct;
    co_members := [(_cur_idx, Tint I32 Signed {| attr_volatile := false; attr_alignas := None |});
                  (_inbox,
                   Tarray (Tstruct _inbox_t {| attr_volatile := false; attr_alignas := None |}) 2
                          {| attr_volatile := false; attr_alignas := None |})];
    co_attr := {| attr_volatile := false; attr_alignas := None |};
    co_sizeof := 4 + 2 * (Z.of_nat inb_nsz);
    co_alignof := 4;
    co_rank := 5;
    co_sizeof_pos := _ ;
    co_alignof_two_p := _ ;
    co_sizeof_alignof := _ ;
    |}.
  Next Obligation.
    nia.
  Qed.
  Next Obligation.
    exists 2%nat; ss.
  Qed.
  Next Obligation.
    unfold inb_nsz.
    rewrite Nat2Z.inj_mul.
    rewrite mentry_sz_eq.
    unfold msg_entry_sz.
    solve_divide.
  Qed.

End COMPOSITES.

Definition main_const_ids: list ident :=
  [_TASK_ID; _PALS_PERIOD; _MAX_CSKEW; _MAX_NWDELAY;
  _NUM_TASKS; _NUM_MCASTS; _MSG_SIZE;
  _PORT; _IP_ADDR; _MCAST_MEMBER].

Definition main_gvar_ids: list ident :=
  [_TASK_ID; _PALS_PERIOD; _MAX_CSKEW; _MAX_NWDELAY;
  _NUM_TASKS; _NUM_MCASTS; _MSG_SIZE;
  _PORT; _IP_ADDR; _MCAST_MEMBER;
  _send_buf; _mstore; _send_hist; _txs; _rxs].

Definition main_gfun_ids: list ident :=
  [ _get_cur_inbox; _get_nxt_inbox; _msg_copy; _check_send_hist;
  _reset_send_hist; _pals_send; _get_base_time; _mcast_join;
  _insert_msg; _fetch_msgs; _init_inbox; _switch_inbox;
  _run_task; _main;
  _pals_current_time; _pals_init_timer;  _pals_wait_timer;
  _pals_socket;  _pals_bind;  _pals_mcast_join;  _pals_sendto;
  _pals_recvfrom].

Definition main_cenv_ids: list ident :=
  [_pals_msg_t; _msg_entry_t; _inbox_t; _msg_store_t].

Definition app_unch_gvar_ids: list ident :=
  [_TASK_ID; _PALS_PERIOD; _MAX_CSKEW; _MAX_NWDELAY;
  _NUM_TASKS; _NUM_MCASTS; _MSG_SIZE;
  _PORT; _IP_ADDR; _MCAST_MEMBER;
  _mstore; _txs; _rxs].

Definition v_TASK_ID_p (tid_z: Z) :=
  {| gvar_info := tschar;
     gvar_init := [Init_int8 (Int.repr tid_z)];
     gvar_readonly := true;
     gvar_volatile := false |}.

Definition main_gvar_ilist `{SystemEnv} (tid: nat)
  : list (ident * cglobvar) :=
  [(_TASK_ID, v_TASK_ID_p (Z.of_nat tid));
  (_PALS_PERIOD, config_prm.v_PALS_PERIOD (Z.of_nat period));
  (_MAX_CSKEW, config_prm.v_MAX_CSKEW (Z.of_nat max_clock_skew));
  (_MAX_NWDELAY, config_prm.v_MAX_NWDELAY (Z.of_nat max_nw_delay));
  (_NUM_TASKS, config_prm.v_NUM_TASKS (Z.of_nat num_tasks));
  (_NUM_MCASTS, config_prm.v_NUM_MCASTS (Z.of_nat num_mcasts));
  (_MSG_SIZE, config_prm.v_MSG_SIZE (Z.of_nat msg_size));

  (_PORT, config_prm.v_PORT (Z.of_nat port));
  (_IP_ADDR, config_prm.v_IP_ADDR
               (Z.of_nat max_num_tasks)
               (Z.of_nat max_num_mcasts)
               (task_ips_brep ++ map fst mcasts)) ;
  (_MCAST_MEMBER, config_prm.v_MCAST_MEMBER
                    (Z.of_nat max_num_tasks)
                    (Z.of_nat max_num_mcasts)
                    mcast_memflags) ;

  (_send_buf, main_prm.v_send_buf (Z.of_nat msg_size_k));
  (_mstore, main_prm.v_mstore (Z.of_nat msg_size_k)
                              (Z.of_nat max_num_tasks));
  (_send_hist, main_prm.v_send_hist (Z.of_nat max_num_tasks));
  (_txs, main_prm.v_txs);
  (_rxs, main_prm.v_rxs)].

Definition main_cenv_ilist `{SystemEnv}
  : list (ident * composite) :=
  [(_pals_msg_t, co_pals_msg_t);
  (_msg_entry_t, co_msg_entry_t);
  (_inbox_t, co_inbox_t);
  (_msg_store_t, co_msg_store_t)].

Definition main_gfun_ilist `{SystemEnv}
  : list (ident * fundef) :=
  [ (_get_cur_inbox, Internal f_get_cur_inbox);
  (_get_nxt_inbox, Internal f_get_nxt_inbox);
  (_msg_copy, Internal f_msg_copy);
  (_check_send_hist, Internal (f_check_send_hist
                                 (Z.of_nat max_num_tasks)
                                 (Z.of_nat max_num_mcasts)));
  (_reset_send_hist, Internal (f_reset_send_hist (Z.of_nat max_num_tasks)));
  (_pals_send, Internal (f_pals_send (Z.of_nat msg_size_k)
                                     (Z.of_nat max_num_tasks)
                                     (Z.of_nat max_num_mcasts)));
  (_get_base_time, Internal f_get_base_time);
  (_mcast_join, Internal (f_mcast_join (Z.of_nat max_num_tasks)
                                       (Z.of_nat max_num_mcasts)));
  (_insert_msg, Internal (f_insert_msg (Z.of_nat msg_size_k)));
  (_fetch_msgs, Internal (f_fetch_msgs (Z.of_nat msg_size_k)
                                       (Z.of_nat max_num_tasks)));
  (_init_inbox, Internal (f_init_inbox (Z.of_nat max_num_tasks)));
  (_switch_inbox, Internal f_switch_inbox);
  (_run_task, Internal f_run_task);
  (_main, Internal f_main);

  (_pals_current_time,
   External get_time_ef Tnil tulong cc_default);
  (_pals_init_timer,
   External init_timer_ef Tnil tint cc_default);
  (_pals_wait_timer, External wait_timer_ef
    (Tcons tulong Tnil) tint cc_default);
  (_pals_socket, External open_socket_ef Tnil tint cc_default);
  (_pals_bind, External bind_socket_ef
    (Tcons tint (Tcons tint Tnil)) tint cc_default);
  (_pals_mcast_join, External join_socket_ef
    (Tcons tint (Tcons (tptr tschar) Tnil)) tvoid cc_default);

  (_pals_sendto,
   External sendto_ef
            (Tcons tint
                   (Tcons (tptr tschar)
                          (Tcons tint (Tcons (tptr tschar) (Tcons tint Tnil))))) tint cc_default);
  (_pals_recvfrom,
   External recvfrom_ef
            (Tcons tint (Tcons (tptr tschar) (Tcons tint Tnil))) tint cc_default)
].

Definition bool2memval (b: bool): memval :=
  Byte (if b then Byte.one else Byte.zero).

Section MATCH_MEM.
  Local Open Scope Z.

  Variable ge: genv.
  Variable tid: nat.
  Context `{SystemEnv}.
  (* Context `{ genv_props *)
  (*              ge (main_gvar_ilist tid) *)
  (*              main_gfun_ilist main_cenv_ilist }. *)

  Record mem_consts (m: mem) (tid: nat): Prop :=
    MemConsts {
        mem_consts_task_id:
          forall b_tid
            (FIND_SYMB: Genv.find_symbol
                          ge _TASK_ID = Some b_tid),
            Mem.load Mint8signed m b_tid 0%Z =
            Some (Vint (IntNat.of_nat tid)) ;

        mem_consts_pals_period:
          forall b_pprd
            (FIND_SYMB: Genv.find_symbol
                          ge _PALS_PERIOD = Some b_pprd),
          Mem.load Mint64 m b_pprd 0%Z =
          Some (Vlong (IntNat.of_nat64 period)) ;

        mem_consts_max_cskew:
          forall b_sk
            (FIND_SYMB: Genv.find_symbol
                          ge _MAX_CSKEW = Some b_sk),
            Mem.load Mint64 m b_sk 0%Z =
            Some (Vlong (IntNat.of_nat64 max_clock_skew)) ;

        mem_consts_max_nwdelay:
          forall b_nd
            (FIND_SYMB: Genv.find_symbol
                          ge _MAX_NWDELAY = Some b_nd),
            Mem.load Mint64 m b_nd 0%Z =
            Some (Vlong (IntNat.of_nat64 max_nw_delay)) ;

        mem_consts_num_tasks:
          forall b_nt
            (FIND_SYMB: Genv.find_symbol
                          ge _NUM_TASKS = Some b_nt),
            Mem.load Mint32 m b_nt 0%Z =
            Some (Vint (IntNat.of_nat num_tasks)) ;

        mem_consts_num_mcasts:
          forall b_nmc
            (FIND_SYMB: Genv.find_symbol
                          ge _NUM_MCASTS = Some b_nmc),
            Mem.load Mint32 m b_nmc 0%Z =
            Some (Vint (IntNat.of_nat num_mcasts)) ;

        mem_consts_msg_size:
          forall b_msz
            (FIND_SYMB: Genv.find_symbol
                          ge _MSG_SIZE = Some b_msz),
            Mem.load Mint32 m b_msz 0%Z =
            Some (Vint (IntNat.of_nat msg_size)) ;

        mem_consts_port:
          forall b_pn
            (FIND_SYMB: Genv.find_symbol
                          ge _PORT = Some b_pn),
            Mem.load Mint32 m b_pn 0%Z =
            Some (Vint (IntNat.of_nat port)) ;

        mem_consts_ip_addr:
          forall b_ip_addr
            (FIND_SYMB: Genv.find_symbol
                          ge _IP_ADDR = Some b_ip_addr),

            iForall (fun n ip_bs =>
                       Mem.loadbytes
                         m b_ip_addr (Z.of_nat (n * 16))
                         (Zlength ip_bs + 1) =
                       Some (inj_bytes (snoc ip_bs Byte.zero)))
                    0 (task_ips_brep ++ (map fst mcasts)) ;

        mem_consts_mcast_member:
          forall b_mcm mid midx tid'
            mip_bs mem
            (FIND_SYMB: Genv.find_symbol
                          ge _MCAST_MEMBER = Some b_mcm)
            (MCAST_ID: mid = (num_tasks + midx)%nat)
            (MCASTS_MID: nth_error mcasts midx = Some (mip_bs, mem))
            (RANGE_TID: (tid' < num_tasks)%nat)
          ,
            Mem.load Mint8signed m b_mcm
                     (Z.of_nat (max_num_tasks * midx + tid')) =
            Some (Vint (if existsb (Nat.eqb tid') mem
                        then Int.one else Int.zero)) ;
      }.

  Lemma mem_consts_unch
        m m'
        (MEM_CONSTS: mem_consts m tid)
        (UNCH: Mem.unchanged_on
                 (blocks_of ge main_const_ids) m m')
    : mem_consts m' tid.
  Proof.
    inv MEM_CONSTS.
    econs.
    - i. hexploit mem_consts_task_id0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_pals_period0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_max_cskew0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_max_nwdelay0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_num_tasks0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_num_mcasts0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_msg_size0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_port0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_ip_addr0; eauto.
      intro LOAD_FA.
      eapply iForall_nth. i.
      rewrite iForall_nth in LOAD_FA.
      specialize (LOAD_FA n).

      fold bytes in *.
      destruct (nth_error (task_ips_brep ++ map fst mcasts) n); ss.
      eapply Mem.loadbytes_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
    - i. hexploit mem_consts_mcast_member0; eauto.
      intro LOAD.
      eapply Mem.load_unchanged_on; eauto.
      i. ss.
      r. esplits; eauto. sIn.
  Qed.

  Lemma mem_consts_unch_diffblk
        m m' b_ch
        (MEM_CONSTS: mem_consts m tid)
        (MEM_CHB: mem_changed_block b_ch m m')
        (BLK_NOT_CONSTS: forall id,
            In id main_const_ids ->
            Genv.find_symbol ge id <> Some b_ch)
    : mem_consts m' tid.
  Proof.
    eapply mem_consts_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of.
    ii. subst. des.
    hexploit BLK_NOT_CONSTS; eauto.
  Qed.

  Let fsymb (id: ident) (bpred: block -> Prop): Prop :=
    forall b (FIND_SYMB: Genv.find_symbol ge id = Some b),
      bpred b.

  Record mem_sbuf_blk (m: mem) (nsytm: nat) (tid: nat) (mcont: bytes)
         (b_sbuf: block): Prop :=
    MemSBuf {
        mem_sbuf_next_sync_time:
            Mem.loadbytes m b_sbuf 0 8 =
            Some (inj_bytes (IntByte.to_bytes64 (IntNat.of_nat64 nsytm))) ;

        mem_sbuf_task_id:
          Mem.load Mint8signed m b_sbuf 8 =
          Some (Vint (IntNat.of_nat tid)) ;

        mem_sbuf_content:
          Mem.loadbytes m b_sbuf 9 (Z.of_nat msg_size) =
          Some (inj_bytes mcont) ;

        mem_sbuf_writable:
          Mem.range_perm m b_sbuf 0 (Z.of_nat pld_size)
                         Cur Writable;
      }.

  Lemma mem_sbuf_next_sync_time'
        (m: mem) (nsytm: nat) (tid': nat) (mcont: bytes)
        (b_sbuf: block)
        (MEM_SBUF_BLK: mem_sbuf_blk m nsytm tid' mcont b_sbuf)
    : Mem.load Mint64 m b_sbuf 0 =
      Some (Vlong (IntNat.of_nat64 nsytm)).
  Proof.
    erewrite Mem.loadbytes_load;
      try (eapply mem_sbuf_next_sync_time; eauto).
    2: { solve_divide. }
    f_equal.
    unfold decode_val.
    rewrite proj_inj_bytes. f_equal.

    unfold IntByte.to_bytes64.
    rewrite decode_encode_int_8. ss.
  Qed.

  Definition mem_sbuf (m: mem)
             (nsytm: nat) (tid: nat) (mcont: bytes): Prop :=
    fsymb _send_buf (mem_sbuf_blk m nsytm tid mcont).

  Lemma mem_sbuf_unch
        m m' nsytm mcont
        (MEM_SBUF: mem_sbuf m nsytm tid mcont)
        (UNCH: Mem.unchanged_on
                 (fun b _ => Genv.find_symbol ge _send_buf = Some b)
                 m m')
    : mem_sbuf m' nsytm tid mcont.
  Proof.
    ii. rr in MEM_SBUF.
    hexploit MEM_SBUF; eauto. intro MEM_SBUF_BLK.
    clear MEM_SBUF.

    inv MEM_SBUF_BLK.
    econs.
    - eapply Mem.loadbytes_unchanged_on; eauto.
    - eapply Mem.load_unchanged_on; eauto.
    - eapply Mem.loadbytes_unchanged_on; eauto.
    - ii. eapply Mem.perm_unchanged_on; eauto.
  Qed.

  Lemma mem_sbuf_unch_diffblk
        b_ch m m' nsytm mcont
        (MEM_SBUF: mem_sbuf m nsytm tid mcont)
        (MEM_CHB: mem_changed_block b_ch m m')
        (CHB_NOT_SBUF: Genv.find_symbol ge _send_buf <> Some b_ch)
    : mem_sbuf m' nsytm tid mcont.
  Proof.
    eapply mem_sbuf_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of.
    ii. subst. eauto.
  Qed.

  Definition Mem_msg_entry (mem: Mem.mem)
             (b: block) (ofs: Z)
             (idx: nat) (ment: bytes?): Prop :=
    match ment with
    | None =>
      Mem.loadbytes mem b (ofs + Z.of_nat (mentry_nsz * idx)) 1 =
      Some ([Byte Byte.zero])
    | Some cont =>
      Mem.loadbytes mem b (ofs + Z.of_nat (mentry_nsz * idx)) mentry_esz =
      Some (inj_bytes (Byte.one :: cont))
    end.

  Definition Mem_inbox (mem: Mem.mem)
             (b: block) (ofs: Z)
             (ments: list (bytes?)): Prop :=
    <<MSG_ENTRIES: iForall (Mem_msg_entry mem b ofs) 0 ments>> /\
    <<NUM_ENTRIES: length ments = num_tasks>> /\
                 (* ments (incr_nlist 0 num_tasks) /\ *)
    <<INBOX_PERM: Mem.range_perm mem b ofs (ofs + inb_sz)
                                 Cur Writable>>.
  (* (align_chunk Mint8signed | ofs)%Z. *)

  Record mem_mstore_blk
         (m: mem) (cflg: bool)
         (ofsc ofsn: Z)
         (inbc inbn: list (bytes?))
         (b_mst: block): Prop :=
    MemMStore {
        mem_mst_curflag:
          Mem.load Mint32 m b_mst 0 =
          Some (Vint (if cflg then Int.one else Int.zero)) ;

        mem_mst_curflag_writable:
          Mem.range_perm m b_mst 0 4 Cur Writable;

        mst_match_ofs_cur:
          ofsc = if cflg then 4 + inb_sz else 4 ;
        mst_match_ofs_nxt:
          ofsn = if cflg then 4 else (4 + inb_sz)%Z ;

        mem_mst_inbox_cur: Mem_inbox m b_mst ofsc inbc ;
        mem_mst_inbox_nxt: Mem_inbox m b_mst ofsn inbn ;
      }.

  Lemma Mem_msg_entry_unch
        m m' b ofs ment (i: nat)
        (MEM_MENT: Mem_msg_entry m b ofs i ment)
        (MEM_UNCH: Mem.unchanged_on
                     (fun b' ofs' =>
                        b' = b /\
                        (ofs + Z.of_nat (mentry_nsz * i) <= ofs' <
                         ofs + Z.of_nat (mentry_nsz * i + mentry_nsz))%Z)
                     m m')
    : Mem_msg_entry m' b ofs i ment.
  Proof.
    rr in MEM_MENT. rr.
    destruct ment.
    - eapply Mem.loadbytes_unchanged_on; try apply MEM_MENT.
      { eauto. }
      i. ss.
      split; ss.
      pose proof range_mentry_ensz.
      nia.
    - eapply Mem.loadbytes_unchanged_on; try apply MEM_MENT.
      { eauto. }
      i. ss.
      split; ss.
      cut (1 <= mentry_nsz)%nat.
      { nia. }
      unfold mentry_nsz. nia.
  Qed.

  Lemma iForall_Mem_msg_entry_unch
        m m' b ofs ments (i j: nat)
        (MEM_MENT: iForall (Mem_msg_entry m b ofs) i ments)
        (LEN_MENTS: j = length ments)
        (MEM_UNCH: Mem.unchanged_on
                     (fun b' ofs' =>
                        b' = b /\
                        (ofs + Z.of_nat (mentry_nsz * i) <= ofs' <
                         ofs + Z.of_nat (mentry_nsz * (i + j)))%Z)
                     m m')
    : iForall (Mem_msg_entry m' b ofs) i ments.
  Proof.
    subst j.
    induction MEM_MENT; ss.
    { econs. }

    econs.
    { eapply Mem_msg_entry_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      clear. intros b' ofs' [? OFS]. clarify.
      unfold mentry_nsz in *. nia.
    }

    apply IHMEM_MENT.
    eapply Mem.unchanged_on_implies; eauto.
    clear. intros b' ofs' [? OFS]. clarify.
    split; ss.
    nia.
  Qed.

  Lemma Mem_inbox_unch
        m m' b ofs inb
        (MEM_INB: Mem_inbox m b ofs inb)
        (MEM_UNCH: Mem.unchanged_on
                     (fun b' ofs' =>
                        b' = b /\
                        (ofs <= ofs' < ofs + inb_sz)%Z)
                     m m')
    : Mem_inbox m' b ofs inb.
  Proof.
    r. r in MEM_INB. des.
    esplits; ss.
    - eapply iForall_Mem_msg_entry_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      (* rewrite mentry_sz_eq. *)
      rewrite NUM_ENTRIES. ss.
      ii. des. subst.
      split; ss.

      pose proof range_mentry_sz_precise.
      assert (0 < num_tasks)%nat by nia.

      assert (exists x, num_tasks = S x).
      { destruct num_tasks; ss.
        - nia.
        - esplits; eauto. }
      des.

      hexploit (within_inb_nsz2 x mentry_nsz).
      { nia. }
      { nia. }
      unfold inb_nsz.
      nia.
    - ii. eapply Mem.perm_unchanged_on; eauto.
      ss.
  Qed.

  Definition mem_mstore m cflg ofsc ofsn inbc inbn :=
    fsymb _mstore (mem_mstore_blk m cflg ofsc ofsn inbc inbn).

  Lemma mem_mstore_unch
        m m' cf
        ofsc ofsn inbc inbn
        (MEM_MSTORE: mem_mstore m cf ofsc ofsn inbc inbn)
        (UNCH: Mem.unchanged_on
                 (fun b _ => Genv.find_symbol ge _mstore = Some b)
                 m m')
    : mem_mstore m' cf ofsc ofsn inbc inbn.
  Proof.
    ii. rr in MEM_MSTORE.
    hexploit MEM_MSTORE; eauto. intro MEM_MSTORE_BLK.
    clear MEM_MSTORE.

    inv MEM_MSTORE_BLK.
    econs.
    - eapply Mem.load_unchanged_on; eauto.
    - ii. eapply Mem.perm_unchanged_on; eauto.
    - ss.
    - ss.
    - eapply Mem_inbox_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      ii. ss. des. subst. ss.
    - eapply Mem_inbox_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      ii. ss. des. subst. ss.
  Qed.

  Lemma mem_mstore_unch_diffblk
        b_ch m m' cf
        ofsc ofsn inbc inbn
        (MEM_SBUF: mem_mstore m cf ofsc ofsn inbc inbn)
        (MEM_CHB: mem_changed_block b_ch m m')
        (CHB_NOT_MST: Genv.find_symbol ge _mstore <> Some b_ch)
    : mem_mstore m' cf ofsc ofsn inbc inbn.
  Proof.
    eapply mem_mstore_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of.
    ii. subst. eauto.
  Qed.

  Record mem_sh_blk (m: mem) (sh: list bool) (b_sh: block): Prop :=
    MemSendHist {
        (* mem_sh_length: length sh = num_tasks ; *)
        mem_sh_loadbytes:
          Mem.loadbytes m b_sh 0 (Z.of_nat num_tasks) =
          Some (map bool2memval sh);

        mem_sh_writable:
          Mem.range_perm m b_sh 0 (Z.of_nat num_tasks) Cur Writable ;
      }.

  Lemma mem_sh_blk_length
        m sh b
        (MEM_SH_BLK: mem_sh_blk m sh b)
    : length sh = num_tasks.
  Proof.
    inv MEM_SH_BLK.
    hexploit Mem.loadbytes_length; eauto.
    rewrite map_length. rewrite Nat2Z.id. ss.
  Qed.

  Definition mem_sh m (sh: list bool): Prop :=
    fsymb _send_hist (mem_sh_blk m sh).

  Lemma mem_sh_unch
        m m' sh
        (MEM_SH: mem_sh m sh)
        (UNCH: Mem.unchanged_on
                 (fun b _ => Genv.find_symbol ge _send_hist = Some b)
                 m m')
    : mem_sh m' sh.
  Proof.
    ii. rr in MEM_SH.
    hexploit MEM_SH; eauto. intro MEM_SH_BLK.
    clear MEM_SH.

    inv MEM_SH_BLK.
    econs.
    - eapply Mem.loadbytes_unchanged_on; eauto.
    - ii. eapply Mem.perm_unchanged_on; eauto.
  Qed.

  Lemma mem_sh_unch_diffblk
        b_sh m m' sh
        (MEM_SH: mem_sh m sh)
        (MEM_CHB: mem_changed_block b_sh m m')
        (CHB_DIFF: Genv.find_symbol ge _send_hist <> Some b_sh)
    : mem_sh m' sh.
  Proof.
    eapply mem_sh_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of.
    ii. subst. eauto.
  Qed.

  Record mem_skt_blk (m: mem) (sid: nat) (b_sid: block): Prop :=
    MemSocket {
        mem_skt_id:
          Mem.load Mint32 m b_sid 0 =
          Some (Vint (IntNat.of_nat sid));
        mem_skt_writable:
          Mem.range_perm m b_sid 0 4 Cur Writable ;
      }.

  Definition mem_txs m txs :=
    fsymb _txs (mem_skt_blk m txs).

  Definition mem_rxs m rxs :=
    fsymb _rxs (mem_skt_blk m rxs).

  Lemma mem_txs_unch
        m m' txs
        (MEM_SKT: mem_txs m txs)
        (UNCH: Mem.unchanged_on
                 (fun b _ => Genv.find_symbol ge _txs = Some b)
                 m m')
    : mem_txs m' txs.
  Proof.
    ii. rr in MEM_SKT.
    hexploit MEM_SKT; eauto.
    clear MEM_SKT. intro MEM_SKT_BLK.
    inv MEM_SKT_BLK.
    econs.
    - eapply Mem.load_unchanged_on; eauto.
    - ii. eapply Mem.perm_unchanged_on; eauto.
  Qed.

  Lemma mem_txs_unch_diffblk
        b_ch m m' txs
        (MEM_SBUF: mem_txs m txs)
        (MEM_CHB: mem_changed_block b_ch m m')
        (CHB_NOT_MST: Genv.find_symbol ge _txs <> Some b_ch)
    : mem_txs m' txs.
  Proof.
    eapply mem_txs_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of.
    ii. subst. eauto.
  Qed.

  Lemma mem_rxs_unch
        m m' rxs
        (MEM_SKT: mem_rxs m rxs)
        (UNCH: Mem.unchanged_on
                 (fun b _ => Genv.find_symbol ge _rxs = Some b)
                 m m')
    : mem_rxs m' rxs.
  Proof.
    ii. rr in MEM_SKT.
    hexploit MEM_SKT; eauto.
    clear MEM_SKT. intro MEM_SKT_BLK.
    inv MEM_SKT_BLK.
    econs.
    - eapply Mem.load_unchanged_on; eauto.
    - ii. eapply Mem.perm_unchanged_on; eauto.
  Qed.

  Lemma mem_rxs_unch_diffblk
        b_ch m m' rxs
        (MEM_SBUF: mem_rxs m rxs)
        (MEM_CHB: mem_changed_block b_ch m m')
        (CHB_NOT_MST: Genv.find_symbol ge _rxs <> Some b_ch)
    : mem_rxs m' rxs.
  Proof.
    eapply mem_rxs_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of.
    ii. subst. eauto.
  Qed.

End MATCH_MEM.

Lemma mem_sbuf_loadbytes `{SystemEnv}
      m sytm tid mcont b_sbuf
      (RANGE_SYTM: IntRange.uint64 sytm)
      (RANGE_TID: (tid < num_tasks)%nat)
      (MEM_SBUF: mem_sbuf_blk m sytm tid mcont b_sbuf)
  :
    Mem.loadbytes m b_sbuf 0%Z (Z.of_nat pld_size) =
    Some (inj_bytes (IntByte.to_bytes64
                       (IntNat.of_nat64 sytm) ++
                       [Byte.repr (Z.of_nat tid)] ++ mcont)).
Proof.
  replace (Z.of_nat pld_size) with
      (8 + (1 + Z.of_nat msg_size)).
  2: { unfold pld_size. nia. }

  erewrite Mem.loadbytes_concat; try nia.
  { unfold inj_bytes.
    rewrite map_app. reflexivity. }
  { eapply mem_sbuf_next_sync_time; eauto. }
  s.
  erewrite Mem.loadbytes_concat; try nia.
  { rewrite rw_cons_app. reflexivity. }
  { hexploit Mem.load_loadbytes.
    { eapply mem_sbuf_task_id; eauto. }
    i. des.
    ss.
    hexploit Mem.loadbytes_length; eauto. i.
    destruct bytes as [| b []]; ss.
    destruct b; ss.
    hexploit (decode_byte_one_inv (Z.of_nat tid)); eauto.
    { split.
      - transitivity 0.
        { eapply Z.lt_le_incl. ss. }
        nia.
      - cut (Z.of_nat num_tasks < Int.max_signed)%Z.
        { nia. }
        generalize range_num_tasks.
        inversion 1.
        assert (Byte.max_signed < Int.max_signed)%Z by ss.
        nia.
    }
    i. subst.
    ss.
  }
  apply MEM_SBUF.
Qed.

Lemma ip_in_mem_exists `{SystemEnv}
      ge tid tid_r b_ips m
      (MEM_CONSTS: mem_consts ge m tid)
      (FSYMB_IPS: Genv.find_symbol ge _IP_ADDR =
                  Some b_ips)
      (TID: (tid_r < num_tasks + num_mcasts)%nat)
  : exists ip_dest,
    ip_in_mem ip_dest m b_ips
              (Ptrofs.repr (16 * Z.of_nat tid_r)) /\
    dest_id_ip tid_r ip_dest /\
    IntRange.uint ip_dest.
Proof.
  hexploit mem_consts_ip_addr; eauto.
  intro IPS.
  rewrite iForall_nth in IPS.
  specialize (IPS tid_r).

  assert (LEN_TIPS: length task_ips_brep = length task_ips).
  { pose proof task_ips_convert_brep as CONV_TASK_IPS.
    apply Forall2_length in CONV_TASK_IPS. ss. }

  hexploit (nth_error_Some2 _ (task_ips_brep ++ map fst mcasts) tid_r).
  { rewrite app_length.
    rewrite map_length.
    rewrite <- num_mcasts_eq.
    fold bytes in *.
    rewrite LEN_TIPS.
    fold num_tasks. ss.
  }
  i. des.
  renames e1 NTH_EX into ip_bs IP_BS.
  rewrite IP_BS in IPS. ss.

  assert (exists ip,
             <<CONV_IP: IP.convert_brep ip_bs = Some ip>> /\
             <<DEST_ID_IP: dest_id_ip tid_r ip>>).
  { destruct (lt_ge_dec tid_r (length task_ips_brep)) as [LT|GE].
    - rewrite nth_error_app1 in IP_BS by ss.
      pose proof task_ips_convert_brep as CONV_IPS.
      eapply Forall2_nth1 in CONV_IPS; eauto.
      des.
      esplits; eauto.
      r. unfold dest_ips.
      rewrite nth_error_app1 by nia.
      ss.

    - rewrite nth_error_app2 in IP_BS by ss.
      pose proof mcast_ips_convert_brep as CONV_IPS.
      (* hexploit Forall2_length; eauto. i. *)

      apply map_nth_error_iff in IP_BS. des.
      destruct a as (ip_bs' & mbrs). ss. clarify.

      eapply Forall2_nth1 in CONV_IPS; eauto.
      des.
      esplits; eauto.
      r. unfold dest_ips.
      rewrite nth_error_app2 by nia.
      rewrite <- LEN_TIPS. ss.
  }
  des.

  hexploit IP.valid_ip_brep_spec; eauto.
  intros (BS_NONZERO & IP_BS_LEN & IP_SINT).

  exists ip.
  splits; ss.
  2: { range_stac. }

  econs; eauto.
  rewrite Ptrofs.unsigned_repr.
  2: { split; [nia|].
       cut (Z.of_nat tid_r <= Byte.max_signed)%Z.
       { intro TID_R.
         transitivity (16 * Byte.max_signed).
         { nia. }
         eapply Z.lt_le_incl. ss.
       }
       pose proof range_valid_dest_ids as RANGE_D.
       fold num_tasks num_mcasts in *.
       range_stac.
  }
  replace (16 * Z.of_nat tid_r) with (Z.of_nat (tid_r * 16)) by nia.
  rewrite IPS.
  unfold snoc.
  unfold inj_bytes. rewrite map_app. ss.
Qed.

Lemma Mem_msg_entry_inv2 `{SystemEnv}
      m b ofs_inb idx ment
      (MEM_MENT: Mem_msg_entry m b ofs_inb idx ment)
  : <<MENT_RCV: Mem.load Mint8signed m b (ofs_inb + Z.of_nat (mentry_nsz * idx)) =
                Some (if ment then Vtrue else Vfalse)>> /\
                <<MENT_CONT: forall mcont, ment = Some mcont ->
                                      Mem.loadbytes m b (ofs_inb + Z.of_nat (mentry_nsz * idx) + 1) (Z.of_nat msg_size) =
                                      Some (inj_bytes mcont)>>.
Proof.
  r in MEM_MENT. ss.
  destruct ment as [mcont|]; ss.
  - unfold mentry_ensz in MEM_MENT.
    replace (Z.of_nat (msg_size + 1))%nat with
        (1 + Z.of_nat msg_size)%Z in MEM_MENT by nia.
    rewrite rw_cons_app in MEM_MENT.
    apply Mem.loadbytes_split in MEM_MENT; [|nia..].
    destruct MEM_MENT as (mvs1 & mvs2 & LBS_HB1 & LBS_HB2 & BS_EQ).
    hexploit Mem.loadbytes_length; try apply LBS_HB1.
    intro LEN_MVS1.
    destruct mvs1 as [| rcv_hb []]; ss.
    clarify.
    split; ss.
    + r.
      erewrite Mem.loadbytes_load; cycle 1.
      { apply LBS_HB1. }
      { ss. solve_divide. }
      ss.
    + r. intros mcont' AUX.
      symmetry in AUX. inv AUX.
      ss.
  - split; ss.
    r.
    erewrite Mem.loadbytes_load; cycle 1.
    { ss. apply MEM_MENT. }
    { ss. solve_divide. }
    ss.
Qed.

(* Import AppMod. *)

(* Definition progE {sysE: Type -> Type} : Type -> Type := *)
(*   osE +' tlimE +' sysE. *)

(* Notation progE sysE := (osE +' tlimE +' sysE). *)

Existing Instance cprog_event_instance.

Class SimApp
      `{SystemEnv}
      (* {sysE: Type -> Type} *)
      (* `{@CProgSysEvent sysE} *)
      (tid: nat)
      (cprog: Clight.program)
      (app_mod: @AppMod.t obsE bytes)
  : Type :=
  { app_gvar_ilist: list (ident * cglobvar) ;
    app_gfun_ilist: list (ident * fundef) ;
    app_cenv_ilist: list (ident * composite) ;
    app_gvar_ids := map fst app_gvar_ilist ;
    app_gfun_ids := map fst app_gfun_ilist ;
    app_cenv_ids := map fst app_cenv_ilist ;

    main_app_gvar_ids_disj:
      Coqlib.list_disjoint main_gvar_ids app_gvar_ids ;
    main_app_gfun_ids_disj:
      Coqlib.list_disjoint main_gfun_ids app_gfun_ids ;
    main_app_cenv_ids_disj:
      Coqlib.list_disjoint main_cenv_ids app_cenv_ids ;

    (* astate_t: Type ; *)
    inv_app: genv -> AppMod.abst_state_t app_mod -> mem -> Prop ;

    (* itree_app: nat -> list bytes ? -> astate_t -> *)
    (*            itree (sysE +' bsendE) astate_t ; *)

    job_func: Clight.function ;
    job_func_type: type_of_function job_func = Tfunction (Tcons tulong (Tcons (tptr (Tstruct _inbox_t noattr)) Tnil)) tvoid cc_default ;
    job_func_in_app_gfun_ilist:
      In (_job, Internal job_func) app_gfun_ilist;

    idx_job: nat ;

    ge := globalenv cprog;

    (* tid: nat ; *)
    range_tid: (tid < num_tasks)%nat ;

    (* task_id_in_app_gvar_ilist: *)
    (*   In (_TASK_ID, v_TASK_ID_p (Z.of_nat tid)) app_gvar_ilist; *)

    inv_app_dep_app_blocks:
      forall (* ge *) ast m m'
        (INV_APP: inv_app ge ast m)
        (UNCH_APP: Mem.unchanged_on
                     (blocks_of ge app_gvar_ids) m m'),
        inv_app ge ast m' ;

    inv_app_init:
      forall m_i (INIT_MEM: Genv.init_mem cprog = Some m_i),
      inv_app ge (AppMod.init_abst_state app_mod) m_i;

    sim_job_func:
      forall (r: nat -> itree progE unit -> Clight.state -> Prop)
        b_mst txs
        idx' ast ki m kp sytm
        cflg ofsc ofsn inbc inbn
        (mcont: bytes)
        (CALL_CONT: is_call_cont kp)
        (RANGE_SYTM: IntRange.uint64 sytm)
        (RANGE_SYTM2: IntRange.uint64 (sytm + period))

        (RANGE_TXS: IntRange.sint txs)
        (INV_APP: inv_app ge ast m)
        (FSYMB_MST: Genv.find_symbol ge _mstore = Some b_mst)
        (MEM_CONSTS: mem_consts ge m tid)
        (MEM_SBUF: mem_sbuf ge m (sytm + period) tid mcont)
        (MEM_MSTORE: mem_mstore ge m cflg
                                ofsc ofsn inbc inbn)
        (MEM_SH: mem_sh ge m (repeat false num_tasks))
        (MEM_TXS: mem_txs ge m txs)
        (SIM_REST:
           forall sh' ast' m' mcont'
             (UNCH_MAIN: Mem.unchanged_on
                           (blocks_of ge app_unch_gvar_ids) m m')
             (* (main_appinv_region cprog) m m') *)
             (MEM_SH: mem_sh ge m' sh')
             (MEM_SBUF: mem_sbuf ge m' (sytm + period)%nat tid mcont')
             (INV_APP': inv_app ge ast' m'),
             paco3 (_sim_itree (prog_of_clight cprog))
                   r idx' (ki (sh', ast'))
                   (Clight.Returnstate Vundef kp m'))
      ,
        paco3 (_sim_itree (prog_of_clight cprog)) r
              (idx' + idx_job)%nat
              (ret <- MWITree.interp_send
                       tid app_mod txs sytm
                       (repeat false num_tasks)
                       ast inbc;;
               ki ret)
              (Clight.Callstate
                 (Internal job_func)
                 [Vlong (IntNat.of_nat64 sytm);
                 Vptr b_mst (Ptrofs.repr ofsc)] kp m)
    ;
  }.

Section SIM_APP_LEMMAS.
  (* Variable cprog: Clight.program. *)
  Variable (* tid *) txs rxs: nat.

  Context `{SimApp}.
  Let prog: Prog.t := prog_of_clight cprog.
  Let ge := globalenv cprog.

  Lemma inv_app_unch_diffblk
        id ast b m m'
        (INV_APP: inv_app ge ast m)
        (MEM_CH: mem_changed_block b m m')
        (IN_MAIN: In id main_gvar_ids)
        (FIND_SYMB_CH: Genv.find_symbol ge id = Some b)
    : inv_app ge ast m'.
  Proof.
    eapply inv_app_dep_app_blocks; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    intros b_app ofs_app BLKS_OF_APP ?. simpl.
    rr in BLKS_OF_APP. des.
    eapply Genv.global_addresses_distinct; eauto.
    apply not_eq_sym.
    eapply main_app_gvar_ids_disj; eauto.
  Qed.

End SIM_APP_LEMMAS.

Lemma eval_max_time `{SystemEnv}
  : Int64.sub (Int64.repr (-1))
              (Int64.repr (10 * Z.of_nat period)) =
    Int64.repr (Z.of_nat MAX_TIME).
Proof.
  fold Int64.mone.
  rewrite Int64_mone_max_unsigned.
  unfold Int64.sub.
  rewrite Int64.unsigned_repr by ss.
  rewrite Int64.unsigned_repr.
  2: { pose proof period_mul_10_lt_max. nia. }
  rewrite Z.mul_comm.
  fold MAX_TIME_Z.
  rewrite max_time_to_z. ss.
Qed.


Require Export VST.veric.Clight_base.
Require Import VST.veric.rmaps.
Require Import VST.veric.compcert_rmaps.
Require Import VST.veric.res_predicates.
Require Import VST.veric.shares.
Require Import VST.veric.tycontext.
Require Import VST.veric.expr2.

Definition GHOSTspec (A: Type) (x: A) : spec :=
  fun sh loc =>
   allp (jam (eq_dec loc) (fun loc' =>
    yesat (SomeP (ConstType (A -> Prop)) (fun _ y => y = x))
             (FUN (nil,Tvoid) cc_default) sh loc') noat).

Definition ghostp {A: Type} (sh: share) (loc: address) (x: A) : mpred :=
  GHOSTspec A x sh loc.

Lemma ghostp_unique_sepcon:
    forall {A: Type} sh1 sh2 loc (x1 x2: A),
     ghostp sh1 loc x1 * ghostp sh2 loc x2 |-- |> !! (x1=x2).
Proof.
intros.
unfold ghostp, GHOSTspec.
intros w [w1 [w2 [? [? ?]]]].
intros w' ?.
simpl in H2.
apply laterR_level in H2.
generalize (join_level _ _ _ H); intros [? ?].
destruct (level w). inv H2.
hnf.
rename H2 into Hw'.
specialize (H0 loc). specialize (H1 loc).
rewrite jam_true in H0 by auto.
rewrite jam_true in H1 by auto.
destruct H0 as [p ?]. destruct H1 as [p' ?].
hnf in H0,H1.
apply (resource_at_join _ _ _ loc) in H.
rewrite H0 in H; rewrite H1 in H.
simpl in H.
(*rewrite H3 in H. rewrite H4 in H. *)
assert (SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x1) =
          SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x2))%pred.
clear - H.
match goal with |- ?B = ?C => forget B as b; forget C as c end.
inversion H; auto.
clear H.
apply SomeP_inj in H2.
pose proof (@equal_f A Prop _ _ (@equal_f (list Type) (A->Prop) _ _ H2 nil) x1).
simpl in H.
rewrite <- H; auto.
Qed.

Lemma ghostp_unique_andp:
    forall {A: Type} sh loc (x1 x2: A),
     ghostp sh loc x1 && ghostp sh loc x2 |-- |> !! (x1=x2).
Proof.
intros.
unfold ghostp, GHOSTspec.
intros w [? ?].
rename H0 into H1; rename H into H0.
specialize (H0 loc). specialize (H1 loc).
rewrite jam_true in H0 by auto.
rewrite jam_true in H1 by auto.
destruct H0 as [p H0]. destruct H1 as [p' H1].
hnf in H0,H1.
rewrite H0 in H1.
simpl in H1.
intros w' H2.
simpl in H2.
apply laterR_level in H2.
destruct (level w). inv H2.
hnf.
rename H2 into Hw'.
assert (SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x1) =
          SomeP (ConstType (A -> Prop))
            (fun (_ : list Type) (y : A) => y = x2))%pred.
clear - H1.
match goal with |- ?B = ?C => forget B as b; forget C as c end.
inversion H1; auto.
clear - H.
apply SomeP_inj in H.
pose proof (@equal_f A Prop _ _ (@equal_f (list Type) (A->Prop) _ _ H nil) x1).
rewrite <- H0; auto.
Qed.

Definition make_GHOSTspec:
  forall A (sh : share) (rsh: readable_share sh) loc (x: A) (lev: nat),
   exists m: rmap, GHOSTspec A x sh loc m /\ level m =  lev.
Proof.
 intros.
unfold GHOSTspec.
 assert (AV.valid (res_option oo
  (fun l => if eq_dec l loc
   then YES sh rsh (FUN(nil,Tvoid) cc_default)
             (SomeP (ConstType (A -> Prop))
                  (fun _ y => (y = x)))
   else NO Share.bot bot_unreadable))).
 intros b ofs.
 unfold res_option, compose.
 if_tac; auto.
 destruct (make_rmap _ H lev) as [phi [? ?]].
 extensionality l.
 unfold compose, resource_fmap; simpl.
 if_tac; auto.
 exists phi.
 split; auto.
 hnf.
 intro l.
 hnf.
 if_tac.
 subst l.
 hnf. exists rsh.
 hnf.
 rewrite H1. rewrite if_true. f_equal.
 auto.
 do 3 red. rewrite H1.
 rewrite if_false by auto.
 apply NO_identity.
Qed.

Lemma make_ghostp:
  forall A (x: A)  loc (lev: nat),
  exists m : rmap, ghostp Share.top loc x m /\ level m = lev.
Proof.
intros.
unfold ghostp.
destruct (make_GHOSTspec A Share.top readable_share_top loc x lev) as [m [? ?]].
exists m; split; auto.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D M N Aprime Bprime Cprime Dprime Mprime Nprime H G L K : Universe, ((wd_ N M /\ (wd_ M C /\ (wd_ C D /\ (wd_ N D /\ (wd_ Nprime Mprime /\ (wd_ Mprime Cprime /\ (wd_ Cprime Dprime /\ (wd_ Nprime Dprime /\ (wd_ A B /\ (wd_ B C /\ (wd_ A D /\ (wd_ A C /\ (wd_ B D /\ (wd_ Aprime Bprime /\ (wd_ Bprime Cprime /\ (wd_ Aprime Dprime /\ (wd_ Aprime Cprime /\ (wd_ Bprime Dprime /\ (wd_ Nprime Aprime /\ (wd_ Mprime Bprime /\ (wd_ N A /\ (wd_ M B /\ (wd_ N H /\ (wd_ H G /\ (wd_ N G /\ (wd_ M G /\ (wd_ M H /\ (wd_ N C /\ (wd_ D G /\ (wd_ A H /\ (wd_ N L /\ (wd_ L G /\ (wd_ K H /\ (wd_ N K /\ (wd_ H C /\ (wd_ D M /\ (wd_ M A /\ (wd_ K M /\ (wd_ D H /\ (wd_ Mprime Dprime /\ (wd_ Nprime Cprime /\ (wd_ L H /\ (col_ A D H /\ (col_ H A N /\ (col_ M N L /\ (col_ K M C /\ (col_ C K H /\ (col_ D K H /\ (col_ G K H /\ (col_ Nprime Aprime Dprime /\ (col_ N A D /\ (col_ Mprime Bprime Cprime /\ (col_ M B C /\ col_ N D H))))))))))))))))))))))))))))))))))))))))))))))))))))) -> col_ H G C)).
Proof.
  time tac.
Qed.

End FOFProblem.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX DepMaps Protocols Worlds NetworkSem.
From DiSeL
Require Import Actions Injection InductiveInv.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section ProcessSyntax.

Variable this : nid.

(* Syntax for process *)
Inductive proc (W : world) A :=
  Unfinished | Ret of A | Act of action W A this |
  Seq B of proc W B & B -> proc W A |
  Inject V K of injects V W K & proc V A |
  WithInv p I (ii : InductiveInv p I) of
          W = mkWorld (ProtocolWithIndInv ii) & proc (mkWorld p) A.

Definition pcat W A B (t : proc W A) (k : A -> Pred (proc W B)) :=
  [Pred s | exists q, s = Seq t q /\ forall x, q x \In k x].

Inductive schedule :=
  ActStep | SeqRet | SeqStep of schedule |
  InjectStep of schedule | InjectRet |
  WithInvStep of schedule | WithInvRet.

End ProcessSyntax.

Arguments Unfinished [this W A].
Arguments Ret [this W A].
Arguments Act [this W A].
Arguments Seq [this W A B].
Arguments WithInv [this W A].

Section ProcessSemantics.

Variable this : nid.

Fixpoint step (W : world) A (s1 : state) (p1 : proc this W A)
         sc (s2 : state) (p2 : proc this W A) : Prop :=
  match sc, p1 with
  (* Action - make a step *)
  | ActStep, Act a => exists v pf, @a_step _ _ _ a s1 pf s2 v /\ p2 = Ret v
  (* Sequencing - apply a continuation *)
  | SeqRet, Seq _ (Ret v) k => s2 = s1 /\ p2 = k v
  | SeqStep sc', Seq _ p' k1 =>
    exists p'', step s1 p' sc' s2 p'' /\ p2 = Seq p'' k1
  (* Injection of a non-reduced term *)
  | InjectRet, Inject V K pf (Ret v) =>
     exists s1', [/\ s2 = s1, p2 = Ret v & extends pf s1 s1']
  | InjectStep sc', Inject V K pf t1' =>
    exists s1' s2' s t2',
    [/\ p2 = Inject pf t2', s1 = s1' \+ s, s2 = s2' \+ s,
     s1' \In Coh V & step s1' t1' sc' s2' t2']
  (* Imposing an inductive invariant on a non-reduced term *)
  | WithInvRet, WithInv p inv ii pf (Ret v) =>
     exists s1', [/\ s2 = s1, p2 = Ret v & s1 = s1']
  | WithInvStep sc', WithInv p inv ii pf t1' =>
    exists t2', p2 = WithInv p inv ii pf t2' /\
                     step s1 t1' sc' s2 t2'
  | _, _ => False
  end.

Fixpoint good (W : world) A (p : proc this W A) sc  : Prop :=
  match sc, p with
  | ActStep, Act _ => True
  | SeqRet, Seq _ (Ret _) _ => True
  | SeqStep sc', Seq _ p' _ => good p' sc'
  | InjectStep sc', Inject _ _ _ p' => good p' sc'
  | InjectRet, Inject _ _ _ (Ret _) => True
  | WithInvStep sc', WithInv _ _ _ _ p' => good p' sc'
  | WithInvRet, WithInv _ _ _ _ (Ret _) => True
  | _, _ => False
  end.

(*

[Safety in small-step semantics]

The safety (in order to make the following step) with respect to the
schedule is defined inductively on the shape of the program and the
schedule. Omitting the schedule is not a good idea, at it's required
in order to "sequentialize" the execution of the program
structure. Once it's dropped, this structure is lost.

 *)

Fixpoint safe (W : world) A (p : proc this W A) sc (s : state)  : Prop :=
  match sc, p with
  | ActStep, Act a => a_safe a s
  | SeqRet, Seq _ (Ret _) _ => True
  | SeqStep sc', Seq _ p' _ => safe p' sc' s
  | InjectStep sc', Inject V K pf p' =>
      exists s', extends pf s s' /\ safe p' sc' s'
  | InjectRet, Inject V K pf (Ret _) => exists s', extends pf s s'
  | WithInvStep sc', WithInv _ _ _ _ p' => safe p' sc' s
  | WithInvRet, WithInv _ _ _ _ (Ret _) => True
  | _, _ => True
  end.

Definition pstep (W : world) A s1 (p1 : proc this W A) sc s2 p2 :=
  [/\ s1 \In Coh W, safe p1 sc s1 & step s1 p1 sc s2 p2].

(* Some sanity lemmas wrt. stepping *)

Lemma pstep_safe (W : world) A s1 (t : proc this W A) sc s2 q :
        pstep s1 t sc s2 q -> safe t sc s1.
Proof. by case. Qed.

(*

The following lemma established the operational "progress" property: a
program, which is safe and also the schedule is appropriate. Together,
this implies that we can do a step.
 *)

Lemma proc_progress W A s (p : proc this W A) sc :
        s \In Coh W -> safe p sc s -> good p sc ->
        exists s' (p' : proc this W A), pstep s p sc s' p'.
Proof.
move=>C H1 H2; elim: sc W A s p H2 H1 C=>[||sc IH|sc IH||sc IH|]W A s.
- case=>//=a _/= H; move/a_step_total: (H)=>[s'][r]H'.
  by exists s', (Ret r); split=>//=; exists r, H.
- by case=>//; move=>B p k/=; case: p=>//b _ _; exists s, (k b).
- case=>//B p k/=H1 H2 C.
  case: (IH W B s p H1 H2 C)=>s'[p'][G1 G2].
  by exists s', (Seq p' k); split=>//; exists p'.
- case=>// V K pf p/=H1 [z][E]H2 C.
  case: (E)=>s3[Z] C1 C2.
  case: (IH V A z p H1 H2 C1) =>s'[p']H3; case: H3=>S St.
  exists (s' \+ s3), (Inject pf p'); split=>//; first by exists z.
  by subst s; exists z, s', s3, p'.
- case=>//V K pf; case=>// v/=_[s'] E C.
  by exists s, (Ret v); split=>//=; exists s'.
- case=>//pr I ii E p/= H1 H2 C.
  have C' : s \In Coh (mkWorld pr) by subst W; apply: (with_inv_coh C).
  case: (IH (mkWorld pr) A s p H1 H2 C')=>s'[p']H3.
  exists s', (WithInv pr I ii E p'); split=>//=.
  by exists p'; split=>//; case: H3.
- case=>//pr I ii E; case=>//v/=_ _ C.
  by exists s, (Ret v); split=>//=; exists s.
Qed.

(* Some view lemmas for processes and corresponding schedules *)

Lemma stepUnfin W A s1 sc s2 (t : proc this W A) :
        pstep s1 Unfinished sc s2 t <-> False.
Proof. by split=>//; case; case: sc. Qed.

Lemma stepRet W A s1 sc s2 (t : proc this W A) v :
        pstep s1 (Ret v) sc s2 t <-> False.
Proof. by split=>//; case; case: sc. Qed.

Lemma stepAct W A s1 a sc s2 (t : proc this W A) :
        pstep s1 (Act a) sc s2 t <->
        exists v pf, [/\ sc = ActStep, t = Ret v & @a_step _ _ _ a s1 pf s2 v].
Proof.
split; first by case=>C; case: sc=>//= c [v [pf [H ->]]]; exists v, pf.
case=>v[pf] [->-> H]; split=>//; last by exists v, pf.
by apply: (a_safe_coh pf).
Qed.

Lemma stepSeq W A B s1 (t : proc this W B) k sc s2 (q : proc this W A) :
        pstep s1 (Seq t k) sc s2 q <->
        (exists v, [/\ sc = SeqRet, t = Ret v, q = k v, s2 = s1 &
                       s1 \In Coh W]) \/
         exists sc' p',
           [/\ sc = SeqStep sc', q = Seq p' k & pstep s1 t sc' s2 p'].
Proof.
split; last first.
- case; first by case=>v [->->->->].
  by case=>sc' [t'][->->][S H]; do !split=>//; exists t'.
case; case: sc=>//[|sc] C.
- by case: t=>//= v _ [->->]; left; exists v.
by move=>G /= [p' [H1 ->]]; right; exists sc, p'.
Qed.

Lemma stepInject V W K A (em : injects V W K)
                s1 (t : proc this V A) sc s2 (q : proc this W A) :
  pstep s1 (Inject em t) sc s2 q <->
  (* Case 1 : stepped to the final state s1' of the inner program*)
  (exists s1' v, [/\ sc = InjectRet, t = Ret v, q = Ret v, s2 = s1 &
                     extends em s1 s1']) \/
  (* Case 2 : stepped to the nextx state s12 of the inner program*)
  exists sc' t' s1' s2' s,
    [/\ sc = InjectStep sc', q = Inject em t',
     s1 = s1' \+ s, s2 = s2' \+ s, s1 \In Coh W &
              pstep s1' t sc' s2' t'].
Proof.
split; last first.
- case.
  + case=>s1' [v][->->->->] E.
    split=>//=; [by case: E=>x[] | by exists s1'|by exists s1'].
  case=>sc' [t'][s1'][s2'][s][->->->-> C][[C' S] T].
  split=>//=; last by exists s1', s2', s, t'.
  by exists s1'; split=>//; exists s.
case=>C; case: sc=>//=; last first.
- case: t=>//= v [C1 S][s1'][->->{s2 q}] X.
  by left; exists s1'; exists v.
move=>sc /= [s'][X] S [s1'][s2'][t'][t2'][??? C1'] T; subst q s1 s2.
right; exists sc, t2', s1', s2', t'; do !split=>//.
by case: X=>t'' [E] Cs' _; rewrite (coh_prec (cohS C)  _ Cs' E).
Qed.

Lemma stepWithInv W A pr I (ii : InductiveInv pr I) s1
      (t : proc this (mkWorld pr) A) sc s2 (q : proc this W A) pf :
  pstep s1 (WithInv pr I ii pf t) sc s2 q <->
  (exists v, [/\ sc = WithInvRet, t = Ret v, q = Ret v, s2 = s1,
                 s1 \In Coh W & W = mkWorld (ProtocolWithIndInv ii)]) \/
  exists sc' t' , [/\ sc = WithInvStep sc', q = WithInv pr I ii pf t',
                      W = mkWorld (ProtocolWithIndInv ii),
                      s1 \In Coh W & pstep s1 t sc' s2 t'].
Proof.
split; last first.
- case.
  + by case=>v[->->->->{s2}]C E; split=>//=; exists s1.
   by case=>sc' [t'][->->{sc q}]E C[C' S]T; split=>//=; exists t'.
case=>C; case: sc=>//=; last first.
- by case: t=>//=v _[s1'][Z1]Z2 Z3; subst s2 s1' q; left; exists v.
move=>sc /=S[t'][->{q}T]; right; exists sc, t'; split=>//.
by split=>//; subst W; apply: (with_inv_coh C).
Qed.

(*

[Stepping and network semantics]

The following lemma ensures that the operational semantics of our
programs respect the global network semantics.

 *)

Lemma pstep_network_sem (W : world) A s1 (t : proc this W A) sc s2 q :
        pstep s1 t sc s2 q -> network_step W this s1 s2.
Proof.
elim: sc W A s1 s2 t q=>/=.
- move=>W A s1 s2 p q; case: p; do?[by case|by move=>?; case].
  + by move=>a/stepAct [v][pf][Z1]Z2 H; subst q; apply: (a_step_sem H).
  + by move=>???; case.
  + by move=>????; case.
  by move=>?????; case.
- move=>W A s1 s2 p q; case: p; do?[by case|by move=>?; case].
  + move=>B p p0/stepSeq; case=>[[v][_]??? C|[sc'][p'][]]//.
    by subst p s2; apply: Idle.
  by move=>????/stepInject; case=>[[?][?][?]|[?][?][?][?][?][?]]//.
  by move=>?????; case.
- move=>sc HI W A s1 s2 p q; case: p; do?[by case|by move=>?; case].
  + move=>B p p0/stepSeq; case=>[[?][?]|[sc'][p'][][]? ?]//.
    by subst sc' q; apply: HI.
  by move=>????; case=>? _.
  by move=>?????; case.
- move=>sc HI W A s1 s2 p q; case: p; do?[by case|by move=>?; case].
  + by move=>B p p0; case.
  move=>V K pf p/stepInject; case=>[[?][?][?]|[sc'][t'][s1'][s2'][s][][]????]//.
  subst sc' q s1 s2=>C; move/HI=>S; apply: (sem_extend pf)=>//.
  apply/(cohE pf); exists s2', s; case: (step_coh S)=>C1 C2; split=>//.
  move/(cohE pf): (C)=>[s1][s2][E]C' H.
  by move: (coh_prec (cohS C) C1 C' E)=>Z; subst s1'; rewrite (joinxK (cohS C) E).
  by move=>?????; case.
- move=>W A s1 s2 p q; case: p; do?[by case|by move=>?; case].
  + by move=>???; case.
  + move=>V K i p; case/stepInject=>[[s1'][v][_]??? X|[?][?][?][?][?][?]]//.
    by subst p q s2; apply: Idle; split=>//; case: X=>x [].
  by move=>?????; case.

- move=>sc HI W A s1 s2 p q; case: p;
           do?[by case|by move=>?; case|by move=>???; case|by move=>????; case].
  move=>pr I ii E p; case/(stepWithInv s1); first by case=>?; case.
  case=>sc'[t'][][]Z1 Z2 _ C1; subst q sc'.
  by move/HI=>T; subst W; apply: with_inv_step.
move=>W A s1 s2 t q; do?[by case|by move=>?; case|by move=>???; case].
case=>C; case: t=>//pr I ii E; case=>//=v _[s1'][Z1]Z2 Z3.
by subst s1' s2 q; apply: Idle.
Qed.

(*

[Inductive invariants and stepping]

The following lemma is the crux of wrapping into inductive invariants, as
it leverages the proof of the fact that each transition preserves the invariant.

*)

Lemma pstep_inv A pr I (ii : InductiveInv pr I) s1 s2 sc
      (t t' : proc this (mkWorld pr) A):
  s1 \In Coh (mkWorld (ProtocolWithIndInv ii)) ->
  pstep s1 t sc s2 t' ->
  s2 \In Coh (mkWorld (ProtocolWithIndInv ii)).
Proof. by move=>C1; case/pstep_network_sem/(with_inv_step C1)/step_coh. Qed.

End ProcessSemantics.


Require Coq.Lists.List. Import List.ListNotations.
Require Import Coq.ZArith.ZArith. Local Open Scope Z_scope.
Require Import Coq.micromega.Lia.
Require Import Coq.setoid_ring.Ring.
Require Import coqutil.Word.Interface coqutil.Word.Properties.
Require coqutil.Datatypes.List.
Require Import bedrock2.ListPushPullIf.

(* Stores a rewrite opportunity. Will not show up in proof terms, only used in Ltac *)
Inductive rewr(P: Type): Type :=
| mk_rewr(T: Type)(x y: T)(e: x = y)(ctx: T -> Type).
Existing Class rewr.

Lemma rewr_fw{T: Type}{lhs rhs: T}:
  lhs = rhs ->
  forall P : T -> Type, P lhs -> P rhs.
Proof.
  intros. subst. assumption.
Qed.

Lemma rewr_bw{T: Type}{lhs rhs: T}:
  lhs = rhs ->
  forall P : T -> Type, P rhs -> P lhs.
Proof.
  intros. subst. assumption.
Qed.

Ltac rewr_step_in H :=
  let t := type of H in
  lazymatch constr:(_ : rewr t) with
  | mk_rewr _ ?T ?x ?y ?e ?ctx  =>
      let r := constr:(@rewr_fw T x y e ctx) in
      apply r in H
  end.

Ltac mk_rewr equ ctx :=
  refine (mk_rewr _ _ _ _ equ ctx).

Module WordRingAutorewr.
  Ltac mkr orig ctx :=
    refine (mk_rewr _ _ orig _ _ ctx);
    ring_simplify;
    let new := lazymatch goal with |- ?new = _ => new end in
    tryif constr_eq orig new then fail "no simplification opportunity" else reflexivity.

  Ltac mk_word_ring_simplify_rewr P :=
    match P with
    | context C[@word.add ?wi ?wo ?x ?y] =>
        mkr (@word.add wi wo x y) (fun hole => ltac:(let r := context C[hole] in exact r))
    | context C[@word.sub ?wi ?wo ?x ?y] =>
        mkr (@word.sub wi wo x y) (fun hole => ltac:(let r := context C[hole] in exact r))
    | context C[@word.opp ?wi ?wo ?x] =>
        mkr (@word.opp wi wo x) (fun hole => ltac:(let r := context C[hole] in exact r))
    | context C[@word.mul ?wi ?wo ?x ?y] =>
        mkr (@word.mul wi wo x y) (fun hole => ltac:(let r := context C[hole] in exact r))
    end.

  #[export] Hint Extern 5 (rewr ?P) => mk_word_ring_simplify_rewr P : typeclass_instances.
End WordRingAutorewr.

Module HypAutorewr.
  Ltac term_size t acc :=
    lazymatch t with
    | S ?x => lazymatch isnatcst x with
              | true => constr:(S acc)
              | false => term_size x (S acc)
              end
    | Zpos ?p => lazymatch isPcst p with
                 | true => constr:(S acc)
                 | false => term_size p (S acc)
                 end
    | Zneg ?p => lazymatch isPcst p with
                 | true => constr:(S acc)
                 | false => term_size p (S acc)
                 end
    | Z0 => constr:(S acc)
    | ?f ?a => let r := term_size f (S acc) in term_size a r
    | _ => let __ := match constr:(O) with
                     | _ => is_var t
                     | _ => is_const t
                     end in
           constr:(S acc)
    end.

  Ltac mk_rewr_with_hyp P :=
    match goal with
    | E: ?lhs = ?rhs |- _ =>
        lazymatch P with
        | lhs = rhs => fail (* don't rewrite a hypothesis with itself *)
        | context C[lhs] =>
            let s1 := term_size lhs O in
            let s2 := term_size rhs O in
            lazymatch eval cbv in (Nat.ltb s2 s1) with true =>
              let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
              refine (mk_rewr P _ lhs rhs E ctx)
            end
        end
    end.

  #[export] Hint Extern 3 (rewr ?P) => mk_rewr_with_hyp P : typeclass_instances.
End HypAutorewr.

Module ListNoSCAutorewr.
  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[@List.firstn ?A (S ?n) (?a :: ?l)] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P (list A) _ _ (List.firstn_cons n a l) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[@List.skipn ?A (S ?n) (?a :: ?l)] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P (list A) _ _ (List.skipn_cons n a l) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[@List.firstn ?A O ?l] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P (list A) _ _ (List.firstn_O l) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[@List.skipn ?A O ?l] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P (list A) _ _ (List.skipn_O l) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[((?a :: ?x) ++ ?y)%list] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (eq_sym (List.app_comm_cons x y a)) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[([] ++ ?l)%list] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (List.app_nil_l l) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[(?l ++ [])%list] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (List.app_nil_r l) ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[((?l ++ ?m) ++ ?n)%list] =>
        mk_rewr (eq_sym (List.app_assoc l m n))
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.firstn ?n (?l1 ++ ?l2)] =>
        mk_rewr (List.firstn_app n l1 l2)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.firstn ?i (List.firstn ?j ?l)] =>
        mk_rewr (List.firstn_firstn l i j)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.length (List.firstn ?n ?l)] =>
        mk_rewr (List.firstn_length n l)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.firstn ?m (List.skipn ?n ?l)] =>
        mk_rewr (List.firstn_skipn_comm m n l)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.length (?x :: ?xs)] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ (List.length (x :: xs)) (S (List.length xs)) eq_refl ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.length (@nil ?A)] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ (List.length (@nil A)) O eq_refl ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.firstn ?m (List.skipn ?n ?l)] =>
        mk_rewr (List.firstn_skipn_comm m n l)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.nth ?i (List.skipn ?j ?l) ?d] =>
        mk_rewr (List.nth_skipn i j l d)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.repeat ?a O] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ (List.repeat a O) nil eq_refl ctx)
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.skipn ?n (?xs ++ ?ys)] =>
        mk_rewr (List.skipn_app n xs ys)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.skipn ?n (List.skipn ?m ?xs)] =>
        mk_rewr (List.skipn_skipn n m xs)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.unfoldn ?f 0 ?start] =>
        mk_rewr (List.unfoldn_0 f start)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.unfoldn ?f (S ?n) ?start] =>
        mk_rewr (List.unfoldn_S f start n)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.
End ListNoSCAutorewr.

Module PushPullIfAutorewr.
  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[if ?b then ?a else ?a] =>
        mk_rewr (if_same b a)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.firstn ?n (if ?b then ?l1 else ?l2)] =>
        mk_rewr (pull_if_firstn b l1 l2 n)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.length (if ?b then ?l1 else ?l2)] =>
        mk_rewr (pull_if_length b l1 l2)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[List.skipn ?n (if ?b then ?l1 else ?l2)] =>
        mk_rewr (pull_if_skipn b l1 l2 n)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[if ?b then ?l1 ++ ?l2 else ?r] =>
        mk_rewr (push_if_app_l b l1 l2 r)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[if ?b then ?l else ?r1 ++ ?r2] =>
        mk_rewr (push_if_app_r b l r1 r2)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.

  #[export] Hint Extern 1 (rewr ?P) =>
    lazymatch P with
    | context C[if ?b then [?a1] else [?a2]] =>
        mk_rewr (push_if_singleton b a1 a2)
                (fun hole => ltac:(let r := context C[hole] in exact r))
    end
  : typeclass_instances.
End PushPullIfAutorewr.

Module LiaSCAutorewr.
  #[export] Hint Extern 5 (rewr ?P) =>
    match P with
    | context C[word.unsigned (word.of_Z ?x)] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (word.unsigned_of_Z_nowrap x _) ctx); lia
    end
  : typeclass_instances.

  #[export] Hint Extern 5 (rewr ?P) =>
    match P with
    | context C[List.nth ?j (List.firstn ?i ?l) ?d] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (List.nth_firstn i l j d _) ctx); lia
    end
  : typeclass_instances.
End LiaSCAutorewr.

Require Import bedrock2.SepAutoArray bedrock2.ZnWords.

Module ZnWordsSCAutorewr.
  #[export] Hint Extern 10 (rewr ?P) =>
    match P with
    | context C[List.firstn ?n ?l] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (@List.firstn_all2 _ n l _) ctx);
        unfold List.upd, List.upds;
        list_length_rewrites_without_sideconds_in_goal;
        ZnWords
    end
  : typeclass_instances.

  #[export] Hint Extern 10 (rewr ?P) =>
    match P with
    | context C[List.firstn ?n ?l] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (List.firstn_eq_O n l _) ctx);
        unfold List.upd, List.upds;
        list_length_rewrites_without_sideconds_in_goal;
        ZnWords
    end
  : typeclass_instances.

  #[export] Hint Extern 10 (rewr ?P) =>
    match P with
    | context C[List.skipn ?n ?l] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (List.skipn_eq_O n l _) ctx);
        unfold List.upd, List.upds;
        list_length_rewrites_without_sideconds_in_goal;
        ZnWords
    end
  : typeclass_instances.

  #[export] Hint Extern 10 (rewr ?P) =>
    match P with
    | context C[List.skipn ?n ?l] =>
        let ctx := constr:(fun hole => ltac:(let r := context C[hole] in exact r)) in
        refine (mk_rewr P _ _ _ (@List.skipn_all2 _ n l _) ctx);
        unfold List.upd, List.upds;
        list_length_rewrites_without_sideconds_in_goal;
        ZnWords
    end
  : typeclass_instances.
End ZnWordsSCAutorewr.

Require Import bedrock2.groundcbv.

Ltac groundcbv_in H :=
  let t := type of H in
  let t' := groundcbv t in
  progress change t' in H.

Ltac autorew_in_hyps :=
  repeat match goal with
         | H: _ |- _ => rewr_step_in H || groundcbv_in H
         end.


Require Export WellFormedness.
Require Import SyntaxProp.
Require Import StaticProp.
Require Import DynamicProp.
Require Import MapProp.

Lemma wf_actor_ctx :
  forall M H id l L C Q e ctx,
    is_econtext ctx ->
    wf_actor M H id (l, L, C, Q, ctx e) ->
    wf_actor M H id (l, L, C, Q, e).
Proof with eauto using hasType_ctx, freeLocs_ctx, freeIds_ctx, freeBIds_ctx.
  introv Hctx wfActor.
  inverts wfActor as (t & hasType).
  constructors...
Qed.

Lemma wf_msg_heapExtend :
  forall M H L id msg a,
    wf_msg M H L id msg ->
    wf_msg M (heapExtend H a) L id msg.
Proof with (hauto; eauto using wf_msg).
  introv wfMsg.
  inverts wfMsg as Hex Hloc HId HBId...
  constructors...
  + Case "Ids well-formed". crush.
  + Case "BIds well-formed".
    introv HIn.
    eapply HBId in HIn as [Hlt HBloc].
    splits...
    intros...
Qed.

Lemma wf_actor_heapExtend :
  forall M H id a a',
    wf_actor M H id a ->
    wf_actor M (heapExtend H a') id a.
Proof with (hauto; eauto using wf_msg_heapExtend).
  introv wfA.
  inverts wfA as Hthis wfQueue [t hasType] Hloc HId HBId.
  constructors...
  + Case "Ids well-formed". crush.
  + introv HIn.
    eapply HBId in HIn as [Hlt HBloc].
    split...
    intros...
Qed.

Lemma wf_actors_heapExtend :
  forall M H l L Q e id a,
    (forall id a, heapLookup H id = Some a -> wf_actor M H id a) ->
    wf_actor M H (length H) (l, L, Q, e) ->
    heapLookup (heapExtend H (l, L, Q, e)) id = Some a ->
    wf_actor M (heapExtend H (l, L, Q, e)) id a.
Proof with (hauto; eauto using wf_actor_heapExtend).
  introv wfH wfA Hlookup...
Qed.

Lemma wf_queue_heapUpdate :
  forall M H l L L' C' Q Q' e id id' l0 L0 P0 Q0 e0,
    (forall id a, heapLookup H id = Some a -> wf_actor M H id a) ->
    wf_queue M H L id Q ->
    heapLookup H id' = Some (l0, L0, P0, Q0, e0) ->
    (forall l, In l L0 -> In l L') ->
    wf_queue M (heapUpdate H id' (l, L', C', Q', e)) L id Q.
Proof with (hauto; eauto using wf_msg).
  introv wfActors wfQueue Hlookup Hmono.
  introv HIn.
  apply wfQueue in HIn as wfMsg.
  inverts wfMsg as Hex Hloc HId HBId...
  constructors...
  introv HIn'.
  eapply HBId in HIn' as [Hlt HBloc]...
  splits...
  introv HLH. inv_eq...
Qed.

Lemma wf_queue_snoc :
  forall M H L id Q msg,
    wf_queue M H L id Q ->
    wf_msg M H L id msg ->
    wf_queue M H L id (snoc Q msg).
Proof with eauto.
  introv wfQueue wfMsg.
  induction Q; simpls...
  + unfolds; crush.
  + unfolds wf_queue. introv HIn.
    inv HIn; crush.
Qed.

Lemma wf_heap_heapUpdate :
  forall M H l l' L C Q Q' e e' id,
    wf_heap M H ->
    heapLookup H id = Some (l, L, C, Q, e) ->
    wf_actor M H id (l', L, C, Q', e') ->
    local_heap_disjointness H ->
    conversation_disjointness H ->
    wf_heap M (heapUpdate H id (l', L, C, Q', e')).
Proof with (hauto; eauto using wf_queue_heapUpdate).
  introv wfH Hlookup wfActor Hdisj HCdisj.
  assert (id < length H)...
  constructors.
  + introv Hneq HLH1 HLH2 HIn.
    hauto; eapply Hdisj...
  + introv Hneq Hconv1 Hconv2 HC1 HC2.
    eapply HCdisj; eauto; hauto.
  + introv Hlookup'. inverts wfH as _ _ wfActors...
    - inverts wfActor as Hthis wfQid wfQueue HnAtomic HnDup Htype Hloc HId HBId.
      constructors...
      introv HIn. eapply HBId in HIn as [Hlt' HBloc]...
    - eapply wfActors in Hlookup' as wfActor'.
      inverts wfActor' as Hthis wfQid wfQueue HnAtomic HnDup Htype Hloc HId HBId.
      constructors...
      * introv HIn. eapply HBId in HIn as [Hlt' HBloc]...
Qed.

Lemma conversation_lt :
  forall M H id l L C Q e id' qid,
    wf_queueMap M H ->
    wf_actor M H id (l, L, C, Q, e) ->
    C id' = Some qid ->
    id' < length H.
Proof with eauto.
  introv wfM wfActor HC.
  inverts wfActor as _ wfC _ _ _ _ _ _.
  eapply wfC in HC as [Q' HM].
  eapply wfM in HM as [? [? [?L [HLH ?]]]]...
Qed.

Lemma wf_queueMap_heapUpdate :
  forall M H n id L l C Q e,
    wf_cfg (M, H, n) ->
    conv H id = Some C ->
    LH H id = Some L ->
    wf_queueMap M (heapUpdate H id (l, L, C, Q, e)).
Proof with hauto.
  introv wfCfg Hconv HLH.
  inverts wfCfg as wfH wfM _ _.
  inverts wfH as _ _ wfActors.
  unfolds.
  splits 3.
  + introv HIn. eapply wfM in HIn...
  + introv HIn Hconv' HC...
    - eapply wfM...
    - eapply wfM...
  + eapply wfM in H0 as [_ [_ [L' []]]]...
    - assert (id0 < length H)...
      find_actor id0.
      exists L'.
      splits...
      eapply wf_queue_heapUpdate...
    - assert (id < length H)...
      find_actor id.
      exists L'.
      splits...
      eapply wf_queue_heapUpdate...
Qed.


From CTree Require Import
     CTree
	   Eq
	   Interp.Interp.

From RelationAlgebra Require Import
     monoid
     kat
     kat_tac
     prop
     rel
     srel
     comparisons
     rewriting
     normalisation.

From CTreeCCS Require Import
	   Syntax
	   Denotation
	   Operational.

Import CCSNotations.
Import DenNotations.
Import OpNotations.
Open Scope ccs_scope.

Set Implicit Arguments.
Set Contextual Implicit.

Lemma SRep': forall P a P'
               (STEP : step a P P'),
    step a (!P) (P' ∥ !P).
Proof.
  intros * TR; apply SRep,SParL; auto.
Qed.

Lemma trans_nil_inv : forall l p, ~ trans l nil p.
Proof.
  intros * abs; eapply stuckS_is_stuck; apply abs.
Qed.

Definition ι : option action -> @label ccsE :=
  fun a => match a with
        | None => tau
        | Some a => comm a
        end.

Definition γ : @label ccsE -> option action :=
  fun l => match l with
        | val x => None
        | tau   => None
        | obs (Act a) _ => Some a
        end.

Lemma are_opposite_op : forall a, are_opposite a (op a).
Proof.
  unfold op, are_opposite.
  intros []; cbn; rewrite eqb_refl; auto.
Qed.

Lemma are_opposite_are_op : forall a b,
    are_opposite a b ->
    a = op b.
Proof.
  unfold are_opposite,op; intros [] []; cbn; intuition.
  all:destruct (c =? c0)%string eqn:EQ; try easy.
  all:apply eqb_eq in EQ; subst; auto.
Qed.

Lemma use_channel_can_comm : forall c a,
  use_channel c a = false <->
  can_comm c (ι a) = true.
Proof.
  unfold can_comm, use_channel.
  intros ? [[]|]; cbn; split; auto.
  all:match goal with |- context[if ?b then _ else _] => destruct b; easy end.
Qed.

Definition forward (R : term -> ccs -> Prop) : Prop :=
  forall P P' q a,
		R P q ->
		P ⊢ a →op P' ->
	  exists q', trans (ι a) q q' /\ R P' q'.

Definition backward (R : term -> ccs -> Prop) : Prop :=
  forall P q q' l,
		R P q ->
    trans l q q' ->
	  exists P', P ⊢ γ l →op P' /\ R P' q'.

Definition bisim R := forward R /\ backward R.
Definition bisimilar P q := exists R, bisim R /\ R P q.

Lemma bisimilar_bisim : bisim bisimilar.
Proof.
  split; red; intros * (R & BIS & HR) TR;
    pose proof BIS as [F B].
  - edestruct F as (? & ? & ?); eauto; eexists; split; eauto.
    exists R; split; auto.
  - edestruct B as (? & ? & ?); eauto; eexists; split; eauto.
    exists R; split; auto.
Qed.

Definition bisim_model := fun P q => ⟦P⟧ ~ q.

Lemma complete : forward bisim_model.
Proof.
  unfold bisim_model; red.
  intros * HR TR.
  revert q HR.
  induction TR; intros * HR; cbn in *.
  - step in HR; edestruct HR as [[? TR EQ] _].
    apply trans_prefix.
    cbn in *; eauto.
  - step in HR; edestruct HR as [[? TR EQ] _].
    cbn; apply trans_step.
    cbn in *; eauto.
  - edestruct IHTR as (q1 & TR1 & EQ1); eauto.
    step in HR; edestruct HR as [[q' TR' EQ'] _].
    apply trans_plusL; apply TR1. (* Need to fix automation w.r.t. trans/transR *)
    eexists; split; [apply TR' |].
    cbn; rewrite <- EQ', <- EQ1; auto.
  - edestruct IHTR as (q2 & TR2 & EQ2); eauto.
    step in HR; edestruct HR as [[q' TR' EQ'] _].
    apply trans_plusR; apply TR2. (* Need to fix automation w.r.t. trans/transR *)
    eexists; split; [apply TR' |].
    cbn; rewrite <- EQ', <- EQ2; auto.
  - edestruct IHTR as (q1 & TR1 & EQ1); eauto.
    step in HR; edestruct HR as [[q' TR' EQ'] _].
    pL; apply TR1. (* Need to fix automation w.r.t. trans/transR *)
    eexists; split; [apply TR' |].
    cbn; rewrite <- EQ', <- EQ1; auto.
  - edestruct IHTR as (q2 & TR2 & EQ2); eauto.
    step in HR; edestruct HR as [[q' TR' EQ'] _].
    pR; apply TR2. (* Need to fix automation w.r.t. trans/transR *)
    eexists; split; [apply TR' |].
    cbn; rewrite <- EQ', <- EQ2; auto.
  - edestruct IHTR1 as (q1 & TR1' & EQ1); eauto.
    edestruct IHTR2 as (q2 & TR2' & EQ2); eauto.
    step in HR; edestruct HR as [[q' TR' EQ'] _].
    pS; [apply TR1' | apply TR2' | apply are_opposite_op]. (* Need to fix automation w.r.t. trans/transR *)
    eexists; split; [apply TR' |].
    cbn; rewrite <- EQ', <- EQ1, <- EQ2; auto.
  - edestruct IHTR as (q' & TR' & EQ'); eauto.
    eapply trans_new in TR' as (q'' & TR' & EQ''); [| apply use_channel_can_comm; eauto].
    step in HR; edestruct HR as [[q''' TR'' EQ'''] _].
    apply TR'.
    eexists; split.
    apply TR''.
    rewrite <- EQ''', EQ'', <- EQ'; auto.
  - rewrite unfold_bang', paraC in HR.
    exact (IHTR _ HR).
Qed.

Lemma correct : backward bisim_model.
Proof.
  unfold bisim_model; red.
  induction P; intros * HR TR; copy TR; step in HR; destruct HR as [_ B]; apply B in TR as [? TR' EQ']; clear B; cbn in *.
  - exfalso; eapply trans_nil_inv,TR'.
  - apply trans_step_inv in TR' as [EQ ->].
    eexists; split; [constructor |].
    rewrite <- EQ',EQ; auto.
  - apply trans_prefix_inv in TR' as [EQ ->].
    eexists; split; [constructor |].
    rewrite <- EQ', EQ.
    auto.
  - trans_para_invT TR'.
    + edestruct IHP1 as (P' & STEP & EQ''); [reflexivity | apply TRp |].
      eexists; split.
      apply SParL; eauto.
      rewrite <- EQ',EQ,<-EQ''.
      auto.
    + edestruct IHP2 as (P' & STEP & EQ''); [reflexivity | apply TRq |].
      eexists; split.
      apply SParR; eauto.
      rewrite <- EQ',EQ,<-EQ''.
      auto.
    + edestruct IHP1 as (P' & STEP & EQ''); [reflexivity | apply TRp |].
      edestruct IHP2 as (P'' & STEP' & EQ'''); [reflexivity | apply TRq |].
      eexists; split.
      apply SPar with a.
      apply STEP.
      apply are_opposite_sym in Op.
      rewrite <- (are_opposite_are_op _ Op).
      apply STEP'.
      rewrite <- EQ',EQ,<-EQ'',<-EQ'''.
      auto.
  - apply trans_plus_inv in TR' as [(? & TRp & EQ) | (? & TRq & EQ)].
    + edestruct IHP1 as (P' & STEP & EQ''); [reflexivity | apply TRp |].
      eexists; split.
      apply SSumL; eauto.
      rewrite <- EQ',EQ,<-EQ''.
      auto.
    + edestruct IHP2 as (P' & STEP & EQ''); [reflexivity | apply TRq |].
      eexists; split.
      apply SSumR; eauto.
      rewrite <- EQ',EQ,<-EQ''.
      auto.
  - apply trans_new_inv in TR' as (p' & COM & TR & EQ).
    edestruct IHP as (P' & STEP & EQ''); [reflexivity | apply TR |].
    exists (P' ∖ c); split.
    apply SRes; auto.
    rewrite use_channel_can_comm.
    destruct l; auto; destruct e; auto.
    rewrite <- EQ',EQ,sb_guard, <-EQ''; auto.
  - trans_parabang_invT TR'.
    + edestruct IHP as (P' & STEP & EQ''); [reflexivity | apply TRp' |].
      exists (P' ∥ !P); split.
      apply SRep, SParL; auto.
      rewrite <- EQ',EQ,<-EQ''.
      rewrite parabang_eq.
      reflexivity.
    + edestruct IHP as (P' & STEP & EQ''); [reflexivity | apply TRq' |].
      rewrite EQ in EQ'; clear x EQ.
      exists (P' ∥ !P); split.
      apply SRep, SParL; auto.
      rewrite <- EQ', <-EQ''.
      cbn.
      rewrite (paraC ⟦P⟧), parabang_aux, parabang_eq.
      auto.
    + edestruct IHP as (P' & STEP & EQ''); [reflexivity | apply TRp' |].
      edestruct IHP as (P'' & STEP' & EQ'''); [reflexivity | apply TRq' |].
      exists (P' ∥ (P'' ∥ !P)).
      split.
      apply SRep.
      apply SPar with a.
      apply STEP.
      apply are_opposite_sym in Op.
      rewrite <- (are_opposite_are_op _ Op).
      apply SRep', STEP'.
      rewrite <- EQ',EQ,<-EQ'',<-EQ'''.
      rewrite parabang_eq.
      cbn.
      rewrite paraA; auto.
    + edestruct IHP as (P' & STEP & EQ''); [reflexivity | apply TRq' |].
      edestruct IHP as (P'' & STEP' & EQ'''); [reflexivity | apply TRq'' |].
      rewrite EQ in EQ'; clear x EQ.
      rewrite <- EQ'', <- EQ''' in EQ'.
      rewrite paraC, parabang_aux, parabang_eq in EQ'.
      exists (P' ∥ (P'' ∥ !P)).
      split.
      apply SRep.
      apply SPar with a.
      apply STEP.
      apply are_opposite_sym in Op.
      rewrite <- (are_opposite_are_op _ Op).
      apply SRep', STEP'.
      rewrite <- EQ'; cbn; rewrite paraA; auto.
Qed.

Theorem term_model_bisimilar : forall P, bisimilar P ⟦P⟧.
Proof.
  exists bisim_model; split; red; auto using correct,complete.
Qed.

(* We depend currently on
   - [Eqdep.Eq_rect_eq.eq_rect_eq]
 *)
Print Assumptions term_model_bisimilar.

Definition forward_inv (R : ccs -> term -> Prop) : Prop :=
  forall p p' Q l,
		R p Q ->
		trans l p p' ->
	  exists Q', Q ⊢ γ l →op Q' /\ R p' Q'.

Definition backward_inv (R : ccs -> term -> Prop) : Prop :=
  forall p Q Q' a,
		R p Q ->
    Q ⊢ a →op Q' ->
	  exists p', trans (ι a) p p' /\ R p' Q'.

Definition bisim_inv R := forward_inv R /\ backward_inv R.
Definition bisimilar_inv t u := exists R, bisim_inv R /\ R t u.

Lemma bisimilar_inv_bisim_inv : bisim_inv bisimilar_inv.
Proof.
 split; red; intros * (R & BIS & HR) TR;
    pose proof BIS as [F B].
  - edestruct F as (? & ? & ?); eauto; eexists; split; eauto.
    exists R; split; auto.
  - edestruct B as (? & ? & ?); eauto; eexists; split; eauto.
    exists R; split; auto.
Qed.

Definition rev {A B} (R : A -> B -> Prop) : B -> A -> Prop := fun b a => R a b.

Lemma bisim_bisim_inv : forall R, bisim R -> bisim_inv (rev R).
Proof.
  intros ? [F B]; split; red; unfold rev; cbn; intros * HR TR.
  edestruct B; eauto.
  edestruct F; eauto.
Qed.

Lemma term_model_bisimilar_inv : forall P, bisimilar_inv ⟦P⟧ P.
Proof.
  intros P; edestruct (@term_model_bisimilar P) as (R & BIS & HR); eauto.
  eexists; split.
  apply bisim_bisim_inv; eauto.
  auto.
Qed.

Lemma ιγ : forall l (t u : ccs),
    trans l t u ->
    ι (γ l) = l.
Proof.
  intros [] ? ? TR; cbn; auto.
  destruct e,v; auto.
  eapply trans_val_invT in TR; subst; destruct v.
Qed.

Lemma γι : forall l,
    γ (ι l) = l.
Proof.
  intros []; auto.
Qed.

Lemma cross_model_compose : forall T t u U,
    bisimilar t T ->
    Operational.bisim t u ->
    bisimilar u U ->
    T ~ U.
Proof.
  coinduction ? ?.
  intros * EQtT EQtu EQuU.
  pose proof bisimilar_bisim as [F B].
  step in EQtu; destruct EQtu as [F' B'].
  split; intros ? ? TRTt.
  - edestruct B as (T' & TRT' & ?); [apply EQtT | |]; eauto.
    edestruct F' as [U' TRU' ?]; eauto.
    edestruct F as (u' & TRu' & ?); [apply EQuU | |]; eauto.
    erewrite ιγ in TRu'; eauto.
  - edestruct B as (T' & TRT' & ?); [apply EQuU | |]; eauto.
    edestruct B' as [U' TRU' ?]; eauto.
    edestruct F as (u' & TRu' & ?); [apply EQtT | |]; eauto.
    erewrite ιγ in TRu'; eauto.
    cbn in *; eauto.
Qed.

Lemma cross_model_compose' : forall T t u U,
    bisimilar t T ->
    T ~ U ->
    bisimilar u U ->
    Operational.bisim t u.
Proof.
  coinduction ? ?.
  intros * EQtT EQtu EQuU.
  pose proof bisimilar_bisim as [F B].
  step in EQtu; destruct EQtu as [F' B'].
  split; intros ? ? TRTt.
  - edestruct F as (T' & TRT' & ?); [apply EQtT | |]; eauto.
    edestruct F' as [U' TRU' ?]; eauto.
    edestruct B as (u' & TRu' & ?); [apply EQuU | |]; eauto.
    erewrite γι in TRu'; eauto.
  - edestruct F as (T' & TRT' & ?); [apply EQuU | |]; eauto.
    edestruct B' as [U' TRU' ?]; eauto.
    edestruct B as (u' & TRu' & ?); [apply EQtT | |]; eauto.
    erewrite γι in TRu'; eauto.
    cbn in *; eauto.
Qed.

Lemma bisimilar_bisimilar_inv : forall t T,
    bisimilar_inv t T -> bisimilar T t.
Proof.
  intros * (R & [F B] & HR).
  exists (rev R); split; [| apply HR].
  split.
  red; intros; edestruct B; eauto.
  red; intros; edestruct F; eauto.
Qed.

Lemma embed_sound : forall t u, Operational.bisim t u -> ⟦t⟧ ~ ⟦u⟧.
Proof.
  intros * BIS.
  apply (gfp_fp b t u) in BIS; destruct BIS as [F B]; cbn in *.
  step; split.
  - intros ? T' TR.
    pose proof (@term_model_bisimilar t) as BISt.
    pose proof (@term_model_bisimilar u) as BISu.
    pose proof bisimilar_bisim as [F' B'].
    edestruct B' as (t' & TRt & EQTt); [apply BISt | ..]; eauto.
    edestruct F as [u' TR'' EQtu]; eauto.
    edestruct F' as (U' & TRu & EQuU); [apply BISu |..]; eauto.
    erewrite ιγ in TRu; eauto.
    eexists. apply TRu.
    eapply cross_model_compose; eauto.
  - intros ? U' TR.
    pose proof (@term_model_bisimilar_inv u) as BISu.
    pose proof (@term_model_bisimilar_inv t) as BISt.
    pose proof bisimilar_inv_bisim_inv as [F' B'].
    cbn.
    edestruct F' as (u' & TRu & EQuU); [apply BISu |..]; eauto.
    edestruct B as [t' TR'' EQtu]; eauto.
    edestruct B' as (T' & TRT & EQuT); [apply BISt |..]; eauto.
    erewrite ιγ in TRT; eauto.
    eexists. apply TRT.
    apply bisimilar_bisimilar_inv in EQuU, EQuT.
    eapply cross_model_compose; eauto.
Qed.

Lemma embed_complete : forall t u, ⟦t⟧ ~ ⟦u⟧ -> Operational.bisim t u.
Proof.
  intros * BIS.
  step in BIS; destruct BIS as [F B]; cbn in *.
  step; split.
  - intros ? T' TR.
    pose proof (@term_model_bisimilar t) as BISt.
    pose proof (@term_model_bisimilar u) as BISu.
    pose proof bisimilar_bisim as [F' B'].
    edestruct F' as (t' & TRt & EQTt); [apply BISt | ..]; eauto.
    edestruct F as [u' TR'' EQtu]; eauto.
    edestruct B' as (U' & TRu & EQuU); [apply BISu |..]; eauto.
    erewrite γι in TRu; eauto.
    eexists. apply TRu.
    eapply cross_model_compose'; eauto.
  - intros ? U' TR.
    pose proof (@term_model_bisimilar_inv u) as BISu.
    pose proof (@term_model_bisimilar_inv t) as BISt.
    pose proof bisimilar_inv_bisim_inv as [F' B'].
    cbn.
    edestruct B' as (u' & TRu & EQuU); [apply BISu |..]; eauto.
    edestruct B as [t' TR'' EQtu]; eauto.
    edestruct F' as (T' & TRT & EQuT); [apply BISt |..]; eauto.
    erewrite γι in TRT; eauto.
    eexists. apply TRT.
    apply bisimilar_bisimilar_inv in EQuU, EQuT.
    eapply cross_model_compose'; eauto.
Qed.

Theorem equiv_bisims : forall t u, ⟦t⟧ ~ ⟦u⟧ <-> Operational.bisim t u.
Proof.
  intros; split; eauto using embed_complete, embed_sound.
Qed.