section \<open>Boolean Algebra of Assertions\<close>

theory  Assertion_Algebra
imports Mono_Bool_Tran_Algebra
begin

text\<open>
This section introduces the boolean algebra of assertions. The
type $\mathsf{Assertion}$ and the boolean operation are instroduced
based on the set $\mathsf{assertion}$ and the operations on the monotonic
boolean transformers algebra. The type $\mathsf{Assertion}$ over
a complete monotonic boolean transformers algebra is a complete boolean
algebra.
\<close>

typedef (overloaded) ('a::mbt_algebra) Assertion = "assertion::'a set"
  apply (rule_tac x = "\<bottom>" in exI)
  by (unfold assertion_def, simp)

definition
  assert :: "'a::mbt_algebra Assertion \<Rightarrow> 'a"  ("{\<cdot> _ }" [0] 1000) where
  "{\<cdot>p} =  Rep_Assertion p"

definition
  "abs_wpt x = Abs_Assertion (wpt x)"

lemma [simp]: "abs_wpt ({\<cdot>p}) = p"
  apply (simp add: abs_wpt_def)
  by (simp add: assert_def Rep_Assertion_inverse)

lemma [simp]: "x \<in> assertion \<Longrightarrow> {\<cdot>Abs_Assertion x} = x"
  apply (simp add: assert_def)
  by (rule Abs_Assertion_inverse, simp)

lemma [simp]: "x \<in> assertion \<Longrightarrow> {\<cdot>abs_wpt x} = x"
  apply (simp add: abs_wpt_def assert_def)
  by (rule Abs_Assertion_inverse, simp)

lemma assert_injective: "{\<cdot>p} = {\<cdot>q} \<Longrightarrow> p = q"
  proof -
    assume A: "{\<cdot> p } = {\<cdot> q } "
    have "p = abs_wpt ({\<cdot>p})" by simp
    also have "... = q" by (subst A, simp)
    finally show ?thesis .
  qed

instantiation Assertion :: (mbt_algebra) boolean_algebra
begin
  definition
    uminus_Assertion_def: "- p = abs_wpt(neg_assert {\<cdot>p})"

  definition
    bot_Assertion_def: "\<bottom> = abs_wpt \<bottom>"

  definition
    top_Assertion_def: "\<top> = abs_wpt 1"

  definition
    inf_Assertion_def: "p \<sqinter> q = abs_wpt ({\<cdot>p} \<sqinter> {\<cdot>q})"

  definition
    sup_Assertion_def: "p \<squnion> q = abs_wpt ({\<cdot>p} \<squnion> {\<cdot>q})"

  definition
    less_eq_Assertion_def: "(p \<le> q) = ({\<cdot>p} \<le>  {\<cdot>q})"

  definition
    less_Assertion_def: "(p < q) = ({\<cdot>p} < {\<cdot>q})"

  definition
    minus_Assertion_def: "(p::'a Assertion) - q = p \<sqinter> - q"

instance
  proof
    fix x y :: "'a Assertion" show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
      by (simp add: less_Assertion_def less_eq_Assertion_def less_le_not_le)
  next
    fix x ::"'a Assertion" show "x \<le> x" by (simp add: less_eq_Assertion_def)
  next
    fix x y z :: "'a Assertion" assume A: "x \<le> y" assume B: "y \<le> z" from A and B show "x \<le> z"
      by (simp add: less_eq_Assertion_def)
  next
    fix x y :: "'a Assertion" assume A: "x \<le> y" assume B: "y \<le> x" from A and B show "x = y"
      apply (cut_tac p = x and q = y in assert_injective)
      by (rule antisym, simp_all add: less_eq_Assertion_def)
  next
    fix x y :: "'a Assertion" show "x \<sqinter> y \<le> x"
      by (simp add: less_eq_Assertion_def inf_Assertion_def)
    fix x y :: "'a Assertion" show "x \<sqinter> y \<le> y"
      by (simp add: less_eq_Assertion_def inf_Assertion_def)
  next
    fix x y z :: "'a Assertion" assume A: "x \<le> y" assume B: "x \<le> z" from A and B show "x \<le> y \<sqinter> z"
      by (simp add: less_eq_Assertion_def inf_Assertion_def)
  next
    fix x y :: "'a Assertion" show "x \<le> x \<squnion> y"
      by (simp add: less_eq_Assertion_def sup_Assertion_def)
    fix x y :: "'a Assertion" show "y \<le> x \<squnion> y"
      by (simp add: less_eq_Assertion_def sup_Assertion_def)
  next
    fix x y z :: "'a Assertion" assume A: "y \<le> x" assume B: "z \<le> x" from A and B show "y \<squnion> z \<le> x"
      by (simp add: less_eq_Assertion_def sup_Assertion_def)
  next
    fix x :: "'a Assertion" show "\<bottom> \<le> x"
      by (simp add: less_eq_Assertion_def bot_Assertion_def)
  next
    fix x :: "'a Assertion" show "x \<le> \<top>"
      by (simp add: less_eq_Assertion_def top_Assertion_def)
  next
    fix x y z :: "'a Assertion" show "x \<squnion> y \<sqinter> z = (x \<squnion> y) \<sqinter> (x \<squnion> z)"
      by (simp add: less_eq_Assertion_def sup_Assertion_def inf_Assertion_def sup_inf_distrib)
  next
    fix x :: "'a Assertion" show "x \<sqinter> - x = \<bottom>"
      by (simp add: inf_Assertion_def uminus_Assertion_def bot_Assertion_def)
  next
    fix x :: "'a Assertion" show "x \<squnion> - x = \<top>"
      by (simp add: sup_Assertion_def uminus_Assertion_def top_Assertion_def)
  next
    fix x y :: "'a Assertion" show "x - y = x \<sqinter> - y"
      by (simp add: minus_Assertion_def)
  qed

end

lemma assert_image [simp]: "assert ` A \<subseteq> assertion"
  by auto

instantiation Assertion :: (complete_mbt_algebra) complete_lattice
begin
  definition
    Sup_Assertion_def: "Sup A = abs_wpt (Sup (assert ` A))"

  definition
    Inf_Assertion_def: "Inf (A::('a Assertion) set) = - (Sup (uminus ` A))"

lemma Sup1: "(x::'a Assertion) \<in> A \<Longrightarrow> x \<le> Sup A"
    apply (simp add: Sup_Assertion_def less_eq_Assertion_def Abs_Assertion_inverse)
    by (rule Sup_upper, simp)

lemma Sup2: "(\<And>x::'a Assertion . x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup A \<le> z"
    apply (simp add: Sup_Assertion_def less_eq_Assertion_def Abs_Assertion_inverse)
    apply (rule Sup_least)
    by blast

instance
proof
  fix x :: "'a Assertion" fix A assume A: "x \<in> A" from A show "Inf A \<le> x"
    apply (simp add: Inf_Assertion_def)
    apply (subst compl_le_compl_iff [THEN sym], simp)
    by (rule Sup1, simp)
next
  fix z :: "'a Assertion" fix A assume A: "\<And>x . x \<in> A \<Longrightarrow> z \<le> x" from A show "z \<le> Inf A"
    apply (simp add: Inf_Assertion_def)
    apply (subst compl_le_compl_iff [THEN sym], simp)
    apply (rule Sup2)
    apply safe
    by simp
next
  fix x :: "'a Assertion" fix A assume A: "x \<in> A" from A show "x \<le> Sup A"
    by (rule Sup1)
next
  fix z :: "'a Assertion" fix A assume A: "\<And>x . x \<in> A \<Longrightarrow> x \<le> z" from A show "Sup A \<le> z"
    by (rule Sup2)
next
  show "Inf {} = (\<top>::'a Assertion)"
    by (auto simp: Inf_Assertion_def Sup_Assertion_def compl_bot_eq [symmetric] bot_Assertion_def)
next
  show "Sup {} = (\<bottom>::'a Assertion)"
    by (auto simp: Sup_Assertion_def bot_Assertion_def)
qed
end

lemma assert_top [simp]: "{\<cdot>\<top>} = 1"
  by (simp add: top_Assertion_def)

lemma assert_Sup: "{\<cdot>Sup A} = Sup (assert ` A)"
  by (simp add: Sup_Assertion_def Abs_Assertion_inverse)

lemma assert_Inf: "{\<cdot>Inf A} = (Inf (assert ` A)) \<sqinter> 1"
proof (cases "A = {}")
  case True then show ?thesis by simp
next
  note image_cong_simp [cong del]
  case False then show ?thesis
  apply (simp add: Inf_Assertion_def uminus_Assertion_def)
  apply (simp add: neg_assert_def assert_Sup dual_Sup Inf_comp inf_commute inf_Inf comp_def)
  apply (rule_tac f = Inf in arg_cong)
  apply safe
  apply simp
  apply (subst inf_commute)
  apply (simp add: image_def uminus_Assertion_def)
  apply (simp add: neg_assert_def dual_comp dual_inf sup_comp assertion_prop)
  apply auto [1]
  apply (simp)
  apply (subst image_def, simp)
  apply (simp add: uminus_Assertion_def)
  apply (subst inf_commute)
  apply (simp add: neg_assert_def dual_comp dual_inf sup_comp assertion_prop)
  apply auto
  done
qed

lemma assert_Inf_ne: "A \<noteq> {} \<Longrightarrow> {\<cdot>Inf A} = Inf (assert ` A)"
  apply (unfold assert_Inf)
  apply (rule antisym)
  apply simp_all
  apply safe
  apply (erule notE)
  apply (rule_tac y = "{\<cdot>x}" in order_trans)
  by (simp_all add: INF_lower)

lemma assert_Sup_range: "{\<cdot>Sup (range p)} = Sup (range (assert o p))"
  apply (subst assert_Sup)
  by (rule_tac f = "Sup" in arg_cong, auto)

lemma assert_Sup_less: "{\<cdot> Sup_less p w } = Sup_less (assert o p) w"
  apply (simp add: Sup_less_def)
  apply (subst assert_Sup)
  by (rule_tac f = "Sup" in arg_cong, auto)

end


(** Score: 9/10 *)

(** 1 point deducted for one "sorry".
 The proof would have been identical to the If case.
*)

theory GabrielaLimonta2
imports "~~/src/HOL/IMP/BExp"
begin

(* Homework 11.2 *)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
(* begin mod *)
      | Or     com  com         ("_ OR/ _" [60, 61] 60)
(* end mod *)

inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
(* begin mod *)
Or1: "(c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t" |
Or2: "(c\<^sub>2, s) \<Rightarrow> t \<Longrightarrow> (c\<^sub>1 OR c\<^sub>2, s) \<Rightarrow> t"
(* end mod *)
text_raw{*}%endsnip*}

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

