(*  Title:      HOL/Proofs/Lambda/NormalForm.thy
    Author:     Stefan Berghofer, TU Muenchen, 2003
*)

section \<open>Inductive characterization of lambda terms in normal form\<close>

theory NormalForm
imports ListBeta
begin

subsection \<open>Terms in normal form\<close>

definition
  listall :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> bool" where
  "listall P xs \<equiv> (\<forall>i. i < length xs \<longrightarrow> P (xs ! i))"

declare listall_def [extraction_expand_def]

theorem listall_nil: "listall P []"
  by (simp add: listall_def)

theorem listall_nil_eq [simp]: "listall P [] = True"
  by (iprover intro: listall_nil)

theorem listall_cons: "P x \<Longrightarrow> listall P xs \<Longrightarrow> listall P (x # xs)"
  apply (simp add: listall_def)
  apply (rule allI impI)+
  apply (case_tac i)
  apply simp+
  done

theorem listall_cons_eq [simp]: "listall P (x # xs) = (P x \<and> listall P xs)"
  apply (rule iffI)
  prefer 2
  apply (erule conjE)
  apply (erule listall_cons)
  apply assumption
  apply (unfold listall_def)
  apply (rule conjI)
  apply (erule_tac x=0 in allE)
  apply simp
  apply simp
  apply (rule allI)
  apply (erule_tac x="Suc i" in allE)
  apply simp
  done

lemma listall_conj1: "listall (\<lambda>x. P x \<and> Q x) xs \<Longrightarrow> listall P xs"
  by (induct xs) simp_all

lemma listall_conj2: "listall (\<lambda>x. P x \<and> Q x) xs \<Longrightarrow> listall Q xs"
  by (induct xs) simp_all

lemma listall_app: "listall P (xs @ ys) = (listall P xs \<and> listall P ys)"
  apply (induct xs)
   apply (rule iffI, simp, simp)
  apply (rule iffI, simp, simp)
  done

lemma listall_snoc [simp]: "listall P (xs @ [x]) = (listall P xs \<and> P x)"
  apply (rule iffI)
  apply (simp add: listall_app)+
  done

lemma listall_cong [cong, extraction_expand]:
  "xs = ys \<Longrightarrow> listall P xs = listall P ys"
  \<comment> \<open>Currently needed for strange technical reasons\<close>
  by (unfold listall_def) simp

text \<open>
\<^term>\<open>listsp\<close> is equivalent to \<^term>\<open>listall\<close>, but cannot be
used for program extraction.
\<close>

lemma listall_listsp_eq: "listall P xs = listsp P xs"
  by (induct xs) (auto intro: listsp.intros)

inductive NF :: "dB \<Rightarrow> bool"
where
  App: "listall NF ts \<Longrightarrow> NF (Var x \<degree>\<degree> ts)"
| Abs: "NF t \<Longrightarrow> NF (Abs t)"
monos listall_def

lemma nat_eq_dec: "\<And>n::nat. m = n \<or> m \<noteq> n"
  apply (induct m)
  apply (case_tac n)
  apply (case_tac [3] n)
  apply (simp only: nat.simps, iprover?)+
  done

lemma nat_le_dec: "\<And>n::nat. m < n \<or> \<not> (m < n)"
  apply (induct m)
  apply (case_tac n)
    apply (case_tac [3] n)
  apply (simp del: simp_thms subst_all, iprover?)+
  done

lemma App_NF_D: assumes NF: "NF (Var n \<degree>\<degree> ts)"
  shows "listall NF ts" using NF
  by cases simp_all

subsection \<open>Properties of \<open>NF\<close>\<close>

lemma Var_NF: "NF (Var n)"
  apply (subgoal_tac "NF (Var n \<degree>\<degree> [])")
   apply simp
  apply (rule NF.App)
  apply simp
  done

lemma Abs_NF:
  assumes NF: "NF (Abs t \<degree>\<degree> ts)"
  shows "ts = []" using NF
proof cases
  case (App us i)
  thus ?thesis by (simp add: Var_apps_neq_Abs_apps [THEN not_sym])
next
  case (Abs u)
  thus ?thesis by simp
qed

lemma subst_terms_NF: "listall NF ts \<Longrightarrow>
    listall (\<lambda>t. \<forall>i j. NF (t[Var i/j])) ts \<Longrightarrow>
    listall NF (map (\<lambda>t. t[Var i/j]) ts)"
  by (induct ts) simp_all

lemma subst_Var_NF: "NF t \<Longrightarrow> NF (t[Var i/j])"
  apply (induct arbitrary: i j set: NF)
  apply simp
  apply (frule listall_conj1)
  apply (drule listall_conj2)
  apply (drule_tac i=i and j=j in subst_terms_NF)
  apply assumption
  apply (rule_tac m1=x and n1=j in nat_eq_dec [THEN disjE])
  apply simp
  apply (erule NF.App)
  apply (rule_tac m1=j and n1=x in nat_le_dec [THEN disjE])
  apply simp
  apply (iprover intro: NF.App)
  apply simp
  apply (iprover intro: NF.App)
  apply simp
  apply (iprover intro: NF.Abs)
  done

lemma app_Var_NF: "NF t \<Longrightarrow> \<exists>t'. t \<degree> Var i \<rightarrow>\<^sub>\<beta>\<^sup>* t' \<and> NF t'"
  apply (induct set: NF)
  apply (simplesubst app_last)  \<comment> \<open>Using \<open>subst\<close> makes extraction fail\<close>
  apply (rule exI)
  apply (rule conjI)
  apply (rule rtranclp.rtrancl_refl)
  apply (rule NF.App)
  apply (drule listall_conj1)
  apply (simp add: listall_app)
  apply (rule Var_NF)
  apply (rule exI)
  apply (rule conjI)
  apply (rule rtranclp.rtrancl_into_rtrancl)
  apply (rule rtranclp.rtrancl_refl)
  apply (rule beta)
  apply (erule subst_Var_NF)
  done

lemma lift_terms_NF: "listall NF ts \<Longrightarrow>
    listall (\<lambda>t. \<forall>i. NF (lift t i)) ts \<Longrightarrow>
    listall NF (map (\<lambda>t. lift t i) ts)"
  by (induct ts) simp_all

lemma lift_NF: "NF t \<Longrightarrow> NF (lift t i)"
  apply (induct arbitrary: i set: NF)
  apply (frule listall_conj1)
  apply (drule listall_conj2)
  apply (drule_tac i=i in lift_terms_NF)
  apply assumption
  apply (rule_tac m1=x and n1=i in nat_le_dec [THEN disjE])
  apply simp
  apply (rule NF.App)
  apply assumption
  apply simp
  apply (rule NF.App)
  apply assumption
  apply simp
  apply (rule NF.Abs)
  apply simp
  done

text \<open>
\<^term>\<open>NF\<close> characterizes exactly the terms that are in normal form.
\<close>

lemma NF_eq: "NF t = (\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t')"
proof
  assume "NF t"
  then have "\<And>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  proof induct
    case (App ts t)
    show ?case
    proof
      assume "Var t \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> t'"
      then obtain rs where "ts => rs"
        by (iprover dest: head_Var_reduction)
      with App show False
        by (induct rs arbitrary: ts) auto
    qed
  next
    case (Abs t)
    show ?case
    proof
      assume "Abs t \<rightarrow>\<^sub>\<beta> t'"
      then show False using Abs by cases simp_all
    qed
  qed
  then show "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'" ..
