Require Import Coq.omega.Omega.
Require Import Bedrock.Platform.AutoSep.
Require Import Bedrock.Platform.Cito.SyntaxExpr.

Require Import Bedrock.StringSet.
Import StringSet.
Require Import Coq.FSets.FSetProperties.
Module Import SSP := Properties StringSet.

Set Implicit Arguments.

Section TopLevel.

  Variable vars : list string.

  Variable temp_size : nat.

  Variable exprs : list Expr.

  Variable base dst : nat.

  Definition is_state sp vs temps dst dst_buf : HProp :=
    (locals vars vs 0 (sp ^+ $8) *
     array temps (sp ^+ $8 ^+ $ (4 * length vars)) *
     array dst_buf (sp ^+ $ dst))%Sep.

  Definition new_pre : assert :=
    x ~> ExX, Ex vs, Ex temps, Ex dst_buf,
    ![^[is_state x#Sp vs temps dst dst_buf] * #0]x /\
    [| length temps = temp_size /\
       length exprs = length dst_buf |].

  Require Import Bedrock.Platform.Cito.SemanticsExpr.
  Require Import Bedrock.Platform.Cito.DepthExpr.
  Require Import Bedrock.Platform.Cito.Max.

  Definition depth := max_list 0 (map depth exprs).

  Require Bedrock.Platform.Cito.CompileExpr.
  Require Import Bedrock.Platform.Cito.ListFacts5.

  Local Open Scope nat.

  Definition runs_to x_pre x :=
    forall specs other vs temps dst_buf,
      interp specs (![is_state x_pre#Sp vs temps dst dst_buf * other ] x_pre)
      -> length temps = temp_size
      -> length exprs = length dst_buf
      -> Regs x Sp = x_pre#Sp /\
      exists changed,
        interp specs (![is_state (Regs x Sp) vs (upd_sublist temps base changed) dst (map (eval vs) exprs) * other ] (fst x_pre, x)) /\
        length changed <= depth.

  Definition post (pre : assert) :=
    st ~> Ex st_pre,
    pre (fst st, st_pre) /\
    [| runs_to (fst st, st_pre) (snd st) |].

  Definition imply (pre new_pre: assert) := forall specs x, interp specs (pre x) -> interp specs (new_pre x).

  Require Import Bedrock.Platform.Cito.FreeVarsExpr.
  Require Import Bedrock.Platform.Cito.Union.

  Definition syn_req exprs base :=
    Subset (union_list (map free_vars exprs)) (of_list vars) /\
    base + depth <= temp_size /\
    List.Forall (fun e => DepthExpr.depth e <= depth) exprs.

  Definition verifCond base pre := imply pre new_pre :: syn_req exprs base :: nil.

  Variable imports : LabelMap.t assert.

  Variable imports_global : importsGlobal imports.

  Variable modName : string.

  Definition Seq2 := @Seq_ _ imports_global modName.

  Definition Skip := Straightline_ imports modName nil.

  Fixpoint Seq ls :=
    match ls with
      | nil => Skip
      | a :: ls' => Seq2 a (Seq ls')
    end.

  Definition Strline := Straightline_ imports modName.

  Definition SaveRv lv := Strline (IL.Assign lv (RvLval (LvReg Rv)) :: nil).

  Definition stack_slot (n : nat) := LvMem (Sp + n)%loc.

  Definition compile_expr e n := CompileExpr.compile vars temp_size imports_global modName e n.

  Fixpoint do_compile exprs base dst :=
    match exprs with
      | nil => nil
      | x :: xs =>
        compile_expr x base
          :: SaveRv (stack_slot dst)
          :: do_compile xs base (4 + dst)
    end.

  Definition body := Seq (do_compile exprs base dst).

  Require Import Bedrock.Platform.Wrap.

  Opaque mult.
  Opaque evalInstrs.

  Lemma array_out : forall a p,
    length a > 0
    -> array a p ===> p =*> Array.selN a 0 * array (tl a) (p ^+ $4).
    clear_fancy; destruct a; unfold array; simpl; intros.
    inversion H.
    destruct a.
    sepLemma.
    apply Himp_star_frame; try apply Himp_refl.
    eapply Himp_trans; [ apply ptsto32m_shift_base' | ].
    instantiate (1 := 4); auto.
    apply Himp_refl.
  Qed.

  Lemma change_hyp : forall P Q specs st,
    interp specs (![P] st)
    -> P ===> Q
    -> interp specs (![Q] st).
    intros.
    eapply Imply_sound.
    rewrite sepFormula_eq.
    apply H0.
    rewrite sepFormula_eq in *; auto.
  Qed.

  Lemma array_in : forall a p,
    length a > 0
    -> p =*> Array.selN a 0 * array (tl a) (p ^+ $4) ===> array a p.
    clear_fancy; destruct a; unfold array; simpl; intros.
    inversion H.
    destruct a.
    sepLemma.
    apply Himp_star_frame; try apply Himp_refl.
    eapply Himp_trans; [ | apply ptsto32m_shift_base ].
    instantiate (1 := 4); auto.
    apply Himp_refl.
    auto.
  Qed.

  Lemma In_union_list : forall x exprs0,
    In x (fold_right union empty (map free_vars exprs0))
    -> In x (fold_right union empty (map free_vars exprs0)).
    induction exprs0; simpl; intuition.
  Qed.

  Lemma postOk : forall specs exprs base dst pre x,
    interp specs (Postcondition (Seq (do_compile exprs base dst) pre) x)
    -> imply pre (x ~> ExX, Ex vs, Ex temps, Ex dst_buf,
      ![^[is_state x#Sp vs temps dst dst_buf] * #0]x /\
      [| length temps = temp_size /\
        length exprs = length dst_buf |])
    -> syn_req exprs base
    -> exists x0, interp specs (pre (fst x, x0))
        /\ forall specs other vs temps dst_buf,
          interp specs (![is_state (Regs x0 Sp) vs temps dst dst_buf * other ] (fst x, x0))
          -> length temps = temp_size
          -> length exprs = length dst_buf
          -> Regs (snd x) Sp = Regs x0 Sp /\
          exists changed,
            interp specs (![is_state (Regs (snd x) Sp) vs (upd_sublist temps base changed) dst (map (eval vs) exprs) * other ] (fst x, snd x)) /\
            length changed <= depth.
    induction exprs0; post.

    clear_fancy.
    Transparent evalInstrs.
    simpl in H3.
    Opaque evalInstrs.
    injection H3; clear H3; intros; subst.
    descend.
    eauto.
    descend.
    instantiate (1 := nil); simpl.
    destruct dst_buf; simpl in *; auto.
    discriminate.
    simpl; auto.

    apply IHexprs0 in H; clear IHexprs0; auto.
    Focus 2.
    hnf; post.
    apply H0 in H3; clear H0; post.
    unfold is_state in H2.
    assert (interp specs0
      (![locals vars x4 0 (Regs x2 Sp ^+ $ (8)) *
        array x5 (Regs x2 Sp ^+ $ (8) ^+ $ (4 * Datatypes.length vars)) *
        (array x6 (Regs x2 Sp ^+ $ (dst0)) *
        ![fun m : ST.settings * smem => x3 m]) ]
      (fst x0, x2))).
    clear H; clear_fancy.
    step auto_ext.
    clear H2.
    apply H5 in H3; clear H5; post.
    unfold stack_slot in H4.
    clear H; clear_fancy.
    Opaque evalInstrs.
    Opaque evalInstrs.

    eapply change_hyp in H5.
    Focus 2.
    apply Himp_star_frame; [ apply Himp_refl | ].
    apply Himp_star_frame; [ | apply Himp_refl ].
    apply array_out; omega.
    destruct x6; simpl in *; try discriminate.
    evaluate auto_ext.
    destruct x0; simpl in *.
    descend.
    replace (Regs x2 Sp ^+ natToW dst0 ^+ natToW 4) with (Regs x2 Sp ^+ natToW (S (S (S (S dst0)))))
      in H9.
    unfold is_state.
    unfold CompileExpr.is_state in H9.
    step auto_ext.
    rewrite H.
    step auto_ext.
    rewrite <- H3.
    step auto_ext.
    rewrite <- wplus_assoc.
    unfold natToW.
    rewrite <- natToWord_plus.
    repeat f_equal.
    omega.
    rewrite length_upd_sublist; auto.
    auto.

    post.
    post.
    eexists; split; eauto.
    intros.
    clear H2.
    unfold is_state in H.
    assert (interp specs0
      (![CompileExpr.is_state vars (Regs x2 Sp) vs temps
        * (array dst_buf (Regs x2 Sp ^+ $ (dst0)) * other ) ]
      (fst x, x2))).
    unfold CompileExpr.is_state.
    clear H0; clear_fancy.
    step auto_ext.
    clear H.
    apply H5 in H2; clear H5.
    generalize H6; intro Hs.
    apply H2 in Hs; clear H2.
    destruct x; simpl in *.
    destruct Hs as [ ? [ ? [ ? [ ? [ ] ] ] ] ].
    simpl in *.
    eapply change_hyp in H2.
    Focus 2.
    apply Himp_star_frame; [ apply Himp_refl | ].
    apply Himp_star_frame; [ | apply Himp_refl ].
    apply array_out; omega.
    unfold stack_slot in H4.
    clear H0; clear_fancy.
    evaluate auto_ext.
    destruct dst_buf; simpl in *; try discriminate.
    assert (interp specs0
      (![is_state (Regs x0 Sp) vs (upd_sublist temps base0 x) (S (S (S (S dst0)))) dst_buf *
        ((Regs x2 Sp ^+ natToW dst0) =*> Regs x1 Rv * other)] (s, x0))).
    unfold is_state.
    unfold CompileExpr.is_state in H9.
    step auto_ext.
    rewrite <- H0.
    unfold natToW.
    rewrite H.
    rewrite <- H0.
    step auto_ext.
    rewrite <- wplus_assoc.
    unfold natToW.
    rewrite <- natToWord_plus.
    replace (dst0 + 4) with (S (S (S (S dst0)))) by omega.
    step auto_ext.
    clear H9.
    apply H3 in H10; clear H3; auto.
    post.
    congruence.

    assert (length (upd_sublist (upd_sublist temps base0 x) base0 x3)
      = length temps).
    repeat rewrite length_upd_sublist; reflexivity.
    eapply CompileExpr.get_changed in H9.
    post.
    descend.
    rewrite <- H12.
    Focus 3.
    instantiate (1 := base0 + max (length x) (length x3)).
    omega.
    Focus 2.
    destruct H1.
    destruct (NPeano.Nat.max_spec (length x) (length x3)); intuition.
    inversion_clear H16.
    omega.
    unfold is_state in *.
    eapply change_hyp.
    Focus 2.
    apply Himp_star_frame; [ | eapply Himp_refl ].
    apply Himp_star_frame; [ eapply Himp_refl | ].
    Opaque evalInstrs.

    apply array_in; simpl; auto.
    simpl.
    replace (Regs s0 Sp ^+ $ (dst0) ^+ $ (4))
      with (Regs s0 Sp ^+ ($ (dst0) ^+ $ (4))) by words.
    rewrite <- natToWord_plus.
    replace (dst0 + 4) with (S (S (S (S dst0)))) by omega.
    generalize dependent (map (eval vs) exprs0); intros.
    step auto_ext.
    replace (Regs x2 Sp) with (Regs s0 Sp) by congruence.
    step auto_ext.

    intros.
    repeat rewrite CompileExpr.upd_sublist_unchanged by auto; reflexivity.

    intros.
    generalize (Max.le_max_l (length x) (length x3)).
    generalize (Max.le_max_r (length x) (length x3)); intros.
    repeat rewrite CompileExpr.upd_sublist_unchanged_high by auto; reflexivity.

    rewrite length_upd_sublist; auto.
    unfold syn_req in *; intuition.
    hnf; intros.
    apply H2.
    simpl.
    unfold union_list.
    simpl.
    Opaque evalInstrs.

    eapply In_union_list with (exprs0 := a :: exprs0); eauto.
    simpl.
    eapply StringFacts.union_iff; eauto.
    inversion H4; auto.
  Qed.
  Opaque evalInstrs.

  Lemma verifCondOk : forall exprs base dst pre,
    imply pre (x ~> ExX, Ex vs, Ex temps, Ex dst_buf,
      ![^[is_state x#Sp vs temps dst dst_buf] * #0]x /\
      [| length temps = temp_size /\
        length exprs = length dst_buf |])
    -> syn_req exprs base
    -> vcs (VerifCond (Seq (do_compile exprs base dst) pre)).
    induction exprs0; wrap0.

    Transparent evalInstrs.
    discriminate.
    Opaque evalInstrs.

    clear IHexprs0; clear_fancy.
    hnf; post.
    apply H in H1; clear H; post.
    unfold is_state, CompileExpr.is_state in *.
    assert (interp specs
      (![locals vars x1 0 ((x) # (Sp) ^+ $ (8)) *
        array x2 ((x) # (Sp) ^+ $ (8) ^+ $ (4 * Datatypes.length vars)) *
        (array x3 ((x) # (Sp) ^+ $ (dst0)) *
        ![fun m : ST.settings * smem => x0 m]) ] x)).
    step auto_ext.
    clear H1.
    descend.
    step auto_ext.
    auto.

    unfold syn_req, CompileExpr.syn_req in *; intuition.
    hnf; intros.
    apply H1.
    simpl.
    unfold union_list.
    simpl.

    apply StringFacts.union_iff; auto.
    inversion H3; omega.

    clear IHexprs0; clear_fancy.
    apply H in H3; clear H; post.
    unfold is_state in H1.
    assert (interp specs
      (![locals vars x1 0 (Regs x Sp ^+ $ (8)) *
        array x2 (Regs x Sp ^+ $ (8) ^+ $ (4 * Datatypes.length vars)) *
        (array x3 (Regs x Sp ^+ $ (dst0)) *
        ![fun m : ST.settings * smem => x0 m]) ] (stn, x))).
    step auto_ext.
    clear H1.
    apply H4 in H3; clear H4; post.
    eapply change_hyp in H4.
    Focus 2.
    apply Himp_star_frame; [ apply Himp_refl | ].
    apply Himp_star_frame; [ | apply Himp_refl ].
    apply array_out; omega.
    destruct x3; simpl in *; try discriminate.
    unfold stack_slot in *.
    evaluate auto_ext.

    apply IHexprs0; clear IHexprs0; clear_fancy.
    Focus 2.
    unfold syn_req in *; intuition.
    hnf; intros.
    apply H1.
    simpl.
    unfold union_list; simpl.
    eapply In_union_list with (exprs0 := a :: exprs0); eauto.
    apply StringFacts.union_iff; eauto.
    inversion H3; auto.
    hnf; post.
    apply H in H2; clear H; post.
    unfold is_state in H1.
    assert (interp specs
      (![CompileExpr.is_state vars (Regs x1 Sp) x3 x4
        * (array x5 (Regs x1 Sp ^+ $ (dst0)) * ![fun m : ST.settings * smem => x2 m]) ]
      (fst x, x1))).
    unfold CompileExpr.is_state.
    step auto_ext.
    clear H1.
    apply H4 in H2; clear H4; post.
    eapply change_hyp in H4.
    Focus 2.
    apply Himp_star_frame; [ apply Himp_refl | ].
    apply Himp_star_frame; [ | apply Himp_refl ].
    apply array_out; omega.
    destruct x5; simpl in *; try discriminate.
    unfold stack_slot in *.
    evaluate auto_ext.
    destruct x; simpl in *.
    descend.
    rewrite H4.
    rewrite <- H2.
    unfold is_state.
    unfold CompileExpr.is_state in H9.
    step auto_ext.
    rewrite <- H2.
    rewrite <- wplus_assoc.
    rewrite <- natToWord_plus.
    replace (dst0 + 4) with (S (S (S (S dst0)))) by omega.
    step auto_ext.
    rewrite length_upd_sublist; auto.
    congruence.
  Qed.

  Definition compile : cmd imports modName.
    refine (Wrap imports imports_global modName body post (verifCond base) _ _).
    Opaque evalInstrs.

    abstract (unfold verifCond; wrap0;
      match goal with
        | [ H : interp _ _ |- _ ] => eapply postOk in H; post; descend; eauto
      end).
    Opaque evalInstrs.

    abstract (unfold verifCond; wrap0; eauto using verifCondOk).
  Defined.

End TopLevel.


Require Import Terms.
Require Import LNaVSyntax.
Require Import LNaVBigStep.

(** * Equivalences *)

(** Low-equivalence judgments. *)
Inductive eq_atom : Atom -> Atom -> Lab -> Prop :=
| eq_a : forall b1 l1 b2 l2 l,
  l1 = l2 ->
  ((l1 <: l \/ l2 <: l) -> eq_box b1 b2 l) ->
  eq_atom (b1,l1) (b2,l2) l
with eq_box : Box -> Box -> Lab -> Prop :=
| eq_v : forall v1 v2 l, eq_val v1 v2 l -> eq_box (V v1) (V v2) l
| eq_d : forall e l, eq_box (D e) (D e) l
with eq_val : Val -> Val -> Lab -> Prop :=
| eq_vconst : forall c' l, eq_val (VConst c') (VConst c') l
| eq_vinx : forall d a a' l,
  eq_atom a a' l ->
  eq_val (VInx d a) (VInx d a') l
| eq_vclos : forall r1 r2 x t l,
  eq_env r1 r2 l ->
  eq_val (VClos r1 x t) (VClos r2 x t) l
with eq_env : Env -> Env -> Lab -> Prop :=
| eq_e_nil : forall l, eq_env nil nil l
| eq_e_cons : forall x a1 a2 r1 r2 l,
  eq_atom a1 a2 l -> eq_env r1 r2 l -> eq_env ((x,a1)::r1) ((x,a2)::r2) l.
Hint Constructors eq_atom eq_box eq_val eq_env.
Scheme eq_atom_ind' := Minimality for eq_atom Sort Prop
with eq_box_ind' := Minimality for eq_box Sort Prop
with eq_val_ind' := Minimality for eq_val Sort Prop
with eq_env_ind' := Minimality for eq_env Sort Prop.

Combined Scheme eq_mutind from eq_val_ind', eq_box_ind', eq_atom_ind', eq_env_ind'.

(** Low-equivalence judgments, that take the pc label into account. *)
Definition eq_atom' a1 pc1 a2 pc2 l :=
  (pc1 <: l \/ pc2 <: l) ->
  (pc1 = pc2 /\ eq_atom a1 a2 l).
Definition eq_env' r1 pc1 r2 pc2 l :=
  (pc1 <: l \/ pc2 <: l) ->
  (pc1 = pc2 /\ eq_env r1 r2 l).

(** * Preliminary lemmas. *)

Lemma maps_eq_env : forall x a1 a2 r1 r2 l,
  eq_env r1 r2 l ->
  maps r1 x a1 ->
  maps r2 x a2 ->
  eq_atom a1 a2 l.
Proof.
  intros x a1 a2 r1 r2 l Heq_env Hmaps1 Hmaps2.
  induction Heq_env. invs Hmaps1.
  invs Hmaps1; invs Hmaps2. destruct (beq_nat x x0).
  congruence. auto.
Qed.

Lemma maps_eq_env' : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_env' r1 pc1 r2 pc2 l ->
  maps r1 x a1 ->
  maps r2 x a2 ->
  eq_atom' a1 pc1 a2 pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l Heq_env' Hmaps1 Hmaps2 Hflows.
  apply Heq_env' in Hflows. intuition eauto using maps_eq_env.
Qed.

Lemma eq_env'_cons_inv_env : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_env' ((x,a1) :: r1) pc1 ((x,a2) :: r2) pc2 l ->
  eq_env' r1 pc1 r2 pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l H Hflows. apply H in Hflows as [? Henv].
  invsc Henv. auto.
Qed.

Lemma eq_env'_cons_inv_atom : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_env' ((x,a1) :: r1) pc1 ((x,a2) :: r2) pc2 l ->
  eq_atom' a1 pc1 a2 pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l H Hflows. apply H in Hflows as [? Henv].
  invsc Henv. auto.
Qed.

Lemma cons_eq_env' : forall x a1 a2 r1 r2 pc1 pc2 l,
  eq_atom' a1 pc1 a2 pc2 l ->
  eq_env' r1 pc1 r2 pc2 l ->
  eq_env' ((x,a1) :: r1) pc1 ((x,a2) :: r2) pc2 l.
Proof.
  intros x a1 a2 r1 r2 pc1 pc2 l Hatom Henv Hflows.
  specialize (Hatom Hflows). specialize (Henv Hflows).
  intuition auto.
Qed.

(** Reflexivity of low-equivalence. Later, we prove this is actually an
    equivalence relation. *)

Lemma eq_refl :
  (forall v l, eq_val v v l) /\
  (forall b l, eq_box b b l) /\
  (forall a l, eq_atom a a l) /\
  (forall r l, eq_env r r l).
Proof. apply val_box_atom_env_mutind; eauto. Qed.

Lemma eq_val_refl : forall v l, eq_val v v l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma eq_box_refl : forall b l, eq_box b b l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma eq_atom_refl : forall a l, eq_atom a a l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma eq_env_refl : forall r l, eq_env r r l.
Proof. pose proof eq_refl. intuition. Qed.

Lemma intro_and2 : forall (P P1 P2: Prop),
  (P -> (P1 /\ P2)) ->
  (P -> P1) /\ (P -> P2).
Proof. tauto. Qed.

Lemma eq_val_eq_tag : forall v1 v2 l,
  eq_val v1 v2 l ->
  tag_of v1 = tag_of v2.
Proof.
  intros v1 v2 l Heq.
  inversion Heq; eauto.
Qed.

Lemma or_introrefl : forall (P : Prop),
  P -> P \/ P.
Proof. left. assumption. Qed.

Lemma or_elimrefl : forall (P : Prop),
  P \/ P -> P.
Proof. intros P H. destruct H; assumption. Qed.

(** Monotonicity of the pc label. This property is essential for the
    non-interference proof to go through. *)
Lemma pc_eval_monotonic : forall r t pc a pc',
  r |- t, pc ==> a, pc' -> pc <: pc'.
Proof.
  intros r t pc a pc' Heval.
  (eval_cases (induction Heval) Case);
  eauto 4 using flows_refl, flows_trans, join_1_rev.
Qed.

(* Binary operations respect equality *)
Lemma eq_box_eq_bop : forall b b11 b12 b21 b22 l,
  eq_box b11 b21 l ->
  eq_box b12 b22 l ->
  bop_box b b11 b12 = bop_box b b21 b22.
Proof.
  intros b b11 b12 b21 b22 l Heq1 Heq2.
  invsc Heq1; eauto; invsc Heq2; eauto;
  destruct b; invsc H; try invsc H0; eauto.
Qed.

(** * Non-interference *)

(** Strengthened version of non-interference. *)
Lemma non_interference_strong :
  forall r1 t pc1 a1 pc1',
    r1 |- t, pc1 ==> a1, pc1' ->
      forall r2 pc2 a2 pc2' l,
        r2 |- t, pc2 ==> a2, pc2' ->
          eq_env' r1 pc1 r2 pc2 l ->
          (eq_env' r1 pc1' r2 pc2' l /\
            eq_atom' a1 pc1' a2 pc2' l).
Proof.
  intros r1 t pc1 a1 pc1' H.
  (eval_cases (induction H) Case);
  intros r2 pc2 a2 pc2'; try (rename l into l1); intro l;
    intros Heval2 Heq_env; invsc Heval2.
  Case "eval_var". eauto using maps_eq_env'.
  Case "eval_const". intuition.
    intros Hpc. specialize (Heq_env Hpc). invsc Heq_env; eauto.
  Case "eval_let".
    apply intro_and2. intro Hpc.
    pose proof (pc_eval_monotonic _ _ _ _ _ H).
    pose proof (pc_eval_monotonic _ _ _ _ _ H0).
    pose proof (pc_eval_monotonic _ _ _ _ _ H8).
    pose proof (pc_eval_monotonic _ _ _ _ _ H9).
    assert (pc <: l \/ pc2 <: l) by (destruct Hpc; eauto using flows_trans).
    assert (pc' <: l \/ pc2' <: l) by (destruct Hpc; eauto using flows_trans).
    specialize (Heq_env H5). invsc Heq_env.
    apply IHeval1 with (l:=l) in H8; try (intro; eauto). destruct H8.
    apply IHeval2 with (l:=l) in H9; eauto using cons_eq_env'. destruct H9.
    specialize (H11 Hpc). invsc H11; eauto.
  Case "eval_abs". intuition.
    intros Hpc. specialize (Heq_env Hpc). invsc Heq_env; eauto.
    apply intro_and2. intro Hpc.
    pose proof (pc_eval_monotonic _ _ _ _ _ H1).
    pose proof (pc_eval_monotonic _ _ _ _ _ H10).
    pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env H H4).
    pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env H0 H6).
    assert (pc <: l \/ pc2 <: l) by
      (destruct Hpc; eauto using join_1_rev, flows_trans).
    specialize (H5 H8). invsc H5. specialize (H7 H8). invsc H7.
    invsc H11. assert (l0 <: l \/ l0 <: l) by
      (destruct Hpc; eauto using join_2_rev, flows_trans).
    specialize (H17 H7). invsc H17. invsc H13.
    specialize (Heq_env H8). invsc Heq_env.
    apply IHeval with (l:=l) in H10. invsc H10.
    specialize (H14 Hpc). invsc H14; eauto.
    apply cons_eq_env'; intro; eauto.
    SCase "type error". (* spurious *)
      apply intro_and2. intro Hpc.
      pose proof (pc_eval_monotonic _ _ _ _ _ H1).
      assert (pc <: l \/ pc2 <: l) by
        (destruct Hpc; eauto using join_1_rev, flows_trans).
      pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env H H5).
      specialize (H4 H3). invsc H4. invsc H7.
      assert (l0 <: l \/ l0 <: l) by
        (destruct Hpc; eauto using join_2_rev, flows_trans).
      specialize (H13 H4). invsc H13. invsc H7.
      simpl in H9. exfalso; auto.
  Case "eval_app_no_abs".
    SCase "no type error". (* spurious *)
      apply intro_and2. intro Hpc.
      pose proof (pc_eval_monotonic _ _ _ _ _ H9).
      assert (pc <: l \/ pc2 <: l) by
        (destruct Hpc; eauto using join_1_rev, flows_trans).
      pose proof (maps_eq_env' _ _ _ _ _ _ _ _ Heq_env H H3).
      specialize (H4 H2). invsc H4. invsc H7.
      assert (l0 <: l \/ l0 <: l) by
        (destruct Hpc; eauto using join_2_rev, flows_trans).
      specialize (H13 H4). invsc H13. invsc H8.
      simpl in H0. exfalso; auto.
    SCase "eval_app_no_abs".
      apply intro_and2. intro Hpc.
      assert (pc <: l \/ pc2 <: l) by
        (destruct Hpc; eauto using join_1_rev, flows_trans).
      specialize (Heq_env H1). invsc Heq_env.
      pose proof (maps_eq_env _ _ _ _ _ _ H3 H H4).
      invsc H2.
      assert (l0 <: l \/ l0 <: l) by
        (destruct Hpc; eauto using join_2_rev, flows_trans).
      specialize (H12 H2). invsc H12; eauto.
  Case "eval_inx". intuition.
    intros Hpc. specialize (Heq_env Hpc). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H1 H H6). eauto using maps_eq_env.
  Case "eval_match".
    pose proof (pc_eval_monotonic _ _ _ _ _ H0).
    pose proof (pc_eval_monotonic _ _ _ _ _ H10).
    apply intro_and2. intro Hpc.
    assert (pc <: l \/ pc2 <: l) by
      (destruct Hpc; eauto using flows_trans, join_1_rev).
    specialize (Heq_env H3). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H5 H H9).
    invsc H4. assert (l0 <: l \/ l0 <: l) by
      (destruct Hpc; eauto using flows_trans, join_2_rev).
    specialize (H14 H4). invsc H14. invsc H8.
    apply IHeval with (l:=l) in H10. invsc H10. specialize (H7 Hpc).
    invsc H7. eauto. eapply cons_eq_env'; intro; eauto.
    SCase "type error". (* spurious *)
      pose proof (pc_eval_monotonic _ _ _ _ _ H0).
      apply intro_and2. intro Hpc.
      assert (pc <: l \/ pc2 <: l) by
        (destruct Hpc; eauto using flows_trans, join_1_rev).
      specialize (Heq_env H2). invsc Heq_env.
      pose proof (maps_eq_env _ _ _ _ _ _ H4 H H9).
      invsc H3. assert (l0 <: l \/ l0 <: l) by
        (destruct Hpc; eauto using flows_trans, join_2_rev).
      specialize (H13 H3). invsc H13. invsc H6.
      simpl in H10. exfalso; auto.
  Case "eval_match_no_sum". SCase "no type error". (* spurious *)
    pose proof (pc_eval_monotonic _ _ _ _ _ H10).
    apply intro_and2. intro Hpc.
    assert (pc <: l \/ pc2 <: l) by
      (destruct Hpc; eauto using flows_trans, join_1_rev).
    specialize (Heq_env H2). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H4 H H9).
    invsc H3. assert (l0 <: l \/ l0 <: l) by
      (destruct Hpc; eauto using flows_trans, join_2_rev).
    specialize (H13 H3). invsc H13. invsc H7.
    simpl in H0. exfalso; auto.
    SCase "type error".
      apply intro_and2. intro Hpc.
      assert (pc <: l \/ pc2 <: l) by
        (destruct Hpc; eauto using flows_trans, join_1_rev).
      specialize (Heq_env H1). invsc Heq_env.
      pose proof (maps_eq_env _ _ _ _ _ _ H3 H H9).
      invsc H2. assert (l0 <: l \/ l0 <: l) by
        (destruct Hpc; eauto using flows_trans, join_2_rev).
      specialize (H12 H2). invsc H12; eauto.
  Case "eval_tag".
    apply intro_and2. intro Hpc. specialize (Heq_env Hpc).
    invsc Heq_env. pose proof (maps_eq_env _ _ _ _ _ _ H1 H H2).
    invsc H0. split. auto. split. reflexivity.
    constructor. reflexivity. intro. specialize (H9 H0).
    unfold tag_box; invsc H9; eauto. invsc H3; eauto.
  Case "eval_bop".
    apply intro_and2. intro Hpc. specialize (Heq_env Hpc). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H2 H H8).
    pose proof (maps_eq_env _ _ _ _ _ _ H2 H0 H9).
    split. intuition. split. reflexivity. invsc H1. invsc H3.
    constructor. reflexivity. intro.
    assert (l'0 <: l \/ l'0 <: l) by
      (destruct H1; eauto using flows_trans, join_1_rev).
    assert (l''0 <: l \/ l''0 <: l) by
      (destruct H1; eauto using flows_trans, join_2_rev).
    specialize (H12 H3). specialize (H11 H4).
    pose proof (eq_box_eq_bop bo _ _ _ _ l H12 H11).
    rewrite H5. apply eq_box_refl.
  Case "eval_bracket".
    pose proof (pc_eval_monotonic _ _ _ _ _ H0).
    pose proof (pc_eval_monotonic _ _ _ _ _ H8).
    apply intro_and2. intro Hpc.
    assert (pc <: l \/ pc2 <: l) by (destruct Hpc; eauto using join_1_rev).
    specialize (Heq_env H3). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H6 H H4).
    invsc H5.
    assert (l'0 <: l \/ l'0 <: l) by (destruct Hpc; eauto using join_2_rev).
    specialize (H14 H5). invsc H14. invsc H10. split. intuition. split. reflexivity.
    apply IHeval with (l:=l) in H8; try (intro; eauto). invsc H8.
    remember (flows_dec (l'' \_/ pc') (l0 \_/ (pc2 \_/ l'0))) as f1.
    remember (flows_dec (l''0 \_/ pc'0) (l0 \_/ (pc2 \_/ l'0))) as f2.
    destruct f1; destruct f2; constructor; auto; intro.
    SCase "flow, flow".
      assert (pc' <: l \/ pc'0 <: l) by
        (destruct H8; destruct Hpc; eauto using join_2_rev, flows_trans, join_minimal).
      specialize (H9 H10). invsc H9. invsc H12.
      apply H17.
      destruct H8; destruct Hpc; eauto using join_1_rev, flows_trans, join_minimal.
    SCase "flow, no flow". (* spurious *)
      assert (pc' <: l \/ pc'0 <: l) by
        (destruct H8; destruct Hpc; eauto using join_2_rev, flows_trans, join_minimal).
      specialize (H9 H10). invsc H9. invsc H12.
      contradiction.
    SCase "no flow, flow". (* spurious *)
      assert (pc' <: l \/ pc'0 <: l) by
        (destruct H8; destruct Hpc; eauto using join_2_rev, flows_trans, join_minimal).
      specialize (H9 H10). invsc H9. invsc H12.
      contradiction.
  Case "eval_bracket". SCase "type error". (* spurious *)
    apply intro_and2. intro Hpc.
    pose proof (pc_eval_monotonic _ _ _ _ _ H0).
    assert (pc <: l \/ pc2 <: l) by
      (destruct Hpc; eauto using join_1_rev, flows_trans).
    specialize (Heq_env H2). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H5 H H4).
    invsc H3.
    assert (l'0 <: l \/ l'0 <: l) by
      (destruct Hpc; eauto using join_2_rev, flows_trans).
    specialize (H13 H3). invsc H13. invsc H7.
    simpl in H8. exfalso; auto.
  Case "eval_bracket_no_lab". SCase "no type error". (* spurious *)
    apply intro_and2. intro Hpc.
    pose proof (pc_eval_monotonic _ _ _ _ _ H8).
    assert (pc <: l \/ pc2 <: l) by
      (destruct Hpc; eauto using join_1_rev, flows_trans).
    specialize (Heq_env H2). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H5 H H4).
    invsc H3.
    assert (l'0 <: l \/ l'0 <: l) by
      (destruct Hpc; eauto using join_2_rev, flows_trans).
    specialize (H13 H3). invsc H13. invsc H9.
    simpl in H0. exfalso; auto.
  Case "eval_bracket_no_lab".
    apply intro_and2. intro Hpc.
    assert (pc <: l \/ pc2 <: l) by (destruct Hpc; eauto using join_1_rev).
    specialize (Heq_env H1). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H3 H H4).
    invsc H2.
    assert (l'0 <: l \/ l'0 <: l) by (destruct Hpc; eauto using join_2_rev).
    specialize (H12 H2). invsc H12; eauto.
  Case "eval_label_of".
    apply intro_and2. intro Hpc.
    specialize (Heq_env Hpc). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H1 H H2).
    invsc H0. split; eauto.
  Case "eval_get_pc".
    apply intro_and2. intro Hpc.
    specialize (Heq_env Hpc). invsc Heq_env.
    split; eauto.
  Case "eval_mk_nav".
    apply intro_and2. intro Hpc.
    specialize (Heq_env Hpc). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H1 H H2).
    invsc H0. split. intuition. split. reflexivity. constructor. reflexivity.
    intro. specialize (H9 H0). invsc H9; unfold mk_nav_box; try invsc H3; eauto;
    destruct c'; auto.
  Case "eval_to_sum".
    apply intro_and2. intro Hpc. specialize (Heq_env Hpc). invsc Heq_env.
    pose proof (maps_eq_env _ _ _ _ _ _ H1 H H2).
    invsc H0. split. intuition. split. reflexivity. constructor. reflexivity.
    intro. specialize (H9 H0). unfold to_sum_box. invsc H9; constructor; constructor; eauto.
Qed.

(** Finally, non-interference. *)

Theorem non_interference: forall r1 t pc1 a1 pc1' r2 pc2 a2 pc2' l,
    eq_env' r1 pc1 r2 pc2 l ->
    r1 |- t, pc1 ==> a1, pc1' ->
    r2 |- t, pc2 ==> a2, pc2' ->
    eq_atom' a1 pc1' a2 pc2' l.
Proof.
  intros r1 t pc1 a1 pc1' r2 pc2 a2 pc2' l
    Hequiv_env Heval1 Heval2.
  assert (eq_env' r1 pc1' r2 pc2' l /\ eq_atom' a1 pc1' a2 pc2' l) by
    eauto using non_interference_strong.
  intuition.
Qed.