(** * The kernel of our verifier: the abstract programming language *)

Require Import Assertions.
Require Import Atoms.

(** ** Abstract syntax of [kernel] *)
Inductive kernel: Type :=
 | Kle_iter (n:nat) (label: option alabel) (body last next: kernel)
 | Kgjoin (min max:Z) (pf: Z -> kernel) (* generalization of join *)
 | Kiat (inst: atom)
 | Kseq (pf pn:kernel)
 | Kjoin (pl pr:kernel)  (* no convex-hull, use too powerful "\/" instead ! *)
 | Kjoinch (pl pr: kernel) (convexhull: assertion) (* to be emulate "real examples" *)
 | Kloop (body:kernel) (inv: assertion)
 | Kclone (x:var) (body:kernel)
 | Kdeflabel (label: alabel) (res:Z) (p: kernel) (* set the value of a label *)
 | Kbranch2 (label: alabel) (p: bool -> kernel)  (* read the value of a label as a boolean *) 
 | Kbranch (label: alabel) (p: Z -> kernel).     (* read the value of a label as an integer  *) 

(** ** Kernel concrete semantics *)

Fixpoint Kwlp_iter (n:nat) (k: (state-> Prop) -> state -> Prop) (post: state-> Prop) (s:state) :=
  match n with
  | O => post s
  | (S n) => Kwlp_iter n k (k post) s 
  end.

Fixpoint Kwlp_le_iter (n:nat) (k: (state-> Prop) -> state -> Prop) (post: state-> Prop) (s:state) :=
  match n with
  | O => post s
  | (S n) => Kwlp_le_iter n k post s /\ Kwlp_iter (S n) k post s 
  end.

Fixpoint Kwlp (p: kernel) (post: state-> Prop) (s:state) {struct p}: Prop :=
  match p with
  | Kle_iter n _ body last next => 
      Kwlp_le_iter n (Kwlp body) (Kwlp next post) s
      /\ Kwlp_iter (S n) (Kwlp body) (Kwlp last post) s
  | Kgjoin min max pf => forall z, min <= z <= max -> Kwlp (pf z) post s  
  | Kiat inst => awlp inst post s
  | Kseq pf pn => Kwlp pf (Kwlp pn post) s
  | Kjoin pl pr => (Kwlp pl post s) /\ (Kwlp pr post s)
  | Kjoinch pl pr _ => (Kwlp pl post s) /\ (Kwlp pr post s)
  | Kloop body _ => 
    exists inv: state->Prop, 
        (inv s) 
     /\ (forall s', inv s' -> Kwlp body inv s')
     /\ (forall s', inv s' -> post s')
  | Kclone x body => Kwlp body (fun s' => post (add (vid x) (s (vid x)) s')) s
  | Kdeflabel _ _ p => Kwlp p post s
  | Kbranch2 _ p => (Kwlp (p true) post s) \/ (Kwlp (p false) post s) 
  | Kbranch l pf => exists z, (labmin l) <= z <= (labmax l) /\ Kwlp (pf z) post s  
 end.

Section Kiter_proofs.

Variable k: (state-> Prop) -> state -> Prop.

Hypothesis k_monotonic: forall (P Q: state -> Prop) s, k P s -> (forall s, P s -> Q s) -> k Q s.

Lemma Kiter_monotonic n: 
   forall (P Q: state -> Prop) s, Kwlp_iter n k P s -> (forall s, P s -> Q s) -> Kwlp_iter n k Q s.
Proof.
  induction n; simpl; firstorder.
Qed.

Hint Resolve Kiter_monotonic: echecker.

Lemma Kle_iter_monotonic n: 
   forall (P Q: state -> Prop) s, Kwlp_le_iter n k P s -> (forall s, P s -> Q s) -> Kwlp_le_iter n k Q s.
Proof.
  induction n; simpl; firstorder eauto with echecker.
Qed.


End Kiter_proofs.

Hint Resolve Kle_iter_monotonic Kiter_monotonic: echecker.

Lemma Kwlp_monotonic p:
  forall (P Q: state -> Prop) s, Kwlp p P s -> 
    (forall s, P s -> Q s) -> Kwlp p Q s.
Proof.
  induction p; simpl; try (intuition (simpl; eauto with echecker; fail)).
  (* Kbranch *)
  firstorder.
  (* loop *)
  firstorder.
Qed.

Hint Resolve Kwlp_monotonic: echecker.  

(** ** [Kangel_wlp] angelic wlp (used for abstraction of concrete terms) *)
Fixpoint Kangel_wlp (p: kernel) (post: state-> Prop) (s:state) {struct p}: Prop :=
  match p with
  | Kclone x body => Kangel_wlp body (fun s' => post (add (vid x) (s (vid x)) s')) s
  | Kiat inst => angel_awlp inst post s
  | Kseq pf pn => Kangel_wlp pf (Kangel_wlp pn post) s
  | Kjoin pl pr => (Kangel_wlp pl post s) \/ (Kangel_wlp pr post s)
  | Kbranch2 _ p => (Kwlp (p true) (fun s => True) s -> Kangel_wlp (p true) post s) /\ (Kwlp (p false) (fun s => True) s -> Kangel_wlp (p false) post s)
  | Kbranch l p => forall z, (labmin l) <= z <= (labmax l) -> Kwlp (p z) (fun s => True) s  -> Kangel_wlp (p z) post s 
  | _ => False (* "unimplemented" abstractions of terms *)
 end.

Lemma Kangel_wlp_monotonic p:
  forall (P Q: state -> Prop) s, Kangel_wlp p P s -> 
    (forall s, P s -> Q s) -> Kangel_wlp p Q s.
Proof.
  induction p; simpl; try (intuition (eauto with angel; fail)).
Qed.

Hint Resolve Kangel_wlp_monotonic: echecker angel.


Lemma Kangel_wlp_duality p :
  forall P s, Kangel_wlp p P s -> ~(Kwlp p (fun s => ~(P s)) s).
Proof.
  induction p; simpl; try (intuition (eauto with angel; fail)).
  (* seq *)
  intros P s H H1.
  eapply (IHp1 _ _ H).
  eapply Kwlp_monotonic; eauto.
  clear H1 H.
  firstorder.
  (* branch2 *)
  intros P s H0. case H0; clear H0; intros H1 H2.
  intro H0; case H0; clear H0.
  intros H0. lapply H1.
  clear H1 H2; firstorder.
  eapply Kwlp_monotonic; eauto.
  intros H0. lapply H2.
  clear H1 H2; firstorder.
  eapply Kwlp_monotonic; eauto.
  (* branch *)
  intros P s H0 H1.
  case H1; clear H1.
  intros z; intuition. 
  case (H z P s); clear H.
  apply H0; intuition.
  eapply Kwlp_monotonic; eauto.
  eapply Kwlp_monotonic; eauto.
Qed.

Require Import Classical_Prop. (* necessary for the following lemma *)

Lemma Kangel_wlp_correctness p R s s':
  Kwlp p R s -> Kangel_wlp p (eq s') s ->  R s'.
Proof.
  intros H H0.
  apply NNPP.
  intros H1.
  apply (Kangel_wlp_duality _ _ _ H0); clear H0.
  eapply Kwlp_monotonic; eauto.
  intros s0 H0 H2; subst.
  tauto.
Qed.



