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

chapter {* Unsigned words of 32 bits *}

theory Uint32 imports
  Word_Misc
  Bits_Integer
begin

declare prod.Quotient[transfer_rule]

section {* Type definition and primitive operations *}

typedef uint32 = "UNIV :: 32 word set" ..

setup_lifting type_definition_uint32

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

declare Quotient_uint32[transfer_rule]

instantiation uint32 :: "{neg_numeral, Divides.div, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint32 :: uint32 is "0 :: 32 word" .
lift_definition one_uint32 :: uint32 is "1" .
lift_definition plus_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "op + :: 32 word \<Rightarrow> _" .
lift_definition minus_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "op -" .
lift_definition uminus_uint32 :: "uint32 \<Rightarrow> uint32" is uminus .
lift_definition times_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "op *" .
lift_definition divide_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "op div" .
lift_definition mod_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "op mod" .
instance by standard (transfer, simp add: algebra_simps)+
end

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

lemmas [code] = less_uint32.rep_eq less_eq_uint32.rep_eq

instantiation uint32 :: bitss begin
lift_definition bitNOT_uint32 :: "uint32 \<Rightarrow> uint32" is bitNOT .
lift_definition bitAND_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is bitAND .
lift_definition bitOR_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is bitOR .
lift_definition bitXOR_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is bitXOR .
lift_definition test_bit_uint32 :: "uint32 \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint32 :: "uint32 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint32" is set_bit .
lift_definition set_bits_uint32 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint32" is "set_bits" .
lift_definition lsb_uint32 :: "uint32 \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint32 :: "uint32 \<Rightarrow> nat \<Rightarrow> uint32" is shiftl .
lift_definition shiftr_uint32 :: "uint32 \<Rightarrow> nat \<Rightarrow> uint32" is shiftr .
lift_definition msb_uint32 :: "uint32 \<Rightarrow> bool" is msb .
instance ..
end

lemmas [code] = test_bit_uint32.rep_eq lsb_uint32.rep_eq msb_uint32.rep_eq

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

lemmas [code] = equal_uint32.rep_eq

instantiation uint32 :: size begin
lift_definition size_uint32 :: "uint32 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint32.rep_eq

lift_definition sshiftr_uint32 :: "uint32 \<Rightarrow> nat \<Rightarrow> uint32" (infixl ">>>" 55) is sshiftr .

lift_definition uint32_of_int :: "int \<Rightarrow> uint32" is "word_of_int" .

definition uint32_of_nat :: "nat \<Rightarrow> uint32"
where "uint32_of_nat = uint32_of_int \<circ> int"

lift_definition int_of_uint32 :: "uint32 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint32 :: "uint32 \<Rightarrow> nat" is "unat" .

definition integer_of_uint32 :: "uint32 \<Rightarrow> integer"
where "integer_of_uint32 = integer_of_int o int_of_uint32"

lemma bitval_integer_transfer [transfer_rule]:
  "(rel_fun op = pcr_integer) of_bool of_bool"
by(auto simp add: of_bool_def 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 Uint32 :: "integer \<Rightarrow> uint32" is "word_of_int" .

lemma Rep_uint32_numeral [simp]: "Rep_uint32 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint32_def Abs_uint32_inverse numeral.simps plus_uint32_def)

lemma numeral_uint32_transfer [transfer_rule]:
  "(rel_fun op = cr_uint32) numeral numeral"
by(auto simp add: cr_uint32_def)

lemma numeral_uint32 [code_unfold]: "numeral n = Uint32 (numeral n)"
by transfer simp

lemma Rep_uint32_neg_numeral [simp]: "Rep_uint32 (- numeral n) = - numeral n"
by(simp only: uminus_uint32_def)(simp add: Abs_uint32_inverse)

lemma neg_numeral_uint32 [code_unfold]: "- numeral n = Uint32 (- numeral n)"
by transfer(simp add: cr_uint32_def)

end

lemma Abs_uint32_numeral [code_post]: "Abs_uint32 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint32_def numeral.simps plus_uint32_def Abs_uint32_inverse)

lemma Abs_uint32_0 [code_post]: "Abs_uint32 0 = 0"
by(simp add: zero_uint32_def)

lemma Abs_uint32_1 [code_post]: "Abs_uint32 1 = 1"
by(simp add: one_uint32_def)

section {* Code setup *}

code_printing code_module Uint32 \<rightharpoonup> (SML)
{*(* Test that words can handle numbers between 0 and 31 *)
val _ = if 5 <= Word.wordSize then () else raise (Fail ("wordSize less than 5"));

structure Uint32 : sig
  val set_bit : Word32.word -> IntInf.int -> bool -> Word32.word
  val shiftl : Word32.word -> IntInf.int -> Word32.word
  val shiftr : Word32.word -> IntInf.int -> Word32.word
  val shiftr_signed : Word32.word -> IntInf.int -> Word32.word
  val test_bit : Word32.word -> IntInf.int -> bool
end = struct

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

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

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

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

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

end; (* struct Uint32 *)*}
code_reserved SML Uint32

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

type Int32 = Data.Int.Int32;

type Word32 = Data.Word.Word32;*}
code_reserved Haskell Uint32