next
  assume H: "\<forall>t'. \<not> t \<rightarrow>\<^sub>\<beta> t'"
  then show "NF t"
  proof (induct t rule: Apps_dB_induct)
    case (1 n ts)
    then have "\<forall>ts'. \<not> ts => ts'"
      by (iprover intro: apps_preserves_betas)
    with 1(1) have "listall NF ts"
      by (induct ts) auto
    then show ?case by (rule NF.App)
  next
    case (2 u ts)
    show ?case
    proof (cases ts)
      case Nil
      from 2 have "\<forall>u'. \<not> u \<rightarrow>\<^sub>\<beta> u'"
        by (auto intro: apps_preserves_beta)
      then have "NF u" by (rule 2)
      then have "NF (Abs u)" by (rule NF.Abs)
      with Nil show ?thesis by simp
    next
      case (Cons r rs)
      have "Abs u \<degree> r \<rightarrow>\<^sub>\<beta> u[r/0]" ..
      then have "Abs u \<degree> r \<degree>\<degree> rs \<rightarrow>\<^sub>\<beta> u[r/0] \<degree>\<degree> rs"
        by (rule apps_preserves_beta)
      with Cons have "Abs u \<degree>\<degree> ts \<rightarrow>\<^sub>\<beta> u[r/0] \<degree>\<degree> rs"
        by simp
      with 2 show ?thesis by iprover
    qed
  qed
qed

end


(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Two sorted Demonic Refinement Algebras\<close>

theory DRAT2
  imports Kleene_Algebra.DRA
begin

text \<open>
  As an alternative to the one-sorted implementation of demonic refinement algebra with tests,
  we provide a two-sorted, more conventional one.
  This alternative can be developed further along the lines of the one-sorted implementation.
\<close>

syntax "_dra" :: "'a \<Rightarrow> 'a" ("`_`")

ML \<open>
val dra_test_vars = ["p","q","r","s","t","p'","q'","r'","s'","t'","p''","q''","r''","s''","t''"]

fun map_ast_variables ast =
  case ast of
    (Ast.Variable v) =>
      if exists (fn tv => tv = v) dra_test_vars
      then Ast.Appl [Ast.Variable "test", Ast.Variable v]
      else Ast.Variable v
  | (Ast.Constant c) => Ast.Constant c
  | (Ast.Appl []) => Ast.Appl []
  | (Ast.Appl (f :: xs)) => Ast.Appl (f :: map map_ast_variables xs)

structure DRAHomRules = Named_Thms
  (val name = @{binding "kat_hom"}
   val description = "KAT test homomorphism rules")

fun dra_hom_tac ctxt n =
  let
    val rev_rules = map (fn thm => thm RS @{thm sym}) (DRAHomRules.get ctxt)
  in
    asm_full_simp_tac (put_simpset HOL_basic_ss ctxt addsimps rev_rules) n
  end
\<close>

setup \<open>DRAHomRules.setup\<close>

method_setup kat_hom = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD (CHANGED (dra_hom_tac ctxt 1)))
\<close>

parse_ast_translation \<open>
let
  fun dra_tr ctxt [t] = map_ast_variables t
in [(@{syntax_const "_dra"}, dra_tr)] end
\<close>

ML \<open>
structure VCGRules = Named_Thms
  (val name = @{binding "vcg"}
   val description = "verification condition generator rules")

fun vcg_tac ctxt n =
  let
    fun vcg' [] = no_tac
      | vcg' (r :: rs) = resolve_tac ctxt [r] n ORELSE vcg' rs;
  in REPEAT (CHANGED
       (dra_hom_tac ctxt n
        THEN REPEAT (vcg' (VCGRules.get ctxt))
        THEN dra_hom_tac ctxt n
        THEN TRY (resolve_tac ctxt @{thms order_refl} n ORELSE asm_full_simp_tac (put_simpset HOL_basic_ss ctxt) n)))
  end
\<close>

method_setup vcg = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD (CHANGED (vcg_tac ctxt 1)))
\<close>

setup \<open>VCGRules.setup\<close>

locale drat =
  fixes test :: "'a::boolean_algebra \<Rightarrow> 'b::dra"
  and not :: "'b::dra \<Rightarrow> 'b::dra" ("!")
  assumes test_sup [simp,kat_hom]: "test (sup p q) = `p + q`"
  and test_inf [simp,kat_hom]: "test (inf p q) = `p \<cdot> q`"
  and test_top [simp,kat_hom]: "test top = 1"
  and test_bot [simp,kat_hom]: "test bot = 0"
  and test_not [simp,kat_hom]: "test (- p) = `!p`"
  and test_iso_eq [kat_hom]: "p \<le> q \<longleftrightarrow> `p \<le> q`"

begin

notation test ("\<iota>")

lemma test_eq [kat_hom]: "p = q \<longleftrightarrow> `p = q`"
  by (metis eq_iff test_iso_eq)

ML_val \<open>map (fn thm => thm RS @{thm sym}) (DRAHomRules.get @{context})\<close>

lemma test_iso: "p \<le> q \<Longrightarrow> `p \<le> q`"
  by (simp add: test_iso_eq)

lemma test_meet_comm: "`p \<cdot> q = q \<cdot> p`"
  by kat_hom (fact inf_commute)

lemmas test_one_top[simp] = test_iso[OF top_greatest, simplified]

lemma test_star [simp]: "`p\<^sup>\<star> = 1`"
  by (metis star_subid test_iso test_top top_greatest)

lemmas [kat_hom] = test_star[symmetric]

lemma test_comp_add1 [simp]: "`!p + p = 1`"
  by kat_hom (metis compl_sup_top)

lemma test_comp_add2 [simp]: "`p + !p = 1`"
  by kat_hom (metis sup_compl_top)

lemma test_comp_mult1 [simp]: "`!p \<cdot> p = 0`"
  by (metis inf.commute inf_compl_bot test_bot test_inf test_not)

lemma test_comp_mult2 [simp]: "`p \<cdot> !p = 0`"
  by (metis inf_compl_bot test_bot test_inf test_not)

