Set Automatic Coercions Import.
Require Import ssreflect ssrbool ssrnat eqtype seq ssrfun.
Require Import heaps rels hprop stmod stsep stlog. 
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(**********************************************************)
(* First, the reflection mechanism for search-and-replace *)
(* pattern-matching on heap expressions.                  *)
(**********************************************************)

Structure tagged_heap := Tag {untag :> heap}.

Definition right_tag := Tag.
Definition left_tag := right_tag.
Canonical Structure found_tag i := left_tag i.

Definition form_axiom k r (h : tagged_heap) := untag h = k :+ r.

Structure form (k r : heap) :=
  Form {heap_of :> tagged_heap; 
        _ : form_axiom k r heap_of}.

Implicit Arguments Form [].

Lemma formE r k (f : form k r) : untag f = k :+ r.
Proof. by case: f=>[[j]] /=; rewrite /form_axiom /= => ->. Qed.

Lemma found_pf k : form_axiom k empty (found_tag k). 
Proof. by rewrite /form_axiom unh0. Qed.
 
Canonical Structure heap_found k := Form k empty (found_tag k) (found_pf k).

Lemma left_pf h r (f : forall k, form k r) k : 
        form_axiom k (r :+ h) (left_tag (f k :+ h)).
Proof. by rewrite formE /form_axiom /= unA. Qed.

Canonical Structure search_left h r (f : forall k, form k r) k :=
  Form k (r :+ h) (left_tag (f k :+ h)) (left_pf h f k).

Lemma right_pf h r (f : forall k, form k r) k :
        form_axiom k (h :+ r) (right_tag (h :+ f k)).
Proof. by rewrite formE /form_axiom /= unCA. Qed.

Canonical Structure search_right h r (f : forall k, form k r) k := 
  Form k (h :+ r) (right_tag (h :+ f k)) (right_pf h f k).

(*********************)
(* Reflective lemmas *)
(*********************)

Notation cont A := (ans A -> heap -> Prop).

Section EvalDoR.
Variables (A B : Type).

Lemma val_doR (s : spec A) i j (f : forall k, form k j) (r : cont A) :
         s.1 i -> 
         (forall x m, s.2 (Val x) i m -> def (f m) -> r (Val x) (f m)) ->
         (forall e m, s.2 (Exn e) i m -> def (f m) -> r (Exn e) (f m)) -> 
         verify (f i) s r.
Proof.
move=>H1 H2 H3; rewrite formE; apply: (val_do H1).
- by move=>x m; move: (H2 x m); rewrite formE.
by move=>x m; move: (H3 x m); rewrite formE.
Qed.

Lemma try_doR (s : spec A) s1 s2 i j (f : forall k, form k j) (r : cont B) : 
        s.1 i -> 
        (forall x m, s.2 (Val x) i m -> verify (f m) (s1 x) r) ->
        (forall e m, s.2 (Exn e) i m -> verify (f m) (s2 e) r) ->
        verify (f i) (try_s s s1 s2) r.
Proof.
move=>H1 H2 H3; rewrite formE; apply: (try_do H1).
- by move=>x m; move: (H2 x m); rewrite formE.
by move=>x m; move: (H3 x m); rewrite formE.
Qed.

Lemma bnd_doR (s : spec A) s2 i j (f : forall k, form k j) (r : cont B) : 
        s.1 i -> 
        (forall x m, s.2 (Val x) i m -> verify (f m) (s2 x) r) -> 
        (forall e m, s.2 (Exn e) i m -> def (f m) -> r (Exn e) (f m)) ->
        verify (f i) (bind_s s s2) r.
Proof.
move=>H1 H2 H3; rewrite formE; apply: (bnd_do H1).
- by move=>x m; move: (H2 x m); rewrite formE.
by move=>x m; move: (H3 x m); rewrite formE.
Qed.

End EvalDoR.

(* ret lemmas need no reflection, as they operate on any heap; still *)
(* rename them for uniformity *)

