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

chapter \<open>Unsigned words of 32 bits\<close>

theory Uint32 imports
  Code_Target_Word_Base
begin

declare prod.Quotient[transfer_rule]

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

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

setup_lifting type_definition_uint32

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

declare Quotient_uint32[transfer_rule]

instantiation uint32 :: "{neg_numeral, modulo, 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 "(+) :: 32 word \<Rightarrow> _" .
lift_definition minus_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(-)" .
lift_definition uminus_uint32 :: "uint32 \<Rightarrow> uint32" is uminus .
lift_definition times_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(*)" .
lift_definition divide_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(div)" .
lift_definition modulo_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" is "(mod)" .
instance by standard (transfer, simp add: algebra_simps)+
end

instantiation uint32 :: linorder begin
lift_definition less_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> bool" is "(<)" .
lift_definition less_eq_uint32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> bool" is "(\<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 :: bit_operations 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 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

instantiation uint32 :: bit_comprehension begin
lift_definition set_bits_uint32 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint32" is "set_bits" .
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 (=) pcr_integer) of_bool of_bool"
by(auto simp add: of_bool_def integer.pcr_cr_eq cr_integer_def split: bit.split)

text \<open>Use pretty numerals from integer for pretty printing\<close>

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 (=) 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 \<open>Code setup\<close>

code_printing code_module Uint32 \<rightharpoonup> (SML)
\<open>(* 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 *)\<close>
code_reserved SML Uint32

code_printing code_module Uint32 \<rightharpoonup> (Haskell)
 \<open>module Uint32(Int32, Word32) where

  import Data.Int(Int32)
  import Data.Word(Word32)\<close>
code_reserved Haskell Uint32

text \<open>
  OCaml and Scala provide only signed 32bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
