(** In this file, we develop a logic, based on Hoare logic, for reasoning
    about programs.  This follows the Software Foundations book fairly 
    closely. *)

(** Our big-step semantics for IMP as before, with one minor change noted below. *)
Require Import Arith.
Require Import String.
Require Import Bool.
Set Implicit Arguments.
Local Open Scope string_scope.

Definition var : Type := string.

Inductive aexp : Type := 
| AVar : var -> aexp
| ANum : nat -> aexp
| APlus : aexp -> aexp -> aexp
| AMinus : aexp -> aexp -> aexp
| AMult : aexp -> aexp -> aexp.

Inductive bexp : Type := 
| Bool : bool -> bexp  (* true, false *)
| Eq : aexp -> aexp -> bexp (* a1 == a2 *)
| Lte : aexp -> aexp -> bexp (* a1 <= a2 *)
| And : bexp -> bexp -> bexp (* b1 && b2 *)
| Or : bexp -> bexp -> bexp. (* b1 || b2 *)

Inductive com : Type := 
| Skip : com (* do nothing *)
| Assign : var -> aexp -> com (* x := a *)
| Seq : com -> com -> com (* c1 ; c2 *)
| If : bexp -> com -> com -> com (* if b then c1 else c2 *)
| While : bexp -> com -> com. (* while b do c *)

Definition state : Type := var -> nat.
Definition lookup(x:var)(s:state) : nat := s x.
Definition update(x:var)(v:nat)(s:state) : state := 
  fun y => if string_dec x y then v else s y.

Fixpoint aeval (a:aexp)(s:state) : nat := 
  match a with 
    | AVar x => lookup x s
    | ANum n => n
    | APlus a1 a2 => (aeval a1 s) + (aeval a2 s)
    | AMinus a1 a2 => (aeval a1 s) - (aeval a2 s)
    | AMult a1 a2 => (aeval a1 s) * (aeval a2 s)
  end.

Fixpoint beval (b:bexp)(s:state) : bool := 
  match b with 
    | Bool x => x
    | Eq a1 a2 => 
      if eq_nat_dec (aeval a1 s) (aeval a2 s) then true else false
    | Lte a1 a2 => 
      if le_gt_dec (aeval a1 s) (aeval a2 s) then true else false
    | And b1 b2 => (beval b1 s) && (beval b2 s)
    | Or b1 b2 => (beval b1 s) || (beval b2 s)
  end.

(** I've changed the treatment of [While] here to match Software
    Foundations.  It actually simplifies some of the proofs in here.
    (But you could prove that this semantics is equivalent to the
    unrolling semantics!) *)
Inductive ceval : com -> state -> state -> Prop := 
| Ceval_skip : 
  forall s, ceval Skip s s
| Ceval_assign : 
  forall x a s, ceval (Assign x a) s (update x (aeval a s) s)
| Ceval_seq : 
  forall c1 c2 s1 s2 s3, 
    ceval c1 s1 s2 -> 
    ceval c2 s2 s3 -> 
    ceval (Seq c1 c2) s1 s3
| Ceval_if_true : 
  forall b c1 c2 s1 s2, 
    beval b s1 = true -> 
    ceval c1 s1 s2 -> 
    ceval (If b c1 c2) s1 s2
| Ceval_if_false : 
  forall b c1 c2 s1 s2, 
    beval b s1 = false -> 
    ceval c2 s1 s2 -> 
    ceval (If b c1 c2) s1 s2
| Ceval_while_false : 
  forall b c s, 
    beval b s = false -> 
    ceval (While b c) s s
| Ceval_while_true : 
  forall b c s1 s2 s3, 
    beval b s1 = true -> 
    ceval c s1 s2 -> 
    ceval (While b c) s2 s3 -> 
    ceval (While b c) s1 s3.

(** An [sprop] is a predicate on [state]s *)
Definition sprop := state -> Prop.

(** An [hpct] or Hoare-partial-correctness-triple consists of a 
    pre-condition, a command, and a post-condition.  [hpct P c Q]
    holds when for any states [s1] and [s2] such that [s1] satisfies
    the pre-condition [P], and when we run [c] in [s1] and get 
    state [s2], then the post-condition [Q] holds on the final state.
    Note that this doesn't say anything about commands that may
    diverge. *)
Definition hpct(P:sprop)(c:com)(Q:sprop) := 
  forall s1 s2, P s1 -> ceval c s1 s2 -> Q s2.

(** It's useful to define notation to make this a little more readable.
    Coq let's you define notation in a fairly intuitive way, except for
    guessing the appropriate "level" which determines how tightly the
    notation groups when Coq parses.  Notice also that I've placed the
    notation in a particular scope ([hoare_scope]) so that I can control
    when it should be used.  I need to open the scope (see below) to 
    enable it. *)
