From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq path.
From Coq Require Import Eqdep Relation_Operators.
From pcm Require Import axioms pred prelude ordtype finmap pcm unionmap heap.
From DiSeL Require Import Freshness State EqTypeX Protocols Worlds NetworkSem.
From Coq Require Classical_Prop.

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

(* "Atomic" send/receive actions, coherent with the network semantics *)

Module Actions.

Section Actions.

Variable W : world.
Notation getS s l := (getStatelet s l).

(*

Action is defined with respect to the world (i.e., a number of
protocols) and label.

It changes the state as a whole, but, in fact, affects only a specific
statelet in it, associated with a specific label.

*)

Structure action (V : Type) (this : nid)
  := Action
       {
         (* a_lab : Label; *)
         (* a_lab_dom : a_lab \in ddom W; *)

         a_safe : state -> Prop;

         a_safe_coh : forall s, a_safe s -> s \In Coh W;

         (* safe_coh : forall s, a_safe s -> coh (getP a_lab) (getS s a_lab); *)

         a_step : forall s1, (a_safe s1) -> state -> V -> Prop;

         step_total : forall s (pf : a_safe s), exists s' r, a_step pf s' r;

         (* step_coh  : forall s1 s2 r, Coh W s1 -> *)
         (*     a_safe s1 -> a_step s1 s2 r -> coh (getP a_lab) (getS s2 a_lab); *)

         (* step_frame : forall s1 s2 r z, *)
         (*     a_lab != z -> Coh W s1 -> *)
         (*     a_safe s1 -> a_step s1 s2 r -> getS s1 z  = getS s2 z; *)

         (* Action step semantics respects the overall network semantics *)
         step_sem  : forall s1 (pf : a_safe s1) s2 r,
             a_step pf s2 r -> network_step W this s1 s2

       }.

(* Framing follows from the network semantics *)
Lemma step_other this V (a : action V this) l s1 s2 r n (pf : a_safe a s1):
  this != n -> a_step pf s2 r ->
  getLocal n (getS s1 l) = getLocal n (getS s2 l).
Proof.
move=>N S2; move: (step_sem S2)=>H.
by rewrite eq_sym in N; rewrite /getLocal !(step_is_local l H N).
Qed.

End Actions.

Section SkipActionWrapper.

Variable W : world.
Notation getP l := (getProtocol W l).
Notation getS s l := (getStatelet s l).
Variable this : nid.
Variable l : Label.
Variable p : protocol.
Variable pf : getP l = p.

Definition skip_safe s := Coh W s.

Variable V : Type.

(* Skip-like actions allow for reading from the state *)
Variable f : forall s, coh p (getS s l) -> V.

Lemma safe_local s : skip_safe s -> coh p (getS s l).
Proof. by rewrite -pf=>/(coh_s l). Qed.

Definition skip_step s1 (pf : skip_safe s1) (s2 : state) r :=
  [/\ s1 \In Coh W, s1 = s2 & r = f (safe_local pf)].

(* Lemma skip_step_safe s1 s2 r: skip_step s1 s2 r -> skip_safe s1. *)
(* Proof. by case. Qed. *)

Lemma skip_step_total s (S : skip_safe s) : exists s' r, skip_step S s' r.
Proof. by exists s, (f (safe_local S)). Qed.

Lemma skip_safe_coh s1 : skip_safe s1 -> Coh W s1.
Proof. by []. Qed.

Lemma skip_step_sem s1 (S : skip_safe s1) s2 r:
  skip_step S s2 r -> network_step W this s1 s2.
Proof. by move=>H; apply: Idle; case: H. Qed.

Definition skip_action_wrapper :=
  Action skip_safe_coh skip_step_total skip_step_sem.

End SkipActionWrapper.

Section TryReceiveActionWrapper.

Variable W : world.
Notation getP l := (getProtocol W l).
Notation getS s l := (getStatelet s l).
Variable this : nid.

(*

Filter for specific
 - protocol labels
 - message tags
 - message bodies
 *)
Variable filter : Label -> nid -> nat -> pred (seq nat).

(* Necessary validity lemmas *)
Variable f_valid_label : forall l n t m ,
    filter l n t m -> l \in dom (getc W).

(* Variable f_valid_tags : forall l t m , *)
(*     filter l t m -> t \in rcv_tags (getP l). *)

Definition tryrecv_act_safe (s : state) := s \In Coh W.

Lemma tryrecv_act_safe_coh s : tryrecv_act_safe s -> Coh W s.
Proof. by []. Qed.

(* Can we make it decidable rather than classic? *)
Definition tryrecv_act_step s1 s2 (r : option (nid * nat * seq nat)) :=
  exists (pf : s1 \In Coh W),
  (* No message to receive -- all relevant messages are marked *)
    ([/\ (forall l m tms from rt b,
          this \in nodes (getP l) (getS s1 l) ->
          Some (Msg tms from this b) = find m (dsoup (getS s1 l)) ->
          rt \In (rcv_trans (getP l)) ->
          tag tms = (t_rcv rt) ->
          (* This is required for safety *)
          msg_wf rt (coh_s l pf) this from tms ->
          (* The filter applies *)
          filter l from (t_rcv rt) (tms_cont tms) ->
          ~~b),
    r = None & s2 = s1] \/
   (* There is a message to receive and the transition can be executed *)
   exists l m tms from rt (pf' : this \in nodes (getP l) (getS s1 l)),
     let: d :=  getS s1 l in
     [/\ [/\ Some (Msg tms from this true) = find m (dsoup (getS s1 l)),
          rt \In (rcv_trans (getP l)),
          tag tms = (t_rcv rt),
          (* This is required for safety *)
          msg_wf rt (coh_s l pf) this from tms &
          (* The filter applies *)
          filter l from (t_rcv rt) (tms_cont tms)],
      let loc' := receive_step rt from tms (coh_s l pf) pf' in
      let: f' := upd this loc' (dstate d) in
      let: s' := consume_msg (dsoup d) m in
      s2 = upd l (DStatelet f' s') s1 &
      r = Some (from, tag tms, tms_cont tms)]).

Import Classical_Prop.

Lemma tryrecv_act_step_total s:
  tryrecv_act_safe s -> exists s' r , tryrecv_act_step s s' r.
Proof.
move=>C; rewrite /tryrecv_act_step.
case: (classic (exists l m tms from rt (pf' : this \in nodes (getP l) (getS s l)),
                   let: d :=  getS s l in
                   [/\ Some (Msg tms from this true) = find m (dsoup (getS s l)),
                    rt \In (rcv_trans (getP l)),
                    tag tms = (t_rcv rt),
                    msg_wf rt (coh_s l C) this from tms &
                    filter l from (t_rcv rt) (tms_cont tms)])); last first.
- move=>H; exists s, None, C; left; split=>//l m tms from rt b T E1 E2 E3 E M.
  apply/negP=>Z; rewrite Z in E1; clear Z b; apply: H.
  by exists l, m, tms, from, rt.
case=>[l][m][tms][from][rt][T][E1 E2 E3 E M].
exists (let: d :=  getS s l in
        let loc' := receive_step rt from tms (coh_s l C) T in
        let: f' := upd this loc' (dstate d) in
        let: s' := consume_msg (dsoup d) m in
        upd l (DStatelet f' s') s), (Some (from, tag tms, tms_cont tms)).
by exists C; right; exists l, m, tms, from, rt, T.
Qed.

Lemma tryrecv_act_step_safe s1 s2 r:
  tryrecv_act_step s1 s2 r -> tryrecv_act_safe s1.
Proof. by case. Qed.

Lemma tryrecv_act_step_sem s1 (S : tryrecv_act_safe s1) s2 r:
  tryrecv_act_step s1 s2 r -> network_step W this s1 s2.
Proof.
case=>C; rewrite /tryrecv_act_step; case; first by case=>_ _ ->; apply: Idle.
case=>[l][m][tms][from][rt][Y][[E R E1 M]]F/=Z _.
have X1: l \in dom s1 by move: (f_valid_label F); rewrite (cohD C).
by apply: (ReceiveMsg R X1 E1 (i := m) (from := from)).
Qed.

Definition tryrecv_action_wrapper :=
  Action tryrecv_act_safe_coh tryrecv_act_step_total tryrecv_act_step_sem.

End TryReceiveActionWrapper.

(* A wrapper for the send-action *)
Section SendActionWrapper.

Variable W : world.
Variable p : protocol.
Notation getP l := (getProtocol W l).
Notation getS s l := (getStatelet s l).
Variable this : nid.

Variable l : Label.

Variable pf : (getProtocol W l) = p.

(* A dedicated send-transition *)
Variable st: send_trans (coh p).
(* The transition is present *)
Variable pf' : st \In (snd_trans p).

(* The message and the recipient *)
Variable msg : seq nat.
Variable to  : nid.

(* This check is implicit in the action semantics *)
Definition can_send (s : state) := (l \in dom s) && (this \in nodes p (getS s l)).

(* Take only the hooks that affect the transition with a tag st of *)
(* protocol l *)
Definition filter_hooks (h : hooks) :=
  um_filterk (fun e => e.2 == (l, t_snd st)) h.

Definition send_act_safe s :=
  [/\ Coh W s, send_safe st this to (getS s l) msg, can_send s &
      (* All hooks from a "reduced footprint" are applicable *)
      all_hooks_fire (filter_hooks (geth W)) l (t_snd st) s this msg to].

Lemma send_act_safe_coh s : send_act_safe s -> Coh W s.
Proof. by case. Qed.

Lemma safe_safe s : send_act_safe s -> send_safe st this to (getS s l) msg.
Proof. by case. Qed.

Definition send_act_step s1 (S: send_act_safe s1) s2 r :=
   r = msg /\
   exists b,
     Some b = send_step (safe_safe S) /\
     let: d :=  getS s1 l in
     let: f' := upd this b (dstate d) in
     let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg)
                                         this to true)).1 in
     s2 = upd l (DStatelet f' s') s1.

Lemma send_act_step_total s (S: send_act_safe s): exists s' r , send_act_step S s' r.
Proof.
rewrite /send_act_step/send_act_safe.
case: S=>C S J K.
move/(s_safe_def): (S)=>[b][S']E.
set s2 := let: d :=  getS s l in
          let: f' := upd this b (dstate d) in
          let: s' := (post_msg (dsoup d) (Msg (TMsg (t_snd st) msg)
                                                this to true)).1 in
          upd l (DStatelet f' s') s.