Definition val_retR := val_ret.
Definition try_retR := try_ret.
Definition bnd_retR := bnd_ret.

Section EvalReadR.
Variables (A B : Type).

Lemma val_readR v x i (f : form (x :-> v) i) (r : cont A) : 
        (def f -> r (Val v) f) -> 
        verify f (read_s A x) r.
Proof. by rewrite formE; apply: val_read. Qed.
 
Lemma try_readR s1 s2 v x i (f : form (x :-> v) i) (r : cont B) : 
        verify f (s1 v) r -> 
        verify f (try_s (read_s A x) s1 s2) r. 
Proof. by rewrite formE; apply: try_read. Qed.

Lemma bnd_readR s v x i (f : form (x :-> v) i) (r : cont B) : 
        verify f (s v) r -> 
        verify f (bind_s (read_s A x) s) r.
Proof. by rewrite formE; apply: bnd_read. Qed. 

End EvalReadR.

Section EvalWriteR. 
Variables (A B C : Type).

Lemma val_writeR (v : A) (w : B) x i (f : forall k, form k i) (r : cont unit) : 
        (def (f (x :-> v)) -> r (Val tt) (f (x :-> v))) -> 
        verify (f (x :-> w)) (write_s x v) r.
Proof. by rewrite !formE; apply: val_write. Qed.

Lemma try_writeR s1 s2 (v : A) (w : C) x i 
                 (f : forall k, form k i) (r : cont B) : 
        verify (f (x :-> v)) (s1 tt) r -> 
        verify (f (x :-> w)) (try_s (write_s x v) s1 s2) r. 
Proof. rewrite !formE; apply: try_write. Qed.

Lemma bnd_writeR s (v : A) (w : C) x i (f : forall k, form k i) (r : cont B) : 
        verify (f (x :-> v)) (s tt) r -> 
        verify (f (x :-> w)) (bind_s (write_s x v) s) r. 
Proof. by rewrite !formE; apply: bnd_write. Qed.

End EvalWriteR.

Definition val_allocR := val_alloc.
Definition try_allocR := try_alloc.
Definition bnd_allocR := bnd_alloc.
Definition val_allocbR := val_allocb.
Definition try_allocbR := try_allocb.
Definition bnd_allocbR := bnd_allocb.

Section EvalDeallocR.
Variables (A B : Type).

Lemma val_deallocR (v : A) x i (f : forall k, form k i) (r : cont unit) : 
        (def (f empty) -> r (Val tt) (f empty)) -> 
        verify (f (x :-> v)) (dealloc_s x) r.
Proof. by rewrite !formE un0h; apply: val_dealloc. Qed.

Lemma try_deallocR s1 s2 (v : B) x i (f : forall k, form k i) (r : cont A) :
        verify (f empty) (s1 tt) r -> 
        verify (f (x :-> v)) (try_s (dealloc_s x) s1 s2) r.
Proof. by rewrite !formE un0h; apply: try_dealloc. Qed.

Lemma bnd_deallocR s (v : B) x i (f : forall k, form k i) (r : cont A) : 
        verify (f empty) (s tt) r -> 
        verify (f (x :-> v)) (bind_s (dealloc_s x) s) r.
Proof. by rewrite !formE un0h; apply: bnd_dealloc. Qed.

End EvalDeallocR.

Definition val_throwR := val_throw.
Definition try_throwR := try_throw. 
Definition bnd_throwR := bnd_throw.

(* specialized versions of do lemmas, to handle ghost variables. *)

Section EvalGhostR.
Variables (A B C : Type) (t : C) (p : C -> Pred heap) (q : C -> post A).
Variables (s1 : A -> spec B) (s2 : exn -> spec B) (i j : heap).
Variables (f : forall k, form k j) (P : Pred heap).

Lemma val_ghR (r : cont A) : 
        let: s := (fun i => exists x, i \In p x, 
                   fun y i m => forall x, i \In p x -> q x y i m) in 
        (forall x m, q t (Val x) i m -> def (f m) -> r (Val x) (f m)) ->
        (forall e m, q t (Exn e) i m -> def (f m) -> r (Exn e) (f m)) ->            
        i \In p t -> 
        verify (f i) s r.
