theory Chapter5
imports Main
begin

value "List.coset [1, 2, 3 :: int]"
(* value "surj" *)
thm surj_def
thm sym
thm surj_def[symmetric]

lemma flip_eq: "c = (a = b) \<Longrightarrow> c = (b = a)"
  apply(auto)
done

thm flip_eq[of x surj_def]

value "[1, 2, 3 :: int]"

text \<open>
Isar abbreviations:
   then  = from this
   thus  = then show
   hence = then have
\<close>

thm All_def
thm allI
thm allE

thm notI
thm someI

lemma no_surj_for_powerset: "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume 0: "surj f"
  from 0 have 1: "\<forall> y. \<exists> x. y = f x" by (simp add: surj_def)
  (*from 1 have 2: "\<forall> y. \<exists> x. f x = y" by(simp add: sym)*)
  from 1 have 2: "\<exists> x. {y. y \<notin> f y} = f x" by simp
  from 2 show "False" by blast
qed

text \<open>
Linear flow of proof facts is to be preferred to labels
  this - proposition proved in the previous step
\<close>

lemma no_surj_for_powerset_without_labels: "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  from this have "\<exists> x. {y. y \<notin> f y} = f x" by (simp add: surj_def)
  from this show "False" by blast
qed

text \<open>
Convenient abbreviations:
  then  = from this
  hence = then have
  thus  = then show
\<close>

lemma no_surj_for_powerset_without_labels_with_abbrev: "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> x. {y. y \<notin> f y} = f x" by (simp add: surj_def)
  thus "False" by blast
qed

text \<open>
De-emphasize used facts:
  from F (have|show) P = (have|show) P using F
  from F this ...      = ... with F
\<close>

section \<open>Structured lemma format\<close>

lemma surjective_func_to_powerset_does_not_exist:
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof
  - (* Nil proof method - don't automatically search for an introduction rule for proof goal *)
  have "\<exists> x. {y. y \<notin> f y} = f x" using s by (simp add: surj_def)
  (* assms - list of all assumptions. Can index it with assms(1) or take range with assms(2-4) *)
  have "\<exists> x. {y. y \<notin> f y} = f x" using assms by (simp add: surj_def)
  thus "False" by blast
qed

lemma no_surj_for_powerset_without_labels_with_abbrev_no_auto_intro:
  "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  (rule notI)
  assume "surj f"
  hence "\<exists> x. {y. y \<notin> f y} = f x" by (simp add: surj_def)
  thus "False" by blast
qed

lemma no_surj_for_powerset_without_labels_detailed_with_obtain:
  "\<not> surj (f :: 'a \<Rightarrow> 'a set)"
proof
  assume "surj f"
  hence "\<exists> x. {y. y \<notin> f y} = f x" by (simp add: surj_def)
  then obtain a where "{x. x \<notin> f x} = f a" by blast
  hence "a \<in> f a \<longleftrightarrow> a \<notin> f a" by auto
  thus "False" by simp
qed

thm dvd_def

lemma
  fixes a b :: int
  assumes "b dvd (a + b)"
  shows "b dvd a"
proof -
  { fix k :: int
    assume k_init: "a + b = b * k"
    have "\<exists> n. a = b * n"
    proof
      show "a = b * (k - 1)" using k_init by (simp add: algebra_simps)
    qed
  }
  note a_shape = this
  show ?thesis using assms a_shape by (auto simp add: dvd_def)
qed

lemma "p \<longrightarrow> (p \<and> p)"
proof (rule impI)
  assume 1: p
  show "p \<and> p" using 1 1 ..
qed

lemma "(p \<longrightarrow> q) \<and> (q \<longrightarrow> r) \<longrightarrow> (p \<longrightarrow> r)"
proof (rule impI)
  assume pqqr: "(p \<longrightarrow> q) \<and> (q \<longrightarrow> r)" (is "?pq \<and> ?qr")
  have pq: "?pq" using pqqr ..
  have qr: "?qr" using pqqr ..
  show "p \<longrightarrow> r"
  proof (rule impI)
    assume p: "p"
    have q: "q" using pq p ..
    show "r" using qr q ..
  qed
qed

theorem modus_ponens: "(\<forall> x. P x \<longrightarrow> Q x) \<and> P a \<longrightarrow> Q a"
proof (rule impI)
  assume assm: "(\<forall> x. P x \<longrightarrow> Q x) \<and> P a"
  have "(\<forall> x. P x \<longrightarrow> Q x)" using assm ..
  hence pq: "P a \<longrightarrow> Q a" ..
  have p: "P a" using assm ..
  show "Q a" using pq p ..
qed

definition even :: "nat => bool" where
  "even n \<equiv> \<exists> k. n = 2 * k"

definition odd :: "nat \<Rightarrow> bool" where
  "odd n \<equiv> \<exists> k. n = 2 * k + 1"

theorem
  assumes oN: "odd n"
  and     oM: "odd m"
  shows "even (n + m)"
proof -
  from oN have "\<exists> k. n = 2 * k + 1" unfolding odd_def .
  then obtain k where k_prop: "n = 2 * k + 1" ..
  from oM have "\<exists> q. m = 2 * q + 1" unfolding odd_def .
  then obtain q where q_prop: "m = 2 * q + 1" ..
  from k_prop q_prop have "n + m = 2 * k + 2 * q + 2" by simp
  also hence "... = 2 * (k + q + 1)" by simp
  finally have "n + m = 2 * (k + q + 1)" by simp
  hence "\<exists> p. n + m = 2 * p" ..
  thus "even (n + m)" unfolding even_def .
qed

subsection \<open>Exercise 5.1\<close>

thm disjE

lemma
  assumes T:   "\<forall> x y. T x y \<or> T y x"
  and     A:   "\<forall> x y. A x y \<and> A y x \<longrightarrow> x = y"
  and     TA:  "\<forall> x y. T x y \<longrightarrow> A x y"
  and     axy: "A x y"
  shows   "T x y"
proof -
  have "T x y \<or> T y x" using T by auto
  thus ?thesis
  proof (rule disjE)
    assume "T x y"
    thus "T x y" .
  next
    assume tyx_assm: "T y x"
    have ayx:  "A y x" using tyx_assm TA by auto
    have xisy: "x = y" using axy ayx A by auto
    have "T x y" using xisy tyx_assm by auto
    thus ?thesis .
  qed
qed

subsection \<open>Exercise 5.2\<close>

thm disjI1 disjI2 someI

thm List.length_take List.length_drop dvd_def semiring_parity_class.evenE

lemma
  " (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
  \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof cases
  assume xs_len_even: "2 dvd length xs"
  show ?thesis
  proof (rule disjI1)
    show "\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs"
    proof
      fix ys
      show "\<exists> zs. xs = ys @ zs \<and> length ys = length zs"
      proof
        fix zs
        show "xs = ys @ zs \<and> length ys = length zs"
        proof -
          from xs_len_even have "\<exists> k. length xs = k * 2" unfolding dvd_def by auto
          then obtain k where k_def: "length xs = k * 2" ..
          assume ys_def: "ys = take k xs"
          assume zs_def: "zs = drop k xs"
          have "xs = ys @ zs" using ys_def zs_def by simp
          moreover have "length ys = length zs" using ys_def zs_def k_def by auto
          ultimately show "xs = ys @ zs \<and> length ys = length zs" ..
        qed
      qed
    qed
  qed
next
  assume xs_len_odd: "\<not> (2 dvd length xs)"
  show ?thesis
  proof (rule disjI2)
    show "\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1"
    proof
      show "\<exists> zs. xs = ys @ zs \<and> length ys = length zs + 1"
      proof
        fix ys zs
        show "xs = ys @ zs \<and> length ys = length zs + 1" sorry
      qed
    qed
  qed
qed

(*
lemma length_of_take: "n \<le> length xs \<Longrightarrow> length (take n xs) = n"
  apply(induction n)
  apply(simp)
  apply(simp)
done

lemma length_of_drop: "n \<le> length xs \<Longrightarrow> length (drop n xs) = length xs - n"
  apply(induction n)
  apply(simp)
  apply(simp)
done

lemma x_div_2_smaller_than_x: "x div 2 \<le> (x :: nat)"
  apply(auto)
done

lemma min_of_x_and_x_div_2: "min (x :: nat) (x div 2) = x div 2"
  apply(induction x)
  apply(simp)
  apply(simp)
done
*)

(*
lemma x_minus_x_div_2: "((x :: nat) - x div 2) = x div 2 \<or> ((x :: nat) - x div 2) = x div 2 + 1"
  apply(induction x)
  apply(simp)
  apply(simp)
done
*)

thm List.length_take List.length_drop

(* lemma
  " (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
  \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof (rule disjI1)
  fix as bs len
  assume len_def: "len = length xs div 2"
  assume as_def: "as = take len xs"
  assume bs_def: "bs = drop len xs"

  have xs_ok: "xs = as @ bs" using as_def bs_def by simp
  have "len \<le> length xs" using len_def x_div_2_smaller_than_x by simp
  hence as_len: "length as = len" using as_def length_of_take by (simp del: List.length_take)
  (*have "length xs = len + len" using as_def bs_def xs_ok by*)
  have bs_len: "length bs = len" using bs_def len_def by (simp)
  (*also have "length as = length bs" using as_def bs_def length_of_take length_of_drop len_def by simp*)
   (*using as_def bs_def length_of_take by simp*)

qed
 *)

(*
lemma
  " (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs)
  \<or> (\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs + 1)"
proof (rule disjI1)
  show "\<exists> ys zs. xs = ys @ zs \<and> length ys = length zs"
  proof
    show "\<exists> zs. xs = ys @ zs \<and> length ys = length zs"
    proof
      show "xs = ys @ zs \<and> length ys = length zs"
      proof
        assume ys_def: "ys = take (length xs div 2) xs"
        assume zs_def: "zs = drop (length xs div 2) xs"
        show "xs = ys @ zs" using ys_def zs_def by auto
qed
 *)

(*

lemma surjective_func_to_powerset_does_not_exist_with_cases:
  fixes f :: "'a \<Rightarrow> 'a set"
  assumes s: "surj f"
  shows "False"
proof
  - (* Nil proof method - don't automatically search for an introduction rule for proof goal *)
  have 1: "\<exists> x. {y. y \<notin> f y} = f x" using s by (simp add: surj_def)
  fix x :: "'a"
  from 1 have 2: "{y. y \<notin> f y} = f x" by auto
  show "False"
  proof cases
    assume "x \<in> f x"
    from 2 have "x \<notin> f x" by auto
    hence "False" by auto
  (*next
    assume "x \<notin> f x"
    hence "False" using 2 by auto *)
  qed
qed

*)

end


theory Chapter10_1
imports "HOL-IMP.Def_Init"
begin

text{*
\section*{Chapter 10}

\exercise
Define the definite initialisation analysis as two recursive functions
*}

fun ivars :: "com \<Rightarrow> vname set" where
(* your definition/proof here *)

fun ok :: "vname set \<Rightarrow> com \<Rightarrow> bool" where
(* your definition/proof here *)

text{*
such that @{const ivars} computes the set of definitely initialised variables
and @{const ok} checks that only initialised variable are accessed.
Prove
*}

lemma "D A c A' \<Longrightarrow> A' = A \<union> ivars c \<and> ok A c"
(* your definition/proof here *)

lemma "ok A c \<Longrightarrow> D A c (A \<union> ivars c)"
(* your definition/proof here *)

text{*
\endexercise
*}

end


section {* Isabelle/UTP Examples *}

theory utp_examples
  imports
    "UTP-Designs.utp_designs"
    "UTP.utp_easy_parser"
begin recall_syntax

alphabet my_state =
  x :: "int"
  y :: "int"
  z :: "int"

(* Beginning of exercises *)

lemma "(true \<and> false) = false"
  by simp

lemma "true = false"
  oops (* Not provable: show pred_auto produces False *)

lemma "x \<sharp> true"
  by unrest_tac

lemma "x \<sharp> &y"
  by unrest_tac

lemma "(&x =\<^sub>u 1 \<and> &y =\<^sub>u &x) = (&x =\<^sub>u 1 \<and> &y =\<^sub>u 1)"
  by pred_auto

lemma "(&x =\<^sub>u 1 \<and> &y =\<^sub>u &x)\<lbrakk>2/x\<rbrakk> = false"
  apply (subst_tac)
  apply (pred_auto)
done

(* The next two examples illustrate UTP and shallow lifted quantification *)

lemma "(\<forall> x \<bullet> &x =\<^sub>u &x) = true"
  by (pred_auto)

lemma "(\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> =\<^sub>u \<guillemotleft>x\<guillemotright>) = true"
  by (pred_auto)

lemma "(1 :\<^sub>u nat) + 1 = 2"
  by (pred_auto)

lemma "(x := 1 ;; x := x + 1) = (x := 2)"
  by (rel_auto)

lemma "(x := 1 ;; x := x + 1) = (x := 2)"
proof -
  have "x := 1 ;; x := x + 1 = (x := (x + 1))\<lbrakk>1/$x\<rbrakk>"
    by (simp add: assigns_r_comp alpha usubst)
  also have "... = x := (1 + 1)"
    by (rel_auto)
  also have "... = x := 2"
    by (simp)
  finally show ?thesis .
qed

lemma "true \<sqsubseteq> x, y := x + 1, y"
  by (rel_auto)

(* Need to change y' < y to y' = y or similar to discharge with rel_auto *)
lemma "($x\<acute> >\<^sub>u $x \<and> $y\<acute> <\<^sub>u $y) \<sqsubseteq> x, y := x + 1, y"
  oops

lemma "false \<sqsubseteq> x, y := x + 1, y"
  apply (rel_simp)
  oops

lemma "(true ;; x := \<guillemotleft>c\<guillemotright>) = ($x\<acute> =\<^sub>u \<guillemotleft>c\<guillemotright>)"
  oops (* Modified Jim's property *)

lemma "x := 1 ;; (y := 7 \<triangleleft> $x >\<^sub>u 0 \<triangleright> y := 8) = (x,y) := (1,7)"
  oops

lemma "x := 1 ;; (y := 7 \<triangleleft> $x >\<^sub>u 0 \<triangleright> y := 8) = (x,y) := (1,7)"
  oops (* Redo above as Isar proof *)

lemma wp_ex_1: "x := x - 5 wp (x > 10) = (&x >\<^sub>u 15)"
  oops (* Use wp_tac, subst_tac, and pred_auto *)

lemma wp_ex_2: "x := x - 5 ;; x := (x div 2) wp (x > 20) = (&x >\<^sub>u 46)"
  oops

lemma wp_ex_3:
      "(x := \<guillemotleft>X\<guillemotright> ;;
        y := \<guillemotleft>Y\<guillemotright> ;;
        x := x + y ;;
        y := x - y ;;
        x := x - y) wp (x = \<guillemotleft>Y\<guillemotright> \<and> y = \<guillemotleft>X\<guillemotright>) = true"
  oops

lemma wp_ex_4:
      "((x := \<guillemotleft>X\<guillemotright> ;;
         y := \<guillemotleft>Y\<guillemotright> ;;
         x := x * y ;;
         y := x div y ;;
         x := x div y) wp (x = \<guillemotleft>Y\<guillemotright> \<and> y = \<guillemotleft>X\<guillemotright>)) = true"
  oops (* Additional assumptions are needed *)