exists s2, msg; split=>//; exists b; split=>//.
move: (safe_safe (And4 C S J K))=> S''.
by rewrite -E (pf_irr S'' S') .
Qed.

Lemma send_act_step_sem s1 (S : send_act_safe s1) s2 r:
  send_act_step S s2 r -> network_step W this s1 s2.
Proof.
case=>_[b][E Z]; case: (S)=>C S' /andP[D1] D2 K; subst s2=>/=.
rewrite (pf_irr (safe_safe S) S') in E; clear S.
rewrite /all_hooks_fire/filter_hooks in K.
move: st S' E K pf'; clear pf' st; subst p=>st S' E K' pf'.
apply: (@SendMsg W this s1 _ l st pf' to msg)=>////.
move=>z lc hk E'; apply: (K' z); rewrite E'.
by rewrite find_umfiltk/= eqxx.
Qed.

Definition send_action_wrapper :=
  Action send_act_safe_coh send_act_step_total send_act_step_sem.

End SendActionWrapper.

End Actions.

Module ActionExports.

Definition action := Actions.action.
Definition a_safe := Actions.a_safe.
Definition a_step := Actions.a_step.

Definition a_safe_coh := Actions.a_safe_coh.
Definition a_step_total := Actions.step_total.
Definition a_step_sem := Actions.step_sem.
Definition a_step_other := Actions.step_other.

Definition skip_action_wrapper := Actions.skip_action_wrapper.
Definition send_action_wrapper := Actions.send_action_wrapper.
Definition tryrecv_action_wrapper := Actions.tryrecv_action_wrapper.

End ActionExports.

Export ActionExports.


From sflib Require Import sflib.
From Paco Require Import paco.

Require Export Coq.Strings.String Coq.Lists.List.
Require Import Coq.Classes.RelationClasses.
Require Import Program.
Require Import Permutation.

From Fairness Require Import Axioms.
From Fairness Require Export ITreeLib FairBeh FairSim NatStructsLarge.
From Fairness Require Import pind PCMLarge World.
From Fairness Require Export Mod Concurrency.
From Fairness Require Import KnotSim LocalAdequacyAux.
From Fairness Require Import
     ModSim MSim2YOrd YOrd2Stid Stid2NoSync NoSync2Stutter
     Stutter2Knot Knot2Glob.
From Fairness Require Import SchedSim Adequacy.

Set Implicit Arguments.

Section LADEQ.

  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Let ident_src := sum_tid _ident_src.
  Variable _ident_tgt: ID.
  Let ident_tgt := sum_tid _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Notation srcE := (programE _ident_src state_src).
  Notation tgtE := (programE _ident_tgt state_tgt).

  Variable wf_stt: Type -> Type -> WF.
  Let nm_wf_stt: Type -> Type -> WF := nm_wf_stt wf_stt.

  Let shared := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt.

  Notation threads_src1 R0 := (threads _ident_src (sE state_src) R0).
  Notation threads_src2 R0 := (threads2 _ident_src (sE state_src) R0).
  Notation threads_tgt R1 := (threads _ident_tgt (sE state_tgt) R1).

  (* Variable I: shared -> URA.car -> Prop. *)

  Variable St: wf_tgt.(T) -> wf_tgt.(T).
  Hypothesis lt_succ_diag_r_t: forall (t: wf_tgt.(T)), wf_tgt.(lt) t (St t).

  Lemma ModSimStutter_lsim_implies_gsim
        R0 R1 (RR: R0 -> R1 -> Prop)
        (ths_src: threads_src1 R0)
        (ths_tgt: threads_tgt R1)
        (WF: th_wf_pair ths_src ths_tgt)
        tid
        (FINDS: Th.find tid ths_src = None)
        (FINDT: Th.find tid ths_tgt = None)
        src tgt
        (st_src: state_src) (st_tgt: state_tgt)
        ps pt
        (LSIM: forall im_tgt,
          exists (I: shared -> URA.car -> Prop),
          exists im_src (os: (nm_wf_stt R0 R1).(T)) rs_ctx o,
            (<<RSWF: Th.find tid rs_ctx = None>>) /\
              (<<OSWF: (forall tid', Th.In tid' ths_src -> Th.In tid' os) /\ (Th.find tid os = None)>>) /\
              (<<LSIM:
                forall im_tgt0
                  (FAIR: fair_update im_tgt im_tgt0 (prism_fmap inlp (tids_fmap tid (NatSet.add tid (key_set ths_tgt))))),
                exists im_src0,
                  (fair_update im_src im_src0 (prism_fmap inlp (tids_fmap tid (NatSet.add tid (key_set ths_src))))) /\
                    (ModSimStutter.lsim (wf_stt) I tid (local_RR I RR tid)
                                        ps pt (sum_of_resources rs_ctx) (o, src) tgt
                                        (NatSet.add tid (key_set ths_src),
                                          im_src0, im_tgt0, st_src, st_tgt))>>) /\
              (<<LOCAL: forall tid (src: itree srcE R0) (tgt: itree tgtE R1) o r_own
                          (OWN: r_own = fst (get_resource tid rs_ctx))
                          (LSRC: Th.find tid ths_src = Some src)
                          (LTGT: Th.find tid ths_tgt = Some tgt)
                          (ORD: Th.find tid os = Some o),
                  (local_sim_pick wf_stt I RR src tgt tid o r_own)>>))
    :
    gsim wf_src wf_tgt RR
         (interp_all st_src (Th.add tid src ths_src) tid)
         (interp_all st_tgt (Th.add tid tgt ths_tgt) tid).
  Proof.
    remember (Th.map (fun th => (false, th)) ths_src) as ths_src2.
    assert (FINDS2: Th.find tid ths_src2 = None).
    { subst. rewrite NatMapP.F.map_o. rewrite FINDS. ss. }
    assert (WF0: th_wf_pair ths_src2 ths_tgt).
    { subst. unfold th_wf_pair, nm_wf_pair in *. rewrite <- WF. unfold key_set. rewrite nm_map_unit1_map_eq. auto. }
    replace ths_src with (nm_proj_v2 ths_src2).
    2:{ subst. unfold nm_proj_v2. rewrite nm_map_map_eq. ss. apply nm_map_self_eq. }
    eapply ksim_implies_gsim; auto.
    eapply Stutter2Knot.lsim_implies_ksim; eauto.
    i. specialize (LSIM im_tgt). des.
    replace (NatSet.add tid (key_set ths_src2)) with (NatSet.add tid (key_set ths_src)).
    2:{ unfold key_set. clarify. rewrite nm_map_unit1_map_eq. auto. }
    esplits; eauto.
    { i. apply OSWF. rewrite Heqths_src2 in H. eapply Th.map_2 in H. auto. }
    i. assert (SF: sf = false).
    { clarify. rewrite NatMapP.F.map_o in LSRC.
      destruct (NatMap.find (elt:=thread _ident_src (sE state_src) R0) tid0 ths_src); ss. clarify. }
    subst sf. split; i; ss. eapply LOCAL; auto.
    clarify. rewrite NatMapP.F.map_o in LSRC.
    destruct (NatMap.find (elt:=thread _ident_src (sE state_src) R0) tid0 ths_src); ss. clarify.
    Unshelve. exact true.
  Qed.

  Definition ModSimStutter_local_sim_threads
             (I: shared -> URA.car -> Prop)
             R0 R1 (RR: R0 -> R1 -> Prop)
             (ths_src: threads_src1 R0)
             (ths_tgt: threads_tgt R1)
    :=
    List.Forall2
      (fun '(t1, src) '(t2, tgt) => (t1 = t2) /\ (ModSimStutter.local_sim wf_stt I RR src tgt))
      (Th.elements ths_src) (Th.elements ths_tgt).

  Lemma ModSimStutter_local_sim_threads_local_sim_pick
        R0 R1 (RR: R0 -> R1 -> Prop)
        (ths_src: threads_src1 R0)
        (ths_tgt: threads_tgt R1)
        (* (LOCAL: ModSimStutter_local_sim_threads RR ths_src ths_tgt) *)
        (st_src: state_src) (st_tgt: state_tgt)
        (INV: forall im_tgt, exists (I: shared -> URA.car -> Prop), exists im_src r_shared,
            (ModSimStutter_local_sim_threads I RR ths_src ths_tgt) /\
              (I (NatSet.empty, im_src, im_tgt, st_src, st_tgt) r_shared) /\ (URA.wf r_shared))
    :
    forall im_tgt,
    exists (I: shared -> URA.car -> Prop),
    exists (im_src0 : imap ident_src wf_src) r_shared0 (os: (nm_wf_stt R0 R1).(T)) (rs_local: local_resources),
      (I (key_set ths_src, im_src0, im_tgt, st_src, st_tgt) r_shared0) /\
        (resources_wf r_shared0 rs_local) /\
        (Forall4 (fun '(t1, src) '(t2, tgt) '(t3, r_own) '(t4, o) =>
                    (t1 = t2) /\ (t1 = t3) /\ (t1 = t4) /\ (local_sim_pick wf_stt I RR src tgt t1 o r_own))
                 (Th.elements (elt:=thread _ident_src (sE state_src) R0) ths_src)
                 (Th.elements (elt:=thread _ident_tgt (sE state_tgt) R1) ths_tgt)
                 (Th.elements rs_local) (Th.elements os)).
  Proof.
    i. specialize (INV im_tgt). des. rename INV into LOCAL. exists I. move I after St.
    unfold ModSimStutter_local_sim_threads in LOCAL.
    match goal with
    | FA: List.Forall2 _ ?_ml1 ?_ml2 |- _ => remember _ml1 as tl_src; remember _ml2 as tl_tgt
    end.
    move LOCAL before RR. revert_until LOCAL. induction LOCAL; i.
    {
      (* specialize (INV im_tgt). des. *)
      symmetry in Heqtl_src; apply NatMapP.elements_Empty in Heqtl_src.
      symmetry in Heqtl_tgt; apply NatMapP.elements_Empty in Heqtl_tgt.
      apply nm_empty_eq in Heqtl_src, Heqtl_tgt. clarify.
      esplits; ss; eauto.
      - unfold NatSet.empty in *. rewrite !key_set_empty_empty_eq. eauto.
      - instantiate (1:=@NatMap.empty _). unfold resources_wf. r_wf INV1.
        rewrite sum_of_resources_empty. r_solve.
      - instantiate (1:=NatMap.empty _). econs.
    }

    des_ifs. des; clarify. rename k0 into tid1, i into src1, i0 into tgt1.
    hexploit nm_elements_cons_rm. eapply Heqtl_src. intro RESS.
    hexploit nm_elements_cons_rm. eapply Heqtl_tgt. intro REST.
    hexploit IHLOCAL; clear IHLOCAL; eauto. intro IND.
    des.
    (* clear INV. *)
    unfold ModSimStutter.local_sim in H0.
    specialize (H0 _ _ _ _ _ _ (sum_of_resources rs_local) IND tid1 (key_set ths_src)).
    hexploit H0; clear H0.
    { econs. rewrite key_set_pull_rm_eq. eapply nm_find_rm_eq.
      erewrite <- key_set_pull_add_eq. instantiate (1:=src1).
      rewrite <- nm_find_some_rm_add_eq; auto. eapply nm_elements_cons_find_some; eauto.
    }
    { r_wf IND0. }
    { instantiate (1:=im_tgt). clear. ii. unfold prism_fmap; ss. des_ifs. }
    i; des.
    assert (WFPAIR: nm_wf_pair (NatMap.remove (elt:=thread _ident_src (sE state_src) R0) tid1 ths_src) rs_local).
    { hexploit list_forall4_implies_forall2_3. eauto.
      { i. instantiate (1:=fun '(t1, src) '(t3, r_own) => t1 = t3). ss. des_ifs. des; auto. }
      intros FA2. rewrite RESS in FA2. apply nm_forall2_wf_pair in FA2. auto.
    }
    assert (RSL: NatMap.find (elt:=M) tid1 rs_local = None).
    { eapply nm_wf_pair_find_cases in WFPAIR. des. eapply WFPAIR. apply nm_find_rm_eq. }
    assert (WFPAIRO: nm_wf_pair (NatMap.remove (elt:=thread _ident_src (sE state_src) R0) tid1 ths_src) os).
    { hexploit list_forall4_implies_forall2_4. eauto.
      { i. instantiate (1:=fun '(t1, src) '(t4, o) => t1 = t4). ss. des_ifs. des; auto. }
      intros FA2. rewrite RESS in FA2. apply nm_forall2_wf_pair in FA2. auto.
    }
    assert (FINDOS: NatMap.find tid1 os = None).
    { eapply nm_wf_pair_find_cases in WFPAIRO. des. eapply WFPAIRO. apply nm_find_rm_eq. }

    esplits; eauto.
    { instantiate (1:=Th.add tid1 r_own rs_local). unfold resources_wf. rewrite sum_of_resources_add. r_wf VALID. auto. }
    replace (Th.elements (Th.add tid1 r_own rs_local)) with ((tid1, r_own) :: (Th.elements rs_local)).
    instantiate (1:=Th.add tid1 o os).
    replace (Th.elements (Th.add tid1 o os)) with ((tid1, o) :: (Th.elements os)).
    { econs; auto. }
    { remember (Th.add tid1 o os) as os1.
      assert (REP: os = (NatMap.remove tid1 os1)).
      { rewrite Heqos1. rewrite nm_find_none_rm_add_eq; auto. }
      rewrite REP. rewrite REP in WFPAIRO. rewrite RESS in Heqtl_src.
      eapply wf_pair_elements_cons_rm; eauto.
      { eapply nm_wf_pair_rm_inv; eauto.
        - unfold NatMap.In, NatMap.Raw.PX.In. exists src1. unfold NatMap.Raw.PX.MapsTo. ss.
          unfold Th.elements, Th.Raw.elements in Heqtl_src. rewrite <- Heqtl_src. econs 1. ss.
        - rewrite Heqos1. apply NatMapP.F.add_in_iff. auto.
      }
      { rewrite Heqos1. rewrite nm_find_add_eq; auto. }
    }
    { remember (Th.add tid1 r_own rs_local) as rs_local1.
      assert (REP: rs_local = (NatMap.remove tid1 rs_local1)).
      { rewrite Heqrs_local1. rewrite nm_find_none_rm_add_eq; auto. }
      rewrite REP. rewrite REP in WFPAIR. rewrite RESS in Heqtl_src.
      eapply wf_pair_elements_cons_rm; eauto.
      { eapply nm_wf_pair_rm_inv; eauto.
        - unfold NatMap.In, NatMap.Raw.PX.In. exists src1. unfold NatMap.Raw.PX.MapsTo. ss.
          unfold Th.elements, Th.Raw.elements in Heqtl_src. rewrite <- Heqtl_src. econs 1. ss.
        - rewrite Heqrs_local1. apply NatMapP.F.add_in_iff. auto.
      }
      { rewrite Heqrs_local1. rewrite nm_find_add_eq; auto. }
    }
  Qed.

  Lemma forall4_implies_gsim
        R0 R1 (RR: R0 -> R1 -> Prop)
        (ths_src: threads_src1 R0)
        (ths_tgt: threads_tgt R1)
        (st_src: state_src) (st_tgt: state_tgt)
        tid
    :
    (forall im_tgt,
      exists (I: shared -> URA.car -> Prop),
      exists (im_src0 : imap ident_src wf_src) r_shared0 (os: (nm_wf_stt R0 R1).(T)) (rs_local: local_resources),
        (I (key_set ths_src, im_src0, im_tgt, st_src, st_tgt) r_shared0) /\
          (resources_wf r_shared0 rs_local) /\
          (Forall4 (fun '(t1, src) '(t2, tgt) '(t3, r_own) '(t4, o) =>
                      (t1 = t2) /\ (t1 = t3) /\ (t1 = t4) /\ (local_sim_pick wf_stt I RR src tgt t1 o r_own))
                   (Th.elements (elt:=thread _ident_src (sE state_src) R0) ths_src)
                   (Th.elements (elt:=thread _ident_tgt (sE state_tgt) R1) ths_tgt)
                   (Th.elements rs_local) (Th.elements os))) ->
    gsim wf_src wf_tgt RR
         (interp_all st_src ths_src tid)
         (interp_all st_tgt ths_tgt tid).
  Proof.
    intros USIM. ii. assert (WFP: nm_wf_pair ths_src ths_tgt).
    { specialize (USIM mt). des. eapply list_forall4_implies_forall2_2 in USIM1.
      2:{ i. instantiate (1:= fun '(k1, _) '(k2, _) => k1 = k2). des_ifs. des; clarify. }
      eapply nm_forall2_wf_pair.  auto.
    }
    cut (gsim wf_src wf_tgt RR (interp_all st_src ths_src tid) (interp_all st_tgt ths_tgt tid)).
    { i. specialize (H mt). auto. }
    clear mt.

    destruct (NatMapP.F.In_dec ths_src tid).
    2:{ destruct (NatMapP.F.In_dec ths_tgt tid).
        { eapply nm_wf_pair_find_cases in WFP. des. eapply NatMapP.F.not_find_in_iff in n.
          eapply WFP in n. eapply NatMapP.F.not_find_in_iff in n. clarify. }
        eapply NatMapP.F.not_find_in_iff in n. eapply NatMapP.F.not_find_in_iff in n0.
        unfold interp_all.
        rewrite (unfold_interp_sched_nondet_None tid _ _ n).
        rewrite (unfold_interp_sched_nondet_None tid _ _ n0).
        rewrite !interp_state_vis. unfold gsim. i.
        specialize (USIM mt). des. exists im_src0, false, false.
        rewrite <- bind_trigger. pfold. econs 10.
    }
    rename i into INS.
    assert (INT: Th.In tid ths_tgt).
    { destruct (NatMapP.F.In_dec ths_tgt tid); auto.
      apply nm_wf_pair_sym in WFP. eapply nm_wf_pair_find_cases in WFP. des.
      eapply NatMapP.F.not_find_in_iff in n. eapply WFP in n.
      eapply NatMapP.F.not_find_in_iff in n. clarify.
    }
    (* clear WFP. *)

    eapply NatMapP.F.in_find_iff in INS, INT.
    destruct (Th.find tid ths_src) eqn:FINDS.
    2:{ clarify. }
    destruct (Th.find tid ths_tgt) eqn:FINDT.
    2:{ clarify. }
    clear INS INT. rename i into src0, i0 into tgt0.
    remember (Th.remove tid ths_src) as ths_src0.
    remember (Th.remove tid ths_tgt) as ths_tgt0.
    assert (POPS: nm_pop tid ths_src = Some (src0, ths_src0)).
    { unfold nm_pop. rewrite FINDS. rewrite Heqths_src0. auto. }
    assert (POPT: nm_pop tid ths_tgt = Some (tgt0, ths_tgt0)).
    { unfold nm_pop. rewrite FINDT. rewrite Heqths_tgt0. auto. }
    i. replace ths_src with (Th.add tid src0 ths_src0).
    2:{ symmetry; eapply nm_pop_res_is_add_eq; eauto. }
    replace ths_tgt with (Th.add tid tgt0 ths_tgt0).
    2:{ symmetry; eapply nm_pop_res_is_add_eq; eauto. }

    assert (WFST0: nm_wf_pair ths_src0 ths_tgt0).
    { subst. eapply nm_wf_pair_rm. auto. }
    clear WFP.
    eapply ModSimStutter_lsim_implies_gsim; auto.
    { eapply nm_pop_res_find_none; eauto. }
    { eapply nm_pop_res_find_none; eauto. }

    cut (forall im_tgt0,
            exists (I: shared -> URA.car -> Prop),
          exists im_src0 r_shared0 (os0: (nm_wf_stt R0 R1).(T)) rs_ctx0,
            (I (key_set ths_src, im_src0, im_tgt0, st_src, st_tgt) r_shared0) /\
              (resources_wf r_shared0 rs_ctx0) /\
              (nm_wf_pair ths_src os0) /\
              (forall (tid0 : Th.key) (src : thread _ident_src (sE state_src) R0)
                 (tgt : thread _ident_tgt (sE state_tgt) R1) o r_own,
                  (r_own = fst (get_resource tid0 rs_ctx0)) ->
                  (Th.find (elt:=thread _ident_src (sE state_src) R0) tid0 ths_src = Some src) ->
                  (Th.find (elt:=thread _ident_tgt (sE state_tgt) R1) tid0 ths_tgt = Some tgt) ->
                  (Th.find tid0 os0 = Some o) ->
                  local_sim_pick wf_stt I RR src tgt tid0 o r_own)).
    { i. specialize (H im_tgt). des.
      assert (POPOS: exists o os, nm_pop tid os0 = Some (o, os)).
      { hexploit nm_wf_pair_pop_cases. eapply H1. instantiate (1:=tid). i; des; eauto.
        unfold nm_pop in H3. rewrite FINDS in H3. ss. }
      des. exists I, im_src0, os, (snd (get_resource tid rs_ctx0)), o. splits.
      - eapply get_resource_snd_find_eq_none.
      - i. eapply nm_wf_pair_pop_cases in H1. des. erewrite POPS in H1. ss.
        rewrite POPS in H1; rewrite POPOS in H4. clarify.
        eapply nm_wf_pair_find_cases in H5. des. eapply NatMapP.F.in_find_iff. eapply H1.
        eapply NatMapP.F.in_find_iff. auto.
      - eapply find_none_aux; eauto.
      - ii. specialize (H2 tid src0 tgt0 o (fst (get_resource tid rs_ctx0))). hexploit H2; clear H2; auto.
        { eapply nm_pop_find_some; eauto. }
        i. unfold local_sim_pick in H2.
        assert (SETS: NatSet.add tid (key_set ths_src0) = key_set ths_src).
        { subst. rewrite key_set_pull_rm_eq. unfold NatSet.add.
          rewrite <- nm_find_some_rm_add_eq; auto. eapply key_set_find_some1; eauto.
        }
        hexploit H2; clear H2. eapply H.
        { instantiate (1:=sum_of_resources (snd (get_resource tid rs_ctx0))).
          hexploit resources_wf_get_wf. eapply H0.
          2:{ i. des. eapply WF. }
          instantiate (1:=tid). destruct (get_resource tid rs_ctx0); ss.
        }
        { rewrite <- SETS; eauto. unfold nm_wf_pair in WFST0. rewrite WFST0. eauto. }
        rewrite !SETS. i; des. esplits; eauto.
      - i. eapply H2.
        { rewrite OWN. eapply get_resource_rs_neq. destruct (tid_dec tid tid0); auto. clarify.
          rewrite nm_find_rm_eq in LSRC. ss. }
        eapply find_some_aux; eauto. eapply find_some_aux; eauto. eapply find_some_aux; eauto.
    }

    cut (forall im_tgt,
            exists (I: shared -> URA.car -> Prop),
          exists (im_src0 : imap ident_src wf_src) r_shared0 (os0: (nm_wf_stt R0 R1).(T)) rs_ctx0,
            (I (key_set ths_src, im_src0, im_tgt, st_src, st_tgt) r_shared0) /\
              (resources_wf r_shared0 rs_ctx0) /\
              (Forall3 (fun '(t1, src) '(t2, tgt) '(t3, o) =>
                          (t1 = t2) /\ (t1 = t3) /\
                            (local_sim_pick wf_stt I RR src tgt t1 o (fst (get_resource t1 rs_ctx0))))
                       (Th.elements (elt:=thread _ident_src (sE state_src) R0) ths_src)
                       (Th.elements (elt:=thread _ident_tgt (sE state_tgt) R1) ths_tgt)
                       (Th.elements os0))).
    { intro FA. i. specialize (FA im_tgt0). des. esplits; eauto.
      { hexploit list_forall3_implies_forall2_3. eauto.
        { i. instantiate (1:= fun '(t1, src) '(t3, o) => t1 = t3). ss. des_ifs. des; auto. }
        intros FA2. apply nm_forall2_wf_pair in FA2. eauto.
      }
      i. subst. eapply nm_forall3_implies_find_some in FA1; eauto.
    }

    i. rename USIM into FAALL. specialize (FAALL im_tgt). des.
    exists I, im_src0, r_shared0, os, rs_local. splits; auto.
    clear - FAALL1.
    eapply nm_find_some_implies_forall3.
    { hexploit list_forall4_implies_forall2_2. eauto.
      { i. instantiate (1:=fun '(t1, src) '(t2, tgt) => t1 = t2). ss. des_ifs. des; auto. }
      intros FA2. apply nm_forall2_wf_pair; auto.
    }
    { hexploit list_forall4_implies_forall2_4. eauto.
      { i. instantiate (1:=fun '(t1, src) '(t4, o) => t1 = t4). ss. des_ifs. des; auto. }
      intros FA2. apply nm_forall2_wf_pair; auto.
    }
    { i. hexploit nm_forall4_implies_find_some. eapply FAALL1. all: eauto.
      2:{ ss. eauto. }
      assert (WFPAIR: nm_wf_pair ths_src rs_local).
      { hexploit list_forall4_implies_forall2_3. eauto.
        { i. instantiate (1:=fun '(t1, src) '(t3, r_own) => t1 = t3). ss. des_ifs. des; auto. }
        intros FA2. apply nm_forall2_wf_pair in FA2. auto.
      }
      hexploit nm_wf_pair_find_cases. eapply WFPAIR. i. des. clear H. hexploit H0.
      { ii. rewrite FIND1 in H. ss. }
      i. destruct (NatMap.find k rs_local) eqn:FRS; ss. erewrite get_resource_find_some_fst; eauto.
    }
    Unshelve. all: exact true.
  Qed.

  Theorem ModSimStutter_local_sim_implies_gsim
          R0 R1 (RR: R0 -> R1 -> Prop)
          (ths_src: threads_src1 R0)
          (ths_tgt: threads_tgt R1)
          (* (LOCAL: ModSimStutter_local_sim_threads RR ths_src ths_tgt) *)
          (st_src: state_src) (st_tgt: state_tgt)
          (INV: forall im_tgt, exists (I: shared -> URA.car -> Prop), exists im_src r_shared,
              (ModSimStutter_local_sim_threads I RR ths_src ths_tgt) /\
                (I (NatSet.empty, im_src, im_tgt, st_src, st_tgt) r_shared) /\ (URA.wf r_shared))
          tid
    :
    gsim wf_src wf_tgt RR
         (interp_all st_src ths_src tid)
         (interp_all st_tgt ths_tgt tid).
  Proof.
    eapply forall4_implies_gsim. i.
    i. hexploit ModSimStutter_local_sim_threads_local_sim_pick; eauto.
  Qed.

End LADEQ.

Section ADEQ.

  Lemma _numbering_cons
        E (l: list E) n x
    :
    _numbering (x :: l) n = (n, x) :: (_numbering l (S n)).
  Proof. reflexivity. Qed.

  Lemma of_list_cons
        elt (l: list (NatMap.key * elt)) k e
    :
    NatMapP.of_list ((k, e) :: l) = Th.add k e (NatMapP.of_list l).
  Proof. reflexivity. Qed.

  Lemma mod_funs_cases
        (m: Mod.t)
    :
    (forall fn, Mod.funs m fn = None) \/ (exists fn ktr, Mod.funs m fn = Some ktr).
  Proof.
    destruct (classic (forall fn, Mod.funs m fn = None)); auto.
    apply Classical_Pred_Type.not_all_ex_not in H. right. des.
    destruct (Mod.funs m n) eqn:FUNS; ss; eauto.
  Qed.

  Theorem modsim_adequacy
          m_src m_tgt
          (MSIM: ModSim.ModSim.mod_sim m_src m_tgt)
    :
    forall tid (p: program),
      Adequacy.improves (interp_all m_src.(Mod.st_init) (prog2ths m_src p) tid)
                        (interp_all m_tgt.(Mod.st_init) (prog2ths m_tgt p) tid).
  Proof.
    apply modsim_implies_yord_mod in MSIM.
    apply yord_implies_stid_mod in MSIM.
    apply stid_implies_nosync_mod in MSIM.
    apply nosync_implies_stutter_mod in MSIM.
    inv MSIM. i.
    eapply Adequacy.adequacy. eapply wf_tgt_inhabited. eapply wf_tgt_open.
    instantiate (1:=wf_src).
    destruct (mod_funs_cases m_src).
    { ii. specialize (init mt). des. exists im_src, false, false.
      destruct (Th.find tid (prog2ths m_src p)) eqn:FIND.
      2:{ unfold interp_all. rewrite unfold_interp_sched_nondet_None.
          rewrite interp_state_vis. rewrite <- bind_trigger. pfold. econs 10. auto.
      }
      unfold interp_all. erewrite unfold_interp_sched_nondet_Some.
      2: eauto.
      rename init0 into funs.
      assert (UB: i = (Vis (inl1 (inl1 (inl1 Undefined))) (Empty_set_rect _))).
      { revert_until funs. clear. i. unfold prog2ths, numbering in FIND.
        remember 0 as k. clear Heqk. move p after tid. revert_until p. induction p; i; ss.
        destruct a as [fn args]. unfold NatMapP.uncurry in FIND. ss.
        destruct (tid_dec tid k); clarify.
        { rewrite nm_find_add_eq in FIND. clarify. unfold fn2th. rewrite H. auto. }
        rewrite nm_find_add_neq in FIND; auto. eapply IHp; eauto.
      }
      clarify. rewrite interp_thread_vis_eventE. ired. rewrite interp_state_vis.
      rewrite <- bind_trigger. pfold. econs 10.
    }

    des. rename fn into fn0, ktr into ktr0, H into SOME0.
    eapply ModSimStutter_local_sim_implies_gsim.
    instantiate (1:= fun o0 => @epsilon _ wf_tgt_inhabited (fun o1 => wf_tgt.(lt) o0 o1)).
    { i. hexploit (@epsilon_spec _ wf_tgt_inhabited (fun o1 => wf_tgt.(lt) t o1)); eauto. }
    instantiate (1:=wf_stt).
    i. specialize (init im_tgt). des. esplits; eauto.
    unfold ModSimStutter_local_sim_threads, prog2ths. unfold numbering.
    remember 0 as k. clear Heqk. move p before k. revert_until p.
    induction p; i.
    { ss. unfold NatMap.Raw.empty. econs. }
    rewrite !map_cons, !_numbering_cons. destruct a as [fn args].
    rewrite !of_list_cons. eapply nm_find_some_implies_forall2.
    { apply nm_wf_pair_add. clear. move p after m_src. revert_until p. induction p; i.
      { ss. apply nm_wf_pair_empty_empty_eq. }
      ss. destruct a as [fn args]. unfold NatMapP.uncurry. ss. eapply nm_wf_pair_add.
      eauto.
    }
    i. destruct (tid_dec k k0); clarify.
    { clear IHp. rewrite nm_find_add_eq in FIND1, FIND2. clarify. unfold fn2th.
      rename init0 into funs.
      dup funs. specialize (funs0 fn0 ([]: list Val)↑). rewrite SOME0 in funs0.
      specialize (funs fn args). des_ifs; ss.
      unfold local_sim in funs0. ii.
      specialize (funs0 _ _ _ _ _ _ _ INV _ _ THS VALID _ UPD). des.
      esplits; eauto. i. specialize (funs0 _ _ _ _ _ _ _ INV1 VALID1 _ TGT). des.
      esplits. eapply SRC. i. instantiate (1:=o).
      pfold. eapply pind6_fold. rewrite <- bind_trigger. eapply lsim_UB.
    }
    rewrite nm_find_add_neq in FIND1, FIND2; auto.
    specialize (IHp (S k)). eapply nm_forall2_implies_find_some in IHp; eauto.
  Qed.

End ADEQ.

Section USERADEQ.

  Theorem usersim_adequacy
          m_src m_tgt
          p_src p_tgt
          (MSIM: ModSim.UserSim.sim m_src m_tgt p_src p_tgt)
    :
    forall tid,
      Adequacy.improves (interp_all m_src.(Mod.st_init) p_src tid)
                        (interp_all m_tgt.(Mod.st_init) p_tgt tid).
  Proof.
    apply modsim_implies_yord_user in MSIM.
    apply yord_implies_stid_user in MSIM.
    apply stid_implies_nosync_user in MSIM.
    apply nosync_implies_stutter_user in MSIM.
    inv MSIM. i.
    eapply Adequacy.adequacy. eapply wf_tgt_inhabited. eapply wf_tgt_open.
    instantiate (1:=wf_src).
    set (St := fun o0 => @epsilon _ wf_tgt_inhabited (fun o1 => wf_tgt.(lt) o0 o1)).
    assert (lt_succ_diag_r_tgt: forall (t: wf_tgt.(T)), wf_tgt.(lt) t (St t)).
    { i. unfold St. hexploit (@epsilon_spec _ wf_tgt_inhabited (fun o1 => wf_tgt.(lt) t o1)); eauto. }
    eapply forall4_implies_gsim. eauto.
    instantiate (1:=wf_stt). i. specialize (funs im_tgt). des. exists I. esplits; eauto.
  Qed.

End USERADEQ.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
Require Export Sets.
Require Export Axioms.
Require Export Omega.

Definition ord : forall E E' : Ens, INC E' E -> Prop.
simple induction E.
intros A f HR.
intros E' i.
apply and.
exact (forall a : A, IN (f a) E' -> HR a (f a) (INC_refl (f a))).

exact
 (forall (a : A) (e : Ens),
  IN (f a) E' -> forall p : INC e (f a), HR a e p -> IN e E').

Defined.

Lemma ord_ext :
 forall (E E' E'' : Ens) (p' : INC E' E) (p'' : INC E'' E),
 EQ E' E'' -> ord E E' p' -> ord E E'' p''.
simple induction E.
intros A f HR.
simpl in |- *.
intros E' E'' I' I'' e.
simple induction 1.
intros o1 o2.
clear H.
split.
auto with zfc.
intros; apply o1.
apply IN_sound_right with E''; auto with zfc.

intros.
apply IN_sound_right with E'; auto with zfc.
apply (o2 a) with (p := p).
apply IN_sound_right with E''; auto with zfc.

auto with zfc.
Qed.

Lemma ord_sound :
 forall E E' : Ens,
 EQ E E' ->
 forall (E'' : Ens) (p : INC E'' E) (p' : INC E'' E'),
 (ord E E'' p -> ord E' E'' p') /\ (ord E' E'' p' -> ord E E'' p).
simple induction E; intros A f HR; simple induction E'; intros A' f' HR'.
intros e E'' p p'.
elim e; intros e1 e2.
split.
intros o.
elim o; intros o1 o2.
simpl in |- *.
split.
intros a' i.
elim (e2 a'); intros a eq.
cut (INC (f' a') (f a)).
intros inc.
elim (HR a (f' a') eq (f' a') inc (INC_refl (f' a'))).
intros h1 h2.
auto with zfc.
apply h1.
apply ord_ext with (f a) (INC_refl (f a)).
auto with zfc.

auto with zfc.
apply o1.
apply IN_sound_left with (f' a'); auto with zfc.

auto with zfc.

intros a' E0 i inc.
intros or.
elim (e2 a'); intros a eq.
cut (INC E0 (f a)).
intros inc0.
apply (o2 a E0) with inc0.
apply IN_sound_left with (f' a'); auto with zfc.

elim (HR a (f' a')) with (E'' := E0) (p := inc0) (p' := inc).
intros h1 h2.
auto with zfc.

auto with zfc.

apply INC_sound_right with (f' a'); auto with zfc.

intros o; elim o; intros o1 o2.
split.
intros a i.
elim (e1 a); intros a' eq.
cut (INC (f a) (f' a')); auto with zfc.
cut (INC (f' a') (f a)); auto with zfc.
intros inc1 inc2.
elim (HR a (f' a')) with (E'' := f a) (p := INC_refl (f a)) (p' := inc2).
intros h1 h2.
apply h2.
apply ord_ext with (E' := f' a') (p' := INC_refl (f' a')).
auto with zfc.

auto with zfc.
apply o1.
apply IN_sound_left with (f a); auto with zfc.

auto with zfc.
intros a E0 i inc ord0.
elim (e1 a); intros a' eq.
cut (INC E0 (f' a')).
intros inc0.
apply (o2 a') with (p := inc0).
apply IN_sound_left with (f a); auto with zfc.

elim (HR a (f' a') eq E0 inc inc0).
intros h1 h2.
auto with zfc.

apply INC_sound_right with (f a); auto with zfc.
Qed.

Definition Ord (E : Ens) := ord E E (INC_refl E).

Lemma Ord_sound : forall E E' : Ens, EQ E E' -> Ord E -> Ord E'.
unfold Ord in |- *.
intros.
cut (INC E' E).
intros inc; elim (ord_sound E E' H E' inc (INC_refl E')).
intros h1 h2.
unfold Ord in |- *.

apply h1.
apply ord_ext with E (INC_refl E); auto with zfc.
auto with zfc.
Qed.

Lemma IN_Ord_Ord : forall E E' : Ens, Ord E -> IN E' E -> Ord E'.

simple induction E; intros A f HR E'.
simple induction 1; intros o1 o2.
change (forall a : A, IN (f a) (sup A f) -> Ord (f a)) in o1.
intros i.
elim i; intros a eq.
apply Ord_sound with (f a); auto with zfc.
apply o1.
auto with zfc.
exists a; auto with zfc.
Qed.

Lemma ord_tech :
 forall (E1 E2 E : Ens) (p1 : INC E E1) (p2 : INC E E2),
 ord E1 E p1 -> ord E2 E p2.
simple induction E1; intros A1 f1 HR1; simple induction E2;
 intros A2 f2 HR2 E p1 p2.
simple induction 1; intros o1 o2.
split.
intros a2 i2.
elim (IN_EXType _ _ i2).
intros x e.
change (Ord (f2 a2)) in |- *.
apply Ord_sound with (pi2 E x).
auto with zfc.

cut (IN (pi2 E x) (sup A1 f1)).
simple induction 1; intros a1 e1.
apply Ord_sound with (f1 a1); auto with zfc.
unfold Ord in |- *; apply o1.
apply IN_sound_left with (pi2 E x); auto with zfc.
apply IN_sound_left with (f2 a2); auto with zfc.

unfold INC in p1; apply p1; auto with zfc.
apply IN_sound_left with (f2 a2); auto with zfc.

intros a2 e i inc o.
elim (IN_EXType _ _ i).
intros x e2.
cut (IN (pi2 E x) (sup A1 f1)).
simple induction 1; intros a1 e1.
cut (INC e (f1 a1)).
intros inc1.
apply (o2 a1) with (p := inc1).
apply IN_sound_left with (pi2 E x).
auto with zfc.

apply IN_sound_left with (f2 a2); auto with zfc.

elim (ord_sound (f1 a1) (f2 a2)) with (p := inc1) (p' := inc).
intros h1 h2.
auto with zfc.

apply EQ_tran with (pi2 E x).
auto with zfc.

auto with zfc.

auto with zfc.
apply INC_sound_right with (pi2 E x).
auto with zfc.

apply INC_sound_right with (f2 a2); auto with zfc.

apply IN_sound_left with (f2 a2); auto with zfc.

Qed.

Lemma plump :
 forall E : Ens,
 Ord E ->
 forall E1 E2 : Ens, Ord E1 -> Ord E2 -> IN E1 E -> INC E2 E1 -> IN E2 E.
simple induction E; intros A f HR.
simple induction 1; intros o1 o2.
intros E1 E2 o11 o22 i inc.
elim (IN_EXType _ _ i).
intros a eq; simpl in a; simpl in eq.
cut (INC E2 (f a)).
intros inc0; apply (o2 a) with (p := inc0).
exists a; auto with zfc.

apply ord_tech with (E1 := E2) (p1 := INC_refl E2) (p2 := inc0).
assumption.

apply INC_sound_right with E1; auto with zfc.

Qed.

Lemma Ord_intro :
 forall E : Ens,
 (forall E' : Ens, IN E' E -> Ord E') ->
 (forall E1 E2 : Ens, Ord E1 -> Ord E2 -> IN E1 E -> INC E2 E1 -> IN E2 E) ->
 Ord E.
simple induction E; intros A f HR h1 h2; split.
intros a i.
change (Ord (f a)) in |- *; apply h1; exists a; auto with zfc.

intros a E1 i inc o.
apply h2 with (E1 := f a).
auto with zfc.

auto with zfc.
unfold Ord in |- *.
apply (ord_tech (f a)) with (p1 := inc) (p2 := INC_refl E1);
 auto with zfc.

exists a; auto with zfc.

auto with zfc.
Qed.

Lemma Ord_trans :
 forall E : Ens, Ord E -> forall E' : Ens, IN E' E -> INC E' E.
simple induction E; intros A f HR o E' i.
unfold INC in |- *.
intros E'' i'.
apply plump with E'.

auto with zfc.

apply IN_Ord_Ord with (sup A f); auto with zfc.

apply IN_Ord_Ord with E'; auto with zfc; apply IN_Ord_Ord with (sup A f);
 auto with zfc.

auto with zfc.

elim i; intros a e.
apply INC_sound_right with (f a); auto with zfc.
apply HR; auto with zfc.
apply IN_Ord_Ord with (sup A f); auto with zfc; exists a;
 auto with zfc.

apply IN_sound_right with E'; auto with zfc.

Qed.

Lemma inter_ord : forall E : Ens, Ord E -> Ord (Inter E).
simple induction E; intros A f HR o; apply Ord_intro.
intros E'.
simple induction 1.
simple induction x; intro a.
simple induction p.
intros b.
intros h e.
apply Ord_sound with (pi2 (f a) b); auto with zfc.
apply IN_Ord_Ord with (f a); auto with zfc.
apply IN_Ord_Ord with (sup A f).
assumption.

exists a; auto with zfc.

intros.
elim H1; simple induction x.
intro a; simple induction p.
intros b h e.
apply all_IN_Inter with (f a).
exists a; auto with zfc.

intros.
apply plump with E1.
auto with zfc.
apply IN_Ord_Ord with (sup A f); auto with zfc.

auto with zfc.

auto with zfc.

apply IN_Inter_all with (sup A f); auto with zfc.

auto with zfc.
Qed.

Lemma union_Ord : forall E : Ens, Ord E -> Ord (Union E).
simple induction E; intros A f HR o.
apply Ord_intro.
intros E'; simple induction 1.
simple induction x.
intros a b.
simpl in |- *.
intros e.
apply IN_Ord_Ord with (f a); auto with zfc.
apply IN_Ord_Ord with (sup A f); try exists a; auto with zfc.

apply IN_sound_left with (pi2 (f a) b); auto with zfc.
generalize b; elim (f a).
simpl in |- *.
intros.
exists b0; auto with zfc.

intros E1 E2 o1 o2; simple induction 1.
simple induction x.
intros a b e inc.
simpl in e.
apply IN_Union with (f a).
exists a; try trivial with zfc.

apply plump with E1; auto with zfc.
apply IN_Ord_Ord with (sup A f); try exists a; auto with zfc.

apply IN_sound_left with (pi2 (f a) b); auto with zfc.
generalize b; elim (f a); simpl in |- *; intros.
exists b0; auto with zfc.

Qed.

Lemma Inter_Ord :
 forall E : Ens, (forall E' : Ens, IN E' E -> Ord E') -> Ord (Inter E).
simple induction E; intros A f HR H.
apply Ord_intro.
intros E' i.
elim i.
simple induction x.
intro a; simple induction p.
intros b h.
intros e.
apply IN_Ord_Ord with (f a).
apply H; exists a; auto with zfc.

apply IN_sound_left with (pi2 (f a) b); auto with zfc.

intros E1 E2 o1 o2 i inc.
elim i.
simple induction x.
intro a; simple induction p.
intros b h e.
apply all_IN_Inter with (f a).
exists a; auto with zfc.

intros.
apply plump with E1; auto with zfc.
apply IN_Inter_all with (sup A f); auto with zfc.
Qed.

Lemma Union_Ord :
 forall E : Ens, (forall E' : Ens, IN E' E -> Ord E') -> Ord (Union E).
simple induction E; intros A f HR h.
apply Ord_intro.
intros E' i.
elim i.
simple induction x; intros a.
intros b e.
simpl in e.
apply Ord_sound with (pi2 (f a) b).
auto with zfc.
apply IN_Ord_Ord with (f a); auto with zfc.
apply h; exists a; auto with zfc.
generalize b; elim (f a); simpl in |- *.
intros.
exists b0; auto with zfc.
intros.
elim (Union_IN (sup A f) E1); auto with zfc.
intros E3.
simple induction 1.
intros i1 i2.
apply IN_Union with E3.
auto with zfc.
apply plump with E1; auto with zfc.
Qed.

Definition Succ (E : Ens) := Comp (Power E) Ord.

Lemma Ord_Succ : forall E : Ens, Ord E -> Ord (Succ E).
unfold Succ in |- *; intros E o.
apply Ord_intro.
intros.
apply IN_Comp_P with (Power E).
intros w1 w2 o1 e; apply Ord_sound with w1; auto with zfc.

auto with zfc.

intros E1 E2 o1 o2 i inc.
apply IN_P_Comp; auto with zfc.
intros w1 w2 ow1 e; apply Ord_sound with w1; auto with zfc.

apply INC_IN_Power.
apply INC_tran with E1; auto with zfc.
cut (IN E1 (Power E)).
intros i1.
apply IN_Power_INC; try trivial with zfc.

cut (INC (Comp (Power E) Ord) (Power E)).
intros inc1.
apply inc1; try trivial with zfc.

apply Comp_INC; try trivial with zfc.

Qed.

Lemma Succ_incr : forall E : Ens, Ord E -> IN E (Succ E).

unfold Succ in |- *; intros.
apply IN_P_Comp.
intros w1 w2 o1 e; apply Ord_sound with w1; auto with zfc.
auto with zfc.
apply INC_IN_Power; auto with zfc.
try trivial with zfc.
Qed.

Definition PI1 : forall (A : Type) (P : A -> Type), depprod A P -> A.
simple induction 1; intros a p.
exact a.
Defined.

Definition PI2 :
  forall (A : Type) (P : A -> Type) (c : depprod A P), P (PI1 A P c).
simple induction c.
intros a p.
exact p.
Defined.


(*
   Quark is Copyright (C) 2012-2015, Quark Team.

   You can redistribute and modify it under the terms of the GNU GPL,
   version 2 or later, but it is made available WITHOUT ANY WARRANTY.

   For more information about Quark, see our web site at:
   http://goto.ucsd.edu/quark/
*)

Require Import Ynot.
Require Import Basis.
Require Import List.
Require Import Ascii.
Require Import String.
Require Import List.
Require Import RSep.
Require Import NArith.
Require Import Arith.
Require Import VCRIO.
Require Import Message.
Require Import Sumbool.

Open Local Scope stsepi_scope.
Open Local Scope hprop_scope.

Ltac inv H :=
  inversion H; subst; clear H.

Ltac Unify :=
  match goal with
  | H1: ?x = ?a,
    H2: ?x = ?b |- _ =>
      rewrite H1 in H2; symmetry in H2;
      inversion H2; subst; clear H2;
      try Unify
  end.

Fixpoint beq_la (la:list ascii) (la2:list ascii) : bool :=
  match la with
  | a :: la =>
    match la2 with
      | a2 :: la2 => if ascii_dec a a2 then beq_la la la2 else false
      | nil => false
    end
  | nil =>
    match la2 with
      | nil => true
      | _ => false
    end
  end.

Lemma la_eq_cons :
  forall (a:ascii) a' la la',
    a = a' -> la = la' -> a::la = a'::la'.
Proof.
  intros.
  rewrite H. rewrite H0. reflexivity.
Qed.

Lemma la_eq_refl :
  forall la,
    (la_eq la la).
Proof.
  induction la.
  apply nil_la.
  apply not_nil_la.
  auto.
Qed.

Lemma la_eq_same :
  forall la la' another,
    (la_eq la another) -> (la_eq la' another) -> (la = la').
Proof.
  induction la.

  intros.
  inversion H. rewrite<- H2 in H0.
  inversion H0. auto.

  intros.
  destruct la'.
  inversion H0. rewrite<- H2 in H.
  inversion H.

  inversion H.
  inversion H0.
  apply la_eq_cons.

  rewrite<- H6 in H.
  inversion H. auto.

  eapply IHla.
  apply H4.

  rewrite<- H2 in H0.
  inversion H0.
  auto.
Qed.

Fixpoint la_ends_with_bool (la:list ascii) (sym:list ascii) : bool :=
  if (laeq la sym) then
    true
  else
    match la with
      | a :: la' => la_ends_with_bool la' sym
      | nil => false
    end.

Lemma la_ends_equal :
  forall la sym,
    la_ends_with_bool la sym = true -> la_endswith la sym.
Proof.
  induction la.
  intros.
  simpl in H.
  destruct (laeq nil sym).
  rewrite<- e.
  apply la_endswith_same. apply nil_la.

  discriminate.

  intros.
  destruct (laeq (a :: la) sym).
  rewrite <- e.
  apply la_endswith_same.
  apply not_nil_la.
  apply la_eq_refl.

  apply la_endswith_strict.
  apply IHla.

  simpl in H.
  destruct (laeq (a::la) sym).
  destruct n. apply e.

  auto.
Qed.

Lemma la_ends_equal_inv :
  forall la sym,
    la_endswith la sym -> la_ends_with_bool la sym = true.
Proof.
  induction la.

  intros.
  inversion H.
  inversion H0. simpl.
  destruct (laeq nil nil).
  auto.

  destruct n; auto.

  intros.
  simpl.
  destruct (laeq (a :: la) sym).
  auto.

  apply IHla.

  inversion H.
  destruct n.
  eapply la_eq_same.
  apply H0.
  apply la_eq_refl.

  auto.
Qed.

Lemma app_assoc {A}:
  forall (l0 l1 l2:list A),
    (l0 ++ l1) ++ l2 = l0 ++ (l1 ++ l2).
Proof.
  intros. induction l0. auto.

  simpl. rewrite IHl0. reflexivity.
Qed.

Theorem app_nil_r (A:Type) : forall l:list A, l ++ nil = l.
Proof.
  induction l; simpl; f_equal; auto.
Qed.


From Perennial.algebra Require Import append_list.
From Perennial.Helpers Require Import Integers List Map.
From Perennial.program_proof.wal Require Import abstraction.

From Perennial.program_proof Require Import disk_prelude.

(*
txns: list (u64 * list update.t)
txn_id is referenced by pos, log < pos contains updates through and including upds
[txn_id: (pos, upds)]
*)

Class txns_ctxG Σ := { txns_ctx_alist :> alistG Σ (u64 * list update.t) }.
Definition txns_ctxΣ : gFunctors := #[alistΣ (u64 * list update.t)].

#[global]
Instance subG_txns_ctx Σ : subG txns_ctxΣ Σ → txns_ctxG Σ.
Proof. solve_inG. Qed.

Section goose.
Context `{!heapGS Σ} `{!txns_ctxG Σ}.
Implicit Types (γ:gname).

Definition txn_val γ txn_id (txn: u64 * list update.t): iProp Σ :=
  list_el γ txn_id txn.

Definition txn_pos γ txn_id (pos: u64) : iProp Σ :=
  ∃ upds, txn_val γ txn_id (pos, upds).

Definition txns_ctx γ txns : iProp Σ := list_ctx γ 1 txns.

Theorem alloc_txns_ctx E txns :
  ⊢ |={E}=> ∃ γtxns, txns_ctx γtxns txns.
Proof.
  iMod (alist_alloc txns) as (γtxns) "Hctx".
  iExists γtxns.
  rewrite /txns_ctx //=.
Qed.

Theorem txn_val_to_pos γ txn_id pos upds :
  txn_val γ txn_id (pos, upds) -∗ txn_pos γ txn_id pos.
Proof.
  rewrite /txn_pos.
  iIntros "Hval".
  iExists _; iFrame.
Qed.

Lemma txns_ctx_app {γ} txns' txns : txns_ctx γ txns ==∗ txns_ctx γ (txns ++ txns').
Proof.
  rewrite /txns_ctx.
  iIntros "Hctx".
  by iMod (alist_app _ txns' with "Hctx") as "[$ _]".
Qed.

Global Instance txn_pos_timeless γ txn_id pos :
  Timeless (txn_pos γ txn_id pos) := _.

Global Instance txn_pos_persistent γ txn_id pos :
  Persistent (txn_pos γ txn_id pos) := _.

Definition txns_are γ (start: nat) (txns_sub: list (u64*list update.t)) : iProp Σ :=
  list_subseq γ start txns_sub.

Global Instance txns_are_Persistent γ start txns_sub : Persistent (txns_are γ start txns_sub).
Proof. apply _. Qed.

Theorem txns_are_sound γ txns start txns_sub :
  txns_ctx γ txns -∗
  txns_are γ start txns_sub -∗
  ⌜subslice start (start + length txns_sub)%nat txns = txns_sub⌝.
Proof.
  iIntros "Hctx Htxns_are".
  iDestruct (alist_subseq_lookup with "Hctx Htxns_are") as "$".
Qed.

Lemma txns_are_unify γ txns start txns_sub1 txns_sub2 :
  txns_ctx γ txns -∗
  txns_are γ start txns_sub1 -∗
  txns_are γ start txns_sub2 -∗
  ⌜length txns_sub1 = length txns_sub2⌝ -∗
  ⌜txns_sub1 = txns_sub2⌝.
Proof.
  iIntros "Htxns_ctx Htxns_sub1 Htxns_sub2 %Hlen".
  iDestruct (txns_are_sound with "Htxns_ctx Htxns_sub1") as %<-.
  iDestruct (txns_are_sound with "Htxns_ctx Htxns_sub2") as %<-.
  rewrite <-Hlen.
  eauto.
Qed.

Lemma txns_are_nil γ start : ⊢ txns_are γ start [].
Proof.
  iApply list_subseq_nil.
Qed.

(** * some facts about txn_ctx *)
Theorem alloc_txn_pos pos upds γ txns :
  txns_ctx γ txns ==∗
  txns_ctx γ (txns ++ [(pos, upds)]) ∗ txn_val γ (length txns) (pos, upds).
Proof.
  iIntros "Hctx".
  iMod (alist_app1 (pos,upds) with "Hctx") as "[Hctx Hval]".
  by iFrame.
Qed.

Theorem txns_ctx_complete γ txns txn_id txn :
  txns !! txn_id = Some txn ->
  txns_ctx γ txns -∗ txn_val γ txn_id txn.
Proof.
  iIntros (Hlookup) "Hctx".
  iDestruct (alist_lookup_el with "Hctx") as "Hel"; eauto.
Qed.

Theorem txns_ctx_complete' γ txns txn_id txn :
  txns !! txn_id = Some txn ->
  ▷ txns_ctx γ txns -∗ ▷ txn_val γ txn_id txn ∗ ▷ txns_ctx γ txns.
Proof.
  iIntros (Hlookup) "Hctx".
  iDestruct (txns_ctx_complete with "Hctx") as "#Hel"; eauto.
Qed.

Theorem txns_ctx_txn_pos γ txns txn_id pos :
  is_txn txns txn_id pos ->
  txns_ctx γ txns -∗ txn_pos γ txn_id pos.
Proof.
  intros [txn [Hlookup ->]]%fmap_Some_1.
  rewrite txns_ctx_complete; eauto.
  iIntros "Htxn_val".
  destruct txn as [pos upds].
  iExists _; iFrame.
Qed.

Theorem txn_val_valid_general γ txns txn_id txn :
  txns_ctx γ txns -∗
  txn_val γ txn_id txn -∗
  ⌜txns !! txn_id = Some txn⌝.
Proof.
  iIntros "Hctx Htxn".
  iDestruct (alist_lookup with "Hctx Htxn") as %Hlookup.
  eauto.
Qed.

Theorem txn_pos_valid_general γ txns txn_id pos :
  txns_ctx γ txns -∗
  txn_pos γ txn_id pos -∗
  ⌜is_txn txns txn_id pos⌝.
Proof.
  iIntros "Hctx Htxn".
  iDestruct "Htxn" as (upds) "Hval".
  iDestruct (alist_lookup with "Hctx Hval") as %Hlookup.
  iPureIntro.
  rewrite /is_txn Hlookup //.
Qed.

Global Instance txns_ctx_disc γ x: Discretizable (txns_ctx γ x).
Proof.
  rewrite /txns_ctx/list_ctx. apply _.
Qed.

(** * txns_ctx factory:

a way to remember that some [txn_val]s are valid even after a crash *)

(* the crux of this approach is this resource, which has an auth over the old
transactions in [γ] and connects them to the transactions in [γ']. [txn_val]s in
[γ] that are prior to the crash point can be used to get one in the new
generation. *)
Definition old_txn_factory γ crash_txn γ' : iProp Σ :=
  ∃ txns, txns_ctx γ txns ∗
  [∗ list] i↦txn ∈ (take (S crash_txn) txns), list_el γ' i txn.

Lemma txns_ctx_make_factory γ txns crash_txn γ' :
  txns_ctx γ txns -∗
  txns_ctx γ' (take (S crash_txn) txns) -∗
  old_txn_factory γ crash_txn γ' ∗ txns_ctx γ' (take (S crash_txn) txns).
Proof.
  rewrite {2 3}/txns_ctx /list_ctx /old_txn_factory.
  iIntros "Htxn [Hctx #Hels]".
  iFrame "#∗".
  iExists _; iFrame "#∗".
Qed.

Lemma old_txn_get γ γ' crash_txn txn_id txn :
  (txn_id ≤ crash_txn)%nat →
  old_txn_factory γ crash_txn γ' -∗
  txn_val γ txn_id txn -∗
  txn_val γ' txn_id txn.
Proof.
  iIntros (?) "Hfactory Hel".
  iDestruct "Hfactory" as (txns) "[Hctx Hels]".
  iDestruct (alist_lookup with "Hctx Hel") as %Hloookup.
  iDestruct (big_sepL_lookup with "Hels") as "$".
  rewrite -> lookup_take by lia. done.
Qed.

Lemma old_txn_get_pos γ γ' crash_txn txn_id pos :
  (txn_id ≤ crash_txn)%nat →
  old_txn_factory γ crash_txn γ' -∗
  txn_pos γ txn_id pos -∗
  txn_pos γ' txn_id pos.
Proof.
  iIntros (?) "Hfactory Hel".
  iDestruct "Hel" as (txn) "Hel".
  iExists txn.
  iApply (old_txn_get with "[$] [$]"); auto.
Qed.

Lemma old_txns_are_get γ γ' crash_txn start txns_sub :
  (start + length txns_sub ≤ S crash_txn)%nat →
  old_txn_factory γ crash_txn γ' -∗
  txns_are γ start txns_sub -∗
  txns_are γ' start txns_sub.
Proof.
  iIntros (Hbound) "Hfactory Htxns".
  iInduction txns_sub as [|txn txns] "IH" forall (start Hbound).
  - iApply txns_are_nil.
  - rewrite /txns_are /list_subseq.
    simpl in Hbound.
    rewrite !big_sepL_cons.
    iDestruct "Htxns" as "[Htxn Htxns]".
    rewrite Nat.add_0_r.
    iDestruct (old_txn_get with "Hfactory Htxn") as "#$"; first by lia.
    setoid_rewrite <- Nat.add_succ_comm.
    iApply ("IH" with "[%] [$] Htxns").
    lia.
Qed.
End goose.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Export syntax_ott.
Require Import
        Infrastructure
        SubtypingInversion
        Disjointness.

Create HintDb common.
#[export] Hint Extern 1 (exists _, _) => exists : common.
#[export] Hint Extern 1 => match goal with
                   [ h : exists _ , _ |- _ ] => destruct h
                 end : common.

#[export] Hint Extern 0 => match goal with
                   | [ H: value (e_app _ _) |- _ ] => inverts H
                   | [ H: value (e_fixpoint _ _ ) |- _ ] => inverts H
                   | [ H: prevalue (e_app _ _) |- _ ] => inverts H
                   | [ H: prevalue (e_fixpoint _ _) |- _ ] => inverts H
                 end : falseHd.

Lemma principal_type_checks: forall e A B,
    pType e A -> Typing nil e Inf B -> A = B.
Proof.
  intros e A B H H0. gen B.
  induction H; intros; try solve [inverts* H0].
  - inverts* H0. forwards*: IHpType H3. subst*.
  - inverts H1;
      forwards*: IHpType1;
      forwards*: IHpType2;
      subst*.
Qed.

Lemma prevalue_exists_ptype : forall u,
    prevalue u -> exists A, pType u A.
Proof with eauto with common.
  intros u H.
  induction H... induction H...
Qed.

Lemma typ_value_ptype: forall v A,
    Typing nil v Inf A -> value v -> pType v A.
Proof.
  introv Ht Hv. gen A.
  induction Hv; intros; inverts~ Ht.
Qed.

#[export] Hint Immediate typ_value_ptype : core.

Lemma typ_prevalue_ptype: forall u A,
    Typing nil u Inf A -> prevalue u -> pType u A.
Proof.
  introv Ht Hp. gen A.
  induction Hp; intros; inverts~ Ht; inverts~ H.
Qed.

#[export] Hint Immediate typ_prevalue_ptype : core.

Ltac unify_pType e :=
  match goal with
  | [H1: pType e _, H2: Typing _ e Inf _ |- _] =>
    (forwards: principal_type_checks H1 H2; subst)
  | [H1: prevalue e, H2: Typing _ e Inf _ |- _] =>
    (forwards: typ_prevalue_ptype H2 H1)
  | [H1: value e, H2: Typing _ e Inf _ |- _] =>
    (forwards: typ_value_ptype H2 H1)
  | [H1: prevalue e |- _] =>
    (forwards (?&?): prevalue_exists_ptype H1)
  end.

Lemma prevalue_merge_l_inv : forall u1 u2,
    prevalue (e_merge u1 u2) -> prevalue u1.
Proof.
  intros u1 u2 H.
  inductions H; auto.
  inverts~ H.
Qed.

Lemma prevalue_merge_r_inv : forall u1 u2,
    prevalue (e_merge u1 u2) -> prevalue u2.
Proof.
  intros u1 u2 H.
  inductions H; auto.
  inverts~ H.
Qed.

Lemma prevalue_rcd_inv : forall l u,
    prevalue (e_rcd l u) -> prevalue u.
Proof.
  intros l u  H.
  inductions H; auto.
  inverts~ H.
Qed.

#[export] Hint Immediate prevalue_merge_l_inv prevalue_merge_r_inv prevalue_rcd_inv: core.

(* TypedReduce *)
Lemma TypedReduce_prv_value: forall v A v',
    value v -> TypedReduce v A v' -> value v'.
Proof with eauto with termDb.
  intros v A v' Val Red.
  induction* Red; try solve [inverts* Val]...
Qed.

#[export] Hint Immediate TypedReduce_prv_value : core.

Lemma TypedReduce_top_normal : forall (v v': exp),
    TypedReduce v t_top v' -> v' = e_top.
Proof.
  intros v v' H.
  inductions H;
    solve [inverts* H].
Qed.

Lemma TypedReduce_toplike : forall A v1 v2 v1' v2',
    topLike A -> value v1 -> value v2 -> TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.
Proof with (solve_false; auto).
  assert (HH: forall v v' A, value v -> ord A -> topLike A -> TypedReduce v A v' -> v' = e_top). {
    intros.
    induction H2...
    - inverts~ H. inverts* H1...
    - inverts~ H.
    - inverts~ H.
  }
  intros A v1 v2 v1' v2' TL Val1 Val2 Red1 Red2.
  gen v1' v2'.
  proper_ind A; inverts TL; intros;
    try solve [ (* ordinary *)
          forwards*: HH Val1 Red1;
          forwards*: HH Val2 Red2;
          subst* ];
    try solve [ (* splittable *)
          inverts H;
          inverts Red1; solve_false; auto;
          inverts Red2; solve_false; auto;
          split_unify;
          forwards*: IHr1;
          forwards*: IHr2;
          congruence].
Qed.

Lemma TypedReduce_sub: forall v v' A B,
    value v -> TypedReduce v A v' -> pType v B -> algo_sub B A.
Proof with eauto with common.
  introv Val Red Typ. gen B.
  induction Red; intros.
  - inverts Typ...
  - inverts Typ...
  - inverts Typ...
  - inverts Val.
    inverts Typ.
    forwards*: IHRed...
  - inverts Val.
    inverts Typ...
  - inverts Val.
    inverts Typ...
  - forwards*: IHRed1...
Qed.

(* consistency *)
Definition consistencySpec v1 v2 :=
  forall A v1' v2', ord A -> TypedReduce v1 A v1' -> TypedReduce v2 A v2' -> v1' = v2'.

#[export] Hint Unfold consistencySpec : core.

Lemma consistent_symm: forall e1 e2,
    consistent e1 e2 -> consistent e2 e1.
Proof with eauto.
  intros e1 e2 H.
  induction H...
Qed.

#[export] Hint Resolve consistent_symm : core.

Lemma consistent_refl: forall v A,
    value v -> Typing nil v Inf A -> consistent v v.
Proof with eauto.
  intros v A H Typ.
  gen A.
  induction H; intros...
  - constructor; constructor;
      inverts Typ;
      forwards* (?&?): prevalue_exists_ptype v1;
      forwards* (?&?): prevalue_exists_ptype v2;
      forwards* : principal_type_checks v1;
      forwards* : principal_type_checks v2; subst...
  - inverts* Typ.
Qed.

#[export] Hint Resolve consistent_refl : core.


(*! Stdlib | Standard library !*)
Require Import Koika.Frontend.

Section Maybe.
  Context (tau: type).

  Definition Maybe :=
    {| struct_name := "maybe_" ++ type_id tau;
       struct_fields := [("valid", bits_t 1); ("data", tau)] |}.

  Definition valid {reg_t fn} : UInternalFunction reg_t fn :=
    {{ fun valid (x: tau) : struct_t Maybe =>
         struct Maybe { valid := Ob~1; data := x } }}.

  Definition invalid {reg_t fn} : UInternalFunction reg_t fn :=
    {{ fun invalid () : struct_t Maybe =>
         struct Maybe { valid := Ob~0 } }}.
End Maybe.

Notation maybe tau := (struct_t (Maybe tau)).

Module Type Fifo.
  Parameter T:type.
End Fifo.

Module Fifo1 (f: Fifo).
  Import f.
  Inductive reg_t := data0 | valid0.

  Definition R r :=
    match r with
    | data0 => T
    | valid0 => bits_t 1
    end.

  Definition r idx : R idx :=
    match idx with
    | data0 => value_of_bits Bits.zero
    | valid0 => Bits.zero
    end.

  Definition name_reg r :=
    match r with
    | data0 => "data0"
    | valid0 => "valid0"
    end.

  Definition can_enq : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun can_enq () : bits_t 1 => !read1(valid0) }}.

  Definition enq : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun enq (data : T) : bits_t 0 =>
        guard (can_enq ());
        write1(data0, data);
        write1(valid0, #Ob~1) }}.

  Definition can_deq : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun can_deq () : bits_t 1 => read0(valid0) }}.

  Definition peek : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun peek () : maybe T =>
         if can_deq () then {valid T}(read0(data0))
         else {invalid T}() }}.

  Definition deq : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun deq () : T =>
        guard (can_deq ());
        write0(valid0, Ob~0);
        read0(data0) }}.

  Instance FiniteType_reg_t : FiniteType reg_t := _.
End Fifo1.

Module Fifo1Bypass (f: Fifo).
  Import f.
  Inductive reg_t := data0 |  valid0.

  Definition R r :=
    match r with
    | data0 => T
    | valid0 => bits_t 1
    end.

  Definition r idx : R idx :=
    match idx with
    | data0 => value_of_bits Bits.zero
    | valid0 => Bits.zero
    end.

  Definition name_reg r :=
    match r with
    | data0 => "data0"
    | valid0 => "valid0"
    end.

  Definition can_enq : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun can_enq () : bits_t 1 => !read0(valid0) }}.

  Definition enq : UInternalFunction reg_t empty_ext_fn_t :=
   {{ fun enq (data : T) : bits_t 0 =>
       guard (can_enq ());
       write0(data0, data);
       write0(valid0, #Ob~1) }}.

  Definition can_deq : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun can_deq () : bits_t 1 => read1(valid0) }}.

  Definition peek : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun peek () : maybe T =>
         if can_deq () then {valid T}(read1(data0))
         else {invalid T}() }}.

  Definition deq :  UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun deq () : T =>
       guard (can_deq ());
       write1(valid0, Ob~0);
       read1(data0) }}.

  Instance FiniteType_reg_t : FiniteType reg_t := _.
End Fifo1Bypass.

Module Type RfPow2_sig.
  Parameter idx_sz: nat.
  Parameter T: type.
  Parameter init: T.
  Parameter read_style : @switch_style var_t.
  Parameter write_style : @switch_style var_t.
End RfPow2_sig.

Module RfPow2 (s: RfPow2_sig).
  Definition sz := pow2 s.idx_sz.
  Inductive reg_t := rData (n: Vect.index sz).

  Definition R r :=
    match r with
    | rData _ => s.T
    end.

  Definition r idx : R idx :=
    match idx with
    | rData _ => s.init
    end.

  Definition name_reg r :=
    match r with
    | rData n => String.append "rData_" (show n)
    end.

  Definition read_0 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun read_0 (idx : bits_t s.idx_sz) : s.T =>
         `UCompleteSwitch s.read_style s.idx_sz "idx"
              (fun idx => {{ read0(rData idx) }})` }}.

  Definition write_0 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun write_0 (idx : bits_t s.idx_sz) (val: s.T) : unit_t =>
         `UCompleteSwitch s.write_style s.idx_sz "idx"
              (fun idx => {{ write0(rData idx, val) }})` }}.

  Definition read_1 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun read_1 (idx : bits_t s.idx_sz) : s.T =>
         `UCompleteSwitch s.read_style s.idx_sz "idx"
              (fun idx => {{ read1(rData idx) }})` }}.

  Definition write_1 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun write_1 (idx : bits_t s.idx_sz) (val: s.T) : unit_t =>
         `UCompleteSwitch s.write_style s.idx_sz "idx"
              (fun idx => {{ write1(rData idx, val) }})` }}.
