(* Author: Tobias Nipkow, Florian Haftmann, TU Muenchen *)

section \<open>Character and string types\<close>

theory String
imports Enum
begin

subsection \<open>Strings as list of bytes\<close>

text \<open>
  When modelling strings, we follow the approach given
  in \<^url>\<open>https://utf8everywhere.org/\<close>:

  \<^item> Strings are a list of bytes (8 bit).

  \<^item> Byte values from 0 to 127 are US-ASCII.

  \<^item> Byte values from 128 to 255 are uninterpreted blobs.
\<close>

subsubsection \<open>Bytes as datatype\<close>

context unique_euclidean_semiring_with_bit_shifts
begin

lemma bit_horner_sum_iff:
  \<open>bit (foldr (\<lambda>b k. of_bool b + k * 2) bs 0) n \<longleftrightarrow> n < length bs \<and> bs ! n\<close>
proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by simp
  next
    case (Suc m)
    with bit_rec [of _ n] Cons.prems Cons.IH [of m]
    show ?thesis by simp
  qed
qed

lemma take_bit_horner_sum_eq:
  \<open>take_bit n (foldr (\<lambda>b k. of_bool b + k * 2) bs 0) = foldr (\<lambda>b k. of_bool b + k * 2) (take n bs) 0\<close>
proof (induction bs arbitrary: n)
  case Nil
  then show ?case
    by simp
next
  case (Cons b bs)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by simp
  next
    case (Suc m)
    with take_bit_rec [of n] Cons.prems Cons.IH [of m]
    show ?thesis by (simp add: ac_simps)
  qed
qed

lemma (in semiring_bit_shifts) take_bit_eq_horner_sum:
  \<open>take_bit n a = foldr (\<lambda>b k. of_bool b + k * 2) (map (bit a) [0..<n]) 0\<close>
proof (induction a arbitrary: n rule: bits_induct)
  case (stable a)
  have *: \<open>((\<lambda>k. k * 2) ^^ n) 0 = 0\<close>
    by (induction n) simp_all
  from stable have \<open>bit a = (\<lambda>_. odd a)\<close>
    by (simp add: stable_imp_bit_iff_odd fun_eq_iff)
  then have \<open>map (bit a) [0..<n] = replicate n (odd a)\<close>
    by (simp add: map_replicate_const)
  with stable show ?case
    by (simp add: stable_imp_take_bit_eq mask_eq_seq_sum *)
next
  case (rec a b)
  show ?case
  proof (cases n)
    case 0
    then show ?thesis
      by simp
  next
    case (Suc m)
    have \<open>map (bit (of_bool b + 2 * a)) [0..<Suc m] = b # map (bit (of_bool b + 2 * a)) [Suc 0..<Suc m]\<close>
      by (simp only: upt_conv_Cons) simp
    also have \<open>\<dots> = b # map (bit a) [0..<m]\<close>
      by (simp only: flip: map_Suc_upt) (simp add: bit_Suc rec.hyps)
    finally show ?thesis
      using Suc rec.IH [of m] by (simp add: take_bit_Suc rec.hyps, simp add: ac_simps mod_2_eq_odd)
  qed
qed

end

datatype char =
  Char (digit0: bool) (digit1: bool) (digit2: bool) (digit3: bool)
       (digit4: bool) (digit5: bool) (digit6: bool) (digit7: bool)

context comm_semiring_1
begin

definition of_char :: \<open>char \<Rightarrow> 'a\<close>
  where \<open>of_char c = foldr (\<lambda>b k. of_bool b + k * 2)
    [digit0 c, digit1 c, digit2 c, digit3 c, digit4 c, digit5 c, digit6 c, digit7 c] 0\<close>

lemma of_char_Char [simp]:
  \<open>of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) =
    foldr (\<lambda>b k. of_bool b + k * 2) [b0, b1, b2, b3, b4, b5, b6, b7] 0\<close>
  by (simp add: of_char_def)

end

context unique_euclidean_semiring_with_bit_shifts
begin

definition char_of :: \<open>'a \<Rightarrow> char\<close>
  where \<open>char_of n = Char (odd n) (bit n 1) (bit n 2) (bit n 3) (bit n 4) (bit n 5) (bit n 6) (bit n 7)\<close>

lemma char_of_take_bit_eq:
  \<open>char_of (take_bit n m) = char_of m\<close> if \<open>n \<ge> 8\<close>
  using that by (simp add: char_of_def bit_take_bit_iff)

lemma char_of_char [simp]:
  \<open>char_of (of_char c) = c\<close>
  by (simp only: of_char_def char_of_def bit_horner_sum_iff) simp

lemma char_of_comp_of_char [simp]:
  "char_of \<circ> of_char = id"
  by (simp add: fun_eq_iff)

lemma inj_of_char:
  \<open>inj of_char\<close>
proof (rule injI)
  fix c d
  assume "of_char c = of_char d"
  then have "char_of (of_char c) = char_of (of_char d)"
    by simp
  then show "c = d"
    by simp
qed

lemma of_char_eqI:
  \<open>c = d\<close> if \<open>of_char c = of_char d\<close>
  using that inj_of_char by (simp add: inj_eq)

lemma of_char_eq_iff [simp]:
  \<open>of_char c = of_char d \<longleftrightarrow> c = d\<close>
  by (auto intro: of_char_eqI)

lemma of_char_of [simp]:
  \<open>of_char (char_of a) = a mod 256\<close>
proof -
  have \<open>[0..<8] = [0, Suc 0, 2, 3, 4, 5, 6, 7 :: nat]\<close>
    by (simp add: upt_eq_Cons_conv)
  then have \<open>[odd a, bit a 1, bit a 2, bit a 3, bit a 4, bit a 5, bit a 6, bit a 7] = map (bit a) [0..<8]\<close>
    by simp
  then have \<open>of_char (char_of a) = take_bit 8 a\<close>
    by (simp only: char_of_def of_char_def char.sel take_bit_eq_horner_sum)
  then show ?thesis
    by (simp add: take_bit_eq_mod)
qed

lemma char_of_mod_256 [simp]:
  \<open>char_of (n mod 256) = char_of n\<close>
  by (rule of_char_eqI) simp

lemma of_char_mod_256 [simp]:
  \<open>of_char c mod 256 = of_char c\<close>
proof -
  have \<open>of_char (char_of (of_char c)) mod 256 = of_char (char_of (of_char c))\<close>
    by (simp only: of_char_of) simp
  then show ?thesis
    by simp
qed

lemma char_of_quasi_inj [simp]:
  \<open>char_of m = char_of n \<longleftrightarrow> m mod 256 = n mod 256\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
proof
  assume ?Q
  then show ?P
    by (auto intro: of_char_eqI)
next
  assume ?P
  then have \<open>of_char (char_of m) = of_char (char_of n)\<close>
    by simp
  then show ?Q
    by simp
qed

lemma char_of_eq_iff:
  \<open>char_of n = c \<longleftrightarrow> take_bit 8 n = of_char c\<close>
  by (auto intro: of_char_eqI simp add: take_bit_eq_mod)

lemma char_of_nat [simp]:
  \<open>char_of (of_nat n) = char_of n\<close>
  by (simp add: char_of_def String.char_of_def drop_bit_of_nat)

end

lemma inj_on_char_of_nat [simp]:
  "inj_on char_of {0::nat..<256}"
  by (rule inj_onI) simp

lemma nat_of_char_less_256 [simp]:
  "of_char c < (256 :: nat)"
proof -
  have "of_char c mod (256 :: nat) < 256"
    by arith
  then show ?thesis by simp
qed

lemma range_nat_of_char:
  "range of_char = {0::nat..<256}"
proof (rule; rule)
  fix n :: nat
  assume "n \<in> range of_char"
  then show "n \<in> {0..<256}"
    by auto
next
  fix n :: nat
  assume "n \<in> {0..<256}"
  then have "n = of_char (char_of n)"
    by simp
  then show "n \<in> range of_char"
    by (rule range_eqI)
qed

lemma UNIV_char_of_nat:
  "UNIV = char_of ` {0::nat..<256}"
proof -
  have "range (of_char :: char \<Rightarrow> nat) = of_char ` char_of ` {0::nat..<256}"
    by (auto simp add: range_nat_of_char intro!: image_eqI)
  with inj_of_char [where ?'a = nat] show ?thesis
    by (simp add: inj_image_eq_iff)
qed

lemma card_UNIV_char:
  "card (UNIV :: char set) = 256"
  by (auto simp add: UNIV_char_of_nat card_image)

context
  includes lifting_syntax integer.lifting natural.lifting
begin

lemma [transfer_rule]:
  \<open>((=) ===> pcr_integer) of_char of_char\<close>
  by (unfold of_char_def) transfer_prover

lemma [transfer_rule]:
  \<open>(pcr_natural ===> (=)) char_of char_of\<close>
  by (unfold char_of_def) transfer_prover

lemma [transfer_rule]:
  \<open>((=) ===> pcr_natural) of_char of_char\<close>
  by (unfold of_char_def) transfer_prover

end

lifting_update integer.lifting
lifting_forget integer.lifting

lifting_update natural.lifting
lifting_forget natural.lifting

syntax
  "_Char" :: "str_position \<Rightarrow> char"    ("CHR _")
  "_Char_ord" :: "num_const \<Rightarrow> char"   ("CHR _")

type_synonym string = "char list"

syntax
  "_String" :: "str_position \<Rightarrow> string"    ("_")

ML_file \<open>Tools/string_syntax.ML\<close>

instantiation char :: enum
begin

definition
  "Enum.enum = [
    CHR 0x00, CHR 0x01, CHR 0x02, CHR 0x03,
    CHR 0x04, CHR 0x05, CHR 0x06, CHR 0x07,
    CHR 0x08, CHR 0x09, CHR ''\<newline>'', CHR 0x0B,
    CHR 0x0C, CHR 0x0D, CHR 0x0E, CHR 0x0F,
    CHR 0x10, CHR 0x11, CHR 0x12, CHR 0x13,
    CHR 0x14, CHR 0x15, CHR 0x16, CHR 0x17,
    CHR 0x18, CHR 0x19, CHR 0x1A, CHR 0x1B,
    CHR 0x1C, CHR 0x1D, CHR 0x1E, CHR 0x1F,
    CHR '' '', CHR ''!'', CHR 0x22, CHR ''#'',
    CHR ''$'', CHR ''%'', CHR ''&'', CHR 0x27,
    CHR ''('', CHR '')'', CHR ''*'', CHR ''+'',
    CHR '','', CHR ''-'', CHR ''.'', CHR ''/'',
    CHR ''0'', CHR ''1'', CHR ''2'', CHR ''3'',
    CHR ''4'', CHR ''5'', CHR ''6'', CHR ''7'',
    CHR ''8'', CHR ''9'', CHR '':'', CHR '';'',
    CHR ''<'', CHR ''='', CHR ''>'', CHR ''?'',
    CHR ''@'', CHR ''A'', CHR ''B'', CHR ''C'',
    CHR ''D'', CHR ''E'', CHR ''F'', CHR ''G'',
    CHR ''H'', CHR ''I'', CHR ''J'', CHR ''K'',
    CHR ''L'', CHR ''M'', CHR ''N'', CHR ''O'',
    CHR ''P'', CHR ''Q'', CHR ''R'', CHR ''S'',
    CHR ''T'', CHR ''U'', CHR ''V'', CHR ''W'',
    CHR ''X'', CHR ''Y'', CHR ''Z'', CHR ''['',
    CHR 0x5C, CHR '']'', CHR ''^'', CHR ''_'',
    CHR 0x60, CHR ''a'', CHR ''b'', CHR ''c'',
    CHR ''d'', CHR ''e'', CHR ''f'', CHR ''g'',
    CHR ''h'', CHR ''i'', CHR ''j'', CHR ''k'',
    CHR ''l'', CHR ''m'', CHR ''n'', CHR ''o'',
    CHR ''p'', CHR ''q'', CHR ''r'', CHR ''s'',
    CHR ''t'', CHR ''u'', CHR ''v'', CHR ''w'',
    CHR ''x'', CHR ''y'', CHR ''z'', CHR ''{'',
    CHR ''|'', CHR ''}'', CHR ''~'', CHR 0x7F,
    CHR 0x80, CHR 0x81, CHR 0x82, CHR 0x83,
    CHR 0x84, CHR 0x85, CHR 0x86, CHR 0x87,
    CHR 0x88, CHR 0x89, CHR 0x8A, CHR 0x8B,
    CHR 0x8C, CHR 0x8D, CHR 0x8E, CHR 0x8F,
    CHR 0x90, CHR 0x91, CHR 0x92, CHR 0x93,
    CHR 0x94, CHR 0x95, CHR 0x96, CHR 0x97,
    CHR 0x98, CHR 0x99, CHR 0x9A, CHR 0x9B,
    CHR 0x9C, CHR 0x9D, CHR 0x9E, CHR 0x9F,
    CHR 0xA0, CHR 0xA1, CHR 0xA2, CHR 0xA3,
    CHR 0xA4, CHR 0xA5, CHR 0xA6, CHR 0xA7,
    CHR 0xA8, CHR 0xA9, CHR 0xAA, CHR 0xAB,
    CHR 0xAC, CHR 0xAD, CHR 0xAE, CHR 0xAF,
    CHR 0xB0, CHR 0xB1, CHR 0xB2, CHR 0xB3,
    CHR 0xB4, CHR 0xB5, CHR 0xB6, CHR 0xB7,
    CHR 0xB8, CHR 0xB9, CHR 0xBA, CHR 0xBB,
    CHR 0xBC, CHR 0xBD, CHR 0xBE, CHR 0xBF,
    CHR 0xC0, CHR 0xC1, CHR 0xC2, CHR 0xC3,
    CHR 0xC4, CHR 0xC5, CHR 0xC6, CHR 0xC7,
    CHR 0xC8, CHR 0xC9, CHR 0xCA, CHR 0xCB,
    CHR 0xCC, CHR 0xCD, CHR 0xCE, CHR 0xCF,
    CHR 0xD0, CHR 0xD1, CHR 0xD2, CHR 0xD3,
    CHR 0xD4, CHR 0xD5, CHR 0xD6, CHR 0xD7,
    CHR 0xD8, CHR 0xD9, CHR 0xDA, CHR 0xDB,
    CHR 0xDC, CHR 0xDD, CHR 0xDE, CHR 0xDF,
    CHR 0xE0, CHR 0xE1, CHR 0xE2, CHR 0xE3,
    CHR 0xE4, CHR 0xE5, CHR 0xE6, CHR 0xE7,
    CHR 0xE8, CHR 0xE9, CHR 0xEA, CHR 0xEB,
    CHR 0xEC, CHR 0xED, CHR 0xEE, CHR 0xEF,
    CHR 0xF0, CHR 0xF1, CHR 0xF2, CHR 0xF3,
    CHR 0xF4, CHR 0xF5, CHR 0xF6, CHR 0xF7,
    CHR 0xF8, CHR 0xF9, CHR 0xFA, CHR 0xFB,
    CHR 0xFC, CHR 0xFD, CHR 0xFE, CHR 0xFF]"