Notation "{{ P }} c {{ Q }}" := (hpct P c Q) (at level 70) : hoare_scope.

(** An [htct] or Hoare-total-correctness-triple is the same as a
    partial correctness triple, except that we require that the
    command terminates -- i.e., produces an output state [s2] 
    satisfying [Q] for any input state [s1] satisfying [P]. *)
Definition htct(P:sprop)(c:com)(Q:sprop) := 
  forall s1, P s1 -> exists s2, ceval c s1 s2 /\ Q s2.

Notation "[[ P ]] c [[ Q ]]" := (htct P c Q) (at level 70) : hoare_scope.

(** Open up the [hoare_scope] so that we can use the fancy notation. *)
Local Open Scope hoare_scope.

(** Next, we're going to define some rules for reasoning directly about
    Hoare partial correctness triples.  Note that each one involves a
    relatively simple proof.  But once we have a set of proof rules for
    reasoning about commands, then we can use them directly to reason
    about programs. *)

(** The first rule says that if we run [Skip] in a state satisfying 
    [P], then if we terminate, we get a state satisfying [P]. *)
Lemma hpct_skip P : {{ P }} Skip {{ P }}.
Proof.
  unfold hpct. intros. inversion H0 ; subst. auto.
Qed.

(** Sequencing is pretty straightforward.  If we run [c1] in a state
    satisfying [P] to get a state satisfying [Q], then if [Q] is the
    pre-condition on [c2], we can run it to get a state satisfying
    [c2]'s post-condition [R]. *)
Lemma hpct_seq c1 c2 P Q R : 
  {{ P }} c1 {{ Q }} -> 
  {{ Q }} c2 {{ R }} -> 
  {{ P }} Seq c1 c2 {{ R }}.
Proof.
  unfold hpct. intros. inversion H2 ; subst ; clear H2. eauto.
Qed.

(** The assignment rule is a little funny.  This one is a so-called
    "backwards" rule.  The way to see this is that if we want to 
    run [Assign x a] and end up in a state satisfying [P], then we
    should start in some state [s] such that if we update [s] at [x] 
    with [a]'s value, then [P] holds on the resulting state. *)
Lemma hpct_assign P x a : 
  {{ fun s => P (update x (aeval a s) s) }} 
  Assign x a 
  {{ P }}.
Proof.
  unfold hpct. intros. inversion H0. subst. auto.
Qed.

(** Personally, I find the forwards version of this rule a little
    easier to reason about.  It says when we start in a state [s1]
    satisfying [P], then we end up in a state [s2] such that 
    [s2 = update x (aeval a s1) s1] -- that's literally the semantics
    of the command. *)
Lemma hpct_assign2 P x a : 
  {{ P }} 
  Assign x a
  {{ fun s => exists s', P s' /\ s = update x (aeval a s') s' }}.
Proof.
  unfold hpct. intros. exists s1. inversion H0. auto.
Qed.

(** Here is one possible rule for reasoning about conditionals.
    However, it's not as strong as we can get because it doesn't
    take the boolean expression [b] into account.  That is, this
    is a path-insensitive sort of reasoning rule. *)
Lemma hpct_if_weak b c1 c2 P Q : 
  {{ P }} c1 {{ Q }} -> 
  {{ P }} c2 {{ Q }} -> 
  {{ P }} If b c1 c2 {{ Q }}.
Proof.
  unfold hpct. intros. inversion H2 ; subst ; firstorder.
Qed.

(** In contract, this rule is path-sensitive.  Notice that each
    branch gets to take advantage of the fact that the value of
    the boolean is known. *)
Lemma hpct_if b c1 c2 P Q : 
  {{ fun s => beval b s = true /\ P s }} c1 {{ Q }} -> 
  {{ fun s => beval b s = false /\ P s }} c2 {{ Q }} -> 
  {{ P }} If b c1 c2 {{ Q }}.
Proof.
  unfold hpct. intros. inversion H2 ; subst ; firstorder.
Qed.

(** The [While] rule requires us to find some invariant [I] such
    that [I] holds at the beginning of the loop, and is maintained
    each time we execute the body of the loop.  Afterwards, we can
    conclude [I] still holds, but that the boolean condition is false. 
    Think about both the case where [b] evaluates to false (in which
    case, no state change occurs, so whatever the pre-condition is, it
    must hold for the post-condition too.)  The really hard part of
    any proof using the Hoare rules is coming up with an appropriate
    loop invariant...  (In fact, the rest can be completely automated!)
*)
Lemma hpct_while b c I : 
  {{ fun s => beval b s = true /\ I s }} c {{ I }} -> 
  {{ I }} While b c {{ fun s => beval b s = false /\ I s }}.
Proof.
  unfold hpct. intros. remember (While b c) as c0.
  induction H1 ; try congruence. injection Heqc0 ; intros ; subst ; tauto.
  injection Heqc0. intros ; subst ; clear Heqc0. apply IHceval2.
  eapply H. split ; eauto. auto. auto.
Qed.

(** The rule of consequence is the only rule that's not syntax-
    directed.  It basically says that we can always strengthen 
    the pre-condition, and weaken the post-condition.  It's crucial
    for real reasoning, but figuring out when and where to apply it
    can be tricky when doing proofs by hand. *)
Lemma hpct_consequence c (P1 Q1 P2 Q2:sprop) : 
  {{ P1 }} c {{ Q1 }} -> 
  (forall s, P2 s -> P1 s) -> 
  (forall s, Q1 s -> Q2 s) -> 
  {{ P2 }} c {{ Q2 }}.
Proof.
  unfold hpct. intros. firstorder.
Qed.

(** This rule is a specialization of consequence that allows us
    to strengthen the pre-condition. *)
Lemma hpct_pre (P1 P2 Q:sprop) c : 
  (forall s, P2 s -> P1 s) -> 
  {{ P1 }} c {{ Q }} -> 
  {{ P2 }} c {{ Q }}.
Proof.
  intros. apply (@hpct_consequence c P1 Q P2 Q) ; auto. 
Qed.

(** And this one allows us to weaken the post-condition. *)
Lemma hpct_post (Q1 P Q2:sprop) c : 
  (forall s, Q1 s -> Q2 s) -> 
  {{ P }} c {{ Q1 }} -> 
  {{ P }} c {{ Q2 }}.
Proof.
  intros. apply (@hpct_consequence c P Q1 P Q2) ; auto.
Qed.
  
(** Now let's use the rules to try to prove that our factorial
    command is correct. *)
Definition fact_com := 
  Seq (Assign "x" (ANum 1))
      (While (Lte (ANum 1) (AVar "n"))
        (Seq (Assign "x" (AMult (AVar "x") (AVar "n")))
             (Assign "n" (AMinus (AVar "n") (ANum 1))))).
             
(** To begin with, we need some notion of correctness!  So we'll
    write a functional version of factorial to use in our specification.
    In some sense, verification is a sort of n-version programming,
    so if I screw up this definition and the imperative code in the
    same way, we could end up successfully proving nonsense... *)
Fixpoint fact(n:nat) : nat := 
  match n with 
    | 0 => 1
    | S n => (S n) * (fact n)
  end.

(** The [omega] tactic is useful for solving some arithmetic problems. 
    We're going to need this in our reasoning below. *)
Require Import Omega.  

(** Okay, here is our main lemma:  It says that if we start in a state where
    the variable [n] is equal to the value [m] and run [fact_com], then we
    end up in a state where the variable [x] is equal to [fact m]. *)
Lemma fact_corr m : {{ fun s => s "n" = m }} fact_com {{ fun s => s "x" = fact m }}.
Proof.
  (** Annoyingly, we will need this... *)
  Lemma minus_zero n : n - 0 = n.
    omega.
  Qed.
  
  (** Another helper lemma. *)
  Lemma beval_lte s b : beval (Lte (ANum 1) (AVar "n")) s = b -> 
    if b then 1 <= s "n" else 1 > s "n".
  Proof.
    intros.
    assert (beval (Lte (ANum 1) (AVar "n")) s = if le_gt_dec 1 (s "n") then true else false).
    auto. rewrite H in H0. rewrite H0. destruct (le_gt_dec 1 (s "n")) ; auto. 
  Qed.
  
  (** A useful fact about factorial.  Notice that it only holds when [n > 0]. *)
  Lemma fact_unroll n : n > 0 -> n * fact (n - 1) = fact n.
  Proof. 
    induction n ; simpl ; intros. assert False ; [ omega | contradiction ].
    rewrite minus_zero. auto.
  Qed.

  (** A little tactic which breaks apart conjunctions and existentials in
     our hypotheses, and simplifies evaluation of our boolean loop guard. *)
  Ltac des := 
    match goal with 
      | [ H : _ /\ _ |- _ ] => destruct H
      | [ H : exists _, _ |- _] => destruct H
      | [ H : beval (Lte (ANum 1) (AVar "n")) ?s = ?b |- _ ] => 
        generalize (beval_lte s H) ; clear H ; intro H
    end.

  (** unfold the definition of [fact_com] *)
  unfold fact_com. 
  (** strengthen the pre-condition by adding "1 = 1" -- why?  See below. *)
  apply (hpct_pre (P1 := fun s => s "n" = m /\ 1 = 1)) ; auto.
  (** use the [hpct_seq] rule to reason about the two commands at the top-level. *)
  apply (hpct_seq (Q := fun s => s "n" = m /\ s "x" = 1)).
  (** to use the [hpct_assign] rule, we must find an appropriate [P].  Notice that
      if you substitute [1] for the variable [x], then you get back our pre-condition. *)
  apply (@hpct_assign (fun s => s "n" = m /\ s "x" = 1) "x" (ANum 1)). 
  (** Once again, strengthen the pre-condition.  This time, we're trying to set up a loop
      invariant.  I've chosen a loop invariant that asserts there's some [i], less than [m]
      such that the current value of [n] is [m-i], and [x * (fact (m - i)) = fact m].  It
      took me a while to figure out the right invariant so that (a) it really was an 
      invariant, and (b) it was strong enough to prove our desired post-condition -- that
      [x] holds [fact m] when the our condition evaluates to false. *)
  apply (hpct_pre (P1 := fun s => exists i, i <= m /\ s "n" = m - i /\ s "x" * fact (m - i) = fact m)).
  (** Discharge the strengthening argument. *)
  intros. exists 0. des. rewrite H. rewrite H0. rewrite minus_zero. omega.
  (** Weaken the post-condition -- it's basically our loop invariant plus the fact that
      our loop condition evaluated to false. *)
  apply (hpct_post (Q1 := fun s => beval (Lte (ANum 1) (AVar "n")) s = false /\ 
    exists i, i <= m /\ s "n" = m - i /\ s "x" * fact (m - i) = fact m)).
  (** Discharge the weakening argument. *)
  intros. repeat des. assert (m - x = 0). omega. rewrite H3 in H2. simpl in H2. omega.
  (** Now we are set up with an invariant and can use the [hpct_while] rule. *)
  apply hpct_while.
  (** Here, I'm using [eapply hpct_seq] so that Coq will put in a constraint variable for
      the unknown predicate describing the intermediate state. *)
  eapply hpct_seq.
  (** By using the "forwards" assignment rule, I can get Coq to solve for the unknown predicate. *)
  eapply hpct_assign2.
  (** I'm going to use the forwards assignment rule again.  But I will need to weaken the post-
      condition.  So again, I use [eapply] to "guess" the right post-condition. *)
  eapply hpct_post.
  (** Now I'm going to jump to the second goal and use the forwards assignment rule to 
      constrain the predicate automatically. *)
  Focus 2.
  eapply hpct_assign2.
  (** So we are left showing this beast, which is a pure logical statement not involving
      commands, is true. We'll start by simplifying things, and tearing them apart... *)
  intros. destruct H. repeat des. subst.
  (** We have to determine the new [i] for the next iteration of the loop.  A good guess is 
      [1 + i] or [S i] (the successor of i.) *)
  exists (S x1). 
  (** Do some simplifying and rewriting. *)
  simpl. unfold lookup, update. simpl. rewrite H3.
  (** Omega can knock off the first two conjuncts for us... *)
  split. omega. split. omega. rewrite <- H4.
  (** Sadly, it's too stupid to prove this fact for us, so we have to jump through some hoops. *)
  assert ((m - x1) * fact ((m - x1) - 1) = fact (m - x1)).
  (** Our unrolling lemma for [fact] comes into play here.  At least [omega] can knock off the
      requirement that [m - x1 > 0]. *)
  rewrite fact_unroll ; auto ; omega. rewrite <- H0. 
  (** Omega is still too stupid to prove this.  Grr. *)
  assert (m - S x1 = m - x1 - 1). omega.
  rewrite H1. 
  (** And believe it or not, it's still too stupid! *)
  rewrite <- mult_assoc. 
  (** Finally.  Bottom line -- Coq needs better arithmetic support! To be fair, if we used 
      Z (integers) the proof would be easier.  The "funky" definition of subtraction on [nat]
      messes a lot of reasoning up, making the tactics rather conservative. *)
  auto.
Qed.

(** Exercises:

   - Prove that [{{ P }} c {{ fun s => True }}] holds for any command [c] and pre-condition [P].
   - Prove that [{{ False }} c {{ Q }}] holds for any command [c] and post-condition [Q].
   - Prove [{{ True }} While (Bool true) Skip {{ fun s => False }}].
   - Add a "do" loop to commands and formulate an appropriate Hoare rule for it.
   - Write a command to sum the numbers from 0 to n and use the Hoare rules to prove it correct.

*)