Require Import compcert.lib.Coqlib.
Require Export compcert.lib.Maps.
Require Import compcert.common.Errors.
Require Import liblayers.lib.Decision.
Require Import liblayers.lib.OptionMonad.
Require Import liblayers.logic.Structures.
Require Import liblayers.logic.OptionOrders.
Require Import liblayers.logic.PseudoJoin.
Require Import liblayers.logic.LayerData.

(** * Generic operations on [PTree]s *)

Definition ptree_rel {A B} (R: rel (option A) (option B)): rel _ _ :=
  fun t1 t2 => forall i, R (t1!i) (t2!i).

Global Instance ptree_subrel A B:
  Proper (subrel ++> subrel) (@ptree_rel A B).
Proof.
  firstorder.
Qed.

Global Instance ptree_subrel_params:
  Params (@ptree_rel) 3.

Global Instance ptree_get_rel:
  Monotonic
    (@PTree.get)
    (forallr R : fun A B => rel (option A) (option B), - ==> ptree_rel R ++> R).
Proof.
  intros A B R i t1 t2 H.
  apply H.
Qed.

(** Structures on [option A] can be extended to [PTree.t A] *)

Local Instance ptree_emptyset A : Emptyset (PTree.t A) :=
  { emptyset := PTree.empty A }.

Local Instance ptree_mapsto A : Mapsto positive A (PTree.t A) :=
  { mapsto i a := PTree.set i a (PTree.empty A) }.

