(*
 * Copyright (C) 2014 NICTA
 * All rights reserved.
 *)

(* Author: David Cock - David.Cock@nicta.com.au *)

header "Expectations"

theory Expectations imports Misc begin

text_raw {* \label{s:expectations} *}

type_synonym 's expect = "'s \<Rightarrow> real"

text {* Expectations are a real-valued generalisation of boolean predicates: An expectation on state
@{typ 's} is a function @{typ "'s \<Rightarrow> real"}. A predicate @{term P} on @{typ 's} is embedded as an
expectation by mapping @{term True} to 1 and @{term False} to 0.  Under this embedding, implication
becomes comparison, as the truth tables demonstrate:
\begin{center}
\begin{tabular}{ccc|ccc}
$a$ & $b$ & $a \rightarrow b$ & $x$ & $y$ & $x \le y$ \\
 F  &  F  &  T                &  0  &  0  &  T \\
 F  &  T  &  T                &  0  &  1  &  T \\
 T  &  F  &  F                &  1  &  0  &  F \\
 T  &  T  &  T                &  1  &  1  &  T
\end{tabular}
\end{center}

\begin{figure}
\begin{center}
\mbox{
\xymatrix{
*++[o][F=]{b} & & *++[o][F=]{c} \\
  & *++[o][F-]{a} \ar[ul]^{0.7} \ar[ur]_{0.3} \\
  & \ar[u]
}
}
\end{center}
\caption{\label{f:automaton_1}A probabilistic automaton}
\end{figure}

For probabilistic automata, an expectation gives the current expected value of some expression, if
it were to be evaluated in the final state. For example, consider the automaton of
\autoref{f:automaton_1}, with transition probabilities affixed to edges. Let $P\ b = 2.0$ and $P\ c
= 3.0$. Both states $b$ and $c$ are final (accepting) states, and thus the `final expected value' of
$P$ in state $b$ is $2.0$ and in state $c$ is $3.0$. The expected value from state $a$ is the
weighted sum of these, or $0.7 \times 2.0 + 0.3 \times 3.0 = 2.3$.

All expectations must be non-negative and bounded i.e. $\forall s.~0 \le P\ s$ and $\exists b.
\forall s. P\ s \le b$. Note that although every expectation must have a bound, there is no bound on
all expectations; In particular, the following series has no global bound, although each element is
clearly bounded:
\begin{displaymath}
P_i = \lambda s.\ i\quad\text{where}\ i \in \mathbb{N}
\end{displaymath}
*}

subsection {* Bounded Functions *}

definition bounded_by :: "real \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> bool"
where     "bounded_by b P \<equiv> \<forall>x. P x \<le> b"

text {* By instantiating the classical reasoner, both establishing and appealing to boundedness
is largely automatic. *}

lemma bounded_byI[intro]:
  "\<lbrakk> \<And>x. P x \<le> b \<rbrakk> \<Longrightarrow> bounded_by b P"
  by (simp add:bounded_by_def)

lemma bounded_byI2[intro]:
  "P \<le> (\<lambda>s. b) \<Longrightarrow> bounded_by b P"
  by (blast dest:le_funD)

lemma bounded_byD[dest]:
  "bounded_by b P \<Longrightarrow> P x \<le> b"
  by (simp add:bounded_by_def)

lemma bounded_byD2[dest]:
  "bounded_by b P \<Longrightarrow> P \<le> (\<lambda>s. b)"
  by (blast intro:le_funI)

text {* A function is bounded if there exists at least one upper bound on it. *}

definition bounded :: "('a \<Rightarrow> real) \<Rightarrow> bool"
where     "bounded P \<equiv> (\<exists>b. bounded_by b P)"

text {* In the reals, if there exists any upper bound, then there must exist a least upper bound. *}

definition bound_of :: "('a \<Rightarrow> real) \<Rightarrow> real"
where     "bound_of P \<equiv> Sup (P ` UNIV)"

lemma bounded_bdd_above[intro]:
  assumes bP: "bounded P"
  shows "bdd_above (range P)"
proof
  fix x assume "x \<in> range P"
  with bP show "x \<le> Inf {b. bounded_by b P}"
    unfolding bounded_def by(auto intro:cInf_greatest)
qed

text {* The least upper bound has the usual properties: *}
lemma bound_of_least[intro]:
  assumes bP: "bounded_by b P"
  shows "bound_of P \<le> b"
  unfolding bound_of_def
  using bP by(intro cSup_least, auto)

lemma bounded_by_bound_of[intro!]:
  fixes P::"'a \<Rightarrow> real"
  assumes bP: "bounded P"
  shows "bounded_by (bound_of P) P"
  unfolding bound_of_def
  using bP by(intro bounded_byI cSup_upper bounded_bdd_above, auto)

lemma bound_of_greater[intro]:
  "bounded P \<Longrightarrow> P x \<le> bound_of P"
  by (blast intro:bounded_byD)

lemma bounded_by_mono:
  "\<lbrakk> bounded_by a P; a \<le> b \<rbrakk> \<Longrightarrow> bounded_by b P"
  unfolding bounded_by_def by(blast intro:order_trans)

lemma bounded_by_imp_bounded[intro]:
  "bounded_by b P \<Longrightarrow> bounded P"
  unfolding bounded_def by(blast)

text {* This is occasionally easier to apply: *}

lemma bounded_by_bound_of_alt:
  "\<lbrakk> bounded P; bound_of P = a \<rbrakk> \<Longrightarrow> bounded_by a P"
  by (blast)

lemma bounded_const[simp]:
  "bounded (\<lambda>x. c)"
  by (blast)

lemma bounded_by_const[intro]:
  "c \<le> b \<Longrightarrow> bounded_by b (\<lambda>x. c)"
  by (blast)

lemma bounded_by_mono_alt[intro]:
  "\<lbrakk> bounded_by b Q; P \<le> Q \<rbrakk> \<Longrightarrow> bounded_by b P"
  by (blast intro:order_trans dest:le_funD)

lemma bound_of_const[simp, intro]:
  "bound_of (\<lambda>x. c) = (c::real)"
  unfolding bound_of_def
  by(intro antisym cSup_least cSup_upper bounded_bdd_above bounded_const, auto)

lemma bound_of_leI:
  assumes "\<And>x. P x \<le> (c::real)"
  shows "bound_of P \<le> c"
  unfolding bound_of_def
  using assms by(intro cSup_least, auto)

lemma bound_of_mono[intro]:
  "\<lbrakk> P \<le> Q; bounded P; bounded Q \<rbrakk> \<Longrightarrow> bound_of P \<le> bound_of Q"
  by (blast intro:order_trans dest:le_funD)

lemma bounded_by_o[intro,simp]:
  "\<And>b. bounded_by b P \<Longrightarrow> bounded_by b (P o f)"
  unfolding o_def by(blast)

lemma le_bound_of[intro]:
  "\<And>x. bounded f \<Longrightarrow> f x \<le> bound_of f"
  by(blast)

subsection {* Non-Negative Functions. *}

text {* The definitions for non-negative functions are analogous to those for bounded functions. *}

definition
  nneg :: "('a \<Rightarrow> 'b::{zero,order}) \<Rightarrow> bool"
where
  "nneg P \<longleftrightarrow> (\<forall>x. 0 \<le> P x)"

lemma nnegI[intro]:
  "\<lbrakk> \<And>x. 0 \<le> P x \<rbrakk> \<Longrightarrow> nneg P"
  by (simp add:nneg_def)

lemma nnegI2[intro]:
  "(\<lambda>s. 0) \<le> P \<Longrightarrow> nneg P"
  by (blast dest:le_funD)

lemma nnegD[dest]:
  "nneg P \<Longrightarrow> 0 \<le> P x"
  by (simp add:nneg_def)

lemma nnegD2[dest]:
  "nneg P \<Longrightarrow> (\<lambda>s. 0) \<le> P"
  by (blast intro:le_funI)

lemma nneg_bdd_below[intro]:
  "nneg P \<Longrightarrow> bdd_below (range P)"
  by(auto)

lemma nneg_const[iff]:
  "nneg (\<lambda>x. c) \<longleftrightarrow> 0 \<le> c"
  by (simp add:nneg_def)

lemma nneg_o[intro,simp]:
  "nneg P \<Longrightarrow> nneg (P o f)"
  by (force)

lemma nneg_bound_nneg[intro]:
  "\<lbrakk> bounded P; nneg P \<rbrakk> \<Longrightarrow> 0 \<le> bound_of P"
  by (blast intro:order_trans)

lemma nneg_bounded_by_nneg[dest]:
  "\<lbrakk> bounded_by b P; nneg P \<rbrakk> \<Longrightarrow> 0 \<le> (b::real)"
  by (blast intro:order_trans)

lemma bounded_by_nneg[dest]:
  fixes P::"'s \<Rightarrow> real"
  shows "\<lbrakk> bounded_by b P; nneg P \<rbrakk> \<Longrightarrow> 0 \<le> b"
  by (blast intro:order_trans)

subsection {* Sound Expectations *}

definition sound :: "('s \<Rightarrow> real) \<Rightarrow> bool"
where "sound P \<equiv> bounded P \<and> nneg P"

text {* Combining @{term nneg} and @{term bounded}, we have @{term sound} expectations. We set up
the classical reasoner and the simplifier, such that showing soundess, or deriving a simple
consequence (e.g. @{term "sound P \<Longrightarrow> 0 \<le> P s"}) will usually follow by blast, force or simp. *}

lemma soundI:
  "\<lbrakk> bounded P; nneg P \<rbrakk> \<Longrightarrow> sound P"
  by (simp add:sound_def)

lemma soundI2[intro]:
  "\<lbrakk> bounded_by b P; nneg P \<rbrakk> \<Longrightarrow> sound P"
  by(blast intro:soundI)

lemma sound_bounded[dest]:
  "sound P \<Longrightarrow> bounded P"
  by (simp add:sound_def)

lemma sound_nneg[dest]:
  "sound P \<Longrightarrow> nneg P"
  by (simp add:sound_def)

lemma bound_of_sound[intro]:
  assumes sP: "sound P"
  shows "0 \<le> bound_of P"
  using assms by(auto)

text {* This proof demonstrates the use of the classical reasoner (specifically blast), to both
introduce and eliminate soundness terms. *}

lemma sound_sum[simp,intro]:
  assumes sP: "sound P" and sQ: "sound Q"
  shows "sound (\<lambda>s. P s + Q s)"
proof
  from sP have "\<And>s. P s \<le> bound_of P" by(blast)
  moreover from sQ have "\<And>s. Q s \<le> bound_of Q" by(blast)
  ultimately have "\<And>s. P s + Q s \<le> bound_of P + bound_of Q"
    by(rule add_mono)
  thus "bounded_by (bound_of P + bound_of Q) (\<lambda>s. P s + Q s)"
    by(blast)

  from sP have "\<And>s. 0 \<le> P s" by(blast)
  moreover from sQ have "\<And>s. 0 \<le> Q s" by(blast)
  ultimately have "\<And>s. 0 \<le> P s + Q s" by(simp add:add_mono)
  thus "nneg (\<lambda>s. P s + Q s)" by(blast)
qed

lemma mult_sound:
  assumes sP: "sound P" and sQ: "sound Q"
  shows "sound (\<lambda>s. P s * Q s)"
proof
  from sP have "\<And>s. P s \<le> bound_of P" by(blast)
  moreover from sQ have "\<And>s. Q s \<le> bound_of Q" by(blast)
  ultimately have "\<And>s. P s * Q s \<le> bound_of P * bound_of Q"
    using sP and sQ by(blast intro:mult_mono)
  thus "bounded_by (bound_of P * bound_of Q) (\<lambda>s. P s * Q s)" by(blast)

  from sP and sQ show "nneg (\<lambda>s. P s * Q s)"
    by(blast intro:mult_nonneg_nonneg)
qed

lemma div_sound:
  assumes sP: "sound P" and cpos: "0 < c"
  shows "sound (\<lambda>s. P s / c)"
proof
  from sP and cpos have "\<And>s. P s / c \<le> bound_of P / c"
    by(blast intro:divide_right_mono less_imp_le)
  thus "bounded_by (bound_of P / c) (\<lambda>s. P s / c)" by(blast)
  from assms show "nneg (\<lambda>s. P s / c)"
    by(blast intro:divide_nonneg_pos)
qed

lemma tminus_sound:
  assumes sP: "sound P" and nnc: "0 \<le> c"
  shows "sound (\<lambda>s. P s \<ominus> c)"
proof(rule soundI)
  from sP have "\<And>s. P s \<le> bound_of P" by(blast)
  with nnc have "\<And>s. P s \<ominus> c \<le> bound_of P \<ominus> c"
    by(blast intro:tminus_left_mono)
  thus "bounded (\<lambda>s. P s \<ominus> c)" by(blast)
  show "nneg (\<lambda>s. P s \<ominus> c)" by(blast)
qed

lemma const_sound:
  "0 \<le> c \<Longrightarrow> sound (\<lambda>s. c)"
  by (blast)

lemma sound_o[intro,simp]:
  "sound P \<Longrightarrow> sound (P o f)"
  unfolding o_def by(blast)

lemma sc_bounded_by[intro,simp]:
  "\<lbrakk> sound P; 0 \<le> c \<rbrakk> \<Longrightarrow> bounded_by (c * bound_of P) (\<lambda>x. c * P x)"
  by(blast intro!:mult_left_mono)

lemma sc_bounded[intro,simp]:
  assumes sP:  "sound P" and pos: "0 \<le> c"
  shows "bounded (\<lambda>x. c * P x)"
  using assms by(blast)

lemma sc_bound[simp]:
  assumes sP: "sound P"
      and cnn: "0 \<le> c"
  shows "c * bound_of P = bound_of (\<lambda>x. c * P x)"
proof(cases "c = 0")
  case True then show ?thesis by(simp)
next
  case False with cnn have cpos: "0 < c" by(auto)
  show ?thesis
  proof (rule antisym)
    from sP and cnn have "bounded (\<lambda>x. c * P x)" by(simp)
    hence "\<And>x. c * P x \<le> bound_of (\<lambda>x. c * P x)"
      by(rule le_bound_of)
    with cpos have "\<And>x. P x \<le> inverse c * bound_of (\<lambda>x. c * P x)"
      by(force intro:mult_div_mono_right)
    hence "bound_of P \<le> inverse c * bound_of (\<lambda>x. c * P x)"
      by(blast)
    with cpos show "c * bound_of P \<le> bound_of (\<lambda>x. c * P x)"
      by(force intro:mult_div_mono_left)
  next
    from sP and cpos have "\<And>x. c * P x \<le> c * bound_of P"
      by(blast intro:mult_left_mono less_imp_le)
    thus "bound_of (\<lambda>x. c * P x) \<le> c * bound_of P"
      by(blast)
  qed
qed

lemma sc_sound:
  "\<lbrakk> sound P; 0 \<le> c \<rbrakk> \<Longrightarrow> sound (\<lambda>s. c * P s)"
  by (blast intro:mult_nonneg_nonneg)

lemma bounded_by_mult:
  assumes sP: "sound P" and bP: "bounded_by a P"
      and sQ: "sound Q" and bQ: "bounded_by b Q"
  shows "bounded_by (a * b) (\<lambda>s. P s * Q s)"
  using assms by(intro bounded_byI, auto intro:mult_mono)

lemma bounded_by_add:
  fixes P::"'s \<Rightarrow> real" and Q
  assumes bP: "bounded_by a P"
      and bQ: "bounded_by b Q"
  shows "bounded_by (a + b) (\<lambda>s. P s + Q s)"
  using assms by(intro bounded_byI, auto intro:add_mono)

lemma sound_unit[intro!,simp]:
  "sound (\<lambda>s. 1)"
  by(auto)

lemma unit_mult[intro]:
  assumes sP: "sound P" and bP: "bounded_by 1 P"
      and sQ: "sound Q" and bQ: "bounded_by 1 Q"
  shows "bounded_by 1 (\<lambda>s. P s * Q s)"
proof(rule bounded_byI)
  fix s
  have "P s * Q s \<le> 1 * 1"
    using assms by(blast dest:bounded_by_mult)
  thus "P s * Q s \<le> 1" by(simp)
qed

lemma setsum_sound:
  assumes sP: "\<forall>x\<in>S. sound (P x)"
  shows "sound (\<lambda>s. \<Sum>x\<in>S. P x s)"
proof(rule soundI2)
  from sP show "bounded_by (\<Sum>x\<in>S. bound_of (P x)) (\<lambda>s. \<Sum>x\<in>S. P x s)"
    by(auto intro!:setsum_mono)
  from sP show "nneg (\<lambda>s. \<Sum>x\<in>S. P x s)"
    by(auto intro!:setsum_nonneg)
qed

subsection {* Unitary expectations *}

text {* A unitary expectation is a sound expectation that is additionally bounded by one.  This
is the domain on which the \emph{liberal} (partial correctness) semantics operates. *}

definition unitary :: "'s expect \<Rightarrow> bool"
where "unitary P \<longleftrightarrow> sound P \<and> bounded_by 1 P"

lemma unitaryI[intro]:
  "\<lbrakk> sound P; bounded_by 1 P \<rbrakk> \<Longrightarrow> unitary P"
  by(simp add:unitary_def)

lemma unitaryI2:
  "\<lbrakk> nneg P; bounded_by 1 P \<rbrakk> \<Longrightarrow> unitary P"
  by(auto)

lemma unitary_sound[dest]:
  "unitary P \<Longrightarrow> sound P"
  by(simp add:unitary_def)

lemma unitary_bound[dest]:
  "unitary P \<Longrightarrow> bounded_by 1 P"
  by(simp add:unitary_def)

subsection {* Standard Expectations *}
text_raw {* \label{s:standard} *}

definition
  embed_bool :: "('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> real" ("\<guillemotleft> _ \<guillemotright>" 1000)
where
  "\<guillemotleft>P\<guillemotright> \<equiv> (\<lambda>s. if P s then 1 else 0)"

text {* Standard expectations are the embeddings of boolean predicates, mapping @{term False} to 0
and @{term True} to 1. We write @{term "\<guillemotleft>P\<guillemotright>"} rather than @{term "[P]"} (the syntax employed by
\citet{McIver_M_04}) for boolean embedding to avoid clashing with the HOL syntax for lists. *}

lemma embed_bool_nneg[simp,intro]:
  "nneg \<guillemotleft>P\<guillemotright>"
  unfolding embed_bool_def by(force)

lemma embed_bool_bounded_by_1[simp,intro]:
  "bounded_by 1 \<guillemotleft>P\<guillemotright>"
  unfolding embed_bool_def by(force)

text {* Standard expectations have a number of convenient properties, which mostly follow from
boolean algebra. *}

lemma embed_bool_idem:
  "\<guillemotleft>P\<guillemotright> s * \<guillemotleft>P\<guillemotright> s = \<guillemotleft>P\<guillemotright> s"
  by (simp add:embed_bool_def)

lemma eval_embed_true[simp]:
  "P s \<Longrightarrow> \<guillemotleft>P\<guillemotright> s = 1"
  by (simp add:embed_bool_def)

lemma eval_embed_false[simp]:
  "\<not>P s \<Longrightarrow> \<guillemotleft>P\<guillemotright> s = 0"
  by (simp add:embed_bool_def)

lemma embed_ge_0[simp,intro]:
  "0 \<le> \<guillemotleft>G\<guillemotright> s"
  by (simp add:embed_bool_def)

lemma embed_le_1[simp,intro]:
  "\<guillemotleft>G\<guillemotright> s \<le> 1"
  by(simp add:embed_bool_def)

lemma embed_le_1_alt[simp,intro]:
  "0 \<le> 1 - \<guillemotleft>G\<guillemotright> s"
  by(subst add_le_cancel_right[where c="\<guillemotleft>G\<guillemotright> s", symmetric], simp)

lemma expect_1_I:
  "P x \<Longrightarrow> 1 \<le> \<guillemotleft>P\<guillemotright> x"
  by(simp)

lemma standard_sound[intro,simp]:
  "sound \<guillemotleft>P\<guillemotright>"
  by(blast)

lemma embed_o[simp]:
  "\<guillemotleft>P\<guillemotright> o f = \<guillemotleft>P o f\<guillemotright>"
  unfolding embed_bool_def o_def by(simp)

text {* Negating a predicate has the expected effect in its
embedding as an expectation: *}

definition negate :: "('s \<Rightarrow> bool) \<Rightarrow> 's \<Rightarrow> bool" ("\<N>")
where     "negate P = (\<lambda>s. \<not> P s)"

lemma negateI:
  "\<not> P s \<Longrightarrow> \<N> P s"
  by (simp add:negate_def)

lemma embed_split:
  "f s = \<guillemotleft>P\<guillemotright> s * f s + \<guillemotleft>\<N> P\<guillemotright> s * f s"
  by (simp add:negate_def embed_bool_def)

lemma negate_embed:
  "\<guillemotleft>\<N> P\<guillemotright> s = 1 - \<guillemotleft>P\<guillemotright> s"
  by (simp add:embed_bool_def negate_def)

lemma eval_nembed_true[simp]:
  "P s \<Longrightarrow> \<guillemotleft>\<N> P\<guillemotright> s = 0"
  by (simp add:embed_bool_def negate_def)

lemma eval_nembed_false[simp]:
  "\<not>P s \<Longrightarrow> \<guillemotleft>\<N> P\<guillemotright> s = 1"
  by (simp add:embed_bool_def negate_def)

lemma negate_Not[simp]:
  "\<N> Not = (\<lambda>x. x)"
  by(simp add:negate_def)

lemma negate_negate[simp]:
  "\<N> (\<N> P) = P"
  by(simp add:negate_def)

lemma embed_bool_cancel:
  "\<guillemotleft>G\<guillemotright> s * \<guillemotleft>\<N> G\<guillemotright> s = 0"
  by(cases "G s", simp_all)

subsection {* Entailment *}
text_raw {* \label{s:entailment} *}

text {* Entailment on expectations is a generalisation of that on predicates, and is defined by
pointwise comparison: *}

abbreviation entails :: "('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> bool" ("_ \<tturnstile> _" 50)
where "P \<tturnstile> Q \<equiv> P \<le> Q"

lemma entailsI[intro]:
  "\<lbrakk>\<And>s. P s \<le> Q s\<rbrakk> \<Longrightarrow> P \<tturnstile> Q"
  by(simp add:le_funI)

lemma entailsD[dest]:
  "P \<tturnstile> Q \<Longrightarrow> P s \<le> Q s"
  by(simp add:le_funD)

lemma eq_entails[intro]:
  "P = Q \<Longrightarrow> P \<tturnstile> Q"
  by(blast)

lemma entails_trans[trans]:
  "\<lbrakk> P \<tturnstile> Q; Q \<tturnstile> R \<rbrakk> \<Longrightarrow> P \<tturnstile> R"
  by(blast intro:order_trans)

text {* For standard expectations, both notions of entailment coincide. This result justifies the
above claim that our definition generalises predicate entailment: *}

lemma implies_entails:
  "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s \<rbrakk> \<Longrightarrow> \<guillemotleft>P\<guillemotright> \<tturnstile> \<guillemotleft>Q\<guillemotright>"
  by(rule entailsI, case_tac "P s", simp_all)

lemma entails_implies:
  "\<And>s. \<lbrakk> \<guillemotleft>P\<guillemotright> \<tturnstile> \<guillemotleft>Q\<guillemotright>; P s \<rbrakk> \<Longrightarrow> Q s"
  by(rule ccontr, drule_tac s=s in entailsD, simp)

subsection {* Expectation Conjunction *}

definition
  pconj :: "real \<Rightarrow> real \<Rightarrow>  real" (infixl ".&" 71)
where
  "p .& q \<equiv> p + q \<ominus> 1"

definition
  exp_conj :: "('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real) \<Rightarrow> ('s \<Rightarrow> real)" (infixl "&&" 71)
where "a && b \<equiv> \<lambda>s. (a s .& b s)"

text {* Expectation conjunction likewise generalises (boolean) predicate conjunction. We show that
the expected properties are preserved, and instantiate both the classical reasoner, and the
simplifier (in the case of associativity and commutativity). *}

lemma pconj_lzero[intro,simp]:
  "b \<le> 1 \<Longrightarrow> 0 .& b = 0"
  by(simp add:pconj_def tminus_def)

lemma pconj_rzero[intro,simp]:
  "b \<le> 1 \<Longrightarrow> b .& 0 = 0"
  by(simp add:pconj_def tminus_def)

lemma pconj_lone[intro,simp]:
  "0 \<le> b \<Longrightarrow> 1 .& b = b"
  by(simp add:pconj_def tminus_def)

lemma pconj_rone[intro,simp]:
  "0 \<le> b \<Longrightarrow> b .& 1 = b"
  by(simp add:pconj_def tminus_def)

lemma pconj_bconj:
  "\<guillemotleft>a\<guillemotright> s .& \<guillemotleft>b\<guillemotright> s = \<guillemotleft>\<lambda>s. a s \<and> b s\<guillemotright> s"
  unfolding embed_bool_def pconj_def tminus_def by(force)

lemma pconj_comm[ac_simps]:
  "a .& b = b .& a"
  by(simp add:pconj_def ac_simps)

lemma pconj_assoc:
  "\<lbrakk> 0 \<le> a; a \<le> 1; 0 \<le> b; b \<le> 1; 0 \<le> c; c \<le> 1 \<rbrakk> \<Longrightarrow>
   a .& (b .& c) = (a .& b) .& c"
  unfolding pconj_def tminus_def by(simp)

lemma pconj_mono:
  "\<lbrakk> a \<le> b; c \<le> d \<rbrakk> \<Longrightarrow> a .& c \<le> b .& d"
  unfolding pconj_def tminus_def by(simp)

lemma pconj_nneg[intro,simp]:
  "0 \<le> a .& b"
  unfolding pconj_def tminus_def by(auto)

lemma min_pconj:
  "(min a b) .& (min c d) \<le> min (a .& c) (b .& d)"
  by(cases "a \<le> b",
     (cases "c \<le> d",
      simp_all add:min.absorb1 min.absorb2 pconj_mono)[],
     (cases "c \<le> d",
      simp_all add:min.absorb1 min.absorb2 pconj_mono))

lemma pconj_less_one[simp]:
  "a + b < 1 \<Longrightarrow> a .& b = 0"
  unfolding pconj_def by(simp)

lemma pconj_ge_one[simp]:
  "1 \<le> a + b \<Longrightarrow> a .& b = a + b - 1"
  unfolding pconj_def by(simp)

lemma pconj_idem[simp]:
  "\<guillemotleft>P\<guillemotright> s .& \<guillemotleft>P\<guillemotright> s = \<guillemotleft>P\<guillemotright> s"
  unfolding pconj_def by(cases "P s", simp_all)

subsection {* Rules Involving Conjunction. *}

lemma exp_conj_mono_left:
  "P \<tturnstile> Q \<Longrightarrow> P && R \<tturnstile> Q && R"
  unfolding exp_conj_def pconj_def
  by(auto intro:tminus_left_mono add_right_mono)

lemma exp_conj_mono_right:
  "Q \<tturnstile> R \<Longrightarrow> P && Q \<tturnstile> P && R"
  unfolding exp_conj_def pconj_def
  by(auto intro:tminus_left_mono add_left_mono)

lemma exp_conj_comm[ac_simps]:
  "a && b = b && a"
  by(simp add:exp_conj_def ac_simps)

lemma exp_conj_bounded_by[intro,simp]:
  assumes bP: "bounded_by 1 P"
      and bQ: "bounded_by 1 Q"
  shows "bounded_by 1 (P && Q)"
proof(rule bounded_byI, unfold exp_conj_def pconj_def)
  fix x
  from bP have "P x \<le> 1" by(blast)
  moreover from bQ have "Q x \<le> 1" by(blast)
  ultimately have "P x + Q x \<le> 2" by(auto)
  thus "P x + Q x \<ominus> 1 \<le> 1"
    unfolding tminus_def by(simp)
qed

lemma exp_conj_o_distrib[simp]:
  "(P && Q) o f = (P o f) && (Q o f)"
  unfolding exp_conj_def o_def by(simp)

lemma exp_conj_assoc:
  assumes "unitary P" and "unitary Q" and "unitary R"
  shows "P && (Q && R) = (P && Q) && R"
  unfolding exp_conj_def
proof(rule ext)
  fix s
  from assms have "0 \<le> P s" by(blast)
  moreover from assms have "0 \<le> Q s" by(blast)
  moreover from assms have "0 \<le> R s" by(blast)
  moreover from assms have "P s \<le> 1" by(blast)
  moreover from assms have "Q s \<le> 1" by(blast)
  moreover from assms have "R s \<le> 1" by(blast)
  ultimately
  show "P s .& (Q s .& R s) = (P s .& Q s) .& R s"
    by(simp add:pconj_assoc)
qed

lemma exp_conj_top_left[simp]:
  "sound P \<Longrightarrow> \<guillemotleft>\<lambda>_. True\<guillemotright> && P = P"
  unfolding exp_conj_def by(force)

lemma exp_conj_top_right[simp]:
  "sound P \<Longrightarrow> P && \<guillemotleft>\<lambda>_. True\<guillemotright> = P"
  unfolding exp_conj_def by(force)

lemma exp_conj_idem[simp]:
  "\<guillemotleft>P\<guillemotright> && \<guillemotleft>P\<guillemotright> = \<guillemotleft>P\<guillemotright>"
  unfolding exp_conj_def
  by(rule ext, cases "P s", simp_all)

lemma exp_conj_nneg[intro,simp]:
  "(\<lambda>s. 0) \<le> P && Q"
  unfolding exp_conj_def
  by(blast intro:le_funI)

lemma exp_conj_sound[intro,simp]:
  assumes s_P: "sound P"
      and s_Q: "sound Q"
  shows "sound (P && Q)"
  unfolding exp_conj_def
proof(rule soundI)
  from s_P and s_Q have "\<And>s. 0 \<le> P s + Q s" by(blast intro:add_nonneg_nonneg)
  hence "\<And>s. P s .& Q s \<le> P s + Q s"
    unfolding pconj_def by(force intro:tminus_less)
  also from assms have "\<And>s. ... s \<le> bound_of P + bound_of Q"
    by(blast intro:add_mono)
  finally have "bounded_by (bound_of P + bound_of Q) (\<lambda>s. P s .& Q s)"
    by(blast)
  thus "bounded (\<lambda>s. P s .& Q s)" by(blast)

  show "nneg (\<lambda>s. P s .& Q s)"
    unfolding pconj_def tminus_def by(force)
qed

lemma exp_conj_rzero[simp]:
  "bounded_by 1 P \<Longrightarrow> P && (\<lambda>s. 0) = (\<lambda>s. 0)"
  unfolding exp_conj_def by(force)

lemma exp_conj_1_right[simp]:
  assumes nn: "nneg A"
  shows "A && (\<lambda>_. 1) = A"
  unfolding exp_conj_def pconj_def tminus_def
proof(rule ext, simp)
  fix s
  from nn have "0 \<le> A s" by(blast)
  thus "max (A s) 0 = A s" by(force)
qed

lemma exp_conj_std_split:
  "\<guillemotleft>\<lambda>s. P s \<and> Q s\<guillemotright> = \<guillemotleft>P\<guillemotright> && \<guillemotleft>Q\<guillemotright>"
  unfolding exp_conj_def embed_bool_def pconj_def
  by(auto)

subsection {* Rules Involving Entailment and Conjunction Together *}

text {* Meta-conjunction distributes over expectaton entailment,
becoming expectation conjunction: *}
lemma entails_frame:
  assumes ePR: "P \<tturnstile> R"
      and eQS: "Q \<tturnstile> S"
  shows "P && Q \<tturnstile> R && S"
proof(rule le_funI)
  fix s
  from ePR have "P s \<le> R s" by(blast)
  moreover from eQS have "Q s \<le> S s" by(blast)
  ultimately have "P s + Q s \<le> R s + S s" by(rule add_mono)
  hence "P s + Q s \<ominus> 1 \<le> R s + S s \<ominus> 1" by(rule tminus_left_mono)
  thus "(P && Q) s \<le> (R && S) s"
    unfolding exp_conj_def pconj_def .
qed

text {* This rule allows something very much akin to a case distinction
on the pre-expectation. *}
lemma pentails_cases:
  assumes PQe: "\<And>x. P x \<tturnstile> Q x"
      and exhaust: "\<And>s. \<exists>x. P (x s) s = 1"
      and framed: "\<And>x. P x && R \<tturnstile> Q x && S"
      and sR: "sound R" and sS: "sound S"
      and bQ: "\<And>x. bounded_by 1 (Q x)"
  shows "R \<tturnstile> S"
proof(rule le_funI)
  fix s
  from exhaust obtain x where P_xs: "P x s = 1" by(blast)
  moreover {
    hence "1 = P x s" by(simp)
    also from PQe have "P x s \<le> Q x s" by(blast dest:le_funD)
    finally have "Q x s = 1"
      using bQ by(blast intro:antisym)
  }
  moreover note le_funD[OF framed[where x=x], where x=s]
  moreover from sR have "0 \<le> R s" by(blast)
  moreover from sS have "0 \<le> S s" by(blast)
  ultimately show "R s \<le> S s" by(simp add:exp_conj_def)
qed

lemma unitary_bot[iff]:
  "unitary (\<lambda>s. 0::real)"
  by(auto)

lemma unitary_top[iff]:
  "unitary (\<lambda>s. 1::real)"
  by(auto)

lemma unitary_embed[iff]:
  "unitary \<guillemotleft>P\<guillemotright>"
  by(auto)

lemma unitary_const[iff]:
  "\<lbrakk> 0 \<le> c; c \<le> 1 \<rbrakk> \<Longrightarrow> unitary (\<lambda>s. c)"
  by(auto)

lemma unitary_mult:
  assumes uA: "unitary A" and uB: "unitary B"
  shows "unitary (\<lambda>s. A s * B s)"
proof(intro unitaryI2 nnegI bounded_byI)
  fix s
  from assms have nnA: "0 \<le> A s" and nnB: "0 \<le> B s" by(auto)
  thus "0 \<le> A s * B s" by(rule mult_nonneg_nonneg)
  from assms have "A s \<le> 1" and "B s \<le> 1" by(auto)
  with nnB have "A s * B s \<le> 1 * 1" by(intro mult_mono, auto)
  also have "... = 1" by(simp)
  finally show "A s * B s \<le> 1" .
qed

lemma exp_conj_unitary:
  "\<lbrakk> unitary P; unitary Q \<rbrakk> \<Longrightarrow> unitary (P && Q)"
  by(intro unitaryI2 nnegI2, auto)

lemma unitary_comp[simp]:
  "unitary P \<Longrightarrow> unitary (P o f)"
  by(intro unitaryI2 nnegI bounded_byI, auto simp:o_def)

lemmas unitary_intros =
  unitary_bot unitary_top unitary_embed unitary_mult exp_conj_unitary
  unitary_comp unitary_const

lemmas sound_intros =
  mult_sound div_sound const_sound sound_o sound_sum
  tminus_sound sc_sound exp_conj_sound setsum_sound

end


theory Lists
  imports Main

begin

primrec replace :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "replace x y [] = []"
  | "replace x y (z # zs) = (if z = x then y else z) # replace x y zs"

lemma rev_append: "rev (a # zs) = (rev zs) @ [a]"
proof(induct zs)
  case Nil
  show ?case by auto
next
  case (Cons a zs)
  show ?case by auto
qed

lemma repl_append: "replace x y (zs @ a) = (replace x y zs) @ (replace x y a)"
proof(induct zs)
  case Nil
  show ?case by auto
next
  case (Cons z zs)
  fix a
  assume IH: "replace x y (zs @ a) = replace x y zs @ replace x y a"
  define cons_app where "cons_app \<equiv> (z # zs) @ a"
  hence "cons_app = z # (zs @ a)" using cons_app_def by auto
  hence "replace x y cons_app = (replace x y [z]) @ (replace x y (zs @ a))" by auto
  hence "replace x y cons_app = (replace x y [z]) @ (replace x y zs) @ (replace x y a)" using IH by auto
  hence "replace x y cons_app = (replace x y (z # zs)) @ (replace x y a)" by auto
  thus "replace x y ((z # zs) @ a) = replace x y (z # zs) @ replace x y a" using cons_app_def by auto
qed

theorem "rev(replace x y zs) = replace x y (rev zs)"
proof(induct zs)
  case Nil
  show ?case by auto
next
  case (Cons z zs)
  fix z zs
  assume IH: "rev (replace x y zs) = replace x y (rev zs)"
  define repl_rev where "repl_rev \<equiv> replace x y (rev (z # zs))"
  have "repl_rev = replace x y ((rev zs) @ [z])" using rev_append repl_rev_def by auto
  hence "repl_rev = replace x y (rev zs) @ replace x y [z]"
    using repl_append[of "x" "y" "(rev zs)" "[z]"] by auto
  hence "repl_rev = rev (replace x y zs) @ replace x y [z]" using IH by auto
  hence "repl_rev = rev (replace x y (z # zs))" using rev_append by auto
  thus "rev (replace x y (z # zs)) = replace x y (rev (z # zs))" using repl_rev_def by auto
qed
end


section "Stack Machine and Compilation"

theory ASM imports AExp begin

subsection "Stack Machine"

text_raw{*\snip{ASMinstrdef}{0}{1}{% *}
datatype instr = LOADI val | LOAD vname | ADD
text_raw{*}%endsnip*}

text_raw{*\snip{ASMstackdef}{1}{2}{% *}
type_synonym stack = "val list"
text_raw{*}%endsnip*}

abbreviation "hd2 xs == hd(tl xs)"
abbreviation "tl2 xs == tl(tl xs)"

text{* \noindent Abbreviations are transparent: they are unfolded after
parsing and folded back again before printing. Internally, they do not
exist.*}

text_raw{*\snip{ASMexeconedef}{0}{1}{% *}
fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec1 (LOADI n) _ stk  =  n # stk" |
"exec1 (LOAD x) s stk  =  s(x) # stk" |
"exec1  ADD _ stk  =  (hd2 stk + hd stk) # tl2 stk"
text_raw{*}%endsnip*}

text_raw{*\snip{ASMexecdef}{1}{2}{% *}
fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack" where
"exec [] _ stk = stk" |
"exec (i#is) s stk = exec is s (exec1 i s stk)"
text_raw{*}%endsnip*}

value "exec [LOADI 5, LOAD ''y'', ADD] <''x'' := 42, ''y'' := 43> [50]"

lemma exec_append[simp]:
  "exec (is1@is2) s stk = exec is2 s (exec is1 s stk)"
apply(induction is1 arbitrary: stk)
apply (auto)
done

subsection "Compilation"

text_raw{*\snip{ASMcompdef}{0}{2}{% *}
fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x) = [LOAD x]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"
text_raw{*}%endsnip*}

