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

(* hiding the spec, for ease of programming *)

Definition STsec As B (s : spec As B) : Type := LST s.

Implicit Arguments STsec [As B].

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

Definition rspec_of As B (e : ST As B) := let: hide s _ := e in s.
Definition pre_of As B := [fun e : ST As B => (rspec_of e).1]. 
Definition post_of As B := [fun e : ST As B => (rspec_of e).2]. 
Definition code_of As B (e : ST As B) := 
  let: hide _ c := e return STsec (rspec_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.

(***************************************************)
(* Main definitions for reasoning about continuity *)
(***************************************************)

Lemma cont_id (D : cpo) : continuous (id : D -> D). 
Proof.
move=>d p; rewrite val_supch. 
by apply: sup_eq=>// x; split=>[H|[y][H]-> //]; exists x. 
Qed. 

Hint Resolve cont_id.

Section STcont.
Variables (As1 As2 : seq Type) (B1 B2 : Type).
Variables (s1 : spec As1 B1).
Variables (f : STsec s1 -> ST As2 B2).

Definition st_image (t : Pred (STsec s1)) (s2 : spec As2 B2) := 
  [Pred x : STsec s2 | exists y, y \In t /\ hide x = f y].

Definition stcontinuous := 
  (forall e, rspec_of (f e) = rspec_of (f bot)) /\ 
  (forall s (p : chain s), 
     pval (code_of (f (supch p))) = sup (st_image s _)). 

End STcont.

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).
Variables (C : continuous f).

Lemma st_cont : stcontinuous (fun e => hide (f e)).
Proof.
split=>// s rf; move: (C rf); rewrite /st_image /fun_image => H.
rewrite /pval H; apply: psup_eq => p; split.
- by case=>x [[y]][H1] -> <-; exists (f y); split=>//; exists y.
case=>x [[y]][H1] E <-{p}; exists (f y); split; first by exists y.
suff: f y = x :> STsec s2 by move=>->.
by case: E; case/(inj_pairT2 _ _ _ _ _)=>->.
Qed.

End HideCont.

Lemma st_hide As A (s : spec As A) : stcontinuous (hide (s := s)).
Proof. by apply: st_cont; apply: cont_id.  Qed.

Hint Resolve st_hide.

(* constant functions are continuous *)

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

Lemma const_cont (s2 : spec As2 B2) (e : STsec s2) : 
        continuous (fun x : STsec s1 => e).
Proof.
move=>s p; rewrite /fun_image.
apply: leq_asym; last by apply: psupM=>_ [c][[w]][H1] <- <-.
apply: psupP; exists (code_of e); split=>//.
by case: p=>[[x]] E _; exists x.
Qed.

Lemma const_stcont (e : ST As2 B2) : stcontinuous (fun x : STsec s1 => e).
Proof. by case: e=>s e; apply: st_cont; apply: const_cont. Qed.

End ConstCont. 

(*************************************************)
(* Definitions of the commands to hide the specs *)
(* -- otherwise typechecking becomes really slow *)
(*************************************************)

(*************)
(* recursion *)
(*************)

Module Type SecFixSig. 
Parameter Fix' : forall As B (s : spec As B) 
                   (f : STsec s -> STsec s) (C : continuous f), STsec s.
End SecFixSig.

Module SecFix : SecFixSig.
Section SecFix.
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 SecFix.
End SecFix.

Definition Fix' := SecFix.Fix'.