\<close>
code_printing code_module "Uint32" \<rightharpoonup> (OCaml)
\<open>module Uint32 : sig
  val less : int32 -> int32 -> bool
  val less_eq : int32 -> int32 -> bool
  val set_bit : int32 -> Z.t -> bool -> int32
  val shiftl : int32 -> Z.t -> int32
  val shiftr : int32 -> Z.t -> int32
  val shiftr_signed : int32 -> Z.t -> int32
  val test_bit : int32 -> Z.t -> 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 (Z.to_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 (Z.to_int n);;

let shiftr x n = Int32.shift_right_logical x (Z.to_int n);;

let shiftr_signed x n = Int32.shift_right x (Z.to_int n);;

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

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

code_printing code_module Uint32 \<rightharpoonup> (Scala)
\<open>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 */\<close>
code_reserved Scala Uint32

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

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 \<open>
  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'"}.
\<close>

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

lemma Rep_uint32'_transfer [transfer_rule]:
  "rel_fun cr_uint32 (=) (\<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

declare [[code drop: "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.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) "Z.to'_int32"
| 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 ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32), undefined ((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 ((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 ((div) :: uint32 \<Rightarrow> _) x (0 :: uint32)"
declare [[code abort: div0_uint32]]

definition mod0_uint32 :: "uint32 \<Rightarrow> uint32"
where [code del]: "mod0_uint32 x = undefined ((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 ((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 \<open>
  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.
\<close>

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" and
  (Eval) "(fn w => fn n => if n < 0 orelse 32 <= n then raise (Fail \"argument to uint32'_test'_bit out of bounds\") else Uint32.test'_bit w n)"

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" and
  (Eval) "(fn w => fn n => fn b => if n < 0 orelse 32 <= n then raise (Fail \"argument to uint32'_set'_bit out of bounds\") else Uint32.set'_bit x n b)"

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" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftl out of bounds\" else Uint32.shiftl x i)"

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" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftr out of bounds\" else Uint32.shiftr x i)"

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" and
  (Eval) "(fn x => fn i => if i < 0 orelse i >= 32 then raise Fail \"argument to uint32'_shiftr'_signed out of bounds\" else Uint32.shiftr'_signed x i)"

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) "Z.of'_int32" and
  (Scala) "BigInt"

section \<open>Quickcheck setup\<close>

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


(*  Title:      HOL/HOLCF/Tr.thy
    Author:     Franz Regensburger
*)

section {* The type of lifted booleans *}

theory Tr
imports Lift
begin

subsection {* Type definition and constructors *}

type_synonym
  tr = "bool lift"

translations
  (type) "tr" <= (type) "bool lift"

definition
  TT :: "tr" where
  "TT = Def True"

definition
  FF :: "tr" where
  "FF = Def False"

text {* Exhaustion and Elimination for type @{typ tr} *}

lemma Exh_tr: "t = \<bottom> \<or> t = TT \<or> t = FF"
unfolding FF_def TT_def by (induct t) auto

lemma trE [case_names bottom TT FF, cases type: tr]:
  "\<lbrakk>p = \<bottom> \<Longrightarrow> Q; p = TT \<Longrightarrow> Q; p = FF \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
unfolding FF_def TT_def by (induct p) auto

lemma tr_induct [case_names bottom TT FF, induct type: tr]:
  "\<lbrakk>P \<bottom>; P TT; P FF\<rbrakk> \<Longrightarrow> P x"
by (cases x) simp_all

text {* distinctness for type @{typ tr} *}

lemma dist_below_tr [simp]:
  "TT \<notsqsubseteq> \<bottom>" "FF \<notsqsubseteq> \<bottom>" "TT \<notsqsubseteq> FF" "FF \<notsqsubseteq> TT"
unfolding TT_def FF_def by simp_all

lemma dist_eq_tr [simp]:
  "TT \<noteq> \<bottom>" "FF \<noteq> \<bottom>" "TT \<noteq> FF" "\<bottom> \<noteq> TT" "\<bottom> \<noteq> FF" "FF \<noteq> TT"
unfolding TT_def FF_def by simp_all

lemma TT_below_iff [simp]: "TT \<sqsubseteq> x \<longleftrightarrow> x = TT"
by (induct x) simp_all

lemma FF_below_iff [simp]: "FF \<sqsubseteq> x \<longleftrightarrow> x = FF"
by (induct x) simp_all

lemma not_below_TT_iff [simp]: "x \<notsqsubseteq> TT \<longleftrightarrow> x = FF"
by (induct x) simp_all

lemma not_below_FF_iff [simp]: "x \<notsqsubseteq> FF \<longleftrightarrow> x = TT"
by (induct x) simp_all

subsection {* Case analysis *}

default_sort pcpo

definition tr_case :: "'a \<rightarrow> 'a \<rightarrow> tr \<rightarrow> 'a" where
  "tr_case = (\<Lambda> t e (Def b). if b then t else e)"

abbreviation
  cifte_syn :: "[tr, 'c, 'c] \<Rightarrow> 'c"  ("(If (_)/ then (_)/ else (_))" [0, 0, 60] 60)
where
  "If b then e1 else e2 == tr_case\<cdot>e1\<cdot>e2\<cdot>b"

translations
  "\<Lambda> (XCONST TT). t" == "CONST tr_case\<cdot>t\<cdot>\<bottom>"
  "\<Lambda> (XCONST FF). t" == "CONST tr_case\<cdot>\<bottom>\<cdot>t"

lemma ifte_thms [simp]:
  "If \<bottom> then e1 else e2 = \<bottom>"
  "If FF then e1 else e2 = e2"
  "If TT then e1 else e2 = e1"
by (simp_all add: tr_case_def TT_def FF_def)

subsection {* Boolean connectives *}

definition
  trand :: "tr \<rightarrow> tr \<rightarrow> tr" where
  andalso_def: "trand = (\<Lambda> x y. If x then y else FF)"
abbreviation
  andalso_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr"  ("_ andalso _" [36,35] 35)  where
  "x andalso y == trand\<cdot>x\<cdot>y"

definition
  tror :: "tr \<rightarrow> tr \<rightarrow> tr" where
  orelse_def: "tror = (\<Lambda> x y. If x then TT else y)"
abbreviation
  orelse_syn :: "tr \<Rightarrow> tr \<Rightarrow> tr"  ("_ orelse _"  [31,30] 30)  where
  "x orelse y == tror\<cdot>x\<cdot>y"

definition
  neg :: "tr \<rightarrow> tr" where
  "neg = flift2 Not"

definition
  If2 :: "[tr, 'c, 'c] \<Rightarrow> 'c" where
  "If2 Q x y = (If Q then x else y)"

text {* tactic for tr-thms with case split *}

lemmas tr_defs = andalso_def orelse_def neg_def tr_case_def TT_def FF_def

text {* lemmas about andalso, orelse, neg and if *}

lemma andalso_thms [simp]:
  "(TT andalso y) = y"
  "(FF andalso y) = FF"
  "(\<bottom> andalso y) = \<bottom>"
  "(y andalso TT) = y"
  "(y andalso y) = y"
apply (unfold andalso_def, simp_all)
apply (cases y, simp_all)
apply (cases y, simp_all)
done

lemma orelse_thms [simp]:
  "(TT orelse y) = TT"
  "(FF orelse y) = y"
  "(\<bottom> orelse y) = \<bottom>"
  "(y orelse FF) = y"
  "(y orelse y) = y"
apply (unfold orelse_def, simp_all)
apply (cases y, simp_all)
apply (cases y, simp_all)
done

lemma neg_thms [simp]:
  "neg\<cdot>TT = FF"
  "neg\<cdot>FF = TT"
  "neg\<cdot>\<bottom> = \<bottom>"
by (simp_all add: neg_def TT_def FF_def)

text {* split-tac for If via If2 because the constant has to be a constant *}

lemma split_If2:
  "P (If2 Q x y) = ((Q = \<bottom> \<longrightarrow> P \<bottom>) \<and> (Q = TT \<longrightarrow> P x) \<and> (Q = FF \<longrightarrow> P y))"
apply (unfold If2_def)
apply (cases Q)
apply (simp_all)
done

(* FIXME unused!? *)
ML {*
fun split_If_tac ctxt =
  simp_tac (put_simpset HOL_basic_ss ctxt addsimps [@{thm If2_def} RS sym])
    THEN' (split_tac ctxt [@{thm split_If2}])
*}

subsection "Rewriting of HOLCF operations to HOL functions"

lemma andalso_or:
  "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) = FF) = (t = FF \<or> s = FF)"
apply (cases t)
apply simp_all
done

lemma andalso_and:
  "t \<noteq> \<bottom> \<Longrightarrow> ((t andalso s) \<noteq> FF) = (t \<noteq> FF \<and> s \<noteq> FF)"
apply (cases t)
apply simp_all
done

lemma Def_bool1 [simp]: "(Def x \<noteq> FF) = x"
by (simp add: FF_def)

lemma Def_bool2 [simp]: "(Def x = FF) = (\<not> x)"
by (simp add: FF_def)

lemma Def_bool3 [simp]: "(Def x = TT) = x"
by (simp add: TT_def)

lemma Def_bool4 [simp]: "(Def x \<noteq> TT) = (\<not> x)"
by (simp add: TT_def)

lemma If_and_if:
  "(If Def P then A else B) = (if P then A else B)"
apply (cases "Def P")
apply (auto simp add: TT_def[symmetric] FF_def[symmetric])
done

subsection {* Compactness *}

lemma compact_TT: "compact TT"
by (rule compact_chfin)

lemma compact_FF: "compact FF"
by (rule compact_chfin)

end


theory Helper_Algorithms
imports R_Distinguishability State_Separator State_Preamble
begin

subsection \<open>Calculating r-distinguishable State Pairs with Separators\<close>

definition r_distinguishable_state_pairs_with_separators :: "'a FSM \<Rightarrow> (('a \<times> 'a) \<times> (('a \<times> 'a) + 'a) FSM) set" where
  "r_distinguishable_state_pairs_with_separators M = {((q1,q2),Sep) | q1 q2 Sep . q1 \<in> nodes M
                                                                                \<and> q2 \<in> nodes M
                                                                                \<and> q1 \<noteq> q2
                                                                                \<and> (((q1,q2) \<in> node_order M \<and> calculate_state_separator_from_s_states M q1 q2 = Some Sep)
                                                                                \<or> ((q2,q1) \<in> node_order M \<and> calculate_state_separator_from_s_states M q2 q1 = Some Sep)) }"

lemma r_distinguishable_state_pairs_with_separators_same_pair_same_separator :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "((q1,q2),A') \<in> r_distinguishable_state_pairs_with_separators M"
shows "A = A'"
  using assms unfolding r_distinguishable_state_pairs_with_separators_def
  using node_order_antisym by force

lemma r_distinguishable_state_pairs_with_separators_sym_pair_same_separator :
  assumes "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  and     "((q2,q1),A') \<in> r_distinguishable_state_pairs_with_separators M"
shows "A = A'"
  using assms unfolding r_distinguishable_state_pairs_with_separators_def
  using node_order_antisym by force

(* TODO: move *)
lemma r_distinguishable_k_sym : "r_distinguishable_k M q1 q2 k \<Longrightarrow> r_distinguishable_k M q2 q1 k"
proof (induction k arbitrary: q1 q2)
  case 0
  then show ?case by auto
next
  case (Suc k)
  then show ?case unfolding r_distinguishable_k.simps by metis
qed

(*
  lemma r_distinguishable_dist : "completely_specified M \<Longrightarrow> r_distinguishable M q1 q2 \<Longrightarrow> q1 \<noteq> q2"
*)

lemma r_distinguishable_state_pairs_with_separators_containment :
  assumes "q1 \<in> nodes M"
  and     "q2 \<in> nodes M"
  and     "q1 \<noteq> q2"
  and     "r_distinguishable M q1 q2"
shows "\<exists> Sep' . ((q1,q2),Sep') \<in> r_distinguishable_state_pairs_with_separators M"
proof -

  consider (a) "(q1,q2) \<in> node_order M" |
           (b) "(q2,q1) \<in> node_order M"
    using node_order_total[OF assms(1,2)] by blast
  then show ?thesis
  proof cases
    case a
    moreover obtain A where "calculate_state_separator_from_s_states M q1 q2 = Some A"
      using calculate_state_separator_from_s_states_exhaustiveness[OF _ assms(1,2)] assms(4)
      unfolding r_distinguishable_alt_def[OF assms(1,2)] by blast
    ultimately show ?thesis
      using assms(1-3) unfolding r_distinguishable_state_pairs_with_separators_def by blast
  next
    case b

    obtain k where "r_distinguishable_k M q2 q1 k"
      using r_distinguishable_k_sym assms(4)
      unfolding r_distinguishable_alt_def[OF assms(1,2)] by metis
    then obtain A where "calculate_state_separator_from_s_states M q2 q1 = Some A"
      using calculate_state_separator_from_s_states_exhaustiveness[OF _ assms(2,1)] by blast

    then show ?thesis using b assms(2,1,3) unfolding r_distinguishable_state_pairs_with_separators_def by blast
  qed
qed

definition r_distinguishable_state_pairs_with_separators_naive :: "'a FSM \<Rightarrow> (('a \<times> 'a) \<times> (('a \<times> 'a) + 'a) FSM) list" where
  "r_distinguishable_state_pairs_with_separators_naive M =
    (let nonSymNodes = non_sym_dist_pairs (nodes_from_distinct_paths M);
         nonSymSeps = map (\<lambda> (q1,q2) . ((q1,q2),calculate_state_separator_from_s_states M q1 q2)) nonSymNodes;
         filtered = map (\<lambda> ((q1,q2),A) . ((q1,q2), the A)) (filter (\<lambda> ((q1,q2),A) . A \<noteq> None) nonSymSeps)
      in
         concat (map (\<lambda> ((q1,q2),A) . [((q1,q2),A),((q2,q1),A)]) filtered))"

value "r_distinguishable_state_pairs_with_separators_naive M_ex_H"

lemma r_distinguishable_state_pairs_with_separators_code[code] :
  "r_distinguishable_state_pairs_with_separators M = set (r_distinguishable_state_pairs_with_separators_naive M)"
proof -
  have "\<And> q1 q2 A . ((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M \<Longrightarrow> ((q1,q2),A) \<in> set (r_distinguishable_state_pairs_with_separators_naive M)"
  proof -
    fix q1 q2 A assume "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
    then have "q1 \<in> nodes M" and "q2 \<in> nodes M" and "q1 \<noteq> q2" and *: "((q1,q2) \<in> node_order M \<and> calculate_state_separator_from_s_states M q1 q2 = Some A) \<or> ((q2,q1) \<in> node_order M \<and> calculate_state_separator_from_s_states M q2 q1 = Some A)"
      unfolding r_distinguishable_state_pairs_with_separators_def by blast+

    let ?nonSymNodes = "non_sym_dist_pairs (nodes_from_distinct_paths M)"
    let ?nonSymSeps = "map (\<lambda> (q1,q2) . ((q1,q2),calculate_state_separator_from_s_states M q1 q2)) ?nonSymNodes"
    let ?filtered = "map (\<lambda> ((q1,q2),A) . ((q1,q2), the A)) (filter (\<lambda> ((q1,q2),A) . A \<noteq> None) ?nonSymSeps)"

    have "q1 \<in> set (nodes_from_distinct_paths M)"
      using \<open>q1 \<in> nodes M\<close> nodes_code by metis
    moreover have "q2 \<in> set (nodes_from_distinct_paths M)"
      using \<open>q2 \<in> nodes M\<close> nodes_code by metis
    ultimately have "(q1,q2) \<in> set ?nonSymNodes \<or> (q2,q1) \<in> set ?nonSymNodes"
      using non_sym_dist_pairs_elems[OF _ _ \<open>q1 \<noteq> q2\<close>] by blast
    then have "(q1,q2) \<in> node_order M \<or> (q2,q1) \<in> node_order M"
      unfolding node_order_def
      unfolding linear_order_from_list_position_set by blast

    have "\<not> ((q1,q2) \<in> node_order M \<and> (q2,q1) \<in> node_order M)"
      using node_order_antisym[of q1 q2 M] \<open>q1 \<noteq> q2\<close> by auto
    then have "(q1,q2) \<in> node_order M \<Longrightarrow> (q2,q1) \<notin> node_order M"
         and  "(q2,q1) \<in> node_order M \<Longrightarrow> (q1,q2) \<notin> node_order M"
      by auto

    have scheme: "\<And> s1 s2 S . (s1,s2) \<in> node_order M \<Longrightarrow> s1 \<noteq> s2 \<Longrightarrow> calculate_state_separator_from_s_states M s1 s2 = Some S \<Longrightarrow> ((s1,s2),S) \<in> set ?filtered"
    proof -
      fix s1 s2 S assume "(s1,s2) \<in> node_order M" and "s1 \<noteq> s2" and "calculate_state_separator_from_s_states M s1 s2 = Some S"
      then have "((s1,s2), Some S) \<in> set ?nonSymSeps"
        unfolding node_order_def
      unfolding linear_order_from_list_position_set by force
      then have *: "((s1,s2), Some S) \<in> set (filter (\<lambda> ((q1,q2),A) . A \<noteq> None) ?nonSymSeps)"
        by force

      have **: "(\<lambda>((q1, q2), A). ((q1, q2), the A)) ((s1,s2),Some S) = ((s1,s2),S)"
        by simp

      have scheme: "\<And> x xs f y . x \<in> set xs \<Longrightarrow> (f x) = y \<Longrightarrow> y \<in> set (map f xs)" by auto

      show "((s1,s2),S) \<in> set ?filtered"
        using scheme[OF *, of "(\<lambda>((q1, q2), A). ((q1, q2), the A))", OF **] by assumption
    qed

    have "(q1,q2) \<in> node_order M \<Longrightarrow> ((q1,q2),A) \<in> set ?filtered"
      using * \<open>(q1,q2) \<in> node_order M \<Longrightarrow> (q2,q1) \<notin> node_order M\<close>
      using scheme by blast

    moreover have "(q2,q1) \<in> node_order M \<Longrightarrow> ((q2,q1),A) \<in> set ?filtered"
      using * \<open>(q2,q1) \<in> node_order M \<Longrightarrow> (q1,q2) \<notin> node_order M\<close>
      using scheme by blast

    ultimately consider (a) "((q1,q2),A) \<in> set ?filtered" |
                        (b) "((q2,q1),A) \<in> set ?filtered"
      using \<open>(q1,q2) \<in> node_order M \<or> (q2,q1) \<in> node_order M\<close> by blast

    then show "((q1,q2),A) \<in> set (r_distinguishable_state_pairs_with_separators_naive M)"
    proof (cases)
      case a

      have scheme1: "\<And> x xs f y . x \<in> set xs \<Longrightarrow> (f x) = y \<Longrightarrow> y \<in> set (map f xs)" by auto
      have scheme2: "\<And> xs xss . xs \<in> set xss \<Longrightarrow> set xs \<subseteq> set (concat xss)" by auto

      have *: "[((q1,q2),A),((q2,q1),A)] \<in> set (map (\<lambda> ((q1,q2),A) . [((q1,q2),A),((q2,q1),A)]) ?filtered)"
        using scheme1[OF a, of "(\<lambda>((q1, q2), A). [((q1, q2), A), ((q2, q1), A)])" "[((q1, q2), A), ((q2, q1), A)]"] by force
      have "set ([((q1,q2),A),((q2,q1),A)]) \<subseteq> set (r_distinguishable_state_pairs_with_separators_naive M)"
        using scheme2[OF *]
        unfolding r_distinguishable_state_pairs_with_separators_naive_def Let_def  by assumption
      then show ?thesis by auto
    next
      case b

      have scheme1: "\<And> x xs f y . x \<in> set xs \<Longrightarrow> (f x) = y \<Longrightarrow> y \<in> set (map f xs)" by auto
      have scheme2: "\<And> xs xss . xs \<in> set xss \<Longrightarrow> set xs \<subseteq> set (concat xss)" by auto

      have *: "[((q2,q1),A),((q1,q2),A)] \<in> set (map (\<lambda> ((q1,q2),A) . [((q1,q2),A),((q2,q1),A)]) ?filtered)"
        using scheme1[OF b, of "(\<lambda>((q1, q2), A). [((q1, q2), A), ((q2, q1), A)])" "[((q2, q1), A), ((q1, q2), A)]"] by force
      have "set ([((q2,q1),A),((q1,q2),A)]) \<subseteq> set (r_distinguishable_state_pairs_with_separators_naive M)"
        using scheme2[OF *]
        unfolding r_distinguishable_state_pairs_with_separators_naive_def Let_def  by assumption
      then show ?thesis by auto
    qed
  qed

  moreover have "\<And> q1 q2 A . ((q1,q2),A) \<in> set (r_distinguishable_state_pairs_with_separators_naive M) \<Longrightarrow> ((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
  proof -
    fix q1 q2 A assume "((q1,q2),A) \<in> set (r_distinguishable_state_pairs_with_separators_naive M)"

    let ?f1 = "(\<lambda> ((q1,q2),A) . [((q1,q2),A),((q2,q1),A)])"
    let ?f2 = "(\<lambda> ((q1,q2),A) . ((q1,q2), the A))"
    let ?f3 = "(\<lambda> ((q1,q2),A) . A \<noteq> None)"
    let ?f4 = "(\<lambda> (q1,q2) . ((q1,q2),calculate_state_separator_from_s_states M q1 q2))"

    have "((q1,q2),A) \<in> set (concat (map ?f1 (map ?f2 (filter ?f3 (map ?f4 (non_sym_dist_pairs (nodes_from_distinct_paths M)))))))"
      using \<open>((q1,q2),A) \<in> set (r_distinguishable_state_pairs_with_separators_naive M)\<close>
      unfolding r_distinguishable_state_pairs_with_separators_naive_def Let_def by assumption

    have scheme1: "\<And> x xs f1 f2 f3 f4 . x \<in> set (concat (map f1 (map f2 (filter f3 (map f4 xs))))) \<Longrightarrow> \<exists> y \<in> set xs . x \<in> set (f1 (f2 (f4 y))) \<and> f3 (f4 y)" by auto

    obtain qq where "qq \<in> set (non_sym_dist_pairs (nodes_from_distinct_paths M))"
              and   "((q1,q2),A) \<in> set (?f1 (?f2 (?f4 qq)))"
              and   "?f3 (?f4 qq)"
      using scheme1[OF \<open>((q1,q2),A) \<in> set (concat (map ?f1 (map ?f2 (filter ?f3 (map ?f4 (non_sym_dist_pairs (nodes_from_distinct_paths M)))))))\<close>] by force

    obtain q1' q2' where "qq = (q1',q2')"
      using prod.collapse by metis

    then have "(q1',q2') \<in> set (non_sym_dist_pairs (nodes_from_distinct_paths M))"
      using \<open>qq \<in> set (non_sym_dist_pairs (nodes_from_distinct_paths M))\<close> by auto
    then have "q1' \<in> nodes M" and "q2' \<in> nodes M" and "q1' \<noteq> q2'"
      using Util.non_sym_dist_pairs_elems_distinct[of q1' q2' "nodes_from_distinct_paths M"] unfolding nodes_code by blast+

    have "(q1',q2') \<in> node_order M"
      using \<open>(q1',q2') \<in> set (non_sym_dist_pairs (nodes_from_distinct_paths M))\<close>
      unfolding node_order_def linear_order_from_list_position_set by blast

    have "\<And> qq . fst (?f2 (?f4 qq)) = qq" by auto
    then have "fst (?f2 (?f4 qq)) = (q1',q2')"
      using \<open>qq = (q1',q2')\<close> by auto

    have *: "\<And> s1 s2 A s1' s2' A' . ((s1',s2'),A') \<in> set (?f1 ((s1,s2),A)) \<Longrightarrow> A = A' \<and> ((s1',s2') = (s1,s2) \<or> (s1',s2') = (s2,s1))" by auto
    have "A = snd (?f2 (?f4 (q1',q2')))" and "(q1, q2) = (q1', q2') \<or> (q1, q2) = (q2', q1')"
      using *[of q1 q2 A q1' q2' "snd (?f2 (?f4 (q1',q2')))"]
      using \<open>((q1,q2),A) \<in> set (?f1 (?f2 (?f4 qq)))\<close>
      unfolding \<open>qq = (q1',q2')\<close> by simp+

    have "Some A = snd (?f4 (q1',q2'))"
      using \<open>A = snd (?f2 (?f4 (q1',q2')))\<close>
      using \<open>?f3 (?f4 qq)\<close> \<open>qq = (q1', q2')\<close> by auto

    consider (a) "qq = (q1, q2)" |
                  (b) "qq = (q2, q1)"
      using \<open>(q1, q2) = (q1', q2') \<or> (q1, q2) = (q2', q1')\<close> \<open>qq = (q1',q2')\<close> by auto
    then show "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
    proof cases
      case a
      then have "q1' = q1" and "q2' = q2" using \<open>qq = (q1', q2')\<close> by auto

      have "calculate_state_separator_from_s_states M q1' q2' = Some A"
        using \<open>Some A = snd (?f4 (q1',q2'))\<close> a by auto

      show ?thesis unfolding r_distinguishable_state_pairs_with_separators_def
        using \<open>q1' \<in> nodes M\<close> \<open>q2' \<in> nodes M\<close> \<open>q1' \<noteq> q2'\<close> \<open>(q1',q2') \<in> node_order M\<close> \<open>calculate_state_separator_from_s_states M q1' q2' = Some A\<close>
        unfolding \<open>q1' = q1\<close> \<open>q2' = q2\<close> by blast
    next
      case b
      then have "q1' = q2" and "q2' = q1" using \<open>qq = (q1', q2')\<close> by auto

      have "calculate_state_separator_from_s_states M q1' q2' = Some A"
        using \<open>Some A = snd (?f4 (q1',q2'))\<close> b by auto

      show ?thesis unfolding r_distinguishable_state_pairs_with_separators_def
        using \<open>q1' \<in> nodes M\<close> \<open>q2' \<in> nodes M\<close> \<open>q1' \<noteq> q2'\<close> \<open>(q1',q2') \<in> node_order M\<close> \<open>calculate_state_separator_from_s_states M q1' q2' = Some A\<close>
        unfolding \<open>q1' = q2\<close> \<open>q2' = q1\<close> by blast
    qed
  qed

  ultimately show ?thesis by auto
qed

(* calculate all pairs of r_distinguishable states *)
(*
definition r_distinguishable_state_pairs :: "'a FSM \<Rightarrow> ('a \<times> 'a) list" where
  "r_distinguishable_state_pairs M = filter (\<lambda> qq . is_r_distinguishable M (fst qq) (snd qq)) (concat (map (\<lambda> q1 . map (\<lambda> q2 . (q1,q2)) (nodes_from_distinct_paths M)) (nodes_from_distinct_paths M)))"

value "r_distinguishable_state_pairs M_ex_H"
value "r_distinguishable_state_pairs M_ex_9"

lemma r_distinguishable_state_pairs_set : "set (r_distinguishable_state_pairs M) = {(q1,q2) | q1 q2 . q1 \<in> nodes M \<and> q2 \<in> nodes M \<and> is_r_distinguishable M q1 q2}"
  (is "set ?CalcPairs = ?DistPairs")
proof -
  let ?Concs = "(concat (map (\<lambda> q1 . map (\<lambda> q2 . (q1,q2)) (nodes_from_distinct_paths M)) (nodes_from_distinct_paths M)))"
  let ?Pairs = "{(q1,q2) | q1 q2 . q1 \<in> nodes M \<and> q2 \<in> nodes M}"

  have "set ?Concs = ?Pairs"
    by (metis (no_types) cartesian_product_list.simps cartesian_product_list_set nodes_code)
  moreover have "set ?CalcPairs = {qq . qq \<in> set ?Concs \<and> is_r_distinguishable M (fst qq) (snd qq)}"
    by (metis r_distinguishable_state_pairs_def set_filter)
  moreover have "?DistPairs = {qq . qq \<in> ?Pairs \<and> is_r_distinguishable M (fst qq) (snd qq)}"
    using prod.collapse by auto
  ultimately show ?thesis by blast
qed
*)

definition pairwise_r_distinguishable_state_sets_from_separators :: "'a FSM \<Rightarrow> 'a set list" where
  "pairwise_r_distinguishable_state_sets_from_separators M = (let RDS = image fst (r_distinguishable_state_pairs_with_separators M)
                                                              in filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> RDS)
                                                                     (map set (pow_list (nodes_from_distinct_paths M))))"

(*
definition pairwise_r_distinguishable_state_sets_from_separators :: "'a FSM \<Rightarrow> 'a set list" where
  "pairwise_r_distinguishable_state_sets_from_separators M = (let RDS = r_distinguishable_state_pairs_with_separators M
                                                              in filter (\<lambda> S . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst RDS)
                                                                     (map set (pow_list (nodes_from_distinct_paths M))))"
*)

lemma pairwise_r_distinguishable_state_sets_from_separators_set : "set (pairwise_r_distinguishable_state_sets_from_separators M) = {S . S \<subseteq> nodes M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M))}"
proof -
  have "\<And> S . S \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) \<Longrightarrow> S \<in> {S . S \<subseteq> nodes M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M))}"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def
    using pow_list_set[of "nodes_from_distinct_paths M"]
    by (metis (no_types, lifting) PowD filter_is_subset filter_list_set_not_contained mem_Collect_eq nodes_code subsetCE)
  moreover have "\<And> S . S \<in> {S . S \<subseteq> nodes M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M))} \<Longrightarrow> S \<in> set (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_def
    using pow_list_set[of "nodes_from_distinct_paths M"]
    by (simp add: nodes_code)
  ultimately show ?thesis by blast
qed

lemma pairwise_r_distinguishable_state_sets_from_separators_set_r_distinguishable :
  assumes "completely_specified M"
  shows  "set (pairwise_r_distinguishable_state_sets_from_separators M) = {S . S \<subseteq> nodes M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> r_distinguishable M q1 q2)}"
proof -
  have "\<And> q1 q2 . (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M) \<Longrightarrow> r_distinguishable M q1 q2"
  proof -
    fix q1 q2 assume "(q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
    then obtain A where "((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M"
      by auto
    then have "q1 \<in> nodes M" and "q2 \<in> nodes M" and "q1 \<noteq> q2" and "q2 \<noteq> q1"
      unfolding r_distinguishable_state_pairs_with_separators_def by blast+

    have "calculate_state_separator_from_s_states M q1 q2 = Some A \<or> calculate_state_separator_from_s_states M q2 q1 = Some A"
      using \<open>((q1,q2),A) \<in> r_distinguishable_state_pairs_with_separators M\<close>
      unfolding r_distinguishable_state_pairs_with_separators_def by blast
    then have "\<exists> k . (r_distinguishable_k M q1 q2 k \<or> r_distinguishable_k M q2 q1 k)"
      using calculate_state_separator_from_s_states_soundness[of M _ _ A, OF _ \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close> \<open>q1 \<noteq> q2\<close> \<open>completely_specified M\<close>]
      using calculate_state_separator_from_s_states_soundness[of M _ _ A, OF _ \<open>q2 \<in> nodes M\<close> \<open>q1 \<in> nodes M\<close> \<open>q2 \<noteq> q1\<close> \<open>completely_specified M\<close>]
      using state_separator_r_distinguishes_k[of M q1 q2 A] state_separator_r_distinguishes_k[of M q2 q1 A] by blast
    then show "r_distinguishable M q1 q2"
      unfolding r_distinguishable_alt_def[OF \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close>]
      using r_distinguishable_k_sym[of M q2 q1 ] by blast
  qed
  moreover have "\<And> q1 q2 . q1 \<in> nodes M \<Longrightarrow> q2 \<in> nodes M \<Longrightarrow> q1 \<noteq> q2 \<Longrightarrow> r_distinguishable M q1 q2 \<Longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
  proof -
    fix q1 q2 assume "q1 \<in> nodes M" and "q2 \<in> nodes M" and "q1 \<noteq> q2" and "r_distinguishable M q1 q2"
    then obtain k where "r_distinguishable_k M q1 q2 k"
      unfolding r_distinguishable_alt_def[OF \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close>] by blast
    then have "r_distinguishable_k M q2 q1 k"
      using r_distinguishable_k_sym by metis

    have "(q1,q2) \<in> node_order M \<or> (q2,q1) \<in> node_order M"
      using \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close> using FSM.node_order_total by metis
    moreover have "(q1,q2) \<in> node_order M \<Longrightarrow> \<exists> A . ((q1,q2), A) \<in> r_distinguishable_state_pairs_with_separators M"
    proof -
      assume "(q1,q2) \<in> node_order M"
      moreover obtain A where "calculate_state_separator_from_s_states M q1 q2 = Some A"
        using calculate_state_separator_from_s_states_exhaustiveness[OF \<open>r_distinguishable_k M q1 q2 k\<close> \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close>] by blast
      ultimately show "\<exists> A . ((q1,q2), A) \<in> r_distinguishable_state_pairs_with_separators M"
        using \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close> \<open>q1 \<noteq> q2\<close>
        unfolding r_distinguishable_state_pairs_with_separators_def by blast
    qed
    moreover have "(q2,q1) \<in> node_order M \<Longrightarrow> \<exists> A . ((q1,q2), A) \<in> r_distinguishable_state_pairs_with_separators M"
    proof -
      assume "(q2,q1) \<in> node_order M"
      moreover obtain A where "calculate_state_separator_from_s_states M q2 q1 = Some A"
        using calculate_state_separator_from_s_states_exhaustiveness[OF \<open>r_distinguishable_k M q2 q1 k\<close> \<open>q2 \<in> nodes M\<close> \<open>q1 \<in> nodes M\<close>] by blast
      ultimately show "\<exists> A . ((q1,q2), A) \<in> r_distinguishable_state_pairs_with_separators M"
        using \<open>q1 \<in> nodes M\<close> \<open>q2 \<in> nodes M\<close> \<open>q1 \<noteq> q2\<close>
        unfolding r_distinguishable_state_pairs_with_separators_def by blast
    qed
    ultimately show "(q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M)"
      by force
  qed
  ultimately show ?thesis
    unfolding pairwise_r_distinguishable_state_sets_from_separators_set
    by (metis (no_types, lifting) rev_subsetD)
qed

(* old definitions
definition pairwise_r_distinguishable_state_sets_from_separators :: "'a FSM \<Rightarrow> 'a set set" where
  "pairwise_r_distinguishable_state_sets_from_separators M = {S . S \<subseteq> nodes M \<and> (\<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> image fst (r_distinguishable_state_pairs_with_separators M))}"

definition pairwise_r_distinguishable_state_sets_from_separators_naive :: "'a FSM \<Rightarrow> 'a set set" where
  "pairwise_r_distinguishable_state_sets_from_separators_naive M = (let PR = image fst (r_distinguishable_state_pairs_with_separators M) in {S \<in> Pow (set (nodes_from_distinct_paths M)) . \<forall> q1 \<in> S . \<forall> q2 \<in> S . q1 \<noteq> q2 \<longrightarrow> (q1,q2) \<in> PR})"

lemma pairwise_r_distinguishable_state_sets_from_separators_code[code] :
  "pairwise_r_distinguishable_state_sets_from_separators M = pairwise_r_distinguishable_state_sets_from_separators_naive M"
  unfolding pairwise_r_distinguishable_state_sets_from_separators_def pairwise_r_distinguishable_state_sets_from_separators_naive_def
  by (metis (mono_tags, lifting) Collect_cong Pow_iff nodes_code)
*)

lemma pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> nodes M"
  shows "\<exists> S \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) . q \<in> S"
proof -
  have "{q} \<in> set (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_set using assms by blast
  then show ?thesis by blast
qed

definition maximal_pairwise_r_distinguishable_state_sets_from_separators :: "'a FSM \<Rightarrow> 'a set list" where
  "maximal_pairwise_r_distinguishable_state_sets_from_separators M = (let PR = (pairwise_r_distinguishable_state_sets_from_separators M) in filter (\<lambda> S . \<not>(\<exists> S' \<in> set PR . S \<subset> S')) PR)"

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_set_r_distinguishable :
  assumes "completely_specified M"
shows "set (maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S1 \<in> {S. S \<subseteq> nodes M \<and> (\<forall>q1\<in>S. \<forall>q2\<in>S. q1 \<noteq> q2 \<longrightarrow> r_distinguishable M q1 q2)} .
         \<not> (\<exists> S2 \<in> {S. S \<subseteq> nodes M \<and> (\<forall>q1\<in>S. \<forall>q2\<in>S. q1 \<noteq> q2 \<longrightarrow> r_distinguishable M q1 q2)} . S1 \<subset> S2)}"
  unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_def
  unfolding Let_def
  unfolding pairwise_r_distinguishable_state_sets_from_separators_set_r_distinguishable[OF assms]
  using pairwise_r_distinguishable_state_sets_from_separators_set_r_distinguishable[OF assms] by force

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_set :
  "set (maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
    {S \<in> {S. S \<subseteq> nodes M \<and> (\<forall>q1\<in>S. \<forall>q2\<in>S. q1 \<noteq> q2 \<longrightarrow> (q1, q2) \<in> fst ` r_distinguishable_state_pairs_with_separators M)} .
     \<not> Bex {S. S \<subseteq> nodes M \<and>
                (\<forall>q1\<in>S. \<forall>q2\<in>S. q1 \<noteq> q2 \<longrightarrow> (q1, q2) \<in> fst ` r_distinguishable_state_pairs_with_separators M)}
         ((\<subset>) S)}"
  unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_def
  unfolding Let_def
  unfolding pairwise_r_distinguishable_state_sets_from_separators_set
  using pairwise_r_distinguishable_state_sets_from_separators_set by force

value "maximal_pairwise_r_distinguishable_state_sets_from_separators M_ex_9"
value "maximal_pairwise_r_distinguishable_state_sets_from_separators M_ex_H"
value "card (node_order M_ex_DR)"

(* old set version
definition maximal_pairwise_r_distinguishable_state_sets_from_separators :: "'a FSM \<Rightarrow> 'a set set" where
  "maximal_pairwise_r_distinguishable_state_sets_from_separators M = (let PR = (pairwise_r_distinguishable_state_sets_from_separators M) in {S \<in> PR . \<not>(\<exists> S' \<in> PR . S \<subset> S')})"
*)

value "r_distinguishable_state_pairs_with_separators M_ex_H"
value "pairwise_r_distinguishable_state_sets_from_separators M_ex_H"
value "maximal_pairwise_r_distinguishable_state_sets_from_separators M_ex_H"

value "r_distinguishable_state_pairs_with_separators M_ex_9"
value "pairwise_r_distinguishable_state_sets_from_separators M_ex_9"
value "maximal_pairwise_r_distinguishable_state_sets_from_separators M_ex_9"

lemma maximal_pairwise_r_distinguishable_state_sets_from_separators_cover :
  assumes "q \<in> nodes M"
  shows "\<exists> S \<in> set (maximal_pairwise_r_distinguishable_state_sets_from_separators M ). q \<in> S"
proof -

  have *: "{q} \<in> set (pairwise_r_distinguishable_state_sets_from_separators M)"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_set using assms by blast
  have **: "finite (set (pairwise_r_distinguishable_state_sets_from_separators M))"
    unfolding pairwise_r_distinguishable_state_sets_from_separators_set by (simp add: nodes_finite)

  have "set (maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S \<in> set (pairwise_r_distinguishable_state_sets_from_separators M). \<not>(\<exists> S' \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) . S \<subset> S')}"
    unfolding maximal_pairwise_r_distinguishable_state_sets_from_separators_set  pairwise_r_distinguishable_state_sets_from_separators_set by metis
  then have "set (maximal_pairwise_r_distinguishable_state_sets_from_separators M) =
        {S \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) . (\<forall> S' \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) . \<not> S \<subset> S')}"
    by blast
  moreover have "\<exists> S \<in> {S \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) . (\<forall> S' \<in> set (pairwise_r_distinguishable_state_sets_from_separators M) . \<not> S \<subset> S')} . q \<in> S"
    using maximal_set_cover[OF ** *] by blast
  ultimately show ?thesis by blast
