(*  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
    "~~/src/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 "Naraschewski:2001"}.\<close>
\<close>

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

type_synonym perms = "perm set"

record att =
  owner :: uid
  others :: perms

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

  As another simplification, we ignore the @{term Executable} 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 Readable}). 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
  Executable}. We ignore this detail and pretend that all directories give
  @{term Executable} 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 "('a, 'b, 'c) env"} from the
  standard library of Isabelle/HOL @{cite "Bauer-et-al:2002:HOL-Library"}.
  This type provides constructors @{term Val} and @{term Env} 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 'a} refers to plain values occurring at leaf
  positions, parameter @{typ 'b} to information kept with inner branch nodes,
  and parameter @{typ 'c} to the branching type of the tree structure. For our
  purpose we use the type instance with @{typ "att \<times> string"} (representing
  plain files), @{typ att} (for attributes of directory nodes), and @{typ
  name} (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 lookup} and @{term update} 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
  "Bauer-et-al:2002:HOL-Library"}. These will be routinely used later on
  without further notice.

  \<^bigskip>
  Apparently, the elements of type @{typ "file"} contain an @{typ att}
  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 "Nipkow-et-al:2000:HOL"}.
\<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> 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 "file option"}
  indicates if a file had been present at the corresponding @{typ path} 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
  "Tanenbaum:1992"}) 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
  update} operation.

  \<^medskip>
  We see that @{term access} is just a wrapper for the basic @{term lookup}
  function, with additional checking of attributes. Subsequently we establish
  a few auxiliary facts that stem from the primitive @{term lookup} used
  within @{term access}.
\<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
  "Tanenbaum:1992"}) 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 uid} 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 path} 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 Read} and @{term Write} 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> 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' 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 "Torvalds-et-al:Linux"}. 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 root'} from given @{term root} and @{term x} (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 Q} of single transitions
  with property @{term P} may be transferred to iterated transitions. The
  proof is rather obvious by rule induction over the definition of @{term
  "root \<Midarrow>xs\<Rightarrow> root'"}.
\<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 can_exec} (of @{term [source] Cons})\<close>
  apply (rule mkdir)
    \<comment> \<open>back-chain @{term Mkdir}\<close>
  apply (force simp add: eval)+
    \<comment> \<open>solve preconditions of @{term Mkdir}\<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 can_exec} (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 "P x"} 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 "uid_of x = user\<^sub>1"} later
  on. Furthermore, @{term y} refers to the operations we claim to be
  impossible to perform afterwards, we will take @{term Rmdir} later. Moreover
  @{term Q} is a suitable (auxiliary) invariant over the file-system; choosing
  @{term Q} 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 bogus} operations are the ones that lead into the uncouth
  situation; @{term bogus_path} 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 path} within
  the file-system is a non-empty directory that is neither owned nor writable
  by @{term user\<^sub>1}.
\<close>

definition
  "invariant root path \<longleftrightarrow>
    (\<exists>att dir.
      access root path user\<^sub>1 {} = Some (Env att dir) \<and> dir \<noteq> 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 user\<^sub>1} is unable to remove the (owned) directory at @{term
    "[user\<^sub>1, name\<^sub>1]"}.

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

    \<^enum> The invariant is preserved by any file-system operation performed by
    @{term user\<^sub>1} 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 empty)"
    by cases auto
  then have "access root ([user\<^sub>1, name\<^sub>1] @ [name\<^sub>2]) user\<^sub>1 {} = 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> "evaluate all operations"
  apply (drule transitions_nilD)
    \<comment> "reach final result"
  apply (simp add: invariant_def eval)
    \<comment> "check the invariant"
  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
  user\<^sub>1} alone. Note that this holds for any @{term path} given, the
  particular @{term bogus_path} 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> 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> 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> 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> 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


theory Rename_Cfg
imports "../RefPoint/SM_Cfg"
  Type_System SM_Finite_Reachable Gen_Cfg_Bisim
  "HOL-Library.IArray"
begin

(* TODO: Move *)
lemma set_list_bind[simp]: "set (List.bind m f) = Set.bind (set m) (\<lambda>x. set (f x))"
  by (auto simp: List.bind_def)

lemma rel_mset_of_mapI:
  assumes "\<forall>x\<in>set l. R (f x) (g x)"
  shows "rel_mset R (mset (map f l)) (mset (map g l))"
  using assms
  apply (induction l)
  apply (auto simp: rel_mset_Zero rel_mset_Plus)
  done

(* TODO: Move? *)
lemma finite_max1_elemI:
  assumes "(\<forall>x y. x\<in>S \<and> y\<in>S \<longrightarrow> x=y)"
  shows "finite S"
proof (cases "S={}")
  case False
  with assms obtain x where "S={x}" by auto
  thus ?thesis by auto
qed auto

lemma left_unique_finite_sngI:
  assumes "left_unique R"
  shows "finite {a. R a b}"
proof (rule finite_subset)
  {
    fix x y
    assume "x\<in>{a. R a b}" "y\<in>{a. R a b}"
    hence "x=y" using assms
      by (auto dest: left_uniqueD)
  } thus "finite {a. R a b}"
    by (blast intro: finite_max1_elemI)
qed auto

function approx_reachable_list_aux :: "cmd \<Rightarrow> cmd list" where
  "approx_reachable_list_aux (Assign c x e) = [Assign c x e, Skip]"
