(*  Title:      HOL/Word/WordBitwise.thy
    Authors:    Thomas Sewell, NICTA and Sascha Boehme, TU Muenchen
*)

theory WordBitwise

imports Word

begin

text \<open>Helper constants used in defining addition\<close>

definition
  xor3 :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
where
 "xor3 a b c = (a = (b = c))"

definition
  carry :: "bool \<Rightarrow> bool \<Rightarrow> bool \<Rightarrow> bool"
where
 "carry a b c = ((a \<and> (b \<or> c)) \<or> (b \<and> c))"

lemma carry_simps:
  "carry True a b = (a \<or> b)"
  "carry a True b = (a \<or> b)"
  "carry a b True = (a \<or> b)"
  "carry False a b = (a \<and> b)"
  "carry a False b = (a \<and> b)"
  "carry a b False = (a \<and> b)"
  by (auto simp add: carry_def)

lemma xor3_simps:
  "xor3 True a b = (a = b)"
  "xor3 a True b = (a = b)"
  "xor3 a b True = (a = b)"
  "xor3 False a b = (a \<noteq> b)"
  "xor3 a False b = (a \<noteq> b)"
  "xor3 a b False = (a \<noteq> b)"
  by (simp_all add: xor3_def)

text \<open>Breaking up word equalities into equalities on their
bit lists. Equalities are generated and manipulated in the
reverse order to to_bl.\<close>

lemma word_eq_rbl_eq:
  "(x = y) = (rev (to_bl x) = rev (to_bl y))"
  by simp

lemma rbl_word_or:
  "rev (to_bl (x OR y)) = map2 op \<or> (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: map2_def zip_rev bl_word_or rev_map)

lemma rbl_word_and:
  "rev (to_bl (x AND y)) = map2 op \<and> (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: map2_def zip_rev bl_word_and rev_map)

lemma rbl_word_xor:
  "rev (to_bl (x XOR y)) = map2 op \<noteq> (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: map2_def zip_rev bl_word_xor rev_map)

lemma rbl_word_not:
  "rev (to_bl (NOT x)) = map Not (rev (to_bl x))"
  by (simp add: bl_word_not rev_map)

lemma bl_word_sub:
  "to_bl (x - y) = to_bl (x + (- y))"
  by simp

lemma rbl_word_1:
  "rev (to_bl (1 :: ('a :: len0) word))
     = takefill False (len_of TYPE('a)) [True]"
  apply (rule_tac s="rev (to_bl (word_succ (0 :: 'a word)))" in trans)
   apply simp
  apply (simp only: rtb_rbl_ariths(1)[OF refl])
  apply simp
  apply (case_tac "len_of TYPE('a)")
   apply simp
  apply (simp add: takefill_alt)
  done

lemma rbl_word_if:
  "rev (to_bl (if P then x else y))
      = map2 (If P) (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: map2_def split_def)

lemma rbl_add_carry_Cons:
  "(if car then rbl_succ else id) (rbl_add (x # xs) (y # ys))
        = xor3 x y car # (if carry x y car then rbl_succ else id)
             (rbl_add xs ys)"
  by (simp add: carry_def xor3_def)

lemma rbl_add_suc_carry_fold:
  "length xs = length ys \<Longrightarrow>
   \<forall>car. (if car then rbl_succ else id) (rbl_add xs ys)
        = (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car))
                 (zip xs ys) (\<lambda>_. [])) car"
  apply (erule list_induct2)
   apply simp
  apply (simp only: rbl_add_carry_Cons)
  apply simp
  done

lemma to_bl_plus_carry:
  "to_bl (x + y)
     = rev (foldr (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car))
                 (rev (zip (to_bl x) (to_bl y))) (\<lambda>_. []) False)"
  using rbl_add_suc_carry_fold[where xs="rev (to_bl x)" and ys="rev (to_bl y)"]
  apply (simp add: word_add_rbl[OF refl refl])
  apply (drule_tac x=False in spec)
  apply (simp add: zip_rev)
  done