(* begin mod *)
inductive_cases OrE[elim]: "(c1 OR c2, s) \<Rightarrow> t"
thm OrE
(* end mod *)

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

type_synonym assn = "state \<Rightarrow> bool"

definition
hoare_valid :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> {(1_)}/ (_)/ {(1_)}" 50) where
"\<Turnstile> {P}c{Q} = (\<forall>s t. P s \<and> (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

abbreviation state_subst :: "state \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> state"
  ("_[_'/_]" [1000,0,0] 999)
where "s[a/x] == s(x := aval a s)"

inductive
  hoare :: "assn \<Rightarrow> com \<Rightarrow> assn \<Rightarrow> bool" ("\<turnstile> ({(1_)}/ (_)/ {(1_)})" 50)
where
Skip: "\<turnstile> {P} SKIP {P}"  |

Assign:  "\<turnstile> {\<lambda>s. P(s[a/x])} x::=a {P}"  |

Seq: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {Q} c\<^sub>2 {R} \<rbrakk>
      \<Longrightarrow> \<turnstile> {P} c\<^sub>1;;c\<^sub>2 {R}"  |

If: "\<lbrakk> \<turnstile> {\<lambda>s. P s \<and> bval b s} c\<^sub>1 {Q};  \<turnstile> {\<lambda>s. P s \<and> \<not> bval b s} c\<^sub>2 {Q} \<rbrakk>
     \<Longrightarrow> \<turnstile> {P} IF b THEN c\<^sub>1 ELSE c\<^sub>2 {Q}"  |

While: "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P} \<Longrightarrow>
        \<turnstile> {P} WHILE b DO c {\<lambda>s. P s \<and> \<not> bval b s}"  |

conseq: "\<lbrakk> \<forall>s. P' s \<longrightarrow> P s;  \<turnstile> {P} c {Q};  \<forall>s. Q s \<longrightarrow> Q' s \<rbrakk>
        \<Longrightarrow> \<turnstile> {P'} c {Q'}" |

(* begin mod *)
Or: "\<lbrakk> \<turnstile> {P} c\<^sub>1 {Q};  \<turnstile> {P} c\<^sub>2 {Q} \<rbrakk>
      \<Longrightarrow> \<turnstile> {P} c\<^sub>1 OR c\<^sub>2 {Q}"
(* end mod *)

lemmas [simp] = hoare.Skip hoare.Assign hoare.Seq If

lemmas [intro!] = hoare.Skip hoare.Assign hoare.Seq hoare.If

text{* The assignment and While rule are awkward to use in actual proofs
because their pre and postcondition are of a very special form and the actual
goal would have to match this form exactly. Therefore we derive two variants
with arbitrary pre and postconditions. *}

lemma Assign': "\<forall>s. P s \<longrightarrow> Q(s[a/x]) \<Longrightarrow> \<turnstile> {P} x ::= a {Q}"
by (simp add: strengthen_pre[OF _ Assign])

lemma While':
assumes "\<turnstile> {\<lambda>s. P s \<and> bval b s} c {P}" and "\<forall>s. P s \<and> \<not> bval b s \<longrightarrow> Q s"
shows "\<turnstile> {P} WHILE b DO c {Q}"
by(rule weaken_post[OF While[OF assms(1)] assms(2)])

subsection "Soundness"

lemma hoare_sound: "\<turnstile> {P}c{Q}  \<Longrightarrow>  \<Turnstile> {P}c{Q}"
proof(induction rule: hoare.induct)
  case (While P b c)
  { fix s t
    have "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow>  P s  \<Longrightarrow>  P t \<and> \<not> bval b t"
    proof(induction "WHILE b DO c" s t rule: big_step_induct)
      case WhileFalse thus ?case by blast
    next
      case WhileTrue thus ?case
        using While.IH unfolding hoare_valid_def by blast
    qed
  }
  thus ?case unfolding hoare_valid_def by blast
qed (auto simp: hoare_valid_def)

subsection "Weakest Precondition"

definition wp :: "com \<Rightarrow> assn \<Rightarrow> assn" where
"wp c Q = (\<lambda>s. \<forall>t. (c,s) \<Rightarrow> t  \<longrightarrow>  Q t)"

lemma wp_SKIP[simp]: "wp SKIP Q = Q"
by (rule ext) (auto simp: wp_def)

lemma wp_Ass[simp]: "wp (x::=a) Q = (\<lambda>s. Q(s[a/x]))"
by (rule ext) (auto simp: wp_def)

lemma wp_Seq[simp]: "wp (c\<^sub>1;;c\<^sub>2) Q = wp c\<^sub>1 (wp c\<^sub>2 Q)"
by (rule ext) (auto simp: wp_def)

lemma wp_If[simp]:
 "wp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) Q =
 (\<lambda>s. if bval b s then wp c\<^sub>1 Q s else wp c\<^sub>2 Q s)"
by (rule ext) (auto simp: wp_def)

lemma wp_While_If:
 "wp (WHILE b DO c) Q s =
  wp (IF b THEN c;;WHILE b DO c ELSE SKIP) Q s"
unfolding wp_def by (metis unfold_while)

lemma wp_While_True[simp]: "bval b s \<Longrightarrow>
  wp (WHILE b DO c) Q s = wp (c;; WHILE b DO c) Q s"
by(simp add: wp_While_If)

lemma wp_While_False[simp]: "\<not> bval b s \<Longrightarrow> wp (WHILE b DO c) Q s = Q s"
by(simp add: wp_While_If)

lemma wp_Or: "wp (c1 OR c2) Q s = (wp c1 Q s \<and> wp c2 Q s)"
unfolding wp_def
by auto

subsection "Completeness"

lemma wp_is_pre: "\<turnstile> {wp c Q} c {Q}"
proof(induction c arbitrary: Q)
  case If thus ?case by(auto intro: conseq)