value "comp (Plus (Plus (V ''x'') (N 1)) (V ''z''))"

theorem exec_comp: "exec (comp a) s stk = aval a s # stk"
apply(induction a arbitrary: stk)
apply (auto)
done

end


theory Chapter11
imports "~~/src/HOL/IMP/Denotational" "~~/src/HOL/IMP/Vars"
begin

text{*
\section*{Chapter 11}

\begin{exercise}
Building on Exercise~\ref{exe:IMP:REPEAT}, extend the denotational
semantics and the equivalence proof with the big-step semantics
with a @{text REPEAT} loop.
\end{exercise}

\exercise
Consider Example~11.14 and prove the following equation by induction on @{text n}:
*}
lemma "((W (\<lambda>s. s ''x'' \<noteq> 0) ({(s,t). t = s(''x'' := s ''x'' - 1)}))^^n) {} =
  {(s,t). 0 \<le> s ''x'' & s ''x'' < int n & t = s(''x'' := 0)}"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Consider Example~11.14 but with the loop condition
@{prop"b = Less (N 0) (V ''x'')"}. Find a closed expression @{text M}
(containing @{text n})
for @{prop"(f ^^ n) {}"} and prove @{prop"(f ^^ n) {} = M"}.
*}

text {*
\endexercise

\exercise
Define an operator @{text B} such that you
can express the equation for @{term "D (IF b THEN c1 ELSE c2)"}
in a point free way.
*}
definition B :: "bexp \<Rightarrow> (state \<times> state) set"  where
(* your definition/proof here *)