definition
  "Enum.enum_all P \<longleftrightarrow> list_all P (Enum.enum :: char list)"

definition
  "Enum.enum_ex P \<longleftrightarrow> list_ex P (Enum.enum :: char list)"

lemma enum_char_unfold:
  "Enum.enum = map char_of [0..<256]"
proof -
  have "map (of_char :: char \<Rightarrow> nat) Enum.enum = [0..<256]"
    by (simp add: enum_char_def of_char_def upt_conv_Cons_Cons numeral_2_eq_2 [symmetric])
  then have "map char_of (map (of_char :: char \<Rightarrow> nat) Enum.enum) =
    map char_of [0..<256]"
    by simp
  then show ?thesis
    by simp
qed

instance proof
  show UNIV: "UNIV = set (Enum.enum :: char list)"
    by (simp add: enum_char_unfold UNIV_char_of_nat atLeast0LessThan)
  show "distinct (Enum.enum :: char list)"
    by (auto simp add: enum_char_unfold distinct_map intro: inj_onI)
  show "\<And>P. Enum.enum_all P \<longleftrightarrow> Ball (UNIV :: char set) P"
    by (simp add: UNIV enum_all_char_def list_all_iff)
  show "\<And>P. Enum.enum_ex P \<longleftrightarrow> Bex (UNIV :: char set) P"
    by (simp add: UNIV enum_ex_char_def list_ex_iff)
qed

end

lemma linorder_char:
  "class.linorder (\<lambda>c d. of_char c \<le> (of_char d :: nat)) (\<lambda>c d. of_char c < (of_char d :: nat))"
  by standard auto

text \<open>Optimized version for execution\<close>

definition char_of_integer :: "integer \<Rightarrow> char"
  where [code_abbrev]: "char_of_integer = char_of"

definition integer_of_char :: "char \<Rightarrow> integer"
  where [code_abbrev]: "integer_of_char = of_char"

lemma char_of_integer_code [code]:
  "char_of_integer k = (let
     (q0, b0) = bit_cut_integer k;
     (q1, b1) = bit_cut_integer q0;
     (q2, b2) = bit_cut_integer q1;
     (q3, b3) = bit_cut_integer q2;
     (q4, b4) = bit_cut_integer q3;
     (q5, b5) = bit_cut_integer q4;
     (q6, b6) = bit_cut_integer q5;
     (_, b7) = bit_cut_integer q6
    in Char b0 b1 b2 b3 b4 b5 b6 b7)"
  by (simp add: bit_cut_integer_def char_of_integer_def char_of_def div_mult2_numeral_eq bit_iff_odd_drop_bit drop_bit_eq_div)

lemma integer_of_char_code [code]:
  "integer_of_char (Char b0 b1 b2 b3 b4 b5 b6 b7) =
    ((((((of_bool b7 * 2 + of_bool b6) * 2 +
      of_bool b5) * 2 + of_bool b4) * 2 +
        of_bool b3) * 2 + of_bool b2) * 2 +
          of_bool b1) * 2 + of_bool b0"
  by (simp add: integer_of_char_def of_char_def)

subsection \<open>Strings as dedicated type for target language code generation\<close>

subsubsection \<open>Logical specification\<close>

context
begin

qualified definition ascii_of :: "char \<Rightarrow> char"
  where "ascii_of c = Char (digit0 c) (digit1 c) (digit2 c) (digit3 c) (digit4 c) (digit5 c) (digit6 c) False"

qualified lemma ascii_of_Char [simp]:
  "ascii_of (Char b0 b1 b2 b3 b4 b5 b6 b7) = Char b0 b1 b2 b3 b4 b5 b6 False"
  by (simp add: ascii_of_def)

qualified lemma not_digit7_ascii_of [simp]:
  "\<not> digit7 (ascii_of c)"
  by (simp add: ascii_of_def)

qualified lemma ascii_of_idem:
  "ascii_of c = c" if "\<not> digit7 c"
  using that by (cases c) simp

qualified lemma char_of_ascii_of [simp]:
  "of_char (ascii_of c) = take_bit 7 (of_char c :: nat)"
  by (cases c) (simp only: ascii_of_Char of_char_Char take_bit_horner_sum_eq, simp)

qualified typedef literal = "{cs. \<forall>c\<in>set cs. \<not> digit7 c}"
  morphisms explode Abs_literal
proof
  show "[] \<in> {cs. \<forall>c\<in>set cs. \<not> digit7 c}"
    by simp
qed

qualified setup_lifting type_definition_literal

qualified lift_definition implode :: "string \<Rightarrow> literal"
  is "map ascii_of"
  by auto

qualified lemma implode_explode_eq [simp]:
  "String.implode (String.explode s) = s"
proof transfer
  fix cs
  show "map ascii_of cs = cs" if "\<forall>c\<in>set cs. \<not> digit7 c"
    using that
      by (induction cs) (simp_all add: ascii_of_idem)
qed

qualified lemma explode_implode_eq [simp]:
  "String.explode (String.implode cs) = map ascii_of cs"
  by transfer rule

end

subsubsection \<open>Syntactic representation\<close>

text \<open>
  Logical ground representations for literals are:

  \<^enum> \<open>0\<close> for the empty literal;

  \<^enum> \<open>Literal b0 \<dots> b6 s\<close> for a literal starting with one
    character and continued by another literal.

  Syntactic representations for literals are:

  \<^enum> Printable text as string prefixed with \<open>STR\<close>;

  \<^enum> A single ascii value as numerical hexadecimal value prefixed with \<open>STR\<close>.
\<close>

instantiation String.literal :: zero
begin

context
begin

qualified lift_definition zero_literal :: String.literal
  is Nil
  by simp

instance ..

end

end

context
begin

qualified abbreviation (output) empty_literal :: String.literal
  where "empty_literal \<equiv> 0"

qualified lift_definition Literal :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is "\<lambda>b0 b1 b2 b3 b4 b5 b6 cs. Char b0 b1 b2 b3 b4 b5 b6 False # cs"
  by auto

qualified lemma Literal_eq_iff [simp]:
  "Literal b0 b1 b2 b3 b4 b5 b6 s = Literal c0 c1 c2 c3 c4 c5 c6 t
     \<longleftrightarrow> (b0 \<longleftrightarrow> c0) \<and> (b1 \<longleftrightarrow> c1) \<and> (b2 \<longleftrightarrow> c2) \<and> (b3 \<longleftrightarrow> c3)
         \<and> (b4 \<longleftrightarrow> c4) \<and> (b5 \<longleftrightarrow> c5) \<and> (b6 \<longleftrightarrow> c6) \<and> s = t"
  by transfer simp

qualified lemma empty_neq_Literal [simp]:
  "empty_literal \<noteq> Literal b0 b1 b2 b3 b4 b5 b6 s"
  by transfer simp

qualified lemma Literal_neq_empty [simp]:
  "Literal b0 b1 b2 b3 b4 b5 b6 s \<noteq> empty_literal"
  by transfer simp

end

code_datatype "0 :: String.literal" String.Literal

syntax
  "_Literal" :: "str_position \<Rightarrow> String.literal"   ("STR _")
  "_Ascii" :: "num_const \<Rightarrow> String.literal"        ("STR _")

ML_file \<open>Tools/literal.ML\<close>

subsubsection \<open>Operations\<close>

instantiation String.literal :: plus
begin

context
begin

qualified lift_definition plus_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal"
  is "(@)"
  by auto

instance ..

end

end

instance String.literal :: monoid_add
  by (standard; transfer) simp_all

instantiation String.literal :: size
begin

context
  includes literal.lifting
begin

lift_definition size_literal :: "String.literal \<Rightarrow> nat"
  is length .

end

instance ..

end

instantiation String.literal :: equal
begin

context
begin

qualified lift_definition equal_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is HOL.equal .

instance
  by (standard; transfer) (simp add: equal)

end

end

instantiation String.literal :: linorder
begin

context
begin

qualified lift_definition less_eq_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp_eq (\<lambda>c d. of_char c < (of_char d :: nat))"
  .

qualified lift_definition less_literal :: "String.literal \<Rightarrow> String.literal \<Rightarrow> bool"
  is "ord.lexordp (\<lambda>c d. of_char c < (of_char d :: nat))"
  .

instance proof -
  from linorder_char interpret linorder "ord.lexordp_eq (\<lambda>c d. of_char c < (of_char d :: nat))"
    "ord.lexordp (\<lambda>c d. of_char c < (of_char d :: nat)) :: string \<Rightarrow> string \<Rightarrow> bool"
    by (rule linorder.lexordp_linorder)
  show "PROP ?thesis"
    by (standard; transfer) (simp_all add: less_le_not_le linear)
qed

end

end

lemma infinite_literal:
  "infinite (UNIV :: String.literal set)"
proof -
  define S where "S = range (\<lambda>n. replicate n CHR ''A'')"
  have "inj_on String.implode S"
  proof (rule inj_onI)
    fix cs ds
    assume "String.implode cs = String.implode ds"
    then have "String.explode (String.implode cs) = String.explode (String.implode ds)"
      by simp
    moreover assume "cs \<in> S" and "ds \<in> S"
    ultimately show "cs = ds"
      by (auto simp add: S_def)
  qed
  moreover have "infinite S"
    by (auto simp add: S_def dest: finite_range_imageI [of _ length])
  ultimately have "infinite (String.implode ` S)"
    by (simp add: finite_image_iff)
  then show ?thesis
    by (auto intro: finite_subset)
qed

subsubsection \<open>Executable conversions\<close>

context
begin

qualified lift_definition asciis_of_literal :: "String.literal \<Rightarrow> integer list"
  is "map of_char"
  .

qualified lemma asciis_of_zero [simp, code]:
  "asciis_of_literal 0 = []"
  by transfer simp

qualified lemma asciis_of_Literal [simp, code]:
  "asciis_of_literal (String.Literal b0 b1 b2 b3 b4 b5 b6 s) =
    of_char (Char b0 b1 b2 b3 b4 b5 b6 False) # asciis_of_literal s "
  by transfer simp

qualified lift_definition literal_of_asciis :: "integer list \<Rightarrow> String.literal"
  is "map (String.ascii_of \<circ> char_of)"
  by auto

qualified lemma literal_of_asciis_Nil [simp, code]:
  "literal_of_asciis [] = 0"
  by transfer simp

qualified lemma literal_of_asciis_Cons [simp, code]:
  "literal_of_asciis (k # ks) = (case char_of k
    of Char b0 b1 b2 b3 b4 b5 b6 b7 \<Rightarrow> String.Literal b0 b1 b2 b3 b4 b5 b6 (literal_of_asciis ks))"
  by (simp add: char_of_def) (transfer, simp add: char_of_def)

qualified lemma literal_of_asciis_of_literal [simp]:
  "literal_of_asciis (asciis_of_literal s) = s"
proof transfer
  fix cs
  assume "\<forall>c\<in>set cs. \<not> digit7 c"
  then show "map (String.ascii_of \<circ> char_of) (map of_char cs) = cs"
    by (induction cs) (simp_all add: String.ascii_of_idem)
qed

qualified lemma explode_code [code]:
  "String.explode s = map char_of (asciis_of_literal s)"
  by transfer simp

qualified lemma implode_code [code]:
  "String.implode cs = literal_of_asciis (map of_char cs)"
  by transfer simp

qualified lemma equal_literal [code]:
  "HOL.equal (String.Literal b0 b1 b2 b3 b4 b5 b6 s)
    (String.Literal a0 a1 a2 a3 a4 a5 a6 r)
    \<longleftrightarrow> (b0 \<longleftrightarrow> a0) \<and> (b1 \<longleftrightarrow> a1) \<and> (b2 \<longleftrightarrow> a2) \<and> (b3 \<longleftrightarrow> a3)
      \<and> (b4 \<longleftrightarrow> a4) \<and> (b5 \<longleftrightarrow> a5) \<and> (b6 \<longleftrightarrow> a6) \<and> (s = r)"
  by (simp add: equal)

end

subsubsection \<open>Technical code generation setup\<close>

text \<open>Alternative constructor for generated computations\<close>

context
begin

qualified definition Literal' :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> String.literal \<Rightarrow> String.literal"
  where [simp]: "Literal' = String.Literal"

lemma [code_computation_unfold]:
  "String.Literal = Literal'"
  by simp

end