End RfPow2.

Module Type Rf_sig.
  Parameter lastIdx: nat.
  Parameter T: type.
  Parameter init: T.
End Rf_sig.

Module Rf (s: Rf_sig).
  Definition lastIdx := s.lastIdx.
  Definition log_sz := log2 lastIdx.
  Definition sz := S lastIdx.
  Inductive reg_t := rData (n: Vect.index sz).

  Definition R r :=
    match r with
    | rData _ => s.T
    end.

  Definition r idx : R idx :=
    match idx with
    | rData _ => s.init
    end.

  Definition name_reg r :=
    match r with
    | rData n => String.append "rData_" (show n)
    end.

  Definition read : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun read (idx : bits_t log_sz) : s.T =>
         `USugar
             (USwitch
                {{idx}}
                {{fail(type_sz s.T)}}
                (List.map
                   (fun idx =>
                      (USugar (UConstBits
                                 (Bits.of_nat log_sz idx)),
                       {{ read0(rData (match (index_of_nat sz idx) with
                                       | Some idx => idx
                                       | _ => thisone
                                       end)) }}))
                   (List.seq 0 sz))) ` }}.

  Definition write : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun write (idx : bits_t log_sz) (val: s.T) : unit_t =>
         `USugar
          (USwitch
             {{idx}}
             {{fail}}
             (List.map
                (fun idx =>
                   (USugar (UConstBits
                              (Bits.of_nat log_sz idx)),
                    {{ write0(rData (match (index_of_nat sz idx) with
                                    | Some idx => idx
                                    | _ => thisone
                                    end), val) }}))
                   (List.seq 0 sz))) ` }}.
