From Coq Require Import Morphisms.

From ITree Require Import
     ITree
     ITreeFacts
     HeterogeneousRelations
     Events.State
     Events.StateFacts
     Events.Exception
     Events.ExceptionFacts.

From ITree.Extra Require Import
     Secure.SecureEqHalt
     Secure.SecureEqProgInsens
     Secure.SecureEqProgInsensFacts
.

From SecureExample Require Import
     Lattice
     LabelledImp
     LabelledImpHandler
     LabelledImpTypes.

Import Monads.
Import MonadNotation.
Local Open Scope monad_scope.

Section LabelledImpTypesProgInsens.

Context (Labels : Lattice).
Context (HLat : LatticeLaws Labels).

Notation label := (@T Labels).

Definition labelled_equiv  :=
  LabelledImpTypes.labelled_equiv Labels.

Arguments denote_expr {Labels}.
Arguments denote_stmt {Labels}.
Arguments interp_imp {Labels} {R}.

Ltac case_leq l1 l2 := destruct (leq_dec Labels l1 l2) as [?Hleq | ?Hnleq].

Instance labelled_equit_equiv {Γ l} : Equivalence (labelled_equiv Γ l).
Proof.
  constructor; unfold labelled_equiv.
  - red. red. intros; auto.
  - do 2 red. intros. symmetry; auto.
  - do 2 red. intros. rewrite H; auto.
Qed.

Definition label_pi_eqit_secure_impstate  (b1 b2 : bool) (Γ : privacy_map Labels) (l : label) {R1 R2 : Type} (RR : R1 -> R2 -> Prop )
           (m1 : stateT map (itree ((impExcE Labels) +' (IOE Labels))) R1) (m2 : stateT map (itree ((impExcE Labels) +' (IOE Labels))) R2) : Prop :=
  forall σ1 σ2, labelled_equiv Γ l σ1 σ2 -> pi_eqit_secure _ (priv_exc_io Labels) (product_rel (labelled_equiv Γ l) RR) b1 b2 l (m1 σ1) (m2 σ2).

Definition label_state_pi_sec_eutt {R1 R2} priv l (RR : R1 -> R2 -> Prop) m1 m2 :=
  label_pi_eqit_secure_impstate true true  priv l RR m1 m2.

Definition sem_stmt (s : stmt Labels) := interp_imp (denote_stmt s).

Definition sem_throw_stmt (s : stmt Labels) := interp_imp (throw_prefix (denote_stmt s) ).

Definition sem_expr (e : expr) := LabelledImpTypes.sem_expr Labels e.

Definition state_equiv {E R} (m1 m2 : stateT map (itree E) R) := forall (σ : map), m1 σ ≈ m2 σ.

Global Instance proper_eutt_pi_secure_eutt  {E R1 R2 RR Label priv l} : Proper (@eutt E R1 R1 eq ==> @eutt E R2 R2 eq ==> Basics.flip Basics.impl)
                                                               (pi_eqit_secure Label priv RR true true l).
Proof.
  eapply pi_eqit_secure_eq_itree_proper. all : apply true.
Qed.

Global Instance proper_eq_itree_secure_eutt  {E R1 R2 RR Label priv l} : Proper (@eq_itree E R1 R1 eq ==> @eq_itree E R2 R2 eq ==> Basics.flip Basics.impl)
                                                               (pi_eqit_secure Label priv RR true true l).
Proof.
  repeat intro. assert (x ≈ y). rewrite H. reflexivity.
  assert (x0 ≈ y0). rewrite H0. reflexivity. setoid_rewrite H3. rewrite H2. auto.
Qed.

Global Instance proper_state_equiv_label_state_sec_eutt {R1 R2 RR priv l} : Proper (@state_equiv _ R1 ==> @state_equiv _ R2 ==> iff) (@label_state_pi_sec_eutt R1 R2 priv l RR).
Proof.
  repeat intro. split.
  - intros. do 2 red in H1. do 2 red. intros. red in H0. specialize (H0 σ2). red in H.
    specialize (H σ1). eapply proper_eutt_pi_secure_eutt; eauto. symmetry. auto. symmetry. auto.
  - intros. intros. do 2 red in H1. do 2 red. intros. red in H0. specialize (H0 σ2). red in H.
    specialize (H σ1).  eapply proper_eutt_pi_secure_eutt; eauto.
Qed.

Context (Γ : privacy_map Labels).

Variant secure_stmt_at_label (observer pc lexn : label) (s : stmt Labels) : Prop :=
  | ssal_leq : (leq pc observer) -> label_state_pi_sec_eutt Γ observer eq (sem_stmt s) (sem_stmt s) -> secure_stmt_at_label observer pc lexn s
  | ssal_nleq : (~ leq pc observer) -> label_state_pi_sec_eutt Γ observer top2 (sem_stmt s) (ret tt) -> secure_stmt_at_label observer pc lexn s.

Variant secure_expr_at_label (observer protection: label ) (e : expr) : Prop :=
  | seal_leq : (leq protection observer) -> label_state_pi_sec_eutt Γ observer eq (sem_expr e) (sem_expr e) ->
               secure_expr_at_label observer protection e
  | seal_nleq : (~leq protection observer) -> (exists n:value, label_state_pi_sec_eutt Γ observer top2 (sem_expr e) (ret n)) ->
                secure_expr_at_label observer protection e
.

Definition secure_expr l e := forall observer, secure_expr_at_label observer l e.

Definition secure_stmt pc lexn s := forall observer, secure_stmt_at_label observer pc lexn s.

Variant is_inl {A B : Type} : A + B -> Prop :=
  | is_inl_ev (a : A) : is_inl (inl a).

(* I need cases like rsense_termlexcr so for when public observers look at private
   exceptions throw the sum type lense *)
Variant Rsense (observer lexn : label) : unit + label -> unit + label -> Prop :=
  | rsense_termlr : Rsense observer lexn (inl tt) (inl tt)
  | rsense_exclr l1 l2 : leq l1 lexn -> leq l2 lexn -> Rsense observer lexn (inr l1) (inr l2)
  | rsense_termlexcr lpriv : leq lpriv lexn -> ~ leq lpriv observer -> Rsense observer lexn (inl tt) (inr lpriv)
  | rsense_excltermr lpriv : leq lpriv lexn -> ~ leq lpriv observer -> Rsense observer lexn (inr lpriv) (inl tt)
.

Instance sym_rsense {observer lexn} : Symmetric (Rsense observer lexn).
Proof.
  red. intros. inv H; constructor; auto.
Qed.

Variant Rsense_unpriv (observer lexn : label) : unit + label -> Prop :=
  | rup_inl : Rsense_unpriv observer lexn (inl tt)
  | rup_priv_exc lpriv : ~ leq lpriv observer -> leq lpriv lexn -> Rsense_unpriv observer lexn (inr lpriv).

Variant secure_throw_stmt_at_label (observer pc lexn : label) (s : stmt Labels) : Prop :=
  | stsal_leq : leq pc observer -> label_state_pi_sec_eutt Γ observer (Rsense observer lexn )
                                                       (sem_throw_stmt s) (sem_throw_stmt s) -> secure_throw_stmt_at_label observer pc lexn s
  | stsal_nleq : (~ leq pc observer) -> label_state_pi_sec_eutt Γ observer (fun sum _ => Rsense_unpriv observer lexn sum )
                                                            (sem_throw_stmt s) (ret tt ) ->  secure_throw_stmt_at_label observer pc lexn s
  .

Definition secure_throw_stmt pc lexn s := forall observer, secure_throw_stmt_at_label observer pc lexn s.

Lemma pi_sem_stmt_ret_aux:
  forall (s1 s2 : stmt Labels) (observer : label) (σ3 σ4 : map),
    (forall σ1 σ2 : map,
        labelled_equiv Γ observer σ1 σ2 ->
        pi_eqit_secure _ (priv_exc_io Labels) (product_rel (labelled_equiv Γ observer) top2)
                       true true observer (sem_stmt s1 σ1) (Ret (σ2, tt))) ->
    (forall σ1 σ2 : map,
        labelled_equiv Γ observer σ1 σ2 ->
        pi_eqit_secure _ (priv_exc_io Labels) (product_rel (labelled_equiv Γ observer) top2)
                       true true observer (sem_stmt s2 σ1) (Ret (σ2, tt))) ->
    labelled_equiv Γ observer σ3 σ4 ->
    pi_eqit_secure _ (priv_exc_io Labels) (product_rel (labelled_equiv Γ observer) eq) true
                   true observer (interp_state (handle_imp Labels) (denote_stmt s1) σ3)
                   (interp_state (handle_imp Labels) (denote_stmt s2) σ4).
Proof.
  intros s1 s2 observer σ3 σ4 Hσ Hs1 Hs2.
  eapply pi_eqit_secure_RR_imp with (RR1 := rcompose  (product_rel (labelled_equiv Γ observer) (@top2 unit unit)) (Basics.flip (product_rel (labelled_equiv Γ observer) top2))).
  { intros [σ5 [] ] [σ6 [] ] Hr. inv Hr. inv REL1. inv REL2. split; auto.
    destruct r2 as [σ7 [] ]. etransitivity; eauto. symmetry. auto.
  }
  eapply pi_eqit_secure_trans_ret; eauto.
  apply pi_eqit_secure_sym. eapply Hs1. reflexivity.
Qed.

Lemma pi_sem_throw_stmt_ret_aux:
  forall (lexn: label) (s1 s2 : stmt Labels) (observer : label) (σ3 σ4 : map),
    (forall σ1 σ2 : map,
        labelled_equiv Γ observer σ1 σ2 ->
        pi_eqit_secure _ (priv_exc_io Labels)
                       (product_rel (labelled_equiv Γ observer)
                                    (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer lexn sum)) true true observer
                       (sem_throw_stmt s1 σ1) (Ret (σ2, tt))) ->
    (forall σ1 σ2 : map,
        labelled_equiv Γ observer σ1 σ2 ->
        pi_eqit_secure _ (priv_exc_io Labels)
                       (product_rel (labelled_equiv Γ observer)
                                    (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer lexn sum)) true true observer
                       (sem_throw_stmt s2 σ1) (Ret (σ2, tt))) ->
    labelled_equiv Γ observer σ3 σ4 ->
    pi_eqit_secure _ (priv_exc_io Labels)
                   (product_rel (labelled_equiv Γ observer) (Rsense observer lexn)) true true
                   observer (interp_state (handle_imp Labels) (throw_prefix (denote_stmt s1)) σ3)
                   (interp_state (handle_imp Labels) (throw_prefix (denote_stmt s2)) σ4).
Proof.
  intros lexn s1 s2 observer σ3 σ4 Hs1 Hs2 Hσ.
  set (product_rel (labelled_equiv Γ observer) (fun (sum : unit + label) ( _ : unit) => Rsense_unpriv observer lexn sum ) ) as HR.
  eapply pi_eqit_secure_RR_imp with (RR1 := rcompose HR (Basics.flip HR) ).
  { unfold HR. intros [σ5 r1] [σ6 r2] Hr. inv Hr. inv REL1. inv REL2.
    inv H0. inv H2. cbn in H3. cbn in H0. subst.
    destruct r0 as [σ7 [] ]. split. etransitivity; eauto. symmetry. auto.
    constructor. cbn in H5. subst. destruct r0 as [σ7 [] ]. split. etransitivity; eauto. symmetry. auto.
    cbn in H3. subst. constructor; auto. cbn in H5. cbn in H2.
    subst. destruct r0. split. etransitivity; eauto. symmetry. auto.
    cbn. inv H2. constructor; auto. constructor; auto.
  }
  eapply pi_eqit_secure_trans_ret; eauto. apply pi_eqit_secure_sym.
  eapply Hs2. reflexivity.
Qed.

Lemma lower_lexn_sound lexn1 lexn2 t1 t2 observer :
  leq lexn1 lexn2 ->
  pi_eqit_secure _ (priv_exc_io Labels)
                 (product_rel (labelled_equiv Γ observer) (Rsense observer lexn1)) true true
                 observer t1 t2 ->
  pi_eqit_secure _ (priv_exc_io Labels)
                 (product_rel (labelled_equiv Γ observer) (Rsense observer lexn2)) true true
                 observer t1 t2.
Proof.
  intros. eapply pi_eqit_secure_RR_imp; try apply H0.
  intros [σ1 r1] [σ2 r2] [Hσ Hr]. inv Hr.
  all : split; auto.
  - cbn in *; subst; constructor.
  - cbn in H3; cbn in H4; subst. constructor; auto.
    all : eapply leq_trans_lat; eauto.
  - cbn in H3; cbn in H4; subst. constructor; auto.
    eapply leq_trans_lat; eauto.
  - cbn in H3; cbn in H4; subst. constructor; auto.
    eapply leq_trans_lat; eauto.
Qed.

Lemma lower_lexn_sound' lexn1 lexn2 t1 t2 observer :
  leq lexn1 lexn2 ->
  pi_eqit_secure _ (priv_exc_io Labels)
                 (product_rel (labelled_equiv Γ observer) (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer lexn1 sum)) true true
                 observer t1 t2 ->
  pi_eqit_secure _ (priv_exc_io Labels)
                 (product_rel (labelled_equiv Γ observer) (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer lexn2 sum)) true true
                 observer t1 t2.
Proof.
  intros. eapply pi_eqit_secure_RR_imp; try apply H0.
  intros [σ1 r1] [σ2 [] ] [Hσ Hr]; inv Hr.
  - cbn in H1; subst. split; auto. constructor.
  - cbn in H3. subst. split; auto.
    constructor; auto. eapply leq_trans_lat; eauto.
Qed.

Lemma seq_well_typed_correct pc lexn1 lexn2 s1 s2 :
  secure_stmt pc lexn1 s1 -> secure_stmt (join pc lexn1) lexn2 s2 ->
  secure_stmt pc (join lexn1 lexn2) (Seq s1 s2).