| "approx_reachable_list_aux (Assign_local c x e) = [Assign_local c x e, Skip]"
| "approx_reachable_list_aux (Assign_global c x e) = [Assign_global c x e, Skip]"
| "approx_reachable_list_aux (Test e) = [Test e, Skip]"
| "approx_reachable_list_aux (Skip) = [Skip]"
| "approx_reachable_list_aux (Seq c1 c2) = (approx_reachable_list_aux c2) @ (do { c1\<leftarrow>approx_reachable_list_aux c1; [Seq c1 c2] })"
| "approx_reachable_list_aux (Or c1 c2) = (Or c1 c2) # (approx_reachable_list_aux c1 @ approx_reachable_list_aux c2)"
| "approx_reachable_list_aux (Break) = [Break,Invalid]"
| "approx_reachable_list_aux (Continue) = [Continue,Invalid]"
| "approx_reachable_list_aux (Iterate c1 c2) = Skip #
    (do { c1\<leftarrow>approx_reachable_list_aux c1; [Iterate c1 c2] })
  @ (do { c2'\<leftarrow>approx_reachable_list_aux c2; [Iterate c2' c2] })"
| "approx_reachable_list_aux Invalid = [Invalid]"
by pat_completeness auto

termination
  apply (relation "reachable_term_order_aux <*mlex*> measure size")
  apply (metis wf_measure wf_mlex)
  apply (auto simp: mlex_prod_def)
  done

lemma approx_reachable_list_aux_refine:
  "set (approx_reachable_list_aux c) = approx_reachable c"
  apply (induction c rule: approx_reachable.induct)
  apply (simp_all)
  done

definition "cfg_V0 prog \<equiv> proc_decl.body ` set (program.processes prog)"
definition "cfg_V0_list prog \<equiv> remdups (map proc_decl.body (program.processes prog))"

lemma cfg_V0_list_invar: "distinct (cfg_V0_list prog)"
  unfolding cfg_V0_list_def by auto

lemma cfg_V0_list_refine: "set (cfg_V0_list prog) = cfg_V0 prog"
  unfolding cfg_V0_list_def cfg_V0_def by auto

definition "approx_reachable_list prog \<equiv>
  remdups (concat (map approx_reachable_list_aux (cfg_V0_list prog)))"

definition "approx_reachable_prog prog \<equiv> \<Union>(approx_reachable`(cfg_V0 prog))"

lemma approx_reachable_list_invar: "distinct (approx_reachable_list prog)"
  unfolding approx_reachable_list_def
  by auto

lemma approx_reachable_list_refine:
  "set (approx_reachable_list prog) = approx_reachable_prog prog"
  unfolding approx_reachable_list_def approx_reachable_prog_def
  by (auto simp: approx_reachable_list_aux_refine cfg_V0_list_refine)

text \<open>CFG successors\<close>
primrec cfg_succ :: "cmd \<Rightarrow> ((action+brk_ctd) \<times> cmd) set" where
  "cfg_succ (Assign c x e) = {((Inl (AAssign c x e)), Skip)}"
| "cfg_succ (Assign_local c x e) = {((Inl (AAssign_local c x e)), Skip)}"
| "cfg_succ (Assign_global c x e) = {((Inl (AAssign_global c x e)), Skip)}"
| "cfg_succ (Test e) = {((Inl (ATest e)), Skip)}"
| "cfg_succ (Seq c1 c2) =
  ( if c1=Skip then
      {((Inl ASkip), c2)}
    else
      { (e,if c1'=Skip then c2 else Seq c1' c2) | c1' e.  (e,c1')\<in>cfg_succ c1}
  )"
