From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude finite.
From VLSM.Lib Require Import EquationsExtras.
From VLSM.Lib Require Import Preamble StdppExtras.
From VLSM.Core Require Import VLSM MessageDependencies.

(** * Basic Definitions and Lemmas for UMO, MO and ELMO

  This module contains basic definitions and lemmas needed for the UMO, MO and
  ELMO protocols. In contrast to the paper, which uses natural numbers,
  we abstract over the implementation of an [Address] by making it an arbitrary
  type with decidable equality.
*)

Section sec_base_ELMO.

Context
  {Address : Type}
  `{EqDecision Address}.

(** ** Labels, States, Observations and Messages *)

(** Messages can be labeled as either sent or received. *)
Inductive Label : Type :=
| Receive
| Send.

Inductive State : Type := MkState
{
  obs : list Observation;
  adr  : Address;
}
with Observation : Type := MkObservation
{
  label   : Label;
  message : Message;
}
(** A [Message] is a wrapper for [State]. *)
with Message : Type := MkMessage
{
  state : State;
}.

(**
  [State]s, [Observation]s and [Message]s are printed like ordinary inductive
  types, using their constructor names, instead of as records with the
  {| ... |} notation.
*)
#[export] Unset Printing Records.

(** Two states are equal when they have equal observations and equal addresses. *)
Lemma eq_State :
  forall s1 s2 : State,
    obs s1 = obs s2 -> adr s1 = adr s2 -> s1 = s2.
Proof.
  by intros [] []; cbn; congruence.
Qed.

Lemma eq_Message :
  forall m1 m2 : Message,
    obs (state m1) = obs (state m2) -> adr (state m1) = adr (state m2) -> m1 = m2.
Proof.
  by intros [[]] [[]]; cbn; congruence.
Qed.

Lemma eq_Observation :
  forall ob1 ob2 : Observation,
    label ob1 = label ob2 -> message ob1 = message ob2 -> ob1 = ob2.
Proof.
  by intros [] []; cbn; congruence.
Qed.

(** [Label]s, [State]s, [Observation]s and [Message]s have decidable equality. *)
#[export] Instance EqDecision_Label : EqDecision Label.
Proof. by intros x y; unfold Decision; decide equality. Defined.

#[local] Lemma State_eq_dec : forall x y : State, {x = y} + {x <> y}
with Observation_eq_dec : forall x y : Observation, {x = y} + {x <> y}
with Message_eq_dec : forall x y : Message, {x = y} + {x <> y}.
Proof.
  - intros x y; decide equality.
    + by apply EqDecision0.
    + by decide equality.
  - by do 2 decide equality.
  - by intros x y; decide equality.
Defined.

#[export] Instance EqDecision_State : EqDecision State := State_eq_dec.
#[export] Instance EqDecision_Observation : EqDecision Observation := Observation_eq_dec.
#[export] Instance EqDecision_Message : EqDecision Message := Message_eq_dec.

(** A notion of size for [State]s, [Observation]s and [Message]s. *)
Fixpoint sizeState (s : State) : nat :=
  1 + fold_right (fun ob sizeObs => sizeObservation ob + sizeObs) 0 (obs s)

with sizeObservation (ob : Observation) : nat :=
  1 + sizeMessage (message ob)

with sizeMessage (msg : Message) : nat :=
  1 + sizeState (state msg).

Lemma sizeObservation_unfold (ob : Observation) :
  sizeObservation ob = 2 + sizeState (state (message ob)).
Proof. by destruct ob as [? []]. Qed.

(** ** Extending States with new Observations

  We want to abstract over from the "direction" of the [list] of [Observation]s,
  so that we can [cons] new observations at the beginning, whereas in the paper
  they are [app]ended to the end. We will use the function [addObservation] to
  extend a state with a new observations and [addObservations] to extend a state
  with a list of new observations.
*)

Definition addObservation' (ob : Observation) (obs : list Observation) : list Observation :=
  ob :: obs.

Lemma addObservation'_ind (P : list Observation -> Prop)
  (Hempty : P [])
  (Hadd : forall ob obs, P obs -> P (addObservation' ob obs)) :
  forall obs, P obs.
Proof.
  exact (list_ind P Hempty Hadd).
Qed.

Lemma addObservation'_rec (P : list Observation -> Set)
  (Hempty : P [])
  (Hadd : forall ob obs, P obs -> P (addObservation' ob obs)) :
  forall obs, P obs.
Proof.
  exact (list_rec P Hempty Hadd).
Defined.

Lemma addObservation'_rect (P : list Observation -> Type)
  (Hempty : P [])
  (Hadd : forall ob obs, P obs -> P (addObservation' ob obs)) :
  forall obs, P obs.
Proof.
  exact (list_rect P Hempty Hadd).
Defined.

Definition addObservation (ob : Observation) (s : State) : State :=
  MkState (addObservation' ob (obs s)) (adr s).

Notation "s <+> ob" := (addObservation ob s) (left associativity, at level 50).

(**
  The induction principle [addObservation_ind] considers a [State]
  as built up using [addObservation] from an initial state.
*)
Lemma addObservation_ind (P : State -> Prop)
  (Hempty : forall a, P (MkState [] a))
  (Hadd : forall ob s, P s -> P (addObservation ob s)) :
  forall obs, P obs.
Proof.
  intros [obs a].
  induction obs using addObservation'_ind; [done |].
  by apply (Hadd ob) in IHobs.
Qed.

Lemma addObservation_rec (P : State -> Set)
  (Hempty : forall a, P (MkState [] a))
  (Hadd : forall ob s, P s -> P (s <+> ob)) :
  forall obs, P obs.
Proof.
  intros [obs a].
  induction obs using addObservation'_rec; [done |].
  by apply (Hadd ob) in IHobs.
Defined.

Lemma addObservation_rect (P : State -> Type)
  (Hempty : forall a, P (MkState [] a))
  (Hadd : forall ob s, P s -> P (addObservation ob s)) :
  forall obs, P obs.
Proof.
  intros [obs a].
  induction obs using addObservation'_rect; [done |].
  by apply (Hadd ob) in IHobs.
Defined.

(**
  This induction principle is like [addObservation_ind], but
  also provides an induction hypothesis for the [State] contained
  in the message of the added observation.
*)
Definition addObservation_both_ind
  (P : State -> Prop)
  (Hinit : forall a, P (MkState [] a))
  (Hadd : forall [s l ms], P s -> P ms -> P (s <+> MkObservation l (MkMessage ms))) :
  forall s, P s :=
  fix rec s :=
    let '(MkState ol a) := s in
    let Hcons := fun '(MkObservation _ (MkMessage ms)) _ IHol' => Hadd IHol' (rec ms)
    in list_ind _ (Hinit a) Hcons ol.

(**
  A property on [sizeState] of [addObservation].
  Useful because a [Fixpoint] can't be unfolded unless
  the argument is in the form of a constructor application.
*)
Lemma addObservation_size s ob :
  sizeState (s <+> ob) = sizeState s + sizeObservation ob.
Proof. by destruct s; cbn; lia. Qed.

Definition addObservations (obs' : list Observation) (s : State) : State :=
  MkState (obs' ++ (obs s)) (adr s).

Notation "s <++> obs" := (addObservations obs s) (left associativity, at level 50).

Definition addObservationToMessage (ob : Observation) (m : Message) : Message :=
  MkMessage (state m <+> ob).

Notation "m <*> ob" := (addObservationToMessage ob m) (left associativity, at level 50).

Definition addObservationsToMessage (obs' : list Observation) (m : Message) : Message :=
  MkMessage (state m <++> obs').

Notation "m <**> obs" := (addObservationsToMessage obs m) (left associativity, at level 50).

(** [<+>] is injective in both arguments. *)
Lemma addObservation_inj :
  forall (ob1 ob2 : Observation) (s1 s2 : State),
    s1 <+> ob1 = s2 <+> ob2 -> ob1 = ob2 /\ s1 = s2.
Proof.
  intros ob1 ob2 s1 s2 [= ->].
  by split; [| apply eq_State].
Qed.

(** Adding an observation to a state results in a different state. *)
Lemma addObservation_acyclic :
  forall (ob : Observation) (s : State),
    s <+> ob <> s.
Proof.
  intros ob [obs adr] [= Heq].
  unfold addObservation' in Heq.
  by apply (app_inv_tail _ [ob] []) in Heq.
Qed.

(** Adding no observations does not change the state. *)
Lemma addObservations_nil :
  forall s : State,
    s <++> [] = s.
Proof.
  by intros [].
Qed.

(**
  Adding a single observation is compatible with adding many observations at
  once, in the obvious way.
*)
Lemma addObservations_app :
  forall (s : State) (ob : Observation) (obs' : list Observation),
    s <+> ob <++> obs' = s <++> (obs' ++ [ob]).
Proof.
  intros s ob obs'.
  by apply eq_State; cbn; [rewrite <- app_assoc |].
Qed.

Lemma addObservation_cons :
  forall (s : State) (ob : Observation) (obs' : list Observation),
    s <++> obs' <+> ob = s <++> (ob :: obs').
Proof.
  intros s ob obs'.
  by apply eq_State; cbn.
Qed.

(**
  An observation in [s <+> ob] is either the added observation [ob]
  or an observation in the original state.
*)
Lemma elem_of_addObservation :
  forall (s : State) (ob ob' : Observation),
    ob' ∈ obs (s <+> ob) <-> ob' = ob \/ ob' ∈ obs s.
Proof.
  intros [s_obs a] ob ob'.
  cbn; unfold addObservation'.
  by apply elem_of_cons.
Qed.

(**
  The immediate substate relation. May be used to prove that
  a [State] does not contain itself.
*)
Inductive immediate_substate : State -> State -> Prop :=
| substate_prev : forall s ob, immediate_substate s (s <+> ob)
| substate_new : forall s ob, immediate_substate (state (message ob)) (s <+> ob).

Lemma immediate_substate_wf : wf immediate_substate.
Proof.
  intro s; induction s using addObservation_both_ind; constructor.
  - by inversion 1.
  - by inversion 1; [rewrite (eq_State y s1) | subst y].
Qed.

(** *** Messages sent and received by a State *)

Definition isSend (ob : Observation) : Prop :=
match label ob with
| Send => True
| Receive => False
end.

Definition isReceive (ob : Observation) : Prop :=
match label ob with
| Send => False
| Receive => True
end.

#[export] Instance isSend_dec (ob : Observation) : Decision (isSend ob).
Proof.
  by destruct ob as [[] m]; cbn; typeclasses eauto.
Defined.

#[export] Instance isReceive_dec (ob : Observation) : Decision (isReceive ob).
Proof.
  by destruct ob as [[] m]; cbn; typeclasses eauto.
Defined.

Definition messages' (obs : list Observation) : list Message :=
  map message obs.

Definition messages (st : State) : list Message :=
  messages' (obs st).

Definition sentMessages' (obs : list Observation) : list Message :=
  map message (filter isSend obs).

Definition sentMessages (st : State) : list Message :=
  sentMessages' (obs st).

Definition receivedMessages' (obs : list Observation) : list Message :=
  map message (filter isReceive obs).

Definition receivedMessages (st : State) : list Message :=
  receivedMessages' (obs st).

Definition receivedAddresses (st : State) : list Address :=
  map (fun m => adr (state m)) (receivedMessages st).

Lemma elem_of_map_filter_addObservation
  [B] (f : Observation -> B)
  (P : Observation -> Prop) {P_dec : forall a, Decision (P a)} :
  forall s ob v,
    v ∈ map f (filter P (obs (s <+> ob)))
      <->
    v = f ob /\ P ob \/ v ∈ map f (filter P (obs s)).
Proof.
  intros s ob v.
  rewrite !elem_of_list_fmap.
  setoid_rewrite elem_of_list_filter.
  cbn; unfold addObservation'.
  setoid_rewrite elem_of_cons.
  by split; intros H; decompose [and or ex] H; subst; eauto.
Qed.

(**
  When a message belongs to the [sentMessages] of some state, then the state
  contains a corresponding observation which was sent. The converse also holds.
*)
Lemma elem_of_sentMessages :
  forall (s : State) (m : Message),
    m ∈ sentMessages s <-> MkObservation Send m ∈ obs s.
Proof.
  intros; unfold sentMessages, sentMessages'.
  rewrite elem_of_list_fmap; setoid_rewrite elem_of_list_filter.
  split; [| by firstorder].
  by intros ([[] ?] & -> & []); cbn in *.
Qed.

(**
  A message in [sentMessages (s <+> ob)] is either in
  [sentMessages s] or is the message in the new observation [ob],
  and can only be the message from [ob] if that is a [Send] observation.
*)
Lemma elem_of_sentMessages_addObservation :
  forall (s : State) (ob : Observation) (m : Message),
    m ∈ sentMessages (s <+> ob)
      <->
    m = message ob /\ isSend ob \/ m ∈ sentMessages s.
Proof.
  by apply elem_of_map_filter_addObservation.
Qed.

Lemma sentMessages_addObservation :
  forall (s : State) (ob : Observation),
    sentMessages (s <+> ob)
      =
    if decide (isSend ob) then message ob :: sentMessages s else sentMessages s.
Proof.
  intros s ob.
  unfold sentMessages, sentMessages'; cbn.
  by destruct (decide (isSend ob)).
Qed.

(**
  When a message belongs to the [receivedMessages] of some state, then the state
  contains a corresponding observation which was received. The converse also holds.
*)
Lemma elem_of_receivedMessages :
  forall (s : State) (m : Message),
    m ∈ receivedMessages s <-> MkObservation Receive m ∈ obs s.
Proof.
  intros; unfold receivedMessages, receivedMessages'.
  rewrite elem_of_list_fmap; setoid_rewrite elem_of_list_filter.
  split; [| by firstorder].
  by intros ([[] ?] & -> & []); cbn in *.
Qed.

(**
  A message in [receivedMessages (s <+> ob)] is either in
  [receivedMessages s] or is the message in the new observation [ob],
  and can only be the message from [ob] if that is a [Receive] observation.
*)
Lemma elem_of_receivedMessages_addObservation :
  forall (s : State) (ob : Observation) (m : Message),
    m ∈ receivedMessages (s <+> ob)
      <->
    m = message ob /\ isReceive ob \/ m ∈ receivedMessages s.
Proof.
  by apply elem_of_map_filter_addObservation.
Qed.

Lemma receivedMessages_addObservation :
  forall (s : State) (ob : Observation),
    receivedMessages (s <+> ob)
      =
    if decide (isReceive ob) then message ob :: receivedMessages s else receivedMessages s.
Proof.
  intros s ob.
  unfold receivedMessages, receivedMessages'; cbn.
  by destruct (decide (isReceive ob)).
Qed.

Lemma elem_of_messages :
  forall (s : State) (m : Message),
    m ∈ messages s <-> m ∈ sentMessages s \/ m ∈ receivedMessages s.
Proof.
  intros; unfold messages, messages'.
  rewrite elem_of_sentMessages, elem_of_receivedMessages, elem_of_list_fmap.
  split.
  - by intros [[[]] [-> Hm]]; auto.
  - by intros []; (eexists; split; [| eauto]).
Qed.

(**
  A message in [s <+> ob] is either the message of the added
  observation [ob] or a message in the original state.
*)
Lemma elem_of_messages_addObservation :
  forall (s : State) (ob : Observation) (m : Message),
    m ∈ messages (s <+> ob) <-> m = message ob \/ m ∈ messages s.
Proof.
  by intros; apply elem_of_cons.
Qed.

Lemma messages_addObservation :
  forall (s : State) (ob : Observation),
    messages (s <+> ob) = message ob :: messages s.
Proof. done. Qed.

(**
  An address in [receivedAddresses (s <+> ob)] is either in
  [receivedAddresses s] or is the address from the message in the
  new observation [ob], and can only be from [ob] if that is
  a [Receive] observation.
*)
Lemma elem_of_receivedAddresses :
  forall (s : State) (ob : Observation) (a : Address),
    a ∈ receivedAddresses (s <+> ob)
      <->
    a = adr (state (message ob)) /\ isReceive ob \/ a ∈ receivedAddresses s.
Proof.
  intros s ob a.
  unfold receivedAddresses, receivedMessages, receivedMessages'.
  by rewrite !map_map, elem_of_map_filter_addObservation.
Qed.

Lemma receivedAddresses_addObservation :
  forall (s : State) (ob : Observation),
    receivedAddresses (s <+> ob)
      =
    if decide (isReceive ob)
    then adr (state (message ob)) :: receivedAddresses s
    else receivedAddresses s.
Proof.
  intros s ob.
  unfold receivedAddresses; cbn.
  by destruct (decide (isReceive ob)).
Qed.

End sec_base_ELMO.

Notation "s <+> ob" := (addObservation ob s) (left associativity, at level 50).
Notation "s <++> obs" := (addObservations obs s) (left associativity, at level 50).
Notation "m <*> ob" := (addObservationToMessage ob m) (left associativity, at level 50).
Notation "m <**> obs" := (addObservationsToMessage obs m) (left associativity, at level 50).

(** [ram_state_prop] defines the "reachable by any means" or ram states of a VLSM. *)
Definition ram_state_prop {message} (V : VLSM message) (s : vstate V) : Prop :=
  valid_state_prop (pre_loaded_with_all_messages_vlsm V) s.

Section sec_BaseELMO_Observations.

Context
  {Address : Type}
  `{EqDecision Address}
  (State := @State Address)
  (Observation := @Observation Address)
  (Message := @Message Address)
  .

