Require Export MinBFTg.

Section USIGcomp.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc : DTimeContext }.

  Context { minbft_context : MinBFT_context }.
  Context { m_initial_keys : MinBFT_initial_keys }.
  Context { u_initial_keys : USIG_initial_keys }.

  Context { usig_hash : USIG_hash }.

  Context { minbft_auth : MinBFT_auth }.

  Global Instance USIG_trusted_info : TrustedInfo :=
    MkTrustedInfo USIG_state.

  (* ===============================================================
     USIG UPDATE & SM
     =============================================================== *)

  Definition USIG_update : M_Update 0 USIGname _ :=
    fun (s : USIG_state) (m : USIG_input_interface) =>
      interp_s_proc
        (match m with
         | create_ui_in (v,r) =>
           let (s', ui) := create_UI v r s in
           [R] (s', create_ui_out ui)
         | verify_ui_in (v,r,ui) =>
           let b := verify_UI v r ui s in
           [R] (s, verify_ui_out b)
         end).

  (* (1) USIG and TrInc will have the same IO interface, but different states
     (2) add a new field to CompName to allow differentiating those states
     (3) call_proc will only look at the old CompName, without the new field
     (4) write a wrapper around TrInc's interface, which is slightly different
     (5) Parametrize UI in MinBFT
     (6) Move this elsewhere (to where all interfaces and states have been defined)
   *)
  Definition USIG_comp (r : Rep) : M_StateMachine 1 USIGname :=
    build_m_sm USIG_update (USIG_initial r).

  Definition MinBFTsubs (n : Rep) : n_procs _ :=
    [
      MkPProc USIGname (USIG_comp n),
      MkPProc LOGname LOG_comp
    ].

  Definition MinBFTsubs_new (s1 : USIG_state) (s2 : LOG_state) : n_procs _ :=
    [
      MkPProc USIGname (build_m_sm USIG_update s1),
      MkPProc LOGname  (build_m_sm LOG_update s2)
    ].

  Definition MinBFTsubs_new_u (u : USIG_state) : n_procs _ :=
    [
      MkPProc USIGname (build_m_sm USIG_update u),
      MkPProc LOGname  LOG_comp
    ].

  Definition MinBFTsubs_new_l n (l : LOG_state) : n_procs _ :=
    [
      MkPProc USIGname (USIG_comp n),
      MkPProc LOGname  (build_m_sm LOG_update l)
    ].

  Definition MinBFTlocalSys (n : Rep) : MinBFTls :=
    MkLocalSystem
      (MAIN_comp n)
      (MinBFTsubs n).

  Definition MinBFTlocalSys_new
             (n  : Rep)
             (s  : MAIN_state)
             (s1 : USIG_state)
             (s2 : LOG_state) : MinBFTls :=
    MkLocalSystem
      (MinBFT_replicaSM_new n s)
      (MinBFTsubs_new s1 s2).

  Definition MinBFTsys : M_USystem MinBFTfunLevelSpace (*name -> M_StateMachine 2 msg_comp_name*) :=
    fun name =>
      match name with
      | MinBFT_replica n => MinBFTlocalSys n
      | _ => unit_ls
      end.

  Lemma MinBFTsubs_new_inj :
    forall a b c d,
      MinBFTsubs_new a b = MinBFTsubs_new c d
      -> a = c /\ b = d.
  Proof.
    introv h.
    repeat (apply eq_cons in h; repnd); GC.
    apply decomp_p_nproc in h0.
    apply decomp_p_nproc in h1.
    inversion h0; inversion h1; subst; simpl in *; auto.
  Qed.

  Lemma MinBFTlocalSys_new_inj :
    forall a1 a2 b1 b2 c1 c2 d1 d2,
      MinBFTlocalSys_new a1 b1 c1 d1 = MinBFTlocalSys_new a2 b2 c2 d2
      -> b1 = b2 /\ c1 = c2 /\ d1 = d2.
  Proof.
    introv h.
    apply decomp_LocalSystem in h; repnd; simpl in *.
    apply MinBFTsubs_new_inj in h; repnd; subst.
    inversion h0; subst; simpl in *; tcsp.
  Qed.

  Lemma MinBFTlocalSys_as_new :
    forall (r  : Rep),
      MinBFTlocalSys r
      = MinBFTlocalSys_new
          r
          (initial_state r)
          (USIG_initial r)
          LOG_initial.
  Proof.
    introv; eauto.
  Qed.

  Definition USIGlocalSys (s : USIG_state) : LocalSystem _ _  :=
    MkLocalSystem (build_mp_sm USIG_update s) [].

End USIGcomp.


From cap_machine Require Export logrel.
From iris.proofmode Require Import proofmode.
From iris.program_logic Require Import weakestpre adequacy lifting.
From stdpp Require Import base.
From cap_machine.ftlr Require Import ftlr_base interp_weakening.
From cap_machine.rules Require Import rules_base rules_Restrict.

Section fundamental.
  Context {Σ:gFunctors} {memg:memG Σ} {regg:regG Σ} {sealsg: sealStoreG Σ}
          {nainv: logrel_na_invs Σ}
          `{MachineParameters}.

  Notation D := ((leibnizO Word) -n> iPropO Σ).
  Notation R := ((leibnizO Reg) -n> iPropO Σ).
  Implicit Types w : (leibnizO Word).
  Implicit Types interp : (D).

  Lemma PermPairFlows_interp_preserved p p' b e a :
    p <> E ->
    PermFlowsTo p' p = true →
    (□ ▷ (∀ a0 a1 a2 a3 a4,
             full_map a0

          -∗ (∀ (r1 : RegName) v, ⌜r1 ≠ PC⌝ → ⌜a0 !! r1 = Some v⌝ → (fixpoint interp1) v)
          -∗ registers_mapsto (<[PC:=WCap a1 a2 a3 a4]> a0)
          -∗ na_own logrel_nais ⊤
          -∗ □ (fixpoint interp1) (WCap a1 a2 a3 a4) -∗ interp_conf)) -∗
    (fixpoint interp1) (WCap p b e a) -∗
    (fixpoint interp1) (WCap p' b e a).
  Proof.
    intros HpnotE Hp. iIntros "#IH HA".
    iApply (interp_weakening with "IH HA"); eauto; try solve_addr.
  Qed.

  Lemma match_perm_with_E_rewrite:
    forall (A: Type) p (a1 a2: A),
      match p with
      | E => a1
      | _ => a2
      end = if (perm_eq_dec p E) then a1 else a2.
  Proof.
    intros. destruct (perm_eq_dec p E); destruct p; auto; congruence.
  Qed.

  Lemma restrict_case (r : leibnizO Reg) (p : Perm)
        (b e a : Addr) (w : Word) (dst : RegName) (r0 : Z + RegName) (P:D):
    ftlr_instr r p b e a w (Restrict dst r0) P.
  Proof.
    intros Hp Hsome i Hbae Hi.
    iIntros "#IH #Hinv #Hinva #Hreg #[Hread Hwrite] Hown Ha HP Hcls HPC Hmap".
    rewrite delete_insert_delete.
    iDestruct ((big_sepM_delete _ _ PC) with "[HPC Hmap]") as "Hmap /=";
      [apply lookup_insert|rewrite delete_insert_delete;iFrame|]. simpl.
    iApply (wp_Restrict with "[$Ha $Hmap]"); eauto.
    { simplify_map_eq; auto. }
    { rewrite /subseteq /map_subseteq /set_subseteq_instance. intros rr _.
      apply elem_of_dom. apply lookup_insert_is_Some'; eauto. }

    iIntros "!>" (regs' retv). iDestruct 1 as (HSpec) "[Ha Hmap]".
    destruct HSpec as [ * Hdst ? Hz Hfl HincrPC | * Hdst Hz Hfl HincrPC | ].
    { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') .

      assert (a'' = a ∧ b'' = b ∧ e'' = e) as (-> & -> & ->).
      { destruct (decide (PC = dst)); simplify_map_eq; auto. }

      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext; iIntros "_".
      iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri v Hri Hvs).
        subst regs'.
        rewrite lookup_insert_ne in Hvs; auto.
        destruct (decide (ri = dst)).
        { subst ri.
          rewrite lookup_insert_ne in Hdst; auto.
          rewrite lookup_insert in Hvs; inversion Hvs. simplify_eq.
          unshelve iSpecialize ("Hreg" $! dst _ _ Hdst); eauto.
          iApply (interp_weakening with "IH Hreg"); auto; solve_addr. }
        { repeat (rewrite lookup_insert_ne in Hvs); auto.
          iApply "Hreg"; auto. } }
        { subst regs'. rewrite insert_insert. iApply "Hmap". }
      iModIntro.
      iApply (interp_weakening with "IH Hinv"); auto; try solve_addr.
      { destruct Hp; by subst p. }
      { destruct (reg_eq_dec PC dst) as [Heq | Hne]; simplify_map_eq.
        auto. by rewrite PermFlowsToReflexive. }
    }
    { apply incrementPC_Some_inv in HincrPC as (p''&b''&e''&a''& ? & HPC & Z & Hregs') .

      assert (dst ≠ PC) as Hne.
      { destruct (decide (PC = dst)); last auto. simplify_map_eq; auto. }

      assert (p'' = p ∧ b'' = b ∧ e'' = e ∧ a'' = a) as (-> & -> & -> & ->).
      { simplify_map_eq; auto. }

      iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext; iIntros "_".
      iApply ("IH" $! regs' with "[%] [] [Hmap] [$Hown]").
      { cbn. intros. subst regs'. by repeat (apply lookup_insert_is_Some'; right). }
      { iIntros (ri v Hri Hvs).
        subst regs'.
        rewrite lookup_insert_ne in Hvs; auto.
        destruct (decide (ri = dst)).
        { subst ri.
          rewrite lookup_insert_ne in Hdst; auto.
          rewrite lookup_insert in Hvs; inversion Hvs. simplify_eq.
          unshelve iSpecialize ("Hreg" $! dst _ _ Hdst); eauto.
          iApply (interp_weakening_ot with "Hreg"); auto; solve_addr. }
        { repeat (rewrite lookup_insert_ne in Hvs); auto.
          iApply "Hreg"; auto. } }
        { subst regs'. rewrite insert_insert. iApply "Hmap". }
      iModIntro.
      iApply (interp_weakening with "IH Hinv"); auto; try solve_addr.
      { destruct Hp; by subst p. }
      { by rewrite PermFlowsToReflexive. }
    }
     { iApply wp_pure_step_later; auto.
      iMod ("Hcls" with "[HP Ha]");[iExists w;iFrame|iModIntro].
      iNext; iIntros "_".
      iApply wp_value; auto. iIntros; discriminate. }
  Qed.

End fundamental.


(* Construction of a PDM using the monad G *)

From Coq Require Import Utf8 RelationClasses.
From PDM Require Import util structures guarded PURE PDM.

Set Default Goal Selector "!".
Set Printing Projections.
Set Universe Polymorphism.
Unset Universe Minimization ToSet.

Class LeafPred (M : Type → Type) :=
  leaf : ∀ A, A → M A → Prop.

Notation "x ∈ c" := (leaf _ x c) (at level 80).

Class Leafine M (hleaf : LeafPred M) :=
  leafine : ∀ A (c : M A), M { x : A | x ∈ c }.

Arguments leafine {_ _ _} [_].

Section Guarded.

  (* Computation monad *)

  Context {M} `{Monad M}.

  (* Specification monad *)

  Context {W} `{Monad W} {Word : Order W} (hmono : MonoSpec W).

  (* Effect observation *)

  Context {θ : observation M W} (hlax : LaxMorphism θ).

  Arguments θ [_].

  (* We require a LiftPred, which is used to define bind for Mᴳ below *)

  Context (leafpred : LeafPred M) (hleaf : Leafine M leafpred).

  (* Using this we build Mᴳ, a new computation monad with req *)

  Definition Mᴳ A := G (M A).

  #[refine] Instance Monad_Mᴳ : Monad Mᴳ := {|
    ret A x := ret (M := G) (ret x)
  |}.
  Proof.
    hnf. intros A B c f.
    exists (∃ (h : c.π1), ∀ x, x ∈ c.π2 h → (f x).π1). intro h.
    simple refine (bind (leafine (c.π2 _)) (λ x, (f (val x)).π2 _)).
    - apply h.
    - destruct h as [hp h]. destruct x as [x hx]. apply h.
      apply hx.
  Defined.

  Instance ReqMonad_Mᴳ : ReqMonad Mᴳ := {|
    req p := bind (req p) (λ h, ret (M := G) (ret (M := M) h))
  |}.

  (* Now we extend the spec monad with req, we do this using a liftᵂ *)
  (* TODO: Should it generally be built this way? *)

  Context (liftᵂ : spec_lift_pure W).

  Arguments liftᵂ [_].

  Instance ReqMonad_W : ReqMonad W := {|
    req p := liftᵂ (req p)
  |}.

  (* New effect observation *)

  Definition θᴳ : observation Mᴳ W :=
    λ A c, bind (req c.π1) (λ h, θ (c.π2 h)).

  (* We try (and for now fail) to extend the lax monad morphism proof *)
  (* Instance hreqlax : ReqLaxMorphism Word θᴳ.
  Proof.
    constructor. 1: constructor.
    - intros A x.
      unfold θᴳ.
      simpl. etransitivity.
      + eapply bind_mono.
        * admit. (* Maybe we need refl *)
        * intro y. apply θ_ret.
      + (* Would the laws help here? Not clear. *)
        admit.
    - intros A B c f.
      unfold θᴳ. simpl. (* Might be hard to find a general case here *)
      admit.
    - intro p.
      unfold θᴳ. cbn - [pure_wp_reqmon].
      (* Not even clear it works *)
      admit.
  Abort. *)

  (* Until we find the proper assumptions, we will assume it *)
  Context (θᴳ_lax : LaxMorphism θᴳ) (θᴳ_reqlax : ReqLaxMorphism Word θᴳ).

  (* Partial Dijkstra monad *)

  Definition D A w :=
    PDM.D (θ := θᴳ) A w.

  Instance DijkstraMonad_D : DijkstraMonad D :=
    PDM.DijkstraMonad_D hmono θᴳ_lax.

  (* Lift from PURE *)

  (* Same here, we try (and for now fail) to define a lift from PURE *)
  Instance hlift : PureSpec W Word liftᵂ.
  Proof.
    constructor.
    intros A w f.
    simpl.
  Abort.

  (* So we just assume it: *)
  Context (hlift : PureSpec W Word liftᵂ).

  Definition liftᴾ :=
    liftᴾ (M := Mᴳ) (W := W) hmono θᴳ_lax θᴳ_reqlax hlift.

End Guarded.