Require Import ZArith.
Require Import Lia.
Require Import List.

Require Setoid.
Require RelationClasses.
Require Import Relations.
Require Import EquivDec.

Require Import Utils.
Require Import Lattices.
Require Import Instr Memory.
Require Import AbstractCommon.
Require Import AbstractMachine.
Require TINI.

Set Implicit Arguments.

Section ObsEquiv.

Context {Label: Type}
        {Latt: JoinSemiLattice Label}.

Definition low_pc (o: Label) (s: a_state) : Prop :=
  snd (apc s) <: o = true.

Lemma low_pc_dec: forall o s, {low_pc o s}+{~ low_pc o s}.
Proof.
  intros. unfold low_pc.
  destruct (flows (snd (apc s)) o) eqn:?; auto.
Qed.

(** * Low equivalence relations *)
Inductive low_equiv_atom {A} (o: Label) : relation (A * Label)%type :=
| le_a_low : forall l v, l <: o = true -> low_equiv_atom o (v,l) (v,l)
| le_a_high: forall l1 l2 v1 v2,
  l1 <: o = false ->
  l2 <: o = false ->
  low_equiv_atom o (v1,l1) (v2,l2).
Hint Constructors low_equiv_atom : core.

Lemma low_equiv_atom_equal:
  forall {A} (a b:A) (k l:Label) (o:Label), k <: o = true ->
    low_equiv_atom o (a,k) (b,l) -> a = b.
Proof.
  intros A a b k l o h; inversion 1; auto.
  rewrite H3 in h. discriminate.
Qed.

Instance low_pair (A:Type) (o: Label) : @Equivalence (A * Label) (low_equiv_atom o).
Proof.
  constructor.
  (* reflexive *) intro x. destruct x;
  destruct (flows l o) eqn:?; auto.
  (* symmetric *) intros x y Hxy. inv Hxy ; auto.
  (* transitive *) intros x y z Hxy Hyz.
  inv Hxy; auto. inv Hyz ; auto.
Qed.

Global Instance low_atom (o: Label) : @Equivalence (Atom Label Label) (low_equiv_atom o) :=
  low_pair (val Label) o.

Global Instance low_pcatom (o: Label) : @Equivalence (PcAtom Label) (low_equiv_atom o) :=
  low_pair Z o.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_atom _ _ _ => reflexivity
  end : core.

Lemma low_equiv_atom_join_value:
  forall A o (v1 v0 v v2:A) vl vl0  vl2 vl1,
    low_equiv_atom o (v1, vl) (v, vl0) ->
    low_equiv_atom o (v2, vl2) (v0, vl1) ->
    low_equiv_atom o (v1, vl \_/ vl2) (v, vl0 \_/ vl1).
Proof.
  intros.
  inv H; inv H0; econstructor; eauto with lat.
Qed.