| "cfg_succ (Or c1 c2) = cfg_succ c1 \<union> cfg_succ c2"
| "cfg_succ (Break) = {(Inr AIBreak, Invalid)}"
| "cfg_succ (Continue) = {(Inr AIContinue, Invalid)}"
| cfg_succ_iterate:
  "cfg_succ (Iterate c cb) =
  (if c=Skip then {(Inl ASkip, Iterate cb cb)} else {})
  \<union> (
    \<lambda> (Inl e,c') \<Rightarrow> (Inl e, if c'=Skip then Iterate cb cb else Iterate c' cb)
    | (Inr AIBreak,_) \<Rightarrow> (Inl ASkip,Skip)
    | (Inr AIContinue,_) \<Rightarrow> (Inl ASkip, Iterate cb cb)
  )`cfg_succ c"
| "cfg_succ Skip = {}"
| "cfg_succ Invalid = {}"

declare cfg_succ_iterate[simp del]
lemma cfg_succ_iterate'[simp]: "cfg_succ (Iterate c cb) =
  (if c=Skip then {(Inl ASkip, Iterate cb cb)} else {})
  \<union> { (Inl e, if c'=Skip then Iterate cb cb else Iterate c' cb) | e c'. (Inl e, c') \<in> cfg_succ c }
  \<union> (if \<exists>c'. (Inr AIBreak,c')\<in> cfg_succ c then { (Inl ASkip, Skip)} else {})
  \<union> (if \<exists>c'. (Inr AIContinue,c')\<in> cfg_succ c then { (Inl ASkip, Iterate cb cb)} else {})"
  unfolding cfg_succ_iterate
  apply (rule sym)
  apply (cases "c=Skip")
  apply simp
  apply safe
  apply simp_all
  apply force
  apply (force split: if_split_asm)
  apply (force split: if_split_asm)
  apply (auto split: if_split_asm sum.splits brk_ctd.splits)
  done

lemma cfg_succ_iff_cfg: "(a,c')\<in>cfg_succ c \<longleftrightarrow> cfg c a c'"
  apply rule
  apply (induction c arbitrary: a c')
  apply ((auto intro: cfg.intros split: if_split_asm) [])+

  apply (induction rule: cfg.induct)
  apply auto
  done

theorem cfg_succ_correct: "cfg_succ c = {(a,c'). cfg c a c'}"
  using cfg_succ_iff_cfg by auto

lemma cfg_succ_finite[simp, intro!]: "finite (cfg_succ c)"
  apply (induction c)
  using [[simproc add: finite_Collect]]
  apply (simp_all del: cfg_succ_iterate' add: cfg_succ_iterate)
  done

primrec cfg_succ_list :: "cmd \<Rightarrow> ((action+brk_ctd) \<times> cmd) list" where
  "cfg_succ_list (Assign ge x e) = [((Inl (AAssign ge x e)), Skip)]"
| "cfg_succ_list (Assign_local ge x e) = [((Inl (AAssign_local ge x e)), Skip)]"
| "cfg_succ_list (Assign_global ge x e) = [((Inl (AAssign_global ge x e)), Skip)]"
| "cfg_succ_list (Test e) = [((Inl (ATest e)), Skip)]"
| "cfg_succ_list (Seq c1 c2) =
    ( if c1=Skip then
        [((Inl ASkip), c2)]
      else
        map (\<lambda>(e,c1'). (e,if c1'=Skip then c2 else Seq c1' c2)) (cfg_succ_list c1)
    )"
| "cfg_succ_list (Or c1 c2) = remdups (cfg_succ_list c1 @ cfg_succ_list c2)"
| "cfg_succ_list (Break) = [(Inr AIBreak, Invalid)]"
| "cfg_succ_list (Continue) = [(Inr AIContinue, Invalid)]"
| cfg_succ_list_iterate:
  "cfg_succ_list (Iterate c cb) =
  (if c=Skip then [(Inl ASkip, Iterate cb cb)] else [])
  @ remdups (map (
    \<lambda> (Inl e,c') \<Rightarrow> (Inl e, if c'=Skip then Iterate cb cb else Iterate c' cb)
    | (Inr AIBreak,_) \<Rightarrow> (Inl ASkip,Skip)
    | (Inr AIContinue,_) \<Rightarrow> (Inl ASkip, Iterate cb cb)
  ) (cfg_succ_list c))"
| "cfg_succ_list Skip = []"
| "cfg_succ_list Invalid = []"

(* FIXME: Strange, the simplifier should know such lemmas!? *)
lemma Seq_ne_structural[simp]:
  "Seq a b \<noteq> a"
  "Seq a b \<noteq> b"
  "a \<noteq> Seq a b"
  "b \<noteq> Seq a b"
proof -
  show G1: "Seq a b \<noteq> a"
    by (induction a arbitrary: b) auto
  show G2: "Seq a b \<noteq> b"
    by (induction b arbitrary: a) auto
  show "a \<noteq> Seq a b" using G1 by simp
  show "b \<noteq> Seq a b" using G2 by simp
qed

lemma cfg_succ_list_invar: "distinct (cfg_succ_list c)"
  apply (induction c)
  apply (auto simp: distinct_map)
  apply (rule inj_onI)
  apply (auto split: if_split_asm ) []
  done

lemma cfg_succ_list_refine: "set (cfg_succ_list c) = cfg_succ c"
  apply (induction c)
  apply (simp_all only: cfg_succ.simps cfg_succ_list.simps
    if_distrib[of set] if_same_eq set_map)
  apply (simp_all)
  apply (auto, force+) []
  done

definition "cfg'_succ_list c \<equiv> map (map_prod projl id) (filter (isl o fst) (cfg_succ_list c))"

lemma cfg'_succ_list_invar: "distinct (cfg'_succ_list c)"
  unfolding cfg'_succ_list_def
  apply (auto simp: distinct_map cfg_succ_list_invar intro!: inj_onI)
  apply (rename_tac a a' foo)
  apply (case_tac a, simp_all)
  done

lemma cfg'_succ_list_refine: "set (cfg'_succ_list c) = {(a,c'). cfg' c a c'}"
  unfolding cfg'_succ_list_def
  by (force simp: cfg_succ_list_refine cfg'_def cfg_succ_correct)

definition "index_of l x \<equiv>
  if \<exists>i<length l. l!i=x then
    Some (THE i. i<length l \<and> l!i=x)
  else None"

lemma index_of_Some_conv:
  assumes "distinct l"
  shows "index_of l x = Some i \<longleftrightarrow> i < length l \<and> l ! i = x"
proof safe
  show "index_of l x = Some i \<Longrightarrow> i < length l"
    using assms unfolding index_of_def distinct_conv_nth
    by (metis (mono_tags, lifting) option.distinct(1) option.inject theI)
  show "index_of l x = Some i \<Longrightarrow> l ! i = x"
    using assms unfolding index_of_def distinct_conv_nth
    by (metis (mono_tags, lifting) option.distinct(1) option.inject theI)
  show "i < length l \<Longrightarrow> x = l ! i \<Longrightarrow> index_of l (l ! i) = Some i"
    using assms unfolding index_of_def distinct_conv_nth by auto
qed

lemma dom_index_of: "dom (index_of l) = set l"
  by (auto simp: index_of_def in_set_conv_nth split: if_split_asm)

lemma index_of_None_conv: "index_of l x = None \<longleftrightarrow> x\<notin>set l"
  using dom_index_of[of l] by auto

lemma index_of_Nil: "index_of [] x = None"
  by (auto simp: index_of_None_conv)

lemma index_of_Cons: "distinct (a#l)
  \<Longrightarrow> index_of (a#l) x = (if x=a then Some 0 else map_option Suc (index_of l x))"
  apply (auto simp: index_of_Some_conv)
  apply (cases "index_of (a # l) x")
  apply (simp_all only: )
  apply (cases "index_of l x")
  apply (simp_all only: ) [2]
  apply (auto simp: index_of_Some_conv index_of_None_conv) [2]
  apply (cases "index_of l x")
  apply (simp_all only: )
  apply (auto simp: index_of_Some_conv index_of_None_conv
    in_set_conv_nth nth_Cons nth_eq_iff_index_eq split: nat.splits)
  done

primrec cr_index_of where
  "cr_index_of [] x = None"
| "cr_index_of (a#l) x = (if x=a then Some 0 else map_option Suc (cr_index_of l x))"

lemma cr_index_of_eq: "distinct l \<Longrightarrow> cr_index_of l = index_of l"
  apply (induction l)
  apply (auto simp: index_of_Nil index_of_Cons)
  done

locale sl_graph = asystem +
  fixes rlist and succ_list
  assumes rl_distinct: "distinct rlist"
  assumes rl_reachable: "E\<^sup>* `` V0 \<subseteq> set rlist"
  assumes rl_closed: "\<And>c c'. \<lbrakk>c\<in>set rlist; (c, c') \<in> step\<rbrakk> \<Longrightarrow> c'\<in>set rlist"
  assumes sl_distinct: "c\<in>set rlist \<Longrightarrow> distinct (succ_list c)"
  assumes sl_succs: "set (succ_list c) = {(a,c'). astep c a c'}"
begin
  definition "succs_tab \<equiv> map succ_list rlist"

  lemma astep_succs_tab_conv:
    assumes R: "c\<in>set rlist"
    shows "astep c a c' \<longleftrightarrow> (\<exists>i<length succs_tab. c=rlist!i \<and> (a,c')\<in>set (succs_tab!i))"
  proof -
    from R obtain i where "i<length rlist" and RLI[simp]: "rlist!i=c"
      by (auto simp: in_set_conv_nth)
    hence 1: "i<length succs_tab" "succs_tab!i=succ_list c"
      unfolding succs_tab_def
      by auto

    have AUX: "\<And>j. \<lbrakk>c = rlist!j; j<length succs_tab\<rbrakk> \<Longrightarrow> i=j"
    proof -
      fix j
      assume "c = rlist!j" "j<length succs_tab"
      hence "rlist!j=rlist!i" "j<length rlist" by (simp_all add: succs_tab_def)
      with nth_eq_iff_index_eq[OF rl_distinct \<open>i<length rlist\<close> \<open>j<length rlist\<close>]
      show "i=j" by simp
    qed

    from 1 show ?thesis using sl_succs
      by (auto dest: AUX)
  qed

  lemma succs_tab_invar: "i<length succs_tab \<Longrightarrow> distinct (succs_tab!i)"
    unfolding succs_tab_def
    using rl_reachable sl_distinct
    by auto

  lemma succs_tab_rl: "\<lbrakk>i<length rlist; (a,c')\<in>set (succs_tab!i)\<rbrakk>
    \<Longrightarrow> c' \<in> set rlist"
    unfolding succs_tab_def
    apply (simp add: sl_succs)
    apply (rule rl_closed[rotated])
    unfolding step_def
    apply blast
    apply simp
    done

  definition "mapped_succs_tab \<equiv> IArray (
    map (map (\<lambda>(a,c'). (a,the (cr_index_of rlist c')))) succs_tab)"

  definition "\<gamma> c \<equiv> the (cr_index_of rlist c)"
  definition "\<alpha> i \<equiv> rlist!i"
  definition "succ_impl ci \<equiv>
    if ci<IArray.length mapped_succs_tab then
      mapped_succs_tab!!ci
    else []"
  definition "astep_impl c a c' \<equiv> (a,c')\<in>set (succ_impl c)"

  lemma astep_succ_finite[simp, intro!]:
    "finite {(a,c'). astep_impl c a c'}"
    unfolding astep_impl_def
    by auto

  lemma astep_succ_finite_c[simp, intro!]:
    "finite ({c'. \<exists>a. astep_impl c a c'})"
  proof -
    have "{c'. \<exists>a. astep_impl c a c'} = snd`{(a,c'). astep_impl c a c'}"
      by auto
    also have "finite \<dots>" by auto
    finally show ?thesis .
  qed

  lemma \<alpha>_inj: "inj_on \<alpha> {0..<length rlist}"
    by (auto intro!: inj_onI simp: \<alpha>_def nth_eq_iff_index_eq[OF rl_distinct])

  lemma \<gamma>_inj: "inj_on \<gamma> (set rlist)"
    using rl_reachable
    apply (auto intro!: inj_onI
      simp: \<gamma>_def rl_distinct
      cr_index_of_eq)
    by (metis index_of_None_conv index_of_Some_conv not_None_eq
      option.sel rl_distinct)

  lemma \<gamma>_\<alpha>_inverse: "i<length rlist \<Longrightarrow> \<gamma> (\<alpha> i) = i"
    unfolding \<alpha>_def \<gamma>_def
    apply (auto simp: cr_index_of_eq[OF rl_distinct])
    apply (cases "index_of rlist (rlist ! i)", simp_all)
    apply (auto simp: index_of_None_conv index_of_Some_conv[OF rl_distinct]
      simp: nth_eq_iff_index_eq[OF rl_distinct])
    done

  lemma \<alpha>_\<gamma>_inverse: "c\<in>set rlist \<Longrightarrow> \<alpha> (\<gamma> c) = c"
    unfolding \<alpha>_def \<gamma>_def
    apply (auto simp: cr_index_of_eq[OF rl_distinct])
    apply (cases "index_of rlist c", simp_all)
    apply (auto simp: index_of_None_conv index_of_Some_conv[OF rl_distinct]
      simp: nth_eq_iff_index_eq[OF rl_distinct])
    done

  lemma \<gamma>_invar: "c\<in>set rlist \<Longrightarrow> \<gamma> c < length rlist"
    apply (auto simp: \<gamma>_def cr_index_of_eq rl_distinct)
    by (metis index_of_None_conv index_of_Some_conv
      not_None_eq option.sel rl_distinct)

  lemma \<alpha>_invar: "i<length rlist \<Longrightarrow> \<alpha> i \<in> set rlist"
    unfolding \<alpha>_def by simp

  definition "invar i \<equiv> i<length rlist"
  definition "rel \<equiv> brp \<alpha> invar"
  definition "reli \<equiv> brp \<gamma> (\<lambda>x. x\<in>set rlist)"

  lemma bi_unique_rel: "bi_unique rel"
    apply (intro bi_uniqueI left_uniqueI right_uniqueI)
    by (auto simp: rel_def build_relp_def invar_def
      inj_onD[OF \<alpha>_inj])

  lemma bi_unique_reli: "bi_unique reli"
    apply (intro bi_uniqueI left_uniqueI right_uniqueI)
    by (auto simp: reli_def build_relp_def
      inj_onD[OF \<gamma>_inj])

  lemma rel_inv_eq_reli: "rel\<inverse>\<inverse> = reli"
    by (auto
      intro!: ext
      simp: rel_def reli_def build_relp_def invar_def
      simp: \<gamma>_\<alpha>_inverse \<alpha>_\<gamma>_inverse \<gamma>_invar \<alpha>_invar
      )

  corollary reli_inv_eq_rel: "reli\<inverse>\<inverse> = rel"
    using arg_cong[where f="\<lambda>r. r\<inverse>\<inverse>", OF rel_inv_eq_reli, simplified]
    by simp

  lemma rel_unfold1: "c\<in>set rlist \<Longrightarrow> rel i c \<longleftrightarrow> i = \<gamma> c"
    unfolding reli_inv_eq_rel[symmetric]
    by (simp add: reli_def build_relp_def)

  lemma is_reachable_criE:
    assumes R: "c \<in> E\<^sup>* `` V0"
    obtains i where "cr_index_of rlist c = Some i"
  proof -
    from R have IS: "c\<in>set rlist" using rl_reachable by auto

    show ?thesis
      using IS
      by (auto
        simp: cr_index_of_eq[OF rl_distinct] index_of_Some_conv[OF rl_distinct]
        simp: in_set_conv_nth
        intro: that)
  qed

  lemma sim1i: "\<lbrakk> astep c1 a c2; reli c1 c1' \<rbrakk> \<Longrightarrow> \<exists>c2'. reli c2 c2' \<and> astep_impl c1' a c2'"
    apply (auto simp: reli_def build_relp_def)
    apply (rule rl_closed, auto simp: step_def) []
  proof -
    assume R: "c1\<in>set rlist" and S: "astep c1 a c2"
    then obtain i where L: "i<length succs_tab"
      and C1: "c1=rlist!i" and AC': "(a,c2)\<in>set (succs_tab!i)"
      by (auto simp: astep_succs_tab_conv)

    have [simp]: "i<length rlist" using L by simp
    note [simp] = L

    from C1 have [simp]: "\<gamma> c1 = i"
      unfolding \<gamma>_def
      apply (cases "cr_index_of rlist c1")
      apply simp_all
      apply (auto simp: cr_index_of_eq[OF rl_distinct]
        index_of_Some_conv[OF rl_distinct] index_of_None_conv
        nth_eq_iff_index_eq[OF rl_distinct])
      done

    show "astep_impl (\<gamma> c1) a (\<gamma> c2)"
      using AC'
      apply (auto simp: astep_impl_def succ_impl_def mapped_succs_tab_def)
      apply (auto simp: \<gamma>_def)
      done
  qed

  lemma sim2i: "\<lbrakk> astep_impl c1' a c2'; reli c1 c1' \<rbrakk> \<Longrightarrow> \<exists>c2. reli c2 c2' \<and> astep c1 a c2"
  proof -
    assume "reli c1 c1'"
    hence R: "c1\<in>set rlist" and [simp]: "c1'=\<gamma> c1"
      by (auto simp: reli_def build_relp_def)

    hence [simp]: "\<gamma> c1 < length rlist"
      unfolding \<gamma>_def using rl_reachable
      apply (cases "cr_index_of rlist c1", simp_all)
      apply (auto simp: \<alpha>_def cr_index_of_eq[OF rl_distinct]
        index_of_None_conv index_of_Some_conv[OF rl_distinct])
      done

    have [simp]: "rlist!\<gamma> c1 = c1"
      unfolding \<alpha>_def[symmetric]
      by (simp add: \<alpha>_\<gamma>_inverse R)

    assume "astep_impl c1' a c2'"
    then obtain c2 where "(a, c2) \<in> set (succs_tab ! \<gamma> c1)" and [simp]: "c2' = \<gamma> c2"
      apply (auto simp: astep_impl_def succ_impl_def mapped_succs_tab_def)
      apply (auto simp: \<gamma>_def)
      done
    with astep_succs_tab_conv[THEN iffD2, OF R, OF exI, of c1' a c2]
      have "astep c1 a c2" by auto
     moreover hence "c2\<in>set rlist"
      using rl_closed[OF R, of c2] by (auto simp: step_def)
    hence "reli c2 c2'"
      by (auto simp: reli_def build_relp_def)
    ultimately show "\<exists>c2. reli c2 c2' \<and> astep c1 a c2" by blast
  qed

  corollary sim1: "\<lbrakk> astep_impl c1' a c2'; rel c1' c1 \<rbrakk> \<Longrightarrow> \<exists>c2. rel c2' c2 \<and> astep c1 a c2"
    using sim2i unfolding reli_inv_eq_rel[symmetric] by simp

  corollary sim2: "\<lbrakk> astep c1 a c2; rel c1' c1 \<rbrakk> \<Longrightarrow> \<exists>c2'. rel c2' c2 \<and> astep_impl c1' a c2'"
    using sim1i unfolding reli_inv_eq_rel[symmetric] by simp

  lemma succ_impl_invar: "distinct (succ_impl ci)"
    unfolding succ_impl_def mapped_succs_tab_def invar_def
    using succs_tab_invar[of ci]
    apply (clarsimp simp: distinct_map)
    apply (fold \<gamma>_def)
    apply (rule inj_onI)
    apply clarsimp (* TODO: This proof is not particular clean *)
    apply (drule (1) succs_tab_rl[rotated])
    apply (drule (1) succs_tab_rl[rotated])
    by (metis \<alpha>_\<gamma>_inverse local.\<alpha>_def)

  lemma succ_impl_invarc: "\<lbrakk>invar c; (a,c')\<in>set (succ_impl c)\<rbrakk> \<Longrightarrow> invar c'"
    unfolding succ_impl_def mapped_succs_tab_def invar_def
    apply (clarsimp)
    by (metis \<gamma>_def \<gamma>_invar succs_tab_rl)

  lemma astep_impl_invarc: "\<lbrakk>invar c; astep_impl c a c'\<rbrakk> \<Longrightarrow> invar c'"
    unfolding astep_impl_def
    by (auto intro: succ_impl_invarc)

end

lemma path'_path_conv:
  "li'.cs.path c p c' \<longleftrightarrow> cfg_lts.path c (map Inl p) c'"
  by (induction p arbitrary: c) (auto simp: cfg'_def)

lemma approx_reachable_approx': "li'.cs.reachable c c' \<Longrightarrow> c' \<in> approx_reachable c"
  using approx_reachable_approx[of c c']
  by (auto simp: LTS.reachable_def path'_path_conv)

(* TODO: Move *)
lemma approx_reachable_closed':
  assumes "c\<in>approx_reachable c0"
  assumes "cfg' c a c'"
  shows "c'\<in>approx_reachable c0"
  using assms
  unfolding cfg'_def
  using approx_reachable_closed
  by blast

type_synonym cmdc = nat
type_synonym local_config = "(cmdc, local_state) Gen_Scheduler.local_config"
type_synonym global_config = "(cmdc, local_state, global_state) Gen_Scheduler.global_config"

locale cprog =
  fixes prog :: program
begin
  sublocale comp: asystem "\<lambda>x. x\<in>cfg_V0 prog" cfg' .

  sublocale comp: sl_graph
    "\<lambda>x. x\<in>cfg_V0 prog" cfg'
    "approx_reachable_list prog" "cfg'_succ_list"
  apply unfold_locales
  apply (simp_all
    add: approx_reachable_list_invar approx_reachable_list_refine
    add: cfg'_succ_list_invar cfg'_succ_list_refine
    add: approx_reachable_prog_def
    )
  using approx_reachable_approx'
  apply (auto simp: comp.step_path_conv LTS.reachable_def) []

  using approx_reachable_closed' unfolding comp.step_def
  by blast

  abbreviation "cfgc \<equiv> comp.astep_impl"

  definition init_pc :: "proc_decl \<Rightarrow> local_config" where
    "init_pc pd \<equiv> \<lparr>
      local_config.command = comp.\<gamma> (proc_decl.body pd),
      local_config.state = \<lparr>
        local_state.variables = init_valuation (proc_decl.local_vars pd)
      \<rparr>
    \<rparr>"

  definition init_gc :: "global_config" where
    "init_gc \<equiv> \<lparr>
      global_config.processes = mset (map init_pc (program.processes prog)),
      global_config.state = \<lparr>
        global_state.variables = init_valuation (program.global_vars prog)
      \<rparr>
    \<rparr>"

  sublocale lih': Gen_Scheduler'_linit
    cfgc la_en' la_ex'
    "{init_gc}" global_config.state .

  sublocale hc_bisim: Gen_Cfg_Bisim_Pre comp.rel
    cfgc cfg' la_en' la_ex'
    apply unfold_locales
    apply (blast dest: comp.sim1)
    apply (blast dest: comp.sim2)
    done

  lemma approx_reachable_prog0: "p \<in> set (program.processes prog) \<Longrightarrow>
         body p \<in> approx_reachable_prog prog"
    unfolding approx_reachable_prog_def
    by (auto simp: cfg_V0_def intro!: bexI)

  sublocale hc_bisim: Gen_Cfg_LBisim comp.rel
    cfgc "{init_gc}" global_config.state
    cfg' "{SM_Semantics.init_gc prog}" global_config.state la_en' la_ex'
    apply unfold_locales
    apply (auto
      simp: init_gc_def SM_Semantics.init_gc_def
      simp: init_pc_def SM_Semantics.init_pc_def
      simp: hc_bisim.rel_gc_def hc_bisim.rel_lc_def
      simp del: mset_map simp: mset_map[symmetric]
      intro!: rel_mset_of_mapI)

    apply (subst comp.rel_unfold1)
    apply (unfold approx_reachable_list_refine)
    apply (simp add: approx_reachable_prog0)
    apply simp

    apply (subst comp.rel_unfold1)
    apply (unfold approx_reachable_list_refine)
    apply (simp add: approx_reachable_prog0)
    apply simp
    done

  lemma lih'_accept_eq_li': "lih'.sa.accept = li'.sa.accept prog"
    by (rule hc_bisim.accept_bisim)

  definition "lc_\<alpha> lc \<equiv> \<lparr>
    local_config.command = comp.\<alpha> (local_config.command lc),
    local_config.state = local_config.state lc
  \<rparr>"
  definition "lc_invar lc \<equiv> comp.invar (local_config.command lc)"

  lemma hc_bisim_rel_lc_brp_conv: "hc_bisim.rel_lc = brp lc_\<alpha> lc_invar"
    apply (intro ext)
    unfolding hc_bisim.rel_lc_def
    unfolding comp.rel_def lc_\<alpha>_def lc_invar_def build_relp_def
    by auto

  definition "gc_\<alpha> gc \<equiv> \<lparr>
    global_config.processes = image_mset lc_\<alpha> (global_config.processes gc),
    global_config.state = global_config.state gc
  \<rparr>"
  definition "gc_invar gc \<equiv> \<forall>lc. lc \<in># global_config.processes gc \<longrightarrow> lc_invar lc"

  lemma hc_bisim_rel_gc_brp_conv: "hc_bisim.rel_gc = brp gc_\<alpha> gc_invar"
    apply (intro ext)
    unfolding hc_bisim.rel_gc_def hc_bisim_rel_lc_brp_conv
    unfolding comp.rel_def gc_\<alpha>_def gc_invar_def
    apply (auto simp: rel_mset_brp)
    apply (auto simp: build_relp_def)
    done

  lemmas bi_unique_rel_gc = hc_bisim.bi_unique_rel_gcI[OF comp.bi_unique_rel]
  lemmas bi_unique_rel_lc = hc_bisim.bi_unique_rel_lcI[OF comp.bi_unique_rel]

  lemma run_sim_lih'_li: "lih'.sa.is_run r \<Longrightarrow> li'.sa.is_run prog (gc_\<alpha> o r)"
    apply (rule hc_bisim.s1.br_run_sim)
    unfolding hc_bisim_rel_gc_brp_conv
    by auto

  lemmas lih'_reachable_finite_sim = hc_bisim.s1.reachable_finite_sim

end

context well_typed_prog begin
  sublocale cprog .

  lemma lih'_accept_eq: "lih'.sa.accept = ref_accept prog"
    by (simp add: lih'_accept_eq_li' li'.accept_eq)

  lemma lih'_is_run_sim: "lih'.sa.is_run r \<Longrightarrow> ref_is_run prog (Some o gc_\<alpha> o r)"
    apply (drule run_sim_lih'_li)
    unfolding li'.is_run_conv
    by (auto simp: o_def)

  lemma lih'_finite_reachable: "finite ((g_E lih'.system_automaton)\<^sup>* `` g_V0 lih'.system_automaton)"
    apply (rule lih'_reachable_finite_sim)
    apply (rule li'_finite_reachable)
    unfolding rel_of_pred_def
    apply simp
    apply (rule left_unique_finite_sngI)
    using bi_unique_rel_gc
    apply (simp add: bi_unique_alt_def)
    done

end

(* Executable *)
type_synonym comp_info = "(cmd list \<times> (action \<times> nat) list iarray)"
(* TODO: Using a list is slow. Could use a hashmap to map commands to
  their indices *)

definition comp_info_of :: "program \<Rightarrow> comp_info" where
  "comp_info_of prog \<equiv> let
  rlist = approx_reachable_list prog;
  succs_tab = map cfg'_succ_list rlist;
  mapped_succs_tab = IArray (
    map (map (\<lambda>(a,c'). (a,the (cr_index_of rlist c')))) succs_tab)
in
  (rlist,mapped_succs_tab)"

definition ccfg_succ_impl
  :: "comp_info \<Rightarrow> nat \<Rightarrow> (action \<times> nat) list"
where
  "ccfg_succ_impl cinf c \<equiv>
    let mst=snd cinf in
      if c<IArray.length mst then mst!!c else []"

lemma (in cprog) ccfg_succ_impl:
  "ccfg_succ_impl (comp_info_of prog) = comp.succ_impl"
  apply (intro ext)
  unfolding comp.succ_impl_def comp.mapped_succs_tab_def comp.succs_tab_def
  unfolding ccfg_succ_impl_def comp_info_of_def
  by simp

definition comp_\<gamma>_impl :: "comp_info \<Rightarrow> cmd \<Rightarrow> cmdc" where
  "comp_\<gamma>_impl cinf c \<equiv> the (cr_index_of (fst cinf) c)"

lemma (in cprog) comp_\<gamma>_impl: "comp_\<gamma>_impl (comp_info_of prog) = comp.\<gamma>"
  apply (intro ext)
  unfolding comp.\<gamma>_def
  unfolding comp_\<gamma>_impl_def comp_info_of_def
  by simp

export_code comp_info_of ccfg_succ_impl comp_\<gamma>_impl checking SML

end


theory flash85Rev imports flashPub
begin
section{*Main defintions*}
lemma NI_FAckVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_FAck ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_InvVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Inv  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_InvAck_1VsInv85:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_InvAck_1  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_InvAck_1_HomeVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_InvAck_1_Home  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_InvAck_2VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_InvAck_2 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_GetXVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_GetX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_Nak1VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_Nak1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_Nak2VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_Nak2  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_Nak3VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_Nak3  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_GetX_PutX1VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX1 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX2VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX2 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX3VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX3 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX4VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX4 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX5VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX5 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX6VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX6 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX7VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX7 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX8VsInv85:
  (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX8 N  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1  a2  a3 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX8_homeVsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX8_home N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX9VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX9 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX10VsInv85:
  (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX10 N  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1  a2  a3 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX10_homeVsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX10_home N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_GetX_PutX11VsInv85:
  (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_GetX_PutX11 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply(cut_tac  a1 , auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_Local_Get_GetVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Get  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Nak1VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Nak1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Nak2VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Nak2  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Nak3VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Nak3  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Put1VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Put1 N  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Put2VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Put2  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_Get_Put3VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Get_Put3  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Local_PutVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_Local_Put ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_Local_PutXAcksDoneVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_Local_PutXAcksDone ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_NakVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Nak  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Nak_ClearVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_Nak_Clear ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_Nak_HomeVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_Nak_Home ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_Remote_GetX_NakVsInv85:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_GetX_Nak  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_GetX_Nak_HomeVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_GetX_Nak_Home  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_GetX_PutXVsInv85:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_GetX_PutX  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_GetX_PutX_HomeVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_GetX_PutX_Home  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Nak1VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_Get_Nak1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Nak2VsInv85:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_Get_Nak2  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Put1VsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_Get_Put1  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_Get_Put2VsInv85:
    (*Rule2VsPInv0*)
  assumes   a1:"iRule1 \<le> N" and  a2:"iRule2 \<le> N" and  a3:"iRule1~=iRule2  "

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_Get_Put2  iRule1  iRule2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1 a2 a3,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_PutVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_Put  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_Remote_PutXVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Remote_PutX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_ReplaceVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_Replace  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_ReplaceHomeVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_ReplaceHome ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_ReplaceHomeShrVldVsInv85:
  (*Rule0VsPInv0*)
  shows  "invHoldForRule' s (inv85 ) (NI_ReplaceHomeShrVld ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

      have "?P1 s"

        apply( auto)

        done

        then  show "?P1 s\<or> ?P2 s\<or> ?P3 s"

       by blast

 qed
lemma NI_ReplaceShrVldVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (NI_ReplaceShrVld  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma NI_ShWbVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_ShWb N ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma NI_WbVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (NI_Wb ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_GetX1VsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_GetX_GetX1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_GetX2VsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_GetX_GetX2 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_PutX1VsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_GetX_PutX1 N ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_PutX2VsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_GetX_PutX2 N ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_PutX3VsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_GetX_PutX3 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_GetX_PutX4VsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_GetX_PutX4 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_Get_GetVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_Get_Get ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_Get_PutVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_Get_Put ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_PutXVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_PutX ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Local_ReplaceVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (PI_Local_Replace ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  lemma PI_Remote_GetVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (PI_Remote_Get  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma PI_Remote_GetXVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (PI_Remote_GetX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma PI_Remote_PutXVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (PI_Remote_PutX  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma PI_Remote_ReplaceVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (PI_Remote_Replace  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma StoreVsInv85:
    (*Rule1VsPInv0*)
  assumes   a1:"iRule1 \<le> N"

  shows  "invHoldForRule' s (inv85 ) (Store  iRule1 ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

  proof -

     have "?P2 s"

     by (cut_tac a1,auto  )
   then show "?P1 s\<or>?P2 s\<or>?P3 s"
      by auto
 qed
  lemma StoreHomeVsInv85:
    (*Rule0VsPInv0*)

  shows  "invHoldForRule' s (inv85 ) (StoreHome ) (invariants   N)" (is " ?P1 s\<or>?P2 s\<or>?P3 s")

      by( auto)

  end