qed

subsection \<open>Calculating d-reachable States with Preambles\<close>

(* calculate d-reachable states and a fixed assignment of preambles *)
definition d_reachable_states_with_preambles :: "'a FSM \<Rightarrow> ('a \<times> 'a FSM) list" where
  "d_reachable_states_with_preambles M = map (\<lambda> qp . (fst qp, the (snd qp))) (filter (\<lambda> qp . snd qp \<noteq> None) (map (\<lambda> q . (q, calculate_state_preamble_from_d_states M q)) (nodes_from_distinct_paths M)))"

lemma d_reachable_states_with_preambles_exhaustiveness :
  assumes "\<exists> P . is_preamble P M q"
  and     "observable M"
  and     "q \<in> nodes M"
shows "\<exists> P . is_preamble P M q \<and> (q,P) \<in> set (d_reachable_states_with_preambles M)"
proof -
  have "calculate_state_preamble_from_d_states M q \<noteq> None"
    using calculate_state_preamble_from_d_states_exhaustiveness[OF assms(1)] by assumption
  then obtain P where "calculate_state_preamble_from_d_states M q = Some P"
    by blast
  then have "(q,Some P) \<in> set ((filter (\<lambda>qp. snd qp \<noteq> None)
               (map (\<lambda>q. (q, calculate_state_preamble_from_d_states M q)) (nodes_from_distinct_paths M))))"
    by (metis (mono_tags, lifting) \<open>calculate_state_preamble_from_d_states M q \<noteq> None\<close> assms(3) filter_list_set image_eqI nodes_code set_map snd_conv)

  then have "(q,P) \<in> set (d_reachable_states_with_preambles M)"
    unfolding d_reachable_states_with_preambles_def
  proof -
    have "(q, P) = (fst (q, Some P), the (snd (q, Some P)))"
      by auto
    then have "(q, P) \<in> (\<lambda>p. (fst p, the (snd p))) ` set (filter (\<lambda>p. snd p \<noteq> None) (map (\<lambda>a. (a, calculate_state_preamble_from_d_states M a)) (nodes_from_distinct_paths M)))"
      using \<open>(q, Some P) \<in> set (filter (\<lambda>qp. snd qp \<noteq> None) (map (\<lambda>q. (q, calculate_state_preamble_from_d_states M q)) (nodes_from_distinct_paths M)))\<close> by blast
    then show "(q, P) \<in> set (map (\<lambda>p. (fst p, the (snd p))) (filter (\<lambda>p. snd p \<noteq> None) (map (\<lambda>a. (a, calculate_state_preamble_from_d_states M a)) (nodes_from_distinct_paths M))))"
      by (metis (no_types) list.set_map)
  qed
  then show ?thesis
    by (meson \<open>calculate_state_preamble_from_d_states M q = Some P\<close> assms(2) calculate_state_preamble_from_d_states_soundness)