Lemma low_equiv_atom_binop_value:
  forall A o (f:A->A->option A) (v1 v2 v1' v2' v v':A) vl1 vl2  vl1' vl2',
    low_equiv_atom o (v1, vl1) (v1', vl1') ->
    low_equiv_atom o (v2, vl2) (v2', vl2') ->
    f v1 v2 = Some v ->
    f v1' v2' = Some v' ->
    low_equiv_atom o (v, vl1 \_/ vl2) (v', vl1' \_/ vl2').
Proof.
  intros.
  inv H; inv H0;
  try (assert (v'=v) by congruence; subst); econstructor; auto with lat.
Qed.

Inductive low_equiv_stkelt (o: Label) : StkElmt Label Label -> StkElmt Label Label -> Prop :=
| le_data : forall a1 a2
  (LEa: low_equiv_atom o a1 a2),
  low_equiv_stkelt o (AData a1) (AData a2)
| le_aret : forall a1 a2 b
  (LEa: low_equiv_atom o a1 a2),
  low_equiv_stkelt o (ARet a1 b) (ARet a2 b).
Hint Constructors low_equiv_stkelt : core.

Global Instance low_stkelt (o: Label) : @Equivalence (StkElmt Label Label) (low_equiv_stkelt o).
Proof.
  constructor.
  (* reflexive *) intro x. destruct x; auto.
  (* symmetric *) intros x y Hxy. inv Hxy ; constructor ; symmetry; auto.
  (* transitive *) intros x y z Hxy Hyz.
  inv Hxy; inv Hyz; constructor; etransitivity; eauto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_stkelt _ _ _ => reflexivity
  end : core.

(* TODO: Rename and move *)
Lemma Forall2_app_left (A: Type) (low_equiv_a: A -> A -> Prop) :
  forall l1 l1' l2 l2',
    Forall2 low_equiv_a (l1++l2) (l1'++l2') ->
    length l1 = length l1' ->
    Forall2 low_equiv_a l1 l1'.
Proof.
  induction l1; intros; simpl in *.
  destruct l1'; [ eauto | inv H0].
  destruct l1'; [inv H0 | eauto].
  simpl in *; inv H; auto.
  constructor ; eauto.
Qed.

(* TODO: Rename and move *)
Lemma Forall2_app_right (A: Type) (low_equiv_a: A -> A -> Prop) :
  forall l1 l1' l2 l2',
    Forall2 low_equiv_a (l1++l2) (l1'++l2') ->
    length l1 = length l1' ->
    Forall2 low_equiv_a l2 l2'.
Proof.
  induction l1; intros; simpl in *.
  destruct l1' ; [simpl in * ; auto | inv H0].
  destruct l1'; [ inv H0 | simpl in * ].
  inv H; auto.
  eapply IHl1 ; eauto.
Qed.

(* TODO: Move and rename *)
Lemma index_list_low_eq (A: Type) (low_equiv: A -> A -> Prop) :
  forall n l1 l2 v1 v2,
    Forall2 low_equiv l1 l2 ->
    index_list n l1 = Some v1 ->
    index_list n l2 = Some v2 ->
    low_equiv v1 v2.
Proof.
  induction n ; intros.
  inv H; (simpl in * ; congruence).
  destruct l1, l2; (simpl in * ; try congruence).
  inv H.
  eapply IHn ; eauto.
Qed.

(* TODO: Move and rename *)
Lemma index_list_Z_low_eq (A: Type) (low_equiv: A -> A -> Prop) :
  forall i l1 l2 v1 v2,
    Forall2 low_equiv l1 l2 ->
    index_list_Z i l1 = Some v1 ->
    index_list_Z i l2 = Some v2 ->
    low_equiv v1 v2.
Proof.
  intros. eapply index_list_low_eq; eauto.
  eapply index_list_Z_nat; eauto.
  eapply index_list_Z_nat; eauto.
Qed.

Lemma update_list_high: forall A o m1 m2,
  Forall2 (low_equiv_atom o) m1 m2 ->
  forall a m1' (o1:A) v l1 l2
    (Hl1 : l1 <: o = false)
    (Hl2 : l2 <: o = false),
    index_list a m1 = Some (o1, l1) ->
    update_list a (v, l2) m1 = Some m1' ->
    Forall2 (low_equiv_atom o) m1' m2.
Proof.
  induction 1; intros.
  destruct a; simpl in *; allinv.

  destruct a; simpl in *; allinv.
  constructor ; auto. inv H ; auto.

  case_eq (update_list a (v, l2) l) ; intros;
  rewrite H3 in *; allinv.
  constructor; auto.
  eapply (IHForall2 a l0 o1 v l1 l2) ; eauto.
Qed.

Lemma update_list_Z_high: forall A o m1 m2,
  Forall2 (low_equiv_atom o) m1 m2 ->
  forall a m1' o1 (v:A) l1 l2
    (Hl1 : l1 <: o = false)
    (Hl2 : l2 <: o = false),
    index_list_Z a m1 = Some (o1, l1) ->
    update_list_Z a (v, l2) m1 = Some m1' ->
    Forall2 (low_equiv_atom o) m1' m2.
Proof.
  intros.
  eapply update_list_high with (l1 := l1) (l2 := l2); eauto.
  eapply index_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Global Instance low_list
          (A: Type)
          (R: relation A)
          (EqR: Equivalence R) : @Equivalence (list A) (@Forall2 A A R).
Proof.
  constructor.
  (* reflexive *) unfold Reflexive. induction x; intros; constructor; auto. reflexivity.
  (* symmetric *)
  unfold Symmetric.
  induction x ; intros; (inv H ; constructor ; auto). symmetry; auto.
  (* transitive *)
  unfold Transitive.
  induction x; intros.
  inv H. auto. inv H. inv H0.
  constructor. etransitivity; eauto.
  eapply IHx ; eauto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- Forall2 _ _ _ => reflexivity
  end : core.

Lemma update_list_low_equiv: forall A a obs l  m m' o (v:A)
  (Hl : l <: obs = false),
  index_list a m = Some (o, l) ->
  update_list a (v, l) m = Some m' ->
  Forall2 (low_equiv_atom obs) m m'.
Proof.
  induction a; intros.
  destruct m ; simpl in *; allinv.
  constructor; auto.

  destruct m ; simpl in *; allinv.
  case_eq (update_list a (v, l) m) ; intros; rewrite H1 in *; allinv.
  constructor; eauto.
Qed.

Lemma update_list_Z_low_equiv: forall A a obs l  m m' o (v:A)
  (Hl : l <: obs = false),
  index_list_Z a m = Some (o, l) ->
  update_list_Z a (v, l) m = Some m' ->
  Forall2 (low_equiv_atom obs) m m'.
Proof.
  intros. eapply update_list_low_equiv; eauto.
  eapply index_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

(* TODO: Refactor and move *)
Lemma update_list_low_gen :
  forall T (R : T -> T -> Prop) n
         (x1 x2 : T)
         (l1 l1' l2 l2' : list T)
         (ELTS : R x1 x2)
         (LISTS : Forall2 R l1 l2)
         (UPD1 : update_list n x1 l1 = Some l1')
         (UPD2 : update_list n x2 l2 = Some l2'),
    Forall2 R l1' l2'.
Proof.
  induction n; intros.
  - inv LISTS; simpl in *; allinv.
    constructor; auto.

  - inv LISTS.
    simpl in *; allinv.
    simpl in *.
    repeat match goal with
             | H : (match ?b with _ => _ end) = Some _ |- _ =>
               destruct b eqn:?; simpl in *; try congruence
           end;
    allinv.
    constructor; eauto.
Qed.

(* TODO: Refactor and move *)
Lemma update_list_low : forall A o n m1 m2 a1 a2 m1' m2',
  Forall2 (@low_equiv_atom A o) m1 m2 ->
  low_equiv_atom o a1 a2 ->
  update_list n a1 m1 = Some m1' ->
  update_list n a2 m2 = Some m2' ->
  Forall2 (low_equiv_atom o) m1' m2'.
Proof.
  induction n ; intros.
  inv H; simpl in *; allinv.
  constructor ; auto.

  inv H.
  simpl in *; allinv.
  simpl in H2, H1.
  case_eq (update_list n a2 l') ; case_eq (update_list n a1 l) ; intros;
    rewrite H in * ; rewrite H5 in * ; allinv.
  constructor ; eauto.
Qed.

(* TODO: Refactor and move *)
Lemma update_list_Z_low : forall A o n m1 m2 a1 a2 m1' m2',
  Forall2 (@low_equiv_atom A o) m1 m2 ->
  low_equiv_atom o a1 a2 ->
  update_list_Z n a1 m1 = Some m1' ->
  update_list_Z n a2 m2 = Some m2' ->
  Forall2 (low_equiv_atom o) m1' m2'.
Proof.
  intros. eapply update_list_low; eauto.
  eapply update_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Lemma Forall2_update_Z: forall o a1 a2 a1l a2l (o1:val Label) o1l o2 o2l m1 m2 m1' m2' v1 v1l v2 v2l,
    low_equiv_atom o (a1, a1l) (a2, a2l) ->
    Forall2 (low_equiv_atom o) m1 m2 ->
    index_list_Z a1 m1 = Some (o1, o1l) ->
    index_list_Z a2 m2 = Some (o2, o2l) ->
     a1l <: o1l = true ->
     a2l <: o2l = true ->
    low_equiv_atom o (v1, v1l) (v2, v2l) ->
    update_list_Z a1 (v1, join a1l v1l) m1 = Some m1' ->
    update_list_Z a2 (v2, join a2l v2l) m2 = Some m2' ->
    Forall2 (low_equiv_atom o) m1' m2'.
Proof.
  intros.
  inv H; inv H5.

  eapply (@update_list_Z_low _ o) ; eauto.

  eapply update_list_Z_low with (3:= H6) (4:= H7) ; eauto.
  econstructor 2; eauto with lat.

  assert (Forall2 (low_equiv_atom o) m1' m1).
  assert (a1l \_/ v2l <: o = false) by eauto with lat.
  eapply update_list_Z_high with (4:= H1); eauto.
  destruct (flows o1l o) eqn:?; auto.
  assert (flows a1l o = true); eauto with lat.

  assert (Forall2 (low_equiv_atom o) m1' m2) by (etransitivity; eauto).
  assert (a2l \_/ v2l <: o = false) by eauto with lat.
  exploit (@update_list_Z_spec (Atom _ _) (v2, a1l \_/ v2l)) ; eauto. intros HH.
  assert (Forall2 (low_equiv_atom o) m2' m2).
  eapply update_list_Z_high with (4:= H2); eauto.
  destruct (flows o2l o) eqn:?; auto.
  assert (flows a2l o = true); eauto with lat.
  etransitivity; eauto. symmetry; auto.

  assert (a1l \_/ v1l <: o = false) by eauto with lat.
  assert (Forall2 (low_equiv_atom o) m1' m1).
  eapply update_list_Z_high with (4:= H1); eauto.
  destruct (flows o1l o) eqn:?; auto.
  assert (flows a1l o = true); eauto with lat.

  exploit (@update_list_Z_spec (Atom _ _) (v1, a1l \_/ v1l)) ; eauto. intros HH.
  assert (Forall2 (low_equiv_atom o) m1' m2).
  etransitivity ; eauto.

  assert (a2l \_/ v2l <: o = false) by eauto with lat.
  assert (Forall2 (low_equiv_atom o) m2' m2).
  eapply update_list_Z_high with (4:= H2); eauto.
  destruct (flows o2l o) eqn:?; auto.
  assert (flows a2l o = true); eauto with lat.
  etransitivity; eauto. symmetry; eauto.
Qed.

Lemma update_high_low_equiv: forall A o addr m v l l' v' m',
  index_list addr m = Some (v,l) ->
  l <: o = false ->
  l <: l' = true ->
  update_list addr (v',l') m = Some m' ->
  Forall2 (@low_equiv_atom A o) m m'.
Proof.
  induction addr; intros.
  destruct m ; simpl in *; allinv.
  constructor ; eauto.
  constructor 2; auto with lat.
  destruct (flows l' o) eqn:?; auto.
  assert (flows l o = true); eauto with lat.

  destruct m ; simpl in *; allinv.
  remember (update_list addr (v', l') m) as up.
  destruct up; allinv.
  constructor; eauto.
Qed.

Lemma update_Z_high_low_equiv: forall A o addr m v l l' v' m',
  index_list_Z addr m = Some (v,l) ->
  l <: o = false ->
  l <: l' = true ->
  update_list_Z addr (v',l') m = Some m' ->
  Forall2 (@low_equiv_atom A o) m m'.
Proof.
  intros. eapply update_high_low_equiv; eauto.
  eapply index_list_Z_nat; eauto.
  eapply update_list_Z_nat; eauto.
Qed.

Fixpoint below_lret (o: Label) (stk: list (StkElmt Label Label)) : list (StkElmt Label Label) :=
  match stk with
    | nil => nil
    | (ARet (_,l) _)::stk' =>
      match flows l o with
        | true => stk
        | false => below_lret o stk'
      end
    | _::stk' => below_lret o stk'
  end.

Lemma below_lret_low_equiv : forall o l1 l2,
  Forall2 (low_equiv_stkelt o) l1 l2 ->
  Forall2 (low_equiv_stkelt o) (below_lret o l1) (below_lret o l2).
Proof.
  induction 1; intros.
  simpl ; auto.
  inv H; (simpl; auto).
  inv LEa; (rewrite H in *; auto).
  rewrite H1 ; auto.
Qed.

Lemma below_lret_adata : forall o l l',
  (forall d, In d l -> exists a : Atom _ _, d = AData a) ->
  below_lret o (l ++ l') = below_lret o l'.
Proof.
  induction l; intros.
  simpl; auto.
  destruct a. simpl ; auto. eapply IHl ; eauto.
  intros. eapply H ; eauto. constructor 2 ; auto.

  eelim (H (ARet p b)); intros.
  congruence.
  constructor ; auto.
Qed.

Global Instance declare_equiv_option {A} (R:relation A) `{Equivalence A R} : @Equivalence (option A) (match_options R).
Proof.
  constructor.
  - intros [x|]; repeat constructor.
    reflexivity.
  - intros [x|] [y|]; intros H ; inv H; constructor.
    symmetry; auto.
  - intros [x|] [y|] [z|]; intros H1 H2; inv H1; inv H2; constructor.
    transitivity y; auto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- match_options _ _ _ => reflexivity
  end : core.

(* Low-equivalent memories:
   (1) low-equivalence of frames pointed to by low blocks
   (2) allocating a low frame in them results in the same block
     DD -> DP : I understand this as "low allocation history is the same"
*)
Definition equiv_mem (o:Label) : relation (memory Label Label) :=
  fun m1 m2 =>
    (forall b,
      Mem.stamp b <: o = true ->
      match_options (Forall2 (low_equiv_atom o))
                    (Mem.get_frame m1 b) (Mem.get_frame m2 b) )
      /\
      (forall lbl fr,
         lbl <: o = true ->
                fst (Mem.alloc Local m1 lbl fr) = fst (Mem.alloc Local m2 lbl fr)).

Global Instance declare_equiv_mem (o:Label): @Equivalence (memory Label Label) (equiv_mem o).
Proof.
  constructor.
  - intros m; split; reflexivity.
  - intros m1 m2 [H H']; split.
    + intros b Hb; symmetry; auto.
    + intros; symmetry; auto.
  - intros m1 m2 m3 H1 H2.
    destruct H1; destruct H2; split; intros.
    + transitivity (Mem.get_frame m2 b); auto.
    + rewrite H0; auto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- equiv_mem _ _ _ => reflexivity
  end : core.

Lemma load_equiv_mem:
  forall o p m1 m2 v1 v2,
    equiv_mem o m1 m2 ->
    Mem.stamp (fst p) <: o = true ->
    load p m1 = Some v1 ->
    load p m2 = Some v2 ->
    low_equiv_atom o v1 v2.
Proof.
  intros o [b ofs] m1 m2 v1 v2 [H _] Hs H0 H1.
  unfold load in *. simpl in *.
  assert (T:=H b Hs); inv T.
  - rewrite <- H3 in *; congruence.
  - rewrite <- H2 in *.
    rewrite <- H3 in *.
    eapply index_list_Z_low_eq; eauto.
Qed.

Lemma store_equiv_mem:
  forall o m1 m2 p1 p2 pcl l1 l2 v1 v2 ll1 ll2 o1 o2 lll1 lll2 m1' m2',
  equiv_mem o m1 m2 ->
  Mem.stamp (fst p1) <: l1 = true ->
  Mem.stamp (fst p2) <: l2 = true ->
  low_equiv_atom o (Vptr p1, l1) (Vptr p2, l2) ->
  load p1 m1 = Some (o1,ll1) ->
  load p2 m2 = Some (o2,ll2) ->
  pcl <: o = true ->
  l1 <: ll1 = true ->
  l2 <: ll2 = true ->
  low_equiv_atom o (v1, lll1) (v2, lll2) ->
  store p1 (v1, join l1 lll1) m1 = Some m1' ->
  store p2 (v2, join l2 lll2) m2 = Some m2' ->
  equiv_mem o m1' m2'.
Proof.
  intros o m1 m2 [b1 ofs1] [b2 ofs2] pcl l1 l2 v1 v2 ll1 ll2 o1 o2 lll1 lll2 m1' m2'.
  intros [H H'] Hs1 Hs2 H0 H1 H2 Hlow H3 H4 H5 H6 H7. simpl in *.
  split.
  + { intros b Hb.
      unfold load, store in *. simpl in *.
      inv H0.
      - assert (Hs2': Mem.stamp b2 <: o = true) by (eauto with lat).
        generalize (H b2 Hs2'); intros T; inv T.
        * rewrite <- H8 in *; rewrite <- H10 in *; try congruence.
        * unfold Atom in *.
          repeat rewrite <- H8 in *; repeat rewrite <- H0 in *.
          repeat match goal with
                   | id: match ?o with | Some _ => _ | None => None end = Some _ |- _ =>
                     destruct o eqn:?E;[idtac|congruence]
                 end.
          rewrite (Mem.get_upd_frame _ _ _ _ _ _ _ H7).
          rewrite (Mem.get_upd_frame _ _ _ _ _ _ _ H6).
          destruct (equiv_dec b2 b) as [Eb|Eb].
          + constructor.
            eapply Forall2_update_Z; eauto.
          + auto.
      - unfold Atom in *.
        destruct (Mem.get_frame (A:=val _*Label) m1 b1) eqn:E1; try congruence.
        destruct (Mem.get_frame (A:=val _*Label) m2 b2) eqn:E2; try congruence.
        repeat match goal with
                 | id: match ?o with | Some _ => _ | None => None end = Some _ |- _ =>
                   destruct o eqn:?E;[idtac|congruence]
               end.
        rewrite (Mem.get_upd_frame _ _ _ _ _ _ _ H6).
        rewrite (Mem.get_upd_frame _ _ _ _ _ _ _ H7).
        destruct (equiv_dec b1 b);
          destruct (equiv_dec b2 b); subst.
        + constructor.
          eapply Forall2_update_Z with (8:= E0) (9:= E); eauto.
          inv e; inv e0.
          generalize (H b Hb); unfold Atom; rewrite E2; rewrite E1.
          intros T; inv T; auto.
        + inv e.
          transitivity (Mem.get_frame m1 b); auto.
          unfold Atom; rewrite E1.
          constructor.
          eapply update_list_Z_high with (4:=H1) (5:=E0); auto with lat.
          case_eq (ll1 <: o); auto.
          intros; assert (l1 <: o = true) by (eauto with lat).
          congruence.
        + inv e.
          transitivity (Mem.get_frame m2 b); auto.
          unfold Atom; rewrite E2.
          constructor.
          symmetry.
          eapply update_list_Z_high with (4:=H2) (5:=E); auto with lat.
          case_eq (ll2 <: o); auto.
          intros; assert (l2 <: o = true) by (eauto with lat).
          congruence. (* TODO : make a lattice lemma *)
        + auto.
    }
  + intros.
    unfold store in *.
    repeat match goal with
             | id: match ?o with | Some _ => _ | None => None end = Some _ |- _ =>
               destruct o eqn:?E;[idtac|congruence]
           end.
    erewrite (Mem.alloc_upd _ _ _ Local m1); eauto.
    symmetry.
    erewrite (Mem.alloc_upd _ _ _ Local m2); eauto.
    symmetry.
    apply H'; auto.
Qed.

Lemma store_high_equiv_mem: forall o m1 m2 l1 l2 o1 v p,
  l1 <: o = false ->
  l2 <: o = false ->
  load p m1 = Some (o1, l1) ->
  store p (v, l2) m1 = Some m2 ->
  equiv_mem o m1 m2.
Proof.
  unfold load, store; intros. destruct p as [b ofs]. simpl in *.
  destruct (Mem.get_frame m1 b) eqn:E1; try congruence.
  unfold Atom in *.
  destruct (update_list_Z ofs (v,l2) l) eqn:E2; try congruence.
  split.
  + intros b0 Hb.
    rewrite (Mem.get_upd_frame _ _ _ _ _ _ _ H2).
    destruct (equiv_dec b).
    - inv e.
      unfold Atom; rewrite E1; constructor.
      symmetry.
      eapply update_list_Z_high with (4:=H1) (5:=E2); eauto.
    - auto.
  + intros lbl fr Hl.
    symmetry.
    eapply (Mem.alloc_upd _ _ _ Local m1); eauto.
Qed.

Inductive low_equiv_full_state (o: Label) : @a_state Label -> @a_state Label -> Prop :=
| low_equiv_high:
  forall l1 l2 m1 m2 i stk1 stk2 pcv1 pcv2
    (Flowl1: l1 <: o = false)
    (Flowl2: l2 <: o = false)
    (LEm : equiv_mem o m1 m2)
    (LEsH : Forall2 (low_equiv_stkelt o) (below_lret o stk1) (below_lret o stk2)),
    low_equiv_full_state o
      (AState m1 i stk1 (pcv1,l1))
      (AState m2 i stk2 (pcv2,l2))
| low_equiv_low:
  forall l m1 m2 i stk1 stk2 pcv
    (Flowl: l <: o = true)
    (LEm : equiv_mem o m1 m2)
    (LEs : Forall2 (low_equiv_stkelt o) stk1 stk2),
    low_equiv_full_state o
      (AState m1 i stk1 (pcv,l))
      (AState m2 i stk2 (pcv,l)).
Hint Constructors low_equiv_full_state : core.

Global Instance low_state (o: Label) : @Equivalence (@a_state Label) (@low_equiv_full_state o).
Proof.
  constructor.
  (* reflexive *) intros x. destruct x. destruct apc.
  destruct (flows l o) eqn:?; auto.
  intros s s' Hss'.  inv Hss'.
  (constructor; eauto); symmetry ; eauto.
  (constructor 2; eauto) ; symmetry; eauto.
  (* transitive *)
  intros s s' s'' Hss' Hs's''.
  inv Hss' ; inv Hs's''.
  (constructor ; eauto); etransitivity; eauto.
  (constructor ; eauto); etransitivity; eauto.
  apply below_lret_low_equiv; auto.
  (constructor ; eauto); etransitivity; eauto.
  apply below_lret_low_equiv in LEs; auto.
  etransitivity; eauto.
  (constructor 2 ; eauto); etransitivity; eauto.
Qed.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_full_state _ _ _ => reflexivity
  end : core.

Lemma pc_labels1 : forall o s1 s2,
  low_equiv_full_state o s1 s2 ->
  low_pc o s1 ->
  low_pc o s2.
Proof.
  induction 1; intros. unfold low_pc in *;  simpl in *.
  inv H. congruence.
  unfold low_pc in *;  simpl in *. auto.
Qed.

Lemma pc_labels2 : forall o s1 s2,
  low_equiv_full_state o s1 s2 ->
  low_pc o s2 ->
  low_pc o s1.
Proof.
  induction 1; intros. unfold low_pc in *;  simpl in *.
  inv H. congruence.
  unfold low_pc in *;  simpl in *. auto.
Qed.

Lemma index_list_low_equiv_some: forall (A: Type) (R: relation A) n e l l',
  Forall2 R l l' ->
  index_list n l = None ->
  index_list n l' = Some e ->
  False.
Proof.
  induction n ; intros.
  destruct l' ; inv H ; simpl in *; try congruence.
  destruct l' ; inv H ; simpl in * ; try congruence.
  eapply IHn ; eauto.
Qed.

Lemma index_list_Z_low_equiv_some: forall (A: Type) (R: relation A) n e l l',
  Forall2 R l l' ->
  index_list_Z n l = None ->
  index_list_Z n l' = Some e ->
  False.
Proof.
  unfold index_list_Z. intros.
  destruct (n <? 0)%Z. congruence.
  eapply index_list_low_equiv_some; eauto.
Qed.

Inductive visible_event (o : Label) : @Event Label -> Prop :=
| ve_low : forall i l, l <: o = true -> visible_event o (EInt (i, l)).
Hint Constructors visible_event : core.

Lemma visible_event_dec : forall o e, {visible_event o e} + {~ visible_event o e}.
Proof.
  intros o [[x l]].
  destruct (l <: o) eqn: Hl; auto.
  right. intros H. inv H. congruence.
Defined.

End ObsEquiv.

Hint Resolve low_state : core.

Hint Constructors
  low_equiv_atom
  low_equiv_stkelt
  Forall2
  low_equiv_full_state : core.

Hint Extern 1 =>
  match goal with
    | |- low_equiv_atom _ _ _ => reflexivity
    | |- low_equiv_stkelt _ _ _ => reflexivity
    | |- Forall2 _ _ _ => reflexivity
    | |- equiv_mem _ _ _ => reflexivity
    | |- low_equiv_full_state _ _ _ => reflexivity
  end : core.

(** * Non-interference property *)

(** Instantiating the generic lockstep non-interference property for
    our particular abstract machine *)

Section ParamMachine.

Context {T: Type}.
Context {Latt: JoinSemiLattice T}.

Variable atable : ASysTable T.

Ltac exploit_low :=
    repeat match goal with
        | [H: Forall2 _ (_::_) (_::_) |- _ ] => inv H
        | [H: low_equiv_stkelt _ (AData _) (AData _) |- _ ] => inv H
        | [H: low_equiv_stkelt _ (ARet _ _) (ARet _ _) |- _ ] => inv H
    end.

Ltac spec_pop_return :=
  (exploit @pop_to_return_spec; eauto);
  let stk := fresh "stk" in
  let Hstk := fresh "Hstk" in
  (intros [? [? [? [? [Hstk ?]]]]]);
  match type of Hstk with
    | ?aastk = _ =>
      match goal with
        | [HH: pop_to_return aastk _ |- _ ] => (subst ; move_to_top HH)
      end
  end.

Inductive abstract_i_equiv (o : T) : relation (abstract_init_data T) :=
  | ai_equiv : forall p d1 d2 b
                      (STK : Forall2 (low_equiv_atom o) d1 d2),
                 abstract_i_equiv o (p,d1,b) (p,d2,b).

Global Program Instance AMObservation : TINI.Observation (abstract_machine atable) (Event T) := {
  out e := e;
  e_low := visible_event;
  e_low_dec := visible_event_dec;
  i_equiv := abstract_i_equiv
}.

Lemma low_equiv_step_pop_to_return: forall o  stk1 stk2,
  Forall2 (low_equiv_stkelt o) stk1 stk2 ->
  forall  rstk1 rstk2 ,
    pop_to_return stk1 rstk1 ->
    pop_to_return stk2 rstk2 ->
    Forall2 (low_equiv_stkelt o) rstk1 rstk2.
Proof.
  induction 1; intros.
  - invh @pop_to_return.
  - invh @pop_to_return.
    + invh @pop_to_return; eauto.
      invh low_equiv_stkelt.
    + invh (pop_to_return (x::l)); eauto.
      invh low_equiv_stkelt.
Qed.

Section fix_observer.
Variable o : T.
Notation "'<<' m i s pc '>>'" := (AState m i s pc).
Notation "m1 '~~m' m2" := (equiv_mem o m1 m2) (at level 20).
Notation "s1 '~~l' s2" := (Forall2 (low_equiv_stkelt o) s1 s2) (at level 20).
Notation "a1 '~~a' a2" := (low_equiv_atom o a1 a2) (at level 20).

Arguments low_pc {Label Latt} o s /.

Definition syscall_lowstep (SysTable:ASysTable T) := forall id sys_info,
  SysTable id = Some sys_info ->
  forall args1 args2 res1 res2,
    map AData args1 ~~l map AData args2 ->
    asi_sem sys_info args1 = Some res1 ->
    asi_sem sys_info args2 = Some res2 ->
    res1 ~~a res2.

Variable hyp_syscall_lowstep : syscall_lowstep atable.

Local Ltac go :=
  try congruence;
  try lia;
  auto using below_lret_low_equiv with lat;
  try apply below_lret_low_equiv;
  [> once (constructor; go) ..].

Local Ltac inv_equiv_atom :=
 match goal with
   | h: (_,_) ~~a (_,_) |- _ => inv h; simpl in *
  end.

Lemma a_alloc_high_step: forall size1 l1 a1 m1 b1 m1',
  a_alloc size1 l1 a1 m1 = Some (b1, m1') ->
  l1 <: o = false ->
  m1 ~~m m1'.
Proof.
  unfold a_alloc, alloc; intros size1 l1 a1 m1 b1 m1' H H0.
  destruct (zreplicate size1 a1) eqn:Ez1; try congruence; inv H.
  split.
  - intros b Hb.
    rewrite (Mem.alloc_get_frame _ _ _ _ _ _ _ _ _ H2).
    destruct (equiv_dec b1).
    + inv e.
      rewrite <- (Mem.alloc_stamp _ _ _ _ _ _ _ _ _ H2) in *.
      congruence.
    + reflexivity.
  - intros lbl fr Hf.
    destruct (Mem.alloc Local m1' lbl fr) as [b1' m1''] eqn:E1.
    destruct (Mem.alloc Local m1 lbl fr) as [b2 m2] eqn:E2.
    simpl.
    eapply (Mem.alloc_local_comm _ _ _ m1 m1' m1'' m2 m1); eauto.
    congruence.
Qed.

Lemma a_alloc_high: forall size1 l1 a1 m1 b1 m1' size2 l2 a2 m2 b2 m2',
  m1 ~~m m2 ->
  a_alloc size1 l1 a1 m1 = Some (b1, m1') ->
  a_alloc size2 l2 a2 m2 = Some (b2, m2') ->
  l1 <: o = false ->
  l2 <: o = false ->
  m1' ~~m m2'.
Proof.
  unfold a_alloc, alloc; intros size1 l1 a1 m1 b1 m1' size2 l2 a2 m2 b2 m2' H H0 H1 H2 H3.
  destruct (zreplicate size1 a1) eqn:Ez1; try congruence; inv H0.
  destruct (zreplicate size2 a2) eqn:Ez2; try congruence; inv H1.
  split.
  * intros b Hb.
    rewrite (Mem.alloc_get_frame _ _ _ _ _ _ _ _ _ H5).
    rewrite (Mem.alloc_get_frame _ _ _ _ _ _ _ _ _ H4).
    destruct (equiv_dec b1).
    - inv e.
      rewrite <- (Mem.alloc_stamp _ _ _ _ _ _ _ _ _ H5) in *.
      congruence.
    - destruct (equiv_dec b2).
      + inv e.
        rewrite <- (Mem.alloc_stamp _ _ _ _ _ _ _ _ _ H4) in *.
        congruence.
      + destruct H; auto.
  * intros lbl fr Hf.
    destruct (Mem.alloc Local m1' lbl fr) as [b3 m1''] eqn:T1.
    destruct (Mem.alloc Local m2' lbl fr) as [b4 m2''] eqn:T2.
    simpl.
    destruct (Mem.alloc Local m1 lbl fr) as [b5 m1'''] eqn:T3.
    assert (b5=b3).
      eapply (Mem.alloc_local_comm _ _ _ m1 m1' m1'' m1''' m1); eauto.
      congruence.
    destruct (Mem.alloc Local m2 lbl fr) as [b6 m2'''] eqn:T4.
    assert (b6=b4).
      eapply (Mem.alloc_local_comm _ _ _ m2 m2' m2'' m2''' m2); eauto.
      congruence.
    destruct H as [ _ H].
    generalize (H _ fr Hf).
    rewrite T3; rewrite T4; simpl; congruence.
Qed.

Lemma a_alloc_loc_same_block: forall size l a1 m1 b1 m1' a2 m2 b2 m2',
  m1 ~~m m2 ->
  a_alloc size l a1 m1 = Some (b1, m1') ->
  a_alloc size l a2 m2 = Some (b2, m2') ->
  l <: o = true ->
  b1 = b2.
Proof.
  unfold a_alloc, alloc; intros size l a1 m1 b1 m1' a2 m2 b2 m2' H H0 H1 H2.
  destruct (zreplicate size a1) eqn:Ez1; try congruence; inv H0.
  destruct (zreplicate size a2) eqn:Ez2; try congruence; inv H1.
  destruct H as [_ H].
  generalize (Mem.alloc_next_block_no_fr _ _ _ m1 l l0 l1).
  rewrite H4; simpl; intros.
  generalize (H l l1 H2).
  rewrite H3; rewrite <- H0; auto.
Qed.

Lemma low_equiv_replicate: forall (a1 a2:Atom T T),
  a1 ~~a a2 -> forall size,
  Forall2 (low_equiv_atom o)
          (replicate size a1) (replicate size a2).
Proof.
  induction size; constructor; auto.
Qed.

Lemma low_equiv_zreplicate: forall size (a1 a2:Atom T T),
  a1 ~~a a2 ->
  match_options (Forall2 (low_equiv_atom o))
                (zreplicate size a1) (zreplicate size a2).
Proof.
  unfold zreplicate; intros.
  destruct Z_lt_dec; constructor.
  apply low_equiv_replicate; auto.
Qed.

Lemma a_alloc_loc: forall size l a1 m1 b1 m1' a2 m2 b2 m2',
  m1 ~~m m2 ->
  a1 ~~a a2 ->
  a_alloc size l a1 m1 = Some (b1, m1') ->
  a_alloc size l a2 m2 = Some (b2, m2') ->
  l <: o = true ->
  m1' ~~m m2'.
Proof.
  unfold a_alloc, alloc; intros size l a1 m1 b1 m1' a2 m2 b2 m2' H Ha H0 H1 H2.
  assert (b1 = b2) by (eapply a_alloc_loc_same_block; eauto).
  subst.
  unfold Atom in *; destruct (zreplicate size a1) eqn:Ez1; try congruence; inv H0.
  destruct (zreplicate size a2) eqn:Ez2; try congruence; inv H1.
  split.
  * intros b Hb.
    rewrite (Mem.alloc_get_frame _ _ _ _ _ _ _ _ _ H4).
    rewrite (Mem.alloc_get_frame _ _ _ _ _ _ _ _ _ H3).
    destruct (equiv_dec b2).
    - inv e.
      unfold Atom in *.
      rewrite <- Ez1; rewrite <- Ez2.
      apply low_equiv_zreplicate; auto.
    - destruct H; auto.
  * intros lbl fr Hf.
    destruct (lbl == l).
    - inv e.
      eapply Mem.alloc2_local; eauto.
    - destruct (Mem.alloc Local m1' lbl fr) as [b1' m1''] eqn:E1.
      destruct (Mem.alloc Local m2' lbl fr) as [b2' m2''] eqn:E2.
      simpl.
      destruct (Mem.alloc Local m1 lbl fr) as [b1'' m1'''] eqn:E1'.
      destruct (Mem.alloc Local m2 lbl fr) as [b2'' m2'''] eqn:E2'.
      assert (b2'' = b2').
      eapply Mem.alloc_local_comm with (3:=H3) (4:=E2) (5:=E2'); eauto.
      assert (b1'' = b1').
      eapply Mem.alloc_local_comm with (3:=H4) (4:=E1) (5:=E1'); eauto.
      destruct H.
      generalize (H5 lbl fr Hf).
      rewrite E1'; rewrite E2'.
      simpl; congruence.
Qed.

Definition inv_atom (a:Atom T T) (guard:T) : Prop :=
  match a with
    | (Vint _,_) => True
    | (Vptr p, l) => Mem.stamp (fst p) <: l \_/ guard = true
  end.

Lemma inv_atom_weaken :
  forall v lv l lv' l',
    inv_atom (v, lv) l ->
    lv \_/ l <: lv' \_/ l' = true ->
    inv_atom (v, lv') l'.
Proof.
  intros [?|[b off]]; simpl; auto.
  intros.
  eapply flows_trans; eauto.
Qed.

Definition inv_mem m : Prop :=
  forall p a, load p m = Some a -> inv_atom a (Mem.stamp (fst p)).

Inductive inv_stk : list (StkElmt T T) -> T -> Prop :=
| istk_nil : forall lpc, inv_stk nil lpc
| istk_data : forall a stk lpc
                     (STK : inv_stk stk lpc)
                     (ATOM : inv_atom a lpc),
                inv_stk (AData a :: stk) lpc
| istk_ret : forall pc b stk lpc
                    (STK : inv_stk stk (snd pc)),
               inv_stk (ARet pc b :: stk) lpc.

Lemma inv_stk_weaken :
  forall stk l l',
    inv_stk stk l ->
    l <: l' = true ->
    inv_stk stk l'.
Proof.
  intros.
  induction H; constructor; eauto using inv_atom_weaken.
  destruct a.
  eapply inv_atom_weaken; eauto 2; auto with lat.
Qed.

Lemma inv_stk_pop_to_return :
  forall stk pcv pcl b pcl' stk',
    inv_stk stk pcl' ->
    pop_to_return stk (ARet (pcv, pcl) b :: stk') ->
    inv_stk stk' pcl.
Proof.
  intros stk pcv pcl b pcl' stk' H1 H2.
  induction stk as [|[a|pc' b'] stk IH].
  - inv H2.
  - inv H1. inv H2. auto.
  - inv H1. inv H2. auto.
Qed.

Inductive inv_state : @a_state T -> Prop :=
| inv_state_def: forall m i s pc lpc
    (IMEM: inv_mem m)
    (ISTACK: inv_stk s lpc),
    inv_state (AState m i s (pc,lpc)).

Definition systable_inv (table : ASysTable T) : Prop :=
  forall id args sc res lpc
         (SYS : table id = Some sc)
         (IARGS : forall a, In a args -> inv_atom a lpc)
         (RES : sc.(asi_sem) args = Some res),
    inv_atom res lpc.

Hypothesis table_systable_inv : systable_inv atable.

Lemma inv_add : forall xv1 xl1 xv2 xl2 lpc xr,
                  add xv1 xv2 = Some xr ->
                  inv_atom (xv1, xl1) lpc ->
                  inv_atom (xv2, xl2) lpc ->
                  inv_atom (xr, xl1 \_/ xl2) lpc.
Proof.
  intros xv1 xl1 xv2 xl2 lpc xr H1 H2 H3.
  destruct xv1 as [xv1|[b1 off1]], xv2 as [xv2|[b2 off2]]; simpl in *;
  inv H1; trivial; simpl.
  - rewrite <- join_assoc. auto with lat.
  - rewrite (join_comm xl1). rewrite <- join_assoc. auto with lat.
Qed.

Lemma inv_sub : forall xv1 xl1 xv2 xl2 lpc xr,
                  sub xv1 xv2 = Some xr ->
                  inv_atom (xv1, xl1) lpc ->
                  inv_atom (xv2, xl2) lpc ->
                  inv_atom (xr, xl1 \_/ xl2) lpc.
Proof.
  intros xv1 xl1 xv2 xl2 lpc xr H1 H2 H3.
  destruct xv1 as [xv1|[b1 off1]], xv2 as [xv2|[b2 off2]]; simpl in *;
  inv H1; trivial; simpl.
  - rewrite (join_comm xl1). rewrite <- join_assoc. auto with lat.
  - match goal with
      | H : (if ?B then _ else _) = Some _ |- _ =>
        destruct B as [E|_]; inv H; compute in E; subst b2
    end.
    rewrite <- (join_refl lpc).
    rewrite <- join_assoc. rewrite (join_assoc xl2).
    rewrite (join_comm _ lpc).
    rewrite join_assoc.
    auto with lat.
Qed.

Lemma inv_alloc_mem :
  forall size sizel pcl a m b m'
         (ALLOC : a_alloc size (sizel \_/ pcl) a m = Some (b, m'))
         (ATOM : inv_atom a pcl)
         (MEM : inv_mem m),
    inv_mem m'.
Proof.
  intros.
  intros [b' off] a' LOAD. unfold a_alloc in ALLOC. simpl.
  erewrite load_alloc in LOAD; eauto.
  repeat match goal with
           | H : (if ?B then _ else _) = Some _ |- _ =>
             destruct B as [E|_] || destruct B; try solve [inv H]
         end.
  - compute in E. subst b'. inv LOAD.
    unfold alloc in ALLOC.
    destruct (zreplicate size a'); try discriminate.
    inv ALLOC.
    assert (STAMP : Mem.stamp b = sizel \_/ pcl) by eauto using Mem.alloc_stamp.
    rewrite STAMP. clear STAMP.
    destruct a' as [v' l']. clear - ATOM.
    eapply inv_atom_weaken; eauto 2.
    rewrite join_assoc. rewrite (join_comm l' sizel). rewrite <- join_assoc.
    auto with lat.
  - eapply MEM in LOAD. eauto.
Qed.

Lemma inv_alloc_res :
  forall size (sizel pcl : T) a m b m'
         (ALLOC : a_alloc size (sizel \_/ pcl) a m = Some (b, m')),
    inv_atom (Vptr (b, 0)%Z, sizel) pcl.
Proof.
  intros.
  unfold a_alloc, alloc in ALLOC.
  destruct (zreplicate size a); try discriminate.
  simpl. inv ALLOC.
  assert (E : Mem.stamp b = sizel \_/ pcl) by eauto using Mem.alloc_stamp.
  rewrite E. auto with lat.
Qed.

Lemma inv_store :
  forall p addrl xv xl pcl m m',
    inv_mem m ->
    inv_atom (xv, xl) pcl ->
    store p (xv, addrl \_/ pcl \_/ xl) m = Some m' ->
    inv_mem m'.
Proof.
  intros p addrl xv xl pcl m m' H1 H3 H4 p' a LOAD.
  erewrite load_store in LOAD; eauto.
  destruct (equiv_dec p p') as [E | E].
  - compute in E. subst p'. inv LOAD.
    eapply inv_atom_weaken; eauto 2. auto with lat.
  - apply H1. trivial.
Qed.

Lemma inv_stk_inv :
  forall s1 s2 pcl
         (DATA : forall se, In se s1 -> exists a, se = AData a)
         (INV : inv_stk (s1 ++ s2) pcl),
    (forall se, In se s1 -> exists a, se = AData a /\ inv_atom a pcl) /\
    inv_stk s2 pcl.
Proof.
  intros s1 s2 pcl DATA INV.
  induction s1 as [|se s1 IH]; simpl in *.
  - split; trivial.
    intuition.
  - inv INV; eauto.
    + exploit IH; eauto.
      intros [H1 H2].
      split; intuition eauto.
    + specialize (DATA _ (or_introl eq_refl)). destruct DATA. congruence.
Qed.

Lemma inv_stk_app :
  forall s1 s2 pcl
         (INV1 : forall se, In se s1 -> exists a, se = AData a /\ inv_atom a pcl)
         (INV2 : inv_stk s2 pcl),
    inv_stk (s1 ++ s2) pcl.
Proof.
  intros.
  induction s1 as [|se s1 IH]; simpl; trivial.
  exploit IH.
  { intros. apply INV1. intuition. }
  intros H.
  specialize (INV1 _ (or_introl eq_refl)).
  destruct INV1 as (? & ? & ?). subst.
  constructor; eauto.
Qed.

Lemma inv_step : forall as1 e as1',
  inv_state as1 ->
  a_step atable as1 e as1' ->
  inv_state as1'.
Proof.
  intros as1 e as1' Hi Hs.
  inv Hs; inv Hi; constructor;
  try assumption;
  repeat match goal with
           | H : inv_stk (_ :: _) _ |- _ => inv H
         end;
  try match goal with
        | |- inv_stk _ _ => constructor
      end;
  eauto using inv_add, inv_sub, inv_alloc_mem, inv_alloc_res,
              inv_store, inv_stk_weaken, inv_stk_pop_to_return,
              inv_atom_weaken;
  try solve [simpl; auto];
  try (exploit IMEM; [solve [eauto]|]).
  - apply index_list_In in IDX.
    eapply inv_stk_inv in DATA; eauto.
    destruct DATA as [H1 H2].
    edestruct H1 as (? & ? & ?); eauto. subst.
    constructor; eauto.
  - eapply inv_stk_inv in DATA; eauto.
    destruct DATA as [DATA INV].
    eapply inv_stk_app; eauto.
    eapply swap_forall; eauto.
  - simpl in ATOM. clear - ATOM. intros H.
    eapply inv_atom_weaken; eauto 2.
    rewrite (join_comm addrl). rewrite <- join_assoc.
    auto with lat.
  - eapply inv_stk_inv in ARGS; eauto.
    destruct ARGS as [ARGS INV].
    eapply inv_stk_app.
    + intros se IN. apply ARGS in IN.
      destruct IN as (a & ? & INV'). subst.
      eexists a. split; trivial.
      rewrite (surjective_pairing a) in *.
      eapply inv_atom_weaken in INV'; eauto.
      auto with lat.
    + constructor. eauto.
  - eapply inv_stk_inv in ISTACK; intuition eauto.
    rewrite in_map_iff in H. destruct H as (? & ? & ?). subst. eauto.
  - eapply table_systable_inv; eauto.
    clear - ISTACK.
    intros a H.
    induction args as [|a' args IH]; simpl in *; intuition; subst;
    inv ISTACK; auto.
Qed.

Lemma swap_low_equiv :
  forall T (R : T -> T -> Prop) n (l1 l1' l2 l2' : list T)
         (SWAP1 : swap n l1 = Some l1')
         (SWAP2 : swap n l2 = Some l2')
         (LEQUIV : Forall2 R l1 l2),
    Forall2 R l1' l2'.
Proof.
  unfold swap.
  intros.
  destruct l1 as [|y1 l1]; try congruence.
  destruct l2 as [|y2 l2]; try congruence.
  destruct (index_list n (y1 :: l1)) as [x1|] eqn:IDX1; try congruence.
  destruct (index_list n (y2 :: l2)) as [x2|] eqn:IDX2; try congruence.
  destruct n as [|n]; simpl in *; allinv; auto.
  inv LEQUIV.
  repeat match goal with
           | H : (match ?b with _ => _ end) = Some _ |- _ =>
             destruct b eqn:?; simpl in *; try congruence
         end;
  allinv.
  constructor.
  - eapply index_list_low_eq; eauto.
  - eapply update_list_low_gen; eauto.
Qed.

Lemma lowstep : forall as1 e as1' as2 e' as2',
  low_equiv_full_state o as1 as2 ->
  low_pc o as1  ->
  a_step atable as1 e as1' ->
  a_step atable as2 e' as2' ->
  inv_state as1 ->
  inv_state as2 ->
  low_equiv_full_state o as1' as2'.
Proof.
  intros as1 e as1' as2 e' as2' He Hpc Hs1 Hs2 Hi1 Hi2.
  inv He. inv Hpc; congruence.

  inv Hs1; inv Hs2; try congruence;
  match goal with
    | H1 : ?x = _,
      H2 : ?x = _ |- _ =>
      rewrite H1 in H2; inv H2
  end;

  exploit_low; try (repeat inv_equiv_atom; go).

  - (* Add *)
    assert (Hmemv: low_equiv_atom o (xv, x1l \_/ x2l) (xv0, x1l0 \_/ x2l0)) by
      (eapply low_equiv_atom_binop_value; eauto).
    inv Hmemv; go.

  - (* Sub *)
    assert (Hmemv: low_equiv_atom o (xv, x1l \_/ x2l) (xv0, x1l0 \_/ x2l0)) by
      (eapply low_equiv_atom_binop_value; eauto).
    inv Hmemv; go.

  - (* Dup *)
    eapply low_equiv_low; eauto.
    constructor; auto.
    exploit index_list_low_eq; eauto using index_list_app.

  - (* Swap *)
    eapply low_equiv_low; eauto.
    clear DATA DATA0 INSTR Hi1 Hi2 Hpc.
    eapply swap_app with (l2 := s3) in SWAP0.
    eapply swap_app with (l2 := s2) in SWAP.
    eapply swap_low_equiv; eauto.

  - (* Alloc *)
    assert (m' ~~m m'0).
    + inv_equiv_atom.
      * eapply a_alloc_loc with (3:=ALLOC) (4:=ALLOC0); eauto with lat.
      * eapply a_alloc_high; eauto with lat.
    + inv_equiv_atom; try go.
      assert (b=b0).
      * eapply a_alloc_loc_same_block with (2:=ALLOC) (3:=ALLOC0); eauto with lat.
      * subst.
        go.

  - (* Load *)
    inv_equiv_atom; try go.
    (* Load from low addresses *)
    assert (Mem.stamp (fst p0) <: addrl0 \_/ l = true).
    { inv Hi2. inv ISTACK. simpl in *. trivial. }
    assert (Hmemv: low_equiv_atom o (xv, xl) (xv0, xl0)) by
        (eapply load_equiv_mem; eauto with lat).
    inv Hmemv; go.

  - (* Store *)
    assert (Mem.stamp (fst p0) <: addrl0 \_/ l = true).
    { inv Hi2. inv ISTACK. simpl in *. trivial. }
    assert (Mem.stamp (fst p) <: addrl \_/ l = true).
    { inv Hi1. inv ISTACK. simpl in *. trivial. }
    repeat inv_equiv_atom;
    assert (m' ~~m m'0) by (
      eapply store_equiv_mem with (11:= STORE) (12:= STORE0);
      eauto with lat);
    go.

  - (* Call *)
    exploit Forall2_app_left ; eauto; intros Hl.
    exploit Forall2_app_right ; eauto; intros Hr.
    inv_equiv_atom.
    + (* Low Call *)
       constructor 2; eauto with lat.
       eapply Forall2_app ; eauto.

    + (* High Call *)
       constructor; auto with lat.
       rewrite below_lret_adata ; eauto.
       rewrite below_lret_adata ; eauto.
       simpl; rewrite Flowl; go.

  - (* Ret *)
    spec_pop_return.
    spec_pop_return.
    exploit low_equiv_step_pop_to_return; eauto; intros HspecRet.
    inv HspecRet.
    exploit_low.
    inv_equiv_atom; go.

  - (* VRet *)
    spec_pop_return.
    spec_pop_return.
    exploit low_equiv_step_pop_to_return; eauto; intros HspecRet.
    exploit_low.
    repeat inv_equiv_atom; go.

  - (* SysCall *)
    assert (sys_info0 = sys_info) by congruence. subst. clear SYS0.
    assert (EQ : map AData args ~~l map AData args0 /\ s ~~l s0).
    { split.
      - eapply Forall2_app_left; eauto.
        repeat rewrite map_length. congruence.
      - eapply Forall2_app_right; eauto.
        repeat rewrite map_length. congruence. }
    destruct EQ as [EQ1 EQ2].
    specialize (hyp_syscall_lowstep SYS args args0 EQ1 SYSSEM SYSSEM0).
    go.

  - (* SizeOf *)
    inv LEa.
    + assert (LEN : length fr = length fr0).
      { inv Hi1. inv ISTACK.
        simpl in *.
        destruct LEm as [LOWF _].
        assert (STAMP : Mem.stamp (fst p0) <: o = true) by eauto with lat.
        exploit LOWF; eauto. intros FRAMES.
        rewrite FRAME in FRAMES. rewrite FRAME0 in FRAMES.
        inv FRAMES. eapply Forall2_length; eauto. }
      rewrite LEN. clear LEN.
      go.
    + go.
Qed.

Lemma all_data_below_lret :
  forall o s1 s2
         (DATA : forall se, In se s1 -> exists a, se = AData a),
    below_lret o (s1 ++ s2) = below_lret o s2.
Proof.
  induction s1 as [|se' s1 IH]; intros; simpl; auto.
  destruct DATA with (se := se'); simpl; auto.
  subst.
  apply IH.
  intros se H.
  apply DATA.
  simpl. auto.
Qed.

Lemma highstep : forall as1 e as1',
  ~low_pc o as1 ->
  a_step atable as1 e as1' ->
  ~low_pc o as1' ->
  low_equiv_full_state o as1 as1'.
Proof.
  intros as1 e as1' Hpc Hs Hpc'.
  destruct as1. destruct apc. simpl in *.
  assert (t <: o = false) by (destruct (flows t o) eqn:E; congruence).
  clear Hpc. inv Hs; try go.

  - (* Dup *)
    constructor; auto.
    match goal with
      | SE : StkElmt T T |- _ =>
        destruct DATA with (se := SE); eauto
    end.
    subst.
    simpl.
    reflexivity.

  - (* Swap *)
    constructor; auto.
    repeat (rewrite all_data_below_lret; eauto).
    eapply swap_forall; eauto.

  - (* Alloc *)
    simpl in Hpc'.
    assert (amem ~~m m').
    + eapply a_alloc_high_step; eauto with lat.
    + go.
  - (* Store *)
    destruct (flows ml o) eqn:?.
    + (* ml <: o = true *)
      assert (t <: o = true) by eauto with lat.
      congruence.
    + (* ml <: o = false *)
      assert (amem ~~m m') by
        (eapply store_high_equiv_mem with (3:= LOAD) (4:= STORE); eauto with lat).
      constructor; eauto.

  - (* Call *)
    constructor; eauto with lat.
    simpl.
    erewrite below_lret_adata; [idtac|eauto].
    erewrite below_lret_adata; [idtac|eauto].
    simpl in *.
    destruct (t<:o) eqn:Hc; go.

  - (* Ret *)
    spec_pop_return.
    simpl in *.
    exploit @pop_to_return_spec2; eauto. intros HTEMP. inv HTEMP.
    exploit @pop_to_return_spec3; eauto. intros HTEMP. inv HTEMP.
    destruct (flows pcl' o) eqn:e; try congruence.
    constructor ; eauto.
    rewrite below_lret_adata; eauto.
    simpl. rewrite e.
    auto.

 - (* VRet *)
    spec_pop_return.
    exploit @pop_to_return_spec2; eauto. intros HTEMP. inv HTEMP.
    exploit @pop_to_return_spec3; eauto. intros HTEMP. inv HTEMP.
    simpl in *.
    destruct (flows pcl' o) eqn:e; try congruence.
    constructor ; eauto.
    simpl.
    rewrite below_lret_adata; eauto.
    simpl. rewrite e.
    auto.

 - (* SysCall *)
   constructor; try congruence; try reflexivity.
   simpl.
   rewrite all_data_below_lret; try reflexivity.
   intros se IN.
   rewrite in_map_iff in IN. destruct IN as (a & ? & ?). eauto.

Qed.

Lemma highlowstep : forall as1 e as1' as2 e' as2',
  low_equiv_full_state o as1 as2 ->
  ~low_pc o as1 ->
  a_step atable as1 e as1' ->
  low_pc o as1' ->
  a_step atable as2 e' as2' ->
  low_pc o as2' ->
  low_equiv_full_state o as1' as2'.
Proof.
  intros as1 e as1' as2 e' as2' Heq Hpc Hs1 Hpc' Hs2 Hpc''.
  inv Heq; [clear Hpc | elim Hpc; simpl ; auto].

  exploit a_step_instr; eauto. intros [instr1 Hinstr1].

  (* instr1 is Ret or VRet *)
  inv Hs1; simpl in *;
  try assert (l1 <: o = true) by (eapply join_2_rev; eassumption);
  try congruence;
  inv Hs2; simpl in *;
  try assert (l2 <: o = true) by (eapply join_2_rev; eassumption);
  try congruence.

  - (* P1 is Ret and P2 is Ret *)
    spec_pop_return.
    revert POP0.
    spec_pop_return.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP.
    intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.
    inv_equiv_atom; go.

  - (* P1 is Ret and P2 is Vret; contradiction *)
    spec_pop_return.
    revert POP0.
    spec_pop_return.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP.
    intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.

  - (* P1 is VRet and P2 is Ret; *)
    spec_pop_return.
    revert POP0.
    spec_pop_return.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP.
    intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.

  - (* P1 is Vret and P2 is Vret *)
    spec_pop_return.
    revert POP0.
    spec_pop_return.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP.
    intros POP0.
    exploit @pop_to_return_spec2; eauto; intros Temp; inv Temp.
    exploit @pop_to_return_spec3; eauto; intros Temp; inv Temp.
    clear POP0.
    rewrite below_lret_adata in LEsH; eauto.
    rewrite below_lret_adata in LEsH; eauto.
    revert LEsH; simpl.
    rewrite Hpc'; rewrite Hpc''.
    intros Temp; inv Temp.
    exploit_low.
    inv_equiv_atom; go.
Qed.

End fix_observer.

Lemma Forall2_map : forall E1 E2
                           (R1: relation E1)
                           (R2: relation E2)
                           g f (l1 l2: list E1),
                      (forall x y, R1 x y -> R2 (f x) (g y)) ->
                      Forall2 R1 l1 l2 ->
                      Forall2 R2 (map f l1) (map g l2).
Proof.
  induction 2; intros; simpl; auto.
Qed.

Lemma below_lret_alldata :
  forall o l,
    (forall e, In e l -> exists a, e = AData a) ->
    (below_lret o l) = nil.
Proof.
  induction l ; intros.
  auto.
  destruct a ; simpl. eapply IHl ; eauto.
  intros ; eapply H ; eauto. constructor 2; auto.
  eelim (H (ARet p b)) ; eauto.
  congruence. constructor; auto.
Qed.

Lemma map_AData :
  forall T (l: list (Z* T)) e,
   In e (map (fun a : Z * T => let (i,lbl) := a in AData (Vint i,lbl)) l) -> exists a : Atom T T, e = AData a.
Proof.
  induction l ; intros; inv H; eauto.
  destruct a.
  eauto.
Qed.

Lemma map_AData' :
  forall T (l: list (Z* T)) (e:StkElmt T T),
   In e (map (fun a : Z * T => let (i,lbl) := a in AData (Vint i,lbl)) l) ->
   exists (i:Z) (lbl:T), e = AData (Vint i,lbl).
Proof.
  induction l ; intros; inv H; eauto.
  destruct a.
  eauto.
Qed.

Program Instance AMUnwindingSemantics
  (SL : forall o, syscall_lowstep o atable)
  (SI : systable_inv atable) :
  TINI.UnwindingSemantics AMObservation := {
  s_equiv := low_equiv_full_state;
  s_low := low_pc;
  s_low_dec := low_pc_dec;
  s_inv := inv_state
}.

Next Obligation.
  inv H.
  destruct (flows b o) eqn:?.
  constructor 2; eauto.
  eapply Forall2_map; eauto.
  destruct x; destruct y; simpl.
  intros.
  inv H; repeat econstructor; eauto.
  constructor ; eauto.
  rewrite below_lret_alldata; eauto.
  rewrite below_lret_alldata; eauto.
  apply map_AData.
  apply map_AData.
Qed.

Next Obligation.
  intros x y H. rewrite <- H. reflexivity.
Qed.

Next Obligation.
  inv H; split; intros H; inv H; try congruence;
  unfold low_pc; simpl; trivial.
Qed.

Next Obligation.
  destruct i as [[p d] b].
  constructor.
  - intros p' a.
    unfold load; intros.
    rewrite Mem.get_empty in H; discriminate.
  - induction d as [|[a l] d IH]; simpl; try constructor; simpl; trivial.
Qed.

Next Obligation.
  eapply inv_step; eauto.
Qed.

Next Obligation.
  unfold low_pc.
  inv H; simpl;
  try match goal with
        | H : visible_event _ _ |- _ =>
          inv H
      end.
  eauto with lat.
Qed.

Next Obligation.
  inv H1; inv H2;
  try solve [ [> once (econstructor; intros H'; inv H'; solve [eauto]) ..]];
  match goal with
    | H : low_equiv_full_state _ _ _ |- _ =>
      inv H
  end;
  match goal with
    | H : low_pc _ _ |- _ =>
      unfold low_pc in H; simpl in H; try congruence
  end;
  try solve [
        constructor; intros H; inv H;
        match goal with
          | H1 : ?pcl <: ?o = false,
            H2 : ?l \_/ ?pcl <: ?o = true |- _ =>
            apply join_2_rev in H2; congruence
        end
      ];
  try congruence.
  exploit_low.
  inv LEa; try reflexivity.
  constructor 5; intros H; inv H;
  match goal with
    | H : ?l \_/ ?pcl <: ?o = true |- _ =>
      apply join_1_rev in H; congruence
  end.
Qed.

Next Obligation.
  eapply lowstep; eauto.
Qed.

Next Obligation.
  rewrite <- H0.
  symmetry.
  eapply highstep; eauto.
Qed.

Next Obligation.
  eapply highlowstep; eauto.
Qed.

Theorem abstract_noninterference_short
  (SL : forall o, syscall_lowstep o atable)
  (SI : systable_inv atable) :
  TINI.tini AMObservation.
Proof.
  apply TINI.noninterference.
  apply AMUnwindingSemantics; assumption.
Qed.

End ParamMachine.


(** * Halting problem for the call-by-value lambda-calculus HaltL  *)

(* * The call-by-value lambda calculus L *)

(* ** Syntax   *)

(* The terms of L are the terms of the full lambda-calculus, using de Bruijn encoding  *)
Inductive term : Type :=
| var (n : nat) : term
| app (s : term) (t : term) : term
| lam (s : term).

(* We define a simple, capturing substitution operation *)
Fixpoint subst (s : term) (k : nat) (u : term) :=
  match s with
      | var n => if Nat.eqb n k then u else var n
      | app s t => app (subst s k u) (subst t k u)
      | lam s => lam (subst s (S k) u)
  end.

(* ** Evaluation   *)

(* Big-step evaluation is weak (no evaluations below abstractions) and call-by-value (arguments are fully evaluated when pased) *)
Inductive eval : term -> term -> Prop :=
| eval_abs s : eval (lam s) (lam s)
| eval_app s u t t' v :
    eval s (lam u) -> eval t t' -> eval (subst u 0 t') v -> eval (app s t) v.

(* The L-halting problem  *)
Definition HaltL (s : term) := exists t, eval s t.

(* Scott encoding of natural numbers  *)
Fixpoint nat_enc (n : nat) :=
  match n with
  | 0 => lam (lam (var 1))
  | S n => lam (lam (app (var 0) (nat_enc n)))
  end.

(* ** L-computable relations  *)

Require Import Vector.

Definition L_computable {k} (R : Vector.t nat k -> nat -> Prop) :=
  exists s, forall v : Vector.t nat k,
      (forall m, R v m <-> L.eval (Vector.fold_left (fun s n => L.app s (nat_enc n)) s v) (nat_enc m)) /\
      (forall o, L.eval (Vector.fold_left (fun s n => L.app s (nat_enc n)) s v) o -> exists m, o = nat_enc m).


Require Import Coq.Bool.Bool.
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.Lists.List.
Require Import Coq.omega.Omega.
Require Import Imp.
Require Import Maps.
Require Import Hoare.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import SepLogic.

Example test : forall x y s h,
    x = Id 1 -> y = Id 2 ->
    s = st_update (st_update (fun _ => 0) x 1) y 2 ->
    h = h_update emp_heap 1 10 ->
    (((AId x) |-> (ANum 10) \\// (AId y) |-> (ANum 20)) --* (((AId x) |-> (ANum 10)) ** ((AId y) |-> (ANum 20)))) (s, h).
Proof.
  intros. unfold simp. intros. simpl in *.
  unfold s_disj in H4. destruct H4.
  - unfold pto in H4. simpl in H4. rewrite H1 in H4.
    subst. unfold st_update in H3. simpl in H3. unfold disjoint in H3.
    destruct (H3 1).
    + unfold not_in_dom in H. unfold h_update in H.
      simpl in H. inversion H.
    + unfold not_in_dom in H. unfold h_update in H.
      simpl in H. inversion H.
  - unfold pto in H4. simpl in *. subst.
    unfold st_update in H3. simpl in H3.
    unfold st_update; simpl.
    exists (h_update emp_heap 1 10).
    exists ( h_update emp_heap 2 20).
    split. unfold disjoint in *. intros. destruct (H3 l).
    right. assumption. left. assumption.
    auto.
Qed.

Axiom excluded_middle : forall P,
    P \/ (~P).

(* Extend Hoare Logic by separation logic *)
Notation "'SKIP'" :=
  SCSkip.
Notation "x '::=' a" :=
  (SCAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (SCSeq c1 c2) (at level 80, right associativity).
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (SCIf b c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (SCWhile b c) (at level 80, right associativity).
Notation "'Cons' X e1 e2" :=
  (SCCons X e1 e2) (at level 60, right associativity).
Notation "'Lookup' X e" :=
  (SCLookup X e) (at level 60, e at next level, right associativity).
Notation "'[' e1 ']' '::=' e2" :=
  (SCMutation e1 e2) (at level 60, e1 at next level, e2 at next level,
                      right associativity).
Notation "'Dispose' e" :=
  (SCDispose e) (at level 60, e at next level, right associativity).

(* The list of the variables that have been changed *)
Fixpoint modified_scom_var (c : scom) : list id :=
  match c with
  | SCSkip => nil
  | SCAss x a => x :: nil
  | SCSeq c1 c2 => (modified_scom_var c1) ++ (modified_scom_var c2)
  | SCIf b c1 c2 =>
    (modified_scom_var c1) ++ (modified_scom_var c2)
  | SCWhile b c => modified_scom_var c
  | SCCons x e1 e2 => x :: nil
  | SCLookup x e => x :: nil
  | SCMutation e1 e2 => nil
  | SCDispose e => nil
  end.

(* The list of the location that have been changed *)
Fixpoint modified_scom_loc (c : scom) : list aexp :=
  match c with
  | SCSkip => nil
  | SCAss x a => nil
  | SCSeq c1 c2 => (modified_scom_loc c1) ++ (modified_scom_loc c2)
  | SCIf b c1 c2 =>
    (modified_scom_loc c1) ++ (modified_scom_loc c2)
  | SCWhile b c => modified_scom_loc c
  | SCCons x e1 e2 => nil
  | SCLookup x e => nil
  | SCMutation e1 e2 => e1 :: nil
  | SCDispose e => e :: nil
  end.

(* Here we define the variables that free in assertion P *)
Definition inde (l : list id) (P : sass) :=
  forall s h,
    (forall x v, In x l ->
                 (P (s, h) <-> P (st_update s x v, h))).

(* There are some lemmas to help us in the next step *)
Lemma inde_seq : forall c1 c2 R,
    inde (modified_scom_var (c1 ;; c2)) R ->
    inde (modified_scom_var c1) R /\ inde (modified_scom_var c2) R.
Proof.
  intros. unfold inde in H. split.
  - unfold inde. intros. simpl in *.
    assert (In x (modified_scom_var c1 ++ modified_scom_var c2)).
    {
      apply in_or_app. left. assumption.
    }
    apply (H s h x v) in H1. assumption.
  - unfold inde. intros. simpl in *.
    assert (In x (modified_scom_var c1 ++ modified_scom_var c2)).
    {
      apply in_or_app. right. assumption.
    }
    apply (H s h x v) in H1. assumption.
Qed.

Lemma inde_if : forall b c1 c2 R,
    inde (modified_scom_var (IFB b THEN c1 ELSE c2 FI)) R ->
    inde (modified_scom_var c1) R /\ inde (modified_scom_var c2) R.
Proof.
  intros. simpl in *. unfold inde in *. split.
  - intros.
    assert (In x (modified_scom_var c1 ++ modified_scom_var c2)).
    {
      apply in_or_app. auto.
    }
    apply (H s h x v) in H1. assumption.
  - intros.
    assert (In x (modified_scom_var c1 ++ modified_scom_var c2)).
    {
      apply in_or_app. auto.
    }
    apply (H s h x v) in H1. assumption.
Qed.

(* Here we have to explain that if an assertion R doesn't mention any variable modified by c, then the R still support *)
Theorem mention_modified_free : forall st st' c R,
    inde (modified_scom_var c) R ->
    big_step (c, st) (St st') ->
    (forall h1, R (fst st, h1) -> R (fst st', h1)).
Proof.
  intros st st' c R Hinde Hstep.
  remember (c, st) as comst. remember (St st') as est.
  generalize dependent st. generalize dependent st'.
  generalize dependent c. induction Hstep; intros.
  - (* SKIP *) inversion Heqcomst; subst. inversion Heqest; subst.
    clear Heqcomst. clear Heqest. assumption.
  - (* Asg *) inversion Heqcomst; subst. inversion Heqest; subst.
    clear Heqcomst. clear Heqest. simpl in *.
    unfold inde in Hinde.
    assert (In X (X :: nil)).
    {
      unfold In. left. reflexivity.
    }
    apply (Hinde s h1 X (aeval s e)) in H. apply H. assumption.
  - (* SeqAb *) inversion Heqest.
  - (* Seq *) inversion Heqcomst; subst. clear Heqcomst.
    apply inde_seq in Hinde. destruct Hinde.
    apply IHHstep1
    with (c := c1) (st'0 := st') (st := st0) (h1 := h1) in H0; auto.
    apply IHHstep2
    with (c := c2) (st'1 := st'0) (st := st') (h1 := h1) in H1; auto.
  - (* If_true *) inversion Heqcomst; subst. clear Heqcomst.
    apply inde_if in Hinde. destruct Hinde.
    apply IHHstep with (st'0 := st') (st := (s, h)) (h1 := h1) in H1;
      auto.
  - (* If_false *) inversion Heqcomst; subst. clear Heqcomst.
    apply inde_if in Hinde. destruct Hinde.
    apply IHHstep with (st'0 := st') (st := (s, h)) (h1 := h1) in H2;
      auto.
  - (* WHILE_end *) inversion Heqest; subst. inversion Heqcomst; subst.
    assumption.
  - (* WHILE_Ab *) inversion Heqest.
  - (* WHILE_Loop *) inversion Heqcomst; subst. clear Heqcomst.
    simpl in H0.
    assert (inde (modified_scom_var (WHILE b DO c END)) R) by assumption.
    simpl in H1.
    apply IHHstep1 with
    (st' := (s', h')) (st := (s, h)) (h1 := h1) in H1; auto.
    simpl in H1.
    apply IHHstep2 with
    (st'0 := st') (st := (s', h')) (h1 := h1) in Hinde; auto.
  - (* Cons *) inversion Heqcomst; subst. inversion Heqest; subst.
    clear Heqest. clear Heqcomst. simpl in *. unfold inde in Hinde.
    assert (In X (X :: nil)).
    {
      unfold In. auto.
    }
    apply (Hinde s h1 X l) in H1. apply H1. assumption.
  - (* Lookup *) inversion Heqest; subst. inversion Heqcomst; subst.
    clear Heqest. clear Heqcomst. simpl in *. unfold inde in Hinde.
    assert (In X (X :: nil)).
    {
      unfold In. auto.
    }
    apply (Hinde s h1 X n) in H. apply H. assumption.
  - (* LookupAb *) inversion Heqest.
  - (* Mutation *) inversion Heqcomst; subst. inversion Heqest; subst.
    clear Heqcomst. clear Heqest. simpl in *. assumption.
  - (* MutationAb *) inversion Heqest.
  - (* Dispose *) inversion Heqcomst; subst. inversion Heqest; subst.
    clear Heqcomst. clear Heqest. simpl in *. assumption.
  - (* DisposeAb *) inversion Heqest.
Qed.

Definition safeAt_bs (c : scom) (s : sstate) :=
  ~ (big_step (c, s) (Abt)).
(*
  forall est, big_step (c, s) est -> exists st, est = St st.
*)

Definition safty_Mono_bs (c : scom) :=
  forall s h1 h2, safeAt_bs c (s, h1) -> disjoint h1 h2 ->
                  safeAt_bs c (s, h_union h1 h2).

Definition frame_bs (c : scom) :=
  forall s s' h1 h2 h',
    safeAt_bs c (s, h1) -> disjoint h1 h2 ->
    big_step (c, (s, h_union h1 h2)) (St (s', h')) ->
    (exists h1', big_step (c, (s, h1))(St (s', h1')) /\ disjoint h1' h2 /\
                 h_union h1' h2 = h').

Lemma safeAt_bs_seq : forall s h c1 c2,
    safeAt_bs (c1 ;; c2) (s, h) -> safeAt_bs c1 (s, h).
Proof.
  intros. unfold safeAt_bs, not in *. intro.
  assert (big_step (c1;; c2, (s, h)) Abt).
  {
    apply BS_SeqAb. assumption.
  }
  apply H in H1. inversion H1.
Qed.

Lemma safeAt_bs_seq2 : forall s h c1 c2 st,
    safeAt_bs (c1 ;; c2) (s, h) -> big_step (c1, (s, h)) (St st) ->
    safeAt_bs c2 st.
Proof.
  intros. unfold safeAt_bs, not in *. intro.
  assert (big_step (c1;; c2, (s, h)) Abt).
  {
    apply BS_Seq with st; assumption.
  }
  apply H in H2. inversion H2.
Qed.

Lemma safeAt_bs_if : forall s h b c1 c2,
    safeAt_bs (IFB b THEN c1 ELSE c2 FI) (s, h) /\ beval s b = true ->
    safeAt_bs c1 (s, h).
Proof.
  intros. unfold safeAt_bs, not in *. intro. destruct H.
  apply (BS_IfTrue b c1 c2 s h Abt) in H1; auto.
Qed.

Lemma safeAt_bs_if2 : forall s h b c1 c2,
    safeAt_bs (IFB b THEN c1 ELSE c2 FI) (s, h) /\ beval s b = false ->
    safeAt_bs c2 (s, h).
Proof.
  intros. unfold safeAt_bs, not in *. intro. destruct H.
  apply (BS_IfFalse b c1 c2 s h Abt) in H0; auto.
Qed.

Lemma safeAt_bs_while : forall s h b c,
    safeAt_bs (WHILE b DO c END) (s, h) /\ beval s b = true ->
    safeAt_bs c (s, h).
Proof.
  intros. destruct H. unfold safeAt_bs, not in *. intro.
  apply (BS_WhileLoopAb b c s h) in H0; auto.
Qed.

Lemma safeAt_bs_while2 : forall s h b c st,
    safeAt_bs (WHILE b DO c END) (s, h) -> beval s b = true ->
    big_step (c, (s, h)) (St st) ->
    safeAt_bs (WHILE b DO c END) st.
Proof.
  intros. unfold safeAt_bs, not in *. intro.
  assert (big_step (WHILE b DO c END, (s, h)) Abt).
  destruct st as [s' h'].
  apply BS_WhileLoop with s' h'; auto. apply H in H3. inversion H3.
Qed.

Lemma safeAt_bs_lookup : forall s h i a,
    safeAt_bs (SCLookup i a) (s, h) ->
    in_dom (aeval s a) h.
Proof.
  intros. unfold safeAt_bs, not in H.
  destruct (in_not_in_dec (aeval s a) h). assumption.
  assert (big_step (SCLookup i a, (s, h)) Abt).
  {
    apply BS_LookupAb with (aeval s a); auto.
  }
  apply H in H0. inversion H0.
Qed.

Lemma safeAt_bs_mutation : forall s h e1 e2,
    safeAt_bs ([e1]::= e2) (s, h) ->
    in_dom (aeval s e1) h.
Proof.
  intros. unfold safeAt_bs, not in H.
  destruct (in_not_in_dec (aeval s e1) h). assumption.
  assert (big_step ([e1]::=e2, (s, h)) Abt).
  {
    apply BS_MutationAb with (aeval s e1); auto.
  }
  apply H in H0. inversion H0.
Qed.

Lemma safeAt_bs_dispose : forall s h e,
    safeAt_bs (Dispose e) (s, h) ->
    in_dom (aeval s e) h.
Proof.
  intros. unfold safeAt_bs, not in H.
  destruct (in_not_in_dec (aeval s e) h). assumption.
  assert (big_step (Dispose e, (s, h)) Abt).
  {
    apply BS_DisposeAb with (aeval s e); auto.
  }
  apply H in H0. inversion H0.
Qed.

Lemma union_num_unchange : forall l n h1 h2,
    in_dom l h1 -> (h_union h1 h2) l = Some n ->
    h1 l = Some n.
Proof.
  intros. unfold h_union in H0. destruct (in_not_in_dec l h1); auto.
  unfold in_dom in H. destruct H. unfold not_in_dom in n0.
  rewrite H in n0. inversion n0.
Qed.

Theorem frame_bs_correct : forall c, frame_bs c.
Proof with eauto.
  unfold frame_bs. intros.
  remember (c, (s, h_union h1 h2)) as comst.
  remember (St (s', h')) as est.
  generalize dependent c. generalize dependent s.
  generalize dependent h1. generalize dependent h2.
  generalize dependent h'. generalize dependent s'.
  induction H1; intros; inversion Heqest; subst;
    inversion Heqcomst; subst; try clear Heqcomst; try clear Heqest.
  - (* SKIP *) exists h1. auto.
  - (* Asg *) exists h1. auto.
  - (* Seq *) destruct st'.
    assert (
        exists h1', big_step (c1, (s, h1)) (St (s0, h1')) /\
                    disjoint h1' h2 /\ h_union h1' h2 = h
      ).
    {
      apply IHbig_step1; auto. apply safeAt_bs_seq in H.
      assumption.
    }
    destruct H2 as [h1' [Hstep1 [Hdisj1 Hunion1]]].
    assert (
        exists h1'', big_step (c2, (s0, h1')) (St (s', h1'')) /\
                     disjoint h1'' h2 /\ h_union h1'' h2 = h'
      ).
    {
      apply IHbig_step2; auto.
      apply safeAt_bs_seq2 with (st := (s0, h1')) in H; assumption.
      rewrite Hunion1. reflexivity.
    }
    destruct H2 as [h1'' [Hstep2 [Hdisj2 Hunion2]]].
    exists h1''. split. econstructor ... auto.
  - (* IFB_true *)
    assert (
        exists h1', big_step (c1, (s0, h1)) (St (s', h1')) /\
                    disjoint h1' h2 /\ h_union h1' h2 = h'
      ).
    {
      apply IHbig_step; auto. eapply safeAt_bs_if ...
    }
    destruct H4 as [h1' [Hstep [Hdisj Hunion]]]. exists h1'.
    split. eapply BS_IfTrue ... auto.
  - (* IFB_false *)
    assert (
        exists h1', big_step (c2, (s0, h1)) (St (s', h1')) /\
                    disjoint h1' h2 /\ h_union h1' h2 = h'
      ).
    {
      apply IHbig_step; auto. eapply safeAt_bs_if2 ...
    }
    destruct H4 as [h1' [Hstep [Hdisj Hunion]]]. exists h1'.
    split. eapply BS_IfFalse ... auto.
  - (* While_end *) exists h1. split. eapply BS_WhileEnd ...
    auto.
  - (* While_Loop *)
    assert (
        exists h1', big_step (c, (s0, h1)) (St (s', h1')) /\
                    disjoint h1' h2 /\ h_union h1' h2 = h'
      ).
    {
      apply IHbig_step1; auto. eapply safeAt_bs_while ...
    }
    destruct H3 as [h1' [Hstep1 [Hdisj1 Hunion1]]].
    assert (
        exists h1'', big_step (WHILE b DO c END, (s', h1'))
                              (St (s'0, h1'')) /\ disjoint h1'' h2 /\
                     h_union h1'' h2 = h'0
      ).
    {
      apply IHbig_step2; auto. eapply safeAt_bs_while2 ...
      rewrite Hunion1; reflexivity.
    }
    destruct H3 as [h1'' [Hstep2 [Hdisj2 Hunion2]]].
    exists h1''. split. eapply BS_WhileLoop ... auto.
  - (* Cons *)
    exists (h_update (h_update h1 l (aeval s0 e1))
                     (l+1) (aeval s0 e2)).
    split. econstructor ... apply union_not_in in H.
    destruct H; assumption. apply union_not_in in H0.
    destruct H0; assumption.
    apply disjoint_extend
    with (l := l) (n := aeval s0 e1) in H3 ...
    apply disjoint_extend
    with (l := l+1) (n := aeval s0 e2) in H3 ...
    split. assumption.
    rewrite h_union_extend. rewrite h_union_extend. reflexivity.
    apply union_not_in in H0. destruct H0 ...
    apply union_not_in in H. destruct H ...
  - (* Lookup *) exists h1. split. apply safeAt_bs_lookup in H3.
    apply union_num_unchange with (n := n) (h2 := h2) in H3; auto.
    econstructor ... rewrite <- plus_n_O. unfold in_dom.
    exists n. assumption. rewrite <- plus_n_O. assumption.
    auto.
  - (* Mutation *)
    exists (h_update h1 (aeval s0 e1) (aeval s0 e2)). split.
    econstructor ... apply safeAt_bs_mutation in H3. assumption.
    split. apply disjoint_l_in with
           (l := aeval s0 e1) (n := aeval s0 e2) in H2; auto.
    apply safeAt_bs_mutation in H3; assumption.
    rewrite h_union_extend. reflexivity.
  - (* Dispose *)
    exists (fun l' => if eq_nat_dec (aeval s0 e) l' then None
                      else h1 l').
    split. econstructor ... apply safeAt_bs_dispose in H2. assumption.
    split. apply disjoint_l_seq ... apply safeAt_bs_dispose ...
    apply union_dispose ... apply safeAt_bs_dispose ...
Qed.

Lemma while_safty : forall b c st,
    (forall st', beval (fst st') b = true -> safeAt_bs c st') ->
    safeAt_bs (WHILE b DO c END) st.
Proof.
  intros. unfold safeAt_bs, not. intro.
  remember (WHILE b DO c END, st) as comst.
  remember Abt as est. generalize dependent st.
  generalize dependent c.
  induction H0; intros; try inversion Heqcomst; try inversion Heqest;
    try clear Heqcomst; try clear Heqest; subst.
  - apply (H1 (s, h)) in H. unfold safeAt_bs, not in H.
    apply H in H0. inversion H0.
  - assert ((WHILE b DO c0 END, (s', h')) =
            (WHILE b DO c0 END, (s', h')) -> False).
    {
      apply IHbig_step2; auto.
    }
    apply H1. reflexivity.
Qed.

Theorem safty_mono_correct : forall c,
    safty_Mono_bs c.
Proof with eauto.
  intro c. unfold safty_Mono_bs. induction c; intros.
  - (* SKIP *) unfold safeAt_bs, not in *. intro.
    inversion H1.
  - (* Asgn *) unfold safeAt_bs, not in *. intro.
    inversion H1.
  - (* Seq *) unfold safeAt_bs, not. intro.
    assert (safeAt_bs (c1;; c2) (s, h1)) by assumption.
    apply safeAt_bs_seq in H. apply (IHc1 s h1 h2) in H; auto.
    inversion H1; subst. unfold safeAt_bs, not in H.
    apply H in H4. inversion H4.
    assert (safeAt_bs (c1;; c2) (s, h1)) by assumption.
    apply safeAt_bs_seq in H2. destruct st' as [s' h'].
    assert (exists h1', big_step (c1, (s, h1)) (St (s', h1')) /\
                        disjoint h1' h2 /\ h_union h1' h2 = h').
    {
      apply frame_bs_correct; auto.
    }
    destruct H4 as [h1' [Hbs [Hdisj Hunion]]].
    apply safeAt_bs_seq2 with (st := (s', h1')) in H3; auto.
    apply IHc2 with (h2 := h2) in H3; eauto. subst h'.
    unfold safeAt_bs, not in H3. apply H3 in H8. inversion H8.
  - (* IFB *) unfold safeAt_bs, not. intro.
    inversion H1; subst.
    assert (safeAt_bs c1 (s, h1)).
    {
      apply safeAt_bs_if with (b := b) (c2 := c2). auto.
    }
    apply (IHc1 s h1 h2) in H2; auto.
    assert (safeAt_bs c2 (s, h1)).
    {
      apply safeAt_bs_if2 with (b := b) (c1 := c1). auto.
    }
    apply IHc2 with (h2 := h2) in H2; auto.
  - (* WHILE *) unfold safeAt_bs, not. intro.
    inversion H1; subst.
    assert (safeAt_bs c (s, h1)).
    {
      apply safeAt_bs_while with b. auto.
    }
    apply (IHc s h1 h2) in H2; auto.
    assert (safeAt_bs c (s, h1)).
    {
      apply safeAt_bs_while with b. auto.
    }
    admit.
  - (* Cons *) unfold safeAt_bs, not in *. intro.
    inversion H1; subst.
  - (* Lookup *) unfold safeAt_bs, not. intro.
    inversion H1; subst. apply union_not_in in H7.
    destruct H7. apply safeAt_bs_lookup in H.
    unfold in_dom in H. destruct H as [n]. unfold not_in_dom in H2.
    rewrite H in H2. inversion H2.
  - (* Mutation *) unfold safeAt_bs, not. intro.
    inversion H1; subst. apply union_not_in in H7.
    destruct H7. apply safeAt_bs_mutation in H.
    unfold not_in_dom in H2. unfold in_dom in H. destruct H as [n].
    rewrite H in H2. inversion H2.
  - (* Dispose *) unfold safeAt_bs, not. intro.
    inversion H1; subst. apply union_not_in in H6.
    destruct H6. apply safeAt_bs_dispose in H.
    unfold not_in_dom in H2. unfold in_dom in H. destruct H as [n].
    rewrite H in H2. inversion H2.
Admitted.

Definition hoare_triple (P : sass) (c : scom) (Q : sass) : Prop :=
  forall st,
    P st -> (safeAt_bs c st /\ (forall est, big_step (c, st) (St est) -> Q est)).

Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level) : hoare_spec_scope.

Open Scope hoare_spec_scope.

Definition assert_implies (P Q : sass) : Prop :=
  forall st, P st -> Q st.
Notation "P ->> Q" := (assert_implies P Q)
                        (at level 80) : hoare_spec_scope.
Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* frame rule *)
Theorem Frame_Rule : forall P Q c,
    {{ P }} c {{ Q }} ->
    ( forall R, inde (modified_scom_var c) R ->
    {{ P ** R }} c {{ Q ** R }}).
Proof.
  unfold hoare_triple in *. intros. unfold star in H1.
  destruct st as [s h].
  destruct H1 as [h1 [h2 [Hdisj [Hunion [HP HR]]]]].
  apply H in HP. destruct HP. split. rewrite <- Hunion.
  apply (safty_mono_correct); auto. intros. unfold star.
  destruct est as [s' h']. rewrite <- Hunion in H3.
  apply (frame_bs_correct c s s' h1 h2 h') in H1; auto.
  destruct H1 as [h1' [Hstep [Hdisj1 Hunion1]]].
  exists h1', h2. split. assumption. split. assumption.
  split. apply H2 in Hstep. assumption.
  eapply (mention_modified_free (s, h1) (s', h1') c R) in H0; eauto.
Qed.

Definition pto_any (e : aexp) : sass :=
  fun st => match st with
            | (s, h) => exists v, h = h_update emp_heap (aeval s e) v
            end.
Notation "e '|->' '-'" := (pto_any e) (at level 60).

Theorem hoare_consquence_post : forall c p q q',
    {{ p }} c {{ q' }} -> (q' ->> q) ->
    {{ p }} c {{ q }}.
Proof.
  unfold hoare_triple. intros. apply H in H1. destruct H1.
  split. assumption. intros. apply H2 in H3.
  unfold assert_implies in H0. apply H0 in H3. assumption.
Qed.

Theorem hoare_consquence_pre : forall c p p' q,
    {{ p' }} c {{ q }} -> (p ->> p') ->
    {{ p }} c {{ q }}.
Proof.
  unfold hoare_triple. intros. unfold assert_implies in H0.
  apply H0 in H1. apply H in H1. auto.
Qed.

(** Inference Rules for Mutation and Disposal **)
(* The local form mutation *)
Theorem hoare_mul : forall e e',
    {{ e |-> - }} ([e] ::= e') {{ e |-> e' }}.
Proof.
  unfold hoare_triple. intros. split.
  unfold safeAt_bs, not. intro. inversion H0; subst.
  simpl in H. destruct H as [v]. rewrite H in H5.
  unfold not_in_dom in H5. unfold h_update in H5.
  unfold eq_nat_dec in H5.
  assert (aeval s e =? aeval s e = true).
  {
    apply beq_nat_true_iff. reflexivity.
  }
  rewrite H1 in H5. inversion H5.
  intros. inversion H0; subst. simpl. simpl in H. destruct H as [v].
  rewrite H. apply functional_extensionality. intros.
  unfold h_update. destruct (eq_nat_dec (aeval s e) x); auto.
Qed.

(* The Global form mutation *)
Theorem hoare_mug : forall e e' r,
    {{ (e |-> -) ** r }} [e] ::= e' {{ (e |-> e') ** r }}.
Proof.
  intros. apply Frame_Rule. apply hoare_mul.
  simpl. unfold inde. intros. unfold In in H. inversion H.
Qed.

Lemma disjoint_in_still : forall h1 h2 l n,
    in_dom l h1 -> disjoint h1 h2 ->
    disjoint (h_update h1 l n) h2.
Proof.
  unfold disjoint in *. intros.
  destruct (H0 l0). left. unfold not_in_dom in *.
  unfold h_update. unfold eq_nat_dec. destruct (l =? l0) eqn:Heqe.
  apply beq_nat_true_iff in Heqe. rewrite <- Heqe in H1.
  unfold in_dom in H. destruct H as [n']. rewrite H in H1.
  inversion H1. assumption. right. assumption.
Qed.

(* The backward-reasoning form mutation *)
Theorem hoare_mubr : forall e e' p,
    {{ (e |-> -) ** ((e |-> e') --* p) }} [e] ::= e' {{ p }}.
Proof.
  unfold hoare_triple. intros. split.
  - unfold safeAt_bs, not. intro. inversion H0; subst.
    unfold star in H.
    destruct H as [h1 [h2 [Hdisj [Hunion [HP HQ]]]]].
    simpl in HP. destruct HP as [v]. rewrite <- Hunion in H5.
    rewrite H in H5. unfold not_in_dom in H5.
    unfold h_union in H5.
    destruct
      (in_not_in_dec (aeval s e) (h_update emp_heap (aeval s e) v)).
    unfold h_update in H5. unfold eq_nat_dec in H5.
    assert (aeval s e =? aeval s e = true)
      by (apply beq_nat_true_iff; reflexivity).
    rewrite H1 in H5. inversion H5. unfold not_in_dom in n.
    unfold h_update in n.
    assert (aeval s e =? aeval s e = true)
      by (apply beq_nat_true_iff; reflexivity).
    unfold eq_nat_dec in n. rewrite H1 in n. inversion n.
  - intros. unfold star in H. destruct st as [s h].
    destruct H as [h1 [h2 [Hdisj [Hunion [HP HQ]]]]].
    inversion H0; subst. unfold simp in HQ. simpl in HP.
    destruct HP as [v].
    assert (in_dom (aeval s e) h1).
    {
      rewrite H. unfold in_dom. exists v. unfold h_update.
      unfold eq_nat_dec.
      assert (aeval s e =? aeval s e = true) by
          (apply beq_nat_true_iff; auto).
      rewrite H1. reflexivity.
    }
    apply disjoint_in_still
    with (h2 := h2) (n := aeval s e') in H1; auto.
    apply HQ in H1.
    assert (h_union h2 (h_update h1 (aeval s e) (aeval s e'))
            = h_union (h_update h1 (aeval s e) (aeval s e')) h2).
    {
      apply disj_union_symmetry. apply disjoint_symmetry.
      apply disjoint_in_still; auto. rewrite H. unfold in_dom.
      exists v. unfold eq_nat_dec.
      assert (aeval s e =? aeval s e = true) by
          (apply beq_nat_true_iff; auto).
      unfold h_update, eq_nat_dec. rewrite H2. reflexivity.
    }
    rewrite H2 in H1. rewrite h_union_extend in H1. assumption.
    simpl. rewrite H. apply functional_extensionality. intros.
    unfold h_update, eq_nat_dec. destruct (aeval s e =? x); auto.
Qed.

(* The local form dispose *)
Theorem hoare_dispose_lc : forall e,
    {{ e |-> - }} (Dispose e) {{ emp }}.
Proof.
  unfold hoare_triple. intros. split. unfold safeAt_bs, not.
  intro. inversion H0; subst. simpl in H. destruct H as [v].
  rewrite H in H4.
  unfold not_in_dom in H4. unfold h_update, eq_nat_dec in H4.
  assert (aeval s e =? aeval s e = true)
    by (apply beq_nat_true_iff; auto).
  rewrite H1 in H4. inversion H4. intros.
  inversion H0; subst. simpl in H. destruct H as [v]. subst h.
  unfold emp. simpl. apply functional_extensionality. intros.
  unfold eq_nat_dec. destruct (aeval s e =? x) eqn:Heqe.
  unfold emp_heap. reflexivity. unfold h_update, eq_nat_dec.
  rewrite Heqe. reflexivity.
Qed.

Lemma union_emp : forall h1 h2,
    h_union emp_heap h1 = h2 -> h1 = h2.
Proof.
  intros. apply functional_extensionality. intros.
  apply equal_f with x in H. unfold h_union in H.
  destruct (in_not_in_dec x emp_heap); auto. unfold in_dom in i.
  destruct i. unfold emp_heap in H0. inversion H0.
Qed.

(* The global form dispose *)
Theorem hoare_dispose_gb : forall e r,
    {{ (e |-> -) ** r }} (Dispose e) {{ r }}.
Proof.
  intros. apply hoare_consquence_post with (emp ** r).
  apply Frame_Rule. apply hoare_dispose_lc.
  simpl. unfold inde. intros. unfold In in H. inversion H.
  unfold assert_implies. intros. unfold star in H.
  destruct st as [s h].
  destruct H as [h1 [h2 [Hdisj [Hunion [H1 H2]]]]].
  unfold emp in H1. simpl in H1. rewrite H1 in Hunion.
  apply union_emp in Hunion. subst h2. assumption.
Qed.

(* The specification for cons and lookup will be more complicated, since they will modify the stack even the heap *)
Fixpoint free_var_aexp (e : aexp) : list id :=
  match e with
  | AId v => v :: nil
  | ANum _ => nil
  | APlus e1 e2 => (free_var_aexp e1) ++ (free_var_aexp e2)
  | AMinus e1 e2 => (free_var_aexp e1) ++ (free_var_aexp e2)
  | AMult e1 e2 => (free_var_aexp e1) ++ (free_var_aexp e2)
  end.

Definition distinct_var_aexp (x : id) (e : aexp) : Prop :=
  forall v s,
    aeval s e = aeval (st_update s x v) e.

Fixpoint aexp_subst_var (e : aexp) (x : id) (v : aexp) : aexp :=
  match e with
  | AId i => if beq_id i x then v else (AId i)
  | ANum n => ANum n
  | APlus e1 e2 =>
    APlus (aexp_subst_var e1 x v) (aexp_subst_var e2 x v)
  | AMinus e1 e2 =>
    AMinus (aexp_subst_var e1 x v) (aexp_subst_var e2 x v)
  | AMult e1 e2 =>
    AMult (aexp_subst_var e1 x v) (aexp_subst_var e2 x v)
  end.

Lemma disjoint_cell : forall l1 l2 n1 n2,
    l1 =? l2 = false ->
    disjoint (h_update emp_heap l1 n1) (h_update emp_heap l2 n2).
Proof.
  intros. unfold disjoint, not_in_dom. intros.
  unfold h_update, eq_nat_dec. destruct (l1 =? l) eqn:Heqe.
  right. destruct (l2 =? l) eqn:Heqe1.
  apply beq_nat_true_iff in Heqe. apply beq_nat_true_iff in Heqe1.
  subst l1. subst l2. rewrite <- beq_nat_refl in H. inversion H.
  reflexivity. left. reflexivity.
Qed.

Lemma beq_id_symmetry : forall x y,
    beq_id x y = beq_id y x.
Proof.
  intros. destruct x, y. simpl.
  apply Nat.eqb_sym.
Qed.

Lemma distinct_stability : forall v v' s l e,
    distinct_var_aexp v v' -> s v = aeval s v' ->
    aeval s e = aeval (st_update s v l) (aexp_subst_var e v v').
Proof.
  intros v v' s l e. generalize dependent v. generalize dependent s.
  generalize dependent l. induction e; intros.
  - reflexivity.
  - simpl. unfold distinct_var_aexp in H.
    destruct (beq_id i v) eqn:Heqe. rewrite <- H.
    apply beq_id_true_iff in Heqe. subst. assumption.
    simpl. unfold st_update, eq_id_dec. rewrite beq_id_symmetry.
    rewrite Heqe. reflexivity.
  - simpl. assert (H' : distinct_var_aexp v v') by assumption.
    assert (H1 : s v = aeval s v') by assumption.
    apply IHe1 with (l := l) (s := s) in H; auto.
  - simpl. assert (H' : distinct_var_aexp v v') by assumption.
    assert (H1 : s v = aeval s v') by assumption.
    apply IHe1 with (l := l) (s := s) in H; auto.
  - simpl. assert (H' : distinct_var_aexp v v') by assumption.
    assert (H1 : s v = aeval s v') by assumption.
    apply IHe1 with (l := l) (s := s) in H; auto.
Qed.

Definition assertion_var_sub X a P : sass :=
  fun (st : sstate) =>
    match st with
      (s, h) => P (st_update s X (aeval s a), h)
    end.
Notation "P [ X --> a ]" := (assertion_var_sub X a P) (at level 10).

Theorem hoare_cons_lc : forall v v' e1 e2,
    distinct_var_aexp v v' ->
    {{ (fun st => (fst st) v = aeval (fst st) v') //\\ emp }}
      (SCCons v e1 e2)
    {{ ((AId v) |-> (aexp_subst_var e1 v v')) **
         ((APlus (AId v) (ANum 1)) |-> (aexp_subst_var e2 v v')) }}.
Proof.
  unfold hoare_triple. intros. split.
  - unfold safeAt_bs, not. intro. inversion H1.
  - intros. destruct st as [s h]. unfold s_conj in H0. simpl in *.
    inversion H1; subst. unfold star. destruct H0.
    unfold emp in H2. simpl in H2. subst h.
    exists (h_update emp_heap l (aeval s e1)).
    exists (h_update emp_heap (l+1) (aeval s e2)).
    split. apply disjoint_cell. apply beq_nat_false_iff. omega.
    split.
    unfold h_union. apply functional_extensionality. intro.
    destruct (in_not_in_dec x (h_update emp_heap l (aeval s e1))).
    unfold h_update, eq_nat_dec. destruct (l =? x) eqn:Heqe.
    assert (l + 1 =? x = false). apply beq_nat_true_iff in Heqe.
    apply beq_nat_false_iff. subst x. omega. rewrite H2. reflexivity.
    unfold in_dom in i. destruct i as [n].
    unfold h_update, eq_nat_dec in H2. destruct (l =? x) eqn:Heqe1.
    inversion Heqe. unfold emp_heap in H2. inversion H2.
    unfold h_update, eq_nat_dec. destruct (l + 1 =? x) eqn:Heqe.
    reflexivity. destruct (l =? x) eqn:Heqe1. unfold not_in_dom in n.
    apply beq_nat_true_iff in Heqe1. rewrite Heqe1 in n.
    unfold h_update, eq_nat_dec in n. rewrite <- beq_nat_refl in n.
    inversion n. reflexivity. split.
    unfold pto. unfold st_update. simpl. unfold eq_id_dec.
    rewrite <- beq_id_refl.
    apply (distinct_stability v v' s l e1) in H; auto.
    unfold pto. simpl.
    assert (st_update s v l v = l).
    {
      unfold st_update, eq_id_dec. rewrite <- beq_id_refl.
      reflexivity.
    }
    rewrite H2.
    apply (distinct_stability v v' s l e2) in H; auto.
Qed.

Theorem hoare_cons_gb : forall v e1 e2 r,
    {{ r }} (SCCons v e1 e2)
    {{ fun st => exists v', distinct_var_aexp v v' /\
            ((((AId v) |-> (aexp_subst_var e1 v v'))
             ** ((APlus (AId v) (ANum 1)) |-> (aexp_subst_var e2 v v')))
                 ** (r [ v --> v' ])) st }}.
Proof.
  unfold hoare_triple. intros. split.
  unfold safeAt_bs, not. intro. inversion H0. intros.
  unfold star in *. inversion H0; subst. exists (ANum (s v)).
  split. unfold distinct_var_aexp. intros. simpl. reflexivity.
  exists
    (h_update (h_update emp_heap l (aeval s e1)) (l+1) (aeval s e2)).
  exists h.
  split. unfold disjoint, not_in_dom. intros.
  unfold h_update, eq_nat_dec. destruct (l + 1 =? l0) eqn:Heqe.
  apply beq_nat_true_iff in Heqe. unfold not_in_dom in H7.
  rewrite Heqe in H7. right. assumption.
  destruct (l =? l0) eqn:Heqe1. apply beq_nat_true_iff in Heqe1.
  unfold not_in_dom in H6. rewrite Heqe1 in H6. right. assumption.
  left. unfold emp_heap. reflexivity. split. unfold h_union.
  apply functional_extensionality. intros.
  destruct (in_not_in_dec x
    (h_update (h_update emp_heap l (aeval s e1)) (l + 1) (aeval s e2))).
  unfold h_update, eq_nat_dec. destruct (l + 1 =? x) eqn:Heqe; auto.
  destruct (l =? x) eqn:Heqe1; auto. unfold in_dom in i. destruct i.
  unfold h_update, eq_nat_dec in H1. rewrite Heqe in H1.
  rewrite Heqe1 in H1. unfold emp_heap in H1. inversion H1.
  unfold h_update, eq_nat_dec. destruct (l + 1 =? x) eqn:Heqe.
  unfold not_in_dom in n. unfold h_update, eq_nat_dec in n.
  rewrite Heqe in n. inversion n. destruct (l =? x) eqn:Heqe1.
  unfold not_in_dom in n. unfold h_update, eq_nat_dec in n.
  rewrite Heqe in n. rewrite Heqe1 in n. inversion n. reflexivity. split.
  exists (h_update emp_heap l (aeval s e1)).
  exists (h_update emp_heap (l+1) (aeval s e2)).
  split. apply disjoint_cell. apply beq_nat_false_iff. omega.
  split. unfold h_union. apply functional_extensionality. intro.
  destruct (in_not_in_dec x (h_update emp_heap l (aeval s e1))).
  unfold h_update, eq_nat_dec. destruct (l =? x) eqn:Heqe.
  destruct (l + 1 =? x) eqn:Heqe1. apply beq_nat_true_iff in Heqe.
  apply beq_nat_true_iff in Heqe1. rewrite <- Heqe in Heqe1. omega.
  reflexivity. destruct (l + 1 =? x) eqn:Heqe1.
  unfold in_dom in i. destruct i as [n].
  unfold h_update, eq_nat_dec in H1. rewrite Heqe in H1.
  unfold emp_heap in H1. inversion H1. reflexivity.
  unfold h_update, eq_nat_dec. destruct (l + 1 =? x) eqn:Heqe; auto.
  assert (st_update s v l v = l).
  {
     unfold st_update, eq_id_dec. rewrite <- beq_id_refl.
     reflexivity.
  }
  unfold pto. simpl. rewrite H1. split.
  assert ((aeval s e1)
     = (aeval (st_update s v l) (aexp_subst_var e1 v (ANum (s v))))).
  {
    apply distinct_stability; auto. unfold distinct_var_aexp.
    intros. simpl. reflexivity.
  }
  rewrite <- H2. reflexivity.
  assert ((aeval s e2) =
          (aeval (st_update s v l) (aexp_subst_var e2 v (ANum (s v))))).
  {
    apply distinct_stability; auto. unfold distinct_var_aexp.
    intros. reflexivity.
  }
  rewrite <- H2. reflexivity. unfold assertion_var_sub. simpl.
  assert (s = st_update (st_update s v l) v (s v)).
  {
    apply functional_extensionality. intros.
    unfold st_update, eq_id_dec. destruct (beq_id v x) eqn:Heqe; auto.
    apply beq_id_true_iff in Heqe. subst. reflexivity.
  }
  rewrite <- H1. assumption.
Qed.

Lemma aeval_subst_var_eq : forall s e v v',
    aeval s (aexp_subst_var e v v') =
    aeval (st_update s v (aeval s v')) e.
Proof.
  intros s e. generalize dependent s.
  induction e; intros; auto; try solve
                                 [simpl; rewrite IHe1; rewrite IHe2;
                                 reflexivity].
  - simpl. destruct (beq_id i v) eqn:Heqe. unfold st_update, eq_id_dec.
    rewrite beq_id_symmetry in Heqe. rewrite Heqe. reflexivity.
    simpl. unfold st_update, eq_id_dec. rewrite beq_id_symmetry in Heqe.
    rewrite Heqe. reflexivity.
Qed.

Theorem hoare_cons_br : forall e1 e2 p v,
    {{ fun st => (forall v'', (distinct_var_aexp v v'') /\
       (((v'' |-> e1) ** ((APlus v'' (ANum 1)) |-> e2))
          --* (p [v --> v''])) st) }}
      (SCCons v e1 e2)
    {{ p }}.
Proof.
  intros. eapply hoare_consquence_post. apply hoare_cons_gb.
  unfold assert_implies. intros. destruct H as [v'].
  destruct H as [Hdist]. unfold star in H. destruct st as [s h].
  destruct H as [h1 [h2]]. destruct H as [Hdisj [Hunion [H1 H2]]].
  destruct H1 as [h3 [h4]]. simpl in *.
  destruct (H2 (ANum (s v))). clear H2.
  destruct H as [Hdisj1 [Hunion2 [Hupdate1 Hupdate2]]].
  assert (disjoint h1 h2) by assumption.
  apply H1 in Hdisj. clear H1.
  assert (h_union h1 h2 = h_union h2 h1).
  {
    apply disj_union_symmetry; auto.
  }
  rewrite <- H1 in Hdisj. rewrite Hunion in Hdisj.
  simpl in Hdisj.
  assert (st_update (st_update s v (aeval s v')) v (s v) = s).
  {
    unfold st_update. apply functional_extensionality.
    intro. unfold eq_id_dec. destruct (beq_id v x) eqn:Heqe; auto.
    apply beq_id_true_iff in Heqe. rewrite Heqe. reflexivity.
  }
  rewrite H2 in Hdisj. assumption.
  simpl. exists h3, h4. split. assumption. split. assumption.
  split. rewrite Hupdate1. clear H1. rewrite aeval_subst_var_eq.
  reflexivity. rewrite Hupdate2. rewrite aeval_subst_var_eq.
  reflexivity.
Qed.

(* The specification for lookup *)
Theorem hoare_lookup_lc : forall v v' v'' e,
    (distinct_var_aexp v v' /\ distinct_var_aexp v v'') ->
    {{ fun st => ((fst st) v = aeval (fst st) v' /\
    (e |-> v'') st) }}
      (SCLookup v e)
      {{ fun st => ((fst st) v = aeval (fst st) v'')
                   /\ ((aexp_subst_var e v v' |-> (AId v)) st) }}.
Proof.
  unfold hoare_triple. intros. split.
  destruct st as [s h]. unfold safeAt_bs, not. intro.
  inversion H1; subst. destruct H0. simpl in *. rewrite H2 in H7.
  unfold not_in_dom in H7. unfold h_update, eq_nat_dec in H7.
  rewrite <- beq_nat_refl in H7. inversion H7. intros.
  inversion H1; subst. simpl in *. split.
  destruct H. unfold distinct_var_aexp in H2. rewrite <- H2.
  unfold st_update, eq_id_dec. rewrite <- beq_id_refl. destruct H0.
  rewrite H3 in H8. unfold h_update, eq_nat_dec in H8.
  rewrite <- beq_nat_refl in H8. inversion H8. reflexivity.
  destruct H0. rewrite H2. destruct H.
  apply (distinct_stability v v' s n e) in H; auto.
  rewrite <- H. rewrite H2 in H8. unfold h_update, eq_nat_dec in H8.
  rewrite <- beq_nat_refl in H8. inversion H8. rewrite H5.
  assert (st_update s v n v = n).
  {
    unfold st_update, eq_id_dec. rewrite <- beq_id_refl.
    reflexivity.
  }
  rewrite H4. reflexivity.
Qed.

Theorem hoare_lookup_gb : forall v r e,
    {{ fun st => (exists v'', distinct_var_aexp v v'' /\
                     ((e |-> v'') ** (r [v --> v''])) st) }}
      (SCLookup v e)
      {{ fun st => (exists v', distinct_var_aexp v v' /\
                   ((aexp_subst_var e v v' |-> (AId v)) ** r) st)  }}.
Proof.
  unfold hoare_triple. intros. destruct H as [v'' [Hdistinc Hass]].
  destruct st as [s h]. unfold star in Hass.
  destruct Hass as [h1 [h2 [Hdisj [Hunion [H1 H2]]]]].
  split. unfold safeAt_bs, not. intro. inversion H; subst.
  unfold pto in H1. unfold not_in_dom in H7. rewrite H1 in H7.
  unfold h_union in H7.
  destruct (in_not_in_dec (aeval s e)
                          (h_update emp_heap (aeval s e) (aeval s v''))).
  unfold h_update, eq_nat_dec in H7. rewrite <- beq_nat_refl in H7.
  inversion H7. unfold not_in_dom in n.
  unfold h_update, eq_nat_dec in n. rewrite <- beq_nat_refl in n.
  inversion n. intros. inversion H; subst.
  exists (ANum (s v)). split. unfold distinct_var_aexp. intros.
  simpl. reflexivity. unfold pto. simpl. exists h1, h2.
  split. assumption. split. reflexivity. split.
  unfold pto in H1. rewrite H1.
  assert (aeval s e =
          aeval (st_update s v n) (aexp_subst_var e v (ANum (s v)))).
  {
    apply distinct_stability. unfold distinct_var_aexp. intros.
    reflexivity. reflexivity.
  }
  rewrite <- H0. unfold assertion_var_sub in H2.
  rewrite H1 in H9. unfold h_union in H9.
  destruct (in_not_in_dec (aeval s e)
                          (h_update emp_heap (aeval s e) (aeval s v''))).
  unfold h_update, eq_nat_dec in H9. rewrite <- beq_nat_refl in H9.
  inversion H9; subst. unfold st_update, eq_id_dec.
  rewrite <- beq_id_refl. reflexivity. unfold not_in_dom in n0.
  unfold h_update, eq_nat_dec in n0. rewrite <- beq_nat_refl in n0.
  inversion n0. unfold assertion_var_sub in H2.
  unfold pto in H1. rewrite H1 in H9. unfold h_union in H9.
  destruct (in_not_in_dec (aeval s e)
                          (h_update emp_heap (aeval s e) (aeval s v''))).
  unfold h_update, eq_nat_dec in H9. rewrite <- beq_nat_refl in H9.
  inversion H9. assumption. unfold not_in_dom in n0.
  unfold h_update, eq_nat_dec in n0. rewrite <- beq_nat_refl in n0.
  inversion n0.
Qed.

Lemma in_union_in : forall h1 h2 l,
    in_dom l h1 -> in_dom l (h_union h1 h2).
Proof.
  intros. unfold in_dom in *. destruct H as [n].
  exists n. unfold h_union. destruct (in_not_in_dec l h1); auto.
  unfold not_in_dom in n0. rewrite H in n0. inversion n0.
Qed.

Theorem hoare_lookup_bw : forall e p v,
    {{ fun st => (exists v', ((e |-> v')
                   ** ((e |-> v') --* (p [v --> v']))) st) }}
      (SCLookup v e)
    {{ p }}.
Proof.
  unfold hoare_triple. intros. destruct H. unfold star in H.
  destruct st as [s h].
  destruct H as [h1 [h2 [Hdisj [Hunion [H1 H2]]]]].
  split. unfold safeAt_bs, not. intros. inversion H; subst.
  unfold pto in H1.
  assert (in_dom (aeval s e) h1).
  {
    unfold in_dom. exists (aeval s x). rewrite H1.
    unfold h_update, eq_nat_dec. rewrite <- beq_nat_refl.
    reflexivity.
  }
  apply in_union_in with (h2 := h2) in H0. unfold not_in_dom in H7.
  unfold in_dom in H0. destruct H0. rewrite H7 in H0. inversion H0.
  intros. inversion H; subst. unfold pto in H1.
  unfold pto, simp in H2. assert (Hdisj1 : disjoint h1 h2) by auto.
  apply (H2 h1) in Hdisj; auto.
  unfold assertion_var_sub in Hdisj.
  rewrite H1 in H9. unfold h_union in H9.
  destruct (in_not_in_dec (aeval s e)
                          (h_update emp_heap (aeval s e) (aeval s x))).
  unfold h_update, eq_nat_dec in H9. rewrite <- beq_nat_refl in H9.
  inversion H9; subst. apply disj_union_symmetry in Hdisj1.
  rewrite <- Hdisj1 in Hdisj. assumption.
  unfold not_in_dom in n0. unfold h_update, eq_nat_dec in n0.
  rewrite <- beq_nat_refl in n0. inversion n0.
Qed.