(*  Title:      Uint_Userguide.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* User guide for native words *}

(*<*)
theory Uint_Userguide imports
  Uint32
  Uint16
  Code_Target_Bits_Int
begin
(*>*)

text {*
  This tutorial explains how to best use the types for native
  words like @{typ "uint32"} in your formalisation.
  You can base your formalisation
  \begin{enumerate}
  \item either directly on these types,
  \item or on the generic @{typ "'a word"} and only introduce native
    words a posteriori via code generator refinement.
  \end{enumerate}

  The first option causes the least overhead if you have to prove only
  little about the words you use and start a fresh formalisation.
  Just use the native type @{typ uint32} instead of @{typ "32 word"}
  and similarly for @{text uint16} and @{text uint8}.
  As native word types are meant only for code generation, the lemmas
  about @{typ "'a word"}  have not been duplicated, but you can transfer
  theorems between native word types and @{typ "'a word"} using the
  transfer package.

  Note, however, that this option restricts your work a bit:
  your own functions cannot be ``polymorphic'' in the word length,
  but you have to define a separate function for every word length you need.

  The second option is recommended if you already have a formalisation
  based on @{typ "'a word"} or if your proofs involve words and their
  properties. It separates code generation from modelling and proving,
  i.e., you can work with words as usual. Consequently, you have to
  manually setup the code generator to use the native types wherever
  you want. The following describes how to achieve this with moderate
  effort.

  Note, however, that some target languages of the code generator
  (especially OCaml) do not support all the native word types provided.
  Therefore, you should only import those types that you need -- the
  theory file for each type mentions at the top the restrictions for
  code generation. For example, PolyML does not provide the Word16
  structure, and OCaml provides neither Word8 nor Word16.
  You can still use these theories provided that you also import
  the theory @{theory "Code_Target_Bits_Int"} (which implements
  @{typ int} by target-language integers), but these words will
  be implemented via Isabelle's @{text "HOL-Word"} library, i.e.,
  you do not gain anything in terms of efficiency.

  \textbf{There is a separate code target @{text "SML_word"} for SML.}
  If you use one of the native words that PolyML does not support
  (such as @{text "uint16"}), but would like to map its operations
  to the Standard Basis Library functions, make sure to use the target
  @{text "SML_word"} instead of @{text "SML"};  if you only use native
  word sizes that PolyML supports, you can stick with @{text "SML"}.
  This ensures that code generation within Isabelle as used by
  @{text Quickcheck}, @{text value} and @\{code\} in ML blocks
  continues to work.
*}

section {* Lifting functions from @{typ "'a word"} to native words *}

text {*
  This section shows how to convert functions from @{typ "'a word"} to native
  words. For example, the following function @{text sum_squares} computes
  the sum of the first @{term n} square numbers in 16 bit arithmetic using
  a tail-recursive function @{text gen_sum_squares} with accumulator;
  for convenience, @{text sum_squares_int} takes an integer instead of a word.
*}

function gen_sum_squares :: "16 word \<Rightarrow> 16 word \<Rightarrow> 16 word" where (*<*)[simp del]:(*>*)

  "gen_sum_squares accum n =
   (if n = 0 then accum else gen_sum_squares (accum + n * n) (n - 1))"
(*<*)by pat_completeness simp
termination by(relation "measure (nat \<circ> uint \<circ> snd)")
  (simp_all, metis (hide_lams, mono_tags) uint_1 uint_eq_0 uint_minus_simple_alt uint_sub_ge word_le_sub1 word_less_def word_neq_0_conv word_zero_le zle_diff1_eq)(*>*)

definition sum_squares :: "16 word \<Rightarrow> 16 word" where
   "sum_squares = gen_sum_squares 0"

definition sum_squares_int :: "int \<Rightarrow> 16 word" where
  "sum_squares_int n = sum_squares (word_of_int n)"

text {*
  The generated code for @{term sum_squares} and @{term sum_squares_int}
  emulates words with unbounded integers and explicit modulus as specified
  in the theory @{theory Word}. But for efficiency, we want that the
  generated code uses machine words and machine arithmetic. Unfortunately,
  as @{typ "'a word"} is polymorphic in the word length, the code generator
  can only do this if we use another type for machine words. The theory
  @{theory Uint16} defines the type @{typ uint16} for machine words of
  16~bits. We just have to follow two steps to use it:

  First, we lift all our functions from @{typ "16 word"} to @{typ uint16},
  i.e., @{term sum_squares}, @{term gen_sum_squares}, and
  @{term sum_squares_int} in our case. The theory @{theory Uint16} sets
  up the lifting package for this and has already taken care of the
  arithmetic and bit-wise operations.
*}
lift_definition gen_sum_squares_uint :: "uint16 \<Rightarrow> uint16 \<Rightarrow> uint16"
  is gen_sum_squares .
lift_definition sum_squares_uint :: "uint16 \<Rightarrow> uint16" is sum_squares .
lift_definition sum_squares_int_uint :: "int \<Rightarrow> uint16" is sum_squares_int .

text {*
  Second, we also have to transfer the code equations for our functions.
  The attribute @{text Transfer.transferred} takes care of that, but it is
  better to check that the transfer succeeded: inspect the theorem to check
  that the new constants are used throughout.
*}

lemmas [Transfer.transferred, code] =
  gen_sum_squares.simps
  sum_squares_def
  sum_squares_int_def

text {*
  Finally, we export the code to standard ML.  We use the target
  @{text "SML_word"} instead of @{text "SML"} to have the operations
  on @{typ uint16} mapped to the Standard Basis Library. As PolyML
  does not provide a Word16 type, the mapping for @{typ uint16} is only
  active in the refined target @{text "SML_word"}.
*}
export_code sum_squares_int_uint in SML_word

text {*
  Nevertheless, we can still evaluate terms with @{term "uint16"} within
  Isabelle, i.e., PolyML, but this will be translated to @{typ "16 word"}
  and therefore less efficient.
*}

value "sum_squares_int_uint 40"

section {* Storing native words in datatypes *}

text {*
  The above lifting is necessary for all functions whose type mentions
  the word type. Fortunately, we do not have to duplicate functions that
  merely operate on datatypes that contain words. Nevertheless, we have
  to tell the code generator that these functions should call the new ones,
  which operate on machine words. This section shows how to achieve this
  with data refinement.
*}

subsection {* Example: expressions and two semantics *}

text {*
  As the running example, we consider a language of expressions (literal values, less-than comparisions and conditional) where values are either booleans or 32-bit words.
  The original specification uses the type @{typ "32 word"}.
*}

datatype val = Bool bool | Word "32 word"
datatype expr = Lit val | LT expr expr | IF expr expr expr

abbreviation (input) word :: "32 word \<Rightarrow> expr" where "word i \<equiv> Lit (Word i)"
abbreviation (input) bool :: "bool \<Rightarrow> expr" where "bool i \<equiv> Lit (Bool i)"

-- {* Denotational semantics of expressions, @{term None} denotes a type error *}
fun eval :: "expr \<Rightarrow> val option" where
  "eval (Lit v) = Some v"
| "eval (LT e\<^sub>1 e\<^sub>2) =
  (case (eval e\<^sub>1, eval e\<^sub>2)
   of (Some (Word i\<^sub>1), Some (Word i\<^sub>2)) \<Rightarrow> Some (Bool (i\<^sub>1 < i\<^sub>2))
   | _ \<Rightarrow> None)"
| "eval (IF e\<^sub>1 e\<^sub>2 e\<^sub>3) =
  (case eval e\<^sub>1 of Some (Bool b) \<Rightarrow> if b then eval e\<^sub>2 else eval e\<^sub>3
   | _ \<Rightarrow> None)"

-- {* Small-step semantics of expressions, it gets stuck upon type errors. *}
inductive step :: "expr \<Rightarrow> expr \<Rightarrow> bool" ("_ \<rightarrow> _" [50, 50] 60) where
  "e \<rightarrow> e' \<Longrightarrow> LT e e\<^sub>2 \<rightarrow> LT e' e\<^sub>2"
| "e \<rightarrow> e' \<Longrightarrow> LT (word i) e \<rightarrow> LT (word i) e'"
| "LT (word i\<^sub>1) (word i\<^sub>2) \<rightarrow> bool (i\<^sub>1 < i\<^sub>2)"
| "e \<rightarrow> e' \<Longrightarrow> IF e e\<^sub>1 e\<^sub>2 \<rightarrow> IF e' e\<^sub>1 e\<^sub>2"
| "IF (bool True) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>1"
| "IF (bool False) e\<^sub>1 e\<^sub>2 \<rightarrow> e\<^sub>2"