definition
 "rbl_plus cin xs ys = foldr
       (\<lambda>(x, y) res car. xor3 x y car # res (carry x y car))
       (zip xs ys) (\<lambda>_. []) cin"

lemma rbl_plus_simps:
  "rbl_plus cin (x # xs) (y # ys)
      = xor3 x y cin # rbl_plus (carry x y cin) xs ys"
  "rbl_plus cin [] ys = []"
  "rbl_plus cin xs [] = []"
  by (simp_all add: rbl_plus_def)

lemma rbl_word_plus:
  "rev (to_bl (x + y)) = rbl_plus False (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: rbl_plus_def to_bl_plus_carry zip_rev)

definition
 "rbl_succ2 b xs = (if b then rbl_succ xs else xs)"

lemma rbl_succ2_simps:
  "rbl_succ2 b [] = []"
  "rbl_succ2 b (x # xs) = (b \<noteq> x) # rbl_succ2 (x \<and> b) xs"
  by (simp_all add: rbl_succ2_def)

lemma twos_complement:
  "- x = word_succ (NOT x)"
  using arg_cong[OF word_add_not[where x=x], where f="\<lambda>a. a - x + 1"]
  by (simp add: word_succ_p1 word_sp_01[unfolded word_succ_p1]
           del: word_add_not)

lemma rbl_word_neg:
  "rev (to_bl (- x)) = rbl_succ2 True (map Not (rev (to_bl x)))"
  by (simp add: twos_complement word_succ_rbl[OF refl]
                bl_word_not rev_map rbl_succ2_def)

lemma rbl_word_cat:
  "rev (to_bl (word_cat x y :: ('a :: len0) word))
     = takefill False (len_of TYPE('a)) (rev (to_bl y) @ rev (to_bl x))"
  by (simp add: word_cat_bl word_rev_tf)

lemma rbl_word_slice:
  "rev (to_bl (slice n w :: ('a :: len0) word))
     = takefill False (len_of TYPE('a)) (drop n (rev (to_bl w)))"
  apply (simp add: slice_take word_rev_tf rev_take)
  apply (cases "n < len_of TYPE('b)", simp_all)
  done

lemma rbl_word_ucast:
  "rev (to_bl (ucast x :: ('a :: len0) word))
     = takefill False (len_of TYPE('a)) (rev (to_bl x))"
  apply (simp add: to_bl_ucast takefill_alt)
  apply (simp add: rev_drop)
  apply (case_tac "len_of TYPE('a) < len_of TYPE('b)")
   apply simp_all
  done

lemma rbl_shiftl:
  "rev (to_bl (w << n)) = takefill False (size w)
     (replicate n False @ rev (to_bl w))"
  by (simp add: bl_shiftl takefill_alt word_size rev_drop)

lemma rbl_shiftr:
  "rev (to_bl (w >> n)) = takefill False (size w)
     (drop n (rev (to_bl w)))"
  by (simp add: shiftr_slice rbl_word_slice word_size)

definition
 "drop_nonempty v n xs
     = (if n < length xs then drop n xs else [last (v # xs)])"

lemma drop_nonempty_simps:
  "drop_nonempty v (Suc n) (x # xs) = drop_nonempty x n xs"
  "drop_nonempty v 0 (x # xs) = (x # xs)"
  "drop_nonempty v n [] = [v]"
  by (simp_all add: drop_nonempty_def)

definition
  "takefill_last x n xs = takefill (last (x # xs)) n xs"

lemma takefill_last_simps:
  "takefill_last z (Suc n) (x # xs) = x # takefill_last x n xs"
  "takefill_last z 0 xs = []"
  "takefill_last z n [] = replicate n z"
  apply (simp_all add: takefill_last_def)
  apply (simp_all add: takefill_alt)
  done

lemma rbl_sshiftr:
  "rev (to_bl (w >>> n)) =
     takefill_last False (size w)
        (drop_nonempty False n (rev (to_bl w)))"
  apply (cases "n < size w")
   apply (simp add: bl_sshiftr takefill_last_def word_size
                    takefill_alt rev_take last_rev
                    drop_nonempty_def)
  apply (subgoal_tac "(w >>> n) = of_bl (replicate (size w) (msb w))")
   apply (simp add: word_size takefill_last_def takefill_alt
                    last_rev word_msb_alt word_rev_tf
                    drop_nonempty_def take_Cons')
   apply (case_tac "len_of TYPE('a)", simp_all)
  apply (rule word_eqI)
  apply (simp add: nth_sshiftr word_size test_bit_of_bl
                   msb_nth)
  done

lemma nth_word_of_int:
  "(word_of_int x :: ('a :: len0) word) !! n
      = (n < len_of TYPE('a) \<and> bin_nth x n)"
  apply (simp add: test_bit_bl word_size to_bl_of_bin)
  apply (subst conj_cong[OF refl], erule bin_nth_bl)
  apply (auto)
  done

lemma nth_scast:
  "(scast (x :: ('a :: len) word) :: ('b :: len) word) !! n
     = (n < len_of TYPE('b) \<and>
          (if n < len_of TYPE('a) - 1 then x !! n
           else x !! (len_of TYPE('a) - 1)))"
  by (simp add: scast_def nth_word_of_int nth_sint)

lemma rbl_word_scast:
  "rev (to_bl (scast x :: ('a :: len) word))
     = takefill_last False (len_of TYPE('a))
           (rev (to_bl x))"
  apply (rule nth_equalityI)
   apply (simp add: word_size takefill_last_def)
  apply (clarsimp simp: nth_scast takefill_last_def
                        nth_takefill word_size nth_rev to_bl_nth)
  apply (cases "len_of TYPE('b)")
   apply simp
  apply (clarsimp simp: less_Suc_eq_le linorder_not_less
                        last_rev word_msb_alt[symmetric]
                        msb_nth)
  done

definition
  rbl_mul :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
where
 "rbl_mul xs ys = foldr (\<lambda>x sm. rbl_plus False (map (op \<and> x) ys) (False # sm))
    xs []"

lemma rbl_mul_simps:
  "rbl_mul (x # xs) ys
     = rbl_plus False (map (op \<and> x) ys) (False # rbl_mul xs ys)"
  "rbl_mul [] ys = []"
  by (simp_all add: rbl_mul_def)

lemma takefill_le2:
  "length xs \<le> n \<Longrightarrow>
   takefill x m (takefill x n xs)
     = takefill x m xs"
  by (simp add: takefill_alt replicate_add[symmetric])

lemma take_rbl_plus:
  "\<forall>n b. take n (rbl_plus b xs ys)
    = rbl_plus b (take n xs) (take n ys)"
  apply (simp add: rbl_plus_def take_zip[symmetric])
  apply (rule_tac list="zip xs ys" in list.induct)
   apply simp
  apply (clarsimp simp: split_def)
  apply (case_tac n, simp_all)
  done

lemma word_rbl_mul_induct:
  fixes y :: "'a :: len word" shows
  "length xs \<le> size y
   \<Longrightarrow> rbl_mul xs (rev (to_bl y))
     = take (length xs) (rev (to_bl (of_bl (rev xs) * y)))"
proof (induct xs)
  case Nil
  show ?case
    by (simp add: rbl_mul_simps)
next
  case (Cons z zs)

  have rbl_word_plus':
    "\<And>(x :: 'a word) y.
      to_bl (x + y) = rev (rbl_plus False (rev (to_bl x)) (rev (to_bl y)))"
    by (simp add: rbl_word_plus[symmetric])

  have mult_bit: "to_bl (of_bl [z] * y) = map (op \<and> z) (to_bl y)"
    apply (cases z)
     apply (simp cong: map_cong)
    apply (simp add: map_replicate_const cong: map_cong)
    done

  have shiftl: "\<And>xs. of_bl xs * 2 * y = (of_bl xs * y) << 1"
    by (simp add: shiftl_t2n)

  have zip_take_triv: "\<And>xs ys n. n = length ys
      \<Longrightarrow> zip (take n xs) ys = zip xs ys"
    by (rule nth_equalityI, simp_all)

  show ?case
    using Cons
    apply (simp add: trans [OF of_bl_append add.commute]
                     rbl_mul_simps rbl_word_plus'
                     Cons.hyps distrib_right mult_bit
                     shiftl rbl_shiftl)
    apply (simp add: takefill_alt word_size rev_map take_rbl_plus
                     min_def)
    apply (simp add: rbl_plus_def zip_take_triv)
    done
qed

lemma rbl_word_mul:
  fixes x :: "'a :: len word"
  shows "rev (to_bl (x * y)) = rbl_mul (rev (to_bl x)) (rev (to_bl y))"
  using word_rbl_mul_induct[where xs="rev (to_bl x)" and y=y]
  by (simp add: word_size)

text \<open>Breaking up inequalities into bitlist properties.\<close>

definition
  "rev_bl_order F xs ys =
     (length xs = length ys \<and>
       ((xs = ys \<and> F)
          \<or> (\<exists>n < length xs. drop (Suc n) xs = drop (Suc n) ys
                   \<and> \<not> xs ! n \<and> ys ! n)))"

lemma rev_bl_order_simps:
  "rev_bl_order F [] [] = F"
  "rev_bl_order F (x # xs) (y # ys)
     = rev_bl_order ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> F)) xs ys"
  apply (simp_all add: rev_bl_order_def)
  apply (rule conj_cong[OF refl])
  apply (cases "xs = ys")
   apply (simp add: nth_Cons')
   apply blast
  apply (simp add: nth_Cons')
  apply safe
   apply (rule_tac x="n - 1" in exI)
   apply simp
  apply (rule_tac x="Suc n" in exI)
  apply simp
  done

lemma rev_bl_order_rev_simp:
  "length xs = length ys \<Longrightarrow>
   rev_bl_order F (xs @ [x]) (ys @ [y])
     = ((y \<and> \<not> x) \<or> ((y \<or> \<not> x) \<and> rev_bl_order F xs ys))"
  apply (induct arbitrary: F rule: list_induct2)
   apply (auto simp add: rev_bl_order_simps)
  done

lemma rev_bl_order_bl_to_bin:
  "length xs = length ys
     \<Longrightarrow> rev_bl_order True xs ys
            = (bl_to_bin (rev xs) \<le> bl_to_bin (rev ys))
       \<and> rev_bl_order False xs ys
            = (bl_to_bin (rev xs) < bl_to_bin (rev ys))"
  apply (induct xs ys rule: list_induct2)
   apply (simp_all add: rev_bl_order_simps bl_to_bin_app_cat)
  apply (auto simp add: bl_to_bin_def Bit_B0 Bit_B1 add1_zle_eq Bit_def)
  done

lemma word_le_rbl:
  fixes x :: "('a :: len0) word"
  shows "(x \<le> y) = rev_bl_order True (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: rev_bl_order_bl_to_bin word_le_def)

lemma word_less_rbl:
  fixes x :: "('a :: len0) word"
  shows "(x < y) = rev_bl_order False (rev (to_bl x)) (rev (to_bl y))"
  by (simp add: word_less_alt rev_bl_order_bl_to_bin)

lemma word_sint_msb_eq:
  "sint x = uint x - (if msb x then 2 ^ size x else 0)"
  apply (cases "msb x")
   apply (rule word_sint.Abs_eqD[where 'a='a], simp_all)
    apply (simp add: word_size wi_hom_syms
                     word_of_int_2p_len)
   apply (simp add: sints_num word_size)
   apply (rule conjI)
    apply (simp add: le_diff_eq')
    apply (rule order_trans[where y="2 ^ (len_of TYPE('a) - 1)"])
     apply (simp add: power_Suc[symmetric])
    apply (simp add: linorder_not_less[symmetric] mask_eq_iff[symmetric])
    apply (rule notI, drule word_eqD[where x="size x - 1"])
    apply (simp add: msb_nth word_ops_nth_size word_size)
   apply (simp add: order_less_le_trans[where y=0])
  apply (rule word_uint.Abs_eqD[where 'a='a], simp_all)
  apply (simp add: linorder_not_less uints_num word_msb_sint)
  apply (rule order_less_le_trans[OF sint_lt])
  apply simp
  done

lemma word_sle_msb_le:
  "(x <=s y) = ((msb y --> msb x) \<and>
                  ((msb x \<and> \<not> msb y) \<or> (x <= y)))"
  apply (simp add: word_sle_def word_sint_msb_eq word_size
                   word_le_def)
  apply safe
   apply (rule order_trans[OF _ uint_ge_0])
   apply (simp add: order_less_imp_le)
  apply (erule notE[OF leD])
  apply (rule order_less_le_trans[OF _ uint_ge_0])
  apply simp
  done

lemma word_sless_msb_less:
  "(x <s y) = ((msb y --> msb x) \<and>
                  ((msb x \<and> \<not> msb y) \<or> (x < y)))"
  by (auto simp add: word_sless_def word_sle_msb_le)

definition
  "map_last f xs = (if xs = [] then [] else butlast xs @ [f (last xs)])"

lemma map_last_simps:
  "map_last f [] = []"
  "map_last f [x] = [f x]"
  "map_last f (x # y # zs) = x # map_last f (y # zs)"
  by (simp_all add: map_last_def)

lemma word_sle_rbl:
  "(x <=s y) = rev_bl_order True (map_last Not (rev (to_bl x)))
     (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sle_msb_le word_le_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

lemma word_sless_rbl:
  "(x <s y) = rev_bl_order False (map_last Not (rev (to_bl x)))
     (map_last Not (rev (to_bl y)))"
  using word_msb_alt[where w=x] word_msb_alt[where w=y]
  apply (simp add: word_sless_msb_less word_less_rbl)
  apply (subgoal_tac "length (to_bl x) = length (to_bl y)")
   apply (cases "to_bl x", simp)
   apply (cases "to_bl y", simp)
   apply (clarsimp simp: map_last_def rev_bl_order_rev_simp)
   apply auto
  done

text \<open>Lemmas for unpacking rev (to_bl n) for numerals n and also
for irreducible values and expressions.\<close>

lemma rev_bin_to_bl_simps:
  "rev (bin_to_bl 0 x) = []"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit0 nm)))
    = False # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.Bit1 nm)))
    = True # rev (bin_to_bl n (numeral nm))"
  "rev (bin_to_bl (Suc n) (numeral (num.One)))
    = True # replicate n False"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm)))
    = False # rev (bin_to_bl n (- numeral nm))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm)))
    = True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One)))
    = True # replicate n True"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit0 nm + num.One)))
    = True # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.Bit1 nm + num.One)))
    = False # rev (bin_to_bl n (- numeral (nm + num.One)))"
  "rev (bin_to_bl (Suc n) (- numeral (num.One + num.One)))
    = False # rev (bin_to_bl n (- numeral num.One))"
  apply (simp_all add: bin_to_bl_def)
  apply (simp_all only: bin_to_bl_aux_alt)
  apply (simp_all)
  apply (simp_all add: bin_to_bl_zero_aux bin_to_bl_minus1_aux)
  done

lemma to_bl_upt:
  "to_bl x = rev (map (op !! x) [0 ..< size x])"
  apply (rule nth_equalityI)
   apply (simp add: word_size)
  apply (clarsimp simp: to_bl_nth word_size nth_rev)
  done

lemma rev_to_bl_upt:
  "rev (to_bl x) = map (op !! x) [0 ..< size x]"
  by (simp add: to_bl_upt)

lemma upt_eq_list_intros:
  "j <= i \<Longrightarrow> [i ..< j] = []"
  "\<lbrakk> i = x; x < j; [x + 1 ..< j] = xs \<rbrakk> \<Longrightarrow> [i ..< j] = (x # xs)"
  by (simp_all add: upt_eq_Nil_conv upt_eq_Cons_conv)

text \<open>Tactic definition\<close>

ML \<open>
structure Word_Bitwise_Tac =
struct

val word_ss = simpset_of @{theory_context Word};

fun mk_nat_clist ns = List.foldr
  (uncurry (Thm.mk_binop @{cterm "Cons :: nat => _"}))
  @{cterm "[] :: nat list"} ns;

fun upt_conv ctxt ct =
  case Thm.term_of ct of
    (@{const upt} $ n $ m) =>
      let
        val (i, j) = apply2 (snd o HOLogic.dest_number) (n, m);
        val ns = map (Numeral.mk_cnumber @{ctyp nat}) (i upto (j - 1))
          |> mk_nat_clist;
        val prop = Thm.mk_binop @{cterm "op = :: nat list => _"} ct ns
                     |> Thm.apply @{cterm Trueprop};
      in
        try (fn () =>
          Goal.prove_internal ctxt [] prop
            (K (REPEAT_DETERM (resolve_tac ctxt @{thms upt_eq_list_intros} 1
                ORELSE simp_tac (put_simpset word_ss ctxt) 1))) |> mk_meta_eq) ()
      end
  | _ => NONE;

val expand_upt_simproc =
  Simplifier.make_simproc @{context} "expand_upt"
   {lhss = [@{term "upt x y"}], proc = K upt_conv};

fun word_len_simproc_fn ctxt ct =
  case Thm.term_of ct of
    Const (@{const_name len_of}, _) $ t => (let
        val T = fastype_of t |> dest_Type |> snd |> the_single
        val n = Numeral.mk_cnumber @{ctyp nat} (Word_Lib.dest_binT T);
        val prop = Thm.mk_binop @{cterm "op = :: nat => _"} ct n
                 |> Thm.apply @{cterm Trueprop};
      in Goal.prove_internal ctxt [] prop (K (simp_tac (put_simpset word_ss ctxt) 1))
             |> mk_meta_eq |> SOME end
    handle TERM _ => NONE | TYPE _ => NONE)
  | _ => NONE;

val word_len_simproc =
  Simplifier.make_simproc @{context} "word_len"
   {lhss = [@{term "len_of x"}], proc = K word_len_simproc_fn};

(* convert 5 or nat 5 to Suc 4 when n_sucs = 1, Suc (Suc 4) when n_sucs = 2,
   or just 5 (discarding nat) when n_sucs = 0 *)

fun nat_get_Suc_simproc_fn n_sucs ctxt ct =
  let
    val (f $ arg) = Thm.term_of ct;
    val n = (case arg of @{term nat} $ n => n | n => n)
      |> HOLogic.dest_number |> snd;
    val (i, j) = if n > n_sucs then (n_sucs, n - n_sucs)
      else (n, 0);
    val arg' = List.foldr (op $) (HOLogic.mk_number @{typ nat} j)
        (replicate i @{term Suc});
    val _ = if arg = arg' then raise TERM ("", []) else ();
    fun propfn g = HOLogic.mk_eq (g arg, g arg')
      |> HOLogic.mk_Trueprop |> Thm.cterm_of ctxt;
    val eq1 = Goal.prove_internal ctxt [] (propfn I)
      (K (simp_tac (put_simpset word_ss ctxt) 1));
  in Goal.prove_internal ctxt [] (propfn (curry (op $) f))
      (K (simp_tac (put_simpset HOL_ss ctxt addsimps [eq1]) 1))
       |> mk_meta_eq |> SOME end
    handle TERM _ => NONE;

fun nat_get_Suc_simproc n_sucs ts =
  Simplifier.make_simproc @{context} "nat_get_Suc"
   {lhss = map (fn t => t $ @{term "n :: nat"}) ts,
    proc = K (nat_get_Suc_simproc_fn n_sucs)};

val no_split_ss =
  simpset_of (put_simpset HOL_ss @{context}
    |> Splitter.del_split @{thm if_split});

val expand_word_eq_sss =
  (simpset_of (put_simpset HOL_basic_ss @{context} addsimps
       @{thms word_eq_rbl_eq word_le_rbl word_less_rbl word_sle_rbl word_sless_rbl}),
  map simpset_of [
   put_simpset no_split_ss @{context} addsimps
    @{thms rbl_word_plus rbl_word_and rbl_word_or rbl_word_not
                                rbl_word_neg bl_word_sub rbl_word_xor
                                rbl_word_cat rbl_word_slice rbl_word_scast
                                rbl_word_ucast rbl_shiftl rbl_shiftr rbl_sshiftr
                                rbl_word_if},
   put_simpset no_split_ss @{context} addsimps
    @{thms to_bl_numeral to_bl_neg_numeral to_bl_0 rbl_word_1},
   put_simpset no_split_ss @{context} addsimps
    @{thms rev_rev_ident rev_replicate rev_map to_bl_upt word_size}
          addsimprocs [word_len_simproc],
   put_simpset no_split_ss @{context} addsimps
    @{thms list.simps split_conv replicate.simps list.map
                                zip_Cons_Cons zip_Nil drop_Suc_Cons drop_0 drop_Nil
                                foldr.simps map2_Cons map2_Nil takefill_Suc_Cons
                                takefill_Suc_Nil takefill.Z rbl_succ2_simps
                                rbl_plus_simps rev_bin_to_bl_simps append.simps
                                takefill_last_simps drop_nonempty_simps
                                rev_bl_order_simps}
          addsimprocs [expand_upt_simproc,
                       nat_get_Suc_simproc 4
                         [@{term replicate}, @{term "takefill x"},
                          @{term drop}, @{term "bin_to_bl"},
                          @{term "takefill_last x"},
                          @{term "drop_nonempty x"}]],
    put_simpset no_split_ss @{context} addsimps @{thms xor3_simps carry_simps if_bool_simps}
  ])

fun tac ctxt =
  let
    val (ss, sss) = expand_word_eq_sss;
  in
    foldr1 (op THEN_ALL_NEW)
      ((CHANGED o safe_full_simp_tac (put_simpset ss ctxt)) ::
        map (fn ss => safe_full_simp_tac (put_simpset ss ctxt)) sss)
  end;

end

\<close>

method_setup word_bitwise =
  \<open>Scan.succeed (fn ctxt => Method.SIMPLE_METHOD (Word_Bitwise_Tac.tac ctxt 1))\<close>
  "decomposer for word equalities and inequalities into bit propositions"

end


theory T137
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


section {* Partial functions *}

theory Pfun
imports Map_Extra
begin

text {* I'm not completely satisfied with partial functions as provided by Map.thy, since they don't
        have a unique type and so we can't instantiate classes, make use of adhoc-overloading
        etc. Consequently I've created a new type and derived the laws. *}

subsection {* Partial function type and operations *}

typedef ('a, 'b) pfun = "UNIV :: ('a \<rightharpoonup> 'b) set" ..

setup_lifting type_definition_pfun

lift_definition pfun_app :: "('a, 'b) pfun \<Rightarrow> 'a \<Rightarrow> 'b" ("_'(_')\<^sub>p" [999,0] 999) is
"\<lambda> f x. if (x \<in> dom f) then the (f x) else undefined" .

lift_definition pfun_upd :: "('a, 'b) pfun \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) pfun"
is "\<lambda> f k v. f(k := Some v)" .

lift_definition pdom :: "('a, 'b) pfun \<Rightarrow> 'a set" is dom .

lift_definition pran :: "('a, 'b) pfun \<Rightarrow> 'b set" is ran .

lift_definition pfun_comp :: "('b, 'c) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'c) pfun" (infixl "\<circ>\<^sub>p" 55) is map_comp .

lift_definition pfun_member :: "'a \<times> 'b \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" (infix "\<in>\<^sub>p" 50) is "op \<in>\<^sub>m" .

lift_definition pId_on :: "'a set \<Rightarrow> ('a, 'a) pfun" is "\<lambda> A x. if (x \<in> A) then Some x else None" .

abbreviation pId :: "('a, 'a) pfun" where
"pId \<equiv> pId_on UNIV"

lift_definition pdom_res :: "'a set \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" (infixl "\<lhd>\<^sub>p" 85)
is "\<lambda> A f. restrict_map f A" .

lift_definition pran_res :: "('a, 'b) pfun \<Rightarrow> 'b set \<Rightarrow> ('a, 'b) pfun" (infixl "\<rhd>\<^sub>p" 85)
is ran_restrict_map .

lift_definition pfun_graph :: "('a, 'b) pfun \<Rightarrow> ('a \<times> 'b) set" is map_graph .

lift_definition graph_pfun :: "('a \<times> 'b) set \<Rightarrow> ('a, 'b) pfun" is graph_map .

lift_definition pfun_entries :: "'k set \<Rightarrow> ('k \<Rightarrow> 'v) \<Rightarrow> ('k, 'v) pfun" is
"\<lambda> d f x. if (x \<in> d) then Some (f x) else None" .

definition pcard :: "('a, 'b) pfun \<Rightarrow> nat"
where "pcard f = card (pdom f)"

instantiation pfun :: (type, type) zero
begin
lift_definition zero_pfun :: "('a, 'b) pfun" is "Map.empty" .
instance ..
end

abbreviation pempty :: "('a, 'b) pfun" ("{}\<^sub>p")
where "pempty \<equiv> 0"

instantiation pfun :: (type, type) plus
begin
lift_definition plus_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" is "op ++" .
instance ..
end

instantiation pfun :: (type, type) minus
begin
lift_definition minus_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" is "op --" .
instance ..
end

instance pfun :: (type, type) monoid_add
  by (intro_classes, (transfer, auto)+)

instantiation pfun :: (type, type) inf
begin
lift_definition inf_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" is
"\<lambda> f g x. if (x \<in> dom(f) \<inter> dom(g) \<and> f(x) = g(x)) then f(x) else None" .
instance ..
end

abbreviation pfun_inter :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun" (infixl "\<inter>\<^sub>p" 80)
where "pfun_inter \<equiv> inf"

instantiation pfun :: (type, type) order
begin
  lift_definition less_eq_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" is
  "\<lambda> f g. f \<subseteq>\<^sub>m g" .
  lift_definition less_pfun :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" is
  "\<lambda> f g. f \<subseteq>\<^sub>m g \<and> f \<noteq> g" .
instance
  by (intro_classes, (transfer, auto intro: map_le_trans simp add: map_le_antisym)+)
end

abbreviation pfun_subset :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" (infix "\<subset>\<^sub>p" 50)
where "pfun_subset \<equiv> less"

abbreviation pfun_subset_eq :: "('a, 'b) pfun \<Rightarrow> ('a, 'b) pfun \<Rightarrow> bool" (infix "\<subseteq>\<^sub>p" 50)
where "pfun_subset_eq \<equiv> less_eq"

instance pfun :: (type, type) semilattice_inf
  by (intro_classes, (transfer, auto simp add: map_le_def dom_def)+)

lemma pfun_subset_eq_least [simp]:
  "{}\<^sub>p \<subseteq>\<^sub>p f"
  by (transfer, auto)

syntax
  "_PfunUpd"  :: "[('a, 'b) pfun, maplets] => ('a, 'b) pfun" ("_'(_')\<^sub>p" [900,0]900)
  "_Pfun"     :: "maplets => ('a, 'b) pfun"            ("(1{_}\<^sub>p)")

translations
  "_PfunUpd m (_Maplets xy ms)"  == "_PfunUpd (_PfunUpd m xy) ms"
  "_PfunUpd m (_maplet  x y)"    == "CONST pfun_upd m x y"
  "_Pfun ms"                     => "_PfunUpd (CONST pempty) ms"
  "_Pfun (_Maplets ms1 ms2)"     <= "_PfunUpd (_Pfun ms1) ms2"
  "_Pfun ms"                     <= "_PfunUpd (CONST pempty) ms"

subsection {* Algebraic laws *}

lemma pfun_comp_assoc: "f \<circ>\<^sub>p (g \<circ>\<^sub>p h) = (f \<circ>\<^sub>p g) \<circ>\<^sub>p h"
  by (transfer, simp add: map_comp_assoc)

lemma pfun_comp_left_id [simp]: "pId \<circ>\<^sub>p f = f"
  by (transfer, auto)

lemma pfun_comp_right_id [simp]: "f \<circ>\<^sub>p pId = f"
  by (transfer, auto)

lemma pfun_override_dist_comp:
  "(f + g) \<circ>\<^sub>p h = (f \<circ>\<^sub>p h) + (g \<circ>\<^sub>p h)"
  apply (transfer)
  apply (rule ext)
  apply (auto simp add: map_add_def)
  apply (rename_tac f g h x)
  apply (case_tac "h x")
  apply (auto)
  apply (rename_tac f g h x y)
  apply (case_tac "g y")
  apply (auto)
done

lemma pfun_minus_unit [simp]:
  fixes f :: "('a, 'b) pfun"
  shows "f - 0 = f"
  by (transfer, simp add: map_minus_def)

lemma pfun_minus_zero [simp]:
  fixes f :: "('a, 'b) pfun"
  shows "0 - f = 0"
  by (transfer, simp add: map_minus_def)

lemma pfun_minus_self [simp]:
  fixes f :: "('a, 'b) pfun"
  shows "f - f = 0"
  by (transfer, simp add: map_minus_def)

lemma pfun_minus_plus_commute:
  "pdom(g) \<inter> pdom(h) = {} \<Longrightarrow> (f - g) + h = (f + h) - g"
  by (transfer, simp add: map_minus_plus_commute)

lemma pfun_plus_minus:
  "f \<subseteq>\<^sub>p g \<Longrightarrow> (g - f) + f = g"
  by (transfer, rule ext, auto simp add: map_le_def map_minus_def map_add_def option.case_eq_if)

lemma pfun_minus_common_subset:
  "\<lbrakk> h \<subseteq>\<^sub>p f; h \<subseteq>\<^sub>p g \<rbrakk> \<Longrightarrow> (f - h = g - h) = (f = g)"
  by (transfer, simp add: map_minus_common_subset)

lemma pfun_minus_plus:
  "pdom(f) \<inter> pdom(g) = {} \<Longrightarrow> (f + g) - g = f"
  by (transfer, simp add: map_add_def map_minus_def option.case_eq_if, rule ext, auto)
     (metis Int_commute domIff insert_disjoint(1) insert_dom)

subsection {* Membership, application, and update *}

lemma pfun_ext: "\<lbrakk> \<And> x y. (x, y) \<in>\<^sub>p f \<longleftrightarrow> (x, y) \<in>\<^sub>p g \<rbrakk> \<Longrightarrow> f = g"
  by (transfer, simp add: map_ext)

lemma pfun_member_alt_def:
  "(x, y) \<in>\<^sub>p f \<longleftrightarrow> (x \<in> pdom f \<and> f(x)\<^sub>p = y)"
  by (transfer, auto simp add: map_member_alt_def map_apply_def)

lemma pfun_member_plus:
  "(x, y) \<in>\<^sub>p f + g \<longleftrightarrow> ((x \<notin> pdom(g) \<and> (x, y) \<in>\<^sub>p f) \<or> (x, y) \<in>\<^sub>p g)"
  by (transfer, simp add: map_member_plus)

lemma pfun_member_minus:
  "(x, y) \<in>\<^sub>p f - g \<longleftrightarrow> (x, y) \<in>\<^sub>p f \<and> (\<not> (x, y) \<in>\<^sub>p g)"
  by (transfer, simp add: map_member_minus)

lemma pfun_app_upd_1 [simp]: "x = y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>p)(y)\<^sub>p = v"
  by (transfer, simp)

lemma pfun_app_upd_2 [simp]: "x \<noteq> y \<Longrightarrow> (f(x \<mapsto> v)\<^sub>p)(y)\<^sub>p = f(y)\<^sub>p"
  by (transfer, simp)

lemma pfun_upd_add [simp]: "f + g(x \<mapsto> v)\<^sub>p = (f + g)(x \<mapsto> v)\<^sub>p"
  by (transfer, simp)

lemma pfun_upd_twice [simp]: "f(x \<mapsto> u, x \<mapsto> v)\<^sub>p = f(x \<mapsto> v)\<^sub>p"
  by (transfer, simp)

lemma pfun_upd_comm:
  assumes "x \<noteq> y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>p = f(x \<mapsto> v, y \<mapsto> u)\<^sub>p"
  using assms by (transfer, auto)

lemma pfun_upd_comm_linorder [simp]:
  fixes x y :: "'a :: linorder"
  assumes "x < y"
  shows "f(y \<mapsto> u, x \<mapsto> v)\<^sub>p = f(x \<mapsto> v, y \<mapsto> u)\<^sub>p"
  using assms by (transfer, auto)

lemma pfun_app_minus [simp]: "x \<notin> pdom g \<Longrightarrow> (f - g)(x)\<^sub>p = f(x)\<^sub>p"
  by (transfer, auto simp add: map_minus_def)

lemma pfun_app_empty [simp]: "{}\<^sub>p(x)\<^sub>p = undefined"
  by (transfer, simp)

lemma pfun_app_not_in_dom:
  "x \<notin> pdom(f) \<Longrightarrow> f(x)\<^sub>p = undefined"
  by (transfer, simp)

lemma pfun_upd_minus [simp]:
  "x \<notin> pdom g \<Longrightarrow> (f - g)(x \<mapsto> v)\<^sub>p = (f(x \<mapsto> v)\<^sub>p - g)"
  by (transfer, auto simp add: map_minus_def)

lemma pdom_member_minus_iff [simp]:
  "x \<notin> pdom g \<Longrightarrow> x \<in> pdom(f - g) \<longleftrightarrow> x \<in> pdom(f)"
  by (transfer, simp add: domIff map_minus_def)

lemma psubseteq_pfun_upd1 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>p g; x \<notin> pdom(g) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>p g(x \<mapsto> v)\<^sub>p"
  by (transfer, auto simp add: map_le_def dom_def)

lemma psubseteq_pfun_upd2 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>p g; x \<notin> pdom(f) \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>p g(x \<mapsto> v)\<^sub>p"
  by (transfer, auto simp add: map_le_def dom_def)

lemma psubseteq_pfun_upd3 [intro]:
  "\<lbrakk> f \<subseteq>\<^sub>p g; g(x)\<^sub>p = v \<rbrakk> \<Longrightarrow> f \<subseteq>\<^sub>p g(x \<mapsto> v)\<^sub>p"
  by (transfer, auto simp add: map_le_def dom_def)

lemma psubseteq_dom_subset:
  "f \<subseteq>\<^sub>p g \<Longrightarrow> pdom(f) \<subseteq> pdom(g)"
  by (transfer, auto simp add: map_le_def dom_def)

lemma psubseteq_ran_subset:
  "f \<subseteq>\<^sub>p g \<Longrightarrow> pran(f) \<subseteq> pran(g)"
  by (transfer, auto simp add: map_le_def dom_def ran_def, fastforce)

subsection {* Domain laws *}

lemma pdom_zero [simp]: "pdom 0 = {}"
  by (transfer, simp)

lemma pdom_pId_on [simp]: "pdom (pId_on A) = A"
  by (transfer, auto)

lemma pdom_plus [simp]: "pdom (f + g) = pdom f \<union> pdom g"
  by (transfer, auto)

lemma pdom_inter: "pdom (f \<inter>\<^sub>p g) \<subseteq> pdom f \<inter> pdom g"
  by (transfer, auto simp add: dom_def)

lemma pdom_comp [simp]: "pdom (g \<circ>\<^sub>p f) = pdom (f \<rhd>\<^sub>p pdom g)"
  by (transfer, auto simp add: ran_restrict_map_def)

lemma pdom_upd [simp]: "pdom (f(k \<mapsto> v)\<^sub>p) = insert k (pdom f)"
  by (transfer, simp)

lemma pdom_pdom_res [simp]: "pdom (A \<lhd>\<^sub>p f) = A \<inter> pdom(f)"
  by (transfer, auto)

lemma pdom_graph_pfun [simp]: "pdom (graph_pfun R) = Domain R"
  by (transfer, simp add: Domain_fst graph_map_dom)

lemma pdom_pran_res_finite [simp]:
  "finite (pdom f) \<Longrightarrow> finite (pdom (f \<rhd>\<^sub>p A))"
  by (transfer, auto)

lemma pdom_pfun_graph_finite [simp]:
  "finite (pdom f) \<Longrightarrow> finite (pfun_graph f)"
  by (transfer, simp add: finite_dom_graph)

subsection {* Range laws *}

lemma pran_zero [simp]: "pran 0 = {}"
  by (transfer, simp)

lemma pran_pId_on [simp]: "pran (pId_on A) = A"
  by (transfer, auto simp add: ran_def)

lemma pran_upd [simp]: "pran (f(k \<mapsto> v)\<^sub>p) = insert v (pran ((- {k}) \<lhd>\<^sub>p f))"
  by (transfer, auto simp add: ran_def restrict_map_def)

lemma pran_pran_res [simp]: "pran (f \<rhd>\<^sub>p A) = pran(f) \<inter> A"
  by (transfer, auto)

lemma pran_comp [simp]: "pran (g \<circ>\<^sub>p f) = pran (pran f \<lhd>\<^sub>p g)"
  by (transfer, auto simp add: ran_def restrict_map_def)

lemma pran_finite [simp]: "finite (pdom f) \<Longrightarrow> finite (pran f)"
  by (transfer, auto)

subsection {* Domain restriction laws *}

lemma pdom_res_zero [simp]: "A \<lhd>\<^sub>p {}\<^sub>p = {}\<^sub>p"
  by (transfer, auto)

lemma pdom_res_empty [simp]:
  "({} \<lhd>\<^sub>p f) = {}\<^sub>p"
  by (transfer, auto)

lemma pdom_res_UNIV [simp]: "UNIV \<lhd>\<^sub>p f = f"
  by (transfer, auto)

lemma pdom_res_alt_def: "A \<lhd>\<^sub>p f =  f \<circ>\<^sub>p pId_on A"
  by (transfer, rule ext, auto simp add: restrict_map_def)

lemma pdom_res_upd_in [simp]:
  "k \<in> A \<Longrightarrow> A \<lhd>\<^sub>p f(k \<mapsto> v)\<^sub>p = (A \<lhd>\<^sub>p f)(k \<mapsto> v)\<^sub>p"
  by (transfer, auto)

lemma pdom_res_upd_out [simp]:
  "k \<notin> A \<Longrightarrow> A \<lhd>\<^sub>p f(k \<mapsto> v)\<^sub>p = A \<lhd>\<^sub>p f"
  by (transfer, auto)

lemma pfun_pdom_antires_upd [simp]:
  "k \<in> A \<Longrightarrow> ((- A) \<lhd>\<^sub>p m)(k \<mapsto> v)\<^sub>p =  ((- (A - {k})) \<lhd>\<^sub>p m)(k \<mapsto> v)\<^sub>p"
  by (transfer, simp)

lemma pdom_antires_insert_notin [simp]:
  "k \<notin> pdom(f) \<Longrightarrow> (- insert k A) \<lhd>\<^sub>p f = (- A) \<lhd>\<^sub>p f"
  by (transfer, auto simp add: restrict_map_def)

lemma pdom_res_override [simp]: "A \<lhd>\<^sub>p (f + g) = (A \<lhd>\<^sub>p f) + (A \<lhd>\<^sub>p g)"
  by (simp add: pdom_res_alt_def pfun_override_dist_comp)

lemma pdom_res_minus [simp]: "A \<lhd>\<^sub>p (f - g) = (A \<lhd>\<^sub>p f) - g"
  by (transfer, auto simp add: map_minus_def restrict_map_def)

lemma pdom_res_swap: "(A \<lhd>\<^sub>p f) \<rhd>\<^sub>p B = A \<lhd>\<^sub>p (f \<rhd>\<^sub>p B)"
  by (transfer, auto simp add: restrict_map_def ran_restrict_map_def)

lemma pdom_res_twice [simp]: "A \<lhd>\<^sub>p (B \<lhd>\<^sub>p f) = (A \<inter> B) \<lhd>\<^sub>p f"
  by (transfer, auto simp add: Int_commute)

lemma pdom_res_comp [simp]: "A \<lhd>\<^sub>p (g \<circ>\<^sub>p f) =  g \<circ>\<^sub>p (A \<lhd>\<^sub>p f)"
  by (simp add: pdom_res_alt_def pfun_comp_assoc)

lemma pdom_res_apply [simp]:
  "x \<in> A \<Longrightarrow> (A \<lhd>\<^sub>p f)(x)\<^sub>p = f(x)\<^sub>p"
  by (transfer, auto)

subsection {* Range restriction laws *}

lemma pran_res_zero [simp]: "{}\<^sub>p \<rhd>\<^sub>p A = {}\<^sub>p"
  by (transfer, auto simp add: ran_restrict_map_def)

lemma pran_res_upd_1 [simp]: "v \<in> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>p \<rhd>\<^sub>p A = (f \<rhd>\<^sub>p A)(x \<mapsto> v)\<^sub>p"
  by (transfer, auto simp add: ran_restrict_map_def)

lemma pran_res_upd_2 [simp]: "v \<notin> A \<Longrightarrow> f(x \<mapsto> v)\<^sub>p \<rhd>\<^sub>p A = ((- {x}) \<lhd>\<^sub>p f) \<rhd>\<^sub>p A"
  by (transfer, auto simp add: ran_restrict_map_def)

lemma pran_res_alt_def: "f \<rhd>\<^sub>p A = pId_on A \<circ>\<^sub>p f"
  by (transfer, rule ext, auto simp add: ran_restrict_map_def)

lemma pran_res_override: "(f + g) \<rhd>\<^sub>p A \<subseteq>\<^sub>p (f \<rhd>\<^sub>p A) + (g \<rhd>\<^sub>p A)"
  apply (transfer, auto simp add: map_add_def ran_restrict_map_def map_le_def)
  apply (rename_tac f g A a y x)
  apply (case_tac "g a")
  apply (auto)
done

subsection {* Graph laws *}

lemma pfun_graph_inv: "graph_pfun (pfun_graph f) = f"
  by (transfer, simp)

lemma pfun_graph_zero: "pfun_graph 0 = {}"
  by (transfer, simp add: map_graph_def)

lemma pfun_graph_pId_on: "pfun_graph (pId_on A) = Id_on A"
  by (transfer, auto simp add: map_graph_def)

lemma pfun_graph_minus: "pfun_graph (f - g) = pfun_graph f - pfun_graph g"
  by (transfer, simp add: map_graph_minus)

lemma pfun_graph_inter: "pfun_graph (f \<inter>\<^sub>p g) = pfun_graph f \<inter> pfun_graph g"
  apply (transfer, auto simp add: map_graph_def)
  apply (metis option.discI)+
done

subsection {* Entries *}

lemma pfun_entries_empty [simp]: "pfun_entries {} f = {}\<^sub>p"
  by (transfer, simp)

lemma pfun_entries_apply_1 [simp]:
  "x \<in> d \<Longrightarrow> (pfun_entries d f)(x)\<^sub>p = f x"
  by (transfer, auto)

lemma pfun_entries_apply_2 [simp]:
  "x \<notin> d \<Longrightarrow> (pfun_entries d f)(x)\<^sub>p = undefined"
  by (transfer, auto)

subsection {* Summation *}

definition pfun_sum :: "('k, 'v::comm_monoid_add) pfun \<Rightarrow> 'v" where
"pfun_sum f = sum (pfun_app f) (pdom f)"

lemma pfun_sum_empty [simp]: "pfun_sum {}\<^sub>p = 0"
  by (simp add: pfun_sum_def)

lemma pfun_sum_upd_1:
  assumes "finite(pdom(m))" "k \<notin> pdom(m)"
  shows "pfun_sum (m(k \<mapsto> v)\<^sub>p) = pfun_sum m + v"
  by (simp_all add: pfun_sum_def assms, metis add.commute assms(2) pfun_app_upd_2 sum.cong)

lemma pfun_sums_upd_2:
  assumes "finite(pdom(m))"
  shows "pfun_sum (m(k \<mapsto> v)\<^sub>p) = pfun_sum ((- {k}) \<lhd>\<^sub>p m) + v"
proof (cases "k \<notin> pdom(m)")
  case True
  then show ?thesis
    by (simp add: pfun_sum_upd_1 assms)
next
  case False
  then show ?thesis
    using assms pfun_sum_upd_1[of "((- {k}) \<lhd>\<^sub>p m)" k v]
    by (simp add: pfun_sum_upd_1)
qed

lemma pfun_sum_dom_res_insert [simp]:
  assumes "x \<in> pdom f" "x \<notin> A" "finite A"
  shows "pfun_sum ((insert x A) \<lhd>\<^sub>p f) = f(x)\<^sub>p + pfun_sum (A \<lhd>\<^sub>p f)"
  using assms by (simp add: pfun_sum_def)

lemma pfun_sum_pdom_res:
  fixes f :: "('a,'b::ab_group_add) pfun"
  assumes "finite(pdom f)"
  shows "pfun_sum (A \<lhd>\<^sub>p f) = pfun_sum f - (pfun_sum ((- A) \<lhd>\<^sub>p f))"
proof -
  have 1:"A \<inter> pdom(f) = pdom(f) - (pdom(f) - A)"
    by (auto)
  show ?thesis
    apply (simp add: pfun_sum_def)
    apply (subst 1)
    apply (subst sum_diff)
    apply (auto simp add: sum_diff Diff_subset Int_commute boolean_algebra_class.diff_eq assms)
  done
qed

lemma pfun_sum_pdom_antires [simp]:
  fixes f :: "('a,'b::ab_group_add) pfun"
  assumes "finite(pdom f)"
  shows "pfun_sum ((- A) \<lhd>\<^sub>p f) = pfun_sum f - pfun_sum (A \<lhd>\<^sub>p f)"
  by (subst pfun_sum_pdom_res, simp_all add: assms)

text {* Hide implementation details for partial functions *}

lifting_update pfun.lifting
lifting_forget pfun.lifting

end


(*  Title:      ZF/Induct/ListN.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section {* Lists of n elements *}

theory ListN imports Main begin

text {*
  Inductive definition of lists of @{text n} elements; see
  @{cite "paulin-tlca"}.
*}

consts listn :: "i=>i"
inductive
  domains "listn(A)" \<subseteq> "nat \<times> list(A)"
  intros
    NilI: "<0,Nil> \<in> listn(A)"
    ConsI: "[| a \<in> A; <n,l> \<in> listn(A) |] ==> <succ(n), Cons(a,l)> \<in> listn(A)"
  type_intros nat_typechecks list.intros

lemma list_into_listn: "l \<in> list(A) ==> <length(l),l> \<in> listn(A)"
  by (induct set: list) (simp_all add: listn.intros)

lemma listn_iff: "<n,l> \<in> listn(A) \<longleftrightarrow> l \<in> list(A) & length(l)=n"
  apply (rule iffI)
   apply (erule listn.induct)
    apply auto
  apply (blast intro: list_into_listn)
  done

lemma listn_image_eq: "listn(A)``{n} = {l \<in> list(A). length(l)=n}"
  apply (rule equality_iffI)
  apply (simp add: listn_iff separation image_singleton_iff)
  done

lemma listn_mono: "A \<subseteq> B ==> listn(A) \<subseteq> listn(B)"
  apply (unfold listn.defs)
  apply (rule lfp_mono)
    apply (rule listn.bnd_mono)+
  apply (assumption | rule univ_mono Sigma_mono list_mono basic_monos)+
  done

lemma listn_append:
    "[| <n,l> \<in> listn(A); <n',l'> \<in> listn(A) |] ==> <n#+n', l@l'> \<in> listn(A)"
  apply (erule listn.induct)
   apply (frule listn.dom_subset [THEN subsetD])
   apply (simp_all add: listn.intros)
  done

inductive_cases
      Nil_listn_case: "<i,Nil> \<in> listn(A)"
  and Cons_listn_case: "<i,Cons(x,l)> \<in> listn(A)"

inductive_cases
      zero_listn_case: "<0,l> \<in> listn(A)"
  and succ_listn_case: "<succ(i),l> \<in> listn(A)"

end


theory
  IOAutomata
imports
  Main
begin

section{* Introduction *}

section{* Modelling I: The Synchronous Network Model *}

subsection{* Synchronous Network Systems *}

text {* A network basically is a directed graph without labeled edges. (p. 17) *}
locale network =
  fixes net :: "'v rel"
  assumes finNet: "finite net"
begin
  text {* Every node has a set of in-neighbors linking to it
          and out-neighbors it is linking to.*}
  definition innbrs :: "'v \<Rightarrow> 'v set"
    where "innbrs j \<equiv> {i . (i,j) \<in> net}"
  definition outnbrs :: "'v \<Rightarrow> 'v set"
    where "outnbrs i \<equiv> {j . (i,j) \<in> net}"

  definition nodes :: "'v set"
    where "nodes \<equiv> Domain net \<union> Range net"

  lemma finNbrs: "finite (innbrs i)" "finite (outnbrs i)"
    unfolding innbrs_def outnbrs_def
    using finNet by (induct set: finite, auto)

  lemma finNodes: "finite nodes"
    unfolding nodes_def
    using finNet by (induct set: finite, auto)

end

definition automorphism :: "'v rel \<Rightarrow> ('v \<Rightarrow> 'v) \<Rightarrow> bool"
where "automorphism g subst \<equiv>
    bij subst \<and> (\<forall> i j . (i,j) \<in> g \<longleftrightarrow> (subst i, subst j) \<in> g)"
    (* hier bin ich mir nicht sicher, ob ich das am 1.11. richtig verstand.
       -- 2012/11/02 ben *)

subsection{* Executions *}

text {* An @{text execution} is a series of process state assignments and
        process message assignments. (p. 20)*}
record ('v, 'states, 'm) execution =
    C :: "nat \<Rightarrow> 'v \<Rightarrow> 'states"          --"process states"
    N :: "nat \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> 'm option"  --"messages sent"
(* actually having upper case selector functions breaks isabelle's naming conventions..
   but lower case cs and ns are quite common variable names in expressions (and it
   would be annoying to tell isabelle not to confuse a local c and a global function c...)*)

text {* With respect to some process two executions are said to be
        @{text indistinguishable} iff the process has the same sequence of states and
        incoming messages. (p. 21) *}
definition indistinguishable
    :: "'v \<Rightarrow> ('v, 'states, 'm) execution \<Rightarrow> ('v, 'states, 'm) execution \<Rightarrow> bool"
  where "indistinguishable i ex1 ex2 \<equiv>
    \<forall> r . C ex1 r i = C ex2 r i \<and> N ex1 r i = N ex2 r i"

text {* Obviously (indistinguishable i) is an equivalence relation. *}
lemma indistinguishableEquiv:
  "reflp (indistinguishable i)  \<and> symp (indistinguishable i)  \<and> transp (indistinguishable i)"
by (auto simp add: indistinguishable_def reflp_def symp_def transp_def)

subsection{* Synchronous Network Systems cont. *}

type_synonym ('von, 'states, 'm) nodeMsg   = "'states \<Rightarrow>  'von \<Rightarrow> 'm option"
type_synonym ('vin, 'states, 'm) nodeTrans = "'states \<Rightarrow> ('vin \<Rightarrow> 'm option) \<Rightarrow> 'states"

locale ioanet =
  network net
  for   net :: "'v rel"
  +
  fixes start :: "'v \<Rightarrow> 'states set"
    and msg   :: "'v \<Rightarrow> 'states \<Rightarrow> 'v \<Rightarrow> 'm option"
    and trans :: "'v \<Rightarrow> 'states \<Rightarrow> ('v \<Rightarrow> 'm option) \<Rightarrow> 'states"
  assumes msg_typing : "(i,j)\<notin>net \<Longrightarrow> msg i s j = None"
    --{* the lack of a channel is modelled as a permanent None-signal.
         (deviates from Lynch to avoid strange typing constructions.. )*}

begin

  definition sys_sync_ex :: "('v, 'states, 'm) execution \<Rightarrow> bool"
    where "sys_sync_ex ex \<equiv>
     (\<forall> i . C ex 0 i \<in> start i)
    \<and> (\<forall>r . \<forall> i .
          (\<forall> j . N ex (r+1) i j \<noteq> None \<longrightarrow> N ex (r+1) i j = msg i (C ex r i) j )
         \<and> C ex (r+1) i = trans i (C ex r i) (\<lambda> j . N ex (r+1) j i))"

   lemma sys_sync_ex_induct: "sys_sync_ex ex \<Longrightarrow> P ex 0 \<Longrightarrow>
                                (\<forall> r . P ex r \<longrightarrow> P ex (Suc r)) \<Longrightarrow> \<forall> r . P ex r"
     unfolding sys_sync_ex_def
     proof (auto)
       fix r
       assume init: "P ex 0" and
              indStep: "\<forall>r. P ex r \<longrightarrow> P ex (Suc r)" and
              defInit: "\<forall>i. C ex 0 i \<in> start i" and
              defStep: "\<forall>r i. (\<forall>j. (\<exists>y. N ex (Suc r) i j = Some y) \<longrightarrow> N ex (Suc r) i j = msg i (C ex r i) j) \<and>
              C ex (Suc r) i = trans i (C ex r i) (\<lambda>j. N ex (Suc r) j i)"
       thus "P ex r" by (induct r, auto)
    qed

  lemma sys_sync_ex_transition_induct: "sys_sync_ex ex \<Longrightarrow> P (C ex 0 i) \<Longrightarrow>
                                (\<forall> r . P (C ex r i) \<longrightarrow> P (trans i (C ex r i) (\<lambda>j. N ex (Suc r) j i)))
                                  \<Longrightarrow> \<forall> r . P (C ex r i)"
     using sys_sync_ex_induct[of ex "\<lambda> ex r. P (C ex r i)"]
     unfolding sys_sync_ex_def by (auto)

  definition M :: "('v, 'states, 'm) execution \<Rightarrow> nat \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> 'm option"
    where "M ex r i j \<equiv>  msg i (C ex (r - 1) i) j"

  definition fake_msg_loss_oracle
      :: "('v, 'states, 'm) execution \<Rightarrow> nat \<Rightarrow> 'v \<Rightarrow> 'v \<Rightarrow> bool"
    where "fake_msg_loss_oracle ex r i j \<equiv>
      M ex r i j \<noteq> None \<and> N ex r i j = None"

  definition ex_elects_leader :: "('states \<Rightarrow> bool) \<Rightarrow> ('v, 'states, 'm) execution \<Rightarrow> bool"
    where "ex_elects_leader isLeader ex \<equiv>
      \<exists> i r . \<forall> j s . isLeader (C ex s j) \<longleftrightarrow> (i = j \<and> s > r)"

  definition node_has_program :: "'v
    \<Rightarrow> ('von, 'states, 'm) nodeMsg \<Rightarrow> ('vin, 'states, 'm) nodeTrans
    \<Rightarrow> ('v \<Rightarrow> 'von)                \<Rightarrow> ('v \<Rightarrow> 'vin)
    \<Rightarrow> bool"
    where "node_has_program i nMsg nTrans outMap inMap \<equiv>
      (\<forall> s .
          (\<forall> j \<in> outnbrs i . nMsg s (outMap j) = msg i s j)
       \<and>  (\<forall> j \<in> innbrs i . \<forall> asg1 asg2 . asg1 (inMap j) = asg2 j
                  \<longrightarrow>  nTrans s asg1 = trans i s asg2))"

  definition identical :: "'v \<Rightarrow> 'v \<Rightarrow> bool"
    where "identical i1 i2 \<equiv>
       (\<exists> (nMsg :: (nat, 'states, 'm) nodeMsg) (nTrans::(nat, 'states, 'm) nodeTrans)
          outMap1 inMap1 outMap2 inMap2 .
           node_has_program i1 nMsg nTrans outMap1 inMap1
        \<and>  node_has_program i2 nMsg nTrans outMap2 inMap2)"

  lemma every_node_has_a_program:
      "\<exists> (nMsg :: (nat, 'states, 'm) nodeMsg) (nTrans::(nat, 'states, 'm) nodeTrans)
          outMap inMap.
           node_has_program i nMsg nTrans outMap inMap"
    unfolding node_has_program_def
    sorry

  lemma identity_refl : "identical i i"
    unfolding identical_def
    using every_node_has_a_program by auto

end

section{* Leader Election in a Synchronous Ring *}

text{* bidirectional ring *}
definition ring :: "nat \<Rightarrow> nat rel"
  where "ring num \<equiv> {(i,j) . i < num \<and> j < num
                              \<and> (   (i = (j + 1) mod num)
                                  \<or> (j = (i + 1) mod num))}"

lemma ring_size: "ring n \<subseteq> {0..n} \<times> {0..n}"
  unfolding ring_def by auto

subsection{* The Problem *}

locale leader_election_synchronous_ring =
  ioanet net
  for   net :: "nat rel"
+
  fixes num :: "nat"
  assumes ring_not_empty: "num > 0"
  assumes ring_topology: "net = ring num"
begin
  primrec ring_pred :: "nat \<Rightarrow> nat"
  where "ring_pred 0 = num - 1"
      | "ring_pred (Suc n) = n"

  lemma ring_network: "network net"
    unfolding network_def ring_topology proof-
      have "finite ({0..num} \<times> {0..num})" by auto
      thus "finite (ring num)" using ring_size[of num] by (rule rev_finite_subset)
    qed

  lemma there_are_links: "(0, num - 1) \<in> net"
    unfolding ring_topology ring_def using ring_not_empty by auto

  lemma there_are_nodes: "nodes \<noteq> {}"
    using there_are_links unfolding nodes_def by auto

subsection{* Impossibility Result for Identical Processes *}

(*all_identical: "\<forall> i j . identical i j"*)

end

subsection{* A Basic Algorithm *}

record LCR_state =
  u :: nat
  send :: "nat option"
  status :: "bool"

locale leader_election_synchronous_ring_LCR =
  leader_election_synchronous_ring start msg trans
  for start :: "nat \<Rightarrow> LCR_state set"
   and msg  :: "nat \<Rightarrow> LCR_state \<Rightarrow> nat \<Rightarrow> nat option"
   and trans :: "nat \<Rightarrow> LCR_state \<Rightarrow> (nat \<Rightarrow> nat option) \<Rightarrow> LCR_state"
+ fixes UID :: "nat \<Rightarrow> nat"
  assumes
        uniqueId: "inj UID"
    and startD: "start i = { \<lparr> u = UID i, send = Some (UID i), status = False \<rparr> }"
    and msgD:   "msg i = (\<lambda> s n .
                            if n = ((i + 1) mod num)
                              then send s
                              else None)"
    and transD: "trans i = (\<lambda> s asg.
                             case (asg (ring_pred i)) of
                                None   \<Rightarrow>
                                      s \<lparr> send := None \<rparr>
                             |  Some v \<Rightarrow>
                                  if v > u s then
                                      s \<lparr> send := Some v \<rparr>
                                  else if v = u s then
                                      s \<lparr> send := None,
                                          status := True \<rparr>
                                  else
                                      s \<lparr> send := None \<rparr>)"
begin

lemma u_constant: "sys_sync_ex ex \<Longrightarrow> \<forall> r. u (C ex r i) = UID i"
  proof (rule sys_sync_ex_transition_induct[of ex "\<lambda> s . u s = UID i" i],
          simp, simp add: sys_sync_ex_def startD, clarify)
    fix r
    assume IV: "u (C ex r i) = UID i"
    have "\<And> x someAsg. u x = u (trans i x someAsg)" proof-
      fix x someAsg
      show "u x = u (trans i x someAsg)"
        unfolding transD
        by (cases "someAsg (ring_pred i) = None", auto)
    qed
    from this[of "C ex r i"] IV
      show "u (trans i (C ex r i) (\<lambda>j. N ex (Suc r) j i)) = UID i " by auto
  qed

definition uids :: "nat set"
  where "uids \<equiv> UID ` nodes"

lemma uids: "finite uids" "uids \<noteq> {}"
  unfolding uids_def using finNodes there_are_nodes by auto

definition u_max :: "nat"
  where "u_max \<equiv> Max uids"

lemma u_max: "u2 \<in> uids \<Longrightarrow> u2 \<le> u_max"
 unfolding u_max_def using uids by (auto)

definition i_max :: "nat"
  where "i_max \<equiv> THE i . i \<in> nodes \<and> UID i = u_max"

end

end


(*  Title:      WordInterval.thy
    Authors:    Julius Michaelis, Cornelius Diekmann
*)
theory WordInterval
imports Main
  "Word_Lib.Word_Lemmas"
begin

section\<open>WordInterval: Executable datatype for Machine Word Sets\<close>
text\<open>Stores ranges of machine words as interval. This has been proven quite efficient for
     IP Addresses.\<close>
(*NOTE: All algorithms here use a straight-forward implementation. There is a lot of room for
        improving the computation complexity, for example by making the WordInterval a balanced,
        sorted tree.*)

subsection\<open>Syntax\<close>
context
  notes [[typedef_overloaded]]
begin
  datatype ('a::len0) wordinterval = WordInterval
                                        "('a::len0) word" \<comment> \<open>start (inclusive)\<close>
                                        "('a::len0) word" \<comment> \<open>end (inclusive)\<close>
                                  | RangeUnion "'a wordinterval" "'a wordinterval"
end

subsection\<open>Semantics\<close>
  fun wordinterval_to_set :: "'a::len0 wordinterval \<Rightarrow> ('a::len0 word) set"
  where
    "wordinterval_to_set (WordInterval start end) =
        {start .. end}" |
    "wordinterval_to_set (RangeUnion r1 r2) =
        wordinterval_to_set r1 \<union> wordinterval_to_set r2"

(*Note: The runtime of all the operations could be improved, for example by keeping the tree sorted
  and balanced.*)

subsection\<open>Basic operations\<close>
  text\<open>\<open>\<in>\<close>\<close>
  fun wordinterval_element :: "'a::len0 word \<Rightarrow> 'a::len0 wordinterval \<Rightarrow> bool" where
    "wordinterval_element el (WordInterval s e) \<longleftrightarrow> s \<le> el \<and> el \<le> e" |
    "wordinterval_element el (RangeUnion r1 r2) \<longleftrightarrow>
                                            wordinterval_element el r1 \<or> wordinterval_element el r2"
  lemma wordinterval_element_set_eq[simp]:
    "wordinterval_element el rg = (el \<in> wordinterval_to_set rg)"
    by(induction rg rule: wordinterval_element.induct) simp_all

  definition wordinterval_union
    :: "'a::len0 wordinterval \<Rightarrow> 'a::len0 wordinterval \<Rightarrow> 'a::len0 wordinterval" where
    "wordinterval_union r1 r2 = RangeUnion r1 r2"

  fun wordinterval_empty :: "'a::len0 wordinterval \<Rightarrow> bool" where
    "wordinterval_empty (WordInterval s e) \<longleftrightarrow> e < s" |
    "wordinterval_empty (RangeUnion r1 r2) \<longleftrightarrow> wordinterval_empty r1 \<and> wordinterval_empty r2"
  lemma wordinterval_empty_set_eq[simp]: "wordinterval_empty r \<longleftrightarrow> wordinterval_to_set r = {}"
    by(induction r) auto

  definition Empty_WordInterval :: "'a::len wordinterval" where
    "Empty_WordInterval \<equiv> WordInterval 1 0"
  lemma wordinterval_empty_Empty_WordInterval: "wordinterval_empty Empty_WordInterval"
    by(simp add: Empty_WordInterval_def)
  lemma Empty_WordInterval_set_eq[simp]: "wordinterval_to_set Empty_WordInterval = {}"
    by(simp add: Empty_WordInterval_def)

subsection\<open>WordInterval and Lists\<close>
  text\<open>A list of \<open>(start, end)\<close> tuples.\<close>

  text\<open>wordinterval to list\<close>
  fun wi2l :: "'a::len0 wordinterval \<Rightarrow> ('a::len0 word \<times> 'a::len0 word) list" where
    "wi2l (RangeUnion r1 r2) = wi2l r1 @ wi2l r2" |
    "wi2l (WordInterval s e) = (if e < s then [] else [(s,e)])"

  text\<open>list to wordinterval\<close>
  fun l2wi :: "('a::len word \<times> 'a word) list \<Rightarrow> 'a wordinterval" where
    "l2wi [] = Empty_WordInterval" |
    "l2wi [(s,e)] = (WordInterval s e)" |
    "l2wi ((s,e)#rs) = (RangeUnion (WordInterval s e) (l2wi rs))"

  lemma l2wi_append: "wordinterval_to_set (l2wi (l1@l2)) =
                      wordinterval_to_set (l2wi l1) \<union> wordinterval_to_set (l2wi l2)"
    proof(induction l1 arbitrary: l2 rule:l2wi.induct)
    case 1 thus ?case by simp
    next
    case (2 s e l2) thus ?case by (cases l2) simp_all
    next
    case 3 thus ?case by force
    qed

  lemma l2wi_wi2l[simp]: "wordinterval_to_set (l2wi (wi2l r)) = wordinterval_to_set r"
    by(induction r) (simp_all add: l2wi_append)

  lemma l2wi: "wordinterval_to_set (l2wi l) = (\<Union> (i,j) \<in> set l. {i .. j})"
    by(induction l rule: l2wi.induct, simp_all)

  lemma wi2l: "(\<Union>(i,j)\<in>set (wi2l r). {i .. j}) = wordinterval_to_set r"
    by(induction r rule: wi2l.induct, simp_all)

  lemma l2wi_remdups[simp]: "wordinterval_to_set (l2wi (remdups ls)) = wordinterval_to_set (l2wi ls)"
    by(simp add: l2wi)

  lemma wi2l_empty[simp]: "wi2l Empty_WordInterval = []"
    unfolding Empty_WordInterval_def
    by simp

subsection\<open>Optimizing and minimizing @{typ "('a::len) wordinterval"}s\<close>
text\<open>Removing empty intervals\<close>
context
begin
  fun wordinterval_optimize_empty :: "'a::len0 wordinterval \<Rightarrow> 'a wordinterval" where
    "wordinterval_optimize_empty (RangeUnion r1 r2) = (let r1o = wordinterval_optimize_empty r1;
                                                           r2o = wordinterval_optimize_empty r2
      in if
        wordinterval_empty r1o
      then
        r2o
      else if
        wordinterval_empty r2o
      then
        r1o
      else
        RangeUnion r1o r2o)" |
    "wordinterval_optimize_empty r = r"
  lemma wordinterval_optimize_empty_set_eq[simp]:
    "wordinterval_to_set (wordinterval_optimize_empty r) = wordinterval_to_set r"
    by(induction r) (simp_all add: Let_def)

  lemma wordinterval_optimize_empty_double:
    "wordinterval_optimize_empty (wordinterval_optimize_empty r) = wordinterval_optimize_empty r"
    by(induction r) (simp_all add: Let_def)

  private fun wordinterval_empty_shallow :: "'a::len0 wordinterval \<Rightarrow> bool"  where
    "wordinterval_empty_shallow (WordInterval s e) \<longleftrightarrow> e < s" |
    "wordinterval_empty_shallow (RangeUnion _ _) \<longleftrightarrow> False"
  private lemma helper_optimize_shallow:
    "wordinterval_empty_shallow (wordinterval_optimize_empty r) =
      wordinterval_empty (wordinterval_optimize_empty r)"
    by(induction r) fastforce+
  private fun wordinterval_optimize_empty2 where
    "wordinterval_optimize_empty2 (RangeUnion r1 r2) = (let r1o = wordinterval_optimize_empty r1;
                                                            r2o = wordinterval_optimize_empty r2
      in if
        wordinterval_empty_shallow r1o
      then
        r2o
      else if
        wordinterval_empty_shallow r2o
      then
        r1o
      else
        RangeUnion r1o r2o)" |
    "wordinterval_optimize_empty2 r = r"
  lemma wordinterval_optimize_empty_code[code_unfold]:
    "wordinterval_optimize_empty = wordinterval_optimize_empty2"
    by (subst fun_eq_iff, clarify, rename_tac r, induct_tac r)
       (unfold wordinterval_optimize_empty.simps wordinterval_optimize_empty2.simps
               Let_def helper_optimize_shallow, simp_all)
end

text\<open>Merging overlapping intervals\<close>
context
begin

  private definition disjoint :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
    "disjoint A B \<equiv> A \<inter> B = {}"

  private primrec interval_of :: "('a::len0) word \<times> 'a word \<Rightarrow> 'a word set" where
    "interval_of (s,e) = {s .. e}"
  declare interval_of.simps[simp del]

  private definition disjoint_intervals
    :: "(('a::len0) word \<times> ('a::len0) word) \<Rightarrow> ('a word \<times> 'a word) \<Rightarrow> bool"
  where
    "disjoint_intervals A B \<equiv> disjoint (interval_of A) (interval_of B)"

  private definition not_disjoint_intervals
    :: "(('a::len0) word \<times> ('a::len0) word) \<Rightarrow> ('a word \<times> 'a word) \<Rightarrow> bool"
  where
    "not_disjoint_intervals A B \<equiv> \<not> disjoint (interval_of A) (interval_of B)"

  private

  private lemma [code]:
    "disjoint_intervals A B =
      (case A of (s,e) \<Rightarrow> case B of (s',e') \<Rightarrow> s > e' \<or> s' > e \<or> s > e \<or> s' > e')"
    apply(cases A, cases B)
    apply(simp add: disjoint_intervals_def interval_of.simps disjoint_def)
    by fastforce

  text\<open>BEGIN merging overlapping intervals\<close>
  (*result has no empty intervals and all are disjoint.
    merging things such as [1,7] [8,10] would still be possible*)
  private fun merge_overlap
    :: "(('a::len0) word \<times> ('a::len0) word) \<Rightarrow> ('a word \<times> 'a word) list \<Rightarrow> ('a word \<times> 'a word) list"
  where
    "merge_overlap s [] = [s]" |
    "merge_overlap (s,e) ((s',e')#ss) = (
       if not_disjoint_intervals (s,e) (s',e')
       then (min s s', max e e')#ss
       else (s',e')#merge_overlap (s,e) ss)"

  private lemma not_disjoint_union:
      fixes s :: "('a::len0) word"
      shows "\<not> disjoint {s..e} {s'..e'} \<Longrightarrow> {s..e} \<union> {s'..e'} = {min s s' .. max e e'}"
    by(auto simp add: disjoint_def min_def max_def)

  private lemma disjoint_subset: "disjoint A B \<Longrightarrow> A \<subseteq> B \<union> C \<Longrightarrow> A \<subseteq> C"
    unfolding disjoint_def
    by blast

  private lemma merge_overlap_helper1: "interval_of A \<subseteq> (\<Union>s \<in> set ss. interval_of s) \<Longrightarrow>
      (\<Union>s \<in> set (merge_overlap A ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
    apply(induction ss)
     apply(simp; fail)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add: not_disjoint_intervals_def interval_of.simps)
    apply(intro impI conjI)
     apply(drule not_disjoint_union)
     apply blast
    apply(drule_tac C="(\<Union>x\<in>set xs. interval_of x)" in disjoint_subset)
     apply(simp_all)
    done

  private lemma merge_overlap_helper2: "\<exists>s'\<in>set ss. \<not> disjoint (interval_of A) (interval_of s') \<Longrightarrow>
          interval_of A \<union> (\<Union>s \<in> set ss. interval_of s) = (\<Union>s \<in> set (merge_overlap A ss). interval_of s)"
    apply(induction ss)
     apply(simp; fail)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add: not_disjoint_intervals_def interval_of.simps)
    apply(intro impI conjI)
     apply(drule not_disjoint_union)
     apply blast
    apply(simp)
    by blast

  private lemma merge_overlap_length:
    "\<exists>s' \<in> set ss. \<not> disjoint (interval_of A) (interval_of s') \<Longrightarrow>
      length (merge_overlap A ss) = length ss"
    apply(induction ss)
     apply(simp)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add: not_disjoint_intervals_def interval_of.simps)
    done

  lemma "merge_overlap (1:: 16 word,2) [(1, 7)] = [(1, 7)]" by eval
  lemma "merge_overlap (1:: 16 word,2) [(2, 7)] = [(1, 7)]" by eval
  lemma "merge_overlap (1:: 16 word,2) [(3, 7)] = [(3, 7), (1,2)]" by eval

  private function listwordinterval_compress
    :: "(('a::len0) word \<times> ('a::len0) word) list \<Rightarrow> ('a word \<times> 'a word) list" where
    "listwordinterval_compress [] = []" |
    "listwordinterval_compress (s#ss) = (
            if \<forall>s' \<in> set ss. disjoint_intervals s s'
            then s#listwordinterval_compress ss
            else listwordinterval_compress (merge_overlap s ss))"
  by(pat_completeness, auto)

  private termination listwordinterval_compress
  apply (relation "measure length")
    apply(rule wf_measure)
   apply(simp)
  using disjoint_intervals_def merge_overlap_length by fastforce

  private lemma listwordinterval_compress:
    "(\<Union>s \<in> set (listwordinterval_compress ss). interval_of s) = (\<Union>s \<in> set ss. interval_of s)"
    apply(induction ss rule: listwordinterval_compress.induct)
     apply(simp)
    apply(simp)
    apply(intro impI)
    apply(simp add: disjoint_intervals_def)
    apply(drule merge_overlap_helper2)
    apply(simp)
    done

  lemma "listwordinterval_compress [(1::32 word,3), (8,10), (2,5), (3,7)] = [(8, 10), (1, 7)]"
    by eval

  private lemma A_in_listwordinterval_compress: "A \<in> set (listwordinterval_compress ss) \<Longrightarrow>
    interval_of A \<subseteq> (\<Union>s \<in> set ss. interval_of s)"
    using listwordinterval_compress by blast

  private lemma listwordinterval_compress_disjoint:
    "A \<in> set (listwordinterval_compress ss) \<Longrightarrow> B \<in> set (listwordinterval_compress ss) \<Longrightarrow>
      A \<noteq> B \<Longrightarrow> disjoint (interval_of A) (interval_of B)"
    apply(induction ss arbitrary: rule: listwordinterval_compress.induct)
     apply(simp)
    apply(simp split: if_split_asm)
    apply(elim disjE)
       apply(simp_all)
     apply(simp_all add: disjoint_intervals_def disjoint_def)
     apply(thin_tac [!] "False \<Longrightarrow> _ \<Longrightarrow> _ \<Longrightarrow> _")
     apply(blast dest: A_in_listwordinterval_compress)+
    done
  text\<open>END merging overlapping intervals\<close>

  text\<open>BEGIN merging adjacent intervals\<close>
  private fun merge_adjacent
    :: "(('a::len) word \<times> ('a::len) word) \<Rightarrow> ('a word \<times> 'a word) list \<Rightarrow> ('a word \<times> 'a word) list"
  where
    "merge_adjacent s [] = [s]" |
    "merge_adjacent (s,e) ((s',e')#ss) = (
       if s \<le>e \<and> s' \<le> e' \<and> word_next e = s'
       then (s, e')#ss
       else if s \<le>e \<and> s' \<le> e' \<and> word_next e' = s
       then (s', e)#ss
       else (s',e')#merge_adjacent (s,e) ss)"

  private lemma merge_adjacent_helper:
  "interval_of A \<union> (\<Union>s \<in> set ss. interval_of s) = (\<Union>s \<in> set (merge_adjacent A ss). interval_of s)"
    apply(induction ss)
     apply(simp; fail)
    apply(rename_tac x xs)
    apply(cases A, rename_tac a b)
    apply(case_tac x)
    apply(simp add:  interval_of.simps)
    apply(intro impI conjI)
       apply (metis Un_assoc word_adjacent_union)
      apply(elim conjE)
      apply(drule(2) word_adjacent_union)
      subgoal by (blast)
     subgoal by (metis word_adjacent_union Un_assoc)
    by blast

  private lemma merge_adjacent_length:
    "\<exists>(s', e')\<in>set ss. s \<le> e \<and> s' \<le> e' \<and> (word_next e = s' \<or> word_next e' = s)
     \<Longrightarrow> length (merge_adjacent (s,e) ss) = length ss"
    apply(induction ss)
     apply(simp)
    apply(rename_tac x xs)
    apply(case_tac x)
    apply(simp add: )
    by blast

  private function listwordinterval_adjacent
    :: "(('a::len) word \<times> ('a::len) word) list \<Rightarrow> ('a word \<times> 'a word) list" where
    "listwordinterval_adjacent [] = []" |
    "listwordinterval_adjacent ((s,e)#ss) = (
            if \<forall>(s',e') \<in> set ss. \<not> (s \<le>e \<and> s' \<le> e' \<and> (word_next e = s' \<or> word_next e' = s))
            then (s,e)#listwordinterval_adjacent ss
            else listwordinterval_adjacent (merge_adjacent (s,e) ss))"
  by(pat_completeness, auto)

  private termination listwordinterval_adjacent
  apply (relation "measure length")
    apply(rule wf_measure)
   apply(simp)
  apply(simp)
  using merge_adjacent_length by fastforce

  private

  lemma "listwordinterval_adjacent [(1::16 word, 3), (5, 10), (10,10), (4,4)] = [(10, 10), (1, 10)]"
    by eval
  text\<open>END merging adjacent intervals\<close>

  definition wordinterval_compress :: "('a::len) wordinterval \<Rightarrow> 'a wordinterval" where
    "wordinterval_compress r \<equiv>
      l2wi (remdups (listwordinterval_adjacent (listwordinterval_compress
        (wi2l (wordinterval_optimize_empty r)))))"

  text\<open>Correctness: Compression preserves semantics\<close>
  lemma wordinterval_compress:
    "wordinterval_to_set (wordinterval_compress r) = wordinterval_to_set r"
    unfolding wordinterval_compress_def
    proof -
      have interval_of': "interval_of s = (case s of (s,e) \<Rightarrow> {s .. e})" for s
        by (cases s) (simp add: interval_of.simps)

      have "wordinterval_to_set (l2wi (remdups (listwordinterval_adjacent
              (listwordinterval_compress (wi2l (wordinterval_optimize_empty r)))))) =
            (\<Union>x\<in>set (listwordinterval_adjacent (listwordinterval_compress
                (wi2l (wordinterval_optimize_empty r)))). interval_of x)"
        by (force simp: interval_of' l2wi)
      also have "\<dots> =  (\<Union>s\<in>set (wi2l (wordinterval_optimize_empty r)). interval_of s)"
        by(simp add: listwordinterval_compress listwordinterval_adjacent)
      also have "\<dots> = (\<Union>(i, j)\<in>set (wi2l (wordinterval_optimize_empty r)). {i..j})"
        by(simp add: interval_of')
      also have "\<dots> = wordinterval_to_set r" by(simp add: wi2l)
      finally show "wordinterval_to_set
        (l2wi (remdups (listwordinterval_adjacent (listwordinterval_compress
            (wi2l (wordinterval_optimize_empty r))))))
          = wordinterval_to_set r" .
  qed

end

text\<open>Example\<close>
lemma "(wi2l \<circ> (wordinterval_compress :: 32 wordinterval \<Rightarrow> 32 wordinterval) \<circ> l2wi)
          [(70, 80001), (0,0), (150, 8000), (1,3), (42,41), (3,7), (56, 200), (8,10)] =
          [(56, 80001), (0, 10)]" by eval

lemma "wordinterval_compress (RangeUnion (RangeUnion (WordInterval (1::32 word) 5)
                                                        (WordInterval 8 10)) (WordInterval 3 7)) =
       WordInterval 1 10" by eval

subsection\<open>Further operations\<close>

  text\<open>\<open>\<Union>\<close>\<close>
  definition wordinterval_Union :: "('a::len) wordinterval list \<Rightarrow> 'a wordinterval" where
    "wordinterval_Union ws = wordinterval_compress (foldr wordinterval_union ws Empty_WordInterval)"

  lemma wordinterval_Union:
    "wordinterval_to_set (wordinterval_Union ws) = (\<Union> w \<in> (set ws). wordinterval_to_set w)"
    by(induction ws) (simp_all add: wordinterval_compress wordinterval_Union_def)

context
begin
  private fun wordinterval_setminus'
    :: "'a::len wordinterval \<Rightarrow> 'a wordinterval \<Rightarrow> 'a wordinterval" where
    "wordinterval_setminus' (WordInterval s e) (WordInterval ms me) = (
      if s > e \<or> ms > me then WordInterval s e else
      if me \<ge> e
        then
          WordInterval (if ms = 0 then 1 else s) (min e (word_prev ms))
        else if ms \<le> s
        then
          WordInterval (max s (word_next me)) (if me = max_word then 0 else e)
        else
          RangeUnion (WordInterval (if ms = 0 then 1 else s) (word_prev ms))
                     (WordInterval (word_next me) (if me = max_word then 0 else e))
        )" |
     "wordinterval_setminus' (RangeUnion r1 r2) t =
        RangeUnion (wordinterval_setminus' r1 t) (wordinterval_setminus' r2 t)"|
     "wordinterval_setminus' t (RangeUnion r1 r2) =
        wordinterval_setminus' (wordinterval_setminus' t r1) r2"

  private lemma wordinterval_setminus'_rr_set_eq:
    "wordinterval_to_set(wordinterval_setminus' (WordInterval s e) (WordInterval ms me)) =
    wordinterval_to_set (WordInterval s e) - wordinterval_to_set (WordInterval ms me)"
     apply(simp only: wordinterval_setminus'.simps)
     apply(case_tac "e < s")
      apply simp
     apply(case_tac "me < ms")
      apply simp
     apply(case_tac [!] "e \<le> me")
      apply(case_tac [!] "ms = 0")
        apply(case_tac [!] "ms \<le> s")
            apply(case_tac [!] "me = max_word")
                    apply(simp_all add: word_prev_def word_next_def min_def max_def)
            apply(safe)
                                  apply(auto)
                          apply(uint_arith)
                         apply(uint_arith)
                        apply(uint_arith)
                       apply(uint_arith)
                      apply(uint_arith)
                     apply(uint_arith)
                    apply(uint_arith)
                   apply(uint_arith)
                  apply(uint_arith)
                 apply(uint_arith)
                apply(uint_arith)
               apply(uint_arith)
              apply(uint_arith)
             apply(uint_arith)
            apply(uint_arith)
           apply(uint_arith)
          apply(uint_arith)
         apply(uint_arith)
        apply(uint_arith)
       apply(uint_arith)
      apply(uint_arith)
     apply(uint_arith)
   done

  private lemma wordinterval_setminus'_set_eq:
    "wordinterval_to_set (wordinterval_setminus' r1 r2) =
      wordinterval_to_set r1 - wordinterval_to_set r2"
    apply(induction rule: wordinterval_setminus'.induct)
      using wordinterval_setminus'_rr_set_eq apply blast
     apply auto
    done
  lemma wordinterval_setminus'_empty_struct:
    "wordinterval_empty r2 \<Longrightarrow> wordinterval_setminus' r1 r2 = r1"
    by(induction r1 r2 rule: wordinterval_setminus'.induct) auto

  definition wordinterval_setminus
    :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
    "wordinterval_setminus r1 r2 = wordinterval_compress (wordinterval_setminus' r1 r2)"

  lemma wordinterval_setminus_set_eq[simp]: "wordinterval_to_set (wordinterval_setminus r1 r2) =
    wordinterval_to_set r1 - wordinterval_to_set r2"
    by(simp add: wordinterval_setminus_def wordinterval_compress wordinterval_setminus'_set_eq)
end

definition wordinterval_UNIV :: "'a::len wordinterval" where
  "wordinterval_UNIV \<equiv> WordInterval 0 max_word"
lemma wordinterval_UNIV_set_eq[simp]: "wordinterval_to_set wordinterval_UNIV = UNIV"
  unfolding wordinterval_UNIV_def
  using max_word_max by fastforce

fun wordinterval_invert :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
  "wordinterval_invert r = wordinterval_setminus wordinterval_UNIV r"
lemma wordinterval_invert_set_eq[simp]:
  "wordinterval_to_set (wordinterval_invert r) = UNIV - wordinterval_to_set r" by(auto)

lemma wordinterval_invert_UNIV_empty:
  "wordinterval_empty (wordinterval_invert wordinterval_UNIV)" by simp

lemma wi2l_univ[simp]: "wi2l wordinterval_UNIV = [(0, max_word)]"
  unfolding wordinterval_UNIV_def
  by simp

text\<open>\<open>\<inter>\<close>\<close>
context
begin
  private lemma "{(s::nat) .. e} \<inter> {s' .. e'} = {} \<longleftrightarrow> s > e' \<or> s' > e \<or> s > e \<or> s' > e'"
    by simp linarith
  private fun wordinterval_intersection'
    :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
    "wordinterval_intersection' (WordInterval s e) (WordInterval s' e') = (
        if s > e \<or> s' > e' \<or> s > e' \<or> s' > e \<or> s > e \<or> s' > e'
        then
          Empty_WordInterval
        else
          WordInterval (max s s') (min e e')
        )" |
    "wordinterval_intersection' (RangeUnion r1 r2) t =
        RangeUnion (wordinterval_intersection' r1 t) (wordinterval_intersection' r2 t)"|
    "wordinterval_intersection' t (RangeUnion r1 r2) =
        RangeUnion (wordinterval_intersection' t r1) (wordinterval_intersection' t r2)"

  private lemma wordinterval_intersection'_set_eq:
    "wordinterval_to_set (wordinterval_intersection' r1 r2) =
      wordinterval_to_set r1 \<inter> wordinterval_to_set r2"
    by(induction r1 r2 rule: wordinterval_intersection'.induct) (auto)

  lemma "wordinterval_intersection'
          (RangeUnion (RangeUnion (WordInterval (1::32 word) 3) (WordInterval 8 10))
                      (WordInterval 1 3)) (WordInterval 1 3) =
          RangeUnion (RangeUnion (WordInterval 1 3) (WordInterval 1 0)) (WordInterval 1 3)" by eval

  definition wordinterval_intersection
    :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> 'a::len wordinterval" where
    "wordinterval_intersection r1 r2 \<equiv> wordinterval_compress (wordinterval_intersection' r1 r2)"

  lemma wordinterval_intersection_set_eq[simp]:
    "wordinterval_to_set (wordinterval_intersection r1 r2) =
      wordinterval_to_set r1 \<inter> wordinterval_to_set r2"
    by(simp add: wordinterval_intersection_def
                 wordinterval_compress wordinterval_intersection'_set_eq)

  lemma "wordinterval_intersection
          (RangeUnion (RangeUnion (WordInterval (1::32 word) 3) (WordInterval 8 10))
                      (WordInterval 1 3)) (WordInterval 1 3) =
          WordInterval 1 3" by eval
end

definition wordinterval_subset :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
  "wordinterval_subset r1 r2 \<equiv> wordinterval_empty (wordinterval_setminus r1 r2)"
lemma wordinterval_subset_set_eq[simp]:
  "wordinterval_subset r1 r2 = (wordinterval_to_set r1 \<subseteq> wordinterval_to_set r2)"
  unfolding wordinterval_subset_def by simp

definition wordinterval_eq :: "'a::len wordinterval \<Rightarrow> 'a::len wordinterval \<Rightarrow> bool" where
  "wordinterval_eq r1 r2 = (wordinterval_subset r1 r2 \<and> wordinterval_subset r2 r1)"
lemma wordinterval_eq_set_eq:
  "wordinterval_eq r1 r2 \<longleftrightarrow> wordinterval_to_set r1 = wordinterval_to_set r2"
  unfolding wordinterval_eq_def by auto

thm iffD1[OF wordinterval_eq_set_eq]
(*declare iffD1[OF wordinterval_eq_set_eq, simp]*)

lemma wordinterval_eq_comm: "wordinterval_eq r1 r2 \<longleftrightarrow> wordinterval_eq r2 r1"
  unfolding wordinterval_eq_def by fast
lemma wordinterval_to_set_alt: "wordinterval_to_set r = {x. wordinterval_element x r}"
  unfolding wordinterval_element_set_eq by blast

lemma wordinterval_un_empty:
  "wordinterval_empty r1 \<Longrightarrow> wordinterval_eq (wordinterval_union r1 r2) r2"
  by(subst wordinterval_eq_set_eq, simp)
lemma wordinterval_un_emty_b:
  "wordinterval_empty r2 \<Longrightarrow> wordinterval_eq (wordinterval_union r1 r2) r1"
  by(subst wordinterval_eq_set_eq, simp)

lemma wordinterval_Diff_triv:
  "wordinterval_empty (wordinterval_intersection a b) \<Longrightarrow> wordinterval_eq (wordinterval_setminus a b) a"
  unfolding wordinterval_eq_set_eq
  by simp blast

text\<open>A size of the datatype, does not correspond to the cardinality of the corresponding set\<close>
fun wordinterval_size :: "('a::len) wordinterval \<Rightarrow> nat" where
  "wordinterval_size (RangeUnion a b) = wordinterval_size a + wordinterval_size b" |
  "wordinterval_size (WordInterval s e) = (if s \<le> e then 1 else 0)"

lemma wordinterval_size_length: "wordinterval_size r = length (wi2l r)"
  by(induction r) (auto)

lemma Ex_wordinterval_nonempty: "\<exists>x::('a::len wordinterval). y \<in> wordinterval_to_set x"
  proof show "y \<in> wordinterval_to_set wordinterval_UNIV" by simp qed

lemma wordinterval_eq_reflp:
  "reflp wordinterval_eq"
  apply(rule reflpI)
  by(simp only: wordinterval_eq_set_eq)
lemma wordintervalt_eq_symp:
  "symp wordinterval_eq"
  apply(rule sympI)
  by(simp add: wordinterval_eq_comm)
lemma wordinterval_eq_transp:
  "transp wordinterval_eq"
  apply(rule transpI)
  by(simp only: wordinterval_eq_set_eq)

lemma wordinterval_eq_equivp:
  "equivp wordinterval_eq"
  by (auto intro: equivpI wordinterval_eq_reflp wordintervalt_eq_symp wordinterval_eq_transp)

text\<open>The smallest element in the interval\<close>
  definition is_lowest_element :: "'a::ord \<Rightarrow> 'a set \<Rightarrow> bool" where
    "is_lowest_element x S = (x \<in> S \<and> (\<forall>y\<in>S. y \<le> x \<longrightarrow> y = x))"

  lemma
  	fixes x :: "'a :: complete_lattice"
  	assumes "x \<in> S"
  	shows " x = Inf S \<Longrightarrow> is_lowest_element x S"
  using assms apply(simp add: is_lowest_element_def)
   by (simp add: Inf_lower eq_iff)

  lemma
  	fixes x :: "'a :: linorder"
  	assumes "finite S" and "x \<in> S"
  	shows "is_lowest_element x S \<longleftrightarrow> x = Min S"
  apply(rule)
  subgoal
   apply(simp add: is_lowest_element_def)
   apply(subst Min_eqI[symmetric])
   using assms by(auto)
  by (metis Min.coboundedI assms(1) assms(2) dual_order.antisym is_lowest_element_def)

text\<open>Smallest element in the interval\<close>
  fun wordinterval_lowest_element :: "'a::len0 wordinterval \<Rightarrow> 'a word option" where
    "wordinterval_lowest_element (WordInterval s e) = (if s \<le> e then Some s else None)" |
    "wordinterval_lowest_element (RangeUnion A B) =
      (case (wordinterval_lowest_element A, wordinterval_lowest_element B) of
          (Some a, Some b) \<Rightarrow> Some (if a < b then a else b) |
          (None, Some b) \<Rightarrow> Some b |
          (Some a, None) \<Rightarrow> Some a |
          (None, None) \<Rightarrow> None)"

  lemma wordinterval_lowest_none_empty: "wordinterval_lowest_element r = None \<longleftrightarrow> wordinterval_empty r"
    proof(induction r)
    case WordInterval thus ?case by simp
    next
    case RangeUnion thus ?case by fastforce
    qed

  lemma wordinterval_lowest_element_correct_A:
    "wordinterval_lowest_element r = Some x \<Longrightarrow> is_lowest_element x (wordinterval_to_set r)"
    unfolding is_lowest_element_def
    apply(induction r arbitrary: x rule: wordinterval_lowest_element.induct)
     apply(rename_tac rs re x, case_tac "rs \<le> re", auto)[1]
    apply(subst(asm) wordinterval_lowest_element.simps(2))
    apply(rename_tac A B x)
    apply(case_tac     "wordinterval_lowest_element B")
     apply(case_tac[!] "wordinterval_lowest_element A")
       apply(simp_all add: wordinterval_lowest_none_empty)[3]
    apply fastforce
  done

  lemma wordinterval_lowest_element_set_eq: assumes "\<not> wordinterval_empty r"
    shows "(wordinterval_lowest_element r = Some x) = (is_lowest_element x (wordinterval_to_set r))"
    (*unfolding is_lowest_element_def*)
    proof(rule iffI)
      assume "wordinterval_lowest_element r = Some x"
      thus "is_lowest_element x (wordinterval_to_set r)"
     using wordinterval_lowest_element_correct_A wordinterval_lowest_none_empty by simp
    next
      assume "is_lowest_element x (wordinterval_to_set r)"
      with assms show "(wordinterval_lowest_element r = Some x)"
        proof(induction r arbitrary: x rule: wordinterval_lowest_element.induct)
        case 1 thus ?case by(simp add: is_lowest_element_def)
        next
        case (2 A B x)

        have is_lowest_RangeUnion: "is_lowest_element x (wordinterval_to_set A \<union> wordinterval_to_set B) \<Longrightarrow>
          is_lowest_element x (wordinterval_to_set A) \<or> is_lowest_element x (wordinterval_to_set B)"
          by(simp add: is_lowest_element_def)

         (*why \<And> A B?*)
         have wordinterval_lowest_element_RangeUnion:
          "\<And>a b A B. wordinterval_lowest_element A = Some a \<Longrightarrow>
                  wordinterval_lowest_element B = Some b \<Longrightarrow>
                  wordinterval_lowest_element (RangeUnion A B) = Some (min a b)"
           by(auto dest!: wordinterval_lowest_element_correct_A simp add: is_lowest_element_def min_def)

        from 2 show ?case
        apply(case_tac     "wordinterval_lowest_element B")
         apply(case_tac[!] "wordinterval_lowest_element A")
           apply(auto simp add: is_lowest_element_def)[3]
        apply(subgoal_tac "\<not> wordinterval_empty A \<and> \<not> wordinterval_empty B")
         prefer 2
         using arg_cong[where f = Not, OF wordinterval_lowest_none_empty] apply blast
        apply(drule(1) wordinterval_lowest_element_RangeUnion)
        apply(simp split: option.split_asm add: min_def)
         apply(drule is_lowest_RangeUnion)
         apply(elim disjE)
          apply(simp add: is_lowest_element_def)
         apply(clarsimp simp add: wordinterval_lowest_none_empty)

        apply(simp add: is_lowest_element_def)
        apply(clarsimp simp add: wordinterval_lowest_none_empty)
        using wordinterval_lowest_element_correct_A[simplified is_lowest_element_def]
        by (metis Un_iff not_le)
      qed
    qed

text\<open>Cardinality approximation for @{typ "('a::len) wordinterval"}s\<close>
context
begin
  lemma card_atLeastAtMost_word: fixes s::"('a::len) word" shows "card {s..e} = Suc (unat e) - (unat s)"
    apply(cases "s > e")
     apply(simp)
     apply(subst(asm) Word.word_less_nat_alt)
     apply simp
    apply(subst Word_Lemmas.upto_enum_set_conv2[symmetric])
    apply(subst List.card_set)
    apply(simp add: remdups_enum_upto)
    done

  fun wordinterval_card :: "('a::len) wordinterval \<Rightarrow> nat" where
    "wordinterval_card (WordInterval s e) = Suc (unat e) - (unat s)" |
    "wordinterval_card (RangeUnion a b) = wordinterval_card a + wordinterval_card b"

  lemma wordinterval_card: "wordinterval_card r \<ge> card (wordinterval_to_set r)"
    proof(induction r)
    case WordInterval thus ?case by (simp add: card_atLeastAtMost_word)
    next
    case (RangeUnion r1 r2)
      have "card (wordinterval_to_set r1 \<union> wordinterval_to_set r2) \<le>
              card (wordinterval_to_set r1) + card (wordinterval_to_set r2)"
        using Finite_Set.card_Un_le by blast
      with RangeUnion show ?case by(simp)
    qed

  text\<open>With @{thm wordinterval_compress} it should be possible to get the exact cardinality\<close>
end

end