code_reserved SML string String Char List
code_reserved OCaml string String Char List
code_reserved Haskell Prelude
code_reserved Scala string

code_printing
  type_constructor String.literal \<rightharpoonup>
    (SML) "string"
    and (OCaml) "string"
    and (Haskell) "String"
    and (Scala) "String"
| constant "STR ''''" \<rightharpoonup>
    (SML) "\"\""
    and (OCaml) "\"\""
    and (Haskell) "\"\""
    and (Scala) "\"\""

setup \<open>
  fold Literal.add_code ["SML", "OCaml", "Haskell", "Scala"]
\<close>

code_printing
  constant "(+) :: String.literal \<Rightarrow> String.literal \<Rightarrow> String.literal" \<rightharpoonup>
    (SML) infixl 18 "^"
    and (OCaml) infixr 6 "^"
    and (Haskell) infixr 5 "++"
    and (Scala) infixl 7 "+"
| constant String.literal_of_asciis \<rightharpoonup>
    (SML) "!(String.implode/ o List.map (fn k => if 0 <= k andalso k < 128 then (Char.chr o IntInf.toInt) k else raise Fail \"Non-ASCII character in literal\"))"
    and (OCaml) "!(let xs = _
      and chr k =
        let l = Z.to'_int k
          in if 0 <= l && l < 128
          then Char.chr l
          else failwith \"Non-ASCII character in literal\"
      in String.init (List.length xs) (List.nth (List.map chr xs)))"
    and (Haskell) "map/ (let chr k | (0 <= k && k < 128) = Prelude.toEnum k :: Prelude.Char in chr . Prelude.fromInteger)"
    and (Scala) "\"\"/ ++/ _.map((k: BigInt) => if (BigInt(0) <= k && k < BigInt(128)) k.charValue else sys.error(\"Non-ASCII character in literal\"))"
| constant String.asciis_of_literal \<rightharpoonup>
    (SML) "!(List.map (fn c => let val k = Char.ord c in if k < 128 then IntInf.fromInt k else raise Fail \"Non-ASCII character in literal\" end) /o String.explode)"
    and (OCaml) "!(let s = _ in let rec exp i l = if i < 0 then l else exp (i - 1) (let k = Char.code (String.get s i) in
      if k < 128 then Z.of'_int k :: l else failwith \"Non-ASCII character in literal\") in exp (String.length s - 1) [])"
    and (Haskell) "map/ (let ord k | (k < 128) = Prelude.toInteger k in ord . (Prelude.fromEnum :: Prelude.Char -> Prelude.Int))"
    and (Scala) "!(_.toList.map(c => { val k: Int = c.toInt; if (k < 128) BigInt(k) else sys.error(\"Non-ASCII character in literal\") }))"
| class_instance String.literal :: equal \<rightharpoonup>
    (Haskell) -
| constant "HOL.equal :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) = _)"
    and (OCaml) "!((_ : string) = _)"
    and (Haskell) infix 4 "=="
    and (Scala) infixl 5 "=="
| constant "(\<le>) :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) <= _)"
    and (OCaml) "!((_ : string) <= _)"
    and (Haskell) infix 4 "<="
    \<comment> \<open>Order operations for \<^typ>\<open>String.literal\<close> work in Haskell only
          if no type class instance needs to be generated, because String = [Char] in Haskell
          and \<^typ>\<open>char list\<close> need not have the same order as \<^typ>\<open>String.literal\<close>.\<close>
    and (Scala) infixl 4 "<="
    and (Eval) infixl 6 "<="
| constant "(<) :: String.literal \<Rightarrow> String.literal \<Rightarrow> bool" \<rightharpoonup>
    (SML) "!((_ : string) < _)"
    and (OCaml) "!((_ : string) < _)"
    and (Haskell) infix 4 "<"
    and (Scala) infixl 4 "<"
    and (Eval) infixl 6 "<"

subsubsection \<open>Code generation utility\<close>

setup \<open>Sign.map_naming (Name_Space.mandatory_path "Code")\<close>

definition abort :: "String.literal \<Rightarrow> (unit \<Rightarrow> 'a) \<Rightarrow> 'a"
  where [simp]: "abort _ f = f ()"

declare [[code drop: Code.abort]]

lemma abort_cong:
  "msg = msg' \<Longrightarrow> Code.abort msg f = Code.abort msg' f"
  by simp

setup \<open>Sign.map_naming Name_Space.parent_path\<close>

setup \<open>Code_Simp.map_ss (Simplifier.add_cong @{thm Code.abort_cong})\<close>

code_printing
  constant Code.abort \<rightharpoonup>
    (SML) "!(raise/ Fail/ _)"
    and (OCaml) "failwith"
    and (Haskell) "!(error/ ::/ forall a./ String -> (() -> a) -> a)"
    and (Scala) "!{/ sys.error((_));/ ((_)).apply(())/ }"

subsubsection \<open>Finally\<close>

lifting_update literal.lifting
lifting_forget literal.lifting

end


(*  Author: Tobias Nipkow, Dmitriy Traytel *)

section "Connection Between Derivatives and Partial Derivatives"

(*<*)
theory Deriv_PDeriv
imports Derivatives_Finite
begin
(*>*)

lemma pderiv_not_is_Zero_is_Plus[simp]: "\<forall>x \<in> pderiv a r. \<not> is_Zero x \<and> \<not> is_Plus x"
  by (induct r) auto

lemma finite_pderiv[simp]: "finite (pderiv a r)"
  by (induct r) auto

lemma PLUS_inject: "\<lbrakk>\<forall>x \<in> set xs \<union> set ys. \<not> is_Zero x \<and> \<not> is_Plus x; sorted xs; sorted ys\<rbrakk> \<Longrightarrow>
  (PLUS xs = PLUS ys) \<longleftrightarrow> xs = ys"
proof (induct xs arbitrary: ys rule: list_singleton_induct)
  case nil then show ?case by (induct ys rule: list_singleton_induct) auto
next
  case single then show ?case by (induct ys rule: list_singleton_induct) auto
next
  case cons then show ?case by (induct ys rule: list_singleton_induct) auto
qed

lemma sorted_list_of_set_inject: "\<lbrakk>finite R; finite S\<rbrakk> \<Longrightarrow>
  (sorted_list_of_set R = sorted_list_of_set S) \<longleftrightarrow> R = S"
proof (induct R arbitrary: S rule: finite_linorder_min_induct)
  case empty then show ?case
  proof (induct S rule: finite_linorder_min_induct)
    case (insert b S) then show ?case by simp (metis insort_not_Nil)
  qed simp