Proof.
  intros Hs1 Hs2 observer.
  specialize (Hs1 observer). inv Hs1.
  - left; auto. unfold sem_stmt, interp_imp.
    cbn. do 2 red. intros σ1 σ2 Hσ. setoid_rewrite interp_state_bind.
    eapply pi_eqit_secure_bind; eauto. intros [σ3 [] ] [σ4 [] ] [Hσ' _ ].
    specialize (Hs2 observer). inv Hs2; eauto. cbn. do 2 red in H2. cbn in H2.
    eapply pi_sem_stmt_ret_aux; eauto.
  - right; auto. cbn in H0. unfold sem_stmt, interp_imp. cbn.
    do 2 red. intros σ1 σ2 Hσ.
    setoid_rewrite <- bind_ret_r with (s := Ret (σ2, tt) ).
    setoid_rewrite interp_state_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 [] ] [σ4 [] ] [Hσ' _ ].
    specialize (Hs2 observer). inv Hs2; eauto.
    + exfalso. apply H. eapply leq_trans_lat; eauto.
      apply leq_join_l; auto.
    + cbn in H2. eauto.
Qed.

Lemma seq_well_typed_correct' pc lexn1 lexn2 s1 s2 :
  secure_throw_stmt pc lexn1 s1 -> secure_throw_stmt (join pc lexn1) lexn2 s2 ->
  secure_throw_stmt pc (join lexn1 lexn2) (Seq s1 s2).
Proof.
  intros Hs1 Hs2 observer.
  specialize (Hs1 observer). inv Hs1.
  - left; auto. unfold sem_throw_stmt, interp_imp. cbn. do 2 red.
    intros σ1 σ2 Hσ. setoid_rewrite throw_prefix_bind.
    setoid_rewrite interp_state_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 r1] [σ4 r2] [Hσ' Hr]. inv Hr.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * cbn.
        eapply pi_eqit_secure_RR_imp; try eapply H4; eauto.
        intros. destruct H5. split; auto. inv H6; constructor; auto;
        try eapply leq_trans_lat; eauto; apply leq_join_r; auto.
      * cbn in H4. cbn.
        do 2 red in H4. cbn in Hσ'.
        eapply lower_lexn_sound. apply leq_join_r; auto.
        eapply pi_sem_throw_stmt_ret_aux; eauto.
    + setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret.
      split; auto; constructor; eapply leq_trans_lat; eauto.
      all : apply leq_join_l; auto.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * exfalso. apply H2. eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; eauto. apply leq_join_r; auto.
      * setoid_rewrite interp_state_ret. cbn.
        cbn in H6. do 2 red in H6.
        match goal with
      |- pi_eqit_secure _ _ _ _ _ _ _ ?t => assert (t ≈ ITree.bind (Ret (σ4,tt) ) (fun '(σ',x) => Ret (σ', inr lpriv) )) end.
        rewrite bind_ret_l. reflexivity.
        rewrite H7. rewrite <- bind_ret_r.
        eapply pi_eqit_secure_bind; eauto.
        intros [σ5 r3] [σ6 r4] [Hσ'' Hr']; inv Hr'.
        -- cbn in H8. subst. apply pi_eqit_secure_ret. split; auto.
           constructor; auto. eapply leq_trans_lat; eauto. apply leq_join_l; auto.
        -- cbn in H10. subst. apply pi_eqit_secure_ret. split; auto.
           constructor; auto. eapply leq_trans_lat; eauto. apply leq_join_r; auto.
           eapply leq_trans_lat; eauto. apply leq_join_l; auto.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * exfalso. apply H2. eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; eauto. apply leq_join_r; auto.
      * setoid_rewrite interp_state_ret. cbn.
        cbn in H6.
        match goal with
        |- pi_eqit_secure _ _ _ _ _ _ ?t _ => assert (t ≈ ITree.bind (Ret (σ3,tt) ) (fun '(σ',x) => Ret (σ', inr lpriv) )) end.
        rewrite bind_ret_l. reflexivity. rewrite H7.
        setoid_rewrite <- bind_ret_r at 4.
        apply pi_eqit_secure_sym. symmetry in Hσ'. eapply pi_eqit_secure_bind; eauto.
        intros [σ5 r3] [σ6 [] ] [Hσ'' Hr']; inv Hr'.
        -- cbn in H8. subst. apply pi_eqit_secure_ret. split; auto. symmetry. auto.
           constructor; auto. eapply leq_trans_lat; eauto. apply leq_join_l; auto.
        -- cbn in H10. subst. apply pi_eqit_secure_ret. split; auto. symmetry. auto.
           constructor. eapply leq_trans_lat; eauto. apply leq_join_l; auto.
           eapply leq_trans_lat; eauto. apply leq_join_r; auto.
  - right; auto. intros σ1 σ2 Hσ. unfold sem_throw_stmt, interp_imp.
    cbn. setoid_rewrite throw_prefix_bind. setoid_rewrite interp_state_bind.
    cbn in H0. rewrite <- bind_ret_r with (s := Ret (σ2, tt) ).
    eapply pi_eqit_secure_bind; eauto. intros [σ3 r1] [σ4 [] ] [Hσ' Hr]. inv Hr.
    -- cbn in H1. subst. cbn. specialize (Hs2 observer). inv Hs2.
       ++ exfalso. apply H. eapply leq_trans_lat; eauto. apply leq_join_l; auto.
       ++ cbn in H2. eapply lower_lexn_sound'; eauto. apply leq_join_r; auto.
    -- cbn in H3. subst. cbn.  setoid_rewrite interp_state_ret.
       apply pi_eqit_secure_ret. split; auto. constructor; auto.
       eapply leq_trans_lat; eauto. apply leq_join_l; auto.
Qed.

Lemma try_catch_well_typed_correct pc lexn1 lexn2 s1 s2 :
  secure_stmt pc lexn1 s1 -> secure_throw_stmt pc lexn1 s1 ->
  secure_stmt (join pc lexn1) lexn2 s2 ->
  secure_stmt pc lexn2 (TryCatch s1 s2).
Proof.
  intros Hs1 Hs1t Hs2 observer.
  specialize (Hs1 observer). specialize (Hs1t observer).
  inv Hs1; inv Hs1t; try contradiction.
  - left; auto. unfold sem_stmt, interp_imp. do 2 red. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite try_catch_to_throw_prefix.
    setoid_rewrite interp_state_bind. eapply pi_eqit_secure_bind; eauto.
    intros [σ3 r1 ] [σ4 r2 ] [Hσ' Hr] ; inv Hr; cbn.
    + setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret. split; auto.
    + specialize (Hs2 observer). inv Hs2; eauto. do 2 red in H8.
      cbn in H8. eapply pi_sem_stmt_ret_aux; eauto.
    + specialize (Hs2 observer). inv Hs2.
      * exfalso. apply H4. eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; auto. apply leq_join_r; auto. eauto.
      * apply pi_eqit_secure_sym. do 2 red in H8.
        apply pi_eqit_secure_RR_imp with (RR1 := product_rel (labelled_equiv Γ observer) top2).
        { intros [? [] ] [? [] ] ? . inv H9. split; auto. symmetry. auto. }
        cbn in H8. setoid_rewrite interp_state_ret. eapply H8. symmetry. auto.
    + specialize (Hs2 observer). inv Hs2.
      * exfalso. apply H4. eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; auto. apply leq_join_r; auto. eauto.
      * do 2 red in H8.
        apply pi_eqit_secure_RR_imp with (RR1 := product_rel (labelled_equiv Γ observer) top2).
        { intros [? [] ] [? [] ] ? . inv H9. split; auto. }
        cbn in H8. setoid_rewrite interp_state_ret. eapply H8. auto.
  - right; auto. unfold sem_stmt, interp_imp. do 2 red. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite try_catch_to_throw_prefix.
    (* rewrite the ret into a trivial bind *)
    match goal with
      |- pi_eqit_secure _ _ _ _ _ _ _ ?t => assert (t ≈ ITree.bind (Ret (σ2,tt) ) (fun x => Ret x)) end.
    rewrite bind_ret_r. reflexivity. rewrite H3.
    setoid_rewrite interp_state_bind. cbn in H2.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 r1] [σ4 [] ] [Hσ' Hr]; inv Hr.
    + tau_steps. apply pi_eqit_secure_ret. split; auto. cbv. auto.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * exfalso. apply H. eapply leq_trans_lat; eauto. apply leq_join_l; auto.
      * cbn in H8. eauto.
Qed.

Lemma try_catch_well_typed_correct' pc lexn1 lexn2 s1 s2 :
  secure_stmt pc lexn1 s1 -> secure_throw_stmt pc lexn1 s1 ->
  secure_throw_stmt (join pc lexn1) lexn2 s2 ->
  secure_throw_stmt pc lexn2 (TryCatch s1 s2).
Proof.
  intros Hs1 Hs1t Hs2 observer. specialize (Hs1 observer).
  specialize (Hs1t observer). inv Hs1; inv Hs1t; try contradiction.
  - left; auto. unfold sem_throw_stmt, interp_imp. cbn. do 2 red.
    intros σ1 σ2 Hσ. rewrite throw_prefix_of_try_catch.
    setoid_rewrite try_catch_to_throw_prefix.
    setoid_rewrite throw_prefix_bind.
    repeat setoid_rewrite interp_state_bind. setoid_rewrite bind_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 r1] [σ4 r2] [Hσ' Hr]; inv Hr; cbn;
      try setoid_rewrite throw_prefix_ret; try setoid_rewrite interp_state_ret;
        try setoid_rewrite bind_ret_l; cbn.
    + setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret.
      split; auto. constructor.
    + specialize (Hs2 observer). inv Hs2; eauto.
      eapply pi_sem_throw_stmt_ret_aux; eauto.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * exfalso. apply H4. eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; eauto. apply leq_join_r; auto.
      * apply pi_eqit_secure_sym. cbn in H8. do 2 red in H8.
        setoid_rewrite interp_state_ret.
        match goal with
        |- pi_eqit_secure _ _ _ _ _ _ _ ?t => assert (t ≈ ITree.bind (Ret (σ3, tt) ) (fun '(σ, x) => Ret (σ, inl x) ) ) end.
        rewrite bind_ret_l. reflexivity. rewrite H9.
        rewrite <- bind_ret_r. symmetry in Hσ'. eapply pi_eqit_secure_bind; eauto.
        intros [σ5 r] [σ6 [] ] Hr. inv Hr. inv H11.
        -- apply pi_eqit_secure_ret. split. symmetry. auto. cbn in H12. subst.
           constructor.
        -- cbn in H14. subst. apply pi_eqit_secure_ret. split. symmetry. auto.
           constructor; auto.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * exfalso. apply H4. eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; eauto. apply leq_join_r; auto.
      * setoid_rewrite interp_state_ret.
         match goal with
        |- pi_eqit_secure _ _ _ _ _ _ _ ?t => assert (t ≈ ITree.bind (Ret (σ4, tt) ) (fun '(σ, x) => Ret (σ, inl x) ) ) end.
        rewrite bind_ret_l. reflexivity. rewrite H9. cbn in H8.
        rewrite <- bind_ret_r. eapply pi_eqit_secure_bind; eauto.
        intros [σ5 r] [σ6 [] ] Hr. inv Hr. inv H11.
        -- cbn in H12. subst. apply pi_eqit_secure_ret. constructor.
           auto. constructor.
        -- cbn in H14. subst. apply pi_eqit_secure_ret. split; auto.
           constructor; auto.
  - right; auto. unfold sem_throw_stmt, interp_imp. cbn. do 2 red.
    intros σ1 σ2 Hσ. rewrite throw_prefix_of_try_catch.
    rewrite try_catch_to_throw_prefix.
    rewrite throw_prefix_bind. repeat rewrite interp_state_bind.
    rewrite bind_bind.
    setoid_rewrite <- bind_ret_r with (s := Ret (σ2, tt) ).
    cbn in H2.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 r1] [σ4 r2] [Hσ' Hr]; inv Hr.
    + rewrite throw_prefix_ret, interp_state_ret, bind_ret_l. cbn.
      rewrite interp_state_ret. apply pi_eqit_secure_ret. split; auto.
      constructor.
    + specialize (Hs2 observer). inv Hs2; eauto.
      * exfalso. apply H. eapply leq_trans_lat; eauto. apply leq_join_l; auto.
      * cbn in H7. setoid_rewrite interp_state_ret. rewrite bind_ret_l.
        cbn. destruct r2. eauto.
Qed.

Lemma pi_eqit_secure_while_ret_aux:
  forall (e : expr) (s : stmt Labels) (observer : label),
    label_state_pi_sec_eutt Γ observer top2 (sem_stmt s) (ret tt) ->
    forall σ1 σ2 : map,
      labelled_equiv Γ observer σ1 σ2 ->
      pi_eqit_secure _ (priv_exc_io Labels)
                     (product_rel (labelled_equiv Γ observer) top2) true true
                     observer (sem_stmt (While e s) σ1) (Ret (σ2, tt)).
Proof.
  intros e s observer H0 σ1 σ2 H3.
  unfold sem_stmt, interp_imp.
  cbn. specialize (@interp_state_iter') as Hisi. red in Hisi. setoid_rewrite Hisi.
  eapply pi_eqit_secure_iter_ret with (Rinv := product_rel (labelled_equiv Γ observer) eq ).
  2 : split; auto.
  intros [σ3 [] ] [Hσ3 _ ]. cbn.
  setoid_rewrite interp_state_bind. rewrite bind_bind.
  specialize (expr_only_ret' Labels e σ3) as [n Hn]. setoid_rewrite Hn.
  rewrite bind_ret_l. destruct n.
  + cbn. rewrite interp_state_ret, bind_ret_l. cbn. apply pi_eqit_secure_ret.
    constructor. split; auto. cbv. auto.
  + cbn. rewrite interp_state_bind. rewrite bind_bind.
    rewrite <- (bind_ret_r (Ret (σ2, tt))).
    cbn in H0.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ4 [] ] [σ5 [] ] [Hσ' _ ]. rewrite interp_state_ret, bind_ret_l. cbn.
    apply pi_eqit_secure_ret. constructor. split; auto.
Qed.

Lemma pi_eqit_secure_while_ret_throw_aux:
  forall (e : expr) (s : stmt Labels) (observer lexn : label),
    label_state_pi_sec_eutt Γ observer (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer lexn sum)
                            (sem_throw_stmt s) (ret tt) ->
    forall σ1 σ2 : map,
      labelled_equiv Γ observer σ1 σ2 ->
      pi_eqit_secure _ (priv_exc_io Labels)
                     (product_rel (labelled_equiv Γ observer)
                                  (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer lexn sum)) true true observer
                     (sem_throw_stmt (While e s) σ1) (Ret (σ2, tt)).
Proof.
  intros e s observer lexn H0 σ1 σ2 Hσ.
  unfold sem_throw_stmt, interp_imp.
  cbn. setoid_rewrite throw_prefix_iter.
  specialize (@interp_state_iter') as Hisi. red in Hisi. setoid_rewrite Hisi.
  apply pi_eqit_secure_iter_ret with (Rinv := product_rel (labelled_equiv Γ observer) eq).
  2 : split; auto.
  intros [σ3 [] ] [Hσ3 _ ]. cbn. cbn in Hσ3. setoid_rewrite throw_prefix_bind.
  repeat setoid_rewrite interp_state_bind. repeat rewrite bind_bind.
  rewrite throw_prefix_denote_expr. rewrite interp_state_bind, bind_bind.
  specialize (expr_only_ret' Labels e σ3) as [n Hn]. setoid_rewrite Hn.
  rewrite bind_ret_l, interp_state_ret, bind_ret_l. cbn.
  destruct n.
  + rewrite throw_prefix_ret, interp_state_ret, bind_ret_l. cbn.
    rewrite interp_state_ret. rewrite bind_ret_l. cbn.
    apply pi_eqit_secure_ret. constructor. split; auto.
    constructor.
  + rewrite throw_prefix_bind. rewrite interp_state_bind. rewrite bind_bind.
    rewrite <- (bind_ret_r (Ret (σ2, tt))).
    cbn in H0.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ4 r1] [σ5 r2] [Hσ' Hr]; inv Hr.
    * cbn in H. subst. tau_steps. apply pi_eqit_secure_ret.
      constructor; auto. split; auto. destruct r2. auto.
    * cbn in H2. subst. tau_steps.
      apply pi_eqit_secure_ret. constructor. split; auto. constructor; auto.
Qed.

Lemma while_well_typed_correct e le pc lexn s :
  secure_expr le e -> secure_stmt (join pc (join le lexn)) lexn s -> secure_stmt pc lexn (While e s).
Proof.
  intros He Hs observer.
  specialize (He observer). specialize (Hs observer).
  inv Hs; inv He.
  - left. eapply leq_trans_lat; try apply H; auto. apply leq_join_l; auto.
    do 2 red. intros σ1 σ2 Hσ. unfold sem_stmt, interp_imp. cbn.
    specialize (@interp_state_iter') as Hisi. red in Hisi. setoid_rewrite Hisi.
    apply secure_eqit_iter with (RA := product_rel (labelled_equiv Γ observer) eq );
      auto.
    clear σ1 σ2 Hσ. intros [σ1 [] ] [σ2 [] ] [Hσ _ ].
    cbn. setoid_rewrite interp_state_bind. repeat rewrite bind_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v2] [Hσ' Hv]; cbn in Hv; subst. cbn.
    destruct v2.
    + setoid_rewrite interp_state_ret. setoid_rewrite bind_ret_l.
      cbn. apply pi_eqit_secure_ret. constructor. split; auto.
    + setoid_rewrite interp_state_bind. setoid_rewrite bind_bind.
      eapply pi_eqit_secure_bind; eauto.
      intros [σ5 [] ] [σ6 [] ] [Hσ'' _ ]. setoid_rewrite interp_state_ret.
      setoid_rewrite bind_ret_l. cbn. apply pi_eqit_secure_ret.
      constructor; split; auto.
    + split; auto.
  - exfalso. apply H1.
    eapply leq_trans_lat with (l2 := join le lexn); eauto.
    apply leq_join_l; auto.
    eapply leq_trans_lat; try apply leq_join_r; auto. eauto.
  - case_leq pc observer.
    + left; auto. intros σ1 σ2 Hσ.
      specialize (pi_eqit_secure_while_ret_aux e s observer H0) as Hwhile.
      eapply pi_sem_stmt_ret_aux; eauto.
    + right; auto. cbn. do 2 red. intros. eapply pi_eqit_secure_while_ret_aux; eauto.
  - case_leq pc observer.
    + left; auto. intros σ1 σ2 Hσ.
      specialize (pi_eqit_secure_while_ret_aux e s observer H0) as Hwhile.
      eapply pi_sem_stmt_ret_aux; eauto.
    + right; auto. cbn. do 2 red. intros. eapply pi_eqit_secure_while_ret_aux; eauto.
Qed.

Lemma while_well_typed_correct' e le pc lexn s :
  secure_expr le e -> secure_throw_stmt (join pc (join le lexn)) lexn s -> secure_throw_stmt pc lexn (While e s).
Proof.
  intros He Hs observer.
  specialize (He observer). specialize (Hs observer).
  inv Hs; inv He.
  - left. eapply leq_trans_lat; try apply H; auto. apply leq_join_l; auto.
    do 2 red. intros σ1 σ2 Hσ. unfold sem_throw_stmt, interp_imp. cbn.
    setoid_rewrite throw_prefix_iter.
    specialize (@interp_state_iter') as Hisi. red in Hisi. setoid_rewrite Hisi.
    eapply secure_eqit_iter with (RA := product_rel (labelled_equiv Γ observer) eq ); auto.
    intros [σ3 [] ] [σ4 [] ] [Hσ' _ ]. cbn. setoid_rewrite throw_prefix_bind.
    repeat setoid_rewrite interp_state_bind. repeat rewrite bind_bind.
    setoid_rewrite throw_prefix_denote_expr. setoid_rewrite interp_state_bind.
    setoid_rewrite bind_bind.
    eapply pi_eqit_secure_bind; eauto. intros [σ5 v1] [σ6 v2] [Hσ'' Hv]; cbn in Hv; subst.
    setoid_rewrite interp_state_ret. setoid_rewrite bind_ret_l. cbn.
    destruct v2; cbn.
    + setoid_rewrite throw_prefix_ret. tau_steps.
      apply pi_eqit_secure_ret. constructor. split; auto. constructor.
    + setoid_rewrite throw_prefix_bind. setoid_rewrite interp_state_bind.
      setoid_rewrite bind_bind.
      eapply pi_eqit_secure_bind; eauto.
      intros [σ7 r1] [σ8 r2] [Hσ''' Hr]. cbn in Hr. inv Hr.
      * setoid_rewrite throw_prefix_ret. tau_steps.
        apply pi_eqit_secure_ret. constructor. split; auto.
      * tau_steps. apply pi_eqit_secure_ret. constructor. split; auto.
        constructor; auto.
      * exfalso. apply H4.
        eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; try apply H; auto.
        eapply leq_trans_lat with (l2 := join le lexn); eauto.
        apply leq_join_r; auto. apply leq_join_r; auto.
      * exfalso.  apply H4.
        eapply leq_trans_lat; eauto.
        eapply leq_trans_lat; try apply H; auto.
        eapply leq_trans_lat with (l2 := join le lexn); eauto.
        apply leq_join_r; auto. apply leq_join_r; auto.
    + split; auto.
  - exfalso. apply H1. eapply leq_trans_lat; eauto.
    eapply leq_trans_lat with (l2 := join le lexn); auto.
    apply leq_join_l; auto. apply leq_join_r; auto.
  - case_leq pc observer.
    + left; auto. intros σ1 σ2 Hσ.
      specialize (pi_eqit_secure_while_ret_throw_aux e s observer) as Hwhile.
      eapply pi_sem_throw_stmt_ret_aux; eauto.
    + right; auto. cbn. intros σ1 σ2 Hσ.
      eapply pi_eqit_secure_while_ret_throw_aux; eauto.
  - case_leq pc observer.
    + left; auto. intros σ1 σ2 Hσ.
      specialize (pi_eqit_secure_while_ret_throw_aux e s observer) as Hwhile.
      eapply pi_sem_throw_stmt_ret_aux; eauto.
    + right; auto. cbn. intros σ1 σ2 Hσ.
      eapply pi_eqit_secure_while_ret_throw_aux; eauto.
Qed.

Lemma if_well_typed_correct e le pc lexn1 lexn2 s1 s2 :
  secure_expr le e -> secure_stmt (join pc le) lexn1 s1 ->
  secure_stmt (join pc le) lexn2 s2 ->
  secure_stmt pc (join lexn1 lexn2) (If e s1 s2).
Proof.
  intros He Hs1 Hs2 observer.
  specialize (Hs1 observer). specialize (Hs2 observer).
  specialize (He observer).
  inv Hs1; inv Hs2; inv He; try contradiction.
  - left; auto. eapply leq_trans_lat with (l2 := join pc le);  eauto.
    apply leq_join_l; auto.
    intros σ1 σ2 Hσ. unfold sem_stmt, interp_imp.
    cbn. setoid_rewrite interp_state_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v2] [Hσ' Hv]; cbn in Hv; subst.
    destruct v2; cbn; eauto.
  - exfalso. apply H3. eapply leq_trans_lat; eauto.
    apply leq_join_r; auto.
  - right. intro. apply H. apply leq_join_lub; auto.
    intros σ1 σ2 Hσ. unfold sem_stmt, interp_imp. cbn.
    setoid_rewrite interp_state_bind.
    specialize (expr_only_ret' Labels e σ1) as [n Hn]. setoid_rewrite Hn.
    rewrite bind_ret_l. destruct n; cbn in *; eauto.
  - case_leq pc observer.
    + left; auto. intros σ1 σ2 Hσ. unfold sem_stmt, interp_imp. cbn.
      setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      specialize (expr_only_ret' Labels e σ2) as [n2 Hn2]. setoid_rewrite Hn2.
      setoid_rewrite bind_ret_l.
      destruct n1; destruct n2; cbn;
        eapply pi_sem_stmt_ret_aux; eauto.
    + right; auto.
      intros σ1 σ2 Hσ. unfold sem_stmt, interp_imp. cbn.
      setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      rewrite bind_ret_l. destruct n1; cbn in *; eauto.
Qed.

Lemma if_well_typed_correct' e le pc lexn1 lexn2 s1 s2 :
  secure_expr le e -> secure_throw_stmt (join pc le) lexn1 s1 ->
  secure_throw_stmt (join pc le) lexn2 s2 ->
  secure_throw_stmt pc (join lexn1 lexn2) (If e s1 s2).
Proof.
  intros He Hs1 Hs2 observer.
  specialize (Hs1 observer). specialize (Hs2 observer).
  specialize (He observer).
  inv Hs1; inv Hs2; inv He; try contradiction.
  - left; auto. eapply leq_trans_lat with (l2 := join pc le);  eauto.
    apply leq_join_l; auto.
    unfold sem_throw_stmt, interp_imp. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite throw_prefix_bind.
    rewrite throw_prefix_denote_expr.
    repeat setoid_rewrite interp_state_bind.
    repeat setoid_rewrite bind_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v2] [Hσ' Hv]; cbn in Hv; subst.
    setoid_rewrite interp_state_ret. setoid_rewrite bind_ret_l.
    cbn. destruct v2; eauto.
    eapply lower_lexn_sound; eauto. apply leq_join_r; auto.
    eapply lower_lexn_sound; eauto. apply leq_join_l; auto.
  - exfalso. apply H3. eapply leq_trans_lat; eauto. apply leq_join_r; auto.
  - right. intro. apply H.
    apply leq_join_lub; auto.
    intros σ1 σ2 Hσ. unfold sem_throw_stmt, interp_imp.
    cbn. setoid_rewrite throw_prefix_bind.
    setoid_rewrite throw_prefix_denote_expr.
    repeat rewrite interp_state_bind. repeat rewrite bind_bind.
    specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
    rewrite bind_ret_l. rewrite interp_state_ret, bind_ret_l.
    cbn.
    destruct n1; cbn in *; eapply lower_lexn_sound'; eauto.
    apply leq_join_r; auto. apply leq_join_l; auto.
  - case_leq pc observer.
    + left; auto. intros σ1 σ2 Hσ. unfold sem_throw_stmt, interp_imp.
      cbn. setoid_rewrite throw_prefix_bind. setoid_rewrite interp_state_bind.
      setoid_rewrite throw_prefix_denote_expr. setoid_rewrite interp_state_bind.
      repeat rewrite bind_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      specialize (expr_only_ret' Labels e σ2) as [n2 Hn2]. setoid_rewrite Hn2.
      setoid_rewrite bind_ret_l. setoid_rewrite interp_state_ret.
      setoid_rewrite bind_ret_l. cbn.
      assert (label_state_pi_sec_eutt Γ observer
         (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer (join lexn1 lexn2) sum)
         (sem_throw_stmt s1) (ret tt)).
      { do 2 red. intros. eapply lower_lexn_sound'; eauto. apply leq_join_l; auto. }
      assert (label_state_pi_sec_eutt Γ observer
         (fun (sum : unit + label) (_ : unit) => Rsense_unpriv observer (join lexn1 lexn2) sum)
         (sem_throw_stmt s2) (ret tt)).
      { do 2 red. intros. eapply lower_lexn_sound'; eauto. apply leq_join_r; auto. }
      destruct n1; destruct n2; cbn in *; try eapply pi_sem_throw_stmt_ret_aux; eauto.
   + right; auto.
     intros σ1 σ2 Hσ. unfold sem_throw_stmt, interp_imp. cbn.
     setoid_rewrite throw_prefix_bind. setoid_rewrite throw_prefix_denote_expr.
     repeat rewrite interp_state_bind. repeat rewrite bind_bind.
     specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
     rewrite bind_ret_l. rewrite interp_state_ret, bind_ret_l. cbn.
     destruct n1; try eapply lower_lexn_sound'; cbn in *; eauto.
     apply leq_join_r; auto. apply leq_join_l; auto.
Qed.

Lemma secure_expr_upward_close
     : forall (e : expr) (l1 l2 : L),
       leq l1 l2 -> secure_expr l1 e -> secure_expr l2 e.
Proof.
  intros e l1 l2 Hl He observer.
  specialize (He observer). inv He.
  - case_leq l2 observer.
    + left; auto.
    + right; auto.
      exists 0. do 2 red. intros. cbn.
      specialize (expr_only_ret' Labels e σ1) as [n Hn]. rewrite Hn.
      apply pi_eqit_secure_ret. split; auto. cbv. auto.
  - case_leq l2 observer.
    + left; auto. exfalso. apply H. eapply leq_trans_lat; eauto.
    + right; auto.
Qed.

Lemma assign_well_typed_correct e le pc x :
  secure_expr le e -> leq (join le pc) (Γ x) ->
  secure_stmt pc bot (Assign x e).
Proof.
  intros Hle Hx.
  assert (Hpc : leq pc (Γ x) ).
  { eapply leq_trans_lat; eauto. apply leq_join_r; auto. }
  assert (Hl : leq le (Γ x) ).
  { eapply leq_trans_lat; try apply H5; auto. apply leq_join_l; auto. eauto. }
  assert (He : secure_expr (Γ x) e ).
  { eapply secure_expr_upward_close with (l2:= Γ x); eauto. }
  intros observer.
  specialize ( He observer). inv He.
  - left. eapply leq_trans_lat; eauto.
    do 2 red in H0. do 2 red. intros. unfold sem_stmt.
    cbn. unfold interp_imp.
    setoid_rewrite interp_state_bind. eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v2] [Hσ Hv]; cbn in Hv; subst.
    setoid_rewrite interp_state_trigger. cbn. apply pi_eqit_secure_ret.
    split; auto. cbn. eapply update_labelled_equiv_visible; auto.
  - case_leq pc observer.
    + left; auto.
      destruct H0 as [n Hn]. unfold sem_stmt.
      cbn. unfold interp_imp. do 2 red. intros. setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      specialize (expr_only_ret' Labels e σ2) as [n2 Hn2]. setoid_rewrite Hn2.
      setoid_rewrite bind_ret_l. cbn. setoid_rewrite interp_state_trigger.
      cbn. apply pi_eqit_secure_ret. split; auto.
      cbn. apply update_labelled_equiv_invisible; auto. symmetry.
      apply update_labelled_equiv_invisible; auto. symmetry; auto.
    + right; auto.
      unfold sem_stmt, interp_imp. cbn. intros σ1 σ2 Hσ.
      setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      rewrite bind_ret_l. setoid_rewrite interp_state_trigger.
      cbn. apply pi_eqit_secure_ret.
      split. 2 : cbv; auto. cbn. apply update_labelled_equiv_invisible; auto.
Qed.

Lemma assign_well_typed_correct' e le pc x :
  secure_expr le e -> leq (join le pc) (Γ x) ->
  secure_throw_stmt pc bot (Assign x e).
Proof.
  intros Hle Hx.
  assert (Hpc : leq pc (Γ x) ).
  { eapply leq_trans_lat; eauto. apply leq_join_r; auto. }
  assert (Hl : leq le (Γ x) ).
  { eapply leq_trans_lat; try apply H5; auto. apply leq_join_l; auto. eauto. }
  assert (He : secure_expr (Γ x) e ).
  { eapply secure_expr_upward_close with (l2:= Γ x); eauto. }
  intros observer.
  specialize ( He observer). inv He.
  - left. eapply leq_trans_lat; eauto.
    do 2 red in H0. do 2 red. intros. unfold sem_throw_stmt.
    cbn. unfold interp_imp. setoid_rewrite throw_prefix_bind.
    setoid_rewrite throw_prefix_denote_expr.
    setoid_rewrite interp_state_bind.
    setoid_rewrite interp_state_bind. repeat rewrite bind_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v2] [Hσ Hv]; cbn in Hv; subst.
    setoid_rewrite interp_state_ret. setoid_rewrite bind_ret_l. cbn.
    setoid_rewrite throw_prefix_ev.
    setoid_rewrite interp_state_vis. cbn.
    setoid_rewrite bind_ret_l. tau_steps.
    apply pi_eqit_secure_ret.
    split; auto. cbn. eapply update_labelled_equiv_visible; auto.
    constructor.
  - case_leq pc observer.
    + left; auto.
      destruct H0 as [n Hn]. unfold sem_throw_stmt.
      cbn. unfold interp_imp. do 2 red. intros.
      setoid_rewrite throw_prefix_bind. setoid_rewrite throw_prefix_denote_expr.
      repeat setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      specialize (expr_only_ret' Labels e σ2) as [n2 Hn2]. setoid_rewrite Hn2.
      repeat rewrite bind_ret_l. tau_steps.
      apply pi_eqit_secure_ret. split; auto.
      cbn. apply update_labelled_equiv_invisible; auto. symmetry.
      apply update_labelled_equiv_invisible; auto. symmetry; auto.
      constructor.
    + right; auto.
      unfold sem_throw_stmt, interp_imp. cbn. intros σ1 σ2 Hσ.
      setoid_rewrite throw_prefix_bind.
      setoid_rewrite interp_state_bind. rewrite throw_prefix_denote_expr.
      setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      tau_steps.
      apply pi_eqit_secure_ret.
      split. 2 : constructor. cbn. apply update_labelled_equiv_invisible; auto.
Qed.

Lemma print_well_typed_correct pc le lp e :
  secure_expr le e -> leq (join le pc) lp ->
  secure_stmt pc bot (Output lp e).
Proof.
  intros He0 Hle1.
  assert (Hle : leq le lp).
  { eapply leq_trans_lat; eauto. apply leq_join_l; auto. }
  assert (Hpc : leq pc lp).
  { eapply leq_trans_lat; try apply H5; auto. apply leq_join_r; eauto. eauto.  }
  assert (He : secure_expr lp e ).
  { eapply secure_expr_upward_close with (l1 := le); eauto. }
  intros observer. specialize (He observer).
  inv He.
  - left. eapply leq_trans_lat; eauto.
    unfold sem_stmt, interp_imp. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite interp_state_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v4] [Hσ' Hv]; cbn in Hv; subst.
    cbn. setoid_rewrite interp_state_trigger. cbn.
    setoid_rewrite bind_trigger. apply pi_eqit_secure_pub_vis.
    auto. intros []. apply pi_eqit_secure_ret. split; auto.
  - case_leq pc observer.
    + left; auto. unfold sem_stmt, interp_imp. intros σ1 σ2 Hσ.
      cbn. setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      specialize (expr_only_ret' Labels e σ2) as [n2 Hn2]. setoid_rewrite Hn2.
      setoid_rewrite bind_ret_l. setoid_rewrite interp_state_trigger.
      cbn. setoid_rewrite bind_trigger. apply pi_eqit_secure_priv_vislr; auto.
      intros [] []. apply pi_eqit_secure_ret. split; auto.
    + right; auto. unfold sem_stmt, interp_imp. intros σ1 σ2 Hσ.
      cbn. setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      rewrite bind_ret_l. rewrite interp_state_trigger. cbn. rewrite bind_trigger.
      apply pi_eqit_secure_priv_visl; auto. intros [].
      apply pi_eqit_secure_ret. split; auto. cbv. auto.
Qed.

Lemma print_well_typed_correct' pc le lp e :
  secure_expr le e -> leq (join le pc) lp ->
  secure_throw_stmt pc bot (Output lp e).
Proof.
  intros He0 Hle1.
  assert (Hle : leq le lp).
  { eapply leq_trans_lat; eauto. apply leq_join_l; auto. }
  assert (Hpc : leq pc lp).
  { eapply leq_trans_lat; try apply H5; auto. apply leq_join_r; eauto. eauto.  }
  assert (He : secure_expr lp e ).
  { eapply secure_expr_upward_close with (l1 := le); eauto. }
  intros observer. specialize (He observer).
  inv He.
  - left. eapply leq_trans_lat; eauto.
    unfold sem_throw_stmt, interp_imp. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite throw_prefix_bind. setoid_rewrite interp_state_bind.
    setoid_rewrite throw_prefix_denote_expr. setoid_rewrite interp_state_bind.
    repeat rewrite bind_bind.
    eapply pi_eqit_secure_bind; eauto.
    intros [σ3 v1] [σ4 v4] [Hσ' Hv]; cbn in Hv; subst.
    setoid_rewrite interp_state_ret. setoid_rewrite bind_ret_l.
    cbn. setoid_rewrite throw_prefix_ev. setoid_rewrite interp_state_vis.
    cbn. setoid_rewrite bind_trigger. setoid_rewrite bind_vis.
    apply pi_eqit_secure_pub_vis; auto. intros [].
    setoid_rewrite bind_ret_l. setoid_rewrite throw_prefix_ret.
    tau_steps. apply pi_eqit_secure_ret. split; auto; constructor.
  - case_leq pc observer.
    + left; auto. unfold sem_throw_stmt, interp_imp. intros σ1 σ2 Hσ.
      cbn. setoid_rewrite throw_prefix_bind.
      setoid_rewrite throw_prefix_denote_expr.
      repeat setoid_rewrite interp_state_bind.
      repeat rewrite bind_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      specialize (expr_only_ret' Labels e σ2) as [n2 Hn2]. setoid_rewrite Hn2.
      setoid_rewrite bind_ret_l.
      setoid_rewrite interp_state_ret. setoid_rewrite bind_ret_l. cbn.
      setoid_rewrite throw_prefix_ev.
      setoid_rewrite interp_state_vis.
      cbn. setoid_rewrite bind_trigger.
      setoid_rewrite bind_vis.
      apply pi_eqit_secure_priv_vislr; auto.
      intros [] []. tau_steps. apply pi_eqit_secure_ret. split; auto. constructor.
    + right; auto. unfold sem_throw_stmt, interp_imp. intros σ1 σ2 Hσ.
      cbn.
      setoid_rewrite throw_prefix_bind. setoid_rewrite interp_state_bind.
      setoid_rewrite throw_prefix_denote_expr.
      setoid_rewrite interp_state_bind.
      specialize (expr_only_ret' Labels e σ1) as [n1 Hn1]. setoid_rewrite Hn1.
      repeat rewrite bind_ret_l.
      rewrite interp_state_ret. rewrite bind_ret_l. cbn.
      setoid_rewrite throw_prefix_ev.
      rewrite interp_state_vis. cbn. rewrite bind_trigger.
      rewrite bind_vis.
      apply pi_eqit_secure_priv_visl; auto. intros [].
      tau_steps.
      apply pi_eqit_secure_ret. split; auto. cbv. constructor.
Qed.

Lemma skip_well_typed_correct pc :
  secure_stmt pc bot Skip.
Proof.
  intros observer. case_leq pc observer.
  - left; auto. do 2 red. unfold sem_stmt. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret.
    split; auto.
  - right; auto. do 2 red. unfold sem_stmt. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret.
    split; auto. cbv. auto.
Qed.

Lemma skip_well_typed_correct' pc :
  secure_throw_stmt pc bot Skip.
Proof.
  intros observer. case_leq pc observer.
  - left; auto. do 2 red. unfold sem_throw_stmt. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite throw_prefix_ret.
    setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret.
    split; auto. constructor.
  - right; auto. do 2 red. unfold sem_throw_stmt. intros σ1 σ2 Hσ.
    cbn. setoid_rewrite throw_prefix_ret.
    setoid_rewrite interp_state_ret. apply pi_eqit_secure_ret.
    split; auto. constructor.
Qed.

Lemma raise_well_typed pc lexn :
  leq pc lexn -> secure_stmt pc lexn (Raise lexn).
Proof.
  intros Hpc observer. case_leq pc observer.
  - left; auto. unfold sem_stmt, interp_imp. do 2 red. intros.
    cbn. setoid_rewrite bind_trigger. setoid_rewrite interp_state_vis.
    cbn. setoid_rewrite bind_trigger. setoid_rewrite bind_vis.
    case_leq lexn observer.
    + apply pi_eqit_secure_pub_vis. auto. intros [].
    + apply pi_eqit_secure_priv_vislr; auto. intros [].
  - right; auto. unfold sem_stmt, interp_imp. do 2 red. intros.
    cbn. setoid_rewrite bind_trigger. setoid_rewrite interp_state_vis.
    cbn. setoid_rewrite bind_trigger. setoid_rewrite bind_vis.
    apply pi_eqit_secure_priv_visl. 2 : intros []. intro.
    apply Hnleq. eapply leq_trans_lat; eauto.
Qed.

Lemma raise_well_typed' pc lexn :
  leq pc lexn -> secure_throw_stmt pc lexn (Raise lexn).
Proof.
  intros Hpc observer. case_leq pc observer.
  - left; auto. unfold sem_throw_stmt, interp_imp.
    cbn. do 2 red. intros. setoid_rewrite bind_trigger.
    setoid_rewrite throw_prefix_exc. setoid_rewrite interp_state_ret.
    apply pi_eqit_secure_ret; auto. split; auto. constructor.
    all : apply leq_refl_lat; auto.
  - right; auto. do 2 red. intros. unfold sem_throw_stmt, interp_imp.
    cbn. setoid_rewrite bind_trigger.
    setoid_rewrite throw_prefix_exc. setoid_rewrite interp_state_ret.
    apply pi_eqit_secure_ret. split; auto.
    constructor. 2 : apply leq_refl_lat; auto.
    intro.
    apply Hnleq. eapply leq_trans_lat; eauto.
Qed.

Definition well_typed_expr := LabelledImpTypes.well_typed_expr Labels Γ.

(* rework this definition to have only public exceptions*)
Inductive well_typed_stmt : label -> label -> stmt Labels -> Prop :=
  | wts_manual pc lexn s : secure_stmt pc lexn s /\ secure_throw_stmt pc lexn s -> well_typed_stmt pc lexn s
  | wts_skip pc : well_typed_stmt pc bot Skip
  | wts_seq pc lexn1 lexn2 s1 s2 : well_typed_stmt pc lexn1 s1 -> well_typed_stmt (join pc lexn1) lexn2 s2 ->
                                   well_typed_stmt pc (join lexn1 lexn2) (Seq s1 s2)
  | wts_assign pc l x e : well_typed_expr l e -> leq (join l pc) (Γ x) ->
                          well_typed_stmt pc bot (Assign x e)
  | wts_print pc le lp e : well_typed_expr le e -> leq (join le pc) lp ->
                           well_typed_stmt pc bot (Output lp e)
  | wts_if pc le e lexn1 lexn2 s1 s2 : well_typed_expr le e -> well_typed_stmt (join pc le) lexn1 s1 -> well_typed_stmt (join pc le) lexn2 s2 ->
                                       well_typed_stmt pc (join lexn1 lexn2) (If e s1 s2)
  | wts_while e le pc lexn s : well_typed_expr le e -> well_typed_stmt (join pc (join le lexn)) lexn s ->
                         well_typed_stmt pc lexn (While e s)
  | wts_raise pc lexn : leq pc lexn -> well_typed_stmt pc lexn (Raise lexn)
  | wts_try pc lexn1 lexn2 s1 s2 : well_typed_stmt pc lexn1 s1 -> well_typed_stmt (join pc lexn1) lexn2 s2 ->
                                   well_typed_stmt pc lexn2 (TryCatch s1 s2)
.

Lemma well_typed_expr_correct e l :
  well_typed_expr l e -> secure_expr l e.
Proof.
  intros He observer.
  apply well_typed_expr_correct in He; auto.
  specialize (He observer). inv He.
  - left; auto. do 2 red. intros. eapply eqit_secure_imp_pi_eqit_scure; eauto.
  - right; auto. destruct H0 as [n Hn]. exists n.
    do 2 red. intros. eapply eqit_secure_imp_pi_eqit_scure; eauto.
Qed.

Lemma well_typed_stmt_sound s pc lexn : well_typed_stmt s pc lexn -> secure_stmt s pc lexn.
Proof.
  intros Htype. enough (secure_stmt s pc lexn /\ secure_throw_stmt s pc lexn); try tauto.
  induction Htype; eauto.
  - (* Skip *) split; try apply skip_well_typed_correct; try apply skip_well_typed_correct'.
  - (* Seq *)
    split; try apply seq_well_typed_correct; try apply seq_well_typed_correct'; tauto.
  - (* Assign *)
    split; try eapply assign_well_typed_correct; try eapply assign_well_typed_correct';
      try apply well_typed_expr_correct; eauto.
  - (* Output *)
    split; try eapply print_well_typed_correct; try eapply print_well_typed_correct';
      try apply well_typed_expr_correct; eauto.
  - (* If *)
    apply well_typed_expr_correct in H.
    split; try eapply if_well_typed_correct; try eapply if_well_typed_correct'; eauto; try tauto.
  - (* While *)
    destruct IHHtype. apply well_typed_expr_correct in H.
    split; try eapply while_well_typed_correct; try eapply while_well_typed_correct'; eauto.
  - (* Raise *)
    split; try eapply raise_well_typed; try eapply raise_well_typed'; eauto.
  - (* TryCatch *)
    destruct IHHtype1. destruct IHHtype2.
    split; try eapply try_catch_well_typed_correct; try eapply try_catch_well_typed_correct'; eauto.
Qed.

Lemma secure_stmt_lower_pc:
  forall (pc2 : label) lexn (s : stmt Labels),
    secure_stmt pc2 lexn s -> forall pc1 : L, leq pc1 pc2 -> secure_stmt pc1 lexn s.
Proof.
  intros pc2 lexn s H pc1 Hpc observer.
  specialize (H observer). inv H.
  - left. eapply leq_trans_lat; eauto. auto.
  - case_leq pc1 observer.
    + left; auto. cbn in H1. intros σ1 σ2 Hσ.
      eapply pi_sem_stmt_ret_aux; eauto.
    + right; auto.
Qed.

Lemma secure_throw_stmt_lower_pc:
  forall (pc lexn : label) (s : stmt Labels),
    secure_throw_stmt pc lexn s -> forall pc1 : L, leq pc1 pc -> secure_throw_stmt pc1 lexn s.
Proof.
  intros pc lexn s H pc1 Hpc observer.
  specialize (H observer). inv H.
  - left. eapply leq_trans_lat; eauto. auto.
  - case_leq pc1 observer.
    + left; auto. cbn in H1. intros σ1 σ2 Hσ.
      eapply pi_sem_throw_stmt_ret_aux; eauto.
    + right; auto.
Qed.
(* Would need to make annoying changes to type system for this to technically hold
Lemma lower_pc_sound s lexn pc1 pc2 :
  leq pc1 pc2 -> well_typed_stmt pc2 lexn s -> well_typed_stmt pc1 lexn s.
Proof.
  intros Hpc Hs. generalize dependent pc1. induction Hs; intros.
  - constructor. destruct H. split. eapply secure_stmt_lower_pc; eauto.
    eapply secure_throw_stmt_lower_pc; eauto.
  - apply wts_skip.
  - apply wts_seq; eauto. eapply IHHs2.
    destruct pc1; destruct pc; destruct lexn1; cbv; auto; try contradiction.
  - eapply wts_assign; eauto. eapply leq_trans_lat; eauto.
    destruct l; destruct pc; destruct pc1; cbv; auto; contradiction.
  - eapply wts_print; eauto. eapply leq_trans_lat; eauto.
    destruct le; destruct pc; destruct pc1; cbv; auto; contradiction.
  - eapply wts_if; eauto. eapply IHHs1. 2: eapply IHHs2.
    all :  destruct le; destruct pc; destruct pc1; cbv; auto; contradiction.
  - eapply wts_while; eauto. eapply IHHs.
    destruct le; destruct pc; destruct pc1; destruct lexn; cbv; auto; contradiction.
  - apply wts_raise. eapply leq_trans_lat; eauto.
  - eapply wts_try; eauto. eapply IHHs2.
    destruct pc; destruct pc1; destruct lexn1; cbv; auto; contradiction.
Qed.
*)
End LabelledImpTypesProgInsens.


(*
 * Coq code for "Using XCAP to Certify Realistic System Code: Machine Context Management"
 *
 * PropX lemma library (independent of XCAP meta theory)
 *
 * (for Coq version 8.0pl2)
 *)

Require Import ZArith.
Require Import Eqdep.
Require Import Mapt.
Require Import axiom.
Require Import tm.
Require Import tylist.
Require Import mathlib.
Require Import propx.

Lemma disj_update_disj :
  forall h1 h2 l w, Map.disjoint h1 h2 -> Map.in_dom h1 l ->
                              Map.disjoint (updH h1 l w) h2.
unfold Map.disjoint, Map.in_dom, updH. intros. generalize (H a). clear H. intro.
destruct H0. destruct (Z_eq_dec l a). intros. rewrite <- (Zeq_bool_eq_true l a e).
rewrite e in H0. rewrite H0 in H. auto.
intros. rewrite <- (Zeq_bool_neq_false l a n). auto.
Qed.

Lemma ex_eq : forall L A (p : A -> PropX L) q, p = q -> (Ex x. p x) = (Ex y. q y).
intros. rewrite H. auto.
Qed.

Lemma ex_eq_h : forall L A B (p : A -> B -> PropX L) q h, p = q -> (Ex x. p x h) = (Ex y. q y h).
intros. rewrite H. auto.
Qed.

Lemma Subst_lift_eq : forall L (p:PropX L) B (A:B->PropX L),
                         p = Subst _ B (lift _ _ p) A.
simpl. auto.
Qed.

Lemma imp_imp : forall P P' Q Q' Si,
  OK propx.nil Si (P .-> P') -> OK propx.nil Si (Q' .-> Q)
    -> OK propx.nil Si (P' .-> Q') -> OK propx.nil Si (P .-> Q).
intros.
apply ok_imp_i.
generalize (ext_env _ _ _ H1 (propx.cons P propx.nil)). clear H1.
generalize (ext_env _ _ _ H0 (propx.cons P propx.nil)). clear H0.
generalize (ext_env _ _ _ H (propx.cons P propx.nil)). clear H.
intros. apply ok_imp_e with Q'. apply ok_imp_e with P'. apply ok_imp_e with P.
apply ok_env. simpl. auto. apply H. unfold wk. intros. inversion H2.
apply H1. unfold wk. intros. inversion H2.
apply H0. unfold wk. intros. inversion H2.
Qed.

Lemma and_imp : forall P P' Q Q' Si,
  OK propx.nil Si (P .-> P') -> OK propx.nil Si (Q .-> Q')
    -> OK propx.nil Si ((P ./\ Q) .-> (P' ./\ Q')).
intros. apply ok_imp_i. apply ok_and_i.
generalize (ext_env _ _ _ H (propx.cons (P ./\ Q) propx.nil)). clear H.
intro. apply ok_imp_e with P. apply ok_and_e1 with Q. apply ok_env. simpl. auto.
apply H. unfold wk. intros. inversion H1.
generalize (ext_env _ _ _ H0 (propx.cons (P ./\ Q) propx.nil)). clear H0.
intro. apply ok_imp_e with Q. apply ok_and_e2 with P. apply ok_env. simpl. auto.
apply H0. unfold wk. intros. inversion H1.
Qed.

Lemma imp_ext : forall A P Q Si,
  (exists x:A, OK propx.nil Si (P .-> Q x)) -> OK propx.nil Si (P .-> Ex x. Q x).
intros. destruct H. apply ok_imp_i. apply ok_extx_i with x.
generalize (ext_env _ _ _ H (propx.cons P propx.nil)). clear H.
intros. apply ok_imp_e with P. apply ok_env. simpl. auto.
apply H. unfold wk. intros. inversion H0.
Qed.

Lemma shift_extx_unfold : forall L L' B A P,
  Shift L L' (extx _ A P) B = (extx _ _ (fun x => Shift L L' (P x) B)).
intro. simpl. auto.
Qed.

Lemma extx_eq : forall L A P Q,
  P = Q -> extx L A P = extx _ _ Q.
intros. rewrite H. auto.
Qed.

Lemma extv_eq : forall L A P Q,
  P = Q -> extv L A P = extv _ _ Q.
intros. rewrite H. auto.
Qed.

Lemma subst_and_unfold : forall L B (A : B -> PropX L) a a',
  Subst L B (a ./\ a') A = (Subst L B a A) ./\ (Subst L B a' A).
intros. simpl. auto.
Qed.
Implicit Arguments subst_and_unfold [L].

Lemma shift_and_unfold : forall L L' B a a',
  Shift L L' (a ./\ a') B = (Shift L L' a B) ./\ (Shift L L' a' B).
intros. simpl. auto.
Qed.

Lemma ext_imp : forall A B P Q Si,
  (forall x:A, exists y:B, OK propx.nil Si (P x.-> Q y))
                 -> OK propx.nil Si ((Ex x. P x) .-> Ex y. Q y).
intros.
apply ok_imp_i. apply ok_extx_e with A P. apply ok_env; simpl; left; auto.
rewrite (ext_eq _ _ P (fun x => P x)); auto.
intros. destruct (H B0).
existsx x.
apply ok_imp_e with (P B0).
apply ok_env; simpl; left; auto.
apply ext_env with propx.nil; auto.
unfold wk. intros. inversion H1.
Qed.

Lemma and_imp_sym : forall P Q Si,
             OK propx.nil Si ((P ./\ Q) .-> (Q ./\ P)).
intros. apply ok_imp_i. apply ok_and_i.
apply ok_and_e2 with P; apply ok_env; left; auto.
apply ok_and_e1 with Q; apply ok_env; left; auto.
Qed.

Lemma shift_let_unfold : forall L L' B X Y (c:prod X Y) XX (s:XX) p,
  Shift L L' (let (a,b):=c in p a b s) B =
              let (a,b):=c in Shift L L' (p a b s) B.
intros. destruct c. auto.
Qed.

Lemma shift_let_unfold_fun : forall L L' B X Y (c:prod X Y) XX p,
  (fun s : XX => Shift L L' (let (a,b):=c in p a b s) B) =
              fun s => let (a,b):=c in Shift L L' (p a b s) B.
intros. apply ext_eq. intros. destruct c. auto.
Qed.

Lemma shift_subst_eq_2_fun_2 : forall L C D p B (A:B->PropX L),
 (fun x y => (p (pairT x y))) = fun (x:C) (y:D) => Subst _ B (Shift tO _ (p (pairT x y)) B) A.
intros. apply ext_eq. intro. apply ext_eq. intro.
apply shift_subst_eq.
Qed.

Lemma shift_and_unfold_fun : forall L L' T B a a',
  (fun h:T => Shift L L' (a h ./\ a' h) B) =
  (fun h:T => Shift L L' (a h) B ./\ Shift L L' (a' h) B).
intros. simpl. auto.
Qed.

Lemma subst_and_unfold_fun : forall L B (A : B -> PropX L) T a a',
  (fun h:T => Subst L B (a h ./\ a' h) A) =
  (fun h:T => Subst L B (a h) A ./\ Subst L B (a' h) A).
intros. simpl. auto.
Qed.
Implicit Arguments subst_and_unfold_fun [L].

Lemma prop_imp : forall (p q:Prop) Si,
  (p -> q)
    -> OK propx.nil Si (prop _ p .-> prop _ q).
intros. apply ok_imp_i. apply ok_prop_e with p. apply ok_env; left; auto.
intros. apply ok_prop_i. auto.
Qed.

Lemma imp_extv : forall A P (Q:PropX (tplus tO (tS A tO))) Si,
  (exists x:A->PropX _, OK propx.nil Si (P .-> (Subst _ _ Q x)))
             -> OK propx.nil Si (P .-> extv _ A Q).
intros. destruct H. apply ok_imp_i. apply ok_extv_i with x.
generalize (ext_env _ _ _ H (propx.cons P propx.nil)). clear H.
intros. apply ok_imp_e with P. apply ok_env. simpl. auto.
apply H. unfold wk. intros. inversion H0.
Qed.

Lemma imp_and : forall P Q Q' Si,
  OK propx.nil Si (P .-> Q) -> OK propx.nil Si (P .-> Q')
                            -> OK propx.nil Si (P .-> (Q ./\ Q')).
intros. apply ok_imp_i. apply ok_and_i; apply ok_imp_e with P.
apply ok_env; left; auto.
apply ext_env with propx.nil; auto. unfold wk; intros. inversion H1.
apply ok_env; left; auto.
apply ext_env with propx.nil; auto. unfold wk; intros. inversion H1.
Qed.

Lemma ext_imp' : forall Si A P Q,
  (forall (x:A), OK propx.nil Si (P x .-> Q))
  -> OK propx.nil Si ((Ex x. P x) .-> Q).
intros. apply ok_imp_i. apply ok_extx_e with A P.
apply ok_env; left; replace P with (fun x => P x); auto. apply ext_eq; auto.
intros. apply ok_imp_e with (P B). apply ok_env; left; auto.
apply ext_env with propx.nil; unfold wk; auto.
intros. right; right; auto.
Qed.

Lemma imp_cut : forall P Q R Si,
  OK propx.nil Si (P .-> Q) -> OK propx.nil Si (Q .-> R)
                            -> OK propx.nil Si (P .-> R).
intros. apply ok_imp_i. apply ok_imp_e with Q.
apply ok_imp_e with P.
apply ok_env; left; auto.
apply ext_env with propx.nil; auto. unfold wk; intros; right; auto.
apply ext_env with propx.nil; auto. unfold wk; intros; right; auto.
Qed.

Lemma and_imp' : forall Si P Q R,
  (OK propx.nil Si (Q .-> R)) -> OK propx.nil Si ((P ./\ Q) .-> R).
intros. apply ok_imp_i; apply ok_imp_e with Q.
apply ok_and_e2 with P. apply ok_env; left; auto.
apply ext_env with propx.nil; auto. unfold wk. intros. right. auto.
Qed.

Lemma and_imp'' : forall Si P Q R,
  (OK propx.nil Si (P .-> R)) -> OK propx.nil Si ((P ./\ Q) .-> R).
intros. apply ok_imp_i; apply ok_imp_e with P.
apply ok_and_e1 with Q. apply ok_env; left; auto.
apply ext_env with propx.nil; auto. unfold wk. intros. right. auto.
Qed.

Lemma subst_codeptr_unfold : forall B (A : B -> PropX tO) l a,
  Subst _ B (codeptr _ l (fun s => Shift tO tO (a s) B)) A
    = codeptr _ l a.
unfold codeptr. simpl. intros.
replace (fun x =>
            Subst (tS State tO) B (Shift (tS B tO) tO (Shift tO tO (a x) B) State) (fun x0 : B => Shift tO tO (A x0) State)
             .-> var tO State x)
with (fun S => Shift tO tO (a S) State .-> var tO State S).
auto.
apply ext_eq. intro.
rewrite <- shift_subst_eq_2_1.
auto.
Qed.

Lemma shift_subst_eq_2' : forall L (p:PropX L) A (B:A -> PropX _) C (D:C -> PropX _),
     p = Subst L A (Subst (tS A L) C (Shift (tS C tO) L (Shift tO L p C) A) D) B.
induction p; simpl; auto; intros.
apply (f_equal (fun p => cptr L w p)); apply ext_eq; auto.
rewrite <- IHp1; rewrite <- IHp2; auto.
rewrite <- IHp1; rewrite <- IHp2; auto.
rewrite <- IHp1; rewrite <- IHp2; auto.
apply (f_equal (fun p => allx L A p)); apply ext_eq; auto.
apply (f_equal (fun p => extx L A p)); apply ext_eq; auto.
rewrite <- IHp; auto.
rewrite <- IHp; auto.
apply (f_equal (fun p => mu L A p a)); apply ext_eq; auto.
Qed.

Lemma shift_subst_eq_2_fun' : forall T L (p:T->PropX L) A (B:A -> PropX _) C (D:C -> PropX _),
     p = fun x => Subst L A (Subst (tS A L) C (Shift (tS C tO) L (Shift tO L (p x) C) A) D) B.
intros. apply ext_eq. intro. apply shift_subst_eq_2'.
Qed.

Lemma ext_imp1 : forall A B P Q Si,
  (forall x:A, exists y:B, OK propx.nil Si (P x.-> Q y))
                 -> OK propx.nil Si ((extx tO A P) .-> extx tO B Q).
intros.
apply ok_imp_i. apply ok_extx_e with A P. apply ok_env; simpl; left; auto.
rewrite (ext_eq _ _ P (fun x => P x)); auto.
intros. destruct (H B0).
existsx x.
apply ok_imp_e with (P B0).
apply ok_env; simpl; left; auto.
apply ext_env with propx.nil; auto.
unfold wk. intros. inversion H1.
Qed.


(*

  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 ComponentSM.

Section ComponentSMExample1.

  Definition def_nat : nat := 0.

  Definition CIOnat : ComponentIO :=
    MkComponentIO nat nat def_nat.

  Instance funIOnat : funIO := MkFunIO (fun _ => CIOnat).

  Definition m_counter_update : M_Update 0 "A" nat :=
    fun (s : nat) i =>
      ret _ (Some (s + i), s + i).

  Definition A : M_StateMachine 1 "A" :=
    build_m_sm m_counter_update 0.

  Definition B_update : M_Update 1 "B" nat :=
    fun s i =>
      (call_proc "A" i)
        >>= fun out =>
      ret _ (Some (s + out + 1), s + out + 1).

  Definition B : M_StateMachine 2 "B" :=
    build_m_sm B_update 0.

  Definition C_update : M_Update 2 "C" nat :=
    fun s i =>
      (call_proc "B" i)
        >>= fun out1 =>
      (call_proc "B" i)
        >>= fun out2 =>
      ret _ (Some (s + out1 + out2 + 2), s + out1 + out2 + 2).

  Definition C : M_StateMachine 3 "C" :=
    build_m_sm C_update 0.

  Definition M_update : M_Update 3 "M" unit :=
    fun s i =>
      (call_proc "C" i)
        >>= (fun out => ret _ (Some s, out)).

  Definition M : M_StateMachine 4 "M" :=
    build_m_sm M_update tt.

  Definition progs : n_procs 3 :=
    [existT _ "A" (incr_n_proc (incr_n_proc A)),
     existT _ "B" (incr_n_proc B),
     existT _ "C" C].

  Eval compute in (snd (run_n_proc M [17] progs)).

  Definition ls :=
    MkLocalSystem
      3
      (existT _ "M" M)
      [existT _ "A" (incr_n_proc (incr_n_proc A)),
       existT _ "B" (incr_n_proc B),
       existT _ "C" C].

  Eval compute in (snd (run_local_system ls [17,33,2])).

End ComponentSMExample1.


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

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************)
(*           The Calculus of Inductive Constructions            *)
(*                       COQ v5.10                              *)
(*                                                              *)
(* Laurent Arditi.  Laboratoire I3S. CNRS ura 1376.             *)
(* Universite de Nice - Sophia Antipolis                        *)
(* arditi@unice.fr, http://wwwi3s.unice.fr/~arditi/lolo.html    *)
(*                                                              *)
(* date: may 1995                                               *)
(* file: BV.v                                                   *)
(* contents: definition of bit-vectors using polymorphic lists  *)
(* abstraction to nat                                           *)
(****************************************************************)

(* Version AVEC les listes polymorphiques *)
(* Les operateurs instancies pour les BVs sont ceux des listes, avec le
   nom terminant par "bv". ex: nilbv, consbv...*)

Require Export Arith_compl.
Require Export Bool_compl.
Require Export Lists_replace.

(********************************************************************)
(* Instanciation des operateurs des listes polymorph(iqu)es         *)
Definition BV := list bool.
Definition nilbv : BV := nil.
Definition consbv : bool -> BV -> BV := cons (A:=bool).
Definition appbv : BV -> BV -> BV := app (A:=bool).
Definition lengthbv : BV -> nat := length (A:=bool).
Definition lenbv : BV -> nat -> Prop := len bool.
Definition BV_null (n : nat) : BV := list_const bool n false.
Definition truncbv : BV -> nat -> BV := trunc bool.
Definition stripbv : BV -> nat -> BV := strip bool.
Definition field : BV -> nat -> nat -> BV := sublist bool.
Definition abit : BV -> nat -> BV := elemlist bool.
Definition bitset : BV -> nat -> bool -> BV := replace bool.
Definition BVnot (v : BV) : BV := map bool bool v negb.
(********************************************************************)

Fixpoint BV_to_nat (v : BV) : nat :=
  match v return nat with
  | nil => 0
  | b :: w => bool_to_nat b + (BV_to_nat w + BV_to_nat w)
  end.

Lemma BV_to_nat_eq1 : BV_to_nat nilbv = 0.
auto. Qed.
Lemma BV_to_nat_eq2 :
 forall (b : bool) (w : BV),
 BV_to_nat (consbv b w) = bool_to_nat b + (BV_to_nat w + BV_to_nat w).
auto. Qed.

(* In the current version of Coq (V 5.10.14.b) it is impossible to use
recursive definitions with BV's constructors on left of "=>" as in the
following code: *)

(*Recursive Definition BV_to_nat : BV -> nat :=
     nilbv => O
   | (consbv b w) => (plus (bool_to_nat b) (plus (BV_to_nat w) (BV_to_nat w))).
*)

Lemma BV_to_nat_app :
 forall (l n : BV) (ll : nat),
 (******************)
 lenbv l ll -> BV_to_nat (appbv l n) = BV_to_nat l + power2 ll * BV_to_nat n.
unfold BV, lenbv, appbv in |- *. simple induction l. intros. inversion H. simpl in |- *. auto.
intros. simpl in |- *. inversion H0. simpl in |- *.
rewrite (H n l1). rewrite mult_plus_distr_r. repeat rewrite plus_assoc.
rewrite
 (plus_permute2 (bool_to_nat a + BV_to_nat l0) (power2 l1 * BV_to_nat n)
    (BV_to_nat l0)).
auto.
exact H4.
Qed. Hint Resolve BV_to_nat_app.

Lemma BV_to_nat_app2 :
 forall l n : BV,
 (*******************)
 BV_to_nat (appbv l n) = BV_to_nat l + power2 (lengthbv l) * BV_to_nat n.
intros. apply BV_to_nat_app. auto. unfold lenbv, lengthbv in |- *. apply len_length.
Qed. Hint Resolve BV_to_nat_app2.

Lemma BV_null_nat : forall n : nat, BV_to_nat (BV_null n) = 0.
(****************)
unfold BV_null in |- *.
simple induction n; auto.
intros. simpl in |- *. rewrite H. auto.
Qed. Hint Resolve BV_null_nat.

Lemma length_BV_null : forall n : nat, lengthbv (BV_null n) = n.
(*******************)
unfold lengthbv, BV_null in |- *. intro. apply length_list_const.
Qed. Hint Resolve length_BV_null.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Q C0 Q0 : Universe, ((wd_ P C0 /\ (wd_ P Q /\ (wd_ P Q0 /\ (wd_ A B /\ (wd_ B Q0 /\ (wd_ A Q0 /\ (wd_ C0 A /\ (wd_ C0 B /\ (wd_ Q C0 /\ (wd_ B Q /\ (wd_ A Q /\ (wd_ C D /\ (wd_ D P /\ (wd_ C P /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (col_ A B P /\ (col_ C0 C D /\ (col_ Q P Q0 /\ col_ P C0 Q0))))))))))))))))))))) -> col_ P Q C0)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.Z.Syntax.Util.
Require Import Crypto.Compilers.ZExtended.Syntax.
Require Import Crypto.Compilers.ZExtended.Syntax.Util.
Require Import Crypto.Compilers.MapBaseType.

Definition MapBaseType' {t} (e : Expr t)
  : Z.Syntax.Expr (Arrow (lift_flat_type unextend_base_type (domain t))
                         (lift_flat_type unextend_base_type (codomain t)))
  := @MapBaseType' _ _ _ _ unextend_base_type (fun _ s d opc _ => unextend_op opc)
                   (fun _ t => Op (make_const t (ZToInterp 0)) TT)
                   t e.

Definition MapBaseType {t} (e : Expr t)
  : option (Z.Syntax.Expr (Arrow (lift_flat_type unextend_base_type (domain t))
                                 (lift_flat_type unextend_base_type (codomain t))))
  := @MapBaseType _ _ _ _ unextend_base_type (fun _ s d opc _ => unextend_op opc)
                  (fun _ t => Op (make_const t (ZToInterp 0)) TT)
                  t e.


Require Import Coq.Classes.Equivalence.
Require Import Coq.Program.Program.

Ltac obligations_tactic ::= program_simpl ; simpl_relation.

Lemma bla : forall [ ! Equivalence A (eqA : relation A) ] x y, eqA x y -> eqA y x.
Proof.
  intros.
  rewrite H0.
  reflexivity.
Defined.

Lemma bla' : forall [ ! Equivalence A (eqA : relation A) ] x y, eqA x y -> eqA y x.
Proof.
  intros.
  (* Need delta on [relation] to unify with the right lemmas. *)
  rewrite <- H0.
  reflexivity.
Qed.

Axiom euclid : nat -> { x : nat | x > 0 } -> nat.

Definition eq_proj {A} {s : A -> Prop} : relation (sig s) :=
  fun x y => `x = `y.

Program Instance {A : Type} {s : A -> Prop} => Equivalence (sig s) eq_proj.

  Next Obligation.
  Proof.
    constructor ; red ; intros.
    reflexivity.
  Qed.

  Admit Obligations.

Instance Morphism (eq ==> eq_proj ==> eq) euclid.
Proof.
Admitted.

Goal forall (x : nat) (y : nat | y > 0) (z : nat | z > 0), eq_proj y z -> euclid x y = euclid x z.
Proof.
  intros.
  (* Breaks if too much delta in unification *)
  rewrite H.
  reflexivity.
Qed.


Require Export
        Coq.Lists.List
        Fiat.Common
        Fiat.Computation.Core
        Fiat.Computation.Notations
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Common.Monoid
        Fiat.Narcissus.Stores.Cache.

Set Implicit Arguments.

Section Specifications.

  Variable A : Type. (* Source Type. (in-memory data) *)
  Variable B : Type. (* Target Type. (usually ByteStrings) *)
  Context {store : Cache}. (* Store Type. *)

  (* Formats are a quaternary relation on an source value, initial store,
     target value, and final store. *)
  Definition FormatM : Type :=
    A -> CacheFormat -> Comp (B * CacheFormat).

  (* Decoders consume a target value and store and produce either
     - a source value, remaining target value, and updated store
     - or an error value, i.e. None. *)

  Definition DecodeM : Type :=
    B -> CacheDecode -> option (A * B * CacheDecode).

  Local Notation "a ∋ b" := (@computes_to _ a b) (at level 90).
  Local Notation "a ∌ b" := (~ @computes_to _ a b) (at level 90).

  Definition format_decode_correct
             (monoid : Monoid B)
             (predicate : A -> Prop)
             (format : A -> CacheFormat -> B * CacheFormat)
             (decode : B -> CacheDecode -> A * B * CacheDecode) :=
    forall env env' xenv xenv' data data' bin ext ext',
      Equiv env env' ->
      predicate data ->
      format data env = (bin, xenv) ->
      decode (mappend bin ext) env' = (data', ext', xenv') ->
      Equiv xenv xenv' /\ data = data' /\ ext = ext'.

  Definition CorrectDecoder
             (monoid : Monoid B)
             (predicate : A -> Prop)
             (rest_predicate : A -> B -> Prop)
             (format : FormatM)
             (decode : DecodeM)
             (decode_inv : CacheDecode -> Prop) :=
    (forall env env' xenv data bin ext
            (env_OK : decode_inv env'),
        Equiv env env' ->
        predicate data ->
        rest_predicate data ext ->
        format data env ∋ (bin, xenv) ->
        exists xenv',
          decode (mappend bin ext) env' = Some (data, ext, xenv')
          /\ Equiv xenv xenv' /\ decode_inv xenv') /\
    (forall env env' xenv' data bin ext,
        Equiv env env'
        -> decode_inv env'
        -> decode bin env' = Some (data, ext, xenv')
        -> decode_inv xenv'
           /\ exists bin' xenv,
            (format data env ∋ (bin', xenv))
            /\ bin = mappend bin' ext
            /\ predicate data
            /\ Equiv xenv xenv').

  (* Definition that identifies properties of cache invariants for automation. *)
  Definition cache_inv_Property
             (P : CacheDecode -> Prop)
             (P_inv : (CacheDecode -> Prop) -> Prop) :=
    P_inv P.

  Lemma CorrectDecoderNone
        (monoid : Monoid B)
    : forall (predicate : A -> Prop)
             (rest_predicate : A -> B -> Prop)
             (format : FormatM)
             (decode : DecodeM)
             (decode_inv : CacheDecode -> Prop),
      CorrectDecoder _ predicate rest_predicate format decode decode_inv
      -> forall b b' s_d,
        decode_inv s_d
        -> decode (mappend b b') s_d = None
        -> forall a s_e s_e',
            Equiv s_e s_d
            -> predicate a
            -> rest_predicate a b'
            -> format a s_e ∌ (b, s_e').
  Proof.
    unfold not, CorrectDecoder; intros.
    eapply H in H4; eauto.
    destruct H4 as [? [? [? ?] ] ].
    rewrite H1 in H4; discriminate.
  Qed.

  Corollary CorrectDecoderNone_dec_predicates
            (monoid : Monoid B)
    : forall (predicate : A -> Prop)
             (rest_predicate : A -> B -> Prop)
             (predicate_dec : forall a, predicate a \/ ~ predicate a)
             (rest_predicate_dec : forall a b, rest_predicate a b \/ ~ rest_predicate a b)
             (format : FormatM)
             (decode : DecodeM)
             (decode_inv : CacheDecode -> Prop),
      CorrectDecoder _ predicate rest_predicate format decode decode_inv
      -> forall b b' s_d,
        decode_inv s_d
        -> decode (mappend b b') s_d = None
        -> forall a ,
            (~ predicate a)
            \/ (~ rest_predicate a b')
            \/ forall s_e s_e',
                Equiv s_e s_d
                -> format a s_e ∌ (b, s_e').
  Proof.
    intros.
    destruct (predicate_dec a); intuition.
    destruct (rest_predicate_dec a b'); intuition.
    right; right; intros; eapply CorrectDecoderNone; eauto.
  Qed.

  Lemma decode_None :
    forall (monoid : Monoid B)
           (predicate : A -> Prop)
           (rest_predicate : A -> B -> Prop)
           (format : A -> CacheFormat -> Comp (B * CacheFormat))
           (decode : B -> CacheDecode -> option (A * B * CacheDecode))
           (decode_inv : CacheDecode -> Prop)
           (predicate_dec : forall a, {predicate a} + {~ predicate a})
           (rest_predicate_dec : forall data, {rest_predicate data mempty} + {~rest_predicate data mempty}),
      CorrectDecoder monoid predicate rest_predicate format decode decode_inv
      -> forall b env' env,
        Equiv env env'
        -> decode b env' = None
        -> decode_inv env'
        -> forall data,
          ~ predicate data
          \/ ~ rest_predicate data mempty
          \/ ~ exists xenv, format data env ∋ (b, xenv).
  Proof.
    intros.
    destruct (predicate_dec data); try (solve [intuition]).
    right.
    destruct (rest_predicate_dec data); try (solve [intuition]).
    right.
    intros [? ?].
    destruct ((proj1 H) env env' _ data _ _ H2 H0 p r H3); intuition.
    rewrite mempty_right in H5; congruence.
  Qed.

  Local Transparent computes_to.

  (* We can always strengthen a format to disallow invalid data. *)
  Lemma CorrectDecoderStrengthenFormat :
    forall (monoid : Monoid B)
           (predicate : A -> Prop)
           (rest_predicate : A -> B -> Prop)
           (format : A -> CacheFormat -> Comp (B * CacheFormat))
           (decode : B -> CacheDecode -> option (A * B * CacheDecode))
           (decode_inv : CacheDecode -> Prop)
           (predicate_dec : forall a, {predicate a} + {~ predicate a})
           (rest_predicate_dec : forall data, {rest_predicate data mempty} + {~rest_predicate data mempty}),
      CorrectDecoder monoid predicate rest_predicate format decode decode_inv
      ->
      CorrectDecoder monoid predicate rest_predicate  (fun a s b => (format a s ∋ b) /\ predicate a) decode decode_inv.
  Proof.
    intros; destruct H; unfold CorrectDecoder; split; intros.
    eapply H; eauto.
    apply (proj1 H4).
    destruct (H0 env env' xenv' data bin ext) as [? [? [? ?] ] ]; intuition eauto.
    eexists _, _; intuition eauto.
    unfold computes_to; eauto.
  Qed.
  Local Opaque computes_to.

  Definition BindOpt {A' A''}
             (a_opt : option A')
             (k : A' -> option A'') :=
    Ifopt a_opt as a Then k a Else None.

  Lemma BindOpt_assoc {A''' A' A''} :
    forall (a_opt : option A''')
           (f : A''' -> option A')
           (g : A' -> option A''),
      BindOpt (BindOpt a_opt f) g =
      BindOpt a_opt (fun a => BindOpt (f a) g).
  Proof.
    destruct a_opt as [ ? | ]; simpl; intros; eauto.
  Qed.

  Definition DecodeBindOpt2
             {C D E}
             (a : option (A * B * D))
             (k : A -> B -> D -> option (C * E * D))
    : option (C * E * D) :=
    BindOpt a (fun a => match a with (a, b, d) => k a b d end).

  Definition DecodeBindOpt
             {C}
             (a : option (A * B))
             (k : A -> B -> option (C * B))
    : option (C * B) :=
    BindOpt a (fun a => let (a, b) := a in k a b).

  Lemma DecodeBindOpt2_inv
        {C D E}
        (a_opt : option (A * B * D))
        (a : C * E * D)
        (k : A -> B -> D -> option (C * E * D))
    : DecodeBindOpt2 a_opt k = Some a ->
      exists a' b' d',
        a_opt = Some (a', b', d')
        /\ Some a = k a' b' d'.
  Proof.
    unfold DecodeBindOpt2; destruct a_opt as [ [ [a' b'] d'] | ];
      simpl; intros; first [discriminate | injections ].
    eexists _, _, _; intuition eauto.
  Qed.

  Lemma DecodeBindOpt_inv
        {C}
        (a_opt : option (A * B))
        (a : C * B)
        (k : A -> B -> option (C * B))
    : DecodeBindOpt a_opt k = Some a ->
      exists a' b',
        a_opt = Some (a', b')
        /\ Some a = k a' b'.
  Proof.
    unfold DecodeBindOpt; destruct a_opt as [ [a' b'] | ];
      simpl; intros; first [discriminate | injections ].
    eexists _, _; intuition eauto.
  Qed.

End Specifications.

Definition DecodeOpt2_fmap
           {A A'}
           (f : A -> A')
           (a_opt : option A)
  : option A' := Ifopt a_opt as a Then Some (f a) Else None.

Definition DecodeOpt2_fmap_id {A}
  : forall (a_opt : option A),
    DecodeOpt2_fmap id a_opt = a_opt.
Proof.
  destruct a_opt as [ a' | ]; reflexivity.
Qed.

Definition DecodeOpt2_fmap_compose
           {A A' A''}
  : forall
    (f : A -> A')
    (f' : A' -> A'')
    (a_opt : option A),
    DecodeOpt2_fmap f' (DecodeOpt2_fmap f a_opt) =
    DecodeOpt2_fmap (compose f' f) a_opt.
Proof.
  destruct a_opt as [ a' | ]; reflexivity.
Qed.

Definition DecodeBindOpt2_fmap
           {A B B'} :
  forall (f : B -> B')
         (a_opt : option A)
         (k : A -> option B),
    DecodeOpt2_fmap f (BindOpt a_opt k) =
    BindOpt a_opt (fun a => DecodeOpt2_fmap f (k a)).
Proof.
  destruct a_opt as [ a' | ]; reflexivity.
Qed.

Definition BindOpt_map
           {A B B'} :
  forall (f : option B -> B')
         (a_opt : option A)
         (k : A -> option B),
    f (BindOpt a_opt k) =
    Ifopt a_opt as a Then f (k a) Else f None.
Proof.
  destruct a_opt as [ a' | ]; reflexivity.
Qed.

Lemma If_Opt_Then_Else_BindOpt {A B C}
  : forall (a_opt : option A)
           (t : A -> option B)
           (e : option B)
           (k : _ -> option C),
    BindOpt (Ifopt a_opt as a Then t a Else e) k
    = Ifopt a_opt as a Then (BindOpt (t a) k) Else (BindOpt e k).
Proof.
  destruct a_opt; simpl; intros; reflexivity.
Qed.

Lemma DecodeOpt2_fmap_if_bool
      {A A' }
  : forall
    (f : A -> A')
    (b : bool)
    (a_opt a_opt' : option A),
    DecodeOpt2_fmap f (if b then a_opt else a_opt') =
    if b then (DecodeOpt2_fmap f a_opt)
    else (DecodeOpt2_fmap f a_opt').
Proof.
  intros; find_if_inside; reflexivity.
Qed.

Lemma BindOpt_map_if_bool
      {A A' }
  : forall
    (f : option A -> A')
    (b : bool)
    (a_opt a_opt' : option A),
    f (if b then a_opt else a_opt') =
    if b then (f a_opt)
    else (f a_opt').
Proof.
  intros; find_if_inside; reflexivity.
Qed.

Lemma DecodeOpt2_fmap_if
      {A A' P P'}
  : forall
    (f : A -> A')
    (b : {P} + {P'})
    (a_opt a_opt' : option A),
    DecodeOpt2_fmap f (if b then a_opt else a_opt') =
    if b then (DecodeOpt2_fmap f a_opt)
    else (DecodeOpt2_fmap f a_opt').
Proof.
  intros; find_if_inside; reflexivity.
Qed.

Lemma BindOpt_map_if
      {A A' P P'}
  : forall
    (f : option A -> A')
    (b : {P} + {P'})
    (a_opt a_opt' : option A),
    f (if b then a_opt else a_opt') =
    if b then (f a_opt)
    else (f a_opt').
Proof.
  intros; find_if_inside; reflexivity.
Qed.

Lemma DecodeBindOpt2_assoc {A B C D E F G} :
  forall (a_opt : option (A * B * D))
         (f : A -> B -> D -> option (C * E * D))
         (g : C -> E -> D -> option (F * G * D)),
    DecodeBindOpt2 (DecodeBindOpt2 a_opt f) g =
    DecodeBindOpt2 a_opt (fun a b c => DecodeBindOpt2 (f a b c) g).
Proof.
  destruct a_opt as [ [ [? ?] ?] | ]; simpl; intros; eauto.
Qed.

Lemma DecodeBindOpt2_under_bind {A B C D E} :
  forall (a_opt : option (A * B * D))
         (f f' : A -> B -> D -> option (C * E * D)),
    (forall a b d, f a b d = f' a b d)
    -> DecodeBindOpt2 a_opt f = DecodeBindOpt2 a_opt f'.
Proof.
  destruct a_opt as [ [ [? ?] ?] | ]; simpl; intros; eauto.
Qed.

Notation "`( a , b , env ) <- c ; k" :=
  (DecodeBindOpt2 c%format (fun a b env => k%format)) : format_scope.

Notation "`( a , b ) <- c ; k" :=
  (DecodeBindOpt c%format (fun a b => k%format)) : format_scope.

Open Scope format_scope.

Lemma optimize_If_bind2_bool {A A' B B' C}
  : forall (c : bool)
           (t e : option (A * B * C))
           (k : A -> B -> C -> option (A' * B' * C)),
    (`(a, b, env) <- (If c Then t Else e); k a b env) =
    If c Then `(a, b, env) <- t; k a b env Else (`(a, b, env) <- e; k a b env).
Proof.
  destruct c; simpl; intros; reflexivity.
Qed.

Lemma If_sumbool_Then_Else_DecodeBindOpt {A B B' ResultT ResultT'} {c : Cache} {P}
  : forall (a_eq_dec : forall a a' : A, {P a a'} + {~ P a a'})
           a a'
           (k : _ -> _ -> _ -> option (ResultT' * B' * CacheDecode))
           (t : P a a' ->  option (ResultT * B * CacheDecode))
           (e : ~ P a a' -> option (ResultT * B * CacheDecode)),
    (`(w, b', cd') <- match a_eq_dec a a' with
                      | left e => t e
                      | right n => e n
                      end;
       k w b' cd') =
    match a_eq_dec a a' with
    | left e => `(w, b', cd') <- t e; k w b' cd'
    | right n => `(w, b', cd') <- e n; k w b' cd'
    end.
Proof.
  intros; destruct (a_eq_dec a a'); simpl; intros; reflexivity.
Qed.

Lemma optimize_under_DecodeBindOpt2_both {A B C D E} {B' }
  : forall (a_opt : option (A * B * C))
           (a_opt' : option (A * B' * C))
           (g : B' -> B)
           (a_opt_eq_Some : forall a' b' c,
               a_opt' = Some (a', b', c) ->
               a_opt = Some (a', g b', c))
           (a_opt_eq_None : a_opt' = None -> a_opt = None)
           (k : _ -> _ -> _ -> option (D * E * C))
           (k' : _ -> _ -> _ -> _)
           (k_eq_Some :
              forall a' b' c,
                a_opt' = Some (a', b', c) ->
                k a' (g b') c = k' a' b' c),
    DecodeBindOpt2 a_opt k = DecodeBindOpt2 a_opt' k'.
Proof.
  destruct a_opt' as [ [ [? ?] ?] | ]; simpl; intros.
  erewrite a_opt_eq_Some; simpl; eauto.
  erewrite a_opt_eq_None; simpl; eauto.
Qed.

Add Parametric Morphism
    A B
    (cache : Cache)
    (monoid : Monoid B)
    (predicate : A -> Prop)
    rest_predicate
    (decode : B -> CacheDecode -> option (A * B * CacheDecode))
    (decode_inv : CacheDecode -> Prop)
  : (fun format =>
       @CorrectDecoder A B cache monoid predicate
                                rest_predicate format decode decode_inv)
    with signature (pointwise_relation _ (pointwise_relation _ refineEquiv) ==> impl)
      as format_decode_correct_refineEquiv.
Proof.
  unfold impl, pointwise_relation, CorrectDecoder;
    intuition eauto; intros.
  - eapply H1; eauto; apply H; eauto.
  - eapply H2; eauto.
  - destruct (H2 _ _ _ _ _ _ H0 H3 H4) as [ ? [? [? ?] ] ];
      intuition.
    repeat eexists; intuition eauto; apply H; eauto.
Qed.

Section DecodeWMeasure.
  Context {A : Type}. (* data type *)
  Context {B : Type}. (* bin type *)
  Context {cache : Cache}.
  Context {monoid : Monoid B}.

  Variable format_A : A -> CacheFormat -> Comp (B * CacheFormat).
  Variable A_decode : B -> CacheDecode -> option (A * B * CacheDecode).

  Definition Decode_w_Measure_lt
             (b : B)
             (cd : CacheDecode)
             (A_decode_lt
              : forall  (b : B)
                        (cd : CacheDecode)
                        (a : A)
                        (b' : B)
                        (cd' : CacheDecode),
                 A_decode b cd = Some (a, b', cd')
                 -> lt_B b' b)
    : option (A * {b' : B | lt_B b' b} * CacheDecode).
    generalize (A_decode_lt b cd); clear.
    destruct (A_decode b cd) as [ [ [ a b' ] cd' ] | ]; intros;
      [ refine (Some (a, exist _ b' (H _ _ _ eq_refl), cd'))
      | exact None ].
  Defined.

  Lemma Decode_w_Measure_lt_eq
        (b : B)
        (cd : CacheDecode)
        (A_decode_lt
         : forall  (b : B)
                   (cd : CacheDecode)
                   (a : A)
                   (b' : B)
                   (cd' : CacheDecode),
            A_decode b cd = Some (a, b', cd')
            -> lt_B b' b)
    : forall a' b' cd',
      A_decode b cd = Some (a', b', cd')
      -> exists pf,
        Decode_w_Measure_lt b cd A_decode_lt =
        Some (a', exist _ b' pf , cd').
  Proof.
    clear; intros; unfold Decode_w_Measure_lt.
    remember (A_decode_lt b cd); clear Heql.
    destruct (A_decode b cd) as [ [ [? ?] ? ] | ].
    injections; eauto.
    discriminate.
  Qed.

  Lemma Decode_w_Measure_lt_eq'
        (b : B)
        (cd : CacheDecode)
        (A_decode_lt
         : forall  (b : B)
                   (cd : CacheDecode)
                   (a : A)
                   (b' : B)
                   (cd' : CacheDecode),
            A_decode b cd = Some (a, b', cd')
            -> lt_B b' b)
    : A_decode b cd = None
      -> Decode_w_Measure_lt b cd A_decode_lt = None.
  Proof.
    clear; intros; unfold Decode_w_Measure_lt.
    remember (A_decode_lt b cd); clear Heql.
    destruct (A_decode b cd) as [ [ [? ?] ? ] | ]; eauto.
    discriminate.
  Qed.

  Definition Decode_w_Measure_le
             (b : B)
             (cd : CacheDecode)
             (A_decode_le
              : forall  (b : B)
                        (cd : CacheDecode)
                        (a : A)
                        (b' : B)
                        (cd' : CacheDecode),
                 A_decode b cd = Some (a, b', cd')
                 -> le_B b' b)
    : option (A * {b' : B | le_B b' b} * CacheDecode).
    generalize (A_decode_le b cd); clear.
    destruct (A_decode b cd) as [ [ [ a b' ] cd' ] | ]; intros;
      [ refine (Some (a, exist _ b' (H _ _ _ eq_refl), cd'))
      | exact None ].
  Defined.

  Lemma Decode_w_Measure_le_eq
        (b : B)
        (cd : CacheDecode)
        (A_decode_le
         : forall  (b : B)
                   (cd : CacheDecode)
                   (a : A)
                   (b' : B)
                   (cd' : CacheDecode),
            A_decode b cd = Some (a, b', cd')
            -> le_B b' b)
    : forall a' b' cd',
      A_decode b cd = Some (a', b', cd')
      -> exists pf,
        Decode_w_Measure_le b cd A_decode_le =
        Some (a', exist _ b' pf , cd').
  Proof.
    clear; intros; unfold Decode_w_Measure_le.
    remember (A_decode_le b cd); clear Heql.
    destruct (A_decode b cd) as [ [ [? ?] ? ] | ].
    injections; eauto.
    discriminate.
  Qed.

  Lemma Decode_w_Measure_le_eq'
        (b : B)
        (cd : CacheDecode)
        (A_decode_le
         : forall  (b : B)
                   (cd : CacheDecode)
                   (a : A)
                   (b' : B)
                   (cd' : CacheDecode),
            A_decode b cd = Some (a, b', cd')
            -> le_B b' b)
    : A_decode b cd = None
      -> Decode_w_Measure_le b cd A_decode_le = None.
  Proof.
    clear; intros; unfold Decode_w_Measure_le.
    remember (A_decode_le b cd); clear Heql.
    destruct (A_decode b cd) as [ [ [? ?] ? ] | ]; eauto.
    discriminate.
  Qed.

  Lemma Decode_w_Measure_le_eq'':
    forall (b : B) (cd : CacheDecode)
           (A_decode_le : forall (b0 : B) (cd0 : CacheDecode) (a : A) (b' : B) (cd' : CacheDecode),
               A_decode b0 cd0 = Some (a, b', cd') -> le_B b' b0),
      Decode_w_Measure_le b cd A_decode_le = None ->
      A_decode b cd = None.
  Proof.
    clear; intros ? ? ?; unfold Decode_w_Measure_le in *.
    remember (A_decode_le b cd); clear Heql.
    destruct (A_decode b cd) as [ [ [? ?] ? ] | ]; eauto.
    intros; discriminate.
  Qed.

  Lemma Decode_w_Measure_lt_eq'':
    forall (b : B) (cd : CacheDecode)
           (A_decode_lt : forall (b0 : B) (cd0 : CacheDecode) (a : A) (b' : B) (cd' : CacheDecode),
               A_decode b0 cd0 = Some (a, b', cd') -> lt_B b' b0),
      Decode_w_Measure_lt b cd A_decode_lt = None ->
      A_decode b cd = None.
  Proof.
    clear; intros ? ? ?; unfold Decode_w_Measure_lt in *.
    remember (A_decode_lt b cd); clear Heql.
    destruct (A_decode b cd) as [ [ [? ?] ? ] | ]; eauto.
    discriminate.
  Qed.

End DecodeWMeasure.

Global Unset Implicit Arguments.

Definition CorrectDecoderFor {A B} {cache : Cache}
           {monoid : Monoid B} Invariant FormatSpec :=
  { decodePlusCacheInv : _ |
    exists P_inv,
    (cache_inv_Property (snd decodePlusCacheInv) P_inv
     -> CorrectDecoder (A := A) monoid Invariant (fun _ _ => True)
                                FormatSpec
                                (fst decodePlusCacheInv)
                                (snd decodePlusCacheInv))
    /\ cache_inv_Property (snd decodePlusCacheInv) P_inv}.

Lemma Start_CorrectDecoderFor
      {A B} {cache : Cache}
      {monoid : Monoid B}
      Invariant
      FormatSpec
      (decoder decoder_opt : B -> CacheDecode -> option (A * B * CacheDecode))
      (cache_inv : CacheDecode -> Prop)
      (P_inv : (CacheDecode -> Prop) -> Prop)
      (decoder_OK :
         cache_inv_Property cache_inv P_inv
         -> CorrectDecoder (A := A) monoid Invariant (fun _ _ => True)
                                    FormatSpec decoder cache_inv)
      (cache_inv_OK : cache_inv_Property cache_inv P_inv)
      (decoder_opt_OK : forall b cd, decoder b cd = decoder_opt b cd)
  : @CorrectDecoderFor A B cache monoid Invariant FormatSpec.
Proof.
  exists (decoder_opt, cache_inv); exists P_inv; split; simpl; eauto.
  unfold CorrectDecoder in *; intuition; intros.
  - destruct (H1 _ _ _ _ _ ext env_OK H0 H3 H4 H5).
    rewrite decoder_opt_OK in H6; eauto.
  - rewrite <- decoder_opt_OK in H4; destruct (H2 _ _ _ _ _ _ H0 H3 H4); eauto.
  - rewrite <- decoder_opt_OK in H4; destruct (H2 _ _ _ _ _ _ H0 H3 H4); eauto.
Defined.

(* Shorthand for nondeterministically decoding a value. *)
Definition Pick_Decoder_For
           {A B} {cache : Cache}
           {monoid : Monoid B}
           Invariant
           FormatSpec
           (b : B)
           (ce : CacheFormat)
  := {a : option A |
      forall a' : A,
        a = Some a' <->
        (exists b1 b2 (ce' : CacheFormat),
            computes_to (FormatSpec a' ce) (b1, ce')
            /\ b = mappend b1 b2
            /\ Invariant a')}%comp.

Lemma refine_Pick_Decoder_For
      {A B} {cache : Cache}
      {monoid : Monoid B} {Invariant}
      {FormatSpec}
      (decoderImpl : @CorrectDecoderFor A B cache monoid Invariant FormatSpec)
  : forall b ce cd,
    Equiv ce cd
    -> snd (proj1_sig decoderImpl) cd
    -> refine (Pick_Decoder_For Invariant FormatSpec b ce)
              (ret match fst (proj1_sig decoderImpl) b cd
                   with
                   | Some (a, _, _) => Some a
                   | None => None
                   end).
Proof.
  intros.
  pose proof (proj2_sig (decoderImpl)).
  cbv beta in H1.
  destruct_ex; intuition.
  destruct H1.
  intros v Comp_v; computes_to_inv; subst;
    apply PickComputes; intros.
  split; intros.
  - destruct (fst (proj1_sig decoderImpl) b cd) as [ [ [? ?] ?] | ] eqn: ?; try discriminate.
    injections.
    eapply H2 in Heqo; eauto.
    destruct Heqo as [? [? [? [? ?] ] ] ].
    intuition.
    subst.
    eexists _, _, _ ; split; eauto.
  - destruct_ex; intuition; subst.
    eapply H1 in H5; eauto.
    destruct_ex; intuition.
    rewrite H5; reflexivity.
Qed.


(* Counter with contributions. A specification derived from the modular
   specification proved in modular_incr module. *)
From iris.base_logic Require Import invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.proofmode Require Import proofmode.
From iris.algebra Require Import numbers frac_auth.
From iris.prelude Require Import options.

From iris_examples.lecture_notes Require Import modular_incr.

Class ccounterG Σ := CCounterG { ccounter_inG :> inG Σ (frac_authR natR) }.
Definition ccounterΣ : gFunctors := #[GFunctor (frac_authR natR)].

Global Instance subG_ccounterΣ {Σ} : subG ccounterΣ Σ → ccounterG Σ.
Proof. solve_inG. Qed.

Section ccounter.
  Context `{!heapGS Σ, !cntG Σ, !ccounterG Σ} (N : namespace).

  Lemma ccounterRA_valid (m n : natR) (q : frac): ✓ (●F m ⋅ ◯F{q} n) → n ≤ m.
  Proof.
    intros ?.
    (* This property follows directly from the generic properties of the relevant RAs. *)
    apply nat_included. by apply: (frac_auth_included_total q).
  Qed.

  Lemma ccounterRA_valid_full (m n : natR): ✓ (●F m ⋅ ◯F n) → n = m.
  Proof.
    by intros ?%frac_auth_agree.
  Qed.

  Lemma ccounterRA_update (m n : natR) (q : frac): (●F m ⋅ ◯F{q} n) ~~> (●F (S m) ⋅ ◯F{q} (S n)).
  Proof.
    apply frac_auth_update, (nat_local_update _ _ (S _) (S _)).
    lia.
  Qed.

  Definition ccounter_inv (γ₁ γ₂ : gname): iProp Σ :=
    (∃ n, own γ₁ (●F n) ∗ γ₂ ⤇½ (Z.of_nat n))%I.

  Definition is_ccounter (γ₁ γ₂ : gname) (l : loc) (q : frac) (n : natR) : iProp Σ := (own γ₁ (◯F{q} n) ∗ inv (N .@ "counter") (ccounter_inv γ₁ γ₂)  ∗ Cnt N l γ₂)%I.

  (** The main proofs. *)
  Lemma is_ccounter_op γ₁ γ₂ ℓ q1 q2 (n1 n2 : nat) :
    is_ccounter γ₁ γ₂ ℓ (q1 + q2) (n1 + n2) ⊣⊢ is_ccounter γ₁ γ₂ ℓ q1 n1 ∗ is_ccounter γ₁ γ₂ ℓ q2 n2.
  Proof.
    apply bi.equiv_entails; split; rewrite /is_ccounter frac_auth_frag_op own_op.
    - iIntros "[? #?]".
      iFrame "#"; iFrame.
    - iIntros "[[? #?] [? _]]".
      iFrame "#"; iFrame.
  Qed.

  Lemma newcounter_contrib_spec (R : iProp Σ) m:
    {{{ True }}}
        newcounter #m
    {{{ γ₁ γ₂ ℓ, RET #ℓ; is_ccounter γ₁ γ₂ ℓ 1 m }}}.
  Proof.
    iIntros (Φ) "_ HΦ". rewrite -wp_fupd.
    wp_apply newcounter_spec; auto.
    iIntros (ℓ) "H"; iDestruct "H" as (γ₂) "[#HCnt Hown]".
    iMod (own_alloc (●F m ⋅ ◯F m)) as (γ₁) "[Hγ Hγ']"; first by apply auth_both_valid_discrete.
    iMod (inv_alloc (N .@ "counter") _ (ccounter_inv γ₁ γ₂) with "[Hγ Hown]").
    { iNext. iExists _. by iFrame. }
    iModIntro. iApply "HΦ". rewrite /is_ccounter; eauto.
  Qed.

  Lemma incr_contrib_spec γ₁ γ₂ ℓ q n :
    {{{ is_ccounter γ₁ γ₂ ℓ q n  }}}
        incr #ℓ
    {{{ (y : Z), RET #y; is_ccounter γ₁ γ₂ ℓ q (S n) }}}.
  Proof.
    iIntros (Φ) "[Hown #[Hinv HCnt]] HΦ".
    iApply (incr_spec N γ₂ _ (own γ₁ (◯F{q} n))%I (λ _, (own γ₁ (◯F{q} (S n))))%I with "[] [Hown]"); first set_solver.
    - iIntros (m) "!# [HOwnElem HP]".
      iInv (N .@ "counter") as (k) "[>H1 >H2]" "HClose".
      iDestruct (makeElem_eq with "HOwnElem H2") as %->.
      iMod (makeElem_update _ _ _ (k+1) with "HOwnElem H2") as "[HOwnElem H2]".
      iMod (own_update_2 with "H1 HP") as "[H1 HP]".
      { apply ccounterRA_update. }
      iMod ("HClose" with "[H1 H2]") as "_".
      { iNext; iExists (S k); iFrame.
        rewrite Nat2Z.inj_succ Z.add_1_r //.
      }
      by iFrame.
    - by iFrame.
    - iNext.
      iIntros (m) "[HCnt' Hown]".
      iApply "HΦ". by iFrame.
  Qed.

  Lemma read_contrib_spec γ₁ γ₂ ℓ q n :
    {{{ is_ccounter γ₁ γ₂ ℓ q n }}}
        read #ℓ
    {{{ (c : Z), RET #c; ⌜(Z.of_nat n ≤ c)%Z⌝ ∧ is_ccounter γ₁ γ₂ ℓ q n }}}.
  Proof.
    iIntros (Φ) "[Hown #[Hinv HCnt]] HΦ".
    wp_apply (read_spec N γ₂ _ (own γ₁ (◯F{q} n))%I (λ m,
        ⌜(n ≤ m)%Z⌝ ∗ (own γ₁ (◯F{q} n)))%I with "[] [Hown]"); first set_solver.
    - iIntros (m) "!# [HownE HOwnfrag]".
      iInv (N .@ "counter") as (k) "[>H1 >H2]" "HClose".
      iDestruct (makeElem_eq with "HownE H2") as %->.
      iDestruct (own_valid_2 with "H1 HOwnfrag") as %Hleq%ccounterRA_valid.
      iMod ("HClose" with "[H1 H2]") as "_".
      { iExists _; by iFrame. }
      iFrame; iIntros "!>!%".
      auto using inj_le.
    - by iFrame.
    - iIntros (i) "[_ [% HQ]]".
      iApply "HΦ".
      iSplit; first by iIntros "!%".
      iFrame; iFrame "#".
  Qed.

  Lemma read_contrib_spec_1 γ₁ γ₂ ℓ n :
    {{{ is_ccounter γ₁ γ₂ ℓ 1%Qp n }}} read #ℓ
    {{{ RET #n; is_ccounter γ₁ γ₂ ℓ 1 n }}}.
  Proof.
    iIntros (Φ) "[Hown #[Hinv HCnt]] HΦ".
    wp_apply (read_spec N γ₂ _ (own γ₁ (◯F n))%I (λ m, ⌜Z.of_nat n = m⌝ ∗ (own γ₁ (◯F n)))%I with "[] [Hown]"); first set_solver.
    - iIntros (m) "!# [HownE HOwnfrag]".
      iInv (N .@ "counter") as (k) "[>H1 >H2]" "HClose".
      iDestruct (makeElem_eq with "HownE H2") as %->.
      iDestruct (own_valid_2 with "H1 HOwnfrag") as %Hleq%ccounterRA_valid_full; simplify_eq.
      iMod ("HClose" with "[H1 H2]") as "_".
      { iExists _; by iFrame. }
      iFrame; by iIntros "!>!%".
    - by iFrame.
    - iIntros (i) "[_ [% HQ]]".
      simplify_eq. iApply "HΦ".
      iFrame; iFrame "#".
  Qed.
End ccounter.