lemma hoare_ex_1:
  "{{true}} if x > y then z := x else z := y fi {{z = max(x, y)}}"
  apply (hoare_auto)
  oops

lemma hoare_ex_2:
  assumes "X > 0" "Y > 0"
  shows
  "{{x = \<guillemotleft>X\<guillemotright> \<and> y = \<guillemotleft>Y\<guillemotright>}}
    while \<not>(x = y)
    invr x > 0 \<and> y > 0 \<and> (gcd(x,y) = gcd(\<guillemotleft>X\<guillemotright>,\<guillemotleft>Y\<guillemotright>))
    do
       if x > y then x := x - y else y := y - x fi
    od
    {{x = gcd(\<guillemotleft>X\<guillemotright>, \<guillemotleft>Y\<guillemotright>)}}"
  using assms
  apply (hoare_auto)
  apply (simp add: gcd_diff1)
  oops

lemma hoare_ex_3:
  assumes "X > 0" "Y > 0"
  shows
  "{{x = \<guillemotleft>X\<guillemotright> \<and> y = \<guillemotleft>Y\<guillemotright>}}
    while \<not>(x = y)
    invr x > 0 \<and> y > 0 \<and> (gcd(x,y) = gcd(\<guillemotleft>X\<guillemotright>,\<guillemotleft>Y\<guillemotright>))
    vrt nat(x + y)
    do
       if x > y then x := x - y else y := y - x fi
    od
    {{x = gcd(\<guillemotleft>X\<guillemotright>, \<guillemotleft>Y\<guillemotright>)}}"
  using assms
  apply (hoare_auto)
  oops

lemma "x :=\<^sub>D 1 ;; x :=\<^sub>D (x + 1) = x :=\<^sub>D 2"
  oops (* Rule required: assigns_d_comp *)

lemma violate_precond:
  "(true \<turnstile>\<^sub>n x := 1) ;; ((&x >\<^sub>u 1) \<turnstile>\<^sub>n y := 2) = \<bottom>\<^sub>D"
  oops (* Prove using Isar *)