qed

lemma d_reachable_states_with_preambles_containment :
  assumes "(q,P) \<in> set (d_reachable_states_with_preambles M)"
  and     "observable M"
  shows "is_preamble P M q"
    and "q \<in> nodes M"
proof -

  have "calculate_state_preamble_from_d_states M q = Some P"
    using assms unfolding d_reachable_states_with_preambles_def
    using image_iff by auto
  then show "is_preamble P M q"
    using calculate_state_preamble_from_d_states_soundness assms(2) by metis

  show "q \<in> nodes M"
    using assms unfolding d_reachable_states_with_preambles_def nodes_code
    using filter_map_elem fst_conv list_map_source_elem by force
qed

value "d_reachable_states_with_preambles M_ex_H"
value "d_reachable_states_with_preambles M_ex_DR"

(* preamble sets

(* calculate d-reachable states and a fixed assignment of preambles *)
definition d_reachable_states_with_preamble_sets :: "'a FSM \<Rightarrow> ('a \<times> ((Input \<times> Output) list set)) list" where
  "d_reachable_states_with_preamble_sets M = map (\<lambda> qp . (fst qp, the (snd qp))) (filter (\<lambda> qp . snd qp \<noteq> None) (map (\<lambda> q . (q, calculate_preamble_set_from_d_states M q)) (nodes_from_distinct_paths M)))"

lemma d_reachable_states_with_preamble_sets_exhaustiveness :
  assumes "\<exists> P . is_preamble_set M q P"
  and     "observable M"
  and     "q \<in> nodes M"
shows "\<exists> P . is_preamble_set M q P \<and> (q,P) \<in> set (d_reachable_states_with_preamble_sets M)"
proof -
  have "calculate_preamble_set_from_d_states M q \<noteq> None"
    using calculate_preamble_set_from_d_states_exhaustiveness[OF assms(1,2)] by assumption
  then obtain P where "calculate_preamble_set_from_d_states M q = Some P"
    by blast
  then have "(q,Some P) \<in> set ((filter (\<lambda>qp. snd qp \<noteq> None)
               (map (\<lambda>q. (q, calculate_preamble_set_from_d_states M q)) (nodes_from_distinct_paths M))))"
    by (metis (mono_tags, lifting) \<open>calculate_preamble_set_from_d_states M q \<noteq> None\<close> assms(3) filter_list_set image_eqI nodes_code set_map snd_conv)

  then have "(q,P) \<in> set (d_reachable_states_with_preamble_sets M)"
    unfolding d_reachable_states_with_preamble_sets_def
  proof -
    have "(q, P) = (fst (q, Some P), the (snd (q, Some P)))"
      by auto
    then have "(q, P) \<in> (\<lambda>p. (fst p, the (snd p))) ` set (filter (\<lambda>p. snd p \<noteq> None) (map (\<lambda>a. (a, calculate_preamble_set_from_d_states M a)) (nodes_from_distinct_paths M)))"
      using \<open>(q, Some P) \<in> set (filter (\<lambda>qp. snd qp \<noteq> None) (map (\<lambda>q. (q, calculate_preamble_set_from_d_states M q)) (nodes_from_distinct_paths M)))\<close> by blast
    then show "(q, P) \<in> set (map (\<lambda>p. (fst p, the (snd p))) (filter (\<lambda>p. snd p \<noteq> None) (map (\<lambda>a. (a, calculate_preamble_set_from_d_states M a)) (nodes_from_distinct_paths M))))"
      by (metis (no_types) list.set_map)
  qed
  then show ?thesis
    by (meson \<open>calculate_preamble_set_from_d_states M q = Some P\<close> assms(2) calculate_preamble_set_from_d_states_soundness)
