Require Import VST.floyd.proofauto.
Require Import VST.progs.load_demo.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

Definition pair_pair_t := (Tstruct _pair_pair noattr).

Definition array_size := 100.

Definition get22_spec :=
 DECLARE _get22
  WITH pps: val, i: Z, x11: int, x12: int, x21: int, x22: int, sh : share
  PRE [ _pps OF (tptr pair_pair_t), _i OF tint ]
    PROP  (readable_share sh; 0 <= i < array_size)
    LOCAL (temp _pps pps; temp _i (Vint (Int.repr i)))
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps)
  POST [ tint ]
        PROP () LOCAL (temp ret_temp (Vint x22))
    SEP   (field_at sh (tarray pair_pair_t array_size) [ArraySubsc i]
                    ((Vint x11, Vint x12), (Vint x21, Vint x22)) pps).

Definition uint_sum (contents : list Z) : int :=
  fold_right (fun el sum => Int.add sum (Int.repr el)) Int.zero contents.

Definition fiddle_spec :=
 DECLARE _fiddle
  WITH p: val, n: Z, tag: Z, contents: list Z
  PRE [ _p OF tptr tuint ]
          PROP  (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10)) = n)
          LOCAL (temp _p p)
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p))
  POST [ tint ]
          PROP ( )
          LOCAL (temp ret_temp (Vint (Int.add (Int.repr (Z.land tag 255)) (uint_sum contents))))
          SEP (data_at Ews (tarray tuint (1+n))
                      (map Vint (map Int.repr (tag::contents)))
                      (offset_val (-sizeof tuint) p)).

Definition get_uint32_le (arr: list Z) : int :=
 (Int.or (Int.or (Int.or
            (Int.repr (Znth 0 arr 0))
   (Int.shl (Int.repr (Znth 1 arr 0)) (Int.repr  8)))
   (Int.shl (Int.repr (Znth 2 arr 0)) (Int.repr 16)))
   (Int.shl (Int.repr (Znth 3 arr 0)) (Int.repr 24))).

Definition get_little_endian_spec :=
  DECLARE _get_little_endian
  WITH input : val, in_sh : share, arr : list Z
  PRE [ _input OF (tptr tuchar) ]
    PROP (Zlength arr = 4;
          readable_share in_sh;
          forall i, 0 <= i < 4 -> 0 <= Znth i arr 0 <= Byte.max_unsigned)
    LOCAL (temp _input input)
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input)
  POST [ tuint ]
    PROP() LOCAL(temp ret_temp (Vint (get_uint32_le arr)))
    SEP (data_at in_sh (tarray tuchar 4) (map Vint (map Int.repr arr)) input).

Definition Gprog : funspecs := ltac:(with_library prog
  [get22_spec; fiddle_spec; get_little_endian_spec]).

Ltac solve_arr_range H :=
 match goal with |- context [Znth ?i _ 0] =>
   specialize (H i); spec H; [ computable | ];
   rewrite Int.unsigned_repr; rep_omega
 end.

Lemma body_get_little_endian: semax_body Vprog Gprog f_get_little_endian get_little_endian_spec.
Proof.
start_function.
assert (BMU: Byte.max_unsigned=255) by reflexivity.
forward.
entailer!. solve_arr_range H0.
forward.
forward.
entailer!. solve_arr_range H0.
forward.
forward.
entailer!. solve_arr_range H0.
forward.
entailer!. solve_arr_range H0.
forward.
Qed.

Lemma uint_sum_app: forall a b, uint_sum (a++b) = Int.add (uint_sum a) (uint_sum b).
Proof.
  intros. induction a; simpl.
  - symmetry. apply Int.add_zero_l.
  - rewrite IHa. rewrite !Int.add_assoc. f_equal. apply Int.add_commut.
Qed.

Lemma body_fiddle: semax_body Vprog Gprog f_fiddle fiddle_spec.
Proof.
start_function.
rename H into Htag.
assert_PROP (Zlength contents = n) as LEN. {
  entailer!.
  forget (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) as n.
  clear - H0.
  rewrite Zlength_cons in H0.
  rewrite !Zlength_map in H0.
  destruct (zlt n 0); [elimtype False | ].
  rewrite Z.max_l in H0 by omega.
  pose proof (Zlength_nonneg contents).
  omega.
  rewrite Z.max_r in H0 by omega. omega.
}
assert (Zlength (tag :: contents) = 1 + n) as LEN1. {
  rewrite Zlength_cons. omega.
}
assert (N0: 0 <= n). {
  pose proof (Zlength_nonneg contents). omega.
}
assert_PROP (isptr p) as P by entailer!.

(* forward fails, but tells us to prove this: *)
assert_PROP (force_val (sem_add_ptr_int tuint Signed p (eval_unop Oneg tint (Vint (Int.repr 1))))
  = field_address (tarray tuint (1+n)) [ArraySubsc 0] (offset_val (-sizeof tuint) p)). {
  entailer!.
  destruct p; inversion P. simpl.
  rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  rewrite ptrofs_add_repr_0_r. reflexivity.
}
forward.
(* sum = tagword & 0xff; *)
forward.
(* size = tagword >> 10; *)
forward.
rewrite !Znth_0_cons.

forward_for_simple_bound (Int.unsigned (Int.shru (Int.repr tag) (Int.repr 10))) (EX i: Z,
  PROP ( )
  LOCAL (
    temp _size (Vint (Int.shru (Int.repr tag) (Int.repr 10)));
    temp _sum (Vint (Int.add (Int.and (Int.repr tag) (Int.repr 255))
                             (uint_sum (sublist 0 i contents))));
    temp _tagword (Vint (Int.repr tag));
    temp _p p
  )
  SEP (data_at Ews (tarray tuint (1 + n)) (map Vint (map Int.repr (tag :: contents)))
          (offset_val (- sizeof tuint) p))).
- pose proof (Int.unsigned_range (Int.shru (Int.repr tag) (Int.repr 10))). rep_omega.
- (* precondition implies invariant: *)
  entailer!. f_equal. apply Int.repr_unsigned.
- (* body preserves invariant: *)
  (* forward fails, but tells us to prove this: *)
  assert_PROP (force_val (sem_add_ptr_int tuint Unsigned p (Vint (Int.repr i)))
    = field_address (tarray tuint (1 + n)) [ArraySubsc (1 + i)] (offset_val (- sizeof tuint) p)). {
    entailer!.
    destruct p; inversion P. simpl.
    rewrite field_compatible_field_address by auto with field_compatible.
    simpl.
    rewrite Ptrofs.add_assoc, ptrofs_add_repr.
    f_equal. f_equal. f_equal. omega.
  }
  forward.
  forward.
  entailer!. split.
  + f_equal. apply Int.repr_unsigned.
  + f_equal. rewrite Int.add_assoc. f_equal.
    rewrite (sublist_split 0 i (i+1)) by omega.
    rewrite sublist_len_1 with (d := 0) by omega.
    rewrite Znth_pos_cons by omega.
    replace (1 + i - 1) with i by omega.
    rewrite uint_sum_app. f_equal. simpl. apply Int.add_zero_l.
- (* return sum; *)
  forward. rewrite sublist_same by auto. entailer!.
Qed.

Lemma body_get22_root_expr: semax_body Vprog Gprog f_get22 get22_spec.
 Proof.
 start_function.
 (* int_pair_t* p = &pps[i].right; *)
 forward.
 simpl (temp _p _).
 (* Assert_PROP what forward asks us for (only for the root expression "p"):  *)
 assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
   = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
   entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. normalize.
 }
 (* int res = p->snd; *)
 forward.
 (* return res; *)
 forward.
 Qed.

Lemma body_get22_full_expr: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Assert_PROP what forward asks us for (for the full expression "p->snd"): *)
assert_PROP (
  offset_val 4 (offset_val 8 (force_val
    (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i)))))
  = (field_address (tarray pair_pair_t array_size)
                   [StructField _snd; StructField _right; ArraySubsc i] pps)). {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl. f_equal. omega.
}
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.

Lemma body_get22_alt: semax_body Vprog Gprog f_get22 get22_spec.
Proof.
start_function.
(* int_pair_t* p = &pps[i].right; *)
forward.
simpl (temp _p _).

(* Alternative: Make p nice enough so that no hint is required: *)
assert_PROP (offset_val 8 (force_val (sem_add_ptr_int (Tstruct _pair_pair noattr) Signed pps (Vint (Int.repr i))))
  = field_address (tarray pair_pair_t array_size) [StructField _right; ArraySubsc i] pps) as E. {
  entailer!. rewrite field_compatible_field_address by auto with field_compatible.
  simpl.
  normalize.
}
rewrite E. clear E.
(* int res = p->snd; *)
forward.
(* return res; *)
forward.
Qed.


From Coq Require Import Bool List ListSet Reals FinFun RelationClasses Relations Relations_1 Sorting Basics Lia.
Import ListNotations.

From CasperCBC
Require Import
  Lib.Preamble
  Lib.ListExtras
  Lib.ListSetExtras
  Lib.SortedLists
  Lib.Measurable
  VLSM.Common
  VLSM.Plans
  VLSM.ProjectionTraces
  VLSM.Composition
  VLSM.Equivocation
  VLSM.ListValidator.ListValidator
  VLSM.ListValidator.Equivocation
  VLSM.ListValidator.Observations
  VLSM.ListValidator.EquivocationAwareListValidator
  VLSM.ObservableEquivocation
  .

(** * VLSM Free Composition of List Validators *)

(**   This file describes a free composition <X> of List Validator nodes, each using
   an [equivocation_aware_estimator]. Also see:

   - [Observations.v] for the observation model used here
   - [EquivocationAwareListValidator.v] for the used estimators
   - [Equivocation.v] and [ListValidator.v] for some general
     facts about List Validators.
*)

