(*<*)
(* Author: Kyndylan Nienhuis *)
(* Author: Thomas Bauereiss *)
theory Word_Extra
imports
  Main
  "HOL-Word.Word"
  "HOL-Lattice.Lattice"
  "HOL-Eisbach.Eisbach_Tools"
begin
(*>*)

subsection \<open>Lemmas about machine words\<close>

text \<open>We first prove lemmas about integers, then about definitions that create words (such as
@{const mask} and @{const max_word}), then about definitions that manipulate words of the same size
(such as \<open>NOT\<close>, \<open>AND\<close>, \ldots), then about definitions that manipulate words of different sizes
(such as @{const ucast}, @{const slice}) and finally we define a bit-wise order over words.\<close>

subsubsection \<open>Integers\<close>

text \<open>We start by proving lemmas about integers that can later be lifted to machine words.\<close>

paragraph \<open>Power of two difference\<close>

lemma mod_power_self:
  fixes x :: "'a::euclidean_semiring_cancel"
  shows "x ^ n mod x = (if n = 0 then 1 mod x else 0)"
by (induct n) simp_all

lemma bin_last_power_of_two_minus_one [simp]:
  shows "bin_last (2 ^ n - 1) = (0 < n)"
unfolding bin_last_def mod_diff_left_eq[where a="2 ^ n", THEN sym] mod_power_self
by simp

lemma bin_last_Suc_power_of_two_minus_one [simp]:
  shows "bin_last (2 * 2 ^ n - 1)"
using bin_last_power_of_two_minus_one[where n="Suc n"]
by simp

lemma bin_rest_power_of_two_minus_one [simp]:
  shows "bin_rest (2 ^ n - 1) = (case n of 0 \<Rightarrow> 0 | Suc m \<Rightarrow> 2 ^ m - 1)"
unfolding bin_rest_def
by (induct n) simp_all

lemma bin_rest_Suc_power_of_two_minus_one [simp]:
  shows "bin_rest (2 * 2 ^ n - 1) =  2 ^ n - 1"
using bin_rest_power_of_two_minus_one[where n="Suc n"]
by simp

lemma int_power_of_two_difference:
  assumes "n \<le> m"
  shows "(2 ^ m - 1) AND NOT (2 ^ n - 1) = (2::int) ^ m - 2 ^ n"
using assms
proof (induct m arbitrary: n)
  case 0
  thus ?case by simp
next
  case (Suc m)
  show ?case
    proof (cases "n = 0")
      case True
      thus ?thesis by simp
    next
      case False
      then obtain n' where [simp]: "n = Suc n'"
        by (metis Suc.prems le_SucE le_zero_eq zero_induct)
      have [simp]: "\<not> 2 * x = 1" for x :: int
        proof
          assume "2 * x = 1"
          from arg_cong[where f=even, OF this]
          show False by simp
        qed
      have "(2::int) ^ Suc m - 2 ^ n = 2 * (2 ^ m - 2 ^ n')"
        by simp
      also have "... = 2 * (2 ^ m - 1 AND NOT (2 ^ n' - 1))"
        using Suc by auto
      also have "... = 2 ^ Suc m - 1 AND NOT (2 ^ n - 1)"
        unfolding bitAND_int.simps[where x="2 ^ Suc m - 1"]
        by (simp add: Bit_B0_2t)
      finally show ?thesis by simp
    qed
qed

paragraph \<open>Nth bit of products, divisions and remainders\<close>

lemma bin_nth_prod:
  shows "bin_nth (2 ^ n * m) k = (bin_nth m (k - n) \<and> n \<le> k)"
proof (induct n arbitrary: k)
  case 0
  thus ?case
    by simp
next
  case (Suc n)
  have "bin_nth (2 ^ Suc n * m) k = bin_nth ((2 ^ n * m) BIT False) k"
    by (simp add: Bit_B0_2t mult.assoc)
  also have "... = (bin_nth (2 ^ n * m) (k - 1) \<and> 1 \<le> k)"
    by (induct k) simp_all
  also have "... = (bin_nth m (k - Suc n) \<and> Suc n \<le> k)"
    unfolding Suc[where k="k - 1"]
    by auto
  finally show ?case .
qed

lemma bin_nth_div:
  shows "bin_nth (m div 2 ^ n) k = bin_nth m (k + n)"
proof (induct n arbitrary: k)
  case 0
  thus ?case
    by simp
next
  case (Suc n)
  have "bin_nth (m div 2 ^ Suc n) k = bin_nth (m div 2 ^ n div 2) k"
    using zdiv_zmult2_eq
    by (auto simp: mult.commute)
  also have "... = bin_nth (m div 2 ^ n) (Suc k)"
    by (induct k) (simp_all add: bin_rest_def)
  also have "... = bin_nth m (k + Suc n)"
    using Suc[where k="Suc k"]
    by auto
  finally show ?case .
qed

lemma bin_nth_mod:
  shows "bin_nth (m mod 2 ^ n) k = (bin_nth m k \<and> k < n)"
proof (induct k arbitrary: m n)
  case 0
  thus ?case
    proof (cases "n = 0")
      case True
      thus ?thesis by simp
    next
      case False
      define n' where "n' \<equiv> n - 1"
      hence [simp]: "n = Suc n'"
        using False by auto
      have "(2::int) dvd (2 * 2 ^ n')" by arith
      note [simp] = mod_mod_cancel[OF this]
      show ?thesis
        by (auto simp: bin_last_def)
    qed
next
  case (Suc k)
  thus ?case
    proof (cases "n = 0")
      case True
      thus ?thesis by simp
    next
      case False
      define n' where "n' \<equiv> n - 1"
      hence [simp]: "n = Suc n'"
        using False by auto
      have [simp]: "bin_rest (m mod (2 * 2 ^ n')) = bin_rest m mod (2 ^ n')"
        unfolding bin_rest_def
        using zmod_zmult2_eq
        by simp
      show ?thesis
        using Suc by auto
    qed
qed

subsubsection \<open>Words to and from integers\<close>

lemma uint_less [simp]:
  fixes x :: "'a::len0 word"
  shows "uint x \<le> 2 ^ LENGTH('a)"
using uint_lt[where w=x, THEN order.strict_implies_order] .

text \<open>A useful technique to prove equality over words is to compare the words bit by bit.\<close>

lemma test_bit_nat:
  shows "(of_nat n::'a::len word) !! m = (m < LENGTH('a) \<and> bin_nth (int n) m)"
unfolding word_of_nat test_bit_wi ..

subsubsection \<open>Exhaustive enumeration of small words\<close>

lemma exhaustive_1_word:
  fixes x :: "1 word"
  obtains "x = 0"
        | "x = 1"
proof -
  obtain n where x: "x = of_nat n" and "n < 2"
    by (cases x) auto
  hence "n = 0 \<or> n = 1" by auto
  thus ?thesis using x that by auto
qed

lemma exhaustive_2_word:
  fixes x :: "2 word"
  obtains "x = 0"
        | "x = 1"
        | "x = 2"
        | "x = 3"
proof -
  obtain n where x: "x = of_nat n" and "n < 4"
    by (cases x) auto
  hence "n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3" by auto
  thus ?thesis using x that by auto
qed

lemma exhaustive_3_word:
  fixes x :: "3 word"
  obtains "x = 0"
        | "x = 1"
        | "x = 2"
        | "x = 3"
        | "x = 4"
        | "x = 5"
        | "x = 6"
        | "x = 7"
proof -
  obtain n where x: "x = of_nat n" and "n < 8"
    by (cases x) auto
  hence "n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3 \<or> n = 4 \<or> n = 5 \<or> n = 6 \<or> n = 7"
    by auto
  thus ?thesis using x that by auto
qed

lemma exhaustive_4_word:
  fixes x :: "4 word"
  obtains "x = 0" | "x = 1" | "x = 2" | "x = 3" | "x = 4" | "x = 5" | "x = 6" | "x = 7" | "x = 8"
    | "x = 9" | "x = 10" | "x = 11" | "x = 12" | "x = 13" | "x = 14" | "x = 15"
proof -
  have upt_16: "[0..<16] = [0, Suc 0, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15]"
    by (auto simp: upt_conv_Cons)
  obtain n where x: "x = of_nat n" and "n \<in> set [0..<16]"
    by (cases x) auto
  then have "n = 0 \<or> n = 1 \<or> n = 2 \<or> n = 3 \<or> n = 4 \<or> n = 5 \<or> n = 6 \<or> n = 7 \<or> n = 8 \<or> n = 9 \<or> n = 10 \<or>
             n = 11 \<or> n = 12 \<or> n = 13 \<or> n = 14 \<or> n = 15"
    unfolding upt_16 by auto
  thus ?thesis using x that by auto
qed

lemma word1_eq_1_neq_0:
  fixes w :: "1 word"
  shows "(w = 1) \<longleftrightarrow> \<not>(w = 0)"
  by (cases w rule: exhaustive_1_word) auto

lemma of_bl_eq_1_word[simp]:
  "of_bl [b] = (1 :: 1 word) \<longleftrightarrow> b"
  "of_bl [b] = (0 :: 1 word) \<longleftrightarrow> \<not>b"
  by (cases b) auto

subsubsection \<open>Masks\<close>

text \<open>We see @{const max_word} as a special case of @{const mask}.\<close>

lemma mask_max_word [simp]:
  assumes "LENGTH('a) \<le> n"
  shows "(mask n::'a::len word) = max_word"
using assms
by (intro word_eqI) (simp add: word_size)

lemma max_word_alt_def:
  shows "(max_word::'a::len word) = mask LENGTH('a)"
by (intro word_eqI) (simp add: word_size)

lemma mask_plus_one:
  shows "(mask n::'a::len word) + 1 = 2 ^ n"
unfolding mask_def
by (auto simp: wi_hom_syms)

lemma uint_mask:
  shows "uint (mask n::'a::len word) = 2 ^ (min n LENGTH('a)) - 1"