-- {* Compile the inductive definition with the predicate compiler *}
code_pred (modes: i \<Rightarrow> o \<Rightarrow> bool as reduce, i \<Rightarrow> i \<Rightarrow> bool as step') step .

subsection {* Change the datatype to use machine words *}

text {*
  Now, we want to use @{typ uint32} instead of @{typ "32 word"}.
  The goal is to make the code generator use the new type without
  duplicating any of the types (@{typ val}, @{typ expr}) or the
  functions (@{term eval}, @{term reduce}) on such types.

  The constructor @{term Word} has @{typ "32 word"} in its type, so
  we have to lift it to @{text "Word'"}, and the same holds for the
  case combinator @{term case_val}, which @{term case_val'} replaces.%
  \footnote{%
    Note that we should not declare a case translation for the new
    case combinator because this will break parsing case expressions
    with old case combinator.
  }
  Next, we set up the code generator accordingly:
  @{term Bool} and @{term Word'} are the new constructors for @{typ val},
  and @{term case_val'} is the new case combinator with an appropriate
  case certificate.%
  \footnote{%
    Case certificates tell the code generator to replace the HOL
    case combinator for a datatype with the case combinator of the
    target language.  Without a case certificate, the code generator
    generates a function that re-implements the case combinator;
    in a strict languages like ML or Scala, this means that the code
    evaluates all possible cases before it decides which one is taken.

    Case certificates are described in Haftmann's PhD thesis
    \cite[Def.\ 27]{Haftmann2009PhD}. For a datatype @{text dt}
    with constructors @{text "C\<^sub>1"} to @{text "C\<^sub>n"}
    where each constructor @{text "C\<^sub>i"} takes @{text "k\<^sub>i"} parameters,
    the certificate for the case combinator @{text "case_dt"}
    looks as follows:

    {
      \isamarkuptrue\isacommand{lemma}\isamarkupfalse\isanewline%
      \ \ \isakeyword{assumes}\ {\isachardoublequoteopen}CASE\ {\isasymequiv}\ dt{\isacharunderscore}case\ c\isactrlsub {\isadigit{1}}\ c\isactrlsub {\isadigit{2}}\ \ldots\ c\isactrlsub{n}{\isachardoublequoteclose}\isanewline
      \ \ \isakeyword{shows}\ {\isachardoublequoteopen}{\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{1}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{1}}\isactrlsub {k\ensuremath{{}_1}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {\isadigit{2}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{1}}\ a\isactrlsub {\isadigit{2}}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {\isadigit{2}}\isactrlsub {k\ensuremath{{}_2}}{\isacharparenright}\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ \ldots\isanewline
      \ \ \ \ {\isacharampersand}{\isacharampersand}{\isacharampersand}\ {\isacharparenleft}CASE\ {\isacharparenleft}C\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}\ {\isasymequiv}\ c\isactrlsub {n}\ a\isactrlsub {n}\isactrlsub {\isadigit{1}}\ a\isactrlsub {n}\isactrlsub {\isadigit{2}}\ \ldots\ a\isactrlsub {n}\isactrlsub {k\ensuremath{{}_n}}{\isacharparenright}{\isachardoublequoteclose}\isanewline
    }
  }
  We delete the code equations for the old constructor @{term Word}
  and case combinator @{term case_val} such that the code generator
  reports missing adaptations.
*}

lift_definition Word' :: "uint32 \<Rightarrow> val" is Word .

code_datatype Bool Word'

lift_definition case_val' :: "(bool \<Rightarrow> 'a) \<Rightarrow> (uint32 \<Rightarrow> 'a) \<Rightarrow> val \<Rightarrow> 'a" is case_val .

lemmas [code, simp] = val.case [Transfer.transferred]

lemma case_val'_cert:
  fixes bool word' b w
  assumes "CASE \<equiv> case_val' bool word'"
  shows "(CASE (Bool b) \<equiv> bool b) &&& (CASE (Word' w) \<equiv> word' w)"
by(simp_all add: assms)
setup {* Code.add_case @{thm case_val'_cert} *}

lemma [code, code del]: "case_val = case_val" ..
lemma [code, code del]: "Word = Word" ..

subsection {* Make functions use functions on machine words *}

text {*
  Finally, we merely have to change the code equations to use the
  new functions that operate on @{typ uint32}. As before, the
  attribute @{text Transfer.transferred} does the job. In our example,
  we adapt the equality test on @{typ val} (code equations
  @{thm [source] val.eq.simps}) and the denotational and small-step
  semantics (code equations @{thm [source] eval.simps} and
  @{thm [source] step.equation}, respectively).

  We check that the adaptation has suceeded by exporting the functions.
  As we only use native word sizes that PolyML supports, we can use
  the usual target @{text "SML"} instead of @{text "SML_word"}.
*}

lemmas [code] =
  val.eq.simps[THEN meta_eq_to_obj_eq, Transfer.transferred, THEN eq_reflection]
  eval.simps[Transfer.transferred]
  step.equation[Transfer.transferred]

export_code reduce step' eval in SML

section {* Troubleshooting *}

text {*
  This section explains some possible problems when using native words.
  If you experience other difficulties, please contact the author.
*}

subsection {* @{text export_code} raises an exception \label{section:export_code:exception} *}

text {*
  Probably, you have defined and are using a function on a native word type,
  but the code equation refers to emulated words. For example, the following
  defines a function @{text double} that doubles a word. When we try to export
  code for @{text double} without any further setup, @{text export_code} will
  raise an exception or generate code that does not compile.
*}

lift_definition double :: "uint32 \<Rightarrow> uint32" is "\<lambda>x. x + x" .

text {*
  We have to prove a code equation that only uses the existing operations on
  @{typ uint32}. Then, @{text export_code} works again.
*}

lemma double_code [code]: "double n = n + n"
by transfer simp

subsection {* The generated code does not compile *}

text {*
  Probably, you have been exporting to a target language for which there
  is no setup, or your compiler does not provide the required API. Every
  theory for native words mentions at the start the limitations on code
  generation. Check that your concrete application meets all the
  requirements.

  Alternatively, this might be an instance of the problem described
  in \S\ref{section:export_code:exception}.

  For Haskell, you have to enable the extension TypeSynonymInstances with \texttt{-XTypeSynonymInstances}
  if you are using polymorphic bit operations on the native word types.
*}

subsection {* The generated code is too slow *}

text {*
  The generated code will most likely not be as fast as a direct implementation in the target language with manual tuning.
  This is because we want the configuration of the code generation to be sound (as it can be used to prove theorems in Isabelle).
  Therefore, the bit operations sometimes perform range checks before they call the target language API.
  Here are some examples:
  \begin{itemize}
  \item Shift distances and bit indices in target languages are often expected to fit into a bounded integer or word.
    However, the size of these types varies across target languages and platforms.
    Hence, no Isabelle/HOL type can model uniformly all of them.
    Instead, the bit operations use arbitrary-precision integers for such quantities and check at run-time that the values fit into a bounded integer or word, respectively -- if not, they raise an exception.

  \item Division and modulo operations explicitly test whether the divisor is $0$ and return the HOL value of division by $0$ in that case.
    This is necessary because some languages leave the behaviour of division by 0 unspecified.
  \end{itemize}

  If you have better ideas how to eliminate such checks and speed up the generated code without sacrificing soundness, please contact the author!
*}

(*<*)end(*>*)


theory NP4_Optimising_Action_Values
  imports
  NP4_Optimising_Action_Syntax
  "~~/src/HOL/Word/Word"
  "~~/src/HOL/Word/Word_Bitwise"
(*
    This file contains the concrete values and their encapsulation as used by
    P4 and the P4 action constructs. This includes the evaluation functions.
*)
begin

(* ============================================================================================================== *)
(*                                              VALUE MAPPINGS                                                    *)
(* ============================================================================================================== *)

(* Mapping to concrete value *)
datatype val = UINT nat
  | SINT int
  | IINT int
  | VINT nat
  | BOOL bool
  | STRING string
  | ERROR "identifier list"
  | MATCH "identifier list"

(* State is a mapping from variable names to values *)
type_synonym state = "vname \<Rightarrow> val"

(* Tab is a table of values that contain a constant *)
type_synonym tab = "vname \<Rightarrow> val option"

(* ============================================================================================================== *)
(*                                              HELPER FUNCTIONS                                                  *)
(* ============================================================================================================== *)

(* Convert a basetype to a concrete value used for converting the entries of derived types. *)
fun baseToVal :: "baseType \<Rightarrow> val" where
    "baseToVal (BBOOL b)        = (BOOL b)"
  | "baseToVal (BIINT n)        = (IINT n)"
  | "baseToVal (BUINT n)        = (UINT n)"
  | "baseToVal (BSINT n)        = (SINT n)"
  | "baseToVal (BVINT n)        = (VINT n)"
  | "baseToVal (BERROR e)       = (ERROR e)"
  | "baseToVal (BMATCH m)       = (MATCH m)"
  | "baseToVal (BSTRING s)      = (STRING s)"

fun valToBase :: "val \<Rightarrow> baseType" where
    "valToBase (BOOL b)        = (BBOOL b)"
  | "valToBase (IINT n)        = (BIINT n)"
  | "valToBase (UINT n)        = (BUINT n)"
  | "valToBase (SINT n)        = (BSINT n)"
  | "valToBase (VINT n)        = (BVINT n)"
  | "valToBase (ERROR e)       = (BERROR e)"
  | "valToBase (MATCH m)       = (BMATCH m)"
  | "valToBase (STRING s)      = (BSTRING s)"

(* ============================================================================================================== *)
(*                                   CONCRETE VALUE EVALUATION FUNCTIONS                                          *)
(* ============================================================================================================== *)

inductive eval :: "expression \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool"
  where
(* =============== Base types =============== *)
    RBOOL:    "eval (BASE (BBOOL b))      s (BOOL b)"
  | RIINT:    "eval (BASE (BIINT n))      s (IINT n)"
  | RUINT:    "eval (BASE (BUINT n))      s (UINT n)"
  | RSINT:    "eval (BASE (BSINT n))      s (SINT n)"
  | RVINT:    "eval (BASE (BVINT n))      s (VINT n)"
  | RERROR:   "eval (BASE (BERROR e))     s (ERROR e)"
  | RMATCH:   "eval (BASE (BMATCH m))     s (MATCH m)"
  | RSTRING:  "eval (BASE (BSTRING str))  s (STRING str)"
(* =============== Miscellaneous expressions =============== *)
  | TERNTRUE:  "eval e1 s (BOOL b) \<Longrightarrow> b = True \<Longrightarrow> eval e2 s v \<Longrightarrow> eval (TernExpr e1 e2 e3) s v"
  | TERNFALSE: "eval e1 s (BOOL b) \<Longrightarrow> b = False \<Longrightarrow> eval e3 s v \<Longrightarrow> eval (TernExpr e1 e2 e3) s v"
(* =============== Variable mapping  =============== *)
  | NAMEDVAR: "eval (NamedVar varName) s (s varName)"
(* =============== Operations that yield a single bit (SBIT)  =============== *)
          (* Empty for now *)
(* =============== Operations that yield a boolean (BOOL)  =============== *)
  | ULNEB: "eval e1 s (BOOL b) \<Longrightarrow> eval (UNA_LNE e1) s (BOOL (\<not>b))"
    (* Boolean operations *)
  | BEQUB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (b1 = b2))"
  | BNEQB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (b1 \<noteq> b2))"
  | BFANB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_FAN e1 e2) s (BOOL (b1 \<and> b2))"
  | BFORB: "eval e1 s (BOOL b1) \<Longrightarrow> eval e2 s (BOOL b2) \<Longrightarrow> eval (BIN_FOR e1 e2) s (BOOL (b1 \<or> b2))"
    (* Signed integer opreations *)
  | BEQUS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGRES: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Unsigned integer opreations *)
  | BEQUU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGREU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Infinite precision integer opreations *)
  | BEQUI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
  | BLEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_LEQ e1 e2) s (BOOL (n1 \<le> n2))"
  | BGEQI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_GEQ e1 e2) s (BOOL (n1 \<ge> n2))"
  | BLESI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_LES e1 e2) s (BOOL (n1 < n2))"
  | BGREI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_GRE e1 e2) s (BOOL (n1 > n2))"
    (* Variable size bitstring opreations *)
  | BEQUV: "eval e1 s (VINT n1) \<Longrightarrow> eval e2 s (VINT n2) \<Longrightarrow> eval (BIN_EQU e1 e2) s (BOOL (n1 = n2))"
  | BNEQV: "eval e1 s (VINT n1) \<Longrightarrow> eval e2 s (VINT n2) \<Longrightarrow> eval (BIN_NEQ e1 e2) s (BOOL (n1 \<noteq> n2))"
