Load loadpath.
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
Require Import prelude domains heaps rels hprop.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Delimit Scope iflow_scope with iflow.
Open Scope iflow_scope.  

(* dedicated notation for sequences of types *)
(* when writing local context types, forces coq to infer *)
(* that nat, bool, ptr, etc, are Type, not Set *)

Definition tnil := (Nil Type).
Definition tcons := (Cons Type).

Notation "x ::: s" := (tcons x s)
  (at level 60, right associativity, format "x  :::  s") : iflow_scope.

Notation "[ ::: ]" := tnil (at level 0, format "[ ::: ]") : iflow_scope.

Notation "[ ::: x1 ]" := (tcons x1 nil)
  (at level 0, format "[ :::  x1 ]") : iflow_scope.

Notation "[ ::: x & s ]" := (tcons x s) (only parsing) : iflow_scope.

Notation "[ ::: x1 , x2 , .. , xn & s ]" := 
 (tcons x1 (tcons x2 .. (tcons xn s) ..))
  (at level 0, format
  "'[hv' [ ::: '['  x1 , '/'  x2 , '/'  .. , '/'  xn ']' '/ '  &  s ] ']'"
  ) : iflow_scope.

Notation "[ ::: x1 ; x2 ; .. ; xn ]" := 
  (tcons x1 (tcons x2 .. [::: xn] .. )) 
  (at level 0, format "[ ::: '['  x1 ; '/'  x2 ; '/'  .. ; '/'  xn ']' ]"
  ) : iflow_scope.

(**********************************************)
(* parametrized preconditions, postconditions *)
(* and arity-polymorphic functions            *)
(**********************************************)

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

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

Fixpoint dargs As : Type := 
  if As is A::As' then d A * dargs As' : Type else (unit * unit):Type. 

Fixpoint dpair As : args As -> args As -> dargs As := 
  match As as As' return (args As' -> args As' -> dargs As') with 
    [::] => fun a1 a2 => (tt, tt)
  | A::As' => fun a1 a2 => ((a1.1, a2.1), (dpair a1.2 a2.2))
  end.

Fixpoint dfst As : dargs As -> args As := 
  match As as As' return (dargs As' -> args As') with
    [::] => fun a => tt
  | A::As' => fun a => (a.1.1, dfst a.2)
  end.

Fixpoint dsnd As : dargs As -> args As := 
  match As as As' return (dargs As' -> args As') with
    [::] => fun a => tt
  | A::As' => fun a => (a.1.2, dsnd a.2)
  end.

Lemma dargs_beta1 As (a1 a2 : args As) : dfst (dpair a1 a2) = a1.
Proof.
elim: As a1 a2=>[|A As IH] /=; first by case.
by move=>[a1 as1][a2 as2]; rewrite IH.
Qed.

Lemma dargs_beta2 As (a1 a2 : args As) : dsnd (dpair a1 a2) = a2.
Proof.
elim: As a1 a2=>[|A As IH] /=; first by move=>_; case.
by move=>[a1 as1][a2 as2]; rewrite IH.
Qed.

Lemma dargs_eta As (a : dargs As) : a = dpair (dfst a) (dsnd a).
Proof.
elim: As a=>[|A As IH] /=; first by case=>[][][].
by case=>[[a1 a2]] as1 /=; rewrite -IH.
Qed.

Fixpoint funtp As B := if As is A::As' then A -> funtp As' B else B.
Fixpoint dfuntp As B := if As is A::As' then d A -> dfuntp 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.

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

Fixpoint dfun_lam As B : (dargs As -> B) -> dfuntp As B := 
  match As as As' return ((dargs As' -> _) -> dfuntp As' B) with
    [::] => fun f => f (tt, tt)
  | A::As' => fun f b => dfun_lam (fun bs => f (b, bs))
  end.

Lemma dfun_beta As B (f : dargs As -> B) a : 
        dfun_app (dfun_lam f) a = f a.
Proof.
elim: As B f a=>[|A As IH] B f /=; first by move=>[][][].
by case=>aa aas; rewrite IH.
Qed.

Notation pre As := (funtp As (Pred heap)).
Notation post As B := (dfuntp As (d heap -> d B -> d heap -> Prop)).

Definition spec As B := pre As * post As B : Type.

(**********************)
(* Building the model *)
(**********************)

Module Model.

(* parametrization of programs *)

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

Notation ideald p := (ideal (defed p)).

(* base program type *)

Definition prog0 B P := [cpo of ideald P -> B -> Pred heap].

Implicit Arguments prog0 [].

Fixpoint prog As B : pre As -> cpo :=
  match As as As' return pre As' -> _ with
    [::] => fun p => prog0 B p
  | A::As' => fun p => dfunCPO (fun x => @prog As' B (p x))
  end. 

Implicit Arguments prog [].

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

Implicit Arguments prog_app [As B r].

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

Lemma prog_beta As B (r : pre As)
        (f : forall (a : args As), prog0 B (fun_app r a)) (a : args As) : 
        prog_app (prog_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 prog_eta As B (r : pre As) (f : prog As B r) :
        f = prog_lam (fun a => prog_app f a).
Proof.
elim: As B r f=>[|A As IH] B r f //=.
by apply: fext=>x; rewrite {1}(IH B (r x) (f x)).
Qed. 

Lemma prog_lam_mono As B (r : pre As) 
                    (p1 p2 : forall a, prog0 B (fun_app r a)) :  
        (forall a, p1 a <== p2 a) -> prog_lam p1 <== prog_lam p2.
Proof.
elim: As r p1 p2=>[|A As IH] r p1 p2 /=; first by apply.
by move=>H a; apply: IH=>as'; apply: (H (a, as')).
Qed.

Lemma prog_app_mono As B (r : pre As) a : 
       monotone (fun p : prog As B r => prog_app p a).
Proof.
elim: As r a=>[|A As IH] r a p1 p2 //.
by move=>H; apply: IH; apply: H.
Qed.

Definition prog_app_chain As B (r : pre As) (u : chain (prog As B r)) a := 
  [_ ^^ u by @prog_app_mono As B r a].

Lemma prog_app_limE As B (r : pre As) (u : chain (prog As B r)) a : 
        prog_app (lim u) a = lim (prog_app_chain u a).
Proof.
elim: As r u a=>[|A As IH] /= r u.
- by case; rewrite /prog_app_chain id_chainE.
case=>a a' /=; rewrite (lim_dappE u a) IH; apply: limE.
move=>x; split; first by case=>p [->][y][->]; exists y.
by case=>p [->]; exists (p a); split=>//; exists p.
Qed.

(* Now we go back to building the model of computations. *)
(* First a few definitions and properties *)

Section BasicDefs0.
Variables (B : Type) (p : Pred heap). 

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) := Ideal (singleP pf).

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

End BasicDefs0.

(* Basic definitions *)

Definition coherent As B (p : pre As) (e : prog As B p) := 
  forall a r x m, 
    m \In prog_app e a r x <-> 
    exists i, exists pf : i \In id_val r, 
      m \In prog_app e a (single (bound pf)) x.

Definition def_strict As B (p : pre As) (e : prog As B p) := 
  forall a r x, Undef \Notin prog_app e a r x.


Definition runs As B (p : pre As) (e : prog As B p) a : Pred _:=
  (fun r => exists pf : r.1.1 \In defed (fun_app p a), 
              r.2 \In prog_app e a (single pf) r.1.2).

Prenex Implicits runs.

Notation runs0 e := (runs e tt).

Lemma runs_bot As B p a : runs (bot : prog As B p) a =p Pred0.
Proof. 
elim: As p a=>[|A As IH] /= p a; last by apply: IH.
by move=>r; split=>//; case.
Qed.

Lemma runs_mono As B p a : monotone (fun e : prog As B p => runs e a).
Proof. by move=>e1 e2 H r [H1 T1]; exists H1; apply: prog_app_mono T1. Qed.

Definition has_spec As B (s : spec As B) := 
  [Pred p : prog As B s.1 | 
     forall a i y m,
       (i.1, y.1, m.1) \In runs p (dfst a) -> 
       (i.2, y.2, m.2) \In runs p (dsnd a) -> 
     dfun_app s.2 a i y m]. 

(********************)
(* STsec Definition *)
(********************)

Section STsecDef.
Variables (As : seq Type) (B : Type) (s : spec As B).

Structure STsec := STprog {
  model : prog As B s.1;
  _ : coherent model; 
  _ : def_strict model; 
  _ : model \In has_spec s}.

End STsecDef.

Prenex Implicits model STsec STprog.

(* projections out of the model *)
(* eventually, we should hide the model, prog and runs definition *)
(* and just use the following lemmas for reasoning about *)
(* the elements of the model *)

Section BasicOps.
Variables (As : seq Type) (B : Type) (s : spec As B).

Lemma modelE (e1 e2 : STsec s) : e1 = e2 <-> model e1 = model e2.
Proof.
move: e1 e2=>[p1 M1 D1 S1][p2 M2 D2 S2]; split; case=>//= E.
rewrite E in D1 D2 M1 M2 S1 S2 *. 
by congr STprog; apply: proof_irrelevance.
Qed.

Lemma model_runs (e : STsec s) a p x m : 
        m \In prog_app (model e) a p x <-> 
        exists i, i \In id_val p /\ 
                  (i, x, m) \In runs (model e) a.
Proof.
case: e=>mod M D S; rewrite (M a); 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 : STsec s) a i x m : 
        (i, x, m) \In runs (model e) a -> 
        [/\ def i, i \In fun_app s.1 a & def m].