end


section {* Standalone Verification Component Based on KAT *}

theory VC_KAT_scratch
  imports Main GCD (*"$ISABELLE_HOME/src/HOL/Eisbach/Eisbach"*)

begin

subsection {* KAT: Definition and Basic Properties *}

text {* Most proofs are fully automated when using SMT solvers. We have added proofs without these tools for the AFP,
 but SMT proofs can be commented in if wanted. *}

notation times (infixl "\<cdot>" 70)

class plus_ord = plus + ord +
  assumes less_eq_def: "x \<le> y \<longleftrightarrow> x + y = y"
  and less_def: "x < y \<longleftrightarrow> x \<le> y \<and> x \<noteq> y"

class dioid = semiring + one + zero + plus_ord +
  assumes add_idem [simp]: "x + x = x"
  and mult_onel [simp]: "1 \<cdot> x = x"
  and mult_oner [simp]: "x \<cdot> 1 = x"
  and add_zerol [simp]: "0 + x = x"
  and annil [simp]: "0 \<cdot> x = 0"
  and annir [simp]: "x \<cdot> 0 = 0"

begin

subclass monoid_mult
  by (standard, simp_all)

subclass order
  apply (standard, simp_all add: less_def less_eq_def add_commute)
  apply auto[1]
  by (metis add_assoc)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis distrib_left less_eq_def)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis distrib_right less_eq_def)

lemma add_iso: "x \<le> y \<Longrightarrow> x + z \<le> y + z"
  by (metis (no_types, lifting) abel_semigroup.commute add.abel_semigroup_axioms add.semigroup_axioms add_idem less_eq_def semigroup.assoc)

lemma add_lub: "x + y \<le> z \<longleftrightarrow> x \<le> z \<and> y \<le> z"
  by (metis add_assoc add_commute less_eq_def order.ordering_axioms ordering.refl)

end

class kleene_algebra = dioid +
  fixes star :: "'a \<Rightarrow> 'a" ("_\<^sup>\<star>" [101] 100)
  assumes star_unfoldl: "1 + x \<cdot> x\<^sup>\<star> \<le> x\<^sup>\<star>"
  and star_unfoldr: "1 + x\<^sup>\<star> \<cdot> x \<le> x\<^sup>\<star>"
  and star_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x\<^sup>\<star> \<cdot> z \<le> y"
  and star_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x\<^sup>\<star> \<le> y"

begin

lemma star_sim: "x \<cdot> y \<le> z \<cdot> x \<Longrightarrow> x \<cdot> y\<^sup>\<star> \<le> z\<^sup>\<star> \<cdot> x"
(*  by (sm add_commute add_assoc add_idem distrib_left distrib_right less_eq_def mult_onel star_inductr star_unfoldr mult_assoc)  *)
proof -
  assume "x \<cdot> y \<le> z \<cdot> x"
  hence "x + z\<^sup>\<star> \<cdot> x \<cdot> y \<le> x + z\<^sup>\<star> \<cdot> z \<cdot> x"
    by (metis add_lub distrib_left eq_refl less_eq_def mult_assoc)
  also have  "... \<le> z\<^sup>\<star> \<cdot> x"
    using add_lub mult_isor star_unfoldr by fastforce
  finally show ?thesis
    by (simp add: star_inductr)
qed

end

class kat = kleene_algebra +
  fixes at :: "'a \<Rightarrow> 'a"
  assumes test_one [simp]: "at (at 1) = 1"
  and test_mult [simp]: "at (at (at (at x) \<cdot> at (at y))) = at (at y) \<cdot> at (at x)"
  and test_mult_comp [simp]: "at x \<cdot> at (at x) = 0"
  and test_de_morgan: "at x + at y = at (at (at x) \<cdot> at (at y))"

begin

definition t_op :: "'a \<Rightarrow> 'a" ("t_" [100] 101) where
  "t x = at (at x)"

lemma t_n [simp]: "t (at x) = at x"
  by (metis add_idem test_de_morgan test_mult t_op_def)

lemma t_comm: "t x \<cdot> t y = t y \<cdot> t x"
  by (metis add_commute test_de_morgan test_mult t_op_def)

lemma t_idem [simp]: "t x \<cdot> t x = t x"
  by (metis add_idem test_de_morgan test_mult t_op_def)

lemma t_mult_closed [simp]: "t (t x \<cdot> t y) = t x \<cdot> t y"
  using t_comm t_op_def by auto

subsection{* Propositional Hoare Logic *}

definition H :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "H p x q \<longleftrightarrow> t p \<cdot> x \<le> x \<cdot> t q"

definition if_then_else :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = t p \<cdot> x + at p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (t p \<cdot> x)\<^sup>\<star> \<cdot> at p"

definition while_inv :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ inv _ do _ od" [64,64,64] 63) where
  "while p inv i do x od = while p do x od"

lemma H_skip: "H p 1 p"
  by (simp add: H_def)

lemma H_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> H p' x q' \<Longrightarrow> H p x q"
  by (meson H_def mult_isol mult_isor order.trans)

lemma H_seq: "H r y q \<Longrightarrow> H p x r  \<Longrightarrow> H p (x \<cdot> y) q"
(* by (smt H_def add.semigroup_axioms distrib_left distrib_right less_eq_def mult.semigroup_axioms semigroup.assoc)*)
proof -
  assume h1: "H p x r" and h2: "H r y q"
  hence h3: "t p \<cdot> x \<le> x \<cdot> t r" and h4: "t r \<cdot> y \<le> y \<cdot> t q"
    using H_def apply  blast using H_def h2 by blast
  hence "t p \<cdot> x \<cdot> y \<le> x \<cdot> t r \<cdot> y"
    using mult_isor by blast
  also have "... \<le> x \<cdot> y \<cdot> t q"
    by (simp add: h4 mult_isol mult_assoc)
  finally show ?thesis
    by (simp add: H_def mult_assoc)
qed

lemma H_cond: "H (t p \<cdot> t r) x q \<Longrightarrow> H (t p \<cdot> at r) y q \<Longrightarrow> H p (if r then x else y fi) q"
(* by (smt H_def abel_semigroup.commute abel_semigroup.left_commute if_then_else_def add.abel_semigroup_axioms distrib_left distrib_right less_eq_def mult.semigroup_axioms t_comm t_idem t_mult_closed t_n semigroup.assoc)*)
proof -
  assume h1: "H (t p \<cdot> t r) x q" and h2: "H (t p \<cdot> at r) y q"
  hence h3: "t r \<cdot> t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t q" and h4: "at r \<cdot> t p \<cdot> at r \<cdot> y \<le> at r \<cdot> y \<cdot> t q"
    by (simp add: H_def mult_isol mult_assoc, metis H_def h2 mult_isol mult_assoc t_mult_closed t_n)
  hence h5: "t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t q" and  h6: "t p \<cdot> at r \<cdot> y \<le> at r \<cdot> y \<cdot> t q"
    by (simp add: mult_assoc t_comm, metis h4 mult_assoc t_comm t_idem t_n)
  have "t p \<cdot> (t r \<cdot> x + at r \<cdot> y) = t p \<cdot> t r \<cdot> x + t p \<cdot> at r \<cdot> y"
    by (simp add: distrib_left mult_assoc)
  also have "... \<le> t r \<cdot> x \<cdot> t q + t p \<cdot> at r \<cdot> y"
    using h5 add_iso by blast
  also have "... \<le> t r \<cdot> x \<cdot> t q + at r \<cdot> y \<cdot> t q"
    by (simp add: add_commute h6 add_iso)
  finally show ?thesis
    by (simp add: H_def if_then_else_def distrib_right)
qed

lemma H_loop: "H (t p \<cdot> t r) x p \<Longrightarrow> H p (while r do x od) (t p \<cdot> at r)"
(*  by (smt while_def H_def distrib_left less_eq_def mult.semigroup_axioms semigroup.assoc star_sim t_comm t_idem t_mult_closed mult_isor test_mult t_n t_op_def)*)
proof -
  assume  "H (t p \<cdot> t r) x p"
  hence "t r \<cdot> t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t p"
    by (metis H_def distrib_left less_eq_def mult_assoc t_mult_closed)
  hence "t p \<cdot> t r \<cdot> x \<le> t r \<cdot> x \<cdot> t p"
    by (simp add: mult_assoc t_comm)
  hence "t p \<cdot> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<le> (t r \<cdot> x)\<^sup>\<star> \<cdot> t p \<cdot> at r"
    by (metis mult_isor star_sim mult_assoc)
  hence "t p \<cdot> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<le> (t r \<cdot> x)\<^sup>\<star> \<cdot> at r \<cdot> t p \<cdot> at r"
    by (metis mult_assoc t_comm t_idem t_n)
  thus ?thesis
    by (metis H_def mult_assoc t_mult_closed t_n while_def)
