Require Import Sumbool.

Require Import Raft.
Require Import CommonTheorems.
Require Import TraceUtil.
Require Import Linearizability.
Require Import OutputImpliesAppliedInterface.
Require Import AppliedImpliesInputInterface.
Require Import CausalOrderPreservedInterface.
Require Import OutputCorrectInterface.
Require Import InputBeforeOutputInterface.
Require Import OutputGreatestIdInterface.

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

  Context {oiai : output_implies_applied_interface}.
  Context {aiii : applied_implies_input_interface}.
  Context {copi : causal_order_preserved_interface}.
  Context {iboi : input_before_output_interface}.
  Context {oci : output_correct_interface}.
  Context {ogii : output_greatest_id_interface}.

  Definition op_eq_dec : forall x y : op key, {x = y} + {x <> y}.
  Proof using.
    decide equality; auto using key_eq_dec.
  Qed.

  Fixpoint import (tr : list (name * (raft_input + list raft_output)))
  : list (op key) :=
    match tr with
      | [] => []
      | (_, (inl (ClientRequest c id cmd))) :: xs =>
        I (c, id) :: remove op_eq_dec (I (c, id)) (import xs)
      | (_, (inr l)) :: xs =>
        let os := dedup op_eq_dec
                        (filterMap (fun x =>
                               match x with
                                 | ClientResponse c id cmd => Some (O (c, id))
                                 | _ => None
                               end) l)
        in os ++ remove_all op_eq_dec os (import xs)
      | _ :: xs => import xs
    end.

  Inductive exported (env_i : key -> option input) (env_o : key -> option output) :
    list (IR key) -> list (input * output) -> Prop :=
  | exported_nil : exported env_i env_o nil nil
  | exported_IO : forall k i o l tr,
                    env_i k = Some i ->
                    env_o k = Some o ->
                    exported env_i env_o l tr ->
                    exported env_i env_o (IRI k :: IRO k :: l) ((i, o) :: tr)
  | exported_IU : forall k i o l tr,
                    env_i k = Some i ->
                    exported env_i env_o l tr ->
                    exported env_i env_o (IRI k :: IRU k :: l) ((i, o) :: tr).

  Fixpoint get_input (tr : list (name * (raft_input + list raft_output))) (k : key)
    : option input :=
    match tr with
      | [] => None
      | (_, (inl (ClientRequest c id cmd))) :: xs =>
        if (sumbool_and _ _ _ _
                        (eq_nat_dec c (fst k))
                        (eq_nat_dec id (snd k))) then
          Some cmd
        else
          get_input xs k
      | _ :: xs => get_input xs k
    end.

  Fixpoint get_output' (os : list raft_output) (k : key) : option output :=
    match os with
      | [] => None
      | ClientResponse c id o :: xs =>
        if (sumbool_and _ _ _ _
                        (eq_nat_dec c (fst k))
                        (eq_nat_dec id (snd k))) then
          Some o
        else
          get_output' xs k
      | _ :: xs => get_output' xs k
    end.

  Fixpoint get_output (tr : list (name * (raft_input + list raft_output))) (k : key)
    : option output :=
    match tr with
      | [] => None
      | (_, (inr os)) :: xs => (match get_output' os k with
                                 | Some o => Some o
                                 | None => get_output xs k
                               end)
      | _ :: xs => get_output xs k
    end.

  Lemma has_key_intro :
    forall e,
      has_key (eClient e) (eId e) e = true.
  Proof using.
    unfold has_key.
    intros.
    destruct e.
    simpl.
    repeat (do_bool; intuition).
  Qed.

  Lemma has_key_intro' :
    forall e c i,
      eClient e = c ->
      eId e = i ->
      has_key c i e = true.
  Proof using.
    intros. subst. apply has_key_intro.
  Qed.

  Lemma has_key_different_id_false :
    forall e e',
      eId e <> eId e' ->
      has_key (eClient e) (eId e) e' = false.
  Proof using.
    unfold has_key.
    intros.
    destruct e'.
    simpl in *.
    do_bool. right. do_bool. auto.
  Qed.

  Lemma has_key_different_client_false :
    forall e e',
      eClient e <> eClient e' ->
      has_key (eClient e) (eId e) e' = false.
  Proof using.
    unfold has_key.
    intros.
    destruct e'.
    simpl in *.
    do_bool. left. do_bool. auto.
  Qed.

  Lemma deduplicate_log'_In :
    forall l e,
      In e l ->
      forall ks,
      (forall i, assoc eq_nat_dec ks (eClient e) = Some i -> i < eId e) ->
      (forall id',
         before_func (has_key (eClient e) id') (has_key (eClient e) (eId e)) l ->
         id' <= eId e) ->
      (exists e',
        eClient e' = eClient e /\
        eId e' = eId e /\
        In e' (deduplicate_log' l ks)).
  Proof using.
    induction l; simpl.
    - intuition.
    - intros. repeat break_match; intuition; subst; simpl in *; intuition eauto.
      + do_bool. destruct (eq_nat_dec (eClient e) (eClient a)).
        * assert (eId a <= eId e).
          { repeat find_rewrite. auto using has_key_intro.
          }
          { find_apply_lem_hyp le_lt_or_eq. break_or_hyp.
            - specialize (IHl _ ltac:(eauto)).
              match goal with
                | [ |- context [deduplicate_log' _ ?ks] ] =>
                  specialize (IHl ks)
              end.
              forward IHl.
              { intuition.
                repeat find_rewrite. rewrite get_set_same in *. find_injection. auto.
              }
              concludes.
              forward IHl.
              { intuition auto using has_key_different_id_false with *. }
              concludes.
              break_exists_exists. intuition.
            - eauto.
          }
        * specialize (IHl _ ltac:(eauto)).
          match goal with
            | [ |- context [deduplicate_log' _ ?ks] ] =>
              specialize (IHl ks)
          end.
          forward IHl.
          { intuition.
            repeat find_rewrite. rewrite get_set_diff in * by auto. auto.
          }
          concludes.
          forward IHl.
          { intuition auto using has_key_different_client_false with *. }
          concludes.
          break_exists_exists. intuition.
      + do_bool. assert (n < eId e) by auto. omega.
      + do_bool. apply IHl; auto.
        intros.
        destruct (eq_nat_dec (eClient e) (eClient a)).
        * assert (eId e <> eId a).
          { intro. repeat find_rewrite.
            assert (n < eId a) by auto. omega.
          }
          intuition auto using has_key_different_id_false with *.
        * intuition auto using has_key_different_client_false with *.
      + destruct (eq_nat_dec (eClient e) (eClient a)).
        * assert (eId a <= eId e).
          { repeat find_rewrite. auto using has_key_intro.
          }
          { find_apply_lem_hyp le_lt_or_eq. break_or_hyp.
            - specialize (IHl _ ltac:(eauto)).
              match goal with
                | [ |- context [deduplicate_log' _ ?ks] ] =>
                  specialize (IHl ks)
              end.
              forward IHl.
              { intuition.
                repeat find_rewrite. rewrite get_set_same in *. find_injection. auto.
              }
              concludes.
              forward IHl.
              { intuition auto using has_key_different_id_false with *. }
              concludes.
              break_exists_exists. intuition.
            - eauto.
          }
        * specialize (IHl _ ltac:(eauto)).
          match goal with
            | [ |- context [deduplicate_log' _ ?ks] ] =>
              specialize (IHl ks)
          end.
          forward IHl.
          { intuition.
            repeat find_rewrite. rewrite get_set_diff in * by auto. auto.
          }
          concludes.
          forward IHl.
          { intuition auto using has_key_different_client_false with *. }
          concludes.
          break_exists_exists. intuition.
  Qed.

  Lemma deduplicate_log_In :
    forall l e,
      In e l ->
      (forall id',
         before_func (has_key (eClient e) id') (has_key (eClient e) (eId e)) l ->
         id' <= eId e) ->
      exists e',
        eClient e' = eClient e /\
        eId e' = eId e /\
        In e' (deduplicate_log l).
  Proof using.
    unfold deduplicate_log'.
    intros.
    eapply deduplicate_log'_In with (ks := []) in H; simpl; intuition; try discriminate.
  Qed.

  Lemma deduplicate_log_In_if :
    forall l e,
      In e (deduplicate_log l) ->
      In e l.
  Proof using.
    eauto using deduplicate_log'_In_if.
  Qed.

  Fixpoint log_to_IR (env_o : key -> option output) (log : list entry) {struct log} : list (IR key) :=
    match log with
      | [] => []
      | mkEntry h client id index term input :: log' =>
        (match env_o (client, id) with
           | None => [IRI (client, id); IRU (client, id)]
           | Some _ => [IRI (client, id); IRO (client, id)]
         end) ++ log_to_IR env_o log'
    end.

  Lemma log_to_IR_good_trace :
    forall env_o log,
      good_trace _ (log_to_IR env_o log).
  Proof using.
    intros.
    induction log; simpl in *; auto.
    - repeat break_match; simpl in *; constructor; auto.
  Qed.

  Lemma in_import_in_trace_O :
    forall tr k,
      In (O k) (import tr) ->
      exists os h,
        In (h, inr os) tr /\
        exists o, In (ClientResponse (fst k) (snd k) o) os.
  Proof using.
    induction tr; intros; simpl in *; intuition.
    repeat break_match; subst; intuition.
    - find_apply_hyp_hyp. break_exists_exists.
      intuition.
    - simpl in *. intuition; try congruence.
      find_apply_lem_hyp in_remove.
      find_apply_hyp_hyp. break_exists_exists.
      intuition.
    - do_in_app. intuition.
      + find_apply_lem_hyp in_dedup_was_in.
        find_apply_lem_hyp In_filterMap.
        break_exists. intuition.
        break_match; try congruence.
        find_inversion.
        repeat eexists; intuition eauto.
      + find_apply_lem_hyp in_remove_all_was_in.
        find_apply_hyp_hyp. break_exists_exists.
        intuition.
  Qed.

  Lemma in_import_in_trace_I :
    forall tr k,
      In (I k) (import tr) ->
      exists h i,
        In (h, inl (ClientRequest (fst k) (snd k) i)) tr.
  Proof using.
    induction tr; intros; simpl in *; intuition.
    repeat break_match; subst.
    - find_apply_hyp_hyp. break_exists.
      eauto 10.
    - simpl in *. intuition.
      + find_inversion. simpl. eauto 10.
      + find_apply_lem_hyp in_remove.
        find_apply_hyp_hyp. break_exists. eauto 10.
    - do_in_app. intuition.
      + find_apply_lem_hyp in_dedup_was_in.
        find_eapply_lem_hyp In_filterMap. break_exists. break_and.
        break_match; discriminate.
      + find_eapply_lem_hyp in_remove_all_was_in.
        find_apply_hyp_hyp. break_exists. eauto 10.
  Qed.

  Lemma in_applied_entries_in_IR :
    forall log e client id env,
      eClient e = client ->
      eId e = id ->
      In e log ->
      (exists o, env (client, id) = Some o) ->
      In (IRO (client, id)) (log_to_IR env log).
  Proof using.
    intros.
    induction log; simpl in *; intuition.
    - subst. break_exists.
      repeat break_match; intuition.
      simpl in *.
      subst. congruence.
    - repeat break_match; in_crush.
  Qed.

  Theorem In_get_output' :
    forall l client id o,
      In (ClientResponse client id o) l ->
      exists o', get_output' l (client, id) = Some o'.
  Proof using.
    intros. induction l; simpl in *; intuition.
    - subst. break_if; simpl in *; intuition eauto.
    - break_match; simpl in *; intuition eauto.
      break_if; simpl in *; intuition eauto.
  Qed.

  Theorem import_get_output :
    forall tr k,
      In (O k) (import tr) ->
      exists o,
        get_output tr k = Some o.
  Proof using.
    intros.
    induction tr; simpl in *; intuition.
    repeat break_match; intuition; subst; simpl in *; intuition; try congruence;
    try do_in_app; intuition eauto.
    - find_apply_lem_hyp in_remove; auto.
    - find_apply_lem_hyp in_dedup_was_in; auto.
      find_apply_lem_hyp In_filterMap.
      break_exists; break_match; intuition; try congruence.
      subst. find_inversion.
      find_apply_lem_hyp In_get_output'. break_exists; congruence.
    - find_apply_lem_hyp in_remove_all_was_in. auto.
  Qed.

  Lemma IRO_in_IR_in_log :
    forall k log tr,
      In (IRO k) (log_to_IR (get_output tr) log) ->
      exists e out,
        eClient e = fst k /\
        eId e = snd k /\
        get_output tr k = Some out /\
        In e log.
  Proof using.
    induction log; intros; simpl in *; intuition.
    repeat break_match; subst; simpl in *; intuition; try congruence; try find_inversion; simpl.
    - eexists. eexists. intuition; eauto.
    - find_apply_hyp_hyp. break_exists_exists. intuition.
    - find_apply_hyp_hyp. break_exists_exists. intuition.
  Qed.

  Lemma get_output'_In :
    forall l k out,
      get_output' l k = Some out ->
      In (ClientResponse (fst k) (snd k) out) l.
  Proof using.
    induction l; intros; simpl in *; intuition.
    - discriminate.
    - repeat break_match; subst; eauto.
      find_inversion. break_and. subst. eauto.
  Qed.

  Lemma get_output_import_O :
    forall tr k out,
      get_output tr k = Some out ->
      In (O k) (import tr).
  Proof using.
    induction tr; intros; simpl in *.
    - discriminate.
    - repeat break_match; subst; simpl; intuition eauto.
      + right. apply remove_preserve; try discriminate. eauto.
      + find_inversion. apply in_or_app. left.
        find_apply_lem_hyp get_output'_In.
        apply dedup_In.
        eapply filterMap_In; eauto.
        simpl. now rewrite <- surjective_pairing.
      + apply in_or_app. right.
        apply in_remove_all_preserve.
        * intro. find_apply_lem_hyp in_dedup_was_in.
          find_apply_lem_hyp In_filterMap.
          break_exists. break_and.
          break_match; try discriminate.
          find_inversion.
          find_apply_lem_hyp In_get_output'.
          break_exists. congruence.
        * eauto.
  Qed.

  Lemma IRU_in_IR_in_log :
    forall k log tr,
      In (IRU k) (log_to_IR (get_output tr) log) ->
      exists e,
        eClient e = fst k /\
        eId e = snd k /\
        get_output tr k = None /\
        In e log.
  Proof using.

    induction log; intros; simpl in *; intuition.
    repeat break_match; subst; simpl in *; intuition; try congruence; try find_inversion; simpl.
    - find_apply_hyp_hyp. break_exists_exists. intuition.
    - eexists. intuition; eauto.
    - find_apply_hyp_hyp. break_exists_exists. intuition.
  Qed.

  Lemma trace_I_in_import :
    forall tr k h i,
      In (h, inl (ClientRequest (fst k) (snd k) i)) tr ->
      In (I k) (import tr).
  Proof using.
    induction tr; intros; simpl in *; intuition; subst.
    - rewrite <- surjective_pairing. intuition.
    - break_match; simpl; eauto.
      subst.
      destruct (key_eq_dec (n, n0) k).
      + subst. auto.
      + right. apply remove_preserve.
        * congruence.
        * eauto.
    - apply in_or_app.
      right.
      apply in_remove_all_preserve.
      + intro. find_apply_lem_hyp in_dedup_was_in.
        find_apply_lem_hyp In_filterMap.
        break_exists. break_and.
        break_match; try discriminate.
      + eauto.
  Qed.

  Lemma get_IR_input_of_log_to_IR :
    forall env log,
      get_IR_input_keys _ (log_to_IR env log) =
      map (fun e => (eClient e, eId e)) log.
  Proof using.
    induction log; simpl; intuition.
    repeat break_match; subst; simpl in *;
    rewrite get_IR_input_keys_defn; auto using f_equal.
  Qed.

  Lemma get_IR_output_of_log_to_IR :
    forall env log,
      get_IR_output_keys _ (log_to_IR env log) =
      map (fun e => (eClient e, eId e)) log.
  Proof using.
    induction log; simpl; intuition.
    repeat break_match; subst; simpl in *;
    repeat rewrite get_IR_output_keys_defn; auto using f_equal.
  Qed.

  Lemma NoDup_input_import :
    forall tr,
      NoDup (get_op_input_keys key (import tr)).
  Proof using.
    induction tr; intros.
    - constructor.
    - simpl. repeat break_match; subst.
      + auto.
      + rewrite get_op_input_keys_defn. constructor; auto.
        * intro. find_apply_lem_hyp get_op_input_keys_sound.
          eapply remove_In; eauto.
        * eapply subseq_NoDup; eauto.
          eapply subseq_get_op_input_keys.
          auto using subseq_remove.
      + rewrite get_op_input_keys_app.
        rewrite get_op_input_keys_on_Os_nil.
        * simpl.
          eapply subseq_NoDup; eauto.
          eapply subseq_get_op_input_keys.
          apply subseq_remove_all.
          apply subseq_refl.
        * intros.
          find_apply_lem_hyp in_dedup_was_in.
          find_apply_lem_hyp In_filterMap.
          break_exists.  break_and.
          break_match; try discriminate.
          subst. find_inversion. eauto.
  Qed.

  Lemma NoDup_output_import :
    forall tr,
      NoDup (get_op_output_keys key (import tr)).
  Proof using.
    induction tr; intros.
    - constructor.
    - simpl. repeat break_match; subst.
      + auto.
      + rewrite get_op_output_keys_defn.
        eapply subseq_NoDup; eauto.
        apply subseq_get_op_output_keys.
        apply subseq_remove.
      + rewrite get_op_output_keys_app.
        apply NoDup_disjoint_append.
        * apply get_op_output_keys_preserves_NoDup.
          apply NoDup_dedup.
        * eapply subseq_NoDup; eauto.
          eapply subseq_get_op_output_keys.
          apply subseq_remove_all.
          apply subseq_refl.
        * intros. intro.
          repeat find_apply_lem_hyp get_op_output_keys_sound.
          eapply in_remove_all_not_in; eauto.
  Qed.

  Lemma before_import_output_before_input :
    forall k k' tr,
      before (O k) (I k') (import tr) ->
      output_before_input (fst k) (snd k) (fst k') (snd k') tr.
  Proof using.
    induction tr; intros; simpl in *; intuition.
    repeat break_match; subst; simpl in *; intuition eauto; try congruence;
    unfold output_before_input; simpl in *; intuition.
    - right. intuition.
      + do_bool.
        destruct k'.  simpl in *.
        match goal with
          | _ : I (?x, ?y) = I (?x', ?y') -> False |- _ =>
            destruct (eq_nat_dec x x'); destruct (eq_nat_dec y y')
        end; subst; intuition.
        * right. do_bool. intuition.
        * left. do_bool. intuition.
        * left. do_bool. intuition.
      + apply IHtr. eauto using before_remove.
    - break_if; intuition. right.
      intuition. find_apply_lem_hyp before_app; [find_apply_lem_hyp before_remove_all|]; intuition eauto.
      + find_apply_lem_hyp in_dedup_was_in.
        find_apply_lem_hyp In_filterMap.
        break_exists. intuition. break_match; congruence.
      + find_apply_lem_hyp in_dedup_was_in.
        find_apply_lem_hyp In_filterMap.
        break_exists.
        intuition. break_match; try congruence.
        subst. find_inversion. simpl in *.
        match goal with
          | H : _ -> False |- False => apply H
        end. eexists; eauto.
  Qed.

  Lemma has_key_true_key_of :
    forall c i e,
      has_key c i e = true ->
      key_of e = (c, i).
  Proof using.
    intros. unfold has_key, key_of in *.
    break_match. subst. simpl in *. repeat (do_bool; intuition).
  Qed.

  Lemma key_of_has_key_true :
    forall c i e,
      key_of e = (c, i) ->
      has_key c i e = true.
  Proof using.
    intros. unfold has_key, key_of in *.
    break_match. subst. simpl in *. find_inversion. repeat (do_bool; intuition).
  Qed.

  Lemma has_key_false_key_of :
    forall c i e,
      has_key c i e = false ->
      key_of e <> (c, i).
  Proof using.
    intros. unfold has_key, key_of in *.
    break_match. subst. simpl in *. repeat (do_bool; intuition); congruence.
  Qed.

  Lemma key_of_has_key_false :
    forall c i e,
      key_of e <> (c, i) ->
      has_key c i e = false.
  Proof using.
    intros. unfold has_key, key_of in *.
    break_match. subst. simpl in *. repeat (do_bool; intuition).
    match goal with
      | _ : (?x, ?y) = (?x', ?y') -> False |- _ =>
        destruct (eq_nat_dec x x'); destruct (eq_nat_dec y y')
    end; subst; intuition.
    - right. do_bool. congruence.
    - left. do_bool. congruence.
    - left. do_bool. congruence.
  Qed.

  Lemma before_func_antisymmetric :
    forall A f g l,
      (forall x, f x = true -> g x = true -> False) ->
      before_func(A:=A) f g l ->
      before_func g f l ->
      False.
  Proof using.
    induction l; simpl; intuition.
    - eauto.
    - congruence.
    - congruence.
  Qed.

  Lemma has_key_true_same_client :
    forall c i e,
      has_key c i e = true ->
      eClient e = c.
  Proof using.
    unfold has_key.
    intros. destruct e.
    simpl. do_bool. intuition. do_bool. auto.
  Qed.

  Lemma has_key_true_same_id :
    forall c i e,
      has_key c i e = true ->
      eId e = i.
  Proof using.
    unfold has_key.
    intros. destruct e.
    simpl. do_bool. intuition. do_bool. auto.
  Qed.

  Lemma has_key_true_elim :
    forall c i e,
      has_key c i e = true ->
      eClient e = c /\ eId e = i.
  Proof using.
    intuition eauto using has_key_true_same_client, has_key_true_same_id.
  Qed.

  Lemma has_key_false_elim :
    forall c i e,
      has_key c i e = false ->
      eClient e <> c \/ eId e <> i.
  Proof using.
    unfold has_key.
    intros. destruct e. simpl. do_bool. intuition (do_bool; auto).
  Qed.

  Lemma before_func_deduplicate' :
    forall l k k' ks,
      before_func (has_key (fst k) (snd k)) (has_key (fst k') (snd k')) l ->
      (forall id',
         before_func (has_key (fst k) id') (has_key (fst k) (snd k)) l ->
         id' <= snd k) ->
      (forall i, assoc eq_nat_dec ks (fst k) = Some i -> i < snd k) ->
      before_func (has_key (fst k) (snd k)) (has_key (fst k') (snd k')) (deduplicate_log' l ks).
  Proof using.
    induction l; simpl; intros.
    - intuition.
    - intuition.
      + repeat break_match; simpl; auto.
        do_bool.
        find_apply_lem_hyp has_key_true_elim. break_and. repeat find_rewrite.
        assert (n < snd k) by auto. omega.
      + repeat break_match; simpl.
        * { destruct (has_key (fst k) (snd k) a) eqn:?; auto.
            right. intuition. apply IHl; auto.
            do_bool.
            intros. destruct (eq_nat_dec (eClient a) (fst k)).
            - repeat find_rewrite. rewrite get_set_same in *. find_inversion.
              repeat match goal with
                | H : context [ has_key (fst k')] |- _ => clear H
              end.
              find_apply_lem_hyp has_key_false_elim.
              intuition; try congruence.
              assert (has_key (fst k) (eId a) a = true) by eauto using has_key_intro'.
              assert (eId a <= snd k) by auto.
              omega.
            - rewrite get_set_diff in * by auto. auto.
          }
        * do_bool. apply IHl; auto. intros.
          { destruct (has_key (fst k) (snd k) a) eqn:?; auto.
            find_apply_lem_hyp has_key_true_elim. break_and.
            repeat find_rewrite. assert (n < snd k) by auto. omega.
          }
        * { destruct (has_key (fst k) (snd k) a) eqn:?; auto.
            right. intuition. apply IHl; auto.
            do_bool.
            intros. destruct (eq_nat_dec (eClient a) (fst k)).
            - repeat find_rewrite. rewrite get_set_same in *. find_inversion.
              repeat match goal with
                | H : context [ has_key (fst k')] |- _ => clear H
              end.
              find_apply_lem_hyp has_key_false_elim.
              intuition; try congruence.
              assert (has_key (fst k) (eId a) a = true) by eauto using has_key_intro'.
              assert (eId a <= snd k) by auto.
              omega.
            - rewrite get_set_diff in * by auto. auto.
          }
  Qed.

  Lemma before_func_deduplicate :
    forall k k' l,
      before_func (has_key (fst k) (snd k)) (has_key (fst k') (snd k')) l ->
      (forall id',
         before_func (has_key (fst k) id') (has_key (fst k) (snd k)) l ->
         id' <= snd k) ->
      before_func (has_key (fst k) (snd k)) (has_key (fst k') (snd k')) (deduplicate_log l).
  Proof using.
    intros.
    apply before_func_deduplicate'; auto.
    simpl. intros. discriminate.
  Qed.

  Lemma entries_ordered_before_log_to_IR :
    forall k k' net failed tr,
      step_f_star step_f_init (failed, net) tr ->
      In (O k) (import tr) ->
      k <> k' ->
      entries_ordered (fst k) (snd k) (fst k') (snd k') net ->
      before (IRO k) (IRI k')
             (log_to_IR (get_output tr) (deduplicate_log (applied_entries (nwState net)))).
  Proof using ogii.
    intros. unfold entries_ordered in *.
    remember (applied_entries (nwState net)) as l.
    find_apply_lem_hyp before_func_deduplicate.
    {
      remember (deduplicate_log l) as l'; clear Heql'. clear Heql. clear l. rename l' into l.
      induction l; simpl in *; intuition.
      - repeat break_match; subst; simpl in *; repeat (do_bool; intuition).
        + destruct k; simpl in *; subst. right. intuition.
          find_inversion. simpl in *. intuition.
        + exfalso. destruct k; subst; simpl in *.
          find_apply_lem_hyp import_get_output. break_exists. congruence.
      - repeat break_match; subst; simpl in *; repeat (do_bool; intuition).
        + right. destruct k'. simpl in *. intuition; try congruence.
          destruct (key_eq_dec k (eClient, eId)); subst; intuition.
          right. intuition; congruence.
        + right. destruct k'. simpl in *. intuition; try congruence.
          destruct (key_eq_dec k (eClient, eId)); subst; intuition.
          right. intuition; congruence.
        + right. intuition; [find_inversion; simpl in *; intuition|].
          right. intuition. congruence.
        + right. intuition; [find_inversion; simpl in *; intuition|].
          right. intuition. congruence.
    }
    {
      intros. subst.
      eapply output_greatest_id with (client := fst k) (id := snd k) in H.
      - intros. unfold greatest_id_for_client in *.
        destruct (le_lt_dec id' (snd k)); auto.
        find_copy_apply_hyp_hyp.
        exfalso. eapply before_func_antisymmetric; try eassumption.
        unfold has_key.
        intros. destruct x.
        do_bool. intuition. do_bool. subst. omega.
      - red. find_apply_lem_hyp in_import_in_trace_O.
        break_exists_exists. intuition.
    }
  Qed.

  Lemma input_before_output_import :
    forall tr k,
      before_func (is_input_with_key (fst k) (snd k))
                  (is_output_with_key (fst k) (snd k)) tr ->
      before (I k) (O k) (import tr).
  Proof using.
    intros; induction tr; simpl in *; intuition.
    - repeat break_match; subst; simpl in *; intuition; try congruence.
      repeat (do_bool; intuition).
      destruct k; subst; simpl in *; intuition.
    - repeat break_match; subst; simpl in *; intuition; try congruence.
      + destruct k.
        match goal with
          | |- context [ I (?x, ?y) = I (?x', ?y') ] =>
            destruct (op_eq_dec (I (x, y)) (I (x', y')))
        end; subst; intuition.
        right.
        intuition; try congruence.
        apply before_remove_if; intuition.
      + break_if; try congruence.
        apply before_app_if; [apply before_remove_all_if|]; auto.
        * intuition. find_apply_lem_hyp in_dedup_was_in.
          find_apply_lem_hyp In_filterMap. break_exists.
          break_match; intuition; congruence.
        * intuition.
          match goal with
            | H : _ -> False |- False => apply H
          end.
          find_apply_lem_hyp in_dedup_was_in.
          find_apply_lem_hyp In_filterMap.
          break_exists. intuition. break_match; try congruence.
          find_inversion.
          unfold key_in_output_list. simpl.
          eexists; eauto.
  Qed.

  Lemma I_before_O :
    forall failed net tr k,
      step_f_star step_f_init (failed, net) tr ->
      In (O k) (import tr) ->
      before (I k) (O k) (import tr).
  Proof using iboi.
    intros.
    find_apply_lem_hyp in_import_in_trace_O.
    find_eapply_lem_hyp output_implies_input_before_output; eauto.
    eauto using input_before_output_import.
  Qed.

  Lemma get_IR_input_keys_log_to_IR :
    forall l env_o,
      get_IR_input_keys key (log_to_IR env_o l) =
      map (fun e => (eClient e, eId e)) l.
  Proof using.
    intros. induction l; simpl in *; intuition.
    repeat break_match; subst; compute; simpl; f_equal; auto.
  Qed.

  Lemma get_IR_output_keys_log_to_IR :
    forall l env_o,
      get_IR_output_keys key (log_to_IR env_o l) =
      map (fun e => (eClient e, eId e)) l.
  Proof using.
    intros. induction l; simpl in *; intuition.
    repeat break_match; subst; compute; simpl; f_equal; auto.
  Qed.

  Lemma deduplicate_log'_ks :
    forall l ks e id,
      In e (deduplicate_log' l ks) ->
      assoc eq_nat_dec ks (eClient e) = Some id ->
      id < (eId e).
  Proof using.
    induction l; intros; simpl in *; intuition.
    repeat break_match; simpl in *; do_bool; intuition; subst; eauto;
    repeat find_rewrite; repeat find_inversion; intuition.
    - destruct (eq_nat_dec (eClient e) (eClient a)); repeat find_rewrite.
      * find_injection.
        eapply IHl with (id := eId a) in H1; try omega.
        repeat find_rewrite. eauto using get_set_same.
      * eapply IHl with (id := id) in H1; try omega.
        rewrite get_set_diff; auto.
    - congruence.
    - destruct (eq_nat_dec (eClient e) (eClient a)); repeat find_rewrite.
      * congruence.
      * eapply IHl with (id := id) in H1; try omega.
        rewrite get_set_diff; auto.
  Qed.

  Lemma NoDup_deduplicate_log' :
    forall l ks,
      NoDup (map (fun e => (eClient e, eId e)) (deduplicate_log' l ks)).
  Proof using.
    induction l; intros.
    - simpl in *. constructor.
    - simpl in *. repeat break_match; eauto.
      + simpl in *. constructor; eauto.
        intuition. do_in_map. find_inversion.
        eapply deduplicate_log'_ks with (id := eId a) in H0; try omega.
        repeat find_rewrite.
        rewrite get_set_same. auto.
      + simpl in *. constructor; eauto.
        intuition. do_in_map. find_inversion.
        eapply deduplicate_log'_ks with (id := eId a) in H0; try omega.
        repeat find_rewrite.
        rewrite get_set_same. auto.
  Qed.

  Lemma NoDup_deduplicate_log :
    forall l,
      NoDup (map (fun e => (eClient e, eId e)) (deduplicate_log l)).
  Proof using.
    eauto using NoDup_deduplicate_log'.
  Qed.

  Lemma NoDup_input_log :
    forall l env_o,
      NoDup (get_IR_input_keys key (log_to_IR env_o (deduplicate_log l))).
  Proof using.
    intros.
    rewrite get_IR_input_keys_log_to_IR.
    eauto using NoDup_deduplicate_log.
  Qed.

  Lemma NoDup_output_log :
    forall l env_o,
      NoDup (get_IR_output_keys key (log_to_IR env_o (deduplicate_log l))).
  Proof using.
    intros.
    rewrite get_IR_output_keys_log_to_IR.
    eauto using NoDup_deduplicate_log.
  Qed.

  Hint Constructors exported.

  Lemma exported_snoc_IO :
    forall env_i env_o ir tr i o k,
      exported env_i env_o ir tr ->
      env_i k = Some i ->
      env_o k = Some o ->
      exported env_i env_o (ir ++ [IRI k; IRO k]) (tr ++ [(i, o)]).
  Proof using.
    induction 1; intros; simpl; auto.
  Qed.

  Lemma exported_snoc_IU :
    forall env_i env_o ir tr i k o,
      exported env_i env_o ir tr ->
      env_i k = Some i ->
      env_o k = None ->
      exported env_i env_o (ir ++ [IRI k; IRU k]) (tr ++ [(i, o)]).
  Proof using.
    induction 1; intros; simpl; auto.
  Qed.

  Lemma log_to_IR_app :
    forall xs ys env,
      log_to_IR env (xs ++ ys) = log_to_IR env xs ++ log_to_IR env ys.
  Proof using.
    induction xs; intros; simpl; intuition.
    repeat break_match; subst; simpl; auto using f_equal.
  Qed.

  Lemma exported_execute_log' :
    forall env_i env_o l es tr st,
      (forall e, In e l -> env_i (eClient e, eId e) = Some (eInput e)) ->
      (forall xs ys e tr' st' o o0 st'',
         l = xs ++ e :: ys ->
         execute_log' xs st tr = (tr', st') ->
         handler (eInput e) st' = (o, st'') ->
         env_o (eClient e, eId e) = Some o0 ->
         o = o0) ->
      execute_log es = (tr, st) ->
      exported env_i env_o (log_to_IR env_o es) tr ->
      exported env_i env_o (log_to_IR env_o (es ++ l)) (fst (execute_log' l st tr)).
  Proof using.
    induction l using rev_ind; intros; simpl in *.
    - rewrite app_nil_r.  auto.
    - rewrite execute_log'_app. simpl. repeat break_let.
      simpl.
      eapply_prop_hyp execute_log execute_log; auto.
      + find_rewrite. simpl in *.
        rewrite <- app_ass.
        rewrite log_to_IR_app.
        simpl.
        specialize (H x). concludes.
        specialize (H0 l [] x l0 d).
        break_match; subst; simpl in *.
        rewrite app_nil_r.
        break_match.
        * specialize (H0 o o0 d0). repeat concludes.
          apply exported_snoc_IO; congruence.
        * apply exported_snoc_IU; auto.
      + intros. apply H. intuition.
      + intros. subst. eapply H0 with (ys0 := ys ++ [x]).
        rewrite app_ass. simpl. eauto.
        eauto.
        eauto.
        eauto.
  Qed.

  Lemma exported_execute_log :
    forall env_i env_o l,
      (forall e, In e l -> env_i (eClient e, eId e) = Some (eInput e)) ->
      (forall xs ys e tr' st' o o0 st'',
         l = xs ++ e :: ys ->
         execute_log xs  = (tr', st') ->
         handler (eInput e) st' = (o, st'') ->
         env_o (eClient e, eId e) = Some o0 ->
         o = o0) ->
      exported env_i env_o (log_to_IR env_o l) (fst (execute_log l)).
  Proof using.
    intros.
    unfold execute_log.
    change (log_to_IR env_o l) with (log_to_IR env_o ([] ++ l)).
    eapply exported_execute_log'; eauto.
  Qed.

  Definition input_correct (tr : list (name * (raft_input + list raft_output))) : Prop :=
    (forall client id i i' h h',
       In (h, inl (ClientRequest client id i)) tr ->
       In (h', inl (ClientRequest client id i')) tr ->
       i = i').

  Lemma in_input_trace_get_input :
    forall tr e,
      input_correct tr ->
      in_input_trace (eClient e) (eId e) (eInput e) tr ->
      get_input tr (eClient e, eId e) = Some (eInput e).
  Proof using.
    unfold in_input_trace, input_correct.
    induction tr; intros; break_exists; simpl in *; intuition; subst;
    repeat break_match; intuition; subst; eauto 10 using f_equal.
  Qed.

  Lemma get_output_in_output_trace :
    forall tr client id o,
      get_output tr (client, id) = Some o ->
      in_output_trace client id o tr.
  Proof using.
    intros. induction tr; simpl in *; try congruence.
    repeat break_let. subst.
    repeat break_match; simpl in *; intuition; subst;
    try solve [unfold in_output_trace in *;break_exists_exists; intuition].
    find_inversion. find_apply_lem_hyp get_output'_In.
    repeat eexists; eauto; in_crush.
  Qed.

  Lemma NoDup_map_partition :
    forall A B (f : A -> B) xs l y zs xs' y' zs',
      NoDup (map f l) ->
      l = xs ++ y :: zs ->
      l = xs' ++ y' :: zs' ->
      f y = f y' ->
      xs = xs'.
  Proof using.
    induction xs; simpl; intros; destruct xs'.
    - auto.
    - subst. simpl in *. find_inversion.
      invc H. exfalso. rewrite map_app in *. simpl in *.
      repeat find_rewrite. intuition.
    - subst. simpl in *. find_inversion.
      invc H. exfalso. rewrite map_app in *. simpl in *.
      repeat find_rewrite. intuition.
    - subst. simpl in *. find_injection. intros. subst.
      f_equal. eapply IHxs; eauto. solve_by_inversion.
  Qed.

  Lemma deduplicate_partition :
    forall l xs e ys xs' e' ys',
      deduplicate_log l = xs ++ e :: ys ->
      deduplicate_log l = xs' ++ e' :: ys' ->
      eClient e = eClient e' ->
      eId e = eId e' ->
      xs = xs'.
  Proof using.
    intros.
    eapply NoDup_map_partition.
    - apply NoDup_deduplicate_log.
    - eauto.
    - eauto.
    - simpl. congruence.
  Qed.

  Lemma applied_entries_applied_implies_input_state :
    forall net e,
      In e (applied_entries (nwState net)) ->
      applied_implies_input_state (eClient e) (eId e) (eInput e) net.
  Proof using.
    intros.
    red. exists e.
    intuition.
    - red. auto.
    - unfold applied_entries in *. break_match.
      + find_apply_lem_hyp in_rev.
        find_apply_lem_hyp removeAfterIndex_in.
        eauto.
      + simpl in *. intuition.
  Qed.

  Lemma before_func_before :
    forall A f g l,
      before_func f g l ->
      forall y,
        g y = true ->
        exists x : A,
          f x = true /\
          before x y l.
  Proof using.
    induction l; intros; simpl in *; intuition.
    - eauto.
    - find_copy_apply_hyp_hyp. break_exists_exists. intuition.
      right. intuition. congruence.
  Qed.

  Theorem raft_linearizable' :
    forall failed net tr,
      input_correct tr ->
      step_f_star step_f_init (failed, net) tr ->
      exists l tr1 st,
        equivalent _ (import tr) l /\
        exported (get_input tr) (get_output tr) l tr1 /\
        step_1_star init st tr1.
  Proof using ogii oci iboi copi aiii oiai.
    intros.
    exists (log_to_IR (get_output tr) (deduplicate_log (applied_entries (nwState net)))).
    exists (fst (execute_log (deduplicate_log (applied_entries (nwState net))))).
    exists (snd (execute_log (deduplicate_log (applied_entries (nwState net))))).
    intuition eauto using execute_log_correct.
    - eapply equivalent_intro; eauto using log_to_IR_good_trace, key_eq_dec.
      + (* In O -> In IRO *)
        intros.
        find_copy_apply_lem_hyp in_import_in_trace_O.
        find_eapply_lem_hyp output_implies_applied; eauto.
        unfold in_applied_entries in *.
        break_exists. intuition.
        destruct k; simpl in *.
        find_apply_lem_hyp deduplicate_log_In.
        * break_exists. intuition.
          repeat find_rewrite.
          eapply in_applied_entries_in_IR; eauto.
          apply import_get_output. auto.
        * { eapply output_greatest_id with (client := eClient x) (id := eId x) in H0.
            - intros. unfold greatest_id_for_client in *.
              subst. destruct (le_lt_dec id' (eId x)); auto.
              find_copy_apply_hyp_hyp.
              exfalso. eapply before_func_antisymmetric; try eassumption.
              unfold has_key.
              intros. destruct x0.
              do_bool. intuition. do_bool. subst. omega.
            - red. find_apply_lem_hyp in_import_in_trace_O.
              break_exists_exists. intuition. red.
              simpl in *. subst. auto.
          }
      + (* In IRO -> In O *)
        intros.
        find_apply_lem_hyp IRO_in_IR_in_log. break_exists. break_and.
        eapply get_output_import_O; eauto.
      + (* In IRU -> In I *)
        intros.
        find_apply_lem_hyp IRU_in_IR_in_log. break_exists. break_and.
        destruct k as [c id].
        find_apply_lem_hyp deduplicate_log_In_if.
        find_eapply_lem_hyp applied_implies_input; eauto.
        * unfold in_input_trace in *. break_exists.
          eauto using trace_I_in_import.
        * simpl in *. subst.
          auto using applied_entries_applied_implies_input_state.
      + (* before preserved *)
        intros.
        assert (k <> k').
        * intuition. subst.
          find_copy_apply_lem_hyp before_In.
          find_eapply_lem_hyp I_before_O; eauto.
          find_eapply_lem_hyp before_antisymmetric; auto.
          congruence.
        * eauto using before_In, before_import_output_before_input, causal_order_preserved,
          entries_ordered_before_log_to_IR.
      + (* I before O *)
        intros. eauto using I_before_O.
      + (* In IRU -> not In O *)
        intros.
        find_apply_lem_hyp IRU_in_IR_in_log. break_exists. break_and.
        intro.
        find_apply_lem_hyp import_get_output.
        break_exists. congruence.
      + (* NoDup op input *)
        apply NoDup_input_import.
      + (* NoDup IR input *)
        apply NoDup_input_log.
      + (* NoDup op output *)
        apply NoDup_output_import.
      + (* NoDup IR output *)
        apply NoDup_output_log.
    - apply exported_execute_log.
      + intros.
        find_apply_lem_hyp deduplicate_log_In_if.
        apply in_input_trace_get_input.
        * auto.
        * eapply applied_implies_input; eauto.
          auto using applied_entries_applied_implies_input_state.
      + intros.
        find_apply_lem_hyp get_output_in_output_trace.
        find_eapply_lem_hyp output_correct_invariant; eauto.
        unfold output_correct in *.
        break_exists. intuition.
        find_eapply_lem_hyp deduplicate_partition; eauto.
        subst.
        repeat find_rewrite.
        find_apply_lem_hyp app_inv_head. find_inversion.
        unfold execute_log in *.
        find_rewrite_lem execute_log'_app. simpl in *.
        repeat break_let. repeat find_inversion.
        rewrite rev_app_distr in *. simpl in *.
        unfold value in *. find_inversion.
        repeat find_rewrite. find_inversion. auto.
  Qed.
End RaftLinearizableProofs.


From algebra Require Export excl.
From algebra Require Import upred.
Local Arguments valid _ _ !_ /.
Local Arguments validN _ _ _ !_ /.

Record auth (A : Type) : Type := Auth { authoritative : excl A ; own : A }.
Add Printing Constructor auth.
Arguments Auth {_} _ _.
Arguments authoritative {_} _.
Arguments own {_} _.
Notation "◯ a" := (Auth ExclUnit a) (at level 20).
Notation "● a" := (Auth (Excl a) ∅) (at level 20).

(* COFE *)
Section cofe.
Context {A : cofeT}.
Implicit Types a : excl A.
Implicit Types b : A.
Implicit Types x y : auth A.

Instance auth_equiv : Equiv (auth A) := λ x y,
  authoritative x ≡ authoritative y ∧ own x ≡ own y.
Instance auth_dist : Dist (auth A) := λ n x y,
  authoritative x ≡{n}≡ authoritative y ∧ own x ≡{n}≡ own y.

Global Instance Auth_ne : Proper (dist n ==> dist n ==> dist n) (@Auth A).
Proof. by split. Qed.
Global Instance Auth_proper : Proper ((≡) ==> (≡) ==> (≡)) (@Auth A).
Proof. by split. Qed.
Global Instance authoritative_ne: Proper (dist n ==> dist n) (@authoritative A).
Proof. by destruct 1. Qed.
Global Instance authoritative_proper : Proper ((≡) ==> (≡)) (@authoritative A).
Proof. by destruct 1. Qed.
Global Instance own_ne : Proper (dist n ==> dist n) (@own A).
Proof. by destruct 1. Qed.
Global Instance own_proper : Proper ((≡) ==> (≡)) (@own A).
Proof. by destruct 1. Qed.

Instance auth_compl : Compl (auth A) := λ c,
  Auth (compl (chain_map authoritative c)) (compl (chain_map own c)).
Definition auth_cofe_mixin : CofeMixin (auth A).
Proof.
  split.
  - intros x y; unfold dist, auth_dist, equiv, auth_equiv.
    rewrite !equiv_dist; naive_solver.
  - intros n; split.
    + by intros ?; split.
    + by intros ?? [??]; split; symmetry.
    + intros ??? [??] [??]; split; etrans; eauto.
  - by intros ? [??] [??] [??]; split; apply dist_S.
  - intros n c; split. apply (conv_compl n (chain_map authoritative c)).
    apply (conv_compl n (chain_map own c)).
Qed.
Canonical Structure authC := CofeT auth_cofe_mixin.

Global Instance Auth_timeless a b :
  Timeless a → Timeless b → Timeless (Auth a b).
Proof. by intros ?? [??] [??]; split; apply: timeless. Qed.
Global Instance auth_discrete : Discrete A → Discrete authC.
Proof. intros ? [??]; apply _. Qed.
Global Instance auth_leibniz : LeibnizEquiv A → LeibnizEquiv (auth A).
Proof. by intros ? [??] [??] [??]; f_equal/=; apply leibniz_equiv. Qed.
End cofe.

Arguments authC : clear implicits.

(* CMRA *)
Section cmra.
Context {A : cmraT}.
Implicit Types a b : A.
Implicit Types x y : auth A.

Global Instance auth_empty `{Empty A} : Empty (auth A) := Auth ∅ ∅.
Instance auth_valid : Valid (auth A) := λ x,
  match authoritative x with
  | Excl a => own x ≼ a ∧ ✓ a
  | ExclUnit => ✓ own x
  | ExclBot => False
  end.
Global Arguments auth_valid !_ /.
Instance auth_validN : ValidN (auth A) := λ n x,
  match authoritative x with
  | Excl a => own x ≼{n} a ∧ ✓{n} a
  | ExclUnit => ✓{n} own x
  | ExclBot => False
  end.
Global Arguments auth_validN _ !_ /.
Instance auth_core : Core (auth A) := λ x,
  Auth (core (authoritative x)) (core (own x)).
Instance auth_op : Op (auth A) := λ x y,
  Auth (authoritative x ⋅ authoritative y) (own x ⋅ own y).
Instance auth_div : Div (auth A) := λ x y,
  Auth (authoritative x ÷ authoritative y) (own x ÷ own y).

Lemma auth_included (x y : auth A) :
  x ≼ y ↔ authoritative x ≼ authoritative y ∧ own x ≼ own y.
Proof.
  split; [intros [[z1 z2] Hz]; split; [exists z1|exists z2]; apply Hz|].
  intros [[z1 Hz1] [z2 Hz2]]; exists (Auth z1 z2); split; auto.
Qed.
Lemma authoritative_validN n (x : auth A) : ✓{n} x → ✓{n} authoritative x.
Proof. by destruct x as [[]]. Qed.
Lemma own_validN n (x : auth A) : ✓{n} x → ✓{n} own x.
Proof. destruct x as [[]]; naive_solver eauto using cmra_validN_includedN. Qed.

Definition auth_cmra_mixin : CMRAMixin (auth A).
Proof.
  split.
  - by intros n x y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - by intros n y1 y2 [Hy Hy']; split; simpl; rewrite ?Hy ?Hy'.
  - intros n [x a] [y b] [Hx Ha]; simpl in *;
      destruct Hx; intros ?; cofe_subst; auto.
  - by intros n x1 x2 [Hx Hx'] y1 y2 [Hy Hy'];
      split; simpl; rewrite ?Hy ?Hy' ?Hx ?Hx'.
  - intros [[] ?]; rewrite /= ?cmra_included_includedN ?cmra_valid_validN;
      naive_solver eauto using O.
  - intros n [[] ?] ?; naive_solver eauto using cmra_includedN_S, cmra_validN_S.
  - by split; simpl; rewrite assoc.
  - by split; simpl; rewrite comm.
  - by split; simpl; rewrite ?cmra_core_l.
  - by split; simpl; rewrite ?cmra_core_idemp.
  - intros ??; rewrite! auth_included; intros [??].
    by split; simpl; apply cmra_core_preserving.
  - assert (∀ n (a b1 b2 : A), b1 ⋅ b2 ≼{n} a → b1 ≼{n} a).
    { intros n a b1 b2 <-; apply cmra_includedN_l. }
   intros n [[a1| |] b1] [[a2| |] b2];
     naive_solver eauto using cmra_validN_op_l, cmra_validN_includedN.
  - by intros ??; rewrite auth_included;
      intros [??]; split; simpl; apply cmra_op_div.
  - intros n x y1 y2 ? [??]; simpl in *.
    destruct (cmra_extend n (authoritative x) (authoritative y1)
      (authoritative y2)) as (ea&?&?&?); auto using authoritative_validN.
    destruct (cmra_extend n (own x) (own y1) (own y2))
      as (b&?&?&?); auto using own_validN.
    by exists (Auth (ea.1) (b.1), Auth (ea.2) (b.2)).
Qed.
Canonical Structure authR : cmraT := CMRAT auth_cofe_mixin auth_cmra_mixin.
Global Instance auth_cmra_discrete : CMRADiscrete A → CMRADiscrete authR.
Proof.
  split; first apply _.
  intros [[] ?]; by rewrite /= /cmra_valid /cmra_validN /=
    -?cmra_discrete_included_iff -?cmra_discrete_valid_iff.
Qed.

(** Internalized properties *)
Lemma auth_equivI {M} (x y : auth A) :
  (x ≡ y)%I ≡ (authoritative x ≡ authoritative y ∧ own x ≡ own y : uPred M)%I.
Proof. by uPred.unseal. Qed.
Lemma auth_validI {M} (x : auth A) :
  (✓ x)%I ≡ (match authoritative x with
             | Excl a => (∃ b, a ≡ own x ⋅ b) ∧ ✓ a
             | ExclUnit => ✓ own x
             | ExclBot => False
             end : uPred M)%I.
Proof. uPred.unseal. by destruct x as [[]]. Qed.

(** The notations ◯ and ● only work for CMRAs with an empty element. So, in
what follows, we assume we have an empty element. *)
Context `{Empty A, !CMRAUnit A}.

Global Instance auth_cmra_unit : CMRAUnit authR.
Proof.
  split; simpl.
  - by apply (@cmra_unit_valid A _).
  - by intros x; constructor; rewrite /= left_id.
  - apply _.
Qed.
Lemma auth_frag_op a b : ◯ (a ⋅ b) ≡ ◯ a ⋅ ◯ b.
Proof. done. Qed.
Lemma auth_both_op a b : Auth (Excl a) b ≡ ● a ⋅ ◯ b.
Proof. by rewrite /op /auth_op /= left_id. Qed.

Lemma auth_update a a' b b' :
  (∀ n af, ✓{n} a → a ≡{n}≡ a' ⋅ af → b ≡{n}≡ b' ⋅ af ∧ ✓{n} b) →
  ● a ⋅ ◯ a' ~~> ● b ⋅ ◯ b'.
Proof.
  move=> Hab n [[?| |] bf1] // =>-[[bf2 Ha] ?]; do 2 red; simpl in *.
  destruct (Hab n (bf1 ⋅ bf2)) as [Ha' ?]; auto.
  { by rewrite Ha left_id assoc. }
  split; [by rewrite Ha' left_id assoc; apply cmra_includedN_l|done].
Qed.

Lemma auth_local_update L `{!LocalUpdate Lv L} a a' :
  Lv a → ✓ L a' →
  ● a' ⋅ ◯ a ~~> ● L a' ⋅ ◯ L a.
Proof.
  intros. apply auth_update=>n af ? EQ; split; last by apply cmra_valid_validN.
  by rewrite EQ (local_updateN L) // -EQ.
Qed.

Lemma auth_update_op_l a a' b :
  ✓ (b ⋅ a) → ● a ⋅ ◯ a' ~~> ● (b ⋅ a) ⋅ ◯ (b ⋅ a').
Proof. by intros; apply (auth_local_update _). Qed.
Lemma auth_update_op_r a a' b :
  ✓ (a ⋅ b) → ● a ⋅ ◯ a' ~~> ● (a ⋅ b) ⋅ ◯ (a' ⋅ b).
Proof. rewrite -!(comm _ b); apply auth_update_op_l. Qed.

(* This does not seem to follow from auth_local_update.
   The trouble is that given ✓ (L a ⋅ a'), Lv a
   we need ✓ (a ⋅ a'). I think this should hold for every local update,
   but adding an extra axiom to local updates just for this is silly. *)
Lemma auth_local_update_l L `{!LocalUpdate Lv L} a a' :
  Lv a → ✓ (L a ⋅ a') →
  ● (a ⋅ a') ⋅ ◯ a ~~> ● (L a ⋅ a') ⋅ ◯ L a.
Proof.
  intros. apply auth_update=>n af ? EQ; split; last by apply cmra_valid_validN.
  by rewrite -(local_updateN L) // EQ -(local_updateN L) // -EQ.
Qed.
End cmra.

Arguments authR : clear implicits.

(* Functor *)
Definition auth_map {A B} (f : A → B) (x : auth A) : auth B :=
  Auth (excl_map f (authoritative x)) (f (own x)).
Lemma auth_map_id {A} (x : auth A) : auth_map id x = x.
Proof. by destruct x; rewrite /auth_map excl_map_id. Qed.
Lemma auth_map_compose {A B C} (f : A → B) (g : B → C) (x : auth A) :
  auth_map (g ∘ f) x = auth_map g (auth_map f x).
Proof. by destruct x; rewrite /auth_map excl_map_compose. Qed.
Lemma auth_map_ext {A B : cofeT} (f g : A → B) x :
  (∀ x, f x ≡ g x) → auth_map f x ≡ auth_map g x.
Proof. constructor; simpl; auto using excl_map_ext. Qed.
Instance auth_map_cmra_ne {A B : cofeT} n :
  Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@auth_map A B).
Proof.
  intros f g Hf [??] [??] [??]; split; [by apply excl_map_cmra_ne|by apply Hf].
Qed.
Instance auth_map_cmra_monotone {A B : cmraT} (f : A → B) :
  CMRAMonotone f → CMRAMonotone (auth_map f).
Proof.
  split; try apply _.
  - intros n [[a| |] b]; rewrite /= /cmra_validN /=; try
      naive_solver eauto using includedN_preserving, validN_preserving.
  - by intros [x a] [y b]; rewrite !auth_included /=;
      intros [??]; split; simpl; apply: included_preserving.
Qed.
Definition authC_map {A B} (f : A -n> B) : authC A -n> authC B :=
  CofeMor (auth_map f).
Lemma authC_map_ne A B n : Proper (dist n ==> dist n) (@authC_map A B).
Proof. intros f f' Hf [[a| |] b]; repeat constructor; apply Hf. Qed.

Program Definition authRF (F : rFunctor) : rFunctor := {|
  rFunctor_car A B := authR (rFunctor_car F A B);
  rFunctor_map A1 A2 B1 B2 fg := authC_map (rFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, rFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(auth_map_id x).
  apply auth_map_ext=>y; apply rFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -auth_map_compose.
  apply auth_map_ext=>y; apply rFunctor_compose.
Qed.

Instance authRF_contractive F :
  rFunctorContractive F → rFunctorContractive (authRF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply authC_map_ne, rFunctor_contractive.
Qed.


Require Import sflib.
From Paco Require Import paco.

Require Import Axioms.
Require Import Basic.
Require Import DataStructure.
Require Import DenseOrder.
Require Import Language.
Require Import Loc.

Require Import Event.
Require Import Time.

Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Mapping.
Require Import Pred.
Require Import Trace.
Require Import MemoryProps.

Set Implicit Arguments.

Module CompressSteps.
  Section CompressSteps.
    Variable (lang: language).

    Inductive spatial_mem (mem_src mem_tgt: Memory.t): Prop :=
    | spatial_mem_intro
        loc from to
        (SPACE: Time.lt (Memory.max_ts loc mem_tgt) from)
        (ADD: Memory.add mem_tgt loc from to Message.reserve mem_src)
    .

    Inductive spatial_thread (e_src e_tgt: Thread.t lang): Prop :=
    | spatial_thread_intro
        (STATE: (Thread.state e_src) = (Thread.state e_tgt))
        (LOCAL: (Thread.local e_src) = (Thread.local e_tgt))
        (SC: (Thread.sc e_src) = (Thread.sc e_tgt))
        (MEMORY: spatial_mem (Thread.memory e_src) (Thread.memory e_tgt))
    .

    Lemma spatial_memory_map mem_src mem_tgt times
          (SPATIAL: spatial_mem mem_src mem_tgt)
          (CLOSED: Memory.closed mem_tgt)
      :
        exists (f: Loc.t -> Time.t -> Time.t -> Prop),
          (<<IDENT: map_ident_in_memory f mem_tgt>>) /\
          (<<MAPLT: mapping_map_lt f>>) /\
          (<<MEMORY: memory_map f mem_tgt mem_src>>) /\
          (<<COMPLETE: forall loc to (IN: List.In to (times loc)),
              exists fto, (<<MAPPED: f loc to fto>>)>>).
    Proof.
      inv SPATIAL.
      hexploit shift_map_exists.
      { refl. }
      { eapply SPACE. }
      i. des.
      exists (fun loc' => if (Loc.eq_dec loc loc') then f else eq).
      assert (IDENT: map_ident_in_memory (fun loc' => if LocSet.Facts.eq_dec loc loc' then f else eq) mem_tgt).
      { ii. des_ifs. eapply SAME; eauto. } splits; ss.
      - ii. des_ifs. eapply MAPLT; eauto.
      - econs.
        + i. right. exists to0, from0, msg, msg. splits; auto.
          * des_ifs. eapply SAME.
            eapply Memory.max_ts_spec in GET. des. eauto.
          * eapply map_ident_in_memory_closed_message; eauto.
            inv CLOSED. eapply CLOSED0 in GET. des. auto.
          * refl.
          * eapply Memory.add_get1; eauto.
        + i. erewrite Memory.add_o in GET; eauto.
          destruct (loc_ts_eq_dec (loc0, fto) (loc, to)).
          { ss. des; clarify. right. ii. des_ifs.
            destruct (Time.le_lt_dec ts (Memory.max_ts loc mem_tgt)).
            - dup l. eapply SAME in l. replace fts with ts in *.
              + eapply TimeFacts.le_lt_lt; eauto.
              + destruct (Time.le_lt_dec ts fts).
                * destruct l1; auto.
                  eapply MAPLT in H; eauto.
                  exfalso. eapply Time.lt_strorder; eauto.
                * eapply MAPLT in l1; eauto.
                  exfalso. eapply Time.lt_strorder; eauto.
            - eapply BOUND in MAP; eauto. des. auto. }
          { guardH o. left. exists fto, ffrom, fto, ffrom. splits.
            - eapply IDENT. eapply Memory.max_ts_spec in GET. des; auto.
            - refl.
            - refl.
            - eapply IDENT. dup GET. eapply Memory.max_ts_spec in GET. des; auto.
              eapply Memory.get_ts in GET0. des; clarify.
              etrans; eauto. left. auto.
            - i. econs; eauto. }
      - i. des_ifs.
        + eapply COMPLETE in IN; eauto.
        + eauto.
    Qed.

    Lemma compress_steps_failure
          e1_src e1_tgt
          (THREAD1: spatial_thread e1_src e1_tgt)
          (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
          (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
          (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
          (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
          (MEM1_SRC: Memory.closed (Thread.memory e1_src))
          (MEM1_TGT: Memory.closed (Thread.memory e1_tgt))
          (STEPS_TGT: @Thread.steps_failure lang e1_tgt):
      Thread.steps_failure e1_src.
    Proof.
      inv THREAD1. destruct e1_src, e1_tgt. ss. clarify.
      unfold Thread.steps_failure in *. des.
      eapply pred_steps_thread_steps in STEPS.
      eapply pred_steps_trace_steps in STEPS. des.
      hexploit (trace_times_list_exists tr). i. des.
      hexploit (spatial_memory_map times MEMORY); eauto. i. des.
      destruct e2. hexploit trace_steps_map; try apply STEPS0; try apply MEMORY0; eauto.
      { eapply mapping_map_lt_map_le; eauto. }
      { eapply map_ident_in_memory_bot; eauto. }
      { eapply mapping_map_lt_map_eq; eauto. }
      { eapply wf_time_mapped_mappable; eauto. }
      { eapply map_ident_in_memory_local; eauto. }
      { eapply mapping_map_lt_collapsable_unwritable; eauto. }
      { eapply map_ident_in_memory_closed_timemap; eauto. }
      { refl. }
      i. des. inv FAILURE; inv STEP. inv LOCAL0. inv LOCAL1.
      esplits.
      - eapply thread_steps_pred_steps.
        eapply pred_steps_trace_steps2.
        + eapply STEPS.
        + instantiate (1:=fun _ => True). eapply List.Forall_forall. ii.
          eapply list_Forall2_in in H; eauto. des.
          eapply List.Forall_forall in EVENTS; try apply IN. destruct a, x.
          ss. des. split; auto. rewrite <- TAU.
          eapply tevent_map_same_machine_event; eauto.
      - econs 2. econs; eauto. econs. econs.
        destruct lc2, flc1. inv LOCAL. ss.
        eapply promise_consistent_mon.
        + eapply promise_consistent_map.
          { eapply mapping_map_lt_map_le; eauto. }
          { eapply mapping_map_lt_map_eq; eauto. }
          { eapply TVIEW. }
          { eapply PROMISES. }
          { eapply CONSISTENT. }
        + eauto.
        + refl.
    Qed.

    Lemma compress_steps_fulfill
          e1_src e1_tgt
          e2_tgt
          (THREAD1: spatial_thread e1_src e1_tgt)
          (WF1_SRC: Local.wf (Thread.local e1_src) (Thread.memory e1_src))
          (WF1_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
          (SC1_SRC: Memory.closed_timemap (Thread.sc e1_src) (Thread.memory e1_src))
          (SC1_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
          (MEM1_SRC: Memory.closed (Thread.memory e1_src))
          (MEM1_TGT: Memory.closed (Thread.memory e1_tgt))
          (STEPS_TGT: rtc (@Thread.tau_step lang) e1_tgt e2_tgt)
          (PROMISES_TGT: (Local.promises (Thread.local e2_tgt)) = Memory.bot):
      exists e2_src,
        <<STEPS_SRC: rtc (@Thread.tau_step lang) e1_src e2_src>> /\
                     <<PROMISES_SRC: (Local.promises (Thread.local e2_src)) = Memory.bot>>.
    Proof.
      inv THREAD1. destruct e1_src, e1_tgt. ss. clarify.
      unfold Thread.steps_failure in *. des.
      eapply pred_steps_thread_steps in STEPS_TGT.
      eapply pred_steps_trace_steps in STEPS_TGT. des.
      hexploit (trace_times_list_exists tr). i. des.
      hexploit (spatial_memory_map times MEMORY); eauto. i. des.
      destruct e2_tgt. hexploit trace_steps_map; try apply STEPS; try apply MEMORY0; eauto.
      { eapply mapping_map_lt_map_le; eauto. }
      { eapply map_ident_in_memory_bot; eauto. }
      { eapply mapping_map_lt_map_eq; eauto. }
      { eapply wf_time_mapped_mappable; eauto. }
      { eapply map_ident_in_memory_local; eauto. }
      { eapply mapping_map_lt_collapsable_unwritable; eauto. }
      { eapply map_ident_in_memory_closed_timemap; eauto. }
      { refl. }
      i. des. esplits.
      - eapply thread_steps_pred_steps.
        eapply pred_steps_trace_steps2.
        + eapply STEPS0.
        + instantiate (1:=fun _ => True). eapply List.Forall_forall. ii.
          eapply list_Forall2_in in H; eauto. des.
          eapply List.Forall_forall in EVENTS; try apply IN. destruct a, x.
          ss. des. split; auto. inv EVENT; ss.
      - ss. inv LOCAL. rewrite PROMISES_TGT in *.
        eapply bot_promises_map; eauto.
    Qed.
  End CompressSteps.
End CompressSteps.


Require Import CatSem.CAT.monad_h_module.
Require Import CatSem.CAT.cat_INDEXED_TYPE.
Require Import CatSem.CAT.retype_functor.

Set Implicit Arguments.
Unset Strict Implicit.

Unset Automatic Introduction.

Section f.

Variables T U : Type.

Variable f : T -> U.

Variable P : Monad (ITYPE U).

Inductive f_P (V : ITYPE T)(t : T) : Type :=
  | copy : P (retype f V) (f t) -> f_P V t.

Definition inv : forall V t, f_P V t -> P (retype f V) (f t).
intros.
destruct X.
apply f0.
Defined.

Hint Resolve copy ctype.

Notation "' V" := (retype _ V) (at level 20).

Definition bla  V W (x : forall t : T, V t -> f_P W t):
    forall t : U, (retype f V) t -> P (retype f W) t.
intros.
destruct X.
apply inv.
auto.
Defined.

Obligation Tactic := idtac.

Program Instance f_P_Mon_s : Monad_struct (ITYPE T)(f_P).
Next Obligation.
  simpl.
  intros.
  apply copy.
  apply (weta (Monad_struct := P)).
  apply ctype.
  apply X.
Defined.
Next Obligation.
  simpl.
  intros V W x.
  set (Z := kleisli (Monad_struct := P)).
  set (z := Z (retype f V) (retype f W)).
  simpl in *.
  set (z':= z (bla x)).
  intros.

  destruct X.
  apply copy.
  apply z'.
  apply f0.
Defined.
Next Obligation.
Proof.
  unfold Proper,f_P_Mon_s_obligation_2.
  red.
  intros V W g g' H.
  intros t x.
  induction x.
  apply f_equal.
  apply (kleisli_oid (Monad_struct := P)).
  simpl.
  intros t0 x.
  induction x.
  simpl.
  rewrite H.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros.
  assert (H:=etakl P).
  simpl in *.
  rewrite H.
  simpl.
  generalize (f0 t x).
  intros.
  induction f1.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V t x.
  induction x.
  simpl.
  apply f_equal.
  assert (H:=kleta P).
  simpl in H.
  unfold f_P_Mon_s_obligation_1.
  simpl in *.
  rewrite <- H.
  apply (kl_eq P).
  simpl.
  intros.
  induction x.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros.
  induction x.
  simpl.
  apply f_equal.
  assert (H:=dist (Monad_struct := P)).
  simpl in H.
  rewrite H.
  apply (kl_eq P).
  simpl.
  intros.
  induction x.
  simpl.
  generalize (f0 t0 v).
  intros f2.
  induction f2.
  simpl.
  auto.
Qed.

Definition f_P_Mon := Build_Monad f_P_Mon_s.

Definition bla2:
(forall c : ITYPE T,
  (RETYPE (U:=T) (U':=U) f) (f_P_Mon c) --->
       P ((RETYPE (U:=T) (U':=U) f) c)).
intros V u x.
simpl in *.
induction x.
induction v.
apply f0.
Defined.

Program Instance pb_mon_s :
   gen_Monad_Hom_struct (P:=f_P_Mon) (Q:=P) (F0:=RETYPE f) bla2.
Next Obligation.
Proof.
  simpl.
  intros V W g u x.
  induction x.
  simpl.
  induction v.
  simpl.
  apply (kl_eq P).
  simpl.
  intros t0 x.
  induction x.
  simpl.
  generalize (g t0 v).
  intros.
  induction f1.
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V t x.
  induction x.
  simpl.
  auto.
Qed.

Definition pb_mon := Build_gen_Monad_Hom pb_mon_s.

Variable W : Monad (ITYPE T).

Variable r : gen_Monad_Hom W P (RETYPE f).

Definition car : (forall c : ITYPE T, W c ---> f_P_Mon c).
simpl.
intros.
set (r' := r c).
simpl in *.
apply copy.
apply r. simpl.
apply (ctype _ X).
Defined.
(*
Program Instance fac : Monad_Hom_struct
      (P := W) (Q := f_P_Mon) car.
Next Obligation.
Proof.
  simpl.
  intros.
  unfold car.
  apply f_equal.
  assert (H:=gen_monad_hom_kl (gen_Monad_Hom_struct := r)).
  simpl in H.
  unfold retype_map in H.
  simpl in H.
  rewrite <- H.
  simpl.
*)
End f.


(*! Language | Continuation-passing semantics and weakest precondition calculus !*)

Require Import CompactSemantics.
Require Import Magic.

Section CPS.
  Context {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t: Type}.
  Context {reg_t_eq_dec: EqDec reg_t}.

  Context {R: reg_t -> type}.
  Context {Sigma: ext_fn_t -> ExternalSignature}.

  Context {REnv: Env reg_t}.

  Notation Log := (Log R REnv).

  Notation rule := (rule pos_t var_t fn_name_t R Sigma).
  Notation action := (action pos_t var_t fn_name_t R Sigma).
  Notation scheduler := (scheduler pos_t rule_name_t).

  Definition tcontext (sig: tsig var_t) :=
    context (fun k_tau => type_denote (snd k_tau)) sig.

  Definition acontext (sig argspec: tsig var_t) :=
    context (fun k_tau => action sig (snd k_tau)) argspec.

  Definition interp_continuation A sig R := option (Log * R * (tcontext sig)) -> A.
  Definition action_continuation A sig tau := interp_continuation A sig (type_denote tau).
  Definition rule_continuation A := option Log -> A.
  Definition scheduler_continuation A := Log -> A.
  Definition cycle_continuation A := REnv.(env_t) R -> A.

  (* FIXME what's the right terminology for interpreter? *)
  Definition action_interpreter A sig := forall (Gamma: tcontext sig) (action_log: Log), A.
  Definition interpreter A := forall (log: Log), A.

  (* Definition wp_bind (p: Log * tau * (tcontext sig) -> Prop) p' := *)
  (*   fun res => *)
  (*     match res with *)
  (*     | Some res => p res *)
  (*     | None => p None *)
  (*     end *)

  (* FIXME monad *)

  Section Action.
    Context (r: REnv.(env_t) R).
    Context (sigma: forall f, Sig_denote (Sigma f)).

    Section Args.
      Context (interp_action_cps:
                 forall {sig: tsig var_t} {tau}
                   (a: action sig tau)
                   {A} (k: action_continuation A sig tau),
                 action_interpreter A sig).

      Fixpoint interp_args'_cps
               {sig: tsig var_t}
               {argspec: tsig var_t}
               (args: acontext sig argspec)
               {A} (k: interp_continuation A sig (tcontext argspec))
        : action_interpreter A sig :=
        match args in context _ argspec return interp_continuation A sig (tcontext argspec) -> action_interpreter A sig with
        | CtxEmpty => fun k Gamma l => k (Some (l, CtxEmpty, Gamma))
        | @CtxCons _ _ argspec k_tau arg args =>
          fun k =>
            interp_args'_cps
              args
              (fun res =>
                 match res with
                 | Some (l, ctx, Gamma) =>
                   interp_action_cps _ _ arg _
                                     (fun res =>
                                        match res with
                                        | Some (l, v, Gamma) => k (Some (l, CtxCons k_tau v ctx, Gamma))
                                        | None => k None
                                        end) Gamma l
                 | None => k None
                 end)
        end k.
    End Args.

    Fixpoint interp_action_cps
             {sig tau}
             (L: Log)
             (a: action sig tau)
             {A} (k: action_continuation A sig tau)
    : action_interpreter A sig :=
      let cps {sig tau} a {A} k := @interp_action_cps sig tau L a A k in
      match a in TypedSyntax.action _ _ _ _ _ ts tau return (action_continuation A ts tau -> action_interpreter A ts)  with
      | Fail tau => fun k Gamma l => k None
      | Var m => fun k Gamma l => k (Some (l, cassoc m Gamma, Gamma))
      | Const cst => fun k Gamma l => k (Some (l, cst, Gamma))
      | Seq r1 r2 =>
        fun k =>
          cps r1 (fun res =>
                    match res with
                    | Some (l, v, Gamma) => cps r2 k Gamma l
                    | None => k None
                    end)
      | Assign m ex =>
        fun k =>
          cps ex (fun res =>
                    match res with
                    | Some (l, v, Gamma) => k (Some (l, Ob, creplace m v Gamma))
                    | None => k None
                    end)
      | Bind var ex body =>
        fun k =>
          cps ex (fun res =>
                    match res with
                    | Some (l, v, Gamma) =>
                      cps body (fun res =>
                                  match res with
                                  | Some (l, v, Gamma) =>
                                    k (Some (l, v, ctl Gamma))
                                  | None =>
                                    k None
                                  end) (CtxCons (var, _) v Gamma) l
                    | None => k None
                    end)
      | If cond tbranch fbranch =>
        fun k =>
          cps cond (fun res =>
                      match res with
                      | Some (l, v, Gamma) =>
                        if Bits.single v then cps tbranch k Gamma l
                        else cps fbranch k Gamma l
                      | None => k None
                      end)
      | Read P0 idx =>
        fun k Gamma l =>
          if may_read0 L idx then
            k (Some (Environments.update
                       REnv l idx
                       (fun rl => {| lread0 := true; lread1 := rl.(lread1);
                                  lwrite0 := rl.(lwrite0); lwrite1 := rl.(lwrite1) |}),
                     REnv.(getenv) r idx,
                     Gamma))
          else k None
      | Read P1 idx =>
        fun k Gamma l =>
          if may_read1 L idx then
            k (Some (Environments.update
                       REnv l idx
                       (fun rl => {| lread0 := rl.(lread1); lread1 := true;
                                  lwrite0 := rl.(lwrite0); lwrite1 := rl.(lwrite1) |}),
                     match (REnv.(getenv) l idx).(lwrite0), (REnv.(getenv) L idx).(lwrite0) with
                     | Some v, _ => v
                     | _, Some v => v
                     | _, _ => REnv.(getenv) r idx
                     end,
                     Gamma))
          else k None
      | Write P0 idx value =>
        fun k =>
          cps value (fun res =>
                       match res with
                       | Some (l, v, Gamma) =>
                         if may_write0 L l idx then
                           k (Some (Environments.update
                                      REnv l idx
                                      (fun rl => {| lread0 := rl.(lread1); lread1 := rl.(lread1);
                                                 lwrite0 := Some v; lwrite1 := rl.(lwrite1) |}),
                                    Ob, Gamma))
                         else
                           k None
                       | None => k None
                       end)
      | Write P1 idx value =>
        fun k =>
          cps value (fun res =>
                       match res with
                       | Some (l, v, Gamma) =>
                         if may_write1 L l idx then
                           k (Some (Environments.update
                                      REnv l idx
                                      (fun rl => {| lread0 := rl.(lread1); lread1 := rl.(lread1);
                                                 lwrite0 := rl.(lwrite0); lwrite1 := Some v |}),
                                    Ob, Gamma))
                         else
                           k None
                       | None => k None
                       end)
      | Unop fn arg1 =>
        fun k =>
          cps arg1 (fun res =>
                      match res with
                      | Some (l, v, Gamma) =>
                        k (Some (l, (PrimSpecs.sigma1 fn) v, Gamma))
                      | None => k None
                      end)
      | Binop fn arg1 arg2 =>
        fun k =>
          cps arg1 (fun res =>
                      match res with
                      | Some (l, v1, Gamma) =>
                        cps arg2 (fun res =>
                                    match res with
                                    | Some (l, v2, Gamma) =>
                                      k (Some (l, (PrimSpecs.sigma2 fn) v1 v2, Gamma))
                                    | None => k None
                                    end) Gamma l
                      | None => k None
                      end)
      | ExternalCall fn arg =>
        fun k =>
          cps arg (fun res =>
                     match res with
                     | Some (l, v, Gamma) =>
                       k (Some (l, (sigma fn) v, Gamma))
                     | None => k None
                     end)
      | InternalCall fn args body =>
        fun k =>
          interp_args'_cps (@cps) args
                           (fun res =>
                              match res with
                              | Some (l, argvals, Gamma) =>
                                cps body (fun res =>
                                            match res with
                                            | Some (l, v, _) =>
                                              k (Some (l, v, Gamma))
                                            | None => k None
                                            end)
                                    argvals l
                              | None => k None
                              end)
      | APos pos a => fun k => cps a k
      end k.

    Definition interp_rule_cps (rl: rule) {A} (k: rule_continuation A) : interpreter A :=
      fun L =>
        interp_action_cps L rl (fun res =>
                                  match res with
                                  | Some (l, _, _) => k (Some l)
                                  | None => k None
                                  end) CtxEmpty log_empty.
  End Action.

  Section Scheduler.
    Context (r: REnv.(env_t) R).
    Context (sigma: forall f, Sig_denote (Sigma f)).
    Context (rules: rule_name_t -> rule).

    Fixpoint interp_scheduler'_cps
             (s: scheduler)
             {A} (k: scheduler_continuation A)
             {struct s} : interpreter A :=
      let interp_try rl s1 s2 : interpreter A :=
          fun L =>
            interp_rule_cps r sigma (rules rl)
                            (fun res =>
                               match res with
                               | Some l => interp_scheduler'_cps s1 k (log_app l L)
                               | None => interp_scheduler'_cps s2 k L
                               end) L in
      match s with
      | Done => k
      | Cons r s => interp_try r s s
      | Try r s1 s2 => interp_try r s1 s2
      | SPos _ s => interp_scheduler'_cps s k
      end.

    Definition interp_scheduler_cps
               (s: scheduler)
               {A} (k: scheduler_continuation A) : A :=
      interp_scheduler'_cps s k log_empty.
  End Scheduler.

  Definition interp_cycle_cps (sigma: forall f, Sig_denote (Sigma f)) (rules: rule_name_t -> rule)
             (s: scheduler) (r: REnv.(env_t) R)
             {A} (k: _ -> A) :=
    interp_scheduler_cps r sigma rules s (fun L => k (commit_update r L)).

  Section WP.
    Context (r: REnv.(env_t) R).
    Context (sigma: forall f, Sig_denote (Sigma f)).

    Definition action_precondition := action_interpreter Prop.
    Definition action_postcondition := action_continuation Prop.
    Definition precondition := interpreter Prop.
    Definition rule_postcondition := rule_continuation Prop.
    Definition scheduler_postcondition := scheduler_continuation Prop.
    Definition cycle_postcondition := cycle_continuation Prop.

    Definition wp_action {sig tau} (L: Log) (a: action sig tau) (post: action_postcondition sig tau) : action_precondition sig :=
      interp_action_cps r sigma L a post.

    Definition wp_rule (rl: rule) (post: rule_postcondition) : precondition :=
      interp_rule_cps r sigma rl post.

    Definition wp_scheduler (rules: rule_name_t -> rule) (s: scheduler) (post: scheduler_postcondition) : Prop :=
      interp_scheduler_cps r sigma rules s post.

    Definition wp_cycle (rules: rule_name_t -> rule) (s: scheduler) r (post: cycle_postcondition) : Prop :=
      interp_cycle_cps sigma rules s r post.
  End WP.

  Section Proofs.
    Context (r: REnv.(env_t) R).
    Context (sigma: forall f, Sig_denote (Sigma f)).

    Section Args.
      Context (IHa : forall (sig : tsig var_t) (tau : type) (L : Log) (a : action sig tau) (A : Type) (k : option (Log * tau * tcontext sig) -> A)
                       (Gamma : tcontext sig) (l : Log), interp_action_cps r sigma L a k Gamma l = k (interp_action r sigma Gamma L l a)).

      Lemma interp_args'_cps_correct :
        forall L {sig} {argspec} args Gamma l {A} (k: interp_continuation A sig (tcontext argspec)),
          interp_args'_cps (fun sig tau a A k => interp_action_cps r sigma L a k) args k Gamma l =
          k (interp_args r sigma Gamma L l args).
      Proof.
        induction args; cbn; intros.
        - reflexivity.
        - rewrite IHargs.
          destruct (interp_args r sigma Gamma L l args) as [((?, ?), ?) | ]; cbn; try reflexivity.
          rewrite IHa.
          destruct (interp_action r sigma _ L _ _) as [((?, ?), ?) | ]; cbn; reflexivity.
      Defined.
    End Args.

    Lemma interp_action_cps_correct:
      forall {sig: tsig var_t}
        {tau}
        (L: Log)
        (a: action sig tau)
        {A} (k: _ -> A)
        (Gamma: tcontext sig)
        (l: Log),
        interp_action_cps r sigma L a k Gamma l =
        k (interp_action r sigma Gamma L l a).
    Proof.
      fix IHa 4; destruct a; cbn; intros.
      all: repeat match goal with
                  | _ => progress simpl
                  | [ H: context[_ = _] |- _ ] => rewrite H
                  | [  |- context[interp_action] ] => destruct interp_action as [((?, ?), ?) | ]
                  | [  |- context[match ?x with _ => _ end] ] => destruct x
                  | _ => rewrite interp_args'_cps_correct
                  | _ => reflexivity || assumption
                  end.
    Qed.

    Lemma interp_action_cps_correct_rev:
      forall {sig: tsig var_t}
        {tau}
        (L: Log)
        (a: action sig tau)
        (Gamma: tcontext sig)
        (l: Log),
        interp_action r sigma Gamma L l a =
        interp_action_cps r sigma L a id Gamma l.
    Proof.
      intros; rewrite interp_action_cps_correct; reflexivity.
    Qed.

    Lemma interp_rule_cps_correct:
      forall (L: Log)
        (a: rule)
        {A} (k: _ -> A),
        interp_rule_cps r sigma a k L =
        k (interp_rule r sigma L a).
    Proof.
      unfold interp_rule, interp_rule_cps; intros.
      rewrite interp_action_cps_correct.
      destruct interp_action as [((?, ?), ?) | ]; reflexivity.
    Qed.

    Lemma interp_rule_cps_correct_rev:
      forall (L: Log)
        (a: rule),
        interp_rule r sigma L a =
        interp_rule_cps r sigma a id L.
    Proof.
      intros; rewrite interp_rule_cps_correct; reflexivity.
    Qed.

    Lemma interp_scheduler'_cps_correct:
      forall (rules: rule_name_t -> rule)
        (s: scheduler)
        (L: Log)
        {A} (k: _ -> A),
        interp_scheduler'_cps r sigma rules s k L =
        k (interp_scheduler' r sigma rules L s).
    Proof.
      induction s; cbn; intros.
      all: repeat match goal with
                  | _ => progress simpl
                  | _ => rewrite interp_rule_cps_correct
                  | [ H: context[_ = _] |- _ ] => rewrite H
                  | [  |- context[interp_rule] ] => destruct interp_action as [((?, ?), ?) | ]
                  | [  |- context[match ?x with _ => _ end] ] => destruct x
                  | _ => reflexivity
                  end.
    Qed.

    Lemma interp_scheduler_cps_correct:
      forall (rules: rule_name_t -> rule)
        (s: scheduler)
        {A} (k: _ -> A),
        interp_scheduler_cps r sigma rules s k =
        k (interp_scheduler r sigma rules s).
    Proof.
      intros; apply interp_scheduler'_cps_correct.
    Qed.

    Lemma interp_cycle_cps_correct:
      forall (rules: rule_name_t -> rule)
        (s: scheduler)
        {A} (k: _ -> A),
        interp_cycle_cps sigma rules s r k =
        k (interp_cycle sigma rules s r).
    Proof.
      unfold interp_cycle, interp_cycle_cps; intros; rewrite interp_scheduler_cps_correct.
      reflexivity.
    Qed.

    Lemma interp_cycle_cps_correct_rev:
      forall (rules: rule_name_t -> rule)
        (s: scheduler),
        interp_cycle sigma rules s r =
        interp_cycle_cps sigma rules s r id.
    Proof.
      intros; rewrite interp_cycle_cps_correct; reflexivity.
    Qed.

    Section WP.
      Lemma wp_action_correct:
        forall {sig: tsig var_t}
          {tau}
          (Gamma: tcontext sig)
          (L: Log)
          (l: Log)
          (a: action sig tau)
          (post: action_postcondition sig tau),
          wp_action r sigma L a post Gamma l <->
          post (interp_action r sigma Gamma L l a).
      Proof.
        intros; unfold wp_action; rewrite interp_action_cps_correct; reflexivity.
      Qed.

      Lemma wp_rule_correct:
        forall (L: Log)
          (rl: rule)
          (post: rule_postcondition),
          wp_rule r sigma rl post L <->
          post (interp_rule r sigma L rl).
      Proof.
        intros; unfold wp_rule; rewrite interp_rule_cps_correct; reflexivity.
      Qed.

      Lemma wp_scheduler_correct:
        forall (rules: rule_name_t -> rule)
          (s: scheduler)
          (post: scheduler_postcondition),
          wp_scheduler r sigma rules s post <->
          post (interp_scheduler r sigma rules s).
      Proof.
        intros; unfold wp_scheduler; rewrite interp_scheduler_cps_correct; reflexivity.
      Qed.

      Lemma wp_cycle_correct:
        forall (rules: rule_name_t -> rule)
          (s: scheduler)
          (post: cycle_postcondition),
          wp_cycle sigma rules s r post <->
          post (interp_cycle sigma rules s r).
      Proof.
        intros; unfold wp_cycle; rewrite interp_cycle_cps_correct; reflexivity.
      Qed.
    End WP.
  End Proofs.
End CPS.

Arguments interp_action_cps
          {pos_t var_t fn_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} r sigma
          {sig tau} L !a / A k.

Arguments interp_rule_cps
          {pos_t var_t fn_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} r sigma
          !rl / {A} k.

Arguments interp_scheduler_cps
          {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} r sigma
          rules !s / {A} k : assert.

Arguments interp_cycle_cps
          {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} sigma
          rules !s r / {A} k : assert.

Arguments wp_action
          {pos_t var_t fn_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} r sigma
          {sig tau} L !a post / Gamma action_log : assert.

Arguments wp_rule
          {pos_t var_t fn_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} r sigma
          !rl / post.

Arguments wp_scheduler
          {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} r sigma
          rules !s / post : assert.

Arguments wp_cycle
          {pos_t var_t fn_name_t rule_name_t reg_t ext_fn_t}
          {R Sigma} {REnv} sigma
          rules !s r / post : assert.