Local Instance ptree_le_op {A} `(Ale: Le (option A)): Le (PTree.t A) :=
  { le := ptree_rel (≤) }.

Lemma ptree_refl A (R: relation (option A)):
  Reflexive R ->
  Reflexive (ptree_rel R).
Proof.
  intros HA.
  intros t i.
  reflexivity.
Qed.

Hint Extern 1 (Reflexive (ptree_rel _)) =>
  eapply ptree_refl : typeclass_instances.

Lemma ptree_trans A (R: relation (option A)):
  Transitive R ->
  Transitive (ptree_rel R).
Proof.
  intros HA.
  intros t1 t2 t3 H12 H23 i.
  transitivity (t2 ! i); now trivial.
Qed.

Hint Extern 1 (Transitive (ptree_rel _)) =>
  eapply ptree_trans : typeclass_instances.

Global Instance ptree_rel_htrans {A B C} RAB RBC RAC:
  HTransitive (A:=option A) (B:=option B) (C:=option C) RAB RBC RAC ->
  HTransitive (ptree_rel RAB) (ptree_rel RBC) (ptree_rel RAC).
Proof.
  intros HR x y z Hxy Hyz.
  intros i.
  ehtransitivity; eauto.
Qed.

(** To show that [RTransitive] carries through [ptree_rel] is tricky
  because we need to construct the intermediate tree. To make our job
  easier we only consider the [option_le] case. *)
Section RTRANSITIVE.
  Context `{HR: RTransitive}.

  (** We need Hilbert's epsilon. *)
  Require Import ClassicalEpsilon.
  Require Import List.

  (** Then we can construct the middle ptree by eliminating the
    existential from the [rtransitivity] of the underlying relation. *)

  Definition rtrans_midval a c (Hac: option_le RAC a c) :=
    proj1_sig (constructive_indefinite_description _ (rtransitivity a c Hac)).

  Lemma rtrans_midval_correct a c Hac:
    option_le RAB a (rtrans_midval a c Hac) /\
    option_le RBC (rtrans_midval a c Hac) c.
  Proof.
    unfold rtrans_midval.
    destruct (constructive_indefinite_description _ _) as [b Hb].
    simpl.
    assumption.
  Qed.

  Definition ptree_rtrans_midval tA tC (Ht: ptree_rel (option_le RAC) tA tC) i :=
    rtrans_midval (tA!i) (tC!i) (Ht i).

  Lemma ptree_rtrans_midval_correct tA tC Ht i:
    option_le RAB (tA!i) (ptree_rtrans_midval tA tC Ht i) /\
    option_le RBC (ptree_rtrans_midval tA tC Ht i) (tC!i).
  Proof.
    unfold ptree_rtrans_midval.
    apply rtrans_midval_correct.
  Qed.

  Definition ptree_option_set i (x: option B) t :=
    match x with
      | Some b => PTree.set i b t
      | None => PTree.remove i t
    end.

  Definition ptree_rtrans_midtree tA tC Ht :=
    fold_right (fun i => ptree_option_set i (ptree_rtrans_midval tA tC Ht i))
               (PTree.empty B)
               (map fst (PTree.elements tC)).

  Lemma ptree_rtrans_midtree_correct tA tC Ht i:
    option_le RAB (tA!i) ((ptree_rtrans_midtree tA tC Ht) ! i) /\
    option_le RBC ((ptree_rtrans_midtree tA tC Ht) ! i) (tC!i).
  Proof.
    pose proof (ptree_rtrans_midval_correct tA tC Ht i) as Hb.
    unfold ptree_rtrans_midtree.
    unfold ptree_option_set.
    assert (HCi: tC!i = None \/ (exists c, In (i, c) (PTree.elements tC))).
    {
      destruct (tC ! i) as [c|] eqn:HtC.
      * eauto using PTree.elements_correct.
      * eauto.
    }
    induction (PTree.elements tC); simpl in *.
    + destruct HCi as [HCi | [c Hc]].
      - rewrite PTree.gempty, HCi in *.
        destruct Hb as [Hab Hbc].
        inversion Hbc as [? Hmv | ]; subst.
        rewrite <- Hmv in *.
        eauto.
      - elim Hc.
    + destruct a as [j cj]; simpl in *.
      destruct (decide (i = j)).
      - subst.
        simpl in *.
        destruct (ptree_rtrans_midval tA tC Ht j) as [b|].
        rewrite PTree.gss; assumption.
        rewrite PTree.grs; assumption.
      - destruct HCi as [Hnone | [c [Hc|Hc]]]; try congruence;
        destruct (ptree_rtrans_midval tA tC Ht j) as [b|];
        rewrite ?PTree.gso, ?PTree.gro; now eauto.
  Qed.

  Global Instance ptree_rel_rtrans:
    RTransitive (ptree_rel (option_le RAB))
                (ptree_rel (option_le RBC))
                (ptree_rel (option_le RAC)).
  Proof.
    intros tA tC Ht.
    exists (ptree_rtrans_midtree tA tC Ht).
    pose proof (ptree_rtrans_midtree_correct tA tC Ht).
    split; intro i; destruct (H i); eauto.
  Qed.
End RTRANSITIVE.

Local Instance ptree_oplus A `{Aoplus: Oplus (option A)}: Oplus (PTree.t A) :=
  { oplus := PTree.combine (⊕) }.

Global Instance ptree_emptyset_lb A B (R: rel (option A) (option B)):
  LowerBound R None ->
  LowerBound (ptree_rel R) (PTree.empty A).
Proof.
  intros H t2 i.
  rewrite PTree.gempty.
  apply lower_bound.
Qed.

Lemma ptree_combine_rel:
  forall
    {A1 A2} (RA: rel (option A1) (option A2))
    {B1 B2} (RB: rel (option B1) (option B2))
    {C1 C2} (RC: rel (option C1) (option C2))
    (f: option A1 -> option B1 -> option C1)
    (g: option A2 -> option B2 -> option C2),
  f None None = None ->
  g None None = None ->
  (RA ++> RB ++> RC)%rel f g ->
  (ptree_rel RA ++> ptree_rel RB ++> ptree_rel RC)%rel (PTree.combine f) (PTree.combine g).
Proof.
  intros A1 A2 RA B1 B2 RB C1 C2 RC f g.
  intros Hf Hg Hfg x1 x2 Hx y1 y2 Hy i.
  rewrite !PTree.gcombine by assumption.
  apply Hfg; eauto.
Qed.

Lemma ptree_combine_id_left {A} R f:
  f None None = None ->
  LeftIdentity R f None ->
  LeftIdentity (ptree_rel R) (PTree.combine f) (PTree.empty A).
Proof.
  intros Hf H.
  intros y i.
  rewrite PTree.gcombine by assumption.
  rewrite PTree.gempty.
  apply id_left.
Qed.

Lemma ptree_combine_assoc {A} (R: relation (option A)) f:
  f None None = None ->
  Associative R f ->
  Associative (ptree_rel R) (PTree.combine f).
Proof.
  intros Hf H.
  intros x y z i.
  rewrite !PTree.gcombine by assumption.
  apply associativity.
Qed.

Lemma ptree_combine_comm {A} (R: relation (option A)) f:
  f None None = None ->
  Commutative R f ->
  Commutative (ptree_rel R) (PTree.combine f).
Proof.
  intros Hf H.
  intros x y i.
  rewrite !PTree.gcombine by assumption.
  apply commutativity.
Qed.

Lemma ptree_combine_left_upper_bound {A} (R: relation (option A)) f:
  f None None = None ->
  LeftUpperBound R f ->
  LeftUpperBound (ptree_rel R) (PTree.combine f).
Proof.
  intros Hf H.
  intros x y i.
  rewrite !PTree.gcombine by assumption.
  apply left_upper_bound.
Qed.

Global Instance ptree_pseudojoin A:
  forall `{Ale: Le (option A)} `{Aoplus: Oplus (option A)},
    None ⊕ None = None ->
    PseudoJoin (option A) None ->
    PseudoJoin (PTree.t A) ∅.
Proof with try (assumption || typeclasses eauto).
  intros Hnone Hop.
  split; simpl...
  * split; typeclasses eauto.
  * apply ptree_combine_rel...
    solve_monotonic.
  * apply ptree_combine_id_left...
  * apply ptree_combine_assoc...
  * apply ptree_combine_comm...
  * apply ptree_combine_left_upper_bound...
Qed.

(** Same thing, indexed by layer data *)

Section SIM.
  Context {V E T} `{Hsim: CategorySim V E (fun v => option (T v))}.

  Local Instance ptree_sim_op: Sim E (fun D => PTree.t (T D)) :=
    {
      simRR D1 D2 R := ptree_rel (simRR (Sim:=cat_sim) D1 D2 R)
    }.

  Local Instance ptree_rg_sim:
    CategorySim V E (fun D => PTree.t (T D)).
  Proof.
    (** Those will be expressed in terms of [(fun u => option (T u)) v]
      instead of [option (T v)], so we need to get them explicitely in
      the context, and reduce. *)
    Set Printing All.
    pose proof (fun v => cat_sim_preorder v) as Hle_preorder.
    pose proof (fun v1 v2 e => cat_sim_trans v1 v2 e) as Hsim_trans.
    simpl in *.
    Unset Printing All.

    split.
    * apply cat_sim_cat.
    * simpl.
      solve_monotonic.
    * simpl.
      typeclasses eauto.
    * simpl.
      intros v1 v2 v3 e12 e23 x1 x2 x3 H12 H23 i.
      specialize (H12 i).
      specialize (H23 i).
      htransitivity (x2 ! i);
      assumption.
  Qed.

  Ltac eta_option :=
    repeat
      lazymatch goal with
        | |- context [option (?T ?v)] =>
          change (option (T v)) with ((fun u => option (T u)) v)
      end.

  Local Instance ptree_sim_pseudojoin:
    forall `{Aoplus: forall v, Oplus ((fun v => option (T v)) v)},
      (forall v, None ⊕ None = @None (T v)) ->
      SimPseudoJoin _ _ _ (Toplus := Aoplus) (fun v => @None (T v)) ->
      SimPseudoJoin _ _ _ (Toplus := fun v => ptree_oplus (T v)) (fun v => PTree.empty (T v)).
  Proof with eta_option; try (typeclasses eauto || simpl; eauto).
    intros.
    split; intros...
    * red in H1; subst.
      apply ptree_emptyset_lb.
      eta_option.
      eapply @oplus_sim_lower_bound.
      + eassumption.
      + typeclasses eauto.
    * intros v1 v2 R.
      apply ptree_combine_rel...
      eta_option.
      apply oplus_sim_monotonic.
    * red in H1; subst.
      apply ptree_combine_id_left...
    * apply ptree_combine_assoc...
      eta_option.
      apply oplus_sim_assoc_le.
    * apply ptree_combine_comm...
      eta_option.
      apply oplus_sim_comm_le.
    * apply ptree_combine_left_upper_bound...
  Qed.
End SIM.

(** * Decidable properties of [PTree]s *)

(** ** Some property holds for all bindings *)

Definition ptree_forall {A} (P: positive -> A -> Prop) (t: PTree.t A) :=
  forall i a, t!i = Some a -> P i a.

Program Instance ptree_forall_decision {A} (P: positive -> A -> Prop):
  (forall i a, Decision (P i a)) ->
  (forall t, Decision (ptree_forall P t)) :=
  fun HP t =>
    match (decide (Forall (fun b => P (fst b) (snd b)) (PTree.elements t))) with
      | left HPt => left _
      | right HPt => right _
    end.

Next Obligation.
  clear Heq_anonymous.
  intros i a Hia.
  apply PTree.elements_correct in Hia.
  rewrite Forall_forall in HPt.
  specialize (HPt (i, a)); simpl in *.
  tauto.
Qed.

Next Obligation.
  clear Heq_anonymous.
  intros H.
  apply HPt; clear HPt.
  rewrite Forall_forall.
  intros [i a] Hia; simpl.
  apply H.
  apply PTree.elements_complete.
  assumption.
Qed.

(** ** Two [PTree]s have disjoint domains *)

Definition ptree_disjoint {A B} (ta: PTree.t A) (tb: PTree.t B) :=
  ptree_forall (fun i _ => tb ! i = None) ta.

Lemma ptree_disjoint_sym {A B} (ta: PTree.t A) (tb: PTree.t B):
  ptree_disjoint ta tb ->
  ptree_disjoint tb ta.
Proof.
  unfold ptree_disjoint, ptree_forall. intros.
  destruct (ta ! i) eqn:?; try reflexivity.
  exploit H; eauto. congruence.
Qed.

Lemma ptree_disjoint_combine {A B}
      (ta: PTree.t A) (tb1 tb2: PTree.t B)
      (f: option B -> option B -> option B)
:
  f None None = None ->
  ptree_disjoint ta tb1 ->
  ptree_disjoint ta tb2 ->
  ptree_disjoint ta (PTree.combine f tb1 tb2).
Proof.
  unfold ptree_disjoint.
  unfold ptree_forall.
  intros H H0 H1 i a H2.
  rewrite PTree.gcombine by assumption.
  erewrite H0 by eassumption.
  erewrite H1 by eassumption.
  assumption.
Qed.

(** * Applying a partial function to all data of a tree. *)

(** For now, I disable. I suspect we can redo this in a more
  straightforward way, closer to where it's actually used. Will need
  to see when we update CompCertiKOS. *)

(** If it fails on one element, then it fails on the whole tree.  If
    it succeeds on all elements, then it succeeds on the whole tree.
*)

Module PTree.
Export Maps.PTree.

(*
    Fixpoint xmap_error {A B : Type} (f : positive -> A -> res B) (m : t A) (i : positive)
             {struct m} : res (t B) :=
      match m with
      | Leaf => OK Leaf
      | Node l o r =>
        match xmap_error f l (append i (xO xH)) with
            | Error msg => Error msg
            | OK l' =>
              match xmap_error f r (append i (xI xH)) with
                | Error msg => Error msg
                | OK r' =>
                  match o with
                    | None => OK (Node l' None r')
                    | Some a =>
                      match f i a with
                        | Error msg => Error msg
                        | OK b => OK (Node l' (Some b) r')
                      end
                  end
              end
        end
      end.

  Definition map_error {A B : Type} (f : positive -> A -> res B) m := xmap_error f m xH.

    Lemma xgmap_error_ok:
      forall (A B: Type) (f: positive -> A -> res B) (i j : positive) (m: t A),
        forall (m': t B),
          xmap_error f m j = OK m' ->
          match get i m with
            | None => get i m' = None
            | Some a => exists b, f (append j i) a = OK b /\ get i m' = Some b
          end.
    Proof.
      induction i; intros until m'; destruct m; simpl; auto.
      + inversion 1; subst; reflexivity.
      + destruct (xmap_error f m1 (append j 2)) eqn:?; try discriminate.
        destruct (xmap_error f m2 (append j 3)) eqn:?; try discriminate.
        destruct o.
        - destruct (f j a) eqn:?; try discriminate.
          inversion 1; subst.
          rewrite (append_assoc_1 j i). eapply IHi; eauto.
        - inversion 1; subst.
          rewrite (append_assoc_1 j i). eapply IHi; eauto.
      + inversion 1; subst; reflexivity.
      + destruct (xmap_error f m1 (append j 2)) eqn:?; try discriminate.
        destruct (xmap_error f m2 (append j 3)) eqn:?; try discriminate.
        destruct o.
        - destruct (f j a) eqn:?; try discriminate.
          inversion 1; subst.
          rewrite (append_assoc_0 j i). eapply IHi; eauto.
        - inversion 1; subst.
          rewrite (append_assoc_0 j i). eapply IHi; eauto.
      + inversion 1; subst; reflexivity.
      + destruct (xmap_error f m1 (append j 2)) eqn:?; try discriminate.
        destruct (xmap_error f m2 (append j 3)) eqn:?; try discriminate.
        destruct o.
        - destruct (f j a) eqn:?; try discriminate.
          inversion 1; subst.
          rewrite (append_neutral_r j). eauto.
        - inversion 1; subst.
          reflexivity.
    Qed.

    Theorem gmap_error_ok:
      forall (A B: Type) (f: positive -> A -> res B) (i: positive) (m: t A),
        forall (m': t B),
          map_error f m = OK m' ->
          match get i m with
            | None => get i m' = None
            | Some a => exists b, f i a = OK b /\ get i m' = Some b
          end.
    Proof.
      unfold map_error.
      intros.
      replace (f i) with (f (append xH i)).
      apply xgmap_error_ok; auto.
      rewrite append_neutral_l; auto.
    Qed.

    Lemma xgmap_error_error:
      forall (A B: Type) (f: positive -> A -> res B) (m: t A) (j : positive),
        forall msg,
          xmap_error f m j = Error msg ->
          exists k, exists a, exists msg',
            get k m = Some a /\
            f (append j k) a = Error msg'.
    Proof.
      induction m; simpl; try discriminate.
      intros.
      destruct (xmap_error f m1 (append j 2)) eqn:?.
      destruct (xmap_error f m2 (append j 3)) eqn:?.
      destruct o; try discriminate.
      destruct (f j a) eqn:?; try discriminate.
      + exists xH; simpl. rewrite append_neutral_r. eauto.
      + exploit IHm2; eauto.
        destruct 1 as [? [? [? [? ?]]]].
        exists (xI x); simpl. rewrite append_assoc_1. eauto.
      + exploit IHm1; eauto.
        destruct 1 as [? [? [? [? ?]]]].
        exists (xO x); simpl. rewrite append_assoc_0. eauto.
    Qed.

    Theorem gmap_error_error:
      forall (A B: Type) (f: positive -> A -> res B) (i: positive) (m: t A),
        forall msg,
          map_error f m = Error msg ->
          exists k, exists a, exists msg',
          get k m = Some a /\
          f k a = Error msg'.
    Proof.
      unfold map_error.
      intros.
      exploit xgmap_error_error; eauto.
    Qed.

    Lemma xmap_compose_ok:
      forall (A B C: Type) (fab: positive -> A -> res B) (fbc: positive -> B -> res C) (fac: positive -> A -> res C) (ma: t A) (j: positive),
        forall (mb: t B) (mc: t C),
          xmap_error fab ma j = OK mb ->
          xmap_error fbc mb j = OK mc ->
          (forall i a, get i ma = Some a ->
                       forall b, fab (append j i) a = OK b ->
                                 forall c,
                                 fbc (append j i) b = OK c ->
                                 fac (append j i) a = OK c) ->
          xmap_error fac ma j = OK mc.
    Proof.
      induction ma; simpl; intros.
      * inv H. inv H0. reflexivity.
      * destruct (xmap_error fab ma1 (append j 2)) eqn:?; try discriminate.
        destruct (xmap_error fab ma2 (append j 3)) eqn:?; try discriminate.
        destruct o.
        + destruct (fab j a) eqn:?; try discriminate.
          inv H.
          simpl in H0.
          destruct (xmap_error fbc t0 (append j 2)) eqn:?; try discriminate.
          destruct (xmap_error fbc t1 (append j 3)) eqn:?; try discriminate.
          destruct (fbc j b) eqn:?; try discriminate.
          inv H0.
          generalize (H1 xH _ (refl_equal _) b).
          rewrite append_neutral_r.
          intro.
          erewrite H; eauto.
          erewrite IHma1.
          erewrite IHma2.
          reflexivity.
          eassumption.
          assumption.
          intros until 1. intro.
          rewrite <- append_assoc_1.
          eauto.
          eassumption.
          assumption.
          intros until 1. intro.
          rewrite <- append_assoc_0.
          eauto.
        + inv H.
          simpl in H0.
          destruct (xmap_error fbc t0 (append j 2)) eqn:?; try discriminate.
          destruct (xmap_error fbc t1 (append j 3)) eqn:?; try discriminate.
          inv H0.
          erewrite IHma1.
          erewrite IHma2.
          reflexivity.
          eassumption.
          assumption.
          intros until 1. intro.
          rewrite <- append_assoc_1.
          eauto.
          eassumption.
          assumption.
          intros until 1. intro.
          rewrite <- append_assoc_0.
          eauto.
    Qed.

    Lemma map_compose_ok:
      forall (A B C: Type) (fab: positive -> A -> res B) (fbc: positive -> B -> res C) (fac: positive -> A -> res C) (ma: t A),
        forall (mb: t B) (mc: t C),
          map_error fab ma = OK mb ->
          map_error fbc mb = OK mc ->
          (forall i a, get i ma = Some a ->
                       forall b, fab i a = OK b ->
                                 forall c,
                                 fbc i b = OK c ->
                                 fac i a = OK c) ->
          map_error fac ma = OK mc.
    Proof.
      intros.
      eapply xmap_compose_ok; eauto.
    Qed.
 *)

Fixpoint xmap_option {A B : Type} (f : positive -> A -> option B) (m : t A) (i : positive) {struct m} :
  t B :=
  match m with
  | Leaf => Leaf
  | Node l o r =>
    Node (xmap_option f l (i~0)%positive) match o with
                                                | Some x => (f (prev i) x)
                                                | None => None
                                                end (xmap_option  f r (i~1)%positive)
  end.

Definition map_option {A B: Type} (f: positive -> A -> option B) (m: t A): t B :=
  xmap_option f m 1.

Lemma xgmap_option_some:
  forall (A B: Type) (f: positive -> A -> option B) (i j : positive) (m: t A),
  forall a,
    get i m = Some a ->
    get i (xmap_option f m j) = f (prev (prev_append i j)) a.
Proof.
  induction i; destruct m; simpl; intros; try discriminate.
  + apply IHi. auto.
  + apply IHi; auto.
  + subst. auto.
Qed.

Theorem gmap_option_some:
  forall (A B: Type) (f: positive -> A -> option B) (i: positive) (m: t A),
  forall a,
    get i m = Some a ->
    get i (map_option f m) = f i a.
Proof.
  unfold map_option.
  intros.
  erewrite xgmap_option_some; eauto.
  rewrite prev_append_prev. simpl. reflexivity.
Qed.

Lemma xgmap_option_none:
  forall (A B: Type) (f: positive -> A -> option B) (i: positive) (m: t A) (j : positive),
    get i m = None ->
    get i (xmap_option f m j) = None.
Proof.
  induction i; destruct m; simpl; intros; try reflexivity; eauto.
  subst. reflexivity.
Qed.

Theorem gmap_option_none:
  forall (A B: Type) (f: positive -> A -> option B) (i: positive) (m: t A),
    get i m = None ->
    get i (map_option f m) = None.
Proof.
  unfold map_option.
  intros.
  exploit xgmap_option_none; eauto.
Qed.

Lemma gmap_option {A B} (f: positive -> A -> option B) (i: positive) m:
  (map_option f m) ! i = x <- m ! i; f i x.
Proof.
  case_eq (m ! i).
  * apply gmap_option_some.
  * apply gmap_option_none.
Qed.

End PTree.

(** A PTree is never completely full... *)

Theorem ptree_get_none_ex {A} (m: _ A):
  exists i, PTree.get i m = None.
Proof.
  induction m; simpl.
  * exists xH. reflexivity.
  * destruct IHm1 as (x & ?).
    exists (xO x); simpl.
    assumption.
Qed.

Theorem ptree_forall_decision_strong {A}
        (P: positive -> A -> Prop)
        (Q: Prop):
  (forall i a, Decision (P i a)) ->
  Decision Q ->
  (forall t, Decision (forall i,
                         match t ! i with
                           | Some a => P i a
                           | None => Q
                         end)).
Proof.
  intros DP DQ t.
  apply (decide_discr (fun i => t ! i = None) (fun i => t ! i <> None)).
  + intro. apply OptionMonad.isNone_dec.
  + revert DQ.
    apply decide_rewrite.
    split.
    - intros until i. intro Li.
      rewrite Li.
      assumption.
    - intro J.
      destruct (ptree_get_none_ex t) as (? & Hx).
      generalize (J _ Hx).
      rewrite Hx.
      tauto.
  + generalize (ptree_forall_decision _ DP t).
    apply decide_rewrite.
    unfold ptree_forall.
    split.
    - intros J i Hi.
      destruct (t ! i) eqn:Ti; try congruence.
      auto.
    - intros J i a Ha.
      generalize (J i).
      rewrite Ha.
      intro K.
      apply K; congruence.
Defined.

(** ** Monotonicity wrt. [ptree_rel] *)

Global Instance ptree_map_monotonic:
  Monotonic
    PTree.map
    (forallr RA, forallr RB,
      (- ==> RA ++> RB) ++>
      ptree_rel (option_le RA) ++>
      ptree_rel (option_le RB)).
Proof.
  intros A1 A2 RA B1 B2 RB f g Hfg t1 t2 Ht i.
  rewrite !PTree.gmap.
  solve_monotonic.
Qed.

Global Instance: Params (@PTree.map) 4.

(*
Global Instance ptree_map_option_monotonic {A B} (RA: relation A) (RB: relation B):
  Proper ((- ==> RA ++> option_le RB) ++> (ptree_rel (option_le RA) ++> ptree_rel (option_le RB)))
    PTree.map_option.
Proof.
  intros f g Hfg t1 t2 Ht i.
  specialize (Ht i).
  inversion Ht as [x2 Hx1 Hx2 | x1 x2 Hx Hx1 Hx2].
  * rewrite PTree.gmap_option_none by congruence.
    constructor.
  * symmetry in Hx1, Hx2.
    erewrite !PTree.gmap_option_some by eassumption.
    apply Hfg.
    assumption.
Qed.

Global Instance: Params (@PTree.map_option) 2.
*)

(** FIXME: those could actually be strengthened to use [option_rel] if
  we had the appropriate subrelation infrastructure. *)

Instance ptree_set_le:
  Monotonic
    (@PTree.set)
    (forallr R, - ==> R ++> ptree_rel (option_le R) ++> ptree_rel (option_le R)).
Proof.
  intros A1 A2 RA i x1 x2 Hx t1 t2 Ht j.
  destruct (decide (j = i)) as [Hij | Hij]; subst.
  * rewrite !PTree.gss.
    solve_monotonic.
  * rewrite !PTree.gso by assumption.
    solve_monotonic.
Qed.

Global Instance: Params (@PTree.set) 4.

Instance ptree_empty_le:
  Monotonic (@PTree.empty) (forallr R, ptree_rel (option_le R)).
Proof.
  intros A1 A2 RA i.
  rewrite !PTree.gempty.
  constructor.
Qed.

Global Instance: Params (@PTree.empty) 1.

Global Instance ptree_elements_rel:
  Monotonic
    (@PTree.elements)
    (forallr R, ptree_rel (option_rel R) ++> list_rel (eq * R)).
Proof.
  intros A B R t1 t2 Ht.
  cut (list_forall2 (eq * R)%rel (PTree.elements t1) (PTree.elements t2)).
  - induction 1; constructor; eauto.
  - eapply PTree.elements_canonical_order.
    + intros i.
      destruct (Ht i); inversion 1; subst; eauto.
    + intros i.
      destruct (Ht i); inversion 1; subst; eauto.
Qed.

Global Instance: Params (@PTree.elements) 2.


From HTTP2.HPACK Require Import HPACKTypes.
From HTTP2 Require Import Types.
From HTTP2.Util Require Import Parser.
From Coq Require Import Strings.String BinNat Lists.List Basics.
From ExtLib Require Import Monad MonadExc.
Import ListNotations MonadNotation.
Require Coq.Structures.OrderedTypeEx Program.Wf.
Open Scope list_scope.
Open Scope string_scope.
Open Scope N_scope.
Open Scope program_scope.
Open Scope monad_scope.

(* https://tools.ietf.org/html/rfc7541#appendix-A *)
(* https://tools.ietf.org/html/rfc7541#section-2.3.1 *)
Definition static_table : Table :=
  [ (":authority", "");
    (":method", "GET");
    (":method", "POST");
    (":path", "/");
    (":path", "/index.html");
    (":scheme", "http");
    (":scheme", "https");
    (":status", "200");
    (":status", "204");
    (":status", "206");
    (":status", "304");
    (":status", "400");
    (":status", "404");
    (":status", "500");
    ("accept-charset", "");
    ("accept-encoding", "gzip, deflate");
    ("accept-language", "");
    ("accept-ranges", "");
    ("accept", "");
    ("access-control-allow-origin", "");
    ("age", "");
    ("allow", "");
    ("authorization", "");
    ("cache-control", "");
    ("content-disposition", "");
    ("content-encoding", "");
    ("content-language", "");
    ("content-length", "");
    ("content-location", "");
    ("content-range", "");
    ("content-type", "");
    ("cookie", "");
    ("date", "");
    ("etag", "");
    ("expect", "");
    ("expires", "");
    ("from", "");
    ("host", "");
    ("if-match", "");
    ("if-modified-since", "");
    ("if-none-match", "");
    ("if-range", "");
    ("if-unmodified-since", "");
    ("last-modified", "");
    ("link", "");
    ("location", "");
    ("max-forwards", "");
    ("proxy-authenticate", "");
    ("proxy-authorization", "");
    ("range", "");
    ("referer", "");
    ("refresh", "");
    ("retry-after", "");
    ("server", "");
    ("set-cookie", "");
    ("strict-transport-security", "");
    ("transfer-encoding", "");
    ("user-agent", "");
    ("vary", "");
    ("via", "");
    ("www-authenticate", "")].

(* https://tools.ietf.org/html/rfc7541#section-2.3.3 *)
Definition index_into_tables `{Monad Err} `{MonadExc HPACKError Err} (i:N)
           (dynamic_table:DTable) : Err HeaderField :=
  if i =? 0 then raise (IndexOverrun i)
  else if i <=? N.of_nat (length static_table)
       then opt_err (IndexOverrun i)
                    (nth_error static_table (N.to_nat i))
       else opt_err (IndexOverrun i)
                    (nth_error (snd dynamic_table)
                               (N.to_nat i - (length static_table + 1))%nat).

(* https://tools.ietf.org/html/rfc7541#section-2.3.2 *)
(* https://tools.ietf.org/html/rfc7541#section-2.3.3 *)
Definition eqb_hf (s1 s2:HeaderField) : bool :=
  match s1, s2 with
  | (fs1, ss1), (fs2, ss2) => andb (if string_dec fs1 fs2 then true else false)
                                  (if string_dec ss1 ss2 then true else false)
  end.

Definition find_table (h:HeaderField) (t:Table) : option N :=
  let fix loop i l :=
      match l with
      | [] => None
      | a :: tl =>
        if eqb_hf h a then Some i else loop (N.succ i) (tl)
      end in
  loop 1 t.

(* The size of an entry is the sum of its name's length in octets (as defined in
   https://tools.ietf.org/html/rfc7541#section-5.2), its value's length in
   octets, and 32. *)
Definition size_hf (hf:HeaderField) : N :=
  N.of_nat (String.length (fst hf)) + 32.

(* https://tools.ietf.org/html/rfc7541#section-4.1 *)
Definition size_dtable (dynamic_table:DTable) : N :=
  fold_left N.add (map size_hf (snd dynamic_table)) 0.

(* https://tools.ietf.org/html/rfc7541#section-4.3 *)
(* https://tools.ietf.org/html/rfc7541#section-4.4 *)
Lemma removelast_decreasing : forall A (l:list A),
    l <> [] -> (length (removelast l) < length l)%nat.
Proof.
  intros. specialize exists_last with (l:=l); intros exists_last.
  apply exists_last in H. inversion H. inversion X. rewrite H0.
    rewrite removelast_app; try congruence. simpl. repeat rewrite app_length.
    simpl. rewrite PeanoNat.Nat.add_0_r. rewrite PeanoNat.Nat.add_1_r.
    apply PeanoNat.Nat.lt_succ_diag_r.
Qed.

Program Fixpoint dtable_entry_eviction (dynamic_table:DTable)
        {measure (length (snd dynamic_table))}: DTable :=
  match size_dtable dynamic_table <=? fst (fst dynamic_table) with
  | true => dynamic_table
  | false => dtable_entry_eviction (fst dynamic_table,
                                   removelast (snd dynamic_table))
  end.
Obligation 1.
  symmetry in Heq_anonymous; rewrite N.leb_gt in Heq_anonymous.
  destruct dynamic_table; destruct t.
  - simpl in *. compute in Heq_anonymous. destruct p; destruct n; inversion Heq_anonymous.
  - cut (snd (p, h :: t) <> []); intros; try solve [simpl; congruence].
    apply removelast_decreasing; auto.
Defined.

Definition change_dtable_size (i:N) (dynamic_table:DTable) : DTable :=
  dtable_entry_eviction (i, snd (fst dynamic_table), snd dynamic_table).

Definition cons_dtable (entry:HeaderField) (dynamic_table:DTable) : DTable :=
  (fst dynamic_table, entry :: snd dynamic_table).

Definition add_dtable_entry (dynamic_table:DTable) (entry:HeaderField)
  : DTable :=
  (* First, evict entries so that the table can add the entry (removes elements
     if table is non empty and adding element pushes table over max size), add
     entry to table, and finally evict entries if table is now too large
     (removes just entry added only when entry is larger than max table size) *)
  let evict1 := change_dtable_size (fst (fst dynamic_table) - size_hf entry)
                                   dynamic_table in
  (change_dtable_size (fst (fst dynamic_table))) (cons_dtable entry evict1).

(* Maps an ascii (+ 256) to a huffman encoded binary number *)
Definition huffman_table : list (N * list bool) :=
  [ ( 0, [true;true;true;true;true;true;true;true;true;true;false;false;false]);
      ( 1, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false;false]);
      ( 2, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;false]);
      ( 3, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;true]);
      ( 4, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;false]);
      ( 5, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;true]);
      ( 6, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      ( 7, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      ( 8, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      ( 9, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (10, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false]);
      (11, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true]);
      (12, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (13, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true]);
      (14, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (15, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (16, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (17, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false]);
      (18, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true]);
      (19, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false]);
      (20, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true]);
      (21, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false]);
      (22, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false]);
      (23, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true]);
      (24, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false]);
      (25, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true]);
      (26, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false]);
      (27, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true]);
      (28, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false]);
      (29, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true]);
      (30, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false]);
      (31, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true]);
      (32, [false;true;false;true;false;false]);
      (33, [true;true;true;true;true;true;true;false;false;false]);
      (34, [true;true;true;true;true;true;true;false;false;true]);
      (35, [true;true;true;true;true;true;true;true;true;false;true;false]);
      (36, [true;true;true;true;true;true;true;true;true;true;false;false;true]);
      (37, [false;true;false;true;false;true]);
      (38, [true;true;true;true;true;false;false;false]);
      (39, [true;true;true;true;true;true;true;true;false;true;false]);
      (40, [true;true;true;true;true;true;true;false;true;false]);
      (41, [true;true;true;true;true;true;true;false;true;true]);
      (42, [true;true;true;true;true;false;false;true]);
      (43, [true;true;true;true;true;true;true;true;false;true;true]);
      (44, [true;true;true;true;true;false;true;false]);
      (45, [false;true;false;true;true;false]);
      (46, [false;true;false;true;true;true]);
      (47, [false;true;true;false;false;false]);
      (48, [false;false;false;false;false]);
      (49, [false;false;false;false;true]);
      (50, [false;false;false;true;false]);
      (51, [false;true;true;false;false;true]);
      (52, [false;true;true;false;true;false]);
      (53, [false;true;true;false;true;true]);
      (54, [false;true;true;true;false;false]);
      (55, [false;true;true;true;false;true]);
      (56, [false;true;true;true;true;false]);
      (57, [false;true;true;true;true;true]);
      (58, [true;false;true;true;true;false;false]);
      (59, [true;true;true;true;true;false;true;true]);
      (60, [true;true;true;true;true;true;true;true;true;true;true;true;true;false;false]);
      (61, [true;false;false;false;false;false]);
      (62, [true;true;true;true;true;true;true;true;true;false;true;true]);
      (63, [true;true;true;true;true;true;true;true;false;false]);
      (64, [true;true;true;true;true;true;true;true;true;true;false;true;false]);
      (65, [true;false;false;false;false;true]);
      (66, [true;false;true;true;true;false;true]);
      (67, [true;false;true;true;true;true;false]);
      (68, [true;false;true;true;true;true;true]);
      (69, [true;true;false;false;false;false;false]);
      (70, [true;true;false;false;false;false;true]);
      (71, [true;true;false;false;false;true;false]);
      (72, [true;true;false;false;false;true;true]);
      (73, [true;true;false;false;true;false;false]);
      (74, [true;true;false;false;true;false;true]);
      (75, [true;true;false;false;true;true;false]);
      (76, [true;true;false;false;true;true;true]);
      (77, [true;true;false;true;false;false;false]);
      (78, [true;true;false;true;false;false;true]);
      (79, [true;true;false;true;false;true;false]);
      (80, [true;true;false;true;false;true;true]);
      (81, [true;true;false;true;true;false;false]);
      (82, [true;true;false;true;true;false;true]);
      (83, [true;true;false;true;true;true;false]);
      (84, [true;true;false;true;true;true;true]);
      (85, [true;true;true;false;false;false;false]);
      (86, [true;true;true;false;false;false;true]);
      (87, [true;true;true;false;false;true;false]);
      (88, [true;true;true;true;true;true;false;false]);
      (89, [true;true;true;false;false;true;true]);
      (90, [true;true;true;true;true;true;false;true]);
      (91, [true;true;true;true;true;true;true;true;true;true;false;true;true]);
      (92, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false]);
      (93, [true;true;true;true;true;true;true;true;true;true;true;false;false]);
      (94, [true;true;true;true;true;true;true;true;true;true;true;true;false;false]);
      (95, [true;false;false;false;true;false]);
      (96, [true;true;true;true;true;true;true;true;true;true;true;true;true;false;true]);
      (97, [false;false;false;true;true]);
      (98, [true;false;false;false;true;true]);
      (99, [false;false;true;false;false]);
      (100, [true;false;false;true;false;false]);
      (101, [false;false;true;false;true]);
      (102, [true;false;false;true;false;true]);
      (103, [true;false;false;true;true;false]);
      (104, [true;false;false;true;true;true]);
      (105, [false;false;true;true;false]);
      (106, [true;true;true;false;true;false;false]);
      (107, [true;true;true;false;true;false;true]);
      (108, [true;false;true;false;false;false]);
      (109, [true;false;true;false;false;true]);
      (110, [true;false;true;false;true;false]);
      (111, [false;false;true;true;true]);
      (112, [true;false;true;false;true;true]);
      (113, [true;true;true;false;true;true;false]);
      (114, [true;false;true;true;false;false]);
      (115, [false;true;false;false;false]);
      (116, [false;true;false;false;true]);
      (117, [true;false;true;true;false;true]);
      (118, [true;true;true;false;true;true;true]);
      (119, [true;true;true;true;false;false;false]);
      (120, [true;true;true;true;false;false;true]);
      (121, [true;true;true;true;false;true;false]);
      (122, [true;true;true;true;false;true;true]);
      (123, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;false]);
      (124, [true;true;true;true;true;true;true;true;true;false;false]);
      (125, [true;true;true;true;true;true;true;true;true;true;true;true;false;true]);
      (126, [true;true;true;true;true;true;true;true;true;true;true;false;true]);
      (127, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false]);
      (128, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      (129, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true;false]);
      (130, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      (131, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      (132, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true;true]);
      (133, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false;false]);
      (134, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false;true]);
      (135, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false;true]);
      (136, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true;false]);
      (137, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true;false]);
      (138, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true;true]);
      (139, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false;false]);
      (140, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false;true]);
      (141, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;false]);
      (142, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (143, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;true]);
      (144, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (145, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (146, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true;true]);
      (147, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;false]);
      (148, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false]);
      (149, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;true]);
      (150, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;false]);
      (151, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;true]);
      (152, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;false]);
      (153, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false;false]);
      (154, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false;false]);
      (155, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;true]);
      (156, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false;true]);
      (157, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      (158, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      (159, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true]);
      (160, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true;false]);
      (161, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false;true]);
      (162, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true]);
      (163, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true;true]);
      (164, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false;false]);
      (165, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      (166, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true]);
      (167, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;false]);
      (168, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (169, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false;true]);
      (170, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;false]);
      (171, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false]);
      (172, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;true]);
      (173, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;true]);
      (174, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (175, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (176, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;false]);
      (177, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;true]);
      (178, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;false]);
      (179, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;false]);
      (180, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (181, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;true]);
      (182, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false]);
      (183, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true]);
      (184, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (185, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;false]);
      (186, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;true]);
      (187, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;false]);
      (188, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false]);
      (189, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;true]);
      (190, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      (191, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true]);
      (192, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;false]);
      (193, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;true]);
      (194, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (195, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true]);
      (196, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      (197, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false]);
      (198, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      (199, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (200, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;false]);
      (201, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;true]);
      (202, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;false]);
      (203, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;false]);
      (204, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true;true]);
      (205, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;true]);
      (206, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true]);
      (207, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (208, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false]);
      (209, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;true]);
      (210, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      (211, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;false]);
      (212, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false;true]);
      (213, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      (214, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;false]);
      (215, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false]);
      (216, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;false]);
      (217, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;true]);
      (218, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      (219, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true]);
      (220, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true]);
      (221, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;true;true]);
      (222, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;false]);
      (223, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;false;true]);
      (224, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (225, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true]);
      (226, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (227, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      (228, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true]);
      (229, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      (230, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      (231, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true]);
      (232, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (233, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (234, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false]);
      (235, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true]);
      (236, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false]);
      (237, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true]);
      (238, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (239, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false]);
      (240, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (241, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;false]);
      (242, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (243, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (244, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;true;true;true]);
      (245, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;false]);
      (246, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;false;true]);
      (247, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;false]);
      (248, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;false;true;true]);
      (249, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false]);
      (250, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;false]);
      (251, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;false;true]);
      (252, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false]);
      (253, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;true]);
      (254, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;false;false;false]);
      (255, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;false;true;true;true;false]);
      (256, [true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true;true])].


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

  Velisarios 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 3 of the License, or
  (at your option) any later version.

  Velisarios 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 Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export PBFTprops2.
Require Export PBFTtactics.
Require Export PBFTwf_prepared_info.
Require Export PBFTordering.
Require Export PBFTtactics3.

Require Export List.
Require Export Peano.

Section PBFTwf_checkpoint_state.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { pbft_context : PBFTcontext      }.
  Context { pbft_auth    : PBFTauth         }.
  Context { pbft_keys    : PBFTinitial_keys }.
  Context { pbft_hash    : PBFThash         }.

  Definition wf_checkpoint_entry_same_seq_and_digest (entry : PBFTcheckpointEntry) : bool :=
    forallb
      (fun c =>
         (same_seq_nums (cp_sn entry) (checkpoint2seq c))
           && (same_digests (cp_d entry) (checkpoint2digest c)))
      (cp_checkpoint entry).

  Definition wf_checkpoint_entry_no_repeats (entry : PBFTcheckpointEntry) : bool :=
    norepeatsb rep_deq (map checkpoint2sender (cp_checkpoint entry)).

  Definition wf_checkpoint_entry (entry : PBFTcheckpointEntry) : bool :=
    (wf_checkpoint_entry_same_seq_and_digest entry)
      && (wf_checkpoint_entry_no_repeats entry).

  Definition wf_stable_checkpoint_entry_same_seq_and_digest (entry : PBFTstableCheckpointEntry) : bool :=
    forallb
      (fun c =>
         (same_seq_nums (scp_sn entry) (checkpoint2seq c))
           && (same_digests (scp_d entry) (checkpoint2digest c)))
      (scp_checkpoint entry).

  Definition wf_stable_checkpoint_entry_no_repeats (entry : PBFTstableCheckpointEntry) : bool :=
    norepeatsb rep_deq (map checkpoint2sender (scp_checkpoint entry)).

  Definition wf_stable_checkpoint_entry (entry : PBFTstableCheckpointEntry) : bool :=
    (wf_stable_checkpoint_entry_same_seq_and_digest entry)
      && (wf_stable_checkpoint_entry_no_repeats entry).

  Fixpoint wf_checkpoint_log (s : PBFTcheckpoint_log) : bool :=
    match s with
    | [] => true
    | entry :: entries => wf_checkpoint_entry entry && wf_checkpoint_log entries
    end.

  Definition wf_stable_checkpoint (entry : PBFTstableCheckpointEntry) : bool :=
    (* either the initial stable checkpoint *)
    (length (scp_checkpoint entry) =? 0)
    ||
    (* or a stable checkpoint *)
    ((F + 1) <=? length (scp_checkpoint entry)).

  Definition wf_checkpoint_state (s : PBFTcheckpointState) : bool :=
    (wf_stable_checkpoint_entry (chk_state_stable s))
      && (wf_stable_checkpoint  (chk_state_stable s))
      && (wf_checkpoint_log (chk_state_others s)).

  Lemma check_send_replies_preserves_cp_state :
    forall i v keys giop s1 n msgs s2,
      check_send_replies i v keys giop s1 n = (msgs, s2)
      -> cp_state s2 = cp_state s1.
  Proof.
    introv check; unfold check_send_replies in check; smash_pbft.
    destruct x; simpl in *; smash_pbft.
  Qed.

  Lemma check_send_replies_update_log_preserves_wf_checkpoint_state :
    forall i v keys giop s1 L n msgs s2,
      check_send_replies i v keys giop (update_log s1 L) n = (msgs, s2)
      -> wf_checkpoint_state (cp_state s1) = true
      -> wf_checkpoint_state (cp_state s2) = true.
  Proof.
    introv check wf.
    apply check_send_replies_preserves_cp_state in check; simpl in check.
    allrw; tcsp.
  Qed.
  Hint Resolve check_send_replies_update_log_preserves_wf_checkpoint_state : pbft.

  Definition wf_checkpoint_entry_op (eop : option PBFTcheckpointEntry) : bool :=
    match eop with
    | Some entry => wf_checkpoint_entry entry
    | None => true
    end.

  Lemma implies_wf_checkpoint_log_trim_checkpoint_log :
    forall n L,
      wf_checkpoint_log L = true
      -> wf_checkpoint_log (trim_checkpoint_log n L) = true.
  Proof.
    induction L; introv wf; simpl in *; tcsp; smash_pbft.
  Qed.
  Hint Resolve implies_wf_checkpoint_log_trim_checkpoint_log : pbft.

  Lemma is_stable_checkpoint_entry_implies_wf_stable_checkpoint :
    forall e se,
      is_stable_checkpoint_entry e = true
      -> checkpoint_entry2stable e = Some se
      -> wf_stable_checkpoint se = true.
  Proof.
    introv h check; unfold is_stable_checkpoint_entry in h.
    destruct e; simpl in *; smash_pbft.
    unfold wf_stable_checkpoint; smash_pbft.
  Qed.
  Hint Resolve is_stable_checkpoint_entry_implies_wf_stable_checkpoint : pbft.

  Lemma checkpoint_entry2stable_implies_wf_stable_checkpoint_entry :
    forall e se,
      checkpoint_entry2stable e = Some se
      -> wf_checkpoint_entry e = true
      -> wf_stable_checkpoint_entry se = true.
  Proof.
    introv check wf.
    destruct e; simpl in *; smash_pbft.
  Qed.
  Hint Resolve checkpoint_entry2stable_implies_wf_stable_checkpoint_entry : pbft.

  Lemma check_stable_preserves_wf_checkpoint_state :
    forall i s1 e s2,
      check_stable i s1 e = Some s2
      -> wf_checkpoint_entry e = true
      -> wf_checkpoint_state (cp_state s1) = true
      -> wf_checkpoint_state (cp_state s2) = true.
  Proof.
    introv check wf1 wf2.
    unfold check_stable in check; smash_pbft.
    unfold wf_checkpoint_state; simpl; smash_pbft; dands; eauto 3 with pbft.
    apply implies_wf_checkpoint_log_trim_checkpoint_log; tcsp.
    unfold wf_checkpoint_state in *.
    allrw andb_true; tcsp.
  Qed.
  Hint Resolve check_stable_preserves_wf_checkpoint_state : pbft.

  Lemma same_seq_nums_same :
    forall n, same_seq_nums n n = true.
  Proof.
    introv; unfold same_seq_nums; smash_pbft.
  Qed.
  Hint Resolve same_seq_nums_same : pbft.
  Hint Rewrite same_seq_nums_same : pbft.

  Lemma same_digests_same :
    forall d, same_digests d d = true.
  Proof.
    introv; unfold same_digests; smash_pbft.
  Qed.
  Hint Resolve same_digests_same : pbft.
  Hint Rewrite same_digests_same : pbft.

  Lemma in_sender_of_add_checkpoint2checkpoint_implies :
    forall c l k s,
      add_checkpoint2checkpoint c l = Some k
      -> In s (map checkpoint2sender k)
      -> s = checkpoint2sender c
         \/ In s (map checkpoint2sender l).
  Proof.
    induction l; introv add i; repeat (simpl in *; tcsp; smash_pbft).
    repndors; subst; tcsp.
    pose proof (IHl x s) as q; repeat (autodimp q hyp); tcsp.
  Qed.

  Lemma add_checkpoint2entry_preserves_wf_checkpoint_entry :
    forall a c sm lastr x,
      add_checkpoint2entry a c sm lastr = Some x
      -> is_checkpoint_for_entry a c = true
      -> wf_checkpoint_entry a = true
      -> wf_checkpoint_entry x = true.
  Proof.
    introv add isc wf.
    unfold is_checkpoint_for_entry in isc.
    unfold similar_sn_and_checkpoint_sn in isc; smash_pbft.
    destruct a; simpl in *.
    smash_pbft.
    unfold wf_checkpoint_entry in *; simpl in *.
    unfold wf_checkpoint_entry_same_seq_and_digest in *; simpl in *.
    unfold wf_checkpoint_entry_no_repeats in *; simpl in *.
    smash_pbft.
    revert dependent x0.
    induction cp_checkpoint; introv add; simpl in *; ginv; simpl in *; smash_pbft;
      dands; tcsp;
        try (complete (repeat (autodimp IHcp_checkpoint hyp); tcsp; apply IHcp_checkpoint; auto)).
    eapply in_sender_of_add_checkpoint2checkpoint_implies in i;[|eauto]; tcsp.
  Qed.
  Hint Resolve add_checkpoint2entry_preserves_wf_checkpoint_entry : pbft.

  Lemma add_new_checkpoint2cp_log_preserves_wf_checkpoint_entry_op :
    forall L smstate R c eop K,
      add_new_checkpoint2cp_log L smstate R c = (eop, K)
      -> wf_checkpoint_log L = true
      -> wf_checkpoint_entry_op eop = true.
  Proof.
    induction L; introv add wf; simpl in *; tcsp; ginv; smash_pbft.

    unfold wf_checkpoint_entry_op; simpl.
    unfold wf_checkpoint_entry; simpl.
    unfold wf_checkpoint_entry_same_seq_and_digest; simpl.
    unfold wf_checkpoint_entry_no_repeats; simpl.
    unfold same_seq_nums, same_digests; simpl; smash_pbft.
  Qed.
  Hint Resolve add_new_checkpoint2cp_log_preserves_wf_checkpoint_entry_op : pbft.

  Lemma add_new_checkpoint2cp_log_preserves_wf_checkpoint_log :
    forall L smstate R c eop K,
      add_new_checkpoint2cp_log L smstate R c = (eop, K)
      -> wf_checkpoint_log L = true
      -> wf_checkpoint_log K = true.
  Proof.
    induction L; introv add wf; simpl in *; tcsp; ginv; smash_pbft.

    unfold wf_checkpoint_log; simpl.
    unfold wf_checkpoint_entry; simpl.
    unfold wf_checkpoint_entry_same_seq_and_digest; simpl.
    unfold wf_checkpoint_entry_no_repeats; simpl.
    unfold same_seq_nums, same_digests; simpl; smash_pbft.
  Qed.
  Hint Resolve add_new_checkpoint2cp_log_preserves_wf_checkpoint_log : pbft.

  Lemma add_new_checkpoint2cp_state_preserves_wf_checkpoint_entry_op :
    forall s1 smstate R c eop s2,
      add_new_checkpoint2cp_state s1 smstate R c = (eop, s2)
      -> wf_checkpoint_state s1 = true
      -> wf_checkpoint_entry_op eop = true.
  Proof.
    introv add wf.
    unfold add_new_checkpoint2cp_state in add; smash_pbft.
    destruct s1; simpl in *.
    unfold wf_checkpoint_state in *; simpl in *.
    allrw andb_true; repnd; smash_pbft.
  Qed.
  Hint Resolve add_new_checkpoint2cp_state_preserves_wf_checkpoint_entry_op : pbft.

  Lemma add_new_checkpoint2cp_state_preserves_wf_checkpoint_state :
    forall s1 smstate R c eop s2,
      add_new_checkpoint2cp_state s1 smstate R c = (eop, s2)
      -> wf_checkpoint_state s1 = true
      -> wf_checkpoint_state s2 = true.
  Proof.
    introv add wf.
    unfold add_new_checkpoint2cp_state in add; smash_pbft.
    destruct s1; simpl in *.
    unfold wf_checkpoint_state in *; simpl in *; smash_pbft; dands; eauto 3 with pbft.
  Qed.
  Hint Resolve add_new_checkpoint2cp_state_preserves_wf_checkpoint_state : pbft.

  Lemma cp_state_decrement_requests_in_progress_if_primary :
    forall i v s,
      cp_state (decrement_requests_in_progress_if_primary i v s) = cp_state s.
  Proof.
    introv; destruct s; simpl.
    unfold decrement_requests_in_progress_if_primary; simpl; smash_pbft.
  Qed.
  Hint Rewrite cp_state_decrement_requests_in_progress_if_primary : pbft.

  Lemma implies_wf_checkpoint_state_cp_state_decrement_requests_in_progress_if_primary :
    forall i v s,
      wf_checkpoint_state (cp_state s) = true
      -> wf_checkpoint_state (cp_state (decrement_requests_in_progress_if_primary i v s)) = true.
  Proof.
    introv wf; smash_pbft.
  Qed.
  Hint Resolve implies_wf_checkpoint_state_cp_state_decrement_requests_in_progress_if_primary : pbft.

  Lemma execute_requests_preserves_wf_checkpoint_state :
    forall R i v keys s1 msgs l s2,
      execute_requests i v keys s1 R = (msgs, l, s2)
      -> wf_checkpoint_state (cp_state s1) = true
      -> wf_checkpoint_state (cp_state s2) = true.
  Proof.
    induction R; introv exec wf; simpl in *; smash_pbft.
    unfold check_broadcast_checkpoint in *; simpl in *; smash_pbft.
  Qed.
  Hint Resolve execute_requests_preserves_wf_checkpoint_state : pbft.

  Lemma find_and_execute_requests_preserves_wf_checkpoint_state :
    forall i v keys s1 msgs s2,
      find_and_execute_requests i v keys s1 = (msgs, s2)
      -> wf_checkpoint_state (cp_state s1) = true
      -> wf_checkpoint_state (cp_state s2) = true.
  Proof.
    introv find wf.
    unfold find_and_execute_requests in find; smash_pbft.
  Qed.
  Hint Resolve find_and_execute_requests_preserves_wf_checkpoint_state : pbft.

  Lemma implies_wf_checkpoint_state_trim_checkpoint_state :
    forall n s,
      wf_checkpoint_state s = true
      -> wf_checkpoint_state (trim_checkpoint_state n s) = true.
  Proof.
    introv wf; destruct s; simpl in *.
    unfold wf_checkpoint_state in *; simpl in *; smash_pbft; dands; eauto 3 with pbft.
  Qed.
  Hint Resolve implies_wf_checkpoint_state_trim_checkpoint_state : pbft.

(*  Lemma implies_forallb_add_own_checkpoint_to_certificate_true :
    forall F c C,
      F c = true
      -> forallb F C = true
      -> forallb F (add_own_checkpoint_to_certificate c C) = true.
  Proof.
    introv h q; destruct C; simpl in *; smash_pbft.
  Qed.*)

  Lemma correct_view_change_cert_one_implies_same_seq_nums :
    forall s v S e,
      correct_view_change_cert_one s v S e = true
      -> same_seq_nums s (checkpoint2seq e) = true.
  Proof.
    introv cor.
    unfold correct_view_change_cert_one in cor; smash_pbft.
  Qed.
  Hint Resolve correct_view_change_cert_one_implies_same_seq_nums : pbft.

  Definition view_change2digest (vc : ViewChange) : PBFTdigest :=
    StableChkPt2digest (view_change2stable vc).

  Lemma correct_view_change_cert_one_implies_same_digests :
    forall s v S e,
      correct_view_change_cert_one s v S e = true
      -> same_digests (StableChkPt2digest S) (checkpoint2digest e) = true.
  Proof.
    introv cor.
    unfold correct_view_change_cert_one in cor; smash_pbft.
    unfold same_digests in *; smash_pbft.
  Qed.
  Hint Resolve correct_view_change_cert_one_implies_same_digests : pbft.

  Lemma correct_view_change_implies_all_same_seq_nums :
    forall v vc,
      correct_view_change v vc = true
      -> forallb
           (fun c =>
              (same_seq_nums (view_change2seq vc) (checkpoint2seq c))
                && (same_digests (view_change2digest vc) (checkpoint2digest c)))
           (view_change2cert vc) = true.
  Proof.
    introv cor.
    unfold correct_view_change in cor; smash_pbft.
    unfold correct_view_change_cert in *; smash_pbft.
    allrw forallb_forall.
    introv xx; apply cor0 in xx; smash_pbft.
    dands; unfold view_change2digest; eauto 2 with pbft.
  Qed.
  Hint Resolve correct_view_change_implies_all_same_seq_nums : pbft.

  Lemma correct_view_change_cert_one_implies_eq_digests :
    forall s v S e,
      correct_view_change_cert_one s v S e = true
      -> StableChkPt2digest S = checkpoint2digest e.
  Proof.
    introv cor.
    unfold correct_view_change_cert_one in cor; smash_pbft.
    unfold same_digests in *; smash_pbft.
  Qed.
  Hint Resolve correct_view_change_cert_one_implies_eq_digests : pbft.

  Lemma extract_seq_and_digest_from_checkpoint_certificate_implies_eq_seq_and_digest :
    forall vc n d view,
      extract_seq_and_digest_from_checkpoint_certificate (view_change2cert vc) = Some (n, d)
      -> correct_view_change view vc = true
      -> view_change2seq vc = n
         /\ view_change2digest vc = d.
  Proof.
    introv h cor.
    destruct vc, v; simpl in *.
    destruct C; simpl in *; ginv.
    unfold correct_view_change in cor; simpl in cor.
    unfold view_change2prep in cor; simpl in cor.
    allrw andb_true; repnd.
    unfold correct_view_change_cert, view_change2digest in *; dands; smash_pbft.
  Qed.

  Lemma correct_view_change_implies_norepeatsb :
    forall v vc,
      correct_view_change v vc = true
      -> norepeatsb rep_deq (map checkpoint2sender (view_change2cert vc)) = true.
  Proof.
    introv cor.
    unfold correct_view_change in cor; smash_pbft.
    unfold correct_view_change_cert in *; smash_pbft.
  Qed.
  Hint Resolve correct_view_change_implies_norepeatsb : pbft.

  Lemma in_senders_implies_contains_our_own_checkpoint_message :
    forall i l,
      In i (map checkpoint2sender l)
      -> contains_our_own_checkpoint_message i l = true.
  Proof.
    induction l; introv j; simpl in *; tcsp; repndors; subst; smash_pbft.
  Qed.
  Hint Resolve in_senders_implies_contains_our_own_checkpoint_message : pbft.

(*  Lemma implies_norepeatsb_add_own_checkpoint_to_certificate :
    forall cp l,
      contains_our_own_checkpoint_message (checkpoint2sender cp) l = false
      -> norepeatsb rep_deq (map checkpoint2sender l) = true
      -> norepeatsb rep_deq (map checkpoint2sender (add_own_checkpoint_to_certificate cp l)) = true.
  Proof.
    induction l; introv own norep; simpl in *; tcsp; smash_pbft.
  Qed.
  Hint Resolve implies_norepeatsb_add_own_checkpoint_to_certificate : pbft.*)

  Lemma correct_view_change_implies_stable :
    forall v vc,
      correct_view_change v vc = true
      -> F + 1 <= length (view_change2cert vc).
  Proof.
    introv cor; unfold correct_view_change in cor; smash_pbft.
    unfold correct_view_change_cert in cor0; smash_pbft.
  Qed.
  Hint Resolve correct_view_change_implies_stable : pbft.

  Lemma view_change_cert2max_seq_vc_implies_stable :
    forall nv n vc,
      correct_new_view nv = true
      -> view_change_cert2max_seq_vc (new_view2cert nv) = Some (n, vc)
      -> F + 1 <= length (view_change2cert vc).
  Proof.
    introv cor mseq.
    apply view_change_cert2_max_seq_vc_some_in in mseq.
    apply correct_new_view_implies_correct_view_change in mseq; auto; eauto 3 with pbft.
  Qed.
  Hint Resolve view_change_cert2max_seq_vc_implies_stable : pbft.

  Lemma update_state_new_view_preserves_wf_checkpoint_state :
    forall i s1 nv s2 msgs,
      correct_new_view nv = true
      -> update_state_new_view i s1 nv = (s2, msgs)
      -> wf_checkpoint_state (cp_state s1) = true
      -> wf_checkpoint_state (cp_state s2) = true.
  Proof.
    introv cor upd wf.
    unfold update_state_new_view in upd; smash_pbft.
    unfold update_checkpoint_from_new_view; smash_pbft;
      apply implies_wf_checkpoint_state_trim_checkpoint_state.

    - unfold log_checkpoint_cert_from_new_view in *; smash_pbft.

      + unfold update_stable_sp_log; simpl.
        unfold wf_checkpoint_state in *; smash_pbft.
        unfold wf_stable_checkpoint in *; smash_pbft.
        dands; auto; eauto 3 with pbft;[].

        unfold wf_stable_checkpoint_entry; simpl.

        match goal with
        | [ H : context[view_change_cert2max_seq_vc] |- _ ] => rename H into vcert
        end.
        applydup view_change_cert2_max_seq_vc_some_in in vcert.
        applydup correct_new_view_implies_correct_cert in cor.
        rewrite forallb_forall in cor0.

        applydup cor0 in vcert0.

        match goal with
        | [ H : context[extract_seq_and_digest_from_checkpoint_certificate] |- _ ] => rename H into ext
        end.

        dup ext as ext'.
        eapply extract_seq_and_digest_from_checkpoint_certificate_implies_eq_seq_and_digest in ext; auto; repnd.
        subst; eauto 3 with pbft.
        unfold wf_stable_checkpoint_entry_same_seq_and_digest; simpl.
        unfold wf_stable_checkpoint_entry_no_repeats; simpl.
        smash_pbft; dands; eauto 2 with pbft.

      + unfold update_stable_sp_log; simpl.
        unfold wf_checkpoint_state in *; smash_pbft.
        unfold wf_stable_checkpoint in *; smash_pbft.
        dands; auto; eauto 3 with pbft;[].
        unfold wf_stable_checkpoint_entry; simpl.

        match goal with
        | [ H : context[view_change_cert2max_seq_vc] |- _ ] => rename H into vcert
        end.

        match goal with
        | [ H : context[extract_seq_and_digest_from_checkpoint_certificate] |- _ ] => rename H into ext
        end.

        applydup sn_of_view_change_cert2max_seq_vc in vcert; subst.

        applydup view_change_cert2_max_seq_vc_some_in in vcert.
        applydup correct_new_view_implies_correct_cert in cor.
        rewrite forallb_forall in cor0.

        applydup cor0 in vcert0.

        dup ext as ext'.
        eapply extract_seq_and_digest_from_checkpoint_certificate_implies_eq_seq_and_digest in ext; auto; repnd.
        subst.

        unfold wf_stable_checkpoint_entry_same_seq_and_digest,
        wf_stable_checkpoint_entry_no_repeats; simpl; smash_pbft;
          dands; eauto 3 with pbft;
            eapply correct_view_change_implies_all_same_seq_nums; eauto.

    - unfold log_checkpoint_cert_from_new_view in *; smash_pbft.

      + unfold update_stable_sp_log; simpl.
        unfold wf_checkpoint_state in *; smash_pbft.
        unfold wf_stable_checkpoint in *; smash_pbft.
        dands; auto; eauto 3 with pbft;[].
        unfold wf_stable_checkpoint_entry; simpl.

        match goal with
        | [ H : context[view_change_cert2max_seq_vc] |- _ ] => rename H into vcert
        end.
        applydup view_change_cert2_max_seq_vc_some_in in vcert.
        applydup correct_new_view_implies_correct_cert in cor.
        rewrite forallb_forall in cor0.

        applydup cor0 in vcert0.

        match goal with
        | [ H : context[extract_seq_and_digest_from_checkpoint_certificate] |- _ ] => rename H into ext
        end.

        dup ext as ext'.
        eapply extract_seq_and_digest_from_checkpoint_certificate_implies_eq_seq_and_digest in ext; auto; repnd.
        subst; eauto 3 with pbft.
        unfold wf_stable_checkpoint_entry_same_seq_and_digest; simpl.
        unfold wf_stable_checkpoint_entry_no_repeats; simpl.
        smash_pbft; dands; eauto 2 with pbft.

      + unfold update_stable_sp_log; simpl.
        unfold wf_checkpoint_state in *; smash_pbft.
        unfold wf_stable_checkpoint in *; smash_pbft.
        dands; auto; eauto 3 with pbft;[].
        unfold wf_stable_checkpoint_entry; simpl.

        match goal with
        | [ H : context[view_change_cert2max_seq_vc] |- _ ] => rename H into vcert
        end.

        match goal with
        | [ H : context[extract_seq_and_digest_from_checkpoint_certificate] |- _ ] => rename H into ext
        end.

        applydup sn_of_view_change_cert2max_seq_vc in vcert; subst.

        applydup view_change_cert2_max_seq_vc_some_in in vcert.
        applydup correct_new_view_implies_correct_cert in cor.
        rewrite forallb_forall in cor0.

        applydup cor0 in vcert0.

        dup ext as ext'.
        eapply extract_seq_and_digest_from_checkpoint_certificate_implies_eq_seq_and_digest in ext; auto; repnd.
        subst.
        unfold wf_stable_checkpoint_entry_same_seq_and_digest; simpl.
        unfold wf_stable_checkpoint_entry_no_repeats; simpl.
        smash_pbft; dands; eauto 3 with pbft;
          eapply correct_view_change_implies_all_same_seq_nums; eauto.
  Qed.
  Hint Resolve update_state_new_view_preserves_wf_checkpoint_state : pbft.

  Lemma add_prepares_to_log_from_new_view_pre_prepares_preserves_cp_state :
    forall i L s1 s2 msgs,
      add_prepares_to_log_from_new_view_pre_prepares i s1 L = (s2, msgs)
      -> cp_state s2 = cp_state s1.
  Proof.
    induction L; introv add; simpl in *; smash_pbft.
    match goal with
    | [ H : context[add_prepares_to_log_from_new_view_pre_prepares] |- _ ] =>
      apply IHL in H; allrw
    end.

    unfold add_prepare_to_log_from_new_view_pre_prepare in *; smash_pbft.

    match goal with
    | [ H : context[check_send_replies] |- _ ] =>
      apply check_send_replies_preserves_cp_state in H
    end.
    allrw; simpl; auto.
  Qed.

  Lemma add_prepares_to_log_from_new_view_pre_prepares_preserves_wf_checkpoint_state :
    forall i L s1 s2 msgs,
      add_prepares_to_log_from_new_view_pre_prepares i s1 L = (s2, msgs)
      -> wf_checkpoint_state (cp_state s1) = true
      -> wf_checkpoint_state (cp_state s2) = true.
  Proof.
    introv add wf.
    apply add_prepares_to_log_from_new_view_pre_prepares_preserves_cp_state in add.
    allrw; auto.
  Qed.
  Hint Resolve add_prepares_to_log_from_new_view_pre_prepares_preserves_wf_checkpoint_state : pbft.

  Lemma wf_checkpoint_state_check_one_stable :
    forall i s l,
      wf_checkpoint_state (cp_state s) = true
      -> wf_checkpoint_log l = true
      -> wf_checkpoint_state (cp_state (check_one_stable i s l)) = true.
  Proof.
    induction l; introv wf1 wf2; simpl in *; smash_pbft.
  Qed.
  Hint Resolve wf_checkpoint_state_check_one_stable : pbft.

  Lemma wf_checkpoint_state_implies_wf_checkpoint_log :
    forall s,
      wf_checkpoint_state s = true
      -> wf_checkpoint_log (chk_state_others s) = true.
  Proof.
    introv wf.
    unfold wf_checkpoint_state in wf; smash_pbft.
  Qed.
  Hint Resolve wf_checkpoint_state_implies_wf_checkpoint_log : pbft.

  Lemma implies_wf_checkpoint_state_cp_state_log_new_view_state :
    forall s nv,
      wf_checkpoint_state (cp_state s) = true
      -> wf_checkpoint_state (cp_state (log_new_view_state s nv)) = true.
  Proof.
    tcsp.
  Qed.
  Hint Resolve implies_wf_checkpoint_state_cp_state_log_new_view_state : pbft.

  Lemma implies_wf_checkpoint_state_cp_state :
    forall s v,
      wf_checkpoint_state (cp_state s) = true
      -> wf_checkpoint_state (cp_state (update_view s v)) = true.
  Proof.
    tcsp.
  Qed.
  Hint Resolve implies_wf_checkpoint_state_cp_state : pbft.

  Lemma wf_checkpoint_state_state_preserved_on_event :
    forall (eo  : EventOrdering)
           (e   : Event)
           (slf : Rep)
           (st  : PBFTstate),
      state_sm_on_event (PBFTreplicaSM slf) e = Some st
      -> wf_checkpoint_state (cp_state st) = true.
  Proof.
    prove_by_ind ind h eqst sop p m eqtrig trig smash_handlers3 smash_pbft_ind6_7.
  Qed.

  Lemma wf_checkpoint_state_state_preserved_before_event :
    forall (eo  : EventOrdering)
           (e   : Event)
           (slf : Rep)
           (st  : PBFTstate),
      state_sm_before_event (PBFTreplicaSM slf) e = Some st
      -> wf_checkpoint_state (cp_state st) = true.
  Proof.
    introv eqst.
    rewrite <- ite_first_state_sm_on_event_as_before in eqst.
    unfold ite_first in *.
    destruct (dec_isFirst e) as [d|d]; ginv; subst; simpl in *;tcsp;[].
    eapply wf_checkpoint_state_state_preserved_on_event in eqst; eauto.
  Qed.

End PBFTwf_checkpoint_state.

Hint Resolve check_send_replies_update_log_preserves_wf_checkpoint_state : pbft.
Hint Resolve wf_checkpoint_state_state_preserved_on_event : pbft.
Hint Resolve wf_checkpoint_state_state_preserved_before_event : pbft.
Hint Resolve correct_view_change_cert_one_implies_same_seq_nums : pbft.
Hint Resolve correct_view_change_cert_one_implies_same_digests : pbft.
Hint Resolve correct_view_change_implies_all_same_seq_nums : pbft.
Hint Resolve correct_view_change_cert_one_implies_eq_digests : pbft.
Hint Resolve same_seq_nums_same : pbft.
Hint Resolve same_digests_same : pbft.
Hint Resolve in_senders_implies_contains_our_own_checkpoint_message : pbft.
(*Hint Resolve implies_norepeatsb_add_own_checkpoint_to_certificate : pbft.*)
Hint Resolve is_stable_checkpoint_entry_implies_wf_stable_checkpoint : pbft.
Hint Resolve correct_view_change_implies_stable : pbft.
Hint Resolve view_change_cert2max_seq_vc_implies_stable : pbft.
Hint Resolve checkpoint_entry2stable_implies_wf_stable_checkpoint_entry : pbft.
Hint Resolve wf_checkpoint_state_check_one_stable : pbft.
Hint Resolve wf_checkpoint_state_implies_wf_checkpoint_log : pbft.

Hint Rewrite @same_seq_nums_same : pbft.
Hint Rewrite @same_digests_same : pbft.


(* Stream programs with blocking pull.
   No option of pull finished or not, just wait until something new comes along.
 *)
Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Merges.List.List.
Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.
Require Import Coq.Logic.FunctionalExtensionality.

Module Base.
Section Machine.
  Variable Label : Set.

  Definition Value := nat.
  (* Pred input_seen input_left output *)
  (* I don't think predicate needs the peek of the stream before pull *)
  Definition Pred := list Value -> list Value -> Prop.

  (* No heap or variables, just constant values *)
  Inductive Block : Type :=
   (* Pull, ignore value, but note whether something was pulled *)
   | BlockPull   : Label -> Block
   (* Push a constant value *)
   | BlockPush   : Value -> Label -> Block
   (* Jump to another label without doing anything *)
   | BlockJump   : Label -> Block.
  Hint Constructors Block.

  Variable Blocks : Label -> Block.
  Variable LabelPre  : Label -> Pred.

  Inductive EvalB : list Value -> list Value -> Label
                 -> list Value -> list Value -> Label -> Prop :=
   | EvalBPull l lok i iss os
      : Blocks l = BlockPull lok
     -> EvalB iss os l
              (iss++[i])  os lok

   | EvalBPush l push l' iss os
      : Blocks l = BlockPush push l'
     -> EvalB iss os l
              iss (os ++ [push]) l'

   | EvalBJump l l' iss os
      : Blocks l = BlockJump l'
     -> EvalB iss os l
              iss os l'
   .

  Variable Init : Label.
  Variable InitPre : LabelPre Init [] [].

  Inductive EvalBs : list Value -> list Value -> Label -> Prop :=
   | EvalBs0
      : EvalBs [] [] Init
   | EvalBs1 l l' iss iss' os os'
      : EvalBs iss os l
     -> EvalB  iss os l iss' os' l'
     -> EvalBs iss' os' l'
   .
  Definition BlocksPreT :=
    forall iss iss' os os' l l',
    EvalBs iss os l ->
    LabelPre l iss os ->
    EvalB  iss os l iss' os' l' ->
    LabelPre l' iss' os'.

  Hypothesis BlocksPre: BlocksPreT.

  Theorem EvalBs_Hoare l iss os
   (hEvB : EvalBs iss    os l)
         : LabelPre l iss os.
  Proof.
   !induction hEvB.
  Qed.
End Machine.

End Base.

Module Program.
 Module B := Base.
 Record Program (Label : Set) : Type
  := mkProgram
   { Init     : Label
   ; Blocks   : Label -> B.Block Label
   ; LabelPre : Label -> B.Pred
   ; BlocksPre: B.BlocksPreT Blocks LabelPre Init
   ; InitPre  : LabelPre Init [] []
   }.

  Definition EvalBs (Label : Set) (P : Program Label)
   := B.EvalBs (Blocks P) (Init P).
  (*
  Ltac Program_Block_destruct p l :=
    let pre := fresh "block_pre" in
    let eq  := fresh "block_eq" in
    destruct (Blocks p l) eqn:eq;
    lets pre: (BlocksPre p l);
    simpl;
    rewrite eq in *. *)
End Program.

Module Fuse.
  Module B := Base.
  Module P := Program.

  Parameter L1 : Set.
  Parameter P1 : P.Program L1.

  Parameter L2 : Set.
  Parameter P2 : P.Program L2.

  Inductive State :=
    | Waiting
    | Ok
    .
  Hint Constructors State.

  Inductive L' :=
    | LX (l1 : L1) (l2 : L2) (s1 : State) (s2 : State).
  Hint Constructors L'.

  Definition Blocks (l : L') : B.Block L' :=
   match l with
   | LX l1 l2 s1 s2
   => match P.Blocks P1 l1, P.Blocks P2 l2, s1, s2 with
      (* try to run 1. for most it doesn't matter what state is, *)
      (* as state can only be 'Waiting' if stuck on a push. *)
      (* pulling is normal. *)
      | B.BlockPull lok, _, _, _
      => B.BlockPull (LX lok l2 Ok s2)

      (* trying to push while in 'Ok' marks this as 'Waiting' for other to pull *)
      | B.BlockPush _ _, _, Ok, _
      => B.BlockJump (LX l1 l2 Waiting s2)

      (* jump is normal *)
      | B.BlockJump l', _, _, _
      => B.BlockJump (LX l' l2 Ok s2)

      (* try to run 2 *)
      (* pulling while 'Ok' marks as waiting. *)
      | _, B.BlockPull _, _, Ok
      => B.BlockJump (LX l1 l2 s1 Waiting)

      (* pushing is normal *)
      | _, B.BlockPush f l', _, _
      => B.BlockPush f (LX l1 l' s1 Ok)

      (* jump is normal *)
      | _, B.BlockJump l', _, _
      => B.BlockJump (LX l1 l' s1 Ok)

      (* Both machines are waiting on other one, so can progress *)
      | B.BlockPush f1 l1', B.BlockPull lok, Waiting, Waiting
      => B.BlockJump (LX l1' lok Ok Ok)

      end
   end.

  Check P.EvalBs.
  Definition listOfOption (o : option nat) : list nat :=
  match o with
  | Some v => [v]
  | None   => []
  end.
  Definition LabelPre (l : L') : B.Pred :=
   match l with
   | LX l1 l2 s1 s2
   => fun iss os
   => exists (iss' : list nat),
      P.EvalBs P1 iss  iss' l1
   /\ P.EvalBs P2 iss' os l2
   end.
  Hint Unfold LabelPre.

  Program Definition r := {| P.Blocks := Blocks; P.LabelPre := LabelPre; P.Init := LX (P.Init P1) (P.Init P2) Ok Ok |}.
  Next Obligation.
   unfolds B.BlocksPreT.
   introv hEvBs hLbl hEvB.
   destruct l; destruct l'.
   !inverts hEvB; simpls
  ; destruct (P.Blocks P1 l1) eqn:P1Block
  ; destruct (P.Blocks P2 l2) eqn:P2Block
  ; destruct s1; destruct s2
  ; (!inject_all; simpls; tryfalse)
  ; try solve [(!jauto_set)
  ;   (!eapply B.EvalBs1)
  ;   try solve [!eapply B.EvalBPull]
  ;   try solve [!eapply B.EvalBPush]
  ;   try solve [!eapply B.EvalBJump]
  ].
  Qed.
  Next Obligation.
   jauto_set; eapply B.EvalBs0.
  Qed.

  Theorem fuse_ok (l1 : L1) (l2 : L2) (s1 s2 : State) iss oss:
   P.EvalBs r iss oss (LX l1 l2 s1 s2)
  ->
   exists (iss' : list nat),
      P.LabelPre P1 l1 iss  iss' /\ P.LabelPre P2 l2 iss' oss.
  Proof.
   introv hEvBs.
   apply B.EvalBs_Hoare with (LabelPre := LabelPre) in hEvBs.
   simpls; jauto_set.
   !apply B.EvalBs_Hoare with (LabelPre := P.LabelPre P1) in H.
   apply (P.InitPre P1).
   apply (P.BlocksPre P1).

   !apply B.EvalBs_Hoare with (LabelPre := P.LabelPre P2) in H0.
   apply (P.InitPre P2).
   apply (P.BlocksPre P2).

   apply (P.InitPre r).
   apply (P.BlocksPre r).
  Qed.
End Fuse.