Proof.
case: e=>mod M D S [[/= D1 H1]] H2; split=>//.
by case: m H2=>//; move/(D a).
Qed.

Lemma spec_runs (e : STsec s) a1 a2 y1 y2 i1 i2 m1 m2 :
        (i1, y1, m1) \In runs (model e) a1 ->
        (i2, y2, m2) \In runs (model e) a2 -> 
        dfun_app s.2 (dpair a1 a2) (i1, i2) (y1, y2) (m1, m2).
Proof.
case: e=>p M D S.
move: (S (dpair a1 a2) (i1, i2) (y1, y2) (m1, m2)).
by rewrite dargs_beta1 dargs_beta2.
Qed.

End BasicOps.

Prenex Implicits def_runs spec_runs.

(* application of a command to a single argument *)
(* used for building various chains of partial instantiations *)

Section Apply.
Variables (A : Type) (As : seq Type) (B : Type) (s : spec (A ::: As) B).
Variables (e : STsec s) (a : A).

Local Notation apply_s := (s.1 a, s.2 (a, a)).
Local Notation apply_prog := (model e a : prog As B apply_s.1).

Lemma apply_coherent : coherent apply_prog. 
Proof. by case: e=>mod M S D b; apply: (M (a, b)). Qed.

Lemma apply_dstrict : def_strict (model e a). 
Proof. by case: e=>mod M D S b; apply: (D (a, b)). Qed.

Lemma apply_has_spec : model e a \In has_spec apply_s. 
Proof. by case: e=>mod M D S b1 b2; apply: (S ((a, a), b1)). Qed.

Definition apply := STprog apply_coherent apply_dstrict apply_has_spec.

End Apply.

Prenex Implicits apply.

(****************************)
(* poset structure on STsec *)
(****************************)

Section STsecPoset.
Variables (As : seq Type) (B : Type) (s : spec As B).

Definition st_leq (e1 e2 : STsec s) := model e1 <== model e2.

Lemma st_refl e : st_leq e e.
Proof. by rewrite /st_leq. Qed.

Lemma st_asym e1 e2 : st_leq e1 e2 -> st_leq e2 e1 -> e1 = e2.
Proof.
move: e1 e2=>[p1 M1 D1 S1][p2 M2 D2 S2]; rewrite /st_leq /= => E1 E2.
rewrite (poset_asym E1 E2) in M1 M2 D1 D2 S1 S2 *; congr STprog;
by apply: proof_irrelevance.
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 M1 D1 S1][p2 M2 D2 S2][p3 M3 D3 S3].
by apply: poset_trans.
Qed.

Definition st_bot' : prog As B s.1 := bot.