lemma test_eq1: "`y \<le> x` \<longleftrightarrow> `p\<cdot>y \<le> x` \<and> `!p\<cdot>y \<le> x`"
  apply standard
  apply (metis mult_isol_var mult_onel test_not test_one_top)
  apply (subgoal_tac "`(p + !p)\<cdot>y \<le> x`")
  apply (metis mult_onel sup_compl_top test_not test_sup test_top)
  by (metis distrib_right' join.sup.bounded_iff)

lemma "`p\<cdot>x = p\<cdot>x\<cdot>q` \<Longrightarrow> `p\<cdot>x\<cdot>!q = 0`"
  nitpick oops

lemma test1: "`p\<cdot>x\<cdot>!q = 0` \<Longrightarrow> `p\<cdot>x = p\<cdot>x\<cdot>q`"
  by (metis add_0_left distrib_left mult_oner test_comp_add1)

lemma test2: "`p\<cdot>q\<cdot>p = p\<cdot>q`"
  by (metis inf.commute inf.left_idem test_inf)

lemma test3: "`p\<cdot>q\<cdot>!p = 0`"
  by (metis inf.assoc inf.idem inf.left_commute inf_compl_bot test_bot test_inf test_not)

lemma test4: "`!p\<cdot>q\<cdot>p = 0`"
  by (metis double_compl test3 test_not)

lemma total_correctness: "`p\<cdot>x\<cdot>!q = 0` \<longleftrightarrow> `x\<cdot>!q \<le> !p\<cdot>\<top>`"
  apply standard
  apply (metis join.bot.extremum mult.assoc test_eq1 top_elim)
  by (metis (no_types, hide_lams) add_zeror annil less_eq_def mult.assoc mult_isol test_comp_mult2)

lemma test_iteration_annir: "`!p\<cdot>(p\<cdot>x)\<^sup>\<infinity> = !p`"
  by (metis annil iteration_idep mult.assoc test_comp_mult1)

end

end


theory ND_Compl_Truthtable
imports ND_Sound
begin

text\<open>This proof is inspired by Huth and Ryan~\<^cite>\<open>"huth2004logic"\<close>.\<close>

definition "turn_true \ F \<equiv> if \ \<Turnstile> F then F else (Not F)"
lemma lemma0[simp,intro!]: "\ \<Turnstile> turn_true \ F" unfolding turn_true_def by simp

lemma turn_true_simps[simp]:
  "\ \<Turnstile> F \<Longrightarrow> turn_true \ F = F"
  "\<not> \ \<Turnstile> F \<Longrightarrow> turn_true \ F = \<^bold>\<not> F"
unfolding turn_true_def by simp_all
(* often more sensible than to unfold everything *)

definition line_assm :: "'a valuation \<Rightarrow> 'a set \<Rightarrow> 'a formula set" where
"line_assm \ \<equiv> (`) (\<lambda>k. turn_true \ (Atom k))"
definition line_suitable :: "'a set \<Rightarrow> 'a formula \<Rightarrow> bool" where
"line_suitable Z F \<equiv> (atoms F \<subseteq> Z)"
lemma line_suitable_junctors[simp]:
  "line_suitable \ (Not F) = line_suitable \ F"
  "line_suitable \ (And F G) = (line_suitable \ F \<and> line_suitable \ G)"
  "line_suitable \ (Or F G) = (line_suitable \ F \<and> line_suitable \ G)"
  "line_suitable \ (Imp F G) = (line_suitable \ F \<and> line_suitable \ G)"
unfolding line_suitable_def by(clarsimp; linarith)+

lemma line_assm_Cons[simp]: "line_assm \ (k\<triangleright>ks) = (if \ k then Atom k else Not (Atom k)) \<triangleright> line_assm \ ks"
unfolding line_assm_def by simp

lemma NotD: "\<Gamma> \<turnstile> \<^bold>\<not> F \<Longrightarrow> F\<triangleright>\<Gamma> \<turnstile> \<bottom>" by (meson Not2I NotE Weaken subset_insertI)

lemma truthline_ND_proof:
  fixes F :: "'a formula"
  assumes "line_suitable Z F"
  shows "line_assm \ Z \<turnstile> turn_true \ F"
using assms proof(induction F)
  case (Atom k) thus ?case using Ax[where 'a='a] by (simp add: line_suitable_def line_assm_def)
next
  case Bot
  have "turn_true \ \<bottom> = Not Bot" unfolding turn_true_def by simp
  thus ?case by (simp add: Ax NotI) (* the theorems from ND/BigFormulas would be useful here. but\<dots> nah. *)
next
  have [simp]: "\<Gamma> \<turnstile> \<^bold>\<not> (\<^bold>\<not> F) \<longleftrightarrow> \<Gamma> \<turnstile> F" for F :: "'a formula" and \<Gamma> by (metis NDtrans Not2E Not2I)
  case (Not F)
  hence "line_assm \ Z \<turnstile> turn_true \ F" by simp
  thus ?case by(cases "\ \<Turnstile> F"; simp)
next
  have [simp]: "\<lbrakk>line_assm \ Z \<turnstile> \<^bold>\<not> F; \<not> \ \<Turnstile> F\<rbrakk> \<Longrightarrow> F \<^bold>\<and> G\<triangleright> line_assm \ Z \<turnstile> \<bottom>" for F G by(blast intro!: NotE[where F=F] intro: AndE1[OF Ax] Weaken[OF _ subset_insertI])
  have [simp]: "\<lbrakk>line_assm \ Z \<turnstile> \<^bold>\<not> G; \<not> \ \<Turnstile> G\<rbrakk> \<Longrightarrow> F \<^bold>\<and> G\<triangleright> line_assm \ Z \<turnstile> \<bottom>" for F G by(blast intro!: NotE[where F=G] intro: AndE2[OF Ax] Weaken[OF _ subset_insertI])
    (* (meson AndL_sim Not2I NotE Weaken subset_insertI) *)
  case (And F G)
  thus ?case by(cases "\ \<Turnstile> F"; cases "\ \<Turnstile> G"; simp; intro ND.NotI AndI; simp)
next
  case (Or F G)
  thus ?case by(cases "\ \<Turnstile> F"; cases "\ \<Turnstile> G"; simp; (elim ND.OrI1 ND.OrI2)?) (force intro!: NotI dest!: NotD dest: OrL_sim)
next
  case (Imp F G)
  hence mIH: "line_assm \ Z \<turnstile> turn_true \ F" "line_assm \ Z \<turnstile> turn_true \ G" by simp+
  thus ?case by(cases "\ \<Turnstile> F"; cases "\ \<Turnstile> G"; simp; intro ImpI NotI ImpL_sim; simp add: Weaken[OF _ subset_insertI] NotSwap NotD NotD[THEN BotE])
qed
thm NotD[THEN BotE]

lemma deconstruct_assm_set:
  assumes IH: "\<And>\. line_assm \ (k\<triangleright>Z) \<turnstile> F"
  shows "\<And>\. line_assm \ Z \<turnstile> F"
proof cases
  assume "k \<in> Z" with IH show "?thesis \" for \ by (simp add: insert_absorb)
next
  assume "k \<notin> Z"
  fix \
  text\<open>Since we require the IH for arbitrary @{term \}, we use a modified @{term \} from the conclusion like this:\<close>
  from IH have av: "line_assm (\(k := v)) (k\<triangleright>Z) \<turnstile> F" for v by blast
  text\<open>However, that modification is only relevant for @{term "k\<triangleright>Z"}, nothing from @{term Z} gets touched.\<close>
  from \<open>k \<notin> Z\<close> have "line_assm (\(k := v)) Z = line_assm \ Z" for v unfolding line_assm_def turn_true_def by force
  text\<open>That means we can rewrite the modified @{const line_assm} like this:\<close>
  hence "line_assm (\(k := v)) (k\<triangleright>Z) =
      (if v then Atom k else Not (Atom k)) \<triangleright> line_assm \ Z" for v by simp
  text\<open>Inserting @{const True} and @{const False} for \<open>v\<close> yields the two alternatives.\<close>
  with av have "Atom k \<triangleright> line_assm \ Z \<turnstile> F" "Not (Atom k) \<triangleright> line_assm \ Z \<turnstile> F"
    by(metis (full_types))+
  with ND_caseDistinction show "line_assm \ Z \<turnstile> F" .
qed

theorem ND_complete:
  assumes taut: "\<Turnstile> F"
  shows "{} \<turnstile> F"
proof -
  have [simp]: "turn_true Z F = F" for Z using taut by simp
  (* \<up> too fast for you? read \<down> *)
  have "line_assm \ {} \<turnstile> F" for \
  proof(induction arbitrary: \ rule: finite_empty_induct)
    show fat: "finite (atoms F)" by (fact atoms_finite)
  next
    have su: "line_suitable (atoms F) F" unfolding line_suitable_def by simp
    with truthline_ND_proof[OF su] show base: "line_assm \ (atoms F) \<turnstile> F" for \ by simp
  next
    case (3 k Z)
    from \<open>k \<in> Z\<close> have *: \<open>k \<triangleright> Z - {k} = Z\<close> by blast
    from \<open>\<And>\. line_assm \ Z \<turnstile> F\<close>
    show \<open>line_assm \ (Z - {k}) \<turnstile> F\<close>
      using deconstruct_assm_set[of k "Z - {k}" F \]
      unfolding * by argo
  qed
  (* could have done that more efficiently\<dots>
  have "line_assm \ {} \<turnstile> F" for \
    using deconstruct_assm_set[OF spec[where P="\<lambda>\. line_assm \ (_ \<triangleright> _) \<turnstile> F"]]
    using finite_empty_induct[OF fat, where P="\<lambda>Z. \<forall>\. line_assm \ Z \<turnstile> F",
        OF base[THEN allI[where P="\<lambda>\. line_assm \ (atoms F) \<turnstile> F"]]]
    by (metis (full_types) insert_Diff_single insert_absorb)*)
  thus ?thesis unfolding line_assm_def by simp
qed

corollary ND_sound_complete: "{} \<turnstile> F \<longleftrightarrow> \<Turnstile> F"
  using ND_sound[of "{}" F] ND_complete[of F] unfolding entailment_def by blast

end


theory Extra
  imports HandDryer VCTheoryLemmas Requirements
begin

theorem extra2: "VC2 extraInv s0 hands_value"
  apply(simp only: VC2_def extraInv_def dryer_def
waiting_def drying_def)
  by auto

theorem extra3: "VC3 extraInv s0 hands_value"
  apply(simp only: VC3_def extraInv_def dryer_def
waiting_def drying_def)
  by auto

theorem extra5: "VC5 extraInv s0 hands_value"
  apply(simp only: VC5_def extraInv_def dryer_def
waiting_def drying_def)
  apply(auto)
proof -
  assume 1: " toEnvP s0"
   " \<forall>s1. toEnvP s1 \<and> substate s1 s0 \<longrightarrow>
         getPstate s1 Ctrl =
         Suc (Suc (Suc (Suc 0))) \<or>
         getPstate s1 Ctrl =
         Suc (Suc (Suc (Suc (Suc 0))))"
    "env (setVarAny s0 ON) ON "
   " getPstate s0 Ctrl =
    Suc (Suc (Suc (Suc (Suc 0)))) "
   " hands_value "
   " 0 < ltimeEnv s0 Ctrl "
   " ltimeEnv s0 Ctrl \<le> 10 "
  "\<forall>s1. toEnvP s1 \<and>
         substate s1 s0 \<and>
         Suc (toEnvNum s1 s0) = ltimeEnv s0 Ctrl \<longrightarrow>
         getVarBool s1 (Suc 0) \<and>
         getVarBool s1 (Suc (Suc 0)) "
   " \<forall>s1. toEnvP s1 \<and>
         substate s1 s0 \<and>
         Suc (toEnvNum s1 s0) < ltimeEnv s0 Ctrl \<longrightarrow>
         \<not> getVarBool s1 (Suc 0) \<and>
         getVarBool s1 (Suc (Suc 0))"
  with toEnvNum_id  have "Suc (toEnvNum s0 s0) = ltimeEnv s0 Ctrl \<or>
Suc (toEnvNum s0 s0) <ltimeEnv s0 Ctrl" by auto
  with 1 substate_refl
  show "getVarBool s0 (Suc (Suc 0))" by auto
qed

theorem extra6: "VC6 extraInv s0 hands_value"
  apply(simp only: VC6_def extraInv_def dryer_def
waiting_def drying_def)
  by auto

theorem extra7: "VC7 extraInv s0 hands_value"
  apply(simp only: VC7_def extraInv_def dryer_def
waiting_def drying_def)
  apply(auto)
proof -
  assume 1: "toEnvP s0 "
    "\<forall>s1. toEnvP s1 \<and> substate s1 s0 \<longrightarrow>
         getPstate s1 Ctrl =
         Suc (Suc (Suc (Suc 0))) \<or>
         getPstate s1 Ctrl =
         Suc (Suc (Suc (Suc (Suc 0)))) "
   " env (setVarAny s0 OFF) OFF "
    "getPstate s0 Ctrl =
    Suc (Suc (Suc (Suc (Suc 0)))) "
    "\<not> hands_value "
   " ltimeEnv s0 Ctrl \<noteq> 10 "
    "0 < ltimeEnv s0 Ctrl "
   " ltimeEnv s0 Ctrl \<le> 10 "
   " \<forall>s1. toEnvP s1 \<and>
         substate s1 s0 \<and>
         Suc (toEnvNum s1 s0) = ltimeEnv s0 Ctrl \<longrightarrow>
         getVarBool s1 (Suc 0) \<and>
         getVarBool s1 (Suc (Suc 0)) "
    "\<forall>s1. toEnvP s1 \<and>
         substate s1 s0 \<and>
         Suc (toEnvNum s1 s0) < ltimeEnv s0 Ctrl \<longrightarrow>
         \<not> getVarBool s1 (Suc 0) \<and>
         getVarBool s1 (Suc (Suc 0))"
with toEnvNum_id  have "Suc (toEnvNum s0 s0) = ltimeEnv s0 Ctrl \<or>
Suc (toEnvNum s0 s0) <ltimeEnv s0 Ctrl" by auto
  with 1 substate_refl
  show "getVarBool s0 (Suc (Suc 0))" by auto
qed

end


section \<open>Undirected Kruskal on Directed Graphs\<close>

theory Graph_Definition_Impl
imports
 Kruskal_Impl Kruskal.Graph_Definition_Aux
begin

context weight begin subclass ordered_comm_monoid_add.. end
\<comment> \<open>could replace @{class ordered_ab_semigroup_add} and @{class comm_monoid_add} in @{class weight}'s def\<close>
thm class.weight_def thm class.ordered_comm_monoid_add_def

context finite_weighted_graph
begin

  abbreviation "ind E' \<equiv> \<lparr>nodes=V, edges=E'\<rparr>"
  abbreviation "subforest E' \<equiv> forest (ind E') \<and> subgraph (ind E')  (ind E)"

  lemma ind_valid_graph: "\<And>E'. E' \<subseteq> E \<Longrightarrow> valid_graph (ind E')"
    by (simp add: subgraph_def valid_subgraph)

  lemma vE: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp

  lemma ind_valid_graph': "\<And>E'. subgraph (ind E') (ind E) \<Longrightarrow> valid_graph (ind E')"
    apply(rule ind_valid_graph) by(auto simp: subgraph_def)

  lemma add_edge_ind: "(a,w,b)\<in>E \<Longrightarrow> add_edge a w b (ind F) = ind (insert (a,w,b) F)"
    by (simp add: E_validD insert_absorb)

  lemma nodes_connected_ind_sym: "F\<subseteq>E \<Longrightarrow> sym {(x, y) |x y. nodes_connected (ind F) x y}"
    apply(frule ind_valid_graph)
      unfolding sym_def using valid_graph.nodes_connected_sym by fast
  lemma nodes_connected_ind_trans: "F\<subseteq>E \<Longrightarrow> trans {(x, y) |x y. nodes_connected (ind F) x y}"
    apply(frule ind_valid_graph)
     unfolding trans_def using valid_graph.is_path_undir_append by fast

  lemma part_equiv_nodes_connected_ind:
    "F\<subseteq>E \<Longrightarrow> part_equiv {(x, y) |x y. nodes_connected (ind F) x y}"
     apply(rule) using nodes_connected_ind_trans nodes_connected_ind_sym by auto

  sublocale s: Kruskal_interface E V
    "\<lambda>e. {fst e, snd (snd e)}" "\<lambda>u v (a,w,b). u=a \<and> v=b \<or> u=b \<and> v=a"
    "subforest"
    "\<lambda>E'. { (a,b) |a b. nodes_connected (ind E') a b}"
    "\<lambda>(u,w,v). w"
  proof (unfold_locales, goal_cases)
    show "finite E"
      by (simp add: finite_E)
  next
    fix E'
    assume "forest (ind E') \<and> subgraph (ind E')  \<lparr>nodes=V, edges=E\<rparr>"
    then show "E' \<subseteq> E" unfolding subgraph_def by auto
  next
    show "subforest {}" by (auto simp: subgraph_def forest_def valid_graph_def forest_axioms_def)
  next
    case (4 X Y)
    then have *: "subgraph (ind Y) (ind X)" "subgraph (ind Y) (ind E)"
      unfolding subgraph_def by auto
    with 4 show ?case using forest.subgraph_forest by auto
  next
    case (5 u v)
    show ?case
      apply auto
      subgoal for p  apply(cases p) by auto
      subgoal for p  apply(cases p) by auto
      subgoal apply(rule exI[where x="[]"]) by auto
      done
  next
    case (6 E1 E2 u v)
    have *: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp
    from 6 show ?case using valid_graph.augment_edge[of "ind E" "ind E1" "ind E2" u v, OF *]
      unfolding subgraph_def by simp
  next
    case (7 F e u v)
    then have f: "forest (ind F)" and s: "subgraph (ind F) (ind E)" by auto
    from 7 have uv: "u\<in>V" "v\<in>V" using E_valid by blast+
    obtain a w b where e: "e=(a,w,b)" apply(cases e) by auto
    from e 7(3) have abuv: "u=a \<and> v=b \<or> u=b \<and> v=a" by auto
    show ?case
    proof
      assume "forest (ind (insert e F)) \<and> subgraph (ind (insert e F)) (ind E) "
      then have "(\<forall>(a, w, b)\<in> insert e F.
                \<not>nodes_connected (delete_edge a w b (ind (insert e F))) a b)"
        unfolding forest_def forest_axioms_def by auto
      with e have i: "\<not> nodes_connected (delete_edge a w b (ind (insert e F))) a b" by auto
      have ii: "(delete_edge a w b (ind (insert e F))) = ind F"
        using 7(2) e by (auto simp: delete_edge_def)
      from i have "\<not> nodes_connected (ind F) a b" using ii by auto
      then show "(u, v) \<notin> {(a, b) |a b. nodes_connected (ind F) a b}"
        using 7(3)   valid_graph.nodes_connected_sym[OF ind_valid_graph'[OF s]] e by auto
    next
      from s 7(2) have sg: "subgraph (ind (insert e F)) (ind E)"
        unfolding subgraph_def by auto
      assume "(u, v) \<notin> {(a, b) |a b. nodes_connected (ind F) a b}"
      with abuv have "(a, b) \<notin> {(a, b) |a b. nodes_connected (ind F) a b}"
        using  valid_graph.nodes_connected_sym[OF ind_valid_graph'[OF s]]
        by auto
      then have nn: "~nodes_connected (ind F) a b" by auto
      have "forest (add_edge a w b (ind F))" apply(rule forest.forest_add_edge[OF f _ _ nn])
        using uv abuv by auto
      then have f': "forest (ind (insert e F))" using 7(2) add_edge_ind by (auto simp add: e)
      from f' sg show "forest (ind (insert e F)) \<and> subgraph (ind (insert e F)) (ind E) "
        by auto
    qed
  next
    case (8 F)
    then have s: "subgraph (ind F) (ind E)" unfolding subgraph_def by auto
    from valid_graph.connected_VV[OF vE s]
      show i: "{(x, y) |x y. nodes_connected (ind F) x y} \<subseteq> V\<times>V" by simp

    from valid_graph.connected_equiv[OF vE s]
      show "equiv V {(x, y) |x y. nodes_connected (ind F) x y}" by simp
  next
    case (10 x y F e)
    from 10 have xy: "x\<in>V" "y\<in>V" by force+
    obtain a w b where e: "e=(a,w,b)" apply(cases e) by auto

    from 10(4) have ad_eq: "add_edge a w b (ind F) = ind (insert e F)"
      using e unfolding add_edge_def by (simp add: E_validD insert_absorb)
    have *: "\<And>x y. nodes_connected (add_edge a w b (ind F)) x y
             = ((x, y) \<in> per_union {(x, y) |x y. nodes_connected (ind F) x y} a b)"
      apply(rule valid_graph.nodes_connected_insert_per_union[of "ind E"])
      subgoal apply(rule ind_valid_graph) by simp
      subgoal using 10(3) by(auto simp: subgraph_def)
      subgoal apply(rule part_equiv_nodes_connected_ind) by fact
      using xy e 10(5) by auto
    show ?case
      using 10(5) e * ad_eq by auto
  next
    case 11
    then show ?case by auto
  next
    case 12
    then show ?case by auto
  next
    case 13
    then show ?case by auto
  next
    case (14 a F e)
    then obtain w where "e=(a,w,a)" by auto
    with 14 have "a\<in>V" and p: "(a,w,a): edges (ind (insert e F))"
      by (auto simp: E_validD(2))
    then have *: "nodes_connected (delete_edge a w a (ind (insert e F))) a a"
      apply (intro exI[where x="[]"]) by simp
    have "\<exists>(a, w, b)\<in>edges (ind (insert e F)).
          nodes_connected (delete_edge a w b (ind (insert e F))) a b"
      apply (rule bexI[where x="(a,w,a)"])
      using * p by auto
    then
      have "\<not> forest (ind (insert e F))"
        unfolding forest_def forest_axioms_def by blast
    then show ?case by auto
  next
    case (15 e)
    then show ?case by auto
  next
    case 16
    thus ?case
      using E_valid by blast
  next
    case 17
    thus ?case
      by (simp add: finite_V)
  next
    case (18 a b)
    then show ?case apply auto
        subgoal for w apply(rule exI[where x="[(a, w, b)]"])
          using finite_weighted_graph.ind_valid_graph finite_weighted_graph_axioms valid_graph.is_path_undir_simps(2) by fastforce
        subgoal for w apply(rule exI[where x="[(a, w, b)]"]) apply simp
          using E_validD(1) by blast
        done
  qed

  subsection \<open>Showing the equivalence of minimum spanning forest definitions\<close>

  text \<open>As the definition of the minimum spanning forest from the minWeightBasis algorithm differs
    from the one of our graph formalization, we now show their equivalence.\<close>

  lemma spanning_forest_eq: "s.SpanningForest E' = spanning_forest (ind E') (ind E)"
  proof rule
    assume t: "s.SpanningForest E'"
    have f: "(forest (ind E'))" and sub: "subgraph (ind E') (ind E)" and
        n: "(\<forall>x\<in>E - E'.  \<not> (forest (ind (insert x E')) \<and> subgraph (ind (insert x E')) (ind E)))"
      using t[unfolded  s.SpanningForest_def ]  by auto

    have vE: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp

    have "\<And>x. x\<in>E-E' \<Longrightarrow> subgraph (ind (insert x E')) (ind E)"
      using sub unfolding subgraph_def by auto
    with n have "(\<forall>x\<in>E - E'.  \<not> (forest (ind (insert x E'))))" by blast
    then have n': "(\<forall>(a,w,b)\<in>edges (ind E) - edges (ind E').  \<not> forest (add_edge a w b (ind E')))"
      using valid_graph.E_validD[OF vE]  by(auto simp: add_edge_def insert_absorb)

    have mc: "maximally_connected (ind E') (ind E)"
      apply(rule valid_graph.forest_maximally_connected_incl_max1) by fact+

    show "spanning_forest (ind E') (ind E)"
      unfolding spanning_forest_def using f sub mc by blast
  next
    assume t: "spanning_forest (ind E') (ind E)"
    have  f: "(forest (ind E'))" and sub: "subgraph (ind E') (ind E)" and
        n: "maximally_connected (ind E') (ind E)" using t[unfolded spanning_forest_def] by auto

    have i: "\<And>x. x\<in>E-E' \<Longrightarrow> subgraph (ind (insert x E')) (ind E)"
      using sub unfolding subgraph_def by auto
    have vE: "valid_graph (ind E)" apply(rule ind_valid_graph) by simp

    have "\<forall>(a, w, b)\<in>edges (ind E) - edges (ind E'). \<not> forest (add_edge a w b (ind E'))"
      apply(rule valid_graph.forest_maximally_connected_incl_max2) by fact+
    then have t: "\<And>a w b. (a, w, b)\<in>edges (ind E) - edges (ind E')
                   \<Longrightarrow> \<not> forest (add_edge a w b (ind E'))"
      by blast

    have ii: "(\<forall>x\<in>E - E'.  \<not> (forest (ind (insert x E'))))"
      apply (auto simp: add_edge_def)
      subgoal for a w b using t[of a w b] valid_graph.E_validD[OF vE]
        by(auto simp: add_edge_def insert_absorb)
      done

    from i ii have
      iii: "(\<forall>x\<in>E - E'. \<not>(forest (ind (insert x E')) \<and> subgraph (ind (insert x E')) (ind E)))"
      by blast

    show "s.SpanningForest E'"
      unfolding s.SpanningForest_def using iii f sub by blast
  qed

  lemma (in -) edge_weight_alt: "edge_weight G = sum (\<lambda>(u,w,v). w) (edges G)"
  proof -
    have f: "fst o snd  = (\<lambda>(u,w,v). w) " by auto
    show ?thesis unfolding edge_weight_def f by auto
  qed

  lemma MSF_eq: "s.MSF E' = minimum_spanning_forest (ind E') (ind E)"
    unfolding s.MSF_def minimum_spanning_forest_def optimal_forest_def
    unfolding spanning_forest_eq edge_weight_alt
  proof safe
    fix F'
    assume "spanning_forest (ind E') (ind E)"
      and B: "(\<forall>B'. spanning_forest (ind B') (ind E)
             \<longrightarrow> (\<Sum>(u, w, v)\<in>E'. w) \<le> (\<Sum>(u, w, v)\<in>B'. w))"
      and sf: "spanning_forest F' (ind E)"
    from sf have "subgraph F' (ind E)" by(auto simp: spanning_forest_def)
    then have "F' = ind (edges F')" unfolding subgraph_def by auto
    with B sf show "(\<Sum>(u, w, v)\<in>edges (ind E'). w) \<le> (\<Sum>(u, w, v)\<in>edges F'. w)" by auto
  qed auto

end

subsection \<open>Interpreting @{locale Kruskal_Impl}\<close>

locale fromlist = fixes
  L :: "(nat \<times> int \<times> nat) list"
begin

sublocale finite_weighted_graph "\<lparr>nodes=fst ` set L \<union> (snd \<circ> snd) ` set L, edges=set L\<rparr>"
  apply standard by simp_all blast

lemma max_node_is_Max_V: " E =  set la \<Longrightarrow> max_node la = Max (insert 0 V)"
  by (auto simp: max_node_def)

sublocale s: Kruskal_Impl E V
   "\<lambda>e. {fst e, snd (snd e)}" "\<lambda>u v (a,w,b). u=a \<and> v=b \<or> u=b \<and> v=a"
   "subforest"
   "\<lambda>E'. { (a,b) |a b. nodes_connected (ind E') a b}"
   "\<lambda>(u,w,v). w" id  "PR_CONST (\<lambda>(u,w,v). RETURN (u,v))"
   "PR_CONST (RETURN L)" "return L" "set L" "(\<lambda>(u,w,v). return (u,v))"
proof (standard, goal_cases)
  case 1
  thus ?case by (auto split: prod.split )
next
  case 2
  thus ?case by auto
next
  case 3
  thus ?case apply sepref_to_hoare apply sep_auto by(auto simp: pure_fold list_assn_emp)
next
  case (4 l)
  then show ?case using max_node_is_Max_V by auto
next
  case 5
  then show ?case apply sepref_to_hoare by sep_auto
qed

  lemma kruskal_correct:
    "<emp> kruskal (return L) (\<lambda>(u,w,v). return (u,v)) ()
      <\<lambda>F. \<up> (distinct F \<and> set F \<subseteq> E \<and> minimum_spanning_forest (ind (set F)) (ind E))>\<^sub>t"
    using s.kruskal_correct_forest unfolding MSF_eq by auto

  definition (in -) "kruskal_algo L = kruskal (return L) (\<lambda>(u,w,v). return (u,v)) ()"

end

subsection \<open>Outside the locale\<close>

definition "GD_from_list_\<alpha>_weight L e = (case e of (u,w,v) \<Rightarrow> w)"
abbreviation "GD_from_list_\<alpha>_graph G L \<equiv> \<lparr>nodes=fst ` (set G) \<union> (snd \<circ> snd) ` (set G), edges=set L\<rparr>"

lemma corr: "
  <emp> kruskal_algo L
     <\<lambda>F. \<up> (set F \<subseteq> set L \<and>
       minimum_spanning_forest (GD_from_list_\<alpha>_graph L F) (GD_from_list_\<alpha>_graph L L))>\<^sub>t"
  by(sep_auto heap: fromlist.kruskal_correct simp:  kruskal_algo_def  )

lemma kruskal_correct: "<emp> kruskal_algo L
     <\<lambda>F. \<up> (set F \<subseteq> set L \<and>
       spanning_forest (GD_from_list_\<alpha>_graph L F) (GD_from_list_\<alpha>_graph L L)
      \<and> (\<forall>F'. spanning_forest (GD_from_list_\<alpha>_graph L F') (GD_from_list_\<alpha>_graph L L)
               \<longrightarrow>  sum (\<lambda>(u,w,v). w) (set F) \<le> sum (\<lambda>(u,w,v). w) (set F')))>\<^sub>t"
proof -
  interpret fromlist L by unfold_locales
  have *: "\<And>F'. edge_weight (ind F') = sum (\<lambda>(u,w,v). w) F'"
    unfolding edge_weight_def apply auto by (metis fn_snd_conv fst_def)
  show ?thesis using *
    by (sep_auto heap: corr simp: edge_weight_alt minimum_spanning_forest_def optimal_forest_def)
qed

subsection \<open>Code export\<close>

export_code kruskal_algo checking SML_imp

ML_val \<open>
  val export_nat = @{code integer_of_nat}
  val import_nat = @{code nat_of_integer}
  val export_int = @{code integer_of_int}
  val import_int = @{code int_of_integer}
  val import_list = map (fn (a,b,c) => (import_nat a, (import_int b, import_nat c)))
  val export_list = map (fn (a,(b,c)) => (export_nat a, export_int b, export_nat c))
  val export_Some_list = (fn SOME l => SOME (export_list l) | NONE => NONE)

  fun kruskal l = @{code kruskal} (fn () => import_list l) (fn (a,(_,c)) => fn () => (a,c)) () ()
                     |> export_list
  fun kruskal_algo l = @{code kruskal_algo} (import_list l) ()  |> export_list

  val result = kruskal [(1,~9,2),(2,~3,3),(3,~4,1)]
  val result4 = kruskal [(1,~100,4), (3,64,5), (1,13,2), (3,20,2), (2,5,5), (4,80,3), (4,40,5)]

  val result' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1)]
  val result1' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1),(1,5,3)]
  val result2' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1),(1,~4,3)]
  val result3' = kruskal_algo [(1,~9,2),(2,~3,3),(3,~4,1),(1,~4,1)]
  val result4' = kruskal_algo [(1,~100,4), (3,64,5), (1,13,2), (3,20,2),
                               (2,5,5), (4,80,3), (4,40,5)]
\<close>

end


(*<*)
theory Example_Verification
imports "../Examples/Gcd/Greatest_Common_Divisor" Simple_Greatest_Common_Divisor
begin
(*>*)

chapter \<open>Verifying an Example Program\<close>

text \<open>
\label{sec:example-verification}
\begin{figure}
\lstinputlisting{Gcd.ads}
\lstinputlisting{Gcd.adb}
\caption{\SPARK{} program for computing the greatest common divisor}
\label{fig:gcd-prog}
\end{figure}

\begin{figure}
\input{Greatest_Common_Divisor}
\caption{Correctness proof for the greatest common divisor program}
\label{fig:gcd-proof}
\end{figure}
We will now explain the usage of the \SPARK{} verification environment by proving
the correctness of an example program. As an example, we use a program for computing
the \emph{greatest common divisor} of two natural numbers shown in \figref{fig:gcd-prog},
which has been taken from the book about \SPARK{} by Barnes @{cite \<open>\S 11.6\<close> Barnes}.
\<close>

section \<open>Importing \SPARK{} VCs into Isabelle\<close>

text \<open>
In order to specify that the \SPARK{} procedure \texttt{G\_C\_D} behaves like its
mathematical counterpart, Barnes introduces a \emph{proof function} \texttt{Gcd}
in the package specification. Invoking the \SPARK{} Examiner and Simplifier on
this program yields a file \texttt{g\_c\_d.siv} containing the simplified VCs,
as well as files \texttt{g\_c\_d.fdl} and \texttt{g\_c\_d.rls}, containing FDL
declarations and rules, respectively. The files generated by \SPARK{} are assumed to reside in the
subdirectory \texttt{greatest\_common\_divisor}. For \texttt{G\_C\_D} the
Examiner generates ten VCs, eight of which are proved automatically by
the Simplifier. We now show how to prove the remaining two VCs
interactively using HOL-\SPARK{}. For this purpose, we create a \emph{theory}
\texttt{Greatest\_Common\_Divisor}, which is shown in \figref{fig:gcd-proof}.
A theory file always starts with the keyword \isa{\isacommand{theory}} followed
by the name of the theory, which must be the same as the file name. The theory
name is followed by the keyword \isa{\isacommand{imports}} and a list of theories
imported by the current theory. All theories using the HOL-\SPARK{} verification
environment must import the theory \texttt{SPARK}. In addition, we also include
the \texttt{GCD} theory. The list of imported theories is followed by the
\isa{\isacommand{begin}} keyword. In order to interactively process the theory
shown in \figref{fig:gcd-proof}, we start Isabelle with the command
\begin{verbatim}
  isabelle emacs -l HOL-SPARK Greatest_Common_Divisor.thy
\end{verbatim}
The option ``\texttt{-l HOL-SPARK}'' instructs Isabelle to load the right
object logic image containing the verification environment. Each proof function
occurring in the specification of a \SPARK{} program must be linked with a
corresponding Isabelle function. This is accomplished by the command
\isa{\isacommand{spark\_proof\_functions}}, which expects a list of equations
of the form \emph{name}\texttt{\ =\ }\emph{term}, where \emph{name} is the
name of the proof function and \emph{term} is the corresponding Isabelle term.
In the case of \texttt{gcd}, both the \SPARK{} proof function and its Isabelle
counterpart happen to have the same name. Isabelle checks that the type of the
term linked with a proof function agrees with the type of the function declared
in the \texttt{*.fdl} file.
It is worth noting that the
\isa{\isacommand{spark\_proof\_functions}} command can be invoked both outside,
i.e.\ before \isa{\isacommand{spark\_open}}, and inside the environment, i.e.\ after
\isa{\isacommand{spark\_open}}, but before any \isa{\isacommand{spark\_vc}} command. The
former variant is useful when having to declare proof functions that are shared by several
procedures, whereas the latter has the advantage that the type of the proof function
can be checked immediately, since the VCs, and hence also the declarations of proof
functions in the \texttt{*.fdl} file have already been loaded.
\begin{figure}
\begin{flushleft}
\tt
Context: \\
\ \\
\begin{tabular}{ll}
fixes & \<open>m ::\<close>\ "\<open>int\<close>" \\
and   & \<open>n ::\<close>\ "\<open>int\<close>" \\
and   & \<open>c ::\<close>\ "\<open>int\<close>" \\
and   & \<open>d ::\<close>\ "\<open>int\<close>" \\
assumes & \<open>g_c_d_rules1:\<close>\ "\<open>0 \<le> integer__size\<close>" \\
and     & \<open>g_c_d_rules6:\<close>\ "\<open>0 \<le> natural__size\<close>" \\
\multicolumn{2}{l}{notes definition} \\
\multicolumn{2}{l}{\hspace{2ex}\<open>defns =\<close>\ `\<open>integer__first = - 2147483648\<close>`} \\
\multicolumn{2}{l}{\hspace{4ex}`\<open>integer__last = 2147483647\<close>`} \\
\multicolumn{2}{l}{\hspace{4ex}\dots}
\end{tabular}\ \\[1.5ex]
\ \\
Definitions: \\
\ \\
\begin{tabular}{ll}
\<open>g_c_d_rules2:\<close> & \<open>integer__first = - 2147483648\<close> \\
\<open>g_c_d_rules3:\<close> & \<open>integer__last = 2147483647\<close> \\
\dots
\end{tabular}\ \\[1.5ex]
\ \\
Verification conditions: \\
\ \\
path(s) from assertion of line 10 to assertion of line 10 \\
\ \\
\<open>procedure_g_c_d_4\<close>\ (unproved) \\
\ \ \begin{tabular}{ll}
assumes & \<open>H1:\<close>\ "\<open>0 \<le> c\<close>" \\
and     & \<open>H2:\<close>\ "\<open>0 < d\<close>" \\
and     & \<open>H3:\<close>\ "\<open>gcd c d = gcd m n\<close>" \\
\dots \\
shows & "\<open>0 < c - c sdiv d * d\<close>" \\
and   & "\<open>gcd d (c - c sdiv d * d) = gcd m n\<close>
\end{tabular}\ \\[1.5ex]
\ \\
path(s) from assertion of line 10 to finish \\
\ \\
\<open>procedure_g_c_d_11\<close>\ (unproved) \\
\ \ \begin{tabular}{ll}
assumes & \<open>H1:\<close>\ "\<open>0 \<le> c\<close>" \\
and     & \<open>H2:\<close>\ "\<open>0 < d\<close>" \\
and     & \<open>H3:\<close>\ "\<open>gcd c d = gcd m n\<close>" \\
\dots \\
shows & "\<open>d = gcd m n\<close>"
\end{tabular}
\end{flushleft}
\caption{Output of \isa{\isacommand{spark\_status}} for \texttt{g\_c\_d.siv}}
\label{fig:gcd-status}
\end{figure}
We now instruct Isabelle to open
a new verification environment and load a set of VCs. This is done using the
command \isa{\isacommand{spark\_open}}, which must be given the name of a
\texttt{*.siv} file as an argument. Behind the scenes, Isabelle
parses this file and the corresponding \texttt{*.fdl} and \texttt{*.rls} files,
and converts the VCs to Isabelle terms. Using the command \isa{\isacommand{spark\_status}},
the user can display the current VCs together with their status (proved, unproved).
The variants \isa{\isacommand{spark\_status}\ (proved)}
and \isa{\isacommand{spark\_status}\ (unproved)} show only proved and unproved
VCs, respectively. For \texttt{g\_c\_d.siv}, the output of
\isa{\isacommand{spark\_status}} is shown in \figref{fig:gcd-status}.
To minimize the number of assumptions, and hence the size of the VCs,
FDL rules of the form ``\dots\ \texttt{may\_be\_replaced\_by}\ \dots'' are
turned into native Isabelle definitions, whereas other rules are modelled
as assumptions.
\<close>

section \<open>Proving the VCs\<close>

text \<open>
\label{sec:proving-vcs}
The two open VCs are \<open>procedure_g_c_d_4\<close> and \<open>procedure_g_c_d_11\<close>,
both of which contain the \<open>gcd\<close> proof function that the \SPARK{} Simplifier
does not know anything about. The proof of a particular VC can be started with
the \isa{\isacommand{spark\_vc}} command, which is similar to the standard
\isa{\isacommand{lemma}} and \isa{\isacommand{theorem}} commands, with the
difference that it only takes a name of a VC but no formula as an argument.
A VC can have several conclusions that can be referenced by the identifiers
\<open>?C1\<close>, \<open>?C2\<close>, etc. If there is just one conclusion, it can
also be referenced by \<open>?thesis\<close>. It is important to note that the
\texttt{div} operator of FDL behaves differently from the \<open>div\<close> operator
of Isabelle/HOL on negative numbers. The former always truncates towards zero,
whereas the latter truncates towards minus infinity. This is why the FDL
\texttt{div} operator is mapped to the \<open>sdiv\<close> operator in Isabelle/HOL,
which is defined as
@{thm [display] sdiv_def}
For example, we have that
@{lemma "-5 sdiv 4 = -1" by (simp add: sdiv_neg_pos)}, but
@{lemma "(-5::int) div 4 = -2" by simp}.
For non-negative dividend and divisor, \<open>sdiv\<close> is equivalent to \<open>div\<close>,
as witnessed by theorem \<open>sdiv_pos_pos\<close>:
@{thm [display,mode=no_brackets] sdiv_pos_pos}
In contrast, the behaviour of the FDL \texttt{mod} operator is equivalent to
the one of Isabelle/HOL. Moreover, since FDL has no counterpart of the \SPARK{}
operator \textbf{rem}, the \SPARK{} expression \texttt{c}\ \textbf{rem}\ \texttt{d}
just becomes \<open>c - c sdiv d * d\<close> in Isabelle. The first conclusion of
\<open>procedure_g_c_d_4\<close> requires us to prove that the remainder of \<open>c\<close>
and \<open>d\<close> is greater than \<open>0\<close>. To do this, we use the theorem
\<open>minus_div_mult_eq_mod [symmetric]\<close> describing the correspondence between \<open>div\<close>
and \<open>mod\<close>
@{thm [display] minus_div_mult_eq_mod [symmetric]}
together with the theorem \<open>pos_mod_sign\<close> saying that the result of the
\<open>mod\<close> operator is non-negative when applied to a non-negative divisor:
@{thm [display] pos_mod_sign}
We will also need the aforementioned theorem \<open>sdiv_pos_pos\<close> in order for
the standard Isabelle/HOL theorems about \<open>div\<close> to be applicable
to the VC, which is formulated using \<open>sdiv\<close> rather that \<open>div\<close>.
Note that the proof uses \texttt{`\<open>0 \<le> c\<close>`} and \texttt{`\<open>0 < d\<close>`}
rather than \<open>H1\<close> and \<open>H2\<close> to refer to the hypotheses of the current
VC. While the latter variant seems more compact, it is not particularly robust,
since the numbering of hypotheses can easily change if the corresponding
program is modified, making the proof script hard to adjust when there are many hypotheses.
Moreover, proof scripts using abbreviations like \<open>H1\<close> and \<open>H2\<close>
are hard to read without assistance from Isabelle.
The second conclusion of \<open>procedure_g_c_d_4\<close> requires us to prove that
the \<open>gcd\<close> of \<open>d\<close> and the remainder of \<open>c\<close> and \<open>d\<close>
is equal to the \<open>gcd\<close> of the original input values \<open>m\<close> and \<open>n\<close>,
which is the actual \emph{invariant} of the procedure. This is a consequence
of theorem \<open>gcd_non_0_int\<close>
@{thm [display] gcd_non_0_int}
Again, we also need theorems \<open>minus_div_mult_eq_mod [symmetric]\<close> and \<open>sdiv_pos_pos\<close>
to justify that \SPARK{}'s \textbf{rem} operator is equivalent to Isabelle's
\<open>mod\<close> operator for non-negative operands.
The VC \<open>procedure_g_c_d_11\<close> says that if the loop invariant holds before
the last iteration of the loop, the postcondition of the procedure will hold
after execution of the loop body. To prove this, we observe that the remainder
of \<open>c\<close> and \<open>d\<close>, and hence \<open>c mod d\<close> is \<open>0\<close> when exiting
the loop. This implies that \<open>gcd c d = d\<close>, since \<open>c\<close> is divisible
by \<open>d\<close>, so the conclusion follows using the assumption \<open>gcd c d = gcd m n\<close>.
This concludes the proofs of the open VCs, and hence the \SPARK{} verification
environment can be closed using the command \isa{\isacommand{spark\_end}}.
This command checks that all VCs have been proved and issues an error message
if there are remaining unproved VCs. Moreover, Isabelle checks that there is
no open \SPARK{} verification environment when the final \isa{\isacommand{end}}
command of a theory is encountered.
\<close>

section \<open>Optimizing the proof\<close>

text \<open>
\begin{figure}
\lstinputlisting{Simple_Gcd.adb}
\input{Simple_Greatest_Common_Divisor}
\caption{Simplified greatest common divisor program and proof}
\label{fig:simple-gcd-proof}
\end{figure}
When looking at the program from \figref{fig:gcd-prog} once again, several
optimizations come to mind. First of all, like the input parameters of the
procedure, the local variables \texttt{C}, \texttt{D}, and \texttt{R} can
be declared as \texttt{Natural} rather than \texttt{Integer}. Since natural
numbers are non-negative by construction, the values computed by the algorithm
are trivially proved to be non-negative. Since we are working with non-negative
numbers, we can also just use \SPARK{}'s \textbf{mod} operator instead of
\textbf{rem}, which spares us an application of theorems \<open>minus_div_mult_eq_mod [symmetric]\<close>
and \<open>sdiv_pos_pos\<close>. Finally, as noted by Barnes @{cite \<open>\S 11.5\<close> Barnes},
we can simplify matters by placing the \textbf{assert} statement between
\textbf{while} and \textbf{loop} rather than directly after the \textbf{loop}.
In the former case, the loop invariant has to be proved only once, whereas in
the latter case, it has to be proved twice: since the \textbf{assert} occurs after
the check of the exit condition, the invariant has to be proved for the path
from the \textbf{assert} statement to the \textbf{assert} statement, and for
the path from the \textbf{assert} statement to the postcondition. In the case
of the \texttt{G\_C\_D} procedure, this might not seem particularly problematic,
since the proof of the invariant is very simple, but it can unnecessarily
complicate matters if the proof of the invariant is non-trivial. The simplified
program for computing the greatest common divisor, together with its correctness
proof, is shown in \figref{fig:simple-gcd-proof}. Since the package specification
has not changed, we only show the body of the packages. The two VCs can now be
proved by a single application of Isabelle's proof method \<open>simp\<close>.
\<close>

(*<*)
end
(*>*)