proof -
  have "uint (mask n::'a word) = uint (word_of_int (2 ^ n - 1)::'a word)"
    unfolding mask_def shiftl_1 word_size wi_hom_syms word_of_int_power_hom[THEN sym]
    by simp
  also have "... = 2 ^ (min n LENGTH('a)) - 1"
    proof (cases "n \<le> LENGTH('a)")
      case True
      hence [simp]: "min n LENGTH('a) = n"
        by auto
      have "(2::int) ^ n \<le> 2 ^ LENGTH('a)"
        using True by auto
      hence "(2::int) ^ n - 1 < 2 ^ LENGTH('a)"
        by arith
      hence [simp]: "((2::int) ^ n - 1) mod 2 ^ LENGTH('a) = 2 ^ n - 1"
        using int_mod_eq' by auto
      show ?thesis
        unfolding int_word_uint
        by simp
    next
      case False
      hence [simp]: "min n LENGTH('a) = LENGTH('a)"
        by auto
      define n' where "n' \<equiv> n - LENGTH('a)"
      hence "n = LENGTH('a) + n'"
        using False by auto
      hence [simp]: "(2::int) ^ n = 2 ^ LENGTH('a) * 2 ^ n'"
        using power_add by auto
      have "((2::int) ^ n - 1) mod 2 ^ LENGTH('a) = - 1 mod 2 ^ LENGTH('a)"
        using mod_diff_left_eq[where a="(2::int) ^ n", THEN sym]
        by auto
      also have "... = 2 ^ LENGTH('a) - 1"
        using zmod_minus1 by auto
      finally show ?thesis
        unfolding int_word_uint
        by simp
    qed
  finally show ?thesis .
qed

corollary uint_max_word:
  shows "uint (max_word::'a::len word) = 2 ^ LENGTH('a) - 1"
unfolding max_word_alt_def uint_mask
by simp
(* Direct proof:
unfolding max_word_def uint_word_of_int
using m1mod2k
by auto *)

lemma unat_mask:
  shows "unat (mask n::'a::len word) = 2 ^ (min n LENGTH('a)) - 1"
unfolding unat_def uint_mask
using nat_diff_distrib nat_power_eq
by simp

corollary unat_max_word:
  shows "unat (max_word::'a::len word) = 2 ^ LENGTH('a) - 1"
unfolding max_word_alt_def unat_mask
by simp

lemma min_uint_length:
  fixes x :: "'a::len word"
  shows "min (uint x) (2 ^ LENGTH('a) - 1) = uint x"
proof -
  have "uint x \<le> 2 ^ LENGTH('a) - 1" by simp
  from min_absorb1[OF this]
  show ?thesis .
qed

corollary min_length_uint:
  fixes x :: "'a::len word"
  shows "min (2 ^ LENGTH('a) - 1) (uint x) = uint x"
using min_uint_length[where x=x]
by simp

lemma min_unat_length:
  fixes x :: "'a::len word"
  shows "min (unat x) (2 ^ LENGTH('a) - 1) = unat x"
proof -
  have "unat x \<le> 2 ^ LENGTH('a) - 1"
    using word_le_nat_alt[THEN iffD1, OF max_word_max[where n=x]]
    unfolding unat_max_word
    by simp
  from min_absorb1[OF this]
  show ?thesis .
qed

corollary min_length_unat:
  fixes x :: "'a::len word"
  shows "min (2 ^ LENGTH('a) - 1) (unat x) = unat x"
using min_unat_length[where x=x]
by simp

subsubsection \<open>@{const max_word}\<close>

text \<open>These lemmas are not a corollary of a corresponding lemma about @{const mask}.\<close>

lemma max_word_le [simp]:
  shows "(max_word \<le> x) = (x = max_word)"
using antisym
by auto

lemma max_word_less [simp]:
  shows "(x < max_word) = (x \<noteq> max_word)"
    and "(max_word < x) = False"
unfolding not_le[THEN sym]
by simp_all

subsubsection \<open>Negation\<close>

lemma word_not_alt:
  fixes x :: "'a::len word"
  shows "NOT x = max_word - x"
unfolding word_not_def int_not_def
by (simp add: wi_hom_syms max_word_def word_of_int_2p_len)

lemma uminus_alt:
  fixes x :: "'a::len word"
  shows "- x = NOT x + 1"
unfolding word_not_alt max_word_minus
by simp

lemma uint_not:
  fixes x :: "'a::len word"
  shows "uint (NOT x) = uint (max_word::'a::len word) - uint x"
using uint_minus_simple_alt[THEN iffD1, OF max_word_max]
by (auto simp: word_not_alt)

corollary unat_not:
  fixes x :: "'a::len word"
  shows "unat (NOT x) = unat (max_word::'a::len word) - unat x"
unfolding unat_def uint_not
using nat_diff_distrib'
by auto

lemma uint_not_mask:
  shows "uint (NOT mask n::'a::len word) =
         (if LENGTH('a) \<le> n then 0 else 2 ^ LENGTH('a) - 2 ^ n)"
by (auto simp: uint_not uint_max_word uint_mask)

corollary unat_not_mask:
  shows "unat (NOT mask n::'a::len word) =
         (if LENGTH('a) \<le> n then 0 else 2 ^ LENGTH('a) - 2 ^ n)"
by (auto simp: unat_not unat_max_word unat_mask)

subsubsection \<open>Conjunction\<close>

lemma conj_outside_absorb [simp]:
  fixes x y :: "'a::len word"
  shows "x AND y AND x = x AND y"
by (simp add: word_bool_alg.conj.commute)

subsubsection \<open>XOR\<close>

lemma word_xor_mask [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) \<le> n"
  shows "x XOR mask n = NOT x"
using assms
by (intro word_eqI) (auto simp: word_size word_ops_nth_size)

subsubsection \<open>Lower and upper bits\<close>

(* Perhaps we should create a definition for the lower and upper bits. The only annoying thing
is that I'd like the parameter for the upper bits to specify how many lower bits are cleared,
while intuitively it specifies how many upper bits are retained.*)

lemma mask_and_mask [simp]:
  shows "mask n AND mask m = mask (min m n)"
by (intro word_eqI) (auto simp: word_size word_ops_nth_size)

lemma not_mask_and_not_mask [simp]:
  shows "NOT mask n AND NOT mask m = NOT mask (max m n)"
by (intro word_eqI) (auto simp: word_size word_ops_nth_size)

lemma mask_and_not_mask [simp]:
  assumes "n \<le> m"
  shows "mask n AND NOT mask m = 0"
using assms
by (intro word_eqI) (auto simp: word_size word_ops_nth_size)

corollary not_mask_and_mask [simp]:
  assumes "m \<le> n"
  shows "NOT mask n AND mask m = 0"
using assms
unfolding word_bool_alg.conj.commute[where a="NOT _"]
by simp

lemma word_and_mask_and_word_and_not_mask [simp]:
  shows "(x AND mask n) AND (y AND NOT mask n) = 0"
unfolding word_bool_alg.conj.commute[where b="NOT _"]
unfolding word_bool_alg.conj.assoc[where b="mask _"]
   word_bool_alg.conj.assoc[where b="NOT mask _", THEN sym]
by simp

corollary word_and_not_mask_and_word_and_mask [simp]:
  shows "(x AND NOT mask n) AND (y AND mask n) = 0"
unfolding word_bool_alg.conj.commute[where a="_ AND NOT mask _"]
by simp

lemma word_and_not_mask_or_word_and_mask [simp]:
  shows "(x AND NOT mask n) OR (x AND mask n) = x"
by (intro word_eqI)
   (auto simp: word_size word_ops_nth_size)

corollary word_and_mask_or_word_and_not_mask [simp]:
  shows "(x AND mask n) OR (x AND NOT mask n) = x"
using trans[OF word_bool_alg.disj.commute
               word_and_not_mask_or_word_and_mask] .

lemma word_and_not_mask_plus_word_and_mask [simp]:
  shows "(x AND NOT mask n) + (x AND mask n) = x"
using word_plus_and_or[where x="x AND NOT mask n" and y="x AND mask n"]
by simp

corollary word_and_mask_plus_word_and_not_mask [simp]:
  shows "(x AND mask n) + (x AND NOT mask n) = x"
using trans[OF ab_semigroup_add_class.add.commute
               word_and_not_mask_plus_word_and_mask] .

corollary word_minus_word_and_mask [simp]:
  shows "x - (x AND mask n) = (x AND NOT mask n)"
by (simp add: diff_eq_eq)

corollary word_minus_word_and_not_mask [simp]:
  shows "x - (x AND NOT mask n) = (x AND mask n)"
by (simp add: diff_eq_eq)

corollary word_and_mask_minus_word [simp]:
  shows "(x AND mask n) - x = - (x AND NOT mask n)"
by (simp add: diff_eq_eq)

corollary word_and_not_mask_minus_word [simp]:
  shows "(x AND NOT mask n) - x = - (x AND mask n)"
by (simp add: diff_eq_eq)

lemma uint_word_and_not_mask_plus_uint_word_and_mask [simp]:
  shows "uint (x AND NOT mask n) + uint (x AND mask n) = uint x"
proof -
  have "x AND NOT mask n \<le> (x AND NOT mask n) + (x AND mask n)"
    using word_and_le2
    by auto
  from uint_plus_simple[OF this]
  show ?thesis by simp
qed

corollary uint_word_and_mask_plus_uint_word_and_not_mask [simp]:
  shows "uint (x AND mask n) + uint (x AND NOT mask n) = uint x"
using trans[OF ab_semigroup_add_class.add.commute
               uint_word_and_not_mask_plus_uint_word_and_mask] .

corollary unat_word_and_not_mask_plus_unat_word_and_mask [simp]:
  shows "unat (x AND NOT mask n) + unat (x AND mask n) = unat x"
unfolding unat_def
by (simp add: nat_add_distrib[THEN sym])

corollary unat_word_and_mask_plus_unat_word_and_not_mask [simp]:
  shows "unat (x AND mask n) + unat (x AND NOT mask n) = unat x"
unfolding unat_def
by (simp add: nat_add_distrib[THEN sym])

lemma word_and_mask [simp]:
  fixes x :: "('a :: len) word"
  assumes "len_of TYPE('a) \<le> m"
  shows "(x AND mask m) = x"
proof (intro word_eqI impI, simp only: word_size)
  fix i
  assume len_of_'a: "i < len_of TYPE('a)"
  hence "i < m" using assms by simp
  thus "(x AND mask m) !! i = x !! i"
    using len_of_'a
    by (simp add: nth_ucast word_ao_nth word_size)
qed

lemma uint_and_mask:
  fixes x :: "'a::len word"
  shows "uint (x AND mask n) = uint x mod 2 ^ (min n LENGTH('a))"
unfolding uint_and uint_mask AND_mod
by simp

lemma unat_and_mask:
  fixes x :: "'a::len word"
  shows "unat (x AND mask n) = unat x mod 2 ^ (min n LENGTH('a))"
unfolding unat_def uint_and_mask
using nat_mod_distrib nat_power_eq
by simp

lemma word_and_not_mask [simp]:
  fixes x :: "('a :: len) word"
  assumes "len_of TYPE('a) \<le> m"
  shows "(x AND NOT mask m) = 0"
using assms
by (intro word_eqI)
   (auto simp: word_size word_ops_nth_size)

