From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude finite.
From Coq Require Import FinFun Program.
From VLSM.Lib Require Import Preamble ListExtras.
From VLSM.Core Require Import VLSM VLSMProjections Composition SubProjectionTraces.
From VLSM.Core Require Import Equivocation Equivocation.NoEquivocation.
From VLSM.Core Require Import Equivocators.Equivocators Equivocators.EquivocatorsProjections.
From VLSM.Core Require Import Equivocators.EquivocatorReplay Equivocators.MessageProperties.
From VLSM.Core Require Import Equivocators.EquivocatorsComposition.
From VLSM.Core Require Import Equivocators.EquivocatorsCompositionProjections Plans.

(** * VLSM Equivocator Full Replay Traces

  In this section we show that given a trace of equivocators, one can "replay"
  that at the end of an existing trace, by first equivocating for each initial
  state and then performing each transition, but appropriately "shifted".

  To make the results more general, we take the trace to be replayed to be
  produced by a restricted set of equivocators pre-loaded with messages
  satisfying some conditions.
*)

Section sec_all_equivocating.

Context {message : Type}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i : index, HasBeenSentCapability (IM i)}
  `{forall i : index, HasBeenReceivedCapability (IM i)}
  (seed : message -> Prop)
  (equivocating : list index)
  (equiv_index : Type := sub_index equivocating)
  (equivocator_descriptors := equivocator_descriptors IM)
  (equivocators_state_project := equivocators_state_project IM)
  (equivocator_IM := equivocator_IM IM)
  (sub_equivocator_IM := sub_IM equivocator_IM equivocating)
  (sub_IM := sub_IM IM equivocating)
  (equivocator_descriptors_update := equivocator_descriptors_update IM)
  (proper_equivocator_descriptors := proper_equivocator_descriptors IM)
  (equivocators_trace_project := equivocators_trace_project IM)
  (Free := free_composite_vlsm IM)
  (FreeE := free_composite_vlsm equivocator_IM)
  (PreFreeE := pre_loaded_with_all_messages_vlsm FreeE)
  (FreeSubE := free_composite_vlsm sub_equivocator_IM)
  (PreFreeSubE := pre_loaded_with_all_messages_vlsm FreeSubE)
  (SeededXE : VLSM message := seeded_equivocators_no_equivocation_vlsm IM equivocating seed)
  (equivocators_no_equivocations_vlsm := equivocators_no_equivocations_vlsm IM)
.

#[local] Hint Unfold equivocator_descriptors_update : state_update.

Lemma SeededXE_Free_embedding
  (Hseed : forall m, seed m -> valid_message_prop FreeE m)
  : VLSM_embedding SeededXE
    (composite_vlsm equivocator_IM (free_constraint equivocator_IM))
    (lift_sub_label equivocator_IM equivocating) (lift_sub_state equivocator_IM equivocating).
Proof.
  apply basic_VLSM_embedding; intros ? *.
  - split; [| done].
    by apply lift_sub_valid, Hv.
  - by intros [_ Ht]; revert Ht; apply lift_sub_transition.
  - by intros; apply (lift_sub_state_initial equivocator_IM).
  - intros; destruct HmX as [Hinit | Hseeded]; [| by apply Hseed].
    apply initial_message_is_valid.
    destruct Hinit as [i Him].
    by exists (proj1_sig i).
Qed.

(**
  Given a <<base_s>>tate to replay on, the replay label corresponding to a
  given transition label is obtained as the [equivocator_state_append_label].
*)
Definition lift_equivocators_sub_label_to
  (base_s : composite_state equivocator_IM)
  (l : composite_label sub_equivocator_IM)
  : composite_label equivocator_IM
  :=
  let (sub_i, li) := l in
  let i := proj1_sig sub_i in
  existT i (equivocator_state_append_label (IM i) (base_s i) li).

(**
  Given a <<base_s>>tate to replay on, the replay state corresponding to a
  destination state in a transition by appending its components to the
  base state using [equivocator_state_append].
*)
Definition lift_equivocators_sub_state_to
  (base_s : composite_state equivocator_IM)
  (s : composite_state sub_equivocator_IM)
  : composite_state equivocator_IM
  := fun i =>
    match @decide  (sub_index_prop equivocating i) (sub_index_prop_dec equivocating i) with
    | left e =>  equivocator_state_append (base_s i) (s (dexist i e))
    | _ => base_s i
    end.

Lemma lift_equivocators_sub_state_to_sub
  (base_s : composite_state equivocator_IM)
  (s : composite_state sub_equivocator_IM)
  i
  (Hi : sub_index_prop equivocating i)
  : lift_equivocators_sub_state_to base_s s i
      =
    equivocator_state_append (base_s i) (s (dexist i Hi)).
Proof.
  unfold lift_equivocators_sub_state_to.
  case_decide as H_i; [| done].
  by rewrite (sub_IM_state_pi s H_i Hi).
Qed.

Lemma lift_equivocators_sub_state_to_size
  (base_s : composite_state equivocator_IM)
  (s : composite_state sub_equivocator_IM)
  : forall i,
    equivocator_state_n (base_s i) <= equivocator_state_n (lift_equivocators_sub_state_to base_s s i).
Proof.
  intro i.
  unfold lift_equivocators_sub_state_to.
  destruct (decide _); [| lia].
  by rewrite equivocator_state_append_size; lia.
Qed.

(** The plan item corresponding to an initial state equivocation. *)
Definition initial_new_machine_transition_item
  (is : composite_state sub_equivocator_IM)
  (eqv : equiv_index)
  : composite_plan_item equivocator_IM
  :=
  let i := proj1_sig eqv in
  let seqv := is eqv in
  let new_l :=
    (existT i (Spawn (equivocator_state_zero seqv)))
    in
  @Build_plan_item message (composite_type equivocator_IM) new_l None.

(** Command for equivocating all states of an initial composite state. *)
Definition spawn_initial_state
  (is : composite_state sub_equivocator_IM)
  : composite_plan equivocator_IM
  := map (initial_new_machine_transition_item is) (enum (sub_index equivocating)).

Definition replayed_initial_state_from full_replay_state is :=
  fst (composite_apply_plan equivocator_IM full_replay_state (spawn_initial_state is)).

(**
  The final state obtained after replaying an initial state is precisely
  the lifting of that initial state over the given base state.
*)
Lemma replayed_initial_state_from_lift
  (full_replay_state : composite_state equivocator_IM)
  (is : composite_state sub_equivocator_IM)
  (His : composite_initial_state_prop sub_equivocator_IM is)
  : finite_trace_last full_replay_state (replayed_initial_state_from full_replay_state is)
    = lift_equivocators_sub_state_to full_replay_state is.
Proof.
  cut (forall l (Hincl : incl l (enum (sub_index equivocating))) (Hnodup : NoDup l),
    let tr_full_replay_is :=
      composite_apply_plan equivocator_IM full_replay_state
        (map (initial_new_machine_transition_item is)
          l) in
    (forall i : index,
      tr_full_replay_is.2 i =
      match @decide  (sub_index_prop equivocating i) (sub_index_prop_dec equivocating i) with
      | left e =>
        let eqv := (dexist i e) in
        if (decide (eqv ∈ l)) then equivocator_state_append (full_replay_state i) (is eqv)
        else full_replay_state i
      | _ =>  full_replay_state i
      end)).
  {
    intros Hcut; specialize (Hcut _ (incl_refl _) ltac:(apply NoDup_enum)).
    unfold replayed_initial_state_from, composite_apply_plan.
    rewrite _apply_plan_last; extensionality i.
    specialize (Hcut i); unfold composite_apply_plan in Hcut; unfold spawn_initial_state
    ; simpl in *; rewrite Hcut.
    unfold lift_equivocators_sub_state_to.
    case_decide; [| done].
    rewrite decide_True; [done |].
    by apply elem_of_enum.
  }
  induction l using rev_ind; intros.
  - case_decide; [| done].
    by rewrite decide_False; [| inversion 1].
  - spec IHl; [by apply incl_app_inv in Hincl; apply Hincl |].
    spec IHl; [by apply NoDup_app in Hnodup; apply Hnodup |].
    subst tr_full_replay_is.
    rewrite map_app, (composite_apply_plan_app equivocator_IM); simpl in *
    ; destruct (composite_apply_plan _ _ _) as (aitems, afinal); simpl in *.
    specialize (IHl i); destruct_dec_sig x ix Hix Heqx; subst x; simpl in *.
    case_decide as _Hix; cycle 1;
      destruct (decide (ix = i)); subst; equivocator_state_update_simpl; [done | done | |].
    + rewrite decide_False in IHl.
      * rewrite IHl, decide_True.
        -- rewrite (sub_IM_state_pi is _Hix Hix); symmetry.
           by apply equivocator_state_append_singleton_is_extend, (His (dexist i Hix)).
        -- rewrite elem_of_app, elem_of_list_singleton; right.
           by apply dsig_eq.
      * intro Heqv.
        apply NoDup_app in Hnodup as (_ & Hnodup & _).
        eapply Hnodup; [done |].
        rewrite elem_of_list_singleton.
        by apply dsig_eq.
    + case_decide.
      * rewrite decide_True; rewrite ?elem_of_app; itauto.
      * rewrite decide_False; [done |].
        intros [Hin | Hx]%elem_of_app; [done |].
        by rewrite elem_of_list_singleton, dsig_eq in Hx.
Qed.

(**
  For any [equivocator_descriptors] corresponding to the base state
  the projection of the replaying of an initial state is empty.
*)
Lemma equivocators_trace_project_replayed_initial_state_from full_replay_state is
  (eqv_descriptors : equivocator_descriptors)
  (Heqv_descriptors : not_equivocating_equivocator_descriptors IM eqv_descriptors full_replay_state)
  : equivocators_trace_project eqv_descriptors
      (replayed_initial_state_from full_replay_state is) =
    Some ([], eqv_descriptors).
Proof.
  unfold replayed_initial_state_from, spawn_initial_state.
  generalize (enum (sub_index equivocating)).
  intro l.
  remember (composite_apply_plan _ _ _) as plan.
  apply proj1 with
    (forall i, equivocator_state_n (full_replay_state i) <= equivocator_state_n (plan.2 i)).
  subst plan.
  induction l using rev_ind; [split; simpl; [done | lia] |].
  rewrite map_app, (composite_apply_plan_app equivocator_IM).
  destruct (composite_apply_plan _ _ _) as (litems, lfinal) eqn: Hplanl.
  destruct (composite_apply_plan _ lfinal _) as (aitems, afinal) eqn: Hplana.
  simpl in *.
  inversion_clear Hplana.
  split.
  - apply equivocators_trace_project_app_iff.
    exists [], [], eqv_descriptors.
    repeat split; [| by apply IHl].
    specialize (Heqv_descriptors (` x)).
    unfold existing_descriptor in Heqv_descriptors.
    destruct (eqv_descriptors (` x)) eqn: Heqv_x; [done |].
    destruct Heqv_descriptors as [s_x_n Heqv_descriptors].
    apply equivocator_state_project_Some_rev in Heqv_descriptors as Hltn.
    apply proj2 in IHl.
    specialize (IHl (` x)).
    cbn. unfold equivocators_transition_item_project; simpl.
    unfold equivocator_vlsm_transition_item_project. rewrite Heqv_x.
    simpl; equivocator_state_update_simpl.
    rewrite decide_False by lia.
    destruct_equivocator_state_project (lfinal (` x)) n lfinal_x_n Hltn'; [| lia].
    by equivocator_state_update_simpl.
  - intro i. apply proj2 in IHl. specialize (IHl i).
    by destruct (decide (i = `x)); subst; equivocator_state_update_simpl; [lia |].