next
  case (insert a R) from this(4,1-3) show ?case
  proof (induct S rule: finite_linorder_min_induct)
    case (insert b S)
    show ?case
    proof
      assume "sorted_list_of_set (insert a R) = sorted_list_of_set (insert b S)"
      with insert(1,2,4,5) have "insort a (sorted_list_of_set R) = insort b (sorted_list_of_set S)"
        by (elim box_equals[OF _ sorted_list_of_set.insert sorted_list_of_set.insert]) auto
      with insert(2,5) have "a # sorted_list_of_set R = b # sorted_list_of_set S"
        apply (cases "sorted_list_of_set R" "sorted_list_of_set S" rule: list.exhaust[case_product list.exhaust])
        apply (auto split: if_splits simp add: not_le)
        using insort_not_Nil apply metis
        using insert.prems(1) set_sorted_list_of_set apply fastforce
        using insert.prems(1) set_sorted_list_of_set apply fastforce
        using insert.prems(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        using insert.hyps(1) set_sorted_list_of_set apply fastforce
        done
      with insert show "insert a R = insert b S" by auto
    next
      assume "insert a R = insert b S"
      then show "sorted_list_of_set (insert a R) = sorted_list_of_set (insert b S)" by simp
    qed
  qed simp
qed

lemma flatten_PLUS_inject: "\<lbrakk>\<forall>x \<in> R \<union> S. \<not> is_Zero x \<and> \<not> is_Plus x; finite R; finite S\<rbrakk> \<Longrightarrow>
  (flatten PLUS R = flatten PLUS S) = (R = S)"
  by (rule trans[OF PLUS_inject sorted_list_of_set_inject]) auto

primrec pset where
  "pset Zero = {}"
| "pset One = {One}"
| "pset (Atom a) = {Atom a}"
| "pset (Plus r s) = pset r \<union> pset s"
| "pset (Times r s) = Timess (pset r) s"
| "pset (Star r) = {Star r}"

lemma pset_not_is_Zero_is_Plus[simp]: "\<forall>x \<in> pset r. \<not> is_Zero x \<and> \<not> is_Plus x"
  by (induct r) auto

lemma finite_pset[simp]: "finite (pset r)"
  by (induct r) auto

lemma pset_deriv: "pset (deriv a r) = pderiv a r"
  by (induct r) auto

definition pnorm where
  "pnorm = flatten PLUS o pset"

fun pnPlus :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnPlus Zero r = r"
| "pnPlus r Zero = r"
| "pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
| "pnPlus r (Plus s t) =
     (if r = s then (Plus s t)
     else if le_rexp r s then Plus r (Plus s t)
     else Plus s (pnPlus r t))"
| "pnPlus r s =
     (if r = s then r
      else if le_rexp r s then Plus r s
      else Plus s r)"

fun pnTimes :: "'a::linorder rexp \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp" where
  "pnTimes Zero r = Zero"
| "pnTimes (Plus r s) t = pnPlus (pnTimes r t) (pnTimes s t)"
| "pnTimes r s = Times r s"

primrec pnorm_alt :: "'a::linorder rexp \<Rightarrow> 'a rexp" where
  "pnorm_alt Zero = Zero"
| "pnorm_alt One = One"
| "pnorm_alt (Atom a) = Atom a"
| "pnorm_alt (Plus r s) = pnPlus (pnorm_alt r) (pnorm_alt s)"
| "pnorm_alt (Times r s) = pnTimes (pnorm_alt r) s"
| "pnorm_alt (Star r) = Star r"

lemma pset_pnPlus:
  "pset (pnPlus r s) = pset (Plus r s)"
  by (induct r s rule: pnPlus.induct) auto

lemma pset_pnTimes:
  "pset (pnTimes r s) = pset (Times r s)"
  by (induct r s rule: pnTimes.induct) (auto simp: pset_pnPlus)

lemma pset_pnorm_alt_Times: "s \<in> pset r \<Longrightarrow> pnTimes (pnorm_alt s) t = Times (pnorm_alt s) t"
  by (induct r arbitrary: s t) auto

lemma pset_pnorm_alt:
  "pset (pnorm_alt r) = pnorm_alt ` pset r"
  by (induct r) (auto simp: pset_pnPlus pset_pnTimes pset_pnorm_alt_Times image_iff)

lemma pset_pnTimes_Times: "s \<in> pset r \<Longrightarrow> pnTimes s t = Times s t"
  by (induct r arbitrary: s t) auto

lemma pset_pnorm_alt_id: "s \<in> pset r \<Longrightarrow> pnorm_alt s = s"
  by (induct r arbitrary: s) (auto simp: pset_pnTimes_Times)

lemma pnorm_alt_image_pset: "pnorm_alt ` pset r = pset r"
  by (induction r) (auto, auto simp add: pset_pnorm_alt_id pset_pnTimes_Times image_iff)

lemma pnorm_pnorm_alt: "pnorm (pnorm_alt r) = pnorm r"
  by (induct r) (auto simp: pnorm_def pset_pnPlus pset_pnTimes pset_pnorm_alt pnorm_alt_image_pset)

lemma pnPlus_singleton_PLUS:
  "\<lbrakk>xs \<noteq> []; sorted xs; distinct xs; \<forall>x \<in> {x} \<union> set xs. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk> \<Longrightarrow>
  pnPlus x (PLUS xs) = (if x \<in> set xs then PLUS xs else PLUS (insort x xs))"
proof (induct xs rule: list_singleton_induct)
  case (single y)
  thus ?case unfolding is_Zero_def is_Plus_def
    apply (cases x y rule: linorder_cases)
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    apply (cases y)
    apply auto
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    apply (induct x y rule: pnPlus.induct)
    apply (auto simp: less_rexp_def less_eq_rexp_def)
    done
next
  case (cons y1 y2 ys) thus ?case unfolding is_Zero_def is_Plus_def
    apply (cases x)
    apply (metis UnCI insertI1)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply (metis UnCI insertI1)
    apply simp apply (metis antisym less_eq_rexp_def)
    apply simp apply (metis antisym less_eq_rexp_def)
    done
qed simp

lemma pnPlus_PlusL[simp]: "t \<noteq> Zero \<Longrightarrow> pnPlus (Plus r s) t = pnPlus r (pnPlus s t)"
  by (induct t) auto

lemma pnPlus_ZeroR[simp]: "pnPlus r Zero = r"
  by (induct r) auto

lemma PLUS_eq_Zero: "PLUS xs = Zero \<longleftrightarrow> xs = [] \<or> xs = [Zero]"
  by (induct xs rule: list_singleton_induct) auto

lemma pnPlus_PLUS:
  "\<lbrakk>xs1 \<noteq> []; xs2 \<noteq> []; \<forall>x \<in> set (xs1 @ xs2). \<not>is_Zero x \<and> \<not>is_Plus x; sorted xs2; distinct xs2\<rbrakk>\<Longrightarrow>
  pnPlus (PLUS xs1) (PLUS xs2) = flatten PLUS (set (xs1 @ xs2))"
proof (induct xs1 arbitrary: xs2 rule: list_singleton_induct)
  case (single x1)
  thus ?case
    apply (auto intro!: trans[OF pnPlus_singleton_PLUS]
      simp: insert_absorb simp del: sorted_list_of_set_insert)
    apply (metis List.finite_set finite_sorted_distinct_unique sorted_list_of_set)
    apply (rule arg_cong[of _ _ PLUS])
    apply (metis remdups_id_iff_distinct sorted_list_of_set_sort_remdups sorted_sort_id)
    done
next
  case (cons x11 x12 xs1)
  then show ?case unfolding rexp_of_list.simps
  apply (subst pnPlus_PlusL)
  apply (unfold PLUS_eq_Zero) []
  apply (metis in_set_conv_decomp rexp.disc(1))
  apply (subst cons(1))
  apply (simp_all del: sorted_list_of_set_insert)
  apply (rule trans[OF pnPlus_singleton_PLUS])
  apply (simp_all add: sorted_insort set_insort_key del: sorted_list_of_set_insert)
  apply safe
  unfolding insert_commute[of x11]
  apply (auto simp only: Un_insert_left[of x11, symmetric] insert_absorb) []
  apply (auto simp only: Un_insert_right[of _ x11, symmetric] insert_absorb) []
  done
qed simp

lemma pnPlus_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; X2 \<noteq> {}; finite X1; finite X2; \<forall>x \<in> X1 \<union> X2.  \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnPlus (flatten PLUS X1) (flatten PLUS X2) = flatten PLUS (X1 \<union> X2)"
  by (rule trans[OF pnPlus_PLUS]) auto

lemma pnPlus_pnorm: "pnPlus (pnorm r) (pnorm s) = pnorm (Plus r s)"
  by (cases "pset r = {} \<or> pset s = {}")
    (auto simp: pnorm_def pset_pnPlus pset_pnorm_alt intro: pnPlus_flatten_PLUS)

lemma pnTimes_not_Zero_or_Plus[simp]: "\<lbrakk>\<not> is_Zero x; \<not> is_Plus x\<rbrakk> \<Longrightarrow> pnTimes x r = Times x r"
  by (cases x) auto

lemma pnTimes_PLUS:
  "\<lbrakk>xs \<noteq> []; \<forall>x \<in> set xs. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnTimes (PLUS xs) r = flatten PLUS (Timess (set xs) r)"
proof (induct xs arbitrary: r rule: list_singleton_induct)
  case (cons x y xs) then show ?case unfolding rexp_of_list.simps pnTimes.simps
  apply (subst pnTimes_not_Zero_or_Plus)
  apply (simp_all add: sorted_insort set_insort_key del: sorted_list_of_set_insert)
  apply (subst pnPlus_singleton_PLUS)
  apply (simp_all add: sorted_insort set_insort_key del: sorted_list_of_set_insert)
  unfolding insert_commute[of "Times y r"]
  apply (simp del: sorted_list_of_set_insert)
  apply safe
  apply (subst insert_absorb[of "Times x r"])
  apply simp_all
  done
qed auto

lemma pnTimes_flatten_PLUS:
  "\<lbrakk>X1 \<noteq> {}; finite X1; \<forall>x \<in> X1. \<not>is_Zero x \<and> \<not>is_Plus x\<rbrakk>\<Longrightarrow>
  pnTimes (flatten PLUS X1) r = flatten PLUS (Timess X1 r)"
  by (rule trans[OF pnTimes_PLUS]) auto

lemma pnTimes_pnorm: "pnTimes (pnorm r1) r2 = pnorm (Times r1 r2)"
  by (cases "pset r1 = {}")
    (auto simp: pnorm_def pset_pnTimes pset_pnorm_alt intro: pnTimes_flatten_PLUS)

lemma pnorm_alt[symmetric]: "pnorm_alt r = pnorm r"
  by (induct r) (simp_all only: pnorm_alt.simps pnPlus_pnorm pnTimes_pnorm, auto simp: pnorm_def)

lemma insort_eq_Cons: "\<lbrakk>\<forall>a \<in> set xs. b < a; sorted xs\<rbrakk> \<Longrightarrow> insort b xs = b # xs"
  by (cases xs) auto

lemma pderiv_PLUS: "pderiv a (PLUS (x # xs)) = pderiv a x \<union> pderiv a (PLUS xs)"
  by (cases xs) auto

lemma pderiv_set_flatten_PLUS:
   "finite X \<Longrightarrow> pderiv (a :: 'a :: linorder) (flatten PLUS X) = pderiv_set a X"
proof (induction X rule: finite_linorder_min_induct)
  case (insert b X)
  then have "b \<notin> X" by auto
  then have "pderiv a (flatten PLUS (insert b X)) = pderiv a b \<union> pderiv a (flatten PLUS X)"
    by (simp add: pderiv_PLUS insort_eq_Cons insert.hyps)
  also from insert.IH have "\<dots> = pderiv a b \<union> pderiv_set a X" by simp
  finally show ?case by simp
qed simp

lemma fold_pderiv_set_flatten_PLUS:
  "\<lbrakk>w \<noteq> []; finite X\<rbrakk> \<Longrightarrow> fold pderiv_set w {flatten PLUS X} = fold pderiv_set w X"
  by (induct w arbitrary: X) (simp_all add: pderiv_set_flatten_PLUS)

lemma fold_pnorm_deriv:
  "fold (\<lambda>a r. pnorm (deriv a r)) w s = flatten PLUS (fold pderiv_set w {s})"
proof (induction w arbitrary: s)
  case (Cons x w) then show ?case
  proof (cases "w = []")
    case False
    show ?thesis using fold_pderiv_set_flatten_PLUS[OF False] Cons.IH
      by (auto simp: pnorm_def pset_deriv)
  qed (simp add: pnorm_def pset_deriv)
qed simp

primrec
  pnderiv :: "'a :: linorder \<Rightarrow> 'a rexp \<Rightarrow> 'a rexp"
where
  "pnderiv c (Zero) = Zero"
| "pnderiv c (One) = Zero"
| "pnderiv c (Atom c') = (if c = c' then One else Zero)"
| "pnderiv c (Plus r1 r2) = pnPlus (pnderiv c r1) (pnderiv c r2)"
| "pnderiv c (Times r1 r2) =
    (if nullable r1 then pnPlus (pnTimes (pnderiv c r1) r2) (pnderiv c r2) else pnTimes (pnderiv c r1) r2)"
| "pnderiv c (Star r) = pnTimes (pnderiv c r) (Star r)"

lemma pnderiv_alt[code]: "pnderiv a r = pnorm (deriv a r)"
  by (induct r) (auto simp: pnorm_alt)

lemma pnderiv_pderiv: "pnderiv a r = flatten PLUS (pderiv a r)"
  unfolding pnderiv_alt pnorm_def o_apply pset_deriv ..

(*<*)
end
(*>*)


section \<open> Frames \<close>

theory Frames
  imports Scene_Spaces
begin

subsection \<open> Frame type \<close>

typedef (overloaded) 'a::scene_space frame = "scene_space :: 'a scene set"
  morphisms of_frame mk_frame
  by blast

notation of_frame ("\<lbrakk>_\<rbrakk>\<^sub>F")

setup_lifting type_definition_frame

lemma UNIV_frame_scene_space: "UNIV = mk_frame ` scene_space"
  by (metis of_frame of_frame_inverse UNIV_eq_I imageI)

lemma idem_scene_frame [simp]: "idem_scene \<lbrakk>A\<rbrakk>\<^sub>F"
  by (simp add: idem_scene_space of_frame)

lemma compat_frames [simp]: "\<lbrakk>A\<rbrakk>\<^sub>F ##\<^sub>S \<lbrakk>B\<rbrakk>\<^sub>F"
  by (simp add: of_frame scene_space_compat)

lift_definition frame_scene :: "'s::scene_space scene \<Rightarrow> 's frame" ("[_]\<^sub>F")
  is "\<lambda> s. if s \<in> scene_space then s else \<bottom>\<^sub>S"
  by auto

named_theorems frame

instance frame :: (scene_space) finite
  by (intro_classes, simp add: UNIV_frame_scene_space finite_scene_space)

instantiation frame :: (scene_space) order
begin

lift_definition less_eq_frame :: "'a frame \<Rightarrow> 'a frame \<Rightarrow> bool" is "(\<le>)" .
lift_definition less_frame :: "'a frame \<Rightarrow> 'a frame \<Rightarrow> bool" is "(<)" .

instance
  apply (intro_classes; transfer)
     apply (simp add: less_scene_def)
    apply (simp_all add: less_scene_def subscene_refl)
  using idem_scene_space subscene_trans apply auto[1]
  apply (simp add: idem_scene_space subscene_antisym)
  done

end

lift_definition frame_indep :: "'a::scene_space frame \<Rightarrow> 'a frame \<Rightarrow> bool" is "(\<bowtie>\<^sub>S)" .

instantiation frame :: (scene_space) lattice
begin

lift_definition sup_frame :: "'a frame \<Rightarrow> 'a frame \<Rightarrow> 'a frame" is "(\<squnion>\<^sub>S)"
  by (simp add: union_scene_space)

lift_definition inf_frame :: "'a frame \<Rightarrow> 'a frame \<Rightarrow> 'a frame" is "(\<sqinter>\<^sub>S)"
  by (simp add: scene_space_inter)

instance
  apply (intro_classes; transfer)
  apply (metis scene_compl_subset_iff scene_demorgan2 scene_space_inter scene_space_ub scene_space_uminus)
  apply (metis inf_scene_def scene_indep_sym scene_le_iff_indep_inv scene_space_ub scene_space_uminus scene_union_commute)
  apply (metis idem_scene_space scene_compl_subset_iff scene_demorgan2 scene_space_compat scene_space_inter scene_space_uminus scene_union_mono)
  using scene_space_ub apply blast
  apply (simp add: scene_space_ub scene_union_commute)
  apply (meson idem_scene_space scene_space_compat scene_union_mono)
  done

end

abbreviation frame_union :: "'a::scene_space frame \<Rightarrow> 'a frame \<Rightarrow> 'a frame" (infixl "\<union>\<^sub>F" 65)
  where "frame_union \<equiv> sup"

abbreviation frame_inter :: "'a::scene_space frame \<Rightarrow> 'a frame \<Rightarrow> 'a frame"(infixl "\<inter>\<^sub>F" 70)
  where "frame_inter \<equiv> inf"

lemma frame_scene_union: "\<lbrakk> A \<in> scene_space; B \<in> scene_space \<rbrakk> \<Longrightarrow> [A \<squnion>\<^sub>S B]\<^sub>F = [A]\<^sub>F \<union>\<^sub>F [B]\<^sub>F"
  by (transfer, auto)

instantiation frame :: (scene_space) bounded_lattice
begin

lift_definition bot_frame :: "'a frame" is "\<bottom>\<^sub>S" by (simp add: bot_scene_space)
lift_definition top_frame :: "'a frame" is "\<top>\<^sub>S" by (simp add: top_scene_space)

instance by (intro_classes; transfer; simp add: scene_bot_least scene_top_greatest)

end

abbreviation frame_UNIV :: "'s::scene_space frame" ("\<top>\<^sub>F")
  where "\<top>\<^sub>F \<equiv> top"

abbreviation frame_empty :: "'s::scene_space frame" ("\<lbrace>\<rbrace>\<^sub>F")
  where "\<lbrace>\<rbrace>\<^sub>F \<equiv> bot"

syntax "_frame_UNIV" :: "type \<Rightarrow> logic" ("UNIV\<^sub>F'(_')")

translations "UNIV\<^sub>F('a)" == "\<top>\<^sub>F :: 'a frame"

lemma frame_top: "top = frame_scene \<top>\<^sub>S"
  by (transfer, simp add: top_scene_space)

instance frame :: (scene_space) distrib_lattice
  by (intro_classes; transfer)
     (simp add: scene_space_class.scene_union_inter_distrib)

instantiation frame :: (scene_space) boolean_algebra
begin

lift_definition minus_frame :: "'a frame \<Rightarrow> 'a frame \<Rightarrow> 'a frame" is "\<lambda> a b. a \<sqinter>\<^sub>S - b"
  by (simp add: scene_space_inter scene_space_uminus)

lift_definition uminus_frame :: "'a frame \<Rightarrow> 'a frame" is "uminus"
  by (simp add: scene_space_uminus)

instance
  by (intro_classes; transfer)
     (simp_all add: idem_scene_space scene_inter_indep scene_union_compl scene_le_iff_indep_inv subscene_refl)

end

instantiation frame :: (scene_space) "{Inf, Sup}"
begin

lift_definition Sup_frame :: "'a frame set \<Rightarrow> 'a frame" is "\<lambda> A. \<Squnion>\<^sub>S (SOME xs. set xs = A)"
proof -
  fix A :: "'a scene set"
  assume a: "\<And>x. x \<in> A \<Longrightarrow> x \<in> scene_space"
  have A_ss: "A \<subseteq> scene_space"
    by (simp add: a subsetI)
  hence "finite A"
    using finite_scene_space rev_finite_subset by blast
  then obtain xs where A: "A = set xs"
    using finite_list by blast
  hence "\<Squnion>\<^sub>S xs \<in> scene_space"
    using A_ss scene_space_foldr by blast
  moreover have "\<Squnion>\<^sub>S (SOME xs. set xs = A) = \<Squnion>\<^sub>S xs"
    by (metis (mono_tags, lifting) A A_ss foldr_scene_union_eq_scene_space someI)
  ultimately show "\<Squnion>\<^sub>S (SOME xs. set xs = A) \<in> scene_space"
    by simp
qed

definition Inf_frame :: "'a frame set \<Rightarrow> 'a frame" where "Inf_frame A = - (Sup (uminus ` A))"

instance ..

end

abbreviation frame_Union :: "'a::scene_space frame set \<Rightarrow> 'a frame"  ("\<Union>\<^sub>F")
  where "\<Union>\<^sub>FS \<equiv> Sup S"

abbreviation frame_Inter :: "'a::scene_space frame set \<Rightarrow> 'a frame"  ("\<Inter>\<^sub>F")
  where "\<Inter>\<^sub>FS \<equiv> Inf S"

instance frame :: (scene_space) complete_lattice
proof
  show Sup: "\<Union>\<^sub>F {} = bot"
    by (transfer, simp)
  show Inf: "\<Inter>\<^sub>F {} = top"
    by (simp add: Inf_frame_def Sup)
  show le_Sup: "\<And>(x::'a frame) A. x \<in> A \<Longrightarrow> x \<le> \<Union>\<^sub>F A"
  proof -
    fix x and A :: "'a frame set"
    assume "x \<in> A"
    thus "x \<le> Sup A"
    proof (transfer)
      fix x and A :: "'a scene set"
      assume x: "x \<in> scene_space" "\<forall>x\<in>A. x \<in> scene_space" "x \<in> A"
      then obtain xs where xs: "set xs = A"
        by (metis finite_list finite_scene_space rev_finite_subset subsetI)
      thus "x \<subseteq>\<^sub>S \<Squnion>\<^sub>S (SOME xs. set xs = A)"
        by (metis (mono_tags, lifting) scene_space_in_foldr someI subset_iff x(2) x(3))
    qed
  qed
  show "\<And>(x:: 'a frame) A. x \<in> A \<Longrightarrow> \<Inter>\<^sub>F A \<le> x"
  proof -
    fix x and A :: "'a frame set"
    assume xA: "x \<in> A"
    have "Inf A \<le> x \<longleftrightarrow> (- \<Union>\<^sub>F (uminus ` A) \<le> x)"
      by (simp add: Inf_frame_def)
    also have "... \<longleftrightarrow> (- x \<le> \<Union>\<^sub>F (uminus ` A))"
      using compl_le_swap2 by blast
    also have "..."
      by (simp add: le_Sup xA)
    finally show "\<Inter>\<^sub>F A \<le> x" .
  qed
  show Sup_le: "\<And>(A::'a frame set) z. (\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> \<Union>\<^sub>F A \<le> z"
  proof transfer
    fix z and A :: "'a scene set"
    assume a: "\<forall>x\<in>A. x \<in> scene_space" "z \<in> scene_space" "\<And>x. x \<in> scene_space \<Longrightarrow> x \<in> A \<Longrightarrow> x \<subseteq>\<^sub>S z"
    then obtain xs where xs: "set xs = A"
      by (metis finite_list finite_scene_space rev_finite_subset subsetI)
    with a show "\<Squnion>\<^sub>S (SOME xs. set xs = A) \<subseteq>\<^sub>S z"
      by (metis (mono_tags, lifting) scene_space_foldr_lb subset_iff tfl_some)
  qed
  show "\<And>(A :: 'a frame set) z. (\<And>x. x \<in> A \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> \<Inter>\<^sub>F A"
  proof -
    fix A :: "'a frame set" and z :: "'a frame"
    assume a: "\<And>x. x \<in> A \<Longrightarrow> z \<le> x"
    have "z \<le> Inf A \<longleftrightarrow> \<Union>\<^sub>F (uminus ` A) \<le> - z"
      by (metis Inf_frame_def compl_le_swap1)
    also have "..."
      using a compl_le_compl_iff by (blast intro: Sup_le)
    finally show "z \<le> Inf A" .
  qed
qed

lemma frame_scene_foldr: "\<lbrakk> set xs \<subseteq> scene_space \<rbrakk> \<Longrightarrow> [\<Squnion>\<^sub>S xs]\<^sub>F = \<Union>\<^sub>F (set (map frame_scene xs))"
  by (transfer, auto simp add: image_constant_conv Int_absorb2 scene_space_foldr)
     (metis (mono_tags, lifting) foldr_scene_union_eq_scene_space tfl_some)

lemma frame_scene_top: "\<top>\<^sub>F = [\<Squnion>\<^sub>S Vars]\<^sub>F"
  by (simp add: frame_top top_scene_eq)

lemma uminus_frame_Inf: "- \<Inter>\<^sub>F A = \<Union>\<^sub>F (uminus ` A)"
  by (simp add: Inf_frame_def)

lemma uminus_frame_Sup: "- \<Union>\<^sub>F A = \<Inter>\<^sub>F (uminus ` A)"
  by (simp add: Inf_frame_def SUP_image)

lift_definition frame_comp :: "'a::scene_space frame \<Rightarrow> ('a \<Longrightarrow> 'b) \<Rightarrow> 'b::scene_space frame" (infixl ";\<^sub>F" 80)
  is "\<lambda> A X. if composite_lens X then (A ;\<^sub>S X) else \<bottom>\<^sub>S"
  by (auto simp add: composite_lens.scene_space_closed_comp)

lemma frame_comp_assoc:
  assumes "composite_lens X" "composite_lens Y"
  shows "(A ;\<^sub>F X) ;\<^sub>F Y = A ;\<^sub>F (X ;\<^sub>L Y)"
  by (insert assms, transfer, simp add: scene_comp_assoc)

lemma frame_comp_empty: "\<lbrace>\<rbrace>\<^sub>F ;\<^sub>F X = \<lbrace>\<rbrace>\<^sub>F"
  by (transfer, simp)

subsection \<open> Frames as sets of basis scenes \<close>

lift_definition lens_frame :: "('a \<Longrightarrow> 's::scene_space) \<Rightarrow> 's frame"
is "\<lambda> x. if var_lens x then \<lbrakk>x\<rbrakk>\<^sub>\<sim> else \<bottom>\<^sub>S" by auto

lemma frame_scene_basis_lens: "var_lens x \<Longrightarrow> [\<lbrakk>x\<rbrakk>\<^sub>\<sim>]\<^sub>F = lens_frame x"
  by (transfer, auto)

definition lens_member :: "('a \<Longrightarrow> 's::scene_space) \<Rightarrow> 's frame \<Rightarrow> bool" (infix "\<in>\<^sub>F" 50)
  where "x \<in>\<^sub>F a \<longleftrightarrow> (lens_frame x \<le> a)"

abbreviation lens_not_member (infix "\<notin>\<^sub>F" 50) where "x \<notin>\<^sub>F A \<equiv> \<not> (x \<in>\<^sub>F A)"

lemma lens_member_frame [simp]: "x \<in>\<^sub>F lens_frame x"
  by (simp add: lens_member_def)

lemma lens_not_member_empty: "var_lens x \<Longrightarrow> (x \<in>\<^sub>F \<lbrace>\<rbrace>\<^sub>F) \<longleftrightarrow> x \<approx>\<^sub>L 0\<^sub>L"
  by (simp add: lens_member_def)
     (transfer, auto simp add: lens_equiv_scene scene_bot_least subscene_antisym zero_lens_scene)

lemma lens_not_member_empty_two [simp]: "evar_lens x \<Longrightarrow> x \<notin>\<^sub>F \<lbrace>\<rbrace>\<^sub>F"
  using ief_lens_iff_zero lens_not_member_empty no_ief_two_view var_lens.axioms(1) by blast

lemma lens_member_top [simp]: "x \<in>\<^sub>F top"
  by (simp add: lens_member_def)

lemma FUn_iff [simp]: "basis_lens x \<Longrightarrow> (x \<in>\<^sub>F a \<union>\<^sub>F b) = (x \<in>\<^sub>F a \<or> x \<in>\<^sub>F b)"
  by (simp add: lens_member_def)
     (transfer, simp add: var_le_union_iff)

lemma FCompl_iff: "ebasis_lens x \<Longrightarrow> x \<in>\<^sub>F - A \<longleftrightarrow> x \<notin>\<^sub>F A"
  apply (simp add: lens_member_def, auto)
  apply (metis (no_types, opaque_lifting) basis_then_var boolean_algebra.disj_cancel_right boolean_algebra_class.boolean_algebra.double_compl bot.extremum compl_le_swap1 dual_order.trans lens_member_def lens_not_member_empty_two sup.absorb2)
  apply (metis FUn_iff boolean_algebra.disj_cancel_right lens_member_def top_greatest)
  done

lemma FInter_iff [simp]: "basis_lens x \<Longrightarrow> (x \<in>\<^sub>F a \<inter>\<^sub>F b) = (x \<in>\<^sub>F a \<and> x \<in>\<^sub>F b)"
  by (simp add: lens_member_def)

text \<open> A basis lens is not a member of a frame when it is independent of the corresponding scene. This
  does not hold for non-basis lenses, because in that case part of the lens may be in the frame, even
  if not all of it is. \<close>

lemma basis_lens_not_member_indep: "ebasis_lens x \<Longrightarrow> x \<notin>\<^sub>F A \<longleftrightarrow> \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<bowtie>\<^sub>S \<lbrakk>A\<rbrakk>\<^sub>F"
  apply (auto simp add: lens_frame.rep_eq less_eq_frame.rep_eq FCompl_iff[THEN sym] indep_then_compl_in uminus_frame.rep_eq)
  apply (metis basis_then_var boolean_algebra_class.boolean_algebra.double_compl lens_frame.rep_eq lens_member_def less_eq_frame.rep_eq scene_le_iff_indep_inv uminus_frame.rep_eq)
  apply (simp add: indep_then_compl_in lens_frame.rep_eq lens_member_def less_eq_frame.rep_eq uminus_frame.rep_eq)
  done

definition lens_insert :: "('a \<Longrightarrow> 's::scene_space) \<Rightarrow> 's frame \<Rightarrow> 's frame"
  where "lens_insert x a = sup (lens_frame x) a"

syntax
  "_frame_set" :: "args \<Rightarrow> 'a::scene_space frame"    ("\<lbrace>(_)\<rbrace>\<^sub>F")
translations
  "\<lbrace>x, xs\<rbrace>\<^sub>F" \<rightleftharpoons> "CONST lens_insert x \<lbrace>xs\<rbrace>\<^sub>F"
  "\<lbrace>x\<rbrace>\<^sub>F" \<rightleftharpoons> "CONST lens_insert x \<lbrace>\<rbrace>\<^sub>F"

lemma lens_insert_twice [simp]: "lens_insert x (lens_insert x A) = lens_insert x A"
  by (simp add: lens_insert_def)

lemma lens_Un_insert_left [simp]: "lens_insert x A \<union>\<^sub>F B = lens_insert x (A \<union>\<^sub>F B)"
  by (simp add: lens_insert_def semigroup.assoc sup.semigroup_axioms)

lemma lens_insert_iff:
  assumes "basis_lens x" "basis_lens y"
  shows "x \<in>\<^sub>F lens_insert y A \<longleftrightarrow> x \<approx>\<^sub>L 0\<^sub>L \<or> x \<approx>\<^sub>L y \<or> x \<in>\<^sub>F A"
  using assms
  apply (simp add: lens_insert_def lens_member_def)
  apply (transfer)
  apply (simp_all add: lens_equiv_scene scene_bot_least zero_lens_scene)
  apply (metis basis_lens.lens_in_basis basis_then_var le_vars_then_equal scene_bot_least subscene_refl var_le_union_iff var_lens.lens_in_scene_space)
  done

lemma lens_insert_iff_two [simp]:
  assumes "basis_lens (x :: 'a::two \<Longrightarrow> 's::scene_space)" "basis_lens y"
  shows "x \<in>\<^sub>F lens_insert y A \<longleftrightarrow> x \<approx>\<^sub>L y \<or> x \<in>\<^sub>F A"
  using assms basis_lens_def ief_lens_iff_zero lens_insert_iff no_ief_two_view by blast

lemma lens_insert_commute: "lens_insert x (lens_insert y A) = lens_insert y (lens_insert x A)"
  by (simp add: lens_insert_def sup.left_commute)

lemma lens_scene_insert_frame:
  "var_lens x \<Longrightarrow> \<lbrakk>x\<rbrakk>\<^sub>\<sim> \<squnion>\<^sub>S \<lbrakk>A\<rbrakk>\<^sub>F = \<lbrakk>lens_insert x A\<rbrakk>\<^sub>F"
  by (simp add: lens_frame.rep_eq lens_insert_def sup_frame.rep_eq)

lemma frame_single_var_lens [simp]: "var_lens x \<Longrightarrow> [\<lbrakk>x\<rbrakk>\<^sub>\<sim>]\<^sub>F = lens_insert x frame_empty"
  by (simp add: frame_scene_basis_lens lens_insert_def)

subsection \<open> Equivalence under a frame \<close>

lift_definition frame_equiv :: "'a::scene_space \<Rightarrow> 'a \<Rightarrow> 'a frame \<Rightarrow> bool" ("_ \<approx>\<^sub>F _ on _" [65,0,66] 65)
  is "\<lambda> s\<^sub>1 s\<^sub>2 a. s\<^sub>1 \<approx>\<^sub>S s\<^sub>2 on a" .

lemma frame_equiv_empty [simp]: "s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on \<lbrace>\<rbrace>\<^sub>F"
  by (transfer, simp)

lemma frame_equiv_top [simp]: "s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on \<top>\<^sub>F = (s\<^sub>1 = s\<^sub>2)"
  by (metis frame_equiv.rep_eq scene_equiv_def scene_override_id top_frame.rep_eq)

lemma frame_equiv_refl [simp]: "s \<approx>\<^sub>F s on a"
  by (simp add: of_frame frame_equiv.rep_eq idem_scene_space scene_equiv_def)

lemma frame_equiv_sym [simp]: "s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on a \<Longrightarrow> s\<^sub>2 \<approx>\<^sub>F s\<^sub>1 on a"
  by (transfer, simp add: scene_equiv_def)
     (metis idem_scene_space scene_override_idem scene_override_overshadow_right)

lemma frame_equiv_trans_gen [simp]: "\<lbrakk> s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on a; s\<^sub>2 \<approx>\<^sub>F s\<^sub>3 on b \<rbrakk> \<Longrightarrow> s\<^sub>1 \<approx>\<^sub>F s\<^sub>3 on (a \<inter>\<^sub>F b)"
proof (transfer, simp add: scene_override_inter scene_space_compat scene_space_uminus)
  fix a b :: "'a scene" and s\<^sub>1 s\<^sub>2 s\<^sub>3 :: "'a"
  assume
    a:"a \<in> scene_space" and b: "b \<in> scene_space" and
    "s\<^sub>1 \<approx>\<^sub>S s\<^sub>2 on a" "s\<^sub>2 \<approx>\<^sub>S s\<^sub>3 on b"
  have 1: "s\<^sub>3 = s\<^sub>3 \<oplus>\<^sub>S s\<^sub>2 on b"
    by (metis \<open>b \<in> scene_space\<close> \<open>s\<^sub>2 \<approx>\<^sub>S s\<^sub>3 on b\<close> idem_scene_space scene_equiv_def scene_equiv_sym)
  have 2: "s\<^sub>1 = s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on a"
    by (metis \<open>s\<^sub>1 \<approx>\<^sub>S s\<^sub>2 on a\<close> scene_equiv_def)
  have 3: "s\<^sub>2 = s\<^sub>2 \<oplus>\<^sub>S s\<^sub>3 on b"
    by (metis \<open>s\<^sub>2 \<approx>\<^sub>S s\<^sub>3 on b\<close> scene_equiv_def)

  have "s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>1 \<oplus>\<^sub>S s\<^sub>3 on a) on b = s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>3 \<oplus>\<^sub>S s\<^sub>2 on b) on a) on b"
    using "1" by auto
  also from 1 2 3 a b have "... = s\<^sub>1 \<oplus>\<^sub>S (s\<^sub>1 \<oplus>\<^sub>S s\<^sub>2 on a) on b"
    by (metis scene_inter_commute scene_override_inter scene_override_overshadow_right scene_space_compat scene_space_uminus)
  also have "... = s\<^sub>1 \<oplus>\<^sub>S s\<^sub>1 on b"
    using 2 by auto
  also have "... = s\<^sub>1"
    by (simp add: b idem_scene_space)
  finally show "s\<^sub>1 \<approx>\<^sub>S s\<^sub>3 on a \<sqinter>\<^sub>S b"
    by (simp add: a b scene_equiv_def scene_override_inter scene_space_compat scene_space_uminus)
qed

lemma frame_equiv_trans: "\<lbrakk> s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on a; s\<^sub>2 \<approx>\<^sub>F s\<^sub>3 on a \<rbrakk> \<Longrightarrow> s\<^sub>1 \<approx>\<^sub>F s\<^sub>3 on a"
  by (transfer)
     (metis scene_equiv_def scene_override_overshadow_right)

lemma put_eq_ebasis_lens_notin:
  "\<lbrakk> ebasis_lens x; s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on A; x \<notin>\<^sub>F A \<rbrakk> \<Longrightarrow> put\<^bsub>x\<^esub> s\<^sub>1 v \<approx>\<^sub>F put\<^bsub>x\<^esub> s\<^sub>2 v on A"
  by (simp add: basis_lens_not_member_indep, transfer)
     (metis basis_lens.axioms(1) idem_scene_space idem_scene_uminus indep_then_compl_in put_scene_override_le_distrib scene_equiv_def scene_override_commute)

lemma put_eq_var_lens_notin: "\<lbrakk> var_lens x; s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on A; x \<in>\<^sub>F A \<rbrakk> \<Longrightarrow> put\<^bsub>x\<^esub> s\<^sub>1 v \<approx>\<^sub>F put\<^bsub>x\<^esub> s\<^sub>2 v on A"
  unfolding lens_member_def
  by (transfer, simp, metis idem_scene_space put_scene_override_le_distrib scene_equiv_def var_lens.axioms(1))

lemma put_eq_ebasis_lens:
  assumes "ebasis_lens x" "s\<^sub>1 \<approx>\<^sub>F s\<^sub>2 on A"
  shows "put\<^bsub>x\<^esub> s\<^sub>1 v \<approx>\<^sub>F put\<^bsub>x\<^esub> s\<^sub>2 v on A"
  by (meson assms basis_then_var put_eq_ebasis_lens_notin put_eq_var_lens_notin)

end


theory sort_StoogeSort2IsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

fun ztake :: "int => 'a list => 'a list" where
"ztake x y =
   (if x = 0 then Nil2 else
      case y of
        | Nil2 => y
        | Cons2 z xs => Cons2 z (ztake (x - 1) xs)
      end)"

fun zlength :: "'a list => int" where
"zlength (Nil2) = 0"
| "zlength (Cons2 y xs) = 1 + (zlength xs)"

fun zdrop :: "int => 'a list => 'a list" where
"zdrop x y =
   (if x = 0 then y else
      case y of
        | Nil2 => y
        | Cons2 z xs => zdrop (x - 1) xs
      end)"

fun zsplitAt :: "int => 'a list =>
                 (('a list), ('a list)) Pair2" where
"zsplitAt x y = Pair (ztake x y) (zdrop x y)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

function stooge2sort2 :: "int list => int list"
         and stoogesort2 :: "int list => int list"
         and stooge2sort1 :: "int list => int list" where
"stooge2sort2 x =
   case zsplitAt (div ((2 * (zlength x)) + 1) 3) x of
     | Pair ys zs =>
         case zsplitAt (div ((2 * (zlength x)) + 1) 3) x of
           | Pair xs zs2 => append (stoogesort2 ys) zs2
         end
   end"
| "stoogesort2 (Nil2) = Nil2"
| "stoogesort2 (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "stoogesort2 (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "stoogesort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     stooge2sort2
       (stooge2sort1 (stooge2sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "stooge2sort1 x =
     case zsplitAt (div (zlength x) 3) x of
       | Pair ys zs =>
           case zsplitAt (div (zlength x) 3) x of
             | Pair xs zs2 => append ys (stoogesort2 zs2)
           end
     end"
by pat_completeness auto

(*hipster ztake
          zlength
          zdrop
          zsplitAt
          sort2
          insert2
          isort
          append
          stooge2sort2
          stoogesort2
          stooge2sort1 *)

theorem x0 :
  "!! (x :: int list) . (stoogesort2 x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section \<open>Implementations of the W-Method\<close>

theory W_Method_Implementations
imports Intermediate_Frameworks Pair_Framework "../Distinguishability" Test_Suite_Representations "../OFSM_Tables_Refined" "HOL-Library.List_Lexorder"
begin

subsection \<open>Using the H-Framework\<close>

definition w_method_via_h_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "w_method_via_h_framework M m = h_framework_static_with_empty_graph M (\<lambda> k q . distinguishing_set M) m"

definition w_method_via_h_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "w_method_via_h_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (w_method_via_h_framework M m))"

lemma w_method_via_h_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (w_method_via_h_framework M1 m)) = (L M2 \<inter> set (w_method_via_h_framework M1 m)))"
and "finite_tree (w_method_via_h_framework M1 m)"
  using h_framework_static_with_empty_graph_completeness_and_finiteness[OF assms, where dist_fun="(\<lambda> k q . distinguishing_set M1)"]
  using distinguishing_set_distinguishes[OF assms(1,3)]
  using distinguishing_set_finite
  unfolding w_method_via_h_framework_def
  by blast+

lemma w_method_via_h_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (w_method_via_h_framework_lists M1 m)"
  using h_framework_static_with_empty_graph_lists_completeness[OF assms, where dist_fun="(\<lambda> k q . distinguishing_set M1)", OF _ distinguishing_set_finite]
  using distinguishing_set_distinguishes[OF assms(1,3)]
  unfolding w_method_via_h_framework_lists_def h_framework_static_with_empty_graph_lists_def w_method_via_h_framework_def
  by blast

definition w_method_via_h_framework_2 :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "w_method_via_h_framework_2 M m = h_framework_static_with_empty_graph M (\<lambda> k q . distinguishing_set_reduced M) m"

definition w_method_via_h_framework_2_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "w_method_via_h_framework_2_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (w_method_via_h_framework_2 M m))"

lemma w_method_via_h_framework_2_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('e,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (w_method_via_h_framework_2 M1 m)) = (L M2 \<inter> set (w_method_via_h_framework_2 M1 m)))"
and "finite_tree (w_method_via_h_framework_2 M1 m)"
  using h_framework_static_with_empty_graph_completeness_and_finiteness[OF assms, where dist_fun="(\<lambda> k q . distinguishing_set_reduced M1)"]
  using distinguishing_set_reduced_distinguishes[OF assms(1,3)]
  using distinguishing_set_reduced_finite
  unfolding w_method_via_h_framework_2_def
  by blast+

lemma w_method_via_h_framework_lists_2_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (w_method_via_h_framework_2_lists M1 m)"
  using h_framework_static_with_empty_graph_lists_completeness[OF assms, where dist_fun="(\<lambda> k q . distinguishing_set_reduced M1)", OF _ distinguishing_set_reduced_finite]
  using distinguishing_set_reduced_distinguishes[OF assms(1,3)]
  unfolding w_method_via_h_framework_2_lists_def h_framework_static_with_empty_graph_lists_def w_method_via_h_framework_2_def
  by blast

subsection \<open>Using the SPY-Framework\<close>

definition w_method_via_spy_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "w_method_via_spy_framework M m = spy_framework_static_with_empty_graph M (\<lambda> k q . distinguishing_set M) m"

lemma w_method_via_spy_framework_completeness_and_finiteness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> ((L M1 \<inter> set (w_method_via_spy_framework M1 m)) = (L M2 \<inter> set (w_method_via_spy_framework M1 m)))"
and "finite_tree (w_method_via_spy_framework M1 m)"
  unfolding w_method_via_spy_framework_def
  using spy_framework_static_with_empty_graph_completeness_and_finiteness[OF assms, of "(\<lambda> k q . distinguishing_set M1)"]
  using distinguishing_set_distinguishes[OF assms(1,3)]
  using distinguishing_set_finite[of M1]
  by (metis IntI)+

definition w_method_via_spy_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "w_method_via_spy_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (w_method_via_spy_framework M m))"

lemma w_method_via_spy_framework_lists_completeness :
  fixes M1 :: "('a::linorder,'b::linorder,'c::linorder) fsm"
  fixes M2 :: "('d,'b,'c) fsm"
  assumes "observable M1"
  and     "observable M2"
  and     "minimal M1"
  and     "minimal M2"
  and     "size_r M1 \<le> m"
  and     "size M2 \<le> m"
  and     "inputs M2 = inputs M1"
  and     "outputs M2 = outputs M1"
shows "(L M1 = L M2) \<longleftrightarrow> list_all (passes_test_case M2 (initial M2)) (w_method_via_spy_framework_lists M1 m)"
  unfolding w_method_via_spy_framework_lists_def
            w_method_via_spy_framework_completeness_and_finiteness(1)[OF assms]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial w_method_via_spy_framework_completeness_and_finiteness(2)[OF assms]]
  by blast

subsection \<open>Using the Pair-Framework\<close>

definition w_method_via_pair_framework :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> ('b\<times>'c) prefix_tree" where
  "w_method_via_pair_framework M m = pair_framework_h_components M m add_distinguishing_set"

lemma w_method_via_pair_framework_completeness_and_finiteness :
  assumes "observable M"
  and     "observable I"
  and     "minimal M"
  and     "size I \<le> m"
  and     "m \<ge> size_r M"
  and     "inputs I = inputs M"
  and     "outputs I = outputs M"
shows "(L M = L I) \<longleftrightarrow> (L M \<inter> set (w_method_via_pair_framework M m) = L I \<inter> set (w_method_via_pair_framework M m))"
and   "finite_tree (w_method_via_pair_framework M m)"
  using pair_framework_h_components_completeness_and_finiteness[OF assms(1,2,3,5,4,6,7), where get_separating_traces="add_distinguishing_set", OF add_distinguishing_set_distinguishes[OF assms(1,3)] add_distinguishing_set_finite]
  using get_distinguishing_sequence_from_ofsm_tables_distinguishes[OF assms(1,3)]
  unfolding w_method_via_pair_framework_def[symmetric]
  by blast+

definition w_method_via_pair_framework_lists :: "('a::linorder,'b::linorder,'c::linorder) fsm \<Rightarrow> nat \<Rightarrow> (('b\<times>'c) \<times> bool) list list" where
  "w_method_via_pair_framework_lists M m = sorted_list_of_maximal_sequences_in_tree (test_suite_from_io_tree M (initial M) (w_method_via_pair_framework M m))"

lemma w_method_implementation_lists_completeness :
  assumes "observable M"
  and     "observable I"
  and     "minimal M"
  and     "size I \<le> m"
  and     "m \<ge> size_r M"
  and     "inputs I = inputs M"
  and     "outputs I = outputs M"
shows "(L M = L I) \<longleftrightarrow> list_all (passes_test_case I (initial I)) (w_method_via_pair_framework_lists M m)"
unfolding w_method_via_pair_framework_lists_def
            w_method_via_pair_framework_completeness_and_finiteness(1)[OF assms]
            passes_test_cases_from_io_tree[OF assms(1,2) fsm_initial fsm_initial w_method_via_pair_framework_completeness_and_finiteness(2)[OF assms]]
  by blast

subsection \<open>Code Generation\<close>

lemma w_method_via_pair_framework_code[code] :
  "w_method_via_pair_framework M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
      pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M));
      distSet = from_list (map (case_prod distHelper) pairs);
      distFun = (\<lambda>  M x t . distSet)
    in pair_framework_h_components M m distFun)"
  unfolding w_method_via_pair_framework_def pair_framework_h_components_def pair_framework_def
  unfolding add_distinguishing_set.simps
  unfolding distinguishing_set.simps
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