qed

lemma d_reachable_states_with_preamble_sets_containment :
  assumes "(q,P) \<in> set (d_reachable_states_with_preamble_sets M)"
  and     "observable M"
  shows "is_preamble_set M q P"
    and "q \<in> nodes M"
proof -

  have "calculate_preamble_set_from_d_states M q = Some P"
    using assms unfolding d_reachable_states_with_preamble_sets_def
    using image_iff by auto
  then show "is_preamble_set M q P"
    using calculate_preamble_set_from_d_states_soundness assms(2) by metis

  show "q \<in> nodes M"
    using assms unfolding d_reachable_states_with_preamble_sets_def
  proof -
    assume "(q, P) \<in> set (map (\<lambda>qp. (fst qp, the (snd qp))) (filter (\<lambda>qp. snd qp \<noteq> None) (map (\<lambda>q. (q, calculate_preamble_set_from_d_states M q)) (nodes_from_distinct_paths M))))"
    then have "q \<in> set (nodes_from_distinct_paths M)"
      by fastforce
    then show ?thesis
      by (metis nodes_code)
  qed
qed

value "d_reachable_states_with_preamble_sets M_ex_H"
*)

fun d_reachable_states :: "'a FSM \<Rightarrow> 'a list" where
  "d_reachable_states M = (map fst (d_reachable_states_with_preambles M))"

lemma d_reachable_states_set :
  assumes "observable M"
  shows "set (d_reachable_states M) = {q . q \<in> nodes M \<and> (\<exists> P . is_preamble P M q)}"
proof -
  have "\<And> q . q \<in> set (d_reachable_states M) \<Longrightarrow> q \<in> {q \<in> nodes M. \<exists>P. is_preamble P M q}"
    unfolding d_reachable_states.simps using d_reachable_states_with_preambles_containment[of _ _ M]
    by (metis (no_types, lifting) assms list_map_source_elem mem_Collect_eq prod.collapse)

  moreover have "\<And> q . q \<in> {q \<in> nodes M. \<exists>P. is_preamble P M q} \<Longrightarrow> q \<in> set (d_reachable_states M)"
    unfolding d_reachable_states.simps using d_reachable_states_with_preambles_exhaustiveness[OF _ assms]
  proof -
    fix q :: 'a
    assume "q \<in> {q \<in> nodes M. \<exists>P. is_preamble P M q}"
    then have "q \<in> nodes M \<and> (\<exists>P. (is_preamble P M q))"
      by blast
    then show "q \<in> set (map fst (d_reachable_states_with_preambles M))"
      by (metis (no_types) \<open>\<And>q. \<lbrakk>\<exists>P. is_preamble P M q; q \<in> nodes M\<rbrakk> \<Longrightarrow> \<exists>P. is_preamble P M q \<and> (q, P) \<in> set (d_reachable_states_with_preambles M)\<close> fst_conv image_eqI set_map)
  qed
  ultimately show ?thesis by blast
qed

