From ITree Require Import ITree.
From compcert Require Coqlib.
From Paco Require Import paco.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import RTSysEnv.
Require Import NWSysModel SyncSysModel AbstAsyncSysModel.
Require Import MWITree.

Require Import List.
Require Import Arith ZArith Lia.
Require Import Relation_Operators.

Generalizable Variable sysE.

Local Opaque Int.max_signed Int64.max_unsigned.

(* SpecNode: connects (inner) sync_node and async network *)
Module AbstMW.

  Section NODE.
    (* Variable msgT: Set. *)
    Context `{sysE: Type -> Type}.
    Context `{SystemEnv}.
    Let msgT: Set := bytes.
    Let t := @SNode.t sysE msgT.

    Inductive stage_t: Set :=
    | Ready
    | Running (sh: list bool)
    .

    Inductive istate_t {node: t} : Type :=
    | Off (* (outb: list (ip_t(*dip*) * bytes * nat)) *)
    | Prep
        (* (rcv_open: bool) *)
        (to_join: list Tid)
        (join_time_limit: nat)
        (inbp: list Packet.msg_t)
        (ast: node.(SNode.app_state))
    | On
        (sytm: nat)
        (inbp: list Packet.msg_t)
        (inbm: list msgT?)
        (* (outb: list (ip_t(*dip*) * bytes * nat)) *)
        (stage: stage_t)
        (ast: node.(SNode.app_state))
    .

    Record state: Type :=
      State {
          task_id: Tid ;
          ip_addr: ip_t ;
          snode: t ;
          istate: @istate_t snode ;
        }.

    Inductive istate_wf (snode: t)
      : @istate_t snode -> Prop :=
    | IStateWf_Off
      : istate_wf snode Off
    | IStateWf_Prep
        mids fsytm inbp ast
        (VALID_MCAST_IDS: Forall valid_mcast_id mids)
      : istate_wf snode (Prep mids fsytm inbp ast)
    | IStateWf_OnReady
        sytm inbp inbm ast
      : istate_wf snode (On sytm inbp inbm Ready ast)
    | IStateWf_On
        sytm inbp inbm sh ast
        (RUNNING_SYTM_UB: sytm < MAX_TIME)
        (SEND_HIST_LENGTH: length sh = num_tasks)
      : istate_wf snode (On sytm inbp inbm (Running sh) ast)
    .

    (* TODO: define wf for each case *)
    Inductive state_wf (tid: Tid): state -> Prop :=
      StateWf
        ip snode ist
        (TASK_ID_IP: task_id_ip tid ip)
        (* (WF_SNODE: SNode.wf imcasts snode) *)
        (WF_IST: istate_wf snode ist)
      : state_wf tid (State tid ip snode ist).

    Definition init_inbox : list msgT? :=
      List.repeat None (length task_ips).

    Lemma init_inbox_length
      : length init_inbox = num_tasks.
    Proof.
      unfold init_inbox.
      rewrite repeat_length. ss.
    Qed.

    Lemma init_inbox_nth
          n
          (VALID_N: n < num_tasks)
      : nth_error init_inbox n = Some None.
    Proof.
      apply repeat_nth_error_Some. ss.
    Qed.

    Lemma filtermap_init_inbox
      : filtermap id init_inbox = [].
    Proof.
      unfold init_inbox.
      apply filtermap_nil.
      intros a IN.
      eapply repeat_spec in IN. ss.
    Qed.

    Definition update_msg (ims: list (msgT?))
               (sid: Tid) (msg: msgT)
      : list (msgT?) :=
      replace_nth ims sid (Some msg).

    Definition parse_pld (pld: bytes)
      : (nat * Tid * msgT)? :=
      if length pld <? pld_size
      then None else parse_msg (firstn pld_size pld).

    Definition fetch_one_msg (sytm: nat)
               (pm: Packet.msg_t)
               (inbs: list (msgT?) * list (msgT?))
      : list (msgT?) * list (msgT?) :=
      let sytm_nxt := sytm + period in
      (* if negb (Packet.dest_port pm =? port)%nat *)
      (* then inbs *)
      match parse_pld (Packet.payload pm) with
      | None => inbs
      | Some (dtm, tid_s, msg) =>
        let (inbc, inbn) := inbs in
        if (dtm =? sytm) then
          (update_msg inbc tid_s msg, inbn)
        else if (dtm =? sytm_nxt) then
               (inbc, update_msg inbn tid_s msg)
             else inbs
      end.

    Definition fetch_msgs (sytm: nat)
               (inbp: list Packet.msg_t)
               (inbc: list msgT?)
      : list msgT? * list msgT? * list Packet.msg_t :=
      let inbn := init_inbox in
      process_firstn
        (fetch_one_msg sytm)
        inbp (inbc, inbn) (length task_ips * 4).

    Definition srl_pm (sytm_d: nat) (tid_s: nat)
               (tid_d: Tid) (msg: msgT)
      : Packet.t :=
      (* if (tid_d <? num_tasks + num_mcasts) then *)
      let ip_s := tid2ip tid_s in
      let ip_d := tid2ip tid_d in
      let rmsg := resize_bytes msg_size msg in
      let pld := serialize_msg sytm_d tid_s rmsg in
      Packet.Msg (Packet.mkMsg ip_s ip_d port pld).
    (* else None. *)

    Lemma wf_srl_pm
          sytm tid tid_d msg
          (* (RANGE_TID: IntRange.sint8 tid) *)
          (* (RANGE_SYTM: IntRange.uint64 sytm) *)
      : Packet.wf (srl_pm sytm tid tid_d msg).
    Proof.
      unfold srl_pm.
      econs. econs. ss.
      hexploit serialize_msg_size_lt_maxlen.
      { reflexivity. }
      2: { intro LE. apply LE. }
      erewrite resize_bytes_length; eauto.
    Qed.

    Definition check_and_send
               (sytm: nat) (tid: Tid)
               (sh: list bool) (om: (Tid * msgT)?)
      : list bool * Packet.t? :=
      match om with
      | None => (sh, None)
      | Some (tid_d, msg) =>
        match check_send_hist sh tid_d with
        | None => (sh, None)
        | Some sh' =>
          (sh', Some (srl_pm (sytm + period) tid tid_d msg))
        end
      end.

    Inductive istep
              (tm: DTime.t)
              (tid: Tid) (ip: ip_t)
              (node: t)
      : @istate_t node -> tsp * events (nbE +' sysE) -> Packet.t ? ->
        @istate_t node -> Prop :=
    | IStep_Fail st
        (* outb outb' opkt *)
        (* (OUTPUT: age_outbox ip outb = (outb', opkt)) *)
      : istep tm tid ip node
              st (Z0, []) None Off

    | IStep_TurnOn
        cbt jtl (* fsytm *)
        ast_i mids_j
        (CBT_LB: period <= cbt)
        (CUR_BASE_TIME: cbt = get_skwd_base_time period tm)
        (* (SYNC_TIME: Nat.divide period fsytm) *)
        (JOIN_BEFORE_START: jtl = cbt + period - max_clock_skew - max_nw_delay)
        (* (FIRST_SYNC_TIME: fsytm = cbt + period + period) *)
        (RANGE_TM: DTime.of_ns (cbt - max_clock_skew) < tm
                   < DTime.of_ns jtl)
        (ABST_INIT_STATE: SNode.init_app_state _ ast_i)
        (MCAST_IPS_TO_JOIN: mids_j = get_mcast_of tid)
      : istep tm tid ip node
              Off (Z0, []) None
              (Prep mids_j jtl [] ast_i)

    | IStep_Prep_Internal
        jtl inbp ast mids_j
        (BEFORE_LIMIT: tm < DTime.of_ns jtl)
      : istep tm tid ip node
              (Prep mids_j jtl inbp ast) (Z0, []) None
              (Prep mids_j jtl inbp ast)
    | IStep_Prep_SendJoin
        mid_j mids_j' jtl inbp ast mcm
        (BEFORE_LIMIT: tm < DTime.of_ns jtl)
        (MCAST_MEMBER: mcm = (tid2ip mid_j, ip))
      : istep tm tid ip node
              (Prep (mid_j::mids_j') jtl inbp ast)
              (Z0, []) (Some (Packet.MCast mcm))
              (Prep mids_j' jtl inbp ast)
    | IStep_Prep_Complete
        jtl sytm inbp inbm ast
        (BEFORE_LIMIT: tm < DTime.of_ns jtl)
        (JOIN_BEFORE_START: sytm = jtl + max_clock_skew +
                                   max_nw_delay + period)
        (INIT_INBOX: inbm = init_inbox)
      : istep tm tid ip node
              (Prep [] jtl inbp ast) (Z0, []) None
              (On sytm inbp inbm Ready ast)

    | IStep_OnStay
        sytm inbp inbm stg ast
        (TIME_UB: tm < DTime.of_ns (sytm + period - max_clock_skew - max_nw_delay))
      : istep tm tid ip node
              (On sytm inbp inbm stg ast)
              (Z0, []) None
              (On sytm inbp inbm stg ast)

    | IStep_PeriodBegin
        sytm inbp inbm ast
        inbc inbn inbp' ast' sh_i
        (SYTM_BELOW_MAX_TIME: sytm < MAX_TIME)
        (SYNC_TIME: sytm = get_skwd_base_time period tm)
        (RANGE_TIME: DTime.of_ns (sytm - max_clock_skew) < tm < DTime.of_ns (sytm + period - max_clock_skew - max_nw_delay))
        (FETCH_MSGS: fetch_msgs sytm inbp inbm =
                     (inbc, inbn, inbp'))
        (PERIOD_BEGIN: node.(SNode.period_begin) (Z.of_nat sytm) inbc ast ast')
        (SEND_HIST: sh_i = List.repeat false num_tasks)
        (* (NEXT_SYNC_TIME: nsytm = sytm + period) *)
      : istep tm tid ip node
              (On sytm inbp inbm Ready ast)
              (Z0, []) None
              (On sytm inbp' inbn (Running sh_i) ast')

    | IStep_Running_Go
        inbp inbm sh ast ast1
        oe om sh' ast' opkt
        sytm (* nsytm *) es zsytm
        (TIME_UB:  tm < DTime.of_ns (sytm + period - max_clock_skew - max_nw_delay))
        (TAU_STEPS: AANode.sh_tau_steps sh node ast ast1)
        (ISTEP: SNode.istep node ast1 oe om ast')
        (CHECK_SEND: check_and_send sytm tid sh om = (sh', opkt))
        (EVTS: es = opt2list oe)
        (TIMESTAMP: zsytm = Z.of_nat sytm)
      : istep tm tid ip node
              (On sytm inbp inbm (Running sh) ast)
              (zsytm, es) opkt
              (On sytm inbp inbm (Running sh') ast')

    | IStep_Done
        sytm inbp inbm sh ast ast_f nsytm
        (TIME_UB: tm < DTime.of_ns (sytm + period - max_clock_skew - max_nw_delay))
        (NEXT_SYNC_TIME: nsytm = sytm + period)
        (TAU_STEPS: AANode.sh_tau_steps sh node ast ast_f)
        (* (TAU_STEPS: clos_refl_trans *)
        (*               _ (SNode.app_step node) ast ast_f) *)
        (PERIOD_END: node.(SNode.period_end) ast_f)
      : istep tm tid ip node
              (On sytm inbp inbm (Running sh) ast)
              (Z0, []) None
              (On nsytm inbp inbm Ready ast_f)
    .

    Definition filter_port dpms_f1: list Packet.msg_t :=
      filter (fun pm : Packet.msg_t =>
                Packet.dest_port pm =? port) dpms_f1.

    Definition accept_packets {node: t}
               (* (tm: DTime.t) *)
               (pms: list Packet.msg_t)
               (ist: @istate_t node)
      : istate_t :=
      let pms' := filter_port pms in
      (* filter (fun pm => Packet.dest_port pm =? port) pms in *)
      match ist with
      | Prep mids tm inbp ast =>
        Prep mids tm (inbp ++ pms') ast
      | On sytm inbp inbm stg ast =>
        On sytm (inbp ++ pms') inbm stg ast
      | Off => Off
      end.

    Inductive step (tm: DTime.t) (dpms: list Packet.msg_t)
      : state -> tsp * events (nbE +' sysE) -> Packet.t ? ->
        state -> Prop :=
      Step
        tid ip node ist ist1
        tes op ist'
        (ACCEPT_PACKETS: ist1 = accept_packets dpms ist)
        (ISTEP: istep tm tid ip node
                      ist1 tes op ist')
      : step tm dpms
             (State tid ip node ist) tes op
             (State tid ip node ist').

    Lemma wf_accept_prsv
          pms node ist
          (* (WF_PMS: Forall Packet.msg_wf pms) *)
          (WF_IST: istate_wf node ist)
      : istate_wf node (accept_packets pms ist).
    Proof.
      inv WF_IST; econs; ss.
    Qed.

    Lemma wf_istep_prsv
          tm tid ip node
          ist tes op ist'
          (TASK_ID_IP: task_id_ip tid ip)
          (ISTEP: istep tm tid ip node
                        ist tes op ist')
          (WF_IST: istate_wf node ist)
      : <<WF_OPKT: option_rel1 Packet.wf op>> /\
        <<WF_IST': istate_wf node ist'>>.
    Proof.
      inv WF_IST.
      - inv ISTEP; ss.
        + esplits; ss. econs.
        + esplits; ss. econs.
          apply Forall_forall.
          intros mid IN.
          hexploit get_mcast_of_spec; eauto. i. des.
          r. esplits; eauto.
          unfold num_mcasts.
          eapply nth_error_Some. congruence.
      - inv ISTEP; ss.
        + esplits; ss. econs.
        + esplits; ss. econs. ss.
        + inv VALID_MCAST_IDS.
          esplits; ss.
          * econs. econs; ss.
            { hexploit valid_mcast_id_ip; eauto. i.
              hexploit mcast_id_ip_comput; eauto. i. des.
              eauto. }
            { hexploit task_id_ip_comput; eauto. i. des.
              eauto. }
          * econs; eauto.
        + esplits; ss. econs.
      - inv ISTEP.
        + esplits; ss. econs.
        + esplits; ss. econs.
        + esplits; ss. econs; ss.
          rewrite repeat_length. ss.
      - inv ISTEP; ss.
        + esplits; ss. econs.
        + esplits; ss. econs; ss.
        + unfold check_and_send in CHECK_SEND.
          destruct om as [ [tid_d m] |].
          2: { clarify.
               esplits; ss.
               econs; eauto. }
          destruct (check_send_hist sh tid_d) eqn:SH.
          2: { clarify.
               esplits; ss.
               econs; eauto. }
          clarify.
          apply check_send_hist_Some in SH; eauto.
          esplits.
          { apply wf_srl_pm. }
          { econs; ss.
            des; ss.
          }
        + esplits; ss. econs.
    Qed.

    Lemma wf_prsv
          tm dpms st tes op st' tid
          (STEP: step tm dpms st tes op st')
          (WF_STATE: state_wf tid st)
      : state_wf tid st' /\
        option_rel1 Packet.wf op.
    Proof.
      inv WF_STATE.
      inv STEP; ss. existT_elim. subst.
      hexploit wf_istep_prsv; eauto.
      { eapply wf_accept_prsv; eauto. }
      i. des.
      split; ss.
    Qed.

    Lemma istep_progress
          tm tid ip node ist
      : exists tes op ist',
        istep tm tid ip node
              ist tes op ist'.
    Proof.
      esplits. econs 1.
    Qed.

    Lemma step_progress
          tm dpms st
      : exists tes op st',
        step tm dpms st tes op st'.
    Proof.
      destruct st as [tid ip nd oist].
      hexploit istep_progress; eauto. i. des.
      esplits. econs; eauto.
    Qed.

    Lemma wf_init_state tid ip snode
          (* (WF_SNODE: SNode.wf imcasts snode) *)
          (TASK_ID_IP: task_id_ip tid ip)
      : state_wf tid (State tid ip snode Off).
    Proof.
      econs; eauto. econs.
    Qed.

    Definition as_node (tid: Tid) (snode: t)
      : @Node.t sysE :=
      let ip := tid2ip tid in
      Node.mk ip state
              (fun st => st = State tid ip snode Off) step.

    Lemma safe_node
          tid (* ip *) snode
          (* (WF_SNODE: SNode.wf imcasts snode) *)
      (* (TASK_ID_IP: task_id_ip tid ip) *)
          (VALID_TASK_ID: valid_task_id tid)
      : Node.safe (as_node tid snode).
    Proof.
      econs; ss.
      { esplits; eauto. }
      i. subst.

      eapply valid_task_id_ip in VALID_TASK_ID.

      (* hexploit task_id_ip_comput; eauto. *)
      (* intros (TID2IP_EQ & IP_LOCAL). *)
      (* rewrite TID2IP_EQ. *)
      pose (ip := tid2ip tid).
      fold ip.

      hexploit (wf_init_state tid ip snode); eauto.

      match goal with
      | |- _ -> Node.safe_istate _ _ ?st =>
        generalize st
      end.
      revert tm.

      clear VALID_TASK_ID ip.
      pcofix CIH. i.

      pfold. econs.
      - i. ss.
        hexploit step_progress; eauto.
      - i. ss.
        hexploit wf_prsv; eauto.
        intro WF_ST'.
        i. des.
        splits; ss.
        right. apply CIH. eauto.
    Qed.

  End NODE.
End AbstMW.


Require Import Arith.
Require Import ZArith.
Require Import List.
Import ListNotations.
Require Import Sorted.
Require Import Omega.
Require Import Psatz.

Require Import v1.NeutronTactics.
Require Import v1.Util.
Require Import v1.Multi.
Require Import v1.MForall.
Require Import v1.ListLemmas.
Require Import v1.Wf.
Require Import v1.Terminate.
Require Import v1.Preservation.
Require Import v1.Queue.
Require Import v1.System.
Require Import v1.SystemWf.
Require Import v1.Expr.
Require v1.ExprDbl.
Require v1.ExprAbs.

Require Import v1.EpicsTypes.
Require Import v1.FloatAux.
Require Import v1.FloatAbs.
Require Import v1.FloatAbsBase.
Require Import v1.Step.
Require Import v1.StepAux.
Require v1.ControlFlow.

Set Default Timeout 10.

Module Dbl := ExprDbl.
Module Abs := ExprAbs.

Definition D := Dbl.dbl_eval_bits.
Definition A := Abs.abs_eval_bits.

Inductive ty_rel : Dbl.dbl_tydesc -> Abs.abs_tydesc -> Prop :=
| TrNil : ty_rel Dbl.Nil Abs.Nil
| TrDbl : ty_rel Dbl.Dbl Abs.Abs
.
Hint Constructors ty_rel.

Definition lift (fd : tydesc D -> Type) (fa : tydesc A -> Type) :
    (forall dty aty, fd dty -> fa aty -> Prop) ->
    ({ ty : tydesc D & fd ty } -> { ty : tydesc A & fa ty } -> Prop).
intro P.
intros dsig asig.
destruct dsig as [d d'], asig as [a a'].
eapply P; eassumption.
Defined.

Inductive refine_dbl : e_double -> abs_value -> Prop :=
| RdNone : forall d, refine_dbl d None
| RdSome : forall d z min max,
        fwhole_eq d z ->
        (min <= z <= max)%Z ->
        refine_dbl d (Some (min, max)).

Inductive refine_value : forall dty aty, ty_denote D dty -> ty_denote A aty -> Prop :=
| RvNil : refine_value Dbl.Nil Abs.Nil tt tt
| RvDbl : forall d a,
        refine_dbl d a ->
        refine_value Dbl.Dbl Abs.Abs d a.
Definition refine_value' :
    ({ ty : tydesc D & ty_denote D ty } -> { ty : tydesc A & ty_denote A ty } -> Prop) :=
    lift _ _ refine_value.

Inductive refine_unop dty1 aty1 :
    forall dtyR atyR
        (df : unop_impl _ dty1 dtyR)
        (af : unop_impl _ aty1 atyR),
        Prop :=
| RefineUnop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1,
        refine_value dty1 aty1 dx1 ax1 ->
        refine_value dtyR atyR (df dx1) (af ax1)) ->
    refine_unop dty1 aty1 dtyR atyR df af.
Definition refine_unop' dty1 aty1 :=
    lift _ _ (refine_unop dty1 aty1).

Inductive refine_binop dty1 aty1 dty2 aty2 :
    forall dtyR atyR
        (df : binop_impl _ dty1 dty2 dtyR)
        (af : binop_impl _ aty1 aty2 atyR),
        Prop :=
| RefineBinop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1 dx2 ax2,
        refine_value dty1 aty1 dx1 ax1 ->
        refine_value dty2 aty2 dx2 ax2 ->
        refine_value dtyR atyR (df dx1 dx2) (af ax1 ax2)) ->
    refine_binop dty1 aty1 dty2 aty2 dtyR atyR df af.
Definition refine_binop' dty1 aty1 dty2 aty2 :=
    lift _ _ (refine_binop dty1 aty1 dty2 aty2).

Inductive refine_ternop dty1 aty1 dty2 aty2 dty3 aty3 :
    forall dtyR atyR
        (df : ternop_impl _ dty1 dty2 dty3 dtyR)
        (af : ternop_impl _ aty1 aty2 aty3 atyR),
        Prop :=
| RefineTernop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    ty_rel dty3 aty3 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1 dx2 ax2 dx3 ax3,
        refine_value dty1 aty1 dx1 ax1 ->
        refine_value dty2 aty2 dx2 ax2 ->
        refine_value dty3 aty3 dx3 ax3 ->
        refine_value dtyR atyR (df dx1 dx2 dx3) (af ax1 ax2 ax3)) ->
    refine_ternop dty1 aty1 dty2 aty2 dty3 aty3 dtyR atyR df af.
Definition refine_ternop' dty1 aty1 dty2 aty2 dty3 aty3 :=
    lift _ _ (refine_ternop dty1 aty1 dty2 aty2 dty3 aty3).

Inductive refine_varop dty1 aty1 :
    forall dtyR atyR
        (df : varop_impl _ dty1 dtyR)
        (af : varop_impl _ aty1 atyR),
        Prop :=
| RefineVarop : forall dtyR atyR df af,
    ty_rel dty1 aty1 ->
    ty_rel dtyR atyR ->
    (forall dx1 ax1,
        Forall2 (refine_value dty1 aty1) dx1 ax1 ->
        refine_value dtyR atyR (df dx1) (af ax1)) ->
    refine_varop dty1 aty1 dtyR atyR df af.
Definition refine_varop' dty1 aty1 :=
    lift _ _ (refine_varop dty1 aty1).

Inductive refine_state_fn :
    forall dtyR atyR
        (df : state_fn D 12 (ty_denote D dtyR))
        (af : state_fn A 12 (ty_denote A atyR)),
        Prop :=
| RefineStateFn : forall dtyR atyR df af,
    ty_rel dtyR atyR ->
    (forall dsv dsx asv asx dsv' dsx' dr asv' asx' ar,
        MForall2 (refine_value _ _) dsv asv ->
        MForall2 (refine_value _ _) dsx asx ->
        df dsv dsx = (dsv', dsx', dr) ->
        af asv asx = (asv', asx', ar) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        MForall2 (refine_value _ _) dsx' asx' /\
        refine_value _ _ dr ar) ->
    refine_state_fn dtyR atyR df af.
Definition refine_state_fn' :=
    lift _ _ (refine_state_fn).

Inductive refine_state_fn_list :
    forall dtyR atyR
        (df : state_fn D 12 (list (ty_denote D dtyR)))
        (af : state_fn A 12 (list (ty_denote A atyR))),
        Prop :=
| RefineStateFnList : forall dtyR atyR df af,
    ty_rel dtyR atyR ->
    (forall dsv dsx asv asx dsv' dsx' drs asv' asx' ars,
        MForall2 (refine_value _ _) dsv asv ->
        MForall2 (refine_value _ _) dsx asx ->
        df dsv dsx = (dsv', dsx', drs) ->
        af asv asx = (asv', asx', ars) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        MForall2 (refine_value _ _) dsx' asx' /\
        Forall2 (refine_value _ _) drs ars) ->
    refine_state_fn_list dtyR atyR df af.
Definition refine_state_fn_list' :=
    lift _ _ (refine_state_fn_list).

Inductive refine_state_fn_noxvar :
    forall dtyR atyR
        (df : state_fn_noxvar D 12 (ty_denote D dtyR))
        (af : state_fn_noxvar A 12 (ty_denote A atyR)),
        Prop :=
| RefineStateFnNoXVar : forall dtyR atyR df af,
    ty_rel dtyR atyR ->
    (forall dsv asv dsv' dr asv' ar,
        MForall2 (refine_value _ _) dsv asv ->
        df dsv = (dsv', dr) ->
        af asv = (asv', ar) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        refine_value _ _ dr ar) ->
    refine_state_fn_noxvar dtyR atyR df af.
Definition refine_state_fn_noxvar' :=
    lift _ _ (refine_state_fn_noxvar).

Lemma double_abs_refine : forall d,
    refine_dbl d (Abs.double_abs d).
intros. unfold Abs.double_abs. break_match.
- econstructor.
  + eapply B2Z_safe_correct. eassumption.
  + omega.
- constructor.
Qed.

Lemma convert_lit_refine : forall x,
    refine_value' (convert_lit D x) (convert_lit A x).
intros. simpl.  constructor. eauto using double_abs_refine.
Qed.

Local Hint Resolve (tydesc_eq_dec D) : eq_dec.
Local Hint Resolve (tydesc_eq_dec A) : eq_dec.

Lemma abs_bool_refine : forall d,
    (d = zero \/ d = one) ->
    refine_dbl d Abs.abs_bool.
intros0 Hor. destruct Hor.
- econstructor.
  + subst. eapply fwhole_eq_Z2B.
    eapply Z.pow_pos_nonneg; omega.
  + omega.

- econstructor.
  + subst. eapply fwhole_eq_Z2B.
    rewrite Z.abs_eq by omega.
    replace 1 with (1 ^ (53 - 1)) at 1 by (eapply Z.pow_1_l; omega).
    eapply Z.pow_lt_mono_l; omega.
  + omega.
Qed.

Lemma unop_denote_refine : forall op dty1 aty1 dden,
    ty_rel dty1 aty1 ->
    unop_denote D op dty1 = Some dden ->
    exists aden,
        unop_denote A op aty1 = Some aden /\
        refine_unop' _ _ dden aden.
destruct op, dty1; inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_unop', lift.
all: constructor; eauto.
all: inversion 1; constructor.
all: fix_existT; subst.

- on >refine_dbl, invc; [ solve [constructor] | ].
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bopp; eauto.
  + omega.

- eapply abs_bool_refine.  break_if; eauto.

Qed.

Lemma Z_mult_range_max_l : forall x y0 y1 y,
    y0 <= y <= y1 ->
    x * y <= Z.max (x * y0) (x * y1).
intros. destruct (Z_le_gt_dec 0 x).
- eapply Z.le_trans with (m := x * y1).
  + eapply Z.mul_le_mono_nonneg_l; omega.
  + eapply Z.le_max_r.
- eapply Z.le_trans with (m := x * y0).
  + eapply Z.mul_le_mono_nonpos_l; omega.
  + eapply Z.le_max_l.
Qed.

Lemma Z_mult_range_max_r : forall x0 x1 x y,
    x0 <= x <= x1 ->
    x * y <= Z.max (x0 * y) (x1 * y).
intros. destruct (Z_le_gt_dec 0 y).
- eapply Z.le_trans with (m := x1 * y).
  + eapply Z.mul_le_mono_nonneg_r; omega.
  + eapply Z.le_max_r.
- eapply Z.le_trans with (m := x0 * y).
  + eapply Z.mul_le_mono_nonpos_r; omega.
  + eapply Z.le_max_l.
Qed.

Lemma Z_mult_range_max : forall x0 x1 y0 y1 x y,
    x0 <= x <= x1 ->
    y0 <= y <= y1 ->
    let z1 := Z.max (Z.max (x0 * y0) (x0 * y1)) (Z.max (x1 * y0) (x1 * y1)) in
    x * y <= z1.
intros.
eapply Z.le_trans with (m := Z.max (x0 * y) (x1 * y)).
- eapply Z_mult_range_max_r. eauto.
- eapply Z.max_le_compat; eapply Z_mult_range_max_l; eauto.
Qed.

Lemma Z_mult_range_min_l : forall x y0 y1 y,
    y0 <= y <= y1 ->
    Z.min (x * y0) (x * y1) <= x * y.
intros. destruct (Z_le_gt_dec 0 x).
- eapply Z.le_trans with (m := x * y0).
  + eapply Z.le_min_l.
  + eapply Z.mul_le_mono_nonneg_l; omega.
- eapply Z.le_trans with (m := x * y1).
  + eapply Z.le_min_r.
  + eapply Z.mul_le_mono_nonpos_l; omega.
Qed.

Lemma Z_mult_range_min_r : forall x0 x1 x y,
    x0 <= x <= x1 ->
    Z.min (x0 * y) (x1 * y) <= x * y.
intros. destruct (Z_le_gt_dec 0 y).
- eapply Z.le_trans with (m := x0 * y).
  + eapply Z.le_min_l.
  + eapply Z.mul_le_mono_nonneg_r; omega.
- eapply Z.le_trans with (m := x1 * y).
  + eapply Z.le_min_r.
  + eapply Z.mul_le_mono_nonpos_r; omega.
Qed.

Lemma Z_mult_range_min : forall x0 x1 y0 y1 x y,
    x0 <= x <= x1 ->
    y0 <= y <= y1 ->
    let z0 := Z.min (Z.min (x0 * y0) (x0 * y1)) (Z.min (x1 * y0) (x1 * y1)) in
    z0 <= x * y.
intros.
eapply Z.le_trans with (m := Z.min (x0 * y) (x1 * y)).
- eapply Z.min_le_compat; eapply Z_mult_range_min_l; eauto.
- eapply Z_mult_range_min_r. eauto.
Qed.

Lemma Z_mult_range : forall x0 x1 y0 y1 x y,
    x0 <= x <= x1 ->
    y0 <= y <= y1 ->
    let z0 := Z.min (Z.min (x0 * y0) (x0 * y1)) (Z.min (x1 * y0) (x1 * y1)) in
    let z1 := Z.max (Z.max (x0 * y0) (x0 * y1)) (Z.max (x1 * y0) (x1 * y1)) in
    z0 <= x * y <= z1.
intros. split; eauto using Z_mult_range_min, Z_mult_range_max.
Qed.

Lemma binop_denote_refine : forall op dty1 aty1 dty2 aty2 dden,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    binop_denote D op dty1 dty2 = Some dden ->
    exists aden,
        binop_denote A op aty1 aty2 = Some aden /\
        refine_binop' _ _ _ _ dden aden.
destruct op, dty1, dty2; do 2 inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_unop', lift.
all: constructor; eauto.
all: do 2 inversion 1; constructor.
all: fix_existT; subst.

- do 2 (on >refine_dbl, invc; [ solve [constructor] | ]).
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bplus; eauto.
    rewrite Z_abs_range. change (53 - 1) with 52. omega.
  + omega.

- do 2 (on >refine_dbl, invc; [ solve [constructor] | ]).
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bminus; eauto.
    rewrite Z_abs_range. change (53 - 1) with 52. omega.
  + omega.

- do 2 (on >refine_dbl, invc; [ solve [constructor] | ]).
  simpl. unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
  econstructor.
  + eapply fwhole_eq_Bmult; eauto.
    rewrite Z_abs_range. change (53 - 1) with 52.
    forward eapply Z_mult_range with (x := z) (y := z0); eauto.
    cbv zeta in *. omega.
  + eapply Z_mult_range; eauto.

- constructor.

- eapply abs_bool_refine.  unfold Dbl.b64_ge. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_gt. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_le. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_lt. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_ne. do 2 (break_match; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_eq. do 2 (break_match; eauto).

- eapply abs_bool_refine.  unfold Dbl.b64_and. do 2 (break_if; eauto).
- eapply abs_bool_refine.  unfold Dbl.b64_or. do 2 (break_if; eauto).

Qed.

Lemma ternop_denote_refine : forall op dty1 aty1 dty2 aty2 dty3 aty3 dden,
    ty_rel dty1 aty1 ->
    ty_rel dty2 aty2 ->
    ty_rel dty3 aty3 ->
    ternop_denote D op dty1 dty2 dty3 = Some dden ->
    exists aden,
        ternop_denote A op aty1 aty2 aty3 = Some aden /\
        refine_ternop' _ _ _ _ _ _ dden aden.
destruct op, dty1, dty2, dty3; do 3 inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_unop', lift.
all: constructor; eauto.
all: do 3 inversion 1; constructor.
all: fix_existT; subst.

- on (refine_dbl dx2 _), invc; [ solve [constructor] | ].
  on (refine_dbl dx3 _), invc; [ solve [constructor] | ].
  simpl. unfold Abs.check_overflow. do 3 (break_if; try solve [constructor]).
  + econstructor; eauto. lia.
  + econstructor; eauto. lia.

Qed.

Lemma min_fwhole_eq : forall dx dy zx zy,
    fwhole_eq dx zx ->
    fwhole_eq dy zy ->
    fwhole_eq (Dbl.b64_min dx dy) (Z.min zx zy).
intros0 Hx Hy.
unfold Dbl.b64_min, Z.min. break_match; [ break_match | ].
all: erewrite fwhole_eq_Bcompare in * by eauto.
4: discriminate.
all: inject_some; find_rewrite.
all: eauto.

(* Eq case needs a bit more. *)
rewrite Z.compare_eq_iff in *. subst. auto.
Qed.

Lemma max_fwhole_eq : forall dx dy zx zy,
    fwhole_eq dx zx ->
    fwhole_eq dy zy ->
    fwhole_eq (Dbl.b64_max dx dy) (Z.max zx zy).
intros0 Hx Hy.
unfold Dbl.b64_max, Z.max. break_match; [ break_match | ].
all: erewrite fwhole_eq_Bcompare in * by eauto.
4: discriminate.
all: inject_some; find_rewrite.
all: eauto.
Qed.

Lemma min_refine : forall dx dy ax ay,
    refine_dbl dx ax ->
    refine_dbl dy ay ->
    refine_dbl (Dbl.b64_min dx dy) (Abs.abs_min ax ay).
intros0 Hx Hy.
invc Hx; invc Hy; simpl; try solve [constructor].
unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
eapply RdSome with (z := Z.min z z0).
- eapply min_fwhole_eq; eauto.
- lia.
Qed.

Lemma max_refine : forall dx dy ax ay,
    refine_dbl dx ax ->
    refine_dbl dy ay ->
    refine_dbl (Dbl.b64_max dx dy) (Abs.abs_max ax ay).
intros0 Hx Hy.
invc Hx; invc Hy; simpl; try solve [constructor].
unfold Abs.check_overflow. do 2 (break_if; try solve [constructor]).
eapply RdSome with (z := Z.max z z0).
- eapply max_fwhole_eq; eauto.
- lia.
Qed.

Lemma minimum_refine : forall dxs axs,
    Forall2 refine_dbl dxs axs ->
    refine_dbl (Dbl.b64_minimum dxs) (Abs.abs_minimum axs).
induction dxs; intros0 Hfa; invc Hfa; simpl.
- eapply RdSome with (z := 0).
  + unfold zero. eapply fwhole_eq_Z2B. eapply Z.pow_pos_nonneg; lia.
  + lia.
- eapply min_refine; eauto.
Qed.

Lemma maximum_refine : forall dxs axs,
    Forall2 refine_dbl dxs axs ->
    refine_dbl (Dbl.b64_maximum dxs) (Abs.abs_maximum axs).
induction dxs; intros0 Hfa; invc Hfa; simpl.
2: on >Forall2, invc.
- eapply RdSome with (z := 0).
  + unfold zero. eapply fwhole_eq_Z2B. eapply Z.pow_pos_nonneg; lia.
  + lia.
- auto.
- eapply max_refine; eauto.
Qed.

Lemma refine_value_dbl : forall dx ax,
    refine_value Dbl.Dbl Abs.Abs dx ax <->
    refine_dbl dx ax.
intros. split; intro Hr.
- inversion Hr. fix_existT. subst. auto.
- constructor. auto.
Qed.

Lemma refine_value_dbl_list : forall dx ax,
    Forall2 (refine_value Dbl.Dbl Abs.Abs) dx ax <->
    Forall2 refine_dbl dx ax.
induction dx; intros; split; intro Hr; invc Hr; eauto.
- rewrite refine_value_dbl in *. rewrite IHdx in *. eauto.
- rewrite <- refine_value_dbl in *. rewrite <- IHdx in *. eauto.
Qed.

Lemma varop_denote_refine : forall op dty1 aty1 dden,
    ty_rel dty1 aty1 ->
    varop_denote D op dty1 = Some dden ->
    exists aden,
        varop_denote A op aty1 = Some aden /\
        refine_varop' _ _ dden aden.

destruct op, dty1; inversion 1; intros0 Dop;
simpl in *; try discriminate.
all: eexists; split; [ reflexivity | ].
all: inject_some; unfold refine_varop', lift.
all: constructor; eauto.
all: constructor.

- rewrite refine_value_dbl_list in *.
  eapply minimum_refine; eauto.

- rewrite refine_value_dbl_list in *.
  eapply maximum_refine; eauto.
Qed.

Ltac specialize_refinement :=
    repeat match goal with
    (* First, try to destruct some applications.  This will fail if the arguments
       used in the LHS have not been filled in yet, and we will fall through to the
       spec_evar case below. *)
    | [ H : forall x, _ |- _ ] =>
            match type of H with
            | context [ ?x = (_, _, _) ] =>
                    match x with
                    | (_, _, _) => fail 1
                    | _ => destruct x as [[? ?] ?] eqn:?
                    end
            end
    (* Main case: try to fill in arguments using evar or eassumption *)
    | [ H : forall x : ?T, _ |- _ ] =>
            match type of T with
            | Set => spec_evar H
            | Prop =>
                    match goal with
                    | [ H' : _ |- _ ] => specialize (H H'); clear H'
                    end
            end
    (* Also handle @eq premises with reflexivity *)
    | [ H : _ = _ -> _ |- _ ] => spec H by reflexivity
    (* Final cleanup: break `exists` and `and`. *)
    | [ H : exists _, _ |- _ ] => destruct H
    | [ H : _ /\ _ |- _ ] => destruct H
    end.

Lemma var_ty_rel : ty_rel (var_ty D) (var_ty A).
constructor.
Qed.

Lemma xvar_ty_rel : ty_rel (xvar_ty D) (xvar_ty A).
constructor.
Qed.

Lemma nil_ty_rel : ty_rel (nil_ty D) (nil_ty A).
constructor.
Qed.

Lemma ty_rel_inj : forall dty aty1 aty2,
    ty_rel dty aty1 ->
    ty_rel dty aty2 ->
    aty1 = aty2.
do 2 inversion 1; eauto.
Qed.

Lemma ty_rel_nil_sur : forall dty1 dty2,
    ty_rel dty1 (nil_ty A) ->
    ty_rel dty2 (nil_ty A) ->
    dty1 = dty2.
do 2 inversion 1; eauto.
Qed.

Lemma nil_rel_fwd : forall aty,
    ty_rel (nil_ty D) aty ->
    aty = nil_ty A.
intros. eapply ty_rel_inj; eauto using nil_ty_rel.
Qed.

Lemma nil_rel_rev : forall dty,
    ty_rel dty (nil_ty A) ->
    dty = nil_ty D.
intros. eapply ty_rel_nil_sur; eauto using nil_ty_rel.
Qed.

Lemma unpack_opt_helper1
    DI DP DR dopt (didx : DI) dval df drhs
    AI AP AR aopt (aidx : AI) aval af
        (P : AR -> Prop):
    unpack_opt (R := DR) dopt df = Some drhs ->
    dopt = Some (existT DP didx dval) ->
    aopt = Some (existT AP aidx aval) ->
    (df didx dval = Some drhs ->
        exists arhs, af aidx aval = Some arhs /\ P arhs) ->
    exists arhs, unpack_opt (R := AR) aopt af = Some arhs /\ P arhs.
intros0 Hunpack Hdden Haden Hinner.
subst dopt aopt. simpl in *.
eauto.
Qed.

Lemma unpack_opt_some_inv : forall I P R (opt : option { x : I & P x }) f rhs
        (Q : Prop),
    (forall idx val,
        opt = Some (existT P idx val) ->
        f idx val = Some rhs ->
        Q) ->
    unpack_opt (R := R) opt f = Some rhs -> Q.
intros.
destruct opt as [ s | ]; try discriminate.
destruct s. eauto.
Qed.

Lemma unpack_opt_some_inv' : forall I P R (opt : option { x : I & P x }) f rhs
        (Q : Prop),
    (forall idx val,
        opt = Some (existT P idx val) ->
        Q) ->
    unpack_opt (R := R) opt f = Some rhs -> Q.
inversion 2 using unpack_opt_some_inv. eauto.
Qed.

Lemma unpack_opt_some_ex
    I P R opt (idx : I) val f (Q : R -> Prop):
    opt = Some (existT P idx val) ->
    (exists rhs, f idx val = Some rhs /\ Q rhs) ->
    (exists rhs, unpack_opt (R := R) opt f = Some rhs /\ Q rhs).
intros0 Hopt Hinner.
subst opt. simpl in *. eauto.
Qed.

Ltac handle_unpack_opt :=
    let dden' := fresh "dden'" in
    let aden' := fresh "aden'" in
    let Hdden := fresh "Hdden" in
    let Haden := fresh "Haden" in
    let dty := fresh "dty" in
    let aty := fresh "aty" in
    let Hex := fresh "Hex" in
    let Hrefine := fresh "Hrefine" in

    match goal with
    | [ H : unpack_opt ?dden ?df = Some _ |-
        exists aden', unpack_opt ?aden ?af = Some _ /\ _ ] =>

            eapply unpack_opt_some_inv with (2 := H); clear H;
            intros dty dden' Hdden H;

            simple refine (let Hex : exists aden', aden = Some aden' /\ _ aden' := _ in _);
            [ shelve
            | eauto (* or defer to caller *)
            | clearbody Hex;
              destruct Hex as (aden' & Haden & Hrefine);
              destruct aden' as [aty aden'];
              eapply unpack_opt_some_ex; simpl in *; eauto
            ]
    end.

Lemma if_tydesc_eq_dec_inv : forall
    (T : Set) (A : eval_bits T)
    (P : tydesc A -> tydesc A -> Type)
    (ty xty : tydesc A)
    (x : forall ty xty, P ty xty)
    (y : forall ty xty, P ty xty)
    (z : forall ty xty, P ty xty)
    (Q : tydesc A -> Prop),
    (x xty xty = z xty xty -> Q xty) ->
    (ty <> xty ->
        y ty xty = z ty xty ->
        Q ty) ->
    ((if tydesc_eq_dec A ty xty then x ty xty else y ty xty) = z ty xty) -> Q ty.
intros.
destruct (tydesc_eq_dec _ _ _).
- subst. eauto.
- eauto.
Qed.

Lemma if_tydesc_eq_dec_eq_ex : forall
    (T : Set) (A : eval_bits T)
    (ty xty : tydesc A)
    (R : Type) (f g : tydesc A -> tydesc A -> option R)
    (Q : R -> Prop),
    ty = xty ->
    (exists rhs, f xty xty = Some rhs /\ Q rhs) ->
    (exists rhs, (if tydesc_eq_dec A ty xty then f ty xty else g ty xty) = Some rhs /\ Q rhs).
intros.
destruct (tydesc_eq_dec _ _ _); [ | exfalso; congruence ].
subst. auto.
Qed.

Lemma if_tydesc_eq_dec_ne_ex : forall
    (T : Set) (A : eval_bits T)
    (ty xty : tydesc A)
    (R : Type) (f g : tydesc A -> tydesc A -> option R)
    (Q : R -> Prop),
    ty <> xty ->
    (exists rhs, g ty xty = Some rhs /\ Q rhs) ->
    (exists rhs, (if tydesc_eq_dec A ty xty then f ty xty else g ty xty) = Some rhs /\ Q rhs).
intros.
destruct (tydesc_eq_dec _ _ _); [ exfalso; congruence | ].
auto.
Qed.

Lemma unpack_ty_helper1
    (DT : Set) (D : eval_bits DT) (DP : forall ty : tydesc D, Type) DR
        dden dty dden' (df : DP dty -> option DR) drhs
    (AT : Set) (A : eval_bits AT) (AP : forall ty : tydesc A, Type) AR
        aden aty aden' (af : AP aty -> option AR)
        (P : AR -> Prop) :
    unpack_ty (R := DR) D dty dden df = Some drhs ->
    dden = Some (existT DP dty dden') ->
    aden = Some (existT AP aty aden') ->
    (df dden' = Some drhs ->
        exists arhs, af aden' = Some arhs /\ P arhs) ->
    exists arhs, unpack_ty (R := AR) A aty aden af = Some arhs /\ P arhs.
intros0 Hunpack Hdden Haden Hinner.
subst dden aden. simpl in *.
destruct (tydesc_eq_dec _ dty dty); [ | exfalso; congruence ].
destruct (tydesc_eq_dec _ aty aty); [ | exfalso; congruence ].
fix_eq_rect; eauto using tydesc_eq_dec.
Qed.

Lemma unpack_ty_some_ex
    (T : Set) (A : eval_bits T) (P : forall ty : tydesc A, Type) R
        den ty den' (f : P ty -> option R)
        (Q : R -> Prop) :
    den = Some (existT P ty den') ->
    (exists rhs, f den' = Some rhs /\ Q rhs) ->
    (exists rhs, unpack_ty (R := R) A ty den f = Some rhs /\ Q rhs).
intros0 Hden Hinner.
subst den. simpl in *.
destruct (tydesc_eq_dec _ ty ty); [ | exfalso; congruence ].
fix_eq_rect; eauto using tydesc_eq_dec.
Qed.

Lemma unpack_ty_some_inv : forall
    (T : Set) (D : eval_bits T) (P : forall ty : tydesc D, Type) R
        xty den f rhs
        (Q : Prop),
    (forall val,
        den = Some (existT P xty val) ->
        f val = Some rhs ->
        Q) ->
    unpack_ty (R := R) D xty den f = Some rhs -> Q.
intros0 HQ Hunpack.
destruct den as [ s | ]; try discriminate.
destruct s. simpl in Hunpack.
destruct (tydesc_eq_dec _ _ _); try discriminate.
subst xty. fix_eq_rect; eauto using tydesc_eq_dec.
Qed.

Lemma denote'_refine : forall e dden,
    denote' D e = Some dden ->
    exists aden,
        denote' A e = Some aden /\
        refine_state_fn' dden aden.
induction e using expr_rect_mut with
    (Pl := fun es => forall ddens,
        denote'_list D es = Some ddens ->
        exists adens,
            denote'_list A es = Some adens /\
            refine_state_fn_list' ddens adens);
[ .. | eauto | eauto ];
intros0 Hden.

Local Opaque multi.
Local Opaque multi_get.
Local Opaque multi_set.
Local Opaque A.
Local Opaque D.

all: simpl in *; unfold pack_denot in *; inject_some.
all: try (eexists; split; [reflexivity|]; unfold refine_state_fn', lift).

- constructor.  { constructor. }
  intros. inject_pair.
  split; [|split]; auto.
  + eapply MForall2_get. assumption.

- constructor.  { constructor. }
  intros. inject_pair.
  split; [|split]; auto.
  + eapply MForall2_get. assumption.

- constructor.  { constructor. }
  intros. inject_pair.
  split; [|split]; auto.
  + eapply convert_lit_refine.

- (* Unary *)
  handle_unpack_opt.
  handle_unpack_opt.
    { on >refine_state_fn, invc. eapply unop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_unop, invc. auto. }
  intros.  clear IHe.

  on >refine_state_fn, invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_unop, invc.  specialize_refinement.

  eauto.

- (* Binary *)
  handle_unpack_opt.
  handle_unpack_opt.
  handle_unpack_opt.
    { inv Hrefine. inv Hrefine0. eapply binop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_binop, invc. auto. }
  intros.  clear IHe1 IHe2.

  on >(refine_state_fn dty), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >(refine_state_fn dty0), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_binop, invc.  specialize_refinement.

  eauto.

- (* Varary *)
  fold (denote'_list D xs) in *.
  fold (denote'_list A xs) in *.
  handle_unpack_opt.
  handle_unpack_opt.
    { inv Hrefine. eapply varop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_varop, invc. auto. }
  intros.  clear IHe.

  on >refine_state_fn_list, invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_varop, invc.  specialize_refinement.

  eauto.

- (* Assign *)

  (* TODO - put unpack_ty stuff into the handle_unpack_opt tactic *)
  on _, invc_using unpack_ty_some_inv.
    destruct (IHe _ **) as ([? ?] & HH & ?). simpl in *.
    on >refine_state_fn, invc.
    assert (x = var_ty A) by eauto using ty_rel_inj, var_ty_rel. subst x.
    eapply unpack_ty_some_ex; eauto.  clear HH.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { eauto using nil_ty_rel. }
  intros.  clear IHe.

  specialize_refinement.
    repeat find_rewrite. inject_pair.

  split; [|split]; eauto using set_MForall2.
  + econstructor.

- (* XAssign *)

  on _, invc_using unpack_ty_some_inv.
    destruct (IHe _ **) as ([? ?] & HH & ?). simpl in *.
    on >refine_state_fn, invc.
    assert (x = xvar_ty A) by eauto using ty_rel_inj, xvar_ty_rel. subst x.
    eapply unpack_ty_some_ex; eauto.  clear HH.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { eauto using nil_ty_rel. }
  intros.  clear IHe.

  specialize_refinement.
    repeat find_rewrite. inject_pair.

  split; [|split]; eauto using set_MForall2.
  + econstructor.

- (* Cond *)
  handle_unpack_opt.
  handle_unpack_opt.
  handle_unpack_opt.
  handle_unpack_opt.
    { do 3 on >refine_state_fn, invc. eapply ternop_denote_refine; eauto. }
    simpl in *.

  eexists. split; [reflexivity|]. inject_some. simpl.

  constructor.  { on >refine_ternop, invc. auto. }
  intros.  clear IHe1 IHe2 IHe3.

  on >(refine_state_fn dty), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >(refine_state_fn dty0), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >(refine_state_fn dty1), invc.  specialize_refinement.
    repeat find_rewrite. inject_pair.
  on >refine_ternop, invc.  specialize_refinement.

  eauto.

- (* Seq *)
  handle_unpack_opt.
  handle_unpack_opt.
  destruct (tydesc_eq_dec D _ _); [ | destruct (tydesc_eq_dec D _ _); [ | discriminate Hden ] ].

  + assert (aty = nil_ty A). { eapply nil_rel_fwd. invc Hrefine. auto. }
    subst aty. destruct (tydesc_eq_dec A _ _); [ | exfalso; congruence ].
    eexists. split; [ reflexivity | ]. inject_some. simpl.
    constructor. { invc Hrefine0. auto. } intros.

    on >(refine_state_fn (nil_ty D)), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    on >(refine_state_fn dty0), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

  + assert (aty <> nil_ty A).
      { on (dty <> _), contradict. eapply nil_rel_rev. invc Hrefine. auto. }
    destruct (tydesc_eq_dec A _ _); [ exfalso; congruence | ].
    assert (aty0 = nil_ty A). { eapply nil_rel_fwd. invc Hrefine0. auto. }
    subst aty0. destruct (tydesc_eq_dec A _ _); [ | exfalso; congruence ].
    eexists. split; [ reflexivity | ]. inject_some. simpl.
    constructor. { invc Hrefine. auto. } intros.

    on >(refine_state_fn dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    on >(refine_state_fn (nil_ty D)), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

- (* nil *) discriminate.

- destruct es as [| e' es ].

  + (* singleton list *)
    handle_unpack_opt.

    eexists. split; [reflexivity|]. inject_some. simpl.

    constructor.  { on >refine_state_fn, invc. auto. }
    intros.  clear IHe IHe0.

    on >(refine_state_fn dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

  + (* singleton list *)
    remember (e' :: es) as e'_es.
    handle_unpack_opt.
    handle_unpack_opt.
    destruct (tydesc_eq_dec _ _ _); try discriminate.
      subst dty0.

    destruct (tydesc_eq_dec _ _ _); cycle 1.
      { on (aty <> _), contradict.
        invc Hrefine. invc Hrefine0.
        eapply ty_rel_inj; eauto. }
      subst aty0.

    eexists. split; [reflexivity|]. inject_some. simpl.

    constructor.  { on >refine_state_fn, invc. auto. }
    intros.  clear IHe IHe0.

    on >(refine_state_fn dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    on >(refine_state_fn_list dty), invc.  specialize_refinement.
      repeat find_rewrite. inject_pair.
    auto.

Qed.

Local Transparent A.
Local Transparent D.

Lemma denote_refine : forall e dden,
    Dbl.denote e = Some dden ->
    exists aden,
        Abs.denote e = Some aden /\
        refine_state_fn_noxvar Dbl.Dbl Abs.Abs dden aden.
intros. unfold Dbl.denote in *.

on _, invc_using unpack_ty_some_inv.
forward eapply denote'_refine as HH; eauto.  destruct HH as (aden & Haden & Hrefine).
  simpl in Hrefine. destruct aden as [aty aden].
  change e_double with (ty_denote D Dbl.Dbl) in val.
  assert (aty = Abs.Abs).  { inv Hrefine. on >ty_rel, invc. auto. }  subst aty.
unfold Abs.denote.
eapply unpack_ty_some_ex; eauto.

eexists. split; [ reflexivity | ]. inject_some.
constructor. { invc Hrefine. auto. }  intros.
change (tt, tt, tt, tt, tt, tt, tt, tt, tt, tt, tt, tt) with (multi_rep 12 tt) in *.

assert (MForall2 (refine_value (xvar_ty D) (xvar_ty A)) (multi_rep 12 tt) (multi_rep 12 tt)).
  { eapply rep_MForall2. constructor. }

on >refine_state_fn, invc.  specialize_refinement.
  repeat find_rewrite. inject_pair.
auto.
Qed.

Lemma refine_state_fn_noxvar_dbl_abs_inv : forall df af,
    refine_state_fn_noxvar Dbl.Dbl Abs.Abs df af ->
    (forall dsv asv dsv' dr asv' ar,
        MForall2 (refine_value _ _) dsv asv ->
        df dsv = (dsv', dr) ->
        af asv = (asv', ar) ->
        MForall2 (refine_value _ _) dsv' asv' /\
        refine_value _ _ dr ar).
inversion 1. auto.
Qed.


From iris.proofmode Require Import tactics monpred.
From iris.base_logic Require Import base_logic.
From iris.base_logic.lib Require Import invariants cancelable_invariants na_invariants.
From iris.prelude Require Import options.

From iris.bi Require Import ascii.

Unset Mangle Names.

(* Remove this and the [Set Printing Raw Literals.] below once we require Coq
8.14. *)
Set Warnings "-unknown-option".

Section base_logic_tests.
  Context {M : ucmra}.
  Implicit Types P Q R : uPred M.

  Lemma test_random_stuff (P1 P2 P3 : nat -> uPred M) :
    |- forall (x y : nat) a b,
      x ≡ y ->
      <#> (uPred_ownM (a ⋅ b) -*
      (exists y1 y2 c, P1 ((x + y1) + y2) /\ True /\ <#> uPred_ownM c) -*
      <#> |> (forall z, P2 z ∨ True -> P2 z) -*
      |> (forall n m : nat, P1 n -> <#> (True /\ P2 n -> <#> (⌜n = n⌝ <-> P3 n))) -*
      |> ⌜x = 0⌝ \/ exists x z, |> P3 (x + z) ** uPred_ownM b ** uPred_ownM (core b)).
  Proof.
    iIntros (i [|j] a b ?) "!> [Ha Hb] H1 #H2 H3"; setoid_subst.
    { iLeft. by iNext. }
    iRight.
    iDestruct "H1" as (z1 z2 c) "(H1&_&#Hc)".
    iPoseProof "Hc" as "foo".
    iRevert (a b) "Ha Hb". iIntros (b a) "Hb {foo} Ha".
    iAssert (uPred_ownM (a ⋅ core a)) with "[Ha]" as "[Ha #Hac]".
    { by rewrite cmra_core_r. }
    iIntros "{$Hac $Ha}".
    iExists (S j + z1), z2.
    iNext.
    iApply ("H3" $! _ 0 with "[$]").
    - iSplit; first done. iApply "H2". iLeft. iApply "H2". by iRight.
    - done.
  Qed.

  Lemma test_iFrame_pure (x y z : M) :
    ✓ x -> ⌜y ≡ z⌝ |-@{uPredI M} ✓ x /\ ✓ x /\ y ≡ z.
  Proof. iIntros (Hv) "Hxy". by iFrame (Hv) "Hxy". Qed.

  Lemma test_iAssert_modality P : (|==> False) -* |==> P.
  Proof. iIntros. iAssert False%I with "[> - //]" as %[]. Qed.

  Lemma test_iStartProof_1 P : P -* P.
  Proof. iStartProof. iStartProof. iIntros "$". Qed.
  Lemma test_iStartProof_2 P : P -* P.
  Proof. iStartProof (uPred _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_3 P : P -* P.
  Proof. iStartProof (uPredI _). iStartProof (uPredI _). iIntros "$". Qed.
  Lemma test_iStartProof_4 P : P -* P.
  Proof. iStartProof (uPredI _). iStartProof (uPred _). iIntros "$". Qed.
End base_logic_tests.

Section iris_tests.
  Context `{!invGS_gen hlc Σ, !cinvG Σ, !na_invG Σ}.
  Implicit Types P Q R : iProp Σ.

  Lemma test_masks  N E P Q R :
    ↑N ⊆ E ->
    (True -* P -* inv N Q -* True -* R) -* P -* |> Q ={E}=* R.
  Proof.
    iIntros (?) "H HP HQ".
    iApply ("H" with "[% //] [$] [> HQ] [> //]").
    by iApply inv_alloc.
  Qed.

  Lemma test_iInv_0 N P: inv N (<pers> P) ={⊤}=* |> P.
  Proof.
    iIntros "#H".
    iInv N as "#H2". Show.
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_0_with_close N P: inv N (<pers> P) ={⊤}=* |> P.
  Proof.
    iIntros "#H".
    iInv N as "#H2" "Hclose". Show.
    iMod ("Hclose" with "H2").
    iModIntro. by iNext.
  Qed.

  Lemma test_iInv_1 N E P:
    ↑N ⊆ E ->
    inv N (<pers> P) ={E}=* |> P.
  Proof.
    iIntros (?) "#H".
    iInv N as "#H2".
    iModIntro. iSplit; auto.
  Qed.

  Lemma test_iInv_2 γ p N P:
    cinv N γ (<pers> P) ** cinv_own γ p ={⊤}=* cinv_own γ p ** |> P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)". Show.
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_2_with_close γ p N P:
    cinv N γ (<pers> P) ** cinv_own γ p ={⊤}=* cinv_own γ p ** |> P.
  Proof.
    iIntros "(#?&?)".
    iInv N as "(#HP&Hown)" "Hclose". Show.
    iMod ("Hclose" with "HP").
    iModIntro. iFrame. by iNext.
  Qed.

  Lemma test_iInv_3 γ p1 p2 N P:
    cinv N γ (<pers> P) ** cinv_own γ p1 ** cinv_own γ p2
      ={⊤}=* cinv_own γ p1 ** cinv_own γ p2  ** |> P.
  Proof.
    iIntros "(#?&Hown1&Hown2)".
    iInv N with "[Hown2 //]" as "(#HP&Hown2)".
    iModIntro. iSplit; auto with iFrame.
  Qed.

  Lemma test_iInv_4 t N E1 E2 P:
    ↑N ⊆ E2 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
         |- |={⊤}=> na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)". Show.
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_4_with_close t N E1 E2 P:
    ↑N ⊆ E2 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
         |- |={⊤}=> na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N as "(#HP&Hown2)" "Hclose". Show.
    iMod ("Hclose" with "[HP Hown2]").
    { iFrame. done. }
    iModIntro. iFrame. by iNext.
  Qed.

  (* test named selection of which na_own to use *)
  Lemma test_iInv_5 t N E1 E2 P:
    ↑N ⊆ E2 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown2" as "(#HP&Hown2)".
    iModIntro. iSplitL "Hown2"; auto with iFrame.
  Qed.

  Lemma test_iInv_6 t N E1 E2 P:
    ↑N ⊆ E1 ->
    na_inv t N (<pers> P) ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2  ** |> P.
  Proof.
    iIntros (?) "(#?&Hown1&Hown2)".
    iInv N with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test robustness in presence of other invariants *)
  Lemma test_iInv_7 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 ->
    inv N1 P ** na_inv t N3 (<pers> P) ** inv N2 P ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2 ** |> P.
  Proof.
    iIntros (?) "(#?&#?&#?&Hown1&Hown2)".
    iInv N3 with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* iInv should work even where we have "inv N P" in which P contains an evar *)
  Lemma test_iInv_8 N : ∃ P, inv N P ={⊤}=* P ≡ True /\ inv N P.
  Proof.
    eexists. iIntros "#H".
    iInv N as "HP". iFrame "HP". auto.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_9 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 ->
    inv N1 P ** na_inv t N3 (<pers> P) ** inv N2 P ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2 ** |> P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" with "Hown1" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by hypothesis name instead of namespace *)
  Lemma test_iInv_10 t N1 N2 N3 E1 E2 P:
    ↑N3 ⊆ E1 ->
    inv N1 P ** na_inv t N3 (<pers> P) ** inv N2 P ** na_own t E1 ** na_own t E2
      ={⊤}=* na_own t E1 ** na_own t E2 ** |> P.
  Proof.
    iIntros (?) "(#?&#HInv&#?&Hown1&Hown2)".
    iInv "HInv" as "(#HP&Hown1)".
    iModIntro. iSplitL "Hown1"; auto with iFrame.
  Qed.

  (* test selection by ident name *)
  Lemma test_iInv_11 N P: inv N (<pers> P) ={⊤}=* |> P.
  Proof.
    let H := iFresh in
    (iIntros H; iInv H as "#H2"). auto.
  Qed.

  (* error messages *)
  Check "test_iInv_12".
  Lemma test_iInv_12 N P: inv N (<pers> P) ={⊤}=* True.
  Proof.
    iIntros "H".
    Fail iInv 34 as "#H2".
    Fail iInv nroot as "#H2".
    Fail iInv "H2" as "#H2".
    done.
  Qed.

  (* test destruction of existentials when opening an invariant *)
  Lemma test_iInv_13 N:
    inv N (∃ (v1 v2 v3 : nat), emp ** emp ** emp) ={⊤}=* |> emp.
  Proof.
    iIntros "H"; iInv "H" as (v1 v2 v3) "(?&?&_)".
    eauto.
  Qed.

  Theorem test_iApply_inG `{!inG Σ A} γ (x x' : A) :
    x' ≼ x ->
    own γ x -* own γ x'.
  Proof. intros. by iApply own_mono. Qed.
End iris_tests.

Section monpred_tests.
  Context `{!invGS_gen hlc Σ}.
  Context {I : biIndex}.
  Local Notation monPred := (monPred I (iPropI Σ)).
  Local Notation monPredI := (monPredI I (iPropI Σ)).
  Implicit Types P Q R : monPred.
  Implicit Types 𝓟 𝓠 𝓡 : iProp Σ.

  Check "test_iInv".
  Lemma test_iInv N E 𝓟 :
    ↑N ⊆ E ->
    ⎡inv N 𝓟⎤ |-@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP". Show.
    iFrame "HP". auto.
  Qed.

  Check "test_iInv_with_close".
  Lemma test_iInv_with_close N E 𝓟 :
    ↑N ⊆ E ->
    ⎡inv N 𝓟⎤ |-@{monPredI} |={E}=> emp.
  Proof.
    iIntros (?) "Hinv".
    iInv N as "HP" "Hclose". Show.
    iMod ("Hclose" with "HP"). auto.
  Qed.

End monpred_tests.

(** Test specifically if certain things parse correctly. *)
Section parsing_tests.
Context {PROP : bi}.
Implicit Types P : PROP.

Lemma test_bi_emp_valid : |-@{PROP} True.
Proof. naive_solver. Qed.

Lemma test_bi_emp_valid_parens : (|-@{PROP} True) /\ ((|-@{PROP} True)).
Proof. naive_solver. Qed.

Lemma test_bi_emp_valid_parens_space_open : ( |-@{PROP} True).
Proof. naive_solver. Qed.

Lemma test_bi_emp_valid_parens_space_close : (|-@{PROP} True ).
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections P :
  (P |-@{PROP} P) /\ (|-@{PROP}) P P /\
  (P -|-@{PROP} P) /\ (-|-@{PROP}) P P.
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections_parens P :
  ((P |-@{PROP} P)) /\ ((|-@{PROP})) P P /\
  ((P -|-@{PROP} P)) /\ ((-|-@{PROP})) P P.
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections_space_open P :
  ( P |-@{PROP} P) /\
  ( P -|-@{PROP} P).
Proof. naive_solver. Qed.

Lemma test_entails_annot_sections_space_close P :
  (P |-@{PROP} P ) /\ (|-@{PROP} ) P P /\
  (P -|-@{PROP} P ) /\ (-|-@{PROP} ) P P.
Proof. naive_solver. Qed.

(* Make sure these all parse as they should.
To make the [Check] print correctly, we need to set and reset the printing
settings each time. *)
Check "p1".
Lemma p1 : forall P, True -> P |- P.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p2".
Lemma p2 : forall P, True /\ (P |- P).
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p3".
Lemma p3 : exists P, P |- P.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p4".
Lemma p4 : |-@{PROP} exists (x : nat), ⌜x = 0⌝.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p5".
Lemma p5 : |-@{PROP} exists (x : nat), ⌜forall y : nat, y = y⌝.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p6".
Lemma p6 : exists! (z : nat), |-@{PROP} exists (x : nat), ⌜forall y : nat, y = y⌝ ** ⌜z = 0⌝.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p7".
Lemma p7 : forall (a : nat), a = 0 -> forall y, True |-@{PROP} ⌜y >= 0⌝.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p8".
Lemma p8 : forall (a : nat), a = 0 -> forall y, |-@{PROP} ⌜y >= 0⌝.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

Check "p9".
Lemma p9 : forall (a : nat), a = 0 -> forall y : nat, |-@{PROP} forall z : nat, ⌜z >= 0⌝.
Proof.
  Unset Printing Notations. Set Printing Raw Literals. Show. Set Printing Notations. Unset Printing Raw Literals.
Abort.

End parsing_tests.


Require Export MicroBFTprops0.
Require Export MicroBFTsubs.
Require Export MicroBFTbreak.
Require Export ComponentSM6.

Section MicroBFTcount.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc                 : DTimeContext          }.
  Context { microbft_context    : MicroBFT_context      }.
  Context { m_initial_keys      : MicroBFT_initial_keys }.
  Context { u_initial_keys      : USIG_initial_keys     }.
  Context { usig_hash           : USIG_hash             }.
  Context { microbft_auth       : MicroBFT_auth         }.

(*
  Lemma accepted_if_executed_previous_step :
    forall {eo  : EventOrdering}
           (e   : Event)
           (req : Request)
           (i   : nat)
           (l   : list name)
           (r   : Rep)
           (s   : MAIN_state)
           (s1  : USIG_state)
           (s2  : LOG_state),
      In (send_accept (accept req i) l)
         (M_output_ls_on_this_one_event (MicroBFTlocalSys_new r s s1 s2) e)
      -> i = S (cexec s).
  Proof.
    introv h.
    apply in_M_output_ls_on_this_one_event_implies in h; exrepnd; simpl in *.
    autorewrite with microbft comp in *.
    Time microbft_dest_msg Case; simpl in *; tcsp; ginv; repeat smash_microbft2;
      repndors; tcsp; inversion h0; subst; GC; eauto 4 with microbft.
  Qed.

  Lemma operation_inc_counter_ls_step :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i     : nat)
           (l     : list name)
           (s     : Rep)
           (ls    : MicroBFTls),
      M_run_ls_before_event (MicroBFTlocalSys s) e = Some ls
      -> In (send_accept (accept r (S i)) l) (M_output_ls_on_this_one_event ls e)
      -> i = 0
         \/
         exists r' l' e' ls',
           e' ⊏ e
           /\ M_run_ls_before_event (MicroBFTlocalSys s) e' = Some ls'
           /\ In (send_accept (accept r' i) l') (M_output_ls_on_this_one_event ls' e').
  Proof.
    introv eqls out.
    applydup M_run_ls_before_event_ls_is_microbft in eqls; exrepnd; subst.
    applydup accepted_if_executed_previous_step in out; ginv.
    clear r l out.
    revert s s0 s1 s2 eqls.

    induction e as [e ind] using predHappenedBeforeInd;[]; introv eqls.
    rewrite M_run_ls_before_event_unroll in eqls.
    destruct (dec_isFirst e) as [d|d]; ginv.

    { inversion eqls; subst; GC; simpl; tcsp. }

    apply map_option_Some in eqls; exrepnd; rev_Some.
    applydup M_run_ls_before_event_ls_is_microbft in eqls1; exrepnd; subst.

    dup eqls1 as eqbef.
    rename eqls1 into eqbef_backup.
    eapply ind in eqbef; eauto 3 with eo;[].

    apply map_option_Some in eqls0; exrepnd; simpl in *; rev_Some.
    autorewrite with microbft comp in *.
    Time microbft_dest_msg Case;
      repeat (autorewrite with microbft comp in *; simpl in *; smash_microbft2);
      try (complete (clear eqbef_backup; repndors; tcsp; [];
                       right; exrepnd; microbft_finish_eexists));
      [|].

    { Case "Commit".

      right.

      applydup invalid_commit_false_implies in Heqx as w.
      apply valid_commit_implies_executed_prior in w.
      apply executed_prior_counter_implies_eq_S in w.

      exists (commit2request c) [MicroBFT_replica s] (local_pred e) (MicroBFTlocalSys_new s s3 s1 s5).
      dands; eauto 3 with eo.

      Time unfold M_output_ls_on_this_one_event; simpl; repeat (allrw; simpl);
        repeat (autorewrite with microbft comp in *; simpl in *; smash_microbft2);
        try (complete (left; try congruence)).
    }

    { Case "Commit".

      right.

      applydup invalid_commit_false_implies in Heqx as w.
      apply valid_commit_implies_executed_prior in w.
      apply executed_prior_counter_implies_eq_S in w.

      exists (commit2request c) [MicroBFT_replica s] (local_pred e) (MicroBFTlocalSys_new s s3 s4 s5).
      dands; eauto 3 with eo.

      Time unfold M_output_ls_on_this_one_event; simpl; repeat (allrw; simpl);
        repeat (autorewrite with microbft comp in *; simpl in *; smash_microbft2);
        try (complete (left; try congruence)).
    }
  Qed.

  Lemma operation_inc_counter_ls :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i1 i2 : nat)
           (l     : list name)
           (s     : Rep)
           (ls    : MicroBFTls),
      M_run_ls_before_event (MicroBFTlocalSys s) e = Some ls
      -> In (send_accept (accept r i2) l) (M_output_ls_on_this_one_event ls e)
      -> i1 < i2
      -> 0 < i1
      -> exists r' l' e' ls',
          e' ⊏ e
          /\ M_run_ls_before_event (MicroBFTlocalSys s) e' = Some ls'
          /\ In (send_accept (accept r' i1) l') (M_output_ls_on_this_one_event ls' e').
  Proof.
    intros eo e r i1 i2; revert e r.
    induction i2; introv eqls out lti lti0; try omega;[].
    apply lt_n_Sm_le in lti.

    eapply operation_inc_counter_ls_step in out; eauto.
    repndors; subst; try omega.
    exrepnd.

    apply le_lt_or_eq in lti; repndors; subst; try (complete microbft_finish_eexists);[].

    eapply IHi2 in out1; eauto; try omega.
    exrepnd.
    exists r'0 l'0 e'0 ls'0; dands; auto; eauto 3 with eo.
  Qed.

  Lemma operation_inc_counter :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i1 i2 : nat)
           (l     : list name),
      is_replica e
      -> In (send_accept (accept r i2) l) (M_output_sys_on_event MicroBFTsys e)
      -> i1 < i2
      -> 0 < i1
      -> exists r' l' e',
          e' ⊏ e
          /\ In (send_accept (accept r' i1) l') (M_output_sys_on_event MicroBFTsys e').
  Proof.
    introv isr h lti lti0.
    unfold M_output_sys_on_event in *.
    unfold MicroBFTsys, is_replica in *; exrepnd.
    rewrite isr0 in *; simpl in *.

    apply M_output_ls_on_event_as_run in h; exrepnd.
    eapply operation_inc_counter_ls in h0; eauto.
    exrepnd.
    applydup local_implies_loc in h2 as eqloc.
    exists r' l' e'; dands; auto.
    rewrite eqloc.
    rewrite isr0.

    apply M_output_ls_on_event_as_run.
    eexists; dands; eauto.
  Qed.

  Lemma accepted_counter_positive :
    forall {eo    : EventOrdering}
           (e     : Event)
           (r     : Request)
           (i     : nat)
           (l     : list name),
      is_replica e
      -> In (send_accept (accept r i) l) (M_output_sys_on_event MicroBFTsys e)
      -> 0 < i.
  Proof.
    introv isrep out.
    unfold M_output_sys_on_event in *.
    unfold MicroBFTsys, is_replica in *; exrepnd.
    rewrite isrep0 in *; simpl in *.
    apply M_output_ls_on_event_implies_run in out; exrepnd.
    applydup M_run_ls_before_event_ls_is_microbft in out1; exrepnd; subst.
    eapply accepted_if_executed_previous_step in out0; subst; omega.
  Qed.
  Hint Resolve accepted_counter_positive : microbft.
*)

  (*Lemma M_output_ls_on_input_is_log_new_implies :
    forall u r v o,
      M_output_ls_on_input (LOGlocalSys u) (log_new r) = (LOGlocalSys v, o)
      -> in_log r v.
  Proof.
    introv out.
    unfold M_output_ls_on_input in out; simpl in *.
    unfold M_run_smat_on_inputs in out; simpl in *.
    unfold M_run_update_on_inputs in out; simpl in *.
    unfold M_break in *; simpl in *; ginv.
    inversion out; auto; simpl; tcsp.
  Qed.*)

  Lemma invalid_request_false_implies_ui2rep_eq :
    forall R r s,
      invalid_commit R r s = false
      -> ui2rep (commit_ui r) = MicroBFT_primary.
  Proof.
    introv inv; unfold invalid_commit, valid_commit, is_primary in *; smash_microbft_2.
  Qed.
  Hint Resolve invalid_request_false_implies_ui2rep_eq : microbft.

  Lemma invalid_request_false_implies_not_primary :
    forall R r s,
      invalid_commit R r s = false
      -> not_primary R = true.
  Proof.
    introv inv; unfold invalid_commit, valid_commit, is_primary in *; smash_microbft_2.
  Qed.
  Hint Resolve invalid_request_false_implies_not_primary : microbft.

  (* This uses compositional reasoning, but using [LOG_comp]'s spec defined in
     [M_output_ls_on_input_is_committed_implies] *)
  Lemma accepted_counter_if_received_UI_primary :
    forall {eo : EventOrdering}
           (e  : Event)
           (R  : MicroBFT_node)
           (r  : nat)
           (i  : nat)
           (l  : list name),
      In (send_accept (accept r i) l) (M_output_ls_on_event (MicroBFTlocalSys R) e)
      ->
      exists (s  : MAIN_state)
             (s1 : USIG_state)
             (s2 : LOG_state)
             (ui : UI)
             (rq : Commit),
        M_run_ls_on_event (MicroBFTlocalSys R) e = Some (MicroBFTlocalSys_new R s s1 s2)
        /\ in_log rq s2
        /\ commit_n rq = r
        /\ commit_ui rq = ui
        /\ ui2counter ui = i
        /\ ui2rep ui = MicroBFT_primary
        /\ not_primary R = true.
  Proof.
    introv h.
    apply M_output_ls_on_event_as_run in h; exrepnd.
    rename ls' into ls.
    rewrite M_run_ls_on_event_unroll2; allrw; simpl.
    applydup M_run_ls_before_event_ls_is_microbft in h1; exrepnd; subst.
    apply in_M_output_ls_on_this_one_event_implies in h0; exrepnd; simpl in *; microbft_simp.
    unfold M_run_ls_on_this_one_event; simpl; allrw; simpl.
    unfold M_run_ls_on_input_ls, M_run_ls_on_input.
    unfold statefund_nm in *; simpl in *.
    autorewrite with microbft comp in *.

    Time microbft_dest_msg Case; simpl in *; tcsp; ginv; repeat smash_microbft_2; ginv.
    eexists; eexists; eexists; eexists; eexists; dands; try reflexivity; eauto 3 with microbft; tcsp.
  Qed.

End MicroBFTcount.

(*
Hint Resolve accepted_counter_positive : microbft.
 *)


Require Export Db.Inst.
Require Export Db.Lemmas.
Require Export Db.WellScoping.

Require Export RecTypes.SpecTypes.

#[export]
#[refine] Instance vrTy : Vr Ty := {| vr := tvar |}.
Proof. inversion 1; auto. Defined.

Local Ltac crush :=
  intros; cbn in * |-;
  repeat
    (cbn;
     repeat crushRecTypesMatchH;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasMatchH;
     rewrite ?comp_up, ?up_liftSub, ?up_comp_lift
    );
  auto.

Module TyKit <: Kit.

  Definition TM := Ty.
  Definition inst_vr := vrTy.

  Section Application.

    Context {Y : Type}.
    Context {vrY : Vr Y}.
    Context {wkY: Wk Y}.
    Context {liftY: Lift Y Ty}.

    #[refine] Global Instance inst_ap : Ap Ty Y := {| ap := apTy |}.
    Proof.
      induction x; crush.
    Defined.

    #[refine] Global Instance inst_ap_vr : LemApVr Ty Y := {}.
    Proof. reflexivity. Qed.

  End Application.

  #[export]
  #[refine] Instance inst_ap_inj: LemApInj Ty Ix := {}.
  Proof.
    intros m Inj_m x. revert m Inj_m.
    induction x; destruct y; simpl; try discriminate;
    inversion 1; subst; f_equal; eauto using InjSubIxUp.
  Qed.

  #[export]
  #[refine] Instance inst_ap_comp (Y Z: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Ty}
    {vrZ: Vr Z} {wkZ: Wk Z} {liftZ: Lift Z Ty}
    {apYZ: Ap Y Z} {compUpYZ: LemCompUp Y Z}
    {apLiftYTmZ: LemApLift Y Z Ty} :
    LemApComp Ty Y Z := {}.
  Proof. induction x; crush. Qed.

  #[export]
  #[refine] Instance inst_ap_liftSub (Y: Type)
    {vrY: Vr Y} {wkY: Wk Y} {liftY: Lift Y Ty} :
    LemApLiftSub Ty Y := {}.
  Proof. induction t; crush. Qed.

  Lemma inst_ap_ixComp (τ: Ty) :
    ∀ (ξ: Sub Ix) (ζ: Sub Ty), τ[ξ][ζ] = τ[⌈ξ⌉ >=> ζ].
  Proof. pose proof up_comp_lift. induction τ; crush. Qed.

End TyKit.

Module InstTy := Inst TyKit.
Export InstTy. (* Export for shorter names. *)

#[export]
Instance wsVrTy: WsVr Ty.
Proof.
  constructor.
  - now constructor.
  - now inversion 1.
Qed.

Section ApplicationTy.

  Context {Y: Type}.
  Context {vrY : Vr Y}.
  Context {wkY: Wk Y}.
  Context {liftY: Lift Y Ty}.
  Context {wsY: Ws Y}.
  Context {wsVrY: WsVr Y}.
  Context {wsWkY: WsWk Y}.
  Context {wsLiftY: WsLift Y Ty}.

  Hint Resolve wsLift : ws.
  Hint Resolve wsSub_up : ws.

  Global Instance wsApTy : WsAp Ty Y.
  Proof.
    constructor.
    - intros ξ γ δ t wξ wt; revert ξ δ wξ.
      induction wt; intros ξ δ wξ; crush;
      try econstructor;
      try match goal with
            | |- wsTy ?δ ?t =>
              change (wsTy δ t) with ⟨ δ ⊢ t ⟩
          end; eauto with ws.
    - intros γ t wt.
      induction wt; crush.
      + apply IHwt; inversion 1; crush.
  Qed.
End ApplicationTy.

#[export]
Instance wsWkTy : WsWk Ty.
Proof.
  constructor; crush.
  - refine (wsAp _ H); eauto.
    constructor; eauto.
Qed.