lemma w_method_via_spy_framework_code[code] :
  "w_method_via_spy_framework M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
      pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M));
      distSet = from_list (map (case_prod distHelper) pairs);
      distFun = (\<lambda> k q . distSet)
    in spy_framework_static_with_empty_graph M distFun m)"
  unfolding w_method_via_spy_framework_def
  unfolding add_distinguishing_set.simps
  unfolding distinguishing_set.simps
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

lemma w_method_via_h_framework_code[code] :
  "w_method_via_h_framework M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
      pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M));
      distSet = from_list (map (case_prod distHelper) pairs);
      distFun = (\<lambda> k q . distSet)
    in h_framework_static_with_empty_graph M distFun m)"
  unfolding w_method_via_h_framework_def
  unfolding distinguishing_set.simps
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

lemma w_method_via_h_framework_2_code[code] :
  "w_method_via_h_framework_2 M m = (let
      tables = (compute_ofsm_tables M (size M - 1));
      distMap = mapping_of (map (\<lambda> (q1,q2) . ((q1,q2), get_distinguishing_sequence_from_ofsm_tables_with_provided_tables tables M q1 q2))
                        (filter (\<lambda> qq . fst qq \<noteq> snd qq) (List.product (states_as_list M) (states_as_list M))));
      distHelper = (\<lambda> q1 q2 . if q1 \<in> states M \<and> q2 \<in> states M \<and> q1 \<noteq> q2 then the (Mapping.lookup distMap (q1,q2)) else get_distinguishing_sequence_from_ofsm_tables M q1 q2);
      pairs = filter (\<lambda> (x,y) . x \<noteq> y) (list_ordered_pairs (states_as_list M));
      handlePair = (\<lambda> W (q,q') . if contains_distinguishing_trace M W q q'
                                then W
                                else insert W (distHelper q q'));
      distSet = foldl handlePair empty pairs;
      distFun = (\<lambda> k q . distSet)
    in h_framework_static_with_empty_graph M distFun m)"
  unfolding w_method_via_h_framework_2_def
  unfolding distinguishing_set_reduced.simps
  apply (subst get_distinguishing_sequence_from_ofsm_tables_precomputed[of M])
  unfolding Let_def
  by presburger

end


theory FSM_Enumerator
imports State_Separator (* TODO *)
begin

(* TODO: move *)
(* TODO: just add left ... *)
(*
fun find_last_index :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat option" where
  "find_last_index f xs = (case find_index f (rev xs) of
    None \<Rightarrow> None |
    Some i \<Rightarrow> Some (length xs - Suc i))"

value "find_index ((=) True) [False,True,True,False,True]"
value "find_last_index ((=) True) [False,True,True,False,True]"

lemma find_last_index_index :
  assumes "find_last_index f xs = Some k"
  shows "k < length xs" and "f (xs ! k)" and "\<And> j . j > k \<Longrightarrow> k < length xs \<Longrightarrow> \<not> f (xs ! j)"
*)

fun next_boolean_list :: "bool list \<Rightarrow> (bool list) option" where
  "next_boolean_list [] = None" |
  "next_boolean_list (False#[]) = None" |
  "next_boolean_list (False#ts) = (case next_boolean_list ts of None \<Rightarrow> None | Some ts' \<Rightarrow> Some (True # ts'))" |
  "next_boolean_list (True#ts) = Some (False # ts)"

value "next_boolean_list [True ,True ,True ]"
value "next_boolean_list [False,True ,True ]"
value "next_boolean_list [True ,False,True ]"
value "next_boolean_list [False,False,True ]"
value "next_boolean_list [True ,True ,False]"
value "next_boolean_list [False,True ,False]"
value "next_boolean_list [True ,False,False]"
value "next_boolean_list [False,False,False]"

fun bool_list_less :: "bool list \<Rightarrow> bool list \<Rightarrow> bool" where
  "bool_list_less [] bs2 = True" |
  "bool_list_less bs1 [] = False" |
  "bool_list_less (b1#bs1) (b2#bs2) = ((\<not>b1 \<and> b2) \<or> ((b1 = b2) \<and> (bs1 \<noteq> bs2) \<and> bool_list_less bs1 bs2))"

abbreviation(input) "bool_lists k \<equiv> {bs :: bool list . length bs = k}"

lemma next_boolean_list_length :
  assumes "next_boolean_list bs = Some bs'"
shows "length bs' = length bs"
using assms proof (induction bs arbitrary: bs')
  case Nil
  then show ?case by auto
next
  case (Cons b bs)
  then show ?case proof (cases "length bs > 0")
    case True
    then show ?thesis proof (cases b)
      case True
      then show ?thesis using \<open>0 < length bs\<close>
        using Cons.prems by auto
    next
      case False
      then have "b = False" by auto
      then have "next_boolean_list (False # bs) = Some bs'" using Cons.prems by auto
      then obtain bs'' where "next_boolean_list bs = Some bs''"
      proof -
        assume "\<And>bs''. next_boolean_list bs = Some bs'' \<Longrightarrow> thesis"
        then show ?thesis
          by (metis (no_types) True \<open>next_boolean_list (False # bs) = Some bs'\<close> length_0_conv neq_Nil_conv next_boolean_list.simps(3) not_None_eq not_less0 option.simps(4))
      qed
      then have "next_boolean_list (False # bs) = Some (True # bs'')"
        using \<open>next_boolean_list (False # bs) = Some bs'\<close>
        using next_boolean_list.elims by force

      then show ?thesis using Cons.IH[OF \<open>next_boolean_list bs = Some bs''\<close>]
        using \<open>next_boolean_list (False # bs) = Some bs'\<close> by auto
    qed
  next
    case False
    then show ?thesis
      using Cons
      by (metis (full_types) length_Cons length_greater_0_conv next_boolean_list.simps(2) next_boolean_list.simps(4) not_None_eq option.sel)
  qed
qed

fun enumerate_transitions :: "'a list \<Rightarrow> Input list \<Rightarrow> Output list \<Rightarrow> 'a Transition list" where
  "enumerate_transitions qs xs ys = cartesian_product_list qs
                                      (cartesian_product_list xs
                                        (cartesian_product_list ys qs))"

fun find_FSM' :: "('a FSM \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> Input list \<Rightarrow> Output list \<Rightarrow> 'a Transition list \<Rightarrow> bool list \<Rightarrow> nat \<Rightarrow> 'a FSM option" where
  "find_FSM' f q xs ys ts bs 0 = None" |
  "find_FSM' f q xs ys ts bs (Suc k) = (let M = \<lparr> initial = q, inputs = xs, outputs = ys, transitions = map fst (filter snd (zip ts bs)) \<rparr> in
    if f M then Some M
    else (case next_boolean_list bs of
      Some bs' \<Rightarrow> find_FSM' f q xs ys ts bs' k |
      None \<Rightarrow> None))"

fun find_FSM :: "('a FSM \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> Input list \<Rightarrow> Output list \<Rightarrow> 'a FSM option" where
  "find_FSM f q qs xs ys = (let ts = enumerate_transitions qs xs ys
                            in find_FSM' f q xs ys ts (replicate (length ts) True) (power 2 (length ts)))"

(*

lemma next_boolean_list_diff :
  assumes "length bs > 0"
  and     "next_boolean_list bs = Some bs'"
shows "bool_list_less bs bs' \<and> \<not> (\<exists> bs'' . bool_list_less bs bs'' \<and> bool_list_less bs'' bs')"
using next_boolean_list_length[OF assms(2)] assms(1) proof (induction bs' bs rule: list_induct2)
  case Nil
  then show ?case by auto
next
  case (Cons x xs y ys)

qed
using assms proof (induction bs)
case Nil
  then show ?case by auto
next
  case (Cons b bs)
  then show ?case proof (cases "length bs > 0")
    case True
    then show ?thesis using Cons
  next
    case False
    then show ?thesis sorry
  qed
qed

fun find_boolean_list :: "(bool list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> (bool list) option"

lemma next_boolean_list_find :
  assumes "\<exists> bs . length bs = k \<and> P bs"
  shows "

fun next_selector_list :: "bool list \<Rightarrow> (bool list) option" where
  "next_selector_list =

(* TODO: move *)
fun generate_sublists :: "'a list \<Rightarrow> 'a list list" where
  "generate_sublists [] = [[]]" |
  "generate_sublists (x#xs) = (let sl = generate_sublists xs in sl @ (map ((#) x) sl))"

value "generate_sublists [0::nat,1,2,3]"

lemma set_map_insert :
  "image set (set (map ((#) x) xs)) = image (insert x) (image set (set xs))"
by (induction xs; auto)

lemma generate_sublists_powerset :
  "image set (set (generate_sublists xs)) = Pow (set xs)"
proof (induction xs)
  case Nil
  then show ?case by auto
next
  case (Cons x xs)

  have "image set (set (map ((#) x) (generate_sublists xs))) = (image (insert x) (Pow (set xs)))"
    using Cons set_map_insert[of x "generate_sublists xs"]
    by simp

  then have "image set (set (generate_sublists xs @ map ((#) x) (generate_sublists xs))) = Pow (set xs) \<union> (image (insert x) (Pow (set xs)))"
    using Cons
    by (simp add: image_Un)
  moreover have "Pow (set (x # xs)) = Pow (set xs) \<union> (image (insert x) (Pow (set xs)))"
    by (simp add: Pow_insert)
  ultimately show ?case unfolding generate_sublists.simps Let_def
    by auto
qed

fun enumerate_transitions :: "'a list \<Rightarrow> Input list \<Rightarrow> Output list \<Rightarrow> 'a Transition list" where
  "enumerate_transitions qs xs ys = cartesian_product_list qs
                                      (cartesian_product_list xs
                                        (cartesian_product_list ys qs))"

value "enumerate_transitions [0::nat,1,2,3] [0,1] [0,1,2]"

(* TODO: add variant that also uses sublists for inputs and outputs? *)
fun enumerate_FSMs :: "'a \<Rightarrow> 'a list \<Rightarrow> Input list \<Rightarrow> Output list \<Rightarrow> 'a FSM list" where
  "enumerate_FSMs q qs xs ys = map (\<lambda> ts . \<lparr> initial = q, inputs = xs, outputs = ys, transitions = ts  \<rparr>) (generate_sublists (enumerate_transitions qs xs ys))"

value "enumerate_FSMs (0::nat) [0,1] [0] [0,1]"

value "filter observable (enumerate_FSMs (0::nat) [0,1] [0] [0,1])"
*)

end


header {* Deutsch-Schorr-Waite Marking Algorithm *}

theory DSWMark
imports LinkMark
begin

text{*
Finally, we construct the Deutsch-Schorr-Waite marking algorithm by assuming that there
are only two pointers ($\mathit{left}$, $\mathit{right}$) from every node. There is also a new variable,
$\mathit{atom}: \mathit{node} \to  \mathit{bool}$ which associates to every node a Boolean value.
The data invariant of this refinement step requires that $\mathit{index}$ has exactly two distinct
elements $none$  and $\mathit{some}$, $\mathit{left} = \mathit{link}\ \mathit{none}$,
$\mathit{right}=\mathit{link}\  \mathit{some}$, and $\mathit{atom}\ x$ is true
if and only if $\mathit{label}\ x = \mathit{some}$.

We use a new locale which fixes the initial values of the variables $\mathit{left}$, $\mathit{right}$, and
$\mathit{atom}$ in $\mathit{left0}$, $\mathit{right0}$, and $\mathit{atom0}$ respectively.
*}

datatype Index = none | some

locale classical = node +
  fixes left0  :: "'node \<Rightarrow> 'node"
  fixes right0 :: "'node \<Rightarrow> 'node"
  fixes atom0  :: "'node \<Rightarrow> bool"
  assumes "(nil::'node) = nil"
  begin
    definition
      "link0 i = (if i = (none::Index) then left0 else right0)"

    definition
      "label0 x = (if atom0 x then (some::Index) else none)"
  end

sublocale classical \<subseteq> dsw: pointer "nil" "root" "none::Index" "link0" "label0"
proof qed auto

context classical
begin

definition
  "gg mrk atom ptr x \<equiv> ptr x \<noteq> nil \<and> ptr x \<notin> mrk \<and> \<not> atom x"

subsection {* Transitions *}

definition
  "QQ1_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
         root = nil \<and>  p' = nil \<and> t' = nil \<and> mrk' = mrk \<and> left' = left
         \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ2_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
         root \<noteq> nil \<and>  p' = root \<and> t' = nil \<and> mrk' = mrk \<union> {root}
         \<and> left' = left \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ3_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> gg mrk atom left p \<and>
      p' = left p \<and> t' = p \<and> mrk' = mrk \<union> {left p} \<and>
      left' = left(p := t) \<and> right' = right \<and> atom' = atom:]"

definition
  "QQ4_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> gg mrk atom right p \<and>
      p' = right p \<and> t' = p \<and> mrk' = mrk \<union> {right p} \<and>
      left' = left \<and> right' = right(p := t) \<and> atom' = atom(p := True) :]"

definition
  "QQ5_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> (*not needed in the proof*)
      \<not> gg mrk atom left p \<and> \<not> gg mrk atom right p \<and>
      t \<noteq> nil \<and> \<not> atom t \<and>
      p' = t \<and> t' = left t \<and> mrk' = mrk \<and>
      left' = left(t := p) \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ6_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and> (*not needed in the proof*)
      \<not> gg mrk atom left p \<and> \<not> gg mrk atom right p \<and>
      t \<noteq> nil \<and> atom t \<and>
      p' = t \<and> t' = right t \<and> mrk' = mrk \<and>
      left' = left \<and> right' = right(t := p) \<and> atom' = atom(t := False) :]"

definition
  "QQ7_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
      p \<noteq> nil \<and>
      \<not> gg mrk atom left p \<and> \<not> gg mrk atom right p \<and>
      t = nil \<and>
      p' = nil \<and> t' = t \<and> mrk' = mrk \<and>
      left' = left \<and> right' = right \<and> atom' = atom :]"

definition
  "QQ8_a \<equiv> [: p, t, left, right, atom, mrk \<leadsto> p', t', left', right', atom', mrk' .
     p = nil \<and> p' = p \<and> t' = t \<and> mrk' = mrk \<and> left' = left \<and> right' = right \<and> atom' = atom:]"

section {* Data refinement relation *}

definition
  "RR_a \<equiv> {: p, t, left, right, atom, mrk \<leadsto> p', t', lnk, lbl, mrk' .
          lnk none = left \<and> lnk some = right \<and>
          lbl = (\<lambda> x . if atom x then some else none) \<and>
          p' = p \<and> t' = t \<and> mrk' = mrk :}"

definition [simp]:
  "R''_a i = RR_a"

definition
  "ClassicMark = (\<lambda> (i, j) . (case (i, j) of
      (I.init, I.loop)  \<Rightarrow> QQ1_a \<sqinter> QQ2_a |
      (I.loop, I.loop)  \<Rightarrow> (QQ3_a \<sqinter> QQ4_a) \<sqinter> ((QQ5_a \<sqinter> QQ6_a) \<sqinter> QQ7_a) |
      (I.loop, I.final) \<Rightarrow> QQ8_a |
       _ \<Rightarrow> \<top>))"

subsection {* Data refinement of the transitions *}

theorem init1_a [simp]:
  "DataRefinement ({.Init''.} o Q1''_a) RR_a RR_a QQ1_a"
  by (simp add: data_refinement_hoare hoare_demonic angelic_def QQ1_a_def Q1''_a_def RR_a_def
       Init''_def subset_eq)

theorem init2_a [simp]:
  "DataRefinement ({.Init''.} o Q2''_a) RR_a RR_a QQ2_a"
  by (simp add: data_refinement_hoare hoare_demonic angelic_def QQ2_a_def Q2''_a_def RR_a_def
       Init''_def subset_eq)

lemma index_simp:
  "(u = v) = (u none = v none \<and> u some = v some)"
  by (safe, rule ext, case_tac "x", auto)

theorem step1_a [simp]:
  "DataRefinement ({.Loop''.} o Q3''_a) RR_a RR_a QQ3_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def QQ3_a_def  Q3''_a_def RR_a_def
       Loop''_def subset_eq g_def gg_def simp_eq_emptyset)
  apply safe
  apply (rule_tac x="\<lambda> x . if x = some then ab some else (ab none)(a := aa)" in exI)
  apply simp
  apply (rule_tac x="none" in exI)
  apply (simp add: index_simp)
  done

theorem step2_a[simp]:
  "DataRefinement ({.Loop''.} o Q3''_a) RR_a RR_a QQ4_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def QQ4_a_def Q3''_a_def RR_a_def
       Loop''_def subset_eq g_def gg_def simp_eq_emptyset)
  apply safe
  apply (rule_tac x="\<lambda> x . if x = none then ab none else (ab some)(a := aa)" in exI)
  apply simp
  apply (rule_tac x="some" in exI)
  apply (simp add: index_simp)
  apply (rule ext)
  apply auto
  done

theorem step3_a [simp]:
  "DataRefinement ({.Loop''.} o Q4''_a) RR_a RR_a QQ5_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def QQ5_a_def Q4''_a_def RR_a_def
       Loop''_def subset_eq g_def gg_def simp_eq_emptyset)
  apply clarify
  apply (case_tac "i")
  apply auto
  done