Lemma st_bot_coherent : coherent st_bot'.
Proof. 
rewrite /st_bot'; elim: As s=>[|A As' IH] s'.
- by move=>/= a p x m; split=>//; case=>i [pf].
by move=>/= [a as']; apply: (IH (s'.1 a, s'.2 (a, a))). 
Qed.

Lemma st_bot_dstrict : def_strict st_bot'.
Proof.
rewrite /st_bot'; elim: As s=>[|A As' IH] s'.
- by move=>a p x [].
by move=>/= [a as']; apply: (IH (s'.1 a, s'.2 (a, a))).
Qed.

(* common lemma that will be used both for bot and sup *)

Lemma has_spec_clos : chain_closed (has_spec s).
Proof.
suff L: forall As B (p1 p2 : pre As) (q : post As B), 
  chain_closed [Pred c : prog As B p1 * prog As B p2 | 
           forall a i y m, 
             (i.1, y.1, m.1) \In runs c.1 (dfst a) ->
             (i.2, y.2, m.2) \In runs c.2 (dsnd a) ->  
             dfun_app q a i y m].
- by apply: chain_clos_diag (L _ _ s.1 s.1 s.2).
elim=>[|A As' IH] /= B' p1 p2 q.
- split; first by move=>[][][] i y m; move/runs_bot.
  move=>[d [H1 H2]] H [][][] i y m /=.
  case=>[/= D1][_][[_]][->][_][->][_][->][[c1 d1]][->] L1 /= T1.
  case=>[/= D2][_][[_]][->][_][->][_][->][[c2 d2]][->] L2 /= T2.
  case: (H2 _ _ L1 L2); case=>/= R1 R2;
  [move/H: L2 | move/H: L1]; move/(_ (tt, tt) i y m); 
  (apply; [exists D1 | exists D2])=>//=;
  by [apply: R1 T1 | apply: R2 T2].
split; first by move=>a i y m; move/runs_bot.
set cpo := pairCPO _ _; move=>d H1 [[a1 a2]] b. 
set map := fun e : cpo => (e.1 a1, e.2 a2).
have mono_map : monotone map.
- by case=>/= e1 e2 [/= f1 f2][/= L1 L2]; split; [apply: L1 | apply: L2].
set d' := [map ^^ d by mono_map].
have E : lim d' = ((lim d).1 a1, (lim d).2 a2).
- congr (_, _); rewrite /= lim_dappE /d' /proj1_chain /proj2_chain;
  by rewrite /dapp_chain !comp_chainE !/comp; apply: limE.
case: (IH B' (p1 a1) (p2 a2) (q (a1, a2)))=>_.
move/(_ d'); rewrite E; apply.
case=>f1 f2 [[g1 g2]][[->->]] L bs.
by apply: (H1 (g1, g2) L ((a1, a2), bs)).
Qed.

Lemma st_bot_has_spec : st_bot' \In has_spec s.
Proof. by case: has_spec_clos. Qed.

Definition st_bot := STprog st_bot_coherent st_bot_dstrict st_bot_has_spec.

Lemma st_botP e : st_leq st_bot e.
Proof. by apply: botP. Qed.

Definition stPosetMixin := PosetMixin st_botP st_refl st_asym st_trans.
Canonical stPoset := Eval hnf in Poset (STsec s) stPosetMixin.

End STsecPoset.

(* now that we have a poset, we can state *)
(* monotonicity of various operations. *)

Lemma model_def As B (s : spec As B) (e1 e2 : STsec s) :
        model e1 <== model e2 -> e1 <== e2.
Proof. by []. Qed.

Lemma model_mono As B (s : spec As B) : 
        monotone (fun e : STsec s => model e). 
Proof. by []. Qed.

Lemma apply_mono A As B a (s : spec (A ::: As) B) : 
        monotone (fun e : STsec s => apply e a). 
Proof. by move=>e1 e2; apply. Qed.

Implicit Arguments model_mono [As B].
Implicit Arguments apply_mono [A As B a].
Prenex Implicits model_mono apply_mono.

(**************************)
(* cpo structure on STsec *)
(**************************)

Section STsecCPO.

Notation st_lim' u := (lim [model ^^ u by model_mono _]).

Lemma st_lim_coherent As B (s : spec As B)
                      (u : chain [poset of STsec s]) : 
        coherent (st_lim' u).
Proof.
elim: As s u=>[|A As IH] s u; last first. 
- move=>/= [a b]; move: (IH _ [apply^~ a ^^ u by apply_mono s] b). 
  by rewrite !prog_app_limE /prog_app_chain /dapp_chain !comp_chainE.
move=>/= _ p x m; rewrite !lim_appE /app_chain /=.
split.
- case=>_ [[_]][->][_][->][_][->][[/= r M D S]] [->] P. 
  case/(M tt)=>i [pf] H3; exists i; exists pf.
  exists (r (single (bound pf)) x m); split=>//.
  by do 3![eexists _; split=>//]; exists (STprog M D S).
case=>i [pf][_][[_]][->][_][->][_][->][[/= r]] M D S [->] P E.
have: exists i, exists pf : i \In id_val p, m \In r (single (bound pf)) x.
- by exists i; exists pf.
move/(M tt)=>H3; exists (r p x m); split=>//.
by do 3![eexists _; split=>//]; exists (STprog M D S).
Qed.

Variables (As : seq Type) (B : Type) (s : spec As B).

Lemma st_lim_dstrict (u : chain [poset of STsec s]) : def_strict (st_lim' u).
Proof.
move=>a p x; rewrite prog_app_limE.
by case=>_ [[_]][->][_][->][_][->][_][->][[/= r M D S]][->] P; case/D.
Qed.

Lemma st_lim_has_spec u : st_lim' u \In has_spec s.
Proof. by case: (has_spec_clos s)=>_; apply=>p [[mod M D S]][->]. Qed.

Definition st_lim u := 
  STprog (st_lim_coherent u) (@st_lim_dstrict u) (@st_lim_has_spec u).

Lemma st_limP u x : x \In u -> x <== st_lim u.
Proof. by case: x=>p M D S H; apply: limP; exists (STprog M D S). Qed.

Lemma st_limM u x : (forall y, y \In u -> y <== x) -> st_lim u <== x.
Proof. by case: x=>p M D S H; apply: limM=>q [y][->]; move/H. Qed.

Definition stCPOMixin := CPOMixin st_limP st_limM.
Canonical stCPO := Eval hnf in CPO (STsec s) stCPOMixin.

End STsecCPO.

(* now that we have a cpo, we can prove *)
(* some helper lemmas about lims and model *)

Section LimRuns.
Variables (As1 As2 : seq Type) (B1 B2 : Type).
Variables (s1 : spec As1 B1) (s2 : spec As2 B2).
Variables (f : STsec s1 -> STsec s2) (M : monotone f).

Lemma lim_runsP (e : STsec s2) d : 
         e \In d -> runs (model e) <== runs (model (lim d)).
Proof. by move=>H a; apply: runs_mono; apply: limP; exists e. Qed.

Lemma lim_runsM (p : pre As2) (F : STsec s1 -> prog As2 B2 p) 
                (N : monotone F) a (r : ideald (fun_app p a)) 
                (d : chain (stCPO s1)) y i m :
         (forall e, e \In d -> 
                    (i, y, m) \In runs (model (f e)) a ->
                    prog_app (F e) a r y m) ->
         (i, y, m) \In runs (model (lim [f ^^ d by M])) a ->
         prog_app (lim [F ^^ d by N]) a r y m.
Proof.
move=>H1 [/= D]; rewrite -toPredE !prog_app_limE /= !lim_appE.
rewrite /app_chain /prog_app_chain !comp_chainE !/comp /=.
set j1 := [_ ^^ _ by _]; set j2 := [_ ^^ _ by _].
apply: (@limM _ j1 (lim j2))=>_ [e][->] H2.
case/model_runs=>_ [[<-]]; move/(H1 _ H2)=>H3.
by exists (prog_app (F e) a r y m); split=>//; exists e.
Qed.

End LimRuns.

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

(* recursion *)

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

Definition ffix : STsec s := kleene_lfp C.

End FFix.

(* simultaneous application of a command to arguments *)

Section Instantiation.
Variables (As Bs : seq Type) (B : Type) (s : spec As B).
Variables (e : STsec s) (f : funtp Bs (args As)).

Definition inst_s : spec Bs B := 
  (fun_lam (fun b => fun_app s.1 (fun_app f b)), 
   dfun_lam (fun b => dfun_app s.2 (dpair (fun_app f (dfst b)) 
                                          (fun_app f (dsnd b))))).

Definition inst_prog : prog Bs B inst_s.1 := 
  prog_lam (fun b p y m => 
    exists i, i \In id_val p /\ (i, y, m) \In runs (model e) (fun_app f b)).

Lemma inst_coherent : coherent inst_prog.
Proof.
move=>a; rewrite prog_beta=>p x m; split.
- by case=>i [/= H]; exists i; exists H; exists i.
by case=>i [H][_][[<-]]; exists i.
Qed.

Lemma inst_dstrict : def_strict inst_prog.
Proof. by move=>a; rewrite prog_beta=>p x [i][pf]; case/def_runs. Qed.

Lemma inst_has_spec : inst_prog \In has_spec inst_s. 
Proof.
move=>b [i1 i2][y1 y2][m1 m2] /=.
rewrite /runs !prog_beta !fun_beta !dfun_beta.
move=>[/= D1][_][[<-]] H1 [/= D2][_][[<-]] H2.
by apply: spec_runs H1 H2.
Qed.

Definition inst_unlocked := STprog inst_coherent inst_dstrict inst_has_spec.

Definition inst := locked inst_unlocked.

Lemma instlock : inst_unlocked = inst.
Proof. by rewrite /inst -lock. Qed.

End Instantiation.

Prenex Implicits inst_prog.
Prenex Implicits inst.

Definition inst0 As B (s : spec As B) (e : STsec s)
                 (a : args As) := inst (Bs := [::]) e a.
Definition inst1 As A B (s : spec As B) (e : STsec s) 
                 (a : A -> args As) := inst (Bs := [::: A]) e a.
Definition inst2 As A1 A2 B (s : spec As B) (e : STsec s)
                 (a : A1 -> A2 -> args As) := inst (Bs := [::: A1; A2]) e a.

Notation "[ x1 , .. , xn ] " := (pair x1 .. (pair xn tt) ..)
  (at level 0) : iflow_scope.
Notation "e @ f" := (inst e f) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @0 f " := (inst0 e f) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @1 f " := (inst1 e f) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @2 f " := (inst2 e f) 
  (at level 50, left associativity) : iflow_scope.

(* some equations on inst *)

Lemma inst_runs As B (s : spec As B) (e : STsec s) (a : args As) : 
        runs0 (model (e @0 a)) <~> runs (model e) a.
Proof.
case=>[[i x] m] /=; split; rewrite /inst0 -instlock /=.
- by case=>/= [[H1 H2]][_][[<-]].
by move=>H; case/def_runs: (H)=>D1 H1 _; exists (conj H1 D1); exists i.
Qed.

Lemma inst_assoc As Bs B (s : spec Bs B) (e : STsec s)
                 (f : funtp As (args Bs)) (a : args As) : 
        runs (model (e @ f)) a <~> runs (model e) (fun_app f a).
Proof.
case=>[[i x] m] /=; split; rewrite -instlock /=.
- case=>[/= S]; rewrite prog_beta; case=>_ [[<-]] H.
  by rewrite fun_beta in S; exists S; apply/model_runs; exists i.
move=>H; case/def_runs: (H)=>D S _; rewrite /runs /=.
set d := defed _; have E : i \In d by rewrite fun_beta in d *.
by exists E; rewrite prog_beta; exists i.
Qed.

(* monotonicity of inst *)
Lemma inst_mono As Bs B (s : spec As B) (f : funtp Bs (args As)) : 
        monotone (fun e : STsec s => e @ f).
Proof.
move=>e1 e2 H; rewrite /inst1 -!instlock; apply: prog_lam_mono=>a p x m. 
by case=>i [P] L; exists i; split=>//; apply: runs_mono L.
Qed.

Implicit Arguments inst_mono [As Bs B s f].
Prenex Implicits inst_mono.

Lemma inst_cont As Bs B (s : spec As B) (f : funtp Bs (args As)) : 
        continuous (fun e : STsec s => e @ f).
Proof.
exists inst_mono=>d; apply: poset_asym; last first.
- apply: limM=>y [e][->] H; rewrite -!instlock.
  apply: prog_lam_mono=>b p z m.
  case=>i [H3] H4; exists i; split=>//.
  by apply: lim_runsP H4.
apply: model_def; rewrite /= comp_chainE /comp /=.
rewrite [lim [_ ^^ _ by _]]prog_eta -instlock /=.
apply: prog_lam_mono=>b [p H] y m [i][/= H1][[/= S D]]. 
rewrite !prog_app_limE -toPredE /= !lim_appE.
rewrite /app_chain /prog_app_chain !comp_chainE !/comp /=.
set j1 := [_ ^^ _ by _]; set j2 := [_ ^^ _ by _].
apply: (@limM _ j1 (lim j2))=>_ [z][->] H2; case/model_runs=>_ [[<-]] H3.
eexists _; split=>//; first by exists z; split.
by rewrite -instlock prog_beta; exists i.
Qed.

Implicit Arguments inst_cont [As Bs B s f].
Prenex Implicits inst_cont. 

(* rule of assignment / monadic unit *)

Section Return.
Variable A : Type. 

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

Definition ret_prog : prog [::: A] A ret_s.1 := 
  fun x p y m => m \In id_val p /\ y = x.

Lemma ret_coherent : coherent ret_prog. 
Proof.
case=>a [] /= p y m; split; first by case=>H ->{y}; exists m; exists H.
by case=>i [H1][[<-{m}]] ->{y}.
Qed.

Lemma ret_dstrict : def_strict ret_prog.
Proof. by case=>a [][p H] y /= []; case/H. Qed.

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 := STprog ret_coherent ret_dstrict ret_has_spec.

End Return.

(* rule of sequential composition / monadic bind *)

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

Definition bind_pre : pre As :=
  fun_lam (fun a i => i \In (fun_app s1.1 a) /\ 
    forall y m, dfun_app s1.2 (dpair a a) (i, i) (y, y) (m, m) -> def m -> 
                m \In (fun_app s2.1 (y, a))).
Definition bind_post : post As B := 
  dfun_lam (fun a i y m => exists x, exists h, 
              dfun_app s1.2 a i x h /\ def h.1 /\ def h.2 /\
              dfun_app s2.2 (x, a) h y m).
Definition bind_s := (bind_pre, bind_post).

Definition bind_prog : prog As B bind_s.1 := 
  prog_lam (fun a p y m =>
    exists i, exists x, exists h, i \In id_val p /\
      (i, x, h) \In runs (model e1) a /\ 
      (h, y, m) \In runs (model e2) (x, a)).

Lemma bind_coherent : coherent bind_prog.
Proof.
move=>b p y m; split; rewrite prog_beta.
- case=>i [x][h][/= H1][H2] H3.
  by exists i; exists H1; exists i; exists x; exists h.
case=>i [/= H1][_][x][h][[<-]][H2 H3]. 
by exists i; exists x; exists h.
Qed.

Lemma bind_dstrict : def_strict bind_prog.
Proof. 
by move=>b p y; rewrite prog_beta; case=>i [x][h][H1][H2]; case/def_runs. 
Qed.

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

Definition bind_unlocked := STprog bind_coherent bind_dstrict bind_has_spec.

Definition bind := locked bind_unlocked.

Lemma bindlock : bind_unlocked = bind.
Proof. by rewrite /bind -lock. Qed.

End Bind.

Lemma bindS A B (s1 : spec [:::] A) (s2 : spec [::: A] B) 
            (e1 : STsec s1) (e2 : STsec s2) y i m : 
       (i, y, m) \In runs0 (model (bind e1 e2)) -> 
       exists x, exists h, 
         (i, x, h) \In runs0 (model e1) /\ 
         (h, y, m) \In runs (model e2) [x].
Proof. 
rewrite -bindlock.
by case=>/= D [_][x][h][[<-]][H1] H2; exists x; exists h.
Qed.

Lemma bindC A B (s1 : spec [:::] A) (s2 : spec [::: A] B) 
            (e1 : STsec s1) (e2 : STsec s2) y i m x h : 
        i \In bind_pre s1 s2 -> 
        (i, x, h) \In runs0 (model e1) -> 
        (h, y, m) \In runs (model e2) [x] -> 
        (i, y, m) \In runs0 (model (bind e1 e2)).
Proof.
move=>H1 H2 H3; case: (def_runs H2)=>D _ _; rewrite -bindlock.
by exists (conj H1 D); exists i; exists x; exists h.
Qed.

Lemma bindR As A B (s1 : spec As A) (s2 : spec [::: A & As] B)
            (e1 : STsec s1) (e2 : STsec s2) a : 
        runs (model (bind e1 e2)) a <~>
        runs0 (model (bind (e1 @0 a) (e2 @1 (fun x => (x, a))))).
Proof.
move=>[[i y] m]; split=>/=. 
- case/(inst_runs (bind _ _))=>/= H0.
  rewrite {1}/inst0 -{1}instlock /=.
  case=>_ [[<-]][[/= H D]] {H0}.
  rewrite -{1}bindlock /bind_prog /= prog_beta.
  case=>_ [x][h][[<-]][H1 H2].
  rewrite /runs /=; set j := defed _; have E : i \In j.
  - by split=>//; rewrite /bind_pre fun_beta in H *.
  exists E; rewrite -bindlock; exists i; exists x; exists h.
  by rewrite inst_runs inst_assoc.
case=>[[/= H D]]; rewrite -bindlock.
case=>_ [x][h][[<-]][]; move/inst_runs=>/= H1.
(* yikes, why can't the following lines infer arguments? *)
(* what's going on? *)
move/(@inst_assoc [::: A] (A:::As) _ _ _ (fun x => (x, a)))=>/= H2.
apply/(inst_runs (bind _ _)); rewrite /runs /=.
set j := defed _; have E : i \In j by split=>//; rewrite fun_beta.
exists E; rewrite /inst0 -instlock; exists i; split=>//=.
exists E; rewrite -bindlock prog_beta /=.
by exists i; exists x; exists h.
Qed.

Lemma bind_mono As A B (s1 : spec As A) (s2 : spec (A ::: As) B) :
        monotone (fun e : STsec s1 * STsec s2 => bind e.1 e.2).
Proof.
move=>e1 e2 [/= H1 H2]; rewrite -!bindlock; apply: prog_lam_mono.
move=>a p y m [i][x][h][T1][T2] T3.
exists i; exists x; exists h; split=>//.
by split; [apply: runs_mono T2 | apply: runs_mono T3].
Qed.

Implicit Arguments bind_mono [As A B s1 s2].
Prenex Implicits bind_mono.

Lemma bind_cont As A B (s1 : spec As A) (s2 : spec (A ::: As) B) :
        continuous (fun e : STsec s1 * STsec s2 => bind e.1 e.2).
Proof.
exists bind_mono=>d; apply: poset_asym; last first.
- apply: limM=>y [e][->] H; rewrite -!bindlock /=.
  apply: prog_lam_mono=>a [/= p H1] z m; rewrite fun_beta in H1.
  case=>i [x][h][H2][H3] H4; exists i; exists x; exists h; split=>//.
  by split; [apply: lim_runsP H3 | apply: lim_runsP H4]; exists e.
apply: model_def; rewrite /= comp_chainE /comp /=.
rewrite [lim [_ ^^ _ by _]]prog_eta -bindlock.
apply: prog_lam_mono=>b [p H] y m [i][x][h][/= H1][[[/= S1 D1]]] T1.
case=>[[/= S2 D2]]; move: T1.
rewrite !prog_app_limE -toPredE /= !lim_appE.
rewrite /app_chain /prog_app_chain !comp_chainE !/comp /=. 
set j1 := [_ ^^ _ by _]; set j2 := [_ ^^ _ by _]; set j3 := [_ ^^ _ by _].
move=>H2 H3; apply: (@limM _ j1 (lim j3))=>// z [e1][->] H4.
case/model_runs=>_ [[<-]] H5.
case: H3=>_ [[_]][->] [e2][->] H6 {j1 D1 S1 H2 j2}.
case/(@model_runs (A::As) B s2 e2.2 (x, b))=>_ [[<-]] H7 {D2 S2}.
have : e1 <== e2 \/ e2 <== e1 by case: d H4 H6 {j3}=>q [L]; apply.
case=>L.
- exists (prog_app (model (bind e2.1 e2.2)) b {| id_val := p; id_pf := H |} y m).
  split; first by exists e2.
  rewrite -bindlock prog_beta /=.
  exists i; exists x; exists h; do 2![split=>//].
  by apply: runs_mono H5; case: L.
exists (prog_app (model (bind e1.1 e1.2)) b {| id_val := p; id_pf := H |} y m).
split; first by exists e1.
rewrite -bindlock prog_beta /=.
exists i; exists x; exists h; do 2![split=>//]. 
by apply: runs_mono H7; case: L.
Qed.

(*
(* definition for a Hoare fourtuple / subsumption rule *)

Definition conseq As B (s1 : spec As B) (e : STsec 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 (model e) a1 ->
       (i.2, y.2, m.2) \In runs (model 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 : STsec s1) (pf : conseq e s2). 

Definition do_prog : prog As B s2.1 := 
  prog_lam (fun b p y m => 
    exists i, i \In id_val p /\ (i, y, m) \In runs (model e) b).

Lemma do_coherent : coherent do_prog. 
Proof.
move=>b p y m; split; rewrite prog_beta.
- by case=>i [/= H1 T1]; exists i; exists H1; exists i.
by case=>i [/= H1][_][[<-]] T1; exists i.
Qed.

Lemma do_dstrict : def_strict do_prog.
Proof. by move=>b p y; rewrite prog_beta; case=>h [/= H]; case/def_runs. Qed.

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

Definition Do := STprog do_coherent do_dstrict do_has_spec.

End Consequence.

Implicit Arguments Do [As B s1 s2].

Lemma do_mono As B (s1 s2 : spec As B) 
              (pf : forall e : STsec s1, conseq e s2) : 
        monotone (fun e : STsec s1 => Do e (pf e)).
Proof.
move=>e1 e2 H; apply: prog_lam_mono=>a p y m.
by case=>i [H1] H2; exists i; split=>//; apply: runs_mono H2.
Qed.

Implicit Arguments do_mono [As B s1 s2 pf].
Prenex Implicits do_mono.

Lemma do_cont As B (s1 s2 : spec As B) 
              (pf : forall e : STsec s1, conseq e s2) :
        continuous (fun e : STsec s1 => Do e (pf e)).
Proof.
exists do_mono=>d; apply: poset_asym; last first.
- apply: limM=>y [e][->] H1. 
  apply: prog_lam_mono=>a [p H] z m [i][H2] H3; exists i; split=>//.
  rewrite /runs /=; set j := defed _; have E : i \In j.
  - by case/H: H2=>S D; split=>//; case: (pf e)=>L _; apply: L S D.
  exists E; rewrite -toPredE /= prog_app_limE !lim_appE /=.
  rewrite /app_chain /prog_app_chain !comp_chainE !/comp.
  exists (prog_app (model e) a (single E) z m).
  by split; [exists e | apply/model_runs; exists i].
apply: model_def; rewrite /= comp_chainE /comp /=.
rewrite [lim [_ ^^ _ by _]]prog_eta.
apply: prog_lam_mono=>b [p H] y m [i][/= H1][/= D1].
rewrite !prog_app_limE -toPredE /= !lim_appE.
rewrite /app_chain /prog_app_chain !comp_chainE !/comp /=.
set j1 := [_ ^^ _ by _]. set j2 := [_ ^^ _ by _].
apply: (@limM _ j1 (lim j2))=>_ [z][->] H2; case/model_runs=>_ [[<-]] H3.
eexists _; split=>//; first by exists z; split.
by rewrite prog_beta; exists i.
Qed.
 
*)

(***********************)
(* the non-structurals *)
(***********************)

(* read *)

Section Read.
Variable A : Type.

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

Definition read_prog : prog [::: ptr] A read_s.1 := 
  fun x p v m => m \In id_val p /\ look x m = dyn v.

Lemma read_coherent : coherent read_prog. 
Proof.
move=>b p x m; split; last by case=>i [H1][[<-]].
by case=>H1 [H2]; exists m; exists H1.
Qed.

Lemma read_dstrict : def_strict read_prog. 
Proof. by move=>b [p H] y []; case/H. Qed.

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 := STprog read_coherent read_dstrict read_has_spec. 

End Read.

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

Definition write_s : spec [::: ptr; A] unit := 
  (fun x v i => exists h, exists B, exists ww : B, i = x :-> ww :+ h,
   fun x v i y m => 
     forall h B1 B2 (ww1 : B1) (ww2 : B2), 
       i = (x.1 :-> ww1 :+ h.1, x.2 :-> ww2 :+ h.2) -> 
       m = (x.1 :-> v.1 :+ h.1, x.2 :-> v.2 :+ h.2)).

Definition write_prog : prog [::: ptr; A] unit write_s.1 := 
  fun x v p y m => exists i, 
    i \In id_val p /\ x \in dom i /\ m = upd i x (dyn v).

Lemma write_coherent : coherent write_prog. 
Proof.
move=>xv 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 : def_strict write_prog. 
Proof.
case=>x [v][][p H] y [i][_][H1].
suff L: def (upd i x (dyn v)) by move=>H2; rewrite -H2 in L.
by rewrite defU (dom_null H1) (dom_def H1).
Qed.

Lemma write_has_spec : write_prog \In has_spec write_s.
Proof.
move=>[[l1 l2]][[v1 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 := STprog write_coherent write_dstrict write_has_spec. 

End Write.

(* low allocation *)

Section LowAllocation.
Variable A : Type.

Definition lalloc_s : spec [::: A] ptr := 
  (fun v i => True,
   fun v i y 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_prog : prog [::: A] ptr lalloc_s.1 :=
  fun v p y m => exists i, 
    i \In id_val p /\ y = lfresh i /\ m = y :-> v :+ i.

Lemma lalloc_coherent : coherent lalloc_prog. 
Proof.
move=>v p x m; split; case=>i [H1].
- by case=>-> ->; exists i; exists H1; exists i.
by case=>_ [[<-]][->] ->; exists i.
Qed.

Lemma lalloc_dstrict : def_strict lalloc_prog. 
Proof.
case=>v [][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.

Lemma lalloc_has_spec : lalloc_prog \In has_spec lalloc_s.
Proof.
move=>[[v1 v2]][[][]][i1 i2][y1 y2][m1 m2] /=. 
case=>[[/= _ D1]][_][[<-]][->] ->.
case=>[[/= _ D2]][_][[<-]][->] ->.
split=>// H; rewrite (loweqE H); split=>//.
have [E1 E2] : def (lfresh i1 :-> v1 :+ i1) /\ def (lfresh i2 :-> v2 :+ i2).
- rewrite !defPtUn D1 D2 !lfresh_null /=. 
  by rewrite -[lfresh i1]ptr0 -[lfresh i2]ptr0 !(dom_lfresh _ 0).
by rewrite lowPtUn // -(loweqE H).
Qed.

Definition lalloc := STprog lalloc_coherent lalloc_dstrict lalloc_has_spec.

End LowAllocation. 

(* high allocation *)

Section HighAllocation.
Variable A : Type.

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

Definition halloc_prog : prog [::: A] ptr halloc_s.1 :=
  fun v p y m => exists i, 
    i \In id_val p /\ m = y :-> v :+ i /\ high y /\
    y != null /\ y \notin dom i.

Lemma halloc_coherent : coherent halloc_prog.
Proof.
move=>v 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 : def_strict halloc_prog.
Proof.
case=>v [][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. 

Lemma halloc_has_spec : halloc_prog \In has_spec halloc_s.
Proof.
move=>[[v1 v2]][[][]][i1 i2][y1 y2][m1 m2] /=.
by case=>[[/= _ D1]][_][[<-]][->][H1][N1 Y1]
         [[/= _ D2]][_][[<-]][->][H2][N2 Y2].
Qed.

Definition halloc := STprog halloc_coherent halloc_dstrict halloc_has_spec.

End HighAllocation. 

(* deallocation *)

Section Deallocation. 

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

Definition dealloc_prog : prog [::: ptr] unit dealloc_s.1 :=
  fun x p y m => exists i, i \In id_val p /\ x \in dom i /\ m = free x i.

Lemma dealloc_coherent : coherent dealloc_prog.
Proof.
move=>x 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 : def_strict dealloc_prog.
Proof.
case=>x [][p H] y [h][/=]; case/H=>_ H1 [H2] H3.
suff: def (free x h) by rewrite -H3.
by rewrite defF.
Qed. 

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 := 
  STprog dealloc_coherent dealloc_dstrict dealloc_has_spec.

End Deallocation.

(* we need a combinator for lifting functions of type *)
(* A -> STsec As B s into STsec [:: A & As] B s' *)
(* this is needed so that such ordinary functions can be applied *)
(* to arguments which are propagated in the local context *)

(* this combinator makes the function argument low by default *)
(* as commented in Remark 2 of the paper, in a somewhat simplified fashion *)

Section Localize.
Variables (As : seq Type) (A B : Type) (s : A -> spec As B).
Variables (f : forall x, STsec (s x)). 

Definition localize_s : spec [::: A & As] B := 
  (fun_lam (fun a : args [::: A & As] => fun_app (s a.1).1 a.2),
   dfun_lam (fun (a : dargs [::: A & As]) i y m => 
              a.1.1 = a.1.2 -> dfun_app (s a.1.1).2 a.2 i y m)).

Definition localize_prog : prog [::: A & As] B localize_s.1 := 
  prog_lam (fun (a : args [::: A & As]) p y m => 
    exists i, i \In id_val p /\ (i, y, m) \In runs (model (f a.1)) a.2).

Lemma localize_coherent : coherent localize_prog. 
Proof.
move=>a q x m; split; rewrite prog_beta; case=>i [/= H1]. 
- by exists i; exists H1; exists i.
by case=>_ [[<-]] L; exists i.
Qed.

Lemma localize_dstrict : def_strict localize_prog. 
Proof. by move=>a q y; rewrite prog_beta; case=>i [/= H]; case/def_runs. Qed.

Lemma localize_has_spec : localize_prog \In has_spec localize_s.
Proof.
move=>/= [[a1 a2]] b [i1 i2][y1 y2][m1 m2] /=. 
rewrite /Model.runs !prog_beta !fun_beta !dfun_beta.
case=>[[/= S1 D1]][_][[<-]] E1 [[/= S2 D2]][_][[<-]] E2 E.
rewrite -{a2}E in E2 S2; rewrite (dargs_eta b).
by apply: spec_runs E1 E2.
Qed.

Definition localize := 
  STprog localize_coherent localize_dstrict localize_has_spec. 

End Localize.

(**************************)
(* The exported inferface *)
(**************************)

Module Exports.

Notation STsec := Model.STsec.

Prenex Implicits Model.STsec.

Structure ST As B := hide (s : spec As B) of STsec s.

Definition spec_of As B (e : ST As B) := let: hide s _ := e in s.
Definition pre_of As B := [fun e : ST As B => (spec_of e).1]. 
Definition post_of As B := [fun e : ST As B => (spec_of e).2]. 
Definition code_of As B (e : ST As B) := 
  let: hide _ c := e return STsec (spec_of e) in c.

Implicit Arguments pre_of [As B].
Implicit Arguments post_of [As B].
Prenex Implicits pre_of post_of.

Coercion hide : STsec >-> ST.

Definition runs As B (e : ST As B) := Model.runs (Model.model (code_of e)).

Notation runs0 e := (runs e tt).

Lemma def_runs As B (e : ST As B) a i x m : 
        (i, x, m) \In runs e a -> 
        [/\ def i, i \In fun_app (spec_of e).1 a & def m].
Proof. by apply: Model.def_runs. Qed.

Lemma spec_runs As B (e : ST As B) a1 a2 y1 y2 i1 i2 m1 m2 :
        (i1, y1, m1) \In runs e a1 ->
        (i2, y2, m2) \In runs e a2 -> 
        dfun_app (spec_of e).2 (dpair a1 a2) (i1, i2) (y1, y2) (m1, m2).
Proof. by apply: Model.spec_runs. Qed.

Prenex Implicits def_runs spec_runs. 

(* definition of continuity for "hiden" functions *)

Definition stcontinuous As1 As2 B1 B2 (s1 : spec As1 B1) 
                        (f : STsec s1 -> ST As2 B2) := 
  exists s2 : spec As2 B2, 
  exists f' : STsec s1 -> STsec s2, 
    continuous f' /\ forall x, f x = hide (f' x).

Section HideCont. 
Variables (As1 As2 : seq Type) (B1 B2 : Type).
Variables (s1 : spec As1 B1) (s2 : spec As2 B2).
Variables (f : STsec s1 -> STsec s2) (C : continuous f).

Lemma hide_stcont : stcontinuous (fun e => hide (f e)).
Proof. by exists s2; exists f. Qed.

End HideCont.

Implicit Arguments hide_stcont [As1 As2 B1 B2 s1 s2 f].
Prenex Implicits hide_stcont.

Lemma id_stcont As A (s : spec As A) : stcontinuous (fun e : STsec s => e). 
Proof. by apply: hide_stcont; apply: id_cont. Qed.

Hint Resolve id_stcont.

Section ConstCont.
Variables (As1 As2 : seq Type) (B1 B2 : Type) (s1 : spec As1 B1).

Lemma const_stcont (e : ST As2 B2) : stcontinuous (fun x : STsec s1 => e).
Proof. 
case: e=>s2 e; exists s2; exists (fun x => e).
by split=>//; exact: const_cont.
Qed.

End ConstCont. 

Implicit Arguments const_stcont [As1 As2 B1 B2 s1].
Prenex Implicits const_stcont.

(***************)
(* ST commands *)
(***************)

(* fix *)

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

Definition Fix' : STsec s := Model.ffix C.
End ExportFix.

Implicit Arguments Fix' [As B s].
Prenex Implicits Fix'.

Notation "'Fix' f" := (Fix' f _) (at level 80).

(* ret *)

Definition ret_s A : simpl_fun unit (spec [::: A] A) :=
  [fun : unit => (fun x i => True, fun x i y m => m = i /\ y = x)].

Definition ret A : ST [::: A] A := hide (s := ret_s A tt) (Model.ret A).

Implicit Arguments ret [A].
Prenex Implicits ret.

(* instantiation *)

Section InstDef.
Variables (As Bs : seq Type) (B : Type) (e : ST As B).
Variables (f : funtp Bs (args As)).

(* we make the specs self-simplifying *)

Definition inst_s : simpl_fun unit (spec Bs B) := 
  [fun : unit => 
    (fun_lam (fun b : args Bs => fun_app (spec_of e).1 (fun_app f b)),
     dfun_lam (fun b : dargs Bs => 
       dfun_app (spec_of e).2 (dpair (fun_app f (dfst b))
                                     (fun_app f (dsnd b)))))].

End InstDef.

Implicit Arguments inst_s [As Bs B].
Prenex Implicits inst_s.

(* bind *)

Definition bind_pre As A B (e1 : ST As A) : 
             simpl_fun (ST [::: A & As] B) (pre As) :=
  [fun e2 : ST [::: A & As] B => 
     fun_lam (fun a i => i \In (fun_app (spec_of e1).1 a) /\ 
        forall y m, dfun_app (spec_of e1).2 (dpair a a) (i, i) (y, y) (m, m) -> 
          def m -> m \In (fun_app (spec_of e2).1 (y, a)))].

Implicit Arguments bind_pre [As A B].
Prenex Implicits bind_pre.

Definition bind_post As A B (e1 : ST As A) : 
             simpl_fun (ST [::: A & As] B) (post As B) := 
  [fun e2 : ST [::: A & As] B =>
      dfun_lam (fun a i y m => exists x, exists h, 
        dfun_app (spec_of e1).2 a i x h /\ def h.1 /\ def h.2 /\
        dfun_app (spec_of e2).2 (x, a) h y m)].

Implicit Arguments bind_post [As A B].
Prenex Implicits bind_post.

Definition bind_s As A B (e1 : ST As A) :
             simpl_fun (ST [::: A & As] B) (spec As B) :=
  [fun e2 => (bind_pre e1 e2, bind_post e1 e2)].

Implicit Arguments bind_s [As A B].
Prenex Implicits bind_s.

Module Type SecInstBindSig.

(* first signature for inst *)

Parameter inst : 
  forall As Bs B, ST As B -> funtp Bs (args As) -> ST Bs B.

Notation "[ x1 , .. , xn ] " := (pair x1 .. (pair xn tt) ..)
  (at level 0) : iflow_scope.
Notation "e @ f" := (inst e f) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @0 f " := (inst e (f : funtp [:::] _))
  (at level 50, left associativity) : iflow_scope.
Notation "e @1 f " := (inst e (f : funtp [::: _] _)) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @2 f " := (inst e (f : funtp [::: _; _] _)) 
  (at level 50, left associativity) : iflow_scope.

Parameter instE : 
  forall As Bs B (e : ST As B) (f : funtp Bs (args As)), 
    spec_of (e @ f) = inst_s e f tt.

Parameter inst_runs : 
  forall As B (e : ST As B) a, runs0 (e @0 a) <~> runs e a.

Parameter inst_assoc :
  forall As Bs B (e : ST Bs B) (f : funtp As (args Bs)) (a : args As),
    runs (e @ f) a <~> runs e (fun_app f a).

Parameter inst_stcont : 
  forall As As1 As2 B B1 (s : spec As B)
   (f : STsec s -> ST As1 B1) (g : funtp As2 (args As1))
   (C : stcontinuous f), stcontinuous (fun e => f e @ g).

(* then for bind *)

Parameter bind : 
  forall As A B (e1 : ST As A) (e2 : ST [::: A & As] B), ST As B.

Notation "e1 ';;' e2" := (bind e1 e2)
  (at level 78, right associativity) : iflow_scope.

Parameter bindE : 
  forall As A B (e1 : ST As A) (e2 : ST [:: A & As] B), 
    spec_of (e1;; e2) = bind_s e1 e2.

Parameter bindS : forall A B (e1 : ST [:::] A) (e2 : ST [::: A] B) y i m, 
  (i, y, m) \In runs0 (e1;; e2) -> 
  exists x, exists h, 
    (i, x, h) \In runs0 e1 /\ (h, y, m) \In runs e2 [x].

Parameter bindC : forall A B (e1 : ST [:::] A) (e2 : ST [::: A] B) y i m x h,
  i \In bind_pre e1 e2 ->
  (i, x, h) \In runs0 e1 -> 
  (h, y, m) \In runs e2 [x] -> 
  (i, y, m) \In runs0 (e1;; e2). 

Parameter bindR : forall As A B (e1 : ST As A) (e2 : ST [::: A & As] B) 
                   (a : args As) , 
  runs (e1;; e2) a <~>
  runs0 (e1 @0 a;; e2 @1 (fun x => (x, a))). 

Parameter bind_stcont : forall As As1 B B1 B2 (s : spec As B)
  (f1 : STsec s -> ST As1 B1) (f2 : STsec s -> ST [::: B1 & As1] B2)
  (C1 : stcontinuous f1) (C2 : stcontinuous f2),
  stcontinuous (fun e => bind (f1 e) (f2 e)). 

End SecInstBindSig.

Module SecInstBind : SecInstBindSig.
Section InstDef.
Variables (As Bs : seq Type) (B : Type) (e : ST As B).
Variables (f : funtp Bs (args As)).

Definition inst_s : simpl_fun unit (spec Bs B) := 
  [fun : unit => 
    (fun_lam (fun b : args Bs => fun_app (spec_of e).1 (fun_app f b)),
     dfun_lam (fun b : dargs Bs => 
       dfun_app (spec_of e).2 (dpair (fun_app f (dfst b))
                                     (fun_app f (dsnd b)))))].

Definition inst : ST Bs B := hide (s:= inst_s tt) (Model.inst (code_of e) f).

Lemma instE : spec_of inst = inst_s tt.
Proof. by []. Qed.

End InstDef.

Notation "e @ f" := (inst e f) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @0 f " := (inst e (f : funtp [:::] _))
  (at level 50, left associativity) : iflow_scope.

(* helper lemmas about inst *)

Lemma inst_runs As B (e : ST As B) a : runs0 (e @0 a) <~> runs e a.
Proof. by apply: Model.inst_runs. Qed.

Lemma inst_assoc As Bs B (e : ST Bs B) 
                 (f : funtp As (args Bs)) (a : args As) :
        runs (e @ f) a <~> runs e (fun_app f a).
Proof. by apply: Model.inst_assoc. Qed.

(* continuity of inst *)

Section InstContinuity.
Variables (As As1 As2 : seq Type) (B B1 : Type) (s : spec As B).
Variables (f : STsec s -> ST As1 B1) (g : funtp As2 (args As1)).
Variables (C : stcontinuous f).

Lemma inst_stcont : stcontinuous (fun e => f e @ g). 
Proof.
case: C=>s' [f'][H E]. 
exists (Model.inst_s s' g); exists (Model.inst^~ g \o f').
split; first by apply: comp_cont H; apply: Model.inst_cont.
by move=>x; rewrite E.
Qed.

End InstContinuity.

Implicit Arguments inst_stcont [As As1 As2 B B1 s f g].
Prenex Implicits inst_stcont.

Notation "[ x1 , .. , xn ] " := (pair x1 .. (pair xn tt) ..)
  (at level 0) : iflow_scope.
Notation "e @1 f " := (inst e (f : funtp [::: _] _)) 
  (at level 50, left associativity) : iflow_scope.
Notation "e @2 f " := (inst e (f : funtp [::: _; _] _)) 
  (at level 50, left associativity) : iflow_scope.

Section BindDef.
Variables (As : seq Type) (A B : Type) (e1 : ST As A) (e2 : ST [::: A & As] B).

Definition bind : ST As B := 
  hide (s := bind_s e1 e2) (Model.bind (code_of e1) (code_of e2)).

End BindDef.

(* helper lemmas about bind *)

Lemma bindE As A B (e1 : ST As A) (e2 : ST [:: A & As] B) : 
    spec_of (bind e1 e2) = bind_s e1 e2.
Proof. by []. Qed.

Lemma bindS A B (e1 : ST [:::] A) (e2 : ST [::: A] B) y i m : 
        (i, y, m) \In runs0 (bind e1 e2) -> 
        exists x, exists h, 
          (i, x, h) \In runs0 e1 /\ (h, y, m) \In runs e2 [x]. 
Proof. by apply: Model.bindS. Qed.

Lemma bindC A B (e1 : ST [:::] A) (e2 : ST [::: A] B) y i m x h : 
        i \In bind_pre e1 e2 ->
        (i, x, h) \In runs0 e1 -> 
        (h, y, m) \In runs e2 [x] -> 
        (i, y, m) \In runs0 (bind e1 e2). 
Proof. by apply: Model.bindC. Qed.

Lemma bindR As A B (e1 : ST As A) (e2 : ST [::: A & As] B) a:
        runs (bind e1 e2) a <~>
        runs0 (bind (e1 @0 a) (e2 @1 (fun x => (x, a)))).
Proof. by apply: Model.bindR. Qed.

Prenex Implicits bindE bindS bindC bindR.

(* continuity of bind *)

Section BindContinuity.
Variables (As As1 : seq Type) (B B1 B2 : Type).
Variables (s : spec As B).
Variables (f1 : STsec s -> ST As1 B1). 
Variables (f2 : STsec s -> ST [::: B1 & As1] B2).
Variables (C1 : stcontinuous f1) (C2 : stcontinuous f2).

Lemma bind_stcont : stcontinuous (fun e => bind (f1 e) (f2 e)).
Proof.
case: C1=>s1 [g1][H1 E1]; case: C2=>s2 [g2][H2 E2].
exists (Model.bind_s s1 s2). 
exists ((fun e => Model.bind e.1 e.2) \o (g1 \* g2) \o (fun e => (e, e))).
split; last by move=>x; rewrite E1 E2.
apply: comp_cont; last by apply: diag_cont.
by apply: comp_cont; [apply: Model.bind_cont | apply: prod_cont].
Qed.

End BindContinuity.

End SecInstBind. 

Export SecInstBind.

Implicit Arguments inst_stcont [As As1 As2 B B1 s f g].
Prenex Implicits inst_stcont.

Prenex Implicits bindE bindS bindC bindR.

Notation "e1 ';;' e2" := (bind e1 e2)
  (at level 78, right associativity) : iflow_scope.

Lemma bndP As Bs A B f (e : ST As B) (e' : ST [::: B] A) (b : args Bs) :
        runs0 ((e @ f) @0 b ;; e') <~>
        runs0 (e @0 (fun_app f b) ;; e').
Proof.
case=>[[i x h]]; rewrite !toPredE /=; split=>H1.
- suff H: i \In (bind_pre (e @0 fun_app f b)) e'.
  - case/bindS: H1=>x0 [h0][H1]; apply: bindC H _.
    by rewrite !inst_runs inst_assoc in H1 *.
  case/def_runs: H1=>_ /=; rewrite bindE instE /=; case.
  rewrite instE /= instE /= fun_beta dfun_beta /=.
  by rewrite dargs_beta1 dargs_beta2. 
suff H: i \In (bind_pre (e @ f @0 b)) e'.
- case/bindS: H1=>x0 [h0][H1]; apply: bindC H _.
  by rewrite !inst_runs inst_assoc in H1 *.
case/def_runs: H1=>_ /=; rewrite bindE instE /=; case. 
rewrite instE /= instE /= fun_beta dfun_beta /=.
by rewrite dargs_beta1 dargs_beta2.
Qed.

(* definition of the Hoare fourtuple / subsumption rule *)
(* put the defs into the module, so that the typechecker *)
(* doesn't unfold them when backtracking with canonical structs *)

Module Defs.

Definition safe' A (e : ST [:::] A) i := def i -> i \In (spec_of e).1.

Definition verify' A (e : ST [:::] A) i (q : A -> heap -> Prop) := 
  def i ->
  forall y m, (i, y, m) \In runs0 e -> q y m.

Definition verify2' A (e1 e2 : ST [:::] A) i1 i2
                    (q : A -> A -> heap -> heap -> Prop) := 
  def i1 -> def i2 ->
  forall y1 y2 m1 m2, 
    (i1, y1, m1) \In runs0 e1 -> 
    (i2, y2, m2) \In runs0 e2 -> q y1 y2 m1 m2.

End Defs.

Notation safe i e := (@Defs.safe' _ e i).

Notation verify i e q := (@Defs.verify' _ e i q).

Notation verify2 i1 i2 e1 e2 q := (@Defs.verify2' _ e1 e2 i1 i2 q).  

(* Notation verify2 i1 i2 e1 e2 q := 
  (verify i1 e1 (fun y1 m1 => 
     verify i2 e2 (fun y2 m2 => q y1 y2 m1 m2))). *)

Definition conseq As B (e : ST As B) 
             (p : args As -> heap -> Prop) 
             (q : args As -> args As -> heap -> heap -> 
                  B -> B -> heap -> heap -> Prop) :=
  (forall a i, p a i -> safe i (e @0 a)) /\ 
   forall a1 a2 i1 i2, p a1 i1 -> p a2 i2 -> 
     verify2 i1 i2 (e @0 a1) (e @0 a2) (q a1 a2 i1 i2). 

Implicit Arguments conseq [As B].

(* some local notation to make the messages of Program prettier *)

Local Notation conseq1 := 
  (fun As B (e : ST As B) (s : spec As B) => 
     conseq e (let: pair p _ := s in fun_app p)
              (let: pair _ q := s in 
                 fun a1 a2 i1 i2 y1 y2 m1 m2 => 
                   forall x:unit, dfun_app q (dpair a1 a2) 
                                  (i1, i2) (y1, y2) (m1, m2))).

Module Type SecConseqSig.
Parameter do' : forall As B (s : spec As B)
                  (e : ST As B), conseq1 As B e s -> STsec s.
Parameter do'_cont : 
  forall (As1 As2 : seq Type) (B1 B2 : Type) 
         (s1 : spec As1 B1) (s2 : spec As2 B2)
         (f : STsec s1 -> ST As2 B2)
         (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2)
         (C : stcontinuous f),
  continuous (fun e : STsec s1 => do' (pf e)).

End SecConseqSig.

Module SecConseq : SecConseqSig.
Section SecConsequence.
Variables (As : seq Type) (B : Type) (s : spec As B).
Variables (e : ST As B) (pf : conseq1 As B e s).

Definition do_prog : prog As B s.1 := 
  prog_lam (fun b p y m => 
    exists i, i \In id_val p /\ (i, y, m) \In runs e b).

Lemma do_coherent : coherent do_prog. 
Proof.
move=>b p y m; split; rewrite prog_beta.
- by case=>i [/= H1 T1]; exists i; exists H1; exists i.
by case=>i [/= H1][_][[<-]] T1; exists i.
Qed.

Lemma do_dstrict : def_strict do_prog.
Proof. 
by move=>b p y; rewrite prog_beta; case=>h [/= H]; case/Model.def_runs. 
Qed.

Lemma do_has_spec : do_prog \In has_spec s.
Proof.
move=>a [i1 i2][y1 y2][m1 m2]; rewrite /runs /Model.runs !prog_beta /=. 
case=>[[/= H1 D1]][_][[<-]] T1 [[/= H2 D2]][_][[<-]] T2.
case: s pf H1 H2=>p q [_ L] H1 H2; rewrite (dargs_eta a).
by apply: L=>//; rewrite inst_runs.
Qed.

Definition do' := STprog do_coherent do_dstrict do_has_spec.

End SecConsequence.

Implicit Arguments do' [As B s].

(* monotonicity of do' *)

Section DoMonotonicity. 
Variables (As1 As2 : seq Type) (B1 B2 : Type).
Variables (s1 : spec As1 B1) (s2 : spec As2 B2).
Variables (f : STsec s1 -> ST As2 B2). 
Variables (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2).
Variables (C : stcontinuous f).

Lemma do'_mono : monotone (fun e : STsec s1 => do' (f e) (pf e)).
Proof.
move=>e1 e2 H; apply: prog_lam_mono=>a p y m [i][H1] H2; exists i; split=>//.
case: C=>s [f'][[M']] _ E'; rewrite !E' in H2 *.
by apply: runs_mono H2; apply: M'.
Qed.

End DoMonotonicity. 

Implicit Arguments do'_mono [As1 As2 B1 B2 s1 s2 f pf].
Prenex Implicits do'_mono.

(* continuity of do' *)

Section DoContinuity.
Variables (As1 As2 : seq Type) (B1 B2 : Type).
Variables (s1 : spec As1 B1) (s2 : spec As2 B2).
Variables (f : STsec s1 -> ST As2 B2). 
Variables (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2).
Variables (C : stcontinuous f).

Lemma do'_cont : continuous (fun e : STsec s1 => do' (f e) (pf e)).
Proof.
case: s2 pf=>p q pf'; case: C=>s [f'][[M']] C' E'. 
exists (do'_mono C)=>d; apply: poset_asym; last first.
- apply: limM=>y [e][->] H1. 
  apply: prog_lam_mono=>a [/= r H] z m [i][H2] H3; exists i; split=>//.
  rewrite !E' /= C' in H3 *.
  by apply: lim_runsP H3; exists e.
apply: model_def; rewrite /= comp_chainE /comp.
rewrite [lim [_ ^^ _ by _]]prog_eta.
apply: prog_lam_mono=>b r y m [i][H1].
rewrite E' /=  C'; apply: lim_runsM=>e H H2.
by rewrite prog_beta E'; exists i.
Qed.

End DoContinuity.

End SecConseq.

Definition do' := SecConseq.do'.

Implicit Arguments do' [As B s].
Notation "'Do' e" := (do' e _) (at level 80).

Lemma do_cont : 
  forall (As1 As2 : seq Type) (B1 B2 : Type) 
         (s1 : spec As1 B1) (s2 : spec As2 B2)
         (f : STsec s1 -> ST As2 B2)
         (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2)
         (C : stcontinuous f),
  continuous (fun e : STsec s1 => do' (f e) (pf e)).
Proof. by apply: SecConseq.do'_cont. Qed.

(***********************)
(* the non-structurals *)
(***********************)

(* read *)

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

Definition read A : ST [::: ptr] A := 
  hide (s := read_s A tt) (Model.read A).

(* write *)

Definition write_s A : simpl_fun unit (spec [::: ptr; A] unit) := 
  [fun : unit => 
    (fun x v i => exists h, exists B, exists ww : B, i = x :-> ww :+ h,
     fun x v i y m => 
       forall h B1 B2 (ww1 : B1) (ww2 : B2), 
         i = (x.1 :-> ww1 :+ h.1, x.2 :-> ww2 :+ h.2) -> 
         m = (x.1 :-> v.1 :+ h.1, x.2 :-> v.2 :+ h.2))].

Definition write A : ST [::: ptr; A] unit := 
  hide (s := write_s A tt) (Model.write A).

(* lalloc *)

Definition lalloc_s A : simpl_fun unit (spec [::: A] ptr) := 
  [fun : unit => 
     (fun v i => True,
      fun v i y 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 A : ST [::: A] ptr := 
  hide (s := lalloc_s A tt) (Model.lalloc A).

(* halloc *)

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

Definition halloc A : ST [::: A] ptr := 
  hide (s := halloc_s A tt) (Model.halloc A).

(* dealloc *)

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

Definition dealloc : ST [::: ptr] unit := 
  hide (s := dealloc_s tt) Model.dealloc.

Implicit Arguments write [A].
Implicit Arguments lalloc [A].
Implicit Arguments halloc [A].

Prenex Implicits write lalloc halloc.

(* conditional *)

Definition if_conseq As B (b : funtp As bool) (e1 e2 : ST As B) 
             (p : args As -> heap -> Prop) 
             (q : args As -> args As -> heap -> heap -> 
                  B -> B -> heap -> heap -> Prop) :=
  (forall a i, p a i -> 
     safe i (if fun_app b a then e1 @0 a else e2 @0 a)) /\
  (forall a1 a2 i1 i2, 
     p a1 i1 -> p a2 i2 -> 
   verify2 i1 i2 (if fun_app b a1 then e1 @0 a1 else e2 @0 a1) 
                 (if fun_app b a2 then e1 @0 a2 else e2 @0 a2) 
    (q a1 a2 i1 i2)).

Implicit Arguments if_conseq [As B].

Local Notation if_conseq1 := 
  (fun As B b (e1 e2 : ST As B) (s : spec As B) => 
     if_conseq b e1 e2 (let: pair p _ := s in fun_app p)
                       (let: pair _ q := s in 
                          fun a1 a2 i1 i2 y1 y2 m1 m2 => 
                            forall x:unit, dfun_app q (dpair a1 a2) 
                                           (i1, i2) (y1, y2) (m1, m2))).

Module Type IfBoolSig.
Parameter if_bool : 
  forall (As : seq Type) (B : Type) (b : funtp As bool) 
         (e1 e2 : ST As B) (s : spec As B)
         (pf : if_conseq1 As B b e1 e2 s), STsec s.

Parameter if_bool_cont : 
  forall (As As1 : seq Type) (b : funtp As bool) (B B1 : Type)
         (s1 : spec As1 B1) (s : spec As B)
         (f1 f2 : STsec s1 -> ST As B)
         (pf : forall e : STsec s1, if_conseq1 As B b (f1 e) (f2 e) s)
         (C1 : stcontinuous f1) (C2 : stcontinuous f2),
    continuous (fun e => if_bool (pf e)).
End IfBoolSig.

Module IfBool : IfBoolSig.
Section IfBool.
Variables (As : seq Type) (B : Type).
Variables (b : funtp As bool) (e1 e2 : ST As B) (s : spec As B). 
Variables (pf : if_conseq1 As B b e1 e2 s).

Definition if_bool_prog : prog As B s.1 := 
  prog_lam (fun a p y m => 
    exists i, i \In id_val p /\ 
      if fun_app b a then  (i, y, m) \In runs e1 a
      else (i, y, m) \In runs e2 a).

Lemma if_bool_coherent : coherent if_bool_prog.
Proof.
move=>a [q H] y m; split; rewrite prog_beta; case=>i [/= H1].
- by case: ifP=>E H2; exists i; exists H1; exists i.
by case=>[_][[<-]]; case: ifP=>E H2; exists i.
Qed.

Lemma if_bool_dstrict : def_strict if_bool_prog.
Proof. 
move=>a q y; rewrite prog_beta; case=>i [H].
by case: ifP=>E; case/Model.def_runs.
Qed. 

Lemma if_bool_has_spec : if_bool_prog \In has_spec s.
Proof.
move=>a [i1 i2][y1 y2][m1 m2] /=; rewrite /runs /Model.runs !prog_beta /=.
case=>[[/= S1 D1]][_][[<-]] E1 [[/= S2 D2]][_][[<-]] E2.
case: ifP E1=>E1 H1; case: ifP E2=>E2 H2; 
case: s S1 S2 (proj2 pf)=>/= [r1 r2] S1 S2; rewrite (dargs_eta a); apply=>//;
by rewrite ?E1 ?E2 inst_runs.
Qed.

Definition if_bool := STprog if_bool_coherent if_bool_dstrict if_bool_has_spec.

End IfBool.

Implicit Arguments if_bool [As B].

(* monotonicity of the conditional *)

Section IfMonotonicity.
Variables (As As1 : seq Type) (b : funtp As bool) (B B1 : Type).
Variables (s1 : spec As1 B1) (s : spec As B).
Variables (f1 f2 : STsec s1 -> ST As B). 
Variables (pf : forall e : STsec s1, if_conseq1 As B b (f1 e) (f2 e) s).
Variables (C1 : stcontinuous f1) (C2 : stcontinuous f2).

Lemma if_bool_mono : monotone (fun e => if_bool b (f1 e) (f2 e) s (pf e)).
Proof.
case: C1=>s1' [f1'][[M1' _]] E1'; case: C2=>s2' [f2'][[M2' _]] E2'.
move=>e1 e2 H; apply: prog_lam_mono=>a p y m [i][H1].
case: ifP=>E H2; exists i; split=>//.
- rewrite !E1' /= in H2 *; apply: runs_mono H2.
  by apply: model_mono; apply: M1'.
rewrite !E2' /= in H2 *; apply: runs_mono H2.
by apply: model_mono; apply: M2'.
Qed.

End IfMonotonicity.

Implicit Arguments if_bool_mono [As As1 b B B1 s1 s f1 f2 pf].
Prenex Implicits if_bool_mono.

(* continuity of the conditional *)

Section IfContinuity.
Variables (As As1 : seq Type) (b : funtp As bool) (B B1 : Type).
Variables (s1 : spec As1 B1) (s : spec As B).
Variables (f1 f2 : STsec s1 -> ST As B). 
Variable (pf : forall e : STsec s1, if_conseq1 As B b (f1 e) (f2 e) s).
Variables (C1 : stcontinuous f1) (C2 : stcontinuous f2).

Lemma if_bool_cont : continuous (fun e => if_bool b (f1 e) (f2 e) s (pf e)).
Proof.
case: s pf=>p q pf'.
case: C1=>s1' [f1'][[M1' C1']] E1'; case: C2=>s2' [f2'][[M2' C2']] E2'.
exists (if_bool_mono C1 C2)=>d; apply: poset_asym; last first.
- apply: limM=>y [e][->] H1.
  apply: prog_lam_mono=>a [/= r H] z m [i][H2] H3; exists i; split=>//=.
  move: H3; rewrite !E1' !E2' /= C1' C2'.
  by case: ifP=>E; apply: lim_runsP; exists e. 
apply: model_def; rewrite /= comp_chainE /comp /=.
rewrite [lim [_ ^^ _ by _]]prog_eta.
apply: prog_lam_mono=>a r y m [i][H].
rewrite !E1' !E2' /= C1' C2'.
case: ifP=>E; apply: lim_runsM=>e H2 H3; rewrite prog_beta;
by exists i; split=>//; rewrite E ?E1' ?E2'.
Qed.

End IfContinuity.
End IfBool.

Export IfBool.

Implicit Arguments if_bool [As B].

(*
Definition if_bool := IfBool.if_bool.


Lemma if_bool_cont As As1 (b : funtp As bool) B B1 
        (s1 : spec As1 B1) (s : spec As B)
        (f1 f2 : STsec s1 -> ST As B)
        (pf : forall e : STsec s1, if_conseq1 As B b (f1 e) (f2 e) s)
        (C1 : stcontinuous f1) (C2 : stcontinuous f2) :
      continuous (fun e => if_bool b (f1 e) (f2 e) s (pf e)).
Proof. by apply: IfBool.if_bool_cont. Qed.
*)

Notation "'Ifbool' b 'then' e1 'else' e2 'with' As , B , s" := 
  (@if_bool As B b e1 e2 s _) (at level 0).

Notation "'ifbool' b 'then' e1 'else' e2" := 
  (@if_bool _ _ b e1 e2 _ _) (at level 0).

(* localization *)

Section Localize. 
Variables (As : seq Type) (A B : Type) (f : A -> ST As B).

Definition localize_s : simpl_fun unit (spec [::: A & As] B) := 
  [fun : unit => 
    (fun_lam (fun a : args [::: A & As] => fun_app (spec_of (f a.1)).1 a.2),
     dfun_lam (fun (a : dargs [::: A & As]) y i m => 
       a.1.1 = a.1.2 -> dfun_app (spec_of (f a.1.1)).2 a.2 y i m))].

Definition localize := 
  hide (s := localize_s tt) (Model.localize (fun x => code_of (f x))).

End Localize.

Prenex Implicits localize_s.

(* the inverse of localize *)
(* so we can freely swap back and forth between a function into an STsec *)
(* and an STsec where the argument is explicitly declared low *)

Section FuncOf. 
Variables (As : seq Type) (A B : Type) (f : A -> ST As B).
Variables (e : STsec (localize_s f tt)).

Program 
Definition funcof : forall x, STsec (spec_of (f x)) := 
  fun x => Do (e @ (fun_lam (fun a => (x, a)))).
Next Obligation.
case E: (spec_of (f x))=>[p q]; split=>[a|a1 a2] /=.
- by move=>i H D; rewrite /Defs.safe' instE /= instE /= !fun_beta /= E.
move=>i1 i2 H1 H2 D1 D2 y1 y2 m1 m2.
rewrite inst_runs=>S1; rewrite inst_runs=>S2 _.
move: (spec_runs S1 S2); rewrite instE /= !dfun_beta !fun_beta E /=.
by rewrite dargs_beta1 dargs_beta2; apply.
Qed.
End FuncOf.

End Exports.

End Model.

Export Model.Exports.