(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory Noninterference_Base_Refinement
imports Noninterference_Base
        Noninterference_Base_Alternatives
begin

(* we assume the same initial state for both systems *)
locale noninterference_refinement =
   abs?: complete_unwinding_system A s0 dom uwr policy out schedDomain +
   conc?: noninterference_system C s0 dom uwr policy out schedDomain
   for A :: "('a,'s,'e) data_type"
   and s0 :: "'s"
   and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
   and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
   and policy :: "('d \<times> 'd) set"
   and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
   and schedDomain :: "'d"
   and C :: "('c,'s,'e) data_type" +
   assumes refines: "refines C A"

context noninterference_refinement begin

lemma reachable:
  "conc.reachable s \<Longrightarrow> abs.reachable s"
  apply(simp add: conc.reachable_def abs.reachable_def)
  using refines by (fastforce simp: refines_def)

lemma Step:
  "conc.Step a \<subseteq> abs.Step a"
  apply(simp add: conc.Step_def abs.Step_def)
  using refines by(fastforce simp: refines_def)

lemma confidentiality_u_refinement_closed:
  "abs.confidentiality_u \<Longrightarrow> conc.confidentiality_u"
  apply(simp add: abs.confidentiality_u_def)
  apply(subst conc.confidentiality_u_def)
  apply(blast intro: subsetD[OF Step] reachable)
  done

lemma confidentiality_u_weak_refinement_closed:
  "abs.confidentiality_u_weak \<Longrightarrow> conc.confidentiality_u_weak"
  apply(simp add: abs.confidentiality_u_weak_def)
  apply(subst conc.confidentiality_u_weak_def)
  apply(blast intro: subsetD[OF Step] reachable)
  done

lemma integrity_u_refinement_closed:
  "abs.integrity_u \<Longrightarrow> conc.integrity_u"
  apply(simp add: abs.integrity_u_def)
  apply(subst conc.integrity_u_def)
  apply(blast intro: subsetD[OF Step] reachable)
  done

lemma xources_subset:
  "abs.confidentiality_u \<Longrightarrow> abs.xources as s u \<subseteq> conc.xources as s u"
  apply(induct as arbitrary: s u)
   apply(simp add: abs.xources.xources_Nil conc.xources.xources_Nil)
  apply(simp add: abs.xources.xources_Cons conc.xources.xources_Cons)
  apply(rule conjI)
   apply(rule subsetI)
   apply(rule UnI1)
   apply(blast dest: subsetD[OF Step])
  apply(rule subsetI)
  apply(rule UnI2)
  apply(blast dest: subsetD[OF Step])
  done

lemma uwr_equiv:
  "abs.uwr_equiv s as t bs u \<Longrightarrow> conc.uwr_equiv s as t bs u"
  apply(insert refines)
  apply(fastforce simp: abs.uwr_equiv_def conc.uwr_equiv_def simp: refines_def dest: subsetD)
  done

lemma xNonleakage_gen_refinement_closed:
  "abs.xNonleakage_gen \<Longrightarrow> conc.xNonleakage_gen"
  apply(frule abs.xNonleakage_gen_confidentiality_u)
  apply(frule xources_subset)
  apply(clarsimp simp: abs.xNonleakage_gen_def conc.xNonleakage_gen_def)
  apply(drule (1) sameFor_subset_dom[OF _ xources_subset])
  apply(blast dest: reachable uwr_equiv)
  done

end

locale complete_noninterference_refinement = noninterference_refinement A s0 dom uwr policy out schedDomain C
   for A :: "('a,'s,'e) data_type"
   and s0 :: "'s"
   and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
   and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
   and policy :: "('d \<times> 'd) set"
   and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
   and schedDomain :: "'d"
   and C :: "('c,'s,'e) data_type" +
   assumes Step_C: "Step_system C s0"

sublocale complete_noninterference_refinement \<subseteq> conc: complete_unwinding_system C s0 dom uwr policy out schedDomain
  apply(unfold_locales)
    using Step_C apply(fastforce simp: Step_system_def)
   using Step_C apply(fastforce simp: Step_system_def)
  apply(rule policy_refl)
  done

context complete_noninterference_refinement begin
lemma Noninfluence_strong_uwr_refinement_closed:
  "abs.Noninfluence_strong_uwr \<Longrightarrow>
    conc.Noninfluence_strong_uwr"
  apply(frule abs.Noninfluence_strong_uwr_confidentiality_u_weak)
  apply(drule abs.Noninfluence_strong_uwr_integrity_u)
  apply(drule confidentiality_u_weak_refinement_closed)
  apply(drule integrity_u_refinement_closed)
  apply(blast intro: conc.Noninfluence_strong_uwr)
  done

lemma Nonleakage_gen_refinement_closed:
  "abs.Nonleakage_gen \<Longrightarrow>
    conc.Nonleakage_gen"
  apply(simp add: abs.Nonleakage_gen_equiv_confidentiality_u conc.Nonleakage_gen_equiv_confidentiality_u)
  apply(erule confidentiality_u_refinement_closed)
  done

lemma Noninfluence_strong_quasi_refinement_closed:
  "\<lbrakk>abs.confidentiality_u_weak; abs.integrity_u;
        output_consistent\<rbrakk> \<Longrightarrow>
    conc.Noninfluence_strong"
  apply(rule conc.Noninfluence_strong)
    apply(erule confidentiality_u_weak_refinement_closed)
   apply assumption
  apply(erule integrity_u_refinement_closed)
  done

lemma Noninfluence_strong_uwr_quasi_refinement_closed:
  "\<lbrakk>abs.Noninfluence_strong_uwr;
        output_consistent\<rbrakk> \<Longrightarrow>
    conc.Noninfluence_strong"
  apply(rule conc.Noninfluence_strong)
    apply(rule confidentiality_u_weak_refinement_closed)
    apply(erule abs.Noninfluence_strong_uwr_confidentiality_u_weak)
   apply assumption
  apply(rule integrity_u_refinement_closed)
  apply(erule abs.Noninfluence_strong_uwr_integrity_u)
  done

end
end


(*  Title:      HOL/Unix/Unix.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Unix file-systems \label{sec:unix-file-system}\<close>

theory Unix
  imports
    Nested_Environment
    "HOL-Library.Sublist"
begin

text \<open>
  We give a simple mathematical model of the basic structures underlying the
  Unix file-system, together with a few fundamental operations that could be
  imagined to be performed internally by the Unix kernel. This forms the basis
  for the set of Unix system-calls to be introduced later (see
  \secref{sec:unix-trans}), which are the actual interface offered to
  processes running in user-space.

  \<^medskip>
  Basically, any Unix file is either a \<^emph>\<open>plain file\<close> or a \<^emph>\<open>directory\<close>,
  consisting of some \<^emph>\<open>content\<close> plus \<^emph>\<open>attributes\<close>. The content of a plain
  file is plain text. The content of a directory is a mapping from names to
  further files.\<^footnote>\<open>In fact, this is the only way that names get associated with
  files. In Unix files do \<^emph>\<open>not\<close> have a name in itself. Even more, any number
  of names may be associated with the very same file due to \<^emph>\<open>hard links\<close>
  (although this is excluded from our model).\<close> Attributes include information
  to control various ways to access the file (read, write etc.).

  Our model will be quite liberal in omitting excessive detail that is easily
  seen to be ``irrelevant'' for the aspects of Unix file-systems to be
  discussed here. First of all, we ignore character and block special files,
  pipes, sockets, hard links, symbolic links, and mount points.
\<close>

subsection \<open>Names\<close>

text \<open>
  User ids and file name components shall be represented by natural numbers
  (without loss of generality). We do not bother about encoding of actual
  names (e.g.\ strings), nor a mapping between user names and user ids as
  would be present in a reality.
\<close>

type_synonym uid = nat
type_synonym name = nat
type_synonym path = "name list"

subsection \<open>Attributes\<close>

text \<open>
  Unix file attributes mainly consist of \<^emph>\<open>owner\<close> information and a number of
  \<^emph>\<open>permission\<close> bits which control access for ``user'', ``group'', and
  ``others'' (see the Unix man pages \<open>chmod(2)\<close> and \<open>stat(2)\<close> for more
  details).

  \<^medskip>
  Our model of file permissions only considers the ``others'' part. The
  ``user'' field may be omitted without loss of overall generality, since the
  owner is usually able to change it anyway by performing \<open>chmod\<close>.\<^footnote>\<open>The
  inclined Unix expert may try to figure out some exotic arrangements of a
  real-world Unix file-system such that the owner of a file is unable to apply
  the \<open>chmod\<close> system call.\<close> We omit ``group'' permissions as a genuine
  simplification as we just do not intend to discuss a model of multiple
  groups and group membership, but pretend that everyone is member of a single
  global group.\<^footnote>\<open>A general HOL model of user group structures and related
  issues is given in \<^cite>\<open>"Naraschewski:2001"\<close>.\<close>
\<close>

datatype perm =
    Readable
  | Writable
  | Executable    \<comment> \<open>(ignored)\<close>

type_synonym perms = "perm set"

record att =
  owner :: uid
  others :: perms

text \<open>
  For plain files \<^term>\<open>Readable\<close> and \<^term>\<open>Writable\<close> specify read and write
  access to the actual content, i.e.\ the string of text stored here. For
  directories \<^term>\<open>Readable\<close> determines if the set of entry names may be
  accessed, and \<^term>\<open>Writable\<close> controls the ability to create or delete any
  entries (both plain files or sub-directories).

  As another simplification, we ignore the \<^term>\<open>Executable\<close> permission
  altogether. In reality it would indicate executable plain files (also known
  as ``binaries''), or control actual lookup of directory entries (recall that
  mere directory browsing is controlled via \<^term>\<open>Readable\<close>). Note that the
  latter means that in order to perform any file-system operation whatsoever,
  all directories encountered on the path would have to grant
  \<^term>\<open>Executable\<close>. We ignore this detail and pretend that all directories
  give \<^term>\<open>Executable\<close> permission to anybody.
\<close>

subsection \<open>Files\<close>

text \<open>
  In order to model the general tree structure of a Unix file-system we use
  the arbitrarily branching datatype \<^typ>\<open>('a, 'b, 'c) env\<close> from the
  standard library of Isabelle/HOL \<^cite>\<open>"Bauer-et-al:2002:HOL-Library"\<close>.
  This type provides constructors \<^term>\<open>Val\<close> and \<^term>\<open>Env\<close> as follows:

  \<^medskip>
  {\def\isastyleminor{\isastyle}
  \begin{tabular}{l}
  @{term [source] "Val :: 'a \<Rightarrow> ('a, 'b, 'c) env"} \\
  @{term [source] "Env :: 'b \<Rightarrow> ('c \<Rightarrow> ('a, 'b, 'c) env option) \<Rightarrow> ('a, 'b, 'c) env"} \\
  \end{tabular}}
  \<^medskip>

  Here the parameter \<^typ>\<open>'a\<close> refers to plain values occurring at leaf
  positions, parameter \<^typ>\<open>'b\<close> to information kept with inner branch
  nodes, and parameter \<^typ>\<open>'c\<close> to the branching type of the tree
  structure. For our purpose we use the type instance with \<^typ>\<open>att \<times>
  string\<close> (representing plain files), \<^typ>\<open>att\<close> (for attributes of
  directory nodes), and \<^typ>\<open>name\<close> (for the index type of directory nodes).
\<close>

type_synonym "file" = "(att \<times> string, att, name) env"

text \<open>
  \<^medskip>
  The HOL library also provides \<^term>\<open>lookup\<close> and \<^term>\<open>update\<close> operations
  for general tree structures with the subsequent primitive recursive
  characterizations.

  \<^medskip>
  {\def\isastyleminor{\isastyle}
  \begin{tabular}{l}
  @{term [source] "lookup :: ('a, 'b, 'c) env \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"} \\
  @{term [source]
  "update :: 'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow> ('a, 'b, 'c) env \<Rightarrow> ('a, 'b, 'c) env"} \\
  \end{tabular}}

  @{thm [display, indent = 2, eta_contract = false] lookup_eq [no_vars]}
  @{thm [display, indent = 2, eta_contract = false] update_eq [no_vars]}

  Several further properties of these operations are proven in \<^cite>\<open>"Bauer-et-al:2002:HOL-Library"\<close>. These will be routinely used later on
  without further notice.

  \<^bigskip>
  Apparently, the elements of type \<^typ>\<open>file\<close> contain an \<^typ>\<open>att\<close>
  component in either case. We now define a few auxiliary operations to
  manipulate this field uniformly, following the conventions for record types
  in Isabelle/HOL \<^cite>\<open>"Nipkow-et-al:2000:HOL"\<close>.
\<close>

definition
  "attributes file =
    (case file of
      Val (att, text) \<Rightarrow> att
    | Env att dir \<Rightarrow> att)"

definition
  "map_attributes f file =
    (case file of
      Val (att, text) \<Rightarrow> Val (f att, text)
    | Env att dir \<Rightarrow> Env (f att) dir)"

lemma [simp]: "attributes (Env att dir) = att"
  by (simp add: attributes_def)

lemma [simp]: "attributes (map_attributes f file) = f (attributes file)"
  by (cases "file") (simp_all add: attributes_def map_attributes_def
    split_tupled_all)

lemma [simp]: "map_attributes f (Val (att, text)) = Val (f att, text)"
  by (simp add: map_attributes_def)

lemma [simp]: "map_attributes f (Env att dir) = Env (f att) dir"
  by (simp add: map_attributes_def)

subsection \<open>Initial file-systems\<close>

text \<open>
  Given a set of \<^emph>\<open>known users\<close> a file-system shall be initialized by
  providing an empty home directory for each user, with read-only access for
  everyone else. (Note that we may directly use the user id as home directory
  name, since both types have been identified.) Certainly, the very root
  directory is owned by the super user (who has user id 0).
\<close>

definition
  "init users =
    Env \<lparr>owner = 0, others = {Readable}\<rparr>
      (\<lambda>u. if u \<in> users then Some (Env \<lparr>owner = u, others = {Readable}\<rparr> Map.empty)
        else None)"

subsection \<open>Accessing file-systems\<close>

text \<open>
  The main internal file-system operation is access of a file by a user,
  requesting a certain set of permissions. The resulting \<^typ>\<open>file option\<close>
  indicates if a file had been present at the corresponding \<^typ>\<open>path\<close> and if
  access was granted according to the permissions recorded within the
  file-system.

  Note that by the rules of Unix file-system security (e.g.\ \<^cite>\<open>"Tanenbaum:1992"\<close>) both the super-user and owner may always access a file
  unconditionally (in our simplified model).
\<close>

definition
  "access root path uid perms =
    (case lookup root path of
      None \<Rightarrow> None
    | Some file \<Rightarrow>
        if uid = 0
          \<or> uid = owner (attributes file)
          \<or> perms \<subseteq> others (attributes file)
        then Some file
        else None)"

text \<open>
  \<^medskip>
  Successful access to a certain file is the main prerequisite for
  system-calls to be applicable (cf.\ \secref{sec:unix-trans}). Any
  modification of the file-system is then performed using the basic
  \<^term>\<open>update\<close> operation.

  \<^medskip>
  We see that \<^term>\<open>access\<close> is just a wrapper for the basic \<^term>\<open>lookup\<close>
  function, with additional checking of attributes. Subsequently we establish
  a few auxiliary facts that stem from the primitive \<^term>\<open>lookup\<close> used
  within \<^term>\<open>access\<close>.
\<close>

lemma access_empty_lookup: "access root path uid {} = lookup root path"
  by (simp add: access_def split: option.splits)

lemma access_some_lookup:
  "access root path uid perms = Some file \<Longrightarrow>
    lookup root path = Some file"
  by (simp add: access_def split: option.splits if_splits)

lemma access_update_other:
  assumes parallel: "path' \<parallel> path"
  shows "access (update path' opt root) path uid perms = access root path uid perms"
proof -
  from parallel obtain y z xs ys zs where
      "y \<noteq> z" and "path' = xs @ y # ys" and "path = xs @ z # zs"
    by (blast dest: parallel_decomp)
  then have "lookup (update path' opt root) path = lookup root path"
    by (blast intro: lookup_update_other)
  then show ?thesis by (simp only: access_def)
qed

section \<open>File-system transitions \label{sec:unix-trans}\<close>

subsection \<open>Unix system calls \label{sec:unix-syscall}\<close>

text \<open>
  According to established operating system design (cf.\ \<^cite>\<open>"Tanenbaum:1992"\<close>) user space processes may only initiate system operations
  by a fixed set of \<^emph>\<open>system-calls\<close>. This enables the kernel to enforce
  certain security policies in the first place.\<^footnote>\<open>Incidently, this is the very
  same principle employed by any ``LCF-style'' theorem proving system
  according to Milner's principle of ``correctness by construction'', such as
  Isabelle/HOL itself.\<close>

  \<^medskip>
  In our model of Unix we give a fixed datatype \<open>operation\<close> for the syntax of
  system-calls, together with an inductive definition of file-system state
  transitions of the form \<open>root \<midarrow>x\<rightarrow> root'\<close> for the operational semantics.
\<close>

datatype operation =
    Read uid string path
  | Write uid string path
  | Chmod uid perms path
  | Creat uid perms path
  | Unlink uid path
  | Mkdir uid perms path
  | Rmdir uid path
  | Readdir uid "name set" path

text \<open>
  The \<^typ>\<open>uid\<close> field of an operation corresponds to the \<^emph>\<open>effective user id\<close>
  of the underlying process, although our model never mentions processes
  explicitly. The other parameters are provided as arguments by the caller;
  the \<^term>\<open>path\<close> one is common to all kinds of system-calls.
\<close>

primrec uid_of :: "operation \<Rightarrow> uid"
  where
    "uid_of (Read uid text path) = uid"
  | "uid_of (Write uid text path) = uid"
  | "uid_of (Chmod uid perms path) = uid"
  | "uid_of (Creat uid perms path) = uid"
  | "uid_of (Unlink uid path) = uid"
  | "uid_of (Mkdir uid path perms) = uid"
  | "uid_of (Rmdir uid path) = uid"
  | "uid_of (Readdir uid names path) = uid"

primrec path_of :: "operation \<Rightarrow> path"
  where
    "path_of (Read uid text path) = path"
  | "path_of (Write uid text path) = path"
  | "path_of (Chmod uid perms path) = path"
  | "path_of (Creat uid perms path) = path"
  | "path_of (Unlink uid path) = path"
  | "path_of (Mkdir uid perms path) = path"
  | "path_of (Rmdir uid path) = path"
  | "path_of (Readdir uid names path) = path"

text \<open>
  \<^medskip>
  Note that we have omitted explicit \<open>Open\<close> and \<open>Close\<close> operations, pretending
  that \<^term>\<open>Read\<close> and \<^term>\<open>Write\<close> would already take care of this behind
  the scenes. Thus we have basically treated actual sequences of real
  system-calls \<open>open\<close>--\<open>read\<close>/\<open>write\<close>--\<open>close\<close> as atomic.

  In principle, this could make big a difference in a model with explicit
  concurrent processes. On the other hand, even on a real Unix system the
  exact scheduling of concurrent \<open>open\<close> and \<open>close\<close> operations does \<^emph>\<open>not\<close>
  directly affect the success of corresponding \<open>read\<close> or \<open>write\<close>. Unix allows
  several processes to have files opened at the same time, even for writing!
  Certainly, the result from reading the contents later may be hard to
  predict, but the system-calls involved here will succeed in any case.

  \<^bigskip>
  The operational semantics of system calls is now specified via transitions
  of the file-system configuration. This is expressed as an inductive relation
  (although there is no actual recursion involved here).
\<close>

inductive transition :: "file \<Rightarrow> operation \<Rightarrow> file \<Rightarrow> bool"
  ("_ \<midarrow>_\<rightarrow> _" [90, 1000, 90] 100)
  where
    read:
      "root \<midarrow>(Read uid text path)\<rightarrow> root"
      if "access root path uid {Readable} = Some (Val (att, text))"
  | "write":
      "root \<midarrow>(Write uid text path)\<rightarrow> update path (Some (Val (att, text))) root"
      if "access root path uid {Writable} = Some (Val (att, text'))"
  | chmod:
      "root \<midarrow>(Chmod uid perms path)\<rightarrow>
        update path (Some (map_attributes (others_update (\<lambda>_. perms)) file)) root"
      if "access root path uid {} = Some file" and "uid = 0 \<or> uid = owner (attributes file)"
  | creat:
      "root \<midarrow>(Creat uid perms path)\<rightarrow>
        update path (Some (Val (\<lparr>owner = uid, others = perms\<rparr>, []))) root"
      if "path = parent_path @ [name]"
      and "access root parent_path uid {Writable} = Some (Env att parent)"
      and "access root path uid {} = None"
  | unlink:
      "root \<midarrow>(Unlink uid path)\<rightarrow> update path None root"
      if "path = parent_path @ [name]"
      and "access root parent_path uid {Writable} = Some (Env att parent)"
      and "access root path uid {} = Some (Val plain)"
  | mkdir:
      "root \<midarrow>(Mkdir uid perms path)\<rightarrow>
        update path (Some (Env \<lparr>owner = uid, others = perms\<rparr> Map.empty)) root"
      if "path = parent_path @ [name]"
      and "access root parent_path uid {Writable} = Some (Env att parent)"
      and "access root path uid {} = None"
  | rmdir:
      "root \<midarrow>(Rmdir uid path)\<rightarrow> update path None root"
      if "path = parent_path @ [name]"
      and "access root parent_path uid {Writable} = Some (Env att parent)"
      and "access root path uid {} = Some (Env att' Map.empty)"
  | readdir:
      "root \<midarrow>(Readdir uid names path)\<rightarrow> root"
      if "access root path uid {Readable} = Some (Env att dir)"
      and "names = dom dir"

text \<open>
  \<^medskip>
  Certainly, the above specification is central to the whole formal
  development. Any of the results to be established later on are only
  meaningful to the outside world if this transition system provides an
  adequate model of real Unix systems. This kind of ``reality-check'' of a
  formal model is the well-known problem of \<^emph>\<open>validation\<close>.

  If in doubt, one may consider to compare our definition with the informal
  specifications given the corresponding Unix man pages, or even peek at an
  actual implementation such as \<^cite>\<open>"Torvalds-et-al:Linux"\<close>. Another common
  way to gain confidence into the formal model is to run simple simulations
  (see \secref{sec:unix-examples}), and check the results with that of
  experiments performed on a real Unix system.
\<close>

subsection \<open>Basic properties of single transitions \label{sec:unix-single-trans}\<close>

text \<open>
  The transition system \<open>root \<midarrow>x\<rightarrow> root'\<close> defined above determines a unique
  result \<^term>\<open>root'\<close> from given \<^term>\<open>root\<close> and \<^term>\<open>x\<close> (this is
  holds rather trivially, since there is even only one clause for each
  operation). This uniqueness statement will simplify our subsequent
  development to some extent, since we only have to reason about a partial
  function rather than a general relation.
\<close>

theorem transition_uniq:
  assumes root': "root \<midarrow>x\<rightarrow> root'"
    and root'': "root \<midarrow>x\<rightarrow> root''"
  shows "root' = root''"
  using root''
proof cases
  case read
  with root' show ?thesis by cases auto
next
  case "write"
  with root' show ?thesis by cases auto
next
  case chmod
  with root' show ?thesis by cases auto
next
  case creat
  with root' show ?thesis by cases auto
next
  case unlink
  with root' show ?thesis by cases auto
next
  case mkdir
  with root' show ?thesis by cases auto
next
  case rmdir
  with root' show ?thesis by cases auto
next
  case readdir
  with root' show ?thesis by cases blast+
qed

text \<open>
  \<^medskip>
  Apparently, file-system transitions are \<^emph>\<open>type-safe\<close> in the sense that the
  result of transforming an actual directory yields again a directory.
\<close>

theorem transition_type_safe:
  assumes tr: "root \<midarrow>x\<rightarrow> root'"
    and inv: "\<exists>att dir. root = Env att dir"
  shows "\<exists>att dir. root' = Env att dir"
proof (cases "path_of x")
  case Nil
  with tr inv show ?thesis
    by cases (auto simp add: access_def split: if_splits)
next
  case Cons
  from tr obtain opt where
      "root' = root \<or> root' = update (path_of x) opt root"
    by cases auto
  with inv Cons show ?thesis
    by (auto simp add: update_eq split: list.splits)
qed

text \<open>
  The previous result may be seen as the most basic invariant on the
  file-system state that is enforced by any proper kernel implementation. So
  user processes --- being bound to the system-call interface --- may never
  mess up a file-system such that the root becomes a plain file instead of a
  directory, which would be a strange situation indeed.
\<close>

subsection \<open>Iterated transitions\<close>

text \<open>
  Iterated system transitions via finite sequences of system operations are
  modeled inductively as follows. In a sense, this relation describes the
  cumulative effect of the sequence of system-calls issued by a number of
  running processes over a finite amount of time.
\<close>

inductive transitions :: "file \<Rightarrow> operation list \<Rightarrow> file \<Rightarrow> bool"  ("_ \<Midarrow>_\<Rightarrow> _" [90, 1000, 90] 100)
  where
    nil: "root \<Midarrow>[]\<Rightarrow> root"
  | cons: "root \<Midarrow>(x # xs)\<Rightarrow> root''" if "root \<midarrow>x\<rightarrow> root'" and "root' \<Midarrow>xs\<Rightarrow> root''"

text \<open>
  \<^medskip>
  We establish a few basic facts relating iterated transitions with single
  ones, according to the recursive structure of lists.
\<close>

lemma transitions_nil_eq: "root \<Midarrow>[]\<Rightarrow> root' \<longleftrightarrow> root = root'"
proof
  assume "root \<Midarrow>[]\<Rightarrow> root'"
  then show "root = root'" by cases simp_all
next
  assume "root = root'"
  then show "root \<Midarrow>[]\<Rightarrow> root'" by (simp only: transitions.nil)
qed

lemma transitions_cons_eq:
  "root \<Midarrow>(x # xs)\<Rightarrow> root'' \<longleftrightarrow> (\<exists>root'. root \<midarrow>x\<rightarrow> root' \<and> root' \<Midarrow>xs\<Rightarrow> root'')"
proof
  assume "root \<Midarrow>(x # xs)\<Rightarrow> root''"
  then show "\<exists>root'. root \<midarrow>x\<rightarrow> root' \<and> root' \<Midarrow>xs\<Rightarrow> root''"
    by cases auto
next
  assume "\<exists>root'. root \<midarrow>x\<rightarrow> root' \<and> root' \<Midarrow>xs\<Rightarrow> root''"
  then show "root \<Midarrow>(x # xs)\<Rightarrow> root''"
    by (blast intro: transitions.cons)
qed

text \<open>
  The next two rules show how to ``destruct'' known transition sequences. Note
  that the second one actually relies on the uniqueness property of the basic
  transition system (see \secref{sec:unix-single-trans}).
\<close>

lemma transitions_nilD: "root \<Midarrow>[]\<Rightarrow> root' \<Longrightarrow> root' = root"
  by (simp add: transitions_nil_eq)

lemma transitions_consD:
  assumes list: "root \<Midarrow>(x # xs)\<Rightarrow> root''"
    and hd: "root \<midarrow>x\<rightarrow> root'"
  shows "root' \<Midarrow>xs\<Rightarrow> root''"
proof -
  from list obtain r' where r': "root \<midarrow>x\<rightarrow> r'" and root'': "r' \<Midarrow>xs\<Rightarrow> root''"
    by cases simp_all
  from r' hd have "r' = root'" by (rule transition_uniq)
  with root'' show "root' \<Midarrow>xs\<Rightarrow> root''" by simp
qed

text \<open>
  \<^medskip>
  The following fact shows how an invariant \<^term>\<open>Q\<close> of single transitions
  with property \<^term>\<open>P\<close> may be transferred to iterated transitions. The
  proof is rather obvious by rule induction over the definition of
  \<^term>\<open>root \<Midarrow>xs\<Rightarrow> root'\<close>.
\<close>

lemma transitions_invariant:
  assumes r: "\<And>r x r'. r \<midarrow>x\<rightarrow> r' \<Longrightarrow> Q r \<Longrightarrow> P x \<Longrightarrow> Q r'"
    and trans: "root \<Midarrow>xs\<Rightarrow> root'"
  shows "Q root \<Longrightarrow> \<forall>x \<in> set xs. P x \<Longrightarrow> Q root'"
  using trans
proof induct
  case nil
  show ?case by (rule nil.prems)
next
  case (cons root x root' xs root'')
  note P = \<open>\<forall>x \<in> set (x # xs). P x\<close>
  then have "P x" by simp
  with \<open>root \<midarrow>x\<rightarrow> root'\<close> and \<open>Q root\<close> have Q': "Q root'" by (rule r)
  from P have "\<forall>x \<in> set xs. P x" by simp
  with Q' show "Q root''" by (rule cons.hyps)
qed

text \<open>
  As an example of applying the previous result, we transfer the basic
  type-safety property (see \secref{sec:unix-single-trans}) from single
  transitions to iterated ones, which is a rather obvious result indeed.
\<close>

theorem transitions_type_safe:
  assumes "root \<Midarrow>xs\<Rightarrow> root'"
    and "\<exists>att dir. root = Env att dir"
  shows "\<exists>att dir. root' = Env att dir"
  using transition_type_safe and assms
proof (rule transitions_invariant)
  show "\<forall>x \<in> set xs. True" by blast
qed

section \<open>Executable sequences\<close>

text \<open>
  An inductively defined relation such as the one of \<open>root \<midarrow>x\<rightarrow> root'\<close> (see
  \secref{sec:unix-syscall}) has two main aspects. First of all, the resulting
  system admits a certain set of transition rules (introductions) as given in
  the specification. Furthermore, there is an explicit least-fixed-point
  construction involved, which results in induction (and case-analysis) rules
  to eliminate known transitions in an exhaustive manner.

  \<^medskip>
  Subsequently, we explore our transition system in an experimental style,
  mainly using the introduction rules with basic algebraic properties of the
  underlying structures. The technique closely resembles that of Prolog
  combined with functional evaluation in a very simple manner.

  Just as the ``closed-world assumption'' is left implicit in Prolog, we do
  not refer to induction over the whole transition system here. So this is
  still purely positive reasoning about possible executions; exhaustive
  reasoning will be employed only later on (see \secref{sec:unix-bogosity}),
  when we shall demonstrate that certain behavior is \<^emph>\<open>not\<close> possible.
\<close>

subsection \<open>Possible transitions\<close>

text \<open>
  Rather obviously, a list of system operations can be executed within a
  certain state if there is a result state reached by an iterated transition.
\<close>

definition "can_exec root xs \<longleftrightarrow> (\<exists>root'. root \<Midarrow>xs\<Rightarrow> root')"

lemma can_exec_nil: "can_exec root []"
  unfolding can_exec_def by (blast intro: transitions.intros)

lemma can_exec_cons:
    "root \<midarrow>x\<rightarrow> root' \<Longrightarrow> can_exec root' xs \<Longrightarrow> can_exec root (x # xs)"
  unfolding can_exec_def by (blast intro: transitions.intros)

text \<open>
  \<^medskip>
  In case that we already know that a certain sequence can be executed we may
  destruct it backwardly into individual transitions.
\<close>

lemma can_exec_snocD: "can_exec root (xs @ [y])
    \<Longrightarrow> \<exists>root' root''. root \<Midarrow>xs\<Rightarrow> root' \<and> root' \<midarrow>y\<rightarrow> root''"
proof (induct xs arbitrary: root)
  case Nil
  then show ?case
    by (simp add: can_exec_def transitions_nil_eq transitions_cons_eq)
next
  case (Cons x xs)
  from \<open>can_exec root ((x # xs) @ [y])\<close> obtain r root'' where
      x: "root \<midarrow>x\<rightarrow> r" and
      xs_y: "r \<Midarrow>(xs @ [y])\<Rightarrow> root''"
    by (auto simp add: can_exec_def transitions_nil_eq transitions_cons_eq)
  from xs_y Cons.hyps obtain root' r'
    where xs: "r \<Midarrow>xs\<Rightarrow> root'" and y: "root' \<midarrow>y\<rightarrow> r'"
    unfolding can_exec_def by blast
  from x xs have "root \<Midarrow>(x # xs)\<Rightarrow> root'"
    by (rule transitions.cons)
  with y show ?case by blast
qed

subsection \<open>Example executions \label{sec:unix-examples}\<close>

text \<open>
  We are now ready to perform a few experiments within our formal model of
  Unix system-calls. The common technique is to alternate introduction rules
  of the transition system (see \secref{sec:unix-trans}), and steps to solve
  any emerging side conditions using algebraic properties of the underlying
  file-system structures (see \secref{sec:unix-file-system}).
\<close>

lemmas eval = access_def init_def

theorem "u \<in> users \<Longrightarrow> can_exec (init users)
    [Mkdir u perms [u, name]]"
  apply (rule can_exec_cons)
    \<comment> \<open>back-chain \<^term>\<open>can_exec\<close> (of @{term [source] Cons})\<close>
  apply (rule mkdir)
    \<comment> \<open>back-chain \<^term>\<open>Mkdir\<close>\<close>
  apply (force simp add: eval)+
    \<comment> \<open>solve preconditions of \<^term>\<open>Mkdir\<close>\<close>
  apply (simp add: eval)
    \<comment> \<open>peek at resulting dir (optional)\<close>
  txt \<open>@{subgoals [display]}\<close>
  apply (rule can_exec_nil)
    \<comment> \<open>back-chain \<^term>\<open>can_exec\<close> (of @{term [source] Nil})\<close>
  done

text \<open>
  By inspecting the result shown just before the final step above, we may gain
  confidence that our specification of Unix system-calls actually makes sense.
  Further common errors are usually exhibited when preconditions of transition
  rules fail unexpectedly.

  \<^medskip>
  Here are a few further experiments, using the same techniques as before.
\<close>

theorem "u \<in> users \<Longrightarrow> can_exec (init users)
   [Creat u perms [u, name],
    Unlink u [u, name]]"
  apply (rule can_exec_cons)
  apply (rule creat)
  apply (force simp add: eval)+
  apply (simp add: eval)
  apply (rule can_exec_cons)
  apply (rule unlink)
  apply (force simp add: eval)+
  apply (simp add: eval)
  txt \<open>peek at result: @{subgoals [display]}\<close>
  apply (rule can_exec_nil)
  done

theorem "u \<in> users \<Longrightarrow> Writable \<in> perms\<^sub>1 \<Longrightarrow>
  Readable \<in> perms\<^sub>2 \<Longrightarrow> name\<^sub>3 \<noteq> name\<^sub>4 \<Longrightarrow>
  can_exec (init users)
   [Mkdir u perms\<^sub>1 [u, name\<^sub>1],
    Mkdir u' perms\<^sub>2 [u, name\<^sub>1, name\<^sub>2],
    Creat u' perms\<^sub>3 [u, name\<^sub>1, name\<^sub>2, name\<^sub>3],
    Creat u' perms\<^sub>3 [u, name\<^sub>1, name\<^sub>2, name\<^sub>4],
    Readdir u {name\<^sub>3, name\<^sub>4} [u, name\<^sub>1, name\<^sub>2]]"
  apply (rule can_exec_cons, rule transition.intros,
    (force simp add: eval)+, (simp add: eval)?)+
  txt \<open>peek at result: @{subgoals [display]}\<close>
  apply (rule can_exec_nil)
  done

theorem "u \<in> users \<Longrightarrow> Writable \<in> perms\<^sub>1 \<Longrightarrow> Readable \<in> perms\<^sub>3 \<Longrightarrow>
  can_exec (init users)
   [Mkdir u perms\<^sub>1 [u, name\<^sub>1],
    Mkdir u' perms\<^sub>2 [u, name\<^sub>1, name\<^sub>2],
    Creat u' perms\<^sub>3 [u, name\<^sub>1, name\<^sub>2, name\<^sub>3],
    Write u' ''foo'' [u, name\<^sub>1, name\<^sub>2, name\<^sub>3],
    Read u ''foo'' [u, name\<^sub>1, name\<^sub>2, name\<^sub>3]]"
  apply (rule can_exec_cons, rule transition.intros,
    (force simp add: eval)+, (simp add: eval)?)+
  txt \<open>peek at result: @{subgoals [display]}\<close>
  apply (rule can_exec_nil)
  done

section \<open>Odd effects --- treated formally \label{sec:unix-bogosity}\<close>

text \<open>
  We are now ready to give a completely formal treatment of the slightly odd
  situation discussed in the introduction (see \secref{sec:unix-intro}): the
  file-system can easily reach a state where a user is unable to remove his
  very own directory, because it is still populated by items placed there by
  another user in an uncouth manner.
\<close>

subsection \<open>The general procedure \label{sec:unix-inv-procedure}\<close>

text \<open>
  The following theorem expresses the general procedure we are following to
  achieve the main result.
\<close>

theorem general_procedure:
  assumes cannot_y: "\<And>r r'. Q r \<Longrightarrow> r \<midarrow>y\<rightarrow> r' \<Longrightarrow> False"
    and init_inv: "\<And>root. init users \<Midarrow>bs\<Rightarrow> root \<Longrightarrow> Q root"
    and preserve_inv: "\<And>r x r'. r \<midarrow>x\<rightarrow> r' \<Longrightarrow> Q r \<Longrightarrow> P x \<Longrightarrow> Q r'"
    and init_result: "init users \<Midarrow>bs\<Rightarrow> root"
  shows "\<not> (\<exists>xs. (\<forall>x \<in> set xs. P x) \<and> can_exec root (xs @ [y]))"
proof -
  {
    fix xs
    assume Ps: "\<forall>x \<in> set xs. P x"
    assume can_exec: "can_exec root (xs @ [y])"
    then obtain root' root'' where xs: "root \<Midarrow>xs\<Rightarrow> root'" and y: "root' \<midarrow>y\<rightarrow> root''"
      by (blast dest: can_exec_snocD)
    from init_result have "Q root" by (rule init_inv)
    from preserve_inv xs this Ps have "Q root'"
      by (rule transitions_invariant)
    from this y have False by (rule cannot_y)
  }
  then show ?thesis by blast
qed

text \<open>
  Here \<^prop>\<open>P x\<close> refers to the restriction on file-system operations that
  are admitted after having reached the critical configuration; according to
  the problem specification this will become \<^prop>\<open>uid_of x = user\<^sub>1\<close> later
  on. Furthermore, \<^term>\<open>y\<close> refers to the operations we claim to be
  impossible to perform afterwards, we will take \<^term>\<open>Rmdir\<close> later. Moreover
  \<^term>\<open>Q\<close> is a suitable (auxiliary) invariant over the file-system; choosing
  \<^term>\<open>Q\<close> adequately is very important to make the proof work (see
  \secref{sec:unix-inv-lemmas}).
\<close>

subsection \<open>The particular situation\<close>

text \<open>
  We introduce a few global declarations and axioms to describe our particular
  situation considered here. Thus we avoid excessive use of local parameters
  in the subsequent development.
\<close>

context
  fixes users :: "uid set"
    and user\<^sub>1 :: uid
    and user\<^sub>2 :: uid
    and name\<^sub>1 :: name
    and name\<^sub>2 :: name
    and name\<^sub>3 :: name
    and perms\<^sub>1 :: perms
    and perms\<^sub>2 :: perms
  assumes user\<^sub>1_known: "user\<^sub>1 \<in> users"
    and user\<^sub>1_not_root: "user\<^sub>1 \<noteq> 0"
    and users_neq: "user\<^sub>1 \<noteq> user\<^sub>2"
    and perms\<^sub>1_writable: "Writable \<in> perms\<^sub>1"
    and perms\<^sub>2_not_writable: "Writable \<notin> perms\<^sub>2"
  notes facts = user\<^sub>1_known user\<^sub>1_not_root users_neq
    perms\<^sub>1_writable perms\<^sub>2_not_writable
begin

definition
  "bogus =
     [Mkdir user\<^sub>1 perms\<^sub>1 [user\<^sub>1, name\<^sub>1],
      Mkdir user\<^sub>2 perms\<^sub>2 [user\<^sub>1, name\<^sub>1, name\<^sub>2],
      Creat user\<^sub>2 perms\<^sub>2 [user\<^sub>1, name\<^sub>1, name\<^sub>2, name\<^sub>3]]"

definition "bogus_path = [user\<^sub>1, name\<^sub>1, name\<^sub>2]"

text \<open>
  The \<^term>\<open>bogus\<close> operations are the ones that lead into the uncouth
  situation; \<^term>\<open>bogus_path\<close> is the key position within the file-system
  where things go awry.
\<close>

subsection \<open>Invariance lemmas \label{sec:unix-inv-lemmas}\<close>

text \<open>
  The following invariant over the root file-system describes the bogus
  situation in an abstract manner: located at a certain \<^term>\<open>path\<close> within
  the file-system is a non-empty directory that is neither owned nor writable
  by \<^term>\<open>user\<^sub>1\<close>.
\<close>

definition
  "invariant root path \<longleftrightarrow>
    (\<exists>att dir.
      access root path user\<^sub>1 {} = Some (Env att dir) \<and> dir \<noteq> Map.empty \<and>
      user\<^sub>1 \<noteq> owner att \<and>
      access root path user\<^sub>1 {Writable} = None)"

text \<open>
  Following the general procedure (see \secref{sec:unix-inv-procedure}) we
  will now establish the three key lemmas required to yield the final result.

    \<^enum> The invariant is sufficiently strong to entail the pathological case
    that \<^term>\<open>user\<^sub>1\<close> is unable to remove the (owned) directory at
    \<^term>\<open>[user\<^sub>1, name\<^sub>1]\<close>.

    \<^enum> The invariant does hold after having executed the \<^term>\<open>bogus\<close> list of
    operations (starting with an initial file-system configuration).

    \<^enum> The invariant is preserved by any file-system operation performed by
    \<^term>\<open>user\<^sub>1\<close> alone, without any help by other users.

  As the invariant appears both as assumptions and conclusions in the course
  of proof, its formulation is rather critical for the whole development to
  work out properly. In particular, the third step is very sensitive to the
  invariant being either too strong or too weak. Moreover the invariant has to
  be sufficiently abstract, lest the proof become cluttered by confusing
  detail.

  \<^medskip>
  The first two lemmas are technically straight forward --- we just have to
  inspect rather special cases.
\<close>

lemma cannot_rmdir:
  assumes inv: "invariant root bogus_path"
    and rmdir: "root \<midarrow>(Rmdir user\<^sub>1 [user\<^sub>1, name\<^sub>1])\<rightarrow> root'"
  shows False
proof -
  from inv obtain "file" where "access root bogus_path user\<^sub>1 {} = Some file"
    unfolding invariant_def by blast
  moreover
  from rmdir obtain att where "access root [user\<^sub>1, name\<^sub>1] user\<^sub>1 {} = Some (Env att Map.empty)"
    by cases auto
  then have "access root ([user\<^sub>1, name\<^sub>1] @ [name\<^sub>2]) user\<^sub>1 {} = Map.empty name\<^sub>2"
    by (simp only: access_empty_lookup lookup_append_some) simp
  ultimately show False by (simp add: bogus_path_def)
qed

lemma
  assumes init: "init users \<Midarrow>bogus\<Rightarrow> root"
  shows init_invariant: "invariant root bogus_path"
  supply eval = facts access_def init_def
  using init
  apply (unfold bogus_def bogus_path_def)
  apply (drule transitions_consD, rule transition.intros,
      (force simp add: eval)+, (simp add: eval)?)+
    \<comment> \<open>evaluate all operations\<close>
  apply (drule transitions_nilD)
    \<comment> \<open>reach final result\<close>
  apply (simp add: invariant_def eval)
    \<comment> \<open>check the invariant\<close>
  done

text \<open>
  \<^medskip>
  At last we are left with the main effort to show that the ``bogosity''
  invariant is preserved by any file-system operation performed by
  \<^term>\<open>user\<^sub>1\<close> alone. Note that this holds for any \<^term>\<open>path\<close> given,
  the particular \<^term>\<open>bogus_path\<close> is not required here.
\<close>

lemma preserve_invariant:
  assumes tr: "root \<midarrow>x\<rightarrow> root'"
    and inv: "invariant root path"
    and uid: "uid_of x = user\<^sub>1"
  shows "invariant root' path"
proof -
  from inv obtain att dir where
      inv1: "access root path user\<^sub>1 {} = Some (Env att dir)" and
      inv2: "dir \<noteq> Map.empty" and
      inv3: "user\<^sub>1 \<noteq> owner att" and
      inv4: "access root path user\<^sub>1 {Writable} = None"
    by (auto simp add: invariant_def)

  from inv1 have lookup: "lookup root path = Some (Env att dir)"
    by (simp only: access_empty_lookup)

  from inv1 inv3 inv4 and user\<^sub>1_not_root
  have not_writable: "Writable \<notin> others att"
    by (auto simp add: access_def split: option.splits)

  show ?thesis
  proof cases
    assume "root' = root"
    with inv show "invariant root' path" by (simp only:)
  next
    assume changed: "root' \<noteq> root"
    with tr obtain opt where root': "root' = update (path_of x) opt root"
      by cases auto
    show ?thesis
    proof (rule prefix_cases)
      assume "path_of x \<parallel> path"
      with inv root'
      have "\<And>perms. access root' path user\<^sub>1 perms = access root path user\<^sub>1 perms"
        by (simp only: access_update_other)
      with inv show "invariant root' path"
        by (simp only: invariant_def)
    next
      assume "prefix (path_of x) path"
      then obtain ys where path: "path = path_of x @ ys" ..

      show ?thesis
      proof (cases ys)
        assume "ys = []"
        with tr uid inv2 inv3 lookup changed path and user\<^sub>1_not_root
        have False
          by cases (auto simp add: access_empty_lookup dest: access_some_lookup)
        then show ?thesis ..
      next
        fix z zs assume ys: "ys = z # zs"
        have "lookup root' path = lookup root path"
        proof -
          from inv2 lookup path ys
          have look: "lookup root (path_of x @ z # zs) = Some (Env att dir)"
            by (simp only:)
          then obtain att' dir' file' where
              look': "lookup root (path_of x) = Some (Env att' dir')" and
              dir': "dir' z = Some file'" and
              file': "lookup file' zs = Some (Env att dir)"
            by (blast dest: lookup_some_upper)

          from tr uid changed look' dir' obtain att'' where
              look'': "lookup root' (path_of x) = Some (Env att'' dir')"
            by cases (auto simp add: access_empty_lookup lookup_update_some
              dest: access_some_lookup)
          with dir' file' have "lookup root' (path_of x @ z # zs) =
              Some (Env att dir)"
            by (simp add: lookup_append_some)
          with look path ys show ?thesis
            by simp
        qed
        with inv show "invariant root' path"
          by (simp only: invariant_def access_def)
      qed
    next
      assume "strict_prefix path (path_of x)"
      then obtain y ys where path: "path_of x = path @ y # ys" ..

      obtain dir' where
        lookup': "lookup root' path = Some (Env att dir')" and
        inv2': "dir' \<noteq> Map.empty"
      proof (cases ys)
        assume "ys = []"
        with path have parent: "path_of x = path @ [y]" by simp
        with tr uid inv4 changed obtain "file" where
            "root' = update (path_of x) (Some file) root"
          by cases auto
        with lookup parent have "lookup root' path = Some (Env att (dir(y\<mapsto>file)))"
          by (simp only: update_append_some update_cons_nil_env)
        moreover have "dir(y\<mapsto>file) \<noteq> Map.empty" by simp
        ultimately show ?thesis ..
      next
        fix z zs assume ys: "ys = z # zs"
        with lookup root' path
        have "lookup root' path = Some (update (y # ys) opt (Env att dir))"
          by (simp only: update_append_some)
        also obtain file' where
          "update (y # ys) opt (Env att dir) = Env att (dir(y\<mapsto>file'))"
        proof -
          have "dir y \<noteq> None"
          proof -
            have "dir y = lookup (Env att dir) [y]"
              by (simp split: option.splits)
            also from lookup have "\<dots> = lookup root (path @ [y])"
              by (simp only: lookup_append_some)
            also have "\<dots> \<noteq> None"
            proof -
              from ys obtain us u where rev_ys: "ys = us @ [u]"
                by (cases ys rule: rev_cases) simp
              with tr path
              have "lookup root ((path @ [y]) @ (us @ [u])) \<noteq> None \<or>
                  lookup root ((path @ [y]) @ us) \<noteq> None"
                by cases (auto dest: access_some_lookup)
              then show ?thesis
                by (fastforce dest!: lookup_some_append)
            qed
            finally show ?thesis .
          qed
          with ys show ?thesis using that by auto
        qed
        also have "dir(y\<mapsto>file') \<noteq> Map.empty" by simp
        ultimately show ?thesis ..
      qed

      from lookup' have inv1': "access root' path user\<^sub>1 {} = Some (Env att dir')"
        by (simp only: access_empty_lookup)

      from inv3 lookup' and not_writable user\<^sub>1_not_root
      have "access root' path user\<^sub>1 {Writable} = None"
        by (simp add: access_def)
      with inv1' inv2' inv3 show ?thesis unfolding invariant_def by blast
    qed
  qed
qed

subsection \<open>Putting it all together \label{sec:unix-main-result}\<close>

text \<open>
  The main result is now imminent, just by composing the three invariance
  lemmas (see \secref{sec:unix-inv-lemmas}) according the the overall
  procedure (see \secref{sec:unix-inv-procedure}).
\<close>

corollary
  assumes bogus: "init users \<Midarrow>bogus\<Rightarrow> root"
  shows "\<not> (\<exists>xs. (\<forall>x \<in> set xs. uid_of x = user\<^sub>1) \<and>
    can_exec root (xs @ [Rmdir user\<^sub>1 [user\<^sub>1, name\<^sub>1]]))"
proof -
  from cannot_rmdir init_invariant preserve_invariant
    and bogus show ?thesis by (rule general_procedure)
qed

end

end


section {* ICTAC 2016 tutorial. Taipei, 24/10/2016 *}

theory ictac16_tutorial
  imports "../theories/utp_designs"
begin

subsection {* Laws of programming *}

theorem cond_shadow: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)" oops

theorem seqr_assoc: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)" oops

theorem seqr_left_unit: "(II ;; P) = P" oops

theorem seqr_left_zero: "(false ;; P) = false" oops

theorem cond_seq_left_distr:
  assumes "out\<alpha> \<sharp> b"
  shows "((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  using assms by (rel_simp, blast+)

theorem assign_twice:
  assumes "vwb_lens x" "x \<sharp> f"
  shows "(x := e ;; x := f) = (x := f)"
  using assms by rel_auto

theorem assign_commute:
  assumes "x \<bowtie> y" "x \<sharp> f" "y \<sharp> e"
  shows "(x := e ;; y := f) = (y := f ;; x := e)"
  using assms by (rel_auto, simp_all add: lens_indep_comm)

subsection {* Design laws *}

theorem design_false_pre: "(false \<turnstile> P) = true" by rel_auto

theorem design_true_left_zero: "(true ;; (P \<turnstile> Q)) = true"
proof -
  have "(true ;; (P \<turnstile> Q)) = (\<^bold>\<exists> ok\<^sub>0 \<bullet> true\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>\<guillemotleft>ok\<^sub>0\<guillemotright>/$ok\<rbrakk>)"
    by (subst seqr_middle[of ok], simp_all)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>false/$ok\<rbrakk>) \<or> (true\<lbrakk>true/$ok\<acute>\<rbrakk> ;; (P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>))"
    by (simp add: disj_comm false_alt_def true_alt_def)
  also have "... = ((true\<lbrakk>false/$ok\<acute>\<rbrakk> ;; true\<^sub>h) \<or> (true ;; ((P \<turnstile> Q)\<lbrakk>true/$ok\<rbrakk>)))"
    by (subst_tac, rel_auto)
  also have "... = true"
    by (subst_tac, simp add: precond_right_unit unrest)
  finally show ?thesis .
qed

theorem rdesign_left_unit:
  fixes P Q :: "'\<alpha> hrel_des"
  shows "II\<^sub>D ;; (P \<turnstile>\<^sub>r Q) = (P \<turnstile>\<^sub>r Q)"
proof -
  -- {* We first expand out the definition of the design identity *}
  have "II\<^sub>D ;; (P \<turnstile>\<^sub>r Q) = (true \<turnstile>\<^sub>r II) ;; (P \<turnstile>\<^sub>r Q)"
    by (simp add: skip_d_def)
  -- {* Next, we apply the design composition law above in a subproof *}
  also have "... = (true \<and> \<not> (II ;; (\<not> P))) \<turnstile>\<^sub>r (II ;; Q)"
  proof -
    -- {* The assumption of identity is $\true$ so it is easy to discharge the proviso *}
    have "out\<alpha> \<sharp> true"
      by unrest_tac
    -- {* From this we can apply the composition law *}
    thus ?thesis
      using rdesign_composition_cond by blast
  qed
  -- {* Simplification then allows us to remove extraneous terms *}
  also have "... = (\<not> (\<not> P)) \<turnstile>\<^sub>r Q"
    by simp
  -- {* Finally, we can show the thesis *}
  finally show ?thesis by simp
qed

subsection {* Program example *}

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

lemma "(x := 1 ;; x := (&x + 1)) = (x := 2)"
  oops

lemma "($x\<acute> >\<^sub>u $x \<and> $y\<acute> <\<^sub>u $y) \<sqsubseteq> x, y := &x + 1, &y"
  oops

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

(* Need following law:  *)
theorem ndesign_composition_wp: "((p1 \<turnstile>\<^sub>n Q1) ;; (p2 \<turnstile>\<^sub>n Q2)) = ((p1 \<and> Q1 wp p2) \<turnstile>\<^sub>n (Q1 ;; Q2))"
  oops

lemma violate_precond:
  "(true \<turnstile>\<^sub>n x := 1) ;; ((&x >\<^sub>u 1) \<turnstile>\<^sub>n y := 2) = \<bottom>\<^sub>D"
  apply (subst ndesign_composition_wp)
  apply (simp)
  apply (wp_tac)
  apply (subst_tac)
  apply (rel_auto)
done
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory WhileLoopRules
  imports
    Empty_Fail
    NonDetMonad_Total
    NonDetMonad_Sat
begin

section "Well-ordered measures"

(* A version of "measure" that takes any wellorder, instead of being fixed to "nat". *)
definition measure' :: "('a \<Rightarrow> 'b::wellorder) => ('a \<times> 'a) set" where
  "measure' = (\<lambda>f. {(a, b). f a < f b})"

lemma in_measure'[simp, code_unfold]:
  "((x,y) \<in> measure' f) = (f x < f y)"
  by (simp add:measure'_def)

lemma wf_measure'[iff]:
  "wf (measure' f)"
  apply (clarsimp simp: measure'_def)
  apply (insert wf_inv_image [OF wellorder_class.wf, where f=f])
  apply (clarsimp simp: inv_image_def)
  done

lemma wf_wellorder_measure:
  "wf {(a, b). (M a :: 'a :: wellorder) < M b}"
  apply (subgoal_tac "wf (inv_image ({(a, b). a < b}) M)")
   apply (clarsimp simp: inv_image_def)
  apply (rule wf_inv_image)
  apply (rule wellorder_class.wf)
  done

section "whileLoop lemmas"

text \<open>
  The following @{const whileLoop} definitions with additional
  invariant/variant annotations allow the user to annotate
  @{const whileLoop} terms with information that can be used
  by automated tools.
\<close>
definition whileLoop_inv ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'a) nondet_monad" where
  "whileLoop_inv C B x I R \<equiv> whileLoop C B x"

definition whileLoopE_inv ::
  "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> ('b, 'c + 'a) nondet_monad) \<Rightarrow> 'a \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow>
   (('a \<times> 'b) \<times> 'a \<times> 'b) set \<Rightarrow> ('b, 'c + 'a) nondet_monad" where
  "whileLoopE_inv C B x I R \<equiv> whileLoopE C B x"

lemma whileLoop_add_inv:
  "whileLoop B C = (\<lambda>x. whileLoop_inv B C x I (measure' M))"
  by (clarsimp simp: whileLoop_inv_def)

lemma whileLoopE_add_inv:
  "whileLoopE B C = (\<lambda>x. whileLoopE_inv B C x I (measure' M))"
  by (clarsimp simp: whileLoopE_inv_def)

subsection "Simple base rules"

lemma whileLoop_terminates_unfold:
  "\<lbrakk> whileLoop_terminates C B r s; (r', s') \<in> fst (B r s); C r s \<rbrakk> \<Longrightarrow>
   whileLoop_terminates C B r' s'"
  by (force elim!: whileLoop_terminates.cases)

lemma snd_whileLoop_first_step: "\<lbrakk> \<not> snd (whileLoop C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (B r s)"
  apply (subst (asm) whileLoop_unroll)
  apply (clarsimp simp: bind_def condition_def)
  done

lemma snd_whileLoopE_first_step: "\<lbrakk> \<not> snd (whileLoopE C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (B r s)"
  apply (subgoal_tac "\<lbrakk> \<not> snd (whileLoopE C B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd ((lift B (Inr r)) s)")
   apply (clarsimp simp: lift_def)
  apply (unfold whileLoopE_def)
  apply (erule snd_whileLoop_first_step)
  apply clarsimp
  done

lemma snd_whileLoop_unfold:
  "\<lbrakk> \<not> snd (whileLoop C B r s); C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> \<not> snd (whileLoop C B r' s')"
  apply (clarsimp simp: whileLoop_def)
  apply (auto elim: whileLoop_results.cases whileLoop_terminates.cases
              intro: whileLoop_results.intros whileLoop_terminates.intros)
  done

lemma snd_whileLoopE_unfold:
  "\<lbrakk> \<not> snd (whileLoopE C B r s); (Inr r', s') \<in> fst (B r s); C r s \<rbrakk> \<Longrightarrow> \<not> snd (whileLoopE C B r' s')"
  unfolding whileLoopE_def
  by (fastforce simp: lift_def dest: snd_whileLoop_unfold)

lemma whileLoop_results_cong [cong]:
  assumes C:  "\<And>r s. C r s = C' r s"
  and B:"\<And>(r :: 'r) (s :: 's). C' r s \<Longrightarrow> B r s = B' r s"
  shows "whileLoop_results C B = whileLoop_results C' B'"
proof -
  {
    fix x y C B C' B'
    have  "\<lbrakk> (x, y) \<in> whileLoop_results C B;
             \<And>(r :: 'r) (s :: 's). C r s = C' r s; \<And>r s. C' r s \<Longrightarrow> B r s = B' r s \<rbrakk>
           \<Longrightarrow> (x, y) \<in> whileLoop_results C' B'"
      by (induct rule: whileLoop_results.induct) (auto intro: whileLoop_results.intros)
  }

  thus ?thesis
    apply -
    apply (rule set_eqI, rule iffI; clarsimp split: prod.splits)
     apply (clarsimp simp: C B)
    apply (clarsimp simp: C [symmetric] B [symmetric])
    done
qed

lemma whileLoop_terminates_cong [cong]:
  assumes r: "r = r'"
  and s: "s = s'"
  and C: "\<And>r s. C r s = C' r s"
  and B: "\<And>r s. C' r s \<Longrightarrow> B r s = B' r s"
  shows "whileLoop_terminates C B r s = whileLoop_terminates C' B' r' s'"
proof (rule iffI)
  assume T: "whileLoop_terminates C B r s"
  show "whileLoop_terminates C' B' r' s'"
    apply (insert T r s)
    apply (induct arbitrary: r' s' rule: whileLoop_terminates.induct)
     apply (clarsimp simp: C)
     apply (erule whileLoop_terminates.intros)
    apply (clarsimp simp: C B split: prod.splits)
    apply (rule whileLoop_terminates.intros, assumption)
    apply (clarsimp simp: C B split: prod.splits)
    done
next
  assume T: "whileLoop_terminates C' B' r' s'"
  show "whileLoop_terminates C B r s"
    apply (insert T r s)
    apply (induct arbitrary: r s rule: whileLoop_terminates.induct)
     apply (rule whileLoop_terminates.intros)
     apply (clarsimp simp: C)
    apply (rule whileLoop_terminates.intros, fastforce simp: C)
    apply (clarsimp simp: C B split: prod.splits)
    done
qed

lemma whileLoop_cong[cong]:
  "\<lbrakk> \<And>r s. C r s = C' r s; \<And>r s. C r s \<Longrightarrow> B r s = B' r s \<rbrakk> \<Longrightarrow> whileLoop C B = whileLoop C' B'"
  by (clarsimp simp: whileLoop_def)

lemma whileLoopE_cong[cong]:
  "\<lbrakk> \<And>r s. C r s = C' r s ; \<And>r s. C r s \<Longrightarrow> B r s = B' r s \<rbrakk> \<Longrightarrow> whileLoopE C B = whileLoopE C' B'"
  unfolding whileLoopE_def
  by (rule whileLoop_cong[THEN arg_cong]; clarsimp simp: lift_def throwError_def split: sum.splits)

lemma whileLoop_terminates_wf:
  "wf {(x, y). C (fst y) (snd y) \<and> x \<in> fst (B (fst y) (snd y)) \<and> whileLoop_terminates C B (fst y) (snd y)}"
  apply (rule wfI[where A="UNIV" and B="{(r, s). whileLoop_terminates C B r s}"]; clarsimp)
  apply (erule whileLoop_terminates.induct; blast)
  done

subsection "Basic induction helper lemmas"

lemma whileLoop_results_induct_lemma1:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B; b = Some (x, y) \<rbrakk> \<Longrightarrow> \<not> C x y"
  by (induct rule: whileLoop_results.induct) auto

lemma whileLoop_results_induct_lemma1':
  "\<lbrakk> (a, b) \<in> whileLoop_results C B; a \<noteq> b \<rbrakk> \<Longrightarrow> \<exists>x. a = Some x \<and> C (fst x) (snd x)"
  by (induct rule: whileLoop_results.induct) auto

lemma whileLoop_results_induct_lemma2 [consumes 1]:
  "\<lbrakk> (a, b) \<in> whileLoop_results C B;
     a = Some (x :: 'a \<times> 'b); b = Some y;
     P x; \<And>s t. \<lbrakk> P s; t \<in> fst (B (fst s) (snd s)); C (fst s) (snd s) \<rbrakk> \<Longrightarrow> P t \<rbrakk> \<Longrightarrow> P y"
  apply (induct arbitrary: x y rule: whileLoop_results.induct)
    apply simp
   apply simp
  apply atomize
  apply fastforce
  done

lemma whileLoop_results_induct_lemma3 [consumes 1]:
  assumes result: "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B"
  and inv_start: "I r s"
  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  shows "I r' s'"
  apply (rule whileLoop_results_induct_lemma2 [where P="case_prod I" and y="(r', s')" and x="(r, s)",
                                               simplified case_prod_unfold, simplified])
      apply (rule result)
     apply simp
    apply simp
   apply fact
  apply (erule (1) inv_step)
  apply clarsimp
  done

subsection "Inductive reasoning about whileLoop results"

lemma in_whileLoop_induct[consumes 1]:
  assumes in_whileLoop: "(r', s') \<in> fst (whileLoop C B r s)"
  and init_I: "\<And> r s. \<not> C r s \<Longrightarrow> I r s r s"
  and step: "\<And>r s r' s' r'' s''. \<lbrakk> C r s; (r', s') \<in> fst (B r s);
                                   (r'', s'') \<in> fst (whileLoop C B r' s');
                                   I r' s' r'' s'' \<rbrakk> \<Longrightarrow> I r s r'' s''"
  shows "I r s r' s'"
proof cases
  assume "C r s"

  {
    obtain a where a_def: "a = Some (r, s)"
      by blast
    obtain b where b_def: "b = Some (r', s')"
      by blast

    have "\<lbrakk> (a, b) \<in> whileLoop_results C B; \<exists>x. a = Some x;  \<exists>x. b = Some x \<rbrakk>
          \<Longrightarrow> I (fst (the a)) (snd (the a)) (fst (the b)) (snd (the b))"
      by (induct rule: whileLoop_results.induct)
         (auto simp: init_I whileLoop_def intro: step)

    hence "(Some (r, s), Some (r', s')) \<in> whileLoop_results C B \<Longrightarrow> I r s r' s'"
      by (clarsimp simp: a_def b_def)
   }

   thus ?thesis
     using in_whileLoop
     by (clarsimp simp: whileLoop_def)
next
  assume "\<not> C r s"

  hence "r' = r \<and> s' = s"
    using in_whileLoop
    by (subst (asm) whileLoop_unroll, clarsimp simp: condition_def return_def)

  thus ?thesis
    by (metis init_I \<open>\<not> C r s\<close>)
qed

lemma snd_whileLoop_induct [consumes 1]:
  assumes induct: "snd (whileLoop C B r s)"
  and terminates: "\<not> whileLoop_terminates C B r s \<Longrightarrow> I r s"
  and init: "\<And> r s. \<lbrakk> snd (B r s); C r s \<rbrakk> \<Longrightarrow> I r s"
  and step: "\<And>r s r' s' r'' s''. \<lbrakk> C r s; (r', s') \<in> fst (B r s); snd (whileLoop C B r' s');
                                   I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert init induct)
  apply atomize
  apply (unfold whileLoop_def)
  apply clarsimp
  apply (erule disjE)
   apply (erule rev_mp)
   apply (induct "Some (r, s)" "None :: ('a \<times> 'b) option" arbitrary: r s rule: whileLoop_results.induct)
    apply clarsimp
   apply clarsimp
   apply (erule (1) step)
    apply (clarsimp simp: whileLoop_def)
   apply clarsimp
  apply (metis terminates)
  done

lemma whileLoop_terminatesE_induct [consumes 1]:
  assumes induct: "whileLoop_terminatesE C B r s"
  and init: "\<And>r s. \<not> C r s \<Longrightarrow> I r s"
  and step: "\<And>r s r' s'. \<lbrakk> C r s; \<forall>(v', s') \<in> fst (B r s). case v' of Inl _ \<Rightarrow> True | Inr r' \<Rightarrow> I r' s' \<rbrakk> \<Longrightarrow> I r s"
  shows "I r s"
  apply (insert induct)
  apply (clarsimp simp: whileLoop_terminatesE_def)
  apply (subgoal_tac "(\<lambda>r s. case (Inr r) of Inl x \<Rightarrow> True | Inr x \<Rightarrow> I x s) r s")
   apply simp
  apply (induction rule: whileLoop_terminates.induct)
   apply (clarsimp split: sum.splits elim!: init)
  apply (clarsimp split: sum.splits)
  apply (rule step)
   apply simp
  apply (force simp: lift_def split: sum.splits)
  done

subsection "Direct reasoning about whileLoop components"

lemma fst_whileLoop_cond_false:
  assumes loop_result: "(r', s') \<in> fst (whileLoop C B r s)"
  shows "\<not> C r' s'"
  using loop_result
  by (rule in_whileLoop_induct, auto)

lemma snd_whileLoop:
  assumes init_I: "I r s"
      and cond_I: "C r s"
      and non_term:  "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<and> \<not> snd (B r s) \<rbrace> B r \<exists>\<lbrace> \<lambda>r' s'. C r' s' \<and> I r' s' \<rbrace>"
  shows "snd (whileLoop C B r s)"
  apply (clarsimp simp: whileLoop_def)
  apply (rotate_tac)
  apply (insert init_I cond_I)
  apply (induct rule: whileLoop_terminates.induct)
   apply clarsimp
  apply (cut_tac r=r in non_term)
  apply (clarsimp simp: exs_valid_def)
   apply (subst (asm) (2) whileLoop_results.simps)
   apply clarsimp
  apply (insert whileLoop_results.simps)
  apply fast
  done

lemma whileLoop_terminates_inv:
  assumes init_I: "I r s"
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>"
  assumes wf_R: "wf R"
  shows "whileLoop_terminates C B r s"
  apply (insert init_I)
  using wf_R
  apply (induction "(r, s)" arbitrary: r s)
  apply atomize
  apply (subst whileLoop_terminates_simps)
  apply clarsimp
  apply (erule use_valid)
  apply (rule hoare_strengthen_post, rule inv)
   apply force
  apply force
  done

lemma not_snd_whileLoop:
  assumes init_I: "I r s"
      and inv_holds: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
      and wf_R: "wf R"
  shows "\<not> snd (whileLoop C B r s)"
proof -
  {
    fix x y
    have "\<lbrakk> (x, y) \<in> whileLoop_results C B; x = Some (r, s); y = None \<rbrakk> \<Longrightarrow> False"
      apply (insert init_I)
      apply (induct arbitrary: r s rule: whileLoop_results.inducts)
        apply simp
       apply simp
       apply (insert snd_validNF [OF inv_holds])[1]
       apply blast
      apply (drule use_validNF [OF _ inv_holds])
       apply simp
      apply clarsimp
      done
  }

  also have "whileLoop_terminates C B r s"
    apply (rule whileLoop_terminates_inv [where I=I, OF init_I _ wf_R])
    apply (insert inv_holds)
    apply (clarsimp simp: validNF_def)
    done

  ultimately show ?thesis
    by (clarsimp simp: whileLoop_def, blast)
qed

lemma valid_whileLoop:
  assumes first_step: "\<And>s. P r s \<Longrightarrow> I r s"
      and inv_step: "\<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>"
      and final_step: "\<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace> P r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
proof -
  {
    fix r' s' s
    assume inv: "I r s"
    assume step: "(r', s') \<in> fst (whileLoop C B r s)"

    have "I r' s'"
      using step inv
      apply (induct rule: in_whileLoop_induct)
       apply simp
      apply (drule use_valid, rule inv_step, auto)
      done
  }

  thus ?thesis
    apply (clarsimp simp: valid_def)
    apply (drule first_step)
    apply (rule final_step, simp)
    apply (metis fst_whileLoop_cond_false)
    done
qed

lemma whileLoop_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoop C B r \<lbrace> Q \<rbrace>"
  by (rule valid_whileLoop)

lemma whileLoop_wp_inv [wp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>; \<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s \<rbrakk>
   \<Longrightarrow> \<lbrace> I r \<rbrace> whileLoop_inv C B r I M \<lbrace> Q \<rbrace>"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule valid_whileLoop [where P=I and I=I], auto)
  done

lemma validE_whileLoopE:
  "\<lbrakk>\<And>s. P r s \<Longrightarrow> I r s;
    \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>,\<lbrace> A \<rbrace>;
    \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s\<rbrakk> \<Longrightarrow>
   \<lbrace> P r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>,\<lbrace> A \<rbrace>"
  apply (clarsimp simp: whileLoopE_def validE_def)
  apply (rule valid_whileLoop [where I="\<lambda>r s. (case r of Inl x \<Rightarrow> A x s | Inr x \<Rightarrow> I x s)"
                                 and Q="\<lambda>r s. (case r of Inl x \<Rightarrow> A x s | Inr x \<Rightarrow> Q x s)"])
    apply atomize
    apply (clarsimp simp: valid_def lift_def split: sum.splits)
   apply (clarsimp simp: valid_def lift_def split: sum.splits)
  apply (clarsimp split: sum.splits)
  done

lemma whileLoopE_wp:
  "\<lbrakk> \<And>r. \<lbrace> \<lambda>s. I r s \<and> C r s \<rbrace> B r \<lbrace> I \<rbrace>, \<lbrace> A \<rbrace>;
     \<And>r s. \<lbrakk> I r s; \<not> C r s \<rbrakk> \<Longrightarrow> Q r s \<rbrakk> \<Longrightarrow>
  \<lbrace> I r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>, \<lbrace> A \<rbrace>"
  by (rule validE_whileLoopE)

lemma exs_valid_whileLoop:
 assumes init_T: "\<And>s. P s \<Longrightarrow> T r s"
    and iter_I: "\<And>r s0. \<lbrace>\<lambda>s. T r s \<and> C r s \<and> s = s0\<rbrace> B r \<exists>\<lbrace>\<lambda>r' s'. T r' s' \<and> ((r', s'),(r, s0)) \<in> R\<rbrace>"
    and wf_R: "wf R"
    and final_I: "\<And>r s. \<lbrakk> T r s; \<not> C r s  \<rbrakk> \<Longrightarrow> Q r s"
 shows "\<lbrace> P \<rbrace> whileLoop C B r \<exists>\<lbrace> Q \<rbrace>"
proof (clarsimp simp: exs_valid_def Bex_def)
  fix s
  assume "P s"

  {
    fix x
    have "T (fst x) (snd x) \<Longrightarrow> \<exists>r' s'. (r', s') \<in> fst (whileLoop C B (fst x) (snd x)) \<and> T r' s'"
      using wf_R
      apply induction
      apply atomize
      apply (case_tac "C (fst x) (snd x)")
       apply (subst whileLoop_unroll)
       apply (clarsimp simp: condition_def bind_def' split: prod.splits)
       apply (cut_tac ?s0.0=b and r=a in iter_I)
       apply (clarsimp simp: exs_valid_def)
       apply blast
      apply (subst whileLoop_unroll)
      apply (clarsimp simp: condition_def bind_def' return_def)
      done
  }

  thus "\<exists>r' s'. (r', s') \<in> fst (whileLoop C B r s) \<and> Q r' s'"
    by (metis \<open>P s\<close> fst_conv init_T snd_conv final_I fst_whileLoop_cond_false)
qed

lemma empty_fail_whileLoop[empty_fail_cond, intro!, wp]:
  assumes body_empty_fail: "\<And>r. empty_fail (B r)"
  shows "empty_fail (whileLoop C B r)"
proof -
  {
    fix s A
    assume empty: "fst (whileLoop C B r s) = {}"

    have cond_true: "\<And>x s. fst (whileLoop C B x s) = {} \<Longrightarrow> C x s"
      apply (subst (asm) whileLoop_unroll)
      apply (clarsimp simp: condition_def return_def split: if_split_asm)
      done

    have  "snd (whileLoop C B r s)"
      apply (rule snd_whileLoop [where I="\<lambda>x s. fst (whileLoop C B x s) = {}"])
        apply fact
       apply (rule cond_true, fact)
      apply (clarsimp simp: exs_valid_def)
      apply (case_tac "fst (B r s) = {}")
       apply (metis empty_failD [OF body_empty_fail])
      apply (subst (asm) whileLoop_unroll)
      apply (fastforce simp: condition_def bind_def split_def cond_true)
      done
   }

  thus ?thesis
    by (clarsimp simp: empty_fail_def)
qed

lemma empty_fail_whileLoopE[empty_fail_cond, intro!, wp]:
  assumes "\<And>r. empty_fail (B r)"
  shows "empty_fail (whileLoopE C B r)"
  by (clarsimp simp: whileLoopE_def assms)

lemma empty_fail_whileM[empty_fail_cond, intro!, wp]:
  "\<lbrakk> empty_fail C; empty_fail B \<rbrakk> \<Longrightarrow> empty_fail (whileM C B)"
  unfolding whileM_def
  by (wpsimp wp: empty_fail_whileLoop empty_fail_bind)

lemma whileLoop_results_bisim:
  assumes base: "(a, b) \<in> whileLoop_results C B"
  and vars1: "Q = (case a of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
  and vars2: "R = (case b of Some (r, s) \<Rightarrow> Some (rt r, st s) | _ \<Rightarrow> None)"
  and inv_init: "case a of Some (r, s) \<Rightarrow> I r s | _ \<Rightarrow> True"
  and inv_step: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in> fst (B r s) \<rbrakk> \<Longrightarrow> I r' s'"
  and cond_match: "\<And>r s. I r s \<Longrightarrow> C r s = C' (rt r) (st s)"
  and fail_step: "\<And>r s. \<lbrakk>C r s; snd (B r s); I r s\<rbrakk>
                         \<Longrightarrow> (Some (rt r, st s), None) \<in> whileLoop_results C' B'"
  and refine: "\<And>r s r' s'. \<lbrakk> I r s; C r s; (r', s') \<in>  fst (B r s) \<rbrakk>
                            \<Longrightarrow> (rt r', st s') \<in> fst (B' (rt r) (st s))"
  shows "(Q, R) \<in> whileLoop_results C' B'"
  apply (subst vars1)
  apply (subst vars2)
  apply (insert base inv_init)
  apply (induct rule: whileLoop_results.induct)
    apply clarsimp
    apply (subst (asm) cond_match)
     apply (clarsimp simp: option.splits)
    apply (clarsimp simp: option.splits)
   apply (clarsimp simp: option.splits)
   apply (metis fail_step)
  apply (case_tac z)
   apply (clarsimp simp: option.splits)
   apply (metis cond_match inv_step refine whileLoop_results.intros(3))
  apply (clarsimp simp: option.splits)
  apply (metis cond_match inv_step refine whileLoop_results.intros(3))
  done

lemma whileLoop_terminates_liftE:
  "whileLoop_terminatesE C (\<lambda>r. liftE (B r)) r s = whileLoop_terminates C B r s"
  apply (subst eq_sym_conv)
  apply (clarsimp simp: whileLoop_terminatesE_def)
  apply (rule iffI)
   apply (erule whileLoop_terminates.induct)
    apply (rule whileLoop_terminates.intros)
    apply clarsimp
   apply (clarsimp simp: split_def)
   apply (rule whileLoop_terminates.intros(2))
    apply clarsimp
   apply (clarsimp simp: liftE_def in_bind return_def lift_def[abs_def]
                          bind_def lift_def throwError_def o_def
                   split: sum.splits
                   cong: sum.case_cong)
   apply (drule (1) bspec)
   apply clarsimp
  apply (subgoal_tac
         "case Inr r of
            Inl _ \<Rightarrow> True
          | Inr r \<Rightarrow> whileLoop_terminates
                       (\<lambda>r s. (\<lambda>r s. case r of Inl _ \<Rightarrow> False | Inr v \<Rightarrow> C v s) (Inr r) s)
                       (\<lambda>r. lift (\<lambda>r. liftE (B r)) (Inr r) >>= (\<lambda>x. return (projr x))) r s")
   apply (clarsimp simp: liftE_def lift_def)
  apply (erule whileLoop_terminates.induct)
   apply (clarsimp simp: liftE_def lift_def split: sum.splits)
   apply (erule whileLoop_terminates.intros)
  apply (clarsimp simp: liftE_def split: sum.splits)
  apply (clarsimp simp: bind_def return_def split_def lift_def)
  apply (erule whileLoop_terminates.intros)
  apply force
  done

lemma snd_X_return[simp]:
  "snd ((A >>= (\<lambda>a. return (X a))) s) = snd (A s)"
  by (clarsimp simp: return_def bind_def split_def)

lemma whileLoopE_liftE:
  "whileLoopE C (\<lambda>r. liftE (B r)) r = liftE (whileLoop C B r)"
  apply (rule ext)
  apply (clarsimp simp: whileLoopE_def)
  apply (rule prod_eqI)
   apply (rule set_eqI, rule iffI)
    apply clarsimp
    apply (clarsimp simp: in_bind whileLoop_def liftE_def)
    apply (rule_tac x="b" in exI)
    apply (rule_tac x="projr a" in exI)
    apply (rule conjI)
     apply (erule whileLoop_results_bisim[where rt=projr
                                            and st="\<lambda>x. x"
                                            and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
            auto intro: whileLoop_results.intros simp: bind_def return_def lift_def split: sum.splits)[1]
    apply (drule whileLoop_results_induct_lemma2[where P="\<lambda>(r, s). case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"])
        apply (rule refl)
       apply (rule refl)
      apply clarsimp
     apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
    apply (clarsimp simp: return_def bind_def lift_def split: sum.splits)
   apply (clarsimp simp: in_bind whileLoop_def liftE_def)
   apply (erule whileLoop_results_bisim[where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"],
          auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def
               split: sum.splits)[1]
  apply (rule iffI)
   apply (clarsimp simp: whileLoop_def liftE_def del: notI)
   apply (erule disjE)
    apply (erule whileLoop_results_bisim[where rt=projr
                                           and st="\<lambda>x. x"
                                           and I="\<lambda>r s. case r of Inr x \<Rightarrow> True | _ \<Rightarrow> False"],
           auto intro: whileLoop_results.intros simp: bind_def return_def lift_def split: sum.splits)[1]
   apply (subst (asm) whileLoop_terminates_liftE [symmetric])
   apply (fastforce simp: whileLoop_def liftE_def whileLoop_terminatesE_def)
  apply (clarsimp simp: whileLoop_def liftE_def del: notI)
  apply (subst (asm) whileLoop_terminates_liftE [symmetric])
  apply (clarsimp simp: whileLoop_def liftE_def whileLoop_terminatesE_def)
  apply (erule disjE)
   apply (erule whileLoop_results_bisim [where rt=Inr and st="\<lambda>x. x" and I="\<lambda>r s. True"])
         apply (clarsimp split: option.splits)
        apply (clarsimp split: option.splits)
       apply (clarsimp split: option.splits)
      apply (auto intro: whileLoop_results.intros intro!: bexI simp: bind_def return_def lift_def
                  split: sum.splits)
  done

lemma validNF_whileLoop:
  assumes pre: "\<And>s. P r s \<Longrightarrow> I r s"
  and inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>P r\<rbrace> whileLoop C B r \<lbrace>Q\<rbrace>!"
  apply rule
   apply (rule valid_whileLoop)
     apply fact
    apply (insert inv, clarsimp simp: validNF_def valid_def split: prod.splits, force)[1]
   apply (metis post_cond)
  apply (unfold no_fail_def)
  apply (intro allI impI)
  apply (rule not_snd_whileLoop [where I=I and R=R])
    apply (auto intro: assms)
  done

lemma validNF_whileLoop_inv [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I R \<lbrace>Q\<rbrace>!"
  apply (clarsimp simp: whileLoop_inv_def)
  apply (rule validNF_whileLoop [where I=I and R=R])
     apply simp
    apply (rule inv)
   apply (rule wf)
  apply (metis post_cond)
  done

lemma validNF_whileLoop_inv_measure [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> M r' s' < M r s \<rbrace>!"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>!"
  apply (clarsimp simp: whileLoop_inv_def)
    apply (rule validNF_whileLoop[where R="measure' (\<lambda>(r, s). M r s)" and I=I])
     apply simp
    apply clarsimp
    apply (rule inv)
   apply simp
  apply (metis post_cond)
  done

lemma validNF_whileLoop_inv_measure_twosteps:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<rbrace>!"
  assumes measure: "\<And>r m. \<lbrace>\<lambda>s. I r s \<and> C r s \<and> M r s = m \<rbrace> B r \<lbrace> \<lambda>r' s'. M r' s' < m \<rbrace>"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoop_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>!"
  apply (rule validNF_whileLoop_inv_measure)
   apply (rule validNF_weaken_pre)
    apply (rule validNF_post_comb_conj_L)
     apply (rule inv)
    apply (rule measure)
   apply fast
  apply (metis post_cond)
  done

lemma wf_custom_measure:
  "\<lbrakk> \<And>a b. (a, b) \<in> R \<Longrightarrow> f a < (f :: 'a \<Rightarrow> nat) b \<rbrakk> \<Longrightarrow>  wf R"
  by (metis in_measure wf_def wf_measure)

lemma validNF_whileLoopE:
  assumes pre: "\<And>s. P r s \<Longrightarrow> I r s"
  and inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>,\<lbrace> E \<rbrace>!"
  and wf: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace> P r \<rbrace> whileLoopE C B r \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>!"
  apply (unfold validE_NF_alt_def whileLoopE_def)
  apply (rule validNF_whileLoop [where
                I="\<lambda>r s. case r of Inl x \<Rightarrow> E x s | Inr x \<Rightarrow> I x s" and
                R="{((r', s'), (r, s)). \<exists>x x'. r' = Inl x' \<and> r = Inr x} \<union>
                   {((r', s'), (r, s)). \<exists>x x'. r' = Inr x' \<and> r = Inr x \<and> ((x', s'),(x, s)) \<in> R}"])
     apply (simp add: pre)
    apply (insert inv)[1]
    apply (fastforce simp: lift_def validNF_def valid_def validE_NF_def throwError_def no_fail_def
                           return_def validE_def
                     split: sum.splits prod.splits)
   apply (rule wf_Un)
     apply (rule wf_custom_measure [where f="\<lambda>(r, s). case r of Inl _ \<Rightarrow> 0 | _ \<Rightarrow> 1"])
     apply clarsimp
    apply (insert wf_inv_image [OF wf, where f="\<lambda>(r, s). (projr r, s)"])
    apply (drule wf_Int1 [where r'="{((r', s'),(r, s)). (\<exists>x. r = Inr x) \<and> (\<exists>x. r' = Inr x)}"])
    apply (erule wf_subset)
    apply (fastforce simp: inv_image_def split: prod.splits sum.splits)
   apply fastforce
  apply (fastforce split: sum.splits intro: post_cond)
  done

lemma validNF_whileLoopE_inv [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> ((r', s'), (r, s)) \<in> R \<rbrace>,\<lbrace> E \<rbrace>!"
  and wf_R: "wf R"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I R \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  apply (clarsimp simp: whileLoopE_inv_def)
  apply (metis validNF_whileLoopE [OF _ inv] post_cond wf_R)
  done

lemma validNF_whileLoopE_inv_measure [wp]:
  assumes inv: "\<And>r s. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<and> s' = s \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<and> M r' s' < M r s \<rbrace>, \<lbrace> E \<rbrace>!"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>,\<lbrace>E\<rbrace>!"
  apply (rule validNF_whileLoopE_inv)
    apply clarsimp
    apply (rule inv)
   apply clarsimp
  apply (metis post_cond)
  done

lemma validNF_whileLoopE_inv_measure_twosteps:
  assumes inv: "\<And>r. \<lbrace>\<lambda>s'. I r s' \<and> C r s' \<rbrace> B r \<lbrace> \<lambda>r' s'. I r' s' \<rbrace>, \<lbrace> E \<rbrace>!"
  assumes measure: "\<And>r m. \<lbrace>\<lambda>s. I r s \<and> C r s \<and> M r s = m \<rbrace> B r \<lbrace> \<lambda>r' s'. M r' s' < m \<rbrace>, \<lbrace> \<lambda>_ _. True \<rbrace>"
  and post_cond: "\<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s"
  shows "\<lbrace>I r\<rbrace> whileLoopE_inv C B r I (measure' (\<lambda>(r, s). M r s)) \<lbrace>Q\<rbrace>, \<lbrace>E\<rbrace>!"
  apply (rule validNF_whileLoopE_inv_measure)
   apply (rule validE_NF_weaken_pre)
    apply (rule validE_NF_post_comb_conj_L)
     apply (rule inv)
    apply (rule measure)
   apply fast
  apply (metis post_cond)
  done

lemma whileLoopE_wp_inv [wp]:
  "\<lbrakk> \<And>r. \<lbrace>\<lambda>s. I r s \<and> C r s\<rbrace> B r \<lbrace>I\<rbrace>,\<lbrace>E\<rbrace>; \<And>r s. \<lbrakk>I r s; \<not> C r s\<rbrakk> \<Longrightarrow> Q r s \<rbrakk>
      \<Longrightarrow> \<lbrace> I r \<rbrace> whileLoopE_inv C B r I M \<lbrace> Q \<rbrace>,\<lbrace> E \<rbrace>"
  apply (clarsimp simp: whileLoopE_inv_def)
  apply (rule validE_whileLoopE [where I=I], auto)
  done

subsection "Stronger whileLoop rules"

lemma whileLoop_rule_strong:
  assumes init_U: "\<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>r s. (r, s) \<in> fst Q \<rbrace>"
  and path_exists: "\<And>r'' s''. \<lbrakk> (r'', s'') \<in> fst Q \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> \<lambda>r s. r = r'' \<and> s = s'' \<rbrace>"
  and loop_fail: "snd Q \<Longrightarrow> snd (whileLoop C B r s)"
  and loop_nofail: "\<not> snd Q \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>_ _. True \<rbrace>!"
  shows "whileLoop C B r s = Q"
  using assms
  apply atomize
  apply (clarsimp simp: valid_def exs_valid_def validNF_def no_fail_def)
  apply rule
    apply blast
   apply blast
  apply blast
  done

lemma whileLoop_rule_strong_no_fail:
  assumes init_U: "\<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<lbrace> \<lambda>r s. (r, s) \<in> fst Q \<rbrace>!"
  and path_exists: "\<And>r'' s''. \<lbrakk> (r'', s'') \<in> fst Q \<rbrakk> \<Longrightarrow> \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B r \<exists>\<lbrace> \<lambda>r s. r = r'' \<and> s = s'' \<rbrace>"
  and loop_no_fail: "\<not> snd Q"
  shows "whileLoop C B r s = Q"
  apply (rule whileLoop_rule_strong)
     apply (metis init_U validNF_valid)
    apply (metis path_exists)
   apply (metis loop_no_fail)
  apply (metis (lifting, no_types) init_U validNF_chain)
  done

subsection "Miscellaneous rules"

(* Failure of one whileLoop implies the failure of another whileloop
 * which will only ever fail more. *)
lemma snd_whileLoop_subset:
    assumes a_fails: "snd (whileLoop C A r s)"
    and b_success_step:
        "\<And>r s r' s'. \<lbrakk> C r s; (r', s') \<in> fst (A r s); \<not> snd (B r s) \<rbrakk>
             \<Longrightarrow> (r', s') \<in> fst (B r s)"
    and b_fail_step: "\<And>r s. \<lbrakk> C r s; snd (A r s) \<rbrakk> \<Longrightarrow> snd (B r s) "
   shows "snd (whileLoop C B r s)"
  apply (insert a_fails)
  apply (induct rule: snd_whileLoop_induct)
    apply (unfold whileLoop_def snd_conv)[1]
    apply (rule disjCI, simp)
    apply rotate_tac
    apply (induct rule: whileLoop_terminates.induct)
     apply (subst (asm) whileLoop_terminates.simps)
     apply simp
    apply (subst (asm) (3) whileLoop_terminates.simps, clarsimp)
    apply (subst whileLoop_results.simps, clarsimp)
    apply (rule classical)
    apply (frule b_success_step, assumption, simp)
    apply (drule (1) bspec)
    apply clarsimp
   apply (frule (1) b_fail_step)
   apply (metis snd_whileLoop_first_step)
  apply (metis b_success_step snd_whileLoop_first_step snd_whileLoop_unfold)
  done

subsection "Some rules for whileM"

lemma whileM_wp_gen:
  assumes termin:"\<And>s. I False s \<Longrightarrow> Q s"
  assumes [wp]: "\<lbrace>I'\<rbrace> C \<lbrace>I\<rbrace>"
  assumes [wp]: "\<lbrace>I True\<rbrace> f \<lbrace>\<lambda>_. I'\<rbrace>"
  shows "\<lbrace>I'\<rbrace> whileM C f \<lbrace>\<lambda>_. Q\<rbrace>"
  unfolding whileM_def
  using termin
  by (wpsimp wp: whileLoop_wp[where I=I])

lemma whileM_inv:
  "\<lbrakk>f \<lbrace>Q\<rbrace>; P \<lbrace>Q\<rbrace>\<rbrakk> \<Longrightarrow> whileM P f \<lbrace>Q\<rbrace>"
  by (fastforce intro: whileM_wp_gen)

lemmas whileM_post_inv
  = hoare_strengthen_post[where R="\<lambda>_. Q" for Q, OF whileM_inv[where P=C for C], rotated -1]

end