Load loadpath.
Require Import ssreflect ssrbool ssrfun ssrnat eqtype seq.
Require Import prelude domains heaps rels hprop.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits. 
Set Automatic Coercion Import.

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 pre As : Type := 
  if As is A :: As' then A -> pre As' else Pred heap.

Fixpoint post As B := 
  if As is A :: As' then d A -> post As' B 
  else d B -> d heap -> d heap -> Prop.

Definition spec As B := pre As * post As B : 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.

(* lemmas for simultaneous abstraction and application *) 

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.

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.

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.

(**********************)
(* 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 (pre_app r a) :=
  match As as As' return (forall r, prog As' B r -> 
                            forall a, prog0 B (pre_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 (pre_app r a)) -> prog As B r := 
  match As as As' return 
     (forall r, (forall a, prog0 B (pre_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 (pre_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 (pre_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 (pre_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 a1 a2 i y m,
       (i.1, y.1, m.1) \In runs p a1 -> 
       (i.2, y.2, m.2) \In runs p a2 -> 
     post_app s.2 a1 a2 y i 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 pre_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 -> 
        post_app s.2 a1 a2 (y1, y2) (i1, i2) (m1, m2).
Proof. by case: e=>p M D S; apply: (S a1 a2 (i1, i2) (y1, y2) (m1, m2)). 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, b1) (a, b2)). 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 a1 a2 i y m, 
             (i.1, y.1, m.1) \In runs c.1 a1 ->
             (i.2, y.2, m.2) \In runs c.2 a2 ->  
             post_app q a1 a2 y i 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=>a1 a2 i y m; move/runs_bot.
set cpo := pairCPO _ _; move=>d H1 [a1 b1][a2 b2].
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 bs1 bs2.
by apply: (H1 (g1, g2) L (a1, bs1) (a2, bs2)).
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 (pre_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 := 
  (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_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=>b1 b2 [i1 i2][y1 y2][m1 m2] /=; rewrite /runs !prog_beta.
move=>[/= D1][_][[<-]] H1 [/= D2][_][[<-]] H2.
by rewrite post_beta; 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 pre_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 pre_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 y i 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 :=
  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_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=>a1 a2 [i1 i2][y1 y2][m1 m2] /=; rewrite /runs !prog_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_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 pre_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 pre_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 pre_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 y i 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 y i 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][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 := 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 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_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 y i 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. 

(* low block allocation *)

Lemma updi2_lfreshD {A} i (s : seq A) : def i -> def (updi2 (lfresh i) s :+ i).
Proof.
set k := updi2 _ _; case: (defUn k i)=>//[||x H1]; rewrite /k;
[rewrite updi2D lfresh_null=>//|case: negP=>//|]. 
suff H3: exists m, x = (lfresh i).+(2 * m) by 
move: H3=>[m]-> H4; move: (dom_lfresh i)=> H5; move: (H5 m); rewrite H4.
by apply: (updi2_in_dom H1).
Qed.

Section LowBlockAllocation.
Variable A : Type.

Definition lallocb_s : spec [::: A; nat] ptr :=
  (fun v n i => True,
   fun v n y i m =>
     m = (updi2 y.1 (nseq n.1 v.1) :+ i.1, updi2 y.2 (nseq n.2 v.2) :+ i.2) /\
     (i.1 =~ i.2 -> n.1 = n.2 -> v.1 = v.2 -> y.1 = y.2 /\ m.1 =~ m.2)).

Definition lallocb_prog : prog [::: A; nat] ptr lallocb_s.1 :=
  fun v n p y m => exists i,
    i \In id_val p /\ y = lfresh i /\ m = updi2 y (nseq n v) :+ i.

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

Lemma lallocb_dstrict : def_strict lallocb_prog.
Proof.
case=>v[n][][p H] y [h][/= H1][->] H2; case/H: H1=>_ D.
suff: def (updi2 (lfresh h) (nseq n v) :+ h) by rewrite -H2.
by apply: updi2_lfreshD.
Qed.

Lemma lallocb_has_spec : lallocb_prog \In has_spec lallocb_s.
Proof.
move=>[v1][n1][][v2][n2][][i1 i2][y1 y2][m1 m2] /=. 
case=>[[/= _ D1]][_][[<-]][->] ->.
case=>[[/= _ D2]][_][[<-]][->] ->.
split=>// H; rewrite (loweqE H); split=>//.
have [E1 E2] : def (updi2 (lfresh i1) (nseq n1 v1) :+ i1) /\ 
               def (updi2 (lfresh i2) (nseq n2 v2) :+ i2).
- by split; apply: updi2_lfreshD.
by rewrite -(loweqE H) H0 H1 in E1 E2 |- *; apply: lowUn.
Qed.

Definition lallocb := STprog lallocb_coherent lallocb_dstrict lallocb_has_spec.

End LowBlockAllocation.

(* 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 y i 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 := 
  (pre_lam (fun a : args [::: A & As] => pre_app (s a.1).1 a.2),
   post_lam (fun (a1 a2 : args [::: A & As]) y i m => 
              a1.1 = a2.1 -> post_app (s a1.1).2 a1.2 a2.2 y i 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 b1][a2 b2][i1 i2][y1 y2][m1 m2] /=. 
rewrite /Model.runs !prog_beta !post_beta.
case=>[[/= S1 D1]][_][[<-]] E1 [[/= S2 D2]][_][[<-]] E2 E.
rewrite pre_beta in S1; rewrite -{a2}E in E2 S2.
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 pre_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 -> 
        post_app (spec_of e).2 a1 a2 (y1, y2) (i1, i2) (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).

(* 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 => 
    (pre_lam (fun b : args Bs => pre_app (spec_of e).1 (fun_app f b)),
     post_lam (fun b1 b2 : args Bs => 
       post_app (spec_of e).2 (fun_app f b1) (fun_app f b2)))].

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

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

Definition inst0 As B (e : ST As B) a : ST [:::] B := inst e a.
Definition inst1 As A B (e : ST As B) (a : funtp [::: A] (args As)) : 
             ST [::: A] B := inst e a.
Definition inst2 As A1 A2 B (e : ST As B) (a : funtp [::: A1; A2] (args As)) : 
             ST [::: A1; A2] B := inst 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.

(* 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.

(* ret *)

Definition ret_s A : simpl_fun unit (spec [::: A] A) :=
  [fun : unit => (fun x i => True, fun x y i 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.

(* 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 => 
     pre_lam (fun a i => i \In (pre_app (spec_of e1).1 a) /\ 
        forall y m, post_app (spec_of e1).2 a a (y, y) (i, i) (m, m) -> def m -> 
                        m \In (pre_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 =>
      post_lam (fun a1 a2 y i m => exists x, exists h, 
        post_app (spec_of e1).2 a1 a2 x i h /\ def h.1 /\ def h.2 /\
        post_app (spec_of e2).2 (x.1, a1) (x.2, a2) y h 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.

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 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 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.

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

(* definition of the Hoare fourtuple / subsumption rule *)

Definition safe A (e : ST [:::] A) : Pred heap := 
  fun i => i \In (spec_of e).1.

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

Definition verify2 A i1 i2 (e1 e2 : ST [:::] A) (q : d A -> d 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). 

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

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 pre_app p)
              (let: pair _ q := s in 
                 fun a1 a2 y i m => 
                   forall x:unit, post_app q a1 a2 y i m)).

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)
         (C : stcontinuous f)  
         (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2), 
  continuous (fun e : STsec s1 => do' (pf e)).
End SecConseqSig.

Module SecConseq.
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=>a1 a2 [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.
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 y i 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 y i 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 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 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 y i 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).

(* lallocb *)

Definition lallocb_s A : simpl_fun unit (spec [::: A; nat] ptr) := 
  [fun : unit =>
    (fun v n i => True,
     fun v n y i m => 
       m = (updi2 y.1 (nseq n.1 v.1) :+ i.1, updi2 y.2 (nseq n.2 v.2) :+ i.2) /\
       (i.1 =~ i.2 -> n.1 = n.2 -> v.1 = v.2 -> y.1 = y.2 /\ m.1 =~ m.2))].

Definition lallocb {A} : ST [::: A; nat] ptr := 
  hide (s := lallocb_s A tt) (Model.lallocb 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 y i 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 -> d B -> d heap -> d heap -> Prop) :=
  (forall a i, p a i -> def i -> 
     i \In safe (if fun_app b a then e1 @0 a else e2 @0 a)) /\
  (forall a1 a2 i1 i2, 
     p a1 i1 -> p a2 i2 -> def i1 -> def 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) 
    (fun y m => q a1 a2 y (i1, i2) m)).

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 pre_app p)
                       (let: pair _ q := s in 
                          fun a1 a2 y i m => 
                            forall x:unit, post_app q a1 a2 y i m)).

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=>a1 a2 [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; 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.

Definition if_bool := IfBool.if_bool.
Implicit Arguments if_bool [As B].

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 => 
    (pre_lam (fun a : args [::: A & As] => pre_app (spec_of (f a.1)).1 a.2),
     post_lam (fun (a1 a2 : args [::: A & As]) y i m => 
       a1.1 = a2.1 -> post_app (spec_of (f a1.1)).2 a1.2 a2.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 /safe /= !pre_beta 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 /= !post_beta !fun_beta E /=.
by apply.
Qed.
End FuncOf.

End Exports.

End Model.

Export Model.Exports.