next
  case (While b c)
  let ?w = "WHILE b DO c"
  show "\<turnstile> {wp ?w Q} ?w {Q}"
  proof(rule While')
    show "\<turnstile> {\<lambda>s. wp ?w Q s \<and> bval b s} c {wp ?w Q}"
    proof(rule strengthen_pre[OF _ While.IH])
      show "\<forall>s. wp ?w Q s \<and> bval b s \<longrightarrow> wp c (wp ?w Q) s" by auto
    qed
    show "\<forall>s. wp ?w Q s \<and> \<not> bval b s \<longrightarrow> Q s" by auto
  qed
next
(* begin mod *)
  case (Or c1 c2)
  from this and wp_Or and big_step.Or1 and big_step.Or2
  show ?case unfolding wp_def sorry
(* end mod *)
qed auto

lemma hoare_complete: assumes "\<Turnstile> {P}c{Q}" shows "\<turnstile> {P}c{Q}"
proof(rule strengthen_pre)
  show "\<forall>s. P s \<longrightarrow> wp c Q s" using assms
    by (auto simp: hoare_valid_def wp_def)
  show "\<turnstile> {wp c Q} c {Q}" by(rule wp_is_pre)
qed

corollary hoare_sound_complete: "\<turnstile> {P}c{Q} \<longleftrightarrow> \<Turnstile> {P}c{Q}"
by (metis hoare_complete hoare_sound)

end


section "Exact nonstandard semantics"

theory ExCF
  imports HOLCF HOLCFUtils CPSScheme Utils
begin

text \<open>
We now alter the standard semantics given in the previous section to calculate a control flow graph instead of the return value. At this point, we still ``run'' the program in full, so this is not yet the static analysis that we aim for. Instead, this is the reference for the correctness proof of the static analysis: If an edge is recorded here, we expect it to be found by the static analysis as well.
\<close>

text \<open>
In preparation of the correctness proof we change the type of the contour counters. Instead of plain natural numbers as in the previous sections we use lists of labels, remembering at each step which part of the program was just evaluated.

Note that for the exact semantics, this is information is not used in any way and it would have been possible to just use natural numbers again. This is reflected by the preorder instance for the contours which only look at the length of the list, but not the entries.
\<close>

definition "contour = (UNIV::label list set)"

typedef contour = contour
  unfolding contour_def by auto

definition initial_contour ("\<binit>")
  where "\<binit> = Abs_contour []"

definition nb
  where "nb b c = Abs_contour (c # Rep_contour b)"

instantiation contour :: preorder
begin
definition le_contour_def: "b \<le> b' \<longleftrightarrow> length (Rep_contour b) \<le> length (Rep_contour b')"
definition less_contour_def: "b < b' \<longleftrightarrow> length (Rep_contour b) < length (Rep_contour b')"
instance proof
qed(auto simp add:le_contour_def less_contour_def Rep_contour_inverse Abs_contour_inverse contour_def)
end

text \<open>
Three simple lemmas helping Isabelle to automatically prove statements about contour numbers.
\<close>

lemma nb_le_less[iff]: "nb b c \<le> b' \<longleftrightarrow> b < b'"
  unfolding nb_def
  by (auto simp add:le_contour_def less_contour_def Rep_contour_inverse Abs_contour_inverse contour_def)

lemma nb_less[iff]: "b' < nb b c \<longleftrightarrow> b' \<le> b"
  unfolding nb_def
  by (auto simp add:le_contour_def less_contour_def Rep_contour_inverse Abs_contour_inverse contour_def)

declare less_imp_le[where 'a = contour, intro]

text \<open>
The other types used in our semantics functions have not changed.
\<close>

type_synonym benv = "label \<rightharpoonup> contour"
type_synonym closure = "lambda \<times> benv"

datatype d = DI int
           | DC closure
           | DP prim
           | Stop

type_synonym venv = "var \<times> contour \<rightharpoonup> d"

text \<open>
As we do not use the type system to distinguish procedural from non-procedural values, we define a predicate for that.
\<close>

primrec isProc
  where "isProc (DI _) = False"
      | "isProc (DC _) = True"
      | "isProc (DP _) = True"
      | "isProc Stop   = True"

text \<open>
To please @{theory HOLCF}, we declare the discrete partial order for our types:
\<close>

instantiation contour :: discrete_cpo
begin
definition [simp]: "(x::contour) \<sqsubseteq> y \<longleftrightarrow> x = y"
instance by standard simp
end
instantiation d :: discrete_cpo begin
definition  [simp]: "(x::d) \<sqsubseteq> y \<longleftrightarrow> x = y"
instance by standard simp
end

instantiation call :: discrete_cpo begin
definition  [simp]: "(x::call) \<sqsubseteq> y \<longleftrightarrow> x = y"
instance by standard simp
end

text \<open>
The evaluation function for values has only changed slightly: To avoid worrying about incorrect programs, we return zero when a variable lookup fails. If the labels in the program given are correct, this will not happen. Shivers makes this explicit in Section 4.1.3 by restricting the function domains to the valid programs. This is omitted here.
\<close>

fun evalV :: "val \<Rightarrow> benv \<Rightarrow> venv \<Rightarrow> d" ("\<A>")
  where "\<A> (C _ i) \<beta> ve = DI i"
  |     "\<A> (P prim) \<beta> ve = DP prim"
  |     "\<A> (R _ var) \<beta> ve =
           (case \<beta> (binder var) of
              Some l \<Rightarrow> (case ve (var,l) of Some d \<Rightarrow> d | None \<Rightarrow> DI 0)
             | None \<Rightarrow> DI 0)"
  |     "\<A> (L lam) \<beta> ve = DC (lam, \<beta>)"

text \<open>
To be able to do case analysis on the custom datatypes \<open>lambda\<close>, \<open>d\<close>, \<open>call\<close> and \<open>prim\<close> inside a function defined with \<open>fixrec\<close>, we need continuity results for them. These are all of the same shape and proven by case analysis on the discriminator.
\<close>

lemma cont2cont_case_lambda [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f x a b c)"
  shows "cont (\<lambda>x. case_lambda (f x) l)"
using assms
by (cases l) auto

lemma cont2cont_case_d [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y. cont (\<lambda>x. f2 x y)"
     and  "\<And>y. cont (\<lambda>x. f3 x y)"
    and   "cont (\<lambda>x. f4 x)"
  shows "cont (\<lambda>x. case_d (f1 x) (f2 x) (f3 x) (f4 x) d)"
using assms
by (cases d) auto

lemma cont2cont_case_call [simp, cont2cont]:
  assumes "\<And>a b c. cont (\<lambda>x. f1 x a b c)"
     and  "\<And>a b c. cont (\<lambda>x. f2 x a b c)"
  shows "cont (\<lambda>x. case_call (f1 x) (f2 x) c)"
using assms
by (cases c) auto

lemma cont2cont_case_prim [simp, cont2cont]:
  assumes "\<And>y. cont (\<lambda>x. f1 x y)"
     and  "\<And>y z. cont (\<lambda>x. f2 x y z)"
  shows "cont (\<lambda>x. case_prim (f1 x) (f2 x) p)"
using assms
by (cases p) auto

text \<open>
Now, our answer domain is not any more the integers, but rather call caches. These are represented as sets containing tuples of call sites (given by their label) and binding environments to the called value. The argument types are unaltered.

In the functions \<open>\<F>\<close> and \<open>\<C>\<close>, upon every call, a new element is added to the resulting set. The \<open>STOP\<close> continuation now ignores its argument and retuns the empty set instead. This corresponds to Figure 4.2 and 4.3 in Shivers' dissertation.
\<close>

type_synonym ccache = "((label \<times> benv) \<times> d) set"
type_synonym ans = ccache

type_synonym fstate = "(d \<times> d list \<times> venv \<times> contour)"
type_synonym cstate = "(call \<times> benv \<times> venv \<times> contour)"

fixrec   evalF :: "fstate discr \<rightarrow> ans" ("\<F>")
     and evalC :: "cstate discr \<rightarrow> ans" ("\<C>")
  where "\<F>\<cdot>fstate = (case undiscr fstate of
             (DC (Lambda lab vs c, \<beta>), as, ve, b) \<Rightarrow>
               (if length vs = length as
                then let \<beta>' = \<beta> (lab \<mapsto> b);
                         ve' = map_upds ve (map (\<lambda>v.(v,b)) vs) as
                     in \<C>\<cdot>(Discr (c,\<beta>',ve',b))
                else \<bottom>)
            | (DP (Plus c),[DI a1, DI a2, cnt],ve,b) \<Rightarrow>
                (if isProc cnt
                 then let b' = nb b c;
                          \<beta>  = [c \<mapsto> b]
                      in \<F>\<cdot>(Discr (cnt,[DI (a1 + a2)],ve,b'))
                        \<union> {((c, \<beta>),cnt)}
                 else \<bottom>)
            | (DP (prim.If ct cf),[DI v, contt, contf],ve,b) \<Rightarrow>
                (if isProc contt \<and> isProc contf
                 then
                  (if v \<noteq> 0
                   then let b' = nb b ct;
                            \<beta> = [ct \<mapsto> b]
                        in (\<F>\<cdot>(Discr (contt,[],ve,b'))
                            \<union> {((ct, \<beta>),contt)})
                   else let b' = nb b cf;
                            \<beta> = [cf \<mapsto> b]
                        in (\<F>\<cdot>(Discr (contf,[],ve,b')))
                            \<union> {((cf, \<beta>),contf)})
                 else \<bottom>)
            | (Stop,[DI i],_,_) \<Rightarrow> {}
            | _ \<Rightarrow> \<bottom>
        )"
      | "\<C>\<cdot>cstate = (case undiscr cstate of
             (App lab f vs,\<beta>,ve,b) \<Rightarrow>
                 let f' = \<A> f \<beta> ve;
                     as = map (\<lambda>v. \<A> v \<beta> ve) vs;
                     b' = nb b lab
                  in if isProc f'
                     then \<F>\<cdot>(Discr (f',as,ve,b')) \<union> {((lab, \<beta>),f')}
                     else \<bottom>
            | (Let lab ls c',\<beta>,ve,b) \<Rightarrow>
                 let b' = nb b lab;
                     \<beta>' = \<beta> (lab \<mapsto> b');
                    ve' = ve ++ map_of (map (\<lambda>(v,l). ((v,b'), \<A> (L l) \<beta>' ve)) ls)
                 in \<C>\<cdot>(Discr (c',\<beta>',ve',b'))
        )"

text \<open>
In preparation of later proofs, we give the cases of the generated induction rule names and also create a large rule to deconstruct the an value of type \<open>fstate\<close> into the various cases that were used in the definition of \<open>\<F>\<close>.
\<close>

lemmas evalF_evalC_induct = evalF_evalC.induct[case_names Admissibility Bottom Next]

lemmas cl_cases = prod.exhaust[OF lambda.exhaust, of _ "\<lambda> a _ . a"]
lemmas ds_cases_plus = list.exhaust[
  OF _ d.exhaust, of _ _ "\<lambda>a _. a",
  OF _ list.exhaust, of _ _ "\<lambda>_ x _. x",
  OF _ _ d.exhaust, of _ _ "\<lambda>_ _ _ a _. a",
  OF _ _ list.exhaust,of _ _ "\<lambda>_ _ _ _ x _. x",
  OF _ _ _ list.exhaust,of _ _ "\<lambda>_ _ _ _ _ _ _ x. x"
  ]
lemmas ds_cases_if = list.exhaust[OF _ d.exhaust, of _ _ "\<lambda>a _. a",
  OF _ list.exhaust[OF _ list.exhaust[OF _ list.exhaust, of _ _ "\<lambda>_ x. x"], of _ _ "\<lambda>_ x. x"], of _ _ "\<lambda>_ x _. x"]
lemmas ds_cases_stop = list.exhaust[OF _ d.exhaust, of _ _ "\<lambda>a _. a",
  OF _ list.exhaust, of _ _ "\<lambda>_ x _. x"]
lemmas fstate_case = prod_cases4[OF d.exhaust, of _ "\<lambda>x _ _ _ . x",
  OF _ cl_cases prim.exhaust, of _ _ "\<lambda> _ _ _ _ a . a" "\<lambda> _ _ _ _ a. a",
  OF _ case_split ds_cases_plus ds_cases_if ds_cases_stop,
  of _ _ "\<lambda>_ as _ _ _ _ _ _ vs _ . length vs = length as" "\<lambda> _ ds _ _ _ _ . ds" "\<lambda> _ ds _ _ _ _ _. ds" "\<lambda> _ ds _ _. ds",
  case_names "x" "Closure" "x" "x"  "x" "x" "Plus" "x" "x" "x" "x" "x" "x" "x" "x"   "x" "x" "If_True" "If_False" "x" "x" "x" "x" "x" "Stop"  "x" "x" "x" "x" "x"]

text \<open>
The exact semantics of a program again uses \<open>\<F>\<close> with properly initialized arguments. For the first two examples, we see that the function works as expected.
\<close>

definition evalCPS :: "prog \<Rightarrow> ans" ("\<PR>")
  where "\<PR> l = (let ve = Map.empty;
                          \<beta> = Map.empty;
                          f = \<A> (L l) \<beta> ve
                      in  \<F>\<cdot>(Discr (f,[Stop],ve,\<binit>)))"

lemma correct_ex1: "\<PR> ex1 = {((2,[1 \<mapsto> \<binit>]), Stop)}"
unfolding evalCPS_def
by simp

lemma correct_ex2: "\<PR> ex2 = {((2, [1 \<mapsto> \<binit>]), DP (Plus 3)),
                                   ((3, [3 \<mapsto> nb \<binit> 2]),  Stop)}"
unfolding evalCPS_def
by simp

end


theory Lmap_map
  imports Main "$HIPSTER_HOME/IsaHipster"
    "Lmap"
    "To_Llist"
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

(* cohipster lmap map to_llist *)
(* Found and proved in ca. 70 seconds *)
lemma lemma_ac [thy_expl]: "to_llist (map y z) = lmap y (to_llist z)"
  apply (induct z)
apply (simp add: lmap.ctr(1))
apply (simp add: lemma_aa)
done

end


(*  Title:      HOL/HOLCF/FOCUS/Buffer.thy
    Author:     David von Oheimb, TU Muenchen

Formalization of section 4 of

@inproceedings {broy_mod94,
    author = {Manfred Broy},
    title = {{Specification and Refinement of a Buffer of Length One}},
    booktitle = {Deductive Program Design},
    year = {1994},
    editor = {Manfred Broy},
    volume = {152},
    series = {ASI Series, Series F: Computer and System Sciences},
    pages = {273 -- 304},
    publisher = {Springer}
}

Slides available from http://ddvo.net/talks/1-Buffer.ps.gz

*)

theory Buffer
imports FOCUS
begin

typedecl D

datatype
  M     = Md D | Mreq ("\<bullet>")

datatype
  State = Sd D | Snil ("\<currency>")

type_synonym
  SPF11         = "M fstream \<rightarrow> D fstream"

type_synonym
  SPEC11        = "SPF11 set"

type_synonym
  SPSF11        = "State \<Rightarrow> SPF11"

type_synonym
  SPECS11       = "SPSF11 set"

definition
  BufEq_F       :: "SPEC11 \<Rightarrow> SPEC11" where
  "BufEq_F B = {f. \<forall>d. f\<cdot>(Md d\<leadsto><>) = <> \<and>
                (\<forall>x. \<exists>ff\<in>B. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x)}"

definition
  BufEq         :: "SPEC11" where
  "BufEq = gfp BufEq_F"

definition
  BufEq_alt     :: "SPEC11" where
  "BufEq_alt = gfp (\<lambda>B. {f. \<forall>d. f\<cdot>(Md d\<leadsto><> ) = <> \<and>
                         (\<exists>ff\<in>B. (\<forall>x. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x))})"

definition
  BufAC_Asm_F   :: " (M fstream set) \<Rightarrow> (M fstream set)" where
  "BufAC_Asm_F A = {s. s = <> \<or>
                  (\<exists>d x. s = Md d\<leadsto>x \<and> (x = <> \<or> (ft\<cdot>x = Def \<bullet> \<and> (rt\<cdot>x)\<in>A)))}"

definition
  BufAC_Asm     :: " (M fstream set)" where
  "BufAC_Asm = gfp BufAC_Asm_F"

definition
  BufAC_Cmt_F   :: "((M fstream * D fstream) set) \<Rightarrow>
                    ((M fstream * D fstream) set)" where
  "BufAC_Cmt_F C = {(s,t). \<forall>d x.
                           (s = <>         \<longrightarrow>     t = <>                 ) \<and>
                           (s = Md d\<leadsto><>   \<longrightarrow>     t = <>                 ) \<and>
                           (s = Md d\<leadsto>\<bullet>\<leadsto>x \<longrightarrow> (ft\<cdot>t = Def d \<and> (x,rt\<cdot>t)\<in>C))}"

definition
  BufAC_Cmt     :: "((M fstream * D fstream) set)" where
  "BufAC_Cmt = gfp BufAC_Cmt_F"

definition
  BufAC         :: "SPEC11" where
  "BufAC = {f. \<forall>x. x\<in>BufAC_Asm \<longrightarrow> (x,f\<cdot>x)\<in>BufAC_Cmt}"

definition
  BufSt_F       :: "SPECS11 \<Rightarrow> SPECS11" where
  "BufSt_F H = {h. \<forall>s  . h s      \<cdot><>        = <>         \<and>
                                 (\<forall>d x. h \<currency>     \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x \<and>
                                (\<exists>hh\<in>H. h (Sd d)\<cdot>(\<bullet>   \<leadsto>x) = d\<leadsto>(hh \<currency>\<cdot>x)))}"

definition
  BufSt_P       :: "SPECS11" where
  "BufSt_P = gfp BufSt_F"

definition
  BufSt         :: "SPEC11" where
  "BufSt = {f. \<exists>h\<in>BufSt_P. f = h \<currency>}"

lemma set_cong: "\<And>X. A = B \<Longrightarrow> (x\<in>A) = (x\<in>B)"
by (erule subst, rule refl)

(**** BufEq *******************************************************************)

lemma mono_BufEq_F: "mono BufEq_F"
by (unfold mono_def BufEq_F_def, fast)

lemmas BufEq_fix = mono_BufEq_F [THEN BufEq_def [THEN eq_reflection, THEN def_gfp_unfold]]

lemma BufEq_unfold: "(f\<in>BufEq) = (\<forall>d. f\<cdot>(Md d\<leadsto><>) = <> \<and>
                 (\<forall>x. \<exists>ff\<in>BufEq. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>(ff\<cdot>x)))"
