Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq heaps rels hprop. 
Require Import domains Eqdep. 
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits. 

Delimit Scope iflow_scope with iflow.
Open Scope iflow_scope.  

(***************************************)
(* Programs are predicate transformers *)
(***************************************)

(* the ideal over which a program runs defines the resources that the     *)
(* program requires. we need to put the set of resources in the type of   *)
(* the program, because otherwise we can't define the notion of safety.   *)
(* if safety is not done via types, one has to rely on run-time checks in *)
(* order to enforce it, but for some commands, this notion is undecidable *)
(* and hence cannot be carried out by a run-time check. typical example   *)
(* is read, which requires that the location stores a value of            *)
(* appropriate type, in order to be safe. checking the type is impossible *)
(* at run time, so read has to have a precondition.                       *)
(* Even if this can be avoided, another problem is nontermination and     *)
(* safety.  we need to make sure that once an error has occured, the      *)
(* continuation simply propagates it. in abseplog, this is done by adding *)
(* top on the lattice of programs (for undefined), and insisting on       *)
(* continuity. but in a setting of relations + intuitionist of coq, it's  *)
(* not clear how to do it.  we get into discreteness problems.            *)

Definition defed (P : Pred heap) : Pred heap := fun i => i \In P /\ def i. 

Definition ideald P := ideal (defed P).

Section Programs.
Variables (A : Type) (P : Pred heap). 

(* first the definition of an ideal out of a heap *)

Definition this i : Pred heap := Pred1 i.

Lemma singleP i : i \In defed P -> this i <== defed P. 
Proof. by move=>[pf1 pf2] h [<-]; split. Qed. 
  
Definition single i (pf : i \In defed P) : ideald P := 
  exist _ (this i) (singleP pf).

Lemma bound (p : ideald P) i : i \In sval p -> i \In defed P.
Proof. by case: p=>p H; case/H. Qed.

(* We now need a definition of continuity using directed sets, not *)
(* chains. So, we can't reuse the old definition. *)

Definition coherent (f : ideald P -> A -> Pred heap) := 
  forall p x m, 
    m \In f p x <-> exists i, exists pf : i \In sval p, 
                    m \In f (single (bound pf)) x.

(* defined heaps map to defined heaps *)
Definition def_strict (f : ideald P -> A -> Pred heap) := 
  forall p x, Undef \Notin f p x. 

Inductive prog := Prog {
  model : ideald P -> A -> Pred heap;
  _ : coherent model; 
  _ : def_strict model}.

Lemma progE (p1 p2 : prog ) : p1 = p2 <-> model p1 = model p2.
Proof.
case: p1 p2=>p1 D1 S1 [p2 D2 S2]; split; case=>E //.
rewrite E in D1 D2 S1 S2 *. 
by congr Prog; apply: proof_irrelevance.
Qed.

(* poset structure on programs *)
Let pleq e1 e2 := model e1 <== model e2.

(* bottom is continuous, strict and has frame *)
Lemma pbot_dcont : coherent pbot.
Proof. by move=>p x m; split=>//; case=>i []. Qed.

Lemma pbot_dstrict : def_strict pbot.
Proof. by move=>p x []. Qed.

Let pbot := Prog pbot_dcont pbot_dstrict.

(* suprema of continuous models are continuous *)
(* same for strict and has_frame *)

Let coerce (s : Pred prog) := fun f => exists e, e \In s /\ model e = f.
Let psup' (s : Pred prog) : ideald P -> A -> Pred heap := psup (coerce s).

Lemma psup_dcont s : coherent (psup' s).
Proof.
move=>p x m; split.
- case=>Q [[f1]][[f2]][[f3]][[]][r] D S [H1] <- -> -> ->.
  case/D=>i [pf] H3.
  exists i; exists pf; exists (r (single (bound pf)) x m).   
  split=>//; do 3![econstructor; split=>//].
  by exists (Prog D S).
case=>i [pf][_][][_][][_][][_][][[r]] D S [H1] <- -> -> -> H2.
have: exists i, exists pf : i \In sval p, m \In r (single (bound pf)) x.
- by exists i; exists pf.
move/D=>H3; exists (r p x m); split=>//.
do 3![econstructor; split=>//].
by exists (Prog D S).
Qed.

Lemma psup_dstrict s : def_strict (psup' s).
Proof. by move=>?? [_][][_][][_][][_][[[r]]] D S [?] <- ->->->; move/S. Qed.

Let psup s := Prog (@psup_dcont s) (@psup_dstrict s).

Lemma prog_refl x : pleq x x.
Proof. by case: x=>mod M S. Qed.

Lemma prog_asym x y : pleq x y -> pleq y x -> x = y.
Proof.
move: x y=>[x1 M1 S1][x2 M2 S2]; rewrite /pleq /= => H1 H2; 
move: M1 M2 S1 S2. 
rewrite (leq_asym H1 H2)=>M1 M2 S1 S2; congr Prog;
by apply: proof_irrelevance.
Qed.

Lemma prog_trans x y z : pleq x y -> pleq y z -> pleq x z.
Proof. by move: x y z=>[x1 M1 S1][x2 M2 S2][x3 M3 S3]; apply: leq_trans. Qed.

Lemma prog_botM x : pleq pbot x.
Proof. by case: x=>x M S; apply: pbotM. Qed.

Lemma prog_supP (s : Pred prog) e : e \In s -> pleq e (psup s).
Proof. by move: e=>[p M S] H; apply: psupP; exists (Prog M S). Qed.

Lemma prog_supM (s : Pred prog) e : 
        (forall e1, e1 \In s -> pleq e1 e) -> pleq (psup s) e.
Proof. by move: e=>[p M S] H; apply: psupM=>y [q][H1] <-; apply: H. Qed.

Definition progPosetMixin := 
  PosetMixin prog_refl prog_asym prog_trans prog_botM prog_supP prog_supM.
Canonical Structure progPoset := Poset progPosetMixin.

Lemma modelM : forall e1 e2, e1 <== e2 -> model e1 <== model e2.
Proof. by move=>[p1 M1 S1][p2 M2 S2]. Qed. 

(* for the purposes of specification, we view *)
(* every program as a set of its runs *)

Definition runs_of (e : prog) : Pred (heap * A * heap) := 
  fun r => exists pf : r.1.1 \In defed P, r.2 \In model e (single pf) r.1.2.

(* Canonical Structure progPredType := mkPredType runs_of. *)

Lemma runsP (e1 e2 : prog) : e1 <== e2 -> runs_of e1 <=p runs_of e2. 
Proof. by move=>H r [H1 T1]; exists H1; apply: modelM T1. Qed.

Lemma runs_bot : runs_of pbot =p Pred0.
Proof. by move=>r; split=>//; case. Qed.

Lemma model_runs e p x m : 
        m \In model e p x <-> exists i, i \In sval p /\ (i, x, m) \In runs_of e. 
Proof.
case: e=>mod H S; rewrite H; split; case=>i [H1] H2. 
- by exists i; split=>//; exists (bound H1).
exists i; exists H1; case: H2 =>/= H2.
by rewrite (proof_irrelevance H2 (bound H1)).
Qed.

Lemma def_runs e i x m : 
        (i, x, m) \In runs_of e -> [/\ def i, i \In P & def m].
Proof.
case: e=>mod H S [[/= D1 H1]] H2; split=>//.
by case: m H2=>//; move/S.
Qed.

End Programs.

Prenex Implicits model_runs def_runs.

(* Our main type is the subset of functions into prog B that and
satisfy the given spec. *)

Definition d (A : Type) := (A * A)%type.

Fixpoint args As : Type := 
  if As is A :: As' then A * args As' : Type else unit.

Fixpoint funtp As B := if As is A :: As' then A -> funtp As' B else B.

Fixpoint fun_app As B : funtp As B -> args As -> B :=
  match As as As' return (funtp As' B -> args As' -> _) with
    [::] => fun f a => f
  | A::As' => fun f a => fun_app (f a.1) a.2
  end.

Fixpoint fun_lam As B : (args As -> B) -> funtp As B := 
  match As as As' return ((args As' -> B) -> funtp As' B) with
    [::] => fun f => f tt
  | A::As' => fun f x => fun_lam (fun as' => f (x, as'))
  end.

Lemma fun_beta As B (f : args As -> B) a : 
        fun_app (fun_lam f) a = f a.
Proof. 
elim: As B f a=>[|A As IH] B f /=; first by move=>[].
by case=>a1 as1 /=; rewrite IH.
Qed.

(* parametrized preconditions *)
Fixpoint pre As : Type := if As is A::As' then A -> pre As' else Pred heap.

Fixpoint pre_app As : pre As -> args As -> Pred heap := 
  match As as As' return (pre As' -> args As' -> _) with
    [::] => fun p a => p
  | A::As' => fun p a => pre_app (p a.1) a.2 
  end.

Fixpoint pre_lam As : (args As -> Pred heap) -> pre As := 
  match As as As' return ((args As' -> _) -> pre As') with
    [::] => fun f => f tt
  | A::As' => fun f a => pre_lam (fun bs => f (a, bs))
  end.

Lemma pre_beta As f (a : args As) : pre_app (pre_lam f) a = f a.
Proof. 
elim: As f a=>[|A As IH] f /=; first by move=>[].
by case=>a1 as1 /=; rewrite IH.
Qed.

(* parametrized postconditions *)
Fixpoint post As B := 
  if As is A::As' then d A -> post As' B 
  else d B -> d heap -> d heap -> Prop.

Fixpoint post_app As B : post As B -> args As -> args As -> 
                           d B -> d heap -> d heap -> Prop :=
  match As as As' return (post As' B -> args As' -> args As' -> _) with
    [::] => fun p a b => p
  | A::As' => fun p a b => post_app (p (a.1, b.1)) a.2 b.2
  end.

Fixpoint post_lam As B : (args As -> args As -> d B -> 
                            d heap -> d heap -> Prop) -> post As B := 
  match As as As' return ((args As' -> args As' -> _) -> post As' B) with
    [::] => fun f => f tt tt
  | A::As' => fun f a => post_lam (fun as1 as2 => f (a.1, as1) (a.2, as2))
  end.

Lemma post_beta As B (f : args As -> _ -> d B -> _) a1 a2 : 
        post_app (post_lam f) a1 a2 = f a1 a2.
Proof. 
elim: As B f a1 a2=>[|A As IH] B f /=; first by move=>[][].
by case=>a1 as1 [a2 as2] /=; rewrite IH.
Qed.

(* parametrized specs *)
Definition spec As B := pre As * post As B : Type. 

(* type of code, with a heap predicate describing code resources *)
Fixpoint code As B : pre As -> poset :=
  match As as As' return pre As' -> _ with
    [::] => fun r => progPoset B r
  | A::As' => fun r => dparamPoset (fun x => @code As' B (r x))
  end. 

Implicit Arguments code [].

Fixpoint code_app As B : 
    forall r, code As B r -> forall a, prog B (pre_app r a) :=
  match As as As' return (forall r, code As' B r -> 
                            forall a, prog B (pre_app r a)) with
    [::] => fun r c a => c
  | A::As' => fun r c a => 
     @code_app As' B (r a.1) (c a.1) a.2
  end.

Fixpoint code_lam As B : 
    forall r, (forall a, prog B (pre_app r a)) -> code As B r := 
  match As as As' return 
     (forall r, (forall a, prog B (pre_app r a)) -> code As' B r) with 
    [::] => fun r f => f tt
  | A::As' => fun r f x => @code_lam As' B (r x) (fun bs => f (x, bs))
  end.

Lemma code_beta As B (r : pre As)
        (f : forall a, prog B (pre_app r a)) (a : args As) : 
        code_app (code_lam f) a = f a.
Proof. by elim: As B r f a=>[|A As IH] B r f /= [] //= b bs; rewrite IH. Qed.

Lemma code_eta As B (r : pre As) 
        (f : forall a, prog B (pre_app r a)) (c : code As B r) : 
      code_lam f = c <->
      forall a : args As, f a = code_app c a.
Proof.
elim: As B r f c=>[|A As IH] B r f /= c.
- by split; [move=><-; case | move/(_ tt)].
split; first by move=><-; case=>b bs; rewrite code_beta.
by move=>H; apply: fext=>b; rewrite IH=>bs; apply: (H (b, bs)).
Qed.

Lemma code_sup_app As B (r : pre As) (t : Pred (code As B r)) (a : args As) : 
        code_app (psup t) a = 
        psup [Pred x : prog B (pre_app r a) | 
              exists y, y \In t /\ x = code_app y a].
Proof.
elim: As B r t a=>[|A As IH] B /= r t.
- case; rewrite progE; apply: psup_eq=>f; split.
  - by case=>e [H] <-; exists e; eauto; split=>//; exists e.
  by case=>e [[g]][H] ->{e} <-{f}; exists g.
case=>b bs; rewrite IH; apply: psup_eq=>x; split.
- by case=>e [[g]][H] ->{e} ->{x}; exists g.
by case=>e [H] ->{x}; exists (e b); split=>//; exists e.
Qed.

Lemma code_appM As B (r : pre As) (a : args As) (e1 e2 : code As B r) :
        e1 <== e2 -> code_app e1 a <== code_app e2 a.
Proof. 
by elim: As B r a e1 e2=>[|A As IH] B r //= [b bs] e1 e2 H; apply: IH. 
Qed.

(* now back to hoare specs *)
Definition has_spec As B (s : spec As B) := 
  [Pred c : code As B s.1 | 
     forall a1 a2 i y m,
       (i.1, y.1, m.1) \In runs_of (code_app c a1) ->
       (i.2, y.2, m.2) \In runs_of (code_app c a2) ->  
       post_app s.2 a1 a2 y i m]. 

(* has_spec is admissible *)
Lemma has_spec_clos As B (s : spec As B) : closed (has_spec s).
Proof.
move: As B s.
suff L: forall As B (p1 p2 : pre As) (q : post As B), 
  closed [Pred c : code As B p1 * code As B p2 | 
           forall a1 a2 i y m, 
             (i.1, y.1, m.1) \In runs_of (code_app c.1 a1) ->
             (i.2, y.2, m.2) \In runs_of (code_app c.2 a2) ->  
             post_app q a1 a2 y i m].
- by move=>As B s; move/(clos_diag): (L _ _ s.1 s.1 s.2).
elim=>[|A As IH] B /=.
- split=>[|D H1 H2][][] i y m; first by move/runs_bot.
  case=>[/= D1][_][[_]][[_]][[_]][[_]][[[f1 g1]]] /= [->] L1 <- -> -> ->.
  case/model_runs=>_ [[<-]] T1.
  case=>[/= D2][_][[_]][[_]][[_]][[_]][[[f2 g2]]] /= [->] L2 <- -> -> ->.
  case/model_runs=>_ [[<-]] T2.
  by case: H1=>_; case/(_ _ _ L1 L2); case=>/= R1 R2;
  [move: L2 | move: L1]; move/H2; move/(_ tt tt i y m);
  apply=>//; [apply: runsP T1 | apply: runsP T2].
move=>p1 p2 q.
split=>[|/= D H1 H2]; move=>/=[a1 as1][a2 as2] i y m /= S1 S2;
case: (IH B (p1 a1) (p2 a2) (q (a1, a2)))=>IH1 IH2.
- by apply: IH1.
set D' := [Pred t | exists f, t.1 = f.1 a1 /\ t.2 = f.2 a2 /\ f \In D].
set G := D : Pred (dparamPoset _ * dparamPoset _).
have: pchain D'.
- case: H1=>[[/= f C1]] C2.
  split=>[|[r1 q1][r2 q2]]; first by exists (f.1 a1, f.2 a2); exists f.
  case=>[[f1 g1]][/= ->][->] L1 [[f2 g2]][/= ->][->] L2.
  case: (C2 _ _ L1 L2); case=>/= T1 T2; [left | right]; 
  by (split=>/=; [apply: T1 | apply: T2]).
move/IH2.
rewrite (_ : psup D' = ((psup G).1 a1, (psup G).2 a2)); last first.
- congr (_, _); apply: psup_eq=>c; 
  (split; last by case=>f [[g]][->] L ->; exists (g.1 a1, g.2 a2); 
                  split=>//; exists g).
  - by case=>f [->][g][->][_] L; exists g.1; split=>//; exists g.
  by case=>f [->][g][_][->] L; exists g.2; split=>//; exists g.
apply=>// [[f1 f2]][[g1 g2]] /= [->][->] L bs1 bs2.
by apply: (H2 (g1, g2) L (a1, bs1) (a2, bs2)).
Qed.

(**************************************************)
(* Modeling the monad and the language primitives *)
(**************************************************)

Definition shape As B (p : post As B) : funtp As (B -> heap -> heap -> Prop) := 
  fun_lam (fun a y i m => post_app p a a (y, y) (i, i) (m, m)).

Definition reflective As B (s : spec As B) :=
  forall (a1 a2 : args As) y i m, 
    def i.1 -> def i.2 -> pre_app s.1 a1 i.1 -> pre_app s.1 a2 i.2 ->
    post_app s.2 a1 a2 y i m  -> 
      fun_app (shape s.2) a1 y.1 i.1 m.1 /\
      fun_app (shape s.2) a2 y.2 i.2 m.2.

(* the model of computations is the sub-cpo of all programs *)
(* that satisfy the spec *)
Inductive rspec As B := Rspec {spec_of : spec As B;
                               refl_of : reflective spec_of}.

Implicit Arguments refl_of [As B].

Notation "r ..1" := ((spec_of r).1) (at level 0).
Notation "r ..2" := ((spec_of r).2) (at level 0).
Notation "r ..3" := (refl_of r) (at level 0).

(* this is the large footprint monad *)
Definition LST As B (s : spec As B) := subCPO (has_spec_clos s). 

Implicit Arguments LST [As B].

Definition pval As B (s : spec As B) (e : LST s) : code As B s.1 := e. 

(* the following lemma is mostly used in forward style *)
Lemma spec_runs As B (s : spec As B) (e : LST s) a1 a2 y1 y2 i1 i2 m1 m2 :
        (i1, y1, m1) \In runs_of (code_app (pval e) a1) ->
        (i2, y2, m2) \In runs_of (code_app (pval e) a2) -> 
        post_app s.2 a1 a2 (y1, y2) (i1, i2) (m1, m2).
Proof. by case: e=>e H; apply: (H a1 a2 (i1, i2) (y1, y2) (m1, m2)). Qed.

Implicit Arguments spec_runs [As B s a1 a2 y1 y2 i1 i2 m1 m2].  

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

Module Model.

(* recursion *)

Section Fix.
Variables (As : seq Type) (B : Type) (s : spec As B).
Variables (f : LST s -> LST s) (C : continuous f).

Definition ffix : LST s := lfp C.
End Fix.

(* simultaneous application of a command to arguments *)
Section Instantiation.
Variables (As Bs : seq Type) (B : Type) (s : spec As B).
Variables (e : LST s) (f : funtp Bs (args As)).

Definition inst_s : spec Bs B := 
  (pre_lam (fun b => pre_app s.1 (fun_app f b)), 
   post_lam (fun b1 b2 => post_app s.2 (fun_app f b1) (fun_app f b2))).

Definition inst_sp b (p : ideald (pre_app inst_s.1 b)) y m := 
  exists i, i \In sval p /\ 
    (i, y, m) \In runs_of (code_app (pval e) (fun_app f b)).

Lemma inst_cont b : coherent (@inst_sp b).
Proof.
move=>p x m; split; last by case=>i [H][_][[<-]]; exists i.
by case=>i [/= H]; exists i; exists H; exists i.
Qed.

Lemma inst_dstrict b : def_strict (@inst_sp b). 
Proof. by move=>p x [i][_]; case/def_runs. Qed.

Definition inst_prog := 
  code_lam (fun b => Prog (@inst_cont b) (@inst_dstrict b)).

Lemma inst_has_spec : inst_prog \In has_spec inst_s. 
Proof.
move=>b1 b2 [i1 i2][y1 y2][m1 m2] /=; rewrite !code_beta. 
move=>[/= D1][_][[<-]] H1 [/= D2][_][[<-]] H2.
by rewrite post_beta; apply: (spec_runs _ H1 H2).
Qed.

Definition inst := @bundle (LST inst_s) _ inst_has_spec.

End Instantiation.

(* rule of assignment *)
(* serves as monadic unit in the type theory *)
Section Return.
Variables (A : Type). 

Definition ret_pre : pre [:: A] := fun x i => True.
Definition ret_post : post [:: A] A := fun x y i m => m = i /\ y = x.
Definition ret_s := (ret_pre, ret_post).

Definition ret_sp x (p : ideald (ret_s.1 x)) y m := 
  m \In sval p /\ y = x.

Lemma ret_cont x : coherent (@ret_sp x).
Proof.
move=>p y m; split; first by case=>H ->{y}; exists m; exists H.
by case=>i [H1] [[<-{m}]] ->{y}.
Qed.  

Lemma ret_dstrict x : def_strict (@ret_sp x).
Proof. by case=>p H y /= []; case/H. Qed.

Definition ret_prog x := Prog (@ret_cont x) (@ret_dstrict x).

Lemma ret_has_spec : ret_prog \In has_spec ret_s.
Proof.
move=>[x1 []][x2 []][i1 i2][y1 y2][m1 m2] /=.
by move=>[/= T1][[<-]] -> [/= T2][<-] ->.
Qed.
 
Definition ret := @bundle (LST ret_s) _ ret_has_spec.

End Return.

(* rule of sequential composition *)
(* serves as monadic bind in type theory *)

Section Bind.
Variables (As : seq Type) (A B : Type).
Variables (s1 : spec As A) (s2 : spec [:: A & As] B).
Variables (e1 : LST s1) (e2 : LST s2).

Definition bind_pre : pre As :=
  pre_lam (fun a i => i \In (pre_app s1.1 a) /\ 
             forall y m, post_app s1.2 a a (y, y) (i, i) (m, m) -> def m -> 
                         m \In (pre_app s2.1 (y, a))).
Definition bind_post : post As B := 
  post_lam (fun a1 a2 y i m => exists x, exists h, 
              post_app s1.2 a1 a2 x i h /\ def h.1 /\ def h.2 /\
              post_app s2.2 (x.1, a1) (x.2, a2) y h m).
Definition bind_s := (bind_pre, bind_post).

Definition bind_sp a (p : ideald (pre_app bind_s.1 a)) y m := 
   exists i, exists x, exists h, i \In sval p /\
     (i, x, h) \In runs_of (code_app (pval e1) a) /\ 
     (h, y, m) \In runs_of (code_app (pval e2) (x, a)).

Lemma bind_dcont a : coherent (@bind_sp a).
Proof.
move=>[p H] y m; split.
- case=>i [x][h][/= H1][H2] H3.
  by exists i; exists H1; exists i; exists x; exists h.
case=>i [/= H1][_][x][h][[<-]][T1 T2].
by exists i; exists x; exists h.
Qed.

Lemma bind_dstrict a : def_strict (@bind_sp a).
Proof. by move=>p y [i][x][h][H1][H2]; case/def_runs. Qed.

Definition bind_prog := 
  code_lam (fun a => Prog (@bind_dcont a) (@bind_dstrict a)).

Lemma bind_has_spec : bind_prog \In has_spec bind_s.
Proof.
move=>a1 a2 [i1 i2][y1 y2][m1 m2] /=; rewrite !code_beta.
case=>/= D1 [_][x1][h1][[<-]][T1] S1; case/def_runs: (T1)=>_ _ Y1.
case=>/= D2 [_][x2][h2][[<-]][T2] S2; case/def_runs: (T2)=>_ _ Y2.
rewrite post_beta; exists (x1, x2); exists (h1, h2); split.
- by apply: spec_runs T2.
by do !split=>//; apply: spec_runs S2.
Qed. 

Definition bind := @bundle (LST bind_s) _ bind_has_spec.

End Bind.

(* definitions for a Hoare fourtuple *)
(* serves as subsumption rule in the type theory *)

Definition conseq As B (s1 : spec As B) (e : LST s1) (s2 : spec As B) :=
  (forall a i, pre_app s2.1 a i -> def i -> pre_app s1.1 a i) /\
  (forall a1 a2 i y m, 
     pre_app s2.1 a1 i.1 -> pre_app s2.1 a2 i.2 -> def i.1 -> def i.2 ->
       (i.1, y.1, m.1) \In runs_of (code_app (pval e) a1) ->
       (i.2, y.2, m.2) \In runs_of (code_app (pval e) a2) -> 
     post_app s2.2 a1 a2 y i m).

Section Consequence.
Variables (As : seq Type) (B : Type) (s1 : spec As B) (s2 : spec As B). 
Variables (e : LST s1) (pf : conseq e s2). 

Definition do_sp a (p : ideald (pre_app s2.1 a)) y m := 
  exists i, i \In sval p /\ (i, y, m) \In runs_of (code_app (pval e) a). 

Lemma do_dcont a : coherent (@do_sp a).
Proof.
move=>[q H] y m; split.
- by case=>i [/= H1 T1]; exists i; exists H1; exists i.
by case=>i [/= H1][_][[<-]] T1; exists i.
Qed.

Lemma do_dstrict a : def_strict (@do_sp a).
Proof. by move=>q y [h][/= H]; case/def_runs. Qed.

Definition do_prog := 
  code_lam (fun a => Prog (@do_dcont a) (@do_dstrict a)). 

Lemma do_has_spec : do_prog \In has_spec s2.
Proof.
move=>a1 a2 i y m; rewrite !code_beta.
case=>[[/= H1 D1]][_][[<-]] T1 [[/= H2 D2]][_][[<-]] T2.
by case: pf=>_; apply.
Qed.

Definition Do := @bundle (LST s2) _ do_has_spec.

End Consequence.

Implicit Arguments Do [As B s1 s2].

(*************************************)
(* now the non-structural primitives *)
(*************************************)

(* read *)

Section Read.
Variables (A : Type).

Definition read_s : spec [:: ptr:Type] A := 
  (fun l i => exists h, exists v : A, i = l :-> v :+ h, 
   fun l y i m => m = i /\ 
     forall h v, i.1 = l.1 :-> v.1 :+ h.1 -> 
                 i.2 = l.2 :-> v.2 :+ h.2 -> y = v).

Definition read_sp l (p : ideald (read_s.1 l)) (x : A) m :=
  m \In sval p /\ look l m = dyn x. 

Lemma read_dcont l : coherent (@read_sp l).
Proof.
move=>p x m; split; last by case=>i [H1][[<-]].
by case=>H1 [H2]; exists m; exists H1.
Qed.

Lemma read_dstrict l : def_strict (@read_sp l).
Proof. by move=>[p H] y []; case/H. Qed.

Definition read_prog l :=
  Prog (@read_dcont l) (@read_dstrict l).

Lemma read_has_spec : read_prog \In has_spec read_s.
Proof.
move=>[l1 []][l2 []][i1 i2][y1 y2][m1 m2] /=.
case=>[[/= _ D1]][[<-]] T1; case=>[[/= _ D2]][[<-]] T2.
split=>// [[h1 h2]][v1 v2] /= E1 E2.
move: D1 D2 T1 T2; rewrite {}E1 {}E2=>D1 D2.
by rewrite !lookPtUn //; do 2![move/dyn_inj=>->].
Qed.

Definition read := @bundle (LST read_s) _ read_has_spec.

End Read.

(* write *) 
  
Section Write.
Variable (A : Type).

Definition write_s : spec [:: ptr:Type; A] unit := 
  (fun l v i => exists h, exists B, exists w:B, i = l :-> w :+ h,
   fun l v y i m => 
     forall h B1 B2 (w1 : B1) (w2 : B2), 
       i.1 = l.1 :-> w1 :+ h.1 -> 
       i.2 = l.2 :-> w2 :+ h.2 -> 
       m.1 = l.1 :-> v.1 :+ h.1 /\ m.2 = l.2 :-> v.2 :+ h.2).

Definition write_sp l v (p : ideald (write_s.1 l v)) (y : unit) m :=
  exists i, sval p i /\ l \in dom i /\ m = upd i l (dyn v).

Lemma write_dcont l v : coherent (@write_sp l v).
Proof.
move=>p y m; split; case=>i [H1]. 
- by case=>H2 ->; exists i; exists H1; exists i.
by case=>_ [[<-]][H2] ->; exists i.
Qed.

Lemma write_dstrict l v : def_strict (@write_sp l v).
Proof.
move=>[p H] y [x][_][H1].
suff L: def (upd x l (dyn v)) by move=>H2; rewrite -H2 in L.
by rewrite defU (dom_null H1) (dom_def H1).
Qed.

Definition write_prog l v :=
  Prog (@write_dcont l v) (@write_dstrict l v).

Lemma write_has_spec : write_prog \In has_spec write_s.
Proof.
move=>[l1][v1][][l2][v2][][i1 i2][[][]][m1 m2] /=.
case=>[[/= _ D1]][_][[<-]][_] -> [[/= _ D2]][_][[<-]][_] ->.
move=>h1 h2 B w1 w2 E1 E2; rewrite E1 E2 in D1 D2 *.
rewrite !updUnl !domPt !inE !eq_refl /= (defPt_null D1) (defPt_null D2).
by rewrite updU eq_refl updU eq_refl.
Qed.

Definition write := @bundle (LST write_s) _ write_has_spec.

End Write.

(* allocation *)

Section LowAllocation.
Variables (A : Type).

Definition lalloc_s : spec [:: A] ptr := 
  (fun v i => True,
   fun v y i m => 
     m = (y.1 :-> v.1 :+ i.1, y.2 :-> v.2 :+ i.2) /\
     (i.1 =~ i.2 -> y.1 = y.2 /\ m.1 =~ m.2)).

Definition lalloc_sp v (p : ideald (lalloc_s.1 v)) y m := 
  exists i, sval p i /\ y = lfresh i /\ m = y :-> v :+ i.

Lemma lalloc_dcont v : coherent (@lalloc_sp v).
Proof.
move=>p x m; split; case=>i [H1].
- by case=>-> ->; exists i; exists H1; exists i.
by case=>_ [[<-]][->] ->; exists i.
Qed.

Lemma lalloc_dstrict v : def_strict (@lalloc_sp v).
Proof.
move=>[p H] y [h][/= H1][->] H2; case/H: H1=>_ D.
suff: def (lfresh h :-> v :+ h) by rewrite -H2. 
by rewrite defPtUn lfresh_null D /= -(ptr0 (lfresh h)) (dom_lfresh h 0).
Qed.

Definition lalloc_prog v := 
  Prog (@lalloc_dcont v) (@lalloc_dstrict v).

Lemma lalloc_has_spec : lalloc_prog \In has_spec lalloc_s.
Proof.
move=>[v1][][v2][][i1 i2][y1 y2][m1 m2] /= S1 S2.
case/def_runs: (S1)=>_ _ D1; case/def_runs: (S2)=>_ _ D2.
case: S1 D1=>/= _ [_][[<-]][->] -> D1.
case: S2 D2=>/= _ [_][[<-]][->] -> D2.
split=>// H; rewrite (loweqE H); split=>//.
by rewrite lowPtUn // -(loweqE H).
Qed.

Definition lalloc := @bundle (LST lalloc_s) _ lalloc_has_spec.

End LowAllocation. 

(* high allocation *)

Section HighAllocation.
Variables (A : Type).

Definition halloc_s : spec [:: A] ptr := 
  (fun v i => True,
   fun v y i m => 
     m = (y.1 :-> v.1 :+ i.1, y.2 :-> v.2 :+ i.2) /\ 
     high y.1 /\ high y.2).

Definition halloc_sp v (p : ideald (halloc_s.1 v)) y m := 
  exists i, sval p i /\ m = y :-> v :+ i /\ high y /\ 
    y != null /\ y \notin dom i.

Lemma halloc_dcont v : coherent (@halloc_sp v).
Proof.
move=>p x m; split; case=>i [H1].
- by case=>-> H2; exists i; exists H1; exists i.
by case=>_ [[<-]][->] H2; exists i.
Qed.

Lemma halloc_dstrict v : def_strict (@halloc_sp v).
Proof.
move=>[p H] y [h][/= H1][H2][H3][H4] H5; case/H: H1=>_ D.
suff: def (y :-> v :+ h) by rewrite -H2.
by rewrite defPtUn H4 D H5.
Qed. 

Definition halloc_prog v := 
  Prog (@halloc_dcont v) (@halloc_dstrict v).

Lemma halloc_has_spec : halloc_prog \In has_spec halloc_s.
Proof.
move=>[v1][][v2][][i1 i2][y1 y2][m1 m2] /= S1 S2.
case/def_runs: (S1)=>D1 _ _; case/def_runs: (S2)=>D2 _ _.
case: S1=>/= H1 [_][[<-]][->][N1][M1 V1] {H1}.
by case: S2=>/= H2 [_][[<-]][->][N2][M2 V2] {H2}.
Qed.

Definition halloc := @bundle (LST halloc_s) _ halloc_has_spec.

End HighAllocation. 

(* deallocation *)

Section Deallocation. 

Definition dealloc_s : spec [:: ptr:Type] unit :=  
  (fun l i => exists h,exists A, exists v : A, i = l :-> v :+ h, 
   fun l y i m => 
     forall h A1 A2 (v1 : A1) (v2 : A2), 
       i.1 = l.1 :-> v1 :+ h.1 -> i.2 = l.2 :-> v2 :+ h.2 -> 
       m = (h.1, h.2)).

Definition dealloc_sp l (p : ideald (dealloc_s.1 l)) (y : unit) m :=
  exists i, sval p i /\ l \in dom i /\ m = free l i.

Lemma dealloc_dcont l : coherent (@dealloc_sp l).
Proof.
move=>p [] m; split; case=>i [H1].
- by case=>H2 ->{m}; exists i; exists H1; exists i.
by case=>_ [[<-]][H2] ->{m}; exists i. 
Qed.

Lemma dealloc_dstrict l : def_strict (@dealloc_sp l).
Proof.
move=>[p H] y [h][/=]; case/H=>_ H1 [H2] H3.
suff: def (free l h) by rewrite -H3.
by rewrite defF.
Qed. 

Definition dealloc_prog l := 
  Prog (@dealloc_dcont l) (@dealloc_dstrict l).

Lemma dealloc_has_spec : dealloc_prog \In has_spec dealloc_s.
Proof.
move=>[l1][][l2][][i1 i2][y1 y2][m1 m2] /=.
case=>[[/= _ D1]][_][[<-]][H1] ->{m1} [[/= _ D2]][_][[<-]][H2] ->{m2}.
case=>h1 h2 A1 A2 v1 v2 E1 E2; rewrite {}E1 {}E2 /= in H1 H2 D1 D2 *.
rewrite !freeUnr ?(defPt_dom D1) ?(defPt_dom D2) // !freeU !eq_refl.
by rewrite (negbTE (defPt_null D1)) (negbTE (defPt_null D2)) !free0 !un0h.
Qed.

Definition dealloc := @bundle (LST dealloc_s) _ dealloc_has_spec.

End Deallocation.

End Model.