qed

lemma H_while_inv: "t p \<le> t i \<Longrightarrow> t i \<cdot> at r \<le> t q \<Longrightarrow> H (t i \<cdot> t r) x i \<Longrightarrow> H p (while r inv i do x od) q"
  by (metis H_cons H_loop t_mult_closed t_n while_inv_def)

end

subsection{* Soundness *}

notation relcomp (infixl ";" 70)

interpretation rel_d: dioid Id "{}" "op \<union>" "op ;" "op \<subseteq>" "op \<subset>"
  by (standard, auto)

lemma (in dioid) power_inductl: "z + x \<cdot> y \<le> y \<Longrightarrow> x ^ i \<cdot> z \<le> y"
  by (induct i, simp add: add_lub, smt add_lub distrib_left less_eq_def power.power_Suc mult_assoc)

lemma (in dioid) power_inductr: "z + y \<cdot> x \<le> y \<Longrightarrow> z \<cdot> x ^ i \<le> y"
  by (induct i, simp add: add_lub, smt add_lub combine_common_factor less_eq_def power_Suc2 mult_assoc)

lemma power_is_relpow: "rel_d.power X i = X ^^ i"
  by (induct i, simp_all add: relpow_commute)

lemma rel_star_def: "X^* = (\<Union>i. rel_d.power X i)"
  by (simp add: power_is_relpow rtrancl_is_UN_relpow)

lemma rel_star_contl: "X ; Y^* = (\<Union>i. X ; rel_d.power Y i)"
  by (simp add: rel_star_def relcomp_UNION_distrib)

lemma rel_star_contr: "X^* ; Y = (\<Union>i. (rel_d.power X i) ; Y)"
  by (simp add: rel_star_def relcomp_UNION_distrib2)

definition rel_at :: "'a rel \<Rightarrow> 'a rel" where
  "rel_at X = Id \<inter> - X"

interpretation rel_kat: kat Id "{}" "op \<union>" "op ;" "op \<subseteq>" "op \<subset>"  rtrancl rel_at
  apply standard
  apply auto[2]
  by (auto simp: rel_star_contr rel_d.power_inductl rel_star_contl  SUP_least rel_d.power_inductr rel_at_def)

subsection{* Embedding Predicates in Relations *}

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

abbreviation p2r :: "'a pred \<Rightarrow> 'a rel" ("\<lceil>_\<rceil>") where
  "\<lceil>P\<rceil> \<equiv> {(s,s) |s. P s}"

lemma t_p2r [simp]: "rel_kat.t_op \<lceil>P\<rceil> = \<lceil>P\<rceil>"
  by (auto simp add: rel_kat.t_op_def rel_at_def)

lemma p2r_neg_hom [simp]: "rel_at \<lceil>P\<rceil> = \<lceil>\<lambda>s. \<not> P s\<rceil>"
  by (auto simp: rel_at_def)

lemma p2r_conj_hom [simp]: "\<lceil>P\<rceil> \<inter> \<lceil>Q\<rceil> = \<lceil>\<lambda>s.  P s \<and> Q s\<rceil>"
  by auto

lemma p2r_conj_hom_var [simp]: "\<lceil>P\<rceil> ; \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<and> Q s\<rceil>"
  by auto

lemma p2r_disj_hom [simp]: "\<lceil>P\<rceil> \<union> \<lceil>Q\<rceil> = \<lceil>\<lambda>s. P s \<or> Q s\<rceil>"
  by auto

lemma impl_prop [simp]: "\<lceil>P\<rceil> \<subseteq> \<lceil>Q\<rceil> \<longleftrightarrow> (\<forall>s. P s \<longrightarrow>  Q s)"
  by auto

subsection {* Store and Assignment *}

type_synonym 'a store = "string  \<Rightarrow> 'a"

definition gets :: "string \<Rightarrow> ('a store \<Rightarrow> 'a) \<Rightarrow> 'a store rel" ("_ ::= _" [70, 65] 61) where
  "v ::= e = {(s,s (v := e s)) |s. True}"

lemma H_assign: "rel_kat.H \<lceil>\<lambda>s. P (s (v := e s))\<rceil> (v ::= e) \<lceil>P\<rceil>"
  by (auto simp: gets_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

lemma H_assign_var: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> rel_kat.H \<lceil>P\<rceil> (v ::= e) \<lceil>Q\<rceil>"
  by (auto simp: gets_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

subsection {* Simplifications *}

abbreviation H_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a pred \<Rightarrow> bool" ("PRE _ _ POST _" [64,64,64] 63) where
  "PRE P X POST Q \<equiv> rel_kat.H \<lceil>P\<rceil> X \<lceil>Q\<rceil>"

abbreviation if_then_else_sugar :: "'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("IF _ THEN _ ELSE _ FI" [64,64,64] 63) where
  "IF P THEN X ELSE Y FI \<equiv> rel_kat.if_then_else \<lceil>P\<rceil> X Y"

abbreviation while_inv_sugar :: "'a pred \<Rightarrow> 'a pred \<Rightarrow> 'a rel \<Rightarrow> 'a rel" ("WHILE _ INV _ DO _ OD" [64,64,64] 63) where
  "WHILE P INV I DO X OD \<equiv> rel_kat.while_inv \<lceil>P\<rceil> \<lceil>I\<rceil> X"

subsection {* Examples *}

lemma euclid:
  "PRE (\<lambda>s::nat store. s ''x'' = x \<and> s ''y'' = y)
   (WHILE (\<lambda>s. s ''y'' \<noteq> 0) INV (\<lambda>s. gcd (s ''x'') (s ''y'') = gcd x y)
    DO
     (''z'' ::= (\<lambda>s. s ''y''));
     (''y'' ::= (\<lambda>s. s ''x'' mod s ''y''));
     (''x'' ::= (\<lambda>s. s ''z''))
    OD)
   POST (\<lambda>s. s ''x'' = gcd x y)"
  apply (rule rel_kat.H_while_inv, simp_all, clarsimp)
  apply (intro rel_kat.H_seq)
  apply (subst H_assign, simp)+
  apply (rule H_assign_var)
  using gcd_red_nat by auto

section {* Refinement Component Based on KAT *}

subsection {* Definition of RKAT *}

class rkat = kat +
  fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  assumes R1: "H p (R p q) q"
  and R2: "H p x q \<Longrightarrow> x \<le> R p q"

begin

subsection {* Refinement Laws *}

lemma R_skip: "1 \<le> R p p"
  by (simp add: H_skip R2)

lemma R_cons: "t p \<le> t p' \<Longrightarrow> t q' \<le> t q \<Longrightarrow> R p' q' \<le> R p q"
  by (simp add: H_cons R2 R1)

lemma R_seq: "(R p r) \<cdot> (R r q) \<le> R p q"
  using H_seq R2 R1 by blast

lemma R_cond: "if v then (R (t v \<cdot> t p) q) else (R (at v \<cdot> t p) q) fi \<le> R p q"
  by (metis H_cond R1 R2 t_comm t_n)

lemma R_loop: "while q do (R (t p \<cdot> t q) p) od  \<le> R p (t p \<cdot> at q)"
  by (simp add: H_loop R2 R1)

end

subsection {* Soundness *}

definition rel_R :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a rel" where
  "rel_R P Q = \<Union>{X. rel_kat.H P X Q}"

interpretation rel_rkat: rkat Id "{}" "op \<union>"  "op ;" "op \<subseteq>" "op \<subset>" rtrancl rel_at rel_R
  by (standard, auto simp: rel_R_def rel_kat.H_def rel_kat.t_op_def rel_at_def)

subsection {* Assignment Laws *}

lemma R_assign: "(\<forall>s. P s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
  by (simp add: H_assign_var rel_rkat.R2)

lemma R_assignr: "(\<forall>s. Q' s \<longrightarrow> Q (s (v := e s))) \<Longrightarrow> (rel_R \<lceil>P\<rceil> \<lceil>Q'\<rceil>) ; (v ::= e) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
proof -
  assume a1: "\<forall>s. Q' s \<longrightarrow> Q (s(v := e s))"
  have "\<forall>p pa cs f. \<exists>fa. (p fa \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>) \<and> (\<not> pa (fa(cs := f fa::'a)) \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>)"
    using R_assign by blast
  hence "v ::= e \<subseteq> rel_R \<lceil>Q'\<rceil> \<lceil>Q\<rceil>"
    using a1 by blast
  thus ?thesis
    by (meson dual_order.trans rel_d.mult_isol rel_rkat.R_seq)
qed

lemma R_assignl: "(\<forall>s. P s \<longrightarrow> P' (s (v := e s))) \<Longrightarrow> (v ::= e) ; (rel_R \<lceil>P'\<rceil> \<lceil>Q\<rceil>) \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>Q\<rceil>"
proof -
  assume a1: "\<forall>s. P s \<longrightarrow> P' (s(v := e s))"
  have "\<forall>p pa cs f. \<exists>fa. (p fa \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>) \<and> (\<not> pa (fa(cs := f fa::'a)) \<or> cs ::= f \<subseteq> rel_R \<lceil>p\<rceil> \<lceil>pa\<rceil>)"
    using R_assign by blast
  then have "v ::= e \<subseteq> rel_R \<lceil>P\<rceil> \<lceil>P'\<rceil>"
    using a1 by blast
  then show ?thesis
    by (meson dual_order.trans rel_d.mult_isor rel_rkat.R_seq)
qed

subsection {* Example *}

lemma var_swap_ref1:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref2:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''x'' ::= (\<lambda>s. s ''y'')); rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref3:
  "rel_R \<lceil>\<lambda>s. s ''z'' = a \<and> s ''x'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''y'' ::= (\<lambda>s. s ''z'')); rel_R \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>"
  by (rule R_assignl, auto)

lemma var_swap_ref_var:
  "rel_R \<lceil>\<lambda>s. s ''x'' = a \<and> s ''y'' = b\<rceil> \<lceil>\<lambda>s. s ''x'' = b \<and> s ''y'' = a\<rceil>
   \<supseteq> (''z'' ::= (\<lambda>s. s ''x'')); (''x'' ::= (\<lambda>s. s ''y'')); (''y'' ::= (\<lambda>s. s ''z''))"
  using var_swap_ref1 var_swap_ref2 var_swap_ref3 rel_rkat.R_skip  by fastforce

end


(*  Title:      HOL/Proofs/Lambda/Standardization.thy
    Author:     Stefan Berghofer
    Copyright   2005 TU Muenchen
*)

section {* Standardization *}

theory Standardization
imports NormalForm
begin

text {*
Based on lecture notes by Ralph Matthes @{cite "Matthes-ESSLLI2000"},
original proof idea due to Ralph Loader @{cite Loader1998}.
*}

subsection {* Standard reduction relation *}

declare listrel_mono [mono_set]

inductive
  sred :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>s" 50)
  and sredlist :: "dB list \<Rightarrow> dB list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>s]" 50)