lemma uint_and_not_mask:
  fixes x :: "'a::len word"
  shows "uint (x AND NOT mask n) =
         (if LENGTH('a) \<le> n then 0 else 2 ^ n * (uint x div 2 ^ n))"
proof -
  have "uint (x AND NOT mask n) + uint (x AND mask n) = uint x"
    by simp
  hence "uint (x AND NOT mask n) = uint x - uint (x AND mask n)"
    by arith
  also have "... = uint x - uint x mod 2 ^ min n LENGTH('a)"
    by (simp add: uint_and_mask)
  also have "... = uint x mod 2 ^ min n LENGTH('a) +
                   2 ^ min n LENGTH('a) * (uint x div 2 ^ min n LENGTH('a)) -
                   uint x mod 2 ^ min n LENGTH('a)"
    using mod_mult_div_eq[where a="uint x" and b="2 ^ min n LENGTH('a)"]
    by auto
  also have "... = 2 ^ min n LENGTH('a) * (uint x div 2 ^ min n LENGTH('a))"
    by arith
  also have "... = (if LENGTH('a) \<le> n then 0 else 2 ^ n * (uint x div 2 ^ n))"
    proof (cases "LENGTH('a) \<le> n")
      case True
      hence [simp]: "min n LENGTH('a) = LENGTH('a)"
        by simp
      have "uint x div 2 ^ LENGTH('a) = 0"
        using div_pos_pos_trivial[OF _ uint_lt[where w=x]]
        by auto
      thus ?thesis
        using True by simp
    qed auto
  finally show ?thesis .
qed

corollary unat_and_not_mask:
  fixes x :: "'a::len word"
  shows "unat (x AND NOT mask n) =
         (if LENGTH('a) \<le> n then 0 else 2 ^ n * (unat x div 2 ^ n))"
unfolding unat_def uint_and_not_mask
by (simp add: nat_div_distrib nat_mult_distrib nat_power_eq)

lemma uint_and_mask_plus_uint_and_mask_less:
  fixes x y :: "'a::len word"
  assumes "n < LENGTH('a)"
  shows "uint (x AND mask n) + uint (y AND mask n) < 2 ^ (n + 1)"
proof -
  have [simp]: "min n LENGTH('a) = n"
    using assms by auto
  have "0 < (2::'a word) ^ n"
    by (simp add: assms word_2p_lem word_size)
  from uint_2p[OF this]
  have [simp]: "uint ((2::'a word) ^ n) = 2 ^ n" .
  show ?thesis
    using and_mask_less'[OF assms, where w=x]
    using and_mask_less'[OF assms, where w=y]
    unfolding word_less_def
    by simp
qed

corollary uint_and_mask_plus_uint_and_mask_less_size:
  fixes x y :: "'a::len word"
  assumes "n < LENGTH('a)"
  shows "uint (x AND mask n) + uint (y AND mask n) < 2 ^ LENGTH('a)"
proof -
  have "n + 1 \<le> LENGTH('a)"
    using assms by auto
  hence "(2::int) ^ (n + 1) \<le> 2 ^ LENGTH('a)"
    using one_le_numeral power_increasing by blast
  thus ?thesis
    using uint_and_mask_plus_uint_and_mask_less[where x=x and y=y, OF assms]
    by simp
qed

corollary plus_word_and_mask_no_wrap:
  fixes x y :: "'a::len word"
  assumes "n < LENGTH('a)"
  shows "(x AND mask n) \<le> (x AND mask n) + (y AND mask n)"
unfolding no_olen_add
using uint_and_mask_plus_uint_and_mask_less_size[OF assms]
by simp

corollary uint_plus_word_and_mask [simp]:
  fixes x y :: "'a::len word"
  assumes "n < LENGTH('a)"
  shows "uint ((x AND mask n) + (y AND mask n)) =
         uint (x AND mask n) + uint (y AND mask n)"
using uint_and_mask_plus_uint_and_mask_less_size[OF assms]
unfolding uint_add_lem .

lemma uint_word_and_mask_plus_word_and_not_mask:
  shows "uint ((x AND mask n) + (y AND NOT mask n)) =
         uint (x AND mask n) + uint (y AND NOT mask n)"
proof (cases "n \<le> LENGTH('a)")
  case True
  hence [simp]: "min n LENGTH('a) = n"
    by simp
  note [simp] = dvd_imp_mod_0[OF le_imp_power_dvd[where a="2::int", OF True]]
  have [simp]: "((2::int) ^ LENGTH('a) - 1) div 2 ^ n = 2 ^ LENGTH('a) div 2 ^ n - 1"
    using div_add1_eq[where a="2 ^ LENGTH('a)" and b="-1::int" and c="2 ^ n"]
    using zdiv_mult_self[where a="-1" and n=1 and m="2 ^ n"]
    using True
    by (auto simp: m1mod2k div_eq_minus1)
  have x: "uint (x AND mask n) < 2 ^ n"
    unfolding uint_and_mask
    by simp
  have "uint y \<le> 2 ^ LENGTH('a) - 1"
    by auto
  from zdiv_mono1[where b="2 ^ n", OF this]
  have "uint (y AND NOT mask n) \<le> 2 ^ n * (2 ^ LENGTH('a) div 2 ^ n - 1)"
    unfolding uint_and_not_mask
    using True
    by auto
  also have "... = 2 ^ LENGTH('a) - 2 ^ n"
    unfolding right_diff_distrib zmde
    by simp
  finally have "uint (x AND mask n) + uint (y AND NOT mask n) < 2 ^ LENGTH('a)"
    using x by auto
  from uint_add_lem[THEN iffD1, OF this]
  show ?thesis .
qed simp

corollary uint_word_and_not_mask_plus_word_and_mask:
  shows "uint ((x AND NOT mask n) + (y AND mask n)) =
         uint (x AND NOT mask n) + uint (y AND mask n)"
by (simp add: uint_word_and_mask_plus_word_and_not_mask add.commute)

corollary unat_word_and_mask_plus_word_and_not_mask:
  shows "unat ((x AND mask n) + (y AND NOT mask n)) =
         unat (x AND mask n) + unat (y AND NOT mask n)"
unfolding unat_def uint_word_and_mask_plus_word_and_not_mask
using nat_add_distrib
by auto

corollary unat_word_and_not_mask_plus_word_and_mask:
  shows "unat ((x AND NOT mask n) + (y AND mask n)) =
         unat (x AND NOT mask n) + unat (y AND mask n)"
by (simp add: unat_word_and_mask_plus_word_and_not_mask add.commute)

lemma not_mask_eq_plus:
  shows "x + (y AND NOT mask n) AND NOT mask n = (x AND NOT mask n) + (y AND NOT mask n)"
proof -
  have "x + (y AND NOT mask n) AND NOT mask n = x + y - (y AND mask n) AND NOT mask n"
    by (simp add: add_diff_eq[THEN sym])
  also have "... = x + y - (y AND mask n) - ((x + y - (y AND mask n)) AND mask n)"
    by simp
  also have "... = x + y - (y AND mask n) - (x AND mask n)"
    unfolding mask_eqs
    by simp
  also have "... = x - (x AND mask n) + y - (y AND mask n)"
    by simp
  also have "... = (x AND NOT mask n) + (y AND NOT mask n)"
    by simp
  finally show ?thesis .
qed

corollary not_mask_eq_plus_commuted:
  shows "(x AND NOT mask n) + y AND NOT mask n = (x AND NOT mask n) + (y AND NOT mask n)"
using not_mask_eq_plus[where x=y and y=x]
by (simp add: add.commute)

lemma not_mask_eq_minus:
  shows "x - (y AND NOT mask n) AND NOT mask n = (x AND NOT mask n) - (y AND NOT mask n)"
proof -
  have "x - (y AND NOT mask n) AND NOT mask n = x - y + (y AND mask n) AND NOT mask n"
    by (simp add: diff_diff_eq2[THEN sym] diff_add_eq)
  also have "... = x - y + (y AND mask n) - (x - y + (y AND mask n) AND mask n)"
    by simp
  also have "... = x - y + (y AND mask n) - (x AND mask n)"
    unfolding mask_eqs
    by simp
  also have "... = (x AND NOT mask n) - (y AND NOT mask n)"
    by (simp add: diff_diff_eq2[THEN sym] diff_add_eq)
  finally show ?thesis .
qed

lemma word_plus_and_mask:
  fixes x y :: "'a::len word"
  assumes "(x AND mask n) + (y AND mask n) \<le> mask n"
  shows "x + y AND mask n = (x AND mask n) + (y AND mask n)"
proof (cases "n < LENGTH('a)")
  case True
  have [simp]: "min n LENGTH('a) = n"
    using True by auto
  have [simp]: "i mod 2 ^ LENGTH('a) mod 2 ^ n = i mod 2 ^ n" for i :: int
    using True bintrunc_bintrunc_min bintrunc_mod2p
    by auto
  have *: "uint (x AND mask n) + uint (y AND mask n) < 2 ^ n"
    using assms True
    unfolding word_le_def
    by (simp add: uint_mask)
  have x_and_mask: "uint (x AND mask n) < 2 ^ n"
    by (rule le_less_trans[OF _ *]) auto
  have y_and_mask: "uint (y AND mask n) < 2 ^ n"
    by (rule le_less_trans[OF _ *]) auto
  have "x + y AND mask n = ((x AND mask n) + (y AND mask n)) AND mask n"
    unfolding mask_eqs ..
  also have "... = (x AND mask n) + (y AND mask n)"
    unfolding word_uint_eq_iff
    using mod_add_if_z[OF x_and_mask y_and_mask] * True
    by (simp add: uint_and_mask)
  finally show ?thesis .
qed simp

corollary word_plus_and_not_mask:
  fixes x y :: "'a::len word"
  assumes "(x AND mask n) + (y AND mask n) \<le> mask n"
  shows "x + y AND NOT mask n = (x AND NOT mask n) + (y AND NOT mask n)"
proof -
  have "x + y AND NOT mask n = (x + y) - (x + y AND mask n)"
    by simp
  also have "... = (x + y) - ((x AND mask n) + (y AND mask n))"
    unfolding word_plus_and_mask[OF assms] ..
  also have "... = (x -  (x AND mask n)) + (y - (y AND mask n))"
    using add_diff_eq diff_add_eq diff_diff_add
    by (metis (no_types, hide_lams))
  also have "... = (x AND NOT mask n) + (y AND NOT mask n)"
    by simp
  finally show ?thesis .
qed

lemma mask_minus_word_and_mask [simp]:
  fixes x :: "'a::len word"
  shows "mask n - (x AND mask n) = NOT x AND mask n"
proof -
  have "mask n - (x AND mask n) = (mask n - (x AND mask n)) AND mask n"
    proof (cases "n < LENGTH('a)")
      case True
      have "mask n - (x AND mask n) < 2 ^ n"
        using word_sub_le[OF word_and_le1[where y=x and a="mask n"]]
        using and_mask_less'[where w=max_word, OF True]
        by simp
      from less_mask_eq[OF this]
      show ?thesis by simp
    qed simp
  also have "... = NOT x AND mask n"
    unfolding word_not_alt
    using mask_eqs(8)[where a="max_word" and b=x and n=n]
    by simp
  finally show ?thesis .
qed

lemma word_power_of_two_difference:
  assumes "n \<le> m"
      and "n \<le> LENGTH('a)"
  shows "(2::'a::len word) ^ m - 2 ^ n = mask m AND NOT mask n"
proof (cases "m \<le> LENGTH('a)")
  case True
  have "(2::'a::len word) ^ m - 2 ^ n = word_of_int (2 ^ m - 2 ^ n)"
    unfolding word_sub_wi word_of_int_2p[THEN sym] int_word_uint
    using mod_power_lem assms True
    by (auto simp: word_of_int_minus)
  also have "... = word_of_int ((2 ^ m - 1) AND NOT (2 ^ n - 1))"
    using assms int_power_of_two_difference
    by simp
  also have "... = word_of_int (2 ^ m - 1) AND NOT word_of_int (2 ^ n - 1)"
    unfolding word_and_def word_not_def wils1
    by simp
  also have "... = mask m AND NOT mask n"
    unfolding mask_def shiftl_1 word_sub_wi word_of_int_2p[THEN sym] int_word_uint
    using mod_power_lem assms True
    by (auto simp: word_of_int_minus)
  finally show ?thesis by simp
next
  case False
  then obtain m' where m_def: "m = LENGTH('a) + m'"
    unfolding not_le using less_imp_add_positive by auto
  have [simp]: "(2::'a::len word) ^ m = 0"
    unfolding word_of_int_2p[THEN sym] m_def power_add word_of_int_2p_len
    by simp
  have "NOT (mask n::'a word) = - (2 ^ n)"
    unfolding mask_def shiftl_1 word_sub_wi bwsimps int_not_def
    by (auto simp: wi_hom_syms)
  thus ?thesis
    unfolding mask_def shiftl_1
    by simp
qed

lemma word_and_mask_xor_mask [simp]:
  shows "x AND mask n XOR mask n = (NOT x) AND mask n"
by (intro word_eqI) (auto simp: word_size word_ops_nth_size)

lemma word_and_mask_and_mask [simp]:
  shows "(x AND mask n) AND mask m = x AND mask (min n m)"
by (intro word_eqI) (auto simp: word_size word_ops_nth_size)

lemma and_shiftl_not_mask [simp]:
  assumes "m \<le> n"
  shows "(x << n) AND NOT mask m = x << n"
using assms
by (intro word_eqI)
   (auto simp: word_size word_ops_nth_size nth_shiftl)

lemma word_and_mask_shiftl_eq_shiftl[simp]:
  assumes "i + j \<ge> LENGTH('a)"
  shows "x AND (mask i :: 'a::len word) << j = x << j"
  using assms by (intro word_eqI) (auto simp: nth_shiftl word_ao_nth word_size)

lemma word_and_mask_0_iff_not_testbits: "(w AND mask n) = 0 \<longleftrightarrow> (\<forall>i < n. \<not>w !! i)"
  using test_bit_size[of w] by (auto simp: word_ao_nth word_eq_iff word_size)

subsubsection \<open>@{const slice}\<close>

text \<open>We see @{const ucast} as a special case of @{const slice}.\<close>

lemma slice_zero [simp]:
  shows "slice 0 x = ucast x"
by (intro word_eqI) (simp add: nth_slice nth_ucast word_size)

lemma slice_beyond_length [simp]:
  fixes x :: "'a::len0 word"
  assumes len: "LENGTH('a) \<le> n"
  shows "slice n x = 0"
proof (intro word_eqI impI notI, clarsimp simp: word_size)
  fix m
  assume "m < LENGTH('b)" "slice n x !! m"
  hence "x !! (m + n)"
    by (simp add: nth_slice)
  from test_bit_size[OF this]
  have "m + n < LENGTH('a)"
    by (simp add: word_size)
  thus False
    using len by auto
qed

lemma slice_not:
  fixes x :: "'a::len word"
  shows "(slice n (NOT x)::'b::len word) = NOT (slice n x) AND mask (LENGTH('a) - n)"
proof (intro word_eqI iffI impI, unfold word_size)
  fix i
  assume length: "i < LENGTH('b)"
  assume "(slice n (NOT x)::'b word) !! i"
  hence "(NOT x) !! (i + n)"
    by (simp add: nth_slice)
  with test_bit_size[OF this]
  show "(NOT (slice n x::'b word) AND mask (LENGTH('a) - n)) !! i"
    using length
    by (auto simp: word_size nth_slice word_ops_nth_size)
next
  fix i
  assume "i < LENGTH('b)"
     and "(NOT (slice n x::'b word) AND mask (LENGTH('a) - n)) !! i"
  thus "(slice n (NOT x)::'b word) !! i"
    by (auto simp: word_size nth_slice word_ops_nth_size)
qed

corollary ucast_not:
  fixes x :: "'a::len word"
  shows "(ucast (NOT x)::'b::len word) = NOT (ucast x) AND mask LENGTH('a)"
using slice_not[where n=0]
by simp

lemma slice_or:
  shows "slice n (x OR y) = slice n x OR slice n y"
by (intro word_eqI)
   (auto simp: word_size word_ao_nth nth_slice)

lemma ucast_or:
  shows "ucast (x OR y) = ucast x OR ucast y"
using slice_or[where n=0]
by simp
(* Direct proof:
unfolding ucast_def uint_or bitOR_word.abs_eq[THEN sym] .. *)

lemma slice_and:
  shows "slice n (x AND y) = slice n x AND slice n y"
by (intro word_eqI)
   (auto simp: word_size word_ao_nth nth_slice)

lemma ucast_and:
  shows "ucast (x AND y) = ucast x AND ucast y"
using slice_and[where n=0]
by simp
(* Direct proof:
unfolding ucast_def uint_and bitAND_word.abs_eq[THEN sym] .. *)

lemma slice_xor:
  fixes x y :: "'a::len0 word"
  shows "(slice n (x XOR y)::'b::len0 word) = slice n x XOR slice n y"
proof (intro word_eqI iffI impI, unfold word_size)
  fix m
  assume "m < LENGTH('b)"
     and "slice n (x XOR y) !! m"
  hence "(x XOR y) !! (m + n)"
    by (simp add: nth_slice)
  with test_bit_size[OF this]
  have "x !! (m + n) \<noteq> y !! (m + n)"
    by (simp add: word_ops_nth_size word_size)
  thus "((slice n x XOR slice n y)::'b::len0 word) !! m"
    using `m < LENGTH('b)`
    by (simp add: nth_slice word_ops_nth_size word_size)
next
  fix m
  assume "m < LENGTH('b)"
     and "((slice n x XOR slice n y)::'b::len0 word) !! m"
  hence *: "x !! (m + n) \<noteq> y !! (m + n)"
    by (simp add: nth_slice word_ops_nth_size word_size)
  hence "m + n < LENGTH('a)"
    by (cases "x !! n")
       (auto dest: test_bit_size simp: word_size)
  thus "(slice n (x XOR y)::'b::len0 word) !! m"
    using * `m < LENGTH('b)`
    by (simp add: nth_slice word_ops_nth_size word_size)
qed

lemma ucast_xor:
  fixes x y :: "'a::len word"
  shows "(ucast (x XOR y)::'b::len word) = ucast x XOR ucast y"
using slice_xor[where n=0]
by simp

(* lemma slice_word_of_int:
  assumes "n + LENGTH('a) \<le> LENGTH('b)"
  shows "(slice n (word_of_int m::'b::len word)::'a::len word) =
         word_of_int (m div 2 ^ n)"
using assms
by (intro word_eqI)
   (auto simp: word_size nth_slice word_of_int zdiv_int bin_nth_div) *)

lemma slice_word_of_int:
  shows "slice n (word_of_int m::'a::len word) =
         word_of_int (m div 2 ^ n) AND mask (LENGTH('a) - n)"
by (intro word_eqI)
   (auto simp: word_size nth_slice word_ao_nth word_of_int zdiv_int bin_nth_div)

corollary ucast_word_of_int:
  shows "ucast (word_of_int m::'a::len word) =
         word_of_int m AND mask LENGTH('a)"
using slice_word_of_int[where n=0]
by simp

corollary slice_of_nat:
  shows "slice n (of_nat m::'a::len word) =
         of_nat (m div 2 ^ n) AND mask (LENGTH('a) - n)"
using slice_word_of_int[where m="int m" and n=n]
using zdiv_int[where a=m and b="2 ^ n", THEN sym]
by (simp add: word_of_int[THEN sym])

corollary ucast_of_nat:
  shows "(ucast (of_nat m::'b::len word)::'a::len word) =
         of_nat m AND mask LENGTH('b)"
using slice_of_nat[where n=0]
by simp

(* corollary
  fixes x :: "'a::len word"
  shows "slice n x = x div (2 ^ n)"
proof -
  have "slice n x = word_of_int (uint x div 2 ^ n) AND mask (LENGTH('a) - n)"
    using slice_word_of_int[where m="uint x" and n=n and 'a='a]
    by simp

  have "... = x div (2 ^ n)"
    unfolding word_div_def
    apply auto
oops *)

lemma slice_mask [simp]:
  shows "slice n (mask m::'a::len word) = mask (min m LENGTH('a) - n)"
by (intro word_eqI) (auto simp add: nth_slice word_size)

corollary ucast_mask [simp]:
  shows "ucast ((mask n)::'a::len word) = mask (min n LENGTH('a))"
unfolding slice_zero[THEN sym]
by (simp del: slice_zero)

lemma slice_of_slice [simp]:
  shows "slice n (slice m x::'a::len0 word) =
         slice (n + m) x AND mask (LENGTH('a) - n)"
by (intro word_eqI)
   (auto simp add: word_size nth_slice word_ao_nth add.assoc)

corollary slice_ucast [simp]:
  shows "slice n (ucast x::'a::len0 word) =
         (slice n x) AND mask (LENGTH('a) - n)"
unfolding slice_zero[THEN sym]
by (simp del: slice_zero)

corollary ucast_slice [simp]:
  shows "ucast (slice n x::'a::len0 word) =
         (slice n x) AND mask LENGTH('a)"
unfolding slice_zero[THEN sym]
by (simp del: slice_zero)

corollary ucast_ucast [simp]:
  shows "ucast (ucast x::'b::len0 word) =
         ucast x AND mask LENGTH('b)"
unfolding slice_zero[THEN sym]
by (simp del: slice_zero)

lemma slice_word_and_mask [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('b) + n \<le> m"
  shows "(slice n (x AND mask m)::'b::len0 word) = slice n x"
proof (intro word_eqI impI, simp only: word_size)
  fix i
  assume len: "i < LENGTH('b)"
  hence "i + n < m" using assms by simp
  thus "(slice n (x AND mask m)::'b word) !! i = (slice n x::'b word) !! i"
    using len Word.test_bit_size[where w=x and n="i + n"]
    by (auto simp add: nth_slice word_ao_nth word_size)
qed

corollary ucast_word_and_mask [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('b) \<le> m"
  shows "(ucast (x AND mask m)::'b::len0 word) = ucast x"
using assms
unfolding slice_zero[THEN sym]
by (simp del: slice_zero)

subsubsection \<open>@{const ucast}\<close>

text \<open>These lemmas are not a corollary of a corresponding lemma about @{const slice}.\<close>

thm ucast_id
declare ucast_id [simp]

lemma zero_less_ucast [simp]:
  fixes x :: "'a::len0 word"
  assumes "LENGTH('a) \<le> LENGTH('b)"
  shows "(0 < (ucast x::'b::len0 word)) = (0 < x)"
unfolding ucast_def word_less_def word_ubin.eq_norm bintr_uint[OF assms]
by auto

lemma one_less_ucast [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) \<le> LENGTH('b)"
  shows "(1 < (ucast x::'b::len word)) = (1 < x)"
unfolding ucast_def word_less_def word_ubin.eq_norm bintr_uint[OF assms]
by auto

lemma one_le_ucast [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) \<le> LENGTH('b)"
  shows "(1 \<le> (ucast x::'b::len word)) = (1 \<le> x)"
unfolding ucast_def word_le_def word_ubin.eq_norm bintr_uint[OF assms]
by auto

lemma ucast_up_eq [simp]:
  fixes x y :: "'a::len0 word"
  assumes "LENGTH('a) \<le> LENGTH('b)"
  shows "((ucast x::'b::len0 word) = (ucast y)) = (x = y)"
proof
  assume ucast: "(ucast x::'b word) = ucast y"
  show "x = y"
    proof (intro word_eqI impI, unfold word_size)
      fix n
      assume "n < LENGTH('a)"
      thus "x !! n = y !! n"
        using test_bit_cong[where x=n, OF ucast] assms
        by (auto simp: nth_ucast)
    qed
qed simp

lemma uint_ucast [simp]:
  fixes x :: "'a::len word"
  shows "uint (ucast x::'b::len0 word) =
         uint (x AND mask LENGTH('b))"
proof (intro bin_nth_eq_iff[THEN iffD1] ext)
  fix i
  show "bin_nth (uint (ucast x::'b word)) i =
        bin_nth (uint (x AND mask LENGTH('b))) i"
    using test_bit_size[where w=x and n=i]
    by (auto simp add: test_bit_def'[THEN sym]
                       nth_ucast
                       word_ao_nth
                       word_size)
qed

corollary unat_ucast [simp]:
  fixes x :: "'a::len word"
  shows "unat ((ucast x :: ('b :: len0) word)) =
         unat (x AND mask (len_of TYPE('b)))"
unfolding unat_def
by simp

lemma ucast_max_word [simp]:
  shows "ucast (max_word::'a::len word) = mask LENGTH('a)"
by (intro word_eqI) (simp add: word_size nth_ucast)

lemma and_ucast_mask [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) \<le> n"
  shows "(ucast x::'b::len word) AND mask n = ucast x"
proof (intro word_eqI impI iffI, unfold word_size)
  fix m
  assume "m < LENGTH('b)" "(ucast x::'b word) !! m"
  hence "x !! m"
    by (simp add: nth_ucast)
  from test_bit_size[OF this]
  have "m < n"
    using assms
    unfolding word_size
    by simp
  thus "((ucast x::'b word) AND mask n) !! m"
    using `m < LENGTH('b)` `x !! m`
    by (simp add: word_size nth_ucast word_ao_nth)
qed (simp add: nth_ucast word_ao_nth)

(* lemma ucast_max_word [simp]:
  assumes "LENGTH('b) \<le> LENGTH('a)"
  shows "(ucast (max_word::'a::len word)::'b::len word) = max_word"
using assms
by (intro word_eqI) (simp add: word_size nth_ucast) *)

declare word_cat_id [simp]

lemma ucast_word_cat [simp]:
  assumes "LENGTH('a) \<le> LENGTH('b)"
  shows "(ucast (word_cat w w'::'b::len0 word)::'a::len0 word) = word_cat w w'"
unfolding ucast_def word_cat_def
unfolding word_ubin.eq_norm
using assms
by (simp add: wi_bintr)

lemma ucast_shiftr:
  shows "(ucast (x >> n) :: ('b :: len0) word) = slice n x"
by (intro word_eqI)
   (simp add: word_size nth_slice nth_ucast nth_shiftr)

lemma ucast_shiftl:
  fixes x :: "'a::len word"
  shows "ucast (x << n) = ucast (x AND mask (LENGTH('a) - n)) << n"
by (intro word_eqI) (auto simp: nth_ucast nth_shiftl word_ao_nth word_size)

lemma ucast_plus_down:
  fixes x y :: "'a ::len0 word"
  assumes "LENGTH('b) \<le> LENGTH('a)"
  shows "(ucast (x + y)::'b::len0 word) = ucast x + ucast y"
proof -
  have "(2::int) ^ LENGTH('b) dvd 2 ^ LENGTH('a)"
    using le_imp_power_dvd[OF assms, where a="2::int"]
    by simp
  from mod_mod_cancel[OF this]
  show ?thesis
    using assms mod_mod_cancel
    unfolding ucast_def uint_word_ariths
    unfolding word_uint.norm_eq_iff[THEN sym] wi_hom_syms[THEN sym]
    by simp
qed

lemma ucast_plus_up:
  fixes x y :: "'a ::len0 word"
  assumes "LENGTH('a) < LENGTH('b)"
  shows "(ucast (x + y)::'b::len word) = (ucast x + ucast y) AND mask (LENGTH('a))"
proof -
  have "LENGTH('a) \<le> LENGTH('b)"
    using assms by simp
  from le_imp_power_dvd[OF this, where a="2::int"]
  have "(2::int) ^ LENGTH('a) dvd 2 ^ LENGTH('b)"
    by simp
  from mod_mod_cancel[OF this]
  show ?thesis
    unfolding ucast_def uint_word_ariths and_mask_mod_2p wi_hom_syms[THEN sym] uint_word_of_int
    unfolding word_uint.norm_eq_iff[THEN sym]
    by auto
qed

lemma ucast_minus_down:
  fixes x y :: "'a ::len0 word"
  assumes "LENGTH('b) \<le> LENGTH('a)"
  shows "(ucast (x - y)::'b::len0 word) = ucast x - ucast y"
proof -
  have "(2::int) ^ LENGTH('b) dvd 2 ^ LENGTH('a)"
    using le_imp_power_dvd[OF assms, where a="2::int"]
    by simp
  from mod_mod_cancel[OF this]
  show ?thesis
    using assms mod_mod_cancel
    unfolding ucast_def uint_word_ariths
    unfolding word_uint.norm_eq_iff[THEN sym] wi_hom_syms[THEN sym]
    by simp
qed

lemma ucast_minus_up:
  fixes x y :: "'a ::len0 word"
  assumes "LENGTH('a) < LENGTH('b)"
  shows "(ucast (x - y)::'b::len word) = (ucast x - ucast y) AND mask (LENGTH('a))"
proof -
  have "LENGTH('a) \<le> LENGTH('b)"
    using assms by simp
  from le_imp_power_dvd[OF this, where a="2::int"]
  have "(2::int) ^ LENGTH('a) dvd 2 ^ LENGTH('b)"
    by simp
  from mod_mod_cancel[OF this]
  show ?thesis
    unfolding ucast_def uint_word_ariths and_mask_mod_2p wi_hom_syms[THEN sym] uint_word_of_int
    unfolding word_uint.norm_eq_iff[THEN sym]
    by auto
qed

lemma uint_ucast_plus_ucast [simp]:
  fixes x :: "'a::len word"
    and y :: "'b::len word"
  assumes "LENGTH('a) < LENGTH('c)"
      and "LENGTH('b) < LENGTH('c)"
  shows "uint ((ucast x :: 'c::len word) + ucast y) = uint x + uint y"
proof -
  have x: "uint x < 2 ^ (LENGTH('c) - 1)"
    using less_le_trans[OF uint_lt[where w=x]] assms
    by auto
  have y: "uint y < 2 ^ (LENGTH('c) - 1)"
    using less_le_trans[OF uint_lt[where w=y]] assms
    by auto
  have "(2::int) * 2 ^ (LENGTH('c) - 1) = 2 ^ (Suc (LENGTH('c) - 1))"
    by (rule power_Suc[THEN sym])
  also have "... = 2 ^ LENGTH('c)"
    by auto
  finally have "uint x + uint y < 2 ^ LENGTH('c)"
    using add_strict_mono[OF x y]
    by auto
  hence *: "uint (ucast x :: 'c word) + uint (ucast y :: 'c word) < 2 ^ LENGTH('c)"
    using assms by simp
  show ?thesis
    using uint_add_lem[THEN iffD1, OF *]
    using assms
    by simp
qed

lemma uint_ucast_plus_one [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) < LENGTH('c)"
      and "1 < LENGTH('c)"
  shows "uint ((ucast x :: 'c::len word) + 1) = uint x + 1"
    and "uint (1 + (ucast x :: 'c::len word)) = 1 + uint x"
using assms
using uint_ucast_plus_ucast[where x=x and y="(1::1 word)" and 'c='c]
using uint_ucast_plus_ucast[where x="(1::1 word)" and y=x and 'c='c]
by auto

corollary unat_ucast_plus_one [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) < LENGTH('c)"
      and "1 < LENGTH('c)"
  shows "unat ((ucast x :: 'c::len word) + 1) = unat x + 1"
    and "unat (1 + (ucast x :: 'c::len word)) = 1 + unat x"
using assms
unfolding unat_def
by (simp_all add: Suc_nat_eq_nat_zadd1)

corollary ucast_ucast_plus_one [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) < LENGTH('c)"
      and "1 < LENGTH('c)"
  shows "(ucast ((ucast x :: 'c::len word) + 1)::'b::len word) = ucast x + 1"
    and "(ucast (1 + (ucast x :: 'c::len word))::'b::len word) = 1 + ucast x"
using arg_cong[where f="\<lambda>x. (word_of_int x::'b word)", OF uint_ucast_plus_one(1)[OF assms, of x]]
using arg_cong[where f="\<lambda>x. (word_of_int x::'b word)", OF uint_ucast_plus_one(2)[OF assms, of x]]
unfolding ucast_def
by (auto simp: wi_hom_syms)

lemma uint_ucast_plus_ucast_plus_one [simp]:
  fixes x :: "'a::len word"
    and y :: "'b::len word"
  assumes "LENGTH('a) < LENGTH('c)"
      and "LENGTH('b) < LENGTH('c)"
  shows "uint ((ucast x :: 'c::len word) + ucast y + 1) = uint x + uint y + 1"
proof -
  have x: "uint x < 2 ^ (LENGTH('c) - 1)"
    using less_le_trans[OF uint_lt[where w=x]] assms
    by auto
  have y: "uint y < 2 ^ (LENGTH('c) - 1)"
    using less_le_trans[OF uint_lt[where w=y]] assms
    by auto
  have "(2::int) * 2 ^ (LENGTH('c) - 1) = 2 ^ (Suc (LENGTH('c) - 1))"
    by (rule power_Suc[THEN sym])
  also have "... = 2 ^ LENGTH('c)"
    by auto
  finally have "uint x + uint y + 1 < 2 ^ LENGTH('c)"
    using zle_diff1_eq[THEN iffD2, OF x]
    using zle_diff1_eq[THEN iffD2, OF y]
    by auto
  hence "uint ((ucast x::'c word) + ucast y) + uint (1::'c word) < 2 ^ LENGTH('c)"
    using assms by simp
  from uint_add_lem[THEN iffD1, OF this]
  show ?thesis
    using assms by simp
qed

subsubsection \<open>@{const word_cat}\<close>

lemma nth_word_cat:
  fixes x :: "'a::len0 word"
    and y :: "'b::len0 word"
  shows "((word_cat x y)::'c::len0 word) !! n =
         (n < len_of TYPE('c) \<and>
          (if n < len_of TYPE('b) then y !! n else x !! (n - len_of TYPE('b))))"
unfolding word_cat_def
by (simp add: bin_nth_cat word_test_bit_def[THEN sym])

lemma word_cat_zero [simp]:
  shows "(word_cat 0 x) = ucast x"
using test_bit_size
by (intro word_eqI)
   (auto simp add: nth_word_cat nth_ucast word_size)

lemma word_cat_slice_zero [simp]:
  fixes x :: "'a::len word"
  assumes "LENGTH('b) = n"
      and "LENGTH('c) = LENGTH('a) - n"
  shows "word_cat (slice n x::'c::len0 word) (0::'b::len0 word) = x AND NOT mask n"
using assms
by (intro word_eqI)
  (auto simp: word_size nth_word_cat nth_slice word_ops_nth_size)

lemma test_bit_len: "(x :: 'a::len word) !! n \<Longrightarrow> n < LENGTH('a)"
  by (auto simp: test_bit_bin)

lemma word_cat_shiftl_OR: "word_cat xs (ys :: 'y::len word) = (ucast xs << LENGTH('y)) OR ucast ys"
  using test_bit_len
  by (intro word_eqI) (auto simp: nth_word_cat word_ao_nth nth_shiftl nth_ucast)

subsubsection \<open>@{const shiftl}\<close>

lemma shiftl_zero [simp]:
  fixes x :: "'a::len0 word"
  assumes "LENGTH('a) \<le> n"
  shows "x << n = 0"
using assms
by (intro word_eqI) (simp add: word_size nth_shiftl)

subsubsection \<open>@{const scast}\<close>

lemma nth_scast:
  fixes w :: "'a::len word"
  shows "(scast w::'b::len word) !! n =
         ((if n < LENGTH('a) - 1 then w !! n else w !! (LENGTH('a) - 1)) \<and> n < len_of TYPE('b))"
unfolding scast_def test_bit_def' word_ubin.eq_norm nth_bintr nth_sint
by auto

lemma scast_alt_def:
  fixes x :: "'a::len word"
  assumes "LENGTH('c) = LENGTH('a) + LENGTH('b)"
      and "m = LENGTH('a) - 1"
  shows "scast x = (word_cat (if x !! m then max_word else 0::'b::len word) x::'c::len word)"
  (is "?l = ?r")
proof (intro word_eqI impI, unfold word_size)
  fix n
  show "?l !! n = ?r !! n"
    by (cases "n = m")
       (auto simp: assms word_size nth_word_cat nth_scast
             split: if_splits)
qed

lemma scast_scast_shiftl:
  fixes x :: "'a::len word"
  assumes "LENGTH('a) + n \<le> LENGTH('b)"
  shows "(scast ((scast x::'b::len word) << n)::'c::len word) = scast x << n"
  (is "?l = ?r")
proof (intro word_eqI impI, unfold word_size)
  fix k
  assume len: "k < LENGTH('c)"
  have "1 \<le> LENGTH('a)"
    using add_leD2 discrete by blast
  hence *: "n \<le> LENGTH('b) - Suc 0"
    using assms
    by auto
  consider "k < n"
         | "n \<le> k" "k - n < LENGTH('a) - 1"
         | "n \<le> k" "LENGTH('a) - 1 \<le> k - n"
    by arith
  thus "?l !! k = ?r !! k"
    proof cases
      case 1
      hence "\<not> ?l !! k" "\<not> ?r !! k"
        unfolding nth_scast nth_shiftl
        by simp_all
      thus ?thesis by simp
    next
      case 2
      hence "?l !! k = x !! (k - n)" "?r !! k = x !! (k - n)"
        unfolding nth_scast nth_shiftl
        using assms len
        by auto
      thus ?thesis by simp
    next
      case 3
      hence "?l !! k = x !! (LENGTH('a) - 1)" "?r !! k = x !! (LENGTH('a) - 1)"
        unfolding nth_scast nth_shiftl
        using assms len *
        by auto
      thus ?thesis by simp
    qed
qed

subsubsection \<open>Upper bits and @{const slice}\<close>

lemma slice_eq_imp_and_not_mask_eq:
  fixes x y :: "'a::len word"
  assumes length: "LENGTH('a) \<le> LENGTH('b) + n"
      and slice: "(slice n x::'b::len0 word) = slice n y"
  shows "(x AND NOT mask n) = (y AND NOT mask n)"
proof (intro word_eqI impI, simp add: word_size)
  fix i
  assume "i < LENGTH('a)"
  thus "(x AND NOT mask n) !! i = (y AND NOT mask n) !! i"
    using length test_bit_cong[OF slice, where x="i - n"]
    by (auto simp: word_size nth_slice word_ops_nth_size)
qed

lemma and_not_mask_eq_imp_slice_eq:
  fixes x y :: "'a::len word"
  assumes length: "LENGTH('b) + n \<le> LENGTH('a)"
      and mask: "(x AND NOT mask n) = (y AND NOT mask n)"
  shows "(slice n x::'b::len0 word) = slice n y"
proof (intro word_eqI impI, simp add: word_size)
  fix i
  assume "i < LENGTH('b)"
  thus "(slice n x::'b::len0 word) !! i = (slice n y::'b::len0 word) !! i"
    using length test_bit_cong[OF mask, where x="i + n"]
    by (auto simp: word_size nth_slice word_ops_nth_size)
qed

lemma eq_slice_eq_and_not_mask:
  fixes x y :: "'a::len word"
  assumes "LENGTH('a) = LENGTH('b) + n"
  shows "((slice n x::'b::len0 word) = slice n y) =
         ((x AND NOT mask n) = (y AND NOT mask n))"
using assms
using slice_eq_imp_and_not_mask_eq[where 'b='b and x=x and y=y and n=n]
using and_not_mask_eq_imp_slice_eq[where 'b='b and x=x and y=y and n=n]
by auto

subsubsection \<open>Lower bits and @{const ucast}\<close>

lemma ucast_eq_imp_and_mask_eq:
  fixes x y :: "'a::len word"
  assumes length: "n \<le> LENGTH('b)"
      and ucast: "(ucast x::'b::len0 word) = ucast y"
  shows "(x AND mask n) = (y AND mask n)"
proof (intro word_eqI impI, simp add: word_size)
  fix i
  assume "i < LENGTH('a)"
  thus "(x AND mask n) !! i = (y AND mask n) !! i"
    using length test_bit_cong[OF ucast, where x=i]
    by (auto simp: word_size nth_ucast word_ops_nth_size)
qed

lemma and_mask_eq_imp_ucast_eq:
  fixes x y :: "'a::len word"
  assumes length: "LENGTH('b) \<le> n"
      and mask: "(x AND mask n) = (y AND mask n)"
  shows "(ucast x::'b::len0 word) = ucast y"
proof (intro word_eqI impI, simp add: word_size)
  fix i
  show "(ucast x::'b::len0 word) !! i = (ucast y::'b::len0 word) !! i"
    using test_bit_size[where w=x and n=i]
    using test_bit_size[where w=y and n=i]
    using length test_bit_cong[OF mask, where x=i]
    by (auto simp: word_size nth_ucast word_ao_nth)
qed

lemma eq_ucast_eq_and_mask:
  fixes x y :: "'a::len word"
  assumes "n = LENGTH('b)"
  shows "((ucast x::'b::len0 word) = ucast y) =
         ((x AND mask n) = (y AND mask n))"
using assms
using ucast_eq_imp_and_mask_eq[where 'b='b and x=x and y=y and n=n]
using and_mask_eq_imp_ucast_eq[where 'b='b and x=x and y=y and n=n]
by auto

subsubsection \<open>Aligned inequalities\<close>

lemma le_and_not_mask:
  fixes x y :: "'a::len word"
  assumes "x \<le> y"
  shows "x AND NOT mask n \<le> y AND NOT mask n"
proof -
  have "uint x \<le> uint y"
    using assms unfolding word_le_def by simp
  from zdiv_mono1[OF this]
  have "uint x div 2 ^ n \<le> uint y div 2 ^ n"
    by auto
  thus ?thesis
    unfolding word_le_def
    by (simp add: uint_and_not_mask not_le)
qed

lemma le_right_and_not_mask:
  assumes "(ucast x::'b::len0 word) = 0"
      and "n = LENGTH('b)"
  shows "(x \<le> y AND NOT mask n) = (x \<le> y)"
proof
  assume "x \<le> y AND NOT mask n"
  thus "x \<le> y"
    using word_and_le2[where a=y and y="NOT mask n"]
    by auto
next
  have [simp]: "x AND mask n = 0"
    using assms eq_ucast_eq_and_mask[where x=x and y=0]
    by auto
  have [simp]: "x AND NOT mask n = x"
    using word_and_not_mask_plus_word_and_mask[where x=x and n=n]
    by simp
  assume "x \<le> y"
  from le_and_not_mask[where n=n, OF this]
  show "x \<le> y AND NOT mask n"
    by simp
qed

corollary less_left_and_not_mask:
  assumes "(ucast y::'b::len0 word) = 0"
      and "n = LENGTH('b)"
  shows "(x AND NOT mask n < y) = (x < y)"
using le_right_and_not_mask[where x=y and y=x, OF assms]
by auto

lemma word_and_mask_and_not_mask_size:
  fixes x :: "'a::len word"
  assumes "n \<le> m"
      and "n \<le> LENGTH('a)"
  shows "(x AND mask m) AND NOT mask n \<le> 2 ^ m - 2 ^ n"
unfolding word_power_of_two_difference[OF assms]
using le_and_not_mask[OF word_and_le1[where y=x and a="mask m"]]
by simp

corollary word_and_not_mask_and_mask_size:
  fixes x :: "'a::len word"
  assumes "n \<le> m"
      and "n \<le> LENGTH('a)"
  shows "(x AND NOT mask n) AND mask m \<le> 2 ^ m - 2 ^ n"
using word_and_mask_and_not_mask_size[OF assms]
using word_bool_alg.conj.assoc word_bool_alg.conj.commute
by metis

(*<*)
end
(*>*)


(*  Author:     Tobias Nipkow, 2007  *)

theory QEdlo
imports DLO
begin

subsection "DNF-based quantifier elimination"

definition qe_dlo\<^sub>1 :: "atom list \<Rightarrow> atom fm" where
"qe_dlo\<^sub>1 as =
 (if Less 0 0 \<in> set as then FalseF else
  let lbs = [i. Less (Suc i) 0 \<leftarrow> as]; ubs = [j. Less 0 (Suc j) \<leftarrow> as];
      pairs = [Atom(Less i j). i \<leftarrow> lbs, j \<leftarrow> ubs]
  in list_conj pairs)"

theorem I_qe_dlo\<^sub>1:
assumes less: "\<forall>a \<in> set as. is_Less a" and dep: "\<forall>a \<in> set as. depends\<^sub>d\<^sub>l\<^sub>o a"
shows "DLO.I (qe_dlo\<^sub>1 as) xs = (\<exists>x. \<forall>a \<in> set as. I\<^sub>d\<^sub>l\<^sub>o a (x#xs))"
  (is "?L = ?R")
proof
  let ?lbs = "[i. Less (Suc i) 0 \<leftarrow> as]"
  let ?ubs = "[j. Less 0 (Suc j) \<leftarrow> as]"
  let ?Ls = "set ?lbs" let ?Us = "set ?ubs"
  let ?lb = "Max (\<Union>x\<in>?Ls. {xs!x})"
  let ?ub = "Min (\<Union>x\<in>?Us. {xs!x})"
  have 2: "Less 0 0 \<notin> set as \<Longrightarrow> \<forall>a \<in> set as.
      (\<exists>i \<in> ?Ls. a = Less (Suc i) 0) \<or> (\<exists>i \<in> ?Us. a = Less 0 (Suc i))"
  proof
    fix a assume "Less 0 0 \<notin> set as" "a \<in> set as"
    then obtain i j where [simp]: "a = Less i j"
      using less by (force simp:is_Less_iff)
    with dep obtain k where "i = 0 \<and> j = Suc k \<or> i = Suc k \<and> j = 0"
      using `Less 0 0 \<notin> set as` `a \<in> set as`
      by auto (metis Nat.nat.nchotomy depends\<^sub>d\<^sub>l\<^sub>o.simps(2))
    moreover hence "i=0 \<and> k \<in> ?Us \<or> j=0 \<and> k \<in> ?Ls"
      using `a \<in> set as` by force
    ultimately show "(\<exists>i\<in>?Ls. a=Less (Suc i) 0) \<or> (\<exists>i\<in>?Us. a=Less 0 (Suc i))"
      by force
  qed
  assume qe1: ?L
  hence 0: "Less 0 0 \<notin> set as" by (auto simp:qe_dlo\<^sub>1_def)
  with qe1 have 1: "\<forall>x\<in>?Ls. \<forall>y\<in>?Us. xs ! x < xs ! y"
    by (fastforce simp:qe_dlo\<^sub>1_def)
  have finite: "finite ?Ls" "finite ?Us" by (rule finite_set)+
  { fix i x
    assume "Less i 0 \<in> set as | Less 0 i \<in> set as"
    moreover hence "i \<noteq> 0" using 0 by iprover
    ultimately have "(x#xs) ! i = xs!(i - 1)" by (simp add: nth_Cons')
  } note this[simp]
  { assume nonempty: "?Ls \<noteq> {} \<and> ?Us \<noteq> {}"
    hence "Max (\<Union>x\<in>?Ls. {xs!x}) < Min (\<Union>x\<in>?Us. {xs!x})"
      using 1 finite by auto
    then obtain m where "?lb < m \<and> m < ?ub" using dense by blast
    hence "\<forall>i\<in>?Ls. xs!i < m" and "\<forall>j\<in>?Us. m < xs!j"
      using nonempty finite by auto
    hence "\<forall>a \<in> set as. I\<^sub>d\<^sub>l\<^sub>o a (m # xs)" using 2[OF 0] by(auto simp:less)
    hence ?R .. }
  moreover
  { assume asm: "?Ls \<noteq> {} \<and> ?Us = {}"
    then obtain m where "?lb < m" using no_ub by blast
    hence "\<forall>a\<in> set as. I\<^sub>d\<^sub>l\<^sub>o a (m # xs)" using 2[OF 0] asm finite by auto
    hence ?R .. }
  moreover
  { assume asm: "?Ls = {} \<and> ?Us \<noteq> {}"
    then obtain m where "m < ?ub" using no_lb by blast
    hence "\<forall>a\<in> set as. I\<^sub>d\<^sub>l\<^sub>o a (m # xs)" using 2[OF 0] asm finite by auto
    hence ?R .. }
  moreover
  { assume "?Ls = {} \<and> ?Us = {}"
    hence ?R using 2[OF 0] by (auto simp add:less)
  }
  ultimately show ?R by blast
next
  assume ?R
  then obtain x where 1: "\<forall>a\<in> set as. I\<^sub>d\<^sub>l\<^sub>o a (x # xs)" ..
  hence 0: "Less 0 0 \<notin> set as" by auto
  { fix i j
    assume asm: "Less i 0 \<in> set as" "Less 0 j \<in> set as"
    hence "(x#xs)!i < x" "x < (x#xs)!j" using 1 by auto+
    hence "(x#xs)!i < (x#xs)!j" by(rule order_less_trans)
    moreover have "\<not>(i = 0 | j = 0)" using 0 asm by blast
    ultimately have "xs ! (i - 1) < xs ! (j - 1)" by (simp add: nth_Cons')
  }
  thus ?L using 0 less
    by (fastforce simp: qe_dlo\<^sub>1_def is_Less_iff split:atom.splits nat.splits)
qed

lemma I_qe_dlo\<^sub>1_pretty:
  "\<forall>a \<in> set as. is_Less a \<and> depends\<^sub>d\<^sub>l\<^sub>o a \<Longrightarrow> DLO.is_dnf_qe _ qe_dlo\<^sub>1 as"
by(metis I_qe_dlo\<^sub>1)

definition subst :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
"subst i j k = (if k=0 then if i=0 then j else i else k) - 1"
fun subst\<^sub>0 :: "atom \<Rightarrow> atom \<Rightarrow> atom" where
"subst\<^sub>0 (Eq i j) a = (case a of
   Less m n \<Rightarrow> Less (subst i j m) (subst i j n)
 | Eq m n \<Rightarrow> Eq (subst i j m) (subst i j n))"

lemma subst\<^sub>0_pretty:
  "subst\<^sub>0 (Eq i j) (Less m n) = Less (subst i j m) (subst i j n)"
  "subst\<^sub>0 (Eq i j) (Eq m n) = Eq (subst i j m) (subst i j n)"
by auto

(*<*)
(* needed for code generation *)
definition [code del]: "lift_dnfeq_qe = ATOM_EQ.lift_dnfeq_qe neg\<^sub>d\<^sub>l\<^sub>o depends\<^sub>d\<^sub>l\<^sub>o decr\<^sub>d\<^sub>l\<^sub>o (\<lambda>Eq i j \<Rightarrow> i=0 \<or> j=0 | a \<Rightarrow> False)
          (\<lambda>Eq i j \<Rightarrow> i=j | a \<Rightarrow> False) subst\<^sub>0"
definition [code del]:
  "lift_eq_qe = ATOM_EQ.lift_eq_qe (\<lambda>Eq i j \<Rightarrow> i=0 \<or> j=0 | a \<Rightarrow> False)
                                   (\<lambda>Eq i j \<Rightarrow> i=j | a \<Rightarrow> False) subst\<^sub>0"

lemmas DLOe_code_lemmas = DLO_code_lemmas lift_dnfeq_qe_def lift_eq_qe_def

hide_const lift_dnfeq_qe lift_eq_qe
(*>*)

interpretation DLO\<^sub>e!:
  ATOM_EQ neg\<^sub>d\<^sub>l\<^sub>o "(\<lambda>a. True)" I\<^sub>d\<^sub>l\<^sub>o depends\<^sub>d\<^sub>l\<^sub>o decr\<^sub>d\<^sub>l\<^sub>o
          "(\<lambda>Eq i j \<Rightarrow> i=0 \<or> j=0 | a \<Rightarrow> False)"
          "(\<lambda>Eq i j \<Rightarrow> i=j | a \<Rightarrow> False)" subst\<^sub>0
apply(unfold_locales)
apply(fastforce simp:subst_def nth_Cons' split:atom.splits split_if_asm)
apply(simp add:subst_def split:atom.splits)
apply(fastforce simp:subst_def nth_Cons' split:atom.splits)
apply(fastforce simp add:subst_def split:atom.splits)
done

(*<*)
lemmas [folded DLOe_code_lemmas, code] =
  DLO\<^sub>e.lift_dnfeq_qe_def DLO\<^sub>e.lift_eq_qe_def
(*>*)

setup {* Sign.revert_abbrev "" @{const_abbrev DLO\<^sub>e.lift_dnfeq_qe} *}

definition "qe_dlo = DLO\<^sub>e.lift_dnfeq_qe qe_dlo\<^sub>1"
(*<*)
lemmas [folded DLOe_code_lemmas, code] = qe_dlo_def
(*>*)

lemma qfree_qe_dlo\<^sub>1: "qfree (qe_dlo\<^sub>1 as)"
by(auto simp:qe_dlo\<^sub>1_def intro!:qfree_list_conj)

theorem I_qe_dlo: "DLO.I (qe_dlo \<phi>) xs = DLO.I \<phi> xs"
unfolding qe_dlo_def
by(fastforce intro!: I_qe_dlo\<^sub>1 qfree_qe_dlo\<^sub>1 DLO\<^sub>e.I_lift_dnfeq_qe
        simp: is_Less_iff not_is_Eq_iff split:atom.splits cong:conj_cong)

theorem qfree_qe_dlo: "qfree (qe_dlo \<phi>)"
by(simp add:qe_dlo_def DLO\<^sub>e.qfree_lift_dnfeq_qe qfree_qe_dlo\<^sub>1)

end


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

section \<open>Classes cpo and pcpo\<close>

theory Pcpo
  imports Porder
begin

subsection \<open>Complete partial orders\<close>

text \<open>The class cpo of chain complete partial orders\<close>

class cpo = po +
  assumes cpo: "chain S \<Longrightarrow> \<exists>x. range S <<| x"
begin

text \<open>in cpo's everthing equal to THE lub has lub properties for every chain\<close>

lemma cpo_lubI: "chain S \<Longrightarrow> range S <<| (\<Squnion>i. S i)"
  by (fast dest: cpo elim: is_lub_lub)

lemma thelubE: "\<lbrakk>chain S; (\<Squnion>i. S i) = l\<rbrakk> \<Longrightarrow> range S <<| l"
  by (blast dest: cpo intro: is_lub_lub)

text \<open>Properties of the lub\<close>

lemma is_ub_thelub: "chain S \<Longrightarrow> S x \<sqsubseteq> (\<Squnion>i. S i)"
  by (blast dest: cpo intro: is_lub_lub [THEN is_lub_rangeD1])

lemma is_lub_thelub: "\<lbrakk>chain S; range S <| x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
  by (blast dest: cpo intro: is_lub_lub [THEN is_lubD2])

lemma lub_below_iff: "chain S \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x \<longleftrightarrow> (\<forall>i. S i \<sqsubseteq> x)"
  by (simp add: is_lub_below_iff [OF cpo_lubI] is_ub_def)

lemma lub_below: "\<lbrakk>chain S; \<And>i. S i \<sqsubseteq> x\<rbrakk> \<Longrightarrow> (\<Squnion>i. S i) \<sqsubseteq> x"
  by (simp add: lub_below_iff)

lemma below_lub: "\<lbrakk>chain S; x \<sqsubseteq> S i\<rbrakk> \<Longrightarrow> x \<sqsubseteq> (\<Squnion>i. S i)"
  by (erule below_trans, erule is_ub_thelub)

lemma lub_range_mono: "\<lbrakk>range X \<subseteq> range Y; chain Y; chain X\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
  apply (erule lub_below)
  apply (subgoal_tac "\<exists>j. X i = Y j")
   apply clarsimp
   apply (erule is_ub_thelub)
  apply auto
  done

lemma lub_range_shift: "chain Y \<Longrightarrow> (\<Squnion>i. Y (i + j)) = (\<Squnion>i. Y i)"
  apply (rule below_antisym)
   apply (rule lub_range_mono)
     apply fast
    apply assumption
   apply (erule chain_shift)
  apply (rule lub_below)
   apply assumption
  apply (rule_tac i="i" in below_lub)
   apply (erule chain_shift)
  apply (erule chain_mono)
  apply (rule le_add1)
  done

lemma maxinch_is_thelub: "chain Y \<Longrightarrow> max_in_chain i Y = ((\<Squnion>i. Y i) = Y i)"
  apply (rule iffI)
   apply (fast intro!: lub_eqI lub_finch1)
  apply (unfold max_in_chain_def)
  apply (safe intro!: below_antisym)
   apply (fast elim!: chain_mono)
  apply (drule sym)
  apply (force elim!: is_ub_thelub)
  done

text \<open>the \<open>\<sqsubseteq>\<close> relation between two chains is preserved by their lubs\<close>

lemma lub_mono: "\<lbrakk>chain X; chain Y; \<And>i. X i \<sqsubseteq> Y i\<rbrakk> \<Longrightarrow> (\<Squnion>i. X i) \<sqsubseteq> (\<Squnion>i. Y i)"
  by (fast elim: lub_below below_lub)

text \<open>the = relation between two chains is preserved by their lubs\<close>

lemma lub_eq: "(\<And>i. X i = Y i) \<Longrightarrow> (\<Squnion>i. X i) = (\<Squnion>i. Y i)"
  by simp

lemma ch2ch_lub:
  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
  shows "chain (\<lambda>i. \<Squnion>j. Y i j)"
  apply (rule chainI)
  apply (rule lub_mono [OF 2 2])
  apply (rule chainE [OF 1])
  done

lemma diag_lub:
  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>i. Y i i)"
proof (rule below_antisym)
  have 3: "chain (\<lambda>i. Y i i)"
    apply (rule chainI)
    apply (rule below_trans)
     apply (rule chainE [OF 1])
    apply (rule chainE [OF 2])
    done
  have 4: "chain (\<lambda>i. \<Squnion>j. Y i j)"
    by (rule ch2ch_lub [OF 1 2])
  show "(\<Squnion>i. \<Squnion>j. Y i j) \<sqsubseteq> (\<Squnion>i. Y i i)"
    apply (rule lub_below [OF 4])
    apply (rule lub_below [OF 2])
    apply (rule below_lub [OF 3])
    apply (rule below_trans)
     apply (rule chain_mono [OF 1 max.cobounded1])
    apply (rule chain_mono [OF 2 max.cobounded2])
    done
  show "(\<Squnion>i. Y i i) \<sqsubseteq> (\<Squnion>i. \<Squnion>j. Y i j)"
    apply (rule lub_mono [OF 3 4])
    apply (rule is_ub_thelub [OF 2])
    done
qed

lemma ex_lub:
  assumes 1: "\<And>j. chain (\<lambda>i. Y i j)"
  assumes 2: "\<And>i. chain (\<lambda>j. Y i j)"
  shows "(\<Squnion>i. \<Squnion>j. Y i j) = (\<Squnion>j. \<Squnion>i. Y i j)"
  by (simp add: diag_lub 1 2)

end

subsection \<open>Pointed cpos\<close>

text \<open>The class pcpo of pointed cpos\<close>

class pcpo = cpo +
  assumes least: "\<exists>x. \<forall>y. x \<sqsubseteq> y"
begin

definition bottom :: "'a"  ("\<bottom>")
  where "bottom = (THE x. \<forall>y. x \<sqsubseteq> y)"

lemma minimal [iff]: "\<bottom> \<sqsubseteq> x"
  unfolding bottom_def
  apply (rule the1I2)
   apply (rule ex_ex1I)
    apply (rule least)
   apply (blast intro: below_antisym)
  apply simp
  done

end

text \<open>Old "UU" syntax:\<close>

syntax UU :: logic
translations "UU" \<rightharpoonup> "CONST bottom"

text \<open>Simproc to rewrite \<^term>\<open>\<bottom> = x\<close> to \<^term>\<open>x = \<bottom>\<close>.\<close>
setup \<open>Reorient_Proc.add (fn \<^Const_>\<open>bottom _\<close> => true | _ => false)\<close>
simproc_setup reorient_bottom ("\<bottom> = x") = Reorient_Proc.proc

text \<open>useful lemmas about \<^term>\<open>\<bottom>\<close>\<close>

lemma below_bottom_iff [simp]: "x \<sqsubseteq> \<bottom> \<longleftrightarrow> x = \<bottom>"
  by (simp add: po_eq_conv)

lemma eq_bottom_iff: "x = \<bottom> \<longleftrightarrow> x \<sqsubseteq> \<bottom>"
  by simp

lemma bottomI: "x \<sqsubseteq> \<bottom> \<Longrightarrow> x = \<bottom>"
  by (subst eq_bottom_iff)

lemma lub_eq_bottom_iff: "chain Y \<Longrightarrow> (\<Squnion>i. Y i) = \<bottom> \<longleftrightarrow> (\<forall>i. Y i = \<bottom>)"
  by (simp only: eq_bottom_iff lub_below_iff)

subsection \<open>Chain-finite and flat cpos\<close>

text \<open>further useful classes for HOLCF domains\<close>

class chfin = po +
  assumes chfin: "chain Y \<Longrightarrow> \<exists>n. max_in_chain n Y"
begin

subclass cpo
  apply standard
  apply (frule chfin)
  apply (blast intro: lub_finch1)
  done

lemma chfin2finch: "chain Y \<Longrightarrow> finite_chain Y"
  by (simp add: chfin finite_chain_def)

end

class flat = pcpo +
  assumes ax_flat: "x \<sqsubseteq> y \<Longrightarrow> x = \<bottom> \<or> x = y"
begin

subclass chfin
proof
  fix Y
  assume *: "chain Y"
  show "\<exists>n. max_in_chain n Y"
    apply (unfold max_in_chain_def)
    apply (cases "\<forall>i. Y i = \<bottom>")
     apply simp
    apply simp
    apply (erule exE)
    apply (rule_tac x="i" in exI)
    apply clarify
    using * apply (blast dest: chain_mono ax_flat)
    done
qed

lemma flat_below_iff: "x \<sqsubseteq> y \<longleftrightarrow> x = \<bottom> \<or> x = y"
  by (safe dest!: ax_flat)

lemma flat_eq: "a \<noteq> \<bottom> \<Longrightarrow> a \<sqsubseteq> b = (a = b)"
  by (safe dest!: ax_flat)

end

subsection \<open>Discrete cpos\<close>

class discrete_cpo = below +
  assumes discrete_cpo [simp]: "x \<sqsubseteq> y \<longleftrightarrow> x = y"
begin

subclass po
  by standard simp_all

text \<open>In a discrete cpo, every chain is constant\<close>

lemma discrete_chain_const:
  assumes S: "chain S"
  shows "\<exists>x. S = (\<lambda>i. x)"
proof (intro exI ext)
  fix i :: nat
  from S le0 have "S 0 \<sqsubseteq> S i" by (rule chain_mono)
  then have "S 0 = S i" by simp
  then show "S i = S 0" by (rule sym)
qed

subclass chfin
proof
  fix S :: "nat \<Rightarrow> 'a"
  assume S: "chain S"
  then have "\<exists>x. S = (\<lambda>i. x)"
    by (rule discrete_chain_const)
  then have "max_in_chain 0 S"
    by (auto simp: max_in_chain_def)
  then show "\<exists>i. max_in_chain i S" ..
qed

end

end


theory prop_26
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster equal2 elem append *)
  theorem x0 :
    "(elem x xs) ==> (elem x (append xs ys))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory ex_2_3
imports Main
begin
fun count::"'a \<Rightarrow> 'a list \<Rightarrow> nat" where
"count x [] = 0" |
"count x (y # ys) = (if x = y then 1 else 0) + (count x ys)"

theorem count_bound:"count x xs \<le> length xs"
  apply (induction xs)
  by (auto)
end


(*  Title:      HOL/MicroJava/BV/Opt.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

More about options.
*)

section \<open>More about Options\<close>

theory Opt imports Err begin

definition le :: "'a ord \<Rightarrow> 'a option ord"
where
  "le r o\<^sub>1 o\<^sub>2 =
  (case o\<^sub>2 of None \<Rightarrow> o\<^sub>1=None | Some y \<Rightarrow> (case o\<^sub>1 of None \<Rightarrow> True | Some x \<Rightarrow> x \<sqsubseteq>\<^sub>r y))"

definition opt :: "'a set \<Rightarrow> 'a option set"
where
  "opt A = insert None {Some y |y. y \<in> A}"

definition sup :: "'a ebinop \<Rightarrow> 'a option ebinop"
where
  "sup f o\<^sub>1 o\<^sub>2 =
  (case o\<^sub>1 of None \<Rightarrow> OK o\<^sub>2
           | Some x \<Rightarrow> (case o\<^sub>2 of None \<Rightarrow> OK o\<^sub>1
                                 | Some y \<Rightarrow> (case f x y of Err \<Rightarrow> Err | OK z \<Rightarrow> OK (Some z))))"

definition esl :: "'a esl \<Rightarrow> 'a option esl"
where
  "esl = (\<lambda>(A,r,f). (opt A, le r, sup f))"

lemma unfold_le_opt:
  "o\<^sub>1 \<sqsubseteq>\<^bsub>le r\<^esub> o\<^sub>2 =
  (case o\<^sub>2 of None \<Rightarrow> o\<^sub>1=None |
              Some y \<Rightarrow> (case o\<^sub>1 of None \<Rightarrow> True | Some x \<Rightarrow> x \<sqsubseteq>\<^sub>r y))"
(*<*)
apply (unfold lesub_def le_def)
apply (rule refl)
done
(*>*)

lemma le_opt_refl: "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> x"
(*<*) by (simp add: unfold_le_opt split: option.split) (*<*)

lemma le_opt_trans [rule_format]:
  "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> y \<longrightarrow> y \<sqsubseteq>\<^bsub>le r\<^esub> z \<longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> z"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_trans)
done
(*>*)

lemma le_opt_antisym [rule_format]:
  "order r \<Longrightarrow> x \<sqsubseteq>\<^bsub>le r\<^esub> y \<longrightarrow> y \<sqsubseteq>\<^bsub>le r\<^esub> x \<longrightarrow> x=y"
(*<*)
apply (simp add: unfold_le_opt split: option.split)
apply (blast intro: order_antisym)
done
(*>*)

lemma order_le_opt [intro!,simp]: "order r \<Longrightarrow> order(le r)"
(*<*)
apply (subst order_def)
apply (blast intro: le_opt_refl le_opt_trans le_opt_antisym)
done
(*>*)

lemma None_bot [iff]:  "None \<sqsubseteq>\<^bsub>le r\<^esub> ox"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma Some_le [iff]: "(Some x \<sqsubseteq>\<^bsub>le r\<^esub> z) = (\<exists>y. z = Some y \<and> x \<sqsubseteq>\<^sub>r y)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma le_None [iff]: "(x \<sqsubseteq>\<^bsub>le r\<^esub> None) = (x = None)"
(*<*)
apply (unfold lesub_def le_def)
apply (simp split: option.split)
done
(*>*)

lemma OK_None_bot [iff]: "OK None \<sqsubseteq>\<^bsub>Err.le (le r)\<^esub> x"
(*<*) by (simp add: lesub_def Err.le_def le_def split: option.split err.split) (*>*)

lemma sup_None1 [iff]: "x \<squnion>\<^bsub>sup f\<^esub> None = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma sup_None2 [iff]: "None \<squnion>\<^bsub>sup f\<^esub> x = OK x"
(*<*) by (simp add: plussub_def sup_def split: option.split) (*>*)

lemma None_in_opt [iff]: "None \<in> opt A"
(*<*) by (simp add: opt_def) (*>*)

lemma Some_in_opt [iff]: "(Some x \<in> opt A) = (x \<in> A)"
(*<*) by (unfold opt_def) auto (*>*)

lemma semilat_opt [intro, simp]:
  "err_semilat L \<Longrightarrow> err_semilat (Opt.esl L)"
(*<*)
proof -
  assume s: "err_semilat L"
  obtain A r f where [simp]: "L = (A,r,f)" by (cases L)
  let ?A0 = "err A" and ?r0 = "Err.le r" and ?f0 = "lift2 f"
  from s obtain
    ord: "order ?r0" and
    clo: "closed ?A0 ?f0" and
    ub1: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. x \<sqsubseteq>\<^bsub>?r0\<^esub> x \<squnion>\<^bsub>?f0\<^esub> y" and
    ub2: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. y \<sqsubseteq>\<^bsub>?r0\<^esub> x \<squnion>\<^bsub>?f0\<^esub> y" and
    lub: "\<forall>x\<in>?A0. \<forall>y\<in>?A0. \<forall>z\<in>?A0. x \<sqsubseteq>\<^bsub>?r0\<^esub> z \<and> y \<sqsubseteq>\<^bsub>?r0\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f0\<^esub> y \<sqsubseteq>\<^bsub>?r0\<^esub> z"
    by (unfold semilat_def sl_def) simp

  let ?A = "err (opt A)" and ?r = "Err.le (Opt.le r)" and ?f = "lift2 (Opt.sup f)"

  from ord have "order ?r" by simp
  moreover
  have "closed ?A ?f"
  proof (unfold closed_def, intro strip)
    fix x y assume x: "x \<in> ?A" and y: "y \<in> ?A"

    { fix a b assume ab: "x = OK a" "y = OK b"
      with x have a: "\<And>c. a = Some c \<Longrightarrow> c \<in> A" by (clarsimp simp add: opt_def)
      from ab y have b: "\<And>d. b = Some d \<Longrightarrow> d \<in> A" by (clarsimp simp add: opt_def)
      { fix c d assume "a = Some c" "b = Some d"
        with ab x y have "c \<in> A & d \<in> A" by (simp add: err_def opt_def Bex_def)
        with clo have "f c d \<in> err A"
          by (simp add: closed_def plussub_def err_def' lift2_def)
        moreover fix z assume "f c d = OK z"
        ultimately have "z \<in> A" by simp
      } note f_closed = this
      have "sup f a b \<in> ?A"
      proof (cases a)
        case None thus ?thesis
          by (simp add: sup_def opt_def) (cases b, simp, simp add: b Bex_def)
      next
        case Some thus ?thesis
          by (auto simp add: sup_def opt_def Bex_def a b f_closed split: err.split option.split)
      qed
    }
    thus "x \<squnion>\<^bsub>?f\<^esub> y \<in> ?A" by (simp add: plussub_def lift2_def split: err.split)
  qed
  moreover
  { fix a b c assume "a \<in> opt A" and "b \<in> opt A" and "a \<squnion>\<^bsub>sup f\<^esub> b = OK c"
    moreover from ord have "order r" by simp
    moreover
    { fix x y z assume "x \<in> A" and "y \<in> A"
      hence "OK x \<in> err A \<and> OK y \<in> err A" by simp
      with ub1 ub2
      have "(OK x) \<sqsubseteq>\<^bsub>Err.le r\<^esub> (OK x) \<squnion>\<^bsub>lift2 f\<^esub> (OK y) \<and>
            (OK y) \<sqsubseteq>\<^bsub>Err.le r\<^esub> (OK x) \<squnion>\<^bsub>lift2 f\<^esub> (OK y)"
        by blast
      moreover assume "x \<squnion>\<^sub>f y = OK z"
      ultimately have "x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z"
        by (auto simp add: plussub_def lift2_def Err.le_def lesub_def)
    }
    ultimately have "a \<sqsubseteq>\<^bsub>le r\<^esub> c \<and> b \<sqsubseteq>\<^bsub>le r\<^esub> c"
      by (auto simp add: sup_def le_def lesub_def plussub_def
               dest: order_refl split: option.splits err.splits)
  }
  hence "(\<forall>x\<in>?A. \<forall>y\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y) \<and> (\<forall>x\<in>?A. \<forall>y\<in>?A. y \<sqsubseteq>\<^bsub>?r\<^esub> x \<squnion>\<^bsub>?f\<^esub> y)"
    by (auto simp add: lesub_def plussub_def Err.le_def lift2_def split: err.split)
  moreover
  have "\<forall>x\<in>?A. \<forall>y\<in>?A. \<forall>z\<in>?A. x \<sqsubseteq>\<^bsub>?r\<^esub> z \<and> y \<sqsubseteq>\<^bsub>?r\<^esub> z \<longrightarrow> x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
  proof (intro strip, elim conjE)
    fix x y z
    assume xyz: "x \<in> ?A"   "y \<in> ?A"   "z \<in> ?A"
    assume xz: "x \<sqsubseteq>\<^bsub>?r\<^esub> z" and yz: "y \<sqsubseteq>\<^bsub>?r\<^esub> z"
    { fix a b c assume ok: "x = OK a"  "y = OK b"  "z = OK c"
      { fix d e g  assume some: "a = Some d"  "b = Some e"  "c = Some g"
        with ok xyz obtain "OK d:err A" "OK e:err A" "OK g:err A"  by simp
        with lub
        have "\<lbrakk> OK d \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g; OK e \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g \<rbrakk> \<Longrightarrow> OK d \<squnion>\<^bsub>lift2 f\<^esub> OK e \<sqsubseteq>\<^bsub>Err.le r\<^esub> OK g"
          by blast
        hence "\<lbrakk> d \<sqsubseteq>\<^sub>r g; e \<sqsubseteq>\<^sub>r g \<rbrakk> \<Longrightarrow> \<exists>y. d \<squnion>\<^sub>f e = OK y \<and> y \<sqsubseteq>\<^sub>r g" by simp
        with ok some xyz xz yz have "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
          by (auto simp add: sup_def le_def lesub_def lift2_def plussub_def Err.le_def)
      } note this [intro!]
      from ok xyz xz yz have "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
        by - (cases a, simp, cases b, simp, cases c, simp, blast)
    }
    with xyz xz yz show "x \<squnion>\<^bsub>?f\<^esub> y \<sqsubseteq>\<^bsub>?r\<^esub> z"
      by - (cases x, simp, cases y, simp, cases z, simp+)
  qed
  ultimately show "err_semilat (Opt.esl L)"
    by (unfold semilat_def esl_def sl_def) simp
qed
(*>*)

lemma top_le_opt_Some [iff]: "top (le r) (Some T) = top r T"
(*<*)
apply (unfold top_def)
apply (rule iffI)
 apply blast
apply (rule allI)
apply (case_tac "x")
apply simp+
done
(*>*)

lemma Top_le_conv:  "\<lbrakk> order r; top r T \<rbrakk> \<Longrightarrow> (T \<sqsubseteq>\<^sub>r x) = (x = T)"
(*<*)
apply (unfold top_def)
apply (blast intro: order_antisym)
done
(*>*)

lemma acc_le_optI [intro!]: "acc r \<Longrightarrow> acc(le r)"
(*<*)
apply (unfold acc_def lesub_def le_def lesssub_def)
apply (simp add: wf_eq_minimal split: option.split)
apply clarify
apply (case_tac "\<exists>a. Some a \<in> Q")
 apply (erule_tac x = "{a . Some a \<in> Q}" in allE)
 apply blast
apply (case_tac "x")
 apply blast
apply blast
done
(*>*)

lemma map_option_in_optionI:
  "\<lbrakk> ox \<in> opt S; \<forall>x\<in>S. ox = Some x \<longrightarrow> f x \<in> S \<rbrakk>
  \<Longrightarrow> map_option f ox \<in> opt S"
(*<*)
apply (unfold map_option_case)
apply (simp split: option.split)
apply blast
done
(*>*)

end