(*
 * 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)
 *)

(*
 * Facts about recursive functions with measure parameter.
 * Any recursive functions from AutoCorres are monotonic in the measure,
 * which allows us to use the "measure_call" mechanism for calling them.
 *)
theory MonadMono
imports
  NonDetMonadEx
  "../../lib/Monad_WP/OptionMonadWP"
begin

(*
 * Call function f by returning all of its possible results.
 * The call succeeds if any measure value succeeds.
 *)
definition "measure_call f \<equiv>
    \<lambda>s. ({(r', s'). \<exists>m. (r', s') \<in> fst (f m s)}, \<forall>m. snd (f m s))"

(*
 * monad_mono gives preconditions for functions so that measure_call will
 * return meaningful results.
 *
 * The preconditions are:
 *
 * - If the measure is increased, the function never returns fewer
 *   results. (Monotonicity condition)
 *
 * - If the function succeeds with some measure, it will not fail with
 *   a larger measure, and will return exactly the same results.
 *
 * The monotonicity condition is technically not needed, but all our
 * functions satisfy it anyway and it makes intermediate proofs easier.
 *)
definition "monad_mono f \<equiv>
     (\<forall>(x :: nat) y s. x < y \<longrightarrow>
         (fst (f x s) \<subseteq> fst (f y s) \<and>
          (\<not> snd (f x s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f x s) = fst (f y s))))"

(* Basic monad_mono lemmas *)
lemma monad_mono_incl: "\<lbrakk> monad_mono f; \<not> snd (f m s) \<rbrakk> \<Longrightarrow> fst (f m' s) \<subseteq> fst (f m s)"
  using less_linear[where x = m and y = m']
  by (auto simp: monad_mono_def)

(* wp rules for function calls *)
lemma call_all_valid [wp]:
    "\<lbrakk> \<forall> m. valid P (x m) Q; monad_mono x \<rbrakk> \<Longrightarrow> valid P (measure_call x) Q"
  apply (clarsimp simp: valid_def measure_call_def monad_mono_def)
  by blast

lemma call_all_validNF [wp]:
    "\<lbrakk>  validNF P (x m) Q; monad_mono x \<rbrakk> \<Longrightarrow> validNF P (measure_call x) Q"
  apply (clarsimp simp: measure_call_def validNF_def valid_def no_fail_def)
  apply (metis in_mono split_conv monad_mono_incl)
  done

(* Alternative definition of monad_mono, suitable for induction *)
definition "monad_mono_step f m \<equiv>
  (\<forall>s. fst (f m s) \<subseteq> fst (f (Suc m) s) \<and>
       (\<not> snd (f m s) \<longrightarrow> \<not> snd (f (Suc m) s) \<and> fst (f m s) = fst (f (Suc m) s)))"

lemma monad_mono_alt_def: "monad_mono f = (\<forall>m. monad_mono_step f m)"
  apply (rule iffI)
   apply (fastforce simp: monad_mono_def monad_mono_step_def)
  apply (unfold monad_mono_def monad_mono_step_def)
  apply clarify
  apply (subst (asm) atomize_all[symmetric])+
  proof -
    fix x y :: nat
    fix s
    assume suc: "\<And>m s. fst (f m s) \<subseteq> fst (f (Suc m) s) \<and>
              (\<not> snd (f m s) \<longrightarrow> \<not> snd (f (Suc m) s) \<and> fst (f m s) = fst (f (Suc m) s))"
       and less: "x < y"
    thus "fst (f x s) \<subseteq> fst (f y s) \<and>
          (\<not> snd (f x s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f x s) = fst (f y s))"
      apply (induct x)
       apply (induct y)
        apply blast
       apply blast
      (* induct bureaucracy... *)
      proof -
        fix x :: nat
        assume less: "Suc x < y"
        thus "fst (f (Suc x) s) \<subseteq> fst (f y s) \<and>
           (\<not> snd (f (Suc x) s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f (Suc x) s) = fst (f y s))"
          apply (induct y)
           apply blast
          apply (case_tac "Suc x < y")
           using suc apply blast
          apply (case_tac "Suc x = y")
           using suc apply blast
          apply simp
          done
       qed
  qed

lemmas monad_mono_step = iffD2[OF monad_mono_alt_def, rule_format]

lemma monad_mono_step_const: "monad_mono_step (\<lambda>_. f) m"
  by (simp add: monad_mono_step_def)

(* nondet_monad rules *)
lemma monad_mono_step_in_monad:
  "\<lbrakk> monad_mono_step f m; (r', s') \<in> fst (f m s) \<rbrakk> \<Longrightarrow> (r', s') \<in> fst (f (Suc m) s)"
  apply (clarsimp simp: monad_mono_step_def)
  apply blast
  done

lemma monad_mono_step_snd_monad:
  "\<lbrakk> monad_mono_step f m; \<not> snd (f m s) \<rbrakk> \<Longrightarrow> \<not> snd (f (Suc m) s)"
  by (clarsimp simp: monad_mono_step_def)

lemma monad_mono_step_bexI:
  "\<lbrakk> monad_mono_step f m; (r', s') \<in> fst (f m s); P r' s' \<rbrakk> \<Longrightarrow> \<exists>(r', s') \<in> fst (f (Suc m) s). P r' s'"
  apply (drule (1) monad_mono_step_in_monad)
  apply force
  done

lemma monad_mono_stepI [intro]:
  "\<lbrakk> \<And>s r' s'. (r', s') \<in> fst (f m s) \<Longrightarrow> (r', s') \<in> fst (f (Suc m) s);
     \<And>s. \<not> snd (f m s) \<Longrightarrow> \<not> snd (f (Suc m) s);
     \<And>s r' s'. \<lbrakk> \<not> snd (f m s); \<not> snd (f (Suc m) s); (r', s') \<in> fst (f (Suc m) s) \<rbrakk>
                \<Longrightarrow> (r', s') \<in> fst (f m s)
   \<rbrakk> \<Longrightarrow> monad_mono_step f m"
  apply (clarsimp simp: monad_mono_step_def)
  apply fast
  done

lemma monad_mono_step_bind:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. (f m) >>= (g m)) m"
  apply atomize
  apply rule
    apply (monad_eq)
    apply (metis monad_mono_step_in_monad)
   apply (monad_eq simp: Ball_def)
   apply (metis monad_mono_step_def)
  apply (monad_eq simp: Ball_def)
  apply (unfold monad_mono_step_def)
  apply blast
  done

lemma monad_mono_step_bindE:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. (f m) >>=E (g m)) m"
  apply (unfold bindE_def)
  apply (rule monad_mono_step_bind)
   apply simp
  apply (monad_eq simp: monad_mono_step_def NonDetMonad.lift_def
      split: sum.splits)
  done

lemma monad_mono_step_liftE:
  "monad_mono_step f m \<Longrightarrow> monad_mono_step (\<lambda>m. liftE (f m)) m"
  apply (unfold liftE_def)
  apply (erule monad_mono_step_bind)
  apply (rule monad_mono_step_const)
  done

lemma monad_mono_step_handleE':
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. f m <handle2> g m) m"
  apply atomize
  apply rule
    apply (monad_eq)
    apply (metis monad_mono_step_in_monad)
   apply (monad_eq simp: Ball_def)
   apply (metis monad_mono_step_def)
  apply (monad_eq simp: Ball_def)
  apply (fastforce simp: monad_mono_step_def)
  done

