(*  Title:      Uint.thy
    Author:     Peter Lammich, TU Munich
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter \<open>Unsigned words of default size\<close>

theory Uint imports
  Word_Type_Copies
  Code_Target_Integer_Bit
begin

text \<open>
  This theory provides access to words in the target languages of the code generator
  whose bit width is the default of the target language. To that end, the type \<open>uint\<close>
  models words of width \<open>dflt_size\<close>, but \<open>dflt_size\<close> is known only to be positive.

  Usage restrictions:
  Default-size words (type \<open>uint\<close>) cannot be used for evaluation, because
  the results depend on the particular choice of word size in the target language
  and implementation. Symbolic evaluation has not yet been set up for \<open>uint\<close>.
\<close>

text \<open>The default size type\<close>
typedecl dflt_size

instantiation dflt_size :: typerep begin
definition "typerep_class.typerep \<equiv>  \<lambda>_ :: dflt_size itself. Typerep.Typerep (STR ''Uint.dflt_size'') []"
instance ..
end

consts dflt_size_aux :: "nat"
specification (dflt_size_aux) dflt_size_aux_g0: "dflt_size_aux > 0"
  by auto
hide_fact dflt_size_aux_def

instantiation dflt_size :: len begin
definition "len_of_dflt_size (_ :: dflt_size itself) \<equiv> dflt_size_aux"
instance by(intro_classes)(simp add: len_of_dflt_size_def dflt_size_aux_g0)
end

abbreviation "dflt_size \<equiv> len_of (TYPE (dflt_size))"

context includes integer.lifting begin
lift_definition dflt_size_integer :: integer is "int dflt_size" .
declare dflt_size_integer_def[code del]
  \<comment> \<open>The code generator will substitute a machine-dependent value for this constant\<close>

lemma dflt_size_by_int[code]: "dflt_size = nat_of_integer dflt_size_integer"
by transfer simp

lemma dflt_size[simp]:
  "dflt_size > 0"
  "dflt_size \<ge> Suc 0"
  "\<not> dflt_size < Suc 0"
  using len_gt_0[where 'a=dflt_size]
  by (simp_all del: len_gt_0)
end

section \<open>Type definition and primitive operations\<close>

typedef uint = \<open>UNIV :: dflt_size word set\<close> ..

global_interpretation uint: word_type_copy Abs_uint Rep_uint
  using type_definition_uint by (rule word_type_copy.intro)

setup_lifting type_definition_uint

declare uint.of_word_of [code abstype]

declare Quotient_uint [transfer_rule]

instantiation uint :: \<open>{comm_ring_1, semiring_modulo, equal, linorder}\<close>
begin

lift_definition zero_uint :: uint is 0 .
lift_definition one_uint :: uint is 1 .
lift_definition plus_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(+)\<close> .
lift_definition uminus_uint :: \<open>uint \<Rightarrow> uint\<close> is uminus .
lift_definition minus_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(-)\<close> .
lift_definition times_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(*)\<close> .
lift_definition divide_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(div)\<close> .
lift_definition modulo_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>(mod)\<close> .
lift_definition equal_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> bool\<close> is \<open>HOL.equal\<close> .
lift_definition less_eq_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> bool\<close> is \<open>(\<le>)\<close> .
lift_definition less_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> bool\<close> is \<open>(<)\<close> .

global_interpretation uint: word_type_copy_ring Abs_uint Rep_uint
  by standard (fact zero_uint.rep_eq one_uint.rep_eq
    plus_uint.rep_eq uminus_uint.rep_eq minus_uint.rep_eq
    times_uint.rep_eq divide_uint.rep_eq modulo_uint.rep_eq
    equal_uint.rep_eq less_eq_uint.rep_eq less_uint.rep_eq)+

instance proof -
  show \<open>OFCLASS(uint, comm_ring_1_class)\<close>
    by (rule uint.of_class_comm_ring_1)
  show \<open>OFCLASS(uint, semiring_modulo_class)\<close>
    by (fact uint.of_class_semiring_modulo)
  show \<open>OFCLASS(uint, equal_class)\<close>
    by (fact uint.of_class_equal)
  show \<open>OFCLASS(uint, linorder_class)\<close>
    by (fact uint.of_class_linorder)
qed

end

instantiation uint :: ring_bit_operations
begin

lift_definition bit_uint :: \<open>uint \<Rightarrow> nat \<Rightarrow> bool\<close> is bit .
lift_definition not_uint :: \<open>uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.not\<close> .
lift_definition and_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.and\<close> .
lift_definition or_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.or\<close> .
lift_definition xor_uint :: \<open>uint \<Rightarrow> uint \<Rightarrow> uint\<close> is \<open>Bit_Operations.xor\<close> .
lift_definition mask_uint :: \<open>nat \<Rightarrow> uint\<close> is mask .
lift_definition push_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is push_bit .
lift_definition drop_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is drop_bit .
lift_definition signed_drop_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is signed_drop_bit .
lift_definition take_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is take_bit .
lift_definition set_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is Bit_Operations.set_bit .
lift_definition unset_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is unset_bit .
lift_definition flip_bit_uint :: \<open>nat \<Rightarrow> uint \<Rightarrow> uint\<close> is flip_bit .

global_interpretation uint: word_type_copy_bits Abs_uint Rep_uint signed_drop_bit_uint
  by standard (fact bit_uint.rep_eq not_uint.rep_eq and_uint.rep_eq or_uint.rep_eq xor_uint.rep_eq
    mask_uint.rep_eq push_bit_uint.rep_eq drop_bit_uint.rep_eq signed_drop_bit_uint.rep_eq take_bit_uint.rep_eq
    set_bit_uint.rep_eq unset_bit_uint.rep_eq flip_bit_uint.rep_eq)+

instance
  by (fact uint.of_class_ring_bit_operations)

end

lift_definition uint_of_nat :: \<open>nat \<Rightarrow> uint\<close>
  is word_of_nat .

lift_definition nat_of_uint :: \<open>uint \<Rightarrow> nat\<close>
  is unat .

lift_definition uint_of_int :: \<open>int \<Rightarrow> uint\<close>
  is word_of_int .

lift_definition int_of_uint :: \<open>uint \<Rightarrow> int\<close>
  is uint .

context
  includes integer.lifting
begin

lift_definition Uint :: \<open>integer \<Rightarrow> uint\<close>
  is word_of_int .

lift_definition integer_of_uint :: \<open>uint \<Rightarrow> integer\<close>
  is uint .

end

global_interpretation uint: word_type_copy_more Abs_uint Rep_uint signed_drop_bit_uint
  uint_of_nat nat_of_uint uint_of_int int_of_uint Uint integer_of_uint
  apply standard
       apply (simp_all add: uint_of_nat.rep_eq nat_of_uint.rep_eq
         uint_of_int.rep_eq int_of_uint.rep_eq
         Uint.rep_eq integer_of_uint.rep_eq integer_eq_iff)
  done

instantiation uint :: "{size, msb, lsb, set_bit, bit_comprehension}"
begin

lift_definition size_uint :: \<open>uint \<Rightarrow> nat\<close> is size .

lift_definition msb_uint :: \<open>uint \<Rightarrow> bool\<close> is msb .
lift_definition lsb_uint :: \<open>uint \<Rightarrow> bool\<close> is lsb .

text \<open>Workaround: avoid name space clash by spelling out \<^text>\<open>lift_definition\<close> explicitly.\<close>

definition set_bit_uint :: \<open>uint \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint\<close>
  where set_bit_uint_eq: \<open>set_bit_uint a n b = (if b then Bit_Operations.set_bit else unset_bit) n a\<close>

context
  includes lifting_syntax
begin

lemma set_bit_uint_transfer [transfer_rule]:
  \<open>(cr_uint ===> (=) ===> (\<longleftrightarrow>) ===> cr_uint) Generic_set_bit.set_bit Generic_set_bit.set_bit\<close>
  by (simp only: set_bit_eq [abs_def] set_bit_uint_eq [abs_def]) transfer_prover

end

lift_definition set_bits_uint :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> uint\<close> is set_bits .
lift_definition set_bits_aux_uint :: \<open>(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> uint \<Rightarrow> uint\<close> is set_bits_aux .

global_interpretation uint: word_type_copy_misc Abs_uint Rep_uint signed_drop_bit_uint
  uint_of_nat nat_of_uint uint_of_int int_of_uint Uint integer_of_uint dflt_size set_bits_aux_uint
  by (standard; transfer) simp_all

instance using uint.of_class_bit_comprehension
  uint.of_class_set_bit uint.of_class_lsb
  by simp_all standard

end

section \<open>Code setup\<close>

code_printing code_module Uint \<rightharpoonup> (SML)
\<open>
structure Uint : sig
  val set_bit : Word.word -> IntInf.int -> bool -> Word.word
  val shiftl : Word.word -> IntInf.int -> Word.word
  val shiftr : Word.word -> IntInf.int -> Word.word
  val shiftr_signed : Word.word -> IntInf.int -> Word.word
  val test_bit : Word.word -> IntInf.int -> bool
end = struct

fun set_bit x n b =
  let val mask = Word.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))
  in if b then Word.orb (x, mask)
     else Word.andb (x, Word.notb mask)
  end

fun shiftl x n =
  Word.<< (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr x n =
  Word.>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun shiftr_signed x n =
  Word.~>> (x, Word.fromLargeInt (IntInf.toLarge n))

fun test_bit x n =
  Word.andb (x, Word.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word.fromInt 0

end; (* struct Uint *)\<close>
code_reserved SML Uint

code_printing code_module Uint \<rightharpoonup> (Haskell)
 \<open>module Uint(Int, Word, dflt_size) where

  import qualified Prelude
  import Data.Int(Int)
  import Data.Word(Word)
  import qualified Data.Bits

  dflt_size :: Prelude.Integer
  dflt_size = Prelude.toInteger (bitSize_aux (0::Word)) where
    bitSize_aux :: (Data.Bits.Bits a, Prelude.Bounded a) => a -> Int
    bitSize_aux = Data.Bits.bitSize\<close>
  and (Haskell_Quickcheck)
 \<open>module Uint(Int, Word, dflt_size) where

  import qualified Prelude
  import Data.Int(Int)
  import Data.Word(Word)
  import qualified Data.Bits

  dflt_size :: Prelude.Int
  dflt_size = bitSize_aux (0::Word) where
    bitSize_aux :: (Data.Bits.Bits a, Prelude.Bounded a) => a -> Int
    bitSize_aux = Data.Bits.bitSize
\<close>
code_reserved Haskell Uint dflt_size

text \<open>
  OCaml and Scala provide only signed bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
\<close>

code_printing code_module "Uint" \<rightharpoonup> (OCaml)
\<open>module Uint : sig
  type t = int
  val dflt_size : Z.t
  val less : t -> t -> bool
  val less_eq : t -> t -> bool
  val set_bit : t -> Z.t -> bool -> t
  val shiftl : t -> Z.t -> t
  val shiftr : t -> Z.t -> t
  val shiftr_signed : t -> Z.t -> t
  val test_bit : t -> Z.t -> bool
  val int_mask : int
  val int32_mask : int32
  val int64_mask : int64
end = struct

type t = int

let dflt_size = Z.of_int Sys.int_size;;

(* negative numbers have their highest bit set,
   so they are greater than positive ones *)
let less x y =
  if x<0 then
    y<0 && x<y
  else y < 0 || x < y;;

let less_eq x y =
  if x < 0 then
    y < 0 &&  x <= y
  else y < 0 || x <= y;;

let set_bit x n b =
  let mask = 1 lsl (Z.to_int n)
  in if b then x lor mask
     else x land (lnot mask);;

let shiftl x n = x lsl (Z.to_int n);;

let shiftr x n = x lsr (Z.to_int n);;

let shiftr_signed x n = x asr (Z.to_int n);;

let test_bit x n = x land (1 lsl (Z.to_int n)) <> 0;;

let int_mask =
  if Sys.int_size < 32 then lnot 0 else 0xFFFFFFFF;;

let int32_mask =
  if Sys.int_size < 32 then Int32.pred (Int32.shift_left Int32.one Sys.int_size)
  else Int32.of_string "0xFFFFFFFF";;

let int64_mask =
  if Sys.int_size < 64 then Int64.pred (Int64.shift_left Int64.one Sys.int_size)
  else Int64.of_string "0xFFFFFFFFFFFFFFFF";;

end;; (*struct Uint*)\<close>
code_reserved OCaml Uint

code_printing code_module Uint \<rightharpoonup> (Scala)
\<open>object Uint {
def dflt_size : BigInt = BigInt(32)

def less(x: Int, y: Int) : Boolean =
  if (x < 0) y < 0 && x < y
  else y < 0 || x < y

def less_eq(x: Int, y: Int) : Boolean =
  if (x < 0) y < 0 && x <= y
  else y < 0 || x <= y

def set_bit(x: Int, n: BigInt, b: Boolean) : Int =
  if (b)
    x | (1 << n.intValue)
  else
    x & (1 << n.intValue).unary_~

def shiftl(x: Int, n: BigInt) : Int = x << n.intValue

def shiftr(x: Int, n: BigInt) : Int = x >>> n.intValue

def shiftr_signed(x: Int, n: BigInt) : Int = x >> n.intValue

def test_bit(x: Int, n: BigInt) : Boolean =
  (x & (1 << n.intValue)) != 0

} /* object Uint */\<close>
code_reserved Scala Uint

text \<open>
  OCaml's conversion from Big\_int to int demands that the value fits into a signed integer.
  The following justifies the implementation.
\<close>

context
  includes integer.lifting bit_operations_syntax
begin

definition wivs_mask :: int where "wivs_mask = 2^ dflt_size - 1"
lift_definition wivs_mask_integer :: integer is wivs_mask .

definition wivs_shift :: int where "wivs_shift = 2 ^ dflt_size"
lift_definition wivs_shift_integer :: integer is wivs_shift .
lemma [code]: "wivs_shift_integer = 2 ^ dflt_size"
  by transfer (simp add: wivs_shift_def)

definition wivs_index :: nat where "wivs_index == dflt_size - 1"
lift_definition wivs_index_integer :: integer is "int wivs_index".
lemma wivs_index_integer_code[code]: "wivs_index_integer = dflt_size_integer - 1"
  by transfer (simp add: wivs_index_def of_nat_diff)

definition wivs_overflow :: int where "wivs_overflow == 2^ (dflt_size - 1)"
lift_definition wivs_overflow_integer :: integer is wivs_overflow .
lemma [code]: "wivs_overflow_integer = 2 ^ (dflt_size - 1)"
  by transfer (simp add: wivs_overflow_def)

definition wivs_least :: int where "wivs_least == - wivs_overflow"
lift_definition wivs_least_integer :: integer is wivs_least .
lemma [code]: "wivs_least_integer = - (2 ^ (dflt_size - 1))"
  by transfer (simp add: wivs_overflow_def wivs_least_def)

definition Uint_signed :: "integer \<Rightarrow> uint" where
  "Uint_signed i = (if i < wivs_least_integer \<or> wivs_overflow_integer \<le> i then undefined Uint i else Uint i)"

lemma Uint_code [code]:
  "Uint i =
  (let i' = i AND wivs_mask_integer in
   if bit i' wivs_index then Uint_signed (i' - wivs_shift_integer) else Uint_signed i')"
  including undefined_transfer
  unfolding Uint_signed_def
  apply transfer
  apply (subst word_of_int_via_signed)
       apply (auto simp add: push_bit_of_1 mask_eq_exp_minus_1 word_of_int_via_signed
         wivs_mask_def wivs_index_def wivs_overflow_def wivs_least_def wivs_shift_def)
  done

lemma Uint_signed_code [code]:
  "Rep_uint (Uint_signed i) =
  (if i < wivs_least_integer \<or> i \<ge> wivs_overflow_integer then Rep_uint (undefined Uint i) else word_of_int (int_of_integer_symbolic i))"
  unfolding Uint_signed_def Uint_def int_of_integer_symbolic_def by(simp add: Abs_uint_inverse)
end

text \<open>
  Avoid @{term Abs_uint} in generated code, use @{term Rep_uint'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint}.

  The new destructor @{term Rep_uint'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint}
  ([code abstract] equations for @{typ uint} may use @{term Rep_uint} because
  these instances will be folded away.)
\<close>

definition Rep_uint' where [simp]: "Rep_uint' = Rep_uint"

lemma Rep_uint'_code [code]: "Rep_uint' x = (BITS n. bit x n)"
  unfolding Rep_uint'_def by transfer (simp add: set_bits_bit_eq)

lift_definition Abs_uint' :: "dflt_size word \<Rightarrow> uint" is "\<lambda>x :: dflt_size word. x" .

lemma Abs_uint'_code [code]:
  "Abs_uint' x = Uint (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint \<Rightarrow> _"]]

lemma term_of_uint_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''"
  shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint.uint.Abs_uint'') (TR (STR ''fun'') [TR (STR ''Word.word'')  [TR (STR ''Uint.dflt_size'') []], TR (STR ''Uint.uint'') []]))
       (term_of_class.term_of (Rep_uint' x))"
  by(simp add: term_of_anything)

text \<open>Important:
  We must prevent the reflection oracle (eval-tac) to
  use our machine-dependent type.
\<close>

code_printing
  type_constructor uint \<rightharpoonup>
  (SML) "Word.word" and
  (Haskell) "Uint.Word" and
  (OCaml) "Uint.t" and
  (Scala) "Int" and
  (Eval) "*** \"Error: Machine dependent type\" ***" and
  (Quickcheck) "Word.word"
| constant dflt_size_integer \<rightharpoonup>
  (SML) "(IntInf.fromLarge (Int.toLarge Word.wordSize))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.wordSize" and
  (Haskell) "Uint.dflt'_size" and
  (OCaml) "Uint.dflt'_size" and
  (Scala) "Uint.dflt'_size"
| constant Uint \<rightharpoonup>
  (SML) "Word.fromLargeInt (IntInf.toLarge _)" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.fromInt" and
  (Haskell) "(Prelude.fromInteger _ :: Uint.Word)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint.Word)" and
  (Scala) "_.intValue"
| constant Uint_signed \<rightharpoonup>
  (OCaml) "Z.to'_int"
| constant "0 :: uint" \<rightharpoonup>
  (SML) "(Word.fromInt 0)" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "(Word.fromInt 0)" and
  (Haskell) "(0 :: Uint.Word)" and
  (OCaml) "0" and
  (Scala) "0"
| constant "1 :: uint" \<rightharpoonup>
  (SML) "(Word.fromInt 1)" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "(Word.fromInt 1)" and
  (Haskell) "(1 :: Uint.Word)" and
  (OCaml) "1" and
  (Scala) "1"
| constant "plus :: uint \<Rightarrow> _ " \<rightharpoonup>
  (SML) "Word.+ ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (OCaml) "Pervasives.(+)" and
  (Scala) infixl 7 "+"
| constant "uminus :: uint \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.~" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.~" and
  (Haskell) "negate" and
  (OCaml) "Pervasives.(~-)" and
  (Scala) "!(- _)"
| constant "minus :: uint \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.- ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (OCaml) "Pervasives.(-)" and
  (Scala) infixl 7 "-"
| constant "times :: uint \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.* ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (OCaml) "Pervasives.( * )" and
  (Scala) infixl 8 "*"
| constant "HOL.equal :: uint \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Word.word) = _)" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "!((_ : Word.word) = _)" and
  (Haskell) infix 4 "==" and
  (OCaml) "(Pervasives.(=):Uint.t -> Uint.t -> bool)" and
  (Scala) infixl 5 "=="
| class_instance uint :: equal \<rightharpoonup>
  (Haskell) -
| constant "less_eq :: uint \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word.<= ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (OCaml) "Uint.less'_eq" and
  (Scala) "Uint.less'_eq"
| constant "less :: uint \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word.< ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (OCaml) "Uint.less" and
  (Scala) "Uint.less"
| constant "Bit_Operations.not :: uint \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.notb" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.notb" and
  (Haskell) "Data'_Bits.complement" and
  (OCaml) "Pervasives.lnot" and
  (Scala) "_.unary'_~"
| constant "Bit_Operations.and :: uint \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.andb ((_),/ (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (OCaml) "Pervasives.(land)" and
  (Scala) infixl 3 "&"
| constant "Bit_Operations.or :: uint \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.orb ((_),/ (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (OCaml) "Pervasives.(lor)" and
  (Scala) infixl 1 "|"
| constant "Bit_Operations.xor :: uint \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word.xorb ((_),/ (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (OCaml) "Pervasives.(lxor)" and
  (Scala) infixl 2 "^"

definition uint_divmod :: "uint \<Rightarrow> uint \<Rightarrow> uint \<times> uint" where
  "uint_divmod x y =
  (if y = 0 then (undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint), undefined ((mod) :: uint \<Rightarrow> _) x (0 :: uint))
  else (x div y, x mod y))"

definition uint_div :: "uint \<Rightarrow> uint \<Rightarrow> uint"
where "uint_div x y = fst (uint_divmod x y)"

definition uint_mod :: "uint \<Rightarrow> uint \<Rightarrow> uint"
where "uint_mod x y = snd (uint_divmod x y)"

lemma div_uint_code [code]: "x div y = (if y = 0 then 0 else uint_div x y)"
including undefined_transfer unfolding uint_divmod_def uint_div_def
by transfer(simp add: word_div_def)

lemma mod_uint_code [code]: "x mod y = (if y = 0 then x else uint_mod x y)"
including undefined_transfer unfolding uint_mod_def uint_divmod_def
by transfer(simp add: word_mod_def)

definition uint_sdiv :: "uint \<Rightarrow> uint \<Rightarrow> uint"
where [code del]:
  "uint_sdiv x y =
   (if y = 0 then undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint)
    else Abs_uint (Rep_uint x sdiv Rep_uint y))"

definition div0_uint :: "uint \<Rightarrow> uint"
where [code del]: "div0_uint x = undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint)"
declare [[code abort: div0_uint]]

definition mod0_uint :: "uint \<Rightarrow> uint"
where [code del]: "mod0_uint x = undefined ((mod) :: uint \<Rightarrow> _) x (0 :: uint)"
declare [[code abort: mod0_uint]]

definition wivs_overflow_uint :: uint
  where "wivs_overflow_uint \<equiv> push_bit (dflt_size - 1) 1"

lemma Rep_uint_wivs_overflow_uint_eq:
  \<open>Rep_uint wivs_overflow_uint = 2 ^ (dflt_size - Suc 0)\<close>
  by (simp add: wivs_overflow_uint_def one_uint.rep_eq push_bit_uint.rep_eq uint.word_of_power push_bit_eq_mult)

lemma wivs_overflow_uint_greater_eq_0:
  \<open>wivs_overflow_uint > 0\<close>
  apply (simp add: less_uint.rep_eq zero_uint.rep_eq Rep_uint_wivs_overflow_uint_eq)
  apply transfer
  apply (simp add: take_bit_push_bit push_bit_eq_mult)
  done

lemma uint_divmod_code [code]:
  "uint_divmod x y =
  (if wivs_overflow_uint \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint x, mod0_uint x)
   else let q = push_bit 1 (uint_sdiv (drop_bit 1 x) y);
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
proof (cases \<open>y = 0\<close>)
  case True
  moreover have \<open>x \<ge> 0\<close>
    by transfer simp
  moreover note wivs_overflow_uint_greater_eq_0
  ultimately show ?thesis
    by (auto simp add: uint_divmod_def div0_uint_def mod0_uint_def not_less)
next
  case False
  then show ?thesis
    including undefined_transfer
    unfolding uint_divmod_def uint_sdiv_def div0_uint_def mod0_uint_def
      wivs_overflow_uint_def
    apply transfer
    apply (simp add: divmod_via_sdivmod push_bit_of_1)
    done
qed

lemma uint_sdiv_code [code]:
  "Rep_uint (uint_sdiv x y) =
   (if y = 0 then Rep_uint (undefined ((div) :: uint \<Rightarrow> _) x (0 :: uint))
    else Rep_uint x sdiv Rep_uint y)"
unfolding uint_sdiv_def by(simp add: Abs_uint_inverse)

text \<open>
  Note that we only need a translation for signed division, but not for the remainder
  because @{thm uint_divmod_code} computes both with division only.
\<close>

code_printing
  constant uint_div \<rightharpoonup>
  (SML) "Word.div ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.div ((_), (_))" and
  (Haskell) "Prelude.div"
| constant uint_mod \<rightharpoonup>
  (SML) "Word.mod ((_), (_))" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Word.mod ((_), (_))" and
  (Haskell) "Prelude.mod"
| constant uint_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint_sdiv \<rightharpoonup>
  (OCaml) "Pervasives.('/)" and
  (Scala) "_ '/ _"

definition uint_test_bit :: "uint \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint_test_bit x n =
  (if n < 0 \<or> dflt_size_integer \<le> n then undefined (bit :: uint \<Rightarrow> _) x n
   else bit x (nat_of_integer n))"

lemma test_bit_uint_code [code]:
  "bit x n \<longleftrightarrow> n < dflt_size \<and> uint_test_bit x (integer_of_nat n)"
  including undefined_transfer integer.lifting unfolding uint_test_bit_def
  by (transfer, simp, transfer, simp)

lemma uint_test_bit_code [code]:
  "uint_test_bit w n =
  (if n < 0 \<or> dflt_size_integer \<le> n then undefined (bit :: uint \<Rightarrow> _) w n else bit (Rep_uint w) (nat_of_integer n))"
  unfolding uint_test_bit_def by(simp add: bit_uint.rep_eq)

code_printing constant uint_test_bit \<rightharpoonup>
  (SML) "Uint.test'_bit" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Uint.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (OCaml) "Uint.test'_bit" and
  (Scala) "Uint.test'_bit"

definition uint_set_bit :: "uint \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint"
where [code del]:
  "uint_set_bit x n b =
  (if n < 0 \<or> dflt_size_integer \<le> n then undefined (set_bit :: uint \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint_code [code]:
  "set_bit x n b = (if n < dflt_size then uint_set_bit x (integer_of_nat n) b else x)"
  including undefined_transfer integer.lifting unfolding uint_set_bit_def
  by (transfer) (auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint_set_bit_code [code]:
  "Rep_uint (uint_set_bit w n b) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (set_bit :: uint \<Rightarrow> _) w n b)
   else set_bit (Rep_uint w) (nat_of_integer n) b)"
including undefined_transfer integer.lifting unfolding uint_set_bit_def by transfer simp

code_printing constant uint_set_bit \<rightharpoonup>
  (SML) "Uint.set'_bit" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Uint.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (OCaml) "Uint.set'_bit" and
  (Scala) "Uint.set'_bit"

definition uint_shiftl :: "uint \<Rightarrow> integer \<Rightarrow> uint"
where [code del]:
  "uint_shiftl x n = (if n < 0 \<or> dflt_size_integer \<le> n then undefined (push_bit :: nat \<Rightarrow> uint \<Rightarrow> _) x n else push_bit (nat_of_integer n) x)"

lemma shiftl_uint_code [code]: "push_bit n x = (if n < dflt_size then uint_shiftl x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint_shiftl_def
  by (transfer fixing: n) simp

lemma uint_shiftl_code [code]:
  "Rep_uint (uint_shiftl w n) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (push_bit :: nat \<Rightarrow> uint \<Rightarrow> _) w n) else push_bit (nat_of_integer n) (Rep_uint w))"
  including undefined_transfer integer.lifting unfolding uint_shiftl_def by transfer simp

code_printing constant uint_shiftl \<rightharpoonup>
  (SML) "Uint.shiftl" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Uint.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (OCaml) "Uint.shiftl" and
  (Scala) "Uint.shiftl"

definition uint_shiftr :: "uint \<Rightarrow> integer \<Rightarrow> uint"
where [code del]:
  "uint_shiftr x n = (if n < 0 \<or> dflt_size_integer \<le> n then undefined (drop_bit :: nat \<Rightarrow> uint \<Rightarrow> _) x n else drop_bit (nat_of_integer n) x)"

lemma shiftr_uint_code [code]: "drop_bit n x = (if n < dflt_size then uint_shiftr x (integer_of_nat n) else 0)"
  including undefined_transfer integer.lifting unfolding uint_shiftr_def
  by (transfer fixing: n) simp

lemma uint_shiftr_code [code]:
  "Rep_uint (uint_shiftr w n) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (drop_bit :: nat \<Rightarrow> uint \<Rightarrow> _) w n) else drop_bit (nat_of_integer n) (Rep_uint w))"
  including undefined_transfer integer.lifting unfolding uint_shiftr_def by transfer simp

code_printing constant uint_shiftr \<rightharpoonup>
  (SML) "Uint.shiftr" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Uint.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (OCaml) "Uint.shiftr" and
  (Scala) "Uint.shiftr"

definition uint_sshiftr :: "uint \<Rightarrow> integer \<Rightarrow> uint"
where [code del]:
  "uint_sshiftr x n =
  (if n < 0 \<or> dflt_size_integer \<le> n then undefined signed_drop_bit_uint n x else signed_drop_bit_uint (nat_of_integer n) x)"

lemma sshiftr_uint_code [code]:
  "signed_drop_bit_uint n x =
  (if n < dflt_size then uint_sshiftr x (integer_of_nat n) else
    if bit x wivs_index then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint_sshiftr_def
by transfer(simp add: not_less signed_drop_bit_beyond word_size wivs_index_def)

lemma uint_sshiftr_code [code]:
  "Rep_uint (uint_sshiftr w n) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined signed_drop_bit_uint n w) else signed_drop_bit (nat_of_integer n) (Rep_uint w))"
including undefined_transfer integer.lifting unfolding uint_sshiftr_def by transfer simp

code_printing constant uint_sshiftr \<rightharpoonup>
  (SML) "Uint.shiftr'_signed" and
  (Eval) "(raise (Fail \"Machine dependent code\"))" and
  (Quickcheck) "Uint.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint.Int) _)) :: Uint.Word)" and
  (OCaml) "Uint.shiftr'_signed" and
  (Scala) "Uint.shiftr'_signed"

lemma uint_msb_test_bit: "msb x \<longleftrightarrow> bit (x :: uint) wivs_index"
  by transfer (simp add: msb_word_iff_bit wivs_index_def)

lemma msb_uint_code [code]: "msb x \<longleftrightarrow> uint_test_bit x wivs_index_integer"
  apply(simp add: uint_test_bit_def uint_msb_test_bit
  wivs_index_integer_code dflt_size_integer_def wivs_index_def)
  by (metis (full_types) One_nat_def dflt_size(2) less_iff_diff_less_0
    nat_of_integer_of_nat of_nat_1 of_nat_diff of_nat_less_0_iff wivs_index_def)

lemma uint_of_int_code [code]: "uint_of_int i = (BITS n. bit i n)"
  by transfer (simp add: word_of_int_conv_set_bits)

section \<open>Quickcheck setup\<close>

definition uint_of_natural :: "natural \<Rightarrow> uint"
where "uint_of_natural x \<equiv> Uint (integer_of_natural x)"

instantiation uint :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint \<equiv> qc_random_cnv uint_of_natural"
definition "exhaustive_uint \<equiv> qc_exhaustive_cnv uint_of_natural"
definition "full_exhaustive_uint \<equiv> qc_full_exhaustive_cnv uint_of_natural"
instance ..
end

instantiation uint :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. (Uint i, Uint (- i))" "0"
  "Typerep.Typerep (STR ''Uint.uint'') []" .

definition "narrowing_uint d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint itself \<Rightarrow> _"]]
lemmas partial_term_of_uint [code] = partial_term_of_code

instance ..
end

end


(*
(C) Copyright Andreas Viktor Hess, DTU, 2020
(C) Copyright Sebastian A. Mödersheim, DTU, 2020
(C) Copyright Achim D. Brucker, University of Exeter, 2020
(C) Copyright Anders Schlichtkrull, DTU, 2020

All Rights Reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright
  notice, this list of conditions and the following disclaimer.

- Redistributions in binary form must reproduce the above copyright
  notice, this list of conditions and the following disclaimer in the
  documentation and/or other materials provided with the distribution.

- Neither the name of the copyright holder nor the names of its
  contributors may be used to endorse or promote products
  derived from this software without specific prior written
  permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

(*  Title:      Term_Abstraction.thy
    Author:     Andreas Viktor Hess, DTU
    Author:     Sebastian A. Mödersheim, DTU
    Author:     Achim D. Brucker, University of Exeter
    Author:     Anders Schlichtkrull, DTU
*)

section\<open>Term Abstraction\<close>
theory Term_Abstraction
  imports Transactions
begin

subsection \<open>Definitions\<close>
fun to_abs ("\<alpha>\<^sub>0") where
  "\<alpha>\<^sub>0 [] _ = {}"
| "\<alpha>\<^sub>0 ((Fun (Val m) [],Fun (Set s) S)#D) n =
    (if m = n then insert s (\<alpha>\<^sub>0 D n) else \<alpha>\<^sub>0 D n)"
| "\<alpha>\<^sub>0 (_#D) n = \<alpha>\<^sub>0 D n"

fun abs_apply_term (infixl "\<cdot>\<^sub>\<alpha>" 67) where
  "Var x \<cdot>\<^sub>\<alpha> \<alpha> = Var x"
| "Fun (Val n) T \<cdot>\<^sub>\<alpha> \<alpha> = Fun (Abs (\<alpha> n)) (map (\<lambda>t. t \<cdot>\<^sub>\<alpha> \<alpha>) T)"
| "Fun f T \<cdot>\<^sub>\<alpha> \<alpha> = Fun f (map (\<lambda>t. t \<cdot>\<^sub>\<alpha> \<alpha>) T)"

definition abs_apply_list (infixl "\<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t" 67) where
  "M \<cdot>\<^sub>\<alpha>\<^sub>l\<^sub>i\<^sub>s\<^sub>t \<alpha> \<equiv> map (\<lambda>t. t \<cdot>\<^sub>\<alpha> \<alpha>) M"

definition abs_apply_terms (infixl "\<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t" 67) where
  "M \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha> \<equiv> (\<lambda>t. t \<cdot>\<^sub>\<alpha> \<alpha>) ` M"

definition abs_apply_pairs (infixl "\<cdot>\<^sub>\<alpha>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s" 67) where
  "F \<cdot>\<^sub>\<alpha>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \<alpha> \<equiv> map (\<lambda>(s,t). (s \<cdot>\<^sub>\<alpha> \<alpha>, t \<cdot>\<^sub>\<alpha> \<alpha>)) F"

definition abs_apply_strand_step (infixl "\<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>t\<^sub>p" 67) where
  "s \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>t\<^sub>p \<alpha> \<equiv> (case s of
    (l,send\<langle>t\<rangle>) \<Rightarrow> (l,send\<langle>t \<cdot>\<^sub>\<alpha> \<alpha>\<rangle>)
  | (l,receive\<langle>t\<rangle>) \<Rightarrow> (l,receive\<langle>t \<cdot>\<^sub>\<alpha> \<alpha>\<rangle>)
  | (l,\<langle>ac: t \<doteq> t'\<rangle>) \<Rightarrow> (l,\<langle>ac: (t \<cdot>\<^sub>\<alpha> \<alpha>) \<doteq> (t' \<cdot>\<^sub>\<alpha> \<alpha>)\<rangle>)
  | (l,insert\<langle>t,t'\<rangle>) \<Rightarrow> (l,insert\<langle>t \<cdot>\<^sub>\<alpha> \<alpha>,t' \<cdot>\<^sub>\<alpha> \<alpha>\<rangle>)
  | (l,delete\<langle>t,t'\<rangle>) \<Rightarrow> (l,delete\<langle>t \<cdot>\<^sub>\<alpha> \<alpha>,t' \<cdot>\<^sub>\<alpha> \<alpha>\<rangle>)
  | (l,\<langle>ac: t \<in> t'\<rangle>) \<Rightarrow> (l,\<langle>ac: (t \<cdot>\<^sub>\<alpha> \<alpha>) \<in> (t' \<cdot>\<^sub>\<alpha> \<alpha>)\<rangle>)
  | (l,\<forall>X\<langle>\<or>\<noteq>: F \<or>\<notin>: F'\<rangle>) \<Rightarrow> (l,\<forall>X\<langle>\<or>\<noteq>: (F \<cdot>\<^sub>\<alpha>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \<alpha>) \<or>\<notin>: (F' \<cdot>\<^sub>\<alpha>\<^sub>p\<^sub>a\<^sub>i\<^sub>r\<^sub>s \<alpha>)\<rangle>))"