where
  "s [\<rightarrow>\<^sub>s] t \<equiv> listrelp op \<rightarrow>\<^sub>s s t"
| Var: "rs [\<rightarrow>\<^sub>s] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>s r' \<Longrightarrow> ss [\<rightarrow>\<^sub>s] ss' \<Longrightarrow> Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> ss'"
| Beta: "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>s t \<Longrightarrow> Abs r \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>s t"

lemma refl_listrelp: "\<forall>x\<in>set xs. R x x \<Longrightarrow> listrelp R xs xs"
  by (induct xs) (auto intro: listrelp.intros)

lemma refl_sred: "t \<rightarrow>\<^sub>s t"
  by (induct t rule: Apps_dB_induct) (auto intro: refl_listrelp sred.intros)

lemma refl_sreds: "ts [\<rightarrow>\<^sub>s] ts"
  by (simp add: refl_sred refl_listrelp)

lemma listrelp_conj1: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp R x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_conj2: "listrelp (\<lambda>x y. R x y \<and> S x y) x y \<Longrightarrow> listrelp S x y"
  by (erule listrelp.induct) (auto intro: listrelp.intros)

lemma listrelp_app:
  assumes xsys: "listrelp R xs ys"
  shows "listrelp R xs' ys' \<Longrightarrow> listrelp R (xs @ xs') (ys @ ys')" using xsys
  by (induct arbitrary: xs' ys') (auto intro: listrelp.intros)

lemma lemma1:
  assumes r: "r \<rightarrow>\<^sub>s r'" and s: "s \<rightarrow>\<^sub>s s'"
  shows "r \<degree> s \<rightarrow>\<^sub>s r' \<degree> s'" using r
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "rs @ [s] [\<rightarrow>\<^sub>s] rs' @ [s']" by (rule listrelp_app)
  hence "Var x \<degree>\<degree> (rs @ [s]) \<rightarrow>\<^sub>s Var x \<degree>\<degree> (rs' @ [s'])" by (rule sred.Var)
  thus ?case by (simp only: app_last)
next
  case (Abs r r' ss ss')
  from Abs(3) have "ss [\<rightarrow>\<^sub>s] ss'" by (rule listrelp_conj1)
  moreover have "[s] [\<rightarrow>\<^sub>s] [s']" by (iprover intro: s listrelp.intros)
  ultimately have "ss @ [s] [\<rightarrow>\<^sub>s] ss' @ [s']" by (rule listrelp_app)
  with `r \<rightarrow>\<^sub>s r'` have "Abs r \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> (ss' @ [s'])"
    by (rule sred.Abs)
  thus ?case by (simp only: app_last)
next
  case (Beta r u ss t)
  hence "r[u/0] \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (simp only: app_last)
  hence "Abs r \<degree> u \<degree>\<degree> (ss @ [s]) \<rightarrow>\<^sub>s t \<degree> s'" by (rule sred.Beta)
  thus ?case by (simp only: app_last)
qed