lemma if_set_elim: "(x \<in> (if b then A else B)) = ((b \<and> x \<in> A) \<or> (\<not> b \<and> x \<in> B))"
  by auto

theorem step4_a [simp]:
  "DataRefinement ({.Loop''.} o  Q4''_a) RR_a RR_a QQ6_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def RR_a_def QQ6_a_def Q4''_a_def
       Loop''_def subset_eq simp_eq_emptyset g_def gg_def if_set_elim)
  apply (simp add: ext)
  apply safe
  apply (case_tac "i")
  apply simp_all
  apply (case_tac "i")
  apply simp_all
  apply (case_tac "i")
  apply simp_all
  apply (case_tac "i")
  by simp_all

theorem step5_a [simp]:
  "DataRefinement ({.Loop''.} o Q5''_a) RR_a RR_a QQ7_a"
  apply (simp add: data_refinement_hoare hoare_demonic angelic_def Q5''_a_def QQ7_a_def
       Loop''_def subset_eq RR_a_def simp_eq_emptyset)
  apply safe
  apply (simp_all add: g_def gg_def)
  apply (case_tac "i")
  by auto

theorem final_step_a [simp]:
  "DataRefinement ({.Loop''.} o Q6''_a) RR_a RR_a QQ8_a"
  by (simp add: data_refinement_hoare hoare_demonic angelic_def Q6''_a_def QQ8_a_def
       Loop''_def subset_eq RR_a_def simp_eq_emptyset)

