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

chapter {* Unsigned words of default size *}

theory Uint imports
  "Word_Misc"
  "Bits_Integer"
begin

text {*
  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 @{text uint}
  models words of width @{text dflt_size}, but @{text dflt_size} is known only to be positive.

  Usage restrictions:
  Default-size words (type @{text uint}) 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 @{text "uint"}.
*}

text {* The default size type *}
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

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]
  -- "The code generator will substitute a machine-dependent value for this constant"

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

declare prod.Quotient[transfer_rule]

section {* Type definition and primitive operations *}

typedef uint = "UNIV :: dflt_size word set" ..

setup_lifting type_definition_uint

text {* Use an abstract type for code generation to disable pattern matching on @{term Abs_uint}. *}
declare Rep_uint_inverse[code abstype]

declare Quotient_uint[transfer_rule]

instantiation uint :: "{neg_numeral, Divides.div, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint :: uint is "0 :: dflt_size word" .
lift_definition one_uint :: uint is "1" .
lift_definition plus_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is "op + :: dflt_size word \<Rightarrow> _" .
lift_definition minus_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is "op -" .
lift_definition uminus_uint :: "uint \<Rightarrow> uint" is uminus .
lift_definition times_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is "op *" .
lift_definition divide_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is "op div" .
lift_definition mod_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is "op mod" .
instance by standard (transfer, simp add: algebra_simps)+
end

instantiation uint :: linorder begin
lift_definition less_uint :: "uint \<Rightarrow> uint \<Rightarrow> bool" is "op <" .
lift_definition less_eq_uint :: "uint \<Rightarrow> uint \<Rightarrow> bool" is "op \<le>" .
instance by standard (transfer, simp add: less_le_not_le linear)+
end

lemmas [code] = less_uint.rep_eq less_eq_uint.rep_eq

instantiation uint :: bitss begin
lift_definition bitNOT_uint :: "uint \<Rightarrow> uint" is bitNOT .
lift_definition bitAND_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is bitAND .
lift_definition bitOR_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is bitOR .
lift_definition bitXOR_uint :: "uint \<Rightarrow> uint \<Rightarrow> uint" is bitXOR .
lift_definition test_bit_uint :: "uint \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint :: "uint \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint" is set_bit .
lift_definition set_bits_uint :: "(nat \<Rightarrow> bool) \<Rightarrow> uint" is "set_bits" .
lift_definition lsb_uint :: "uint \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint :: "uint \<Rightarrow> nat \<Rightarrow> uint" is shiftl .
lift_definition shiftr_uint :: "uint \<Rightarrow> nat \<Rightarrow> uint" is shiftr .
lift_definition msb_uint :: "uint \<Rightarrow> bool" is msb .
instance ..
end

lemmas [code] = test_bit_uint.rep_eq lsb_uint.rep_eq msb_uint.rep_eq

instantiation uint :: equal begin
lift_definition equal_uint :: "uint \<Rightarrow> uint \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint.rep_eq

instantiation uint :: size begin
lift_definition size_uint :: "uint \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint.rep_eq

lift_definition sshiftr_uint :: "uint \<Rightarrow> nat \<Rightarrow> uint" (infixl ">>>" 55) is sshiftr .

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

lemma of_bool_integer_transfer [transfer_rule]:
  "(rel_fun op = pcr_integer) of_bool of_bool"
by(auto simp add: integer.pcr_cr_eq cr_integer_def split: bit.split)

text {* Use pretty numerals from integer for pretty printing *}

context includes integer.lifting begin

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

lemma Rep_uint_numeral [simp]: "Rep_uint (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint_def Abs_uint_inverse numeral.simps plus_uint_def)

lemma numeral_uint [code_unfold]: "numeral n = Uint (numeral n)"
by transfer simp

lemma Rep_uint_neg_numeral [simp]: "Rep_uint (- numeral n) = - numeral n"
by(simp only: uminus_uint_def)(simp add: Abs_uint_inverse)

lemma neg_numeral_uint [code_unfold]: "- numeral n = Uint (- numeral n)"
by transfer(simp add: cr_uint_def)

end

lemma Abs_uint_numeral [code_post]: "Abs_uint (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint_def numeral.simps plus_uint_def Abs_uint_inverse)

lemma Abs_uint_0 [code_post]: "Abs_uint 0 = 0"
by(simp add: zero_uint_def)

lemma Abs_uint_1 [code_post]: "Abs_uint 1 = 1"
by(simp add: one_uint_def)

section {* Code setup *}

code_printing code_module Uint \<rightharpoonup> (SML)
{*
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 *)*}
code_reserved SML Uint

code_printing code_module Uint \<rightharpoonup> (Haskell)
{*
import qualified Prelude;
import qualified Data.Word;
import qualified Data.Int;
import qualified Data.Bits;

type Int = Data.Int.Int;

type Word = Data.Word.Word;

dflt_size :: Prelude.Integer;
dflt_size = Prelude.toInteger (bitSize_aux (0::Word))
  where {
    bitSize_aux :: (Data.Bits.Bits a, Prelude.Bounded a) => a -> Uint.Int;
    bitSize_aux = Data.Bits.bitSize
  };
*}
  and (Haskell_Quickcheck)
{*
import qualified Prelude;
import qualified Data.Word;
import qualified Data.Int;
import qualified Data.Bits;

type Int = Data.Int.Int;

type Word = Data.Word.Word;

dflt_size :: Prelude.Int;
dflt_size = bitSize_aux (0::Word)
  where {
    bitSize_aux :: (Data.Bits.Bits a, Prelude.Bounded a) => a -> Uint.Int;
    bitSize_aux = Data.Bits.bitSize
  };
*}
code_reserved Haskell Uint dflt_size

text {*
  OCaml and Scala provide only signed bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
*}