apply (subst BufEq_fix [THEN set_cong])
apply (unfold BufEq_F_def)
apply (simp)
done

lemma Buf_f_empty: "f\<in>BufEq \<Longrightarrow> f\<cdot><> = <>"
by (drule BufEq_unfold [THEN iffD1], auto)

lemma Buf_f_d: "f\<in>BufEq \<Longrightarrow> f\<cdot>(Md d\<leadsto><>) = <>"
by (drule BufEq_unfold [THEN iffD1], auto)

lemma Buf_f_d_req:
        "f\<in>BufEq \<Longrightarrow> \<exists>ff. ff\<in>BufEq \<and> f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x"
by (drule BufEq_unfold [THEN iffD1], auto)

(**** BufAC_Asm ***************************************************************)

lemma mono_BufAC_Asm_F: "mono BufAC_Asm_F"
by (unfold mono_def BufAC_Asm_F_def, fast)

lemmas BufAC_Asm_fix =
  mono_BufAC_Asm_F [THEN BufAC_Asm_def [THEN eq_reflection, THEN def_gfp_unfold]]

lemma BufAC_Asm_unfold: "(s\<in>BufAC_Asm) = (s = <> \<or> (\<exists>d x.
        s = Md d\<leadsto>x \<and> (x = <> \<or> (ft\<cdot>x = Def \<bullet> \<and> (rt\<cdot>x)\<in>BufAC_Asm))))"