text {*
  OCaml and Scala provide only signed 32bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
*}
code_printing code_module "Uint32" \<rightharpoonup> (OCaml)
{*module Uint32 : sig
  val less : int32 -> int32 -> bool
  val less_eq : int32 -> int32 -> bool
  val set_bit : int32 -> Big_int.big_int -> bool -> int32
  val shiftl : int32 -> Big_int.big_int -> int32
  val shiftr : int32 -> Big_int.big_int -> int32
  val shiftr_signed : int32 -> Big_int.big_int -> int32
  val test_bit : int32 -> Big_int.big_int -> bool
end = struct

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

let less_eq x y =
  if Int32.compare x Int32.zero < 0 then
    Int32.compare y Int32.zero < 0 && Int32.compare x y <= 0
  else Int32.compare y Int32.zero < 0 || Int32.compare x y <= 0;;

let set_bit x n b =
  let mask = Int32.shift_left Int32.one (Big_int.int_of_big_int n)
  in if b then Int32.logor x mask
     else Int32.logand x (Int32.lognot mask);;

let shiftl x n = Int32.shift_left x (Big_int.int_of_big_int n);;

let shiftr x n = Int32.shift_right_logical x (Big_int.int_of_big_int n);;

let shiftr_signed x n = Int32.shift_right x (Big_int.int_of_big_int n);;

let test_bit x n =
  Int32.compare
    (Int32.logand x (Int32.shift_left Int32.one (Big_int.int_of_big_int n)))
    Int32.zero
  <> 0;;

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

code_printing code_module Uint32 \<rightharpoonup> (Scala)
{*object Uint32 {

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 Uint32 */*}
code_reserved Scala Uint32

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

definition Uint32_signed :: "integer \<Rightarrow> uint32"
where "Uint32_signed i = (if i < -(0x80000000) \<or> i \<ge> 0x80000000 then undefined Uint32 i else Uint32 i)"

lemma Uint32_code [code]:
  "Uint32 i =
  (let i' = i AND 0xFFFFFFFF
   in if i' !! 31 then Uint32_signed (i' - 0x100000000) else Uint32_signed i')"
including undefined_transfer integer.lifting unfolding Uint32_signed_def
by transfer(rule word_of_int_via_signed, simp_all add: bin_mask_numeral)

lemma Uint32_signed_code [code abstract]:
  "Rep_uint32 (Uint32_signed i) =
  (if i < -(0x80000000) \<or> i \<ge> 0x80000000 then Rep_uint32 (undefined Uint32 i) else word_of_int (int_of_integer_symbolic i))"
unfolding Uint32_signed_def Uint32_def int_of_integer_symbolic_def word_of_integer_def
by(simp add: Abs_uint32_inverse)

text {*
  Avoid @{term Abs_uint32} in generated code, use @{term Rep_uint32'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint32}.

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

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

  To convert @{typ "32 word"} values into @{typ uint32}, use @{term "Abs_uint32'"}.
*}

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

lemma Rep_uint32'_transfer [transfer_rule]:
  "rel_fun cr_uint32 op = (\<lambda>x. x) Rep_uint32'"
unfolding Rep_uint32'_def by(rule uint32.rep_transfer)

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

lift_definition Abs_uint32' :: "32 word \<Rightarrow> uint32" is "\<lambda>x :: 32 word. x" .

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

lemma [code, code del]: "term_of_class.term_of = (term_of_class.term_of :: uint32 \<Rightarrow> _)" ..

lemma term_of_uint32_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 ''Uint32.Abs_uint32'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]]], TR (STR ''Uint32.uint32'') []]))
       (term_of_class.term_of (Rep_uint32' x))"
by(simp add: term_of_anything)

code_printing
  type_constructor uint32 \<rightharpoonup>
  (SML) "Word32.word" and
  (Haskell) "Uint32.Word32" and
  (OCaml) "int32" and
  (Scala) "Int" and
  (Eval) "Word32.word"
| constant Uint32 \<rightharpoonup>
  (SML) "Word32.fromLargeInt (IntInf.toLarge _)" and
  (Haskell) "(Prelude.fromInteger _ :: Uint32.Word32)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint32.Word32)" and
  (Scala) "_.intValue"
| constant Uint32_signed \<rightharpoonup>
  (OCaml) "Big'_int.int32'_of'_big'_int"
| constant "0 :: uint32" \<rightharpoonup>
  (SML) "(Word32.fromInt 0)" and
  (Haskell) "(0 :: Uint32.Word32)" and
  (OCaml) "Int32.zero" and
  (Scala) "0"
| constant "1 :: uint32" \<rightharpoonup>
  (SML) "(Word32.fromInt 1)" and
  (Haskell) "(1 :: Uint32.Word32)" and
  (OCaml) "Int32.one" and
  (Scala) "1"
| constant "plus :: uint32 \<Rightarrow> _ " \<rightharpoonup>
  (SML) "Word32.+ ((_), (_))" and
  (Haskell) infixl 6 "+" and
  (OCaml) "Int32.add" and
  (Scala) infixl 7 "+"
| constant "uminus :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.~" and
  (Haskell) "negate" and
  (OCaml) "Int32.neg" and
  (Scala) "!(- _)"
| constant "minus :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.- ((_), (_))" and
  (Haskell) infixl 6 "-" and
  (OCaml) "Int32.sub" and
  (Scala) infixl 7 "-"
| constant "times :: uint32 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.* ((_), (_))" and
  (Haskell) infixl 7 "*" and
  (OCaml) "Int32.mul" and
  (Scala) infixl 8 "*"
| constant "HOL.equal :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Word32.word) = _)" and
  (Haskell) infix 4 "==" and
  (OCaml) "(Int32.compare _ _ = 0)" and
  (Scala) infixl 5 "=="
| class_instance uint32 :: equal \<rightharpoonup>
  (Haskell) -
| constant "less_eq :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word32.<= ((_), (_))" and
  (Haskell) infix 4 "<=" and
  (OCaml) "Uint32.less'_eq" and
  (Scala) "Uint32.less'_eq"
| constant "less :: uint32 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Word32.< ((_), (_))" and
  (Haskell) infix 4 "<" and
  (OCaml) "Uint32.less" and
  (Scala) "Uint32.less"
| constant "bitNOT :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.notb" and
  (Haskell) "Data'_Bits.complement" and
  (OCaml) "Int32.lognot" and
  (Scala) "_.unary'_~"
| constant "bitAND :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.andb ((_),/ (_))" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (OCaml) "Int32.logand" and
  (Scala) infixl 3 "&"
| constant "bitOR :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.orb ((_),/ (_))" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (OCaml) "Int32.logor" and
  (Scala) infixl 1 "|"
| constant "bitXOR :: uint32 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Word32.xorb ((_),/ (_))" and
  (Haskell) "Data'_Bits.xor" and
  (OCaml) "Int32.logxor" and
  (Scala) infixl 2 "^"

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

definition uint32_div :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
where "uint32_div x y = fst (uint32_divmod x y)"

definition uint32_mod :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
where "uint32_mod x y = snd (uint32_divmod x y)"

lemma div_uint32_code [code]: "x div y = (if y = 0 then 0 else uint32_div x y)"
including undefined_transfer unfolding uint32_divmod_def uint32_div_def
by transfer (simp add: word_div_def)

lemma mod_uint32_code [code]: "x mod y = (if y = 0 then x else uint32_mod x y)"
including undefined_transfer unfolding uint32_mod_def uint32_divmod_def
by transfer (simp add: word_mod_def)

definition uint32_sdiv :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"
where [code del]:
  "uint32_sdiv x y =
   (if y = 0 then undefined (op div :: uint32 \<Rightarrow> _) x (0 :: uint32)
    else Abs_uint32 (Rep_uint32 x sdiv Rep_uint32 y))"

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

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

lemma uint32_divmod_code [code]:
  "uint32_divmod x y =
  (if 0x80000000 \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint32 x, mod0_uint32 x)
   else let q = (uint32_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 uint32_divmod_def uint32_sdiv_def div0_uint32_def mod0_uint32_def
by transfer(simp add: divmod_via_sdivmod)

lemma uint32_sdiv_code [code abstract]:
  "Rep_uint32 (uint32_sdiv x y) =
   (if y = 0 then Rep_uint32 (undefined (op div :: uint32 \<Rightarrow> _) x (0 :: uint32))
    else Rep_uint32 x sdiv Rep_uint32 y)"
unfolding uint32_sdiv_def by(simp add: Abs_uint32_inverse)

text {*
  Note that we only need a translation for signed division, but not for the remainder
  because @{thm uint32_divmod_code} computes both with division only.
*}

code_printing
  constant uint32_div \<rightharpoonup>
  (SML) "Word32.div ((_), (_))" and
  (Haskell) "Prelude.div"
| constant uint32_mod \<rightharpoonup>
  (SML) "Word32.mod ((_), (_))" and
  (Haskell) "Prelude.mod"
| constant uint32_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint32_sdiv \<rightharpoonup>
  (OCaml) "Int32.div" and
  (Scala) "_ '/ _"

definition uint32_test_bit :: "uint32 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint32_test_bit x n =
  (if n < 0 \<or> 31 < n then undefined (test_bit :: uint32 \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint32_code [code]:
  "test_bit x n \<longleftrightarrow> n < 32 \<and> uint32_test_bit x (integer_of_nat n)"
including undefined_transfer integer.lifting unfolding uint32_test_bit_def
by transfer(auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint32_test_bit_code [code]:
  "uint32_test_bit w n =
  (if n < 0 \<or> 31 < n then undefined (test_bit :: uint32 \<Rightarrow> _) w n else Rep_uint32 w !! nat_of_integer n)"
unfolding uint32_test_bit_def
by(simp add: test_bit_uint32.rep_eq)

code_printing constant uint32_test_bit \<rightharpoonup>
  (SML) "Uint32.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (OCaml) "Uint32.test'_bit" and
  (Scala) "Uint32.test'_bit"

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

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

lemma uint32_set_bit_code [code abstract]:
  "Rep_uint32 (uint32_set_bit w n b) =
  (if n < 0 \<or> 31 < n then Rep_uint32 (undefined (set_bit :: uint32 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint32 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint32_set_bit_def by transfer simp

code_printing constant uint32_set_bit \<rightharpoonup>
  (SML) "Uint32.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (OCaml) "Uint32.set'_bit" and
  (Scala) "Uint32.set'_bit"

lift_definition uint32_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint32 \<Rightarrow> nat \<Rightarrow> uint32" is set_bits_aux .

lemma uint32_set_bits_code [code]:
  "uint32_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint32_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_uint32 [code]:
  "(BITS n. f n) = uint32_set_bits f 0 32"
by transfer(simp add: set_bits_conv_set_bits_aux)

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

definition uint32_shiftl :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
where [code del]:
  "uint32_shiftl x n = (if n < 0 \<or> 32 \<le> n then undefined (shiftl :: uint32 \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint32_code [code]: "x << n = (if n < 32 then uint32_shiftl x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint32_shiftl_def
by transfer(simp add: not_less shiftl_zero_size word_size)

lemma uint32_shiftl_code [code abstract]:
  "Rep_uint32 (uint32_shiftl w n) =
  (if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined (shiftl :: uint32 \<Rightarrow> _) w n) else Rep_uint32 w << (nat_of_integer n))"
including undefined_transfer unfolding uint32_shiftl_def by transfer simp

code_printing constant uint32_shiftl \<rightharpoonup>
  (SML) "Uint32.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (OCaml) "Uint32.shiftl" and
  (Scala) "Uint32.shiftl"

definition uint32_shiftr :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
where [code del]:
  "uint32_shiftr x n = (if n < 0 \<or> 32 \<le> n then undefined (shiftr :: uint32 \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint32_code [code]: "x >> n = (if n < 32 then uint32_shiftr x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint32_shiftr_def
by transfer(simp add: not_less shiftr_zero_size word_size)

lemma uint32_shiftr_code [code abstract]:
  "Rep_uint32 (uint32_shiftr w n) =
  (if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined (shiftr :: uint32 \<Rightarrow> _) w n) else Rep_uint32 w >> nat_of_integer n)"
including undefined_transfer unfolding uint32_shiftr_def by transfer simp

code_printing constant uint32_shiftr \<rightharpoonup>
  (SML) "Uint32.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (OCaml) "Uint32.shiftr" and
  (Scala) "Uint32.shiftr"

definition uint32_sshiftr :: "uint32 \<Rightarrow> integer \<Rightarrow> uint32"
where [code del]:
  "uint32_sshiftr x n =
  (if n < 0 \<or> 32 \<le> n then undefined sshiftr_uint32 x n else sshiftr_uint32 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_uint32_code [code]:
  "x >>> n =
  (if n < 32 then uint32_sshiftr x (integer_of_nat n) else if x !! 31 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint32_sshiftr_def
by transfer(simp add: not_less sshiftr_beyond word_size)

lemma uint32_sshiftr_code [code abstract]:
  "Rep_uint32 (uint32_sshiftr w n) =
  (if n < 0 \<or> 32 \<le> n then Rep_uint32 (undefined sshiftr_uint32 w n) else Rep_uint32 w >>> (nat_of_integer n))"
including undefined_transfer unfolding uint32_sshiftr_def by transfer simp

code_printing constant uint32_sshiftr \<rightharpoonup>
  (SML) "Uint32.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint32.Int32) _)) :: Uint32.Word32)" and
  (OCaml) "Uint32.shiftr'_signed" and
  (Scala) "Uint32.shiftr'_signed"

lemma uint32_msb_test_bit: "msb x \<longleftrightarrow> (x :: uint32) !! 31"
by transfer(simp add: msb_nth)

lemma msb_uint32_code [code]: "msb x \<longleftrightarrow> uint32_test_bit x 31"
by(simp add: uint32_test_bit_def uint32_msb_test_bit)

lemma uint32_of_int_code [code]: "uint32_of_int i = Uint32 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint32_code [code]:
  "int_of_uint32 x = int_of_integer (integer_of_uint32 x)"
by(simp add: integer_of_uint32_def)

lemma nat_of_uint32_code [code]:
  "nat_of_uint32 x = nat_of_integer (integer_of_uint32 x)"
unfolding integer_of_uint32_def including integer.lifting by transfer (simp add: unat_def)

definition integer_of_uint32_signed :: "uint32 \<Rightarrow> integer"
where
  "integer_of_uint32_signed n = (if n !! 31 then undefined integer_of_uint32 n else integer_of_uint32 n)"

lemma integer_of_uint32_signed_code [code]:
  "integer_of_uint32_signed n =
  (if n !! 31 then undefined integer_of_uint32 n else integer_of_int (uint (Rep_uint32' n)))"
unfolding integer_of_uint32_signed_def integer_of_uint32_def
including undefined_transfer by transfer simp

lemma integer_of_uint32_code [code]:
  "integer_of_uint32 n =
  (if n !! 31 then integer_of_uint32_signed (n AND 0x7FFFFFFF) OR 0x80000000 else integer_of_uint32_signed n)"
unfolding integer_of_uint32_def integer_of_uint32_signed_def o_def
including undefined_transfer integer.lifting
by transfer(auto simp add: word_ao_nth uint_and_mask_or_full mask_numeral mask_Suc_0 intro!: uint_and_mask_or_full[symmetric])

code_printing
  constant "integer_of_uint32" \<rightharpoonup>
  (SML) "IntInf.fromLarge (Word32.toLargeInt _) : IntInf.int" and
  (Haskell) "Prelude.toInteger"
| constant "integer_of_uint32_signed" \<rightharpoonup>
  (OCaml) "Big'_int.big'_int'_of'_int32" and
  (Scala) "BigInt"

section {* Quickcheck setup *}

definition uint32_of_natural :: "natural \<Rightarrow> uint32"
where "uint32_of_natural x \<equiv> Uint32 (integer_of_natural x)"

instantiation uint32 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint32 \<equiv> qc_random_cnv uint32_of_natural"
definition "exhaustive_uint32 \<equiv> qc_exhaustive_cnv uint32_of_natural"
definition "full_exhaustive_uint32 \<equiv> qc_full_exhaustive_cnv uint32_of_natural"
instance ..
end

instantiation uint32 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint32 i in (x, 0xFFFFFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint32.uint32'') []" .

definition "narrowing_uint32 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint32 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint32 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint32 (infixl ">>>" 55)

end


section \<open> Weak Bisimulation \<close>

theory ITree_Weak_Bisim
  imports ITree_Divergence
begin

text \<open> See Hennessy's paper relating CCS and CSP. If you forget divergence, i+1 equivalence and
  its limit. 2.5 equivalence. "ON THE RELATIONSHIP OF CCS AND CSP". \<close>

inductive wbisim_to :: "('e, 's) itree \<Rightarrow> (('e, 's) itree \<Rightarrow> ('e, 's) itree \<Rightarrow> bool) \<Rightarrow> ('e, 's) itree \<Rightarrow> bool" (infix "\<approx>\<^bsub>_\<^esub>" 50) where
wbisim_to_Ret [intro]: "Ret x \<approx>\<^bsub>\<R>\<^esub> Ret x" |
wbisim_to_Sil1 [intro]: "P \<approx>\<^bsub>\<R>\<^esub> Q \<Longrightarrow> Sil P \<approx>\<^bsub>\<R>\<^esub> Q" |
wbisim_to_Sil2 [intro]: "P \<approx>\<^bsub>\<R>\<^esub> Q \<Longrightarrow> P \<approx>\<^bsub>\<R>\<^esub> Sil Q" |
wbisim_to_Vis [intro]: "\<lbrakk> pdom(F) = pdom(G); \<And> e. e \<in> pdom(F) \<Longrightarrow> \<R> (F e) (G e) \<rbrakk> \<Longrightarrow> Vis F \<approx>\<^bsub>\<R>\<^esub> Vis G"

inductive_cases
  wbisim_RetE [elim]: "Ret x \<approx>\<^bsub>\<R>\<^esub> P" and
  wbisim_SilE [elim]: "Sil P \<approx>\<^bsub>\<R>\<^esub> Q"

thm wbisim_SilE

lemma monotonic_wbisim_to: "P \<approx>\<^bsub>\<R>\<^sub>1\<^esub> Q \<Longrightarrow> \<R>\<^sub>1 \<le> \<R>\<^sub>2 \<Longrightarrow> P \<approx>\<^bsub>\<R>\<^sub>2\<^esub> Q"
  by (induct rule: wbisim_to.induct, auto)

lemma mono_wbisim_to [mono add]: "\<R>\<^sub>1 \<le> \<R>\<^sub>2 \<Longrightarrow> (\<lambda> P Q. P \<approx>\<^bsub>\<R>\<^sub>1\<^esub> Q) \<le> (\<lambda> P Q. P \<approx>\<^bsub>\<R>\<^sub>2\<^esub> Q)"
  using monotonic_wbisim_to by auto

lemma wbisim_to_Sils1 [intro]: "P \<approx>\<^bsub>\<R>\<^esub> Q \<Longrightarrow> Sils n P \<approx>\<^bsub>\<R>\<^esub> Q"
  by (induct n, auto)

lemma wbisim_to_Sils2 [intro]: "P \<approx>\<^bsub>\<R>\<^esub> Q \<Longrightarrow> P \<approx>\<^bsub>\<R>\<^esub> Sils n Q"
  by (induct n, auto)

lemma wbisim_toD:
  "P \<approx>\<^bsub>\<R>\<^esub> Q \<Longrightarrow>
  ((\<exists> m n x. P = Sils m (Ret x) \<and> Q = Sils n (Ret x))
   \<or> (\<exists> m n F G. P = Sils m (Vis F) \<and> Q = Sils n (Vis G) \<and> pdom(F) = pdom(G) \<and> (\<forall> e \<in> pdom(F). \<R> (F e) (G e))))"
  by (induct rule: wbisim_to.induct, auto, (metis (full_types) Sils.simps(1) Sils.simps(2))+)[1]

lemma wbisim_toE [elim]:
  assumes "P \<approx>\<^bsub>\<R>\<^esub> Q"
  "\<And> m n x. \<lbrakk> P = Sils m (Ret x); Q = Sils n (Ret x) \<rbrakk> \<Longrightarrow> R"
  "\<And> m n F G. \<lbrakk> P = Sils m (Vis F); Q = Sils n (Vis G); pdom(F) = pdom(G); (\<forall> e \<in> pdom(F). \<R> (F e) (G e)) \<rbrakk> \<Longrightarrow> R"
  shows R
  using assms by (auto dest: wbisim_toD)

lemma wbisim_to_SilD1: "(\<tau> P \<approx>\<^bsub>\<R>\<^esub> Q) \<Longrightarrow> (P \<approx>\<^bsub>\<R>\<^esub> Q)"
  apply (erule wbisim_toE)
  apply (auto)
  apply (metis (no_types, lifting) Sils.elims itree.distinct(1) itree.sel(2) wbisim_to_Ret wbisim_to_Sils1 wbisim_to_Sils2)
  apply (metis (no_types, opaque_lifting) itree.disc(8) itree.disc(9) wbisim_SilE wbisim_to_Sils1 wbisim_to_Sils2 wbisim_to_Vis)
  done

lemma wbisim_to_Sil_iff1 [simp]: "(\<tau> P \<approx>\<^bsub>\<R>\<^esub> Q) \<longleftrightarrow> (P \<approx>\<^bsub>\<R>\<^esub> Q)"
  by (metis wbisim_to_Sil1 wbisim_to_SilD1)

lemma wbisim_to_Sils_iff1 [simp]: "(Sils n P \<approx>\<^bsub>\<R>\<^esub> Q) \<longleftrightarrow> (P \<approx>\<^bsub>\<R>\<^esub> Q)"
  by (induct n, auto)

lemma wbisim_to_SilD2: "(P \<approx>\<^bsub>\<R>\<^esub> \<tau> Q) \<Longrightarrow> (P \<approx>\<^bsub>\<R>\<^esub> Q)"
  apply (erule wbisim_toE)
  apply (auto)
  apply (metis (no_types, lifting) Sils.elims itree.distinct(1) itree.sel(2) wbisim_to_Ret wbisim_to_Sils1 wbisim_to_Sils2)
  apply (metis (no_types, lifting) Sils.elims itree.disc(8) itree.disc(9) itree.sel(2) wbisim_to_Sils1 wbisim_to_Sils2 wbisim_to_Vis)
  done

lemma wbisim_to_Sil_iff2 [simp]: "(P \<approx>\<^bsub>\<R>\<^esub> \<tau> Q) \<longleftrightarrow> (P \<approx>\<^bsub>\<R>\<^esub> Q)"
  by (metis wbisim_to_Sil2 wbisim_to_SilD2)

lemma wbisim_to_Sils_iff2 [simp]: "(P \<approx>\<^bsub>\<R>\<^esub> Sils n Q) \<longleftrightarrow> (P \<approx>\<^bsub>\<R>\<^esub> Q)"
  by (induct n, auto)

lemma wbisim_to_ndiv1 [elim]: "diverge \<approx>\<^bsub>\<R>\<^esub> P \<Longrightarrow> False"
  apply (erule wbisim_toE)
  apply (metis div_free_Ret div_free_Sils div_free_diverge)
  apply (metis (no_types, opaque_lifting) Sils_diverge Sils_injective diverge_not_Vis)
  done

lemma wbisim_to_ndiv2 [elim]: "P \<approx>\<^bsub>\<R>\<^esub> diverge \<Longrightarrow> False"
  apply (erule wbisim_toE)
  apply (metis div_free_Ret div_free_Sils div_free_diverge)
  apply (metis (no_types, opaque_lifting) Sils_diverge Sils_injective diverge_not_Vis)
  done

coinductive wbisim :: "('e, 's) itree \<Rightarrow> ('e, 's) itree \<Rightarrow> bool" (infix "\<approx>" 50) where
wbisim_divI: "diverge \<approx> diverge" | \<comment> \<open> Can we eliminate this? \<close>
wbisimI: "P \<approx>\<^bsub>(\<approx>)\<^esub> Q \<Longrightarrow> P \<approx> Q"

lemma diverge_wbisim1: "diverge \<approx> Q \<Longrightarrow> Q = diverge"
  apply (coinduction rule: itree_strong_coind)
  apply (metis diverge.disc_iff wbisim.cases wbisim_to_ndiv1)
  apply (metis diverge_not_Ret)
  apply (metis itree.inject(2) wbisim.cases wbisim_to_ndiv1)
  apply (metis diverge_not_Vis)
  done

lemma diverge_wbisim2: "P \<approx> diverge \<Longrightarrow> P = diverge"
  apply (coinduction rule: itree_strong_coind)
  apply (metis (no_types, lifting) wbisim.cases wbisim_to_ndiv2)
  apply (metis diverge_not_Ret)
  apply (metis itree.inject(2) wbisim.cases wbisim_to_ndiv2)
  apply (metis diverge_not_Vis)
  done

lemma wbisim_refl [intro]: "P \<approx> P"
proof (cases "divergent P")
  case True
  then show ?thesis
    by (metis (mono_tags, opaque_lifting) diverges_then_diverge wbisim_divI)
next
  case False
  then show ?thesis
    apply (auto)
    apply (coinduction arbitrary: P)
    apply (auto)
    apply (smt (verit, best) diverges_diverge diverges_implies_equal itree.collapse(1) itree.collapse(3) itree.exhaust_disc stabilises_def wbisim_divI wbisim_to.intros(1) wbisim_to_Sils1 wbisim_to_Sils2 wbisim_to_Vis)
    done
qed

lemma wbisim_sym [intro]: "P \<approx> Q \<Longrightarrow> Q \<approx> P"
  apply (case_tac "P = diverge")
  apply (simp)
   apply (metis (no_types, opaque_lifting) diverge_wbisim1)
  apply (case_tac "Q = diverge")
   apply (simp)
   apply (metis (no_types, opaque_lifting) diverge_wbisim2)
  apply (coinduction arbitrary: P Q)
  apply (auto elim!: wbisim.cases wbisim_toE intro!: wbisim_to_Sils1 wbisim_to_Sils2 wbisim_to_Vis)
  apply (metis diverge_wbisim1)
  apply (metis diverge_wbisim2)
  done

lemma wbisim_SilI1 [intro]: "P \<approx> Q \<Longrightarrow> \<tau> P \<approx> Q"
  by (metis diverge.code wbisim.cases wbisimI wbisim_to_Sil1)

lemma wbisim_SilI2 [intro]: "P \<approx> Q \<Longrightarrow> P \<approx> \<tau> Q"
  by (metis (no_types, opaque_lifting) wbisim_SilI1 wbisim_sym)

lemma Sil_wbisim_iff1 [simp]: "\<tau> P \<approx> Q \<longleftrightarrow> P \<approx> Q"
proof
  show "P \<approx> Q \<Longrightarrow> \<tau> P \<approx> Q" by auto
next
  assume \<tau>: "\<tau> P \<approx> Q"
  show "P \<approx> Q"
  proof (cases "divergent P")
    case True
    with \<tau> show ?thesis
      by (metis (no_types, opaque_lifting) diverge.code diverges_then_diverge)
  next
    case False
    with \<tau> have stb: "stabilises Q"
      by (metis (no_types, opaque_lifting) diverge_wbisim2 diverges_then_diverge stabilises_Sil)
    with \<tau> show ?thesis
      by (metis diverges_then_diverge wbisim.simps wbisim_to_SilD1)
  qed
qed

lemma Sil_wbisim_iff2 [simp]: "P \<approx> \<tau> Q \<longleftrightarrow> P \<approx> Q"
  by (metis Sil_wbisim_iff1 wbisim_sym)

lemma wbisim_Sils_iff1 [simp]: "Sils n P \<approx> Q \<longleftrightarrow> P \<approx> Q"
  by (metis Sils_diverge Sils_injective wbisim.simps wbisim_to_Sils_iff1)

lemma wbisim_Sils_iff2 [simp]: "P \<approx> Sils n Q \<longleftrightarrow> P \<approx> Q"
  by (metis (mono_tags, opaque_lifting) wbisim_Sils_iff1 wbisim_sym)

lemma wbisim_Sils [intro]: "P \<approx> Q \<Longrightarrow> Sils n P \<approx> Q"
  by (induct n, auto)

lemma wbisim_bothVisI [intro]: "\<lbrakk> pdom(F) = pdom(G); \<And> e. e \<in> pdom(F) \<Longrightarrow> (F e) \<approx> (G e) \<rbrakk> \<Longrightarrow> Vis F \<approx> Vis G"
  by (rule wbisimI, force)

lemma wbisim_both_VisE [elim]: "\<lbrakk> Vis F \<approx> Vis G; \<lbrakk> pdom(F) = pdom(G); \<And> e. e \<in> pdom(F) \<Longrightarrow> (F e) \<approx> (G e) \<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  by (auto elim: wbisim.cases wbisim_to.cases)

lemma wbisim_Vis_eq:
  "\<lbrakk> Vis F \<approx> Q \<rbrakk> \<Longrightarrow> \<exists> n G. Q = Sils n (Vis G) \<and> pdom(F) = pdom(G) \<and> (\<forall> e \<in> pdom(F). (F e) \<approx> (G e))"
  by (auto elim!: wbisim.cases)
     (smt (verit, best) Vis_not_Sils_Ret wbisimI wbisim_Sils_iff2 wbisim_both_VisE wbisim_toD)

lemma wbisim_VisE:
  assumes "Vis F \<approx> Q" "\<And> n G. \<lbrakk> Q = Sils n (Vis G); pdom(F) = pdom(G); \<And> e. e \<in> pdom(F) \<Longrightarrow> (F e) \<approx> (G e) \<rbrakk> \<Longrightarrow> R"
  shows R
  by (metis (mono_tags, lifting) assms(1) assms(2) wbisim_Vis_eq)

lemma wbisim_trans:
  assumes "P \<approx> Q" "Q \<approx> R"
  shows "P \<approx> R"
proof (cases "divergent P")
  case True
  then show ?thesis
    by (metis assms(1) assms(2) diverges_then_diverge wbisim.cases wbisim_to_ndiv1)
next
  case False
  with assms have stbs: "stabilises P" "stabilises Q" "stabilises R"
    apply (metis (no_types, opaque_lifting))
    apply (metis (mono_tags, lifting) False assms(1) diverge_wbisim2 diverges_then_diverge)
    apply (metis (mono_tags, lifting) False assms(1) assms(2) diverge_wbisim2 diverges_then_diverge)
    done
  with assms show ?thesis
    apply (coinduction arbitrary: P Q R)
    apply (auto elim!: wbisim.cases wbisim_toE intro!: wbisim_to_Sils1 wbisim_to_Sils2 wbisim_to_Vis)
    apply (metis (no_types, opaque_lifting) diverge_wbisim1 diverge_wbisim2 diverges_then_diverge)
    apply (metis diverge_wbisim1 diverge_wbisim2 diverges_then_diverge)
    done
qed

lemma wbisim_coind:
  assumes
    "\<R> P Q"
    "\<And> P Q. \<R> P Q \<Longrightarrow> \<R> Q P"
    "\<And> P. \<R> diverge P \<Longrightarrow> P = diverge"
    "\<And> n P Q. \<R> (Sils n P) Q \<Longrightarrow> \<R> P Q"
    "\<And> P Q. \<lbrakk> \<R> P Q; stable P; stable Q \<rbrakk> \<Longrightarrow> (is_Vis P \<longleftrightarrow> is_Vis Q) \<and> (is_Ret P \<longleftrightarrow> is_Ret Q)"
    "\<And> F G. \<R> (Vis F) (Vis G) \<Longrightarrow> pdom F = pdom G \<and> (\<forall> e \<in> pdom(F). \<R> (F e) (G e))"
    "\<And> x y. \<R> (Ret x) (Ret y) \<Longrightarrow> x = y"
  shows "P \<approx> Q"
proof (rule wbisim.coinduct[of \<R>, OF assms(1)], simp)
  fix P Q
  assume PQ: "\<R> P Q"
  show "P = diverge \<and> Q = diverge \<or> P \<approx>\<^bsub>(\<lambda> x y. \<R> x y \<or> x \<approx> y)\<^esub> Q"
  proof (cases "divergent P")
  case True
  then show ?thesis
    by (metis PQ assms(3) diverges_then_diverge)
  next
    case False
    hence ndiv: "P \<noteq> diverge \<and> Q \<noteq> diverge"
      by (metis (no_types, lifting) PQ assms(2) assms(3) diverges_then_diverge)
    have "P \<approx>\<^bsub>(\<lambda>x y. \<R> x y \<or> x \<approx> y)\<^esub> Q"
    proof (cases P rule: itree_cases)
      case (Vis m F)
      hence R1: "\<R> (Vis F) Q"
        by (metis PQ assms(4))
      obtain n Q' where Q: "Q = Sils n Q'" "stable Q'"
        by (metis diverges_then_diverge ndiv stabilises_def)
      hence "\<R> (Vis F) Q'"
        by (metis (no_types, lifting) R1 assms(2) assms(4))
      then obtain G where Q': "Q' = Vis G"
        by (metis (no_types, lifting) \<open>stable Q'\<close> assms(5) is_VisE itree.disc(9) stable_Vis)
      have "pdom(F) = pdom(G)"
        by (metis (mono_tags, lifting) \<open>Q' = Vis G\<close> \<open>\<R> (Vis F) Q'\<close> assms(6))
      moreover have "(\<forall> e \<in> pdom(F). \<R> (F e) (G e))"
        by (metis (no_types, lifting) Q' \<open>\<R> (Vis F) Q'\<close> assms(6))
      ultimately have "P \<approx>\<^bsub>\<R>\<^esub> Q"
        by (metis Q' Q(1) Vis wbisim_to_Sils1 wbisim_to_Sils2 wbisim_to_Vis)
      thus ?thesis
        by (metis (mono_tags, lifting) monotonic_wbisim_to predicate2I)
    next
      case (Ret m x)
      then obtain n y where "Q = Sils n (Ret y)"
        by (metis (no_types, opaque_lifting) PQ assms(2) assms(4) assms(5) itree.disc(4) itree.disc(7) itree.disc(9) itree.distinct_disc(6) itree_disj_cases ndiv)
      with Ret show ?thesis
        by (metis (no_types, lifting) PQ assms(2) assms(4) assms(7) wbisim_to_Ret wbisim_to_Sils1 wbisim_to_Sils2)
    next
      case diverge
      then show ?thesis
        by (metis ndiv)
    qed
    thus ?thesis
      by metis
  qed
qed

lemma wbisim_coind_Sil:
  assumes
    "\<R> P Q"
    "\<And> P Q. \<R> P Q \<Longrightarrow> \<R> Q P"
    "\<And> P. \<R> diverge P \<Longrightarrow> P = diverge"
    "\<And> P Q. \<R> (Sil P) Q \<Longrightarrow> \<R> P Q"
    "\<And> P Q. \<lbrakk> \<R> P Q; stable P; stable Q \<rbrakk> \<Longrightarrow> (is_Vis P \<longleftrightarrow> is_Vis Q) \<and> (is_Ret P \<longleftrightarrow> is_Ret Q)"
    "\<And> F G. \<R> (Vis F) (Vis G) \<Longrightarrow> pdom F = pdom G \<and> (\<forall> e \<in> pdom(F). \<R> (F e) (G e))"
    "\<And> x y. \<R> (Ret x) (Ret y) \<Longrightarrow> x = y"
  shows "P \<approx> Q"
  using assms
  apply (rule_tac wbisim_coind[of \<R>])
        apply (assumption)
       apply (assumption)
      apply (assumption)
  subgoal premises prems for n P Q
    using prems(4,8)
    apply (induct n)
     apply (simp_all)
    done
    apply assumption+
  done

lemma wbisim_strong_coind:
  assumes
    "\<R> P Q"
    "\<And> P Q. \<R> P Q \<Longrightarrow> \<R> Q P"
    "\<And> P. \<R> diverge P \<Longrightarrow> P = diverge"
    "\<And> n P Q. \<R> (Sils n P) Q \<Longrightarrow> \<R> P Q \<or> P \<approx> Q"
    "\<And> P Q. \<lbrakk> \<R> P Q; stable P; stable Q \<rbrakk> \<Longrightarrow> (is_Vis P \<longleftrightarrow> is_Vis Q) \<and> (is_Ret P \<longleftrightarrow> is_Ret Q)"
    "\<And> F G. \<R> (Vis F) (Vis G) \<Longrightarrow> pdom F = pdom G \<and> (\<forall> e \<in> pdom(F). \<R> (F e) (G e) \<or> (F e) \<approx> (G e))"
    "\<And> x y. \<R> (Ret x) (Ret y) \<Longrightarrow> x = y"
  shows "P \<approx> Q"
  apply (rule wbisim_coind[of "\<lambda> x y. \<R> x y \<or> x \<approx> y"])
  apply (simp_all add: assms)
  apply (metis (mono_tags, lifting) assms(2) wbisim_sym)
  apply (metis (full_types) assms(3) diverge_wbisim1)
  apply (metis (mono_tags, lifting) assms(4))
  apply (metis (no_types, lifting) assms(5) itree.case_eq_if itree.disc(5) itree.disc(9) itree.disc_eq_case(3) wbisim.cases wbisim_to.simps)
  apply (metis assms(6) wbisim_both_VisE)
  apply (metis (no_types, lifting) assms(7) itree.distinct(1) itree.inject(1) wbisim.cases wbisim_RetE)
  done

lemma wbisim_strong_Sil_coind:
  assumes
    "\<R> P Q"
    "\<And> P Q. \<R> P Q \<Longrightarrow> \<R> Q P"
    "\<And> P. \<R> diverge P \<Longrightarrow> P = diverge"
    "\<And> P Q. \<R> (Sil P) Q \<Longrightarrow> \<R> P Q \<or> P \<approx> Q"
    "\<And> P Q. \<lbrakk> \<R> P Q; stable P; stable Q \<rbrakk> \<Longrightarrow> (is_Vis P \<longleftrightarrow> is_Vis Q) \<and> (is_Ret P \<longleftrightarrow> is_Ret Q)"
    "\<And> F G. \<R> (Vis F) (Vis G) \<Longrightarrow> pdom F = pdom G \<and> (\<forall> e \<in> pdom(F). \<R> (F e) (G e) \<or> (F e) \<approx> (G e))"
    "\<And> x y. \<R> (Ret x) (Ret y) \<Longrightarrow> x = y"
  shows "P \<approx> Q"
  apply (rule wbisim_coind_Sil[of "\<lambda> x y. \<R> x y \<or> x \<approx> y"])
  apply (simp_all add: assms)
  apply (metis (mono_tags, lifting) assms(2) wbisim_sym)
  apply (metis (full_types) assms(3) diverge_wbisim1)
  apply (metis (mono_tags, lifting) assms(4))
  apply (metis (no_types, lifting) assms(5) itree.case_eq_if itree.disc(5) itree.disc(9) itree.disc_eq_case(3) wbisim.cases wbisim_to.simps)
  apply (metis assms(6) wbisim_both_VisE)
  apply (metis (no_types, lifting) assms(7) itree.distinct(1) itree.inject(1) wbisim.cases wbisim_RetE)
  done

lemma wbisim_trace_to_Nil: "P \<midarrow>[]\<leadsto> P' \<Longrightarrow> P \<approx> P'"
  by auto

lemma wbisim_step_rule:
  assumes
    "\<forall> tr P'. P \<midarrow>tr\<leadsto> P' \<longrightarrow> (\<exists> Q'. Q \<midarrow>tr\<leadsto> Q' \<and> P' \<approx> Q')"
    "\<forall> tr Q'. Q \<midarrow>tr\<leadsto> Q' \<longrightarrow> (\<exists> P'. P \<midarrow>tr\<leadsto> P' \<and> P' \<approx> Q')"
  shows "P \<approx> Q"
  by (metis (mono_tags, lifting) assms(1) trace_to_Nil wbisim_sym wbisim_trace_to_Nil wbisim_trans)

lemma wbsim_silent_step: "\<lbrakk> P \<approx> Q; P \<midarrow>[]\<leadsto> P' \<rbrakk> \<Longrightarrow> \<exists> Q'. Q \<midarrow>[]\<leadsto> Q' \<and> P' \<approx> Q'"
  by (metis (mono_tags, lifting) trace_to_Nil wbisim_sym wbisim_trace_to_Nil wbisim_trans)

lemma wbisim_single_step: "\<lbrakk> P \<approx> Q; P \<midarrow>[e]\<leadsto> P' \<rbrakk> \<Longrightarrow> \<exists> Q'. Q \<midarrow>[e]\<leadsto> Q' \<and> P' \<approx> Q'"
  apply (erule trace_to_singleE)
  apply (auto elim!: trace_to_singleE wbisim_VisE)
  apply (metis (no_types, lifting) trace_of_Sils wbsim_silent_step)
  done

lemma wbisim_step: "\<lbrakk> P \<approx> Q; P \<midarrow>tr\<leadsto> P' \<rbrakk> \<Longrightarrow> \<exists> Q'. Q \<midarrow>tr\<leadsto> Q' \<and> P' \<approx> Q'"
  apply (induct tr arbitrary: P Q P')
   apply (metis wbsim_silent_step)
  apply (erule trace_to_ConsE)
  apply (erule trace_to_ConsE)
  apply (auto elim!: wbisim_VisE)
  apply (metis (no_types, opaque_lifting) trace_to_NilE wbisim_Sils_iff1)
  done

lemma wbisim_silent_step_terminate: "\<lbrakk> P \<approx> Q; P \<midarrow>[]\<leadsto> Ret x \<rbrakk> \<Longrightarrow> Q \<midarrow>[]\<leadsto> Ret x"
  by (auto elim!: wbisim.cases)
     (smt (verit, best) Sils_Vis_not_Ret Sils_to_Ret trace_to_Nil_Sils wbisim_toD)

lemma wbisim_single_step_terminate: "\<lbrakk> P \<approx> Q; P \<midarrow>[e]\<leadsto> Ret x \<rbrakk> \<Longrightarrow> Q \<midarrow>[e]\<leadsto> Ret x"
  apply (erule trace_to_singleE)
  apply (auto elim!: trace_to_singleE wbisim_VisE)
  apply (metis (no_types, opaque_lifting) Sils_Vis_not_Ret termination_determinsitic trace_of_Sils wbisim.cases wbisim_toD)
  done

lemma wbisim_step_terminate: "\<lbrakk> P \<approx> Q; P \<midarrow>tr\<leadsto> Ret x \<rbrakk> \<Longrightarrow> Q \<midarrow>tr\<leadsto> Ret x"
  apply (induct tr arbitrary: P Q)
  apply (metis (mono_tags, opaque_lifting) wbisim_silent_step_terminate)
  apply (smt (verit, ccfv_SIG) trace_to_Cons trace_to_ConsE wbisim_step)
  done

lemma wbisim_silent_step_stable: "\<lbrakk> P \<approx> Q; P \<midarrow>[]\<leadsto> P'; stable P' \<rbrakk> \<Longrightarrow> \<exists> Q'. Q \<midarrow>[]\<leadsto> Q' \<and> stable Q' \<and> P' \<approx> Q'"
  by (metis (no_types, opaque_lifting) diverges_then_diverge stabilises_def trace_of_Sils wbisim.cases wbisim_sym wbisim_to_ndiv2 wbisim_trace_to_Nil wbisim_trans)

lemma wbisim_single_step_stable:
  assumes "P \<approx> Q" "P \<midarrow>[e]\<leadsto> P'" "stable P'"
  shows "\<exists> Q'. Q \<midarrow>[e]\<leadsto> Q' \<and> stable Q' \<and> P' \<approx> Q'"
proof -
  obtain Q\<^sub>0 where Q\<^sub>0: "Q \<midarrow>[e]\<leadsto> Q\<^sub>0" "P' \<approx> Q\<^sub>0"
    by (metis (no_types, lifting) assms(1) assms(2) wbisim_single_step)
  hence "stabilises Q\<^sub>0"
    by (metis assms(3) diverges_implies_unstable diverges_then_diverge wbisim.cases wbisim_to_ndiv2)
  then obtain Q' n where Q': "Q\<^sub>0 = Sils n Q'" "stable Q'"
    by (metis stabilises_def)
  hence "Q \<midarrow>[e]\<leadsto> Q'" "P' \<approx> Q'"
    by (metis Q\<^sub>0(1) trace_of_Sils trace_to_Cons)
       (metis Q'(1) Q\<^sub>0(2) wbisim_Sils_iff2)
  thus ?thesis
    by (metis (full_types) Q'(2))
qed

lemma wbisim_step_stable:
  assumes "P \<approx> Q" "P \<midarrow>tr\<leadsto> P'" "stable P'"
  shows "\<exists> Q'. Q \<midarrow>tr\<leadsto> Q' \<and> stable Q' \<and> P' \<approx> Q'"
  using assms
  apply (induct tr arbitrary: P Q P')
   apply (metis (full_types) wbisim_silent_step_stable)
  apply (erule trace_to_ConsE)
  apply (auto elim!: wbisim_VisE)
  apply (metis wbisim_Sils_iff1)
  done

lemma "(\<And>s. Q\<^sub>1 s \<approx> Q\<^sub>2 s) \<Longrightarrow> P \<bind> Q\<^sub>1 \<approx> P \<bind> Q\<^sub>2"
  apply (rule wbisim_strong_coind[of "\<lambda> x y. \<exists> P Q. x = P \<bind> Q\<^sub>1 \<and> y = P \<bind> Q\<^sub>2 \<or> y = P \<bind> Q\<^sub>1 \<and> x = P \<bind> Q\<^sub>2"])
        apply auto[1]
       apply auto[1]
      apply (metis (no_types, lifting) bind_Ret bind_Sils bind_diverge bind_divergeE' diverge_wbisim1 diverge_wbisim2)
     apply (auto)
                   apply (erule bind_SilsE')
  subgoal premises prems for n P Q P'
    oops

text \<open> For CCS, weak bisimulation is not a congruence with respect to choice. Hence, Milner creates
  a derived relation, observation congruence, which adds the requirement that an initial silent
  action must be matched by a silent action in the other process. This is an issue because $\tau$
  can resolve a choice in CCS. \<close>

end


(*  Title:       Isabelle Collections Library
    Author:      Peter Lammich <peter dot lammich at uni-muenster.de>
    Maintainer:  Peter Lammich <peter dot lammich at uni-muenster.de>
*)
section \<open>\isaheader{DFS Implementation by Hashset}\<close>
theory Exploration_DFS
imports Exploration
begin
text_raw \<open>\label{thy:Exploration_Example}\<close>

text \<open>
  This theory implements the DFS-algorithm by using a hashset to remember the
  explored states. It illustrates how to use data refinement with the Isabelle Collections
  Framework in a realistic, non-trivial application.
\<close>

subsection "Definitions"
\<comment> \<open>The concrete algorithm uses a hashset (@{typ [source] "'q hs"}) and a worklist.\<close>
type_synonym 'q hs_dfs_state = "'q hs \<times> 'q list"

\<comment> \<open>The loop terminates on empty worklist\<close>
definition hs_dfs_cond :: "'q hs_dfs_state \<Rightarrow> bool"
  where "hs_dfs_cond S == let (Q,W) = S in W\<noteq>[]"

\<comment> \<open>Refinement of a DFS-step, using hashset operations\<close>
definition hs_dfs_step
  :: "('q::hashable \<Rightarrow> 'q ls) \<Rightarrow> 'q hs_dfs_state \<Rightarrow> 'q hs_dfs_state"
  where "hs_dfs_step post S == let
    (Q,W) = S;
    \<sigma>=hd W
  in
    ls.iteratei (post \<sigma>) (\<lambda>_. True) (\<lambda>x (Q,W).
      if hs.memb x Q then
        (Q,W)
      else (hs.ins x Q,x#W)
      )
      (Q, tl W)
  "

\<comment> \<open>Convert post-function to relation\<close>
definition hs_R :: "('q \<Rightarrow> 'q ls) \<Rightarrow> ('q\<times>'q) set"
  where "hs_R post == {(q,q'). q'\<in>ls.\<alpha> (post q)}"

\<comment> \<open>Initial state: Set of initial states in discovered set and on worklist\<close>
definition hs_dfs_initial :: "'q::hashable hs \<Rightarrow> 'q hs_dfs_state"
  where "hs_dfs_initial \<Sigma>i == (\<Sigma>i,hs.to_list \<Sigma>i)"

\<comment> \<open>Abstraction mapping to abstract-DFS state\<close>
definition hs_dfs_\<alpha> :: "'q::hashable hs_dfs_state \<Rightarrow> 'q dfs_state"
  where "hs_dfs_\<alpha> S == let (Q,W)=S in (hs.\<alpha> Q,W)"

(*-- {* Additional invariant on concrete level: The hashset invariant must hold *}
definition hs_dfs_invar_add :: "'q::hashable hs_dfs_state set"
  where "hs_dfs_invar_add == { (Q,W). hs_invar Q }"*)

\<comment> \<open>Combined concrete and abstract level invariant\<close>
definition hs_dfs_invar
  :: "'q::hashable hs \<Rightarrow> ('q \<Rightarrow> 'q ls) \<Rightarrow> 'q hs_dfs_state set"
  where "hs_dfs_invar \<Sigma>i post ==
    { s. (hs_dfs_\<alpha> s) \<in> dfs_invar (hs.\<alpha> \<Sigma>i) (hs_R post) }"

\<comment> \<open>The deterministic while-algorithm\<close>
definition "hs_dfs_dwa \<Sigma>i post == \<lparr>
  dwa_cond = hs_dfs_cond,
  dwa_step = hs_dfs_step post,
  dwa_initial = hs_dfs_initial \<Sigma>i,
  dwa_invar = hs_dfs_invar \<Sigma>i post
\<rparr>"

\<comment> \<open>Executable DFS-search. Given a set of initial states, and a successor
      function, this function performs a DFS search to return the set of
      reachable states.\<close>
definition "hs_dfs \<Sigma>i post
  == fst (while hs_dfs_cond (hs_dfs_step post) (hs_dfs_initial \<Sigma>i))"

subsection "Refinement"

text \<open>We first show that a concrete step implements its abstract specification, and preserves the
  additional concrete invariant\<close>
lemma hs_dfs_step_correct:
  (*assumes [simp]: "hs_invar Q"
                  "!!s. ls_invar (post s)"*)
  assumes ne: "hs_dfs_cond (Q,W)"
  shows "(hs_dfs_\<alpha> (Q,W),hs_dfs_\<alpha> (hs_dfs_step post (Q,W)))
         \<in>dfs_step (hs_R post)" (is ?T1)
        (*"(hs_dfs_step post (Q,W)) \<in> hs_dfs_invar_add" (is ?T2)*)
proof -

  from ne obtain \<sigma> Wtl where
    [simp]: "W=\<sigma>#Wtl"
    by (cases W) (auto simp add: hs_dfs_cond_def)

  have G: "let (Q',W') = hs_dfs_step post (Q,W) in
    hs.invar Q' \<and> (\<exists>Wn.
      distinct Wn
      \<and> set Wn = ls.\<alpha> (post \<sigma>) - hs.\<alpha> Q
      \<and> W'=Wn@Wtl
      \<and> hs.\<alpha> Q'=ls.\<alpha> (post \<sigma>) \<union> hs.\<alpha> Q)"
    apply (simp add: hs_dfs_step_def)
    apply (rule_tac
      I="\<lambda>it (Q',W'). hs.invar Q' \<and> (\<exists>Wn.
           distinct Wn
           \<and> set Wn = (ls.\<alpha> (post \<sigma>) - it) - hs.\<alpha> Q
           \<and> W'=Wn@Wtl
           \<and> hs.\<alpha> Q'=(ls.\<alpha> (post \<sigma>) - it) \<union> hs.\<alpha> Q)"
      in ls.iterate_rule_P)
    apply simp
    apply simp
    apply (force split: if_split_asm simp add: hs.correct)
    apply force
    done
  from G show ?T1
    apply (cases "hs_dfs_step post (Q, W)")
    apply (auto simp add: hs_R_def hs_dfs_\<alpha>_def intro!: dfs_step.intros)
    done
  (*from G show ?T2
    apply (cases "hs_dfs_step post (Q, W)")
    apply (auto simp add: hs_dfs_invar_add_def)
    done*)
qed

\<comment> \<open>Prove refinement\<close>
theorem hs_dfs_pref_dfs:
  (*assumes [simp]: "hs_invar \<Sigma>i"
  assumes [simp]: "!!q. ls_invar (post q)"*)
  shows "wa_precise_refine
    (det_wa_wa (hs_dfs_dwa \<Sigma>i post))
    (dfs_algo (hs.\<alpha> \<Sigma>i) (hs_R post))
    hs_dfs_\<alpha>"
  apply (unfold_locales)
  apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def hs_dfs_\<alpha>_def
                        hs_dfs_cond_def dfs_algo_def dfs_cond_def) [1]
  apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def dfs_algo_def
                        hs_dfs_invar_def (*hs_dfs_invar_add_def *)
              intro!: hs_dfs_step_correct(1)) [1]
  apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def hs_dfs_\<alpha>_def
                        hs_dfs_cond_def dfs_algo_def dfs_cond_def
                        hs_dfs_invar_def hs_dfs_step_def hs_dfs_initial_def
                        hs.to_list_correct
              intro: dfs_initial.intros
  ) [3]
  done

    \<comment> \<open>Show that concrete algorithm is a while-algo\<close>
theorem hs_dfs_while_algo:
  assumes finite[simp]: "finite ((hs_R post)\<^sup>* `` hs.\<alpha> \<Sigma>i)"
  shows "while_algo (det_wa_wa (hs_dfs_dwa \<Sigma>i post))"
proof -
  interpret ref: wa_precise_refine
    "(det_wa_wa (hs_dfs_dwa \<Sigma>i post))"
    "(dfs_algo (hs.\<alpha> \<Sigma>i) (hs_R post))"
    "hs_dfs_\<alpha>"
    using hs_dfs_pref_dfs .
  show ?thesis
    apply (rule ref.wa_intro[where addi=UNIV])
    apply (simp add: dfs_while_algo)
    apply (simp add: det_wa_wa_def hs_dfs_dwa_def hs_dfs_invar_def dfs_algo_def)

    apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def) [1]
    apply simp
    done
qed

\<comment> \<open>Show that concrete algo is a deterministic while-algo\<close>
lemmas hs_dfs_det_while_algo = det_while_algo_intro[OF hs_dfs_while_algo]

  \<comment> \<open>Transferred correctness theorem\<close>
lemmas hs_dfs_invar_final =
  wa_precise_refine.transfer_correctness[OF
     hs_dfs_pref_dfs dfs_invar_final]

  \<comment> \<open>The executable implementation is correct\<close>
theorem hs_dfs_correct:
  assumes finite[simp]: "finite ((hs_R post)\<^sup>* `` hs.\<alpha> \<Sigma>i)"
  shows "hs.\<alpha> (hs_dfs \<Sigma>i post) = (hs_R post)\<^sup>*``hs.\<alpha> \<Sigma>i" (is ?T1)
proof -
  from hs_dfs_det_while_algo[OF finite] interpret
    dwa: det_while_algo "(hs_dfs_dwa \<Sigma>i post)" .

  have
    LC: "(while hs_dfs_cond (hs_dfs_step post) (hs_dfs_initial \<Sigma>i)) = dwa.loop"
    by (unfold dwa.loop_def) (simp add: hs_dfs_dwa_def)

  have "?T1 \<^cancel>\<open>\<and> ?T2\<close>"
    apply (unfold hs_dfs_def)
    apply (simp only: LC)
    apply (rule dwa.while_proof)
    apply (case_tac s)
    using hs_dfs_invar_final[of \<Sigma>i "post"] (*[of id, simplified]*)
    apply (auto simp add: det_wa_wa_def hs_dfs_dwa_def
                          dfs_\<alpha>_def hs_dfs_\<alpha>_def) [1]
    done
  thus ?T1  by auto
qed

subsection "Code Generation"
export_code hs_dfs in SML module_name DFS
export_code hs_dfs in OCaml module_name DFS
export_code hs_dfs in Haskell module_name DFS

end


(*  Title:       Isabelle Collections Library
    Author:      Andreas Lochbihler <andreas dot lochbihler at kit.edu>
    Maintainer:  Andreas Lochbihler <andreas dot lochbihler at kit.edu>
*)
section {* \isaheader{Implementation of a trie with explicit invariants} *}
theory Trie_Impl imports
  "../../Lib/Assoc_List"
  "../../../Trie/Trie"
begin

subsection {* Interuptible iterator *}

fun iteratei_postfixed :: "'key list \<Rightarrow> ('key, 'val) trie \<Rightarrow>
    ('key list \<times> 'val, '\<sigma>) set_iterator"
where
  "iteratei_postfixed ks (Trie vo ts) c f \<sigma> =
   (if c \<sigma>
    then foldli ts c (\<lambda>(k, t) \<sigma>. iteratei_postfixed (k # ks) t c f \<sigma>)
           (case vo of None \<Rightarrow> \<sigma> | Some v \<Rightarrow> f (ks, v) \<sigma>)
    else \<sigma>)"

definition iteratei :: "('key, 'val) trie \<Rightarrow> ('key list \<times> 'val, '\<sigma>) set_iterator"
where "iteratei t c f \<sigma> = iteratei_postfixed [] t c f \<sigma>"

lemma iteratei_postfixed_interrupt:
  "\<not> c \<sigma> \<Longrightarrow> iteratei_postfixed ks t c f \<sigma> = \<sigma>"
by(cases t) simp

lemma iteratei_interrupt:
  "\<not> c \<sigma> \<Longrightarrow> iteratei t c f \<sigma> = \<sigma>"
unfolding iteratei_def by (simp add: iteratei_postfixed_interrupt)

lemma iteratei_postfixed_alt_def :
  "iteratei_postfixed ks ((Trie vo ts)::('key, 'val) trie) =
   (set_iterator_union
     (case_option set_iterator_emp (\<lambda>v. set_iterator_sng (ks, v)) vo)
     (set_iterator_image snd
     (set_iterator_product (foldli ts)
        (\<lambda>(k, t'). iteratei_postfixed (k # ks) t'))
     ))"
proof -
  have aux: "\<And>c f. (\<lambda>(k, t). iteratei_postfixed (k # ks) t c f) =
              (\<lambda>a. iteratei_postfixed (fst a # ks) (snd a) c f)"
    by auto

  show ?thesis
    apply (rule ext)+ apply (rename_tac c f \<sigma>)
    apply (simp add: set_iterator_product_def set_iterator_image_filter_def
                     set_iterator_union_def set_iterator_sng_def set_iterator_image_alt_def
                     case_prod_beta set_iterator_emp_def
            split: option.splits)
    apply (simp add: aux)
  done
qed

lemma iteratei_postfixed_correct :
  assumes invar: "invar_trie (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei_postfixed ks0 t)::('key list \<times> 'val, '\<sigma>) set_iterator)
           ((\<lambda>ksv. (rev (fst ksv) @ ks0, (snd ksv))) ` (map_to_set (lookup_trie t)))"
using invar
proof (induct t arbitrary: ks0)
  case (Trie vo kvs)
  note ind_hyp = Trie(1)
  note invar = Trie(2)

  from invar
  have dist_fst_kvs : "distinct (map fst kvs)"
   and dist_kvs: "distinct kvs"
   and invar_child: "\<And>k t. (k, t) \<in> set kvs \<Longrightarrow> invar_trie t"
  by (simp_all add: Ball_def distinct_map)

  -- "root iterator"
  def it_vo \<equiv> "(case vo of None \<Rightarrow> set_iterator_emp
                        | Some v \<Rightarrow> set_iterator_sng (ks0, v)) ::
                  ('key list \<times> 'val, '\<sigma>) set_iterator"
  def vo_S \<equiv> "case vo of None \<Rightarrow> {} | Some v \<Rightarrow> {(ks0, v)}"
  have it_vo_OK: "set_iterator it_vo vo_S"
    unfolding it_vo_def vo_S_def
    by (simp split: option.split
             add: set_iterator_emp_correct set_iterator_sng_correct)

  -- "children iterator"
  def it_prod \<equiv> "(set_iterator_product (foldli kvs)
      (\<lambda>(k, y). iteratei_postfixed (k # ks0) y))::
          (('key \<times> ('key, 'val) trie) \<times> 'key list \<times> 'val, '\<sigma>) set_iterator"

    def it_prod_S \<equiv> "SIGMA kt:set kvs.
       (\<lambda>ksv. (rev (fst ksv) @ ((fst kt) # ks0), snd ksv)) `
       map_to_set (lookup_trie (snd kt))"

  have it_prod_OK: "set_iterator it_prod it_prod_S"
  proof -
    from set_iterator_foldli_correct[OF dist_kvs]
    have it_foldli: "set_iterator (foldli kvs) (set kvs)" .

    { fix kt
      assume kt_in: "kt \<in> set kvs"
      hence k_t_in: "(fst kt, snd kt) \<in> set kvs" by simp

      note ind_hyp [OF k_t_in, OF invar_child[OF k_t_in], of "fst kt # ks0"]
    } note it_child = this

    show ?thesis
      unfolding it_prod_def it_prod_S_def
      apply (rule set_iterator_product_correct [OF it_foldli])
      apply (insert it_child)
      apply (simp add: case_prod_beta)
    done
  qed

  have it_image_OK : "set_iterator (set_iterator_image snd it_prod) (snd ` it_prod_S)"
  proof (rule set_iterator_image_correct[OF it_prod_OK])
    from dist_fst_kvs
    have "\<And>k v1 v2. (k, v1) \<in> set kvs \<Longrightarrow> (k, v2) \<in> set kvs \<Longrightarrow> v1 = v2"
       by (induct kvs) (auto simp add: image_iff)
    thus "inj_on snd it_prod_S"
      unfolding inj_on_def it_prod_S_def
      apply (simp add: image_iff Ball_def map_to_set_def)
      apply auto
    done
  qed auto

  -- "overall iterator"
  have it_all_OK: "set_iterator
      ((iteratei_postfixed ks0 (Trie vo kvs)):: ('key list \<times> 'val, '\<sigma>) set_iterator)
     (vo_S \<union> snd ` it_prod_S)"
    unfolding iteratei_postfixed_alt_def
       it_vo_def[symmetric]
       it_prod_def[symmetric]
  proof (rule set_iterator_union_correct [OF it_vo_OK it_image_OK])
    show "vo_S \<inter> snd ` it_prod_S = {}"
      unfolding vo_S_def it_prod_S_def
      by (simp split: option.split add: set_eq_iff image_iff)
  qed

  -- "rewrite result set"
  have it_set_rewr: "((\<lambda>ksv. (rev (fst ksv) @ ks0, snd ksv)) `
      map_to_set (lookup_trie (Trie vo kvs))) = (vo_S \<union> snd ` it_prod_S)"
    (is "?ls = ?rs")
    apply (simp add: map_to_set_def lookup_eq_Some_iff[OF invar]
                     set_eq_iff image_iff vo_S_def it_prod_S_def Ball_def Bex_def)
    apply (simp split: option.split del: ex_simps add: ex_simps[symmetric])
    apply (intro allI impI iffI)
    apply auto[]
    apply (metis append_Cons append_Nil append_assoc rev.simps)
  done

  -- "done"
  show ?case
    unfolding it_set_rewr using it_all_OK by fast
qed

definition trie_reverse_key where
  "trie_reverse_key ksv = (rev (fst ksv), (snd ksv))"

lemma trie_reverse_key_alt_def[code] :
  "trie_reverse_key (ks, v) = (rev ks, v)"
unfolding trie_reverse_key_def by auto

lemma trie_reverse_key_reverse[simp] :
  "trie_reverse_key (trie_reverse_key ksv) = ksv"
by (simp add: trie_reverse_key_def)

lemma trie_iteratei_correct:
  assumes invar: "invar_trie (t :: ('key, 'val) trie)"
  shows "set_iterator ((iteratei t)::('key list \<times> 'val, '\<sigma>) set_iterator)
           (trie_reverse_key ` (map_to_set (lookup_trie t)))"
unfolding trie_reverse_key_def[abs_def] iteratei_def[abs_def]
using iteratei_postfixed_correct [OF invar, of "[]"]
by simp

hide_const (open) iteratei
hide_type (open) trie

end