definition abs_apply_strand (infixl "\<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>t" 67) where
  "S \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>t \<alpha> \<equiv> map (\<lambda>x. x \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>t\<^sub>p \<alpha>) S"

subsection \<open>Lemmata\<close>
lemma to_abs_alt_def:
  "\<alpha>\<^sub>0 D n = {s. \<exists>S. (Fun (Val n) [], Fun (Set s) S) \<in> set D}"
by (induct D n rule: to_abs.induct) auto

lemma abs_term_apply_const[simp]:
  "is_Val f \<Longrightarrow> Fun f [] \<cdot>\<^sub>\<alpha> a = Fun (Abs (a (the_Val f))) []"
  "\<not>is_Val f \<Longrightarrow> Fun f [] \<cdot>\<^sub>\<alpha> a = Fun f []"
by (cases f; auto)+

lemma abs_fv: "fv (t \<cdot>\<^sub>\<alpha> a) = fv t"
by (induct t a rule: abs_apply_term.induct) auto

lemma abs_eq_if_no_Val:
  assumes "\<forall>f \<in> funs_term t. \<not>is_Val f"
  shows "t \<cdot>\<^sub>\<alpha> a = t \<cdot>\<^sub>\<alpha> b"
using assms
proof (induction t)
  case (Fun f T) thus ?case by (cases f) simp_all