Section Composition.
Context
  {index : Type}
  {i0 : Inhabited index}
  {index_listing : list index}
  {Hfinite : Listing index_listing}
  {idec : EqDecision index}
  {Mindex : Measurable index}
  {Rindex : ReachableThreshold index}
  (est' := fun (i : index) => (@EquivocationAwareListValidator.equivocation_aware_estimator _ i _ Hfinite _ _ _ ))
  (IM_index := fun (i : index) => @VLSM_list index i index_listing idec (est' i))
  (has_been_sent_capabilities := fun i : index => @lv_sent_capability index i index_listing Hfinite idec (est' i))
  (has_been_received_capabilities := fun i : index => @lv_received_capability index i index_listing Hfinite idec (est' i))
  (X := composite_vlsm IM_index (free_constraint IM_index))
  (preX := pre_loaded_with_all_messages_vlsm X)
  (Hevents_set' := fun (i : index) => @simp_lv_observable_events index i index_listing _)
  (Hstate_events_set := fun (i : index) => @simp_lv_state_observations index i index_listing _)
  (Hevidence := fun (i : index) => @simp_observable_full index i index_listing idec)
  (Hstate_events_fn := fun (i : index) => (@simp_lv_observations index i index_listing _))
  (Hbasic := fun (i : index) => @simp_lv_basic_equivocation index i index_listing Hfinite idec Mindex Rindex).

  Local Notation in_listing := (proj2 Hfinite).

  (**  We begin with some basic facts about the given composition. *)

  (**  Protocol states are never bottom *)

  Lemma protocol_state_component_no_bottom
    (s : vstate X)
    (i : index)
    (Hprs : protocol_state_prop X s) :
    (s i) <> Bottom.
  Proof.
    apply (@protocol_prop_no_bottom index i _ _ (est' i)).
    apply protocol_state_projection with (j := i) in Hprs.
    unfold protocol_state_prop in Hprs.
    destruct Hprs as [om Hprs] in Hprs.
    apply proj_pre_loaded_with_all_messages_protocol_prop in Hprs.
    unfold protocol_state_prop.
    exists om.
    assumption.
  Qed.

  Proposition Hsnb
    (s : vstate X)
    (Hpr : protocol_state_prop X s) :
    forall (i : index), (s i) <> Bottom.
  Proof.
    intros i.
    apply protocol_state_component_no_bottom. intuition.
  Qed.

  (**  Applying a protocol plan of receive transitions do not alter the nodes'
     self-projections (i.e, <<project (s i) i >> *)

  Proposition self_projections_same_after_receive
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (i : index)
    (ai : vplan_item X)
    (Hrec : projT2 (label_a ai) = receive)
    (Hprai : finite_protocol_plan_from X s [ai]) :
    project ((snd (apply_plan X s [ai])) i) i = project (s i) i.
  Proof.
    apply finite_protocol_plan_from_one in Hprai.
    destruct Hprai as [Hprotocol Htransition].
    unfold protocol_valid in Hprotocol.
    unfold valid in Hprotocol.
    simpl in Hprotocol.
    unfold constrained_composite_valid in Hprotocol.
    unfold composite_valid in Hprotocol.
    unfold vvalid in Hprotocol.
    unfold valid in Hprotocol.
    simpl in Hprotocol.
    simpl in Hrec.
    destruct ai. simpl in *.
    destruct label_a. simpl in *. subst v. simpl in *.
    destruct input_a eqn : eq_input.
    + simpl in Htransition.
      assert (x <> fst m) by intuition.
      simpl.
      destruct (decide (i = x)).
      * subst x. rewrite state_update_eq.
        rewrite (@project_different index index_listing Hfinite).
        intuition. intuition.
        apply protocol_state_component_no_bottom. intuition.
     * rewrite state_update_neq by intuition.
       intuition.
    + intuition.
  Qed.

  Proposition self_projections_same_after_receives
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (a : plan X)
    (Hpra : finite_protocol_plan_from X s a)
    (Hrec : forall (ai : vplan_item X), In ai a -> projT2 (label_a ai) = receive) :
    let res := snd (apply_plan X s a) in
    forall (i : index), project (res i) i = project (s i) i.
  Proof.
    induction a using rev_ind.
    - intuition.
    - simpl in *.
      intros.
      rewrite apply_plan_app.
      destruct (apply_plan X s a) as (tr_long, res_long) eqn : eq_long.
      destruct (apply_plan X res_long [x]) as (tr_short, res_short) eqn : eq_short.

      assert (Hres_long : res_long = snd ((apply_plan X s a))) by (rewrite eq_long; intuition).
      assert (Hres_short : res_short = snd (apply_plan X res_long [x])) by (rewrite eq_short; intuition).
      simpl in *.

      apply finite_protocol_plan_from_app_iff in Hpra.
      destruct Hpra as [Hpra_long Hpra_short].

      specialize (IHa Hpra_long).

      spec IHa. {
        intros. specialize (Hrec ai).
        spec Hrec. apply in_app_iff. intuition. intuition.
      }

      specialize (IHa i).
      rewrite <- IHa.

      assert (Hpr_long : protocol_state_prop X res_long). {
        rewrite Hres_long.
        apply apply_plan_last_protocol.
        all : intuition.
      }

      specialize (self_projections_same_after_receive res_long Hpr_long i x) as Hone.
      spec Hone. {
        specialize (Hrec x). spec Hrec. apply in_app_iff. intuition.
        intuition.
     }
     rewrite Hres_long in Hone.
     specialize (Hone Hpra_short).
     rewrite Hres_short.
     rewrite Hres_long.
     intuition.
  Qed.

  (**  Applying a plan of send/update transitions does not alter
     non-self projections. *)

  Proposition non_self_projections_same_after_send
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (i j : index)
    (Hdif : i <> j)
    (ai : vplan_item X)
    (Hrec : exists (c : bool), projT2 (label_a ai) = update c)
    (Hprai : finite_protocol_plan_from X s [ai]) :
    project ((snd (apply_plan X s [ai])) i) j = project (s i) j.
  Proof.
    apply finite_protocol_plan_from_one in Hprai.
    destruct Hprai as [Hprotocol Htransition].
    unfold protocol_valid in Hprotocol.
    unfold valid in Hprotocol.
    simpl in Hprotocol.
    unfold constrained_composite_valid in Hprotocol.
    unfold composite_valid in Hprotocol.
    unfold vvalid in Hprotocol.
    unfold valid in Hprotocol.
    simpl in Hprotocol.
    simpl in Hrec.
    destruct ai. simpl in *.
    destruct label_a. simpl in *.
    destruct Hrec as [c Heqv].
    subst v. simpl in *.
    destruct input_a eqn : eq_input.
    + simpl in Htransition.
      intuition congruence.
    + destruct (decide (x = i)).
      * subst x.
        rewrite state_update_eq.
        rewrite <- update_consensus_clean with (value := c).
        rewrite (@project_different index index_listing Hfinite).
        intuition. intuition.
        apply protocol_state_component_no_bottom. intuition.
      * rewrite state_update_neq by intuition.
        intuition.
  Qed.

  Proposition non_self_projections_same_after_sends
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (a : plan X)
    (Hpra : finite_protocol_plan_from X s a)
    (Hrec : forall (ai : vplan_item X), In ai a -> exists (c : bool), projT2 (label_a ai) = update c) :
    let res := snd (apply_plan X s a) in
    forall (i j : index), i <> j -> project (res i) j = project (s i) j.
  Proof.
    induction a using rev_ind.
    - intuition.
    - simpl in *.
      intros.
      rewrite apply_plan_app.
      destruct (apply_plan X s a) as (tr_long, res_long) eqn : eq_long.
      destruct (apply_plan X res_long [x]) as (tr_short, res_short) eqn : eq_short.

      assert (Hres_long : res_long = snd ((apply_plan X s a))) by (rewrite eq_long; intuition).
      assert (Hres_short : res_short = snd (apply_plan X res_long [x])) by (rewrite eq_short; intuition).
      simpl in *.

      apply finite_protocol_plan_from_app_iff in Hpra.
      destruct Hpra as [Hpra_long Hpra_short].

      specialize (IHa Hpra_long).

      spec IHa. {
        intros. specialize (Hrec ai).
        spec Hrec. apply in_app_iff. intuition. intuition.
      }

      specialize (IHa i).
      rewrite <- IHa.

      assert (Hpr_long : protocol_state_prop X res_long). {
        rewrite Hres_long.
        apply apply_plan_last_protocol.
        all : intuition.
      }

      specialize (non_self_projections_same_after_send res_long Hpr_long i j H x) as Hone.
      spec Hone. {
        specialize (Hrec x). spec Hrec. apply in_app_iff. intuition.
        intuition.
     }
     rewrite Hres_long in Hone.
     specialize (Hone Hpra_short).
     rewrite Hres_short.
     rewrite Hres_long.
     intuition.
     intuition.
  Qed.

  Local Notation component_list s li := (List.map s li).

  Section EquivObsUtils.

  (** Here we instantiate the observation-based equivocation model for our composition.
     The implicit <<ws>> stands for "witness set" and it means, in short, that we only
     take into account validators in <<ws>> when gathering observations for the composite state.
     Note that these observations can concern anyone, but they can only be taken from local
     observations of validators in <<ws>>. *)

  Context
  {ws : set index}.

  Definition Hstate_validators := fun (i : index) => (fun (s : vstate (IM_index i)) => index_listing).

  Program Instance lv_composed_observable_events :
     observable_events (vstate X) simp_lv_event :=
     composite_state_observable_events_instance
     index_listing
     ws
     IM_index
     Hstate_events_fn
     Hstate_validators.

  Definition ce :=
  @composite_observable_events_equivocation_evidence
    message index simp_lv_event
    decide_eq
    index index_listing ws IM_index
    Hstate_events_fn
    Hstate_validators
    decide_eq
    simp_lv_event_lt
    simp_lv_event_lt_dec
    get_simp_event_subject_some.

  (** The honest set: Validators for which there is no evidence of equivocation.
     Note that some of these may actually be equivocating if we were to
     take into account observations originating outside of <<ws>> *)

  Definition wH (s : vstate X) : set index :=
    List.filter (fun i : index => negb (
    @bool_decide _ (@composite_observable_events_equivocation_evidence_dec
      message index simp_lv_event
      decide_eq
      index index_listing ws IM_index
      Hstate_events_fn
      Hstate_validators
      decide_eq
      simp_lv_event_lt
      simp_lv_event_lt_dec
      get_simp_event_subject_some s i))) index_listing.

  (** The equivocating set : Validators for which there is evidence of equivocation. *)

  Definition wE (s : vstate X) : set index :=
    List.filter (fun i : index =>
    @bool_decide _ (@composite_observable_events_equivocation_evidence_dec
      message index simp_lv_event
      decide_eq
      index index_listing ws IM_index
      Hstate_events_fn
      Hstate_validators
      decide_eq
      simp_lv_event_lt
      simp_lv_event_lt_dec
      get_simp_event_subject_some s i)) index_listing.

  (** Shorthands for the union of observations. *)

  Definition wcobs :=
    (composite_state_events_fn ws IM_index Hstate_events_fn).

  Definition wcobs_messages
    (s : vstate X)
    (target : index) :=
  fold_right (set_union decide_eq) [] (List.map (fun (i : index) => (simp_lv_message_observations (s i) target)) ws).

  Definition wcobs_states
    (s : vstate X)
    (target : index) : set simp_lv_event :=
    fold_right (set_union decide_eq) [] (List.map (fun (i : index) => (@simp_lv_state_observations index i index_listing _) (s i) target) ws).

  Remark cobs_single
    (s : vstate X)
    (target : index)
    (e : simp_lv_event) :
    In e (wcobs s target) <->
    exists (i : index), (In i ws) /\ (In e (@simp_lv_observations index i index_listing _ (s i) target)).
  Proof.
    split; intros.
    - apply set_union_in_iterated in H. rewrite Exists_exists in H.
      destruct H as [le [Hinle Hine]].
      apply in_map_iff in Hinle.
      destruct Hinle as [ii [Heqle Hini]].
      exists ii. rewrite <- Heqle in Hine. intuition.
    - apply set_union_in_iterated. rewrite Exists_exists.
      destruct H as [i Hi].
      exists (@simp_lv_observations index i index_listing _ (s i) target).
      split.
      + apply in_map_iff. exists i. split;intuition.
      + intuition.
  Qed.

  Remark cobs_single_s
    (s : vstate X)
    (target : index)
    (e : simp_lv_event) :
    In e (wcobs_states s target) <->
    exists (i : index), (In i ws) /\ (In e (@simp_lv_state_observations index i index_listing _ (s i) target)).
  Proof.
    split; intros.
    - apply set_union_in_iterated in H. rewrite Exists_exists in H.
      destruct H as [le [Hinle Hine]].
      apply in_map_iff in Hinle.
      destruct Hinle as [ii [Heqle Hini]].
      exists ii. rewrite <- Heqle in Hine. intuition.
    - apply set_union_in_iterated. rewrite Exists_exists.
      destruct H as [i Hi].
      exists (@simp_lv_state_observations index i index_listing _ (s i) target).
      split.
      + apply in_map_iff. exists i. split;intuition.
      + intuition.
  Qed.

  Remark cobs_single_m
    (s : vstate X)
    (target : index)
    (e : simp_lv_event) :
    In e (wcobs_messages s target) <->
    exists (i : index), (In i ws) /\ (In e (simp_lv_message_observations (s i) target)).
  Proof.
    split; intros.
    - apply set_union_in_iterated in H. rewrite Exists_exists in H.
      destruct H as [le [Hinle Hine]].
      apply in_map_iff in Hinle.
      destruct Hinle as [ii [Heqle Hini]].
      exists ii. rewrite <- Heqle in Hine. intuition.
    - apply set_union_in_iterated. rewrite Exists_exists.
      destruct H as [i Hi].
      exists (simp_lv_message_observations (s i) target).
      split.
      + apply in_map_iff. exists i. split;intuition.
      + intuition.
  Qed.

  Remark in_cobs_messages
    (s : vstate X)
    (target : index)
    (e : simp_lv_event)
    (Hin : In e (wcobs_messages s target)) :
    get_simp_event_type e = Message'.
  Proof.
    apply cobs_single_m in Hin.
    destruct Hin as [i [Hini Hine]].
    apply in_simp_lv_message_observations in Hine.
    intuition.
  Qed.

  Remark in_cobs_states
    (s : vstate X)
    (target : index)
    (e : simp_lv_event)
    (Hin : In e (wcobs_states s target)) :
    get_simp_event_type e = State'.
  Proof.
    apply cobs_single_s in Hin.
    destruct Hin as [i [Hini Hine]].
    apply in_simp_lv_state_observations in Hine.
    intuition.
  Qed.

  Remark cobs_messages_states
    (s : vstate X)
    (target : index) :
    set_eq (wcobs s target) (set_union decide_eq (wcobs_states s target) (wcobs_messages s target)).
  Proof.
    apply set_eq_extract_forall. intros.
    split; intros.
    - apply cobs_single in H.
      destruct H as [i [Hini Hobsi]].
      unfold simp_lv_observations in Hobsi.
      apply set_union_iff in Hobsi.
      apply set_union_iff.
      destruct Hobsi.
      + right. apply cobs_single_m.
        exists i. intuition.
      + left. apply cobs_single_s.
        exists i. intuition.
     - apply set_union_iff in H.
       destruct H.
       + apply cobs_single_s in H.
         destruct H as [i [Hini Hobsi]].
         apply cobs_single.
         exists i. split;[intuition|].
         apply in_simp_lv_state_observations'.
         intuition.
       + apply cobs_single_m in H.
         destruct H as [i [Hini Hobsi]].
         apply cobs_single.
         exists i. split;[intuition|].
         apply in_simp_lv_message_observations'.
         intuition.
  Qed.

  Remark in_cobs_and_message
    (s : vstate X)
    (target : index)
    (e : simp_lv_event)
    (Hm : get_simp_event_type e = Message')
    (Hin : In e (wcobs s target)) :
    In e (wcobs_messages s target).
  Proof.
    setoid_rewrite cobs_messages_states in Hin.
    apply set_union_iff in Hin.
    destruct Hin.
    - apply in_cobs_states in H. congruence.
    - intuition.
  Qed.

  Remark in_cobs_states'
    (s : vstate X)
    (target : index)
    (e : simp_lv_event)
    (Hin : In e (wcobs_states s target)) :
    In e (wcobs s target).
  Proof.
    setoid_rewrite cobs_messages_states.
    apply set_union_iff.
    left. intuition.
  Qed.

  Remark in_cobs_messages'
    (s : vstate X)
    (target : index)
    (e : simp_lv_event)
    (Hin : In e (wcobs_messages s target)) :
    In e (wcobs s target).
  Proof.
    setoid_rewrite cobs_messages_states.
    apply set_union_iff.
    right. intuition.
  Qed.

  Definition cequiv_evidence
    := (@equivocation_evidence
    (vstate X) index simp_lv_event
    _ decide_eq
    simp_lv_event_lt simp_lv_event_lt_dec
    get_simp_event_subject_some ce).

  (** There's at most one state observation
     regarding a fixed validator. *)

  Lemma unique_state_observation
    (s : vstate X)
    (i : index)
    (e : simp_lv_event)
    (Hin : In e (wcobs_states s i)) :
    e = SimpObs State' i (s i).
  Proof.
    unfold wcobs in Hin.
    unfold composite_state_events_fn in Hin; simpl in Hin.
    apply cobs_single_s in Hin.
    destruct Hin as [j [Hinj Hine]].
    unfold simp_lv_state_observations in Hine.
    destruct (decide (i = j)).
    - subst j.
      destruct Hine; intuition.
    - intuition.
  Qed.

  (** And if said validator is in <<ws>>,
     it's always there. *)

  Lemma state_obs_present
    (s : vstate X)
    (i : index)
    (Hin : In i ws) :
    In (SimpObs State' i (s i)) (wcobs_states s i).
  Proof.
    apply cobs_single_s.
    exists i.
    split;[intuition|].
    unfold simp_lv_state_observations.
    rewrite decide_True by intuition.
    intuition.
  Qed.

  Remark GE_direct
    (s : vstate X)
    (i : index) :
    In i (wE s) <-> (cequiv_evidence s i).
  Proof.
    split; intros.
    - unfold wE in H.
      unfold wH in H.
      apply filter_In in H.
      destruct H as [_ H].
      apply bool_decide_eq_true in H.
      intuition.
    - unfold wE.
      apply filter_In.
      split.
      apply ((proj2 Hfinite) i).
      apply bool_decide_eq_true.
      intuition.
  Qed.

  (** Shortcircuiting the lengthy translation
     between the observation typeclass and
     the above definitions. *)

  Remark hbo_cobs
    (s : vstate X)
    (e : simp_lv_event) :
    has_been_observed s e <->
    In e (wcobs s (get_simp_event_subject e)).
  Proof.
    unfold has_been_observed in *. simpl in *.
    unfold observable_events_has_been_observed in *.
    unfold state_observable_events_fn in *. simpl in *.
    unfold composite_state_events_fn in *. simpl in *.
    split; intros Hine.
    - apply set_union_in_iterated in Hine.
      rewrite Exists_exists in Hine.
      destruct Hine as [le [Hinle Hine]].
      apply in_map_iff in Hinle.
      destruct Hinle as [i [Heqle Hini]].
      assert (i = get_simp_event_subject e). {
        destruct (decide (i = get_simp_event_subject e)); [intuition|].
        rewrite <- Heqle in Hine.
        apply set_union_in_iterated in Hine.
        rewrite Exists_exists in Hine.
        destruct Hine as [le' [Hinle' Hine']].
        apply in_map_iff in Hinle'.
        destruct Hinle' as [k [Heqk Hink]].
        unfold Hstate_events_fn in Heqk.
        rewrite <- Heqk in Hine'.
        apply in_simp_lv_observations in Hine'.
        congruence.
      }
      rewrite <- H.
      unfold wcobs.
      unfold composite_state_events_fn.
      rewrite <- Heqle in Hine.
      intuition.
    - apply set_union_in_iterated.
      rewrite Exists_exists.
      exists (wcobs s (get_simp_event_subject e)).
      split.
      + apply in_map_iff.
        exists (get_simp_event_subject e).
        split.
        * intuition.
        * unfold composite_validators.
          unfold Hstate_validators.
          apply set_union_in_iterated.
          rewrite Exists_exists.
          exists index_listing.
          split.
          -- apply in_map_iff.
             exists inhabitant.
             split;[intuition|]. apply (proj2 Hfinite).
          -- apply ((proj2 Hfinite) (get_simp_event_subject e)).
     + intuition.
  Qed.

  (** We have actual equality due to these
     sets being the results of [filter]s. *)

  Remark wE_eq_equality
    (s s' : vstate X) :
    set_eq (wE s) (wE s') -> (wE s) = (wE s').
  Proof.
    intros.
    apply filter_set_eq.
    unfold wE in H.
    intuition.
  Qed.

  Remark wH_eq_equality
    (s s' : vstate X)
    (i : index) :
    set_eq (wH s) (wH s') -> (wH s) = (wH s').
  Proof.
    intros.
    apply filter_set_eq.
    unfold wH in H.
    intuition.
  Qed.

  Remark wH_wE'
    (s : vstate X)
    (i : index) :
    In i (wH s) <-> ~ In i (wE s).
  Proof.
    unfold wH.
    unfold wE.
    split; intros.
    - apply filter_In in H.
      intros contra.
      apply filter_In in contra.
      destruct H as [_ H].
      destruct contra as [_ contra].
      rewrite contra in H.
      unfold negb in H. congruence.
    - apply filter_In.
      split; [apply (proj2 Hfinite)|].
      rewrite negb_true_iff.
      match goal with
      |- ?e = _ =>
         destruct e eqn : eq_d end.
      + contradict H.
        apply filter_In.
        split; [apply (proj2 Hfinite)|].
        intuition.
      + intuition.
  Qed.

  Remark wE_wH'
    (s : vstate X)
    (i : index) :
    In i (wE s) <-> ~ In i (wH s).
  Proof.
    unfold wH.
    unfold wE.
    split; intros.
    - apply filter_In in H.
      intros contra.
      apply filter_In in contra.
      destruct H as [_ H].
      destruct contra as [_ contra].
      rewrite bool_decide_eq_true in H.
      rewrite negb_true_iff in contra.
      rewrite bool_decide_eq_false in contra.
      intuition.
    - apply filter_In.
      split; [apply (proj2 Hfinite)|].
      match goal with
      |- ?e = _ =>
        destruct e eqn : eq_d end.
      + intuition.
      + contradict H.
        apply filter_In.
        split;[apply in_listing|].
        rewrite negb_true_iff.
        intuition.
  Qed.

  Remark wH_wE
    (s : vstate X) :
    set_eq (wH s) (set_diff decide_eq index_listing (wE s)).
  Proof.
    apply set_eq_extract_forall.
    intros i.
    split; intros H.
    - apply set_diff_intro.
      apply (proj2 Hfinite i).
      apply wH_wE' in H.
      intuition.
    - apply set_diff_iff in H.
      destruct H as [_ H].
      apply wH_wE'.
      intuition.
  Qed.

  Remark HE_eq_equiv
    (s s' : vstate X) :
    (wH s) = (wH s') <-> (wE s) = (wE s').
  Proof.
    unfold wH. unfold wE.
    symmetry. apply filter_complement.
  Qed.

  (** We start to describe what happens to observations
     when doing composite updates (similarly to results in [Observations.v]). Some results
     that don't hold for arbitrary <<ws>> live outside
     this section. *)

  Lemma cobs_message_existing_other_lf
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (so : state)
    (i j target : index)
    (Hdif : i <> j)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j)
    (Hhave : In (SimpObs Message' j so) (wcobs s j)) :
    incl (wcobs_messages s' target) (wcobs_messages s target).
  Proof.
    assert (Hsnb : forall (k : index), (s k) <> Bottom). {
      intros k.
      apply protocol_state_component_no_bottom. intuition.
    }

    assert (Hsonb : so <> Bottom). {
        apply in_cobs_and_message in Hhave.
        apply cobs_single_m in Hhave.
        destruct Hhave as [k Hhave].
        destruct Hhave as [_ Hhave].
        apply (@in_message_observations_nb index index_listing Hfinite) in Hhave.
        all : intuition.
    }
    unfold incl.
    intros e.
    intros H.
    unfold wcobs_messages in H.
    apply cobs_single_m in H.
    destruct H as [k Hink].
    destruct (decide (k = i)).
    - subst k.
      unfold s' in Hink.
      rewrite state_update_eq in Hink.
      destruct (decide (j = target)).
      + subst target.
        destruct Hink as [Hink' Hink].
        apply (@new_incl_rest_same index index_listing Hfinite) in Hink.
        2 : {
          split. apply Hsnb; intuition. intuition.
        }
        2 : intuition.

        apply set_union_iff in Hink.
        destruct Hink as [Hink|Hink].
        * apply set_union_iff in Hink.
          destruct Hink as [Hink|Hink].
          -- apply cobs_single_m.
             exists i. intuition.
          -- apply in_cobs_and_message in Hhave.
             apply cobs_single_m in Hhave.
             destruct Hhave as [l Hhave].
             apply cobs_single_m.
             exists l.
             split;[intuition|].
             apply (@message_cross_observations index index_listing Hfinite) with (e1 := (SimpObs Message' j so)) (i := j).
             all : intuition.
       * destruct Hink;[|intuition].
         rewrite <- H.
         apply in_cobs_and_message in Hhave.
         all : intuition.

      + destruct Hink as [Hink' Hink].
        apply (@new_incl_rest_diff index index_listing Hfinite) in Hink.
        2 : {
          split. apply Hsnb; intuition. intuition.
        }
        2 : intuition.

        apply set_union_iff in Hink.
        destruct Hink as [Hink|Hink].
        apply cobs_single_m.
        exists i.
        split;[intuition|].
        intuition.
        apply in_cobs_and_message in Hhave.
        2 : intuition.
        apply cobs_single_m in Hhave.
        destruct Hhave as [l Hhave].
        apply cobs_single_m.
        exists l.
        split;[intuition|].
        apply (@message_cross_observations index index_listing Hfinite) with (e1 := (SimpObs Message' j so)) (i := j).
        intuition.
        simpl.
        intuition.
        intuition.
    - unfold s' in Hink.
      rewrite state_update_neq in Hink by intuition.
      apply cobs_single_m.
      exists k.
      intuition.
  Qed.

  Lemma cobs_message_existing_other_rt
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (so : state)
    (i j target : index)
    (Hdif : i <> j)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j)
    (Hhave : In (SimpObs Message' j so) (wcobs s j)) :
    incl (wcobs_messages s target) (wcobs_messages s' target).
  Proof.
    assert (Hsnb : forall (k : index), (s k) <> Bottom). {
      intros k.
      apply protocol_state_component_no_bottom. intuition.
    }

    assert (Hsonb : so <> Bottom). {
        apply in_cobs_and_message in Hhave.
        apply cobs_single_m in Hhave.
        destruct Hhave as [k Hhave].
        destruct Hhave as [_ Hhave].
        apply (@in_message_observations_nb index index_listing Hfinite) in Hhave.
        all : intuition.
    }

    unfold incl.
    intros.
    apply cobs_single_m in H.
    destruct H as [k H].
    destruct (decide (i = k)).
    - subst k.
      apply cobs_single_m.
      exists i.
      split;[intuition|].
      destruct H as [_ H].
      apply (@old_incl_new index index_listing Hfinite) with (so := so) (i := j) in H.
      unfold s'.
      rewrite state_update_eq.
      intuition.
      split. apply Hsnb. intuition.
      intuition.
   - apply cobs_single_m.
     exists k.
     unfold s'.
     rewrite state_update_neq.
     all : intuition.
  Qed.

  Lemma cobs_message_existing_other_rt'
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (so : state)
    (Hsonb : so <> Bottom)
    (i j target : index)
    (Hdif : i <> j)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j) :
    incl (wcobs_messages s target) (wcobs_messages s' target).
  Proof.
    assert (Hsnb : forall (k : index), (s k) <> Bottom). {
      intros k.
      apply protocol_state_component_no_bottom. intuition.
    }

    unfold incl.
    intros.
    apply cobs_single_m in H.
    destruct H as [k H].
    destruct (decide (i = k)).
    - subst k.
      apply cobs_single_m.
      exists i.
      split;[intuition|].
      destruct H as [_ H].
      apply (@old_incl_new index index_listing Hfinite) with (so := so) (i := j) in H.
      unfold s'.
      rewrite state_update_eq.
      intuition.
      split. apply Hsnb. intuition.
      intuition.
   - apply cobs_single_m.
     exists k.
     unfold s'.
     rewrite state_update_neq.
     all : intuition.
  Qed.

  Lemma cobs_message_existing_other
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (so : state)
    (i j target : index)
    (Hdif : i <> j)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j)
    (Hhave : In (SimpObs Message' j so) (wcobs s j)) :
    set_eq (wcobs_messages s target) (wcobs_messages s' target).
  Proof.
    unfold set_eq.
    split.
    - apply cobs_message_existing_other_rt.
      all : intuition.
    - apply cobs_message_existing_other_lf.
      all : intuition.
  Qed.

  Lemma wcobs_message_existing_same1
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (b : bool)
    (i target : index)
    (Hdif : i <> target)
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b)) :
    incl (wcobs_messages s target) (wcobs_messages s' target).
  Proof.
    assert (Hsnb : forall (k : index), (s k) <> Bottom). {
      intros k.
      apply protocol_state_component_no_bottom. intuition.
    }

    intros e.
    intros H.
    - apply cobs_single_m in H.
      destruct H as [k H].
      destruct (decide (k = i)).
      + subst k.
        destruct H as [H' H].
        apply (@old_incl_new index index_listing Hfinite) with (so := (s i)) (i := i) in H.
        apply cobs_single_m.
        exists i.
        unfold s'.
        rewrite state_update_eq.
        rewrite cons_clean_message_obs with (b0 := b) in H.
        split;[intuition|].
        intuition.
        split; apply Hsnb.
        intuition.
      + apply cobs_single_m.
        exists k.
        unfold s'.
        rewrite state_update_neq.
        all : intuition.
  Qed.

  Lemma wcobs_message_existing_same2
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (b : bool)
    (i : index)
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b)) :
    incl (wcobs_messages s i) (wcobs_messages s' i).
  Proof.
    assert (Hsnb : forall (k : index), (s k) <> Bottom). {
      intros k.
      apply protocol_state_component_no_bottom. intuition.
    }
    intros e.
    intros H.
    -
      + apply cobs_single_m in H.
        destruct H as [k [H' H]].
        destruct (decide (i = k)).
        * subst k.
          apply (@old_incl_new index index_listing Hfinite) with (so := (s i)) (i := i) in H.
          apply cobs_single_m.
          exists i.
          unfold s'.
          rewrite state_update_eq.
          rewrite cons_clean_message_obs with (b0 := b) in H.
          split;[intuition|].
          intuition.
          split; apply Hsnb.
          intuition.
        * apply cobs_single_m.
          exists k.
          unfold s'.
          rewrite state_update_neq.
          split;[intuition|].
          all : intuition.
  Qed.

  Lemma in_future_message_obs
    (s s' : vstate X)
    (target : index)
    (Hf : in_futures X s s')
    (e : simp_lv_event)
    (Hin : In e (wcobs_messages s target)) :
    In e (wcobs_messages s' target).
  Proof.
    unfold in_futures in Hf.
    destruct Hf as [tr Hpr].
    induction Hpr.
    - assumption.
    - apply IHHpr; clear IHHpr.
      apply protocol_transition_origin in H as Hprs'.
      destruct H as [Hproto Htrans].
      unfold transition in Htrans.
      simpl in Htrans.
      destruct l. simpl in *.
      unfold constrained_composite_valid in Hproto.
      unfold composite_valid in Hproto.
      unfold vvalid in Hproto. unfold valid in Hproto. simpl in *.
      unfold vtransition in Htrans.
      unfold transition in Htrans. simpl in Htrans.
      destruct v eqn : eq_v.
      + subst v.
        inversion Htrans.
        destruct (decide (x = target)).
        * subst x.
          apply wcobs_message_existing_same2. intuition. intuition.
        * apply wcobs_message_existing_same1; intuition.
      + destruct iom eqn : eq_iom;[|solve[intuition]].
        inversion Htrans;clear Htrans;subst s oom.
        specialize (cobs_message_existing_other_rt' s' Hprs' (snd m)) as Hex.
        spec Hex. apply Hproto.
        specialize (Hex x (fst m) target).
        spec Hex. apply Hproto. simpl in Hex.
        spec Hex. apply Hproto.
        apply Hex. assumption.
  Qed.

  End EquivObsUtils.

  Lemma ws_incl_cobs
    (s : vstate X)
    (i : index)
    (ws ws' : set index)
    (Hincl : incl ws' ws)
    (e : simp_lv_event) :
    In e (@wcobs ws' s i) -> In e (@wcobs ws s i).
  Proof.
    intros.
    unfold wcobs in *.
    unfold composite_state_events_fn in *.
    apply set_union_in_iterated in H; rewrite Exists_exists in H.
    apply set_union_in_iterated. apply Exists_exists.
    destruct H as [le [H1 H2]].
    exists le.
    apply in_map_iff in H1. destruct H1 as [j [Hj Hinj]].
    split.
    - apply in_map_iff.
      exists j. intuition.
    - intuition.
  Qed.

  Lemma ws_incl_wE
    (s : vstate X)
    (ws ws' : set index)
    (Hincl : incl ws' ws) :
    incl (@wE ws' s) (@wE ws s).
  Proof.
    unfold incl. intros.
    apply GE_direct in H.
    apply GE_direct.
    unfold cequiv_evidence in *.
    unfold equivocation_evidence in *.
    setoid_rewrite hbo_cobs.
    setoid_rewrite hbo_cobs in H.
    destruct H as [e1 [He1 [He1' [e2 [He2 [He2' Hcomp]]]]]].
    exists e1.
    apply ws_incl_cobs with (ws := ws) in He1. 2 : intuition.
    split;[intuition|].
    split;[intuition|].
    exists e2.
    apply ws_incl_cobs with (ws := ws) in He2. 2 : intuition.
    intuition.
  Qed.

  (** GH := the set of globally honest validators: no evidence of equiv. exists at all.
     HH := the set of honest-looking-for-the-honest validators: members of GH have
     no evidence of equiv. regarding these validators.
     LH i := the set of locally honest validators (<<ws>> is a singleton). *)

  Definition GE := @wE index_listing.
  Definition GH := @wH index_listing.
  Definition cobs (s : vstate X) := @wcobs index_listing s.
  Definition cobs_messages (s : vstate X) := @wcobs_messages index_listing s.
  Definition cobs_states (s : vstate X) := @wcobs_states index_listing s.

  Definition HE (s : vstate X) := @wE (GH s) s.
  Definition HH (s : vstate X) := @wH (GH s) s.

  Definition hcobs (s : vstate X) := @wcobs (GH s) s.
  Definition hcobs_messages (s : vstate X) := @wcobs_messages (GH s) s.
  Definition hcobs_states (s : vstate X) := @wcobs_states (GH s) s.

  Definition LE (i : index) := (@wE [i]).
  Definition LH (i : index) := (@wH [i]).

  Remark GH_NoDup
    (s : vstate X) :
    NoDup (GH s).
  Proof.
    unfold GH.
    apply NoDup_filter.
    apply (proj1 Hfinite).
  Qed.

  Lemma cobs_message_existing_same1
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (b : bool)
    (i target : index)
    (Hdif : i <> target)
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b)) :
    set_eq (cobs_messages s' target) (cobs_messages s target).
  Proof.
    apply set_eq_extract_forall.
    intros e.
    split; intros H.
    - apply cobs_single_m in H.
      destruct H as [k H].
      destruct (decide (k = i)).
      + subst k.
        unfold s' in H.
        rewrite state_update_eq in H.
        rewrite <- cons_clean_message_obs in H.
        destruct H as [_ H].
        apply (@new_incl_rest_diff index index_listing Hfinite) in H.
        apply set_union_iff in H.
        destruct H; (apply cobs_single_m; exists i; split;[apply in_listing|intuition]).
        split; apply Hsnb.
        all :intuition.
      + unfold s' in H.
        rewrite state_update_neq in H.
        apply cobs_single_m.
        exists k. all : intuition.
    - apply wcobs_message_existing_same1; intuition.
  Qed.

  Lemma cobs_message_existing_same2
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (b : bool)
    (i : index)
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b)) :
    set_eq (cobs_messages s' i) (set_union decide_eq (cobs_messages s i) [SimpObs Message' i (s i)]).
  Proof.
    apply set_eq_extract_forall.
    intros e.
    split; intros H.
    - apply cobs_single_m in H.
      apply set_union_iff.
      destruct H as [k H].
      destruct (decide (i = k)).
      + subst k.
        unfold s' in H.
        rewrite state_update_eq in H by intuition.
        rewrite <- cons_clean_message_obs with (b0 := b) in H.
        destruct H as [_ H].
        apply (@new_incl_rest_same index index_listing Hfinite) in H.
        apply set_union_iff in H.
        destruct H as [H|H];[|right;intuition].
        apply set_union_iff in H.
        destruct H; left; apply cobs_single_m; exists i; (split;[apply in_listing|intuition]).
        split; apply Hsnb; intuition.
        intuition.
      + left.
        unfold s' in H.
        rewrite state_update_neq in H by intuition.
        apply cobs_single_m. exists k. intuition.
    -  apply set_union_iff in H.
      destruct H as [H | H].
      + apply wcobs_message_existing_same2; intuition.
      + apply cobs_single_m.
        exists i.
        unfold s'.
        rewrite state_update_eq by intuition.
        destruct H;[|intuition].
        rewrite <- cons_clean_message_obs with (b0 := b).
        assert (project (update_state (s i) (s i) i) i = s i). {
          rewrite (@project_same index index_listing).
          intuition.
          intuition.
          apply Hsnb; intuition.
        }
        split;[apply in_listing|].
        apply refold_simp_lv_observations1.
        unfold update_state.
        destruct (s i) eqn : eq_si.
        specialize (Hsnb s Hpr i). congruence.
        congruence.
        rewrite H0.
        apply Hsnb; intuition.
        rewrite H0.
        intuition.
  Qed.

  (** The following set of results allow us to conclude that our
     common future-finding procedure maintains the same set of globally
     honest validators. *)

  Lemma GE_existing_same_state_message
    (s : vstate X)
    (es2 : state)
    (Hprs : protocol_state_prop X s)
    (b : bool)
    (i v : index)
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b))
    (Hine2 : In (SimpObs Message' v es2) (cobs_messages s' v))
    (Hcomp : ~ comparable simp_lv_event_lt (SimpObs State' v (s' v)) (SimpObs Message' v es2)) :
    @cequiv_evidence index_listing s v.
  Proof.
    unfold cequiv_evidence.
    unfold equivocation_evidence.
    setoid_rewrite hbo_cobs.
    destruct (decide (i = v)).
    - subst i.
      unfold s' in Hine2.
      setoid_rewrite cobs_message_existing_same2 in Hine2.
      2 : intuition.
      apply set_union_iff in Hine2.
      destruct Hine2 as [Hine2|Hine2].
      + exists (SimpObs State' v (s v)).
        split.
            * simpl.
              apply in_cobs_states'.
              apply state_obs_present.
              apply in_listing.
            * split; [simpl;intuition|].
                exists (SimpObs Message' v es2).
                split.
                -- simpl. apply in_cobs_messages'. intuition.
                -- split;[simpl;intuition|].
                   intros contra.
                   apply comparable_commutative in contra.
                   apply (@state_obs_stuff_cons index v index_listing Hfinite) with (so := (s v)) (i := v) (b := b) in contra.
                   unfold s' in Hcomp.
                   apply comparable_commutative in contra.
                   rewrite state_update_eq in Hcomp.
                   intuition.
                   split;apply Hsnb; intuition.
                   intuition.
                   simpl. congruence.
                   simpl. congruence.
          +  destruct Hine2; [|intuition].
             inversion H.
             subst es2.
             contradict Hcomp.
             unfold comparable.
             right. right.
             unfold simp_lv_event_lt.
             rewrite decide_True by intuition.
             unfold s'.
             rewrite state_update_eq.
             unfold state_lt'.
             rewrite history_disregards_cv.
             rewrite (@unfold_history_cons index index_listing Hfinite).
             simpl. left.
             rewrite (@project_same index index_listing Hfinite).
             intuition.
             apply Hsnb; intuition.
             rewrite (@project_same index index_listing Hfinite).
             apply Hsnb; intuition.
             apply Hsnb; intuition.
         - unfold s' in Hine2.
           setoid_rewrite cobs_message_existing_same1 in Hine2.
           2, 3 : intuition.
           exists (SimpObs State' v (s v)).
             split.
             * simpl.
                apply in_cobs_states'.
                apply state_obs_present.
                apply in_listing.
             * split; [simpl;intuition|].
                exists (SimpObs Message' v es2).
                split.
                -- simpl. apply in_cobs_messages'. intuition.
                -- split;[simpl;intuition|].
                   intros contra.
                   apply comparable_commutative in contra.
                   unfold s' in Hcomp.
                   rewrite state_update_neq in Hcomp.
                   apply comparable_commutative in contra.
                   all : intuition.
  Qed.

  Lemma GE_existing_same
    (s : vstate X)
    (Hprs : protocol_state_prop X s)
    (b : bool)
    (i : index)
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b)) :
    incl (GE s') (GE s).
  Proof.
    unfold incl; intros v H.
    apply GE_direct in H as Hev.
    apply GE_direct.
    unfold cequiv_evidence in *.
    unfold equivocation_evidence in *.
    destruct Hev as [e1 [Hine1 [He1subj Hrem]]].
    destruct Hrem as [e2 [Hine2 [He2subj Hcomp]]].
    destruct e1 as [et1 ev1 es1] eqn : eq_e1.
    destruct e2 as [et2 ev2 es2] eqn : eq_e2.
    apply hbo_cobs in Hine1.
    apply hbo_cobs in Hine2.

    setoid_rewrite hbo_cobs.
    unfold get_simp_event_subject_some.

    assert (Hv : ev1 = v /\ ev2 = v). {
      rewrite <- He2subj in He1subj.
      unfold get_simp_event_subject_some in He1subj.
      inversion He1subj.
      unfold get_simp_event_subject_some in He2subj.
      inversion He2subj.
      intuition.
    }

    destruct Hv as [Hv1 Hv2].
    subst ev1. subst ev2.

    setoid_rewrite cobs_messages_states in Hine1.
    setoid_rewrite cobs_messages_states in Hine2.
    apply set_union_iff in Hine1.
    apply set_union_iff in Hine2.
    simpl in *.
    destruct Hine1 as [Hine1|Hine1].
    - apply in_cobs_states in Hine1 as Het1.
      simpl in Het1.
      subst et1.
      apply unique_state_observation in Hine1.
      simpl in Hine1.
      inversion Hine1.
      subst es1.
      destruct Hine2 as [Hine2|Hine2].
      + (** State and state : immediate contradiction *)
        apply in_cobs_states in Hine2 as Het2.
        simpl in Het2.
        subst et2.
        apply unique_state_observation in Hine2.
        simpl in Hine2.
        inversion Hine2.
        subst es2.
        unfold comparable in Hcomp.
        contradict Hcomp.
        left. intuition.
      + (*State and message *)
        apply in_cobs_messages in Hine2 as Het2.
        simpl in Het2. subst et2.
        specialize (GE_existing_same_state_message s es2 Hprs b i v Hine2 Hcomp) as Hev.
        unfold cequiv_evidence in Hev. unfold equivocation_evidence in Hev.
        setoid_rewrite hbo_cobs in Hev. intuition.
     - apply in_cobs_messages in Hine1 as Het1.
       simpl in Het1. subst et1.
       destruct Hine2 as [Hine2|Hine2].
       + apply in_cobs_states in Hine2 as Het2.
         simpl in Het2. subst et2.
         apply unique_state_observation in Hine2.
         inversion Hine2. subst es2.
         rewrite comparable_commutative in Hcomp.
         specialize (GE_existing_same_state_message s es1 Hprs b i v Hine1 Hcomp) as Hev.
         unfold cequiv_evidence in Hev. unfold equivocation_evidence in Hev.
         setoid_rewrite hbo_cobs in Hev. intuition.
       + apply in_cobs_messages in Hine2 as Het2.
         simpl in Het2. subst et2.
         destruct (decide (i = v)).
         * subst v.
           unfold s' in Hine1, Hine2.
           setoid_rewrite cobs_message_existing_same2 in Hine1.
           2 : intuition.
           setoid_rewrite cobs_message_existing_same2 in Hine2.
           2 : intuition.
           apply set_union_iff in Hine1.
           apply set_union_iff in Hine2.

           destruct Hine1 as [Hine1|Hine1].
           -- destruct Hine2 as [Hine2|Hine2].
              ++ exists e1. subst e1. simpl.
                 split;[apply in_cobs_messages' in Hine1; intuition|].
                 split;[intuition|].
                 exists e2. subst e2. simpl.
                 split;[apply in_cobs_messages' in Hine2; intuition|].
                 split;[intuition|].
                 intuition.
              ++ destruct Hine2;[|intuition].
                 inversion H0. subst es2.
                 exists e1. subst e1. simpl.
                 split;[apply in_cobs_messages' in Hine1; intuition|].
                 split;[intuition|].
                 exists (SimpObs State' i (s i)). simpl.
                 split;[apply in_cobs_states';apply state_obs_present; intuition|].
                 apply in_listing.
                 split;[intuition|].
                 intros contra.
                 unfold comparable in contra.
                 destruct contra as [contra|contra];[congruence|].
                 destruct contra as [contra|contra].
                 ** unfold simp_lv_event_lt in contra.
                    rewrite decide_True in contra by intuition.
                    contradict Hcomp.
                    unfold comparable.
                    right. left.
                    unfold simp_lv_event_lt.
                    rewrite decide_True by intuition.
                    intuition.
                 ** unfold simp_lv_event_lt in contra.
                    rewrite decide_True in contra by intuition.
                    intuition.
           -- destruct Hine2 as [Hine2|Hine2].
              ++ destruct Hine1;[|intuition].
                 inversion H0. subst es1.
                 exists e2. subst e2. simpl.
                 split;[apply in_cobs_messages' in Hine2; intuition|].
                 split;[intuition|].
                 exists (SimpObs State' i (s i)). simpl.
                 split;[apply in_cobs_states';apply state_obs_present; intuition|].
                 apply in_listing.
                 split;[intuition|].
                 intros contra.
                 unfold comparable in contra.
                 destruct contra as [contra|contra];[congruence|].
                 destruct contra as [contra|contra].
                 ** unfold simp_lv_event_lt in contra.
                    rewrite decide_True in contra by intuition.
                    contradict Hcomp.
                    unfold comparable.
                    right. right.
                    unfold simp_lv_event_lt.
                    rewrite decide_True by intuition.
                    intuition.
                 ** unfold simp_lv_event_lt in contra.
                    rewrite decide_True in contra by intuition.
                    intuition.
              ++ destruct Hine1 as [Hine1|];[|intuition].
                 destruct Hine2 as [Hine2|];[|intuition].
                 inversion Hine1. inversion Hine2.
                 subst es1. subst es2.
                 contradict Hcomp.
                 unfold comparable.
                 left. intuition.
        * unfold s' in Hine1, Hine2.
          setoid_rewrite cobs_message_existing_same1 in Hine1.
          2, 3 : intuition.
          setoid_rewrite cobs_message_existing_same1 in Hine2.
          2, 3 : intuition.
          exists e1. subst e1. simpl.
          split;[apply in_cobs_messages';intuition|].
          split;[intuition|].
          exists e2. subst e2. simpl.
          split;[apply in_cobs_messages';intuition|].
          split;[intuition|].
          intuition.
  Qed.

  Lemma GE_existing_different_state_message
    (s : vstate X)
    (Hprs : protocol_state_prop X s)
    (i j v : index)
    (Hdif : i <> j)
    (es2 so : state)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j)
    (Hhave : In (SimpObs Message' j so) (cobs s j))
    (Hine2 : In (SimpObs Message' v es2) (cobs_messages s' v))
    (Hcomp : ~ comparable simp_lv_event_lt (SimpObs State' v (s' v)) (SimpObs Message' v es2)) :
    @cequiv_evidence index_listing s v.
  Proof.
    assert (Hsnb : forall (k : index), (s k) <> Bottom). {
      intros k.
      apply protocol_state_component_no_bottom. intuition.
    }

    assert (Hsonb : so <> Bottom). {
        apply in_cobs_and_message in Hhave.
        apply cobs_single_m in Hhave.
        destruct Hhave as [k [_ Hhave]].
        apply (@in_message_observations_nb index index_listing Hfinite) in Hhave.
        all : intuition.
    }

    unfold cequiv_evidence.
    unfold equivocation_evidence. setoid_rewrite hbo_cobs.
    unfold s' in Hine2.
        setoid_rewrite <- cobs_message_existing_other in Hine2.
        2, 3, 4, 5: intuition.
        exists (SimpObs Message' v es2). simpl.
        split;[apply in_cobs_messages';intuition|].
        split;[intuition|].
        destruct (decide (i = v)).
        * exists (SimpObs State' v (s v)). simpl.
          subst v.
          split;[apply in_cobs_states'; apply state_obs_present|].
          apply in_listing.
          split;[intuition|].
          intros contra.
          apply (@state_obs_stuff index i index_listing Hfinite) with (so := so) (i0 := j) in contra.
          unfold s' in Hcomp.
          apply comparable_commutative in contra.
          rewrite state_update_eq in Hcomp by intuition.
          intuition.
          split;[apply Hsnb|intuition].
          intuition.
          simpl. congruence.
          simpl. intuition.
        * unfold s' in *.
          rewrite state_update_neq in Hcomp.
          exists (SimpObs State' v (s v)).
          simpl.
          split;[apply in_cobs_states';apply state_obs_present|].
          apply in_listing.
          split;[simpl;intuition|].
          intros contra.
          apply comparable_commutative in contra.
          all : intuition.
  Qed.

  Lemma GE_existing_different
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (so : state)
    (i j : index)
    (Hdif : i <> j)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j)
    (Hhave : In (SimpObs Message' j so) (cobs s j)) :
    incl (GE s') (GE s).
  Proof.
    unfold incl; intros v H.
    apply GE_direct in H as Hev.
    apply GE_direct.
    unfold cequiv_evidence in *.
    unfold equivocation_evidence in *.
    destruct Hev as [e1 [Hine1 [He1subj Hrem]]].
    destruct Hrem as [e2 [Hine2 [He2subj Hcomp]]].
    destruct e1 as [et1 ev1 es1] eqn : eq_e1.
    destruct e2 as [et2 ev2 es2] eqn : eq_e2.
    apply hbo_cobs in Hine1.
    apply hbo_cobs in Hine2.

    setoid_rewrite hbo_cobs.
    unfold get_simp_event_subject_some.

    assert (Hv : ev1 = v /\ ev2 = v). {
      rewrite <- He2subj in He1subj.
      unfold get_simp_event_subject_some in He1subj.
      inversion He1subj.
      unfold get_simp_event_subject_some in He2subj.
      inversion He2subj.
      intuition.
    }

    destruct Hv as [Hv1 Hv2].
    subst ev1. subst ev2.

    setoid_rewrite cobs_messages_states in Hine1.
    setoid_rewrite cobs_messages_states in Hine2.
    apply set_union_iff in Hine1.
    apply set_union_iff in Hine2.

    destruct Hine1 as [Hine1|Hine1].
    - apply in_cobs_states in Hine1 as Het1.
      simpl in Het1. subst et1.
      apply unique_state_observation in Hine1. simpl in Hine1.
      inversion Hine1. subst es1.
      destruct Hine2 as [Hine2|Hine2].
      + apply in_cobs_states in Hine2 as Het2.
        simpl in Het2. subst et2.
        apply unique_state_observation in Hine2. simpl in Hine2.
        inversion Hine2. subst es2.
        contradict Hcomp.
        unfold comparable. left. intuition.
      + apply in_cobs_messages in Hine2 as Het2.
        simpl in Het2. subst et2. simpl in Hine2.
        specialize (GE_existing_different_state_message s Hpr i j v Hdif es2 so Hfull Hhave Hine2 Hcomp) as Hev.
        setoid_rewrite <- hbo_cobs. intuition.
    - apply in_cobs_messages in Hine1 as Het1.
      simpl in Het1. subst et1. simpl in Hine1.
      destruct Hine2 as [Hine2|Hine2].
      + apply in_cobs_states in Hine2 as Het2.
        simpl in Het2. subst et2.
        apply unique_state_observation in Hine2. simpl in Hine2.
        inversion Hine2. subst es2.
        rewrite comparable_commutative in Hcomp.
        specialize (GE_existing_different_state_message s Hpr i j v Hdif es1 so Hfull Hhave Hine1 Hcomp) as Hev.
        setoid_rewrite <- hbo_cobs. intuition.
      + apply in_cobs_messages in Hine2 as Het2.
        simpl in Het2. subst et2. simpl in Hine2.
        unfold s' in Hine2. unfold s' in Hine1.
        setoid_rewrite <- cobs_message_existing_other in Hine2.
        setoid_rewrite <- cobs_message_existing_other in Hine1.
        2, 3, 4, 5: intuition.
        2, 3, 4, 5: intuition.
        exists e1. subst e1. simpl.
        split;[apply in_cobs_messages';intuition|].
        split;[intuition|].
        exists e2. subst e2. simpl.
        split;[apply in_cobs_messages';intuition|].
        split;[intuition|].
        intuition.
  Qed.

  Lemma GE_existing_same_rev
    (s : vstate X)
    (Hprs : protocol_state_prop X s)
    (b : bool)
    (i : index)
    (Hhonest : ~ In i (GE s))
    (s' := state_update IM_index s i (update_consensus (update_state (s i) (s i) i) b)) :
    incl (GE s) (GE s').
  Proof.
    unfold incl; intros v H.
    apply GE_direct in H as Hev.
    apply GE_direct.
    unfold cequiv_evidence in *.
    unfold equivocation_evidence in *.
    destruct Hev as [e1 [Hine1 [He1subj Hrem]]].
    destruct Hrem as [e2 [Hine2 [He2subj Hcomp]]].
    destruct e1 as [et1 ev1 es1] eqn : eq_e1.
    destruct e2 as [et2 ev2 es2] eqn : eq_e2.
    apply hbo_cobs in Hine1.
    apply hbo_cobs in Hine2.

    setoid_rewrite hbo_cobs.
    unfold get_simp_event_subject_some.

    assert (Hv : ev1 = v /\ ev2 = v). {
      rewrite <- He2subj in He1subj.
      unfold get_simp_event_subject_some in He1subj.
      inversion He1subj.
      unfold get_simp_event_subject_some in He2subj.
      inversion He2subj.
      intuition.
    }

    destruct Hv as [Hv1 Hv2].
    subst ev1. subst ev2.

    setoid_rewrite cobs_messages_states in Hine1.
    setoid_rewrite cobs_messages_states in Hine2.
    apply set_union_iff in Hine1.
    apply set_union_iff in Hine2.

    destruct Hine1 as [Hine1|Hine1].
    - apply in_cobs_states in Hine1 as Het1.
      simpl in Het1.
      subst et1.
      apply unique_state_observation in Hine1.
      simpl in Hine1.
      inversion Hine1.
      subst es1.
      destruct Hine2 as [Hine2|Hine2].
      + apply in_cobs_states in Hine2 as Het2.
        simpl in Het2.
        subst et2.
        apply unique_state_observation in Hine2.
        simpl in Hine2.
        inversion Hine2.
        subst es2.
        unfold comparable in Hcomp.
        contradict Hcomp.
        left. intuition.
      + apply in_cobs_messages in Hine2 as Het2.
        simpl in Het2.
        subst et2.
        destruct (decide (i = v)).
        * subst v.
          intuition.
        * exists (SimpObs State' v (s' v)).
          split;[apply in_cobs_states';apply state_obs_present|].
          apply in_listing.
          split;[intuition|].
          exists e2. subst e2.
          simpl in *.
          unfold s'.
          rewrite state_update_neq by intuition.
          split.
          -- apply in_cobs_messages'.
             setoid_rewrite cobs_message_existing_same1.
             all : intuition.
          -- split;intuition.
     - apply in_cobs_messages in Hine1 as Het1.
       simpl in Het1. subst et1.
       destruct Hine2 as [Hine2|Hine2].
       + apply in_cobs_states in Hine2 as Het2.
         simpl in Het2. subst et2.
         apply unique_state_observation in Hine2.
         simpl in Hine2.
         inversion Hine2. subst es2.
         destruct (decide (i = v)).
        * subst v.
          intuition.
        * exists (SimpObs State' v (s' v)).
          split;[apply in_cobs_states';apply state_obs_present|].
          apply in_listing.
          split;[intuition|].
          exists e1. subst e1.
          simpl in *.
          unfold s'.
          rewrite state_update_neq by intuition.
          split.
          -- apply in_cobs_messages'.
             setoid_rewrite cobs_message_existing_same1.
             all : intuition.
          -- split;[intuition|].
             intros contra.
             apply comparable_commutative in contra.
             intuition.
       + apply in_cobs_messages in Hine2 as Het2.
         simpl in Het2.
         subst et2.

         destruct (decide (i = v)); [subst v;intuition|].

         exists e1. subst e1. simpl in *.
         split.
         * apply in_cobs_messages'.
           unfold s'.
           setoid_rewrite cobs_message_existing_same1.
           all : intuition.
         * split;[intuition|].
           exists e2. subst e2. simpl in *.
           split.
           -- apply in_cobs_messages'.
              unfold s'.
              setoid_rewrite cobs_message_existing_same1.
              all : intuition.
           -- intuition.
  Qed.

  Lemma GE_existing_different_rev
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (so : state)
    (i j : index)
    (Hdif : i <> j)
    (s' := state_update IM_index s i (update_state (s i) so j))
    (Hfull : project (s i) j = project so j)
    (Hhave : In (SimpObs Message' j so) (cobs s j)) :
    incl (GE s) (GE s').
  Proof.
    assert (Hsonb : so <> Bottom). {
        apply in_cobs_and_message in Hhave.
        apply cobs_single_m in Hhave.
        destruct Hhave as [k [_ Hhave]].
        apply (@in_message_observations_nb index index_listing Hfinite) in Hhave.
        all : intuition.
    }

    unfold incl; intros v H.
    apply GE_direct in H as Hev.
    apply GE_direct.
    unfold cequiv_evidence in *.
    unfold equivocation_evidence in *.
    destruct Hev as [e1 [Hine1 [He1subj Hrem]]].
    destruct Hrem as [e2 [Hine2 [He2subj Hcomp]]].
    destruct e1 as [et1 ev1 es1] eqn : eq_e1.
    destruct e2 as [et2 ev2 es2] eqn : eq_e2.
    apply hbo_cobs in Hine1.
    apply hbo_cobs in Hine2.

    setoid_rewrite hbo_cobs.
    unfold get_simp_event_subject_some.

    assert (Hv : ev1 = v /\ ev2 = v). {
      rewrite <- He2subj in He1subj.
      unfold get_simp_event_subject_some in He1subj.
      inversion He1subj.
      unfold get_simp_event_subject_some in He2subj.
      inversion He2subj.
      intuition.
    }

    destruct Hv as [Hv1 Hv2].
    subst ev1. subst ev2.

    setoid_rewrite cobs_messages_states in Hine1.
    setoid_rewrite cobs_messages_states in Hine2.
    apply set_union_iff in Hine1.
    apply set_union_iff in Hine2.

    destruct Hine1 as [Hine1|Hine1].
    - apply in_cobs_states in Hine1 as Het1.
      simpl in Het1. subst et1.
      apply unique_state_observation in Hine1. simpl in Hine1.
      inversion Hine1. subst es1.
      destruct Hine2 as [Hine2|Hine2].
      + apply in_cobs_states in Hine2 as Het2.
        simpl in Het2. subst et2.
        apply unique_state_observation in Hine2. simpl in Hine2.
        inversion Hine2. subst es2.
        contradict Hcomp.
        unfold comparable. left. intuition.
      + apply in_cobs_messages in Hine2 as Het2.
        simpl in Het2. subst et2. simpl in Hine2.

        exists (SimpObs State' v (s' v)). simpl.
        split;[apply in_cobs_states';apply state_obs_present|].
        apply in_listing.
        split;[intuition|].
        exists e2. subst e2. simpl in *.
        split.
        * apply in_cobs_messages'.
          unfold s'.
          setoid_rewrite <- cobs_message_existing_other.
          all :intuition.
        * split;[intuition|].
          unfold s'.
          destruct (decide (i = v)).
          -- subst v.
             rewrite state_update_eq.
             intros contra.
             unfold comparable in contra.
             destruct contra as [contra|contra];[congruence|].
             unfold simp_lv_event_lt in contra.
             rewrite decide_True in contra by intuition.
             destruct contra as [contra|contra];[intuition|].
             rewrite decide_True in contra by intuition.
             unfold state_lt' in contra.

             contradict Hcomp.
             unfold comparable.
             right.
             right.
             unfold simp_lv_event_lt.
             rewrite decide_True by intuition.
             unfold state_lt'.

             assert (get_history (update_state (s i) so j) i = get_history (s i) i). {
              apply (@eq_history_eq_project index index_listing Hfinite).
              rewrite (@project_different index index_listing Hfinite).
              intuition.
              intuition.
              apply Hsnb; intuition.
             }

             rewrite <- H0.
             intuition.
          -- rewrite state_update_neq by intuition.
             intuition.
    - apply in_cobs_messages in Hine1 as Het1.
      simpl in Het1. subst et1. simpl in Hine1.

      destruct Hine2 as [Hine2|Hine2].
      + apply in_cobs_states in Hine2 as Het2.
        simpl in Het2. subst et2.
        apply unique_state_observation in Hine2. simpl in Hine2.
        inversion Hine2. subst es2.

        exists (SimpObs State' v (s' v)). simpl.
        split;[apply in_cobs_states';apply state_obs_present|].
        apply in_listing.
        split;[intuition|].
        exists e1. subst e1. simpl in *.
        split.
        * apply in_cobs_messages'.
          unfold s'.
          setoid_rewrite <- cobs_message_existing_other.
          all :intuition.
        * split;[intuition|].
          unfold s'.
          destruct (decide (i = v)).
          -- subst v.
             rewrite state_update_eq.
             intros contra.
             unfold comparable in contra.
             destruct contra as [contra|contra];[congruence|].
             unfold simp_lv_event_lt in contra.
             rewrite decide_True in contra by intuition.
             destruct contra as [contra|contra];[intuition|].
             rewrite decide_True in contra by intuition.
             unfold state_lt' in contra.

             contradict Hcomp.
             unfold comparable.
             right.
             left.
             unfold simp_lv_event_lt.
             rewrite decide_True by intuition.
             unfold state_lt'.

             assert (get_history (update_state (s i) so j) i = get_history (s i) i). {
              apply (@eq_history_eq_project index index_listing Hfinite).
              rewrite (@project_different index index_listing Hfinite).
              intuition.
              intuition.
              apply Hsnb; intuition.
             }

             rewrite <- H0.
             intuition.
          -- rewrite state_update_neq by intuition.
             intros contra.
             apply comparable_commutative in contra.
             intuition.
      + apply in_cobs_messages in Hine2 as Het2.
        simpl in Het2. subst et2. simpl in Hine2.

        exists e1. subst e1. simpl in *.
        split.
        * apply in_cobs_messages'.
          unfold s'.
          setoid_rewrite <- cobs_message_existing_other.
          all :intuition.
        * split;[intuition|].
          exists e2. subst e2. simpl in *.
          split.
          -- apply in_cobs_messages'.
             unfold s'.
             setoid_rewrite <- cobs_message_existing_other.
             all : intuition.
          -- split;[intuition|].
             intuition.
  Qed.

  Lemma receive_plan_preserves_equivocation
    (s : vstate X)
    (Hpr : protocol_state_prop X s)
    (a : plan X)
    (Hpr_a : finite_protocol_plan_from X s a)
    (Hgood : forall (ai : vplan_item X), In ai a ->
      (projT2 (label_a ai)) = receive /\
      exists (so : state) (from : index),
      input_a ai = Some (from, so) /\
      In (SimpObs Message' from so) (cobs_messages s from)) :
    let res := snd (apply_plan X s a) in
    set_eq (GE s) (GE res).
  Proof.
    simpl.
    induction a using rev_ind.
    - simpl in *. intuition.
    - assert (Hpr_a' := Hpr_a).
      apply finite_protocol_plan_from_app_iff in Hpr_a.
      spec IHa. intuition.

      rewrite apply_plan_app.
      destruct (apply_plan X s a) as (tr_long, res_long) eqn : eq_long.
      destruct (apply_plan X res_long [x]) as (tr_short, res_short) eqn : eq_short.

      assert (res_long = snd (apply_plan X s a)) by (rewrite eq_long; intuition).
      assert (res_short = snd (apply_plan X res_long [x])) by (rewrite eq_short; intuition).

      simpl.
      apply set_eq_tran with (s2 := GE res_long).
      + spec IHa. {
          intros ai Hai.
          specialize (Hgood ai).
          spec Hgood. apply in_app_iff. left. intuition.
          intuition.
        }
        simpl in IHa.
        intuition.
      + rewrite H0.
        unfold apply_plan, _apply_plan. simpl.

        specialize (Hgood x).
        spec Hgood. {
          apply in_app_iff. right. intuition.
        }

        destruct x. simpl in *.

        destruct (vtransition X label_a (res_long, input_a)) eqn : eq_trans.
        unfold vtransition in eq_trans.
        unfold transition in eq_trans.
        simpl in eq_trans.
        unfold vtransition in eq_trans.
        unfold transition in eq_trans.
        simpl in eq_trans.
        destruct label_a. simpl in *.
        destruct Hgood as [Hv Hgood].
        destruct Hpr_a as [Hpr_a2 Hpr_a].
        apply finite_protocol_plan_from_one in Hpr_a. simpl in Hpr_a.
        move Hpr_a at bottom.
        destruct Hpr_a as [Hpr_a _].
        unfold protocol_valid in Hpr_a.
        unfold valid in Hpr_a.
        simpl in Hpr_a.
        unfold constrained_composite_valid in Hpr_a.
        unfold composite_valid in Hpr_a.
        unfold vvalid in Hpr_a.
        unfold valid in Hpr_a. simpl in Hpr_a.
        subst v.
        destruct input_a eqn : eq_input
        ; [| intuition].
        destruct Hgood as [so [from [Heqm Hinso]]].
        inversion Heqm.
        subst m. simpl in *.
        unfold set_eq.
        inversion eq_trans. clear H3.
        assert (In (SimpObs Message' from so) (cobs res_long from)). {
          specialize (@in_future_message_obs index_listing s res_long from) as Hf.
          spec Hf. {
            unfold in_futures.
            exists (fst (apply_plan X s a)).
            apply ptrace_add_last.
            - assert (finite_protocol_plan_from X s a). {
                intuition.
              }
              unfold finite_protocol_plan_from in H1.
              intuition.
            - rewrite H.
              apply apply_plan_last.
          }
          specialize (Hf (SimpObs Message' from so)).
          apply in_cobs_messages'.
          apply Hf.
          intuition.
        }
        split.
        * apply GE_existing_different_rev.
          all : intuition.
        * apply GE_existing_different.
          all : intuition.
  Qed.

End Composition.


(**
    VerifiedDSP
    Copyright (C) {2015}  {Jeremy L Rubin}

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 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 General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

**)
(* Copyright (c) 2011. Greg Morrisett, Gang Tan, Joseph Tassarotti,
   Jean-Baptiste Tristan, and Edward Gan.

   This file is part of RockSalt.

   This file is free software; you can redistribute it and/or
   modify it under the terms of the GNU General Public License as
   published by the Free Software Foundation; either version 2 of
   the License, or (at your option) any later version.
*)

Require Import List.
Require Import Bits.
Require Import ZArith.
Require Import Parser.
Require Import String.
Require Import Monad.
Require Import Maps.
Require Import i8051Syntax.
Require Import Eqdep.
Set Implicit Arguments.
Unset Automatic Introduction.

Definition size1 := 0.
Definition size4 := 3.
Definition size8 := 7.
Definition size16 := 15.
Definition size32 := 31.
Definition int n := Word.int n.

Module Type MACHINE_SIG.
  (** We abstract over locations which include things like registers, flags, the pc,
      segment registers, etc.  Our only assumption is that updates to distinct locations
      commute. *)
  Variable location : nat -> Set.  (* registers, flags, etc. *)

  (** We also abstract over the size of memory, by parameterizing the RTLs over the
      number of bits in addresses. *)
  Variable size_addr : nat.  (* number of bits in a memory adress minus one *)
  Variable size_pc : nat.
  (** We assume some type for the machine state *)
  Variable mach_state : Type.
  (** And operations for reading/writing locations *)
  Variable get_location : forall s, location s -> mach_state -> Word.int s.
  Variable set_location : forall s, location s -> Word.int s -> mach_state -> mach_state.
End MACHINE_SIG.

(** Generic register-transfer language *)
Module RTL(M : MACHINE_SIG).
  Import M.
  Local Open Scope Z_scope.
  Module AddrIndexed.
    Definition t := int size_addr.
    Definition index(i:int size_addr) : positive := ZIndexed.index (Word.unsigned i).
    Lemma index_inj : forall (x y : int size_addr), index x = index y -> x = y.
    Proof.
      unfold index. destruct x; destruct y ; simpl ; intros.
      generalize intrange intrange0. clear intrange intrange0.
      rewrite (ZIndexed.index_inj intval intval0 H). intros.
      rewrite (Coqlib.proof_irrelevance _ intrange intrange0). auto.
    Qed.
    Definition eq := @Word.eq_dec size_addr.
  End AddrIndexed.

  Module CodeIndexed.
    Definition t := int size_pc.
    Definition index(i:int size_pc) : positive := ZIndexed.index (Word.unsigned i).
    Lemma index_inj : forall (x y : int size_pc), index x = index y -> x = y.
    Proof.
      unfold index. destruct x; destruct y ; simpl ; intros.
      generalize intrange intrange0. clear intrange intrange0.
      rewrite (ZIndexed.index_inj intval intval0 H). intros.
      rewrite (Coqlib.proof_irrelevance _ intrange intrange0). auto.
    Qed.
    Definition eq := @Word.eq_dec size_pc.
  End CodeIndexed.
  Module AddrMap := IMap(AddrIndexed).
  Module CodeMap := IMap(CodeIndexed).

  (** RTL instructions form a RISC-like core language that operate over pseudo-registers.
      We assume that we're working under an environment that holds an infinite number of
      pseudo registers for each bit-vector size of interest.  The instructions include
      arithmetic operations over bitvectors, test instructions, a primitive conditional
      instruction, signed and unsigned conversions of bitvectors from one size to another,
      the ability to read/write locations in the machine state, the ability to read/write
      locations in memory, the ability to non-deterministically choose a bit-vector,
      and an error. *)
  Inductive bit_vector_op : Set :=
    add_op | sub_op | mul_op | divs_op | divu_op | modu_op | mods_op
  | and_op | or_op | xor_op | shl_op | shr_op | shru_op | ror_op | rol_op.

  Inductive test_op : Set := eq_op | lt_op | ltu_op.

  Inductive pseudo_reg (s:nat) : Set :=
  | ps_reg : Z -> pseudo_reg s.

  Inductive rtl_instr : Type :=
  | arith_rtl : forall s (b:bit_vector_op)(r1 r2:pseudo_reg s)(rd:pseudo_reg s), rtl_instr
  | test_rtl : forall s (top:test_op)(r1 r2:pseudo_reg s)(rd:pseudo_reg size1), rtl_instr
  | if_rtl : pseudo_reg size1 -> rtl_instr -> rtl_instr
  | cast_s_rtl : forall s1 s2 (r1:pseudo_reg s1) (rd:pseudo_reg s2),  rtl_instr
  | cast_u_rtl : forall s1 s2 (r1:pseudo_reg s1) (rd:pseudo_reg s2),  rtl_instr
  | load_imm_rtl : forall s (i:int s) (rd:pseudo_reg s),  rtl_instr
  | set_loc_rtl : forall s (rs:pseudo_reg s) (l:location s), rtl_instr
  | get_loc_rtl : forall s (l:location s) (rd:pseudo_reg s), rtl_instr
  | set_byte_rtl: forall (rs:pseudo_reg size8)(addr:pseudo_reg size_addr), rtl_instr
  | get_byte_rtl: forall (addr:pseudo_reg size_addr)(rd:pseudo_reg size8), rtl_instr
  | choose_rtl : forall s (rd:pseudo_reg s), rtl_instr
  | error_rtl : rtl_instr
  | safe_fail_rtl : rtl_instr.

  (** Next, we give meaning to RTL instructions as transformers over an
      environment for pseudo-registers and a machine state. *)
  Definition pseudo_env := forall s, pseudo_reg s -> int s.
  Definition empty_env : pseudo_env := fun s _ => Word.zero.
  Definition eq_pseudo_reg s : forall (r1 r2:pseudo_reg s), {r1 = r2} + {r1 <> r2}.
    intros. destruct r1. destruct r2. destruct (Z_eq_dec z z0). subst. left. auto.
    right. intro. apply n. congruence.
  Defined.
  Definition update_env s (r:pseudo_reg s) (v:int s) (env:pseudo_env) : pseudo_env.
    intros s r v env s' r'.
    destruct (eq_nat_dec s s'). subst. destruct (eq_pseudo_reg r r'). subst. apply v.
    apply (env s' r').
    apply (env s' r').
  Defined.

  Record oracle := {
    oracle_bits : forall s, Z -> int s ;
    oracle_offset : Z
  }.

  Record rtl_state := {
    rtl_oracle : oracle ;
    rtl_env : pseudo_env ;
    rtl_mach_state : mach_state ;
    rtl_memory : AddrMap.t int8;
    rtl_code : CodeMap.t int8
  }.

  Inductive RTL_ans(A:Type) : Type :=
  | Fail_ans : RTL_ans A
  | SafeFail_ans : RTL_ans A
  | Okay_ans : A -> RTL_ans A.

  Definition RTL(T:Type) := rtl_state -> (RTL_ans T * rtl_state).

  Instance RTL_monad : Monad RTL := {
    Return := fun A (x:A) (rs:rtl_state) => (Okay_ans x, rs) ;
    Bind := fun A B (c:RTL A) (f:A -> RTL B) (rs:rtl_state) =>
      match c rs with
        | (Okay_ans v, rs') => f v rs'
        | (Fail_ans, rs') => (Fail_ans _, rs')
        | (SafeFail_ans, rs') => (SafeFail_ans _, rs')
      end
  }.
  intros ; apply Coqlib.extensionality. auto.
  intros ; apply Coqlib.extensionality. intros. destruct (c x) ; auto. destruct r ; auto.
  intros ; apply Coqlib.extensionality. intros. destruct (f x) ; auto.
    destruct r ; auto.
  Defined.

  Definition Fail T : RTL T := fun rs => (Fail_ans T,rs).
  Definition SafeFail T : RTL T := fun rs => (SafeFail_ans T,rs).

  Definition flush_env : RTL unit :=
    fun rs => (Okay_ans tt, {| rtl_oracle := rtl_oracle rs ;
                           rtl_env := empty_env;
                           rtl_mach_state := rtl_mach_state rs ;
                           rtl_code := rtl_code rs ;
                           rtl_memory := rtl_memory rs |}).
  Definition set_ps s (r:pseudo_reg s) (v:int s) : RTL unit :=
    fun rs => (Okay_ans tt, {| rtl_oracle := rtl_oracle rs ;
                           rtl_env := update_env r v (rtl_env rs) ;
                           rtl_mach_state := rtl_mach_state rs ;
                           rtl_code := rtl_code rs ;
                           rtl_memory := rtl_memory rs |}).
  Definition set_loc s (l:location s) (v:int s) : RTL unit :=
    fun rs => (Okay_ans tt, {| rtl_oracle := rtl_oracle rs ;
                           rtl_env := rtl_env rs ;
                           rtl_mach_state := set_location l v (rtl_mach_state rs) ;
                           rtl_code := rtl_code rs ;
                           rtl_memory := rtl_memory rs |}).

  Definition set_byte (addr:int size_addr) (v:int size8) : RTL unit :=
    fun rs => (Okay_ans tt, {| rtl_oracle := rtl_oracle rs ;
                           rtl_env := rtl_env rs ;
                           rtl_mach_state := rtl_mach_state rs ;
                           rtl_code := rtl_code rs ;
                           rtl_memory := AddrMap.set addr v (rtl_memory rs) |}).

  Definition set_code_byte (addr:int size_pc) (v:int size8) : RTL unit :=
    fun rs => (Okay_ans tt, {| rtl_oracle := rtl_oracle rs ;
                           rtl_env := rtl_env rs ;
                           rtl_mach_state := rtl_mach_state rs ;
                           rtl_code := CodeMap.set addr v (rtl_code rs) ;
                           rtl_memory := rtl_memory rs |}).
  Definition get_ps s (r:pseudo_reg s) : RTL (int s) :=
    fun rs => (Okay_ans (rtl_env rs r), rs).
  Definition get_loc s (l:location s) : RTL (int s) :=
    fun rs => (Okay_ans (get_location l (rtl_mach_state rs)), rs).
  Definition get_byte (addr:int size_addr) : RTL (int size8) :=
    fun rs => (Okay_ans (AddrMap.get addr (rtl_memory rs)), rs).

  Definition get_code_byte (addr:int size_pc) : RTL (int size8) :=
    fun rs => (Okay_ans (CodeMap.get addr (rtl_code rs)), rs).
  Definition choose_bits (s:nat) : RTL (int s) :=
    fun rs =>
      let o := rtl_oracle rs in
      let o' := {| oracle_bits := oracle_bits o; oracle_offset := oracle_offset o + 1 |} in
        (Okay_ans (oracle_bits o s (oracle_offset o)),
          {| rtl_oracle := o' ;
             rtl_env := rtl_env rs ;
             rtl_mach_state := rtl_mach_state rs ;
             rtl_code := rtl_code rs ;
             rtl_memory := rtl_memory rs |}).

  Definition interp_arith s (b:bit_vector_op)(v1 v2:int s) : int s :=
    match b with
      | add_op => Word.add v1 v2
      | sub_op => Word.sub v1 v2
      | mul_op => Word.mul v1 v2
      | divs_op => Word.divs v1 v2
      | divu_op => Word.divu v1 v2
      | modu_op => Word.modu v1 v2
      | mods_op => Word.mods v1 v2
      | and_op => Word.and v1 v2
      | or_op => Word.or v1 v2
      | xor_op => Word.xor v1 v2
      | shl_op => Word.shl v1 v2
      | shr_op => Word.shr v1 v2
      | shru_op => Word.shru v1 v2
      | ror_op => Word.ror v1 v2
      | rol_op => Word.rol v1 v2
    end.

  Definition interp_test s (t:test_op)(v1 v2:int s) : int size1 :=
    if (match t with
      | eq_op => Word.eq v1 v2
      | lt_op => Word.lt v1 v2
      | ltu_op => Word.ltu v1 v2
        end) then Word.one else Word.zero.

  Local Open Scope monad_scope.

  Fixpoint interp_rtl (instr:rtl_instr) : RTL unit :=
    match instr with
      | arith_rtl s b r1 r2 rd =>
        v1 <- get_ps r1 ; v2 <- get_ps r2 ; set_ps rd (interp_arith b v1 v2)
      | test_rtl s t r1 r2 rd =>
        v1 <- get_ps r1 ; v2 <- get_ps r2 ; set_ps rd (interp_test t v1 v2)
      | if_rtl r i =>
        v <- get_ps r ; if (Word.eq v Word.one) then interp_rtl i else ret tt
      | cast_s_rtl s1 s2 rs rd =>
        v <- get_ps rs ;
        set_ps rd (Word.repr (Word.signed v))
      | cast_u_rtl s1 s2 rs rd =>
        v <- get_ps rs ;
        set_ps rd (Word.repr (Word.unsigned v))
      | load_imm_rtl s i rd => set_ps rd i
      | set_loc_rtl s rs l => v <- get_ps rs ; set_loc l v
      | get_loc_rtl s l rd => v <- get_loc l ; set_ps rd v
      | set_byte_rtl rs addr => v <- get_ps rs ; a <- get_ps addr ; set_byte a v
      | get_byte_rtl addr rd => a <- get_ps addr ; v <- get_byte a ; set_ps rd v
      | choose_rtl s rd => v <- choose_bits s ; set_ps rd v
      | error_rtl => Fail unit
      | safe_fail_rtl => SafeFail unit
    end.

  (** We collect all of the information for an instruction into a record
      satisfying this interface. *)
  Record instruction := {
    instr_assembly : string ;  (* for printing/debugging *)
    instr_rtl : list rtl_instr (* semantics as RTL instructions *)
  }.
End RTL.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import VST.progs.list_dt.  Import LsegSpecial.
Require Import VST.progs.queue2.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition t_struct_elem := Tstruct _elem noattr.
Definition t_struct_fifo := Tstruct _fifo noattr.

Instance QS: listspec _elem _next (fun sh => malloc_token Ews t_struct_elem).
Proof. eapply mk_listspec; reflexivity. Defined.

Lemma isnil: forall {T: Type} (s: list T), {s=nil}+{s<>nil}.
Proof. intros. destruct s; [left|right]; auto. intro Hx; inv Hx. Qed.

Lemma field_at_list_cell:
  forall sh i v p,
  data_at sh t_struct_elem (i,v) p
  = list_cell QS sh i p *
  field_at sh t_struct_elem [StructField _next] v p.
Proof.
intros.
unfold_data_at (data_at _ _ _ _).
f_equal.
unfold field_at, list_cell.
autorewrite with gather_prop.
f_equal.
apply ND_prop_ext.
rewrite field_compatible_cons; simpl.
intuition.
left; auto.
Qed.

Definition surely_malloc_spec :=
  DECLARE _surely_malloc
   WITH t:type, gv: globals
   PRE [ _n OF tuint ]
       PROP (0 <= sizeof t <= Int.max_unsigned;
                complete_legal_cosu_type t = true;
                natural_aligned natural_alignment t = true)
       LOCAL (temp _n (Vint (Int.repr (sizeof t))); gvars gv)
       SEP (mem_mgr gv)
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p).

Definition fifo_body (contents: list val) (hd tl : val) :=
     (if isnil contents
      then (!!(hd=nullval) && emp)
      else (EX prefix: list val, EX last: val,
              !!(contents = prefix++last::nil)
            &&  (lseg QS Ews prefix hd tl
                   * malloc_token Ews t_struct_elem tl
                   * data_at Ews t_struct_elem (last, nullval) tl)))%logic.

Definition fifo (contents: list val) (p: val) : mpred :=
  EX ht: (val*val), let (hd,tl) := ht in
      !! is_pointer_or_null hd && !! is_pointer_or_null tl &&
      data_at Ews t_struct_fifo (hd, tl) p * malloc_token Ews t_struct_fifo p *
      fifo_body contents hd tl.

Definition fifo_new_spec :=
 DECLARE _fifo_new
  WITH gv: globals
  PRE  [  ]
       PROP() LOCAL(gvars gv) SEP (mem_mgr gv)
  POST [ (tptr t_struct_fifo) ]
    EX v:val, PROP() LOCAL(temp ret_temp v) SEP (mem_mgr gv; fifo nil v).

Definition fifo_put_spec :=
 DECLARE _fifo_put
  WITH q: val, contents: list val, p: val, last: val
  PRE  [ _Q OF (tptr t_struct_fifo) , _p OF (tptr t_struct_elem) ]
          PROP () LOCAL (temp _Q q; temp _p p)
          SEP (fifo contents q;
                 malloc_token Ews t_struct_elem p;
                 data_at Ews t_struct_elem (last,Vundef) p)
  POST [ tvoid ]
          PROP() LOCAL() SEP (fifo (contents++(last :: nil)) q).

Definition fifo_empty_spec :=
 DECLARE _fifo_empty
  WITH q: val, contents: list val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
     PROP() LOCAL (temp _Q q) SEP(fifo contents q)
  POST [ tint ]
      PROP ()
      LOCAL(temp ret_temp (if isnil contents then Vtrue else Vfalse))
      SEP (fifo (contents) q).

Definition fifo_get_spec :=
 DECLARE _fifo_get
  WITH q: val, contents: list val, first: val
  PRE  [ _Q OF (tptr t_struct_fifo) ]
       PROP() LOCAL (temp _Q q) SEP (fifo (first :: contents) q)
  POST [ (tptr t_struct_elem) ]
      EX p:val,
       PROP ()
       LOCAL(temp ret_temp p)
       SEP (fifo contents q;
              malloc_token Ews t_struct_elem p;
              data_at Ews t_struct_elem (first,Vundef) p).

Definition make_elem_spec :=
 DECLARE _make_elem
  WITH i: int, gv: globals
  PRE  [ _data OF tint ]
        PROP() LOCAL(temp _data (Vint i); gvars gv) SEP(mem_mgr gv)
  POST [ (tptr t_struct_elem) ]
    EX p:val,
       PROP()
       LOCAL (temp ret_temp p)
       SEP (mem_mgr gv;
              malloc_token Ews t_struct_elem p;
              data_at Ews t_struct_elem (Vint i, Vundef) p).

Definition main_spec :=
 DECLARE _main
  WITH gv: globals
  PRE  [] main_pre prog nil gv
  POST [ tint ]
       PROP() LOCAL (temp ret_temp (Vint (Int.repr 1))) SEP(TT).

Definition Gprog : funspecs :=
  ltac:(with_library prog
    [surely_malloc_spec; fifo_new_spec; fifo_put_spec;
     fifo_empty_spec; fifo_get_spec; make_elem_spec;
     main_spec]).

Lemma body_surely_malloc: semax_body Vprog Gprog f_surely_malloc surely_malloc_spec.
Proof.
  start_function.
  forward_call (* p = malloc(n); *)
     (t,gv).
  Intros p.
  forward_if
  (PROP ( )
   LOCAL (temp _p p)
   SEP (mem_mgr gv; malloc_token Ews t p * data_at_ Ews t p)).
*
  if_tac.
    subst p. entailer!.
    entailer!.
*
    forward_call tt.
    contradiction.
*
    if_tac.
    + forward. subst p. congruence.
    + Intros. forward. entailer!.
*
  forward. Exists p; entailer!.
Qed.

Lemma fifo_isptr: forall al q, fifo al q |-- !! isptr q.
Proof.
intros.
 unfold fifo, fifo_body.
 if_tac; entailer; destruct ht; entailer!.
Qed.

Hint Resolve fifo_isptr : saturate_local.

Lemma body_fifo_empty: semax_body Vprog Gprog f_fifo_empty fifo_empty_spec.
Proof.
start_function.
unfold fifo.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* h = Q->head; *)
forward. (* return (h == NULL); *)
{
unfold fifo, fifo_body.
destruct (isnil contents).
+ normalize; auto with valid_pointer.
+ entailer!.
  destruct hd; inv PNhd; entailer!.
}
unfold fifo, fifo_body.
Exists (hd,tl).
destruct (isnil contents).
* entailer!.
* Intros prefix last.
Exists prefix last.
  assert_PROP (isptr hd).
    destruct prefix; entailer.
    rewrite @lseg_cons_eq by auto. Intros y.
    entailer.
 destruct hd; try contradiction.
 entailer!.
Qed.

Lemma body_fifo_new: semax_body Vprog Gprog f_fifo_new fifo_new_spec.
Proof.
  start_function.

  forward_call (* Q = surely_malloc(sizeof ( *Q)); *)
     (t_struct_fifo, gv).
    split3; simpl; auto; computable.
  Intros q.
  assert_PROP (field_compatible t_struct_fifo [] q).
   entailer!.
  forward. (* Q->head = NULL; *)
  forward. (* Q->tail = NULL; *)
  forward. (* return Q; *)
  Exists q. unfold fifo, fifo_body. Exists (nullval,nullval).
  rewrite if_true by auto.
  simpl sizeof.
  entailer!.
Qed.

Lemma body_fifo_put: semax_body Vprog Gprog f_fifo_put fifo_put_spec.
Proof.
start_function.
unfold fifo at 1.
Intros ht; destruct ht as [hd tl].
Intros.
forward. (* p->next = NULL; *)
forward. (*   h = Q->head; *)
forward_if
  (PROP() LOCAL () SEP (fifo (contents ++ last :: nil) q))%assert.
* unfold fifo_body; if_tac; entailer.  (* typechecking clause *)
      (* TODO: In the line above, entailer works but not entailer! *)
* (* then clause *)
  subst.
  forward. (* Q->head=p; *)
  forward. (* Q->tail=p; *)
  entailer.
  unfold fifo, fifo_body.
  destruct (isnil contents).
  + subst. Exists (p,p).
     simpl. rewrite if_false by congruence.
     Exists (@nil val) last.
      rewrite @lseg_nil_eq by auto.
      entailer!.
   + Intros prefix last0.
      destruct prefix;
      entailer!.
      rewrite @lseg_cons_eq by auto. simpl.
      Intros y.
      entailer!.
* (* else clause *)
  forward. (*  t = Q->tail; *)
  unfold fifo_body.
  destruct (isnil contents).
  + Intros. contradiction H; auto.
  + Intros prefix last0.
     forward. (*  t->next=p; *)
     forward. (* Q->tail=p; *)
     entailer!.
     unfold fifo, fifo_body. Exists (hd, p).
     rewrite if_false by (clear; destruct prefix; simpl; congruence).
     Exists  (prefix ++ last0 :: nil) last.
     entailer.
     rewrite (field_at_list_cell Ews last0 p).
     unfold_data_at (@data_at CompSpecs Ews t_struct_elem (last,nullval) p).
     unfold_data_at (data_at _ _ _ p).
     simpl sizeof.
     match goal with
     | |- _ |-- _ * _ * (_ * ?AA) => remember AA as A
     end.     (* prevent it from canceling! *)
     cancel. subst A.
     eapply derives_trans;
        [ | apply (lseg_cons_right_neq QS Ews prefix hd last0 tl nullval p ); auto].
     simpl sizeof.  cancel.
* (* after the if *)
     forward. (* return ; *)
Qed.

Lemma body_fifo_get: semax_body Vprog Gprog f_fifo_get fifo_get_spec.
Proof.
start_function.
unfold fifo at 1, fifo_body.
Intros ht; destruct ht as [hd tl].
rewrite if_false by congruence.
Intros prefix last.
forward.  (*   h = Q->head; *)
destruct prefix; inversion H; clear H.
+
   rewrite @lseg_nil_eq by auto.
   Intros.
   subst_any.
   forward. (*  n=h->next; *)
   forward. (* Q->head=n; *)
   forward. (* return p; *)
   unfold fifo, fifo_body. Exists tl (nullval, tl).
   rewrite if_true by congruence.
   entailer!. simpl sizeof.
   do 2 unfold_data_at (data_at _ _ _ _). cancel.
+ rewrite @lseg_cons_eq by auto.
    Intros x.
    simpl @valinject. (* can we make this automatic? *)
    subst_any.
    forward. (*  n=h->next; *)
    forward. (* Q->head=n; *)
    forward. (* return p; *)
    Exists hd. unfold fifo, fifo_body. Exists (x, tl).
    rewrite if_false by (destruct prefix; simpl; congruence).
    Exists prefix last.
    entailer!.
    rewrite field_at_list_cell. simpl sizeof. cancel.
Qed.

Lemma body_make_elem: semax_body Vprog Gprog f_make_elem make_elem_spec.
Proof.
start_function.
forward_call (*  p = surely_malloc(sizeof ( *p));  *)
    (t_struct_elem, gv).
 split3; simpl; auto; computable.
 Intros p.
forward.  (*  p->data=i; *)
simpl.
forward. (* return p; *)
Exists p.
entailer!.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
start_function.
sep_apply (create_mem_mgr gv).
forward_call (* Q = fifo_new(); *)  gv.
Intros q.

forward_call  (*  p = make_elem(1); *)
     (Int.repr 1, gv).
Intros p'.
forward_call (* fifo_put(Q,p);*)
    ((q, @nil val),p', Vint (Int.repr 1)).

forward_call  (*  p = make_elem(2); *)
     (Int.repr 2, gv).
Intros p2.
simpl app.
 forward_call  (* fifo_put(Q,p); *)
    (((q,[Vint (Int.repr 1)]),p2), Vint (Int.repr 2)).
simpl app.
forward_call  (*   p' = fifo_get(Q); p = p'; *)
    ((q,[Vint (Int.repr 2)]), Vint (Int.repr 1)).
Intros p3.
forward. (*   i = p->data;  *)
forward_call (*  free(p); *)
   (t_struct_elem, p3, gv).
assert_PROP (isptr p3); [entailer! | rewrite if_false by (intro; subst; contradiction) ]; cancel.
forward. (* return i; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_malloc. apply semax_func_cons_malloc_aux.
semax_func_cons body_free.
semax_func_cons body_exit.
semax_func_cons body_surely_malloc.
semax_func_cons body_fifo_new.
semax_func_cons body_fifo_put.
semax_func_cons body_fifo_empty.
semax_func_cons body_fifo_get.
semax_func_cons body_make_elem.
semax_func_cons body_main.
Qed.