From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
From pcm Require Import options axioms pred prelude.
From pcm Require Import pcm unionmap heap.
From htt Require Import domain.

(* Exceptions are an equality type *)
Inductive exn : Type := exn_from_nat of nat.

Definition exn_to_nat :=
  fun '(exn_from_nat y) => y.

Definition eqexn :=
  fun '(exn_from_nat m) '(exn_from_nat n) => m == n.

Lemma eqexnP : Equality.axiom eqexn.
Proof. by move=>[x][y]/=; case: eqP=>[->|*]; constructor=>//; case. Qed.

Canonical Structure exn_eqMixin := EqMixin eqexnP.
Canonical Structure exn_eqType := EqType exn exn_eqMixin.

(* Answer type *)
Inductive ans (A : Type) : Type := Val of A | Exn of exn.
Arguments Exn [A].

(* A set of heaps *)
Notation pre := (Pred heap).

(* A set of (ans A * heap) *)
(* This models the fact that programs can hang, returning nothing, *)
(* or produce nondeterministic results (e.g. alloc). *)
Notation post A := (ans A -> heap -> Prop).

Definition spec G A := G -> pre * post A : Type.

(*************************************************************)
(* List of inference rules, with vrf predicate kept abstract *)
(*************************************************************)

Module Type VrfSig.

Parameter ST : Type -> Type.

Parameter ret : forall A, A -> ST A.
Parameter throw : forall A, exn -> ST A.
Parameter bind : forall A B, ST A -> (A -> ST B) -> ST B.
Parameter try : forall A B, ST A -> (A -> ST B) -> (exn -> ST B) -> ST B.
Parameter read : forall A, ptr -> ST A.
Parameter write : forall A, ptr -> A -> ST unit.
Parameter alloc : forall A, A -> ST ptr.
Parameter allocb : forall A, A -> nat -> ST ptr.
Parameter dealloc : ptr -> ST unit.

Arguments throw [A] e.
Arguments read [A] x.

(* we need program to come first in the argument list
   so that automation can match on it *)
Parameter vrf' : forall A, ST A -> heap -> post A -> Prop.

(* recover the usual [pre]prog[post] order with a notation *)
Notation vrf i e Q := (vrf' e i Q).

Parameter vrfV : forall A e i (Q : post A),
            (valid i -> vrf i e Q) -> vrf i e Q.
Parameter vrf_post : forall A e i (Q1 Q2 : post A),
            (forall y m, valid m -> Q1 y m -> Q2 y m) ->
            vrf i e Q1 -> vrf i e Q2.
Parameter vrf_frame : forall A e i j (Q : post A),
            vrf i e (fun y m => valid (m \+ j) -> Q y (m \+ j)) ->
            vrf (i \+ j) e Q.
Parameter vrf_ret : forall A x i (Q : post A),
            (valid i -> Q (Val x) i) -> vrf i (ret x) Q.
Parameter vrf_throw : forall A e i (Q : post A),
            (valid i -> Q (Exn e) i) -> vrf i (throw e) Q.
Parameter vrf_bind : forall A B (e1 : ST A) (e2 : A -> ST B) i (Q : post B),
            vrf i e1 (fun x m =>
                        match x with
                        | Val x' => vrf m (e2 x') Q
                        | Exn e => valid m -> Q (Exn e) m
                        end) ->
            vrf i (bind e1 e2) Q.
Parameter vrf_try : forall A B (e : ST A) (e1 : A -> ST B) (e2 : exn -> ST B) i (Q : post B),
            vrf i e (fun x m =>
                       match x with
                       | Val x' => vrf m (e1 x') Q
                       | Exn ex => vrf m (e2 ex) Q
                       end) ->
            vrf i (try e e1 e2) Q.
Parameter vrf_read : forall A x j (v : A) (Q : post A),
            (valid (x :-> v \+ j) -> Q (Val v) (x :-> v \+ j)) ->
            vrf (x :-> v \+ j) (read x) Q.
Parameter vrf_write : forall A x (v : A) B (u : B) j (Q : post unit),
            (valid (x :-> v \+ j) -> Q (Val tt) (x :-> v \+ j)) ->
            vrf (x :-> u \+ j) (write x v) Q.
Parameter vrf_alloc : forall A (v : A) i (Q : post ptr),
            (forall x, valid (x :-> v \+ i) -> Q (Val x) (x :-> v \+ i)) ->
            vrf i (alloc v) Q.
Parameter vrf_allocb : forall A (v : A) n i (Q : post ptr),
            (forall x, valid (updi x (nseq n v) \+ i) ->
               Q (Val x) (updi x (nseq n v) \+ i)) ->
            vrf i (allocb v n) Q.
Parameter vrf_dealloc : forall x A (v : A) j (Q : post unit),
            (x \notin dom j -> valid j -> Q (Val tt) j) ->
            vrf (x :-> v \+ j) (dealloc x) Q.

Definition has_spec G A (s : spec G A) (e : ST A) :=
  forall g i, (s g).1 i -> vrf i e (s g).2.

Structure STspec G A (s : spec G A) := STprog {
  model :> ST A;
  _ : model \In has_spec s}.

Arguments STspec G [A] s.

Notation "'Do' e" := (@STprog _ _ _ e _) (at level 80).

Notation "x '<--' c1 ';' c2" := (bind c1 (fun x => c2))
  (at level 81, right associativity).
Notation "c1 ';;' c2" := (bind c1 (fun _ => c2))
  (at level 81, right associativity).
Notation "'!' x" := (read x) (at level 50).
Notation "x '::=' e" := (write x e) (at level 60).

Parameter Fix : forall G A (B : A -> Type) (s : forall x : A, spec G (B x)),
  ((forall x : A, STspec G (s x)) -> forall x : A, STspec G (s x)) ->
  forall x : A, STspec G (s x).

End VrfSig.

(********************************)
(* Definition of the Hoare type *)
(********************************)

Module Vrf : VrfSig.

Section BasePrograms.
Variables (P : pre) (A : Type).

(* we carve out the model out of the following base type *)
Definition prog : Type := forall i : heap, valid i -> i \In P -> post A.

(* we take only preconditions and progs with special properties *)
(* which we define next *)

(* safety monotonicity *)
Definition safe_mono :=
  forall i j, i \In P -> valid (i \+ j) -> i \+ j \In P.

(* defined heaps map to defined heaps *)
Definition def_strict (e : prog) :=
  forall i p v x, Heap.Undef \Notin e i v p x.

(* frame property *)
Definition frameable (e : prog) :=
  forall i j (pf : i \In P) (V : valid (i \+ j)) (pf' : i \+ j \In P) y m,
    e _ V pf' y m ->
    exists h, [/\ m = h \+ j, valid (h \+ j) & e _ (validL V) pf y h].

End BasePrograms.

Section STDef.
Variable (A : Type).

Structure ST' := Prog {
  pre_of : pre;
  prog_of : prog pre_of A;
  _ : safe_mono pre_of;
  _ : def_strict prog_of;
  _ : frameable prog_of}.

(* module field must be a definition, not structure *)
Definition ST := ST'.

Lemma sfm_st e : safe_mono (pre_of e).
Proof. by case: e. Qed.

Arguments prog_of : clear implicits.

Lemma dstr_st e : def_strict (prog_of e).
Proof. by case: e. Qed.

Corollary dstr_valid e i p v x m :
            m \In prog_of e i p v x -> valid m.
Proof. by case: m=>// /dstr_st. Qed.

Lemma fr_st e : frameable (prog_of e).
Proof. by case: e. Qed.

Arguments fr_st [e i j].

(* poset structure on ST *)

Definition st_leq e1 e2 :=
  exists pf : pre_of e2 <== pre_of e1,
  forall i (v : valid i) (p : i \In pre_of e2),
    prog_of e1 _ v (pf _ p) <== prog_of e2 _ v p.

Lemma st_refl e : st_leq e e.
Proof.
exists (poset_refl _)=>i V P y m.
by rewrite (pf_irr (poset_refl (pre_of e) i P) P).
Qed.

Lemma st_asym e1 e2 : st_leq e1 e2 -> st_leq e2 e1 -> e1 = e2.
Proof.
move: e1 e2=>[p1 e1 S1 D1 F1][p2 e2 S2 D2 F2]; rewrite /st_leq /=.
case=>E1 R1 [E2 R2].
move: (poset_asym E1 E2)=>?; subst p2.
have : e1 = e2.
- apply: fext=>i; apply: fext=>Vi; apply: fext=>Pi; apply: fext=>y; apply: fext=>m.
  move: (R2 i Vi Pi y m)=>{}R2; move: (R1 i Vi Pi y m)=>{}R1.
  apply: pext; split.
  - by move=>H1; apply: R1; rewrite (pf_irr (E1 i Pi) Pi).
  by move=>H2; apply: R2; rewrite (pf_irr (E2 i Pi) Pi).
move=>?; subst e2.
by congr Prog; apply: pf_irr.
Qed.