#[export] Instance ELMOComponentType : VLSMType Message :=
{
  state := State;
  label := Label;
}.

(** We can extract a trace from a [list] of [Observation]s. *)
Fixpoint observations2trace (obs : list Observation) (adr : Address)
  : list transition_item :=
match obs with
| [] => []
| MkObservation Send msg as ob :: obs =>
    let s'   := MkState obs adr in
    let msg' := MkMessage s' in
    let ob'  := MkObservation Send msg' in
    let obs' := addObservation' ob' obs in
    let dest := MkState obs' adr in
      observations2trace obs adr ++ [Build_transition_item Send None dest (Some msg')]
| MkObservation Receive msg as ob :: obs =>
    let dest := MkState (ob :: obs) adr in
      observations2trace obs adr ++ [Build_transition_item Receive (Some msg) dest None]
end.

(** A state contains a list of observations, so we can extract a trace from a state. *)
Definition state2trace (s : State) : list transition_item :=
  observations2trace (obs s) (adr s).

(** ** Observations and message dependencies *)

Lemma obs_sizeState :
  forall (s : State) (ob : Observation), ob ∈ obs s ->
    sizeState (state (message ob)) < sizeState s.
Proof.
  induction s using addObservation_ind; inversion 1; subst.
  - by destruct ob as [? []]; unfold sizeState; cbn; lia.
  - etransitivity; [by apply IHs |].
    by destruct s, ob as [? []]; unfold sizeState; cbn; lia.
Qed.

Lemma messages_sizeState :
  forall (s : State) (m : Message), m ∈ messages s ->
    sizeState (state m) < sizeState s.
Proof.
  intros s m Hm.
  apply elem_of_list_fmap in Hm as (o & -> & Hobs).
  by apply obs_sizeState.
Qed.

Inductive rec_obs : State -> Observation -> Prop :=
| rec_new :
    forall (s : State) (ob : Observation),
      rec_obs (s <+> ob) ob
| rec_prev :
    forall (s : State) (ob' ob : Observation),
      rec_obs s ob -> rec_obs (s <+> ob') ob
| rec_recv :
    forall (s : State) (m : Message) (ob : Observation),
      rec_obs (state m) ob -> rec_obs (s <+> MkObservation Receive m) ob.

Equations rec_obs_fn (s : State) : listset Observation by wf (sizeState s) lt :=
| {| obs := [] |} => ∅
| {| obs := o :: os; adr := a |} =>
  {[ o ]} ∪ rec_obs_fn (state (message o)) ∪ rec_obs_fn {| obs := os; adr := a |}.
Next Obligation.
Proof. by intros [? []] os a _; unfold sizeState; cbn; lia. Qed.
Next Obligation.
Proof. by intros [? []] os a _; unfold sizeState; cbn; lia. Qed.

Lemma elem_of_rec_obs_fn_1 :
  forall (s : State) (o : Observation),
    rec_obs s o -> o ∈ rec_obs_fn s.
Proof.
  intro s; apply_funelim (rec_obs_fn s); clear s; [by inversion 1 |].
  by intros [] os a Hindm Hindos o; inversion 1 as [[] ? | [] ? | [] ?]; subst;
    cbn in *; unfold Observation; rewrite !elem_of_union, ?elem_of_singleton; itauto.
Qed.

Lemma rec_obs_fn_sizeState :
  forall (s : State) (o : Observation), o ∈ rec_obs_fn s ->
    sizeState (state (message o)) < sizeState s.
Proof.
  intro s; apply_funelim (rec_obs_fn s); clear s;
    [intros * Ho; contradict Ho; apply not_elem_of_empty |].
  intros o os a Hindo Hindos o0; rewrite !elem_of_union; intros [[Heq | Ho] | Hos].
  - apply elem_of_singleton in Heq as ->.
    by unfold sizeState; destruct o as [? []]; cbn; lia.
  - transitivity (sizeState (state (message o))); [by apply Hindo |].
    by unfold sizeState; destruct o as [? []]; cbn; lia.
  - transitivity (sizeState (MkState os a)); [by apply Hindos |].
    by unfold sizeState; destruct o as [? []]; cbn; lia.
Qed.

Definition Message_dependencies (m : Message) : listset Message :=
  list_to_set (map message (obs (state m))).

Definition Message_full_dependencies (m : Message) : listset Message :=
  fin_sets.set_map message (rec_obs_fn (state m)).

Lemma Message_full_dependencies_sizeState (dm m : Message) :
  dm ∈ Message_full_dependencies m -> sizeState (state dm) < sizeState (state m).
Proof.
  unfold Message_full_dependencies; intro Hdm.
  apply elem_of_map in Hdm as (o & -> & Ho).
  by apply rec_obs_fn_sizeState.
Qed.

#[export] Instance Message_FullMessageDependencies :
  FullMessageDependencies Message_dependencies Message_full_dependencies.
Proof.
  constructor; cycle 1.
  - by intros m Hm; apply Message_full_dependencies_sizeState in Hm; lia.
  - intros dm [s]; revert dm; unfold Message_full_dependencies; cbn.
    apply_funelim (rec_obs_fn s);
      [intros adr dm; split | intros [l m] os a Hindm Hindos dm; split].
    + by rewrite set_map_empty, elem_of_empty.
    + rewrite msg_dep_happens_before_iff_one; unfold msg_dep_rel; cbn.
      rewrite set_map_empty; setoid_rewrite elem_of_empty.
      by firstorder.
    + intros Hdm; apply elem_of_map in Hdm as (o & -> & Hdm).
      unfold Message in Hdm; rewrite !elem_of_union, !elem_of_singleton in Hdm; cbn in Hdm.
      destruct Hdm as [[-> | Hm] | Hos].
      * apply msg_dep_happens_before_iff_one; left.
        unfold msg_dep_rel, compose; cbn; unfold Message.
        by rewrite elem_of_union, elem_of_singleton; left.
      * transitivity m; cbn in *.
        -- by destruct m; apply Hindm, elem_of_map; cbn; eexists; split.
        -- apply msg_dep_happens_before_iff_one; left.
           unfold msg_dep_rel, compose; cbn; unfold Message.
           by rewrite elem_of_union, elem_of_singleton; left.
      * assert (Hmos : message o ∈@{listset Message} set_map message (rec_obs_fn (MkState os a)))
          by (apply elem_of_map; eexists; split; done).
        apply Hindos in Hmos.
        cut (forall dm,
              msg_dep_rel Message_dependencies
                dm (MkMessage (MkState os a)) ->
              msg_dep_rel Message_dependencies
                dm (MkMessage (MkState (MkObservation l m :: os) a))).
        {
          intro Hext; apply msg_dep_happens_before_iff_one.
          apply msg_dep_happens_before_iff_one in Hmos as [Hdep | (dm & Hhb & Hdep)].
          - by left; apply Hext.
          - by right; eexists; split; [| apply Hext].
        }
        unfold msg_dep_rel; cbn.
        by intros dm; rewrite elem_of_union; right.
    + intros Hb; apply elem_of_map.
      do 2 setoid_rewrite elem_of_union; setoid_rewrite elem_of_singleton; cbn.
      apply msg_dep_happens_before_iff_one in Hb.
      unfold msg_dep_rel, compose in Hb; cbn in Hb; unfold Message in Hb.
      setoid_rewrite elem_of_union in Hb;
        setoid_rewrite elem_of_singleton in Hb.
      destruct Hb as [[-> | Hdm] | Hos].
      * by eexists; split; [| by left; left].
      * cut (msg_dep_happens_before Message_dependencies dm (MkMessage (MkState os a))).
        {
          intro Hb; apply Hindos, elem_of_map in Hb as (y & -> & Hy).
          by eexists; split; [| right].
        }
        by apply msg_dep_happens_before_iff_one; left.
      * destruct Hos as (y & Hb & [-> | Hos]).
        -- destruct m as [state_m].
           apply Hindm, elem_of_map in Hb as (y & -> & Hy).
           by eexists; split; [| left; right].
        -- cut (msg_dep_happens_before Message_dependencies dm
                (MkMessage (MkState os a))).
           {
             intros (z & -> & Hz)%Hindos%elem_of_map.
             by eexists; split; [| right].
           }
           transitivity y; [done |].
           by apply msg_dep_happens_before_iff_one; left.
Qed.

Definition Message_sender (m : Message) : option Address :=
  Some (adr (state m)).

Context
  `{finite.Finite index}
  `{Inhabited index}
  (idx : index -> Address)
  `{!Inj (=) (=) idx}
  .

Definition ELMO_A (a : Address) : index :=
  hd inhabitant (filter (fun i => idx i = a) (enum index)).

Lemma ELMO_A_inv : forall i, ELMO_A (idx i) = i.
Proof.
  intro i; unfold ELMO_A; cbn.
  replace (filter _ _) with [i]; [done |].
  generalize (enum index), (NoDup_enum index) as Hnodup, (elem_of_enum i) as Hi.
  induction l; intros; [by inversion Hi |].
  inversion Hnodup; subst.
  assert (Hnil : forall i, i ∉ l -> filter (fun i0 : index => idx i0 = idx i) l = []).
  {
    intros; apply Forall_filter_nil, Forall_forall.
    intros j Hj; contradict Hj.
    by eapply inj in Hj; [| done]; subst.
  }
  inversion Hi; subst; cbn.
  - by rewrite decide_True, Hnil.
  - rewrite decide_False, IHl; [done.. |].
    by intro Hcontra; eapply inj in Hcontra; [| done]; subst.
Qed.

End sec_BaseELMO_Observations.


(*
 * Notations_rewrites.v
 *
 * Rewriting rules useful for Notation definitions
 *)
Require Import Kami.AllNotations.
Require Import List.
Import ListNotations.
Require Import Kami.Notations.

Lemma app_rewrite1: forall T (a:T) b c, (a::b)++c=a::(b++c).
Proof.
  simpl.
  intros.
  reflexivity.
Qed.

Lemma Registers1: forall a b, Registers (a::b) = (MERegister a)::(Registers b).
Proof.
  intros.
  simpl Registers.
  reflexivity.
Qed.

Lemma Registers2: Registers []=[].
Proof.
  simpl.
  reflexivity.
Qed.

Lemma Registers_dist_append : forall l1 l2, Registers (l1++l2)=(Registers l1)++(Registers l2).
Proof.
  intros.
  induction l1.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHl1.
    reflexivity.
Qed.

Hint Rewrite Registers_dist_append : kami_rewrite_db.

Lemma app_rewrite2: forall A (f:A) (r:list A), [f]++r=f::r.
  Proof. reflexivity. Qed.

Hint Rewrite app_rewrite1 app_rewrite2 app_nil_l app_nil_r Registers1 Registers2 : kami_rewrite_db.
Hint Rewrite Registers1 Registers2 : kami_rewrite_db.

Lemma makeModule_rules_Registers: forall l, makeModule_rules (Registers l)=[].
Proof.
  intros.
  induction l.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHl.
    simpl.
    reflexivity.
Qed.

Lemma makeModule_rules_append: forall l1 l2, (makeModule_rules (l1++l2))=(makeModule_rules l1)++(makeModule_rules l2).
Proof.
  intros.
  induction l1.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHl1.
    destruct a; reflexivity.
Qed.

Lemma makeModule_rules_MERegister: forall a b, makeModule_rules ((MERegister a)::b)=makeModule_rules b.
Proof.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_rules_MERule: forall a b, makeModule_rules ((MERule a)::b)=a::(makeModule_rules b).
Proof.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_rules_nil: makeModule_rules []=[].
Proof.
  simpl.
  reflexivity.
Qed.

Hint Rewrite makeModule_rules_Registers makeModule_rules_append makeModule_rules_MERegister makeModule_rules_MERule makeModule_rules_nil : kami_rewrite_db.

Lemma makeModule_meths_Registers: forall l, makeModule_meths (Registers l)=[].
Proof.
  intros.
  induction l.
  simpl.
  reflexivity.
  simpl.
  rewrite IHl.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_meths_append: forall l1 l2, makeModule_meths (l1++l2)=(makeModule_meths l1)++(makeModule_meths l2).
Proof.
  intros.
  induction l1.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHl1.
    destruct a; reflexivity.
Qed.

Lemma makeModule_meths_MERegister: forall a b, makeModule_meths ((MERegister a)::b)=makeModule_meths b.
Proof.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_meths_MERule: forall a b, makeModule_meths ((MERule a)::b)=(makeModule_meths b).
Proof.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_meths_nil: makeModule_meths []=[].
Proof.
  simpl.
  reflexivity.
Qed.

Hint Rewrite makeModule_meths_Registers makeModule_meths_append makeModule_meths_MERegister makeModule_meths_MERule makeModule_meths_nil : kami_rewrite_db.

Lemma makeModule_regs_Registers: forall l, makeModule_regs (Registers l)=l.
Proof.
  intros.
  induction l.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHl.
    simpl.
    reflexivity.
Qed.

Lemma makeModule_regs_append: forall l1 l2, makeModule_regs (l1++l2)=(makeModule_regs l1)++(makeModule_regs l2).
Proof.
  intros.
  induction l1.
  + simpl.
    reflexivity.
  + simpl.
    rewrite IHl1.
    destruct a; reflexivity.
Qed.

Lemma makeModule_regs_MERegister: forall a b, makeModule_regs ((MERegister a)::b)=a::(makeModule_regs b).
Proof.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_regs_MERule: forall a b, makeModule_regs ((MERule a)::b)=makeModule_regs b.
Proof.
  simpl.
  reflexivity.
Qed.

Lemma makeModule_regs_nil: makeModule_regs []=[].
Proof.
  simpl.
  reflexivity.
Qed.

Hint Rewrite makeModule_regs_Registers makeModule_regs_append makeModule_regs_MERegister makeModule_regs_MERule makeModule_regs_nil : kami_rewrite_db.

Lemma map1: forall T R (f: T -> R) (h:T) t, List.map f (h::t)=(f h)::(List.map f t).
Proof.
  simpl.
  reflexivity.
Qed.

Lemma fold_right1: forall A B (f : B -> A -> A) (a0 : A) (h : B) (t : list B), List.fold_right f a0 (h::t)=f h (List.fold_right f a0 t).
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Lemma getAllRegisters_fold_right_ConcatMod : forall (b: Mod) (l:list Mod), getAllRegisters (List.fold_right ConcatMod b l)=(concat (List.map getAllRegisters l))++(getAllRegisters b).
Proof.
    induction l.
    + simpl.
      reflexivity.
    + simpl.
      rewrite IHl.
      rewrite app_assoc.
      reflexivity.
Qed.

Lemma getAllMethods_fold_right_ConcatMod : forall (b: Mod) (l:list Mod), getAllMethods (List.fold_right ConcatMod b l)=(concat (List.map getAllMethods l))++(getAllMethods b).
Proof.
    induction l.
    + simpl.
      reflexivity.
    + simpl.
      rewrite IHl.
      rewrite app_assoc.
      reflexivity.
Qed.

Lemma getAllRules_fold_right_ConcatMod : forall (b: Mod) (l:list Mod), getAllRules (List.fold_right ConcatMod b l)=(concat (List.map getAllRules l))++(getAllRules b).
Proof.
    induction l.
    + simpl.
      reflexivity.
    + simpl.
      rewrite IHl.
      rewrite app_assoc.
      reflexivity.
Qed.

Lemma getAllRules_ConcatMod : forall a b, getAllRules (ConcatMod a b)=getAllRules a++getAllRules b.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

Lemma getAllMethods_ConcatMod : forall a b, getAllMethods (ConcatMod a b)=getAllMethods a++getAllMethods b.
Proof.
  intros.
  simpl.
  reflexivity.
Qed.

(*
Lemma getCallsWithSignPerRule_append: forall T a b, getCallsWithSignPerRule (a++b)=getCallsWithSignPerRule a++getCallsWithSignPerRule b.
Proof.*)

Lemma getCallsPerMod_ConcatMod : forall a b, getCallsPerMod (ConcatMod a b)=(getCallsPerMod a)++(getCallsPerMod b).
Proof.
  unfold getCallsPerMod.
  simpl.
  intros.
  rewrite map_app.
  reflexivity.
Qed.

Lemma getCallsPerMod_BaseRegFile: forall m,
  getCallsPerMod (Base (BaseRegFile m)) = [].
Proof.
  intros.
  unfold getCallsPerMod.
  unfold getCallsWithSignPerMod.
  simpl.
  unfold getRegFileMethods.
  destruct m.
  destruct rfRead.
  + simpl.
    unfold getCallsWithSignPerMeth.
    destruct rfIsWrMask.
    - simpl.
      unfold readRegFile.
      induction reads.
      * reflexivity.
      * simpl.
        rewrite IHreads.
        reflexivity.
    - simpl.
      unfold readRegFile.
      induction reads.
      * reflexivity.
      * simpl.
        rewrite IHreads.
        reflexivity.
  + simpl.
    unfold getCallsWithSignPerMeth.
    simpl.
    unfold readSyncRegFile.
    destruct rfIsWrMask.
    simpl.
    destruct isAddr.
    * simpl.
      induction reads.
      -- reflexivity.
      -- simpl.
         rewrite map_app in IHreads.
         rewrite map_app.
         rewrite map_cons.
         simpl.
         rewrite concat_app in IHreads.
         rewrite concat_app.
         rewrite concat_cons.
         rewrite app_nil_l.
         rewrite IHreads.
         reflexivity.
    * simpl.
      induction reads.
      -- reflexivity.
      -- simpl.
         rewrite map_app in IHreads.
         rewrite map_app.
         rewrite map_cons.
         simpl.
         rewrite concat_app in IHreads.
         rewrite concat_app.
         rewrite concat_cons.
         rewrite app_nil_l.
         rewrite IHreads.
         reflexivity.
    * simpl.
      destruct isAddr.
      -- simpl.
         induction reads.
         ++ reflexivity.
         ++ simpl.
            rewrite map_app in IHreads.
            rewrite map_app.
            rewrite map_cons.
            simpl.
            rewrite concat_app in IHreads.
            rewrite concat_app.
            rewrite concat_cons.
            rewrite app_nil_l.
            rewrite IHreads.
            reflexivity.
      -- simpl.
         induction reads.
         ++ reflexivity.
         ++ simpl.
            rewrite map_app in IHreads.
            rewrite map_app.
            rewrite map_cons.
            simpl.
            rewrite concat_app in IHreads.
            rewrite concat_app.
            rewrite concat_cons.
            rewrite app_nil_l.
            rewrite IHreads.
            reflexivity.
Qed.

  Lemma getCallsPerMod_Base: forall (m : BaseModule), getCallsPerMod (Base m)=List.map fst (getCallsWithSignPerMod m).
  Proof.
    unfold getCallsPerMod.
    reflexivity.
  Qed.

Lemma map_getCallsPerMod_map_BaseRegFile: forall l,
  (concat (List.map getCallsPerMod
     (List.map (fun m : RegFileBase => (Base (BaseRegFile m))) l)))=[].
Proof.
  intros.
  induction l.
  + reflexivity.
  + simpl.
    rewrite IHl.
    rewrite app_nil_r.
    rewrite getCallsPerMod_BaseRegFile.
    reflexivity.
Qed.

  Lemma getCallsPerMod_fold_right_ConcatMod: forall (a:Mod) (l:list Mod), getCallsPerMod (List.fold_right ConcatMod a l)=concat (List.map getCallsPerMod l)++(getCallsPerMod a).
  Proof.
    intros.
    induction l.
    + reflexivity.
    + simpl.
      rewrite <- app_assoc.
      rewrite <- IHl.
      rewrite getCallsPerMod_ConcatMod.
      reflexivity.
Qed.

  Hint Rewrite map1 fold_right1 getAllRules_ConcatMod getAllMethods_ConcatMod getCallsPerMod_ConcatMod map_getCallsPerMod_map_BaseRegFile : kami_rewrite_db.
  Hint Rewrite getCallsPerMod_fold_right_ConcatMod getCallsPerMod_BaseRegFile : kami_rewrite_db.

  Theorem getAllRegisters_ConcatMod: forall a b, getAllRegisters (ConcatMod a b)=getAllRegisters(a)++getAllRegisters(b).
  Proof.
     reflexivity.
  Qed.

  (*Axiom EquivThenEqual: prop_extensionality.

  Theorem equiv_rewrite: forall x y, (x=y)=(x<->y).
  Proof.
    intros.
    apply EquivThenEqual.
    split.
    + intros.
      subst.
      split.
      - intros.
        apply H.
      - intros.
        apply H.
    + intros.
      inversion H; subst; clear H.
      apply EquivThenEqual.
      split.
      - apply H0.
      - apply H1.
  Qed.*)

  Theorem DisjKey_Cons1:
    forall T Q (a:(T*Q)) x z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}),
           DisjKey (a::x) z <-> ((~(List.In (fst a) (List.map fst z))) /\ DisjKey x z).
  Proof.
    intros.
    rewrite ?DisjKeyWeak_same.
    split.
    + intros.
      split.
      - unfold DisjKeyWeak in H.
        assert (List.In (fst a) (List.map fst (a::x)) -> List.In (fst a) (List.map fst z) -> False).
        apply H.
        intro X.
        apply H0.
        simpl.
        left.
        reflexivity.
        apply X.
      - simpl.
        intros.
        unfold DisjKeyWeak in H.
        unfold DisjKeyWeak.
        intros.
        assert (List.In k (List.map fst (a::x)) -> List.In k (List.map fst z) -> False).
        apply H.
        apply H2.
        simpl.
        right.
        apply H0.
        apply H1.
    + intros.
      inversion H; subst; clear H.
      unfold DisjKeyWeak.
      unfold DisjKeyWeak in H1.
      intros.
      assert (List.In k (List.map fst x) -> List.In k (List.map fst z) -> False).
      apply H1.
      simpl in H.
      inversion H;subst;clear H.
      - apply H0.
        apply H2.
      - apply H3.
        apply H4.
        apply H2.
    + apply W.
    + apply W.
Qed.

Theorem DisjKey_Cons2:
    forall T Q (a:(T*Q)) x z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}),
           DisjKey x (a::z) <-> ((~(List.In (fst a) (List.map fst x))) /\ DisjKey x z).
Proof.
    intros.
    rewrite ?DisjKeyWeak_same.
    split.
    + intros.
      split.
      - intros.
        unfold DisjKeyWeak in H.
        assert (List.In (fst a) (List.map fst x) -> List.In (fst a) (List.map fst (a::z)) -> False).
        apply H.
        intro X.
        apply H0.
        apply X.
        simpl.
        left.
        reflexivity.
      - simpl.
        intros.
        unfold DisjKeyWeak in H.
        unfold DisjKeyWeak.
        intros.
        assert (List.In k (List.map fst x) -> List.In k (List.map fst (a::z)) -> False).
        apply H.
        apply H2.
        apply H0.
        simpl.
        right.
        apply H1.
    + intros.
      inversion H; subst; clear H.
      unfold DisjKeyWeak.
      unfold DisjKeyWeak in H1.
      intros.
      inversion H2;subst;clear H2.
      - apply H0 in H.
        inversion H.
      - assert (List.In k (List.map fst x) -> List.In k (List.map fst z) -> False).
        apply H1.
        apply H2.
        apply H.
        apply H3.
    +  apply W.
    + apply W.
Qed.

Theorem DisjKey_Append1:
  forall T Q (x:list (T*Q)) y z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}),
  DisjKey (x++y) z<->(DisjKey x z /\ DisjKey y z).
  Proof.
    intros.
    rewrite ?DisjKeyWeak_same.
    induction x.
    + simpl.
      unfold DisjKeyWeak.
      simpl.
      split.
      - intros.
        * split.
          tauto.
          apply H.
      - intros.
        inversion H. subst. clear H.
        eapply H3.
        apply H0.
        apply H1.
    + simpl.
      repeat (rewrite <- DisjKeyWeak_same).
      rewrite ?DisjKey_Cons1.
      rewrite ?DisjKeyWeak_same.
      split.
      - intros.
        inversion H; subst; clear H.
        split.
        * split.
          ++ apply H0.
          ++ rewrite IHx in H1.
             inversion H1; subst; clear H1.
             apply H.
        * rewrite IHx in H1.
          inversion H1; subst; clear H1.
          apply H2.
      - simpl.
        intros.
        inversion H; subst; clear H.
        split.
        * inversion H0; subst; clear H0.
          apply H.
        * simpl.
          rewrite IHx.
          split.
          ++ inversion H0; subst; clear H0.
             apply H2.
          ++ simpl.
             apply H1.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
    + apply W.
    + apply W.
    + apply W.
Qed.

  Theorem DisjKey_Append2:
    forall T Q (x:list (T*Q)) y z (W:forall (a1:T) (a2:T), {a1=a2}+{a1<>a2}),
           DisjKey x (y++z)<->(DisjKey x y /\ DisjKey x z).
  Proof.
    intros.
    rewrite ?DisjKeyWeak_same.
    induction y.
    + simpl.
      unfold DisjKeyWeak.
      split.
      - intros.
        tauto.
      - simpl.
        intros.
        inversion H; subst; clear H.
        assert (List.In k (List.map fst x) -> List.In k (List.map fst z) -> False).
        apply H3.
        apply H.
        apply H0.
        apply H1.
    + simpl.
      repeat (rewrite <- DisjKeyWeak_same).
      rewrite ?DisjKey_Cons2.
      rewrite ?DisjKeyWeak_same.
      split.
      - intros.
        inversion H; subst; clear H.
        * split.
          ++ split.
             -- apply H0.
             -- apply IHy in H1.
                inversion H1; subst; clear H1.
                apply H.
          ++ apply IHy in H1.
             inversion H1; subst; clear H1.
             apply H2.
      - intros.
        inversion H; subst; clear H.
        inversion H0; subst; clear H0.
        split.
        * apply H.
        * apply IHy.
          split.
          ++ apply H2.
          ++ apply H1.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
      - apply W.
    + apply W.
    + apply W.
    + apply W.
  Qed.

  Theorem DisjKey_In_map2:
    forall A B a (k:A) r l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}), @DisjKey A B a ((k,r)::l)<->(~List.In k (List.map fst a) /\ (DisjKey a l)).
  Proof.
    intros.
    rewrite DisjKey_Cons2.
    simpl.
    reflexivity.
    apply W.
  Qed.

  Theorem DisjKey_In_map1: forall A B b (k:A) r l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}),
                           @DisjKey A B ((k,r)::l) b<->(~List.In k (List.map fst b) /\ (DisjKey l b)).
  Proof.
    intros.
    rewrite DisjKey_Cons1.
    simpl.
    reflexivity.
    apply W.
  Qed.

  Theorem DisjKey_In_map_fst2: forall A B a (f:(A*B)) l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}),
                               @DisjKey A B a (f::l)<->(~List.In (fst f) (List.map fst a) /\ (DisjKey a l)).
  Proof.
    intros.
    rewrite DisjKey_Cons2.
    reflexivity.
    apply W.
  Qed.

  Theorem DisjKey_In_map_fst1: forall A B b (f:(A*B)) l (W:forall (a1:A) (a2:A), {a1=a2}+{a1<>a2}),
          @DisjKey A B (f::l) b<->(~List.In (fst f) (List.map fst b) /\ (DisjKey l b)).
  Proof.
    intros.
    rewrite DisjKey_Cons1.
    reflexivity.
    apply W.
  Qed.

  Theorem map_getAllRegisters_map_RegFileBase: forall m,
    (List.map getAllRegisters (List.map (fun mm: RegFileBase =>  (Base (BaseRegFile mm))) m))=
        (List.map (fun mm: RegFileBase => getRegFileRegisters mm) m).
  Proof.
      induction m.
      + reflexivity.
      + simpl.
        rewrite IHm.
        reflexivity.
  Qed.

  Theorem map_getAllMethods_map_RegFileBase: forall m,
    (List.map getAllMethods (List.map (fun mm: RegFileBase =>  (Base (BaseRegFile mm))) m))=
        (List.map (fun mm: RegFileBase => getRegFileMethods mm) m).
  Proof.
      induction m.
      + reflexivity.
      + simpl.
        rewrite IHm.
        reflexivity.
  Qed.

  Theorem concat_map_getAllRules_map_RegFileBase: forall m,
    (concat (List.map getAllRules (List.map (fun mm: RegFileBase =>  (Base (BaseRegFile mm))) m))) = List.nil.
  Proof.
      induction m.
      + reflexivity.
      + simpl.
        rewrite IHm.
        reflexivity.
  Qed.

  Hint Rewrite getAllRegisters_fold_right_ConcatMod getAllMethods_fold_right_ConcatMod
       getAllRules_fold_right_ConcatMod
       concat_map_getAllRules_map_RegFileBase
       map_getAllMethods_map_RegFileBase map_getAllRegisters_map_RegFileBase : kami_rewrite_db.
  Hint Rewrite getAllRegisters_ConcatMod DisjKey_Append1 DisjKey_Append2 DisjKey_In_map2 DisjKey_In_map1 : kami_rewrite_db.
  Hint Rewrite DisjKey_In_map_fst2 DisjKey_In_map_fst1: kami_rewrite_db.

  Theorem getAllRegisters_BaseMod: forall regs rules dms,
      getAllRegisters (BaseMod regs rules dms)=regs.
  Proof.
      simpl.
      reflexivity.
  Qed.

  Theorem append_equal_prefix: forall T (a: list T) (b: list T) (c: list T), (a++b=a++c)->(b=c).
  Proof.
    intros.
    induction a.
    + rewrite ?app_nil_l.
      apply H.
    + inversion H; subst; clear H.
      apply IHa.
      apply H1.
  Qed.

  (*Theorem append_nequal_prefix: forall T (a: list T) (b: list T) (c: list T), (List.app a b<>List.app a c)<>(b=c).
  Proof.
      induction a.
      + reflexivity.
      + intros.
        simpl.
        destruct eq.
  Admitted.*)

  Hint Rewrite getAllRegisters_BaseMod append_equal_prefix : kami_rewrite_db.

  Theorem getAllRegisters_makeModule_MERegister: forall a b, getAllRegisters (makeModule ((MERegister a)::b))=a::getAllRegisters (makeModule b).
Proof.
    simpl.
    intros.
    reflexivity.
Qed.

Theorem getAllRegisters_makeModule_MERule: forall a b, getAllRegisters (makeModule ((MERule a)::b))=getAllRegisters (makeModule b).
Proof.
    simpl.
    intros.
    reflexivity.
Qed.

Theorem getAllRegisters_makeModule_Registers: forall a b, getAllRegisters (makeModule ((Registers a)++b))=a++getAllRegisters (makeModule b).
Proof.
    simpl.
    intros.
    induction a.
    + simpl.
      reflexivity.
    + simpl.
      rewrite IHa.
      reflexivity.
Qed.

Hint Rewrite getAllRegisters_makeModule_MERegister
             getAllRegisters_makeModule_Registers
           getAllRegisters_makeModule_MERule : kami_rewrite_db.

Theorem in_app: forall T (x:T) (a:List.list T) (b:List.list T), (List.In x (a++b)) <-> (List.In x a)\/(List.In x b).
Proof.
    intros.
    split.
    + intros.
      induction a.
      - simpl in H.
        right.
        apply H.
      - simpl in H.
        simpl.
        inversion H; subst; clear H.
        * left.
          left.
          reflexivity.
        * apply <- or_assoc.
          right.
          apply IHa.
          apply H0.
    + intros.
      inversion H; subst; clear H.
      - induction a.
        * unfold List.In in H0.
          inversion H0.
        * simpl.
          simpl in H0.
          inversion H0; subst; clear H0.
          ++ left.
             reflexivity.
          ++ right.
             apply IHa.
             apply H.
      - induction a.
        * simpl.
          apply H0.
        * simpl.
          right.
          apply IHa.
Qed.

Hint Rewrite in_app : kami_rewrite_db.

Lemma getAllMethods_makeModule_append: forall a b, getAllMethods (makeModule (a++b))=getAllMethods (makeModule a)++getAllMethods (makeModule b).
Proof.
    induction a.
    + reflexivity.
    + intros.
      destruct a.
      - apply IHa.
      - apply IHa.
      - unfold makeModule.
        simpl.
        simpl in IHa.
        rewrite IHa.
        reflexivity.
Qed.

Hint Rewrite getAllMethods_makeModule_append : kami_rewrite_db.

Lemma getAllMethods_makeModule_MERegister: forall a b, getAllMethods (makeModule ((MERegister a)::b))=getAllMethods (makeModule b).
Proof.
    simpl.
    reflexivity.
Qed.

Hint Rewrite getAllMethods_makeModule_MERegister : kami_rewrite_db.

Lemma getAllMethods_makeModule_MERule: forall a b, getAllMethods (makeModule ((MERule a)::b))=getAllMethods (makeModule b).
Proof.
    simpl.
    reflexivity.
Qed.

Hint Rewrite getAllMethods_makeModule_MERule : kami_rewrite_db.

Lemma getAllMethods_makeModule_Registers: forall a, getAllMethods (makeModule (Registers a))=[].
Proof.
    induction a.
    + reflexivity.
    + simpl.
      apply IHa.
Qed.

Hint Rewrite getAllMethods_makeModule_Registers : kami_rewrite_db.

Lemma getAllRules_makeModule_append: forall a b, getAllRules (makeModule (a++b))=getAllRules (makeModule a)++getAllRules (makeModule b).
Proof.
    induction a.
    + reflexivity.
    + intros.
      destruct a.
      - apply IHa.
      - unfold makeModule.
        simpl.
        simpl in IHa.
        rewrite IHa.
        reflexivity.
      - apply IHa.
Qed.

Hint Rewrite getAllRules_makeModule_append : kami_rewrite_db.

Lemma getAllRules_makeModule_MERegister: forall a b, getAllRules (makeModule ((MERegister a)::b))=getAllRules (makeModule b).
Proof.
    simpl.
    reflexivity.
Qed.

Hint Rewrite getAllRules_makeModule_MERegister : kami_rewrite_db.

Lemma getAllRules_makeModule_MERule: forall a b, getAllRules (makeModule ((MERule a)::b))=a::(getAllRules (makeModule b)).
Proof.
    simpl.
    reflexivity.
Qed.

Hint Rewrite getAllRules_makeModule_MERule : kami_rewrite_db.

Lemma getAllRules_makeModule_Registers: forall a, getAllRules (makeModule (Registers a))=[].
Proof.
    induction a.
    + reflexivity.
    + simpl.
      apply IHa.
Qed.

Hint Rewrite getAllRules_makeModule_Registers : kami_rewrite_db.

Hint Rewrite map_app : kami_rewrite_db.

Lemma getAllMethods_createHideMod: forall m h, getAllMethods (createHideMod m h)=getAllMethods m.
Proof.
  intros.
  induction h.
  - reflexivity.
  - simpl.
    apply IHh.
Qed.

Hint Rewrite getAllMethods_createHideMod : kami_rewrite_db.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Translation of parallel moves into sequences of individual moves.

  In this file, we adapt the generic "parallel move" algorithm
  (developed and proved correct in module [Parmov]) to the idiosyncraties
  of the [LTLin] and [Linear] intermediate languages.  While the generic
  algorithm assumes that registers never overlap, the locations
  used in [LTLin] and [Linear] can overlap, and assigning one location
  can set the values of other, overlapping locations to [Vundef].
  We address this issue in the remainder of this file.
*)

Require Import Coqlib.
Require Parmov.
Require Import Values.
Require Import AST.
Require Import Locations.
Require Import Conventions.

(** * Instantiating the generic parallel move algorithm *)

(** The temporary location to use for a move is determined
  by the type of the data being moved: register [IT2] for an
  integer datum, and register [FT2] for a floating-point datum. *)

Definition temp_for (l: loc) : loc :=
  match Loc.type l with Tint => R IT2 | Tfloat => R FT2 end.

Definition parmove (srcs dsts: list loc) :=
  Parmov.parmove2 loc Loc.eq temp_for srcs dsts.

Definition moves := (list (loc * loc))%type.

(** [exec_seq m] gives semantics to a sequence of elementary moves.
  This semantics ignores the possibility of overlap: only the
  target locations are updated, but the locations they
  overlap with are not set to [Vundef].  See [effect_seqmove] below
  for a semantics that accounts for overlaps. *)

Definition exec_seq (m: moves) (e: Locmap.t) : Locmap.t :=
  Parmov.exec_seq loc Loc.eq val m e.

Lemma temp_for_charact:
  forall l, temp_for l = R IT2 \/ temp_for l = R FT2.
Proof.
  intro; unfold temp_for. destruct (Loc.type l); tauto.
Qed.

Lemma is_not_temp_charact:
  forall l,
  Parmov.is_not_temp loc temp_for l <-> l <> R IT2 /\ l <> R FT2.
Proof.
  intros. unfold Parmov.is_not_temp.
  destruct (Loc.eq l (R IT2)).
  subst l. intuition. apply (H (R IT2)). reflexivity. discriminate.
  destruct (Loc.eq l (R FT2)).
  subst l. intuition. apply (H (R FT2)). reflexivity.
  assert (forall d, l <> temp_for d).
    intro. elim (temp_for_charact d); congruence.
  intuition.
Qed.

Lemma disjoint_temp_not_temp:
  forall l, Loc.notin l temporaries -> Parmov.is_not_temp loc temp_for l.
Proof.
  intros. rewrite is_not_temp_charact.
  unfold temporaries in H; simpl in H.
  split; apply Loc.diff_not_eq; tauto.
Qed.

Lemma loc_norepet_norepet:
  forall l, Loc.norepet l -> list_norepet l.
Proof.
  induction 1; constructor.
  apply Loc.notin_not_in; auto. auto.
Qed.

(** Instantiating the theorems proved in [Parmov], we obtain
  the following properties of semantic correctness and well-typedness
  of the generated sequence of moves.  Note that the semantic
  correctness result is stated in terms of the [exec_seq] semantics,
  and therefore does not account for overlap between locations. *)

Lemma parmove_prop_1:
  forall srcs dsts,
  List.length srcs = List.length dsts ->
  Loc.norepet dsts ->
  Loc.disjoint srcs temporaries ->
  Loc.disjoint dsts temporaries ->
  forall e,
  let e' := exec_seq (parmove srcs dsts) e in
  List.map e' dsts = List.map e srcs /\
  forall l, ~In l dsts -> l <> R IT2 -> l <> R FT2 -> e' l = e l.
Proof.
  intros.
  assert (NR: list_norepet dsts) by (apply loc_norepet_norepet; auto).
  assert (NTS: forall r, In r srcs -> Parmov.is_not_temp loc temp_for r).
    intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with srcs; auto.
  assert (NTD: forall r, In r dsts -> Parmov.is_not_temp loc temp_for r).
    intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with dsts; auto.
  generalize (Parmov.parmove2_correctness loc Loc.eq temp_for val srcs dsts H NR NTS NTD e).
  change (Parmov.exec_seq loc Loc.eq val (Parmov.parmove2 loc Loc.eq temp_for srcs dsts) e) with e'.
  intros [A B].
  split. auto. intros. apply B. auto. rewrite is_not_temp_charact; auto.
Qed.

Lemma parmove_prop_2:
  forall srcs dsts s d,
  In (s, d) (parmove srcs dsts) ->
     (In s srcs \/ s = R IT2 \/ s = R FT2)
  /\ (In d dsts \/ d = R IT2 \/ d = R FT2).
Proof.
  intros srcs dsts.
  set (mu := List.combine srcs dsts).
  assert (forall s d, Parmov.wf_move loc temp_for mu s d ->
            (In s srcs \/ s = R IT2 \/ s = R FT2)
         /\ (In d dsts \/ d = R IT2 \/ d = R FT2)).
  unfold mu; induction 1.
  split.
    left. eapply List.in_combine_l; eauto.
    left. eapply List.in_combine_r; eauto.
  split.
    right. apply temp_for_charact.
    tauto.
  split.
    tauto.
    right. apply temp_for_charact.
  intros. apply H.
  apply (Parmov.parmove2_wf_moves loc Loc.eq temp_for srcs dsts s d H0).
Qed.

Lemma loc_type_temp_for:
  forall l, Loc.type (temp_for l) = Loc.type l.
Proof.
  intros; unfold temp_for. destruct (Loc.type l); reflexivity.
Qed.

Lemma loc_type_combine:
  forall srcs dsts,
  List.map Loc.type srcs = List.map Loc.type dsts ->
  forall s d,
  In (s, d) (List.combine srcs dsts) ->
  Loc.type s = Loc.type d.
Proof.
  induction srcs; destruct dsts; simpl; intros; try discriminate.
  elim H0.
  elim H0; intros. inversion H1; subst. congruence.
  apply IHsrcs with dsts. congruence. auto.
Qed.

Lemma parmove_prop_3:
  forall srcs dsts,
  List.map Loc.type srcs = List.map Loc.type dsts ->
  forall s d,
  In (s, d) (parmove srcs dsts) -> Loc.type s = Loc.type d.
Proof.
  intros srcs dsts TYP.
  set (mu := List.combine srcs dsts).
  assert (forall s d, Parmov.wf_move loc temp_for mu s d ->
            Loc.type s = Loc.type d).
  unfold mu; induction 1.
  eapply loc_type_combine; eauto.
  rewrite loc_type_temp_for; auto.
  rewrite loc_type_temp_for; auto.
  intros. apply H.
  apply (Parmov.parmove2_wf_moves loc Loc.eq temp_for srcs dsts s d H0).
Qed.

(** * Accounting for overlap between locations *)

Section EQUIVALENCE.

(** We now prove the correctness of the generated sequence of elementary
  moves, accounting for possible overlap between locations.
  The proof is conducted under the following hypotheses: there must
  be no partial overlap between
- two distinct destinations (hypothesis [NOREPET]);
- a source location and a destination location (hypothesis [NO_OVERLAP]).
*)

Variables srcs dsts: list loc.
Hypothesis LENGTH: List.length srcs = List.length dsts.
Hypothesis NOREPET: Loc.norepet dsts.
Hypothesis NO_OVERLAP: Loc.no_overlap srcs dsts.
Hypothesis NO_SRCS_TEMP: Loc.disjoint srcs temporaries.
Hypothesis NO_DSTS_TEMP: Loc.disjoint dsts temporaries.

(** [no_overlap_dests l] holds if location [l] does not partially overlap
  a destination location: either it is identical to one of the
  destinations, or it is disjoint from all destinations. *)

Definition no_overlap_dests (l: loc) : Prop :=
  forall d, In d dsts -> l = d \/ Loc.diff l d.

(** We show that [no_overlap_dests] holds for any destination location
  and for any source location. *)

Lemma dests_no_overlap_dests:
  forall l, In l dsts -> no_overlap_dests l.
Proof.
  assert (forall d, Loc.norepet d ->
          forall l1 l2, In l1 d -> In l2 d -> l1 = l2 \/ Loc.diff l1 l2).
  induction 1; simpl; intros.
  contradiction.
  elim H1; intro; elim H2; intro.
  left; congruence.
  right. subst l1. eapply Loc.in_notin_diff; eauto.
  right. subst l2. apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto.
  eauto.
  intros; red; intros. eauto.
Qed.

Lemma notin_dests_no_overlap_dests:
  forall l, Loc.notin l dsts -> no_overlap_dests l.
Proof.
  intros; red; intros.
  right. eapply Loc.in_notin_diff; eauto.
Qed.

Lemma source_no_overlap_dests:
  forall s, In s srcs \/ s = R IT2 \/ s = R FT2 -> no_overlap_dests s.
Proof.
  intros. elim H; intro. exact (NO_OVERLAP s H0).
  elim H0; intro; subst s; red; intros;
  right; apply Loc.diff_sym; apply NO_DSTS_TEMP; auto; simpl; tauto.
Qed.

Lemma source_not_temp1:
  forall s, In s srcs \/ s = R IT2 \/ s = R FT2 ->
  Loc.diff s (R IT1) /\ Loc.diff s (R FT1) /\ Loc.notin s destroyed_at_move.
Proof.
  intros. destruct H.
  exploit Loc.disjoint_notin. eexact NO_SRCS_TEMP. eauto.
  simpl; tauto.
  destruct H; subst s; simpl; intuition congruence.
Qed.

Lemma dest_noteq_diff:
  forall d l,
  In d dsts \/ d = R IT2 \/ d = R FT2 ->
  l <> d ->
  no_overlap_dests l ->
  Loc.diff l d.
Proof.
  intros. elim H; intro.
  elim (H1 d H2); intro. congruence. auto.
  assert (forall r, l <> R r -> Loc.diff l (R r)).
    intros. destruct l; simpl. congruence. destruct s; auto.
  elim H2; intro; subst d; auto.
Qed.

(** [locmap_equiv e1 e2] holds if the location maps [e1] and [e2]
  assign the same values to all locations except temporaries [IT1], [FT1]
  and except locations that partially overlap a destination. *)

Definition locmap_equiv (e1 e2: Locmap.t): Prop :=
  forall l,
  no_overlap_dests l -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> Loc.notin l destroyed_at_move -> e2 l = e1 l.

(** The following predicates characterize the effect of one move
  move ([effect_move]) and of a sequence of elementary moves
  ([effect_seqmove]).  We allow the code generated for one move
  to use the temporaries [IT1] and [FT1] and [destroyed_at_move] in any way it needs. *)

Definition effect_move (src dst: loc) (e e': Locmap.t): Prop :=
  e' dst = e src /\
  forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> Loc.notin l destroyed_at_move -> e' l = e l.

Inductive effect_seqmove: list (loc * loc) -> Locmap.t -> Locmap.t -> Prop :=
  | effect_seqmove_nil: forall e,
      effect_seqmove nil e e
  | effect_seqmove_cons: forall s d m e1 e2 e3,
      effect_move s d e1 e2 ->
      effect_seqmove m e2 e3 ->
      effect_seqmove ((s, d) :: m) e1 e3.

(** The following crucial lemma shows that [locmap_equiv] is preserved
  by executing one move [d <- s], once using the [effect_move]
  predicate that accounts for partial overlap and the use of
  temporaries [IT1], [FT1], or via the [Parmov.update] function that
  does not account for any of these. *)

Lemma effect_move_equiv:
  forall s d e1 e2 e1',
  (In s srcs \/ s = R IT2 \/ s = R FT2) ->
  (In d dsts \/ d = R IT2 \/ d = R FT2) ->
  locmap_equiv e1 e2 -> effect_move s d e1 e1' ->
  locmap_equiv e1' (Parmov.update loc Loc.eq val d (e2 s) e2).
Proof.
  intros. destruct H2. red; intros.
  unfold Parmov.update. destruct (Loc.eq l d).
  subst l. destruct (source_not_temp1 _ H) as [A [B C]].
  rewrite H2. apply H1; auto. apply source_no_overlap_dests; auto.
  rewrite H3; auto. apply dest_noteq_diff; auto.
Qed.

(** We then extend the previous lemma to a sequence [mu] of elementary moves.
*)

Lemma effect_seqmove_equiv:
  forall mu e1 e1',
  effect_seqmove mu e1 e1' ->
  forall e2,
  (forall s d, In (s, d) mu ->
     (In s srcs \/ s = R IT2 \/ s = R FT2) /\
     (In d dsts \/ d = R IT2 \/ d = R FT2)) ->
  locmap_equiv e1 e2 ->
  locmap_equiv e1' (exec_seq mu e2).
Proof.
  induction 1; intros.
  simpl. auto.
  simpl. apply IHeffect_seqmove.
  intros. apply H1. apply in_cons; auto.
  destruct (H1 s d (in_eq _ _)).
  eapply effect_move_equiv; eauto.
Qed.

(** Here is the main result in this file: executing the sequence
  of moves returned by the [parmove] function results in the
  desired state for locations: the final values of destination locations
  are the initial values of source locations, and all locations
  that are disjoint from the temporaries and the destinations
  keep their initial values. *)

Lemma effect_parmove:
  forall e e',
  effect_seqmove (parmove srcs dsts) e e' ->
  List.map e' dsts = List.map e srcs /\
  forall l, Loc.notin l dsts -> Loc.notin l temporaries -> e' l = e l.
Proof.
  set (mu := parmove srcs dsts). intros.
  assert (locmap_equiv e e) by (red; auto).
  generalize (effect_seqmove_equiv mu e e' H e (parmove_prop_2 srcs dsts) H0).
  intro.
  generalize (parmove_prop_1 srcs dsts LENGTH NOREPET NO_SRCS_TEMP NO_DSTS_TEMP e).
  fold mu. intros [A B].
  (* e' dsts = e srcs *)
  split. rewrite <- A. apply list_map_exten; intros.
  exploit Loc.disjoint_notin. eexact NO_DSTS_TEMP. eauto. simpl; intros.
  apply H1. apply dests_no_overlap_dests; auto.
  tauto. tauto. simpl; tauto.
  (* other locations *)
  intros. transitivity (exec_seq mu e l).
  symmetry. apply H1. apply notin_dests_no_overlap_dests; auto.
  eapply Loc.in_notin_diff; eauto. simpl; tauto.
  eapply Loc.in_notin_diff; eauto. simpl; tauto.
  simpl in H3; simpl; tauto.
  apply B. apply Loc.notin_not_in; auto.
  apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto.
  apply Loc.diff_not_eq. eapply Loc.in_notin_diff; eauto. simpl; tauto.
Qed.

End EQUIVALENCE.


(**

== Representation and verification of WordCount ==

WordCount is a standard MapReduce application.
It counts each word's frequency in a CBS file.

This file shows how we represent the actual application,
and how we specify and verify the behavior of programs.

Advice: readers need to read Language.v first.

Author: Bowen Zhang.

Date : 2022.11.1
*)

From SLF (* TLC *) Require Export LibCore TLCbuffer.
From SLF (* Sep *) Require Export Rules AuxLmm.
(*------------------------------------------------------------------------*)

Export NotationForTrm.
Export NotationForVariables.

Open Scope val_scope.
Open Scope trm_scope.
Open Scope Z_scope.

(* ########################### WordCount ########################### *)

(*
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose a HDFS state before WordCount:

--f
  | bk1 [n1;n2]
  | bk2 [n3;n1]
  | bk3 [n2]

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The state after WordCount:

--f
  | bk1 [n1;n2]
  | bk2 [n3;n1]
  | bk3 [n2]

--f2
  | bk4 [n1;2]
  | bk5 [n2;2]
  | bk6 [n3;1]
*)

(*
------- Representation and Specification ----------

Definition WordCount :=
  Fun 'f :=
    Let 'L1 := Mapper 'f 0 in
    Let 'L2 := Shuffle 'L1 in
    Let 'l := Reducer 'L2 in
    Create_File 'l.

Lemma triple_WordCount: forall Hf Hb (f:floc) (n1 n2 n3 :int) (p1 p2 p3:bloc),
  diff_each_3 n1 n2 n3 ->
  Hf = ( f ~f~> (p1::p2::p3::nil) ) ->
  Hb = ( (p1 ~b~> (n1::n2::nil)) \b* (p2 ~b~> (n3::n1::nil)) \b* (p3 ~b~> (n2::nil)) ) ->
  triple (WordCount f)
    (\R[Hf,Hb])
    (fun r => \exists f1 b4 b5 b6,( \[r= (val_floc f1)] \*
        (\R[(f1 ~f~> (b4::b5::b6::nil) \f* Hf),
        Hb \b* (b4 ~b~> (n1::2::nil)) \b* (b5 ~b~> (n2::2::nil))
        \b* (b6 ~b~> (n3::1::nil))] ))).

*)

(*============= Mapper ================*)
Definition Mapper :=
  Fix 'F 'f 'i :=
    Let 'n := 'fsize 'f in
    Let 'be := ('i '= 'n) in
    If_ 'be
    Then (val_Listwd nil)
    Else
      Let 'bk := 'nth_blk 'f 'i in
      Let 'i1 := 'i '+ 1 in
      Let 'ln := 'wdmap 'bk in
      Let 'ln1 := 'F 'f 'i1 in
      'ln 'w:: 'ln1.

(* specification of mapper *)
Lemma triple_Mapper: forall Hf Hb (f:floc) (n1 n2 n3:int) (p1 p2 p3:bloc) (L:(list (list wdpair))),
  diff_each_3 n1 n2 n3 ->
  Hf = ( f ~f~> (p1::p2::p3::nil) ) ->
  Hb = ( (p1 ~b~> (n1::n2::nil)) \b* (p2 ~b~> (n3::n1::nil)) \b* (p3 ~b~> (n2::nil)) ) ->
  L = ( ((n1,1)::(n2,1)::nil) :: ((n3,1)::(n1,1)::nil) :: ((n2,1)::nil) :: nil ) ->
  triple (Mapper f 0)
    (\R[Hf,Hb])
    (fun r => \[r= val_Listwd L] \* \R[Hf,Hb]).
Proof.
  fix_map.
  rewrite hstar_sep, hfstar_hempty_l. apply himpl_refl.
  rew_read. ext.

  applys triple_let.
  fix_map.
  rewrite hstar_sep, hfstar_hempty_l,hbstar_comm,hbstar_assoc. apply himpl_refl.
  rew_read. ext.

  applys triple_let.
  fix_map.
  rewrite hstar_sep, hfstar_hempty_l,hbstar_comm,hbstar_assoc. apply himpl_refl.
  rew_read. ext.

  applys triple_let.
  exp_fix.
  applys triple_val'. ext.
  applys triple_app_wdlist. ext.
  applys triple_app_wdlist. ext.
  applys triple_conseq triple_app_wdlist.
  apply himpl_refl.
  intros r. rew_list.
  rewrite hbstar_comm,hbstar_assoc. apply himpl_refl.
Qed.

(*============= Shuffle ================*)
Definition Shuffle :=
 Fun 'L :=
    Let 'l := 'wdmerge 'L in
      'wdshuffle 'l.

Lemma triple_Shuffle: forall Hf Hb (n1 n2 n3 : int) (L1 L2: (list (list wdpair))),
  diff_each_3 n1 n2 n3 ->
  L1 = ( ((n1,1)::(n2,1)::nil) :: ((n3,1)::(n1,1)::nil) :: ((n2,1)::nil) :: nil ) ->
  L2 = ( ((n1,1)::(n1,1)::nil) :: ((n2,1)::(n2,1)::nil) :: ((n3,1)::nil) ::nil ) ->
  triple (Shuffle (val_Listwd L1))
    (\R[Hf,Hb])
    (fun r => \[r= val_Listwd L2] \* \R[Hf,Hb]).
Proof.
  intros. subst.
  applys* triple_app_fun. simpl.
  applys triple_let.
  applys triple_conseq_frame triple_wdmerge.
  rewrite hstar_hempty_r'. applys himpl_refl.
  intros r. rewrite hstar_hempty_r'.
  unfold wordmerge,merge. simpl. applys himpl_refl.
  ext.
  applys triple_conseq_frame triple_wdshuffle.
  rewrite hstar_hempty_r'. applys himpl_refl.
  intros r. rewrite hstar_hempty_r'.
  apply shuffle_diff in H.
  rewrite <- H.
  applys himpl_refl.
Qed.

(*============= Reducer ================*)
Definition Reducer :=
  Fun 'L :=  'wdreduce 'L.

Lemma triple_Reducer: forall Hf Hb (n1 n2 n3 : int) (lwd:list wdpair) (L : (list (list wdpair))),
  diff_each_3 n1 n2 n3 ->
  L = ( ((n1,1)::(n1,1)::nil) :: ((n2,1)::(n2,1)::nil) :: ((n3,1)::nil) ::nil ) ->
  lwd = ((n1,2)::(n2,2)::(n3,1)::nil ) ->
  triple (Reducer (val_Listwd L))
    (\R[Hf,Hb])
    (fun r => \[r= val_listwdpair lwd] \* \R[Hf,Hb]).
Proof.
  intros. subst.
  applys* triple_app_fun. simpl.
  applys triple_conseq_frame triple_wdreduce.
  rewrite hstar_hempty_r'. applys himpl_refl.
  intros r. rewrite hstar_hempty_r'.
  applys himpl_refl.
Qed.

(*============= Create files ================*)
Definition Create_Blks_buffer : val :=
  Fix 'F 'l 'lb:=
    Let 'm := 'len 'l in
    Let 'be := ('m '<= 2) in
    If_ 'be
    Then
      Let 'bk := 'bcreate 'l in
        'bk 'b+ 'lb
    Else
      Let 'l1 := 'hd 'l in
      Let 'l2 := 'tl 'l in
      Let 'bk1 := 'bcreate 'l1 in
      Let 'lb1 := 'bk1 'b+ 'lb in
        'F 'l2 'lb1.

Lemma triple_Create_Blks_buffer : forall Hf (n1 n2 n3 n4 n5 n6:int),
  triple (Create_Blks_buffer (val_listint (n1::n2::n3::n4::n5::n6::nil)) (val_listbloc nil))
    (\R[Hf, \b[] ])
     (fun r => \exists b1 b2 b3,( \[r=(val_listbloc (b3::b2::b1::nil))] \*
               (\R[Hf, (b1 ~b~> (n1::n2::nil)) \b* (b2 ~b~> (n3::n4::nil) \b* (b3 ~b~> (n5::n6::nil)))]))).
Proof.
  intros. applys* triple_app_fix2. simpl.
  applys triple_let triple_list_len.
  ext. applys triple_let triple_le. ext.
  applys triple_if. case_if*. destruct C. auto.
  applys triple_let triple_list_hd. ext.
  applys triple_let triple_list_tl. ext.
  applys triple_let.
  applys triple_conseq_frame triple_bcreate.
  rewrite hstar_sep. rewrite hfstar_hempty_r, hbstar_hempty_l.
  apply himpl_refl. intros r. simpl.
  apply himpl_refl. intros r. simpl.
  rewrite hstar_hexists.
  applys triple_hexists. intros b1.
  rewrite hstar_hempty_r. ext.
  applys triple_let triple_fbuffer_list.
  intros. simpl. ext.

  applys* triple_app_fix2. simpl.
  applys triple_let triple_list_len.
  ext. applys triple_let triple_le. ext.
  applys triple_if. case_if*.
  applys triple_let triple_list_hd. ext.
  applys triple_let triple_list_tl. ext.
  applys triple_let.
  applys triple_conseq_frame triple_bcreate.
  rewrite hstar_sep. rewrite hfstar_hempty_r, hbstar_hempty_l.
  apply himpl_refl. intros r. simpl.
  apply himpl_refl. intros r. simpl.
  rewrite hstar_hexists.
  applys triple_hexists. intros b2.
  rewrite hstar_assoc, hstar_sep, hfstar_hempty_r. ext.
  applys triple_let triple_fbuffer_list.
  intros. simpl. ext.

  applys* triple_app_fix2. simpl.
  applys triple_let triple_list_len.
  ext. applys triple_let triple_le. ext.
  applys triple_if. case_if*.
  applys triple_let.
  applys triple_conseq_frame triple_bcreate.
  rewrite hstar_sep. rewrite hfstar_hempty_r, hbstar_hempty_l.
  apply himpl_refl. intros r. simpl.
  apply himpl_refl. intros r. simpl.
  rewrite hstar_hexists.
  applys triple_hexists. intros b3.
  rewrite hstar_assoc, hstar_sep, hfstar_hempty_r. ext.
  applys triple_conseq_frame triple_fbuffer_list.
  rewrite hstar_hempty_l'. apply himpl_refl.
  intros r. simpl. rewrite hstar_hempty_r.
  rewrite hbstar_comm3. intros h H.
  rewrite hstar_hpure_iff in H.
  destruct H as (H1&H2).
  exists b1 b2 b3.
  applys hstar_hpure_iff. splits~.
  destruct C1. rew_list. discriminate.
Qed.

Definition Create_File : val :=
  Fun 'l:=
    Let 'l1 := 'reform 'l in
    Let 'lb1 := Create_Blks_buffer 'l1 (val_listbloc nil) in
    Let 'lb := 'frev 'lb1 in
      'fcreate 'lb.

Lemma triple_Create_File : forall (w1 w2 w3 n1 n2 n3:int),
  triple (Create_File (val_listwdpair ((w1,n1)::(w2,n2)::(w3,n3)::nil)) )
    (\R[\f[], \b[] ])
     (fun r => \exists f b1 b2 b3,( \[r= (val_floc f)] \*
               (\R[(f ~f~> (b1::b2::b3::nil)), (b1 ~b~> (w1::n1::nil)) \b* (b2 ~b~> (w2::n2::nil) \b* (b3 ~b~> (w3::n3::nil)))]))).
Proof.
  intros. applys* triple_app_fun. simpl.
  applys triple_let triple_MRlist_reform.
  ext.
  applys triple_let triple_Create_Blks_buffer.
  intros v. ext. intros b1. ext. intros b2. ext. intros b3. ext.
  applys triple_let.
  applys triple_conseq_frame triple_frev_blist.
  rewrite hstar_hempty_l'. apply himpl_refl.
  intros r. rewrite hstar_assoc, hstar_hempty_l. apply himpl_refl.
  ext.
  applys triple_conseq_frame triple_fcreate.
  rewrite hstar_hempty_r'.
  apply himpl_noduplicate3.
  intros v. rewrite hstar_hempty_r'.
  apply himpl_hexists_l. intros f.
  intros h M. exists~ f b1 b2 b3.
Qed.

(* $$$$$$$$$$$$$==================$$$$$$$$$$$$$$$$$$$$$ *)

Definition WordCount :=
  Fun 'f :=
    Let 'L1 := Mapper 'f 0 in
    Let 'L2 := Shuffle 'L1 in
    Let 'l := Reducer 'L2 in
    Create_File 'l.

Lemma triple_WordCount: forall Hf Hb (f:floc) (n1 n2 n3 :int) (p1 p2 p3:bloc),
  diff_each_3 n1 n2 n3 ->
  Hf = ( f ~f~> (p1::p2::p3::nil) ) ->
  Hb = ( (p1 ~b~> (n1::n2::nil)) \b* (p2 ~b~> (n3::n1::nil)) \b* (p3 ~b~> (n2::nil)) ) ->
  triple (WordCount f)
    (\R[Hf,Hb])
    (fun r => \exists f1 b4 b5 b6,( \[r= (val_floc f1)] \*
        (\R[(f1 ~f~> (b4::b5::b6::nil) \f* Hf),
        Hb \b* (b4 ~b~> (n1::2::nil)) \b* (b5 ~b~> (n2::2::nil))
        \b* (b6 ~b~> (n3::1::nil))] ))).
Proof.
    intros. subst.
  applys* triple_app_fun. simpl.
  applys triple_let.
  applys* triple_Mapper.
  simpl. intros r. ext.
  applys triple_let. applys* triple_Shuffle H.
  ext.
  applys triple_let. applys* triple_Reducer.
  ext.
  applys triple_conseq_frame triple_Create_File.
  rewrite hstar_hempty_l'. apply himpl_refl.
  intros r. rewrite hstar_hexists.
  apply himpl_hexists_l. intros f1.
  rewrite hstar_hexists.
  apply himpl_hexists_l. intros b4.
  rewrite hstar_hexists.
  apply himpl_hexists_l. intros b5.
  rewrite hstar_hexists.
  apply himpl_hexists_l. intros b6.
  rewrite hstar_assoc.
  intros h M.
  rewrite hstar_hpure_iff in M.
  destruct M as (M1&M2).
  rewrite hstar_sep in M2.
  exists f1 b4 b5 b6.
  rewrite hstar_hpure_iff.
  splits*. rewrite~ hbstar_comm.
Qed.