qed simp

lemma abs_set_empty[simp]: "{} \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha> = {}"
unfolding abs_apply_terms_def by simp

lemma abs_set_union: "(A \<union> B) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a = (A \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a) \<union> (B \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a)"
unfolding abs_apply_terms_def
by auto

lemma abs_subterms: "subterms (t \<cdot>\<^sub>\<alpha> \<alpha>) = subterms t \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t \<alpha>"
proof (induction t)
  case (Fun f T) thus ?case by (cases f) (auto simp add: abs_apply_terms_def)
qed (simp add: abs_apply_terms_def)

lemma abs_subterms_in: "s \<in> subterms t \<Longrightarrow> s \<cdot>\<^sub>\<alpha> a \<in> subterms (t \<cdot>\<^sub>\<alpha> a)"
proof (induction t)
  case (Fun f T) thus ?case by (cases f) auto
qed simp

lemma abs_ik_append: "(ik\<^sub>s\<^sub>s\<^sub>t (A@B) \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a = (ik\<^sub>s\<^sub>s\<^sub>t A \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a \<union> (ik\<^sub>s\<^sub>s\<^sub>t B \<cdot>\<^sub>s\<^sub>e\<^sub>t I) \<cdot>\<^sub>\<alpha>\<^sub>s\<^sub>e\<^sub>t a"
unfolding abs_apply_terms_def ik\<^sub>s\<^sub>s\<^sub>t_def
by auto

lemma to_abs_in:
  assumes "(Fun (Val n) [], Fun (Set s) []) \<in> set D"
  shows "s \<in> \<alpha>\<^sub>0 D n"
using assms by (induct rule: to_abs.induct) auto