Lemma st_trans e1 e2 e3 : st_leq e1 e2 -> st_leq e2 e3 -> st_leq e1 e3.
Proof.
move: e1 e2 e3=>[p1 e1 S1 D1 F1][p2 e2 S2 D2 F2][p3 e3 S3 D3 F3].
case=>/= E1 R1 [/= E2 R2]; rewrite /st_leq /=.
have E3 := poset_trans E2 E1; exists E3=>i V P y m.
set P' := E2 i P.
move: (R1 i V P' y m)=>{}R1; move: (R2 i V P y m)=>{}R2.
move=>H1; apply/R2/R1.
by rewrite (pf_irr (E1 i P') (E3 i P)).
Qed.

(* bottom is a program that can always run but never returns (an endless loop) *)

Definition pre_bot : pre := top.

Definition prog_bot : prog pre_bot A :=
  fun _ _ _ _ => bot.

Lemma sfmono_bot : safe_mono pre_bot.
Proof. by []. Qed.

Lemma dstrict_bot : def_strict prog_bot.
Proof. by move=>*. Qed.

Lemma frame_bot : frameable prog_bot.
Proof. by []. Qed.

Definition st_bot := Prog sfmono_bot dstrict_bot frame_bot.

Lemma st_botP e : st_leq st_bot e.
Proof. by case: e=>p e S D F; exists (@pred_topP _ _)=>???; apply: botP. Qed.

Definition stPosetMixin := PosetMixin st_botP st_refl st_asym st_trans.
Canonical stPoset := Eval hnf in Poset ST stPosetMixin.

(* lattice structure on ST *)

(* intersection of preconditions *)
Definition pre_sup (u : Pred ST) : pre :=
  fun h => forall e, e \In u -> h \In pre_of e.

Definition pre_sup_leq u e (pf : e \In u) : pre_sup u <== pre_of e :=
  fun h (pf1 : pre_sup u h) => pf1 e pf.

(* union of postconditions *)
Definition prog_sup (u : Pred ST) : prog (pre_sup u) A :=
  fun i V P y m => exists e (pf : e \In u),
    prog_of e _ V (pre_sup_leq pf P) y m.

Arguments prog_sup : clear implicits.

Lemma pre_sup_sfmono u : safe_mono (pre_sup u).
Proof.
move=>i j Pi Vij e He.
by apply: sfm_st=>//; apply: Pi.
Qed.

Lemma prog_sup_dstrict u : def_strict (prog_sup u).
Proof. by move=>i P V y; case; case=>p e S D F [H1] /D. Qed.

Lemma prog_sup_frame u : frameable (prog_sup u).
Proof.
move=>i j Pi Vij Pij y m [e][He]Pe.
have Pi' := Pi e He; have Pij' := Pij e He.
move: Pe; rewrite (pf_irr (pre_sup_leq He Pij) Pij').
case/(fr_st Pi' Vij Pij')=>h [{m}-> Vhj Ph].
exists h; split=>//; exists e, He.
by rewrite (pf_irr (pre_sup_leq He Pi) Pi').
Qed.

Definition st_sup u : ST :=
  Prog (@pre_sup_sfmono u) (@prog_sup_dstrict u) (@prog_sup_frame u).

Lemma st_supP u e : e \In u -> e <== st_sup u.
Proof.
case: e=>p e' S D F R.
exists (pre_sup_leq R)=>/=p0 y m H.
by exists (Prog S D F), R.
Qed.

Lemma st_supM u e :
  (forall e1, e1 \In u -> e1 <== e) -> st_sup u <== e.
Proof.
case: e=>p e S D F R.
have J : p <== pre_sup u.
- by move=>/= x Px e' pf; case: (R _ pf)=>/= + _; apply.
exists J=>i V P y m [e0][H0 Hm].
case: (R _ H0)=>/= Hx; apply.
by rewrite (pf_irr (Hx i P) (pre_sup_leq H0 (J i P))).
Qed.

Definition stLatticeMixin := LatticeMixin st_supP st_supM.
Canonical stLattice := Lattice ST stLatticeMixin.

End STDef.

Arguments prog_of [A].
Arguments sfm_st [A e i j].
Arguments dstr_st [A e i].
Arguments fr_st [A e i j].

Section STspecDef.
Variables (G A : Type) (s : spec G A).

(* strongest postcondition predicate transformer *)

Definition vrf' (e : ST A) i (Q : post A) :=
  forall (V : valid i),
    exists (pf : i \In pre_of e), forall y m,
      prog_of e _ V pf y m -> Q y m.

Notation vrf i e Q := (vrf' e i Q).

Definition has_spec (e : ST A) :=
  forall g i, (s g).1 i -> vrf i e (s g).2.

Structure STspec := STprog {
  model :> ST A;
  _ : model \In has_spec}.

Lemma modelE e1 e2 : e1 = e2 <-> model e1 = model e2.
Proof.
move: e1 e2=>[e1 H1][e2 H2] /=; split=>[[//]|E].
by subst e2; congr STprog; apply: pf_irr.
Qed.

(* poset structure on STspec *)

Definition stsp_leq e1 e2 := model e1 <== model e2.

Lemma stsp_refl e : stsp_leq e e.
Proof. by case: e=>e He; apply: poset_refl. Qed.

Lemma stsp_asym e1 e2 : stsp_leq e1 e2 -> stsp_leq e2 e1 -> e1 = e2.
Proof.
move: e1 e2=>[e1 H1][e2 H2]; rewrite /stsp_leq /= =>E1 E2.
have E := poset_asym E1 E2; subst e2.
by congr STprog; apply: pf_irr.
Qed.

Lemma stsp_trans e1 e2 e3 : stsp_leq e1 e2 -> stsp_leq e2 e3 -> stsp_leq e1 e3.
Proof.
move: e1 e2 e3=>[e1 H1][e2 H2][e3 H3].
by apply: poset_trans.
Qed.

Lemma st_bot_has_spec : @st_bot A \In has_spec.
Proof. by move=>g i H V /=; exists I. Qed.

Definition stsp_bot := STprog st_bot_has_spec.

Lemma stsp_botP e : stsp_leq stsp_bot e.
Proof. by case: e=>*; apply: botP. Qed.

Definition stspPosetMixin := PosetMixin stsp_botP stsp_refl stsp_asym stsp_trans.
Canonical stspPoset := Eval hnf in Poset STspec stspPosetMixin.

(* lattice structure on STspec *)

Definition st_sup' (u : Pred STspec) : ST A :=
  sup [Pred p | exists e, p = model e /\ e \In u].

Lemma st_sup_has_spec' u : st_sup' u \In has_spec.
Proof.
move=>g i p Vi.
have J : i \In pre_of (st_sup' u).
- by move=>_ [e][->]; case: e=>e P; case: (P _ _ p Vi).
exists J=>y m /= [e][[[e1 P]]][/= E He1] H; subst e1.
case: (P _ _ p Vi)=>Hi; apply.
set I' := (X in prog_of e _ Vi X) in H.
by rewrite (pf_irr Hi I').
Qed.

Definition stsp_sup u := STprog (@st_sup_has_spec' u).

Lemma stsp_supP u e : e \In u -> e <== stsp_sup u.
Proof. by case: e=>p S R; apply: supP; exists (STprog S). Qed.

Lemma stsp_supM u e :
        (forall e1, e1 \In u -> e1 <== e) -> stsp_sup u <== e.
Proof. by case: e=>p S R; apply: supM=>/= y[q][->]; apply: R. Qed.

Definition stspLatticeMixin := LatticeMixin stsp_supP stsp_supM.
Canonical stspLattice := Lattice STspec stspLatticeMixin.

End STspecDef.

Notation vrf i e Q := (vrf' e i Q).

(************************************)
(* modeling the language primitives *)
(************************************)

(* recursion *)
Section Fix.
Variables (G A : Type) (B : A -> Type) (s : forall x, spec G (B x)).
Notation tp := (forall x, STspec (s x)).
Notation lat := (dfunLattice (fun x => [lattice of STspec (s x)])).
Variable (f : tp -> tp).

(* we take a fixpoint not of f, but of its monotone completion f' *)

Definition f' (e : lat) :=
  sup [Pred t : lat | exists e', e' <== e /\ t = f e'].

Lemma f'_mono : monotone f'.
Proof.
move=>x y H; apply: sup_mono=>fz; case=>z [Hz {fz}->].
by exists z; split=>//; apply/poset_trans/H.
Qed.

Definition Fix : tp := tarski_lfp f'.

(* fixed point constructor which requires explicit proof of monotonicity *)
Definition Fix' (pf : monotone (f : lat -> lat)) : tp :=
  tarski_lfp (f : lat -> lat).

End Fix.

Arguments Fix [G A B s] f x.
Arguments Fix' [G A B s] f pf x.

Section VrfLemmas.
Variables (A : Type) (e : ST A).

Lemma vrfV i (Q : post A) :
        (valid i -> vrf i e Q) -> vrf i e Q.
Proof. by move=>H V; apply: H. Qed.

Lemma vrf_post i (Q1 Q2 : post A) :
        (forall y m, valid m -> Q1 y m -> Q2 y m) ->
        vrf i e Q1 -> vrf i e Q2.
Proof.
move=>H H1 Vi; case: (H1 Vi)=>pf {}H1.
exists pf=>y m Hm.
by apply/H/H1=>//; exact: (dstr_valid Hm).
Qed.

Lemma vrf_frame i j (Q : post A) :
        vrf i e (fun y m => valid (m \+ j) -> Q y (m \+ j)) ->
        vrf (i \+ j) e Q.
Proof.
move=>H Vij; have Vi := validL Vij; case: (H Vi)=>Hi {}H.
have Hij := sfm_st Hi Vij.
exists Hij=>y m.
case/(fr_st Hi Vij Hij)=>h [{m}-> Vhj P].
apply: H=>//.
by rewrite (pf_irr Vi (validL Vij)).
Qed.

Lemma frame_star i (Q : post A) (r : Pred heap) :
        i \In (fun h => vrf h e Q) # r -> vrf i e (fun v => Q v # r).
Proof.
case=>h1[h2][{i}-> H1 H2].
apply: vrf_frame=>V1; case: (H1 V1)=>Hp Hr.
exists Hp=>y m Pm Vm2.
exists m, h2; split=>//.
by apply: Hr.
Qed.

End VrfLemmas.

Section Return.
Variables (A : Type) (x : A).

Definition ret_pre : pre := top.

Definition ret_prog : prog ret_pre A :=
  fun i _ _ y m =>
    m = i /\ y = Val x.

Lemma ret_sfmono : safe_mono ret_pre.
Proof. by []. Qed.

Lemma ret_dstrict : def_strict ret_prog.
Proof. by move=>i [] V _ /= [E _]; rewrite -E in V. Qed.

Lemma ret_frame : frameable ret_prog.
Proof. by move=>i j [Vij []] _ _ [-> ->]; exists i. Qed.

Definition ret := Prog ret_sfmono ret_dstrict ret_frame.

Lemma vrf_ret i (Q : post A) :
        (valid i -> Q (Val x) i) -> vrf i ret Q.
Proof. by move=>H V; exists I=>_ _ [->->]; apply: H. Qed.

End Return.

Section Throw.
Variables (A : Type) (e : exn).

Definition throw_pre : pre := top.

Definition throw_prog : prog throw_pre A :=
  fun i _ _ y m =>
    m = i /\ y = @Exn A e.

Lemma throw_sfmono : safe_mono throw_pre.
Proof. by []. Qed.

Lemma throw_dstrict : def_strict throw_prog.
Proof. by move=>i [] V _ /= [E _]; rewrite -E in V. Qed.

Lemma throw_frame : frameable throw_prog.
Proof. by move=>i j [Vij []] _ _ [-> ->]; exists i. Qed.

Definition throw := Prog throw_sfmono throw_dstrict throw_frame.

Lemma vrf_throw i (Q : post A) :
        (valid i -> Q (Exn e) i) -> vrf i throw Q.
Proof. by move=>H V; exists I=>_ _ [->->]; apply: H. Qed.

End Throw.

Section Bind.
Variables (A B : Type).
Variables (e1 : ST A) (e2 : A -> ST B).

Definition bind_pre : pre :=
  fun i =>
    exists (Vi : valid i) (Pi : i \In pre_of e1),
      forall x m, prog_of e1 _ Vi Pi (Val x) m -> pre_of (e2 x) m.

Definition bind_pre_proj i : i \In bind_pre -> i \In pre_of e1 :=
  fun '(ex_intro _ (ex_intro p _)) => p.

Definition bind_prog : prog bind_pre B :=
  fun i V P y m =>
    exists x h (Ph : h \In prog_of e1 _ V (bind_pre_proj P) x),
      match x with
      | Val x' => exists Ph' : h \In pre_of (e2 x'),
                    m \In prog_of (e2 x') _ (dstr_valid Ph) Ph' y
      | Exn e => y = Exn e /\ m = h
      end.

Lemma bind_sfmono : safe_mono bind_pre.
Proof.
move=>i j [Vi][Pi]P Vij.
have Pij := sfm_st Pi Vij.
exists Vij, Pij=>x m.
case/(fr_st Pi Vij Pij)=>h [{m}-> Vhj].
rewrite (pf_irr (validL Vij) Vi)=>/P Ph.
by apply: sfm_st=>//; apply: (validL Vhj).
Qed.

Lemma bind_dstrict : def_strict bind_prog.
Proof.
move=>i [Vi][Pi P] Vi' y[x][h][/=].
case: x=>[x|e]Ph.
- by case=>Ph' /dstr_st.
by case=>_; move: Ph=>/[swap]<- /dstr_st.
Qed.

Lemma bind_frame : frameable bind_prog.
Proof.
move=>i j [Vi][Pi P] Vij [_ [Pij _]] y m [x][h][/=].
move: (fr_st Pi Vij Pij)=>H.
case: x=>[x|e] Ph.
- case=>Ph'.
  case: (H _ _ Ph)=>h1[Eh V1 Ph1]; subst h.
  rewrite (pf_irr (validL Vij) Vi) in Ph1 *; move: (P _ _  Ph1)=> P21.
  rewrite (pf_irr (dstr_valid Ph) V1).
  case/(fr_st P21 V1 Ph')=>h2[Em Vm Ph2].
  exists h2; split=>//; exists (Val x), h1, Ph1, P21.
  by rewrite (pf_irr (dstr_valid Ph1) (validL V1)).
case=>->->.
case/H: Ph=>h1[Eh Vh Ph1].
by exists h1; split=>//; exists (Exn e), h1, Ph1.
Qed.

Definition bind := Prog bind_sfmono bind_dstrict bind_frame.

Lemma vrf_bind i (Q : post B) :
        vrf i e1 (fun x m =>
                    match x with
                    | Val x' => vrf m (e2 x') Q
                    | Exn e => valid m -> Q (Exn e) m
                    end) ->
        vrf i bind Q.
Proof.
move=>H Vi; case: (H Vi)=>Hi {}H /=.
have Hi' : i \In bind_pre.
- by exists Vi, Hi=>x m Pm; case: (H _ _ Pm (dstr_valid Pm)).
exists Hi'=>y j /= [x][m][Pm] C.
rewrite (pf_irr Hi (bind_pre_proj Hi')) in H.
case: x Pm C=>[x|e] Pm; move: (H _ _ Pm (dstr_valid Pm))=>{}H.
- by case=>Pm2 Pj; case: H=>Pm2'; apply; rewrite (pf_irr Pm2' Pm2).
by case=>->->.
Qed.

End Bind.

Section Try.
Variables (A B : Type).
Variables (e : ST A) (e1 : A -> ST B) (e2 : exn -> ST B).

Definition try_pre : pre :=
  fun i =>
    exists (Vi : valid i) (Pi : i \In pre_of e),
      (forall y  m, prog_of e _ Vi Pi (Val y)  m -> pre_of (e1 y)  m) /\
       forall ex m, prog_of e _ Vi Pi (Exn ex) m -> pre_of (e2 ex) m.

Definition try_pre_proj i : i \In try_pre -> i \In pre_of e :=
  fun '(ex_intro _ (ex_intro p _)) => p.

Definition try_prog : prog try_pre B :=
  fun i V P y m =>
    exists x h (Ph : h \In prog_of e i V (try_pre_proj P) x),
      match x with
      | Val x' => exists (Ph' : h \In pre_of (e1 x')),
                    m \In prog_of (e1 x') _ (dstr_valid Ph) Ph' y
      | Exn ex => exists (Ph' : h \In pre_of (e2 ex)),
                    m \In prog_of (e2 ex) _ (dstr_valid Ph) Ph' y
      end.

Lemma try_sfmono : safe_mono try_pre.
Proof.
move=>i j [Vi [Pi][E1 E2]] Vij.
have Pij := sfm_st Pi Vij.
exists Vij, Pij; split.
- move=>y m.
  case/(fr_st Pi Vij Pij)=>h [{m}-> Vhj].
  rewrite (pf_irr (validL Vij) Vi)=>/E1 Ph.
  by apply: sfm_st=>//; apply: (validL Vhj).
move=>ex m.
case/(fr_st Pi Vij Pij)=>h [{m}-> Vhj].
rewrite (pf_irr (validL Vij) Vi)=>/E2 Ph.
by apply: sfm_st=>//; apply: (validL Vhj).
Qed.

Lemma try_dstrict : def_strict try_prog.
Proof.
move=>i [Vi [Pi][E1 E2]] Vi' y[x][h][/=].
by case: x=>[x|ex] Eh; case=>Ph /dstr_st.
Qed.

Lemma try_frame : frameable try_prog.
Proof.
move=>i j [Vi [Pi][E1 E2]] Vij [_ [Pij _]] y m [x][h][/=].
move: (fr_st Pi Vij Pij)=>H.
case: x=>[x|ex] Ph.
- case=>Ph'.
  case: (H _ _ Ph)=>h1[Eh V1 Ph1]; subst h.
  rewrite (pf_irr (validL Vij) Vi) in Ph1 *; move: (E1 _ _  Ph1)=>P21.
  rewrite (pf_irr (dstr_valid Ph) V1).
  case/(fr_st P21 V1 Ph')=>h2[Em Vm Ph2].
  exists h2; split=>//; exists (Val x), h1, Ph1, P21.
  by rewrite (pf_irr (dstr_valid Ph1) (validL V1)).
case=>Ph'.
case: (H _ _ Ph)=>h1[Eh V1 Ph1]; subst h.
rewrite (pf_irr (validL Vij) Vi) in Ph1 *; move: (E2 _ _  Ph1)=> P21.
rewrite (pf_irr (dstr_valid Ph) V1).
case/(fr_st P21 V1 Ph')=>h2[Em Vm Ph2].
exists h2; split=>//; exists (Exn ex), h1, Ph1, P21.
by rewrite (pf_irr (dstr_valid Ph1) (validL V1)).
Qed.

Definition try := Prog try_sfmono try_dstrict try_frame.

Lemma vrf_try i (Q : post B) :
        vrf i e (fun x m =>
                   match x with
                   | Val x' => vrf m (e1 x') Q
                   | Exn ex => vrf m (e2 ex) Q
                   end) ->
        vrf i try Q.
Proof.
move=>H Vi; case: (H Vi)=>pf {}H /=.
have J : i \In try_pre.
- by exists Vi, pf; split=>x m Pm; case: (H _ _ Pm (dstr_valid Pm)).
exists J=>y j /= [x][m][Pm]F.
rewrite (pf_irr pf (try_pre_proj J)) in H.
case: x Pm F=>[x|ex] Pm [Hm Hj];
case: (H _ _ Pm (dstr_valid Pm))=>pf''; apply;
by rewrite (pf_irr pf'' Hm).
Qed.

End Try.

(* don't export, just for fun *)
Lemma bnd_is_try A B (e1 : ST A) (e2 : A -> ST B) i r :
        vrf i (try e1 e2 (throw B)) r ->
        vrf i (bind e1 e2) r.
Proof.
move=>H Vi; case: (H Vi)=>[[Vi'][P1 /= [E1 E2]]] {}H.
have J : i \In pre_of (bind e1 e2).
- exists Vi, P1=>y m.
  by rewrite (pf_irr Vi Vi')=>/E1.
exists J=>y m /= [x][h][Ph]C.
apply: H; exists x, h=>/=.
rewrite (pf_irr P1 (bind_pre_proj J)) in E2 *; exists Ph.
move: Ph C; case: x=>// e Ph [{y}-> {m}->].
rewrite (pf_irr Vi' Vi) in E2.
by exists (E2 _ _ Ph).
Qed.

Section Read.
Variable (A : Type) (x : ptr).

Local Notation idyn v := (@dyn _ id _ v).

Definition read_pre : pre :=
  fun i => x \in dom i /\ exists v : A, find x i = Some (idyn v).

Definition read_prog : prog read_pre A :=
  fun i _ _ y m =>
    exists w, [/\ m = i, y = Val w & find x m = Some (idyn w)].

Lemma read_sfmono : safe_mono read_pre.
Proof.
move=>i j [Hx [v E]] Vij; split.
- by rewrite domUn inE Vij Hx.
by exists v; rewrite findUnL // Hx.
Qed.

Lemma read_dstrict : def_strict read_prog.
Proof. by move=>i _ Vi _ [_ [E _ _]]; rewrite -E in Vi. Qed.

Lemma read_frame : frameable read_prog.
Proof.
move=>i j [Hx [v E]] Vij _ _ _ [w [-> -> H]].
exists i; split=>//; exists w; split=>{v E}//.
by rewrite findUnL // Hx in H.
Qed.

Definition read := Prog read_sfmono read_dstrict read_frame.

Lemma vrf_read j (v : A) (Q : post A) :
       (valid (x :-> v \+ j) -> Q (Val v) (x :-> v \+ j)) ->
       vrf (x :-> v \+ j) read Q.
Proof.
move=>H Vi /=.
have J : x :-> v \+ j \In read_pre.
- split; first by rewrite domPtUnE.
  by exists v; rewrite findPtUn.
exists J=>_ _ [w [->->]].
rewrite findPtUn //; case=>/inj_pair2 {w}<-.
by apply: H.
Qed.

End Read.

Section Write.
Variable (A : Type) (x : ptr) (v : A).

Local Notation idyn v := (@dyn _ id _ v).

Definition write_pre : pre :=
  fun i => x \in dom i.

Definition write_prog : prog write_pre unit :=
  fun i _ _ y m =>
    [/\ y = Val tt, m = upd x (idyn v) i & x \in dom i].

Lemma write_sfmono : safe_mono write_pre.
Proof.
move=>i j; rewrite /write_pre -!toPredE /= => Hx Vij.
by rewrite domUn inE Vij Hx.
Qed.

Lemma write_dstrict : def_strict write_prog.
Proof.
move=>i Hx _ _ [_ E _]; rewrite /write_pre -toPredE /= in Hx.
suff {E}: valid (upd x (idyn v) i) by rewrite -E.
by rewrite validU (dom_cond Hx) (dom_valid Hx).
Qed.

Lemma write_frame : frameable write_prog.
Proof.
move=>i j Hx Vij _ _ _ [-> -> _].
exists (upd x (idyn v) i); split=>//;
rewrite /write_pre -toPredE /= in Hx.
- by rewrite updUnL Hx.
by rewrite validUUn.
Qed.

Definition write := Prog write_sfmono write_dstrict write_frame.

Lemma vrf_write B (u : B) j (Q : post unit) :
        (valid (x :-> v \+ j) -> Q (Val tt) (x :-> v \+ j)) ->
        vrf (x :-> u \+ j) write Q.
Proof.
move=>H Vi /=.
have J : x :-> u \+ j \In write_pre.
- by rewrite /write_pre -toPredE /= domPtUnE.
exists J=>_ _ [->-> _].
rewrite updPtUn; apply: H.
by rewrite (@validPtUnE _ _ _ _ (idyn u)).
Qed.

End Write.

Section Allocation.
Variables (A : Type) (v : A).

Local Notation idyn v := (@dyn _ id _ v).

Definition alloc_pre : pre := top.

Definition alloc_prog : prog alloc_pre ptr :=
  fun i _ _ y m =>
    exists l, [/\ y = Val l, m = l :-> v \+ i,
                  l != null & l \notin dom i].

Lemma alloc_sfmono : safe_mono alloc_pre.
Proof. by []. Qed.

Lemma alloc_dstrict : def_strict alloc_prog.
Proof.
move=>i [] Vi _ [l][_ E Hl Hl2].
suff {E}: valid (l :-> v \+ i) by rewrite -E.
by rewrite validPtUn; apply/and3P.
Qed.

Lemma alloc_frame : frameable alloc_prog.
Proof.
move=>i j [] Vij [] _ _ [l][->-> Hl Hl2].
exists (l :-> v \+ i); rewrite -joinA; split=>//.
- rewrite validUnAE validPt domPtK Hl Vij /= all_predC.
  apply/hasP=>[[y Hy]]; rewrite !inE=>/eqP E.
  by move: Hy Hl2; rewrite E=>->.
exists l; split=>//.
by apply/dom_NNL/Hl2.
Qed.

Definition alloc := Prog alloc_sfmono alloc_dstrict alloc_frame.

Lemma vrf_alloc i (Q : post ptr) :
        (forall x, valid (x :-> v \+ i) -> Q (Val x) (x :-> v \+ i)) ->
        vrf i alloc Q.
Proof.
move=>H Vi /=.
exists I=>_ _ [x][-> -> Hx Hx2].
by apply: H; rewrite validPtUn Hx Vi.
Qed.

End Allocation.

Section BlockAllocation.
Variables (A : Type) (v : A) (n : nat).

Definition allocb_pre : pre := top.

Definition allocb_prog : prog allocb_pre ptr :=
  fun i _ _ y m =>
    exists l, [/\ y = Val l, m = updi l (nseq n v) \+ i & valid m].

Lemma allocb_sfmono : safe_mono allocb_pre.
Proof. by []. Qed.

Lemma allocb_dstrict : def_strict allocb_prog.
Proof. by move=>i [] Vi y [l][]. Qed.

Lemma allocb_frame : frameable allocb_prog.
Proof.
move=>i j [] Vij [] _ _ [l][->-> V].
exists (updi l (nseq n v) \+ i); rewrite -joinA; split=>//.
exists l; split=>//.
by rewrite joinA in V; apply: (validL V).
Qed.

Definition allocb := Prog allocb_sfmono allocb_dstrict allocb_frame.

Lemma vrf_allocb i (Q : post ptr) :
        (forall x, valid (updi x (nseq n v) \+ i) ->
           Q (Val x) (updi x (nseq n v) \+ i)) ->
        vrf i allocb Q.
Proof.
move=>H Vi /=.
exists I=>_ _ [l][->-> V].
by apply: H.
Qed.

End BlockAllocation.

Section Deallocation.
Variable x : ptr.

Definition dealloc_pre : pre :=
  fun i => x \in dom i.

Definition dealloc_prog : prog dealloc_pre unit :=
  fun i _ _ y m =>
    [/\ y = Val tt, m = free i x & x \in dom i].

Lemma dealloc_sfmono : safe_mono dealloc_pre.
Proof.
move=>i j; rewrite /dealloc_pre -!toPredE /= => Hx Vij.
by rewrite domUn inE Vij Hx.
Qed.

Lemma dealloc_dstrict : def_strict dealloc_prog.
Proof.
move=>i _ Vi _ [_ E _].
suff {E}: valid (free i x) by rewrite -E.
by rewrite validF.
Qed.

Lemma dealloc_frame : frameable dealloc_prog.
Proof.
move=>i j Hx Vij Hx' _ _ [->-> _].
exists (free i x); split=>//;
rewrite /dealloc_pre -!toPredE /= in Hx Hx'.
- by apply/freeUnR/dom_inNL/Hx.
by apply: validFUn.
Qed.

Definition dealloc :=
  Prog dealloc_sfmono dealloc_dstrict dealloc_frame.

Lemma vrf_dealloc A (v : A) j (Q : post unit) :
        (x \notin dom j -> valid j -> Q (Val tt) j) ->
        vrf (x :-> v \+ j) dealloc Q.
Proof.
move=>H Vi /=.
have J: x :-> v \+ j \In dealloc_pre.
- by rewrite /dealloc_pre -toPredE /= domPtUnE.
exists J=>_ _ [->-> Hx].
rewrite freePtUn //; apply: H; last by exact: (validR Vi).
by move: Hx; rewrite domPtUnE validPtUn; case/and3P.
Qed.

End Deallocation.

(* Monotonicity of the constructors *)

Section Monotonicity.

Variables (A B : Type).

Lemma do_mono G (e1 e2 : ST A) (s : spec G A)
        (pf1 : has_spec s e1) (pf2 : has_spec s e2) :
        e1 <== e2 -> @STprog _ _ _ e1 pf1 <== @STprog _ _ _ e2 pf2.
Proof. by []. Qed.

Lemma bind_mono (e1 e2 : ST A) (k1 k2 : A -> ST B) :
        e1 <== e2 -> k1 <== k2 -> (bind e1 k1 : ST B) <== bind e2 k2.
Proof.
move=>[H1 H2] pf2.
have pf: bind_pre e2 k2 <== bind_pre e1 k1.
- move=>h [Vh][Pi] H.
  exists Vh, (H1 _ Pi)=>x m /H2/H H'.
  by case: (pf2 x)=>+ _; apply.
exists pf=>i Vi /[dup][[Vi'][Pi']P'] Pi x h.
case; case=>[a|e][h0][Ph][Ph'] H.
- exists (Val a), h0.
  move: (H2 i Vi (bind_pre_proj Pi))=>H'.
  rewrite (pf_irr (H1 i (bind_pre_proj Pi)) (bind_pre_proj (pf i Pi))) in H'.
  have Ph0 := (H' _ _ Ph); exists Ph0.
  move: (P' a h0); rewrite (pf_irr Vi' Vi) (pf_irr Pi' (bind_pre_proj Pi))=>H''.
  exists (H'' Ph0); case: (pf2 a)=>Pr; apply.
  by rewrite (pf_irr (dstr_valid Ph0) (dstr_valid Ph)) (pf_irr (Pr h0 (H'' Ph0)) Ph').
rewrite Ph' H; exists (Exn e), h0.
move: (H2 i Vi (bind_pre_proj Pi))=>H'.
rewrite (pf_irr (H1 i (bind_pre_proj Pi)) (bind_pre_proj (pf i Pi))) in H'.
by exists (H' _ _ Ph).
Qed.

Lemma try_mono (e1 e2 : ST A) (k1 k2 : A -> ST B) (h1 h2 : exn -> ST B) :
        e1 <== e2 -> k1 <== k2 -> h1 <== h2 ->
        (try e1 k1 h1 : ST B) <== try e2 k2 h2.
Proof.
move=>[H1 H2] pf2 pf3.
have pf: try_pre e2 k2 h2 <== try_pre e1 k1 h1.
- move=>h [Vh][Pi] [Hk Hn].
  exists Vh, (H1 _ Pi); split.
  - move=>x m /H2/Hk H'.
    by case: (pf2 x)=>+ _; apply.
  move=>ex m /H2/Hn H'.
  by case: (pf3 ex)=>+ _; apply.
exists pf =>i Vi /[dup][[Vi'][Pi'][Pk0 Ph0]] Pi x h.
case; case=>[a|e][h0][Ph][Ph'] H.
- exists (Val a), h0.
  move: (H2 i Vi (try_pre_proj Pi))=>H'.
  rewrite (pf_irr (H1 i (try_pre_proj Pi)) (try_pre_proj (pf i Pi))) in H'.
  have Ph1 := (H' _ _ Ph); exists Ph1.
  move: (Pk0 a h0); rewrite (pf_irr Vi' Vi) (pf_irr Pi' (try_pre_proj Pi))=>H''.
  exists (H'' Ph1); case: (pf2 a)=>Pr; apply.
  by rewrite (pf_irr (dstr_valid Ph1) (dstr_valid Ph)) (pf_irr (Pr h0 (H'' Ph1)) Ph').
exists (Exn e), h0.
move: (H2 i Vi (try_pre_proj Pi))=>H'.
rewrite (pf_irr (H1 i (try_pre_proj Pi)) (try_pre_proj (pf i Pi))) in H'.
have Ph1 := (H' _ _ Ph); exists Ph1.
move: (Ph0 e h0); rewrite (pf_irr Vi' Vi) (pf_irr Pi' (try_pre_proj Pi))=>H''.
exists (H'' Ph1); case: (pf3 e)=>Pr; apply.
by rewrite (pf_irr (dstr_valid Ph1) (dstr_valid Ph)) (pf_irr (Pr h0 (H'' Ph1)) Ph').
Qed.

(* the rest of the  constructors are trivial *)
Lemma ret_mono (v1 v2 : A) :
        v1 = v2 -> (ret v1 : ST A) <== ret v2.
Proof. by move=>->. Qed.

Lemma throw_mono (e1 e2 : exn) :
        e1 = e2 -> (throw A e1 : ST A) <== throw A e2.
Proof. by move=>->. Qed.

Lemma read_mono (p1 p2 : ptr) :
        p1 = p2 -> (read A p1 : ST A) <== read A p2.
Proof. by move=>->. Qed.

Lemma write_mono (p1 p2 : ptr) (x1 x2 : A) :
        p1 = p2 -> x1 = x2 -> (write p1 x1 : ST unit) <== write p2 x2.
Proof. by move=>->->. Qed.

Lemma alloc_mono (x1 x2 : A) :
        x1 = x2 -> (alloc x1 : ST ptr) <== alloc x2.
Proof. by move=>->. Qed.

Lemma allocb_mono (x1 x2 : A) (n1 n2 : nat) :
        x1 = x2 -> n1 = n2 -> (allocb x1 n1 : ST ptr) <== allocb x2 n2.
Proof. by move=>->->. Qed.

Lemma dealloc_mono (p1 p2 : ptr) :
        p1 = p2 -> (dealloc p1 : ST unit) <== dealloc p2.
Proof. by move=>->. Qed.

Variables (G : Type) (C : A -> Type) (s : forall x, spec G (C x)).
Notation lat := (dfunLattice (fun x => [lattice of STspec (s x)])).

Lemma fix_mono (f1 f2 : lat -> lat) : f1 <== f2 -> (Fix f1 : lat) <== Fix f2.
Proof.
move=>Hf; apply: tarski_lfp_mono.
- move=>x1 x2 Hx; apply: supM=>z [x][H ->]; apply: supP; exists x.
  by split=>//; apply: poset_trans H Hx.
move=>y; apply: supM=>_ [x][H1 ->].
by apply: poset_trans (Hf x) _; apply: supP; exists x.
Qed.

End Monotonicity.

End Vrf.

Export Vrf.

Definition skip := ret tt.

Corollary vrf_mono A (e : ST A) i : monotone (vrf' e i).
Proof. by move=>/= Q1 Q2 H; apply: vrf_post=>y m _; apply: H. Qed.

(******************************************)
(* Notation for logical variable postexts *)
(******************************************)

Definition logbase A (p : pre) (q : post A) : spec unit A :=
  fun => (p, q).

Definition logvar {B A} (G : A -> Type) (s : forall x : A, spec (G x) B) :
             spec {x : A & G x} B :=
  fun '(existT x g) => s x g.

Notation "'STsep' ( p , q ) " := (STspec unit (logbase p q)) (at level 0).

Notation "{ x .. y }, 'STsep' ( p , q ) " :=
  (STspec _ (logvar (fun x => .. (logvar (fun y => logbase p q)) .. )))
   (at level 0, x binder, y binder, right associativity).

(************************************************************)
(* Lemmas for pulling out and instantiating ghost variables *)
(************************************************************)

(* Lemmas without framing, i.e. they pass the entire heap to the *)
(* routine being invoked.                                        *)

Lemma gE G A (s : spec G A) g i (e : STspec G s) (Q : post A) :
        (s g).1 i ->
        (forall v m, (s g).2 (Val v) m ->
           valid m -> Q (Val v) m) ->
        (forall x m, (s g).2 (Exn x) m ->
           valid m -> Q (Exn x) m) ->
        vrf i e Q.
Proof.
case: e=>e /= /[apply] Hp Hv He; apply: vrfV=>V /=.
by apply/vrf_post/Hp; case=>[v|ex] m Vm H; [apply: Hv | apply: He].
Qed.

Arguments gE [G A s] g [i e Q] _ _.

Notation "[gE]" := (gE tt) (at level 0).

Notation "[ 'gE' x1 , .. , xn ]" :=
  (gE (existT _ x1 .. (existT _ xn tt) ..))
  (at level 0, format "[ 'gE'  x1 ,  .. ,  xn ]").

(* a combination of gE + vrf_bind, for "stepping over" the call *)
Lemma stepE G A B (s : spec G A) g i (e : STspec G s) (e2 : A -> ST B) (Q : post B) :
        (s g).1 i ->
        (forall x m, (s g).2 (Val x) m -> vrf m (e2 x) Q) ->
        (forall x m, (s g).2 (Exn x) m ->
           valid m -> Q (Exn x) m) ->
        vrf i (bind e e2) Q.
Proof.
move=>Hp Hv He.
by apply/vrf_bind/(gE _ Hp)=>[v m P|x m P _] V; [apply: Hv | apply: He].
Qed.

Arguments stepE [G A B s] g [i e e2 Q] _ _.

Notation "[stepE]" := (stepE tt) (at level 0).

Notation "[ 'stepE' x1 , .. , xn ]" :=
  (stepE (existT _ x1 .. (existT _ xn tt) ..))
  (at level 0, format "[ 'stepE'  x1 ,  .. ,  xn ]").

(* a combination of gE + vrf_try *)
Lemma tryE G A B (s : spec G A) g i (e : STspec G s) (e1 : A -> ST B) (e2 : exn -> ST B) (Q : post B) :
        (s g).1 i ->
        (forall x m, (s g).2 (Val x) m -> vrf m (e1 x) Q) ->
        (forall x m, (s g).2 (Exn x) m -> vrf m (e2 x) Q) ->
        vrf i (try e e1 e2) Q.
Proof.
move=>Hp Hv Hx.
by apply/vrf_try/(gE _ Hp)=>[x|ex] m Vm P; [apply: Hv | apply: Hx].
Qed.

Arguments tryE [G A B s] g [i e e1 e2 Q] _ _.

Notation "[tryE]" := (tryE tt) (at level 0).

Notation "[ 'tryE' x1 , .. , xn ]" :=
  (tryE (existT _ x1 .. (existT _ xn tt) ..))
  (at level 0, format "[ 'tryE'  x1 ,  .. ,  xn ]").

(* Common special case for framing on `Unit`, i.e. passing an *)
(* empty heap to the routine. For more sophisticated framing  *)
(* variants see the `heapauto` module.                        *)

Lemma gU G A (s : spec G A) g i (e : STspec G s) (Q : post A) :
        (s g).1 Unit ->
        (forall v m, (s g).2 (Val v) m ->
           valid (m \+ i) -> Q (Val v) (m \+ i)) ->
        (forall x m, (s g).2 (Exn x) m ->
           valid (m \+ i) -> Q (Exn x) (m \+ i)) ->
        vrf i e Q.
Proof.
case: e=>e /= /[apply] Hp Hv Hx; rewrite -(unitL i).
apply/vrf_frame/vrf_post/Hp.
by case=>[x|ex] n _ =>[/Hv|/Hx].
Qed.

Notation "[gU]" := (gU tt) (at level 0).

Notation "[ 'gU' x1 , .. , xn ]" :=
  (gU (existT _ x1 .. (existT _ xn tt) ..))
  (at level 0, format "[ 'gU'  x1 ,  .. ,  xn ]").

(* a combination of gU + vrf_bind *)
Lemma stepU G A B (s : spec G A) g i (e : STspec G s) (e2 : A -> ST B)
             (Q : post B) :
        (s g).1 Unit ->
        (forall x m, (s g).2 (Val x) m -> vrf (m \+ i) (e2 x) Q) ->
        (forall x m, (s g).2 (Exn x) m ->
           valid (m \+ i) -> Q (Exn x) (m \+ i)) ->
        vrf i (bind e e2) Q.
Proof.
move=>Hp Hv Hx.
apply/vrf_bind/(gU _ Hp)=>[x m H V|ex m H V _].
- by apply: Hv H.
by apply: Hx.
Qed.

Arguments stepU [G A B s] g i [e e2 Q] _ _ _.

Notation "[stepU]" := (stepU tt) (at level 0).

Notation "[ 'stepU' x1 , .. , xn ]" :=
  (stepU (existT _ x1 .. (existT _ xn tt) ..))
  (at level 0, format "[ 'stepU'  x1 ,  .. ,  xn ]").

(* a combination of gU + vrf_try *)
Lemma tryU G A B (s : spec G A) g i (e : STspec G s)
             (e1 : A -> ST B) (e2 : exn -> ST B) (Q : post B) :
        (s g).1 Unit ->
        (forall x m, (s g).2 (Val x) m -> vrf (m \+ i) (e1 x) Q) ->
        (forall x m, (s g).2 (Exn x) m -> vrf (m \+ i) (e2 x) Q) ->
        vrf i (try e e1 e2) Q.
Proof.
move=>Hi H1 H2.
apply/vrf_try/(gU _ Hi)=>[x|ex] m H V.
- by apply: H1 H.
by apply: H2.
Qed.

Arguments tryU [G A B s] g i [e e1 e2 Q] _ _ _.

Notation "[tryU]" := (tryU tt) (at level 0).

Notation "[ 'tryU' x1 , .. , xn ]" :=
  (tryU (existT _ x1 .. (existT _ xn tt) ..))
  (at level 0, format "[ 'tryU'  x1 ,  .. ,  xn ]").

(* some notation for writing posts that signify no exceptions are raised *)

Definition vfun' A (f : A -> heap -> Prop) : post A :=
  fun y i => if y is Val v then f v i else False.

Notation "[ 'vfun' x => p ]" := (vfun' (fun x => p))
  (at level 0, x name, format "[ 'vfun'  x  =>  p ]") : fun_scope.

Notation "[ 'vfun' x : aT => p ]" := (vfun' (fun (x : aT) => p))
  (at level 0, x name, only parsing) : fun_scope.

Notation "[ 'vfun' x i => p ]" := (vfun' (fun x i => p))
  (at level 0, x name, format "[ 'vfun'  x  i  =>  p ]") : fun_scope.

Notation "[ 'vfun' ( x : aT ) i => p ]" := (vfun' (fun (x : aT) i => p))
  (at level 0, x name, only parsing) : fun_scope.


Require Import RGref.DSL.DSL.
Require Import RGref.DSL.Concurrency.

(** * Trieber Stack
    A lock-free stack implementation. *)
(** ** Basic heap structure, and rely/guarantee interactions *)
(** Luckily, we can escape the induction-induction encoding since
    nodes are constant. *)
Inductive Node : Set :=
  | mkNode : nat -> option (ref{Node|any}[local_imm,local_imm]) -> Node.
Global Instance reach_ts_node : ImmediateReachability Node :=
{ imm_reachable_from_in := fun T P R G r nd =>
                             match nd with (mkNode n tl) =>
                                             imm_reachable_from_in r tl
                             end }.
Global Instance node_contains : Containment Node :=
{ contains := fun R => True }. (* the recursive refs are heap-agnostic (immutable) *)
(* Nodes grant no heap mutation capabilities ever, so every fold is safe. *)
Global Instance node_fold R G : readable_at Node R G :=
  { res := Node ;
    dofold := fun x => x
  }.
Require Import RGref.DSL.Fields.
Inductive nd_fields : Set := val | nxt.
Instance node_field_type : FieldTyping Node nd_fields.
Instance nxt_type : FieldType Node nd_fields nxt (option (ref{Node|any}[local_imm,local_imm])) :=
{ getF := fun x => match x with (mkNode v tl) => tl end;
  setF := fun x val => match x with (mkNode v tl) => mkNode v val end
}.
Instance val_type : FieldType Node nd_fields val nat :=
{ getF := fun x => match x with (mkNode v tl) => v end;
  setF := fun x val => match x with mkNode v tl => mkNode val tl end
}.

(** We'll follow roughly S11.2 of The Art of Multiprocessor Programming:
    a basic Trieber stack, with no backoff or elimination. *)
Inductive deltaTS : hrel (option (ref{Node|any}[local_imm,local_imm])) :=
  | ts_nop : forall n h h', deltaTS n n h h'
  | ts_push : forall n hd hd' h h', h'[hd']=(mkNode n hd) ->
                                    deltaTS hd (Some hd') h h'
  | ts_pop : forall n hd hd' h h', h[hd]=(mkNode n hd') ->
                                   deltaTS (Some hd) hd' h h'.
(** ** Meta properties of TS-specific rely/guarantee relations *)
Lemma precise_deltaTS : precise_rel deltaTS.
Proof.
  red. intros. induction H1.
  constructor.
  eapply ts_push. rewrite <- H0; eauto. constructor. red. unfold reach_option. constructor.
      red. red. reflexivity.
  eapply ts_pop. rewrite <- H; eauto. constructor. constructor. red. red. reflexivity.
Qed.
Hint Resolve precise_deltaTS.
Lemma hrefl_deltaTS : hreflexive deltaTS.
Proof.
  compute. constructor.
Qed.
Hint Resolve hrefl_deltaTS.

Definition ts := ref{option (ref{Node|any}[local_imm,local_imm])|any}[deltaTS,deltaTS].

(** ** Standard operations *)
(** *** Allocating a new stack *)
Program Definition alloc_ts {Γ} (u:unit) : rgref Γ ts Γ :=
  Alloc None.

(*Local Obligation Tactic := compute; eauto.*)
(** *** Push operation *)
Program Definition push_ts {Γ} : ts -> nat -> rgref Γ unit Γ :=
  RGFix2 _ _ _ (fun rec s n =>
    tl <- !s;
    (* Eventually, lift allocation out of the loop, do substructural
       allocation, and strongly update tail until insertion *)
    (* For some reason the AllocNE notation isn't parsing here... *)
    new_node_pf <- (allocne _ _ _ (mkNode n tl) _ _ _ _ _ _ s);
    (*new_node_pf <- (AllocNE (mkNode n tl) s);*)
    let (new_node, nn_ne_s) := new_node_pf in
    success <- CAS(s,tl,Some (convert new_node (fun v h (pf:v=mkNode n tl) => I)
                                               (rel_sub_refl _ local_imm)
                                               (rel_sub_refl _ local_imm) _
                                               (rel_sub_refl _ local_imm) _ _ _));
    if success then rgret tt else rec s n).
Next Obligation.
  f_equal. intros. rewrite H. reflexivity.
  eapply (rgref_exchange); try solve[compute; eauto].
  split; red; intros. red in H. destruct H. eauto.
  split; eauto. intros. constructor.
  Defined.
Next Obligation. (* local identity constraint stable wrt local_imm *)
  compute. intros. subst. rewrite <- H0. reflexivity. Qed.
Next Obligation.
  compute; eauto. Qed.
Next Obligation. (* Guarantee satisfaction! *)
  eapply ts_push.  rewrite <- convert_equiv.
  Check @heap_lookup2.
  assert (tmp := @heap_lookup2 _ (fun v _ => v=mkNode n ((h[s]))) local_imm local_imm h new_node).
  simpl in tmp.
  rewrite <- tmp. unfold ts in s.
  (* We know new_node and s are not equal, since we allocated new_node with AllocNE while s existed *)
  apply non_ptr_eq_based_nonaliasing. assumption.
Qed.

(** *** Pop operation *)

Require Import Utf8.
Local Obligation Tactic := intros; compute; try subst; intuition; eauto with typeclass_instances.
Program Definition pop_ts {Γ} : ts -> rgref Γ (option nat) Γ :=
  RGFix _ _ (fun rec s =>
    head <- !s;
    match head with
    | None => rgret None
    | Some hd =>
                 observe-field hd --> val as n, pf in (fun a h => @eq nat (getF a) n);
                 (* making the @eq type explicit causes 5 more goals to be auto solved! *)
                 observe-field hd --> nxt as tl', pf' in (fun a h => @eq (option _) (getF a) tl');
                 success <- CAS(s,Some hd,tl');
                 if success then rgret (Some n) else rec s
    end).
Next Obligation. (* options equivalent... *)
  f_equal. intros. rewrite H. reflexivity.
  eapply (rgref_exchange); try solve[compute; eauto].
  split; red; intros. simpl in H. destruct H. eauto.
  split; eauto. intros. constructor.
Defined.
Next Obligation. (* refining hd stability *)
  intros. subst. auto.
Defined.
Next Obligation. (* refining hd stability *)
  intros. subst. auto.
Defined.
Next Obligation. (** Guarantee Satisfaction *)
  eapply ts_pop.
  assert (field_inj : forall nd, nd = mkNode (getF nd) (getF nd)).
      intros. destruct nd. reflexivity.
  rewrite (field_inj (h[hd])). rewrite pf. rewrite pf'. reflexivity.
Qed.


Require Import ModelProperties.
Require Import AuxiliaryLemmas.

Section mkdirIsSecure.

Lemma MkdirPSS :
 forall (s t : SFSstate) (u : SUBJECT),
 FuncPre1 s ->
 FuncPre2 s ->
 FuncPre3 s -> SecureState s -> TransFunc u s Mkdir t -> SecureState t.
intros s t Sub FP1 FP2 FP3 SS TF; inversion TF.
inversion H.
BreakSS.
unfold SecureState in |- *.
split.
unfold DACSecureState in |- *; simpl in |- *.
intros.
cut
 (match fsecmat (secmat s) o with
  | Some y => set_In u0 (ActReaders y) -> PreDACRead s u0 o
  | None => True
  end /\
  match fsecmat (secmat s) o with
  | Some y => set_In u0 (ActWriters y) -> PreDACWrite s u0 o
  | None => True
  end).
elim (fsecmat (secmat s) o).
unfold PreDACRead, PreDACWrite, mkdir_acl in |- *; simpl in |- *.
elim (fsecmat (secmat s) (MyDir p)); elim (fSSC (subjectSC s) Sub).
elim (OBJNAMEeq_dec p (ObjName o)).
intro y.
rewrite y.
replace (facl (acl s) o) with (None (A:=AccessCtrlListData)).
intros.
elim H8; intros.
split; intro.
tauto.

tauto.

rewrite y in H4.
rewrite y in H2.
symmetry  in |- *.
unfold facl in |- *.
apply NotInDOMIsUndef.
eauto.

intro y.
replace
 (facl
    (set_add ACLeq_dec
       (NEWDIR p,
       acldata Sub (primaryGrp s Sub)
         (ChangeUserR Sub (empty_set SUBJECT) (ownerp perms))
         (ChangeGroupR (AllGrp s) (groupp perms)
            (ChangeGroupR (primaryGrp s Sub) (groupp perms)
               (empty_set GRPNAME)))
         (ChangeUserW Sub (empty_set SUBJECT) (ownerp perms))
         (ChangeGroupW (AllGrp s) (groupp perms)
            (ChangeGroupW (primaryGrp s Sub) (groupp perms)
               (empty_set GRPNAME))) (Sub :: nil) (RootGrp s :: nil))
       (acl s)) o) with (facl (acl s) o).
auto.

unfold facl in |- *; apply AddEq.
unfold NEWDIR in |- *.
intro.
apply y.
rewrite H8.
simpl in |- *.
auto.

auto.

auto.

auto.

tauto.

unfold DACSecureState in DAC.
split.
apply ReadWriteImpRead; auto.

apply ReadWriteImpWrite; auto.

unfold MACSecureState in |- *; simpl in |- *; intros.
elim (OBJNAMEeq_dec p (ObjName o)).
intro y.
rewrite y.
replace (fsecmat (secmat s) o) with (None (A:=ReadersWriters)).
replace (fOSC (objectSC s) o) with (None (A:=SecClass)).
elim (fSSC (subjectSC s) u0); elim (fOSC (mkdir_oSC s Sub (ObjName o)) o);
 contradiction || auto.

symmetry  in |- *.
unfold fOSC in |- *; apply NotInDOMIsUndef.
replace (DOM OBJeq_dec (objectSC s)) with (DOM OBJeq_dec (acl s)).
rewrite y in H4; rewrite y in H2; eauto.

symmetry  in |- *; unfold fsecmat in |- *; apply NotInDOMIsUndef.
cut (~ set_In o (DOM OBJeq_dec (acl s))).
unfold not in |- *.
intros SI1 SI2; apply SI1.
unfold FuncPre3 in FP3.
unfold Included in FP3.
auto.

rewrite y in H4; rewrite y in H2; eauto.

intro y.
replace (fOSC (mkdir_oSC s Sub p) o) with (fOSC (objectSC s) o).
unfold MACSecureState in MAC; apply MAC.

auto.

Qed.

Lemma MkdirPSP :
 forall (s t : SFSstate) (u : SUBJECT),
 FuncPre1 s ->
 FuncPre2 s ->
 FuncPre3 s -> StarProperty s -> TransFunc u s Mkdir t -> StarProperty t.
intros s t Sub FP1 FP2 FP3 SP TF; inversion TF.
inversion H.
unfold StarProperty in |- *; simpl in |- *; intros u0 o1 o2.
elim (OBJNAMEeq_dec p (ObjName o1)); elim (OBJNAMEeq_dec p (ObjName o2)).
intros y y0.
replace (fsecmat (secmat s) o1) with (None (A:=ReadersWriters)).
elim (fsecmat (secmat s) o2); elim (fOSC (mkdir_oSC s Sub p) o2);
 elim (fOSC (mkdir_oSC s Sub p) o1); trivial.

eauto.

intros y y0.
replace (fsecmat (secmat s) o1) with (None (A:=ReadersWriters)).
elim (fsecmat (secmat s) o2); elim (fOSC (mkdir_oSC s Sub p) o2);
 elim (fOSC (mkdir_oSC s Sub p) o1); trivial.

eauto.

intros y y0.
replace (fsecmat (secmat s) o2) with (None (A:=ReadersWriters)).
elim (fsecmat (secmat s) o1); elim (fOSC (mkdir_oSC s Sub p) o2);
 elim (fOSC (mkdir_oSC s Sub p) o1); trivial.

eauto.

intros y y0.
replace (fOSC (mkdir_oSC s Sub p) o1) with (fOSC (objectSC s) o1).
replace (fOSC (mkdir_oSC s Sub p) o2) with (fOSC (objectSC s) o2).
unfold StarProperty in SP; apply SP.

auto.

auto.

Qed.

Lemma MkdirPCP :
 forall s t : SFSstate,
 FuncPre1 s -> FuncPre2 s -> PreservesControlProp s Mkdir t.
intros s t FP1 FP2; unfold PreservesControlProp in |- *; intros Sub TF;
 inversion TF; unfold ControlProperty in |- *.
inversion H.
split.
intros.
split.
intro.
inversion H8.
simpl in H10.
elim (OBJNAMEeq_dec p (ObjName o)).
intro.
cut (facl (acl s) o = None).
intro.
rewrite H12 in H9.
discriminate H9.

unfold facl in |- *; apply NotInDOMIsUndef.
rewrite a in H4; rewrite a in H2; eauto.

intro.
cut (y = z).
intro.
cut False.
tauto.

rewrite H12 in H11; inversion H11; auto.

cut (facl (acl s) o = facl (mkdir_acl s Sub p perms) o).
intro EQ; rewrite <- EQ in H10; rewrite H10 in H9; injection H9; auto.

auto.

simpl in H10.
elim (OBJNAMEeq_dec p (ObjName o)).
intro.
cut (facl (acl s) o = None).
intro.
rewrite H12 in H9.
discriminate H9.

unfold facl in |- *; apply NotInDOMIsUndef.
rewrite a in H4; rewrite a in H2; eauto.

intro.
cut (y = z).
intro.
cut False.
tauto.

rewrite H12 in H11; inversion H11; auto.

cut (facl (acl s) o = facl (mkdir_acl s Sub p perms) o).
intro EQ; rewrite <- EQ in H10; rewrite H10 in H9; injection H9; auto.

auto.

intro.
inversion H8.
simpl in H10.
elim (OBJNAMEeq_dec p (ObjName o)).
intro.
cut (fOSC (objectSC s) o = None).
intro.
rewrite H12 in H9; discriminate H9.

unfold fOSC in |- *; apply NotInDOMIsUndef.

replace (DOM OBJeq_dec (objectSC s)) with (DOM OBJeq_dec (acl s)).
rewrite a in H4; rewrite a in H2; eauto.

auto.

intro.
cut (x = y).
intro.
cut False.
tauto.

rewrite H12 in H11; inversion H11; auto.

cut (fOSC (objectSC s) o = fOSC (mkdir_oSC s Sub p) o).
intro EQ; rewrite <- EQ in H10; rewrite H10 in H9; injection H9; auto.

auto.

intros;
 absurd
  (MACSubCtrlAttrHaveChanged s
     (mkSFS (groups s) (primaryGrp s) (subjectSC s)
        (AllGrp s) (RootGrp s) (SecAdmGrp s) (mkdir_oSC s Sub p)
        (mkdir_acl s Sub p perms) (secmat s) (files s)
        (mkdir_directories Sub p)) u0); auto.

Qed.

End mkdirIsSecure.

Hint Resolve MkdirPSS MkdirPSP MkdirPCP.


Require Import Lia.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
From PromisingLib Require Import Language.

Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import PromiseConsistent.
Require Import ReorderPromise.

Set Implicit Arguments.

Lemma steps_pf_steps_aux
      lang
      n e1 e3
      (STEPS: rtcn (@Thread.all_step lang) n e1 e3)
      (CONS: Local.promise_consistent (Thread.local e3))
      (WF1: Local.wf (Thread.local e1) (Thread.memory e1))
      (SC1: Memory.closed_timemap (Thread.sc e1) (Thread.memory e1))
      (MEM1: Memory.closed (Thread.memory e1)):
  exists n' e2,
    <<N: n' <= n>> /\
    <<STEPS1: rtcn (union (Thread.step true)) n' e1 e2>> /\
    <<STEPS2: rtc (union (Thread.step false)) e2 e3>>.
Proof.
  revert_until n. induction n using strong_induction; i.
  inv STEPS.
  { esplits; eauto. }
  inv A12. inv USTEP. exploit Thread.step_future; eauto. i. des.
  destruct pf.
  { exploit Thread.step_future; eauto. i. des.
    exploit IH; eauto. i. des.
    esplits; cycle 1.
    + econs 2; eauto.
    + auto.
    + lia.
  }
  exploit IH; try exact A23; try refl; eauto. i. des.
  assert (CONS2: Local.promise_consistent (Thread.local e2)).
  { exploit rtcn_rtc; try exact A0; eauto. i.
    exploit rtc_implies; [|exact x0|i].
    { apply union_mon. apply Thread.allpf. }
    exploit Thread.rtc_all_step_future; eauto. i. des.
    eapply rtc_all_step_promise_consistent; try exact CONS; eauto.
    eapply rtc_implies; try exact STEPS2; eauto.
    apply union_mon. apply Thread.allpf.
  }
  inv STEPS1.
  { esplits; cycle 1.
    - eauto.
    - econs; eauto.
    - lia.
  }
  inversion A12. exploit Thread.step_future; eauto. i. des.
  exploit reorder_nonpf_pf; eauto.
  { exploit rtcn_rtc; try exact A0; eauto. i.
    eapply rtc_all_step_promise_consistent; try exact CONS; eauto.
    etrans.
    - eapply rtc_implies; [|exact x0]. apply union_mon. apply Thread.allpf.
    - eapply rtc_implies; [|exact STEPS2]. apply union_mon. apply Thread.allpf.
  }
  i. des.
  - subst. esplits; cycle 1; eauto. lia.
  - assert (STEPS: rtcn (@Thread.all_step lang) (S n) e1 e2).
    { econs 2.
      - econs. econs. eauto.
      - eapply rtcn_imply; [|exact A0]. apply union_mon. apply Thread.allpf.
    }
    exploit IH; try exact STEPS; eauto.
    { lia. }
    i. des. esplits; cycle 1; eauto.
    + etrans; eauto.
    + lia.
  - assert (STEPS: rtcn (@Thread.all_step lang) (S n) th1' e2).
    { econs 2.
      - econs. econs 1. eauto.
      - eapply rtcn_imply; [|exact A0]. apply union_mon. apply Thread.allpf.
    }
    exploit Thread.step_future; eauto. i. des.
    exploit IH; try exact STEPS; eauto.
    { lia. }
    i. des. esplits; cycle 1.
    + econs 2; eauto.
    + etrans; eauto.
    + lia.
Qed.

Lemma steps_pf_steps
      lang
      e1 e3
      (STEPS: rtc (@Thread.all_step lang) e1 e3)
      (CONS: Local.promise_consistent (Thread.local e3))
      (WF1: Local.wf (Thread.local e1) (Thread.memory e1))
      (SC1: Memory.closed_timemap (Thread.sc e1) (Thread.memory e1))
      (MEM1: Memory.closed (Thread.memory e1)):
  exists e2,
    <<STEPS1: rtc (union (Thread.step true)) e1 e2>> /\
    <<STEPS2: rtc (union (Thread.step false)) e2 e3>>.
Proof.
  apply rtc_rtcn in STEPS. des.
  exploit steps_pf_steps_aux; eauto. i. des.
  exploit rtcn_rtc; eauto.
Qed.

Lemma tau_steps_pf_tau_steps_aux
      lang
      n e1 e3
      (STEPS: rtcn (@Thread.tau_step lang) n e1 e3)
      (CONS: Local.promise_consistent (Thread.local e3))
      (WF1: Local.wf (Thread.local e1) (Thread.memory e1))
      (SC1: Memory.closed_timemap (Thread.sc e1) (Thread.memory e1))
      (MEM1: Memory.closed (Thread.memory e1)):
  exists n' e2,
    <<N: n' <= n>> /\
    <<STEPS1: rtcn (tau (Thread.step true)) n' e1 e2>> /\
    <<STEPS2: rtc (tau (Thread.step false)) e2 e3>>.
Proof.
  revert_until n. induction n using strong_induction; i.
  inv STEPS.
  { esplits; eauto. }
  inv A12. inv TSTEP. exploit Thread.step_future; eauto. i. des.
  destruct pf.
  { exploit Thread.step_future; eauto. i. des.
    exploit IH; eauto. i. des.
    esplits; cycle 1.
    + econs 2; eauto.
    + auto.
    + lia.
  }
  exploit IH; try exact A23; try refl; eauto. i. des.
  assert (CONS2: Local.promise_consistent (Thread.local e2)).
  { exploit rtcn_rtc; try exact A0; eauto. i.
    exploit rtc_implies; [|exact x0|i].
    { apply tau_mon. apply Thread.allpf. }
    exploit Thread.rtc_tau_step_future; eauto. i. des.
    eapply rtc_all_step_promise_consistent; try exact CONS; eauto.
    eapply rtc_implies; try exact STEPS2; eauto.
    i. apply tau_union. eapply tau_mon; [|eauto]. apply Thread.allpf.
  }
  inv STEPS1.
  { esplits; cycle 1.
    - eauto.
    - econs; eauto.
    - lia.
  }
  inversion A12. exploit Thread.step_future; eauto. i. des.
  exploit reorder_nonpf_pf; eauto.
  { exploit rtcn_rtc; try exact A0; eauto. i.
    eapply rtc_all_step_promise_consistent; try exact CONS; eauto.
    etrans.
    - eapply rtc_implies; [|exact x0]. i. apply tau_union. eapply tau_mon; [|eauto]. apply Thread.allpf.
    - eapply rtc_implies; [|exact STEPS2]. i. apply tau_union. eapply tau_mon; [|eauto]. apply Thread.allpf.
  }
  i. des.
  - subst. esplits; cycle 1; eauto. lia.
  - assert (STEPS: rtcn (@Thread.tau_step lang) (S n) e1 e2).
    { econs 2.
      - econs. econs; eauto. unguardH EVENT1. by destruct e2', e0; des.
      - eapply rtcn_imply; [|exact A0]. apply tau_mon. apply Thread.allpf.
    }
    exploit IH; try exact STEPS; eauto.
    { lia. }
    i. des. esplits; cycle 1; eauto.
    + etrans; eauto.
    + lia.
  - assert (STEPS: rtcn (@Thread.tau_step lang) (S n) th1' e2).
    { econs 2.
      - econs.
        + econs. econs 1. eauto.
        + inv STEP2. ss.
      - eapply rtcn_imply; [|exact A0]. apply tau_mon. apply Thread.allpf.
    }
    exploit Thread.step_future; eauto. i. des.
    exploit IH; try exact STEPS; eauto.
    { lia. }
    i. des. esplits; cycle 1.
    + econs 2; eauto. econs; eauto. unguardH EVENT1. by destruct e2', e0; des.
    + etrans; eauto.
    + lia.
Qed.

Lemma tau_steps_pf_tau_steps
      lang
      e1 e3
      (STEPS: rtc (@Thread.tau_step lang) e1 e3)
      (CONS: Local.promise_consistent (Thread.local e3))
      (WF1: Local.wf (Thread.local e1) (Thread.memory e1))
      (SC1: Memory.closed_timemap (Thread.sc e1) (Thread.memory e1))
      (MEM1: Memory.closed (Thread.memory e1)):
  exists e2,
    <<STEPS1: rtc (tau (Thread.step true)) e1 e2>> /\
    <<STEPS2: rtc (tau (Thread.step false)) e2 e3>>.
Proof.
  apply rtc_rtcn in STEPS. des.
  exploit tau_steps_pf_tau_steps_aux; eauto. i. des.
  exploit rtcn_rtc; eauto.
Qed.

Lemma union_step_nonpf_bot
      lang e1 e2
      (STEP: union (@Thread.step lang false) e1 e2)
      (PROMISE: (Local.promises (Thread.local e2)) = Memory.bot):
  False.
Proof.
  inv STEP. inv USTEP. inv STEP. inv LOCAL. ss. subst. inv PROMISE0; ss.
  - exploit (@Memory.add_o Memory.bot (Local.promises lc1) loc from to msg loc to)
    ; try exact PROMISES; eauto. condtac; ss; [|des; congr].
    rewrite Memory.bot_get. congr.
  - exploit (@Memory.split_o Memory.bot (Local.promises lc1) loc from to ts3 msg msg3 loc to)
    ; try exact PROMISES; eauto. condtac; ss; [|des; congr].
    rewrite Memory.bot_get. congr.
  - exploit (@Memory.lower_o Memory.bot (Local.promises lc1) loc from to msg0 msg loc to)
    ; try exact PROMISES; eauto. condtac; ss; [|des; congr].
    rewrite Memory.bot_get. congr.
Qed.

Lemma rtc_union_step_nonpf_bot
      lang e1 e2
      (STEP: rtc (union (@Thread.step lang false)) e1 e2)
      (PROMISE: (Local.promises (Thread.local e2)) = Memory.bot):
  e1 = e2.
Proof.
  exploit rtc_tail; eauto. i. des; ss.
  exfalso. eapply union_step_nonpf_bot; eauto.
Qed.


Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.

Require Import Language Types.
Require Import Lemmas.
Require Import preservation.
Require Import Label.

Theorem Progress : forall config T ct h ctn ctns,
  config = (Config ct ctn ctns h) ->
  valid_config (Config ct ctn ctns h) ->
  config_has_type ct empty_context (Config ct ctn ctns h) T
  -> terminal_state config \/ (exists config', config ==> config').
Proof with eauto.
  intros config T ct h ctn ctns.
  intro H_config.
  intro H_valid_config.
  intro H_typing.
  remember (empty_context) as Gamma.
  inversion H_typing; subst; auto.
  inversion H2; subst; auto.

  inversion H_valid_config; subst; auto.
  inversion H0; subst; auto; try (apply value_progress with T; auto;fail);
    try (exists Error_state, auto) .
  (*Tvar*)
  - inversion H1; subst; auto.
    destruct H9 with x (classTy T3); auto.
    destruct H10; subst; auto.
    right.
    exists (Config ct (Container x0 fs lb sf) ctns h); auto.

  (*(EqCmp e1 e2)*)
  - pose proof (excluded_middle_value e1).
    destruct H11.
    right.
    + pose proof (excluded_middle_value e2).
      destruct H12.
      ++ pose proof (exclude_middle_val_eq e1 e2 H11 H12).
         destruct H15.
         +++ inversion H11; subst; inversion H; subst; auto.
             ++++ destruct H26 as [F]. destruct H15 as [lo].
                  case_eq (flow_to lo lb); intro.
                  exists (Config ct (Container (B_true) fs lb sf) ctns h).
                  apply ST_EqCmp_result; auto.
                  intros. intuition.
                  right; exists o; exists cls_def; exists F; exists lo;
                    split; auto.
                  right; exists o; exists cls_def; exists F; exists lo;
                    split; auto.

                  exists Error_state.
                  apply ST_EqCmp_leak; auto.
                  left. exists o; exists cls_def; exists F; exists lo;
                          split; auto.
             ++++
               exists (Config ct (Container (B_true) fs lb sf) ctns h).
               apply ST_EqCmp_result; auto.
               intros. intuition.
         +++ inversion H11; subst; inversion H; subst; auto.
             ++++ destruct H27 as [F]. destruct H16 as [lo].
                  inversion H12; subst; inversion H9; subst; auto.
                  +++++ destruct H30 as [F2]. destruct H21 as [lo2].
                    case_eq (flow_to lo lb); intro.
                    case_eq (flow_to lo2 lb); intro.
                  exists (Config ct (Container (B_false) fs lb sf) ctns h).
                  apply ST_EqCmp_result; auto.
                  intros. intuition.

                  right; exists o; exists cls_def; exists F; exists lo;
                    split; auto.
                  right; exists o0; exists cls_def0; exists F2; exists lo2;
                    split; auto.

                  exists Error_state.
                  apply ST_EqCmp_leak; auto.
                  right. exists o0; exists cls_def0; exists F2; exists lo2;
                           split; auto.

                  exists Error_state.
                  apply ST_EqCmp_leak; auto.
                  left. exists o; exists cls_def; exists F; exists lo;
                    split; auto.
                  +++++ case_eq (flow_to lo lb); intro.
                    * exists (Config ct (Container (B_false) fs lb sf) ctns h).
                       apply ST_EqCmp_result; auto.
                       intros. intuition.
                       right; exists o; exists cls_def; exists F; exists lo;
                         split; auto.
                    * exists Error_state.
                       apply ST_EqCmp_leak; auto.
                       left. exists o; exists cls_def; exists F; exists lo;
                               split; auto.
               ++++
                 inversion H12; subst; inversion H9; subst; auto.
                 +++++ destruct H27 as [F2]. destruct H16 as [lo2].
                 case_eq (flow_to lo2 lb); intro.
                 * exists (Config ct (Container (B_false) fs lb sf) ctns h).
                  apply ST_EqCmp_result; auto.
                  intros. intuition.
                  right. exists o; exists cls_def; exists F2; exists lo2;
                           split; auto.
                 * exists Error_state.
                   apply ST_EqCmp_leak; auto.
                   right. exists o; exists cls_def; exists F2; exists lo2;
                            split; auto.
                   +++++ intuition.

                   ++ exists (Config ct (Container e2 ((EqCmp e1 hole) :: fs) lb sf) ctns h).
                      auto.

    + right.
      exists ( Config ct (Container e1 ((EqCmp hole e2) :: fs) lb sf) ctns h). auto.

  (*field access*)
  - pose proof (excluded_middle_value e).
    destruct H10.
    right. inversion H10; subst; inversion H; subst; auto.
    + destruct H25 as [F].
      destruct H12 as [lo].
      assert (exists v, F(f) = Some v).
      apply field_val_of_heap_obj with h o ct cls_def0 lo cls' (find_fields cls_def); auto.
      subst; auto.
      rewrite <- H9 in H16; inversion H16; subst; auto.
      destruct H15 as [v].
      remember (Label.join_label lo lb) as l'.
      exists (Config ct (Container v fs l' sf) ctns h); auto.
      eauto using reduction.
    + exists Error_state; subst; auto.
    + right. exists (Config ct (Container (e) ((FieldAccess hole f)::fs) lb sf) ctns h); auto.

  (* method call *)
  - pose proof (excluded_middle_value e).
    destruct H12; subst; auto.
    right. inversion H12; subst; inversion H; subst; auto.
    + pose proof (excluded_middle_value argu). destruct H21.
      ++ destruct H28 as [F]. destruct H22 as [lx].
         subst. rewrite <- H10 in H23. inversion H23;subst.
         remember (sf_update empty_stack_frame arg_id argu) as sf'.
         case_eq (flow_to lx lb); intro.
         +++ exists (Config ct (Container body nil lb sf' ) ((Container (return_hole) fs lb sf ) :: ctns) h).
             eauto using reduction.
         +++ exists Error_state; subst; auto.
             eauto using reduction.
      ++ pose proof (exclude_middle_unlabelOpaque argu).
         destruct H22.
         +++ destruct H22 as [v]. destruct H22.
             destruct H28 as [F].
             destruct H25 as [lo].
             rewrite <- H10 in H23; inversion H23; subst; auto.
             inversion H9; subst; auto.
             inversion H22; subst; inversion H26; subst; auto.
             ++++ exists Error_state. auto.
             ++++ case_eq (flow_to lo lb); intro.
                  +++++
                    remember ( sf_update empty_stack_frame arg_id v0) as sf'.
                  remember ( join_label lb lb0) as lb'.
                  exists (Config ct (Container body nil lb' sf' ) ((Container return_hole fs lb sf ) :: ctns) h).
                  apply ST_MethodCall_unlableOpaque with cls_def F arg_id arguT returnT lo; auto.
                  +++++ exists Error_state.
                  apply ST_MethodCall_unlableOpaque_leak with cls_def F lo (join_label lb lb0); auto.

         +++ destruct H22; subst; auto.
             ++++ exists (Config ct (Container argu ((MethodCall (ObjId o) meth  hole) :: fs) lb sf) ctns h).
                  auto. apply ST_MethodCall4; auto.
                  intro contra; inversion contra.

             ++++ auto. destruct H22 as [e2]. destruct H22. subst; auto.
                  exists (Config ct (Container e2 ((MethodCall  (ObjId o) meth (unlabelOpaque hole)) :: fs) lb sf) ctns h).
                  apply ST_MethodCall5; auto.
                  intro contra; inversion contra.
                      + exists Error_state; subst; auto.
    + eauto using reduction.

  (*new exp*)
  - destruct H as [cls].
    destruct H as [field_defs].
    destruct H as [method_defs].
    destruct H. remember (get_fresh_oid h) as o.
    remember (init_field_map (find_fields cls) empty_field_map) as F.
    remember (add_heap_obj h o (Heap_OBJ cls F lb)) as h'.
    right. exists (Config ct (Container (ObjId o) fs lb sf ) ctns h').
    apply ST_NewExp with field_defs method_defs cls F; auto.

    Lemma exclude_middle_null : forall v, value v ->
                                          v = null \/ v <> null.
    Proof with eauto.
      intros.  inversion H; try (right; intro contra; inversion contra; fail).
      left. auto.
    Qed. Hint Resolve exclude_middle_null.

  (*label data*)
  -  pose proof (excluded_middle_value e).
     destruct H11; right.
     + pose proof exclude_middle_null e H11 .
       destruct H12.
       exists Error_state. subst; apply ST_LabelDataException.
       exists (Config ct (Container (v_l e lb0)  fs lb sf) ctns h); auto.
     + exists (Config ct (Container e ((labelData hole lb0) :: fs) lb sf) ctns h ); auto.

  (*unlabel*)
  - pose proof (excluded_middle_value e).
    destruct H10; right.
    + inversion H10; subst; inversion H; subst; auto.
      ++ exists Error_state. auto.

      ++ subst. remember (join_label lb lb0) as l'.
         exists (Config ct (Container v fs l' sf) ctns h); auto.
  + exists (Config ct (Container (e) ((unlabel hole)::fs) lb sf) ctns h); auto.

  (*(labelOf e)*)
  - pose proof (excluded_middle_value e).
    destruct H10; right.
    + inversion H10; subst; inversion H; subst; auto.
      ++ exists Error_state. auto.
      ++ exists (Config ct (Container (l lb0) fs lb sf) ctns h). auto.
    + exists (Config ct (Container (e) ((labelOf hole)::fs) lb sf) ctns h); auto.

  (*(unlabelOpaque e)*)
  - pose proof (excluded_middle_value e).
    destruct H10; right.
    + inversion H10; subst; inversion H; subst; auto.
      ++ exists Error_state. auto.
      ++ subst. remember (join_label lb lb0) as l'.
         exists (Config ct (Container v fs l' sf) ctns h); auto.
  + exists (Config ct (Container (e) ((unlabelOpaque hole)::fs) lb sf) ctns h); auto.

  (*raise label*)
  -  pose proof (excluded_middle_value e).
     destruct H11; right.
     + inversion H11; subst; auto; inversion H9; subst; auto.
       destruct H25 as [F]. destruct H12 as [lo].
       case_eq (flow_to lb lo); intro.
       case_eq (flow_to lo lb0); intro.
       remember  (update_heap_obj h o (Heap_OBJ cls_def F lb0)) as h'.
       exists (Config ct (Container Skip fs lb sf) ctns h' ). auto.
       eauto using ST_raiseLabel3 .

       exists Error_state. eauto using ST_raiseLabelException2.
       exists Error_state. eauto using ST_raiseLabelException2.
       exists Error_state. eauto using ST_raiseLabelException1.

     + exists (Config ct (Container e ((raiseLabel hole lb0) :: fs) lb sf) ctns h ); auto.

  (* skip *)
  - destruct fs.
    + inversion H_typing; subst; auto.
      inversion H11; subst; auto.
      inversion H28; subst; auto.
      inversion H21; subst; auto.
      assert (T1 = voidTy); auto.
      subst; auto.
      intuition.
   + right.  exists (Config ct (Container t fs lb sf) ctns h ); auto.

  (*(Assignment x e) *)
  - pose proof (excluded_middle_value e).
    destruct H11; right.
    + remember ( sf_update sf x e) as sf'.
      exists (Config ct (Container Skip fs lb sf') ctns h). auto.
    + exists (Config ct (Container (e) ((Assignment x hole)::fs) lb sf) ctns h); auto.

  (* (FieldWrite x f e)*)
  - pose proof (excluded_middle_value x).
    destruct H12; subst; auto.
    right. inversion H12; subst; inversion H; subst; auto.
    + pose proof (excluded_middle_value e). destruct H15.
      ++ destruct H26 as [F]. destruct H16 as [lx].
         subst. rewrite <- H10 in H21. inversion H21;subst.
         rename lx into lo.
         case_eq (flow_to lb lo); intro.

         +++ inversion H15; subst; auto; inversion H9; subst; auto.
             ++++ destruct H31 as [F0].
                  destruct H23 as [lo0].
                  case_eq (flow_to lo0 lo); intro.
                  +++++ remember (fields_update F f (ObjId o0)) as F'.
                  remember ( update_heap_obj h o (Heap_OBJ cls_def F' lo)) as h'.
                  exists (Config ct (Container Skip fs lb sf) ctns h' ); auto.
                  apply ST_fieldWrite_normal with lo cls_def F F'; auto.
                  right.
                  exists o0. exists cls_def0.
                  exists F0. exists lo0. split; auto.
                  +++++ exists Error_state.
                  apply ST_fieldWrite_leak with lo cls_def F; auto.
                  right.
                  exists o0. exists cls_def0.
                  exists F0. exists lo0. split; auto.
             ++++ remember (fields_update F f null) as F'.
                  remember ( update_heap_obj h o (Heap_OBJ cls_def F' lo)) as h'.
                  exists (Config ct (Container Skip fs lb sf) ctns h' ); auto.
                  apply ST_fieldWrite_normal with lo cls_def F F'; auto.
         +++ exists Error_state.
             apply ST_fieldWrite_leak with lo cls_def F; auto.
      ++ pose proof (exclude_middle_unlabelOpaque e).
         destruct H16.
         +++ destruct H16 as [v]. destruct H16.
             destruct H26 as [F].
             destruct H23 as [lo].
             rewrite <- H10 in H21; inversion H21; subst; auto.
             inversion H9; subst; auto.
             inversion H16; subst; inversion H24; subst; auto.
             ++++ exists Error_state. auto.

             ++++
               case_eq (flow_to (join_label lb lb0) lo); intro.
               +++++
                 inversion H36; subst; inversion H34; subst; auto.
               destruct H39 as [F0].
               destruct H27 as [lo0].
               ++++++ case_eq (flow_to lo0 lo); intro.
                 * remember (fields_update F f (ObjId o0)) as F'.
               remember ( update_heap_obj h o (Heap_OBJ cls_def F' lo)) as h'.
               exists (Config ct (Container Skip fs lb sf) ctns h' ); auto.
               apply ST_fieldWrite_unlableOpaque with lo cls_def F F'; auto.
               right.
               exists o0. exists cls_def0.
               exists F0. exists lo0. split; auto.
                 * exists Error_state.
                   apply ST_fieldWrite_unlableOpaque_leak with lo cls_def F; auto.
                   right. exists o0. exists cls_def0.
                  exists F0. exists lo0. split; auto.
                  ++++++  remember (fields_update F f null) as F'.
                  remember ( update_heap_obj h o (Heap_OBJ cls_def F' lo)) as h'.
                  exists (Config ct (Container Skip fs lb sf) ctns h' ); auto.
                  apply ST_fieldWrite_unlableOpaque with lo cls_def F F'; auto.

                  +++++ exists Error_state.
                  apply ST_fieldWrite_unlableOpaque_leak with lo cls_def F; auto.

        +++ destruct H16.
            ++++ exists (Config ct (Container e ((FieldWrite (ObjId o) f hole) :: fs) lb sf) ctns h).
                  auto. apply ST_fieldWrite3; auto.
                  intro contra; inversion contra.

            ++++ destruct H16 as [e2]. destruct H16.
                 subst; auto.

                  exists (Config ct (Container e2 ((FieldWrite  (ObjId o) f (unlabelOpaque hole)) :: fs) lb sf) ctns h).
                  apply ST_fieldWrite5; auto.
                  intro contra; inversion contra.
    + exists Error_state; subst; auto.
    +  eauto using reduction.

(* if *)
  - pose proof (excluded_middle_value guard). destruct H11; subst; right.
    + inversion H11; subst; inversion H; subst; auto; eauto using reduction.

    + eauto using reduction.

(* sequence *)
  - right. eauto using reduction.

(* (Container hole fs lb sf) *)
  - inversion H18.

(* (Container hole fs lb sf) *)
  - inversion H_valid_config; subst; auto.
    inversion H17.
Qed. Hint Resolve Progress.