lemma lemma1':
  assumes ts: "ts [\<rightarrow>\<^sub>s] ts'"
  shows "r \<rightarrow>\<^sub>s r' \<Longrightarrow> r \<degree>\<degree> ts \<rightarrow>\<^sub>s r' \<degree>\<degree> ts'" using ts
  by (induct arbitrary: r r') (auto intro: lemma1)

lemma lemma2_1:
  assumes beta: "t \<rightarrow>\<^sub>\<beta> u"
  shows "t \<rightarrow>\<^sub>s u" using beta
proof induct
  case (beta s t)
  have "Abs s \<degree> t \<degree>\<degree> [] \<rightarrow>\<^sub>s s[t/0] \<degree>\<degree> []" by (iprover intro: sred.Beta refl_sred)
  thus ?case by simp
next
  case (appL s t u)
  thus ?case by (iprover intro: lemma1 refl_sred)
next
  case (appR s t u)
  thus ?case by (iprover intro: lemma1 refl_sred)
next
  case (abs s t)
  hence "Abs s \<degree>\<degree> [] \<rightarrow>\<^sub>s Abs t \<degree>\<degree> []" by (iprover intro: sred.Abs listrelp.Nil)
  thus ?case by simp
qed

lemma listrelp_betas:
  assumes ts: "listrelp op \<rightarrow>\<^sub>\<beta>\<^sup>* ts ts'"
  shows "\<And>t t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<Longrightarrow> t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<degree>\<degree> ts'" using ts
  by induct auto

lemma lemma2_2:
  assumes t: "t \<rightarrow>\<^sub>s u"
  shows "t \<rightarrow>\<^sub>\<beta>\<^sup>* u" using t
  by induct (auto dest: listrelp_conj2
    intro: listrelp_betas apps_preserves_beta converse_rtranclp_into_rtranclp)

lemma sred_lift:
  assumes s: "s \<rightarrow>\<^sub>s t"
  shows "lift s i \<rightarrow>\<^sub>s lift t i" using s
proof (induct arbitrary: i)
  case (Var rs rs' x)
  hence "map (\<lambda>t. lift t i) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. lift t i) rs'"
    by induct (auto intro: listrelp.intros)
  thus ?case by (cases "x < i") (auto intro: sred.Var)
next
  case (Abs r r' ss ss')
  from Abs(3) have "map (\<lambda>t. lift t i) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. lift t i) ss'"
    by induct (auto intro: listrelp.intros)
  thus ?case by (auto intro: sred.Abs Abs)
next
  case (Beta r s ss t)
  thus ?case by (auto intro: sred.Beta)
qed

lemma lemma3:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "s \<rightarrow>\<^sub>s s' \<Longrightarrow> r[s/x] \<rightarrow>\<^sub>s r'[s'/x]" using r
proof (induct arbitrary: s s' x)
  case (Var rs rs' y)
  hence "map (\<lambda>t. t[s/x]) rs [\<rightarrow>\<^sub>s] map (\<lambda>t. t[s'/x]) rs'"
    by induct (auto intro: listrelp.intros Var)
  moreover have "Var y[s/x] \<rightarrow>\<^sub>s Var y[s'/x]"
  proof (cases "y < x")
    case True thus ?thesis by simp (rule refl_sred)
  next
    case False
    thus ?thesis
      by (cases "y = x") (auto simp add: Var intro: refl_sred)
  qed
  ultimately show ?case by simp (rule lemma1')
next
  case (Abs r r' ss ss')
  from Abs(4) have "lift s 0 \<rightarrow>\<^sub>s lift s' 0" by (rule sred_lift)
  hence "r[lift s 0/Suc x] \<rightarrow>\<^sub>s r'[lift s' 0/Suc x]" by (fast intro: Abs.hyps)
  moreover from Abs(3) have "map (\<lambda>t. t[s/x]) ss [\<rightarrow>\<^sub>s] map (\<lambda>t. t[s'/x]) ss'"
    by induct (auto intro: listrelp.intros Abs)
  ultimately show ?case by simp (rule sred.Abs)
next
  case (Beta r u ss t)
  thus ?case by (auto simp add: subst_subst intro: sred.Beta)
qed

lemma lemma4_aux:
  assumes rs: "listrelp (\<lambda>t u. t \<rightarrow>\<^sub>s u \<and> (\<forall>r. u \<rightarrow>\<^sub>\<beta> r \<longrightarrow> t \<rightarrow>\<^sub>s r)) rs rs'"
  shows "rs' => ss \<Longrightarrow> rs [\<rightarrow>\<^sub>s] ss" using rs
proof (induct arbitrary: ss)
  case Nil
  thus ?case by cases (auto intro: listrelp.Nil)
next
  case (Cons x y xs ys)
  note Cons' = Cons
  show ?case
  proof (cases ss)
    case Nil with Cons show ?thesis by simp
  next
    case (Cons y' ys')
    hence ss: "ss = y' # ys'" by simp
    from Cons Cons' have "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys \<or> y' = y \<and> ys => ys'" by simp
    hence "x # xs [\<rightarrow>\<^sub>s] y' # ys'"
    proof
      assume H: "y \<rightarrow>\<^sub>\<beta> y' \<and> ys' = ys"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from Cons' have "xs [\<rightarrow>\<^sub>s] ys" by (iprover dest: listrelp_conj1)
      ultimately have "x # xs [\<rightarrow>\<^sub>s] y' # ys" by (rule listrelp.Cons)
      with H show ?thesis by simp
    next
      assume H: "y' = y \<and> ys => ys'"
      with Cons' have "x \<rightarrow>\<^sub>s y'" by blast
      moreover from H have "xs [\<rightarrow>\<^sub>s] ys'" by (blast intro: Cons')
      ultimately show ?thesis by (rule listrelp.Cons)
    qed
    with ss show ?thesis by simp
  qed
qed

lemma lemma4:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "r' \<rightarrow>\<^sub>\<beta> r'' \<Longrightarrow> r \<rightarrow>\<^sub>s r''" using r
proof (induct arbitrary: r'')
  case (Var rs rs' x)
  then obtain ss where rs: "rs' => ss" and r'': "r'' = Var x \<degree>\<degree> ss"
    by (blast dest: head_Var_reduction)
  from Var(1) rs have "rs [\<rightarrow>\<^sub>s] ss" by (rule lemma4_aux)
  hence "Var x \<degree>\<degree> rs \<rightarrow>\<^sub>s Var x \<degree>\<degree> ss" by (rule sred.Var)
  with r'' show ?case by simp
next
  case (Abs r r' ss ss')
  from `Abs r' \<degree>\<degree> ss' \<rightarrow>\<^sub>\<beta> r''` show ?case
  proof
    fix s
    assume r'': "r'' = s \<degree>\<degree> ss'"
    assume "Abs r' \<rightarrow>\<^sub>\<beta> s"
    then obtain r''' where s: "s = Abs r'''" and r''': "r' \<rightarrow>\<^sub>\<beta> r'''" by cases auto
    from r''' have "r \<rightarrow>\<^sub>s r'''" by (blast intro: Abs)
    moreover from Abs have "ss [\<rightarrow>\<^sub>s] ss'" by (iprover dest: listrelp_conj1)
    ultimately have "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r''' \<degree>\<degree> ss'" by (rule sred.Abs)
    with r'' s show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    fix rs'
    assume "ss' => rs'"
    with Abs(3) have "ss [\<rightarrow>\<^sub>s] rs'" by (rule lemma4_aux)
    with `r \<rightarrow>\<^sub>s r'` have "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> rs'" by (rule sred.Abs)
    moreover assume "r'' = Abs r' \<degree>\<degree> rs'"
    ultimately show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" by simp
  next
    fix t u' us'
    assume "ss' = u' # us'"
    with Abs(3) obtain u us where
      ss: "ss = u # us" and u: "u \<rightarrow>\<^sub>s u'" and us: "us [\<rightarrow>\<^sub>s] us'"
      by cases (auto dest!: listrelp_conj1)
    have "r[u/0] \<rightarrow>\<^sub>s r'[u'/0]" using Abs(1) and u by (rule lemma3)
    with us have "r[u/0] \<degree>\<degree> us \<rightarrow>\<^sub>s r'[u'/0] \<degree>\<degree> us'" by (rule lemma1')
    hence "Abs r \<degree> u \<degree>\<degree> us \<rightarrow>\<^sub>s r'[u'/0] \<degree>\<degree> us'" by (rule sred.Beta)
    moreover assume "Abs r' = Abs t" and "r'' = t[u'/0] \<degree>\<degree> us'"
    ultimately show "Abs r \<degree>\<degree> ss \<rightarrow>\<^sub>s r''" using ss by simp
  qed
next
  case (Beta r s ss t)
  show ?case
    by (rule sred.Beta) (rule Beta)+
qed

lemma rtrancl_beta_sred:
  assumes r: "r \<rightarrow>\<^sub>\<beta>\<^sup>* r'"
  shows "r \<rightarrow>\<^sub>s r'" using r
  by induct (iprover intro: refl_sred lemma4)+

subsection {* Leftmost reduction and weakly normalizing terms *}

inductive
  lred :: "dB \<Rightarrow> dB \<Rightarrow> bool"  (infixl "\<rightarrow>\<^sub>l" 50)
  and lredlist :: "dB list \<Rightarrow> dB list \<Rightarrow> bool"  (infixl "[\<rightarrow>\<^sub>l]" 50)
where
  "s [\<rightarrow>\<^sub>l] t \<equiv> listrelp op \<rightarrow>\<^sub>l s t"
| Var: "rs [\<rightarrow>\<^sub>l] rs' \<Longrightarrow> Var x \<degree>\<degree> rs \<rightarrow>\<^sub>l Var x \<degree>\<degree> rs'"
| Abs: "r \<rightarrow>\<^sub>l r' \<Longrightarrow> Abs r \<rightarrow>\<^sub>l Abs r'"
| Beta: "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>l t \<Longrightarrow> Abs r \<degree> s \<degree>\<degree> ss \<rightarrow>\<^sub>l t"

lemma lred_imp_sred:
  assumes lred: "s \<rightarrow>\<^sub>l t"
  shows "s \<rightarrow>\<^sub>s t" using lred
proof induct
  case (Var rs rs' x)
  then have "rs [\<rightarrow>\<^sub>s] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (rule sred.Var)
next
  case (Abs r r')
  from `r \<rightarrow>\<^sub>s r'`
  have "Abs r \<degree>\<degree> [] \<rightarrow>\<^sub>s Abs r' \<degree>\<degree> []" using listrelp.Nil
    by (rule sred.Abs)
  then show ?case by simp
next
  case (Beta r s ss t)
  from `r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>s t`
  show ?case by (rule sred.Beta)
qed

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

lemma listrelp_imp_listsp1:
  assumes H: "listrelp (\<lambda>x y. P x) xs ys"
  shows "listsp P xs" using H
  by induct auto

lemma listrelp_imp_listsp2:
  assumes H: "listrelp (\<lambda>x y. P y) xs ys"
  shows "listsp P ys" using H
  by induct auto

lemma lemma5:
  assumes lred: "r \<rightarrow>\<^sub>l r'"
  shows "WN r" and "NF r'" using lred
  by induct
    (iprover dest: listrelp_conj1 listrelp_conj2
     listrelp_imp_listsp1 listrelp_imp_listsp2 intro: WN.intros
     NF.intros [simplified listall_listsp_eq])+

lemma lemma6:
  assumes wn: "WN r"
  shows "\<exists>r'. r \<rightarrow>\<^sub>l r'" using wn
proof induct
  case (Var rs n)
  then have "\<exists>rs'. rs [\<rightarrow>\<^sub>l] rs'"
    by induct (iprover intro: listrelp.intros)+
  then show ?case by (iprover intro: lred.Var)
qed (iprover intro: lred.intros)+

lemma lemma7:
  assumes r: "r \<rightarrow>\<^sub>s r'"
  shows "NF r' \<Longrightarrow> r \<rightarrow>\<^sub>l r'" using r
proof induct
  case (Var rs rs' x)
  from `NF (Var x \<degree>\<degree> rs')` have "listall NF rs'"
    by cases simp_all
  with Var(1) have "rs [\<rightarrow>\<^sub>l] rs'"
  proof induct
    case Nil
    show ?case by (rule listrelp.Nil)
  next
    case (Cons x y xs ys)
    hence "x \<rightarrow>\<^sub>l y" and "xs [\<rightarrow>\<^sub>l] ys" by simp_all
    thus ?case by (rule listrelp.Cons)
  qed
  thus ?case by (rule lred.Var)
next
  case (Abs r r' ss ss')
  from `NF (Abs r' \<degree>\<degree> ss')`
  have ss': "ss' = []" by (rule Abs_NF)
  from Abs(3) have ss: "ss = []" using ss'
    by cases simp_all
  from ss' Abs have "NF (Abs r')" by simp
  hence "NF r'" by cases simp_all
  with Abs have "r \<rightarrow>\<^sub>l r'" by simp
  hence "Abs r \<rightarrow>\<^sub>l Abs r'" by (rule lred.Abs)
  with ss ss' show ?case by simp
next
  case (Beta r s ss t)
  hence "r[s/0] \<degree>\<degree> ss \<rightarrow>\<^sub>l t" by simp
  thus ?case by (rule lred.Beta)
qed

lemma WN_eq: "WN t = (\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t')"
proof
  assume "WN t"
  then have "\<exists>t'. t \<rightarrow>\<^sub>l t'" by (rule lemma6)
  then obtain t' where t': "t \<rightarrow>\<^sub>l t'" ..
  then have NF: "NF t'" by (rule lemma5)
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule lred_imp_sred)
  then have "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" by (rule lemma2_2)
  with NF show "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'" by iprover
next
  assume "\<exists>t'. t \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  then obtain t' where t': "t \<rightarrow>\<^sub>\<beta>\<^sup>* t'" and NF: "NF t'"
    by iprover
  from t' have "t \<rightarrow>\<^sub>s t'" by (rule rtrancl_beta_sred)
  then have "t \<rightarrow>\<^sub>l t'" using NF by (rule lemma7)
  then show "WN t" by (rule lemma5)
qed

end


(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo_fr
imports DLO
begin

subsection "Interior Point Method"

text\<open>This section formalizes a new quantifier elimination procedure
based on the idea of Ferrante and Rackoff~\<^cite>\<open>"FerranteR-SIAM75"\<close> (see
also \S\ref{sec:FRE}) of taking a point between each lower and upper
bound as a test point. For dense linear orders it is not obvious how
to realize this because we cannot name any intermediate point
directly.\<close>

fun asubst\<^sub>2 :: "nat \<Rightarrow> nat \<Rightarrow> atom \<Rightarrow> atom fm" where
"asubst\<^sub>2 l u (Less 0 0) = FalseF" |
"asubst\<^sub>2 l u (Less 0 (Suc j)) = Or (Atom(Less u j)) (Atom(Eq u j))" |
"asubst\<^sub>2 l u (Less (Suc i) 0) = Or (Atom(Less i l)) (Atom(Eq i l))" |
"asubst\<^sub>2 l u (Less (Suc i) (Suc j)) = Atom(Less i j)" |
"asubst\<^sub>2 l u (Eq 0 0) = TrueF" |
"asubst\<^sub>2 l u (Eq 0 _) = FalseF" |
"asubst\<^sub>2 l u (Eq _ 0) = FalseF" |
"asubst\<^sub>2 l u (Eq (Suc i) (Suc j)) = Atom(Eq i j)"

abbreviation "subst\<^sub>2 l u \<equiv> amap\<^sub>f\<^sub>m (asubst\<^sub>2 l u)"

lemma I_subst\<^sub>21:
 "nqfree f \<Longrightarrow> xs!l < xs!u \<Longrightarrow> DLO.I (subst\<^sub>2 l u f) xs
 \<Longrightarrow> xs!l < x \<Longrightarrow> x < xs!u \<Longrightarrow> DLO.I f (x#xs)"
proof(induct f arbitrary: x)
  case (Atom a) thus ?case
    by (cases "(l,u,a)" rule: asubst\<^sub>2.cases) auto
qed auto

definition
"nolub f xs l x u \<longleftrightarrow> (\<forall>y\<in>{l<..<x}. y \<notin> LB f xs) \<and> (\<forall>y\<in>{x<..<u}. y \<notin> UB f xs)"

lemma nolub_And[simp]:
  "nolub (And f g) xs l x u = (nolub f xs l x u \<and> nolub g xs l x u)"
by(auto simp:nolub_def)

lemma nolub_Or[simp]:
  "nolub (Or f g) xs l x u = (nolub f xs l x u \<and> nolub g xs l x u)"
by(auto simp:nolub_def)

context notes [[simp_depth_limit=3]]
begin

lemma I_subst\<^sub>22:
 "nqfree f \<Longrightarrow> xs!l < x \<and> x < xs!u \<Longrightarrow> nolub f xs (xs!l) x (xs!u)
 \<Longrightarrow> \<forall>x\<in>{xs!l <..< xs!u}. DLO.I f (x#xs) \<and> x \<notin> EQ f xs
 \<Longrightarrow> DLO.I (subst\<^sub>2 l u f) xs"
proof (induct f)
  case (Atom a) show ?case
    apply (cases "(l,u,a)" rule: asubst\<^sub>2.cases)
    apply(insert Atom, auto simp: EQ_def nolub_def split:if_split_asm)
    done
next
  case Or thus ?case by (simp add: Ball_def)(metis innermost_intvl)
qed auto

end

definition
"qe_interior\<^sub>1 \<phi> =
(let as = DLO.atoms\<^sub>0 \<phi>; lbs = lbounds as; ubs = ubounds as; ebs = ebounds as;
     intrs = [And (Atom(Less l u)) (subst\<^sub>2 l u \<phi>). l\<leftarrow>lbs, u\<leftarrow>ubs]
 in list_disj (inf\<^sub>- \<phi> # inf\<^sub>+ \<phi> # intrs @ map (subst \<phi>) ebs))"

theorem I_interior1:
assumes "nqfree \<phi>" shows "DLO.I (qe_interior\<^sub>1 \<phi>) xs = (\<exists>x. DLO.I \<phi> (x#xs))"
  (is "?QE = ?EX")
proof
  assume ?QE
  { assume "DLO.I (inf\<^sub>- \<phi>) xs"
    hence ?EX using \<open>?QE\<close> min_inf[of \<phi> xs] \<open>nqfree \<phi>\<close>
      by(auto simp add:qe_interior\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume  "DLO.I (inf\<^sub>+ \<phi>) xs"
    hence ?EX using \<open>?QE\<close> plus_inf[of \<phi> xs] \<open>nqfree \<phi>\<close>
      by(auto simp add:qe_interior\<^sub>1_def amap_fm_list_disj)
  } moreover
  { assume "\<not>DLO.I (inf\<^sub>- \<phi>) xs \<and> \<not>DLO.I (inf\<^sub>+ \<phi>) xs \<and>
            (\<forall>x\<in>EQ \<phi> xs. \<not>DLO.I \<phi> (x#xs))"
    with \<open>?QE\<close> \<open>nqfree \<phi>\<close> obtain l u
      where "DLO.I (subst\<^sub>2 l u \<phi>) xs" and "xs!l < xs!u"
      by(fastforce simp: qe_interior\<^sub>1_def set_lbounds set_ubounds I_subst EQ_conv_set_ebounds)
    moreover then obtain x where "xs!l < x \<and> x < xs!u" by(metis dense)
    ultimately have "DLO.I \<phi> (x # xs)"
      using \<open>nqfree \<phi>\<close> I_subst\<^sub>21[OF \<open>nqfree \<phi>\<close> \<open>xs!l < xs!u\<close>] by simp
    hence ?EX .. }
  ultimately show ?EX by blast
next
  let ?as = "DLO.atoms\<^sub>0 \<phi>" let ?E = "set(ebounds ?as)"
  assume ?EX
  then obtain x where x: "DLO.I \<phi> (x#xs)" ..
  { assume "DLO.I (inf\<^sub>- \<phi>) xs \<or> DLO.I (inf\<^sub>+ \<phi>) xs"
    hence ?QE using \<open>nqfree \<phi>\<close> by(auto simp:qe_interior\<^sub>1_def)
  } moreover
  { assume "\<exists>k \<in> ?E. DLO.I (subst \<phi> k) xs"
    hence ?QE by(force simp:qe_interior\<^sub>1_def) } moreover
  { assume "\<not> DLO.I (inf\<^sub>- \<phi>) xs" and "\<not> DLO.I (inf\<^sub>+ \<phi>) xs"
    and "\<forall>k \<in> ?E. \<not> DLO.I (subst \<phi> k) xs"
    hence noE: "\<forall>e \<in> EQ \<phi> xs. \<not> DLO.I \<phi> (e#xs)"
      using \<open>nqfree \<phi>\<close> by (force simp:set_ebounds EQ_def I_subst)
    hence "x \<notin> EQ \<phi> xs" using x by fastforce
    obtain l where "l \<in> LB \<phi> xs" "l < x"
      using LBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> DLO.I(inf\<^sub>- \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    obtain u where "u \<in> UB \<phi> xs" "x < u"
      using UBex[OF \<open>nqfree \<phi>\<close> x \<open>\<not> DLO.I(inf\<^sub>+ \<phi>) xs\<close> \<open>x \<notin> EQ \<phi> xs\<close>] ..
    have "\<exists>l\<in>LB \<phi> xs. \<exists>u\<in>UB \<phi> xs. l<x \<and> x<u \<and> nolub \<phi> xs l x u \<and> (\<forall>y. l < y \<and> y < u \<longrightarrow> DLO.I \<phi> (y#xs))"
      using dense_interval[where P = "\<lambda>x. DLO.I \<phi> (x#xs)", OF finite_LB finite_UB \<open>l:LB \<phi> xs\<close> \<open>u:UB \<phi> xs\<close> \<open>l<x\<close> \<open>x<u\<close> x] x innermost_intvl[OF \<open>nqfree \<phi>\<close> _ _ _ \<open>x \<notin> EQ \<phi> xs\<close>]
      by (simp add:nolub_def)
    then obtain m n where
      "Less (Suc m) 0 \<in> set ?as" "Less 0 (Suc n) \<in> set ?as"
      "xs!m < x \<and> x < xs!n"
      "nolub \<phi> xs (xs!m) x (xs!n)"
      "\<forall>y. xs!m < y \<and> y < xs!n \<longrightarrow> DLO.I \<phi> (y#xs)"
      by blast
    moreover
    hence "DLO.I (subst\<^sub>2 m n \<phi>) xs" using noE
      by(force intro!: I_subst\<^sub>22[OF \<open>nqfree \<phi>\<close>])
    ultimately have ?QE
      by(fastforce simp add:qe_interior\<^sub>1_def bex_Un set_lbounds set_ubounds)
  } ultimately show ?QE by blast
qed

lemma qfree_asubst\<^sub>2: "qfree (asubst\<^sub>2 l u a)"
by(cases "(l,u,a)" rule:asubst\<^sub>2.cases) simp_all

lemma qfree_subst\<^sub>2: "nqfree \<phi> \<Longrightarrow> qfree (subst\<^sub>2 l u \<phi>)"
by(induct \<phi>) (simp_all add:qfree_asubst\<^sub>2)

lemma qfree_interior1: "nqfree \<phi> \<Longrightarrow> qfree(qe_interior\<^sub>1 \<phi>)"
apply(simp add:qe_interior\<^sub>1_def)
apply(rule qfree_list_disj)
apply (auto simp:qfree_min_inf qfree_plus_inf qfree_subst\<^sub>2 qfree_map_fm)
done

definition "qe_interior = DLO.lift_nnf_qe qe_interior\<^sub>1"

lemma qfree_qe_interior: "qfree(qe_interior \<phi>)"
by(simp add: qe_interior_def DLO.qfree_lift_nnf_qe qfree_interior1)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*<*)
theory Chapter2_HoareHeap
imports "AutoCorres.AutoCorres"
begin

external_file "mult_by_add.c"
(*>*)

section  \<open>More Complex Functions with AutoCorres\<close>

text \<open>

  In the previous section we saw how to use the C-Parser and AutoCorres
  to prove properties about some very simple C programs.

  Real life C programs tend to be far more complex however; they
  read and write to local variables, have loops and use pointers to
  access the heap. In this section we will look at some simple programs
  which use loops and access the heap to show how AutoCorres can
  allow such constructs to be reasoned about.

\<close>

subsection \<open>A simple loop: \texttt{mult\_by\_add}\<close>

text \<open>

  Our C function \texttt{mult\_by\_add} implements a multiply operation
  by successive additions:

\lstinputlisting[language=C, firstline=15]{../../mult_by_add.c}

  We start by translating the program using the C parser and AutoCorres,
  and entering the generated locale \texttt{mult\_by\_add}.
\<close>

install_C_file "mult_by_add.c"
autocorres [ts_rules = nondet] "mult_by_add.c"
(*<*)
context mult_by_add begin
(*>*)

text \<open>
  The C parser produces the SIMPL output as follows:
\<close>

thm mult_by_add_body_def
text \<open>@{thm [display] mult_by_add_body_def}\<close>

text \<open>
  Which is abstracted by AutoCorres to the following:
\<close>

thm mult_by_add'_def
text \<open>@{thm [display] mult_by_add'_def }\<close>

text \<open>

  In this case AutoCorres has abstracted \texttt{mult\_by\_add} into a
  \emph{monadic} form. Monads are a pattern frequently used in
  functional programming to represent imperative-style control-flow; an
  in-depth introduction to monads can be found elsewhere.

  The monads used by AutoCorres in this example is a
  \emph{non-deterministic state monad}; program state is implicitly
  passed between each statement, and results of computations may produce
  more than one (or possibly zero) results\footnote{Non-determinism
  becomes useful when modelling hardware, for example, where the exact
  results of the hardware cannot be determined ahead of time.}.
\<close>
  (* FIXME : probably describe below in further detail. *)
text \<open>
  The bulk of @{term "mult_by_add'"} is wrapped inside the @{term
  "whileLoop"} \emph{monad combinator}, which is really just a fancy way
  of describing the method used by AutoCorres to encode (potentially
  non-terminating) loops using monads.

  If we want to describe the behaviour of this program, we can use
  Hoare logic as follows:

    @{term [display] "\<lbrace> P \<rbrace> mult_by_add' a b \<lbrace> Q \<rbrace>"}

  This predicate states that, assuming @{term "P"} holds on the initial
  program state, if we execute @{term "mult_by_add' a b"}, then
  @{term "Q"} will hold on the final state of the program.

  There are a few details: while @{term "P"} has type
  @{typ "'s \<Rightarrow> bool"} (i.e., takes a state and returns true if
  it satisifies the precondition), @{term "Q"} has an additional
  parameter @{typ "'r \<Rightarrow> 's \<Rightarrow> bool"}. The additional parameter
  @{typ "'r"} is the \emph{return value} of the function; so, in
  our \texttt{mult\_by\_add'} example, it will be the result of
  the multiplication.

  For example one useful property to prove on our program would
  be:

    @{term [display] "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>"}

  That is, for all possible input states, our \texttt{mult\_by\_add'}
  function returns the product of @{term "a"} and @{term "b"}.

  Unfortunately, this is not sufficient. As mentioned in the previous
  section, AutoCorres produces a theorem for each function it abstracts
  stating that, \emph{assuming the function does not fail}, then the
  generated function is a valid abstraction of the concrete function.
  Thus, if we wish to reason about our concrete C function, we must
  also show non-failure on the abstract program. This can be done
  using the predicate @{term "no_fail"} as follows:

    @{term [display] "\<And>a b. no_fail (\<lambda>s. True) (mult_by_add' a b)"}

  Here @{term "\<lambda>s. True"} is the precondition on the input state.

  Instead of proving our Hoare triple and @{term no_fail} separately,
  we can prove them together using the ``valid no fail'' framework
  as follows:

    @{thm [display] validNF_def}

  Our proof of @{term mult_by_add'} could then proceed as follows:

\<close>

lemma mult_by_add_correct:
    "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  txt \<open>Unfold abstracted definition\<close>
  apply (unfold mult_by_add'_def)
  txt \<open>Annotate the loop with an invariant and a measure.\<close>
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', result) s. result = (a - a') * b"
        and M="\<lambda>((a', result), s). a'"] )
  txt \<open>Run the ``weakest precondition'' tool \texttt{wp}.\<close>
  apply wp
  txt \<open>Solve the program correctness goals.\<close>
     apply (simp add: field_simps)
    apply unat_arith
   apply (auto simp: field_simps not_less)
  done

(* FIXME: Update the following explanation. *)
text \<open>
  The proof is straight-forward, but uses a few different techniques:
  The first is that we annotate the loop with a loop invariant and a
  measure, using the rule @{thm whileLoop_add_inv}. We then run the
  \texttt{wp} tool which applys a large set of
  \emph{weakest precondition} rules on the program\footnote{This set of
  rules includes a rule which can handle annotated @{term whileLoop}
  terms, but will not attempt to process @{term whileLoop} terms without
  annotations.}. We finially discharge the remaining subgoals left from
  the \texttt{wp} tool using \texttt{auto}, and our proof is complete.

  In the next section, we will look at how we can use AutoCorres to
  verify a C program that reads and writes to the heap.

\<close>

(*<*)
end
end
(*>*)