(* =============== Operations that yield an unsigned integer (UINT)  =============== *)
  | UNEGU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (UINT n1)" (* Incorrect but w/e for now *)
  | UPOSU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_POS e1) s (UINT n1)"
  | UCOMU: "eval e1 s (UINT n1) \<Longrightarrow> eval (UNA_COM e1) s (UINT n1)" (* (nat (NOT (int n1))))" Incorrect but w/e *)
  | BADDU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (UINT (n1 + n2))"
  | BMINU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (UINT (n1 - n2))"
  | BANDU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_AND e1 e2) s (UINT (nat ((int n1) AND (int n2))))"
  | BXORU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_XOR e1 e2) s (UINT (nat ((int n1) XOR (int n2))))"
  | BLORU: "eval e1 s (UINT n1) \<Longrightarrow> eval e2 s (UINT n2) \<Longrightarrow> eval (BIN_LOR e1 e2) s (UINT (nat ((int n1) OR (int n2))))"
(* =============== Operations that yield a signed integer (SINT)  =============== *)
  | UNEGS: "eval e1 s (SINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (SINT (-n1))"
  | UPOSS: "eval e1 s (SINT n1) \<Longrightarrow> eval (UNA_POS e1) s (SINT n1)"
  | BADDS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (SINT (n1 + n2))"
  | BMINS: "eval e1 s (SINT n1) \<Longrightarrow> eval e2 s (SINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (SINT (n1 - n2))"
(* =============== Operations that yield an infinite-precision integer (IINT)  =============== *)
  | UNEGI: "eval e1 s (IINT n1) \<Longrightarrow> eval (UNA_NEG e1) s (IINT (-n1))"
  | UPOSI: "eval e1 s (IINT n1) \<Longrightarrow> eval (UNA_POS e1) s (IINT n1)"
  | BADDI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_ADD e1 e2) s (IINT (n1 + n2))"
  | BMINI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MIN e1 e2) s (IINT (n1 - n2))"
  | BMULI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MUL e1 e2) s (IINT (n1 * n2))"
  | BDIVI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_DIV e1 e2) s (IINT (n1 div n2))"
  | BMODI: "eval e1 s (IINT n1) \<Longrightarrow> eval e2 s (IINT n2) \<Longrightarrow> eval (BIN_MOD e1 e2) s (IINT (n1 mod n2))"
(* =============== Operations that yield a variable-width integer (VINT)  =============== *)
      (* Empty for now *)

lemmas eval_induct = eval.induct[split_format(complete)]
declare eval.intros[simp, intro]

inductive_cases [elim!]: "eval (BASE b) s v" "eval (TernExpr e1 e2 e3) s v" "eval (NamedVar i) s v"
"eval (UNA_LNE e) s v" "eval (UNA_COM e) s v" "eval (UNA_NEG e) s v" "eval (UNA_POS e) s v" "eval (BIN_MUL e1 e2) s v"
"eval (BIN_DIV e1 e2) s v" "eval (BIN_MOD e1 e2) s v" "eval (BIN_ADD e1 e2) s v" "eval (BIN_MIN e1 e2) s v" "eval (BIN_AND e1 e2) s v"
"eval (BIN_XOR e1 e2) s v" "eval (BIN_LOR e1 e2) s v" "eval (BIN_LEQ e1 e2) s v" "eval (BIN_GEQ e1 e2) s v" "eval (BIN_LES e1 e2) s v"
"eval (BIN_GRE e1 e2) s v" "eval (BIN_NEQ e1 e2) s v" "eval (BIN_EQU e1 e2) s v" "eval (BIN_FAN e1 e2) s v" "eval (BIN_FOR e1 e2) s v"

lemma eval_deterministic: "(eval e s v) \<Longrightarrow> (eval e s v') \<Longrightarrow> (v = v')"
  apply (induction arbitrary: v' rule: eval.induct)
                      apply (blast+)
  done

(* ============================================================================================================== *)
(*                                  OPTIMISED VALUE EVALUATION FUNCTIONS                                          *)
(* ============================================================================================================== *)

fun efold :: "expression \<Rightarrow> tab \<Rightarrow> expression"
  where
(* =============== Base types  =============== *)
    "efold (BASE bVal) _ = (BASE bVal)"
(* =============== Variable mapping  =============== *)
  | "efold (NamedVar vName) t = (case t vName of
            None \<Rightarrow> NamedVar vName
          | Some vVal \<Rightarrow> BASE (valToBase vVal))"
(* =============== Miscellaneous expressions =============== *)
  | "efold (TernExpr e1 e2 e3) t = (case efold e1 t of
            BASE (BBOOL True) \<Rightarrow> e2
          | BASE (BBOOL False) \<Rightarrow> e3
          | e1' \<Rightarrow> TernExpr e1' e2 e3)"
(* =============== Unary operators =============== *)
  | "efold (UNA_LNE e1) t = (case efold e1 t of
            BASE (BBOOL b) \<Rightarrow> BASE (BBOOL (\<not>b))
          | e1' \<Rightarrow> UNA_LNE e1')"
  | "efold (UNA_NEG e1) t = (case efold e1 t of
            BASE (BUINT n1) \<Rightarrow> BASE (BUINT (n1))
          | BASE (BSINT n1) \<Rightarrow> BASE (BSINT (-n1))
          | BASE (BIINT n1) \<Rightarrow> BASE (BIINT (-n1))
          | e1' \<Rightarrow> UNA_NEG e1')"
  | "efold (UNA_POS e1) t = (case efold e1 t of
            BASE (BUINT n1) \<Rightarrow> BASE (BUINT (n1))
          | BASE (BSINT n1) \<Rightarrow> BASE (BSINT (n1))
          | BASE (BIINT n1) \<Rightarrow> BASE (BIINT (n1))
          | e1' \<Rightarrow> UNA_POS e1')"
  | "efold (UNA_COM e1) t = (case efold e1 t of
            BASE (BUINT n1) \<Rightarrow> BASE (BUINT (n1))
          | e1' \<Rightarrow> UNA_COM e1')"
