(* En este archivo se demuestra la corrección de la acción stop *)
Require Export Exec.
Require Export Implementacion.
Require Export AuxFunsCorrect.
Require Export ListAuxFuns.
Require Import Classical.
Require Import Estado.
Require Import DefBasicas.
Require Import EqTheorems.
Require Import Semantica.
Require Import Operaciones.
Require Import ErrorManagement.
Require Import Maps.
Require Import Tacticas.
Require Import ValidStateLemmas.

Section Stop.

Lemma stopCorrect : forall (s:System) (ic:iCmp) (sValid: validstate s),
    (pre (stop ic) s) -> post_stop ic s (stop_post ic s).
Proof.
    intros.
    unfold post_stop.
    split. simpl; auto.
    simpl in H.
    unfold pre_stop in H;simpl in H.
    destruct H.
    unfold stop_post.
    unfold insNotInState.
    simpl.
    split;intros.
    rewrite valueDropValue in H0.
    destruct H0.
    auto.
    split;intros.
    elim (classic (ic=ic'));intros.
    right;auto.
    left.
    apply valueDropValue.
    auto.
    split.
    apply dropPreservesCorrectness.
    apply runningCorrect;auto.
    split;intros.
    apply valueDropNotValue.
    unfold removeTPerms.
    split;intros.
    rewrite valueDropThenValue in H0.
    destruct H0.
    auto.
    split;intros.
    elim (classic (ic'=ic));intros.
    right;auto.
    left.
    apply valueDropThenValue.
    split;auto.
    unfold not;intros.
    apply H1.
    rewrite filter_In in H2.
    destruct H2.
    simpl in H3.
    destruct iCmp_eq in H3.
    auto.
    discriminate H3.
    split;intros.
    elim (classic (In (ic,cp,u) (filter (fun tuple : iCmp * CProvider * uri => if iCmp_eq ic (fst (fst tuple)) then true else false) (map_getKeys (delTPerms (state s))))));intros.
    apply valueDropAllNotValue.
    auto.
    assert (map_apply deltpermsdomeq (dropAll (iCmp * CProvider * uri) PType deltpermsdomeq (filter (fun tuple : iCmp * CProvider * uri => if iCmp_eq ic (fst (fst tuple)) then true else false) (map_getKeys (delTPerms (state s)))) (delTPerms (state s))) (ic, cp, u) = map_apply deltpermsdomeq (delTPerms (state s)) (ic,cp,u)).
    apply dropNotIn;auto.
    rewrite H1.
    unfold not;intros.
    apply H0.
    rewrite filter_In.
    simpl.
    split.
    unfold map_getKeys.
    rewrite in_map_iff.
    unfold is_Value in H2.
    case_eq (map_apply deltpermsdomeq (delTPerms (state s)) (ic, cp, u));intros.
    rewrite valueIffExists in H3.
    exists {| item_index := (ic, cp, u); item_info := p |}.
    simpl.
    auto.
    apply (delTPermsCorrect);auto.
    rewrite H3 in H2.
    inversion H2.
    destruct iCmp_eq;auto.

    repeat (split;auto).
    apply dropAllPreservesCorrectness.
    apply delTPermsCorrect;auto.
Qed.

Lemma notPreStopThenError : forall (s:System) (ic:iCmp), ~(pre (stop ic) s) -> validstate s -> exists ec : ErrorCode, response (step s (stop ic)) = error ec /\ ErrorMsg s (stop ic) ec /\ s = system (step s (stop ic)).
Proof.
    intros.
    simpl.
    simpl in H.
    unfold pre_stop in H.
    unfold stop_safe.
    unfold stop_pre.
    case_eq(is_ValueBool (map_apply iCmp_eq (running (state s)) ic));intros.
    destruct H.
    unfold is_ValueBool in H1.
    case_eq ((map_apply iCmp_eq (running (state s)) ic));intros;rewrite H in H1;simpl in H1.
    exists c;auto.
    discriminate H1.
    exists instance_not_running.
    split;auto.
    split;auto.
    invertBool H1.
    intro;apply H1.
    unfold is_ValueBool.
    unfold is_Value in H2.
    case_eq ((map_apply iCmp_eq (running (state s)) ic));intros;rewrite H3 in H2;simpl in H2;auto.
Qed.

Lemma stopIsSound : forall (s:System) (ic:iCmp) (sValid: validstate s),
        exec s (stop ic) (system (step s (stop ic))) (response (step s (stop ic))).
Proof.
    intros.
    unfold exec.
    split.
    auto.
    elim (classic (pre (stop ic) s));intro.
    left.
    simpl.
    assert(stop_pre ic s = None).
    unfold stop_pre.
    destruct H.
    unfold is_ValueBool.
    rewrite H.
    auto.

    unfold stop_safe;simpl.
    rewrite H0;simpl.
    split;auto.
    split;auto.
    apply stopCorrect;auto.
    right.
    apply notPreStopThenError;auto.

Qed.
End Stop.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import TableWalk.Spec.
Require Import AbsAccessor.Spec.
Require Import TableAux.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition table_unmap_spec0 (g_rd: Pointer) (map_addr: Z64) (level: Z64) (adt: RData) : option (RData * Z64) :=
    match g_rd, map_addr, level with
    | (_g_rd_base, _g_rd_ofst), VZ64 _map_addr, VZ64 _level =>
      rely is_int64 (_level - 1);
      rely is_int64 _map_addr;
      when adt == table_walk_lock_unlock_spec (_g_rd_base, _g_rd_ofst) (VZ64 _map_addr) (VZ64 (_level - 1)) adt;
      when'' _g_llt_base, _g_llt_ofst == get_wi_g_llt_spec  adt;
      rely is_int _g_llt_ofst;
      when' _index == get_wi_index_spec  adt;
      rely is_int64 _index;
      when _t'7 == is_null_spec (_g_llt_base, _g_llt_ofst) adt;
      rely is_int _t'7;
      if (_t'7 =? 1) then
        let _ret := 1 in
        Some (adt, (VZ64 _ret))
      else
        when'' _ll_table_base, _ll_table_ofst, adt == granule_map_spec (_g_llt_base, _g_llt_ofst) 5 adt;
        rely is_int _ll_table_ofst;
        when' _llt_pgte == pgte_read_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) adt;
        rely is_int64 _llt_pgte;
        if (_level <? 3) then
          when _t'6 == entry_is_table_spec (VZ64 _llt_pgte) adt;
          rely is_int _t'6;
          let _t'5 := (_t'6 =? 1) in
          if _t'5 then
            let _ret := 1 in
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
          else
            rely is_int64 (Z.land _llt_pgte 281474976706560);
            let _data_addr := (Z.land _llt_pgte 281474976706560) in
            rely is_int64 (Z.land _llt_pgte 504403158265495552);
            rely is_int64 ((Z.land _llt_pgte 504403158265495552) / 72057594037927936);
            let _ipa_state := ((Z.land _llt_pgte 504403158265495552) / 72057594037927936) in
            if (_ipa_state =? 2) then
              rely is_int64 (1 * 72057594037927936);
              rely is_int64 (Z.lor (1 * 72057594037927936) _data_addr);
              let _new_pgte := (Z.lor (1 * 72057594037927936) _data_addr) in
              rely is_int64 _new_pgte;
              when adt == pgte_write_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) (VZ64 _new_pgte) adt;
              if (_level =? 3) then
                when adt == invalidate_page_spec (VZ64 _map_addr) adt;
                let _ret := 0 in
                when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
                when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
                Some (adt, (VZ64 _ret))
              else
                when adt == invalidate_block_spec (VZ64 _map_addr) adt;
                let _ret := 0 in
                when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
                when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
                Some (adt, (VZ64 _ret))
            else
              let _ret := 1 in
              when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
              when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
              Some (adt, (VZ64 _ret))
        else
          let _t'5 := 0 in
          rely is_int64 (Z.land _llt_pgte 281474976706560);
          let _data_addr := (Z.land _llt_pgte 281474976706560) in
          rely is_int64 (Z.land _llt_pgte 504403158265495552);
          rely is_int64 ((Z.land _llt_pgte 504403158265495552) / 72057594037927936);
          let _ipa_state := ((Z.land _llt_pgte 504403158265495552) / 72057594037927936) in
          if (_ipa_state =? 2) then
            rely is_int64 (1 * 72057594037927936);
            rely is_int64 (Z.lor (1 * 72057594037927936) _data_addr);
            let _new_pgte := (Z.lor (1 * 72057594037927936) _data_addr) in
            rely is_int64 _new_pgte;
            when adt == pgte_write_spec (_ll_table_base, _ll_table_ofst) (VZ64 _index) (VZ64 _new_pgte) adt;
            if (_level =? 3) then
              when adt == invalidate_page_spec (VZ64 _map_addr) adt;
              let _ret := 0 in
              when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
              when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
              Some (adt, (VZ64 _ret))
            else
              when adt == invalidate_block_spec (VZ64 _map_addr) adt;
              let _ret := 0 in
              when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
              when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
              Some (adt, (VZ64 _ret))
          else
            let _ret := 1 in
            when adt == buffer_unmap_spec (_ll_table_base, _ll_table_ofst) adt;
            when adt == granule_unlock_spec (_g_llt_base, _g_llt_ofst) adt;
            Some (adt, (VZ64 _ret))
     end
    .

End SpecLow.


Require compcert.backend.Mach.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Globalenvs.
Import Events.
Import Smallstep.
Import Locations.
Import Conventions.
Export Mach.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

(** Execution of Mach functions with Asm-style arguments (long long 64-bit integers NOT allowed) *)

Inductive initial_state (lm: regset) (init_sp: val) (p: Mach.program) (i: ident) (sg: signature) (args: list val) (m: mem): state -> Prop :=
| initial_state_intro
    b
    (Hb: Genv.find_symbol (Genv.globalenv p) i = Some b)
    (Hargs: extcall_arguments lm m init_sp sg args)
  :
      initial_state lm init_sp p i sg args m (Callstate nil b lm m)
.

Definition get_pair (p: rpair mreg) (m: regset): val :=
  match p with
    | One l => m l
    | Twolong l1 l2 => Val.longofwords (m l1) (m l2)
  end.

Inductive final_state (lm: regset) (sg: signature): state -> (val * mem) -> Prop :=
| final_state_intro
    rs
    v
    (Hv: v = get_pair (loc_result sg) rs)
    (** Callee-save registers.
        We use Val.lessdef instead of eq because the Stacking pass does not exactly preserve their values. *)
    (CALLEE_SAVE: forall r,
       ~ In r destroyed_at_call ->
       Val.lessdef (lm r) (rs r))
    m :
    final_state lm sg (Returnstate nil rs m) (v, m)
.

Definition semantics
           (return_address_offset: function -> code -> ptrofs -> Prop)
           (lm: regset) (init_sp init_ra: val)
           (p: Mach.program) (i: ident) (sg: signature) (args: list val) (m: mem) :=
  Semantics
    (Mach.step init_sp init_ra return_address_offset)
    (initial_state lm init_sp p i sg args m)
    (final_state lm sg)
    (Genv.globalenv p).

End WITHCONFIG.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Require Import VerdiRaft.CommonTheorems.
Require Import VerdiRaft.CroniesCorrectInterface.
Require Import VerdiRaft.VotesCorrectInterface.
Require Import VerdiRaft.TermSanityInterface.
Require Import VerdiRaft.CroniesTermInterface.

Require Import VerdiRaft.RefinementCommonTheorems.

Require Import VerdiRaft.SpecLemmas.

Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.CandidateEntriesInterface.

Section CandidateEntriesProof.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {cti : cronies_term_interface}.
  Context {tsi : term_sanity_interface}.
  Context {vci : votes_correct_interface}.
  Context {cci : cronies_correct_interface}.

  Lemma handleClientRequest_spec :
    forall h d client id c out d' l,
      handleClientRequest h d client id c = (out, d', l) ->
      currentTerm d' = currentTerm d /\
      type d' = type d /\
      l = [] /\
      (forall e, In e (log d') ->
            (In e (log d) \/ (e = (mkEntry
                                     h
                                     client
                                     id
                                     (S (maxIndex (log d)))
                                     (currentTerm d)
                                     c) /\ log d' = e :: log d /\ type d' = Leader))).
  Proof using.
    intros. unfold handleClientRequest in *.
    break_match; find_inversion; intuition.
    simpl in *. intuition. subst. auto.
  Qed.

  Lemma candidate_entries_client_request :
    refined_raft_net_invariant_client_request CandidateEntries.
  Proof using cci.
    unfold refined_raft_net_invariant_client_request, CandidateEntries.
    intros. subst.
    intuition.
    - unfold candidateEntries_host_invariant in *.
      intros; simpl in *.
      eapply candidateEntries_ext; try eassumption.
      repeat find_higher_order_rewrite.
      unfold update_elections_data_client_request in *. repeat break_let. simpl in *.
      destruct (name_eq_dec h0 h); subst.
      + rewrite_update.
        unfold update_elections_data_client_request in *. repeat break_let. simpl in *.
        simpl in *. find_inversion.
        find_apply_lem_hyp handleClientRequest_spec; intuition eauto.
        find_apply_hyp_hyp.
        intuition.
        * rewrite_update.
          eapply candidateEntries_same; eauto; intuition;
          destruct (name_eq_dec h0 h); subst; rewrite_update; auto.
          repeat break_match; simpl; auto.
        * find_apply_lem_hyp cronies_correct_invariant.
          unfold candidateEntries. exists h.
          intuition; rewrite_update; simpl in *; try congruence.
          repeat find_rewrite. simpl in *.
          repeat break_match; simpl; pose won_election_cronies; eauto.
      + rewrite_update.
        find_apply_lem_hyp handleClientRequest_spec.
        eapply candidateEntries_same; eauto; intuition;
        destruct (name_eq_dec h1 h); subst; rewrite_update; auto;
        tuple_inversion; repeat find_rewrite;
        repeat break_match; simpl; auto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; try eassumption.
      find_apply_lem_hyp handleClientRequest_spec.
      intuition.
      subst. simpl in *.

      eapply_prop_hyp candidateEntries AppendEntries; eauto.
      + eapply candidateEntries_same; eauto; intuition;
        destruct (name_eq_dec h h0); subst; rewrite_update; auto.
        unfold update_elections_data_client_request; repeat break_match; simpl; auto.
      + find_apply_hyp_hyp. intuition.
  Qed.

  Lemma update_elections_data_timeout_leader_cronies_same :
    forall sigma h,
      type (snd (sigma h)) = Leader ->
      cronies (update_elections_data_timeout h (sigma h)) =
      cronies (fst (sigma h)).
  Proof using.
    unfold update_elections_data_timeout.
    intros.
    repeat break_match; subst; simpl in *; auto.
    unfold handleTimeout, tryToBecomeLeader in *.
    repeat break_match; try congruence; repeat find_inversion; simpl in *;
    unfold raft_data in *;
    congruence.
  Qed.

  Lemma handleTimeout_only_sends_RequestVotes :
    forall h d out d' l p,
      handleTimeout h d = (out, d', l) ->
      In p l ->
      exists t h' maxi maxt,
        snd p = RequestVote t h' maxi maxt.
  Proof using.
    unfold handleTimeout, tryToBecomeLeader.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; intuition;
    do_in_map; subst; simpl; eauto.
  Qed.

  Lemma handleTimeout_not_leader_inc_term :
    forall h d out d' l,
      handleTimeout h d = (out, d', l) ->
      type d <> Leader ->
      currentTerm d' = S (currentTerm d).
  Proof using.
    unfold handleTimeout, tryToBecomeLeader.
    intros. simpl in *.
    repeat break_match; try congruence; repeat find_inversion; auto.
  Qed.

  Lemma update_elections_data_timeout_cronies :
    forall h d out d' l t,
      handleTimeout h (snd d) = (out, d', l) ->
      cronies (update_elections_data_timeout h d) t = cronies (fst d) t \/
      (t = currentTerm d' /\
       cronies (update_elections_data_timeout h d) t = votesReceived d').
  Proof using.
    unfold update_elections_data_timeout.
    intros.
    repeat break_match; repeat find_inversion; simpl; auto.
    break_match; auto.
  Qed.

  Lemma handleTimeout_preserves_candidateEntries :
    forall net h e out d l,
      refined_raft_intermediate_reachable net ->
      handleTimeout h (snd (nwState net h)) = (out, d, l) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (update_elections_data_timeout h (nwState net h), d)).
  Proof using cti.
    intros.
    destruct (serverType_eq_dec (type (snd (A:=electionsData) (B:=raft_data) (nwState net h))) Leader).
      + (* Leader case *)
        unfold handleTimeout, tryToBecomeLeader in *. simpl in *.
        find_rewrite. find_inversion.

        eapply candidateEntries_same; eauto;
        intros;
        repeat (rewrite update_fun_comm; simpl in * );
        update_destruct; subst; rewrite_update;
        auto using update_elections_data_timeout_leader_cronies_same.
      + (* non-Leader case *)

        unfold candidateEntries in *.
        break_exists. break_and.
        exists x.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm; simpl.
        rewrite update_fun_comm with (f := type); simpl.
        update_destruct; subst; rewrite_update; auto.
        split.
        * match goal with
          | [ H : handleTimeout _ _ = _ |- _ ] =>
            pose proof H;
              apply update_elections_data_timeout_cronies with (t := eTerm e) in H
          end.
          intuition; find_rewrite; auto.
          find_apply_lem_hyp wonElection_exists_voter.
          break_exists.
          find_apply_lem_hyp in_dedup_was_in.
          find_copy_apply_lem_hyp cronies_term_invariant; auto.
          find_copy_apply_lem_hyp handleTimeout_not_leader_inc_term; auto.
          simpl in *.
          lia.
        * intros.
          find_apply_lem_hyp wonElection_exists_voter.
          break_exists.
          find_apply_lem_hyp in_dedup_was_in.
          find_copy_apply_lem_hyp cronies_term_invariant; auto.
          find_copy_apply_lem_hyp handleTimeout_not_leader_inc_term; auto.
          simpl in *.
          lia.
  Qed.

  Lemma candidate_entries_timeout :
    refined_raft_net_invariant_timeout CandidateEntries.
  Proof using cti.
    unfold refined_raft_net_invariant_timeout, CandidateEntries.
    intros. subst.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; try eassumption.
      repeat find_higher_order_rewrite.

        find_rewrite_lem update_fun_comm. simpl in *.
        find_rewrite_lem update_fun_comm. simpl in *.
        find_erewrite_lem handleTimeout_log_same.

        find_rewrite_lem_by update_nop_ext' auto.
        find_apply_hyp_hyp.
        eauto using handleTimeout_preserves_candidateEntries.
    - unfold candidateEntries_nw_invariant in *.
      intros.
      simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      break_or_hyp.
      + eapply_prop_hyp pBody pBody; eauto.
        eauto using handleTimeout_preserves_candidateEntries.
      + do_in_map. subst. simpl in *.
        eapply handleTimeout_only_sends_RequestVotes in H8; eauto.
        break_exists. congruence.
  Qed.

  Lemma update_elections_data_appendEntries_cronies_same :
    forall h d t n pli plt es ci,
      cronies (update_elections_data_appendEntries h d t n pli plt es ci) =
      cronies (fst d).
  Proof using.
    unfold update_elections_data_appendEntries.
    intros.
    repeat break_match; auto.
  Qed.

  Lemma handleAppendEntries_spec :
    forall h st t n pli plt es ci st' m,
      handleAppendEntries h st t n pli plt es ci = (st', m) ->
      (currentTerm st <= currentTerm st' /\
       (forall e,
          In e (log st') ->
          In e (log st) \/
          In e es /\ currentTerm st' = t) /\
       ~ is_append_entries m).
  Proof using.
    intros.
    unfold handleAppendEntries, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition; try solve [break_exists; congruence];
    in_crush; eauto using removeAfterIndex_in.
  Qed.

  Lemma handleAppendEntries_term_same_or_type_follower :
    forall h t n pli plt es ci d m st,
      handleAppendEntries h st t n pli plt es ci = (d, m) ->
      (currentTerm d = currentTerm st /\ type d = type st) \/ type d = Follower.
  Proof using.
    unfold handleAppendEntries in *.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; auto; try congruence.
  Qed.

  Lemma handleAppendEntries_preserves_candidate_entries :
    forall net h t n pli plt es ci d m e,
      handleAppendEntries h (snd (nwState net h)) t n pli plt es ci = (d, m) ->
      refined_raft_intermediate_reachable net ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h
                                 (update_elections_data_appendEntries
                                    h
                                    (nwState net h) t n pli plt es ci, d)).
  Proof using.
    unfold candidateEntries.
    intros. break_exists. break_and.
    exists x.
    split.
    - rewrite update_fun_comm. simpl.
      rewrite update_fun_comm. simpl.
      rewrite update_elections_data_appendEntries_cronies_same.
      destruct (name_eq_dec x h); subst; rewrite_update; auto.
    - intros.
      rewrite update_fun_comm. simpl.
      find_rewrite_lem update_fun_comm. simpl in *.
      destruct (name_eq_dec x h); subst; rewrite_update; auto.
      find_apply_lem_hyp handleAppendEntries_term_same_or_type_follower.
      intro; intuition;
      repeat find_rewrite; auto; discriminate.
  Qed.

  Lemma is_append_entries_intro :
    forall t n plt pli es ci,
      is_append_entries (AppendEntries t n pli plt es ci).
  Proof using.
    eauto 20.
  Qed.

  Lemma candidate_entries_append_entries :
    refined_raft_net_invariant_append_entries CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros. subst.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; subst; rewrite_update;
      eapply handleAppendEntries_preserves_candidate_entries; eauto.
      find_copy_apply_lem_hyp handleAppendEntries_spec. break_and.
      find_apply_hyp_hyp. intuition eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      intuition.
      + eapply handleAppendEntries_preserves_candidate_entries; eauto.
      + subst. simpl in *. find_apply_lem_hyp handleAppendEntries_spec.
        break_and.
        subst.
        exfalso.
        eauto using is_append_entries_intro.
  Qed.

  Lemma handleAppendEntriesReply_spec :
    forall h st h' t es r st' ms,
      handleAppendEntriesReply h st h' t es r = (st', ms) ->
      log st' = log st /\
      ((currentTerm st' = currentTerm st /\ type st' = type st)
       \/ type st' = Follower) /\
      (forall m, In m ms -> ~ is_append_entries (snd m)).
  Proof using.
    intros.
    unfold handleAppendEntriesReply, advanceCurrentTerm in *.
    repeat break_match; try find_inversion; subst; simpl in *; intuition;
    do_bool; intuition.
  Qed.

  Lemma handleAppendEntriesReply_preserves_candidate_entries :
    forall net h h' t es r st' ms e,
      handleAppendEntriesReply h (snd (nwState net h)) h' t es r = (st', ms) ->
      refined_raft_intermediate_reachable net ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (fst (nwState net h), st')).
  Proof using.
    unfold candidateEntries.
    intros. break_exists. break_and.
    exists x.
    split.
    - rewrite update_fun_comm. simpl.
      rewrite update_fun_comm. simpl.
      update_destruct; subst; rewrite_update; auto.
    - intros. update_destruct; subst; rewrite_update; auto.
      simpl in *.
      find_apply_lem_hyp handleAppendEntriesReply_spec.
      intuition; repeat find_rewrite; intuition.
      congruence.
  Qed.

  Ltac prove_in :=
    match goal with
      | [ _ : nwPackets ?net = _,
              _ : In ?p _ |- _] =>
        assert (In p (nwPackets net)) by (repeat find_rewrite; do_in_app; intuition)
      | [ _ : nwPackets ?net = _,
              _ : pBody ?p = _ |- _] =>
        assert (In p (nwPackets net)) by (repeat find_rewrite; intuition)
    end.

  Lemma candidate_entries_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply CandidateEntries.
  Proof using.
    red. unfold CandidateEntries. intros. intuition.
    - unfold candidateEntries_host_invariant in *.
      intros. simpl in *. eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct.
      + subst. rewrite_update.
        unfold candidateEntries in *.
        find_apply_lem_hyp handleAppendEntriesReply_spec. break_and.
        repeat find_rewrite.
        find_apply_hyp_hyp.
        break_exists; exists x; eauto.
        update_destruct; intuition; subst; rewrite_update; simpl in *; auto;
        repeat find_rewrite; intuition; congruence.
      + rewrite_update. find_apply_hyp_hyp.
        eauto using handleAppendEntriesReply_preserves_candidate_entries.
    - unfold candidateEntries_nw_invariant in *. intros. simpl in *.
      find_apply_hyp_hyp. intuition.
      + (* packet already in nw *)
        prove_in.
        eapply candidateEntries_ext; eauto.
        find_eapply_lem_hyp handleAppendEntriesReply_preserves_candidate_entries; eauto.
        subst. auto.
      + exfalso.
        do_in_map.
        find_eapply_lem_hyp handleAppendEntriesReply_spec; eauto.
        subst. simpl in *. find_rewrite.
        match goal with
          | H : ~ is_append_entries _ |- _ => apply H
        end.
        repeat eexists; eauto.
  Qed.

  Lemma update_elections_data_requestVote_cronies_same :
    forall h h' t lli llt st,
      cronies (update_elections_data_requestVote h h' t h' lli llt st) =
      cronies (fst st).
  Proof using.
    unfold update_elections_data_requestVote.
    intros.
    repeat break_match; auto.
  Qed.

  Lemma advanceCurrentTerm_same_or_type_follower :
    forall st t,
      advanceCurrentTerm st t = st \/
      type (advanceCurrentTerm st t) = Follower.
  Proof using.
    unfold advanceCurrentTerm.
    intros. repeat break_match; auto.
  Qed.

  Lemma handleRV_advanceCurrentTerm_preserves_candidateEntries :
    forall net h h' t lli llt e,
      candidateEntries e (nwState net) ->
      candidateEntries e
                       (update name_eq_dec (nwState net) h
                               (update_elections_data_requestVote h h' t h' lli llt (nwState net h),
                                advanceCurrentTerm (snd (nwState net h)) t)).
  Proof using.
    intros.
    unfold candidateEntries in *.
    break_exists.  break_and.
    exists x.
    split; update_destruct; subst; rewrite_update; auto; simpl.
    + rewrite update_elections_data_requestVote_cronies_same. auto.
    + intros.
      match goal with
      | [ |- context [advanceCurrentTerm ?st ?t] ] =>
        pose proof advanceCurrentTerm_same_or_type_follower st t
      end.
      intuition; try congruence.
      repeat find_rewrite. auto.
  Qed.

  Lemma handleRequestVote_preserves_candidateEntries :
    forall net h h' t lli llt d e m,
      handleRequestVote h (snd (nwState net h)) t h' lli llt = (d, m) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h
                                 (update_elections_data_requestVote
                                    h h' t h' lli llt (nwState net h), d)).
  Proof using.
    unfold handleRequestVote.
    intros.
    repeat break_match; repeat find_inversion;
    auto using handleRV_advanceCurrentTerm_preserves_candidateEntries.
    - eapply candidateEntries_same; eauto;
        intros;
        repeat (rewrite update_fun_comm; simpl in * );
        update_destruct; subst; rewrite_update;
        auto using update_elections_data_requestVote_cronies_same.
    - do_bool. intuition. congruence.
    - unfold candidateEntries in *. break_exists. break_and. exists x.
      simpl.
      split.
      + rewrite update_fun_comm with (f := fst). simpl.
        rewrite update_fun_comm with (f := cronies). simpl.
        rewrite update_elections_data_requestVote_cronies_same.
        update_destruct; subst; rewrite_update; auto.
      + rewrite update_fun_comm with (f := snd). simpl.
        rewrite update_fun_comm with (f := currentTerm). simpl.
        rewrite update_fun_comm with (f := type). simpl.
        update_destruct; subst; rewrite_update; auto.
        match goal with
        | [ |- context [advanceCurrentTerm ?st ?t] ] =>
          pose proof advanceCurrentTerm_same_or_type_follower st t
        end.
        intuition; try congruence.
        repeat find_rewrite. auto.
  Qed.

  Lemma handleRequestVote_only_sends_RVR :
    forall d h h' t lli llt d' m,
      handleRequestVote h d t h' lli llt = (d', m) ->
      is_request_vote_reply m.
  Proof using.
    unfold handleRequestVote.
    intros.
    repeat break_match; repeat find_inversion; eauto.
  Qed.

  Lemma candidate_entries_request_vote :
    refined_raft_net_invariant_request_vote CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros. subst.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; subst; rewrite_update; simpl in *;
      try find_erewrite_lem handleRequestVote_same_log;
      eapply handleRequestVote_preserves_candidateEntries; eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp. intuition.
      + eauto using handleRequestVote_preserves_candidateEntries.
      + subst. simpl in *.
        find_apply_lem_hyp handleRequestVote_only_sends_RVR.
        subst. break_exists. discriminate.
  Qed.

  Lemma candidate_entries_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply CandidateEntries.
  Proof using cci.
    red. unfold CandidateEntries. intros. intuition.
    - unfold candidateEntries_host_invariant in *.
      intros. simpl in *. eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct.
      + subst. rewrite_update.
        match goal with
          | |- context [handleRequestVoteReply ?h ?st ?h' ?t ?r] =>
            remember (handleRequestVoteReply h st h' t r) as new_state
        end.
        find_copy_apply_lem_hyp handleRequestVoteReply_spec. break_and.
        match goal with
          | H : log _ = log _ |- _ => rewrite H in *
        end.
        find_apply_hyp_hyp.
        eapply handleRequestVoteReply_preserves_candidate_entries; eauto.
      + rewrite_update.
        eapply handleRequestVoteReply_preserves_candidate_entries; eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *. eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      eapply handleRequestVoteReply_preserves_candidate_entries; eauto.
  Qed.

  Lemma doLeader_in_entries :
    forall (h : name) d h os d' ms m t li pli plt es ci e,
      doLeader d h = (os, d', ms) ->
      snd m = AppendEntries t li pli plt es ci ->
      In m ms ->
      In e es ->
      In e (log d).
  Proof using.
    unfold doLeader.
    intros.
    repeat break_match; repeat find_inversion; simpl in *; intuition.
    do_in_map.

    unfold replicaMessage in *. simpl in *. subst. simpl in *.
    find_inversion.
    eauto using findGtIndex_in.
  Qed.

  Lemma candidate_entries_do_leader :
    refined_raft_net_invariant_do_leader CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      update_destruct; subst; rewrite_update.
      + simpl in *.
        find_erewrite_lem doLeader_same_log.
        repeat match goal with
        | [ H : nwState ?net ?h = (_, ?d), H' : context [ log ?d ] |- _ ] =>
          replace (log d) with (log (snd (nwState net h))) in H' by (repeat find_rewrite; auto)
        end.
        pose doLeader_preserves_candidateEntries; eauto.
      + pose doLeader_preserves_candidateEntries; eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      intuition.
      + pose doLeader_preserves_candidateEntries; eauto.
      + do_in_map. subst. simpl in *.
        eapply doLeader_preserves_candidateEntries; eauto.
        eapply_prop candidateEntries_host_invariant.
        match goal with
        | [ H : _ |- _ ] => rewrite H
        end.
        simpl.
        eauto using doLeader_in_entries.
  Qed.

  Lemma doGenericServer_same_type :
    forall h d os d' ms,
      doGenericServer h d = (os, d', ms) ->
      type d' = type d.
  Proof using.
    unfold doGenericServer.
    intros.
    repeat break_match; repeat find_inversion;
    use_applyEntries_spec; subst; simpl in *;
    auto.
  Qed.

  Lemma doGenericServer_spec :
    forall h d os d' ms,
      doGenericServer h d = (os, d', ms) ->
      (log d' = log d /\ currentTerm d' = currentTerm d /\
       (forall m, In m ms -> ~ is_append_entries (snd m))).
  Proof using.
    intros. unfold doGenericServer in *.
    repeat break_match; find_inversion; subst; intuition;
    use_applyEntries_spec; subst; simpl in *; auto.
  Qed.

  Lemma doGenericServer_preserves_candidateEntries :
    forall net gd d h os d' ms e,
      nwState net h = (gd, d) ->
      doGenericServer h d = (os, d', ms) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (gd, d')).
  Proof using.
    intros.
    eapply candidateEntries_same; eauto;
    intros;
    repeat (rewrite update_fun_comm; simpl in * );
    update_destruct; subst; rewrite_update; auto;
    repeat find_rewrite; simpl; auto.
    - find_copy_apply_lem_hyp doGenericServer_spec. break_and. auto.
    - eauto using doGenericServer_same_type.
  Qed.

  Lemma candidate_entries_do_generic_server :
    refined_raft_net_invariant_do_generic_server CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition; simpl in *.
    - unfold candidateEntries_host_invariant in *.
      intros.
      eapply candidateEntries_ext; eauto.
      repeat find_higher_order_rewrite.
      update_destruct; subst; rewrite_update.
      + simpl in *.
        find_copy_apply_lem_hyp doGenericServer_spec. break_and.
        find_rewrite.
        repeat match goal with
        | [ H : nwState ?net ?h = (_, ?d), H' : context [ log ?d ] |- _ ] =>
          replace (log d) with (log (snd (nwState net h))) in H' by (repeat find_rewrite; auto)
        end.
        eauto using doGenericServer_preserves_candidateEntries.
      + eauto using doGenericServer_preserves_candidateEntries.
    - unfold candidateEntries_nw_invariant in *.
      intros. simpl in *.
      eapply candidateEntries_ext; eauto.
      find_apply_hyp_hyp.
      intuition.
      + eauto using doGenericServer_preserves_candidateEntries.
      + do_in_map.
        find_copy_apply_lem_hyp doGenericServer_spec. break_and.
        subst. simpl in *.
        find_apply_hyp_hyp.
        exfalso.
        find_rewrite. eauto 20.
  Qed.

  Lemma candidate_entries_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition.
    - unfold candidateEntries_host_invariant in *.
      intros.
      repeat find_reverse_higher_order_rewrite.
      apply candidateEntries_ext with (sigma := nwState net); eauto.
    - unfold candidateEntries_nw_invariant in *.
      intros.
      find_apply_hyp_hyp.
      eapply_prop_hyp In In; eauto.
      apply candidateEntries_ext with (sigma := nwState net); eauto.
  Qed.

  Lemma reboot_log_same :
    forall d,
      log (reboot d) = log d.
  Proof using.
    unfold reboot.
    auto.
  Qed.

  Lemma reboot_preservers_candidateEntries :
    forall net h d gd e,
      nwState net h = (gd, d) ->
      candidateEntries e (nwState net) ->
      candidateEntries e (update name_eq_dec (nwState net) h (gd, reboot d)).
  Proof using.
    unfold reboot, candidateEntries.
    intros.
    break_exists.
    exists x.
    break_and.
    rewrite update_fun_comm. simpl in *.
    update_destruct; subst; rewrite_update; auto.
    repeat find_rewrite. simpl in *. intuition. discriminate.
  Qed.

  Lemma candidate_entries_reboot :
    refined_raft_net_invariant_reboot CandidateEntries.
  Proof using.
    red. unfold CandidateEntries.
    intros.
    intuition.
    - unfold candidateEntries_host_invariant in *.
      intros.
      repeat find_higher_order_rewrite.
      eapply candidateEntries_ext; eauto.
      subst.
      find_rewrite_lem update_fun_comm. simpl in *.
      find_rewrite_lem update_fun_comm. simpl in *.
      update_destruct; subst; rewrite_update.
      + repeat match goal with
        | [ H : nwState ?net ?h = (_, ?d), H' : context [ log ?d ] |- _ ] =>
          replace (log d) with (log (snd (nwState net h))) in H' by (repeat find_rewrite; auto)
        end.
        find_apply_hyp_hyp.
        eauto using reboot_preservers_candidateEntries.
      + eauto using reboot_preservers_candidateEntries.
    - unfold candidateEntries_nw_invariant in *.
      intros.
      repeat find_reverse_rewrite.
      eapply_prop_hyp In In; eauto.
      eapply candidateEntries_ext; eauto.
      eauto using reboot_preservers_candidateEntries.
  Qed.

  Lemma candidate_entries_init :
    refined_raft_net_invariant_init CandidateEntries.
  Proof using.
    red.
    unfold CandidateEntries.
    unfold candidateEntries_host_invariant, candidateEntries_nw_invariant.
    intuition;
     repeat match goal with
            | [ H : In _ _ |- _ ] => compute in H
            end;
    intuition.
  Qed.

  Theorem candidate_entries_invariant :
    forall (net : network),
      refined_raft_intermediate_reachable net ->
      CandidateEntries net.
  Proof using cci cti rri.
    intros.
    eapply refined_raft_net_invariant; eauto.
    - apply candidate_entries_init.
    - apply candidate_entries_client_request.
    - apply candidate_entries_timeout.
    - apply candidate_entries_append_entries.
    - apply candidate_entries_append_entries_reply.
    - apply candidate_entries_request_vote.
    - apply candidate_entries_request_vote_reply.
    - apply candidate_entries_do_leader.
    - apply candidate_entries_do_generic_server.
    - apply candidate_entries_state_same_packet_subset.
    - apply candidate_entries_reboot.
  Qed.

  Instance cei : candidate_entries_interface.
  Proof.
    split.
    auto using candidate_entries_invariant.
  Qed.
End CandidateEntriesProof.


Require Import UFO.Rel.Definitions.
Require Import UFO.Rel.BasicFacts.
Require Import UFO.Rel.Monotone.
Require Import UFO.Rel.Compat_weaken_X.
Require Import UFO.Util.Subset.
Require Import UFO.Util.Postfix.
Require Import UFO.Lang.BindingsFacts.
Require Import UFO.Lang.Static.
Set Implicit Arguments.

Local Hint Rewrite in_singleton in_union in_inter dom_single.
Local Hint Resolve subset_union_r subset_empty_l.
Local Hint Resolve 𝓥_monotone 𝓗_monotone.
Local Hint Constructors wf_XEnv.
Local Hint Constructors postfix.

Local Fact fsetfact3 (A : Type) (E : fset A) a :
a ∉ E → disjoint E \{a}.
Proof.
intro H ; apply fset_extens ; [ intros_all ; crush | auto ].
Qed.

Local Hint Resolve fsetfact3.

Section section_ccompat_tm_down.
Context (EV LV : Set).
Context (Ξ : XEnv EV LV).
Context (δ₁ δ₂ : EV → eff0) (δ : EV → IRel 𝓤_Sig).
Context (ρ₁ ρ₂ : LV → lbl0) (ρ : LV → IRel 𝓣_Sig).
Context (X : var).
Context (T : ty ∅ EV LV ∅) (E : eff ∅ EV LV ∅).

Lemma ccompat_tm_down_aux n
(FrX :
  n ⊨ ∀ᵢ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂,
      𝓤⟦ Ξ & (X ~ (T,E)) ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ t₁ t₂ ψ L₁ L₂ ⇒ (X ∉ L₁ ∧ X ∉ L₂)ᵢ
) :
n ⊨ ∀ᵢ ζ₁ ζ₂ ξ₁ ξ₂ t₁ t₂,
    𝓣⟦ Ξ & (X ~ (T,E)) ⊢ T # (ef_lbl (lbl_id (lid_f X))) :: E ⟧
      δ₁ δ₂ δ ρ₁ ρ₂ ρ
      (ζ₁ ++ X :: ξ₁) (ζ₂ ++ X :: ξ₂) t₁ t₂ ⇒
    𝓣⟦ Ξ & (X ~ (T,E)) ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ
      (ζ₁ ++ X :: ξ₁) (ζ₂ ++ X :: ξ₂)
      (ktx_plug (ktx_down ktx_hole X) t₁)
      (ktx_plug (ktx_down ktx_hole X) t₂).
Proof.
loeb_induction LöbIH.
iintro ζ₁ ; iintro ζ₂ ; iintro ξ₁ ; iintro ξ₂ ; iintro t₁ ; iintro t₂ ; iintro Ht.
apply plug1 with
  (ε := ef_lbl (lbl_id (lid_f X))) (Ta := T) (ξ₁ := ζ₁ ++ X :: ξ₁) (ξ₂ := ζ₂ ++ X :: ξ₂).
+ exact FrX.
+ iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂' ;
  iintro v₁ ; iintro v₂ ; iintro Hv.
  eapply 𝓣_step_r.
  { simpl ; apply step_down_val ; eauto. }
  eapply 𝓣_step_l.
  { simpl ; apply step_down_val ; eauto. }
  iintro_later.
  apply 𝓥_in_𝓣 ; apply Hv.
+ clear - LöbIH.
  iintro ξ₁' ; iintro ξ₂' ; iintro Hξ₁' ; iintro Hξ₂'.
  iintro K₁ ; iintro K₂ ;
  iintro s₁ ; iintro s₂ ; iintro ψ ; iintro Xs₁ ; iintro Xs₂.
  iintro H.
  iintro Xs_K₁K₂.
  iintro Hw.
  ielim_prop Xs_K₁K₂.

  simpl in H.
  idestruct H as X₁ H ; idestruct H as X₂ H ;
  idestruct H as r₁ H ; idestruct H as r₂ H ;
  idestruct H as HX₁X₂ H ; idestruct H as HXs₁Xs₂ H ;
  idestruct H as Hs₁s₂ H ; idestruct H as HX Hr.

  ielim_prop HX₁X₂ ; destruct HX₁X₂ as [HX₁ HX₂].
  ielim_prop Hs₁s₂ ; destruct Hs₁s₂ as [Hs₁ Hs₂].
  ielim_prop HXs₁Xs₂ ; destruct HXs₁Xs₂ as [HXs₁ HXs₂].
  simpl in HX₁, HX₂ ; inversion HX₁ ; inversion HX₂ ; clear HX₁ HX₂.
  subst s₁ s₂ Xs₁ Xs₂ X₁ X₂.

  rewrite get_concat in Hr.
  rewrite binds_single_eq in Hr.

  simpl.
  specialize (Xs_K₁K₂ X).
  assert (tunnels X K₁) ; [ crush | ].
  assert (tunnels X K₂) ; [ crush | ].
  eapply 𝓣_step_r.
  { apply step_down_up ; eauto. }
  eapply 𝓣_step_l.
  { apply step_down_up ; eauto. }

  unfold 𝓗_Fun in Hr.
  apply I_later_forall_down in Hr ; iespecialize Hr.
  apply I_later_forall_down in Hr ; iespecialize Hr.
  apply I_later_forall_down in Hr ; eapply I_forall_elim in Hr ; [ | apply postfix_refl ].
  apply I_later_forall_down in Hr ; eapply I_forall_elim in Hr ; [ | apply postfix_refl ].
  repeat (apply I_later_forall_down in Hr ; iespecialize Hr).
  apply I_later_arrow_down in Hr.
  erewrite I_iff_elim_M ; [ |
      eapply I_later_iff_down ; iintro_later ; apply fold_𝓥𝓤_in_𝓣
  ].
  iapply Hr.

  clear - LöbIH Hw Hξ₁' Hξ₂'.
  apply I_later_forall_up ; iintro ξ₁''.
  apply I_later_forall_up ; iintro ξ₂''.
  apply I_later_forall_up ; iintro Hξ₁''.
  apply I_later_forall_up ; iintro Hξ₂''.
  apply I_later_forall_up ; iintro t₁.
  apply I_later_forall_up ; iintro t₂.
  apply I_later_arrow_up ; iintro Ht.
  ielim_vars Hw ; [ | apply Hξ₂'' | apply Hξ₁'' ].
  iespecialize Hw.
  ispecialize Hw ; [ apply Ht | ].

  later_shift.
  erewrite <- I_iff_elim_M ; [ | apply fold_𝓥𝓤_in_𝓣 ].

  simpl ktx_plug in LöbIH.
  apply postfix_inv_app in Hξ₁'' ; destruct Hξ₁'' as [ ζ₁'' Hξ₁'' ].
  apply postfix_inv_app in Hξ₂'' ; destruct Hξ₂'' as [ ζ₂'' Hξ₂'' ].
  apply postfix_inv_app in Hξ₁' ; destruct Hξ₁' as [ ζ₁' Hξ₁' ].
  apply postfix_inv_app in Hξ₂' ; destruct Hξ₂' as [ ζ₂' Hξ₂' ].
  ispecialize LöbIH (ζ₁'' ++ ζ₁' ++ ζ₁) ;
  ispecialize LöbIH (ζ₂'' ++ ζ₂' ++ ζ₂) ;
  ispecialize LöbIH ξ₁ ;
  ispecialize LöbIH ξ₂.
  repeat rewrite <- app_assoc in LöbIH.
  rewrite <- Hξ₁', <- Hξ₂', <- Hξ₁'', <- Hξ₂'' in LöbIH.
  iespecialize LöbIH.
  ispecialize LöbIH ; [ apply Hw | ].
  apply LöbIH.
+ apply postfix_refl.
+ apply postfix_refl.
+ assumption.
Qed.

Context (FrX_Ξ : X # Ξ).
Context (Wf_Ξ : wf_XEnv Ξ).
Context (Wf_T : wf_ty Ξ T).
Context (Wf_E : wf_eff Ξ E).

Lemma ccompat_tm_down n ξ₁ ξ₂ t₁ t₂ :
n ⊨ ( ∀ᵢ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂,
      𝓤⟦ (Ξ & X ~ (T, E)) ⊢ E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁' ξ₂' t₁' t₂' ψ Xs₁ Xs₂ ⇒
      (X ∉ Xs₁ ∧ X ∉ Xs₂)ᵢ
    ) →
X ∉ from_list ξ₁ → X ∉ from_list ξ₂ →
n ⊨ 𝓣⟦ (Ξ & (X ~ (T, E))) ⊢ T # (ef_lbl (lbl_id (lid_f X))) :: E ⟧
    δ₁ δ₂ δ ρ₁ ρ₂ ρ
    (X :: ξ₁) (X :: ξ₂)
    (L_subst_tm (lid_f X) t₁) (L_subst_tm (lid_f X) t₂) →
n ⊨ 𝓣⟦ Ξ ⊢ T # E ⟧ δ₁ δ₂ δ ρ₁ ρ₂ ρ ξ₁ ξ₂ (⬇ t₁) (⬇ t₂).
Proof.
intros FrX_E FrX_ξ₁ FrX_ξ₂ Ht.
specialize (ccompat_tm_down_aux FrX_E) as H.
ispecialize H ([] : list var).
ispecialize H ([] : list var).
iespecialize H.
repeat rewrite app_nil_l in H.
simpl ktx_plug in H.

eapply 𝓣_step_r.
{ apply step_Down with (X := X) ; assumption. }
eapply 𝓣_step_l.
{ apply step_Down with (X := X) ; assumption. }

iintro_later.
iespecialize H ; ispecialize H ; [ apply Ht | ].
erewrite I_iff_elim_M ; [ apply H | apply X_weaken_𝓣 ] ; crush.
Qed.

End section_ccompat_tm_down.

Section section_compat_tm_down.
Context (n : nat).
Context (EV LV V : Set).
Context (Ξ : XEnv EV LV).
Context (Γ : V → ty ∅ EV LV ∅).
Context (Wf_Γ : wf_Γ Ξ Γ).
Context (t₁ t₂ : tm EV LV V (inc ∅)).
Context (T : ty ∅ EV LV ∅) (E : eff ∅ EV LV ∅).
Context (Wf_Ξ : wf_XEnv Ξ).
Context (Wf_T : wf_ty Ξ T).
Context (Wf_E : wf_eff Ξ E).

Lemma compat_tm_down (B : vars) :
( ∀ X, X \notin B →
  n ⊨ ⟦ (Ξ & (X ~ (T, E))) Γ ⊢
        (L_subst_tm (lid_f X) t₁) ≼ˡᵒᵍ (L_subst_tm (lid_f X) t₂) :
        T # (ef_lbl (lbl_id (lid_f X))) :: E ⟧
) →
n ⊨ ⟦ Ξ Γ ⊢ (⬇ t₁) ≼ˡᵒᵍ (⬇ t₂) : T # E ⟧.
Proof.
intro Ht.
iintro ξ₁ ; iintro ξ₂ ; iintro δ₁ ; iintro δ₂ ; iintro δ ;
iintro ρ₁ ; iintro ρ₂ ; iintro ρ ; iintro γ₁ ; iintro γ₂.
pick_fresh_gen (from_list ξ₁ \u from_list ξ₂ \u B) X.
assert (X ∉ B) as FrB ; [ crush | ].
specialize (Ht X FrB).
iintro Hξ ; iintro cl_δ ; iintro cl_ρ₁ρ₂ ; iintro Hγ.
ielim_prop Hξ ; specialize Hξ as Hξ_copy ; destruct Hξ_copy as [Hξ₁ Hξ₂].
ielim_prop cl_ρ₁ρ₂.

assert (X ∉ from_list ξ₁) as Frξ₁ ; [ crush | ].
assert (X ∉ from_list ξ₂) as Frξ₂ ; [ crush | ].
assert (X ∉ dom Ξ) as FrΞ ; [ intro ; crush | ].

ispecialize Ht (X :: ξ₁) ; ispecialize Ht (X :: ξ₂).
ispecialize Ht δ₁ ; ispecialize Ht δ₂ ; ispecialize Ht δ.
ispecialize Ht ρ₁ ; ispecialize Ht ρ₂ ; ispecialize Ht ρ.
ispecialize Ht γ₁ ; ispecialize Ht γ₂.
ispecialize Ht.
{ iintro_prop ; split ; [ clear - Hξ₁ | clear - Hξ₂ ] ;
  rewrite dom_concat, from_list_cons, dom_single, union_comm ;
  apply subset_union_2 ; crush.
}
ispecialize Ht.
{ repeat iintro ; iespecialize cl_δ ; ispecialize cl_δ ; [ eassumption | ].
  repeat rewrite from_list_cons ; ielim_prop cl_δ ; crush.
}
ispecialize Ht.
{ iintro_prop ; intros α Y ; specialize (cl_ρ₁ρ₂ α Y) ;
  clear - cl_ρ₁ρ₂ ; repeat rewrite from_list_cons ; crush.
}
ispecialize Ht.
{ iintro x ; ispecialize Hγ x ; clear - Wf_Ξ Wf_Γ Wf_T Wf_E FrΞ Hγ.
  erewrite <- I_iff_elim_M ; [ | apply X_weaken_𝓥 ; crush ].
  eauto.
}

simpl.
apply ccompat_tm_down with (X := X) ; try assumption.
+ iintro ξ₁' ; iintro ξ₂' ;
  iintro s₁ ; iintro s₂ ; iintro ψ ; iintro Xs₁ ; iintro Xs₂ ; iintro Hs.
  erewrite <- I_iff_elim_M in Hs ; [ | apply X_weaken_𝓤 ; crush ].
  iintro_prop.
  assert (Xs₁ \c from_list ξ₁ ∧ Xs₂ \c from_list ξ₂) as HXs₁Xs₂.
  { eapply 𝓤_is_closed ; eassumption. }
  clear - HXs₁Xs₂ Frξ₁ Frξ₂.
  destruct HXs₁Xs₂.
  split ; intro ; auto.
+ clear - Ht.
  repeat erewrite <- V_L_bind_tm, <- EV_L_bind_tm, <- LV_L_bind_tm.
  { apply Ht. }
  { intro ; unfold compose.
    erewrite L_bind_map_lbl, L_bind_lbl_id, L_map_lbl_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_eff, L_bind_eff_id, L_map_eff_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_val, L_bind_val_id, L_map_val_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_lbl, L_bind_lbl_id, L_map_lbl_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_eff, L_bind_eff_id, L_map_eff_id ; crush. }
  { intro ; unfold compose.
    erewrite L_bind_map_val, L_bind_val_id, L_map_val_id ; crush. }
Qed.

End section_compat_tm_down.


Require Import RefProofDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import RefTactics.
Require Import AbsAccessor.Spec.
Require Import PSCIAux.Spec.
Require Import PSCIAux2.Specs.psci_cpu_on_target.
Require Import PSCIAux2.LowSpecs.psci_cpu_on_target.
Require Import PSCIAux2.RefProof.RefRel.

Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Opaque Z.add Z.mul Z.div Z.shiftl Z.shiftr Z.land Z.lor.

Section Refine.

  Hint Unfold
       get_rec_runnable_spec
       buffer_unmap_spec
       granule_unlock_spec
       set_psci_result_x0_spec
       psci_reset_rec_spec
       set_rec_pc_spec
       set_rec_runnable_spec
       set_psci_result_forward_psci_call_spec
       set_psci_result_forward_x1_spec
    .

  Lemma psci_cpu_on_target_spec_exists:
    forall habd habd'  labd g_target_rec target_rec rec entry_point_address target_cpu
           (Hspec: psci_cpu_on_target_spec g_target_rec target_rec rec entry_point_address target_cpu habd = Some habd')
            (Hrel: relate_RData habd labd),
    exists labd', psci_cpu_on_target_spec0 g_target_rec target_rec rec entry_point_address target_cpu labd = Some labd' /\ relate_RData habd' labd'.
  Proof.
    Local Opaque ptr_eq.
    intros. destruct Hrel. destruct g_target_rec, target_rec, rec.
    unfold psci_cpu_on_target_spec, psci_cpu_on_target_spec0 in *.
    repeat autounfold in *. simpl in *.
    hsimpl_hyp Hspec; inv Hspec; simpl_query_oracle; extract_prop_dec;
      repeat destruct_con; bool_rel; simpl in *; srewrite;
        repeat (simpl_htarget; grewrite; simpl in * ).
    unfold ref_accessible in *; simpl.
    repeat (simpl_htarget; srewrite; simpl in * ).
    eexists; split. reflexivity. constructor; simpl.
    repeat simpl_update_reg.
    repeat (repeat simpl_field; repeat swap_fields).
    rewrite <- C12. reflexivity.
    eexists; split. reflexivity. constructor. rewrite <- C12. reflexivity.
  Qed.

End Refine.


Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import TableDataOpsIntro.Spec.
Require Import TableDataOpsIntro.Layer.
Require Import TableDataOpsRef1.Code.table_unmap1.

Require Import TableDataOpsRef1.LowSpecs.table_unmap1.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _table_unmap ↦ gensem table_unmap_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_table_unmap: block.
    Hypothesis h_table_unmap_s : Genv.find_symbol ge _table_unmap = Some b_table_unmap.
    Hypothesis h_table_unmap_p : Genv.find_funct_ptr ge b_table_unmap
                                 = Some (External (EF_external _table_unmap
                                                  (signature_of_type (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default))
                                        (Tcons Tptr (Tcons tulong (Tcons tulong Tnil))) tulong cc_default).
    Local Opaque table_unmap_spec.

    Lemma table_unmap1_body_correct:
      forall m d d' env le g_rd_base g_rd_offset map_addr level res
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTg_rd: PTree.get _g_rd le = Some (Vptr g_rd_base (Int.repr g_rd_offset)))
             (HPTmap_addr: PTree.get _map_addr le = Some (Vlong map_addr))
             (HPTlevel: PTree.get _level le = Some (Vlong level))
             (Hspec: table_unmap1_spec0 (g_rd_base, g_rd_offset) (VZ64 (Int64.unsigned map_addr)) (VZ64 (Int64.unsigned level)) d = Some (d', VZ64 (Int64.unsigned res))),
           exists le', (exec_stmt ge env le ((m, d): mem) table_unmap1_body E0 le' (m, d') (Out_return (Some (Vlong res, tulong)))).
    Proof.
      solve_code_proof Hspec table_unmap1_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


From Undecidability.FOL Require Import Syntax.Facts Syntax.Asimpl Deduction.FragmentNDFacts Deduction.FragmentNDConsistency Syntax.Theories Semantics.Kripke.FragmentCore
                                       Semantics.Kripke.FragmentSoundness
                                       Semantics.Kripke.FragmentToTarski Deduction.FragmentSequent Deduction.FragmentSequentFacts.
From Undecidability.Synthetic Require Import Definitions DecidabilityFacts MPFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability Require Import Shared.ListAutomation Shared.Dec.
From Undecidability Require Import Shared.Libs.PSL.Vectors.Vectors Shared.Libs.PSL.Vectors.VectorForall.
Import ListAutomationNotations.
From Undecidability.FOL.Completeness Require Export TarskiCompleteness.
(* From Undecidability.FOLC Require Export Gentzen. *)

(* ** Universal Models *)

Section KripkeCompleteness.
  Context {Σf : funcs_signature} {Σp : preds_signature}. (*
  Variable eF : nat -> option Σf.
  Context {HeF : enumerator__T eF Σf}.
  Variable eP : nat -> option Σp.
  Context {HeP : enumerator__T eP Σp}. *)

(*  Hint Constructors sprv. *)
  Instance model_bot : interp term :=
    {| i_func := func; i_atom := fun P v => False|}.
  Lemma universal_interp_eval rho t :
    eval rho t = t`[rho].
  Proof.
    now induction t; cbn.
  Qed.

  Section Contexts.

    Program Instance K_ctx {ff:falsity_flag} : kmodel term :=
      {|
        nodes := list form ;
        reachable := @incl form ;
        k_interp := model_bot ;
        k_P := fun A P v => sprv A None (atom P v) ;
      |}.
    Next Obligation.
      abstract (eauto using seq_Weak).
    Qed.

    Definition F_P {ff} : list (@form _ _ _ ff) -> Prop := match ff with falsity_on => fun n => sprv n None ⊥ | _ => fun _ => False end.
    Lemma mon_F {ff:falsity_flag} (u v : @nodes _ _ _ K_ctx) : reachable u v -> F_P u -> F_P v.
    Proof.
      cbn. unfold F_P. destruct ff; try easy. intros H H1. eapply seq_Weak; [ exact H1| exact H].
    Qed.

    Notation "rho '⊩⊥(' u , M ')' phi" :=  (@ksat_bot _ _ _ M _ F_P mon_F u rho phi) (at level 20).

    Lemma K_ctx_correct_exp {ff:falsity_flag} (A : list form) rho phi :
      (rho ⊩⊥(A, K_ctx ) phi-> A ⊢S phi[rho]) /\
      ((forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩⊥(A, K_ctx) phi).
    Proof.
      revert A rho; enough ((forall A rho, rho ⊩⊥( A, K_ctx) phi -> A ⊢S phi[rho]) /\
                          (forall A rho, (forall B psi, A <<= B -> B;; phi[rho] ⊢s psi -> B ⊢S psi)
                                  -> rho ⊩⊥( A, K_ctx) phi)) by intuition.
      induction phi as [|t1 t2|ff [] phi IHphi psi IHpsi|ff [] phi IHphi]; cbn; split; intros A rho.
      - tauto.
      - eauto.
      - erewrite Vector.map_ext. 1: eauto. apply universal_interp_eval.
      - intros H. erewrite Vector.map_ext. 1: now apply H. apply universal_interp_eval.
      - intros Hsat. apply IR, IHpsi. apply Hsat, IHphi. 1: intuition. eauto.
      - intros H B HB Hphi % IHphi. apply IHpsi. intros C xi HC Hxi. apply H.
        1: now transitivity B. eauto using seq_Weak.
      - intros Hsat. apply AllR.
        pose (phi' := phi[up rho]).
        destruct (find_bounded_L (phi' :: A)).
        eapply seq_nameless_equiv_all' with (n := x) (phi := phi').
        + intros xi Hxi. apply b. now right.
        + eapply bounded_up. 1: apply b; now left. lia.
        + unfold phi'. asimpl. apply IHphi, Hsat.
      - intros H t. apply IHphi. intros B psi HB Hpsi. apply H. assumption.
        apply AllL with (t := t). now asimpl.
    Qed.

    Corollary K_ctx_sprv_exp {ff:falsity_flag} A rho phi :
      rho ⊩⊥(A, K_ctx) phi -> A ⊢S phi[rho].
    Proof.
      now destruct (K_ctx_correct_exp A rho phi).
    Qed.

    Lemma K_ctx_subst_exp {ff:falsity_flag} A phi rho :
      rho ⊩⊥( A, K_ctx) phi <-> var ⊩⊥( A, K_ctx) phi[rho].
    Proof.
      unfold ksat_bot, falsity_to_pred.
      rewrite <- atom_subst_comp. 2:easy.
      assert (forall {ff:falsity_flag} rho, (atom (Σ_preds := Σ_preds_bot) (inl tt) (Vector.nil _)) = (atom (Σ_preds := Σ_preds_bot) (inl tt) (Vector.nil _))[rho]) as Heq by easy.
      erewrite Heq.
      rewrite <- subst_falsity_comm. cbn.
      rewrite (ksat_comp A var rho).
      apply ksat_ext. intros x. unfold funcomp. induction (rho x); cbn; try easy.
      erewrite <- map_ext_forall. 2: apply Forall_in, IH.
      now rewrite Vector.map_id.
    Qed.

    Lemma K_ctx_constraint_exp {ff:falsity_flag} A rho psi:
      rho ⊩⊥(A, K_ctx) (⊥ → psi).
    Proof.
      destruct ff eqn : Hff; try now intros.
      intros v B HB. cbn in HB. apply K_ctx_correct_exp.
      intros B' psi' HB' Hprv. subst. eauto using seq_Weak.
    Qed.

    Corollary K_ctx_ksat_exp {ff:falsity_flag} A rho phi :
      (forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩⊥(A, K_ctx) phi.
    Proof.
      now destruct (K_ctx_correct_exp A rho phi).
    Qed.

    #[local] Existing Instance falsity_off.

    Lemma K_ctx_correct (A : list form) rho phi :
      (rho ⊩(A, K_ctx ) phi-> A ⊢S phi[rho]) /\
      ((forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩(A, K_ctx) phi).
    Proof.
      revert phi. remember falsity_off as ff eqn:Heqff. intros phi.
      revert A rho; enough ((forall A rho, rho ⊩( A, K_ctx) phi -> A ⊢S phi[rho]) /\
                          (forall A rho, (forall B psi, A <<= B -> B;; phi[rho] ⊢s psi -> B ⊢S psi)
                                  -> rho ⊩( A, K_ctx) phi)) by intuition.
      induction phi as [|t1 t2|ff [] phi IHphi psi IHpsi|ff [] phi IHphi]; cbn; split; intros A rho.
      - tauto.
      - congruence.
      - erewrite Vector.map_ext. 1: eauto. apply universal_interp_eval.
      - intros H. erewrite Vector.map_ext. 1: now apply H. apply universal_interp_eval.
      - intros Hsat. apply IR, IHpsi. 1:easy. apply Hsat, IHphi. 1: intuition. 1:easy. eauto.
      - intros H B HB Hphi % IHphi. 2:easy. apply IHpsi. 1:easy. intros C xi HC Hxi. apply H.
        1: now transitivity B. eauto using seq_Weak.
      - intros Hsat. apply AllR.
        pose (phi' := phi[up rho]).
        destruct (find_bounded_L (phi' :: A)).
        eapply seq_nameless_equiv_all' with (n := x) (phi := phi').
        + intros xi Hxi. apply b. now right.
        + eapply bounded_up. 1: apply b; now left. lia.
        + unfold phi'. asimpl. apply IHphi, Hsat. easy.
      - intros H t. apply IHphi. 1:easy. intros B psi HB Hpsi. apply H. assumption.
        apply AllL with (t := t). now asimpl.
    Qed.

    Corollary K_ctx_sprv A rho phi :
      rho ⊩(A, K_ctx) phi -> A ⊢S phi[rho].
    Proof.
      now destruct (K_ctx_correct A rho phi).
    Qed.

    Lemma K_ctx_subst A phi rho :
      rho ⊩( A, K_ctx) phi <-> var ⊩( A, K_ctx) phi[rho].
    Proof.
      rewrite (ksat_comp A var rho).
      apply ksat_ext. intros x. unfold funcomp. induction (rho x); cbn; try easy.
      erewrite <- map_ext_forall. 2: apply Forall_in, IH.
      now rewrite Vector.map_id.
    Qed.

    Corollary K_ctx_ksat A rho phi :
      (forall B psi, A <<= B -> B ;; phi[rho] ⊢s psi -> B ⊢S psi) -> rho ⊩(A, K_ctx) phi.
    Proof.
      now destruct (K_ctx_correct A rho phi).
    Qed.
  End Contexts.

  Section ExplodingCompleteness.

    Lemma K_ctx_exploding {ff:falsity_flag}:
      kexploding mon_F.
    Proof.
      unfold kexploding.
      apply K_ctx_constraint_exp.
    Qed.

    Lemma K_exp_completeness A phi :
      kvalid_exploding_ctx A phi -> A ⊢SE phi.
    Proof.
      intros Hsat. erewrite <-subst_id. 1: apply K_ctx_sprv_exp with (rho := var). 2: reflexivity.
      apply Hsat. 1: apply K_ctx_exploding. intros psi Hpsi. apply K_ctx_ksat_exp. intros B xi HB Hxi.
      rewrite subst_id in Hxi. 2:reflexivity. eauto.
    Qed.

    Ltac clean_ksoundness :=
      match goal with
      | [ H : ?x = ?x -> _ |- _ ] => specialize (H eq_refl)
      | [ H : (?A -> ?B), H2 : (?A -> ?B) -> _ |- _] => specialize (H2 H)
      end.
    Lemma K_exp_ksoundness {ff:falsity_flag} A phi :
      A ⊢I phi -> kvalid_exploding_ctx A phi.
    Proof.
      intros Hprv. cbn in Hprv. intros D M F_P mon_F u rho Hexpl. revert u rho.
      remember intu as s in Hprv. induction Hprv; subst; cbn; intros u rho HA.
      all: repeat (clean_ksoundness + discriminate). all: (eauto || cbn ; eauto).
      - intros v Hr Hpi. eapply IHHprv. intros ? []; subst; eauto using ksat_mon. eapply ksat_mon. 2: now apply HA. easy.
      - eapply IHHprv1. 3: eapply IHHprv2. all: eauto. apply M.
      - intros d. apply IHHprv. intros psi [psi' [<- Hp]] % in_map_iff. cbn.
        unfold ksat_bot. rewrite falsity_to_pred_subst.
        rewrite ksat_comp. apply HA, Hp.
      - unfold ksat_bot. rewrite falsity_to_pred_subst.
        rewrite ksat_comp. eapply ksat_ext. 2: eapply (IHHprv u rho HA (eval rho t)).
        unfold funcomp. now intros [].
      - apply (Hexpl u rho phi u (ltac:(apply M))).
        specialize (IHHprv u rho HA). cbn in IHHprv. apply IHHprv.
    Qed.

    Lemma K_exp_seq_ksoundness {ff:falsity_flag} A phi :
      A ⊢SE phi -> kvalid_exploding_ctx A phi.
    Proof.
      intros H%seq_ND. now apply K_exp_ksoundness.
    Qed.

    Fact SE_cut A phi psi :
      A ⊢SE phi -> A;;phi ⊢sE psi -> A ⊢SE psi.
    Proof.
      intros H1 % seq_ND H2 % seq_ND; cbn in *.
      apply H2 in H1. apply K_exp_completeness.
      apply K_exp_ksoundness. firstorder.
    Qed.

  End ExplodingCompleteness.

  Section BottomlessCompleteness.
    #[local] Existing Instance falsity_off.

    Lemma K_bottomless_completeness A phi :
      kvalid_ctx A phi -> A ⊢S phi.
    Proof.
      intros Hsat. erewrite <- subst_id. apply K_ctx_sprv with (rho := var). 2: reflexivity.
      apply Hsat. intros psi Hpsi. apply K_ctx_ksat. intros B xi HB Hxi.
      rewrite subst_id in Hxi. 2:easy. eauto.
    Qed.
  End BottomlessCompleteness.

(* *** Standard Models *)

  Section StandardCompleteness.
    #[local] Existing Instance falsity_on.

    Definition cons A := ~ A ⊢SE ⊥.
    Definition cons_ctx := { A | cons A }.
    Definition ctx_incl (A B : cons_ctx) := incl (proj1_sig A) (proj1_sig B).

    #[local] Hint Unfold cons cons_ctx ctx_incl : core.

    Notation "A <<=C B" := (ctx_incl A B) (at level 20).
    Notation "A ⊢SC phi" := ((proj1_sig A) ⊢SE phi) (at level 20).
    Notation "A ;; psi ⊢sC phi" := ((proj1_sig A) ;; psi ⊢sE phi) (at level 20).

    Ltac dest_con_ctx :=
      match goal with
      | [ |- forall u : cons_ctx, _] => let Hu := fresh "H" u in intros [u Hu]
      | [ A : cons_ctx |- _] => let HA := fresh "H" A in destruct A as [A HA]
      end.

    Ltac cctx := repeat (progress dest_con_ctx; unfold ctx_incl); cbn.

    Hint Extern 1 => cctx : core.

    Program Instance K_std : kmodel term :=
      {|
        reachable := ctx_incl ;
        k_interp := model_bot ;
        k_P := fun A P v => ~ ~ A ⊢SC (@atom _ _ _ _ P v)
      |}.
    Next Obligation.
      abstract (apply H0; intros K; apply H1; eapply seq_Weak; eauto).
    Qed.

    Lemma K_std_correct (A : cons_ctx) rho phi :
      (rho ⊩(A, K_std) phi -> ~ ~ A ⊢SC phi[rho]) /\
      ((forall B psi, A <<=C B -> B ;; phi[rho] ⊢sC psi -> ~ ~ B ⊢SC psi) -> rho ⊩(A, K_std) phi).
    Proof.
      revert A rho; enough ((forall A rho, rho ⊩( A, K_std) phi -> ~ ~ A ⊢SC phi[rho])
                          /\ (forall A rho, (forall B psi, A <<=C B -> B;; phi[rho] ⊢sC psi -> ~ ~ B ⊢SC psi)
                                    -> rho ⊩( A, K_std) phi)) by firstorder.
      induction phi as [| t1 t2 | [ ] phi [IHphi1 IHphi2] psi [IHpsi1 IHpsi2] | [ ] phi [IHphi1 IHphi2] ] using form_ind_falsity.
      all: cbn; split; intros A rho.
      - tauto.
      - intros H. exfalso. apply (H A ⊥); auto.
      - now rewrite (Vector.map_ext _ _ _ _ (universal_interp_eval rho)).
      - rewrite <- (Vector.map_ext _ _ _ _ (universal_interp_eval rho)). intros H H'.
        eapply H. 3: { intros H1. apply H', H1. } all: auto.
      - intros Hsat H.
        assert (HA : ~ ~ ((phi[rho] :: proj1_sig A) ⊢SE ⊥ \/ ~ (phi[rho] :: proj1_sig A) ⊢SE ⊥)) by tauto.
        apply HA. clear HA. intros [HA|HA].
        + apply H. apply IR. apply Absurd. assumption.
        + pose (A' := exist cons (phi[rho] :: proj1_sig A) HA). apply (IHpsi1 A' rho).
          * apply Hsat. 1: now apply incl_tl. apply IHphi2. intros B theta HB HT.
            intros H'. apply H'. eauto.
          * intros H'. apply H. apply IR, H'.
      - intros H B HB Hphi % IHphi1. apply IHpsi2. intros C xi HC Hxi.
        intros HX. apply Hphi. intros Hphi'. apply (H C xi); trivial.
        + cctx. now transitivity B.
        + apply IL; trivial. eapply seq_Weak; eauto.
      - pose (phi' := subst_form ($0 .: (rho >> subst_term (S >> var))) phi).
        intros Hsat. intros H. cctx. destruct (find_bounded_L (phi' :: A)) as [x b].
        apply (IHphi1 (exist cons A HA) ($x.:rho)).
        rewrite ksat_ext. 2: reflexivity. now apply Hsat.
        intros H'. apply H, AllR. cbn.
        eapply seq_nameless_equiv_all' with (n := x) (phi := phi').
        + intros xi Hxi. apply b. now right.
        + eapply bounded_up. 1: apply b; now left. lia.
        + unfold phi'. cbn in H'. now asimpl.
      - intros H t. apply IHphi2. intros B psi HB Hpsi. apply H. assumption.
        apply AllL with (t := t). now asimpl.
    Qed.

    Corollary K_std_sprv A rho phi :
      rho ⊩(A, K_std) phi -> ~ ~ A ⊢SC phi[rho].
    Proof.
      now destruct (K_std_correct A rho phi).
    Qed.

    Corollary K_std_sprv' A rho phi :
       ~ ~ A ⊢SC phi[rho] -> rho ⊩(A, K_std) phi.
    Proof.
      intros H. apply (K_std_correct A rho phi).
      intros B psi H1 H2 H3. apply H. intros H'.
      apply H3. eapply SE_cut; try eassumption.
      now apply (seq_Weak H').
    Qed.

    Corollary K_std_ksat A rho phi :
      (forall B psi, A <<=C B -> B ;; phi[rho] ⊢sC psi -> ~ ~ B ⊢SC psi) -> rho ⊩(A, K_std) phi.
    Proof.
      now destruct (K_std_correct A rho phi).
    Qed.

    Lemma K_std_completeness A phi :
      kvalid_ctx A phi -> ~ ~ A ⊢SE phi.
    Proof.
      intros Hsat H.
      assert (HA : ~ ~ (A ⊢SE ⊥ \/ ~ A ⊢SE ⊥)) by tauto.
      apply HA. clear HA. intros [HA|HA].
      - apply H. apply Absurd. assumption.
      - specialize (Hsat _ K_std (exist cons A HA) var).
        apply K_std_sprv in Hsat.
        + apply Hsat. intros Hsat'. apply H.
          erewrite <- subst_id; trivial. apply Hsat'.
        + intros psi Hpsi. apply K_std_ksat.
          intros B xi HB Hxi. asimpl in Hxi. eauto.
    Qed.

    Lemma K_std_seq_ksoundness A phi :
      A ⊢SE phi -> kvalid_ctx A phi.
    Proof.
      intros H % seq_ND. apply ksoundness, H.
    Qed.
  End StandardCompleteness.

  Section Stability.
    Existing Instance falsity_on.
    Context (T_kind : theory -> Prop).
    Definition K_completeness := forall T phi, T_kind T -> closed_T T -> closed phi ->
                  kvalid_theo T phi -> T ⊩SE phi.
    Lemma kcompleteness_implies_stability T phi : K_completeness ->
      T_kind (tmap negative_translation T) ->
      closed_T T -> closed phi ->
      ~ ~ T ⊢TC phi -> T ⊢TC phi.
    Proof.
      intros Hcomp kindT clT clphi HTDN.
      apply DN_T. apply nt_correct_theory. cbn. apply seq_ND_T.
      apply Hcomp.
      - easy.
      - apply tmap_closed. 1: apply nt_bounded. easy.
      - unfold closed. solve_bounds. apply nt_bounded. apply clphi.
      - intros D M u rho HT.
        intros v Huv Hphiv. cbn. apply HTDN.
        intros (A & HTA & HTphi). eapply nt_Cprv_to_Iprv in HTphi.
        eapply DN_into in HTphi.
        apply ksoundness in HTphi.
        unshelve eapply (@HTphi D M u rho _ v Huv Hphiv).
        intros ? (psi & <- & HApsi) %in_map_iff. apply HT.
        exists psi. split; try easy. now apply HTA.
    Qed.
  End Stability.

  Section MP_Equivalence.
    Definition kcompleteness_enumerable := K_completeness enumerable.

    Lemma bot_deriv_stable_enum_k (T : @theory _ _ _ falsity_on) : kcompleteness_enumerable -> closed_T T -> enumerable T ->
      stable (@FragmentND.tprv _ _ _ class T ⊥).
    Proof.
      intros Hcomp Hclosed Henum HC.
      apply (kcompleteness_implies_stability Hcomp); try easy. 2: econstructor.
      now apply enum_tmap.
    Qed.

(*
    Lemma MP_implies_kcompleteness_enum : MP -> kcompleteness_enumerable.
    Proof.
      intros Hmp T phi HT Hphi Henum Hvalid.
      apply completeness_classical_stability; eauto. unfold stable.
      eapply mp_tprv_stability; try tauto. now eapply enumerable_list_enumerable.
    Qed.
*)
    Lemma kcompleteness_enum_implies_MP : kcompleteness_enumerable -> MP.
    Proof.
      intros HC f Hf.
      pose (fun x : form => exists n, x = ⊥ /\ f n = true) as T.
      assert (closed_T T) as Hclosed by (now intros k [n [-> Hn]]; econstructor).
      assert (enumerable T) as Henum.
      { exists (fun n => if f n then Some (⊥) else None). intros phi; split; intros H.
        + destruct H as (n & Heq & Hfn). exists n. rewrite Hfn. now rewrite Heq.
        + destruct H as (n & Hn). unfold T. exists n. destruct (f n); try congruence.
          split; try easy. congruence.
       }
      pose proof (@bot_deriv_stable_enum_k T HC Hclosed Henum).
      enough (T ⊢TC ⊥) as [[|lx lr] [HL HL']].
      - exfalso. eapply consistent_ND. apply HL'.
      - destruct (HL lx) as (n & Heq & Hfn). 1:now left. now exists n.
      - apply H. intros Hc. apply Hf. intros [n Hn]. apply Hc. exists [⊥]. split.
        + intros ? [<- | []]. unfold T. exists n. split; try easy.
        + apply Ctx; now left.
    Qed.

  End MP_Equivalence.

  Section LEM_Equivalence.
    Definition kcompleteness_arbitrary := K_completeness (fun x => True).
    Definition LEM := forall (P:Prop), P \/ ~ P.

    Lemma bot_valid_stable (T : @theory _ _ _ falsity_on) : closed_T T -> stable (valid_theory_C (classical (ff := falsity_on)) T ⊥).
    Proof.
      intros Hclosed HH D I rho Hclass H.
      apply HH. intros Hc. apply (Hc D I rho Hclass H).
    Qed.
    Lemma bot_deriv_stable_k (T : @theory _ _ _ falsity_on) : kcompleteness_arbitrary ->
      closed_T T -> stable (@FragmentND.tprv _ _ _ class T ⊥).
    Proof.
      intros Hcomp Hclosed HC.
      apply (kcompleteness_implies_stability Hcomp); try easy. econstructor.
    Qed.
    Existing Instance falsity_on.
    Lemma kcompleteness_implies_LEM : kcompleteness_arbitrary -> LEM.
    Proof.
      intros HC P.
      pose (fun x : form => closed x /\ (P \/ ~P)) as T.
      assert (closed_T T) as Hclosed by (intros k; cbv; tauto).
      pose proof (@bot_deriv_stable_k T HC Hclosed).
      enough (T ⊢TC ⊥) as [[|lx lr] [HL HL']].
      - exfalso. eapply consistent_ND. apply HL'.
      - eapply HL. now left.
      - enough (~~ (P \/ ~P)).
        + apply H. intros Hc. apply H0. intros Hc2. apply Hc. exists [⊥]. split; try (apply Ctx; now left).
          intros ? [<- | []]. cbv. split; try apply Hc2. econstructor.
        + tauto.
    Qed.
(*
    Lemma LEM_implies_kcompleteness : LEM -> kcompleteness_arbitrary.
    Proof.
      intros Hlem T phi HT Hphi Hvalid Htheo.
      destruct (Hlem (T ⊩SE phi)); try easy. exfalso.
      apply K_std_completeness.
      intros H. destruct (Hlem (T ⊢TC phi)); tauto.
    Qed.
*)
  End LEM_Equivalence.

End KripkeCompleteness.


From ConCert.Utils Require Import Extras.
From ConCert.Execution Require Import Blockchain.
From ConCert.Execution Require Import Serializable.
From ConCert.Execution Require Import Containers.
From ConCert.Execution Require Import ResultMonad.
From ConCert.Execution Require Import Monad.
From ConCert.Execution.Test Require Import QCTest.
From ConCert.Examples.Dexter Require Import Dexter.
From ConCert.Examples.Dexter Require Export DexterPrinters.
From ConCert.Examples.Dexter Require Import DexterGens.
From ConCert.Examples.EIP20 Require Import EIP20Token.
From Coq Require Import ZArith_base.
From Coq Require Import List. Import ListNotations.

Definition token_pool_size : N := 100.

Definition token_setup : EIP20Token.Setup := {|
  EIP20Token.owner := creator;
  EIP20Token.init_amount := token_pool_size;
|}.

Definition token_caddr : Address := addr_of_Z 128.
Definition dexter_caddr : Address := addr_of_Z 129.

(* Dexter will have 60 tokens in reverse initially *)
Definition dexter_setup : Dexter.Setup := {|
  token_caddr_ := token_caddr;
  token_pool_ := (token_pool_size - 40);
|}.

Definition add_as_operator_act owner operator tokens :=
  build_call owner token_caddr 0 (EIP20Token.approve operator tokens).

Definition exchange_tokens_to_money_act owner amount :=
  build_call owner dexter_caddr 0 (Dexter.tokens_to_asset {|
    exchange_owner := owner;
    tokens_sold := amount;
  |}).

(* Set up a chain with token contract, and dexter contract deployed.
   Also adds some tokens to person_1 and dexter contract, and adds some operators on the fa2 contract *)
Definition chain : ChainBuilder :=
  unpack_result (TraceGens.add_block builder_initial
  [ (* Give 10 to person 1 *)
    build_transfer creator person_1 10 ;
    (* Deploy contracts *)
    build_deploy creator 0 EIP20Token.contract token_setup ;
    build_deploy creator 30 Dexter.contract dexter_setup ;
    (* Tranfer tokens to exchange contract and person1 *)
    build_call creator token_caddr 0 (EIP20Token.transfer person_1 40%N) ;
    build_call creator token_caddr 0 (EIP20Token.transfer dexter_caddr (token_pool_size - 40)%N) ;
    (* Let dexter transfer tokens on behalf of person_1 and person_2 *)
    add_as_operator_act person_1 dexter_caddr token_pool_size ;
    add_as_operator_act person_2 dexter_caddr token_pool_size
  ]).

Definition add_block_with_acts (c : ChainBuilder) acts :=
  (TraceGens.add_block c acts).

Definition dexter_state env := get_contract_state Dexter.State env dexter_caddr.
Definition token_state env := get_contract_state EIP20Token.State env token_caddr.

Module TestInfo <: DexterTestsInfo.
  Definition token_caddr := token_caddr.
  Definition dexter_contract_addr := dexter_caddr.
  Definition test_accounts := [person_1].
End TestInfo.
Module MG := DexterGens.DexterGens TestInfo. Import MG.

(* Sample (gDexterAction chain1). *)

(* Sample ((liftM (fun a => add_block_with_acts chain1 [a]) (gDexterAction chain1))). *)
(* Sample (gDexterChain 2 chain1 1). *)

Definition person_1_initial_balance : Amount := env_account_balances chain person_1.

Definition dexter_liquidity chain : Amount := env_account_balances chain dexter_caddr.

Definition account_tokens (env : Environment) (account : Address) : N :=
  with_default 0%N (
    do token_state <- token_state env ;
    FMap.find account token_state.(EIP20Token.balances)
    ).

Definition dexter_token_pool (env : Environment) : N :=
  with_default 0%N (
    do s <- dexter_state env ;
    Some s.(token_pool)
    ).

Open Scope Z_scope.
Coercion Z.of_N : N >-> Z.

(* Asserts that exchanges are priced correctly *)
Definition tokens_to_asset_correct_P_opt (old_env new_env : Environment) : option Checker :=
  do state_dexter <- dexter_state new_env;
  let person_1_balance := env_account_balances new_env person_1 in
  let dexter_balance := env_account_balances new_env dexter_caddr in
  let dexter_initial_balance := env_account_balances old_env dexter_caddr in
  let dexter_initial_token_reserve := account_tokens old_env dexter_caddr in
  let dexter_current_token_reserve := account_tokens new_env dexter_caddr in
  (* We assume only the given account has made exchanges in this time period.
     This assumption holds for these tests. *)
  let tokens_received := dexter_current_token_reserve - dexter_initial_token_reserve in
  (* Calculate token exchange price if only a single exchange was made *)
  let expected_currency_sold := getInputPrice tokens_received dexter_initial_token_reserve dexter_initial_balance in
  let expected_dexter_balance := dexter_initial_balance - expected_currency_sold in
  Some (
    whenFail (
      "dexter balance was " ++ show dexter_balance ++
      " while it was expected to be at least " ++ show expected_dexter_balance ++ nl ++
      "person_1 balance: " ++ show person_1_balance ++ nl ++
      "person_1 tokens: " ++ show (account_tokens new_env person_1) ++ nl ++
      "dexter balance: " ++ show dexter_balance ++ nl ++
      "dexter tokens: " ++ show dexter_current_token_reserve ++ nl ++
      "history: " ++ show (state_dexter.(price_history))
    )
    (checker (expected_dexter_balance <=? dexter_balance))
  ).

Definition tokens_to_asset_correct_P old_env env :=
  match tokens_to_asset_correct_P_opt old_env env with
  | Some p => p
  | None => checker true
  end.

Definition tokens_to_asset_correct :=
  forAllChainStatePairs 1 chain (gDexterChain 2) tokens_to_asset_correct_P.

(* We first test the Dexter contract with breadth-first execution model *)
(* QuickChick (tokens_to_asset_correct). *)
(* +++ Passed 10000 tests (0 discards) *)
(* We see that the property holds with breadth-first execution model *)

(* However, the Dexter contract was designed for Tezos which used
   breadth-first execution model.
   Thus, we next test the property with that model *)
(* Extract Constant DepthFirst => "false".
QuickChick (tokens_to_asset_correct). *)
(*
Chain{|
Block 1 [
Action{act_from: 10%256, act_body: (act_deploy 0, DexterSetup{token_caddr_: 10%256, token_pool_: 100})};
Action{act_from: 10%256, act_body: (act_deploy 30, DexterSetup{token_caddr_: 128%256, token_pool_: 60})};
Action{act_from: 10%256, act_body: (act_call 128%256, 0, DexterSetup{token_caddr_: 11%256, token_pool_: 40})};
Action{act_from: 10%256, act_body: (act_call 128%256, 0, DexterSetup{token_caddr_: 129%256, token_pool_: 60})};
Action{act_from: 11%256, act_body: (act_call 128%256, 0, approve 129%256 100)}];
Block 2 [
Action{act_from: 11%256, act_body: (act_call 129%256, 0, token_to_asset exchange{exchange_owner: 11%256, tokens_sold: 20})};
Action{act_from: 11%256, act_body: (act_call 129%256, 0, token_to_asset exchange{exchange_owner: 11%256, tokens_sold: 14})}]; |}

dexter balance was 19 while it was expected to be at least 20
person_1 balance: 11
person_1 tokens: 6
dexter balance: 19
dexter tokens: 94
history: [7; 4]
*** Failed after 23 tests and 2 shrinks. (0 discards)
*)

(* We can see that the property fails in breadth-first model when two trades are made
   in the same block. Below we simulate what goes wrong in this example.
   The starting configuration is
   person_1 balance: 10
   person_1 tokens: 40
   dexter balance: 30
   dexter tokens: 60
*)
(* Compute (env_account_balances chain person_1). *)
(* = 10 : N *)
(* Compute (account_tokens chain person_1). *)
(* = 40 : N *)
(* Compute (env_account_balances chain dexter_caddr). *)
(* = 30 : N *)
(* Compute (account_tokens chain dexter_caddr). *)
(* = 60 : N *)

(* If both trades were merged person_1 would get 10 tez for his 34 tokens *)
(* Compute (getInputPrice 34 60 30). *)
(* = 10 : Z *)

(* However, this is not what happens, in total person_1 gains 7+4=11 tez from
   trading 34 tokens (20 in the first trade, 14 in the second) *)
(* In the first trade person_1 trades 20 tokens for 7 tez *)
(* Compute (getInputPrice 20 60 30). *)
(* = 7 : Z *)
(* In the second trade we would expect person_1 to get 3 tez for his 14 tokens *)
(* Compute (getInputPrice 14 80 23). *)
(* = 3 : Z *)
(* However, this is not the calculation that is being done.
   Instead the contract computes the yield of the second trade as follows *)
(* Compute (getInputPrice 14 80 30). *)
(* = 4 : Z *)
(* This is because in breadth first execution model both trades gets started before tokens and tez
   from previous trades have been transferred. Thus trades uses wrong values.
   Dexter manually tracks and decrements the number of tokens in the reserve because of this.
   However, the contract doesn't manually track tez the same way, thus the tez amount used is wrong. *)


From Coq Require Import
  String
  Lists.List
  .
From PlutusCert Require Import
  Util
  Util.List
  Transform.Congruence
  Analysis.FreeVars
  AFI
  .
From PlutusCert Require
  Language.PlutusIR
  .

Import PlutusIR (term(..), tvdecl(..), vdecl(..), ty(..), dtdecl(..), binding(..), constr(..), Recursivity(..)).
Import PlutusIR.NamedTerm.
Import ListNotations.
Import AFI.

(* Rename context*)
Definition ctx := list (string * string).

(* Binding variable x does not capture free variables in (the pre-term) t if they were renamed
   according to Γ *)
Definition no_capture x (Γ : ctx) t :=
  forall y, In (y, x) Γ -> ~ AFI.Term.appears_free_in y t.

Definition no_captureA α (Δ : ctx) t :=
  forall β, In (β, α) Δ -> ~ AFI.Annotation.appears_free_in β t.

Definition no_ty_capture α (Δ : ctx) τ :=
  forall β, In (β, α) Δ -> ~ AFI.Ty.appears_free_in β τ.

Inductive rename_tvs (Δ : ctx) (cs : list constructor) : list TVDecl -> list TVDecl -> ctx -> Type :=

  | rn_tvs_nil :
      rename_tvs Δ cs [] [] []

  | rn_tvs_cons : forall α tvs k β tvs' Δ_tvs,
      (* check that the bound tyvar does not capture other renamed vars in the
         type signatures of the constructors *)
      Forall (fun '(Constructor (VarDecl _ cty) _) => no_ty_capture β Δ cty) cs ->
      rename_tvs ((α, β) :: Δ) cs tvs tvs' Δ_tvs ->
      rename_tvs Δ cs (TyVarDecl α k :: tvs) (TyVarDecl β k :: tvs') ((α, β) :: Δ_tvs)
.

Inductive rename_ty (Δ : ctx) : Ty -> Ty -> Type :=

   | rn_Ty_Var : forall α α',
      lookup α Δ = Some α' ->
      rename_ty Δ (Ty_Var α) (Ty_Var α')

   | rn_Ty_Fun : forall σ τ σ' τ',
      rename_ty Δ σ σ' ->
      rename_ty Δ τ τ' ->
      rename_ty Δ (Ty_Fun σ τ) (Ty_Fun σ' τ')

   | rn_Ty_IFix : forall σ τ σ' τ',
      rename_ty Δ σ σ' ->
      rename_ty Δ τ τ' ->
      rename_ty Δ (Ty_IFix σ τ) (Ty_IFix σ' τ')

   | rn_Ty_Forall : forall α α' k τ τ',
      rename_ty ((α, α') :: Δ) τ τ' ->
      no_ty_capture α Δ τ ->
      rename_ty Δ (Ty_Forall α k τ) (Ty_Forall α' k τ')

   | rn_Ty_Builtin : forall t,
      rename_ty Δ (Ty_Builtin t) (Ty_Builtin t)

   | rn_Ty_Lam : forall α α' k τ τ',
      rename_ty ((α, α') :: Δ) τ τ' ->
      no_ty_capture α Δ τ ->
      rename_ty Δ (Ty_Lam α k τ) (Ty_Lam α' k τ')

   | Ty_App : forall σ τ σ' τ',
      rename_ty Δ σ σ' ->
      rename_ty Δ τ τ' ->
      rename_ty Δ (Ty_App σ τ) (Ty_App σ' τ')
.

Inductive rename (Γ Δ : ctx) : Term -> Term -> Type :=
  | rn_Var : forall x y,
      lookup x Γ = Some y ->
      rename Γ Δ  (Var x) (Var y)

  | rn_Let_Rec : forall bs bs' t t',
      forall Γ_bs Δ_bs,
      rename_Bindings_Rec (Γ_bs ++ Γ) (Δ_bs ++ Δ) Γ_bs Δ_bs bs bs' ->
      rename (Γ_bs ++ Γ) (Δ_bs ++ Δ) t t' ->

      (* All bound type- and term variables in the bindings should not capture _in the body_.

         Alternatively, this could have been implemented by adding `Let NonRec bs t` as
         an index in rename_binding and putting a simple no_capture at the actual binding *)
      Forall (fun '(_, x') => no_capture x' Γ t) Γ_bs ->
      Forall (fun '(_, α') => no_captureA α' Δ t) Δ_bs ->

      (* All bound (type) variables have to be unique in the binding group *)
      NoDup (bvbs bs') ->
      NoDup (btvbs bs') ->

      rename Γ Δ (Let Rec bs t) (Let Rec bs' t')

  (* If the decision procedure becomes problematic because of not structurally smaller terms,
     these two rules should be refactored into a relation similar to rename_Bindings_Rec *)
  | rn_Let_NonRec_nil : forall t t',
      rename Γ Δ t t' ->
      rename Γ Δ (Let NonRec [] t) (Let NonRec [] t')

  | rn_Let_NonRec_cons : forall Γ_b Δ_b b b' bs bs' t t',
      rename_binding Γ Δ Γ_b Δ_b b b' ->
      rename (Γ_b ++ Γ) (Δ_b ++ Δ) (Let NonRec bs t) (Let NonRec bs' t') ->

      (* All bound (type) variables in the let should not capture.

         Alternatively, add `Let NonRec bs t` as index in rename_binding
         and put a simple no_capture at the actual binding *)
      Forall (fun '(_, x') => no_capture x' Γ (Let NonRec bs t)) Γ_b ->
      Forall (fun '(_, α') => no_captureA α' Δ (Let NonRec bs t)) Δ_b ->

      rename Γ Δ (Let NonRec (b :: bs) t) (Let NonRec (b' :: bs') t')

  | rn_TyAbs : forall α α' k t t',
      rename ((α, α') :: Γ) Δ t t' ->
      no_captureA α' Δ t ->
      rename Γ Δ (TyAbs α k t) (TyAbs α' k t')

  | rn_LamAbs : forall x x' τ τ' t t',
      rename_ty Δ τ τ' ->
      rename ((x, x') :: Γ) Δ t t' ->
      no_capture x' Δ t ->
      rename Γ Δ (LamAbs x τ t) (LamAbs x' τ' t')

  | rn_Apply : forall s t s' t',
      rename Γ Δ s s' ->
      rename Γ Δ t t' ->
      rename Γ Δ (Apply s t) (Apply s' t')

  | rn_Constant : forall c,
      rename Γ Δ (Constant c) (Constant c)

  | rn_Builtin : forall b,
      rename Γ Δ (Builtin b) (Builtin b)

  | rn_TyInst : forall t t' τ τ',
      rename Γ Δ t t' ->
      rename_ty Δ τ τ' ->
      rename Γ Δ (TyInst t τ) (TyInst t' τ')

  | rn_Error : forall τ τ',
      rename_ty Δ τ τ' ->
      rename Γ Δ (Error τ) (Error τ')

  | rn_IWrap σ τ σ' τ' t t':
      rename_ty Δ σ σ' ->
      rename_ty Δ τ τ' ->
      rename Γ Δ t t' ->
      rename Γ Δ (IWrap σ τ t) (IWrap σ' τ' t')

  | rn_Unwrap : forall t t',
      rename Γ Δ t t' ->
      rename Γ Δ (Unwrap t) (Unwrap t')

with rename_binding (Γ Δ : ctx) : ctx -> ctx -> Binding -> Binding -> Type :=

  | rn_TermBind : forall s x x' τ τ' t t',
      rename_ty Δ τ τ' ->
      rename Γ Δ t t' ->
      rename_binding Γ Δ [(x, x')] [] (TermBind s (VarDecl x τ) t) (TermBind s (VarDecl x' τ') t')

  | rn_TypeBind : forall α α' k τ τ',
      rename_ty Δ τ τ' ->
      rename_binding Γ Δ [] [(α, α')] (TypeBind (TyVarDecl α k) τ) (TypeBind (TyVarDecl α' k) τ')

  | rn_DatatypeBind : forall α α' k tvs tvs' elim elim' cs cs',
      forall Δ_tvs Γ_cs Γ_b Δ_b,

      (* Renamings of bound ty-vars, which may be used in constructor types *)
      rename_tvs Δ cs' tvs tvs' Δ_tvs ->
      (* Constructor types are renamed and return any renamed constructor names *)
      rename_constrs ((α, α') :: Δ_tvs ++ Δ) Γ cs cs' Γ_cs ->

      (* Renamings for the rest of the program *)
      Γ_b = (elim, elim') :: Γ_cs ->
      Δ_b = [(α, α')] ->

      rename_binding Γ Δ Γ_b Δ_b
        (DatatypeBind (Datatype (TyVarDecl α k) tvs elim cs))
        (DatatypeBind (Datatype (TyVarDecl α' k) tvs' elim' cs'))

(*
  rename_Bindings_Rec is also indexed over contexts Γ_bs, Δ_bs, which are respectively
  the bound term and type variables of the recursive bindings.
*)
with rename_Bindings_Rec (Γ Δ : ctx) : ctx -> ctx -> list Binding -> list Binding -> Type :=

  | rn_Bindings_Rec_nil :
      rename_Bindings_Rec Γ Δ [] [] [] []

  | rn_Bindings_Rec_cons : forall b b' bs bs',
      forall Γ_b Γ_bs Δ_b Δ_bs,
      rename_binding Γ Δ Γ_b Δ_b b b' ->
      rename_Bindings_Rec Γ Δ Γ_bs Δ_bs bs bs' ->
      rename_Bindings_Rec Γ Δ (Γ_b ++ Γ_bs) (Δ_b ++ Δ_bs) (b :: bs) (b' :: bs')

(*
  rename_constrs is also indexed over context Γ_cs, which are
  the renamings of the constructors
*)
with rename_constrs (Γ Δ : ctx) : list constructor -> list constructor -> ctx -> Type :=

  | rn_constrs_nil :
      rename_constrs Γ Δ [] [] []

  | rn_constrs_cons : forall x x' τ τ' n cs cs' Γ_cs,
      rename_ty Δ τ τ' ->
      rename_constrs Γ Δ cs cs' Γ_cs ->
      rename_constrs Γ Δ
        (Constructor (VarDecl x τ) n :: cs)
        (Constructor (VarDecl x' τ') n :: cs')
        ((x, x') :: Γ_cs)
  .


(*
 * © 2020 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     ModelCheck
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.UniverseEqAutomation
     ModelCheck.ProtocolAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
     ModelCheck.SilentStepElimination
.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: EMPTY.
End Foo.
Module Import SN := SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module MyProtocol.

  (* Start with two users, as that is the minimum for any interesting protocol *)
  Notation USR1 := 0.
  Notation USR2 := 1.

  Section IW.
    Import IdealWorld.

    (* Set up initial communication channels so each user can talk directly to the other *)
    Notation pCH12 := 0.
    Notation pCH21 := 1.
    Notation CH12  := (# pCH12).
    Notation CH21  := (# pCH21).

    (* This is the initial channel vector, each channel should be represented and start with
     * no messages.
     *)
    Notation empty_chs := (#0 #+ (CH12, []) #+ (CH21, [])).

    Notation PERMS1 := ($0 $+ (pCH12, owner) $+ (pCH21, reader)).
    Notation PERMS2 := ($0 $+ (pCH12, reader) $+ (pCH21, owner)).

    (* Fill in the users' protocol specifications here, adding additional users as needed.
     * Note that all users must return an element of the same type, and that type needs to
     * be one of: ...
     *)
    Notation ideal_users :=
      [
        (* User 1 Specification *)
        mkiUsr USR1 PERMS1
                (
                  ret 1
                )
        ;

      (* User 2 Specification *)
      mkiUsr USR2 PERMS2
              (
                ret 1
              )
      ].

    (* This is where the entire specification universe gets assembled.  It is unlikely anything
     * will need to change here.
     *)
    Definition ideal_univ_start :=
      mkiU empty_chs ideal_users.

  End IW.

  Section RW.
    Import RealWorld.

    (* Key management needs to be bootstrapped.  Since all honest users must only send signed
     * messages, we need some way of initially distributing signing keys in order to be able
     * to begin secure communication.  This is analagous in the real world where we need to
     * have some sort of trust relationship in order to distribute trusted keys.
     *
     * Here, each user has a public asymmetric signing key.
     *)
    Notation KID1 := 0.
    Notation KID2 := 1.

    Notation KEYS := [ skey KID1 ; skey KID2 ].

    Notation KEYS1 := ($0 $+ (KID1, true) $+ (KID2, false)).
    Notation KEYS2 := ($0 $+ (KID1, false) $+ (KID2, true)).

    Notation real_users :=
      [
        (* User 1 implementation *)
        MkRUserSpec USR1 KEYS1
                    (
                      ret 1
                    )
        ;

      (* User 2 implementation *)
      MkRUserSpec USR2 KEYS2
                  (
                    ret 1
                  )
      ].

    (* Here is where we put the implementation universe together.  Like above, it is
     * unlikely anything will need to change here.
     *)
    Definition real_univ_start :=
      mkrU (mkKeys KEYS) real_users.
  End RW.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold
       real_univ_start
       ideal_univ_start
    : user_build.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with user_build; simpl).

End MyProtocol.

Module MyProtocolSecure <: AutomatedSafeProtocolSS.

  Import MyProtocol.

  (* Some things may need to change here.  t__hon is where we place the
   * type that the protocol computes.  It is set to Nat now, because we
   * return a natual number.
   *)
  Definition t__hon := Nat.
  Definition t__adv := Unit.
  Definition b    := tt.

  (* These two variables hook up the starting points for both specification and
   * implementation universes.  If you followed the template above, this shouldn't
   * need to be changed.
   *)
  Definition iu0  := ideal_univ_start.
  Definition ru0  := real_univ_start.

  Import Gen Tacs SetLemmas.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold t__hon t__adv b ru0 iu0 ideal_univ_start real_univ_start : core.
  #[export] Hint Unfold
       mkiU mkiUsr mkrU mkrUsr
       mkKeys
    : core.

  Lemma safe_invariant :
    invariantFor
      {| Initial := {(ru0, iu0, true)}; Step := @stepSS t__hon t__adv  |}
      (fun st => safety st /\ alignment st /\ returns_align st).
  Proof.
    eapply invariant_weaken.

    - eapply multiStepClosure_ok; simpl.
      autounfold in *.
      (* Calls to gen1 will need to be addded here until the model checking terminates. *)
      gen1.
      gen1.

    (* The remaining parts of the proof script shouldn't need to change. *)
    - intros.
      unfold iu0, ideal_univ_start, mkiU in *
      ; simpl in *.

      sets_invert; split_ex
      ; simpl in *; autounfold with core
      ; subst; simpl
      ; unfold safety, alignment, returns_align
      ; ( repeat simple apply conj
          ; [ solve_honest_actions_safe; clean_map_lookups; eauto 8
            | trivial
            | unfold labels_align; intros; rstep; subst; solve_labels_align
            | try solve [ intros; find_step_or_solve ]
        ]).

      Unshelve.
      all: exact 0 || auto.

  Qed.

  Lemma U_good : @universe_starts_sane _ Unit b ru0.
  Proof.
    autounfold;
      unfold universe_starts_sane; simpl.
    repeat (apply conj); intros; eauto.
    - solve_perm_merges; eauto.
    - econstructor.
    - unfold AdversarySafety.keys_honest; rewrite Forall_natmap_forall; intros.
      unfold mkrUsr; simpl.
      rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty; eauto.
    - unfold lameAdv; simpl; eauto.
  Qed.

  Lemma universe_starts_safe : universe_ok ru0.
  Proof.
    pose proof (adversary_is_lame_adv_univ_ok_clauses U_good).

    unfold universe_ok
    ; autounfold
    ; simpl
    ; intuition eauto
    .

    - econstructor; eauto.
    - unfold keys_and_permissions_good; solve_simple_maps; intuition eauto.
      solve_simple_maps; eauto.

      rewrite Forall_natmap_forall; intros.

      solve_simple_maps; simpl
      ; unfold permission_heap_good; intros;
        solve_simple_maps; solve_concrete_maps; eauto.

    - unfold user_cipher_queues_ok.
      rewrite Forall_natmap_forall; intros.
      focus_user
      ; simpl in *; econstructor; eauto.

    - unfold honest_nonces_ok, honest_user_nonces_ok, honest_nonces_ok
      ; repeat simple apply conj
      ; intros
      ; clean_map_lookups
      ; intros
      ; focus_user
      ; try contradiction; try discriminate; simpl;
        repeat (apply conj); intros; clean_map_lookups; eauto.

    - unfold honest_users_only_honest_keys; intros.
      focus_user;
        subst;
        simpl in *;
        clean_map_lookups;
        unfold mkrUsr; simpl;
          rewrite !findUserKeys_add_reduce, findUserKeys_empty_is_empty;
          eauto;
          simpl in *;
          solve_perm_merges;
          solve_concrete_maps;
          solve_simple_maps;
          eauto.
  Qed.

End MyProtocolSecure.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Local Arguments update {_} {_} {_} _ _ _ _ : simpl never.

Require Import VerdiRaft.CommonTheorems.

Require Import VerdiRaft.AppendEntriesRequestLeaderLogsInterface.
Require Import VerdiRaft.OneLeaderLogPerTermInterface.
Require Import VerdiRaft.LeaderLogsSortedInterface.
Require Import VerdiRaft.RefinedLogMatchingLemmasInterface.
Require Import VerdiRaft.AppendEntriesRequestsCameFromLeadersInterface.
Require Import VerdiRaft.AllEntriesLogInterface.
Require Import VerdiRaft.LeaderSublogInterface.
Require Import VerdiRaft.LeadersHaveLeaderLogsStrongInterface.

Require Import VerdiRaft.AllEntriesLeaderLogsInterface.

Section AllEntriesLeaderLogs.

  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {aerlli : append_entries_leaderLogs_interface}.
  Context {ollpti : one_leaderLog_per_term_interface}.
  Context {llsi : leaderLogs_sorted_interface}.
  Context {rlmli : refined_log_matching_lemmas_interface}.
  Context {aercfli : append_entries_came_from_leaders_interface}.
  Context {aeli : allEntries_log_interface}.
  Context {lsi : leader_sublog_interface}.
  Context {lhsi : leaders_have_leaderLogs_strong_interface}.

  Lemma leader_without_missing_entry_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      leader_without_missing_entry net.
  Proof using aeli.
    intros. unfold leader_without_missing_entry.
    find_apply_lem_hyp allEntries_log_invariant.
    unfold allEntries_log in *.
    intros. copy_eapply_prop_hyp allEntries allEntries.
    intuition. right. break_exists; intuition; repeat eexists; eauto.
  Qed.

  Lemma appendEntriesRequest_exists_leaderLog_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      appendEntriesRequest_exists_leaderLog net.
  Proof using aercfli.
    intros. unfold appendEntriesRequest_exists_leaderLog.
    apply append_entries_came_from_leaders_invariant; auto.
  Qed.

  Lemma appendEntriesRequest_leaderLog_not_in_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      appendEntriesRequest_leaderLog_not_in net.
  Proof using rlmli llsi ollpti aerlli.
    unfold appendEntriesRequest_leaderLog_not_in.
    intros.
    find_copy_apply_lem_hyp append_entries_leaderLogs_invariant.
    unfold append_entries_leaderLogs in *.
    pose proof entries_sorted_nw_invariant net ltac:(auto) p _ _ _ _ _ _ ltac:(auto) ltac:(eauto).
    match goal with
    | [ H : In _ (nwPackets _), H' : forall _, _ |- _ ] =>
      copy_eapply H' H
    end; eauto.
    break_exists. break_and.
    pose proof one_leaderLog_per_term_invariant _ ltac:(eauto) (pSrc p) x _ _  _ ltac:(eauto) ltac:(eauto).
    break_and. subst.
    intro.
    match goal with
    | [ H : ~ In _ _ |- _ ] => apply H
    end.
    apply in_or_app. right.
    find_copy_apply_lem_hyp leaderLogs_sorted_invariant; auto.
    find_copy_eapply_lem_hyp maxIndex_is_max; eauto.
    intuition.
    - break_and. subst. lia.
    - break_exists. intuition. subst.
      unfold Prefix_sane in *. intuition.
      + eapply prefix_contiguous; eauto.
        pose proof entries_contiguous_nw_invariant _ ltac:(eauto) p _ _ _ _ _ _ ltac:(auto) ltac:(eauto).
        eapply contiguous_app ; eauto.
      + lia.
    - subst. auto.
  Qed.

  Lemma leaderLogs_leader_invariant :
    forall net,
      refined_raft_intermediate_reachable net ->
      leaderLogs_leader net.
  Proof using lhsi.
    unfold leaderLogs_leader. intros.
    find_apply_lem_hyp leaders_have_leaderLogs_strong_invariant; auto.
    break_exists_exists. intuition.
  Qed.

  Instance aelli :  all_entries_leader_logs_interface.
  Proof.
    split.
    intros.
    red.
    intuition.
    - auto using leader_without_missing_entry_invariant.
    - auto using appendEntriesRequest_exists_leaderLog_invariant.
    - auto using appendEntriesRequest_leaderLog_not_in_invariant.
    - auto using leaderLogs_leader_invariant.
  Qed.
End AllEntriesLeaderLogs.