apply (subst BufAC_Asm_fix [THEN set_cong])
apply (unfold BufAC_Asm_F_def)
apply (simp)
done

lemma BufAC_Asm_empty: "<> \<in> BufAC_Asm"
by (rule BufAC_Asm_unfold [THEN iffD2], auto)

lemma BufAC_Asm_d: "Md d\<leadsto><> \<in> BufAC_Asm"
by (rule BufAC_Asm_unfold [THEN iffD2], auto)
lemma BufAC_Asm_d_req: "x \<in> BufAC_Asm \<Longrightarrow> Md d\<leadsto>\<bullet>\<leadsto>x \<in> BufAC_Asm"
by (rule BufAC_Asm_unfold [THEN iffD2], auto)
lemma BufAC_Asm_prefix2: "a\<leadsto>b\<leadsto>s \<in> BufAC_Asm ==> s \<in> BufAC_Asm"
by (drule BufAC_Asm_unfold [THEN iffD1], auto)

(**** BBufAC_Cmt **************************************************************)

lemma mono_BufAC_Cmt_F: "mono BufAC_Cmt_F"
by (unfold mono_def BufAC_Cmt_F_def, fast)

lemmas BufAC_Cmt_fix =
  mono_BufAC_Cmt_F [THEN BufAC_Cmt_def [THEN eq_reflection, THEN def_gfp_unfold]]

lemma BufAC_Cmt_unfold: "((s,t) \<in> BufAC_Cmt) = (\<forall>d x.
     (s = <>       \<longrightarrow>      t = <>) \<and>
     (s = Md d\<leadsto><>  \<longrightarrow>      t = <>) \<and>
     (s = Md d\<leadsto>\<bullet>\<leadsto>x \<longrightarrow> ft\<cdot>t = Def d \<and> (x, rt\<cdot>t) \<in> BufAC_Cmt))"
apply (subst BufAC_Cmt_fix [THEN set_cong])
apply (unfold BufAC_Cmt_F_def)
apply (simp)
done

lemma BufAC_Cmt_empty: "f \<in> BufEq \<Longrightarrow> (<>, f\<cdot><>) \<in> BufAC_Cmt"
by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_empty)

lemma BufAC_Cmt_d: "f \<in> BufEq \<Longrightarrow> (a\<leadsto>\<bottom>, f\<cdot>(a\<leadsto>\<bottom>)) \<in> BufAC_Cmt"
by (rule BufAC_Cmt_unfold [THEN iffD2], auto simp add: Buf_f_d)

lemma BufAC_Cmt_d2:
 "(Md d\<leadsto>\<bottom>, f\<cdot>(Md d\<leadsto>\<bottom>)) \<in> BufAC_Cmt \<Longrightarrow> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
by (drule BufAC_Cmt_unfold [THEN iffD1], auto)

lemma BufAC_Cmt_d3:
"(Md d\<leadsto>\<bullet>\<leadsto>x, f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x)) \<in> BufAC_Cmt \<Longrightarrow> (x, rt\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x))) \<in> BufAC_Cmt"
by (drule BufAC_Cmt_unfold [THEN iffD1], auto)

lemma BufAC_Cmt_d32:
"(Md d\<leadsto>\<bullet>\<leadsto>x, f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x)) \<in> BufAC_Cmt \<Longrightarrow> ft\<cdot>(f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x)) = Def d"
by (drule BufAC_Cmt_unfold [THEN iffD1], auto)

(**** BufAC *******************************************************************)

lemma BufAC_f_d: "f \<in> BufAC \<Longrightarrow> f\<cdot>(Md d\<leadsto>\<bottom>) = \<bottom>"
apply (unfold BufAC_def)
apply (fast intro: BufAC_Cmt_d2 BufAC_Asm_d)
done

lemma ex_elim_lemma: "(\<exists>ff\<in>B. (\<forall>x. f\<cdot>(a\<leadsto>b\<leadsto>x) = d\<leadsto>ff\<cdot>x)) =
    ((\<forall>x. ft\<cdot>(f\<cdot>(a\<leadsto>b\<leadsto>x)) = Def d) \<and> (LAM x. rt\<cdot>(f\<cdot>(a\<leadsto>b\<leadsto>x)))\<in>B)"
(*  this is an instance (though unification cannot handle this) of
lemma "(? ff:B. (!x. f\<cdot>x = d\<leadsto>ff\<cdot>x)) = \
   \((!x. ft\<cdot>(f\<cdot>x) = Def d) & (LAM x. rt\<cdot>(f\<cdot>x)):B)"*)
apply safe
apply (  rule_tac [2] P="(\<lambda>x. x\<in>B)" in ssubst)
prefer 3
apply (   assumption)
apply (  rule_tac [2] cfun_eqI)
apply (  drule_tac [2] spec)
apply (  drule_tac [2] f="rt" in cfun_arg_cong)
prefer 2
apply (  simp)
prefer 2
apply ( simp)
apply (rule_tac bexI)
apply auto
apply (drule spec)
apply (erule exE)
apply (erule ssubst)
apply (simp)
done

lemma BufAC_f_d_req: "f\<in>BufAC \<Longrightarrow> \<exists>ff\<in>BufAC. \<forall>x. f\<cdot>(Md d\<leadsto>\<bullet>\<leadsto>x) = d\<leadsto>ff\<cdot>x"
apply (unfold BufAC_def)
apply (rule ex_elim_lemma [THEN iffD2])
apply safe
apply  (fast intro: BufAC_Cmt_d32 [THEN Def_maximal]
             monofun_cfun_arg BufAC_Asm_empty [THEN BufAC_Asm_d_req])
apply (auto intro: BufAC_Cmt_d3 BufAC_Asm_d_req)
done

(**** BufSt *******************************************************************)

lemma mono_BufSt_F: "mono BufSt_F"
by (unfold mono_def BufSt_F_def, fast)

lemmas BufSt_P_fix =
  mono_BufSt_F [THEN BufSt_P_def [THEN eq_reflection, THEN def_gfp_unfold]]

lemma BufSt_P_unfold: "(h\<in>BufSt_P) = (\<forall>s. h s\<cdot><> = <> \<and>
           (\<forall>d x. h \<currency>     \<cdot>(Md d\<leadsto>x)   =    h (Sd d)\<cdot>x \<and>
      (\<exists>hh\<in>BufSt_P. h (Sd d)\<cdot>(\<bullet>\<leadsto>x)   = d\<leadsto>(hh \<currency>    \<cdot>x))))"
apply (subst BufSt_P_fix [THEN set_cong])
apply (unfold BufSt_F_def)
apply (simp)
done

lemma BufSt_P_empty: "h \<in> BufSt_P \<Longrightarrow> h s     \<cdot> <>       = <>"
by (drule BufSt_P_unfold [THEN iffD1], auto)
lemma BufSt_P_d: "h \<in> BufSt_P \<Longrightarrow> h  \<currency>    \<cdot>(Md d\<leadsto>x) = h (Sd d)\<cdot>x"
by (drule BufSt_P_unfold [THEN iffD1], auto)
lemma BufSt_P_d_req: "h \<in> BufSt_P ==> \<exists>hh\<in>BufSt_P.
                                          h (Sd d)\<cdot>(\<bullet>   \<leadsto>x) = d\<leadsto>(hh \<currency>    \<cdot>x)"
by (drule BufSt_P_unfold [THEN iffD1], auto)

(**** Buf_AC_imp_Eq ***********************************************************)

lemma Buf_AC_imp_Eq: "BufAC \<subseteq> BufEq"
apply (unfold BufEq_def)
apply (rule gfp_upperbound)
apply (unfold BufEq_F_def)
apply safe
apply  (erule BufAC_f_d)
apply (drule BufAC_f_d_req)
apply (fast)
done

(**** Buf_Eq_imp_AC by coinduction ********************************************)

lemma BufAC_Asm_cong_lemma [rule_format]: "\<forall>s f ff. f\<in>BufEq \<longrightarrow> ff\<in>BufEq \<longrightarrow>
  s\<in>BufAC_Asm \<longrightarrow> stream_take n\<cdot>(f\<cdot>s) = stream_take n\<cdot>(ff\<cdot>s)"