subsection {* Diagram data refinement *}

lemma [simp]: "mono RR_a" by (simp add: RR_a_def)
lemma [simp]: "RR_a \<in> Apply.Disjunctive" by (simp add: RR_a_def)
lemma [simp]: "Disjunctive_fun R''_a" by (simp add: Disjunctive_fun_def)

lemma [simp]: "mono_fun R''_a" by simp

lemma [simp]: "mono Q1''_a" by (simp add: Q1''_a_def)
lemma [simp]: "mono Q2''_a" by (simp add: Q2''_a_def)
lemma [simp]: "mono Q3''_a" by (simp add: Q3''_a_def)
lemma [simp]: "mono Q4''_a" by (simp add: Q4''_a_def)
lemma [simp]: "mono Q5''_a" by (simp add: Q5''_a_def)
lemma [simp]: "mono Q6''_a" by (simp add: Q6''_a_def)

lemma [simp]: "dmono LinkMark"
  apply (unfold dmono_def LinkMark_def)
  by simp

theorem ClassicMark_DataRefinement_a [simp]:
 "DgrDataRefinement2 (R'_a .. (R_a .. SetMarkInv)) LinkMark R''_a ClassicMark"
  apply (rule_tac P = "LinkMarkInv" in DgrDataRefinement_mono)
  apply (simp add: le_fun_def SetMarkInv_def
    angelic_def R1'_a_def R2'_a_def Init''_def Loop''_def Final''_def)
  apply auto
  apply (simp add: DgrDataRefinement2_def dgr_demonic_def ClassicMark_def LinkMark_def
    demonic_sup_inf data_refinement_choice2 assert_comp_choice)
  apply (rule data_refinement_choice2)
  apply simp
  apply (rule data_refinement_choice1)
  apply simp_all
  apply (rule data_refinement_choice2)
  apply simp_all
  apply (rule data_refinement_choice1)
  by simp_all