Proof. 
move=>H1 H2; rewrite formE; apply: val_gh.
- by move=>x m; move: (H1 x m); rewrite formE.
by move=>x m; move: (H2 x m); rewrite formE.
Qed.

Lemma val_gh1R (r : cont A) : 
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in 
        (i \In p t -> P i) -> 
        (forall x m, q t (Val x) i m -> def (f m) -> r (Val x) (f m)) -> 
        (forall e m, q t (Exn e) i m -> def (f m) -> r (Exn e) (f m)) ->            
        i \In p t ->
        verify (f i) (P, Q) r.
Proof.
move=>H1 H2 H3; rewrite formE; apply: (val_gh1 H1).
- by move=>x m; move: (H2 x m); rewrite formE.
by move=>x m; move: (H3 x m); rewrite formE.
Qed.

Lemma try_ghR (r : cont B) : 
        let: s := (fun i => exists x, i \In p x, 
                   fun y i m => forall x, i \In p x -> q x y i m) in 
        (forall x m, q t (Val x) i m -> verify (f m) (s1 x) r) ->
        (forall e m, q t (Exn e) i m -> verify (f m) (s2 e) r) ->
        i \In p t -> 
        verify (f i) (try_s s s1 s2) r.
Proof.
move=>H1 H2; rewrite formE; apply: try_gh.
- by move=>x m; move: (H1 x m); rewrite formE.
by move=>x m; move: (H2 x m); rewrite formE.
Qed.

Lemma try_gh1R (r : cont B) : 
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in 
        (i \In p t -> P i) -> 
        (forall x m, q t (Val x) i m -> verify (f m) (s1 x) r) ->
        (forall e m, q t (Exn e) i m -> verify (f m) (s2 e) r) ->
        i \In p t -> 
        verify (f i) (try_s (P, Q) s1 s2) r.
Proof.
move=>H1 H2 H3; rewrite formE; apply: (try_gh1 H1).
- by move=>x m; move: (H2 x m); rewrite formE.
by move=>x m; move: (H3 x m); rewrite formE.
Qed.

Lemma bnd_ghR (r : cont B) : 
        let: s := (fun i => exists x, i \In p x, 
                   fun y i m => forall x, i \In p x -> q x y i m) in 
        (forall x m, q t (Val x) i m -> verify (f m) (s1 x) r) -> 
        (forall e m, q t (Exn e) i m -> def (f m) -> r (Exn e) (f m)) ->
        i \In p t ->
        verify (f i) (bind_s s s1) r.
Proof.
move=>H1 H2; rewrite formE; apply: bnd_gh.
- by move=>x m; move: (H1 x m); rewrite formE.
by move=>x m; move: (H2 x m); rewrite formE.
Qed.

Lemma bnd_gh1R (r : cont B) : 
        let: Q := fun y i m => forall x, i \In p x -> q x y i m in 
        (i \In p t -> P i) ->
        (forall x m, q t (Val x) i m -> verify (f m) (s1 x) r) -> 
        (forall e m, q t (Exn e) i m -> def (f m) -> r (Exn e) (f m)) ->
        i \In p t -> 
        verify (f i) (bind_s (P, Q) s1) r.
Proof.
move=>H1 H2 H3; rewrite formE; apply: (bnd_gh1 H1).
- by move=>x m; move: (H2 x m); rewrite formE.
by move=>x m; move: (H3 x m); rewrite formE.
Qed.

End EvalGhostR.

(****************************************************)
(* Automating the selection of which lemma to apply *)
(* (reflective implementation of the hstep tactic)  *)
(****************************************************)

(* Need to case-split on bnd_, try_, or a val_ lemma. *)
(* Hence, three classes of canonical structures.      *)

Structure val_form A i r (p : Prop):=
  ValForm {val_pivot :> spec A;
           _ : p -> verify i val_pivot r}.