lemma to_abs_empty_iff_notin_db:
  "Fun (Val n) [] \<cdot>\<^sub>\<alpha> \<alpha>\<^sub>0 D = Fun (Abs {}) [] \<longleftrightarrow> (\<nexists>s S. (Fun (Val n) [], Fun (Set s) S) \<in> set D)"
by (simp add: to_abs_alt_def)

lemma to_abs_list_insert:
  assumes "Fun (Val n) [] \<noteq> t"
  shows "\<alpha>\<^sub>0 D n = \<alpha>\<^sub>0 (List.insert (t,s) D) n"
using assms to_abs_alt_def[of D n] to_abs_alt_def[of "List.insert (t,s) D" n]
by auto

lemma to_abs_list_insert':
  "insert s (\<alpha>\<^sub>0 D n) = \<alpha>\<^sub>0 (List.insert (Fun (Val n) [], Fun (Set s) S) D) n"
using to_abs_alt_def[of D n]
      to_abs_alt_def[of "List.insert (Fun (Val n) [], Fun (Set s) S) D" n]
by auto

lemma to_abs_list_remove_all:
  assumes "Fun (Val n) [] \<noteq> t"
  shows "\<alpha>\<^sub>0 D n = \<alpha>\<^sub>0 (List.removeAll (t,s) D) n"
using assms to_abs_alt_def[of D n] to_abs_alt_def[of "List.removeAll (t,s) D" n]
by auto

lemma to_abs_list_remove_all':
  "\<alpha>\<^sub>0 D n - {s} = \<alpha>\<^sub>0 (filter (\<lambda>d. \<nexists>S. d = (Fun (Val n) [], Fun (Set s) S)) D) n"
using to_abs_alt_def[of D n]
      to_abs_alt_def[of "filter (\<lambda>d. \<nexists>S. d = (Fun (Val n) [], Fun (Set s) S)) D" n]
by auto

lemma to_abs_db\<^sub>s\<^sub>s\<^sub>t_append:
  assumes "\<forall>u s. insert\<langle>u, s\<rangle> \<in> set B \<longrightarrow> Fun (Val n) [] \<noteq> u \<cdot> \<I>"
    and "\<forall>u s. delete\<langle>u, s\<rangle> \<in> set B \<longrightarrow> Fun (Val n) [] \<noteq> u \<cdot> \<I>"
  shows "\<alpha>\<^sub>0 (db'\<^sub>s\<^sub>s\<^sub>t A \<I> D) n = \<alpha>\<^sub>0 (db'\<^sub>s\<^sub>s\<^sub>t (A@B) \<I> D) n"
using assms
proof (induction B rule: List.rev_induct)
  case (snoc b B)
  hence IH: "\<alpha>\<^sub>0 (db'\<^sub>s\<^sub>s\<^sub>t A \<I> D) n = \<alpha>\<^sub>0 (db'\<^sub>s\<^sub>s\<^sub>t (A@B) \<I> D) n" by auto
  have *: "\<forall>u s. b = insert\<langle>u,s\<rangle> \<longrightarrow> Fun (Val n) [] \<noteq> u \<cdot> \<I>"
          "\<forall>u s. b = delete\<langle>u,s\<rangle> \<longrightarrow> Fun (Val n) [] \<noteq> u \<cdot> \<I>"
    using snoc.prems by simp_all
  show ?case
  proof (cases b)
    case (Insert u s)
    hence **: "db'\<^sub>s\<^sub>s\<^sub>t (A@B@[b]) \<I> D = List.insert (u \<cdot> \<I>,s \<cdot> \<I>) (db'\<^sub>s\<^sub>s\<^sub>t (A@B) \<I> D)"
      using db\<^sub>s\<^sub>s\<^sub>t_append[of "A@B" "[b]"] by simp
    have "Fun (Val n) [] \<noteq> u \<cdot> \<I>" using *(1) Insert by auto
    thus ?thesis using IH ** to_abs_list_insert by metis
  next
    case (Delete u s)
    hence **: "db'\<^sub>s\<^sub>s\<^sub>t (A@B@[b]) \<I> D = List.removeAll (u \<cdot> \<I>,s \<cdot> \<I>) (db'\<^sub>s\<^sub>s\<^sub>t (A@B) \<I> D)"
      using db\<^sub>s\<^sub>s\<^sub>t_append[of "A@B" "[b]"] by simp
    have "Fun (Val n) [] \<noteq> u \<cdot> \<I>" using *(2) Delete by auto
    thus ?thesis using IH ** to_abs_list_remove_all by metis
  qed (simp_all add: db\<^sub>s\<^sub>s\<^sub>t_no_upd_append[of "[b]" "A@B"] IH)
qed simp

lemma to_abs_neq_imp_db_update:
  assumes "\<alpha>\<^sub>0 (db\<^sub>s\<^sub>s\<^sub>t A I) n \<noteq> \<alpha>\<^sub>0 (db\<^sub>s\<^sub>s\<^sub>t (A@B) I) n"
  shows "\<exists>u s. u \<cdot> I = Fun (Val n) [] \<and> (insert\<langle>u,s\<rangle> \<in> set B \<or> delete\<langle>u,s\<rangle> \<in> set B)"