(* =============== Binary operators =============== *)
  | "efold (BIN_EQU e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BBOOL b1), BASE (BBOOL b2)) \<Rightarrow> BASE (BBOOL (b1 = b2))
          | (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BBOOL (n1 = n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BBOOL (n1 = n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BBOOL (n1 = n2))
          | (BASE (BVINT n1), BASE (BVINT n2)) \<Rightarrow> BASE (BBOOL (n1 = n2))
          | (e1', e2') \<Rightarrow> BIN_EQU e1' e2')"
  | "efold (BIN_NEQ e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BBOOL b1), BASE (BBOOL b2)) \<Rightarrow> BASE (BBOOL (b1 \<noteq> b2))
          | (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<noteq> n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<noteq> n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<noteq> n2))
          | (BASE (BVINT n1), BASE (BVINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<noteq> n2))
          | (e1', e2') \<Rightarrow> BIN_NEQ e1' e2')"
  | "efold (BIN_FAN e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BBOOL b1), BASE (BBOOL b2)) \<Rightarrow> BASE (BBOOL (b1 \<and> b2))
          | (e1', e2') \<Rightarrow> BIN_FAN e1' e2')"
  | "efold (BIN_FOR e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BBOOL b1), BASE (BBOOL b2)) \<Rightarrow> BASE (BBOOL (b1 \<or> b2))
          | (e1', e2') \<Rightarrow> BIN_FOR e1' e2')"
  | "efold (BIN_LEQ e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<le> n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<le> n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<le> n2))
          | (BASE (BVINT n1), BASE (BVINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<le> n2))
          | (e1', e2') \<Rightarrow> BIN_LEQ e1' e2')"
  | "efold (BIN_GEQ e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<ge> n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<ge> n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<ge> n2))
          | (BASE (BVINT n1), BASE (BVINT n2)) \<Rightarrow> BASE (BBOOL (n1 \<ge> n2))
          | (e1', e2') \<Rightarrow> BIN_GEQ e1' e2')"
  | "efold (BIN_LES e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BBOOL (n1 < n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BBOOL (n1 < n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BBOOL (n1 < n2))
          | (BASE (BVINT n1), BASE (BVINT n2)) \<Rightarrow> BASE (BBOOL (n1 < n2))
          | (e1', e2') \<Rightarrow> BIN_LES e1' e2')"
  | "efold (BIN_GRE e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BBOOL (n1 > n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BBOOL (n1 > n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BBOOL (n1 > n2))
          | (BASE (BVINT n1), BASE (BVINT n2)) \<Rightarrow> BASE (BBOOL (n1 > n2))
          | (e1', e2') \<Rightarrow> BIN_GRE e1' e2')"
  | "efold (BIN_ADD e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BSINT (n1 + n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BUINT (n1 + n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BIINT (n1 + n2))
          | (e1', e2') \<Rightarrow> BIN_ADD e1' e2')"
  | "efold (BIN_MIN e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BSINT n1), BASE (BSINT n2)) \<Rightarrow> BASE (BSINT (n1 - n2))
          | (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BUINT (n1 - n2))
          | (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BIINT (n1 - n2))
          | (e1', e2') \<Rightarrow> BIN_MIN e1' e2')"
  | "efold (BIN_AND e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BUINT (nat ((int n1) AND (int n2))))
          | (e1', e2') \<Rightarrow> BIN_AND e1' e2')"
  | "efold (BIN_XOR e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BUINT (nat ((int n1) XOR (int n2))))
          | (e1', e2') \<Rightarrow> BIN_XOR e1' e2')"
  | "efold (BIN_LOR e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BUINT n1), BASE (BUINT n2)) \<Rightarrow> BASE (BUINT (nat ((int n1) OR (int n2))))
          | (e1', e2') \<Rightarrow> BIN_LOR e1' e2')"
  | "efold (BIN_MUL e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BIINT (n1 * n2))
          | (e1', e2') \<Rightarrow> BIN_MUL e1' e2')"
  | "efold (BIN_DIV e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BIINT (n1 div n2))
          | (e1', e2') \<Rightarrow> BIN_DIV e1' e2')"
  | "efold (BIN_MOD e1 e2) t = (case (efold e1 t, efold e2 t) of
            (BASE (BIINT n1), BASE (BIINT n2)) \<Rightarrow> BASE (BIINT (n1 mod n2))
          | (e1', e2') \<Rightarrow> BIN_MOD e1' e2')"

(* ============================================================================================================== *)
(*                                       OPTIMISATION FUNCTION PROOFS                                             *)
(* ============================================================================================================== *)

definition "approx t s \<longleftrightarrow> (\<forall>vName v. t vName = Some v \<longrightarrow> s vName = v)"

lemma approx_map_le:
  "approx t2 s \<Longrightarrow> t1 \<subseteq>\<^sub>m t2 \<Longrightarrow> approx t1 s"
  by (metis (mono_tags, lifting) approx_def domIff map_le_def option.distinct(1))

lemma approx_empty [simp]:
  "approx Map.empty = (\<lambda>_. True)"
  by (auto simp: approx_def)

theorem eval_efold[simp]: "approx t s \<Longrightarrow> (eval e s v = eval (efold e t) s v)"
  sorry
end


theory Chap7_3
  imports
Main
Chap7_2
"HOL-IMP.Star"
begin

inductive small_step :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>" 55) where
Assign: "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))"
| Seq1: "(SKIP ;; p, s) \<rightarrow> (p, s)"
| Seq2: "(p, s) \<rightarrow> (p', s') \<Longrightarrow> (p ;; q, s) \<rightarrow> (p' ;; q, s')"
| IfTrue: "bval b s \<Longrightarrow> (IF b THEN p ELSE q, s) \<rightarrow> (p, s)"
| IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN p ELSE q, s) \<rightarrow> (q, s)"
| While: "(WHILE b DO p, s) \<rightarrow> (IF b THEN p ;; WHILE b DO p ELSE SKIP, s)"
| Repeat: "(REPEAT p UNTIL b, s) \<rightarrow> (p ;; IF b THEN SKIP ELSE REPEAT p UNTIL b, s)"
| ChoiceLeft: "(p OR q, s) \<rightarrow> (p, s)"
| ChoiceRight: "(p OR q, s) \<rightarrow> (q, s)"
| TrySkip: "(TRY SKIP CATCH c, s) \<rightarrow> (SKIP, s)"
| Try: "(p, s) \<rightarrow> (p', s') \<Longrightarrow> (TRY p CATCH c, s) \<rightarrow> (TRY p' CATCH c, s')"
| Throw: "(THROW;; p, s) \<rightarrow> (THROW, s)"
| Catch: "(TRY THROW CATCH c, s) \<rightarrow> (c, s)"

code_pred small_step .

declare small_step.intros [intro]

abbreviation small_steps :: "com \<times> state \<Rightarrow> com \<times> state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
  where "x \<rightarrow>* y \<equiv> star small_step x y"

inductive_cases SkipE[elim!]: "(SKIP, s) \<rightarrow> cs"
thm SkipE
inductive_cases AssignE[elim!]: "(x ::= a, s) \<rightarrow> cs"
thm AssignE
inductive_cases SeqE[elim]: "(p ;; q, s) \<rightarrow> cs"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2, s) \<rightarrow> cs"
thm IfE
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> cs"
thm WhileE
inductive_cases RepeatE[elim]: "(REPEAT c UNTIL b, s) \<rightarrow> cs"
thm RepeatE
inductive_cases ChoiceE[elim!]: "(p OR q, s) \<rightarrow> cs"
thm ChoiceE
inductive_cases ThrowE[elim!]: "(THROW, s) \<rightarrow> cs"
thm ThrowE
inductive_cases TryCatchE[elim]: "(TRY p CATCH c, s) \<rightarrow> cs"
thm TryCatchE

definition final :: "com * state \<Rightarrow> bool" where
"final cs \<equiv> \<not>(\<exists>cs'. cs \<rightarrow> cs')"

lemma final_iff_SKIP: "final (c, s) = (c = SKIP \<or> c = THROW)"
  apply (induct c)
  using final_def apply blast
  using final_def apply auto[1]
  apply (metis Seq1 Seq2 com.distinct(39) com.distinct(4) final_def small_step.Throw surj_pair)
  apply (metis com.distinct(49) com.distinct(5) final_def small_step.IfFalse small_step.IfTrue)
  apply (metis While com.distinct(57) com.distinct(7) final_def)
  apply (metis Repeat com.distinct(63) com.distinct(9) final_def)
  apply (metis com.distinct(11) com.distinct(67) final_def small_step.ChoiceRight)
  using final_def apply blast
  by (metis TrySkip com.distinct(15) com.distinct(71) final_def small_step.Catch small_step.Try surj_pair)

lemma bs_ref_ss_aux: "\<lbrakk> (c1, s1) \<rightarrow>* (SKIP, s2); (c2, s2) \<rightarrow>* cs \<rbrakk> \<Longrightarrow> (c1;; c2, s1) \<rightarrow>* cs"
  apply (induct c1 s1 SKIP s2 rule: star_induct)
   apply (meson Seq1 star.step)
  by (meson Seq2 star.step)

