From VLSM.Lib Require Import Itauto.
From Coq Require Import FunctionalExtensionality.
From stdpp Require Import prelude finite.
From VLSM.Lib Require Import Preamble ListExtras StdppExtras.
From VLSM.Core Require Import VLSM VLSMProjections Composition.
From VLSM.Core Require Import Validator ProjectionTraces.
From VLSM.Core Require Import BaseELMO UMO.

(** * MO Protocol Definitions and Properties

  This module contains definitions and properties of MO components and
  the MO protocol.
*)

Section sec_MO.

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

(**
  A message is valid for MO if one of the following is the case:

  - it has no observations and its address belongs to the set of allowed
    addresses (as determined by the predicate <<P>>)
  - its last observation was another valid message which was sent
  - its last observation was another valid message which was received
    and the messages observed previously are also valid
*)
Inductive MO_msg_valid (P : Address -> Prop) : Message -> Prop :=
| MO_mv_nil :
    forall m : Message,
      obs (state m) = [] -> P (adr (state m)) -> MO_msg_valid P m
| MO_mv_send :
    forall m : Message,
      MO_msg_valid P m -> MO_msg_valid P (m <*> MkObservation Send m)
| MO_mv_recv :
    forall m mr : Message,
      MO_msg_valid P m -> MO_msg_valid P mr -> MO_msg_valid P (m <*> MkObservation Receive mr).

Section sec_alternative_definition_of_validity.

(** ** Alternative definition of validity

  The above constructors of [MO_msg_valid] may not be the most readable,
  so we will provide an alternative version of this inductive
  definition (called [MO_msg_valid_alt]) and prove them equivalent.

  If [MO_msg_valid_alt_sends] holds for <<m>>, then every possible suffix of
  observations from <<m>> is the same as the observations from a message <<m'>>
  which was the next message that was sent after the suffix. Also, the addresses
  of <<m>> and <<m'>> have to agree.
*)
Definition MO_msg_valid_alt_sends (m : Message) : Prop :=
  forall (k : nat) (suffix : list Observation) (m' : Message),
    lastn k (obs (state m)) = addObservation' (MkObservation Send m') suffix ->
      obs (state m') = suffix /\ adr (state m') = adr (state m).