Qed.

Lemma equivocator_state_project_replayed_initial_state_from_left full_replay_state is
  (lst := finite_trace_last full_replay_state (replayed_initial_state_from full_replay_state is))
  : forall i j,
    j < equivocator_state_n (full_replay_state i) ->
    equivocator_state_project (lst i) j =
    equivocator_state_project (full_replay_state i) j.
Proof.
  subst lst.
  unfold replayed_initial_state_from, spawn_initial_state.
  generalize (enum (sub_index equivocating)).
  intro l.
  induction l using rev_ind; simpl; [done |].
  rewrite map_app, (composite_apply_plan_app equivocator_IM).
  specialize (composite_apply_plan_last equivocator_IM full_replay_state
    (map (initial_new_machine_transition_item is) l)) as Hlst.
  destruct (composite_apply_plan _ _ _) as (litems, lfinal) eqn: Hplanl.
  destruct (composite_apply_plan _ lfinal _) as (aitems, afinal) eqn: Hplana.
  inversion_clear Hplana.
  simpl in *.
  rewrite finite_trace_last_is_last. simpl.
  intros i j Hj.
  destruct (decide (`x = i)); subst; equivocator_state_update_simpl; [| by auto].
  specialize (IHl (` x) j Hj).
  destruct_equivocator_state_project (full_replay_state (` x)) j s_x_j Hltj; [| lia].
  rewrite equivocator_state_extend_project_1; [done |].
  by apply equivocator_state_project_Some_rev in IHl as Hltj'.
Qed.

Lemma equivocator_state_descriptor_project_replayed_initial_state_from_left full_replay_state is
  (eqv_descriptors : equivocator_descriptors)
  (Heqv_descriptors : not_equivocating_equivocator_descriptors IM eqv_descriptors full_replay_state)
  (lst := finite_trace_last full_replay_state (replayed_initial_state_from full_replay_state is))
  : forall i,
    equivocator_state_descriptor_project (lst i) (eqv_descriptors i) =
    equivocator_state_descriptor_project (full_replay_state i) (eqv_descriptors i).
Proof.
  intro i. specialize (Heqv_descriptors i).
  unfold equivocator_state_descriptor_project.
  unfold existing_descriptor in Heqv_descriptors.
  destruct (eqv_descriptors i) as [sn | ji]; [done |].
  destruct Heqv_descriptors as [full_i_ji Hpr_ji].
  apply equivocator_state_project_Some_rev in Hpr_ji as Hltji.
  subst lst.
  by rewrite equivocator_state_project_replayed_initial_state_from_left, Hpr_ji.
Qed.

Definition replayed_trace_from full_replay_state is tr :=
  replayed_initial_state_from full_replay_state is ++
  pre_VLSM_embedding_finite_trace_project (type FreeSubE) (type FreeE)
    (lift_equivocators_sub_label_to full_replay_state)
    (lift_equivocators_sub_state_to full_replay_state) tr.

Lemma replayed_trace_from_finite_trace_last full_replay_state is tr
  (His : composite_initial_state_prop _ is)
  : finite_trace_last full_replay_state (replayed_trace_from full_replay_state is tr) =
    (lift_equivocators_sub_state_to full_replay_state (finite_trace_last is tr)).
Proof.
  destruct_list_last tr tr' item Htr; subst.
  - unfold replayed_trace_from. cbn.
    rewrite app_nil_r.
    by apply replayed_initial_state_from_lift.
  - unfold replayed_trace_from, pre_VLSM_embedding_finite_trace_project.
    by rewrite map_app, app_assoc; cbn; rewrite !finite_trace_last_is_last.
Qed.

Lemma equivocator_state_project_replayed_trace_from_left full_replay_state is tr
  (lst := finite_trace_last full_replay_state (replayed_trace_from full_replay_state is tr))
  : forall i j,
    j < equivocator_state_n (full_replay_state i) ->
    equivocator_state_project (lst i) j =
    equivocator_state_project (full_replay_state i) j.
Proof.
  subst lst.
  unfold replayed_trace_from.
  destruct_list_last tr tr' lst Htr.
  - simpl. rewrite app_nil_r.
    by apply equivocator_state_project_replayed_initial_state_from_left.
  - unfold pre_VLSM_embedding_finite_trace_project.
    rewrite map_app, app_assoc. simpl.
    rewrite finite_trace_last_is_last.
    simpl.
    intros i j Hltj.
    unfold lift_equivocators_sub_state_to.
    destruct (decide _); [| done].
    by rewrite equivocator_state_append_project_1.
Qed.

Lemma equivocator_state_descriptor_project_replayed_trace_from_left full_replay_state is tr
  (eqv_descriptors : equivocator_descriptors)
  (Heqv_descriptors : not_equivocating_equivocator_descriptors IM eqv_descriptors full_replay_state)
  (lst := finite_trace_last full_replay_state (replayed_trace_from full_replay_state is tr))
  : forall i,
    equivocator_state_descriptor_project (lst i) (eqv_descriptors i) =
    equivocator_state_descriptor_project (full_replay_state i) (eqv_descriptors i).
Proof.
  intro i. specialize (Heqv_descriptors i).
  unfold equivocator_state_descriptor_project.
  unfold existing_descriptor in Heqv_descriptors.
  destruct (eqv_descriptors i) as [sn | ji]; [done |].
  destruct Heqv_descriptors as [full_i_ji Hpr_ji].
  apply equivocator_state_project_Some_rev in Hpr_ji as Hltji.
  subst lst.
  by rewrite equivocator_state_project_replayed_trace_from_left, Hpr_ji.
Qed.

Lemma equivocators_total_state_project_replayed_trace_from full_replay_state is tr
  (lst := finite_trace_last full_replay_state (replayed_trace_from full_replay_state is tr))
  : equivocators_total_state_project IM lst = equivocators_total_state_project IM full_replay_state.
Proof.
  apply functional_extensionality_dep.
  intro i.
  apply equivocator_state_descriptor_project_replayed_trace_from_left.
  by apply zero_descriptor_not_equivocating.
Qed.

Lemma equivocators_trace_project_replayed_trace_from_left full_replay_state is tr
  (eqv_descriptors : equivocator_descriptors)
  (Heqv_descriptors : not_equivocating_equivocator_descriptors IM eqv_descriptors full_replay_state)
  : equivocators_trace_project eqv_descriptors
      (replayed_trace_from full_replay_state is tr) =
    Some ([], eqv_descriptors).
Proof.
  apply equivocators_trace_project_app_iff.
  exists [], [], eqv_descriptors.
  repeat split; [| by apply equivocators_trace_project_replayed_initial_state_from].
  induction tr using rev_ind; [done |].
  unfold pre_VLSM_embedding_finite_trace_project.
  rewrite map_app.
  apply equivocators_trace_project_app_iff.
  exists [], [], eqv_descriptors.
  repeat split; [| done].
  clear IHtr.
  destruct x. simpl.
  destruct l as (sub_i, li).
  destruct_dec_sig sub_i i Hi Heqsub_i.
  subst sub_i.
  specialize (Heqv_descriptors i).
  unfold existing_descriptor in Heqv_descriptors.
  destruct (eqv_descriptors _) eqn: Heqv_l; [done |].
  destruct Heqv_descriptors as [s_l_n Hs_l_n].
  apply equivocator_state_project_Some_rev in Hs_l_n as Hltn.
  specialize (lift_equivocators_sub_state_to_size full_replay_state destination i)
    as Hltsize.
  unfold equivocators_transition_item_project. simpl.
  rewrite Heqv_l.
  simpl.
  destruct_equivocator_state_project
    (lift_equivocators_sub_state_to full_replay_state destination i) n
    lift_n Hlt_n; [| lia].
  rewrite (lift_equivocators_sub_state_to_sub) with (Hi := Hi).
  rewrite equivocator_state_append_lst.
  by destruct li as [sn_d | id li | id li]; simpl
  ; rewrite !decide_False by lia
  ; equivocator_state_update_simpl.
Qed.

Lemma equivocators_total_trace_project_replayed_trace_from full_replay_state is tr
  : equivocators_total_trace_project IM (replayed_trace_from full_replay_state is tr) = [].
Proof.
  unfold equivocators_total_trace_project.
  rewrite equivocators_trace_project_replayed_trace_from_left
  ; [done |].
  by apply zero_descriptor_not_equivocating.
Qed.

Lemma lift_equivocators_sub_valid
  (full_replay_state : composite_state equivocator_IM)
  l s om
  (Hv : composite_valid sub_equivocator_IM l (s, om))
  : composite_valid equivocator_IM (lift_equivocators_sub_label_to full_replay_state  l)
      (lift_equivocators_sub_state_to full_replay_state s, om).
Proof.
  destruct l as (sub_i, li).
  destruct_dec_sig sub_i i Hi Heqsub_i. subst sub_i.
  specialize
    (equivocator_state_append_valid (IM i) li
      (s (dexist i Hi)) om
      (full_replay_state i) Hv)
    as Hlift.
  cbn.
  by rewrite (lift_equivocators_sub_state_to_sub _ _ _ Hi).
Qed.

Lemma lift_equivocators_sub_transition
  (full_replay_state : composite_state equivocator_IM)
  l s om s' om'
  (Hv : composite_valid sub_equivocator_IM l (s, om))
  (Ht : composite_transition sub_equivocator_IM l (s, om) = (s', om'))
  : composite_transition equivocator_IM (lift_equivocators_sub_label_to full_replay_state  l)
      (lift_equivocators_sub_state_to full_replay_state s, om) =
      (lift_equivocators_sub_state_to full_replay_state s', om').
Proof.
  destruct l as (sub_i, li).
  destruct_dec_sig sub_i i Hi Heqsub_i. subst sub_i.
  specialize
    (equivocator_state_append_transition (IM i) li
      (s (dexist i Hi)) om
      (s' (dexist i Hi)) om'
      (full_replay_state i) Hv)
    as Hlift.
  cbn in Ht.
  destruct (equivocator_transition _ _ _) as (_si', _om').
  inversion Ht; subst s' om'; clear Ht.
  equivocator_state_update_simpl.
  specialize (Hlift eq_refl).
  cbn.
  rewrite (lift_equivocators_sub_state_to_sub _ _ _ Hi).
  replace (equivocator_transition _ _ _) with
    (equivocator_state_append (full_replay_state i) _si', _om').
  f_equal; extensionality j.
  destruct (decide (i = j)); subst; equivocator_state_update_simpl.
  - by rewrite (lift_equivocators_sub_state_to_sub _ _ _ Hi), state_update_eq.
  - unfold lift_equivocators_sub_state_to.
    destruct (decide _); [| done].
    by rewrite state_update_neq; [| inversion 1].
Qed.

Section sec_pre_loaded_constrained_projection.

(**
  By replaying a [valid_trace] on top of a [valid_state] we obtain a
  [valid_trace]. We derive this as a more general [VLSM_weak_embedding]
  result for a class of VLSM parameterized by a constraint having "good"
  properties and pre-loaded with a seed, to allow deriving the
  [VLSM_weak_embedding] result for both the free composition of equivocators
  and for the no message equivocation composition of equivocators (free, or with
  an additional fixed-set state-equivocation constraint).
*)

Context
  (constraint :
    composite_label equivocator_IM -> composite_state equivocator_IM * option message -> Prop)
  (seed1 : message -> Prop)
  (SeededCE := pre_loaded_vlsm (composite_vlsm equivocator_IM constraint) seed1)
  (Hconstraint_none : forall i ns s, i ∈ equivocating -> valid_state_prop SeededCE s ->
                        constraint (existT i (Spawn ns)) (s, None))
  (Hseed : forall m, seed m -> valid_message_prop SeededCE m)
  (full_replay_state : composite_state equivocator_IM)
  (Hfull_replay_state : valid_state_prop SeededCE full_replay_state)
  (Hsubsumption : forall l s om, input_valid SeededXE l (s, om) ->
    valid_state_prop SeededCE (lift_equivocators_sub_state_to full_replay_state s) ->
    constraint
      (lift_equivocators_sub_label_to full_replay_state l)
      (lift_equivocators_sub_state_to full_replay_state s, om))
  .

Lemma replayed_initial_state_from_valid
  (is : composite_state sub_equivocator_IM)
  (His : composite_initial_state_prop sub_equivocator_IM is)
  : finite_valid_trace_from SeededCE full_replay_state
      (replayed_initial_state_from full_replay_state is).
Proof.
  cut (forall l, incl l (enum (sub_index equivocating)) ->
    finite_valid_plan_from SeededCE
      full_replay_state (map (initial_new_machine_transition_item is) l)).
  { intros Hplan. specialize (Hplan _ (incl_refl _)).
    by unfold finite_valid_plan_from in Hplan.
  }
  intro l.
  induction l using rev_ind; intros Hincl.
  - by constructor.
  - spec IHl; [by intros i Hi; apply Hincl, in_app_iff; left |].
    rewrite map_app.
    apply finite_valid_plan_from_app_iff.
    split; [done |].
    apply finite_valid_trace_singleton. simpl.
    repeat split.
    + by apply apply_plan_last_valid.
    + by apply option_valid_message_None.
    + by apply His.
    + apply Hconstraint_none.
      * by destruct_dec_sig x i Hi Hx; subst.
      * apply finite_valid_trace_last_pstate in IHl.
        remember (finite_trace_last _ _) as lst.
        replace ((apply_plan _ _ _).2) with lst; [done |].
        by subst; apply apply_plan_last.
Qed.

Lemma lift_initial_message
  : forall m, vinitial_message_prop SeededXE m -> valid_message_prop SeededCE m.
Proof.
  intros m [Hinit | Hseeded].
  - apply initial_message_is_valid. destruct Hinit as [[i Hi] Hinit].
    by left; exists i.
  - by apply Hseed.
Qed.

Lemma lift_equivocators_sub_weak_projection :
  VLSM_weak_embedding SeededXE SeededCE
    (lift_equivocators_sub_label_to full_replay_state)
    (lift_equivocators_sub_state_to full_replay_state).
Proof.
  apply basic_VLSM_weak_embedding; intros ? *.
  - split.
    + by apply lift_equivocators_sub_valid, Hv.
    + by apply Hsubsumption.
  - by intros Ht; apply lift_equivocators_sub_transition; apply Ht.
  - intro; rewrite <- replayed_initial_state_from_lift; [| done].
    by apply finite_valid_trace_last_pstate, replayed_initial_state_from_valid.
  - by intros; apply lift_initial_message.
Qed.

Lemma sub_preloaded_replayed_trace_from_valid_equivocating
  (is : composite_state sub_equivocator_IM)
  (tr : list (composite_transition_item sub_equivocator_IM))
  (Htr : finite_valid_trace SeededXE is tr)
  : finite_valid_trace_from SeededCE
      full_replay_state (replayed_trace_from full_replay_state is tr).
Proof.
  destruct Htr as [Htr His].
  apply finite_valid_trace_from_app_iff.
  split; [by apply replayed_initial_state_from_valid |].
  rewrite replayed_initial_state_from_lift by done.
  by apply (VLSM_weak_embedding_finite_valid_trace_from lift_equivocators_sub_weak_projection).
Qed.

End sec_pre_loaded_constrained_projection.

Lemma SeededXE_PreFreeE_weak_embedding
  (full_replay_state : composite_state equivocator_IM)
  (Hfull_replay_state : valid_state_prop PreFreeE  full_replay_state)
  : VLSM_weak_embedding SeededXE PreFreeE
      (lift_equivocators_sub_label_to full_replay_state)
      (lift_equivocators_sub_state_to full_replay_state).
Proof.
  constructor.
  intros sX trX HtrX.
  specialize (pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True FreeE) as Heq.
  apply (VLSM_eq_finite_valid_trace_from Heq).
  revert sX trX HtrX.
  apply lift_equivocators_sub_weak_projection; [done | | | done].
  - by intros; apply initial_message_is_valid; right.
  - by apply (VLSM_eq_valid_state Heq) in Hfull_replay_state.
Qed.

Lemma PreFreeSubE_PreFreeE_weak_embedding
  (full_replay_state : composite_state equivocator_IM)
  (Hfull_replay_state : valid_state_prop PreFreeE  full_replay_state)
  : VLSM_weak_embedding PreFreeSubE PreFreeE
      (lift_equivocators_sub_label_to full_replay_state)
      (lift_equivocators_sub_state_to full_replay_state).
Proof.
  apply basic_VLSM_weak_embedding; intros ? *.
  - by split; [apply lift_equivocators_sub_valid; apply Hv |].
  - by intro Ht; apply lift_equivocators_sub_transition; apply Ht.
  - intros.
    rewrite <- replayed_initial_state_from_lift; [| done].
    apply finite_valid_trace_last_pstate.
    specialize (pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True FreeE) as Heq.
    apply (VLSM_eq_finite_valid_trace_from Heq).
    apply replayed_initial_state_from_valid; [done | | done].
    by apply (VLSM_eq_valid_state Heq).
  - by intros; apply any_message_is_valid_in_preloaded.
Qed.

Section sec_seeded_no_equiv.

Context
  (SeededAllXE : VLSM message :=
    composite_no_equivocation_vlsm_with_pre_loaded equivocator_IM (free_constraint _) seed)
  (full_replay_state : composite_state equivocator_IM)
  (Hfull_replay_state : valid_state_prop SeededAllXE full_replay_state)
  .

#[local] Lemma SeededNoEquiv_subsumption :
  forall l s om, input_valid SeededXE l (s, om) ->
    no_equivocations_additional_constraint_with_pre_loaded
      equivocator_IM (free_constraint _) seed
      (lift_equivocators_sub_label_to full_replay_state l)
      (lift_equivocators_sub_state_to full_replay_state s, om).
Proof.
  intros l s om (Hs & _ & _ & Hc1 & _).
  split; [| done].
  destruct om as [m |]; [| done].
  apply (VLSM_incl_valid_state (NoEquivocation.seeded_no_equivocation_incl_preloaded
    equivocator_IM (free_constraint _) seed)) in Hfull_replay_state.
  specialize (valid_state_project_preloaded_to_preloaded _ equivocator_IM (free_constraint _)
    full_replay_state) as Hfull_replay_state_pr.
  pose (no_equivocations_additional_constraint_with_pre_loaded
          sub_equivocator_IM (free_constraint sub_equivocator_IM) seed)
        as constraint.
  specialize
    (pre_loaded_vlsm_incl_pre_loaded_with_all_messages
      (composite_vlsm sub_equivocator_IM constraint)
      seed) as Hincl.
  apply (VLSM_incl_valid_state Hincl) in Hs.
  specialize (valid_state_project_preloaded_to_preloaded _ sub_equivocator_IM constraint s)
    as Hs_pr.
  simpl in Hc1.
  destruct Hc1 as [Hsub_sent | Hseeded]; [| by right].
  destruct Hsub_sent as [sub_i Hsent].
  destruct_dec_sig sub_i i Hi Heqsub_i.
  left. exists i.
  simpl. rewrite (lift_equivocators_sub_state_to_sub _ _ _ Hi).
  subst. unfold SubProjectionTraces.sub_IM in Hsent. cbn in Hsent |-*.
  apply equivocator_state_append_sent_right; [.. | done].
  - by apply Hfull_replay_state_pr.
  - by apply (Hs_pr (dexist i Hi) Hs).
Qed.

#[local] Lemma sent_are_valid
  : forall m, seed m -> valid_message_prop SeededAllXE m.
Proof.
  by intros m Hm; apply initial_message_is_valid; right.
Qed.

(**
  Here we specialize the generic [lift_equivocators_sub_weak_projection]
  result for the [equivocators_no_equivocations_constraint].
*)
Lemma SeededXE_SeededNoEquiv_weak_embedding :
  VLSM_weak_embedding SeededXE SeededAllXE
    (lift_equivocators_sub_label_to full_replay_state)
    (lift_equivocators_sub_state_to full_replay_state).
Proof.
  constructor.
  apply lift_equivocators_sub_weak_projection; intros; [done | | done |].
  - by apply sent_are_valid.
  - by apply SeededNoEquiv_subsumption.
Qed.

Lemma sub_replayed_trace_from_valid_equivocating
  (is : composite_state sub_equivocator_IM)
  (tr : list (composite_transition_item sub_equivocator_IM))
  (Htr : finite_valid_trace SeededXE is tr)
  : finite_valid_trace_from SeededAllXE
      full_replay_state (replayed_trace_from full_replay_state is tr).
Proof.
  unfold composite_no_equivocation_vlsm_with_pre_loaded in SeededAllXE.
  specialize (sub_preloaded_replayed_trace_from_valid_equivocating
    (no_equivocations_additional_constraint_with_pre_loaded equivocator_IM (free_constraint _) seed)
    seed)
    as Hvalid.
  spec Hvalid; [done |].
  spec Hvalid; [by apply sent_are_valid |].
  specialize (Hvalid _ Hfull_replay_state).
  apply Hvalid; [| done].
  by intros; apply SeededNoEquiv_subsumption.
Qed.

End sec_seeded_no_equiv.

End sec_all_equivocating.


Require Import VST.floyd.base.
Require Import VST.floyd.val_lemmas.
Require Import VST.floyd.typecheck_lemmas.

Definition const_only_isUnOpResultType {CS: compspecs} op typeof_a valueof_a ty : bool :=
match op with
  | Cop.Onotbool => match typeof_a with
                    | Tint _ _ _
                    | Tlong _ _
                    | Tfloat _ _ => is_int_type ty
                    | Tpointer _ _ =>
                        if Archi.ptr64
                        then match valueof_a with
                             | Vlong v =>
                                andb (negb (eqb_type (typeof_a) int_or_ptr_type))
                                     (andb (is_int_type ty) (Z.eqb 0 (Int64.unsigned v)))
                             | _ => false
                             end
                        else match valueof_a with
                             | Vint v =>
                                andb (negb (eqb_type typeof_a int_or_ptr_type))
                                     (andb (is_int_type ty) (Z.eqb 0 (Int.unsigned v)))
                             | _ => false
                             end
                    | _ => false
                    end
  | Cop.Onotint => match Cop.classify_notint (typeof_a) with
                   | Cop.notint_default => false
                   | Cop.notint_case_i _ => (is_int32_type ty)
                   | Cop.notint_case_l _ => (is_long_type ty)
                   end
  | Cop.Oneg => match Cop.classify_neg (typeof_a) with
                    | Cop.neg_case_i sg =>
                          andb (is_int32_type ty)
                          match (typeof_a) with
                          | Tint _ Signed _ =>
                            match valueof_a with
                            | Vint v => negb (Z.eqb (Int.signed v) Int.min_signed)
                            | _ => false
                            end
                          | Tlong Signed _ =>
                            match valueof_a with
                            | Vlong v => negb (Z.eqb (Int64.signed v) Int64.min_signed)
                            | _ => false
                            end
                          | _ => true
                          end
                    | Cop.neg_case_f => is_float_type ty
                    | Cop.neg_case_s => is_single_type ty
                    | _ => false
                    end
  | Cop.Oabsfloat =>match Cop.classify_neg (typeof_a) with
                    | Cop.neg_case_i sg => is_float_type ty
                    | Cop.neg_case_l _ => is_float_type ty
                    | Cop.neg_case_f => is_float_type ty
                    | Cop.neg_case_s => is_float_type ty
                    | _ => false
                    end
end.

(* TODO: binarithType would better be bool type *)
Definition const_only_isBinOpResultType {CS: compspecs} op typeof_a1 valueof_a1 typeof_a2 valueof_a2 ty : bool :=
  match op with
  | Cop.Oadd =>
      match Cop.classify_add (typeof_a1) (typeof_a2) with
      | Cop.add_case_pi t _ | Cop.add_case_pl t =>
        andb
          (andb
             (andb (match valueof_a1 with Vptr _ _ => true | _ => false end) (complete_type cenv_cs t))
             (negb (eqb_type (typeof_a1) int_or_ptr_type)))
          (is_pointer_type ty)
    | Cop.add_case_ip _ t | Cop.add_case_lp t =>
        andb
          (andb
             (andb (match valueof_a2 with Vptr _ _ => true | _ => false end) (complete_type cenv_cs t))
             (negb (eqb_type (typeof_a2) int_or_ptr_type)))
          (is_pointer_type ty)
    | Cop.add_default => false
                           (*
        andb (binarithType (typeof a1) (typeof a2) ty deferr reterr)
          (tc_nobinover Z.add a1 a2) *)
      end
  | _ => false (* TODO *)
  end.

Definition const_only_isCastResultType {CS: compspecs} (t1 t2: type) (valueof_a: val)  : bool := false. (* TODO *)

Fixpoint const_only_eval_expr {cs: compspecs} (e: Clight.expr): option val :=
  match e with
  | Econst_int i (Tint I32 _ _) => Some (Vint i)
  | Econst_int _ _ => None
  | Econst_long i ty => None (*Some (Vlong i) *)
  | Econst_float f (Tfloat F64 _) => Some (Vfloat f)
  | Econst_float _ _ => None
  | Econst_single f (Tfloat F32 _) => Some (Vsingle f)
  | Econst_single _ _ => None
  | Etempvar id ty => None
  | Evar _ _ => None
  | Eaddrof a ty => None
  | Eunop op a ty =>
      match const_only_eval_expr a with
      | Some v => if const_only_isUnOpResultType op (typeof a) v ty
                  then Some (eval_unop op (typeof a) v)
                  else None
      | None => None
      end
  | Ebinop op a1 a2 ty =>
      match (const_only_eval_expr a1), (const_only_eval_expr a2) with
      | Some v1, Some v2 =>
          if const_only_isBinOpResultType op (typeof a1) v1 (typeof a2) v2 ty
          then Some (eval_binop op (typeof a1) (typeof a2) v1 v2)
          else None
      | _, _ => None
      end
  | Ecast a ty =>
      match const_only_eval_expr a with
      | Some v => if const_only_isCastResultType (typeof a) ty v
                  then Some (eval_cast (typeof a) ty v)
                  else None
      | None => None
      end
  | Ederef a ty => None
  | Efield a i ty => None
  | Esizeof t t0 =>
    if andb (complete_type cenv_cs t) (eqb_type t0 size_t)
    then Some (Vptrofs (Ptrofs.repr (sizeof t)))
    else None
  | Ealignof t t0 =>
    if andb (complete_type cenv_cs t) (eqb_type t0 size_t)
    then Some (Vptrofs (Ptrofs.repr (alignof t)))
    else None
  end.

Lemma const_only_isUnOpResultType_spec: forall {cs: compspecs} rho u e t P,
  const_only_isUnOpResultType u (typeof e) (eval_expr e rho) t = true ->
  P |-- denote_tc_assert (isUnOpResultType u e t) rho.
Proof.
  intros.
  unfold isUnOpResultType.
  unfold const_only_isUnOpResultType in H.
  destruct u.
  + destruct (typeof e);
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
    rewrite !denote_tc_assert_andp.
    match goal with
    | |- context [denote_tc_assert (tc_test_eq ?a ?b)] =>
      change (denote_tc_assert (tc_test_eq a b)) with (expr2.denote_tc_assert (tc_test_eq a b))
    end.
    rewrite binop_lemmas2.denote_tc_assert_test_eq'.
    simpl expr2.denote_tc_assert.
    unfold_lift. simpl.
    unfold tc_int_or_ptr_type.
    destruct Archi.ptr64 eqn:HH.
    - destruct (eval_expr e rho); try solve [inv H].
      rewrite !andb_true_iff in H.
      destruct H as [? [? ?]].
      rewrite H, H0.
      rewrite Z.eqb_eq in H1.
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      simpl.
      rewrite HH.
      change (P |-- (!! (i = Int64.zero)) && (!! (Int64.zero = Int64.zero)))%logic.
      apply andp_right; apply prop_right; auto.
      rewrite <- (Int64.repr_unsigned i), <- H1.
      auto.
    - destruct (eval_expr e rho); try solve [inv H].
      rewrite !andb_true_iff in H.
      destruct H as [? [? ?]].
      rewrite H, H0.
      rewrite Z.eqb_eq in H1.
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      apply andp_right; [exact (@prop_right mpred _ True _ I) |].
      simpl.
      rewrite HH.
      change (P |-- (!! (i = Int.zero)) && (!! (Int.zero = Int.zero)))%logic.
      apply andp_right; apply prop_right; auto.
      rewrite <- (Int.repr_unsigned i), <- H1.
      auto.
  + destruct (Cop.classify_notint (typeof e));
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
  + destruct (Cop.classify_neg (typeof e));
      try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
    rewrite !andb_true_iff in H.
    destruct H.
    rewrite H; simpl.
    destruct (typeof e) as [| ? [|] | [|] | | | | | |];
      try solve [exact (@prop_right mpred _ True _ I)].
    - simpl.
      unfold_lift.
      unfold denote_tc_nosignedover.
      destruct (eval_expr e rho); try solve [inv H0].
      rewrite negb_true_iff in H0.
      rewrite Z.eqb_neq in H0.
      apply prop_right.
      change (Int.signed Int.zero) with 0.
      rep_omega.
    - simpl.
      unfold_lift.
      unfold denote_tc_nosignedover.
      destruct (eval_expr e rho); try solve [inv H0].
      rewrite negb_true_iff in H0.
      rewrite Z.eqb_neq in H0.
      apply prop_right.
      change (Int64.signed Int64.zero) with 0.
      rep_omega.
  + destruct (Cop.classify_neg (typeof e)); try solve [inv H | rewrite H; exact (@prop_right mpred _ True _ I)].
Qed.

Lemma const_only_isBinOpResultType_spec: forall {cs: compspecs} rho b e1 e2 t P,
  const_only_isBinOpResultType b (typeof e1) (eval_expr e1 rho) (typeof e2) (eval_expr e2 rho) t = true ->
  P |-- denote_tc_assert (isBinOpResultType b e1 e2 t) rho.
Proof.
  intros.
  unfold isBinOpResultType.
  unfold const_only_isBinOpResultType in H.
  destruct b.
  + destruct (Cop.classify_add (typeof e1) (typeof e2)).
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e1 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e1 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e2 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - rewrite !denote_tc_assert_andp; simpl.
      unfold_lift.
      unfold tc_int_or_ptr_type, denote_tc_isptr.
      destruct (eval_expr e2 rho); inv H.
      rewrite !andb_true_iff in H1.
      destruct H1 as [[? ?] ?].
      rewrite H, H0, H1.
      simpl.
      repeat apply andp_right; apply prop_right; auto.
    - inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
  + inv H.
Qed.

Lemma const_only_isCastResultType_spec: forall {cs: compspecs} rho e t P,
  const_only_isCastResultType (typeof e) t (eval_expr e rho) = true ->
  P |-- denote_tc_assert (isCastResultType (typeof e) t e) rho.
Proof.
  intros.
  inv H.
Qed.

Lemma const_only_eval_expr_eq: forall {cs: compspecs} rho e v,
  const_only_eval_expr e = Some v ->
  eval_expr e rho = v.
Proof.
  intros.
  revert v H; induction e; try solve [intros; inv H; auto].
  + intros.
    simpl in *.
    destruct t as [| [| | |] | | | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    destruct t as [| | | [|] | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    destruct t as [| | | [|] | | | | |]; inv H.
    auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e); inv H.
    destruct (const_only_isUnOpResultType u (typeof e) v0 t); inv H1.
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite IHe; auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e1); inv H.
    destruct (const_only_eval_expr e2); inv H1.
    destruct (const_only_isBinOpResultType b (typeof e1) v0 (typeof e2) v1 t); inv H0.
    specialize (IHe1 _ eq_refl).
    specialize (IHe2 _ eq_refl).
    unfold_lift.
    rewrite IHe1, IHe2; auto.
  + intros.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e); inv H. (*
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite IHe; auto.*)
  + intros.
    simpl in *.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t); inv H.
    auto.
  + intros.
    simpl in *.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t); inv H.
    auto.
Qed.

Lemma const_only_eval_expr_tc: forall {cs: compspecs} Delta e v P,
  const_only_eval_expr e = Some v ->
  P |-- tc_expr Delta e.
Proof.
  intros.
  intro rho.
  revert v H; induction e; try solve [intros; inv H].
  + intros.
    inv H.
    destruct t as [| [| | |] | | | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    destruct t as [| | | [|] | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    destruct t as [| | | [|] | | | | |]; inv H1.
    exact (@prop_right mpred _ True _ I).
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e) eqn:HH; inv H.
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite denote_tc_assert_andp; simpl; apply andp_right; auto.
    apply const_only_isUnOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH.
    rewrite HH.
    destruct (const_only_isUnOpResultType u (typeof e) v0 t); inv H1; auto.
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e1) eqn:HH1; inv H.
    destruct (const_only_eval_expr e2) eqn:HH2; inv H1.
    specialize (IHe1 _ eq_refl).
    specialize (IHe2 _ eq_refl).
    unfold_lift.
    rewrite !denote_tc_assert_andp; simpl; repeat apply andp_right; auto.
    apply const_only_isBinOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH1.
    apply (const_only_eval_expr_eq rho) in HH2.
    rewrite HH1, HH2.
    destruct (const_only_isBinOpResultType b (typeof e1) v0 (typeof e2) v1 t); inv H0; auto.
  + intros.
    unfold tc_expr in *.
    simpl in *.
    unfold option_map in H.
    destruct (const_only_eval_expr e) eqn:HH; inv H. (*
    specialize (IHe _ eq_refl).
    unfold_lift.
    rewrite denote_tc_assert_andp; simpl; apply andp_right; auto.
    apply const_only_isUnOpResultType_spec.
    apply (const_only_eval_expr_eq rho) in HH. *)
  + intros.
    inv H.
    unfold tc_expr.
    simpl typecheck_expr.
    simpl.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t) eqn:HH; inv H1.
    rewrite andb_true_iff in HH.
    unfold tuint in HH; destruct HH.
    rewrite H, H0.
    exact (@prop_right mpred _ True _ I).
  + intros.
    inv H.
    unfold tc_expr.
    simpl typecheck_expr.
    simpl.
    destruct (complete_type cenv_cs t && eqb_type t0 size_t) eqn:HH; inv H1.
    rewrite andb_true_iff in HH.
    unfold tuint in HH; destruct HH.
    rewrite H, H0.
    exact (@prop_right mpred _ True _ I).
Qed.


Require Import VST.floyd.proofauto.
Require Import VST.progs.odd.
Require Import VST.progs.verif_evenodd_spec.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.

Definition Gprog : funspecs :=
     ltac:(with_library prog [odd_spec; even_spec]).

Lemma body_odd : semax_body Vprog Gprog f_odd odd_spec.
Proof.
start_function.
change even._n with _n.
forward_if.
*
 forward.
*
  forward_call (z-1).
  omega.
  forward.
  entailer!.
  rewrite Z.even_sub; simpl.
  case_eq (Z.odd z); rewrite Zodd_even_bool;
  destruct (Z.even z); simpl; try (intros; congruence).
Qed.

(* The Espec for odd is different from the Espec for even;
  the former has only "even" as an external function, and vice versa. *)
Definition Espec := add_funspecs NullExtension.Espec (ext_link_prog odd.prog) Gprog.
Existing Instance Espec.

(* Can't prove   prog_correct: semax_prog prog Vprog Gprog
  because there is no _main function, so prove all_funcs_correct instead. *)
Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
repeat (apply semax_func_cons_ext_vacuous; [reflexivity | reflexivity | ]).
semax_func_cons_ext.
semax_func_cons body_odd.
Qed.


From stbor.lang Require Export defs.

Set Default Proof Using "Type".

Definition tagged_sublist (stk1 stk2: stack) :=
  ∀ it1, it1 ∈ stk1 → ∃ it2,
  it2 ∈ stk2 ∧ it1.(tg) = it2.(tg) ∧ it1.(protector) = it2.(protector) ∧
  (it1.(perm) ≠ Disabled → it2.(perm) = it1.(perm)).
Instance tagged_sublist_preorder : PreOrder tagged_sublist.
Proof.
  constructor.
  - intros ??. naive_solver.
  - move => ??? H1 H2 ? /H1 [? [/H2 Eq [-> [-> ND]]]].
    destruct Eq as (it2 &?&?&?&ND2). exists it2. repeat split; auto.
    intros ND3. specialize (ND ND3). rewrite ND2 // ND //.
Qed.

Instance tagged_sublist_proper stk : Proper ((⊆) ==> impl) (tagged_sublist stk).
Proof. move => ?? SUB H1 ? /H1 [? [/SUB ? ?]]. naive_solver. Qed.

Lemma tagged_sublist_app l1 l2 k1 k2 :
  tagged_sublist l1 l2 → tagged_sublist k1 k2 →
  tagged_sublist (l1 ++ k1) (l2 ++ k2).
Proof.
  move => H1 H2 it. setoid_rewrite elem_of_app.
  move => [/H1|/H2]; naive_solver.
Qed.

Lemma remove_check_tagged_sublist cids stk stk' idx:
  remove_check cids stk idx = Some stk' → tagged_sublist stk' stk.
Proof.
  revert idx.
  induction stk as [|it stk IH]; intros idx; simpl.
  { destruct idx; [|done]. intros. by simplify_eq. }
  destruct idx as [|idx]; [intros; by simplify_eq|].
  case check_protector eqn:Eq; [|done].
  move => /IH. apply tagged_sublist_proper. set_solver.
Qed.

Lemma replace_check'_tagged_sublist cids acc stk stk':
  replace_check' cids acc stk = Some stk' → tagged_sublist stk' (acc ++ stk).
Proof.
  revert acc.
  induction stk as [|it stk IH]; intros acc; simpl.
  { intros. simplify_eq. by rewrite app_nil_r. }
  case decide => ?; [case check_protector; [|done]|];
    move => /IH; [|by rewrite -app_assoc].
  move => H1 it1 /H1 [it2 [IN2 [Eq1 [Eq2 ND]]]].
  setoid_rewrite elem_of_app. setoid_rewrite elem_of_cons.
  move : IN2 => /elem_of_app [/elem_of_app [?|/elem_of_list_singleton Eq]|?];
    [..|naive_solver].
  - exists it2. naive_solver.
  - subst it2. exists it. naive_solver.
Qed.

Lemma replace_check_tagged_sublist cids stk stk':
  replace_check cids stk = Some stk' → tagged_sublist stk' stk.
Proof. move => /replace_check'_tagged_sublist. by rewrite app_nil_l. Qed.

(** NoDup for tagged item *)
Lemma stack_item_tagged_NoDup_singleton it:
  stack_item_tagged_NoDup [it].
Proof.
  rewrite /stack_item_tagged_NoDup filter_cons filter_nil.
  case decide => ? /=. apply NoDup_singleton. apply NoDup_nil_2.
Qed.

Lemma stack_item_tagged_NoDup_cons_1 it stk :
  stack_item_tagged_NoDup (it :: stk) → stack_item_tagged_NoDup stk.
Proof.
  rewrite /stack_item_tagged_NoDup filter_cons.
  case decide => [NT|IT //]. rewrite fmap_cons. by apply NoDup_cons_12.
Qed.

Lemma stack_item_tagged_NoDup_sublist stk1 stk2:
  sublist stk1 stk2 → stack_item_tagged_NoDup stk2 → stack_item_tagged_NoDup stk1.
Proof.
  intros SUB. rewrite /stack_item_tagged_NoDup.
  by apply NoDup_sublist, fmap_sublist, filter_sublist.
Qed.

Lemma replace_check'_stack_item_tagged_NoDup cids acc stk stk':
  replace_check' cids acc stk = Some stk' →
  stack_item_tagged_NoDup (acc ++ stk) → stack_item_tagged_NoDup stk'.
Proof.
  revert acc.
  induction stk as [|it stk IH]; intros acc; simpl.
  { intros ?. simplify_eq. by rewrite app_nil_r. }
  case decide => ?; [case check_protector; [|done]|];
    move => /IH; [|by rewrite -app_assoc].
  move => IH1 ND. apply IH1. clear IH1. move : ND.
  rewrite /stack_item_tagged_NoDup 3!filter_app 2!filter_cons.
  case decide => [IT|NT].
  - by rewrite decide_True // 3!fmap_app 2!fmap_cons /= -assoc.
  - by rewrite decide_False // /= filter_nil app_nil_r.
Qed.

Lemma replace_check'_stack_item_tagged_NoDup_2 cids acc stk stk' stk0:
  replace_check' cids acc stk = Some stk' →
  stack_item_tagged_NoDup (acc ++ stk ++ stk0) → stack_item_tagged_NoDup (stk' ++ stk0).
Proof.
  revert acc.
  induction stk as [|it stk IH]; intros acc; simpl.
  { intros ?. by simplify_eq. }
  case decide => ?; [case check_protector; [|done]|];
    move => /IH; [|rewrite (app_assoc acc [it] (stk ++ stk0)); naive_solver].
  move => IH1 ND. apply IH1. clear IH1. move : ND.
  rewrite /stack_item_tagged_NoDup 3!filter_app 2!filter_cons.
  case decide => [IT|NT].
  - by rewrite decide_True // 3!fmap_app 2!fmap_cons /= -assoc.
  - by rewrite decide_False // /= filter_nil app_nil_r.
Qed.

Lemma replace_check_stack_item_tagged_NoDup cids stk stk' :
  replace_check cids stk = Some stk' →
  stack_item_tagged_NoDup stk → stack_item_tagged_NoDup stk'.
Proof. intros. eapply replace_check'_stack_item_tagged_NoDup; eauto. Qed.

Lemma replace_check_stack_item_tagged_NoDup_2 cids stk stk' stk0:
  replace_check cids stk = Some stk' →
  stack_item_tagged_NoDup (stk ++ stk0) → stack_item_tagged_NoDup (stk' ++ stk0).
Proof. intros; eapply replace_check'_stack_item_tagged_NoDup_2; eauto. Qed.

Lemma replace_check'_acc_result cids acc stk stk' :
  replace_check' cids acc stk = Some stk' → acc ⊆ stk'.
Proof.
  revert acc.
  induction stk as [|it stk IH]; intros acc; simpl; [by intros; simplify_eq|].
  case decide => ?; [case check_protector; [|done]|];
    move => /IH; set_solver.
Qed.

Lemma remove_check_stack_item_tagged_NoDup cids stk stk' idx:
  remove_check cids stk idx = Some stk' →
  stack_item_tagged_NoDup stk → stack_item_tagged_NoDup stk'.
Proof.
  revert idx.
  induction stk as [|it stk IH]; intros idx; simpl.
  { destruct idx; [|done]. intros ??. by simplify_eq. }
  destruct idx as [|idx]; [intros ??; by simplify_eq|].
  case check_protector eqn:Eq; [|done].
  move => /IH IH' ND. apply IH'. by eapply stack_item_tagged_NoDup_cons_1.
Qed.

Lemma remove_check_stack_item_tagged_NoDup_2 cids stk stk' stk0 idx:
  remove_check cids stk idx = Some stk' →
  stack_item_tagged_NoDup (stk ++ stk0) → stack_item_tagged_NoDup (stk' ++ stk0).
Proof.
  revert idx.
  induction stk as [|it stk IH]; intros idx; simpl.
  { destruct idx; [|done]. intros ??. by simplify_eq. }
  destruct idx as [|idx]; [intros ??; by simplify_eq|].
  case check_protector eqn:Eq; [|done].
  move => /IH IH' ND. apply IH'. by eapply stack_item_tagged_NoDup_cons_1.
Qed.

Lemma remove_check_sublist cids stk idx stk' :
  remove_check cids stk idx = Some stk' → sublist stk' stk.
Proof.
  revert idx.
  induction stk as [|it stk IH]; intros idx; simpl.
  { destruct idx; [|done]. intros ?. by simplify_eq. }
  destruct idx as [|idx]; [intros ?; by simplify_eq|].
  case check_protector eqn:Eq; [|done].
  move => /IH IH'. by constructor 3.
Qed.

Lemma stack_item_tagged_NoDup_app stk1 stk2 :
  stack_item_tagged_NoDup (stk1 ++ stk2) →
  stack_item_tagged_NoDup stk1 ∧ stack_item_tagged_NoDup stk2.
Proof. rewrite /stack_item_tagged_NoDup filter_app fmap_app NoDup_app. naive_solver. Qed.

Instance stack_item_tagged_NoDup_proper :
  Proper (Permutation ==> iff) stack_item_tagged_NoDup.
Proof. intros stk1 stk2 PERM. by rewrite /stack_item_tagged_NoDup PERM. Qed.

Lemma stack_item_tagged_NoDup_eq stk it1 it2 t :
  stack_item_tagged_NoDup stk →
  it1 ∈ stk → it2 ∈ stk → it1.(tg) = Tagged t → it2.(tg) = Tagged t →
  it1 = it2.
Proof.
  induction stk as [|it stk IH]; [set_solver|].
  intros ND. specialize (IH (stack_item_tagged_NoDup_cons_1 _ _ ND)).
  rewrite 2!elem_of_cons.
  move => [?|In1] [?|In2]; subst; [done|..]; intros Eq1 Eq2.
  - exfalso. apply elem_of_Permutation in In2 as [stk' Eq'].
    move : ND. rewrite Eq'.
    rewrite /stack_item_tagged_NoDup filter_cons decide_True; last by rewrite /is_tagged Eq1.
    rewrite filter_cons decide_True; last by rewrite /is_tagged Eq2.
    rewrite 2!fmap_cons Eq1 Eq2 NoDup_cons. set_solver.
  - exfalso. apply elem_of_Permutation in In1 as [stk' Eq'].
    move : ND. rewrite Eq'.
    rewrite /stack_item_tagged_NoDup filter_cons decide_True; last by rewrite /is_tagged Eq2.
    rewrite filter_cons decide_True; last by rewrite /is_tagged Eq1.
    rewrite 2!fmap_cons Eq1 Eq2 NoDup_cons. set_solver.
  - by apply IH.
Qed.


Require Export DEX_ElemLemmas.

Import DEX_BigStepWithTypes.DEX_BigStepWithTypes DEX_BigStep.DEX_Dom DEX_Prog.

Section p.

Variable kobs: L.t.
Variable p:DEX_ExtendedProgram.
Variable se : DEX_PC -> L.t.
Variable reg : DEX_PC -> DEX_PC -> Prop.
Variable m : DEX_Method.
Variable lookupswitch_hyp : well_formed_lookupswitch m.

Ltac soap2_intra_normal_aux Hreg_in H Hreg r lvl Hget_ori Hvalue_opt_in k k':=
  specialize Hreg_in with r;
  inversion Hreg_in as [k k' Hget Hget' Hleq Hleq'| Hvalue_opt_in];
  try (apply H in Hreg; apply leql_join_each in Hreg; inversion Hreg as [Hleql1 Hleql1'];
    apply not_leql_trans with (k2:=lvl) in Hleq; auto);
  try (apply H in Hreg; apply not_leql_trans with (k2:=lvl) in Hleq; auto);
  try (rewrite Hget in Hget_ori; inversion Hget_ori; subst; auto).

(* High Branching *)
Lemma soap2_intra_normal :
 forall sgn pc pc2 pc2' i r1 rt1 h1 b1 r1' rt1' h1' b1' r2 rt2 h2 b2 r2' rt2' h2' b2',
   instructionAt m pc = Some i ->
   NormalStep kobs p se reg m sgn i (pc,(h1,r1)) rt1 b1 (pc2,(h2,r2)) rt2 b2 ->
   NormalStep kobs p se reg m sgn i (pc,(h1',r1')) rt1' b1' (pc2',(h2',r2')) rt2' b2' ->
   pc2 <> pc2' ->
   st_in kobs (DEX_ft p) b1 b1' rt1 rt1' (pc,h1,r1) (pc,h1',r1') ->

    forall j, reg pc j -> ~ L.leql (se j) kobs.
Proof.
  intros sgn pc pc2 pc2' i r1 rt1 h1 b1 r1' rt1' h1' b1' r2 rt2 h2 b2 r2' rt2' h2' b2' Hins Hstep Hstep' Hpc Hst_in j Hreg.
  destruct i; simpl in Hins, Hstep, Hstep', Hst_in;
  inversion_clear Hstep in Hins Hstep' Hpc Hst_in;
  inversion_clear Hstep' in Hpc Hst_in; subst;
  apply inv_st_in in Hst_in;
  DiscrimateEq; try (elim Hpc; reflexivity); try (contradiction).
  (* PackedSwitch *)
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H5 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
    assert (n = n0) by omega; subst.
    rewrite H3 in H9. inversion H9; subst; apply False_ind; auto.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H6 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst. apply False_ind; omega.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H3 Hreg rt (se j) H1 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H0 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst. apply False_ind; omega.
  (* SparseSwitch *)
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H2 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H3 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
      unfold well_formed_lookupswitch in lookupswitch_hyp.
      specialize lookupswitch_hyp with (pc:=pc) (reg:=rt) (l:=l) (size:=size) (i:=Int.toZ i0) (1:=Hins) (2:=H1) (3:=H5).
      subst. apply False_ind; auto.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H2 Hreg rt (se j) H0 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
      specialize H6 with (i':=Int.toZ i0) (o':=o) (1:=H1).
      apply False_ind; auto.
  inversion Hst_in as [Heqset Hreg_in].
    soap2_intra_normal_aux Hreg_in H3 Hreg rt (se j) H1 Hvalue_opt_in k1 k1'.
    (* both are low *)
    rewrite <- H0 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst.
      specialize H2 with (i':=Int.toZ i0) (o':=o) (1:=H6).
      apply False_ind; omega.
  (* If_icmp *)
  inversion Hst_in as [Heqset Hreg_in].
    (* ra *)
    assert (Hreg_in':=Hreg_in).
    soap2_intra_normal_aux Hreg_in H8 Hreg ra (se j) H5 Hvalue_opt_in k k'.
    (* rb *)
    soap2_intra_normal_aux Hreg_in' H8 Hreg rb (se j) H6 Hvalue_opt_in' k k'.
    (* both are low *)
    rewrite <- H3 in Hvalue_opt_in; rewrite <- H4 in Hvalue_opt_in';
    rewrite <- H14 in Hvalue_opt_in; rewrite <- H15 in Hvalue_opt_in'.
    inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
    inversion Hvalue_opt_in' as [v2 v2' Hvalue_in' | Hnone'];
    inversion Hvalue_in; inversion Hvalue_in'.
    subst; contradiction.
  inversion Hst_in as [Heqset Hreg_in].
    (* ra *)
    assert (Hreg_in':=Hreg_in).
    soap2_intra_normal_aux Hreg_in H9 Hreg ra (se j) H6 Hvalue_opt_in k k'.
    (* rb *)
    soap2_intra_normal_aux Hreg_in' H9 Hreg rb (se j) H7 Hvalue_opt_in' k k'.
    (* both are low *)
    rewrite <- H4 in Hvalue_opt_in; rewrite <- H5 in Hvalue_opt_in';
    rewrite <- H14 in Hvalue_opt_in; rewrite <- H15 in Hvalue_opt_in'.
    inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
    inversion Hvalue_opt_in' as [v2 v2' Hvalue_in' | Hnone'];
    inversion Hvalue_in; inversion Hvalue_in'.
    subst; contradiction.
  (* If_z *)
  inversion Hst_in as [Heq_set Hreg_in].
    soap2_intra_normal_aux Hreg_in H4 Hreg r (se j) H2 Hvalue_opt_in k1 k1'.
    rewrite <- H1 in Hvalue_opt_in; rewrite <- H8 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst; contradiction.
  inversion Hst_in as [Heq_set Hreg_in].
    soap2_intra_normal_aux Hreg_in H5 Hreg r (se j) H3 Hvalue_opt_in k1 k1'.
    rewrite <- H2 in Hvalue_opt_in; rewrite <- H8 in Hvalue_opt_in;
      inversion Hvalue_opt_in as [v v' Hvalue_in | Hnone];
      inversion Hvalue_in; subst; contradiction.
Qed.

End p.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext uniq_tac machine_int.
Import MachineInt.
Require Import mips_cmd mips_tactics mips_contrib.
Import expr_m.
Require Import multi_is_zero_u_prg.

Local Open Scope machine_int_scope.
Local Open Scope mips_expr_scope.
Local Open Scope mips_cmd_scope.
Local Open Scope uniq_scope.

Lemma multi_is_zero_u_termination s h k z ext M_ ret :
  uniq(k, z, ext, M_, ret, r0) ->
  { si | Some (s, h) -- multi_is_zero_u k z ext M_ ret ---> si }.
Proof.
move=> Hregs.
rewrite /multi_is_zero_u.
apply exists_addiu_seq.
rewrite sext_Z2u // addi0.
apply exists_addiu_seq.
rewrite !store.get_r0 add0i.
set s0 := store.upd _ _ _.
(* TODO: factoriser cette etape dans les differentes preuves de terminaison? *)
have [kext Hkext] : { kext | u2Z [k]_s0 - u2Z [ext]_s0 = Z_of_nat kext}.
  have [kext Hkext] : { kext | u2Z [k]_s0 - u2Z [ext]_s0 = kext} by eapply exist; reflexivity.
  have : 0 <= kext. rewrite -Hkext /s0. repeat Reg_upd. rewrite Z2uK // subZ0; exact: min_u2Z.
  case/Z_of_nat_complete_inf => kext' H.
  exists kext'; by rewrite -H.
move: kext s0 Hkext h.
elim.
- move=> s0 Hkext h.
  eapply exist.
  apply while.exec_while_false.
  rewrite /= in Hkext *.
  apply/negPn/eqP; lia.
- move=> kext IH s0 Hext h.
  apply exists_while.
  + rewrite /=; apply/eqP; rewrite Z_S in Hext; lia.
  + apply exists_seq_P2 with (fun s => u2Z [k ]_ (fst s) - u2Z [ext ]_ (fst s) = Z_of_nat kext)%mips_expr.
    * exists_lwxs l_z H_l_z z_z H_z_z.
      exists_movn H.
      - apply exists_movn_false_seq_P => //.
        apply exists_addiu_P.
        simpl fst.
        repeat Reg_upd.
        rewrite Z_S in Hext.
        rewrite sext_Z2u // u2Z_add_Z2u //; first lia.
        move: (min_u2Z [k ]_ s0) (max_u2Z [k ]_ s0) (min_u2Z [ext ]_ s0) (max_u2Z [ext ]_ s0) => ? ? ? ?; lia.
      - apply exists_movn_true_seq_P => //.
        apply exists_addiu_P.
        simpl fst.
        repeat Reg_upd.
        rewrite Z_S in Hext.
        rewrite sext_Z2u // u2Z_add_Z2u //; first lia.
        move: (min_u2Z [k ]_ s0) (max_u2Z [k ]_ s0) (min_u2Z [ext ]_ s0) (max_u2Z [ext ]_ s0) => ? ? ? ?; lia.
    * move=> [si hi] Hsi; exact: IH.
Qed.