lemma bs_ref_ss_aux1: "(c1, s1) \<rightarrow>* (THROW, s2) \<Longrightarrow> (c1;; c2, s1) \<rightarrow>* (THROW, s2)"
  apply (induct c1 s1 THROW s2 rule: star_induct)
   apply (simp add: small_step.Throw)
  by (meson Seq2 star.step)

lemma bs_ref_ss_aux2: "(p, s) \<rightarrow>* (SKIP, s') \<Longrightarrow> (TRY p CATCH c, s) \<rightarrow>* (SKIP, s')"
  apply (induct p s SKIP s' rule: star_induct)
  apply (simp add: TrySkip)
  by (meson small_step.Try star.step)

lemma bs_ref_ss_aux3: "\<lbrakk> (c1, s1) \<rightarrow>* (THROW, s2); (c2, s2) \<rightarrow>* r'\<rbrakk> \<Longrightarrow> (TRY c1 CATCH c2, s1) \<rightarrow>* r'"
  apply (induct c1 s1 THROW s2 rule: star_induct)
  apply (meson small_step.Catch star.step)
  by (meson small_step.Try star.step)

lemma bs_ref_ss: "cs \<Rightarrow> cs' \<Longrightarrow> cs \<rightarrow>* cs' \<and> final cs'"
  unfolding final_def apply (induct rule: big_step.induct)
  apply blast+
  using bs_ref_ss_aux apply blast
  using bs_ref_ss_aux1 apply blast
             apply (meson small_step.IfTrue star.step)
            apply (metis small_step.IfFalse star.step)
           apply (meson While bs_ref_ss_aux small_step.IfTrue star.step)
          apply (meson While bs_ref_ss_aux1 small_step.IfTrue star.simps)
         apply (meson Chap7_3.SkipE While small_step.IfFalse star.step star_step1)
        apply (meson Repeat bs_ref_ss_aux small_step.IfTrue star.step star_step1)
       apply (meson Repeat bs_ref_ss_aux small_step.IfFalse star.step)
      apply (meson Repeat bs_ref_ss_aux1 star.step)
     apply (meson small_step.ChoiceLeft star.step)
    apply (meson small_step.ChoiceRight star.step)
  using bs_ref_ss_aux2 apply blast
  using bs_ref_ss_aux3 by blast

lemma ss_ref_bs_aux:
"\<lbrakk> cs \<rightarrow> cs'; cs' \<Rightarrow> cs''; final cs'' \<rbrakk> \<Longrightarrow> cs \<Rightarrow> cs''"
  unfolding final_def
proof (induct arbitrary: cs'' rule: small_step.induct)
  case Seq2
  thus ?case using bs_ref_ss by auto
qed blast+

lemma ss_ref_bs: "\<lbrakk> cs \<rightarrow>* cs'; final cs' \<rbrakk> \<Longrightarrow> cs \<Rightarrow> cs'"
  apply (induct cs cs' rule: star.induct)
  using final_iff_SKIP apply force
  using ss_ref_bs_aux by force

lemma ss_eq_bs: "final cs' \<and> cs \<rightarrow>* cs' \<longleftrightarrow> cs \<Rightarrow> cs'"
  by (metis ss_ref_bs bs_ref_ss)

lemma "(\<exists>t. cs \<Rightarrow> t) = (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
  using ss_eq_bs by blast

end


theory "InstructionAux"

imports Main
  "../../lem/Evm"
begin

fun get_bits :: "inst option \<Rightarrow> bits_inst" where
  "get_bits (Some (Bits i)) = i"

fun get_sarith :: "inst option \<Rightarrow> sarith_inst" where
  "get_sarith (Some (Sarith i)) = i"

fun get_arith :: "inst option \<Rightarrow> arith_inst" where
  "get_arith (Some (Arith i)) = i"

fun get_info :: "inst option \<Rightarrow> info_inst" where
  "get_info (Some (Info i)) = i"

fun get_memory :: "inst option \<Rightarrow> memory_inst" where
  "get_memory (Some (Memory i)) = i"

fun get_storage :: "inst option \<Rightarrow> storage_inst" where
  "get_storage (Some (Storage i)) = i"

fun get_misc :: "inst option \<Rightarrow> misc_inst" where
  "get_misc (Some (Misc i)) = i"

fun get_log :: "inst option \<Rightarrow> log_inst" where
  "get_log (Some (Log i)) = i"

fun get_pc :: "inst option \<Rightarrow> pc_inst" where
  "get_pc (Some (Pc i)) = i"

fun get_dup :: "inst option \<Rightarrow> 4 word" where
  "get_dup (Some (Dup i)) = i"

fun get_swap :: "inst option \<Rightarrow> 4 word" where
  "get_swap (Some (Swap i)) = i"

fun get_stack :: "inst \<Rightarrow> stack_inst" where
  "get_stack (Stack i) = i"

fun get_some :: "'a option \<Rightarrow> 'a" where
"get_some (Some a) = a"

definition instruction_aux  :: " variable_ctx \<Rightarrow> constant_ctx \<Rightarrow> inst \<Rightarrow> instruction_result "  where
     " instruction_aux v c inst = (
  ((case  inst of
    Stack (PUSH_N lst) => stack_0_1_op v c (Word.word_rcat (constant_mark lst))
  | Unknown _ => instruction_failure_result v [ShouldNotHappen]
  | Storage SLOAD => stack_1_1_op v c(vctx_storage   v)
  | Storage SSTORE => sstore v c
  | Pc JUMPI => jumpi v c
  | Pc JUMP => jump v c
  | Pc JUMPDEST => stack_0_0_op v c
  | Info CALLDATASIZE => stack_0_1_op v c (datasize v)
  | Stack CALLDATALOAD => stack_1_1_op v c (cut_data v)
  | Info CALLER => stack_0_1_op v c (Word.ucast(vctx_caller   v))
  | Arith ADD => stack_2_1_op v c (\<lambda> a b .  a + b)
  | Arith SUB => stack_2_1_op v c (\<lambda> a b .  a - b)
  | Arith ISZERO => stack_1_1_op v c (\<lambda> a .  if a =((word_of_int 0) ::  256 word) then((word_of_int 1) ::  256 word) else((word_of_int 0) ::  256 word))
  | Misc CALL => call v c
  | Misc RETURN => ret v c
  | Misc STOP => stop v c
  | Dup n => general_dup n v c
  | Stack POP => pop v c
  | Info GASLIMIT => stack_0_1_op v c(block_gaslimit  (vctx_block   v))
  | Arith inst_GT => stack_2_1_op v c (\<lambda> a b .  if a > b then((word_of_int 1) ::  256 word) else((word_of_int 0) ::  256 word))
  | Arith inst_EQ => stack_2_1_op v c (\<lambda> a b .  if a = b then((word_of_int 1) ::  256 word) else((word_of_int 0) ::  256 word))
  | Bits inst_AND => stack_2_1_op v c (\<lambda> a b .  a AND b)
  | Bits inst_OR => stack_2_1_op v c (\<lambda> a b .  a OR b)
  | Bits inst_XOR => stack_2_1_op v c (\<lambda> a b .  a XOR b)
  | Bits inst_NOT => stack_1_1_op v c (\<lambda> a .  (NOT a))
  | Bits BYTE =>
      stack_2_1_op v c get_byte
  | Sarith SDIV => stack_2_1_op v c
       (\<lambda> n divisor .  if divisor =((word_of_int 0) ::  256 word) then((word_of_int 0) ::  256 word) else
                         (let divisor = (sintFromW256 divisor) in
                         (let n = (sintFromW256 n) in
                         (let min_int :: int = (- (( 2 :: int) ^( 255 :: nat))) in
                         if (n = min_int) \<and> (divisor = - (( 1 :: int))) then (\<lambda> i .  word_of_int ( i)) min_int else
                         if divisor <( 0 :: int) then
                           (if n <( 0 :: int) then
                              (\<lambda> i .  word_of_int ( i)) ((- (( 1 :: int)) * n) div (- (( 1 :: int)) * divisor))
                            else
                              (\<lambda> i .  word_of_int ( i)) (- (( 1 :: int)) * (n div (- (( 1 :: int)) * divisor)))
                           )
                         else
                           (if n <( 0 :: int) then
                              (\<lambda> i .  word_of_int ( i)) (- (( 1 :: int)) * ((- (( 1 :: int)) * n) div divisor))
                            else
                              (\<lambda> i .  word_of_int ( i)) (n div divisor)))))
                           )
  | Sarith SMOD => stack_2_1_op v c
       (\<lambda> n divisor .  if divisor =((word_of_int 0) ::  256 word) then((word_of_int 0) ::  256 word) else
                         (let divisor = (sintFromW256 divisor) in
                         (let n = (sintFromW256 n) in
                         if divisor <( 0 :: int) then
                           (if n <( 0 :: int) then
                              (\<lambda> i .  word_of_int ( i)) (- (( 1 :: int)) * ((- (( 1 :: int)) * n) mod (- (( 1 :: int)) * divisor)))
                            else
                              (\<lambda> i .  word_of_int ( i)) (n mod (- (( 1 :: int)) * divisor))
                           )
                         else
                           (if n <( 0 :: int) then
                              (\<lambda> i .  word_of_int ( i)) (- (( 1 :: int)) * ((- (( 1 :: int)) * n) mod divisor))
                            else
                              (\<lambda> i .  word_of_int ( i)) (n mod divisor))))
                           )
  | Sarith SGT => stack_2_1_op v c
       (\<lambda> elm0 elm1 .  if word_sless elm1 elm0 then((word_of_int 1) ::  256 word) else((word_of_int 0) ::  256 word))
  | Sarith SLT => stack_2_1_op v c
       (\<lambda> elm0 elm1 .  if word_sless elm0 elm1 then((word_of_int 1) ::  256 word) else((word_of_int 0) ::  256 word))
  | Sarith SIGNEXTEND => stack_2_1_op v c signextend
  | Arith MUL => stack_2_1_op v c
       (\<lambda> a b .  a * b)
  | Arith DIV => stack_2_1_op v c
       (\<lambda> a divisor .  (if divisor =((word_of_int 0) ::  256 word) then((word_of_int 0) ::  256 word) else (\<lambda> i .  word_of_int ( i)) ((Word.uint a) div (Word.uint divisor))))
  | Arith MOD => stack_2_1_op v c
       (\<lambda> a divisor .  (if divisor =((word_of_int 0) ::  256 word) then((word_of_int 0) ::  256 word) else
            (\<lambda> i .  word_of_int ( i)) ((Word.uint a) mod (Word.uint divisor))
        ))
  | Arith ADDMOD => stack_3_1_op v c
       (\<lambda> a b divisor .
           (if divisor =((word_of_int 0) ::  256 word) then((word_of_int 0) ::  256 word) else (\<lambda> i .  word_of_int ( i)) ((Word.uint a + Word.uint b) mod (Word.uint divisor))))
  | Arith MULMOD => stack_3_1_op v c
       (\<lambda> a b divisor .
           (if divisor =((word_of_int 0) ::  256 word) then((word_of_int 0) ::  256 word) else (\<lambda> i .  word_of_int ( i)) ((Word.uint a * Word.uint b) mod (Word.uint divisor))))
  | Arith EXP => stack_2_1_op v c (\<lambda> a exponent .
      (\<lambda> i .  word_of_int ( i))
       (word_exp (Word.uint a) (unat exponent)))
  | Arith inst_LT => stack_2_1_op v c (\<lambda> arg0 arg1 .  if arg1 > arg0 then((word_of_int 1) ::  256 word) else((word_of_int 0) ::  256 word))
  | Arith SHA3 => sha3 v c
  | Info ADDRESS => stack_0_1_op v c (Word.ucast(cctx_this   c))
  | Info BALANCE => stack_1_1_op v c (\<lambda> addr . (vctx_balance   v) (Word.ucast addr))
  | Info ORIGIN => stack_0_1_op v c (Word.ucast(vctx_origin   v))
  | Info CALLVALUE => stack_0_1_op v c(vctx_value_sent   v)
  | Info CODESIZE => stack_0_1_op v c ((\<lambda> i .  word_of_int ( i))(program_length  (cctx_program   c)))
  | Info GASPRICE => stack_0_1_op v c(block_gasprice  (vctx_block   v))
  | Info EXTCODESIZE => stack_1_1_op v c
       (\<lambda> arg .  (\<lambda> i .  word_of_int ( i))(program_length   ((vctx_ext_program   v) (Word.ucast arg))))
  | Info BLOCKHASH => stack_1_1_op v c(block_blockhash  (vctx_block   v))
  | Info COINBASE => stack_0_1_op v c (Word.ucast(block_coinbase  (vctx_block   v)))
  | Info TIMESTAMP => stack_0_1_op v c(block_timestamp  (vctx_block   v))
  | Info NUMBER => stack_0_1_op v c(block_number  (vctx_block   v))
  | Info DIFFICULTY => stack_0_1_op v c(block_difficulty  (vctx_block   v))
  | Memory MLOAD => mload v c
  | Memory MSTORE => mstore v c
  | Memory MSTORE8 => mstore8 v c
  | Memory CALLDATACOPY => calldatacopy v c
  | Memory CODECOPY => codecopy v c
  | Memory EXTCODECOPY => extcodecopy v c
  | Pc PC => pc v c
  | Log LOG0 => Evm.log(( 0 :: nat)) v c
  | Log LOG1 => Evm.log(( 1 :: nat)) v c
  | Log LOG2 => Evm.log(( 2 :: nat)) v c
  | Log LOG3 => Evm.log(( 3 :: nat)) v c
  | Log LOG4 => Evm.log(( 4 :: nat)) v c
  | Swap n => swap (unat n) v c
  | Misc CREATE => create v c
  | Misc CALLCODE => callcode v c
  | Misc SUICIDE => suicide v c
  | Misc DELEGATECALL => delegatecall v c
  | Info GAS => stack_0_1_op v c (gas v -((word_of_int 2) ::  256 word))
  | Memory MSIZE => stack_0_1_op v c (((word_of_int 32) ::  256 word) * (\<lambda> i .  word_of_int ( i))(vctx_memory_usage   v))
  )))"

lemma inst_gas :
  "instruction_sem v c inst =
   subtract_gas (predict_gas inst v c) (instruction_aux v c inst)"
  by (simp add: instruction_aux_def instruction_sem_def)

lemma advance_stack :
   "vctx_advance_pc c (v\<lparr>vctx_stack:=x\<rparr>) =
    (vctx_advance_pc c v)\<lparr>vctx_stack:=x\<rparr>"
apply(auto simp:vctx_advance_pc_def
  vctx_next_instruction_def split:option.split)

done

definition program_step  :: "constant_ctx \<Rightarrow> instruction_result \<Rightarrow> instruction_result "  where
"program_step c pr1 = (
  (case  pr1 of
    InstructionToEnvironment _ _ _ => pr1
  | InstructionAnnotationFailure => pr1
  | InstructionContinue v =>
     if \<not> (check_annotations v c) then InstructionAnnotationFailure else
     (case  vctx_next_instruction v c of
        None => InstructionToEnvironment (ContractFail [ShouldNotHappen]) v None
      | Some i =>
        if check_resources v c ((vctx_stack   v)) i then
          instruction_sem v c i
        else
          InstructionToEnvironment (ContractFail
              ((case  inst_stack_numbers i of
                 (consumed, produced) =>
                 (if (((int (List.length ((vctx_stack   v))) + produced) - consumed) \<le>( 1024 :: int)) then [] else [TooLongStack])
                  @ (if predict_gas i v c \<le>(vctx_gas   v) then [] else [OutOfGas])
               )
              ))
              v None
     )
  ))"