(**
  If [MO_msg_valid_alt_recvs'] holds for <<valid>> and <<m>>, this means
  that for every suffix of observations from <<m>>, the message <<m'>>, which
  was the next message received after the suffix, is valid.

  Here, validity is determined by an arbitrary predicate. Ultimately, we want
  to replace this arbitrary predicate with [MO_msg_valid_alt], the alternative
  definition of message validity for MO.
*)
Definition MO_msg_valid_alt_recvs' (valid : Message -> Prop) (m : Message) : Prop :=
  forall (k : nat) (suffix : list Observation) (m' : Message),
    lastn k (obs (state m)) = addObservation' (MkObservation Receive m') suffix ->
      valid m'.

(**
  A message is valid for MO (according to the alternative definition) if one
  of the following holds:

  - its address belongs to the set of allowed addresses (as determined by <<P>>)
  - it satisfies [MO_msg_valid_alt_sends]
  - it satisfies [MO_msg_valid_alt_recvs'], with [MO_msg_valid_alt] applied to
    <<P>> used as the validity predicate
*)
Inductive MO_msg_valid_alt (P : Address -> Prop) (m : Message) : Prop :=
{
  P_adr_state : P (adr (state m));
  MO_msg_valid_alt_sends' : MO_msg_valid_alt_sends m;
  MO_msg_valid_alt_recvs'' : MO_msg_valid_alt_recvs' (MO_msg_valid_alt P) m;
}.

(**
  Now we just need to define the final version of [MO_msg_valid_alt_recvs],
  in which the validity predicate is set to [MO_msg_valid_alt].
*)
Definition MO_msg_valid_alt_recvs (P : Address -> Prop) (m : Message) : Prop :=
  MO_msg_valid_alt_recvs' (MO_msg_valid_alt P) m.

(**
  For some proofs to go through, we will need "bounded" versions of the
  [Send] and [Receive] parts of the alternative definition.

  By bounded, we mean that we will only look for suffixes at most as long
  as the whole list of observations of the given message (the suffix can't
  be any longer than that of course; this matters for purely technical
  reasons).
*)

Definition MO_msg_valid_alt_sends_bounded (m : Message) : Prop :=
  forall (k : nat) (suffix : list Observation) (m' : Message),
    k <= length (obs (state m)) ->
    lastn k (obs (state m)) = addObservation' (MkObservation Send m') suffix ->
      obs (state m') = suffix /\ adr (state m') = adr (state m).

Definition MO_msg_valid_alt_recvs_bounded (P : Address -> Prop) (m : Message) : Prop :=
  forall (k : nat) (suffix : list Observation) (m' : Message),
    k <= length (obs (state m)) ->
    lastn k (obs (state m)) = addObservation' (MkObservation Receive m') suffix ->
      MO_msg_valid_alt P m'.

(** The bounded versions are equivalent to the original ones. *)

Lemma MO_msg_valid_alt_sends_shorten :
  forall (m : Message),
    MO_msg_valid_alt_sends m <-> MO_msg_valid_alt_sends_bounded m.
Proof.
  split.
  - unfold MO_msg_valid_alt_sends, MO_msg_valid_alt_sends_bounded.
    by intros Hs k suffix m' _ Hlast; eapply Hs.
  - unfold MO_msg_valid_alt_sends, MO_msg_valid_alt_sends_bounded.
    intros Hs k suffix m' Hlast.
    destruct (decide (k <= length (obs (state m)))).
    + by eapply Hs.
    + apply (Hs (length (obs (state m)))); [lia |].
      by rewrite lastn_ge in *; [| lia | lia].
Qed.

Lemma MO_msg_valid_alt_recvs_shorten :
  forall (P : Address -> Prop) (m : Message),
    MO_msg_valid_alt_recvs P m <-> MO_msg_valid_alt_recvs_bounded P m.
Proof.
  split.
  - unfold MO_msg_valid_alt_recvs, MO_msg_valid_alt_recvs', MO_msg_valid_alt_recvs_bounded.
    by intros Hr k suffix m' _ Hlast; eapply Hr.
  - unfold MO_msg_valid_alt_recvs, MO_msg_valid_alt_recvs', MO_msg_valid_alt_recvs_bounded.
    intros Hr k suffix m' Hlast.
    destruct (decide (k <= length (obs (state m)))).
    + by eapply Hr.
    + apply (Hr (length (obs (state m))) suffix); [lia |].
      by rewrite lastn_ge in *; [| lia | lia].
Qed.

(**
  Now we need a collection of lemmas that tell us what happens when we extend
  a message with a new observation of a sent message. We need to do this
  separately for both the "sends" and the "recvs" parts of the alternative
  definition.
*)

Lemma MO_msg_valid_alt_sends_Send :
  forall m : Message,
    MO_msg_valid_alt_sends m -> MO_msg_valid_alt_sends (m <*> MkObservation Send m).
Proof.
  unfold MO_msg_valid_alt_sends; cbn; unfold addObservation'.
  intros m Hvalid k suffix m' Hlast.
  rewrite lastn_cons in Hlast; case_decide.
  - by inversion Hlast.
  - by eapply Hvalid.
Qed.

Lemma MO_msg_valid_alt_recvs_Send :
  forall (P : Address -> Prop) (m : Message),
    MO_msg_valid_alt_recvs P m -> MO_msg_valid_alt_recvs P (m <*> MkObservation Send m).
Proof.
  unfold MO_msg_valid_alt_recvs, MO_msg_valid_alt_recvs'; cbn; unfold addObservation'.
  intros P m Hvalid k suffix m' Hlast.
  rewrite lastn_cons in Hlast; case_decide.
  - by inversion Hlast.
  - by eapply Hvalid.
Qed.

(**
  When we put the above lemmas together, we get a lemma for [MO_msg_valid_alt]
  which corresponds to one of the constructors of [MO_msg_valid].
*)

Lemma MO_msg_valid_alt_Send :
  forall (P : Address -> Prop) (m : Message),
    MO_msg_valid_alt P m -> MO_msg_valid_alt P (m <*> MkObservation Send m).
Proof.
  intros P m [Hs Hr]; constructor; cbn; [done | |].
  - by apply MO_msg_valid_alt_sends_Send.
  - by apply MO_msg_valid_alt_recvs_Send.
Qed.

(** We will also need the converses of all these lemmas. *)

Lemma MO_msg_valid_alt_sends_Send_conv :
  forall m : Message,
    MO_msg_valid_alt_sends (m <*> MkObservation Send m) -> MO_msg_valid_alt_sends m.
Proof.
  intros m.
  rewrite (MO_msg_valid_alt_sends_shorten m).
  unfold MO_msg_valid_alt_sends; cbn; unfold addObservation'.
  intros Hv k suffix m' Hlen Hlast.
  destruct (decide (1 + length (obs (state m)) <= k)); [lia |].
  apply Hv with k. rewrite lastn_cons. by case_decide; [lia |].
Qed.

Lemma MO_msg_valid_alt_recvs_Send_conv :
  forall (P : Address -> Prop) (m : Message),
    MO_msg_valid_alt_recvs P (m <*> MkObservation Send m) -> MO_msg_valid_alt_recvs P m.
Proof.
  intros P m.
  rewrite (MO_msg_valid_alt_recvs_shorten P m).
  unfold MO_msg_valid_alt_recvs, MO_msg_valid_alt_recvs'; cbn; unfold addObservation'.
  intros Hv k suffix m' Hlen Hlast.
  destruct (decide (1 + length (obs (state m)) <= k)); [lia |].
  apply (Hv k suffix). rewrite lastn_cons.
  by case_decide; [lia |].
Qed.

Lemma MO_msg_valid_alt_Send_conv :
  forall (P : Address -> Prop) (m : Message),
    MO_msg_valid_alt P (m <*> MkObservation Send m) -> MO_msg_valid_alt P m.
Proof.
  intros P m [Hvs Hvr]; split; [done | |].
  - by apply MO_msg_valid_alt_sends_Send_conv.
  - by apply MO_msg_valid_alt_recvs_Send_conv.
Qed.

(**
  We need another collection of lemmas, but this time for the case when a new
  observation was a received message.
*)

Lemma MO_msg_valid_alt_sends_Receive :
  forall m mr : Message,
    MO_msg_valid_alt_sends m ->
      MO_msg_valid_alt_sends (m <*> MkObservation Receive mr).
Proof.
  unfold MO_msg_valid_alt_sends; cbn; unfold addObservation'.
  intros m mr Hm k suffix m' Hlast.
  rewrite lastn_cons in Hlast; case_decide.
  - by inversion Hlast.
  - by apply Hm with k.
Qed.

Lemma MO_msg_valid_alt_recvs_Receive :
  forall (P : Address -> Prop) (m mr : Message),
    MO_msg_valid_alt_recvs P m -> MO_msg_valid_alt P mr ->
      MO_msg_valid_alt_recvs P (m <*> MkObservation Receive mr).
Proof.
  unfold MO_msg_valid_alt_recvs, MO_msg_valid_alt_recvs'; cbn; unfold addObservation'.
  intros P m mr Hm Hmr k suffix m' Hlast.
  rewrite lastn_cons in Hlast; case_decide.
  - by inversion Hlast; subst; clear Hlast.
  - by apply (Hm k suffix).
Qed.

Lemma MO_msg_valid_alt_Receive :
  forall (P : Address -> Prop) (m mr : Message),
    MO_msg_valid_alt P m -> MO_msg_valid_alt P mr ->
      MO_msg_valid_alt P (m <*> MkObservation Receive mr).
Proof.
  intros P m mr [Hs Hr] Hmr; split; cbn; [done | |].
  - by apply MO_msg_valid_alt_sends_Receive.
  - by apply MO_msg_valid_alt_recvs_Receive.
Qed.

(** We need the converses of these lemmas too. *)

Lemma MO_msg_valid_alt_sends_Receive_conv :
  forall m mr : Message,
    MO_msg_valid_alt_sends (m <*> MkObservation Receive mr) ->
      MO_msg_valid_alt_sends m.
Proof.
  intros m mr.
  rewrite (MO_msg_valid_alt_sends_shorten m).
  unfold MO_msg_valid_alt_sends; cbn; unfold addObservation'.
  intros Hv k suffix m' Hlen Hlast.
  destruct (decide (1 + length (obs (state m)) <= k)); [lia |].
  apply Hv with k.
  by rewrite lastn_cons; case_decide; [lia |].
Qed.

Lemma MO_msg_valid_alt_recvs_Receive_conv :
  forall (P : Address -> Prop) (m mr : Message),
    MO_msg_valid_alt_recvs P (m <*> MkObservation Receive mr) ->
      MO_msg_valid_alt_recvs P m /\ MO_msg_valid_alt P mr.
Proof.
  intros P m mr.
  rewrite (MO_msg_valid_alt_recvs_shorten P m).
  unfold MO_msg_valid_alt_recvs, MO_msg_valid_alt_recvs'; cbn; unfold addObservation'.
  intros Hv; split.
  - intros k suffix m' Hlen Hlast.
    destruct (decide (1 + length (obs (state m)) <= k)); [lia |].
    apply (Hv k suffix). rewrite lastn_cons.
    by case_decide; [lia |].
  - apply (Hv (1 + length (obs (state m))) (obs (state m))).
    by rewrite lastn_ge; cbn; [| lia].
Qed.

Lemma MO_msg_valid_alt_Receive_conv :
  forall (P : Address -> Prop) (m mr : Message),
    MO_msg_valid_alt P (m <*> MkObservation Receive mr) ->
      MO_msg_valid_alt P m /\ MO_msg_valid_alt P mr.
Proof.
  intros P m mr [HP Hms Hmr]; cbn in *.
  apply MO_msg_valid_alt_sends_Receive_conv in Hms.
  apply MO_msg_valid_alt_recvs_Receive_conv in Hmr as [].
  by split; [constructor |].
Qed.

(**
  Last but not least, we need an inversion lemma which tells us that,
  if from the state of a message <<m1>> we sent the message <<m2>>, then
  <<m1>> must be equal to <<m2>>.
*)
Lemma MO_msg_valid_alt_Send_inv :
  forall (P : Address -> Prop) (m1 m2 : Message),
    MO_msg_valid_alt P (m1 <*> MkObservation Send m2) -> m1 = m2.
Proof.
  intros P m1 m2 [_ Hvs _].
  unfold MO_msg_valid_alt_sends in Hvs; cbn in *; unfold addObservation' in Hvs.
  specialize (Hvs (1 + length (obs (state m1))) (obs (state m1)) m2).
  rewrite lastn_cons in Hvs; case_decide; [| lia].
  destruct (Hvs eq_refl) as [].
  by destruct m1 as [[]], m2 as [[]]; cbn in *; congruence.
Qed.

(**
  We now have, by previous lemmas, that [MO_msg_valid] and [MO_msg_valid_alt]
  are equivalent. The proof of the equivalence lemma is structured as follows:

  - the [MO_msg_valid] to [MO_msg_valid_alt] direction is by induction on
    [MO_msg_valid] for <<P>> and <<m>>
  - the [MO_msg_valid_alt] to [MO_msg_valid] direction is by well-founded
    induction on the size of the message <<m>>
*)
Lemma MO_msg_valid__MO_msg_valid_alt :
  forall (P : Address -> Prop) (m : Message),
    MO_msg_valid P m <-> MO_msg_valid_alt P m.
Proof.
  split; [| revert m].
  - induction 1 as [m Hobs | m Hm IH | m mr Hm IHm Hmr IHmr].
    + by constructor; [done | |]
      ; intros k suffix m' Hlast
      ; rewrite Hobs, lastn_nil in Hlast; inversion Hlast.
    + by apply MO_msg_valid_alt_Send.
    + by apply MO_msg_valid_alt_Receive.
  - assert (Hwf := well_founded_lt_compat _ (fun m => @sizeMessage Address m)
      (fun m1 m2 => sizeMessage m1 < sizeMessage m2) (fun _ _ H => H)).
    apply (@well_founded_induction _ (fun m1 m2 => sizeMessage m1 < sizeMessage m2) Hwf
      (fun m => MO_msg_valid_alt P m -> MO_msg_valid P m)).
    intros [[[| [[] m'] obs'] adr']] IH Hvalid.
    + by constructor; [| inversion Hvalid].
    + change (MkMessage _) with (MkMessage (MkState obs' adr') <*> MkObservation Receive m') in *.
      apply MO_msg_valid_alt_Receive_conv in Hvalid as [].
      by constructor 3; (apply IH; [unfold sizeMessage; cbn; lia |]).
    + change (MkMessage _) with (MkMessage (MkState obs' adr') <*> MkObservation Send m') in *.
      replace (MkMessage (MkState obs' adr')) with m' in *
        by (apply MO_msg_valid_alt_Send_inv in Hvalid; done).
      apply MO_msg_valid_alt_Send_conv in Hvalid.
      by constructor 2; apply IH; [unfold sizeMessage; cbn; lia |].
Qed.

End sec_alternative_definition_of_validity.

Inductive MOComponentValid (P : Address -> Prop) : Label -> State -> option Message -> Prop :=
| MOCV_Receive :
    forall (s : State) (m : Message),
      MO_msg_valid P m -> MOComponentValid P Receive s (Some m)
| MOCV_Send :
    forall s : State,
      MOComponentValid P Send s None.

Ltac invert_MOComponentValid :=
repeat match goal with
| H : MOComponentValid _ Receive _ None  |- _ => inversion H; subst; clear H
| H : MOComponentValid _ Send _ (Some _) |- _ => inversion H; subst; clear H
end.

Definition MOComponentMachine (P : Address -> Prop) (i : Address) : VLSMMachine ELMOComponentType :=
{|
  initial_state_prop := UMOComponent_initial_state_prop i;
  initial_message_prop := const False;
  s0 := Inhabited_UMOComponent_initial_state_type i;
  transition := fun l '(st, om) => UMOComponent_transition l st om;
  valid := fun l '(st, om) => MOComponentValid P l st om;
|}.

Definition MOComponent (P : Address -> Prop) (i : Address) : VLSM Message :=
{|
  vtype := ELMOComponentType;
  vmachine := MOComponentMachine P i;
|}.

Section sec_MOComponent_lemmas.

(** ** Component lemmas

  We will use the notation [Mi] for a [MOComponent] of address [i].

  We will use [RMi] to denote the corresponding pre-loaded VLSM, which is
  used to model reachability.

  There is a VLSM inclusion from [Mi] to [RMi].
*)

Context
  {i : Address}
  {P : Address -> Prop}
  (Mi : VLSM Message := MOComponent P i)
  (RMi : VLSM Message := pre_loaded_with_all_messages_vlsm Mi).

(** The VLSM [Mi] embeds into [RMi]. *)
Lemma VLSM_incl_Mi_RMi :
  VLSM_incl_part (vmachine Mi) (vmachine RMi).
Proof.
  by apply vlsm_incl_pre_loaded_with_all_messages_vlsm.
Qed.

(** The initial state of [RMi] is unique. *)
Lemma vs0_uniqueness :
  forall is : State,
    UMOComponent_initial_state_prop i is ->
      is = ``(vs0 RMi).
Proof.
  by intros []; inversion 1; cbv in *; subst.
Qed.

(** *** Properties of transitions and traces *)

(** In a valid state <<s>>, we can send a message containing this state. *)
Lemma input_valid_transition_Send_RMi :
  forall s : State,
    valid_state_prop RMi s ->
      input_valid_transition RMi Send
        (s, None)
        (s <+> MkObservation Send (MkMessage s), Some (MkMessage s)).
Proof.
  intros s Hvsp.
  red; cbn; split_and!; [done | | | done].
  - by exists (MkState [] i); constructor.
  - by do 2 constructor.
Qed.

(** In a valid state <<s>>, we can receive any valid message. *)
Lemma input_valid_transition_Receive_RMi :
  forall (s : State) (m : Message),
    valid_state_prop RMi s -> MO_msg_valid P m ->
      input_valid_transition RMi Receive
        (s, Some m)
        (s <+> MkObservation Receive m, None).
Proof.
  intros s m Hvsp Hvalid.
  red; cbn; split_and!; [done | | | done].
  - by exists (MkState [] i); constructor.
  - by constructor.
Qed.

(** If a message <<m>> is valid, its [state] is reachable. *)
Lemma valid_state_prop_MO_msg_valid_RMi :
  forall m : Message,
    MO_msg_valid P m -> adr (state m) = i ->
      valid_state_prop RMi (state m).
Proof.
  induction 1 as [m Hobs | m Hm IH | m mr Hm IHm Hmr IHmr]; cbn; intros Hadr.
  - by exists None; constructor.
  - apply (@input_valid_transition_destination _ RMi Send (state m) _ None (Some m)).
    destruct m as [s]; cbn in *.
    by apply input_valid_transition_Send_RMi, IH.
  - apply (@input_valid_transition_destination _ RMi Receive (state m) _ (Some mr) None).
    destruct m as [s]; cbn in *.
    by apply input_valid_transition_Receive_RMi; itauto.
Qed.

(** Valid transitions and valid traces lead to bigger states. *)

Lemma MOComponent_valid_transition_size :
  forall (s1 s2 : State) (iom oom : option Message) (lbl : Label),
    MOComponentValid P lbl s1 iom ->
    UMOComponent_transition lbl s1 iom = (s2, oom) ->
      sizeState s1 < sizeState s2.
Proof.
  by intros [] s2 [im |] oom []; do 2 inversion_clear 1; cbn; lia.
Qed.

Lemma input_valid_transition_size_RMi :
  forall (s1 s2 : State) (iom oom : option Message) (lbl : Label),
    input_valid_transition RMi lbl (s1, iom) (s2, oom) ->
      sizeState s1 < sizeState s2.
Proof.
  by intros s1 s2 iom oom lbl [(_ & _ & ?) Ht]; cbn in *
  ; eapply MOComponent_valid_transition_size.
Qed.

Lemma finite_valid_trace_from_to_size_RMi :
  forall (s1 s2 : State) (tr : list transition_item),
    finite_valid_trace_from_to RMi s1 s2 tr ->
      s1 = s2 /\ tr = []
        \/
      sizeState s1 < sizeState s2.
Proof.
  induction 1; [by left |].
  assert (sizeState s' < sizeState s)
      by (eapply input_valid_transition_size_RMi; done).
  by destruct IHfinite_valid_trace_from_to; [itauto congruence | itauto lia].
Qed.

(**
  The final state of a valid transition determines the label, initial state,
  input message and output message.
*)
Lemma input_valid_transition_deterministic_conv_RMi :
  forall (s1 s2 f : State) (iom1 iom2 oom1 oom2 : option Message) (lbl1 lbl2 : Label),
    input_valid_transition RMi lbl1 (s1, iom1) (f, oom1) ->
    input_valid_transition RMi lbl2 (s2, iom2) (f, oom2) ->
      lbl1 = lbl2 /\ s1 = s2 /\ iom1 = iom2 /\ oom1 = oom2.
Proof.
  intros s1 s2 f iom1 iom2 oom1 oom2 lbl1 lbl2 Hivt1 Hivt2
  ; inversion Hivt1 as [(_ & _ & Hvalid1) Ht1]; subst
  ; inversion Hivt2 as [(_ & _ & Hvalid2) Ht2]; subst.
  destruct lbl1, lbl2, iom1, iom2; cbn in *
  ; inversion Ht1; subst; clear Ht1
  ; inversion Ht2; subst; clear Ht2
  ; inversion Hvalid1; inversion Hvalid2; invert_MOComponentValid; auto.
  by destruct s1, s2; cbn in *; subst; itauto.
Qed.

(** Trace segments between any two states are unique. *)
Lemma finite_valid_trace_from_to_unique_RMi :
  forall (s1 s2 : State) (tr1 tr2 : list transition_item),
    finite_valid_trace_from_to RMi s1 s2 tr1 ->
    finite_valid_trace_from_to RMi s1 s2 tr2 ->
      tr1 = tr2.
Proof.
  intros s1 s2 tr1 tr2 Hfvt1 Hfvt2; revert tr2 Hfvt2.
  induction Hfvt1 using finite_valid_trace_from_to_rev_ind; intros.
  - by apply finite_valid_trace_from_to_size_RMi in Hfvt2; itauto (congruence + lia).
  - destruct Hfvt2 using finite_valid_trace_from_to_rev_ind; [| clear IHHfvt2].
    + apply finite_valid_trace_from_to_size_RMi in Hfvt1.
      apply input_valid_transition_size_RMi in Ht.
      by decompose [and or] Hfvt1; subst; clear Hfvt1; lia.
    + assert (l = l0 /\ s = s0 /\ iom = iom0 /\ oom = oom0)
          by (eapply input_valid_transition_deterministic_conv_RMi; done).
      decompose [and] H; subst; clear H.
      by f_equal; apply IHHfvt1.
Qed.

(** Traces between any two states are unique. *)

Lemma finite_valid_trace_init_to_unique_RMi :
  forall (s1 s2 s : State) (tr1 tr2 : list transition_item),
    finite_valid_trace_init_to RMi s1 s tr1 ->
    finite_valid_trace_init_to RMi s2 s tr2 ->
      tr1 = tr2.
Proof.
  intros [] [] s tr1 tr2 [Ht1 []] [Ht2 []]; cbn in *; subst.
  by eapply finite_valid_trace_from_to_unique_RMi.
Qed.

(** All above properties also hold for [Mi]. *)

Lemma input_valid_transition_Send_Mi :
  forall s : State,
    valid_state_prop Mi s ->
      input_valid_transition Mi Send
        (s, None)
        (s <+> MkObservation Send (MkMessage s), Some (MkMessage s)).
Proof.
  intros s Hvsp.
  red; cbn; split_and!; [done | | | done].
  - by exists (MkState [] i); constructor.
  - by do 2 constructor.
Qed.

Lemma input_valid_transition_size_Mi :
  forall (s1 s2 : State) (iom oom : option Message) (lbl : Label),
    input_valid_transition Mi lbl (s1, iom) (s2, oom) ->
      sizeState s1 < sizeState s2.
Proof.
  intros s1 s2 iom oom lbl Hivt.
  eapply input_valid_transition_size_RMi.
  by apply (@VLSM_incl_input_valid_transition _ (vtype Mi) (vmachine Mi) (vmachine RMi))
  ; eauto using VLSM_incl_Mi_RMi.
Qed.

Lemma finite_valid_trace_from_to_size_Mi :
  forall (s1 s2 : State) (tr : list transition_item),
    finite_valid_trace_from_to Mi s1 s2 tr ->
      s1 = s2 /\ tr = []
        \/
      sizeState s1 < sizeState s2.
Proof.
  intros s1 s2 tr Hfvt.
  eapply finite_valid_trace_from_to_size_RMi.
  by apply (@VLSM_incl_finite_valid_trace_from_to _ (vtype Mi) (vmachine Mi) (vmachine RMi))
  ; eauto using VLSM_incl_Mi_RMi.
Qed.

Lemma input_valid_transition_deterministic_conv_Mi :
  forall (s1 s2 f : State) (iom1 iom2 oom1 oom2 : option Message) (lbl1 lbl2 : Label),
    input_valid_transition Mi lbl1 (s1, iom1) (f, oom1) ->
    input_valid_transition Mi lbl2 (s2, iom2) (f, oom2) ->
      lbl1 = lbl2 /\ s1 = s2 /\ iom1 = iom2 /\ oom1 = oom2.
Proof.
  intros s1 s2 f iom1 iom2 oom1 oom2 lbl1 lbl2 Hivt1 Hivt2.
  by eapply input_valid_transition_deterministic_conv_RMi
  ; apply (@VLSM_incl_input_valid_transition _ (vtype Mi) (vmachine Mi) (vmachine RMi))
  ; eauto using VLSM_incl_Mi_RMi.
Qed.

Lemma finite_valid_trace_from_to_unique_Mi :
  forall (s1 s2 : State) (l1 l2 : list transition_item),
    finite_valid_trace_from_to Mi s1 s2 l1 ->
    finite_valid_trace_from_to Mi s1 s2 l2 ->
      l1 = l2.
Proof.
  by intros s1 s2 l1 l2 Hfvt1 Hfvt2
  ; eapply finite_valid_trace_from_to_unique_RMi
  ; apply VLSM_incl_finite_valid_trace_from_to
  ; eauto using VLSM_incl_Mi_RMi.
Qed.

Lemma finite_valid_trace_init_to_unique_Mi :
  forall (s f : State) (l1 l2 : list transition_item),
    finite_valid_trace_init_to Mi s f l1 ->
    finite_valid_trace_init_to Mi s f l2 ->
      l1 = l2.
Proof.
  by intros s f l1 l2 Hfvit1 Hfvit2
  ; eapply finite_valid_trace_init_to_unique_RMi
  ; apply VLSM_incl_finite_valid_trace_init_to
  ; eauto using VLSM_incl_Mi_RMi.
Qed.

(** *** Extracting a trace from a state *)

(** If a valid trace leads to state s, the trace extracted from s also leads to s. *)

Lemma finite_valid_trace_init_to_state2trace_RMi :
  forall (is s : State) (tr : list transition_item),
    finite_valid_trace_init_to RMi is s tr ->
      finite_valid_trace_init_to RMi is s (state2trace s).
Proof.
  intros is s tr [Hfv Hinit]; cbn in *; revert Hinit.
  induction Hfv using finite_valid_trace_from_to_rev_ind; intros.
  - inversion Hinit; clear Hinit.
    destruct si; cbn in *; subst; cbn.
    repeat constructor. exists None.
    by repeat constructor.
  - specialize (IHHfv Hinit).
    destruct Ht as [Hvalid Ht]; cbn in Ht.
    destruct s as [obs adr], l, iom as [im |]
    ; inversion Ht; subst; clear Ht; cbn in *
    ; cycle 1; [done | done | |].
    + constructor; [| done].
      by eapply extend_right_finite_trace_from_to; [apply IHHfv |]; auto.
    + constructor; [| done].
      by eapply extend_right_finite_trace_from_to; [apply IHHfv |]; auto.
Qed.

(** The trace extracted from the final state of another trace is equal to that trace. *)

Lemma finite_valid_trace_init_to_state2trace_RMi_inv :
  forall (is s : State) (tr : list transition_item),
    finite_valid_trace_init_to RMi is s tr ->
      state2trace s = tr.
Proof.
  intros is s tr Hfvti.
  assert (Hfvti' : finite_valid_trace_init_to RMi is s (state2trace s))
      by (eapply finite_valid_trace_init_to_state2trace_RMi; done).
  by eapply finite_valid_trace_init_to_unique_RMi.
Qed.

(** The trace extracted from a ram-state <<s>> leads to <<s>>. *)

Lemma finite_valid_trace_init_to_state2trace_RMi' :
  forall (s : State),
    valid_state_prop RMi s ->
      finite_valid_trace_init_to RMi (``(vs0 RMi)) s (state2trace s).
Proof.
  intros s Hs.
  apply valid_state_has_trace in Hs as (is & tr & Htr).
  apply finite_valid_trace_init_to_state2trace_RMi_inv in Htr as Heqtr; subst.
  replace (``(vs0 RMi)) with is; [done |].
  by apply vs0_uniqueness, Htr.
Qed.

Lemma valid_state_contains_unique_valid_trace_RMi :
  forall s : State,
    valid_state_prop RMi s ->
      exists tr : list transition_item,
        finite_valid_trace_init_to RMi (``(vs0 RMi)) s tr
          /\
        forall tr' : list transition_item,
          finite_valid_trace_init_to RMi (``(vs0 RMi)) s tr' -> tr' = tr.
Proof.
  intros s Hvsp.
  exists (state2trace s); split.
  - by eapply finite_valid_trace_init_to_state2trace_RMi'.
  - intros tr' Hfvt. symmetry.
    by eapply finite_valid_trace_init_to_state2trace_RMi_inv.
Qed.

(** *** State and message suffix relations *)

Lemma state_suffix_totally_orders_valid_sent_messages :
  forall (m m1 m2 : Message) (obs1 obs2 obs3 : list Observation),
    m = MkMessage (MkState [] i) <**>
      obs1 <*> MkObservation Send m1 <**> obs2 <*> MkObservation Send m2 <**> obs3 ->
    MO_msg_valid_alt_sends m ->
      state_suffix (state m1) (state m2) /\ state_suffix (state m2) (state m).
Proof.
  intros m m1 m2 obs1 obs2 obs3 Heq Hvalid.
  red in Hvalid.
  assert (H2 :
    obs (state m2) =
    obs (state (MkMessage (MkState [] i) <**> obs1 <*> MkObservation Send m1 <**> obs2))
    /\ adr (state m2) = i).
  {
    replace i with (adr (state m)) at 2 by (subst; done).
    apply (Hvalid (1 + length
      (obs (state (MkMessage (MkState [] i) <**> obs1 <*> MkObservation Send m1 <**> obs2))))).
    rewrite Heq; simpl.
    rewrite lastn_app_le by (cbn; lia).
    by rewrite lastn_ge; [| cbn; lia].
  }
  assert (H1 :
    obs (state m1) = obs (state (MkMessage (MkState [] i) <**> obs1))
    /\ adr (state m1) = i).
  {
    replace i with (adr (state m)) at 2 by (subst; done).
    apply (Hvalid (1 + length (obs (state (MkMessage (MkState [] i) <**> obs1))))).
    rewrite Heq; simpl.
    unfold addObservation'.
    rewrite <- (app_cons (MkObservation Send m2)),
            <- (app_cons (MkObservation Send m1)), 2!app_assoc.
    rewrite lastn_app_le by (cbn; lia).
    by rewrite lastn_ge; [| cbn; lia].
  }
  destruct H1 as [H11 H12], H2 as [H21 H22].
  split.
  - constructor; [by congruence |].
    rewrite H11, H21; cbn.
    split.
    + by apply suffix_app_r, suffix_cons_r.
    + intros []. apply (f_equal length) in H.
      rewrite !app_length in H; cbn in H; rewrite app_length in H; cbn in H.
      by lia.
  - constructor; [by subst |].
    rewrite H21, Heq; cbn.
    split.
    + by apply suffix_app_r, suffix_cons_r.
    + intros []. apply (f_equal length) in H.
      unfold addObservation' in H.
      by rewrite <- (app_cons (MkObservation _ m1)),
                 <- (app_cons (MkObservation _ m2)), !app_length in H
      ; cbn in H; lia.
Qed.

Definition MO_msg_suffix (m : Message) : Prop :=
  forall k1 k2 : nat, k1 < k2 ->
  forall ob1 ob2 : Observation,
    obs (state m) !! k1 = Some ob1 -> label ob1 = Send ->
    obs (state m) !! k2 = Some ob2 -> label ob2 = Send ->
      state_suffix (state (message ob2)) (state (message ob1)).

Lemma state_suffix_totally_orders_valid_sent_messages' :
  forall m : Message, MO_msg_valid_alt_sends m -> MO_msg_suffix m.
Proof.
  unfold MO_msg_valid_alt_sends, MO_msg_suffix.
  intros m H k1 k2 Hlt ob1 ob2 Heq1 Hlbl1 Heq2 Hlbl2.
  remember (length (obs (state m))) as K.
  destruct (H (K - k1) (lastn (K - S k1) (obs (state m))) (message ob1)) as [Hobs1 Hadr1]
  ; [by destruct ob1; cbn in *; subst; apply lastn_length_cons |].
  destruct (H (K - k2) (lastn (K - S k2) (obs (state m))) (message ob2)) as [Hobs2 Hadr2]
  ; [by destruct ob2; cbn in *; subst; apply lastn_length_cons |].
  constructor; [by congruence |].
  constructor; rewrite Hobs1, Hobs2.
  - by apply suffix_lastn; lia.
  - intros Hsuf. apply suffix_length in Hsuf.
    rewrite 2!length_lastn in Hsuf.
    apply lookup_lt_Some in Heq1, Heq2.
    unfold Observation in *.
    by destruct (Nat.min_spec (K - S k1) (length (obs (state m)))) as [[H11 H12] | [H11 H12]],
             (Nat.min_spec (K - S k2) (length (obs (state m)))) as [[H21 H22] | [H21 H22]]
    ; rewrite ?H12, ?H22 in Hsuf; lia.
Qed.

End sec_MOComponent_lemmas.

Section sec_MOProtocol.

Context
  (index : Type)
  `{finite.Finite index}
  (idx : index -> Address)
  `{!Inj (=) (=) idx}
  (P : Address -> Prop)
  (P' := fun adr => P adr /\ exists i : index, idx i = adr)
  (M : index -> VLSM Message := fun i => MOComponent P' (idx i))
  (RM : index -> VLSM Message := fun i => pre_loaded_with_all_messages_vlsm (M i)).

(** ** Protocol

  The MO protocol is a free composition of finitely many MO components (each
  with the same predicate <<P>>.

  To talk about reachable states in the MO protocol, we will use [RMO],
  which is MO preloaded with all messages.
*)

Definition MO : VLSM Message := free_composite_vlsm M.
Definition RMO : VLSM Message := pre_loaded_with_all_messages_vlsm MO.

(** We set up aliases for some functions operating on free VLSM composition. *)

Definition MO_state : Type := composite_state M.
Definition MO_label : Type := composite_label M.
Definition MO_transition_item : Type := composite_transition_item M.

(** We can lift labels, states and traces from an MO component to the MO protocol. *)

Definition lift_to_MO_label
  (i : index) (li : vlabel (M i)) : MO_label :=
    lift_to_composite_label M i li.

Definition lift_to_MO_state
  (us : MO_state) (i : index) (si : vstate (M i)) : MO_state :=
    lift_to_composite_state M us i si.

Definition lift_to_MO_trace
  (us : MO_state) (i : index) (tr : list (vtransition_item (M i)))
  : list MO_transition_item :=
    pre_VLSM_embedding_finite_trace_project
      _ _ (lift_to_MO_label i) (lift_to_MO_state us i) tr.

#[local] Hint Rewrite @state_update_twice : state_update.

#[local] Hint Unfold lift_to_MO_label : state_update.
#[local] Hint Unfold lift_to_MO_state : state_update.
#[local] Hint Unfold lift_to_MO_trace : state_update.

(**
  We can also lift properties from MO components to the MO protocol, among
  them [valid_state_prop], [valid_message_prop], [input_valid_transition]
  and the various kinds of traces.
*)

Lemma lift_to_MO :
  forall (us : MO_state) (Hus : valid_state_prop MO us) (i : index),
    VLSM_weak_embedding (M i) MO (lift_to_MO_label i) (lift_to_MO_state us i).
Proof. by intros; apply lift_to_free_weak_embedding. Qed.

Lemma lift_to_MO_valid_state_prop :
  forall (i : index) (s : State) (us : MO_state),
    valid_state_prop MO us -> valid_state_prop (M i) s ->
      valid_state_prop MO (lift_to_MO_state us i s).
Proof.
  intros is s us Hvsp.
  by eapply VLSM_weak_embedding_valid_state, lift_to_MO.
Qed.

Lemma lift_to_MO_valid_message_prop :
  forall (i : index) (om : option Message),
    option_valid_message_prop (M i) om ->
      option_valid_message_prop MO om.
Proof.
  intros i [] Hovmp; cycle 1.
  - by exists (``(vs0 MO)); constructor.
  - eapply VLSM_weak_embedding_valid_message.
    + by apply (lift_to_MO (``(vs0 MO))); exists None; constructor.
    + by inversion 1.
    + by apply Hovmp.
Qed.

Lemma lift_to_MO_input_valid_transition :
  forall (i : index) (lbl : Label) (s1 s2 : State) (iom oom : option Message) (us : MO_state),
    valid_state_prop MO us ->
    input_valid_transition (M i) lbl (s1, iom) (s2, oom) ->
      input_valid_transition MO
        (lift_to_MO_label i lbl)
        (lift_to_MO_state us i s1, iom)
        (lift_to_MO_state us i s2, oom).
Proof.
  intros i lbl s1 s2 iom oom us Hivt.
  by apply @VLSM_weak_embedding_input_valid_transition, lift_to_MO.
Qed.

Lemma lift_to_MO_finite_valid_trace_from_to :
  forall (i : index) (s1 s2 : State) (tr : list (vtransition_item (M i))) (us : MO_state),
    valid_state_prop MO us ->
    finite_valid_trace_from_to (M i) s1 s2 tr ->
      finite_valid_trace_from_to
        MO (lift_to_MO_state us i s1) (lift_to_MO_state us i s2) (lift_to_MO_trace us i tr).
Proof.
  intros i s1 s2 tr us Hvsp Hfvt.
  by eapply (VLSM_weak_embedding_finite_valid_trace_from_to (lift_to_MO _ Hvsp i)).
Qed.

(** We could prove the same lifting lemmas for [RMO], but we won't need them. *)

Lemma lift_to_RMO
  (us : MO_state) (Hus : valid_state_prop RMO us) (i : index) :
  VLSM_weak_embedding (RM i) RMO (lift_to_MO_label i) (lift_to_MO_state us i).
Proof. by apply lift_to_preloaded_free_weak_embedding. Qed.

Lemma lift_to_RMO_valid_state_prop :
  forall (i : index) (s : State) (us : MO_state),
    valid_state_prop RMO us -> valid_state_prop (RM i) s ->
      valid_state_prop RMO (lift_to_MO_state us i s).
Proof.
  intros is s us Hvsp.
  by eapply VLSM_weak_embedding_valid_state, lift_to_RMO.
Qed.

Lemma lift_to_RMO_valid_message_prop :
  forall (i : index) (om : option Message),
    option_valid_message_prop (RM i) om ->
      option_valid_message_prop RMO om.
Proof.
  intros i [] Hovmp; cycle 1.
  - by exists (``(vs0 MO)); constructor.
  - eapply VLSM_weak_embedding_valid_message.
    + by apply (lift_to_RMO (``(vs0 MO))); exists None; constructor.
    + by inversion 1.
    + by apply Hovmp.
Qed.

Lemma lift_to_RMO_input_valid_transition :
  forall (i : index) (lbl : Label) (s1 s2 : State) (iom oom : option Message) (us : MO_state),
    valid_state_prop RMO us ->
    input_valid_transition (RM i) lbl (s1, iom) (s2, oom) ->
      input_valid_transition RMO
        (lift_to_MO_label i lbl)
        (lift_to_MO_state us i s1, iom)
        (lift_to_MO_state us i s2, oom).
Proof.
  intros i lbl s1 s2 iom oom us Hivt.
  by apply @VLSM_weak_embedding_input_valid_transition, lift_to_RMO.
Qed.

Lemma lift_to_RMO_finite_valid_trace_from_to :
  forall (i : index) (s1 s2 : State) (tr : list (vtransition_item (RM i))) (us : MO_state),
    valid_state_prop RMO us ->
    finite_valid_trace_from_to (RM i) s1 s2 tr ->
      finite_valid_trace_from_to
        RMO (lift_to_MO_state us i s1) (lift_to_MO_state us i s2) (lift_to_MO_trace us i tr).
Proof.
  intros i s1 s2 tr us Hvsp Hfvt.
  by apply (VLSM_weak_embedding_finite_valid_trace_from_to (lift_to_RMO _ Hvsp i)).
Qed.

(** *** Lifting lemmas for validating theorem *)

Lemma initial_state_prop_lift_RM_to_MO :
  forall (i : index) (s : State),
    vinitial_state_prop (RM i) s ->
      vinitial_state_prop MO (lift_to_MO_state (``(vs0 MO)) i s).
Proof.
  intros i s Hisp j; cbn.
  by destruct (decide (i = j)); subst; state_update_simpl.
Qed.

Lemma finite_valid_trace_lift_RM_to_MO :
  forall (i : index) (s : State),
    vinitial_state_prop (RM i) s ->
      finite_valid_trace_init_to MO
        (lift_to_MO_state (``(vs0 MO)) i s) (lift_to_MO_state (``(vs0 MO)) i s) [].
Proof.
  constructor; cycle 1.
  - by apply initial_state_prop_lift_RM_to_MO.
  - constructor; exists None; constructor; [| done].
    by apply initial_state_prop_lift_RM_to_MO.
Qed.

Lemma option_valid_message_prop_initial :
  forall i : index,
    option_valid_message_prop MO (Some (MkMessage (MkState [] (idx i)))).
Proof.
  intros i.
  remember (MkMessage (MkState [] (idx i))) as m.
  exists (state_update M (``(vs0 MO)) i (state m <+> MkObservation Send m)).
  by econstructor 2 with
    (s := ``(vs0 MO)) (_om := None) (_s := ``(vs0 MO)) (om := None) (l := existT i Send);
    [by repeat split; constructor.. | rewrite Heqm].
Qed.

Lemma option_valid_message_prop_addObservationToMessage_Send :
  forall m : Message,
    option_valid_message_prop MO (Some m) ->
      option_valid_message_prop MO (Some (m <*> MkObservation Send m)).
Proof.
  intros m [s' IH].
  inversion IH; subst; [by inversion Hom as [j []]; inversion x |].
  destruct l as [k []], om as [m' |];
    destruct Hv as [Hv _]; inversion Hv; subst; clear Hv;
    inversion Ht; subst; clear Ht.
  unfold addObservationToMessage; cbn; red.
  remember (s k <+> MkObservation Send (MkMessage (s k))) as sk'.
  remember (state_update M s k sk') as ss.
  assert (Heq : ss k = sk') by (subst; state_update_simpl; done).
  rewrite <- Heq in *; clear Heqsk'.
  exists (state_update M ss k (ss k <+> MkObservation Send (MkMessage (ss k)))).
  by econstructor 2 with (s := ss) (_s := ``(vs0 MO)) (om := None) (l := existT k Send);
    [| constructor | repeat split; constructor |].
Qed.

Lemma option_valid_message_prop_addObservationToMessage_Receive :
  forall m mr : Message,
    MO_msg_valid P' mr ->
    option_valid_message_prop MO (Some m) ->
    option_valid_message_prop MO (Some mr) ->
      option_valid_message_prop MO (Some (m <*> MkObservation Receive mr)).
Proof.
  intros m mr Hvalid [sm IH1] [smr IH2].
  inversion IH1; subst; [by inversion Hom as [j []]; inversion x |].
  destruct l as [k []], om as [m' |];
    destruct Hv as [Hv _]; inversion Hv; subst; clear Hv;
    inversion Ht; subst; clear Ht.
  exists (state_update M s k (s k <+> MkObservation Receive mr <+>
    MkObservation Send (MkMessage (s k <+> MkObservation Receive mr)))).
  econstructor 2 with
    (s := state_update M s k (s k <+> MkObservation Receive mr)) (_om := None)
    (_s := ``(vs0 MO)) (om := None) (l := existT k Send); cycle 1.
  - by constructor.
  - by repeat split; constructor.
  - by cbn; state_update_simpl.
  - by econstructor 2 with (s := s) (om := Some mr) (l := existT k Receive);
      [| | repeat split; constructor |].
Qed.

Lemma option_valid_message_prop_MO_msg_valid :
  forall m : Message,
    MO_msg_valid P' m -> option_valid_message_prop MO (Some m).
Proof.
  induction 1.
  - destruct H1 as (_ & i & Heq).
    replace m with (MkMessage (MkState [] (idx i))) by (apply eq_Message; done).
    by apply option_valid_message_prop_initial.
  - by apply option_valid_message_prop_addObservationToMessage_Send.
  - by apply option_valid_message_prop_addObservationToMessage_Receive.
Qed.

Lemma lift_to_MO_finite_valid_trace_init_to :
  forall (i : index) (s1 s2 : State) (tr : list (vtransition_item (M i))),
    finite_valid_trace_init_to (RM i) s1 s2 tr ->
      finite_valid_trace_init_to MO (lift_to_MO_state (``(vs0 MO)) i s1)
        (lift_to_MO_state (``(vs0 MO)) i s2) (lift_to_MO_trace (``(vs0 MO)) i tr).
Proof.
  intros i s1 s2 tr [Hfvt Hisp].
  induction Hfvt using finite_valid_trace_from_to_rev_ind; cbn;
    [by apply finite_valid_trace_lift_RM_to_MO |].
  constructor; [| by apply initial_state_prop_lift_RM_to_MO].
  unfold lift_to_MO_trace, pre_VLSM_embedding_finite_trace_project.
  rewrite map_app.
  eapply finite_valid_trace_from_to_app; cbn; [by apply IHHfvt |].
  apply valid_trace_add_last; [| done].
  apply first_transition_valid; cbn.
  destruct Ht as [(Hvsp & _ & Hvalid) Ht], l, iom as [im |]; cbn in *;
    inversion Hvalid; subst; clear Hvalid;
    inversion Ht; subst; cbn in *; clear Ht; cycle 1.
  - repeat split.
    + by eapply finite_valid_trace_from_to_last_pstate, IHHfvt.
    + by apply option_valid_message_None.
    + by constructor.
    + by cbn; state_update_simpl.
  - repeat split.
    + by eapply finite_valid_trace_from_to_last_pstate, IHHfvt.
    + by apply option_valid_message_prop_MO_msg_valid.
    + by constructor.
    + by cbn; state_update_simpl.
Qed.

Lemma lift_RM_to_MO :
  forall i : index,
    VLSM_embedding (RM i) MO (lift_to_MO_label i) (lift_to_MO_state (``(vs0 MO)) i).
Proof.
  constructor; intros.
  by eapply valid_trace_forget_last, lift_to_MO_finite_valid_trace_init_to,
    valid_trace_add_default_last.
Qed.

(**
  Every state in a MO component gives rise to a unique trace leading to this
  state, which we can then lift to the MO protocol.
*)
Definition MOComponent_state2trace
  (s : MO_state) (i : index) : list MO_transition_item :=
    lift_to_MO_trace s i (state2trace (s i)).

(**
  Iterating [MOComponent_state2trace] shows that every reachable MO state contains a
  trace that leads to this state. However, this trace is not unique, because
  we can concatenate the lifted traces in any order.
*)
Fixpoint MO_state2trace_aux
  (us : MO_state) (is : list index) : list MO_transition_item :=
match is with
| [] => []
| i :: is' =>
  MO_state2trace_aux (state_update _ us i (MkState [] (idx i))) is' ++ MOComponent_state2trace us i
end.

Definition MO_state2trace
  (us : MO_state) : list MO_transition_item :=
    MO_state2trace_aux us (enum index).

Lemma finite_valid_trace_from_to_MO_state2trace_RMO :
  forall us : MO_state,
    valid_state_prop RMO us ->
      finite_valid_trace_init_to RMO (``(vs0 RMO)) us (MO_state2trace us).
Proof.
  intros us Hvsp; split; [| done].
  unfold MO_state2trace.
  assert (Hall : forall i, i ∉ enum index -> us i = MkState [] (idx i))
    by (intros i Hin; contradict Hin; apply elem_of_enum).
  revert us Hall Hvsp.
  generalize (enum index) as is.
  induction is as [| i is']; cbn; intros us Hall Hvsp.
  - replace us with (fun n : index => MkState [] (idx n)).
    + by constructor; apply initial_state_is_valid; compute.
    + extensionality i; rewrite Hall; [done |].
      by apply not_elem_of_nil.
  - eapply finite_valid_trace_from_to_app.
    + apply IHis'.
      * intros j Hj. destruct (decide (i = j)); subst; state_update_simpl; [done |].
        by apply Hall; rewrite elem_of_cons; intros [].
      * apply (VLSM_eq_valid_state (pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True MO)).
        apply pre_composite_free_update_state_with_initial; [| by compute].
        by apply (VLSM_eq_valid_state (pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True MO)).
    + replace us with (state_update M us i (us i)) at 2 by (state_update_simpl; done).
      apply lift_to_RMO_finite_valid_trace_from_to; [done |].
      apply (valid_state_project_preloaded_to_preloaded _ _ _ us i) in Hvsp as Hvsp'.
      apply valid_state_has_trace in Hvsp' as (s & tr & [Hfvt Hinit]).
      replace s with (MkState [] (idx i)) in *; cycle 1.
      * by inversion Hinit; destruct s; cbn in *; subst.
      * by eapply finite_valid_trace_init_to_state2trace_RMi.
Qed.

(** *** Validators *)

Lemma MO_component_validating :
  forall i : index, component_projection_validator_prop M (free_constraint M) i.
Proof.
  unfold component_projection_validator_prop.
  intros i lj sj omi * Hiv.
  apply input_valid_transition_iff in Hiv as [[s m] Ht].
  apply exists_right_finite_trace_from in Ht as (s' & tr & Hfvt & Hlast).
  apply lift_to_MO_finite_valid_trace_init_to in Hfvt as [Hfvt _].
  unfold lift_to_MO_trace, pre_VLSM_embedding_finite_trace_project in Hfvt;
    rewrite map_app in Hfvt.
  apply finite_valid_trace_from_to_app_split in Hfvt as [_ Hfvt].
  remember (finite_trace_last _ _) as ftl.
  change (finite_trace_last _ _)
    with (finite_trace_last
            (lift_to_MO_state (fun j : index => MkState [] (idx j)) i s')
            (lift_to_MO_trace (fun j : index => MkState [] (idx j)) i tr)) in Heqftl.
  apply valid_trace_forget_last, first_transition_valid in Hfvt; cbn in *.
  destruct Hfvt as [[Hvps [Hovmp [Hv1 Hv2]]] Ht]; cbn in Hv1, Hv2.
  unfold lift_to_MO_trace in Heqftl; cbn in Heqftl.
  rewrite <- pre_VLSM_embedding_finite_trace_last, Hlast in Heqftl.
  exists ftl; split; [| done].
  by rewrite Heqftl; state_update_simpl.
Qed.

(** *** Equivocation *)

Lemma rec_obs_input_valid_transition :
  forall (i : index) (s1 s2 : State) (m1 m2 : option Message) (lbl : Label),
    input_valid_transition (RM i) lbl (s1, m1) (s2, m2) ->
      forall ob : Observation, rec_obs s1 ob -> rec_obs s2 ob.
Proof.
  intros i s1 s2 m1 m2 lbl Hivt ob Hro.
  destruct Hivt as [(_ & _ & Hvalid) Ht]; cbn in *.
  by inversion Hvalid; subst; inversion Ht; subst; cbn in *; constructor.
Qed.

Record incomparable_state (s1 s2 : State) : Prop :=
{
  incs_not_state_suffix12 : ~ state_suffix s1 s2;
  incs_not_state_suffix21 : ~ state_suffix s2 s1;
  incs_not_equal : s1 <> s2;
}.

Lemma rec_obs_send_inv
  (Q : State -> Observation -> Prop) s ob
  (Hnew : Q s (MkObservation Send (MkMessage s)))
  (Hprev : rec_obs s ob -> Q s ob) :
  rec_obs (s <+> MkObservation Send (MkMessage s)) ob -> Q s ob.
Proof.
  by inversion 1; (replace s with s0 in *; [auto | apply eq_State]).
Qed.

Lemma rec_obs_recv_inv
  (Q : State -> Message -> Observation -> Prop) s m ob
  (Hnew : Q s m (MkObservation Receive m))
  (Hprev : rec_obs s ob -> Q s m ob)
  (Hrecv : rec_obs (state m) ob -> Q s m ob) :
  rec_obs (s <+> MkObservation Receive m) ob -> Q s m ob.
Proof.
  by inversion 1; (replace s with s0 in *; [auto | apply eq_State]).
Qed.

Lemma rec_obs_addObservation_iff (s : State) (ob' ob : Observation) :
  rec_obs (s <+> ob) ob'
    <->
  rec_obs s ob' \/ ob' = ob \/ label ob = Receive /\ rec_obs (state (message ob)) ob'.
Proof.
  split.
  - inversion 1; subst.
    + by right; left.
    + by left; replace s with s0 by (apply eq_State; done).
    + by right; right.
  - destruct 1 as [Hprev | [-> | Hob]].
    + by apply rec_prev.
    + by apply rec_new.
    + destruct ob as [l m]; cbn in Hob.
      destruct Hob as [-> Hm].
      by apply rec_recv.
Qed.

Lemma unfold_rec_obs :
  forall (s : State) (ob : Observation),
    rec_obs s ob
      <->
    ob ∈ obs s \/ exists m, MkObservation Receive m ∈ obs s /\ rec_obs (state m) ob.
Proof using. clear. (* avoid unneccessary dependence on section variables *)
  intros s ob; split.
  - induction 1.
    + by left; constructor.
    + by setoid_rewrite elem_of_addObservation; firstorder.
    + by setoid_rewrite elem_of_addObservation; firstorder.
  - induction s using addObservation_ind.
    + by firstorder using elem_of_nil.
    + setoid_rewrite elem_of_addObservation.
      rewrite rec_obs_addObservation_iff.
      by firstorder; subst; auto.
Qed.

Set Warnings "-cannot-define-projection".
Record local_equivocators (s : State) (i : Address) : Prop :=
{
  lceqv_ob1 : Observation;
  lceqv_ob2 : Observation;
  lceqv_adr1 : adr (state (message lceqv_ob1)) = i;
  lceqv_adr2 : adr (state (message lceqv_ob2)) = i;
  lceqv_rec_obs1 : rec_obs s lceqv_ob1;
  lceqv_rec_obs2 : rec_obs s lceqv_ob2;
  lceqv_incomparable : incomparable (message lceqv_ob1) (message lceqv_ob2);
}.
Set Warnings "cannot-define-projection".

Definition composite_rec_observation
  (s : vstate MO) (ob : Observation) : Prop :=
    exists i : index, rec_obs (s i) ob.

Definition state_after_sending (m : Message) : State :=
  state m <+> MkObservation Send m.

Set Warnings "-cannot-define-projection".
Record global_equivocators
  (sigma : vstate MO) (i : index) : Prop :=
{
  globeqv_ob : Observation;
  globeqv_adr : adr (state (message globeqv_ob)) = idx i;
  globeqv_cro : composite_rec_observation sigma globeqv_ob;
  s := state_after_sending (message globeqv_ob);
  globeqv_nss : ~ state_suffix s (sigma i);
  globeqv_neq : s <> sigma i;
}.
Set Warnings "cannot-define-projection".

Lemma obs_rec_obs :
  forall (s : State) ob,
    ob ∈ obs s -> rec_obs s ob.
Proof.
  intros s ob.
  induction s using addObservation_ind.
  - by inversion 1.
  - intros [<- | Hob]%elem_of_cons.
    + by apply rec_new.
    + by apply rec_prev, IHs, Hob.
Qed.

Lemma messages_rec_obs :
  forall i (s : vstate (RM i)),
    valid_state_prop (RM i) s ->
    forall (m' : Message) (ob : Observation),
      m' ∈ messages s ->
      rec_obs (state m') ob ->
      rec_obs s ob.
Proof.
  intros i s Hs.
  induction Hs using valid_state_prop_ind.
  - destruct s as [ol a].
    assert (ol = []) as -> by apply Hs.
    by inversion 1.
  - intros m' ob Hm' Hob.
    destruct Ht as [(_ & _ & Hvalid) Ht], Hvalid as [s m _ | s];
      cbn in Ht; injection Ht as [= <- <-].
    + change (m' ∈ m :: messages s) in Hm'.
      apply elem_of_cons in Hm' as [-> | Hm'].
      * by apply rec_recv.
      * by eapply rec_prev, IHHs.
    + change (m' ∈ MkMessage s :: messages s) in Hm'.
      apply elem_of_cons in Hm' as [-> | Hm'].
      * by apply rec_prev.
      * by eapply rec_prev, IHHs.
Qed.

Lemma unfold_robs_fwd :
  forall (s : State) ob,
    rec_obs s ob ->
      ob ∈ obs s \/ exists (m' : Message), m' ∈ messages s /\ rec_obs (state m') ob.
Proof.
  intros s ob.
  induction s using addObservation_ind; [by inversion 1 |].
  intro Hob; inversion Hob; subst; clear Hob
  ; replace s0 with s in * by (apply eq_State; done); clear H2 H3.
  - by left; constructor.
  - destruct (IHs H4) as [Hob | (m' & Hm & Hob)].
    + by left; constructor.
    + by right; exists m'; split; [constructor |].
  - by right; exists m; split; [constructor |].
Qed.

Lemma unfold_robs_rev :
  forall [Q : State -> Message -> Prop] [s : State],
    UMO_reachable Q s ->
    forall ob,
      (ob ∈ obs s \/ exists (m' : Message), m' ∈ messages s /\ rec_obs (state m') ob) ->
        rec_obs s ob.
Proof.
  by induction 1; intros ob [Hob | [m' [Hob ?]]];
    apply (@not_elem_of_nil, @elem_of_addObservation, @elem_of_messages_addObservation) in Hob;
    destruct Hob; subst; constructor; eauto.
Qed.

Lemma unfold_robs :
  forall (Q : State -> Message -> Prop) (s : State),
    UMO_reachable Q s ->
    forall ob,
      rec_obs s ob
        <->
      ob ∈ obs s \/ exists (m' : Message), m' ∈ messages s /\ rec_obs (state m') ob.
Proof.
  split.
  - by apply unfold_robs_fwd.
  - by eapply unfold_robs_rev.
Qed.

Lemma rec_obs_size_desc (s : State) (ob : Observation) :
  rec_obs s ob -> sizeState (state (message ob)) < sizeState s.
Proof.
  by induction 1; rewrite addObservation_size, sizeObservation_unfold; cbn; lia.
Qed.

Lemma rec_obs_acyclic (s : State) :
  forall l, ~ rec_obs s (MkObservation l (MkMessage s)).
Proof.
  by intros l Hrobs; apply rec_obs_size_desc, Nat.lt_irrefl in Hrobs.
Qed.

End sec_MOProtocol.

End sec_MO.

Arguments rec_obs_send_inv : clear implicits.
Arguments rec_obs_recv_inv : clear implicits.


(*
 * Licensed under the Apache License, Version 2.0 (the "License");
 * you may not use this file except in compliance with the License.
 * You may obtain a copy of the License at
 *
 * http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 *)

Require Import String.
Require Import List.
Require Import Compare_dec.
Require Import DataSystem.
Require Import NRAExt.
Require Import TNRA.

Section TNRAExt.
  Local Open Scope nraext_scope.

  (** Typing for NRA *)

  Context {m:basic_model}.

  Definition nraext_type Op C A B := nra_type C (nra_of_nraext Op) A B.

  Notation "Op ▷ A >=> B ⊣ C" := (nraext_type Op C A B) (at level 70) : nraext_scope.

  (** Main typing soundness theorem for the Extended NRA *)

  Theorem typed_nraext_yields_typed_data {τc} {τin τout} (d:data) c (op:nraext):
    (bindings_type c τc) ->
    (d ▹ τin) -> (op ▷ τin >=> τout ⊣ τc) ->
    (exists x, (brand_relation_brands ⊢ op @ₓ d ⊣ c = Some x /\ (x ▹ τout))).
  Proof.
    unfold nraext_eval, nraext_type; intros.
    apply (@typed_nra_yields_typed_data m τc τin τout); assumption.
  Qed.

  (** Corrolaries of the main type soudness theorem *)

  Definition typed_nraext_total {τc} {τin τout} (op:nraext) (d:data) c :
    (bindings_type c τc) ->
    (d ▹ τin) -> (op ▷ τin >=> τout ⊣ τc) ->
    { x:data | x ▹ τout }.
  Proof.
    unfold nraext_eval, nraext_type; intros.
    apply (@typed_nra_total m τc τin τout (nra_of_nraext op) H1 c d); assumption.
  Defined.

  Definition tnraext_eval {τc} {τin τout} (op:nraext) (d:data) c :
    (bindings_type c τc) ->
    (d ▹ τin) -> (op ▷ τin >=> τout ⊣ τc) -> data.
  Proof.
    unfold nraext_eval, nraext_type; intros.
    apply (@tnra_eval m τc τin τout (nra_of_nraext op) H1 c d); assumption.
  Defined.
End TNRAExt.

(* Typed algebraic plan *)

Notation "Op ▷ A >=> B ⊣ C" := (nraext_type Op C A B) (at level 70) : nraext_scope.
Notation "Op @▷ d ⊣ c" := (tnraext_eval Op d c) (at level 70) : nraext_scope.


From mathcomp Require Import
     all_ssreflect.

From AUChain Require Import
     Messages
     Parameters.

From RecordUpdate Require Import RecordSet.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * MessageTuple
    This file contains the wrapper around messages used
    by the network functionality.
**)

Record MessageTuple :=
  mkMessageTuple
    { msg : Message
    ; rcv : Party
    ; cd : Delay }.

Instance MessageTupleSettable : Settable MessageTuple :=
  settable! mkMessageTuple <msg; rcv; cd>.

Definition MessagePool := seq MessageTuple.

Module MessageTupleEq.

Definition eq_msg_tuple a b :=
  [&& msg a == msg b
   , rcv a == rcv b
   & cd a  == cd b ].

Lemma eq_msg_tupleP : Equality.axiom eq_msg_tuple.
Proof.
  case => ???; case => ???. rewrite /eq_msg_tuple /=.
  do ! (case: _ /eqP; [move => -> |by constructor; case]).
  by constructor.
Qed.

Canonical MessageTuple_eqMixin := Eval hnf in EqMixin eq_msg_tupleP.
Canonical MessageTuple_eqType := Eval hnf in EqType MessageTuple MessageTuple_eqMixin.

End MessageTupleEq.
Export MessageTupleEq.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Export Typing.

Set Implicit Arguments.
Unset Standard Proposition Elimination Names.

(* Redefinition of pairs on [Type] instead of [Set] *)

Inductive prod (A B:Type) : Type :=
    pair : A -> B -> prod A B.
Notation "x * y" := (prod x y) : type_scope.

Definition fst (A B:Type)(ab:prod A B) := let (a,_) := ab in a.
Definition snd (A B:Type)(ab:prod A B) := let (_,b) := ab in b.

Inductive halfprod (A:Prop)(B:Type) : Type :=
   halfpair : A -> B -> halfprod A B.
Notation "x ** y" := (halfprod x y) (at level 40) : type_scope.

Definition F (rhos:context)(rho:type)(r:term)(k:nat) :=
  TypJ rhos r rho /\ length rhos <= k.

Hint Unfold F.

Lemma F_occurs : forall r rhos rho k,
  F rhos rho r k -> occurs k r = false.
Proof.
  induction r; destruct 1; simpl; intros.
  case (eq_nat_dec n k); auto.
  intros; subst.
  destruct H; inversion_clear H.
  cut False; try contradiction.
  omega.

  rewrite (IHr1 rhos (typ rhos r2 --> rho)); [simpl|red; intuition eauto].
  apply (IHr2 rhos (typ rhos r2)); red; intuition eauto.

  rename rho into sigma; rename t into rho.
  destruct H; simpl in *.
  inversion_clear H.
  apply (IHr (rho::rhos) (typ (rho::rhos) r) (S k)); red; intuition eauto.
  simpl; auto with arith.
Qed.

Module Type Requirements.

 Parameter abstr : nat -> type -> term -> term.
 Notation " \! k : rho , r " := (abstr k rho r) (at level 20, k at level 99).

 Parameter N : context -> type -> term -> term -> Prop.
 Parameter A : context -> type -> term -> term -> Prop.
 Parameter H : context -> type -> term -> term -> Prop.

 Axiom Ax1 : forall r t rhos rho sigma k, F rhos (rho-->sigma) r k ->
  N (rhos++ext_ctx rhos k rho) sigma (r;k) t ->
  N rhos (rho-->sigma) r (\!k:rho, t).

 Axiom Ax2 : forall rhos r s,  A rhos Iota r s -> N rhos Iota r s.

 Axiom Ax3 : forall rhos rho k, TypJ rhos [k] rho ->  A rhos rho [k] [k].

 Axiom Ax4 : forall rhos rho sigma r r' s s', TypJ rhos s rho ->
  A rhos (rho-->sigma) r r' -> N rhos rho s s' -> A rhos sigma (r;s) (r';s').

 Axiom Ax5 : forall rhos rho r s t,
  H rhos rho r s -> N rhos rho s t -> N rhos rho r t.

 Axiom Ax6 : forall rhos rho sigma r s rs,
  H rhos sigma ((sub (\rho,r) rs);s)
  (sub r ((s::rs)#rs.(shift))).

 Axiom Ax7 : forall rhos rho sigma r s t,
  H rhos (rho-->sigma) r s -> H rhos sigma (r;t) (s;t).

 Axiom Ax_H_ext_ctx :  forall rhos sigmas rho r s, TypJ rhos r rho ->
  H rhos rho r s -> H (rhos++sigmas) rho r s.

End Requirements.

Module NormalizationProof (R:Requirements).

Import R.

Definition SN (rhos:context)(rho:type)(r:term) :=
  forall k sigmas, F (rhos++sigmas) rho r k ->
    { s:term | N (rhos++sigmas) rho r s }.

Definition SA (rhos:context)(rho:type)(r:term) :=
 forall k sigmas, F (rhos++sigmas) rho r k ->
    { s:term | A (rhos++sigmas) rho r s }.

Open Scope type_scope.

Fixpoint SC (rhos:context)(rho:type)(r:term) {struct rho} : Type :=
  (TypJ rhos r rho) **
  match rho with
  | Iota => SN rhos Iota r
  | rho-->sigma =>
    forall s sigmas, SC (rhos++sigmas) rho s ->
      SC (rhos++sigmas) sigma (r;s)
  end.

Lemma SN_ext_ctx : forall rho rhos sigmas r,
 TypJ rhos r rho -> SN rhos rho r -> SN (rhos++sigmas) rho r.
Proof.
unfold SN; intros.
rewrite app_ass in H2; rewrite app_ass.
apply (H1 k _ H2); auto.
Qed.
Hint Resolve SN_ext_ctx.

Lemma SC_TypJ : forall rhos rho r, SC rhos rho r -> TypJ rhos r rho.
Proof.
 destruct rho; destruct 1; auto.
Qed.
Hint Resolve SC_TypJ.

Lemma SC_ext_ctx : forall rho rhos sigmas r,
 SC rhos rho r -> SC (rhos++sigmas) rho r.
Proof.
destruct rho; simpl; intuition.
destruct a; auto.
rewrite app_ass; rewrite app_ass in X; auto.
Qed.

Lemma one :
 forall rho rhos r, TypJ rhos r rho ->
 (SC rhos rho r -> SN rhos rho r)*(SA rhos rho r -> SC rhos rho r).
Proof.
induction rho.
simpl.
split.
intuition.
unfold SA, SN.
intros.
split; auto.
intros.
destruct (H1 k _ H2) as [s Hs].
exists s.
apply Ax2; auto.

rename rho1 into rho.
rename rho2 into sigma.
split.
rename H0 into T.
simpl.
unfold SN.
destruct 1 as [_ X].
intros k mus; intros.
set (rhos':=rhos++mus).
set (sigmas := ext_ctx rhos' k rho).
assert (T' : TypJ (rhos'++sigmas) k rho).
 unfold sigmas; apply ext_ctx_TypJ; destruct H0; auto.
assert (SA (rhos'++sigmas) rho [k]).
 red; intros.
 exists [k].
 apply Ax3.
 destruct H1; auto.
assert (SC (rhos'++sigmas) sigma (r;k)).
 unfold rhos' in *.
 assert (Eq:=app_ass rhos mus sigmas); rewrite_all Eq; clear Eq.
 apply X.
 refine (snd (IHrho1 (rhos++mus++sigmas) [k] _) _); auto.
assert (SN (rhos'++sigmas) sigma (r;k)).
 refine (fst (IHrho2 (rhos'++sigmas) (r;k) _) _); eauto.
try rename X2 into H2.
destruct (H2 (S k) nil) as [t Ht]; auto.
 simpl_list.
 split; auto.
 unfold sigmas; rewrite ext_ctx_length; auto.
 unfold F in *; intuition.
exists (\!k:rho,t); auto.
do_in Ht simpl_list.
apply Ax1; auto.

unfold SA; simpl; split; auto; intros.
rename H0 into T.
refine (snd (IHrho2 (rhos++sigmas) (r;s) _) _); eauto.
red; intros.
destruct (H1 k (sigmas++sigmas0)) as [r' Hr'].
 rewrite <- app_ass.
 split; auto.
 unfold F in *; intuition.
rewrite <- app_ass in Hr'.
assert (IH: SN (rhos++sigmas) rho s).
 refine (fst (IHrho1 (rhos++sigmas) s _) _); eauto.
destruct (IH k sigmas0) as [s' Hs']; auto.
 unfold F in *; intuition.
exists (r';s').
eapply Ax4; eauto.
Defined.

Lemma two : forall rho rhos r r', TypJ rhos r rho ->
  SC rhos rho r' -> H rhos rho r r' -> SC rhos rho r.
Proof.
induction rho; simpl; unfold SN; split; auto; intros.
try rename X into H1.
destruct H1 as [T H4].
destruct (H4 k sigmas) as [s Hs]; auto.
unfold F in *; intuition.
exists s.
eapply Ax5; eauto.
apply Ax_H_ext_ctx; auto.
apply IHrho2 with (r':= r';s); intuition.
eauto.
eapply Ax7; eapply Ax_H_ext_ctx; eauto.
Defined.

Fixpoint SCs (sigmas rhos: context)(rs: list term) {struct rhos} : Type :=
 match rhos, rs with
 | nil,nil => True
 | nil, _ => False
 | _, nil => False
 | rho::rhos, r::rs => (SC sigmas rho r)*(SCs sigmas rhos rs)
end.

Lemma SCs_length : forall sigmas rhos rs, SCs sigmas rhos rs ->
 length rhos = length rs.
Proof.
induction rhos; destruct rs; auto; simpl; destruct 1; firstorder.
Qed.

Lemma SCs_nth : forall sigmas rhos rho rs r n, n < length rhos ->
  SCs sigmas rhos rs -> SC sigmas (nth n rhos rho)  (nth n rs r).
Proof.
induction rhos; destruct rs.
intros.
elimtype False.
inversion H0.
contradiction.
contradiction.
intros.
simpl in X; destruct X.
destruct n.
simpl.
auto.
simpl.
firstorder.
Defined.

Lemma SCs_ext_ctx : forall sigmas sigmas0 rhos rs,
 SCs sigmas rhos rs -> SCs (sigmas++sigmas0) rhos rs.
Proof.
induction rhos; destruct rs; simpl; intuition.
apply SC_ext_ctx; auto.
Qed.

Lemma three : forall r (rs:substitution) rhos sigmas rho,
 SCs sigmas rhos rs ->
 TypJ rhos r rho ->  SC sigmas rho (sub r rs).
Proof.
induction r.
simpl.
intros.
destruct H0.
simpl in H1.
subst rho.
apply SCs_nth; auto.
inversion_clear H0; auto.

simpl.
intros.
set (sigma := typ rhos r2).
assert (H1: TypJ rhos r1 (sigma-->rho)). eauto.
assert (H2: TypJ rhos r2 (typ rhos r2)). eauto.
assert (IH1:= IHr1 rs rhos sigmas (sigma --> rho) X H1).
assert (IH2:= IHr2 rs rhos sigmas (typ rhos r2) X H2).
simpl in IH1.
destruct IH1 as [_ B].
replace sigmas with (sigmas++nil); [idtac|simpl_list;auto].
apply (B (sub r2 rs) nil); simpl_list; auto.

rename t into rho.
intros.
destruct H0.
subst rho0.
set (freeze:= sub (\ rho, r) rs).
assert (TypJ sigmas (sub (\ rho, r) rs) (rho --> typ (rho::rhos) r)).
 apply TypJ_sub2 with rhos.
 rewrite (SCs_length _ _ _ X); auto with arith.
 split; auto.
 intros.
 lapply (@SCs_nth sigmas rhos d' rs d n); auto.
simpl; split; auto; intros.
destruct (@one rho (sigmas ++ sigmas0) s); auto.
apply two with (sub r ((s::rs)#(rs.(shift)))); eauto.
apply IHr with (rhos:=rho::rhos).
simpl.
split; auto.
apply SCs_ext_ctx; auto.
inversion_clear H0; split; auto.
unfold freeze.
apply Ax6; auto.
Qed.

Lemma SCs_seq : forall rhos sigmas,
  SCs (sigmas++rhos) rhos
   (map Var (seq (length sigmas) (length rhos))).
Proof.
induction rhos.
simpl; auto.
simpl.
split.
destruct (@one a (sigmas++a::rhos) (length sigmas)).
split.
constructor.
simpl_list; simpl; omega.
simpl; simpl_list; auto.
rewrite app_nth2; auto.
simpl_arith; simpl; auto.
apply s0.
unfold SA.
exists [length sigmas].
apply Ax3.
destruct H0; auto.
replace (a::rhos) with ((a::nil) ++ rhos); auto.
rewrite <- app_ass.
replace (S (length sigmas)) with (length (sigmas++a::nil)); auto.
simpl_list; simpl; simpl_arith; auto.
Defined.

Lemma normalizeTheorem :
 forall rhos rho r, TypJ rhos r rho -> { s:term | N rhos rho r s }.
Proof.
intros.
destruct (@one rho rhos r); auto.
assert (SC rhos rho r).
rewrite <- (sub_id r (length rhos)).
apply three with rhos; auto.
unfold id; simpl.
generalize (SCs_seq rhos nil); simpl_list; simpl; auto.
generalize (s X (length rhos) nil); simpl_list; intuition.
Defined.

End NormalizationProof.


From Coq Require Import ZArith List.
From mathcomp Require Import ssreflect ssrbool ssrnat eqtype seq.
From BitBlasting Require Import QFBV CNF BBCommon.
From ssrlib Require Import ZAriths Tactics Bools Seqs.
From nbits Require Import NBits.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* ===== bit_blast_eq ===== *)

Fixpoint bit_blast_eq_eq_zip r lsp : cnf :=
  match lsp with
  | [::] => [::]
  | (l1, l2)::tl =>
    let cs_hd := List.map (fun cs => neg_lit r::cs) (cnf_lit_eq l1 l2) in
    let cs_tl := bit_blast_eq_eq_zip r tl in
    catrev cs_hd cs_tl
  end.

Definition bit_blast_eq_choice r (auxs: word) : cnf :=
  [:: r::auxs].

Fixpoint bit_blast_eq_neq_zip g lsp : generator * cnf * word :=
  match lsp with
  | [::] => (g, [::], [::])
  | (l1, l2)::tl =>
    let (g_hd, auxs_hd) := gen g in
    let cs_hd := [:: [:: neg_lit auxs_hd; l1; l2];
                    [:: neg_lit auxs_hd; neg_lit l1; neg_lit l2];
                    [:: auxs_hd; neg_lit l1; l2];
                    [:: auxs_hd; l1; neg_lit l2] ] in
    let '(g_tl, cs_tl, auxs_tl) := bit_blast_eq_neq_zip g_hd tl in
    (g_tl, catrev cs_hd cs_tl, auxs_hd :: auxs_tl)
  end.

Fixpoint mk_env_eq_neq_zip E g lsp : env * generator * cnf * word :=
  match lsp with
  | [::] => (E, g, [::], [::])
  | (l1, l2)::tl =>
    let (g_hd, auxs_hd) := gen g in
    let E' := env_upd E (var_of_lit auxs_hd)
                      (xorb (interp_lit E l1) (interp_lit E l2)) in
    let cs_hd := [:: [:: neg_lit auxs_hd; l1; l2];
                    [:: neg_lit auxs_hd; neg_lit l1; neg_lit l2];
                    [:: auxs_hd; neg_lit l1; l2];
                    [:: auxs_hd; l1; neg_lit l2] ] in
    let '(E_tl, g_tl, cs_tl, auxs_tl) := mk_env_eq_neq_zip E' g_hd tl in
    (E_tl, g_tl, catrev cs_hd cs_tl, auxs_hd :: auxs_tl)
  end.

Definition bit_blast_eq_zip (g : generator) lsp : generator * cnf * literal :=
  let (g_r, r) := gen g in
  let '(g_aux, cs_neq, auxs) := bit_blast_eq_neq_zip g_r lsp in
  let cs_aux := bit_blast_eq_choice r auxs in
  let cs_eq := bit_blast_eq_eq_zip r lsp in
  (g_aux, catrev cs_neq (catrev cs_aux cs_eq), r).

Definition mk_env_eq_zip E g lsp : env * generator * cnf * literal :=
  let (g_r, r) := gen g in
  let E' := env_upd E (var_of_lit r) (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)) in
  let '(E_aux, g_aux, cs_neq, auxs) := mk_env_eq_neq_zip E' g_r lsp in
  let cs_aux := bit_blast_eq_choice r auxs in
  let cs_eq := bit_blast_eq_eq_zip r lsp in
  (E_aux, g_aux, catrev cs_neq (catrev cs_aux cs_eq), r).

Definition bit_blast_eq g ls1 ls2 := bit_blast_eq_zip g (extzip_ff ls1 ls2).

Definition mk_env_eq E g ls1 ls2 := mk_env_eq_zip E g (extzip_ff ls1 ls2).

Lemma bit_blast_eq_eq_zip_correct E bsp lsp lr:
  enc_bits E (unzip1 lsp) (unzip1 bsp) ->
  enc_bits E (unzip2 lsp) (unzip2 bsp) ->
  interp_cnf E (add_prelude (bit_blast_eq_eq_zip lr lsp)) ->
  interp_lit E lr ->
  (unzip1 bsp) = (unzip2 bsp).
Proof.
  elim: lsp E bsp lr => [| [ls1_hd ls2_hd] lsp_tl IH] E bsp lr.
  - rewrite !enc_bits_nil_l unzip1_l_nil.
      by case/eqP => ->.
  - rewrite /=.
    case: bsp => [| [bsp_hd1 bsp_hd2] bsp_tl] //=.
    rewrite !enc_bits_cons. move=> /andP [Henc1hd Henc1tl] /andP [Henc2hd Henc2tl].
    move=> Hcnf Hlr.
    rewrite add_prelude_cons in Hcnf. move/andP: Hcnf => [Hcnf_hd1 Hcnf_tl].
    rewrite add_prelude_cons in Hcnf_tl. move/andP: Hcnf_tl => [Hcnf_hd2 Hcnf_tl].
    have Heqhd: bsp_hd1 = bsp_hd2.
    {
      rewrite 2!add_prelude_singleton in Hcnf_hd1 Hcnf_hd2.
      rewrite /= in Hcnf_hd1 Hcnf_hd2. split_andb_hyps.
      rewrite !interp_lit_neg_lit in H0 H2. rewrite Hlr /= !orbF in H0 H2.
      move: (expand_eq (interp_lit E ls1_hd) (interp_lit E ls2_hd)).
      rewrite H0 H2 /= => /eqP Heq. exact: (enc_bit_eq_bit Heq Henc1hd Henc2hd).
    }
    move: (IH _ _ _ Henc1tl Henc2tl Hcnf_tl Hlr) => Heqtl.
    rewrite Heqhd Heqtl. reflexivity.
Qed.

Lemma bit_blast_eq_neq_zip_correct E g bsp lsp g' cs lauxs:
  bit_blast_eq_neq_zip g lsp = (g', cs, lauxs) ->
  enc_bits E (unzip1 lsp) (unzip1 bsp) ->
  enc_bits E (unzip2 lsp) (unzip2 bsp) ->
  interp_cnf E (add_prelude cs) ->
  (exists laux : literal, laux \in lauxs /\ interp_lit E laux) ->
  (unzip1 bsp) <> (unzip2 bsp).
Proof.
  elim: lsp E g bsp g' cs lauxs  => [| [ls1_hd ls2_hd] lsp_tl IH] E g bsp g' cs lauxs /=.
  - case=> _ _ <- _ _ _ Hcontra.
    destruct Hcontra.
    rewrite in_nil in H. by destruct H.
  - dcase (bit_blast_eq_neq_zip (g + 1)%positive lsp_tl) => [[[g_tl cs_tl] auxs_tl] Hblast].
    case=> Hg Hcs Hlauxs.
    case: bsp => [| [bsp_hd1 bsp_hd2] bsp_tl] //=.
    rewrite !enc_bits_cons. move=> /andP [Henc1hd Henc1tl] /andP [Henc2hd Henc2tl].
    move=> Hcnf Hlr.
    move: Hlr => [laux [Hin Haux]].
    rewrite -Hlauxs in_cons in Hin.
    case/orP: Hin.
    + move=> /eqP Hin. rewrite -Hcs in Hcnf. rewrite -/(neg_lit (Pos g)) in Hcnf.
      rewrite  -Hin in Hcnf.
      rewrite add_prelude_expand /= in Hcnf.
      rewrite !interp_lit_neg_lit in Hcnf. rewrite Haux /= !orbF in Hcnf. split_andb_hyps.
      move=> Heq. injection Heq => Heqtl Heqhd. move: H0 H1.
      move: (enc_bit_eq_lit Heqhd Henc1hd Henc2hd) => ->.
        by case: (interp_lit E ls2_hd).
    + move=> Hin.
      have Hexists: (exists laux : literal,
                        laux \in auxs_tl /\ interp_lit E laux).
      {
        exists laux. split; last by exact: Haux.
        exact: Hin.
      }
      have Hcnftl: interp_cnf E (add_prelude cs_tl).
      {
        rewrite -Hcs in Hcnf.
        rewrite add_prelude_cons in Hcnf.
        move/andP: Hcnf => [Hcnf1 Hcnf]. rewrite add_prelude_cons in Hcnf.
        move/andP: Hcnf => [Hcnf2 Hcnf]. rewrite add_prelude_cons in Hcnf.
        move/andP: Hcnf => [Hcnf3 Hcnf]. rewrite add_prelude_cons in Hcnf.
        move/andP: Hcnf => [Hcnf4 Hcnf]. exact: Hcnf.
      }
      move: (IH _ _ _ _ _ _ Hblast Henc1tl Henc2tl Hcnftl Hexists) => Hne Heq.
      apply: Hne. injection Heq => Heqtl Heqhd. exact: Heqtl.
Qed.

Lemma bit_blast_eq_choice_correct E r auxs:
  interp_cnf E (add_prelude (bit_blast_eq_choice r auxs)) ->
  interp_lit E r \/ (exists aux : literal,
                       aux \in auxs /\ interp_lit E aux).
Proof.
  rewrite /bit_blast_eq_choice.
  rewrite add_prelude_expand.
  rewrite interp_cnf_cons /= -/(interp_clause E (r::auxs)).
  rewrite !andbT.
  move/andP=> [_ H].
  case/orP: H => H.
  - by left.
  - right.
    move: (interp_clause_mem H).
    destruct 1.
    exists x; done.
Qed.

Lemma bit_blast_eq_zip_correct E g bsp lsp g' cs lr:
  bit_blast_eq_zip g lsp = (g', cs, lr) ->
  enc_bits E (unzip1 lsp) (unzip1 bsp) ->
  enc_bits E (unzip2 lsp) (unzip2 bsp) ->
  interp_cnf E (add_prelude cs) ->
  enc_bit E lr (unzip1 bsp == unzip2 bsp).
Proof.
  rewrite /bit_blast_eq_zip.
  rewrite /gen. case Hneq: (bit_blast_eq_neq_zip (g+1)%positive lsp) =>
                [[g_aux cs_neq] auxs]. set r := Pos g.
  case=> _ <- <- Henc1 Henc2 Hcnf.
  rewrite add_prelude_catrev add_prelude_cons in Hcnf.
  move/andP: Hcnf=> [Hcnf_neq Hcnf]. move/andP: Hcnf=> [Hcnf_auxs Hcnf_eq].
  rewrite /enc_bit. case Hr: (interp_lit E r).
  - apply/eqP; symmetry. apply/eqP.
    exact: (bit_blast_eq_eq_zip_correct Henc1 Henc2 Hcnf_eq Hr).
  - move: (bit_blast_eq_choice_correct Hcnf_auxs). rewrite Hr.
    case => H; first by elim H. apply/eqP; symmetry. apply/eqP.
    exact: (bit_blast_eq_neq_zip_correct Hneq Henc1 Henc2 Hcnf_neq H).
Qed.

Lemma bit_blast_eq_correct g bs1 bs2 E ls1 ls2 g' cs lr :
  bit_blast_eq g ls1 ls2 = (g', cs, lr) ->
  size ls1 = size ls2 ->
  enc_bits E ls1 bs1 -> enc_bits E ls2 bs2 -> interp_cnf E (add_prelude cs) ->
  enc_bit E lr (bs1 == bs2).
Proof.
  rewrite /bit_blast_eq => Hbb Hsz Henc1 Henc2 Hcs.
  move: (enc_bits_size Henc1) (enc_bits_size Henc2) => Hs1 Hs2.
  move: (add_prelude_enc_bit_tt Hcs) => Henctt.
  move: (bit_blast_eq_zip_correct Hbb
                                  (enc_bits_unzip1_extzip Henctt Henc1 Henc2)
                                  (enc_bits_unzip2_extzip Henctt Henc1 Henc2) Hcs).

  have H1: (size bs2 <= size bs1) by rewrite -Hs1 -Hs2 Hsz.
  have H2: (size bs1 <= size bs2) by rewrite -Hs1 -Hs2 Hsz.
  rewrite /extzip0.
  rewrite (unzip1_extzip_ll b0 b0 H1).
  rewrite (unzip2_extzip_rl b0 b0 H2).
  done.
Qed.

Lemma mk_env_eq_neq_zip_is_bit_blast_eq_neq_zip E g lsp E' g' cs lr:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lr) ->
  bit_blast_eq_neq_zip g lsp = (g', cs, lr).
Proof.
  elim: lsp E g E' g' cs lr => [| [ls1_hd ls2_hd] lsp_tl IH ]E g E' g' cs lr //=.
  - intros; dcase_hyps; subst; reflexivity.
  - dcase (mk_env_eq_neq_zip
             (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
             (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
    rewrite (IH _ _ _ _ _ _ Henv_tl).
      by case=> _ <- <- <-.
Qed.

Lemma mk_env_eq_zip_is_bit_blast_eq_zip E g lsp E' g' cs lrs:
  mk_env_eq_zip E g lsp = (E', g', cs, lrs) ->
  bit_blast_eq_zip g lsp = (g', cs, lrs).
Proof.
  rewrite /mk_env_eq_zip /bit_blast_eq_zip /=; intros; dcase_hyps; subst.
  move: H.
  dcase (mk_env_eq_neq_zip
           (env_upd E g
                    (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)))
           (g + 1)%positive lsp) => [[[[? ?] ?] ?] H].
  rewrite (mk_env_eq_neq_zip_is_bit_blast_eq_neq_zip H).
    by case=> _ <- <- <-.
Qed.

Lemma mk_env_eq_is_bit_blast_eq E g ls1 ls2 E' g' cs lr:
  mk_env_eq E g ls1 ls2 = (E', g', cs, lr) ->
  bit_blast_eq g ls1 ls2 = (g', cs, lr).
Proof.
  exact: mk_env_eq_zip_is_bit_blast_eq_zip.
Qed.

Lemma mk_env_eq_neq_zip_newer_gen E g lsp E' g' cs lr:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lr) ->
  (g <=? g')%positive.
Proof.
  elim: lsp E g E' g' cs lr => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lr /=.
  - case; t_auto_newer.
  - dcase (mk_env_eq_neq_zip
             (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
             (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
    case=> _ <- _ _.
    move: (IH _ _ _ _ _ _ Henv_tl) => H.
    t_auto_newer.
Qed.

Lemma mk_env_eq_zip_newer_gen E g lsp E' g' cs lrs:
  mk_env_eq_zip E g lsp = (E', g', cs, lrs) ->
  (g <=? g')%positive.
Proof.
  rewrite /mk_env_eq_zip /gen /=.
  dcase (mk_env_eq_neq_zip
           (env_upd E g
                    (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)))
           (g + 1)%positive lsp) => [[[[? ?] ?] ?] H].
  case=> _ <- _ _.
  move: (mk_env_eq_neq_zip_newer_gen H).
  by t_auto_newer.
Qed.

Lemma mk_env_eq_newer_gen E g ls1 ls2 E' g' cs lr:
  mk_env_eq E g ls1 ls2 = (E', g', cs, lr) ->
  (g <=? g')%positive.
Proof.
  exact: mk_env_eq_zip_newer_gen.
Qed.

Lemma mk_env_eq_neq_zip_newer_res E g lsp E' g' cs lr:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lr) ->
  newer_than_lits g' lr.
Proof.
  elim: lsp E g E' g' cs lr => [| [ls1_hd ls2_hd] lsp_tl IH] E g E' g' cs lr /=.
  - by case=> _ <- _ <-.
  - dcase (mk_env_eq_neq_zip
             (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
             (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
    case=> _ <- _ <-.
    move: (IH _ _ _ _ _ _ Henv_tl) => H.
    move: (mk_env_eq_neq_zip_newer_gen Henv_tl) => H2.
    t_auto_newer.
    rewrite /newer_than_lit /newer_than_var /=.
    by t_auto_newer.
Qed.

Lemma mk_env_eq_zip_newer_res E g lsp E' g' cs lr:
  mk_env_eq_zip E g lsp = (E', g', cs, lr) ->
  newer_than_lit g' lr.
Proof.
  rewrite /mk_env_eq_zip /gen /=.
  dcase (mk_env_eq_neq_zip
           (env_upd E g
                    (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)))
           (g + 1)%positive lsp) => [[[[E_aux g_aux] cs_neq] auxs] H].
  case=> _ <- _ <-.
  move: (mk_env_eq_neq_zip_newer_gen H).
  t_auto_newer.
    rewrite /newer_than_lit /newer_than_var /=.
  by t_auto_newer.
Qed.

Lemma mk_env_eq_newer_res E g ls1 ls2 E' g' cs lr:
  mk_env_eq E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g' lr.
Proof.
  exact: mk_env_eq_zip_newer_res.
Qed.

Lemma bit_blast_eq_eq_zip_newer_cnf g lsp g':
  (g <? g')%positive ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_cnf g' (bit_blast_eq_eq_zip (Pos g) lsp).
Proof.
  elim: lsp g g' => [| [ls1_hd ls2_hd] lsp_tl IH] g g' //=.
  move=> Hgg' /andP [Hnew_gls1hd Hnew_gls1tl] /andP [Hnew_gls2hd Hnew_gls2tl].
  rewrite !newer_than_lit_neg.
  split_andb_goal; t_auto_newer.
  by apply: IH.
Qed.

Lemma mk_env_eq_neq_zip_newer_cnf E g lsp E' g' cs lr:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lr) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_cnf g' cs.
Proof.
  elim: lsp E g E' g' cs lr => [| [ls1_hd ls2_hd] lsp_tl IH] E g  E' g' cs lr //=.
  - by case=> _ <- <- _.
  - dcase (mk_env_eq_neq_zip
             (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
             (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
    case=> _ <- <- _.
    move: (IH _ _ _ _ _ _ Henv_tl) => H.
    move: (mk_env_eq_neq_zip_newer_gen Henv_tl) => H2.
    move=> /andP [Hnew_gls1hd Hnew_gls1tl] /andP [Hnew_gls2hd Hnew_gls2tl].
    rewrite /= !newer_than_lit_neg.
    split_andb_goal; t_auto_newer.
    all:  rewrite /newer_than_lit /newer_than_var /=; t_auto_newer.
      by apply: H; t_auto_newer.
Qed.

Lemma mk_env_eq_zip_newer_cnf E g lsp E' g' cs lr:
  mk_env_eq_zip E g lsp = (E', g', cs, lr) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_eq_zip /gen /=.
  dcase (mk_env_eq_neq_zip
           (env_upd E g
                    (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)))
           (g + 1)%positive lsp) => [[[[E_aux g_aux] cs_neq] auxs] H].
  case=> _ <- <- _.
  move: (mk_env_eq_neq_zip_newer_gen H) => Hg1gg Hnew_gls1 Hnew_gls2.
  move: (mk_env_eq_neq_zip_newer_res H) => Hnres_eq_neq.
  move: (mk_env_eq_neq_zip_newer_cnf H) => Hncnf_eq_neq.
  have Hggaux: (g <? g_aux)%positive by t_auto_newer.
  move: (bit_blast_eq_eq_zip_newer_cnf Hggaux Hnew_gls1 Hnew_gls2) => Hncnf_eq_eq.
  t_auto_newer.
  by apply: Hncnf_eq_neq; t_auto_newer.
Qed.

Lemma mk_env_eq_newer_cnf E g ls1 ls2 E' g' cs lr:
  mk_env_eq E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  newer_than_cnf g' cs.
Proof.
  rewrite /mk_env_eq.
  move=> Hzip.
  move: (mk_env_eq_zip_newer_cnf Hzip) => Hncnf_zip.
  move=> Hgtt Hgls1 Hgls2.
    by apply: Hncnf_zip; t_auto_newer.
Qed.

Lemma mk_env_eq_neq_zip_preserve E g lsp E' g' cs lr:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lr) ->
  env_preserve E E' g.
Proof.
  elim: lsp E g E' g' cs lr => [| [ls1_hd ls2_hd] lsp_tl IH] E g  E' g' cs lr //=.
  - by case=> <- _ _ _.
  - dcase (mk_env_eq_neq_zip
             (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
             (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
    case=> <- _ _ _.
    move: (IH _ _ _ _ _ _ Henv_tl) => H.
    have H2: (env_preserve
        (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
        E_tl (g)
) by t_auto_preserve.
    by t_auto_preserve.
Qed.

Lemma mk_env_eq_zip_preserve E g lsp E' g' cs lr:
  mk_env_eq_zip E g lsp = (E', g', cs, lr) ->
  env_preserve E E' g.
Proof.
  rewrite /mk_env_eq_zip /gen /=.
  dcase (mk_env_eq_neq_zip
           (env_upd E g
                    (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)))
           (g + 1)%positive lsp) => [[[[E_aux g_aux] cs_neq] auxs] H].
  case=> <- _ _ _.
  move: (mk_env_eq_neq_zip_preserve H) => Hpre_eq_neq.
  eapply env_preserve_env_upd_succ.
  exact: Hpre_eq_neq.
Qed.

Lemma mk_env_eq_preserve E g ls1 ls2 E' g' cs lr:
  mk_env_eq E g ls1 ls2 = (E', g', cs, lr) ->
  env_preserve E E' g.
Proof.
  exact: mk_env_eq_zip_preserve.
Qed.

Lemma mk_env_eq_neq_zip_sat E g lsp E' g' cs lr:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lr) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  interp_cnf E' cs.
Proof.
  elim: lsp E g E' g' cs lr => [| [ls1_hd ls2_hd] lsp_tl IH] E g  E' g' cs lr //=.
  - by case=> <- _ <- _.
  - dcase (mk_env_eq_neq_zip
             (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
             (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
    case=> <- _ <- _.
    move: (IH _ _ _ _ _ _ Henv_tl) => IHH.
    move: (mk_env_eq_neq_zip_newer_gen Henv_tl) => H2.
    move=> /andP [Hnew_gls1hd Hnew_gls1tl] /andP [Hnew_gls2hd Hnew_gls2tl].
    rewrite /=.
    have -> : (interp_cnf E_tl cs_tl) by apply: IHH; t_auto_newer.
    rewrite /= !interp_lit_neg_lit.
    move: (mk_env_eq_neq_zip_preserve Henv_tl) => Hpre.
    move: (env_preserve_lit Hpre (newer_than_lit_add_diag_r (Pos g) 1))=> /= H_etlg.
    rewrite env_upd_eq in H_etlg.
    rewrite H_etlg.
    have Hnew_g1ls1hd: (newer_than_lit (g+1) ls1_hd) by t_auto_newer.
    have Hnew_g1ls2hd: (newer_than_lit (g+1) ls2_hd) by t_auto_newer.
    move: (env_preserve_lit Hpre Hnew_g1ls1hd) (env_preserve_lit Hpre Hnew_g1ls2hd).
    rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hnew_gls1hd)).
    rewrite (interp_lit_env_upd_neq _ _ (newer_than_lit_neq Hnew_gls2hd)).
    move=> -> ->.
    by case: (interp_lit E ls1_hd); case: (interp_lit E ls2_hd).
Qed.

Lemma bit_blast_eq_eq_zip_sat_eq (E:env) g lsp:
  E g ->
  interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp) ->
  interp_cnf E (bit_blast_eq_eq_zip (Pos g) lsp).
Proof.
  elim: lsp E g => [| [ls1_hd ls2_hd] lsp_tl IH] E g //=.
  move=> Heg.
  move/eqP => Heq_tl.
  inversion Heq_tl.
  move/eqP: H1 => H1.
  rewrite (IH E _  Heg H1).
  rewrite !interp_lit_neg_lit.
  by rewrite Heg -H0; case: (interp_lit E ls1_hd).
Qed.

Lemma bit_blast_eq_eq_zip_sat_neq (E:env) g lsp:
  ~~ E g ->
  interp_cnf E (bit_blast_eq_eq_zip (Pos g) lsp).
Proof.
  elim: lsp E g => [| [ls1_hd ls2_hd] lsp_tl IH] E g //=.
  move=> Heg.
  rewrite (IH E _  Heg).
  rewrite !interp_lit_neg_lit.
  by rewrite Heg.
Qed.

Lemma mk_env_eq_neq_zip_sat_neq E g lsp E' g' cs lrs:
  mk_env_eq_neq_zip E g lsp = (E', g', cs, lrs) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  interp_word E' (unzip1 lsp) != interp_word E' (unzip2 lsp) ->
  interp_clause E' lrs.
Proof.
  elim: lsp E g E' g' cs lrs => [| [ls1_hd ls2_hd] lsp_tl IH] E g  E' g' cs lrs //=.
  dcase (mk_env_eq_neq_zip
           (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd)))
           (g + 1)%positive lsp_tl) => [[[[E_tl g_tl] cs_tl] auxs_tl] Henv_tl].
  case=> <- _ _ <-.
  move: (IH _ _ _ _ _ _ Henv_tl) => IHH.
  move: (mk_env_eq_neq_zip_newer_gen Henv_tl) => H2.
  move=> /andP [Hnew_gls1hd Hnew_gls1tl] /andP [Hnew_gls2hd Hnew_gls2tl].
  rewrite /=.
  move=> Hneq.
  rewrite seq_neq_split in Hneq.
  case/orP: Hneq => Hneq.
  - move: (mk_env_eq_neq_zip_preserve Henv_tl) => Hpre.
    move: (env_preserve_lit Hpre (newer_than_lit_add_diag_r (Pos g) 1))=> /= H_etlg.
    rewrite env_upd_eq in H_etlg.
    rewrite H_etlg.
    have Hpre2: (env_preserve (env_upd E g (xorb (interp_lit E ls1_hd) (interp_lit E ls2_hd))) E_tl g) by t_auto_preserve.
    have Hpre3: (env_preserve E E_tl g) by t_auto_preserve.
    move: (env_preserve_lit Hpre3 Hnew_gls1hd) (env_preserve_lit Hpre3 Hnew_gls2hd).
    move=> <- <-.
      by move: Hneq; case: (interp_lit E_tl ls1_hd); case: (interp_lit E_tl ls2_hd).
  - apply /orP; right.
    by apply IHH; t_auto_newer.
Qed.

Lemma mk_env_eq_zip_sat E g lsp E' g' cs lr:
  mk_env_eq_zip E g lsp = (E', g', cs, lr) ->
  newer_than_lits g (unzip1 lsp) -> newer_than_lits g (unzip2 lsp) ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_eq_zip /gen /=.
  dcase (mk_env_eq_neq_zip
           (env_upd E g
                    (interp_word E (unzip1 lsp) == interp_word E (unzip2 lsp)))
           (g + 1)%positive lsp) => [[[[E_aux g_aux] cs_neq] auxs] H].
  case=> <- _ <- _ Hnew_gls1 Hnew_gls2.
  move: (mk_env_eq_neq_zip_newer_gen H) => Hg1gg.
  move: (mk_env_eq_neq_zip_newer_res H) => Hnres_eq_neq.
  move: (mk_env_eq_neq_zip_newer_cnf H) => Hncnf_eq_neq.
  move: (mk_env_eq_neq_zip_sat H) => Hsat_eq_neq.
  have Hggaux: (g <? g_aux)%positive by t_auto_newer.
  rewrite interp_cnf_catrev interp_cnf_cons.
  have -> : interp_cnf E_aux cs_neq by apply Hsat_eq_neq; t_auto_newer.
  rewrite andTb.
  rewrite interp_clause_cons.
  move: (mk_env_eq_neq_zip_preserve H) => Hpre.
  move: (env_preserve_lit Hpre (newer_than_lit_add_diag_r (Pos g) 1))=> /= H_etlg.
  rewrite env_upd_eq in H_etlg.
  move: H_etlg.
  move: (env_preserve_env_upd_succ Hpre) => Hpre2.
  rewrite -(env_preserve_word Hpre2 Hnew_gls1) -(env_preserve_word Hpre2 Hnew_gls2).
  case Heg: (E_aux g).
  - rewrite /=. move=> Heq. move: (Logic.eq_sym Heq) => {Heq} Heq.
    exact: (bit_blast_eq_eq_zip_sat_eq Heg Heq).
  - rewrite /=. move=> Hne. move: (Logic.eq_sym Hne) => {Hne} Hne.
    move/idP/negP: Hne => Hne. move/idP/negP: Heg => Heg.
    rewrite (bit_blast_eq_eq_zip_sat_neq lsp Heg) andbT.
    by apply: (mk_env_eq_neq_zip_sat_neq H _ _ Hne); t_auto_newer.
Qed.

Lemma mk_env_eq_sat E g ls1 ls2 E' g' cs lr:
  mk_env_eq E g ls1 ls2 = (E', g', cs, lr) ->
  newer_than_lit g lit_tt ->
  newer_than_lits g ls1 -> newer_than_lits g ls2 ->
  interp_cnf E' cs.
Proof.
  rewrite /mk_env_eq.
  move=> Hzip.
  move: (mk_env_eq_zip_sat Hzip) => Hsat_zip.
  move=> Hgtt Hgls1 Hgls2.
    by apply: Hsat_zip; t_auto_newer.
Qed.

Lemma mk_env_eq_neq_zip_env_equal E1 E2 g lsp E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_eq_neq_zip E1 g lsp = (E1', g1', cs1, lrs1) ->
  mk_env_eq_neq_zip E2 g lsp = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  elim: lsp E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 =>
  [| [l1 l2] lsp IH] //= E1 E2 g E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 Heq.
  - case=> ? ? ? ?; case=> ? ? ? ?; subst. done.
  - rewrite (env_equal_interp_lit l1 Heq) (env_equal_interp_lit l2 Heq).
    dcase (mk_env_eq_neq_zip (env_upd E1 g (xorb (interp_lit E2 l1) (interp_lit E2 l2)))
                             (g + 1)%positive lsp) => [[[[E_tl1 g_tl1] cs_tl1] lrs_tl1] Hbb_tl1].
    dcase (mk_env_eq_neq_zip (env_upd E2 g (xorb (interp_lit E2 l1) (interp_lit E2 l2)))
                             (g + 1)%positive lsp) => [[[[E_tl2 g_tl2] cs_tl2] lrs_tl2] Hbb_tl2].
    case=> ? ? ? ?; case=> ? ? ? ?; subst.
    move: (env_equal_upd g (xorb (interp_lit E2 l1) (interp_lit E2 l2)) Heq) => Heq1.
    move: (IH _ _ _ _ _ _ _ _ _ _ _ Heq1 Hbb_tl1 Hbb_tl2) => [Heq2 [? [? ?]]]; subst.
    done.
Qed.

Lemma mk_env_eq_zip_env_equal E1 E2 g lsp E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_eq_zip E1 g lsp = (E1', g1', cs1, lrs1) ->
  mk_env_eq_zip E2 g lsp = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  rewrite /mk_env_eq_zip => Heq. dcase (gen g) => [[g1 r1] Hg1].
  dcase (mk_env_eq_neq_zip
           (env_upd E1 (var_of_lit r1)
                    (interp_word E1 (unzip1 lsp) == interp_word E1 (unzip2 lsp)))
           g1 lsp) => [[[[E_aux1 g_aux1] cs_aux1] lrs_aux1] Hbb_aux1].
  dcase (mk_env_eq_neq_zip
           (env_upd E2 (var_of_lit r1)
                    (interp_word E2 (unzip1 lsp) == interp_word E2 (unzip2 lsp)))
           g1 lsp) => [[[[E_aux2 g_aux2] cs_aux2] lrs_aux2] Hbb_aux2].
  case=> ? ? ? ?; case=> ? ? ? ?; subst.
  rewrite !(env_equal_interp_word _ Heq) in Hbb_aux1.
  move: (env_equal_upd (var_of_lit lrs2)
                       (interp_word E2 (unzip1 lsp) == interp_word E2 (unzip2 lsp)) Heq) => Heq1.
  move: (mk_env_eq_neq_zip_env_equal Heq1 Hbb_aux1 Hbb_aux2) => [Heq2 [? [? ?]]]; subst.
  done.
Qed.

Lemma mk_env_eq_env_equal E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_eq E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_eq E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof. exact: mk_env_eq_zip_env_equal. Qed.


From Perennial.algebra Require Import gen_heap_names.
From Perennial.goose_lang Require Import adequacy recovery_adequacy dist_adequacy.
From Perennial.program_proof Require Import grove_prelude.
From Goose.github_com.mit_pdos.gokv Require Import memkv.

From Perennial.program_proof.memkv Require Export memkv_shard_definitions memkv_coord_definitions.

Section memkv_coord_ghost_init_proof.

(* These lemmas happen *before* we get node local names (e.g. the gname for memory, crashes etc. *)
Context `{!gooseGlobalGS Σ, erpcG Σ, urpcregG Σ, kvMapG Σ}.

Definition coord_SpecList γkv : uRPCSpecList :=
  spec_cons (is_coord_server_addSpec γkv)
    (spec_cons (is_coord_server_getSpec γkv) spec_nil).

Lemma coord_server_ghost_init host (γkv : gname) :
  host c↦ ∅ ={⊤}=∗
  ∃ γ, ⌜ γ.(coord_kv_gn) = γkv ⌝ ∗
       handlers_dom γ.(coord_urpc_gn) (dom_uRPCSpecList (coord_SpecList (γ.(coord_kv_gn)))) ∗
       is_coord_server host γ.
Proof.
  iIntros "Hg".
  iMod (handler_is_init_list host (coord_SpecList γkv) with "[Hg]") as (γ) "H".
  { simpl. set_solver. }
  { iExactEq "Hg". f_equal. }
  iDestruct "H" as "(#Hdom&#Hadd&#Hget&_)".

  set (Γsrv := {| coord_urpc_gn := γ; coord_kv_gn := γkv |}).
  iAssert (is_coord_server host Γsrv) as "Hcoord".
  {
    iSplitL. { iFrame "Hadd". }
    iFrame "Hget".
  }
  iExists Γsrv. iFrame "# ∗".
  eauto.
Qed.

End memkv_coord_ghost_init_proof.