lemma monad_mono_step_handleE:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. f m <handle> g m) m"
  by (simp add: handleE_def monad_mono_step_handleE')

lemma monad_mono_step_condition:
  "\<lbrakk> monad_mono_step f m; monad_mono_step g m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. condition C (f m) (g m)) m"
  apply rule
    apply (monad_eq simp: monad_mono_step_def, blast)+
  done

lemma fst_whileLoop_is_exs_valid:
  "((a, b) \<in> fst (whileLoop C B i s)) = \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B i \<exists>\<lbrace> \<lambda>rv s. rv = a \<and> s = b \<rbrace>"
  by (clarsimp simp: exs_valid_def Bex_def)

lemma not_snd_whileLoop_is_validNF:
  "(\<not> snd (whileLoop C B i s)) = \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B i \<lbrace> \<lambda>_ _. True \<rbrace>!"
  by (clarsimp simp: validNF_alt_def)

lemma monad_mono_step_whileLoop:
  assumes body_mono: "\<And>x. monad_mono_step (\<lambda>m. B m x) m"
  shows "monad_mono_step (\<lambda>m. whileLoop C (B m) i) m"
proof -
  {
    fix a b s
    have "(a, b) \<in> fst (whileLoop C (B m) i s) \<Longrightarrow>
             (a, b) \<in> fst (whileLoop C (B (Suc m)) i s)"
      apply (clarsimp simp: fst_whileLoop_is_exs_valid)
      apply (subst (asm) exs_valid_whileLoop_complete [symmetric])
      apply (erule exE | erule conjE)+
      apply (rule_tac T=T and R=R in exs_valid_whileLoop)
         apply clarsimp
        apply (cut_tac x=r in body_mono)
        apply (clarsimp simp: monad_mono_step_def exs_valid_def split_def)
        apply blast
       apply simp
      apply blast
      done
  }
  note A = this

  {
    fix a b s
    have "\<lbrakk> \<not> snd (whileLoop C (B m) i s);
                  (a, b) \<in> fst (whileLoop C (B (Suc m)) i s) \<rbrakk>
              \<Longrightarrow> (a, b) \<in> fst (whileLoop C (B m) i s)"
      apply (clarsimp simp: fst_whileLoop_is_exs_valid)
      apply (subst (asm) exs_valid_whileLoop_complete [symmetric])
      apply (subst (asm) not_snd_whileLoop_complete)
      apply (erule exE | erule conjE)+
      apply (rule_tac T="\<lambda>r s. T r s \<and> I r s" and R=Ra in exs_valid_whileLoop)
         apply simp
        apply (cut_tac x=r in body_mono)
        apply (clarsimp simp: monad_mono_step_def exs_valid_def split_def Bex_def)
        apply metis
       apply simp
      apply (clarsimp simp: exs_valid_def Bex_def)
      done
  }
  note B = this

  {
    fix i s
    have "\<lbrakk>\<not> snd (whileLoop C (B m) i s) \<rbrakk> \<Longrightarrow>
                  \<not> snd (whileLoop C (B (Suc m)) i s)"
      apply (subst (asm) not_snd_whileLoop_complete)
      apply (erule exE | erule conjE)+
      apply (rule_tac I="I" and R=R in not_snd_whileLoop)
        apply clarsimp
       apply (cut_tac x=r in body_mono)
       apply (clarsimp simp: monad_mono_step_def validNF_alt_def)
       apply blast
      apply simp
      done
  }
  note C = this

  show ?thesis
    apply (clarsimp simp: monad_mono_step_def)
    apply (metis prod.exhaust subsetI subset_antisym A B C)
    done
qed

lemma monad_mono_step_whileLoopE:
  "\<lbrakk> \<And>x. monad_mono_step (\<lambda>m. B m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. whileLoopE C (B m) i) m"
  apply (unfold whileLoopE_def)
  apply (subgoal_tac "\<And>x. monad_mono_step (\<lambda>m. lift (B m) x) m")
  apply (erule monad_mono_step_whileLoop)
  apply (unfold lift_def)
  apply rule
    apply (clarsimp split: prod.splits sum.splits)
    apply (fastforce dest: monad_mono_step_in_monad)
   apply (clarsimp split: prod.splits sum.splits simp: monad_mono_step_def)+
  done

(* measure_call for the option monad. *)
definition "measure_ocall f \<equiv> \<lambda>s. f (SOME m. f m s \<noteq> None) s"

definition "option_monad_mono f \<equiv>
  \<forall>(x :: nat) y s. x < y \<longrightarrow>
    (case f y s of None \<Rightarrow> f x s = None
                 | Some r \<Rightarrow> f x s = None \<or> f x s = Some r)"

lemma option_monad_mono_eq:
  "(\<And>m. f m = gets_the (f' m)) \<Longrightarrow> monad_mono f = option_monad_mono f'"
  apply (clarsimp simp: monad_mono_def option_monad_mono_def gets_the_def
    gets_def get_def assert_opt_def return_def fail_def bind_def' split: option.splits)
  apply (rule iff_allI iff_impI)+
  apply (rule_tac t = "\<forall>r. f' x s = Some r \<longrightarrow> (\<exists>r'. f' y s = Some r') \<and> (\<forall>r'. f' y s = Some r' \<longrightarrow> r = r')"
              and s = "\<forall>r. f' x s = Some r \<longrightarrow> f' y s = Some r" in subst)
   apply (force intro: iff_allI iff_impI)
  apply (rule iffI)
   apply (metis (hide_lams, no_types) option.exhaust)
  apply force
  done

lemma measure_ocall_ovalid [wp]:
    "\<lbrakk> \<forall> m. ovalid P (x m) Q; option_monad_mono x \<rbrakk> \<Longrightarrow> ovalid P (measure_ocall x) Q"
  by (clarsimp simp: ovalid_def measure_ocall_def option_monad_mono_def)

lemma measure_ocall_ovalidNF [wp]:
    "\<lbrakk> ovalidNF P (x m) Q; option_monad_mono x \<rbrakk> \<Longrightarrow> ovalidNF P (measure_ocall x) Q"
  apply (clarsimp simp: measure_ocall_def option_monad_mono_def ovalidNF_def)
  apply (rule_tac a = m in someI2)
   apply simp
  apply (metis (lifting, full_types) linorder_neqE_nat option.distinct(1) option.simps(5))
  done

end


(*  Title:       CoreC++
    Author:      Daniel Wasserrab
    Maintainer:  Daniel Wasserrab <wasserra at fmi.uni-passau.de>
*)

header {* \isaheader{Definition of Subobjects} *}

theory SubObj
imports ClassRel
begin

section {* General definitions *}

type_synonym
  subobj = "cname  \<times> path"

definition mdc :: "subobj \<Rightarrow> cname" where
  "mdc S = fst S"

definition ldc :: "subobj \<Rightarrow> cname" where
  "ldc S = last (snd S)"

lemma mdc_tuple [simp]: "mdc (C,Cs) = C"
by(simp add:mdc_def)

lemma ldc_tuple [simp]: "ldc (C,Cs) = last Cs"
by(simp add:ldc_def)

section {* Subobjects according to Rossie-Friedman *}

fun is_subobj :: "prog \<Rightarrow> subobj \<Rightarrow> bool" -- "legal subobject to class hierarchie" where
  "is_subobj P (C, []) \<longleftrightarrow> False"
| "is_subobj P (C, [D]) \<longleftrightarrow> (is_class P C \<and> C = D)
                                \<or> (\<exists> X. P \<turnstile> C \<preceq>\<^sup>* X \<and> P \<turnstile> X \<prec>\<^sub>S D)"
| "is_subobj P (C, D # E # Xs) = (let Ys=butlast (D # E # Xs);
                                      Y=last (D # E # Xs);
                                      X=last Ys
                                in is_subobj P (C, Ys) \<and> P \<turnstile> X \<prec>\<^sub>R Y)"

lemma subobj_aux_rev:
assumes 1:"is_subobj P ((C,C'#rev Cs@[C'']))"
shows "is_subobj P ((C,C'#rev Cs))"
proof -
  obtain Cs' where Cs':"Cs' = rev Cs" by simp
  hence rev:"Cs'@[C''] = rev Cs@[C'']" by simp
  from this obtain D Ds where DDs:"Cs'@[C''] = D#Ds" by (cases Cs') auto
  with 1 rev have subo:"is_subobj P ((C,C'#D#Ds))" by simp
  from DDs have "butlast (C'#D#Ds) = C'#Cs'" by (cases Cs') auto
  with subo have "is_subobj P ((C,C'#Cs'))" by simp
  with Cs' show ?thesis by simp
qed

lemma subobj_aux:
assumes 1:"is_subobj P ((C,C'#Cs@[C'']))"
shows "is_subobj P ((C,C'#Cs))"
proof -
  from 1 obtain Cs' where Cs':"Cs' = rev Cs" by simp
  with 1 have "is_subobj P ((C,C'#rev Cs'@[C'']))" by simp
  hence "is_subobj P ((C,C'#rev Cs'))" by (rule subobj_aux_rev)
  with Cs' show ?thesis by simp
qed

lemma isSubobj_isClass:
assumes 1:"is_subobj P (R)"
shows "is_class P (mdc R)"

proof -
  obtain C' Cs' where R:"R = (C',Cs')" by(cases R) auto
  with 1 have ne:"Cs' \<noteq> []" by (cases Cs') auto
  from this obtain C'' Cs'' where C''Cs'':"Cs' = C''#Cs''" by (cases Cs') auto
  from this obtain Ds where "Ds = rev Cs''" by simp
  with 1 R C''Cs'' have subo1:"is_subobj P ((C',C''#rev Ds))" by simp
  with R show ?thesis
    by (induct Ds,auto simp:mdc_def split:split_if_asm dest:subobj_aux,
      auto elim:converse_rtranclE dest!:subclsS_subcls1 elim:subcls1_class)
qed

lemma isSubobjs_subclsR_rev:
assumes 1:"is_subobj P ((C,Cs@[D,D']@(rev Cs')))"
shows "P \<turnstile> D \<prec>\<^sub>R D'"
using 1
proof (induct Cs')
  case Nil
  from this obtain Cs' X Y Xs where Cs'1:"Cs' = Cs@[D,D']"
    and "X = hd(Cs@[D,D'])" and "Y = hd(tl(Cs@[D,D']))"
    and "Xs =  tl(tl(Cs@[D,D']))" by simp
  hence Cs'2:"Cs' = X#Y#Xs" by (cases Cs) auto
  from Cs'1 have last:"last Cs' = D'" by simp
  from Cs'1 have butlast:"last(butlast Cs') = D" by (simp add:butlast_tail)
  from Nil Cs'1 Cs'2 have "is_subobj P ((C,X#Y#Xs))" by simp
  with last butlast Cs'2 show ?case by simp
next
  case (Cons C'' Cs'')
  have IH:"is_subobj P ( (C, Cs @ [D, D'] @ rev Cs'')) \<Longrightarrow> P \<turnstile> D \<prec>\<^sub>R D'" by fact
  from Cons obtain Cs' X Y Xs where Cs'1:"Cs' = Cs@[D,D']@(rev (C''#Cs''))"
    and "X = hd(Cs@[D,D']@(rev (C''#Cs'')))"
    and "Y = hd(tl(Cs@[D,D']@(rev (C''#Cs''))))"
    and "Xs =  tl(tl(Cs@[D,D']@(rev (C''#Cs''))))" by simp
  hence Cs'2:"Cs' = X#Y#Xs" by (cases Cs) auto
  from Cons Cs'1 Cs'2 have "is_subobj P ((C,X#Y#Xs))" by simp
  hence sub:"is_subobj P ((C,butlast (X#Y#Xs)))" by simp
  from Cs'1 obtain E Es where Cs'3:"Cs' = Es@[E]" by (cases Cs') auto
  with Cs'1 have butlast:"Es = Cs@[D,D']@(rev Cs'')" by simp
  from Cs'3 have "butlast Cs' = Es" by simp
  with butlast have "butlast Cs' = Cs@[D,D']@(rev Cs'')" by simp
  with Cs'2 sub have "is_subobj P ((C,Cs@[D,D']@(rev Cs'')))"
    by simp
  with IH show ?case by simp
qed

lemma isSubobjs_subclsR:
assumes 1:"is_subobj P ((C,Cs@[D,D']@Cs'))"
shows "P \<turnstile> D \<prec>\<^sub>R D'"

proof -
  from 1 obtain Cs'' where "Cs'' = rev Cs'" by simp
  with 1 have "is_subobj P ((C,Cs@[D,D']@(rev Cs'')))" by simp
  thus ?thesis by (rule isSubobjs_subclsR_rev)
qed

lemma mdc_leq_ldc_aux:
assumes 1:"is_subobj P ((C,C'#rev Cs'))"
shows "P \<turnstile> C \<preceq>\<^sup>* last (C'#rev Cs')"
using 1
proof (induct Cs')
  case Nil
  from 1 have "is_class P C"
    by (drule_tac R="(C,C'#rev Cs')" in isSubobj_isClass, simp add:mdc_def)
  with Nil show ?case
    proof (cases "C=C'")
      case True
      thus ?thesis by simp
    next
      case False
      with Nil show ?thesis
        by (auto dest!:subclsS_subcls1)
    qed
  next
    case (Cons C'' Cs'')
    have IH:"is_subobj P ( (C, C' # rev Cs'')) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* last (C' # rev Cs'')"
      and subo:"is_subobj P ( (C, C' # rev (C'' # Cs'')))" by fact+
    hence "is_subobj P ( (C, C' # rev Cs''))" by (simp add:subobj_aux_rev)
    with IH have rel:"P \<turnstile> C \<preceq>\<^sup>* last (C' # rev Cs'')" by simp
    from subo obtain D Ds where DDs:"C' # rev Cs'' = Ds@[D]"
      by (cases Cs'') auto
    hence " C' # rev (C'' # Cs'') = Ds@[D,C'']" by simp
    with subo have "is_subobj P ((C,Ds@[D,C'']))" by (cases Ds) auto
    hence "P \<turnstile> D \<prec>\<^sub>R C''" by (rule_tac Cs'="[]" in isSubobjs_subclsR) simp
    hence rel1:"P \<turnstile> D \<prec>\<^sup>1 C''" by (rule subclsR_subcls1)
    from DDs have "D = last (C' # rev Cs'')" by simp
    with rel1 have lastrel1:"P \<turnstile> last (C' # rev Cs'') \<prec>\<^sup>1 C''" by simp
    with rel have "P \<turnstile> C \<preceq>\<^sup>* C''"
      by(rule_tac b="last (C' # rev Cs'')" in rtrancl_into_rtrancl) simp
    thus ?case by simp
qed

lemma mdc_leq_ldc:
assumes 1:"is_subobj P (R)"
shows "P \<turnstile> mdc R \<preceq>\<^sup>* ldc R"

proof -
  from 1 obtain C Cs where R:"R = (C,Cs)" by (cases R) auto
  with 1 have ne:"Cs \<noteq> []" by (cases Cs) auto
  from this obtain C' Cs' where Cs:"Cs = C'#Cs'" by (cases Cs) auto
  from this obtain Cs'' where Cs':"Cs'' = rev Cs'" by simp
  with R Cs 1 have "is_subobj P ((C,C'#rev Cs''))" by simp
  hence rel:"P \<turnstile> C \<preceq>\<^sup>* last (C'#rev Cs'')" by (rule mdc_leq_ldc_aux)
  from R Cs Cs' have ldc:"last (C'#rev Cs'') = ldc R" by(simp add:ldc_def)
  from R have "mdc R = C" by(simp add:mdc_def)
  with ldc rel show ?thesis by simp
qed

text{* Next three lemmas show subobject property as presented in literature *}

lemma class_isSubobj:
  "is_class P C \<Longrightarrow> is_subobj P ((C,[C]))"
by simp

lemma repSubobj_isSubobj:
assumes 1:"is_subobj P ((C,Xs@[X]))" and 2:"P \<turnstile> X \<prec>\<^sub>R Y"
shows "is_subobj P ((C,Xs@[X,Y]))"

using 1
proof -
  obtain Cs D E Cs' where Cs1:"Cs = Xs@[X,Y]" and  "D = hd(Xs@[X,Y])"
    and "E = hd(tl(Xs@[X,Y]))" and "Cs' = tl(tl(Xs@[X,Y]))"by simp
  hence Cs2:"Cs = D#E#Cs'" by (cases Xs) auto
  with 1 Cs1 have subobj_butlast:"is_subobj P ((C,butlast(D#E#Cs')))"
    by (simp add:butlast_tail)
  with 2 Cs1 Cs2 have "P \<turnstile> (last(butlast(D#E#Cs'))) \<prec>\<^sub>R last(D#E#Cs')"
    by (simp add:butlast_tail)
  with subobj_butlast have "is_subobj P ((C,(D#E#Cs')))" by simp
  with Cs1 Cs2 show ?thesis by simp
qed

lemma shSubobj_isSubobj:
assumes 1:  "is_subobj P ((C,Xs@[X]))" and 2:"P \<turnstile> X \<prec>\<^sub>S Y"
shows "is_subobj P ((C,[Y]))"

using 1
proof -
  from 1 have classC:"is_class P C"
    by (drule_tac R="(C,Xs@[X])" in isSubobj_isClass, simp add:mdc_def)
  from 1 have "P \<turnstile> C \<preceq>\<^sup>* X"
    by (drule_tac R="(C,Xs@[X])" in mdc_leq_ldc, simp add:mdc_def ldc_def)
  with classC 2 show ?thesis by fastforce
qed

text{* Auxiliary lemmas *}

lemma build_rec_isSubobj_rev:
assumes 1:"is_subobj P ((D,D#rev Cs))" and 2:" P \<turnstile> C \<prec>\<^sub>R D"
shows "is_subobj P ((C,C#D#rev Cs))"
using 1
proof (induct Cs)
  case Nil
  from 2 have "is_class P C" by (auto dest:subclsRD simp add:is_class_def)
  with 1 2 show ?case by simp
next
  case (Cons C' Cs')
  have suboD:"is_subobj P ((D,D#rev (C'#Cs')))"
    and IH:"is_subobj P ((D,D#rev Cs')) \<Longrightarrow> is_subobj P ((C,C#D#rev Cs'))" by fact+
  obtain E Es where E:"E = hd (rev (C'#Cs'))" and Es:"Es = tl (rev (C'#Cs'))"
    by simp
  with E have E_Es:"rev (C'#Cs') = E#Es" by simp
  with E Es have butlast:"butlast (D#E#Es) = D#rev Cs'" by simp
  from E_Es suboD have suboDE:"is_subobj P ((D,D#E#Es))" by simp
  hence "is_subobj P ((D,butlast (D#E#Es)))" by simp
  with butlast have "is_subobj P ((D,D#rev Cs'))" by simp
  with IH have suboCD:"is_subobj P ( (C, C#D#rev Cs'))" by simp
  from suboDE obtain Xs X Y Xs' where Xs':"Xs' = D#E#Es"
    and bb:"Xs = butlast (butlast (D#E#Es))"
    and lb:"X = last(butlast (D#E#Es))" and l:"Y = last (D#E#Es)" by simp
  from this obtain Xs'' where Xs'':"Xs'' = Xs@[X]" by simp
  with bb lb have "Xs'' = butlast (D#E#Es)" by simp
  with l have "D#E#Es = Xs''@[Y]" by simp
  with Xs'' have "D#E#Es = Xs@[X]@[Y]" by simp
  with suboDE have "is_subobj P ((D,Xs@[X,Y]))" by simp
  hence subR:"P \<turnstile> X \<prec>\<^sub>R Y"  by(rule_tac Cs="Xs" and Cs'="[]" in isSubobjs_subclsR) simp
  from E_Es Es have "last (D#E#Es) = C'" by simp
  with subR lb l butlast have "P \<turnstile> last(D#rev Cs') \<prec>\<^sub>R C'"
    by (auto split:split_if_asm)
  with suboCD show ?case by simp
qed

lemma build_rec_isSubobj:
assumes 1:"is_subobj P ((D,D#Cs))" and 2:" P \<turnstile> C \<prec>\<^sub>R D"
shows "is_subobj P ((C,C#D#Cs))"

proof -
  obtain Cs' where Cs':"Cs' = rev Cs" by simp
  with 1 have "is_subobj P ((D,D#rev Cs'))" by simp
  with 2 have "is_subobj P ((C,C#D#rev Cs'))"
    by - (rule build_rec_isSubobj_rev)
  with Cs' show ?thesis by simp
qed

lemma isSubobj_isSubobj_isSubobj_rev:
assumes 1:"is_subobj P ((C,[D]))" and 2:"is_subobj P ((D,D#(rev Cs)))"
shows "is_subobj P ((C,D#(rev Cs)))"
using 2
proof (induct Cs)
 case Nil
 with 1 show ?case by simp
next
  case (Cons C' Cs')
  have IH:"is_subobj P ((D,D#rev Cs')) \<Longrightarrow> is_subobj P ((C,D#rev Cs'))"
    and "is_subobj P ((D,D#rev (C'#Cs')))" by fact+
  hence suboD:"is_subobj P ((D,D#rev Cs'@[C']))" by simp
  hence "is_subobj P ((D,D#rev Cs'))" by (rule subobj_aux_rev)
  with IH have suboC:"is_subobj P ((C,D#rev Cs'))" by simp
  obtain C'' where C'':"C'' = last(D#rev Cs')" by simp
  hence butlast:"D#rev Cs' = butlast(D#rev Cs')@[C'']" by simp
  hence butlast2:"D#rev Cs'@[C'] = butlast(D#rev Cs')@[C'']@[C']" by simp
  with suboD have "is_subobj P ((D,butlast(D#rev Cs')@[C'']@[C']))"
    by simp
  with C'' have subR:"P \<turnstile> C'' \<prec>\<^sub>R C'"
    by (rule_tac Cs="butlast(D#rev Cs')" and Cs'="[]" in isSubobjs_subclsR)simp
  with C'' suboC butlast have "is_subobj P ((C,butlast(D#rev Cs')@[C'']@[C']))"
    by (auto intro:repSubobj_isSubobj simp del:butlast.simps)
  with butlast2 have "is_subobj P ((C,D#rev Cs'@[C']))"
    by (cases Cs')auto
  thus ?case by simp
qed

lemma isSubobj_isSubobj_isSubobj:
assumes 1:"is_subobj P ((C,[D]))" and 2:"is_subobj P ((D,D#Cs))"
shows "is_subobj P ((C,D#Cs))"

proof -
  obtain Cs' where Cs':"Cs' = rev Cs" by simp
  with 2 have "is_subobj P ((D,D#rev Cs'))" by simp
  with 1 have "is_subobj P ((C,D#rev Cs'))"
  by - (rule isSubobj_isSubobj_isSubobj_rev)
with Cs' show ?thesis by simp
qed

section {* Subobject handling and lemmas *}

text{* Subobjects consisting of repeated inheritance relations only: *}

inductive Subobjs\<^sub>R :: "prog \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> bool" for P :: prog
where
  SubobjsR_Base: "is_class P C \<Longrightarrow> Subobjs\<^sub>R P C [C]"
| SubobjsR_Rep: "\<lbrakk>P \<turnstile> C \<prec>\<^sub>R D; Subobjs\<^sub>R P D Cs\<rbrakk> \<Longrightarrow> Subobjs\<^sub>R P C (C # Cs)"

text{* All subobjects: *}

inductive Subobjs :: "prog \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> bool" for P :: prog
where
  Subobjs_Rep: "Subobjs\<^sub>R P C Cs \<Longrightarrow> Subobjs P C Cs"
| Subobjs_Sh: "\<lbrakk>P \<turnstile> C \<preceq>\<^sup>* C'; P \<turnstile> C' \<prec>\<^sub>S D; Subobjs\<^sub>R P D Cs\<rbrakk>
             \<Longrightarrow> Subobjs P C Cs"

lemma Subobjs_Base:"is_class P C \<Longrightarrow> Subobjs P C [C]"
by (fastforce intro:Subobjs_Rep SubobjsR_Base)

lemma SubobjsR_nonempty: "Subobjs\<^sub>R P C Cs \<Longrightarrow> Cs \<noteq> []"
by (induct rule: Subobjs\<^sub>R.induct, simp_all)

lemma Subobjs_nonempty: "Subobjs P C Cs \<Longrightarrow> Cs \<noteq> []"
by (erule Subobjs.induct)(erule SubobjsR_nonempty)+

lemma hd_SubobjsR:
  "Subobjs\<^sub>R P C Cs \<Longrightarrow> \<exists>Cs'. Cs = C#Cs'"
by(erule Subobjs\<^sub>R.induct,simp+)

lemma SubobjsR_subclassRep:
  "Subobjs\<^sub>R P C Cs \<Longrightarrow> (C,last Cs) \<in> (subclsR P)\<^sup>*"

apply(erule Subobjs\<^sub>R.induct)
 apply simp
apply(simp add: SubobjsR_nonempty)
done

lemma SubobjsR_subclass: "Subobjs\<^sub>R P C Cs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* last Cs"

apply(erule Subobjs\<^sub>R.induct)
 apply simp
apply(simp add: SubobjsR_nonempty)
apply(blast intro:subclsR_subcls1 rtrancl_trans)
done

lemma Subobjs_subclass: "Subobjs P C Cs \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* last Cs"

apply(erule Subobjs.induct)
 apply(erule SubobjsR_subclass)
apply(erule rtrancl_trans)
apply(blast intro:subclsS_subcls1 SubobjsR_subclass rtrancl_trans)
done

lemma Subobjs_notSubobjsR:
  "\<lbrakk>Subobjs P C Cs; \<not> Subobjs\<^sub>R P C Cs\<rbrakk>
\<Longrightarrow> \<exists>C' D. P \<turnstile> C \<preceq>\<^sup>* C' \<and> P \<turnstile> C' \<prec>\<^sub>S D \<and> Subobjs\<^sub>R P D Cs"
apply (induct rule: Subobjs.induct)
 apply clarsimp
apply fastforce
done

lemma Subobjs_Subobjs:"Subobjs P C (Cs@ C'#Cs') \<Longrightarrow> Subobjs P C' (C'#Cs')"

  apply -
  apply (drule Subobjs.cases)
  apply auto
   apply (subgoal_tac "C = hd(Cs @ C' # Cs')")
    apply (fastforce intro:SubobjsR_Subobjs)
   apply (fastforce dest:hd_SubobjsR)
  apply (subgoal_tac "D = hd(Cs @ C' # Cs')")
   apply (fastforce intro:SubobjsR_Subobjs)
  apply (fastforce dest:hd_SubobjsR)
  done

lemma SubobjsR_isClass:
assumes subo:"Subobjs\<^sub>R P C Cs"
shows "is_class P C"

using subo
proof (induct rule:Subobjs\<^sub>R.induct)
  case SubobjsR_Base thus ?case by assumption
next
  case SubobjsR_Rep thus ?case by (fastforce intro:subclsR_subcls1 subcls1_class)
qed

lemma Subobjs_isClass:
assumes subo:"Subobjs P C Cs"
shows "is_class P C"

using subo
proof (induct rule:Subobjs.induct)
  case Subobjs_Rep thus ?case by (rule SubobjsR_isClass)
next
  case (Subobjs_Sh C C' D Cs)
  have leq:"P \<turnstile> C \<preceq>\<^sup>* C'" and leqS:"P \<turnstile> C' \<prec>\<^sub>S D" by fact+
  hence "(C,D) \<in> (subcls1 P)\<^sup>+" by (fastforce intro:rtrancl_into_trancl1 subclsS_subcls1)
  thus ?case by (induct rule:trancl_induct, fastforce intro:subcls1_class)
qed

lemma Subobjs_subclsR:
assumes subo:"Subobjs P C (Cs@[D,D']@Cs')"
shows "P \<turnstile> D \<prec>\<^sub>R D'"

using subo
proof -
  from subo have "Subobjs P D (D#D'#Cs')" by -(rule Subobjs_Subobjs,simp)
  then obtain C' where subo':"Subobjs\<^sub>R P C' (D#D'#Cs')"
    by (induct rule:Subobjs.induct,blast+)
  hence "C' = D" by -(drule hd_SubobjsR,simp)
  with subo' have "Subobjs\<^sub>R P D (D#D'#Cs')" by simp
  thus ?thesis by (fastforce elim:Subobjs\<^sub>R.cases dest:hd_SubobjsR)
qed

lemma assumes subo:"Subobjs\<^sub>R P (hd Cs) (Cs@[D])" and notempty:"Cs \<noteq> []"
  shows butlast_Subobjs_Rep:"Subobjs\<^sub>R P (hd Cs) Cs"
using subo notempty
proof (induct Cs)
  case Nil thus ?case by simp
next
  case (Cons C' Cs')
  have subo:"Subobjs\<^sub>R P (hd(C'#Cs')) ((C'#Cs')@[D])"
    and IH:"\<lbrakk>Subobjs\<^sub>R P (hd Cs') (Cs'@[D]); Cs' \<noteq> []\<rbrakk> \<Longrightarrow> Subobjs\<^sub>R P (hd Cs') Cs'" by fact+
  from subo have subo':"Subobjs\<^sub>R P C' (C'#Cs'@[D])" by simp
  show ?case
  proof (cases "Cs' = []")
    case True
    with subo' have "Subobjs\<^sub>R P C' [C',D]" by simp
    hence "is_class P C'" by(rule SubobjsR_isClass)
    hence "Subobjs\<^sub>R P C' [C']" by (rule SubobjsR_Base)
    with True show ?thesis by simp
  next
    case False
    with subo' obtain D' where subo'':"Subobjs\<^sub>R P D' (Cs'@[D])"
      and subR:"P \<turnstile> C' \<prec>\<^sub>R D'"
      by (auto elim:Subobjs\<^sub>R.cases)
    from False subo'' have hd:"D' = hd Cs'"
      by (induct Cs',auto dest:hd_SubobjsR)
    with subo'' False IH have "Subobjs\<^sub>R P (hd Cs') Cs'" by simp
    with subR hd have "Subobjs\<^sub>R P C' (C'#Cs')" by (fastforce intro:SubobjsR_Rep)
    thus ?thesis by simp
  qed
qed

lemma assumes subo:"Subobjs P C (Cs@[D])" and notempty:"Cs \<noteq> []"
  shows butlast_Subobjs:"Subobjs P C Cs"

using subo
proof (rule Subobjs.cases,auto)
  assume suboR:"Subobjs\<^sub>R P C (Cs@[D])" and "Subobjs P C (Cs@[D])"
  from suboR notempty have hd:"C = hd Cs"
    by (induct Cs,auto dest:hd_SubobjsR)
  with suboR notempty have "Subobjs\<^sub>R P (hd Cs) Cs"
    by(fastforce intro:butlast_Subobjs_Rep)
  with hd show "Subobjs P C Cs" by (fastforce intro:Subobjs_Rep)
next
  fix C' D' assume leq:"P \<turnstile> C \<preceq>\<^sup>* C'" and subS:"P \<turnstile> C' \<prec>\<^sub>S D'"
  and suboR:"Subobjs\<^sub>R P D' (Cs@[D])" and "Subobjs P C (Cs@[D])"
  from suboR notempty have hd:"D' = hd Cs"
    by (induct Cs,auto dest:hd_SubobjsR)
  with suboR notempty have "Subobjs\<^sub>R P (hd Cs) Cs"
    by(fastforce intro:butlast_Subobjs_Rep)
  with hd leq subS show "Subobjs P C Cs"
    by(fastforce intro:Subobjs_Sh)
qed

lemma assumes subo:"Subobjs P C (Cs@(rev Cs'))" and notempty:"Cs \<noteq> []"
  shows rev_appendSubobj:"Subobjs P C Cs"
using subo
proof(induct Cs')
  case Nil thus ?case by simp
next
  case (Cons D Ds)
  have subo':"Subobjs P C (Cs@rev(D#Ds))"
    and IH:"Subobjs P C (Cs@rev Ds) \<Longrightarrow> Subobjs P C Cs" by fact+
  from notempty subo' have "Subobjs P C (Cs@rev Ds)"
    by (fastforce intro:butlast_Subobjs)
  with IH show ?case by simp
qed

lemma appendSubobj:
assumes subo:"Subobjs P C (Cs@Cs')" and notempty:"Cs \<noteq> []"
shows "Subobjs P C Cs"

proof -
  obtain Cs'' where Cs'':"Cs'' = rev Cs'" by simp
  with subo have "Subobjs P C (Cs@(rev Cs''))" by simp
  with notempty show ?thesis by - (rule rev_appendSubobj)
qed

lemma SubobjsR_isSubobj:
  "Subobjs\<^sub>R P C Cs \<Longrightarrow> is_subobj P ((C,Cs))"
by(erule Subobjs\<^sub>R.induct,simp,
  auto dest:hd_SubobjsR intro:build_rec_isSubobj)

lemma leq_SubobjsR_isSubobj:
  "\<lbrakk>P \<turnstile> C \<preceq>\<^sup>* C'; P \<turnstile> C' \<prec>\<^sub>S D; Subobjs\<^sub>R P D Cs\<rbrakk>
\<Longrightarrow> is_subobj P ((C,Cs))"

apply (subgoal_tac "is_subobj P ((C,[D]))")
 apply (frule hd_SubobjsR)
 apply (drule SubobjsR_isSubobj)
 apply (erule exE)
 apply (simp del: is_subobj.simps)
 apply (erule isSubobj_isSubobj_isSubobj)
 apply simp
apply auto
done

lemma Subobjs_isSubobj:
  "Subobjs P C Cs \<Longrightarrow> is_subobj P ((C,Cs))"
by (auto elim:Subobjs.induct SubobjsR_isSubobj
  simp add:leq_SubobjsR_isSubobj)

section {* Paths *}

subsection {* Appending paths *}

text{* Avoided name clash by calling one path Path. *}

definition path_via :: "prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> bool" ("_ \<turnstile> Path _ to _ via _ " [51,51,51,51] 50) where
  "P \<turnstile> Path C to D via Cs \<equiv> Subobjs P C Cs \<and> last Cs = D"

definition path_unique :: "prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool" ("_ \<turnstile> Path _ to _ unique" [51,51,51] 50) where
  "P \<turnstile> Path C to D unique \<equiv> \<exists>!Cs. Subobjs P C Cs \<and> last Cs = D"

definition appendPath :: "path \<Rightarrow> path \<Rightarrow> path" (infixr "@\<^sub>p" 65) where
  "Cs @\<^sub>p Cs' \<equiv> if (last Cs = hd Cs') then Cs @ (tl Cs') else Cs'"

lemma appendPath_last: "Cs \<noteq> [] \<Longrightarrow> last Cs = last (Cs'@\<^sub>pCs)"
by(auto simp:appendPath_def last_append)(cases Cs, simp_all)+

inductive
  casts_to :: "prog \<Rightarrow> ty \<Rightarrow> val \<Rightarrow> val \<Rightarrow> bool"
    ("_ \<turnstile> _ casts _ to _ " [51,51,51,51] 50)
  for P :: prog
where

  casts_prim: "\<forall>C. T \<noteq> Class C \<Longrightarrow> P \<turnstile> T casts v to v"

| casts_null: "P \<turnstile> Class C casts Null to Null"

| casts_ref: "\<lbrakk> P \<turnstile> Path last Cs to C via Cs'; Ds = Cs@\<^sub>pCs' \<rbrakk>
  \<Longrightarrow> P \<turnstile> Class C casts Ref(a,Cs) to Ref(a,Ds)"

inductive
  Casts_to :: "prog \<Rightarrow> ty list \<Rightarrow> val list \<Rightarrow> val list \<Rightarrow> bool"
    ("_ \<turnstile> _ Casts _ to _ " [51,51,51,51] 50)
  for P :: prog
where

  Casts_Nil: "P \<turnstile> [] Casts [] to []"

| Casts_Cons: "\<lbrakk> P \<turnstile> T casts v to v'; P \<turnstile> Ts Casts vs to vs' \<rbrakk>
  \<Longrightarrow> P \<turnstile> (T#Ts) Casts (v#vs) to (v'#vs')"

lemma length_Casts_vs:
  "P \<turnstile> Ts Casts vs to vs' \<Longrightarrow> length Ts = length vs"
by (induct rule:Casts_to.induct,simp_all)

lemma length_Casts_vs':
  "P \<turnstile> Ts Casts vs to vs' \<Longrightarrow> length Ts = length vs'"
by (induct rule:Casts_to.induct,simp_all)

subsection {* The relation on paths *}

inductive_set
  leq_path1 :: "prog \<Rightarrow> cname \<Rightarrow> (path \<times> path) set"
  and leq_path1' :: "prog \<Rightarrow> cname \<Rightarrow> [path, path] \<Rightarrow> bool" ("_,_ \<turnstile> _ \<sqsubset>\<^sup>1 _" [71,71,71] 70)
  for P :: prog and C :: cname
where
  "P,C \<turnstile> Cs \<sqsubset>\<^sup>1 Ds \<equiv> (Cs,Ds) \<in> leq_path1 P C"
| leq_pathRep: "\<lbrakk> Subobjs P C Cs; Subobjs P C Ds; Cs = butlast Ds\<rbrakk>
  \<Longrightarrow> P,C \<turnstile> Cs \<sqsubset>\<^sup>1 Ds"
| leq_pathSh:  "\<lbrakk> Subobjs P C Cs; P \<turnstile> last Cs \<prec>\<^sub>S D \<rbrakk>
  \<Longrightarrow> P,C \<turnstile> Cs \<sqsubset>\<^sup>1 [D]"

abbreviation
  leq_path :: "prog \<Rightarrow> cname \<Rightarrow> [path, path] \<Rightarrow> bool" ("_,_ \<turnstile> _ \<sqsubseteq> _"  [71,71,71] 70) where
  "P,C \<turnstile> Cs \<sqsubseteq> Ds \<equiv> (Cs,Ds) \<in> (leq_path1 P C)\<^sup>*"

lemma leq_path_rep:
  "\<lbrakk> Subobjs P C (Cs@[C']); Subobjs P C (Cs@[C',C''])\<rbrakk>
\<Longrightarrow> P,C \<turnstile> (Cs@[C']) \<sqsubset>\<^sup>1 (Cs@[C',C''])"
by(rule leq_pathRep,simp_all add:butlast_tail)

lemma leq_path_sh:
  "\<lbrakk> Subobjs P C (Cs@[C']); P \<turnstile> C' \<prec>\<^sub>S C''\<rbrakk>
\<Longrightarrow> P,C \<turnstile> (Cs@[C']) \<sqsubset>\<^sup>1 [C'']"
by(erule leq_pathSh)simp

section{* Member lookups *}

definition FieldDecls :: "prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> (path \<times> ty) set" where
  "FieldDecls P C F \<equiv>
   {(Cs,T). Subobjs P C Cs \<and> (\<exists>Bs fs ms. class P (last Cs) = Some(Bs,fs,ms)
                                    \<and> map_of fs F = Some T)}"

definition LeastFieldDecl  :: "prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has least _:_ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> C has least F:T via Cs \<equiv>
   (Cs,T) \<in> FieldDecls P C F \<and>
   (\<forall>(Cs',T') \<in> FieldDecls P C F. P,C \<turnstile> Cs \<sqsubseteq> Cs')"

definition MethodDefs :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> (path \<times> method)set" where
  "MethodDefs P C M \<equiv>
   {(Cs,mthd). Subobjs P C Cs \<and> (\<exists>Bs fs ms. class P (last Cs) = Some(Bs,fs,ms)
                                    \<and> map_of ms M = Some mthd)}"

  -- "needed for well formed criterion"
definition HasMethodDef :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has _ = _ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> C has M = mthd via Cs \<equiv> (Cs,mthd) \<in> MethodDefs P C M"

definition LeastMethodDef :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has least _ = _ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> C has least M = mthd via Cs \<equiv>
   (Cs,mthd) \<in> MethodDefs P C M \<and>
   (\<forall>(Cs',mthd') \<in> MethodDefs P C M. P,C \<turnstile> Cs \<sqsubseteq> Cs')"

definition MinimalMethodDefs :: "prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> (path \<times> method)set" where
  "MinimalMethodDefs P C M \<equiv>
      {(Cs,mthd). (Cs,mthd) \<in> MethodDefs P C M \<and>
         (\<forall>(Cs',mthd')\<in> MethodDefs P C M. P,C \<turnstile> Cs' \<sqsubseteq> Cs \<longrightarrow> Cs' = Cs)}"

definition OverriderMethodDefs :: "prog \<Rightarrow> subobj \<Rightarrow> mname \<Rightarrow> (path \<times> method)set" where
  "OverriderMethodDefs P R M \<equiv>
      {(Cs,mthd). \<exists>Cs' mthd'. P \<turnstile> (ldc R) has least M = mthd' via Cs' \<and>
                      (Cs,mthd) \<in> MinimalMethodDefs P (mdc R) M \<and>
                      P,mdc R \<turnstile> Cs \<sqsubseteq> (snd R)@\<^sub>pCs'}"

definition FinalOverriderMethodDef :: "prog \<Rightarrow> subobj \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
    ("_ \<turnstile> _ has overrider _ = _ via _" [51,0,0,0,51] 50) where
  "P \<turnstile> R has overrider M = mthd via Cs \<equiv>
      (Cs,mthd) \<in> OverriderMethodDefs P R M \<and>
      card(OverriderMethodDefs P R M) = 1"
      (*(\<forall>(Cs',mthd') \<in> OverriderMethodDefs P R M. Cs = Cs' \<and> mthd = mthd')"*)

inductive
  SelectMethodDef :: "prog \<Rightarrow> cname \<Rightarrow> path \<Rightarrow> mname \<Rightarrow> method \<Rightarrow> path \<Rightarrow> bool"
     ("_ \<turnstile> '(_,_') selects _ = _ via _" [51,0,0,0,0,51] 50)
  for P :: prog
where

  dyn_unique:
    "P \<turnstile> C has least M = mthd via Cs' \<Longrightarrow> P \<turnstile> (C,Cs) selects M = mthd via Cs'"

| dyn_ambiguous:
    "\<lbrakk>\<forall>mthd Cs'. \<not> P \<turnstile> C has least M = mthd via Cs';
      P \<turnstile> (C,Cs) has overrider M = mthd via Cs'\<rbrakk>
  \<Longrightarrow> P \<turnstile> (C,Cs) selects M = mthd via Cs'"

lemma sees_fields_fun:
  "(Cs,T) \<in> FieldDecls P C F \<Longrightarrow> (Cs,T') \<in> FieldDecls P C F \<Longrightarrow> T = T'"
by(fastforce simp:FieldDecls_def)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C has least F:T via Cs; P \<turnstile> C has least F:T' via Cs\<rbrakk>
  \<Longrightarrow> T = T'"
by (fastforce simp:LeastFieldDecl_def dest:sees_fields_fun)

lemma has_least_method_has_method:
  "P \<turnstile> C has least M = mthd via Cs \<Longrightarrow> P \<turnstile> C has M = mthd via Cs"
by (simp add:LeastMethodDef_def HasMethodDef_def)

lemma visible_methods_exist:
  "(Cs,mthd) \<in> MethodDefs P C M \<Longrightarrow>
  (\<exists>Bs fs ms. class P (last Cs) = Some(Bs,fs,ms) \<and> map_of ms M = Some mthd)"
by(auto simp:MethodDefs_def)

lemma sees_methods_fun:
  "(Cs,mthd) \<in> MethodDefs P C M \<Longrightarrow> (Cs,mthd') \<in> MethodDefs P C M \<Longrightarrow> mthd = mthd'"
by(fastforce simp:MethodDefs_def)

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C has least M = mthd via Cs; P \<turnstile> C has least M = mthd' via Cs\<rbrakk>
  \<Longrightarrow> mthd = mthd'"
by (fastforce simp:LeastMethodDef_def dest:sees_methods_fun)

lemma overrider_method_fun:
assumes overrider:"P \<turnstile> (C,Cs) has overrider M = mthd via Cs'"
  and overrider':"P \<turnstile> (C,Cs) has overrider M = mthd' via Cs''"
shows "mthd = mthd' \<and> Cs' = Cs''"
proof -
  from overrider' have omd:"(Cs'',mthd') \<in> OverriderMethodDefs P (C,Cs) M"
    by(simp_all add:FinalOverriderMethodDef_def)
  from overrider have "(Cs',mthd) \<in> OverriderMethodDefs P (C,Cs) M"
    and "card(OverriderMethodDefs P (C,Cs) M) = 1"
    by(simp_all add:FinalOverriderMethodDef_def)
  hence "\<forall>(Ds,mthd'') \<in> OverriderMethodDefs P (C,Cs) M. (Cs',mthd) = (Ds,mthd'')"
    by(fastforce simp:card_Suc_eq)
  with omd show ?thesis by fastforce
qed

end


theory Denotational
  imports "Abstract-Denotational-Props" "Value-Nominal"
begin

text {*
This is the actual denotational semantics as found in \cite{launchbury}.
*}

interpretation semantic_domain Fn Fn_project "\<Lambda> x. x".

abbreviation ESem_syn'' ("\<lbrakk> _ \<rbrakk>\<^bsub>_\<^esub>"  [60,60] 60) where "\<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> \<equiv> ESem e \<cdot> \<rho>"
abbreviation EvalHeapSem_syn''  ("\<^bold>\<lbrakk> _ \<^bold>\<rbrakk>\<^bsub>_\<^esub>"  [0,0] 110)  where "\<^bold>\<lbrakk>\<Gamma>\<^bold>\<rbrakk>\<^bsub>\<rho>\<^esub> \<equiv> evalHeap \<Gamma> (\<lambda> e. \<lbrakk>e\<rbrakk>\<^bsub>\<rho>\<^esub>)"
abbreviation HSem_syn' ("\<lbrace>_\<rbrace>_"  [60,60] 60) where "\<lbrace>\<Gamma>\<rbrace>\<rho> \<equiv> HSem \<Gamma> \<cdot> \<rho>"
abbreviation HSem_bot  ("\<lbrace>_\<rbrace>"  [60] 60) where "\<lbrace>\<Gamma>\<rbrace> \<equiv> \<lbrace>\<Gamma>\<rbrace>\<bottom>"

lemma ESem_simps_as_defined:
  "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> =  Fn\<cdot>(\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>(\<rho> f|` (fv (Lam [x].e)))(x := v)\<^esub>)"
  "\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>    =  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> \<down>Fn \<rho> x"
  "\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>      =  \<rho>  x"
  "\<lbrakk> Let as body \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>(\<rho> f|` fv (Let as body))\<^esub>"
  by (simp_all del: ESem_Lam ESem_Let add: ESem.simps(1,4) )

lemma ESem_simps:
  "\<lbrakk> Lam [x]. e \<rbrakk>\<^bsub>\<rho>\<^esub> =  Fn\<cdot>(\<Lambda> v. \<lbrakk> e \<rbrakk>\<^bsub>\<rho>(x := v)\<^esub>)"
  "\<lbrakk> App e x \<rbrakk>\<^bsub>\<rho>\<^esub>    =  \<lbrakk> e \<rbrakk>\<^bsub>\<rho>\<^esub> \<down>Fn \<rho> x"
  "\<lbrakk> Var x \<rbrakk>\<^bsub>\<rho>\<^esub>      =  \<rho>  x"
  "\<lbrakk> Let as body \<rbrakk>\<^bsub>\<rho>\<^esub> = \<lbrakk>body\<rbrakk>\<^bsub>\<lbrace>as\<rbrace>\<rho>\<^esub>"
  by simp_all
(*<*)

text {*
Excluded from the document, as these are unused in the current development.
*}

subsubsection {* Replacing subexpressions by variables *}

lemma HSem_subst_var_app:
  assumes fresh: "atom n \<sharp> x"
  shows "\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho> = \<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho> "
proof(rule HSem_subst_expr)
  from fresh have [simp]: "n \<noteq> x" by (simp add: fresh_at_base)
  have ne: "(n,e) \<in> set ((x, App e y) # (n, e) # \<Gamma>)" by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> App (Var n) y \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> App e y \<rbrakk>\<^bsub>\<lbrace>(x, App e y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp

 have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> App e y \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> App (Var n) y \<rbrakk>\<^bsub>\<lbrace>(x, App (Var n) y) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp
qed

lemma HSem_subst_var_var:
  assumes fresh: "atom n \<sharp> x"
  shows "\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho> = \<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho> "
proof(rule HSem_subst_expr)
  from fresh have [simp]: "n \<noteq> x" by (simp add: fresh_at_base)
  have ne: "(n,e) \<in> set ((x, e) # (n, e) # \<Gamma>)" by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, e) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp

  have "\<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> = (\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>) n"
    by simp
  also have "... = \<lbrakk> e \<rbrakk>\<^bsub>(\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>)\<^esub>"
    by (subst HSem_eq, simp)
  finally
  show "\<lbrakk> e \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub> \<sqsubseteq> \<lbrakk> Var n \<rbrakk>\<^bsub>\<lbrace>(x, Var n) # (n, e) # \<Gamma>\<rbrace>\<rho>\<^esub>"
    by simp
qed
(*>*)

end


(*<*) theory Failure imports RealRandVar begin (*>*)

text{*
Defining Lebesgue integration can be quite involved, judging by the
process in \ref{sec:stepwise-approach} that imitates Bauer's way
\cite{Bauer}.  So it is quite tempting to try cutting a corner. The
following two alternative approaches back up my experience that this
almost never pays in formalization. The theory that seems most complex
at first sight is often the one that is closest to formal reasoning
and deliberately avoids ``hand-waving''.

\subsection{A closed expression}
\label{sec:closed-expression}

  In contrast, Billingsley's definition \cite[p.~172]{Billingsley86} is
  strikingly short. For nonnegative measurable functions $f$:

  \begin{quote}

  $\int f d\mu = \mathit{sup} \sum_i \big[ \mathit{inf}_{\omega \in A_i} f(w) \big] \mu(A_i).$

  The supremum here extends over all finite decompositions $\{A_i\}$ of
  $\Omega$ into $\mathcal{F}$-sets.\footnote{The $\mathcal{F}$-sets are just the measurable sets of a measure
  space.}

  \end{quote}

  Like the definition, the proofs of the essential properties are also
  rather
  short, about three pages in the textbook for almost all the theorems
  in \ref{sec:stepwise-approach}; and a proof of uniqueness is obsolete
  for a closed expression like this. Therefore, I found this approach
  quite tempting. It turns out, however, that it is unfortunately not
  well suited for formalization, at least with the background we use.

  A complication shared by all possible styles of definition is the lack
  of infinite values in our theory, combined with the lack of partial
  functions in HOL. Like the sum operator in
  \ref{sec:measure-spaces}, the integral has to be defined
  indirectly. The classical way to do this employs predicates, invoking @{text \<epsilon>}
  to choose the value that satisfies the condition:

  @{text "\<integral> f dM \<equiv> (\<epsilon> i. is_integral M f i)"}

  To sensibly apply this principle, the predicate has to be @{text
  \<epsilon>}-free to supply the information if the integral is
  defined or not. Now the above definition contains up to three additional
  @{text \<epsilon>} when formalized naively in HOL, namely in the supremum,
  infimum and sum operators. The sum is over a finite set, so it can
  be replaced by a total function. For nonnegative functions, the
  infimum can also be shown to exist everywhere, but, like the
  supremum,  must
  itself be replaced by a predicate.

  Also note that predicates require a proof of uniqueness, thus losing
  the prime advantage of a closed formula anyway. In this case,
  uniqueness can be reduced to uniqueness of the supremum/infimum. The
  problem is that neither suprema nor infima come predefined in
  Isabelle/Isar as of yet. It is an easy task to make up for this ---
  and I did --- but a much harder one to establish all the properties
  needed for reasoning with the defined entities.

  A lot of such reasoning is necessary to deduce from the above definition
  (or a formal version of it, as just outlined) the basic behavior of
  integration, which includes additivity, monotonicity and especially the
  integral of simple functions. It turns out that the brevity of the
  proofs in the textbook stems from a severely informal style that
  assumes ample background knowledge. Formalizing all this knowledge
  started to become overwhelming when the idea of a contrarian approach
  emerged.

  \subsection{A one-step inductive definition}
  \label{sec:one-step}

  This idea was sparked by the following note: ``(\ldots) the integral
  is uniquely determined by certain simple properties it is natural to
  require of it'' \cite[p.~175]{Billingsley86}. Billingsley goes on
  discussing exactly those properties that are so hard to derive
  from his definition. So why not simply define integration using
  these properties? That is the gist of an inductive set definition, like
  the one we have seen in \ref{sec:sigma}. This time a functional operator is
  to be defined, but it can be represented as a set of pairs, where
  the first component is the function and the second its integral.
  To cut a long story short, here is the definition. *}

inductive_set
  integral_set:: "('a set set * ('a set \<Rightarrow> real)) \<Rightarrow> (('a \<Rightarrow> real) * real) set"
  for M :: "'a set set * ('a set \<Rightarrow> real)"
  where
    char: "\<lbrakk>f = \<chi> A; A \<in> measurable_sets M\<rbrakk> \<Longrightarrow> (f,measure M A) \<in> integral_set M"
  | add: "\<lbrakk>f = (\<lambda>w. g w + h w); (g,x) \<in> integral_set M; (h,y) \<in> integral_set M\<rbrakk>
    \<Longrightarrow> (f,(x + y)) \<in> integral_set M"
  | times: "\<lbrakk>f = (\<lambda>w. a*g w); (g,x) \<in> integral_set M\<rbrakk> \<Longrightarrow> (f,a*x) \<in> integral_set M"
  | mon_conv: "\<lbrakk>u\<up>f; \<And>n. (u n, x n) \<in> integral_set M; x\<up>y\<rbrakk>
    \<Longrightarrow> (f,y) \<in> integral_set M"

  text {*The technique is also encountered in the @{text
    "Finite_Set"} theory from the Isabelle library. It is used there
    to define the @{text setsum} function, which calculates a sum
    indexed over a finite set and is employed in
    \ref{sec:stepwise-approach}. The definition here is much more
    intricate though.

    An obvious advantage of this approach is that almost all
    important properties are gained without effort. The
    introduction rule @{text mon_conv} corresponds to what is known as
    the Monotone Convergence Theorem in scientific literature; negative functions are also provided for via
    the @{text times} rule.
    To be precise,
    there is exactly one important theorem missing ---
    uniqueness. That is, every function appears in at most one pair.

    From uniqueness together with the introduction rules, all the
    other statements about integration, monotonicity for example,
    could be derived. On the other hand, monotonicity implies
    uniqueness. Much to my regret, none of these two could be proven.
    The proof would basically amount to a double induction to show
    that an integral gained via one rule is the same when derived by
    another. A lot of effort was spent trying to strengthen the
    induction hypothesis or reduce the goal to a simpler case. All of
    this was in vain though, and it seems that the hypothesis would
    have to be strengthened as far as to include the concept of
    integration in the first place, which in a way defeats the
    advantages of the approach. *}

  (*<*)end  (*>*)


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Tobias Nipkow, Gerwin Klein
    Copyright   2000 TUM
*)

header {* \isaheader{LBV for the JVM}\label{sec:JVM} *}

theory LBVJVM
imports
  "../DFA/Abstract_BV"
  TF_JVM
begin

type_synonym prog_cert = "cname \<Rightarrow> mname \<Rightarrow> ty\<^sub>i' err list"

definition check_cert :: "'addr jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> bool"
where
  "check_cert P mxs mxl n cert \<equiv> check_types P mxs mxl cert \<and> size cert = n+1 \<and>
                                 (\<forall>i<n. cert!i \<noteq> Err) \<and> cert!n = OK None"

definition lbvjvm :: "'addr jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow>
             ty\<^sub>i' err list \<Rightarrow> 'addr instr list \<Rightarrow> ty\<^sub>i' err \<Rightarrow> ty\<^sub>i' err"
where
  "lbvjvm P mxs maxr T\<^sub>r et cert bs \<equiv>
  wtl_inst_list bs cert (JVM_SemiType.sup P mxs maxr) (JVM_SemiType.le P mxs maxr) Err (OK None) (exec P mxs T\<^sub>r et bs) 0"

definition wt_lbv :: "'addr jvm_prog \<Rightarrow> cname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>
             ex_table \<Rightarrow> ty\<^sub>i' err list \<Rightarrow> 'addr instr list \<Rightarrow> bool"
where
  "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 et cert ins \<equiv>
   check_cert P mxs (1+size Ts+mxl\<^sub>0) (size ins) cert \<and>
   0 < size ins \<and>
   (let start  = Some ([],(OK (Class C))#((map OK Ts))@(replicate mxl\<^sub>0 Err));
        result = lbvjvm P mxs (1+size Ts+mxl\<^sub>0) T\<^sub>r et cert ins (OK start)
    in result \<noteq> Err)"

definition wt_jvm_prog_lbv :: "'addr jvm_prog \<Rightarrow> prog_cert \<Rightarrow> bool"
where
  "wt_jvm_prog_lbv P cert \<equiv>
  wf_prog (\<lambda>P C (mn,Ts,T\<^sub>r,(mxs,mxl\<^sub>0,b,et)). wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 et (cert C mn) b) P"

definition mk_cert :: "'addr jvm_prog \<Rightarrow> nat \<Rightarrow> ty \<Rightarrow> ex_table \<Rightarrow> 'addr instr list
              \<Rightarrow> ty\<^sub>m \<Rightarrow> ty\<^sub>i' err list"
where
  "mk_cert P mxs T\<^sub>r et bs phi \<equiv> make_cert (exec P mxs T\<^sub>r et bs) (map OK phi) (OK None)"

definition prg_cert :: "'addr jvm_prog \<Rightarrow> ty\<^sub>P \<Rightarrow> prog_cert"
where
  "prg_cert P phi C mn \<equiv> let (C,Ts,T\<^sub>r,meth) = method P C mn; (mxs,mxl\<^sub>0,ins,et) = the meth
                         in  mk_cert P mxs T\<^sub>r et ins (phi C mn)"

lemma check_certD [intro?]:
  "check_cert P mxs mxl n cert \<Longrightarrow> cert_ok cert n Err (OK None) (states P mxs mxl)"
  by (unfold cert_ok_def check_cert_def check_types_def) auto

lemma (in start_context) wt_lbv_wt_step:
  assumes lbv: "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
  shows "\<exists>\<tau>s \<in> list (size is) A. wt_step r Err step \<tau>s \<and> OK first \<sqsubseteq>\<^sub>r \<tau>s!0"
(*<*)
proof -
  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err \<in> A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)"
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None \<in> A" by (simp add: JVM_states_unfold)
  moreover note bounded_step
  moreover from lbv have "cert_ok cert (size is) Err (OK None) A"
    by (unfold wt_lbv_def) (auto dest: check_certD)
  moreover note exec_pres_type
  moreover
  from lbv
  have "wtl_inst_list is cert f r Err (OK None) step 0 (OK first) \<noteq> Err"
    by (simp add: wt_lbv_def lbvjvm_def step_def_exec [symmetric])
  moreover note first_in_A
  moreover from lbv have "0 < size is" by (simp add: wt_lbv_def)
  ultimately show ?thesis by (rule lbvs.wtl_sound_strong [OF lbvs.intro, OF lbv.intro lbvs_axioms.intro, OF Semilat.intro lbv_axioms.intro])
qed
(*>*)

lemma (in start_context) wt_lbv_wt_method:
  assumes lbv: "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
  shows "\<exists>\<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
(*<*)
proof -
  from lbv have l: "is \<noteq> []" by (simp add: wt_lbv_def)
  moreover
  from wf lbv C Ts obtain \<tau>s where
    list:  "\<tau>s \<in> list (size is) A" and
    step:  "wt_step r Err step \<tau>s" and
    start: "OK first \<sqsubseteq>\<^sub>r \<tau>s!0"
    by (blast dest: wt_lbv_wt_step)
  from list have [simp]: "size \<tau>s = size is" by simp
  have "size (map ok_val \<tau>s) = size is" by simp
  moreover from l have 0: "0 < size \<tau>s" by simp
  with step obtain \<tau>s0 where "\<tau>s!0 = OK \<tau>s0"
    by (unfold wt_step_def) blast
  with start 0 have "wt_start P C Ts mxl\<^sub>0 (map ok_val \<tau>s)"
    by (simp add: wt_start_def JVM_le_Err_conv lesub_def Err.le_def)
  moreover {
    from list have "check_types P mxs mxl \<tau>s" by (simp add: check_types_def)
    also from step  have "\<forall>x \<in> set \<tau>s. x \<noteq> Err"
      by (auto simp add: all_set_conv_all_nth wt_step_def)
    hence [symmetric]: "map OK (map ok_val \<tau>s) = \<tau>s"
      by (auto intro!: map_idI)
    finally have "check_types P mxs mxl (map OK (map ok_val \<tau>s))" .
  }
  moreover {
    note bounded_step
    moreover from list have "set \<tau>s \<subseteq> A" by simp
    moreover from step have "wt_err_step (sup_state_opt P) step \<tau>s"
      by (simp add: wt_err_step_def JVM_le_Err_conv)
    ultimately have "wt_app_eff (sup_state_opt P) app eff (map ok_val \<tau>s)"
      by (auto intro: wt_err_imp_wt_app_eff simp add: exec_def states_def)
  }
  ultimately have "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt (map ok_val \<tau>s)"
    by (simp add: wt_method_def2 check_types_def del: map_map)
  thus ?thesis ..
qed
(*>*)

lemma (in start_context) wt_method_wt_lbv:
  assumes wt: "wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"
  defines [simp]: "cert \<equiv> mk_cert P mxs T\<^sub>r xt is \<tau>s"

  shows "wt_lbv P C Ts T\<^sub>r mxs mxl\<^sub>0 xt cert is"
(*<*)
proof -
  let ?\<tau>s  = "map OK \<tau>s"
  let ?cert = "make_cert step ?\<tau>s (OK None)"

  from wt obtain
    0:        "0 < size is" and
    size:     "size is = size ?\<tau>s" and
    ck_types: "check_types P mxs mxl ?\<tau>s" and
    wt_start: "wt_start P C Ts mxl\<^sub>0 \<tau>s" and
    app_eff:  "wt_app_eff (sup_state_opt P) app eff \<tau>s"
    by (force simp add: wt_method_def2 check_types_def)

  from wf have "semilat (JVM_SemiType.sl P mxs mxl)" ..
  hence "semilat (A, r, f)" by (simp add: sl_def2)
  moreover have "top r Err" by (simp add: JVM_le_Err_conv)
  moreover have "Err \<in> A" by (simp add: JVM_states_unfold)
  moreover have "bottom r (OK None)"
    by (simp add: JVM_le_Err_conv bottom_def lesub_def Err.le_def split: err.split)
  moreover have "OK None \<in> A" by (simp add: JVM_states_unfold)
  moreover from wf have "mono r step (size is) A" by (rule step_mono)
  hence "mono r step (size ?\<tau>s) A" by (simp add: size)
  moreover from exec_pres_type
  have "pres_type step (size ?\<tau>s) A" by (simp add: size)
  moreover
  from ck_types have \<tau>s_in_A: "set ?\<tau>s \<subseteq> A" by (simp add: check_types_def)
  hence "\<forall>pc. pc < size ?\<tau>s \<longrightarrow> ?\<tau>s!pc \<in> A \<and> ?\<tau>s!pc \<noteq> Err" by auto
  moreover from bounded_step
  have "bounded step (size ?\<tau>s)" by (simp add: size)
  moreover have "OK None \<noteq> Err" by simp
  moreover from bounded_step size \<tau>s_in_A app_eff
  have "wt_err_step (sup_state_opt P) step ?\<tau>s"
    by (auto intro: wt_app_eff_imp_wt_err simp add: exec_def states_def)
  hence "wt_step r Err step ?\<tau>s"
    by (simp add: wt_err_step_def JVM_le_Err_conv)
  moreover
  from 0 size have "0 < size \<tau>s" by auto
  hence "?\<tau>s!0 = OK (\<tau>s!0)" by simp
  with wt_start have "OK first \<sqsubseteq>\<^sub>r ?\<tau>s!0"
    by (clarsimp simp add: wt_start_def lesub_def Err.le_def JVM_le_Err_conv)
  moreover note first_in_A
  moreover have "OK first \<noteq> Err" by simp
  moreover note size
  ultimately
  have "wtl_inst_list is ?cert f r Err (OK None) step 0 (OK first) \<noteq> Err"
    by (rule lbvc.wtl_complete [OF lbvc.intro, OF lbv.intro lbvc_axioms.intro, OF Semilat.intro lbv_axioms.intro])
  moreover from 0 size have "\<tau>s \<noteq> []" by auto
  moreover from ck_types have "check_types P mxs mxl ?cert"
    by (auto simp add: make_cert_def check_types_def JVM_states_unfold)
  moreover note 0 size
  ultimately show ?thesis
    by (simp add: wt_lbv_def lbvjvm_def mk_cert_def step_def_exec [symmetric]
                  check_cert_def make_cert_def nth_append)
qed
(*>*)

theorem jvm_lbv_correct:
  "wt_jvm_prog_lbv P Cert \<Longrightarrow> wf_jvm_prog P"
(*<*)
proof -
  let ?\<Phi> = "\<lambda>C mn. let (C,Ts,T\<^sub>r,meth) = method P C mn; (mxs,mxl\<^sub>0,is,xt) = the meth in
              SOME \<tau>s. wt_method P C Ts T\<^sub>r mxs mxl\<^sub>0 is xt \<tau>s"

  assume wt: "wt_jvm_prog_lbv P Cert"
  hence "wf_jvm_prog\<^bsub>?\<Phi>\<^esub> P"
    apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
    apply (erule wf_prog_lift)
    apply(auto intro: someI_ex[OF start_context.wt_lbv_wt_method [OF start_context.intro]])
    done
  thus ?thesis by (unfold wf_jvm_prog_def) blast
qed
(*>*)

theorem jvm_lbv_complete:
  assumes wt: "wf_jvm_prog\<^bsub>\<Phi>\<^esub> P"
  shows "wt_jvm_prog_lbv P (prg_cert P \<Phi>)"
(*<*)
  using wt
  apply (unfold wf_jvm_prog_phi_def wt_jvm_prog_lbv_def)
  apply (erule wf_prog_lift)
  apply (auto simp add: prg_cert_def
              intro!: start_context.wt_method_wt_lbv start_context.intro)
  done
(*>*)

end


theory EventSystemWatchdog
  imports EventSystemExBase
begin

subsection \<open>Implementations of basic operations\<close>

definition get_chain_pos :: "nat \<Rightarrow> (watchdog_chain, event, nat) event_monad" where
  "get_chain_pos i = (
     get \<bind>
     (\<lambda>st. return (snd (st ! i))))"

theorem get_chain_pos_rule [wp]:
  "\<lbrace> \<lambda>s e. Q (snd (s ! i)) s e \<rbrace>
    get_chain_pos i
   \<lbrace> Q \<rbrace>!"
  unfolding get_chain_pos_def by wp

definition get_chain_pos_id :: "nat \<Rightarrow> (watchdog_chain, event, task_id) event_monad" where
  "get_chain_pos_id i = (
     get \<bind>
     (\<lambda>st. return (fst (st ! i))))"

theorem get_chain_pos_id_rule [wp]:
  "\<lbrace> \<lambda>s e. Q (fst (s ! i)) s e \<rbrace>
    get_chain_pos_id i
   \<lbrace> Q \<rbrace>!"
  unfolding get_chain_pos_id_def by wp

definition get_chain_length :: "(watchdog_chain, event, nat) event_monad" where
  "get_chain_length = (
     get \<bind>
     (\<lambda>st. return (length st)))"

theorem get_chain_length_rule [wp]:
  "\<lbrace> \<lambda>s e. Q (length s) s e \<rbrace>
     get_chain_length
   \<lbrace> Q \<rbrace>!"
  unfolding get_chain_length_def by wp

definition set_chain_pos :: "nat \<Rightarrow> nat \<Rightarrow> (watchdog_chain, event, unit) event_monad" where
  "set_chain_pos i k = (
     modify (\<lambda>es. es[i := (fst (es ! i), k)]))"

theorem set_chain_pos_rule [wp]:
  "\<lbrace> \<lambda>s e. Q () (s[i := (fst (s ! i), k)]) e \<rbrace>
    set_chain_pos i k
   \<lbrace> Q \<rbrace>!"
  unfolding set_chain_pos_def by wp

definition insert_chain_pos :: "nat \<Rightarrow> task_id \<Rightarrow> nat \<Rightarrow> (watchdog_chain, event, unit) event_monad" where
  "insert_chain_pos i evt_id n = (
    modify (\<lambda>es. (take i es) @ [(evt_id, n)] @ drop i es))"

theorem insert_chain_pos_rule [wp]:
  "\<lbrace> \<lambda>s e. Q () (take i s @ [(evt_id, n)] @ drop i s) e \<rbrace>
    insert_chain_pos i evt_id n
   \<lbrace> Q \<rbrace>!"
  unfolding insert_chain_pos_def by wp

definition remove_first :: "(watchdog_chain, event, unit) event_monad" where
  "remove_first = modify (\<lambda>es. tl es)"

theorem remove_first_rule [wp]:
  "\<lbrace> \<lambda>s e. Q () (tl s) e \<rbrace>
     remove_first
   \<lbrace> Q \<rbrace>!"
  unfolding remove_first_def by wp

subsection \<open>Imperative version of watchdog_add\<close>

text \<open>
  While loop keeps track of current position in the list and remaining ticks.
\<close>
definition watchdog_add_impl' :: "task_id \<Rightarrow> nat \<Rightarrow> (watchdog_chain, event, nat \<times> nat) event_monad" where
  "watchdog_add_impl' evt_id n = whileLoop (\<lambda>r s. snd r > 0) (\<lambda>r.
     get_chain_length \<bind> (\<lambda>len.
     if fst r \<ge> len then
       insert_chain_pos (fst r) evt_id (snd r) \<bind> (\<lambda>_.
       return (fst r + 1, 0))   \<comment> \<open>Add at end\<close>
     else
       get_chain_pos (fst r) \<bind> (\<lambda>w.
       (if snd r > w then
          return (fst r + 1, snd r - w)  \<comment> \<open>Add at later iteration\<close>
        else
          set_chain_pos (fst r) (w - snd r) \<bind> (\<lambda>_.
          insert_chain_pos (fst r) evt_id (snd r) \<bind> (\<lambda>_.
          return (fst r + 1, 0))))))) (0, n)"  \<comment> \<open>Add at current iteration\<close>

definition watchdog_add_impl :: "task_id \<Rightarrow> nat \<Rightarrow> (watchdog_chain, event, unit) event_monad" where
  "watchdog_add_impl evt_id n = (watchdog_add_impl' evt_id n) \<bind> (\<lambda>_. return ())"

text \<open>Functional array implementation of watchdog_add.

  The parameters are:
  evt_id - ID of event to be added
  n - initial amount of ticks
  s - current state of watchdog chain
  i - number of iterations of execute

  Returns pair of remaining amount of ticks and state of watchdog chain after i iterations
\<close>
fun watchdog_add_fun :: "task_id \<Rightarrow> nat \<Rightarrow> watchdog_chain \<Rightarrow> nat \<Rightarrow> nat \<times> watchdog_chain" where
  "watchdog_add_fun evt_id n s 0 = (n, s)"
| "watchdog_add_fun evt_id n s (Suc i) = (
    let (n', s') = watchdog_add_fun evt_id n s i in
      if n' = 0 then
        (n', s')  \<comment> \<open>Imperative code should have terminated\<close>
      else if i \<ge> length s' then
        (0, s' @ [(evt_id, n')])  \<comment> \<open>Add at the end\<close>
      else if n' > snd (s' ! i) then
        (n' - snd (s' ! i), s')  \<comment> \<open>Add at later iteration\<close>
      else
        (0, take i s' @ [(evt_id, n')] @ drop i (s'[i := (fst (s' ! i), snd (s' ! i) - n')])))"  \<comment> \<open>Add at current iteration\<close>

lemma watchdog_add_fun_correct:
  "(n > watchdog_total_upto s i \<longrightarrow> i \<le> length s \<longrightarrow>
     watchdog_add_fun evt_id n s i = (n - watchdog_total_upto s i, s)) \<and>  \<comment> \<open>not inserting at step i\<close>
   (n > watchdog_total_upto s (length s) \<longrightarrow> i = Suc (length s) \<longrightarrow>
     watchdog_add_fun evt_id n s i = (0, s @ [(evt_id, n - watchdog_total_upto s (length s))])) \<and>  \<comment> \<open>inserting at the end\<close>
   (n > 0 \<longrightarrow> n \<le> watchdog_total_upto s i \<longrightarrow> i \<le> length s \<longrightarrow> i = Suc (watchdog_add_pos s n) \<longrightarrow>
     watchdog_add_fun evt_id n s i = (0,
       take (i - 1) s @ [(evt_id, n - watchdog_total_upto s (i - 1))] @
       drop (i - 1) (s[i - 1 := (fst (s ! (i - 1)), snd (s ! (i - 1)) - (n - watchdog_total_upto s (i - 1)))])))"  \<comment> \<open>inserting at middle\<close>
proof (induct i arbitrary: n s)
  case 0
  then show ?case by auto
next
  case (Suc i)
  have s1: "watchdog_add_fun evt_id n s (Suc i) = (n - watchdog_total_upto s (Suc i), s)"
    if "n > watchdog_total_upto s (Suc i)" "Suc i \<le> length s"
  proof -
    let ?n' = "fst (watchdog_add_fun evt_id n s i)"
    let ?s' = "snd (watchdog_add_fun evt_id n s i)"
    have a1: "n > watchdog_total_upto s i"
      using that by (auto simp add: watchdog_total_upto_Suc)
    have a2: "?n' = n - watchdog_total_upto s i"
      using Suc a1 that(2) by auto
    have a3: "?n' \<noteq> 0"
      using a1 a2 by auto
    have a4: "?s' = s"
      using a1 Suc that(2) by auto
    have a5: "\<not>i \<ge> length ?s'"
      using a4 that(2) by auto
    have a6: "?n' > snd (?s' ! i)"
      using that(1) a2 a4 a5 by (auto simp add: watchdog_total_upto_Suc)
    show ?thesis
      apply (auto simp add: a3 a5 a6 case_prod_beta)
      using a5
      unfolding a2 a4
      by (auto simp add: watchdog_total_upto_Suc)
  qed
  have s2: "watchdog_add_fun evt_id n s (Suc i) = (0, s @ [(evt_id, n - watchdog_total_upto s (length s))])"
    if "n > watchdog_total_upto s (length s)" "Suc i = Suc (length s)"
  proof -
    let ?n' = "fst (watchdog_add_fun evt_id n s i)"
    let ?s' = "snd (watchdog_add_fun evt_id n s i)"
    have a1: "n > watchdog_total_upto s i"
      using that by auto
    have a2: "i \<le> length s \<longrightarrow> ?n' = n - watchdog_total_upto s i"
      using a1 Suc by auto
    have a3: "i \<le> length s \<longrightarrow> ?s' = s"
      using a1 Suc by auto
    show ?thesis
    proof (cases "?n' = 0")
      case True
      have b1: "i > length s"
        using a1 a2 True by auto
      show ?thesis
        using b1 that(2) by auto
    next
      case False
      have b1: "?s' = s"
        using a3 that(2) by auto
      have b2: "i \<ge> length ?s'"
        using b1 that(2) by auto
      have b3: "?n' = n - watchdog_total_upto s i"
        using that(2) a2 by auto
      show ?thesis
        apply (auto simp add: case_prod_beta \<open>?n' \<noteq> 0\<close> b2)
        unfolding b3 b1 using that(2) by auto
    qed
  qed
  have s3: "watchdog_add_fun evt_id n s (Suc i) = (0,
              take i s @ [(evt_id, n - watchdog_total_upto s i)] @
              drop i (s[i := (fst (s ! i), snd (s ! i) - (n - watchdog_total_upto s i))]))"
    if assum_s3: "n > 0" "n \<le> watchdog_total_upto s (Suc i)" "Suc i \<le> length s"
                 "Suc i = Suc (watchdog_add_pos s n)"
  proof -
    let ?n' = "fst (watchdog_add_fun evt_id n s i)"
    let ?s' = "snd (watchdog_add_fun evt_id n s i)"
    have "i = watchdog_add_pos s n"
      using assum_s3(4) by auto
    then have "i \<le> length s"
      using watchdog_add_pos_prop1 by auto
    have a1a: "watchdog_total_upto s i < n"
      by (metis (full_types) Suc_inject le_neq_implies_less that(1) that(4)
             watchdog_add_pos_prop1 watchdog_add_pos_prop2 watchdog_add_pos_prop3)
    have a1b: "i < length s"
      using that(3) by auto
    have a2: "?n' = n - watchdog_total_upto s i"
      using a1a a1b Suc by auto
    have a3: "?s' = s"
      using a1a a1b Suc by auto
    have a4: "?n' \<noteq> 0"
      using a2 a1a by auto
    have a5: "\<not>i \<ge> length ?s'"
      using a3 a1b by auto
    have a6: "\<not>?n' > snd (?s' ! i)"
      unfolding a2 a3 using assum_s3(2) a3 a5
      by (auto simp add: watchdog_total_upto_Suc)
    show ?thesis
      apply (auto simp add: case_prod_beta a4 a5 a6)
      unfolding a2 a3 by auto
  qed
  show ?case
    using s1 s2 s3 by auto
qed

lemma watchdog_add_fun_prop1:
  assumes "n > 0"
    and "i = Suc (watchdog_add_pos s0 n)"
  shows "fst (watchdog_add_fun evt_id n s0 i) = 0"
proof -
  have a1: "(n > watchdog_total_upto s0 (length s0) \<and> i = Suc (length s0)) \<or>
        (n \<le> watchdog_total_upto s0 i \<and> i \<le> length s0)"
    using watchdog_add_fun_range2 assms(1-2) by auto
  have a2: ?thesis
    if "n > watchdog_total_upto s0 (length s0)" "i = Suc (length s0)"
    using watchdog_add_fun_correct[of s0 i n evt_id] that by auto
  have a3: ?thesis
    if "n \<le> watchdog_total_upto s0 i" "i \<le> length s0"
    using watchdog_add_fun_correct[of s0 i n evt_id] assms(1,2) that by auto
  show ?thesis
    using a1 a2 a3 by auto
qed

lemma watchdog_add_fun_prop2:
  assumes "n > 0"
    and "i < Suc (watchdog_add_pos s0 n)"
  shows "fst (watchdog_add_fun evt_id n s0 i) > 0"
proof -
  have a1: "watchdog_total_upto s0 i < n \<and> i \<le> length s0"
    using watchdog_add_fun_range assms by auto
  then have a2: "watchdog_add_fun evt_id n s0 i = (n - watchdog_total_upto s0 i, s0)"
    using watchdog_add_fun_correct by auto
  show ?thesis
    using a1 a2 by auto
qed

lemma watchdog_add_impl_rule':
  assumes "n > 0"
  shows
    "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
      watchdog_add_impl' evt_id n
     \<lbrace> \<lambda>r s es. fst r = Suc (watchdog_add_pos s0 n) \<and> s = snd (watchdog_add_fun evt_id n s0 (fst r)) \<and> es = e0 \<rbrace>!"
  unfolding watchdog_add_impl'_def
  apply (rule validNF_whileLoop[where I="\<lambda>r s e. watchdog_add_fun evt_id n s0 (fst r) = (snd r, s) \<and>
                                                 fst r \<le> Suc (watchdog_add_pos s0 n) \<and> e = e0" and
                                      R="measure (\<lambda>(r,s). Suc (watchdog_add_pos s0 n) - fst r)"])
  subgoal for s es
    by auto
  subgoal for r s0'
    apply wp
    apply auto
    using assms watchdog_add_fun_prop1[of n "fst r" s0 evt_id]
     apply fastforce
    by (metis assms diff_less_mono fst_conv le_SucE lessI neq0_conv watchdog_add_fun_prop1)
  subgoal
    by (rule wf_measure)
  subgoal for r s es
    apply auto
    by (metis assms fst_conv le_neq_implies_less less_numeral_extra(3) watchdog_add_fun_prop2)
  done

lemma watchdog_add_fun_correct2:
  assumes "n > 0"
  shows "snd (watchdog_add_fun evt_id n s (Suc (watchdog_add_pos s n))) = Watchdog.watchdog_add evt_id n s"
proof -
  let ?i="watchdog_add_pos s n"
  have a1: "(n > watchdog_total_upto s (length s) \<and> ?i = length s) \<or>
        (n \<le> watchdog_total_upto s (Suc ?i) \<and> n > watchdog_total_upto s ?i \<and> Suc ?i \<le> length s)"
    using watchdog_add_fun_range2[OF assms] by auto
  have a2: ?thesis if "n > watchdog_total_upto s (length s)" "?i = length s"
    using watchdog_add_fun_correct[of s "Suc ?i" n evt_id] watchdog_add_prop1 that by auto
  have a3: ?thesis if "n \<le> watchdog_total_upto s (Suc ?i)" "n > watchdog_total_upto s ?i" "Suc ?i \<le> length s"
    using watchdog_add_fun_correct[of s "Suc ?i" n evt_id] watchdog_add_prop2 that by auto
  show ?thesis
    using a1 a2 a3 by blast
qed

lemma watchdog_add_impl_rule2':
  assumes "n > 0"
  shows
    "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
      watchdog_add_impl' evt_id n
     \<lbrace> \<lambda>r s es. s = Watchdog.watchdog_add evt_id n s0 \<and> es = e0 \<rbrace>!"
  apply (rule validNF_strengthen_post[OF watchdog_add_impl_rule'])
  using watchdog_add_fun_correct2 assms by auto

lemma watchdog_add_impl_rule2:
  assumes "n > 0"
  shows
    "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
      watchdog_add_impl evt_id n
     \<lbrace> \<lambda>_ s es. s = Watchdog.watchdog_add evt_id n s0 \<and> es = e0 \<rbrace>!"
  unfolding watchdog_add_impl_def
  apply wp apply (rule watchdog_add_impl_rule2')
  using assms apply auto by wp

subsection \<open>Imperative version of watchdog_tick\<close>

definition decr_head_impl :: "nat \<Rightarrow> (watchdog_chain, event, unit) event_monad" where
  "decr_head_impl n = (
     get_chain_pos 0 \<bind> (\<lambda>k.
     set_chain_pos 0 (k - n) \<bind> (\<lambda>_.
     return ())))"

theorem decr_head_impl_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
     decr_head_impl n
   \<lbrace> \<lambda>r s es. s = decr_head n s0 \<and> es = e0 \<rbrace>!"
  unfolding decr_head_impl_def
  apply wp
  apply (cases s0) by auto

text \<open>
  While loop keeps track of whether to continue iteration.
\<close>
definition extract_zero_impl :: "(watchdog_chain, event, bool) event_monad" where
  "extract_zero_impl = whileLoop (\<lambda>k s. k) (\<lambda>k.
     get_chain_length \<bind> (\<lambda>len.
     if len = 0 then
       return False
     else
       get_chain_pos 0 \<bind> (\<lambda>k.
       if k = 0 then
         get_chain_pos_id 0 \<bind> (\<lambda>evt_id.
         signal (DISPATCH evt_id) \<bind> (\<lambda>_.
         remove_first \<bind> (\<lambda>_.
         return True)))
       else
         return False))) True"

text \<open>Functional array implementation of extract_zero\<close>
fun extract_zero_fun :: "watchdog_chain \<Rightarrow> nat \<Rightarrow> event list \<times> bool \<times> watchdog_chain" where
  "extract_zero_fun s 0 = ([], True, s)"
| "extract_zero_fun s (Suc i) = (
    let (es, r, s') = extract_zero_fun s i in
      if \<not>r then
        (es, r, s')
      else case s' of
             [] \<Rightarrow> (es, False, s')
           | p # s2 \<Rightarrow> if snd p = 0 then (es @ [DISPATCH (fst p)], True, s2)
                       else (es, False, s'))"

lemma extract_zero_fun_prop1:
  "extract_zero_fun s0 i = (e, True, s) \<Longrightarrow> s = drop i s0 \<and> i \<le> count_zero s0"
proof (induction i arbitrary: s0 e s)
  case 0
  then show ?case by auto
next
  case (Suc i)
  show ?case
  proof (cases "extract_zero_fun s0 i")
    case (fields es r s')
    show ?thesis
    proof (cases "r = True")
      case True
      have a1: "s' = drop i s0 \<and> i \<le> count_zero s0"
        using Suc(1)[OF fields[unfolded True]] by auto
      show ?thesis
      proof (cases s')
        case Nil
        then show ?thesis
          using Suc(2) fields True by auto
      next
        case (Cons p s2)
        show ?thesis
          using Suc(2) apply (auto simp add: fields True Cons)
          subgoal apply (cases "snd p = 0") apply auto
            using Cons a1 by (metis Cons_nth_drop_Suc length_Cons length_drop list.inject zero_less_Suc zero_less_diff)
          subgoal apply (cases "snd p = 0")
             apply auto using Cons a1
            by (metis Cons_nth_drop_Suc Suc_leI count_zero_iff2 le_neq_implies_less length_Cons
                      length_drop nth_Cons_0 zero_less_Suc zero_less_diff)
          done
      qed
    next
      case False
      then show ?thesis
        using Suc(2) by (auto simp add: fields)
    qed
  qed
qed

lemma extract_zero_fun_prop2:
  "i \<le> count_zero s0 \<Longrightarrow> extract_zero_fun s0 i = (map (\<lambda>p. DISPATCH (fst p)) (take i s0), True, drop i s0)"
proof (induction i)
  case 0
  then show ?case by auto
next
  case (Suc i)
  have a1: "extract_zero_fun s0 i = (map (\<lambda>p. DISPATCH (fst p)) (take i s0), True, drop i s0)"
    using Suc by auto
  have a2: "i < count_zero s0"
    using Suc by auto
  have a3: "i < length s0" "snd (s0 ! i) = 0"
    using count_zero_iff a2 by auto
  have a4: "drop i s0 \<noteq> []" "snd ((drop i s0) ! 0) = 0"
    using a3 by auto
  have a5: "take (Suc i) s0 = take i s0 @ [s0 ! i]"
    by (simp add: a3(1) take_Suc_conv_app_nth)
  show ?case
    apply (auto simp add: a1) apply (cases "drop i s0")
    subgoal using a4 by auto
    subgoal for p s2
      apply (auto simp add: a4 a5 nth_via_drop)
      apply (simp add: a3(1) drop_Suc_nth)
      using a4(2) by auto
    done
qed

lemma extract_zero_fun_prop3:
  "extract_zero_fun s0 (Suc (count_zero s0)) =
   (map (\<lambda>p. DISPATCH (fst p)) (take (count_zero s0) s0), False, drop (count_zero s0) s0)"
proof -
  let ?i="count_zero s0"
  have a1: "extract_zero_fun s0 ?i = (map (\<lambda>p. DISPATCH (fst p)) (take ?i s0), True, drop ?i s0)"
    using extract_zero_fun_prop2 by auto
  have a2: "?i = length s0 \<or> snd (s0 ! ?i) \<noteq> 0"
    using count_zero_iff2 by auto
  show ?thesis
    apply (auto simp add: a1)
    apply (cases "drop ?i s0") apply auto
    using a2 nth_via_drop by fastforce
qed

lemma extract_zero_impl_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
    extract_zero_impl
   \<lbrace> \<lambda>r s es. \<not>r \<and> extract_zero_fun s0 (Suc (count_zero s0)) = (es, r, s) \<rbrace>!"
  unfolding extract_zero_impl_def
  apply (rule validNF_whileLoop[where
          I="\<lambda>r s es. \<exists>i. i \<le> Suc (count_zero s0) \<and> extract_zero_fun s0 i = (es, r, s)" and
          R="measure (\<lambda>(r,s). length s + (if r then 1 else 0))"])
  subgoal
    apply (rule exI[where x=0]) by auto
  subgoal for r s0'
    apply wp
    subgoal for s e apply auto
      subgoal for i
        apply (rule exI[where x="Suc i"])
        apply auto
        by (auto simp add: extract_zero_fun_prop1)
      subgoal for i
        apply (rule exI[where x="Suc i"])
        apply (auto simp add: extract_zero_fun_prop1)
        apply (cases s) by auto
      subgoal for i
        apply (rule exI[where x="Suc i"])
        apply (auto simp add: extract_zero_fun_prop1)
        apply (cases s) by auto
      done
    done
  subgoal
    by (rule wf_measure)
  subgoal for r s es
    using extract_zero_fun_prop2 le_Suc_eq by fastforce
  done

lemma extract_zero_fun_correct:
  "extract_zero_fun s0 (Suc (count_zero s0)) =
   (map DISPATCH (fst (extract_zero s0)), False, snd (extract_zero s0))"
  unfolding extract_zero_fun_prop3 extract_zero_array by auto

lemma extract_zero_impl_rule2:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
    extract_zero_impl
   \<lbrace> \<lambda>r s es. \<not>r \<and> s = snd (extract_zero s0) \<and> es = map DISPATCH (fst (extract_zero s0)) \<rbrace>!"
  apply (rule validNF_strengthen_post[OF extract_zero_impl_rule])
  using extract_zero_fun_correct by auto

definition watchdog_tick_impl :: "(watchdog_chain, event, unit) event_monad" where
  "watchdog_tick_impl = (
    decr_head_impl 1 \<bind> (\<lambda>_.
    extract_zero_impl \<bind> (\<lambda>_. return ())))"

lemma watchdog_tick_impl_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = [] \<rbrace>
     watchdog_tick_impl
   \<lbrace> \<lambda>_ s es. s = snd (Watchdog.watchdog_tick s0) \<and>
              es = map DISPATCH (fst (Watchdog.watchdog_tick s0)) \<rbrace>!"
  unfolding watchdog_tick_impl_def
  apply wp
    apply (rule decr_head_impl_rule)
   apply (rule validNF_strengthen_post)
  apply (rule validNF_bind)
     apply (rule extract_zero_impl_rule2)
  apply (rule validNF_weaken_pre)
     apply (rule validNF_return)
  by (auto simp add: Watchdog.watchdog_tick_def)

subsection \<open>Imperative version of watchdog_remove\<close>

text \<open>Imperative code\<close>
definition find_chain_pos_impl :: "task_id \<Rightarrow> (watchdog_chain, event, bool \<times> nat) event_monad" where
  "find_chain_pos_impl evt_id = whileLoop (\<lambda>r s. (snd r < length s \<and> fst r = False)) (\<lambda>r.
     get_chain_pos_id (snd r) \<bind> (\<lambda>w.
     if evt_id = w then
       return (True, snd r + 1)
     else
       return (False, snd r + 1))) (False, 0)"

text \<open>Corresponding functional code\<close>
fun find_chain_pos_fun :: "task_id \<Rightarrow> watchdog_chain \<Rightarrow> nat \<Rightarrow> bool" where
  "find_chain_pos_fun evt_id s 0 = False"
| "find_chain_pos_fun evt_id s (Suc i) = (
    let b' = find_chain_pos_fun evt_id s i in
      if b' \<or> i \<ge> length s then
        b'    \<comment> \<open>Imperative code should have terminated\<close>
      else if fst (s ! i) = evt_id then
        True  \<comment> \<open>Found at other position\<close>
      else
        False)"   \<comment> \<open>Repeat the iteration\<close>

lemma find_chain_pos_Suc:
  "n < length s0 \<Longrightarrow>
   find_chain_pos_fun evt_id s0 n = False \<and> evt_id \<noteq> fst (s0 ! n) \<longleftrightarrow>
   find_chain_pos_fun evt_id s0 (Suc n) = False"
  by (induction n, auto)

lemma find_chain_pos_evtid:
  "n \<le> length s0 \<Longrightarrow>
   find_chain_pos_fun evt_id s0 n = False \<longleftrightarrow> (\<forall>i < n. evt_id \<noteq> fst (s0 ! i))"
proof (induct n arbitrary: s0)
  case 0
  then show ?case by auto
next
  case (Suc n)
  show ?case
  proof (cases s0)
    case Nil
    then show ?thesis
      using Suc.prems(1) by auto
  next
    case (Cons s es)
    show ?thesis
      using Suc.hyps less_Suc_eq local.Suc(2) by auto
  qed
qed

lemma find_chain_some_n:
  assumes "n < length s0"
    shows "watchdog_remove_pos evt_id s0 = Some n \<longleftrightarrow>
    (evt_id = fst (s0 ! n) \<and> find_chain_pos_fun evt_id s0 (n) = False)"
  using assms find_chain_pos_evtid watchdog_remove_pos_evtid2 by auto

lemma find_chain_some_nSuc:
  "watchdog_remove_pos evt_id s0 = Some n \<longleftrightarrow>
   (find_chain_pos_fun evt_id s0 (Suc n) = True \<and> find_chain_pos_fun evt_id s0 (n) = False)"
proof (induct n)
  case 0
  then show ?case apply auto
     apply (simp add: find_chain_some_n)
    by (simp add: find_chain_some_n)
next
  case (Suc n)
  then show ?case
  proof -
    have "(watchdog_remove_pos evt_id s0 = Some (Suc n)) = (evt_id = fst (s0 ! Suc n) \<and> Suc n < length s0 \<and>
      \<not> find_chain_pos_fun evt_id s0 (Suc n))"
      by (metis find_chain_some_n watchdog_remove_pos_le)
    then show ?thesis
      using not_le by force
  qed
qed

lemma find_chain_some_snd:
  "watchdog_remove_pos evt_id s0 = Some n \<Longrightarrow> i \<le> Suc n \<Longrightarrow> find_chain_pos_fun evt_id s0 i \<Longrightarrow> i = Suc n"
proof (induct n)
  case 0
  then show ?case
    using le_eq_less_or_eq by fastforce
next
  case (Suc n)
  then show ?case
    by (metis find_chain_pos_fun.simps(2) find_chain_some_nSuc le_Suc_eq nat_induct_at_least)
qed

lemma find_chain_pos_impl_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
    find_chain_pos_impl evt_id
   \<lbrace> \<lambda>r s es. (case watchdog_remove_pos evt_id s0 of
                 None \<Rightarrow> fst r = False \<and> snd r = length s0
               | Some i \<Rightarrow> fst r = True \<and> snd r = Suc i) \<and>
              s = s0 \<and> es = e0 \<rbrace>!"
  unfolding find_chain_pos_impl_def
  apply (rule validNF_whileLoop[where I="\<lambda>r s e. find_chain_pos_fun evt_id s0 (snd r) = fst r \<and>
                                                 (case watchdog_remove_pos evt_id s0 of
                                                    None \<Rightarrow> snd r \<le> length s0
                                                  | Some i \<Rightarrow> snd r \<le> Suc i) \<and> s = s0 \<and> e = e0" and
                                      R="measure (\<lambda>(r,s). length s0 - snd r)"])
  subgoal for s es
    apply (cases "watchdog_remove_pos evt_id s0") by auto
  subgoal for r0 s0
    apply wp subgoal for s e
      apply (cases "watchdog_remove_pos evt_id s0") apply auto
      apply (metis find_chain_some_nSuc le_SucE)
      using find_chain_some_nSuc le_Suc_eq by auto
    done
  subgoal
    apply (cases "watchdog_remove_pos evt_id s0") by auto
  subgoal for r s e
    apply (cases "watchdog_remove_pos evt_id s0") apply auto
    apply (metis find_chain_pos_fun.simps(1) find_chain_some_nSuc option.simps(3) zero_induct)
    apply (metis find_chain_pos_fun.simps(1) find_chain_some_nSuc option.simps(3) zero_induct)
    apply (metis (full_types) find_chain_pos_fun.simps(1) find_chain_some_nSuc option.distinct(1) zero_induct)
    apply (simp add: find_chain_some_snd)
    apply (metis (mono_tags, hide_lams) Suc_leI find_chain_some_nSuc le_antisym not_less order_trans watchdog_remove_pos_le)
    using watchdog_remove_pos_le apply fastforce
    by (simp add: find_chain_some_snd)
done

definition remove_chain_pos_impl :: "nat \<Rightarrow> (watchdog_chain, event, unit) event_monad" where
  "remove_chain_pos_impl i = (
    get_chain_length \<bind> (\<lambda>len.
    if i \<ge> len then
      return ()
    else if i = len - 1 then
        modify (\<lambda>es. take i es) \<bind> (\<lambda>_.
        return ())
    else
      get_chain_pos i \<bind> (\<lambda>n.
      get_chain_pos (i + 1) \<bind> (\<lambda>k.
      modify (\<lambda>es. (take i es) @ (drop (i + 1) es)) \<bind> (\<lambda>_.
      set_chain_pos i (n + k) \<bind> (\<lambda>_.
      return ()))))))"

theorem remove_chain_pos_impl_rule:
 "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
       remove_chain_pos_impl n
     \<lbrace> \<lambda>r s es. s = remove_chain_pos_fun n s0 \<and> es = e0 \<rbrace>!"
  unfolding remove_chain_pos_impl_def
  apply wp
  apply (cases s0) apply auto
     apply (simp add: remove_chain_pos_fun_def)
  using remove_chain_pos_prop1 apply auto
  using remove_chain_pos_prop2
    apply (simp add: remove_chain_pos_fun_def)
   apply (simp add: remove_chain_pos_prop1)
  by (simp add: remove_chain_pos_prop2)

definition watchdog_remove_impl :: "task_id \<Rightarrow> (watchdog_chain, event, unit) event_monad" where
  "watchdog_remove_impl evt_id = (
    find_chain_pos_impl evt_id \<bind> (\<lambda>r.
    if fst r then
      remove_chain_pos_impl (snd r - 1)
    else return ()))"

lemma watchdog_remove_impl_rule':
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
    watchdog_remove_impl evt_id
   \<lbrace> \<lambda>r s es. s = watchdog_remove2 evt_id s0 \<and> es = e0 \<rbrace>!"
  unfolding watchdog_remove_impl_def
  apply (rule validNF_bind)
   apply (rule find_chain_pos_impl_rule)
  subgoal for r
  proof (cases "watchdog_remove_pos evt_id s0")
    case None
    then show ?thesis
      apply auto
      subgoal apply (rule validNF_weaken_pre)
        unfolding remove_chain_pos_impl_def apply wp by auto
      subgoal
        apply wp
        by (auto simp add: watchdog_remove2_def)
      done
  next
    case (Some n)
    then show ?thesis
      apply auto
      subgoal
        apply (subst validNF_conj_pre) apply auto
        apply (rule validNF_strengthen_post)
         apply (rule remove_chain_pos_impl_rule)
        by (auto simp add: watchdog_remove2_def)
      subgoal apply (rule validNF_weaken_pre)
        unfolding remove_chain_pos_impl_def apply wp by auto
      done
  qed
  done

lemma watchdog_remove_impl_rule:
  "\<lbrace> \<lambda>s es. s = s0 \<and> es = e0 \<rbrace>
    watchdog_remove_impl evt_id
   \<lbrace> \<lambda>r s es. s = watchdog_remove evt_id s0 \<and> es = e0 \<rbrace>!"
  using watchdog_remove_impl_rule' watchdog_remove2_correct
  by auto

subsection \<open>Refinement proofs for watchdog\<close>

type_synonym astate_watchdog =
  "task_id \<Rightarrow> nat option"

definition rel_watchdog :: "astate_watchdog \<Rightarrow> watchdog_chain \<Rightarrow> bool" where
  "rel_watchdog as cs \<longleftrightarrow> valid_watchdog cs \<and> as = event_time cs"

theorem watchdog_add_rule':
  assumes "0 < n"
    and "as evt_id = None"
  shows
  "\<lbrace> \<lambda>cs es. \<exists>cs'. rel_watchdog as cs' \<and> cs = cs' \<and> es = e0 \<rbrace>
     watchdog_add_impl evt_id n
   \<lbrace> \<lambda>_ cs es. rel_watchdog (as(evt_id \<mapsto> n)) cs \<and> es = e0 \<rbrace>!"
  apply (rule validNF_ex_pre)
  subgoal for cs'
    apply (subst validNF_conj_pre)
    apply auto
    apply (rule validNF_strengthen_post)
    apply (rule watchdog_add_impl_rule2[OF assms(1)])
    apply (auto simp add: rel_watchdog_def)
    apply (rule watchdog_add_valid) using assms apply auto
    apply (subst watchdog_add_full[OF _ assms(1)])
    using assms(2) by auto
  done

theorem watchdog_add_rule:
  assumes "n > 0"
    and "as evt_id = None"
  shows
  "\<lbrace> \<lambda>cs es. rel_watchdog as cs \<and> nil\<^sub>e es \<rbrace>
     watchdog_add_impl evt_id n
   \<lbrace> \<lambda>_ cs es. rel_watchdog (as(evt_id \<mapsto> n)) cs \<and> nil\<^sub>e es \<rbrace>!"
  apply (rule validNF_weaken_pre)
  unfolding nil_event_def
   apply (rule watchdog_add_rule')
  by (auto simp add: assms)

definition spec_watchdog_tick :: "astate_watchdog \<Rightarrow> astate_watchdog" where
  "spec_watchdog_tick as =
    (\<lambda>ev. case as ev of None \<Rightarrow> None
                       | Some n \<Rightarrow> if n > 1 then Some (n - 1) else None)"

definition spec_watchdog_tick_ev :: "astate_watchdog \<Rightarrow> task_id set" where
  "spec_watchdog_tick_ev as = {ev. as ev = Some 1}"

theorem watchdog_tick_full:
  assumes "rel_watchdog as cs"
  shows "set (fst (watchdog_tick cs)) = spec_watchdog_tick_ev as"
        "rel_watchdog (spec_watchdog_tick as) (snd (watchdog_tick cs))"
proof -
  have valid: "valid_watchdog cs"
    using assms unfolding rel_watchdog_def by auto
  have a: "evt_id \<in> set (fst (watchdog_tick cs)) \<longleftrightarrow> evt_id \<in> spec_watchdog_tick_ev as" for evt_id
    apply (cases "event_time cs evt_id = None")
    using assms apply (auto simp add: watchdog_tick_None spec_watchdog_tick_ev_def rel_watchdog_def)[1]
    apply (cases "event_time cs evt_id = Some 0")
    apply (auto simp add: watchdog_tick_triv[OF valid])[1]
    apply (cases "event_time cs evt_id = Some 1")
    using assms apply (auto simp add: watchdog_tick1 spec_watchdog_tick_ev_def rel_watchdog_def)[1]
    using assms by (auto simp add: watchdog_tick2[OF valid] spec_watchdog_tick_ev_def rel_watchdog_def)
  show "rel_watchdog (spec_watchdog_tick as) (snd (watchdog_tick cs))"
    apply (auto simp add: rel_watchdog_def)
    apply (rule watchdog_tick_valid[OF valid])
    apply (rule ext) subgoal for evt_id
      apply (cases "event_time cs evt_id = None")
      subgoal
        apply (auto simp add: watchdog_tick_None spec_watchdog_tick_def rel_watchdog_def)
        apply (cases "as evt_id") using assms rel_watchdog_def by auto
      apply (cases "event_time cs evt_id = Some 0")
      subgoal by (auto simp add: watchdog_tick_triv[OF valid])[1]
      apply (cases "event_time cs evt_id = Some 1")
      subgoal
        apply (auto simp add: watchdog_tick1[OF valid] spec_watchdog_tick_def)
        apply (cases "as evt_id") using assms rel_watchdog_def by auto
      apply (auto simp add: watchdog_tick2[OF valid] spec_watchdog_tick_def)
      apply (cases "as evt_id") using assms rel_watchdog_def by auto
    done
  show "set (fst (watchdog_tick cs)) = spec_watchdog_tick_ev as"
    using a by auto
qed

lemma watchdog_tick_event_distinct:
  assumes "rel_watchdog as cs"
  shows "distinct (map DISPATCH (fst (watchdog_tick cs)))"
proof -
  have a: "distinct (fst (watchdog_tick cs))"
    unfolding watchdog_tick_def
    apply (rule watchdog_tick_distinct)
    using assms(1) unfolding rel_watchdog_def valid_watchdog_def
    using decr_head_atmost_one by auto
  have b: "distinct es \<Longrightarrow> distinct (map DISPATCH es)" for es
    apply (induction es) by auto
  show ?thesis
    using a b by auto
qed

theorem watchdog_tick_rule':
  "\<lbrace> \<lambda>cs es. \<exists>cs'. rel_watchdog as cs' \<and> cs = cs' \<and> es = [] \<rbrace>
     watchdog_tick_impl
   \<lbrace> \<lambda>_ cs es. rel_watchdog (spec_watchdog_tick as) cs \<and>
               distinct es \<and>
               set es = DISPATCH ` (spec_watchdog_tick_ev as) \<rbrace>!"
  apply (rule validNF_ex_pre)
  subgoal for cs'
    apply (subst validNF_conj_pre)
    apply auto
    apply (rule validNF_strengthen_post)
     apply (rule watchdog_tick_impl_rule)
    apply (rule conjI)
    by (auto simp add: watchdog_tick_full watchdog_tick_event_distinct)
  done

theorem watchdog_tick_rule:
  "\<lbrace> \<lambda>cs es. rel_watchdog as cs \<and> nil\<^sub>e es \<rbrace>
     watchdog_tick_impl
   \<lbrace> \<lambda>_ cs es. rel_watchdog (spec_watchdog_tick as) cs \<and>
               distinct es \<and>
               set es = DISPATCH ` (spec_watchdog_tick_ev as) \<rbrace>!"
  apply (rule validNF_weaken_pre) unfolding nil_event_def
  apply (rule watchdog_tick_rule')
  by auto

theorem watchdog_remove_full:
  assumes "rel_watchdog as cs"
  shows "rel_watchdog (as(evt_id := None)) (watchdog_remove evt_id cs)"
proof -
  have valid: "valid_watchdog cs"
    using assms unfolding rel_watchdog_def by auto
  show ?thesis
    apply (auto simp add: rel_watchdog_def)
    apply (rule watchdog_remove_valid[OF valid])
    apply (rule ext) subgoal for evt_id'
      apply (cases "evt_id = evt_id'")
      subgoal apply auto apply (subst watchdog_remove_prop1')
        using assms by (auto simp add: valid_watchdog_def rel_watchdog_def)
      apply auto apply (subst watchdog_remove_prop2')
      using assms by (auto simp add: rel_watchdog_def)
    done
qed

theorem watchdog_remove_rule':
  "\<lbrace> \<lambda>cs es. \<exists>cs'. rel_watchdog as cs' \<and> cs = cs' \<and> es = e0 \<rbrace>
     watchdog_remove_impl evt_id
   \<lbrace> \<lambda>_ cs es. rel_watchdog (as(evt_id := None)) cs \<and> es = e0 \<rbrace>!"
  apply (rule validNF_ex_pre)
  subgoal for cs'
    apply (subst validNF_conj_pre)
    apply auto
    apply (rule validNF_strengthen_post)
     apply (rule watchdog_remove_impl_rule)
    apply auto
    apply (rule watchdog_remove_full)
    by (auto simp add: watchdog_remove_valid)
  done

theorem watchdog_remove_rule:
  "\<lbrace> \<lambda>cs es. rel_watchdog as cs \<and> nil\<^sub>e es \<rbrace>
     watchdog_remove_impl evt_id
   \<lbrace> \<lambda>_ cs es. rel_watchdog (as(evt_id := None)) cs \<and> nil\<^sub>e es \<rbrace>!"
  apply (rule validNF_weaken_pre) unfolding nil_event_def
   apply (rule watchdog_remove_rule')
  by auto

end