fun program_iter ::
   "nat \<Rightarrow> constant_ctx \<Rightarrow> instruction_result \<Rightarrow> instruction_result"  where
"program_iter 0 ctx x = x"
| "program_iter (Suc n) ctx x = program_iter n ctx (program_step ctx x)"

lemma program_step_failure :
 "program_step c InstructionAnnotationFailure =
    InstructionContinue v2 \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_step_failure_env :
 "program_step c InstructionAnnotationFailure =
    InstructionToEnvironment x31 x32
        x33 \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_step_env :
 "program_step c (InstructionToEnvironment x31 x32
        x33) =
    InstructionContinue v2 \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_step_env_failure :
 "program_step c (InstructionToEnvironment x31 x32
        x33) =
    InstructionAnnotationFailure \<Longrightarrow> False"
apply (auto simp:program_step_def)
done

lemma program_iter_failure :
 "program_iter n c InstructionAnnotationFailure =
    InstructionContinue v2 \<Longrightarrow> False"
apply (induction n arbitrary:v2)
apply (auto)
apply (cases "program_step c
          InstructionAnnotationFailure")
apply auto
using program_step_failure apply blast
using program_step_failure_env apply blast
done

lemma program_iter_env :
 "program_iter n c (InstructionToEnvironment e f g) =
    InstructionContinue v2 \<Longrightarrow> False"
apply (induction n arbitrary:v2 e f g)
apply (cases n)
apply (auto)
apply (cases "program_step c
          (InstructionToEnvironment e f g)")
using program_step_env apply blast
using program_step_env_failure apply blast
  using program_step_def by auto

theorem program_step_continue :
 "InstructionContinue v2 = program_step c x \<Longrightarrow>
  \<exists>v. x = InstructionContinue v"
apply(cases x)
apply(auto simp:program_step_def)
done

theorem program_iter_continue :
 "InstructionContinue v2 = program_iter steps c x \<Longrightarrow>
  \<exists>v n k. x = InstructionContinue v"
apply(induction steps arbitrary:v2 n2 k2 c)
apply(auto simp:program_step_continue)
apply(cases x)
apply(auto simp:program_step_def)
done

lemma program_step_is_next_state :
 "program_step c x = next_state stopper c x"
by (simp add: program_step_def next_state_def)

lemma program_step_is_next_state2 :
 "next_state stopper c x = program_step c x"
by (simp add: program_step_def next_state_def)

lemma program_iter_is_sem :
 "program_sem stopper c n x = program_iter n c x"
apply(induction n arbitrary:x)
apply(auto simp:program_sem.simps program_step_is_next_state2)
done

end


theory RRLoopFive
(* Last instance of the RRLoop: here, we now
   avoid the put attack -- this is what characterises a proper
   non-centralised blockchain: since the control is not in just one
   point it is not feasible to mess with existing data.
   We can simply achieve this by simply adding to the semantics that
   put is only possible if the dlm\<times>data hasn't been used already
   somewhere in the blochain.
   *)
imports hcKripkeFour
begin
type_synonym data = string
  (* Inspired by Myers DLM mode: first is the owner of a data item, second is the
     set of all actors that may access the data item *)
type_synonym dlm = "identity * identity set"
type_synonym acond = "(dlm * data) set"

(* Similar to the label_fun from RRLoopThree to RRLoopFour:
   a new type must not be redefined in the refined theory
typedef ledger = "{ ld :: dlm \<times> data \<Rightarrow> location set. \<forall> d. (\<forall> l. ld (l, d) = {}) \<or>
(\<exists>! l. ld (l, d) \<noteq> {})}"
  by auto
*)
datatype igraph = Lgraph "(location * location)set" "location \<Rightarrow> identity set"
                         "actor \<Rightarrow> (string set * string set)"  "location \<Rightarrow> string"
                         "ledger"
datatype infrastructure =
         Infrastructure "igraph"
                        "[igraph ,location] \<Rightarrow> policy set"
primrec loc :: "location \<Rightarrow> nat"
where  "loc(Location n) = n"
primrec gra :: "igraph \<Rightarrow> (location * location)set"
where  "gra(Lgraph g a c l ld) = g"
primrec agra :: "igraph \<Rightarrow> (location \<Rightarrow> identity set)"
where  "agra(Lgraph g a c l ld) = a"
primrec cgra :: "igraph \<Rightarrow> (actor \<Rightarrow> string set * string set)"
where  "cgra(Lgraph g a c l ld) = c"
primrec lgra :: "igraph \<Rightarrow> (location \<Rightarrow> string)"
  where  "lgra(Lgraph g a c l ld) = l"
primrec ledgra :: "igraph \<Rightarrow> ledger"
  where  "ledgra(Lgraph g a c l ld) = ld"

(* Since the type ledger is not redefined we don't have to and shouldn't
   redefine the constructors. We can use the ones from before, i.e. RRLoopFour
definition ledgra_upd :: "[ledger, dlm \<times> data, location set] \<Rightarrow> ledger" ("_ _ := _" 50)
  where
 "ledgra_upd ld dl L == Abs_ledger((Rep_ledger ld)(dl := L))"

definition ledgra_at :: "[ledger, dlm \<times> data] \<Rightarrow> location set" ("_ \<nabla> _" 50)
  where  "l \<nabla> dl \<equiv> (Rep_ledger l) dl"
*)

definition nodes :: "igraph \<Rightarrow> location set"
where "nodes g == { x. (? y. ((x,y): gra g) | ((y,x): gra g))}"

definition actors_graph :: "igraph \<Rightarrow> identity set"
where  "actors_graph g == {x. ? y. y : nodes g \<and> x \<in> (agra g y)}"

primrec graphI :: "infrastructure \<Rightarrow> igraph"
where "graphI (Infrastructure g d) = g"
primrec delta :: "[infrastructure, igraph, location] \<Rightarrow> policy set"
where "delta (Infrastructure g d) = d"
primrec tspace :: "[infrastructure, actor ] \<Rightarrow> string set * string set"
  where "tspace (Infrastructure g d) = cgra g"
primrec lspace :: "[infrastructure, location ] \<Rightarrow> string"
where "lspace (Infrastructure g d) = lgra g"
definition credentials :: "string set * string set \<Rightarrow> string set"
  where  "credentials lxl \<equiv> (fst lxl)"
definition has :: "[igraph, actor * string] \<Rightarrow> bool"
  where "has G ac \<equiv> snd ac \<in> credentials(cgra G (fst ac))"
definition roles :: "string set * string set \<Rightarrow> string set"
  where  "roles lxl \<equiv> (snd lxl)"
definition role :: "[igraph, actor * string] \<Rightarrow> bool"
  where "role G ac \<equiv> snd ac \<in> roles(cgra G (fst ac))"

definition isin :: "[igraph,location, string] \<Rightarrow> bool"
  where "isin G l s \<equiv> s = (lgra G l)"

definition owner :: "dlm * data \<Rightarrow> identity" where "owner d \<equiv> fst(fst d)"

definition owns :: "[igraph, location, identity, dlm * data] \<Rightarrow> bool"
  where "owns G l a d \<equiv> owner d = a"

definition readers :: "dlm * data \<Rightarrow> identity set"
  where "readers d \<equiv> snd (fst d)"

definition has_access :: "[igraph, location, identity, dlm * data] \<Rightarrow> bool"
where "has_access G l a d \<equiv> owns G l a d \<or> a \<in> readers d"

definition atI :: "[identity, igraph, location] \<Rightarrow> bool" ("_ @\<^bsub>(_)\<^esub> _" 50)
where "a @\<^bsub>G\<^esub> l \<equiv> a \<in> (agra G l)"

definition enables :: "[infrastructure, location, actor, action] \<Rightarrow> bool"
where
"enables I l a a' \<equiv>  (\<exists> (p,e) \<in> delta I (graphI I) l. a' \<in> e \<and> p a)"

definition move_graph_a :: "[identity, location, location, igraph] \<Rightarrow> igraph"
where "move_graph_a n l l' g \<equiv> Lgraph (gra g)
                    (if n \<in> ((agra g) l) &  n \<notin> ((agra g) l') then
                     ((agra g)(l := (agra g l) - {n}))(l' := (insert n (agra g l')))
                     else (agra g))(cgra g)(lgra g)(ledgra g)"

