(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_nat_boring_gt_irreflexive
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun lt :: "Nat => Nat => bool" where
"lt x (Z) = False"
| "lt (Z) (S z) = True"
| "lt (S n) (S z) = lt n z"

fun gt :: "Nat => Nat => bool" where
"gt x y = lt y x"

theorem property0 :
  "(~ (gt x x))"
  oops

end


           (*-------------------------------------------*
            |    Example 1 [Roscoe_Dathi_1987 P.10]     |
            |             WITH computation              |
            |  Self-timed version of a systolic array   |
            |                   June 2005               |
            |               December 2005  (modified)   |
            |                                           |
            |   on DFP on CSP-Prover ver.3.0            |
            |              September 2006  (modified)   |
            |                                           |
            |   on DFP on CSP-Prover ver.4.0            |
            |                  April 2007  (modified)   |
            |                                           |
            |   on DFP on CSP-Prover ver.5.0            |
            |                   July 2009  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2012         |
            |               November 2012  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory SA_main
imports SA_condition SA_expanding SA_local
begin

(*=================================================================*
 |                 main theorem (deadlock freedom)                 |
 *=================================================================*)

theorem Example1_ring:
  "ALL N. N ~= 0 --> DeadlockFreeNetwork (Systolic_Array N)"
apply (intro allI impI)
apply (rule Rule1_Roscoe_Dathi_1987_I)
apply (simp_all)
apply (rule EX1_isFailureOf[simplified Systolic_ArrayF_def])

(* nonempty *)
apply (simp add: Array_Index_def)
apply (fast)

(* finite *)
apply (simp add: Example1_finite)

(* 3triple_disjoint*)
apply (simp add: Example1_triple_disjoint[simplified Systolic_ArrayF_def])

(* BusyNetwork *)
apply (simp add: Example1_BusyNetwork[simplified Systolic_ArrayF_def])

(* variant function *)
apply (rule_tac x="(%(i,j). (%(s,X). (lengtht s) + 2 * (i + j)))" in exI)
apply (simp)
apply (intro ballI impI allI)
apply (simp add: Example1_index_mem)
apply (elim conjE exE)
apply (rename_tac N ij1 ij2 t Yf i1 i2 j1 j2)
apply (simp)
apply (subgoal_tac "(i1 = i2 & j1 = Suc j2)
                  | (i1 = i2 & j2 = Suc j1)
                  | (i1 = Suc i2 & j1 = j2)
                  | (i2 = Suc i1 & j1 = j2)")
apply (elim conjE disjE)
apply (simp add: local_hori_rev)
apply (simp add: local_hori)
apply (simp add: local_vert_rev)
apply (simp add: local_vert)
apply (simp add: possible_pairs)
done

(****************** to add it again ******************)

end


theory Config_Morphisms
  imports Hygge_Theory
begin

text \<open>
  TESL morphisms change the time on clocks, preserving the ticks.
\<close>
consts morphism :: \<open>'a \<Rightarrow> ('\<tau>::linorder \<Rightarrow> '\<tau>::linorder) \<Rightarrow> 'a\<close> (infixl \<open>\<Otimes>\<close> 100)

text \<open>
  Applying a TESL morphism to a tag simply changes its value.
\<close>
overloading morphism_tagconst \<equiv> \<open>morphism :: '\<tau> tag_const \<Rightarrow> ('\<tau>::linorder \<Rightarrow> '\<tau>) \<Rightarrow> '\<tau> tag_const\<close>
begin
  definition morphism_tagconst :
          \<open>(x::'\<tau> tag_const) \<Otimes> (f::('\<tau>::linorder \<Rightarrow> '\<tau>)) = (\<tau>\<^sub>c\<^sub>s\<^sub>t o f)(the_tag_const x) \<close>
end

text \<open>
  Applying a TESL morphism to an atomic formula only changes the dates.
\<close>
overloading morphism_TESL_atomic \<equiv>
            \<open>morphism :: '\<tau> TESL_atomic \<Rightarrow> ('\<tau>::linorder \<Rightarrow> '\<tau>) \<Rightarrow> '\<tau> TESL_atomic\<close>
begin
definition morphism_TESL_atomic :
          \<open>(\<Psi>::'\<tau> TESL_atomic) \<Otimes> (f::('\<tau>::linorder \<Rightarrow> '\<tau>)) =
              (case \<Psi> of
                (C sporadic t on C')     \<Rightarrow> (C sporadic (t\<Otimes>f) on C')
              | (time-relation \<lfloor>C, C'\<rfloor>\<in>R)\<Rightarrow> (time-relation \<lfloor>C, C'\<rfloor> \<in> (\<lambda>(t, t'). R(t\<Otimes>f,t'\<Otimes>f)))
              | (C implies C')           \<Rightarrow> (C implies C')
              | (C implies not C')       \<Rightarrow> (C implies not C')
              | (C time-delayed by t on C' implies C'')
                                         \<Rightarrow> (C time-delayed by t\<Otimes>f on C' implies C'')
              | (C weakly precedes C')   \<Rightarrow> (C weakly precedes C')
              | (C strictly precedes C') \<Rightarrow> (C strictly precedes C')
              | (C kills C')             \<Rightarrow> (C kills C'))\<close>
end

text \<open>
  Applying a TESL morphism to a formula amounts to apply it to each atomic formula.
\<close>
overloading morphism_TESL_formula \<equiv>
            \<open>morphism :: '\<tau> TESL_formula \<Rightarrow> ('\<tau>::linorder \<Rightarrow> '\<tau>) \<Rightarrow> '\<tau> TESL_formula\<close>
begin
definition  morphism_TESL_formula :
           \<open>(\<Psi>::'\<tau> TESL_formula) \<Otimes> (f::('\<tau>::linorder \<Rightarrow> '\<tau>)) = map (\<lambda>x. x \<Otimes> f) \<Psi>\<close>
end

text \<open>
  Applying a TESL morphism to a configuration amounts to apply it to the
  present and future formulae. The past (in the context @{term \<open>\<Gamma>\<close>}) is not changed.
\<close>
overloading morphism_TESL_config \<equiv>
            \<open>morphism :: ('\<tau>::linordered_field) config \<Rightarrow> ('\<tau> \<Rightarrow> '\<tau>) \<Rightarrow> '\<tau> config\<close>
begin
fun  morphism_TESL_config
  where  \<open>((\<Gamma>, n \<turnstile> \<Psi> \<triangleright> \<Phi>)::('\<tau>::linordered_field) config) \<Otimes> (f::('\<tau> \<Rightarrow> '\<tau>)) =
           (\<Gamma>, n \<turnstile> (\<Psi>\<Otimes>f) \<triangleright> (\<Phi>\<Otimes>f))\<close>
end

text \<open>
  A TESL formula is called consistent if it possesses Kripke-models
  in its denotational interpretation.
\<close>

definition consistent :: \<open>('\<tau>::linordered_field) TESL_formula \<Rightarrow> bool\<close>
  where   \<open>consistent \<Psi> \<equiv> \<lbrakk>\<lbrakk> \<Psi> \<rbrakk>\<rbrakk>\<^sub>T\<^sub>E\<^sub>S\<^sub>L \<noteq> {}\<close>

text \<open>
  If we can derive a consistent finite context from a TESL formula, the formula is consistent.
\<close>
theorem consistency_finite :
  assumes start             : \<open>([], 0 \<turnstile> \<Psi> \<triangleright> [])  \<hookrightarrow>\<^sup>*\<^sup>* (\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> [] \<triangleright> [])\<close>
      and init_invariant    : \<open>consistent_context \<Gamma>\<^sub>1\<close>
    shows \<open>consistent \<Psi>\<close>
proof -
  have * : \<open>\<exists> n. (([], 0 \<turnstile> \<Psi> \<triangleright> []) \<hookrightarrow>\<^bsup>n\<^esup> (\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> [] \<triangleright> []))\<close>
    by (simp add: rtranclp_imp_relpowp start)
  show ?thesis
  unfolding consistent_context_def consistent_def
  using * consistent_context_def init_invariant soundness by fastforce
qed

subsubsection \<open>Snippets on runs\<close>

text \<open>
  A run with no ticks and constant time for all clocks.
\<close>
definition const_nontick_run :: \<open>(clock \<Rightarrow> '\<tau> tag_const) \<Rightarrow> ('\<tau>::linordered_field) run \<close> (\<open>\<box>_\<close> 80)
  where \<open>\<box>f \<equiv>  Abs_run(\<lambda>n c. (False, f c))\<close>

text \<open>
  Ensure a clock ticks in a run at a given instant.
\<close>
definition set_tick :: \<open>('\<tau>::linordered_field) run \<Rightarrow> nat \<Rightarrow> clock \<Rightarrow> ('\<tau>) run\<close>
  where   \<open>set_tick r k c = Abs_run(\<lambda>n c.  if k = n
                                           then (True , time(Rep_run r k c))
                                           else Rep_run r k c) \<close>

text \<open>
  Ensure a clock does not tick in a run at a given instant.
\<close>
definition unset_tick :: \<open>('\<tau>::linordered_field) run \<Rightarrow> nat \<Rightarrow> clock \<Rightarrow> ('\<tau>) run\<close>
  where   \<open>unset_tick r k c = Abs_run(\<lambda>n c.  if k = n
                                           then (False , time(Rep_run r k c))
                                           else Rep_run r k c) \<close>

text \<open>
  Replace all instants after k in a run with the instants from another run.
  Warning: the result may not be a proper run since time may not be monotonous
  from instant k to instant k+1.
\<close>
definition patch :: \<open>('\<tau>::linordered_field) run \<Rightarrow> nat \<Rightarrow> '\<tau> run \<Rightarrow> '\<tau> run\<close> (\<open>_ \<ggreater>\<^bsup>_\<^esup> _\<close> 80)
  where   \<open>r \<ggreater>\<^bsup>k\<^esup>r' \<equiv> Abs_run(\<lambda>n c. if n \<le> k then Rep_run (r) n c else  Rep_run (r') n c)\<close>

text \<open>
  For some infinite cases, the idea for a proof scheme looks as follows: if we can derive
  from the initial configuration @{term \<open>([], 0 \<turnstile> \<Psi> \<triangleright> [])\<close>} a start-point of a lasso
  @{term \<open>(\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1)\<close>}, and if we can traverse the lasso one time
  @{term \<open>(\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1) \<hookrightarrow>\<^sup>+\<^sup>+ (\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2)\<close>} to isomorphic one,
  we can always always make a derivation along the lasso. If the entry point of the lasso had traces
  with prefixes consistent to @{term \<open>\<Gamma>\<^sub>1\<close>}, then there exist traces consisting of this prefix and
  repetitions of the delta-prefix of the lasso which are consistent with @{term \<open>\<Psi>\<close>} which implies
  the logical consistency of  @{term \<open>\<Psi>\<close>}.

  So far the idea. Remains to prove it. Why does one symbolic run along a lasso generalises to
  arbitrary runs ?
\<close>

theorem consistency_coinduct :
  assumes start             : \<open>([], 0 \<turnstile> \<Psi> \<triangleright> [])   \<hookrightarrow>\<^sup>*\<^sup>* (\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1)\<close>
      and loop              : \<open>(\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1) \<hookrightarrow>\<^sup>+\<^sup>+ (\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2)\<close>
      and init_invariant    : \<open>consistent_context \<Gamma>\<^sub>1\<close>
      and post_invariant    : \<open>consistent_context \<Gamma>\<^sub>2\<close>
      and retract_condition : \<open>(\<Gamma>\<^sub>2, n\<^sub>2 \<turnstile> \<Psi>\<^sub>2 \<triangleright> \<Phi>\<^sub>2) \<Otimes> (f::'\<tau> \<Rightarrow> '\<tau>) = (\<Gamma>\<^sub>1, n\<^sub>1 \<turnstile> \<Psi>\<^sub>1 \<triangleright> \<Phi>\<^sub>1) \<close>
    shows \<open>consistent (\<Psi> :: ('\<tau> :: linordered_field)TESL_formula)\<close>
oops

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)
(*
 * Contributions by:
 *   2012 Lars Noschinski <noschinl@in.tum.de>
 *     Option monad while loop formalisation.
 *)

theory OptionMonad
imports Lib
begin

type_synonym ('s,'a) lookup = "'s \<Rightarrow> 'a option"

text \<open>Similar to map_option but the second function returns option as well\<close>
definition
  opt_map :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> ('s,'b) lookup" (infixl "|>" 54)
where
  "f |> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x"

lemma opt_map_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f s = Some v \<Longrightarrow> g v = g' v\<rbrakk> \<Longrightarrow> f |> g = f' |> g'"
  by (rule ext) (simp add: opt_map_def split: option.splits)

lemma in_opt_map_eq:
  "((f |> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' = Some v)"
  by (simp add: opt_map_def split: option.splits)

lemma opt_mapE:
  "\<lbrakk> (f |> g) s = Some v; \<And>v'. \<lbrakk>f s = Some v'; g v' = Some v \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_opt_map_eq)

definition
  obind :: "('s,'a) lookup \<Rightarrow> ('a \<Rightarrow> ('s,'b) lookup) \<Rightarrow> ('s,'b) lookup" (infixl "|>>" 53)
where
  "f |>> g \<equiv> \<lambda>s. case f s of None \<Rightarrow> None | Some x \<Rightarrow> g x s"

definition
  "ofail = K None"

definition
  "oreturn = K o Some"

definition
  "oassert P \<equiv> if P then oreturn () else ofail"

text \<open>
  If the result can be an exception.
  Corresponding bindE would be analogous to lifting in NonDetMonad.
\<close>

definition
  "oreturnOk x = K (Some (Inr x))"

definition
  "othrow e = K (Some (Inl e))"

definition
  "oguard G \<equiv> (\<lambda>s. if G s then Some () else None)"

definition
  "ocondition c L R \<equiv> (\<lambda>s. if c s then L s else R s)"

definition
  "oskip \<equiv> oreturn ()"

text \<open>Monad laws\<close>
lemma oreturn_bind [simp]: "(oreturn x |>> f) = f x"
  by (auto simp add: oreturn_def obind_def K_def intro!: ext)

lemma obind_return [simp]: "(m |>> oreturn) = m"
  by (auto simp add: oreturn_def obind_def K_def intro!: ext split: option.splits)

lemma obind_assoc:
  "(m |>> f) |>> g  =  m |>> (\<lambda>x. f x |>> g)"
  by (auto simp add: oreturn_def obind_def K_def intro!: ext split: option.splits)

text \<open>Binding fail\<close>

lemma obind_fail [simp]:
  "f |>> (\<lambda>_. ofail) = ofail"
  by (auto simp add: ofail_def obind_def K_def intro!: ext split: option.splits)

lemma ofail_bind [simp]:
  "ofail |>> m = ofail"
  by (auto simp add: ofail_def obind_def K_def intro!: ext split: option.splits)

text \<open>Function package setup\<close>
lemma opt_bind_cong [fundef_cong]:
  "\<lbrakk> f = f'; \<And>v s. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> f |>> g = f' |>> g'"
  by (rule ext) (simp add: obind_def split: option.splits)

lemma opt_bind_cong_apply [fundef_cong]:
  "\<lbrakk> f s = f' s; \<And>v. f' s = Some v \<Longrightarrow> g v s = g' v s \<rbrakk> \<Longrightarrow> (f |>> g) s = (f' |>> g') s"
  by (simp add: obind_def split: option.splits)

lemma oassert_bind_cong [fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m = m' \<rbrakk> \<Longrightarrow> oassert P |>> m = oassert P' |>> m'"
  by (auto simp: oassert_def)

lemma oassert_bind_cong_apply [fundef_cong]:
  "\<lbrakk> P = P'; P' \<Longrightarrow> m () s = m' () s \<rbrakk> \<Longrightarrow> (oassert P |>> m) s = (oassert P' |>> m') s"
  by (auto simp: oassert_def)

lemma oreturn_bind_cong [fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> oreturn x |>> m = oreturn x' |>> m'"
  by simp

lemma oreturn_bind_cong_apply [fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> (oreturn x |>> m) s = (oreturn x' |>> m') s"
  by simp

lemma oreturn_bind_cong2 [fundef_cong]:
  "\<lbrakk> x = x'; m x' = m' x' \<rbrakk> \<Longrightarrow> (oreturn $ x) |>> m = (oreturn $ x') |>> m'"
  by simp

lemma oreturn_bind_cong2_apply [fundef_cong]:
  "\<lbrakk> x = x'; m x' s = m' x' s \<rbrakk> \<Longrightarrow> ((oreturn $ x) |>> m) s = ((oreturn $ x') |>> m') s"
  by simp

lemma ocondition_cong [fundef_cong]:
"\<lbrakk>c = c'; \<And>s. c' s \<Longrightarrow> l s = l' s; \<And>s. \<not>c' s \<Longrightarrow> r s = r' s\<rbrakk>
  \<Longrightarrow> ocondition c l r = ocondition c' l' r'"
  by (auto simp: ocondition_def)

text \<open>Decomposition\<close>

lemma ocondition_K_true [simp]:
  "ocondition (\<lambda>_. True) T F = T"
  by (simp add: ocondition_def)

lemma ocondition_K_false [simp]:
  "ocondition (\<lambda>_. False) T F = F"
  by (simp add: ocondition_def)

lemma ocondition_False:
    "\<lbrakk> \<And>s. \<not> P s \<rbrakk> \<Longrightarrow> ocondition P L R = R"
  by (rule ext, clarsimp simp: ocondition_def)

lemma ocondition_True:
    "\<lbrakk> \<And>s. P s \<rbrakk> \<Longrightarrow> ocondition P L R = L"
  by (rule ext, clarsimp simp: ocondition_def)

lemma in_oreturn [simp]:
  "(oreturn x s = Some v) = (v = x)"
  by (auto simp: oreturn_def K_def)

lemma oreturnE:
  "\<lbrakk>oreturn x s = Some v; v = x \<Longrightarrow> P x\<rbrakk> \<Longrightarrow> P v"
  by simp

lemma in_ofail [simp]:
  "ofail s \<noteq> Some v"
  by (auto simp: ofail_def K_def)

lemma ofailE:
  "ofail s = Some v \<Longrightarrow> P"
  by simp

lemma in_oassert_eq [simp]:
  "(oassert P s = Some v) = P"
  by (simp add: oassert_def)

lemma oassertE:
  "\<lbrakk> oassert P s = Some v; P \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by simp

lemma in_obind_eq:
  "((f |>> g) s = Some v) = (\<exists>v'. f s = Some v' \<and> g v' s = Some v)"
  by (simp add: obind_def split: option.splits)

lemma obindE:
  "\<lbrakk> (f |>> g) s = Some v;
     \<And>v'. \<lbrakk>f s = Some v'; g v' s = Some v\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (auto simp: in_obind_eq)

lemma in_othrow_eq [simp]:
  "(othrow e s = Some v) = (v = Inl e)"
  by (auto simp: othrow_def K_def)

lemma othrowE:
  "\<lbrakk>othrow e s = Some v; v = Inl e \<Longrightarrow> P (Inl e)\<rbrakk> \<Longrightarrow> P v"
  by simp

lemma in_oreturnOk_eq [simp]:
  "(oreturnOk x s = Some v) = (v = Inr x)"
  by (auto simp: oreturnOk_def K_def)

lemma oreturnOkE:
  "\<lbrakk>oreturnOk x s = Some v; v = Inr x \<Longrightarrow> P (Inr x)\<rbrakk> \<Longrightarrow> P v"
  by simp

lemmas omonadE [elim!] =
  opt_mapE obindE oreturnE ofailE othrowE oreturnOkE oassertE

section \<open>"While" loops over option monad.\<close>

text \<open>
  This is an inductive definition of a while loop over the plain option monad
  (without passing through a state)
\<close>

inductive_set
  option_while' :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> 'a option rel"
  for C B
where
    final: "\<not> C r \<Longrightarrow> (Some r, Some r) \<in> option_while' C B"
  | fail: "\<lbrakk> C r; B r = None \<rbrakk> \<Longrightarrow> (Some r, None) \<in> option_while' C B"
  | step: "\<lbrakk> C r;  B r = Some r'; (Some r', sr'') \<in> option_while' C B \<rbrakk>
           \<Longrightarrow> (Some r, sr'') \<in> option_while' C B"

definition
  "option_while C B r \<equiv>
    (if (\<exists>s. (Some r, s) \<in> option_while' C B) then
      (THE s. (Some r, s) \<in> option_while' C B) else None)"

lemma option_while'_inj:
  assumes "(s,s') \<in> option_while' C B" "(s, s'') \<in> option_while' C B"
  shows "s' = s''"
  using assms by (induct rule: option_while'.induct) (auto elim: option_while'.cases)

lemma option_while'_THE:
  assumes "(Some r, sr') \<in> option_while' C B"
  shows "(THE s. (Some r, s) \<in> option_while' C B) = sr'"
  using assms by (blast dest: option_while'_inj)

lemma option_while_simps:
  "\<not> C s \<Longrightarrow> option_while C B s = Some s"
  "C s \<Longrightarrow> B s = None \<Longrightarrow> option_while C B s = None"
  "C s \<Longrightarrow> B s = Some s' \<Longrightarrow> option_while C B s = option_while C B s'"
  "(Some s, ss') \<in> option_while' C B \<Longrightarrow> option_while C B s = ss'"
  using option_while'_inj_step[of C s B s']
  by (auto simp: option_while_def option_while'_THE
      intro: option_while'.intros
      dest: option_while'_inj
      elim: option_while'.cases)

lemma option_while_rule:
  assumes "option_while C B s = Some s'"
  assumes "I s"
  assumes istep: "\<And>s s'. C s \<Longrightarrow> I s \<Longrightarrow> B s = Some s' \<Longrightarrow> I s'"
  shows "I s' \<and> \<not> C s'"
proof -
  { fix ss ss' assume "(ss, ss') \<in> option_while' C B" "ss = Some s" "ss' = Some s'"
    then have ?thesis using \<open>I s\<close>
      by (induct arbitrary: s) (auto intro: istep) }
  then show ?thesis using assms(1)
    by (auto simp: option_while_def option_while'_THE split: if_split_asm)
qed

lemma option_while'_term:
  assumes "I r"
  assumes "wf M"
  assumes step_less: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step_I: "\<And>r r'. \<lbrakk>I r; C r; B r = Some r'\<rbrakk> \<Longrightarrow> I r'"
  obtains sr' where "(Some r, sr') \<in> option_while' C B"
  apply atomize_elim
  using assms(2,1)
proof induct
  case (less r)
  show ?case
  proof (cases "C r" "B r" rule: bool.exhaust[case_product option.exhaust])
    case (True_Some r')
    then have "(r',r) \<in> M" "I r'"
      by (auto intro: less step_less step_I)
    then obtain sr' where "(Some r', sr') \<in> option_while' C B"
      by atomize_elim (rule less)
    then have "(Some r, sr') \<in> option_while' C B"
      using True_Some by (auto intro: option_while'.intros)
    then show ?thesis ..
  qed (auto intro: option_while'.intros)
qed

lemma option_while_rule':
  assumes "option_while C B s = ss'"
  assumes "wf M"
  assumes "I (Some s)"
  assumes less: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> (s', s) \<in> M"
  assumes step: "\<And>s s'. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = Some s' \<Longrightarrow> I (Some s')"
  assumes final: "\<And>s. C s \<Longrightarrow> I (Some s) \<Longrightarrow> B s = None \<Longrightarrow> I None"
  shows "I ss' \<and> (case ss' of Some s' \<Rightarrow> \<not> C s' | _ \<Rightarrow> True)"
proof -
  define ss where "ss = Some s"
  obtain ss1' where "(Some s, ss1') \<in> option_while' C B"
    using assms(3,2,4,5) by (rule option_while'_term)
  then have *: "(ss, ss') \<in> option_while' C B" using \<open>option_while C B s = ss'\<close>
    by (auto simp: option_while_simps ss_def)
  show ?thesis
  proof (cases ss')
    case (Some s') with * ss_def show ?thesis using \<open>I _\<close>
      by (induct arbitrary:s) (auto intro: step)
  next
    case None with * ss_def show ?thesis using \<open>I _\<close>
      by (induct arbitrary:s) (auto intro: step final)
  qed
qed

section \<open>Lift @{term option_while} to the @{typ "('a,'s) lookup"} monad\<close>

definition
  owhile :: "('a \<Rightarrow> 's \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('s,'a) lookup) \<Rightarrow> 'a \<Rightarrow> ('s,'a) lookup"
where
 "owhile c b a \<equiv> \<lambda>s. option_while (\<lambda>a. c a s) (\<lambda>a. b a s) a"

lemma owhile_unroll:
  "owhile C B r = ocondition (C r) (B r |>> owhile C B) (oreturn r)"
  by (auto simp: ocondition_def obind_def oreturn_def owhile_def
           option_while_simps K_def split: option.split)

text \<open>rule for terminating loops\<close>

lemma owhile_rule:
  assumes "I r s"
  assumes "wf M"
  assumes less: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> (r',r) \<in> M"
  assumes step: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = Some r'\<rbrakk> \<Longrightarrow> I r' s"
  assumes fail: "\<And>r r'. \<lbrakk>I r s; C r s; B r s = None\<rbrakk> \<Longrightarrow> Q None"
  assumes final: "\<And>r. \<lbrakk>I r s; \<not>C r s\<rbrakk> \<Longrightarrow> Q (Some r)"
  shows "Q (owhile C B r s)"
proof -
  let ?rs' = "owhile C B r s"
  have "(case ?rs' of Some r \<Rightarrow> I r s | _ \<Rightarrow> Q None)
      \<and> (case ?rs' of Some r' \<Rightarrow> \<not> C r' s | _ \<Rightarrow> True)"
    by (rule option_while_rule'[where B="\<lambda>r. B r s" and s=r, OF _ \<open>wf _\<close>])
       (auto simp: owhile_def intro: assms)
  then show ?thesis by (auto intro: final split: option.split_asm)
qed

end