proof -
  { fix D have ?thesis when "\<alpha>\<^sub>0 D n \<noteq> \<alpha>\<^sub>0 (db'\<^sub>s\<^sub>s\<^sub>t B I D) n" using that
    proof (induction B I D rule: db'\<^sub>s\<^sub>s\<^sub>t.induct)
      case 2 thus ?case
        by (metis db'\<^sub>s\<^sub>s\<^sub>t.simps(2) list.set_intros(1,2) subst_apply_pair_pair to_abs_list_insert)
    next
      case 3 thus ?case
        by (metis db'\<^sub>s\<^sub>s\<^sub>t.simps(3) list.set_intros(1,2) subst_apply_pair_pair to_abs_list_remove_all)
    qed simp_all
  } thus ?thesis using assms by (metis db\<^sub>s\<^sub>s\<^sub>t_append db\<^sub>s\<^sub>s\<^sub>t_def)
qed

lemma abs_term_subst_eq:
  fixes \<delta> \<theta>::"(('a,'b,'c) prot_fun, ('d,'e prot_atom) term \<times> nat) subst"
  assumes "\<forall>x \<in> fv t. \<delta> x \<cdot>\<^sub>\<alpha> a = \<theta> x \<cdot>\<^sub>\<alpha> b"
    and "\<nexists>n T. Fun (Val n) T \<in> subterms t"
  shows "t \<cdot> \<delta> \<cdot>\<^sub>\<alpha> a = t \<cdot> \<theta> \<cdot>\<^sub>\<alpha> b"
using assms
proof (induction t)
  case (Fun f T) thus ?case
  proof (cases f)
    case (Val n)
    hence False using Fun.prems(2) by blast
    thus ?thesis by metis
  qed auto
qed simp

lemma abs_term_subst_eq':
  fixes \<delta> \<theta>::"(('a,'b,'c) prot_fun, ('d,'e prot_atom) term \<times> nat) subst"
  assumes "\<forall>x \<in> fv t. \<delta> x \<cdot>\<^sub>\<alpha> a = \<theta> x"
    and "\<nexists>n T. Fun (Val n) T \<in> subterms t"
  shows "t \<cdot> \<delta> \<cdot>\<^sub>\<alpha> a = t \<cdot> \<theta>"
using assms
proof (induction t)
  case (Fun f T) thus ?case
  proof (cases f)
    case (Val n)
    hence False using Fun.prems(2) by blast
    thus ?thesis by metis
  qed auto
qed simp

lemma abs_val_in_funs_term:
  assumes "f \<in> funs_term t" "is_Val f"
  shows "Abs (\<alpha> (the_Val f)) \<in> funs_term (t \<cdot>\<^sub>\<alpha> \<alpha>)"
using assms by (induct t \<alpha> rule: abs_apply_term.induct) auto

end


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

theory Noninterference_Base
imports "../../lib/Simulation"
begin

text {*
  Toby's extended noninterference definitions to handle dynamic assignment,
  that depends on the current state, of
  the domain that each action is assigned to. This is the gory details
  reported in the the CPP 2012 paper
  \emph{Noninterference for Operating System Kernels}.
*}

lemma un_eq:
  "\<lbrakk>S = S'; T = T'\<rbrakk> \<Longrightarrow> S \<union> T = S' \<union> T'"
  apply auto
  done

lemma Un_eq:
  "\<lbrakk>\<And> x y. \<lbrakk>x \<in> xs; y \<in> ys\<rbrakk> \<Longrightarrow> P x = Q y; \<exists> x. x \<in> xs; \<exists> y. y \<in> ys\<rbrakk> \<Longrightarrow> (\<Union>x\<in>xs. P x) = (\<Union>y\<in>ys. Q y)"
  apply auto
  done

lemma Int_eq:
  "\<lbrakk>\<And> x y. \<lbrakk>x \<in> xs; y \<in> ys\<rbrakk> \<Longrightarrow> P x = Q y; \<exists> x. x \<in> xs; \<exists> y. y \<in> ys\<rbrakk> \<Longrightarrow> (\<Inter>x\<in>xs. P x) = (\<Inter>y\<in>ys. Q y)"
  apply auto
  done

lemma Un_eq_Int:
  assumes ex: "\<exists> x. x \<in> xs"
  assumes ey: "\<exists> y. y \<in> ys"
  assumes a: "\<And> x y. \<lbrakk>x \<in> xs; y \<in> ys\<rbrakk> \<Longrightarrow> S x = S' y"
  shows "(\<Union>x\<in>xs. S x) = (\<Inter>x\<in>ys. S' x)"
  apply(rule equalityI)
   apply(clarsimp)
   apply(drule a, assumption, simp)
  apply clarsimp
  apply(insert ex ey)
  apply clarsimp
  apply(frule a, assumption)
  apply fastforce
  done

primrec Run :: "('e \<Rightarrow> ('s \<times> 's) set) \<Rightarrow> 'e list \<Rightarrow> ('s \<times> 's) set" where
  "Run Stepf []     = Id" |
  "Run Stepf (a#as) = Stepf a O Run Stepf as"

lemma Run_mid':
  shows
  "\<forall> s u bs. (s,u) \<in> Run Stepf (as @ bs)  \<longrightarrow> (\<exists> t. (s,t) \<in> Run Stepf as \<and> (t,u) \<in> Run Stepf bs)"
  proof(induct as)
  case Nil show ?case
   apply(clarsimp)
   done
  next
  case (Cons a as) show ?case
  apply(clarsimp simp: relcomp_def)
  apply(drule "Cons.hyps"[rule_format])
  apply fastforce
  done
qed

lemma Run_mid:
  "(s,u) \<in> Run Stepf (as @ bs) \<Longrightarrow> (\<exists> t. (s,t) \<in> Run Stepf as \<and> (t,u) \<in> Run Stepf bs)"
  apply(erule Run_mid'[rule_format])
  done

lemma Run_trans':
  "\<forall> s t u bs. (s,t) \<in> Run Stepf as \<and> (t,u) \<in> Run Stepf bs \<longrightarrow> (s,u) \<in> Run Stepf (as @ bs)"
  by (induct_tac as) auto

lemma Run_trans:
  "\<lbrakk>(s,t) \<in> Run Stepf as; (t,u) \<in> Run Stepf bs\<rbrakk> \<Longrightarrow> (s,u) \<in> Run Stepf (as @ bs)"
  by(blast intro: Run_trans'[rule_format])

lemma Run_app:
  "Run Stepf (as @ bs) = (Run Stepf as) O (Run Stepf bs)"
  apply(rule equalityI)
   apply(fastforce dest: Run_mid)
  apply(fastforce intro: Run_trans)
  done

(* An ADT with an initial state. *)
locale system =
  fixes A :: "('a,'s,'e) data_type"
  and s0 :: "'s"  (* an initial state *)

context system begin

(* State 's' is reachable from the initial state 's0'. *)
definition reachable where
  "reachable s \<equiv> \<exists> js. s \<in> execution A s0 js"

definition Step where
  "Step a \<equiv> {(s,s') . s' \<in> execution A s [a]}"

(* The system is "observationally deterministic": that is, the
 * observable part of the system is always deterministic. *)
definition obs_det where
  "obs_det \<equiv> \<forall> s js. (\<exists> s'. execution A s js = {s'})"

lemma obs_detD:
  "obs_det \<Longrightarrow> \<exists> s'. execution A s js = {s'}" by (simp add: obs_det_def)

(* The abstraction/concretisation functions "Init"/"Fin"
 * don't abstract away information. *)
definition no_abs where
  "no_abs \<equiv> \<forall> x s as . reachable s \<longrightarrow> x \<in> steps (Simulation.Step A) (Init A s) as \<longrightarrow>  Init A (Fin A x) = {x}"

lemma no_absD:
  "no_abs \<Longrightarrow> reachable s \<Longrightarrow> x \<in> steps (Simulation.Step A) (Init A s) as \<Longrightarrow> Init A (Fin A x) = {x}" by (auto simp: no_abs_def)

end

(*
 * A system that is always enabled.
 *
 * In particular, the system will never be in deadlock, and there
 * is always an enabled transition from every reachable state.
 *)
locale enabled_system = system +
  assumes enabled: "(\<exists> js. s \<in> execution A s0 js) \<Longrightarrow> \<exists> s'. s' \<in> execution A s js"

context enabled_system begin

lemma reachable_enabled:
  "reachable s \<Longrightarrow> \<exists> s'. s' \<in> execution A s js"
  apply(simp add: reachable_def)
  apply(erule enabled)
  done

lemma enabled_Step:
  "reachable s \<Longrightarrow> \<exists> s'. (s,s') \<in> Step a"
  apply(simp add: Step_def, blast intro: reachable_enabled)
  done

end

(* we define the unwinding conditions for systems for which a running
   a sequence of events is equivalent to performing a sequence of individual
   steps: one for each event in the sequence in turn  *)
locale Step_system = system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s"  +
  assumes reachable_s0: "reachable s0"
  assumes execution_Run: "reachable s \<Longrightarrow> execution A s as = {s'. (s,s') \<in> Run Step as}"

context Step_system begin

lemma execution_Run':
  "s \<in> execution A s0 js \<Longrightarrow> execution A s as = {s'. (s,s') \<in> Run Step as}"
  apply(rule execution_Run)
  apply(fastforce simp: reachable_def)
  done

lemma reachable_Run:
  "reachable s \<Longrightarrow> \<exists>as. (s0,s) \<in> Run Step as"
  apply (clarsimp simp add: reachable_def)
  apply (cut_tac as=js in execution_Run[OF reachable_s0])
  apply blast
  done

lemma Run_reachable:
  "\<exists>as. (s0,s) \<in> Run Step as \<Longrightarrow> reachable s"
  apply (clarsimp simp add: reachable_def)
  apply (cut_tac as=as in execution_Run[OF reachable_s0])
  apply blast
  done

lemma reachable_execution:
  "\<lbrakk>reachable s; s' \<in> execution A s js\<rbrakk> \<Longrightarrow> reachable s'"
  apply(clarsimp simp: reachable_def)
  apply(rule_tac x="jsa @ js" in exI)
  apply(frule execution_Run'[where s=s and as=js])
  apply(simp add: execution_Run[where s=s0, simplified reachable_s0])
  apply(fastforce simp: Run_app)
  done

lemma reachable_Step:
  "\<lbrakk>reachable s; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow> reachable s'"
  apply(erule reachable_execution)
  apply(simp add: Step_def)
  done

lemma reachable_induct_helper: assumes a:
      "\<And>s s' a.
             \<lbrakk>reachable s; P s;
              (s, s') \<in> Step a\<rbrakk>
             \<Longrightarrow> P s'"
       shows "\<lbrakk>(s0, s1) \<in> Run Step as; P s0\<rbrakk>
         \<Longrightarrow> P s1"
  apply (induct as arbitrary: s1 rule: rev_induct)
   apply simp
  apply(fastforce dest: Run_mid intro: a Run_reachable)
  done

lemma reachable_induct: "(\<And>s s' a. reachable s \<Longrightarrow> (s,s') \<in> (Step a) \<Longrightarrow> P s \<Longrightarrow> P s') \<Longrightarrow> reachable s1 \<Longrightarrow> P s0 \<Longrightarrow> P s1"
  apply (drule reachable_Run)
  apply (elim exE)
  apply (rule reachable_induct_helper)
    apply simp+
  done

end

locale Init_Fin_system = system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s"  +
  assumes reachable_s0: "reachable s0"
  assumes Fin_Init: "reachable s \<Longrightarrow> Fin A ` Init A s = {s}"
  assumes Init_Fin: "reachable s \<Longrightarrow> x \<in> steps (Simulation.Step A) (Init A s) as \<Longrightarrow>  x \<in> Init A (Fin A x)"
  assumes obs_det_or_no_abs: "obs_det \<or> no_abs"

context Init_Fin_system begin

lemma execution_subset_Run:
  "reachable s \<Longrightarrow> execution A s as \<subseteq> {s'. (s,s') \<in> Run Step as}"
  apply(induct as arbitrary: s rule: rev_induct)
   apply(simp add: execution_def steps_def Fin_Init)
  apply(simp add: execution_def steps_def)
  apply(rule subsetI)
  apply clarsimp
  apply(rule Run_trans)
   apply blast
  apply(cut_tac x=xc and s=s and as=xs in Init_Fin, (simp add: steps_def)+)
  apply(clarsimp simp: Step_def execution_def steps_def)
  apply blast
  done

lemma Run_subset_execution:
  "\<lbrakk>no_abs; reachable s\<rbrakk> \<Longrightarrow> {s'. (s,s') \<in> Run Step as} \<subseteq> execution A s as"
  apply(induct as arbitrary: s rule: rev_induct)
   apply(simp add: execution_def steps_def Fin_Init)
  apply(simp add: execution_def steps_def)
  apply(rule subsetI)
  apply clarsimp
  apply(drule Run_mid)
  apply clarsimp
  apply(drule_tac x=s in meta_spec)
  apply clarsimp
  apply(drule_tac subsetD)
   apply blast
  apply(clarsimp simp: Image_def image_def Step_def execution_def steps_def)
  apply(rule_tac x=xc in exI)
  apply clarsimp
  apply(rule_tac x=xd in bexI)
   apply assumption
  apply(drule_tac x=xb in no_absD)
    apply(simp add: steps_def Image_def)+
  done

lemma Run_det:
  "obs_det \<Longrightarrow> \<exists> s'. {s'. (s,s') \<in> Run Step as} = {s'}"
  apply(induct as arbitrary: s rule: rev_induct)
   apply simp
  apply(simp add: Run_app relcomp_def)
  apply(drule_tac x=s in meta_spec)
  apply clarsimp
  apply(drule_tac s=s' and js="[x]" in obs_detD)
  apply (clarsimp simp: Step_def)
  apply(rule_tac x="s'a" in exI)
  apply (auto dest: equalityD1)
  done

lemma eq:
  "\<lbrakk>S \<subseteq> T; \<exists> x. S = {x}; \<exists> y. T = {y}\<rbrakk> \<Longrightarrow> S = T"
  apply blast
  done

lemma execution_Run:
  "reachable s \<Longrightarrow> execution A s as = {s'. (s,s') \<in> Run Step as}"
  apply(rule disjE[OF obs_det_or_no_abs])
   apply(rule eq)
     apply(erule execution_subset_Run)
    apply(erule obs_detD)
   apply(erule Run_det)
  apply(rule equalityI)
   apply(erule execution_subset_Run)
  apply(erule (1) Run_subset_execution)
  done

end

lemma Init_Fin_system_Step_system:
  "Init_Fin_system A s0 \<Longrightarrow> Step_system A s0"
  apply(unfold_locales)
   apply(erule Init_Fin_system.reachable_s0)
  apply(erule (1) Init_Fin_system.execution_Run)
  done

sublocale Init_Fin_system \<subseteq> Step_system
  apply(rule Init_Fin_system_Step_system)
  apply(unfold_locales)
  done

(* when Init is the inverse image of Fin, the above assumptions are met by a system
   for which Fin is injective, or one that appears deterministic to an observer *)

locale Init_inv_Fin_system = system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s" +
  assumes Fin_Init_s0: "s0 \<in> Fin A ` Init A s0"
  assumes Init_inv_Fin: "reachable s \<Longrightarrow> Init A s = {s'. Fin A s' = s}"
  assumes Fin_inj: "inj (Fin A)"

context Init_inv_Fin_system begin

lemma s0_reachable:
  "reachable s0"
  apply(simp add: system.reachable_def)
  apply(rule_tac x="[]" in exI)
  apply(simp add: execution_def steps_def)
  apply(simp add: Fin_Init_s0)
  done

lemma foldl_foldl_Step:
  "\<lbrakk>x \<in> foldl (\<lambda>S j. data_type.Step A j `` S) M as;
   M \<subseteq> foldl (\<lambda>S j. data_type.Step A j `` S) B js\<rbrakk>
       \<Longrightarrow> x \<in> foldl (\<lambda>S j. data_type.Step A j `` S)
               (foldl (\<lambda>S j. data_type.Step A j `` S) B js) as"
  apply(induct  as arbitrary: x M js B rule: rev_induct)
   apply fastforce
  apply simp
  apply(erule ImageE)
  apply(drule_tac x=xb in meta_spec)
  apply(drule_tac x=M in meta_spec)
  apply simp
  apply(drule_tac x=js in meta_spec)
  apply(drule_tac x=B in meta_spec, simp)
  apply(blast)
  done

lemma reachable_Fin:
  "\<lbrakk>reachable s;
    x \<in> steps (Simulation.Step A) (Init A s) as\<rbrakk>
   \<Longrightarrow> reachable (Fin A x)"
  apply(cut_tac s=s in Init_inv_Fin, assumption)
  apply(clarsimp simp: reachable_def execution_def steps_def)
  apply(rule_tac x="js@as" in exI)
  apply(rule imageI)
  apply(subgoal_tac "{s'. Fin A s' = Fin A xa} = {xa}")
   apply simp
   apply(erule foldl_foldl_Step)
   apply blast
  apply(blast dest: injD[OF Fin_inj])
  done

end

lemma Init_inv_Fin_system_Init_Fin_system:
  "Init_inv_Fin_system A s0 \<Longrightarrow> Init_Fin_system A s0"
  apply(unfold_locales)
     apply(erule Init_inv_Fin_system.s0_reachable)
    apply(simp add: Init_inv_Fin_system.Init_inv_Fin)
    apply(simp add: image_def)
    apply(fastforce simp: system.reachable_def execution_def)
   apply(cut_tac s="Fin A x" in Init_inv_Fin_system.Init_inv_Fin)
     apply assumption
    apply(blast intro: Init_inv_Fin_system.reachable_Fin)
   apply simp
  apply(rule disjI2)
  apply(clarsimp simp: system.no_abs_def)
  apply(frule Init_inv_Fin_system.Fin_inj)
  apply(cut_tac s="Fin A x" in Init_inv_Fin_system.Init_inv_Fin)
    apply assumption
   apply(blast intro: Init_inv_Fin_system.reachable_Fin)
  apply simp
  apply(fastforce dest: injD)
  done

sublocale Init_inv_Fin_system \<subseteq> Init_Fin_system
  apply(rule Init_inv_Fin_system_Init_Fin_system)
  apply(unfold_locales)
  done

locale noninterference_policy =
  fixes dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"        (* dynamic dom assignment *)
  fixes uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
  fixes policy :: "('d \<times> 'd) set"     (* who can send info to whom *)
  fixes out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"        (* observable parts of d in state s *)
  fixes schedDomain :: "'d"
  assumes uwr_equiv_rel: "equiv UNIV (uwr u)"
  assumes schedIncludesCurrentDom:
    "(s,t) \<in> uwr schedDomain \<Longrightarrow> dom e s = dom e t"
  assumes schedFlowsToAll:
    "(schedDomain,d) \<in> policy"
  assumes schedNotGlobalChannel:
    "(x,schedDomain) \<in> policy \<Longrightarrow> x = schedDomain"

context noninterference_policy begin

abbreviation uwr2 :: "'s \<Rightarrow> 'd \<Rightarrow> 's \<Rightarrow> bool" ("(_/ \<sim>_\<sim>/ _)" [50,100,50] 1000)
where "s \<sim>u\<sim> t \<equiv> (s,t) \<in> uwr u"

abbreviation policy2 :: "'d \<Rightarrow> 'd \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"u \<leadsto> v \<equiv> (u,v) \<in> policy"

lemma uwr_refl:
  "s \<sim>(u::'d)\<sim> s"
  apply(cut_tac u=u in uwr_equiv_rel)
  apply(clarsimp simp: equiv_def)
  apply(blast dest: refl_onD)
  done

lemma uwr_sym:
  "x \<sim>(u::'d)\<sim> y \<Longrightarrow> y \<sim>u\<sim> x"
  apply(cut_tac u=u in uwr_equiv_rel)
  apply(clarsimp simp: equiv_def)
  apply(blast dest: symD)
  done

lemma uwr_trans:
  "\<lbrakk>x \<sim>(u::'d)\<sim> y; y \<sim>u\<sim> z\<rbrakk> \<Longrightarrow> x \<sim>u\<sim> z"
  apply(cut_tac u=u in uwr_equiv_rel)
  apply(clarsimp simp: equiv_def)
  apply(blast dest: transD)
  done

definition sameFor_dom :: "'s \<Rightarrow> 'd set \<Rightarrow> 's \<Rightarrow> bool"  ("(_/ \<approx>_\<approx>/ _)" [50,100,50] 1000) where
 "s \<approx>us\<approx> t \<equiv> \<forall>u\<in>us. (s,t) \<in> uwr u"

lemma sameFor_subset_dom: "\<lbrakk>s \<approx>(x::'d set)\<approx> t; y \<subseteq> x\<rbrakk> \<Longrightarrow> s \<approx>y\<approx> t"
  by(fastforce simp: sameFor_dom_def)

lemma sameFor_inter_domI: "s \<approx>(S::'d set)\<approx> t \<Longrightarrow> s \<approx>(S \<inter> B)\<approx> t"
  by(auto simp: sameFor_dom_def)

lemma sameFor_sym_dom:
  "s \<approx>(S::'d set)\<approx> t \<Longrightarrow> t \<approx>S\<approx> s"
  by(auto simp: sameFor_dom_def uwr_sym)

end

locale noninterference_system = enabled_system A s0 + noninterference_policy dom uwr policy out schedDomain
  for A :: "('a,'s,'e) data_type"
  and s0 :: "'s"
  and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
  and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
  and policy :: "('d \<times> 'd) set"
  and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
  and schedDomain :: "'d"

context noninterference_system begin

(* The set of domains (which carry out actions in the list "as") which
 * may influence "u", assuming we start in state "s". *)
primrec
 sources :: "'e list \<Rightarrow> 's \<Rightarrow> 'd \<Rightarrow> 'd set" where
 sources_Nil: "sources [] s u = {u}"|
 sources_Cons: "sources (a#as) s u = (\<Union>{sources as s' u| s'. (s,s') \<in> Step a}) \<union>
      {w. w = dom a s \<and> (\<exists> v s'. dom a s \<leadsto> v \<and> (s,s') \<in> Step a \<and> v \<in> sources as s' u)}"

declare sources_Nil [simp del]
declare sources_Cons [simp del]

definition
  obs_equiv :: "'s \<Rightarrow> 'e list \<Rightarrow> 's \<Rightarrow> 'e list \<Rightarrow> 'd \<Rightarrow> bool"
where
  "obs_equiv s as t bs d \<equiv> \<forall> s' t'. s' \<in> execution A s as \<and> t' \<in> execution A t bs \<longrightarrow>
                out d s' = out d t'"

definition
  uwr_equiv :: "'s \<Rightarrow> 'e list \<Rightarrow> 's \<Rightarrow> 'e list \<Rightarrow> 'd \<Rightarrow> bool"
where
  "uwr_equiv s as t bs d \<equiv> \<forall> s' t'. s' \<in> execution A s as \<and> t' \<in> execution A t bs \<longrightarrow>
                s' \<sim>d\<sim> t'"

text {* Nonleakage *}
definition
  Nonleakage :: "bool" where
  "Nonleakage \<equiv> \<forall>as s u t. reachable s \<and> reachable t \<longrightarrow>
     s \<sim>schedDomain\<sim> t \<longrightarrow>
     s \<approx>(sources as s u)\<approx> t \<longrightarrow> obs_equiv s as t as u"

text {* A generalisation of Nonleakage. *}
definition Nonleakage_gen :: "bool" where
  "Nonleakage_gen \<equiv> \<forall>as s u t. reachable s \<and> reachable t \<longrightarrow>
     s \<sim>schedDomain\<sim> t \<longrightarrow>
       s \<approx>(sources as s u)\<approx> t \<longrightarrow> uwr_equiv s as t as u"

lemma uwr_equiv_sym:
  "uwr_equiv s as t bs u \<Longrightarrow> uwr_equiv t bs s as u"
  apply(fastforce simp: uwr_equiv_def uwr_sym)
  done

lemma uwr_equiv_trans:
  "\<lbrakk>reachable t; uwr_equiv s as t bs x; uwr_equiv t bs u cs x\<rbrakk> \<Longrightarrow> uwr_equiv s as u cs x"
  apply(clarsimp simp: uwr_equiv_def)
  apply(cut_tac s=t and js=bs in reachable_enabled)
   apply assumption
  apply(blast intro: uwr_trans)
  done

primrec gen_purge :: "('e list \<Rightarrow> 's \<Rightarrow> 'd \<Rightarrow> 'd set) \<Rightarrow> 'd \<Rightarrow> 'e list \<Rightarrow> 's set \<Rightarrow> 'e list"
where
  Nil : "gen_purge sf u []     ss = []" |
  Cons: "gen_purge sf u (a#as) ss =
            (if (\<exists>s\<in>ss. dom a s \<in> sf (a#as) s u) then
               a#gen_purge sf u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
             else
               gen_purge sf u as ss)"

definition ipurge where
 "ipurge \<equiv> gen_purge sources"

lemma ipurge_Nil:
  "ipurge u [] ss = []"
  by(auto simp: ipurge_def)

lemma ipurge_Cons:
  "ipurge u (a#as) ss =
     (if (\<exists> s\<in>ss. dom a s \<in> sources (a#as) s u) then
         a#ipurge u as (\<Union>s\<in>ss. {s'. (s,s') \<in> Step a})
      else
         ipurge u as ss)"
  by (auto simp: ipurge_def)

lemma gen_purge_shortens:
  "length (gen_purge sf u as ss) \<le> length as"
  apply(induct as arbitrary: ss)
   apply(simp)
  apply(clarsimp)
  apply(rule le_trans)
   apply assumption
  apply simp
  done

lemma INT_cong':
  assumes a: "\<And> x. Q x \<Longrightarrow> P x = P' x"
  shows
  "\<Inter>{P x|x. Q x} = \<Inter>{P' x|x. Q x}"
  apply (auto simp: a)
  done

text {* Standard Noninterfernce *}

definition
  Noninterference :: "bool" where
 "Noninterference \<equiv>
  \<forall> u as s. reachable s \<longrightarrow>
         (obs_equiv s as s (ipurge u as {s}) u)"

text {* Strong Noninterference *}
definition
  Noninterference_strong :: "bool" where
 "Noninterference_strong \<equiv>
  \<forall> u as bs s. reachable s \<longrightarrow>
         (ipurge u as {s}) = (ipurge u bs {s}) \<longrightarrow>
         (obs_equiv s as s bs u)"

lemma obs_equiv_sym:
  "obs_equiv s as t bs u \<Longrightarrow> obs_equiv t bs s as u"
  apply(clarsimp simp: obs_equiv_def)
  done

lemma obs_equiv_trans:
  "\<lbrakk>reachable t; obs_equiv s as t bs u; obs_equiv t bs x cs u\<rbrakk> \<Longrightarrow> obs_equiv s as x cs u"
  apply(clarsimp simp: obs_equiv_def)
  apply(cut_tac s=t and js=bs in reachable_enabled, assumption, blast)
  done

lemma Noninterference_Noninterference_strong:
  "\<lbrakk>Noninterference\<rbrakk> \<Longrightarrow> Noninterference_strong
"
  apply(clarsimp simp: Noninterference_def Noninterference_strong_def)
  apply(drule_tac x=u in spec)
  apply(frule_tac x=as in spec, drule_tac x=s in spec)
  apply(drule_tac x=bs in spec, drule_tac x=s in spec)
  apply clarsimp
  apply(rule obs_equiv_trans)
    apply assumption
   apply assumption
  apply(erule obs_equiv_sym)
  done

text {* Noninfluence -- the combination of Noninterference and
   Nonleakage.

   We add the assumption about equivalence wrt the scheduler's domain, as
   is common in e.g. GVW.*}
definition
  Noninfluence  :: "bool" where
 "Noninfluence \<equiv>
  \<forall> u as s t. reachable s \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         obs_equiv s as t (ipurge u as {t}) u"

definition
  Noninfluence_strong  :: "bool" where
 "Noninfluence_strong \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurge u as {s} = ipurge u bs {s} \<longrightarrow>
         obs_equiv s as t bs u"

lemma notin_policyI:
  "\<lbrakk>dom a s \<notin> sources (a # list) s u; \<exists> s'. (s,s') \<in> Step a \<and> ua \<in> sources list s' u\<rbrakk> \<Longrightarrow>
   (dom a s,ua) \<notin> policy"
  apply(clarsimp simp: sources_Cons)
  done

lemma Noninfluence_strong_Noninterference_strong:
  "Noninfluence_strong \<Longrightarrow> Noninterference_strong"
  apply(clarsimp simp: Noninfluence_strong_def Noninterference_strong_def)
  apply(drule_tac x=u in spec, drule_tac x=as in spec, drule_tac x=bs in spec)
  apply(fastforce simp: sameFor_dom_def uwr_refl)
  done

lemma Noninfluence_strong_Nonleakage:
  "Noninfluence_strong \<Longrightarrow> Nonleakage"
  apply(clarsimp simp: Noninfluence_strong_def Nonleakage_def)
  done

text {* This stronger condition is needed
   to make the induction proof work for Noninterference. It can be viewed
   as a generalisation of Noninfluence; hence its name here.
*}
definition
  Noninfluence_gen :: "bool" where
 "Noninfluence_gen \<equiv>
  \<forall> u as s ts. reachable s \<and> (\<forall> t \<in> ts. reachable t) \<longrightarrow>
      (\<forall>t \<in> ts. s \<approx>(sources as s u)\<approx> t) \<longrightarrow>  (\<forall>t \<in> ts. s \<sim>schedDomain\<sim> t) \<longrightarrow>
         (\<forall>t \<in> ts. uwr_equiv s as t (ipurge u as ts) u)"

definition
  Noninfluence_uwr  :: "bool" where
 "Noninfluence_uwr \<equiv>
  \<forall> u as s t. reachable s \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         uwr_equiv s as t (ipurge u as {t}) u"

definition
  Noninfluence_strong_uwr :: "bool" where
 "Noninfluence_strong_uwr \<equiv>
  \<forall> u as bs s t. reachable s  \<and> reachable t \<longrightarrow>
      s \<approx>(sources as s u)\<approx> t \<longrightarrow>  s \<sim>schedDomain\<sim> t \<longrightarrow>
         ipurge u as {s} = ipurge u bs {s} \<longrightarrow>
         uwr_equiv s as t bs u"

definition output_consistent :: "bool" where
  "output_consistent \<equiv> \<forall> u s s'. s \<sim>u\<sim> s'  \<longrightarrow> (out u s = out u s')"

definition confidentiality_u :: "bool" where
  "confidentiality_u \<equiv> \<forall> a u s t.  reachable s \<and> reachable t \<longrightarrow>
    s \<sim>schedDomain\<sim> t \<longrightarrow>
    ((dom a s \<leadsto> u) \<longrightarrow> s \<sim>dom a s\<sim> t) \<longrightarrow>
      s \<sim>u\<sim> t \<longrightarrow>
      (\<forall> s' t'. (s,s') \<in> Step a \<and> (t,t') \<in> Step a \<longrightarrow>
        s' \<sim>u\<sim> t')"

lemma no_domain_visible_nondeterminism:
  "\<lbrakk>confidentiality_u; reachable s; (s,s') \<in> Step a; (s,s'') \<in> Step a\<rbrakk> \<Longrightarrow> s' \<sim>d\<sim> s''"
  apply(clarsimp simp: confidentiality_u_def)
  apply(fastforce intro: uwr_refl)
  done

definition integrity_u :: "bool" where
  "integrity_u \<equiv> \<forall> a u s. reachable  s \<longrightarrow>
   (dom a s,u) \<notin> policy  \<longrightarrow>
   (\<forall> s'. (s,s') \<in> Step a \<longrightarrow> s \<sim>u\<sim> s')"

(*<*)
(* integrity_u actually guarantees this (seemingly) stronger condition *)
definition integrity_u_more :: "bool" where
  "integrity_u_more \<equiv> \<forall> a u s. reachable s \<longrightarrow>
   (dom a s,u) \<notin> policy \<longrightarrow>
   (\<forall> s' t. s \<sim>u\<sim> t \<and> (s,s') \<in> Step a \<longrightarrow> s' \<sim>u\<sim> t)"

lemma integrity_u_more:
  "integrity_u \<Longrightarrow> integrity_u_more"
  apply(clarsimp simp: integrity_u_more_def integrity_u_def)
  apply(blast dest: uwr_sym uwr_trans)
  done
(*>*)

lemma integrity_uD:
  "\<lbrakk>integrity_u; reachable s; (dom a s,u) \<notin> policy;
    s \<sim>u\<sim> t; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow>
   s' \<sim>u\<sim> t"
  apply(drule integrity_u_more)
  apply(simp add: integrity_u_more_def)
  done

text {*
  A weaker version of @{prop confidentiality_u} that, with
  @{prop integrity_u}, implies it.
*}
definition confidentiality_u_weak where
  "confidentiality_u_weak \<equiv> \<forall> a u s t.  reachable s \<and> reachable t \<longrightarrow>
    s \<sim>schedDomain\<sim> t \<longrightarrow> dom a s \<leadsto> u \<longrightarrow> s \<sim>(dom a s)\<sim> t \<longrightarrow>
      s \<sim>u\<sim> t \<longrightarrow>
        (\<forall> s' t'. (s,s') \<in> Step a \<and> (t,t') \<in> Step a \<longrightarrow> s' \<sim>u\<sim> t')"

lemma confidentiality_u_confidentiality_u_weak:
  "confidentiality_u \<Longrightarrow> confidentiality_u_weak"
  apply (simp add: confidentiality_u_def confidentiality_u_weak_def)
  apply blast
  done

lemma impCE':
  "\<lbrakk>P \<longrightarrow> Q; \<lbrakk>P; Q\<rbrakk> \<Longrightarrow> R; \<not> P \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  apply auto
  done

lemma confidentiality_u_weak:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
  confidentiality_u"
  apply(clarsimp simp: confidentiality_u_def)
  apply(erule impCE')
   apply(subst (asm) confidentiality_u_weak_def, blast)
  apply(frule integrity_uD, simp+)
  apply(drule_tac s=t and t="s'" in integrity_uD)
      apply assumption
     apply(drule_tac e=a in schedIncludesCurrentDom)
     apply simp
    apply(blast intro: uwr_sym)
   apply assumption
  apply(erule uwr_sym)
  done

lemma obs_equivI:
  "\<lbrakk>output_consistent; uwr_equiv s as t bs ob\<rbrakk> \<Longrightarrow> obs_equiv s as t bs ob"
  apply(clarsimp simp: obs_equiv_def)
  apply(auto simp: uwr_equiv_def output_consistent_def)
  done

lemma Noninfluence_uwr_Noninfluence:
  "\<lbrakk>output_consistent; Noninfluence_uwr\<rbrakk> \<Longrightarrow> Noninfluence"
  apply(clarsimp simp: Noninfluence_def)
  apply(erule obs_equivI)
  apply(auto simp: Noninfluence_uwr_def)
  done

lemma Noninfluence_strong_uwr_Noninfluence_strong:
  "\<lbrakk>output_consistent; Noninfluence_strong_uwr\<rbrakk> \<Longrightarrow> Noninfluence_strong"
  apply(clarsimp simp: Noninfluence_strong_def)
  apply(erule obs_equivI)
  apply(auto simp: Noninfluence_strong_uwr_def)
  done

lemma sched_equiv_preserved:
  "\<lbrakk>confidentiality_u;  reachable s; reachable t;
   s \<sim>schedDomain\<sim> t; (s,s') \<in> Step a; (t,t') \<in> Step a\<rbrakk> \<Longrightarrow>
   s' \<sim>schedDomain\<sim> t'"
  apply(case_tac "dom a s = schedDomain")
   apply(subst (asm) confidentiality_u_def)
   apply(drule_tac x=a in spec)
   apply(drule_tac x=schedDomain in spec)
   apply(drule_tac x=s in spec)
   apply(drule_tac x=t in spec)
   apply simp
  apply(subst (asm) confidentiality_u_def)
  apply(blast intro: schedNotGlobalChannel)
  done

lemma sched_equiv_preserved_left:
  "\<lbrakk>integrity_u; s \<sim>schedDomain\<sim> t;
    dom a s \<noteq> schedDomain; (s,s') \<in> Step a; reachable s\<rbrakk> \<Longrightarrow>
    s' \<sim>schedDomain\<sim> t"
  apply(blast intro: integrity_uD schedNotGlobalChannel)
  done

lemma Noninfluence_gen_Noninterference:
  "\<lbrakk>output_consistent; Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninterference"
  apply(clarsimp simp: Noninterference_def Noninfluence_gen_def)
  apply(erule_tac x=u in allE)
  apply(erule_tac x=as in allE)
  apply(erule_tac x=s in allE)
  apply(erule_tac x="{s}" in allE)
  apply(clarsimp simp: sameFor_dom_def uwr_refl)
  apply(blast intro: obs_equivI)
  done

lemma Noninfluence_gen_Noninfluence:
  "\<lbrakk>output_consistent; Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninfluence"
  apply(clarsimp simp: Noninfluence_def Noninfluence_gen_def)
  apply(erule_tac x=u in allE)
  apply(erule_tac x=as in allE)
  apply(erule_tac x=s in allE)
  apply(erule_tac x="{t}" in allE)
  apply(blast intro: obs_equivI)
  done

lemma Noninfluence_gen_Noninfluence_uwr:
  "\<lbrakk>Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninfluence_uwr"
  apply(clarsimp simp: Noninfluence_uwr_def Noninfluence_gen_def)
  done

lemma Noninfluence_gen_Noninterference_strong:
  "\<lbrakk>output_consistent; Noninfluence_gen\<rbrakk> \<Longrightarrow> Noninterference_strong"
  apply(rule Noninterference_Noninterference_strong)
  apply(blast intro: Noninfluence_gen_Noninterference)
  done

end

locale enabled_Step_system = enabled_system A s0 + Step_system A s0
  for A :: "('a,'s,'e) data_type" and s0 :: "'s"

(* we define the unwinding conditions for any system *)
locale unwinding_system = enabled_Step_system A s0 +  noninterference_policy dom uwr policy out schedDomain
  for A :: "('a,'s,'e) data_type"
  and s0 :: "'s"
  and dom :: "'e \<Rightarrow> 's \<Rightarrow> 'd"
  and uwr :: "'d \<Rightarrow> ('s \<times> 's) set"
  and policy :: "('d \<times> 'd) set"
  and out :: "'d \<Rightarrow> 's \<Rightarrow> 'p"
  and schedDomain :: "'d"

sublocale unwinding_system \<subseteq> noninterference_system
  apply(unfold_locales)
  done

context unwinding_system begin

lemma sources_refl:
  "reachable s \<Longrightarrow> u \<in> sources as s u"
  apply(induct as arbitrary: s)
   apply(simp add: sources_Nil)
  apply(simp add: sources_Cons)
  apply(frule_tac a=a in enabled_Step)
  apply (auto simp: reachable_Step)
  done

lemma schedDomain_in_sources_Cons:
  "reachable s \<Longrightarrow> dom a s = schedDomain \<Longrightarrow> dom a s \<in> sources (a#as) s u"
  apply(unfold sources_Cons)
  apply(erule ssubst)
  apply(rule UnI2)
  apply(clarsimp)
  apply(rule_tac x=u in exI)
  apply(safe)
   apply(rule schedFlowsToAll)
  apply(frule_tac a=a in enabled_Step)
  apply(fastforce dest: sources_refl reachable_Step)
  done

lemma sources_eq':
  "confidentiality_u \<and> s \<sim>schedDomain\<sim> t \<and> reachable s \<and> reachable t \<longrightarrow> sources as s u = sources as t u"
  proof (induct as arbitrary: s t)
  case Nil show ?case
   apply(simp add: sources_Nil)
   done
  next
  case (Cons a as) show ?case
  apply(clarsimp simp: sources_Cons)
  apply(rule un_eq)
   apply(simp only: Union_eq, simp only: UNION_eq[symmetric])
   apply(rule Un_eq, clarsimp)
     apply(metis "Cons.hyps"[rule_format] sched_equiv_preserved reachable_Step)
    apply(fastforce intro: enabled_Step)
   apply(fastforce intro: enabled_Step)
  apply(clarsimp simp: schedIncludesCurrentDom)
  apply(rule Collect_cong)
  apply(rule conj_cong, rule refl)
  apply(rule iff_exI)
  apply(metis "Cons.hyps"[rule_format] sched_equiv_preserved reachable_Step enabled_Step)
  done
  qed

lemma sources_eq:
  "\<lbrakk>confidentiality_u; s \<sim>schedDomain\<sim> t; reachable s; reachable t\<rbrakk> \<Longrightarrow>
  sources as s u = sources as t u"
  apply(rule sources_eq'[rule_format], simp)
  done

lemma sameFor_sources_dom:
  "\<lbrakk>s \<approx>(sources (a#as) s u)\<approx> t; dom a s \<leadsto> x; x \<in> sources as s' u; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow>
   s \<sim>(dom a s)\<sim> t"
  apply(simp add: sameFor_dom_def)
  apply(erule bspec)
  apply(subst sources_Cons)
  apply(rule UnI2)
  apply blast
  done

lemma sources_unwinding_step:
  "\<lbrakk>s \<approx>(sources (a#as) s u)\<approx> t; s \<sim>schedDomain\<sim> t; confidentiality_u;
    (s,s') \<in> Step a; (t,t') \<in> Step a; reachable s; reachable t\<rbrakk>  \<Longrightarrow>
    s' \<approx>(sources as s' u)\<approx> t'"
  apply(clarsimp simp: sameFor_dom_def sources_Cons)
  apply(subst (asm) confidentiality_u_def)
  apply(drule_tac x=a in spec)
  apply(drule_tac x=ua in spec)
  apply(drule_tac x=s in spec)
  apply(drule_tac x=t in spec)
  apply(fastforce intro: sameFor_sources_dom)
  done

lemma ipurge_eq'_helper:
  "\<lbrakk>s \<in> ss; dom a s \<in> sources (a # as) s u; \<forall>s\<in>ts. dom a s \<notin> sources (a # as) s u;
   (\<forall>s t. s \<in> ss \<and> t \<in> ts \<longrightarrow> s \<sim>schedDomain\<sim> t \<and> reachable s \<and> reachable t);  t \<in> ts; confidentiality_u\<rbrakk> \<Longrightarrow>
  False"
  apply(cut_tac s=s and t=t and as=as and u=u in sources_eq, simp+)
  apply(clarsimp  simp: sources_Cons | safe)+
  apply(rename_tac s')
   apply(drule_tac x=t in bspec, simp)
   apply clarsimp
   apply(cut_tac s=t in enabled_Step, simp)
   apply(erule exE, rename_tac t')
   apply(drule_tac x="sources as t' u" in spec)
   apply(cut_tac s=s' and t=t' and u=u in sources_eq, simp+)
      apply(fastforce elim: sched_equiv_preserved)
     apply(fastforce intro: reachable_Step)
    apply(fastforce intro: reachable_Step)
   apply(fastforce simp: schedIncludesCurrentDom)
  apply(drule_tac x=t in bspec, simp)
  apply clarsimp
  apply(rename_tac v s')
  apply(drule_tac x=v in spec, erule impE, fastforce simp: schedIncludesCurrentDom)
  apply(cut_tac s=t in enabled_Step[where a=a], simp, clarsimp, rename_tac t')
  apply(cut_tac s=s' and t=t' and u=u in sources_eq, simp+)
     apply(fastforce elim: sched_equiv_preserved)
    apply(fastforce intro: reachable_Step)
   apply(fastforce intro: reachable_Step)
  apply(fastforce simp: schedIncludesCurrentDom)
  done

lemma ipurge_eq':
  "(\<forall> s t. s\<in>ss \<and> t\<in>ts \<longrightarrow> s \<sim>schedDomain\<sim> t \<and> reachable s \<and> reachable t) \<and> (\<exists> s. s \<in> ss) \<and> (\<exists> t. t \<in> ts) \<and> confidentiality_u \<longrightarrow> ipurge u as ss = ipurge u as ts"
  proof (induct as arbitrary: ss ts)
  case Nil show ?case
   apply(simp add: ipurge_def)
   done
  next
  case (Cons a as) show ?case
   apply(clarsimp simp: ipurge_Cons schedIncludesCurrentDom)
   apply(intro conjI impI)
      apply(rule "Cons.hyps"[rule_format])
      apply clarsimp
      apply(metis sched_equiv_preserved reachable_Step enabled_Step)
     apply clarsimp
     apply(drule ipurge_eq'_helper, simp+)[1]
    apply clarsimp
    apply(drule ipurge_eq'_helper, (simp add: uwr_sym)+)[1]
   apply(rule "Cons.hyps"[rule_format], auto)
   done
  qed

lemma ipurge_eq:
  "\<lbrakk>s \<sim>schedDomain\<sim> t; reachable s; reachable t;
    confidentiality_u\<rbrakk> \<Longrightarrow>
   ipurge u as {s} = ipurge u as {t}"
  apply(rule ipurge_eq'[rule_format], simp)
  done

lemma Noninfluence_uwr_Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u; Noninfluence_uwr\<rbrakk> \<Longrightarrow> Noninfluence_strong_uwr"
  apply(clarsimp simp: Noninfluence_uwr_def Noninfluence_strong_uwr_def)
  apply(frule_tac s=s and t=t and as=as and u=u in ipurge_eq)
     apply assumption+
  apply(frule_tac s=s and t=t and as=bs and u=u in ipurge_eq)
     apply assumption+
  apply clarsimp
  apply(drule_tac x=u in spec)
  apply(frule_tac x=as in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(drule_tac x=bs in spec)
  apply(drule_tac x=t in spec, drule_tac x=t in spec)
  apply clarsimp
  apply(rule_tac t=t in uwr_equiv_trans)
    apply assumption
   apply assumption
  apply(rule uwr_equiv_sym)
  apply(clarsimp simp: sameFor_dom_def uwr_refl)
  done

lemma Noninfluence_Noninfluence_strong:
  "\<lbrakk>confidentiality_u; Noninfluence\<rbrakk> \<Longrightarrow> Noninfluence_strong"
  apply(clarsimp simp: Noninfluence_def Noninfluence_strong_def)
  apply(frule_tac s=s and t=t and as=as and u=u in ipurge_eq)
     apply assumption+
  apply(frule_tac s=s and t=t and as=bs and u=u in ipurge_eq)
     apply assumption+
  apply clarsimp
  apply(drule_tac x=u in spec)
  apply(frule_tac x=as in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(drule_tac x=bs in spec)
  apply(drule_tac x=t in spec, drule_tac x=t in spec)
  apply clarsimp
  apply(rule_tac t=t in obs_equiv_trans)
    apply assumption
   apply assumption
  apply(rule obs_equiv_sym)
  apply(clarsimp simp: sameFor_dom_def uwr_refl)
  done

lemma dom_in_sources_Cons:
  "\<lbrakk>confidentiality_u; reachable s; reachable t;
    s \<approx>(sources (a#as) s u)\<approx> t; s \<sim>schedDomain\<sim> t;
    (dom a s \<in> sources (a#as) s u)\<rbrakk> \<Longrightarrow>
    (dom a t \<in> sources (a#as) t u)"
  apply(subgoal_tac "dom a s = dom a t")
   apply(fastforce dest: sources_eq)
  apply(blast intro: schedIncludesCurrentDom)
  done

lemma uwr_equiv_Cons_bothI:
   "\<lbrakk>reachable s; reachable t;
     \<forall> s' t'. (s,s') \<in> Step a \<and> (t,t') \<in> Step b \<longrightarrow> uwr_equiv s' as t' bs u\<rbrakk> \<Longrightarrow>
    uwr_equiv s (a # as) t (b # bs) u"
  apply(clarsimp simp: uwr_equiv_def)
  apply(clarsimp simp: execution_Run)
  apply(fastforce simp: execution_Run reachable_Step)
  done

lemma uwr_equiv_Cons_leftI:
   "\<lbrakk>reachable s; \<forall> s'. (s,s') \<in> Step a \<longrightarrow> uwr_equiv s' as t bs u\<rbrakk> \<Longrightarrow>
    uwr_equiv s (a # as) t bs u"
  apply(fastforce simp: uwr_equiv_def execution_Run reachable_Step)
  done

lemma notin_policyI':
  "\<lbrakk>reachable s;
    dom a s \<notin> sources (a # list) s u; (s,s') \<in> Step a; ua \<in> sources list s' u\<rbrakk> \<Longrightarrow>
   (dom a s,ua) \<notin> policy"
  apply(rule notin_policyI)
  apply auto
  done

lemma sources_eq_Step:
  "\<lbrakk>integrity_u; confidentiality_u; reachable s; (s,s') \<in> Step a; dom a s \<noteq> schedDomain\<rbrakk> \<Longrightarrow>
   (sources as s' u) = (sources as s u)"
  apply(rule sources_eq, simp+)
    apply(rule_tac t=s and s=s and a=a in sched_equiv_preserved_left, (simp add: uwr_refl reachable_Step)+)
  done

lemma sources_equiv_preserved_left:
  "\<lbrakk>integrity_u; confidentiality_u; reachable s; reachable t; s \<sim>schedDomain\<sim> t;
    dom a s \<notin> sources (a#as) s u; s \<approx>sources (a#as) s u\<approx> t; (s,s') \<in> Step a; dom a s \<noteq> schedDomain\<rbrakk> \<Longrightarrow>
   s' \<approx>sources as s' u\<approx> t"
  apply(clarsimp simp: sameFor_dom_def)
  apply(rename_tac v)
  apply(case_tac "(dom a s, v) \<in> policy")
   apply(fastforce simp: sources_Cons)
  apply(fastforce dest: integrity_uD simp: sources_Cons)
  done

lemma Noninfluence_gen:
  "\<lbrakk>confidentiality_u; integrity_u\<rbrakk> \<Longrightarrow> Noninfluence_gen"
  apply(subst Noninfluence_gen_def)
  apply(intro allI)
  proof -
  assume conf: "confidentiality_u"
  assume integ: "integrity_u"
  fix u as s ts
  show "reachable s \<and> Ball ts reachable \<longrightarrow>
          Ball ts (sameFor_dom s (sources as s u)) \<longrightarrow> (\<forall>t\<in>ts. s \<sim>schedDomain\<sim> t) \<longrightarrow> (\<forall>t\<in>ts. uwr_equiv s as t (ipurge u as ts) u)"
    proof(induct as arbitrary: s ts)
    case Nil
    show ?case
      apply(clarsimp simp: sameFor_dom_def ipurge_Nil sources_Nil uwr_equiv_def)
      apply(clarsimp simp: execution_Run)
      done
    next
    case (Cons a as)
    show ?case
  apply(clarsimp simp: ipurge_Cons | safe)+
   apply(rule uwr_equiv_Cons_bothI)
     apply assumption
    apply blast
   apply(clarify)
   apply(rename_tac ta tb s' tb')
   apply(rule Cons.hyps[rule_format])
      apply(blast intro: reachable_Step)
     apply(clarsimp)
     apply(rename_tac tc' tc)
     using conf apply(rule_tac s=s and t=tc and a=a in sources_unwinding_step, simp+)[1]
    apply(clarsimp, rename_tac tc' tc)
    apply(rule sched_equiv_preserved[OF conf], (auto simp: sources_refl))[1]
   apply blast
  apply(rename_tac ta)
  apply(rule uwr_equiv_Cons_leftI, blast)
  apply(clarsimp, rename_tac s')
  apply(case_tac "dom a s = schedDomain")
   apply(cut_tac s=s and a=a and as=as and u=u in schedDomain_in_sources_Cons, assumption+)
   apply(metis schedIncludesCurrentDom sources_eq[OF conf])
  apply(rule Cons.hyps[rule_format])
     apply(blast intro: reachable_Step)
    apply(rename_tac tb)
    apply(rule_tac a=a in sources_equiv_preserved_left[OF integ conf], simp+)
       apply(fastforce simp: schedIncludesCurrentDom sources_eq[OF conf])
      apply blast
     apply assumption
    apply assumption
   apply(rule_tac s=s and a=a in sched_equiv_preserved_left[OF integ], simp+)
  done
  qed
  qed

lemma Nonleakage_gen:
  "\<lbrakk>confidentiality_u\<rbrakk> \<Longrightarrow> Nonleakage_gen"
  apply(subst Nonleakage_gen_def)
  apply(rule allI)
  apply(induct_tac as)
   apply(simp add: sources_Nil uwr_equiv_def execution_Run sameFor_dom_def)
  apply(clarsimp)
  apply(rule uwr_equiv_Cons_bothI)
    apply assumption
   apply assumption
  apply clarsimp
  apply(drule_tac x=s' in spec, drule_tac x=u in spec, drule_tac x=t' in spec)
  apply(clarsimp simp: reachable_Step)
  apply(erule impE)
   apply(blast intro: sched_equiv_preserved)
  apply(erule mp)
  apply(blast intro: sources_unwinding_step)
  done

lemma Noninterference:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninterference"
  apply(rule Noninfluence_gen_Noninterference)
   apply assumption
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninterference_strong:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninterference_strong"
  apply(rule Noninfluence_gen_Noninterference_strong)
   apply assumption
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninfluence:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence"
  apply(rule Noninfluence_gen_Noninfluence)
   apply assumption
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninfluence_strong:
  "\<lbrakk>confidentiality_u_weak; output_consistent; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence_strong"
  apply(rule Noninfluence_Noninfluence_strong)
   apply(blast intro: confidentiality_u_weak)
  apply(blast intro: Noninfluence)
  done

lemma Noninfluence_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence_uwr"
  apply(rule Noninfluence_gen_Noninfluence_uwr)
  apply(blast intro: Noninfluence_gen confidentiality_u_weak)
  done

lemma Noninfluence_strong_uwr:
  "\<lbrakk>confidentiality_u_weak; integrity_u\<rbrakk> \<Longrightarrow>
   Noninfluence_strong_uwr"
  apply(rule Noninfluence_uwr_Noninfluence_strong_uwr)
   apply(blast intro: confidentiality_u_weak)
  apply(blast intro: Noninfluence_uwr)
  done

lemma sources_Step:
  "\<lbrakk>reachable s; (dom a s, u) \<notin> policy\<rbrakk> \<Longrightarrow>
  sources [a] s u = {u}"
  apply(auto simp: sources_Cons sources_Nil enabled_Step dest: enabled_Step)
  done

lemma sources_Step_2:
  "\<lbrakk>reachable s; (dom a s, u) \<in> policy\<rbrakk> \<Longrightarrow>
  sources [a] s u = {dom a s,u}"
  apply(auto simp: sources_Cons sources_Nil enabled_Step dest: enabled_Step)
  done

lemma execution_Nil:
  "reachable s \<Longrightarrow> execution A s [] = {s}"
  apply(simp add: execution_Run)
  done

lemma Noninfluence_gen_confidentiality_u_weak:
  "Noninfluence_gen \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: Noninfluence_gen_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x="{t}" in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def ipurge_Cons ipurge_Nil split: if_splits add: schedIncludesCurrentDom)
  done

lemma Noninfluence_strong_uwr_confidentiality_u_weak:
  "Noninfluence_strong_uwr \<Longrightarrow> confidentiality_u_weak"
  apply(clarsimp simp: Noninfluence_strong_uwr_def confidentiality_u_weak_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=t in spec)
  apply(simp add: sources_Step_2 sameFor_dom_def uwr_equiv_def Step_def)
  done

lemma Nonleakage_gen_confidentiality_u:
  "Nonleakage_gen \<Longrightarrow> confidentiality_u"
  apply(clarsimp simp: Nonleakage_gen_def confidentiality_u_def)
  apply(drule_tac x="[a]" in spec, drule_tac x=s in spec)
  apply(drule_tac x=u in spec, drule_tac x=t in spec)
  apply(case_tac "dom a s \<leadsto> u")
   apply(simp add: sources_Step_2 uwr_equiv_def sameFor_dom_def Step_def)
  apply(simp add: sources_Step uwr_equiv_def sameFor_dom_def Step_def)
  done

lemma Nonleakage_gen_equiv_confidentiality_u:
  "Nonleakage_gen = confidentiality_u"
  apply(blast intro: Nonleakage_gen_confidentiality_u Nonleakage_gen)
  done

lemma non_sched_doms_cannot_schedule:
  "\<lbrakk>integrity_u; reachable s; dom a s \<noteq> schedDomain; (s,s') \<in> Step a\<rbrakk> \<Longrightarrow> s \<sim>schedDomain\<sim> s'"
  apply(drule_tac u=schedDomain in integrity_uD)
      apply assumption
     apply(erule contrapos_nn)
     apply(erule schedNotGlobalChannel)
    apply(rule uwr_refl)
   apply assumption
  apply(erule uwr_sym)
  done

text {*
   In systems with just a single event, @{prop integrity_u} is a very strong
   condition. It implies that once the scheduler is not
   running, it can never run again.

   This is one explanation for why seL4 (whose automaton has only a single
   event) doesn't satisfy @{prop integrity_u}.
*}
lemma integrity_u_and_single_event_systems:
  "\<lbrakk>integrity_u; reachable s; dom a s \<noteq> schedDomain; s' \<in> execution A s as;
    \<forall> y::'e. y = a\<rbrakk> \<Longrightarrow> dom e s' \<noteq> schedDomain"
  apply(frule_tac x=e in spec)
  apply(erule ssubst)
  apply(rule_tac P="\<lambda>x. x \<noteq> schedDomain" in subst[rotated])
   apply assumption
  apply(induct as arbitrary: s s' a rule: rev_induct)
   apply(simp add: execution_Run)
  apply(simp add: execution_Run)
  apply(drule Run_mid)
  apply(erule exE, rename_tac t)
  apply(drule_tac x=s in meta_spec)
  apply(drule_tac x=t in meta_spec)
  apply(drule_tac x=a in meta_spec)
  apply simp
  apply(rule schedIncludesCurrentDom)
  apply(rule non_sched_doms_cannot_schedule)
     apply assumption
    apply(rule reachable_execution)
     apply assumption
    apply(fastforce simp: execution_Run)
   apply assumption
  apply(drule_tac x=x in spec)
  apply blast
  done

end

text {* The unwinding conditions are not only sound but also complete *}
locale complete_unwinding_system = unwinding_system +
  assumes  policy_refl:
  "(u,u) \<in> policy"

context complete_unwinding_system begin

lemma Noninfluence_gen_integrity_u:
  "Noninfluence_gen \<Longrightarrow> integrity_u"
  apply(clarsimp simp: Noninfluence_gen_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec)
  apply(drule_tac x=s in spec, drule_tac x="{s}" in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_equiv_def Step_def ipurge_Cons ipurge_Nil split: if_splits add: uwr_refl policy_refl execution_Nil uwr_sym)
  done

lemma Noninfluence_strong_uwr_integrity_u: "Noninfluence_strong_uwr \<Longrightarrow> integrity_u"
  apply(clarsimp simp: Noninfluence_strong_uwr_def integrity_u_def)
  apply(drule_tac x=u in spec, drule_tac x="[a]" in spec, drule_tac x="[]" in spec)
  apply(drule_tac x=s in spec, drule_tac x=s in spec)
  apply(simp add: sources_Step sameFor_dom_def uwr_refl uwr_equiv_def Step_def ipurge_Cons ipurge_Nil split: if_splits)
   apply(simp add: policy_refl)
  apply(simp add: execution_Nil)
  apply(blast intro: uwr_sym)
  done

text {*
   @{prop Noninfluence_gen} actually turns out to be equivalent to @{prop Noninfluence_strong_uwr},
   when the policy is reflexive. So the two unwinding conditions for integrity
   and confidentiality actually turn out to be sound and sufficient for the
   condition we were using them to prove in the first place.
*}
lemma Noninfluence_gen_equiv_Noninfluence_strong_uwr:
  "Noninfluence_gen = Noninfluence_strong_uwr"
  apply(rule iffI)
   apply(rule Noninfluence_strong_uwr)
    apply(erule Noninfluence_gen_confidentiality_u_weak)
   apply(erule Noninfluence_gen_integrity_u)
  apply(rule Noninfluence_gen)
   apply(rule confidentiality_u_weak)
    apply(erule Noninfluence_strong_uwr_confidentiality_u_weak)
   apply(erule Noninfluence_strong_uwr_integrity_u)+
  done

end

end