(* type of functions that preserves the security labeling *)
typedef label_fun = "{f :: dlm * data \<Rightarrow> dlm * data.
                        \<forall> x:: dlm * data. fst x = fst (f x)}"
proof (auto)
  show "\<exists>x::(identity \<times> identity set) \<times> string \<Rightarrow> (identity \<times> identity set) \<times> string.
       \<forall>(a::identity) (b::identity set) ba::string. (a, b) = fst (x ((a, b), ba))"
  by (rule_tac x = id in exI, simp)
qed

definition secure_process :: "label_fun \<Rightarrow> dlm * data \<Rightarrow> dlm * data" ("_ \<Updown> _" 50)
  where "f  \<Updown> d \<equiv> (Rep_label_fun f) d"

lemma move_graph_eq: "move_graph_a a l l g = g"
proof (simp add: move_graph_a_def, case_tac g, force)
qed

inductive state_transition_in :: "[infrastructure, infrastructure] \<Rightarrow> bool" ("(_ \<rightarrow>\<^sub>n _)" 50)
where
  move: "\<lbrakk> G = graphI I; a @\<^bsub>G\<^esub> l; l \<in> nodes G; l' \<in> nodes G;
          (a) \<in> actors_graph(graphI I); enables I l' (Actor a) move;
         I' = Infrastructure (move_graph_a a l l' (graphI I))(delta I) \<rbrakk> \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| get_data : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> l \<in> nodes G \<Longrightarrow> l' \<in> nodes G \<Longrightarrow>
        enables I l (Actor a) get \<Longrightarrow>
        (ledgra G \<nabla> ((a', as), n)) = L \<Longrightarrow> l' \<in> L  \<Longrightarrow>  a \<in> as \<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                           ((ledgra G)((a', as), n) := (L \<union> {l})))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
| process : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow>
        enables I l (Actor a) eval \<Longrightarrow>
        (ledgra G \<nabla> ((a', as), n)) = L \<Longrightarrow>
        a \<in> as  \<or> a = a'\<Longrightarrow>
        I' = Infrastructure
                   (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                                 ((ledgra G ((a', as), n) := {}
                                    (f :: label_fun) \<Updown> ((a', as), n) := L)))
                   (delta I)
         \<Longrightarrow> I \<rightarrow>\<^sub>n I'"
(* Can't have del_data or at least not the unrestricted form *)
(* the "ledgra G \<nabla> ((a, as),n) = {}" is the decisive pre-condition *)
| put : "G = graphI I \<Longrightarrow> a @\<^bsub>G\<^esub> l \<Longrightarrow> enables I l (Actor a) put \<Longrightarrow>
        ledgra G \<nabla> ((a, as),n) = {} \<Longrightarrow>
        I' = Infrastructure
                  (Lgraph (gra G)(agra G)(cgra G)(lgra G)
                          (ledgra G ((a, as),n) := {l}))
                   (delta I)
          \<Longrightarrow> I \<rightarrow>\<^sub>n I'"

instantiation "infrastructure" :: state
begin

definition
   state_transition_infra_def: "(i \<rightarrow>\<^sub>i i') =  (i \<rightarrow>\<^sub>n (i' :: infrastructure))"

instance
  by (rule MC.class.MC.state.of_class.intro)

definition state_transition_in_refl ("(_ \<rightarrow>\<^sub>n* _)" 50)
where "s \<rightarrow>\<^sub>n* s' \<equiv> ((s,s') \<in> {(x,y). state_transition_in x y}\<^sup>*)"

end

(* The ref_map is trivial since only the semantics above has changed  *)
definition ref_map :: "[RRLoopFive.infrastructure,
                        [RRLoopFour.igraph, location] \<Rightarrow> policy set]
                        \<Rightarrow> RRLoopFour.infrastructure"
  where "ref_map I lp = RRLoopFour.Infrastructure
                                 (RRLoopFour.Lgraph
                                        (RRLoopFive.gra (graphI I))(RRLoopFive.agra (graphI I))
                                        (RRLoopFive.cgra (graphI I))(RRLoopFive.lgra (graphI I))
                                        (RRLoopFive.ledgra (graphI I)))
                                 lp"

lemma delta_invariant: "\<forall> z z'. z \<rightarrow>\<^sub>n z' \<longrightarrow>  delta(z) = delta(z')"
  apply clarify
  apply (erule state_transition_in.cases)
  by simp+

end


(* Author: Andrew Boyton, 2012
   Maintainers: Gerwin Klein <kleing at cse.unsw.edu.au>
                Rafal Kolanski <rafal.kolanski at nicta.com.au>
*)

section "A simplified version of the actual capDL specification."

theory Types_D
imports "HOL-Library.Word"
begin

(*
 * Objects are named by 32 bit words.
 * This name may correspond to the memory address of the object.
 *)
type_synonym cdl_object_id = "32 word"

type_synonym cdl_object_set = "cdl_object_id set"

(* The type we use to represent object sizes. *)
type_synonym cdl_size_bits = nat

(* An index into a CNode, TCB, or other kernel object that contains caps. *)
type_synonym cdl_cnode_index = nat

(* A reference to a capability slot. *)
type_synonym cdl_cap_ref = "cdl_object_id \<times> cdl_cnode_index"

(* The possible access-control rights that exist in the system. *)
datatype cdl_right = AllowRead | AllowWrite | AllowGrant

(*
 * Kernel capabilities.
 *
 * Such capabilities (or "caps") give the holder particular rights to
 * a kernel object or system hardware.
 *
 * Caps have attributes such as the object they point to, the rights
 * they give the holder, or how the holder is allowed to interact with
 * the target object.
 *
 * This is a simplified, cut-down version of this datatype for
 * demonstration purposes.
 *)
datatype cdl_cap =
    NullCap
  | EndpointCap cdl_object_id "cdl_right set"
  | CNodeCap cdl_object_id
  | TcbCap cdl_object_id

(* A mapping from capability identifiers to capabilities. *)
type_synonym cdl_cap_map = "cdl_cnode_index \<Rightarrow> cdl_cap option"

translations
  (type) "cdl_cap_map" <= (type) "nat \<Rightarrow> cdl_cap option"
  (type) "cdl_cap_ref" <= (type) "cdl_object_id \<times> nat"

(* A user cap pointer. *)
type_synonym cdl_cptr = "32 word"

(* Kernel objects *)
record cdl_tcb =
  cdl_tcb_caps :: cdl_cap_map
  cdl_tcb_fault_endpoint :: cdl_cptr

record cdl_cnode =
  cdl_cnode_caps :: cdl_cap_map
  cdl_cnode_size_bits :: cdl_size_bits

(*
 * Kernel objects.
 *
 * These are in-memory objects that may, over the course of the system
 * execution, be created or deleted by users.
 *
 * Again, a simplified version of the real datatype.
 *)
datatype cdl_object =
    Endpoint
  | Tcb cdl_tcb
  | CNode cdl_cnode

(*
 * The current state of the system.
 *
 * The state record contains the following primary pieces of information:
 *
 * objects:
 *   The objects that currently exist in the system.
 *
 * current_thread:
 *   The currently running thread. Operations will always be performed
 *   on behalf of this thread.
 *
 * ghost_state: (Used for separation logic)
 *   Which fields are owned by an object.
 *   In capDL this is all of the fields (or none of them).
 *   In any concrete state, this will be all of the fields.
 *)

(* The ghost state tracks which components (fields and slots) are owned by an object.
 * Fields + slots are encoded as None + Some nat.
 *)
type_synonym cdl_heap = "cdl_object_id \<Rightarrow> cdl_object option"
type_synonym cdl_component  = "nat option"
type_synonym cdl_components = "cdl_component set"
type_synonym cdl_ghost_state = "cdl_object_id \<Rightarrow> cdl_components"

translations
  (type) "cdl_heap" <= (type) "cdl_object_id \<Rightarrow> cdl_object option"
  (type) "cdl_ghost_state" <= (type) "cdl_object_id \<Rightarrow> nat option set"

record cdl_state =
  cdl_objects :: "cdl_heap"
  cdl_current_thread :: "cdl_object_id option"
  cdl_ghost_state :: "cdl_ghost_state"

(* Kernel objects types. *)
datatype cdl_object_type =
    EndpointType
  | TcbType
  | CNodeType

(* Return the type of an object. *)
definition
  object_type :: "cdl_object \<Rightarrow> cdl_object_type"
where
  "object_type x \<equiv>
    case x of
        Endpoint \<Rightarrow> EndpointType
      | Tcb _ \<Rightarrow> TcbType
      | CNode _ \<Rightarrow> CNodeType"

(*
 * Getters and setters for various data types.
 *)

(* Capability getters / setters *)

definition cap_objects :: "cdl_cap \<Rightarrow> cdl_object_id set"
where
    "cap_objects cap \<equiv>
       case cap of
           TcbCap x \<Rightarrow> {x}
         | CNodeCap x \<Rightarrow> {x}
         | EndpointCap x _ \<Rightarrow> {x}"

definition cap_has_object :: "cdl_cap \<Rightarrow> bool"
where
    "cap_has_object cap \<equiv>
       case cap of
           NullCap          \<Rightarrow> False
         | _                \<Rightarrow> True"

definition cap_object :: "cdl_cap \<Rightarrow> cdl_object_id"
where
    "cap_object cap \<equiv>
       if cap_has_object cap
         then THE obj_id. cap_objects cap = {obj_id}
         else undefined "

lemma cap_object_simps:
  "cap_object (TcbCap x) = x"
  "cap_object (CNodeCap x) = x"
  "cap_object (EndpointCap x j) = x"
  by (simp_all add:cap_object_def cap_objects_def cap_has_object_def)

definition
  cap_rights :: "cdl_cap \<Rightarrow> cdl_right set"
where
  "cap_rights c \<equiv> case c of
      EndpointCap _ x \<Rightarrow> x
    | _ \<Rightarrow> UNIV"

definition
  update_cap_rights :: "cdl_right set \<Rightarrow> cdl_cap \<Rightarrow> cdl_cap"
where
  "update_cap_rights r c \<equiv> case c of
      EndpointCap f1 _ \<Rightarrow> EndpointCap f1 r
    | _ \<Rightarrow> c"

(* Kernel object getters / setters *)
definition
  object_slots :: "cdl_object \<Rightarrow> cdl_cap_map"
where
  "object_slots obj \<equiv> case obj of
    CNode x \<Rightarrow> cdl_cnode_caps x
  | Tcb x \<Rightarrow> cdl_tcb_caps x
  | _ \<Rightarrow> Map.empty"

definition
  update_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "update_slots new_val obj \<equiv> case obj of
    CNode x \<Rightarrow> CNode (x\<lparr>cdl_cnode_caps := new_val\<rparr>)
  | Tcb x \<Rightarrow> Tcb (x\<lparr>cdl_tcb_caps := new_val\<rparr>)
  | _ \<Rightarrow> obj"

(* Adds new caps to an object. It won't overwrite on a collision. *)
definition
  add_to_slots :: "cdl_cap_map \<Rightarrow> cdl_object \<Rightarrow> cdl_object"
where
  "add_to_slots new_val obj \<equiv> update_slots (new_val ++ (object_slots obj)) obj"

definition
  slots_of :: "cdl_heap \<Rightarrow> cdl_object_id \<Rightarrow> cdl_cap_map"
where
  "slots_of h \<equiv> \<lambda>obj_id.
  case h obj_id of
    None \<Rightarrow> Map.empty
  | Some obj \<Rightarrow> object_slots obj"

definition
  has_slots :: "cdl_object \<Rightarrow> bool"
where
  "has_slots obj \<equiv> case obj of
    CNode _ \<Rightarrow> True
  | Tcb _ \<Rightarrow> True
  | _ \<Rightarrow> False"

definition
  object_at :: "(cdl_object \<Rightarrow> bool) \<Rightarrow> cdl_object_id \<Rightarrow> cdl_heap \<Rightarrow> bool"
where
  "object_at P p s \<equiv> \<exists>object. s p = Some object \<and> P object"

abbreviation
  "ko_at k \<equiv> object_at ((=) k)"

end