lemma
  "D (IF b THEN c1 ELSE c2) = (B b O D c1) \<union> (B (Not b) O D c2)"
(* your definition/proof here *)

text {*
  Similarly, find a point free equation for @{term "W (bval b) dc"}
  and use it to write down a point free version of
  @{term "D (WHILE b DO c)"} (still using @{text lfp}).
  Prove that your equations are equivalent to the old ones.
*}

(* your definition/proof here *)

text{*
\endexercise

\exercise
Let the `thin' part of a relation be its single-valued subset:
*}

definition thin :: "'a rel \<Rightarrow> 'a rel" where
"thin R = {(a,b) . (a,b) \<in> R \<and> (\<forall> c. (a,c) \<in> R \<longrightarrow> c = b)}"

text{* Prove *}

lemma fixes f :: "'a rel \<Rightarrow> 'a rel"
assumes "mono f" and thin_f: "\<And> R. f (thin R) \<subseteq> thin (f R)"
shows "single_valued (lfp f)"
(* your definition/proof here *)

text{*
\endexercise

\exercise
Generalise our set-theoretic treatment of continuity and least fixpoints to
\concept{chain-complete partial order}s (\concept{cpo}s),
i.e.\ partial orders @{text"\<le>"} that have a least element @{text "\<bottom>"} and
where every chain @{text"c 0 \<le> c 1 \<le> \<dots>"} has a least upper bound
@{term"lub c"} where \noquotes{@{term[source]"c :: nat \<Rightarrow> 'a"}}.
This setting is described by the following type class @{text cpo}
which is an extension of the type class @{class order} of partial orders.
For details see the decription of type classes in Chapter~13.
*}

context order
begin
definition chain :: "(nat \<Rightarrow> 'a) \<Rightarrow> bool" where
"chain c = (\<forall>n. c n \<le> c (Suc n))"
end

class cpo = order +
fixes bot :: 'a and lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
assumes bot_least: "bot \<le> x"
and lub_ub: "chain c \<Longrightarrow> c n \<le> lub c"
and lub_least: "chain c \<Longrightarrow> (\<And>n. c n \<le> u) \<Longrightarrow> lub c \<le> u"

text{*
A function \noquotes{@{term[source] "f :: 'a \<Rightarrow> 'b"}}
between two cpos @{typ 'a} and @{typ 'b}
is called \concept{continuous} if @{prop"f(lub c) = lub (f o c)"}.
Prove that if @{text f} is monotone and continuous then
\ \mbox{@{text"lub (\<lambda>n. (f ^^ n) \<bottom>)"}} \ is the least (pre)fixpoint of @{text f}:
*}

definition cont :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> bool" where
"cont f = (\<forall>c. chain c \<longrightarrow> f (lub c) = lub (f o c))"

abbreviation "fix f \<equiv> lub (\<lambda>n. (f^^n) bot)"

lemma fix_lpfp: assumes "mono f" and "f p \<le> p" shows "fix f \<le> p"
(* your definition/proof here *)

theorem fix_fp: assumes "mono f" and "cont f" shows "f(fix f) = fix f"
(* your definition/proof here *)

text{*
\endexercise

\exercise
We define a dependency analysis @{text Dep} that maps commands to relations
between variables such that @{term "(x,y) : Dep c"} means that in
the execution of @{text c}
the initial value of @{text x} can influence the final value of @{text y}:
*}

fun Dep :: "com \<Rightarrow> (vname * vname) set" where
"Dep SKIP = Id" |
"Dep (x::=a) = {(u,v). if v = x then u \<in> vars a else u = v}" |
"Dep (c1;;c2) = Dep c1 O Dep c2" |
"Dep (IF b THEN c1 ELSE c2) = Dep c1 \<union> Dep c2 \<union> vars b \<times> UNIV" |
"Dep (WHILE b DO c) = lfp(\<lambda>R. Id \<union> vars b \<times> UNIV \<union> Dep c O R)"

text{*
where @{text"\<times>"} is the cross product of two sets.
Prove monotonicity of the function @{const lfp} is applied to.
*}

text{* For the correctness statement define *}

abbreviation Deps :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"Deps c X \<equiv> (\<Union> x\<in>X. {y. (y,x) : Dep c})"

text{* and prove *}

lemma "\<lbrakk> (c,s) \<Rightarrow> s';  (c,t) \<Rightarrow> t';  s = t on Deps c X \<rbrakk> \<Longrightarrow> s' = t' on X"
(* your definition/proof here *)

text{*

Give an example that the following stronger termination-sensitive property
@{prop[display] "\<lbrakk> (c,s) \<Rightarrow> s'; s = t on Deps c X \<rbrakk>
  \<Longrightarrow> \<exists>t'. (c,t) \<Rightarrow> t' \<and> s' = t' on X"}
does not hold. Hint: @{prop"X = {}"}.

In the definition of @{term"Dep(IF b THEN c1 ELSE c2)"} the variables
in @{text b} can influence all variables (@{text UNIV}). However,
if a variable is not assigned to in @{text c1} and @{text c2}
it is not influenced by @{text b} (ignoring termination).
Theory @{theory Vars} defines a function @{const lvars} such
that @{term"lvars c"} is the set of variables on the left-hand side
of an assignment in @{text c}.
Modify the definition of @{const Dep} as follows:
replace @{const UNIV} by @{term"lvars c1 \<union> lvars c2"}
(in the case @{term"IF b THEN c1 ELSE c2"}) and by \mbox{@{term"lvars c"}}
(in the case @{term"WHILE b DO c"}).
Adjust the proof of the above correctness statement.
*}

text{*
\endexercise
*}

end


section "Arrays without bounds"
theory CArrays imports Main begin

text \<open>For these arrays there is no
        built-in protection against reading or writing out-of-bounds.\<close>

type_synonym 'a cArray = "nat => 'a"

definition makeCArray :: "nat => 'a => 'a cArray" where
  "makeCArray arraySize fillValue index ==
   if index < arraySize then fillValue else undefined"

definition readCArray :: "'a cArray => nat => 'a" where
  "readCArray array index == array index"

definition writeCArray :: "'a cArray => nat => 'a => 'a cArray" where
  "writeCArray array index value == array(index := value)"

(* ---------------------------------------------------------------*)

lemma makeCArrayCorrect:
  "index < arraySize ==>
   readCArray (makeCArray arraySize fillValue) index = fillValue"
by (simp add: readCArray_def makeCArray_def)

lemma writeCArrayCorrect1:
  "readCArray (writeCArray array index value) index = value"
by (simp add: readCArray_def writeCArray_def)

lemma writeCArrayCorrect2:
  "index1 ~= index2 ==>
   readCArray (writeCArray array index1 value) index2 =
   readCArray array index2"
by (simp add: readCArray_def writeCArray_def)

end


theory T84
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory T86
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=7,timeout=86400]
oops
end


(*  Title:      HOL/Proofs/Lambda/InductTermi.thy
    Author:     Tobias Nipkow
    Copyright   1998 TU Muenchen

Inductive characterization of terminating lambda terms.  Goes back to
Raamsdonk & Severi. On normalization. CWI TR CS-R9545, 1995.  Also
rediscovered by Matthes and Joachimski.
*)

section {* Inductive characterization of terminating lambda terms *}

theory InductTermi imports ListBeta begin

subsection {* Terminating lambda terms *}

inductive IT :: "dB => bool"
  where
    Var [intro]: "listsp IT rs ==> IT (Var n \<degree>\<degree> rs)"
  | Lambda [intro]: "IT r ==> IT (Abs r)"
  | Beta [intro]: "IT ((r[s/0]) \<degree>\<degree> ss) ==> IT s ==> IT ((Abs r \<degree> s) \<degree>\<degree> ss)"

subsection {* Every term in @{text "IT"} terminates *}

lemma double_induction_lemma [rule_format]:
  "termip beta s ==> \<forall>t. termip beta t -->
    (\<forall>r ss. t = r[s/0] \<degree>\<degree> ss --> termip beta (Abs r \<degree> s \<degree>\<degree> ss))"
  apply (erule accp_induct)
  apply (rule allI)
  apply (rule impI)
  apply (erule thin_rl)
  apply (erule accp_induct)
  apply clarify
  apply (rule accp.accI)
  apply (safe elim!: apps_betasE)
    apply (blast intro: subst_preserves_beta apps_preserves_beta)
   apply (blast intro: apps_preserves_beta2 subst_preserves_beta2 rtranclp_converseI
     dest: accp_downwards)  (* FIXME: acc_downwards can be replaced by acc(R ^* ) = acc(r) *)
  apply (blast dest: apps_preserves_betas)
  done

lemma IT_implies_termi: "IT t ==> termip beta t"
  apply (induct set: IT)
    apply (drule rev_predicate1D [OF _ listsp_mono [where B="termip beta"]])
    apply (fast intro!: predicate1I)
    apply (drule lists_accD)
    apply (erule accp_induct)
    apply (rule accp.accI)
    apply (blast dest: head_Var_reduction)
   apply (erule accp_induct)
   apply (rule accp.accI)
   apply blast
  apply (blast intro: double_induction_lemma)
  done

subsection {* Every terminating term is in @{text "IT"} *}

declare Var_apps_neq_Abs_apps [symmetric, simp]

lemma [simp, THEN not_sym, simp]: "Var n \<degree>\<degree> ss \<noteq> Abs r \<degree> s \<degree>\<degree> ts"
  by (simp add: foldl_Cons [symmetric] del: foldl_Cons)

inductive_cases [elim!]:
  "IT (Var n \<degree>\<degree> ss)"
  "IT (Abs t)"
  "IT (Abs r \<degree> s \<degree>\<degree> ts)"

theorem termi_implies_IT: "termip beta r ==> IT r"
  apply (erule accp_induct)
  apply (rename_tac r)
  apply (erule thin_rl)
  apply (erule rev_mp)
  apply simp
  apply (rule_tac t = r in Apps_dB_induct)
   apply clarify
   apply (rule IT.intros)
   apply clarify
   apply (drule bspec, assumption)
   apply (erule mp)
   apply clarify
   apply (drule_tac r=beta in conversepI)
   apply (drule_tac r="beta^--1" in ex_step1I, assumption)
   apply clarify
   apply (rename_tac us)
   apply (erule_tac x = "Var n \<degree>\<degree> us" in allE)
   apply force
   apply (rename_tac u ts)
   apply (case_tac ts)
    apply simp
    apply blast
   apply (rename_tac s ss)
   apply simp
   apply clarify
   apply (rule IT.intros)
    apply (blast intro: apps_preserves_beta)
   apply (erule mp)
   apply clarify
   apply (rename_tac t)
   apply (erule_tac x = "Abs u \<degree> t \<degree>\<degree> ss" in allE)
   apply force
   done

end


(*  Title:      HOL/Isar_Examples/Hoare.thy
    Author:     Makarius

A formulation of Hoare logic suitable for Isar.
*)

section \<open>Hoare Logic\<close>

theory Hoare
  imports Main
begin

subsection \<open>Abstract syntax and semantics\<close>

text \<open>
  The following abstract syntax and semantics of Hoare Logic over \<^verbatim>\<open>WHILE\<close>
  programs closely follows the existing tradition in Isabelle/HOL of
  formalizing the presentation given in @{cite \<open>\S6\<close> "Winskel:1993"}. See also
  \<^dir>\<open>~~/src/HOL/Hoare\<close> and @{cite "Nipkow:1998:Winskel"}.
\<close>

type_synonym 'a bexp = "'a set"
type_synonym 'a assn = "'a set"

datatype 'a com =
    Basic "'a \<Rightarrow> 'a"
  | Seq "'a com" "'a com"    ("(_;/ _)" [60, 61] 60)
  | Cond "'a bexp" "'a com" "'a com"
  | While "'a bexp" "'a assn" "'a com"

abbreviation Skip  ("SKIP")
  where "SKIP \<equiv> Basic id"

type_synonym 'a sem = "'a \<Rightarrow> 'a \<Rightarrow> bool"

primrec iter :: "nat \<Rightarrow> 'a bexp \<Rightarrow> 'a sem \<Rightarrow> 'a sem"
  where
    "iter 0 b S s s' \<longleftrightarrow> s \<notin> b \<and> s = s'"
  | "iter (Suc n) b S s s' \<longleftrightarrow> s \<in> b \<and> (\<exists>s''. S s s'' \<and> iter n b S s'' s')"

primrec Sem :: "'a com \<Rightarrow> 'a sem"
  where
    "Sem (Basic f) s s' \<longleftrightarrow> s' = f s"
  | "Sem (c1; c2) s s' \<longleftrightarrow> (\<exists>s''. Sem c1 s s'' \<and> Sem c2 s'' s')"
  | "Sem (Cond b c1 c2) s s' \<longleftrightarrow> (if s \<in> b then Sem c1 s s' else Sem c2 s s')"
  | "Sem (While b x c) s s' \<longleftrightarrow> (\<exists>n. iter n b (Sem c) s s')"

definition Valid :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a bexp \<Rightarrow> bool"  ("(3\<turnstile> _/ (2_)/ _)" [100, 55, 100] 50)
  where "\<turnstile> P c Q \<longleftrightarrow> (\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> P \<longrightarrow> s' \<in> Q)"

lemma ValidI [intro?]: "(\<And>s s'. Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q) \<Longrightarrow> \<turnstile> P c Q"
  by (simp add: Valid_def)

lemma ValidD [dest?]: "\<turnstile> P c Q \<Longrightarrow> Sem c s s' \<Longrightarrow> s \<in> P \<Longrightarrow> s' \<in> Q"
  by (simp add: Valid_def)

subsection \<open>Primitive Hoare rules\<close>

text \<open>
  From the semantics defined above, we derive the standard set of primitive
  Hoare rules; e.g.\ see @{cite \<open>\S6\<close> "Winskel:1993"}. Usually, variant forms
  of these rules are applied in actual proof, see also \S\ref{sec:hoare-isar}
  and \S\ref{sec:hoare-vcg}.

  \<^medskip>
  The \<open>basic\<close> rule represents any kind of atomic access to the state space.
  This subsumes the common rules of \<open>skip\<close> and \<open>assign\<close>, as formulated in
  \S\ref{sec:hoare-isar}.
\<close>

theorem basic: "\<turnstile> {s. f s \<in> P} (Basic f) P"
proof
  fix s s'
  assume s: "s \<in> {s. f s \<in> P}"
  assume "Sem (Basic f) s s'"
  then have "s' = f s" by simp
  with s show "s' \<in> P" by simp
qed

text \<open>
  The rules for sequential commands and semantic consequences are established
  in a straight forward manner as follows.
\<close>

theorem seq: "\<turnstile> P c1 Q \<Longrightarrow> \<turnstile> Q c2 R \<Longrightarrow> \<turnstile> P (c1; c2) R"
proof
  assume cmd1: "\<turnstile> P c1 Q" and cmd2: "\<turnstile> Q c2 R"
  fix s s'
  assume s: "s \<in> P"
  assume "Sem (c1; c2) s s'"
  then obtain s'' where sem1: "Sem c1 s s''" and sem2: "Sem c2 s'' s'"
    by auto
  from cmd1 sem1 s have "s'' \<in> Q" ..
  with cmd2 sem2 show "s' \<in> R" ..
qed

theorem conseq: "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P' c Q'"
proof
  assume P'P: "P' \<subseteq> P" and QQ': "Q \<subseteq> Q'"
  assume cmd: "\<turnstile> P c Q"
  fix s s' :: 'a
  assume sem: "Sem c s s'"
  assume "s : P'" with P'P have "s \<in> P" ..
  with cmd sem have "s' \<in> Q" ..
  with QQ' show "s' \<in> Q'" ..
qed

text \<open>
  The rule for conditional commands is directly reflected by the corresponding
  semantics; in the proof we just have to look closely which cases apply.
\<close>

theorem cond:
  assumes case_b: "\<turnstile> (P \<inter> b) c1 Q"
    and case_nb: "\<turnstile> (P \<inter> -b) c2 Q"
  shows "\<turnstile> P (Cond b c1 c2) Q"
proof
  fix s s'
  assume s: "s \<in> P"
  assume sem: "Sem (Cond b c1 c2) s s'"
  show "s' \<in> Q"
  proof cases
    assume b: "s \<in> b"
    from case_b show ?thesis
    proof
      from sem b show "Sem c1 s s'" by simp
      from s b show "s \<in> P \<inter> b" by simp
    qed
  next
    assume nb: "s \<notin> b"
    from case_nb show ?thesis
    proof
      from sem nb show "Sem c2 s s'" by simp
      from s nb show "s : P \<inter> -b" by simp
    qed
  qed
qed

text \<open>
  The \<open>while\<close> rule is slightly less trivial --- it is the only one based on
  recursion, which is expressed in the semantics by a Kleene-style least
  fixed-point construction. The auxiliary statement below, which is by
  induction on the number of iterations is the main point to be proven; the
  rest is by routine application of the semantics of \<^verbatim>\<open>WHILE\<close>.
\<close>

theorem while:
  assumes body: "\<turnstile> (P \<inter> b) c P"
  shows "\<turnstile> P (While b X c) (P \<inter> -b)"
proof
  fix s s' assume s: "s \<in> P"
  assume "Sem (While b X c) s s'"
  then obtain n where "iter n b (Sem c) s s'" by auto
  from this and s show "s' \<in> P \<inter> -b"
  proof (induct n arbitrary: s)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    then obtain s'' where b: "s \<in> b" and sem: "Sem c s s''"
      and iter: "iter n b (Sem c) s'' s'" by auto
    from Suc and b have "s \<in> P \<inter> b" by simp
    with body sem have "s'' \<in> P" ..
    with iter show ?case by (rule Suc)
  qed
qed

subsection \<open>Concrete syntax for assertions\<close>

text \<open>
  We now introduce concrete syntax for describing commands (with embedded
  expressions) and assertions. The basic technique is that of semantic
  ``quote-antiquote''. A \<^emph>\<open>quotation\<close> is a syntactic entity delimited by an
  implicit abstraction, say over the state space. An \<^emph>\<open>antiquotation\<close> is a
  marked expression within a quotation that refers the implicit argument; a
  typical antiquotation would select (or even update) components from the
  state.

  We will see some examples later in the concrete rules and applications.

  \<^medskip>
  The following specification of syntax and translations is for Isabelle
  experts only; feel free to ignore it.

  While the first part is still a somewhat intelligible specification of the
  concrete syntactic representation of our Hoare language, the actual ``ML
  drivers'' is quite involved. Just note that the we re-use the basic
  quote/antiquote translations as already defined in Isabelle/Pure (see @{ML
  Syntax_Trans.quote_tr}, and @{ML Syntax_Trans.quote_tr'},).
\<close>

syntax
  "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)"
  "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b"  ("\<acute>_" [1000] 1000)
  "_Subst" :: "'a bexp \<Rightarrow> 'b \<Rightarrow> idt \<Rightarrow> 'a bexp"  ("_[_'/\<acute>_]" [1000] 999)
  "_Assert" :: "'a \<Rightarrow> 'a set"  ("(\<lbrace>_\<rbrace>)" [0] 1000)
  "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com"  ("(\<acute>_ :=/ _)" [70, 65] 61)
  "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
  "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
    ("(0WHILE _/ INV _ //DO _ /OD)"  [0, 0, 0] 61)
  "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"  ("(0WHILE _ //DO _ /OD)"  [0, 0] 61)

translations
  "\<lbrace>b\<rbrace>" \<rightharpoonup> "CONST Collect (_quote b)"
  "B [a/\<acute>x]" \<rightharpoonup> "\<lbrace>\<acute>(_update_name x (\<lambda>_. a)) \<in> B\<rbrace>"
  "\<acute>x := a" \<rightharpoonup> "CONST Basic (_quote (\<acute>(_update_name x (\<lambda>_. a))))"
  "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "CONST Cond \<lbrace>b\<rbrace> c1 c2"
  "WHILE b INV i DO c OD" \<rightharpoonup> "CONST While \<lbrace>b\<rbrace> i c"
  "WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"

parse_translation \<open>
  let
    fun quote_tr [t] = Syntax_Trans.quote_tr @{syntax_const "_antiquote"} t
      | quote_tr ts = raise TERM ("quote_tr", ts);
  in [(@{syntax_const "_quote"}, K quote_tr)] end
\<close>

text \<open>
  As usual in Isabelle syntax translations, the part for printing is more
  complicated --- we cannot express parts as macro rules as above. Don't look
  here, unless you have to do similar things for yourself.
\<close>

print_translation \<open>
  let
    fun quote_tr' f (t :: ts) =
          Term.list_comb (f $ Syntax_Trans.quote_tr' @{syntax_const "_antiquote"} t, ts)
      | quote_tr' _ _ = raise Match;

    val assert_tr' = quote_tr' (Syntax.const @{syntax_const "_Assert"});

    fun bexp_tr' name ((Const (@{const_syntax Collect}, _) $ t) :: ts) =
          quote_tr' (Syntax.const name) (t :: ts)
      | bexp_tr' _ _ = raise Match;

    fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
          quote_tr' (Syntax.const @{syntax_const "_Assign"} $ Syntax_Trans.update_name_tr' f)
            (Abs (x, dummyT, Syntax_Trans.const_abs_tr' k) :: ts)
      | assign_tr' _ = raise Match;
  in
   [(@{const_syntax Collect}, K assert_tr'),
    (@{const_syntax Basic}, K assign_tr'),
    (@{const_syntax Cond}, K (bexp_tr' @{syntax_const "_Cond"})),
    (@{const_syntax While}, K (bexp_tr' @{syntax_const "_While_inv"}))]
  end
\<close>

subsection \<open>Rules for single-step proof \label{sec:hoare-isar}\<close>

text \<open>
  We are now ready to introduce a set of Hoare rules to be used in single-step
  structured proofs in Isabelle/Isar. We refer to the concrete syntax
  introduce above.

  \<^medskip>
  Assertions of Hoare Logic may be manipulated in calculational proofs, with
  the inclusion expressed in terms of sets or predicates. Reversed order is
  supported as well.
\<close>

lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> P' \<subseteq> P \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast
lemma [trans] : "P' \<subseteq> P \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P' c Q"
  by (unfold Valid_def) blast

lemma [trans]: "Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast
lemma [trans]: "\<turnstile> P c Q \<Longrightarrow> Q \<subseteq> Q' \<Longrightarrow> \<turnstile> P c Q'"
  by (unfold Valid_def) blast

lemma [trans]:
    "\<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> (\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (simp add: Valid_def)
lemma [trans]:
    "(\<And>s. P' s \<longrightarrow> P s) \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> c Q \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P'\<rbrace> c Q"
  by (simp add: Valid_def)

lemma [trans]:
    "\<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> (\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (simp add: Valid_def)
lemma [trans]:
    "(\<And>s. Q s \<longrightarrow> Q' s) \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q\<rbrace> \<Longrightarrow> \<turnstile> P c \<lbrace>\<acute>Q'\<rbrace>"
  by (simp add: Valid_def)

text \<open>
  Identity and basic assignments.\<^footnote>\<open>The \<open>hoare\<close> method introduced in
  \S\ref{sec:hoare-vcg} is able to provide proper instances for any number of
  basic assignments, without producing additional verification conditions.\<close>
\<close>

lemma skip [intro?]: "\<turnstile> P SKIP P"
proof -
  have "\<turnstile> {s. id s \<in> P} SKIP P" by (rule basic)
  then show ?thesis by simp
qed

lemma assign: "\<turnstile> P [\<acute>a/\<acute>x::'a] \<acute>x := \<acute>a P"
  by (rule basic)

text \<open>
  Note that above formulation of assignment corresponds to our preferred way
  to model state spaces, using (extensible) record types in HOL @{cite
  "Naraschewski-Wenzel:1998:HOOL"}. For any record field \<open>x\<close>, Isabelle/HOL
  provides a functions \<open>x\<close> (selector) and \<open>x_update\<close> (update). Above, there is
  only a place-holder appearing for the latter kind of function: due to
  concrete syntax \<open>\<acute>x := \<acute>a\<close> also contains \<open>x_update\<close>.\<^footnote>\<open>Note that due to the
  external nature of HOL record fields, we could not even state a general
  theorem relating selector and update functions (if this were required here);
  this would only work for any particular instance of record fields introduced
  so far.\<close>

  \<^medskip>
  Sequential composition --- normalizing with associativity achieves proper of
  chunks of code verified separately.
\<close>

lemmas [trans, intro?] = seq

lemma seq_assoc [simp]: "\<turnstile> P c1;(c2;c3) Q \<longleftrightarrow> \<turnstile> P (c1;c2);c3 Q"
  by (auto simp add: Valid_def)

text \<open>Conditional statements.\<close>

lemmas [trans, intro?] = cond

lemma [trans, intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c1 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace> c2 Q
      \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> IF \<acute>b THEN c1 ELSE c2 FI Q"
    by (rule cond) (simp_all add: Valid_def)

text \<open>While statements --- with optional invariant.\<close>

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b P c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]: "\<turnstile> (P \<inter> b) c P \<Longrightarrow> \<turnstile> P (While b undefined c) (P \<inter> -b)"
  by (rule while)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b INV \<lbrace>\<acute>P\<rbrace> DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

lemma [intro?]:
  "\<turnstile> \<lbrace>\<acute>P \<and> \<acute>b\<rbrace> c \<lbrace>\<acute>P\<rbrace>
    \<Longrightarrow> \<turnstile> \<lbrace>\<acute>P\<rbrace> WHILE \<acute>b DO c OD \<lbrace>\<acute>P \<and> \<not> \<acute>b\<rbrace>"
  by (simp add: while Collect_conj_eq Collect_neg_eq)

subsection \<open>Verification conditions \label{sec:hoare-vcg}\<close>

text \<open>
  We now load the \<^emph>\<open>original\<close> ML file for proof scripts and tactic definition
  for the Hoare Verification Condition Generator (see \<^dir>\<open>~~/src/HOL/Hoare\<close>).
  As far as we are concerned here, the result is a proof method \<open>hoare\<close>, which
  may be applied to a Hoare Logic assertion to extract purely logical
  verification conditions. It is important to note that the method requires
  \<^verbatim>\<open>WHILE\<close> loops to be fully annotated with invariants beforehand.
  Furthermore, only \<^emph>\<open>concrete\<close> pieces of code are handled --- the underlying
  tactic fails ungracefully if supplied with meta-variables or parameters, for
  example.
\<close>

lemma SkipRule: "p \<subseteq> q \<Longrightarrow> Valid p (Basic id) q"
  by (auto simp add: Valid_def)

lemma BasicRule: "p \<subseteq> {s. f s \<in> q} \<Longrightarrow> Valid p (Basic f) q"
  by (auto simp: Valid_def)

lemma SeqRule: "Valid P c1 Q \<Longrightarrow> Valid Q c2 R \<Longrightarrow> Valid P (c1;c2) R"
  by (auto simp: Valid_def)

lemma CondRule:
  "p \<subseteq> {s. (s \<in> b \<longrightarrow> s \<in> w) \<and> (s \<notin> b \<longrightarrow> s \<in> w')}
    \<Longrightarrow> Valid w c1 q \<Longrightarrow> Valid w' c2 q \<Longrightarrow> Valid p (Cond b c1 c2) q"
  by (auto simp: Valid_def)

lemma iter_aux:
  "\<forall>s s'. Sem c s s' \<longrightarrow> s \<in> I \<and> s \<in> b \<longrightarrow> s' \<in> I \<Longrightarrow>
       (\<And>s s'. s \<in> I \<Longrightarrow> iter n b (Sem c) s s' \<Longrightarrow> s' \<in> I \<and> s' \<notin> b)"
  by (induct n) auto

lemma WhileRule:
    "p \<subseteq> i \<Longrightarrow> Valid (i \<inter> b) c i \<Longrightarrow> i \<inter> (-b) \<subseteq> q \<Longrightarrow> Valid p (While b i c) q"
  apply (clarsimp simp: Valid_def)
  apply (drule iter_aux)
    prefer 2
    apply assumption
   apply blast
  apply blast
  done

lemma Compl_Collect: "- Collect b = {x. \<not> b x}"
  by blast

lemmas AbortRule = SkipRule  \<comment> "dummy version"

ML_file "~~/src/HOL/Hoare/hoare_tac.ML"

method_setup hoare =
  \<open>Scan.succeed (fn ctxt =>
    (SIMPLE_METHOD'
      (Hoare.hoare_tac ctxt
        (simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm "Record.K_record_comp"}] )))))\<close>
  "verification condition generator for Hoare logic"

end