value "d_reachable_states M_ex_H"
value "d_reachable_states M_ex_9"

definition maximal_repetition_sets_from_separators :: "'a FSM \<Rightarrow> ('a set \<times> 'a set) list" where
  "maximal_repetition_sets_from_separators M = map (\<lambda> S . (S, S \<inter> set (d_reachable_states M))) (maximal_pairwise_r_distinguishable_state_sets_from_separators M)"

(* old set version *)
(*
definition maximal_repetition_sets_from_separators :: "'a FSM \<Rightarrow> ('a set \<times> 'a set) set" where
  "maximal_repetition_sets_from_separators M = {(S, S \<inter> set (d_reachable_states M)) | S . S \<in> (maximal_pairwise_r_distinguishable_state_sets_from_separators M)}"

lemma maximal_repetition_sets_from_separators_code[code] :
  "maximal_repetition_sets_from_separators M = (let DR = set (d_reachable_states M) in image (\<lambda> S . (S, S \<inter> DR)) (maximal_pairwise_r_distinguishable_state_sets_from_separators M))"
  unfolding maximal_repetition_sets_from_separators_def Let_def
  by (simp add: Setcompr_eq_image)
*)

value "maximal_repetition_sets_from_separators M_ex_H"
value "maximal_repetition_sets_from_separators M_ex_9"

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Set Partitions\<close>

theory Set_Partition
imports
  "HOL-Library.Disjoint_Sets"
  "HOL-Library.FuncSet"
begin

subsection \<open>Useful Additions to Main Theories\<close>

lemma set_eqI':
  assumes "\<And>x. x \<in> A \<Longrightarrow> x \<in> B"
  assumes "\<And>x. x \<in> B \<Longrightarrow> x \<in> A"
  shows "A = B"
using assms by auto

lemma comp_image:
  "((`) f \<circ> (`) g) = (`) (f o g)"
by rule auto

subsection \<open>Introduction and Elimination Rules\<close>

text \<open>The definition of @{const partition_on} is in @{theory "HOL-Library.Disjoint_Sets"}.\<close>

(* TODO: move the following theorems to Disjoint Sets *)

lemma partition_onI:
  assumes "\<And>p. p \<in> P \<Longrightarrow> p \<noteq> {}"
  assumes "\<Union>P = A"
  assumes "\<And>p p'. p \<in> P \<Longrightarrow> p' \<in> P \<Longrightarrow> p \<noteq> p' \<Longrightarrow> p \<inter> p' = {}"
  shows "partition_on A P"
using assms unfolding partition_on_def disjoint_def by blast

lemma partition_onE:
  assumes "partition_on A P"
  obtains "\<And>p. p \<in> P \<Longrightarrow> p \<noteq> {}"
     "\<Union>P = A"
     "\<And>p p'. p \<in> P \<Longrightarrow> p' \<in> P \<Longrightarrow> p \<noteq> p' \<Longrightarrow> p \<inter> p' = {}"
using assms unfolding partition_on_def disjoint_def by blast

subsection \<open>Basic Facts on Set Partitions\<close>

lemma partition_onD4: "partition_on A P \<Longrightarrow> p \<in> P \<Longrightarrow> q \<in> P \<Longrightarrow> x \<in> p \<Longrightarrow> x \<in> q \<Longrightarrow> p = q"
  by (auto simp: partition_on_def disjoint_def)

lemma partition_subset_imp_notin:
  assumes "partition_on A P" "X \<in> P"
  assumes "X' \<subset> X"
  shows "X' \<notin> P"
proof
  assume "X' \<in> P"
  from \<open>X' \<in> P\<close> \<open>partition_on A P\<close> have "X' \<noteq> {}"
    using partition_onD3 by blast
  moreover from \<open>X' \<in> P\<close> \<open>X \<in> P\<close> \<open>partition_on A P\<close> \<open>X' \<subset> X\<close> have "disjnt X X'"
    by (metis disjnt_def disjointD inf.strict_order_iff partition_onD2)
  moreover note \<open>X' \<subset> X\<close>
  ultimately show False
    by (meson all_not_in_conv disjnt_iff psubsetD)
qed

lemma partition_on_Diff:
  assumes P: "partition_on A P" shows "Q \<subseteq> P \<Longrightarrow> partition_on (A - \<Union>Q) (P - Q)"
  using P P[THEN partition_onD4] by (auto simp: partition_on_def disjoint_def)

lemma partition_on_UN:
  assumes A: "partition_on A B" and B: "\<And>b. b \<in> B \<Longrightarrow> partition_on b (P b)"
  shows "partition_on A (\<Union>b\<in>B. P b)"
proof (rule partition_onI)
  show "\<Union>(\<Union>b\<in>B. P b) = A"
    using B[THEN partition_onD1] A[THEN partition_onD1] by blast
next
  show "p \<noteq> {}" if "p \<in> (\<Union>b\<in>B. P b)" for p
    using B[THEN partition_onD3] that by auto
next
  fix p q assume "p \<in> (\<Union>i\<in>B. P i)" "q \<in> (\<Union>i\<in>B. P i)" and "p \<noteq> q"
  then obtain i j where i: "p \<in> P i" "i \<in> B" and j: "q \<in> P j" "j \<in> B"
    by auto
  show "p \<inter> q = {}"
  proof cases
    assume "i = j" then show ?thesis
      using i j \<open>p \<noteq> q\<close> B[THEN partition_onD2, of i] by (simp add: disjointD)
  next
    assume "i \<noteq> j"
    then have "disjnt i j"
      using i j A[THEN partition_onD2] by (auto simp: pairwise_def)
    moreover have "p \<subseteq> i" "q \<subseteq> j"
      using B[THEN partition_onD1, of i, symmetric] B[THEN partition_onD1, of j, symmetric] i j by auto
    ultimately show ?thesis
      by (auto simp: disjnt_def)
  qed
qed

lemma partition_on_notemptyI:
  assumes "partition_on A P"
  assumes "A \<noteq> {}"
  shows "P \<noteq> {}"
using assms by (auto elim: partition_onE)

lemma partition_on_disjoint:
  assumes "partition_on A P"
  assumes "partition_on B Q"
  assumes "A \<inter> B = {}"
  shows "P \<inter> Q = {}"
using assms by (fastforce elim: partition_onE)

lemma partition_on_eq_implies_eq_carrier:
  assumes "partition_on A Q"
  assumes "partition_on B Q"
  shows "A = B"
using assms by (fastforce elim: partition_onE)

lemma partition_on_insert:
  assumes "partition_on A P"
  assumes "disjnt A X" "X \<noteq> {}"
  assumes "A \<union> X = A'"
  shows "partition_on A' (insert X P)"
using assms by (auto simp: partition_on_def disjoint_def disjnt_def)

text \<open>An alternative formulation of @{thm partition_on_insert}\<close>
lemma partition_on_insert':
  assumes "partition_on (A - X) P"
  assumes "X \<subseteq> A" "X \<noteq> {}"
  shows "partition_on A (insert X P)"
proof -
  have "disjnt (A - X) X" by (simp add: disjnt_iff)
  from assms(1) this assms(3) have "partition_on ((A - X) \<union> X) (insert X P)"
    by (auto intro: partition_on_insert)
  from this \<open>X \<subseteq> A\<close> show ?thesis
    by (metis Diff_partition sup_commute)
qed

lemma partition_on_insert_singleton:
  assumes "partition_on A P" "a \<notin> A" "insert a A = A'"
  shows "partition_on A' (insert {a} P)"
using assms by (auto simp: partition_on_def disjoint_def disjnt_def)

lemma partition_on_remove_singleton:
  assumes "partition_on A P" "X \<in> P" "A - X = A'"
  shows "partition_on A' (P - {X})"
using assms partition_on_Diff by (metis Diff_cancel Diff_subset cSup_singleton insert_subset)

subsection \<open>The Unique Part Containing an Element in a Set Partition\<close>

lemma partition_on_partition_on_unique:
  assumes "partition_on A P"
  assumes "x \<in> A"
  shows "\<exists>!X. x \<in> X \<and> X \<in> P"
proof -
  from \<open>partition_on A P\<close> have "\<Union>P = A"
    by (auto elim: partition_onE)
  from this \<open>x \<in> A\<close> obtain X where X: "x \<in> X \<and> X \<in> P" by blast
  {
    fix Y
    assume "x \<in> Y \<and> Y \<in> P"
    from this have "X = Y"
      using X \<open>partition_on A P\<close> by (meson partition_onE disjoint_iff_not_equal)
  }
  from this X show ?thesis by auto
qed

lemma partition_on_the_part_mem:
  assumes "partition_on A P"
  assumes "x \<in> A"
  shows "(THE X. x \<in> X \<and> X \<in> P) \<in> P"
proof -
  from \<open>x \<in> A\<close> have "\<exists>!X. x \<in> X \<and> X \<in> P"
    using \<open>partition_on A P\<close> by (simp add: partition_on_partition_on_unique)
  from this show "(THE X. x \<in> X \<and> X \<in> P) \<in> P"
    by (metis (no_types, lifting) theI)
qed

lemma partition_on_in_the_unique_part:
  assumes "partition_on A P"
  assumes "x \<in> A"
  shows "x \<in> (THE X. x \<in> X \<and> X \<in> P)"