code_printing code_module "Uint" \<rightharpoonup> (OCaml)
{*module Uint : sig
  type t = int
  val dflt_size : Big_int.big_int
  val less : t -> t -> bool
  val less_eq : t -> t -> bool
  val set_bit : t -> Big_int.big_int -> bool -> t
  val shiftl : t -> Big_int.big_int -> t
  val shiftr : t -> Big_int.big_int -> t
  val shiftr_signed : t -> Big_int.big_int -> t
  val test_bit : t -> Big_int.big_int -> bool
end = struct

type t = int

let dflt_size = Big_int.big_int_of_int (
  let rec f n = if n=0 then 0 else f (n / 2) + 1 in f min_int);;

(* 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 (Big_int.int_of_big_int n)
  in if b then x lor mask
     else x land (lnot mask);;

let shiftl x n = x lsl (Big_int.int_of_big_int n);;

let shiftr x n = x lsr (Big_int.int_of_big_int n);;

let shiftr_signed x n = x asr (Big_int.int_of_big_int n);;

let test_bit x n = x land (1 lsl (Big_int.int_of_big_int n)) <> 0;;

end;; (*struct Uint*)*}
code_reserved OCaml Uint

code_printing code_module Uint \<rightharpoonup> (Scala)
{*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 */*}
code_reserved Scala Uint

text {*
  OCaml's conversion from Big\_int to int demands that the value fits int a signed integer.
  The following justifies the implementation.
*}

context includes integer.lifting 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"
  apply transfer apply (simp add: wivs_index_def)
  by (metis One_nat_def add_diff_cancel2 dflt_size(1) diff_Suc_1
    less_nat_zero_code nat.exhaust of_nat_Suc)

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 i' !! wivs_index then
       Uint_signed (i' - wivs_shift_integer)
     else Uint_signed i')"
  including undefined_transfer
  unfolding Uint_signed_def
  apply transfer
  apply (rule word_of_int_via_signed)
  by (simp_all add: wivs_mask_def wivs_shift_def wivs_index_def wivs_overflow_def
    wivs_least_def bin_mask_conv_pow2 shiftl_int_def)

lemma Uint_signed_code [code abstract]:
  "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 word_of_integer_def
  by(simp add: Abs_uint_inverse)
end

text {*
  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.)
*}

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

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

lemma [code, code del]: "term_of_class.term_of = (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.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 {* Important:
  We must prevent the reflection oracle (eval-tac) to
  use our machine-dependent type.
 *}

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) "Big'_int.int'_of'_big'_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 "bitNOT :: 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 "bitAND :: 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 "bitOR :: 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 "bitXOR :: 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 (op div :: uint \<Rightarrow> _) x (0 :: uint), undefined (op 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 (op 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 (op div :: uint \<Rightarrow> _) x (0 :: uint)"
declare [[code abort: div0_uint]]

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

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

(* TODO: Move to Word *)
lemma dflt_size_word_pow_ne_zero [simp]:
  "(2 :: 'a word) ^ (len_of TYPE('a::len) - Suc 0) \<noteq> 0"
proof
  assume "(2 :: 'a word) ^ (len_of TYPE('a::len) - Suc 0) = 0"
  then have "unat ((2 :: 'a word) ^ (len_of TYPE('a::len) - Suc 0)) = unat 0"
    by simp
  then show False by (simp add: unat_p2)
qed

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 = (uint_sdiv (x >> 1) y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
  including undefined_transfer
  unfolding uint_divmod_def uint_sdiv_def div0_uint_def mod0_uint_def
    wivs_overflow_uint_def
  by transfer (simp add: divmod_via_sdivmod)

lemma uint_sdiv_code [code abstract]:
  "Rep_uint (uint_sdiv x y) =
   (if y = 0 then Rep_uint (undefined (op 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 {*
  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.
*}

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 (test_bit :: uint \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint_code [code]:
  "test_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 (auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint_test_bit_code [code]:
  "uint_test_bit w n =
  (if n < 0 \<or> dflt_size_integer \<le> n then undefined (test_bit :: uint \<Rightarrow> _) w n else Rep_uint w !! nat_of_integer n)"
unfolding uint_test_bit_def
by(simp add: test_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 abstract]:
  "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"

lift_definition uint_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint \<Rightarrow> nat \<Rightarrow> uint" is set_bits_aux .

lemma uint_set_bits_code [code]:
  "uint_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint_set_bits f ((w << 1) OR (if f n' then 1 else 0)) n')"
by(transfer fixing: n)(cases n, simp_all)

lemma set_bits_uint [code]:
  "(BITS n. f n) = uint_set_bits f 0 dflt_size"
  by transfer (simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint shows "lsb x = x !! 0"
by transfer(simp add: word_lsb_def word_test_bit_def)

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 (shiftl :: uint \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint_code [code]: "x << n = (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(simp add: not_less shiftl_zero_size word_size)

lemma uint_shiftl_code [code abstract]:
  "Rep_uint (uint_shiftl w n) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (shiftl :: uint \<Rightarrow> _) w n) else Rep_uint w << (nat_of_integer n))"
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 (shiftr :: uint \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint_code [code]: "x >> n = (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(simp add: not_less shiftr_zero_size word_size)

lemma uint_shiftr_code [code abstract]:
  "Rep_uint (uint_shiftr w n) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined (shiftr :: uint \<Rightarrow> _) w n) else Rep_uint w >> nat_of_integer n)"
including undefined_transfer 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 sshiftr_uint x n else sshiftr_uint x (nat_of_integer n))"

lemma sshiftr_beyond: fixes x :: "'a :: len word" shows
  "size x \<le> n \<Longrightarrow> x >>> n = (if x !! (size x - 1) then -1 else 0)"
by(rule word_eqI)(simp add: nth_sshiftr word_size)

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

lemma uint_sshiftr_code [code abstract]:
  "Rep_uint (uint_sshiftr w n) =
  (if n < 0 \<or> dflt_size_integer \<le> n then Rep_uint (undefined sshiftr_uint w n) else Rep_uint w >>> (nat_of_integer n))"
including undefined_transfer 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> (x :: uint) !! wivs_index"
by transfer(simp add: msb_nth 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. i !! n)"
by transfer(simp add: word_of_int_conv_set_bits test_bit_int_def[abs_def])

section {* Quickcheck setup *}

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

no_notation sshiftr_uint (infixl ">>>" 55)

end


theory Hopcroft_Tarjan_5
  imports
    Hopcroft_Tarjan
begin

type_synonym ('a, 'b) component = "('a, 'b) Directed_Multigraph.edge list"

record ('b, 't, 'g, 'a) state =
  root :: 'b
  tree :: 't
  multigraph :: 'g
  ESTACK :: "('a, 'b) Directed_Multigraph.edge list"
  Cs :: "('a, 'b) component list"

locale path_search =
  other
  where other = other +
    T: Map
  where empty = T_empty
    and update = T_update
    and delete = T_delete
    and lookup = T_lookup
    and invar = T_invar +
    P: Incidence_Structure
  where insert = insert
  for other :: "('a::linorder, 'b::linorder) Multigraph.edge \<Rightarrow> 'b \<Rightarrow> 'b"
    and T_empty
    and T_update :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and T_delete
    and T_lookup
    and T_invar
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes algorithm_5 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  fixes algorithm_6 :: "('b \<Rightarrow> nat) \<Rightarrow> ('a, 'b) Directed_Multigraph.edge \<Rightarrow> ('b, 't, 'g, 'a) state \<Rightarrow> ('b, 't, 'g, 'a) state"
  assumes root_algorithm_5: "root (algorithm_5 N e \<sigma>) = root \<sigma>"
  assumes root_algorithm_6: "root (algorithm_6 N e \<sigma>) = root \<sigma>"
begin

definition tree_arc_2 where
  "tree_arc_2 \<sigma> \<equiv> tree.tree_arc (T_lookup (tree \<sigma>))"

definition lookup where
  "lookup \<sigma> v \<equiv> case T_lookup (tree \<sigma>) v of None \<Rightarrow> None | Some p \<Rightarrow> Some (to_edge v p)"

definition incidence_2 where
  "incidence_2 \<sigma> \<equiv> Directed_Multigraph.incidence (\<lambda>v. incidence v (multigraph \<sigma>))"

function (domintros) path_search where
  "path_search N e \<sigma> =
   (if tree_arc_2 \<sigma> e
    then if incidence_2 \<sigma> (head e) = []
         then let \<sigma>1 = \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>;
                  \<sigma>2 = algorithm_5 N e \<sigma>1;
                  \<sigma>3 = algorithm_6 N e \<sigma>2
              in case lookup \<sigma>3 (tail e) of
                   None \<Rightarrow> \<sigma>3 |
                   Some e' \<Rightarrow> path_search N e' \<sigma>3
         else path_search N (hd (incidence_2 \<sigma> (head e))) \<sigma>
    else let \<sigma>1 = \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>
         in case lookup \<sigma>1 (tail e) of
                   None \<Rightarrow> \<sigma>1 |
                   Some e' \<Rightarrow> path_search N e' \<sigma>1)"
  by auto
thm path_search.pinduct

end

locale algorithm_3_pre = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g"
begin

definition init where
  "init r T P \<equiv>
   \<lparr>root = r,
    tree = T,
    multigraph = P,
    ESTACK = [],
    Cs = []\<rparr>"

definition algorithm_3 where
  "algorithm_3 r T P N \<equiv>
   let \<sigma> = path_search N (hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)) (init r T P)
   in ESTACK \<sigma> # Cs \<sigma>"

end

locale algorithm_3 = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes T :: "'g \<Rightarrow> 'b \<Rightarrow> 't"
  fixes N :: "'g \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> nat"
  fixes I :: "'g \<Rightarrow> 'b \<Rightarrow> 'g"
  assumes steps_1_2_3_high_3:
    "\<lbrakk> biconnected_multigraph other (P.E G); r \<in> Multigraph.V (P.E G) \<rbrakk> \<Longrightarrow>
     steps_1_2_3_high_3 other r (\<lambda>v. incidence v (I G r)) (N G r) (P.E G) (T_lookup (T G r))"
begin

definition algorithm_3' :: "'g \<Rightarrow> 'b \<Rightarrow> ('a, 'b) Multigraph.edge list list" where
  "algorithm_3' G r \<equiv> map (map undirect) (algorithm_3 r (T G r) (I G r) (N G r))"

end

subsection \<open>Verification of the correctness of the algorithm\<close>

subsubsection \<open>Assumptions on the input\<close>

locale path_search_valid_input = path_search
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes N :: "'b \<Rightarrow> nat"
  fixes e :: "('a, 'b) Directed_Multigraph.edge"
  assumes "0 \<le> N (tail e)"
begin
end

locale algorithm_3_pre_valid_input = algorithm_3_pre
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes r :: 'b
  fixes T :: 't
  fixes P :: 'g
  fixes N :: "'b \<Rightarrow> nat"
  assumes steps_1_2_3_high_2: "steps_1_2_3_high_2 r (\<lambda>v. incidence v P) (T_lookup T) N"
begin
sublocale path_search_valid_input
  where N = N
    and e = "hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)"
  sorry
end

abbreviation (in algorithm_3_pre) algorithm_3_pre_valid_input' where
  "algorithm_3_pre_valid_input' \<equiv>
   algorithm_3_pre_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T_update
    insert"

locale algorithm_3_valid_input = algorithm_3
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes G :: 'g
  fixes r :: 'b
  assumes biconnected_multigraph: "biconnected_multigraph other (P.E G)"
  assumes r_mem_V: "r \<in> Multigraph.V (P.E G)"
begin

sublocale steps_1_2_3_high_3
  where N = "N G r"
    and I = "\<lambda>v. incidence v (I G r)"
    and G = "P.E G"
    and T = "T_lookup (T G r)"
  using biconnected_multigraph r_mem_V
  by (intro steps_1_2_3_high_3)

sublocale algorithm_3_pre_valid_input
  where T = "T G r"
    and P = "I G r"
    and N = "N G r"
  sorry

end

abbreviation (in algorithm_3) algorithm_3_valid_input' where
  "algorithm_3_valid_input' \<equiv>
   algorithm_3_valid_input
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    T
    N
    I
    T_update
    insert"

subsubsection \<open>Loop invariants\<close>

definition (in path_search) current_multigraph :: "('b, 't, 'g, 'a) state \<Rightarrow> ('a, 'b) Directed_Multigraph.multigraph" where
  "current_multigraph \<sigma> \<equiv> P.A (multigraph \<sigma>) \<union> set (ESTACK \<sigma>)"

locale path_search_invar = path_search_valid_input
  where T_update = T_update
    and insert = insert
  for T_update :: "'b::linorder \<Rightarrow> 'a::linorder \<times> 'b \<Rightarrow> 't \<Rightarrow> 't"
    and insert :: "'b \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'g \<Rightarrow> 'g" +
  fixes \<sigma> :: "('b, 't, 'g, 'a) state"
    (* QUESTION: Use P.E instead? *)
  assumes finite_current_multigraph: "finite (undirect ` current_multigraph \<sigma>)"
  assumes simple_current_multigraph: "simple (undirect ` current_multigraph \<sigma>)"
  assumes finite_Cs: "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) finite"
  assumes no_separation_pair_Cs: "\<forall>G\<in>set (map set (map (map undirect) (Cs \<sigma>))). \<not> (\<exists>a b. is_separation_pair G a b)"
    (* TODO: Order. *)
  assumes palm_tree_2: "palm_tree_2 (root \<sigma>) (T_lookup (tree \<sigma>)) (\<lambda>v. incidence v (multigraph \<sigma>))"
begin
end

abbreviation (in path_search) path_search_invar' where
  "path_search_invar' N e \<equiv>
   path_search_invar
    empty delete incidence invar
    other
    T_empty T_delete T_lookup T_invar
    algorithm_5
    algorithm_6
    N
    e
    T_update
    insert"

abbreviation (in path_search_valid_input) path_search_invar'' where
  "path_search_invar'' \<equiv> path_search_invar' N e"

lemma (in algorithm_3_pre_valid_input) path_search_invar_init:
  shows "path_search_invar'' (init r T P)"
  sorry

lemma (in path_search_invar) finite_multigraph_Cs:
  shows "Ball (set (map set (map (map undirect) (Cs \<sigma>)))) (Multigraph.finite_multigraph other)"
  sorry

subsubsection \<open>Termination\<close>

lemma (in path_search_valid_input) path_search_dom:
  assumes "path_search_invar'' \<sigma>"
  shows "path_search_dom (N, e, \<sigma>)"
  sorry

lemma (in path_search_invar) path_search_dom:
  shows "path_search_dom (N, e, \<sigma>)"
  using path_search_invar_axioms
  by (intro path_search_dom)

lemma (in path_search) path_search_simps:
  assumes "path_search_invar' N e \<sigma>"
  shows
    "path_search N e \<sigma> =
     (if tree_arc_2 \<sigma> e
      then if incidence_2 \<sigma> (head e) = []
           then let \<sigma>1 = \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>;
                    \<sigma>2 = algorithm_5 N e \<sigma>1;
                    \<sigma>3 = algorithm_6 N e \<sigma>2
                in case lookup \<sigma>3 (tail e) of
                     None \<Rightarrow> \<sigma>3 |
                     Some e' \<Rightarrow> path_search N e' \<sigma>3
           else path_search N (hd (incidence_2 \<sigma> (head e))) \<sigma>
      else let \<sigma>1 = \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>
           in case lookup \<sigma>1 (tail e) of
                None \<Rightarrow> \<sigma>1 |
                Some e' \<Rightarrow> path_search N e' \<sigma>1)"
  using assms
  by (intro path_search_invar.path_search_dom path_search.psimps)

lemma (in path_search) path_search_induct:
  assumes "path_search_invar' N e \<sigma>"
  assumes
    "\<And>N e \<sigma>.
        (\<And>\<sigma>3 e'.
            tree_arc_2 \<sigma> e \<Longrightarrow>
            incidence_2 \<sigma> (head e) = [] \<Longrightarrow>
            \<sigma>3 = algorithm_6 N e (algorithm_5 N e (\<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr>)) \<Longrightarrow>
            lookup \<sigma>3 (tail e) = Some e' \<Longrightarrow>
            P N e' \<sigma>3) \<Longrightarrow>
        (tree_arc_2 \<sigma> e \<Longrightarrow> incidence_2 \<sigma> (head e) \<noteq> [] \<Longrightarrow> P N (hd (incidence_2 \<sigma> (head e))) \<sigma>) \<Longrightarrow>
        (\<And>\<sigma>1 e'.
            \<not> tree_arc_2 \<sigma> e \<Longrightarrow>
            \<sigma>1 = \<sigma>\<lparr>ESTACK := e # ESTACK \<sigma>\<rparr> \<Longrightarrow>
            lookup \<sigma>1 (tail e) = Some e' \<Longrightarrow>
            P N e' \<sigma>1) \<Longrightarrow>
        P N e \<sigma>"
  shows "P N e \<sigma>"
  using assms
  by (blast intro: path_search_invar.path_search_dom path_search.pinduct)

subsubsection \<open>Correctness\<close>

lemma (in path_search_valid_input) is_split_tbd_path_search:
  assumes "path_search_invar'' \<sigma>"
  shows
    "is_split_tbd
      (undirect ` current_multigraph \<sigma> # map set (map (map undirect) (Cs \<sigma>)))
      (undirect ` current_multigraph (path_search N e \<sigma>) # map set (map (map undirect) (Cs (path_search N e \<sigma>))))"
  using assms
proof (induct rule: path_search_induct[OF assms])
  case (1 N e \<sigma>)
  then show ?case sorry
qed

lemma (in path_search_valid_input) no_separation_pair_path_search:
  assumes "path_search_invar'' \<sigma>"
  assumes "is_separation_pair (undirect ` current_multigraph (path_search N e \<sigma>)) a b"
  shows
    "a \<notin> tree.D (T_lookup (tree (path_search N e \<sigma>))) (tail e) \<or>
     b \<notin> tree.D (T_lookup (tree (path_search N e \<sigma>))) (tail e)"
  using assms
proof (induct rule: path_search_induct[OF assms(1)])
  case (1 N e \<sigma>)
  then show ?case sorry
qed

(* TODO: Move. *)
lemma (in path_search) edges_from_fun_incidence_eq_A:
  shows "edges_from_fun (\<lambda>v. incidence v P) = P.A P"
  by (force simp add: edges_from_fun_def incidence_def to_edge_def P.A_def)

(* TODO: Move. *)
lemma (in algorithm_3_valid_input) image_undirect_A_eq_E:
  shows "undirect ` P.A (I G r) = P.E G"
  using undirect_P_eq_G
  by (force simp add: edges_from_fun_incidence_eq_A)

lemma (in algorithm_3_pre_valid_input) algorithm_3_correct:
  shows "are_split_components (undirect ` P.A P) (map set (map (map undirect) (algorithm_3 r T P N)))"
  unfolding algorithm_3_def Let_def
proof (intro are_split_componentsI_2, goal_cases)
  case 1
  let ?\<sigma> = "path_search N (hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)) (init r T P)"
  have "Multigraph.finite_multigraph other (undirect ` set (ESTACK ?\<sigma>))"
    sorry
  moreover have "Ball (set (map set (map (map undirect) (Cs ?\<sigma>)))) (Multigraph.finite_multigraph other)"
    sorry
  ultimately show ?case
    by fastforce
next
  case 2
  show ?case
    thm is_split_tbd_path_search[OF path_search_invar_init]
    sorry
next
  case 3
  let ?\<sigma> = "path_search N (hd (Directed_Multigraph.incidence (\<lambda>v. incidence v P) r)) (init r T P)"
  show ?case sorry
qed

lemma (in algorithm_3_valid_input) algorithm_3'_correct:
  shows "are_split_components (P.E G) (map set (algorithm_3' G r))"
  unfolding image_undirect_A_eq_E[symmetric] algorithm_3'_def
  using algorithm_3_correct
  .

end


theory Weak_Formula
imports
  Weak_Transition_System
  Disjunction
begin

section \<open>Weak Formulas\<close>

subsection \<open>Lemmas about \texorpdfstring{$\alpha$}{alpha}-equivalence involving \texorpdfstring{$\tau$}{tau}\<close>

context weak_nominal_ts
begin

  lemma Act_tau_eq_iff [simp]:
    "Act \<tau> x1 = Act \<alpha> x2 \<longleftrightarrow> \<alpha> = \<tau> \<and> x2 = x1"
    (is "?l \<longleftrightarrow> ?r")
  proof
    assume "?l"
    then obtain p where p_\<alpha>: "p \<bullet> \<tau> = \<alpha>" and p_x: "p \<bullet> x1 = x2" and fresh: "(supp x1 - bn \<tau>) \<sharp>* p"
      by (metis Act_eq_iff_perm)
    from p_\<alpha> have "\<alpha> = \<tau>"
      by (metis tau_eqvt)
    moreover from fresh and p_x have "x2 = x1"
      by (simp add: supp_perm_eq)
    ultimately show "?r" ..
  next
    assume "?r" then show "?l"
      by simp
  qed

end

subsection \<open>Weak action modality\<close>

text \<open>The definition of (strong) formulas is parametric in the index type, but from now on we
want to work with a fixed (sufficiently large) index type.

Also, we use~@{term \<tau>} in our definition of weak formulas.\<close>

locale indexed_weak_nominal_ts = weak_nominal_ts satisfies transition
  for satisfies :: "'state::fs \<Rightarrow> 'pred::fs \<Rightarrow> bool" (infix "\<turnstile>" 70)
  and transition :: "'state \<Rightarrow> ('act::bn,'state) residual \<Rightarrow> bool" (infix "\<rightarrow>" 70) +
  assumes card_idx_perm: "|UNIV::perm set| <o |UNIV::'idx set|"
      and card_idx_state: "|UNIV::'state set| <o |UNIV::'idx set|"
      and card_idx_nat: "|UNIV::nat set| <o |UNIV::'idx set|"
begin

  text \<open>The assumption @{thm card_idx_nat} is redundant: it is already implied by
  @{thm card_idx_perm}.  A formal proof of this fact is left for future work.\<close>

  lemma card_idx_nat' [simp]:
    "|UNIV::nat set| <o natLeq +c |UNIV::'idx set|"
  proof -
    note card_idx_nat
    also have "|UNIV :: 'idx set| \<le>o natLeq +c |UNIV :: 'idx set|"
      by (metis Cnotzero_UNIV ordLeq_csum2)
    finally show ?thesis .
  qed

  primrec tau_steps :: "('idx,'pred::fs,'act::bn) formula \<Rightarrow> nat \<Rightarrow> ('idx,'pred,'act) formula"
    where
      "tau_steps x 0       = x"
    | "tau_steps x (Suc n) = Act \<tau> (tau_steps x n)"

  lemma tau_steps_eqvt (*[eqvt]*) [simp]:
    "p \<bullet> tau_steps x n = tau_steps (p \<bullet> x) (p \<bullet> n)"
    by (induct n) (simp_all add: permute_nat_def tau_eqvt)

  lemma tau_steps_eqvt' [simp]:
    "p \<bullet> tau_steps x = tau_steps (p \<bullet> x)"
    by (simp add: permute_fun_def)

  lemma tau_steps_eqvt_raw [simp]:
    "p \<bullet> tau_steps = tau_steps"
    by (simp add: permute_fun_def)

  lemma tau_steps_add [simp]:
    "tau_steps (tau_steps x m) n = tau_steps x (m + n)"
    by (induct n) auto

  lemma tau_steps_not_self:
    "x = tau_steps x n \<longleftrightarrow> n = 0"
  proof
    assume "x = tau_steps x n" then show "n = 0"
      proof (induct n arbitrary: x)
        case 0 show ?case ..
      next
        case (Suc n)
        then have "x = Act \<tau> (tau_steps x n)"
          by simp
        then show "Suc n = 0"
          proof (induct x)
            case (Act \<alpha> x)
            then have "x = tau_steps (Act \<tau> x) n"
              by (metis Act_tau_eq_iff)
            with Act.hyps show ?thesis
              by (metis add_Suc tau_steps.simps(2) tau_steps_add)
          qed simp_all
      qed
  next
    assume "n = 0" then show "x = tau_steps x n"
      by simp
  qed

  definition weak_tau_modality :: "('idx,'pred::fs,'act::bn) formula \<Rightarrow> ('idx,'pred,'act) formula"
    where
      "weak_tau_modality x \<equiv> Disj (map_bset (tau_steps x) (Abs_bset UNIV))"

  lemma finite_supp_map_bset_tau_steps [simp]:
    "finite (supp (map_bset (tau_steps x) (Abs_bset UNIV :: nat set['idx])))"
  proof -
    have "eqvt map_bset" and "eqvt tau_steps"
      by (simp add: eqvtI)+
    then have "supp (map_bset (tau_steps x)) \<subseteq> supp x"
      using supp_fun_eqvt supp_fun_app supp_fun_app_eqvt by blast
    moreover have "supp (Abs_bset UNIV :: nat set['idx]) = {}"
      by (simp add: eqvtI supp_fun_eqvt)
    ultimately have "supp (map_bset (tau_steps x) (Abs_bset UNIV :: nat set['idx])) \<subseteq> supp x"
      using supp_fun_app by blast
    then show ?thesis
      by (metis finite_subset finite_supp)
  qed

  lemma weak_tau_modality_eqvt (*[eqvt]*) [simp]:
    "p \<bullet> weak_tau_modality x = weak_tau_modality (p \<bullet> x)"
    unfolding weak_tau_modality_def by (simp add: map_bset_eqvt)

  lemma weak_tau_modality_eq_iff [simp]:
    "weak_tau_modality x = weak_tau_modality y \<longleftrightarrow> x = y"
  proof
    assume "weak_tau_modality x = weak_tau_modality y"
    then have "map_bset (tau_steps x) (Abs_bset UNIV :: _ set['idx]) = map_bset (tau_steps y) (Abs_bset UNIV)"
      unfolding weak_tau_modality_def by simp
    with card_idx_nat' have "range (tau_steps x) = range (tau_steps y)"
      (is "?X = ?Y")
      by (metis Abs_bset_inverse' map_bset.rep_eq)
    then have "x \<in> range (tau_steps y)" and "y \<in> range (tau_steps x)"
      by (metis range_eqI tau_steps.simps(1))+
    then obtain nx ny where x: "x = tau_steps y nx" and y: "y = tau_steps x ny"
      by blast
    then have "ny + nx = 0"
      by (simp add: tau_steps_not_self)
    with x and y show "x = y"
      by simp
  next
    assume "x = y" then show "weak_tau_modality x = weak_tau_modality y"
      by simp
  qed

  lemma supp_weak_tau_modality [simp]:
    "supp (weak_tau_modality x) = supp x"
    unfolding supp_def by simp

  lemma Act_weak_tau_modality_eq_iff [simp]:
    "Act \<alpha>1 (weak_tau_modality x1) = Act \<alpha>2 (weak_tau_modality x2) \<longleftrightarrow> Act \<alpha>1 x1 = Act \<alpha>2 x2"
    by (simp add: Act_eq_iff_perm)

  definition weak_action_modality :: "'act \<Rightarrow> ('idx,'pred::fs,'act::bn) formula \<Rightarrow> ('idx,'pred,'act) formula" ("\<langle>\<langle>_\<rangle>\<rangle>_")
    where
      "\<langle>\<langle>\<alpha>\<rangle>\<rangle>x \<equiv> if \<alpha> = \<tau> then weak_tau_modality x else weak_tau_modality (Act \<alpha> (weak_tau_modality x))"

  lemma weak_action_modality_eqvt (*[eqvt]*) [simp]:
    "p \<bullet> (\<langle>\<langle>\<alpha>\<rangle>\<rangle>x) = \<langle>\<langle>p \<bullet> \<alpha>\<rangle>\<rangle>(p \<bullet> x)"
    using tau_eqvt weak_action_modality_def by fastforce

  lemma weak_action_modality_tau:
    "(\<langle>\<langle>\<tau>\<rangle>\<rangle>x) = weak_tau_modality x"
    unfolding weak_action_modality_def by simp

  lemma weak_action_modality_not_tau:
    assumes "\<alpha> \<noteq> \<tau>"
    shows "(\<langle>\<langle>\<alpha>\<rangle>\<rangle>x) = weak_tau_modality (Act \<alpha> (weak_tau_modality x))"
    using assms unfolding weak_action_modality_def by simp

  text \<open>Equality is modulo $\alpha$-equivalence.\<close>

  text \<open>Note that the converse of the following lemma does not hold. For instance,
  for~@{prop "\<alpha> \<noteq> \<tau>"} we have @{prop "(\<langle>\<langle>\<tau>\<rangle>\<rangle>(Act \<alpha> (weak_tau_modality x))) = \<langle>\<langle>\<alpha>\<rangle>\<rangle>x"} by definition,
  but clearly not @{prop "Act \<tau> (Act \<alpha> (weak_tau_modality x)) = Act \<alpha> x"}.\<close>

  lemma weak_action_modality_eq:
    assumes "Act \<alpha>1 x1 = Act \<alpha>2 x2"
    shows "(\<langle>\<langle>\<alpha>1\<rangle>\<rangle>x1) = (\<langle>\<langle>\<alpha>2\<rangle>\<rangle>x2)"
  proof (cases "\<alpha>1 = \<tau>")
    case True
    with assms have "\<alpha>2 = \<alpha>1 \<and> x2 = x1"
      by (metis Act_tau_eq_iff)
    then show ?thesis
      by simp
  next
    case False
    from assms obtain p where 1: "supp x1 - bn \<alpha>1 = supp x2 - bn \<alpha>2" and 2: "(supp x1 - bn \<alpha>1) \<sharp>* p"
      and 3: "p \<bullet> x1 = x2" and 4: "supp \<alpha>1 - bn \<alpha>1 = supp \<alpha>2 - bn \<alpha>2" and 5: "(supp \<alpha>1 - bn \<alpha>1) \<sharp>* p"
      and 6: "p \<bullet> \<alpha>1 = \<alpha>2"
      by (metis Act_eq_iff_perm)
    from 1 have "supp (weak_tau_modality x1) - bn \<alpha>1 = supp (weak_tau_modality x2) - bn \<alpha>2"
      by (metis supp_weak_tau_modality)
    moreover from 2 have "(supp (weak_tau_modality x1) - bn \<alpha>1) \<sharp>* p"
      by (metis supp_weak_tau_modality)
    moreover from 3 have "p \<bullet> weak_tau_modality x1 = weak_tau_modality x2"
      by (metis weak_tau_modality_eqvt)
    ultimately have "Act \<alpha>1 (weak_tau_modality x1) = Act \<alpha>2 (weak_tau_modality x2)"
      using 4 and 5 and 6 and Act_eq_iff_perm by blast
    moreover from \<open>\<alpha>1 \<noteq> \<tau>\<close> and assms have "\<alpha>2 \<noteq> \<tau>"
      by (metis Act_tau_eq_iff)
    ultimately show ?thesis
      using \<open>\<alpha>1 \<noteq> \<tau>\<close> by (simp add: weak_action_modality_not_tau)
  qed

  subsection \<open>Weak formulas\<close>

  inductive weak_formula :: "('idx,'pred::fs,'act::bn) formula \<Rightarrow> bool"
    where
      wf_Conj: "finite (supp xset) \<Longrightarrow> (\<And>x. x \<in> set_bset xset \<Longrightarrow> weak_formula x) \<Longrightarrow> weak_formula (Conj xset)"
    | wf_Not: "weak_formula x \<Longrightarrow> weak_formula (Not x)"
    | wf_Act: "weak_formula x \<Longrightarrow> weak_formula (\<langle>\<langle>\<alpha>\<rangle>\<rangle>x)"
    | wf_Pred: "weak_formula x \<Longrightarrow> weak_formula (\<langle>\<langle>\<tau>\<rangle>\<rangle>(Conj (binsert (Pred \<phi>) (bsingleton x))))"

  lemma finite_supp_wf_Pred [simp]: "finite (supp (binsert (Pred \<phi>) (bsingleton x)))"
  proof -
    have "supp (bsingleton x) \<subseteq> supp x"
      by (simp add: eqvtI supp_fun_app_eqvt)
    moreover have "eqvt binsert"
      by (simp add: eqvtI)
    ultimately have "supp (binsert (Pred \<phi>) (bsingleton x)) \<subseteq> supp \<phi> \<union> supp x"
      using supp_fun_app supp_fun_app_eqvt by fastforce
    then show ?thesis
      by (metis finite_UnI finite_supp rev_finite_subset)
  qed

  text \<open>@{const weak_formula} is equivariant.\<close>

  lemma weak_formula_eqvt (*[eqvt]*) [simp]: "weak_formula x \<Longrightarrow> weak_formula (p \<bullet> x)"
  proof (induct rule: weak_formula.induct)
    case (wf_Conj xset) then show ?case
      by simp (metis (no_types, lifting) imageE permute_finite permute_set_eq_image set_bset_eqvt supp_eqvt weak_formula.wf_Conj)
  next
    case (wf_Not x) then show ?case
      by (simp add: weak_formula.wf_Not)
  next
    case (wf_Act x \<alpha>) then show ?case
      by (simp add: weak_formula.wf_Act)
  next
    case (wf_Pred x \<phi>) then show ?case
      by (simp add: tau_eqvt weak_formula.wf_Pred)
  qed

end

end


(*
Title: WHATandWHERE-Security
Authors: Sylvia Grewe, Alexander Lux, Heiko Mantel, Jens Sauer
*)
theory Type_System_example
imports Type_System Strong_Security.Expr Strong_Security.Domain_example
begin

\<comment> \<open>When interpreting, we have to instantiate the type for domains. As an example, we take a type containing 'low' and 'high' as domains.\<close>

consts DA :: "('id,Dom) DomainAssignment"
consts BMap :: "'val \<Rightarrow> bool"
consts lH :: "(Dom,('id,'val) Expr) lHatches"

\<comment> \<open>redefine all the abbreviations necessary for auxiliary lemmas with the
  correct parameter instantiation\<close>

abbreviation MWLsStepsdet' ::
  "(('id,'val) Expr, 'id, 'val, (('id,'val) Expr,'id) MWLsCom) TLSteps_curry"
("(1\<langle>_,/_\<rangle>) \<rightarrow>\<lhd>_\<rhd>/ (1\<langle>_,/_\<rangle>)" [0,0,0,0,0] 81)
where
"\<langle>c1,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>c2,m2\<rangle> \<equiv>
  ((c1,m1),\<alpha>,(c2,m2)) \<in> MWLs_semantics.MWLsSteps_det ExprEval BMap"

abbreviation d_equal' :: "('id, 'val) State
  \<Rightarrow> Dom \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ =\<^bsub>_\<^esub> _)" )
where
"m =\<^bsub>d\<^esub> m' \<equiv> WHATWHERE.d_equal DA d m m'"

abbreviation dH_equal' :: "('id, 'val) State \<Rightarrow> Dom
  \<Rightarrow> (Dom,('id,'val) Expr) Hatches
  \<Rightarrow> ('id, 'val) State \<Rightarrow> bool"
( "(_ \<sim>\<^bsub>_,_\<^esub> _)" )
where
"m \<sim>\<^bsub>d,H\<^esub> m' \<equiv> WHATWHERE.dH_equal ExprEval DA d H m m'"

abbreviation NextMem' :: "(('id,'val) Expr, 'id) MWLsCom
  \<Rightarrow> ('id,'val) State \<Rightarrow> ('id,'val) State"
("\<lbrakk>_\<rbrakk>'(_')")
where
"\<lbrakk>c\<rbrakk>(m)
  \<equiv> WHATWHERE.NextMem (MWLs_semantics.MWLsSteps_det ExprEval BMap) c m"

abbreviation dH_indistinguishable' :: "('id,'val) Expr \<Rightarrow> Dom
  \<Rightarrow> (Dom,('id,'val) Expr) Hatches \<Rightarrow> ('id,'val) Expr \<Rightarrow> bool"
( "(_ \<equiv>\<^bsub>_,_\<^esub> _)" )
where
"e1 \<equiv>\<^bsub>d,H\<^esub> e2
  \<equiv> WHATWHERE_Secure_Programs.dH_indistinguishable ExprEval DA d H e1 e2"

abbreviation htchLoc :: "nat \<Rightarrow> (Dom, ('id,'val) Expr) Hatches"
where
"htchLoc \<iota> \<equiv> WHATWHERE.htchLoc lH \<iota>"

\<comment> \<open>Security typing rules for expressions\<close>
inductive
ExprSecTyping :: "(Dom, ('id,'val) Expr) Hatches
  \<Rightarrow> ('id, 'val) Expr \<Rightarrow> Dom \<Rightarrow> bool"
("_ \<turnstile>\<^bsub>\<E>\<^esub> _ : _")
for H :: "(Dom, ('id, 'val) Expr) Hatches"
where
Consts: "H \<turnstile>\<^bsub>\<E>\<^esub> (Const v) : d" |
Vars: "DA x = d \<Longrightarrow> H \<turnstile>\<^bsub>\<E>\<^esub> (Var x) : d" |
Hatch: "(d,e) \<in> H \<Longrightarrow> H \<turnstile>\<^bsub>\<E>\<^esub> e : d" |
Ops: "\<lbrakk> \<forall>i < length arglist. H \<turnstile>\<^bsub>\<E>\<^esub> (arglist!i) : (dl!i) \<and> (dl!i) \<le> d \<rbrakk>
  \<Longrightarrow> H \<turnstile>\<^bsub>\<E>\<^esub> (Op f arglist) : d"

\<comment> \<open>function substituting a certain expression with another expression
  in expressions\<close>
primrec Subst :: "('id, 'val) Expr \<Rightarrow> ('id, 'val) Expr
  \<Rightarrow> ('id, 'val) Expr \<Rightarrow> ('id, 'val) Expr"
("_<_\\_>")
and SubstL :: "('id, 'val) Expr list \<Rightarrow> ('id, 'val) Expr
  \<Rightarrow> ('id, 'val) Expr \<Rightarrow> ('id, 'val) Expr list"
where
"(Const v)<e1\\e2> = (if e1=(Const v) then e2 else (Const v))" |
"(Var x)<e1\\e2> = (if e1=(Var x) then e2 else (Var x))" |
"(Op f arglist)<e1\\e2> = (if e1=(Op f arglist) then e2 else
  (Op f (SubstL arglist e1 e2)))" |

"SubstL [] e1 e2 = []" |
"SubstL (e#V) e1 e2 = (e<e1\\e2>)#(SubstL V e1 e2)"

definition SubstClosure :: "'id \<Rightarrow> ('id, 'val) Expr \<Rightarrow> bool"
where
"SubstClosure x e \<equiv> \<forall>(d',e',\<iota>') \<in> lH. (d',e'<(Var x)\\e>,\<iota>') \<in> lH"

definition synAssignSC :: "'id \<Rightarrow> ('id, 'val) Expr \<Rightarrow> nat \<Rightarrow> bool"
where
"synAssignSC x e \<iota> \<equiv> \<exists>d. ((htchLoc \<iota>) \<turnstile>\<^bsub>\<E>\<^esub> e : d \<and> d \<le> DA x)
  \<and> (SubstClosure x e)"

definition synWhileSC :: "('id, 'val) Expr \<Rightarrow> bool"
where
"synWhileSC e \<equiv> (\<exists>d. ({} \<turnstile>\<^bsub>\<E>\<^esub> e : d) \<and> (\<forall>d'. d \<le> d'))"

definition synIfSC :: "('id, 'val) Expr
  \<Rightarrow> (('id, 'val) Expr, 'id) MWLsCom
  \<Rightarrow> (('id, 'val) Expr, 'id) MWLsCom \<Rightarrow> bool"
where
"synIfSC e c1 c2 \<equiv> \<exists>d. ({} \<turnstile>\<^bsub>\<E>\<^esub> e : d \<and> (\<forall>d'. d \<le> d'))"

\<comment> \<open>auxiliary lemma for locale interpretation (theorem 7 in original paper)\<close>
lemma ExprTypable_with_smallerd_implies_dH_indistinguishable:
  "\<lbrakk> H \<turnstile>\<^bsub>\<E>\<^esub> e : d'; d' \<le> d \<rbrakk> \<Longrightarrow> e \<equiv>\<^bsub>d,H\<^esub> e"
proof (induct rule: ExprSecTyping.induct,
    simp_all add: WHATWHERE_Secure_Programs.dH_indistinguishable_def
    WHATWHERE.dH_equal_def WHATWHERE.d_equal_def, auto)
  fix dl arglist f m1 m2 d' d
  assume main: "\<forall>i < length arglist.
    (H \<turnstile>\<^bsub>\<E>\<^esub> (arglist!i) : (dl!i)) \<and> (dl!i \<le> d \<longrightarrow>
    (\<forall>m1 m2. (\<forall>x. DA x \<le> d \<longrightarrow> m1 x = m2 x) \<and>
    (\<forall>(d',e)\<in>H. d' \<le> d \<longrightarrow> ExprEval e m1 = ExprEval e m2) \<longrightarrow>
    ExprEval (arglist!i) m1 = ExprEval (arglist!i) m2)) \<and> dl!i \<le> d'"
  assume smaller: "d' \<le> d"
  assume eqeval: "\<forall>(d',e) \<in> H. d' \<le> d \<longrightarrow> ExprEval e m1 = ExprEval e m2"
  assume eqstate: "\<forall>x. DA x \<le> d \<longrightarrow> m1 x = m2 x"

  from main smaller have irangesubst:
    "\<forall>i < length arglist. dl!i \<le> d"
    by (metis order_trans)

  with eqstate eqeval main have
    "\<forall>i < length arglist. ExprEval (arglist!i) m1
       = ExprEval (arglist!i) m2"
    by force

  hence substmap: "(ExprEvalL arglist m1) = (ExprEvalL arglist m2)"
    by (induct arglist, auto, force)

  show "f (ExprEvalL arglist m1) = f (ExprEvalL arglist m2)"
    by (subst substmap, auto)

qed

\<comment> \<open>auxiliary lemma about substitutions in expressions and in memories\<close>
lemma substexp_substmem:
"ExprEval e'<Var x\\e> m = ExprEval e' (m(x := ExprEval e m))
  \<and> ExprEvalL (SubstL elist (Var x) e) m
  = ExprEvalL elist (m(x := ExprEval e m))"
by (induct_tac e' and elist rule: ExprEval.induct ExprEvalL.induct, simp_all)

\<comment> \<open>another auxiliary lemma for locale interpretation (lemma 8 in original paper)\<close>
lemma SubstClosure_implications:
"\<lbrakk> SubstClosure x e; m \<sim>\<^bsub>d,(htchLoc \<iota>')\<^esub> m';
  \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m) =\<^bsub>d\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m') \<rbrakk>
  \<Longrightarrow> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m) \<sim>\<^bsub>d,(htchLoc \<iota>')\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m')"
proof -
  fix m1 m1'
  assume substclosure: "SubstClosure x e"
  assume dequalm2: "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) =\<^bsub>d\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1')"
  assume dhequalm1: "m1 \<sim>\<^bsub>d,(htchLoc \<iota>')\<^esub> m1'"

  from MWLs_semantics.nextmem_exists_and_unique obtain m2 where m1step:
    "(\<exists>p \<alpha>. \<langle>x :=\<^bsub>\<iota>\<^esub> e,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2\<rangle>)
    \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>x :=\<^bsub>\<iota>\<^esub> e,m1\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m2)"
    by force
  hence m2_is_next: "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) = m2"
    by (simp add: WHATWHERE.NextMem_def, auto)
  from m1step MWLs_semantics.MWLsSteps_det.assign
     [of "ExprEval" "e" "m1" _ "x" "\<iota>" "BMap"]
  have m2eq: "m2 = m1(x := (ExprEval e m1))"
    by auto

  from MWLs_semantics.nextmem_exists_and_unique obtain m2' where m1'step:
    "(\<exists>p \<alpha>. \<langle>x :=\<^bsub>\<iota>\<^esub> e,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m2'\<rangle>)
    \<and> (\<forall>m''. (\<exists>p \<alpha>. \<langle>x :=\<^bsub>\<iota>\<^esub> e,m1'\<rangle> \<rightarrow>\<lhd>\<alpha>\<rhd> \<langle>p,m''\<rangle>) \<longrightarrow> m'' = m2')"
    by force
  hence m2'_is_next: "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1') = m2'"
    by (simp add: WHATWHERE.NextMem_def, auto)
  from m1'step MWLs_semantics.MWLsSteps_det.assign
     [of "ExprEval" "e" "m1'" _ "x" "\<iota>" "BMap"]
  have m2'eq: "m2' = m1'(x := (ExprEval e m1'))"
    by auto

  from m2eq substexp_substmem
  have substeval1: "\<forall>e'. ExprEval (e'<Var x\\e>) m1 = ExprEval e' m2"
    by force

  from m2'eq substexp_substmem
  have substeval2: "\<forall>e'. ExprEval e'<Var x\\e> m1' = ExprEval e' m2'"
    by force

  from substclosure have
    "\<forall>(d',e') \<in> htchLoc \<iota>'. (d',e'<Var x\\e>) \<in> (htchLoc \<iota>')"
    by (simp add: SubstClosure_def WHATWHERE.htchLoc_def, auto)

  with dhequalm1 have
    "\<forall>(d',e') \<in> htchLoc \<iota>'.
    d' \<le> d \<longrightarrow> ExprEval e'<Var x\\e> m1 = ExprEval e'<Var x\\e> m1'"
    by (simp add: WHATWHERE.dH_equal_def, auto)

  with substeval1 substeval2 have
    "\<forall>(d',e') \<in> htchLoc \<iota>'.
    d' \<le> d \<longrightarrow> ExprEval e' m2 = ExprEval e' m2'"
    by auto

  with dequalm2 m2_is_next m2'_is_next
  show "\<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1) \<sim>\<^bsub>d,htchLoc \<iota>'\<^esub> \<lbrakk>x :=\<^bsub>\<iota>\<^esub> e\<rbrakk>(m1')"
    by (simp add: WHATWHERE.dH_equal_def)
qed

\<comment> \<open>interpretation of the abstract type system using the above definitions for the side conditions\<close>
interpretation Type_System_example: Type_System ExprEval BMap DA lH
  synAssignSC synWhileSC synIfSC
by (unfold_locales, auto,
  metis ExprTypable_with_smallerd_implies_dH_indistinguishable
  synAssignSC_def,
  metis SubstClosure_implications synAssignSC_def,
  simp add: synWhileSC_def,
  metis ExprTypable_with_smallerd_implies_dH_indistinguishable
  WHATWHERE_Secure_Programs.empH_implies_dHindistinguishable_eq_dindistinguishable,
  simp add: synIfSC_def,
  metis ExprTypable_with_smallerd_implies_dH_indistinguishable
  WHATWHERE_Secure_Programs.empH_implies_dHindistinguishable_eq_dindistinguishable)

end


(*  Title:       Aodv_Basic.thy
    License:     BSD 2-Clause. See LICENSE.
    Author:      Timothy Bourke, Inria
*)

section "Basic data types and constants"

theory Aodv_Basic
imports Main AWN.AWN_SOS
begin

text \<open>These definitions are shared with all variants.\<close>

type_synonym rreqid = nat
type_synonym sqn = nat

datatype k = Known | Unknown
abbreviation kno where "kno \<equiv> Known"
abbreviation unk where "unk \<equiv> Unknown"

datatype p = NoRequestRequired | RequestRequired
abbreviation noreq where "noreq \<equiv> NoRequestRequired"
abbreviation req where "req \<equiv> RequestRequired"

datatype f = Valid | Invalid
abbreviation val where "val \<equiv> Valid"
abbreviation inv where "inv \<equiv> Invalid"

lemma not_ks [simp]:
   "(x \<noteq> kno) = (x = unk)"
   "(x \<noteq> unk) = (x = kno)"
  by (cases x, clarsimp+)+

lemma not_ps [simp]:
  "(x \<noteq> noreq) = (x = req)"
  "(x \<noteq> req) = (x = noreq)"
  by (cases x, clarsimp+)+

lemma not_ffs [simp]:
  "(x \<noteq> val) = (x = inv)"
  "(x \<noteq> inv) = (x = val)"
  by (cases x, clarsimp+)+

end


theory Iterate_GPV imports
  "~~/src/HOL/Library/BNF_Axiomatization"
  "~~/src/HOL/Library/BNF_Corec"
begin

declare [[typedef_overloaded]]

datatype 'a spmf = return_spmf 'a

primrec (transfer) bind_spmf where
  "bind_spmf (return_spmf a) f = f a"

datatype (generat_pures: 'a, generat_outs: 'b, generat_conts: 'c) generat
  = Pure (result: 'a)
  | IO ("output": 'b) (continuation: "'c")

codatatype (results'_gpv: 'a, outs'_gpv: 'out, 'in) gpv
  = GPV (the_gpv: "('a, 'out, 'in \<Rightarrow> ('a, 'out, 'in) gpv) generat spmf")

declare gpv.rel_eq [relator_eq]

primcorec bind_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a \<Rightarrow> ('b, 'out, 'in) gpv) \<Rightarrow> ('b, 'out, 'in) gpv"
where
  "bind_gpv r f = GPV (map_spmf (map_generat id id (op \<circ> (case_sum id (\<lambda>r. bind_gpv r f))))
     (bind_spmf (the_gpv r)
      (case_generat
        (\<lambda>x. map_spmf (map_generat id id (op \<circ> Inl)) (the_gpv (f x)))
        (\<lambda>out c. return_spmf (IO out (\<lambda>input. Inr (c input)))))))"

context includes lifting_syntax begin

lemma bind_gpv_parametric [transfer_rule]:
  "(rel_gpv A C ===> (A ===> rel_gpv B C) ===> rel_gpv B C) bind_gpv bind_gpv"
unfolding bind_gpv_def by transfer_prover

end

lemma [friend_of_corec_simps]:
  "map_spmf f (bind_spmf x h) = bind_spmf x (map_spmf f o h)"
  by (cases x) auto

lemma [friend_of_corec_simps]:
  "bind_spmf (map_spmf f x) h = bind_spmf x (h o f)"
  by (cases x) auto

friend_of_corec bind_gpv :: "('a, 'out, 'in) gpv \<Rightarrow> ('a \<Rightarrow> ('a, 'out, 'in) gpv) \<Rightarrow> ('a, 'out, 'in) gpv"
where "bind_gpv r f = GPV (map_spmf (map_generat id id (op \<circ> (case_sum id (\<lambda>r. bind_gpv r f))))
     (bind_spmf (the_gpv r)
      (case_generat
        (\<lambda>x. map_spmf (map_generat id id (op \<circ> Inl)) (the_gpv (f x)))
        (\<lambda>out c. return_spmf (IO out (\<lambda>input. Inr (c input)))))))"
apply(rule bind_gpv.ctr)
apply transfer_prover
apply transfer_prover
done

end


section \<open>Map Interface\<close>
theory IICF_Map
imports "../../Sepref"
begin

subsection \<open>Parametricity for Maps\<close>
definition [to_relAPP]: "map_rel K V \<equiv> (K \<rightarrow> \<langle>V\<rangle>option_rel)
  \<inter> { (mi,m). dom mi \<subseteq> Domain K \<and> dom m \<subseteq> Range K }"
(*
definition [to_relAPP]: "map_rel K V \<equiv> (K \<rightarrow> \<langle>V\<rangle>option_rel)
  \<inter> { (mi,m). dom mi \<subseteq> Domain K \<and> dom m \<subseteq> Range K
      \<and> ran mi \<subseteq> Domain V \<and> ran m \<subseteq> Range V }"
*)

lemma bi_total_map_rel_eq:
  "\<lbrakk>IS_RIGHT_TOTAL K; IS_LEFT_TOTAL K\<rbrakk> \<Longrightarrow> \<langle>K,V\<rangle>map_rel = K \<rightarrow> \<langle>V\<rangle>option_rel"
  unfolding map_rel_def IS_RIGHT_TOTAL_def IS_LEFT_TOTAL_def
  by (auto dest: fun_relD)

lemma map_rel_empty1_simp[simp]:
  "(Map.empty,m)\<in>\<langle>K,V\<rangle>map_rel \<longleftrightarrow> m=Map.empty"
  apply (auto simp: map_rel_def)
  by (meson RangeE domIff option_rel_simp(1) subsetCE tagged_fun_relD_none)

lemma map_rel_empty2_simp[simp]:
  "(m,Map.empty)\<in>\<langle>K,V\<rangle>map_rel \<longleftrightarrow> m=Map.empty"
  apply (auto simp: map_rel_def)
  by (meson Domain.cases domIff fun_relD2 option_rel_simp(2) subset_eq)

lemma map_rel_obtain1:
  assumes 1: "(m,n)\<in>\<langle>K,V\<rangle>map_rel"
  assumes 2: "n l = Some w"
  obtains k v where "m k = Some v" "(k,l)\<in>K" "(v,w)\<in>V"
  using 1 unfolding map_rel_def
proof clarsimp
  assume R: "(m, n) \<in> K \<rightarrow> \<langle>V\<rangle>option_rel"
  assume "dom n \<subseteq> Range K"
  with 2 obtain k where "(k,l)\<in>K" by auto
  moreover from fun_relD[OF R this] have "(m k, n l) \<in> \<langle>V\<rangle>option_rel" .
  with 2 obtain v where "m k = Some v" "(v,w)\<in>V" by (cases "m k"; auto)
  ultimately show thesis by - (rule that)
qed

lemma map_rel_obtain2:
  assumes 1: "(m,n)\<in>\<langle>K,V\<rangle>map_rel"
  assumes 2: "m k = Some v"
  obtains l w where "n l = Some w" "(k,l)\<in>K" "(v,w)\<in>V"
  using 1 unfolding map_rel_def
proof clarsimp
  assume R: "(m, n) \<in> K \<rightarrow> \<langle>V\<rangle>option_rel"
  assume "dom m \<subseteq> Domain K"
  with 2 obtain l where "(k,l)\<in>K" by auto
  moreover from fun_relD[OF R this] have "(m k, n l) \<in> \<langle>V\<rangle>option_rel" .
  with 2 obtain w where "n l = Some w" "(v,w)\<in>V" by (cases "n l"; auto)
  ultimately show thesis by - (rule that)
qed

subsection \<open>Interface Type\<close>

sepref_decl_intf ('k,'v) i_map is "'k \<rightharpoonup> 'v"

subsection \<open>Operations\<close>
  sepref_decl_op map_empty: "Map.empty" :: "\<langle>K,V\<rangle>map_rel" .

  sepref_decl_op map_is_empty: "(=) Map.empty" :: "\<langle>K,V\<rangle>map_rel \<rightarrow> bool_rel"
    apply (rule fref_ncI)
    apply parametricity
    apply (rule fun_relI; auto)
    done

  sepref_decl_op map_update: "\<lambda>k v m. m(k\<mapsto>v)" :: "K \<rightarrow> V \<rightarrow> \<langle>K,V\<rangle>map_rel \<rightarrow> \<langle>K,V\<rangle>map_rel"
    where "single_valued K" "single_valued (K\<inverse>)"
    apply (rule fref_ncI)
    apply parametricity
    unfolding map_rel_def
    apply (intro fun_relI)
    apply (elim IntE; rule IntI)
    apply (intro fun_relI)
    apply parametricity
    apply (simp add: pres_eq_iff_svb)
    apply auto
    done

  sepref_decl_op map_delete: "\<lambda>k m. fun_upd m k None" :: "K \<rightarrow> \<langle>K,V\<rangle>map_rel \<rightarrow> \<langle>K,V\<rangle>map_rel"
    where "single_valued K" "single_valued (K\<inverse>)"
    apply (rule fref_ncI)
    apply parametricity
    unfolding map_rel_def
    apply (intro fun_relI)
    apply (elim IntE; rule IntI)
    apply (intro fun_relI)
    apply parametricity
    apply (simp add: pres_eq_iff_svb)
    apply auto
    done

  sepref_decl_op map_lookup: "\<lambda>k (m::'k\<rightharpoonup>'v). m k" :: "K \<rightarrow> \<langle>K,V\<rangle>map_rel \<rightarrow> \<langle>V\<rangle>option_rel"
    apply (rule fref_ncI)
    apply parametricity
    unfolding map_rel_def
    apply (intro fun_relI)
    apply (elim IntE)
    apply parametricity
    done

  lemma in_dom_alt: "k\<in>dom m \<longleftrightarrow> \<not>is_None (m k)" by (auto split: option.split)

  sepref_decl_op map_contains_key: "\<lambda>k m. k\<in>dom m" :: "K \<rightarrow> \<langle>K,V\<rangle>map_rel \<rightarrow> bool_rel"
    unfolding in_dom_alt
    apply (rule fref_ncI)
    apply parametricity
    unfolding map_rel_def
    apply (elim IntE)
    apply parametricity
    done

subsection \<open>Patterns\<close>

lemma pat_map_empty[pat_rules]: "\<lambda>\<^sub>2_. None \<equiv> op_map_empty" by simp

lemma pat_map_is_empty[pat_rules]:
  "(=) $m$(\<lambda>\<^sub>2_. None) \<equiv> op_map_is_empty$m"
  "(=) $(\<lambda>\<^sub>2_. None)$m \<equiv> op_map_is_empty$m"
  "(=) $(dom$m)${} \<equiv> op_map_is_empty$m"
  "(=) ${}$(dom$m) \<equiv> op_map_is_empty$m"
  unfolding atomize_eq
  by (auto dest: sym)

lemma pat_map_update[pat_rules]:
  "fun_upd$m$k$(Some$v) \<equiv> op_map_update$'k$'v$'m"
  by simp
lemma pat_map_lookup[pat_rules]: "m$k \<equiv> op_map_lookup$'k$'m"
  by simp

lemma op_map_delete_pat[pat_rules]:
  "(|`) $ m $ (uminus $ (insert $ k $ {})) \<equiv> op_map_delete$'k$'m"
  "fun_upd$m$k$None \<equiv> op_map_delete$'k$'m"
  by (simp_all add: map_upd_eq_restrict)

lemma op_map_contains_key[pat_rules]:
  "(\<in>) $ k $ (dom$m) \<equiv> op_map_contains_key$'k$'m"
  "Not$((=) $(m$k)$None) \<equiv> op_map_contains_key$'k$'m"
   by (auto intro!: eq_reflection)

subsection \<open>Parametricity\<close>

locale map_custom_empty =
  fixes op_custom_empty :: "'k\<rightharpoonup>'v"
  assumes op_custom_empty_def: "op_custom_empty = op_map_empty"
begin
  sepref_register op_custom_empty :: "('kx,'vx) i_map"

  lemma fold_custom_empty:
    "Map.empty = op_custom_empty"
    "op_map_empty = op_custom_empty"
    "mop_map_empty = RETURN op_custom_empty"
    unfolding op_custom_empty_def by simp_all
end

end