apply (induct_tac "n")
apply  (simp)
apply (intro strip)
apply (drule BufAC_Asm_unfold [THEN iffD1])
apply safe
apply   (simp add: Buf_f_empty)
apply  (simp add: Buf_f_d)
apply (drule ft_eq [THEN iffD1])
apply (clarsimp)
apply (drule Buf_f_d_req)+
apply safe
apply (erule ssubst)+
apply (simp (no_asm))
apply (fast)
done

lemma BufAC_Asm_cong: "\<lbrakk>f \<in> BufEq; ff \<in> BufEq; s \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> f\<cdot>s = ff\<cdot>s"
apply (rule stream.take_lemma)
apply (erule (2) BufAC_Asm_cong_lemma)
done

lemma Buf_Eq_imp_AC_lemma: "\<lbrakk>f \<in> BufEq; x \<in> BufAC_Asm\<rbrakk> \<Longrightarrow> (x, f\<cdot>x) \<in> BufAC_Cmt"
apply (unfold BufAC_Cmt_def)
apply (rotate_tac)
apply (erule weak_coinduct_image)
apply (unfold BufAC_Cmt_F_def)
apply safe
apply    (erule Buf_f_empty)
apply   (erule Buf_f_d)
apply  (drule Buf_f_d_req)
apply  (clarsimp)
apply  (erule exI)
apply (drule BufAC_Asm_prefix2)
apply (frule Buf_f_d_req)
apply (clarsimp)
apply (erule ssubst)
apply (simp)
apply (drule (2) BufAC_Asm_cong)
apply (erule subst)
apply (erule imageI)
done
lemma Buf_Eq_imp_AC: "BufEq \<subseteq> BufAC"
apply (unfold BufAC_def)
apply (clarify)
apply (erule (1) Buf_Eq_imp_AC_lemma)
done

(**** Buf_Eq_eq_AC ************************************************************)

lemmas Buf_Eq_eq_AC = Buf_AC_imp_Eq [THEN Buf_Eq_imp_AC [THEN subset_antisym]]

(**** alternative (not strictly) stronger version of Buf_Eq *******************)

lemma Buf_Eq_alt_imp_Eq: "BufEq_alt \<subseteq> BufEq"
apply (unfold BufEq_def BufEq_alt_def)
apply (rule gfp_mono)
apply (unfold BufEq_F_def)
apply (fast)
done

(* direct proof of "BufEq \<subseteq> BufEq_alt" seems impossible *)

lemma Buf_AC_imp_Eq_alt: "BufAC <= BufEq_alt"
apply (unfold BufEq_alt_def)
apply (rule gfp_upperbound)
apply (fast elim: BufAC_f_d BufAC_f_d_req)
done

lemmas Buf_Eq_imp_Eq_alt = subset_trans [OF Buf_Eq_imp_AC Buf_AC_imp_Eq_alt]

lemmas Buf_Eq_alt_eq = subset_antisym [OF Buf_Eq_alt_imp_Eq Buf_Eq_imp_Eq_alt]

(**** Buf_Eq_eq_St ************************************************************)

lemma Buf_St_imp_Eq: "BufSt <= BufEq"
apply (unfold BufSt_def BufEq_def)
apply (rule gfp_upperbound)
apply (unfold BufEq_F_def)
apply safe
apply ( simp add: BufSt_P_d BufSt_P_empty)
apply (simp add: BufSt_P_d)
apply (drule BufSt_P_d_req)
apply (force)
done

lemma Buf_Eq_imp_St: "BufEq <= BufSt"
apply (unfold BufSt_def BufSt_P_def)
apply safe
apply (rename_tac f)
apply (rule_tac x="\<lambda>s. case s of Sd d => \<Lambda> x. f\<cdot>(Md d\<leadsto>x)| \<currency> => f" in bexI)
apply ( simp)
apply (erule weak_coinduct_image)
apply (unfold BufSt_F_def)
apply (simp)
apply safe
apply (  rename_tac "s")
apply (  induct_tac "s")
apply (   simp add: Buf_f_d)
apply (  simp add: Buf_f_empty)
apply ( simp)
apply (simp)
apply (rename_tac f d x)
apply (drule_tac d="d" and x="x" in Buf_f_d_req)
apply auto
done

lemmas Buf_Eq_eq_St = Buf_St_imp_Eq [THEN Buf_Eq_imp_St [THEN subset_antisym]]

end