proof -
  from assms have "\<exists>!X. x \<in> X \<and> X \<in> P"
    by (simp add: partition_on_partition_on_unique)
  from this show ?thesis
    by (metis (mono_tags, lifting) theI')
qed

lemma partition_on_the_part_eq:
  assumes "partition_on A P"
  assumes "x \<in> X" "X \<in> P"
  shows "(THE X. x \<in> X \<and> X \<in> P) = X"
proof -
  from \<open>x \<in> X\<close> \<open>X \<in> P\<close> have "x \<in> A"
    using \<open>partition_on A P\<close> by (auto elim: partition_onE)
  from this have "\<exists>!X. x \<in> X \<and> X \<in> P"
    using \<open>partition_on A P\<close> by (simp add: partition_on_partition_on_unique)
  from \<open>x \<in> X\<close> \<open>X \<in> P\<close> this show "(THE X. x \<in> X \<and> X \<in> P) = X"
    by (auto intro!: the1_equality)
qed

lemma the_unique_part_alternative_def:
  assumes "partition_on A P"
  assumes "x \<in> A"
  shows "(THE X. x \<in> X \<and> X \<in> P) = {y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"
proof
  show "(THE X. x \<in> X \<and> X \<in> P) \<subseteq> {y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"
  proof
    fix y
    assume "y \<in> (THE X. x \<in> X \<and> X \<in> P)"
    moreover from \<open>x \<in> A\<close> have "x \<in> (THE X. x \<in> X \<and> X \<in> P)"
      using \<open>partition_on A P\<close> partition_on_in_the_unique_part by force
    moreover from \<open>x \<in> A\<close> have "(THE X. x \<in> X \<and> X \<in> P) \<in> P"
      using \<open>partition_on A P\<close> partition_on_the_part_mem by force
    ultimately show "y \<in> {y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X}" by auto
  qed
next
  show "{y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X} \<subseteq> (THE X. x \<in> X \<and> X \<in> P)"
  proof
    fix y
    assume "y \<in> {y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"
    from this obtain X where "x \<in> X" and "y \<in> X" and "X \<in> P" by auto
    from \<open>x \<in> X\<close> \<open>X \<in> P\<close> have "(THE X. x \<in> X \<and> X \<in> P) = X"
      using \<open>partition_on A P\<close> partition_on_the_part_eq by force
    from this \<open>y \<in> X\<close> show "y \<in> (THE X. x \<in> X \<and> X \<in> P)" by simp
  qed
qed

lemma partition_on_all_in_part_eq_part:
  assumes "partition_on A P"
  assumes "X' \<in> P"
  shows "{x \<in> A. (THE X. x \<in> X \<and> X \<in> P) = X'} = X'"
proof
  show "{x \<in> A. (THE X. x \<in> X \<and> X \<in> P) = X'} \<subseteq> X'"
    using assms(1) partition_on_in_the_unique_part by force
next
  show "X' \<subseteq> {x \<in> A. (THE X. x \<in> X \<and> X \<in> P) = X'}"
  proof
    fix x
    assume "x \<in> X'"
    from \<open>x \<in> X'\<close> \<open>X' \<in> P\<close> have "x \<in> A"
      using \<open>partition_on A P\<close> by (auto elim: partition_onE)
    moreover from \<open>x \<in> X'\<close> \<open>X' \<in> P\<close> have "(THE X. x \<in> X \<and> X \<in> P) = X'"
      using \<open>partition_on A P\<close> partition_on_the_part_eq by fastforce
    ultimately show "x \<in> {x \<in> A. (THE X. x \<in> X \<and> X \<in> P) = X'}" by auto
  qed
qed

lemma partition_on_part_characteristic:
  assumes "partition_on A P"
  assumes "X \<in> P" "x \<in> X"
  shows "X = {y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"
proof -
  from \<open>x \<in> X\<close> \<open>X \<in> P\<close> have "x \<in> A"
    using \<open>partition_on A P\<close> partition_onE by blast
  from  \<open>x \<in> X\<close> \<open>X \<in> P\<close> have "X = (THE X. x \<in> X \<and> X \<in> P)"
    using \<open>partition_on A P\<close> by (simp add: partition_on_the_part_eq)
  also from \<open>x \<in> A\<close> have "(THE X. x \<in> X \<and> X \<in> P) = {y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X}"
    using \<open>partition_on A P\<close> the_unique_part_alternative_def by force
  finally show ?thesis .
qed

lemma partition_on_no_partition_outside_carrier:
  assumes "partition_on A P"
  assumes "x \<notin> A"
  shows "{y. \<exists>X\<in>P. x \<in> X \<and> y \<in> X} = {}"
using assms unfolding partition_on_def by auto

subsection \<open>Cardinality of Parts in a Set Partition\<close>

lemma partition_on_le_set_elements:
  assumes "finite A"
  assumes "partition_on A P"
  shows "card P \<le> card A"
using assms
proof (induct A arbitrary: P)
  case empty
  from this show "card P \<le> card {}" by (simp add: partition_on_empty)
next
  case (insert a A)
  show ?case
  proof (cases "{a} \<in> P")
    case True
    have prop_partition_on: "\<forall>p\<in>P. p \<noteq> {}" "\<Union>P = insert a A"
      "\<forall>p\<in>P. \<forall>p'\<in>P. p \<noteq> p' \<longrightarrow> p \<inter> p' = {}"
      using \<open>partition_on (insert a A) P\<close> by (fastforce elim: partition_onE)+
    from this(2, 3) \<open>a \<notin> A\<close> \<open>{a} \<in> P\<close> have A_eq: "A = \<Union>(P - {{a}})"
      by auto (metis Int_iff UnionI empty_iff insert_iff)
    from prop_partition_on A_eq have partition_on: "partition_on A (P - {{a}})"
      by (intro partition_onI) auto
    from insert.hyps(3) this have "card (P - {{a}}) \<le> card A" by simp
    from this insert(1, 2, 4) \<open>{a} \<in> P\<close> show ?thesis
      using finite_elements[OF \<open>finite A\<close> partition_on] by simp
  next
    case False
    from \<open>partition_on (insert a A) P\<close> obtain p where p_def: "p \<in> P" "a \<in> p"
      by (blast elim: partition_onE)
    from \<open>partition_on (insert a A) P\<close> p_def have a_notmem: "\<forall>p'\<in> P - {p}. a \<notin> p'"
      by (blast elim: partition_onE)
    from \<open>partition_on (insert a A) P\<close> p_def have "p - {a} \<notin> P"
      unfolding partition_on_def disjoint_def
      by (metis Diff_insert_absorb Diff_subset inf.orderE mk_disjoint_insert)
    let ?P' = "insert (p - {a}) (P - {p})"
    have "partition_on A ?P'"
    proof (rule partition_onI)
      from \<open>partition_on (insert a A) P\<close> have "\<forall>p\<in>P. p \<noteq> {}" by (auto elim: partition_onE)
      from this p_def \<open>{a} \<notin> P\<close> show "\<And>p'. p'\<in>insert (p - {a}) (P - {p}) \<Longrightarrow> p' \<noteq> {}"
        by (simp; metis (no_types) Diff_eq_empty_iff subset_singletonD)
    next
      from \<open>partition_on (insert a A) P\<close> have "\<Union>P = insert a A" by (auto elim: partition_onE)
      from p_def this \<open>a \<notin> A\<close> a_notmem show "\<Union>(insert (p - {a}) (P - {p})) = A" by auto
    next
      show "\<And>pa pa'. pa\<in>insert (p - {a}) (P - {p}) \<Longrightarrow> pa'\<in>insert (p - {a}) (P - {p}) \<Longrightarrow> pa \<noteq> pa' \<Longrightarrow> pa \<inter> pa' = {}"
        using \<open>partition_on (insert a A) P\<close> p_def a_notmem
        unfolding partition_on_def disjoint_def
        by (metis disjoint_iff_not_equal insert_Diff insert_iff)
    qed
    have "finite P" using \<open>finite A\<close> \<open>partition_on A ?P'\<close> finite_elements by fastforce
    have "card P = Suc (card (P - {p}))"
      using p_def \<open>finite P\<close> card.remove by fastforce
    also have "\<dots> = card ?P'" using \<open>p - {a} \<notin> P\<close> \<open>finite P\<close> by simp
    also have "\<dots> \<le> card A" using \<open>partition_on A ?P'\<close> insert.hyps(3) by simp
    also have "\<dots> \<le> card (insert a A)" by (simp add: card_insert_le \<open>finite A\<close> )
    finally show ?thesis .
  qed
qed

subsection \<open>Operations on Set Partitions\<close>

lemma partition_on_union:
  assumes "A \<inter> B = {}"
  assumes "partition_on A P"
  assumes "partition_on B Q"
  shows "partition_on (A \<union> B) (P \<union> Q)"
proof (rule partition_onI)
  fix X
  assume "X \<in> P \<union> Q"
  from this \<open>partition_on A P\<close> \<open>partition_on B Q\<close> show "X \<noteq> {}"
    by (auto elim: partition_onE)
next
  show "\<Union>(P \<union> Q) = A \<union> B"
    using \<open>partition_on A P\<close> \<open>partition_on B Q\<close> by (auto elim: partition_onE)
next
  fix X Y
  assume "X \<in> P \<union> Q" "Y \<in> P \<union> Q" "X \<noteq> Y"
  from this assms show "X \<inter> Y = {}"
    by (elim UnE partition_onE) auto
qed

lemma partition_on_split1:
  assumes "partition_on A (P \<union> Q)"
  shows "partition_on (\<Union>P) P"
proof (rule partition_onI)
  fix p
  assume "p \<in> P"
  from this assms show "p \<noteq> {}"
    using Un_iff partition_onE by auto
next
  show "\<Union>P = \<Union>P" ..
next
  fix p p'
  assume a: "p \<in> P" "p' \<in> P" "p \<noteq> p'"
  from this assms show "p \<inter> p' = {}"
    using partition_onE subsetCE sup_ge1 by blast
qed

lemma partition_on_split2:
  assumes "partition_on A (P \<union> Q)"
  shows "partition_on (\<Union>Q) Q"
using assms partition_on_split1 sup_commute by metis

lemma partition_on_intersect_on_elements:
  assumes "partition_on (A \<union> C) P"
  assumes "\<forall>X \<in> P. \<exists>x. x \<in> X \<inter> C"
  shows "partition_on C ((\<lambda>X. X \<inter> C) ` P)"
proof (rule partition_onI)
  fix p
  assume "p \<in> (\<lambda>X. X \<inter> C) ` P"
  from this assms show "p \<noteq> {}" by auto
next
  have "\<Union>P = A \<union> C"
    using assms by (auto elim: partition_onE)
  from this show "\<Union>((\<lambda>X. X \<inter> C) ` P) = C" by auto
next
  fix p p'
  assume "p \<in> (\<lambda>X. X \<inter> C) ` P" "p' \<in> (\<lambda>X. X \<inter> C) ` P" "p \<noteq> p'"
  from this assms(1) show "p \<inter> p' = {}"
    by (blast elim: partition_onE)
qed

lemma partition_on_insert_elements:
  assumes "A \<inter> B = {}"
  assumes "partition_on B P"
  assumes "f \<in> A \<rightarrow>\<^sub>E P"
  shows "partition_on (A \<union> B) ((\<lambda>X. X \<union> {x \<in> A. f x = X}) ` P)" (is "partition_on _ ?P")
proof (rule partition_onI)
  fix X
  assume "X \<in> ?P"
  from this \<open>partition_on B P\<close> show "X \<noteq> {}"
    by (auto elim: partition_onE)
next
  show "\<Union>?P = A \<union> B"
    using \<open>partition_on B P\<close> \<open>f \<in> A \<rightarrow>\<^sub>E P\<close> by (auto elim: partition_onE)
next
  fix X Y
  assume "X \<in> ?P" "Y \<in> ?P" "X \<noteq> Y"
  from \<open>X \<in> ?P\<close> obtain X' where X': "X = X' \<union> {x \<in> A. f x = X'}" "X' \<in> P" by auto
  from \<open>Y \<in> ?P\<close> obtain Y' where Y': "Y = Y' \<union> {x \<in> A. f x = Y'}" "Y' \<in> P" by auto
  from \<open>X \<noteq> Y\<close> X' Y' have "X' \<noteq> Y'" by auto
  from this X' Y' have "X' \<inter> Y' = {}"
    using \<open>partition_on B P\<close> by (auto elim!: partition_onE)
  from X' Y' have "X' \<subseteq> B" "Y' \<subseteq> B"
    using \<open>partition_on B P\<close> by (auto elim!: partition_onE)
  from this \<open>X' \<inter> Y' = {}\<close> X' Y' \<open>X' \<noteq> Y'\<close> show "X \<inter> Y = {}"
    using \<open>A \<inter> B = {}\<close> by auto
qed

lemma partition_on_map:
  assumes "inj_on f A"
  assumes "partition_on A P"
  shows "partition_on (f ` A) ((`) f ` P)"
proof -
  {
    fix X Y
    assume "X \<in> P" "Y \<in> P" "f ` X \<noteq> f ` Y"
    moreover from assms have "\<forall>p\<in>P. \<forall>p'\<in>P. p \<noteq> p' \<longrightarrow> p \<inter> p' = {}" and "inj_on f (\<Union>P)"
      by (auto elim!: partition_onE)
    ultimately have "f ` X \<inter> f ` Y = {}"
      unfolding inj_on_def by auto (metis IntI empty_iff rev_image_eqI)+
  }
  from assms this show "partition_on (f ` A) ((`) f ` P)"
    by (auto intro!: partition_onI elim!: partition_onE)
qed

lemma set_of_partition_on_map:
  assumes "inj_on f A"
  shows "(`) ((`) f) ` {P. partition_on A P} = {P. partition_on (f ` A) P}"
proof (rule set_eqI')
  fix x
  assume "x \<in> (`) ((`) f) ` {P. partition_on A P}"
  from this \<open>inj_on f A\<close> show "x \<in> {P. partition_on (f ` A) P}"
    by (auto intro: partition_on_map)
next
  fix P
  assume "P \<in> {P. partition_on (f ` A) P}"
  from this have "partition_on (f ` A) P" by auto
  from this have mem: "\<And>X x. X \<in> P \<Longrightarrow> x \<in> X \<Longrightarrow> x \<in> f ` A"
    by (auto elim!: partition_onE)
  have "(`) (f \<circ> the_inv_into A f) ` P = (`) f ` (`) (the_inv_into A f) ` P"
    by (simp add: image_image cong: image_cong_simp)
  moreover have "P = (`) (f \<circ> the_inv_into A f) ` P"
  proof (rule set_eqI')
    fix X
    assume X: "X \<in> P"
    moreover from X mem have in_range: "\<forall>x\<in>X. x \<in> f ` A" by auto
    moreover have "X = (f \<circ> the_inv_into A f) ` X"
    proof (rule set_eqI')
      fix x
      assume "x \<in> X"
      show "x \<in> (f \<circ> the_inv_into A f) ` X"
      proof (rule image_eqI)
        from in_range \<open>x \<in> X\<close> assms show "x = (f \<circ> the_inv_into A f) x"
          by (auto simp add: f_the_inv_into_f[of f])
        from \<open>x \<in> X\<close> show "x \<in> X" by assumption
      qed
    next
      fix x
      assume "x \<in> (f \<circ> the_inv_into A f) ` X"
      from this obtain x' where x': "x' \<in> X \<and> x = f (the_inv_into A f x')" by auto
      from in_range x' have f: "f (the_inv_into A f x') \<in> X"
        by (subst f_the_inv_into_f[of f]) (auto intro: \<open>inj_on f A\<close>)
      from x' \<open>X \<in> P\<close> f show "x \<in> X" by auto
    qed
    ultimately show "X \<in> (`) (f \<circ> the_inv_into A f) ` P" by auto
  next
    fix X
    assume "X \<in> (`) (f \<circ> the_inv_into A f) ` P"
    moreover
    {
      fix Y
      assume "Y \<in> P"
      from this \<open>inj_on f A\<close> mem have "\<forall>x\<in>Y. f (the_inv_into A f x) = x"
        by (auto simp add: f_the_inv_into_f)
      from this have "(f \<circ> the_inv_into A f) ` Y = Y" by force
    }
    ultimately show "X \<in> P" by auto
  qed
  ultimately have P: "P = (`) f ` (`) (the_inv_into A f) ` P" by simp
  have A_eq: "A = the_inv_into A f ` f ` A" by (simp add: assms)
  from \<open>inj_on f A\<close> have "inj_on (the_inv_into A f) (f ` A)"
    using \<open>partition_on (f ` A) P\<close> by (simp add: inj_on_the_inv_into)
  from this have  "(`) (the_inv_into A f) ` P \<in> {P. partition_on A P}"
    using \<open>partition_on (f ` A) P\<close> by (subst A_eq, auto intro!: partition_on_map)
  from P this show "P \<in> (`) ((`) f) ` {P. partition_on A P}" by (rule image_eqI)
qed

end


theory Multi_Monad
  imports CryptHOL
  keywords "monad" :: thy_goal
begin

ML_file "multi_monad.ML"

monad list: "_ list" "%x. [x::'c]" List.bind
proof -
  show "[x] \<bind> f = f x" by auto
  show "m \<bind> (\<lambda>x. [x]) = m"
    unfolding List.bind_def by auto
  show "(m \<bind> f) \<bind> g = m \<bind> (\<lambda>x. f x \<bind> g)"
    unfolding List.bind_def
    by (induction m, auto)
qed

monad option: "_option" "Some" Option.bind
  by auto

ML {*
 Multi_Monad.print_functors @{context}
*}

monad pmf: "_pmf" return_pmf bind_pmf
    apply (rule bind_return_pmf)
   apply (rule bind_return_pmf')
  by (rule bind_assoc_pmf)

(* typedef 'b SPMF = "UNIV :: 'b spmf set" by simp
setup_lifting type_definition_SPMF
lift_definition return_SPMF :: "'b \<Rightarrow> 'b SPMF" is return_spmf .
lift_definition bind_SPMF :: "'b SPMF \<Rightarrow> ('b\<Rightarrow>'c SPMF) \<Rightarrow> 'c SPMF" is bind_spmf . *)

monad spmf: "_ spmf" return_spmf bind_spmf by auto

(* typedef 'a total = "UNIV :: 'a set"
  morphisms Rep_total return_total
  ..
setup_lifting type_definition_total
lift_definition bind_total :: "'a total \<Rightarrow> ('a \<Rightarrow> 'b total) \<Rightarrow> 'b total" is "%m f. f m" . *)

find_consts "'a \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b"
monad total: _ id Let by auto

(* lift_definition pmf_to_SPMF :: "'a pmf \<Rightarrow> 'a SPMF" is spmf_of_pmf . *)
lemma "spmf_of_pmf (return_pmf x) = return_spmf x" by auto
lemma "spmf_of_pmf (bind_pmf m f) = bind_spmf (spmf_of_pmf m) (\<lambda>x. spmf_of_pmf (f x))"
  apply simp using spmf_of_pmf_bind by blast

lemma "return_pmf (id x) = return_pmf x" apply transfer by auto
lemma "return_pmf (Let m f) = bind_pmf (return_pmf m) (\<lambda>x. return_pmf (f x))"
  by (simp add: bind_return_pmf)

lift_definition option_to_spmf :: "'a option \<Rightarrow> 'a spmf" is "return_pmf :: 'a option \<Rightarrow> _" .
lemma "option_to_spmf (Some x) = return_spmf x" apply transfer by auto
lemma "option_to_spmf (Option.bind m f) = bind_spmf (option_to_spmf m) (\<lambda>x. option_to_spmf (f x))"
  apply transfer
  by (metis bind.bind_lunit bind_spmf_cong return_bind_spmf return_pmf_bind_option)

(* lift_definition total_to_option :: "'a total \<Rightarrow> 'a option" is Some . *)
lemma "Some (id x) = Some x" apply transfer by simp
lemma "Some (Let m f) = Option.bind (Some m) (\<lambda>x. Some (f x))"
  apply transfer by simp

lemma "spmf_of_pmf (return_pmf m) = option_to_spmf (Some m)"
  apply transfer by simp

typedef ('a,'b) state_spmf = "UNIV :: ('b\<Rightarrow>('a*'b) spmf) set" ..
setup_lifting type_definition_state_spmf
lift_definition return_state_spmf :: "'a \<Rightarrow> ('a,'b) state_spmf" is "\<lambda>x s. return_spmf (x,s)" .
lift_definition bind_state_spmf :: "('a,'s) state_spmf \<Rightarrow> ('a \<Rightarrow> ('b,'s) state_spmf) \<Rightarrow> ('b,'s) state_spmf"
  is "\<lambda>(m::'s\<Rightarrow>('a*'s) spmf) (f::('a\<Rightarrow>'s\<Rightarrow>('b*'s) spmf)) (s::'s). bind_spmf (m s) (%(x,s). f x s)" .

declare[[ML_exception_trace]]

monad state: "(_,'s) state_spmf" return_state_spmf bind_state_spmf
    apply transfer apply simp
   apply transfer apply (rule ext) unfolding case_prod_beta apply simp
  apply transfer apply (rule ext) unfolding case_prod_beta by simp

lift_definition add_state :: "'a spmf \<Rightarrow> ('a,'s) state_spmf" is "%m s. (bind_spmf m (%x. return_spmf (x,s)))" .
lemma "add_state (return_spmf x) = return_state_spmf x" apply transfer by simp
lemma "add_state (bind_spmf m f) = bind_state_spmf (add_state m) (\<lambda>x. add_state (f x))"
  apply transfer by simp