From ITree Require Import ITree.
Require Import sflib.
Require Import StdlibExt.

Require Import ITreeTac.

Require Import ZArith List Lia.

Import ITreeNotations.

Local Opaque Nat.min.

Set Nested Proofs Allowed.

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

Inductive msg_t: Type :=
| Acquire
| Release
| Grant
.

Inductive sysE: Type -> Type :=
| Demand: sysE nat
| UseRes: sysE unit
| Compl: sysE unit
.

Inductive event: Type :=
| Event (R: Type) (e: sysE R) (r: R).

Inductive ctrl_err: Set :=
  Success | FailBefore | FailAfter.

Definition Tid: Set := nat.

Definition MAX_TOUT: nat := 5.

Inductive sendE: Type -> Type :=
  Send (dest: Tid) (m: msg_t): sendE unit.

Definition msgbox_t: Set := msg_t? * msg_t? * msg_t?.

Definition update_msgbox
           (mbox: msgbox_t)
           (tid: nat) (msg: msg_t)
  : msgbox_t :=
  let '(m1, m2, m3) := mbox in
  match tid with
  | 1 => (Some msg, m2, m3)
  | 2 => (m1, Some msg, m3)
  | 3 => (m1, m2, Some msg)
  | _ => mbox
  end.

Module Ctrl.

  Record t : Type :=
    mk { timeout: nat ;
         queue: list Tid ;
       }.

  Definition init: t := mk O [].

  Definition try_addq (tid: nat) (st: t): t :=
    let 'mk tout q := st in
    if existsb (Nat.eqb tid) q then st
    else mk tout (snoc q tid).

  Definition try_relq (tid: nat) (st: t): t :=
    let 'mk tout q := st in
    if orb (tout =? O) (tout =? MAX_TOUT) then st
    else
      match q with
      | [] => st
      | h :: t =>
        if tid =? h then mk 1 (h :: t) else st
      end.

  Definition apply_msg
             (tid: nat) (msg: msg_t?)
             (st: t)
    : t :=
    match msg with
    | None => st
    | Some m =>
      match m with
      | Acquire => try_addq tid st
      | Release => try_relq tid st
      | _ => st
      end
    end.

  Definition reduce_timeout (st: t): t * bool :=
    match timeout st with
    | O => (st, true)
    | 1 => (mk O (tl (queue st)), false)
    | S (S n) => (mk (S n) (queue st), false)
    end.

  Definition update
             (inb_c: msgbox_t)
             (st: t): t * bool :=
    let '(cm1, cm2, cm3) := inb_c in
    let st1 := apply_msg 1 cm1 st in
    let st2 := apply_msg 2 cm2 st1 in
    let st3 := apply_msg 3 cm3 st2 in
    reduce_timeout st3.

  (* Do this if tout = 0 & queue is nonempty: *)
  (* if tzero_flag is true, ignore cerr *)
  (* if cerr = success, set tout to max & send Grant *)
  (* if cerr = failafter, send Grant *)
  (* if cerr = failbefore, do nothing *)
  Definition send_grant (cerr: ctrl_err) (st: t)
             (tzero_flag: bool)
    : itree (sysE +' sendE) t :=
    if timeout st =? O then
      match queue st with
      | [] => Ret st
      | h :: t =>
        let cerr' :=
            if tzero_flag then Success else cerr in
        match cerr' with
        | FailBefore => Ret st
        | FailAfter =>
          trigger (Send h Grant);;
          Ret (mk 0 (h :: t))
        | Success =>
          trigger (Send h Grant);;
          Ret (mk MAX_TOUT (h :: t))
        end
      end
    else Ret st.

  Definition send_grant_func (cerr: ctrl_err) (st: t)
             (tzero_flag: bool)
    : t * (Tid * msg_t)? :=
    if timeout st =? O then
      match queue st with
      | [] => (st, None)
      | h :: t =>
        let cerr' :=
            if tzero_flag then Success else cerr in
        match cerr' with
        | FailBefore => (st, None)
        | FailAfter =>
          (mk 0 (h :: t), Some (h, Grant))
          (* trigger (Send h Grant);; *)
          (* Ret (mk 0 (h :: t)) *)
        | Success =>
          (* trigger (Send h Grant);; *)
          (* Ret (mk MAX_TOUT (h :: t)) *)
          (mk MAX_TOUT (h :: t), Some (h, Grant))
        end
      end
    else (st, None).

  Definition job (cerr: ctrl_err)
             (inbox: msgbox_t)
             (st: t): itree (sysE +' sendE) t :=
    let (st_upd, tzero_flag) := update inbox st in
    st' <- send_grant cerr st_upd tzero_flag ;;
    Ret st'.
    (* st' <- match new_owner with *)
    (*       | None => Ret st_upd *)
    (*       | Some tid_nown => *)
    (*         match cerr with *)
    (*         | FailBefore => *)
    (*           Ret (set_tout_zero st_upd) *)
    (*         | FailAfter => *)
    (*           trigger (Send tid_nown Grant);; *)
    (*           Ret (set_tout_zero st_upd) *)
    (*         | Success => *)
    (*           trigger (Send tid_nown Grant);; *)
    (*           Ret st_upd *)
    (*         end *)
    (*       end;; *)
    (* trigger Compl;; *)
    (* Ret st'. *)

  Definition job_func (cerr: ctrl_err)
             (inbox: msgbox_t)
             (st: t)
    : t * msgbox_t :=
    let (st_upd, tzero_flag) := update inbox st in
    let (st', om) := send_grant_func
                      cerr st_upd tzero_flag in
    let outbox_i := (None, None, None) in
    let outbox := match om with
                  | None => outbox_i
                  | Some (tid, msg) =>
                    update_msgbox outbox_i tid msg
                  end in
    (st', outbox).

  Inductive run_itree
            (itr: itree (sysE +' sendE) t)
            (out: msgbox_t)
    : list event -> t -> msgbox_t -> Prop :=
  | RunITree_Ret
      st'
      (OBS_RET: observe itr = RetF st')
    : run_itree itr out [] st' out
  | RunITree_Tau
      itr' es st' out'
      (OBS_TAU: observe itr = TauF itr')
      (RUN_REST: run_itree itr' out es st' out')
    : run_itree itr out es st' out'
  | RunITree_SysEvt
      R (syse: sysE R) (k: R -> itree _ t) (r: R)
      e es st' out'
      (OBS_EVT: observe itr = VisF (inl1 syse) k)
      (RUN_REST: run_itree (k r) out es st' out')
      (EVENT: e = Event _ syse r)
    : run_itree itr out (e :: es) st' out'
  | RunITree_Send
      tid msg (k: unit -> itree _ t)
      out_upd es st' out'
      (OBS_EVT: observe itr = VisF (inr1 (Send tid msg)) k)
      (UPDATE_OUTBOX: out_upd = update_msgbox
                                  out tid msg)
      (RUN_REST: run_itree (k tt) out_upd es st' out')
    : run_itree itr out es st' out'
  .

  Lemma run_itree_func
        cerr inb st es st' out
        (RUN: run_itree (job cerr inb st)
                        (None, None, None) es st' out)
    : <<CTRL_SILENT: es = []>> /\
      <<JOB_FUNC: job_func cerr inb st = (st', out)>>.
  Proof.
    unfold job in RUN.
    unfold job_func.

    assert (AUX1: exists st_upd tzero_flag,
               update inb st = (st_upd, tzero_flag)).
    { esplits. eapply surjective_pairing. }
    des.
    rewrite AUX1 in *.

    destruct st_upd as [tout q].
    unfold send_grant in RUN.
    unfold send_grant_func.
    ss.

    destruct  (Nat.eqb_spec tout 0); ss.
    2: {
      simpl_itree_hyp RUN.
      inv RUN; ss.
      clarify.
    }

    destruct q as [| qh qt].
    { simpl_itree_hyp RUN.
      inv RUN; ss. clarify. }
    { destruct tzero_flag; ss.
      - simpl_itree_hyp RUN.
        simpl_itree_hyp RUN.
        inv RUN; ss.
        clarify. existT_elim. subst.
        simpl_itree_hyp RUN_REST.

        inv RUN_REST; ss. clarify.
      - simpl_itree_hyp RUN.
        destruct cerr.
        + simpl_itree_hyp RUN.
          inv RUN; ss.
          clarify. existT_elim. subst.
          inv RUN_REST; ss.
          clarify.
        + inv RUN; ss.
          clarify.
        + simpl_itree_hyp RUN.
          inv RUN; ss.
          clarify. existT_elim. subst.
          inv RUN_REST; ss.
          clarify.
    }
  Qed.

  Inductive step (inb: msgbox_t)
    : t -> list event -> t -> msgbox_t -> Prop :=
  | Step
      (cerr: ctrl_err)
      st es st' out
      (RUN_ITREE: run_itree (job cerr inb st)
                            (None, None, None)
                            es st' out)
    : step inb st es st' out
  .

End Ctrl.

Module Dev.
  Inductive t: Type :=
  | Init
  | Running (is_owner: bool) (demand: nat)
  .

  Definition update_ownership
             (inb: msg_t?) (is_owner: bool): bool :=
    match inb with
    | None => is_owner
    | Some m =>
      match m with
      | Grant => true
      | _ => is_owner
      end
    end.

  Definition update_demand (dmd: nat)
    : itree (sysE +' sendE) (nat * bool) :=
    if dmd =? O then
      dmd' <- trigger Demand;;
      Ret (Nat.min MAX_TOUT dmd', true)
    else Ret (dmd, false).

  Definition use_res (own: bool) (dmd: nat)
    : itree (sysE +' sendE) nat :=
    if andb own (0 <? dmd) then
      trigger UseRes;; Ret (pred dmd)
    else Ret dmd.

  Definition send_msg (own: bool) (dmd: nat) (dupd: bool)
    : itree (sysE +' sendE) bool :=
    if andb own (dmd =? O) then
      trigger (Send 0 Release);; Ret false
    else
      if andb (negb own) (andb (0 <? dmd) dupd) then
        trigger (Send 0 Acquire);; Ret own
       else Ret own.

  Definition job
             (inbox: msg_t?) (st: t)
    : itree (sysE +' sendE) t :=
    match st with
    | Init =>
      trigger (Send 0 Release) ;;
      Ret (Running false 0)
    | Running is_owner dmd =>
      let is_owner1 := update_ownership inbox is_owner in
      '(dmd1, dmd_upd) <- update_demand dmd ;;
      dmd' <- use_res is_owner1 dmd1 ;;
      is_owner'<- send_msg is_owner1 dmd' dmd_upd ;;
      trigger Compl ;;
      Ret (Running is_owner' dmd')
    end.

  Inductive run_itree
            (itr: itree (sysE +' sendE) t)
            (out: msg_t?)
    : list event -> t? -> msg_t? -> Prop :=
  | RunITree_Fail
    : run_itree itr out [] None out
  | RunITree_Ret
      st'
      (OBS_RET: observe itr = RetF st')
    : run_itree itr out [] (Some st') out
  | RunITree_Tau
      itr' es ost' out'
      (OBS_TAU: observe itr = TauF itr')
      (RUN_REST: run_itree itr' out es ost' out')
    : run_itree itr out es ost' out'
  | RunITree_SysEvt
      R (syse: sysE R) (k: R -> itree _ t) (r: R)
      e es ost' out'
      (OBS_EVT: observe itr = VisF (inl1 syse) k)
      (RUN_REST: run_itree (k r) out es ost' out')
      (EVENT: e = Event _ syse r)
    : run_itree itr out (e :: es) ost' out'
  | RunITree_Send
      tid msg (k: unit -> itree _ t)
      es ost' out'
      (OBS_EVT: observe itr = VisF (inr1 (Send tid msg)) k)
      (RUN_REST: run_itree (k tt) (Some msg) es ost' out')
    : run_itree itr out es ost' out'
  .

  Lemma job_dzero_ngrant_cases
        es ost' out
        (RUN: run_itree (job None (Running false 0))
                        None es ost' out)
    : <<FAILED: es = [] /\ out = None /\ ost' = None>>
        \/
      <<DEMAND_FAILED: exists dmd',
        es = [Event _ Demand dmd'] /\
        out = None /\ ost' = None>>
        \/
      <<DEMAND_ZERO_SUCC:
        es = [Event _ Demand 0; Event _ Compl tt] /\
        out = None /\
        option_rel1 (fun st => st = Running false 0) ost'>>
        \/
      <<DEMAND_ACQ_FAILED: exists dmd',
          0 < dmd' /\
          es = [Event _ Demand dmd'] /\
          out = Some Acquire /\ ost' = None>> \/
      <<DEMAND_ACQ_SUCC: exists dmd',
          0 < dmd' /\
          es = [Event _ Demand dmd'; Event _ Compl tt] /\
          out = Some Acquire /\
          option_rel1 (fun st => st = Running false
                                           (Nat.min MAX_TOUT dmd')) ost'>>
  .
  Proof.
      unfold job in RUN.
      unfold update_demand in RUN.
      rewrite Nat.eqb_refl in RUN.
      simpl_itree_hyp RUN.
      simpl_itree_hyp RUN.

      inv RUN; ss.
      { left. eauto. }

      clarify. existT_elim. subst.
      rename RUN_REST into RUN.
      simpl_itree_hyp RUN.
      unfold use_res in RUN. ss.
      simpl_itree_hyp RUN.
      unfold send_msg in RUN. ss.

      pose (dmd_trim := Nat.min MAX_TOUT r).
      fold dmd_trim in RUN.

      destruct (Nat.ltb_spec 0 dmd_trim); ss.
      2: {
        assert (r = 0).
        { subst dmd_trim.
          destruct r; ss.
          exfalso. unfold MAX_TOUT in *. nia.
        }
        subst r.

        simpl_itree_hyp RUN.
        simpl_itree_hyp RUN.
        inv RUN; ss.
        { right. left. eauto. }

        clarify. existT_elim. subst.
        inv RUN_REST; ss.
        { right. right. left.
          esplits; eauto.
          destruct r; ss. }

        clarify.
        destruct r; ss.

        right. right. left.
        esplits; eauto.
      }

      assert (0 < r).
      { subst dmd_trim.
        destruct r; ss. nia. }

      simpl_itree_hyp RUN.
      simpl_itree_hyp RUN.
      inv RUN; ss.
      { right. left. eauto. }

      clarify. existT_elim. subst.
      rename RUN_REST into RUN.
      simpl_itree_hyp RUN.
      simpl_itree_hyp RUN.

      inv RUN; ss.
      { right. right. right. left.
        esplits; eauto. }

      clarify. existT_elim. subst.
      destruct r0; ss.

      inv RUN_REST; ss.
      { right. right. right. right.
        esplits; eauto. }

      clarify.
      right. right. right. right.
      esplits; eauto.
  Qed.

  Lemma job_dzero_grant_cases
        es ost' out
        (RUN: run_itree (job (Some Grant) (Running false 0))
                        None es ost' out)
    : <<FAILED: es = [] /\ out = None /\ ost' = None>>
        \/
      <<DEMAND_FAILED: exists dmd',
        es = [Event _ Demand dmd'] /\
        out = None /\ ost' = None>>
        \/
      <<DEMAND_ZERO_REL:
        es = [Event _ Demand 0] /\
        out = Some Release /\
        ost' = None>>
        \/
      <<DEMAND_ZERO_SUCC:
        es = [Event _ Demand 0; Event _ Compl tt] /\
        out = Some Release /\
        option_rel1 (fun st => st = Running false 0) ost'>>
        \/
      <<DEMAND_USE_FAILED: exists dmd',
          0 < dmd' /\
          es = [Event _ Demand dmd'; Event _ UseRes tt] /\
          out = None /\ ost' = None>> \/
      <<DEMAND_USE_FAILED: exists dmd',
          0 < dmd' /\
          es = [Event _ Demand dmd'; Event _ UseRes tt] /\
          out = None /\ ost' = None>> \/
      <<DEMAND_ACQ_SUCC: exists dmd',
          0 < dmd' /\
          es = [Event _ Demand dmd'; Event _ Compl tt] /\
          out = Some Acquire /\
          option_rel1 (fun st => st = Running false
                                           (Nat.min MAX_TOUT dmd')) ost'>>
  .
  Proof.

  Inductive step (inbox: msg_t?)
    : t? -> list event -> t? -> msg_t? -> Prop :=
  | Step_Fail st
    : step inbox st [] None None
  | Step_Init
    : step inbox None [] (Some Init) None
  | Step_Run
      st es ost' out
      (RUN: run_itree (job inbox st)
                      None es ost' out)
    : step inbox (Some st) es ost' out
  .

End Dev.

Module Sys.
  Record t: Set :=
    mk { time: nat ;
         inbox_controller: msgbox_t ;
         controller: Ctrl.t ;

         inbox_device1: msg_t? ;
         device1: Dev.t? ;
         inbox_device2: msg_t? ;
         device2: Dev.t? ;
         inbox_device3: msg_t? ;
         device3: Dev.t? ;
       }.

  Definition sys_trace_t: Type :=
    list (nat * event) *
    list (nat * event) *
    list (nat * event) *
    list (nat * event).

  Inductive step: t -> sys_trace_t -> t -> Prop :=
    Step
      tm inbc ctrl
      dm1 dev1 dm2 dev2 dm3 dev3
      es_c ctrl' dm1' dm2' dm3'
      es_d1 dev1' cm1'
      es_d2 dev2' cm2'
      es_d3 dev3' cm3'
      inbc' tr
      (STEP_C: Ctrl.step inbc ctrl es_c ctrl'
                         (dm1', dm2', dm3'))
      (STEP_D1: Dev.step dm1 dev1 es_d1 dev1' cm1')
      (STEP_D2: Dev.step dm2 dev2 es_d2 dev2' cm2')
      (STEP_D3: Dev.step dm3 dev3 es_d3 dev3' cm3')
      (INB_CTRL': inbc' = (cm1', cm2', cm3'))
      (TRACE: tr = (map (fun x => (tm, x)) es_c ,
                    map (fun x => (tm, x)) es_d1 ,
                    map (fun x => (tm, x)) es_d2 ,
                    map (fun x => (tm, x)) es_d3))
    : step (mk tm inbc ctrl
               dm1 dev1 dm2 dev2 dm3 dev3)
           tr
           (mk (S tm) inbc' ctrl'
               dm1' dev1' dm2' dev2' dm3' dev3').

  Definition init: t :=
    mk O (None, None, None) Ctrl.init
       None None None None None None.

  Inductive state_trace
    : t -> sys_trace_t -> t -> Prop :=
  | StateTrace_Base st
    : state_trace st ([], [], [], []) st

  | StateTrace_Step
      st tr1 tr2 tr3 tr4 st1
      tr1' tr2' tr3' tr4' st'
      str
      (STEP: step st (tr1, tr2, tr3, tr4) st1)
      (REST: state_trace st1 (tr1', tr2', tr3', tr4') st')
      (TRACES: str = (tr1 ++ tr1', tr2 ++ tr2',
                      tr3 ++ tr3', tr4 ++ tr4'))
    : state_trace st str st'
  .

End Sys.

Section PF.

  Definition wf_queue (q: list nat): Prop :=
    <<NODUP_Q: NoDup q >> /\
    <<VALID_IDS: Forall (fun x => 1 <= x <= 3) q>>.

  Inductive tout_grant_rel: nat -> msg_t? -> Prop :=
  | TOutGrant_MaxSent
    : tout_grant_rel MAX_TOUT (Some Grant)
  | TOutGrant_ZeroSent
    : tout_grant_rel 0 (Some Grant)
  | TOutGrant_ZeroNotSent
    : tout_grant_rel 0 None
  .

  Inductive dms_inv: nat -> list Tid -> msgbox_t -> Prop :=
  | DMSInv_NoMsgs
      tout q
      (NO_MSGS_COND: q = [] \/ (0 < tout < MAX_TOUT))
    : dms_inv tout q (None, None, None)

  | DMSInv_Dev1
      tout q' dm1
      (DM1: tout_grant_rel tout dm1)
    : dms_inv tout (1::q') (dm1, None, None)
  | DMSInv_Dev2
      tout q' dm2
      (DM2: tout_grant_rel tout dm2)
    : dms_inv tout (2::q') (None, dm2, None)
  | DMSInv_Dev3
      tout q' dm3
      (DM3: tout_grant_rel tout dm3)
    : dms_inv tout (3::q') (None, None, dm3)
  .

  Inductive ctrl_inv: Ctrl.t -> msgbox_t -> Prop :=
    CtrlInv
      tout q dms
      (RANGE_TOUT: 0 <= tout <= MAX_TOUT)
      (WF_Q: wf_queue q)
      (EMPTY_QUEUE_TOUT_ZERO: length q = 0 -> tout = 0)
      (DMS_INV: dms_inv tout q dms)
    : ctrl_inv (Ctrl.mk tout q) dms.

  Inductive dev_inv (tid: Tid) (ctrl: Ctrl.t)
    : Dev.t? -> msg_t? -> Prop :=
  | DevInv_Off cm
    : dev_inv tid ctrl None cm
  | DevInv_Init
    : dev_inv tid ctrl (Some Dev.Init) None
  | DevInv_NotOwnerWithDemand
      dmd cm
      (QHD_NEQ: hd_error (Ctrl.queue ctrl) = Some tid ->
                Ctrl.timeout ctrl = 0 \/
                Ctrl.timeout ctrl = MAX_TOUT)
      (DMD_POS: 0 < dmd <= MAX_TOUT)
      (CM_CASES: cm = None \/ cm = Some Acquire)
      (CTRL_KNOWS_DEMAND: In tid (Ctrl.queue ctrl) \/
                          cm = Some Acquire)
    : dev_inv tid ctrl
              (Some (Dev.Running false dmd)) cm
  | DevInv_NotOwnerWithoutDemand
      cm
      (QHD_REL: hd_error (Ctrl.queue ctrl) = Some tid ->
                0 < Ctrl.timeout ctrl < MAX_TOUT ->
                cm = Some Release)
      (CM_CASES: cm = None \/ cm = Some Release)
    : dev_inv tid ctrl
              (Some (Dev.Running false 0)) cm
  | DevInv_Owner
      dmd
      (DMD_POS: 0 < dmd < MAX_TOUT)
      (DMD_LE_TOUT:dmd <= Ctrl.timeout ctrl)
      (QHD_EQ: hd_error (Ctrl.queue ctrl) = Some tid)
    : dev_inv tid ctrl
              (Some (Dev.Running true dmd)) None
  .

  Inductive sys_inv: Sys.t -> Prop :=
    SysInv
      tm cm1 cm2 cm3 ctrl
      dm1 dev1 dm2 dev2 dm3 dev3
      (INV_CTRL: ctrl_inv ctrl (dm1, dm2, dm3))
      (INV_DEV1: dev_inv 1 ctrl dev1 cm1)
      (INV_DEV2: dev_inv 2 ctrl dev2 cm2)
      (INV_DEV3: dev_inv 3 ctrl dev3 cm3)
    : sys_inv (Sys.mk tm (cm1, cm2, cm3) ctrl
                      dm1 dev1 dm2 dev2 dm3 dev3).

  Lemma sys_inv_init
    : sys_inv Sys.init.
  Proof.
    econs.
    - econs; ss.
      { nia. }
      { r. splits.
        - econs.
        - econs.
      }
      { econs 1. eauto. }
    - econs 1.
    - econs 1.
    - econs 1.
  Qed.

  (* Lemma ctrl_inv_prsv *)
  (*       ctrl dms cms *)
  (*       es ctrl' dms' *)
  (*       (INV: ctrl_inv ctrl dms) *)
  (*       (STEP: Ctrl.step cms *)
  (*                        ctrl es ctrl' dms') *)
  (*   : ctrl_inv ctrl' dms'. *)
  (* Proof. *)
  (*   inv INV. *)
  (*   inv STEP. *)
  (* Admitted. *)

  (* Lemma new_owner_timeout_aux1 *)
  (*       tid cerr ms tout q *)
  (*       ctrl' ms' *)
  (*       (* (IF_QHD_TOUT_ZERO: hd_error q = Some tid -> tout = 0) *) *)
  (*       (QHD_NEQ: hd_error q <> Some tid) *)
  (*       (JOB_FUNC: Ctrl.job_func cerr ms (Ctrl.mk tout q) = (ctrl', ms')) *)
  (*       (QHD': hd_error (Ctrl.queue ctrl') = Some tid) *)
  (*   : Ctrl.timeout ctrl' = 0 \/ *)
  (*     Ctrl.timeout ctrl' = MAX_TOUT. *)
  (* Proof. *)
  (*   unfold Ctrl.job_func in *. *)
  (* Admitted. *)

  (* Lemma new_owner_timeout_aux2 *)
  (*       tid cerr ms tout q *)
  (*       ctrl' ms' *)
  (*       (* (IF_QHD_TOUT_ZERO: hd_error q = Some tid -> tout = 0) *) *)
  (*       (QHD_NEQ: hd_error q = Some tid) *)
  (*       (TIMEOUT: tout = 0) *)
  (*       (JOB_FUNC: Ctrl.job_func cerr ms (Ctrl.mk tout q) = (ctrl', ms')) *)
  (*   : hd_error (Ctrl.queue ctrl') = Some tid /\ *)
  (*     Ctrl.timeout ctrl' = MAX_TOUT. *)
  (* Proof. *)
  (* Admitted. *)

  Lemma inv_prsv_each_dev
        (tid: Tid) (ctrl: Ctrl.t) (dev: Dev.t?)
        (cm cm1 cm2 cm3: msg_t?)
        (dm dm1 dm2 dm3: msg_t?)
        es_c ctrl'
        dm1' dm2' dm3'
        es_d dev' cm'
        (DEV_CASES:
           (tid = 1 /\ cm = cm1 /\ dm = dm1) \/
           (tid = 2 /\ cm = cm2 /\ dm = dm2) \/
           (tid = 3 /\ cm = cm3 /\ dm = dm3))
        (INV_CTRL: ctrl_inv ctrl (dm1, dm2, dm3))
        (INV_DEV: dev_inv tid ctrl dev cm)
        (STEP_C : Ctrl.step (cm1, cm2, cm3)
                            ctrl es_c ctrl'
                            (dm1', dm2', dm3'))
        (STEP_D : Dev.step dm dev es_d dev' cm')
    : <<INV_CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')>> /\
      <<INV_DEV': dev_inv tid ctrl' dev' cm'>>.
  Proof.
    des; ss.
    - subst.
      inv INV_CTRL.
      inv INV_DEV.
      + (* dev none *)
        assert (CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')).
        { admit. }
        des.

        inv STEP_D.
        { splits.
          2: { econs 1. }
          eauto.
        }
        { splits.
          2: { econs 2. }
          eauto.
        }
      + (* init *)
        assert (CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')).
        { admit. }

        inv STEP_D.
        { splits.
          2: { econs 1. }
          eauto.
        }
        { inv RUN; ss.
          { splits.
            2: { econs 1. }
            eauto.
          }

          unfold Dev.job in OBS_EVT.
          simpl_itree_hyp OBS_EVT.
          ss. clarify. existT_elim. subst.
          rename RUN_REST into RUN.
          inv RUN; ss.
          { esplits.
            2: { econs 1. }
            eauto.
          }

          clarify.
          splits.
          2: { econs 4; eauto. }
          eauto.
        }
      + (* not_owner with_demand *)
        guardH CM_CASES. ss.
        guardH CTRL_KNOWS_DEMAND.

        assert (<<CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')>> /\
                <<IN_Q': In 1 (Ctrl.queue ctrl')>>).
                (* <<QHD': hd_error q = Some 1 /\ tout = 0 -> *)
                (*       hd_error (Ctrl.queue ctrl') = Some 1 /\ tout = MAX_TOUT>>). *)
        { admit. }
        des.

        splits; ss.
        inv STEP_D.
        { econs. }

        unfold Dev.job in RUN.
        unfold Dev.update_demand in RUN.

        destruct (Nat.eqb_spec dmd 0).
        { exfalso. nia. }

        unfold Dev.use_res in RUN.
        simpl_itree_hyp RUN.

        assert (DM_CASES: dm1 = None \/ dm1 = Some Grant).
        { inv DMS_INV; ss; eauto.
          inv DM1; eauto. }
        desH DM_CASES.
        { subst dm1.
          unfold Dev.send_msg in RUN.
          simpl in RUN.
          simpl_itree_hyp RUN.
          rewrite Bool.andb_false_r in RUN.
          simpl_itree_hyp RUN.
          simpl_itree_hyp RUN.

          inv RUN; ss.
          { econs. }

          clarify. existT_elim. subst.
          inv RUN_REST; ss.
          { econs 1. }
          clarify.

          econs 3; eauto.

          assert (IF_QHD_TOUT_ZERO:
                    hd_error q = Some 1 -> tout = 0).
          { intro HD.
            inv DMS_INV; ss.
            - desH NO_MSGS_COND; ss.
              + subst q. ss.
              + exfalso.
                hexploit QHD_NEQ; eauto. nia.
            - inv DM1. ss.
          }
          (* from DMS_INV *)
          intro QHD'.

          inv STEP_C.
          hexploit Ctrl.run_itree_func; eauto.
          intro AUX1. desH AUX1. subst.

          (* eapply new_owner_timeout_aux; eauto. *)
          admit.
        }
        { (* dm1 = Some Grant *)
          subst dm1.
          ss.

          assert (QHD_EQ: hd_error q = Some 1).
          { inv DMS_INV.
            inv DM1; ss. }

          destruct (Nat.ltb_spec 0 dmd); ss.
          2: { nia. }
          simpl_itree_hyp RUN.
          simpl_itree_hyp RUN.

          inv RUN; ss.
          { econs. }
          clarify. existT_elim. subst.

          simpl_itree_hyp RUN_REST.
          unfold Dev.send_msg in RUN_REST. ss.

          destruct (pred dmd) as [| dmd'] eqn:DMD'; ss.
          - simpl_itree_hyp RUN_REST.
            simpl_itree_hyp RUN_REST.
            rename RUN_REST into RUN.
            inv RUN; ss.
            { econs. }
            clarify. existT_elim. subst.

            simpl_itree_hyp RUN_REST.
            simpl_itree_hyp RUN_REST.
            rename RUN_REST into RUN.
            inv RUN; ss.
            { econs 1. }

            clarify. existT_elim. subst.
            inv RUN_REST; ss.
            { econs 1. }
            clarify.
            econs 4; eauto.

          - simpl_itree_hyp RUN_REST.
            simpl_itree_hyp RUN_REST.
            rename RUN_REST into RUN.
            inv RUN; ss.
            { econs 1. }
            clarify. existT_elim. subst.
            inv RUN_REST; ss.
            { econs 1. }
            clarify.

            assert (CASES': hd_error (Ctrl.queue ctrl') = Some 1 /\
                    ((Ctrl.timeout ctrl') = MAX_TOUT \/
                     (Ctrl.timeout ctrl') = pred MAX_TOUT)).
            { admit. }
            desH CASES'.
            { econs 5; eauto.
              nia. }
            { econs 5; eauto.
              nia. }
        }

      + (* not owner, without_demand *)
        guardH CM_CASES. ss.

        assert (<<CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')>> /\
                <<IF_QHD_EQ': hd_error (Ctrl.queue ctrl') = Some 1 ->
                              Ctrl.timeout ctrl' = 0 \/
                              Ctrl.timeout ctrl' = MAX_TOUT>>).
        { admit. }
        des.

        splits; ss.
        inv STEP_D.
        { econs. }

        unfold Dev.job in RUN.
        unfold Dev.update_demand in RUN.
        rewrite Nat.eqb_refl in RUN.
        simpl_itree_hyp RUN.
        simpl_itree_hyp RUN.

        inv RUN; ss.
        { econs 1. }

        destruct dm1 as [m|].
        * (* grant *)
          clarify. existT_elim. subst.

          inv DMS_INV.
          assert (TOUT_CASES: m = Grant /\
                              (tout = 0 \/ tout = MAX_TOUT)).
          { inv DM1; eauto. }
          destruct TOUT_CASES as [? TOUT_CASES].
          subst m. guardH TOUT_CASES.
          clear DM1. ss.

          rename RUN_REST into RUN.
          simpl_itree_hyp RUN.
          unfold Dev.use_res in RUN. ss.

          pose (dmd' := Nat.min MAX_TOUT r).
          fold dmd' in RUN.

          destruct (Nat.ltb_spec 0 dmd').
          {

          guardH TOUT_CASES.

        TODO

        assert (DM_CASES: dm1 = None \/ dm1 = Some Grant).
        { inv DMS_INV; ss; eauto.
          inv DM1; eauto. }
        desH DM_CASES.
        { subst dm1.
          unfold Dev.send_msg in RUN.
          simpl in RUN.
          simpl_itree_hyp RUN.
          rewrite Bool.andb_false_r in RUN.
          simpl_itree_hyp RUN.
          simpl_itree_hyp RUN.

          inv RUN; ss.
          { econs. }

          clarify. existT_elim. subst.
          inv RUN_REST; ss.
          { econs 1. }
          clarify.

          econs 3; eauto.

          assert (IF_QHD_TOUT_ZERO:
                    hd_error q = Some 1 -> tout = 0).
          { intro HD.
            inv DMS_INV; ss.
            - desH NO_MSGS_COND; ss.
              + subst q. ss.
              + exfalso.
                hexploit QHD_NEQ; eauto. nia.
            - inv DM1. ss.
          }
          (* from DMS_INV *)
          intro QHD'.

          inv STEP_C.
          hexploit Ctrl.run_itree_func; eauto.
          intro AUX1. desH AUX1. subst.

          (* eapply new_owner_timeout_aux; eauto. *)
          admit.
        }
        { (* dm1 = Some Grant *)
          subst dm1.
          ss.

          assert (QHD_EQ: hd_error q = Some 1).
          { inv DMS_INV.
            inv DM1; ss. }

          destruct (Nat.ltb_spec 0 dmd); ss.
          2: { nia. }
          simpl_itree_hyp RUN.
          simpl_itree_hyp RUN.

          inv RUN; ss.
          { econs. }
          clarify. existT_elim. subst.

          simpl_itree_hyp RUN_REST.
          unfold Dev.send_msg in RUN_REST. ss.

          destruct (pred dmd) as [| dmd'] eqn:DMD'; ss.
          - simpl_itree_hyp RUN_REST.
            simpl_itree_hyp RUN_REST.
            rename RUN_REST into RUN.
            inv RUN; ss.
            { econs. }
            clarify. existT_elim. subst.

            simpl_itree_hyp RUN_REST.
            simpl_itree_hyp RUN_REST.
            rename RUN_REST into RUN.
            inv RUN; ss.
            { econs 1. }

            clarify. existT_elim. subst.
            inv RUN_REST; ss.
            { econs 1. }
            clarify.
            econs 4. eauto.

          - simpl_itree_hyp RUN_REST.
            simpl_itree_hyp RUN_REST.
            rename RUN_REST into RUN.
            inv RUN; ss.
            { econs 1. }
            clarify. existT_elim. subst.
            inv RUN_REST; ss.
            { econs 1. }
            clarify.

            assert (CASES': hd_error (Ctrl.queue ctrl') = Some 1 /\
                    ((Ctrl.timeout ctrl') = MAX_TOUT \/
                     (Ctrl.timeout ctrl') = pred MAX_TOUT)).
            { admit. }
            desH CASES'.
            { econs 5; eauto.
              nia. }
            { econs 5; eauto.
              nia. }
        }

    }

        desH CM_CASES.
        * subst cm1.
          desH CTRL_KNOWS_DEMAND; ss.

          assert (<<CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')>> /\
                  <<IN_Q': In 1 (Ctrl.queue ctrl')>>).
          { admit. }
          des.

          splits; ss.
          inv STEP_D.
          { econs. }

          unfold Dev.job in RUN.
          unfold Dev.update_demand in RUN.

          destruct (Nat.eqb_spec dmd 0).
          { exfalso. nia. }

          unfold Dev.use_res in RUN.
          simpl_itree_hyp RUN.

          assert (DM_CASES: dm1 = None \/ dm1 = Some Grant).
          { admit. }
          desH DM_CASES.
          { subst dm1.
            unfold Dev.send_msg in RUN.
            simpl in RUN.
            simpl_itree_hyp RUN.
            rewrite Bool.andb_false_r in RUN.
            simpl_itree_hyp RUN.
            simpl_itree_hyp RUN.

            inv RUN; ss.
            { econs. }

            clarify. existT_elim. subst.
            inv RUN_REST; ss.
            { econs 1. }
            clarify.

            econs 3; eauto.

            assert (hd_error q = Some 1 -> tout = 0).
            { intro HD.
              inv DMS_INV; ss.
              - des; ss.
                + subst q. ss.
                + hexploit QHD_NEQ; eauto. nia.
              - inv DM1. ss.
            }
            (* from DMS_INV *)
            admit. (* if tout = 0, nxt timeout should be MAX_TOUT *)
          }
          { (* dm1 = Some Grant *)
            subst dm1.
            ss.

            assert (QHD_EQ: hd_error q = Some 1).
            { inv DMS_INV.
              inv DM1; ss. }

            destruct (Nat.ltb_spec 0 dmd); ss.
            2: { nia. }
            simpl_itree_hyp RUN.
            simpl_itree_hyp RUN.

            inv RUN; ss.
            { econs. }
            clarify. existT_elim. subst.

            simpl_itree_hyp RUN_REST.
            unfold Dev.send_msg in RUN_REST. ss.

            destruct (pred dmd) as [| dmd'] eqn:DMD'; ss.
            - simpl_itree_hyp RUN_REST.
              simpl_itree_hyp RUN_REST.
              rename RUN_REST into RUN.
              inv RUN; ss.
              { econs. }
              clarify. existT_elim. subst.

              simpl_itree_hyp RUN_REST.
              simpl_itree_hyp RUN_REST.
              rename RUN_REST into RUN.
              inv RUN; ss.
              { econs 1. }

              clarify. existT_elim. subst.
              inv RUN_REST; ss.
              { econs 1. }
              clarify.
              econs 4. eauto.

            - simpl_itree_hyp RUN_REST.
              simpl_itree_hyp RUN_REST.
              rename RUN_REST into RUN.
              inv RUN; ss.
              { econs 1. }
              clarify. existT_elim. subst.
              inv RUN_REST; ss.
              { econs 1. }
              clarify.

              assert (hd_error (Ctrl.queue ctrl') = Some 1 /\
                      ((Ctrl.timeout ctrl') = MAX_TOUT \/
                       (Ctrl.timeout ctrl') = pred MAX_TOUT)).
              { admit. }
              des.
              { econs 5; eauto.
                nia. }
              { econs 5; eauto.
                nia. }
          }

        * (* cm1 is Acquire *)
          subst cm1. ss.
          clear CTRL_KNOWS_DEMAND.

          assert (CTRL': ctrl_inv ctrl' (dm1', dm2', dm3')).
          { admit. }

          splits; eauto.

          inv STEP_D.
          { econs 1. }

          unfold Dev.job in RUN.
          unfold Dev.update_demand in RUN.

          destruct (Nat.eqb_spec dmd 0).
          { exfalso. nia. }

          unfold Dev.use_res in RUN.
          simpl_itree_hyp RUN.

          assert (DM_CASES: dm1 = None \/ dm1 = Some Grant).
          { admit. }
          desH DM_CASES.
          { subst dm1.
            unfold Dev.send_msg in RUN.
            simpl in RUN.
            simpl_itree_hyp RUN.
            rewrite Bool.andb_false_r in RUN.
            simpl_itree_hyp RUN.
            simpl_itree_hyp RUN.

            inv RUN; ss.
            { econs. }

            clarify. existT_elim. subst.
            inv RUN_REST; ss.
            { econs 1. }
            clarify.

            econs 3; eauto.

            assert (hd_error q = Some 1 -> tout = 0).
            { intro HD.
              inv DMS_INV; ss.
              - des; ss.
                + subst q. ss.
                + hexploit QHD_NEQ; eauto. nia.
              - inv DM1. ss.
            }
            (* from DMS_INV *)
            admit. (* if tout = 0, nxt timeout should be MAX_TOUT *)
          }
          { (* dm1 = Some Grant *)
            subst dm1.
            ss.

            assert (QHD_EQ: hd_error q = Some 1).
            { inv DMS_INV.
              inv DM1; ss. }

            destruct (Nat.ltb_spec 0 dmd); ss.
            2: { nia. }
            simpl_itree_hyp RUN.
            simpl_itree_hyp RUN.

            inv RUN; ss.
            { econs. }
            clarify. existT_elim. subst.

            simpl_itree_hyp RUN_REST.
            unfold Dev.send_msg in RUN_REST. ss.

            destruct (pred dmd) as [| dmd'] eqn:DMD'; ss.
            - simpl_itree_hyp RUN_REST.
              simpl_itree_hyp RUN_REST.
              rename RUN_REST into RUN.
              inv RUN; ss.
              { econs. }
              clarify. existT_elim. subst.

              simpl_itree_hyp RUN_REST.
              simpl_itree_hyp RUN_REST.
              rename RUN_REST into RUN.
              inv RUN; ss.
              { econs 1. }

              clarify. existT_elim. subst.
              inv RUN_REST; ss.
              { econs 1. }
              clarify.
              econs 4. eauto.

            - simpl_itree_hyp RUN_REST.
              simpl_itree_hyp RUN_REST.
              rename RUN_REST into RUN.
              inv RUN; ss.
              { econs 1. }
              clarify. existT_elim. subst.
              inv RUN_REST; ss.
              { econs 1. }
              clarify.

              assert (hd_error (Ctrl.queue ctrl') = Some 1 /\
                      ((Ctrl.timeout ctrl') = MAX_TOUT \/
                       (Ctrl.timeout ctrl') = pred MAX_TOUT)).
              { admit. }
              des.
              { econs 5; eauto.
                nia. }
              { econs 5; eauto.
                nia. }
          }

          inv RUN; ss.

              econs 5.
              { (* dmd <= Ctrl.timeout -> dmd' <= Ctrl.timeout' *)
                admit. }

              destruct (Nat.eqb_spec dmd 0); ss.

            inv RUN_REST; ss.
            { econs. }

            simpl_itree_hyp OBS_RET.
            ss.

          inv RUN; ss.
          { econs. }

        destruct q as [| qh qt].
        { hexploit EMPTY_QUEUE_TOUT_ZERO; eauto.
          clear EMPTY_QUEUE_TOUT_ZERO.
          i. subst.

          inv DMS_INV.
          clear NO_MSGS_COND WF_Q RANGE_TOUT.

          inv STEP_D.
          - esplits.
            2: { econs. }
            admit. (* ctrl_inv prsv *)
          -

  Admitted.

  Lemma sys_inv_prsv
        st str st'
        (INV: sys_inv st)
        (STEP: Sys.step st str st')
    : sys_inv st'.
  Proof.
    inv INV.
    inv STEP.

    hexploit (inv_prsv_each_dev 1); eauto.
    hexploit (inv_prsv_each_dev 2); eauto.
    hexploit (inv_prsv_each_dev 3); eauto.
    i. des.
    econs; eauto.
  Qed.


From RecoveryRefinement Require Import Lib.

Require Import OneDiskAPI.
Require Import TwoDiskAPI.
Require Import TwoDiskTheorems.
Require Import HoareTactics.

(**
ReplicatedDisk provides a single-disk API on top of two disks, handling disk
failures with replication.
*)

Module ReplicatedDisk.

  Import TwoDiskAPI.TwoDisk.

  Import ProcNotations EqualDecNotation.
  Open Scope proc_scope.

  Definition read (a:addr) : proc Op block :=
    mv0 <- td.read d0 a;
    match mv0 with
    | Working v => Ret v
    | Failed =>
      mv2 <- td.read d1 a;
      match mv2 with
      | Working v => Ret v
      | Failed => Ret block0
      end
    end.

  Definition write (a:addr) (b:block) : proc Op unit :=
    _ <- td.write d0 a b;
    _ <- td.write d1 a b;
    Ret tt.

  Definition size : proc Op nat :=
    msz <- td.size d0;
    match msz with
    | Working sz => Ret sz
    | Failed =>
      msz <- td.size d1;
      match msz with
      | Working sz => Ret sz
      | Failed => Ret 0
      end
    end.

  (** [sizeInit] computes the size during initialization; it may return None if
  the sizes of the underlying disks differ. *)
  Definition sizeInit : proc Op (option nat) :=
    sz1 <- td.size d0;
    sz2 <- td.size d1;
    match sz1 with
    | Working sz1 =>
      match sz2 with
      | Working sz2 =>
        if sz1 == sz2 then Ret (Some sz1) else Ret None
      | Failed => Ret (Some sz1)
      end
    | Failed =>
      match sz2 with
      | Working sz2 => Ret (Some sz2)
      | Failed => Ret None
      end
    end.

  (* Recursively initialize block a and below. For simplicity, we make the disks
  match by setting every block to [block0]. *)
  Fixpoint init_at (a:nat) : proc Op unit :=
    match a with
    | 0 => Ret tt
    | S a =>
      _ <- td.write d0 a block0;
      _ <- td.write d1 a block0;
      init_at a
    end.

  (* Initialize every disk block *)
  Definition init' : proc Op InitStatus :=
    size <- sizeInit;
    match size with
    | Some sz =>
      _ <- init_at sz;
      Ret Initialized
    | None =>
      Ret InitFailed
    end.

  (**
   * Helper theorems and tactics for proofs.
   *)

  Tactic Notation "evar_tuple" ident(a) ident(b) :=
    match goal with
    | [ |- ?aT * ?bT ] =>
      let a := fresh a in
      let b := fresh b in
      evar (a : aT);
      evar (b : bT);
      exact (a, b)
    end.

  Ltac simplify :=
    repeat match goal with
           | |- forall _, _ => intros
           | _ => deex
           | _ => destruct_tuple
           | [ u: unit |- _ ] => destruct u
           | |- _ /\ _ => split; [ solve [auto] | ]
           | |- _ /\ _ => split; [ | solve [auto] ]
           | [ H: identity _ _ _ |- _ ] => apply identity_unfold in H
           | |- list block => shelve
           | |- disk => shelve
           | |- disk*(disk -> Prop) => evar_tuple d F
           | |- list block*(list block -> Prop) => evar_tuple d F
           | _ => progress simpl in *
           | _ => progress safe_intuition
           | _ => progress subst
           | _ => progress autorewrite with length array in *
           end.

  (* The [finish] tactic tries a number of techniques to solve the goal. *)
  Ltac finish :=
    repeat match goal with
           | _ => solve_false
           | _ => congruence
           | _ => solve [ intuition (subst; eauto; try congruence) ]
           | _ =>
             (* if we can solve all the side conditions automatically, then it's
             safe to run descend and create existential variables *)
             descend; (intuition eauto);
             lazymatch goal with
             | |- proc_hspec _ _ _ => idtac
             | |- proc_rspec _ _ _ _ => idtac
             | _ => fail
             end
           end.

  Ltac step :=
    unshelve (step_proc); simplify; finish.

  (**
   * Specifications and proofs about our implementation of the replicated disk API,
   * without considering our recovery.
   *
   * These intermediate specifications separate reasoning about the
   * implementations from recovery behavior.
   *)

  Theorem both_disks_not_missing : forall (state: State),
      disk0 state ?|= missing ->
      disk1 state ?|= missing ->
      False.
  Proof.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Global Hint Resolve both_disks_not_missing : false.

  Theorem missing0_implies_any : forall (state: State) P,
      disk0 state ?|= missing ->
      disk0 state ?|= P.
  Proof.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Theorem missing1_implies_any : forall (state: State) P,
      disk1 state ?|= missing ->
      disk1 state ?|= P.
  Proof.
    destruct state; unfold missing; simpl; intuition auto.
  Qed.

  Global Hint Resolve missing0_implies_any : core.
  Global Hint Resolve missing1_implies_any : core.
  Global Hint Resolve read_ok write_ok size_ok : core.

  Theorem read_int_ok : forall a d,
      proc_hspec TDLayer
        (read a)
        (fun state =>
           {|
             pre := disk0 state ?|= eq d /\
                    disk1 state ?|= eq d;
             post :=
               fun state' r =>
                 index d a ?|= eq r /\
                 disk0 state' ?|= eq d /\
                 disk1 state' ?|= eq d;
             alternate :=
               fun state' _ =>
                 disk0 state' ?|= eq d /\
                 disk1 state' ?|= eq d;
           |}).
  Proof.
    unfold read.
    repeat (step; destruct r).
  Qed.

  Global Hint Resolve read_int_ok : core.

  Theorem write_int_ok : forall a b d,
      proc_hspec TDLayer
        (write a b)
        (fun state =>
           {|
             pre :=
               disk0 state ?|= eq d /\
               disk1 state ?|= eq d;
             post :=
               fun state' r =>
                 r = tt /\
                 disk0 state' ?|= eq (assign d a b) /\
                 disk1 state' ?|= eq (assign d a b);
             alternate :=
               fun state' _ =>
                 (disk0 state' ?|= eq d /\
                  disk1 state' ?|= eq d) \/
                  ((disk0 state' ?|= eq (assign d a b) /\
                  disk1 state' ?|= eq d)) \/
                 (disk0 state' ?|= eq (assign d a b) /\
                  disk1 state' ?|= eq (assign d a b));
           |}).
  Proof.
    unfold write.
    step.

    destruct r; step.
    - descend; intuition eauto.

      step.
      destruct r; (intuition eauto); simplify.
    - destruct (lt_dec a (length d)).
      + eauto.
        simplify.
        destruct r; step.
      + destruct r; step.
  Qed.

  Global Hint Resolve write_int_ok : core.

  Theorem size_int_ok d_0 d_1:
    proc_hspec TDLayer
      (size)
      (fun state =>
         {|
           pre :=
             disk0 state ?|= eq d_0 /\
             disk1 state ?|= eq d_1 /\
             length d_0 = length d_1;
           post :=
             fun state' r =>
               r = length d_0 /\
               r = length d_1 /\
               disk0 state' ?|= eq d_0 /\
               disk1 state' ?|= eq d_1;
           alternate :=
             fun state' _ =>
               disk0 state' ?|= eq d_0 /\
               disk1 state' ?|= eq d_1;
         |}).
  Proof.
    unfold size.
    step.
    destruct r; step.
    destruct r; step.
  Qed.

  Global Hint Resolve size_int_ok : core.

  Definition equal_after a (d_0 d_1: disk) :=
    length d_0 = length d_1 /\
    forall a', a <= a' -> index d_0 a' = index d_1 a'.

  Theorem le_eq_or_S_le : forall n m,
      n <= m ->
      n = m \/
      S n <= m /\ n <> m.
  Proof.
    intros.
    lia.
  Qed.

  Theorem equal_after_assign : forall a d_0 d_1 b,
      equal_after (S a) d_0 d_1 ->
      equal_after a (assign d_0 a b) (assign d_1 a b).
  Proof.
    unfold equal_after; intuition.
    - autorewrite with length; eauto.
    - apply le_eq_or_S_le in H; intuition subst.
      + destruct (lt_dec a' (length d_0)); autorewrite with array; auto.
      + autorewrite with array; auto.
  Qed.

  Global Hint Resolve equal_after_assign : core.

  Theorem init_at_ok : forall a d_0 d_1,
      proc_hspec TDLayer
        (init_at a)
        (fun state =>
           {| pre :=
                disk0 state ?|= eq d_0 /\
                disk1 state ?|= eq d_1 /\
                equal_after a d_0 d_1;
              post :=
                fun state' _ =>
                  exists d_0' d_1': disk,
                    disk0 state' ?|= eq d_0' /\
                    disk1 state' ?|= eq d_1' /\
                    equal_after 0 d_0' d_1';
              alternate :=
                fun state' _ => True;
           |}).
  Proof.
    induction a; simpl; intros.
    - step.
    - step.

      step. do 2 especialize IHa.
      destruct r; finish.
      + step; destruct r; simplify; finish.
      + step; destruct r; finish.
  Qed.

  Global Hint Resolve init_at_ok : core.

  Theorem sizeInit_ok d_0 d_1 :
    proc_hspec TDLayer
      (sizeInit)
      (fun state =>
         {| pre :=
              disk0 state ?|= eq d_0 /\
              disk1 state ?|= eq d_1;
            post :=
              fun state' r =>
                exists d_0' d_1',
                  disk0 state' ?|= eq d_0' /\
                  disk1 state' ?|= eq d_1' /\
                  match r with
                  | Some sz => length d_0' = sz /\ length d_1' = sz
                  | None => True
                  end;
            alternate :=
              fun state' _ => True;
         |}).
  Proof.
    unfold sizeInit.
    step.
    destruct r.
    - step.
      destruct r.
      + destruct (length d_0 == v).
        * step.
        * step.
      + step.
    - step.
      destruct r.
      + step.
      + step.
  Qed.

  Global Hint Resolve sizeInit_ok : core.

  Theorem equal_after_0_to_eq : forall d_0 d_1,
      equal_after 0 d_0 d_1 ->
      d_0 = d_1.
  Proof.
    unfold equal_after; intuition.
    eapply index_ext_eq; intros.
    eapply H1; lia.
  Qed.

  Theorem equal_after_size : forall d_0 d_1,
      length d_0 = length d_1 ->
      equal_after (length d_0) d_0 d_1.
  Proof.
    unfold equal_after; intuition.
    assert (~a' < length d_0) by lia.
    assert (~a' < length d_1) by congruence.
    autorewrite with array; eauto.
  Qed.

  Global Hint Resolve equal_after_size : core.
  Global Hint Resolve equal_after_0_to_eq : core.

  Theorem init'_ok d_0 d_1:
    proc_hspec TDLayer
      (init')
      (fun state =>
         {| pre :=
              disk0 state ?|= eq d_0 /\
              disk1 state ?|= eq d_1;
            post :=
              fun state' r =>
                match r with
                | Initialized =>
                  exists d_0' d_1',
                  disk0 state' ?|= eq d_0' /\
                  disk1 state' ?|= eq d_1' /\
                  d_0' = d_1'
                | InitFailed =>
                  True
                end;
            alternate :=
              fun state' _ => True;
         |}).
  Proof.
    step.
    spec_intros.
    simpl in H1. repeat deex.
    destruct r; step.
    step.
  Qed.

  Theorem init'_ok_closed:
    proc_hspec TDLayer
      (init')
      (fun state =>
         {| pre := True;
            post :=
              fun state' r =>
                match r with
                | Initialized =>
                  exists d_0' d_1',
                  disk0 state' ?|= eq d_0' /\
                  disk1 state' ?|= eq d_1' /\
                  d_0' = d_1'
                | InitFailed =>
                  True
                end;
            alternate :=
              fun state' _ => True;
         |}).
  Proof.
    spec_intros.
    destruct state0; simplify.
    - eapply proc_hspec_impl; unfold spec_impl; [| eapply (init'_ok d_0)]; simplify.
    - eapply proc_hspec_impl; unfold spec_impl; [| eapply (init'_ok d_0 d_0)]; simplify.
    - eapply proc_hspec_impl; unfold spec_impl; [| eapply (init'_ok d_1)]; simplify.
  Qed.

  (**
   * Recovery implementation.
   *
   * General structure for recovery: essentially, it consists of
   * a loop around [fixup] that terminates after either fixing an out-of-sync
   * disk block or when a disk has failed.
  *)

  (* [fixup] returns a [RecStatus] to implement early termination in [recovery_at]. *)
  Inductive RecStatus :=
  (* continue working, nothing interesting has happened *)
  | Continue
  (* some address has been repaired (or the recovery has exhausted the
     addresses) - only one address can be out of sync and thus only it must be
     recovered. *)
  (* OR, one of the disks has failed, so don't bother continuing recovery since
     the invariant is now trivially satisfied *)
  | RepairDoneOrFailed.

  Definition fixup (a:addr) : proc Op RecStatus :=
    mv0 <- td.read d0 a;
    match mv0 with
    | Working v =>
      mv2 <- td.read d1 a;
      match mv2 with
      | Working v' =>
        if v == v' then
          Ret Continue
        else
          mu <- td.write d1 a v;
          Ret RepairDoneOrFailed
      | Failed => Ret RepairDoneOrFailed
      end
    | Failed => Ret RepairDoneOrFailed
    end.

  (* recursively performs recovery at [a-1], [a-2], down to 0 *)
  Fixpoint recover_at (a:addr) : proc Op unit :=
    match a with
    | 0 => Ret tt
    | S n =>
      s <- fixup n;
      match s with
      | Continue => recover_at n
      | RepairDoneOrFailed => Ret tt
      end
    end.

  Definition Recover : proc Op unit :=
    sz <- size;
    _ <- recover_at sz;
    Ret tt.

  (**
   * Theorems and recovery proofs.
   *)

  Theorem if_lt_dec : forall A n m (a a':A),
      n < m ->
      (if lt_dec n m then a else a') = a.
  Proof.
    intros.
    destruct (lt_dec n m); auto.
    contradiction.
  Qed.

  Theorem disks_eq_inbounds : forall (d: disk) a v v',
      a < length d ->
      index d a ?|= eq v ->
      index d a ?|= eq v' ->
      v = v'.
  Proof.
    intros.
    case_eq (index d a); intros.
    - rewrite H2 in *. simpl in *. congruence.
    - exfalso.
      apply index_not_none in H2; eauto.
  Qed.

  (* To make these specifications precise while also covering both the already
   * synced and diverged disks cases, we keep track of which input state we're
   * in from the input and use it to give an exact postcondition. *)
  Inductive DiskStatus :=
  | FullySynced
  | OutOfSync (a:addr) (b:block).

  Theorem assign_maybe_same : forall (d:disk) a b,
      index d a ?|= eq b ->
      assign d a b = d.
  Proof.
    intros.
    destruct (lt_dec a (length d));
      autorewrite with array;
      auto.
    destruct_with_eqn (index d a); simpl in *; subst; eauto.
    - apply index_ext_eq; intros i.
      destruct (lt_dec i (length d)), (a == i);
        subst;
        autorewrite with array;
        auto.
    - exfalso; apply index_not_none in Heqo; auto.
  Qed.

#[global]
  Hint Rewrite assign_maybe_same using (solve [ auto ]) : array.
  Global Hint Resolve PeanoNat.Nat.lt_neq : core.
  Global Hint Resolve disks_eq_inbounds : core.

  (* we will show that fixup does nothing once the disks are the same *)
  Theorem fixup_equal_ok : forall a d,
      proc_hspec TDLayer
        (fixup a)
        (fun state =>
           {|
             pre :=
               (* for simplicity we only consider in-bounds addresses, though
                  if a is out-of-bounds fixup just might uselessly write to
                  disk and not do anything *)
               a < length d /\
               disk0 state ?|= eq d /\
               disk1 state ?|= eq d;
             post :=
               fun state' r =>
                 disk0 state' ?|= eq d /\
                 disk1 state' ?|= eq d;
             alternate :=
               fun state' _ =>
                 disk0 state' ?|= eq d /\
                 disk1 state' ?|= eq d;
           |}).
  Proof.
    unfold fixup.
    step.

    destruct r; step.

    destruct r; try step.
    destruct (v == v0); subst; try step.

    Unshelve.
    { auto. }
    { exact (fun _ => True). }
  Qed.

  Theorem fixup_correct_addr_ok : forall a d b,
      proc_hspec TDLayer
        (fixup a)
        (fun state =>
           {|
             pre :=
               a < length d /\
               disk0 state ?|= eq (assign d a b) /\
               disk1 state ?|= eq d;
             post :=
               fun state' r =>
                 match r with
                 | Continue =>
                   (* could happen if b already happened to be value *)
                   disk0 state' ?|= eq (assign d a b) /\
                   disk1 state' ?|= eq (assign d a b)
                 | RepairDoneOrFailed =>
                   (disk0 state' ?|= eq (assign d a b) /\
                    disk1 state' ?|= eq (assign d a b)) \/
                   (disk0 state' ?|= eq d /\
                    disk1 state' ?|= eq d)
                 end;
             alternate :=
               fun state' _ =>
                 (disk0 state' ?|= eq (assign d a b) /\
                  disk1 state' ?|= eq (assign d a b)) \/
                 (disk0 state' ?|= eq (assign d a b) /\
                  disk1 state' ?|= eq d) \/
                 (disk0 state' ?|= eq d /\
                  disk1 state' ?|= eq d);
           |}).
  Proof.
    unfold fixup; intros.
    step.

    destruct r; try step.

    destruct r; try step.
    destruct (b == v); subst; try step.

    step.
    destruct r; simplify; finish.
  Qed.

  Theorem fixup_wrong_addr_ok : forall a d b a',
      proc_hspec TDLayer
        (fixup a)
        (fun state =>
           {|
             pre :=
               a < length d /\
               (* recovery, working from end of disk, has not yet reached the
                  correct address *)
               a' < a /\
               disk0 state ?|= eq (assign d a' b) /\
               disk1 state ?|= eq d;
             post :=
               fun state' r =>
                 match r with
                 | Continue =>
                   disk0 state' ?|= eq (assign d a' b) /\
                   disk1 state' ?|= eq d
                 | RepairDoneOrFailed =>
                   (disk0 state' ?|= eq d /\
                    disk1 state' ?|= eq d) \/
                   (disk0 state' ?|= eq (assign d a' b) /\
                    disk1 state' ?|= eq (assign d a' b))
                 end;
             alternate :=
               fun state' _ =>
                 (disk0 state' ?|= eq (assign d a' b) /\
                  disk1 state' ?|= eq d) \/
                 (disk0 state' ?|= eq d /\
                  disk1 state' ?|= eq d);
           |}).
  Proof.
    unfold fixup; intros.
    step.

    destruct r; try step.
    destruct r; try step.

    destruct (v == v0); subst.
    - step.
    - step.
    Unshelve.
    { auto. }
    { exact (fun _ => True). }
  Qed.

  Ltac spec_case pf :=
    eapply proc_hspec_impl; [ unfold spec_impl | solve [ apply pf ] ].

  Theorem fixup_ok : forall a d s,
      proc_hspec TDLayer
        (fixup a)
        (fun state =>
           {|
             pre :=
               a < length d /\
               match s with
               | FullySynced => disk0 state ?|= eq d /\
                               disk1 state ?|= eq d
               | OutOfSync a' b => a' <= a /\
                                  disk0 state ?|= eq (assign d a' b) /\
                                  disk1 state ?|= eq d
               end;
             post :=
               fun state' r =>
                 match s with
                 | FullySynced => disk0 state' ?|= eq d /\
                                 disk1 state' ?|= eq d
                 | OutOfSync a' b =>
                   match r with
                   | Continue =>
                     (a' < a /\
                      disk0 state' ?|= eq (assign d a' b) /\
                      disk1 state' ?|= eq d) \/
                     (disk0 state' ?|= eq (assign d a' b) /\
                      disk1 state' ?|= eq (assign d a' b))
                   | RepairDoneOrFailed =>
                     (disk0 state' ?|= eq d /\
                      disk1 state' ?|= eq d) \/
                     (disk0 state' ?|= eq (assign d a' b) /\
                      disk1 state' ?|= eq (assign d a' b))
                   end
                 end;
             alternate :=
               fun state' _ =>
                 match s with
                 | FullySynced => disk0 state' ?|= eq d /\
                                 disk1 state' ?|= eq d
                 | OutOfSync a' b =>
                   (disk0 state' ?|= eq (assign d a' b) /\
                    disk1 state' ?|= eq (assign d a' b)) \/
                   (disk0 state' ?|= eq (assign d a' b) /\
                    disk1 state' ?|= eq d) \/
                   (disk0 state' ?|= eq d /\
                    disk1 state' ?|= eq d)
                 end;
           |}).
  Proof.
    spec_intros; simplify.
    destruct s; intuition eauto.
    - spec_case fixup_equal_ok; simplify; finish.
    - apply PeanoNat.Nat.lt_eq_cases in H1; intuition.
      + spec_case (fixup_wrong_addr_ok a d b a0); simplify; finish.
        destruct v; finish.
      + spec_case fixup_correct_addr_ok; simplify; finish.
        split. { intuition eauto. }
        simplify; finish.
        destruct v; finish.
  Qed.

  Global Hint Resolve fixup_ok : core.

  (* Hint Resolve Lt.lt_n_Sm_le. *)

  Theorem recover_at_ok : forall a d s,
      proc_hspec TDLayer
        (recover_at a)
        (fun state =>
           {|
             pre :=
               a <= length d /\
               match s with
               | FullySynced => disk0 state ?|= eq d /\
                               disk1 state ?|= eq d
               | OutOfSync a' b => a' < a /\
                                  disk0 state ?|= eq (assign d a' b) /\
                                  disk1 state ?|= eq d
               end;
             post :=
               fun state' r =>
                 match s with
                 | FullySynced =>
                   disk0 state' ?|= eq d /\
                   disk1 state' ?|= eq d
                 | OutOfSync a' b =>
                   (disk0 state' ?|= eq d /\
                    disk1 state' ?|= eq d) \/
                   (disk0 state' ?|= eq (assign d a' b) /\
                    disk1 state' ?|= eq (assign d a' b))
                 end;
             alternate :=
               fun state' _ =>
                 match s with
                 | FullySynced => disk0 state' ?|= eq d /\
                                 disk1 state' ?|= eq d
                 | OutOfSync a' b =>
                   (disk0 state' ?|= eq d /\
                    disk1 state' ?|= eq d) \/
                   (disk0 state' ?|= eq (assign d a' b) /\
                    disk1 state' ?|= eq d) \/
                   (disk0 state' ?|= eq (assign d a' b) /\
                    disk1 state' ?|= eq (assign d a' b))
                 end;
           |}).
  Proof.
    induction a; simpl; intros.
    - step.
      destruct s; simplify.
    - step.
      destruct s; simplify.
      * specialize (IHa d FullySynced).
        simplify; finish.
        destruct r; step.
        lia.
      * split; [intuition; eauto; try lia|].
        simplify; finish.
        destruct r.
        ** spec_intros. simpl in H3. destruct H3.
           *** specialize (IHa d (OutOfSync a0 b)).
               step. lia.
           *** specialize (IHa (assign d a0 b) FullySynced).
               step. autorewrite with length in *; lia.
        ** step.
  Qed.

  Global Hint Resolve recover_at_ok : core.

  Definition Recover_spec : _ -> _ -> Specification unit unit State :=
    fun d s state =>
      {|
        pre :=
          match s with
          | FullySynced => disk0 state ?|= eq d /\
                          disk1 state ?|= eq d
          | OutOfSync a b => disk0 state ?|= eq (assign d a b) /\
                             disk1 state ?|= eq d
          end;
        post :=
          fun state' (_:unit) =>
            match s with
            | FullySynced => disk0 state' ?|= eq d /\
                            disk1 state' ?|= eq d
            | OutOfSync a b =>
              (disk0 state' ?|= eq d /\
               disk1 state' ?|= eq d) \/
              (disk0 state' ?|= eq (assign d a b) /\
               disk1 state' ?|= eq (assign d a b))
            end;
        alternate :=
          fun state' (_:unit) =>
            match s with
            | FullySynced => disk0 state' ?|= eq d /\
                            disk1 state' ?|= eq d
            | OutOfSync a b =>
              (disk0 state' ?|= eq d /\
               disk1 state' ?|= eq d) \/
              (disk0 state' ?|= eq (assign d a b) /\
               disk1 state' ?|= eq d) \/
              (disk0 state' ?|= eq (assign d a b) /\
               disk1 state' ?|= eq (assign d a b))
            end;
      |}.

  Inductive rec_prot : Type :=
    | prot_sync1 : rec_prot
    | prot_out : rec_prot
    | prot_sync2 : rec_prot.

  Theorem Recover_rok1 d s :
    proc_hspec TDLayer
      (Recover)
      (Recover_spec d s).
  Proof.
    unfold Recover, Recover_spec; intros.
    spec_intros; simplify.
    destruct s; simplify.
    + step.
      unshelve (step).
      { exact d. } { exact FullySynced. }
      simplify; finish.
      step.
    + step.
      intuition eauto.
      { simplify. }
      destruct (lt_dec a (length d)).
      * unshelve (step).
        { exact d. } { exact (OutOfSync a b). }
        simplify; finish.
        step.
      * unshelve (step).
        { exact d. } { exact FullySynced. }
        simplify.
        step.
  Qed.

  Theorem Recover_rok2 d a b rp:
    proc_hspec TDLayer
      (Recover)
      (match rp with
       | prot_sync1 => Recover_spec d (FullySynced)
       | prot_out => Recover_spec d (OutOfSync a b)
       | prot_sync2 => Recover_spec (assign d a b) (FullySynced)
       end).
  Proof.
    unfold Recover, Recover_spec; intros.
    spec_intros; simplify.
    destruct rp; simplify.
    + step.
        unshelve (step).
        { exact d. } { exact FullySynced. }
        simplify; finish.
        step.
    + step.
      intuition eauto.
      { simplify. }
      destruct (lt_dec a (length d)).
      * unshelve (step).
        { exact d. } { exact (OutOfSync a b). }
        simplify; finish.
        step.
      * unshelve (step).
        { exact d. } { exact FullySynced. }
        simplify.
        step.
    + step.
      intuition eauto.
      simplify.
      destruct (lt_dec a (length d)).
      * unshelve (step).
        { exact (assign d a b). }
        { exact (OutOfSync a b). }
        simplify; finish.
        step.
        intuition simplify.
      * unshelve (step).
        { exact (assign d a b). } { exact (FullySynced). }
        simplify; finish.
        step.
  Qed.

  Theorem Recover_spec_idempotent1 d :
    idempotent (fun (t : unit) => Recover_spec d (FullySynced)).
  Proof.
    unfold idempotent; intuition; simplify.
    exists tt; finish.
  Qed.

  Theorem Recover_spec_idempotent2 d a b :
    idempotent
      (fun rp : rec_prot =>
         match rp with
         | prot_sync1 => Recover_spec d (FullySynced)
         | prot_out => Recover_spec d (OutOfSync a b)
         | prot_sync2 => Recover_spec (assign d a b) (FullySynced)
         end).
  Proof.
    unfold idempotent; intuition; simplify.
    unfold identity in *; subst.
    destruct a0.
    - exists prot_sync1; simplify; finish.
    - destruct H0; [| destruct H0].
      ** exists (prot_sync1); simplify; finish.
      ** exists (prot_out); simplify; finish.
      ** exists (prot_sync2); simplify; finish.
    - exists prot_sync2; simplify; finish.
  Qed.

  (* As the final step in giving the correctness of the replicated disk
  operations, we prove recovery specs that include the replicated disk Recover
  function. *)

  Definition rd_abstraction (d:D.State) (state: State) (u: unit) : Prop :=
    disk0 state ?|= eq d /\
    disk1 state ?|= eq d.

  Theorem read_rec_ok :
    forall a d, proc_rspec TDLayer (read a) Recover
                           (refine_spec rd_abstraction (OneDiskAPI.read_spec a) d).
  Proof.
    intros a d.
    eapply proc_hspec_to_rspec; eauto using Recover_spec_idempotent1;
      unfold refine_spec, rd_abstraction in *.
    - intros []. eapply Recover_rok1.
    - descend; simplify; intuition eauto.
    - descend; simplify; intuition eauto.
      exists tt. subst; intuition eauto.
    - simplify. exists d; split; eauto.
  Qed.

  Theorem write_rec_ok :
    forall a b d, proc_rspec TDLayer (write a b) Recover
                             (refine_spec rd_abstraction (OneDiskAPI.write_spec a b) d).
  Proof.
    intros a b d.
    eapply proc_hspec_to_rspec; eauto using Recover_spec_idempotent2;
      unfold refine_spec, rd_abstraction in *.
    - intros. eapply Recover_rok2.
    - descend; simplify; intuition eauto.
    - intros.
      simpl in *.
      (intuition eauto);
        repeat match goal with
               | [ H: identity _ _ _ |- _ ] => inv_clear H
               end.
      * exists (prot_sync1); simplify; finish.
      * exists (prot_out); simpl.
        intuition eauto.
      * assert (a < length d \/ a >= length d) as [Hlt|Hoob] by lia.
        ** exists (prot_sync2); simplify; finish.
        ** exists (prot_sync1); simplify; finish.
    - unfold rd_abstraction in *; simplify. destruct a0, H0.
      * exists d. simplify; finish.
      * exists d. simplify; finish.
      * exists (assign d a b); simplify; finish.
      * exists (assign d a b); simplify; finish.
  Qed.

  Theorem size_rec_ok :
    forall d, proc_rspec TDLayer (size) Recover
                         (refine_spec rd_abstraction (OneDiskAPI.size_spec) d).
  Proof.
    intros d.
    eapply proc_hspec_to_rspec; eauto using Recover_spec_idempotent1;
      unfold refine_spec, rd_abstraction in *.
    - intros. eapply Recover_rok1.
    - descend; simplify; intuition eauto.
    - descend; simplify; intuition eauto.
      exists tt. intuition eauto.
    - simplify. exists d; split; eauto.
  Qed.

  Global Hint Resolve read_rec_ok size_rec_ok write_rec_ok : core.

  Import Helpers.RelationAlgebra.
  Import RelationNotations.

  Definition Impl_TD_OD: LayerImpl Op D.Op :=
    {| compile_op := fun (T : Type) (op : D.Op T) =>
                       match op in (D.Op T0) return (proc Op T0) with
                       | D.op_read a => read a
                       | D.op_write a b => write a b
                       | D.op_size => size
                       end;
       init := init';
       Layer.recover := Recover |}.

  Lemma one_disk_failure_id x:
    D.one_disk_failure x x tt.
  Proof. econstructor. Qed.

  Lemma one_disk_failure_id_l r x:
    (D.one_disk_failure + r)%rel x x tt.
  Proof. left. econstructor. Qed.

  Global Hint Resolve one_disk_failure_id one_disk_failure_id_l : core.
  Global Hint Constructors D.op_step : core.

  Lemma compile_refine_TD_OD:
    compile_op_refines_step TDLayer D.ODLayer Impl_TD_OD rd_abstraction.
  Proof.
    unfold compile_op_refines_step.
    intros T op. destruct op.
    * eapply proc_rspec_crash_refines_op; [ intros; eapply read_rec_ok |..]; simplify; eauto.
      econstructor; destruct (index _ _); eauto.
    * eapply proc_rspec_crash_refines_op; [ intros; eapply write_rec_ok |..]; simplify; eauto.
      intuition; subst; intuition eauto.
    * eapply proc_rspec_crash_refines_op; [ intros; eapply size_rec_ok |..]; simplify; eauto.
  Qed.

  Theorem Recover_noop d :
    proc_rspec TDLayer
      (Recover)
      (Recover)
      (Recover_spec d (FullySynced)).
  Proof.
    eapply proc_hspec_to_rspec; eauto using Recover_spec_idempotent1.
    { eapply Recover_rok1. }
    { intros []. eapply Recover_rok1. }
    { simplify. exists tt. eauto. }
    { simplify. }
  Qed.

  Lemma recovery_refines_TD_OD:
    recovery_refines_crash_step TDLayer D.ODLayer Impl_TD_OD rd_abstraction.
  Proof.
    unfold recovery_refines_crash_step.
    eapply proc_rspec_recovery_refines_crash_step; [ eapply Recover_noop|..];
      unfold rd_abstraction; simplify; subst; finish.
  Qed.

  Lemma Refinement_TD_OD: LayerRefinement TDLayer D.ODLayer.
  Proof.
    unshelve (econstructor).
    - apply Impl_TD_OD.
    - exact rd_abstraction.
    - exact compile_refine_TD_OD.
    - exact recovery_refines_TD_OD.
    - eapply proc_hspec_init_ok; unfold rd_abstraction.
      { eapply init'_ok_closed. }
      { simplify. }
      { simplify; firstorder. }
  Defined.

End ReplicatedDisk.

(*
Print Assumptions ReplicatedDisk.Refinement_TD_OD.
*)


Require Import Term_Defs StructTactics.

Check Term.

Require Import List.
Import List.ListNotations.
Require Import MonadVM VmSemantics Impl_vm Term_Defs ConcreteEvidence.

Definition secret_evidence_rel := Evidence -> Plc -> Prop.

Definition evidence_subset_of (e:Evidence) (e':Evidence): Prop.
Admitted.

Definition policy_protects : secret_evidence_rel.
Admitted.

Inductive evidence_disclosed' : Plc -> Plc -> Evidence -> Term -> secret_evidence_rel :=
| cumul_req: forall t e e' init requester me,
    evidence_subset_of e e' ->
    e' = eval t me init ->
    evidence_disclosed' requester me init t e requester
| cumul_me: forall t e e' init requester me,
    evidence_subset_of e e' ->
    e' = eval t me init ->
    evidence_disclosed' requester me init t e me

(* These two NOT redundant since t could clear init *)
| always_me_init': forall requester me init t,
    evidence_disclosed' requester me init t init me
| always_requester_init': forall requester me init t,
    evidence_disclosed' requester me init t init requester

| ed_at'': forall requester me init q t',
    evidence_disclosed' requester me init (att q t') init q
| ed_at''': forall requester me init q q' t' e,
    evidence_disclosed' me q init t' e q' ->
    evidence_disclosed' requester me init (att q t') e q'.

Inductive evidence_disclosed : Plc -> Plc -> Evidence -> Term -> secret_evidence_rel :=
| always_me_init: forall requester me init t, evidence_disclosed requester me init t init me
| always_requester_init: forall requester me init t, evidence_disclosed requester me init t init requester
(*| ed_asp_val: forall requester me init, evidence_disclosed requester me init (asp SIG) init requester *)
| ed_asp: forall requester me init a, evidence_disclosed requester me init (asp a) (eval_asp a me init) requester
| ed_at: forall requester me init q t',
    evidence_disclosed requester me init (att q t') init q
| ed_at': forall requester me init q q' t' e,
    evidence_disclosed me q init t' e q' ->
    evidence_disclosed requester me init (att q t') e q'
| ed_ln_l: forall requester me init t1 t2 q e,
    evidence_disclosed requester me init t1 e q ->
    evidence_disclosed requester me init (lseq t1 t2) e q
| ed_ln_r: forall requester me init t1 t2 q e,
    evidence_disclosed requester me init t1 e q ->
    evidence_disclosed requester me init (lseq t1 t2) e q
| ed_bseq_l: forall requester me init t1 t2 q e sp1 sp2,
    evidence_disclosed requester me (splitEv_T sp1 init) t1 e q ->
    evidence_disclosed requester me init (bseq (sp1,sp2) t1 t2) e q
| ed_bseq_r: forall requester me init t1 t2 q e sp1 sp2,
    evidence_disclosed requester me (splitEv_T sp2 init) t1 e q ->
    evidence_disclosed requester me init (bseq (sp1,sp2) t1 t2) e q
| ed_bpar_l: forall requester me init t1 t2 q e sp1 sp2,
    evidence_disclosed requester me (splitEv_T sp1 init) t1 e q ->
    evidence_disclosed requester me init (bpar (sp1,sp2) t1 t2) e q
| ed_bpar_r: forall requester me init t1 t2 q e sp1 sp2,
    evidence_disclosed requester me (splitEv_T sp2 init) t1 e q ->
    evidence_disclosed requester me init (bpar (sp1,sp2) t1 t2) e q.

Inductive disclosure_event: Ev -> Plc -> (*Plc ->*) Evidence -> Plc -> Prop :=
| req_dis: forall i loc requester (* me them *) p q q' ev t e b,
    events (annotated t []) q ev ->
    disclosure_event ev q' e b ->
    disclosure_event (req i loc p q t) requester e b
| asp_dis: forall i p id args requester init,
    disclosure_event (umeas i p id args) requester (eval_asp (ASPC id args) p init) requester.

Inductive events: AnnoTerm -> Plc -> Evidence -> Ev -> Prop :=.

Require Import Trace Main Term.

Require Import ConcreteEvidence.

Fixpoint evshape (e:EvidenceC) :=
  match e with
  | mtc => mt
  | uuc i _ e' => uu i [] 0 (evshape e')
  | ggc p e' => gg p (evshape e')
  | hhc p e' => hh p (evshape e')
  | nnc i _ e' => nn i (evshape e')
  | ssc e1 e2 => ss (evshape e1) (evshape e2)
  | ppc e1 e2 => ss (evshape e1) (evshape e2)
  end.

Lemma evshape_eval: forall init,
    Ev_Shape init (evshape init).
Proof.
Admitted.

Inductive trace: AnnoTerm -> Plc -> Evidence ->
                 list Ev -> Prop :=.

Lemma cvm_respects_disclosed': forall t ev tr p bad_p requester e  et,
  well_formed t ->
  (* copland_compile t (mk_st init_ev [] p o) = (Some tt, (mk_st e' tr p' o')) -> *)
  (*st_trace (run_cvm t
                    (mk_st e [] p o)) = tr -> *)
  (*st_trace
    (run_cvm t (mk_st init_ev [] p o)) = tr -> *)

   trace t p et tr ->
   In ev tr ->
  disclosure_event ev requester e bad_p ->
  (*Ev_Shape init_ev et -> *)
  evidence_disclosed requester p et (unanno t) e bad_p.
Proof.
  intros.
  generalizeEverythingElse t.
  induction t; intros.
  -
    destruct a.
    (*
      solve_by_inversion.
  -
    invc H1.
    invc H3.
    invc H4.
    invc H5.
    invc H3.
    solve_by_inversion.
  -
    solve_by_inversion.
  -
    solve_by_inversion.
  -
    solve_by_inversion.
Defined.
     *)
Admitted.

(*
    invc H0
      try (

      invc H0;
      cbn;
      invc H1; solve_by_inversion).
    +
      (*
      assert (Ev_Shape init_ev (evshape init_ev)).
      {
        eapply evshape_eval; eauto.
      }

      assert (et = evshape init_ev). admit.
      subst.
       *)

      (*

      invc H4.
      invc H1; try solve_by_inversion.
      cbn.
      invc H2.
      assert (et = init). admit.
      subst.
      econstructor.
  -
*)
Admitted.
*)

Lemma cvm_respects_disclosed: forall t ev tr p bad_p requester o e init_ev et e' p' o',
  well_formed t ->
  copland_compile t (mk_st init_ev [] p o) = (Some tt, (mk_st e' tr p' o')) ->
  (*st_trace (run_cvm t
                    (mk_st e [] p o)) = tr -> *)
  (*st_trace
    (run_cvm t (mk_st init_ev [] p o)) = tr -> *)
  In ev tr ->
  disclosure_event ev requester e bad_p ->
  Ev_Shape init_ev et ->
  evidence_disclosed requester p et (unanno t) e bad_p.
Proof.
  intros.
    assert (trace t p et tr).
    {
      (*
    eapply lstar_trace.
    eapply wf_implies_wfr; eauto.

    eapply cvm_refines_lts_event_ordering; eauto.
       *)
      admit.
    }
    eapply cvm_respects_disclosed'; eauto.
Admitted.

Definition policy_check_rel := Term -> Prop.

Inductive policy1: policy_check_rel :=
| allSigs: policy1 (asp SIG).

Definition my_secrets (e:Evidence) (p:Plc) :=
  match (e,p) with
  | (mt,3)  => True
  | _ => False
  end.

Definition passes_policy
           (policy:policy_check_rel)
           (secrets:secret_evidence_rel)
           (requester:Plc)
           (me:Plc)
           (init:Evidence) : Prop :=
  forall t e q,
    policy t ->
    secrets e q ->
    not (evidence_disclosed requester me init t e q).

Check annotated.

Definition cvm_passes_policy
           (policy:policy_check_rel)
           (secrets:secret_evidence_rel)
           (requester:Plc)
           (me:Plc)
           (init:EvidenceC) : Prop :=
  forall t e q ev et o o' p' tr e',
    policy (unanno t) ->
    secrets e q ->
    Ev_Shape init et ->
    well_formed t ->
    (* events t me et ev -> *)
    copland_compile t (mk_st init [] me o) = (Some tt, (mk_st e' tr p' o')) ->
    In ev tr ->
    not (disclosure_event ev requester e q).

Lemma passes_implies_cvm_passes: forall p s r m i i',
  Ev_Shape i i' ->
  passes_policy p s r m i' ->
  cvm_passes_policy p s r m i.
  Proof.
    intros.
    unfold cvm_passes_policy in *.
    unfold passes_policy in *.

    intros.
    unfold not in *.
    intros.
    eapply H0.
    eassumption.
    eassumption.

    eapply cvm_respects_disclosed with (init_ev:=i).
    eassumption.
    eassumption.
    eassumption.
    eassumption.
    eassumption.
  Defined.

(*
    not (evidence_disclosed requester me init t e q). *)

Lemma policy1_passes : passes_policy policy1 my_secrets 0 1 mt.
Proof.
  cbv in *;
    intros.
  invc H.
  destruct e; try solve_by_inversion.
  (*
  repeat (destruct q; try solve_by_inversion).
  invc H1. *)
Defined.

Definition derive_policy (secrets:secret_evidence_rel) : policy_check_rel.
Proof.
  cbv in *.
Admitted.

Lemma derive_passes_policy:
  forall secrets requester me init,
    passes_policy (derive_policy secrets) secrets requester me init.
Proof.
Admitted.

Lemma derive_passes_cvm_policy:
  forall secrets requester me init,
    cvm_passes_policy (derive_policy secrets) secrets requester me init.
Proof.
  intros.
  eapply passes_implies_cvm_passes.
  eapply evshape_eval.
  eapply derive_passes_policy.
Defined.


(* Check behavior of evar-evar subtyping problems in the presence of
   nested let-ins *)
(* Expected time < 2.00s *)

Set Implicit Arguments.
Unset Strict Implicit.

Parameter f : forall P, forall (i : nat), P i -> P i.
Parameter P : nat -> Type.

Time Definition g (n : nat) (a0 : P n) : P n :=
  let a1  := f a0 in
  let a2  := f a1 in
  let a3  := f a2 in
  let a4  := f a3 in
  let a5  := f a4 in
  let a6  := f a5 in
  let a7  := f a6 in
  let a8  := f a7 in
  let a9  := f a8 in
  let a10 := f a9 in
  let a11 := f a10 in
  let a12 := f a11 in
  let a13 := f a12 in
  let a14 := f a13 in
  let a15 := f a14 in
  let a16 := f a15 in
  let a17 := f a16 in
  a17.


Require Import HoareDef SimModSem.
Require Import Coqlib.
Require Import ImpPrelude.
Require Import Skeleton.
Require Import PCM.
Require Import ModSem Behavior.
Require Import Relation_Definitions.

(*** TODO: export these in Coqlib or Universe ***)
Require Import Relation_Operators.
Require Import RelationPairs.
From ITree Require Import
     Events.MapDefault.
From ExtLib Require Import
     Core.RelDec
     Structures.Maps
     Data.Map.FMapAList.
Require Import HTactics ProofMode IPM.
Require Import OpenDef.
Require Import Mem1 MemOpen STB.

Require Import Imp.
Require Import ImpNotations.
Require Import ImpProofs.

Require Import EchoMain0 EchoMainImp.

Set Implicit Arguments.

Local Open Scope nat_scope.

Section SIMMODSEM.

  Import ImpNotations.

  Context `{Σ: GRA.t}.

  Let W: Type := Any.t * Any.t.

  Let wf: unit -> W -> Prop :=
    fun _ '(mrps_src0, mrps_tgt0) =>
      (<<SRC: mrps_src0 = tt↑>>) /\
      (<<TGT: mrps_tgt0 = tt↑>>)
  .

  Theorem correct:
    refines2 [EchoMainImp.EchoMain] [EchoMain0.Main].
  Proof.
    eapply adequacy_local2. econs; ss. i.
    econstructor 1 with (wf:=wf) (le:=top2); et; ss.
    econs; ss.
    { init.
      unfold main_body, main.
      steps.
      rewrite unfold_eval_imp. steps.
      des_ifs.
      2:{ exfalso; apply n. solve_NoDup. }
      unfold ccallU. imp_steps.
      red. esplits; et.
    }
    Unshelve. all: try exact 0. all: ss.
  Qed.

End SIMMODSEM.