subsection {* Diagram corectness *}

theorem ClassicMark_correct_a [simp]:
  "Hoare_dgr  (R''_a .. (R'_a .. (R_a .. SetMarkInv)))  ClassicMark
         ((R''_a .. (R'_a ..(R_a .. SetMarkInv))) \<sqinter> (- grd (step ClassicMark)))"
  apply (rule_tac D = "LinkMark" in Diagram_DataRefinement2)
  apply auto
  by (rule LinkMark_correct)

text {*
We have proved the correctness of the final algorithm, but the pre and the post conditions
involve the angelic choice operator and they depend on all data refinement steps we
have used to prove the final diagram. We simplify these conditions and we show that
we obtained indead the corectness of the marking algorithm.

The predicate $\mathit{ClassicInit}$ which is true for the $\mathit{init}$ situation states that initially
the variables $\mathit{left}$, $\mathit{right}$, and $\mathit{atom}$ are equal to their initial values and also
that no node is marked.

The predicate $\mathit{ClassicFinal}$ which is true for the $final$ situation states that at the end
the values of the variables $\mathit{left}$, $\mathit{right}$, and $\mathit{atom}$ are again equal to their initial values
and the variable $mrk$ records all reachable nodes. The reachable nodes are defined using our initial
$\mathit{next}$ relation, however if we unfold all locale interpretations and definitions we see easeily
that a node $x$ is reachable if there is a path from $root$ to $x$ along $\mathit{left}$ and $\mathit{right}$ functions,
and all nodes in this path have the atom bit false.
*}

definition
  "ClassicInit = {(p, t, left, right, atom, mrk) .
      atom = atom0 \<and> left = left0 \<and> right = right0 \<and>
      finite (- mrk) \<and> mrk = {}}"

definition
  "ClassicFinal = {(p, t, left, right, atom, mrk) .
       atom = atom0 \<and> left = left0 \<and> right = right0 \<and>
       mrk = reach root}"

theorem [simp]:
  "ClassicInit \<subseteq> (RR_a (R1'_a (R1_a (SetMarkInv init))))"
  apply (simp add: SetMarkInv_def)
  apply (simp add: ClassicInit_def angelic_def RR_a_def R1'_a_def R1_a_def Init_def Init''_def)
  apply safe
  apply (unfold simp_eq_emptyset)
  apply (simp add: link0_def label0_def)
  apply (simp add: fun_eq_iff)
  by (simp add: label0_def)

theorem [simp]:
  "(RR_a (R1'_a (R1_a (SetMarkInv final)))) \<le> ClassicFinal"
  apply (simp add: SetMarkInv_def)
  apply (simp add: ClassicFinal_def angelic_def RR_a_def R1'_a_def R1_a_def
    Final_def Final''_def Init''_def label0_def link0_def)
  apply (simp add: simp_eq_emptyset inf_fun_def)
  apply auto
  by (simp_all add: link0_def)

text{*
The indexed predicate $\mathit{ClassicPre}$ is the precondition of the diagram, and since we are only interested
in starting the marking diagram in the $init$ situation we set
$\mathit{ClassicPre} \ loop = \mathit{ClassicPre} \ \mathit{final} = \emptyset$.
*}

definition [simp]:
  "ClassicPre i =  (case i of
      I.init  \<Rightarrow> ClassicInit |
      I.loop  \<Rightarrow> {} |
      I.final \<Rightarrow> {})"

text{*
We are interested on the other hand that the marking diagram terminates only in the $\mathit{final}$ situation. In order to
achieve this we define the postcondition of the diagram as the indexed predicate $\mathit{ClassicPost}$ which is empty
on every situation except $final$.
*}

definition [simp]:
  "ClassicPost i =  (case i of
      I.init  \<Rightarrow> {} |
      I.loop  \<Rightarrow> {} |
      I.final \<Rightarrow> ClassicFinal)"

lemma exists_or:
  "(\<exists> x . p x \<or> q x) = ((\<exists> x . p x) \<or> (\<exists> x . q x))"
  by auto

lemma [simp]:
  "(- grd (step  ClassicMark)) init = {}"
  apply (simp add: grd_def step_def)
  apply safe
  apply simp
  apply (drule_tac x = loop in spec)
  by (simp add: ClassicMark_def QQ1_a_def QQ2_a_def demonic_def, auto)

lemma [simp]: "grd \<top> = \<bottom>"
  by (simp add: grd_def top_fun_def)

lemma [simp]:
  "(- grd (step  ClassicMark)) loop = {}"
  apply safe
  apply simp
  apply (frule_tac x = "final" in spec)
  apply (drule_tac x = "loop" in spec)
  apply (unfold ClassicMark_def QQ1_a_def QQ2_a_def QQ3_a_def QQ4_a_def QQ5_a_def QQ6_a_def QQ7_a_def QQ8_a_def)
  apply simp
  apply (case_tac "a \<noteq> nil")
  by auto

text {*
The final theorem states the correctness of the marking diagram with respect to the precondition
$\mathit{ClassicPre}$ and the postcondition $\mathit{ClassicPost}$, that is, if the diagram starts in the initial
situation, then it will terminate in the final situation, and it will mark all reachable nodes.
*}

lemma [simp]: "mono QQ1_a" by (simp add: QQ1_a_def)
lemma [simp]: "mono QQ2_a" by (simp add: QQ2_a_def)
lemma [simp]: "mono QQ3_a" by (simp add: QQ3_a_def)
lemma [simp]: "mono QQ4_a" by (simp add: QQ4_a_def)
lemma [simp]: "mono QQ5_a" by (simp add: QQ5_a_def)
lemma [simp]: "mono QQ6_a" by (simp add: QQ6_a_def)
lemma [simp]: "mono QQ7_a" by (simp add: QQ7_a_def)
lemma [simp]: "mono QQ8_a" by (simp add: QQ8_a_def)

lemma [simp]: "dmono ClassicMark"
  apply (unfold dmono_def ClassicMark_def)
  by simp

theorem "\<Turnstile> ClassicPre {| pt ClassicMark |} ClassicPost"
  apply (rule_tac P = "(R''_a .. (R'_a .. (R_a ..SetMarkInv)))" in hoare_pre)
  apply (subst le_fun_def)
  apply simp
  apply (rule_tac Q = "((R''_a .. (R'_a .. (R_a .. SetMarkInv))) \<sqinter> (- grd (step ((ClassicMark)))))" in hoare_mono)
  apply (simp_all add: hoare_dgr_correctness)
  apply (rule le_funI)
  apply (case_tac x)
  apply (simp_all add: inf_fun_def del: uminus_apply)
  apply (rule_tac y = "RR_a (R1'_a (R1_a (SetMarkInv final)))" in order_trans)
  by auto

end

end