End Rf.

Definition signExtend {reg_t} (n:nat) (m:nat) : UInternalFunction reg_t empty_ext_fn_t :=
  {{ fun signExtend (arg : bits_t n) : bits_t (m+n) => sext(arg, m + n) }}.

Module RfEhr (s: Rf_sig).

  Definition lastIdx := s.lastIdx.
  Definition log_sz := log2 lastIdx.
  Definition sz := S lastIdx.
  Inductive reg_t := rData (n: Vect.index sz).

  Definition R r :=
    match r with
    | rData _ => s.T
    end.

  Definition r idx : R idx :=
    match idx with
    | rData _ => s.init
    end.

  Definition name_reg r :=
    match r with
    | rData n => String.append "rData_" (show n)
    end.

  Definition read_0 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun read_0 (idx : bits_t log_sz) : s.T =>
         `USugar
             (USwitch
                {{idx}}
                {{fail(type_sz s.T)}}
                (List.map
                   (fun idx =>
                      (USugar (UConstBits
                                 (Bits.of_nat log_sz idx)),
                       {{ read0(rData (match (index_of_nat sz idx) with
                                       | Some idx => idx
                                       | _ => thisone
                                       end)) }}))
                   (List.seq 0 sz))) ` }}.

  Definition read_1 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun read_1 (idx : bits_t log_sz) : s.T =>
         `USugar
             (USwitch
                {{idx}}
                {{fail(type_sz s.T)}}
                (List.map
                   (fun idx =>
                      (USugar (UConstBits
                                 (Bits.of_nat log_sz idx)),
                       {{ read1(rData (match (index_of_nat sz idx) with
                                       | Some idx => idx
                                       | _ => thisone
                                       end)) }}))
                   (List.seq 0 sz))) ` }}.

  Definition write_0 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun write_0 (idx : bits_t log_sz) (val: s.T) : unit_t =>
         `USugar
          (USwitch
             {{idx}}
             {{fail}}
             (List.map
                (fun idx =>
                   (USugar (UConstBits
                              (Bits.of_nat log_sz idx)),
                    {{ write0(rData (match (index_of_nat sz idx) with
                                    | Some idx => idx
                                    | _ => thisone
                                    end), val) }}))
                (List.seq 0 sz))) ` }}.

  Definition write_1 : UInternalFunction reg_t empty_ext_fn_t :=
    {{ fun write_1 (idx : bits_t log_sz) (val: s.T) : unit_t =>
         `USugar
          (USwitch
             {{idx}}
             {{fail}}
             (List.map
                (fun idx =>
                   (USugar (UConstBits
                              (Bits.of_nat log_sz idx)),
                    {{ write1(rData (match (index_of_nat sz idx) with
                                    | Some idx => idx
                                    | _ => thisone
                                    end), val) }}))
                   (List.seq 0 sz))) ` }}.
End RfEhr.