(*  Title:       Loop_Freedom.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Routing graphs and loop freedom"

theory Loop_Freedom
imports Aodv_Predicates Fresher
begin

text \<open>Define the central theorem that relates an invariant over network states to the absence
      of loops in the associate routing graph.\<close>

definition
  rt_graph :: "(ip \<Rightarrow> state) \<Rightarrow> ip \<Rightarrow> ip rel"
where
  "rt_graph \<sigma> = (\<lambda>dip.
     {(ip, ip') | ip ip' dsn dsk hops pre.
        ip \<noteq> dip \<and> rt (\<sigma> ip) dip = Some (dsn, dsk, val, hops, ip', pre)})"

text \<open>Given the state of a network @{term \<sigma>}, a routing graph for a given destination
      ip address @{term dip} abstracts the details of routing tables into nodes
      (ip addresses) and vertices (valid routes between ip addresses).\<close>

lemma rt_graphE [elim]:
    fixes n dip ip ip'
  assumes "(ip, ip') \<in> rt_graph \<sigma> dip"
    shows "ip \<noteq> dip \<and> (\<exists>r. rt (\<sigma> ip) = r
                            \<and> (\<exists>dsn dsk hops pre. r dip = Some (dsn, dsk, val, hops, ip', pre)))"
  using assms unfolding rt_graph_def by auto

lemma rt_graph_vD [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> dip \<in> vD(rt (\<sigma> ip))"
  unfolding rt_graph_def vD_def by auto

lemma rt_graph_vD_trans [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+ \<Longrightarrow> dip \<in> vD(rt (\<sigma> ip))"
  by (erule converse_tranclE) auto

lemma rt_graph_not_dip [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> ip \<noteq> dip"
  unfolding rt_graph_def by auto

lemma rt_graph_not_dip_trans [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+ \<Longrightarrow> ip \<noteq> dip"
  by (erule converse_tranclE) auto

text "NB: the property below cannot be lifted to the transitive closure"

lemma rt_graph_nhip_is_nhop [dest]:
  "\<And>ip ip' \<sigma> dip. (ip, ip') \<in> rt_graph \<sigma> dip \<Longrightarrow> ip' = the (nhop (rt (\<sigma> ip)) dip)"
  unfolding rt_graph_def by auto

theorem inv_to_loop_freedom:
  assumes "\<forall>i dip. let nhip = the (nhop (rt (\<sigma> i)) dip)
                   in dip \<in> vD (rt (\<sigma> i)) \<inter> vD (rt (\<sigma> nhip)) \<and> nhip \<noteq> dip
                      \<longrightarrow> (rt (\<sigma> i)) \<sqsubset>\<^bsub>dip\<^esub> (rt (\<sigma> nhip))"
    shows "\<forall>dip. irrefl ((rt_graph \<sigma> dip)\<^sup>+)"
  using assms proof (intro allI)
    fix \<sigma> :: "ip \<Rightarrow> state" and dip
    assume inv: "\<forall>ip dip.
                  let nhip = the (nhop (rt (\<sigma> ip)) dip)
                  in dip \<in> vD(rt (\<sigma> ip)) \<inter> vD(rt (\<sigma> nhip)) \<and>
                     nhip \<noteq> dip \<longrightarrow> rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
    { fix ip ip'
      assume "(ip, ip') \<in> (rt_graph \<sigma> dip)\<^sup>+"
         and "dip \<in> vD(rt (\<sigma> ip'))"
         and "ip' \<noteq> dip"
       hence "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> ip')"
         proof induction
           fix nhip
           assume "(ip, nhip) \<in> rt_graph \<sigma> dip"
              and "dip \<in> vD(rt (\<sigma> nhip))"
              and "nhip \<noteq> dip"
           from \<open>(ip, nhip) \<in> rt_graph \<sigma> dip\<close> have "dip \<in> vD(rt (\<sigma> ip))"
                                               and "nhip = the (nhop (rt (\<sigma> ip)) dip)"
             by auto
           from \<open>dip \<in> vD(rt (\<sigma> ip))\<close> and \<open>dip \<in> vD(rt (\<sigma> nhip))\<close>
             have "dip \<in> vD(rt (\<sigma> ip)) \<inter> vD(rt (\<sigma> nhip))" ..
           with \<open>nhip = the (nhop (rt (\<sigma> ip)) dip)\<close>
                and \<open>nhip \<noteq> dip\<close>
                and inv
             show "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
             by (clarsimp simp: Let_def)
         next
           fix nhip nhip'
           assume "(ip, nhip) \<in> (rt_graph \<sigma> dip)\<^sup>+"
              and "(nhip, nhip') \<in> rt_graph \<sigma> dip"
              and IH: "\<lbrakk> dip \<in> vD(rt (\<sigma> nhip)); nhip \<noteq> dip \<rbrakk> \<Longrightarrow> rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)"
              and "dip \<in> vD(rt (\<sigma> nhip'))"
              and "nhip' \<noteq> dip"
           from \<open>(nhip, nhip') \<in> rt_graph \<sigma> dip\<close> have 1: "dip \<in> vD(rt (\<sigma> nhip))"
                                                  and 2: "nhip \<noteq> dip"
                                                  and "nhip' = the (nhop (rt (\<sigma> nhip)) dip)"
             by auto
           from 1 2 have "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip)" by (rule IH)
           also have "rt (\<sigma> nhip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')"
             proof -
               from \<open>dip \<in> vD(rt (\<sigma> nhip))\<close> and \<open>dip \<in> vD(rt (\<sigma> nhip'))\<close>
                 have "dip \<in> vD(rt (\<sigma> nhip)) \<inter> vD(rt (\<sigma> nhip'))" ..
               with \<open>nhip' \<noteq> dip\<close>
                    and \<open>nhip' = the (nhop (rt (\<sigma> nhip)) dip)\<close>
                    and inv
                 show "rt (\<sigma> nhip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')"
                   by (clarsimp simp: Let_def)
             qed
           finally show "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> nhip')" .
         qed } note fresher = this

    show "irrefl ((rt_graph \<sigma> dip)\<^sup>+)"
    unfolding irrefl_def proof (intro allI notI)
      fix ip
      assume "(ip, ip) \<in> (rt_graph \<sigma> dip)\<^sup>+"
      moreover then have "dip \<in> vD(rt (\<sigma> ip))"
                     and "ip \<noteq> dip"
        by auto
      ultimately have "rt (\<sigma> ip) \<sqsubset>\<^bsub>dip\<^esub> rt (\<sigma> ip)" by (rule fresher)
      thus False by simp
    qed
  qed

end


theory sol05_2
imports "~~/src/HOL/IMP/BExp" "~~/src/HOL/IMP/Star"
begin

(****************************************)
(** Com.thy **)
(****************************************)

datatype
  com = SKIP
      | Assign vname aexp       ("_ ::= _" [1000, 61] 61)
      | Seq    com  com         ("_;;/ _"  [60, 61] 60)
      | If     bexp com com     ("(IF _/ THEN _/ ELSE _)"  [0, 0, 61] 61)
      | While  bexp com         ("(WHILE _/ DO _)"  [0, 61] 61)
      | Or     com  com         (infixr "\<parallel>" 62)
      | ASSUME bexp

(****************************************)
(** Big_Step.thy **)
(****************************************)

subsection "Big-Step Semantics of Commands"

text {*
The big-step semantics is a straight-forward inductive definition
with concrete syntax. Note that the first paramenter is a tuple,
so the syntax becomes @{text "(c,s) \<Rightarrow> s'"}.
*}

text_raw{*\snip{BigStepdef}{0}{1}{% *}
inductive
  big_step :: "com \<times> state \<Rightarrow> state \<Rightarrow> bool" (infix "\<Rightarrow>" 55)
where
Skip: "(SKIP,s) \<Rightarrow> s" |
Assign: "(x ::= a,s) \<Rightarrow> s(x := aval a s)" |
Seq: "\<lbrakk> (c\<^sub>1,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (c\<^sub>2,s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk> \<Longrightarrow> (c\<^sub>1;;c\<^sub>2, s\<^sub>1) \<Rightarrow> s\<^sub>3" |
IfTrue: "\<lbrakk> bval b s;  (c\<^sub>1,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
IfFalse: "\<lbrakk> \<not>bval b s;  (c\<^sub>2,s) \<Rightarrow> t \<rbrakk> \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2, s) \<Rightarrow> t" |
WhileFalse: "\<not>bval b s \<Longrightarrow> (WHILE b DO c,s) \<Rightarrow> s" |
WhileTrue:
"\<lbrakk> bval b s\<^sub>1;  (c,s\<^sub>1) \<Rightarrow> s\<^sub>2;  (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<rbrakk>
\<Longrightarrow> (WHILE b DO c, s\<^sub>1) \<Rightarrow> s\<^sub>3"
| Or1: "\<lbrakk> (c1,s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (c1\<parallel>c2,s) \<Rightarrow> s'"
| Or2: "\<lbrakk> (c2,s) \<Rightarrow> s' \<rbrakk> \<Longrightarrow> (c1\<parallel>c2,s) \<Rightarrow> s'"
| Assume: "\<lbrakk> bval b s \<rbrakk> \<Longrightarrow> (ASSUME b,s) \<Rightarrow> s"
text_raw{*}%endsnip*}

text_raw{*\snip{BigStepEx}{1}{2}{% *}
schematic_lemma ex: "(''x'' ::= N 5;; ''y'' ::= V ''x'', s) \<Rightarrow> ?t"
apply(rule Seq)
apply(rule Assign)
apply simp
apply(rule Assign)
done
text_raw{*}%endsnip*}

thm ex[simplified]

text{* We want to execute the big-step rules: *}

code_pred big_step .

text{* For inductive definitions we need command
       \texttt{values} instead of \texttt{value}. *}

values "{t. (SKIP, \<lambda>_. 0) \<Rightarrow> t}"

text{* We need to translate the result state into a list
to display it. *}

values "{map t [''x''] |t. (SKIP, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x''] |t. (''x'' ::= N 2, <''x'' := 42>) \<Rightarrow> t}"

values "{map t [''x'',''y''] |t.
  (WHILE Less (V ''x'') (V ''y'') DO (''x'' ::= Plus (V ''x'') (N 5)),
   <''x'' := 0, ''y'' := 13>) \<Rightarrow> t}"

text{* Proof automation: *}

text {* The introduction rules are good for automatically
construction small program executions. The recursive cases
may require backtracking, so we declare the set as unsafe
intro rules. *}
declare big_step.intros [intro]

text{* The standard induction rule
@{thm [display] big_step.induct [no_vars]} *}

thm big_step.induct

text{*
This induction schema is almost perfect for our purposes, but
our trick for reusing the tuple syntax means that the induction
schema has two parameters instead of the @{text c}, @{text s},
and @{text s'} that we are likely to encounter. Splitting
the tuple parameter fixes this:
*}
lemmas big_step_induct = big_step.induct[split_format(complete)]
thm big_step_induct
text {*
@{thm [display] big_step_induct [no_vars]}
*}

subsection "Rule inversion"

text{* What can we deduce from @{prop "(SKIP,s) \<Rightarrow> t"} ?
That @{prop "s = t"}. This is how we can automatically prove it: *}

inductive_cases SkipE[elim!]: "(SKIP,s) \<Rightarrow> t"
thm SkipE

text{* This is an \emph{elimination rule}. The [elim] attribute tells auto,
blast and friends (but not simp!) to use it automatically; [elim!] means that
it is applied eagerly.

Similarly for the other commands: *}

inductive_cases AssignE[elim!]: "(x ::= a,s) \<Rightarrow> t"
thm AssignE
inductive_cases SeqE[elim!]: "(c1;;c2,s1) \<Rightarrow> s3"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<Rightarrow> t"
thm IfE

inductive_cases WhileE[elim]: "(WHILE b DO c,s) \<Rightarrow> t"
thm WhileE
text{* Only [elim]: [elim!] would not terminate. *}

inductive_cases OrE[elim!]: "(c1\<parallel>c2,s) \<Rightarrow> t"
thm OrE

inductive_cases AssumeE[elim!]: "(ASSUME b,s) \<Rightarrow> t"
thm AssumeE

text{* An automatic example: *}

lemma "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t \<Longrightarrow> t = s"
by blast

text{* Rule inversion by hand via the ``cases'' method: *}

lemma assumes "(IF b THEN SKIP ELSE SKIP, s) \<Rightarrow> t"
shows "t = s"
proof-
  from assms show ?thesis
  proof cases  --"inverting assms"
    case IfTrue thm IfTrue
    thus ?thesis by blast
  next
    case IfFalse thus ?thesis by blast
  qed
qed

(* Using rule inversion to prove simplification rules: *)
lemma assign_simp:
  "(x ::= a,s) \<Rightarrow> s' \<longleftrightarrow> (s' = s(x := aval a s))"
  by auto

text {* An example combining rule inversion and derivations *}
lemma Seq_assoc:
  "(c1;; c2;; c3, s) \<Rightarrow> s' \<longleftrightarrow> (c1;; (c2;; c3), s) \<Rightarrow> s'"
proof
  assume "(c1;; c2;; c3, s) \<Rightarrow> s'"
  then obtain s1 s2 where
    c1: "(c1, s) \<Rightarrow> s1" and
    c2: "(c2, s1) \<Rightarrow> s2" and
    c3: "(c3, s2) \<Rightarrow> s'" by auto
  from c2 c3
  have "(c2;; c3, s1) \<Rightarrow> s'" by (rule Seq)
  with c1
  show "(c1;; (c2;; c3), s) \<Rightarrow> s'" by (rule Seq)
next
  -- "The other direction is analogous"
  assume "(c1;; (c2;; c3), s) \<Rightarrow> s'"
  thus "(c1;; c2;; c3, s) \<Rightarrow> s'" by auto
qed

subsection "Command Equivalence"

text {*
  We call two statements @{text c} and @{text c'} equivalent wrt.\ the
  big-step semantics when \emph{@{text c} started in @{text s} terminates
  in @{text s'} iff @{text c'} started in the same @{text s} also terminates
  in the same @{text s'}}. Formally:
*}
text_raw{*\snip{BigStepEquiv}{0}{1}{% *}
abbreviation
  equiv_c :: "com \<Rightarrow> com \<Rightarrow> bool" (infix "\<sim>" 50) where
  "c \<sim> c' \<equiv> (\<forall>s t. (c,s) \<Rightarrow> t  =  (c',s) \<Rightarrow> t)"
text_raw{*}%endsnip*}

text {*
Warning: @{text"\<sim>"} is the symbol written \verb!\ < s i m >! (without spaces).

  As an example, we show that loop unfolding is an equivalence
  transformation on programs:
*}
lemma unfold_while:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)" (is "?w \<sim> ?iw")
proof -
  -- "to show the equivalence, we look at the derivation tree for"
  -- "each side and from that construct a derivation tree for the other side"
  { fix s t assume "(?w, s) \<Rightarrow> t"
    -- "as a first thing we note that, if @{text b} is @{text False} in state @{text s},"
    -- "then both statements do nothing:"
    { assume "\<not>bval b s"
      hence "t = s" using `(?w,s) \<Rightarrow> t` by blast
      hence "(?iw, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then only the @{text WhileTrue} rule can have been used to derive @{text "(?w, s) \<Rightarrow> t"} *}
    { assume "bval b s"
      with `(?w, s) \<Rightarrow> t` obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "now we can build a derivation tree for the @{text IF}"
      -- "first, the body of the True-branch:"
      hence "(c;; ?w, s) \<Rightarrow> t" by (rule Seq)
      -- "then the whole @{text IF}"
      with `bval b s` have "(?iw, s) \<Rightarrow> t" by (rule IfTrue)
    }
    ultimately
    -- "both cases together give us what we want:"
    have "(?iw, s) \<Rightarrow> t" by blast
  }
  moreover
  -- "now the other direction:"
  { fix s t assume "(?iw, s) \<Rightarrow> t"
    -- "again, if @{text b} is @{text False} in state @{text s}, then the False-branch"
    -- "of the @{text IF} is executed, and both statements do nothing:"
    { assume "\<not>bval b s"
      hence "s = t" using `(?iw, s) \<Rightarrow> t` by blast
      hence "(?w, s) \<Rightarrow> t" using `\<not>bval b s` by blast
    }
    moreover
    -- "on the other hand, if @{text b} is @{text True} in state @{text s},"
    -- {* then this time only the @{text IfTrue} rule can have be used *}
    { assume "bval b s"
      with `(?iw, s) \<Rightarrow> t` have "(c;; ?w, s) \<Rightarrow> t" by auto
      -- "and for this, only the Seq-rule is applicable:"
      then obtain s' where
        "(c, s) \<Rightarrow> s'" and "(?w, s') \<Rightarrow> t" by auto
      -- "with this information, we can build a derivation tree for the @{text WHILE}"
      with `bval b s`
      have "(?w, s) \<Rightarrow> t" by (rule WhileTrue)
    }
    ultimately
    -- "both cases together again give us what we want:"
    have "(?w, s) \<Rightarrow> t" by blast
  }
  ultimately
  show ?thesis by blast
qed

text {* Luckily, such lengthy proofs are seldom necessary.  Isabelle can
prove many such facts automatically.  *}

lemma while_unfold:
  "(WHILE b DO c) \<sim> (IF b THEN c;; WHILE b DO c ELSE SKIP)"
by blast

lemma triv_if:
  "(IF b THEN c ELSE c) \<sim> c"
by blast

lemma commute_if:
  "(IF b1 THEN (IF b2 THEN c11 ELSE c12) ELSE c2)
   \<sim>
   (IF b2 THEN (IF b1 THEN c11 ELSE c2) ELSE (IF b1 THEN c12 ELSE c2))"
by blast

lemma sim_while_cong_aux:
  "(WHILE b DO c,s) \<Rightarrow> t  \<Longrightarrow> c \<sim> c' \<Longrightarrow>  (WHILE b DO c',s) \<Rightarrow> t"
apply(induction "WHILE b DO c" s t arbitrary: b c rule: big_step_induct)
 apply blast
apply blast
done

lemma sim_while_cong: "c \<sim> c' \<Longrightarrow> WHILE b DO c \<sim> WHILE b DO c'"
by (metis sim_while_cong_aux)

text {* Command equivalence is an equivalence relation, i.e.\ it is
reflexive, symmetric, and transitive. Because we used an abbreviation
above, Isabelle derives this automatically. *}

lemma sim_refl:  "c \<sim> c" by simp
lemma sim_sym:   "(c \<sim> c') = (c' \<sim> c)" by auto
lemma sim_trans: "c \<sim> c' \<Longrightarrow> c' \<sim> c'' \<Longrightarrow> c \<sim> c''" by auto

lemma "c1 \<parallel> c2 \<sim> c2 \<parallel> c1"
  by blast

lemma "(IF b THEN c1 ELSE c2) \<sim> ((ASSUME b;; c1) \<parallel> (ASSUME (Not b);; c2))"
  by fastforce

subsection "Execution is deterministic"
(** Not any more! **)

(****************************************)
(** Small_Step.thy **)
(****************************************)

subsection "The transition relation"

text_raw{*\snip{SmallStepDef}{0}{2}{% *}
inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"
| Or1: "(c1\<parallel>c2,s) \<rightarrow> (c1,s)"
| Or2: "(c1\<parallel>c2,s) \<rightarrow> (c2,s)"
| Assume: "bval b s \<Longrightarrow> (ASSUME b,s) \<rightarrow> (SKIP,s)"
text_raw{*}%endsnip*}

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection{* Executability *}

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection{* Proof infrastructure *}

subsubsection{* Induction rules *}

text{* The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form @{text"a \<rightarrow> b \<Longrightarrow> \<dots>"} where @{text a} and @{text b} are
not already pairs @{text"(DUMMY,DUMMY)"}. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
@{text"\<rightarrow>"} into pairs: *}
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection{* Proof automation *}

declare small_step.intros[simp,intro]

text{* Rule inversion: *}

inductive_cases ssSkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm ssSkipE
inductive_cases ssAssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm ssAssignE
inductive_cases ssSeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm ssSeqE
inductive_cases ssIfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"

inductive_cases ssWhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

inductive_cases ssOrE[elim!]: "(c1\<parallel>c2,s) \<rightarrow> ct"
inductive_cases ssAssumeE[elim!]: "(ASSUME b,s) \<rightarrow> ct"

(** Does not hold any more.
text{* A simple property: *}
lemma deterministic:
  "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule: small_step.induct)
apply blast+
done
**)

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text{* The following proof corresponds to one on the board where one would
show chains of @{text "\<rightarrow>"} and @{text "\<rightarrow>*"} steps. *}

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix c1 s s' c2
  have "(c1 \<parallel> c2,s) \<rightarrow> (c1,s)" by rule
  moreover assume "(c1, s) \<rightarrow>* (SKIP, s')"
  ultimately show "(c1 \<parallel> c2, s) \<rightarrow>* (SKIP, s')"
    by rule
next
  fix c1 s s' c2
  have "(c1 \<parallel> c2,s) \<rightarrow> (c2,s)" by rule
  moreover assume "(c2, s) \<rightarrow>* (SKIP, s')"
  ultimately show "(c1 \<parallel> c2, s) \<rightarrow>* (SKIP, s')"
    by rule
next
  fix b s
  assume "bval b s"
  hence "(ASSUME b, s) \<rightarrow> (SKIP, s)" by rule
  thus "(ASSUME b, s) \<rightarrow>* (SKIP, s)" by rule
qed

text{* Each case of the induction can be proved automatically: *}
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
next
  case Or1 thus ?case
    by (metis small_step.Or1 star.simps)
next
  case Or2 thus ?case
    by (metis small_step.Or2 star.simps)
next
  case Assume thus ?case by blast
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_big_continue:
  "cs \<rightarrow>* cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction rule: star.induct)
apply (auto intro: small1_big_continue)
done

lemma small_to_big: "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
by (metis small_big_continue Skip)

text {*
  Finally, the equivalence theorem:
*}
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

(** Does not hold any more
definition "final cs \<longleftrightarrow> \<not>(EX cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis ssSkipE finalD final_def)

text{* Now we can show that @{text"\<Rightarrow>"} yields a final state iff @{text"\<rightarrow>"}
terminates: *}

lemma big_iff_small_termination:
  "(EX t. cs \<Rightarrow> t) \<longleftrightarrow> (EX cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text{* This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since @{text"\<rightarrow>"} is determininistic, there is no difference
between may and must terminate. *}
**)

end