Structure bnd_form A B i (s : A -> spec B) r (p : Prop) :=
  BndForm {bnd_pivot :> spec A;
           _ : p -> verify i (bind_s bnd_pivot s) r}.

Structure try_form A B i (s1 : A -> spec B) 
                         (s2 : exn -> spec B) r (p : Prop) :=
  TryForm {try_pivot :> spec A;
           _ : p -> verify i (try_s try_pivot s1 s2) r}.

(* The main lemma which triggers the selection. *)

Lemma hstep A i (r : cont A) p (e : val_form i r p) :
        p -> verify i e r.
Proof. by case:e=>[?]; apply. Qed.

(* First check if matching on bnd_ or try_. If so, switch to searching *)
(* for bnd_ or try_form, respectively. Otherwise, fall through, and    *)
(* continue searching for a val_form. *)

Lemma bnd_case_pf A B i (s : A -> spec B) r p (e : bnd_form i s r p) :
        p -> verify i (bind_s e s) r.
Proof. by case:e=>[?]; apply. Qed.

Canonical Structure 
  bnd_case_form A B i (s : A -> spec B) r p (e : bnd_form i s r p) := 
  ValForm (bnd_case_pf e).

Lemma try_case_pf A B i (s1 : A -> spec B) (s2 : exn -> spec B) r p
                        (e : try_form i s1 s2 r p) : 
        p -> verify i (try_s e s1 s2) r.
Proof. by case:e=>[?]; apply. Qed.

(* After that, find the form in the following list.  Notice that the list *)
(* can be extended arbitrarily in the future. There is no centralized     *)
(* tactic to maintain. *)

Canonical Structure val_ret_form A v i r := 
  ValForm (@val_retR A v i r).
Canonical Structure bnd_ret_form A B s v i r := 
  BndForm (@bnd_retR A B s v i r).
Canonical Structure try_ret_form A B s1 s2 v i r :=
  TryForm (@try_retR A B s1 s2 v i r).

Canonical Structure val_read_form A v x r j f := 
  ValForm (@val_readR A v x j f r).
Canonical Structure bnd_read_form A B s v x r j f := 
  BndForm (@bnd_readR A B s v x j f r).
Canonical Structure try_read_form A B s1 s2 v x r j f := 
  TryForm (@try_readR A B s1 s2 v x j f r).  

Canonical Structure val_write_form A B v w x r j f := 
  ValForm (@val_writeR A B v w x j f r).
Canonical Structure bnd_write_form A B C s v w x r j f := 
  BndForm (@bnd_writeR A B C s v w x j f r).
Canonical Structure try_write_form A B C s1 s2 v w x r j f := 
  TryForm (@try_writeR A B C s1 s2 v w x j f r).

Canonical Structure val_alloc_form A v i r := 
  ValForm (@val_allocR A v i r).
Canonical Structure bnd_alloc_form A B s v i r := 
  BndForm (@bnd_allocR A B s v i r).
Canonical Structure try_alloc_form A B s1 s2 v i r := 
  TryForm (@try_allocR A B s1 s2 v i r).

Canonical Structure val_allocb_form A v n i r := 
  ValForm (@val_allocbR A v n i r).
Canonical Structure bnd_allocb_form A B s v n i r := 
  BndForm (@bnd_allocbR A B s v n i r).
Canonical Structure try_allocb_form A B s1 s2 v n i r := 
  TryForm (@try_allocbR A B s1 s2 v n i r).

Canonical Structure val_dealloc_form A v x r j f := 
  ValForm (@val_deallocR A v x j f r).
Canonical Structure bnd_dealloc_form A B s v x r j f := 
  BndForm (@bnd_deallocR A B s v x j f r).
Canonical Structure try_dealloc_form A B s1 s2 v x r j f := 
  TryForm (@try_deallocR A B s1 s2 v x j f r).

(* we still keep one tactic to kill final goals, which *)
(* are usually full of existentials *)
Ltac vauto := (do ?econstructor=>//).

Ltac step := (apply: hstep=>/=).