Implicit Arguments Fix' [As B s].
Notation "'Fix' f" := (Fix' f _) (at level 80).

(*****************)
(* instantiation *)
(*****************)

Module Type SecInstSig.
Parameter inst : forall (As Bs : seq Type) B, ST As B -> 
                   funtp Bs (args As) -> ST Bs B.
Definition inst0 (As : seq Type) B (e : ST As B) a : ST [::] B := inst e a.

Parameter instE : 
  forall As Bs B (e : ST As B) (f : funtp Bs (args As)), 
    rspec_of (inst e f) = 
      (pre_lam (fun b => pre_app (pre_of e) (fun_app f b)), 
       post_lam (fun b1 b2 => 
                   post_app (post_of e) (fun_app f b1) (fun_app f b2))).

Parameter inst_runs : 
  forall As B (e : ST As B) a, 
    runs_of (pval (code_of (inst0 e a))) <~> 
    runs_of (code_app (pval (code_of e)) a).
 
Parameter inst_assoc :
  forall As Bs B (e : ST Bs B) (f : funtp As (args Bs)) (a : args As), 
        runs_of (pval (code_of (inst0 (inst e f) a))) <~>
        runs_of (pval (code_of (inst0 e (fun_app f a)))).

Parameter inst_cont : 
  forall (As As1 As2 : seq Type) (B B1 : Type) (s : spec As B)
         (f : STsec s -> ST As1 B1) (C : stcontinuous f) 
         (g : funtp As2 (args As1)),
   stcontinuous (fun e => inst (f e) g).
End SecInstSig.

Module SecInstantiation : SecInstSig.
Section Instantiation.
Variables (As Bs : seq Type) (B : Type) (e : ST As B).
Variables (f : funtp Bs (args As)).

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

Lemma instE : rspec_of inst = 
        (pre_lam (fun b => pre_app (pre_of e) (fun_app f b)), 
         post_lam (fun b1 b2 => 
                     post_app (post_of e) (fun_app f b1) (fun_app f b2))).
Proof. by []. Qed.

End Instantiation.

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.

Lemma inst_runs As B (e : ST As B) a :
        runs_of (pval (code_of (inst0 e a))) <~> 
        runs_of (code_app (pval (code_of e)) a).
Proof.
move=>[[i]] y m; split=>/=; first by case=>[[/= _ D1]][_][[<-]].
move=>H; case/def_runs: (H)=>D1 H1 _.
by exists (conj H1 D1); exists i.
Qed.

(* helper lemma on instantiation *)

Lemma inst_assoc As Bs B (e : ST Bs B) (f : funtp As (args Bs)) (a : args As) : 
        runs_of (pval (code_of (inst0 (inst e f) a))) <~>
        runs_of (pval (code_of (inst0 e (fun_app f a)))).
Proof.
move=>[[i]] y m; split.
- case=>[[/= S1 D1]][_][[<-]]; rewrite code_beta.
  case=>[_][_][[<-]] /= L2; rewrite pre_beta in S1.
  by exists (conj S1 D1); exists i.
case=>[[/= S1 D1]][_][[<-]]; rewrite /pval => L; rewrite /runs_of.
set J1 := defed _; have E1 : i \In J1 by split=>//; rewrite pre_beta.
exists E1; exists i; split=>//=; rewrite code_beta /runs_of. 
set J2 := defed _; have E2 : i \In J2 by split=>//; rewrite pre_beta.
by exists E2; exists i.
Qed.

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

Lemma inst_cont : stcontinuous (fun e => inst (f e) g).
Proof.
case: C=>D F; split; first by move=>e; rewrite /inst /= D.
move=>t qf; move: (F t qf); rewrite /st_image=>{F} F.
rewrite /pval /cpo_to_poset /val code_eta => a.
rewrite progE /= /Model.inst_sp {}F /= !code_sup_app.
apply: fext=>p; apply: fext=>y; apply: fext=>m; apply: pext; split.
- case=>i [S1][[/= T1 D1]]. 
  case=>_ [[_]][[_]][[_]][[_]][[_]][[e']][[e]][H1] E1 <- -> <- -> -> ->.
  case/model_runs=>_ [[<-]] H2.
  rewrite (_ : rspec_of (f (supch qf)) = rspec_of (f e)) in p T1 S1 *; 
    last by rewrite !D.
  exists (model (code_app (pval (Model.inst (code_of (f e)) g)) a) p y m).
  split; first by do ![econstructor; split=>//].
  by rewrite code_beta; exists i; split=>//; rewrite -E1.
case=>_ [[_]][[_]][[_]][[_]][[_]][[e']][[e]][H1] E1 <- -> <- -> -> ->.
case/model_runs=>i [S] H2; exists i; split=>//.
case/def_runs: (H2)=>D1; rewrite pre_beta => S1 _.
rewrite (_ : rspec_of (f (supch qf)) = rspec_of (f e)) in p S S1 *;
  last by rewrite !D.
exists (conj S1 D1).
exists (model (code_app (val (code_of (f e))) (fun_app g a)) 
          (single (conj S1 D1)) y m).
split; first by do 6![econstructor; split=>//]; exists e; case: (f e).
apply/model_runs; exists i; split=>//.
by rewrite -inst_runs -inst_assoc -E1 inst_runs.
Qed.

End SecInstContinuity.
End SecInstantiation.

Definition inst := SecInstantiation.inst.
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 @ 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.

Lemma instE As Bs B (e : ST As B) (f : funtp Bs (args As)) :
    rspec_of (e @@ f) = 
      (pre_lam (fun b => pre_app (pre_of e) (fun_app f b)), 
       post_lam (fun b1 b2 => 
                   post_app (post_of e) (fun_app f b1) (fun_app f b2))).
Proof. by apply: SecInstantiation.instE. Qed.

Lemma inst_runs As B (e : ST As B) a :
        runs_of (pval (code_of (e @ a))) <~> 
        runs_of (code_app (pval (code_of e)) a).
Proof. by apply: SecInstantiation.inst_runs. Qed.

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

Lemma inst_cont (As As1 As2 : seq Type) (B B1 : Type) (s : spec As B)
                (f : STsec s -> ST As1 B1) (C : stcontinuous f) 
                (g : funtp As2 (args As1)) : 
        stcontinuous (fun e => (f e) @@ g).
Proof. by apply: SecInstantiation.inst_cont. Qed.

(**********)
(* return *)
(**********)

Module Type SecRetSig.
Parameter ret : forall A, ST [:: A] A.
Parameter retE : forall A, 
  rspec_of (ret A) = (fun x i => True, fun x y i m => m = i /\ y = x).
End SecRetSig.

Module SecRet : SecRetSig.
Definition ret A : ST [:: A] A := hide (Model.ret A).
Lemma retE A : rspec_of (ret A) = 
               (fun x i => True, fun x y i m => m = i /\ y = x).
Proof. by []. Qed.
End SecRet.

Definition ret := SecRet.ret.
Implicit Arguments ret [A].

Lemma retE A : rspec_of (@ret A) = 
               (fun x i => True, fun x y i m => m = i /\ y = x).
Proof. by apply: SecRet.retE. Qed.

(********)
(* bind *)
(********)

Module Type SecBindSig.
Parameter bind : forall As A B, ST As A -> ST [:: A & As] B -> ST As B.

Parameter bindE : 
  forall As A B (e1 : ST As A) (e2 : ST [:: A & As] B), 
    rspec_of (bind e1 e2) =
    (pre_lam (fun a i => i \In (pre_app (pre_of e1) a) /\ 
              forall y m, post_app (post_of e1) a a (y, y) (i, i) (m, m) -> 
                def m -> m \In (pre_app (pre_of e2) (y, a))), 
     post_lam (fun a1 a2 y i m => exists x, exists h, 
       post_app (post_of e1) a1 a2 x i h /\ def h.1 /\ def h.2 /\
       post_app (post_of e2) (x.1, a1) (x.2, a2) y h m)).

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

Parameter bindS : 
  forall A B (e1 : ST [::] A) (e2 : ST [:: A] B) y i m,
    (i, y, m) \In runs_of (pval (code_of (bind e1 e2))) -> 
    exists x, exists h, 
      (i, x, h) \In runs_of (pval (code_of e1)) /\ 
      (h, y, m) \In runs_of (pval (code_of (e2 @ [x]))). 

Parameter bindC : 
  forall A B (e1 : ST [::] A) (e2 : ST [:: A] B) y i m x h,
    i \In Model.bind_pre (rspec_of e1) (rspec_of e2) ->
    (i, x, h) \In runs_of (pval (code_of e1)) -> 
    (h, y, m) \In runs_of (pval (code_of (e2 @ [x]))) -> 
    (i, y, m) \In runs_of (pval (code_of (bind e1 e2))). 

Parameter bindR : 
  forall As A B (e1 : ST As A) (e2 : ST [:: A & As] B) a, 
    runs_of (pval (code_of (bind e1 e2 @ a))) <~>
    runs_of (pval (code_of (bind (e1 @ a) (e2 @1 (fun x => (x, a)))))).
End SecBindSig.

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

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

Lemma bindE : 
        rspec_of bind =
        (pre_lam (fun a i => i \In (pre_app (pre_of e1) a) /\ 
           forall y m, post_app (post_of e1) a a (y, y) (i, i) (m, m) -> 
             def m -> m \In (pre_app (pre_of e2) (y, a))), 
         post_lam (fun a1 a2 y i m => exists x, exists h, 
           post_app (post_of e1) a1 a2 x i h /\ def h.1 /\ def h.2 /\
           post_app (post_of e2) (x.1, a1) (x.2, a2) y h m)).
Proof. by []. Qed.

End SecBind.

Section SecBindContinuity.
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_cont : stcontinuous (fun e => bind (f1 e) (f2 e)).
Proof.
case: C1=>D1 F1; case: C2=>D2 F2.
split; first by move=>e; rewrite /bind /= D1 D2.
move=>t qf; move: (F1 t qf) (F2 t qf); rewrite /st_image=>{F1 F2} F1 F2.
rewrite /pval /cpo_to_poset /val /= code_eta => a.
rewrite progE /= /Model.bind_sp {}F1 {}F2 /=.
apply: fext=>p; apply: fext=>y; apply: fext=>m; apply: pext; split.
- case=>i [x][h][H1][[/= S1]]; rewrite !code_sup_app. 
  case=>[_][[_]][[_]][[_]][[_]][[_]][[g1]][[e1]][H2] E1 <- ->
        <- -> -> -> H3.
  case=>[/= S2][_][[_]][[_]][[_]][[_]][[_]][[_]][[g2]][[e2]][H4]
        E2 <- -> -> <- -> -> -> H5.
  pose r : Pred (LST s) := [Pred x | x = e1 \/ x = e2].
  have R : chain r.
  - split; first by exists e1; left.
    case: {-}(qf)=>_; move/(_ _ _ H2 H4)=>L.
    by move=>?? [] -> [] ->; intuition.
  have [M1 M2] : (val e1 <== val e2 -> supch R = e2) /\ 
                 (val e2 <== val e1 -> supch R = e1).
  - rewrite !valE !(valX (supch R)) !val_supch /r; split=>H; 
    by (apply: leq_asym; first by [apply: supM=>z [] ->];
        apply: supP; rewrite InE /=; auto).
  case: {-}(qf)=>_; case/(_ _ _ H2 H4)=>L.
  - rewrite (_ : rspec_of (f1 (supch qf)) = rspec_of (f1 e2)) in 
    g1 S1 E1 H3 p H1 *; last by rewrite !D1.
    rewrite (_ : rspec_of (f2 (supch qf)) = rspec_of (f2 e2)) in
     g2 S2 E2 H5 p H1 *; last by rewrite !D2.
    exists (model (code_app (pval (code_of (bind (f1 e2) (f2 e2)))) a) p y m).
    split; first by do 6![econstructor; split=>//]; exists e2.
    rewrite code_beta.
    exists i; exists x; exists h; do !split=>//.
    - exists S1; apply: modelM H3; apply: code_appM.
      case: (C1)=>_; move/(_ r R); rewrite M1 // => ->.
      apply: psupP; econstructor; split=>//.
      by exists e1; split=>//; left.
    exists S2; apply: modelM H5; apply: code_appM. 
    case: (f2 e2) g2 E2=>/= t1 [/= T1] t2 [T2] T.
    by rewrite /val /=; case; move/(inj_pairT2 _ _ _ _ _)=>->.
  rewrite (_ : rspec_of (f1 (supch qf)) = rspec_of (f1 e1)) 
    in S1 g1 E1 H3 p H1 *; last by rewrite !D1.
  rewrite (_ : rspec_of (f2 (supch qf)) = rspec_of (f2 e1)) 
    in S2 g2 E2 H5 p H1 *; last by rewrite !D2.
  exists (model (code_app (pval (code_of (bind (f1 e1) (f2 e1)))) a) p y m).
  split; first by do 6![econstructor; split=>//]; exists e1.
  rewrite code_beta.
  exists i; exists x; exists h; do !split=>//.
  - exists S1; apply: modelM H3; apply: code_appM.
    case: (f1 e1) g1 E1=>/= t1 [/= T1] t2 [T2] T.
    by rewrite /val /=; case; move/(inj_pairT2 _ _ _ _ _)=>->.
  case: (C2)=>_; move/(_ r R); rewrite M2 // => ->.
  exists S2; apply: modelM H5; apply: code_appM.
  apply: psupP; do 2![econstructor; split=>//].
  by exists e2; split=>//; right.
rewrite !code_sup_app /=.
case=>_ [[_]][[_]][[_]][[_]][[_]][[g]][[e]][H1] E <- -> <- -> -> ->.
move: E; rewrite /bind /=; case=>_ _.
rewrite (_ : rspec_of (f1 (supch qf)) = rspec_of (f1 e)) in p g *; 
  last by rewrite !D1.
rewrite (_ : rspec_of (f2 (supch qf)) = rspec_of (f2 e)) in p g *;
  last by rewrite !D2.
move/(inj_pairT2 _ _ _ _ _)=>->{g}.
rewrite /val /= code_beta /=.
case=>i [x][h][H2][].
case=>[/= G1]; case/model_runs=>_[[<-]] H3.
case=>[/= G2]; case/model_runs=>_[[<-]] H4.
exists i; exists x; exists h; do !split=>//.
- exists G1.
  exists (model (code_app (val (code_of (f1 e))) a) (single G1) x h).
  split; last by apply/model_runs; exists i. 
  by do 6![econstructor; split=>//]; exists e; split=>//; case: (f1 e).
exists G2; rewrite code_sup_app. 
exists (model (code_app (val (code_of (f2 e)) x) a) (single G2) y m).
split; last by apply/model_runs; exists h.
by do 7![econstructor; split=>//]; exists e; split=>//; case: (f2 e).
Qed.

End SecBindContinuity.

(* some futher helper lemmas about bind *)

Lemma bindS A B (e1 : ST [::] A) (e2 : ST [:: A] B) y i m : 
      (i, y, m) \In runs_of (pval (code_of (bind e1 e2))) -> 
      exists x, exists h, 
        (i, x, h) \In runs_of (pval (code_of e1)) /\ 
        (h, y, m) \In runs_of (pval (code_of (e2 @ [x]))). 
Proof.
move=>[/= D][_][x][h][[<-]][H1] H2.
by exists x; exists h; rewrite inst_runs.
Qed.

Lemma bindC A B (e1 : ST [::] A) (e2 : ST [:: A] B) y i m x h : 
        i \In Model.bind_pre (rspec_of e1) (rspec_of e2) ->
        (i, x, h) \In runs_of (pval (code_of e1)) -> 
        (h, y, m) \In runs_of (pval (code_of (e2 @ [x]))) -> 
        (i, y, m) \In runs_of (pval (code_of (bind e1 e2))). 
Proof.
move=>H1.
rewrite !inst_runs=>H2 H3; case: (def_runs H2)=>D _ _.
by exists (conj H1 D); exists i; exists x; exists h.
Qed.

Lemma bindR As A B (e1 : ST As A) (e2 : ST [:: A & As] B) a:
        runs_of (pval (code_of (bind e1 e2 @ a))) <~>
        runs_of (pval (code_of (bind (e1 @ a) (e2 @1 (fun x => (x, a)))))).
Proof.
move=>[[i y] m]; split=>/=.
- case/inst_runs=>/= H.
  rewrite /Model.bind /= /pval /cpo_to_poset /val /= code_beta.
  case=>_ [x][h][[<-]][H1] H2; case: H=>/= H D.
  have E: i \In defed (Model.bind_pre (rspec_of (e1 @ a)) 
                                      (rspec_of (e2 @1 (fun x => (x, a))))).
  - split=>//; rewrite instE /= instE /=. simpl.
    by rewrite /Model.bind_pre /= pre_beta in H *.
  exists E; exists i; exists x; exists h; split=>//.
  by rewrite inst_runs; split=>//; rewrite -inst_runs inst_assoc inst_runs.
case=>[[/= H D]][_][x][h][[<-]][]; rewrite inst_runs=>H1.
rewrite -inst_runs inst_assoc inst_runs /= => H2.
apply/inst_runs=>/=.
have E:  i \In defed (pre_app (Model.bind_pre (rspec_of e1) (rspec_of e2)) a).
- split=>//; move: H; rewrite instE /= instE /=. 
  by rewrite /Model.bind_pre /= pre_beta.
exists E.
rewrite /pval /cpo_to_poset /val code_beta /=.
by exists i; exists x; exists h.
Qed.

End SecBind.

Definition bind := SecBind.bind.

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

Lemma bindE As A B (e1 : ST As A) (e2 : ST [:: A & As] B) : 
        rspec_of (bind e1 e2) =
         (pre_lam (fun a i => i \In (pre_app (pre_of e1) a) /\ 
            forall y m, post_app (post_of e1) a a (y, y) (i, i) (m, m) -> 
              def m -> m \In (pre_app (pre_of e2) (y, a))), 
          post_lam (fun a1 a2 y i m => exists x, exists h, 
            post_app (post_of e1) a1 a2 x i h /\ def h.1 /\ def h.2 /\
            post_app (post_of e2) (x.1, a1) (x.2, a2) y h m)).
Proof. by apply: SecBind.bindE. Qed.

Lemma bind_cont As As1 B B1 B2 (s : spec As B)
                (f1 : STsec s -> ST As1 B1) 
                (f2 : STsec s -> ST [:: B1 & As1] B2) :
        stcontinuous f1 -> stcontinuous f2 -> 
        stcontinuous (fun e => f1 e ;; f2 e).
Proof. by apply: SecBind.bind_cont. Qed.

Lemma bindS A B (e1 : ST [::] A) (e2 : ST [:: A] B) y i m : 
      (i, y, m) \In runs_of (pval (code_of (bind e1 e2))) -> 
      exists x, exists h, 
        (i, x, h) \In runs_of (pval (code_of e1)) /\ 
        (h, y, m) \In runs_of (pval (code_of (e2 @ [x]))). 
Proof. by apply: SecBind.bindS. Qed.

Lemma bindC A B (e1 : ST [::] A) (e2 : ST [:: A] B) y i m x h : 
        i \In Model.bind_pre (rspec_of e1) (rspec_of e2) ->
        (i, x, h) \In runs_of (pval (code_of e1)) -> 
        (h, y, m) \In runs_of (pval (code_of (e2 @ [x]))) -> 
        (i, y, m) \In runs_of (pval (code_of (bind e1 e2))). 
Proof. by apply: SecBind.bindC. Qed.

Lemma bindR As A B (e1 : ST As A) (e2 : ST [:: A & As] B) a:
        runs_of (pval (code_of (bind e1 e2 @ a))) <~>
        runs_of (pval (code_of (bind (e1 @ a) (e2 @1 (fun x => (x, a)))))).
Proof. by apply: SecBind.bindR. Qed.

Prenex Implicits bindS.

(**************************)
(* Opaque sealing with Do *)
(**************************)

(* some helper definitions first *)

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

Definition verify A i (e : ST [::] A) (q : A -> heap -> Prop) := 
  def i ->
  forall y m, (i, y, m) \In runs_of (val (code_of 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 runs_of (val (code_of e1)) -> 
    (i2, y2, m2) \In runs_of (val (code_of 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 (inst0 e a)) /\ 
   forall a1 a2 i1 i2, p a1 i1 -> p a2 i2 -> def i1 -> def i2 ->
     verify2 i1 i2 (inst0 e a1) (inst0 e 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 : SecConseqSig.
Section SecConsequence.
Variables (As : seq Type) (B : Type) (s : spec As B).
Variables (e : ST As B) (pf : conseq1 As B e s).

Lemma doP : Model.conseq (code_of e) s.
Proof.
case: s pf=>[p q][/= pf1 pf2]; split.
- by move=>a i H; move/(pf1 a i H); rewrite /safe instE.
move=>a1 a2 [i1 i2][y1 y2][m1 m2] /= H1 H2 D1 D2 S1 S2.
by apply: pf2=>//; rewrite inst_runs.
Qed.

Definition do' : STsec s := Model.Do (code_of e) doP.

End SecConsequence.

Implicit Arguments do' [As B s].

Section SecConseqContinuity.
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 (C : stcontinuous f).
Variables (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2).

Lemma do_cont : continuous (fun e : STsec s1 => do' (f e) (pf e)).
Proof.
move=>t rf /=; case: C=>qf D; move: (D t rf); rewrite /st_image => F.
rewrite /cpo_to_poset /val /= code_eta => a.  
rewrite progE code_sup_app /= /Model.do_sp F code_sup_app.  
apply: fext=>p; apply: fext=>y; apply: fext=>m; apply: pext; split=>/=.
- case=>i [H1][[/= S1 D1]][_][[_]][[_]][[_]][[_]][[_]][[g]]
         [[e]][H2] E <- -> <- -> -> ->.
  case/model_runs=>_ [[<-]]. 
  exists (model (code_app (val (do' (f e) (pf e))) a) p y m).
  split; first by do ![econstructor; split=>//].
  apply/model_runs; exists i; split=>//. 
  rewrite /val /= -E code_beta.
  have L: i \In defed (pre_app s2.1 a) by case: p H1=>p H1 /=; move/H1.
  by exists L; exists i.
case=>_ [[_]][[_]][[_]][[_]][[_]][[_]][[e]][H2] -> <- -> <- -> -> ->.
rewrite /val code_beta; case=>i [H3]; rewrite /pval => H4.
exists i; split=>//.
have -> : rspec_of (f (supch rf)) = rspec_of (f e) by rewrite !qf.
have L: i \In defed (pre_app (rspec_of (f e)).1 a) by case/def_runs: H4.
exists L.
exists (model (code_app (pval (code_of (f e))) a) (single L) y m).
split; first by do 6![econstructor; split=>//]; exists e; case: (f e).
by apply/model_runs; exists i.
Qed.

End SecConseqContinuity.

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)
         (C : stcontinuous f)  
         (pf : forall e : STsec s1, conseq1 As2 B2 (f e) s2),
  continuous (fun e : STsec s1 => do' (f e) (pf e)).
Proof. by apply: SecConseq.do_cont. Qed.

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

Module Type NonStructuralsSig.
Parameter read : forall A, ST [:: ptr:Type] A. 
Parameter write : forall A, ST [:: ptr:Type; A] unit.
Parameter lalloc : forall A, ST [:: A] ptr. 
Parameter halloc : forall A, ST [:: A] ptr. 
Parameter dealloc : ST [:: ptr:Type] unit.

Parameter readE : forall A, 
  rspec_of (read A) =  
    (fun l i => exists h, exists v : A, i = l :-> v :+ h, 
     fun l y i m => m = i /\ 
       forall h v, i.1 = l.1 :-> v.1 :+ h.1 -> 
         i.2 = l.2 :-> v.2 :+ h.2 -> y = v).

Parameter writeE : forall A,
  rspec_of (write A) = 
    (fun l v i => exists h, exists B, exists w:B, i = l :-> w :+ h,
     fun l v y i m => 
       forall h B1 B2 (w1 : B1) (w2 : B2), 
         i.1 = l.1 :-> w1 :+ h.1 -> 
         i.2 = l.2 :-> w2 :+ h.2 -> 
         m.1 = l.1 :-> v.1 :+ h.1 /\ m.2 = l.2 :-> v.2 :+ h.2).

Parameter lallocE : forall A,
  rspec_of (lalloc A) = 
    (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)).

Parameter hallocE : forall A, 
  rspec_of (halloc A) = 
    (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).

Parameter deallocE : 
  rspec_of dealloc = 
    (fun l i => exists h,exists A, exists v : A, i = l :-> v :+ h, 
     fun l y i m => 
       forall h A1 A2 (v1 : A1) (v2 : A2), 
         i.1 = l.1 :-> v1 :+ h.1 -> i.2 = l.2 :-> v2 :+ h.2 -> 
         m = (h.1, h.2)).
End NonStructuralsSig.

Module NonStructurals : NonStructuralsSig. 
Definition read A : ST [:: ptr:Type] A := hide (Model.read A).
Definition write A : ST [:: ptr:Type; A] unit := hide (Model.write A).
Definition lalloc A : ST [:: A] ptr := hide (Model.lalloc A).
Definition halloc A : ST [:: A] ptr := hide (Model.halloc A).
Definition dealloc : ST [:: ptr:Type] unit := hide Model.dealloc.

Lemma readE A :
  rspec_of (read A) =  
    (fun l i => exists h, exists v : A, i = l :-> v :+ h, 
     fun l y i m => m = i /\ 
       forall h v, i.1 = l.1 :-> v.1 :+ h.1 -> 
         i.2 = l.2 :-> v.2 :+ h.2 -> y = v).
Proof. by []. Qed.

Lemma writeE A : 
  rspec_of (write A) = 
    (fun l v i => exists h, exists B, exists w:B, i = l :-> w :+ h,
     fun l v y i m => 
       forall h B1 B2 (w1 : B1) (w2 : B2), 
         i.1 = l.1 :-> w1 :+ h.1 -> 
         i.2 = l.2 :-> w2 :+ h.2 -> 
         m.1 = l.1 :-> v.1 :+ h.1 /\ m.2 = l.2 :-> v.2 :+ h.2).
Proof. by []. Qed.

Lemma lallocE A : 
  rspec_of (lalloc A) = 
    (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)).
Proof. by []. Qed.

Lemma hallocE A : 
  rspec_of (halloc A) = 
    (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).
Proof. by []. Qed.

Lemma deallocE : 
  rspec_of dealloc = 
    (fun l i => exists h,exists A, exists v : A, i = l :-> v :+ h, 
     fun l y i m => 
       forall h A1 A2 (v1 : A1) (v2 : A2), 
         i.1 = l.1 :-> v1 :+ h.1 -> i.2 = l.2 :-> v2 :+ h.2 -> 
         m = (h.1, h.2)).
Proof. by []. Qed.
End NonStructurals.

Definition read := NonStructurals.read. 
Definition write := NonStructurals.write.
Definition lalloc := NonStructurals.lalloc. 
Definition halloc := NonStructurals.halloc. 
Definition dealloc := NonStructurals.dealloc.
 
Lemma readE A :
  rspec_of (read A) =  
    (fun l i => exists h, exists v : A, i = l :-> v :+ h, 
     fun l y i m => m = i /\ 
       forall h v, i.1 = l.1 :-> v.1 :+ h.1 -> 
         i.2 = l.2 :-> v.2 :+ h.2 -> y = v).
Proof. by apply: NonStructurals.readE. Qed.

Lemma writeE A : 
  rspec_of (write A) = 
    (fun l v i => exists h, exists B, exists w:B, i = l :-> w :+ h,
     fun l v y i m => 
       forall h B1 B2 (w1 : B1) (w2 : B2), 
         i.1 = l.1 :-> w1 :+ h.1 -> 
         i.2 = l.2 :-> w2 :+ h.2 -> 
         m.1 = l.1 :-> v.1 :+ h.1 /\ m.2 = l.2 :-> v.2 :+ h.2).
Proof. by apply: NonStructurals.writeE. Qed.

Lemma lallocE A : 
  rspec_of (lalloc A) = 
    (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)).
Proof. by apply: NonStructurals.lallocE. Qed.

Lemma hallocE A : 
  rspec_of (halloc A) = 
    (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).
Proof. by apply: NonStructurals.hallocE. Qed.

Lemma deallocE : 
  rspec_of dealloc = 
    (fun l i => exists h,exists A, exists v : A, i = l :-> v :+ h, 
     fun l y i m => 
       forall h A1 A2 (v1 : A1) (v2 : A2), 
         i.1 = l.1 :-> v1 :+ h.1 -> i.2 = l.2 :-> v2 :+ h.2 -> 
         m = (h.1, h.2)).
Proof. by apply: NonStructurals.deallocE. Qed.

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

Prenex Implicits write lalloc halloc.

(* Conditionals *)

Definition ifconseq As B (e1 e2 : ST As B) 
             (p : args [:: bool:Type & As] -> heap -> Prop) 
             (q : args [:: bool:Type & As] -> 
                  args [:: bool:Type & As] -> d B -> d heap -> d heap -> Prop) :=
  (forall (b : bool) a i, p (b, a) i -> def i -> 
     i \In safe (if b then inst0 e1 a else inst0 e2 a)) /\
  (forall (b1 b2 : bool) a1 a2 i1 i2, 
     p (b1, a1) i1 -> p (b2, a2) i2 -> def i1 -> def i2 -> 
   verify2 i1 i2 (if b1 then inst0 e1 a1 else inst0 e2 a1) 
                 (if b2 then inst0 e1 a2 else inst0 e2 a2) 
    (fun y m => q (b1, a1) (b2, a2) y (i1, i2) m)).

Implicit Arguments ifconseq [As B].

Local Notation ifconseq1 := 
  (fun As B (e1 e2 : ST As B) (s : spec [:: bool:Type & As] B) => 
     ifconseq 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) (e1 e2 : ST As B) 
         (s : spec [:: bool:Type & As] B)
         (pf : ifconseq1 As B e1 e2 s), STsec s.

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

Module IfBool : IfBoolSig.
Section IfBool.
Variables (As : seq Type) (B : Type) (e1 e2 : ST As B) 
          (s : spec [:: bool:Type & As] B). 
Variables (pf : ifconseq1 As B e1 e2 s).

Definition if_bool_sp b a (p : ideald (pre_app s.1 (b, a))) y m := 
  exists i, i \In sval p /\ 
    if b then (i, y, m) \In runs_of (code_app (pval (code_of e1)) a)
    else (i, y, m) \In runs_of (code_app (pval (code_of e2)) a).

Lemma if_bool_dcont b (a : args As) : coherent (@if_bool_sp b a).
Proof.
move=>/= [q H] y m; split.
- case: b H=>H; by case=>i [/= H1] H2; exists i; exists H1; exists i.
by case=>i [/= H1][_][[<-]]; case: b H=>H H2; exists i.
Qed.

Lemma if_bool_dstrict b (a : args As) : def_strict (@if_bool_sp b a).
Proof. by case: b=>q y [i][_]; case/def_runs. Qed.

Definition if_bool_prog := 
  code_lam (fun a : args [:: bool:Type & As] => 
   Prog (@if_bool_dcont a.1 a.2) (@if_bool_dstrict a.1 a.2)).

Lemma if_bool_has_spec : if_bool_prog \In has_spec s.
Proof.
move=>/= [b1 a1][b2 a2] [i1 i2][y1 y2][m1 m2] /=; rewrite !code_beta.
case: b1; case: b2=>/=;
by case=>[[/= S1 D1]][_][[<-]] H1 [[/= S2 D2]][_][[<-]] H2;
   case: s S1 S2 (proj2 pf)=>/= [r1 r2] S1 S2; apply=>//;
   rewrite inst_runs.
Qed.

Definition if_bool : STsec s := @bundle (LST s) _ if_bool_has_spec.

End IfBool. 

Section SecIfContinuity.
Variables (As As1 : seq Type) (B B1 : Type).
Variables (s1 : spec As1 B1) (s : spec [:: bool:Type & As] B).
Variables (f1 f2 : STsec s1 -> ST As B). 
Variables (C1 : stcontinuous f1) (C2 : stcontinuous f2).
Variables (pf : forall e : STsec s1, ifconseq1 As B (f1 e) (f2 e) s).

Lemma if_bool_cont : continuous (fun e => if_bool (pf e)).
Proof.
move=>t rf /=; case: C1=>D1 F1; case: C2=>D2 F2. 
move: (F1 t rf) (F2 t rf); rewrite /st_image => {F1 F2} F1 F2.
rewrite /cpo_to_poset /val /= /if_bool_prog. 
rewrite (code_eta (r:=s.1))=>/=; case=>b a1.
rewrite progE /= /if_bool_sp {}F1 {}F2 !code_sup_app.
case: b; apply: fext=>p; apply: fext=>y; apply: fext=>m; apply: pext; split.
- case=>i [H3][H2][_][[_]][[_]][[_]][[_]]
          [[_]][[g]][[e]][H1] E1 <- -> <- -> -> ->.
  case/model_runs=>_ [[<-]] {H2} /= H2. 
  exists (model (code_app (pval (if_bool (pf e)) true) a1) p y m).
  split; first by do ![econstructor; split=>//].
  by rewrite /pval /cpo_to_poset code_beta -E1; exists i.
- case=>_ [[_]][[_]][[_]][[_]][[_]][[_]][[g]][[e]][H1] 
          -> <- -> -> <- -> -> ->.
  rewrite code_beta; case=>i [/= H2] H3.
  exists i; split=>//. 
  rewrite (_ : rspec_of (f1 (supch rf)) = rspec_of (f1 e)); last by rewrite !D1.
  case/def_runs: (H3)=>D L _; exists (conj L D)=>/=.
  exists (model (code_app (val (code_of (f1 e))) a1) (single (conj L D)) y m).
  split; first by do 6![econstructor; split=>//]; exists e; case: (f1 e).
  by apply/model_runs; exists i.
- case=>i [H3][H2][_][[_]][[_]][[_]][[_]]
          [[_]][[g]][[e]][H1] E1 <- -> <- -> -> ->.
  case/model_runs=>_ [[<-]] {H2} /= H2. 
  exists (model (code_app (pval (if_bool (pf e)) false) a1) p y m).
  split; first by do ![econstructor; split=>//].
  by rewrite /pval /cpo_to_poset code_beta -E1; exists i.
case=>_ [[_]][[_]][[_]][[_]][[_]][[_]][[g]][[e]][H1] 
        -> <- -> -> <- -> -> ->.
rewrite code_beta; case=>i [/= H2] H3.
exists i; split=>//. 
rewrite (_ : rspec_of (f2 (supch rf)) = rspec_of (f2 e)); last by rewrite !D2.
case/def_runs: (H3)=>D L _; exists (conj L D)=>/=.
exists (model (code_app (val (code_of (f2 e))) a1) (single (conj L D)) y m).
split; first by do 6![econstructor; split=>//]; exists e; case: (f2 e).
by apply/model_runs; exists i.
Qed.

End SecIfContinuity.
End IfBool.

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

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

(* another version of conditionals, somewhat more convenient for programming *)

Definition ifconseq2 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 inst0 e1 a else inst0 e2 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 inst0 e1 a1 else inst0 e2 a1) 
                 (if (fun_app b a2) then inst0 e1 a2 else inst0 e2 a2) 
    (fun y m => q a1 a2 y (i1, i2) m)).

Implicit Arguments ifconseq2 [As B].

Local Notation ifconseq21 := 
  (fun As B b (e1 e2 : ST As B) (s : spec As B) => 
     ifconseq2 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 IfBool2Sig.
Parameter if_bool2 : 
  forall (As : seq Type) (B : Type) (b : funtp As bool) 
         (e1 e2 : ST As B) (s : spec As B)
         (pf : ifconseq21 As B b e1 e2 s), STsec s.

Parameter if_bool_cont2 : 
  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)
         (C1 : stcontinuous f1) (C2 : stcontinuous f2)
         (pf : forall e : STsec s1, ifconseq21 As B b (f1 e) (f2 e) s),
    continuous (fun e => if_bool2 (pf e)).
End IfBool2Sig.

Module IfBool2 : IfBool2Sig.
Section IfBool2.
Variables (As : seq Type) (B : Type).
Variables (b : funtp As bool) (e1 e2 : ST As B) (s : spec As B). 
Variables (pf : ifconseq21 As B b e1 e2 s).

Definition if_bool_sp2 a (p : ideald (pre_app s.1 a)) y m :=
  exists i, i \In sval p /\ 
    if (fun_app b a) then  
      (i, y, m) \In runs_of (code_app (pval (code_of e1)) a)
    else 
      (i, y, m) \In runs_of (code_app (pval (code_of e2)) a).

Lemma if_bool_dcont2 (a : args As) : coherent (@if_bool_sp2 a).
Proof.
move=>/= [q H] y m; split; case=>i [/= H1].
- by case: ifP=>E H2; exists i; exists H1; exists i; rewrite E.
by case=>[_][[<-]]; case: ifP=>E H2; exists i; rewrite E.
Qed.

Lemma if_bool_dstrict2 (a : args As) : def_strict (@if_bool_sp2 a).
Proof. by move=>q y [i][/= H]; case: ifP=>E; case/def_runs. Qed.

Definition if_bool_prog2 := 
  code_lam (fun a : args As => Prog (@if_bool_dcont2 a) (@if_bool_dstrict2 a)).

Lemma if_bool_has_spec2 : if_bool_prog2 \In has_spec s.
Proof.
move=>a1 a2 [i1 i2][y1 y2][m1 m2] /=; rewrite !code_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_bool2 : STsec s := @bundle (LST s) _ if_bool_has_spec2.

End IfBool2. 

Implicit Arguments if_bool2 [As B].

Section SecIfContinuity2.
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 (C1 : stcontinuous f1) (C2 : stcontinuous f2).
Variables (pf : forall e : STsec s1, ifconseq21 As B b (f1 e) (f2 e) s).

Lemma if_bool_cont2 : continuous (fun e => if_bool2 b (f1 e) (f2 e) s (pf e)).
Proof.
move=>t rf /=; case: C1=>D1 F1; case: C2=>D2 F2. 
move: (F1 t rf) (F2 t rf); rewrite /st_image => {F1 F2} F1 F2.
rewrite /cpo_to_poset /val /= /if_bool_prog2. 
rewrite (code_eta (r:=s.1))=>/= a1.
rewrite progE /= /if_bool_sp2 {}F1 {}F2 !code_sup_app.
apply: fext=>p; apply: fext=>y; apply: fext=>m; apply: pext; split.
- case=>i [H3]; case: ifP=>E; case=>[/= H2][_][[_]][[_]][[_]][[_]]
  [[_]][[g]][[e]][H1] E1 <- -> <- -> -> ->;
  case/model_runs=>_ [[<-]] {H2} /= H2; 
  exists (model (code_app (pval 
           (if_bool2 b  (f1 e) (f2 e) s (pf e))) a1) p y m);
  by (split; first by [do ![econstructor; split=>//]];
      rewrite /pval /cpo_to_poset code_beta; exists i; rewrite E -E1).
case=>_ [[_]][[_]][[_]][[_]][[_]][[g]][[e]][H1] -> <- -> <- -> -> ->.
rewrite code_beta; case=>i [/= H2] H3; exists i; split=>//.  
rewrite (_ : rspec_of (f1 (supch rf)) = rspec_of (f1 e)); last by rewrite !D1.
case: ifP H3=>_ H3.
- case/def_runs: (H3)=>D L _; exists (conj L D).
  exists (model (code_app (val (code_of (f1 e))) a1) (single (conj L D)) y m).
  split; first by do 6![econstructor; split=>//]; exists e; case: (f1 e).
  by apply/model_runs; exists i.
rewrite (_ : rspec_of (f2 (supch rf)) = rspec_of (f2 e)); last by rewrite !D2.
case/def_runs: (H3)=>D L _; exists (conj L D)=>/=.
exists (model (code_app (val (code_of (f2 e))) a1) (single (conj L D)) y m).
split; first by do 6![econstructor; split=>//]; exists e; case: (f2 e).
by apply/model_runs; exists i.
Qed.

End SecIfContinuity2.
End IfBool2.

Definition if_bool2 := IfBool2.if_bool2.
Implicit Arguments if_bool2 [As B].

Lemma if_bool_cont2 As As1 (b : funtp As bool) B B1 
        (s1 : spec As1 B1) (s : spec As B)
        (f1 f2 : STsec s1 -> ST As B)
        (C1 : stcontinuous f1) (C2 : stcontinuous f2)
        (pf : forall e : STsec s1, ifconseq21 As B b (f1 e) (f2 e) s) :
      continuous (fun e => if_bool2 b (f1 e) (f2 e) s (pf e)).
Proof. by apply: IfBool2.if_bool_cont2. Qed.

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

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

(* 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 Apply.
Variables (As : seq Type) (A B : Type) (s : A -> spec As B).
Variables (f : forall x, STsec (s x)). 

Definition apply_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 apply_sp a b (p : ideald (pre_app apply_s.1 (a, b))) y m := 
  exists i, i \In sval p /\ 
    (i, y, m) \In runs_of (code_app (pval (code_of (f a))) b).

Lemma apply_dcont a (b : args As) : coherent (@apply_sp a b).
Proof.
move=>[q H] x m; split; case=>i [/= H1]. 
- by exists i; exists H1; exists i.
by case=>_ [[<-]] L; exists i.
Qed.

Lemma apply_dstrict a (b : args As) : def_strict (@apply_sp a b).
Proof. by move=>q y [i][/= H]; case/def_runs. Qed.

Definition apply_prog := 
  code_lam (fun a : args [:: A & As] => 
    Prog (@apply_dcont a.1 a.2) (@apply_dstrict a.1 a.2)).

Lemma apply_has_spec : apply_prog \In has_spec apply_s.
Proof.
move=>/= [a1 b1][a2 b2][i1 i2][y1 y2][m1 m2] /=. 
rewrite !code_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 apply : STsec apply_s := @bundle (LST apply_s) _ apply_has_spec.

End Apply.

(* we have the opposite coercion as well *)
(* 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) (s : A -> spec As B).
Variables (e : STsec (apply_s s)).

Program 
Definition funcof : forall x, STsec (s x) := 
  fun x => Do (e @@ (fun_lam (fun a => (x, a)))).
Next Obligation.
case E: (s x)=>[p q]; split=>[a|a1 a2] /=.
- by move=>i H D; rewrite /safe instE /= instE /= !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 instE !post_beta !fun_beta E /=.
by apply.
Qed.

End FuncOf.