diff --git a/thys/CakeML/Evaluate_Single.thy b/thys/CakeML/Evaluate_Single.thy
--- a/thys/CakeML/Evaluate_Single.thy
+++ b/thys/CakeML/Evaluate_Single.thy
@@ -1,241 +1,250 @@
 section "Simplifiying the definition: no mutual recursion"
 
 theory Evaluate_Single
 imports Evaluate_Clock
 begin
 
 fun evaluate_list ::
   "('ffi state \<Rightarrow> exp \<Rightarrow> 'ffi state*(v, v) result) \<Rightarrow>
     'ffi state \<Rightarrow> exp list \<Rightarrow> 'ffi state*(v list, v) result" where
 
 Nil:
 "evaluate_list eval s [] = (s, Rval [])" |
 
 Cons:
 "evaluate_list eval s (e#es) =
   (case fix_clock s (eval s e) of
     (s', Rval v) \<Rightarrow>
       (case evaluate_list eval s' es of
         (s'', Rval vs) \<Rightarrow> (s'', Rval (v#vs))
       | res \<Rightarrow> res)
   |  (s', Rerr err) \<Rightarrow> (s', Rerr err))"
 
 lemma evaluate_list_cong[fundef_cong]:
   assumes "\<And>e s. e \<in> set es1 \<Longrightarrow> clock s \<le> clock s1 \<Longrightarrow> eval1 s e = eval2 s e" "s1 = s2" "es1 = es2"
   shows "evaluate_list eval1 s1 es1 = evaluate_list eval2 s2 es2"
 using assms by (induction es1 arbitrary: es2 s1 s2) (fastforce simp: fix_clock_alt_def split: prod.splits result.splits)+
 
 function (sequential)
 evaluate :: " v sem_env \<Rightarrow>'ffi state \<Rightarrow> exp \<Rightarrow> 'ffi state*(v,v) result" where
 
 Lit:
 "evaluate env s (Lit l) = (s, Rval (Litv l))" |
 
 Raise:
 "evaluate env s (Raise e) =
   (case evaluate env s e of
     (s', Rval v) \<Rightarrow> (s', Rerr (Rraise (v)))
   | res \<Rightarrow> res)" |
 
 Handle:
 "evaluate env s (Handle e pes) =
   (case evaluate env s e of
     (s', Rerr (Rraise v)) \<Rightarrow>
       (case match_result env s' v pes v of
         (Rval (e', env')) \<Rightarrow>
           evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s' e'
       | (Rerr err) \<Rightarrow> (s', Rerr err))
   | res \<Rightarrow> res)" |
 
 Con:
 "evaluate env s (Con cn es) =
   (if do_con_check (c env) cn (length es) then
     (case evaluate_list (evaluate env) s (rev es) of
       (s', Rval vs) \<Rightarrow>
         (case build_conv (c env) cn (rev vs) of
           Some v \<Rightarrow> (s', Rval v)
         | None \<Rightarrow> (s', Rerr (Rabort Rtype_error)))
     | (s', Rerr err) \<Rightarrow> (s', Rerr err))
   else (s, Rerr (Rabort Rtype_error)))" |
 
 Var:
 "evaluate env s (Var n) =
   (case nsLookup (sem_env.v env) n of
     Some v \<Rightarrow> (s, Rval v)
   | None \<Rightarrow> (s, Rerr (Rabort Rtype_error)))" |
 
 Fun:
 "evaluate env s (Fun n e) = (s, Rval (Closure env n e))" |
 
 App:
 "evaluate env s (App op0 es) =
   (case evaluate_list (evaluate env) s (rev es) of
     (s', Rval vs) \<Rightarrow>
       (if op0 = Opapp then
         (case do_opapp (rev vs) of
           Some (env', e) \<Rightarrow>
             (if (clock s' = 0) then
               (s', Rerr (Rabort Rtimeout_error))
             else
               evaluate env' (dec_clock s') e)
         | None \<Rightarrow> (s', Rerr (Rabort Rtype_error)))
       else
         (case do_app (refs s', ffi s') op0 (rev vs) of
           Some ((refs',ffi'), res) \<Rightarrow> (s' \<lparr>refs:=refs',ffi:=ffi'\<rparr>, res)
         | None \<Rightarrow> (s', Rerr (Rabort Rtype_error))))
   | (s', Rerr err) \<Rightarrow> (s', Rerr err))" |
 
 Log:
 "evaluate env s (Log op0 e1 e2) =
   (case evaluate env s e1 of
     (s', Rval v) \<Rightarrow>
       (case do_log op0 v e2 of
         Some (Exp e') \<Rightarrow> evaluate env s' e'
       | Some (Val bv) \<Rightarrow> (s', Rval bv)
       | None \<Rightarrow> (s', Rerr (Rabort Rtype_error)))
   | res \<Rightarrow> res)" |
 
 If:
 "evaluate env s (If e1 e2 e3) =
   (case evaluate env s e1 of
     (s', Rval v) \<Rightarrow>
       (case do_if v e2 e3 of
         Some e' \<Rightarrow> evaluate env s' e'
       | None \<Rightarrow> (s', Rerr (Rabort Rtype_error)))
   | res \<Rightarrow> res)" |
 
 Mat:
 "evaluate env s (Mat e pes) =
   (case evaluate env s e of
     (s', Rval v) \<Rightarrow>
       (case match_result env s' v pes Bindv of
         Rval (e', env') \<Rightarrow>
           evaluate (env \<lparr> sem_env.v := nsAppend (alist_to_ns env') (sem_env.v env) \<rparr>) s' e'
       | Rerr err \<Rightarrow> (s', Rerr err))
   | res \<Rightarrow> res)" |
 
 Let:
 "evaluate env s (Let n e1 e2) =
   (case evaluate env s e1 of
     (s', Rval v) \<Rightarrow>
       evaluate ( env \<lparr> sem_env.v := (nsOptBind n v(sem_env.v env)) \<rparr>) s' e2
   | res \<Rightarrow> res)" |
 
 Letrec:
 "evaluate env s (Letrec funs e) =
   (if distinct (List.map (\<lambda>x. (case  x of (x,y,z) => x )) funs) then
     evaluate ( env \<lparr> sem_env.v := (build_rec_env funs env(sem_env.v env)) \<rparr>) s e
   else
     (s, Rerr (Rabort Rtype_error)))" |
 
 Tannot:
 "evaluate env s (Tannot e t0) = evaluate env s e" |
 
 Lannot:
 "evaluate env s (Lannot e l) = evaluate env s e"
   by pat_completeness auto
 
 context
   notes do_app.simps[simp del]
 begin
 
 lemma match_result_elem:
   assumes "match_result env s v0 pes err_v = Rval (e, env')"
   shows "\<exists>pat. (pat, e) \<in> set pes"
   using assms proof (induction pes)
   case Nil
   then show ?case by auto
 next
   case (Cons pe pes)
   then obtain p e where "pe = (p, e)" by force
   show ?case
     using Cons(2)
     apply (simp add:match_result_alt_def)
     unfolding \<open>pe = _\<close>
     apply (cases "allDistinct (pat_bindings p [])")
     apply (cases "pmatch (c env) (refs s) p v0 []")
     using Cons(1) by auto+
 qed
 
 private lemma evaluate_list_clock_monotone: "clock (fst (evaluate_list eval s es)) \<le> clock s"
   apply (induction es arbitrary: s)
   apply (auto split:prod.splits result.splits simp add:fix_clock_alt_def dest!:fstI intro:le_trans)
   apply (metis state.record_simps(1))+
   done
 
+lemma i_hate_words_helper:
+  "i \<le> (j - k :: nat) \<Longrightarrow> i \<le> j"
+  by simp
+
+thm i_hate_words_helper [THEN le_trans, no_vars]
+
 private lemma evaluate_clock_monotone:
-  assumes "evaluate_dom (env, s, e)"
-  shows "clock (fst (evaluate env s e)) \<le> clock s"
-using assms
-by induction
-   (fastforce simp add:evaluate.psimps do_con_check_build_conv evaluate_list_clock_monotone
-              split:prod.splits result.splits option.splits exp_or_val.splits error_result.splits
-              dest:fstI intro:i_hate_words_helper[THEN le_trans])+
+  \<open>clock (fst (evaluate env s e)) \<le> clock s\<close>
+  if \<open>evaluate_dom (env, s, e)\<close>
+proof -
+  have *: \<open>i \<le> j - k \<Longrightarrow> j \<le> r \<Longrightarrow> i \<le> r\<close> for i j k r :: nat
+    by arith
+  from that show ?thesis
+    by induction (fastforce simp add: evaluate.psimps do_con_check_build_conv evaluate_list_clock_monotone
+      split: prod.splits result.splits option.splits exp_or_val.splits error_result.splits
+      dest: fstI intro: *)+
+qed
 
 private definition fun_evaluate_single_relation where
 "fun_evaluate_single_relation = inv_image (less_than <*lex*> less_than) (\<lambda>x.
   case x of (_, s, e) \<Rightarrow> (clock s, size_exp' e))"
 
 private lemma pat_elem_less_size:
   "(pat, e) \<in> set pes \<Longrightarrow> size_exp' e < (size_list (size_prod size size_exp') pes)"
 by (induction pes) auto
 
 private lemma elem_less_size: "e \<in> set es \<Longrightarrow> size_exp' e \<le> size_list size_exp' es"
 by (induction es) auto
 
 lemma evaluate_total: "All evaluate_dom"
 proof (relation "fun_evaluate_single_relation", unfold fun_evaluate_single_relation_def, goal_cases)
   case 7
   then show ?case
     using evaluate_list_clock_monotone "7"(1)[symmetric]
     by (auto dest!: fstI simp add:evaluate_list_clock_monotone Suc_le_lessD)
 qed (auto simp add: less_Suc_eq_le Suc_le_lessD do_if_def do_log_alt_def evaluate_list_clock_monotone elem_less_size
           split:lop.splits v.splits option.splits tid_or_exn.splits if_splits id0.splits list.splits
           dest!:evaluate_clock_monotone match_result_elem fstI dest:sym pat_elem_less_size intro:le_neq_implies_less)
 
 termination evaluate by (rule evaluate_total)
 
 lemma evaluate_clock_monotone': "evaluate eval s e = (s', r) \<Longrightarrow>  clock s' \<le> clock s"
   using fst_conv evaluate_clock_monotone evaluate_total
   by metis
 
 fun evaluate_list' :: "v sem_env \<Rightarrow> 'ffi state \<Rightarrow> exp list \<Rightarrow> 'ffi state*(v list, v) result" where
 "evaluate_list' env s [] = (s, Rval [])" |
 "evaluate_list' env s (e#es) =
   (case evaluate env s e of
     (s', Rval v) \<Rightarrow>
       (case evaluate_list' env s' es of
         (s'', Rval vs) \<Rightarrow> (s'', Rval (v#vs))
       | res \<Rightarrow> res)
   |  (s', Rerr err) \<Rightarrow> (s', Rerr err))"
 
 lemma fix_clock_evaluate[simp]: "fix_clock s (evaluate eval s e) = evaluate eval s e"
   unfolding fix_clock_alt_def
   apply (auto simp: datatype_record_update split: state.splits prod.splits)
   using evaluate_clock_monotone' by fastforce
 
 lemma evaluate_list_eq[simp]: "evaluate_list (evaluate env) = evaluate_list' env"
   apply (rule ext)+
   subgoal for s es
     by (induction rule:evaluate_list'.induct) (auto split:prod.splits result.splits)
   done
 
 declare evaluate_list.simps[simp del]
 
 lemma fun_evaluate_equiv:
   "fun_evaluate_match s env v pes err_v = (case match_result env s v pes err_v of
       Rerr err \<Rightarrow> (s, Rerr err)
     | Rval (e, env') \<Rightarrow> evaluate_list (evaluate (env \<lparr> sem_env.v := (nsAppend (alist_to_ns env') (sem_env.v env)) \<rparr>)) s [e])"
   "fun_evaluate s env es = evaluate_list (evaluate env) s es"
   by (induction rule: fun_evaluate_induct)
      (auto split: prod.splits result.splits match_result.splits option.splits exp_or_val.splits
                   if_splits match_result.splits error_result.splits
            simp: all_distinct_alt_def)
 
 corollary fun_evaluate_equiv':
   "evaluate env s e = map_prod id (map_result hd id) (fun_evaluate s env [e])"
 by (subst fun_evaluate_equiv) (simp split: prod.splits result.splits add: error_result.map_id)
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Interval_Arithmetic_Word32/Interval_Word32.thy b/thys/Interval_Arithmetic_Word32/Interval_Word32.thy
--- a/thys/Interval_Arithmetic_Word32/Interval_Word32.thy
+++ b/thys/Interval_Arithmetic_Word32/Interval_Word32.thy
@@ -1,4143 +1,4143 @@
 (* Author:     Brandon Bohrer *)
 theory Interval_Word32
 imports
   Complex_Main
   Word_Lib.Word_Lib_Sumo
 begin
 
 abbreviation signed_real_of_word :: \<open>'a::len word \<Rightarrow> real\<close>
   where \<open>signed_real_of_word \<equiv> signed\<close>
 
 lemma (in linordered_idom) signed_less_numeral_iff:
   \<open>signed w < numeral n \<longleftrightarrow> sint w < numeral n\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> of_int (sint w) < of_int (numeral n)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by (transfer fixing: less less_eq n) simp
   finally show ?thesis ..
 qed
 
 lemma (in linordered_idom) signed_less_neg_numeral_iff:
   \<open>signed w < - numeral n \<longleftrightarrow> sint w < - numeral n\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> of_int (sint w) < of_int (- numeral n)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by (transfer fixing: less less_eq uminus n) simp
   finally show ?thesis ..
 qed
 
 lemma (in linordered_idom) numeral_less_signed_iff:
   \<open>numeral n < signed w \<longleftrightarrow> numeral n < sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> of_int (numeral n) < of_int (sint w)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by (transfer fixing: less less_eq n) simp
   finally show ?thesis ..
 qed
 
 lemma (in linordered_idom) neg_numeral_less_signed_iff:
   \<open>- numeral n < signed w \<longleftrightarrow> - numeral n < sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> of_int (- numeral n) < of_int (sint w)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by (transfer fixing: less less_eq uminus n) simp
   finally show ?thesis ..
 qed
 
 lemma (in linordered_idom) signed_nonnegative_iff:
   \<open>0 \<le> signed w \<longleftrightarrow> 0 \<le> sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> of_int 0 \<le> of_int (sint w)\<close>
     by (simp only: of_int_le_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by (transfer fixing: less_eq) simp
   finally show ?thesis ..
 qed
 
 lemma signed_real_of_word_plus_numeral_eq_signed_real_of_word_iff:
   \<open>signed_real_of_word v + numeral n = signed_real_of_word w
     \<longleftrightarrow> sint v + numeral n = sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (sint v + numeral n) = real_of_int (sint w)\<close>
     by (simp only: of_int_eq_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma signed_real_of_word_sum_less_eq_numeral_iff:
   \<open>signed_real_of_word v + signed_real_of_word w \<le> numeral n
     \<longleftrightarrow> sint v + sint w \<le> numeral n\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (sint v + sint w) \<le> real_of_int (numeral n)\<close>
     by (simp only: of_int_le_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma signed_real_of_word_sum_less_eq_neg_numeral_iff:
   \<open>signed_real_of_word v + signed_real_of_word w \<le> - numeral n
     \<longleftrightarrow> sint v + sint w \<le> - numeral n\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (sint v + sint w) \<le> real_of_int (- numeral n)\<close>
     by (simp only: of_int_le_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma signed_real_of_word_sum_less_numeral_iff:
   \<open>signed_real_of_word v + signed_real_of_word w < numeral n
     \<longleftrightarrow> sint v + sint w < numeral n\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (sint v + sint w) < real_of_int (numeral n)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma signed_real_of_word_sum_less_neg_numeral_iff:
   \<open>signed_real_of_word v + signed_real_of_word w < - numeral n
     \<longleftrightarrow> sint v + sint w < - numeral n\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (sint v + sint w) < real_of_int (- numeral n)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma numeral_less_eq_signed_real_of_word_sum:
   \<open>numeral n \<le> signed_real_of_word v + signed_real_of_word w
     \<longleftrightarrow> numeral n \<le> sint v + sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (numeral n) \<le> real_of_int (sint v + sint w)\<close>
     by (simp only: of_int_le_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma neg_numeral_less_eq_signed_real_of_word_sum:
   \<open>- numeral n \<le> signed_real_of_word v + signed_real_of_word w
     \<longleftrightarrow> - numeral n \<le> sint v + sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (- numeral n) \<le> real_of_int (sint v + sint w)\<close>
     by (simp only: of_int_le_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma numeral_less_signed_real_of_word_sum:
   \<open>numeral n < signed_real_of_word v + signed_real_of_word w
     \<longleftrightarrow> numeral n < sint v + sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (numeral n) < real_of_int (sint v + sint w)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemma neg_numeral_less_signed_real_of_word_sum:
   \<open>- numeral n < signed_real_of_word v + signed_real_of_word w
     \<longleftrightarrow> - numeral n < sint v + sint w\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
 proof -
   have \<open>?Q \<longleftrightarrow> real_of_int (- numeral n) < real_of_int (sint v + sint w)\<close>
     by (simp only: of_int_less_iff)
   also have \<open>\<dots> \<longleftrightarrow> ?P\<close>
     by simp
   finally show ?thesis ..
 qed
 
 lemmas real_of_word_simps [simp] = signed_less_numeral_iff [where ?'a = real]
   numeral_less_signed_iff [where ?'a = real]
   signed_less_neg_numeral_iff [where ?'a = real]
   neg_numeral_less_signed_iff [where ?'a = real]
   signed_nonnegative_iff [where ?'a = real]
 
 lemmas more_real_of_word_simps =
   signed_real_of_word_plus_numeral_eq_signed_real_of_word_iff
   signed_real_of_word_sum_less_eq_numeral_iff
   signed_real_of_word_sum_less_eq_neg_numeral_iff
   signed_real_of_word_sum_less_numeral_iff
   signed_real_of_word_sum_less_neg_numeral_iff
   numeral_less_eq_signed_real_of_word_sum
   neg_numeral_less_eq_signed_real_of_word_sum
   numeral_less_signed_real_of_word_sum
   neg_numeral_less_signed_real_of_word_sum
 
 declare more_real_of_word_simps [simp]
 
 text\<open>Interval-Word32.thy implements conservative interval arithmetic operators on 32-bit word 
    values, with explicit infinities for values outside the representable bounds. It is suitable 
    for use in interpreters for languages which  must have a well-understood low-level behavior
    (see Interpreter.thy). This work was originally part of the paper by Bohrer \emph{et al.}~\cite{BohrerTMMP18}.
 
    It is worth noting that this is not the first formalization of interval arithmetic in 
    Isabelle/HOL. This article is presented regardless because it has unique goals in mind
    which have led to unique design decisions. Our goal is generate code which can be used to 
    perform conservative arithmetic in implementations extracted from a proof.
 
    The Isabelle standard library now features interval arithmetic, for example in Approximation.thy.
    Ours differs in two ways:
    1) We use intervals with explicit positive and negative infinities, and with overflow checking.
       Such checking is often relevant in implementation-level code with unknown inputs.
       To promote memory-efficient implementations, we moreover use sentinel values for infinities,
       rather than datatype constructors. This is especially important in real-time settings where
       the garbarge collection required for datatypes can be a concern.
    2) Our goal is not to use interval arithmetic to discharge Isabelle goals, but to generate useful
       proven-correct implementation code, see Interpreter.thy. On the other hand,  we are not 
       concerned with producing interval-based automation for arithmetic goals in HOL.
 
    In practice, much of the work in this theory comes down to sheer case-analysis.
    Bounds-checking requires many edge cases in arithmetic functions, which come with many cases in
    proofs. Where possible, we attempt to offload interesting facts about word representations of 
    numbers into reusable lemmas, but even then main results require many subcases, each with 
    a certain amount of arithmetic grunt work.
 \<close>
 
 section \<open>Interval arithmetic definitions\<close>
 subsection \<open>Syntax\<close>
 text\<open>Words are 32-bit\<close>
 type_synonym word = "32 Word.word"
 
 text\<open>Sentinel values for infinities. Note that we leave the maximum value ($2^31$) 
   completed unused, so that negation of $(2^{31})-1$ is not an edge case\<close>
 definition NEG_INF::"word"
 where NEG_INF_def[simp]:"NEG_INF = -((2 ^ 31) -1)"
 
 definition NegInf::"real"
 where NegInf[simp]:"NegInf = real_of_int (sint NEG_INF)"
 
 definition POS_INF::"word"
 where POS_INF_def[simp]:"POS_INF = (2^31) - 1"
 
 definition PosInf::"real"
 where PosInf[simp]:"PosInf = real_of_int (sint POS_INF)"
 
 text\<open>Subtype of words who represent a finite value. \<close>
 typedef bword = "{n::word. sint n \<ge> sint NEG_INF \<and> sint n \<le> sint POS_INF}"
   apply(rule exI[where x=NEG_INF])
   by (auto)
 
 text\<open>Numeric literals\<close>
 type_synonym lit = bword
       
 setup_lifting type_definition_bword
 
 lift_definition bword_zero::"bword" is "0::32 Word.word"
   by auto
 
 lift_definition bword_one::"bword" is "1::32 Word.word"
   by(auto simp add: sint_uint)
 
 lift_definition bword_neg_one::"bword" is "-1::32 Word.word"
   by(auto)
 
 
 definition word::"word \<Rightarrow> bool"
 where word_def[simp]:"word w \<equiv> w \<in> {NEG_INF..POS_INF}"
 
 
 named_theorems rep_simps "Simplifications for representation functions"
 
 text\<open>Definitions of interval containment and word representation
 repe w r iff word w encodes real number r\<close>
 inductive repe ::"word \<Rightarrow> real \<Rightarrow> bool" (infix "\<equiv>\<^sub>E" 10)
 where 
   repPOS_INF:"r \<ge> real_of_int (sint POS_INF) \<Longrightarrow> repe POS_INF r" 
 | repNEG_INF:"r \<le> real_of_int (sint NEG_INF) \<Longrightarrow> repe NEG_INF r"
 | repINT:"(sint w) < real_of_int(sint POS_INF) \<Longrightarrow> (sint w) > real_of_int(sint NEG_INF) 
     \<Longrightarrow> repe w (sint w)"
 
 inductive_simps 
     repePos_simps[rep_simps]:"repe POS_INF r"
 and repeNeg_simps[rep_simps]:"repe NEG_INF r"
 and repeInt_simps[rep_simps]:"repe w (sint w)"
 
 text\<open>repU w r if w represents an upper bound of r\<close>
 definition repU ::"word \<Rightarrow> real \<Rightarrow> bool" (infix "\<equiv>\<^sub>U" 10)
 where "repU w r \<equiv> \<exists> r'. r' \<ge> r \<and> repe w r'"
 
 lemma repU_leq:"repU w r \<Longrightarrow> r' \<le> r \<Longrightarrow> repU w r'"
   unfolding repU_def
   using order_trans by auto
 
 text\<open>repU w r if w represents a lower bound of r\<close>
 definition repL ::"word \<Rightarrow> real \<Rightarrow> bool" (infix "\<equiv>\<^sub>L" 10)
 where "repL w r \<equiv> \<exists> r'. r' \<le> r \<and> repe w r'"
 
 lemma repL_geq:"repL w r \<Longrightarrow> r' \<ge> r \<Longrightarrow> repL w r'"
   unfolding repL_def
   using order_trans by auto
 
 text\<open>repP (l,u) r  iff l and u encode lower and upper bounds of r\<close>
 definition repP ::"word * word \<Rightarrow> real \<Rightarrow> bool" (infix "\<equiv>\<^sub>P" 10)
 where "repP w r \<equiv> let (w1, w2) = w in repL w1 r \<and> repU w2 r" 
 
 
 lemma int_not_posinf:
   assumes b1:"real_of_int (sint ra) <  real_of_int (sint POS_INF)"
   assumes b2:"real_of_int (sint NEG_INF) <  real_of_int (sint ra)"
   shows "ra \<noteq> POS_INF"
   using b1 b2 by auto
         
 lemma int_not_neginf:
   assumes b1:" real_of_int (sint ra) <  real_of_int (sint POS_INF)"
   assumes b2:" real_of_int (sint NEG_INF) <  real_of_int (sint ra)"
   shows "ra \<noteq> NEG_INF"
   using b1 b2 by auto
 
 lemma int_not_undef:
   assumes b1:"real_of_int (sint ra) <  real_of_int (sint POS_INF)"
   assumes b2:"real_of_int (sint NEG_INF) < real_of_int (sint ra)"
   shows "ra \<noteq> NEG_INF-1"
   using b1 b2 by auto
 
 lemma sint_range:
   assumes b1:"real_of_int (sint ra) < real_of_int (sint POS_INF)"
   assumes b2:"real_of_int (sint NEG_INF) < real_of_int (sint ra)"
   shows "sint ra  \<in> {i. i > -((2^31)-1)  \<and> i < (2^31)-1}"
   using b1 b2 by auto
 
 lemma word_size_neg:
   fixes w :: "32 Word.word"
   shows "size (-w) = size w"
   using Word.word_size[of w] Word.word_size[of "-w"] by auto
 
 lemma uint_distinct:
   fixes w1 w2
   shows "w1 \<noteq> w2 \<Longrightarrow> uint w1 \<noteq> uint w2"
   by auto
 
 section \<open>Preliminary lemmas\<close>
 subsection \<open>Case analysis lemmas\<close>
 text\<open>Case analysis principle for pairs of intervals, used in proofs of arithmetic operations\<close>
 lemma ivl_zero_case:
   fixes l1 u1 l2 u2 :: real
   assumes ivl1:"l1 \<le> u1"
   assumes ivl2:"l2 \<le> u2"
   shows 
 "(l1 \<le> 0 \<and> 0 \<le> u1 \<and> l2 \<le> 0 \<and> 0 \<le> u2)
 \<or>(l1 \<le> 0 \<and> 0 \<le> u1 \<and> 0 \<le> l2)
 \<or>(l1 \<le> 0 \<and> 0 \<le> u1 \<and> u2 \<le> 0)
 \<or>(0 \<le> l1 \<and> l2 \<le> 0 \<and> 0 \<le> u2)
 \<or>(u1 \<le> 0 \<and> l2 \<le> 0 \<and> 0 \<le> u2)
 \<or>(u1 \<le> 0 \<and> u2 \<le> 0)
 \<or>(u1 \<le> 0 \<and> 0 \<le> l2)
 \<or>(0 \<le> l1 \<and> u2 \<le> 0)
 \<or>(0 \<le> l1 \<and> 0 \<le> l2)"
 using ivl1 ivl2 
 by (metis le_cases)
 
 lemma case_ivl_zero
 [consumes 2, case_names ZeroZero ZeroPos ZeroNeg PosZero NegZero NegNeg NegPos PosNeg PosPos]:
   fixes l1 u1 l2 u2 :: real
   shows
   "l1 \<le> u1 \<Longrightarrow>
    l2 \<le> u2 \<Longrightarrow> 
 ((l1 \<le> 0 \<and> 0 \<le> u1 \<and> l2 \<le> 0 \<and> 0 \<le> u2) \<Longrightarrow> P) \<Longrightarrow>
 ((l1 \<le> 0 \<and> 0 \<le> u1 \<and> 0 \<le> l2) \<Longrightarrow> P) \<Longrightarrow>
 ((l1 \<le> 0 \<and> 0 \<le> u1 \<and> u2 \<le> 0) \<Longrightarrow> P) \<Longrightarrow>
  ((0 \<le> l1 \<and> l2 \<le> 0 \<and> 0 \<le> u2) \<Longrightarrow> P) \<Longrightarrow>
 ((u1 \<le> 0 \<and> l2 \<le> 0 \<and> 0 \<le> u2) \<Longrightarrow> P) \<Longrightarrow>
 ((u1 \<le> 0 \<and> u2 \<le> 0) \<Longrightarrow> P) \<Longrightarrow>
 ((u1 \<le> 0 \<and> 0 \<le> l2) \<Longrightarrow> P) \<Longrightarrow>
 ((0 \<le> l1 \<and> u2 \<le> 0) \<Longrightarrow> P) \<Longrightarrow>
 ((0 \<le> l1 \<and> 0 \<le> l2) \<Longrightarrow> P) \<Longrightarrow> P"
   using ivl_zero_case[of l1 u1 l2 u2]
   by auto
 
 lemma case_inf2[case_names PosPos PosNeg PosNum NegPos NegNeg NegNum NumPos NumNeg NumNum]:
   shows 
   "\<And>w1 w2 P.
       (w1 = POS_INF \<Longrightarrow> w2 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = POS_INF \<Longrightarrow> w2 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = POS_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = NEG_INF \<Longrightarrow> w2 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = NEG_INF \<Longrightarrow> w2 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = NEG_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> P w1 w2"
   by(auto)
 
 lemma case_pu_inf[case_names PosAny AnyPos NegNeg NegNum NumNeg NumNum]:
   shows 
   "\<And>w1 w2 P.
       (w1 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w2 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = NEG_INF \<Longrightarrow> w2 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = NEG_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> P w1 w2"
   by(auto)
 
 lemma case_pl_inf[case_names NegAny AnyNeg PosPos PosNum NumPos NumNum]:
   shows 
   "\<And>w1 w2 P.
       (w1 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w2 = NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = POS_INF \<Longrightarrow> w2 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 = POS_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 = POS_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> (w1 \<noteq> POS_INF \<Longrightarrow> w1 \<noteq> NEG_INF \<Longrightarrow> w2 \<noteq> POS_INF \<Longrightarrow> w2 \<noteq> NEG_INF \<Longrightarrow> P w1 w2)
   \<Longrightarrow> P w1 w2"
   by(auto)
 
 lemma word_trichotomy[case_names Less Equal Greater]:
   fixes w1 w2 :: word
   shows 
   "(w1 <s w2 \<Longrightarrow> P w1 w2) \<Longrightarrow>
    (w1 = w2  \<Longrightarrow> P w1 w2) \<Longrightarrow>
    (w2 <s w1 \<Longrightarrow> P w1 w2) \<Longrightarrow> P w1 w2"
   using signed.linorder_cases by auto
 
 lemma case_times_inf
  [case_names 
   PosPos NegPos PosNeg NegNeg 
   PosLo PosHi PosZero NegLo NegHi NegZero
   LoPos HiPos ZeroPos LoNeg HiNeg ZeroNeg
   AllFinite]:
   fixes w1 w2 P
   assumes pp:"(w1 = POS_INF \<and> w2 = POS_INF \<Longrightarrow> P w1 w2)"
   and np:"(w1 = NEG_INF \<and> w2 = POS_INF \<Longrightarrow> P w1 w2)"
   and pn:"(w1 = POS_INF \<and> w2 = NEG_INF \<Longrightarrow> P w1 w2)"
   and nn:"(w1 = NEG_INF \<and> w2 = NEG_INF \<Longrightarrow> P w1 w2)"
   and pl:"(w1 = POS_INF \<and> w2 \<noteq> NEG_INF \<and> w2 <s 0 \<Longrightarrow> P w1 w2)"
   and ph:"(w1 = POS_INF \<and> w2 \<noteq> POS_INF \<and> 0 <s w2   \<Longrightarrow> P w1 w2)"
   and pz:"(w1 = POS_INF \<and> w2 = 0 \<Longrightarrow> P w1 w2)"
   and nl:"(w1 = NEG_INF \<and> w2 \<noteq> NEG_INF \<and> w2 <s 0 \<Longrightarrow> P w1 w2)"
   and nh:"(w1 = NEG_INF \<and> w2 \<noteq> POS_INF \<and> 0 <s w2 \<Longrightarrow> P w1 w2)"
   and nz:"(w1 = NEG_INF \<and> 0 = w2 \<Longrightarrow> P w1 w2)"
   and lp:"(w1 \<noteq> NEG_INF \<and> w1 <s 0 \<and> w2 = POS_INF \<Longrightarrow> P w1 w2)"
   and hp:"(w1 \<noteq> POS_INF \<and> 0 <s w1 \<and> w2 = POS_INF \<Longrightarrow> P w1 w2)"
   and zp:"(0 = w1 \<and> w2 = POS_INF \<Longrightarrow> P w1 w2)"
   and ln:"(w1 \<noteq> NEG_INF \<and> w1 <s 0 \<and> w2 = NEG_INF \<Longrightarrow> P w1 w2)"
   and hn:"(w1 \<noteq> POS_INF \<and> 0 <s w1 \<and> w2 = NEG_INF \<Longrightarrow> P w1 w2)"
   and zn:"(0 = w1 \<and> w2 = NEG_INF \<Longrightarrow> P w1 w2)"
   and allFinite:"w1 \<noteq> NEG_INF \<and> w1 \<noteq> POS_INF \<and> w2 \<noteq> NEG_INF \<and> w2 \<noteq> POS_INF \<Longrightarrow> P w1 w2"
   shows " P w1 w2"
   proof (cases rule: word_trichotomy[of w1 0])
     case Less then have w1l:"w1 <s 0" by auto
     then show ?thesis
     proof (cases rule: word_trichotomy[of w2 0])
       case Less
       then show ?thesis 
         using nn nl ln nz zn allFinite w1l lp pl by blast
     next
       case Equal 
       then show ?thesis
         using nn nl ln nz zn  w1l allFinite lp pz
         by (auto)
     next
       case Greater
       then show ?thesis
         using  nh np zp lp w1l allFinite ln ph
         by (auto)
     qed
   next
     case Equal then have w1z:"w1 = 0" by auto
     then show ?thesis
     proof (cases rule: word_trichotomy[of w2 0])
       case Less
       then show ?thesis
         using zn allFinite w1z nl pl zp by auto
     next
       case Equal
       then show ?thesis
         using w1z allFinite
         by (auto)
     next
       case Greater
       then show ?thesis
         using allFinite zp w1z nh ph zn by auto
     qed
   next
     case Greater then have w1h:"0 <s w1" by auto
     then show ?thesis
     proof (cases rule: word_trichotomy[of w2 0])
       case Less
       then show ?thesis
         using pn pl hn  w1h allFinite hp nl by blast
     next
       case Equal
       then show ?thesis
         using pz pz allFinite w1h hn hp nz by blast
     next
       case Greater
       then show ?thesis
         using pp ph hp w1h allFinite hn nh by blast
     qed
   qed
 
 
 subsection \<open>Trivial arithmetic lemmas\<close>
 
 lemma max_diff_pos:"0 \<le> 9223372034707292161 + ((-(2 ^ 31))::real)" by auto
 
 lemma max_less:"2 ^ 31 < (9223372039002259455::int)" by auto
 
 lemma sints64:"sints 64 = {i. - (2 ^ 63) \<le> i \<and> i < 2 ^ 63}"
   using sints_def[of 64] range_sbintrunc[of 63] by auto 
 
 lemma sints32:"sints 32 = {i. - (2 ^ 31) \<le> i \<and> i < 2 ^ 31}"
   using sints_def[of 32] range_sbintrunc[of 31] by auto 
 
 lemma upcast_max:"sint((scast(0x80000001::word))::64 Word.word)=sint((0x80000001::32 Word.word))"
   by auto
 
 lemma upcast_min:"(0xFFFFFFFF80000001::64 Word.word) = ((scast (-0x7FFFFFFF::word))::64 Word.word)"
   by auto
 
 lemma min_extend_neg:"sint ((0xFFFFFFFF80000001)::64 Word.word) < 0"
   by auto
 
 lemma min_extend_val':"sint ((-0x7FFFFFFF)::64 Word.word) = (-0x7FFFFFFF)" by auto
 
 lemma min_extend_val:"(-0x7FFFFFFF::64 Word.word) = 0xFFFFFFFF80000001" by auto
 
 lemma range2s:"\<And>x::int. x \<le> 2 ^ 31 - 1 \<Longrightarrow> x + (- 2147483647) < 2147483647"
   by auto
 
 
 section \<open>Arithmetic operations\<close>
 text\<open>This section defines operations which conservatively compute upper and lower bounds of 
  arithmetic functions given upper and lower bounds on their arguments. Each function comes with a 
  proof that it rounds in the advertised direction.
 \<close>
 subsection \<open>Addition upper bound\<close>
 text\<open>Upper bound of w1 + w2\<close>
 fun pu :: "word \<Rightarrow> word \<Rightarrow> word"
 where "pu w1 w2 = 
 (if w1 = POS_INF then POS_INF
  else if w2 = POS_INF then POS_INF
  else if w1 = NEG_INF then 
   (if w2 = NEG_INF then NEG_INF 
    else
      (let sum::64 Word.word = ((scast w2)::64 Word.word) + ((scast NEG_INF)::64 Word.word) in
      if (sum::64 Word.word) <=s ((scast NEG_INF)::64 Word.word) then NEG_INF
      else scast sum))
  else if w2 = NEG_INF then 
   (let sum::64 Word.word = ((scast w1)::64 Word.word) + ((scast NEG_INF)::64 Word.word) in
    if (sum::64 Word.word) <=s ((scast NEG_INF)::64 Word.word) then NEG_INF
    else scast sum)
  else 
   (let sum::64 Word.word = ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word) in
    if ((scast POS_INF)::64 Word.word) <=s (sum::64 Word.word) then POS_INF
    else if (sum::64 Word.word) <=s ((scast NEG_INF)::64 Word.word) then NEG_INF
    else scast sum))"
 
 lemma scast_down_range:
   fixes w::"'a::len Word.word"
   assumes "sint w \<in> sints (len_of (TYPE('b::len)))"
   shows "sint w = sint ((scast w)::'b Word.word)"
   using word_sint.Abs_inverse [OF assms] by simp
 
 lemma pu_lemma:
   fixes w1 w2
   fixes r1 r2 :: real
   assumes up1:"w1 \<equiv>\<^sub>U (r1::real)"
   assumes up2:"w2 \<equiv>\<^sub>U (r2::real)"
   shows   "pu w1 w2 \<equiv>\<^sub>U (r1 + r2)"
 proof -
   have scast_eq1:"sint((scast w1)::64 Word.word) = sint w1" 
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have scast_eq2:"sint((scast (0x80000001::word))::64 Word.word) 
   = sint ((0x80000001::32 Word.word))"
      by auto
   have scast_eq3:"sint((scast w2)::64 Word.word) = sint w2"
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have w2Geq:"sint ((scast w2)::64 Word.word) \<ge> - (2 ^ 31) " 
     using word_sint.Rep[of "(w2)::32 Word.word"] sints32 Word.word_size 
       scast_eq1 upcast_max scast_eq3 len32 mem_Collect_eq 
     by auto
   have "sint ((scast w2)::64 Word.word) \<le> 2 ^ 31"
     apply (auto simp add: word_sint.Rep[of "(w2)::32 Word.word"] sints32 
         scast_eq3 len32)
     using word_sint.Rep[of "(w2)::32 Word.word"] len32[of "TYPE(32)"] sints32 by auto
   then have w2Less:"sint ((scast w2)::64 Word.word) < 9223372039002259455" by auto
   have w2Range:
     "-(2 ^ (size ((scast w2)::64 Word.word) - 1)) 
      \<le> sint ((scast w2)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word) 
    \<and> sint ((scast w2)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word) 
      \<le> 2 ^ (size ((scast w2)::64 Word.word) - 1) - 1"
     apply(auto simp add: Word.word_size scast_eq1 upcast_max sints64 max_less)
     using max_diff_pos max_less w2Less w2Geq by auto
   have w2case1a:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF::64 Word.word)) 
             =  sint ((scast w2)::64 Word.word) + sint (-0x7FFFFFFF::64 Word.word)"
     by(rule signed_arith_sint(1)[OF w2Range])
   have w1Lower:"sint ((scast w1)::64 Word.word) \<ge> - (2 ^ 31) " 
     using word_sint.Rep[of "(w1)::32 Word.word"] sints32 Word.word_size scast_eq1 scast_eq2 
       scast_eq3 len32 mem_Collect_eq 
     by auto
   have w1Leq:"sint ((scast w1)::64 Word.word) \<le> 2 ^ 31"
     apply (auto simp add: word_sint.Rep[of "(w1)::32 Word.word"] sints32 scast_eq1 len32)
     using word_sint.Rep[of "(w1)::32 Word.word"] len32[of "TYPE(32)"] sints32 by auto
   then have w1Less:"sint ((scast w1)::64 Word.word) < 9223372039002259455"
     using max_less by auto
   have w1MinusBound:" - (2 ^ (size ((scast w1)::64 Word.word) - 1)) 
     \<le> sint ((scast w1)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word) 
   \<and> sint ((scast w1)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word) 
     \<le> 2 ^ (size ((scast w1)::64 Word.word) - 1) - 1"
     apply(auto simp add:
     Word.word_size[of "(scast w1)::64 Word.word"] 
     Word.word_size[of "(scast (-0x7FFFFFFF))::64 Word.word"]
     scast_eq3 scast_eq2 
     word_sint.Rep[of "(w1)::32 Word.word"]
     word_sint.Rep[of "0x80000001::32 Word.word"]
     word_sint.Rep[of "(scast w1)::64 Word.word"]
     word_sint.Rep[of "-0x7FFFFFFF::64 Word.word"]
     sints64 sints32)
     using w1Lower w1Less by auto
   have w1case1a:"sint (((scast w1)::64 Word.word) + (-0x7FFFFFFF::64 Word.word)) 
              = sint ((scast w1)::64 Word.word) + sint (-0x7FFFFFFF::64 Word.word)"
     by (rule signed_arith_sint(1)[of "(scast w1)::64 Word.word" "(- 0x7FFFFFFF)", OF w1MinusBound])
   have w1case1a':"sint (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001) 
         = sint ((scast w1)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word)"
     using min_extend_val w1case1a by auto
   have w1Leq':"sint w1 \<le> 2^31 - 1"
     using word_sint.Rep[of "(w1)::32 Word.word"] 
     by (auto simp add:  sints32 len32[of "TYPE(32)"])
   have neg64:"(((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) 
             = ((scast w2)::64 Word.word) + (-0x7FFFFFFF)" by auto
   have arith:"\<And>x::int. x \<le> 2 ^ 31 - 1 \<Longrightarrow> x + (- 2147483647) < 2147483647"
     by auto
   obtain r'\<^sub>1 and r'\<^sub>2 where   
             geq1:"r'\<^sub>1\<ge>r1" and equiv1:"w1 \<equiv>\<^sub>E r'\<^sub>1"
         and geq2:"r'\<^sub>2\<ge>r2" and equiv2:"w2 \<equiv>\<^sub>E r'\<^sub>2"
           using up1 up2 unfolding repU_def by auto
   show ?thesis
 proof (cases rule: case_pu_inf[where ?w1.0=w1, where ?w2.0=w2])
   case PosAny then show ?thesis
     apply (auto simp add: repU_def repe.simps)
     using linear by blast 
 next
   case AnyPos
   then show ?thesis
   apply (auto simp add: repU_def repe.simps)
   using linear by blast
 next
   case NegNeg
   then show ?thesis 
   using up1 up2 
   by (auto simp add: repU_def repe.simps)
 next
   case NegNum
   assume neq1:"w2 \<noteq> POS_INF"
   assume eq2:"w1 = NEG_INF"
   assume neq3:"w2 \<noteq> NEG_INF"
   let ?sum = "(scast w2 + scast NEG_INF)::64 Word.word"
   have leq1:"r'\<^sub>1 \<le>  (real_of_int (sint NEG_INF))" 
     using equiv1 neq1 eq2 neq3 by (auto simp add: repe.simps)
   have leq2:"r'\<^sub>2 =  (real_of_int (sint w2))"
     using equiv2 neq1 eq2 neq3 by (auto simp add: repe.simps)
   have case1:"?sum <=s ((scast NEG_INF)::64 Word.word) \<Longrightarrow> NEG_INF \<equiv>\<^sub>U r1 + r2"
     using up1 up2
     apply (simp add: repU_def repe.simps word_sle_eq)
     apply (rule exI [where x= "r1 + r2"])
     apply auto
     using w2case1a
     apply (auto simp add: eq2 scast_eq3)
     subgoal for r'
     proof -
       assume \<open>r1 \<le> r'\<close> \<open>r' \<le> - 2147483647\<close> \<open>r2 \<le> signed w2\<close> \<open>sint w2 \<le> 0\<close>
       from \<open>sint w2 \<le> 0\<close> have \<open>real_of_int (sint w2) \<le> real_of_int 0\<close>
         by (simp only: of_int_le_iff)
       then have \<open>signed w2 \<le> (0::real)\<close>
         by simp
       from \<open>r1 \<le> r'\<close> \<open>r' \<le> - 2147483647\<close> have \<open>r1 \<le> - 2147483647\<close>
         by (rule order_trans)
       moreover from \<open>r2 \<le> signed w2\<close> \<open>signed w2 \<le> (0::real)\<close> have \<open>r2 \<le> 0\<close>
         by (rule order_trans)
       ultimately show \<open>r1 + r2 \<le> - 2147483647\<close>
         by simp
     qed
     done   
   have case2:"\<not>(?sum <=s scast NEG_INF) \<Longrightarrow> scast ?sum \<equiv>\<^sub>U r1 + r2"
     apply(simp add: repU_def repe.simps word_sle_def up1 up2)
     apply(rule exI[where x= "r'\<^sub>2 - 0x7FFFFFFF"])
     apply(rule conjI)
     subgoal 
       proof -
         assume " \<not> sint (scast w2 + 0xFFFFFFFF80000001) \<le> - 2147483647"
         have bound1:"r1 \<le> - 2147483647"
           using leq1 geq1 by (auto)
         have bound2:"r2 \<le> r'\<^sub>2"
           using leq2 geq2 by auto        
         show "r1 + r2 \<le> r'\<^sub>2 - 2147483647"
           using bound1 bound2
           by(linarith)
       qed
     apply(rule disjI2)
     apply(rule disjI2)
     apply(auto simp add: not_le)
     subgoal
       proof -
         assume a:"sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) > - 2147483647"
         then have sintw2_bound:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF)) > - 2147483647"
           unfolding min_extend_val by auto 
         have case1a:" sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF::64 Word.word)) 
                  =  sint ((scast w2)::64 Word.word) + sint (-0x7FFFFFFF::64 Word.word)"
           by(rule signed_arith_sint(1)[OF w2Range])
         have "- 0x7FFFFFFF < sint w2 + (- 0x7FFFFFFF)"
           using sintw2_bound case1a min_extend_val' scast_eq3 by linarith
         then have w2bound:"0 < sint w2" 
           using less_add_same_cancel2 by blast
         have rightSize:"sint (((scast w2)::64 Word.word) + - 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
           using case1a scast_eq3 min_extend_val' word_sint.Rep[of "(w2)::32 Word.word"] w2bound
           by (auto simp add: sints32 len32[of "TYPE(32)"])
         have downcast:"sint ((scast (((scast w2)::64 Word.word) + ((- 0x7FFFFFFF))))::word) 
                    = sint (((scast w2)::64 Word.word) + ((- 0x7FFFFFFF)::64 Word.word)) "
           using scast_down_range[OF rightSize]
           by auto
         then have b:"sint ((scast (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001))::word)
                  = sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001)" 
           using min_extend_val by auto
         have c:"sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) 
             = sint ((scast w2)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word)"
           using min_extend_val case1a by auto
         show \<open>r'\<^sub>2 - 2147483647 = signed (SCAST(64 \<rightarrow> 32) (SCAST(32 \<rightarrow> 64) w2 + 0xFFFFFFFF80000001))\<close>
           using a b min_extend_val' scast_eq3 leq2 case1a [symmetric]
           apply (simp add: algebra_simps)
           apply transfer
           apply simp
           done
       qed
     subgoal  
     proof -
       have range2a:" - (2 ^ (size ((scast w2)::64 Word.word) - 1)) 
         \<le> sint ((scast w2)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word) 
       \<and> sint ((scast w2)::64 Word.word) + sint ((-0x7FFFFFFF)::64 Word.word) 
         \<le> 2 ^ (size ((scast w2)::64 Word.word) - 1) - 1"
         apply(auto simp add: Word.word_size scast_eq1 upcast_max sints64 sints32 max_less)
         using max_diff_pos max_less w2Geq w2Less by auto
       have case2a:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF::64 Word.word)) 
                 =  sint ((scast w2)::64 Word.word) + sint (-0x7FFFFFFF::64 Word.word)"
         by(rule signed_arith_sint(1)[OF range2a])
       have neg64:"(((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) 
                 = ((scast w2)::64 Word.word) + (-0x7FFFFFFF)" by auto
       assume "sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) > - 2147483647"
       then have sintw2_bound:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF)) > - 2147483647"
         unfolding neg64 by auto 
       have a:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF)) 
             = sint((scast w2)::64 Word.word) + sint((-0x7FFFFFFF)::64 Word.word)" 
         using case2a by auto
       have b:"sint ((scast w2)::64 Word.word) = sint w2" 
         apply(rule Word.sint_up_scast)
         unfolding Word.is_up by auto
       have d:"sint w2 \<le> 2^31 - 1"
         using word_sint.Rep[of "(w2)::32 Word.word"] 
         by (auto simp add:  sints32 len32[of "TYPE(32)"])
       have "- 0x7FFFFFFF < sint w2 + (- 0x7FFFFFFF)"
         using sintw2_bound case2a min_extend_val' scast_eq3 by linarith
       then have w2bound:"0 < sint w2" 
         using less_add_same_cancel2 by blast
       have rightSize:"sint (((scast w2)::64 Word.word) + - 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
         unfolding case2a b min_extend_val'
         using word_sint.Rep[of "(w2)::32 Word.word"] w2bound
         by (auto simp add: sints32 len32[of "TYPE(32)"])
       have downcast:"sint ((scast (((scast w2)::64 Word.word) + ((- 0x7FFFFFFF))))::word) 
                   = sint (((scast w2)::64 Word.word) + ((- 0x7FFFFFFF)::64 Word.word))"
         using scast_down_range[OF rightSize]
         by auto
       have "sint (scast (((scast w2)::64 Word.word) + (-0x7FFFFFFF))::word) < 2147483647"
         unfolding downcast a b min_extend_val'
         using range2s[of "sint w2", OF d]
         by auto
       then show "sint (scast (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001)::word) < 2147483647"
         by auto
     qed
     subgoal proof -
       assume notLeq:"sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) > - 2147483647"
       then have gr:"sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) > - 2147483647" 
         by auto
       have case2a:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF::64 Word.word)) 
                  = sint ((scast w2)::64 Word.word) + sint (-0x7FFFFFFF::64 Word.word)"
         by(rule signed_arith_sint(1)[OF w2Range])
       from neg64
       have sintw2_bound:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF)) > - 2147483647"
         unfolding neg64 using notLeq by auto 
       have a:"sint (((scast w2)::64 Word.word) + (-0x7FFFFFFF)) 
             = sint((scast w2)::64 Word.word) + sint((-0x7FFFFFFF)::64 Word.word)" 
         using case2a by auto
       have c:"sint((-0x7FFFFFFF)::64 Word.word) = -0x7FFFFFFF" 
         by auto
       have d:"sint w2 \<le> 2^31 - 1"
         using word_sint.Rep[of "(w2)::32 Word.word"] 
         by (auto simp add:  sints32 len32[of "TYPE(32)"])
       have "- 0x7FFFFFFF < sint w2 + (- 0x7FFFFFFF)"
         using sintw2_bound case2a c scast_eq3 by linarith
       then have w2bound:"0 < sint w2" 
         using less_add_same_cancel2 by blast
       have rightSize:"sint (((scast w2)::64 Word.word) + - 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
         unfolding case2a scast_eq3
         using word_sint.Rep[of "(w2)::32 Word.word"] w2bound
         by (auto simp add: sints32 len32[of "TYPE(32)"])
       have downcast:"sint ((scast (((scast w2)::64 Word.word) + ((- 0x7FFFFFFF))))::word) 
                    = sint (((scast w2)::64 Word.word) + ((- 0x7FFFFFFF)::64 Word.word))"
         using scast_down_range[OF rightSize]
         by auto
       have sintEq:" sint ((scast (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001))::word) 
           = sint (((scast w2)::64 Word.word) + 0xFFFFFFFF80000001) "
           using downcast by auto
       show "- 2147483647 < sint (SCAST(64 \<rightarrow> 32) (SCAST(32 \<rightarrow> 64) w2 + 0xFFFFFFFF80000001))"
         unfolding sintEq  
         using gr of_int_less_iff of_int_minus of_int_numeral by linarith
       qed
     done
   have castEquiv:"\<not>(?sum <=s scast NEG_INF) \<Longrightarrow> (scast ?sum) \<equiv>\<^sub>U r1 + r2"
     using up1 up2 case1 case2  by fastforce
   have letRep:"(let sum = ?sum in if sum <=s scast NEG_INF then NEG_INF else scast sum) \<equiv>\<^sub>U r1 + r2"
     using case1 case2
     by(cases "?sum <=s scast NEG_INF"; auto) 
   show "pu w1 w2 \<equiv>\<^sub>U r1 + r2"
     using letRep eq2 neq1 
     by(auto)
 next
   case NumNeg
   assume neq3:"w1 \<noteq> NEG_INF"
   assume neq1:"w1 \<noteq> POS_INF"
   assume eq2:"w2 = NEG_INF"
   let ?sum = "(scast w1 + scast NEG_INF)::64 Word.word"
   have case1:"?sum <=s ((scast NEG_INF)::64 Word.word) \<Longrightarrow> NEG_INF \<equiv>\<^sub>U r1 + r2"
     using up1 up2 apply (simp add: repU_def repe.simps word_sle_def)
     apply(rule exI[where x= "r1 + r2"])
     apply(auto)
         using w1case1a min_extend_neg 
         apply (auto simp add: neq1 eq2 neq3 repINT repU_def repe.simps repeInt_simps 
         up2 word_sless_alt) 
     using repINT repU_def repe.simps repeInt_simps up2 word_sless_alt
     proof -
       fix r'
       assume a1:"sint ((scast w1)::64 Word.word) \<le> 0"
       then have "sint w1 \<le> 0" using scast_eq1 by auto 
       then have h3: \<open>signed w1 \<le> (0::real)\<close>
         by transfer simp
       assume a2:"r2 \<le> r'"
       assume a3:"r1 \<le> signed w1"
       assume a4:"r' \<le>  (- 2147483647)"
       from a2 a4 have h1:"r2 \<le> - 2147483647" by auto
       from a1 a3 h3 have h2:"r1 \<le> 0" 
       using dual_order.trans of_int_le_0_iff by blast
       show "r1 + r2 \<le>  (- 2147483647)"
         using h1 h2 add.right_neutral add_mono by fastforce
     qed
   have leq1:"r'\<^sub>2 \<le>  (real_of_int (sint NEG_INF))" and leq2:"r'\<^sub>1 =  (real_of_int (sint w1))" 
     using equiv1 equiv2 neq1 eq2 neq3 unfolding repe.simps by auto
   have case1a:"sint (((scast w1)::64 Word.word) + (-0x7FFFFFFF::64 Word.word)) 
              = sint ((scast w1)::64 Word.word) + sint (-0x7FFFFFFF::64 Word.word)"
     by(rule signed_arith_sint(1)[OF w1MinusBound])
   have case2:"\<not>(?sum <=s scast NEG_INF) \<Longrightarrow> scast ?sum \<equiv>\<^sub>U r1 + r2"
     apply (simp add: repU_def repe.simps word_sle_def up1 up2)
     apply(rule exI[where x= "r'\<^sub>1 - 0x7FFFFFFF"]) (*r1 + r2*)
     apply(rule conjI)
     subgoal using leq1 leq2 geq1 geq2 by auto
     apply(rule disjI2)
     apply(rule disjI2)
     apply(auto)
     subgoal
       proof -
       have f:"r'\<^sub>1 =  (real_of_int (sint w1))"
         by (simp add: leq1 leq2 )
        assume a:"\<not> sint (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001) \<le> - 2147483647"
        then have sintw2_bound:"sint (((scast w1)::64 Word.word) + (-0x7FFFFFFF)) > - 2147483647"
          unfolding min_extend_val by auto 
        have "- 0x7FFFFFFF < sint w1 + (- 0x7FFFFFFF)"
          using sintw2_bound case1a min_extend_val' scast_eq1 by linarith
        then have w2bound:"0 < sint w1" 
          using less_add_same_cancel2 by blast
        have rightSize:"sint (((scast w1)::64 Word.word) + - 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
          unfolding w1case1a 
          using w2bound word_sint.Rep[of "(w1)::32 Word.word"]
          by (auto simp add: sints32 len32[of "TYPE(32)"] scast_eq1)
       have downcast:"sint ((scast (((scast w1)::64 Word.word) + ((- 0x7FFFFFFF))))::word)
                    = sint (((scast w1)::64 Word.word) + ((- 0x7FFFFFFF)::64 Word.word))"
         using scast_down_range[OF rightSize]
         by auto
       then have "sint ((scast (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001))::word) 
                  = sint (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001)" 
         using min_extend_val by auto
       then have \<open>signed (SCAST(64 \<rightarrow> 32) (SCAST(32 \<rightarrow> 64) w1 + 0xFFFFFFFF80000001)) =
         (signed (SCAST(32 \<rightarrow> 64) w1 + 0xFFFFFFFF80000001) :: real)\<close>
         by transfer simp
       moreover have "r'\<^sub>1 - (real_of_int 2147483647) =
           (real_of_int (sint ((scast w1)::64 Word.word ) - 2147483647))"
         by (simp add: scast_eq1 leq2)
       moreover from w1case1a'
       have \<open>signed (SCAST(32 \<rightarrow> 64) w1 + 0xFFFFFFFF80000001) =
         signed (SCAST(32 \<rightarrow> 64) w1) + (signed (- 0x7FFFFFFF :: 64 Word.word) :: real)\<close>
         by transfer simp
       ultimately show "r'\<^sub>1 -  2147483647 
         = (signed ((scast (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001))::word))"
         by simp
     qed
     subgoal  
     proof -
       assume "\<not> sint (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001) \<le> - 2147483647"
       then have sintw2_bound:"sint (((scast w1)::64 Word.word) + (-0x7FFFFFFF)) > - 2147483647"
         unfolding neg64 by auto 
       have "- 0x7FFFFFFF < sint w1 + (- 0x7FFFFFFF)"
         using sintw2_bound case1a min_extend_val' scast_eq1 by linarith
       then have w2bound:"0 < sint w1" 
         using less_add_same_cancel2 by blast
       have rightSize:"sint (((scast w1)::64 Word.word) + - 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
         unfolding case1a scast_eq1 w1case1a'
         using word_sint.Rep[of "(w1)::32 Word.word"] w2bound
         by(auto simp add: sints32 len32[of "TYPE(32)"])
       have downcast:"sint ((scast (((scast w1)::64 Word.word) + ((- 0x7FFFFFFF))))::word) 
                    = sint (((scast w1)::64 Word.word) + ((- 0x7FFFFFFF)::64 Word.word)) "
         using scast_down_range[OF rightSize]
         by auto
       show "sint (scast (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001)::word) < 2147483647"
         using downcast min_extend_val' w1case1a' scast_eq1 arith[of "sint w1", OF w1Leq']
         by auto
     qed
     subgoal proof -
       assume notLeq:"\<not> sint (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001) \<le> - 2147483647"
       then have gr:"sint (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001) > - 2147483647" 
         by auto
       then have sintw2_bound:"sint (((scast w1)::64 Word.word) + (-0x7FFFFFFF)) > - 2147483647"
         unfolding neg64 using notLeq by auto 
       have "- 0x7FFFFFFF < sint w1 + (- 0x7FFFFFFF)"
         using sintw2_bound case1a min_extend_val' scast_eq1 by linarith
       then have w2bound:"0 < sint w1" 
         using less_add_same_cancel2 by blast
       have rightSize:"sint (((scast w1)::64 Word.word) + - 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
         unfolding case1a scast_eq1 w1case1a'
         using word_sint.Rep[of "(w1)::32 Word.word"] w2bound
         by (auto simp add: sints32 len32[of "TYPE(32)"])
       show "- 2147483647 
         < sint ((scast (((scast w1)::64 Word.word) + 0xFFFFFFFF80000001))::word)"
         using scast_down_range[OF rightSize] gr of_int_less_iff of_int_minus of_int_numeral by simp
       qed
       done
     have letUp:"(let sum=?sum in if sum <=s scast NEG_INF then NEG_INF else scast sum) \<equiv>\<^sub>U r1+r2"
       using case1 case2
       by (auto simp add: Let_def)
     have puSimp:"pu w1 w2=(let sum = ?sum in if sum <=s scast NEG_INF then NEG_INF else scast sum)"
       using neq3 neq1 eq2 equiv1 leq2 repeInt_simps by force
     then show "pu w1 w2 \<equiv>\<^sub>U r1 + r2"      
       using letUp puSimp by auto
 next
   case NumNum
   assume notinf1:"w1 \<noteq> POS_INF"
   assume notinf2:"w2 \<noteq> POS_INF"
   assume notneginf1:"w1 \<noteq> NEG_INF"
   assume notneginf2:"w2 \<noteq> NEG_INF"
   let ?sum = "((scast w1)::64 Word.word) + ((scast w2):: 64 Word.word)"
   have inf_case:"scast POS_INF <=s ?sum \<Longrightarrow> POS_INF \<equiv>\<^sub>U r1 + r2"
     using repU_def repePos_simps 
     by (meson dual_order.strict_trans not_less order_refl)
   have truth:" - (2 ^ (size ((scast w1)::64 Word.word) - 1)) 
      \<le> sint ((scast w1)::64 Word.word) + sint ((scast w2)::64 Word.word) 
    \<and> sint ((scast w1)::64 Word.word) + sint ((scast w2)::64 Word.word) 
      \<le> 2 ^ (size ((scast w1)::64 Word.word) - 1) - 1"
     using Word.word_size[of "(scast w2)::64 Word.word"]
       Word.word_size[of "(scast w1)::64 Word.word"]
     scast_eq1 scast_eq3
     word_sint.Rep[of "(w1)::32 Word.word"]
     word_sint.Rep[of "(w2)::32 Word.word"]
     word_sint.Rep[of "(scast w1)::64 Word.word"]
     word_sint.Rep[of "(scast w2)::64 Word.word"]
     sints64 sints32 by auto 
   have sint_eq:"sint((scast w1 + scast w2)::64 Word.word) = sint w1 + sint w2"
     using signed_arith_sint(1)[of "(scast w1)::64 Word.word" "(scast w2)::64 Word.word", OF truth]
       scast_eq1 scast_eq3
     by auto
   have bigOne:"scast w1 + scast w2 <=s ((- 0x7FFFFFFF)::64 Word.word) 
     \<Longrightarrow> \<exists>r'\<ge>r1 + r2. r' \<le>  (- 0x7FFFFFFF)"
    proof -
      assume "scast w1 + scast w2 <=s ((- 0x7FFFFFFF)::64 Word.word)"
      then have "sint w1 + sint w2 \<le> - 0x7FFFFFFF"
        using sint_eq unfolding word_sle_eq by auto
      then have sum_leq: \<open>real_of_int (sint w1 + sint w2) \<le> real_of_int (- 0x7FFFFFFF)\<close>
        by (simp only: of_int_le_iff)
      obtain r'\<^sub>1 r'\<^sub>2 ::real where 
        bound1:"r'\<^sub>1 \<ge> r1 \<and> (w1 \<equiv>\<^sub>E r'\<^sub>1)" and
        bound2:"r'\<^sub>2 \<ge> r2 \<and> (w2 \<equiv>\<^sub>E r'\<^sub>2)"
        using up1 up2 unfolding repU_def by auto
      have somethingA:"r'\<^sub>1  \<le>  sint w1" and somethingB:"r'\<^sub>2  \<le>  sint w2" 
        using \<open>scast w1 + scast w2 <=s - 0x7FFFFFFF\<close>  word_sle_def notinf1 notinf2 
          bound1 bound2 unfolding repe.simps by auto
      have something:"r'\<^sub>1 + r'\<^sub>2 \<le>  sint w1 + sint w2"
        using somethingA somethingB add_mono by fastforce  
      show "\<exists>r'\<ge>r1 + r2. r' \<le> (- 0x7FFFFFFF)"
        apply(rule exI[where x = "r'\<^sub>1 + r'\<^sub>2"])
        using bound1 bound2 add_mono something sum_leq 
        apply (auto intro: order_trans [of _ \<open>signed_real_of_word w1 +
          signed_real_of_word w2\<close>])
        done
    qed
    have anImp:"\<And>r'.  (r'\<ge>r1 + r2 \<and> r' \<le>  (- 2147483647)) \<Longrightarrow> 
     (\<exists>r. - (2 ^ 31 - 1) = - (2 ^ 31 - 1) 
      \<and> r' = r \<and> r \<le> (real_of_int (sint ((- (2 ^ 31 - 1))::32 Word.word))))"
       by auto
    have anEq:"((scast ((- (2 ^ 31 - 1))::32 Word.word))::64 Word.word) =  (- 0x7FFFFFFF)"
      by auto
    have bigTwo:
    "\<not>(((scast POS_INF)::64 Word.word) <=s ?sum) \<Longrightarrow> 
     \<not>(?sum <=s ((scast NEG_INF)::64 Word.word)) \<Longrightarrow> 
     \<exists>r'\<ge>r1 + r2. r' = 
       (real_of_int (sint (scast (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word))::word)))
     \<and> (r' <  0x7FFFFFFF \<and>  (-0x7FFFFFFF) < r')"
    proof -
      assume "\<not>(((scast POS_INF)::64 Word.word) <=s ?sum)"
        and "\<not>(?sum <=s ((scast NEG_INF)::64 Word.word))"
      then have interval_int: "sint w1 + sint w2 < 0x7FFFFFFF"
        "(- 0x7FFFFFFF) < sint w1 + sint w2"
        unfolding word_sle_eq POS_INF_def NEG_INF_def using sint_eq by auto
      then have interval: \<open>real_of_int (sint w1 + sint w2) < real_of_int (0x7FFFFFFF)\<close>
        \<open>real_of_int (- 0x7FFFFFFF) < real_of_int (sint w1 + sint w2)\<close>
        by (simp_all only: of_int_less_iff)
      obtain r'\<^sub>1 r'\<^sub>2 ::real where 
        bound1:"r'\<^sub>1 \<ge> r1 \<and> (w1 \<equiv>\<^sub>E r'\<^sub>1)" and
        bound2:"r'\<^sub>2 \<ge> r2 \<and> (w2 \<equiv>\<^sub>E r'\<^sub>2)"
        using up1 up2 unfolding repU_def by auto
      have somethingA:"r'\<^sub>1  \<le>  sint w1" and somethingB:"r'\<^sub>2  \<le>  sint w2" 
        using word_sle_def notinf1 notinf2 bound1 bound2 unfolding repe.simps by auto
      have something:"r'\<^sub>1 + r'\<^sub>2 \<le>  sint w1 + sint w2"
        using somethingA somethingB add_mono by fastforce  
      have "(w1 \<equiv>\<^sub>E r'\<^sub>1)" using bound1 by auto
      then have
            r1w1:"r'\<^sub>1 =  (real_of_int (sint w1))"
        and w1U:" (real_of_int (sint w1)) <  (real_of_int (sint POS_INF))"
        and w1L:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w1))"
        unfolding repe.simps
        using notinf1 notinf2 notneginf1 notneginf2 by (auto)
      have "(w2 \<equiv>\<^sub>E r'\<^sub>2)" using bound2 by auto
      then have
            r2w1:"r'\<^sub>2 =  (real_of_int (sint w2))"
        and w2U:" (real_of_int (sint w2)) <  (real_of_int (sint POS_INF))"
        and w2L:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w2))"
        unfolding repe.simps
        using notinf1 notinf2 notneginf1 notneginf2 by (auto)
      have "sint (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)) 
          = sint ((scast (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)))::word)"
        apply(rule scast_down_range)
        unfolding sint_eq using sints32 interval_int by auto
      then have cast_eq:"(sint ((scast (((scast w1)::64 Word.word) 
                       + ((scast w2)::64 Word.word)))::word)) 
                     = sint w1 + sint w2"
        using scast_down_range sints32 interval_int sint_eq by auto
      from something and cast_eq 
      have r12_sint_scast:"r'\<^sub>1 + r'\<^sub>2 
        = (sint ((scast (((scast w1)::64 Word.word) 
          + ((scast w2)::64 Word.word)))::word))"
        using r1w1 w1U w1L r2w1 w2U w2L by (simp)
      show ?thesis 
        using bound1 bound2 add_mono r12_sint_scast cast_eq interval 
        \<open>r'\<^sub>1 + r'\<^sub>2 =  (real_of_int (sint (scast (scast w1 + scast w2))))\<close>
        by simp
    qed
    have neg_inf_case:"?sum <=s ((scast ((NEG_INF)::word))::64 Word.word) \<Longrightarrow> NEG_INF \<equiv>\<^sub>U r1 + r2"
    proof (unfold repU_def NEG_INF_def repe.simps)
      assume "scast w1 + scast w2 <=s ((scast ((- (2 ^ 31 - 1))::word))::64 Word.word)"
      then have "scast w1 + scast w2 <=s ((- 0x7FFFFFFF)::64 Word.word)" 
        by (metis anEq)
      then obtain r' where geq:"(r' \<ge> r1 + r2)" and leq:"(r' \<le>  (- 0x7FFFFFFF))"
       using bigOne by auto
      show "(\<exists>r'\<ge>plus r1 r2.
        (\<exists>r. uminus (minus(2 ^ 31) 1) = POS_INF \<and> r' = r \<and>  (real_of_int (sint POS_INF)) \<le> r) 
      \<or> (\<exists>r. uminus (minus(2 ^ 31) 1) = uminus (minus(2 ^ 31)  1) 
         \<and> r' = r \<and> r \<le> real_of_int (sint ((uminus (minus(2 ^ 31) 1))::word)))
      \<or> (\<exists>w. uminus (minus(2 ^ 31) 1) = w 
         \<and> r' = real_of_int (sint w)
         \<and> (real_of_int (sint w)) <  (real_of_int (sint POS_INF)) 
         \<and> less (real_of_int (sint (uminus (minus(2 ^ 31) 1))))  (real_of_int (sint w))))"
        using leq anImp geq by meson
    qed
    have int_case:"\<not>(((scast POS_INF)::64 Word.word) <=s ?sum) 
               \<Longrightarrow> \<not> (?sum <=s ((scast NEG_INF)::64 Word.word)) 
               \<Longrightarrow> ((scast ?sum)::word) \<equiv>\<^sub>U r1 + r2"
    proof -
      assume bound1:"\<not> ((scast POS_INF)::64 Word.word) <=s scast w1 + scast w2"
      assume bound2:"\<not> scast w1 + scast w2 <=s ((scast NEG_INF)::64 Word.word)"
      obtain r'::real  
        where rDef:"r' = (real_of_int (sint ((scast (((scast w1)::64 Word.word) 
                         + ((scast w2)::64 Word.word)))::word)))"
        and r12:"r'\<ge>r1 + r2" 
        and boundU:"r' <  0x7FFFFFFF" 
        and boundL:"(-0x7FFFFFFF) < r'"
        using bigTwo[OF bound1 bound2] by auto
      obtain w::word 
      where wdef:"w = (scast (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word))::word)"
        by auto
      then have wr:"r' = (real_of_int (sint w))"
        using r12 bound1 bound2 rDef by blast
      show ?thesis
        unfolding repU_def repe.simps 
        using r12 wdef rDef boundU boundL wr  
        by auto 
    qed
    have almost:"(let sum::64 Word.word = scast w1 + scast w2 in 
      if scast POS_INF <=s sum then POS_INF 
      else if sum <=s scast NEG_INF then NEG_INF 
     else scast sum) \<equiv>\<^sub>U r1 + r2"
    apply(cases "((scast POS_INF)::64 Word.word) <=s ((?sum)::64 Word.word)")
    subgoal using inf_case Let_def int_case neg_inf_case by auto
    apply(cases "?sum <=s scast NEG_INF")
    subgoal 
      using inf_case Let_def int_case neg_inf_case 
      proof -
        assume "\<not> (scast POS_INF::64 Word.word) <=s scast w1 + scast w2"
        then have "\<not> (scast w1::64 Word.word) + scast w2 <=s scast NEG_INF 
                 \<and> \<not> (scast POS_INF::64 Word.word) <=s scast w1 + scast w2 
                 \<and> \<not> (scast w1::64 Word.word) + scast w2 <=s scast NEG_INF 
              \<or> ((let w = scast w1 + scast w2 in 
                 if scast POS_INF <=s (w::64 Word.word)  then POS_INF 
                 else if w <=s scast NEG_INF then NEG_INF 
                 else scast w) \<equiv>\<^sub>U r1 + r2)"
          using neg_inf_case by presburger
        then show ?thesis
          using int_case by force
      qed
    subgoal using inf_case Let_def int_case neg_inf_case 
    proof -
      assume a1: "\<not> (scast POS_INF::64 Word.word) <=s scast w1 + scast w2"
      assume "\<not> (scast w1::64 Word.word) + scast w2 <=s scast NEG_INF"
      have "\<not> (scast w1::64 Word.word) + scast w2 <=s scast NEG_INF 
          \<and> \<not> (scast POS_INF::64 Word.word) <=s scast w1 + scast w2 
       \<or> ((let w = scast w1 + scast w2 in 
          if scast POS_INF <=s (w::64 Word.word) then POS_INF 
          else if w <=s scast NEG_INF then NEG_INF 
          else scast w) \<equiv>\<^sub>U r1 + r2)"
        using a1 neg_inf_case by presburger
      then show ?thesis
        using int_case by force
    qed
    done
   then show ?thesis 
     using notinf1 notinf2 notneginf1 notneginf2 by auto
 qed
 qed
 
 text\<open>Lower bound of w1 + w2\<close>
 fun pl :: "word \<Rightarrow> word \<Rightarrow> word"
 where "pl w1 w2 = 
 (if w1 = NEG_INF then NEG_INF
  else if w2 = NEG_INF then NEG_INF
  else if w1 = POS_INF then 
   (if w2 = POS_INF then POS_INF 
    else
      (let sum::64 Word.word = ((scast w2)::64 Word.word) + ((scast POS_INF)::64 Word.word) in
      if ((scast POS_INF)::64 Word.word) <=s(sum::64 Word.word) then POS_INF
      else scast sum))
  else if w2 = POS_INF then 
   (let sum::64 Word.word = ((scast w1)::64 Word.word) + ((scast POS_INF)::64 Word.word) in
    if ((scast POS_INF)::64 Word.word) <=s(sum::64 Word.word)  then POS_INF
    else scast sum)
  else 
   (let sum::64 Word.word = ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word) in
    if ((scast POS_INF)::64 Word.word) <=s (sum::64 Word.word) then POS_INF
    else if (sum::64 Word.word) <=s ((scast NEG_INF)::64 Word.word) then NEG_INF
    else scast sum))"
 
 
 subsection \<open>Addition lower bound\<close>
 
 text\<open>Correctness of lower bound of w1 + w2\<close>
 lemma pl_lemma:
 assumes lo1:"w1 \<equiv>\<^sub>L (r1::real)"
 assumes lo2:"w2 \<equiv>\<^sub>L (r2::real)"
 shows "pl w1 w2 \<equiv>\<^sub>L (r1 + r2)"
 proof -
   have scast_eq1:"sint((scast w1)::64 Word.word) = sint w1" 
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have scast_eq2:"sint((scast (0x80000001::word))::64 Word.word)=sint((0x80000001::32 Word.word))"
     by auto
   have scast_eq3:"sint((scast w2)::64 Word.word) = sint w2"
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have sints64:"sints 64 = {i. - (2 ^ 63) \<le> i \<and> i < 2 ^ 63}"
     using sints_def[of 64] range_sbintrunc[of 63] by auto 
   have sints32:"sints 32 = {i. - (2 ^ 31) \<le> i \<and> i < 2 ^ 31}"
     using sints_def[of 32] range_sbintrunc[of 31] by auto 
   have thing1:"0 \<le> 9223372034707292161 + ((-(2 ^ 31))::real)" by auto
   have "sint (( w2)) \<ge> (-(2 ^ 31))"
     using word_sint.Rep[of "(w2)::32 Word.word"] sints32 mem_Collect_eq
     Word.word_size[of "(scast w2)::64 Word.word"] scast_eq1 scast_eq2 scast_eq3 len32 
     by auto
   then have thing4:"sint ((scast w2)::64 Word.word) \<ge> (-(2 ^ 31))" 
     using scast_down_range sint_ge sints_num
     using scast_eq3 by linarith
   have aLeq2:"(-(2 ^ 31)::int) \<ge> -9223372039002259455" by auto 
   then have thing2:" (0::int) \<le> 9223372039002259455 + sint ((scast w2)::64 Word.word)"
     using thing4 aLeq2 
     by (metis ab_group_add_class.ab_left_minus add.commute add_mono neg_le_iff_le)
   have aLeq:"2 ^ 31 \<le> (9223372039002259455::int)" by auto
   have bLeq:"sint ((scast w2)::64 Word.word) \<le> 2 ^ 31"
     apply ( auto simp add: word_sint.Rep[of "(w2)::32 Word.word"] sints32 
         scast_eq3 len32)
     using word_sint.Rep[of "(w2)::32 Word.word"] len32[of "TYPE(32)"] sints32 by auto
   have thing3:" sint ((scast w2)::64 Word.word) \<le> 9223372034707292160 "
     using aLeq bLeq by auto
   have truth:" - (2 ^ (size ((scast w2)::64 Word.word) - 1)) 
       \<le> sint ((scast w2)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word) 
     \<and> sint ((scast w2)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word) 
       \<le> 2 ^ (size ((scast w2)::64 Word.word) - 1) - 1"
     by(auto simp add:
     Word.word_size[of "(scast w2)::64 Word.word"] 
     Word.word_size[of "(scast (0x7FFFFFFF))::64 Word.word"]
     scast_eq1 scast_eq2 
     sints64 sints32 thing2 thing1 thing3)
   have case1a:" sint (((scast w2)::64 Word.word) + (0x7FFFFFFF::64 Word.word)) 
              =  sint ((scast w2)::64 Word.word) + sint (0x7FFFFFFF::64 Word.word)"
     by(rule signed_arith_sint(1)[OF truth])
   have case1b:"sint ((0xFFFFFFFF80000001)::64 Word.word) < 0"
     by auto
   have arith:"\<And>x::int. x \<le> 2 ^ 31 - 1 \<Longrightarrow> x + (- 2147483647) < 2147483647"
     by auto
   have neg64:"(((scast w2)::64 Word.word) + 0x7FFFFFFF) 
             = ((scast w2)::64 Word.word) + (0x7FFFFFFF)"
     by auto
   obtain r'\<^sub>1 and r'\<^sub>2 where   
             geq1:"r'\<^sub>1\<le>r1" and equiv1:"w1 \<equiv>\<^sub>E r'\<^sub>1"
         and geq2:"r'\<^sub>2\<le>r2" and equiv2:"w2 \<equiv>\<^sub>E r'\<^sub>2"
           using lo1 lo2 unfolding repL_def by auto
   show ?thesis
 proof (cases rule: case_pl_inf[where ?w1.0=w1, where ?w2.0=w2])
   case NegAny
   then show ?thesis
   apply (auto simp add: repL_def repe.simps)
   using lo1 lo2 linear by auto
 next
   case AnyNeg
   then show ?thesis 
   apply (auto simp add: repL_def repe.simps)
   using linear by auto
 next
   case PosPos
   then show ?thesis 
   using lo1 lo2 
   by (auto simp add: repL_def repe.simps)
 next
   case PosNum
   assume neq1:"w2 \<noteq> POS_INF"
   assume eq2:"w1 = POS_INF"
   assume neq3:"w2 \<noteq> NEG_INF"
   let ?sum = "(scast w2 + scast POS_INF)::64 Word.word"
   have case1:"(((scast POS_INF)::64 Word.word) <=s ?sum) \<Longrightarrow> POS_INF \<equiv>\<^sub>L r1 + r2"
     using lo1 lo2 apply (simp add: repL_def repe.simps word_sle_def)
     apply(rule exI[where x= "r1 + r2"])
     using case1a case1b 
     apply (auto simp add: neq1 eq2 neq3 repINT repL_def repe.simps 
       repeInt_simps lo2 word_sless_alt)
    proof -
       fix r'
       assume a1:"0 \<le> sint (((scast w2)::64 Word.word))"
       from a1 have h3:"2147483647 \<le> sint w2 + 0x7FFFFFFF " using scast_eq3
         by auto
       assume a2:"r' \<le> r1"
       assume a3:"signed w2 \<le> r2"
       assume a4:"(2147483647) \<le> r'"
       from a2 a4 have h1:"2147483647 \<le> r1" by auto
       from a1 a3 h3 have h2:"0 \<le> r2" 
         using of_int_le_0_iff le_add_same_cancel2
         apply simp
         apply transfer
         apply simp
         apply (metis (full_types) of_int_0 of_int_le_iff order_trans signed_take_bit_nonnegative_iff)
         done
       show "(2147483647) \<le> r1 + r2 "
         using h1 h2 h3 add.right_neutral add_mono  
         by fastforce
       qed
   have leq1:"r'\<^sub>1 \<ge>  (real_of_int (sint POS_INF))" 
     using equiv1 neq1 eq2 neq3 
     unfolding repe.simps by auto
   have leq2:"r'\<^sub>2 = (real_of_int (sint w2))"
     using equiv2 neq1 eq2 neq3
     unfolding repe.simps by auto      
   have case2:"\<not>(scast POS_INF <=s ?sum) \<Longrightarrow> scast ?sum \<equiv>\<^sub>L r1 + r2"
     apply (simp add: repL_def repe.simps word_sle_def lo1 lo2)
     apply(rule exI[where x= "r'\<^sub>2 + 0x7FFFFFFF"]) (*r1 + r2*)
     apply(rule conjI)
     subgoal 
       proof -
         assume "\<not> 2147483647 \<le> sint (scast w2 + 0x7FFFFFFF)"
         have bound1:"2147483647 \<le> r1"
           using leq1 geq1 by (auto)
         have bound2:"r'\<^sub>2 \<le> r2 "
           using leq2 geq2 by auto        
         show "r'\<^sub>2 + 2147483647 \<le> r1 + r2"
           using bound1 bound2
           by linarith
       qed
     apply(rule disjI2)
     apply(rule disjI2)
     apply(auto)
     subgoal
       proof -
        assume a:"\<not> 2147483647 \<le> sint (((scast w2)::64 Word.word) + 0x7FFFFFFF)"
        then have sintw2_bound:"2147483647 > sint (((scast w2)::64 Word.word) + (0x7FFFFFFF))"
          by auto 
        have case1a:"sint (((scast w2)::64 Word.word) + (0x7FFFFFFF::64 Word.word)) 
                  =  sint ((scast w2)::64 Word.word) + sint (0x7FFFFFFF::64 Word.word)"
          by(rule signed_arith_sint(1)[OF truth])
        have a1:"sint (((scast w2)::64 Word.word) + (0x7FFFFFFF)) 
               = sint((scast w2)::64 Word.word) + sint((0x7FFFFFFF)::64 Word.word)" 
          using case1a by auto
        have c1:"sint((0x7FFFFFFF)::64 Word.word) = 0x7FFFFFFF" 
          by auto
        have "sint w2 + ( 0x7FFFFFFF) <  0x7FFFFFFF"
          using sintw2_bound case1a c1 scast_eq3 by linarith
        then have w2bound:"sint w2 < 0" 
          using add_less_same_cancel2 by blast
        have rightSize:"sint (((scast w2)::64 Word.word) +  0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
          unfolding case1a scast_eq3 c1 
          using word_sint.Rep[of "(w2)::32 Word.word"] w2bound 
          by (auto simp add: sints32 len32[of "TYPE(32)"])
       have downcast:"sint ((scast (((scast w2)::64 Word.word) + (( 0x7FFFFFFF))))::word)
         = sint (((scast w2)::64 Word.word) + (( 0x7FFFFFFF)::64 Word.word))"
         using scast_down_range[OF rightSize]
         by auto
       then have b:"sint ((scast (((scast w2)::64 Word.word) + 0x7FFFFFFF))::word)
                  = sint (((scast w2)::64 Word.word) + 0x7FFFFFFF)" 
         by auto
       have c:"sint (((scast w2)::64 Word.word) + 0x7FFFFFFF)
             = sint ((scast w2)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word)"
         using case1a by auto
       have d:"sint ((0x7FFFFFFF)::64 Word.word) = (0x7FFFFFFF)" by auto 
       have f:"r'\<^sub>2 =  (real_of_int (sint w2))"
         by (simp add: leq2)
       show "r'\<^sub>2 +  2147483647 
         = (signed ((scast (((scast w2)::64 Word.word) + 0x7FFFFFFF))::word))"
         using a b c d scast_eq3 f leq2 of_int_numeral 
         by auto
       qed
     subgoal  
     proof -
       have truth2a:"-(2^(size ((scast w2)::64 Word.word)-1)) 
           \<le> sint ((scast w2)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word) 
         \<and> sint ((scast w2)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word) 
           \<le> 2 ^ (size ((scast w2)::64 Word.word) - 1) - 1"
         apply(auto simp add:
             Word.word_size[of "(scast w2)::64 Word.word"]
             Word.word_size[of "(scast (0x7FFFFFFF))::64 Word.word"]
             scast_eq1 scast_eq2 sints64 sints32 thing2)
         using thing1 thing2 thing3 by auto
       have case2a:" sint (((scast w2)::64 Word.word) + (0x7FFFFFFF::64 Word.word)) 
                   = sint ((scast w2)::64 Word.word) + sint (0x7FFFFFFF::64 Word.word)"
         by(rule signed_arith_sint(1)[OF truth2a])
       have min_cast:"(0x7FFFFFFF::64 Word.word) =((scast (0x7FFFFFFF::word))::64 Word.word)"
         by auto
       assume "\<not> 2147483647 \<le> sint (((scast w2)::64 Word.word) + 0x7FFFFFFF)"
       then have sintw2_bound:"2147483647 > sint (((scast w2)::64 Word.word) + (0x7FFFFFFF))"
         using neg64 by auto
       have a:"sint (((scast w2)::64 Word.word) + (0x7FFFFFFF)) 
             = sint((scast w2)::64 Word.word) + sint((0x7FFFFFFF)::64 Word.word)" 
         using case2a by auto
       have c:"sint((0x7FFFFFFF)::64 Word.word) = 0x7FFFFFFF" 
         by auto
       have " 0x7FFFFFFF > sint w2 + ( 0x7FFFFFFF)"
         using sintw2_bound case2a c scast_eq3 by linarith
       then have w2bound:" sint w2 < 0" 
         by simp
       have rightSize:"sint (((scast w2)::64 Word.word) +  0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
         unfolding case2a scast_eq3 c
         apply (auto simp add: sints32 len32[of "TYPE(32)"])
         using word_sint.Rep[of "(w2)::32 Word.word"] sints32 len32[of "TYPE(32)"] w2bound 
         by auto
       have downcast:"sint ((scast (((scast w2)::64 Word.word) + (( 0x7FFFFFFF))))::word) 
         = sint (((scast w2)::64 Word.word) + (( 0x7FFFFFFF)::64 Word.word))"
         using scast_down_range[OF rightSize]
         by auto
       then show "sint (scast (((scast w2)::64 Word.word) + 0x7FFFFFFF)::word) < 2147483647"
         unfolding downcast a scast_eq3 c
         using w2bound by auto
     qed
     subgoal proof -
       assume notLeq:"\<not> 2147483647 \<le> sint (((scast w2)::64 Word.word) + 0x7FFFFFFF)"
       then have gr:"sint (((scast w2)::64 Word.word) + 0x7FFFFFFF) <  2147483647" 
         by auto
       have case2a:" sint (((scast w2)::64 Word.word) + (0x7FFFFFFF::64 Word.word)) 
                   = sint ((scast w2)::64 Word.word) + sint (0x7FFFFFFF::64 Word.word)"
         by(rule signed_arith_sint(1)[OF truth])
       have min_cast:"(0x7FFFFFFF::64 Word.word) =((scast (0x7FFFFFFF::word))::64 Word.word)"
         by auto
       have neg64:"(((scast w2)::64 Word.word) + 0x7FFFFFFF) 
                 = ((scast w2)::64 Word.word) + (0x7FFFFFFF)"
         by auto
       then have sintw2_bound:"sint (((scast w2)::64 Word.word) + (0x7FFFFFFF)) < 2147483647"
         using neg64 using notLeq by auto 
       have a:"sint (((scast w2)::64 Word.word) + (0x7FFFFFFF)) 
             = sint((scast w2)::64 Word.word) + sint((0x7FFFFFFF)::64 Word.word)"
         using case2a by auto
       have c:"sint((0x7FFFFFFF)::64 Word.word) = 0x7FFFFFFF" 
         by auto
       have "- 2147483647 \<noteq> w2" using neq3 unfolding NEG_INF_def by auto
       then have "sint((- 2147483647)::word) \<noteq> sint w2"
         using word_sint.Rep_inject by blast
       then have n1:"- 2147483647 \<noteq> sint w2"
         by auto
       have "- 2147483648 \<noteq> w2"
         apply(rule repe.cases[OF equiv2])
         by auto
       then have "sint(- 2147483648::word) \<noteq> sint w2"
       using word_sint.Rep_inject by blast
       then have n2:"- 2147483648 \<noteq> sint w2" 
         by auto
       then have d:"sint w2 > - 2147483647"
         using word_sint.Rep[of "(w2)::32 Word.word"] sints32 len32[of "TYPE(32)"] neq3 n1 n2
         by auto
       have w2bound:"- 2147483647 < sint w2 + 0x7FFFFFFF"
         using sintw2_bound case2a c scast_eq3 d by linarith
       have rightSize:"sint (((scast w2)::64 Word.word) +  0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
         using sints32 len32[of "TYPE(32)"] w2bound word_sint.Rep[of "(w2)::32 Word.word"] 
           c case2a scast_eq3 sintw2_bound
         by (auto simp add: sints32 len32[of "TYPE(32)"])
       have downcast:"sint ((scast (((scast w2)::64 Word.word) + (( 0x7FFFFFFF))))::word)
                    = sint (((scast w2)::64 Word.word) + (( 0x7FFFFFFF)::64 Word.word))"
         using scast_down_range[OF rightSize]
         by auto
       have sintEq:" sint ((scast (((scast w2)::64 Word.word) + 0x7FFFFFFF))::word) =
           sint (((scast w2)::64 Word.word) + 0x7FFFFFFF) "
           using downcast by auto
       show "- 2147483647
           < sint ((scast (((scast w2)::64 Word.word) + 0x7FFFFFFF))::word)"
         unfolding sintEq  
         using gr of_int_less_iff of_int_minus of_int_numeral c case2a scast_eq3 w2bound
         by simp
       qed
       done
   have "(let sum = ?sum in if scast POS_INF <=s sum then POS_INF else scast sum) \<equiv>\<^sub>L r1 + r2"
     using case1 case2
     by (auto simp add: Let_def)
   then show ?thesis 
     using lo1 lo2 neq1 eq2 neq3 
     by (auto)
 next
   case NumPos
     assume neq3:"w1 \<noteq> NEG_INF"
     assume neq1:"w1 \<noteq> POS_INF"
     assume eq2:"w2 = POS_INF"
     let ?sum = "(scast w1 + scast POS_INF)::64 Word.word"
     have thing1:"0 \<le> 9223372034707292161 + ((-(2 ^ 31))::real)" by auto
     have "sint (( w1)) \<ge> (-(2 ^ 31))"
       using word_sint.Rep[of "(w1)::32 Word.word"] scast_eq1 scast_eq2 scast_eq3
         Word.word_size[of "(scast w1)::64 Word.word"] sints32 len32 mem_Collect_eq
       by auto
     then have thing4:"sint ((scast w1)::64 Word.word) \<ge> (-(2 ^ 31))" 
       using scast_down_range sint_ge sints_num scast_eq3 scast_eq1 by linarith
     have aLeq2:"(-(2 ^ 31)::int) \<ge> -9223372039002259455" by auto 
     then have thing2:" (0::int) \<le> 9223372039002259455 + sint ((scast w1)::64 Word.word)"
       using thing4 aLeq2 
       by (metis ab_group_add_class.ab_left_minus add.commute add_mono neg_le_iff_le)
     have aLeq:"2 ^ 31 \<le> (9223372039002259455::int)" by auto
     have bLeq:"sint ((scast w1)::64 Word.word) \<le> 2 ^ 31"
       apply (auto simp add: word_sint.Rep[of "(w1)::32 Word.word"] sints32 
           scast_eq1 len32)
       using word_sint.Rep[of "(w1)::32 Word.word"] len32[of "TYPE(32)"] sints32
       by clarsimp
     have thing3:" sint ((scast w1)::64 Word.word) \<le> 9223372034707292160 "
       using aLeq bLeq by auto
     have truth:" - (2 ^ (size ((scast w1)::64 Word.word) - 1)) 
                    \<le> sint ((scast w1)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word)
                  \<and> sint ((scast w1)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word) 
                    \<le> 2 ^ (size ((scast w1)::64 Word.word) - 1) - 1"
       by(auto simp add:
       Word.word_size[of "(scast w1)::64 Word.word"]
       Word.word_size[of "(scast (0x7FFFFFFF))::64 Word.word"]
       scast_eq3 scast_eq2 sints64 sints32 thing2 thing1 thing3)
     have case1a:"sint (((scast w1)::64 Word.word) + (0x7FFFFFFF::64 Word.word)) 
                = sint ((scast w1)::64 Word.word) + sint (0x7FFFFFFF::64 Word.word)"
       by(rule signed_arith_sint(1)[OF truth])
     have case1b:"sint ((0xFFFFFFFF80000001)::64 Word.word) < 0"
       by auto
     have g:"(0x7FFFFFFF::64 Word.word) = 0x7FFFFFFF" by auto
     have c:"sint (((scast w1)::64 Word.word) + 0x7FFFFFFF) 
           = sint ((scast w1)::64 Word.word) + sint ((0x7FFFFFFF)::64 Word.word)"
       using g case1a 
       by blast
     have d:"sint ((0x7FFFFFFF)::64 Word.word) = (0x7FFFFFFF)" by auto 
     have e:"sint ((scast w1)::64 Word.word) = sint w1" 
       using scast_eq1 by blast
     have d2:"sint w1 \<le> 2^31 - 1"
       using word_sint.Rep[of "(w1)::32 Word.word"] 
       by (auto simp add: sints32 len32[of "TYPE(32)"])
     have case1:"scast POS_INF <=s ?sum \<Longrightarrow> POS_INF \<equiv>\<^sub>L r1 + r2"
       using lo1 lo2 apply (simp add: repL_def repe.simps word_sle_def)
       apply(rule exI[where x= "r1 + r2"])
       apply(auto)
           using case1a case1b 
           apply (auto simp add: neq1 eq2 neq3 repINT repL_def 
             repe.simps repeInt_simps lo2 word_sless_alt) (* close 4 goals *)
      proof -
         fix r'
         have h3:"sint (((scast w1)::64 Word.word) + 0x7FFFFFFF) 
           = sint (((scast w1)::64 Word.word)) + sint(0x7FFFFFFF::64 Word.word)" 
           using case1a by auto 
         have h4:"sint(0x7FFFFFFF::64 Word.word) = 2147483647" by auto
         assume a1:"0 \<le> sint ((scast w1)::64 Word.word)"
         then have h3:"sint w1 \<ge> 0" using scast_eq1 h3 h4 by auto 
         assume a2:"r' \<le> r2"
         assume a3:"signed w1 \<le> r1"
         assume a4:"(2147483647) \<le> r'"
         from a2 a4 have h1:"r2 \<ge>  2147483647" by auto
         from a3 h3 have h2:"r1 \<ge> 0"
           by (auto intro: order_trans [of _ \<open>signed_real_of_word w1\<close>])
         show " 2147483647 \<le> r1 + r2"
           using h1 h2 add.right_neutral add_mono by fastforce
         qed
     have leq1:"r'\<^sub>2 \<ge>  (real_of_int (sint POS_INF))" and leq2:"r'\<^sub>1 =  (real_of_int (sint w1))" 
       using equiv1 equiv2 neq1 eq2 neq3 unfolding repe.simps by auto
     have neg64:"(((scast w1)::64 Word.word) + 0xFFFFFFFF80000001) 
               = ((scast w1)::64 Word.word) + (-0x7FFFFFFF)" 
       by auto
     have case2:"\<not>(scast POS_INF <=s ?sum) \<Longrightarrow> scast ?sum \<equiv>\<^sub>L r1 + r2"
       apply (simp add: repL_def repe.simps word_sle_def lo1 lo2)
       apply(rule exI[where x= "r'\<^sub>1 + 0x7FFFFFFF"]) 
       apply(rule conjI)
       subgoal 
         proof -
           assume "\<not> 2147483647 \<le> sint (scast w1 + 0x7FFFFFFF)"
           have bound1:"r2 \<ge>  2147483647"
             using leq1 geq2 by (auto)
           have bound2:"r1 \<ge> r'\<^sub>1"
             using leq2 geq1 by auto        
           show "r'\<^sub>1 + 2147483647 \<le> r1 + r2"
             using bound1 bound2
             by linarith
           qed
       apply(rule disjI2)
       apply(rule disjI2)
       apply(auto)
       subgoal
         proof -
         have f:"r'\<^sub>1 =  (real_of_int (sint w1))"
           by (simp add: leq1 leq2 )
          assume a:"\<not> 2147483647 \<le> sint (((scast w1)::64 Word.word) + 0x7FFFFFFF)"
          then have sintw2_bound:"2147483647 > sint (((scast w1)::64 Word.word) + (0x7FFFFFFF))"
            by auto 
          have "0x7FFFFFFF > sint w1 + (0x7FFFFFFF)"
            using sintw2_bound case1a d scast_eq1 by linarith
          then have w2bound:"0 > sint w1" 
            using add_less_same_cancel2 by blast
          have rightSize:"sint (((scast w1)::64 Word.word) + 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
            unfolding case1a e 
            using w2bound word_sint.Rep[of "(w1)::32 Word.word"]
            by (auto simp add: sints32 len32[of "TYPE(32)"] )
         have arith:"\<And>x::int. x \<le> 2 ^ 31 - 1 \<Longrightarrow> x + (- 2147483647) < 2147483647"
           by auto
         have downcast:"sint ((scast (((scast w1)::64 Word.word) + (( 0x7FFFFFFF))))::word) 
                      = sint (((scast w1)::64 Word.word) + (( 0x7FFFFFFF)::64 Word.word))"
           using scast_down_range[OF rightSize]
           by auto
         then have b:"sint((scast (((scast w1)::64 Word.word) + 0x7FFFFFFF))::word)
                    = sint(((scast w1)::64 Word.word) + 0x7FFFFFFF)" 
           using g by auto
         show "r'\<^sub>1 + 2147483647
           = ((signed_real_of_word ((scast (((scast w1)::64 Word.word) + 0x7FFFFFFF))::word)))"
           using a b c d e f 
           proof -
             have "(real_of_int (sint ((scast w1)::64 Word.word ) + 2147483647)) 
                 = r'\<^sub>1 +  (real_of_int 2147483647)"
               using e leq2 by auto
             from this [symmetric] show ?thesis
               using b c d of_int_numeral
               by simp
           qed
         qed
       subgoal  
       proof -
         assume "\<not> 2147483647 \<le> sint (((scast w1)::64 Word.word) + 0x7FFFFFFF)"
         then have sintw2_bound:"sint (((scast w1)::64 Word.word) + (0x7FFFFFFF)) < 2147483647"
           unfolding neg64 by auto 
         have "0x7FFFFFFF > sint w1 + (0x7FFFFFFF)"
           using sintw2_bound case1a d scast_eq1 by linarith
         then have w2bound:"0 > sint w1" 
           using add_less_same_cancel2 by blast
         have rightSize:"sint (((scast w1)::64 Word.word) + 0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
           unfolding case1a e c 
           using word_sint.Rep[of "(w1)::32 Word.word"] w2bound
           by (auto simp add: sints32 len32[of "TYPE(32)"])
         have arith:"\<And>x::int. x \<le> 2 ^ 31 - 1 \<Longrightarrow> x + (- 2147483647) < 2147483647"
           by auto
         have downcast:"sint ((scast (((scast w1)::64 Word.word) + 0x7FFFFFFF))::word) 
           = sint (((scast w1)::64 Word.word) + ((0x7FFFFFFF)::64 Word.word))"
           using scast_down_range[OF rightSize]
           by auto
         show "sint (scast (((scast w1)::64 Word.word) + 0x7FFFFFFF)::word) < 2147483647"
           using downcast d e c arith[of "sint w1", OF d2] sintw2_bound by linarith
       qed
       subgoal proof -
         assume notLeq:"\<not> 2147483647 \<le> sint (((scast w1)::64 Word.word) + 0x7FFFFFFF)"
         then have gr:"2147483647 > sint (((scast w1)::64 Word.word) + 0x7FFFFFFF)" 
           by auto
         then have sintw2_bound:"sint (((scast w1)::64 Word.word) + (0x7FFFFFFF)) < 2147483647"
           unfolding neg64 using notLeq by auto 
         have "0x7FFFFFFF > sint w1 + ( 0x7FFFFFFF)"
           using sintw2_bound case1a d scast_eq1 by linarith
         then have useful:"0 > sint w1"
           using add_less_same_cancel2 by blast
         have rightSize:"sint (((scast w1)::64 Word.word) +  0x7FFFFFFF) \<in> sints (len_of TYPE(32))"
           unfolding case1a e
           using word_sint.Rep[of "(w1)::32 Word.word"]
             sints32 len32[of "TYPE(32)"] useful
           by auto
         have "- 2147483647 \<noteq> w1" using neq3 unfolding NEG_INF_def by auto
         then have "sint((- 2147483647)::word) \<noteq> sint w1"
           using word_sint.Rep_inject by blast
         then have n1:"- 2147483647 \<noteq> sint w1"
           by auto
         have "- 2147483648 \<noteq> w1"
           apply(rule repe.cases[OF equiv1]) using int_not_undef[of w1] by auto
         then have "sint(- 2147483648::word) \<noteq> sint w1"
           using word_sint.Rep_inject by blast
         then have n2:"- 2147483648 \<noteq> sint w1" 
           by auto
         then have d:"sint w1 > - 2147483647"
           using word_sint.Rep[of "(w1)::32 Word.word"] 
             sints32 len32[of "TYPE(32)"] n1 n2 neq3 
           by (simp)
         have d2:"sint (0x7FFFFFFF::64 Word.word) > 0"
           by auto
         from d d2 have d3:"- 2147483647 < sint w1 + sint (0x7FFFFFFF::64 Word.word)"
           by auto
         have d4:"sint ((scast (((scast w1)::64 Word.word) + 0x7FFFFFFF))::word) 
           = sint w1 + sint (0x7FFFFFFF::64 Word.word)"
           using case1a rightSize scast_down_range scast_eq1 by fastforce  
         then show "- 2147483647 < sint (SCAST(64 \<rightarrow> 32) (SCAST(32 \<rightarrow> 64) w1 + 0x7FFFFFFF))"
           using d3 d4 by auto
         qed done
       have "(let sum = ?sum in if scast POS_INF <=s sum then POS_INF else scast sum) \<equiv>\<^sub>L r1 + r2"
         using case1 case2
         by (auto simp add: Let_def)
       then show ?thesis 
         using neq1 eq2 neq3 by (auto)
 next
   case NumNum
   assume notinf1:"w1 \<noteq> POS_INF"
   assume notinf2:"w2 \<noteq> POS_INF"
   assume notneginf1:"w1 \<noteq> NEG_INF"
   assume notneginf2:"w2 \<noteq> NEG_INF"
   let ?sum = "((scast w1)::64 Word.word) + ((scast w2):: 64 Word.word)"
   have truth:" - (2 ^ (size ((scast w1)::64 Word.word) - 1)) 
       \<le> sint ((scast w1)::64 Word.word) + sint ((scast w2)::64 Word.word) 
     \<and> sint ((scast w1)::64 Word.word) + sint ((scast w2)::64 Word.word) 
       \<le> 2 ^ (size ((scast w1)::64 Word.word) - 1) - 1"
     using Word.word_size[of "(scast w2)::64 Word.word"] 
       Word.word_size[of "(scast w1)::64 Word.word"]
       scast_eq1 scast_eq3 sints64 sints32
       word_sint.Rep[of "(w1)::32 Word.word"]
       word_sint.Rep[of "(w2)::32 Word.word"]
     by auto 
   have sint_eq:"sint((scast w1 + scast w2)::64 Word.word) = sint w1 + sint w2"
     using signed_arith_sint(1)[of "(scast w1)::64 Word.word" "(scast w2)::64 Word.word", OF truth]
       scast_eq1 scast_eq3
     by auto
   have bigOne:"scast w1 + scast w2 <=s ((- 0x7FFFFFFF)::64 Word.word) 
     \<Longrightarrow> \<exists>r'\<le>r1 + r2. r' \<le>  -0x7FFFFFFF"
   proof -
     assume "scast w1 + scast w2 <=s ((- 0x7FFFFFFF)::64 Word.word)"
     then have sum_leq:"sint w1 + sint w2 \<le> - 0x7FFFFFFF"
           and sum_leq':" (sint w1 + sint w2) \<le>  (- 2147483647)"
       using sint_eq unfolding word_sle_eq by auto 
     obtain r'\<^sub>1 r'\<^sub>2 ::real where 
       bound1:"r'\<^sub>1 \<le> r1 \<and> (w1 \<equiv>\<^sub>E r'\<^sub>1)" and
       bound2:"r'\<^sub>2 \<le> r2 \<and> (w2 \<equiv>\<^sub>E r'\<^sub>2)"
       using lo1 lo2 unfolding repL_def by auto
     have somethingA:"r'\<^sub>1 \<le> sint w1" and somethingB:"r'\<^sub>2 \<le> sint w2" 
       using bound1 bound2 \<open>scast w1 + scast w2 <=s -0x7FFFFFFF\<close> word_sle_def notinf1 notinf2 
       unfolding repe.simps by auto
     have something:"r'\<^sub>1 + r'\<^sub>2 \<le>  sint w1 + sint w2"
       using somethingA somethingB add_mono 
       by fastforce  
     show "\<exists>r'\<le>r1 + r2. r' \<le> (-0x7FFFFFFF)"
       apply (rule exI[where x = "r'\<^sub>1 + r'\<^sub>2"])
       using bound1 bound2 add_mono something sum_leq'
       apply (auto intro: order_trans [of _ \<open>signed_real_of_word w1 + signed_real_of_word w2\<close>])
       done      
   qed
   have anImp:"\<And>r'.  (r'\<ge>r1 + r2 \<and> r' \<le>  (- 2147483647)) \<Longrightarrow>
    (\<exists>r. - (2 ^ 31 - 1) = - (2 ^ 31 - 1) \<and> r' = r \<and> r 
         \<le> (real_of_int (sint ((- (2 ^ 31 - 1))::32 Word.word))))"
     by auto
   have anEq:"((scast ((- (2 ^ 31 - 1))::32 Word.word))::64 Word.word) = (- 0x7FFFFFFF)"
     by auto
   have bigTwo:
    "\<not>(((scast POS_INF)::64 Word.word) <=s ?sum) \<Longrightarrow>
     \<not>(?sum <=s ((scast NEG_INF)::64 Word.word)) \<Longrightarrow>
     \<exists>r'\<le>r1 + r2. r' = (real_of_int (sint (scast (((scast w1)::64 Word.word)
                       + ((scast w2)::64 Word.word))::word)))
                \<and> (r' <  0x7FFFFFFF \<and>  (-0x7FFFFFFF) < r')"
   proof -
     assume "\<not>(((scast POS_INF)::64 Word.word) <=s ?sum)"
     then have sum_leq:"sint w1 + sint w2 < 0x7FFFFFFF"
       unfolding word_sle_eq using sint_eq by auto
     then have sum_leq':" (sint w1 + sint w2) < (2147483647)"
       by auto
     assume "\<not>(?sum <=s ((scast NEG_INF)::64 Word.word))"
     then have sum_geq:"(- 0x7FFFFFFF) < sint w1 + sint w2"
       unfolding word_sle_eq using sint_eq by auto
     then have sum_geq':" (- 2147483647) <  (sint w1 + sint w2)"
       by auto
     obtain r'\<^sub>1 r'\<^sub>2 ::real where 
       bound1:"r'\<^sub>1 \<le> r1 \<and> (w1 \<equiv>\<^sub>E r'\<^sub>1)" and
       bound2:"r'\<^sub>2 \<le> r2 \<and> (w2 \<equiv>\<^sub>E r'\<^sub>2)"
        using lo1 lo2 unfolding repL_def by auto
     have somethingA:"r'\<^sub>1  \<le>  sint w1" and somethingB:"r'\<^sub>2 \<le> sint w2" 
       using word_sle_def notinf1 notinf2 bound1 bound2 unfolding repe.simps by auto
     have something:"r'\<^sub>1 + r'\<^sub>2 \<le>  sint w1 + sint w2"
       using somethingA somethingB add_mono 
       by fastforce  
     have "(w1 \<equiv>\<^sub>E r'\<^sub>1)" using bound1 by auto
     then have
           r1w1:"r'\<^sub>1 = (real_of_int (sint w1))"
       and w1U:"(real_of_int (sint w1)) < (real_of_int (sint POS_INF))"
       and w1L:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w1))"
       unfolding repe.simps
       using notinf1 notinf2 notneginf1 notneginf2 by (auto)
     have "(w2 \<equiv>\<^sub>E r'\<^sub>2)" using bound2 by auto
     then have
           r2w1:"r'\<^sub>2 =  (real_of_int (sint w2))"
       and w2U:"(real_of_int (sint w2)) < (real_of_int (sint POS_INF))"
       and w2L:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w2))"
       unfolding repe.simps
       using notinf1 notinf2 notneginf1 notneginf2 by (auto)
     have "sint (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)) 
         = sint ((scast (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)))::word)"
       apply(rule scast_down_range)
       unfolding sint_eq using sints32 sum_geq sum_leq by auto
     then have cast_eq:"(sint ((scast (((scast w1)::64 Word.word) 
         + ((scast w2)::64 Word.word)))::word)) 
       = sint w1 + sint w2"
       using scast_down_range sints32 sum_geq sum_leq sint_eq by auto
     from something and cast_eq 
     have r12_sint_scast:"r'\<^sub>1 + r'\<^sub>2 
       = (sint ((scast (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)))::word))"
       using r1w1 w1U w1L r2w1 w2U w2L 
       by (simp)
     have leq_ref:"\<And>x y ::real. x = y ==> x \<le> y" by auto
     show ?thesis
       apply(rule exI[where x="r'\<^sub>1 + r'\<^sub>2"])
       apply(rule conjI)
       subgoal 
         using r12_sint_scast cast_eq leq_ref r2w1 r1w1 add_mono[of r'\<^sub>1 r1 r'\<^sub>2 r2] bound1 bound2
         by auto
       using bound1 bound2 add_mono r12_sint_scast cast_eq sum_leq sum_leq' sum_geq' sum_geq
       \<open>r'\<^sub>1 + r'\<^sub>2 =  (real_of_int (sint (scast (scast w1 + scast w2))))\<close> 
       by auto
     qed
   have neg_inf_case:"?sum <=s ((scast ((NEG_INF)::word))::64 Word.word)  \<Longrightarrow> NEG_INF \<equiv>\<^sub>L r1 + r2"
   proof (unfold repL_def NEG_INF_def repe.simps)
     assume "scast w1 + scast w2 <=s ((scast ((- (2 ^ 31 - 1))::word))::64 Word.word)"
     then have "scast w1 + scast w2 <=s ((- 0x7FFFFFFF)::64 Word.word)" 
       by (metis anEq)
     then obtain r' where geq:"(r' \<le> r1 + r2)" and leq:"(r' \<le> (-0x7FFFFFFF))"
       using bigOne by auto
     show "(\<exists>r'\<le>plus r1  r2.
       (\<exists>r. uminus (minus(2 ^ 31) 1) = POS_INF \<and> r' = r \<and>  (real_of_int (sint POS_INF)) \<le> r)
     \<or> (\<exists>r. uminus (minus(2 ^ 31) 1) = uminus (minus(2 ^ 31)  1) 
         \<and> r' = r \<and> r \<le>  (real_of_int (sint ((uminus (minus(2 ^ 31) 1))::word))))
     \<or> (\<exists>w. uminus (minus(2 ^ 31) 1) = w \<and>
            r' =  (real_of_int (sint w)) \<and>
             (real_of_int (sint w)) <  (real_of_int (sint POS_INF)) 
         \<and> less ( (real_of_int (sint (uminus (minus(2 ^ 31) 1))))) ((real_of_int (sint w)))))"
     using leq geq
     by (meson dual_order.strict_trans linorder_not_le order_less_irrefl) 
   qed
   have bigThree:"0x7FFFFFFF <=s ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word) 
     \<Longrightarrow> \<exists>r'\<le>r1 + r2. 2147483647 \<le> r'"
   proof -
     assume "0x7FFFFFFF <=s ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)"
     then have sum_leq:"0x7FFFFFFF \<le> sint w1 + sint w2 "
           and sum_leq':" 2147483647 \<le>  (sint w1 + sint w2)"
       using sint_eq unfolding word_sle_eq by auto 
     obtain r'\<^sub>1 r'\<^sub>2 ::real where 
       bound1:"r'\<^sub>1 \<le> r1 \<and> (w1 \<equiv>\<^sub>E r'\<^sub>1)" and
       bound2:"r'\<^sub>2 \<le> r2 \<and> (w2 \<equiv>\<^sub>E r'\<^sub>2)"
       using lo1 lo2 unfolding repL_def by auto
     have somethingA:"r'\<^sub>1  \<le>  sint w1" and somethingB:"r'\<^sub>2  \<le>  sint w2" 
       using \<open> 0x7FFFFFFF <=s scast w1 + scast w2 \<close> word_sle_def notinf1 notinf2
         bound1 bound2 repe.simps
       by auto
     have something:"r'\<^sub>1 + r'\<^sub>2 \<le>  sint w1 + sint w2"
       using somethingA somethingB add_mono of_int_add  
       by fastforce  
     show "\<exists>r'\<le> r1 + r2.  (2147483647) \<le> r'"
       apply(rule exI[where x = "r'\<^sub>1 + r'\<^sub>2"])
       using bound1 bound2 add_mono something sum_leq' order.trans
     proof -
       have f1: " (real_of_int (sint w2)) = r'\<^sub>2"
         by (metis bound2 notinf2 notneginf2 repe.cases)
       have " (real_of_int (sint w1)) = r'\<^sub>1"
         by (metis bound1 notinf1 notneginf1 repe.cases)
       then have f2: " (real_of_int 2147483647) \<le> r'\<^sub>2 + r'\<^sub>1"
         using f1 sum_leq' by auto
       have "r'\<^sub>2 + r'\<^sub>1 \<le> r2 + r1"
         by (meson add_left_mono add_right_mono bound1 bound2 order.trans)
       then show "r'\<^sub>1 + r'\<^sub>2 \<le> r1 + r2 \<and>  2147483647 \<le> r'\<^sub>1 + r'\<^sub>2"
         using f2 by (simp add: add.commute)
     qed
   qed
   have inf_case:"((scast POS_INF)::64 Word.word) <=s ?sum \<Longrightarrow> POS_INF \<equiv>\<^sub>L r1 + r2"
     proof -
       assume "((scast POS_INF)::64 Word.word) 
           <=s ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)"
       then have "((scast ((2 ^ 31 - 1)::word))::64 Word.word) 
              <=s ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)"
         unfolding  repL_def repe.simps by auto
       then have "(0x7FFFFFFF::64 Word.word) 
              <=s ((scast w1)::64 Word.word) + ((scast w2)::64 Word.word)"
         by auto
       then obtain r' where geq:"(r' \<le> r1 + r2)" and leq:"(0x7FFFFFFF \<le> r')"
         using bigThree by auto
       show "?thesis"
         unfolding repL_def repe.simps using leq geq by auto
     qed
   have int_case:"\<not>(((scast POS_INF)::64 Word.word) <=s ?sum) 
     \<Longrightarrow> \<not> (?sum <=s ((scast NEG_INF)::64 Word.word)) 
     \<Longrightarrow> ((scast ?sum)::word) \<equiv>\<^sub>L r1 + r2"
   proof -
     assume bound1:"\<not> ((scast POS_INF)::64 Word.word) <=s scast w1 + scast w2"
     assume bound2:"\<not> scast w1 + scast w2 <=s ((scast NEG_INF)::64 Word.word)"
     obtain r'::real  
       where rDef:"r' = (real_of_int (sint ((scast (((scast w1)::64 Word.word) 
                      + ((scast w2)::64 Word.word)))::word)))"
       and r12:"r'\<le>r1 + r2" 
       and boundU:"r' <  0x7FFFFFFF" 
       and boundL:" (-0x7FFFFFFF) < r'"
       using bigTwo[OF bound1 bound2] by auto
     obtain w::word 
     where wdef:"w = (scast (((scast w1)::64 Word.word) + ((scast w2)::64 Word.word))::word)"
       by auto
     then have wr:"r' =  (real_of_int (sint w))"
       using r12 bound1 bound2 rDef by blast
     show ?thesis
       unfolding repL_def repe.simps 
       using r12 wdef rDef boundU boundL wr  
       by auto 
   qed
   have "(let sum = ?sum in
     if scast POS_INF <=s sum then POS_INF 
     else if sum <=s scast NEG_INF then NEG_INF 
     else scast sum) \<equiv>\<^sub>L r1 + r2"
     apply(cases "((scast POS_INF)::64 Word.word) <=s ?sum")
      apply(cases "?sum <=s scast NEG_INF")
       using inf_case neg_inf_case int_case by (auto simp add: Let_def)
   then show ?thesis 
     using notinf1 notinf2 notneginf1 notneginf2
     by(auto)
 qed
 qed
 
 subsection \<open>Max function\<close>
 
 text\<open>Maximum of w1 + w2 in 2s-complement\<close>
 fun wmax :: "word \<Rightarrow> word \<Rightarrow> word"
 where "wmax w1 w2 = (if w1 <s w2 then w2 else w1)"
 
 text\<open>Correctness of wmax\<close>
 lemma wmax_lemma:
   assumes eq1:"w1 \<equiv>\<^sub>E (r1::real)"
   assumes eq2:"w2 \<equiv>\<^sub>E (r2::real)"
   shows "wmax w1 w2 \<equiv>\<^sub>E (max r1 r2)"
 proof(cases rule: case_inf2[where ?w1.0=w1, where ?w2.0=w2])
   case PosPos
   from PosPos eq1 eq2
   have bound1:"(real_of_int (sint POS_INF)) \<le> r1"
   and bound2:"(real_of_int (sint POS_INF)) \<le> r2"
     by (auto simp add: repe.simps)
   have eqInf:"wmax w1 w2 = POS_INF"
     using PosPos unfolding wmax.simps by auto
   have pos_eq:"POS_INF \<equiv>\<^sub>E max r1 r2"
     apply(rule repPOS_INF)
     using bound1 bound2
     by linarith
   show ?thesis
     using pos_eq eqInf by auto
 next
   case PosNeg
   from PosNeg 
   have bound1:"(real_of_int (sint POS_INF)) \<le> r1"
    and bound2:"r2 \<le> (real_of_int (sint NEG_INF))"
     using eq1 eq2 by (auto simp add: repe.simps)
   have eqNeg:"wmax w1 w2 = POS_INF"
     unfolding eq1 eq2 wmax.simps PosNeg word_sless_def word_sle_def
     by(auto) 
   have neg_eq:"POS_INF \<equiv>\<^sub>E max r1 r2"
     apply(rule repPOS_INF)
     using bound1 bound2 eq1 eq2 by auto
   show "?thesis"
     using eqNeg neg_eq by auto
 next
   case PosNum
   from PosNum eq1 eq2
   have bound1:" (real_of_int (sint POS_INF)) \<le> r1"
   and bound2a:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w2))"
   and bound2b:" (real_of_int (sint w2)) <  (real_of_int (sint POS_INF))"
     by (auto simp add: repe.simps)
   have eqNeg:"wmax w1 w2 = POS_INF"
     using PosNum bound2b 
     unfolding wmax.simps word_sless_def word_sle_def
     by auto 
   have neg_eq:"POS_INF \<equiv>\<^sub>E max r1 r2"
     apply (rule repPOS_INF)
     using bound1 bound2a bound2b word_sless_alt le_max_iff_disj 
     unfolding eq1 eq2 by blast
   show "?thesis"
     using eqNeg neg_eq by auto
 next
   case NegPos
   from NegPos eq1 eq2
   have bound1:"r1 \<le>  (real_of_int (sint NEG_INF))"
    and bound2:" (real_of_int (sint POS_INF)) \<le> r2"
     by (auto simp add: repe.simps)
   have eqNeg:"wmax w1 w2 = POS_INF"
     unfolding NegPos word_sless_def word_sle_def
     by(auto)
   have neg_eq:"POS_INF \<equiv>\<^sub>E max r1 r2"
     apply(rule repPOS_INF)
     using bound1 bound2 by auto
   show "wmax w1 w2 \<equiv>\<^sub>E max r1 r2"
     using eqNeg neg_eq by auto
 next
   case NegNeg
   from NegNeg eq1 eq2
   have bound1:"r1 \<le>  (real_of_int (sint NEG_INF))"
    and bound2:"r2 \<le>  (real_of_int (sint NEG_INF))"
     by (auto simp add: repe.simps)
   have eqNeg:"NEG_INF \<equiv>\<^sub>E max r1 r2"
     apply(rule repNEG_INF)
     using eq1 eq2 bound1 bound2
     by(auto)
   have neg_eq:"wmax w1 w2 = NEG_INF"
     using NegNeg by auto 
   show "wmax w1 w2 \<equiv>\<^sub>E max r1 r2"
     using eqNeg neg_eq by auto
 next
   case NegNum
   from NegNum eq1 eq2
   have eq3:"r2 = (real_of_int (sint w2))"
    and bound2a:"(real_of_int (sint w2)) < (real_of_int (sint POS_INF))"
    and bound2b:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w2))"
    and bound1:"r1 \<le> (real_of_int (sint NEG_INF))"
     by (auto simp add: repe.simps)
   have eqNeg:"max r1 r2 = (real_of_int (sint w2))"
     using NegNum assms(2) bound2a eq3 repeInt_simps bound1 bound2a bound2b
     by (metis less_irrefl max.bounded_iff max_def not_less)
   then have extra_eq:"(wmax w1 w2) = w2"
     using assms(2) bound2a eq3 NegNum repeInt_simps 
     by (simp add: word_sless_alt)
   have neg_eq:"wmax w1 w2 \<equiv>\<^sub>E (real_of_int (sint (wmax w1 w2)))"
     apply(rule repINT)
     using extra_eq eq3 bound2a bound2b by(auto)
   show "wmax w1 w2 \<equiv>\<^sub>E max r1 r2"
     using eqNeg neg_eq extra_eq by auto
 next
   case NumPos
   from NumPos eq1 eq2
   have p2:"w2 = POS_INF"
    and eq1:"r1 = (real_of_int (sint w1))"
    and eq2:"r2 = r2"
    and bound1a:"(real_of_int (sint w1)) < (real_of_int (sint POS_INF))"
    and bound1b:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w1))"
    and bound2:"(real_of_int (sint POS_INF)) \<le> r2"
     by (auto simp add: repe.simps)    
   have res1:"wmax w1 w2 = POS_INF"
     using NumPos p2 eq1 eq2 assms(1) bound1b p2 repeInt_simps 
     by (simp add: word_sless_alt)
   have res3:"POS_INF \<equiv>\<^sub>E max r1 r2"
     using repPOS_INF NumPos bound2 le_max_iff_disj by blast
   show "wmax w1 w2 \<equiv>\<^sub>E max r1 r2" 
     using res1 res3 by auto
 next
   case NumNeg
   from NumNeg eq1 eq2
   have n2:"w2 = NEG_INF"
    and rw1:"r1 = (real_of_int (sint w1))"
    and bound1a:"(real_of_int (sint w1)) < (real_of_int (sint POS_INF))"
    and bound1b:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w1))"
    and bound2:"r2 \<le> (real_of_int (sint NEG_INF))"
     by (auto simp add: repe.simps)    
   have res1:"max r1 r2 = (real_of_int (sint (wmax w1 w2)))"
     using bound1b bound2 NumNeg less_trans wmax.simps of_int_less_iff 
       word_sless_alt rw1 antisym_conv2 less_imp_le max_def
     by metis
   have res2:"wmax w1 w2 \<equiv>\<^sub>E (real_of_int (sint (wmax w1 w2)))"
     apply(rule repINT)
     using bound1a bound1b bound2 NumNeg leD leI less_trans n2 wmax.simps 
     by (auto simp add: word_sless_alt)
   show "wmax w1 w2 \<equiv>\<^sub>E max r1 r2"
     using res1 res2 by auto
 next
   case NumNum
   from NumNum eq1 eq2
   have eq1:"r1 = (real_of_int (sint w1))"
    and eq2:"r2 = (real_of_int (sint w2))"
    and bound1a:"(real_of_int (sint w1)) < (real_of_int (sint POS_INF))"
    and bound1b:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w1))"
    and bound2a:"(real_of_int (sint w2)) < (real_of_int (sint POS_INF))"
    and bound2b:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w2))"
     by (auto simp add: repe.simps)    
   have res1:"max r1 r2 = (real_of_int (sint (wmax w1 w2)))"
     using eq1 eq2 bound1a bound1b bound2a bound2b
     apply (auto simp add: max_def word_sless_alt not_less; transfer)
      apply simp_all
     done
   have res2:"wmax w1 w2 \<equiv>\<^sub>E (real_of_int (sint (wmax w1 w2)))"
     apply (rule repINT)
     using bound1a bound1b bound2a bound2b
     by (simp add: \<open>max r1 r2 =  (real_of_int (sint (wmax w1 w2)))\<close> eq2 min_less_iff_disj)+
   show "wmax w1 w2 \<equiv>\<^sub>E max r1 r2"
     using res1 res2 by auto
 qed
 
 lemma max_repU1:
   assumes "w1 \<equiv>\<^sub>U x"
   assumes "w2 \<equiv>\<^sub>U y"
   shows "wmax w1 w2 \<equiv>\<^sub>U x "
   using wmax_lemma assms repU_def
   by (meson le_max_iff_disj)
   
 lemma max_repU2:
   assumes "w1 \<equiv>\<^sub>U y"
   assumes "w2 \<equiv>\<^sub>U x"
   shows "wmax w1 w2 \<equiv>\<^sub>U x"
   using wmax_lemma assms repU_def
   by (meson le_max_iff_disj)
 
 text\<open>Product of w1 * w2 with bounds checking\<close>
 fun wtimes :: "word \<Rightarrow> word \<Rightarrow> word"
 where "wtimes w1 w2 =
  (if w1 = POS_INF \<and> w2 = POS_INF then POS_INF
   else if w1 = NEG_INF \<and> w2 = POS_INF then NEG_INF
   else if w1 = POS_INF \<and> w2 = NEG_INF then NEG_INF
   else if w1 = NEG_INF \<and> w2 = NEG_INF then POS_INF
   
   else if w1 = POS_INF \<and> w2 <s 0 then NEG_INF 
   else if w1 = POS_INF \<and> 0 <s w2 then POS_INF 
   else if w1 = POS_INF \<and> 0 = w2 then 0 
   else if w1 = NEG_INF \<and> w2 <s 0 then POS_INF 
   else if w1 = NEG_INF \<and> 0 <s w2 then NEG_INF 
   else if w1 = NEG_INF \<and> 0 = w2 then 0 
   
   else if w1 <s 0 \<and> w2 = POS_INF then NEG_INF 
   else if 0 <s w1 \<and> w2 = POS_INF then POS_INF 
   else if 0 = w1 \<and> w2 = POS_INF then 0
   else if w1 <s 0 \<and> w2 = NEG_INF then POS_INF 
   else if 0 <s w1 \<and> w2 = NEG_INF then NEG_INF 
   else if 0 = w1 \<and> w2 = NEG_INF then 0 
   
   else 
   (let prod::64 Word.word = (scast w1) * (scast w2) in
    if prod <=s (scast NEG_INF) then NEG_INF
    else if (scast POS_INF) <=s prod then POS_INF
    else (scast prod)))"
 
 
 subsection \<open>Multiplication upper bound\<close>
 text\<open>Product of 32-bit numbers fits in 64 bits\<close>
 lemma times_upcast_lower:
   fixes x y::int
   assumes a1:"x \<ge> -2147483648"
   assumes a2:"y \<ge> -2147483648"
   assumes a3:"x \<le> 2147483648"
   assumes a4:"y \<le> 2147483648"
   shows "- 4611686018427387904 \<le>  x * y"
 proof -
   let ?thesis = "- 4611686018427387904 \<le> x * y"
   have is_neg:"- 4611686018427387904 < (0::int)" by auto
   have case1:"x \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> ?thesis"
     proof -
       assume a5:"x \<ge> 0" and a6:"y \<ge> 0"
       have h1:"x * y \<ge> 0"
         using a5 a6 by (simp add: zero_le_mult_iff)
       then show ?thesis using is_neg by auto
     qed
   have case2:"x \<le> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> ?thesis" 
     proof -
       assume a5:"x \<le> 0" and a6:"y \<ge> 0"
       have h1:"-2147483648 * (2147483648) \<le> x * 2147483648"
         using a1 a2 a3 a4 a5 a6 by linarith
       have h2:"-2147483648 \<le> y" using a6 by auto
       have h3:"x * 2147483648 \<le> x * y" 
         using a1 a2 a3 a4 a5 a6 h2 
         using mult_left_mono_neg by blast
       show ?thesis using h1 h2 h3 by auto
     qed
   have case3:"x \<ge> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> ?thesis"
     proof -
       assume a5:"x \<ge> 0" and a6:"y \<le> 0"
       have h1:"2147483648 * (-2147483648) \<le> 2147483648 * y"
         using a1 a2 a3 a4 a5 a6 by linarith
       have h2:"-2147483648 \<le> x" using a5 by auto
       have h3:"2147483648 * y \<le> x * y" 
         using a1 a2 a3 a4 a5 a6 h2 
         using mult_left_mono_neg mult_right_mono_neg by blast
       show ?thesis using h1 h2 h3 by auto
     qed
   have case4:"x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> ?thesis"
   proof -
       assume a5:"x \<le> 0" and a6:"y \<le> 0"
       have h1:"x * y \<ge> 0"
         using a5 a6 by (simp add: zero_le_mult_iff)
       then show ?thesis using is_neg by auto
     qed
   show ?thesis
     using case1 case2 case3 case4 by linarith
 qed
 
 text\<open>Product of 32-bit numbers fits in 64 bits\<close>
 lemma times_upcast_upper:
   fixes x y ::int
   assumes a1:"x \<ge> -2147483648"
   assumes a2:"y \<ge> -2147483648"
   assumes a3:"x \<le> 2147483648"
   assumes a4:"y \<le> 2147483648"
   shows "x * y \<le> 4611686018427387904" 
 proof -
   let ?thesis = "x * y \<le> 4611686018427387904"
   have case1:"x \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> ?thesis"
     proof -
       assume a5:"x \<ge> 0" and a6:"y \<ge> 0"
       have h1:"2147483648 * 2147483648 \<ge> x * 2147483648"
         using a1 a2 a3 a4 a5 a6 by linarith
       have h2:"x * 2147483648 \<ge> x * y" 
         using a1 a2 a3 a4 a5 a6 by (simp add: mult_mono)
       show ?thesis using h1 h2 by auto
     qed
   have case2:"x \<le> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> ?thesis"
     proof -
       assume a5:"x \<le> 0" and a6:"y \<ge> 0"
       have h1:"2147483648 * 2147483648 \<ge> (0::int)" by auto
       have h2:"0 \<ge> x * y"
         using a5 a6 mult_nonneg_nonpos2 by blast
       show ?thesis using h1 h2 by auto
     qed
   have case3:"x \<ge> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> ?thesis"
     proof -
       assume a5:"x \<ge> 0" and a6:"y \<le> 0"
       have h1:"2147483648 * 2147483648 \<ge> (0::int)" by auto
       have h2:"0 \<ge> x * y"
         using a5 a6 mult_nonneg_nonpos by blast
       show ?thesis using h1 h2 by auto
     qed
   have case4:"x \<le> 0 \<Longrightarrow> y \<le> 0 \<Longrightarrow> ?thesis"
     proof -
       assume a5:"x \<le> 0" and a6:"y \<le> 0"
       have h1:"-2147483648 * -2147483648 \<ge> x * -2147483648"
         using a1 a2 a3 a4 a5 a6 by linarith
       have h2:"x * -2147483648 \<ge> x * y" 
         using a1 a2 a3 a4 a5 a6 mult_left_mono_neg by blast
       show ?thesis using h1 h2 by auto
     qed
 show "x * y \<le> 4611686018427387904"
   using case1 case2 case3 case4
   by linarith
 qed
    
 text\<open>Correctness of 32x32 bit multiplication\<close>
 
 subsection \<open>Exact multiplication\<close>
 lemma wtimes_exact:
 assumes eq1:"w1 \<equiv>\<^sub>E r1"
 assumes eq2:"w2 \<equiv>\<^sub>E r2"
 shows "wtimes w1 w2 \<equiv>\<^sub>E r1 * r2"
 proof -
   have POS_cast:"sint ((scast POS_INF)::64 Word.word) = sint POS_INF"
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have POS_sint:"sint POS_INF = (2^31)-1"  by auto
   have w1_cast:"sint ((scast w1)::64 Word.word) = sint w1"
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have w2_cast:"sint ((scast w2)::64 Word.word) = sint w2"
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have NEG_cast:"sint ((scast NEG_INF)::64 Word.word) = sint NEG_INF"
     apply(rule Word.sint_up_scast)
     unfolding Word.is_up by auto
   have rangew1:"sint ((scast w1)::64 Word.word) \<in> {- (2 ^ 31).. (2^31)} " 
     using word_sint.Rep[of "(w1)::32 Word.word"] sints32 len32 mem_Collect_eq POS_cast w1_cast 
     by auto
   have rangew2:"sint ((scast w2)::64 Word.word) \<in> {- (2 ^ 31).. (2^31)} " 
     using word_sint.Rep[of "(w2)::32 Word.word"] sints32 len32 mem_Collect_eq POS_cast w2_cast 
     by auto
   show ?thesis
 proof (cases rule: case_times_inf[of w1 w2])
   case PosPos then
   have a1: "PosInf \<le> r1"
   and  a2: "PosInf \<le> r2" 
     using "PosPos" eq1 eq2 repe.simps by (auto)
   have f3: "\<And>n e::real.  1 \<le> max ( (numeral n)) e"
     by (simp add: le_max_iff_disj)
   have "\<And>n e::real. 0 \<le> max ( (numeral n)) e"
     by (simp add: le_max_iff_disj)
   then have "r1 \<le> r1 * r2"
     using f3 "PosPos" eq1 eq2 repe.simps
     using eq1 eq2 by (auto simp add: repe.simps)
   then have "PosInf \<le> r1 * r2"
     using a1 by linarith
   then show ?thesis
     using "PosPos"  by(auto simp add: repe.simps)
 next
   case NegPos
   from "NegPos" have notPos:"w1 \<noteq> POS_INF" unfolding POS_INF_def NEG_INF_def by auto
   have a1: "NegInf \<ge> r1"
     using eq1 "NegPos" by (auto simp add: repe.simps)
   have a2: "PosInf \<le> r2"
     using eq2 "NegPos" by (auto simp add: repe.simps)
   have f1: "real_of_int Numeral1 = 1"
     by simp
   have f3: "(real_of_int 3) \<le> - r1"
     using a1 by (auto)
   have f4:"0 \<le> r2"
     using f1 a2 by(auto)
   have f5: "r1 \<le>  - 1"
     using f3 by auto
   have fact:"r1 * r2 \<le> - r2"
     using f5 f4 mult_right_mono by fastforce
   show ?thesis
     using a1 a2 fact by (auto simp add: repe.simps "NegPos")
 next
   case PosNeg
   have a1: "PosInf \<le> r1"
     using eq1 "PosNeg" by (auto simp add: repe.simps)
   then have h1:"r1 \<ge> 1"
     by (auto)
   have a2: " NegInf \<ge> r2"
     using eq2 "PosNeg" by (auto simp add: repe.simps)
   have f1: "\<not>  NegInf *  (- 1) \<le> 1"
     by (auto)
   have f2: "\<forall>e ea::real. (e *  (- 1) \<le> ea) = (ea *  (- 1) \<le> e)" by force
   then have f3: "\<not> 1 *  (- 1::real) \<le>  NegInf"
     using f1 by blast
   have f4: "r1 *  (- 1) \<le>  NegInf"
     using f2 a1 
     by(auto)
   have f5: "\<forall>e ea eb. (if (ea::real) \<le> eb then e \<le> eb else e \<le> ea) = (e \<le> ea \<or> e \<le> eb)"
     by force
   have " 0 *  (- 1::real) \<le> 1"
     by simp
   then have "r1 *  (- 1) \<le>  0"
     using f5 f4 f3 f2 by meson
   then have f6: "0 \<le> r1" by fastforce
   have "1 *  (- 1) \<le>  (- 1::real)"
     using f2 by force
   then have fact:"r2 \<le>  (- 1)"
     using f3 a2 by fastforce
   have rule:"\<And>c. c > 0 \<Longrightarrow> r1 \<ge> c \<and> r2 \<le> -1 \<Longrightarrow> r1 * r2 \<le> -c"
     apply auto
     by (metis (no_types, hide_lams) f5 mult_less_cancel_left_pos 
         mult_minus1_right neg_le_iff_le not_less)
   have "r1 * r2 \<le> NegInf"
     using "PosNeg" f6 fact rule[of PosInf] a1
     by(auto)
   then show ?thesis
     using "PosNeg" by (auto simp add: repe.simps)
 next
   case NegNeg
   have a1: "(-2147483647) \<ge> r1"
     using eq1 "NegNeg" by (auto simp add: repe.simps)
   then have h1:"r1 \<le> -1"
     using max.bounded_iff max_def one_le_numeral
     by auto
   have a2: " (-2147483647) \<ge> r2"
     using eq2 "NegNeg" by (auto simp add: repe.simps)
   have f1: "\<forall>e ea eb. \<not> (e::real) \<le> ea \<or> \<not> 0 \<le> eb \<or> eb * e \<le> eb * ea"
     using mult_left_mono by metis
   have f2: "-  1 =  (- 1::real)"
     by force
   have f3: " 0 \<le>  (1::real)"
     by simp
   have f4: "\<forall>e ea eb. (ea::real) \<le> e \<or> \<not> ea \<le> eb \<or> \<not> eb \<le> e"
     by (meson less_le_trans not_le)
   have f5: " 0 \<le>  (2147483647::real)"
     by simp
   have f6: "-  (- 2147483647) =  (2147483647::real)"
     by force
   then have f7: "- ( (- 2147483647) * r1) =  (2147483647 * r1)"
     by (metis mult_minus_left)
   have f8: "- ( (- 2147483647) *  (- 1)) =  2147483647 *  (- 1::real)"
     by simp
   have " 2147483647 = -  1 *  (- 2147483647::real)"
     by simp
   then have f9: "r1 \<le>  (- 1) \<longrightarrow>  2147483647 \<le> r1 *  (- 2147483647)"
     using f8 f7 f5 f2 f1 by linarith
   have f10: "-  2147483647 =  (- 2147483647::real)"
     by fastforce
   have f11: "- (r2 *  1 * (r1 *  (- 1))) = r1 * r2"
     by (simp add: mult.commute)
   have f12: "r1 *  (- 1) = - (r1 *  1)"
     by simp
   have "r1 *  1 * ( (- 2147483647) *  1) =  (- 2147483647) * r1"
     by (simp add: mult.commute)
   then have f13: "r1 *  (- 1) * ( (- 2147483647) *  1) =  2147483647 * r1"
     using f12 f6 by (metis (no_types) mult_minus_left)
   have " 1 * r1 \<le>  1 *  (- 2147483647)"
     using a1 
     by (auto simp add: a1)
   then have " 2147483647 \<le> r1 *  (- 1)" by fastforce
   then have "0 \<le> r1 *  (- 1)"
     using f5 f4 by (metis)
   then have "r1 \<le>  (- 1) \<and> - (r1 *  2147483647) \<le> - (r2 *  1 * (r1 *  (- 1)))"
     by (metis a2 f11 h1 mult_left_mono_neg minus_mult_right mult_minus1_right neg_0_le_iff_le)
   then have "r1 \<le>  (- 1) \<and> r1 *  (- 2147483647) \<le> r2 * r1"
     using f11 f10 by (metis mult_minus_left mult.commute)
   then have fact:" 2147483647 \<le> r2 * r1"
     using f9 f4 by blast
   show ?thesis
     using a1 a2 h1 fact
     by (auto simp add: repe.simps "NegNeg" mult.commute)
 next
   case PosLo
   from "PosLo"
   have w2NotPinf:"w2 \<noteq> POS_INF" and w2NotNinf:"w2 \<noteq> NEG_INF" by (auto)
   from eq1 "PosLo" 
   have upper:" (real_of_int (sint POS_INF)) \<le> r1 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w2 < 0" using "PosLo" 
     apply (auto simp add: word_sless_def word_sle_def)   
     by (simp add: dual_order.order_iff_strict)
   then have lower2:"sint w2 \<le> -1" by auto
   from eq2 have rw2:"r2 =  (real_of_int (sint w2))" 
     using repe.simps "PosLo"  
     by (auto simp add: repe.simps)
   have f4: "r1 *  (- 1) \<le>  (- 2147483647)"
     using upper by (auto)
   have f5: "r2 \<le>  (- 1)"
     using lower2 rw2 by transfer simp
   have "0 < r1"
     using upper by (auto) 
   have "\<forall>r. r < - 2147483647 \<or> \<not> r < r1 * - 1"
     using f4 less_le_trans by blast
   then have "r1 *  (real_of_int (sint w2)) \<le>  (- 2147483647)"
     using f5 f4 upper lower2 rw2 mult_left_mono
     by (metis \<open>0 < r1\<close> dual_order.order_iff_strict f5 mult_left_mono rw2)
   then have "r1 * r2 \<le> real_of_int (sint NEG_INF)" 
     using upper lower2  rw2 
     by (auto)
   then show ?thesis
     using "PosLo" by (auto simp add: repe.simps)
 next
   case PosHi
   from "PosHi"
   have w2NotPinf:"w2 \<noteq> POS_INF" and w2NotNinf:"w2 \<noteq> NEG_INF" 
     by (auto)
   from eq1 "PosHi" 
   have upper:"(real_of_int (sint POS_INF)) \<le> r1 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w2 > 0" using "PosHi" 
     apply (auto simp add: word_sless_def word_sle_def)   
     by (simp add: dual_order.order_iff_strict)
   then have lower2:"sint w2 \<ge> 1" by auto
   from eq2 have rw2:"r2 =  (real_of_int (sint w2))" 
     using repe.simps "PosHi"
     by (auto) 
   have "0 \<le> r1" using upper by (auto)
   then have "r1 \<le> r1 * r2"
     using rw2 lower2 by (metis (no_types)  mult_left_mono mult.right_neutral of_int_1_le_iff)
   have "PosInf \<le> r1 * r2"
       using upper lower2 rw2 
       apply (auto)
       using \<open>0 \<le> r1\<close> mult_numeral_1_right numeral_One of_int_1_le_iff zero_le_one
       apply simp
       using mult_mono [of 2147483647 r1 1 \<open>signed_real_of_word (w2::32 Word.word)\<close>]
       apply simp
       apply transfer
       apply simp
       done
   then show ?thesis
   using "PosHi" by (auto simp add: repe.simps)
 next
   case PosZero
   from "PosZero"
   have w2NotPinf:"w2 \<noteq> POS_INF" and w2NotNinf:"w2 \<noteq> NEG_INF"
     by (auto)
   from eq1 "PosZero"
   have upper:" (real_of_int (sint POS_INF)) \<le> r1 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w2 = 0" using "PosZero" 
     by (auto simp add: word_sless_def word_sle_def)   
   from eq2 have rw2:"r2 =  (real_of_int (sint w2))" 
     using repe.simps "PosZero" 
     by auto 
   have "0 = r1 * r2"
     using "PosZero" rw2 by auto
   then show ?thesis
     using "PosZero" by (auto simp add: repe.simps)
 next
   case NegHi
   have w2NotPinf:"w2 \<noteq> POS_INF" and w2NotNinf:"w2 \<noteq> NEG_INF" 
     using "NegHi" by (auto)
   from eq1 "NegHi" 
   have upper:"(real_of_int (sint NEG_INF)) \<ge> r1 " 
     by (auto simp add: repe.simps)
   have low:"sint w2 > 0" using "NegHi"
     apply (auto simp add: word_sless_def word_sle_def)
     by (simp add: dual_order.order_iff_strict)
   then have lower1:"(real_of_int (sint w2)) > 0"
     by transfer simp
   then have lower2:"(real_of_int (sint w2)) \<ge> 1"  
     using low by transfer simp
 
   from eq1 have rw1:"r1 \<le> (real_of_int (sint w1))" 
     using repe.simps "NegHi" 
     by (simp add: upper)
   from eq2 have rw2:"r2 = (real_of_int (sint w2))" 
     using repe.simps "NegHi"
     by (auto)
   have mylem:"\<And>x y z::real. x \<le> -1 \<Longrightarrow> y \<ge> 1 \<Longrightarrow> z \<le> -1 \<Longrightarrow> x \<le> z \<Longrightarrow>  x * y \<le> z"
     proof -
     fix x y z::real
     assume a1:"x \<le> -1"
     assume a2:"y \<ge> 1"
     then have h1:"-1 \<ge> -y" by auto
     assume a3:"z \<le> -1"
     then have a4:"z < 0"  by auto
     from a4 have h2:"-z > 0"  using leD leI by auto
     from a3 have h5:"-z \<ge> 1"  by (simp add: leD leI)
     assume a5:"x \<le> z"
     then have h6:"-x \<ge> -z" by auto
     have h3:"-x * -z = x * z" by auto
     show "x * y \<le> z"
       using a1 a2 a3 a5 a4 h1 h2 h3 h6 h5 a5 dual_order.trans leD mult.right_neutral
       by (metis dual_order.order_iff_strict mult_less_cancel_left2)
     qed
   have prereqs:"r1 \<le> - 1" "1 
       \<le> (real_of_int (sint w2))" " (- 2147483647::real) \<le> - 1 " "r1 \<le> (-2147483647)"
     using rw1 rw2 "NegHi" lower2 by (auto simp add: word_sless_def word_sle_def)
   have "r1 * r2 \<le> real_of_int (sint NEG_INF)"
     using upper lower1 lower2 rw1 rw2 
     apply (auto simp add: word_sless_def word_sle_def)
     using mylem[of  "r1" " (real_of_int (sint w2))" " (- 2147483647)"] prereqs
     by auto
   then show ?thesis
     using "NegHi" by (auto simp add: repe.simps)
 next
   case NegLo
   from "NegLo"
   have w2NotPinf:"w2 \<noteq> POS_INF" and w2NotNinf:"w2 \<noteq> NEG_INF" 
     by (auto)
   from eq1 "NegLo" 
   have upper:"(real_of_int (sint NEG_INF)) \<ge> r1" 
   by (auto simp add: repe.simps)
   have low:"sint w2 < 0" using "NegLo"
     by (auto simp add: word_sless_def word_sle_def dual_order.order_iff_strict)
   then have lower1:"(real_of_int (sint w2)) < 0"
     by transfer simp
   from eq1 have rw1:"r1 \<le>  (real_of_int (sint w1))" 
     using repe.simps "NegLo"
     by (simp add: upper)
   from eq2 have rw2:"r2 =  (real_of_int (sint w2))" 
     using repe.simps "NegLo"
     by (auto)
   have hom:"(- 2147483647) = -(2147483647::real)" by auto
   have mylem:"\<And>x y z::real. y < 0 \<Longrightarrow>   x \<le> y \<Longrightarrow> z \<le> -1 \<Longrightarrow> -y \<le> x * z"
     proof -
     fix x y z::real
     assume a1:"y < 0"
     assume a2:"x \<le> y"
     then have h1:"-x \<ge> -y" by auto
     assume a3:"z \<le> -1"
     then have a4:"z < 0" 
       by auto
     from a4 have h2:"-z > 0" using leD leI by auto
     from a3 have h5:"-z \<ge> 1" by (simp add: leD leI)
     have h4:"-x * -z \<ge> -y"
       using  a1 a2 a3 a4 h1 h2 h5 dual_order.trans mult.right_neutral
       by (metis mult.commute neg_0_less_iff_less mult_le_cancel_iff1)
     have h3:"-x * -z = x * z" by auto
     show "- y \<le> x * z "
       using a1 a2 a3 a4 h1 h2 h3 h4 h5 
       by simp
     qed
   have prereqs:"- 2147483647 < (0::real)" " r1 \<le> - 2147483647"
     using rw1 rw2 "NegLo" by (auto simp add: word_sless_def word_sle_def)
   moreover have \<open>sint w2 \<le> - 1\<close>
     using low by simp
   then have \<open>real_of_int (sint w2) \<le> real_of_int (- 1)\<close>
     by (simp only: of_int_le_iff)
   then have \<open>signed_real_of_word w2 \<le> - 1\<close>
     by simp
   ultimately have "2147483647 \<le> r1 * r2" 
     using upper lower1 rw1 rw2
       mylem[of "-2147483647" "r1" "(real_of_int (sint w2))"] 
     by (auto simp add: word_sless_def word_sle_def)
   then show ?thesis
     using "NegLo" by (auto simp add: repe.simps)
 next
   case NegZero
   from "NegZero"
   have w2NotPinf:"w2 \<noteq> POS_INF" and w2NotNinf:"w2 \<noteq> NEG_INF" by (auto)
   from eq2 "NegZero" 
   have "r2 = 0" 
     using repe.simps "NegZero"
     by (auto)
   then show ?thesis
     using "NegZero" by (auto simp add: repe.simps)
 next
   case LoPos
   from "LoPos"
   have w2NotPinf:"w1 \<noteq> POS_INF" and w2NotNinf:"w1 \<noteq> NEG_INF" 
     by (auto)
   from eq2 "LoPos" 
   have upper:"(real_of_int (sint POS_INF)) \<le> r2 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w1 < 0" using "LoPos"
     apply (auto simp add: word_sless_def word_sle_def)   
     by (simp add: dual_order.order_iff_strict)
   then have lower2:"sint w1 \<le> -1" by auto
   from eq1 have rw1:"r1 = (real_of_int (sint w1))" 
     using repe.simps "LoPos" by (auto simp add: repe.simps)
   have f4: "r2 * (- 1) \<le> (- 2147483647)"
     using upper by(auto)
   have f5: "r1 \<le> (- 1)"
     using lower2 rw1 by transfer simp
   have "0 < r2"
     using upper by(auto)
   then have "r2 * r1 \<le> r2 * (- 1)"
     by (metis dual_order.order_iff_strict mult_right_mono f5  mult.commute)
   then have "r2 * r1 \<le> (- 2147483647)"
     by (meson f4 less_le_trans not_le)
   then have "(real_of_int (sint w1)) * r2 \<le> (- 2147483647)"
     using f5 f4 rw1 less_le_trans not_le mult.commute rw1 
     by (auto simp add: mult.commute)
   then have "r1 * r2 \<le> NegInf"
     using rw1
     by (auto)
   then show ?thesis
     using "LoPos" by (auto simp: repe.simps)
 next
   case HiPos
   from "HiPos"
   have w2NotPinf:"w1 \<noteq> POS_INF" and w2NotNinf:"w1 \<noteq> NEG_INF" 
     by (auto)
   from eq2 "HiPos"
   have upper:"(real_of_int (sint POS_INF)) \<le> r2 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w1 > 0" using "HiPos"
     by (auto simp add: word_sless_def word_sle_def dual_order.order_iff_strict)
   then have lower2:"sint w1 \<ge> 1" by auto
   from eq1 have rw2:"r1 =  (real_of_int (sint w1))" 
     using "HiPos" 
     by (auto simp add: repe.simps)
   have "0 \<le> r2"
     using upper by(auto)
   then have "r2 \<le> r2 * r1"
     using lower2 rw2 by (metis (no_types) mult_left_mono mult.right_neutral of_int_1_le_iff)
   have "2147483647 \<le> r1 * r2"
     using upper lower2 rw2 
     apply (simp add: word_sless_def word_sle_def)
     using mult_mono [of 1 \<open>signed_real_of_word w1\<close> 2147483647 r2]
     apply simp
     apply transfer
     apply simp
     done
   then show ?thesis
     using "HiPos" by (auto simp add: repe.simps)
 next
   case ZeroPos
   from "ZeroPos"
   have w2NotPinf:"w1 \<noteq> POS_INF" and w2NotNinf:"w1 \<noteq> NEG_INF"
     by (auto)
   from eq2 "ZeroPos" 
   have upper:" (real_of_int (sint POS_INF)) \<le> r2 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w1 = 0" using "ZeroPos" 
     by (auto simp add: word_sless_def word_sle_def)   
   from eq1 have rw2:"r1 =  (real_of_int (sint w1))" 
     using repe.simps "ZeroPos" 
     by (auto)
   have "r1 = 0" using lower1 rw2 by auto
   then show ?thesis
     using "ZeroPos" by (auto simp add: repe.simps)
 next 
   case ZeroNeg
   from "ZeroNeg" 
   have w2NotPinf:"w1 \<noteq> POS_INF" and w2NotNinf:"w1 \<noteq> NEG_INF" 
     by (auto)
   from eq2 "ZeroNeg" 
   have upper:"(real_of_int (sint NEG_INF)) \<ge> r2 " 
     by (auto simp add: repe.simps)
   have lower1:"sint w1 = 0" using "ZeroNeg" 
     by (auto simp add: word_sless_def word_sle_def)   
   from eq1 have rw2:"r1 =  (real_of_int (sint w1))" 
     using repe.simps "ZeroNeg" 
     by (auto)
   have "r1 = 0" using lower1 rw2 by auto
   then show ?thesis
     using "ZeroNeg" by (auto simp add: repe.simps)
 next
   case LoNeg
   from "LoNeg"
   have w2NotPinf:"w1 \<noteq> POS_INF" and w2NotNinf:"w1 \<noteq> NEG_INF"
     by (auto)
   from eq2 "LoNeg" 
   have upper:" (real_of_int (sint NEG_INF)) \<ge> r2 " 
     by (auto simp add: repe.simps)
   have low:"sint w1 < 0" using "LoNeg" 
     apply (auto simp add: word_sless_def word_sle_def)
     by (simp add: dual_order.order_iff_strict)
   then have lower1:"(real_of_int (sint w1)) < 0" by transfer simp
   from low have \<open>sint w1 \<le> - 1\<close>
     by simp
   then have lower2:"(real_of_int (sint w1)) \<le> -1"
     by transfer simp
   from eq1 have rw1:"r2 \<le>  (real_of_int (sint w2))" 
     using "LoNeg" upper by auto
   from eq1 have rw2:"r1 =  (real_of_int (sint w1))" 
     using "LoNeg" by (auto simp add: upper repe.simps)
   have hom:"(- 2147483647::real) = -(2147483647)" by auto
   have mylem:"\<And>x y z::real. y < 0 \<Longrightarrow>   x \<le> y \<Longrightarrow> z \<le> -1 \<Longrightarrow> -y \<le> x * z"
     proof -
     fix x y z::real
     assume a1:"y < 0"
     assume a2:"x \<le> y"
     then have h1:"-x \<ge> -y" by auto
     assume a3:"z \<le> -1"
     then have a4:"z < 0" by auto
     from a4 have h2:"-z > 0" 
       using leD leI by auto
     from a3 have h5:"-z \<ge> 1" 
       by (simp add:  leD leI)
     have h4:"-x * -z \<ge> -y"
       using  a1 a2 a3 a4 h1 h2 h5 dual_order.trans mult_left_mono mult.right_neutral mult.commute
       by (metis dual_order.order_iff_strict mult_minus_right mult_zero_right neg_le_iff_le)
     have h3:"-x * -z = x * z" by auto
     show "- y \<le> x * z "
       using a1 a2 a3 a4 h1 h2 h3 h4 h5 
       by simp
     qed
   have prereqs:"- 2147483647 < (0::real)" " r2 \<le> - 2147483647" " (real_of_int (sint w1)) \<le> - 1"
     using rw1 rw2 "LoNeg" lower2 by (auto simp add: word_sless_def word_sle_def lower2)
   have "2147483647 \<le> r1 * r2"
     using upper lower1 lower2 rw1 rw2 mylem[of "-2147483647" "r2" 
         "(real_of_int (sint w1))"] prereqs
     by (auto simp add:word_sless_def word_sle_def mult.commute)
   then show ?thesis
     using "LoNeg" by (auto simp add: repe.simps)
 next
   case HiNeg
   from HiNeg
   have w1NotPinf:"w1 \<noteq> POS_INF" and w1NotNinf:"w1 \<noteq> NEG_INF"
     by (auto)
   have upper:" (real_of_int (sint NEG_INF)) \<ge> r2 " 
     using HiNeg eq2
     by (auto simp add: repe.simps )
   have low:"sint w1 > 0" using HiNeg 
     apply (auto simp add: word_sless_def word_sle_def)
     by (simp add: dual_order.order_iff_strict)
   then have lower1:"(real_of_int (sint w1)) > 0" by transfer simp
   from low have \<open>sint w1 \<ge> 1\<close>
     by simp
   then have lower2:"(real_of_int (sint w1)) \<ge> 1"  
     by transfer simp
   from eq2 have rw1:"r2 \<le>  (real_of_int (sint w2))" 
     using repe.simps HiNeg by (simp add: upper)
   from eq1 have rw2:"r1 =  (real_of_int (sint w1))" 
     using repe.simps HiNeg  
     by (auto)
   have mylem:"\<And>x y z::real. x \<le> -1 \<Longrightarrow> y \<ge> 1 \<Longrightarrow> z \<le> -1 \<Longrightarrow> x \<le> z \<Longrightarrow>  x * y \<le> z"
     proof -
       fix x y z::real
       assume a1:"x \<le> -1"
       assume a2:"y \<ge> 1"
       then have h1:"-1 \<ge> -y" by auto
       assume a3:"z \<le> -1"
       then have a4:"z < 0" by auto
       from a4 have h2:"-z > 0" 
         using  leD leI by auto
       from a3 have h5:"-z \<ge> 1" 
         by (simp add:  leD leI)
       assume a5:"x \<le> z"
       then have h6:"-x \<ge> -z" by auto
       have h3:"-x * -z = x * z" by auto
       show "x * y \<le> z"
         using a1 a2 a3 a4 h1 h2 h3 h6 h5 a5 dual_order.trans less_eq_real_def
         by (metis mult_less_cancel_left1 not_le)
     qed
   have prereqs:"r2 \<le> - 1" "1 \<le> (real_of_int (sint w1))" 
                " (- 2147483647) \<le> - (1::real )" "r2 \<le>  (- 2147483647)"
     using rw1 rw2 HiNeg lower2 by (auto simp add: word_sless_def word_sle_def)
   have "r1 * r2 \<le> - 2147483647"
     using upper lower1 lower2 rw1 rw2 
     apply (auto simp add: word_sless_def word_sle_def)
     using mylem[of "r2" "(real_of_int (sint w1))" " (- 2147483647)"] prereqs
     by (auto simp add: mult.commute)
   then show ?thesis
     using HiNeg by(auto simp add: repe.simps)
 next
   case AllFinite
   let ?prod = "(((scast w1)::64 Word.word) * ((scast w2)::64 Word.word))"
   consider 
       (ProdNeg) "?prod <=s ((scast NEG_INF)::64 Word.word)" 
     | (ProdPos) "(((scast POS_INF)::64 Word.word) <=s ?prod)"
     | (ProdFin) "\<not>(?prod <=s ((scast NEG_INF)::64 Word.word)) 
               \<and>  \<not>((scast POS_INF)::64 Word.word) <=s ?prod"
     by (auto)
   then show ?thesis
   proof (cases)
     case ProdNeg
     have bigLeq:"(4611686018427387904::real) \<le> 9223372036854775807" by auto
     have set_cast:"\<And>x::int. (x \<in> {-(2^31)..2^31}) = ( (real_of_int x) \<in> {-(2^31)..2^31})"
       by auto
     have eq3:"sint(((scast w1)::64 Word.word) * ((scast w2)::64 Word.word)) = 
      sint ((scast w1)::64 Word.word) * sint ((scast w2)::64 Word.word)"
      apply(rule Word_Lemmas.signed_arith_sint(4))
      using rangew1 rangew2 w1_cast w2_cast 
      using Word.word_size[of "((scast w1)::64 Word.word)"] 
      using Word.word_size[of "((scast w2)::64 Word.word)"]
      using times_upcast_upper[of "sint w1" "sint w2"]
      using times_upcast_lower[of "sint w1" "sint w2"] 
      by auto
     assume "?prod <=s ((scast NEG_INF)::64 Word.word)"
     then have sint_leq:"sint ?prod \<le> sint ((scast NEG_INF)::64 Word.word)"
       using word_sle_def by blast
     have neqs:"w1 \<noteq> POS_INF" " w1 \<noteq> NEG_INF" "w2 \<noteq> POS_INF" "w2 \<noteq> NEG_INF"
       using AllFinite word_sless_def signed.not_less_iff_gr_or_eq by force+
     from eq1 have rw1:"r1 = (real_of_int (sint w1))" using neqs by (auto simp add: repe.simps)
     from eq2 have rw2:"r2 = (real_of_int (sint w2))" using neqs by (auto simp add: repe.simps)
     show ?thesis
       using AllFinite ProdNeg  w1_cast w2_cast rw1 rw2 sint_leq  
       apply (auto simp add: repe.simps eq3)
       apply (subst (asm) of_int_le_iff [symmetric, where ?'a = real])
       apply simp
       done
   next
     case ProdPos
     have bigLeq:"(4611686018427387904::real) \<le> 9223372036854775807" by auto
     have set_cast:"\<And>x::int. (x \<in> {-(2^31)..2^31}) = ( (real_of_int x) \<in> {-(2^31)..2^31})"
       by auto
     have eq3:"sint(((scast w1)::64 Word.word) * ((scast w2)::64 Word.word)) = 
       sint ((scast w1)::64 Word.word) * sint ((scast w2)::64 Word.word)"
       apply(rule Word_Lemmas.signed_arith_sint(4))
       using rangew1 rangew2 POS_cast POS_sint w1_cast w2_cast
       using Word.word_size[of "((scast w1)::64 Word.word)"] 
       using Word.word_size[of "((scast w2)::64 Word.word)"]
       using times_upcast_upper[of "sint w1" "sint w2"]
       using times_upcast_lower[of "sint w1" "sint w2"] 
       by auto
     assume cast:"((scast POS_INF)::64 Word.word) <=s ?prod"
     then have sint_leq:"sint ((scast POS_INF)::64 Word.word) \<le> sint ?prod"
       using word_sle_def by blast
     have neqs:"w1 \<noteq> POS_INF" " w1 \<noteq> NEG_INF" "w2 \<noteq> POS_INF" "w2 \<noteq> NEG_INF"
       using AllFinite word_sless_def signed.not_less_iff_gr_or_eq by force+
     from eq1 have rw1:"r1 =  (real_of_int (sint w1))" 
       using repe.simps AllFinite neqs by auto
     from eq2 have rw2:"r2 = (real_of_int (sint w2))" 
       using repe.simps AllFinite neqs by auto
     have prodHi:"r1 * r2 \<ge> PosInf"
       using w1_cast w2_cast rw1 rw2 sint_leq apply (auto simp add: eq3)
       apply (subst (asm) of_int_le_iff [symmetric, where ?'a = real])
       apply simp
       done
     have infs:"SCAST(32 \<rightarrow> 64) NEG_INF <s SCAST(32 \<rightarrow> 64) POS_INF"
       by (auto)
     have casted:"SCAST(32 \<rightarrow> 64) POS_INF <=s SCAST(32 \<rightarrow> 64) w1 * SCAST(32 \<rightarrow> 64) w2"
       using cast by auto
     have almostContra:"SCAST(32 \<rightarrow> 64) NEG_INF <s SCAST(32 \<rightarrow> 64) w1 * SCAST(32 \<rightarrow> 64) w2"
       using infs cast  signed.order.strict_trans2 by blast
     have contra:"\<not>(SCAST(32 \<rightarrow> 64) w1 * SCAST(32 \<rightarrow> 64) w2 <=s SCAST(32 \<rightarrow> 64) NEG_INF)"
       using eq3 almostContra by auto
     have wtimesCase:"wtimes w1 w2 = POS_INF"
       using neqs ProdPos almostContra wtimes.simps AllFinite ProdPos
       by (auto simp add: repe.simps Let_def)
     show ?thesis
       using prodHi
       apply(simp only: repe.simps)      
       apply(rule disjI1)
       apply(rule exI[where x= "r1*r2"])
       apply(rule conjI)
        apply(rule wtimesCase)
       using prodHi by auto
   next
     case ProdFin
     have bigLeq:"(4611686018427387904::real) \<le> 9223372036854775807" by auto
     have set_cast:"\<And>x::int. (x \<in> {-(2^31)..2^31}) = ( (real_of_int x) \<in> {-(2^31)..2^31})"
       by auto
     have eq3:"sint(((scast w1)::64 Word.word) * ((scast w2)::64 Word.word)) = 
       sint ((scast w1)::64 Word.word) * sint ((scast w2)::64 Word.word)"
       apply(rule Word_Lemmas.signed_arith_sint(4))
       using rangew1 rangew2 POS_cast POS_sint w1_cast w2_cast 
       using Word.word_size[of "((scast w1)::64 Word.word)"] 
       using Word.word_size[of "((scast w2)::64 Word.word)"]
       using times_upcast_upper[of "sint w1" "sint w2"]
       using times_upcast_lower[of "sint w1" "sint w2"] 
       by auto
     from ProdFin have a1:"\<not>(?prod <=s ((scast NEG_INF)::64 Word.word))"
       by auto
     then have sintGe:"sint (?prod) > sint (((scast NEG_INF)::64 Word.word))"
       using word_sle_def dual_order.order_iff_strict signed.linear 
       by fastforce
     from ProdFin have a2:"\<not>((scast POS_INF)::64 Word.word) <=s ?prod"
       by auto
     then have sintLe:"sint (((scast POS_INF)::64 Word.word)) > sint (?prod)"
       using word_sle_def dual_order.order_iff_strict signed.linear 
       by fastforce
     have neqs:"w1 \<noteq> POS_INF" " w1 \<noteq> NEG_INF" "w2 \<noteq> POS_INF" "w2 \<noteq> NEG_INF"
       using AllFinite word_sless_def signed.not_less_iff_gr_or_eq by force+
     from eq1 have rw1:"r1 =  (real_of_int (sint w1))" using neqs by(auto simp add: repe.simps)
     from eq2 have rw2:"r2 =  (real_of_int (sint w2))" using neqs by(auto simp add: repe.simps)
     from rw1 rw2 have "r1 * r2 =  (real_of_int ((sint w1) * (sint w2)))"
       by simp
     have rightSize:"sint (((scast w1)::64 Word.word) * ((scast w2)::64 Word.word))
       \<in> sints (len_of TYPE(32))"
       using sintLe sintGe sints32 by (simp) 
     have downcast:"sint ((scast (((scast w1)::64 Word.word) * ((scast w2)::64 Word.word)))::word)
                  = sint (((scast w1)::64 Word.word) * ((scast w2)::64 Word.word))"
       using scast_down_range[OF rightSize]
       by auto
     then have res_eq:"r1 * r2 
       = real_of_int(sint((scast (((scast w1)::64 Word.word)*((scast w2)::64 Word.word)))::word))"
       using rw1 rw2 eq3 POS_cast POS_sint w1_cast w2_cast downcast 
         \<open>r1 * r2 =  (real_of_int (sint w1 * sint w2))\<close> 
       by (auto)
     have res_up:"sint (scast (((scast w1)::64 Word.word) * ((scast w2)::64 Word.word))::word) 
                < sint POS_INF"
       using rw1 rw2 eq3 POS_cast POS_sint w1_cast w2_cast downcast
         \<open>r1 * r2 = (real_of_int (sint w1 * sint w2))\<close> 
         \<open>sint (scast w1 * scast w2) < sint (scast POS_INF)\<close> 
           of_int_eq_iff res_eq 
       by presburger
     have res_lo:"sint NEG_INF 
                < sint (scast (((scast w1)::64 Word.word) * ((scast w2)::64 Word.word))::word)"
       using rw1 rw2 eq3 POS_cast POS_sint w1_cast w2_cast NEG_cast downcast
         \<open>r1 * r2 =  (real_of_int (sint w1 * sint w2))\<close> 
         \<open>sint (scast NEG_INF) < sint (scast w1 * scast w2)\<close> 
         of_int_eq_iff res_eq 
       by presburger
     have "scast ?prod \<equiv>\<^sub>E (r1 * r2)"
       using res_eq res_up res_lo 
       apply (auto simp add: rep_simps)
       using repeInt_simps by auto
     then show ?thesis 
       using AllFinite ProdFin by(auto)
   qed
 qed
 qed
 
 subsection \<open>Multiplication upper bound\<close>
 text\<open>Upper bound of multiplication from upper and lower bounds\<close>
 fun tu :: "word \<Rightarrow> word \<Rightarrow> word \<Rightarrow> word \<Rightarrow> word"
 where "tu w1l w1u w2l w2u = 
  wmax (wmax (wtimes w1l w2l) (wtimes w1u w2l))
       (wmax (wtimes w1l w2u) (wtimes w1u w2u))"
 
 lemma tu_lemma:
   assumes u1:"u\<^sub>1 \<equiv>\<^sub>U (r1::real)"
   assumes u2:"u\<^sub>2 \<equiv>\<^sub>U (r2::real)"
   assumes l1:"l\<^sub>1 \<equiv>\<^sub>L (r1::real)"
   assumes l2:"l\<^sub>2 \<equiv>\<^sub>L (r2::real)"
   shows "tu l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>U (r1 * r2)"
 proof -
   obtain rl1 rl2 ru1 ru2 :: real 
   where gru1:"ru1 \<ge> r1" and gru2:"ru2 \<ge> r2" and grl1:"rl1 \<le> r1" and grl2:"rl2 \<le> r2" 
   and eru1:"u\<^sub>1 \<equiv>\<^sub>E ru1" and eru2:"u\<^sub>2 \<equiv>\<^sub>E ru2" and erl1:"l\<^sub>1 \<equiv>\<^sub>E rl1" and erl2:"l\<^sub>2 \<equiv>\<^sub>E rl2"
   using u1 u2 l1 l2 unfolding repU_def repL_def by auto
   have timesuu:"wtimes u\<^sub>1 u\<^sub>2 \<equiv>\<^sub>E ru1 * ru2"
     using wtimes_exact[OF eru1 eru2] by auto
   have timesul:"wtimes u\<^sub>1 l\<^sub>2 \<equiv>\<^sub>E ru1 * rl2"
     using wtimes_exact[OF eru1 erl2] by auto
   have timeslu:"wtimes l\<^sub>1 u\<^sub>2 \<equiv>\<^sub>E rl1 * ru2"
     using wtimes_exact[OF erl1 eru2] by auto
   have timesll:"wtimes l\<^sub>1 l\<^sub>2 \<equiv>\<^sub>E rl1 * rl2"
     using wtimes_exact[OF erl1 erl2] by auto
   have maxt12:"wmax (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2) \<equiv>\<^sub>E max (rl1 * rl2) (ru1 * rl2)"
     by (rule  wmax_lemma[OF timesll timesul])
   have maxt34:"wmax (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2) \<equiv>\<^sub>E max (rl1 * ru2) (ru1 * ru2)"
     by (rule  wmax_lemma[OF timeslu timesuu])
   have bigMax:"wmax (wmax (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2)) (wmax (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2))
     \<equiv>\<^sub>E max (max (rl1 * rl2) (ru1 * rl2)) (max (rl1 * ru2) (ru1 * ru2))"
     by (rule wmax_lemma[OF maxt12 maxt34])
   obtain maxt12val :: real 
     where maxU12:"wmax (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2) \<equiv>\<^sub>U max (rl1 * rl2) (ru1 * rl2)"
   using maxt12 unfolding repU_def by blast
   obtain maxt34val :: real 
     where maxU34:"wmax (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2) \<equiv>\<^sub>U max (rl1 * ru2) (ru1 * ru2)"
   using maxt34 unfolding repU_def by blast
   obtain bigMaxU:"wmax (wmax (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2)) (wmax (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2))
     \<equiv>\<^sub>U max (max (rl1 * rl2) (ru1 * rl2)) (max (rl1 * ru2) (ru1 * ru2))"
   using bigMax unfolding repU_def by blast
   have ivl1:"rl1 \<le> ru1" using grl1 gru1 by auto
   have ivl2:"rl2 \<le> ru2" using grl2 gru2 by auto
   let ?thesis = "tu l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>U r1 * r2"
   show ?thesis
   using ivl1 ivl2
   proof(cases rule: case_ivl_zero)
     case ZeroZero
     assume "rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2"
     then have geq1:"ru1 \<ge> 0" and geq2:"ru2 \<ge> 0" by auto
     consider "r1 \<ge> 0 \<and> r2 \<ge> 0" | "r1 \<ge> 0 \<and> r2 \<le> 0" | "r1 \<le> 0 \<and> r2 \<ge> 0" | "r1 \<le> 0 \<and> r2 \<le> 0"
     using le_cases by auto
     then show "tu l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>U r1 * r2" 
     proof (cases)
       case 1
       have g1:"ru1 * ru2 \<ge> ru1 * r2" 
         using "1" geq1 geq2 grl2 gru2
         by (simp add: mult_left_mono)
       have g2:"ru1 * r2 \<ge> r1 * r2"
         using "1" geq1 geq2 grl1 grl2 gru1 gru2
         by (simp add: mult_right_mono)
       from g1 and g2
       have up:"ru1 * ru2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up eru1 eru2 erl1 erl2 repU_def timesuu tu.simps
           max_repU2[OF maxU12] max_repU2[OF maxU34] max_repU2[OF bigMaxU]
         by (metis wmax.elims)
     next
       case 2
       have g1:"ru1 * ru2 \<ge> 0" 
         using "2" geq1 geq2 grl2 gru2 by (simp)
       have g2:"0 \<ge> r1 * r2"
         using "2" by (simp add: mult_le_0_iff)
         from g1 and g2
       have up:"ru1 * ru2 \<ge> r1 * r2" by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12]
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.coboundedI1 max.commute maxt34
         by (metis  repU_def  tu.simps)
     next
       case 3
       have g1:"ru1 * ru2 \<ge> 0" 
         using "3" geq1 geq2  by simp
       have g2:"0 \<ge> r1 * r2"
         using "3" by (simp add: mult_le_0_iff)
       from g1 and g2
       have up:"ru1 * ru2 \<ge> r1 * r2" by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] repU_def tu.simps timesuu
         by (metis max.coboundedI1 max.commute maxt34)
     next
       case 4
       have g1:"rl1 * rl2 \<ge> rl1 * r2" 
         using "4" geq1 geq2 grl1 grl2 gru1 gru2
         using  \<open>rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2\<close> less_eq_real_def
           by (metis mult_left_mono_neg)
       have g2:"rl1 * r2 \<ge> r1 * r2"
         using "4" geq1 geq2 grl1 grl2 gru1 gru2 \<open>rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2\<close>  
           by (metis mult_left_mono_neg mult.commute)
       from g1 and g2
       have up:"rl1 * rl2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.commute maxt34
         by (metis max_repU1 repU_def timesll tu.simps)
       qed
   next
     case ZeroPos
     assume bounds:"rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> 0 \<le> rl2"
     have r2:"r2 \<ge> 0" using bounds dual_order.trans grl2 by blast
     consider "r1 \<ge> 0" | "r1 \<le> 0" using le_cases by (auto)
     then show ?thesis
     proof (cases)
       case 1
       assume r1:"r1 \<ge> 0"
       have g1:"ru1 * ru2 \<ge> ru1 * r2" 
         using r1 r2 bounds grl1 grl2 gru1 gru2
         using mult_left_mono by blast
       have g2:"ru1 * r2 \<ge> r1 * r2"
         using r1 r2 bounds grl1 grl2 gru1 gru2
         using mult_right_mono by blast
       from g1 and g2
       have up:"ru1 * ru2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.coboundedI1 max.commute maxt34
         by (metis repU_def tu.simps) 
     next
       case 2
       assume r1:"r1 \<le> 0"
       have g1:"ru1 * ru2 \<ge> 0" 
         using r1 r2 bounds grl1 grl2 gru1 gru2
         using mult_left_mono 
         by (simp add: mult_less_0_iff less_le_trans not_less)
       have g2:"0 \<ge> r1 * r2"
         using r1 r2 bounds grl1 grl2 gru1 gru2
         using mult_right_mono 
         by (simp add: mult_le_0_iff)
       from g1 and g2
       have up:"ru1 * ru2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.coboundedI1 max.commute maxt34
         by (metis repU_def tu.simps) 
       qed 
   next
     case ZeroNeg
     assume bounds:"rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> ru2 \<le> 0"
     have r2:"r2 \<le> 0" using bounds dual_order.trans gru2 by blast
     have case1:"r1 \<ge> 0 \<Longrightarrow> ?thesis" 
     proof -
       assume r1:"r1 \<ge> 0"
       have g1:"rl1 * rl2 \<ge> 0" 
         using r1 r2 bounds grl1 grl2 gru1 gru2 mult_less_0_iff less_le_trans not_less
         by metis
       have g2:"0 \<ge> r1 * r2"
         using r1 r2 bounds grl1 grl2 gru1 gru2
         using mult_right_mono 
         by (simp add: mult_le_0_iff)
       from g1 and g2
       have up:"rl1 * rl2 \<ge> r1 * r2"
         by auto
       show ?thesis 
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.commute maxt34
         by (metis max_repU2 max_repU1 repU_def timesll tu.simps)
     qed
     have case2:"r1 \<le> 0 \<Longrightarrow> ?thesis"
     proof -
       assume r1:"r1 \<le> 0"
       have g1:"rl1 * rl2 \<ge> rl1 * r2" 
         using r1 r2 bounds  grl1 grl2 gru1 gru2
         by (metis mult_left_mono_neg)
       have g2:"rl1 * r2 \<ge> r1 * r2"
         using r1 r2 bounds grl1 grl2 gru1 gru2 mult.commute
         by (metis mult_left_mono_neg)
       from g1 and g2
       have up:"rl1 * rl2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.commute maxt34 
         by (metis max_repU1 repU_def timesll tu.simps) 
     qed
     show "tu l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>U r1 * r2"
       using case1 case2 le_cases by blast
   next
     case PosZero
     assume bounds:"0 \<le> rl1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2"
     have r1:"r1 \<ge> 0" using bounds dual_order.trans grl1 by blast
     consider "r2 \<ge> 0" | "r2 \<le> 0" using le_cases by auto
     then show ?thesis
     proof (cases)
       case 1
       have g1:"ru1 * ru2 \<ge> ru1 * r2" 
         using "1" bounds grl1 grl2 gru1 gru2
         using mult_left_mono 
         using leD leI less_le_trans by metis
       have g2:"ru1 * r2 \<ge> r1 * r2"
         using "1" bounds grl1 grl2 gru1 gru2
         using mult_right_mono by blast
       from g1 and g2
       have up:"ru1 * ru2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.coboundedI1 max.commute maxt34
         by (metis repU_def tu.simps) 
     next
       case 2
         have g1:"ru1 * ru2 \<ge> 0" 
           using r1 bounds grl2 gru2 gru1 leD leI less_le_trans by auto
         have g2:"0 \<ge> r1 * r2"
           using r1 "2" 
           by (simp add: mult_le_0_iff)
         from g1 and g2
         have up:"ru1 * ru2 \<ge> r1 * r2"
           by auto
         show ?thesis
           using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
             max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.coboundedI1 max.commute maxt34
           by (metis repU_def tu.simps)
       qed
   next
     case NegZero
     assume bounds:"ru1 \<le> 0 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2"
     have r1:"r1 \<le> 0"  using bounds dual_order.trans gru1 by blast
     consider "r2 \<ge> 0" | "r2 \<le> 0" using le_cases by auto
     then show ?thesis
     proof (cases)
       case 1
       have g1:"ru1 * rl2 \<ge> 0" 
         using r1 "1" bounds grl1 grl2 gru1 gru2 mult_less_0_iff not_less
         by metis
       have g2:"0 \<ge> r1 * r2"
         using r1 "1" bounds grl1 grl2 gru1 gru2
         by (simp add: mult_le_0_iff)
       from g1 and g2
       have up:"ru1 * rl2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.commute maxt34
         by (metis max_repU1 repU_def timesul tu.simps) 
     next
       case 2
       have lower:"rl1 \<le> 0" using bounds dual_order.trans grl1 r1 by blast
       have g1:"rl1 * rl2 \<ge> rl1 * r2" 
         using r1 "2" bounds grl1 grl2 gru1 gru2 less_eq(1) less_le_trans not_less 
           mult_le_cancel_left
         by metis
       have g2:"rl1 * r2 \<ge> r1 * r2"
         using r1 "2" bounds grl1 grl2 gru1 gru2 mult.commute not_le lower mult_le_cancel_left
         by metis
       from g1 and g2
       have up:"rl1 * rl2 \<ge> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
           max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.commute maxt34
         by (metis max_repU1 repU_def timesll tu.simps)
     qed
   next
     case NegNeg
     assume bounds:"ru1 \<le> 0 \<and> ru2 \<le> 0"
     have r1:"r1 \<le> 0" using bounds dual_order.trans gru1 by blast
     have r2:"r2 \<le> 0" using bounds dual_order.trans gru2 by blast
     have lower1:"rl1 \<le> 0" using bounds dual_order.trans grl1 r1 by blast
     have lower2:"rl2 \<le> 0" using bounds dual_order.trans grl2 r2 by blast
     have g1:"rl1 * rl2 \<ge> rl1 * r2" 
       using r1 r2 bounds  grl1 grl2 gru1 gru2 less_eq(1)  mult_le_cancel_left less_le_trans not_less
       by metis
     have g2:"rl1 * r2 \<ge> r1 * r2"
       using r1 r2 bounds grl1 grl2 gru1 gru2 mult.commute not_le lower1 lower2 mult_le_cancel_left
       by metis
     from g1 and g2
     have up:"rl1 * rl2 \<ge> r1 * r2"
       by auto
     show ?thesis
       using up maxU12 maxU34 bigMaxU wmax.elims max_repU2 max_repU2[OF maxU12] 
         max_repU2[OF maxU34] max_repU2[OF bigMaxU] max.commute maxt34 
       by (metis max_repU1 repU_def timesll tu.simps)
   next
     case NegPos
     assume bounds:"ru1 \<le> 0 \<and> 0 \<le> rl2"
     have r1:"r1 \<le> 0" using bounds dual_order.trans gru1 by blast
     have r2:"r2 \<ge> 0" using bounds dual_order.trans grl2 by blast
     have lower1:"rl1 \<le> 0" using bounds dual_order.trans grl1 r1 by blast
     have lower2:"rl2 \<ge> 0" using bounds by auto
     have upper1:"ru1 \<le> 0" using bounds by auto 
     have upper2:"ru2 \<ge> 0" using bounds dual_order.trans gru2 r2 by blast
     have g1:"ru1 * rl2 \<ge> ru1 * r2" 
       using r1 r2 bounds grl1 grl2 gru1 gru2 not_less upper1 lower2 mult_le_cancel_left
       by metis
     have g2:"ru1 * r2 \<ge> r1 * r2"
       using r1 upper1 r2 mult_right_mono gru1 by metis
     from g1 and g2
     have up:"ru1 * rl2 \<ge> r1 * r2"
       by auto
     show ?thesis
       using up maxU12 maxU34 bigMaxU wmax.elims maxt34
         max_repU2[OF maxU12] max_repU2[OF maxU34] max_repU2[OF bigMaxU]
       by (metis max_repU1 repU_def timesul tu.simps)
   next
     case PosNeg
     assume bounds:"0 \<le> rl1 \<and> ru2 \<le> 0"
     have r1:"r1 \<ge> 0" using bounds dual_order.trans grl1 by blast
     have r2:"r2 \<le> 0" using bounds dual_order.trans gru2 by blast
     have lower1:"rl1 \<ge> 0" using bounds by auto
     have lower2:"rl2 \<le> 0" using dual_order.trans grl2 r2 by blast
     have upper1:"ru1 \<ge> 0" using dual_order.trans gru1 u1 r1 by blast  
     have upper2:"ru2 \<le> 0" using bounds by auto
     have g1:"rl1 * ru2 \<ge> rl1 * r2" 
       using r1 r2 bounds grl1 grl2 gru1 gru2 not_less upper2 lower1 mult_le_cancel_left 
       by metis
     have g2:"rl1 * r2 \<ge> r1 * r2"
       using r1 lower1 r2 not_less gru2 gru1 grl1 grl2
       by (metis mult_le_cancel_left mult.commute)
     from g1 and g2
     have up:"rl1 * ru2 \<ge> r1 * r2"
       by auto
     show "tu l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>U r1 * r2"
       using up maxU12 maxU34 bigMaxU wmax.elims max.coboundedI1 max.commute maxt34
         max_repU2[OF maxU12] max_repU2[OF maxU34] max_repU2[OF bigMaxU] 
       by (metis repU_def tu.simps)
   next
     case PosPos
     assume bounds:"0 \<le> rl1 \<and> 0 \<le> rl2"
     have r1:"r1 \<ge> 0" using bounds dual_order.trans grl1 by blast
     have r2:"r2 \<ge> 0" using bounds dual_order.trans grl2 by blast
     have lower1:"rl1 \<ge> 0" using bounds by auto
     have lower2:"rl2 \<ge> 0" using bounds by auto
     have upper1:"ru1 \<ge> 0" using dual_order.trans gru1 u1 r1 by blast  
     have upper2:"ru2 \<ge> 0" using dual_order.trans gru2 u2 r2 bounds by blast
     have g1:"ru1 * ru2 \<ge> ru1 * r2" 
       using r1 r2 bounds grl1 grl2 gru1 gru2 mult_left_mono leD leI less_le_trans by metis
     have g2:"ru1 * r2 \<ge> r1 * r2"
       using r1 r2 bounds grl1 grl2 gru1 gru2 mult_right_mono by metis
     from g1 and g2
     have up:"ru1 * ru2 \<ge> r1 * r2"
       by auto
     show ?thesis
       using up maxU12 maxU34 bigMaxU wmax.elims max.coboundedI1 max.commute maxt34
         max_repU2[OF bigMaxU] max_repU2[OF maxU12] max_repU2[OF maxU34]
       by (metis repU_def tu.simps)
   qed
 qed
 
 subsection \<open>Minimum function\<close>
 text\<open>Minimum of 2s-complement words\<close>
 fun wmin :: "word \<Rightarrow> word \<Rightarrow> word"
 where "wmin w1 w2 = 
   (if w1 <s w2 then w1 else w2)"
                                             
 text\<open>Correctness of wmin\<close>
 lemma wmin_lemma:
   assumes eq1:"w1 \<equiv>\<^sub>E (r1::real)"
   assumes eq2:"w2 \<equiv>\<^sub>E (r2::real)"
   shows "wmin w1 w2 \<equiv>\<^sub>E (min r1 r2)"
 proof(cases rule: case_inf2[where ?w1.0=w1, where ?w2.0=w2])
   case PosPos
   assume p1:"w1 = POS_INF"   
      and p2:"w2 = POS_INF"
   then have bound1:"(real_of_int (sint POS_INF)) \<le> r1"
         and bound2:"(real_of_int (sint POS_INF)) \<le> r2"
     using eq1 eq2 by (auto simp add: rep_simps repe.simps)
   have eqInf:"wmin w1 w2 = POS_INF"
     using p1 p2 unfolding wmin.simps by auto
   have pos_eq:"POS_INF \<equiv>\<^sub>E min r1 r2"
     apply(rule repPOS_INF)
     using bound1 bound2 unfolding eq1 eq2 by auto
   show ?thesis
     using pos_eq eqInf by auto
 next
   case PosNeg
   assume p1:"w1 = POS_INF"
   assume n2:"w2 = NEG_INF"
   obtain r ra :: real 
   where bound1:" (real_of_int (sint POS_INF)) \<le> r"
     and bound2:"ra \<le>  (real_of_int (sint NEG_INF))"
     and eq1:"r1 = r"
     and eq2:"r2 = ra"
     using p1 n2 eq1 eq2 by(auto simp add: rep_simps repe.simps)
   have eqNeg:"wmin w1 w2 = NEG_INF"
     unfolding eq1 eq2 wmin.simps p1 n2 word_sless_def word_sle_def
     by(auto) 
   have neg_eq:"NEG_INF \<equiv>\<^sub>E min r1 r2"
     apply(rule repNEG_INF)
     using bound1 bound2 eq1 eq2 by auto
   show "?thesis"
     using eqNeg neg_eq by auto
 next
   case PosNum
   assume p1:"w1 = POS_INF"
   assume np2:"w2 \<noteq> POS_INF"
   assume nn2:"w2 \<noteq> NEG_INF"
   have eq2:"r2 = (real_of_int (sint w2))"
     and bound1:"(real_of_int (sint POS_INF)) \<le> r1"
     and bound2a:"(real_of_int (sint NEG_INF)) < (real_of_int (sint w2))"
     and bound2b:"(real_of_int (sint w2)) < (real_of_int (sint POS_INF))"
     using p1 np2 nn2 eq1 eq2 by(auto simp add: rep_simps repe.simps)
   have eqNeg:"min r1 r2 = sint w2"
     using p1
     by (metis bound1 bound2b dual_order.trans eq2 min_def not_less) 
   have neg_eq:"wmin w1 w2 \<equiv>\<^sub>E  (real_of_int (sint (wmin w1 w2)))"
     apply (rule repINT)
     using bound1 bound2a bound2b bound2b p1 unfolding eq1 eq2
     by (auto simp add: word_sless_alt)
   show "?thesis"
     using eqNeg neg_eq
     by (metis bound2b less_eq_real_def not_less of_int_less_iff p1 wmin.simps word_sless_alt)
 next
   case NegPos
   assume n1:"w1 = NEG_INF"   
   assume p2:"w2 = POS_INF"
   have  bound1:"r1 \<le> (real_of_int (sint NEG_INF))"
     and bound2:"(real_of_int (sint POS_INF)) \<le> r2"
     using n1 p2 eq1 eq2 by(auto simp add: rep_simps repe.simps)    
   have eqNeg:"wmin w1 w2 = NEG_INF"
     unfolding eq1 eq2 wmin.simps n1 p2 word_sless_def word_sle_def
     by(auto)
   have neg_eq:"NEG_INF \<equiv>\<^sub>E min r1 r2"
     apply(rule repNEG_INF)
     using bound1 bound2 unfolding eq1 eq2 by auto
   show "wmin w1 w2 \<equiv>\<^sub>E min r1 r2"
     using eqNeg neg_eq by auto                      
 next
   case NegNeg
   assume n1:"w1 = NEG_INF"                 
   assume n2:"w2 = NEG_INF" 
   have bound1:"r1 \<le>  (real_of_int (sint NEG_INF))"
    and bound2:"r2 \<le>  (real_of_int (sint NEG_INF))"
     using n1 n2 eq1 eq2 by(auto simp add: rep_simps repe.simps)    
   have eqNeg:"NEG_INF \<equiv>\<^sub>E min r1 r2"
     apply(rule repNEG_INF)
     using eq1 eq2 bound1 bound2 unfolding NEG_INF_def
     by (auto)
   have neg_eq:"wmin w1 w2 = NEG_INF"
     using n1 n2 unfolding NEG_INF_def wmin.simps by auto 
   show "wmin w1 w2 \<equiv>\<^sub>E min r1 r2"
     using eqNeg neg_eq by auto
 next
   case NegNum
   assume n1:"w1 = NEG_INF" 
     and  nn2:"w2 \<noteq> NEG_INF"
     and  np2:"w2 \<noteq> POS_INF"
   have eq2:"r2 =  (real_of_int (sint w2))"
     and bound2a:"(real_of_int (sint w2)) <  (real_of_int (sint POS_INF))"
     and bound2b:"(real_of_int (sint NEG_INF)) <  (real_of_int (sint w2))"
     and bound1:"r1 \<le>  (real_of_int (sint NEG_INF))"
     using n1 nn2 np2 eq2 eq1 eq2 by (auto simp add: rep_simps repe.simps)  
   have eqNeg:"wmin w1 w2 = NEG_INF"
     using n1 assms(2) bound2a eq2 n1 repeInt_simps  
     by (auto simp add: word_sless_alt)
   have neg_eq:"NEG_INF \<equiv>\<^sub>E min r1 r2"
     apply(rule repNEG_INF)
     using bound1 bound2a bound2b eq1 min_le_iff_disj by blast
   show "wmin w1 w2 \<equiv>\<^sub>E min r1 r2"
     using eqNeg neg_eq by auto
 next
   case NumPos
   assume p2:"w2 = POS_INF"
    and  nn1:"w1 \<noteq> NEG_INF"
    and  np1:"w1 \<noteq> POS_INF"
   have eq1:"r1 =  (real_of_int (sint w1))"
     and bound1a:" (real_of_int (sint w1)) <  (real_of_int (sint POS_INF))"
     and bound1b:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w1))"
     and bound2:" (real_of_int (sint POS_INF)) \<le> r2"
     using nn1 np1 p2 eq2 eq1 eq2 by (auto simp add: rep_simps repe.simps)  
   have res1:"wmin w1 w2 = w1"
     using p2 eq1 eq2  assms(1) bound1b p2 repeInt_simps  
     by (auto simp add: word_sless_alt)
   have res2:"min r1 r2 =  (real_of_int (sint w1))"
     using eq1 eq2 bound1a bound1b bound2 
     by transfer (auto simp add: less_imp_le less_le_trans min_def)
   have res3:"wmin w1 w2 \<equiv>\<^sub>E  (real_of_int (sint (wmin w1 w2)))"
     apply(rule repINT)
     using p2 bound1a res1 bound1a bound1b bound2 
     by auto
   show "wmin w1 w2 \<equiv>\<^sub>E min r1 r2" 
     using res1 res2 res3 by auto
 next
   case NumNeg
   assume nn1:"w1 \<noteq> NEG_INF"
   assume np1:"w1 \<noteq> POS_INF"
   assume n2:"w2 = NEG_INF"
   have eq1:"r1 =  (real_of_int (sint w1))"
     and bound1a:" (real_of_int (sint w1)) <  (real_of_int (sint POS_INF))"
     and bound1b:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w1))"
     and bound2:"r2 \<le>  (real_of_int (sint NEG_INF))"
     using nn1 np1 n2 eq2 eq1 eq2 by (auto simp add: rep_simps repe.simps)
   have res1:"wmin w1 w2 = NEG_INF"
     using n2 bound1b
     by (metis min.absorb_iff2 min_def n2 not_less of_int_less_iff wmin.simps word_sless_alt)
   have res2:"NEG_INF \<equiv>\<^sub>E min r1 r2"
     apply(rule repNEG_INF)
     using eq1 eq2 bound1a bound1b bound2 min_le_iff_disj by blast
   show "wmin w1 w2 \<equiv>\<^sub>E min r1 r2"
     using res1 res2 by auto
 next
   case NumNum
   assume np1:"w1 \<noteq> POS_INF"
   assume nn1:"w1 \<noteq> NEG_INF"
   assume np2:"w2 \<noteq> POS_INF"
   assume nn2:"w2 \<noteq> NEG_INF"
   have eq1:"r1 =  (real_of_int (sint w1))"
   and  eq2:"r2 =  (real_of_int (sint w2))"
   and  bound1a:" (real_of_int (sint w1)) <  (real_of_int (sint POS_INF))"
   and  bound1b:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w1))"
   and  bound2a:" (real_of_int (sint w2)) <  (real_of_int (sint POS_INF))"
   and  bound2b:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint w2))"
     using nn1 np1 nn2 np2 eq2 eq1 eq2 
     by (auto simp add: rep_simps repe.simps)
   have res1:"min r1 r2 =  (real_of_int (sint (wmin w1 w2)))"
     using eq1 eq2 bound1a bound1b bound2a bound2b 
     apply (simp add: min_def word_sless_alt not_less)
     apply transfer
     apply simp
     done
   have res2:"wmin w1 w2 \<equiv>\<^sub>E (real_of_int (sint (wmin w1 w2)))"
     apply (rule repINT)
     using bound1a bound1b bound2a bound2b
     by (simp add: \<open>min r1 r2 = (real_of_int (sint (wmin w1 w2)))\<close> eq2 min_less_iff_disj)+
   show "wmin w1 w2 \<equiv>\<^sub>E min r1 r2"
     using res1 res2 by auto
 qed    
     
 lemma min_repU1:
   assumes "w1 \<equiv>\<^sub>L x"
   assumes "w2 \<equiv>\<^sub>L y"
   shows "wmin w1 w2 \<equiv>\<^sub>L x "
   using wmin_lemma assms repL_def
   by (meson min_le_iff_disj)
 
 lemma min_repU2:
   assumes "w1 \<equiv>\<^sub>L y"
   assumes "w2 \<equiv>\<^sub>L x"
   shows "wmin w1 w2 \<equiv>\<^sub>L x"
   using wmin_lemma assms repL_def
 by (meson min_le_iff_disj)
 
 
 subsection \<open>Multiplication lower bound\<close>
 text\<open>Multiplication lower bound\<close>
 fun tl :: "word \<Rightarrow> word \<Rightarrow> word \<Rightarrow> word \<Rightarrow> word"
 where "tl w1l w1u w2l w2u =
   wmin (wmin (wtimes w1l w2l) (wtimes w1u w2l))
        (wmin (wtimes w1l w2u) (wtimes w1u w2u))"
 
 text\<open>Correctness of multiplication lower bound\<close>
 lemma tl_lemma:
   assumes u1:"u\<^sub>1 \<equiv>\<^sub>U (r1::real)"
   assumes u2:"u\<^sub>2 \<equiv>\<^sub>U (r2::real)"
   assumes l1:"l\<^sub>1 \<equiv>\<^sub>L (r1::real)"
   assumes l2:"l\<^sub>2 \<equiv>\<^sub>L (r2::real)"
   shows "tl l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>L (r1 * r2)"
 proof -
   obtain rl1 rl2 ru1 ru2 :: real 
   where gru1:"ru1 \<ge> r1" and gru2:"ru2 \<ge> r2" and grl1:"rl1 \<le> r1" and grl2:"rl2 \<le> r2" 
   and eru1:"u\<^sub>1 \<equiv>\<^sub>E ru1" and eru2:"u\<^sub>2 \<equiv>\<^sub>E ru2" and erl1:"l\<^sub>1 \<equiv>\<^sub>E rl1" and erl2:"l\<^sub>2 \<equiv>\<^sub>E rl2"
   using u1 u2 l1 l2 unfolding repU_def repL_def by auto
   have timesuu:"wtimes u\<^sub>1 u\<^sub>2 \<equiv>\<^sub>E ru1 * ru2"
     using wtimes_exact[OF eru1 eru2] by auto
   have timesul:"wtimes u\<^sub>1 l\<^sub>2 \<equiv>\<^sub>E ru1 * rl2"
     using wtimes_exact[OF eru1 erl2] by auto
   have timeslu:"wtimes l\<^sub>1 u\<^sub>2 \<equiv>\<^sub>E rl1 * ru2"
     using wtimes_exact[OF erl1 eru2] by auto
   have timesll:"wtimes l\<^sub>1 l\<^sub>2 \<equiv>\<^sub>E rl1 * rl2"
     using wtimes_exact[OF erl1 erl2] by auto
   have maxt12:"wmin (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2) \<equiv>\<^sub>E min (rl1 * rl2) (ru1 * rl2)"
     by (rule  wmin_lemma[OF timesll timesul])
   have maxt34:"wmin (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2) \<equiv>\<^sub>E min (rl1 * ru2) (ru1 * ru2)"
     by (rule  wmin_lemma[OF timeslu timesuu])
   have bigMax:"wmin (wmin (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2)) (wmin (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2))
     \<equiv>\<^sub>E min (min(rl1 * rl2) (ru1 * rl2)) (min (rl1 * ru2) (ru1 * ru2))"
     by (rule wmin_lemma[OF maxt12 maxt34])
   obtain maxt12val :: real 
     where maxU12:"wmin (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2) \<equiv>\<^sub>L min (rl1 * rl2) (ru1 * rl2)"
   using maxt12 unfolding repL_def by blast
   obtain maxt34val :: real 
     where maxU34:"wmin (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2) \<equiv>\<^sub>L min (rl1 * ru2) (ru1 * ru2)"
   using maxt34 unfolding repL_def by blast
   obtain bigMaxU:"wmin (wmin (wtimes l\<^sub>1 l\<^sub>2) (wtimes u\<^sub>1 l\<^sub>2)) (wmin (wtimes l\<^sub>1 u\<^sub>2) (wtimes u\<^sub>1 u\<^sub>2))
     \<equiv>\<^sub>L min (min (rl1 * rl2) (ru1 * rl2)) (min (rl1 * ru2) (ru1 * ru2))"
   using bigMax unfolding repL_def by blast
   have ivl1:"rl1 \<le> ru1" using grl1 gru1 by auto
   have ivl2:"rl2 \<le> ru2" using grl2 gru2 by auto
   let ?thesis = "tl l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>L r1 * r2"
   show ?thesis
   using ivl1 ivl2
   proof(cases rule: case_ivl_zero)
     case ZeroZero        
     assume "rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2"
     then have geq1:"ru1 \<ge> 0" and geq2:"ru2 \<ge> 0" 
     and geq3:"rl1 \<le> 0" and geq4:"rl2 \<le> 0" by auto
     consider "r1 \<ge> 0 \<and> r2 \<ge> 0" | "r1 \<le> 0 \<and> r2 \<ge> 0" | "r1 \<ge> 0 \<and> r2 \<le> 0" | "r1 \<le> 0 \<and> r2 \<le> 0"
       using le_cases by auto
     then show ?thesis
     proof (cases)
       case 1
       have g1:"rl1 * ru2 \<le> 0" 
         using "1" geq1 geq2 geq3 geq4 grl2 gru2 mult_le_0_iff by blast
       have g2:"0 \<le>  r1 * r2"
         using "1"  geq1 geq2 grl1 grl2 gru1 gru2
         by (simp)
       from g1 and g2
       have up:"rl1 * ru2 \<le> r1 * r2"
         by auto
       show ?thesis
         using up eru1 eru2 erl1 erl2 min_repU1 min_repU2 
           repL_def repU_def timeslu tl.simps wmin.elims
         by (metis bigMax min_le_iff_disj)
     next
       case 2
       have g1:"rl1 * ru2 \<le> rl1 * r2" 
         using "2" geq1 geq2 grl2 gru2
         by (metis mult_le_cancel_left  geq3 leD)
       have g2:"rl1 * r2 \<le> r1 * r2"
         using "2" geq1 geq2 grl2 gru2
         by (simp add: mult_right_mono grl1)
       from g1 and g2
       have up:"rl1 * ru2 \<le> r1 * r2"
         by auto
       show ?thesis
         by (metis up maxU12 min_repU2 repL_def tl.simps min.coboundedI1 maxt34)
     next
       case 3
       have g1:"ru1 * rl2 \<le> ru1 * r2" 
         using "3" geq1 geq2 grl2 gru2
         by (simp add: mult_left_mono)
       have g2:"ru1 * r2 \<le> r1 * r2"
         using "3" geq1 geq2 grl1 grl2 gru1 gru2 mult_minus_right mult_right_mono
         by (simp add: mult_right_mono_neg)
       from g1 and g2
       have up:"ru1 * rl2 \<le> r1 * r2" by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmin.elims min_repU2 min_repU1 maxt34 timesul
         by (metis repL_def tl.simps)
     next
       case 4
       have g1:"ru1 * rl2 \<le> 0" 
         using "4" geq1 geq2 grl1 grl2 gru1 gru2 \<open>rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2\<close> 
           mult_less_0_iff  less_eq_real_def not_less
         by auto
       have g2:"0 \<le> r1 * r2"
         using "4" geq1 geq2 grl1 grl2 gru1 gru2
         by (metis mult_less_0_iff  not_less)
       from g1 and g2
       have up:"ru1 * rl2 \<le> r1 * r2"
         by auto
       show ?thesis
       by (metis up maxU12 maxU34 wmin.elims min_repU1 min_repU2 repL_def timesul tl.simps) 
     qed
   next
     case ZeroPos
     assume bounds:"rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> 0 \<le> rl2"
     have r2:"r2 \<ge> 0" using bounds dual_order.trans grl2 by blast
     consider "r1 \<ge> 0" | "r1 \<le> 0" using le_cases by auto
     then show ?thesis
     proof (cases)
       case 1
       have g1:"rl1 * rl2 \<le> 0" 
         using "1" r2 bounds grl1 grl2 gru1 gru2
         by (simp add: mult_le_0_iff)
       have g2:"0 \<le> r1 * r2"
         using "1" r2 bounds grl1 grl2 gru1 gru2
         by (simp)
       from g1 and g2
       have up:"rl1 * rl2 \<le> r1 * r2"
         by auto
       show ?thesis
         by (metis repL_def timesll tl.simps up maxU12 maxU34 wmin.elims min_repU2 min_repU1) 
     next
       case 2
       have bound:"ru2 \<ge> 0"
         using "2" r2 bounds grl1 grl2 gru1 gru2 dual_order.trans by auto
       then have g1:"rl1 * ru2 \<le> rl1 * r2" 
         using "2" r2 bounds grl1 grl2 gru1 gru2 mult_le_cancel_left
         by fastforce
       have g2:"rl1 * r2 \<le> r1 * r2"
         using "2" r2 bounds grl1 grl2 gru1 gru2 mult_le_0_iff mult_le_cancel_right by fastforce
       from g1 and g2
       have up:"rl1 * ru2 \<le> r1 * r2" by auto
       show ?thesis
         by (metis up maxU12 wmin.elims min_repU2 min.coboundedI1 maxt34 repL_def tl.simps) 
       qed
   next
     case ZeroNeg
     assume bounds:"rl1 \<le> 0 \<and> 0 \<le> ru1 \<and> ru2 \<le> 0"
     have r2:"r2 \<le> 0" using bounds dual_order.trans gru2 by blast
     consider (Pos) "r1 \<ge> 0" | (Neg) "r1 \<le> 0" using le_cases by auto
     then show ?thesis
     proof (cases)
       case Pos
       have bound:"rl2 \<le> 0"
         using Pos r2 bounds grl1 grl2 gru1 gru2 dual_order.trans by auto
       then have g1:"ru1 * rl2 \<le> ru1 * r2" 
         using Pos bounds grl1 grl2 gru1 gru2 mult_le_cancel_left
         by fastforce
       have p1:"\<And>a::real. (0 \<le> - a) = (a \<le> 0)"
         by(auto)
       have p2:"\<And>a b::real.  (- a \<le> - b) = (b \<le> a)" by auto
       have g2:"ru1 * r2 \<le> r1 * r2"
         using Pos r2 bounds grl1 grl2 gru1 gru2 p1 p2
         by (simp add: mult_right_mono_neg)
       from g1 and g2
       have up:"ru1 * rl2 \<le> r1 * r2"
         by auto
       show ?thesis 
         by (metis up maxU12 maxU34 wmin.elims min_repU2 min_repU1 repL_def timesul tl.simps)
     next
       case Neg
       have g1:"ru1 * ru2 \<le> 0" 
         using Neg r2 bounds  grl1 grl2 gru1 gru2 mult_le_0_iff by blast
       have g2:"0 \<le> r1 * r2"
         using Neg r2 zero_le_mult_iff by blast  
       from g1 and g2
       have up:"ru1 * ru2 \<le> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmin.elims min_repU2 min_repU1 
         min.coboundedI1 min.commute maxt34 
         by (metis repL_def tl.simps) 
       qed
   next
     case PosZero
     assume bounds:"0 \<le> rl1 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2"
     have r1:"r1 \<ge> 0" using bounds dual_order.trans grl1 by blast
     have bound:"0 \<le> ru1" using r1 bounds grl1 grl2 gru1 gru2 dual_order.trans by auto
     consider "r2 \<ge> 0" | "r2 \<le> 0" using le_cases by auto
     then show ?thesis
     proof (cases)
       case 1
       have g1:"rl1 * rl2 \<le> 0" 
         using r1 "1" bounds grl1 grl2 gru1 gru2 mult_le_0_iff by blast
       have g2:"0 \<le> r1 * r2"
         using r1 "1" bounds grl1 grl2 gru1 gru2 zero_le_mult_iff by blast
       from g1 and g2
       have up:"rl1 * rl2 \<le> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmax.elims min_repU2 min_repU1 
         min.coboundedI1 min.commute maxt12 maxt34 repL_def timesll tl.simps
         by metis          
     next
       case 2
       have g1:"ru1 * rl2 \<le> ru1 * r2" 
         using r1 "2" bounds bound grl1 grl2 gru1 gru2
         using mult_left_mono by blast
       have g2:"ru1 * r2 \<le> r1 * r2"
         using r1 "2" bounds bound grl2 gru2
         by (metis mult_left_mono_neg gru1 mult.commute)
       from g1 and g2
       have up:"ru1 * rl2 \<le> r1 * r2"
         by auto
       show ?thesis
         using up maxU12 maxU34 bigMaxU wmin.elims min_repU2 min_repU1 maxt34
         by (metis repL_def timesul tl.simps)
       qed
   next
     case NegZero
     assume bounds:"ru1 \<le> 0 \<and> rl2 \<le> 0 \<and> 0 \<le> ru2"
     have r1:"r1 \<le> 0"  using bounds dual_order.trans gru1 by blast
     have bound:"rl1 \<le> 0" using r1  bounds grl1 grl2 gru1 gru2 dual_order.trans by auto
     consider "r2 \<ge> 0" | "r2 \<le> 0" using le_cases by auto
     then show ?thesis
     proof (cases)
       case 1
       assume r2:"r2 \<ge> 0"
       have g1:"rl1 * ru2 \<le> rl1 * r2" 
         using r1 r2 bounds bound grl1 grl2 gru1 gru2
         by (metis mult_le_cancel_left leD)  
       have g2:"rl1 * r2 \<le> r1 * r2"
         using r1 r2 bounds grl1 grl2 gru1 gru2 mult_right_mono 
         by (simp add: mult_le_0_iff)
       from g1 and g2
       have up:"rl1 * ru2 \<le> r1 * r2"
         by auto
       show ?thesis
       using up maxU12 maxU34 bigMaxU min_repU2 min_repU1 min.coboundedI1 maxt34
       by (metis min_repU2 repL_def tl.simps) 
     next
       case 2
       assume r2:"r2 \<le> 0"
       have lower:"rl1 \<le> 0" using bounds dual_order.trans grl1 r1 by blast
       have g1:"ru1 * ru2 \<le> 0" 
         using r1 r2 bounds  grl1 grl2 gru1 gru2 mult_le_0_iff by blast
       have g2:"0 \<le> r1 * r2"
         using r1 r2 
         by (simp add: zero_le_mult_iff)
       from g1 and g2
       have up:"ru1 * ru2 \<le> r1 * r2"
         by auto
       show ?thesis
       using up maxU12 maxU34 bigMaxU wmin.elims min_repU2 min_repU1 
         min.coboundedI1 min.commute maxt34
       by (metis repL_def tl.simps)
       qed
   next
     case NegNeg
     assume bounds:"ru1 \<le> 0 \<and> ru2 \<le> 0"
     have r1:"r1 \<le> 0" using bounds dual_order.trans gru1 by blast
     have r2:"r2 \<le> 0" using bounds dual_order.trans gru2 by blast
     have lower1:"rl1 \<le> 0" using bounds dual_order.trans grl1 r1 by blast
     have lower2:"rl2 \<le> 0" using bounds dual_order.trans grl2 r2 by blast
     have g1:"ru1 * ru2 \<le> ru1 * r2" 
       using r1 r2 bounds  grl1 grl2 gru1 gru2
       using    not_less mult_le_cancel_left
       by metis
     have g2:"ru1 * r2 \<le> r1 * r2"
       using r1 r2 bounds grl1 grl2 gru1 gru2 mult_le_cancel_left mult.commute not_le lower1 lower2
       by metis
     from g1 and g2
     have up:"ru1 * ru2 \<le> r1 * r2"
       by auto
     show ?thesis
       using up maxU12 maxU34 bigMaxU 
       wmin.elims min_repU2 min_repU1 
       min.coboundedI1 min.commute maxt34 
       by (metis repL_def tl.simps)
   next
     case NegPos
     assume bounds:"ru1 \<le> 0 \<and> 0 \<le> rl2"
     have r1:"r1 \<le> 0" using bounds dual_order.trans gru1 by blast
     have r2:"r2 \<ge> 0" using bounds dual_order.trans grl2 by blast
     have lower1:"rl1 \<le> 0" using bounds dual_order.trans grl1 r1 by blast
     have lower2:"rl2 \<ge> 0" using bounds by auto
     have upper1:"ru1 \<le> 0" using bounds by auto 
     have upper2:"ru2 \<ge> 0" using bounds dual_order.trans gru2 r2 by blast
     have g1:"rl1 * ru2 \<le> rl1 * r2" 
       using r1 r2 bounds grl1 grl2 gru1 gru2 less_le_trans upper1 lower2 
       by (metis mult_le_cancel_left not_less)
     have g2:"rl1 * r2 \<le> r1 * r2"
       using r1 upper1 r2 mult_right_mono mult_le_0_iff grl1 by blast
     from g1 and g2
     have up:"rl1 * ru2 \<le> r1 * r2"
       by auto
     show ?thesis
     using up maxU12 maxU34 bigMaxU wmin.elims min_repU2 min_repU1 maxt12 maxt34 
     by (metis repL_def timeslu tl.simps)
   next
     case PosNeg
     assume bounds:"0 \<le> rl1 \<and> ru2 \<le> 0"
     have r1:"r1 \<ge> 0" using bounds dual_order.trans grl1 by blast
     have r2:"r2 \<le> 0" using bounds dual_order.trans gru2 by blast
     have lower1:"rl1 \<ge> 0" using bounds by auto
     have lower2:"rl2 \<le> 0" using dual_order.trans grl2 r2 by blast
     have upper1:"ru1 \<ge> 0" using dual_order.trans gru1 u1 r1 by blast  
     have upper2:"ru2 \<le> 0" using bounds by auto
     have g1:"ru1 * rl2 \<le> ru1 * r2" 
       using r1 r2 bounds grl1 grl2 gru1 gru2 mult_left_mono less_le_trans not_less
       by metis
     have g2:"ru1 * r2 \<le> r1 * r2"
       using r1 lower1 r2 not_less gru2 gru1 grl1 grl2
       by (metis mult_le_cancel_left  mult.commute)
     from g1 and g2
     have up:"ru1 * rl2 \<le> r1 * r2"
       by auto
     show "tl l\<^sub>1 u\<^sub>1 l\<^sub>2 u\<^sub>2 \<equiv>\<^sub>L r1 * r2"
       using up maxU12 maxU34 bigMaxU wmin.elims min_repU2 min_repU1
       by (metis repL_def timesul tl.simps)
   next
     case PosPos
     assume bounds:"0 \<le> rl1 \<and> 0 \<le> rl2"
     have r1:"r1 \<ge> 0" using bounds dual_order.trans grl1 by blast
     have r2:"r2 \<ge> 0" using bounds dual_order.trans grl2 by blast
     have lower1:"rl1 \<ge> 0" using bounds by auto
     have lower2:"rl2 \<ge> 0" using bounds by auto
     have upper1:"ru1 \<ge> 0" using dual_order.trans gru1 u1 r1 by blast  
     have upper2:"ru2 \<ge> 0" using dual_order.trans gru2 u2 r2 bounds by blast
     have g1:"rl1 * rl2 \<le> rl1 * r2" 
       using r1 r2 bounds grl1 grl2 gru1 gru2
       using mult_left_mono 
       using leD leI less_le_trans by auto
     have g2:"rl1 * r2 \<le> r1 * r2"
       using r1 r2 bounds grl1 grl2 gru1 gru2
       using mult_right_mono by blast
     from g1 and g2
     have up:"rl1 * rl2 \<le> r1 * r2"
       by auto
     show ?thesis
     using up maxU12 maxU34 bigMaxU min_repU2 min_repU1 min.coboundedI1 maxt12 maxt34
       by (metis repL_def tl.simps)
   qed
 qed
 
 text\<open>Most significant bit only changes under successor when all other bits are 1\<close>
 lemma msb_succ:
   fixes w :: "32 Word.word"
   assumes neq1:"uint w \<noteq> 0xFFFFFFFF"
   assumes neq2:"uint w \<noteq> 0x7FFFFFFF"
   shows "msb (w + 1) = msb w"
   proof -
     have "w \<noteq> 0xFFFFFFFF"
       using neq1 by auto
     then have neqneg1:"w \<noteq> -1" by auto
     have "w \<noteq> 0x7FFFFFFF"
       using neq2 by auto
     then have neqneg2:"w \<noteq> (2^31)-1" by auto
     show ?thesis using neq1 neq2  unfolding msb_big
-    using Word_Lemmas.word_le_make_less[of "w + 1" "0x80000000"] 
-          Word_Lemmas.word_le_make_less[of "w " "0x80000000"]
+    using word_le_make_less[of "w + 1" "0x80000000"] 
+          word_le_make_less[of "w " "0x80000000"]
           neqneg1 neqneg2
       by auto
   qed
 
 text\<open>Negation commutes with msb except at edge cases\<close>
 lemma msb_non_min:
   fixes w :: "32 Word.word"
   assumes neq1:"uint w \<noteq> 0"
   assumes neq2:"uint w \<noteq> ((2^(len_of (TYPE(31)))))"
   shows "msb (uminus w) = HOL.Not(msb(w))"
   proof -
     have fact1:"uminus w = word_succ (~~ w)"
       by (rule twos_complement)
     have fact2:"msb (~~w) = HOL.Not(msb w)"
       using word_ops_msb[of w] 
       by auto
     have neqneg1:"w \<noteq> 0" using neq1 by auto
     have not_undef:"w \<noteq> 0x80000000"
       using neq2 by auto
     then have neqneg2:"w \<noteq> (2^31)" by auto
     from \<open>w \<noteq> 0\<close> have \<open>~~ w \<noteq> ~~ 0\<close>
       by (simp only: bit.compl_eq_compl_iff) simp
     then have "(~~ w) \<noteq> 0xFFFFFFFF"
       by auto
     then have uintNeq1:"uint (~~ w) \<noteq> 0xFFFFFFFF"
       using uint_distinct[of "~~w" "0xFFFFFFFF"] 
       by auto
     from \<open>w \<noteq> 2 ^ 31\<close> have \<open>~~ w \<noteq> ~~ 2 ^ 31\<close>
       by (simp only: bit.compl_eq_compl_iff) simp
     then have "(~~ w) \<noteq> 0x7FFFFFFF"
       by auto
     then have uintNeq2:" uint (~~ w) \<noteq> 0x7FFFFFFF"
       using uint_distinct[of "~~w" "0x7FFFFFFF"]
       by auto
     have fact3:"msb ((~~w) + 1) = msb (~~w)"
       apply(rule msb_succ[of "~~w"])
       using neq1 neq2 uintNeq1 uintNeq2 by auto 
     show "msb (uminus w) = HOL.Not(msb(w))"
       using fact1 fact2 fact3 by (simp add: word_succ_p1)
     qed
 
 text\<open>Only 0x80000000 preserves msb=1 under negation\<close>
 lemma msb_min_neg:
   fixes w::"word"
   assumes msb1:"msb (- w)"
   assumes msb2:"msb w"
   shows "uint w = ((2^(len_of (TYPE(31)))))"
 proof (rule ccontr)
   from \<open>msb w\<close> have \<open>w \<noteq> 0\<close>
     using word_msb_0 by auto
   then have \<open>uint w \<noteq> 0\<close>
     by transfer simp
   moreover assume \<open>uint w \<noteq> 2 ^ LENGTH(31)\<close>
   ultimately have \<open>msb (- w) \<longleftrightarrow> \<not> msb w\<close>
     by (rule msb_non_min)
   with assms show False
     by simp
 qed
 
 text\<open>Only 0x00000000 preserves msb=0 under negation\<close>
 lemma msb_zero:
   fixes w::"word"
   assumes msb1:"\<not> msb (- w)"
   assumes msb2:"\<not> msb w"
   shows "uint w = 0"
   proof -
     have neq:"w \<noteq> ((2 ^ len_of TYPE(31))::word)" using msb1 msb2 by auto
     have eq:"uint ((2 ^ len_of TYPE(31))::word) = 2 ^ len_of TYPE(31)" 
       by auto
     then have neq:"uint w \<noteq> uint ((2 ^ len_of TYPE(31))::word)" 
       using uint_distinct[of w "2^len_of TYPE(31)"] neq eq by auto
     show ?thesis
       using msb1 msb2 minus_zero msb_non_min[of w] neq by force
   qed
     
 text\<open>Finite numbers alternate msb under negation\<close>
 lemma msb_pos:
   fixes w::"word"
   assumes msb1:"msb (- w)"
   assumes msb2:"\<not> msb w"
   shows "uint w \<in> {1 .. (2^((len_of TYPE(32)) - 1))-1}" 
   proof -
     have main: "w \<in> {1 .. (2^((len_of TYPE(32)) - 1))-1}"
       using msb1 msb2 apply(clarsimp) 
       unfolding word_msb_sint
       apply(rule conjI)
       apply (metis neg_equal_0_iff_equal not_le word_less_1)
       proof -
         have imp:"w \<ge> 0x80000000 \<Longrightarrow> False"
           proof -
             assume geq:"w \<ge> 0x80000000"
             then have "msb w"
-              using Word_Lemmas.msb_big[of w] by auto
+              using msb_big [of w] by auto
             then show False using msb2 by auto
           qed
         have mylem:"\<And>w1 w2::word. uint w1 \<ge> uint w2 \<Longrightarrow> w1 \<ge> w2" 
           subgoal for w1 w2 
             by (simp add: word_le_def)
           done
         have mylem2:"\<And>w1 w2::word.  w1 >  w2 \<Longrightarrow> uint w1 > uint w2" 
           subgoal for w1 w2 
             by (simp add: word_less_def)
           done
         have gr_to_geq:"w > 0x7FFFFFFF \<Longrightarrow> w \<ge> 0x80000000"
           apply(rule mylem)
           using mylem2[of "0x7FFFFFFF" "w"] by auto
         have taut:"w \<le> 0x7FFFFFFF \<or> w > 0x7FFFFFFF" by auto        
         then show "w \<le> 0x7FFFFFFF"
         using imp taut gr_to_geq by auto
       qed
     have set_eq:"(uint ` (({1..(minus(2 ^ (minus(len_of TYPE(32))  1)) 1)})::word set)) 
                = ({1..minus(2 ^ (minus (len_of TYPE(32)) 1)) 1}::int set)"
       apply(auto simp add: word_le_def)
       subgoal for xa 
       proof -
         assume lower:"1 \<le> xa" and upper:"xa \<le> 2147483647"
         then have in_range:"xa \<in> {0 .. 2^32-1}" by auto
         then have "xa \<in> range (uint::word \<Rightarrow> int)" 
           unfolding word_uint.Rep_range uints_num by auto
         then obtain w::word  where xaw:"xa = uint w" by auto
         then have "w \<in> {1..0x7FFFFFFF} " 
         using lower upper apply(clarsimp, auto)
         by (auto simp add: word_le_def)
         then show ?thesis
           using uint_distinct uint_distinct main image_eqI word_le_def xaw by blast
       qed
       done
     then show  "uint w \<in> {1..2 ^ (len_of TYPE(32) - 1) - 1}" 
       using uint_distinct uint_distinct main image_eqI
       by blast
     qed
     
 lemma msb_neg:
   fixes w::"word"
   assumes msb1:"\<not> msb (- w)"
   assumes msb2:"msb w"
   shows "uint w \<in> {2^((len_of TYPE(32) - 1))+1 .. 2^((len_of TYPE(32)))-1}" 
   proof -
     have mylem:"\<And>w1 w2::word. uint w1 \<ge> uint w2 \<Longrightarrow> w1 \<ge> w2" 
       by (simp add: word_le_def)
     have mylem2:"\<And>w1 w2::word.  w1 >  w2 \<Longrightarrow> uint w1 > uint w2" 
       by (simp add: word_less_def)
     have gr_to_geq:"w > 0x80000000 \<Longrightarrow> w \<ge> 0x80000001"
       apply(rule mylem)
       using mylem2[of "0x80000000" "w"] by auto
     have taut:"w \<le> 0x80000000 \<or> 0x80000000 < w" by auto
     have imp:"w \<le> 0x80000000 \<Longrightarrow> False"
       proof -
         assume geq:"w \<le> 0x80000000"
         then have "(msb (-w))"
-          using Word_Lemmas.msb_big[of "-w"] Word_Lemmas.msb_big[of "w"] 
+          using msb_big [of "- w"] msb_big [of "w"] 
           by (simp add: msb2) 
         then show False using msb1 by auto
       qed
     have main: "w \<in> {2^((len_of TYPE(32)) - 1)+1 .. 2^((len_of TYPE(32)))-1}"  
       using msb1 msb2 apply(clarsimp)
       unfolding word_msb_sint
       proof -
         show "0x80000001 \<le> w"
         using imp taut gr_to_geq by auto
       qed
     have set_eq:"(uint ` (({2^((len_of TYPE(32) - 1))+1 .. 2^((len_of TYPE(32)))-1})::word set)) 
                        = {2^((len_of TYPE(32) - 1))+1 .. 2^((len_of TYPE(32)))-1}"
       apply(auto)
       subgoal for xa by (simp add: word_le_def)
       subgoal for w using uint_lt [of w] by simp
       subgoal for xa
       proof -
         assume lower:"2147483649 \<le> xa" and upper:"xa \<le> 4294967295"
         then have in_range:"xa \<in> {0x80000000 .. 0xFFFFFFFF}" by auto
         then have "xa \<in> range (uint::word \<Rightarrow> int)" 
           unfolding word_uint.Rep_range uints_num by auto
         then obtain w::word  where xaw:"xa = uint w" by auto
         then have the_in:"w \<in> {0x80000001 .. 0xFFFFFFFF} " 
           using lower upper
           by (auto simp add: word_le_def)
         have the_eq:"(0xFFFFFFFF::word) = -1" by auto
         from the_in the_eq have "w \<in> {0x80000001 .. -1}" by auto
         then show ?thesis
       using uint_distinct uint_distinct main image_eqI word_le_def xaw by blast
       qed
       done
     then show  "uint w \<in> {2^((len_of TYPE(32)) - 1)+1 .. 2^((len_of TYPE(32)))-1}" 
       using uint_distinct uint_distinct main image_eqI
       by blast
     qed
 
 text\<open>2s-complement commutes with negation except edge cases\<close>
 lemma sint_neg_hom:
   fixes w :: "32 Word.word"
   shows "uint w \<noteq> ((2^(len_of (TYPE(31))))) \<Longrightarrow> (sint(-w) = -(sint w))"
   unfolding word_sint_msb_eq apply auto
     subgoal using msb_min_neg by auto 
    prefer 3 subgoal using msb_zero[of w] by (simp add: msb_zero)
   proof -
     assume msb1:"msb (- w)"
     assume msb2:"\<not> msb w"
     have "uint w \<in> {1 .. (2^((len_of TYPE(32)) - 1))-1}" using msb_pos[OF msb1 msb2] by auto
     then have bound:"uint w \<in> {1 .. 0x7FFFFFFF}" by auto
     have size:"size (w::32 Word.word) = 32" using Word.word_size[of w] by auto 
     have lem:"\<And>x::int. \<And>n::nat.   x \<in> {1..(2^n)-1} \<Longrightarrow> ((- x) mod (2^n)) - (2^n) = - x"
       subgoal for x n
         apply(cases "x mod 2^n = 0")
         by(auto simp add: Divides.zmod_zminus1_eq_if[of x  "2^n"])
       done
     have lem_rule:"uint w \<in> {1..2 ^ 32 - 1} 
       \<Longrightarrow> (- uint w mod  4294967296) - 4294967296 = - uint w"
       using lem[of "uint w" 32] by auto
     have almost:"- uint w mod 4294967296 - 4294967296 = - uint w"
       apply(rule lem_rule)  
       using bound by auto
     show "uint (- w) - 2 ^ size (- w) = - uint w"
     using bound
     unfolding Word.uint_word_ariths word_size_neg by (auto simp add: size almost)
 next
   assume neq:"uint w \<noteq> 0x80000000"
   assume msb1:"\<not> msb (- w)"
   assume msb2:"msb w"
   have bound:"uint w \<in> {0x80000001.. 0xFFFFFFFF}" using msb1 msb2 msb_neg by auto
   have size:"size (w::32 Word.word) = 32" using Word.word_size[of w] by auto
   have lem:"\<And>x::int. \<And>n::nat.   x \<in> {1..(2^n)-1} \<Longrightarrow> (-x mod (2^n)) = (2^n) - x"
       subgoal for x n
         apply(auto)
         apply(cases "x mod 2^n = 0")
         by (simp add: Divides.zmod_zminus1_eq_if[of x  "2^n"])+
       done
   from bound 
   have  wLeq: "uint w \<le> 4294967295"
     and wGeq: "2147483649 \<le> uint w"
     by auto
   from wLeq have wLeq':"uint w \<le> 4294967296" by fastforce
   have f3: "(0 \<le> 4294967296 + - 1 * uint w + - 1 * ((4294967296 + - 1 * uint w) mod 4294967296))
             = (uint w + (4294967296 + - 1 * uint w) mod 4294967296 \<le> 4294967296)"
     by auto
   have f4: "(0 \<le> 4294967296 + - 1 * uint w) = (uint w \<le> 4294967296)"
     by auto
   have f5: "\<forall>i ia. \<not> (0::int) \<le> i \<or> 0 \<le> i + - 1 * (i mod ia)"
     by (simp add: zmod_le_nonneg_dividend)
   then have f6: "uint w + (4294967296 + - 1 * uint w) mod 4294967296 \<le> 4294967296"
     using f4 f3 wLeq' by blast
   have f7: "4294967296 + - 1 * uint w + - 4294967296 = - 1 * uint w"
     by auto
   have f8: "- (1::int) * 4294967296 = - 4294967296"
     by auto
   have f9: "(0 \<le> - 1 * uint w) = (uint w \<le> 0)"
     by auto
   have f10: "(4294967296 + -1 * uint w + -1 * ((4294967296 + -1 * uint w) mod 4294967296) \<le> 0) 
            = (4294967296 \<le> uint w + (4294967296 + - 1 * uint w) mod 4294967296)"
     by auto
   have f11: "\<not> 4294967296 \<le> (0::int)"
     by auto
   have f12: "\<forall>x0. ((0::int) < x0) = (\<not> x0 \<le> 0)"
     by auto
   have f13: "\<forall>x0 x1. ((x1::int) < x0) = (\<not> 0 \<le> x1 + - 1 * x0)"
     by auto
   have f14: "\<forall>x0 x1. ((x1::int) \<le> x1 mod x0) = (x1 + - 1 * (x1 mod x0) \<le> 0)"
     by auto
   have "\<not> uint w \<le> 0"
     using wGeq by fastforce
   then have "4294967296 \<le> uint w + (4294967296 + - 1 * uint w) mod 4294967296"
     using f14 f13 f12 f11 f10 f9 f8 f7 by (metis (no_types) int_mod_ge)
   then 
   show "uint (- w) = 2 ^ size w - uint w"
     using f6
     unfolding Word.uint_word_ariths  
     by (auto simp add: size f4)
   qed
 
 text\<open>2s-complement encoding is injective\<close>
 lemma sint_dist:
   fixes x y ::word
   assumes "x \<noteq> y"
   shows "sint x \<noteq> sint y"
   by (simp add: assms)
 
 subsection\<open>Negation\<close>
 fun wneg :: "word \<Rightarrow> word"
 where "wneg w = 
   (if w = NEG_INF then POS_INF else if w = POS_INF then NEG_INF else -w)"
 
 text\<open>word negation is correct\<close>
 lemma wneg_lemma:
   assumes eq:"w \<equiv>\<^sub>E (r::real)"
   shows "wneg w \<equiv>\<^sub>E -r"
   apply(rule repe.cases[OF eq])
     apply(auto intro!: repNEG_INF repPOS_INF simp add: repe.simps)[2]
   subgoal for ra
   proof -
     assume eq:"w = ra"
     assume i:"r =  (real_of_int (sint ra))"
     assume bounda:" (real_of_int (sint ra)) <  (real_of_int (sint POS_INF))"
     assume boundb:" (real_of_int (sint NEG_INF)) <  (real_of_int (sint ra))"
     have raNeq:"ra \<noteq> 2147483647"
       using sint_range[OF bounda boundb]
       by (auto)
     have raNeqUndef:"ra \<noteq> 2147483648"
       using int_not_undef[OF bounda boundb]
       by (auto)
     have "uint ra \<noteq> uint ((2 ^ len_of TYPE(31))::word)"
       apply (rule uint_distinct)
       using raNeqUndef by auto
     then have raNeqUndefUint:"uint ra \<noteq> ((2 ^ len_of TYPE(31)))"
       by auto
     have res1:"wneg w \<equiv>\<^sub>E  (real_of_int (sint (wneg w)))"
       apply (rule repINT)
       using sint_range[OF bounda boundb] sint_neg_hom[of ra, OF raNeqUndefUint]
       raNeq raNeqUndefUint raNeqUndef eq 
       by(auto)
     have res2:"- r =  (real_of_int (sint (wneg w)))"
       using eq bounda boundb i sint_neg_hom[of ra, OF raNeqUndefUint] raNeq raNeqUndef eq
       apply auto
       apply transfer
       apply simp
       done
     show ?thesis
       using res1 res2 by auto
     qed
   done
 
 subsection\<open>Comparison\<close>
 fun wgreater :: "word \<Rightarrow> word \<Rightarrow> bool"
 where "wgreater w1 w2 = (sint w1 > sint w2)"
 
 lemma neg_less_contra:"\<And>x. Suc x < - (Suc x) \<Longrightarrow> False"
   by auto
 
 text\<open>Comparison < is correct\<close>
 lemma wgreater_lemma:"w1 \<equiv>\<^sub>L (r1::real) \<Longrightarrow> w2 \<equiv>\<^sub>U r2 \<Longrightarrow> wgreater w1 w2 \<Longrightarrow> r1 > r2"
   proof (auto simp add: repU_def repL_def)
     fix r'\<^sub>1 r'\<^sub>2
     assume sint_le:"sint w1 > sint w2"
     then have sless:"(w2 <s w1)" using word_sless_alt by auto
     assume r1_leq:"r'\<^sub>1 \<le> r1"
     assume r2_leq:"r2 \<le> r'\<^sub>2"
     assume wr1:"w1 \<equiv>\<^sub>E r'\<^sub>1"
     assume wr2:"w2 \<equiv>\<^sub>E r'\<^sub>2"
     have greater:"r'\<^sub>1 > r'\<^sub>2" 
       using wr1 wr2 apply(auto simp add: repe.simps)
              prefer 4 using sless sint_le
              apply (auto simp add: less_le_trans not_le)
         apply transfer apply simp
        apply transfer apply simp
       apply transfer apply simp
       done
     show "r1 > r2"
       using r1_leq r2_leq greater by auto
   qed
 
 text\<open>Comparison $\geq$ of words\<close>
 fun wgeq :: "word \<Rightarrow> word \<Rightarrow> bool"
 where "wgeq w1 w2 =
 ((\<not> ((w2 = NEG_INF \<and> w1 = NEG_INF)
   \<or>(w2 = POS_INF \<and> w1 = POS_INF))) \<and>
 (sint w2 \<le> sint w1))"
 
 text\<open>Comparison $\geq$ of words is correct\<close>
 lemma wgeq_lemma:"w1 \<equiv>\<^sub>L r1 \<Longrightarrow> w2 \<equiv>\<^sub>U (r2::real) \<Longrightarrow> wgeq w1 w2 \<Longrightarrow> r1 \<ge> r2"
   proof (unfold wgeq.simps)
     assume assms:"\<not> (w2 = NEG_INF \<and> w1 = NEG_INF \<or> w2 = POS_INF \<and> w1 = POS_INF) \<and> sint w2 \<le> sint w1"
     assume a1:"w1 \<equiv>\<^sub>L r1" and a2:"w2 \<equiv>\<^sub>U (r2::real)"
     from assms have sint_le:"sint w2 \<le> sint w1" by auto
     then have sless:"(w2 <=s w1)" using word_sless_alt word_sle_def by auto
     obtain r'\<^sub>1 r'\<^sub>2 where  r1_leq:"r'\<^sub>1 \<le> r1" and r2_leq:"r2 \<le> r'\<^sub>2"
     and wr1:"w1 \<equiv>\<^sub>E r'\<^sub>1" and wr2:"w2 \<equiv>\<^sub>E r'\<^sub>2"
     using a1 a2 unfolding repU_def repL_def by auto
     from assms have check1:"\<not> (w1 = NEG_INF \<and> w2 = NEG_INF)" by auto
     from assms have check2:"\<not> (w1 = POS_INF \<and> w2 = POS_INF)" by auto
     have less:"r'\<^sub>2 \<le> r'\<^sub>1" 
       using sless sint_le check1 check2 repe.simps wr2 wr1
       apply (auto simp add: repe.simps)
              apply transfer
              apply simp
             apply transfer
             apply simp
            apply transfer
            apply simp
           apply transfer
           apply simp
          apply transfer
          apply simp
         apply transfer
         apply simp
        apply transfer
        apply simp
       apply transfer
       apply simp
       done
     show "r1 \<ge> r2"
       using r1_leq r2_leq less by auto
   qed
 
 subsection\<open>Absolute value\<close>
 
 text\<open>Absolute value of word\<close>
 fun wabs :: "word \<Rightarrow> word"
   where "wabs l1 = (wmax l1 (wneg l1))"
 
 text\<open>Correctness of wmax\<close>
 lemma wabs_lemma:
   assumes eq:"w \<equiv>\<^sub>E (r::real)"
   shows "wabs w \<equiv>\<^sub>E (abs r)"
 proof -
   have w:"wmax w (wneg w) \<equiv>\<^sub>E max r (-r)" by (rule wmax_lemma[OF eq wneg_lemma[OF eq]])
   have r:"max r (-r) = abs r" by auto
   from w r show ?thesis by auto
 qed
 
 declare more_real_of_word_simps [simp del]
 
 end
diff --git a/thys/Iptables_Semantics/Common/Word_Upto.thy b/thys/Iptables_Semantics/Common/Word_Upto.thy
--- a/thys/Iptables_Semantics/Common/Word_Upto.thy
+++ b/thys/Iptables_Semantics/Common/Word_Upto.thy
@@ -1,205 +1,206 @@
 section\<open>Word Upto\<close>
 theory Word_Upto
 imports Main
   IP_Addresses.Hs_Compat
   Word_Lib.Word_Lemmas
 begin
 
 
 text\<open>Enumerate a range of machine words.\<close>
 
 text\<open>enumerate from the back (inefficient)\<close>
 function word_upto :: "'a word \<Rightarrow> 'a word \<Rightarrow> ('a::len) word list" where
 "word_upto a b = (if a = b then [a] else word_upto a (b - 1) @ [b])"
 by pat_completeness auto
 
 (*by the way: does not terminate practically if b < a; will terminate after it
   reaches the word wrap-around!*)
 
 termination word_upto
 apply(relation "measure (unat \<circ> uncurry (-) \<circ> prod.swap)")
  apply(rule wf_measure; fail)
 apply(simp)
 apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
  apply(simp add: diff_right_commute; fail)
 apply(rule measure_unat)
 apply auto
 done
 
 declare word_upto.simps[simp del]
  
 
 text\<open>enumerate from the front (more inefficient)\<close>
 function word_upto' :: "'a word \<Rightarrow> 'a word \<Rightarrow> ('a::len) word list" where
 "word_upto' a b = (if a = b then [a] else a # word_upto' (a + 1) b)"
 by pat_completeness auto
 
 termination word_upto'
 apply(relation "measure (\<lambda> (a, b). unat (b - a))")
  apply(rule wf_measure; fail)
 apply(simp)
 apply(subgoal_tac "unat (b - a - 1) < unat (b - a)")
  apply (simp add: diff_diff_add; fail)
 apply(rule measure_unat)
 apply auto
 done
 
 declare word_upto'.simps[simp del]
 
 lemma word_upto_cons_front[code]:
  "word_upto a b = word_upto' a b"
  proof(induction a b rule:word_upto'.induct)
  case (1 a b)
    have hlp1: "a \<noteq> b \<Longrightarrow> a # word_upto (a + 1) b = word_upto a b"
    apply(induction a b rule:word_upto.induct)
    apply simp
    apply(subst(1) word_upto.simps)
    apply(simp)
    apply safe
     apply(subst(1) word_upto.simps)
     apply (simp)
     apply(subst(1) word_upto.simps)
     apply (simp; fail)
    apply(case_tac "a \<noteq> b - 1")
     apply(simp)
     apply (metis Cons_eq_appendI word_upto.simps)
    apply(simp)
    done
 
    from 1[symmetric] show ?case
      apply(cases "a = b")
       subgoal
       apply(subst word_upto.simps)
       apply(subst word_upto'.simps)
       by(simp)
      apply(subst word_upto'.simps)
      by(simp add: hlp1)
  qed
 
 
 (* Most of the lemmas I show about word_upto hold without a \<le> b,
    but I don't need that right now and it's giving me a headache *)
 
 
 lemma word_upto_set_eq: "a \<le> b \<Longrightarrow> x \<in> set (word_upto a b) \<longleftrightarrow> a \<le> x \<and> x \<le> b"
 proof
   show "a \<le> b \<Longrightarrow> x \<in> set (word_upto a b) \<Longrightarrow> a \<le> x \<and> x \<le> b"
     apply(induction a b rule: word_upto.induct)
     apply(case_tac "a = b")
      apply(subst(asm) word_upto.simps)
      apply(simp; fail)
     apply(subst(asm) word_upto.simps)
     apply(simp)
     apply(erule disjE)
      apply(simp; fail)
     proof(goal_cases)
      case (1 a b)
      from 1(2-3) have "b \<noteq> 0" by force
-     from 1(2,3) have "a \<le> b - 1" by (metis \<open>b \<noteq> 0\<close> eq_iff le_step_down_nat unat_arith_simps(1) unat_minus_one)
+     from 1(2,3) have "a \<le> b - 1"
+       by (simp add: word_le_minus_one_leq)
      from 1(1)[OF this 1(4)] show ?case by (metis dual_order.trans 1(2,3) less_imp_le measure_unat word_le_0_iff word_le_nat_alt)
     qed
 next
   show "a \<le> x \<and> x \<le> b \<Longrightarrow> x \<in> set (word_upto a b)"
     apply(induction a b rule: word_upto.induct)
     apply(case_tac "a = b")
      apply(subst word_upto.simps)
      apply(simp; force)
     apply(subst word_upto.simps)
     apply(simp)
     apply(case_tac "x = b")
      apply(simp;fail)
     proof(goal_cases)
        case (1 a b)
        from 1(2-4) have "b \<noteq> 0" by force
        from 1(2,4) have "x \<le> b - 1"
          using le_step_down_word by auto
        from 1(1) this show ?case by simp
     qed
 qed
 
 lemma word_upto_distinct_hlp: "a \<le> b \<Longrightarrow> a \<noteq> b \<Longrightarrow> b \<notin> set (word_upto a (b - 1))"
    apply(rule ccontr, unfold not_not)
    apply(subgoal_tac "a \<le> b - 1")
     apply(drule iffD1[OF word_upto_set_eq[of a "b -1" b]])
      apply(simp add: word_upto.simps)
     apply(subgoal_tac "b \<noteq> 0")
      apply(meson leD measure_unat word_le_nat_alt)
    apply(blast intro: iffD1[OF word_le_0_iff])
   using le_step_down_word apply blast
 done
 
 lemma distinct_word_upto: "a \<le> b \<Longrightarrow> distinct (word_upto a b)"
 apply(induction a b rule: word_upto.induct)
 apply(case_tac "a = b")
  apply(subst word_upto.simps)
  apply(simp; force)
 apply(subst word_upto.simps)
 apply(case_tac "a \<le> b - 1")
  apply(simp)
  apply(rule word_upto_distinct_hlp; simp)
 apply(simp)
   apply(rule ccontr)
   apply (simp add: not_le antisym word_minus_one_le_leq)
 done
 
 
 lemma word_upto_eq_upto: "s \<le> e \<Longrightarrow> e \<le> unat (max_word :: 'l word) \<Longrightarrow>
        word_upto ((of_nat :: nat \<Rightarrow> ('l :: len) word) s) (of_nat e) = map of_nat (upt s (Suc e))"
 proof(induction e)
   let ?mwon = "of_nat :: nat \<Rightarrow> 'l word"
   let ?mmw = "max_word :: 'l word"
   case (Suc e)
   show ?case
   proof(cases "?mwon s = ?mwon (Suc e)")
     case True
     have "s = Suc e" using le_unat_uoi Suc.prems True by metis
     with True show ?thesis by(subst word_upto.simps) (simp)
   next
     case False
     hence le: "s \<le> e" using le_SucE Suc.prems by blast
     have lm: "e \<le> unat ?mmw" using Suc.prems by simp
     have sucm: "(of_nat :: nat \<Rightarrow> ('l :: len) word) (Suc e) - 1 = of_nat e" using Suc.prems(2) by simp
     note mIH = Suc.IH[OF le lm]
     show ?thesis by(subst word_upto.simps) (simp add: False[simplified] Suc.prems mIH sucm)
   qed
 qed(simp add: word_upto.simps)
 
 lemma word_upto_alt: "(a :: ('l :: len) word) \<le> b \<Longrightarrow>
   word_upto a b = map of_nat (upt (unat a) (Suc (unat b)))"
 proof -
    let ?mmw = "max_word :: 'l word"
    assume le: "a \<le> b"
    hence nle: "unat a \<le> unat b" by(unat_arith)
    have lem: "unat b \<le> unat ?mmw" by (simp add: word_unat_less_le) 
    note word_upto_eq_upto[OF nle lem, unfolded word_unat.Rep_inverse]
    thus "word_upto a b = map of_nat [unat a..<Suc (unat b)]" .
 qed
 
 lemma word_upto_upt:
   "word_upto a b = (if a \<le> b then map of_nat (upt (unat a) (Suc (unat b))) else word_upto a b)"
   using word_upto_alt by metis
 
 lemma sorted_word_upto:
   fixes a b :: "('l :: len) word"
   assumes "a \<le> b"
   shows "sorted (word_upto a b)"
 proof -
   define m and n where \<open>m = unat a\<close> and \<open>n = Suc (unat b)\<close>
   moreover have \<open>sorted (map of_nat [m..<n] :: 'l word list)\<close>
     apply (simp add: sorted_map)
     apply (rule sorted_wrt_mono_rel [of _ \<open>(\<le>)\<close>])
      apply (simp_all flip: sorted_sorted_wrt)
     apply (simp add: le_unat_uoi less_Suc_eq_le n_def word_of_nat_le)
     apply transfer
     apply simp
     apply (subst take_bit_int_eq_self)
       apply (simp_all add: le_less_trans)
     apply (metis le_unat_uoi of_int_of_nat_eq of_nat_mono uint_word_of_int_eq unat_eq_nat_uint unsigned_of_int)
     done
   ultimately have \<open>sorted (map of_nat [unat a..<Suc (unat b)] :: 'l word list)\<close>
     by simp
   with assms show ?thesis
     by (simp only: word_upto_alt)
 qed
 
 end
diff --git a/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy b/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy
--- a/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy
+++ b/thys/LLL_Basis_Reduction/LLL_Number_Bounds.thy
@@ -1,1274 +1,1274 @@
 (*
     Authors:    Maximilian Haslbeck
                 René Thiemann
     License:    BSD
 *)
 subsection \<open>Explicit Bounds for Size of Numbers that Occur During LLL Algorithm\<close>
 
 text \<open>The LLL invariant does not contain bounds on the number that occur during the execution. 
   We here strengthen the invariant so that it enforces bounds on the norms of the $f_i$ and $g_i$
   and we prove that the stronger invariant is maintained throughout the execution of the LLL algorithm.
 
   Based on the stronger invariant we prove bounds on the absolute values of the $\mu_{i,j}$,
   and on the absolute values of the numbers in the vectors $f_i$ and $g_i$. 
   Moreover, we further show that also the denominators in all of these numbers doesn't grow to much.
   Finally, we prove that each number (i.e., numerator or denominator) during the execution 
   can be represented with at most ${\cal O}(m \cdot \log(M \cdot n))$ bits, where
   $m$ is the number of input vectors, $n$ is the dimension of the input vectors,
   and $M$ is the maximum absolute value of all numbers in the input vectors.
   Hence, each arithmetic operation in the LLL algorithm can be performed in polynomial time.\<close>
 theory LLL_Number_Bounds
   imports LLL
     Gram_Schmidt_Int
 begin
 
 
 
 context LLL
 begin
 
 text \<open>The bounds for the $f_i$ distinguishes whether we are inside or outside the inner for-loop.\<close>
 
 definition f_bound :: "bool \<Rightarrow> nat \<Rightarrow> int vec list \<Rightarrow> bool" where 
   "f_bound outside ii fs = (\<forall> i < m. sq_norm (fs ! i) \<le> (if i \<noteq> ii \<or> outside then int (N * m) else 
      int (4 ^ (m - 1) * N ^ m * m * m)))" 
 
 definition g_bnd :: "rat \<Rightarrow> int vec list \<Rightarrow> bool" where 
   "g_bnd B fs = (\<forall> i < m. sq_norm (gso fs i) \<le> B)" 
 
 definition "\<mu>_bound_row fs bnd i = (\<forall> j \<le> i. (\<mu> fs i j)^2 \<le> bnd)" 
 abbreviation "\<mu>_bound_row_inner fs i j \<equiv> \<mu>_bound_row fs (4 ^ (m - 1 - j) * of_nat (N ^ (m - 1) * m)) i"  
 
 definition "LLL_bound_invariant outside upw i fs =
   (LLL_invariant upw i fs \<and> f_bound outside i fs \<and> g_bound fs)" 
 
 lemma bound_invD: assumes "LLL_bound_invariant outside upw i fs" 
   shows "LLL_invariant upw i fs" "f_bound outside i fs" "g_bound fs"
   using assms unfolding LLL_bound_invariant_def by auto
 
 lemma bound_invI: assumes "LLL_invariant upw i fs" "f_bound outside i fs" "g_bound fs" 
   shows "LLL_bound_invariant outside upw i fs"
   using assms unfolding LLL_bound_invariant_def by auto
 
 lemma \<mu>_bound_rowI: assumes "\<And> j. j \<le> i \<Longrightarrow> (\<mu> fs i j)^2 \<le> bnd"
   shows "\<mu>_bound_row fs bnd i" 
   using assms unfolding \<mu>_bound_row_def by auto
 
 lemma \<mu>_bound_rowD: assumes "\<mu>_bound_row fs bnd i" "j \<le> i"
   shows "(\<mu> fs i j)^2 \<le> bnd"
   using assms unfolding \<mu>_bound_row_def by auto
 
 lemma \<mu>_bound_row_1: assumes "\<mu>_bound_row fs bnd i" 
   shows "bnd \<ge> 1"
 proof -
   interpret gs1: gram_schmidt_fs n "RAT fs" .
   show ?thesis
   using \<mu>_bound_rowD[OF assms, of i]
   by (auto simp: gs1.\<mu>.simps)
 qed
 
 lemma reduced_\<mu>_bound_row: assumes red: "reduced fs i"  
   and ii: "ii < i" 
 shows "\<mu>_bound_row fs 1 ii"
 proof (intro \<mu>_bound_rowI)
   fix j
   assume "j \<le> ii"
   interpret gs1: gram_schmidt_fs n "RAT fs" .
   show "(\<mu> fs ii j)^2 \<le> 1"
   proof (cases "j < ii")
     case True
     from red[unfolded gram_schmidt_fs.reduced_def, THEN conjunct2, rule_format, OF ii True]
     have "abs (\<mu> fs ii j) \<le> 1/2" by auto
     from mult_mono[OF this this]
     show ?thesis by (auto simp: power2_eq_square)
   qed (auto simp: gs1.\<mu>.simps)
 qed
 
 lemma f_bound_True_arbitrary: assumes "f_bound True ii fs"
   shows "f_bound outside j fs" 
   unfolding f_bound_def 
 proof (intro allI impI, rule ccontr, goal_cases)
   case (1 i)
   from 1 have nz: "\<parallel>fs ! i\<parallel>\<^sup>2 \<noteq> 0" by (auto split: if_splits)
   hence gt: "\<parallel>fs ! i\<parallel>\<^sup>2 > 0" using sq_norm_vec_ge_0[of "fs ! i"] by auto
   from assms(1)[unfolded f_bound_def, rule_format, OF 1(1)]
   have one: "\<parallel>fs ! i\<parallel>\<^sup>2 \<le> int (N * m) * 1" by auto
   from less_le_trans[OF gt one] have N0: "N \<noteq> 0" by (cases "N = 0", auto)
   note one
   also have "int (N * m) * 1 \<le> int (N * m) * int (4 ^ (m - 1) * N ^ (m - 1) * m)"
     by (rule mult_left_mono, unfold of_nat_mult, intro mult_ge_one, insert 1 N0, auto)  
   also have "\<dots> = int (4 ^ (m - 1) * N ^ (Suc (m - 1)) * m * m)" unfolding of_nat_mult by simp
   also have "Suc (m - 1) = m" using 1 by simp
   finally show ?case using one 1 by (auto split: if_splits)
 qed
 
 
 context fixes fs :: "int vec list" 
   assumes lin_indep: "lin_indep fs" 
   and len: "length fs = m" 
 begin
 
 interpretation fs: fs_int_indpt n fs
   by (standard) (use lin_indep in simp)
 
 
 lemma sq_norm_fs_mu_g_bound: assumes i: "i < m" 
   and mu_bound: "\<mu>_bound_row fs bnd i" 
   and g_bound: "g_bound fs" 
 shows "of_int \<parallel>fs ! i\<parallel>\<^sup>2 \<le> of_nat (Suc i * N) * bnd" 
 proof -
   have "of_int \<parallel>fs ! i\<parallel>\<^sup>2 = (\<Sum>j\<leftarrow>[0..<Suc i]. (\<mu> fs i j)\<^sup>2 * \<parallel>gso fs j\<parallel>\<^sup>2)" 
     by (rule fs.sq_norm_fs_via_sum_mu_gso) (use assms lin_indep len in auto)
   also have "\<dots> \<le> (\<Sum>j\<leftarrow>[0..<Suc i]. bnd * of_nat N)" 
   proof (rule sum_list_ge_mono, force, unfold length_map length_upt,
     subst (1 2) nth_map_upt, force, goal_cases)
     case (1 j)
     hence ji: "j \<le> i" by auto
     from g_bound[unfolded g_bound_def] i ji 
     have GB: "sq_norm (gso fs j) \<le> of_nat N" by auto
     show ?case 
       by (rule mult_mono, insert \<mu>_bound_rowD[OF mu_bound ji]
           GB order.trans[OF zero_le_power2], auto)
   qed
   also have "\<dots> = of_nat (Suc i) * (bnd * of_nat N)" unfolding sum_list_triv length_upt by simp
   also have "\<dots> = of_nat (Suc i * N) * bnd" unfolding of_nat_mult by simp
   finally show ?thesis .
 qed
 end
 
 lemma increase_i_bound: assumes LLL: "LLL_bound_invariant True upw i fs" 
   and i: "i < m" 
   and upw: "upw \<Longrightarrow> i = 0" 
   and red_i: "i \<noteq> 0 \<Longrightarrow> sq_norm (gso fs (i - 1)) \<le> \<alpha> * sq_norm (gso fs i)"
 shows "LLL_bound_invariant True True (Suc i) fs" 
 proof -
   from bound_invD[OF LLL] have LLL: "LLL_invariant upw i fs" 
     and "f_bound True i fs" and gbnd: "g_bound fs" by auto
   hence fbnd: "f_bound True (Suc i) fs" by (auto simp: f_bound_def)
   from increase_i[OF LLL i upw red_i]
   have inv: "LLL_invariant True (Suc i) fs" and "LLL_measure (Suc i) fs < LLL_measure i fs" (is ?g2) 
     by auto
   show "LLL_bound_invariant True True (Suc i) fs" 
     by (rule bound_invI[OF inv fbnd gbnd])
 qed
 
 text \<open>Addition step preserves @{term "LLL_bound_invariant False"}\<close>
 
 lemma basis_reduction_add_row_main_bound: assumes Linv: "LLL_bound_invariant False True i fs"
   and i: "i < m"  and j: "j < i" 
   and c: "c = round (\<mu> fs i j)" 
   and fs': "fs' = fs[ i := fs ! i - c \<cdot>\<^sub>v fs ! j]" 
   and mu_small: "\<mu>_small_row i fs (Suc j)" 
   and mu_bnd: "\<mu>_bound_row_inner fs i (Suc j)" 
 shows "LLL_bound_invariant False True i fs'"
   "\<mu>_bound_row_inner fs' i j"
 proof (rule bound_invI)
   from bound_invD[OF Linv]
   have Linv: "LLL_invariant True i fs" and fbnd: "f_bound False i fs" and gbnd: "g_bound fs"
     by auto
   note Linvw = LLL_inv_imp_w[OF Linv]
   note main = basis_reduction_add_row_main[OF Linvw i j fs']
   note main = main(2)[OF Linv] main(3,5-)
   note main = main(1) main(2)[OF c mu_small] main(3-)
   show Linv': "LLL_invariant True i fs'" by fact
   define bnd :: rat where bnd: "bnd = 4 ^ (m - 1 - Suc j) * of_nat (N ^ (m - 1) * m)" 
   note mu_bnd = mu_bnd[folded bnd]
   note inv = LLL_invD[OF Linv]
   let ?mu = "\<mu> fs"
   let ?mu' = "\<mu> fs'"
   from j have "j \<le> i" by simp
   let ?R = rat_of_int
 
   (* (squared) mu bound will increase at most by factor 4 *)
   have mu_bound_factor: "\<mu>_bound_row fs' (4 * bnd) i" 
   proof (intro \<mu>_bound_rowI)
     fix k
     assume ki: "k \<le> i" 
     from \<mu>_bound_rowD[OF mu_bnd] have bnd_i: "\<And> j. j \<le> i \<Longrightarrow> (?mu i j)^2 \<le> bnd" by auto
     have bnd_ik: "(?mu i k)\<^sup>2 \<le> bnd" using bnd_i[OF ki] by auto
     have bnd_ij: "(?mu i j)\<^sup>2 \<le> bnd" using bnd_i[OF \<open>j \<le> i\<close>] by auto
     from \<mu>_bound_row_1[OF mu_bnd] have bnd1: "bnd \<ge> 1" "bnd \<ge> 0" by auto
     show "(?mu' i k)\<^sup>2 \<le> 4 * bnd"
     proof (cases "k > j")
       case True
       show ?thesis
         by (subst main(5), (insert True ki i bnd1, auto)[3], intro order.trans[OF bnd_ik], auto)
     next
       case False
       hence kj: "k \<le> j" by auto
       show ?thesis
       proof (cases "k = j")
         case True 
         have small: "abs (?mu' i k) \<le> 1/2" using main(2) j unfolding True \<mu>_small_row_def by auto
         show ?thesis using mult_mono[OF small small] using bnd1 
           by (auto simp: power2_eq_square)
       next
         case False
         with kj have k_j: "k < j" by auto
         define M where "M = max (abs (?mu i k)) (max (abs (?mu i j)) (1/2))" 
         have M0: "M \<ge> 0" unfolding M_def by auto
         let ?new_mu = "?mu i k - ?R c * ?mu j k" 
         have "abs ?new_mu \<le> abs (?mu i k) + abs (?R c * ?mu j k)" by simp
         also have "\<dots> = abs (?mu i k) + abs (?R c) * abs (?mu j k)" unfolding abs_mult ..
         also have "\<dots> \<le> abs (?mu i k) + (abs (?mu i j) + 1/2) * (1/2)" 
         proof (rule add_left_mono[OF mult_mono], unfold c)
           show "\<bar>?R (round (?mu i j))\<bar> \<le> \<bar>?mu i j\<bar> + 1 / 2" unfolding round_def by linarith
           from inv(10)[unfolded gram_schmidt_fs.reduced_def, THEN conjunct2, rule_format, OF \<open>j < i\<close> k_j]
           show "\<bar>?mu j k\<bar> \<le> 1/2" .
         qed auto
         also have "\<dots> \<le> M + (M + M) * (1/2)" 
           by (rule add_mono[OF _ mult_right_mono[OF add_mono]], auto simp: M_def)
         also have "\<dots> = 2 * M" by auto
         finally have le: "abs ?new_mu \<le> 2 * M" .
         have "(?mu' i k)\<^sup>2 = ?new_mu\<^sup>2" 
           by (subst main(5), insert kj False i j, auto)
         also have "\<dots> \<le> (2 * M)^2" unfolding abs_le_square_iff[symmetric] using le M0 by auto
         also have "\<dots> = 4 * M^2" by simp
         also have "\<dots> \<le> 4 * bnd" 
         proof (rule mult_left_mono)            
           show "M^2 \<le> bnd" using bnd_ij bnd_ik bnd1 unfolding M_def
             by (auto simp: max_def power2_eq_square)
         qed auto
         finally show ?thesis .
       qed
     qed
   qed
   also have "4 * bnd = (4 ^ (1 + (m - 1 - Suc j)) * of_nat (N ^ (m - 1) * m))" unfolding bnd 
     by simp
   also have "1 + (m - 1 - Suc j) = m - 1 - j" using i j by auto
   finally show bnd: "\<mu>_bound_row_inner fs' i j" by auto
 
   show gbnd: "g_bound fs'" using gbnd unfolding g_bound_def
     using main(4) by auto
 
   note inv' = LLL_invD[OF Linv']
   show "f_bound False i fs'"
     unfolding f_bound_def
   proof (intro allI impI, goal_cases)
     case (1 jj)
     show ?case
     proof (cases "jj = i")
       case False
       with 1 fbnd[unfolded f_bound_def] have "\<parallel>fs ! jj\<parallel>\<^sup>2 \<le> int (N * m)" by auto
       thus ?thesis unfolding fs' using False 1 inv(2-) by auto
     next
       case True        
       have "of_int \<parallel>fs' ! i\<parallel>\<^sup>2 = \<parallel>RAT fs' ! i\<parallel>\<^sup>2" using i inv' by (auto simp: sq_norm_of_int)
       also have "... \<le> rat_of_nat (Suc i * N) * (4 ^ (m - 1 - j) * rat_of_nat (N ^ (m - 1) * m))" 
         using sq_norm_fs_mu_g_bound[OF inv'(1,6) i bnd gbnd] i inv'
         unfolding sq_norm_of_int[symmetric]
         by (auto simp: ac_simps)
       also have "\<dots> = rat_of_int ( int (Suc i * N) * (4 ^ (m - 1 - j) * (N ^ (m - 1) * m)))"
         by simp
       finally have "\<parallel>fs' ! i\<parallel>\<^sup>2 \<le> int (Suc i * N) * (4 ^ (m - 1 - j) * (N ^ (m - 1) * m))" by linarith
       also have "\<dots> = int (Suc i) * 4 ^ (m - 1 - j) * (int N ^ (Suc (m - 1))) * int m" 
         unfolding of_nat_mult by (simp add: ac_simps)
       also have "\<dots> = int (Suc i) * 4 ^ (m - 1 - j) * int N ^ m * int m" using i j by simp
       also have "\<dots> \<le> int m * 4 ^ (m - 1) * int N ^ m * int m" 
         by (rule mult_right_mono[OF mult_right_mono[OF mult_mono[OF _ pow_mono_exp]]], insert i, auto)
       finally have "\<parallel>fs' ! i\<parallel>\<^sup>2 \<le> int (4 ^ (m - 1) * N ^ m * m * m)" unfolding of_nat_mult by (simp add: ac_simps)
       thus ?thesis unfolding True by auto
     qed
   qed
 qed
 end
 
 context LLL_with_assms
 begin
 
 subsubsection \<open>@{const LLL_bound_invariant} is maintained during execution of @{const reduce_basis}\<close>
 
 lemma basis_reduction_add_rows_enter_bound: assumes binv: "LLL_bound_invariant True True i fs"
   and i: "i < m"   
 shows "LLL_bound_invariant False True i fs"
   "\<mu>_bound_row_inner fs i i" 
 proof (rule bound_invI)
   from bound_invD[OF binv]
   have Linv: "LLL_invariant True i fs" (is ?g1) and fbnd: "f_bound True i fs" 
     and gbnd: "g_bound fs" by auto
   note Linvw = LLL_inv_imp_w[OF Linv]
   interpret fs: fs_int' n m fs_init fs
     by standard (use Linvw in auto)
   note inv = LLL_invD[OF Linv]
   show "LLL_invariant True i fs" by fact
   show fbndF: "f_bound False i fs" using f_bound_True_arbitrary[OF fbnd] .
   have N0: "N > 0" using LLL_inv_N_pos[OF Linvw gbnd] i by auto
   {
     fix j
     assume ji: "j < i" 
     have "(\<mu> fs i j)\<^sup>2 \<le> gs.Gramian_determinant (RAT fs) j * \<parallel>RAT fs ! i\<parallel>\<^sup>2"
       using ji i inv by (intro fs.gs.mu_bound_Gramian_determinant) (auto)
     also have "gs.Gramian_determinant (RAT fs) j = of_int (d fs j)" unfolding d_def 
       by (subst fs.of_int_Gramian_determinant, insert ji i inv(2-), auto simp: set_conv_nth)
     also have "\<parallel>RAT fs ! i\<parallel>\<^sup>2 = of_int \<parallel>fs ! i\<parallel>\<^sup>2" using i inv(2-) by (auto simp: sq_norm_of_int)
     also have "of_int (d fs j) * \<dots> \<le> rat_of_nat (N^j) * of_int \<parallel>fs ! i\<parallel>\<^sup>2"
       by (rule mult_right_mono, insert ji i d_approx[OF Linvw gbnd, of j], auto)
     also have "\<dots> \<le> rat_of_nat (N^(m-2)) * of_int (int (N * m))" 
       by (intro mult_mono, unfold of_nat_le_iff of_int_le_iff, rule pow_mono_exp,
       insert fbnd[unfolded f_bound_def, rule_format, of i] N0 ji i, auto)
     also have "\<dots> = rat_of_nat (N^(m-2) * N * m)" by simp
     also have "N^(m-2) * N = N^(Suc (m - 2))" by simp
     also have "Suc (m - 2) = m - 1" using ji i by auto
     finally have "(\<mu> fs i j)\<^sup>2 \<le> of_nat (N ^ (m - 1) * m)" .
   } note mu_bound = this
   show mu_bnd: "\<mu>_bound_row_inner fs i i"
   proof (rule \<mu>_bound_rowI)
     fix j
     assume j: "j \<le> i" 
     have "(\<mu> fs i j)\<^sup>2 \<le> 1 * of_nat (N ^ (m - 1) * m)" 
     proof (cases "j = i")
       case False
       with mu_bound[of j] j show ?thesis by auto
     next
       case True
       show ?thesis unfolding True fs.gs.\<mu>.simps using i N0 by auto
     qed
     also have "\<dots> \<le> 4 ^ (m - 1 - i) * of_nat (N ^ (m - 1) * m)" 
       by (rule mult_right_mono, auto)
     finally show "(\<mu> fs i j)\<^sup>2 \<le> 4 ^ (m - 1 - i) * rat_of_nat (N ^ (m - 1) * m)" . 
   qed
   show "g_bound fs" by fact 
 qed
 
 lemma basis_basis_reduction_add_rows_loop_leave:
   assumes binv: "LLL_bound_invariant False True i fs" 
   and mu_small: "\<mu>_small_row i fs 0"
   and mu_bnd: "\<mu>_bound_row_inner fs i 0" 
   and i: "i < m" 
 shows "LLL_bound_invariant True False i fs" 
 proof -
   note Linv = bound_invD(1)[OF binv]
   from mu_small have mu_small: "\<mu>_small fs i" unfolding \<mu>_small_row_def \<mu>_small_def by auto
   note inv = LLL_invD[OF Linv]
   interpret gs1: gram_schmidt_fs_int n "RAT fs"
     by (standard) (use inv gs.lin_indpt_list_def in \<open>auto simp add: vec_hom_Ints\<close>)
   note fbnd = bound_invD(2)[OF binv]
   note gbnd = bound_invD(3)[OF binv]
   {
     fix ii
     assume ii: "ii < m" 
     have "\<parallel>fs ! ii\<parallel>\<^sup>2 \<le> int (N * m)" 
     proof (cases "ii = i")
       case False
       thus ?thesis using ii fbnd[unfolded f_bound_def] by auto
     next
       case True
       have row: "\<mu>_bound_row fs 1 i" 
       proof (intro \<mu>_bound_rowI)
         fix j
         assume j: "j \<le> i" 
         from mu_small[unfolded \<mu>_small_def, rule_format, of j]
         have "abs (\<mu> fs i j) \<le> 1" using j unfolding \<mu>_small_def by (cases "j = i", force simp: gs1.\<mu>.simps, auto)
         from mult_mono[OF this this] show "(\<mu> fs i j)\<^sup>2 \<le> 1" by (auto simp: power2_eq_square)
       qed
       have "rat_of_int \<parallel>fs ! i\<parallel>\<^sup>2 \<le> rat_of_int (int (Suc i * N))" 
         using sq_norm_fs_mu_g_bound[OF inv(1,6) i row gbnd] by auto
       hence "\<parallel>fs ! i\<parallel>\<^sup>2 \<le> int (Suc i * N)" by linarith
       also have "\<dots> = int N * int (Suc i)" unfolding of_nat_mult by simp
       also have "\<dots> \<le> int N * int m" 
         by (rule mult_left_mono, insert i, auto)
       also have "\<dots> = int (N * m)" by simp
       finally show ?thesis unfolding True .
     qed
   }
   hence f_bound: "f_bound True i fs" unfolding f_bound_def by auto
   with binv show ?thesis using basis_reduction_add_row_done[OF Linv i assms(2)] 
     by (auto simp: LLL_bound_invariant_def)
 qed
 
 
 lemma basis_reduction_add_rows_loop_bound: assumes
   binv: "LLL_bound_invariant False True i fs" 
   and mu_small: "\<mu>_small_row i fs j"
   and mu_bnd: "\<mu>_bound_row_inner fs i j" 
   and res: "basis_reduction_add_rows_loop i fs j = fs'" 
   and i: "i < m" 
   and j: "j \<le> i" 
 shows "LLL_bound_invariant True False i fs'" 
   using assms
 proof (induct j arbitrary: fs)
   case (0 fs)
   note binv = 0(1)
   from basis_basis_reduction_add_rows_loop_leave[OF 0(1-3) i] 0(4)
   show ?case by auto
 next
   case (Suc j fs)
   note binv = Suc(2)
   note Linv = bound_invD(1)[OF binv]
   note Linvw = LLL_inv_imp_w[OF Linv]
   from Suc have j: "j < i" by auto
   let ?c = "round (\<mu> fs i j)" 
   note step = basis_reduction_add_row_main_bound[OF Suc(2) i j refl refl Suc(3-4)]
   note step' = basis_reduction_add_row_main(2,3,5)[OF Linvw i j refl]
   note step' = step'(1)[OF Linv] step'(2-)
   show ?case
   proof (cases "?c = 0")
     case True
     note inv = LLL_invD[OF Linv]
     from inv(5)[OF i] inv(5)[of j] i j
     have id: "fs[i := fs ! i - 0 \<cdot>\<^sub>v fs ! j] = fs" 
       by (intro nth_equalityI, insert inv i, auto)
     show ?thesis 
       by (rule Suc(1), insert step step' id True Suc(2-), auto)
   next
     case False
     show ?thesis using Suc(1)[OF step(1) step'(2) step(2)] Suc(2-) False step'(3) by auto
   qed
 qed
 
 lemma basis_reduction_add_rows_bound: assumes 
   binv: "LLL_bound_invariant True upw i fs" 
   and res: "basis_reduction_add_rows upw i fs = fs'" 
   and i: "i < m" 
 shows "LLL_bound_invariant True False i fs'"  
 proof -
   note def = basis_reduction_add_rows_def
   show ?thesis
   proof (cases upw)
     case False
     with res binv show ?thesis by (simp add: def)
   next
     case True
     with binv have binv: "LLL_bound_invariant True True i fs" by auto
     note start = basis_reduction_add_rows_enter_bound[OF this i]
     from res[unfolded def] True 
     have "basis_reduction_add_rows_loop i fs i = fs'" by auto
     from basis_reduction_add_rows_loop_bound[OF start(1) \<mu>_small_row_refl start(2) this i le_refl]      
     show ?thesis by auto
   qed
 qed
 
 lemma g_bnd_swap:  
   assumes i: "i < m" "i \<noteq> 0"
   and Linv: "LLL_invariant_weak fs"
   and mu_F1_i: "\<bar>\<mu> fs i (i-1)\<bar> \<le> 1 / 2"
   and cond: "sq_norm (gso fs (i - 1)) > \<alpha> * sq_norm (gso fs i)" 
   and fs'_def: "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" 
   and g_bnd: "g_bnd B fs" 
 shows "g_bnd B fs'" 
 proof -
   note inv = LLL_inv_wD[OF Linv]
   have choice: "fs' ! k = fs ! k \<or> fs' ! k = fs ! i \<or> fs' ! k = fs ! (i - 1)" for k 
     unfolding fs'_def using i inv(6) by (cases "k = i"; cases "k = i - 1", auto) 
 
   let ?g1 = "\<lambda> i. gso fs i"
   let ?g2 = "\<lambda> i. gso fs' i" 
   let ?n1 = "\<lambda> i. sq_norm (?g1 i)"
   let ?n2 = "\<lambda> i. sq_norm (?g2 i)" 
   from g_bnd[unfolded g_bnd_def] have short: "\<And> k. k < m \<Longrightarrow> ?n1 k \<le> B" by auto
   from short[of "i - 1"] i 
   have short_im1: "?n1 (i - 1) \<le> B" by auto
   note swap = basis_reduction_swap_main[OF Linv disjI2[OF mu_F1_i] i cond fs'_def]
   note updates = swap(4,5)
   note Linv' = swap(1)
   note inv' = LLL_inv_wD[OF Linv']
   note inv = LLL_inv_wD[OF Linv]
   interpret gs1: gram_schmidt_fs_int n "RAT fs"
     by (standard) (use inv gs.lin_indpt_list_def in \<open>auto simp add: vec_hom_Ints\<close>)
   interpret gs2: gram_schmidt_fs_int n "RAT fs'"
     by (standard) (use inv' gs.lin_indpt_list_def in \<open>auto simp add: vec_hom_Ints\<close>)
   let ?mu1 = "\<mu> fs" 
   let ?mu2 = "\<mu> fs'" 
   let ?mu = "?mu1 i (i - 1)" 
   have mu: "abs ?mu \<le> 1/2" using mu_F1_i .
   have "?n2 (i - 1) = ?n1 i + ?mu * ?mu * ?n1 (i - 1)" 
    by (subst updates(2), insert i, auto)
   also have "\<dots> = inverse \<alpha> * (\<alpha> * ?n1 i) + (?mu * ?mu) * ?n1 (i - 1)" 
     using \<alpha> by auto
   also have "\<dots> \<le> inverse \<alpha> * ?n1 (i - 1) + (abs ?mu * abs ?mu) * ?n1 (i - 1)"
     by (rule add_mono[OF mult_left_mono], insert cond \<alpha>, auto)
   also have "\<dots> = (inverse \<alpha> + abs ?mu * abs ?mu) * ?n1 (i - 1)" by (auto simp: field_simps)
   also have "\<dots> \<le> (inverse \<alpha> + (1/2) * (1/2)) * ?n1 (i - 1)" 
     by (rule mult_right_mono[OF add_left_mono[OF mult_mono]], insert mu, auto)  
   also have "inverse \<alpha> + (1/2) * (1/2) = reduction" unfolding reduction_def using \<alpha>0 
     by (auto simp: field_simps)
   also have "\<dots> * ?n1 (i - 1) \<le> 1 * ?n1 (i - 1)" 
     by (rule mult_right_mono, auto simp: reduction)
   finally have n2im1: "?n2 (i - 1) \<le> ?n1 (i - 1)" by simp
   show "g_bnd B fs'" unfolding g_bnd_def
   proof (intro allI impI)
     fix k 
     assume km: "k < m" 
     consider (ki) "k = i" | (im1) "k = i - 1" | (other) "k \<noteq> i" "k \<noteq> i-1" by blast
     thus "?n2 k \<le> B"
     proof cases
       case other
       from short[OF km] have "?n1 k \<le> B" by auto
       also have "?n1 k = ?n2 k" using km other
         by (subst updates(2), auto)
       finally show ?thesis by simp
     next
       case im1
       have "?n2 k = ?n2 (i - 1)" unfolding im1 ..
       also have "\<dots> \<le> ?n1 (i - 1)" by fact
       also have "\<dots> \<le> B" using short_im1 by auto
       finally show ?thesis by simp
     next
       case ki
       have "?n2 k = ?n2 i" unfolding ki using i by auto
       also have "\<dots> \<le> ?n1 (i - 1)" 
       proof -
         let ?f1 = "\<lambda> i. RAT fs ! i"
         let ?f2 = "\<lambda> i. RAT fs' ! i" 
         define u where "u = gs.sumlist (map (\<lambda>j. ?mu1 (i - 1) j \<cdot>\<^sub>v ?g1 j) [0..<i - 1])" 
         define U where "U = ?f1 ` {0 ..< i - 1} \<union> {?f1 i}" 
         have g2i: "?g2 i \<in> Rn" using i inv' by simp
         have U: "U \<subseteq> Rn" unfolding U_def using inv i by auto
         have uU: "u \<in> gs.span U"
         proof -
           have im1: "i - 1 \<le> m" using i by auto
           have G1: "?g1 ` {0..< i - 1} \<subseteq> Rn" using inv(5) i by auto
           have "u \<in> gs.span (?g1 ` {0 ..< i - 1})" unfolding u_def 
             by (rule gs.sumlist_in_span[OF G1], unfold set_map, insert G1,
               auto intro!: gs.smult_in_span intro: gs.span_mem)
           also have "gs.span (?g1 ` {0 ..< i - 1}) = gs.span (?f1 ` {0 ..< i - 1})" 
             apply(subst gs1.partial_span, insert im1 inv, unfold gs.lin_indpt_list_def)
              apply(blast)
             apply(rule arg_cong[of _ _ gs.span])
             apply(subst nth_image[symmetric])
             by (insert i inv, auto)
           also have "\<dots> \<subseteq> gs.span U" unfolding U_def 
             by (rule gs.span_is_monotone, auto)
           finally show ?thesis .
         qed
         from i have im1: "i - 1 < m" by auto
         have u: "u \<in> Rn" using uU U by simp
         have id_u: "u + (?g1 (i - 1) - ?g2 i) = u + ?g1 (i - 1) - ?g2 i" 
           using u g2i inv(5)[OF im1] by auto
         have list_id: "[0..<Suc (i - 1)] = [0..< i - 1] @ [i - 1]" 
           "map f [x] = [f x]" for f x by auto
         have "gs.is_oc_projection (gs2.gso i) (gs.span (gs2.gso ` {0..<i})) ((RAT fs') ! i)"
           using i inv' unfolding gs.lin_indpt_list_def
           by (intro gs2.gso_oc_projection_span(2)) auto
         then have "gs.is_oc_projection (?g2 i) (gs.span (gs2.gso ` {0 ..< i}))  (?f1 (i - 1))" 
           unfolding fs'_def using inv(6) i by auto
         also have "?f1 (i - 1) = u + ?g1 (i - 1) " 
           apply(subst gs1.fi_is_sum_of_mu_gso, insert im1 inv, unfold gs.lin_indpt_list_def)
           apply(blast)
           unfolding list_id map_append u_def
           by (subst gs.M.sumlist_snoc, insert i, auto simp: gs1.\<mu>.simps intro!: inv(5))
         also have "gs.span (gs2.gso ` {0 ..< i}) = gs.span (set (take i (RAT fs')))" 
           using inv' \<open>i < m\<close> unfolding gs.lin_indpt_list_def
           by (subst gs2.partial_span) auto
         also have "set (take i (RAT fs')) = ?f2 ` {0 ..< i}" using inv'(6) i 
           by (subst nth_image[symmetric], auto)
         also have "{0 ..< i} = {0 ..< i - 1} \<union> {(i - 1)}" using i by auto
         also have "?f2 ` \<dots> = ?f2 ` {0 ..< i - 1} \<union> {?f2 (i - 1)}" by auto
         also have "\<dots> = U" unfolding U_def fs'_def 
           by (rule arg_cong2[of _ _ _ _ "(\<union>)"], insert i inv(6), force+)
         finally have "gs.is_oc_projection (?g2 i) (gs.span U) (u + ?g1 (i - 1))" .        
         hence proj: "gs.is_oc_projection (?g2 i) (gs.span U) (?g1 (i - 1))"
           unfolding gs.is_oc_projection_def using gs.span_add[OF U uU, of "?g1 (i - 1) - ?g2 i"] 
           inv(5)[OF im1] g2i u id_u by (auto simp: U)
         from gs.is_oc_projection_sq_norm[OF this gs.span_is_subset2[OF U]  inv(5)[OF im1]]
         show "?n2 i \<le> ?n1 (i - 1)" .
       qed
       also have "\<dots> \<le> B" by fact
       finally show ?thesis .
     qed
   qed
 qed
 
 
 lemma basis_reduction_swap_bound: assumes 
   binv: "LLL_bound_invariant True False i fs" 
   and res: "basis_reduction_swap i fs = (upw',i',fs')" 
   and cond: "sq_norm (gso fs (i - 1)) > \<alpha> * sq_norm (gso fs i)" 
   and i: "i < m" "i \<noteq> 0" 
 shows "LLL_bound_invariant True upw' i' fs'" 
 proof (rule bound_invI)
   note Linv = bound_invD(1)[OF binv]
   from basis_reduction_swap[OF Linv res cond i]
   show Linv': "LLL_invariant upw' i' fs'" by auto
   from res[unfolded basis_reduction_swap_def]
   have id: "i' = i - 1" "fs' = fs[i := fs ! (i - 1), i - 1 := fs ! i]" by auto
   from LLL_invD(6)[OF Linv] i
   have choice: "fs' ! k = fs ! k \<or> fs' ! k = fs ! i \<or> fs' ! k = fs ! (i - 1)" for k 
     unfolding id by (cases "k = i"; cases "k = i - 1", auto) 
   from bound_invD(2)[OF binv] i 
   show "f_bound True i' fs'" unfolding id(1) f_bound_def
   proof (intro allI impI, goal_cases)
     case (1 k)
     thus ?case using choice[of k] by auto
   qed
 
   from bound_invD(3)[OF binv, unfolded g_bound_def]
   have gbnd: "g_bnd (of_nat N) fs" unfolding g_bnd_def .
   from LLL_invD(11)[OF Linv, unfolded \<mu>_small_def] i 
   have "abs (\<mu> fs i (i - 1)) \<le> 1/2" by auto
   from g_bnd_swap[OF i LLL_inv_imp_w[OF Linv] this cond id(2) gbnd]
   have "g_bnd (rat_of_nat N) fs'" .
   thus "g_bound fs'" unfolding g_bnd_def g_bound_def .
 qed
 
 lemma basis_reduction_step_bound: assumes 
   binv: "LLL_bound_invariant True upw i fs" 
   and res: "basis_reduction_step upw i fs = (upw',i',fs')" 
   and i: "i < m" 
 shows "LLL_bound_invariant True upw' i' fs'" 
 proof -
   note def = basis_reduction_step_def
   obtain fs'' where fs'': "basis_reduction_add_rows upw i fs = fs''" by auto
   show ?thesis
   proof (cases "i = 0")
     case True
     from increase_i_bound[OF binv i True] res True
     show ?thesis by (auto simp: def)
   next
     case False
     hence id: "(i = 0) = False" by auto
     note res = res[unfolded def id if_False fs'' Let_def]
     let ?x = "sq_norm (gso fs'' (i - 1))" 
     let ?y = "\<alpha> * sq_norm (gso fs'' i)" 
     from basis_reduction_add_rows_bound[OF binv fs'' i]
     have binv: "LLL_bound_invariant True False i fs''" by auto
     show ?thesis
     proof (cases "?x \<le> ?y")
       case True
       from increase_i_bound[OF binv i _ True] True res
       show ?thesis by auto
     next
       case gt: False
       hence "?x > ?y" by auto
       from basis_reduction_swap_bound[OF binv _ this i False] gt res
       show ?thesis by auto
     qed
   qed
 qed
 
 lemma basis_reduction_main_bound: assumes "LLL_bound_invariant True upw i fs" 
   and res: "basis_reduction_main (upw,i,fs) = fs'" 
 shows "LLL_bound_invariant True True m fs'" 
   using assms
 proof (induct "LLL_measure i fs" arbitrary: i fs upw rule: less_induct)
   case (less i fs upw)
   have id: "LLL_bound_invariant True upw i fs = True" using less by auto
   note res = less(3)[unfolded basis_reduction_main.simps[of upw i fs] id]
   note inv = less(2)
   note IH = less(1)
   note Linv = bound_invD(1)[OF inv]
   show ?case
   proof (cases "i < m")
     case i: True
     obtain i' fs' upw' where step: "basis_reduction_step upw i fs = (upw',i',fs')" 
       (is "?step = _") by (cases ?step, auto)
     note decrease = basis_reduction_step(2)[OF Linv step i]
     from IH[OF decrease basis_reduction_step_bound(1)[OF inv step i]] res[unfolded step] i Linv
     show ?thesis by auto
   next
     case False
     with LLL_invD[OF Linv] have i: "i = m" by auto
     with False res inv have "LLL_bound_invariant True upw m fs'" by auto
     thus ?thesis by (auto simp: LLL_invariant_def LLL_bound_invariant_def)
   qed
 qed
 
 lemma LLL_inv_initial_state_bound: "LLL_bound_invariant True True 0 fs_init" 
 proof (intro bound_invI[OF LLL_inv_initial_state _ g_bound_fs_init])
   {
     fix i
     assume i: "i < m" 
     let ?N = "map (nat o sq_norm) fs_init"
     let ?r = rat_of_int
     from i have mem: "nat (sq_norm (fs_init ! i)) \<in> set ?N" using fs_init len unfolding set_conv_nth by force
     from mem_set_imp_le_max_list[OF _ mem]
     have FN: "nat (sq_norm (fs_init ! i)) \<le> N" unfolding N_def by force
     hence "\<parallel>fs_init ! i\<parallel>\<^sup>2 \<le> int N" using i by auto
     also have "\<dots> \<le> int (N * m)" using i by fastforce
     finally have f_bnd:  "\<parallel>fs_init ! i\<parallel>\<^sup>2 \<le> int (N * m)" .
   }
   thus "f_bound True 0 fs_init" unfolding f_bound_def by auto
 qed
 
 lemma reduce_basis_bound: assumes res: "reduce_basis = fs" 
   shows "LLL_bound_invariant True True m fs" 
   using basis_reduction_main_bound[OF LLL_inv_initial_state_bound res[unfolded reduce_basis_def]] .
 
 
 subsubsection \<open>Bound extracted from @{term LLL_bound_invariant}.\<close>
 
 fun f_bnd :: "bool \<Rightarrow> nat" where
   "f_bnd False = 2 ^ (m - 1) * N ^ m * m" 
 | "f_bnd True = N * m" 
 
 lemma f_bnd_mono: "f_bnd outside \<le> f_bnd False" 
 proof (cases outside)
   case out: True
   show ?thesis
   proof (cases "N = 0 \<or> m = 0")
     case True
     thus ?thesis using out by auto
   next
     case False
     hence 0: "N > 0" "m > 0" by auto
     let ?num = "(2 ^ (m - 1) * N ^ m)" 
     have "(N * m) * 1 \<le> (N * m) * (2 ^ (m - 1) * N ^ (m - 1))" 
       by (rule mult_left_mono, insert 0, auto)
     also have "\<dots> = 2 ^ (m - 1) * N ^ (Suc (m - 1)) * m " by simp
     also have "Suc (m - 1) = m" using 0 by simp
     finally show ?thesis using out by auto
   qed
 qed auto 
 
 lemma aux_bnd_mono: "N * m \<le> (4 ^ (m - 1) * N ^ m * m * m)" 
 proof (cases "N = 0 \<or> m = 0")
   case False
   hence 0: "N > 0" "m > 0" by auto
   let ?num = "(4 ^ (m - 1) * N ^ m * m * m)" 
   have "(N * m) * 1 \<le> (N * m) * (4 ^ (m - 1) * N ^ (m - 1) * m)" 
     by (rule mult_left_mono, insert 0, auto)
   also have "\<dots> = 4 ^ (m - 1) * N ^ (Suc (m - 1)) * m * m" by simp
   also have "Suc (m - 1) = m" using 0 by simp
   finally show "N * m \<le> ?num" by simp
 qed auto
 
 context fixes outside upw k fs
   assumes binv: "LLL_bound_invariant outside upw k fs"
 begin
 
 lemma LLL_f_bnd: 
   assumes i: "i < m" and j: "j < n" 
 shows "\<bar>fs ! i $ j\<bar> \<le> f_bnd outside" 
 proof -
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs" 
     and fbnd: "f_bound outside k fs" 
     and gbnd: "g_bound fs" by auto
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd] i have N0: "N > 0" by auto
   note inv = LLL_invD[OF inv] 
   from inv i have fsi: "fs ! i \<in> carrier_vec n" by auto
   have one: "\<bar>fs ! i $ j\<bar>^1 \<le> \<bar>fs ! i $ j\<bar>^2" 
     by (cases "fs ! i $ j \<noteq> 0", intro pow_mono_exp, auto)
   let ?num = "(4 ^ (m - 1) * N ^ m * m * m)" 
   let ?sq_bnd = "if i \<noteq> k \<or> outside then int (N * m) else int ?num" 
   have "\<bar>fs ! i $ j\<bar>^2 \<le> \<parallel>fs ! i\<parallel>\<^sup>2" using fsi j by (metis vec_le_sq_norm)
   also have "\<dots> \<le> ?sq_bnd" 
     using fbnd[unfolded f_bound_def, rule_format, OF i] by auto
   finally have two: "(fs ! i $ j)^2 \<le> ?sq_bnd" by simp
   show ?thesis
   proof (cases outside)
     case True
     with one two show ?thesis by auto
   next
     case False
     let ?num2 = "(2 ^ (m - 1) * N ^ m * m)" 
     have four: "(4 :: nat) = 2^2" by auto
     have "(fs ! i $ j)^2 \<le> int (max (N * m) ?num)" 
       by (rule order.trans[OF two], auto simp: of_nat_mult[symmetric] simp del: of_nat_mult)
     also have "max (N * m) ?num = ?num" using aux_bnd_mono by presburger 
     also have "int ?num = int ?num * 1" by simp
     also have "\<dots> \<le> int ?num * N ^ m" 
       by (rule mult_left_mono, insert N0, auto)
     also have "\<dots> = int (?num * N ^ m)" by simp
     also have "?num * N ^ m = ?num2^2" unfolding power2_eq_square four power_mult_distrib
       by simp
     also have "int \<dots> = (int ?num2)^2" by simp
     finally have "(fs ! i $ j)\<^sup>2 \<le> (int (f_bnd outside))\<^sup>2" using False by simp
     thus ?thesis unfolding abs_le_square_iff[symmetric] by simp 
   qed
 qed
 
 lemma LLL_gso_bound:
   assumes i: "i < m" and j: "j < n" 
   and quot: "quotient_of (gso fs i $ j) = (num, denom)" 
 shows "\<bar>num\<bar>   \<le> N ^ m" 
   and "\<bar>denom\<bar> \<le> N ^ m"
 proof -
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs" 
     and gbnd: "g_bound fs" by auto
   note invw = LLL_inv_imp_w[OF inv]
   note * = LLL_invD[OF inv]
   interpret fs: fs_int' n m fs_init fs
     by standard (use invw in auto)
   note d_approx[OF invw gbnd i, unfolded d_def]  
   let ?r = "rat_of_int"
   have int: "(gs.Gramian_determinant (RAT fs) i \<cdot>\<^sub>v (gso fs i)) $ j \<in> \<int>"
   proof -
     have "of_int_hom.vec_hom (fs ! j) $ i \<in> \<int>" if "i < n" "j < m" for i j
       using that assms * by (intro vec_hom_Ints) (auto)
     then show ?thesis
       using * gs.gso_connect snd_gram_schmidt_int assms unfolding gs.lin_indpt_list_def
       by (intro fs.gs.d_gso_Ints) (auto)
   qed
   have gsi: "gso fs i \<in> Rn" using *(5)[OF i] .
   have gs_sq: "\<bar>(gso fs i $ j)\<bar>\<^sup>2 \<le> rat_of_nat N"
     by(rule order_trans, rule vec_le_sq_norm[of _ n])
       (use gsi assms gbnd * LLL.g_bound_def in auto)
   from i have "m * m \<noteq> 0"
     by auto
   then have N0: "N \<noteq> 0"
     using less_le_trans[OF LLL_D_pos[OF invw] D_approx[OF invw gbnd]] by auto
   have "\<bar>(gso fs i $ j)\<bar> \<le> max 1 \<bar>(gso fs i $ j)\<bar>"
     by simp
   also have "\<dots> \<le> (max 1 \<bar>gso fs i $ j\<bar>)\<^sup>2"
     by (rule self_le_power, auto) 
   also have "\<dots> \<le> of_nat N"
     using gs_sq N0 unfolding max_def by auto
   finally have gs_bound: "\<bar>(gso fs i $ j)\<bar> \<le> of_nat N" .
   have "gs.Gramian_determinant (RAT fs) i = rat_of_int (gs.Gramian_determinant fs i)"
     using  assms *(4-6) carrier_vecD nth_mem by (intro fs.of_int_Gramian_determinant) (simp, blast)
   with int have "(of_int (d fs i) \<cdot>\<^sub>v gso fs i) $ j \<in> \<int>"
     unfolding d_def by simp
   also have "(of_int (d fs i) \<cdot>\<^sub>v gso fs i) $ j = of_int (d fs i) * (gso fs i $ j)"
     using gsi i j by auto
   finally have l: "of_int (d fs i) * gso fs i $ j \<in> \<int>"
     by auto
   have num: "rat_of_int \<bar>num\<bar> \<le> of_int (d fs i * int N)" and denom: "denom \<le> d fs i"
     using quotient_of_bounds[OF quot l LLL_d_pos[OF invw] gs_bound] i by auto
   from num have num: "\<bar>num\<bar> \<le> d fs i * int N"
     by linarith
   from d_approx[OF invw gbnd i] have d: "d fs i \<le> int (N ^ i)"
     by linarith
   from denom d have denom: "denom \<le> int (N ^ i)"
     by auto
   note num also have "d fs i * int N \<le> int (N ^ i) * int N" 
     by (rule mult_right_mono[OF d], auto)
   also have "\<dots> = int (N ^ (Suc i))"
     by simp
   finally have num: "\<bar>num\<bar> \<le> int (N ^ (i + 1))"
     by auto
   {
     fix jj
     assume "jj \<le> i + 1" 
     with i have "jj \<le> m" by auto
     from pow_mono_exp[OF _ this, of N] N0
     have "N^jj \<le> N^m" by auto
     hence "int (N^jj) \<le> int (N^m)" by linarith
   } note j_m = this
   have "\<bar>denom\<bar> = denom"
     using quotient_of_denom_pos[OF quot] by auto
   also have "\<dots> \<le> int (N ^ i)"
     by fact 
   also have "\<dots> \<le> int (N ^ m)"
     by (rule j_m, auto)
   finally show "\<bar>denom\<bar> \<le> int (N ^ m)"
     by auto
   show "\<bar>num\<bar> \<le> int (N ^ m)"
     using j_m[of "i+1"] num by auto
 qed
 
 lemma LLL_f_bound:
   assumes i: "i < m" and j: "j < n" 
 shows "\<bar>fs ! i $ j\<bar> \<le> N ^ m * 2 ^ (m - 1) * m" 
 proof -
   have "\<bar>fs ! i $ j\<bar> \<le> int (f_bnd outside)" using LLL_f_bnd[OF i j] by auto
   also have "\<dots> \<le> int (f_bnd False)" using f_bnd_mono[of outside] by presburger
   also have "\<dots> = int (N ^ m * 2 ^ (m - 1) * m)" by simp
   finally show ?thesis .
 qed
 
 lemma LLL_d_bound: 
   assumes i: "i \<le> m"   
 shows "abs (d fs i) \<le> N ^ i \<and> abs (d fs i) \<le> N ^ m" 
 proof (cases "m = 0")
   case True
   with i have id: "m = 0" "i = 0" by auto
   show ?thesis unfolding id(2) using id unfolding gs.Gramian_determinant_0 d_def by auto
 next
   case m: False  
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and gbnd: "g_bound fs" by auto
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd] m have N: "N > 0" by auto 
   let ?r = rat_of_int 
   from d_approx_main[OF invw gbnd i m] 
   have "rat_of_int (d fs i) \<le> of_nat (N ^ i)" 
     by auto
   hence one: "d fs i \<le> N ^ i" by linarith
   also have "\<dots> \<le> N ^ m" unfolding of_nat_le_iff
     by (rule pow_mono_exp, insert N i, auto)
   finally have "d fs i \<le> N ^ m" by simp
   with LLL_d_pos[OF invw i] one
   show ?thesis by auto
 qed
 
 lemma LLL_mu_abs_bound: 
   assumes i: "i < m"
   and j: "j < i" 
 shows "\<bar>\<mu> fs i j\<bar> \<le> rat_of_nat (N ^ (m - 1) * 2 ^ (m - 1) * m)" 
 proof -
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and fbnd: "f_bound outside k fs"
      and gbnd: "g_bound fs" by auto
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto 
   note * = LLL_invD[OF inv]
   interpret fs: fs_int' n m fs_init fs
     by standard (use invw in auto)
   let ?mu = "\<mu> fs i j" 
   from j i have jm: "j < m" by auto
   from d_approx[OF invw gbnd jm]
   have dj: "d fs j \<le> int (N ^ j)" by linarith
   let ?num = "4 ^ (m - 1) * N ^ m * m * m" 
   let ?bnd = "N^(m - 1) * 2 ^ (m - 1) * m" 
   from fbnd[unfolded f_bound_def, rule_format, OF i]
     aux_bnd_mono[folded of_nat_le_iff[where ?'a = int]]
   have sq_f_bnd: "sq_norm (fs ! i) \<le> int ?num" by (auto split: if_splits)
   have four: "(4 :: nat) = 2^2" by auto
   have "?mu^2 \<le> (gs.Gramian_determinant (RAT fs) j) * sq_norm (RAT fs ! i)"
   proof -
     have 1: "of_int_hom.vec_hom (fs ! j) $ i \<in> \<int>" if "i < n" "j < length fs" for j i
       using * that by (metis vec_hom_Ints)
     then show ?thesis
       by (intro fs.gs.mu_bound_Gramian_determinant[OF j], insert * j i, 
           auto simp: set_conv_nth gs.lin_indpt_list_def)
   qed
   also have "sq_norm (RAT fs ! i) = of_int (sq_norm (fs ! i))" 
     unfolding sq_norm_of_int[symmetric] using *(6) i by auto
   also have "(gs.Gramian_determinant (RAT fs) j) = of_int (d fs j)" 
     unfolding d_def by (rule fs.of_int_Gramian_determinant, insert i j *(3,6), auto simp: set_conv_nth)
   also have "\<dots> * of_int (sq_norm (fs ! i)) = of_int (d fs j * sq_norm (fs ! i))" by simp 
   also have "\<dots> \<le> of_int (int (N^j) * int ?num)" unfolding of_int_le_iff 
     by (rule mult_mono[OF dj sq_f_bnd], auto)
   also have "\<dots> = of_nat (N^(j + m) * (4 ^ (m - 1) * m * m))" by (simp add: power_add)
   also have "\<dots> \<le> of_nat (N^( (m - 1) + (m-1)) * (4 ^ (m - 1) * m * m))" unfolding of_nat_le_iff
     by (rule mult_right_mono[OF pow_mono_exp], insert N j i jm, auto)
   also have "\<dots> = of_nat (?bnd^2)" 
     unfolding four power_mult_distrib power2_eq_square of_nat_mult by (simp add: power_add)
   finally have "?mu^2 \<le> (of_nat ?bnd)^2" by auto
   from this[folded abs_le_square_iff] 
   show "abs ?mu \<le> of_nat ?bnd" by auto
 qed
 
 
 
 lemma LLL_d\<mu>_bound: 
   assumes i: "i < m" and j: "j < i"  
 shows "abs (d\<mu> fs i j) \<le> N ^ (2 * (m - 1)) * 2 ^ (m - 1) * m" 
 proof -
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and fbnd: "f_bound outside k fs"
      and gbnd: "g_bound fs" by auto
   note invw = LLL_inv_imp_w[OF inv]
   interpret fs: fs_int' n m fs_init fs
     by standard (use invw in auto)
   from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto 
   from j i have jm: "j < m - 1" "j < m" by auto
   let ?r = rat_of_int 
   from LLL_d_bound[of "Suc j"] jm
   have "abs (d fs (Suc j)) \<le> N ^ Suc j" by linarith
   also have "\<dots> \<le> N ^ (m - 1)" unfolding of_nat_le_iff
     by (rule pow_mono_exp, insert N jm, auto)
   finally have dsj: "abs (d fs (Suc j)) \<le> int N ^ (m - 1)" by auto
   from fs.d\<mu>[of j i] j i LLL_invD[OF inv]
   have "?r (abs (d\<mu> fs i j)) = abs (?r (d fs (Suc j)) * \<mu> fs i j)"
     unfolding d_def fs.d_def d\<mu>_def fs.d\<mu>_def by auto
   also have "\<dots> = ?r (abs (d fs (Suc j))) * abs (\<mu> fs i j)" by (simp add: abs_mult)
   also have "\<dots> \<le> ?r (int N ^ (m - 1)) * rat_of_nat (N ^ (m - 1) * 2 ^ (m - 1) * m)" 
     by (rule mult_mono[OF _ LLL_mu_abs_bound[OF i j]], insert dsj, linarith, auto)
   also have "\<dots> = ?r (int (N ^ ((m - 1) + (m - 1)) * 2 ^ (m - 1) * m))" 
     by (simp add: power_add)
   also have "(m - 1) + (m - 1) = 2 * (m - 1)" by simp
   finally show "abs (d\<mu> fs i j) \<le> N ^ (2 * (m - 1)) * 2 ^ (m - 1) * m" by linarith
 qed
 
 lemma LLL_mu_num_denom_bound: 
   assumes i: "i < m"                 
   and quot: "quotient_of (\<mu> fs i j) = (num, denom)" 
 shows "\<bar>num\<bar>   \<le> N ^ (2 * m) * 2 ^ m * m" 
   and "\<bar>denom\<bar> \<le> N ^ m" 
 proof (atomize(full))
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and fbnd: "f_bound outside k fs"
      and gbnd: "g_bound fs" by auto
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto 
   note * = LLL_invD[OF inv]
   interpret fs: fs_int' n m fs_init fs
     by standard (use invw in auto)
   let ?mu = "\<mu> fs i j" 
   let ?bnd = "N^(m - 1) * 2 ^ (m - 1) * m" 
   show "\<bar>num\<bar> \<le> N ^ (2 * m) * 2 ^ m * m \<and> \<bar>denom\<bar> \<le> N ^ m" 
   proof (cases "j < i")
     case j: True
     with i have jm: "j < m" by auto
     from LLL_d_pos[OF invw, of "Suc j"] i j have dsj: "0 < d fs (Suc j)" by auto
     from quotient_of_square[OF quot] 
     have quot_sq: "quotient_of (?mu^2) = (num * num, denom * denom)" 
       unfolding power2_eq_square by auto
     from LLL_mu_abs_bound[OF assms(1) j]
     have mu_bound: "abs ?mu \<le> of_nat ?bnd" by auto
     have "gs.Gramian_determinant (RAT fs) (Suc j) * ?mu \<in> \<int>" 
       by (rule fs.gs.d_mu_Ints,
       insert j *(1,3-6) i, auto simp: set_conv_nth gs.lin_indpt_list_def vec_hom_Ints)
     also have "(gs.Gramian_determinant (RAT fs) (Suc j)) = of_int (d fs (Suc j))" 
       unfolding d_def by (rule fs.of_int_Gramian_determinant, insert i j *(3,6), auto simp: set_conv_nth)
     finally have ints: "of_int (d fs (Suc j)) * ?mu \<in> \<int>" .
     from LLL_d_bound[of "Suc j"] jm
     have d_j: "d fs (Suc j) \<le> N ^ m" by auto
     note quot_bounds = quotient_of_bounds[OF quot ints dsj mu_bound]
     have "abs denom \<le> denom" using quotient_of_denom_pos[OF quot] by auto
     also have "\<dots> \<le> d fs (Suc j)" by fact
     also have "\<dots> \<le> N ^ m" by fact
     finally have denom: "abs denom \<le> N ^ m" by auto
     from quot_bounds(1) have "\<bar>num\<bar> \<le> d fs (Suc j) * int ?bnd" 
       unfolding of_int_le_iff[symmetric, where ?'a = rat] by simp
     also have "\<dots> \<le> N ^ m * int ?bnd" by (rule mult_right_mono[OF d_j], auto)
     also have "\<dots> = (int N ^ (m + (m - 1))) * (2 ^ (m - 1)) * int m" unfolding power_add of_nat_mult by simp
     also have "\<dots> \<le> (int N ^ (2 * m)) * (2 ^ m) * int m" unfolding of_nat_mult
       by (intro mult_mono pow_mono_exp, insert N, auto)
     also have "\<dots> = int (N ^ (2 * m) * 2 ^ m * m)" by simp
     finally have num: "\<bar>num\<bar> \<le> N ^ (2 * m) * 2 ^ m * m" .
     from denom num show ?thesis by blast
   next
     case False
     hence "?mu = 0 \<or> ?mu = 1" unfolding fs.gs.\<mu>.simps by auto
     hence "quotient_of ?mu = (1,1) \<or> quotient_of ?mu = (0,1)" by auto
     from this[unfolded quot] show ?thesis using N i by (auto intro!: mult_ge_one)
   qed
 qed
 
 text \<open>Now we have bounds on each number $(f_i)_j$, $(g_i)_j$, and $\mu_{i,j}$, i.e.,
   for rational numbers bounds on the numerators and denominators.\<close>
 
 lemma logN_le_2log_Mn: assumes m: "m \<noteq> 0" "n \<noteq> 0" and N: "N > 0" 
   shows "log 2 N \<le> 2 * log 2 (M * n)" 
 proof -
   have "N \<le> nat M * nat M * n * 1" using N_le_MMn m by auto
   also have "\<dots> \<le> nat M * nat M * n * n" by (intro mult_mono, insert m, auto)
   finally have NM: "N \<le> nat M * nat M * n * n" by simp
   with N have "nat M \<noteq> 0" by auto
   hence M: "M > 0" by simp
 
   have "log 2 N \<le> log 2 (M * M * n * n)" 
   proof (subst log_le_cancel_iff)      
     show "real N \<le> (M * M * int n * int n)" using NM[folded of_nat_le_iff[where ?'a = real]] M
       by simp
   qed (insert N M m, auto)
   also have "\<dots> = log 2 (of_int (M * n) * of_int (M * n))" 
     unfolding of_int_mult by (simp  add: ac_simps)
   also have "\<dots> = 2 * log 2 (M * n)" 
     by (subst log_mult, insert m M, auto)
   finally show "log 2 N \<le> 2 * log 2 (M * n)" by auto
 qed
 
 
 text \<open>We now prove a combined size-bound for all of these numbers. The bounds clearly indicate
   that the size of the numbers grows at most polynomial, namely the sizes are roughly 
   bounded by ${\cal O}(m \cdot \log(M \cdot n))$ where $m$ is the number of vectors, $n$ is the dimension
   of the vectors, and $M$ is the maximum absolute value that occurs in the input to the LLL algorithm.\<close>
 
 lemma combined_size_bound: fixes number :: int 
   assumes i: "i < m" and j: "j < n"
   and x: "x \<in> {of_int (fs ! i $ j), gso fs i $ j, \<mu> fs i j}" 
   and quot: "quotient_of x = (num, denom)" 
   and number: "number \<in> {num, denom}" 
   and number0: "number \<noteq> 0" 
 shows "log 2 \<bar>number\<bar> \<le> 2 * m * log 2 N       + m + log 2 m" 
       "log 2 \<bar>number\<bar> \<le> 4 * m * log 2 (M * n) + m + log 2 m"
 proof -
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and fbnd: "f_bound outside k fs" 
      and gbnd: "g_bound fs" 
     by auto
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd] i have N: "N > 0" by auto
   let ?bnd = "N ^ (2 * m) * 2 ^ m * m" 
   have "N ^ m * int 1 \<le> N ^ (2 * m) * (2^m * int m)" 
     by (rule mult_mono, unfold of_nat_le_iff, rule pow_mono_exp, insert N i, auto)
   hence le: "int (N ^ m) \<le> N ^ (2 * m) * 2^m * m" by auto
   from x consider (xfs) "x = of_int (fs ! i $ j)" | (xgs) "x = gso fs i $ j" | (xmu) "x = \<mu> fs i j" 
     by auto
   hence num_denom_bound: "\<bar>num\<bar> \<le> ?bnd \<and> \<bar>denom\<bar> \<le> N ^ m" 
   proof (cases)
     case xgs
     from LLL_gso_bound[OF i j quot[unfolded xgs]] le
     show ?thesis by auto
   next
     case xmu
     from LLL_mu_num_denom_bound[OF i, of j, OF quot[unfolded xmu]]
     show ?thesis by auto
   next
     case xfs
     have "\<bar>denom\<bar> = 1" using quot[unfolded xfs] by auto
     also have "\<dots> \<le> N ^ m" using N by auto
     finally have denom: "\<bar>denom\<bar> \<le> N ^ m" .
     have "\<bar>num\<bar> = \<bar>fs ! i $ j\<bar>" using quot[unfolded xfs] by auto
     also have "\<dots> \<le> int (N ^ m * 2 ^ (m - 1) * m)" using LLL_f_bound[OF i j] by auto
     also have "\<dots> \<le> ?bnd" unfolding of_nat_mult of_nat_power
-      by (intro mult_mono pow_mono_exp, insert N, auto)
+      using N by (auto intro!: mult_mono pow_mono_exp)
     finally show ?thesis using denom by auto
   qed
   from number consider (num) "number = num" | (denom) "number = denom" by auto
   hence number_bound: "\<bar>number\<bar> \<le> ?bnd" 
   proof (cases)
     case num
     with num_denom_bound show ?thesis by auto
   next
     case denom
     with num_denom_bound have "\<bar>number\<bar> \<le> N ^ m" by auto
     with le show ?thesis by auto
   qed
   from number_bound have bnd: "of_int \<bar>number\<bar> \<le> real ?bnd" by linarith
   have "log 2 \<bar>number\<bar> \<le> log 2 ?bnd" 
     by (subst log_le_cancel_iff, insert number0 bnd, auto)
   also have "\<dots> = log 2 (N^(2 * m) * 2^m) + log 2 m" 
     by (subst log_mult[symmetric], insert i N, auto)
   also have "\<dots> = log 2 (N^(2 * m)) + log 2 (2^m) + log 2 m" 
     by (subst log_mult[symmetric], insert i N, auto)
   also have "log 2 (N^(2 * m)) = log 2 (N powr (2 * m))" 
     by (rule arg_cong[of _ _ "log 2"], subst powr_realpow, insert N, auto) 
   also have "\<dots> = (2 * m) * log 2 N" 
     by (subst log_powr, insert N, auto)
   finally show boundN: "log 2 \<bar>number\<bar> \<le> 2 * m * log 2 N + m + log 2 m" by simp
   also have "\<dots> \<le> 2 * m * (2 * log 2 (M * n)) + m + log 2 m" 
     by (intro add_right_mono mult_mono logN_le_2log_Mn N, insert i j N, auto)
   finally show "log 2 \<bar>number\<bar> \<le> 4 * m * log 2 (M * n) + m + log 2 m" by simp
 qed
 
 text \<open>And a combined size bound for an integer implementation which stores values 
   $f_i$, $d_{j+1}\mu_{ij}$ and $d_i$.\<close>
 
 interpretation fs: fs_int_indpt n fs_init
   by (standard) (use lin_dep in auto)
 
 lemma fs_gs_N_N': assumes "m \<noteq> 0"
   shows "fs.gs.N = of_nat N"
 proof -
   have 0: "Max (sq_norm ` set fs_init)  \<in>  sq_norm ` set fs_init"
     using len assms by auto
   then have 1: " nat (Max (sq_norm ` set fs_init)) \<in> (nat \<circ> sq_norm) ` set fs_init"
     by (auto)
   have [simp]: "0 \<le> Max (sq_norm ` set fs_init)"
     using 0 by force
   have [simp]: "sq_norm ` of_int_hom.vec_hom ` set fs_init = rat_of_int ` sq_norm ` set fs_init"
     by (auto simp add: sq_norm_of_int image_iff)
   then have [simp]: "rat_of_int (Max (sq_norm ` set fs_init)) \<in> rat_of_int ` sq_norm ` set fs_init"
     using 0 by auto
   have "(Missing_Lemmas.max_list (map (nat \<circ> sq_norm) fs_init)) = Max ((nat \<circ> sq_norm) ` set fs_init)"
     using assms len by (subst max_list_Max) (auto)
   also have "\<dots> = nat (Max (sq_norm_vec ` set fs_init))"
     using assms 1 by (auto intro!: nat_mono Max_eqI)
   also have "int \<dots> = Max (sq_norm_vec ` set fs_init)"
     by (subst int_nat_eq) (auto)
   also have "rat_of_int \<dots> = Max (sq_norm ` set (map of_int_hom.vec_hom fs_init))"
     by (rule Max_eqI[symmetric]) (auto simp add: sq_norm_of_int)
   finally show ?thesis
   unfolding N_def fs.gs.N_def by (auto)
 qed
 
 lemma fs_gs_N_N: "m \<noteq> 0 \<Longrightarrow> real_of_rat fs.gs.N = real N"
   using fs_gs_N_N' by simp
 
 lemma combined_size_bound_gso_integer:
   assumes "x \<in> 
     {fs.\<mu>' i j |i j. j \<le> i \<and> i < m} \<union> 
     {fs.\<sigma>s l i j |i j l. i < m \<and> j \<le> i \<and> l < j}"
   and m: "m \<noteq> 0" and "x \<noteq> 0" "n \<noteq> 0"
 shows "log 2 \<bar>real_of_int x\<bar> \<le> (6 + 6 * m) * log 2 (M * n) + log 2 m + m"
 proof -
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and gbnd: "g_bound fs" 
     by auto 
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd m] have N: "N > 0" by auto
   have "log 2 \<bar>real_of_int x\<bar> \<le> log 2 m + real (3 + 3 * m) * log 2 N"
     using assms len fs.combined_size_bound_integer_log by (auto simp add: fs_gs_N_N)
   also have "\<dots> \<le> log 2 m + (3 + 3 * m) * (2 * log 2 (M * n))"
     using logN_le_2log_Mn assms N by (intro add_left_mono, intro mult_left_mono) (auto)
   also have "\<dots> = log 2 m + (6 + 6 * m) * log 2 (M * n)"
     by (auto simp add: algebra_simps)
   finally show ?thesis
     by auto
 qed
 
 lemma combined_size_bound_integer':  
   assumes x: "x \<in> {fs ! i $ j | i j. i < m \<and> j < n} 
     \<union> {d\<mu> fs i j | i j. j < i \<and> i < m} 
     \<union> {d fs i | i. i \<le> m}" 
     (is "x \<in> ?fs \<union> ?d\<mu> \<union> ?d")
   and m: "m \<noteq> 0" and n: "n \<noteq> 0" 
 shows "abs x \<le> N ^ (2 * m) * 2 ^ m * m"
   "x \<noteq> 0 \<Longrightarrow> log 2 \<bar>x\<bar> \<le> 2 * m * log 2 N       + m + log 2 m" (is "_ \<Longrightarrow> ?l1 \<le> ?b1")
   "x \<noteq> 0 \<Longrightarrow> log 2 \<bar>x\<bar> \<le> 4 * m * log 2 (M * n) + m + log 2 m" (is "_ \<Longrightarrow> _ \<le> ?b2")
 proof -
   let ?bnd = "int N ^ (2 * m) * 2 ^ m * int m" 
   from bound_invD[OF binv]
   have inv: "LLL_invariant upw k fs"
      and fbnd: "f_bound outside k fs" 
      and gbnd: "g_bound fs" 
     by auto 
   note invw = LLL_inv_imp_w[OF inv]
   from LLL_inv_N_pos[OF invw gbnd m] have N: "N > 0" by auto
   let ?r = real_of_int
   from x consider (fs) "x \<in> ?fs" | (d\<mu>) "x \<in> ?d\<mu>" | (d) "x \<in> ?d" by auto
   hence "abs x \<le> ?bnd" 
   proof cases
     case fs
     then obtain i j where i: "i < m" and j: "j < n" and x: "x = fs ! i $ j" by auto
     from LLL_f_bound[OF i j, folded x]
     have "\<bar>x\<bar> \<le> int N ^ m * 2 ^ (m - 1) * int m" by simp
     also have "\<dots> \<le> ?bnd" 
       by (intro mult_mono pow_mono_exp, insert N, auto)
     finally show ?thesis .
   next
     case d\<mu>
     then obtain i j where i: "i < m" and j: "j < i" and x: "x = d\<mu> fs i j" by auto
     from LLL_d\<mu>_bound[OF i j, folded x]
     have "\<bar>x\<bar> \<le> int N ^ (2 * (m - 1)) * 2 ^ (m - 1) * int m" by simp
     also have "\<dots> \<le> ?bnd" 
       by (intro mult_mono pow_mono_exp, insert N, auto)
     finally show ?thesis .
   next
     case d
     then obtain i where i: "i \<le> m" and x: "x = d fs i" by auto
     from LLL_d_bound[OF i, folded x]
     have "\<bar>x\<bar> \<le> int N ^ m * 2 ^ 0 * 1" by simp
     also have "\<dots> \<le> ?bnd" 
       by (intro mult_mono pow_mono_exp, insert N m, auto)
     finally show ?thesis .
   qed
   thus "abs x \<le> N ^ (2 * m) * 2 ^ m * m" by simp
   hence abs: "?r (abs x) \<le> ?r (N ^ (2 * m) * 2 ^ m * m)" by linarith
   assume "x \<noteq> 0" hence x: "abs x > 0" by auto
   from abs have "log 2 (abs x) \<le> log 2 (?r (N ^ (2 * m)) * 2 ^ m * ?r m)" 
     by (subst log_le_cancel_iff, insert x N m, auto)
   also have "\<dots> = log 2 (?r N ^ (2 * m)) + m + log 2 (?r m)" 
     using N m by (auto simp: log_mult)
   also have "log 2 (?r N ^ (2 * m)) = real (2 * m) * log 2 (?r N)" 
     by (subst log_nat_power, insert N, auto)
   finally show "?l1 \<le> ?b1" by simp
   also have "\<dots> \<le> 2 * m * (2 * log 2 (M * n)) + m + log 2 m" 
     by (intro add_right_mono mult_left_mono logN_le_2log_Mn, insert m n N, auto)
   finally show "?l1 \<le> ?b2" by simp  
 qed
 
 lemma combined_size_bound_integer:  
   assumes x: "x \<in> 
       {fs ! i $ j | i j. i < m \<and> j < n} 
     \<union> {d\<mu> fs i j | i j. j < i \<and> i < m} 
     \<union> {d fs i | i. i \<le> m}
     \<union> {fs.\<mu>' i j |i j. j \<le> i \<and> i < m}
     \<union> {fs.\<sigma>s l i j |i j l. i < m \<and> j \<le> i \<and> l < j}"
     (is "?x \<in> ?s1 \<union> ?s2 \<union> ?s3 \<union> ?g1 \<union> ?g2")
   and m: "m \<noteq> 0" and n: "n \<noteq> 0" and "x \<noteq> 0" and "0 < M"
 shows "log 2 \<bar>x\<bar> \<le> (6 + 6 * m) * log 2 (M * n) + log 2 m + m"
 proof -
   show ?thesis
   proof (cases "?x \<in> ?g1 \<union> ?g2")
     case True
     then show ?thesis
       using combined_size_bound_gso_integer assms by simp
   next
     case False
     then have x: "x \<in> ?s1 \<union> ?s2 \<union> ?s3" using x by auto
     from combined_size_bound_integer'(3)[OF this m n \<open>x \<noteq> 0\<close>]
     have "log 2 \<bar>x\<bar> \<le> 4 * m * log 2 (M * n) + m + log 2 m" by simp
     also have "\<dots> \<le> (6 + 6 * m) * log 2 (M * n) + m + log 2 m"
        using assms by (intro add_right_mono, intro mult_right_mono) auto
     finally show ?thesis
       by simp
   qed
 qed
 
 end (* LLL_bound_invariant *)  
 end (* LLL locale *)
 end
diff --git a/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy b/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy
--- a/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy
+++ b/thys/LOFT/LinuxRouter_OpenFlow_Translation.thy
@@ -1,1052 +1,1056 @@
 theory LinuxRouter_OpenFlow_Translation
 imports IP_Addresses.CIDR_Split
   Automatic_Refinement.Misc (*TODO@Peter: rename and make available at better place :)*)
 	Simple_Firewall.Generic_SimpleFw 
 	Semantics_OpenFlow
 	OpenFlow_Matches
 	OpenFlow_Action
 	Routing.Linux_Router
 begin
 hide_const Misc.uncurry
 hide_fact Misc.uncurry_def
   
 (* For reference:
 iiface :: "iface" --"in-interface"
 oiface :: "iface" --"out-interface"
 src :: "(ipv4addr \<times> nat) " --"source IP address"
 dst :: "(ipv4addr \<times> nat) " --"destination"
 proto :: "protocol"
 sports :: "(16 word \<times> 16 word)" --"source-port first:last"
 dports :: "(16 word \<times> 16 word)" --"destination-port first:last"
 
 p_iiface :: string
 p_oiface :: string
 p_src :: ipv4addr
 p_dst :: ipv4addr
 p_proto :: primitive_protocol
 p_sport :: "16 word"
 p_dport :: "16 word"
 p_tcp_flags :: "tcp_flag set"
 p_payload :: string
 *)
 
 definition "route2match r =
 	\<lparr>iiface = ifaceAny, oiface = ifaceAny, 
 	src = (0,0), dst=(pfxm_prefix (routing_match r),pfxm_length (routing_match r)), 
 	proto=ProtoAny, sports=(0,max_word), ports=(0,max_word)\<rparr>"
 
 definition toprefixmatch where
 "toprefixmatch m \<equiv> (let pm = PrefixMatch (fst m) (snd m) in if pm = PrefixMatch 0 0 then None else Some pm)"
 lemma prefix_match_semantics_simple_match: 
   assumes some: "toprefixmatch m = Some pm"
 	assumes vld: "valid_prefix pm"
 	shows "prefix_match_semantics pm = simple_match_ip m"
 using some
   by(cases m)
 	  (clarsimp 
 	   simp add: toprefixmatch_def ipset_from_cidr_def pfxm_mask_def fun_eq_iff
 	            prefix_match_semantics_ipset_from_netmask[OF vld] NOT_mask_shifted_lenword[symmetric]
 	   split: if_splits)
 
 definition simple_match_to_of_match_single ::
     "(32, 'a) simple_match_scheme
      \<Rightarrow> char list option \<Rightarrow> protocol \<Rightarrow> (16 word \<times> 16 word) option \<Rightarrow> (16 word \<times> 16 word) option \<Rightarrow> of_match_field set" 
     where
 "simple_match_to_of_match_single m iif prot sport dport \<equiv>
 	   uncurry L4Src ` option2set sport \<union> uncurry L4Dst ` option2set dport
 	 \<union> IPv4Proto ` (case prot of ProtoAny \<Rightarrow> {} | Proto p \<Rightarrow> {p}) \<comment> \<open>protocol is an 8 word option anyway...\<close>
 	 \<union> IngressPort ` option2set iif
 	 \<union> IPv4Src ` option2set (toprefixmatch (src m)) \<union> IPv4Dst ` option2set (toprefixmatch (dst m))
 	 \<union> {EtherType 0x0800}"
 (* okay, we need to make sure that no packets are output on the interface they were input on. So for rules that don't have an input interface, we'd need to do a product over all interfaces, if we stay naive.
    The more smart way would be to insert a rule with the same match condition that additionally matches the input interface and drops. However, I'm afraid this is going to be very tricky to verify\<dots> *)
 definition simple_match_to_of_match :: "32 simple_match \<Rightarrow> string list \<Rightarrow> of_match_field set list" where
 "simple_match_to_of_match m ifs \<equiv> (let
 	npm = (\<lambda>p. fst p = 0 \<and> snd p = max_word);
 	sb = (\<lambda>p. (if npm p then [None] else if fst p \<le> snd p
   then map (Some \<circ> (\<lambda>pfx. (pfxm_prefix pfx, NOT (pfxm_mask pfx)))) (wordinterval_CIDR_split_prefixmatch (WordInterval (fst p) (snd p))) else []))
 	in [simple_match_to_of_match_single m iif (proto m) sport dport.
 		iif \<leftarrow> (if iiface m = ifaceAny then [None] else [Some i. i \<leftarrow> ifs, match_iface (iiface m) i]),
 		sport \<leftarrow> sb (sports m),
 		dport \<leftarrow> sb (dports m)]
 )"
 (* I wonder\<dots> should I check whether list_all (match_iface (iiface m)) ifs instead of iiface m = ifaceAny? It would be pretty stupid if that wasn't the same, but you know\<dots> *)
 
 lemma smtoms_eq_hlp: "simple_match_to_of_match_single r a b c d = simple_match_to_of_match_single r f g h i \<longleftrightarrow> (a = f \<and> b = g \<and> c = h \<and> d = i)"
 (* In case this proof breaks: there are two alternate proofs in the repo. They are of similar quality, though. Good luck. *)
 proof(rule iffI,goal_cases)
   case 1
   thus ?case proof(intro conjI)
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (IngressPort x)" by simp
     show "a = f" using 1 by(cases a; cases f)
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   next
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Proto x\<rbrakk> \<Longrightarrow> P (IPv4Proto x)" by simp
     show "b = g" using 1 by(cases b; cases g) 
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   next
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (uncurry L4Src x)" by simp
     show "c = h" using 1 by(cases c; cases h)
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   next
     have *: "\<And>P z x. \<lbrakk>\<forall>x :: of_match_field. P x; z = Some x\<rbrakk> \<Longrightarrow> P (uncurry L4Dst x)" by simp
     show "d = i" using 1 by(cases d; cases i)
         (simp add: option2set_None simple_match_to_of_match_single_def toprefixmatch_def option2set_def;
         subst(asm) set_eq_iff; drule (1) *; simp split: option.splits uncurry_splits protocol.splits)+
   qed
 qed simp
 
 lemma simple_match_to_of_match_generates_prereqs: "simple_match_valid m \<Longrightarrow> r \<in> set (simple_match_to_of_match m ifs) \<Longrightarrow> all_prerequisites r"
 unfolding simple_match_to_of_match_def Let_def
 proof(clarsimp, goal_cases)
   case (1 xiface xsrcp xdstp)
   note o = this
   show ?case unfolding simple_match_to_of_match_single_def all_prerequisites_def
     unfolding ball_Un
   proof((intro conjI; ((simp;fail)| - )), goal_cases)
     case 1
     have e: "(fst (sports m) = 0 \<and> snd (sports m) = max_word) \<or> proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP"
       using o(1)
       unfolding simple_match_valid_alt Let_def
       by(clarsimp split: if_splits)
     show ?case
       using o(3) e
       by(elim disjE; simp add: option2set_def split: if_splits prod.splits uncurry_splits)
   next
     case 2
     have e: "(fst (dports m) = 0 \<and> snd (dports m) = max_word) \<or> proto m = Proto TCP \<or> proto m = Proto UDP \<or> proto m = Proto L4_Protocol.SCTP"
       using o(1)
       unfolding simple_match_valid_alt Let_def
       by(clarsimp split: if_splits)
     show ?case
       using o(4) e
       by(elim disjE; simp add: option2set_def split: if_splits prod.splits uncurry_splits)
   qed
 qed
 
 lemma and_assoc: "a \<and> b \<and> c \<longleftrightarrow> (a \<and> b) \<and> c" by simp
 
 lemmas custom_simpset = Let_def set_concat set_map map_map comp_def concat_map_maps set_maps UN_iff fun_app_def Set.image_iff
 
 abbreviation "simple_fw_prefix_to_wordinterval \<equiv> prefix_to_wordinterval \<circ> uncurry PrefixMatch"
 
 lemma simple_match_port_alt: "simple_match_port m p \<longleftrightarrow> p \<in> wordinterval_to_set (uncurry WordInterval m)" by(simp split: uncurry_splits)
 
 lemma simple_match_src_alt: "simple_match_valid r \<Longrightarrow> 
 	simple_match_ip (src r) p \<longleftrightarrow> prefix_match_semantics (PrefixMatch (fst (src r)) (snd (src r))) p"
 by(cases "(src r)") (simp add: prefix_match_semantics_ipset_from_netmask2 prefix_to_wordset_ipset_from_cidr simple_match_valid_def valid_prefix_fw_def)
 lemma simple_match_dst_alt: "simple_match_valid r \<Longrightarrow> 
 	simple_match_ip (dst r) p \<longleftrightarrow> prefix_match_semantics (PrefixMatch (fst (dst r)) (snd (dst r))) p"
 by(cases "(dst r)") (simp add: prefix_match_semantics_ipset_from_netmask2 prefix_to_wordset_ipset_from_cidr simple_match_valid_def valid_prefix_fw_def)
 
 lemma "x \<in> set (wordinterval_CIDR_split_prefixmatch w) \<Longrightarrow> valid_prefix x"
 using wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1] .
 
 lemma simple_match_to_of_matchI: 
 	assumes mv: "simple_match_valid r"
 	assumes mm: "simple_matches r p"
 	assumes ii: "p_iiface p \<in> set ifs"
 	assumes ippkt: "p_l2type p = 0x800"
 	shows eq: "\<exists>gr \<in> set (simple_match_to_of_match r ifs). OF_match_fields gr p = Some True"
 proof -
 	let ?npm = "\<lambda>p. fst p = 0 \<and> snd p = max_word"
 	let ?sb = "\<lambda>p r. (if ?npm p then None else Some r)"
 	obtain si where si: "case si of Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi | None \<Rightarrow> True"
 		"case si of None \<Rightarrow> True | Some ssi \<Rightarrow> ssi \<in> set (
 		wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))"
 		"si = None \<longleftrightarrow> ?npm (sports r)"
 	proof(cases "?npm (sports r)", goal_cases)
 		case 1 (* True *)
 		hence "(case None of None \<Rightarrow> True | Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi) \<and>
             (case None of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r))))" by simp
         with 1 show ?thesis by blast
 	next
 		case 2 (* False *)
 		from mm have "p_sport p \<in> wordinterval_to_set (uncurry WordInterval (sports r))"
 			by(simp only: simple_matches.simps simple_match_port_alt)
 		then obtain ssi where ssi:
 			"ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))"
 			"p_sport p \<in> prefix_to_wordset ssi" 
 			using wordinterval_CIDR_split_existential by fast
 		hence "(case Some ssi of None \<Rightarrow> True | Some ssi \<Rightarrow> p_sport p \<in> prefix_to_wordset ssi) \<and>
             (case Some ssi of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r))))" by simp
         with 2 show ?thesis by blast
     qed				
 	obtain di where di: "case di of Some ddi \<Rightarrow> p_dport p \<in> prefix_to_wordset ddi | None \<Rightarrow> True"
 		"case di of None \<Rightarrow> True | Some ddi \<Rightarrow> ddi \<in> set (
 		wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))"
 		"di = None \<longleftrightarrow> ?npm (dports r)"
 	proof(cases "?npm (dports r)", goal_cases)
 		case 1
 		hence "(case None of None \<Rightarrow> True | Some ssi \<Rightarrow> p_dport p \<in> prefix_to_wordset ssi) \<and>
             (case None of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r))))" by simp
         with 1 show ?thesis by blast
 	next
 		case 2
 		from mm have "p_dport p \<in> wordinterval_to_set (uncurry WordInterval (dports r))"
 			by(simp only: simple_matches.simps simple_match_port_alt)
 		then obtain ddi where ddi:
 			"ddi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))"
 			"p_dport p \<in> prefix_to_wordset ddi" 
 			using wordinterval_CIDR_split_existential by fast
 		hence "(case Some ddi of None \<Rightarrow> True | Some ssi \<Rightarrow> p_dport p \<in> prefix_to_wordset ssi) \<and>
             (case Some ddi of None \<Rightarrow> True
             | Some ssi \<Rightarrow> ssi \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r))))" by simp
         with 2 show ?thesis by blast
     qed
     show ?thesis
 	proof
 		let ?mf = "map_option (apsnd (wordNOT \<circ> mask \<circ> (-) 16) \<circ> prefix_match_dtor)"
 		let ?gr = "simple_match_to_of_match_single r
 			(if iiface r = ifaceAny then None else Some (p_iiface p)) 
 			(if proto r = ProtoAny then ProtoAny else Proto (p_proto p))
 			(?mf si) (?mf di)"
 		note mfu = simple_match_port.simps[of "fst (sports r)" "snd (sports r)", unfolded surjective_pairing[of "sports r",symmetric]]
 				   simple_match_port.simps[of "fst (dports r)" "snd (dports r)", unfolded surjective_pairing[of "dports r",symmetric]]
 		note u = mm[unfolded simple_matches.simps mfu ord_class.atLeastAtMost_iff simple_packet_unext_def simple_packet.simps]
 		note of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs]
 		from u have ple: "fst (sports r) \<le> snd (sports r)" "fst (dports r) \<le> snd (dports r)" by force+
 		show eg: "?gr \<in> set (simple_match_to_of_match r ifs)"
 			unfolding simple_match_to_of_match_def
 			unfolding custom_simpset
 			unfolding smtoms_eq_hlp
 			proof(intro bexI, (intro conjI; ((rule refl)?)), goal_cases)
 				case 2 thus ?case using ple(2) di
 					apply(simp add: pfxm_mask_def prefix_match_dtor_def Set.image_iff 
 					           split: option.splits prod.splits uncurry_splits)
 					apply(erule bexI[rotated])
 					apply(simp split: prefix_match.splits)
 				done
 			next
 				case 3 thus ?case using ple(1) si
 					apply(simp add: pfxm_mask_def prefix_match_dtor_def Set.image_iff 
 					           split: option.splits prod.splits uncurry_splits)
 					apply(erule bexI[rotated])
 					apply(simp split: prefix_match.splits)
 				done
 			next
 				case 4 thus ?case
 				  using u ii by(clarsimp simp: set_maps split: if_splits)
 			next
 				case 1 thus ?case using ii u by simp_all (metis match_proto.elims(2))  
 			qed
 		have dpm: "di = Some (PrefixMatch x1 x2) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1" for x1 x2
     proof -
       have *: "di = Some (PrefixMatch x1 x2) \<Longrightarrow> prefix_match_semantics (the di) (p_dport p) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"
         by(clarsimp simp: prefix_match_semantics_def pfxm_mask_def word_bw_comms;fail)
       have **: "pfx \<in> set (wordinterval_CIDR_split_prefixmatch ra) \<Longrightarrow> prefix_match_semantics pfx a = (a \<in> prefix_to_wordset pfx)" for pfx ra and a :: "16 word"
         by (fact prefix_match_semantics_wordset[OF wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1]])
       have "\<lbrakk>di = Some (PrefixMatch x1 x2); p_dport p \<in> prefix_to_wordset (PrefixMatch x1 x2); PrefixMatch x1 x2 \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (dports r)))\<rbrakk>
              \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"
       using di(1,2)
         using * ** by auto
       thus "di = Some (PrefixMatch x1 x2) \<Longrightarrow> p_dport p && ~~ (mask (16 - x2)) = x1"  using di(1,2) by auto
     qed
 		have spm: "si = Some (PrefixMatch x1 x2) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1" for x1 x2
     using si
     proof -
       have *: "si = Some (PrefixMatch x1 x2) \<Longrightarrow> prefix_match_semantics (the si) (p_sport p) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"
         by(clarsimp simp: prefix_match_semantics_def pfxm_mask_def word_bw_comms;fail)
       have **: "pfx \<in> set (wordinterval_CIDR_split_prefixmatch ra) \<Longrightarrow> prefix_match_semantics pfx a = (a \<in> prefix_to_wordset pfx)" for pfx ra and a :: "16 word"
         by (fact prefix_match_semantics_wordset[OF wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1]])
       have "\<lbrakk>si = Some (PrefixMatch x1 x2); p_sport p \<in> prefix_to_wordset (PrefixMatch x1 x2); PrefixMatch x1 x2 \<in> set (wordinterval_CIDR_split_prefixmatch (uncurry WordInterval (sports r)))\<rbrakk>
              \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"
       using si(1,2)
         using * ** by auto
       thus "si = Some (PrefixMatch x1 x2) \<Longrightarrow> p_sport p && ~~ (mask (16 - x2)) = x1"  using si(1,2) by auto
     qed
 		show "OF_match_fields ?gr p = Some True"
 		unfolding of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs[OF mv eg]]
 		  by(cases si; cases di)
         (simp_all
 					add: simple_match_to_of_match_single_def OF_match_fields_unsafe_def spm
 					     option2set_def u ippkt prefix_match_dtor_def toprefixmatch_def dpm
 					     simple_match_dst_alt[OF mv, symmetric] simple_match_src_alt[OF mv, symmetric]
 					split: prefix_match.splits)
 	qed
 qed
 
 lemma prefix_match_00[simp,intro!]: "prefix_match_semantics (PrefixMatch 0 0) p"
   by (simp add: valid_prefix_def zero_prefix_match_all)
 
 lemma simple_match_to_of_matchD:
 	assumes eg: "gr \<in> set (simple_match_to_of_match r ifs)"
 	assumes mo: "OF_match_fields gr p = Some True"
 	assumes me: "match_iface (oiface r) (p_oiface p)"
 	assumes mv: "simple_match_valid r"
 	shows "simple_matches r p"
 proof -
 	from mv have validpfx: 
 		"valid_prefix (uncurry PrefixMatch (src r))" "valid_prefix (uncurry PrefixMatch (dst r))"
 		"\<And>pm. toprefixmatch (src r) = Some pm \<Longrightarrow> valid_prefix pm"
 		"\<And>pm. toprefixmatch (dst r) = Some pm \<Longrightarrow> valid_prefix pm"
 		unfolding simple_match_valid_def valid_prefix_fw_def toprefixmatch_def 
 		  by(simp_all split: uncurry_splits if_splits)
 	from mo have mo: "OF_match_fields_unsafe gr p" 
 		unfolding of_safe_unsafe_match_eq[OF simple_match_to_of_match_generates_prereqs[OF mv eg]]
 		by simp
 	note this[unfolded OF_match_fields_unsafe_def]
 	note eg[unfolded simple_match_to_of_match_def simple_match_to_of_match_single_def  custom_simpset option2set_def]
 	then guess x ..	moreover from this(2) guess xa ..	moreover from this(2) guess xb ..
 	note xx = calculation(1,3) this
 
   { fix a b xc xa
       fix pp :: "16 word"
 	  have "\<lbrakk>pp && ~~ (pfxm_mask xc) = pfxm_prefix xc\<rbrakk>
               \<Longrightarrow> prefix_match_semantics xc (pp)" for xc
       by(simp add: prefix_match_semantics_def word_bw_comms;fail)
     moreover have "pp \<in> wordinterval_to_set (WordInterval a b) \<Longrightarrow> a \<le> pp \<and> pp \<le> b" by simp
     moreover have "xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)) \<Longrightarrow> pp \<in> prefix_to_wordset xc  \<Longrightarrow> pp \<in> wordinterval_to_set (WordInterval a b)"
 			by(subst wordinterval_CIDR_split_prefixmatch) blast
 	  moreover have "\<lbrakk>xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)); xa = Some (pfxm_prefix xc, ~~ (pfxm_mask xc)); prefix_match_semantics xc (pp)\<rbrakk> \<Longrightarrow> pp \<in> prefix_to_wordset xc"
 			apply(subst(asm)(1) prefix_match_semantics_wordset)
 			apply(erule wordinterval_CIDR_split_prefixmatch_all_valid_Ball[THEN bspec, THEN conjunct1];fail)
 			apply assumption
 	  done
 	  ultimately have "\<lbrakk>xc \<in> set (wordinterval_CIDR_split_prefixmatch (WordInterval a b)); xa = Some (pfxm_prefix xc, ~~ (pfxm_mask xc));
                pp && ~~ (pfxm_mask xc) = pfxm_prefix xc\<rbrakk>
               \<Longrightarrow> a \<le> pp \<and> pp \<le> b"
      by metis
 	} note l4port_logic = this
 
 	show ?thesis unfolding simple_matches.simps
 	proof(unfold and_assoc, (rule)+)
 		show "match_iface (iiface r) (p_iiface p)"
 			apply(cases "iiface r = ifaceAny")
 			 apply (simp add: match_ifaceAny) 
 			using xx(1) mo unfolding xx(4) OF_match_fields_unsafe_def
 			apply(simp only: if_False set_maps UN_iff)
 			apply(clarify)
 			apply(rename_tac a; subgoal_tac "match_iface (iiface r) a")
 			 apply(clarsimp simp add: option2set_def;fail)
 			apply(rule ccontr,simp;fail)
 		done
 	next
 		show "match_iface (oiface r) (p_oiface p)" using me .
 	next
 		show "simple_match_ip (src r) (p_src p)"
 			using mo unfolding xx(4) OF_match_fields_unsafe_def toprefixmatch_def
 			by(clarsimp
 			  simp add: simple_packet_unext_def option2set_def validpfx simple_match_src_alt[OF mv] toprefixmatch_def 
 			  split: if_splits)
 	next
 		show "simple_match_ip (dst r) (p_dst p)"
 			using mo unfolding xx(4) OF_match_fields_unsafe_def toprefixmatch_def
 			by(clarsimp
 			  simp add: simple_packet_unext_def option2set_def validpfx simple_match_dst_alt[OF mv] toprefixmatch_def 
 			  split: if_splits)
  	next
 		show "match_proto (proto r) (p_proto p)"
 			using mo unfolding xx(4) OF_match_fields_unsafe_def
 			using xx(1) by(clarsimp 
 				simp add: singleton_iff simple_packet_unext_def option2set_def prefix_match_semantics_simple_match ball_Un 
 				split: if_splits protocol.splits)
 	next
 		show "simple_match_port (sports r) (p_sport p)"
 			using mo xx(2) unfolding xx(4) OF_match_fields_unsafe_def
 			by(cases "sports r") (clarsimp simp add: l4port_logic simple_packet_unext_def option2set_def prefix_match_semantics_simple_match split: if_splits)
 	next
 		show "simple_match_port (dports r) (p_dport p)" 
 		  using mo xx(3) unfolding xx(4) OF_match_fields_unsafe_def
 			by(cases "dports r") (clarsimp simp add: l4port_logic simple_packet_unext_def option2set_def prefix_match_semantics_simple_match split: if_splits)
     qed
 qed
 
 primrec annotate_rlen where
 "annotate_rlen [] = []" |
 "annotate_rlen (a#as) = (length as, a) # annotate_rlen as"
 lemma "annotate_rlen ''asdf'' = [(3, CHR ''a''), (2, CHR ''s''), (1, CHR ''d''), (0, CHR ''f'')]" by simp
 
 lemma fst_annotate_rlen_le: "(k, a) \<in> set (annotate_rlen l) \<Longrightarrow> k < length l"
 	by(induction l arbitrary: k; simp; force)
 
 lemma distinct_fst_annotate_rlen: "distinct (map fst (annotate_rlen l))"
 	using fst_annotate_rlen_le by(induction l) (simp, fastforce)
 lemma distinct_annotate_rlen: "distinct (annotate_rlen l)"
 	using distinct_fst_annotate_rlen unfolding distinct_map by blast
 lemma in_annotate_rlen: "(a,x) \<in> set (annotate_rlen l) \<Longrightarrow> x \<in> set l" 
   by(induction l) (simp_all, blast)
 lemma map_snd_annotate_rlen: "map snd (annotate_rlen l) = l"
   by(induction l) simp_all
 lemma "sorted_descending (map fst (annotate_rlen l))"
   by(induction l; clarsimp) (force dest: fst_annotate_rlen_le)
 lemma "annotate_rlen l = zip (rev [0..<length l]) l"
   by(induction l; simp) (* It would probably have been better to just use the zip, but oh well\<dots> *)
 
 primrec annotate_rlen_code where
 "annotate_rlen_code [] = (0,[])" |
 "annotate_rlen_code (a#as) = (case annotate_rlen_code as of (r,aas) \<Rightarrow> (Suc r, (r, a) # aas))"
 lemma annotate_rlen_len: "fst (annotate_rlen_code r) = length r"
 by(induction r) (clarsimp split: prod.splits)+
 lemma annotate_rlen_code[code]: "annotate_rlen s = snd (annotate_rlen_code s)"
 proof(induction s)
   case (Cons s ss) thus ?case using annotate_rlen_len[of ss] by(clarsimp split: prod.split)
 qed simp
 
 lemma suc2plus_inj_on: "inj_on (of_nat :: nat \<Rightarrow> ('l :: len) word) {0..unat (max_word :: 'l word)}"
 proof(rule inj_onI)
    let ?mmw = "(max_word :: 'l word)"
    let ?mstp = "(of_nat :: nat \<Rightarrow> 'l word)"
    fix x y :: nat
    assume "x \<in> {0..unat ?mmw}" "y \<in> {0..unat ?mmw}"
    hence se: "x \<le> unat ?mmw" "y \<le> unat ?mmw" by simp_all
    assume eq: "?mstp x = ?mstp y"
    note f = le_unat_uoi[OF se(1)] le_unat_uoi[OF se(2)]
    show "x = y" using eq le_unat_uoi se by metis
 qed
 
 lemma distinct_of_nat_list: (* TODO: Move to CaesarWordLemmaBucket *)
 	"distinct l \<Longrightarrow> \<forall>e \<in> set l. e \<le> unat (max_word :: ('l::len) word) \<Longrightarrow> distinct (map (of_nat :: nat \<Rightarrow> 'l word) l)"
 proof(induction l)
 	let ?mmw = "(max_word :: 'l word)"
 	let ?mstp = "(of_nat :: nat \<Rightarrow> 'l word)"
 	case (Cons a as)
 	have "distinct as" "\<forall>e\<in>set as. e \<le> unat ?mmw" using Cons.prems by simp_all 
 	note mIH = Cons.IH[OF this]
 	moreover have "?mstp a \<notin> ?mstp ` set as"
 	proof 
 		have representable_set: "set as \<subseteq> {0..unat ?mmw}" using \<open>\<forall>e\<in>set (a # as). e \<le> unat max_word\<close> by fastforce
 		have a_reprbl: "a \<in> {0..unat ?mmw}" using \<open>\<forall>e\<in>set (a # as). e \<le> unat max_word\<close> by simp
 		assume "?mstp a \<in> ?mstp ` set as"
 		with inj_on_image_mem_iff[OF suc2plus_inj_on a_reprbl representable_set]
 		have "a \<in> set as" by simp
 		with \<open>distinct (a # as)\<close> show False by simp
 	qed
 	ultimately show ?case by simp
 qed simp
 
 lemma annotate_first_le_hlp:
 	"length l < unat (max_word :: ('l :: len) word) \<Longrightarrow> \<forall>e\<in>set (map fst (annotate_rlen l)). e \<le> unat (max_word :: 'l word)"
 	by(clarsimp) (meson fst_annotate_rlen_le less_trans nat_less_le)
 lemmas distinct_of_prio_hlp = distinct_of_nat_list[OF distinct_fst_annotate_rlen annotate_first_le_hlp]
 (* don't need these right now, but maybe later? *)
                                                   
 lemma fst_annotate_rlen: "map fst (annotate_rlen l) = rev [0..<length l]"
 by(induction l) (simp_all)
 
 lemma sorted_word_upt:
   defines[simp]: "won \<equiv> (of_nat :: nat \<Rightarrow> ('l :: len) word)"
   assumes "length l \<le> unat (max_word :: 'l word)"
   shows "sorted_descending (map won (rev [0..<Suc (length l)]))" 
 using assms
   by(induction l rule: rev_induct;clarsimp)
     (metis (mono_tags, hide_lams) le_SucI le_unat_uoi of_nat_Suc order_refl word_le_nat_alt)
     (* This proof is kind of ugly. In case it breaks unfixably, go back to rev a9c4927 and get word_upto.
        The lemmas on word_upto can be used to shows this trivially. *)
 
 lemma sorted_annotated:
 	assumes "length l \<le> unat (max_word :: ('l :: len) word)"
 	shows "sorted_descending (map fst (map (apfst (of_nat :: nat \<Rightarrow> 'l word)) (annotate_rlen l)))"
 proof -
 	let ?won = "(of_nat :: nat \<Rightarrow> 'l word)"
 	have "sorted_descending (map ?won (rev [0..<Suc (length l)]))" 
 		using sorted_word_upt[OF assms] .
 	hence "sorted_descending (map ?won (map fst (annotate_rlen l)))" by(simp add: fst_annotate_rlen)
 	thus "sorted_descending (map fst (map (apfst ?won) (annotate_rlen l)))" by simp
 qed
 
 text\<open>l3 device to l2 forwarding\<close>
 definition "lr_of_tran_s3 ifs ard = (
 	[(p, b, case a of simple_action.Accept \<Rightarrow> [Forward c] | simple_action.Drop \<Rightarrow> []).
 		(p,r,(c,a)) \<leftarrow> ard, b \<leftarrow> simple_match_to_of_match r ifs])"
 
 definition "oif_ne_iif_p1 ifs \<equiv> [(simple_match_any\<lparr>oiface := Iface oif, iiface := Iface iif\<rparr>, simple_action.Accept). oif \<leftarrow> ifs, iif \<leftarrow> ifs, oif \<noteq> iif]"
 definition "oif_ne_iif_p2 ifs = [(simple_match_any\<lparr>oiface := Iface i, iiface := Iface i\<rparr>, simple_action.Drop). i \<leftarrow> ifs]"
 definition "oif_ne_iif ifs = oif_ne_iif_p2 ifs @ oif_ne_iif_p1 ifs" (* order irrelephant *)
 (*value "oif_ne_iif [''a'', ''b'']"*)
 (* I first tried something like "oif_ne_iif ifs \<equiv> [(simple_match_any\<lparr>oiface := Iface oi, iiface := Iface ii\<rparr>, if oi = ii then simple_action.Drop else simple_action.Accept). oi \<leftarrow> ifs, ii \<leftarrow> ifs]", 
    but making the statement I wanted with that was really tricky. Much easier to have the second element constant and do it separately. *)
 definition "lr_of_tran_s4 ard ifs \<equiv> generalized_fw_join ard (oif_ne_iif ifs)"
 
 definition "lr_of_tran_s1 rt = [(route2match r, output_iface (routing_action r)). r \<leftarrow> rt]"
 
 definition "lr_of_tran_fbs rt fw ifs \<equiv> let
 	gfw = map simple_rule_dtor fw; \<comment> \<open>generalized simple fw, hopefully for FORWARD\<close>
 	frt = lr_of_tran_s1 rt; \<comment> \<open>rt as fw\<close>
 	prd = generalized_fw_join frt gfw
 	in prd
 "
 
 definition "pack_OF_entries ifs ard \<equiv> (map (split3 OFEntry) (lr_of_tran_s3 ifs ard))"
 definition "no_oif_match \<equiv> list_all (\<lambda>m. oiface (match_sel m) = ifaceAny)"
 
 definition "lr_of_tran rt fw ifs \<equiv> 
   if \<not> (no_oif_match fw \<and> has_default_policy fw \<and> simple_fw_valid fw	\<and> valid_prefixes rt \<and> has_default_route rt \<and> distinct ifs)
     then Inl ''Error in creating OpenFlow table: prerequisites not satisifed''
     else (
   let	nrd = lr_of_tran_fbs rt fw ifs;
 	ard = map (apfst of_nat) (annotate_rlen nrd) \<comment> \<open>give them a priority\<close>
 	in
 	if length nrd < unat (max_word :: 16 word)
 	then Inr (pack_OF_entries ifs ard)
 	else Inl ''Error in creating OpenFlow table: priority number space exhausted'')
 "
 
 definition "is_iface_name i \<equiv> i \<noteq> [] \<and> \<not>Iface.iface_name_is_wildcard i"
 definition "is_iface_list ifs \<equiv> distinct ifs \<and> list_all is_iface_name ifs"
 
 lemma max_16_word_max[simp]: "(a :: 16 word) \<le> 0xffff"
 proof -
 	have "0xFFFF = (- 1 :: 16 word)" by simp
 	then show ?thesis by (simp only:) simp
 qed
 
 lemma replicate_FT_hlp: "x \<le> 16 \<and> y \<le> 16 \<Longrightarrow> replicate (16 - x) False @ replicate x True = replicate (16 - y) False @ replicate y True \<Longrightarrow> x = y"
 proof -
 	let ?ns = "{0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16}"
 	assume "x \<le> 16 \<and> y \<le> 16"
 	hence "x \<in> ?ns" "y \<in> ?ns" by(simp; presburger)+
 	moreover assume "replicate (16 - x) False @ replicate x True = replicate (16 - y) False @ replicate y True"
 	ultimately show "x = y" by simp (elim disjE; simp_all) (* that's only 289 subgoals after the elim *)
 qed
 
 lemma mask_inj_hlp1: "inj_on (mask :: nat \<Rightarrow> 16 word) {0..16}"
 proof(intro inj_onI, goal_cases)
   case (1 x y)
   from 1(3)
   have oe: "of_bl (replicate (16 - x) False @ replicate x True) = (of_bl (replicate (16 - y) False @ replicate y True) :: 16 word)"
          unfolding mask_bl of_bl_rep_False .
   have "\<And>z. z \<le> 16 \<Longrightarrow> length (replicate (16 - z) False @ replicate z True) = 16" by auto
   with 1(1,2)
   have ps: "replicate (16 - x) False @ replicate x True \<in> {bl. length bl = LENGTH(16)}" " replicate (16 - y) False @ replicate y True \<in> {bl. length bl = LENGTH(16)}" by simp_all
   from inj_onD[OF word_bl.Abs_inj_on, OF oe ps]
   show ?case using 1(1,2) by(fastforce intro: replicate_FT_hlp)
 qed
 
 lemma distinct_simple_match_to_of_match_portlist_hlp: 
   fixes ps :: "(16 word \<times> 16 word)"
   shows "distinct ifs \<Longrightarrow>
     distinct
      (if fst ps = 0 \<and> snd ps = max_word then [None]
       else if fst ps \<le> snd ps
            then map (Some \<circ> (\<lambda>pfx. (pfxm_prefix pfx, ~~ (pfxm_mask pfx))))
                  (wordinterval_CIDR_split_prefixmatch (WordInterval (fst ps) (snd ps)))
            else [])"
 proof -
   assume di: "distinct ifs"
   { define wis where "wis = set (wordinterval_CIDR_split_prefixmatch (WordInterval (fst ps) (snd ps)))"
     fix x y :: "16 prefix_match"
     obtain xm xn ym yn where xyd[simp]: "x = PrefixMatch xm xn" "y = PrefixMatch ym yn" by(cases x; cases y)
     assume iw: "x \<in> wis" "y \<in> wis" and et: "(pfxm_prefix x, ~~ (pfxm_mask x)) = (pfxm_prefix y, ~~ (pfxm_mask y))"
     hence le16: "xn \<le> 16" "yn \<le> 16" unfolding wis_def using wordinterval_CIDR_split_prefixmatch_all_valid_Ball[unfolded Ball_def, THEN spec, THEN mp] by force+
     with et have "16 - xn = 16 - yn" unfolding pfxm_mask_def by(auto intro: mask_inj_hlp1[THEN inj_onD])
     hence "x = y" using et le16 using diff_diff_cancel by simp
   } note * = this
   show ?thesis 
     apply(clarsimp simp add: smtoms_eq_hlp distinct_map wordinterval_CIDR_split_distinct)
     apply(subst comp_inj_on_iff[symmetric]; intro inj_onI)
   using * by simp_all
 qed
 
 lemma distinct_simple_match_to_of_match: "distinct ifs \<Longrightarrow> distinct (simple_match_to_of_match m ifs)"
   apply(unfold simple_match_to_of_match_def Let_def)
   apply(rule distinct_3lcomprI)
   subgoal by(induction ifs; clarsimp)
   subgoal by(fact distinct_simple_match_to_of_match_portlist_hlp)
   subgoal by(fact distinct_simple_match_to_of_match_portlist_hlp)
   subgoal by(simp_all add: smtoms_eq_hlp)
 done
 
 lemma inj_inj_on: "inj F \<Longrightarrow> inj_on F A" using subset_inj_on by auto (* TODO: include Word_Lib *)
 
 lemma no_overlaps_lroft_hlp2: "distinct (map fst amr) \<Longrightarrow> (\<And>r. distinct (fm r)) \<Longrightarrow>
     distinct (concat (map (\<lambda>(p, r, c, a). map (\<lambda>b. (p, b, fs a c)) (fm r)) amr))"
   by(induction amr; force intro: injI inj_onI simp add: distinct_map split: prod.splits)
 
 lemma distinct_lroft_s3: "\<lbrakk>distinct (map fst amr); distinct ifs\<rbrakk> \<Longrightarrow> distinct (lr_of_tran_s3 ifs amr)"
   unfolding lr_of_tran_s3_def
   by(erule no_overlaps_lroft_hlp2, simp add: distinct_simple_match_to_of_match)
 
 lemma no_overlaps_lroft_hlp3: "distinct (map fst amr) \<Longrightarrow>
 (aa, ab, ac) \<in> set (lr_of_tran_s3 ifs amr) \<Longrightarrow> (ba, bb, bc) \<in> set (lr_of_tran_s3 ifs amr) \<Longrightarrow>
 ac \<noteq> bc \<Longrightarrow> aa \<noteq> ba"
   apply(unfold lr_of_tran_s3_def)
   apply(clarsimp)
   apply(clarsimp split: simple_action.splits)
     apply(metis map_of_eq_Some_iff old.prod.inject option.inject)
    apply(metis map_of_eq_Some_iff old.prod.inject option.inject simple_action.distinct(2))+
 done
 
 lemma no_overlaps_lroft_s3_hlp_hlp: (* I hlps *)
   "\<lbrakk>distinct (map fst amr); OF_match_fields_unsafe ab p; ab \<noteq> ad \<or> ba \<noteq> bb; OF_match_fields_unsafe ad p;
         (ac, ab, ba) \<in> set (lr_of_tran_s3 ifs amr); (ac, ad, bb) \<in> set (lr_of_tran_s3 ifs amr)\<rbrakk>
        \<Longrightarrow> False"
 proof(elim disjE, goal_cases)
   case 1
   have 4: "\<lbrakk>distinct (map fst amr);  (ac, ab, x1, x2) \<in> set amr; (ac, bb, x4, x5) \<in> set amr; ab \<noteq> bb\<rbrakk>
        \<Longrightarrow> False" for ab x1 x2 bb x4 x5
        by (meson distinct_map_fstD old.prod.inject)
   have conjunctSomeProtoAnyD: "Some ProtoAny = simple_proto_conjunct a (Proto b) \<Longrightarrow> False" for a b
     using conjunctProtoD by force
   have 5:
        "\<lbrakk>OF_match_fields_unsafe am p; OF_match_fields_unsafe bm p; am \<noteq> bm; 
         am \<in> set (simple_match_to_of_match ab ifs); bm \<in> set (simple_match_to_of_match bb ifs); \<not> ab \<noteq> bb\<rbrakk>
        \<Longrightarrow> False" for ab bb am bm
       by(clarify | unfold
          simple_match_to_of_match_def smtoms_eq_hlp Let_def set_concat set_map de_Morgan_conj not_False_eq_True)+
         (auto dest: conjunctSomeProtoAnyD cidrsplit_no_overlaps
 	            simp add: OF_match_fields_unsafe_def simple_match_to_of_match_single_def option2set_def comp_def
 	            split: if_splits
 	            cong: smtoms_eq_hlp) (*1min*)
   from 1 show ?case
   using 4 5 by(clarsimp simp add: lr_of_tran_s3_def) blast
 qed(metis no_overlaps_lroft_hlp3)
 
 
 lemma no_overlaps_lroft_s3_hlp: "distinct (map fst amr) \<Longrightarrow> distinct ifs \<Longrightarrow> 
 no_overlaps OF_match_fields_unsafe (map (split3 OFEntry) (lr_of_tran_s3 ifs amr))"
   apply(rule no_overlapsI[rotated])
   apply(subst distinct_map, rule conjI)
   subgoal by(erule (1) distinct_lroft_s3)
   subgoal
     apply(rule inj_inj_on)
     apply(rule injI)
     apply(rename_tac x y, case_tac x, case_tac y)
     apply(simp add: split3_def;fail)
   done
   subgoal
     apply(unfold check_no_overlap_def)
     apply(clarify)
     apply(unfold set_map)
     apply(clarify)
     apply(unfold split3_def prod.simps flow_entry_match.simps flow_entry_match.sel de_Morgan_conj)
     apply(clarsimp simp only:)
     apply(erule (1) no_overlaps_lroft_s3_hlp_hlp)
        apply simp
       apply assumption
      apply assumption
     apply simp
   done
 done
 
 lemma lr_of_tran_no_overlaps: assumes "distinct ifs" shows "Inr t = (lr_of_tran rt fw ifs) \<Longrightarrow> no_overlaps OF_match_fields_unsafe t"
 	apply(unfold lr_of_tran_def Let_def pack_OF_entries_def)
 	apply(simp split: if_splits)
 	apply(thin_tac "t = _")
 	apply(drule distinct_of_prio_hlp)
 	apply(rule no_overlaps_lroft_s3_hlp[rotated])
 	subgoal by(simp add: assms)
 	subgoal by(simp add: o_assoc)
 done
 
 lemma sorted_lr_of_tran_s3_hlp: "\<forall>x\<in>set f. fst x \<le> a \<Longrightarrow> b \<in> set (lr_of_tran_s3 s f) \<Longrightarrow> fst b \<le> a" 
 	by(auto simp add: lr_of_tran_s3_def)
 
 lemma lr_of_tran_s3_Cons: "lr_of_tran_s3 ifs (a#ard) = (
 	[(p, b, case a of simple_action.Accept \<Rightarrow> [Forward c] | simple_action.Drop \<Rightarrow> []).
 		(p,r,(c,a)) \<leftarrow> [a], b \<leftarrow> simple_match_to_of_match r ifs]) @ lr_of_tran_s3 ifs ard"
 	by(clarsimp simp: lr_of_tran_s3_def)
 
 lemma sorted_lr_of_tran_s3: "sorted_descending (map fst f) \<Longrightarrow> sorted_descending (map fst (lr_of_tran_s3 s f))"
 	apply(induction f)
 	 subgoal by(simp add: lr_of_tran_s3_def)
 	apply(clarsimp simp: lr_of_tran_s3_Cons map_concat comp_def)
 	apply(unfold sorted_descending_append)
 	apply(simp add: sorted_descending_alt rev_map sorted_lr_of_tran_s3_hlp sorted_const)
 done
 
 lemma sorted_lr_of_tran_hlp: "(ofe_prio \<circ> split3 OFEntry) = fst" by(simp add: fun_eq_iff comp_def split3_def)
 
 lemma lr_of_tran_sorted_descending: "Inr r = lr_of_tran rt fw ifs \<Longrightarrow> sorted_descending (map ofe_prio r)"
 	apply(unfold lr_of_tran_def Let_def)
 	apply(simp split: if_splits)
 	apply(thin_tac "r = _")
 	apply(unfold sorted_lr_of_tran_hlp pack_OF_entries_def split3_def[abs_def] fun_app_def map_map comp_def prod.case_distrib)
 	apply(simp add: fst_def[symmetric])
 	apply(rule sorted_lr_of_tran_s3)
 	apply(drule sorted_annotated[OF less_or_eq_imp_le, OF disjI1])
 	apply(simp add: o_assoc)
 done
 
 lemma lr_of_tran_s1_split: "lr_of_tran_s1 (a # rt) = (route2match a, output_iface (routing_action a)) # lr_of_tran_s1 rt"
 	by(unfold lr_of_tran_s1_def list.map, rule)
 
 lemma route2match_correct: "valid_prefix (routing_match a) \<Longrightarrow> prefix_match_semantics (routing_match a) (p_dst p) \<longleftrightarrow> simple_matches (route2match a) (p)"
 by(simp add: route2match_def simple_matches.simps match_ifaceAny match_iface_refl ipset_from_cidr_0 prefix_match_semantics_ipset_from_netmask2)
 
 lemma s1_correct: "valid_prefixes rt \<Longrightarrow> has_default_route (rt::('i::len) prefix_routing) \<Longrightarrow> 
   \<exists>rm ra. generalized_sfw (lr_of_tran_s1 rt) p = Some (rm,ra) \<and> ra = output_iface (routing_table_semantics rt (p_dst p))"
 	apply(induction rt)
 	 apply(simp;fail)
 	apply(drule valid_prefixes_split)
 	apply(clarsimp)
 	apply(erule disjE)
 	subgoal for a rt
 	 apply(case_tac a)
 	 apply(rename_tac routing_m metric routing_action)
 	 apply(case_tac routing_m)
 	 apply(simp add: valid_prefix_def pfxm_mask_def prefix_match_semantics_def generalized_sfw_def 
 	       lr_of_tran_s1_def route2match_def simple_matches.simps match_ifaceAny match_iface_refl ipset_from_cidr_0
 	       max_word_mask[where 'a = 'i, symmetric, simplified])
 	done
 	subgoal
     apply(rule conjI)
      apply(simp add: generalized_sfw_def lr_of_tran_s1_def route2match_correct;fail)
     apply(simp add: route2match_def simple_matches.simps prefix_match_semantics_ipset_from_netmask2 
                     lr_of_tran_s1_split generalized_sfw_simps)
   done
 done
 
 definition "to_OF_action a \<equiv> (case a of (p,d) \<Rightarrow> (case d of simple_action.Accept \<Rightarrow> [Forward p] | simple_action.Drop \<Rightarrow> []))"
 definition "from_OF_action a = (case a of [] \<Rightarrow> ('''',simple_action.Drop) | [Forward p] \<Rightarrow> (p, simple_action.Accept))"
 
 lemma OF_match_linear_not_noD: "OF_match_linear \<gamma> oms p \<noteq> NoAction \<Longrightarrow> \<exists>ome. ome \<in> set oms \<and> \<gamma> (ofe_fields ome) p"
 	apply(induction oms)
 	 apply(simp)
 	apply(simp split: if_splits)
 	 apply blast+
 done
 
 lemma s3_noaction_hlp: "\<lbrakk>simple_match_valid ac; \<not>simple_matches ac p; match_iface (oiface ac) (p_oiface p)\<rbrakk> \<Longrightarrow> 
 OF_match_linear OF_match_fields_safe (map (\<lambda>x. split3 OFEntry (x1, x, case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> [])) (simple_match_to_of_match ac ifs)) p = NoAction"
   apply(rule ccontr)
   apply(drule OF_match_linear_not_noD)
   apply(clarsimp)
   apply(rename_tac x)
   apply(subgoal_tac "all_prerequisites x")
    apply(drule simple_match_to_of_matchD)
       apply(simp add: split3_def)
       apply(subst(asm) of_match_fields_safe_eq2)
       apply(simp;fail)+
   using simple_match_to_of_match_generates_prereqs by blast
 
+lemma aux:
+  \<open>v = Some x \<Longrightarrow> the v = x\<close>
+  by simp
+
 lemma s3_correct:
 	assumes vsfwm: "list_all simple_match_valid (map (fst \<circ> snd) ard)"
 	assumes ippkt: "p_l2type p = 0x800"
 	assumes iiifs: "p_iiface p \<in> set ifs"
 	assumes oiifs: "list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) ard"
 	shows "OF_match_linear OF_match_fields_safe (pack_OF_entries ifs ard) p = Action ao \<longleftrightarrow> (\<exists>r af. generalized_sfw (map snd ard) p = (Some (r,af)) \<and> (if snd af = simple_action.Drop then ao = [] else ao = [Forward (fst af)]))"
 unfolding pack_OF_entries_def lr_of_tran_s3_def fun_app_def
 using vsfwm oiifs
   apply(induction ard)
    subgoal by(simp add: generalized_sfw_simps)
   apply simp
   apply(clarsimp simp add: generalized_sfw_simps split: prod.splits)
   apply(intro conjI) (* make two subgoals from one *)
    subgoal for ard x1 ac ad ba
     apply(clarsimp simp add: OF_match_linear_append split: prod.splits)
     apply(drule simple_match_to_of_matchI[rotated])
        apply(rule iiifs)
       apply(rule ippkt)
      apply blast
     apply(clarsimp simp add: comp_def)
     apply(drule 
        OF_match_linear_match_allsameaction[where
          \<gamma>=OF_match_fields_safe and pri = x1 and
          oms = "simple_match_to_of_match ac ifs" and 
          act = "case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> []"])
      apply(unfold OF_match_fields_safe_def comp_def)
-     apply(erule Some_to_the[symmetric];fail)
+     apply(erule aux)
     apply(clarsimp)
     apply(intro iffI)
     subgoal
      apply(rule exI[where x = ac])
      apply(rule exI[where x = ad])
      apply(rule exI[where x = ba])
      apply(clarsimp simp: split3_def split: simple_action.splits flowtable_behavior.splits if_splits)
     done
     subgoal
      apply(clarsimp)
      apply(rename_tac b)
      apply(case_tac b)
      apply(simp_all)
    done
   done
   subgoal for ard x1 ac ad ba
    apply(simp add: OF_match_linear_append OF_match_fields_safe_def comp_def)
    apply(clarify)
    apply(subgoal_tac "OF_match_linear OF_match_fields_safe (map (\<lambda>x. split3 OFEntry (x1, x, case ba of simple_action.Accept \<Rightarrow> [Forward ad] | simple_action.Drop \<Rightarrow> [])) (simple_match_to_of_match ac ifs)) p = NoAction")
     apply(simp;fail)
    apply(erule (1) s3_noaction_hlp)
    apply(simp add: match_ifaceAny;fail)
   done
 done
 
 context
   notes valid_prefix_00[simp, intro!]
 begin
   lemma lr_of_tran_s1_valid: "valid_prefixes rt \<Longrightarrow> gsfw_valid (lr_of_tran_s1 rt)"
     unfolding lr_of_tran_s1_def route2match_def gsfw_valid_def list_all_iff
     apply(clarsimp simp: simple_match_valid_def valid_prefix_fw_def)
     apply(intro conjI)
      apply force
     apply(simp add: valid_prefixes_alt_def)
   done
 end
 
 lemma simple_match_valid_fbs_rlen: "\<lbrakk>valid_prefixes rt; simple_fw_valid fw; (a, aa, ab, b) \<in> set (annotate_rlen (lr_of_tran_fbs rt fw ifs))\<rbrakk> \<Longrightarrow> simple_match_valid aa"
 proof(goal_cases)
   case 1
   note 1[unfolded lr_of_tran_fbs_def Let_def]
   have "gsfw_valid (map simple_rule_dtor fw)" using gsfw_validI 1 by blast
   moreover have "gsfw_valid (lr_of_tran_s1 rt)" using 1 lr_of_tran_s1_valid by blast
   ultimately have "gsfw_valid (generalized_fw_join (lr_of_tran_s1 rt) (map simple_rule_dtor fw))" using gsfw_join_valid by blast
   moreover have "(aa, ab, b) \<in> set (lr_of_tran_fbs rt fw ifs)" using 1 using in_annotate_rlen by fast
   ultimately show ?thesis unfolding lr_of_tran_fbs_def Let_def gsfw_valid_def list_all_iff by fastforce
 qed
 
 lemma simple_match_valid_fbs: "\<lbrakk>valid_prefixes rt; simple_fw_valid fw\<rbrakk> \<Longrightarrow> list_all simple_match_valid (map fst (lr_of_tran_fbs rt fw ifs))"
 proof(goal_cases)
   case 1
   note 1[unfolded lr_of_tran_fbs_def Let_def]
   have "gsfw_valid (map simple_rule_dtor fw)" using gsfw_validI 1 by blast
   moreover have "gsfw_valid (lr_of_tran_s1 rt)" using 1 lr_of_tran_s1_valid by blast
   ultimately have "gsfw_valid (generalized_fw_join (lr_of_tran_s1 rt) (map simple_rule_dtor fw))" using gsfw_join_valid by blast
   thus ?thesis unfolding lr_of_tran_fbs_def Let_def gsfw_valid_def list_all_iff by fastforce
 qed
 
 lemma lr_of_tran_prereqs: "valid_prefixes rt \<Longrightarrow> simple_fw_valid fw \<Longrightarrow> lr_of_tran rt fw ifs = Inr oft \<Longrightarrow>
 list_all (all_prerequisites \<circ> ofe_fields) oft"
 unfolding lr_of_tran_def pack_OF_entries_def lr_of_tran_s3_def Let_def
   apply(simp add: map_concat comp_def prod.case_distrib split3_def split: if_splits)
   apply(simp add: list_all_iff)
   apply(clarsimp)
   apply(drule simple_match_valid_fbs_rlen[rotated])
     apply(simp add: list_all_iff;fail)
    apply(simp add: list_all_iff;fail)
   apply(rule simple_match_to_of_match_generates_prereqs; assumption)
 done
 
 (* TODO: move. where? *)
 lemma OF_unsafe_safe_match3_eq: "
   list_all (all_prerequisites \<circ> ofe_fields) oft \<Longrightarrow>
   OF_priority_match OF_match_fields_unsafe oft = OF_priority_match OF_match_fields_safe oft"
 unfolding OF_priority_match_def[abs_def]
 proof(goal_cases)
   case 1
   from 1 have "\<And>packet. [f\<leftarrow>oft . OF_match_fields_unsafe (ofe_fields f) packet] = [f\<leftarrow>oft . OF_match_fields_safe (ofe_fields f) packet]"
     apply(clarsimp simp add: list_all_iff of_match_fields_safe_eq) 
   using of_match_fields_safe_eq by(metis (mono_tags, lifting) filter_cong)
   thus ?case by metis
 qed
 
 lemma OF_unsafe_safe_match_linear_eq: "
   list_all (all_prerequisites \<circ> ofe_fields) oft \<Longrightarrow>
   OF_match_linear OF_match_fields_unsafe oft = OF_match_linear OF_match_fields_safe oft"
 unfolding fun_eq_iff
 by(induction oft) (clarsimp simp add: list_all_iff of_match_fields_safe_eq)+
 
 lemma simple_action_ne[simp]: 
   "b \<noteq> simple_action.Accept \<longleftrightarrow> b = simple_action.Drop"
   "b \<noteq> simple_action.Drop \<longleftrightarrow> b = simple_action.Accept"
 using simple_action.exhaust by blast+
 
 lemma map_snd_apfst: "map snd (map (apfst x) l) = map snd l"
   unfolding map_map comp_def snd_apfst ..
 
 lemma match_ifaceAny_eq: "oiface m = ifaceAny \<Longrightarrow> simple_matches m p = simple_matches m (p\<lparr>p_oiface := any\<rparr>)"
 by(cases m) (simp add: simple_matches.simps match_ifaceAny)
 lemma no_oif_matchD: "no_oif_match fw \<Longrightarrow> simple_fw fw p = simple_fw fw (p\<lparr>p_oiface := any\<rparr>)"
   by(induction fw)
     (auto simp add: no_oif_match_def simple_fw_alt dest: match_ifaceAny_eq)
 
 lemma lr_of_tran_fbs_acceptD:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw"
   shows "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Accept) \<Longrightarrow>
   simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>)"
 proof(goal_cases)
   case 1
   note 1[unfolded lr_of_tran_fbs_def Let_def, THEN generalized_fw_joinD]
   then guess r1 .. then guess r2 .. note r12 = this
   note s1_correct[OF s1, of p]
   then guess rm .. then guess ra .. note rmra = this
   from r12 rmra have oifra: "oif = ra" by simp
   from r12 have sfw: "simple_fw fw p = Decision FinalAllow" using simple_fw_iff_generalized_fw_accept by blast
   note ifupdateirrel = no_oif_matchD[OF s2, where any = " output_iface (routing_table_semantics rt (p_dst p))" and p = p, symmetric]
   show ?case unfolding simple_linux_router_nol12_def by(simp add: Let_def ifupdateirrel sfw oifra rmra split: Option.bind_splits option.splits) 
 qed
 
 lemma lr_of_tran_fbs_acceptI:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw" "has_default_policy fw"
   shows "simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) \<Longrightarrow>
   \<exists>r. generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Accept)"
 proof(goal_cases)
   from s2 have nud: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy state.distinct(1))
   note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
   case 1
   from 1 have "simple_fw fw p = Decision FinalAllow" by(simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
   then obtain r where r: "generalized_sfw (map simple_rule_dtor fw) p = Some (r, simple_action.Accept)" using simple_fw_iff_generalized_fw_accept by blast
   have oif_def: "oif = output_iface (routing_table_semantics rt (p_dst p))" using 1 by(cases p) (simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
   note s1_correct[OF s1, of p] then guess rm .. then guess ra .. note rmra = this
   show ?case unfolding lr_of_tran_fbs_def Let_def
     apply(rule exI)
     apply(rule generalized_fw_joinI)
     unfolding oif_def using rmra apply simp
     apply(rule r)
   done
 qed
 
 lemma lr_of_tran_fbs_dropD:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw"
   shows "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop) \<Longrightarrow>
   simple_linux_router_nol12 rt fw p = None"
 proof(goal_cases)
   note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
   case 1
   from 1[unfolded lr_of_tran_fbs_def Let_def, THEN generalized_fw_joinD]
   obtain rr fr where "generalized_sfw (lr_of_tran_s1 rt) p = Some (rr, oif) \<and>
           generalized_sfw (map simple_rule_dtor fw) p = Some (fr, simple_action.Drop) \<and> Some r = simple_match_and rr fr" by presburger
   hence fd: "\<And>u. simple_fw fw (p\<lparr>p_oiface := u\<rparr>) = Decision FinalDeny" unfolding ifupdateirrel
   using simple_fw_iff_generalized_fw_drop by blast
   show ?thesis
     by(clarsimp simp: simple_linux_router_nol12_def Let_def fd split: Option.bind_splits)
 qed
 
 lemma lr_of_tran_fbs_dropI:
   assumes s1: "valid_prefixes rt" "has_default_route rt"
   assumes s2: "no_oif_match fw" "has_default_policy fw"
   shows "simple_linux_router_nol12 rt fw p = None \<Longrightarrow>
   \<exists>r oif. generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)"
 proof(goal_cases)
   from s2 have nud: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy state.distinct(1))
   note ifupdateirrel = no_oif_matchD[OF s2(1), symmetric]
   case 1
   from 1 have "simple_fw fw p = Decision FinalDeny" by(simp add: simple_linux_router_nol12_def Let_def nud ifupdateirrel split: Option.bind_splits state.splits final_decision.splits)
   then obtain r where r: "generalized_sfw (map simple_rule_dtor fw) p = Some (r, simple_action.Drop)" using simple_fw_iff_generalized_fw_drop by blast
   note s1_correct[OF s1, of p] then guess rm .. then guess ra .. note rmra = this
   show ?case unfolding lr_of_tran_fbs_def Let_def
     apply(rule exI)
     apply(rule exI[where x = ra])
     apply(rule generalized_fw_joinI)
     using rmra apply simp
     apply(rule r)
   done
 qed
 
 
 lemma no_oif_match_fbs:
  "no_oif_match fw \<Longrightarrow> list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))"
 proof(goal_cases)
   case 1
   have c: "\<And>mr ar mf af f a. \<lbrakk>(mr, ar) \<in> set (lr_of_tran_s1 rt); (mf, af) \<in> simple_rule_dtor ` set fw; simple_match_and mr mf = Some a\<rbrakk> \<Longrightarrow> oiface a = ifaceAny"
   proof(goal_cases)
     case (1 mr ar mf af f a)
     have "oiface mr = ifaceAny" using 1(1) unfolding lr_of_tran_s1_def route2match_def by(clarsimp simp add: Set.image_iff)
     moreover have "oiface mf = ifaceAny" using 1(2) \<open>no_oif_match fw\<close> unfolding no_oif_match_def simple_rule_dtor_def[abs_def]
       by(clarsimp simp: list_all_iff split: simple_rule.splits) fastforce 
     ultimately show ?case using 1(3) by(cases a; cases mr; cases mf) (simp add: iface_conjunct_ifaceAny split: option.splits)
   qed
   have la: "list_all (\<lambda>m. oiface (fst m) = ifaceAny) (lr_of_tran_fbs rt fw ifs)"
     unfolding lr_of_tran_fbs_def Let_def list_all_iff
     apply(clarify)
     apply(subst(asm) generalized_sfw_join_set)
     apply(clarsimp)
   using c by blast
   thus ?case
   proof(goal_cases)
     case 1
     have *: "(\<lambda>m. oiface (fst (snd m)) = ifaceAny) = (\<lambda>m. oiface (fst m) = ifaceAny) \<circ> snd" unfolding comp_def ..
     show ?case unfolding * list_all_map[symmetric] map_snd_apfst map_snd_annotate_rlen using la .
   qed
 qed
 
 
 lemma lr_of_tran_correct:
 	fixes p :: "(32, 'a) simple_packet_ext_scheme"
 assumes nerr: "lr_of_tran rt fw ifs = Inr oft"
 	 and ippkt: "p_l2type p = 0x800"
 	 and ifvld: "p_iiface p \<in> set ifs"
 	shows "OF_priority_match OF_match_fields_safe oft p = Action [Forward oif] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = (Some (p\<lparr>p_oiface := oif\<rparr>))"
 	      "OF_priority_match OF_match_fields_safe oft p = Action [] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = None"
 	      (* fun stuff: *)
 	      "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction" "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined"
 	      "OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
 	      "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
 proof -
 	have s1: "valid_prefixes rt" "has_default_route rt" 
    and s2: "has_default_policy fw" "simple_fw_valid fw" "no_oif_match fw"
    and difs: "distinct ifs"
 	  using nerr unfolding lr_of_tran_def by(simp_all split: if_splits)
   have "no_oif_match fw" using nerr unfolding lr_of_tran_def by(simp split: if_splits)
   note s2 = s2 this
   have unsafe_safe_eq: 
     "OF_priority_match OF_match_fields_unsafe oft = OF_priority_match OF_match_fields_safe oft"
     "OF_match_linear OF_match_fields_unsafe oft = OF_match_linear OF_match_fields_safe oft"
     apply(subst OF_unsafe_safe_match3_eq; (rule lr_of_tran_prereqs s1 s2 nerr refl)+)
     apply(subst OF_unsafe_safe_match_linear_eq; (rule lr_of_tran_prereqs s1 s2 nerr refl)+)
   done
   have lin: "OF_priority_match OF_match_fields_safe oft = OF_match_linear OF_match_fields_safe oft"
     using OF_eq[OF lr_of_tran_no_overlaps lr_of_tran_sorted_descending, OF difs nerr[symmetric] nerr[symmetric]] unfolding fun_eq_iff unsafe_safe_eq by metis
   let ?ard = "map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs))"
   have oft_def: "oft = pack_OF_entries ifs ?ard" using nerr unfolding lr_of_tran_def Let_def by(simp split: if_splits)
   have vld: "list_all simple_match_valid (map (fst \<circ> snd) ?ard)"
     unfolding fun_app_def map_map[symmetric] snd_apfst map_snd_apfst map_snd_annotate_rlen using simple_match_valid_fbs[OF s1(1) s2(2)] .
   have *: "list_all (\<lambda>m. oiface (fst (snd m)) = ifaceAny) ?ard" using no_oif_match_fbs[OF s2(3)] .
   have not_undec: "\<And>p. simple_fw fw p \<noteq> Undecided" by (metis has_default_policy s2(1) state.simps(3))
   have w1_1: "\<And>oif. OF_match_linear OF_match_fields_safe oft p = Action [Forward oif] \<Longrightarrow> simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) 
     \<and> oif = output_iface (routing_table_semantics rt (p_dst p))"
   proof(intro conjI, goal_cases)
     case (1 oif)
     note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD1, unfolded oft_def[symmetric], OF 1]
     hence "\<exists>r. generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, (oif, simple_action.Accept))"
       by(clarsimp split: if_splits)
     then obtain r where "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, (oif, simple_action.Accept))" 
       unfolding map_map comp_def snd_apfst map_snd_annotate_rlen by blast
     thus ?case using lr_of_tran_fbs_acceptD[OF s1 s2(3)] by metis
     thus "oif = output_iface (routing_table_semantics rt (p_dst p))"
       by(cases p) (clarsimp simp: simple_linux_router_nol12_def Let_def not_undec split: Option.bind_splits state.splits final_decision.splits) 
   qed
   have w1_2: "\<And>oif. simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>) \<Longrightarrow> OF_match_linear OF_match_fields_safe oft p = Action [Forward oif]"
   proof(goal_cases)
     case (1 oif)
     note lr_of_tran_fbs_acceptI[OF s1 s2(3) s2(1) this, of ifs] then guess r .. note r = this
     hence "generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, (oif, simple_action.Accept))" 
     unfolding map_snd_apfst map_snd_annotate_rlen .
     moreover note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD2, unfolded oft_def[symmetric], of "[Forward oif]"]
     ultimately show ?case by simp
   qed
   show w1: "\<And>oif. (OF_priority_match OF_match_fields_safe oft p = Action [Forward oif]) = (simple_linux_router_nol12 rt fw p = Some (p\<lparr>p_oiface := oif\<rparr>))"
     unfolding lin using w1_1 w1_2 by blast
   show w2: "(OF_priority_match OF_match_fields_safe oft p = Action []) = (simple_linux_router_nol12 rt fw p = None)"
   unfolding lin
   proof(rule iffI, goal_cases)
     case 1
     note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD1, unfolded oft_def[symmetric], OF 1]
     then obtain r oif where roif: "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)"
       unfolding map_snd_apfst map_snd_annotate_rlen by(clarsimp split: if_splits)
     note lr_of_tran_fbs_dropD[OF s1 s2(3) this]
     thus ?case .
   next
     case 2 
     note lr_of_tran_fbs_dropI[OF s1 s2(3) s2(1) this, of ifs] then 
     obtain r oif where "generalized_sfw (lr_of_tran_fbs rt fw ifs) p = Some (r, oif, simple_action.Drop)" by blast
     hence "generalized_sfw (map snd (map (apfst of_nat) (annotate_rlen (lr_of_tran_fbs rt fw ifs)))) p = Some (r, oif, simple_action.Drop)" 
       unfolding map_snd_apfst map_snd_annotate_rlen .
     moreover note s3_correct[OF vld ippkt ifvld(1) *, THEN iffD2, unfolded oft_def[symmetric], of "[]"]
     ultimately show ?case by force
   qed
   have lr_determ: "\<And>a. simple_linux_router_nol12 rt fw p = Some a \<Longrightarrow> a = p\<lparr>p_oiface := output_iface (routing_table_semantics rt (p_dst p))\<rparr>"
     by(clarsimp simp: simple_linux_router_nol12_def Let_def not_undec split: Option.bind_splits state.splits final_decision.splits)
   show notno: "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction"
     apply(cases "simple_linux_router_nol12 rt fw p")
     using w2 apply(simp)
     using w1[of "output_iface (routing_table_semantics rt (p_dst p))"] apply(simp)
     apply(drule lr_determ)
     apply(simp)
   done
   show notub: "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined" unfolding lin using OF_match_linear_ne_Undefined .
   show notmult: "\<And>ls. OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
   apply(cases "simple_linux_router_nol12 rt fw p")
     using w2 apply(simp)
     using w1[of "output_iface (routing_table_semantics rt (p_dst p))"] apply(simp)
     apply(drule lr_determ)
     apply(clarsimp)
   done
   show "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
     apply(cases "OF_priority_match OF_match_fields_safe oft p")
     using notmult apply blast
     using notno   apply blast
     using notub   apply blast
   done
 qed
 
 end
diff --git a/thys/LOFT/OpenFlow_Documentation.thy b/thys/LOFT/OpenFlow_Documentation.thy
--- a/thys/LOFT/OpenFlow_Documentation.thy
+++ b/thys/LOFT/OpenFlow_Documentation.thy
@@ -1,533 +1,533 @@
 text_raw\<open>
 \twocolumn
 \columnsep 2pc          %    Space between columns
 \textwidth 42pc         % Width of text line.
 \part{Documentation}
 \label{part2}
 \<close>
 section\<open>Configuration Translation\<close>
 text_raw\<open>\label{sec:conv}\<close>
 text\<open>
 All the results we present in this section are formalized and verified in Isabelle/HOL~\cite{nipkow2002isabelle}.
 This means that their formal correctness can be trusted a level close to absolute certainty.
 The definitions and lemmas stated here are merely a repetition of lemmas stated in other theory files.
 This means that they have been directly set to this document from Isabelle and no typos or hidden assumptions are possible.
 Additionally, it allows us to omit various helper lemmas that do not help the understanding.
 However, it causes some notation inaccuracy, as type and function definitions are stated as lemmas or schematic goals.
 \<close>
 theory OpenFlow_Documentation
 (*<*)
 imports 
   LinuxRouter_OpenFlow_Translation 
   Featherweight_OpenFlow_Comparison
   "HOL-Library.LaTeXsugar"
 begin
 (*>*)
 
 subsection\<open>Linux Firewall Model\<close>
 text_raw\<open>\label{sec:lfw}\<close>
 text\<open>We want to write a program that translates the configuration of a linux firewall to that of an OpenFlow switch.
 We furthermore want to verify that translation.
 For this purpose, we need a clear definition of the behavior of the two device types -- we need their models and semantics.
 In case of a linux firewall, this is problematic because a linux firewall is a highly complex device that is ultimately capable of general purpose computation.
 Creating a comprehensive semantics that encompasses all possible configuration types of a linux firewall is thus 
 highly non-trivial and not useful for the purpose of analysis.
 We decided to approach the problem from the other side: we created a model that includes only the most basic features. (This implies neglecting IPv6.)
 Fortunately, many of the highly complex features are rarely essential and even our basic model is still of some use.
 \<close>
 
 text\<open>We first divided the firewall into subsystems.
 Given a routing table @{term rt}, the firewall rules @{term fw},
   the routing decision for a packet @{term p} can be obtained by @{term "routing_table_semantics rt (p_dst p)"}, 
   the firewall decision by @{term "simple_fw fw p"}.
 We draft the first description of our linux router model:
 \begin{enumerate}
   \item The destination MAC address of an arriving packet is checked: Does it match the MAC address of the ingress port? 
   If it does, we continue, otherwise, the packet is discarded.
   \item The routing decision @{term "rd \<equiv> routing_table_semantics rt p"} is obtained.
   \item The packet's output interface is updated based on @{term rd}\footnote{Note that we assume a packet model with input and output interfaces. The origin of this is explained in Section~\ref{sec:lfwfw}}.
   \item The firewall is queried for a decision: @{term "simple_fw fw p"}. If the decision is to @{const[names_short] simple_action.Drop}, the packet is discarded.
   \item The next hop is computed: If @{term rd} provides a next hop, that is used. 
     Otherwise, the destination address of the packet is used.
   \item The MAC address of the next hop is looked up; the packet is updated with it and sent.
 \end{enumerate}
 We decided that this description is best formalized as an abortable program in the option monad:\<close>
 lemma "simple_linux_router rt fw mlf ifl p \<equiv> do {
 	_ \<leftarrow> iface_packet_check ifl p;
 	let rd \<comment> \<open>(routing decision)\<close> = routing_table_semantics rt (p_dst p);
 	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
 	let fd \<comment> \<open>(firewall decision)\<close> = simple_fw fw p;
 	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
 	let nh = (case next_hop rd of None \<Rightarrow> p_dst p | Some a \<Rightarrow> a);
 	ma \<leftarrow> mlf nh;
 	Some (p\<lparr>p_l2dst := ma\<rparr>)
 }" 
 unfolding fromMaybe_def[symmetric] by(fact simple_linux_router_def)
 text\<open>where @{term "mlf :: ipv4addr \<Rightarrow> 48 word"} is a function that looks up the MAC address for an IP address.\<close>
 
 text\<open>There are already a few important aspects that have not been modelled, but they are not core essential for the functionality of a firewall.
 Namely, there is no local traffic from/to the firewall.
 This is problematic since this model can not generate ARP replies --- thus, an equivalent OpenFlow device will not do so, either.
 Furthermore, this model is problematic because it requires access to a function that looks up a MAC address, 
 something that may not be known at the time of time running a translation to an OpenFlow configuration.
 \<close>
 text\<open>It is possible to circumvent these problems by inserting static ARP table entries in the directly connected devices 
 and looking up their MAC addresses \emph{a priori}. 
 A test-wise implementation of the translation based on this model showed acceptable results.
 However, we deemed the \emph{a priori} lookup of the MAC addresses to be rather inelegant and built a second model.\<close>
 definition "simple_linux_router_altered rt fw ifl p \<equiv> do {
 	let rd = routing_table_semantics rt (p_dst p);
 	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
 		_ \<leftarrow> if p_oiface p = p_iiface p then None else Some ();
 	let fd = simple_fw fw p;
 	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
 	Some p
 }"
 (* TODO: Would a router actually forward a packet on the same interface? *)
 text\<open>In this model, all access to the MAC layer has been eliminated.
 This is done by the approximation that the firewall will be asked to route a packet 
 (i.e. be addressed on the MAC layer) iff the destination IP address of the packet causes it to be routed out on a different interface.
 Because this model does not insert destination MAC addresses, the destination MAC address has to be already correct when the packet is sent.
 This can only be achieved by changing the subnet of all connected device, moving them into one common subnet\footnote{There are cases where this is not possible --- A limitation of our system.}.
 \<close>
 text\<open>
 While a test-wise implementation based on this model also showed acceptable results, the model is still problematic.
 The check @{term "p_oiface p = p_iiface p"} and the firewall require access to the output interface.
 The details of why this cannot be provided are be elaborated in Section~\ref{sec:convi}. 
 The intuitive explanation is that an OpenFlow match can not have a field for the output interface.
 We thus simplified the model even further:
 \<close>
 lemma "simple_linux_router_nol12 rt fw p \<equiv> do {
 	let rd = routing_table_semantics rt (p_dst p);
 	let p = p\<lparr>p_oiface := output_iface rd\<rparr>;
 	let fd = simple_fw fw p;
 	_ \<leftarrow> (case fd of Decision FinalAllow \<Rightarrow> Some () | Decision FinalDeny \<Rightarrow> None);
 	Some p
 }" by(fact simple_linux_router_nol12_def)
 text\<open>We continue with this definition as a basis for our translation.
 Even this strongly altered version and the original linux firewall still behave the same in a substantial amount of cases:\<close>
 theorem
 	"\<lbrakk>iface_packet_check ifl pii \<noteq> None;
 	mlf (case next_hop (routing_table_semantics rt (p_dst pii)) of None \<Rightarrow> p_dst pii | Some a \<Rightarrow> a) \<noteq> None\<rbrakk> \<Longrightarrow>
 	\<exists>x. map_option (\<lambda>p. p\<lparr>p_l2dst := x\<rparr>) (simple_linux_router_nol12 rt fw pii) = simple_linux_router rt fw mlf ifl pii"
 by(fact rtr_nomac_eq[unfolded fromMaybe_def])
 text\<open>The conditions are to be read as ``The check whether a received packet has the correct destination MAC never returns @{const False}'' and 
 ``The next hop MAC address for all packets can be looked up''.
 Obviously, these conditions do not hold for all packets. 
 We will show an example where this makes a difference in Section~\ref{sec:mnex}.\<close>
 
 subsubsection\<open>Routing Table\<close>
 text_raw\<open>\label{sec:lfwr}\<close>
 text\<open>
 The routing system in linux features multiple tables and a system that can use the iptables firewall and an additional match language to select a routing table.
 Based on our directive, we only focused on the single most used \texttt{main} routing table.\<close>
 text\<open>
 We define a routing table entry to be a record (named tuple) of a prefix match, a metric and the routing action, which in turn is a record of an output interface and an optional next-hop address.\<close>
 schematic_goal "(?rtbl_entry :: ('a::len) routing_rule) = \<lparr> routing_match = PrefixMatch pfx len, metric = met, routing_action = \<lparr> output_iface = oif_string, next_hop = (h :: 'a word option) \<rparr> \<rparr>" ..
 text\<open>A routing table is then a list of these entries:\<close>
 lemma "(rtbl :: ('a :: len) prefix_routing) = (rtbl :: 'a routing_rule list)" by rule
 text\<open>Not all members of the type @{type prefix_routing} are sane routing tables. There are three different validity criteria that we require so that our definitions are adequate.
 \begin{itemize}
   \item The prefixes have to be 0 in bits exceeding their length.
   \item There has to be a default rule, i.e. one with prefix length 0. With the condition above, that implies that all its prefix bits are zero and it thus matches any address.
   \item The entries have to be sorted by prefix length and metric.
 \end{itemize}
 The first two are set into code in the following way:
 \<close>
 lemma "valid_prefix (PrefixMatch pfx len) \<equiv> pfx && (2 ^ (32 - len) - 1) = (0 :: 32 word)" 
   by (simp add: valid_prefix_def pfxm_mask_def mask_eq_decr_exp and.commute)
 lemma "has_default_route rt \<longleftrightarrow> (\<exists>r \<in> set rt. pfxm_length (routing_match r) = 0)" 
 by(fact has_default_route_alt)
 text\<open>The third is not needed in any of the further proofs, so we omit it.\<close>
 
 text\<open>The semantics of a routing table is to simply traverse the list until a matching entry is found.\<close>
 schematic_goal "routing_table_semantics (rt_entry # rt) dst_addr = (if prefix_match_semantics (routing_match rt_entry) dst_addr then routing_action rt_entry else routing_table_semantics rt dst_addr)" by(fact routing_table_semantics.simps)
 text\<open>If no matching entry is found, the behavior is undefined.\<close>
 
 subsubsection\<open>iptables Firewall\<close>
 text_raw\<open>\label{sec:lfwfw}\<close>
 text\<open>The firewall subsystem in a linux router is not any less complex than any of the of the other systems.
 Fortunately, this complexity has been dealt with in~\cite{diekmann2016verified,Iptables_Semantics-AFP} already and we can directly use the result.\<close>
 text\<open>In short, one of the results is that a complex \emph{iptables} configuration can be simplified to be represented by a single list of matches that only support the following match conditions:
 \begin{itemize}
   \item (String) prefix matches on the input and output interfaces.
   \item A @{type prefix_match} on the source and destination IP address.
   \item An exact match on the layer 4 protocol.
   \item Interval matches on the source or destination port, e.g. @{term "p\<^sub>d \<in> {(1::16 word)..1023}"}
 \end{itemize}
 The model/type of the packet is adjusted to fit that: it is a record of the fields matched on.
 This also means that input and output interface are coded to the packet.
 Given that this information is usually stored alongside the packet content, this can be deemed a reasonable model.
 In case the output interface is not needed (e.g., when evaluating an OpenFlow table), it can simply be left blank.
 
 Obviously, a simplification into the above match type cannot always produce an equivalent firewall, and the set of accepted packets has to be over- or underapproximated.
 The reader interested in the details of this is strongly referred to~\cite{diekmann2016verified}; we are simply going to continue with the result: @{const simple_fw}.
 \<close>
 text\<open>One property of the simplification is worth noting here: The simplified firewall does not know state and the simplification approximates stateful matches by stateless ones. 
 Thus, the overapproximation of a stateful firewall ruleset that begins with accepting packets of established connections usually begins with a rule that accepts all packets.
 Dealing with this by writing a meaningful simplification of stateful firewalls is future work.
 \<close>
 
 subsection\<open>OpenFlow Switch Model\<close>
 text\<open>In this section, we present our model of an OpenFlow switch.
 The requirements for this model are derived from the fact that it models devices that are the target of a configuration translation.
 This has two implications:
 \begin{itemize}
 \item All configurations that are representable in our model should produce the correct behavior wrt. their semantics.
   The problem is that correct here means that the behavior is the same that any real device would produce.
   Since we cannot possibly account for all device types, we instead focus on those that conform to the OpenFlow specifications.
   To account for the multiple different versions of the specification (e.g.~\cite{specification10,specification15}), we tried making our model a subset of 
   both the oldest stable version 1.0~\cite{specification10} and the newest available specification version 1.5.1~\cite{specification15}.
 \item Conversely, our model does not need to represent all possible behavior of an OpenFlow switch, just the behavior that can be invoked by the result of our translation.
   This is especially useful regarding for controller interaction, but also for MPLS or VLANs, which we did not model in Section \ref{sec:lfw}.
 \end{itemize}\<close>
 
 text\<open>More concretely, we set the following rough outline for our model.
 \begin{itemize}
   \item A switch consists of a single flow table.
   \item A flow table entry consists of a priority, a match condition and an action list.
   \item The only possible action (we require) is to forward the packet on a port.
   \item We do not model controller interaction.
 \end{itemize}
 Additionally, we decided that we wanted to be able to ensure the validity of the flow table in all qualities,
 i.e. we want to model the conditions `no overlapping flow entries appear', `all match conditions have their necessary preconditions'.
 The details of this are explained in the following sections.
 \<close>
 
 subsubsection\<open>Matching Flow Table entries\<close>
 text_raw\<open>\label{sec:of_match}\<close>
 text\<open>Table 3 of Section 3.1 of \cite{specification10} gives a list of required packet fields that can be used to match packets.
 This directly translates into the type for a match expression on a single field:\<close>
 
 schematic_goal "(field_match :: of_match_field) \<in> {
   IngressPort (?s::string),
   EtherSrc (?as::48 word), EtherDst (?ad::48 word),
 	EtherType (?t::16 word),
 	VlanId (?i::16 word), VlanPriority (?p::16 word),
 	IPv4Src (?pms::32 prefix_match), 
 	IPv4Dst (?pmd::32 prefix_match),
 	IPv4Proto (?ipp :: 8 word),
 	L4Src (?ps :: 16 word) (?ms :: 16 word),
 	L4Dst (?pd :: 16 word) (?md :: 16 word)
 }" by(fact of_match_field_typeset)
 text\<open>
 Two things are worth additional mention: L3 and L4 ``addressess''.
 The @{term IPv4Src} and @{term IPv4Dst} matches are specified as ``can be subnet masked'' in~\cite{specification10}, 
   whereras~\cite{specification15} states clearly that arbitrary bitmasks can be used. We took the conservative approach here.
 Our alteration of @{term L4Src} and @{term L4Dst} is more grave. While~\cite{specification10} does not state anything about layer 4 ports and masks,
 \cite{specification15} specifically forbids using masks on them. 
 Nevertheless, OpenVSwitch \cite{openvswitch} and some other implementations support them.
 We will explain in detail why we must include bitmasks on layer 4 ports to obtain a meaningful translation in Section~\ref{sec:convi}.\<close>
 
 text\<open>One @{type of_match_field} is not enough to classify a packet. 
 To match packets, we thus use entire sets of match fields.
 As Guha \emph{et al.}~\cite{guha2013machine} noted\footnote{See also: \cite[\<section>2.3]{michaelis2016middlebox}}, executing a set of given @{type of_match_field}s on a packet requires careful consideration.
 For example, it is not meaningful to use @{term IPv4Dst} if the given packet is not actually an IP packet, i.e.
 @{term IPv4Dst} has the prerequisite of @{term "EtherType 0x0800"} being among the match fields.
 Guha \emph{et al.} decided to use the fact that the preconditions can be arranged on a directed acyclic graph (or rather: an acyclic forest).
 They evaluated match conditions in a manner following that graph:
 first, all field matches without preconditions are evaluated.
 Upon evaluating a field match (e.g., @{term "EtherType 0x0800"}), the matches that had their precondition fulfilled by it
   (e.g., @{term IPv4Src} and @{term IPv4Src} in this example) are evalutated.
 This mirrors the faulty behavior of some implementations (see \cite{guha2013machine}).
 Adopting that behavior into our model would mean that any packet matches against the field match set @{term "{IPv4Dst (PrefixMatch 134744072 32)}"} 
 instead of just those destined for 8.8.8.8 or causing an error. We found this to be unsatisfactory.\<close>
 
 text\<open>To solve this problem, we made three definitions.
 The first, @{term match_no_prereq} matches an @{type of_match_field} against a packet without considering prerequisites.
 The second, @{term prerequisites}, checks for a given @{type of_match_field} whether its prerequisites are in a set of given match fields.
 Especially:
 \<close>
 lemma 
   "prerequisites (VlanPriority pri) m = (\<exists>id. let v = VlanId id in v \<in> m \<and> prerequisites v m)"
   "prerequisites (IPv4Proto pr) m = (let v = EtherType 0x0800 in v \<in> m \<and> prerequisites v m)"
   "prerequisites (IPv4Src a) m = (let v = EtherType 0x0800 in v \<in> m \<and> prerequisites v m)"
   "prerequisites (IPv4Dst a) m = (let v = EtherType 0x0800 in v \<in> m \<and> prerequisites v m)"
   "prerequisites (L4Src p msk) m = (\<exists>proto \<in> {TCP,UDP,L4_Protocol.SCTP}. let v = IPv4Proto proto in v \<in> m \<and> prerequisites v m)"
   "prerequisites (L4Dst p msk) m = prerequisites (L4Src undefined undefined) m"
   by(fact prerequisites.simps)+
 text\<open>Then, to actually match a set of @{type of_match_field} against a packet, we use the option type:\<close>
 lemma "OF_match_fields m p =
   (if \<exists>f \<in> m. \<not>prerequisites f m then None else 
     if \<forall>f \<in> m. match_no_prereq f p then Some True else Some False)"
 by(fact OF_match_fields_alt)
 
 subsubsection\<open>Evaluating a Flow Table\<close>
 text\<open>In the previous section, we explained how we match the set of match fields belonging to a single flow entry against a packet.
 This section explains how the correct flow entry from a table can be selected.
 To prevent to much entanglement with the previous section, we assume an arbitrary match function @{term "\<gamma> :: 'match_field set \<Rightarrow> 'packet \<Rightarrow> bool"}.
 This function @{term "\<gamma>"} takes the match condition @{term m} from a flow entry @{term "OFEntry (priority::16 word) (m::'match_field set) action"}
 and decides whether a packet matches those.\<close>
 
 text\<open>The flow table is simply a list of flow table entries @{type flow_entry_match}.
 Deciding the right flow entry to use for a given packet is explained in the OpenFlow specification \cite{specification10}, Section 3.4:
 \begin{quote}
   Packets are matched against flow entries based on prioritization. 
   An entry that specifies an exact match (i.e., has no wildcards) is always the highest priority\footnote{This behavior has been deprecated.}.
   All wildcard entries have a priority associated with them. 
   Higher priority entries must match before lower priority ones.
   If multiple entries have the same priority, the switch is free to choose any ordering.
 \end{quote}
 We use the term ``overlapping'' for  the flow entries that can cause a packet to match multiple flow entries with the same priority.
 Guha \emph{et al.}~\cite{guha2013machine} have dealt with overlapping.
 However, the semantics for a flow table they presented \cite[Figure 5]{guha2013machine}
   is slightly different from what they actually used in their theory files.
 We have tried to reproduce the original inductive definition (while keeping our abstraction @{term \<gamma>}),
  in Isabelle/HOL\footnote{The original is written in Coq~\cite{barras1997coq} and we can not use it directly.}:\<close>
 lemma "\<gamma> (ofe_fields fe) p = True \<Longrightarrow>
  \<forall>fe' \<in> set (ft1 @ ft2). ofe_prio fe' > ofe_prio fe \<longrightarrow> \<gamma> (ofe_fields fe') p = False \<Longrightarrow> 
  guha_table_semantics \<gamma> (ft1 @ fe # ft2) p (Some (ofe_action fe))" 
  "\<forall>fe \<in> set ft. \<gamma> (ofe_fields fe) p = False \<Longrightarrow>
  guha_table_semantics \<gamma> ft p None" by(fact guha_matched guha_unmatched)+
 text\<open>Guha \emph{et al.} have deliberately made their semantics non-deterministic, to match the fact that the switch ``may choose any ordering''.
 This can lead to undesired results:\<close>
 lemma "CARD('action) \<ge> 2 \<Longrightarrow> \<exists>ff. \<gamma> ff p \<Longrightarrow> \<exists>ft (a1 :: 'action) (a2 :: 'action). a1 \<noteq> a2 \<and> guha_table_semantics \<gamma> ft p (Some a1) \<and> guha_table_semantics \<gamma> ft p (Some a2)"
 by(fact guha_table_semantics_ex2res)
 text\<open>This means that, given at least two distinct actions exist and our matcher @{term \<gamma>} is not false for all possible match conditions, 
 we can say that a flow table and two actions exist such that both actions are executed. This can be misleading, as the switch might choose an 
 ordering on some flow table and never execute some of the (overlapped) actions.\<close>
 
 text\<open>Instead, we decided to follow Section 5.3 of the specification \cite{specification15}, which states:
 \begin{quote}
   If there are multiple matching flow entries, the selected flow entry is explicitly undefined.
 \end{quote}
 This still leaves some room for interpretation, but it clearly states that overlapping flow entries are undefined behavior, 
   and undefined behavior should not be invoked.
 Thus, we came up with a semantics that clearly indicates when undefined behavior has been invoked:\<close>
 lemma
   "OF_priority_match \<gamma> flow_entries packet = (
   let m  = filter (\<lambda>f. \<gamma> (ofe_fields f) packet) flow_entries;
   	  m' = filter (\<lambda>f. \<forall>fo \<in> set m. ofe_prio fo \<le> ofe_prio f) m in
   	case m' of []  \<Rightarrow> NoAction
              | [s] \<Rightarrow> Action (ofe_action s)
              |  _  \<Rightarrow> Undefined)"
 unfolding OF_priority_match_def ..
 text\<open>The definition works the following way\footnote{Note that the order of the flow table entries is irrelevant. 
 We could have made this definition on sets but chose not to for consistency.}:
 \begin{enumerate}
   \item The flow table is filtered for those entries that match, the result is called $m$.
   \item $m$ is filtered again, leaving only those entries for which no entries with lower priority could be found, i.e. the matching flow table entries with minimal priority. The result is called $m'$.
   \item A case distinction on $m'$ is made. If only one matching entry was found, its action is returned for execution. 
   If $m$ is empty, the flow table semantics returns @{term NoAction} to indicate that the flow table does not decide an action for the packet.
   If,  not zero or one entry is found, but more, the special value @{term Undefined} for indicating undefined behavior is returned.
 \end{enumerate}
 The use of @{term Undefined} immediately raises the question in which condition it cannot occur.
 We give the following definition:\<close>
 lemma "check_no_overlap \<gamma> ft = (\<forall>a \<in> set ft. \<forall>b \<in> set ft. (a \<noteq> b \<and> ofe_prio a = ofe_prio b) \<longrightarrow> \<not>(\<exists>p. \<gamma> (ofe_fields a) p \<and> \<gamma> (ofe_fields b) p))" unfolding check_no_overlap_alt check_no_overlap2_def by force
 text\<open>Together with distinctness of the flow table, this provides the abscence of @{term Undefined}\footnote{It is slightly stronger than necessary, overlapping rules might be shadowed and thus never influence the behavior.}:\<close>
 lemma "\<lbrakk>check_no_overlap \<gamma> ft; distinct ft\<rbrakk> \<Longrightarrow>
   OF_priority_match \<gamma> ft p \<noteq> Undefined" by (simp add: no_overlapsI no_overlaps_not_unefined)
 
 text\<open>Given the absence of overlapping or duplicate flow entries, we can show two interesting equivalences.
 the first is the equality to the semantics defined by Guha \emph{et al.}:\<close>
 lemma "\<lbrakk>check_no_overlap \<gamma> ft; distinct ft\<rbrakk> \<Longrightarrow> 
 OF_priority_match \<gamma> ft p = option_to_ftb d \<longleftrightarrow> guha_table_semantics \<gamma> ft p d"
 by (simp add: guha_equal no_overlapsI)
 text\<open>where @{term option_to_ftb} maps between the return type of @{term OF_priority_match} and an option type as one would expect.\<close>
 
 text\<open>The second equality for @{term OF_priority_match} is one that helps reasoning about flow tables.
 We define a simple recursive traversal for flow tables:\<close>
 lemma
   "OF_match_linear \<gamma> [] p = NoAction"
   "OF_match_linear \<gamma> (a#as) p = (if \<gamma> (ofe_fields a) p then Action (ofe_action a) else OF_match_linear \<gamma> as p)"
 by(fact OF_match_linear.simps)+
 text\<open>For this definition to be equivalent, we need the flow table to be sorted:\<close>
 lemma"
 	\<lbrakk>no_overlaps \<gamma> f ;sorted_descending (map ofe_prio f)\<rbrakk> \<Longrightarrow>
 	OF_match_linear \<gamma> f p = OF_priority_match \<gamma> f p"
 by(fact  OF_eq)
 
 text\<open>As the last step, we implemented a serialization function for flow entries; it has to remain unverified.
 The serialization function deals with one little inaccuracy: We have modelled the @{term IngressPort} match to use the interface name, but OpenFlow requires numerical interface IDs instead.
 We deemed that pulling this translation step into the main translation would only make the correctness lemma of the translation more complicated while not increasing the confidence in the correctness significantly.
 We thus made replacing interface names by their ID part of the serialization.
 \<close>
 
 text\<open>Having collected all important definitions and models, we can move on to the conversion.\<close>
 (*text\<open>\todo{Maybe I should make a sweet little subsection that merges this all into a single model definition.}\<close>*)
 
 subsection\<open>Translation Implementation\<close>
 text_raw\<open>\label{sec:convi}\<close>
 text\<open>This section explains how the functions that are executed sequentially in a linux firewall can be compressed into a single OpenFlow table.
 Creating this flow table in a single step would be immensely complicated.
 We thus divided the task into several steps using the following key insights:
 \begin{itemize}
   \item All steps that are executed in the linux router can be formulated as a firewall, more specifically, a generalization of @{term simple_fw} that allows arbitrary actions instead of just accept and drop.
   \item A function that computes the conjunction of two @{term simple_fw} matches is already present.
     Extending this to a function that computes the join of two firewalls is relatively simple. This is explained in Section \ref{sec:fwconj}
 \end{itemize}
 \<close>
 subsubsection\<open>Chaining Firewalls\<close>
 text_raw\<open>\label{sec:fwconj}\<close>
 text\<open>This section explains how to compute the join of two firewalls.\<close>
 text\<open>The basis of this is a generalization of @{const simple_fw}.
 Instead of only allowing @{const simple_action.Accept} or @{const simple_action.Drop} as actions, it allows arbitrary actions. The type of the function that evaluates this generalized simple firewall is
 @{term "generalized_sfw :: ('i::len simple_match \<times> 'a) list \<Rightarrow> ('i, 'b) simple_packet_scheme \<Rightarrow> ('i simple_match \<times> 'a) option"}.
 The definition is straightforward:\<close>
 lemma 
 "generalized_sfw [] p = None" 
 "generalized_sfw (a # as) p = (if (case a of (m,_) \<Rightarrow> simple_matches m p) then Some a else generalized_sfw as p)"
 	by(fact generalized_sfw_simps)+
 text\<open>Based on that, we asked: if @{term fw\<^sub>1} makes the decision @{term a} (where @{term a} is the second element of the result tuple from @{const generalized_sfw}) and @{term fw\<^sub>2} makes the decision @{term b}, how can we compute the firewall that
 makes the decision @{term "(a,b)"}\footnote{Note that tuples are right-associative in Isabelle/HOL, i.e., @{term "(a::'a,(b,c)::('b\<times>'c))"} is a pair of @{term a} and the pair @{term "(b,c)"}}.
 One possible answer is given by the following definition:
 \<close>
 lemma "generalized_fw_join l1 l2 \<equiv> [(u,a,b). (m1,a) \<leftarrow> l1, (m2,b) \<leftarrow> l2, u \<leftarrow> (case simple_match_and m1 m2 of None \<Rightarrow> [] | Some s \<Rightarrow> [s])]"
 by(fact generalized_fw_join_def[unfolded option2list_def])+
 text\<open>This definition validates the following lemma:\<close>
 lemma "generalized_sfw (generalized_fw_join fw\<^sub>1 fw\<^sub>2) p = Some (u, d\<^sub>1,d\<^sub>2) \<longleftrightarrow> (\<exists>r\<^sub>1 r\<^sub>2. generalized_sfw fw\<^sub>1 p = Some (r\<^sub>1,d\<^sub>1) \<and> generalized_sfw fw\<^sub>2 p = Some (r\<^sub>2,d\<^sub>2) \<and> Some u = simple_match_and r\<^sub>1 r\<^sub>2)"
-  by(force dest: generalized_fw_joinD generalized_fw_joinI intro: Some_to_the[symmetric])
+  by (auto dest: generalized_fw_joinD sym simp add: generalized_fw_joinI)
 text\<open>Thus, @{const generalized_fw_join} has a number of applications.
 For example, it could be used to compute a firewall ruleset that represents two firewalls that are executed in sequence.
 \<close>
 definition "simple_action_conj a b \<equiv> (if a = simple_action.Accept \<and> b = simple_action.Accept then simple_action.Accept else simple_action.Drop)"
 definition "simple_rule_conj \<equiv> (uncurry SimpleRule \<circ> apsnd (uncurry simple_action_conj))"
 theorem "simple_fw rs\<^sub>1 p = Decision FinalAllow \<and> simple_fw rs\<^sub>2 p = Decision FinalAllow \<longleftrightarrow>
 simple_fw (map simple_rule_conj (generalized_fw_join (map simple_rule_dtor rs\<^sub>1) (map simple_rule_dtor rs\<^sub>2))) p = Decision FinalAllow"
 unfolding simple_rule_conj_def simple_action_conj_def[abs_def] using simple_fw_join by(force simp add: comp_def apsnd_def map_prod_def case_prod_unfold uncurry_def[abs_def])
 text\<open>Using the join, it should be possible to compute any $n$-ary logical operation on firewalls.
 We will use it for something somewhat different in the next section.\<close>
 
 subsubsection\<open>Translation Implementation\<close>
 
 text_raw\<open>
 \begin{figure*}
 \begin{framed}
 \<close>
 lemma "lr_of_tran rt fw ifs \<equiv> 
 if \<not> (no_oif_match fw \<and> has_default_policy fw \<and> simple_fw_valid fw	\<and> valid_prefixes rt \<and> has_default_route rt \<and> distinct ifs)
   then Inl ''Error in creating OpenFlow table: prerequisites not satisifed''
   else (
 let
   nfw = map simple_rule_dtor fw; 
   frt = map (\<lambda>r. (route2match r, output_iface (routing_action r))) rt; 
   nrd = generalized_fw_join frt nfw;
   ard = (map (apfst of_nat) \<circ> annotate_rlen) nrd
   in
   if length nrd < unat (max_word :: 16 word)
   then Inr (pack_OF_entries ifs ard)
   else Inl ''Error in creating OpenFlow table: priority number space exhausted''
 )"
 unfolding Let_def lr_of_tran_def lr_of_tran_fbs_def lr_of_tran_s1_def comp_def route2match_def by force
 
 text_raw\<open>
   \end{framed}
   \caption{Function for translating a @{typ "'i::len simple_rule list"}, a @{typ "'i routing_rule list"}, and a list of interfaces to a flow table.}
   \label{fig:convi}
 \end{figure*}
 \<close>
 
 text\<open>
 This section shows the actual definition of the translation function, in Figure~\ref{fig:convi}.
 Before beginning the translation, the definition checks whether the necessary preconditions are valid.
 This first two steps are to convert @{term fw} and @{term rt} to lists that can be evaluated by @{const generalized_sfw}.
 For @{term fw}, this is done by @{term "map simple_rule_dtor"}, which just deconstructs @{type simple_rule}s into tuples of match and action.
 For @{term rt}, we made a firewall ruleset with rules that use prefix matches on the destination IP address.
 The next step is to join the two rulesets.
  The result of the join is a ruleset with rules @{term r} that only match if both, the corresponding firewall rule @{term fwr} and the corresponding routing rule @{term rr} matches.
 The data accompanying @{term r} is the port from @{term rr} and the firewall decision from @{term fwr}.
 Next, descending priorities are added to the rules using @{term "map (apfst word_of_nat) \<circ> annotate_rlen"}.
 If the number of rules is too large to fit into the $2^{16}$ priority classes, an error is returned.
 Otherwise, the function @{const pack_OF_entries} is used to convert the @{typ "(16 word \<times> 32 simple_match \<times> char list \<times> simple_action) list"} to an OpenFlow table.
 While converting the @{typ "char list \<times> simple_action"} tuple is straightforward, converting the @{type simple_match} to an equivalent list of @{typ "of_match_field set"} is non-trivial.
 This is done by the function @{const simple_match_to_of_match}.
 \<close>
 text\<open>The main difficulties for @{const simple_match_to_of_match} lie in making sure that the prerequisites are satisfied
  and in the fact that a @{type simple_match} operates on slightly stronger match expressions.
 \begin{itemize}
   \item A @{type simple_match} allows a (string) prefix match on the input and output interfaces.
     Given a list of existing interfaces on the router @{term ifs}, the function has to insert flow entries for each interface matching the prefix.
   \item A @{type simple_match} can match ports by an interval. Now it becomes obvious why Section~\ref{sec:of_match} added bitmasks to @{const L4Src} and @{const L4Dst}.
     Using the algorithm to split word intervals into intervals that can be represented by prefix matches from~\cite{diekmann2016verified},
       we can efficiently represent the original interval by a few (32 in the worst case) prefix matches and insert flow entries for each of them.%
       \footnote{It might be possible to represent the interval match more efficiently than a split into prefixes. However, that would produce overlapping matches (which is not a problem if we assing separate priorities) 
         and we did not have a verified implementation of an algorithm that does so.}
 \end{itemize}
 The following lemma characterizes @{const simple_match_to_of_match}:
 \<close>
 lemma simple_match_to_of_match:
 assumes
   "simple_match_valid r" 
   "p_iiface p \<in> set ifs" 
   "match_iface (oiface r) (p_oiface p)"
   "p_l2type p = 0x800"
 shows
   "simple_matches r p \<longleftrightarrow> (\<exists>gr \<in> set (simple_match_to_of_match r ifs). OF_match_fields gr p = Some True)"
 using assms simple_match_to_of_matchD simple_match_to_of_matchI by blast
 
 text\<open>The assumptions are to be read as follows:
 \begin{itemize}
   \item The match @{term r} has to be valid, i.e. it has to use @{const valid_prefix} matches, and it cannot use anything other than $0$-$65535$ for the port matches unless its protocol match ensures @{const TCP}, @{const UDP} or @{const L4_Protocol.SCTP}.
   \item @{const simple_match_to_of_match} cannot produce rules for packets that have input interfaces that are not named in the interface list.
   \item The output interface of @{term p} has to match the output interface match of @{term r}. This is a weakened formulation of @{term "oiface r = ifaceAny"}, since @{thm[display] match_ifaceAny[no_vars]}.
     We require this because OpenFlow field matches cannot be used to match on the output port --- they are supposed to match a packet and decide an output port.
   \item The @{type simple_match} type was designed for IP(v4) packets, we limit ourselves to them.
 \end{itemize}
 The conclusion then states that the @{type simple_match} @{term r} matches iff an element of the result of @{const simple_match_to_of_match} matches.
 The third assumption is part of the explanation why we did not use @{const simple_linux_router_altered}:
 @{const simple_match_to_of_match} cannot deal with output interface matches. 
 Thus, before passing a generalized simple firewall to @{const pack_OF_entries}, we would have to set the output ports to @{const ifaceAny}.
 A system replace output interface matches with destination IP addresses has already been formalized and will be published in a future version of \cite{Iptables_Semantics-AFP}.
 For now, we limit ourselves to firewalls that do not do output port matching, i.e., we require @{term "no_oif_match fw"}.
 \<close>
 
 text_raw\<open>\begin{figure*}
 \begin{framed}
 \<close>
 theorem
 fixes
   p :: "(32, 'a) simple_packet_ext_scheme"
 assumes
   "p_iiface p \<in> set ifs" and "p_l2type p = 0x800"
   "lr_of_tran rt fw ifs = Inr oft"
 shows
   "OF_priority_match OF_match_fields_safe oft p = Action [Forward oif] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = (Some (p\<lparr>p_oiface := oif\<rparr>))"
   "OF_priority_match OF_match_fields_safe oft p = Action [] \<longleftrightarrow> simple_linux_router_nol12 rt fw p = None"
   "OF_priority_match OF_match_fields_safe oft p \<noteq> NoAction" "OF_priority_match OF_match_fields_safe oft p \<noteq> Undefined"
   "OF_priority_match OF_match_fields_safe oft p = Action ls \<longrightarrow> length ls \<le> 1"
   "\<exists>ls. length ls \<le> 1 \<and> OF_priority_match OF_match_fields_safe oft p = Action ls"
 using assms lr_of_tran_correct by simp_all
 text_raw\<open>
 \end{framed}
 \caption{Central theorem on @{const lr_of_tran}}
 \label{fig:central}
 \end{figure*}
 \<close>
 
 text\<open>
 Given discussed properties, we present the central theorem for our translation in Figure~\ref{fig:central}.
 The first two assumptions are limitations on the traffic we make a statement about.
 Obviously, we will never see any packets with an input interface that is not in the interface list.
 Furthermore, we do not state anything about non-IPv4 traffic. (The traffic will remain unmatched in by the flow table, but we have not verified that.)
 The last assumption is that the translation does not return a run-time error.
 The translation will return a run-time error if the rules can not be assigned priorities from a 16 bit integer, 
 or when one of the following conditions on the input data is not satisifed:\<close>
 lemma "
   \<not> no_oif_match fw \<or> 
   \<not> has_default_policy fw \<or>
   \<not> simple_fw_valid fw	\<or>
   \<not> valid_prefixes rt \<or>
   \<not> has_default_route rt \<or>
   \<not> distinct ifs \<Longrightarrow> 
 \<exists>err. lr_of_tran rt fw ifs = Inl err" unfolding lr_of_tran_def by(simp split: if_splits)
 
 subsubsection\<open>Comparison to Exodus\<close>
 text\<open>
   We are not the first researchers to attempt automated static migration to SDN.
   The (only) other attempt we are aware of is \emph{Exodus} by Nelson \emph{et al.}~\cite{nelson2015exodus}.
 \<close>
 text\<open>
 There are some fundamental differences between Exodus and our work:
 \begin{itemize}
   \item Exodus focuses on Cisco IOS instead of linux.
   \item Exodus does not produce OpenFlow rulesets, but FlowLog~\cite{nelson2014tierless} controller programs.
   \item Exodus is not limited to using a single flow table.
   \item Exodus requires continuous controller interaction for some of its functions.
   \item Exodus attempts to support as much functionality as possible and has implemented support for dynamic routing, VLANs and NAT.
   \item Nelson \emph{et al.} reject the idea that the translation could or should be proven correct.
 \end{itemize}
 \<close>
 
 (*<*)
 end
 (*>*)
diff --git a/thys/Native_Word/Code_Target_Word_Base.thy b/thys/Native_Word/Code_Target_Word_Base.thy
--- a/thys/Native_Word/Code_Target_Word_Base.thy
+++ b/thys/Native_Word/Code_Target_Word_Base.thy
@@ -1,394 +1,393 @@
 (*  Title:      Code_Target_Word_Base.thy
     Author:     Andreas Lochbihler, ETH Zurich
 *)
 
 chapter \<open>Common base for target language implementations of word types\<close>
 
 theory Code_Target_Word_Base imports
   "HOL-Library.Word"
   "Word_Lib.Signed_Division_Word"
   Bits_Integer
 begin
 
 text \<open>More lemmas\<close>
 
 lemma div_half_nat:
   fixes x y :: nat
   assumes "y \<noteq> 0"
   shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
 proof -
   let ?q = "2 * (x div 2 div y)"
   have q: "?q = x div y - x div y mod 2"
     by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
   let ?r = "x - ?q * y"
   have r: "?r = x mod y + x div y mod 2 * y"
     by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)
 
   show ?thesis
   proof(cases "y \<le> x - ?q * y")
     case True
     with assms q have "x div y mod 2 \<noteq> 0" unfolding r
       by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1)) 
     hence "x div y = ?q + 1" unfolding q
       by simp
     moreover hence "x mod y = ?r - y"
       by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
     ultimately show ?thesis using True by(simp add: Let_def)
   next
     case False
     hence "x div y mod 2 = 0" unfolding r
       by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
     hence "x div y = ?q" unfolding q by simp
     moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
     ultimately show ?thesis using False by(simp add: Let_def)
   qed
 qed
 
 lemma div_half_word:
   fixes x y :: "'a :: len word"
   assumes "y \<noteq> 0"
   shows "(x div y, x mod y) = (let q = (x >> 1) div y << 1; r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
 proof -
   obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat x\<close>]) simp_all
   moreover obtain m where m: "y = of_nat m" "m < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat y\<close>]) simp_all
   ultimately have [simp]: \<open>unat (of_nat n :: 'a word) = n\<close> \<open>unat (of_nat m :: 'a word) = m\<close>
     by (transfer, simp add: take_bit_of_nat take_bit_nat_eq_self_iff)+
   let ?q = "(x >> 1) div y << 1"
   let ?q' = "2 * (n div 2 div m)"
   have "n div 2 div m < 2 ^ LENGTH('a)" using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
   hence q: "?q = of_nat ?q'" using n m
     by (auto simp add: shiftr_word_eq drop_bit_eq_div shiftl_t2n word_arith_nat_div uno_simps take_bit_nat_eq_self)
   from assms have "m \<noteq> 0" using m by -(rule notI, simp)
 
   from n have "2 * (n div 2 div m) < 2 ^ LENGTH('a)"
     by(metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
   moreover
   have "2 * (n div 2 div m) * m < 2 ^ LENGTH('a)" using n unfolding div_mult2_eq[symmetric]
     by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
   moreover have "2 * (n div 2 div m) * m \<le> n"
     by (metis div_mult2_eq dtle mult.assoc mult.left_commute)
   ultimately
   have r: "x - ?q * y = of_nat (n - ?q' * m)"
     and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
     using n m unfolding q
      apply (simp_all add: of_nat_diff)
     apply (subst of_nat_diff)
     apply (simp_all add: word_le_nat_alt take_bit_nat_eq_self unat_sub_if' unat_word_ariths)
     apply (cases \<open>2 \<le> LENGTH('a)\<close>)
     apply (simp_all add: unat_word_ariths take_bit_nat_eq_self)
     done
   then show ?thesis using n m div_half_nat [OF \<open>m \<noteq> 0\<close>, of n] unfolding q
     by (simp add: word_le_nat_alt word_div_def word_mod_def Let_def take_bit_nat_eq_self
       flip: zdiv_int zmod_int
       split del: if_split split: if_split_asm)
 qed
 
 lemma word_test_bit_set_bits: "(BITS n. f n :: 'a :: len word) !! n \<longleftrightarrow> n < LENGTH('a) \<and> f n"
   by (simp add: test_bit_eq_bit bit_set_bits_word_iff)
 
 lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. i !! n)"
   by (rule word_eqI) (auto simp add: word_test_bit_set_bits)
 
 lemma word_and_mask_or_conv_and_mask:
   "n !! index \<Longrightarrow> (n AND mask index) OR (1 << index) = n AND mask (index + 1)"
   for n :: \<open>'a::len word\<close>
 by(rule word_eqI)(auto simp add: word_ao_nth word_size nth_shiftl simp del: shiftl_1)
 
 lemma uint_and_mask_or_full:
   fixes n :: "'a :: len word"
   assumes "n !! (LENGTH('a) - 1)"
   and "mask1 = mask (LENGTH('a) - 1)"
   and "mask2 = 1 << LENGTH('a) - 1"
   shows "uint (n AND mask1) OR mask2 = uint n"
 proof -
   have "mask2 = uint (1 << LENGTH('a) - 1 :: 'a word)" using assms
     by (simp add: uint_shiftl word_size bintrunc_shiftl del: shiftl_1)
   hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (1 << LENGTH('a) - 1 :: 'a word))"
     by(simp add: uint_or)
   also have "\<dots> = uint (n AND mask (LENGTH('a) - 1 + 1))"
     using assms by(simp only: word_and_mask_or_conv_and_mask)
   also have "\<dots> = uint n" by simp
   finally show ?thesis .
 qed
 
 
 text \<open>Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.\<close>
 
 lemmas word_sdiv_def = sdiv_word_def
 lemmas word_smod_def = smod_word_def
 
 lemma [code]:
   "x sdiv y =
    (let x' = sint x; y' = sint y;
         negative = (x' < 0) \<noteq> (y' < 0);
         result = abs x' div abs y'
     in word_of_int (if negative then -result else result))"
   for x y :: \<open>'a::len word\<close>
   by (simp add: sdiv_word_def signed_divide_int_def sgn_if Let_def not_less not_le)
 
 lemma [code]:
   "x smod y =
    (let x' = sint x; y' = sint y;
         negative = (x' < 0);
         result = abs x' mod abs y'
     in word_of_int (if negative then -result else result))"
   for x y :: \<open>'a::len word\<close>
 proof -
   have *: \<open>k mod l = k - k div l * l\<close> for k l :: int
     by (simp add: minus_div_mult_eq_mod)
   show ?thesis
-    by (simp add: smod_word_def signed_modulo_int_def signed_divide_int_def * sgn_if) (simp add: signed_eq_0_iff)
+    by (simp add: smod_word_def signed_modulo_int_def signed_divide_int_def * sgn_if Let_def)
 qed
 
 text \<open>
   This algorithm implements unsigned division in terms of signed division.
   Taken from Hacker's Delight.
 \<close>
 
 lemma divmod_via_sdivmod:
   fixes x y :: "'a :: len word"
   assumes "y \<noteq> 0"
   shows
   "(x div y, x mod y) =
   (if 1 << (LENGTH('a) - 1) \<le> y then if x < y then (0, x) else (1, x - y)
    else let q = ((x >> 1) sdiv y) << 1;
             r = x - q * y
         in if r \<ge> y then (q + 1, r - y) else (q, r))"
 proof(cases "1 << (LENGTH('a) - 1) \<le> y")
   case True
   note y = this
   show ?thesis
   proof(cases "x < y")
     case True
     then have "x mod y = x"
       by transfer simp
     thus ?thesis using True y by(simp add: word_div_lt_eq_0)
   next
     case False
     obtain n where n: "y = of_nat n" "n < 2 ^ LENGTH('a)"
       by (rule that [of \<open>unat y\<close>]) simp_all
     have "unat x < 2 ^ LENGTH('a)" by(rule unat_lt2p)
     also have "\<dots> = 2 * 2 ^ (LENGTH('a) - 1)"
       by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
     also have "\<dots> \<le> 2 * n" using y n
       by transfer (simp add: push_bit_of_1 take_bit_eq_mod)
     finally have div: "x div of_nat n = 1" using False n
       by (simp add: word_div_eq_1_iff take_bit_nat_eq_self)
     moreover have "x mod y = x - x div y * y"
       by (simp add: minus_div_mult_eq_mod)
     with div n have "x mod y = x - y" by simp
     ultimately show ?thesis using False y n by simp
   qed
 next
   case False
   note y = this
   obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat x\<close>]) simp_all
   hence "int n div 2 + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
-    by (cases "LENGTH('a)")
-      (simp_all, simp only: of_nat_numeral [where ?'a = int, symmetric]
-      zdiv_int [symmetric] of_nat_power [symmetric])
+    by (cases \<open>LENGTH('a)\<close>)
+      (auto dest: less_imp_of_nat_less [where ?'a = int])
   with y n have "sint (x >> 1) = uint (x >> 1)"
     by (simp add: sint_uint sbintrunc_mod2p shiftr_div_2n take_bit_nat_eq_self)
   moreover have "uint y + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
     using y by (cases "LENGTH('a)")
       (simp_all add: not_le word_2p_lem word_size)
   then have "sint y = uint y"
     by (simp add: sint_uint sbintrunc_mod2p)
   ultimately show ?thesis using y
     apply (subst div_half_word [OF assms])
     apply (simp add: sdiv_word_def signed_divide_int_def flip: uint_div)
     done
 qed
 
 
 text \<open>More implementations tailored towards target-language implementations\<close>
 
 context
 includes integer.lifting
 begin
 lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len word" is word_of_int .
 
 lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
 by(simp add: word_of_integer.rep_eq)
 end
 
 lemma word_of_int_code:
   "uint (word_of_int x :: 'a word) = x AND mask (LENGTH('a :: len))"
   by (simp add: take_bit_eq_mask)
 
 context fixes f :: "nat \<Rightarrow> bool" begin
 
 definition set_bits_aux :: \<open>'a word \<Rightarrow> nat \<Rightarrow> 'a :: len word\<close>
   where \<open>set_bits_aux w n = push_bit n w OR take_bit n (set_bits f)\<close>
 
 lemma set_bits_aux_conv:
   \<open>set_bits_aux w n = (w << n) OR (set_bits f AND mask n)\<close>
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI)
     (auto simp add: set_bits_aux_def shiftl_word_eq bit_and_iff bit_or_iff bit_push_bit_iff bit_take_bit_iff bit_mask_iff bit_set_bits_word_iff)
 
 corollary set_bits_conv_set_bits_aux:
   \<open>set_bits f = (set_bits_aux 0 (LENGTH('a)) :: 'a :: len word)\<close>
   by (simp add: set_bits_aux_conv)
 
 lemma set_bits_aux_0 [simp]:
   \<open>set_bits_aux w 0 = w\<close>
   by  (simp add: set_bits_aux_conv)
 
 lemma set_bits_aux_Suc [simp]:
   \<open>set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n\<close>
   by (simp add: set_bits_aux_def shiftl_word_eq bit_eq_iff bit_or_iff bit_push_bit_iff bit_take_bit_iff bit_set_bits_word_iff)
     (auto simp add: bit_exp_iff not_less bit_1_iff less_Suc_eq_le)
 
 lemma set_bits_aux_simps [code]:
   \<open>set_bits_aux w 0 = w\<close>
   \<open>set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n\<close>
   by simp_all
 
 end
 
 lemma word_of_int_via_signed:
   fixes mask
   assumes mask_def: "mask = Bit_Operations.mask (LENGTH('a))"
   and shift_def: "shift = 1 << LENGTH('a)"
   and index_def: "index = LENGTH('a) - 1"
   and overflow_def:"overflow = 1 << (LENGTH('a) - 1)"
   and least_def: "least = - overflow"
   shows
   "(word_of_int i :: 'a :: len word) =
    (let i' = i AND mask
     in if i' !! index then
          if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
        else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
 proof -
   define i' where "i' = i AND mask"
   have "shift = mask + 1" unfolding assms by(simp add: bin_mask_p1_conv_shift)
   hence "i' < shift" by(simp add: mask_def i'_def int_and_le)
   show ?thesis
   proof(cases "i' !! index")
     case True
     then have unf: "i' = overflow OR i'"
       apply (simp add: assms i'_def shiftl_eq_push_bit push_bit_of_1 flip: take_bit_eq_mask)
       apply (rule bit_eqI)
       apply (auto simp add: bit_take_bit_iff bit_or_iff bit_exp_iff)
       done
     have "overflow \<le> i'" by(subst unf)(rule le_int_or, simp add: bin_sign_and assms i'_def)
     hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
       by(cases "LENGTH('a)")(simp_all add: not_less)
     moreover
     have "overflow \<le> i' - shift \<longleftrightarrow> False" using \<open>i' < shift\<close> unfolding assms
       by(cases "LENGTH('a)")(auto simp add: not_le elim: less_le_trans)
     moreover
     have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using \<open>i' < shift\<close>
       by (simp add: i'_def shift_def mask_def shiftl_eq_push_bit push_bit_of_1 word_of_int_eq_iff flip: take_bit_eq_mask)
     ultimately show ?thesis using True by(simp add: Let_def i'_def)
   next
     case False
     hence "i' = i AND Bit_Operations.mask (LENGTH('a) - 1)" unfolding assms i'_def
       by(clarsimp simp add: i'_def bin_nth_ops intro!: bin_eqI)(cases "LENGTH('a)", auto simp add: less_Suc_eq)
     also have "\<dots> \<le> Bit_Operations.mask (LENGTH('a) - 1)" by(rule int_and_le) simp
     also have "\<dots> < overflow" unfolding overflow_def
       by(simp add: bin_mask_p1_conv_shift[symmetric])
     also
     have "least \<le> 0" unfolding least_def overflow_def by simp
     have "0 \<le> i'" by (simp add: i'_def mask_def)
     hence "least \<le> i'" using \<open>least \<le> 0\<close> by simp
     moreover
     have "word_of_int i' = (word_of_int i :: 'a word)"
       by(rule word_eqI)(auto simp add: i'_def bin_nth_ops mask_def)
     ultimately show ?thesis using False by(simp add: Let_def i'_def)
   qed
 qed
 
 
 
 text \<open>Quickcheck conversion functions\<close>
 
 context
   includes state_combinator_syntax
 begin
 
 definition qc_random_cnv ::
   "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
     \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
   where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
        let n = a_of_natural k
        in (n, \<lambda>_. Code_Evaluation.term_of n)))"
 
 end
 
 definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
   \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "qc_exhaustive_cnv a_of_natural f d =
    Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"
 
 definition qc_full_exhaustive_cnv ::
   "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
   \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
   (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"
 
 declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]
 
 definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
 where
   "qc_narrowing_drawn_from xs =
    foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"
 
 locale quickcheck_narrowing_samples =
   fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
   and zero :: "'a"
   and tr :: "typerep"
 begin
 
 function narrowing_samples :: "integer \<Rightarrow> 'a list"
 where
   "narrowing_samples i =
    (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
 by pat_completeness auto
 termination including integer.lifting
 proof(relation "measure nat_of_integer")
   fix i :: integer
   assume "0 < i"
   thus "(i - 1, i) \<in> measure nat_of_integer"
     by simp(transfer, simp)
 qed simp
 
 definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
 where
   "partial_term_of_sample i =
   (if i < 0 then undefined
    else if i = 0 then zero
    else if i mod 2 = 0 then snd (a_of_integer (i div 2))
    else fst (a_of_integer (i div 2 + 1)))"
 
 lemma partial_term_of_code:
   "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
     Code_Evaluation.Free (STR ''_'') tr"
   "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
    Code_Evaluation.term_of (partial_term_of_sample i)"
 by (rule partial_term_of_anything)+
 
 end
 
 lemmas [code] =
   quickcheck_narrowing_samples.narrowing_samples.simps
   quickcheck_narrowing_samples.partial_term_of_sample_def
 
 
 text \<open>
   The separate code target \<open>SML_word\<close> collects setups for the
   code generator that PolyML does not provide.
 \<close>
 
 setup \<open>Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)])\<close>
 
 code_identifier code_module Code_Target_Word_Base \<rightharpoonup>
   (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word
 
 end
diff --git a/thys/Word_Lib/Aligned.thy b/thys/Word_Lib/Aligned.thy
--- a/thys/Word_Lib/Aligned.thy
+++ b/thys/Word_Lib/Aligned.thy
@@ -1,1154 +1,1245 @@
 (*
  * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section "Word Alignment"
 
 theory Aligned
   imports
     "HOL-Library.Word"
     More_Word
     Word_EqI
     Typedef_Morphisms
 begin
 
 lift_definition is_aligned :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> bool\<close>
   is \<open>\<lambda>k n. 2 ^ n dvd take_bit LENGTH('a) k\<close>
   by simp
 
 lemma is_aligned_iff_udvd:
   \<open>is_aligned w n \<longleftrightarrow> 2 ^ n udvd w\<close>
   by transfer (simp flip: take_bit_eq_0_iff add: min_def)
 
 lemma is_aligned_iff_take_bit_eq_0:
   \<open>is_aligned w n \<longleftrightarrow> take_bit n w = 0\<close>
   by (simp add: is_aligned_iff_udvd take_bit_eq_0_iff exp_dvd_iff_exp_udvd)
 
 lemma is_aligned_iff_dvd_int:
   \<open>is_aligned ptr n \<longleftrightarrow> 2 ^ n dvd uint ptr\<close>
   by transfer simp
 
 lemma is_aligned_iff_dvd_nat:
   \<open>is_aligned ptr n \<longleftrightarrow> 2 ^ n dvd unat ptr\<close>
 proof -
   have \<open>unat ptr = nat \<bar>uint ptr\<bar>\<close>
     by transfer simp
   then have \<open>2 ^ n dvd unat ptr \<longleftrightarrow> 2 ^ n dvd uint ptr\<close>
     by (simp only: dvd_nat_abs_iff) simp
   then show ?thesis
     by (simp add: is_aligned_iff_dvd_int)
 qed
 
 lemma is_aligned_0 [simp]:
   \<open>is_aligned 0 n\<close>
   by transfer simp
 
 lemma is_aligned_at_0 [simp]:
   \<open>is_aligned w 0\<close>
   by transfer simp
 
 lemma is_aligned_beyond_length:
   \<open>is_aligned w n \<longleftrightarrow> w = 0\<close> if \<open>LENGTH('a) \<le> n\<close> for w :: \<open>'a::len word\<close>
   using that
   apply (simp add: is_aligned_iff_udvd)
   apply transfer
   apply auto
   done
 
 lemma is_alignedI [intro?]:
   \<open>is_aligned x n\<close> if \<open>x = 2 ^ n * k\<close> for x :: \<open>'a::len word\<close>
 proof (unfold is_aligned_iff_udvd)
   from that show \<open>2 ^ n udvd x\<close>
     using dvd_triv_left exp_dvd_iff_exp_udvd by blast
 qed
 
 lemma is_alignedE:
   fixes w :: \<open>'a::len word\<close>
   assumes \<open>is_aligned w n\<close>
   obtains q where \<open>w = 2 ^ n * word_of_nat q\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
 proof (cases \<open>n < LENGTH('a)\<close>)
   case False
   with assms have \<open>w = 0\<close>
     by (simp add: is_aligned_beyond_length)
   with that [of 0] show thesis
     by simp
 next
   case True
   moreover define m where \<open>m = LENGTH('a) - n\<close>
   ultimately have l: \<open>LENGTH('a) = n + m\<close> and \<open>m \<noteq> 0\<close>
     by simp_all
   from \<open>n < LENGTH('a)\<close> have *: \<open>unat (2 ^ n :: 'a word) = 2 ^ n\<close>
     by transfer simp
   from assms have \<open>2 ^ n udvd w\<close>
     by (simp add: is_aligned_iff_udvd)
   then obtain v :: \<open>'a word\<close>
     where \<open>unat w = unat (2 ^ n :: 'a word) * unat v\<close> ..
   moreover define q where \<open>q = unat v\<close>
   ultimately have unat_w: \<open>unat w = 2 ^ n * q\<close>
     by (simp add: *)
   then have \<open>word_of_nat (unat w) = (word_of_nat (2 ^ n * q) :: 'a word)\<close>
     by simp
   then have w: \<open>w = 2 ^ n * word_of_nat q\<close>
     by simp
   moreover have \<open>q < 2 ^ (LENGTH('a) - n)\<close>
   proof (rule ccontr)
     assume \<open>\<not> q < 2 ^ (LENGTH('a) - n)\<close>
     then have \<open>2 ^ (LENGTH('a) - n) \<le> q\<close>
       by simp
     then have \<open>2 ^ LENGTH('a) \<le> 2 ^ n * q\<close>
       by (simp add: l power_add)
     with unat_w [symmetric] show False
       by (metis le_antisym nat_less_le unsigned_less) 
   qed
   ultimately show thesis
     using that by blast
 qed
 
 lemma is_alignedE' [elim?]:
   fixes w :: \<open>'a::len word\<close>
   assumes \<open>is_aligned w n\<close>
   obtains q where \<open>w = push_bit n (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
 proof -
   from assms
   obtain q where \<open>w = 2 ^ n * word_of_nat q\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
     by (rule is_alignedE)
   then have \<open>w = push_bit n (word_of_nat q)\<close>
     by (simp add: push_bit_eq_mult)
   with that show thesis
     using \<open>q < 2 ^ (LENGTH('a) - n)\<close> .
 qed
 
 lemma is_aligned_mask:
   \<open>is_aligned w n \<longleftrightarrow> w AND mask n = 0\<close>
   by (simp add: is_aligned_iff_take_bit_eq_0 take_bit_eq_mask)
 
 lemma is_aligned_imp_not_bit:
   \<open>\<not> bit w m\<close> if \<open>is_aligned w n\<close> and \<open>m < n\<close>
   for w :: \<open>'a::len word\<close>
 proof -
   from \<open>is_aligned w n\<close>
   obtain q where \<open>w = push_bit n (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close> ..
   moreover have \<open>\<not> bit (push_bit n (word_of_nat q :: 'a word)) m\<close>
     using \<open>m < n\<close> by (simp add: bit_simps)
   ultimately show ?thesis
     by simp
 qed
 
 lemma is_aligned_weaken:
   "\<lbrakk> is_aligned w x; x \<ge> y \<rbrakk> \<Longrightarrow> is_aligned w y"
   unfolding is_aligned_iff_dvd_nat
   by (erule dvd_trans [rotated]) (simp add: le_imp_power_dvd)
 
 lemma is_alignedE_pre:
   fixes w::"'a::len word"
   assumes aligned: "is_aligned w n"
   shows        rl: "\<exists>q. w = 2 ^ n * (of_nat q) \<and> q < 2 ^ (LENGTH('a) - n)"
   using aligned is_alignedE by blast
 
 lemma aligned_add_aligned:
   fixes x::"'a::len word"
   assumes aligned1: "is_aligned x n"
   and     aligned2: "is_aligned y m"
   and           lt: "m \<le> n"
   shows   "is_aligned (x + y) m"
 proof cases
   assume nlt: "n < LENGTH('a)"
   show ?thesis
     unfolding is_aligned_iff_dvd_nat dvd_def
   proof -
     from aligned2 obtain q2 where yv: "y = 2 ^ m * of_nat q2"
       and q2v: "q2 < 2 ^ (LENGTH('a) - m)"
       by (auto elim: is_alignedE)
 
     from lt obtain k where kv: "m + k = n" by (auto simp: le_iff_add)
     with aligned1 obtain q1 where xv: "x = 2 ^ (m + k) * of_nat q1"
       and q1v: "q1 < 2 ^ (LENGTH('a) - (m + k))"
       by (auto elim: is_alignedE)
 
     have l1: "2 ^ (m + k) * q1 < 2 ^ LENGTH('a)"
       by (rule nat_less_power_trans [OF q1v])
          (subst kv, rule order_less_imp_le [OF nlt])
 
     have l2: "2 ^ m * q2 < 2 ^ LENGTH('a)"
       by (rule nat_less_power_trans [OF q2v],
           rule order_less_imp_le [OF order_le_less_trans])
          fact+
 
     have "x = of_nat (2 ^ (m + k) *  q1)" using xv
       by simp
 
     moreover have "y = of_nat (2 ^ m * q2)" using yv
       by simp
 
     ultimately have upls: "unat x + unat y = 2 ^ m * (2 ^ k * q1 + q2)"
     proof -
       have f1: "unat x = 2 ^ (m + k) * q1"
         by (metis (no_types) \<open>x = of_nat (2 ^ (m + k) * q1)\<close> l1 nat_mod_lem word_unat.inverse_norm
                              zero_less_numeral zero_less_power)
       have "unat y = 2 ^ m * q2"
         by (metis (no_types) \<open>y = of_nat (2 ^ m * q2)\<close> l2 nat_mod_lem word_unat.inverse_norm
                              zero_less_numeral zero_less_power)
       then show ?thesis
         using f1 by (simp add: power_add semiring_normalization_rules(34))
     qed
 
     (* (2 ^ k * q1 + q2) *)
     show "\<exists>d. unat (x + y) = 2 ^ m * d"
     proof (cases "unat x + unat y < 2 ^ LENGTH('a)")
       case True
 
       have "unat (x + y) = unat x + unat y"
         by (subst unat_plus_if', rule if_P) fact
 
       also have "\<dots> = 2 ^ m * (2 ^ k * q1 + q2)" by (rule upls)
       finally show ?thesis ..
     next
       case False
       then have "unat (x + y) = (unat x + unat y) mod 2 ^ LENGTH('a)"
         by (subst unat_word_ariths(1)) simp
 
       also have "\<dots> = (2 ^ m * (2 ^ k * q1 + q2)) mod 2 ^ LENGTH('a)"
         by (subst upls, rule refl)
 
       also
       have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (LENGTH('a) - m))"
       proof -
         have "m \<le> len_of (TYPE('a))"
           by (meson le_trans less_imp_le_nat lt nlt)
         then show ?thesis
           by (metis mult_mod_right ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)
       qed
 
       finally show ?thesis ..
     qed
   qed
 next
   assume "\<not> n < LENGTH('a)"
   with assms
   show ?thesis
     by (simp add: is_aligned_mask not_less take_bit_eq_mod power_overflow word_arith_nat_defs(7) flip: take_bit_eq_mask)
 qed
 
 corollary aligned_sub_aligned:
   "\<lbrakk>is_aligned (x::'a::len word) n; is_aligned y m; m \<le> n\<rbrakk>
    \<Longrightarrow> is_aligned (x - y) m"
   apply (simp del: add_uminus_conv_diff add:diff_conv_add_uminus)
   apply (erule aligned_add_aligned, simp_all)
   apply (erule is_alignedE)
   apply (rule_tac k="- of_nat q" in is_alignedI)
   apply simp
   done
 
 lemma is_aligned_shift:
   fixes k::"'a::len word"
   shows "is_aligned (k << m) m"
 proof cases
   assume mv: "m < LENGTH('a)"
   from mv obtain q where mq: "m + q = LENGTH('a)" and "0 < q"
     by (auto dest: less_imp_add_positive)
 
   have "(2::nat) ^ m dvd unat (k << m)"
   proof
     have kv: "(unat k div 2 ^ q) * 2 ^ q + unat k mod 2 ^ q = unat k"
       by (rule div_mult_mod_eq)
 
     have "unat (k << m) = unat (2 ^ m * k)" by (simp add: shiftl_t2n)
     also have "\<dots> = (2 ^ m * unat k) mod (2 ^ LENGTH('a))" using mv
       by (simp add: unat_word_ariths(2))
     also have "\<dots> = 2 ^ m * (unat k mod 2 ^ q)"
       by (subst mq [symmetric], subst power_add, subst mod_mult2_eq) simp
     finally show "unat (k << m) = 2 ^ m * (unat k mod 2 ^ q)" .
   qed
 
   then show ?thesis by (unfold is_aligned_iff_dvd_nat)
 next
   assume "\<not> m < LENGTH('a)"
   then show ?thesis
     by (simp add: not_less power_overflow is_aligned_mask shiftl_zero_size word_size)
 qed
 
 lemma word_mod_by_0: "k mod (0::'a::len word) = k"
   by (simp add: word_arith_nat_mod)
 
 lemma aligned_mod_eq_0:
   fixes p::"'a::len word"
   assumes al: "is_aligned p sz"
   shows   "p mod 2 ^ sz = 0"
 proof cases
   assume szv: "sz < LENGTH('a)"
   with al
   show ?thesis
     unfolding is_aligned_iff_dvd_nat
     by (simp add: and_mask_dvd_nat p2_gt_0 word_mod_2p_is_mask)
 next
   assume "\<not> sz < LENGTH('a)"
   with al show ?thesis
     by (simp add: is_aligned_mask flip: take_bit_eq_mask take_bit_eq_mod)
 qed
 
 lemma is_aligned_triv: "is_aligned (2 ^ n ::'a::len word) n"
   by (rule is_alignedI [where k = 1], simp)
 
 lemma is_aligned_mult_triv1: "is_aligned (2 ^ n * x  ::'a::len word) n"
   by (rule is_alignedI [OF refl])
 
 lemma is_aligned_mult_triv2: "is_aligned (x * 2 ^ n ::'a::len word) n"
   by (subst mult.commute, simp add: is_aligned_mult_triv1)
 
 lemma word_power_less_0_is_0:
   fixes x :: "'a::len word"
   shows "x < a ^ 0 \<Longrightarrow> x = 0" by simp
 
 lemma is_aligned_no_wrap:
   fixes off :: "'a::len word"
   fixes ptr :: "'a::len word"
   assumes al: "is_aligned ptr sz"
   and    off: "off < 2 ^ sz"
   shows  "unat ptr + unat off < 2 ^ LENGTH('a)"
 proof -
   have szv: "sz < LENGTH('a)"
   using off p2_gt_0 word_neq_0_conv by fastforce
 
   from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
     qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)
 
   show ?thesis
   proof (cases "sz = 0")
     case True
     then show ?thesis using off ptrq qv
       by simp
   next
     case False
     then have sne: "0 < sz" ..
 
     show ?thesis
     proof -
       have uq: "unat (of_nat q ::'a::len word) = q"
         apply (subst unat_of_nat)
         apply (rule mod_less)
         apply (rule order_less_trans [OF qv])
         apply (rule power_strict_increasing [OF diff_less [OF sne]])
          apply (simp_all)
         done
 
       have uptr: "unat ptr = 2 ^ sz * q"
         apply (subst ptrq)
         apply (subst iffD1 [OF unat_mult_lem])
          apply (subst unat_power_lower [OF szv])
          apply (subst uq)
          apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
         apply (subst uq)
         apply (subst unat_power_lower [OF szv])
         apply simp
         done
 
       show "unat ptr + unat off < 2 ^ LENGTH('a)" using szv
         apply (subst uptr)
         apply (subst mult.commute, rule nat_add_offset_less [OF _ qv])
         apply (rule order_less_le_trans [OF unat_mono [OF off] order_eq_refl])
          apply simp_all
         done
     qed
   qed
 qed
 
 lemma is_aligned_no_wrap':
   fixes ptr :: "'a::len word"
   assumes al: "is_aligned ptr sz"
   and    off: "off < 2 ^ sz"
   shows  "ptr \<le> ptr + off"
   by (subst no_plus_overflow_unat_size, subst word_size, rule is_aligned_no_wrap) fact+
 
 lemma is_aligned_no_overflow':
   fixes p :: "'a::len word"
   assumes al: "is_aligned p n"
   shows "p \<le> p + (2 ^ n - 1)"
 proof cases
   assume "n<LENGTH('a)"
   with al
   have "2^n - (1::'a::len word) < 2^n"
     by (simp add: word_less_nat_alt unat_sub_if_size)
   with al
   show ?thesis by (rule is_aligned_no_wrap')
 next
   assume "\<not> n<LENGTH('a)"
   with al
   show ?thesis
   by (simp add: not_less power_overflow is_aligned_mask mask_2pm1)
 qed
 
 lemma is_aligned_no_overflow:
   "is_aligned ptr sz \<Longrightarrow> ptr \<le> ptr + 2^sz - 1"
   by (drule is_aligned_no_overflow') (simp add: field_simps)
 
 lemma replicate_not_True:
   "\<And>n. xs = replicate n False \<Longrightarrow> True \<notin> set xs"
   by (induct xs) auto
 
 lemma map_zip_replicate_False_xor:
   "n = length xs \<Longrightarrow> map (\<lambda>(x, y). x = (\<not> y)) (zip xs (replicate n False)) = xs"
   by (induct xs arbitrary: n, auto)
 
 lemma drop_minus_lem:
   "\<lbrakk> n \<le> length xs; 0 < n; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - n) xs = rev xs ! (n - 1)  # drop (Suc (n' - n)) xs"
 proof (induct xs arbitrary: n n')
   case Nil then show ?case by simp
 next
   case (Cons y ys)
   from Cons.prems
   show ?case
     apply simp
     apply (cases "n = Suc (length ys)")
      apply (simp add: nth_append)
     apply (simp add: Suc_diff_le Cons.hyps nth_append)
     apply clarsimp
     apply arith
     done
 qed
 
 lemma drop_minus:
   "\<lbrakk> n < length xs; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - Suc n) xs = rev xs ! n  # drop (n' - n) xs"
   apply (subst drop_minus_lem)
      apply simp
     apply simp
    apply simp
   apply simp
   apply (cases "length xs", simp)
   apply (simp add: Suc_diff_le)
   done
 
 lemma aligned_add_xor:
   \<open>(x + 2 ^ n) XOR 2 ^ n = x\<close>
   if al: \<open>is_aligned (x::'a::len word) n'\<close> and le: \<open>n < n'\<close>
 proof -
   have \<open>\<not> bit x n\<close>
     using that by (rule is_aligned_imp_not_bit)
   then have \<open>x + 2 ^ n = x OR 2 ^ n\<close>
     by (subst disjunctive_add) (auto simp add: bit_simps disjunctive_add)
   moreover have \<open>(x OR 2 ^ n) XOR 2 ^ n = x\<close>
     by (rule bit_word_eqI) (auto simp add: bit_simps \<open>\<not> bit x n\<close>)
   ultimately show ?thesis
     by simp
 qed
 
 lemma is_aligned_add_mult_multI:
   fixes p :: "'a::len word"
   shows "\<lbrakk>is_aligned p m; n \<le> m; n' = n\<rbrakk> \<Longrightarrow> is_aligned (p + x * 2 ^ n * z) n'"
   apply (erule aligned_add_aligned)
   apply (auto intro: is_alignedI [where k="x*z"])
   done
 
 lemma is_aligned_add_multI:
   fixes p :: "'a::len word"
   shows "\<lbrakk>is_aligned p m; n \<le> m; n' = n\<rbrakk> \<Longrightarrow> is_aligned (p + x * 2 ^ n) n'"
   apply (erule aligned_add_aligned)
   apply (auto intro: is_alignedI [where k="x"])
   done
 
 lemma is_aligned_no_wrap''':
   fixes ptr :: "'a::len word"
   shows"\<lbrakk> is_aligned ptr sz; sz < LENGTH('a); off < 2 ^ sz \<rbrakk>
          \<Longrightarrow> unat ptr + off < 2 ^ LENGTH('a)"
   apply (drule is_aligned_no_wrap[where off="of_nat off"])
    apply (simp add: word_less_nat_alt)
    apply (erule order_le_less_trans[rotated])
   apply (simp add: take_bit_eq_mod)
   apply (subst(asm) unat_of_nat_len)
    apply (erule order_less_trans)
    apply (erule power_strict_increasing)
    apply simp
   apply assumption
   done
 
 lemma is_aligned_get_word_bits:
   fixes p :: "'a::len word"
   shows "\<lbrakk> is_aligned p n; \<lbrakk> is_aligned p n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> P;
            \<lbrakk> p = 0; n \<ge> LENGTH('a) \<rbrakk> \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   apply (cases "n < LENGTH('a)")
    apply simp
   apply simp
   apply (erule meta_mp)
   apply (simp add: is_aligned_mask power_add power_overflow not_less
     flip: take_bit_eq_mask)
   apply (metis take_bit_length_eq take_bit_of_0 take_bit_tightened)
   done
 
 lemma aligned_small_is_0:
   "\<lbrakk> is_aligned x n; x < 2 ^ n \<rbrakk> \<Longrightarrow> x = 0"
   by (simp add: is_aligned_mask less_mask_eq)
 
 corollary is_aligned_less_sz:
   "\<lbrakk>is_aligned a sz; a \<noteq> 0\<rbrakk> \<Longrightarrow> \<not> a < 2 ^ sz"
   by (rule notI, drule(1) aligned_small_is_0, erule(1) notE)
 
 lemma aligned_at_least_t2n_diff:
   "\<lbrakk>is_aligned x n; is_aligned y n; x < y\<rbrakk> \<Longrightarrow> x \<le> y - 2 ^ n"
   apply (erule is_aligned_get_word_bits[where p=y])
    apply (rule ccontr)
    apply (clarsimp simp: linorder_not_le)
    apply (subgoal_tac "y - x = 0")
     apply clarsimp
    apply (rule aligned_small_is_0)
     apply (erule(1) aligned_sub_aligned)
     apply simp
    apply unat_arith
   apply simp
   done
 
 lemma is_aligned_no_overflow'':
   "\<lbrakk>is_aligned x n; x + 2 ^ n \<noteq> 0\<rbrakk> \<Longrightarrow> x \<le> x + 2 ^ n"
   apply (frule is_aligned_no_overflow')
   apply (erule order_trans)
   apply (simp add: field_simps)
   apply (erule word_sub_1_le)
   done
 
 lemma is_aligned_nth [word_eqI_simps]:
   "is_aligned p m = (\<forall>n < m. \<not>p !! n)"
   apply (clarsimp simp: is_aligned_mask bang_eq word_size)
   apply (rule iffI)
    apply clarsimp
    apply (case_tac "n < size p")
     apply (simp add: word_size)
    apply (drule test_bit_size)
    apply simp
   apply clarsimp
   done
 
 lemma range_inter:
   "({a..b} \<inter> {c..d} = {}) = (\<forall>x. \<not>(a \<le> x \<and> x \<le> b \<and> c \<le> x \<and> x \<le> d))"
   by auto
 
 lemma aligned_inter_non_empty:
   "\<lbrakk> {p..p + (2 ^ n - 1)} \<inter> {p..p + 2 ^ m - 1} = {};
      is_aligned p n; is_aligned p m\<rbrakk> \<Longrightarrow> False"
   apply (clarsimp simp only: range_inter)
   apply (erule_tac x=p in allE)
   apply simp
   apply (erule impE)
    apply (erule is_aligned_no_overflow')
   apply (erule notE)
   apply (erule is_aligned_no_overflow)
   done
 
 lemma not_aligned_mod_nz:
   assumes al: "\<not> is_aligned a n"
   shows "a mod 2 ^ n \<noteq> 0"
   apply (rule ccontr)
   using al apply (rule notE)
   apply simp
   apply (rule is_alignedI [of _ _ \<open>a div 2 ^ n\<close>])
   apply (metis add.right_neutral mult.commute word_mod_div_equality)
   done
 
 lemma nat_add_offset_le:
   fixes x :: nat
   assumes yv: "y \<le> 2 ^ n"
   and     xv: "x < 2 ^ m"
   and     mn: "sz = m + n"
   shows   "x * 2 ^ n + y \<le> 2 ^ sz"
 proof (subst mn)
   from yv obtain qy where "y + qy = 2 ^ n"
     by (auto simp: le_iff_add)
 
   have "x * 2 ^ n + y \<le> x * 2 ^ n + 2 ^ n"
     using yv xv by simp
   also have "\<dots> = (x + 1) * 2 ^ n" by simp
   also have "\<dots> \<le> 2 ^ (m + n)" using xv
     by (subst power_add) (rule mult_le_mono1, simp)
   finally show "x * 2 ^ n + y \<le> 2 ^ (m + n)" .
 qed
 
 lemma is_aligned_no_wrap_le:
   fixes ptr::"'a::len word"
   assumes al: "is_aligned ptr sz"
   and    szv: "sz < LENGTH('a)"
   and    off: "off \<le> 2 ^ sz"
   shows  "unat ptr + off \<le> 2 ^ LENGTH('a)"
 proof -
   from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
     qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)
 
   show ?thesis
   proof (cases "sz = 0")
     case True
     then show ?thesis using off ptrq qv
       by (auto simp add: le_Suc_eq Suc_le_eq) (simp add: le_less)
   next
     case False
     then have sne: "0 < sz" ..
 
     show ?thesis
     proof -
       have uq: "unat (of_nat q :: 'a word) = q"
         apply (subst unat_of_nat)
         apply (rule mod_less)
         apply (rule order_less_trans [OF qv])
         apply (rule power_strict_increasing [OF diff_less [OF sne]])
         apply simp_all
         done
 
       have uptr: "unat ptr = 2 ^ sz * q"
         apply (subst ptrq)
         apply (subst iffD1 [OF unat_mult_lem])
         apply (subst unat_power_lower [OF szv])
         apply (subst uq)
         apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
         apply (subst uq)
         apply (subst unat_power_lower [OF szv])
         apply simp
         done
 
       show "unat ptr + off \<le> 2 ^ LENGTH('a)" using szv
         apply (subst uptr)
         apply (subst mult.commute, rule nat_add_offset_le [OF off qv])
         apply simp
         done
     qed
   qed
 qed
 
 lemma is_aligned_neg_mask:
   "m \<le> n \<Longrightarrow> is_aligned (x AND NOT (mask n)) m"
   by (metis and_not_mask is_aligned_shift is_aligned_weaken)
 
 lemma unat_minus:
   "unat (- (x :: 'a :: len word)) = (if x = 0 then 0 else 2 ^ size x - unat x)"
   using unat_sub_if_size[where x="2 ^ size x" and y=x]
   by (simp add: unat_eq_0 word_size)
 
 lemma is_aligned_minus:
   \<open>is_aligned (- p) n\<close> if \<open>is_aligned p n\<close> for p :: \<open>'a::len word\<close>
   using that
   apply (cases \<open>n < LENGTH('a)\<close>)
   apply (simp_all add: not_less is_aligned_beyond_length)
   apply transfer
   apply (simp flip: take_bit_eq_0_iff)
   apply (subst take_bit_minus [symmetric])
   apply simp
   done
 
 lemma add_mask_lower_bits:
   "\<lbrakk>is_aligned (x :: 'a :: len word) n;
     \<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'\<rbrakk> \<Longrightarrow> x + p AND NOT (mask n) = x"
   apply (subst word_plus_and_or_coroll)
    apply (rule word_eqI)
    apply (clarsimp simp: word_size is_aligned_nth)
    apply (erule_tac x=na in allE)+
    apply simp
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps not_less test_bit_eq_bit)
   apply (metis is_aligned_nth not_le test_bit_eq_bit)
   done
 
 lemma is_aligned_andI1:
   "is_aligned x n \<Longrightarrow> is_aligned (x AND y) n"
   by (simp add: is_aligned_nth)
 
 lemma is_aligned_andI2:
   "is_aligned y n \<Longrightarrow> is_aligned (x AND y) n"
   by (simp add: is_aligned_nth)
 
 lemma is_aligned_shiftl:
   "is_aligned w (n - m) \<Longrightarrow> is_aligned (w << m) n"
   by (simp add: is_aligned_nth nth_shiftl)
 
 lemma is_aligned_shiftr:
   "is_aligned w (n + m) \<Longrightarrow> is_aligned (w >> m) n"
   by (simp add: is_aligned_nth nth_shiftr)
 
 lemma is_aligned_shiftl_self:
   "is_aligned (p << n) n"
   by (rule is_aligned_shift)
 
 lemma is_aligned_neg_mask_eq:
   "is_aligned p n \<Longrightarrow> p AND NOT (mask n) = p"
   by (metis add.left_neutral is_aligned_mask word_plus_and_or_coroll2)
 
 lemma is_aligned_shiftr_shiftl:
   "is_aligned w n \<Longrightarrow> w >> n << n = w"
   by (metis and_not_mask is_aligned_neg_mask_eq)
 
 lemma aligned_shiftr_mask_shiftl:
   "is_aligned x n \<Longrightarrow> ((x >> n) AND mask v) << n = x AND mask (v + n)"
   apply (rule word_eqI)
   apply (simp add: word_size nth_shiftl nth_shiftr)
   apply (subgoal_tac "\<forall>m. x !! m \<longrightarrow> m \<ge> n")
    apply auto[1]
   apply (clarsimp simp: is_aligned_mask)
   apply (drule_tac x=m in word_eqD)
   apply (frule test_bit_size)
   apply (simp add: word_size)
   done
 
 lemma mask_zero:
   "is_aligned x a \<Longrightarrow> x AND mask a = 0"
   by (metis is_aligned_mask)
 
 lemma is_aligned_neg_mask_eq_concrete:
   "\<lbrakk> is_aligned p n; msk AND NOT (mask n) = NOT (mask n) \<rbrakk>
    \<Longrightarrow> p AND msk = p"
   by (metis word_bw_assocs(1) word_bw_comms(1) is_aligned_neg_mask_eq)
 
 lemma is_aligned_and_not_zero:
   "\<lbrakk> is_aligned n k; n \<noteq> 0 \<rbrakk> \<Longrightarrow> 2 ^ k \<le> n"
   using is_aligned_less_sz leI by blast
 
 lemma is_aligned_and_2_to_k:
   "(n AND 2 ^ k - 1) = 0 \<Longrightarrow> is_aligned (n :: 'a :: len word) k"
   by (simp add: is_aligned_mask mask_eq_decr_exp)
 
 lemma is_aligned_power2:
   "b \<le> a \<Longrightarrow> is_aligned (2 ^ a) b"
   by (metis is_aligned_triv is_aligned_weaken)
 
 lemma aligned_sub_aligned':
   "\<lbrakk> is_aligned (a :: 'a :: len word) n; is_aligned b n; n < LENGTH('a) \<rbrakk>
    \<Longrightarrow> is_aligned (a - b) n"
   by (simp add: aligned_sub_aligned)
 
 lemma is_aligned_neg_mask_weaken:
   "\<lbrakk> is_aligned p n; m \<le> n \<rbrakk> \<Longrightarrow> p AND NOT (mask m) = p"
    using is_aligned_neg_mask_eq is_aligned_weaken by blast
 
 lemma is_aligned_neg_mask2 [simp]:
   "is_aligned (a AND NOT (mask n)) n"
   by (simp add: and_not_mask is_aligned_shift)
 
 lemma is_aligned_0':
   "is_aligned 0 n"
   by (fact is_aligned_0)
 
 lemma aligned_add_offset_no_wrap:
   fixes off :: "('a::len) word"
   and     x :: "'a word"
   assumes al: "is_aligned x sz"
   and   offv: "off < 2 ^ sz"
   shows  "unat x + unat off < 2 ^ LENGTH('a)"
 proof cases
   assume szv: "sz < LENGTH('a)"
   from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
     and kl: "k < 2 ^ (LENGTH('a) - sz)"
     by (auto elim: is_alignedE)
 
   show ?thesis using szv
     apply (subst xv)
     apply (subst unat_mult_power_lem[OF kl])
     apply (subst mult.commute, rule nat_add_offset_less)
       apply (rule less_le_trans[OF unat_mono[OF offv, simplified]])
       apply (erule eq_imp_le[OF unat_power_lower])
      apply (rule kl)
     apply simp
    done
 next
   assume "\<not> sz < LENGTH('a)"
   with offv show ?thesis by (simp add: not_less power_overflow )
 qed
 
 lemma aligned_add_offset_mod:
   fixes x :: "('a::len) word"
   assumes al: "is_aligned x sz"
   and     kv: "k < 2 ^ sz"
   shows   "(x + k) mod 2 ^ sz = k"
 proof cases
   assume szv: "sz < LENGTH('a)"
 
   have ux: "unat x + unat k < 2 ^ LENGTH('a)"
     by (rule aligned_add_offset_no_wrap) fact+
 
   show ?thesis using al szv
     apply -
     apply (erule is_alignedE)
     apply (subst word_unat.Rep_inject [symmetric])
     apply (subst unat_mod)
     apply (subst iffD1 [OF unat_add_lem], rule ux)
     apply simp
     apply (subst unat_mult_power_lem, assumption+)
     apply (simp)
     apply (rule mod_less[OF less_le_trans[OF unat_mono], OF kv])
     apply (erule eq_imp_le[OF unat_power_lower])
     done
 next
   assume "\<not> sz < LENGTH('a)"
   with al show ?thesis
     by (simp add: not_less power_overflow is_aligned_mask mask_eq_decr_exp
                   word_mod_by_0)
 qed
 
 lemma aligned_neq_into_no_overlap:
   fixes x :: "'a::len word"
   assumes neq: "x \<noteq> y"
   and     alx: "is_aligned x sz"
   and     aly: "is_aligned y sz"
   shows  "{x .. x + (2 ^ sz - 1)} \<inter> {y .. y + (2 ^ sz - 1)} = {}"
 proof cases
   assume szv: "sz < LENGTH('a)"
   show ?thesis
   proof (rule equals0I, clarsimp)
     fix z
     assume xb: "x \<le> z" and xt: "z \<le> x + (2 ^ sz - 1)"
       and yb: "y \<le> z" and yt: "z \<le> y + (2 ^ sz - 1)"
 
     have rl: "\<And>(p::'a word) k w. \<lbrakk>uint p + uint k < 2 ^ LENGTH('a); w = p + k; w \<le> p + (2 ^ sz - 1) \<rbrakk>
       \<Longrightarrow> k < 2 ^ sz"
       apply -
       apply simp
       apply (subst (asm) add.commute, subst (asm) add.commute, drule word_plus_mcs_4)
        apply (subst add.commute, subst no_plus_overflow_uint_size)
        apply transfer
       apply simp
       apply (auto simp add: le_less power_2_ge_iff szv)
       apply (metis le_less_trans mask_eq_decr_exp mask_lt_2pn order_less_imp_le szv)
       done
 
     from xb obtain kx where
       kx: "z = x + kx" and
       kxl: "uint x + uint kx < 2 ^ LENGTH('a)"
       by (clarsimp dest!: word_le_exists')
 
     from yb obtain ky where
       ky: "z = y + ky" and
       kyl: "uint y + uint ky < 2 ^ LENGTH('a)"
       by (clarsimp dest!: word_le_exists')
 
     have "x = y"
     proof -
       have "kx = z mod 2 ^ sz"
       proof (subst kx, rule sym, rule aligned_add_offset_mod)
         show "kx < 2 ^ sz" by (rule rl) fact+
       qed fact+
 
       also have "\<dots> = ky"
       proof (subst ky, rule aligned_add_offset_mod)
         show "ky < 2 ^ sz"
           using kyl ky yt by (rule rl)
       qed fact+
 
       finally have kxky: "kx = ky" .
       moreover have "x + kx = y + ky" by (simp add: kx [symmetric] ky [symmetric])
       ultimately show ?thesis by simp
     qed
     then show False using neq by simp
   qed
 next
   assume "\<not> sz < LENGTH('a)"
   with neq alx aly
   have False by (simp add: is_aligned_mask mask_eq_decr_exp power_overflow)
   then show ?thesis ..
 qed
 
 lemma is_aligned_add_helper:
   "\<lbrakk> is_aligned p n; d < 2 ^ n \<rbrakk>
      \<Longrightarrow> (p + d AND mask n = d) \<and> (p + d AND (NOT (mask n)) = p)"
   apply (subst (asm) is_aligned_mask)
   apply (drule less_mask_eq)
   apply (rule context_conjI)
    apply (subst word_plus_and_or_coroll)
     apply (simp_all flip: take_bit_eq_mask)
    apply (metis take_bit_eq_mask word_bw_lcs(1) word_log_esimps(1))
   apply (metis add.commute add_left_imp_eq take_bit_eq_mask word_plus_and_or_coroll2)
   done
 
 lemmas mask_inner_mask = mask_eqs(1)
 
 lemma mask_add_aligned:
   "is_aligned p n \<Longrightarrow> (p + q) AND mask n = q AND mask n"
   apply (simp add: is_aligned_mask)
   apply (subst mask_inner_mask [symmetric])
   apply simp
   done
 
 lemma mask_out_add_aligned:
   assumes al: "is_aligned p n"
   shows "p + (q AND NOT (mask n)) = (p + q) AND NOT (mask n)"
   using mask_add_aligned [OF al]
   by (simp add: mask_out_sub_mask)
 
 lemma is_aligned_add_or:
   "\<lbrakk>is_aligned p n; d < 2 ^ n\<rbrakk> \<Longrightarrow> p + d = p OR d"
   apply (subst disjunctive_add)
    apply (simp_all add: is_aligned_iff_take_bit_eq_0)
   apply (simp add: bit_eq_iff)
   apply (auto simp add: bit_simps)
   subgoal for m
     apply (cases \<open>m < n\<close>)
      apply (auto simp add: not_less)
     apply (metis bit_take_bit_iff less_mask_eq take_bit_eq_mask)
     done
   done
 
 lemma not_greatest_aligned:
   "\<lbrakk> x < y; is_aligned x n; is_aligned y n \<rbrakk> \<Longrightarrow> x + 2 ^ n \<noteq> 0"
   by (metis NOT_mask add_diff_cancel_right' diff_0 is_aligned_neg_mask_eq not_le word_and_le1)
 
 lemma neg_mask_mono_le:
   "x \<le> y \<Longrightarrow> x AND NOT(mask n) \<le> y AND NOT(mask n)" for x :: "'a :: len word"
 proof (rule ccontr, simp add: linorder_not_le, cases "n < LENGTH('a)")
   case False
   then show "y AND NOT(mask n) < x AND NOT(mask n) \<Longrightarrow> False"
     by (simp add: mask_eq_decr_exp linorder_not_less power_overflow)
 next
   case True
   assume a: "x \<le> y" and b: "y AND NOT(mask n) < x AND NOT(mask n)"
   have word_bits: "n < LENGTH('a)" by fact
   have "y \<le> (y AND NOT(mask n)) + (y AND mask n)"
     by (simp add: word_plus_and_or_coroll2 add.commute)
   also have "\<dots> \<le> (y AND NOT(mask n)) + 2 ^ n"
     apply (rule word_plus_mono_right)
      apply (rule order_less_imp_le, rule and_mask_less_size)
      apply (simp add: word_size word_bits)
     apply (rule is_aligned_no_overflow'', simp add: is_aligned_neg_mask word_bits)
     apply (rule not_greatest_aligned, rule b; simp add: is_aligned_neg_mask)
     done
   also have "\<dots> \<le> x AND NOT(mask n)"
     using b
     apply (subst add.commute)
     apply (rule le_plus)
      apply (rule aligned_at_least_t2n_diff; simp add: is_aligned_neg_mask)
     apply (rule ccontr, simp add: linorder_not_le)
     apply (drule aligned_small_is_0[rotated]; simp add: is_aligned_neg_mask)
     done
   also have "\<dots> \<le> x" by (rule word_and_le2)
   also have "x \<le> y" by fact
   finally
   show "False" using b by simp
 qed
 
 lemma and_neg_mask_eq_iff_not_mask_le:
   "w AND NOT(mask n) = NOT(mask n) \<longleftrightarrow> NOT(mask n) \<le> w"
   for w :: \<open>'a::len word\<close>
   by (metis eq_iff neg_mask_mono_le word_and_le1 word_and_le2 word_bw_same(1))
 
 lemma neg_mask_le_high_bits [word_eqI_simps]:
   "NOT(mask n) \<le> w \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. w !! i)"
   for w :: \<open>'a::len word\<close>
   by (auto simp: word_size and_neg_mask_eq_iff_not_mask_le[symmetric] word_eq_iff neg_mask_test_bit)
 
 lemma is_aligned_add_less_t2n:
   "\<lbrakk>is_aligned (p::'a::len word) n; d < 2^n; n \<le> m; p < 2^m\<rbrakk> \<Longrightarrow> p + d < 2^m"
   apply (case_tac "m < LENGTH('a)")
    apply (subst mask_eq_iff_w2p[symmetric])
     apply (simp add: word_size)
    apply (simp add: is_aligned_add_or word_ao_dist less_mask_eq)
    apply (subst less_mask_eq)
     apply (erule order_less_le_trans)
     apply (erule(1) two_power_increasing)
    apply simp
   apply (simp add: power_overflow)
   done
 
 lemma aligned_offset_non_zero:
   "\<lbrakk> is_aligned x n; y < 2 ^ n; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
   apply (cases "y = 0")
    apply simp
   apply (subst word_neq_0_conv)
   apply (subst gt0_iff_gem1)
   apply (erule is_aligned_get_word_bits)
    apply (subst field_simps[symmetric], subst plus_le_left_cancel_nowrap)
      apply (rule is_aligned_no_wrap')
       apply simp
      apply (rule word_leq_le_minus_one)
       apply simp
      apply assumption
     apply (erule (1) is_aligned_no_wrap')
    apply (simp add: gt0_iff_gem1 [symmetric] word_neq_0_conv)
   apply simp
   done
 
 lemma is_aligned_over_length:
   "\<lbrakk> is_aligned p n; LENGTH('a) \<le> n \<rbrakk> \<Longrightarrow> (p::'a::len word) = 0"
   by (simp add: is_aligned_mask mask_over_length)
 
 lemma is_aligned_no_overflow_mask:
   "is_aligned x n \<Longrightarrow> x \<le> x + mask n"
   by (simp add: mask_eq_decr_exp) (erule is_aligned_no_overflow')
 
 lemma aligned_mask_step:
   "\<lbrakk> n' \<le> n; p' \<le> p + mask n; is_aligned p n; is_aligned p' n' \<rbrakk> \<Longrightarrow>
    (p'::'a::len word) + mask n' \<le> p + mask n"
   apply (cases "LENGTH('a) \<le> n")
    apply (frule (1) is_aligned_over_length)
    apply (drule mask_over_length)
    apply clarsimp
   apply (simp add: not_le)
   apply (simp add: word_le_nat_alt unat_plus_simple)
   apply (subst unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)+
   apply (subst (asm) unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)
   apply (clarsimp simp: dvd_def is_aligned_iff_dvd_nat)
   apply (rename_tac k k')
   apply (thin_tac "unat p = x" for p x)+
   apply (subst Suc_le_mono[symmetric])
   apply (simp only: Suc_2p_unat_mask)
   apply (drule le_imp_less_Suc, subst (asm) Suc_2p_unat_mask, assumption)
   apply (erule (1) power_2_mult_step_le)
   done
 
 lemma is_aligned_mask_offset_unat:
   fixes off :: "('a::len) word"
   and     x :: "'a word"
   assumes al: "is_aligned x sz"
   and   offv: "off \<le> mask sz"
   shows  "unat x + unat off < 2 ^ LENGTH('a)"
 proof cases
   assume szv: "sz < LENGTH('a)"
   from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
     and kl: "k < 2 ^ (LENGTH('a) - sz)"
     by (auto elim: is_alignedE)
 
   from offv szv have offv': "unat off < 2 ^ sz"
     by (simp add: mask_2pm1 unat_less_power)
 
   show ?thesis using szv
     using al is_aligned_no_wrap''' offv' by blast
 next
   assume "\<not> sz < LENGTH('a)"
   with al have "x = 0"
     by (meson is_aligned_get_word_bits) 
   thus ?thesis by simp
 qed
 
 lemma aligned_less_plus_1:
   "\<lbrakk> is_aligned x n; n > 0 \<rbrakk> \<Longrightarrow> x < x + 1"
   apply (rule plus_one_helper2)
    apply (rule order_refl)
   apply (clarsimp simp: field_simps)
   apply (drule arg_cong[where f="\<lambda>x. x - 1"])
   apply (clarsimp simp: is_aligned_mask)
   apply (drule word_eqD[where x=0])
   apply simp
   done
 
 lemma aligned_add_offset_less:
   "\<lbrakk>is_aligned x n; is_aligned y n; x < y; z < 2 ^ n\<rbrakk> \<Longrightarrow> x + z < y"
   apply (cases "y = 0")
    apply simp
   apply (erule is_aligned_get_word_bits[where p=y], simp_all)
   apply (cases "z = 0", simp_all)
   apply (drule(2) aligned_at_least_t2n_diff[rotated -1])
   apply (drule plus_one_helper2)
    apply (rule less_is_non_zero_p1)
    apply (rule aligned_less_plus_1)
     apply (erule aligned_sub_aligned[OF _ _ order_refl],
            simp_all add: is_aligned_triv)[1]
    apply (cases n, simp_all)[1]
   apply (simp only: trans[OF diff_add_eq diff_diff_eq2[symmetric]])
   apply (drule word_less_add_right)
    apply (rule ccontr, simp add: linorder_not_le)
    apply (drule aligned_small_is_0, erule order_less_trans)
     apply (clarsimp simp: power_overflow)
    apply simp
   apply (erule order_le_less_trans[rotated],
          rule word_plus_mono_right)
    apply (erule word_le_minus_one_leq)
   apply (simp add: is_aligned_no_wrap' is_aligned_no_overflow field_simps)
   done
 
 lemma gap_between_aligned:
   "\<lbrakk>a < (b :: 'a ::len word); is_aligned a n; is_aligned b n; n < LENGTH('a) \<rbrakk>
   \<Longrightarrow> a + (2^n - 1) < b"
   by (simp add: aligned_add_offset_less)
 
 lemma is_aligned_add_step_le:
   "\<lbrakk> is_aligned (a::'a::len word) n; is_aligned b n; a < b; b \<le> a + mask n \<rbrakk> \<Longrightarrow> False"
   apply (simp flip: not_le)
   apply (erule notE)
   apply (cases "LENGTH('a) \<le> n")
    apply (drule (1) is_aligned_over_length)+
    apply (drule mask_over_length)
    apply clarsimp
   apply (clarsimp simp: word_le_nat_alt not_less not_le)
   apply (subst (asm) unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)
   apply (subst (asm) unat_add_lem' [symmetric])
    apply (simp add: is_aligned_mask_offset_unat)
   apply (metis gap_between_aligned linorder_not_less mask_eq_decr_exp unat_arith_simps(2))
   done
 
 lemma aligned_add_mask_lessD:
   "\<lbrakk> x + mask n < y; is_aligned x n \<rbrakk> \<Longrightarrow> x < y" for y::"'a::len word"
   by (metis is_aligned_no_overflow' mask_2pm1 order_le_less_trans)
 
 lemma aligned_add_mask_less_eq:
   "\<lbrakk> is_aligned x n; is_aligned y n;  n < LENGTH('a) \<rbrakk> \<Longrightarrow> (x + mask n < y) = (x < y)"
   for y::"'a::len word"
   using aligned_add_mask_lessD is_aligned_add_step_le word_le_not_less by blast
 
 lemma is_aligned_diff:
   fixes m :: "'a::len word"
   assumes alm: "is_aligned m s1"
   and     aln: "is_aligned n s2"
   and    s2wb: "s2 < LENGTH('a)"
   and      nm: "m \<in> {n .. n + (2 ^ s2 - 1)}"
   and    s1s2: "s1 \<le> s2"
   and     s10: "0 < s1" (* Probably can be folded into the proof \<dots> *)
 shows  "\<exists>q. m - n = of_nat q * 2 ^ s1 \<and> q < 2 ^ (s2 - s1)"
 proof -
   have rl: "\<And>m s. \<lbrakk> m < 2 ^ (LENGTH('a) - s); s < LENGTH('a) \<rbrakk> \<Longrightarrow> unat ((2::'a word) ^ s * of_nat m) = 2 ^ s * m"
   proof -
     fix m :: nat and  s
     assume m: "m < 2 ^ (LENGTH('a) - s)" and s: "s < LENGTH('a)"
     then have "unat ((of_nat m) :: 'a word) = m"
       apply (subst unat_of_nat)
       apply (subst mod_less)
        apply (erule order_less_le_trans)
        apply (rule power_increasing)
         apply simp_all
       done
 
     then show "?thesis m s" using s m
       apply (subst iffD1 [OF unat_mult_lem])
       apply (simp add: nat_less_power_trans)+
       done
   qed
   have s1wb: "s1 < LENGTH('a)" using s2wb s1s2 by simp
   from alm obtain mq where mmq: "m = 2 ^ s1 * of_nat mq" and mq: "mq < 2 ^ (LENGTH('a) - s1)"
     by (auto elim: is_alignedE simp: field_simps)
   from aln obtain nq where nnq: "n = 2 ^ s2 * of_nat nq" and nq: "nq < 2 ^ (LENGTH('a) - s2)"
     by (auto elim: is_alignedE simp: field_simps)
   from s1s2 obtain sq where sq: "s2 = s1 + sq" by (auto simp: le_iff_add)
 
   note us1 = rl [OF mq s1wb]
   note us2 = rl [OF nq s2wb]
 
   from nm have "n \<le> m" by clarsimp
   then have "(2::'a word) ^ s2 * of_nat nq \<le> 2 ^ s1 * of_nat mq" using nnq mmq by simp
   then have "2 ^ s2 * nq \<le> 2 ^ s1 * mq" using s1wb s2wb
     by (simp add: word_le_nat_alt us1 us2)
   then have nqmq: "2 ^ sq * nq \<le> mq" using sq by (simp add: power_add)
 
   have "m - n = 2 ^ s1 * of_nat mq - 2 ^ s2 * of_nat nq" using mmq nnq by simp
   also have "\<dots> = 2 ^ s1 * of_nat mq - 2 ^ s1 * 2 ^ sq * of_nat nq" using sq by (simp add: power_add)
   also have "\<dots> = 2 ^ s1 * (of_nat mq - 2 ^ sq * of_nat nq)" by (simp add: field_simps)
   also have "\<dots> = 2 ^ s1 * of_nat (mq - 2 ^ sq * nq)" using s1wb s2wb us1 us2 nqmq
-    by (simp add: word_unat_power of_nat_diff del: of_nat_power)
+    by (simp add: of_nat_diff)
   finally have mn: "m - n = of_nat (mq - 2 ^ sq * nq) * 2 ^ s1" by simp
   moreover
   from nm have "m - n \<le> 2 ^ s2 - 1"
     by - (rule word_diff_ls', (simp add: field_simps)+)
   then have "(2::'a word) ^ s1 * of_nat (mq - 2 ^ sq * nq) < 2 ^ s2" using mn s2wb by (simp add: field_simps)
   then have "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (s2 - s1)"
   proof (rule word_power_less_diff)
     have mm: "mq - 2 ^ sq * nq < 2 ^ (LENGTH('a) - s1)" using mq by simp
     moreover from s10 have "LENGTH('a) - s1 < LENGTH('a)"
       by (rule diff_less, simp)
     ultimately show "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (LENGTH('a) - s1)"
       using take_bit_nat_less_self_iff [of \<open>LENGTH('a)\<close> \<open>mq - 2 ^ sq * nq\<close>]
       apply (auto simp add: word_less_nat_alt not_le not_less)
       apply (metis take_bit_nat_eq_self_iff)
       done
   qed
   then have "mq - 2 ^ sq * nq < 2 ^ (s2 - s1)" using mq s2wb
     apply (simp add: word_less_nat_alt take_bit_eq_mod)
     apply (subst (asm) mod_less)
     apply auto
      apply (rule order_le_less_trans)
       apply (rule diff_le_self)
      apply (erule order_less_le_trans)
     apply simp
     done
   ultimately show ?thesis
     by auto
 qed
 
+lemma is_aligned_addD1:
+  assumes al1: "is_aligned (x + y) n"
+  and     al2: "is_aligned (x::'a::len word) n"
+  shows "is_aligned y n"
+  using al2
+proof (rule is_aligned_get_word_bits)
+  assume "x = 0" then show ?thesis using al1 by simp
+next
+  assume nv: "n < LENGTH('a)"
+  from al1 obtain q1
+    where xy: "x + y = 2 ^ n * of_nat q1" and "q1 < 2 ^ (LENGTH('a) - n)"
+    by (rule is_alignedE)
+  moreover from al2 obtain q2
+    where x: "x = 2 ^ n * of_nat q2" and "q2 < 2 ^ (LENGTH('a) - n)"
+    by (rule is_alignedE)
+  ultimately have "y = 2 ^ n * (of_nat q1 - of_nat q2)"
+    by (simp add: field_simps)
+  then show ?thesis using nv by (simp add: is_aligned_mult_triv1)
+qed
+
+lemmas is_aligned_addD2 =
+       is_aligned_addD1[OF subst[OF add.commute,
+                                 of "%x. is_aligned x n" for n]]
+
+lemma is_aligned_add:
+  "\<lbrakk>is_aligned p n; is_aligned q n\<rbrakk> \<Longrightarrow> is_aligned (p + q) n"
+  by (simp add: is_aligned_mask mask_add_aligned)
+
+lemma aligned_shift:
+  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
+   \<Longrightarrow> x + y >> n = y >> n"
+  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
+   apply (auto simp add: bit_simps is_aligned_nth test_bit_eq_bit)
+   apply (metis less_2p_is_upper_bits_unset not_le test_bit_word_eq)
+  apply (metis le_add1 less_2p_is_upper_bits_unset test_bit_bin test_bit_word_eq)
+  done
+
+lemma aligned_shift':
+  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
+   \<Longrightarrow> y + x >> n = y >> n"
+  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
+   apply (auto simp add: bit_simps is_aligned_nth test_bit_eq_bit)
+   apply (metis less_2p_is_upper_bits_unset not_le test_bit_eq_bit)
+  apply (metis bit_imp_le_length le_add1 less_2p_is_upper_bits_unset test_bit_eq_bit)
+  done
+
+lemma and_neg_mask_plus_mask_mono: "(p AND NOT (mask n)) + mask n \<ge> p"
+  for p :: \<open>'a::len word\<close>
+  apply (rule word_le_minus_cancel[where x = "p AND NOT (mask n)"])
+   apply (clarsimp simp: subtract_mask)
+   using word_and_le1[where a = "mask n" and y = p]
+    apply (clarsimp simp: mask_eq_decr_exp word_le_less_eq)
+  apply (rule is_aligned_no_overflow'[folded mask_2pm1])
+  apply (clarsimp simp: is_aligned_neg_mask)
+  done
+
+lemma word_neg_and_le:
+  "ptr \<le> (ptr AND NOT (mask n)) + (2 ^ n - 1)"
+  for ptr :: \<open>'a::len word\<close>
+  by (simp add: and_neg_mask_plus_mask_mono mask_2pm1[symmetric])
+
+lemma is_aligned_sub_helper:
+  "\<lbrakk> is_aligned (p - d) n; d < 2 ^ n \<rbrakk>
+     \<Longrightarrow> (p AND mask n = d) \<and> (p AND (NOT (mask n)) = p - d)"
+  by (drule(1) is_aligned_add_helper, simp)
+
+lemma is_aligned_after_mask:
+  "\<lbrakk>is_aligned k m;m\<le> n\<rbrakk> \<Longrightarrow> is_aligned (k AND mask n) m"
+  by (rule is_aligned_andI1)
+
+lemma and_mask_plus:
+  "\<lbrakk>is_aligned ptr m; m \<le> n; a < 2 ^ m\<rbrakk>
+   \<Longrightarrow> ptr + a AND mask n = (ptr AND mask n) + a"
+  apply (rule mask_eqI[where n = m])
+   apply (simp add:mask_twice min_def)
+    apply (simp add:is_aligned_add_helper)
+    apply (subst is_aligned_add_helper[THEN conjunct1])
+      apply (erule is_aligned_after_mask)
+     apply simp
+    apply simp
+   apply simp
+  apply (subgoal_tac "(ptr + a AND mask n) AND NOT (mask m)
+     = (ptr + a AND NOT (mask m) ) AND mask n")
+   apply (simp add:is_aligned_add_helper)
+   apply (subst is_aligned_add_helper[THEN conjunct2])
+     apply (simp add:is_aligned_after_mask)
+    apply simp
+   apply simp
+  apply (simp add:word_bw_comms word_bw_lcs)
+  done
+
 end
diff --git a/thys/Word_Lib/Bits_Int.thy b/thys/Word_Lib/Bits_Int.thy
--- a/thys/Word_Lib/Bits_Int.thy
+++ b/thys/Word_Lib/Bits_Int.thy
@@ -1,1430 +1,1490 @@
 (*  Author:     Jeremy Dawson and Gerwin Klein, NICTA
 *)
 
 section \<open>Bitwise Operations on integers\<close>
 
 theory Bits_Int
   imports
     "HOL-Library.Word"
     Traditional_Infix_Syntax
 begin
 
 subsection \<open>Implicit bit representation of \<^typ>\<open>int\<close>\<close>
 
 abbreviation (input) bin_last :: "int \<Rightarrow> bool"
   where "bin_last \<equiv> odd"
 
 lemma bin_last_def:
   "bin_last w \<longleftrightarrow> w mod 2 = 1"
   by (fact odd_iff_mod_2_eq_one)
 
 abbreviation (input) bin_rest :: "int \<Rightarrow> int"
   where "bin_rest w \<equiv> w div 2"
 
 lemma bin_last_numeral_simps [simp]:
   "\<not> odd (0 :: int)"
   "odd (1 :: int)"
   "odd (- 1 :: int)"
   "odd (Numeral1 :: int)"
   "\<not> odd (numeral (Num.Bit0 w) :: int)"
   "odd (numeral (Num.Bit1 w) :: int)"
   "\<not> odd (- numeral (Num.Bit0 w) :: int)"
   "odd (- numeral (Num.Bit1 w) :: int)"
   by simp_all
 
 lemma bin_rest_numeral_simps [simp]:
   "bin_rest 0 = 0"
   "bin_rest 1 = 0"
   "bin_rest (- 1) = - 1"
   "bin_rest Numeral1 = 0"
   "bin_rest (numeral (Num.Bit0 w)) = numeral w"
   "bin_rest (numeral (Num.Bit1 w)) = numeral w"
   "bin_rest (- numeral (Num.Bit0 w)) = - numeral w"
   "bin_rest (- numeral (Num.Bit1 w)) = - numeral (w + Num.One)"
   by simp_all
 
 lemma bin_rl_eqI: "\<lbrakk>bin_rest x = bin_rest y; odd x = odd y\<rbrakk> \<Longrightarrow> x = y"
   by (auto elim: oddE)
 
 lemma [simp]: 
   shows bin_rest_lt0: "bin_rest i < 0 \<longleftrightarrow> i < 0"
   and  bin_rest_ge_0: "bin_rest i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by auto
 
 lemma bin_rest_gt_0 [simp]: "bin_rest x > 0 \<longleftrightarrow> x > 1"
   by auto
 
 
 subsection \<open>Bit projection\<close>
 
 abbreviation (input) bin_nth :: \<open>int \<Rightarrow> nat \<Rightarrow> bool\<close>
   where \<open>bin_nth \<equiv> bit\<close>
 
 lemma bin_nth_eq_iff: "bin_nth x = bin_nth y \<longleftrightarrow> x = y"
   by (simp add: bit_eq_iff fun_eq_iff)
 
 lemma bin_eqI:
   "x = y" if "\<And>n. bin_nth x n \<longleftrightarrow> bin_nth y n"
   using that bin_nth_eq_iff [of x y] by (simp add: fun_eq_iff)
 
 lemma bin_eq_iff: "x = y \<longleftrightarrow> (\<forall>n. bin_nth x n = bin_nth y n)"
   by (fact bit_eq_iff)
 
 lemma bin_nth_zero [simp]: "\<not> bin_nth 0 n"
   by simp
 
 lemma bin_nth_1 [simp]: "bin_nth 1 n \<longleftrightarrow> n = 0"
   by (cases n) (simp_all add: bit_Suc)
 
 lemma bin_nth_minus1 [simp]: "bin_nth (- 1) n"
   by (induction n) (simp_all add: bit_Suc)
 
 lemma bin_nth_numeral: "bin_rest x = y \<Longrightarrow> bin_nth x (numeral n) = bin_nth y (pred_numeral n)"
   by (simp add: numeral_eq_Suc bit_Suc)
 
 lemmas bin_nth_numeral_simps [simp] =
   bin_nth_numeral [OF bin_rest_numeral_simps(2)]
   bin_nth_numeral [OF bin_rest_numeral_simps(5)]
   bin_nth_numeral [OF bin_rest_numeral_simps(6)]
   bin_nth_numeral [OF bin_rest_numeral_simps(7)]
   bin_nth_numeral [OF bin_rest_numeral_simps(8)]
 
 lemmas bin_nth_simps =
   bit_0 bit_Suc bin_nth_zero bin_nth_minus1
   bin_nth_numeral_simps
 
 lemma nth_2p_bin: "bin_nth (2 ^ n) m = (m = n)" \<comment> \<open>for use when simplifying with \<open>bin_nth_Bit\<close>\<close>
   by (auto simp add: bit_exp_iff)
   
 lemma nth_rest_power_bin: "bin_nth ((bin_rest ^^ k) w) n = bin_nth w (n + k)"
   apply (induct k arbitrary: n)
    apply clarsimp
   apply clarsimp
   apply (simp only: bit_Suc [symmetric] add_Suc)
   done
 
 lemma bin_nth_numeral_unfold:
   "bin_nth (numeral (num.Bit0 x)) n \<longleftrightarrow> n > 0 \<and> bin_nth (numeral x) (n - 1)"
   "bin_nth (numeral (num.Bit1 x)) n \<longleftrightarrow> (n > 0 \<longrightarrow> bin_nth (numeral x) (n - 1))"
   by (cases n; simp)+
 
 
 subsection \<open>Truncating\<close>
 
 definition bin_sign :: "int \<Rightarrow> int"
   where "bin_sign k = (if k \<ge> 0 then 0 else - 1)"
 
 lemma bin_sign_simps [simp]:
   "bin_sign 0 = 0"
   "bin_sign 1 = 0"
   "bin_sign (- 1) = - 1"
   "bin_sign (numeral k) = 0"
   "bin_sign (- numeral k) = -1"
   by (simp_all add: bin_sign_def)
 
 lemma bin_sign_rest [simp]: "bin_sign (bin_rest w) = bin_sign w"
   by (simp add: bin_sign_def)
 
 abbreviation (input) bintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>bintrunc \<equiv> take_bit\<close>
 
 lemma bintrunc_mod2p: "bintrunc n w = w mod 2 ^ n"
   by (fact take_bit_eq_mod)
 
 abbreviation (input) sbintrunc :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>sbintrunc \<equiv> signed_take_bit\<close>
 
 abbreviation (input) norm_sint :: \<open>nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>norm_sint n \<equiv> signed_take_bit (n - 1)\<close>
 
 lemma sbintrunc_mod2p: "sbintrunc n w = (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n"
   by (simp add: bintrunc_mod2p signed_take_bit_eq_take_bit_shift)
   
 lemma sbintrunc_eq_take_bit:
   \<open>sbintrunc n k = take_bit (Suc n) (k + 2 ^ n) - 2 ^ n\<close>
   by (fact signed_take_bit_eq_take_bit_shift)
 
 lemma sign_bintr: "bin_sign (bintrunc n w) = 0"
   by (simp add: bin_sign_def)
 
 lemma bintrunc_n_0: "bintrunc n 0 = 0"
   by (fact take_bit_of_0)
 
 lemma sbintrunc_n_0: "sbintrunc n 0 = 0"
   by (fact signed_take_bit_of_0)
 
 lemma sbintrunc_n_minus1: "sbintrunc n (- 1) = -1"
   by (fact signed_take_bit_of_minus_1)
 
 lemma bintrunc_Suc_numeral:
   "bintrunc (Suc n) 1 = 1"
   "bintrunc (Suc n) (- 1) = 1 + 2 * bintrunc n (- 1)"
   "bintrunc (Suc n) (numeral (Num.Bit0 w)) = 2 * bintrunc n (numeral w)"
   "bintrunc (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * bintrunc n (numeral w)"
   "bintrunc (Suc n) (- numeral (Num.Bit0 w)) = 2 * bintrunc n (- numeral w)"
   "bintrunc (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * bintrunc n (- numeral (w + Num.One))"
   by (simp_all add: take_bit_Suc)
 
 lemma sbintrunc_0_numeral [simp]:
   "sbintrunc 0 1 = -1"
   "sbintrunc 0 (numeral (Num.Bit0 w)) = 0"
   "sbintrunc 0 (numeral (Num.Bit1 w)) = -1"
   "sbintrunc 0 (- numeral (Num.Bit0 w)) = 0"
   "sbintrunc 0 (- numeral (Num.Bit1 w)) = -1"
   by simp_all
 
 lemma sbintrunc_Suc_numeral:
   "sbintrunc (Suc n) 1 = 1"
   "sbintrunc (Suc n) (numeral (Num.Bit0 w)) = 2 * sbintrunc n (numeral w)"
   "sbintrunc (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * sbintrunc n (numeral w)"
   "sbintrunc (Suc n) (- numeral (Num.Bit0 w)) = 2 * sbintrunc n (- numeral w)"
   "sbintrunc (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * sbintrunc n (- numeral (w + Num.One))"
   by (simp_all add: signed_take_bit_Suc)
 
 lemma bin_sign_lem: "(bin_sign (sbintrunc n bin) = -1) = bit bin n"
   by (simp add: bin_sign_def)
 
 lemma nth_bintr: "bin_nth (bintrunc m w) n \<longleftrightarrow> n < m \<and> bin_nth w n"
   by (fact bit_take_bit_iff)
 
 lemma nth_sbintr: "bin_nth (sbintrunc m w) n = (if n < m then bin_nth w n else bin_nth w m)"
   by (simp add: bit_signed_take_bit_iff min_def)
 
 lemma bin_nth_Bit0:
   "bin_nth (numeral (Num.Bit0 w)) n \<longleftrightarrow>
     (\<exists>m. n = Suc m \<and> bin_nth (numeral w) m)"
   using bit_double_iff [of \<open>numeral w :: int\<close> n]
   by (auto intro: exI [of _ \<open>n - 1\<close>])
 
 lemma bin_nth_Bit1:
   "bin_nth (numeral (Num.Bit1 w)) n \<longleftrightarrow>
     n = 0 \<or> (\<exists>m. n = Suc m \<and> bin_nth (numeral w) m)"
   using even_bit_succ_iff [of \<open>2 * numeral w :: int\<close> n]
     bit_double_iff [of \<open>numeral w :: int\<close> n]
   by auto
 
 lemma bintrunc_bintrunc_l: "n \<le> m \<Longrightarrow> bintrunc m (bintrunc n w) = bintrunc n w"
   by (simp add: min.absorb2)
 
 lemma sbintrunc_sbintrunc_l: "n \<le> m \<Longrightarrow> sbintrunc m (sbintrunc n w) = sbintrunc n w"
   by (simp add: min_def)
 
 lemma bintrunc_bintrunc_ge: "n \<le> m \<Longrightarrow> bintrunc n (bintrunc m w) = bintrunc n w"
   by (rule bin_eqI) (auto simp: nth_bintr)
 
 lemma bintrunc_bintrunc_min [simp]: "bintrunc m (bintrunc n w) = bintrunc (min m n) w"
   by (rule bin_eqI) (auto simp: nth_bintr)
 
 lemma sbintrunc_sbintrunc_min [simp]: "sbintrunc m (sbintrunc n w) = sbintrunc (min m n) w"
   by (rule bin_eqI) (auto simp: nth_sbintr min.absorb1 min.absorb2)
 
 lemmas sbintrunc_Suc_Pls =
   signed_take_bit_Suc [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Suc_Min =
   signed_take_bit_Suc [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Sucs = sbintrunc_Suc_Pls sbintrunc_Suc_Min
   sbintrunc_Suc_numeral
 
 lemmas sbintrunc_Pls =
   signed_take_bit_0 [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Min =
   signed_take_bit_0 [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_0_simps =
   sbintrunc_Pls sbintrunc_Min
 
 lemmas sbintrunc_simps = sbintrunc_0_simps sbintrunc_Sucs
 
 lemma bintrunc_minus: "0 < n \<Longrightarrow> bintrunc (Suc (n - 1)) w = bintrunc n w"
   by auto
 
 lemma sbintrunc_minus: "0 < n \<Longrightarrow> sbintrunc (Suc (n - 1)) w = sbintrunc n w"
   by auto
 
 lemmas sbintrunc_minus_simps =
   sbintrunc_Sucs [THEN [2] sbintrunc_minus [symmetric, THEN trans]]
 
 lemma sbintrunc_BIT_I:
   \<open>0 < n \<Longrightarrow>
   sbintrunc (n - 1) 0 = y \<Longrightarrow>
   sbintrunc n 0 = 2 * y\<close>
   by simp
 
 lemma sbintrunc_Suc_Is:
   \<open>sbintrunc n (- 1) = y \<Longrightarrow>
   sbintrunc (Suc n) (- 1) = 1 + 2 * y\<close>
   by auto
 
 lemma sbintrunc_Suc_lem: "sbintrunc (Suc n) x = y \<Longrightarrow> m = Suc n \<Longrightarrow> sbintrunc m x = y"
   by auto
 
 lemmas sbintrunc_Suc_Ialts =
   sbintrunc_Suc_Is [THEN sbintrunc_Suc_lem]
 
 lemma sbintrunc_bintrunc_lt: "m > n \<Longrightarrow> sbintrunc n (bintrunc m w) = sbintrunc n w"
   by (rule bin_eqI) (auto simp: nth_sbintr nth_bintr)
 
 lemma bintrunc_sbintrunc_le: "m \<le> Suc n \<Longrightarrow> bintrunc m (sbintrunc n w) = bintrunc m w"
   apply (rule bin_eqI)
   using le_Suc_eq less_Suc_eq_le apply (auto simp: nth_sbintr nth_bintr)
   done
 
 lemmas bintrunc_sbintrunc [simp] = order_refl [THEN bintrunc_sbintrunc_le]
 lemmas sbintrunc_bintrunc [simp] = lessI [THEN sbintrunc_bintrunc_lt]
 lemmas bintrunc_bintrunc [simp] = order_refl [THEN bintrunc_bintrunc_l]
 lemmas sbintrunc_sbintrunc [simp] = order_refl [THEN sbintrunc_sbintrunc_l]
 
 lemma bintrunc_sbintrunc' [simp]: "0 < n \<Longrightarrow> bintrunc n (sbintrunc (n - 1) w) = bintrunc n w"
   by (cases n) simp_all
 
 lemma sbintrunc_bintrunc' [simp]: "0 < n \<Longrightarrow> sbintrunc (n - 1) (bintrunc n w) = sbintrunc (n - 1) w"
   by (cases n) simp_all
 
 lemma bin_sbin_eq_iff: "bintrunc (Suc n) x = bintrunc (Suc n) y \<longleftrightarrow> sbintrunc n x = sbintrunc n y"
   apply (rule iffI)
    apply (rule box_equals [OF _ sbintrunc_bintrunc sbintrunc_bintrunc])
    apply simp
   apply (rule box_equals [OF _ bintrunc_sbintrunc bintrunc_sbintrunc])
   apply simp
   done
 
 lemma bin_sbin_eq_iff':
   "0 < n \<Longrightarrow> bintrunc n x = bintrunc n y \<longleftrightarrow> sbintrunc (n - 1) x = sbintrunc (n - 1) y"
   by (cases n) (simp_all add: bin_sbin_eq_iff)
 
 lemmas bintrunc_sbintruncS0 [simp] = bintrunc_sbintrunc' [unfolded One_nat_def]
 lemmas sbintrunc_bintruncS0 [simp] = sbintrunc_bintrunc' [unfolded One_nat_def]
 
 lemmas bintrunc_bintrunc_l' = le_add1 [THEN bintrunc_bintrunc_l]
 lemmas sbintrunc_sbintrunc_l' = le_add1 [THEN sbintrunc_sbintrunc_l]
 
 (* although bintrunc_minus_simps, if added to default simpset,
   tends to get applied where it's not wanted in developing the theories,
   we get a version for when the word length is given literally *)
 
 lemmas nat_non0_gr =
   trans [OF iszero_def [THEN Not_eq_iff [THEN iffD2]] refl]
 
 lemma bintrunc_numeral:
   "bintrunc (numeral k) x = of_bool (odd x) + 2 * bintrunc (pred_numeral k) (x div 2)"
   by (simp add: numeral_eq_Suc take_bit_Suc mod_2_eq_odd)
 
 lemma sbintrunc_numeral:
   "sbintrunc (numeral k) x = of_bool (odd x) + 2 * sbintrunc (pred_numeral k) (x div 2)"
   by (simp add: numeral_eq_Suc signed_take_bit_Suc mod2_eq_if)
 
 lemma bintrunc_numeral_simps [simp]:
   "bintrunc (numeral k) (numeral (Num.Bit0 w)) =
     2 * bintrunc (pred_numeral k) (numeral w)"
   "bintrunc (numeral k) (numeral (Num.Bit1 w)) =
     1 + 2 * bintrunc (pred_numeral k) (numeral w)"
   "bintrunc (numeral k) (- numeral (Num.Bit0 w)) =
     2 * bintrunc (pred_numeral k) (- numeral w)"
   "bintrunc (numeral k) (- numeral (Num.Bit1 w)) =
     1 + 2 * bintrunc (pred_numeral k) (- numeral (w + Num.One))"
   "bintrunc (numeral k) 1 = 1"
   by (simp_all add: bintrunc_numeral)
 
 lemma sbintrunc_numeral_simps [simp]:
   "sbintrunc (numeral k) (numeral (Num.Bit0 w)) =
     2 * sbintrunc (pred_numeral k) (numeral w)"
   "sbintrunc (numeral k) (numeral (Num.Bit1 w)) =
     1 + 2 * sbintrunc (pred_numeral k) (numeral w)"
   "sbintrunc (numeral k) (- numeral (Num.Bit0 w)) =
     2 * sbintrunc (pred_numeral k) (- numeral w)"
   "sbintrunc (numeral k) (- numeral (Num.Bit1 w)) =
     1 + 2 * sbintrunc (pred_numeral k) (- numeral (w + Num.One))"
   "sbintrunc (numeral k) 1 = 1"
   by (simp_all add: sbintrunc_numeral)
 
 lemma no_bintr_alt1: "bintrunc n = (\<lambda>w. w mod 2 ^ n :: int)"
   by (rule ext) (rule bintrunc_mod2p)
 
 lemma range_bintrunc: "range (bintrunc n) = {i. 0 \<le> i \<and> i < 2 ^ n}"
   by (auto simp add: take_bit_eq_mod image_iff) (metis mod_pos_pos_trivial)
 
 lemma no_sbintr_alt2: "sbintrunc n = (\<lambda>w. (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n :: int)"
   by (rule ext) (simp add : sbintrunc_mod2p)
 
 lemma range_sbintrunc: "range (sbintrunc n) = {i. - (2 ^ n) \<le> i \<and> i < 2 ^ n}"
 proof -
   have \<open>surj (\<lambda>k::int. k + 2 ^ n)\<close>
     by (rule surjI [of _ \<open>(\<lambda>k. k - 2 ^ n)\<close>]) simp
   moreover have \<open>sbintrunc n = ((\<lambda>k. k - 2 ^ n) \<circ> take_bit (Suc n) \<circ> (\<lambda>k. k + 2 ^ n))\<close>
     by (simp add: sbintrunc_eq_take_bit fun_eq_iff)
   ultimately show ?thesis
     apply (simp only: fun.set_map range_bintrunc)
     apply (auto simp add: image_iff)
     apply presburger
     done
 qed
   
 lemma sbintrunc_inc:
   \<open>k + 2 ^ Suc n \<le> sbintrunc n k\<close> if \<open>k < - (2 ^ n)\<close>
   using that by (fact signed_take_bit_int_greater_eq)
   
 lemma sbintrunc_dec:
   \<open>sbintrunc n k \<le> k - 2 ^ (Suc n)\<close> if \<open>k \<ge> 2 ^ n\<close>
   using that by (fact signed_take_bit_int_less_eq)
 
 lemma bintr_ge0: "0 \<le> bintrunc n w"
   by (simp add: bintrunc_mod2p)
 
 lemma bintr_lt2p: "bintrunc n w < 2 ^ n"
   by (simp add: bintrunc_mod2p)
 
 lemma bintr_Min: "bintrunc n (- 1) = 2 ^ n - 1"
   by (simp add: stable_imp_take_bit_eq)
   
 lemma sbintr_ge: "- (2 ^ n) \<le> sbintrunc n w"
   by (simp add: sbintrunc_mod2p)
 
 lemma sbintr_lt: "sbintrunc n w < 2 ^ n"
   by (simp add: sbintrunc_mod2p)
 
 lemma sign_Pls_ge_0: "bin_sign bin = 0 \<longleftrightarrow> bin \<ge> 0"
   for bin :: int
   by (simp add: bin_sign_def)
 
 lemma sign_Min_lt_0: "bin_sign bin = -1 \<longleftrightarrow> bin < 0"
   for bin :: int
   by (simp add: bin_sign_def)
 
 lemma bin_rest_trunc: "bin_rest (bintrunc n bin) = bintrunc (n - 1) (bin_rest bin)"
   by (simp add: take_bit_rec [of n bin])
 
 lemma bin_rest_power_trunc:
   "(bin_rest ^^ k) (bintrunc n bin) = bintrunc (n - k) ((bin_rest ^^ k) bin)"
   by (induct k) (auto simp: bin_rest_trunc)
 
 lemma bin_rest_trunc_i: "bintrunc n (bin_rest bin) = bin_rest (bintrunc (Suc n) bin)"
   by (auto simp add: take_bit_Suc)
 
 lemma bin_rest_strunc: "bin_rest (sbintrunc (Suc n) bin) = sbintrunc n (bin_rest bin)"
   by (simp add: signed_take_bit_Suc)
 
 lemma bintrunc_rest [simp]: "bintrunc n (bin_rest (bintrunc n bin)) = bin_rest (bintrunc n bin)"
   by (induct n arbitrary: bin) (simp_all add: take_bit_Suc)
 
 lemma sbintrunc_rest [simp]: "sbintrunc n (bin_rest (sbintrunc n bin)) = bin_rest (sbintrunc n bin)"
   by (induct n arbitrary: bin) (simp_all add: signed_take_bit_Suc mod2_eq_if)
 
 lemma bintrunc_rest': "bintrunc n \<circ> bin_rest \<circ> bintrunc n = bin_rest \<circ> bintrunc n"
   by (rule ext) auto
 
 lemma sbintrunc_rest': "sbintrunc n \<circ> bin_rest \<circ> sbintrunc n = bin_rest \<circ> sbintrunc n"
   by (rule ext) auto
 
 lemma rco_lem: "f \<circ> g \<circ> f = g \<circ> f \<Longrightarrow> f \<circ> (g \<circ> f) ^^ n = g ^^ n \<circ> f"
   apply (rule ext)
   apply (induct_tac n)
    apply (simp_all (no_asm))
   apply (drule fun_cong)
   apply (unfold o_def)
   apply (erule trans)
   apply simp
   done
 
 lemmas rco_bintr = bintrunc_rest'
   [THEN rco_lem [THEN fun_cong], unfolded o_def]
 lemmas rco_sbintr = sbintrunc_rest'
   [THEN rco_lem [THEN fun_cong], unfolded o_def]
 
 
 subsection \<open>Splitting and concatenation\<close>
 
 definition bin_split :: \<open>nat \<Rightarrow> int \<Rightarrow> int \<times> int\<close>
   where [simp]: \<open>bin_split n k = (drop_bit n k, take_bit n k)\<close>
 
 lemma [code]:
   "bin_split (Suc n) w = (let (w1, w2) = bin_split n (w div 2) in (w1, of_bool (odd w) + 2 * w2))"
   "bin_split 0 w = (w, 0)"
   by (simp_all add: drop_bit_Suc take_bit_Suc mod_2_eq_odd)
 
 abbreviation (input) bin_cat :: \<open>int \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>bin_cat k n l \<equiv> concat_bit n l k\<close>
 
 lemma bin_cat_eq_push_bit_add_take_bit:
   \<open>bin_cat k n l = push_bit n k + take_bit n l\<close>
   by (simp add: concat_bit_eq)
   
 lemma bin_sign_cat: "bin_sign (bin_cat x n y) = bin_sign x"
 proof -
   have \<open>0 \<le> x\<close> if \<open>0 \<le> x * 2 ^ n + y mod 2 ^ n\<close>
   proof -
     have \<open>y mod 2 ^ n < 2 ^ n\<close>
       using pos_mod_bound [of \<open>2 ^ n\<close> y] by simp
     then have \<open>\<not> y mod 2 ^ n \<ge> 2 ^ n\<close>
       by (simp add: less_le)
     with that have \<open>x \<noteq> - 1\<close>
       by auto
     have *: \<open>- 1 \<le> (- (y mod 2 ^ n)) div 2 ^ n\<close>
       by (simp add: zdiv_zminus1_eq_if)
     from that have \<open>- (y mod 2 ^ n) \<le> x * 2 ^ n\<close>
       by simp
     then have \<open>(- (y mod 2 ^ n)) div 2 ^ n \<le> (x * 2 ^ n) div 2 ^ n\<close>
       using zdiv_mono1 zero_less_numeral zero_less_power by blast
     with * have \<open>- 1 \<le> x * 2 ^ n div 2 ^ n\<close> by simp
     with \<open>x \<noteq> - 1\<close> show ?thesis
       by simp
   qed
   then show ?thesis
     by (simp add: bin_sign_def not_le not_less bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult take_bit_eq_mod)
 qed
 
 lemma bin_cat_assoc: "bin_cat (bin_cat x m y) n z = bin_cat x (m + n) (bin_cat y n z)"
   by (fact concat_bit_assoc)
 
 lemma bin_cat_assoc_sym: "bin_cat x m (bin_cat y n z) = bin_cat (bin_cat x (m - n) y) (min m n) z"
   by (fact concat_bit_assoc_sym)
 
 definition bin_rcat :: \<open>nat \<Rightarrow> int list \<Rightarrow> int\<close>
   where \<open>bin_rcat n = horner_sum (take_bit n) (2 ^ n) \<circ> rev\<close>
 
 lemma bin_rcat_eq_foldl:
   \<open>bin_rcat n = foldl (\<lambda>u v. bin_cat u n v) 0\<close>
 proof
   fix ks :: \<open>int list\<close>
   show \<open>bin_rcat n ks = foldl (\<lambda>u v. bin_cat u n v) 0 ks\<close>
     by (induction ks rule: rev_induct)
       (simp_all add: bin_rcat_def concat_bit_eq push_bit_eq_mult)
 qed
 
 fun bin_rsplit_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
   where "bin_rsplit_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else
       let (a, b) = bin_split n c
       in bin_rsplit_aux n (m - n) a (b # bs))"
 
 definition bin_rsplit :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
   where "bin_rsplit n w = bin_rsplit_aux n (fst w) (snd w) []"
 
 value \<open>bin_rsplit 1705 (3, 88)\<close>
 
 fun bin_rsplitl_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
   where "bin_rsplitl_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else
       let (a, b) = bin_split (min m n) c
       in bin_rsplitl_aux n (m - n) a (b # bs))"
 
 definition bin_rsplitl :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
   where "bin_rsplitl n w = bin_rsplitl_aux n (fst w) (snd w) []"
 
 declare bin_rsplit_aux.simps [simp del]
 declare bin_rsplitl_aux.simps [simp del]
 
 lemma bin_nth_cat:
   "bin_nth (bin_cat x k y) n =
     (if n < k then bin_nth y n else bin_nth x (n - k))"
   by (simp add: bit_concat_bit_iff)
 
 lemma bin_nth_drop_bit_iff:
   \<open>bin_nth (drop_bit n c) k \<longleftrightarrow> bin_nth c (n + k)\<close>
   by (simp add: bit_drop_bit_eq)
 
 lemma bin_nth_take_bit_iff:
   \<open>bin_nth (take_bit n c) k \<longleftrightarrow> k < n \<and> bin_nth c k\<close>
   by (fact bit_take_bit_iff)
 
 lemma bin_nth_split:
   "bin_split n c = (a, b) \<Longrightarrow>
     (\<forall>k. bin_nth a k = bin_nth c (n + k)) \<and>
     (\<forall>k. bin_nth b k = (k < n \<and> bin_nth c k))"
   by (auto simp add: bin_nth_drop_bit_iff bin_nth_take_bit_iff)
 
 lemma bin_cat_zero [simp]: "bin_cat 0 n w = bintrunc n w"
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma bintr_cat1: "bintrunc (k + n) (bin_cat a n b) = bin_cat (bintrunc k a) n b"
   by (metis bin_cat_assoc bin_cat_zero)
 
 lemma bintr_cat: "bintrunc m (bin_cat a n b) =
     bin_cat (bintrunc (m - n) a) n (bintrunc (min m n) b)"
   
   by (rule bin_eqI) (auto simp: bin_nth_cat nth_bintr)
 
 lemma bintr_cat_same [simp]: "bintrunc n (bin_cat a n b) = bintrunc n b"
   by (auto simp add : bintr_cat)
 
 lemma cat_bintr [simp]: "bin_cat a n (bintrunc n b) = bin_cat a n b"
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma split_bintrunc: "bin_split n c = (a, b) \<Longrightarrow> b = bintrunc n c"
   by simp
 
 lemma bin_cat_split: "bin_split n w = (u, v) \<Longrightarrow> w = bin_cat u n v"
   by (auto simp add: bin_cat_eq_push_bit_add_take_bit bits_ident)
 
 lemma drop_bit_bin_cat_eq:
   \<open>drop_bit n (bin_cat v n w) = v\<close>
   by (rule bit_eqI) (simp add: bit_drop_bit_eq bit_concat_bit_iff)
 
 lemma take_bit_bin_cat_eq:
   \<open>take_bit n (bin_cat v n w) = take_bit n w\<close>
   by (rule bit_eqI) (simp add: bit_concat_bit_iff)
 
 lemma bin_split_cat: "bin_split n (bin_cat v n w) = (v, bintrunc n w)"
   by (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
 
 lemma bin_split_zero [simp]: "bin_split n 0 = (0, 0)"
   by simp
 
 lemma bin_split_minus1 [simp]:
   "bin_split n (- 1) = (- 1, bintrunc n (- 1))"
   by simp
 
 lemma bin_split_trunc:
   "bin_split (min m n) c = (a, b) \<Longrightarrow>
     bin_split n (bintrunc m c) = (bintrunc (m - n) a, b)"
   apply (induct n arbitrary: m b c, clarsimp)
   apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
   apply (case_tac m)
    apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
   done
 
 lemma bin_split_trunc1:
   "bin_split n c = (a, b) \<Longrightarrow>
     bin_split n (bintrunc m c) = (bintrunc (m - n) a, bintrunc m b)"
   apply (induct n arbitrary: m b c, clarsimp)
   apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
   apply (case_tac m)
    apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
   done
 
 lemma bin_cat_num: "bin_cat a n b = a * 2 ^ n + bintrunc n b"
   by (simp add: bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult)
 
 lemma bin_split_num: "bin_split n b = (b div 2 ^ n, b mod 2 ^ n)"
   by (simp add: drop_bit_eq_div take_bit_eq_mod)
 
 lemmas bin_rsplit_aux_simps = bin_rsplit_aux.simps bin_rsplitl_aux.simps
 lemmas rsplit_aux_simps = bin_rsplit_aux_simps
 
 lemmas th_if_simp1 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct1, THEN mp] for l
 lemmas th_if_simp2 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct2, THEN mp] for l
 
 lemmas rsplit_aux_simp1s = rsplit_aux_simps [THEN th_if_simp1]
 
 lemmas rsplit_aux_simp2ls = rsplit_aux_simps [THEN th_if_simp2]
 \<comment> \<open>these safe to \<open>[simp add]\<close> as require calculating \<open>m - n\<close>\<close>
 lemmas bin_rsplit_aux_simp2s [simp] = rsplit_aux_simp2ls [unfolded Let_def]
 lemmas rbscl = bin_rsplit_aux_simp2s (2)
 
 lemmas rsplit_aux_0_simps [simp] =
   rsplit_aux_simp1s [OF disjI1] rsplit_aux_simp1s [OF disjI2]
 
 lemma bin_rsplit_aux_append: "bin_rsplit_aux n m c (bs @ cs) = bin_rsplit_aux n m c bs @ cs"
   apply (induct n m c bs rule: bin_rsplit_aux.induct)
   apply (subst bin_rsplit_aux.simps)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp split: prod.split)
   done
 
 lemma bin_rsplitl_aux_append: "bin_rsplitl_aux n m c (bs @ cs) = bin_rsplitl_aux n m c bs @ cs"
   apply (induct n m c bs rule: bin_rsplitl_aux.induct)
   apply (subst bin_rsplitl_aux.simps)
   apply (subst bin_rsplitl_aux.simps)
   apply (clarsimp split: prod.split)
   done
 
 lemmas rsplit_aux_apps [where bs = "[]"] =
   bin_rsplit_aux_append bin_rsplitl_aux_append
 
 lemmas rsplit_def_auxs = bin_rsplit_def bin_rsplitl_def
 
 lemmas rsplit_aux_alts = rsplit_aux_apps
   [unfolded append_Nil rsplit_def_auxs [symmetric]]
 
 lemma bin_split_minus: "0 < n \<Longrightarrow> bin_split (Suc (n - 1)) w = bin_split n w"
   by auto
 
 lemma bin_split_pred_simp [simp]:
   "(0::nat) < numeral bin \<Longrightarrow>
     bin_split (numeral bin) w =
       (let (w1, w2) = bin_split (numeral bin - 1) (bin_rest w)
        in (w1, of_bool (odd w) + 2 * w2))"
   by (simp add: take_bit_rec drop_bit_rec mod_2_eq_odd)
 
 lemma bin_rsplit_aux_simp_alt:
   "bin_rsplit_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else let (a, b) = bin_split n c in bin_rsplit n (m - n, a) @ b # bs)"
   apply (simp add: bin_rsplit_aux.simps [of n m c bs])
   apply (subst rsplit_aux_alts)
   apply (simp add: bin_rsplit_def)
   done
 
 lemmas bin_rsplit_simp_alt =
   trans [OF bin_rsplit_def bin_rsplit_aux_simp_alt]
 
 lemmas bthrs = bin_rsplit_simp_alt [THEN [2] trans]
 
 lemma bin_rsplit_size_sign' [rule_format]:
   "n > 0 \<Longrightarrow> rev sw = bin_rsplit n (nw, w) \<Longrightarrow> \<forall>v\<in>set sw. bintrunc n v = v"
   apply (induct sw arbitrary: nw w)
    apply clarsimp
   apply clarsimp
   apply (drule bthrs)
   apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
   apply clarify
   apply simp
   done
 
 lemmas bin_rsplit_size_sign = bin_rsplit_size_sign' [OF asm_rl
   rev_rev_ident [THEN trans] set_rev [THEN equalityD2 [THEN subsetD]]]
 
 lemma bin_nth_rsplit [rule_format] :
   "n > 0 \<Longrightarrow> m < n \<Longrightarrow>
     \<forall>w k nw.
       rev sw = bin_rsplit n (nw, w) \<longrightarrow>
       k < size sw \<longrightarrow> bin_nth (sw ! k) m = bin_nth w (k * n + m)"
   apply (induct sw)
    apply clarsimp
   apply clarsimp
   apply (drule bthrs)
   apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
   apply (erule allE, erule impE, erule exI)
   apply (case_tac k)
    apply clarsimp
    prefer 2
    apply clarsimp
    apply (erule allE)
    apply (erule (1) impE)
    apply (simp add: bit_drop_bit_eq ac_simps)
   apply (simp add: bit_take_bit_iff ac_simps)
   done
 
 lemma bin_rsplit_all: "0 < nw \<Longrightarrow> nw \<le> n \<Longrightarrow> bin_rsplit n (nw, w) = [bintrunc n w]"
   by (auto simp: bin_rsplit_def rsplit_aux_simp2ls split: prod.split dest!: split_bintrunc)
 
 lemma bin_rsplit_l [rule_format]:
   "\<forall>bin. bin_rsplitl n (m, bin) = bin_rsplit n (m, bintrunc m bin)"
   apply (rule_tac a = "m" in wf_less_than [THEN wf_induct])
   apply (simp (no_asm) add: bin_rsplitl_def bin_rsplit_def)
   apply (rule allI)
   apply (subst bin_rsplitl_aux.simps)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp simp: Let_def split: prod.split)
   apply (simp add: ac_simps)
   apply (subst rsplit_aux_alts(1))
   apply (subst rsplit_aux_alts(2))
   apply clarsimp
   unfolding bin_rsplit_def bin_rsplitl_def
   apply (simp add: drop_bit_take_bit)
   apply (case_tac \<open>x < n\<close>)
   apply (simp_all add: not_less min_def)
   done
 
 lemma bin_rsplit_rcat [rule_format]:
   "n > 0 \<longrightarrow> bin_rsplit n (n * size ws, bin_rcat n ws) = map (bintrunc n) ws"
   apply (unfold bin_rsplit_def bin_rcat_eq_foldl)
   apply (rule_tac xs = ws in rev_induct)
    apply clarsimp
   apply clarsimp
   apply (subst rsplit_aux_alts)
   apply (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
   done
 
 lemma bin_rsplit_aux_len_le [rule_format] :
   "\<forall>ws m. n \<noteq> 0 \<longrightarrow> ws = bin_rsplit_aux n nw w bs \<longrightarrow>
     length ws \<le> m \<longleftrightarrow> nw + length bs * n \<le> m * n"
 proof -
   have *: R
     if d: "i \<le> j \<or> m < j'"
     and R1: "i * k \<le> j * k \<Longrightarrow> R"
     and R2: "Suc m * k' \<le> j' * k' \<Longrightarrow> R"
     for i j j' k k' m :: nat and R
     using d
     apply safe
     apply (rule R1, erule mult_le_mono1)
     apply (rule R2, erule Suc_le_eq [THEN iffD2 [THEN mult_le_mono1]])
     done
   have **: "0 < sc \<Longrightarrow> sc - n + (n + lb * n) \<le> m * n \<longleftrightarrow> sc + lb * n \<le> m * n"
     for sc m n lb :: nat
     apply safe
      apply arith
     apply (case_tac "sc \<ge> n")
      apply arith
     apply (insert linorder_le_less_linear [of m lb])
     apply (erule_tac k=n and k'=n in *)
      apply arith
     apply simp
     done
   show ?thesis
     apply (induct n nw w bs rule: bin_rsplit_aux.induct)
     apply (subst bin_rsplit_aux.simps)
     apply (simp add: ** Let_def split: prod.split)
     done
 qed
 
 lemma bin_rsplit_len_le: "n \<noteq> 0 \<longrightarrow> ws = bin_rsplit n (nw, w) \<longrightarrow> length ws \<le> m \<longleftrightarrow> nw \<le> m * n"
   by (auto simp: bin_rsplit_def bin_rsplit_aux_len_le)
 
 lemma bin_rsplit_aux_len:
   "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit_aux n nw w cs) = (nw + n - 1) div n + length cs"
   apply (induct n nw w cs rule: bin_rsplit_aux.induct)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp simp: Let_def split: prod.split)
   apply (erule thin_rl)
   apply (case_tac m)
    apply simp
   apply (case_tac "m \<le> n")
    apply (auto simp add: div_add_self2)
   done
 
 lemma bin_rsplit_len: "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, w)) = (nw + n - 1) div n"
   by (auto simp: bin_rsplit_def bin_rsplit_aux_len)
 
 lemma bin_rsplit_aux_len_indep:
   "n \<noteq> 0 \<Longrightarrow> length bs = length cs \<Longrightarrow>
     length (bin_rsplit_aux n nw v bs) =
     length (bin_rsplit_aux n nw w cs)"
 proof (induct n nw w cs arbitrary: v bs rule: bin_rsplit_aux.induct)
   case (1 n m w cs v bs)
   show ?case
   proof (cases "m = 0")
     case True
     with \<open>length bs = length cs\<close> show ?thesis by simp
   next
     case False
     from "1.hyps" [of \<open>bin_split n w\<close> \<open>drop_bit n w\<close> \<open>take_bit n w\<close>] \<open>m \<noteq> 0\<close> \<open>n \<noteq> 0\<close>
     have hyp: "\<And>v bs. length bs = Suc (length cs) \<Longrightarrow>
       length (bin_rsplit_aux n (m - n) v bs) =
       length (bin_rsplit_aux n (m - n) (drop_bit n w) (take_bit n w # cs))"
       using bin_rsplit_aux_len by fastforce 
     from \<open>length bs = length cs\<close> \<open>n \<noteq> 0\<close> show ?thesis
       by (auto simp add: bin_rsplit_aux_simp_alt Let_def bin_rsplit_len split: prod.split)
   qed
 qed
 
 lemma bin_rsplit_len_indep:
   "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, v)) = length (bin_rsplit n (nw, w))"
   apply (unfold bin_rsplit_def)
   apply (simp (no_asm))
   apply (erule bin_rsplit_aux_len_indep)
   apply (rule refl)
   done
 
 
 subsection \<open>Logical operations\<close>
 
 primrec bin_sc :: "nat \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> int"
   where
     Z: "bin_sc 0 b w = of_bool b + 2 * bin_rest w"
   | Suc: "bin_sc (Suc n) b w = of_bool (odd w) + 2 * bin_sc n b (w div 2)"
 
 lemma bin_nth_sc [simp]: "bit (bin_sc n b w) n \<longleftrightarrow> b"
   by (induction n arbitrary: w) (simp_all add: bit_Suc)
 
 lemma bin_sc_sc_same [simp]: "bin_sc n c (bin_sc n b w) = bin_sc n c w"
   by (induction n arbitrary: w) (simp_all add: bit_Suc)
 
 lemma bin_sc_sc_diff: "m \<noteq> n \<Longrightarrow> bin_sc m c (bin_sc n b w) = bin_sc n b (bin_sc m c w)"
   apply (induct n arbitrary: w m)
    apply (case_tac [!] m)
      apply auto
   done
 
 lemma bin_nth_sc_gen: "bin_nth (bin_sc n b w) m = (if m = n then b else bin_nth w m)"
   apply (induct n arbitrary: w m)
    apply (case_tac m; simp add: bit_Suc)
   apply (case_tac m; simp add: bit_Suc)
   done
 
 lemma bin_sc_eq:
   \<open>bin_sc n False = unset_bit n\<close>
   \<open>bin_sc n True = Bit_Operations.set_bit n\<close>
   by (simp_all add: fun_eq_iff bit_eq_iff)
     (simp_all add: bin_nth_sc_gen bit_set_bit_iff bit_unset_bit_iff)
 
 lemma bin_sc_nth [simp]: "bin_sc n (bin_nth w n) w = w"
   by (rule bit_eqI) (simp add: bin_nth_sc_gen)
 
 lemma bin_sign_sc [simp]: "bin_sign (bin_sc n b w) = bin_sign w"
 proof (induction n arbitrary: w)
   case 0
   then show ?case
     by (auto simp add: bin_sign_def) (use bin_rest_ge_0 in fastforce)
 next
   case (Suc n)
   from Suc [of \<open>w div 2\<close>]
   show ?case by (auto simp add: bin_sign_def split: if_splits)
 qed
 
 lemma bin_sc_bintr [simp]:
   "bintrunc m (bin_sc n x (bintrunc m w)) = bintrunc m (bin_sc n x w)"
   apply (cases x)
    apply (simp_all add: bin_sc_eq bit_eq_iff)
    apply (auto simp add: bit_take_bit_iff bit_set_bit_iff bit_unset_bit_iff)
   done
 
 lemma bin_clr_le: "bin_sc n False w \<le> w"
   by (simp add: bin_sc_eq unset_bit_less_eq)
 
 lemma bin_set_ge: "bin_sc n True w \<ge> w"
   by (simp add: bin_sc_eq set_bit_greater_eq)
 
 lemma bintr_bin_clr_le: "bintrunc n (bin_sc m False w) \<le> bintrunc n w"
   by (simp add: bin_sc_eq take_bit_unset_bit_eq unset_bit_less_eq)
 
 lemma bintr_bin_set_ge: "bintrunc n (bin_sc m True w) \<ge> bintrunc n w"
   by (simp add: bin_sc_eq take_bit_set_bit_eq set_bit_greater_eq)
 
 lemma bin_sc_FP [simp]: "bin_sc n False 0 = 0"
   by (induct n) auto
 
 lemma bin_sc_TM [simp]: "bin_sc n True (- 1) = - 1"
   by (induct n) auto
 
 lemmas bin_sc_simps = bin_sc.Z bin_sc.Suc bin_sc_TM bin_sc_FP
 
 lemma bin_sc_minus: "0 < n \<Longrightarrow> bin_sc (Suc (n - 1)) b w = bin_sc n b w"
   by auto
 
 lemmas bin_sc_Suc_minus =
   trans [OF bin_sc_minus [symmetric] bin_sc.Suc]
 
 lemma bin_sc_numeral [simp]:
   "bin_sc (numeral k) b w =
     of_bool (odd w) + 2 * bin_sc (pred_numeral k) b (w div 2)"
   by (simp add: numeral_eq_Suc)
 
 lemmas bin_sc_minus_simps =
   bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]
 
 instance int :: semiring_bit_syntax ..
 
 lemma test_bit_int_def [iff]:
   "i !! n \<longleftrightarrow> bin_nth i n"
   by (simp add: test_bit_eq_bit)
 
 lemma shiftl_int_def:
   "shiftl x n = x * 2 ^ n" for x :: int
   by (simp add: push_bit_int_def shiftl_eq_push_bit)
 
 lemma shiftr_int_def:
   "shiftr x n = x div 2 ^ n" for x :: int
   by (simp add: drop_bit_int_def shiftr_eq_drop_bit)
 
 
 subsubsection \<open>Basic simplification rules\<close>
 
 lemmas int_not_def = not_int_def
 
 lemma int_not_simps [simp]:
   "NOT (0::int) = -1"
   "NOT (1::int) = -2"
   "NOT (- 1::int) = 0"
   "NOT (numeral w::int) = - numeral (w + Num.One)"
   "NOT (- numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
   "NOT (- numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
   by (simp_all add: not_int_def)
 
 lemma int_not_not: "NOT (NOT x) = x"
   for x :: int
   by (fact bit.double_compl)
 
 lemma int_and_0 [simp]: "0 AND x = 0"
   for x :: int
   by (fact bit.conj_zero_left)
 
 lemma int_and_m1 [simp]: "-1 AND x = x"
   for x :: int
   by (fact bit.conj_one_left)
 
 lemma int_or_zero [simp]: "0 OR x = x"
   for x :: int
   by (fact bit.disj_zero_left)
 
 lemma int_or_minus1 [simp]: "-1 OR x = -1"
   for x :: int
   by (fact bit.disj_one_left)
 
 lemma int_xor_zero [simp]: "0 XOR x = x"
   for x :: int
   by (fact bit.xor_zero_left)
 
 
 subsubsection \<open>Binary destructors\<close>
 
 lemma bin_rest_NOT [simp]: "bin_rest (NOT x) = NOT (bin_rest x)"
   by (fact not_int_div_2)
 
 lemma bin_last_NOT [simp]: "bin_last (NOT x) \<longleftrightarrow> \<not> bin_last x"
   by simp
 
 lemma bin_rest_AND [simp]: "bin_rest (x AND y) = bin_rest x AND bin_rest y"
   by (subst and_int_rec) auto
 
 lemma bin_last_AND [simp]: "bin_last (x AND y) \<longleftrightarrow> bin_last x \<and> bin_last y"
   by (subst and_int_rec) auto
 
 lemma bin_rest_OR [simp]: "bin_rest (x OR y) = bin_rest x OR bin_rest y"
   by (subst or_int_rec) auto
 
 lemma bin_last_OR [simp]: "bin_last (x OR y) \<longleftrightarrow> bin_last x \<or> bin_last y"
   by (subst or_int_rec) auto
 
 lemma bin_rest_XOR [simp]: "bin_rest (x XOR y) = bin_rest x XOR bin_rest y"
   by (subst xor_int_rec) auto
 
 lemma bin_last_XOR [simp]: "bin_last (x XOR y) \<longleftrightarrow> (bin_last x \<or> bin_last y) \<and> \<not> (bin_last x \<and> bin_last y)"
   by (subst xor_int_rec) auto
 
 lemma bin_nth_ops:
   "\<And>x y. bin_nth (x AND y) n \<longleftrightarrow> bin_nth x n \<and> bin_nth y n"
   "\<And>x y. bin_nth (x OR y) n \<longleftrightarrow> bin_nth x n \<or> bin_nth y n"
   "\<And>x y. bin_nth (x XOR y) n \<longleftrightarrow> bin_nth x n \<noteq> bin_nth y n"
   "\<And>x. bin_nth (NOT x) n \<longleftrightarrow> \<not> bin_nth x n"
   by (simp_all add: bit_and_iff bit_or_iff bit_xor_iff bit_not_iff)
 
 
 subsubsection \<open>Derived properties\<close>
 
 lemma int_xor_minus1 [simp]: "-1 XOR x = NOT x"
   for x :: int
   by (fact bit.xor_one_left)
 
 lemma int_xor_extra_simps [simp]:
   "w XOR 0 = w"
   "w XOR -1 = NOT w"
   for w :: int
   by simp_all
 
 lemma int_or_extra_simps [simp]:
   "w OR 0 = w"
   "w OR -1 = -1"
   for w :: int
   by simp_all
 
 lemma int_and_extra_simps [simp]:
   "w AND 0 = 0"
   "w AND -1 = w"
   for w :: int
   by simp_all
 
 text \<open>Commutativity of the above.\<close>
 lemma bin_ops_comm:
   fixes x y :: int
   shows int_and_comm: "x AND y = y AND x"
     and int_or_comm:  "x OR y = y OR x"
     and int_xor_comm: "x XOR y = y XOR x"
   by (simp_all add: ac_simps)
 
 lemma bin_ops_same [simp]:
   "x AND x = x"
   "x OR x = x"
   "x XOR x = 0"
   for x :: int
   by simp_all
 
 lemmas bin_log_esimps =
   int_and_extra_simps  int_or_extra_simps  int_xor_extra_simps
   int_and_0 int_and_m1 int_or_zero int_or_minus1 int_xor_zero int_xor_minus1
 
 
 subsubsection \<open>Basic properties of logical (bit-wise) operations\<close>
 
 lemma bbw_ao_absorb: "x AND (y OR x) = x \<and> x OR (y AND x) = x"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_ao_absorbs_other:
   "x AND (x OR y) = x \<and> (y AND x) OR x = x"
   "(y OR x) AND x = x \<and> x OR (x AND y) = x"
   "(x OR y) AND x = x \<and> (x AND y) OR x = x"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemmas bbw_ao_absorbs [simp] = bbw_ao_absorb bbw_ao_absorbs_other
 
 lemma int_xor_not: "(NOT x) XOR y = NOT (x XOR y) \<and> x XOR (NOT y) = NOT (x XOR y)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_and_assoc: "(x AND y) AND z = x AND (y AND z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_or_assoc: "(x OR y) OR z = x OR (y OR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_xor_assoc: "(x XOR y) XOR z = x XOR (y XOR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemmas bbw_assocs = int_and_assoc int_or_assoc int_xor_assoc
 
 (* BH: Why are these declared as simp rules??? *)
 lemma bbw_lcs [simp]:
   "y AND (x AND z) = x AND (y AND z)"
   "y OR (x OR z) = x OR (y OR z)"
   "y XOR (x XOR z) = x XOR (y XOR z)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_not_dist:
   "NOT (x OR y) = (NOT x) AND (NOT y)"
   "NOT (x AND y) = (NOT x) OR (NOT y)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_oa_dist: "(x AND y) OR z = (x OR z) AND (y OR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_ao_dist: "(x OR y) AND z = (x AND z) OR (y AND z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 (*
 Why were these declared simp???
 declare bin_ops_comm [simp] bbw_assocs [simp]
 *)
 
 
 subsubsection \<open>Simplification with numerals\<close>
 
 text \<open>Cases for \<open>0\<close> and \<open>-1\<close> are already covered by other simp rules.\<close>
 
 lemma bin_rest_neg_numeral_BitM [simp]:
   "bin_rest (- numeral (Num.BitM w)) = - numeral w"
   by simp
 
 lemma bin_last_neg_numeral_BitM [simp]:
   "bin_last (- numeral (Num.BitM w))"
   by simp
 
 
 subsubsection \<open>Interactions with arithmetic\<close>
 
 lemma le_int_or: "bin_sign y = 0 \<Longrightarrow> x \<le> x OR y"
   for x y :: int
   by (simp add: bin_sign_def or_greater_eq split: if_splits)
 
 lemmas int_and_le =
   xtrans(3) [OF bbw_ao_absorbs (2) [THEN conjunct2, symmetric] le_int_or]
 
 text \<open>Interaction between bit-wise and arithmetic: good example of \<open>bin_induction\<close>.\<close>
 lemma bin_add_not: "x + NOT x = (-1::int)"
   by (simp add: not_int_def)
 
 lemma AND_mod: "x AND (2 ^ n - 1) = x mod 2 ^ n"
   for x :: int
   by (simp flip: take_bit_eq_mod add: take_bit_eq_mask mask_eq_exp_minus_1)
 
 
 subsubsection \<open>Truncating results of bit-wise operations\<close>
 
 lemma bin_trunc_ao:
   "bintrunc n x AND bintrunc n y = bintrunc n (x AND y)"
   "bintrunc n x OR bintrunc n y = bintrunc n (x OR y)"
   by simp_all
 
 lemma bin_trunc_xor: "bintrunc n (bintrunc n x XOR bintrunc n y) = bintrunc n (x XOR y)"
   by simp
 
 lemma bin_trunc_not: "bintrunc n (NOT (bintrunc n x)) = bintrunc n (NOT x)"
   by (fact take_bit_not_take_bit)
 
 text \<open>Want theorems of the form of \<open>bin_trunc_xor\<close>.\<close>
 lemma bintr_bintr_i: "x = bintrunc n y \<Longrightarrow> bintrunc n x = bintrunc n y"
   by auto
 
 lemmas bin_trunc_and = bin_trunc_ao(1) [THEN bintr_bintr_i]
 lemmas bin_trunc_or = bin_trunc_ao(2) [THEN bintr_bintr_i]
 
 
 subsubsection \<open>More lemmas\<close>
 
 lemma not_int_cmp_0 [simp]:
   fixes i :: int shows
   "0 < NOT i \<longleftrightarrow> i < -1"
   "0 \<le> NOT i \<longleftrightarrow> i < 0"
   "NOT i < 0 \<longleftrightarrow> i \<ge> 0"
   "NOT i \<le> 0 \<longleftrightarrow> i \<ge> -1"
 by(simp_all add: int_not_def) arith+
 
 lemma bbw_ao_dist2: "(x :: int) AND (y OR z) = x AND y OR x AND z"
   by (fact bit.conj_disj_distrib)
 
 lemmas int_and_ac = bbw_lcs(1) int_and_comm int_and_assoc
 
 lemma int_nand_same [simp]: fixes x :: int shows "x AND NOT x = 0"
   by simp
 
 lemma int_nand_same_middle: fixes x :: int shows "x AND y AND NOT x = 0"
   by (simp add: bit_eq_iff bit_and_iff bit_not_iff)
 
 lemma and_xor_dist: fixes x :: int shows
   "x AND (y XOR z) = (x AND y) XOR (x AND z)"
   by (fact bit.conj_xor_distrib)
 
 lemma int_and_lt0 [simp]:
   \<open>x AND y < 0 \<longleftrightarrow> x < 0 \<and> y < 0\<close> for x y :: int
   by (fact and_negative_int_iff)
 
 lemma int_and_ge0 [simp]: 
   \<open>x AND y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<or> y \<ge> 0\<close> for x y :: int
   by (fact and_nonnegative_int_iff)
   
 lemma int_and_1: fixes x :: int shows "x AND 1 = x mod 2"
   by (fact and_one_eq)
 
 lemma int_1_and: fixes x :: int shows "1 AND x = x mod 2"
   by (fact one_and_eq)
 
 lemma int_or_lt0 [simp]: 
   \<open>x OR y < 0 \<longleftrightarrow> x < 0 \<or> y < 0\<close> for x y :: int
   by (fact or_negative_int_iff)
 
 lemma int_or_ge0 [simp]:
   \<open>x OR y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<and> y \<ge> 0\<close> for x y :: int
   by (fact or_nonnegative_int_iff)
   
 lemma int_xor_lt0 [simp]:
   \<open>x XOR y < 0 \<longleftrightarrow> (x < 0) \<noteq> (y < 0)\<close> for x y :: int
   by (fact xor_negative_int_iff)
 
 lemma int_xor_ge0 [simp]:
   \<open>x XOR y \<ge> 0 \<longleftrightarrow> (x \<ge> 0 \<longleftrightarrow> y \<ge> 0)\<close> for x y :: int
   by (fact xor_nonnegative_int_iff)
   
 lemma even_conv_AND:
   \<open>even i \<longleftrightarrow> i AND 1 = 0\<close> for i :: int
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bin_last_conv_AND:
   "bin_last i \<longleftrightarrow> i AND 1 \<noteq> 0"
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bitval_bin_last:
   "of_bool (bin_last i) = i AND 1"
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bin_sign_and:
   "bin_sign (i AND j) = - (bin_sign i * bin_sign j)"
 by(simp add: bin_sign_def)
 
 lemma int_not_neg_numeral: "NOT (- numeral n) = (Num.sub n num.One :: int)"
 by(simp add: int_not_def)
 
 lemma int_neg_numeral_pOne_conv_not: "- numeral (n + num.One) = (NOT (numeral n) :: int)"
 by(simp add: int_not_def)
 
 
 subsection \<open>Setting and clearing bits\<close>
 
 lemma int_shiftl_BIT: fixes x :: int
   shows int_shiftl0 [simp]: "x << 0 = x"
   and int_shiftl_Suc [simp]: "x << Suc n = 2 * (x << n)"
   by (auto simp add: shiftl_int_def)
 
 lemma int_0_shiftl [simp]: "0 << n = (0 :: int)"
 by(induct n) simp_all
 
 lemma bin_last_shiftl: "bin_last (x << n) \<longleftrightarrow> n = 0 \<and> bin_last x"
 by(cases n)(simp_all)
 
 lemma bin_rest_shiftl: "bin_rest (x << n) = (if n > 0 then x << (n - 1) else bin_rest x)"
 by(cases n)(simp_all)
 
 lemma bin_nth_shiftl [simp]: "bin_nth (x << n) m \<longleftrightarrow> n \<le> m \<and> bin_nth x (m - n)"
   by (simp add: bit_push_bit_iff_int shiftl_eq_push_bit)
 
 lemma bin_last_shiftr: "odd (x >> n) \<longleftrightarrow> x !! n" for x :: int
   by (simp add: shiftr_eq_drop_bit bit_iff_odd_drop_bit)
 
 lemma bin_rest_shiftr [simp]: "bin_rest (x >> n) = x >> Suc n"
   by (simp add: bit_eq_iff shiftr_eq_drop_bit drop_bit_Suc bit_drop_bit_eq drop_bit_half)
 
 lemma bin_nth_shiftr [simp]: "bin_nth (x >> n) m = bin_nth x (n + m)"
   by (simp add: shiftr_eq_drop_bit bit_drop_bit_eq)
 
 lemma bin_nth_conv_AND:
   fixes x :: int shows 
   "bin_nth x n \<longleftrightarrow> x AND (1 << n) \<noteq> 0"
   by (simp add: bit_eq_iff)
     (auto simp add: shiftl_eq_push_bit bit_and_iff bit_push_bit_iff bit_exp_iff)
 
 lemma int_shiftl_numeral [simp]: 
   "(numeral w :: int) << numeral w' = numeral (num.Bit0 w) << pred_numeral w'"
   "(- numeral w :: int) << numeral w' = - numeral (num.Bit0 w) << pred_numeral w'"
 by(simp_all add: numeral_eq_Suc shiftl_int_def)
   (metis add_One mult_inc semiring_norm(11) semiring_norm(13) semiring_norm(2) semiring_norm(6) semiring_norm(87))+
 
 lemma int_shiftl_One_numeral [simp]:
   "(1 :: int) << numeral w = 2 << pred_numeral w"
   using int_shiftl_numeral [of Num.One w] by simp
 
 lemma shiftl_ge_0 [simp]: fixes i :: int shows "i << n \<ge> 0 \<longleftrightarrow> i \<ge> 0"
 by(induct n) simp_all
 
 lemma shiftl_lt_0 [simp]: fixes i :: int shows "i << n < 0 \<longleftrightarrow> i < 0"
 by (metis not_le shiftl_ge_0)
 
 lemma int_shiftl_test_bit: "(n << i :: int) !! m \<longleftrightarrow> m \<ge> i \<and> n !! (m - i)"
   by simp
 
 lemma int_0shiftr [simp]: "(0 :: int) >> x = 0"
 by(simp add: shiftr_int_def)
 
 lemma int_minus1_shiftr [simp]: "(-1 :: int) >> x = -1"
 by(simp add: shiftr_int_def div_eq_minus1)
 
 lemma int_shiftr_ge_0 [simp]: fixes i :: int shows "i >> n \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by (simp add: shiftr_eq_drop_bit)
 
 lemma int_shiftr_lt_0 [simp]: fixes i :: int shows "i >> n < 0 \<longleftrightarrow> i < 0"
 by (metis int_shiftr_ge_0 not_less)
 
 lemma int_shiftr_numeral [simp]:
   "(1 :: int) >> numeral w' = 0"
   "(numeral num.One :: int) >> numeral w' = 0"
   "(numeral (num.Bit0 w) :: int) >> numeral w' = numeral w >> pred_numeral w'"
   "(numeral (num.Bit1 w) :: int) >> numeral w' = numeral w >> pred_numeral w'"
   "(- numeral (num.Bit0 w) :: int) >> numeral w' = - numeral w >> pred_numeral w'"
   "(- numeral (num.Bit1 w) :: int) >> numeral w' = - numeral (Num.inc w) >> pred_numeral w'"
   by (simp_all add: shiftr_eq_drop_bit numeral_eq_Suc add_One drop_bit_Suc)
 
 lemma int_shiftr_numeral_Suc0 [simp]:
   "(1 :: int) >> Suc 0 = 0"
   "(numeral num.One :: int) >> Suc 0 = 0"
   "(numeral (num.Bit0 w) :: int) >> Suc 0 = numeral w"
   "(numeral (num.Bit1 w) :: int) >> Suc 0 = numeral w"
   "(- numeral (num.Bit0 w) :: int) >> Suc 0 = - numeral w"
   "(- numeral (num.Bit1 w) :: int) >> Suc 0 = - numeral (Num.inc w)"
   by (simp_all add: shiftr_eq_drop_bit drop_bit_Suc add_One)
 
 lemma bin_nth_minus_p2:
   assumes sign: "bin_sign x = 0"
   and y: "y = 1 << n"
   and m: "m < n"
   and x: "x < y"
   shows "bin_nth (x - y) m = bin_nth x m"
 proof -
   from sign y x have \<open>x \<ge> 0\<close> and \<open>y = 2 ^ n\<close> and \<open>x < 2 ^ n\<close>
     by (simp_all add: bin_sign_def shiftl_eq_push_bit push_bit_eq_mult split: if_splits)
   from \<open>0 \<le> x\<close> \<open>x < 2 ^ n\<close> \<open>m < n\<close> have \<open>bit x m \<longleftrightarrow> bit (x - 2 ^ n) m\<close>
   proof (induction m arbitrary: x n)
     case 0
     then show ?case
       by simp
   next
     case (Suc m)
     moreover define q where \<open>q = n - 1\<close>
     ultimately have n: \<open>n = Suc q\<close>
       by simp
     have \<open>(x - 2 ^ Suc q) div 2 = x div 2 - 2 ^ q\<close>
       by simp
     moreover from Suc.IH [of \<open>x div 2\<close> q] Suc.prems
     have \<open>bit (x div 2) m \<longleftrightarrow> bit (x div 2 - 2 ^ q) m\<close>
       by (simp add: n)
     ultimately show ?case
       by (simp add: bit_Suc n)
   qed
   with \<open>y = 2 ^ n\<close> show ?thesis
     by simp
 qed
 
 lemma bin_clr_conv_NAND:
   "bin_sc n False i = i AND NOT (1 << n)"
   by (induct n arbitrary: i) (rule bin_rl_eqI; simp)+
 
 lemma bin_set_conv_OR:
   "bin_sc n True i = i OR (1 << n)"
   by (induct n arbitrary: i) (rule bin_rl_eqI; simp)+
 
 
 subsection \<open>More lemmas on words\<close>
 
 lemma word_rcat_eq:
   \<open>word_rcat ws = word_of_int (bin_rcat (LENGTH('a::len)) (map uint ws))\<close>
   for ws :: \<open>'a::len word list\<close>
   apply (simp add: word_rcat_def bin_rcat_def rev_map)
   apply transfer
   apply (simp add: horner_sum_foldr foldr_map comp_def)
   done
 
 lemma sign_uint_Pls [simp]: "bin_sign (uint x) = 0"
   by (simp add: sign_Pls_ge_0)
 
 lemmas bin_log_bintrs = bin_trunc_not bin_trunc_xor bin_trunc_and bin_trunc_or
 
 \<comment> \<open>following definitions require both arithmetic and bit-wise word operations\<close>
 
 \<comment> \<open>to get \<open>word_no_log_defs\<close> from \<open>word_log_defs\<close>, using \<open>bin_log_bintrs\<close>\<close>
 lemmas wils1 = bin_log_bintrs [THEN word_of_int_eq_iff [THEN iffD2],
   folded uint_word_of_int_eq, THEN eq_reflection]
 
 \<comment> \<open>the binary operations only\<close>  (* BH: why is this needed? *)
 lemmas word_log_binary_defs =
   word_and_def word_or_def word_xor_def
 
 lemma setBit_no [simp]: "setBit (numeral bin) n = word_of_int (bin_sc n True (numeral bin))"
   by transfer (simp add: bin_sc_eq)
  
 lemma clearBit_no [simp]:
   "clearBit (numeral bin) n = word_of_int (bin_sc n False (numeral bin))"
   by transfer (simp add: bin_sc_eq)
 
 lemma eq_mod_iff: "0 < n \<Longrightarrow> b = b mod n \<longleftrightarrow> 0 \<le> b \<and> b < n"
   for b n :: int
   by auto (metis pos_mod_conj)+
 
 lemma split_uint_lem: "bin_split n (uint w) = (a, b) \<Longrightarrow>
     a = take_bit (LENGTH('a) - n) a \<and> b = take_bit (LENGTH('a)) b"
   for w :: "'a::len word"
   by transfer (simp add: drop_bit_take_bit ac_simps)
 
 \<comment> \<open>limited hom result\<close>
 lemma word_cat_hom:
   "LENGTH('a::len) \<le> LENGTH('b::len) + LENGTH('c::len) \<Longrightarrow>
     (word_cat (word_of_int w :: 'b word) (b :: 'c word) :: 'a word) =
     word_of_int (bin_cat w (size b) (uint b))"
   by transfer (simp add: take_bit_concat_bit_eq)
 
 lemma bintrunc_shiftl:
   "take_bit n (m << i) = take_bit (n - i) m << i"
   for m :: int
   by (rule bit_eqI) (auto simp add: bit_take_bit_iff)
 
 lemma uint_shiftl:
   "uint (n << i) = take_bit (size n) (uint n << i)"
   by transfer (simp add: push_bit_take_bit shiftl_eq_push_bit)
 
 lemma bin_mask_conv_pow2:
   "mask n = 2 ^ n - (1 :: int)"
   by (fact mask_eq_exp_minus_1)
   
 lemma bin_mask_ge0: "mask n \<ge> (0 :: int)"
   by (fact mask_nonnegative_int)
 
 lemma and_bin_mask_conv_mod: "x AND mask n = x mod 2 ^ n"
   for x :: int
   by (simp flip: take_bit_eq_mod add: take_bit_eq_mask)
 
 lemma bin_mask_numeral: 
   "mask (numeral n) = (1 :: int) + 2 * mask (pred_numeral n)"
   by (fact mask_numeral)
 
 lemma bin_nth_mask [simp]: "bit (mask n :: int) i \<longleftrightarrow> i < n"
   by (simp add: bit_mask_iff)
 
 lemma bin_sign_mask [simp]: "bin_sign (mask n) = 0"
   by (simp add: bin_sign_def bin_mask_conv_pow2)
 
 lemma bin_mask_p1_conv_shift: "mask n + 1 = (1 :: int) << n"
   by (simp add: bin_mask_conv_pow2 shiftl_int_def)
 
+lemma sbintrunc_eq_in_range:
+  "(sbintrunc n x = x) = (x \<in> range (sbintrunc n))"
+  "(x = sbintrunc n x) = (x \<in> range (sbintrunc n))"
+  apply (simp_all add: image_def)
+  apply (metis sbintrunc_sbintrunc)+
+  done
+
+lemma sbintrunc_If:
+  "- 3 * (2 ^ n) \<le> x \<and> x < 3 * (2 ^ n)
+    \<Longrightarrow> sbintrunc n x = (if x < - (2 ^ n) then x + 2 * (2 ^ n)
+        else if x \<ge> 2 ^ n then x - 2 * (2 ^ n) else x)"
+  apply (simp add: no_sbintr_alt2, safe)
+   apply (simp add: mod_pos_geq)
+  apply (subst mod_add_self1[symmetric], simp)
+  done
+
+lemma sint_range':
+  \<open>- (2 ^ (LENGTH('a) - Suc 0)) \<le> sint x \<and> sint x < 2 ^ (LENGTH('a) - Suc 0)\<close>
+  for x :: \<open>'a::len word\<close>
+  apply transfer
+  using sbintr_ge sbintr_lt apply auto
+  done
+
+lemma signed_arith_eq_checks_to_ord:
+  "(sint a + sint b = sint (a + b ))
+    = ((a <=s a + b) = (0 <=s b))"
+  "(sint a - sint b = sint (a - b ))
+    = ((0 <=s a - b) = (b <=s a))"
+  "(- sint a = sint (- a)) = (0 <=s (- a) = (a <=s 0))"
+  using sint_range'[where x=a] sint_range'[where x=b]
+  by (simp_all add: sint_word_ariths word_sle_eq word_sless_alt sbintrunc_If)
+
+lemma signed_mult_eq_checks_double_size:
+  assumes mult_le: "(2 ^ (len_of TYPE ('a) - 1) + 1) ^ 2 \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
+           and le: "2 ^ (LENGTH('a) - 1) \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
+  shows "(sint (a :: 'a :: len word) * sint b = sint (a * b))
+       = (scast a * scast b = (scast (a * b) :: 'b :: len word))"
+proof -
+  have P: "sbintrunc (size a - 1) (sint a * sint b) \<in> range (sbintrunc (size a - 1))"
+    by simp
+
+  have abs: "!! x :: 'a word. abs (sint x) < 2 ^ (size a - 1) + 1"
+    apply (cut_tac x=x in sint_range')
+    apply (simp add: abs_le_iff word_size)
+    done
+  have abs_ab: "abs (sint a * sint b) < 2 ^ (LENGTH('b) - 1)"
+    using abs_mult_less[OF abs[where x=a] abs[where x=b]] mult_le
+    by (simp add: abs_mult power2_eq_square word_size)
+  define r s where \<open>r = LENGTH('a) - 1\<close> \<open>s = LENGTH('b) - 1\<close>
+  then have \<open>LENGTH('a) = Suc r\<close> \<open>LENGTH('b) = Suc s\<close>
+    \<open>size a = Suc r\<close> \<open>size b = Suc r\<close>
+    by (simp_all add: word_size)
+  then show ?thesis
+    using P[unfolded range_sbintrunc] abs_ab le
+    apply clarsimp
+    apply (transfer fixing: r s)
+    apply (auto simp add: signed_take_bit_int_eq_self simp flip: signed_take_bit_eq_iff_take_bit_eq)
+    done
+qed
+
 code_identifier
   code_module Bits_Int \<rightharpoonup>
   (SML) Bit_Operations and (OCaml) Bit_Operations and (Haskell) Bit_Operations and (Scala) Bit_Operations
 
 end
diff --git a/thys/Word_Lib/Even_More_List.thy b/thys/Word_Lib/Even_More_List.thy
--- a/thys/Word_Lib/Even_More_List.thy
+++ b/thys/Word_Lib/Even_More_List.thy
@@ -1,151 +1,155 @@
 
 section \<open>Lemmas on list operations\<close>
 
 theory Even_More_List
   imports
     Main
 begin
 
 lemma replicate_numeral [simp]: "replicate (numeral k) x = x # replicate (pred_numeral k) x"
   by (simp add: numeral_eq_Suc)
 
 lemma list_exhaust_size_gt0:
   assumes "\<And>a list. y = a # list \<Longrightarrow> P"
   shows "0 < length y \<Longrightarrow> P"
   apply (cases y)
    apply simp
   apply (rule assms)
   apply fastforce
   done
 
 lemma list_exhaust_size_eq0:
   assumes "y = [] \<Longrightarrow> P"
   shows "length y = 0 \<Longrightarrow> P"
   apply (cases y)
    apply (rule assms)
    apply simp
   apply simp
   done
 
 lemma size_Cons_lem_eq: "y = xa # list \<Longrightarrow> size y = Suc k \<Longrightarrow> size list = k"
   by auto
 
 lemma takeWhile_take_has_property:
   "n \<le> length (takeWhile P xs) \<Longrightarrow> \<forall>x \<in> set (take n xs). P x"
   by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)
 
 lemma takeWhile_take_has_property_nth:
   "\<lbrakk> n < length (takeWhile P xs) \<rbrakk> \<Longrightarrow> P (xs ! n)"
   by (induct xs arbitrary: n; simp split: if_split_asm) (case_tac n, simp_all)
 
 lemma takeWhile_replicate:
   "takeWhile f (replicate len x) = (if f x then replicate len x else [])"
   by (induct_tac len) auto
 
 lemma takeWhile_replicate_empty:
   "\<not> f x \<Longrightarrow> takeWhile f (replicate len x) = []"
   by (simp add: takeWhile_replicate)
 
 lemma takeWhile_replicate_id:
   "f x \<Longrightarrow> takeWhile f (replicate len x) = replicate len x"
   by (simp add: takeWhile_replicate)
 
 lemma nth_rev: "n < length xs \<Longrightarrow> rev xs ! n = xs ! (length xs - 1 - n)"
   using rev_nth by simp
 
 lemma nth_rev_alt: "n < length ys \<Longrightarrow> ys ! n = rev ys ! (length ys - Suc n)"
   by (simp add: nth_rev)
 
 lemma hd_butlast: "length xs > 1 \<Longrightarrow> hd (butlast xs) = hd xs"
   by (cases xs) auto
 
 lemma upt_add_eq_append':
   assumes "i \<le> j" and "j \<le> k"
   shows "[i..<k] = [i..<j] @ [j..<k]"
   using assms le_Suc_ex upt_add_eq_append by blast
 
 lemma split_upt_on_n:
   "n < m \<Longrightarrow> [0 ..< m] = [0 ..< n] @ [n] @ [Suc n ..< m]"
   by (metis append_Cons append_Nil less_Suc_eq_le less_imp_le_nat upt_add_eq_append'
             upt_rec zero_less_Suc)
 
 lemma length_takeWhile_less:
   "\<exists>x\<in>set xs. \<not> P x \<Longrightarrow> length (takeWhile P xs) < length xs"
   by (induct xs) (auto split: if_splits)
 
 lemma drop_eq_mono:
   assumes le: "m \<le> n"
   assumes drop: "drop m xs = drop m ys"
   shows "drop n xs = drop n ys"
 proof -
   have ex: "\<exists>p. n = p + m" by (rule exI[of _ "n - m"]) (simp add: le)
   then obtain p where p: "n = p + m" by blast
   show ?thesis unfolding p drop_drop[symmetric] drop by simp
 qed
 
 lemma drop_Suc_nth:
   "n < length xs \<Longrightarrow> drop n xs = xs!n # drop (Suc n) xs"
   by (simp add: Cons_nth_drop_Suc)
 
 lemma and_len: "xs = ys \<Longrightarrow> xs = ys \<and> length xs = length ys"
   by auto
 
 lemma tl_if: "tl (if p then xs else ys) = (if p then tl xs else tl ys)"
   by auto
 
 lemma hd_if: "hd (if p then xs else ys) = (if p then hd xs else hd ys)"
   by auto
 
 lemma if_single: "(if xc then [xab] else [an]) = [if xc then xab else an]"
   by auto
 
 \<comment> \<open>note -- \<open>if_Cons\<close> can cause blowup in the size, if \<open>p\<close> is complex, so make a simproc\<close>
 lemma if_Cons: "(if p then x # xs else y # ys) = If p x y # If p xs ys"
   by auto
 
 lemma list_of_false:
   "True \<notin> set xs \<Longrightarrow> xs = replicate (length xs) False"
   by (induct xs, simp_all)
 
 lemma map_idem_upt_eq:
   \<open>map f [m..<n] = [m..<n]\<close> if \<open>\<And>q. m \<le> q \<Longrightarrow> q < n \<Longrightarrow> f q = q\<close>
 proof (cases \<open>n \<ge> m\<close>)
   case False
   then show ?thesis
     by simp
 next
   case True
   moreover define r where \<open>r = n - m\<close>
   ultimately have \<open>n = m + r\<close>
     by simp
   with that have \<open>\<And>q. m \<le> q \<Longrightarrow> q < m + r \<Longrightarrow> f q = q\<close>
     by simp
   then have \<open>map f [m..<m + r] = [m..<m + r]\<close>
     by (induction r) simp_all
   with \<open>n = m + r\<close> show ?thesis
     by simp
 qed
 
 lemma upt_zero_numeral_unfold:
   \<open>[0..<numeral n] = [0..<pred_numeral n] @ [pred_numeral n]\<close>
   by (simp add: numeral_eq_Suc)
 
 lemma list_all2_induct [consumes 1, case_names Nil Cons]:
   assumes lall: "list_all2 Q xs ys"
   and     nilr: "P [] []"
   and    consr: "\<And>x xs y ys. \<lbrakk>list_all2 Q xs ys; Q x y; P xs ys\<rbrakk> \<Longrightarrow> P (x # xs) (y # ys)"
   shows  "P xs ys"
   using lall
 proof (induct rule: list_induct2 [OF list_all2_lengthD [OF lall]])
   case 1 then show ?case by auto fact+
 next
   case (2 x xs y ys)
 
   show ?case
   proof (rule consr)
     from "2.prems" show "list_all2 Q xs ys" and "Q x y" by simp_all
     then show "P xs ys" by (intro "2.hyps")
   qed
 qed
 
+lemma replicate_minus:
+  "k < n \<Longrightarrow> replicate n False = replicate (n - k) False @ replicate k False"
+  by (subst replicate_add [symmetric]) simp
+
 end
diff --git a/thys/Word_Lib/Guide.thy b/thys/Word_Lib/Guide.thy
--- a/thys/Word_Lib/Guide.thy
+++ b/thys/Word_Lib/Guide.thy
@@ -1,335 +1,348 @@
 (*<*)
 theory Guide
   imports Word_Lib_Sumo
 begin
 
 hide_const (open) Generic_set_bit.set_bit
 
 (*>*)
 section \<open>A short overview over bit operations and word types\<close>
 
 subsection \<open>Basic theories and key ideas\<close>
 
 text \<open>
   When formalizing bit operations, it is tempting to represent
   bit values as explicit lists over a binary type. This however
   is a bad idea, mainly due to the inherent ambiguities in
   representation concerning repeating leading bits.
 
   Hence this approach avoids such explicit lists altogether
   following an algebraic path:
 
     \<^item> Bit values are represented by numeric types: idealized
       unbounded bit values can be represented by type \<^typ>\<open>int\<close>,
       bounded bit values by quotient types over \<^typ>\<open>int\<close>, aka \<^typ>\<open>'a word\<close>.
 
     \<^item> (A special case are idealized unbounded bit values ending
       in @{term [source] 0} which can be represented by type \<^typ>\<open>nat\<close> but
       only support a restricted set of operations).
 
   The most fundamental ideas are developed in theory \<^theory>\<open>HOL.Parity\<close>
   (which is part of \<^theory>\<open>Main\<close>):
 
     \<^item> Multiplication by \<^term>\<open>2 :: int\<close> is a bit shift to the left and
 
     \<^item> Division by \<^term>\<open>2 :: int\<close> is a bit shift to the right.
 
     \<^item> Concerning bounded bit values, iterated shifts to the left
     may result in eliminating all bits by shifting them all
     beyond the boundary.  The property \<^prop>\<open>(2 :: int) ^ n \<noteq> 0\<close>
     represents that \<^term>\<open>n\<close> is \<^emph>\<open>not\<close> beyond that boundary.
 
     \<^item> The projection on a single bit is then @{thm [mode=iff] bit_iff_odd [where ?'a = int, no_vars]}.
 
     \<^item> This leads to the most fundamental properties of bit values:
 
       \<^item> Equality rule: @{thm [display, mode=iff] bit_eq_iff [where ?'a = int, no_vars]}
 
       \<^item> Induction rule: @{thm [display, mode=iff] bits_induct [where ?'a = int, no_vars]}
 
     \<^item> Characteristic properties \<^prop>\<open>bit (f x) n \<longleftrightarrow> P x n\<close>
       are available in fact collection \<^text>\<open>bit_simps\<close>.
 
   On top of this, the following generic operations are provided
   after import of theory \<^theory>\<open>HOL-Library.Bit_Operations\<close>:
 
     \<^item> Singleton \<^term>\<open>n\<close>th bit: \<^term>\<open>(2 :: int) ^ n\<close>
 
     \<^item> Bit mask upto bit \<^term>\<open>n\<close>: @{thm mask_eq_exp_minus_1 [where ?'a = int, no_vars]}
 
     \<^item> Left shift: @{thm push_bit_eq_mult [where ?'a = int, no_vars]}
 
     \<^item> Right shift: @{thm drop_bit_eq_div [where ?'a = int, no_vars]}
 
     \<^item> Truncation: @{thm take_bit_eq_mod [where ?'a = int, no_vars]}
 
     \<^item> Negation: @{thm [mode=iff] bit_not_iff [where ?'a = int, no_vars]}
 
     \<^item> And: @{thm [mode=iff] bit_and_iff [where ?'a = int, no_vars]}
 
     \<^item> Or: @{thm [mode=iff] bit_or_iff [where ?'a = int, no_vars]}
 
     \<^item> Xor: @{thm [mode=iff] bit_xor_iff [where ?'a = int, no_vars]}
 
     \<^item> Set a single bit: @{thm set_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Unset a single bit: @{thm unset_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Flip a single bit: @{thm flip_bit_def [where ?'a = int, no_vars]}
 
     \<^item> Signed truncation, or modulus centered around \<^term>\<open>0::int\<close>:
         @{thm [display] signed_take_bit_def [where ?'a = int, no_vars]}
 
     \<^item> (Bounded) conversion from and to a list of bits:
         @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}
 
   Proper word types are introduced in theory \<^theory>\<open>HOL-Library.Word\<close>, with
   the following specific operations:
 
     \<^item> Standard arithmetic:
         @{term \<open>(+) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>uminus :: 'a::len word \<Rightarrow> 'a word\<close>},
         @{term \<open>(-) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>(*) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>},
         @{term \<open>0 :: 'a::len word\<close>}, @{term \<open>1 :: 'a::len word\<close>}, numerals etc.
 
     \<^item> Standard bit operations: see above.
 
     \<^item> Conversion with unsigned interpretation of words:
 
         \<^item> @{term [source] \<open>unsigned :: 'a::len word \<Rightarrow> 'b::semiring_1\<close>}
 
         \<^item> Important special cases as abbreviations:
 
             \<^item> @{term [source] \<open>unat :: 'a::len word \<Rightarrow> nat\<close>}
 
             \<^item> @{term [source] \<open>uint :: 'a::len word \<Rightarrow> int\<close>}
 
             \<^item> @{term [source] \<open>ucast :: 'a::len word \<Rightarrow> 'b::len word\<close>}
 
     \<^item> Conversion with signed interpretation of words:
 
         \<^item> @{term [source] \<open>signed :: 'a::len word \<Rightarrow> 'b::ring_1\<close>}
 
         \<^item> Important special cases as abbreviations:
 
             \<^item> @{term [source] \<open>sint :: 'a::len word \<Rightarrow> int\<close>}
 
             \<^item> @{term [source] \<open>scast :: 'a::len word \<Rightarrow> 'b::len word\<close>}
 
     \<^item> Operations with unsigned interpretation of words:
 
         \<^item> @{thm [mode=iff] word_le_nat_alt [no_vars]}
 
         \<^item> @{thm [mode=iff] word_less_nat_alt [no_vars]}
 
         \<^item> @{thm unat_div_distrib [no_vars]}
 
         \<^item> @{thm unat_drop_bit_eq [no_vars]}
 
         \<^item> @{thm unat_mod_distrib [no_vars]}
 
         \<^item> @{thm [mode=iff] udvd_iff_dvd [no_vars]}
 
     \<^item> Operations with signed interpretation of words:
 
         \<^item> @{thm [mode=iff] word_sle_eq [no_vars]}
 
         \<^item> @{thm [mode=iff] word_sless_alt [no_vars]}
 
         \<^item> @{thm sint_signed_drop_bit_eq [no_vars]}
 
     \<^item> Rotation and reversal:
 
         \<^item> @{term [source] \<open>word_rotl :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_rotr :: nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_roti :: int \<Rightarrow> 'a::len word \<Rightarrow> 'a word\<close>}
 
         \<^item> @{term [source] \<open>word_reverse :: 'a::len word \<Rightarrow> 'a word\<close>}
 
     \<^item> Concatenation: @{term [source, display] \<open>word_cat :: 'a::len word \<Rightarrow> 'b::len word \<Rightarrow> 'c::len word\<close>}
 
   For proofs about words the following default strategies are applicable:
 
     \<^item> Using bit extensionality (facts \<^text>\<open>bit_eq_iff\<close>, \<^text>\<open>bit_eqI\<close>; fact
       collection \<^text>\<open>bit_simps\<close>).
 
     \<^item> Using the @{method transfer} method.
 \<close>
 
 subsection \<open>More library theories\<close>
 
 text \<open>
   Note: currently, the theories listed here are hardly separate
   entities since they import each other in various ways.
   Always inspect them to understand what you pull in if you
   want to import one.
 
     \<^descr>[Syntax]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Hex_Words\<close>]
         Printing word numerals as hexadecimal numerals.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Type_Syntax\<close>]
         Pretty type-sensitive syntax for cast operations.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_Syntax\<close>]
         Specific ASCII syntax for prominent bit operations on word.
 
     \<^descr>[Proof tools]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Norm_Words\<close>]
         Rewriting word numerals to normal forms.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Bitwise\<close>]
         Method @{method word_bitwise} decomposes word equalities and inequalities into bit propositions.
 
       \<^descr>[\<^theory>\<open>Word_Lib.Word_EqI\<close>]
         Method @{method word_eqI_solve} decomposes word equalities and inequalities into bit propositions.
 
     \<^descr>[Operations]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Signed_Division_Word\<close>]
 
         Signed division on word:
 
           \<^item> @{term [source] \<open>(sdiv) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}
 
           \<^item> @{term [source] \<open>(smod) :: 'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Aligned\<close>] \
 
           \<^item> @{thm [mode=iff] is_aligned_iff_udvd [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Least_significant_bit\<close>]
     
         The least significant bit as an alias:
         @{thm [mode=iff] lsb_odd [where ?'a = int, no_vars]}
     
       \<^descr>[\<^theory>\<open>Word_Lib.Most_significant_bit\<close>]
     
         The most significant bit:
     
           \<^item> @{thm [mode=iff] msb_int_def [of k]}
     
           \<^item> @{thm [mode=iff] word_msb_sint [no_vars]}
     
           \<^item> @{thm [mode=iff] msb_word_iff_sless_0 [no_vars]}
     
           \<^item> @{thm [mode=iff] msb_word_iff_bit [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Traditional_Infix_Syntax\<close>]
     
         Clones of existing operations decorated with
         traditional syntax:
     
           \<^item> @{thm test_bit_eq_bit [no_vars]}
     
           \<^item> @{thm shiftl_eq_push_bit [no_vars]}
     
           \<^item> @{thm shiftr_eq_drop_bit [no_vars]}
 
           \<^item> @{thm sshiftr_eq [no_vars]}
 
       \<^descr>[\<^theory>\<open>Word_Lib.Next_and_Prev\<close>] \
 
           \<^item> @{thm word_next_unfold [no_vars]}
 
           \<^item> @{thm word_prev_unfold [no_vars]}
 
+      \<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]
+
+        More on explicit enumeration of word types.
+
       \<^descr>[\<^theory>\<open>Word_Lib.More_Word_Operations\<close>]
 
         Even more operations on word.
 
     \<^descr>[Types]
 
       \<^descr>[\<^theory>\<open>Word_Lib.Signed_Words\<close>]
 
           Formal tagging of word types with a \<^text>\<open>signed\<close> marker.
 
-    \<^descr>[Mechanisms]
-
-      \<^descr>[\<^theory>\<open>Word_Lib.Enumeration_Word\<close>]
-
-          More on explicit enumeration of word types.
-
     \<^descr>[Lemmas]
 
-      Collections of lemmas:
-
-      \<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>] generic.
-
-    \<^descr>[Lemmas]
+      \<^descr>[\<^theory>\<open>Word_Lib.More_Word\<close>]
 
-      Words of fixed length:
-
-      \<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>] for 8-bit words.
+          More lemmas on words.
 
-      \<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>] for 16-bit words.
+      \<^descr>[\<^theory>\<open>Word_Lib.Word_Lemmas\<close>]
 
-      \<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>] for 32-bit words.
+          More lemmas on words, covering many other theories mentioned here.
 
-      \<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>] for 64-bit words.
+    \<^descr>[Words of fixed length]
+
+      \<^descr>[\<^theory>\<open>Word_Lib.Word_8\<close>]
+
+          for 8-bit words.
+
+      \<^descr>[\<^theory>\<open>Word_Lib.Word_16\<close>]
+
+          for 16-bit words.
+
+      \<^descr>[\<^theory>\<open>Word_Lib.Word_32\<close>]
+
+          for 32-bit words.
+
+      \<^descr>[\<^theory>\<open>Word_Lib.Word_64\<close>]
+
+          for 64-bit words.
 \<close>
 
 
 subsection \<open>More library sessions\<close>
 
 text \<open>
   \<^descr>[\<^text>\<open>Native_Word\<close>] Makes machine words and machine arithmetic available for code generation.
   It provides a common abstraction that hides the differences between the different target languages.
   The code generator maps these operations to the APIs of the target languages.
 \<close>
 
 subsection \<open>Legacy theories\<close>
 
 text \<open>
   The following theories contain material which has been
   factored out since it is not recommended to use it in
   new applications, mostly because matters can be expressed
   succinctly using already existing operations.
 
   This section gives some indication how to migrate away
   from those theories.  However theorem coverage may still
   be terse in some cases.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Word_Lib_Sumo\<close>]
 
     An entry point importing any relevant theory in that session.  Intended
     for backward compatibility: start importing this theory when
     migrating applications to Isabelle2021, and later sort out
     what you really need.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Generic_set_bit\<close>]
 
     Kind of an alias: @{thm set_bit_eq [no_vars]}
 
   \<^descr>[\<^theory>\<open>Word_Lib.Typedef_Morphisms\<close>]
 
     A low-level extension to HOL typedef providing
     conversions along type morphisms.  The @{method transfer} method
     seems to be sufficient for most applications though.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Bit_Comprehension\<close>]
 
     Comprehension syntax for bit values over predicates
     \<^typ>\<open>nat \<Rightarrow> bool\<close>.  For \<^typ>\<open>'a::len word\<close>, straightforward
     alternatives exist; difficult to handle for \<^typ>\<open>int\<close>.
 
   \<^descr>[\<^theory>\<open>Word_Lib.Reversed_Bit_Lists\<close>]
 
     Representation of bit values as explicit list in
     \<^emph>\<open>reversed\<close> order.
 
     This should rarely be necessary: the \<^const>\<open>bit\<close> projection
     should be sufficient in most cases.  In case explicit lists
     are needed, existing operations can be used:
 
     @{thm [display] horner_sum_bit_eq_take_bit [where ?'a = int, no_vars]}
+
+  \<^descr>[\<^theory>\<open>Word_Lib.Many_More\<close>]
+
+    Collection of operations and theorems which are kept for backward
+    compatibility and not used in other theories in session \<^text>\<open>Word_Lib\<close>.
 \<close>
 
 (*<*)
 end
 (*>*)
diff --git a/thys/Word_Lib/Many_More.thy b/thys/Word_Lib/Many_More.thy
new file mode 100644
--- /dev/null
+++ b/thys/Word_Lib/Many_More.thy
@@ -0,0 +1,126 @@
+
+theory Many_More
+  imports
+    Main 
+    "HOL-Library.Word"
+    More_Word
+begin
+
+lemma nat_less_mult_monoish: "\<lbrakk> a < b; c < (d :: nat) \<rbrakk> \<Longrightarrow> (a + 1) * (c + 1) <= b * d"
+  apply (drule Suc_leI)+
+  apply (drule(1) mult_le_mono)
+  apply simp
+  done
+
+lemma if_and_helper:
+  "(If x v v') AND v'' = If x (v AND v'') (v' AND v'')"
+  by (rule if_distrib)
+
+lemma eq_eqI:
+  "a = b \<Longrightarrow> (a = x) = (b = x)"
+  by simp
+
+lemma map2_Cons_2_3:
+  "(map2 f xs (y # ys) = (z # zs)) = (\<exists>x xs'. xs = x # xs' \<and> f x y = z \<and> map2 f xs' ys = zs)"
+  by (case_tac xs, simp_all)
+
+lemma map2_xor_replicate_False:
+  "map2 (\<lambda>x y. x \<longleftrightarrow> \<not> y) xs (replicate n False) = take n xs"
+  apply (induct xs arbitrary: n, simp)
+  apply (case_tac n; simp)
+  done
+
+lemma plus_Collect_helper:
+  "(+) x ` {xa. P (xa :: 'a :: len word)} = {xa. P (xa - x)}"
+  by (fastforce simp add: image_def)
+
+lemma plus_Collect_helper2:
+  "(+) (- x) ` {xa. P (xa :: 'a :: len word)} = {xa. P (x + xa)}"
+  using plus_Collect_helper [of "- x" P] by (simp add: ac_simps)
+
+lemma range_subset_eq2:
+  "{a :: 'a :: len word .. b} \<noteq> {} \<Longrightarrow> ({a .. b} \<subseteq> {c .. d}) = (c \<le> a \<and> b \<le> d)"
+  by simp
+
+lemma nat_mod_power_lem:
+  fixes a :: nat
+  shows "1 < a \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
+  apply (clarsimp)
+  apply (clarsimp simp add: le_iff_add power_add)
+  done
+
+lemma i_hate_words_helper:
+  "i \<le> (j - k :: nat) \<Longrightarrow> i \<le> j"
+  by simp
+
+lemma i_hate_words:
+  "unat (a :: 'a word) \<le> unat (b :: 'a :: len word) - Suc 0
+    \<Longrightarrow> a \<noteq> -1"
+  apply (frule i_hate_words_helper)
+  apply (subst(asm) word_le_nat_alt[symmetric])
+  apply (clarsimp simp only: word_minus_one_le)
+  apply (simp only: linorder_not_less[symmetric])
+  apply (erule notE)
+  apply (rule diff_Suc_less)
+  apply (subst neq0_conv[symmetric])
+  apply (subst unat_eq_0)
+  apply (rule notI, drule arg_cong[where f="(+) 1"])
+  apply simp
+  done
+
+lemma If_eq_obvious:
+  "x \<noteq> z \<Longrightarrow> ((if P then x else y) = z) = (\<not> P \<and> y = z)"
+  by simp
+
+lemma Some_to_the:
+  "v = Some x \<Longrightarrow> x = the v"
+  by simp
+
+lemma dom_if_Some:
+  "dom (\<lambda>x. if P x then Some (f x) else g x) = {x. P x} \<union> dom g"
+  by fastforce
+
+lemma dom_insert_absorb:
+  "x \<in> dom f \<Longrightarrow> insert x (dom f) = dom f"
+  by (fact insert_absorb)
+
+lemma emptyE2:
+  "\<lbrakk> S = {}; x \<in> S \<rbrakk> \<Longrightarrow> P"
+  by simp
+
+lemma ptr_add_image_multI:
+  "\<lbrakk> \<And>x y. (x * val = y * val') = (x * val'' = y); x * val'' \<in> S \<rbrakk> \<Longrightarrow>
+     ptr_add ptr (x * val) \<in> (\<lambda>p. ptr_add ptr (p * val')) ` S"
+  by (auto simp add: image_iff) metis
+
+lemmas map_prod_split_imageI'
+  = map_prod_imageI[where f="case_prod f" and g="case_prod g"
+                    and a="(a, b)" and b="(c, d)" for a b c d f g]
+lemmas map_prod_split_imageI = map_prod_split_imageI'[simplified]
+
+lemma dom_if:
+  "dom (\<lambda>a. if a \<in> addrs then Some (f a) else g a)  = addrs \<union> dom g"
+  by (auto simp: dom_def split: if_split)
+
+lemmas arg_cong_Not = arg_cong [where f=Not]
+
+lemma drop_append_miracle:
+  "n = length xs \<Longrightarrow> drop n (xs @ ys) = ys"
+  by simp
+
+lemma foldr_does_nothing_to_xf:
+  "\<lbrakk> \<And>x s. x \<in> set xs \<Longrightarrow> xf (f x s) = xf s \<rbrakk> \<Longrightarrow> xf (foldr f xs s) = xf s"
+  by (induct xs, simp_all)
+
+lemma mod_mod_power_int:
+  fixes k :: int
+  shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
+  by (fact mod_exp_eq)
+
+lemma le_step_down_nat:"\<lbrakk>(i::nat) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by arith
+
+lemma le_step_down_int:"\<lbrakk>(i::int) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by arith
+
+end
diff --git a/thys/Word_Lib/More_Arithmetic.thy b/thys/Word_Lib/More_Arithmetic.thy
--- a/thys/Word_Lib/More_Arithmetic.thy
+++ b/thys/Word_Lib/More_Arithmetic.thy
@@ -1,334 +1,349 @@
 
 section \<open>Arithmetic lemmas\<close>
 
 theory More_Arithmetic
-  imports Main
+  imports Main "HOL-Library.Type_Length"
 begin
 
 declare iszero_0 [intro]
 
 declare min.absorb1 [simp] min.absorb2 [simp]
 
 lemma n_less_equal_power_2 [simp]:
   "n < 2 ^ n"
   by (induction n) simp_all
 
 lemma min_pm [simp]: "min a b + (a - b) = a"
   for a b :: nat
   by arith
 
 lemma min_pm1 [simp]: "a - b + min a b = a"
   for a b :: nat
   by arith
 
 lemma rev_min_pm [simp]: "min b a + (a - b) = a"
   for a b :: nat
   by arith
 
 lemma rev_min_pm1 [simp]: "a - b + min b a = a"
   for a b :: nat
   by arith
 
 lemma min_minus [simp]: "min m (m - k) = m - k"
   for m k :: nat
   by arith
 
 lemma min_minus' [simp]: "min (m - k) m = m - k"
   for m k :: nat
   by arith
 
 lemma nat_min_simps:
   "(a::nat) \<le> b \<Longrightarrow> min b a = a"
   "a \<le> b \<Longrightarrow> min a b = a"
   by simp_all
 
 lemma iszero_minus:
   \<open>iszero (- z) \<longleftrightarrow> iszero z\<close>
   by (simp add: iszero_def)
 
 lemma diff_le_eq': "a - b \<le> c \<longleftrightarrow> a \<le> b + c"
   for a b c :: int
   by arith
 
 lemma zless2: "0 < (2 :: int)"
   by (fact zero_less_numeral)
 
 lemma zless2p: "0 < (2 ^ n :: int)"
   by arith
 
 lemma zle2p: "0 \<le> (2 ^ n :: int)"
   by arith
 
 lemma ex_eq_or: "(\<exists>m. n = Suc m \<and> (m = k \<or> P m)) \<longleftrightarrow> n = Suc k \<or> (\<exists>m. n = Suc m \<and> P m)"
   by auto
 
 lemma power_minus_simp: "0 < n \<Longrightarrow> a ^ n = a * a ^ (n - 1)"
   by (auto dest: gr0_implies_Suc)
 
 lemma n2s_ths:
   \<open>2 + n = Suc (Suc n)\<close>
   \<open>n + 2 = Suc (Suc n)\<close>
   by (fact add_2_eq_Suc add_2_eq_Suc')+
 
 lemma s2n_ths:
   \<open>Suc (Suc n) = 2 + n\<close>
   \<open>Suc (Suc n) = n + 2\<close>
   by simp_all
 
 lemma gt_or_eq_0: "0 < y \<or> 0 = y"
   for y :: nat
   by arith
 
 lemmas nat_simps = diff_add_inverse2 diff_add_inverse
 
 lemmas nat_iffs = le_add1 le_add2
 
 lemma sum_imp_diff: "j = k + i \<Longrightarrow> j - i = k"
   for k :: nat
   by simp
 
 lemma le_diff_eq': "a \<le> c - b \<longleftrightarrow> b + a \<le> c"
   for a b c :: int
   by arith
 
 lemma less_diff_eq': "a < c - b \<longleftrightarrow> b + a < c"
   for a b c :: int
   by arith
 
 lemma diff_less_eq': "a - b < c \<longleftrightarrow> a < b + c"
   for a b c :: int
   by arith
 
 lemma axxbyy: "a + m + m = b + n + n \<Longrightarrow> a = 0 \<or> a = 1 \<Longrightarrow> b = 0 \<or> b = 1 \<Longrightarrow> a = b \<and> m = n"
   for a b m n :: int
   by arith
 
 lemmas zadd_diff_inverse =
   trans [OF diff_add_cancel [symmetric] add.commute]
 
 lemmas add_diff_cancel2 =
   add.commute [THEN diff_eq_eq [THEN iffD2]]
 
 lemmas mcl = mult_cancel_left [THEN iffD1, THEN make_pos_rule]
 
 lemma pl_pl_rels: "a + b = c + d \<Longrightarrow> a \<ge> c \<and> b \<le> d \<or> a \<le> c \<and> b \<ge> d"
   for a b c d :: nat
   by arith
 
 lemmas pl_pl_rels' = add.commute [THEN [2] trans, THEN pl_pl_rels]
 
 lemma minus_eq: "m - k = m \<longleftrightarrow> k = 0 \<or> m = 0"
   for k m :: nat
   by arith
 
 lemma pl_pl_mm: "a + b = c + d \<Longrightarrow> a - c = d - b"
   for a b c d :: nat
   by arith
 
 lemmas pl_pl_mm' = add.commute [THEN [2] trans, THEN pl_pl_mm]
 
 lemma less_le_mult': "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> (w + 1) * c \<le> b * c"
   for b c w :: int
   apply (rule mult_right_mono)
    apply (rule zless_imp_add1_zle)
    apply (erule (1) mult_right_less_imp_less)
   apply assumption
   done
 
 lemma less_le_mult: "w * c < b * c \<Longrightarrow> 0 \<le> c \<Longrightarrow> w * c + c \<le> b * c"
   for b c w :: int
   using less_le_mult' [of w c b] by (simp add: algebra_simps)
 
 lemmas less_le_mult_minus = iffD2 [OF le_diff_eq less_le_mult,
   simplified left_diff_distrib]
 
 lemma gen_minus: "0 < n \<Longrightarrow> f n = f (Suc (n - 1))"
   by auto
 
 lemma mpl_lem: "j \<le> i \<Longrightarrow> k < j \<Longrightarrow> i - j + k < i"
   for i j k :: nat
   by arith
 
 lemmas dme = div_mult_mod_eq
 lemmas dtle = div_times_less_eq_dividend
 lemmas th2 = order_trans [OF order_refl [THEN [2] mult_le_mono] div_times_less_eq_dividend]
 
 lemma td_gal: "0 < c \<Longrightarrow> a \<ge> b * c \<longleftrightarrow> a div c \<ge> b"
   for a b c :: nat
   apply safe
    apply (erule (1) xtrans(4) [OF div_le_mono div_mult_self_is_m])
   apply (erule th2)
   done
 
 lemmas td_gal_lt = td_gal [simplified not_less [symmetric], simplified]
 
 lemmas sdl = div_nat_eqI
 
 lemma given_quot: "f > 0 \<Longrightarrow> (f * l + (f - 1)) div f = l"
   for f l :: nat
   by (rule div_nat_eqI) (simp_all)
 
 lemma given_quot_alt: "f > 0 \<Longrightarrow> (l * f + f - Suc 0) div f = l"
   for f l :: nat
   apply (frule given_quot)
   apply (rule trans)
    prefer 2
    apply (erule asm_rl)
   apply (rule_tac f="\<lambda>n. n div f" in arg_cong)
   apply (simp add : ac_simps)
   done
 
 lemma nat_less_power_trans:
   fixes n :: nat
   assumes nv: "n < 2 ^ (m - k)"
   and     kv: "k \<le> m"
   shows "2 ^ k * n < 2 ^ m"
 proof (rule order_less_le_trans)
   show "2 ^ k * n < 2 ^ k * 2 ^ (m - k)"
     by (rule mult_less_mono2 [OF nv zero_less_power]) simp
 
   show "(2::nat) ^ k * 2 ^ (m - k) \<le> 2 ^ m" using nv kv
     by (subst power_add [symmetric]) simp
 qed
 
 lemma nat_le_power_trans:
   fixes n :: nat
   shows "\<lbrakk>n \<le> 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> 2 ^ k * n \<le> 2 ^ m"
   by (metis le_add_diff_inverse mult_le_mono2 semiring_normalization_rules(26))
 
 lemma x_power_minus_1:
   fixes x :: "'a :: {ab_group_add, power, numeral, one}"
   shows "x + (2::'a) ^ n - (1::'a) = x + (2 ^ n - 1)" by simp
 
 lemma nat_diff_add:
   fixes i :: nat
   shows "\<lbrakk> i + j = k \<rbrakk> \<Longrightarrow> i = k - j"
   by arith
 
 lemma pow_2_gt: "n \<ge> 2 \<Longrightarrow> (2::int) < 2 ^ n"
   by (induct n) auto
 
 lemma sum_to_zero:
   "(a :: 'a :: ring) + b = 0 \<Longrightarrow> a = (- b)"
   by (drule arg_cong[where f="\<lambda> x. x - a"], simp)
 
 lemma arith_is_1:
   "\<lbrakk> x \<le> Suc 0; x > 0 \<rbrakk> \<Longrightarrow> x = 1"
   by arith
 
 lemma suc_le_pow_2:
   "1 < (n::nat) \<Longrightarrow> Suc n < 2 ^ n"
   by (induct n; clarsimp)
      (case_tac "n = 1"; clarsimp)
 
 lemma nat_le_Suc_less_imp:
   "x < y \<Longrightarrow> x \<le> y - Suc 0"
   by arith
 
 lemma power_sub_int:
   "\<lbrakk> m \<le> n; 0 < b \<rbrakk> \<Longrightarrow> b ^ n div b ^ m = (b ^ (n - m) :: int)"
   apply (subgoal_tac "\<exists>n'. n = m + n'")
    apply (clarsimp simp: power_add)
   apply (rule exI[where x="n - m"])
   apply simp
   done
 
 lemma nat_Suc_less_le_imp:
   "(k::nat) < Suc n \<Longrightarrow> k \<le> n"
   by auto
 
 lemma nat_add_less_by_max:
   "\<lbrakk> (x::nat) \<le> xmax ; y < k - xmax \<rbrakk> \<Longrightarrow> x + y < k"
   by simp
 
 lemma nat_le_Suc_less:
   "0 < y \<Longrightarrow> (x \<le> y - Suc 0) = (x < y)"
   by arith
 
 lemma nat_power_minus_less:
   "a < 2 ^ (x - n) \<Longrightarrow> (a :: nat) < 2 ^ x"
   by (erule order_less_le_trans) simp
 
 lemma less_le_mult_nat':
   "w * c < b * c ==> 0 \<le> c ==> Suc w * c \<le> b * (c::nat)"
   apply (rule mult_right_mono)
    apply (rule Suc_leI)
    apply (erule (1) mult_right_less_imp_less)
   apply assumption
   done
 
 lemma less_le_mult_nat:
   \<open>0 < c \<and> w < b \<Longrightarrow> c + w * c \<le> b * c\<close> for b c w :: nat
   using less_le_mult_nat' [of w c b] by simp
 
 lemma diff_diff_less:
   "(i < m - (m - (n :: nat))) = (i < m \<and> i < n)"
   by auto
 
 lemma nat_add_offset_less:
   fixes x :: nat
   assumes yv: "y < 2 ^ n"
   and     xv: "x < 2 ^ m"
   and     mn: "sz = m + n"
   shows   "x * 2 ^ n + y < 2 ^ sz"
 proof (subst mn)
   from yv obtain qy where "y + qy = 2 ^ n" and "0 < qy"
     by (auto dest: less_imp_add_positive)
 
   have "x * 2 ^ n + y < x * 2 ^ n + 2 ^ n" by simp fact+
   also have "\<dots> = (x + 1) * 2 ^ n" by simp
   also have "\<dots> \<le> 2 ^ (m + n)" using xv
     by (subst power_add) (rule mult_le_mono1, simp)
   finally show "x * 2 ^ n + y < 2 ^ (m + n)" .
 qed
 
 lemma p_assoc_help:
   fixes p :: "'a::{ring,power,numeral,one}"
   shows "p + 2^sz - 1 = p + (2^sz - 1)"
   by simp
 
 lemma nat_power_less_diff:
   assumes lt: "(2::nat) ^ n * q < 2 ^ m"
   shows "q < 2 ^ (m - n)"
   using lt
 proof (induct n arbitrary: m)
   case 0
   then show ?case by simp
 next
   case (Suc n)
 
   have ih: "\<And>m. 2 ^ n * q < 2 ^ m \<Longrightarrow> q < 2 ^ (m - n)"
     and prem: "2 ^ Suc n * q < 2 ^ m" by fact+
 
   show ?case
   proof (cases m)
     case 0
     then show ?thesis using Suc by simp
   next
     case (Suc m')
     then show ?thesis using prem
       by (simp add: ac_simps ih)
   qed
 qed
 
 lemma pow_mono_leq_imp_lt:
   "x \<le> y \<Longrightarrow> x < 2 ^ y"
   by (simp add: le_less_trans)
 
 lemma small_powers_of_2:
   "x \<ge> 3 \<Longrightarrow> x < 2 ^ (x - 1)"
   by (induct x; simp add: suc_le_pow_2)
 
 lemma power_2_mult_step_le:
   "\<lbrakk>n' \<le> n; 2 ^ n' * k' < 2 ^ n * k\<rbrakk> \<Longrightarrow> 2 ^ n' * (k' + 1) \<le> 2 ^ n * (k::nat)"
   apply (cases "n'=n", simp)
    apply (metis Suc_leI le_refl mult_Suc_right mult_le_mono semiring_normalization_rules(7))
   apply (drule (1) le_neq_trans)
   apply clarsimp
   apply (subgoal_tac "\<exists>m. n = n' + m")
    prefer 2
    apply (simp add: le_Suc_ex)
   apply (clarsimp simp: power_add)
   by (metis Suc_leI mult.assoc mult_Suc_right nat_mult_le_cancel_disj)
 
+lemma nat_less_power_trans2:
+  fixes n :: nat
+  shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> n * 2 ^ k  < 2 ^ m"
+  by (subst mult.commute, erule (1) nat_less_power_trans)
+
+lemma nat_move_sub_le: "(a::nat) + b \<le> c \<Longrightarrow> a \<le> c - b"
+  by arith
+
+lemma plus_minus_one_rewrite:
+  "v + (- 1 :: ('a :: {ring, one, uminus})) \<equiv> v - 1"
+  by (simp add: field_simps)
+
+lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ LENGTH('a :: len)"
+  by (metis One_nat_def len_gt_0 lessI numeral_2_eq_2 one_less_power)
+
 end
diff --git a/thys/Word_Lib/More_Divides.thy b/thys/Word_Lib/More_Divides.thy
--- a/thys/Word_Lib/More_Divides.thy
+++ b/thys/Word_Lib/More_Divides.thy
@@ -1,361 +1,421 @@
 
 section \<open>Lemmas on division\<close>
 
 theory More_Divides
   imports
     "HOL-Library.Word"
 begin
 
 declare div_eq_dividend_iff [simp]
 
 lemma int_div_same_is_1 [simp]:
   \<open>a div b = a \<longleftrightarrow> b = 1\<close> if \<open>0 < a\<close> for a b :: int
   using that by (metis div_by_1 abs_ge_zero abs_of_pos int_div_less_self neq_iff
             nonneg1_imp_zdiv_pos_iff zabs_less_one_iff)
 
 lemma int_div_minus_is_minus1 [simp]:
   \<open>a div b = - a \<longleftrightarrow> b = - 1\<close> if \<open>0 > a\<close> for a b :: int
   using that by (metis div_minus_right equation_minus_iff int_div_same_is_1 neg_0_less_iff_less)
 
 lemma nat_div_eq_Suc_0_iff: "n div m = Suc 0 \<longleftrightarrow> m \<le> n \<and> n < 2 * m"
   apply auto
   using div_greater_zero_iff apply fastforce
    apply (metis One_nat_def div_greater_zero_iff dividend_less_div_times mult.right_neutral mult_Suc mult_numeral_1 numeral_2_eq_2 zero_less_numeral)
   apply (simp add: div_nat_eqI)
   done
 
 lemma diff_mod_le:
   \<open>a - a mod b \<le> d - b\<close> if \<open>a < d\<close> \<open>b dvd d\<close> for a b d :: nat
   using that
   apply(subst minus_mod_eq_mult_div)
   apply(clarsimp simp: dvd_def)
   apply(cases \<open>b = 0\<close>)
    apply simp
   apply(subgoal_tac "a div b \<le> k - 1")
    prefer 2
    apply(subgoal_tac "a div b < k")
     apply(simp add: less_Suc_eq_le [symmetric])
    apply(subgoal_tac "b * (a div b) < b * ((b * k) div b)")
     apply clarsimp
    apply(subst div_mult_self1_is_m)
     apply arith
    apply(rule le_less_trans)
     apply simp
     apply(subst mult.commute)
     apply(rule div_times_less_eq_dividend)
    apply assumption
   apply clarsimp
   apply(subgoal_tac "b * (a div b) \<le> b * (k - 1)")
    apply(erule le_trans)
    apply(simp add: diff_mult_distrib2)
   apply simp
   done
 
 lemma one_mod_exp_eq_one [simp]:
   "1 mod (2 * 2 ^ n) = (1::int)"
   using power_gt1 [of 2 n] by (auto intro: mod_pos_pos_trivial)
 
 lemma int_mod_lem: "0 < n \<Longrightarrow> 0 \<le> b \<and> b < n \<longleftrightarrow> b mod n = b"
   for b n :: int
   apply safe
     apply (erule (1) mod_pos_pos_trivial)
    apply (erule_tac [!] subst)
    apply auto
   done
 
 lemma int_mod_ge': "b < 0 \<Longrightarrow> 0 < n \<Longrightarrow> b + n \<le> b mod n"
   for b n :: int
   by (metis add_less_same_cancel2 int_mod_ge mod_add_self2)
 
 lemma int_mod_le': "0 \<le> b - n \<Longrightarrow> b mod n \<le> b - n"
   for b n :: int
   by (metis minus_mod_self2 zmod_le_nonneg_dividend)
 
 lemma emep1: "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (n + 1) mod d = (n mod d) + 1"
   for n d :: int
   by (auto simp add: pos_zmod_mult_2 add.commute dvd_def)
 
 lemma m1mod2k: "- 1 mod 2 ^ n = (2 ^ n - 1 :: int)"
   by (rule zmod_minus1) simp
 
 lemma sb_inc_lem: "a + 2^k < 0 \<Longrightarrow> a + 2^k + 2^(Suc k) \<le> (a + 2^k) mod 2^(Suc k)"
   for a :: int
   using int_mod_ge' [where n = "2 ^ (Suc k)" and b = "a + 2 ^ k"]
   by simp
 
 lemma sb_inc_lem': "a < - (2^k) \<Longrightarrow> a + 2^k + 2^(Suc k) \<le> (a + 2^k) mod 2^(Suc k)"
   for a :: int
   by (rule sb_inc_lem) simp
 
 lemma sb_dec_lem: "0 \<le> - (2 ^ k) + a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
   for a :: int
   using int_mod_le'[where n = "2 ^ (Suc k)" and b = "a + 2 ^ k"] by simp
 
 lemma sb_dec_lem': "2 ^ k \<le> a \<Longrightarrow> (a + 2 ^ k) mod (2 * 2 ^ k) \<le> - (2 ^ k) + a"
   for a :: int
   by (rule sb_dec_lem) simp
 
 lemma mod_2_neq_1_eq_eq_0: "k mod 2 \<noteq> 1 \<longleftrightarrow> k mod 2 = 0"
   for k :: int
   by (fact not_mod_2_eq_1_eq_0)
 
 lemma z1pmod2: "(2 * b + 1) mod 2 = (1::int)"
   for b :: int
   by arith
 
 lemma p1mod22k': "(1 + 2 * b) mod (2 * 2 ^ n) = 1 + 2 * (b mod 2 ^ n)"
   for b :: int
   by (rule pos_zmod_mult_2) simp
 
 lemma p1mod22k: "(2 * b + 1) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n) + 1"
   for b :: int
   by (simp add: p1mod22k' add.commute)
 
 lemma pos_mod_sign2:
   \<open>0 \<le> a mod 2\<close> for a :: int
   by simp
 
 lemma pos_mod_bound2:
   \<open>a mod 2 < 2\<close> for a :: int
   by simp
 
 lemma nmod2: "n mod 2 = 0 \<or> n mod 2 = 1"
   for n :: int
   by arith
 
 lemma eme1p:
   "even n \<Longrightarrow> even d \<Longrightarrow> 0 \<le> d \<Longrightarrow> (1 + n) mod d = 1 + n mod d" for n d :: int
   using emep1 [of n d] by (simp add: ac_simps)
 
 lemma m1mod22k:
   \<open>- 1 mod (2 * 2 ^ n) = 2 * 2 ^ n - (1::int)\<close>
   by (simp add: zmod_minus1)
 
 lemma z1pdiv2: "(2 * b + 1) div 2 = b"
   for b :: int
   by arith
 
 lemma zdiv_le_dividend:
   \<open>0 \<le> a \<Longrightarrow> 0 < b \<Longrightarrow> a div b \<le> a\<close> for a b :: int
   by (metis div_by_1 int_one_le_iff_zero_less zdiv_mono2 zero_less_one)
 
 lemma axxmod2: "(1 + x + x) mod 2 = 1 \<and> (0 + x + x) mod 2 = 0"
   for x :: int
   by arith
 
 lemma axxdiv2: "(1 + x + x) div 2 = x \<and> (0 + x + x) div 2 = x"
   for x :: int
   by arith
 
 lemmas rdmods =
   mod_minus_eq [symmetric]
   mod_diff_left_eq [symmetric]
   mod_diff_right_eq [symmetric]
   mod_add_left_eq [symmetric]
   mod_add_right_eq [symmetric]
   mod_mult_right_eq [symmetric]
   mod_mult_left_eq [symmetric]
 
 lemma mod_plus_right: "(a + x) mod m = (b + x) mod m \<longleftrightarrow> a mod m = b mod m"
   for a b m x :: nat
   by (induct x) (simp_all add: mod_Suc, arith)
 
 lemma nat_minus_mod: "(n - n mod m) mod m = 0"
   for m n :: nat
   by (induct n) (simp_all add: mod_Suc)
 
 lemmas nat_minus_mod_plus_right =
   trans [OF nat_minus_mod mod_0 [symmetric],
     THEN mod_plus_right [THEN iffD2], simplified]
 
 lemmas push_mods' = mod_add_eq
   mod_mult_eq mod_diff_eq
   mod_minus_eq
 
 lemmas push_mods = push_mods' [THEN eq_reflection]
 lemmas pull_mods = push_mods [symmetric] rdmods [THEN eq_reflection]
 
 lemma nat_mod_eq: "b < n \<Longrightarrow> a mod n = b mod n \<Longrightarrow> a mod n = b"
   for a b n :: nat
   by (induct a) auto
 
 lemmas nat_mod_eq' = refl [THEN [2] nat_mod_eq]
 
 lemma nat_mod_lem: "0 < n \<Longrightarrow> b < n \<longleftrightarrow> b mod n = b"
   for b n :: nat
   apply safe
    apply (erule nat_mod_eq')
   apply (erule subst)
   apply (erule mod_less_divisor)
   done
 
 lemma mod_nat_add: "x < z \<Longrightarrow> y < z \<Longrightarrow> (x + y) mod z = (if x + y < z then x + y else x + y - z)"
   for x y z :: nat
   apply (rule nat_mod_eq)
    apply auto
   apply (rule trans)
    apply (rule le_mod_geq)
    apply simp
   apply (rule nat_mod_eq')
   apply arith
   done
 
 lemma mod_nat_sub: "x < z \<Longrightarrow> (x - y) mod z = x - y"
   for x y :: nat
   by (rule nat_mod_eq') arith
 
 lemma int_mod_eq: "0 \<le> b \<Longrightarrow> b < n \<Longrightarrow> a mod n = b mod n \<Longrightarrow> a mod n = b"
   for a b n :: int
   by (metis mod_pos_pos_trivial)
 
 lemma zmde:
   \<open>b * (a div b) = a - a mod b\<close> for a b :: \<open>'a::{group_add,semiring_modulo}\<close>
   using mult_div_mod_eq [of b a] by (simp add: eq_diff_eq) 
 
 (* already have this for naturals, div_mult_self1/2, but not for ints *)
 lemma zdiv_mult_self: "m \<noteq> 0 \<Longrightarrow> (a + m * n) div m = a div m + n"
   for a m n :: int
   by simp
 
 lemma mod_power_lem: "a > 1 \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
   for a :: int
   by (simp add: mod_eq_0_iff_dvd le_imp_power_dvd)
 
 lemma nonneg_mod_div: "0 \<le> a \<Longrightarrow> 0 \<le> b \<Longrightarrow> 0 \<le> (a mod b) \<and> 0 \<le> a div b"
   for a b :: int
   by (cases "b = 0") (auto intro: pos_imp_zdiv_nonneg_iff [THEN iffD2])
 
 lemma mod_exp_less_eq_exp:
   \<open>a mod 2 ^ n < 2 ^ n\<close> for a :: int
   by (rule pos_mod_bound) simp
 
 lemma div_mult_le:
   \<open>a div b * b \<le> a\<close> for a b :: nat
   by (fact div_times_less_eq_dividend)
 
 lemma power_sub:
   fixes a :: nat
   assumes lt: "n \<le> m"
   and     av: "0 < a"
   shows "a ^ (m - n) = a ^ m div a ^ n"
 proof (subst nat_mult_eq_cancel1 [symmetric])
   show "(0::nat) < a ^ n" using av by simp
 next
   from lt obtain q where mv: "n + q = m"
     by (auto simp: le_iff_add)
 
   have "a ^ n * (a ^ m div a ^ n) = a ^ m"
   proof (subst mult.commute)
     have "a ^ m = (a ^ m div a ^ n) * a ^ n + a ^ m mod a ^ n"
       by (rule  div_mult_mod_eq [symmetric])
 
     moreover have "a ^ m mod a ^ n = 0"
       by (subst mod_eq_0_iff_dvd, subst dvd_def, rule exI [where x = "a ^ q"],
       (subst power_add [symmetric] mv)+, rule refl)
 
     ultimately show "(a ^ m div a ^ n) * a ^ n = a ^ m" by simp
   qed
 
   then show "a ^ n * a ^ (m - n) = a ^ n * (a ^ m div a ^ n)" using lt
     by (simp add: power_add [symmetric])
 qed
 
 lemma mod_lemma: "[| (0::nat) < c; r < b |] ==> b * (q mod c) + r < b * c"
   apply (cut_tac m = q and n = c in mod_less_divisor)
   apply (drule_tac [2] m = "q mod c" in less_imp_Suc_add, auto)
   apply (erule_tac P = "%x. lhs < rhs x" for lhs rhs in ssubst)
   apply (simp add: add_mult_distrib2)
   done
 
 lemma less_two_pow_divD:
   "\<lbrakk> (x :: nat) < 2 ^ n div 2 ^ m \<rbrakk>
     \<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
   apply (rule context_conjI)
    apply (rule ccontr)
    apply (simp add: power_strict_increasing)
   apply (simp add: power_sub)
   done
 
 lemma less_two_pow_divI:
   "\<lbrakk> (x :: nat) < 2 ^ (n - m); m \<le> n \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
   by (simp add: power_sub)
 
 lemmas m2pths = pos_mod_sign mod_exp_less_eq_exp
 
 lemmas int_mod_eq' = mod_pos_pos_trivial (* FIXME delete *)
 
 lemmas int_mod_le = zmod_le_nonneg_dividend (* FIXME: delete *)
 
 lemma power_mod_div:
   fixes x :: "nat"
   shows "x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)" (is "?LHS = ?RHS")
 proof (cases "n \<le> m")
   case True
   then have "?LHS = 0"
     apply -
     apply (rule div_less)
     apply (rule order_less_le_trans [OF mod_less_divisor]; simp)
     done
   also have "\<dots> = ?RHS" using True
     by simp
   finally show ?thesis .
 next
   case False
   then have lt: "m < n" by simp
   then obtain q where nv: "n = m + q" and "0 < q"
     by (auto dest: less_imp_Suc_add)
 
   then have "x mod 2 ^ n = 2 ^ m * (x div 2 ^ m mod 2 ^ q) + x mod 2 ^ m"
     by (simp add: power_add mod_mult2_eq)
 
   then have "?LHS = x div 2 ^ m mod 2 ^ q"
     by (simp add: div_add1_eq)
 
   also have "\<dots> = ?RHS" using nv
     by simp
 
   finally show ?thesis .
 qed
 
 lemma mod_mod_power:
   fixes k :: nat
   shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
 proof (cases "m \<le> n")
   case True
 
   then have "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ m"
     apply -
     apply (subst mod_less [where n = "2 ^ n"])
     apply (rule order_less_le_trans [OF mod_less_divisor])
     apply simp+
     done
   also have "\<dots> = k mod  2 ^ (min m n)" using True by simp
   finally show ?thesis .
 next
   case False
   then have "n < m" by simp
   then obtain d where md: "m = n + d"
     by (auto dest: less_imp_add_positive)
   then have "k mod 2 ^ m = 2 ^ n * (k div 2 ^ n mod 2 ^ d) + k mod 2 ^ n"
     by (simp add: mod_mult2_eq power_add)
   then have "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ n"
     by (simp add: mod_add_left_eq)
   then show ?thesis using False
     by simp
 qed
 
 lemma take_bit_eq_mask_iff:
   \<open>take_bit n k = mask n \<longleftrightarrow> take_bit n (k + 1) = 0\<close>
   for k :: int
   apply auto
    apply (subst take_bit_add [symmetric])
    apply (simp add: mask_eq_exp_minus_1)
   apply (metis add.left_commute diff_0 diff_add_cancel group_cancel.rule0 take_bit_add take_bit_minus take_bit_minus_one_eq_mask)
   done
 
 lemma take_bit_eq_mask_iff_exp_dvd:
   \<open>take_bit n k = mask n \<longleftrightarrow> 2 ^ n dvd k + 1\<close>
   for k :: int
   by (simp add: take_bit_eq_mask_iff flip: take_bit_eq_0_iff)
 
+lemma mod_div_equality_div_eq:
+  "a div b * b = (a - (a mod b) :: int)"
+  by (simp add: field_simps)
+
+lemma zmod_helper:
+  "n mod m = k \<Longrightarrow> ((n :: int) + a) mod m = (k + a) mod m"
+  by (metis add.commute mod_add_right_eq)
+
+lemma int_div_sub_1:
+  "\<lbrakk> m \<ge> 1 \<rbrakk> \<Longrightarrow> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)"
+  apply (subgoal_tac "m = 0 \<or> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)")
+   apply fastforce
+  apply (subst mult_cancel_right[symmetric])
+  apply (simp only: left_diff_distrib split: if_split)
+  apply (simp only: mod_div_equality_div_eq)
+  apply (clarsimp simp: field_simps)
+  apply (clarsimp simp: dvd_eq_mod_eq_0)
+  apply (cases "m = 1")
+   apply simp
+  apply (subst mod_diff_eq[symmetric], simp add: zmod_minus1)
+  apply clarsimp
+  apply (subst diff_add_cancel[where b=1, symmetric])
+  apply (subst mod_add_eq[symmetric])
+  apply (simp add: field_simps)
+  apply (rule mod_pos_pos_trivial)
+   apply (subst add_0_right[where a=0, symmetric])
+   apply (rule add_mono)
+    apply simp
+   apply simp
+  apply (cases "(n - 1) mod m = m - 1")
+   apply (drule zmod_helper[where a=1])
+   apply simp
+  apply (subgoal_tac "1 + (n - 1) mod m \<le> m")
+   apply simp
+  apply (subst field_simps, rule zless_imp_add1_zle)
+  apply simp
+  done
+
+lemma power_minus_is_div:
+  "b \<le> a \<Longrightarrow> (2 :: nat) ^ (a - b) = 2 ^ a div 2 ^ b"
+  apply (induct a arbitrary: b)
+   apply simp
+  apply (erule le_SucE)
+   apply (clarsimp simp:Suc_diff_le le_iff_add power_add)
+  apply simp
+  done
+
+lemma two_pow_div_gt_le:
+  "v < 2 ^ n div (2 ^ m :: nat) \<Longrightarrow> m \<le> n"
+  by (clarsimp dest!: less_two_pow_divD)
+
+lemma nat_mult_power_less_eq:
+  "b > 0 \<Longrightarrow> (a * b ^ n < (b :: nat) ^ m) = (a < b ^ (m - n))"
+  using mult_less_cancel2[where m = a and k = "b ^ n" and n="b ^ (m - n)"]
+        mult_less_cancel2[where m="a * b ^ (n - m)" and k="b ^ m" and n=1]
+  apply (simp only: power_add[symmetric] nat_minus_add_max)
+  apply (simp only: power_add[symmetric] nat_minus_add_max ac_simps)
+  apply (simp add: max_def split: if_split_asm)
+  done
+
 end
diff --git a/thys/Word_Lib/More_Word.thy b/thys/Word_Lib/More_Word.thy
--- a/thys/Word_Lib/More_Word.thy
+++ b/thys/Word_Lib/More_Word.thy
@@ -1,1249 +1,1802 @@
 
 section \<open>Lemmas on words\<close>
 
 theory More_Word
   imports
     "HOL-Library.Word"
     More_Arithmetic
     More_Divides
 begin
 
-lemma Suc_0_lt_2p_len_of: "Suc 0 < 2 ^ LENGTH('a :: len)"
-  by (metis One_nat_def len_gt_0 lessI numeral_2_eq_2 one_less_power)
-
 lemma unat_power_lower [simp]:
   "unat ((2::'a::len word) ^ n) = 2 ^ n" if "n < LENGTH('a::len)"
   using that by transfer simp
 
 lemma unat_p2: "n < LENGTH('a :: len) \<Longrightarrow> unat (2 ^ n :: 'a word) = 2 ^ n"
   by (fact unat_power_lower)
 
 lemma word_div_lt_eq_0:
   "x < y \<Longrightarrow> x div y = 0" for x :: "'a :: len word"
   by transfer simp
 
 lemma word_div_eq_1_iff: "n div m = 1 \<longleftrightarrow> n \<ge> m \<and> unat n < 2 * unat (m :: 'a :: len word)"
   apply (simp only: word_arith_nat_defs word_le_nat_alt word_of_nat_eq_iff flip: nat_div_eq_Suc_0_iff)
   apply (simp flip: unat_div unsigned_take_bit_eq)
   done
 
 lemma shiftl_power:
   "(shiftl1 ^^ x) (y::'a::len word) = 2 ^ x * y"
   apply (induct x)
    apply simp
   apply (simp add: shiftl1_2t)
   done
 
 lemma AND_twice [simp]:
   "(w AND m) AND m = w AND m"
   by (fact and.right_idem)
 
 lemma word_combine_masks:
   "w AND m = z \<Longrightarrow> w AND m' = z' \<Longrightarrow> w AND (m OR m') = (z OR z')"
   for w m m' z z' :: \<open>'a::len word\<close>
   by (simp add: bit.conj_disj_distrib)
 
 lemma p2_gt_0:
   "(0 < (2 ^ n :: 'a :: len word)) = (n < LENGTH('a))"
   by (simp add : word_gt_0 not_le)
 
 lemma uint_2p_alt:
   \<open>n < LENGTH('a::len) \<Longrightarrow> uint ((2::'a::len word) ^ n) = 2 ^ n\<close>
   using p2_gt_0 [of n, where ?'a = 'a] by (simp add: uint_2p) 
 
 lemma p2_eq_0:
   \<open>(2::'a::len word) ^ n = 0 \<longleftrightarrow> LENGTH('a::len) \<le> n\<close>
   by (fact exp_eq_zero_iff)
 
 lemma p2len:
   \<open>(2 :: 'a word) ^ LENGTH('a::len) = 0\<close>
   by simp
 
 lemma neg_mask_is_div:
   "w AND NOT (mask n) = (w div 2^n) * 2^n"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_simps simp flip: push_bit_eq_mult drop_bit_eq_div)
 
 lemma neg_mask_is_div':
   "n < size w \<Longrightarrow> w AND NOT (mask n) = ((w div (2 ^ n)) * (2 ^ n))"
   for w :: \<open>'a::len word\<close>
   by (rule neg_mask_is_div)
 
 lemma and_mask_arith:
   "w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_simps word_size simp flip: push_bit_eq_mult drop_bit_eq_div)
 
 lemma and_mask_arith':
   "0 < n \<Longrightarrow> w AND mask n = (w * 2^(size w - n)) div 2^(size w - n)"
   for w :: \<open>'a::len word\<close>
   by (rule and_mask_arith)
   
 lemma mask_2pm1: "mask n = 2 ^ n - (1 :: 'a::len word)"
   by (fact mask_eq_decr_exp)
 
 lemma add_mask_fold:
   "x + 2 ^ n - 1 = x + mask n"
   for x :: \<open>'a::len word\<close>
   by (simp add: mask_eq_decr_exp)
 
 lemma word_and_mask_le_2pm1: "w AND mask n \<le> 2 ^ n - 1"
   for w :: \<open>'a::len word\<close>
   by (simp add: mask_2pm1[symmetric] word_and_le1)
 
 lemma is_aligned_AND_less_0:
   "u AND mask n = 0 \<Longrightarrow> v < 2^n \<Longrightarrow> u AND v = 0"
   for u v :: \<open>'a::len word\<close>
   apply (drule less_mask_eq)
   apply (simp flip: take_bit_eq_mask)
   apply (simp add: bit_eq_iff)
   apply (auto simp add: bit_simps)
   done
 
 lemma le_shiftr1:
   \<open>shiftr1 u \<le> shiftr1 v\<close> if \<open>u \<le> v\<close>
 using that proof transfer
   fix k l :: int
   assume \<open>take_bit LENGTH('a) k \<le> take_bit LENGTH('a) l\<close>
   then have \<open>take_bit LENGTH('a) (drop_bit 1 (take_bit LENGTH('a) k))
     \<le> take_bit LENGTH('a) (drop_bit 1 (take_bit LENGTH('a) l))\<close>
     apply (simp add: take_bit_drop_bit min_def)
     apply (simp add: drop_bit_eq_div)
     done
   then show \<open>take_bit LENGTH('a) (take_bit LENGTH('a) k div 2)
     \<le> take_bit LENGTH('a) (take_bit LENGTH('a) l div 2)\<close>
     by (simp add: drop_bit_eq_div)
 qed
 
 lemma and_mask_eq_iff_le_mask:
   \<open>w AND mask n = w \<longleftrightarrow> w \<le> mask n\<close>
   for w :: \<open>'a::len word\<close>
   apply (simp flip: take_bit_eq_mask)
   apply (cases \<open>n \<ge> LENGTH('a)\<close>; transfer)
    apply (simp_all add: not_le min_def)
    apply (simp_all add: mask_eq_exp_minus_1)
   apply auto
    apply (metis take_bit_int_less_exp)
   apply (metis min_def nat_less_le take_bit_int_eq_self_iff take_bit_take_bit)
   done
 
 lemma less_eq_mask_iff_take_bit_eq_self:
   \<open>w \<le> mask n \<longleftrightarrow> take_bit n w = w\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: and_mask_eq_iff_le_mask take_bit_eq_mask)
 
 lemma NOT_eq:
   "NOT (x :: 'a :: len word) = - x - 1"
   apply (cut_tac x = "x" in word_add_not)
   apply (drule add.commute [THEN trans])
   apply (drule eq_diff_eq [THEN iffD2])
   by simp
 
 lemma NOT_mask: "NOT (mask n :: 'a::len word) = - (2 ^ n)"
   by (simp add : NOT_eq mask_2pm1)
 
 lemma le_m1_iff_lt: "(x > (0 :: 'a :: len word)) = ((y \<le> x - 1) = (y < x))"
   by uint_arith
 
 lemma gt0_iff_gem1:
   \<open>0 < x \<longleftrightarrow> x - 1 < x\<close>
   for x :: \<open>'a::len word\<close>
   by (metis add.right_neutral diff_add_cancel less_irrefl measure_unat unat_arith_simps(2) word_neq_0_conv word_sub_less_iff)
 
 lemma power_2_ge_iff:
   \<open>2 ^ n - (1 :: 'a::len word) < 2 ^ n \<longleftrightarrow> n < LENGTH('a)\<close>
   using gt0_iff_gem1 p2_gt_0 by blast
 
 lemma le_mask_iff_lt_2n:
   "n < len_of TYPE ('a) = (((w :: 'a :: len word) \<le> mask n) = (w < 2 ^ n))"
   unfolding mask_2pm1 by (rule trans [OF p2_gt_0 [THEN sym] le_m1_iff_lt])
 
 lemma mask_lt_2pn:
   \<open>n < LENGTH('a) \<Longrightarrow> mask n < (2 :: 'a::len word) ^ n\<close>
   by (simp add: mask_eq_exp_minus_1 power_2_ge_iff)
 
 lemma word_unat_power:
   "(2 :: 'a :: len word) ^ n = of_nat (2 ^ n)"
   by simp
 
 lemma of_nat_mono_maybe:
   assumes xlt: "x < 2 ^ len_of TYPE ('a)"
   shows   "y < x \<Longrightarrow> of_nat y < (of_nat x :: 'a :: len word)"
   apply (subst word_less_nat_alt)
   apply (subst unat_of_nat)+
   apply (subst mod_less)
    apply (erule order_less_trans [OF _ xlt])
   apply (subst mod_less [OF xlt])
   apply assumption
   done
 
 lemma word_and_max_word:
   fixes a::"'a::len word"
   shows "x = max_word \<Longrightarrow> a AND x = a"
   by simp
 
 lemma word_and_full_mask_simp:
   \<open>x AND mask LENGTH('a) = x\<close> for x :: \<open>'a::len word\<close>
 proof (rule bit_eqI)
   fix n
   assume \<open>2 ^ n \<noteq> (0 :: 'a word)\<close>
   then have \<open>n < LENGTH('a)\<close>
     by simp
   then show \<open>bit (x AND Bit_Operations.mask LENGTH('a)) n \<longleftrightarrow> bit x n\<close>
     by (simp add: bit_and_iff bit_mask_iff)
 qed
 
 lemma of_int_uint:
   "of_int (uint x) = x"
   by (fact word_of_int_uint)
 
 corollary word_plus_and_or_coroll:
   "x AND y = 0 \<Longrightarrow> x + y = x OR y"
   for x y :: \<open>'a::len word\<close>
   using word_plus_and_or[where x=x and y=y]
   by simp
 
 corollary word_plus_and_or_coroll2:
   "(x AND w) + (x AND NOT w) = x"
   for x w :: \<open>'a::len word\<close>
   apply (subst disjunctive_add)
    apply (simp add: bit_simps)
   apply (simp flip: bit.conj_disj_distrib)
   done
 
 lemma nat_mask_eq:
   \<open>nat (mask n) = mask n\<close>
   by (simp add: nat_eq_iff of_nat_mask_eq)
 
 lemma unat_mask_eq:
   \<open>unat (mask n :: 'a::len word) = mask (min LENGTH('a) n)\<close>
   by transfer (simp add: nat_mask_eq)
 
 lemma word_plus_mono_left:
   fixes x :: "'a :: len word"
   shows "\<lbrakk>y \<le> z; x \<le> x + z\<rbrakk> \<Longrightarrow> y + x \<le> z + x"
   by unat_arith
 
 lemma less_Suc_unat_less_bound:
   "n < Suc (unat (x :: 'a :: len word)) \<Longrightarrow> n < 2 ^ LENGTH('a)"
   by (auto elim!: order_less_le_trans intro: Suc_leI)
 
 lemma up_ucast_inj:
   "\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> len_of TYPE ('b) \<rbrakk> \<Longrightarrow> x = (y::'a::len word)"
   by transfer (simp add: min_def split: if_splits)
 
 lemmas ucast_up_inj = up_ucast_inj
 
 lemma up_ucast_inj_eq:
   "LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow> (ucast x = (ucast y::'b::len word)) = (x = (y::'a::len word))"
   by (fastforce dest: up_ucast_inj)
 
 lemma no_plus_overflow_neg:
   "(x :: 'a :: len word) < -y \<Longrightarrow> x \<le> x + y"
   by (metis diff_minus_eq_add less_imp_le sub_wrap_lt)
 
 lemma ucast_ucast_eq:
   "\<lbrakk> ucast x = (ucast (ucast y::'a word)::'c::len word); LENGTH('a) \<le> LENGTH('b);
      LENGTH('b) \<le> LENGTH('c) \<rbrakk> \<Longrightarrow>
    x = ucast y" for x :: "'a::len word" and y :: "'b::len word"
   apply transfer
   apply (cases \<open>LENGTH('c) = LENGTH('a)\<close>)
    apply (auto simp add: min_def)
   done
 
 lemma ucast_0_I:
   "x = 0 \<Longrightarrow> ucast x = 0"
   by simp
 
 lemma word_add_offset_less:
   fixes x :: "'a :: len word"
   assumes yv: "y < 2 ^ n"
   and     xv: "x < 2 ^ m"
   and     mnv: "sz < LENGTH('a :: len)"
   and    xv': "x < 2 ^ (LENGTH('a :: len) - n)"
   and     mn: "sz = m + n"
   shows   "x * 2 ^ n + y < 2 ^ sz"
 proof (subst mn)
   from mnv mn have nv: "n < LENGTH('a)" and mv: "m < LENGTH('a)"  by auto
 
   have uy: "unat y < 2 ^ n"
     by (rule order_less_le_trans [OF unat_mono [OF yv] order_eq_refl],
         rule unat_power_lower[OF nv])
 
   have ux: "unat x < 2 ^ m"
     by (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl],
         rule unat_power_lower[OF mv])
 
   then show "x * 2 ^ n + y < 2 ^ (m + n)" using ux uy nv mnv xv'
     apply (subst word_less_nat_alt)
     apply (subst unat_word_ariths)+
     apply (subst mod_less)
      apply simp
      apply (subst mult.commute)
      apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
      apply (rule order_less_le_trans [OF unat_mono [OF xv']])
      apply (cases "n = 0"; simp)
     apply (subst unat_power_lower[OF nv])
     apply (subst mod_less)
      apply (erule order_less_le_trans [OF nat_add_offset_less], assumption)
       apply (rule mn)
      apply simp
     apply (simp add: mn mnv)
     apply (erule nat_add_offset_less; simp)
     done
 qed
 
 lemma word_less_power_trans:
   fixes n :: "'a :: len word"
   assumes nv: "n < 2 ^ (m - k)"
   and     kv: "k \<le> m"
   and     mv: "m < len_of TYPE ('a)"
   shows "2 ^ k * n < 2 ^ m"
   using nv kv mv
   apply -
   apply (subst word_less_nat_alt)
   apply (subst unat_word_ariths)
   apply (subst mod_less)
    apply simp
    apply (rule nat_less_power_trans)
     apply (erule order_less_trans [OF unat_mono])
     apply simp
    apply simp
   apply simp
   apply (rule nat_less_power_trans)
    apply (subst unat_power_lower[where 'a = 'a, symmetric])
     apply simp
    apply (erule unat_mono)
   apply simp
   done
 
 lemma  word_less_power_trans2:
   fixes n :: "'a::len word"
   shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk> \<Longrightarrow> n * 2 ^ k < 2 ^ m"
   by (subst field_simps, rule word_less_power_trans)
 
 lemma Suc_unat_diff_1:
   fixes x :: "'a :: len word"
   assumes lt: "1 \<le> x"
   shows "Suc (unat (x - 1)) = unat x"
 proof -
   have "0 < unat x"
     by (rule order_less_le_trans [where y = 1], simp, subst unat_1 [symmetric],
         rule iffD1 [OF word_le_nat_alt lt])
 
   then show ?thesis
     by ((subst unat_sub [OF lt])+, simp only:  unat_1)
 qed
 
 lemma word_eq_unatI:
   \<open>v = w\<close> if \<open>unat v = unat w\<close>
   using that by transfer (simp add: nat_eq_iff)
 
 lemma word_div_sub:
   fixes x :: "'a :: len word"
   assumes yx: "y \<le> x"
   and     y0: "0 < y"
   shows "(x - y) div y = x div y - 1"
   apply (rule word_eq_unatI)
   apply (subst unat_div)
   apply (subst unat_sub [OF yx])
   apply (subst unat_sub)
    apply (subst word_le_nat_alt)
    apply (subst unat_div)
    apply (subst le_div_geq)
      apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
      apply simp
     apply (subst word_le_nat_alt [symmetric], rule yx)
    apply simp
   apply (subst unat_div)
   apply (subst le_div_geq [OF _ iffD1 [OF word_le_nat_alt yx]])
    apply (rule order_le_less_trans [OF _ unat_mono [OF y0]])
    apply simp
   apply simp
   done
 
 lemma word_mult_less_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i < j"
   and    knz: "0 < k"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i * k < j * k"
 proof -
   from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
     by (auto intro: order_less_subst2 simp: word_less_nat_alt elim: mult_less_mono1)
 
   then show ?thesis using ujk knz ij
     by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem])
 qed
 
 lemma word_mult_less_dest:
   fixes i :: "'a :: len word"
   assumes ij: "i * k < j * k"
   and    uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i < j"
   using uik ujk ij
   by (auto simp: word_less_nat_alt iffD1 [OF unat_mult_lem] elim: mult_less_mono1)
 
 lemma word_mult_less_cancel:
   fixes k :: "'a :: len word"
   assumes knz: "0 < k"
   and    uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows "(i * k < j * k) = (i < j)"
   by (rule iffI [OF word_mult_less_dest [OF _ uik ujk] word_mult_less_mono1 [OF _ knz ujk]])
 
 lemma Suc_div_unat_helper:
   assumes szv: "sz < LENGTH('a :: len)"
   and   usszv: "us \<le> sz"
   shows "2 ^ (sz - us) = Suc (unat (((2::'a :: len word) ^ sz - 1) div 2 ^ us))"
 proof -
   note usv = order_le_less_trans [OF usszv szv]
 
   from usszv obtain q where qv: "sz = us + q" by (auto simp: le_iff_add)
 
   have "Suc (unat (((2:: 'a word) ^ sz - 1) div 2 ^ us)) =
     (2 ^ us + unat ((2:: 'a word) ^ sz - 1)) div 2 ^ us"
     apply (subst unat_div unat_power_lower[OF usv])+
     apply (subst div_add_self1, simp+)
     done
 
   also have "\<dots> = ((2 ^ us - 1) + 2 ^ sz) div 2 ^ us" using szv
     by (simp add: unat_minus_one)
 
   also have "\<dots> = 2 ^ q + ((2 ^ us - 1) div 2 ^ us)"
     apply (subst qv)
     apply (subst power_add)
     apply (subst div_mult_self2; simp)
     done
 
   also have "\<dots> = 2 ^ (sz - us)" using qv by simp
 
   finally show ?thesis ..
 qed
 
 lemma enum_word_nth_eq:
   \<open>(Enum.enum :: 'a::len word list) ! n = word_of_nat n\<close>
     if \<open>n < 2 ^ LENGTH('a)\<close>
     for n
   using that by (simp add: enum_word_def)
 
 lemma length_enum_word_eq:
   \<open>length (Enum.enum :: 'a::len word list) = 2 ^ LENGTH('a)\<close>
   by (simp add: enum_word_def)
 
 lemma unat_lt2p [iff]:
   \<open>unat x < 2 ^ LENGTH('a)\<close> for x :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma of_nat_unat [simp]:
   "of_nat \<circ> unat = id"
   by (rule ext, simp)
 
 lemma Suc_unat_minus_one [simp]:
   "x \<noteq> 0 \<Longrightarrow> Suc (unat (x - 1)) = unat x"
   by (metis Suc_diff_1 unat_gt_0 unat_minus_one)
 
 lemma word_add_le_dest:
   fixes i :: "'a :: len word"
   assumes le: "i + k \<le> j + k"
   and    uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i \<le> j"
   using uik ujk le
   by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem] elim: add_le_mono1)
 
 lemma word_add_le_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i \<le> j"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i + k \<le> j + k"
 proof -
   from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: add_le_mono1)
 
   then show ?thesis using ujk ij
     by (auto simp: word_le_nat_alt iffD1 [OF unat_add_lem])
 qed
 
 lemma word_add_le_mono2:
   fixes i :: "'a :: len word"
   shows "\<lbrakk>i \<le> j; unat j + unat k < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> k + i \<le> k + j"
   by (subst field_simps, subst field_simps, erule (1) word_add_le_mono1)
 
 lemma word_add_le_iff:
   fixes i :: "'a :: len word"
   assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i + k \<le> j + k) = (i \<le> j)"
 proof
   assume "i \<le> j"
   show "i + k \<le> j + k" by (rule word_add_le_mono1) fact+
 next
   assume "i + k \<le> j + k"
   show "i \<le> j" by (rule word_add_le_dest) fact+
 qed
 
 lemma word_add_less_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i < j"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i + k < j + k"
 proof -
   from ij ujk have jk: "unat i + unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_less_nat_alt elim: add_less_mono1)
 
   then show ?thesis using ujk ij
     by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem])
 qed
 
 lemma word_add_less_dest:
   fixes i :: "'a :: len word"
   assumes le: "i + k < j + k"
   and    uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and    ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "i < j"
   using uik ujk le
   by (auto simp: word_less_nat_alt iffD1 [OF unat_add_lem] elim: add_less_mono1)
 
 lemma word_add_less_iff:
   fixes i :: "'a :: len word"
   assumes uik: "unat i + unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j + unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i + k < j + k) = (i < j)"
 proof
   assume "i < j"
   show "i + k < j + k" by (rule word_add_less_mono1) fact+
 next
   assume "i + k < j + k"
   show "i < j" by (rule word_add_less_dest) fact+
 qed
 
 lemma word_mult_less_iff:
   fixes i :: "'a :: len word"
   assumes knz: "0 < k"
   and     uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i * k < j * k) = (i < j)"
   using assms by (rule word_mult_less_cancel)
 
 lemma word_le_imp_diff_le:
   fixes n :: "'a::len word"
   shows "\<lbrakk>k \<le> n; n \<le> m\<rbrakk> \<Longrightarrow> n - k \<le> m"
   by (auto simp: unat_sub word_le_nat_alt)
 
 lemma word_less_imp_diff_less:
   fixes n :: "'a::len word"
   shows "\<lbrakk>k \<le> n; n < m\<rbrakk> \<Longrightarrow> n - k < m"
   by (clarsimp simp: unat_sub word_less_nat_alt
              intro!: less_imp_diff_less)
 
 lemma word_mult_le_mono1:
   fixes i :: "'a :: len word"
   assumes ij: "i \<le> j"
   and    knz: "0 < k"
   and    ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "i * k \<le> j * k"
 proof -
   from ij ujk knz have jk: "unat i * unat k < 2 ^ len_of TYPE ('a)"
     by (auto elim: order_le_less_subst2 simp: word_le_nat_alt elim: mult_le_mono1)
 
   then show ?thesis using ujk knz ij
     by (auto simp: word_le_nat_alt iffD1 [OF unat_mult_lem])
 qed
 
 lemma word_mult_le_iff:
   fixes i :: "'a :: len word"
   assumes knz: "0 < k"
   and     uik: "unat i * unat k < 2 ^ len_of TYPE ('a)"
   and     ujk: "unat j * unat k < 2 ^ len_of TYPE ('a)"
   shows  "(i * k \<le> j * k) = (i \<le> j)"
 proof
   assume "i \<le> j"
   show "i * k \<le> j * k" by (rule word_mult_le_mono1) fact+
 next
   assume p: "i * k \<le> j * k"
 
   have "0 < unat k" using knz by (simp add: word_less_nat_alt)
   then show "i \<le> j" using p
     by (clarsimp simp: word_le_nat_alt iffD1 [OF unat_mult_lem uik]
       iffD1 [OF unat_mult_lem ujk])
 qed
 
 lemma word_diff_less:
   fixes n :: "'a :: len word"
   shows "\<lbrakk>0 < n; 0 < m; n \<le> m\<rbrakk> \<Longrightarrow> m - n < m"
   apply (subst word_less_nat_alt)
   apply (subst unat_sub)
    apply assumption
   apply (rule diff_less)
    apply (simp_all add: word_less_nat_alt)
   done
 
 lemma word_add_increasing:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> p + w \<le> x; p \<le> p + w \<rbrakk> \<Longrightarrow> p \<le> x"
   by unat_arith
 
 lemma word_random:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> p \<le> p + x'; x \<le> x' \<rbrakk> \<Longrightarrow> p \<le> p + x"
   by unat_arith
 
 lemma word_sub_mono:
   "\<lbrakk> a \<le> c; d \<le> b; a - b \<le> a; c - d \<le> c \<rbrakk>
     \<Longrightarrow> (a - b) \<le> (c - d :: 'a :: len word)"
   by unat_arith
 
 lemma power_not_zero:
   "n < LENGTH('a::len) \<Longrightarrow> (2 :: 'a word) ^ n \<noteq> 0"
   by (metis p2_gt_0 word_neq_0_conv)
 
 lemma word_gt_a_gt_0:
   "a < n \<Longrightarrow> (0 :: 'a::len word) < n"
   apply (case_tac "n = 0")
    apply clarsimp
   apply (clarsimp simp: word_neq_0_conv)
   done
 
 lemma word_power_less_1 [simp]:
   "sz < LENGTH('a::len) \<Longrightarrow> (2::'a word) ^ sz - 1 < 2 ^ sz"
   apply (simp add: word_less_nat_alt)
   apply (subst unat_minus_one)
   apply simp_all
   done
 
 lemma word_sub_1_le:
   "x \<noteq> 0 \<Longrightarrow> x - 1 \<le> (x :: ('a :: len) word)"
   apply (subst no_ulen_sub)
   apply simp
   apply (cases "uint x = 0")
    apply (simp add: uint_0_iff)
   apply (insert uint_ge_0[where x=x])
   apply arith
   done
 
 lemma push_bit_word_eq_nonzero:
   \<open>push_bit n w \<noteq> 0\<close> if \<open>w < 2 ^ m\<close> \<open>m + n < LENGTH('a)\<close> \<open>w \<noteq> 0\<close>
     for w :: \<open>'a::len word\<close>
   using that
   apply (simp only: word_neq_0_conv word_less_nat_alt
                     mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (metis add_diff_cancel_right' gr0I gr_implies_not0 less_or_eq_imp_le min_def push_bit_eq_0_iff take_bit_nat_eq_self_iff take_bit_push_bit take_bit_take_bit unsigned_push_bit_eq)
   done
 
 lemma unat_less_power:
   fixes k :: "'a::len word"
   assumes szv: "sz < LENGTH('a)"
   and     kv:  "k < 2 ^ sz"
   shows   "unat k < 2 ^ sz"
   using szv unat_mono [OF kv] by simp
 
 lemma unat_mult_power_lem:
   assumes kv: "k < 2 ^ (LENGTH('a::len) - sz)"
   shows "unat (2 ^ sz * of_nat k :: (('a::len) word)) = 2 ^ sz * k"
 proof (cases \<open>sz < LENGTH('a)\<close>)
   case True
   with assms show ?thesis
     by (simp add: unat_word_ariths take_bit_eq_mod mod_simps)
       (simp add: take_bit_nat_eq_self_iff nat_less_power_trans flip: take_bit_eq_mod)
 next
   case False
   with assms show ?thesis
     by simp
 qed
 
 lemma word_plus_mcs_4:
   "\<lbrakk>v + x \<le> w + x; x \<le> v + x\<rbrakk> \<Longrightarrow> v \<le> (w::'a::len word)"
   by uint_arith
 
 lemma word_plus_mcs_3:
   "\<lbrakk>v \<le> w; x \<le> w + x\<rbrakk> \<Longrightarrow> v + x \<le> w + (x::'a::len word)"
   by unat_arith
 
 lemma word_le_minus_one_leq:
   "x < y \<Longrightarrow> x \<le> y - 1" for x :: "'a :: len word"
   by transfer (metis le_less_trans less_irrefl take_bit_decr_eq take_bit_nonnegative zle_diff1_eq) 
 
 lemma word_less_sub_le[simp]:
   fixes x :: "'a :: len word"
   assumes nv: "n < LENGTH('a)"
   shows "(x \<le> 2 ^ n - 1) = (x < 2 ^ n)"
   using le_less_trans word_le_minus_one_leq nv power_2_ge_iff by blast
 
 lemma unat_of_nat_len:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x :: 'a::len word) = x"
   by (simp add: take_bit_nat_eq_self_iff)
 
 lemma unat_of_nat_eq:
   "x < 2 ^ LENGTH('a) \<Longrightarrow> unat (of_nat x ::'a::len word) = x"
   by (rule unat_of_nat_len)
 
 lemma unat_eq_of_nat:
   "n < 2 ^ LENGTH('a) \<Longrightarrow> (unat (x :: 'a::len word) = n) = (x = of_nat n)"
   by transfer
     (auto simp add: take_bit_of_nat nat_eq_iff take_bit_nat_eq_self_iff intro: sym)
 
 lemma alignUp_div_helper:
   fixes a :: "'a::len word"
   assumes kv: "k < 2 ^ (LENGTH('a) - n)"
   and     xk: "x = 2 ^ n * of_nat k"
   and    le: "a \<le> x"
   and    sz: "n < LENGTH('a)"
   and   anz: "a mod 2 ^ n \<noteq> 0"
   shows "a div 2 ^ n < of_nat k"
 proof -
   have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
     using xk kv sz
     apply (subst unat_of_nat_eq)
      apply (erule order_less_le_trans)
      apply simp
     apply (subst unat_power_lower, simp)
     apply (subst mult.commute)
     apply (rule nat_less_power_trans)
      apply simp
     apply simp
     done
 
   have "unat a div 2 ^ n * 2 ^ n \<noteq> unat a"
   proof -
     have "unat a = unat a div 2 ^ n * 2 ^ n + unat a mod 2 ^ n"
       by (simp add: div_mult_mod_eq)
     also have "\<dots> \<noteq> unat a div 2 ^ n * 2 ^ n" using sz anz
       by (simp add: unat_arith_simps)
     finally show ?thesis ..
   qed
 
   then have "a div 2 ^ n * 2 ^ n < a" using sz anz
     apply (subst word_less_nat_alt)
     apply (subst unat_word_ariths)
     apply (subst unat_div)
     apply simp
     apply (rule order_le_less_trans [OF mod_less_eq_dividend])
     apply (erule order_le_neq_trans [OF div_mult_le])
     done
 
   also from xk le have "\<dots> \<le> of_nat k * 2 ^ n" by (simp add: field_simps)
   finally show ?thesis using sz kv
     apply -
     apply (erule word_mult_less_dest [OF _ _ kn])
     apply (simp add: unat_div)
     apply (rule order_le_less_trans [OF div_mult_le])
     apply (rule unat_lt2p)
     done
 qed
 
 lemma mask_out_sub_mask:
   "(x AND NOT (mask n)) = x - (x AND (mask n))"
   for x :: \<open>'a::len word\<close>
   by (simp add: field_simps word_plus_and_or_coroll2)
 
 lemma subtract_mask:
   "p - (p AND mask n) = (p AND NOT (mask n))"
   "p - (p AND NOT (mask n)) = (p AND mask n)"
   for p :: \<open>'a::len word\<close>
   by (simp add: field_simps word_plus_and_or_coroll2)+
 
 lemma take_bit_word_eq_self_iff:
   \<open>take_bit n w = w \<longleftrightarrow> n \<ge> LENGTH('a) \<or> w < 2 ^ n\<close>
   for w :: \<open>'a::len word\<close>
   using take_bit_int_eq_self_iff [of n \<open>take_bit LENGTH('a) (uint w)\<close>]
   by (transfer fixing: n) auto
 
 lemma word_power_increasing:
   assumes x: "2 ^ x < (2 ^ y::'a::len word)" "x < LENGTH('a::len)" "y < LENGTH('a::len)"
   shows "x < y" using x
   using assms by transfer simp
 
 lemma mask_twice:
   "(x AND mask n) AND mask m = x AND mask (min m n)"
   for x :: \<open>'a::len word\<close>
   by (simp flip: take_bit_eq_mask)
 
 lemma plus_one_helper[elim!]:
   "x < n + (1 :: 'a :: len word) \<Longrightarrow> x \<le> n"
   apply (simp add: word_less_nat_alt word_le_nat_alt field_simps)
   apply (case_tac "1 + n = 0")
    apply simp_all
   apply (subst(asm) unatSuc, assumption)
   apply arith
   done
 
 lemma plus_one_helper2:
   "\<lbrakk> x \<le> n; n + 1 \<noteq> 0 \<rbrakk> \<Longrightarrow> x < n + (1 :: 'a :: len word)"
   by (simp add: word_less_nat_alt word_le_nat_alt field_simps
                 unatSuc)
 
 lemma less_x_plus_1:
   fixes x :: "'a :: len word" shows
   "x \<noteq> max_word \<Longrightarrow> (y < (x + 1)) = (y < x \<or> y = x)"
   apply (rule iffI)
    apply (rule disjCI)
    apply (drule plus_one_helper)
    apply simp
   apply (subgoal_tac "x < x + 1")
    apply (erule disjE, simp_all)
   apply (rule plus_one_helper2 [OF order_refl])
   apply (rule notI, drule max_word_wrap)
   apply simp
   done
 
 lemma word_Suc_leq:
   fixes k::"'a::len word" shows "k \<noteq> max_word \<Longrightarrow> x < k + 1 \<longleftrightarrow> x \<le> k"
   using less_x_plus_1 word_le_less_eq by auto
 
 lemma word_Suc_le:
    fixes k::"'a::len word" shows "x \<noteq> max_word \<Longrightarrow> x + 1 \<le> k \<longleftrightarrow> x < k"
   by (meson not_less word_Suc_leq)
 
 lemma word_lessThan_Suc_atMost:
   \<open>{..< k + 1} = {..k}\<close> if \<open>k \<noteq> - 1\<close> for k :: \<open>'a::len word\<close>
   using that by (simp add: lessThan_def atMost_def word_Suc_leq)
 
 lemma word_atLeastLessThan_Suc_atLeastAtMost:
   \<open>{l ..< u + 1} = {l..u}\<close> if \<open>u \<noteq> - 1\<close> for l :: \<open>'a::len word\<close>
   using that by (simp add: atLeastAtMost_def atLeastLessThan_def word_lessThan_Suc_atMost)
 
 lemma word_atLeastAtMost_Suc_greaterThanAtMost:
   \<open>{m<..u} = {m + 1..u}\<close> if \<open>m \<noteq> - 1\<close> for m :: \<open>'a::len word\<close>
   using that by (simp add: greaterThanAtMost_def greaterThan_def atLeastAtMost_def atLeast_def word_Suc_le)
 
 lemma word_atLeastLessThan_Suc_atLeastAtMost_union:
   fixes l::"'a::len word"
   assumes "m \<noteq> max_word" and "l \<le> m" and "m \<le> u"
   shows "{l..m} \<union> {m+1..u} = {l..u}"
   proof -
   from ivl_disj_un_two(8)[OF assms(2) assms(3)] have "{l..u} = {l..m} \<union> {m<..u}" by blast
   with assms show ?thesis by(simp add: word_atLeastAtMost_Suc_greaterThanAtMost)
   qed
 
 lemma max_word_less_eq_iff [simp]:
   \<open>- 1 \<le> w \<longleftrightarrow> w = - 1\<close> for w :: \<open>'a::len word\<close>
   by (fact word_order.extremum_unique)
 
 lemma word_or_zero:
   "(a OR b = 0) = (a = 0 \<and> b = 0)"
   for a b :: \<open>'a::len word\<close>
   by (fact or_eq_0_iff)
 
 lemma word_2p_mult_inc:
   assumes x: "2 * 2 ^ n < (2::'a::len word) * 2 ^ m"
   assumes suc_n: "Suc n < LENGTH('a::len)"
   shows "2^n < (2::'a::len word)^m"
   by (smt suc_n le_less_trans lessI nat_less_le nat_mult_less_cancel_disj p2_gt_0
           power_Suc power_Suc unat_power_lower word_less_nat_alt x)
 
 lemma power_overflow:
   "n \<ge> LENGTH('a) \<Longrightarrow> 2 ^ n = (0 :: 'a::len word)"
   by simp
 
 lemmas extra_sle_sless_unfolds [simp] =
     word_sle_eq[where a=0 and b=1]
     word_sle_eq[where a=0 and b="numeral n"]
     word_sle_eq[where a=1 and b=0]
     word_sle_eq[where a=1 and b="numeral n"]
     word_sle_eq[where a="numeral n" and b=0]
     word_sle_eq[where a="numeral n" and b=1]
     word_sless_alt[where a=0 and b=1]
     word_sless_alt[where a=0 and b="numeral n"]
     word_sless_alt[where a=1 and b=0]
     word_sless_alt[where a=1 and b="numeral n"]
     word_sless_alt[where a="numeral n" and b=0]
     word_sless_alt[where a="numeral n" and b=1]
   for n
 
 lemma word_sint_1:
   "sint (1::'a::len word) = (if LENGTH('a) = 1 then -1 else 1)"
   by (fact signed_1)
 
 lemma ucast_of_nat:
   "is_down (ucast :: 'a :: len word \<Rightarrow> 'b :: len word)
     \<Longrightarrow> ucast (of_nat n :: 'a word) = (of_nat n :: 'b word)"
   by transfer simp
 
 lemma scast_1':
   "(scast (1::'a::len word) :: 'b::len word) =
    (word_of_int (signed_take_bit (LENGTH('a::len) - Suc 0) (1::int)))"
   by transfer simp
 
 lemma scast_1:
   "(scast (1::'a::len word) :: 'b::len word) = (if LENGTH('a) = 1 then -1 else 1)"
   by (fact signed_1)
 
 lemma unat_minus_one_word:
   "unat (-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
   apply (simp only: flip: mask_eq_exp_minus_1)
   apply transfer
   apply (simp add: take_bit_minus_one_eq_mask nat_mask_eq)
   done
 
 lemmas word_diff_ls'' = word_diff_ls [where xa=x and x=x for x]
 lemmas word_diff_ls' = word_diff_ls'' [simplified]
 
 lemmas word_l_diffs' = word_l_diffs [where xa=x and x=x for x]
 lemmas word_l_diffs = word_l_diffs' [simplified]
 
 lemma two_power_increasing:
   "\<lbrakk> n \<le> m; m < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n \<le> 2 ^ m"
   by (simp add: word_le_nat_alt)
 
 lemma word_leq_le_minus_one:
   "\<lbrakk> x \<le> y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x - 1 < (y :: 'a :: len word)"
   apply (simp add: word_less_nat_alt word_le_nat_alt)
   apply (subst unat_minus_one)
    apply assumption
   apply (cases "unat x")
    apply (simp add: unat_eq_zero)
   apply arith
   done
 
 lemma neg_mask_combine:
   "NOT(mask a) AND NOT(mask b) = NOT(mask (max a b) :: 'a::len word)"
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma neg_mask_twice:
   "x AND NOT(mask n) AND NOT(mask m) = x AND NOT(mask (max n m))"
   for x :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma multiple_mask_trivia:
   "n \<ge> m \<Longrightarrow> (x AND NOT(mask n)) + (x AND mask n AND NOT(mask m)) = x AND NOT(mask m)"
   for x :: \<open>'a::len word\<close>
   apply (rule trans[rotated], rule_tac w="mask n" in word_plus_and_or_coroll2)
   apply (simp add: word_bw_assocs word_bw_comms word_bw_lcs neg_mask_twice
                    max_absorb2)
   done
 
 lemma word_of_nat_less:
   "\<lbrakk> n < unat x \<rbrakk> \<Longrightarrow> of_nat n < x"
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
   apply (simp add: take_bit_eq_mod)
   done
 
 lemma unat_mask:
   "unat (mask n :: 'a :: len word) = 2 ^ (min n (LENGTH('a))) - 1"
   apply (subst min.commute)
   apply (simp add: mask_eq_decr_exp not_less min_def  split: if_split_asm)
   apply (intro conjI impI)
    apply (simp add: unat_sub_if_size)
    apply (simp add: power_overflow word_size)
   apply (simp add: unat_sub_if_size)
   done
 
 lemma mask_over_length:
   "LENGTH('a) \<le> n \<Longrightarrow> mask n = (-1::'a::len word)"
   by (simp add: mask_eq_decr_exp)
 
 lemma Suc_2p_unat_mask:
   "n < LENGTH('a) \<Longrightarrow> Suc (2 ^ n * k + unat (mask n :: 'a::len word)) = 2 ^ n * (k+1)"
   by (simp add: unat_mask)
 
 lemma sint_of_nat_ge_zero:
   "x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> sint (of_nat x :: 'a :: len word) \<ge> 0"
   by (simp add: bit_iff_odd)
 
 lemma int_eq_sint:
   "x < 2 ^ (LENGTH('a) - 1) \<Longrightarrow> sint (of_nat x :: 'a :: len word) = int x"
   apply transfer
   apply (rule signed_take_bit_int_eq_self)
    apply simp_all
   apply (metis negative_zle numeral_power_eq_of_nat_cancel_iff)
   done
 
 lemma sint_of_nat_le:
   "\<lbrakk> b < 2 ^ (LENGTH('a) - 1); a \<le> b \<rbrakk>
    \<Longrightarrow> sint (of_nat a :: 'a :: len word) \<le> sint (of_nat b :: 'a :: len word)"
   apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
   apply transfer
   apply (subst signed_take_bit_eq_if_positive)
    apply (simp add: bit_simps)
   apply (metis bit_take_bit_iff nat_less_le order_less_le_trans take_bit_nat_eq_self_iff)
   apply (subst signed_take_bit_eq_if_positive)
     apply (simp add: bit_simps)
   apply (metis bit_take_bit_iff nat_less_le take_bit_nat_eq_self_iff)
     apply (simp flip: of_nat_take_bit add: take_bit_nat_eq_self)
   done
 
 lemma word_le_not_less:
   "((b::'a::len word) \<le> a) = (\<not>(a < b))"
   by fastforce
 
 lemma less_is_non_zero_p1:
   fixes a :: "'a :: len word"
   shows "a < k \<Longrightarrow> a + 1 \<noteq> 0"
   apply (erule contrapos_pn)
   apply (drule max_word_wrap)
   apply (simp add: not_less)
   done
 
 lemma unat_add_lem':
   "(unat x + unat y < 2 ^ LENGTH('a)) \<Longrightarrow>
     (unat (x + y :: 'a :: len word) = unat x + unat y)"
   by (subst unat_add_lem[symmetric], assumption)
 
 lemma word_less_two_pow_divI:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ (n - m); m \<le> n; n < LENGTH('a) \<rbrakk> \<Longrightarrow> x < 2 ^ n div 2 ^ m"
   apply (simp add: word_less_nat_alt)
   apply (subst unat_word_ariths)
   apply (subst mod_less)
    apply (rule order_le_less_trans [OF div_le_dividend])
    apply (rule unat_lt2p)
   apply (simp add: power_sub)
   done
 
 lemma word_less_two_pow_divD:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ n div 2 ^ m \<rbrakk>
      \<Longrightarrow> n \<ge> m \<and> (x < 2 ^ (n - m))"
   apply (cases "n < LENGTH('a)")
    apply (cases "m < LENGTH('a)")
     apply (simp add: word_less_nat_alt)
     apply (subst(asm) unat_word_ariths)
     apply (subst(asm) mod_less)
      apply (rule order_le_less_trans [OF div_le_dividend])
      apply (rule unat_lt2p)
     apply (clarsimp dest!: less_two_pow_divD)
    apply (simp add: power_overflow)
    apply (simp add: word_div_def)
   apply (simp add: power_overflow word_div_def)
   done
 
 lemma of_nat_less_two_pow_div_set:
   "\<lbrakk> n < LENGTH('a) \<rbrakk> \<Longrightarrow>
    {x. x < (2 ^ n div 2 ^ m :: 'a::len word)}
       = of_nat ` {k. k < 2 ^ n div 2 ^ m}"
   apply (simp add: image_def)
   apply (safe dest!: word_less_two_pow_divD less_two_pow_divD
              intro!: word_less_two_pow_divI)
    apply (rule_tac x="unat x" in exI)
    apply (simp add: power_sub[symmetric])
    apply (subst unat_power_lower[symmetric, where 'a='a])
     apply simp
    apply (erule unat_mono)
   apply (subst word_unat_power)
   apply (rule of_nat_mono_maybe)
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply assumption
   done
 
 lemma ucast_less:
   "LENGTH('b) < LENGTH('a) \<Longrightarrow>
    (ucast (x :: 'b :: len word) :: ('a :: len word)) < 2 ^ LENGTH('b)"
   by transfer simp
 
 lemma ucast_range_less:
   "LENGTH('a :: len) < LENGTH('b :: len) \<Longrightarrow>
    range (ucast :: 'a word \<Rightarrow> 'b word) = {x. x < 2 ^ len_of TYPE ('a)}"
   apply safe
    apply (erule ucast_less)
   apply (simp add: image_def)
   apply (rule_tac x="ucast x" in exI)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps)
   apply (metis bit_take_bit_iff less_mask_eq not_less take_bit_eq_mask)
   done
 
 lemma word_power_less_diff:
   "\<lbrakk>2 ^ n * q < (2::'a::len word) ^ m; q < 2 ^ (LENGTH('a) - n)\<rbrakk> \<Longrightarrow> q < 2 ^ (m - n)"
   apply (case_tac "m \<ge> LENGTH('a)")
    apply (simp add: power_overflow)
   apply (case_tac "n \<ge> LENGTH('a)")
    apply (simp add: power_overflow)
   apply (cases "n = 0")
    apply simp
   apply (subst word_less_nat_alt)
   apply (subst unat_power_lower)
    apply simp
   apply (rule nat_power_less_diff)
   apply (simp add: word_less_nat_alt)
   apply (subst (asm) iffD1 [OF unat_mult_lem])
    apply (simp add:nat_less_power_trans)
   apply simp
   done
 
 lemma word_less_sub_1:
   "x < (y :: 'a :: len word) \<Longrightarrow> x \<le> y - 1"
   by (fact word_le_minus_one_leq)
 
 lemma word_sub_mono2:
   "\<lbrakk> a + b \<le> c + d; c \<le> a; b \<le> a + b; d \<le> c + d \<rbrakk>
     \<Longrightarrow> b \<le> (d :: 'a :: len word)"
   apply (drule(1) word_sub_mono)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_not_le:
   "(\<not> x \<le> (y :: 'a :: len word)) = (y < x)"
   by fastforce
 
 lemma word_subset_less:
   "\<lbrakk> {x .. x + r - 1} \<subseteq> {y .. y + s - 1};
      x \<le> x + r - 1; y \<le> y + (s :: 'a :: len word) - 1;
      s \<noteq> 0 \<rbrakk>
      \<Longrightarrow> r \<le> s"
   apply (frule subsetD[where c=x])
    apply simp
   apply (drule subsetD[where c="x + r - 1"])
    apply simp
   apply (clarsimp simp: add_diff_eq[symmetric])
   apply (drule(1) word_sub_mono2)
     apply (simp_all add: olen_add_eqv[symmetric])
   apply (erule word_le_minus_cancel)
   apply (rule ccontr)
   apply (simp add: word_not_le)
   done
 
 lemma uint_power_lower:
   "n < LENGTH('a) \<Longrightarrow> uint (2 ^ n :: 'a :: len word) = (2 ^ n :: int)"
   by (rule uint_2p_alt)
 
 lemma power_le_mono:
   "\<lbrakk>2 ^ n \<le> (2::'a::len word) ^ m; n < LENGTH('a); m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> n \<le> m"
   apply (clarsimp simp add: le_less)
   apply safe
   apply (simp add: word_less_nat_alt)
   apply (simp only: uint_arith_simps(3))
   apply (drule uint_power_lower)+
   apply simp
   done
 
 lemma two_power_eq:
   "\<lbrakk>n < LENGTH('a); m < LENGTH('a)\<rbrakk>
    \<Longrightarrow> ((2::'a::len word) ^ n = 2 ^ m) = (n = m)"
   apply safe
   apply (rule order_antisym)
    apply (simp add: power_le_mono[where 'a='a])+
   done
 
 lemma unat_less_helper:
   "x < of_nat n \<Longrightarrow> unat x < n"
   apply (simp add: word_less_nat_alt)
   apply (erule order_less_le_trans)
   apply (simp add: take_bit_eq_mod)
   done
 
 lemma nat_uint_less_helper:
   "nat (uint y) = z \<Longrightarrow> x < y \<Longrightarrow> nat (uint x) < z"
   apply (erule subst)
   apply (subst unat_eq_nat_uint [symmetric])
   apply (subst unat_eq_nat_uint [symmetric])
   by (simp add: unat_mono)
 
 lemma of_nat_0:
   "\<lbrakk>of_nat n = (0::'a::len word); n < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow> n = 0"
   by transfer (simp add: take_bit_eq_mod)
 
 lemma of_nat_inj:
   "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
    (of_nat x = (of_nat y :: 'a :: len word)) = (x = y)"
   by (metis unat_of_nat_len)
 
 lemma div_to_mult_word_lt:
   "\<lbrakk> (x :: 'a :: len word) \<le> y div z \<rbrakk> \<Longrightarrow> x * z \<le> y"
   apply (cases "z = 0")
    apply simp
   apply (simp add: word_neq_0_conv)
   apply (rule order_trans)
    apply (erule(1) word_mult_le_mono1)
    apply (simp add: unat_div)
    apply (rule order_le_less_trans [OF div_mult_le])
    apply simp
   apply (rule word_div_mult_le)
   done
 
 lemma ucast_ucast_mask:
   "(ucast :: 'a :: len word \<Rightarrow> 'b :: len word) (ucast x) = x AND mask (len_of TYPE ('a))"
   apply (simp flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: ac_simps)
   done
 
 lemma ucast_ucast_len:
   "\<lbrakk> x < 2 ^ LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (ucast x::'b::len word) = (x::'a::len word)"
   apply (subst ucast_ucast_mask)
   apply (erule less_mask_eq)
   done
 
 lemma ucast_ucast_id:
   "LENGTH('a) < LENGTH('b) \<Longrightarrow> ucast (ucast (x::'a::len word)::'b::len word) = x"
   by (auto intro: ucast_up_ucast_id simp: is_up_def source_size_def target_size_def word_size)
 
 lemma unat_ucast:
   "unat (ucast x :: ('a :: len) word) = unat x mod 2 ^ (LENGTH('a))"
 proof -
   have \<open>2 ^ LENGTH('a) = nat (2 ^ LENGTH('a))\<close>
     by simp
   moreover have \<open>unat (ucast x :: 'a word) = unat x mod nat (2 ^ LENGTH('a))\<close>
     by transfer (simp flip: nat_mod_distrib take_bit_eq_mod)
   ultimately show ?thesis
     by (simp only:)
 qed
 
 lemma ucast_less_ucast:
   "LENGTH('a) \<le> LENGTH('b) \<Longrightarrow>
    (ucast x < ((ucast (y :: 'a::len word)) :: 'b::len word)) = (x < y)"
   apply (simp add: word_less_nat_alt unat_ucast)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply (subst mod_less)
    apply(rule less_le_trans[OF unat_lt2p], simp)
   apply simp
   done
 
 \<comment> \<open>This weaker version was previously called @{text ucast_less_ucast}. We retain it to
     support existing proofs.\<close>
 lemmas ucast_less_ucast_weak = ucast_less_ucast[OF order.strict_implies_order]
 
 lemma unat_Suc2:
   fixes n :: "'a :: len word"
   shows
   "n \<noteq> -1 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
   apply (subst add.commute, rule unatSuc)
   apply (subst eq_diff_eq[symmetric], simp add: minus_equation_iff)
   done
 
 lemma word_div_1:
   "(n :: 'a :: len word) div 1 = n"
   by (fact bits_div_by_1)
 
 lemma word_minus_one_le:
   "-1 \<le> (x :: 'a :: len word) = (x = -1)"
   by (fact word_order.extremum_unique)
 
 lemma up_scast_inj:
       "\<lbrakk> scast x = (scast y :: 'b :: len word); size x \<le> LENGTH('b) \<rbrakk>
          \<Longrightarrow> x = y"
   apply transfer
   apply (cases \<open>LENGTH('a)\<close>)
   apply simp_all
   apply (metis order_refl take_bit_signed_take_bit take_bit_tightened)
   done
 
 lemma up_scast_inj_eq:
   "LENGTH('a) \<le> len_of TYPE ('b) \<Longrightarrow>
   (scast x = (scast y::'b::len word)) = (x = (y::'a::len word))"
   by (fastforce dest: up_scast_inj simp: word_size)
 
 lemma word_le_add:
   fixes x :: "'a :: len word"
   shows "x \<le> y \<Longrightarrow> \<exists>n. y = x + of_nat n"
   by (rule exI [where x = "unat (y - x)"]) simp
 
 lemma word_plus_mcs_4':
   fixes x :: "'a :: len word"
   shows "\<lbrakk>x + v \<le> x + w; x \<le> x + v\<rbrakk> \<Longrightarrow> v \<le> w"
   apply (rule word_plus_mcs_4)
    apply (simp add: add.commute)
   apply (simp add: add.commute)
   done
 
+lemma unat_eq_1:
+  \<open>unat x = Suc 0 \<longleftrightarrow> x = 1\<close>
+  by (auto intro!: unsigned_word_eqI [where ?'a = nat])
+
+lemma word_unat_Rep_inject1:
+  \<open>unat x = unat 1 \<longleftrightarrow> x = 1\<close>
+  by (simp add: unat_eq_1)
+
+lemma and_not_mask_twice:
+  "(w AND NOT (mask n)) AND NOT (mask m) = w AND NOT (mask (max m n))"
+  for w :: \<open>'a::len word\<close>
+  by (rule bit_word_eqI) (auto simp add: bit_simps)
+
+lemma word_less_cases:
+  "x < y \<Longrightarrow> x = y - 1 \<or> x < y - (1 ::'a::len word)"
+  apply (drule word_less_sub_1)
+  apply (drule order_le_imp_less_or_eq)
+  apply auto
+  done
+
+lemma mask_and_mask:
+  "mask a AND mask b = (mask (min a b) :: 'a::len word)"
+  by (simp flip: take_bit_eq_mask ac_simps)
+
+lemma mask_eq_0_eq_x:
+  "(x AND w = 0) = (x AND NOT w = x)"
+  for x w :: \<open>'a::len word\<close>
+  using word_plus_and_or_coroll2[where x=x and w=w]
+  by auto
+
+lemma mask_eq_x_eq_0:
+  "(x AND w = x) = (x AND NOT w = 0)"
+  for x w :: \<open>'a::len word\<close>
+  using word_plus_and_or_coroll2[where x=x and w=w]
+  by auto
+
+lemma compl_of_1: "NOT 1 = (-2 :: 'a :: len word)"
+  by (fact not_one)
+
+lemma split_word_eq_on_mask:
+  "(x = y) = (x AND m = y AND m \<and> x AND NOT m = y AND NOT m)"
+  for x y m :: \<open>'a::len word\<close>
+  apply transfer
+  apply (simp add: bit_eq_iff)
+  apply (auto simp add: bit_simps ac_simps)
+  done
+
+lemma word_FF_is_mask:
+  "0xFF = (mask 8 :: 'a::len word)"
+  by (simp add: mask_eq_decr_exp)
+
+lemma word_1FF_is_mask:
+  "0x1FF = (mask 9 :: 'a::len word)"
+  by (simp add: mask_eq_decr_exp)
+
+lemma ucast_of_nat_small:
+  "x < 2 ^ LENGTH('a) \<Longrightarrow> ucast (of_nat x :: 'a :: len word) = (of_nat x :: 'b :: len word)"
+  apply transfer
+  apply (auto simp add: take_bit_of_nat min_def not_le)
+  apply (metis linorder_not_less min_def take_bit_nat_eq_self take_bit_take_bit)
+  done
+
+lemma word_le_make_less:
+  fixes x :: "'a :: len word"
+  shows "y \<noteq> -1 \<Longrightarrow> (x \<le> y) = (x < (y + 1))"
+  apply safe
+  apply (erule plus_one_helper2)
+  apply (simp add: eq_diff_eq[symmetric])
+  done
+
+lemmas finite_word = finite [where 'a="'a::len word"]
+
+lemma word_to_1_set:
+  "{0 ..< (1 :: 'a :: len word)} = {0}"
+  by fastforce
+
+lemma word_leq_minus_one_le:
+  fixes x :: "'a::len word"
+  shows "\<lbrakk>y \<noteq> 0; x \<le> y - 1 \<rbrakk> \<Longrightarrow> x < y"
+  using le_m1_iff_lt word_neq_0_conv by blast
+
+lemma word_count_from_top:
+  "n \<noteq> 0 \<Longrightarrow> {0 ..< n :: 'a :: len word} = {0 ..< n - 1} \<union> {n - 1}"
+  apply (rule set_eqI, rule iffI)
+   apply simp
+   apply (drule word_le_minus_one_leq)
+   apply (rule disjCI)
+   apply simp
+  apply simp
+  apply (erule word_leq_minus_one_le)
+  apply fastforce
+  done
+
+lemma word_minus_one_le_leq:
+  "\<lbrakk> x - 1 < y \<rbrakk> \<Longrightarrow> x \<le> (y :: 'a :: len word)"
+  apply (cases "x = 0")
+   apply simp
+  apply (simp add: word_less_nat_alt word_le_nat_alt)
+  apply (subst(asm) unat_minus_one)
+   apply (simp add: word_less_nat_alt)
+  apply (cases "unat x")
+   apply (simp add: unat_eq_zero)
+  apply arith
+  done
+
+lemma word_div_less:
+  "m < n \<Longrightarrow> m div n = 0" for m :: "'a :: len word"
+  by (simp add: unat_mono word_arith_nat_defs(6))
+
+lemma word_must_wrap:
+  "\<lbrakk> x \<le> n - 1; n \<le> x \<rbrakk> \<Longrightarrow> n = (0 :: 'a :: len word)"
+  using dual_order.trans sub_wrap word_less_1 by blast
+
+lemma range_subset_card:
+  "\<lbrakk> {a :: 'a :: len word .. b} \<subseteq> {c .. d}; b \<ge> a \<rbrakk> \<Longrightarrow> d \<ge> c \<and> d - c \<ge> b - a"
+  using word_sub_le word_sub_mono by fastforce
+
+lemma less_1_simp:
+  "n - 1 < m = (n \<le> (m :: 'a :: len word) \<and> n \<noteq> 0)"
+  by unat_arith
+
+lemma word_power_mod_div:
+  fixes x :: "'a::len word"
+  shows "\<lbrakk> n < LENGTH('a); m < LENGTH('a)\<rbrakk>
+  \<Longrightarrow> x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)"
+  apply (simp add: word_arith_nat_div unat_mod power_mod_div)
+  apply (subst unat_arith_simps(3))
+  apply (subst unat_mod)
+  apply (subst unat_of_nat)+
+  apply (simp add: mod_mod_power min.commute)
+  done
+
+lemma word_range_minus_1':
+  fixes a :: "'a :: len word"
+  shows "a \<noteq> 0 \<Longrightarrow> {a - 1<..b} = {a..b}"
+  by (simp add: greaterThanAtMost_def atLeastAtMost_def greaterThan_def atLeast_def less_1_simp)
+
+lemma word_range_minus_1:
+  fixes a :: "'a :: len word"
+  shows "b \<noteq> 0 \<Longrightarrow> {a..b - 1} = {a..<b}"
+  apply (simp add: atLeastLessThan_def atLeastAtMost_def atMost_def lessThan_def)
+  apply (rule arg_cong [where f = "\<lambda>x. {a..} \<inter> x"])
+  apply rule
+   apply clarsimp
+   apply (erule contrapos_pp)
+   apply (simp add: linorder_not_less linorder_not_le word_must_wrap)
+  apply (clarsimp)
+  apply (drule word_le_minus_one_leq)
+  apply (auto simp: word_less_sub_1)
+  done
+
+lemma ucast_nat_def:
+  "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> 'b :: len word) x"
+  by transfer simp
+
+lemma overflow_plus_one_self:
+  "(1 + p \<le> p) = (p = (-1 :: 'a :: len word))"
+  apply rule
+  apply (rule ccontr)
+   apply (drule plus_one_helper2)
+   apply (rule notI)
+   apply (drule arg_cong[where f="\<lambda>x. x - 1"])
+   apply simp
+   apply (simp add: field_simps)
+  apply simp
+  done
+
+lemma plus_1_less:
+  "(x + 1 \<le> (x :: 'a :: len word)) = (x = -1)"
+  apply (rule iffI)
+   apply (rule ccontr)
+   apply (cut_tac plus_one_helper2[where x=x, OF order_refl])
+    apply simp
+   apply clarsimp
+   apply (drule arg_cong[where f="\<lambda>x. x - 1"])
+   apply simp
+  apply simp
+  done
+
+lemma pos_mult_pos_ge:
+  "[|x > (0::int); n>=0 |] ==> n * x >= n*1"
+  apply (simp only: mult_left_mono)
+  done
+
+lemma word_plus_strict_mono_right:
+  fixes x :: "'a :: len word"
+  shows "\<lbrakk>y < z; x \<le> x + z\<rbrakk> \<Longrightarrow> x + y < x + z"
+  by unat_arith
+
+lemma word_div_mult:
+  "0 < c \<Longrightarrow> a < b * c \<Longrightarrow> a div c < b" for a b c :: "'a::len word"
+  by (rule classical)
+     (use div_to_mult_word_lt [of b a c] in
+      \<open>auto simp add: word_less_nat_alt word_le_nat_alt unat_div\<close>)
+
+lemma word_less_power_trans_ofnat:
+  "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk>
+   \<Longrightarrow> of_nat n * 2 ^ k < (2::'a::len word) ^ m"
+  apply (subst mult.commute)
+  apply (rule word_less_power_trans)
+    apply (simp_all add: word_less_nat_alt less_le_trans take_bit_eq_mod)
+  done
+
+lemma word_1_le_power:
+  "n < LENGTH('a) \<Longrightarrow> (1 :: 'a :: len word) \<le> 2 ^ n"
+  by (rule inc_le[where i=0, simplified], erule iffD2[OF p2_gt_0])
+
+lemma unat_1_0:
+  "1 \<le> (x::'a::len word) = (0 < unat x)"
+  by (auto simp add: word_le_nat_alt)
+
+lemma x_less_2_0_1':
+  fixes x :: "'a::len word"
+  shows "\<lbrakk>LENGTH('a) \<noteq> 1; x < 2\<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
+  apply (cases \<open>2 \<le> LENGTH('a)\<close>)
+  apply simp_all
+  apply transfer
+  apply auto
+  apply (metis add.commute add.right_neutral even_two_times_div_two mod_div_trivial mod_pos_pos_trivial mult.commute mult_zero_left not_less not_take_bit_negative odd_two_times_div_two_succ) 
+  done
+
+lemmas word_add_le_iff2 = word_add_le_iff [folded no_olen_add_nat]
+
+lemma of_nat_power:
+  shows "\<lbrakk> p < 2 ^ x; x < len_of TYPE ('a) \<rbrakk> \<Longrightarrow> of_nat p < (2 :: 'a :: len word) ^ x"
+  apply (rule order_less_le_trans)
+   apply (rule of_nat_mono_maybe)
+    apply (erule power_strict_increasing)
+    apply simp
+   apply assumption
+  apply (simp add: word_unat_power del: of_nat_power)
+  done
+
+lemma of_nat_n_less_equal_power_2:
+  "n < LENGTH('a::len) \<Longrightarrow> ((of_nat n)::'a word) < 2 ^ n"
+  apply (induct n)
+   apply clarsimp
+  apply clarsimp
+  apply (metis of_nat_power n_less_equal_power_2 of_nat_Suc power_Suc)
+  done
+
+lemma eq_mask_less:
+  fixes w :: "'a::len word"
+  assumes eqm: "w = w AND mask n"
+  and      sz: "n < len_of TYPE ('a)"
+  shows "w < (2::'a word) ^ n"
+  by (subst eqm, rule and_mask_less' [OF sz])
+
+lemma of_nat_mono_maybe':
+  fixes Y :: "nat"
+  assumes xlt: "x < 2 ^ len_of TYPE ('a)"
+  assumes ylt: "y < 2 ^ len_of TYPE ('a)"
+  shows   "(y < x) = (of_nat y < (of_nat x :: 'a :: len word))"
+  apply (subst word_less_nat_alt)
+  apply (subst unat_of_nat)+
+  apply (subst mod_less)
+   apply (rule ylt)
+  apply (subst mod_less)
+   apply (rule xlt)
+  apply simp
+  done
+
+lemma of_nat_mono_maybe_le:
+  "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
+  (y \<le> x) = ((of_nat y :: 'a :: len word) \<le> of_nat x)"
+  apply (clarsimp simp: le_less)
+  apply (rule disj_cong)
+   apply (rule of_nat_mono_maybe', assumption+)
+  apply auto
+  using of_nat_inj apply blast
+  done
+
+lemma mask_AND_NOT_mask:
+  "(w AND NOT (mask n)) AND mask n = 0"
+  for w :: \<open>'a::len word\<close>
+  by (rule bit_word_eqI) (simp add: bit_simps)
+
+lemma AND_NOT_mask_plus_AND_mask_eq:
+  "(w AND NOT (mask n)) + (w AND mask n) = w"
+  for w :: \<open>'a::len word\<close>
+  apply (subst disjunctive_add)
+  apply (auto simp add: bit_simps)
+  apply (rule bit_word_eqI)
+  apply (auto simp add: bit_simps)
+  done
+
+lemma mask_eqI:
+  fixes x :: "'a :: len word"
+  assumes m1: "x AND mask n = y AND mask n"
+  and     m2: "x AND NOT (mask n) = y AND NOT (mask n)"
+  shows "x = y"
+proof -
+  have *: \<open>x = x AND mask n OR x AND NOT (mask n)\<close> for x :: \<open>'a word\<close>
+    by (rule bit_word_eqI) (auto simp add: bit_simps)
+  from assms * [of x] * [of y] show ?thesis
+    by simp
+qed
+
+lemma neq_0_no_wrap:
+  fixes x :: "'a :: len word"
+  shows "\<lbrakk> x \<le> x + y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
+  by clarsimp
+
+lemma unatSuc2:
+  fixes n :: "'a :: len word"
+  shows "n + 1 \<noteq> 0 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
+  by (simp add: add.commute unatSuc)
+
+lemma word_of_nat_le:
+  "n \<le> unat x \<Longrightarrow> of_nat n \<le> x"
+  apply (simp add: word_le_nat_alt unat_of_nat)
+  apply (erule order_trans[rotated])
+  apply (simp add: take_bit_eq_mod)
+  done
+
+lemma word_unat_less_le:
+  "a \<le> of_nat b \<Longrightarrow> unat a \<le> b"
+  by (metis eq_iff le_cases le_unat_uoi word_of_nat_le)
+
+lemma mask_Suc_0 : "mask (Suc 0) = (1 :: 'a::len word)"
+  by (simp add: mask_eq_decr_exp)
+
+lemma bool_mask':
+  fixes x :: "'a :: len word"
+  shows "2 < LENGTH('a) \<Longrightarrow> (0 < x AND 1) = (x AND 1 = 1)"
+  by (simp add: and_one_eq mod_2_eq_odd)
+
+lemma ucast_ucast_add:
+  fixes x :: "'a :: len word"
+  fixes y :: "'b :: len word"
+  shows
+  "LENGTH('b) \<ge> LENGTH('a) \<Longrightarrow>
+    ucast (ucast x + y) = x + ucast y"
+  apply transfer
+  apply simp
+  apply (subst (2) take_bit_add [symmetric])
+  apply (subst take_bit_add [symmetric])
+  apply simp
+  done
+
+lemma lt1_neq0:
+  fixes x :: "'a :: len word"
+  shows "(1 \<le> x) = (x \<noteq> 0)" by unat_arith
+
+lemma word_plus_one_nonzero:
+  fixes x :: "'a :: len word"
+  shows "\<lbrakk>x \<le> x + y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x + 1 \<noteq> 0"
+  apply (subst lt1_neq0 [symmetric])
+  apply (subst olen_add_eqv [symmetric])
+  apply (erule word_random)
+  apply (simp add: lt1_neq0)
+  done
+
+lemma word_sub_plus_one_nonzero:
+  fixes n :: "'a :: len word"
+  shows "\<lbrakk>n' \<le> n; n' \<noteq> 0\<rbrakk> \<Longrightarrow> (n - n') + 1 \<noteq> 0"
+  apply (subst lt1_neq0 [symmetric])
+  apply (subst olen_add_eqv [symmetric])
+  apply (rule word_random [where x' = n'])
+   apply simp
+   apply (erule word_sub_le)
+  apply (simp add: lt1_neq0)
+  done
+
+lemma word_le_minus_mono_right:
+  fixes x :: "'a :: len word"
+  shows "\<lbrakk> z \<le> y; y \<le> x; z \<le> x \<rbrakk> \<Longrightarrow> x - y \<le> x - z"
+  apply (rule word_sub_mono)
+     apply simp
+    apply assumption
+   apply (erule word_sub_le)
+  apply (erule word_sub_le)
+  done
+
+lemma word_0_sle_from_less:
+  \<open>0 \<le>s x\<close> if \<open>x < 2 ^ (LENGTH('a) - 1)\<close> for x :: \<open>'a::len word\<close>
+  using that
+  apply transfer
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  apply (metis bit_take_bit_iff min_def nat_less_le not_less_eq take_bit_int_eq_self_iff take_bit_take_bit)
+  done
+
+lemma ucast_sub_ucast:
+  fixes x :: "'a::len word"
+  assumes "y \<le> x"
+  assumes T: "LENGTH('a) \<le> LENGTH('b)"
+  shows "ucast (x - y) = (ucast x - ucast y :: 'b::len word)"
+proof -
+  from T
+  have P: "unat x < 2 ^ LENGTH('b)" "unat y < 2 ^ LENGTH('b)"
+    by (fastforce intro!: less_le_trans[OF unat_lt2p])+
+  then show ?thesis
+    by (simp add: unat_arith_simps unat_ucast assms[simplified unat_arith_simps])
+qed
+
+lemma word_1_0:
+  "\<lbrakk>a + (1::('a::len) word) \<le> b; a < of_nat x\<rbrakk> \<Longrightarrow> a < b"
+  apply transfer
+  apply (subst (asm) take_bit_incr_eq)
+   apply (auto simp add: diff_less_eq)
+  using take_bit_int_less_exp le_less_trans by blast
+
+lemma unat_of_nat_less:"\<lbrakk> a < b; unat b = c \<rbrakk> \<Longrightarrow> a < of_nat c"
+  by fastforce
+
+lemma word_le_plus_1: "\<lbrakk> (y::('a::len) word) < y + n; a < n \<rbrakk> \<Longrightarrow> y + a \<le> y + a + 1"
+  by unat_arith
+
+lemma word_le_plus:"\<lbrakk>(a::('a::len) word) < a + b; c < b\<rbrakk> \<Longrightarrow> a \<le> a + c"
+  by (metis order_less_imp_le word_random)
+
+lemma sint_minus1 [simp]: "(sint x = -1) = (x = -1)"
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  apply transfer
+  apply (simp flip: signed_take_bit_eq_iff_take_bit_eq)
+  done
+
+lemma sint_0 [simp]: "(sint x = 0) = (x = 0)"
+  by (fact signed_eq_0_iff)
+
+(* It is not always that case that "sint 1 = 1", because of 1-bit word sizes.
+ * This lemma produces the different cases. *)
+lemma sint_1_cases:
+  P if \<open>\<lbrakk> len_of TYPE ('a::len) = 1; (a::'a word) = 0; sint a = 0 \<rbrakk> \<Longrightarrow> P\<close>
+     \<open>\<lbrakk> len_of TYPE ('a) = 1; a = 1; sint (1 :: 'a word) = -1 \<rbrakk> \<Longrightarrow> P\<close>
+     \<open>\<lbrakk> len_of TYPE ('a) > 1; sint (1 :: 'a word) = 1 \<rbrakk> \<Longrightarrow> P\<close>
+proof (cases \<open>LENGTH('a) = 1\<close>)
+  case True
+  then have \<open>a = 0 \<or> a = 1\<close>
+    by transfer auto
+  with True that show ?thesis
+    by auto
+next
+  case False
+  with that show ?thesis
+    by (simp add: less_le Suc_le_eq)
+qed
+
+lemma sint_int_min:
+  "sint (- (2 ^ (LENGTH('a) - Suc 0)) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  apply transfer
+  apply (simp add: signed_take_bit_int_eq_self)
+  done
+
+lemma sint_int_max_plus_1:
+  "sint (2 ^ (LENGTH('a) - Suc 0) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  apply (subst word_of_int_2p [symmetric])
+  apply (subst int_word_sint)
+  apply simp
+  done
+
+lemma uint_range':
+  \<open>0 \<le> uint x \<and> uint x < 2 ^ LENGTH('a)\<close>
+  for x :: \<open>'a::len word\<close>
+  by transfer simp
+
+lemma sint_of_int_eq:
+  "\<lbrakk> - (2 ^ (LENGTH('a) - 1)) \<le> x; x < 2 ^ (LENGTH('a) - 1) \<rbrakk> \<Longrightarrow> sint (of_int x :: ('a::len) word) = x"
+  by (simp add: signed_take_bit_int_eq_self)
+
+lemma of_int_sint:
+  "of_int (sint a) = a"
+  by simp
+
+lemma sint_ucast_eq_uint:
+    "\<lbrakk> \<not> is_down (ucast :: ('a::len word \<Rightarrow> 'b::len word)) \<rbrakk>
+            \<Longrightarrow> sint ((ucast :: ('a::len word \<Rightarrow> 'b::len word)) x) = uint x"
+  apply transfer
+  apply (simp add: signed_take_bit_take_bit)
+  done
+
+lemma word_less_nowrapI':
+  "(x :: 'a :: len word) \<le> z - k \<Longrightarrow> k \<le> z \<Longrightarrow> 0 < k \<Longrightarrow> x < x + k"
+  by uint_arith
+
+lemma mask_plus_1:
+  "mask n + 1 = (2 ^ n :: 'a::len word)"
+  by (clarsimp simp: mask_eq_decr_exp)
+
+lemma unat_inj: "inj unat"
+  by (metis eq_iff injI word_le_nat_alt)
+
+lemma unat_ucast_upcast:
+  "is_up (ucast :: 'b word \<Rightarrow> 'a word)
+      \<Longrightarrow> unat (ucast x :: ('a::len) word) = unat (x :: ('b::len) word)"
+  unfolding ucast_eq unat_eq_nat_uint
+  apply transfer
+  apply simp
+  done
+
+lemma ucast_mono:
+  "\<lbrakk> (x :: 'b :: len word) < y; y < 2 ^ LENGTH('a) \<rbrakk>
+   \<Longrightarrow> ucast x < ((ucast y) :: 'a :: len word)"
+  apply (simp only: flip: ucast_nat_def)
+  apply (rule of_nat_mono_maybe)
+  apply (rule unat_less_helper)
+  apply simp
+  apply (simp add: word_less_nat_alt)
+  done
+
+lemma ucast_mono_le:
+  "\<lbrakk>x \<le> y; y < 2 ^ LENGTH('b)\<rbrakk> \<Longrightarrow> (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> ucast y"
+  apply (simp only: flip: ucast_nat_def)
+  apply (subst of_nat_mono_maybe_le[symmetric])
+    apply (rule unat_less_helper)
+    apply simp
+   apply (rule unat_less_helper)
+   apply (erule le_less_trans)
+  apply (simp_all add: word_le_nat_alt)
+  done
+
+lemma ucast_mono_le':
+  "\<lbrakk> unat y < 2 ^ LENGTH('b); LENGTH('b::len) < LENGTH('a::len); x \<le> y \<rbrakk>
+   \<Longrightarrow> ucast x \<le> (ucast y :: 'b word)" for x y :: \<open>'a::len word\<close>
+  by (auto simp: word_less_nat_alt intro: ucast_mono_le)
+
+lemma neg_mask_add_mask:
+  "((x:: 'a :: len word) AND NOT (mask n)) + (2 ^ n - 1) = x OR mask n"
+  unfolding mask_2pm1 [symmetric]
+  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
+   apply (auto simp add: bit_simps)
+  done
+
+lemma le_step_down_word:"\<lbrakk>(i::('a::len) word) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
+  by unat_arith
+
+lemma le_step_down_word_2:
+  fixes x :: "'a::len word"
+  shows "\<lbrakk>x \<le>  y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
+  by (subst (asm) word_le_less_eq,
+      clarsimp,
+      simp add: word_le_minus_one_leq)
+
+lemma NOT_mask_AND_mask[simp]: "(w AND mask n) AND NOT (mask n) = 0"
+  by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff bit_mask_iff)
+
+lemma and_and_not[simp]:"(a AND b) AND NOT b = 0"
+  for a b :: \<open>'a::len word\<close>
+  apply (subst word_bw_assocs(1))
+  apply clarsimp
+  done
+
+lemma ex_mask_1[simp]: "(\<exists>x. mask x = (1 :: 'a::len word))"
+  apply (rule_tac x=1 in exI)
+  apply (simp add:mask_eq_decr_exp)
+  done
+
+lemma not_switch:"NOT a = x \<Longrightarrow> a = NOT x"
+  by auto
+
 end
diff --git a/thys/Word_Lib/Most_significant_bit.thy b/thys/Word_Lib/Most_significant_bit.thy
--- a/thys/Word_Lib/Most_significant_bit.thy
+++ b/thys/Word_Lib/Most_significant_bit.thy
@@ -1,168 +1,198 @@
 (*  Author:     Jeremy Dawson, NICTA
 *)
 
 section \<open>Dedicated operation for the most significant bit\<close>
 
 theory Most_significant_bit
   imports
     "HOL-Library.Word"
     Bits_Int
     Traditional_Infix_Syntax
     More_Arithmetic
 begin
 
 class msb =
   fixes msb :: \<open>'a \<Rightarrow> bool\<close>
 
 instantiation int :: msb
 begin
 
 definition \<open>msb x \<longleftrightarrow> x < 0\<close> for x :: int
 
 instance ..
 
 end
 
 lemma msb_conv_bin_sign: "msb x \<longleftrightarrow> bin_sign x = -1"
 by(simp add: bin_sign_def not_le msb_int_def)
 
 lemma msb_bin_rest [simp]: "msb (x div 2) = msb x"
   for x :: int
   by (simp add: msb_int_def)
 
 lemma int_msb_and [simp]: "msb ((x :: int) AND y) \<longleftrightarrow> msb x \<and> msb y"
 by(simp add: msb_int_def)
 
 lemma int_msb_or [simp]: "msb ((x :: int) OR y) \<longleftrightarrow> msb x \<or> msb y"
 by(simp add: msb_int_def)
 
 lemma int_msb_xor [simp]: "msb ((x :: int) XOR y) \<longleftrightarrow> msb x \<noteq> msb y"
 by(simp add: msb_int_def)
 
 lemma int_msb_not [simp]: "msb (NOT (x :: int)) \<longleftrightarrow> \<not> msb x"
 by(simp add: msb_int_def not_less)
 
 lemma msb_shiftl [simp]: "msb ((x :: int) << n) \<longleftrightarrow> msb x"
 by(simp add: msb_int_def)
 
 lemma msb_shiftr [simp]: "msb ((x :: int) >> r) \<longleftrightarrow> msb x"
 by(simp add: msb_int_def)
 
 lemma msb_bin_sc [simp]: "msb (bin_sc n b x) \<longleftrightarrow> msb x"
 by(simp add: msb_conv_bin_sign)
 
 lemma msb_0 [simp]: "msb (0 :: int) = False"
 by(simp add: msb_int_def)
 
 lemma msb_1 [simp]: "msb (1 :: int) = False"
 by(simp add: msb_int_def)
 
 lemma msb_numeral [simp]:
   "msb (numeral n :: int) = False"
   "msb (- numeral n :: int) = True"
 by(simp_all add: msb_int_def)
 
 instantiation word :: (len) msb
 begin
 
 definition msb_word :: \<open>'a word \<Rightarrow> bool\<close>
   where \<open>msb a \<longleftrightarrow> bin_sign (sbintrunc (LENGTH('a) - 1) (uint a)) = - 1\<close>
 
 lemma msb_word_eq:
   \<open>msb w \<longleftrightarrow> bit w (LENGTH('a) - 1)\<close> for w :: \<open>'a::len word\<close>
   by (simp add: msb_word_def bin_sign_lem bit_uint_iff)
 
 instance ..
 
 end
 
 lemma msb_word_iff_bit:
   \<open>msb w \<longleftrightarrow> bit w (LENGTH('a) - Suc 0)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: msb_word_def bin_sign_def bit_uint_iff)
 
 lemma word_msb_def:
   "msb a \<longleftrightarrow> bin_sign (sint a) = - 1"
   by (simp add: msb_word_def sint_uint)
 
 lemma word_msb_sint: "msb w \<longleftrightarrow> sint w < 0"
   by (simp add: msb_word_eq bit_last_iff)
 
 lemma msb_word_iff_sless_0:
   \<open>msb w \<longleftrightarrow> w <s 0\<close>
   by (simp add: word_msb_sint word_sless_alt)
 
 lemma msb_word_of_int: "msb (word_of_int x::'a::len word) = bin_nth x (LENGTH('a) - 1)"
   by (simp add: word_msb_def bin_sign_lem)
 
 lemma word_msb_numeral [simp]:
   "msb (numeral w::'a::len word) = bin_nth (numeral w) (LENGTH('a) - 1)"
   unfolding word_numeral_alt by (rule msb_word_of_int)
 
 lemma word_msb_neg_numeral [simp]:
   "msb (- numeral w::'a::len word) = bin_nth (- numeral w) (LENGTH('a) - 1)"
   unfolding word_neg_numeral_alt by (rule msb_word_of_int)
 
 lemma word_msb_0 [simp]: "\<not> msb (0::'a::len word)"
   by (simp add: word_msb_def bin_sign_def sint_uint sbintrunc_eq_take_bit)
 
 lemma word_msb_1 [simp]: "msb (1::'a::len word) \<longleftrightarrow> LENGTH('a) = 1"
   unfolding word_1_wi msb_word_of_int eq_iff [where 'a=nat]
   by (simp add: Suc_le_eq)
 
 lemma word_msb_nth: "msb w = bin_nth (uint w) (LENGTH('a) - 1)"
   for w :: "'a::len word"
   by (simp add: word_msb_def sint_uint bin_sign_lem)
 
 lemma msb_nth: "msb w = w !! (LENGTH('a) - 1)"
   for w :: "'a::len word"
   by (simp add: word_msb_nth word_test_bit_def)
 
 lemma word_msb_n1 [simp]: "msb (-1::'a::len word)"
   by (simp add: msb_word_eq not_le)
 
 lemma msb_shift: "msb w \<longleftrightarrow> w >> (LENGTH('a) - 1) \<noteq> 0"
   for w :: "'a::len word"
   by (simp add: msb_word_eq shiftr_word_eq bit_iff_odd_drop_bit drop_bit_eq_zero_iff_not_bit_last)
 
 lemmas word_ops_msb = msb1 [unfolded msb_nth [symmetric, unfolded One_nat_def]]
 
 lemma word_sint_msb_eq: "sint x = uint x - (if msb x then 2 ^ size x else 0)"
   apply (cases \<open>LENGTH('a)\<close>)
    apply (simp_all add: msb_word_def bin_sign_def bit_simps word_size)
   apply transfer
   apply (auto simp add: take_bit_Suc_from_most signed_take_bit_eq_if_positive signed_take_bit_eq_if_negative minus_exp_eq_not_mask ac_simps)
   apply (subst disjunctive_add)
    apply (simp_all add: bit_simps)
   done
 
 lemma word_sle_msb_le: "x <=s y \<longleftrightarrow> (msb y \<longrightarrow> msb x) \<and> ((msb x \<and> \<not> msb y) \<or> x \<le> y)"
   apply (simp add: word_sle_eq 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 \<longleftrightarrow> (msb y \<longrightarrow> msb x) \<and> ((msb x \<and> \<not> msb y) \<or> x < y)"
   by (auto simp add: word_sless_eq word_sle_msb_le)
 
 lemma not_msb_from_less:
   "(v :: 'a word) < 2 ^ (LENGTH('a :: len) - 1) \<Longrightarrow> \<not> msb v"
   apply (clarsimp simp add: msb_nth)
   apply (drule less_mask_eq)
   apply (drule word_eqD, drule(1) iffD2)
   apply simp
   done
 
 lemma sint_eq_uint:
   "\<not> msb x \<Longrightarrow> sint x = uint x"
   apply (simp add: msb_word_eq)
   apply transfer
   apply auto
   apply (smt One_nat_def bintrunc_bintrunc_l bintrunc_sbintrunc' diff_le_self len_gt_0 signed_take_bit_eq_if_positive)
   done
 
+lemma scast_eq_ucast:
+  "\<not> msb x \<Longrightarrow> scast x = ucast x"
+  apply (cases \<open>LENGTH('a)\<close>)
+  apply simp
+  apply (rule bit_word_eqI)
+  apply (auto simp add: bit_signed_iff bit_unsigned_iff min_def msb_word_eq)
+  apply (erule notE)
+  apply (metis le_less_Suc_eq test_bit_bin test_bit_word_eq)
+  done
+
+lemma msb_ucast_eq:
+    "LENGTH('a) = LENGTH('b) \<Longrightarrow>
+         msb (ucast x :: ('a::len) word) = msb (x :: ('b::len) word)"
+  by (simp add: msb_word_eq bit_simps)
+
+lemma msb_big:
+     "msb (a :: ('a::len) word) = (a \<ge> 2 ^ (LENGTH('a)  - Suc 0))"
+  apply (rule iffI)
+   apply (clarsimp simp: msb_nth)
+   apply (drule bang_is_le)
+   apply simp
+  apply (rule ccontr)
+  apply (subgoal_tac "a = a AND mask (LENGTH('a) - Suc 0)")
+   apply (cut_tac and_mask_less' [where w=a and n="LENGTH('a) - Suc 0"])
+    apply (clarsimp simp: word_not_le [symmetric])
+   apply clarsimp
+  apply (rule sym, subst and_mask_eq_iff_shiftr_0)
+  apply (clarsimp simp: msb_shift)
+  done
+
 end
diff --git a/thys/Word_Lib/Reversed_Bit_Lists.thy b/thys/Word_Lib/Reversed_Bit_Lists.thy
--- a/thys/Word_Lib/Reversed_Bit_Lists.thy
+++ b/thys/Word_Lib/Reversed_Bit_Lists.thy
@@ -1,2188 +1,2188 @@
 (*  Author:     Jeremy Dawson, NICTA
 *)
 
 section \<open>Bit values as reversed lists of bools\<close>
 
 theory Reversed_Bit_Lists
   imports
     "HOL-Library.Word"
     Typedef_Morphisms
     Least_significant_bit
     Most_significant_bit
     Even_More_List
     "HOL-Library.Sublist"
     Aligned
 begin
 
 lemma horner_sum_of_bool_2_concat:
   \<open>horner_sum of_bool 2 (concat (map (\<lambda>x. map (bit x) [0..<LENGTH('a)]) ws)) = horner_sum uint (2 ^ LENGTH('a)) ws\<close>
   for ws :: \<open>'a::len word list\<close>
 proof (induction ws)
   case Nil
   then show ?case
     by simp
 next
   case (Cons w ws)
   moreover have \<open>horner_sum of_bool 2 (map (bit w) [0..<LENGTH('a)]) = uint w\<close>
   proof transfer
     fix k :: int
     have \<open>map (\<lambda>n. n < LENGTH('a) \<and> bit k n) [0..<LENGTH('a)]
       = map (bit k) [0..<LENGTH('a)]\<close>
       by simp
     then show \<open>horner_sum of_bool 2 (map (\<lambda>n. n < LENGTH('a) \<and> bit k n) [0..<LENGTH('a)])
       = take_bit LENGTH('a) k\<close>
       by (simp only: horner_sum_bit_eq_take_bit)
   qed
   ultimately show ?case
     by (simp add: horner_sum_append)
 qed
 
 
 subsection \<open>Implicit augmentation of list prefixes\<close>
 
 primrec takefill :: "'a \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
 where
     Z: "takefill fill 0 xs = []"
   | Suc: "takefill fill (Suc n) xs =
       (case xs of
         [] \<Rightarrow> fill # takefill fill n xs
       | y # ys \<Rightarrow> y # takefill fill n ys)"
 
 lemma nth_takefill: "m < n \<Longrightarrow> takefill fill n l ! m = (if m < length l then l ! m else fill)"
   apply (induct n arbitrary: m l)
    apply clarsimp
   apply clarsimp
   apply (case_tac m)
    apply (simp split: list.split)
   apply (simp split: list.split)
   done
 
 lemma takefill_alt: "takefill fill n l = take n l @ replicate (n - length l) fill"
   by (induct n arbitrary: l) (auto split: list.split)
 
 lemma takefill_replicate [simp]: "takefill fill n (replicate m fill) = replicate n fill"
   by (simp add: takefill_alt replicate_add [symmetric])
 
 lemma takefill_le': "n = m + k \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
   by (induct m arbitrary: l n) (auto split: list.split)
 
 lemma length_takefill [simp]: "length (takefill fill n l) = n"
   by (simp add: takefill_alt)
 
 lemma take_takefill': "n = k + m \<Longrightarrow> take k (takefill fill n w) = takefill fill k w"
   by (induct k arbitrary: w n) (auto split: list.split)
 
 lemma drop_takefill: "drop k (takefill fill (m + k) w) = takefill fill m (drop k w)"
   by (induct k arbitrary: w) (auto split: list.split)
 
 lemma takefill_le [simp]: "m \<le> n \<Longrightarrow> takefill x m (takefill x n l) = takefill x m l"
   by (auto simp: le_iff_add takefill_le')
 
 lemma take_takefill [simp]: "m \<le> n \<Longrightarrow> take m (takefill fill n w) = takefill fill m w"
   by (auto simp: le_iff_add take_takefill')
 
 lemma takefill_append: "takefill fill (m + length xs) (xs @ w) = xs @ (takefill fill m w)"
   by (induct xs) auto
 
 lemma takefill_same': "l = length xs \<Longrightarrow> takefill fill l xs = xs"
   by (induct xs arbitrary: l) auto
 
 lemmas takefill_same [simp] = takefill_same' [OF refl]
 
 lemma tf_rev:
   "n + k = m + length bl \<Longrightarrow> takefill x m (rev (takefill y n bl)) =
     rev (takefill y m (rev (takefill x k (rev bl))))"
   apply (rule nth_equalityI)
    apply (auto simp add: nth_takefill rev_nth)
   apply (rule_tac f = "\<lambda>n. bl ! n" in arg_cong)
   apply arith
   done
 
 lemma takefill_minus: "0 < n \<Longrightarrow> takefill fill (Suc (n - 1)) w = takefill fill n w"
   by auto
 
 lemmas takefill_Suc_cases =
   list.cases [THEN takefill.Suc [THEN trans]]
 
 lemmas takefill_Suc_Nil = takefill_Suc_cases (1)
 lemmas takefill_Suc_Cons = takefill_Suc_cases (2)
 
 lemmas takefill_minus_simps = takefill_Suc_cases [THEN [2]
   takefill_minus [symmetric, THEN trans]]
 
 lemma takefill_numeral_Nil [simp]:
   "takefill fill (numeral k) [] = fill # takefill fill (pred_numeral k) []"
   by (simp add: numeral_eq_Suc)
 
 lemma takefill_numeral_Cons [simp]:
   "takefill fill (numeral k) (x # xs) = x # takefill fill (pred_numeral k) xs"
   by (simp add: numeral_eq_Suc)
 
 
 subsection \<open>Range projection\<close>
 
 definition bl_of_nth :: "nat \<Rightarrow> (nat \<Rightarrow> 'a) \<Rightarrow> 'a list"
   where "bl_of_nth n f = map f (rev [0..<n])"
 
 lemma bl_of_nth_simps [simp, code]:
   "bl_of_nth 0 f = []"
   "bl_of_nth (Suc n) f = f n # bl_of_nth n f"
   by (simp_all add: bl_of_nth_def)
 
 lemma length_bl_of_nth [simp]: "length (bl_of_nth n f) = n"
   by (simp add: bl_of_nth_def)
 
 lemma nth_bl_of_nth [simp]: "m < n \<Longrightarrow> rev (bl_of_nth n f) ! m = f m"
   by (simp add: bl_of_nth_def rev_map)
 
 lemma bl_of_nth_inj: "(\<And>k. k < n \<Longrightarrow> f k = g k) \<Longrightarrow> bl_of_nth n f = bl_of_nth n g"
   by (simp add: bl_of_nth_def)
 
 lemma bl_of_nth_nth_le: "n \<le> length xs \<Longrightarrow> bl_of_nth n (nth (rev xs)) = drop (length xs - n) xs"
   apply (induct n arbitrary: xs)
    apply clarsimp
   apply clarsimp
   apply (rule trans [OF _ hd_Cons_tl])
    apply (frule Suc_le_lessD)
    apply (simp add: rev_nth trans [OF drop_Suc drop_tl, symmetric])
    apply (subst hd_drop_conv_nth)
     apply force
    apply simp_all
   apply (rule_tac f = "\<lambda>n. drop n xs" in arg_cong)
   apply simp
   done
 
 lemma bl_of_nth_nth [simp]: "bl_of_nth (length xs) ((!) (rev xs)) = xs"
   by (simp add: bl_of_nth_nth_le)
 
 
 subsection \<open>More\<close>
 
 definition rotater1 :: "'a list \<Rightarrow> 'a list"
   where "rotater1 ys =
     (case ys of [] \<Rightarrow> [] | x # xs \<Rightarrow> last ys # butlast ys)"
 
 definition rotater :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
   where "rotater n = rotater1 ^^ n"
 
 lemmas rotater_0' [simp] = rotater_def [where n = "0", simplified]
 
 lemma rotate1_rl': "rotater1 (l @ [a]) = a # l"
   by (cases l) (auto simp: rotater1_def)
 
 lemma rotate1_rl [simp] : "rotater1 (rotate1 l) = l"
   apply (unfold rotater1_def)
   apply (cases "l")
    apply (case_tac [2] "list")
     apply auto
   done
 
 lemma rotate1_lr [simp] : "rotate1 (rotater1 l) = l"
   by (cases l) (auto simp: rotater1_def)
 
 lemma rotater1_rev': "rotater1 (rev xs) = rev (rotate1 xs)"
   by (cases "xs") (simp add: rotater1_def, simp add: rotate1_rl')
 
 lemma rotater_rev': "rotater n (rev xs) = rev (rotate n xs)"
   by (induct n) (auto simp: rotater_def intro: rotater1_rev')
 
 lemma rotater_rev: "rotater n ys = rev (rotate n (rev ys))"
   using rotater_rev' [where xs = "rev ys"] by simp
 
 lemma rotater_drop_take:
   "rotater n xs =
     drop (length xs - n mod length xs) xs @
     take (length xs - n mod length xs) xs"
   by (auto simp: rotater_rev rotate_drop_take rev_take rev_drop)
 
 lemma rotater_Suc [simp]: "rotater (Suc n) xs = rotater1 (rotater n xs)"
   unfolding rotater_def by auto
 
 lemma nth_rotater:
   \<open>rotater m xs ! n = xs ! ((n + (length xs - m mod length xs)) mod length xs)\<close> if \<open>n < length xs\<close>
   using that by (simp add: rotater_drop_take nth_append not_less less_diff_conv ac_simps le_mod_geq)
 
 lemma nth_rotater1:
   \<open>rotater1 xs ! n = xs ! ((n + (length xs - 1)) mod length xs)\<close> if \<open>n < length xs\<close>
   using that nth_rotater [of n xs 1] by simp
 
 lemma rotate_inv_plus [rule_format]:
   "\<forall>k. k = m + n \<longrightarrow> rotater k (rotate n xs) = rotater m xs \<and>
     rotate k (rotater n xs) = rotate m xs \<and>
     rotater n (rotate k xs) = rotate m xs \<and>
     rotate n (rotater k xs) = rotater m xs"
   by (induct n) (auto simp: rotater_def rotate_def intro: funpow_swap1 [THEN trans])
 
 lemmas rotate_inv_rel = le_add_diff_inverse2 [symmetric, THEN rotate_inv_plus]
 
 lemmas rotate_inv_eq = order_refl [THEN rotate_inv_rel, simplified]
 
 lemmas rotate_lr [simp] = rotate_inv_eq [THEN conjunct1]
 lemmas rotate_rl [simp] = rotate_inv_eq [THEN conjunct2, THEN conjunct1]
 
 lemma rotate_gal: "rotater n xs = ys \<longleftrightarrow> rotate n ys = xs"
   by auto
 
 lemma rotate_gal': "ys = rotater n xs \<longleftrightarrow> xs = rotate n ys"
   by auto
 
 lemma length_rotater [simp]: "length (rotater n xs) = length xs"
   by (simp add : rotater_rev)
 
 lemma rotate_eq_mod: "m mod length xs = n mod length xs \<Longrightarrow> rotate m xs = rotate n xs"
   apply (rule box_equals)
     defer
     apply (rule rotate_conv_mod [symmetric])+
   apply simp
   done
 
 lemma restrict_to_left: "x = y \<Longrightarrow> x = z \<longleftrightarrow> y = z"
   by simp
 
 lemmas rotate_eqs =
   trans [OF rotate0 [THEN fun_cong] id_apply]
   rotate_rotate [symmetric]
   rotate_id
   rotate_conv_mod
   rotate_eq_mod
 
 lemmas rrs0 = rotate_eqs [THEN restrict_to_left,
   simplified rotate_gal [symmetric] rotate_gal' [symmetric]]
 lemmas rrs1 = rrs0 [THEN refl [THEN rev_iffD1]]
 lemmas rotater_eqs = rrs1 [simplified length_rotater]
 lemmas rotater_0 = rotater_eqs (1)
 lemmas rotater_add = rotater_eqs (2)
 
 lemma butlast_map: "xs \<noteq> [] \<Longrightarrow> butlast (map f xs) = map f (butlast xs)"
   by (induct xs) auto
 
 lemma rotater1_map: "rotater1 (map f xs) = map f (rotater1 xs)"
   by (cases xs) (auto simp: rotater1_def last_map butlast_map)
 
 lemma rotater_map: "rotater n (map f xs) = map f (rotater n xs)"
   by (induct n) (auto simp: rotater_def rotater1_map)
 
 lemma but_last_zip [rule_format] :
   "\<forall>ys. length xs = length ys \<longrightarrow> xs \<noteq> [] \<longrightarrow>
     last (zip xs ys) = (last xs, last ys) \<and>
     butlast (zip xs ys) = zip (butlast xs) (butlast ys)"
   apply (induct xs)
    apply auto
      apply ((case_tac ys, auto simp: neq_Nil_conv)[1])+
   done
 
 lemma but_last_map2 [rule_format] :
   "\<forall>ys. length xs = length ys \<longrightarrow> xs \<noteq> [] \<longrightarrow>
     last (map2 f xs ys) = f (last xs) (last ys) \<and>
     butlast (map2 f xs ys) = map2 f (butlast xs) (butlast ys)"
   apply (induct xs)
    apply auto
      apply ((case_tac ys, auto simp: neq_Nil_conv)[1])+
   done
 
 lemma rotater1_zip:
   "length xs = length ys \<Longrightarrow>
     rotater1 (zip xs ys) = zip (rotater1 xs) (rotater1 ys)"
   apply (unfold rotater1_def)
   apply (cases xs)
    apply auto
    apply ((case_tac ys, auto simp: neq_Nil_conv but_last_zip)[1])+
   done
 
 lemma rotater1_map2:
   "length xs = length ys \<Longrightarrow>
     rotater1 (map2 f xs ys) = map2 f (rotater1 xs) (rotater1 ys)"
   by (simp add: rotater1_map rotater1_zip)
 
 lemmas lrth =
   box_equals [OF asm_rl length_rotater [symmetric]
                  length_rotater [symmetric],
               THEN rotater1_map2]
 
 lemma rotater_map2:
   "length xs = length ys \<Longrightarrow>
     rotater n (map2 f xs ys) = map2 f (rotater n xs) (rotater n ys)"
   by (induct n) (auto intro!: lrth)
 
 lemma rotate1_map2:
   "length xs = length ys \<Longrightarrow>
     rotate1 (map2 f xs ys) = map2 f (rotate1 xs) (rotate1 ys)"
   by (cases xs; cases ys) auto
 
 lemmas lth = box_equals [OF asm_rl length_rotate [symmetric]
   length_rotate [symmetric], THEN rotate1_map2]
 
 lemma rotate_map2:
   "length xs = length ys \<Longrightarrow>
     rotate n (map2 f xs ys) = map2 f (rotate n xs) (rotate n ys)"
   by (induct n) (auto intro!: lth)
 
 
 subsection \<open>Explicit bit representation of \<^typ>\<open>int\<close>\<close>
 
 primrec bl_to_bin_aux :: "bool list \<Rightarrow> int \<Rightarrow> int"
   where
     Nil: "bl_to_bin_aux [] w = w"
   | Cons: "bl_to_bin_aux (b # bs) w = bl_to_bin_aux bs (of_bool b + 2 * w)"
 
 definition bl_to_bin :: "bool list \<Rightarrow> int"
   where "bl_to_bin bs = bl_to_bin_aux bs 0"
 
 primrec bin_to_bl_aux :: "nat \<Rightarrow> int \<Rightarrow> bool list \<Rightarrow> bool list"
   where
     Z: "bin_to_bl_aux 0 w bl = bl"
   | Suc: "bin_to_bl_aux (Suc n) w bl = bin_to_bl_aux n (bin_rest w) ((bin_last w) # bl)"
 
 definition bin_to_bl :: "nat \<Rightarrow> int \<Rightarrow> bool list"
   where "bin_to_bl n w = bin_to_bl_aux n w []"
 
 lemma bin_to_bl_aux_zero_minus_simp [simp]:
   "0 < n \<Longrightarrow> bin_to_bl_aux n 0 bl = bin_to_bl_aux (n - 1) 0 (False # bl)"
   by (cases n) auto
 
 lemma bin_to_bl_aux_minus1_minus_simp [simp]:
   "0 < n \<Longrightarrow> bin_to_bl_aux n (- 1) bl = bin_to_bl_aux (n - 1) (- 1) (True # bl)"
   by (cases n) auto
 
 lemma bin_to_bl_aux_one_minus_simp [simp]:
   "0 < n \<Longrightarrow> bin_to_bl_aux n 1 bl = bin_to_bl_aux (n - 1) 0 (True # bl)"
   by (cases n) auto
 
 lemma bin_to_bl_aux_Bit0_minus_simp [simp]:
   "0 < n \<Longrightarrow>
     bin_to_bl_aux n (numeral (Num.Bit0 w)) bl = bin_to_bl_aux (n - 1) (numeral w) (False # bl)"
   by (cases n) simp_all
 
 lemma bin_to_bl_aux_Bit1_minus_simp [simp]:
   "0 < n \<Longrightarrow>
     bin_to_bl_aux n (numeral (Num.Bit1 w)) bl = bin_to_bl_aux (n - 1) (numeral w) (True # bl)"
   by (cases n) simp_all
 
 lemma bl_to_bin_aux_append: "bl_to_bin_aux (bs @ cs) w = bl_to_bin_aux cs (bl_to_bin_aux bs w)"
   by (induct bs arbitrary: w) auto
 
 lemma bin_to_bl_aux_append: "bin_to_bl_aux n w bs @ cs = bin_to_bl_aux n w (bs @ cs)"
   by (induct n arbitrary: w bs) auto
 
 lemma bl_to_bin_append: "bl_to_bin (bs @ cs) = bl_to_bin_aux cs (bl_to_bin bs)"
   unfolding bl_to_bin_def by (rule bl_to_bin_aux_append)
 
 lemma bin_to_bl_aux_alt: "bin_to_bl_aux n w bs = bin_to_bl n w @ bs"
   by (simp add: bin_to_bl_def bin_to_bl_aux_append)
 
 lemma bin_to_bl_0 [simp]: "bin_to_bl 0 bs = []"
   by (auto simp: bin_to_bl_def)
 
 lemma size_bin_to_bl_aux: "length (bin_to_bl_aux n w bs) = n + length bs"
   by (induct n arbitrary: w bs) auto
 
 lemma size_bin_to_bl [simp]: "length (bin_to_bl n w) = n"
   by (simp add: bin_to_bl_def size_bin_to_bl_aux)
 
 lemma bl_bin_bl': "bin_to_bl (n + length bs) (bl_to_bin_aux bs w) = bin_to_bl_aux n w bs"
   apply (induct bs arbitrary: w n)
    apply auto
     apply (simp_all only: add_Suc [symmetric])
     apply (auto simp add: bin_to_bl_def)
   done
 
 lemma bl_bin_bl [simp]: "bin_to_bl (length bs) (bl_to_bin bs) = bs"
   unfolding bl_to_bin_def
   apply (rule box_equals)
     apply (rule bl_bin_bl')
    prefer 2
    apply (rule bin_to_bl_aux.Z)
   apply simp
   done
 
 lemma bl_to_bin_inj: "bl_to_bin bs = bl_to_bin cs \<Longrightarrow> length bs = length cs \<Longrightarrow> bs = cs"
   apply (rule_tac box_equals)
     defer
     apply (rule bl_bin_bl)
    apply (rule bl_bin_bl)
   apply simp
   done
 
 lemma bl_to_bin_False [simp]: "bl_to_bin (False # bl) = bl_to_bin bl"
   by (auto simp: bl_to_bin_def)
 
 lemma bl_to_bin_Nil [simp]: "bl_to_bin [] = 0"
   by (auto simp: bl_to_bin_def)
 
 lemma bin_to_bl_zero_aux: "bin_to_bl_aux n 0 bl = replicate n False @ bl"
   by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)
 
 lemma bin_to_bl_zero: "bin_to_bl n 0 = replicate n False"
   by (simp add: bin_to_bl_def bin_to_bl_zero_aux)
 
 lemma bin_to_bl_minus1_aux: "bin_to_bl_aux n (- 1) bl = replicate n True @ bl"
   by (induct n arbitrary: bl) (auto simp: replicate_app_Cons_same)
 
 lemma bin_to_bl_minus1: "bin_to_bl n (- 1) = replicate n True"
   by (simp add: bin_to_bl_def bin_to_bl_minus1_aux)
 
 
 subsection \<open>Semantic interpretation of \<^typ>\<open>bool list\<close> as \<^typ>\<open>int\<close>\<close>
 
 lemma bin_bl_bin': "bl_to_bin (bin_to_bl_aux n w bs) = bl_to_bin_aux bs (bintrunc n w)"
   by (induct n arbitrary: w bs) (auto simp: bl_to_bin_def take_bit_Suc ac_simps mod_2_eq_odd)
 
 lemma bin_bl_bin [simp]: "bl_to_bin (bin_to_bl n w) = bintrunc n w"
   by (auto simp: bin_to_bl_def bin_bl_bin')
 
 lemma bl_to_bin_rep_F: "bl_to_bin (replicate n False @ bl) = bl_to_bin bl"
   by (simp add: bin_to_bl_zero_aux [symmetric] bin_bl_bin') (simp add: bl_to_bin_def)
 
 lemma bin_to_bl_trunc [simp]: "n \<le> m \<Longrightarrow> bin_to_bl n (bintrunc m w) = bin_to_bl n w"
   by (auto intro: bl_to_bin_inj)
 
 lemma bin_to_bl_aux_bintr:
   "bin_to_bl_aux n (bintrunc m bin) bl =
     replicate (n - m) False @ bin_to_bl_aux (min n m) bin bl"
   apply (induct n arbitrary: m bin bl)
    apply clarsimp
   apply clarsimp
   apply (case_tac "m")
    apply (clarsimp simp: bin_to_bl_zero_aux)
    apply (erule thin_rl)
    apply (induct_tac n)
     apply (auto simp add: take_bit_Suc)
   done
 
 lemma bin_to_bl_bintr:
   "bin_to_bl n (bintrunc m bin) = replicate (n - m) False @ bin_to_bl (min n m) bin"
   unfolding bin_to_bl_def by (rule bin_to_bl_aux_bintr)
 
 lemma bl_to_bin_rep_False: "bl_to_bin (replicate n False) = 0"
   by (induct n) auto
 
 lemma len_bin_to_bl_aux: "length (bin_to_bl_aux n w bs) = n + length bs"
   by (fact size_bin_to_bl_aux)
 
 lemma len_bin_to_bl: "length (bin_to_bl n w) = n"
   by (fact size_bin_to_bl) (* FIXME: duplicate *)
 
 lemma sign_bl_bin': "bin_sign (bl_to_bin_aux bs w) = bin_sign w"
   by (induction bs arbitrary: w) (simp_all add: bin_sign_def)
 
 lemma sign_bl_bin: "bin_sign (bl_to_bin bs) = 0"
   by (simp add: bl_to_bin_def sign_bl_bin')
 
 lemma bl_sbin_sign_aux: "hd (bin_to_bl_aux (Suc n) w bs) = (bin_sign (sbintrunc n w) = -1)"
   by (induction n arbitrary: w bs) (auto simp add: bin_sign_def even_iff_mod_2_eq_zero bit_Suc)
 
 lemma bl_sbin_sign: "hd (bin_to_bl (Suc n) w) = (bin_sign (sbintrunc n w) = -1)"
   unfolding bin_to_bl_def by (rule bl_sbin_sign_aux)
 
 lemma bin_nth_of_bl_aux:
   "bin_nth (bl_to_bin_aux bl w) n =
     (n < size bl \<and> rev bl ! n \<or> n \<ge> length bl \<and> bin_nth w (n - size bl))"
   apply (induction bl arbitrary: w)
    apply simp_all
   apply safe
                       apply (simp_all add: not_le nth_append bit_double_iff even_bit_succ_iff split: if_splits)
   done
 
 lemma bin_nth_of_bl: "bin_nth (bl_to_bin bl) n = (n < length bl \<and> rev bl ! n)"
   by (simp add: bl_to_bin_def bin_nth_of_bl_aux)
 
 lemma bin_nth_bl: "n < m \<Longrightarrow> bin_nth w n = nth (rev (bin_to_bl m w)) n"
   apply (induct n arbitrary: m w)
    apply clarsimp
    apply (case_tac m, clarsimp)
    apply (clarsimp simp: bin_to_bl_def)
    apply (simp add: bin_to_bl_aux_alt)
   apply (case_tac m, clarsimp)
   apply (clarsimp simp: bin_to_bl_def)
   apply (simp add: bin_to_bl_aux_alt bit_Suc)
   done
 
 lemma nth_bin_to_bl_aux:
   "n < m + length bl \<Longrightarrow> (bin_to_bl_aux m w bl) ! n =
     (if n < m then bit w (m - 1 - n) else bl ! (n - m))"
   apply (induction bl arbitrary: w)
    apply simp_all
    apply (simp add: bin_nth_bl [of \<open>m - Suc n\<close> m] rev_nth flip: bin_to_bl_def)
    apply (metis One_nat_def Suc_pred add_diff_cancel_left'
      add_diff_cancel_right' bin_to_bl_aux_alt bin_to_bl_def
      diff_Suc_Suc diff_is_0_eq diff_zero less_Suc_eq_0_disj
      less_antisym less_imp_Suc_add list.size(3) nat_less_le nth_append size_bin_to_bl_aux)
   done
 
 lemma nth_bin_to_bl: "n < m \<Longrightarrow> (bin_to_bl m w) ! n = bin_nth w (m - Suc n)"
   by (simp add: bin_to_bl_def nth_bin_to_bl_aux)
 
 lemma takefill_bintrunc: "takefill False n bl = rev (bin_to_bl n (bl_to_bin (rev bl)))"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp: nth_takefill rev_nth nth_bin_to_bl bin_nth_of_bl)
   done
 
 lemma bl_bin_bl_rtf: "bin_to_bl n (bl_to_bin bl) = rev (takefill False n (rev bl))"
   by (simp add: takefill_bintrunc)
 
 lemma bl_to_bin_lt2p_aux: "bl_to_bin_aux bs w < (w + 1) * (2 ^ length bs)"
 proof (induction bs arbitrary: w)
   case Nil
   then show ?case
     by simp
 next
   case (Cons b bs)
   from Cons.IH [of \<open>1 + 2 * w\<close>] Cons.IH [of \<open>2 * w\<close>]
   show ?case
     apply (auto simp add: algebra_simps)
     apply (subst mult_2 [of \<open>2 ^ length bs\<close>])
     apply (simp only: add.assoc)
     apply (rule pos_add_strict)
      apply simp_all
     done
 qed
 
 lemma bl_to_bin_lt2p_drop: "bl_to_bin bs < 2 ^ length (dropWhile Not bs)"
 proof (induct bs)
   case Nil
   then show ?case by simp
 next
   case (Cons b bs)
   with bl_to_bin_lt2p_aux[where w=1] show ?case
     by (simp add: bl_to_bin_def)
 qed
 
 lemma bl_to_bin_lt2p: "bl_to_bin bs < 2 ^ length bs"
   by (metis bin_bl_bin bintr_lt2p bl_bin_bl)
 
 lemma bl_to_bin_ge2p_aux: "bl_to_bin_aux bs w \<ge> w * (2 ^ length bs)"
 proof (induction bs arbitrary: w)
   case Nil
   then show ?case
     by simp
 next
   case (Cons b bs)
   from Cons.IH [of \<open>1 + 2 * w\<close>] Cons.IH [of \<open>2 * w\<close>]
   show ?case
     apply (auto simp add: algebra_simps)
     apply (rule add_le_imp_le_left [of \<open>2 ^ length bs\<close>])
     apply (rule add_increasing)
     apply simp_all
     done
 qed
 
 lemma bl_to_bin_ge0: "bl_to_bin bs \<ge> 0"
   apply (unfold bl_to_bin_def)
   apply (rule xtrans(4))
    apply (rule bl_to_bin_ge2p_aux)
   apply simp
   done
 
 lemma butlast_rest_bin: "butlast (bin_to_bl n w) = bin_to_bl (n - 1) (bin_rest w)"
   apply (unfold bin_to_bl_def)
   apply (cases n, clarsimp)
   apply clarsimp
   apply (auto simp add: bin_to_bl_aux_alt)
   done
 
 lemma butlast_bin_rest: "butlast bl = bin_to_bl (length bl - Suc 0) (bin_rest (bl_to_bin bl))"
   using butlast_rest_bin [where w="bl_to_bin bl" and n="length bl"] by simp
 
 lemma butlast_rest_bl2bin_aux:
   "bl \<noteq> [] \<Longrightarrow> bl_to_bin_aux (butlast bl) w = bin_rest (bl_to_bin_aux bl w)"
   by (induct bl arbitrary: w) auto
 
 lemma butlast_rest_bl2bin: "bl_to_bin (butlast bl) = bin_rest (bl_to_bin bl)"
   by (cases bl) (auto simp: bl_to_bin_def butlast_rest_bl2bin_aux)
 
 lemma trunc_bl2bin_aux:
   "bintrunc m (bl_to_bin_aux bl w) =
     bl_to_bin_aux (drop (length bl - m) bl) (bintrunc (m - length bl) w)"
 proof (induct bl arbitrary: w)
   case Nil
   show ?case by simp
 next
   case (Cons b bl)
   show ?case
   proof (cases "m - length bl")
     case 0
     then have "Suc (length bl) - m = Suc (length bl - m)" by simp
     with Cons show ?thesis by simp
   next
     case (Suc n)
     then have "m - Suc (length bl) = n" by simp
     with Cons Suc show ?thesis by (simp add: take_bit_Suc ac_simps)
   qed
 qed
 
 lemma trunc_bl2bin: "bintrunc m (bl_to_bin bl) = bl_to_bin (drop (length bl - m) bl)"
   by (simp add: bl_to_bin_def trunc_bl2bin_aux)
 
 lemma trunc_bl2bin_len [simp]: "bintrunc (length bl) (bl_to_bin bl) = bl_to_bin bl"
   by (simp add: trunc_bl2bin)
 
 lemma bl2bin_drop: "bl_to_bin (drop k bl) = bintrunc (length bl - k) (bl_to_bin bl)"
   apply (rule trans)
    prefer 2
    apply (rule trunc_bl2bin [symmetric])
   apply (cases "k \<le> length bl")
    apply auto
   done
 
 lemma take_rest_power_bin: "m \<le> n \<Longrightarrow> take m (bin_to_bl n w) = bin_to_bl m ((bin_rest ^^ (n - m)) w)"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp add: nth_bin_to_bl nth_rest_power_bin)
   done
 
 lemma last_bin_last': "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> bin_last (bl_to_bin_aux xs w)"
   by (induct xs arbitrary: w) auto
 
 lemma last_bin_last: "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> bin_last (bl_to_bin xs)"
   unfolding bl_to_bin_def by (erule last_bin_last')
 
 lemma bin_last_last: "bin_last w \<longleftrightarrow> last (bin_to_bl (Suc n) w)"
   by (simp add: bin_to_bl_def) (auto simp: bin_to_bl_aux_alt)
 
 lemma drop_bin2bl_aux:
   "drop m (bin_to_bl_aux n bin bs) =
     bin_to_bl_aux (n - m) bin (drop (m - n) bs)"
   apply (induction n arbitrary: m bin bs)
    apply auto
   apply (case_tac "m \<le> n")
    apply (auto simp add: not_le Suc_diff_le)
   apply (case_tac "m - n")
    apply auto
   apply (use Suc_diff_Suc in fastforce)
   done
 
 lemma drop_bin2bl: "drop m (bin_to_bl n bin) = bin_to_bl (n - m) bin"
   by (simp add: bin_to_bl_def drop_bin2bl_aux)
 
 lemma take_bin2bl_lem1: "take m (bin_to_bl_aux m w bs) = bin_to_bl m w"
   apply (induct m arbitrary: w bs)
    apply clarsimp
   apply clarsimp
   apply (simp add: bin_to_bl_aux_alt)
   apply (simp add: bin_to_bl_def)
   apply (simp add: bin_to_bl_aux_alt)
   done
 
 lemma take_bin2bl_lem: "take m (bin_to_bl_aux (m + n) w bs) = take m (bin_to_bl (m + n) w)"
   by (induct n arbitrary: w bs) (simp_all (no_asm) add: bin_to_bl_def take_bin2bl_lem1, simp)
 
 lemma bin_split_take: "bin_split n c = (a, b) \<Longrightarrow> bin_to_bl m a = take m (bin_to_bl (m + n) c)"
   apply (induct n arbitrary: b c)
    apply clarsimp
   apply (clarsimp simp: Let_def split: prod.split_asm)
   apply (simp add: bin_to_bl_def)
   apply (simp add: take_bin2bl_lem drop_bit_Suc)
   done
 
 lemma bin_to_bl_drop_bit:
   "k = m + n \<Longrightarrow> bin_to_bl m (drop_bit n c) = take m (bin_to_bl k c)"
   using bin_split_take by simp
 
 lemma bin_split_take1:
   "k = m + n \<Longrightarrow> bin_split n c = (a, b) \<Longrightarrow> bin_to_bl m a = take m (bin_to_bl k c)"
   using bin_split_take by simp
 
 lemma bl_bin_bl_rep_drop:
   "bin_to_bl n (bl_to_bin bl) =
     replicate (n - length bl) False @ drop (length bl - n) bl"
   by (simp add: bl_to_bin_inj bl_to_bin_rep_F trunc_bl2bin)
 
 lemma bl_to_bin_aux_cat:
   "bl_to_bin_aux bs (bin_cat w nv v) =
     bin_cat w (nv + length bs) (bl_to_bin_aux bs v)"
   by (rule bit_eqI)
     (auto simp add: bin_nth_of_bl_aux bin_nth_cat algebra_simps)
 
 lemma bin_to_bl_aux_cat:
   "bin_to_bl_aux (nv + nw) (bin_cat v nw w) bs =
     bin_to_bl_aux nv v (bin_to_bl_aux nw w bs)"
   by (induction nw arbitrary: w bs) (simp_all add: concat_bit_Suc)
 
 lemma bl_to_bin_aux_alt: "bl_to_bin_aux bs w = bin_cat w (length bs) (bl_to_bin bs)"
   using bl_to_bin_aux_cat [where nv = "0" and v = "0"]
   by (simp add: bl_to_bin_def [symmetric])
 
 lemma bin_to_bl_cat:
   "bin_to_bl (nv + nw) (bin_cat v nw w) =
     bin_to_bl_aux nv v (bin_to_bl nw w)"
   by (simp add: bin_to_bl_def bin_to_bl_aux_cat)
 
 lemmas bl_to_bin_aux_app_cat =
   trans [OF bl_to_bin_aux_append bl_to_bin_aux_alt]
 
 lemmas bin_to_bl_aux_cat_app =
   trans [OF bin_to_bl_aux_cat bin_to_bl_aux_alt]
 
 lemma bl_to_bin_app_cat:
   "bl_to_bin (bsa @ bs) = bin_cat (bl_to_bin bsa) (length bs) (bl_to_bin bs)"
   by (simp only: bl_to_bin_aux_app_cat bl_to_bin_def)
 
 lemma bin_to_bl_cat_app:
   "bin_to_bl (n + nw) (bin_cat w nw wa) = bin_to_bl n w @ bin_to_bl nw wa"
   by (simp only: bin_to_bl_def bin_to_bl_aux_cat_app)
 
 text \<open>\<open>bl_to_bin_app_cat_alt\<close> and \<open>bl_to_bin_app_cat\<close> are easily interderivable.\<close>
 lemma bl_to_bin_app_cat_alt: "bin_cat (bl_to_bin cs) n w = bl_to_bin (cs @ bin_to_bl n w)"
   by (simp add: bl_to_bin_app_cat)
 
 lemma mask_lem: "(bl_to_bin (True # replicate n False)) = bl_to_bin (replicate n True) + 1"
   apply (unfold bl_to_bin_def)
   apply (induct n)
    apply simp
   apply (simp only: Suc_eq_plus1 replicate_add append_Cons [symmetric] bl_to_bin_aux_append)
   apply simp
   done
 
 lemma bin_exhaust:
   "(\<And>x b. bin = of_bool b + 2 * x \<Longrightarrow> Q) \<Longrightarrow> Q" for bin :: int
   apply (cases \<open>even bin\<close>)
    apply (auto elim!: evenE oddE)
    apply fastforce
   apply fastforce
   done
 
 primrec rbl_succ :: "bool list \<Rightarrow> bool list"
   where
     Nil: "rbl_succ Nil = Nil"
   | Cons: "rbl_succ (x # xs) = (if x then False # rbl_succ xs else True # xs)"
 
 primrec rbl_pred :: "bool list \<Rightarrow> bool list"
   where
     Nil: "rbl_pred Nil = Nil"
   | Cons: "rbl_pred (x # xs) = (if x then False # xs else True # rbl_pred xs)"
 
 primrec rbl_add :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
   where \<comment> \<open>result is length of first arg, second arg may be longer\<close>
     Nil: "rbl_add Nil x = Nil"
   | Cons: "rbl_add (y # ys) x =
       (let ws = rbl_add ys (tl x)
        in (y \<noteq> hd x) # (if hd x \<and> y then rbl_succ ws else ws))"
 
 primrec rbl_mult :: "bool list \<Rightarrow> bool list \<Rightarrow> bool list"
   where \<comment> \<open>result is length of first arg, second arg may be longer\<close>
     Nil: "rbl_mult Nil x = Nil"
   | Cons: "rbl_mult (y # ys) x =
       (let ws = False # rbl_mult ys x
        in if y then rbl_add ws x else ws)"
 
 lemma size_rbl_pred: "length (rbl_pred bl) = length bl"
   by (induct bl) auto
 
 lemma size_rbl_succ: "length (rbl_succ bl) = length bl"
   by (induct bl) auto
 
 lemma size_rbl_add: "length (rbl_add bl cl) = length bl"
   by (induct bl arbitrary: cl) (auto simp: Let_def size_rbl_succ)
 
 lemma size_rbl_mult: "length (rbl_mult bl cl) = length bl"
   by (induct bl arbitrary: cl) (auto simp add: Let_def size_rbl_add)
 
 lemmas rbl_sizes [simp] =
   size_rbl_pred size_rbl_succ size_rbl_add size_rbl_mult
 
 lemmas rbl_Nils =
   rbl_pred.Nil rbl_succ.Nil rbl_add.Nil rbl_mult.Nil
 
 lemma rbl_add_app2: "length blb \<ge> length bla \<Longrightarrow> rbl_add bla (blb @ blc) = rbl_add bla blb"
   apply (induct bla arbitrary: blb)
    apply simp
   apply clarsimp
   apply (case_tac blb, clarsimp)
   apply (clarsimp simp: Let_def)
   done
 
 lemma rbl_add_take2:
   "length blb \<ge> length bla \<Longrightarrow> rbl_add bla (take (length bla) blb) = rbl_add bla blb"
   apply (induct bla arbitrary: blb)
    apply simp
   apply clarsimp
   apply (case_tac blb, clarsimp)
   apply (clarsimp simp: Let_def)
   done
 
 lemma rbl_mult_app2: "length blb \<ge> length bla \<Longrightarrow> rbl_mult bla (blb @ blc) = rbl_mult bla blb"
   apply (induct bla arbitrary: blb)
    apply simp
   apply clarsimp
   apply (case_tac blb, clarsimp)
   apply (clarsimp simp: Let_def rbl_add_app2)
   done
 
 lemma rbl_mult_take2:
   "length blb \<ge> length bla \<Longrightarrow> rbl_mult bla (take (length bla) blb) = rbl_mult bla blb"
   apply (rule trans)
    apply (rule rbl_mult_app2 [symmetric])
    apply simp
   apply (rule_tac f = "rbl_mult bla" in arg_cong)
   apply (rule append_take_drop_id)
   done
 
 lemma rbl_add_split:
   "P (rbl_add (y # ys) (x # xs)) =
     (\<forall>ws. length ws = length ys \<longrightarrow> ws = rbl_add ys xs \<longrightarrow>
       (y \<longrightarrow> ((x \<longrightarrow> P (False # rbl_succ ws)) \<and> (\<not> x \<longrightarrow> P (True # ws)))) \<and>
       (\<not> y \<longrightarrow> P (x # ws)))"
   by (cases y) (auto simp: Let_def)
 
 lemma rbl_mult_split:
   "P (rbl_mult (y # ys) xs) =
     (\<forall>ws. length ws = Suc (length ys) \<longrightarrow> ws = False # rbl_mult ys xs \<longrightarrow>
       (y \<longrightarrow> P (rbl_add ws xs)) \<and> (\<not> y \<longrightarrow> P ws))"
   by (auto simp: Let_def)
 
 lemma rbl_pred: "rbl_pred (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin - 1))"
 proof (unfold bin_to_bl_def, induction n arbitrary: bin)
   case 0
   then show ?case
     by simp
 next
   case (Suc n)
   obtain b k where \<open>bin = of_bool b + 2 * k\<close>
     using bin_exhaust by blast
   moreover have \<open>(2 * k - 1) div 2 = k - 1\<close>
     using even_succ_div_2 [of \<open>2 * (k - 1)\<close>] 
     by simp
   ultimately show ?case
     using Suc [of \<open>bin div 2\<close>]
     by simp (simp add: bin_to_bl_aux_alt)
 qed
 
 lemma rbl_succ: "rbl_succ (rev (bin_to_bl n bin)) = rev (bin_to_bl n (bin + 1))"
   apply (unfold bin_to_bl_def)
   apply (induction n arbitrary: bin)
    apply simp_all
   apply (case_tac bin rule: bin_exhaust)
   apply simp
   apply (simp add: bin_to_bl_aux_alt ac_simps)
   done
 
 lemma rbl_add:
   "\<And>bina binb. rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
     rev (bin_to_bl n (bina + binb))"
   apply (unfold bin_to_bl_def)
   apply (induct n)
    apply simp
   apply clarsimp
   apply (case_tac bina rule: bin_exhaust)
   apply (case_tac binb rule: bin_exhaust)
   apply (case_tac b)
    apply (case_tac [!] "ba")
      apply (auto simp: rbl_succ bin_to_bl_aux_alt Let_def ac_simps)
   done
 
 lemma rbl_add_long:
   "m \<ge> n \<Longrightarrow> rbl_add (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
     rev (bin_to_bl n (bina + binb))"
   apply (rule box_equals [OF _ rbl_add_take2 rbl_add])
    apply (rule_tac f = "rbl_add (rev (bin_to_bl n bina))" in arg_cong)
    apply (rule rev_swap [THEN iffD1])
    apply (simp add: rev_take drop_bin2bl)
   apply simp
   done
 
 lemma rbl_mult_gt1:
   "m \<ge> length bl \<Longrightarrow>
     rbl_mult bl (rev (bin_to_bl m binb)) =
     rbl_mult bl (rev (bin_to_bl (length bl) binb))"
   apply (rule trans)
    apply (rule rbl_mult_take2 [symmetric])
    apply simp_all
   apply (rule_tac f = "rbl_mult bl" in arg_cong)
   apply (rule rev_swap [THEN iffD1])
   apply (simp add: rev_take drop_bin2bl)
   done
 
 lemma rbl_mult_gt:
   "m > n \<Longrightarrow>
     rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl m binb)) =
     rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb))"
   by (auto intro: trans [OF rbl_mult_gt1])
 
 lemmas rbl_mult_Suc = lessI [THEN rbl_mult_gt]
 
 lemma rbbl_Cons: "b # rev (bin_to_bl n x) = rev (bin_to_bl (Suc n) (of_bool b + 2 * x))"
   by (simp add: bin_to_bl_def) (simp add: bin_to_bl_aux_alt)
 
 lemma rbl_mult:
   "rbl_mult (rev (bin_to_bl n bina)) (rev (bin_to_bl n binb)) =
     rev (bin_to_bl n (bina * binb))"
   apply (induct n arbitrary: bina binb)
    apply simp_all
   apply (unfold bin_to_bl_def)
   apply clarsimp
   apply (case_tac bina rule: bin_exhaust)
   apply (case_tac binb rule: bin_exhaust)
   apply simp
   apply (simp add: bin_to_bl_aux_alt)
   apply (simp add: rbbl_Cons rbl_mult_Suc rbl_add algebra_simps)
   done
 
 lemma sclem: "size (concat (map (bin_to_bl n) xs)) = length xs * n"
   by (induct xs) auto
 
 lemma bin_cat_foldl_lem:
   "foldl (\<lambda>u. bin_cat u n) x xs =
     bin_cat x (size xs * n) (foldl (\<lambda>u. bin_cat u n) y xs)"
   apply (induct xs arbitrary: x)
    apply simp
   apply (simp (no_asm))
   apply (frule asm_rl)
   apply (drule meta_spec)
   apply (erule trans)
   apply (drule_tac x = "bin_cat y n a" in meta_spec)
   apply (simp add: bin_cat_assoc_sym min.absorb2)
   done
 
 lemma bin_rcat_bl: "bin_rcat n wl = bl_to_bin (concat (map (bin_to_bl n) wl))"
   apply (unfold bin_rcat_eq_foldl)
   apply (rule sym)
   apply (induct wl)
    apply (auto simp add: bl_to_bin_append)
   apply (simp add: bl_to_bin_aux_alt sclem)
   apply (simp add: bin_cat_foldl_lem [symmetric])
   done
 
 lemma bin_last_bl_to_bin: "bin_last (bl_to_bin bs) \<longleftrightarrow> bs \<noteq> [] \<and> last bs"
 by(cases "bs = []")(auto simp add: bl_to_bin_def last_bin_last'[where w=0])
 
 lemma bin_rest_bl_to_bin: "bin_rest (bl_to_bin bs) = bl_to_bin (butlast bs)"
 by(cases "bs = []")(simp_all add: bl_to_bin_def butlast_rest_bl2bin_aux)
 
 lemma bl_xor_aux_bin:
   "map2 (\<lambda>x y. x \<noteq> y) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v XOR w) (map2 (\<lambda>x y. x \<noteq> y) bs cs)"
   apply (induction n arbitrary: v w bs cs)
    apply auto
   apply (case_tac v rule: bin_exhaust)
   apply (case_tac w rule: bin_exhaust)
   apply clarsimp
   done
 
 lemma bl_or_aux_bin:
   "map2 (\<or>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v OR w) (map2 (\<or>) bs cs)"
   by (induct n arbitrary: v w bs cs) simp_all
 
 lemma bl_and_aux_bin:
   "map2 (\<and>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v AND w) (map2 (\<and>) bs cs)"
   by (induction n arbitrary: v w bs cs) simp_all
 
 lemma bl_not_aux_bin: "map Not (bin_to_bl_aux n w cs) = bin_to_bl_aux n (NOT w) (map Not cs)"
   by (induct n arbitrary: w cs) auto
 
 lemma bl_not_bin: "map Not (bin_to_bl n w) = bin_to_bl n (NOT w)"
   by (simp add: bin_to_bl_def bl_not_aux_bin)
 
 lemma bl_and_bin: "map2 (\<and>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v AND w)"
   by (simp add: bin_to_bl_def bl_and_aux_bin)
 
 lemma bl_or_bin: "map2 (\<or>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v OR w)"
   by (simp add: bin_to_bl_def bl_or_aux_bin)
 
 lemma bl_xor_bin: "map2 (\<noteq>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v XOR w)"
   using bl_xor_aux_bin by (simp add: bin_to_bl_def)
 
 
 subsection \<open>Type \<^typ>\<open>'a word\<close>\<close>
 
 lift_definition of_bl :: \<open>bool list \<Rightarrow> 'a::len word\<close>
   is bl_to_bin .
 
 lift_definition to_bl :: \<open>'a::len word \<Rightarrow> bool list\<close>
   is \<open>bin_to_bl LENGTH('a)\<close>
   by (simp add: bl_to_bin_inj)
 
 lemma to_bl_eq:
   \<open>to_bl w = bin_to_bl (LENGTH('a)) (uint w)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma bit_of_bl_iff [bit_simps]:
   \<open>bit (of_bl bs :: 'a word) n \<longleftrightarrow> rev bs ! n \<and> n < LENGTH('a::len) \<and> n < length bs\<close>
   by transfer (simp add: bin_nth_of_bl ac_simps)
 
 lemma rev_to_bl_eq:
   \<open>rev (to_bl w) = map (bit w) [0..<LENGTH('a)]\<close>
   for w :: \<open>'a::len word\<close>
   apply (rule nth_equalityI)
    apply (simp add: to_bl.rep_eq)
   apply (simp add: bin_nth_bl bit_word.rep_eq to_bl.rep_eq)
   done
 
 lemma to_bl_eq_rev:
   \<open>to_bl w = map (bit w) (rev [0..<LENGTH('a)])\<close>
   for w :: \<open>'a::len word\<close>
   using rev_to_bl_eq [of w]
   apply (subst rev_is_rev_conv [symmetric])
   apply (simp add: rev_map)
   done
 
 lemma of_bl_rev_eq:
   \<open>of_bl (rev bs) = horner_sum of_bool 2 bs\<close>
   apply (rule bit_word_eqI)
   apply (simp add: bit_of_bl_iff)
   apply transfer
   apply (simp add: bit_horner_sum_bit_iff ac_simps)
   done
 
 lemma of_bl_eq:
   \<open>of_bl bs = horner_sum of_bool 2 (rev bs)\<close>
   using of_bl_rev_eq [of \<open>rev bs\<close>] by simp
 
 lemma bshiftr1_eq:
   \<open>bshiftr1 b w = of_bl (b # butlast (to_bl w))\<close>
   apply transfer
   apply auto
    apply (subst bl_to_bin_app_cat [of \<open>[True]\<close>, simplified])
    apply simp
    apply (metis One_nat_def add.commute bin_bl_bin bin_last_bl_to_bin bin_rest_bl_to_bin butlast_bin_rest concat_bit_eq last.simps list.distinct(1) list.size(3) list.size(4) odd_iff_mod_2_eq_one plus_1_eq_Suc power_Suc0_right push_bit_of_1 size_bin_to_bl take_bit_eq_mod trunc_bl2bin_len)
   apply (simp add: butlast_rest_bl2bin)
   done
 
 lemma length_to_bl_eq:
   \<open>length (to_bl w) = LENGTH('a)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma word_rotr_eq:
   \<open>word_rotr n w = of_bl (rotater n (to_bl w))\<close>
   apply (rule bit_word_eqI)
   subgoal for n
     apply (cases \<open>n < LENGTH('a)\<close>)
      apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff rotater_rev length_to_bl_eq nth_rotate rev_to_bl_eq ac_simps)
     done
   done
 
 lemma word_rotl_eq:
   \<open>word_rotl n w = of_bl (rotate n (to_bl w))\<close>
 proof -
   have \<open>rotate n (to_bl w) = rev (rotater n (rev (to_bl w)))\<close>
     by (simp add: rotater_rev')
   then show ?thesis
     apply (simp add: word_rotl_eq_word_rotr bit_of_bl_iff length_to_bl_eq rev_to_bl_eq)
     apply (rule bit_word_eqI)
     subgoal for n
       apply (cases \<open>n < LENGTH('a)\<close>)
        apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff nth_rotater)
       done
     done
 qed
 
 lemma to_bl_def': "(to_bl :: 'a::len word \<Rightarrow> bool list) = bin_to_bl (LENGTH('a)) \<circ> uint"
   by transfer (simp add: fun_eq_iff)
 
 \<comment> \<open>type definitions theorem for in terms of equivalent bool list\<close>
 lemma td_bl:
   "type_definition
     (to_bl :: 'a::len word \<Rightarrow> bool list)
     of_bl
     {bl. length bl = LENGTH('a)}"
   apply (standard; transfer)
   apply (auto dest: sym)
   done
 
 interpretation word_bl:
   type_definition
     "to_bl :: 'a::len word \<Rightarrow> bool list"
     of_bl
     "{bl. length bl = LENGTH('a::len)}"
   by (fact td_bl)
 
 lemmas word_bl_Rep' = word_bl.Rep [unfolded mem_Collect_eq, iff]
 
 lemma word_size_bl: "size w = size (to_bl w)"
   by (auto simp: word_size)
 
 lemma to_bl_use_of_bl: "to_bl w = bl \<longleftrightarrow> w = of_bl bl \<and> length bl = length (to_bl w)"
   by (fastforce elim!: word_bl.Abs_inverse [unfolded mem_Collect_eq])
 
 lemma length_bl_gt_0 [iff]: "0 < length (to_bl x)"
   for x :: "'a::len word"
   unfolding word_bl_Rep' by (rule len_gt_0)
 
 lemma bl_not_Nil [iff]: "to_bl x \<noteq> []"
   for x :: "'a::len word"
   by (fact length_bl_gt_0 [unfolded length_greater_0_conv])
 
 lemma length_bl_neq_0 [iff]: "length (to_bl x) \<noteq> 0"
   for x :: "'a::len word"
   by (fact length_bl_gt_0 [THEN gr_implies_not0])
 
 lemma hd_bl_sign_sint: "hd (to_bl w) = (bin_sign (sint w) = -1)"
   apply transfer
   apply (auto simp add: bin_sign_def)
   using bin_sign_lem bl_sbin_sign apply fastforce
   using bin_sign_lem bl_sbin_sign apply force
   done
 
 lemma of_bl_drop':
   "lend = length bl - LENGTH('a::len) \<Longrightarrow>
     of_bl (drop lend bl) = (of_bl bl :: 'a word)"
   by transfer (simp flip: trunc_bl2bin)
 
 lemma test_bit_of_bl:
   "(of_bl bl::'a::len word) !! n = (rev bl ! n \<and> n < LENGTH('a) \<and> n < length bl)"
   by transfer (simp add: bin_nth_of_bl ac_simps)
 
 lemma no_of_bl: "(numeral bin ::'a::len word) = of_bl (bin_to_bl (LENGTH('a)) (numeral bin))"
   by transfer simp
 
 lemma uint_bl: "to_bl w = bin_to_bl (size w) (uint w)"
   by transfer simp
 
 lemma to_bl_bin: "bl_to_bin (to_bl w) = uint w"
   by (simp add: uint_bl word_size)
 
 lemma to_bl_of_bin: "to_bl (word_of_int bin::'a::len word) = bin_to_bl (LENGTH('a)) bin"
   by (auto simp: uint_bl word_ubin.eq_norm word_size)
 
 lemma to_bl_numeral [simp]:
   "to_bl (numeral bin::'a::len word) =
     bin_to_bl (LENGTH('a)) (numeral bin)"
   unfolding word_numeral_alt by (rule to_bl_of_bin)
 
 lemma to_bl_neg_numeral [simp]:
   "to_bl (- numeral bin::'a::len word) =
     bin_to_bl (LENGTH('a)) (- numeral bin)"
   unfolding word_neg_numeral_alt by (rule to_bl_of_bin)
 
 lemma to_bl_to_bin [simp] : "bl_to_bin (to_bl w) = uint w"
   by (simp add: uint_bl word_size)
 
 lemma uint_bl_bin: "bl_to_bin (bin_to_bl (LENGTH('a)) (uint x)) = uint x"
   for x :: "'a::len word"
   by (rule trans [OF bin_bl_bin word_ubin.norm_Rep])
 
 lemma ucast_bl: "ucast w = of_bl (to_bl w)"
   by transfer simp
 
 lemma ucast_down_bl:
   \<open>(ucast :: 'a::len word \<Rightarrow> 'b::len word) (of_bl bl) = of_bl bl\<close>
     if \<open>is_down (ucast :: 'a::len word \<Rightarrow> 'b::len word)\<close>
   using that by transfer simp
 
 lemma of_bl_append_same: "of_bl (X @ to_bl w) = w"
   by transfer (simp add: bl_to_bin_app_cat) 
 
 lemma ucast_of_bl_up:
   \<open>ucast (of_bl bl :: 'a::len word) = of_bl bl\<close>
   if \<open>size bl \<le> size (of_bl bl :: 'a::len word)\<close>
   using that
   apply transfer
   apply (rule bit_eqI)
   apply (auto simp add: bit_take_bit_iff)
   apply (subst (asm) trunc_bl2bin_len [symmetric])
   apply (auto simp only: bit_take_bit_iff)
   done
 
 lemma word_rev_tf:
   "to_bl (of_bl bl::'a::len word) =
     rev (takefill False (LENGTH('a)) (rev bl))"
   by transfer (simp add: bl_bin_bl_rtf)
 
 lemma word_rep_drop:
   "to_bl (of_bl bl::'a::len word) =
     replicate (LENGTH('a) - length bl) False @
     drop (length bl - LENGTH('a)) bl"
   by (simp add: word_rev_tf takefill_alt rev_take)
 
 lemma to_bl_ucast:
   "to_bl (ucast (w::'b::len word) ::'a::len word) =
     replicate (LENGTH('a) - LENGTH('b)) False @
     drop (LENGTH('b) - LENGTH('a)) (to_bl w)"
   apply (unfold ucast_bl)
   apply (rule trans)
    apply (rule word_rep_drop)
   apply simp
   done
 
 lemma ucast_up_app:
   \<open>to_bl (ucast w :: 'b::len word) = replicate n False @ (to_bl w)\<close>
     if \<open>source_size (ucast :: 'a word \<Rightarrow> 'b word) + n = target_size (ucast :: 'a word \<Rightarrow> 'b word)\<close>
     for w :: \<open>'a::len word\<close>
   using that
   by (auto simp add : source_size target_size to_bl_ucast)
 
 lemma ucast_down_drop [OF refl]:
   "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow>
     to_bl (uc w) = drop n (to_bl w)"
   by (auto simp add : source_size target_size to_bl_ucast)
 
 lemma scast_down_drop [OF refl]:
   "sc = scast \<Longrightarrow> source_size sc = target_size sc + n \<Longrightarrow>
     to_bl (sc w) = drop n (to_bl w)"
   apply (subgoal_tac "sc = ucast")
    apply safe
    apply simp
    apply (erule ucast_down_drop)
   apply (rule down_cast_same [symmetric])
   apply (simp add : source_size target_size is_down)
   done
 
 lemma word_0_bl [simp]: "of_bl [] = 0"
   by transfer simp
 
 lemma word_1_bl: "of_bl [True] = 1"
   by transfer (simp add: bl_to_bin_def)
 
 lemma of_bl_0 [simp]: "of_bl (replicate n False) = 0"
   by transfer (simp add: bl_to_bin_rep_False)
 
 lemma to_bl_0 [simp]: "to_bl (0::'a::len word) = replicate (LENGTH('a)) False"
   by (simp add: uint_bl word_size bin_to_bl_zero)
 
 \<comment> \<open>links with \<open>rbl\<close> operations\<close>
 lemma word_succ_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_succ w) = rev (rbl_succ (rev bl))"
   by transfer (simp add: rbl_succ)
 
 lemma word_pred_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_pred w) = rev (rbl_pred (rev bl))"
   by transfer (simp add: rbl_pred)
 
 lemma word_add_rbl:
   "to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
     to_bl (v + w) = rev (rbl_add (rev vbl) (rev wbl))"
   apply transfer
   apply (drule sym)
   apply (drule sym)
   apply (simp add: rbl_add)
   done
 
 lemma word_mult_rbl:
   "to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
     to_bl (v * w) = rev (rbl_mult (rev vbl) (rev wbl))"
   apply transfer
   apply (drule sym)
   apply (drule sym)
   apply (simp add: rbl_mult)
   done
 
 lemma rtb_rbl_ariths:
   "rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_succ w)) = rbl_succ ys"
   "rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_pred w)) = rbl_pred ys"
   "rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v * w)) = rbl_mult ys xs"
   "rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v + w)) = rbl_add ys xs"
   by (auto simp: rev_swap [symmetric] word_succ_rbl word_pred_rbl word_mult_rbl word_add_rbl)
 
 lemma of_bl_length_less:
   \<open>(of_bl x :: 'a::len word) < 2 ^ k\<close>
     if \<open>length x = k\<close> \<open>k < LENGTH('a)\<close>
 proof -
   from that have \<open>length x < LENGTH('a)\<close>
     by simp
   then have \<open>(of_bl x :: 'a::len word) < 2 ^ length x\<close>
     apply (simp add: of_bl_eq)
     apply transfer
     apply (simp add: take_bit_horner_sum_bit_eq)
     apply (subst length_rev [symmetric])
     apply (simp only: horner_sum_of_bool_2_less)
     done
   with that show ?thesis
     by simp
 qed
 
 lemma word_eq_rbl_eq: "x = y \<longleftrightarrow> rev (to_bl x) = rev (to_bl y)"
   by simp
 
 lemma bl_word_not: "to_bl (NOT w) = map Not (to_bl w)"
   by transfer (simp add: bl_not_bin)
 
 lemma bl_word_xor: "to_bl (v XOR w) = map2 (\<noteq>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_xor_bin)
 
 lemma bl_word_or: "to_bl (v OR w) = map2 (\<or>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_or_bin)
 
 lemma bl_word_and: "to_bl (v AND w) = map2 (\<and>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_and_bin)
 
 lemma bin_nth_uint': "bin_nth (uint w) n \<longleftrightarrow> rev (bin_to_bl (size w) (uint w)) ! n \<and> n < size w"
   apply (unfold word_size)
   apply (safe elim!: bin_nth_uint_imp)
    apply (frule bin_nth_uint_imp)
    apply (fast dest!: bin_nth_bl)+
   done
 
 lemmas bin_nth_uint = bin_nth_uint' [unfolded word_size]
 
 lemma test_bit_bl: "w !! n \<longleftrightarrow> rev (to_bl w) ! n \<and> n < size w"
   by transfer (auto simp add: bin_nth_bl)
 
 lemma to_bl_nth: "n < size w \<Longrightarrow> to_bl w ! n = w !! (size w - Suc n)"
   by (simp add: word_size rev_nth test_bit_bl)
 
 lemma map_bit_interval_eq:
   \<open>map (bit w) [0..<n] = takefill False n (rev (to_bl w))\<close> for w :: \<open>'a::len word\<close>
 proof (rule nth_equalityI)
   show \<open>length (map (bit w) [0..<n]) =
     length (takefill False n (rev (to_bl w)))\<close>
     by simp
   fix m
   assume \<open>m < length (map (bit w) [0..<n])\<close>
   then have \<open>m < n\<close>
     by simp
   then have \<open>bit w m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
     by (auto simp add: nth_takefill not_less rev_nth to_bl_nth word_size test_bit_word_eq dest: bit_imp_le_length)
   with \<open>m < n \<close>show \<open>map (bit w) [0..<n] ! m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
     by simp
 qed
 
 lemma to_bl_unfold:
   \<open>to_bl w = rev (map (bit w) [0..<LENGTH('a)])\<close> for w :: \<open>'a::len word\<close>
   by (simp add: map_bit_interval_eq takefill_bintrunc to_bl_def flip: bin_to_bl_def)
 
 lemma nth_rev_to_bl:
   \<open>rev (to_bl w) ! n \<longleftrightarrow> bit w n\<close>
   if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
   using that by (simp add: to_bl_unfold)
 
 lemma nth_to_bl:
   \<open>to_bl w ! n \<longleftrightarrow> bit w (LENGTH('a) - Suc n)\<close>
   if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
   using that by (simp add: to_bl_unfold rev_nth)
 
 lemma of_bl_rep_False: "of_bl (replicate n False @ bs) = of_bl bs"
   by (auto simp: of_bl_def bl_to_bin_rep_F)
 
 lemma [code abstract]:
   \<open>Word.the_int (of_bl bs :: 'a word) = horner_sum of_bool 2 (take LENGTH('a::len) (rev bs))\<close>
   apply (simp add: of_bl_eq flip: take_bit_horner_sum_bit_eq)
   apply transfer
   apply simp
   done
 
 lemma [code]:
   \<open>to_bl w = map (bit w) (rev [0..<LENGTH('a::len)])\<close>
   for w :: \<open>'a::len word\<close>
   by (fact to_bl_eq_rev)
 
 lemma word_reverse_eq_of_bl_rev_to_bl:
   \<open>word_reverse w = of_bl (rev (to_bl w))\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_word_reverse_iff bit_of_bl_iff nth_to_bl)
 
 lemmas word_reverse_no_def [simp] =
   word_reverse_eq_of_bl_rev_to_bl [of "numeral w"] for w
 
 lemma to_bl_word_rev: "to_bl (word_reverse w) = rev (to_bl w)"
   by (rule nth_equalityI) (simp_all add: nth_rev_to_bl word_reverse_def word_rep_drop flip: of_bl_eq)
 
 lemma to_bl_n1 [simp]: "to_bl (-1::'a::len word) = replicate (LENGTH('a)) True"
   apply (rule word_bl.Abs_inverse')
    apply simp
   apply (rule word_eqI)
   apply (clarsimp simp add: word_size)
   apply (auto simp add: word_bl.Abs_inverse test_bit_bl word_size)
   done
 
 lemma rbl_word_or: "rev (to_bl (x OR y)) = map2 (\<or>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_or rev_map)
 
 lemma rbl_word_and: "rev (to_bl (x AND y)) = map2 (\<and>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_and rev_map)
 
 lemma rbl_word_xor: "rev (to_bl (x XOR y)) = map2 (\<noteq>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: 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 bshiftr1_numeral [simp]:
   \<open>bshiftr1 b (numeral w :: 'a word) = of_bl (b # butlast (bin_to_bl LENGTH('a::len) (numeral w)))\<close>
   by (simp add: bshiftr1_eq)
 
 lemma bshiftr1_bl: "to_bl (bshiftr1 b w) = b # butlast (to_bl w)"
   unfolding bshiftr1_eq by (rule word_bl.Abs_inverse) simp
 
 lemma shiftl1_of_bl: "shiftl1 (of_bl bl) = of_bl (bl @ [False])"
   by transfer (simp add: bl_to_bin_append)
 
 lemma shiftl1_bl: "shiftl1 w = of_bl (to_bl w @ [False])"
   for w :: "'a::len word"
 proof -
   have "shiftl1 w = shiftl1 (of_bl (to_bl w))"
     by simp
   also have "\<dots> = of_bl (to_bl w @ [False])"
     by (rule shiftl1_of_bl)
   finally show ?thesis .
 qed
 
 lemma bl_shiftl1: "to_bl (shiftl1 w) = tl (to_bl w) @ [False]"
   for w :: "'a::len word"
   by (simp add: shiftl1_bl word_rep_drop drop_Suc drop_Cons') (fast intro!: Suc_leI)
 
 \<comment> \<open>Generalized version of \<open>bl_shiftl1\<close>. Maybe this one should replace it?\<close>
 lemma bl_shiftl1': "to_bl (shiftl1 w) = tl (to_bl w @ [False])"
   by (simp add: shiftl1_bl word_rep_drop drop_Suc del: drop_append)
 
 lemma shiftr1_bl:
   \<open>shiftr1 w = of_bl (butlast (to_bl w))\<close>
 proof (rule bit_word_eqI)
   fix n
   assume \<open>n < LENGTH('a)\<close>
   show \<open>bit (shiftr1 w) n \<longleftrightarrow> bit (of_bl (butlast (to_bl w)) :: 'a word) n\<close>
   proof (cases \<open>n = LENGTH('a) - 1\<close>)
     case True
     then show ?thesis
       by (simp add: bit_shiftr1_iff bit_of_bl_iff)
   next
     case False
     with \<open>n < LENGTH('a)\<close>
     have \<open>n < LENGTH('a) - 1\<close>
       by simp
     with \<open>n < LENGTH('a)\<close> show ?thesis 
       by (simp add: bit_shiftr1_iff bit_of_bl_iff rev_nth nth_butlast
         word_size test_bit_word_eq to_bl_nth)
   qed
 qed
 
 lemma bl_shiftr1: "to_bl (shiftr1 w) = False # butlast (to_bl w)"
   for w :: "'a::len word"
   by (simp add: shiftr1_bl word_rep_drop len_gt_0 [THEN Suc_leI])
 
 \<comment> \<open>Generalized version of \<open>bl_shiftr1\<close>. Maybe this one should replace it?\<close>
 lemma bl_shiftr1': "to_bl (shiftr1 w) = butlast (False # to_bl w)"
   apply (rule word_bl.Abs_inverse')
    apply (simp del: butlast.simps)
   apply (simp add: shiftr1_bl of_bl_def)
   done
 
 lemma bl_sshiftr1: "to_bl (sshiftr1 w) = hd (to_bl w) # butlast (to_bl w)"
   for w :: "'a::len word"
 proof (rule nth_equalityI)
   fix n
   assume \<open>n < length (to_bl (sshiftr1 w))\<close>
   then have \<open>n < LENGTH('a)\<close>
     by simp
   then show \<open>to_bl (sshiftr1 w) ! n \<longleftrightarrow> (hd (to_bl w) # butlast (to_bl w)) ! n\<close>
     apply (cases n)
      apply (simp_all add: to_bl_nth word_size hd_conv_nth test_bit_eq_bit bit_sshiftr1_iff nth_butlast Suc_diff_Suc nth_to_bl)
     done
 qed simp
 
 lemma drop_shiftr: "drop n (to_bl (w >> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
   apply (unfold shiftr_def)
   apply (induct n)
    prefer 2
    apply (simp add: drop_Suc bl_shiftr1 butlast_drop [symmetric])
    apply (rule butlast_take [THEN trans])
     apply (auto simp: word_size)
   done
 
 lemma drop_sshiftr: "drop n (to_bl (w >>> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
    apply (simp_all add: word_size sshiftr_eq)
   apply (rule nth_equalityI)
    apply (simp_all add: word_size nth_to_bl bit_signed_drop_bit_iff)
   done
 
 lemma take_shiftr: "n \<le> size w \<Longrightarrow> take n (to_bl (w >> n)) = replicate n False"
   apply (unfold shiftr_def)
   apply (induct n)
    prefer 2
    apply (simp add: bl_shiftr1' length_0_conv [symmetric] word_size)
    apply (rule take_butlast [THEN trans])
     apply (auto simp: word_size)
   done
 
 lemma take_sshiftr':
   "n \<le> size w \<Longrightarrow> hd (to_bl (w >>> n)) = hd (to_bl w) \<and>
     take n (to_bl (w >>> n)) = replicate n (hd (to_bl w))"
   for w :: "'a::len word"
   apply (auto simp add: sshiftr_eq hd_bl_sign_sint bin_sign_def not_le word_size sint_signed_drop_bit_eq)
   apply (rule nth_equalityI)
     apply (auto simp add: nth_to_bl bit_signed_drop_bit_iff bit_last_iff)
   apply (rule nth_equalityI)
    apply (auto simp add: nth_to_bl bit_signed_drop_bit_iff bit_last_iff)
   done
 
 lemmas hd_sshiftr = take_sshiftr' [THEN conjunct1]
 lemmas take_sshiftr = take_sshiftr' [THEN conjunct2]
 
 lemma atd_lem: "take n xs = t \<Longrightarrow> drop n xs = d \<Longrightarrow> xs = t @ d"
   by (auto intro: append_take_drop_id [symmetric])
 
 lemmas bl_shiftr = atd_lem [OF take_shiftr drop_shiftr]
 lemmas bl_sshiftr = atd_lem [OF take_sshiftr drop_sshiftr]
 
 lemma shiftl_of_bl: "of_bl bl << n = of_bl (bl @ replicate n False)"
   by (induct n) (auto simp: shiftl_def shiftl1_of_bl replicate_app_Cons_same)
 
 lemma shiftl_bl: "w << n = of_bl (to_bl w @ replicate n False)"
   for w :: "'a::len word"
 proof -
   have "w << n = of_bl (to_bl w) << n"
     by simp
   also have "\<dots> = of_bl (to_bl w @ replicate n False)"
     by (rule shiftl_of_bl)
   finally show ?thesis .
 qed
 
 lemma bl_shiftl: "to_bl (w << n) = drop n (to_bl w) @ replicate (min (size w) n) False"
   by (simp add: shiftl_bl word_rep_drop word_size)
 
 lemma shiftr1_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
     shiftr1 (of_bl bl::'a::len word) = of_bl (butlast bl)"
   by transfer (simp add: butlast_rest_bl2bin trunc_bl2bin)
 
 lemma shiftr_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
     (of_bl bl::'a::len word) >> n = of_bl (take (length bl - n) bl)"
   apply (unfold shiftr_def)
   apply (induct n)
    apply clarsimp
   apply clarsimp
   apply (subst shiftr1_bl_of)
    apply simp
   apply (simp add: butlast_take)
   done
 
 lemma shiftr_bl: "x >> n \<equiv> of_bl (take (LENGTH('a) - n) (to_bl x))"
   for x :: "'a::len word"
   using shiftr_bl_of [where 'a='a, of "to_bl x"] by simp
 
 lemma aligned_bl_add_size [OF refl]:
   "size x - n = m \<Longrightarrow> n \<le> size x \<Longrightarrow> drop m (to_bl x) = replicate n False \<Longrightarrow>
     take m (to_bl y) = replicate m False \<Longrightarrow>
     to_bl (x + y) = take m (to_bl x) @ drop m (to_bl y)" for x :: \<open>'a::len word\<close>
   apply (subgoal_tac "x AND y = 0")
    prefer 2
    apply (rule word_bl.Rep_eqD)
    apply (simp add: bl_word_and)
    apply (rule align_lem_and [THEN trans])
        apply (simp_all add: word_size)[5]
    apply simp
   apply (subst word_plus_and_or [symmetric])
   apply (simp add : bl_word_or)
   apply (rule align_lem_or)
      apply (simp_all add: word_size)
   done
 
 lemma mask_bl: "mask n = of_bl (replicate n True)"
   by (auto simp add : test_bit_of_bl word_size intro: word_eqI)
 
 lemma bl_and_mask':
   "to_bl (w AND mask n :: 'a::len word) =
     replicate (LENGTH('a) - n) False @
     drop (LENGTH('a) - n) (to_bl w)"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp add: to_bl_nth word_size)
   apply (auto simp add: word_size test_bit_bl nth_append rev_nth)
   done
 
 lemma slice1_eq_of_bl:
   \<open>(slice1 n w :: 'b::len word) = of_bl (takefill False n (to_bl w))\<close>
   for w :: \<open>'a::len word\<close>
 proof (rule bit_word_eqI)
   fix m
   assume \<open>m < LENGTH('b)\<close>
   show \<open>bit (slice1 n w :: 'b::len word) m \<longleftrightarrow> bit (of_bl (takefill False n (to_bl w)) :: 'b word) m\<close>
     by (cases \<open>m \<ge> n\<close>; cases \<open>LENGTH('a) \<ge> n\<close>)
       (auto simp add: bit_slice1_iff bit_of_bl_iff not_less rev_nth not_le nth_takefill nth_to_bl algebra_simps)
 qed
 
 lemma slice1_no_bin [simp]:
   "slice1 n (numeral w :: 'b word) = of_bl (takefill False n (bin_to_bl (LENGTH('b::len)) (numeral w)))"
   by (simp add: slice1_eq_of_bl) (* TODO: neg_numeral *)
 
 lemma slice_no_bin [simp]:
   "slice n (numeral w :: 'b word) = of_bl (takefill False (LENGTH('b::len) - n)
     (bin_to_bl (LENGTH('b::len)) (numeral w)))"
   by (simp add: slice_def) (* TODO: neg_numeral *)
 
 lemma slice_take': "slice n w = of_bl (take (size w - n) (to_bl w))"
   by (simp add: slice_def word_size slice1_eq_of_bl takefill_alt)
 
 lemmas slice_take = slice_take' [unfolded word_size]
 
 \<comment> \<open>shiftr to a word of the same size is just slice,
     slice is just shiftr then ucast\<close>
 lemmas shiftr_slice = trans [OF shiftr_bl [THEN meta_eq_to_obj_eq] slice_take [symmetric]]
 
 lemma slice1_down_alt':
   "sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs + k = n \<Longrightarrow>
     to_bl sl = takefill False fs (drop k (to_bl w))"
   apply (simp add: slice1_eq_of_bl)
   apply transfer
   apply (simp add: bl_bin_bl_rep_drop)
   using drop_takefill
   apply force
   done
 
 lemma slice1_up_alt':
   "sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs = n + k \<Longrightarrow>
     to_bl sl = takefill False fs (replicate k False @ (to_bl w))"
   apply (simp add: slice1_eq_of_bl)
   apply transfer
   apply (simp add: bl_bin_bl_rep_drop flip: takefill_append)
   apply (metis diff_add_inverse)
   done
 
 lemmas sd1 = slice1_down_alt' [OF refl refl, unfolded word_size]
 lemmas su1 = slice1_up_alt' [OF refl refl, unfolded word_size]
 lemmas slice1_down_alt = le_add_diff_inverse [THEN sd1]
 lemmas slice1_up_alts =
   le_add_diff_inverse [symmetric, THEN su1]
   le_add_diff_inverse2 [symmetric, THEN su1]
 
 lemma slice1_tf_tf':
   "to_bl (slice1 n w :: 'a::len word) =
     rev (takefill False (LENGTH('a)) (rev (takefill False n (to_bl w))))"
   unfolding slice1_eq_of_bl by (rule word_rev_tf)
 
 lemmas slice1_tf_tf = slice1_tf_tf' [THEN word_bl.Rep_inverse', symmetric]
 
 lemma revcast_eq_of_bl:
   \<open>(revcast w :: 'b::len word) = of_bl (takefill False (LENGTH('b)) (to_bl w))\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: revcast_def slice1_eq_of_bl)
 
 lemmas revcast_no_def [simp] = revcast_eq_of_bl [where w="numeral w", unfolded word_size] for w
 
 lemma to_bl_revcast:
   "to_bl (revcast w :: 'a::len word) = takefill False (LENGTH('a)) (to_bl w)"
   apply (rule nth_equalityI)
   apply simp
   apply (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
    apply (auto simp add: nth_to_bl nth_takefill bit_revcast_iff)
   done
 
 lemma word_cat_bl: "word_cat a b = of_bl (to_bl a @ to_bl b)"
   apply (rule bit_word_eqI)
   apply (simp add: bit_word_cat_iff bit_of_bl_iff nth_append not_less nth_rev_to_bl)
   apply (meson bit_word.rep_eq less_diff_conv2 nth_rev_to_bl)
   done
 
 lemma of_bl_append:
   "(of_bl (xs @ ys) :: 'a::len word) = of_bl xs * 2^(length ys) + of_bl ys"
   apply transfer
   apply (simp add: bl_to_bin_app_cat bin_cat_num)
   done
 
 lemma of_bl_False [simp]: "of_bl (False#xs) = of_bl xs"
   by (rule word_eqI) (auto simp: test_bit_of_bl nth_append)
 
 lemma of_bl_True [simp]: "(of_bl (True # xs) :: 'a::len word) = 2^length xs + of_bl xs"
   by (subst of_bl_append [where xs="[True]", simplified]) (simp add: word_1_bl)
 
 lemma of_bl_Cons: "of_bl (x#xs) = of_bool x * 2^length xs + of_bl xs"
   by (cases x) simp_all
 
 lemma word_split_bl':
   "std = size c - size b \<Longrightarrow> (word_split c = (a, b)) \<Longrightarrow>
     (a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c)))"
   apply (simp add: word_split_def)
   apply transfer
   apply (cases \<open>LENGTH('b) \<le> LENGTH('a)\<close>)
    apply (auto simp add: drop_bit_take_bit drop_bin2bl bin_to_bl_drop_bit [symmetric, of \<open>LENGTH('a)\<close> \<open>LENGTH('a) - LENGTH('b)\<close> \<open>LENGTH('b)\<close>] min_absorb2)
   done
 
 lemma word_split_bl: "std = size c - size b \<Longrightarrow>
     (a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c))) \<longleftrightarrow>
     word_split c = (a, b)"
   apply (rule iffI)
    defer
    apply (erule (1) word_split_bl')
   apply (case_tac "word_split c")
   apply (auto simp add: word_size)
   apply (frule word_split_bl' [rotated])
    apply (auto simp add: word_size)
   done
 
 lemma word_split_bl_eq:
   "(word_split c :: ('c::len word \<times> 'd::len word)) =
     (of_bl (take (LENGTH('a::len) - LENGTH('d::len)) (to_bl c)),
      of_bl (drop (LENGTH('a) - LENGTH('d)) (to_bl c)))"
   for c :: "'a::len word"
   apply (rule word_split_bl [THEN iffD1])
    apply (unfold word_size)
    apply (rule refl conjI)+
   done
 
 lemma word_rcat_bl:
   \<open>word_rcat wl = of_bl (concat (map to_bl wl))\<close>
 proof -
   define ws where \<open>ws = rev wl\<close>
   moreover have \<open>word_rcat (rev ws) = of_bl (concat (map to_bl (rev ws)))\<close>
     apply (simp add: word_rcat_def of_bl_eq rev_concat rev_map comp_def rev_to_bl_eq flip: horner_sum_of_bool_2_concat)
     apply transfer
     apply simp
     done
   ultimately show ?thesis
     by simp
 qed
 
 lemma size_rcat_lem': "size (concat (map to_bl wl)) = length wl * size (hd wl)"
   by (induct wl) (auto simp: word_size)
 
 lemmas size_rcat_lem = size_rcat_lem' [unfolded word_size]
 
 lemma nth_rcat_lem:
   "n < length (wl::'a word list) * LENGTH('a::len) \<Longrightarrow>
     rev (concat (map to_bl wl)) ! n =
     rev (to_bl (rev wl ! (n div LENGTH('a)))) ! (n mod LENGTH('a))"
   apply (induct wl)
    apply clarsimp
   apply (clarsimp simp add : nth_append size_rcat_lem)
   apply (simp flip: mult_Suc minus_div_mult_eq_mod add: less_Suc_eq_le not_less)
   apply (metis (no_types, lifting) diff_is_0_eq div_le_mono len_not_eq_0 less_Suc_eq less_mult_imp_div_less nonzero_mult_div_cancel_right not_le nth_Cons_0)
   done
 
 lemma foldl_eq_foldr: "foldl (+) x xs = foldr (+) (x # xs) 0"
   for x :: "'a::comm_monoid_add"
   by (induct xs arbitrary: x) (auto simp: add.assoc)
 
 lemmas word_cat_bl_no_bin [simp] =
   word_cat_bl [where a="numeral a" and b="numeral b", unfolded to_bl_numeral]
   for a b (* FIXME: negative numerals, 0 and 1 *)
 
 lemmas word_split_bl_no_bin [simp] =
   word_split_bl_eq [where c="numeral c", unfolded to_bl_numeral] for c
 
 lemmas word_rot_defs = word_roti_eq_word_rotr_word_rotl word_rotr_eq word_rotl_eq
 
 lemma to_bl_rotl: "to_bl (word_rotl n w) = rotate n (to_bl w)"
   by (simp add: word_rotl_eq to_bl_use_of_bl)
 
 lemmas blrs0 = rotate_eqs [THEN to_bl_rotl [THEN trans]]
 
 lemmas word_rotl_eqs =
   blrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotl [symmetric]]
 
 lemma to_bl_rotr: "to_bl (word_rotr n w) = rotater n (to_bl w)"
   by (simp add: word_rotr_eq to_bl_use_of_bl)
 
 lemmas brrs0 = rotater_eqs [THEN to_bl_rotr [THEN trans]]
 
 lemmas word_rotr_eqs =
   brrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotr [symmetric]]
 
 declare word_rotr_eqs (1) [simp]
 declare word_rotl_eqs (1) [simp]
 
 lemmas abl_cong = arg_cong [where f = "of_bl"]
 
 locale word_rotate
 begin
 
 lemmas word_rot_defs' = to_bl_rotl to_bl_rotr
 
 lemmas blwl_syms [symmetric] = bl_word_not bl_word_and bl_word_or bl_word_xor
 
 lemmas lbl_lbl = trans [OF word_bl_Rep' word_bl_Rep' [symmetric]]
 
 lemmas ths_map2 [OF lbl_lbl] = rotate_map2 rotater_map2
 
 lemmas ths_map [where xs = "to_bl v"] = rotate_map rotater_map for v
 
 lemmas th1s [simplified word_rot_defs' [symmetric]] = ths_map2 ths_map
 
 end
 
 lemmas bl_word_rotl_dt = trans [OF to_bl_rotl rotate_drop_take,
   simplified word_bl_Rep']
 
 lemmas bl_word_rotr_dt = trans [OF to_bl_rotr rotater_drop_take,
   simplified word_bl_Rep']
 
 lemma bl_word_roti_dt':
   "n = nat ((- i) mod int (size (w :: 'a::len word))) \<Longrightarrow>
     to_bl (word_roti i w) = drop n (to_bl w) @ take n (to_bl w)"
   apply (unfold word_roti_eq_word_rotr_word_rotl)
   apply (simp add: bl_word_rotl_dt bl_word_rotr_dt word_size)
   apply safe
    apply (simp add: zmod_zminus1_eq_if)
    apply safe
     apply (simp add: nat_mult_distrib)
    apply (simp add: nat_diff_distrib [OF pos_mod_sign pos_mod_conj
                                       [THEN conjunct2, THEN order_less_imp_le]]
                     nat_mod_distrib)
   apply (simp add: nat_mod_distrib)
   done
 
 lemmas bl_word_roti_dt = bl_word_roti_dt' [unfolded word_size]
 
 lemmas word_rotl_dt = bl_word_rotl_dt [THEN word_bl.Rep_inverse' [symmetric]]
 lemmas word_rotr_dt = bl_word_rotr_dt [THEN word_bl.Rep_inverse' [symmetric]]
 lemmas word_roti_dt = bl_word_roti_dt [THEN word_bl.Rep_inverse' [symmetric]]
 
 lemmas word_rotr_dt_no_bin' [simp] =
   word_rotr_dt [where w="numeral w", unfolded to_bl_numeral] for w
   (* FIXME: negative numerals, 0 and 1 *)
 
 lemmas word_rotl_dt_no_bin' [simp] =
   word_rotl_dt [where w="numeral w", unfolded to_bl_numeral] for w
   (* FIXME: negative numerals, 0 and 1 *)
 
 lemma max_word_bl: "to_bl (max_word::'a::len word) = replicate LENGTH('a) True"
   by (fact to_bl_n1)
 
 lemma to_bl_mask:
   "to_bl (mask n :: 'a::len word) =
   replicate (LENGTH('a) - n) False @
     replicate (min (LENGTH('a)) n) True"
   by (simp add: mask_bl word_rep_drop min_def)
 
 lemma map_replicate_True:
   "n = length xs \<Longrightarrow>
     map (\<lambda>(x,y). x \<and> y) (zip xs (replicate n True)) = xs"
   by (induct xs arbitrary: n) auto
 
 lemma map_replicate_False:
   "n = length xs \<Longrightarrow> map (\<lambda>(x,y). x \<and> y)
     (zip xs (replicate n False)) = replicate n False"
   by (induct xs arbitrary: n) auto
 
 lemma bl_and_mask:
   fixes w :: "'a::len word"
     and n :: nat
   defines "n' \<equiv> LENGTH('a) - n"
   shows "to_bl (w AND mask n) = replicate n' False @ drop n' (to_bl w)"
 proof -
   note [simp] = map_replicate_True map_replicate_False
   have "to_bl (w AND mask n) = map2 (\<and>) (to_bl w) (to_bl (mask n::'a::len word))"
     by (simp add: bl_word_and)
   also have "to_bl w = take n' (to_bl w) @ drop n' (to_bl w)"
     by simp
   also have "map2 (\<and>) \<dots> (to_bl (mask n::'a::len word)) =
       replicate n' False @ drop n' (to_bl w)"
     unfolding to_bl_mask n'_def by (subst zip_append) auto
   finally show ?thesis .
 qed
 
 lemma drop_rev_takefill:
   "length xs \<le> n \<Longrightarrow>
     drop (n - length xs) (rev (takefill False n (rev xs))) = xs"
   by (simp add: takefill_alt rev_take)
 
 declare bin_to_bl_def [simp]
 
 lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append
 
 lemma uint_of_bl_is_bl_to_bin_drop:
   "length (dropWhile Not l) \<le> LENGTH('a) \<Longrightarrow> uint (of_bl l :: 'a::len word) = bl_to_bin l"
   apply transfer
   apply (simp add: take_bit_eq_mod)
   apply (rule Divides.mod_less)
    apply (rule bl_to_bin_ge0)
   using bl_to_bin_lt2p_drop apply (rule order.strict_trans2)
   apply simp
   done
 
 corollary uint_of_bl_is_bl_to_bin:
   "length l\<le>LENGTH('a) \<Longrightarrow> uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
   apply(rule uint_of_bl_is_bl_to_bin_drop)
   using le_trans length_dropWhile_le by blast
 
 lemma bin_to_bl_or:
   "bin_to_bl n (a OR b) = map2 (\<or>) (bin_to_bl n a) (bin_to_bl n b)"
   using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
   by simp
 
 lemma word_and_1_bl:
   fixes x::"'a::len word"
   shows "(x AND 1) = of_bl [x !! 0]"
   by (simp add: mod_2_eq_odd test_bit_word_eq and_one_eq)
 
 lemma word_1_and_bl:
   fixes x::"'a::len word"
   shows "(1 AND x) = of_bl [x !! 0]"
   by (simp add: mod_2_eq_odd test_bit_word_eq one_and_eq)
 
 lemma of_bl_drop:
   "of_bl (drop n xs) = (of_bl xs AND mask (length xs - n))"
   apply (clarsimp simp: bang_eq test_bit_of_bl rev_nth cong: rev_conj_cong)
   apply (safe; simp add: word_size to_bl_nth)
   done
 
 lemma to_bl_1:
   "to_bl (1::'a::len word) = replicate (LENGTH('a) - 1) False @ [True]"
   by (rule nth_equalityI) (auto simp add: to_bl_unfold nth_append rev_nth bit_1_iff not_less not_le)
 
 lemma eq_zero_set_bl:
   "(w = 0) = (True \<notin> set (to_bl w))"
   using list_of_false word_bl.Rep_inject by fastforce
 
 lemma of_drop_to_bl:
   "of_bl (drop n (to_bl x)) = (x AND mask (size x - n))"
   by (simp add: of_bl_drop word_size_bl)
 
 lemma unat_of_bl_length:
   "unat (of_bl xs :: 'a::len word) < 2 ^ (length xs)"
 proof (cases "length xs < LENGTH('a)")
   case True
   then have "(of_bl xs::'a::len word) < 2 ^ length xs"
     by (simp add: of_bl_length_less)
   with True
   show ?thesis
-    by (simp add: word_less_nat_alt word_unat_power unat_of_nat del: of_nat_power)
+    by (simp add: word_less_nat_alt unat_of_nat)
 next
   case False
   have "unat (of_bl xs::'a::len word) < 2 ^ LENGTH('a)"
     by (simp split: unat_split)
   also
   from False
   have "LENGTH('a) \<le> length xs" by simp
   then have "2 ^ LENGTH('a) \<le> (2::nat) ^ length xs"
     by (rule power_increasing) simp
   finally
   show ?thesis .
 qed
 
 lemma word_msb_alt: "msb w \<longleftrightarrow> hd (to_bl w)"
   for w :: "'a::len word"
   apply (simp add: msb_word_eq)
   apply (subst hd_conv_nth)
    apply simp
   apply (subst nth_to_bl)
    apply simp
   apply simp
   done
 
 lemma word_lsb_last:
   \<open>lsb w \<longleftrightarrow> last (to_bl w)\<close>
   for w :: \<open>'a::len word\<close>
   using nth_to_bl [of \<open>LENGTH('a) - Suc 0\<close> w]
   by (simp add: lsb_odd last_conv_nth)
 
 lemma is_aligned_to_bl:
   "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
   apply (simp add: is_aligned_mask eq_zero_set_bl)
   apply (clarsimp simp: in_set_conv_nth word_size)
   apply (simp add: to_bl_nth word_size cong: conj_cong)
   apply (simp add: diff_diff_less)
   apply safe
    apply (case_tac "n \<le> LENGTH('a)")
     prefer 2
     apply (rule_tac x=i in exI)
     apply clarsimp
    apply (subgoal_tac "\<exists>j < LENGTH('a). j < n \<and> LENGTH('a) - n + j = i")
     apply (erule exE)
     apply (rule_tac x=j in exI)
     apply clarsimp
    apply (thin_tac "w !! t" for t)
    apply (rule_tac x="i + n - LENGTH('a)" in exI)
    apply clarsimp
    apply arith
   apply (rule_tac x="LENGTH('a) - n + i" in exI)
   apply clarsimp
   apply arith
   done
 
 lemma is_aligned_replicate:
   fixes w::"'a::len word"
   assumes aligned: "is_aligned w n"
   and          nv: "n \<le> LENGTH('a)"
   shows   "to_bl w = (take (LENGTH('a) - n) (to_bl w)) @ replicate n False"
 proof -
   from nv have rl: "\<And>q. q < 2 ^ (LENGTH('a) - n) \<Longrightarrow>
       to_bl (2 ^ n * (of_nat q :: 'a word)) =
       drop n (to_bl (of_nat q :: 'a word)) @ replicate n False"
     by (metis bl_shiftl le_antisym min_def shiftl_t2n wsst_TYs(3))
   show ?thesis using aligned
     by (auto simp: rl elim: is_alignedE)
 qed
 
 lemma is_aligned_drop:
   fixes w::"'a::len word"
   assumes "is_aligned w n" "n \<le> LENGTH('a)"
   shows "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
 proof -
   have "to_bl w = take (LENGTH('a) - n) (to_bl w) @ replicate n False"
     by (rule is_aligned_replicate) fact+
   then have "drop (LENGTH('a) - n) (to_bl w) = drop (LENGTH('a) - n) \<dots>" by simp
   also have "\<dots> = replicate n False" by simp
   finally show ?thesis .
 qed
 
 lemma less_is_drop_replicate:
   fixes x::"'a::len word"
   assumes lt: "x < 2 ^ n"
   shows   "to_bl x = replicate (LENGTH('a) - n) False @ drop (LENGTH('a) - n) (to_bl x)"
   by (metis assms bl_and_mask' less_mask_eq)
 
 lemma is_aligned_add_conv:
   fixes off::"'a::len word"
   assumes aligned: "is_aligned w n"
   and        offv: "off < 2 ^ n"
   shows    "to_bl (w + off) =
    (take (LENGTH('a) - n) (to_bl w)) @ (drop (LENGTH('a) - n) (to_bl off))"
 proof cases
   assume nv: "n \<le> LENGTH('a)"
   show ?thesis
   proof (subst aligned_bl_add_size, simp_all only: word_size)
     show "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
       by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)
 
     from offv show "take (LENGTH('a) - n) (to_bl off) =
                     replicate (LENGTH('a) - n) False"
       by (subst less_is_drop_replicate, assumption) simp
   qed fact
 next
   assume "\<not> n \<le> LENGTH('a)"
   with offv show ?thesis by (simp add: power_overflow)
 qed
 
 lemma is_aligned_replicateI:
   "to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
   apply (simp add: is_aligned_to_bl word_size)
   apply (subgoal_tac "length addr = LENGTH('a) - n")
    apply (simp add: replicate_not_True)
   apply (drule arg_cong [where f=length])
   apply simp
   done
 
 lemma to_bl_2p:
   "n < LENGTH('a) \<Longrightarrow>
    to_bl ((2::'a::len word) ^ n) =
    replicate (LENGTH('a) - Suc n) False @ True # replicate n False"
   apply (subst shiftl_1 [symmetric])
   apply (subst bl_shiftl)
   apply (simp add: to_bl_1 min_def word_size)
   done
 
 lemma xor_2p_to_bl:
   fixes x::"'a::len word"
   shows "to_bl (x XOR 2^n) =
   (if n < LENGTH('a)
    then take (LENGTH('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (LENGTH('a)-n) (to_bl x)
    else to_bl x)"
 proof -
   have x: "to_bl x = take (LENGTH('a)-Suc n) (to_bl x) @ drop (LENGTH('a)-Suc n) (to_bl x)"
     by simp
 
   show ?thesis
   apply simp
   apply (rule conjI)
    apply (clarsimp simp: word_size)
    apply (simp add: bl_word_xor to_bl_2p)
    apply (subst x)
    apply (subst zip_append)
     apply simp
    apply (simp add: map_zip_replicate_False_xor drop_minus)
   apply (auto simp add: word_size nth_w2p intro!: word_eqI)
   done
 qed
 
 lemma is_aligned_replicateD:
   "\<lbrakk> is_aligned (w::'a::len word) n; n \<le> LENGTH('a) \<rbrakk>
      \<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
                \<and> length xs = size w - n"
   apply (subst is_aligned_replicate, assumption+)
   apply (rule exI, rule conjI, rule refl)
   apply (simp add: word_size)
   done
 
 text \<open>right-padding a word to a certain length\<close>
 
 definition
   "bl_pad_to bl sz \<equiv> bl @ (replicate (sz - length bl) False)"
 
 lemma bl_pad_to_length:
   assumes lbl: "length bl \<le> sz"
   shows   "length (bl_pad_to bl sz) = sz"
   using lbl by (simp add: bl_pad_to_def)
 
 lemma bl_pad_to_prefix:
   "prefix bl (bl_pad_to bl sz)"
   by (simp add: bl_pad_to_def)
 
 
 lemma of_bl_length:
   "length xs < LENGTH('a) \<Longrightarrow> of_bl xs < (2 :: 'a::len word) ^ length xs"
   by (simp add: of_bl_length_less)
 
 lemma of_bl_mult_and_not_mask_eq:
   "\<lbrakk>is_aligned (a :: 'a::len word) n; length b + m \<le> n\<rbrakk>
    \<Longrightarrow> a + of_bl b * (2^m) AND NOT(mask n) = a"
   apply (simp flip: push_bit_eq_mult subtract_mask(1) take_bit_eq_mask)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps not_le not_less)
    apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
   apply (erule is_alignedE')
   apply (simp add: take_bit_push_bit)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps)
   done
 
 lemma bin_to_bl_of_bl_eq:
   "\<lbrakk>is_aligned (a::'a::len word) n; length b + c \<le> n; length b + c < LENGTH('a)\<rbrakk>
   \<Longrightarrow> bin_to_bl (length b) (uint ((a + of_bl b * 2^c) >> c)) = b"
   apply (simp flip: push_bit_eq_mult take_bit_eq_mask add: shiftr_eq_drop_bit)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps not_le not_less unsigned_or_eq unsigned_drop_bit_eq
      unsigned_push_bit_eq bin_to_bl_or simp flip: bin_to_bl_def)
    apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
   apply (erule is_alignedE')
   apply (rule nth_equalityI)
    apply (auto simp add: nth_bin_to_bl bit_simps simp flip: bin_to_bl_def dest: nth_rev_alt)
   done
 
 (* FIXME: move to Word distribution *)
 lemma bin_nth_minus_Bit0[simp]:
   "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit0 w)) n = bin_nth (numeral w) (n - 1)"
   by (cases n; simp)
 
 lemma bin_nth_minus_Bit1[simp]:
   "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit1 w)) n = bin_nth (numeral w) (n - 1)"
   by (cases n; simp)
 
 (* casting a long word to a shorter word and casting back to the long word
    is equal to the original long word -- if the word is small enough.
   'l is the longer word.
   's is the shorter word.
 *)
 lemma bl_cast_long_short_long_ingoreLeadingZero_generic:
   "\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
    (of_bl :: _ \<Rightarrow> 'l::len word) (to_bl ((of_bl::_ \<Rightarrow> 's::len word) (to_bl w))) = w"
   by (rule word_uint_eqI) (simp add: uint_of_bl_is_bl_to_bin uint_of_bl_is_bl_to_bin_drop)
 
 (*
  Casting between longer and shorter word.
   'l is the longer word.
   's is the shorter word.
  For example: 'l::len word is 128 word (full ipv6 address)
               's::len word is 16 word (address piece of ipv6 address in colon-text-representation)
 *)
 corollary ucast_short_ucast_long_ingoreLeadingZero:
   "\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
    (ucast:: 's::len word \<Rightarrow> 'l::len word) ((ucast:: 'l::len word \<Rightarrow> 's::len word) w) = w"
   apply (subst ucast_bl)+
   apply (rule bl_cast_long_short_long_ingoreLeadingZero_generic; simp)
   done
 
 lemma length_drop_mask:
   fixes w::"'a::len word"
   shows "length (dropWhile Not (to_bl (w AND mask n))) \<le> n"
 proof -
   have "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
     for ls n by(subst takeWhile_append2) simp+
   then show ?thesis
     unfolding bl_and_mask by (simp add: dropWhile_eq_drop)
 qed
 
 lemma map_bits_rev_to_bl:
   "map ((!!) x) [0..<size x] = rev (to_bl x)"
   by (auto simp: list_eq_iff_nth_eq test_bit_bl word_size)
 
 lemma of_bl_length2:
   "length xs + c < LENGTH('a) \<Longrightarrow> of_bl xs * 2^c < (2::'a::len word) ^ (length xs + c)"
   by (simp add: of_bl_length word_less_power_trans2)
 
 lemma of_bl_max:
   "(of_bl xs :: 'a::len word) \<le> mask (length xs)"
 proof -
   define ys where \<open>ys = rev xs\<close>
   have \<open>take_bit (length ys) (horner_sum of_bool 2 ys :: 'a word) = horner_sum of_bool 2 ys\<close>
     by transfer (simp add: take_bit_horner_sum_bit_eq min_def)
   then have \<open>(of_bl (rev ys) :: 'a word) \<le> mask (length ys)\<close>
     by (simp only: of_bl_rev_eq less_eq_mask_iff_take_bit_eq_self)
   with ys_def show ?thesis
     by simp
 qed
 
 end
diff --git a/thys/Word_Lib/Signed_Division_Word.thy b/thys/Word_Lib/Signed_Division_Word.thy
--- a/thys/Word_Lib/Signed_Division_Word.thy
+++ b/thys/Word_Lib/Signed_Division_Word.thy
@@ -1,53 +1,151 @@
 
 section \<open>Signed division on word\<close>
 
 theory Signed_Division_Word
   imports "HOL-Library.Signed_Division" "HOL-Library.Word"
 begin
 
 instantiation word :: (len) signed_division
 begin
 
 lift_definition signed_divide_word :: \<open>'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>
   is \<open>\<lambda>k l. signed_take_bit (LENGTH('a) - Suc 0) k sdiv signed_take_bit (LENGTH('a) - Suc 0) l\<close>
   by (simp flip: signed_take_bit_decr_length_iff)
 
 lift_definition signed_modulo_word :: \<open>'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word\<close>
   is \<open>\<lambda>k l. signed_take_bit (LENGTH('a) - Suc 0) k smod signed_take_bit (LENGTH('a) - Suc 0) l\<close>
   by (simp flip: signed_take_bit_decr_length_iff)
 
 instance ..
 
 end
 
 lemma sdiv_word_def [code]:
   \<open>v sdiv w = word_of_int (sint v sdiv sint w)\<close>
   for v w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma smod_word_def [code]:
   \<open>v smod w = word_of_int (sint v smod sint w)\<close>
   for v w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma sdiv_smod_id:
   \<open>(a sdiv b) * b + (a smod b) = a\<close>
   for a b :: \<open>'a::len word\<close>
   by (cases \<open>sint a < 0\<close>; cases \<open>sint b < 0\<close>) (simp_all add: signed_modulo_int_def sdiv_word_def smod_word_def)
 
-(* Basic proofs that signed word div/mod operations are
- * truncations of their integer counterparts. *)
-
 lemma signed_div_arith:
     "sint ((a::('a::len) word) sdiv b) = signed_take_bit (LENGTH('a) - 1) (sint a sdiv sint b)"
   apply transfer
   apply simp
   done
 
 lemma signed_mod_arith:
     "sint ((a::('a::len) word) smod b) = signed_take_bit (LENGTH('a) - 1) (sint a smod sint b)"
   apply transfer
   apply simp
   done
 
+lemma word_sdiv_div1 [simp]:
+    "(a :: ('a::len) word) sdiv 1 = a"
+  apply (cases \<open>LENGTH('a)\<close>)
+  apply simp_all
+  apply transfer
+  apply simp
+  apply (case_tac nat)
+   apply simp_all
+  apply (simp add: take_bit_signed_take_bit)
+  done
+
+lemma word_sdiv_div0 [simp]:
+    "(a :: ('a::len) word) sdiv 0 = 0"
+  apply (auto simp: sdiv_word_def signed_divide_int_def sgn_if)
+  done
+
+lemma word_sdiv_div_minus1 [simp]:
+    "(a :: ('a::len) word) sdiv -1 = -a"
+  apply (auto simp: sdiv_word_def signed_divide_int_def sgn_if)
+  apply transfer
+  apply simp
+  apply (metis Suc_pred len_gt_0 signed_take_bit_eq_iff_take_bit_eq signed_take_bit_of_0 take_bit_of_0)
+  done
+
+lemmas word_sdiv_0 = word_sdiv_div0
+
+lemma sdiv_word_min:
+    "- (2 ^ (size a - 1)) \<le> sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word)"
+  using sdiv_int_range [where a="sint a" and b="sint b"]
+  apply auto
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  apply transfer
+  apply simp
+  apply (rule order_trans)
+   defer
+   apply assumption
+  apply simp
+  apply (metis abs_le_iff add.inverse_inverse le_cases le_minus_iff not_le signed_take_bit_int_eq_self_iff signed_take_bit_minus)
+  done
+
+lemmas word_sdiv_numerals_lhs = sdiv_word_def[where v="numeral x" for x]
+    sdiv_word_def[where v=0] sdiv_word_def[where v=1]
+
+lemmas word_sdiv_numerals = word_sdiv_numerals_lhs[where w="numeral y" for y]
+    word_sdiv_numerals_lhs[where w=0] word_sdiv_numerals_lhs[where w=1]
+
+lemma smod_word_mod_0 [simp]:
+  "x smod (0 :: ('a::len) word) = x"
+  by (clarsimp simp: smod_word_def)
+
+lemma smod_word_0_mod [simp]:
+  "0 smod (x :: ('a::len) word) = 0"
+  by (clarsimp simp: smod_word_def)
+
+lemma smod_word_max:
+  "sint (a::'a word) smod sint (b::'a word) < 2 ^ (LENGTH('a::len) - Suc 0)"
+  apply (cases \<open>sint b = 0\<close>)
+   apply (simp_all add: sint_less)
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  using smod_int_range [where a="sint a" and b="sint b"]
+  apply auto
+  apply (rule less_le_trans)
+   apply assumption
+  apply (auto simp add: abs_le_iff)
+   apply (metis diff_Suc_1 le_cases linorder_not_le sint_lt)
+  apply (metis add.inverse_inverse diff_Suc_1 linorder_not_less neg_less_iff_less sint_ge)
+  done
+
+lemma smod_word_min:
+  "- (2 ^ (LENGTH('a::len) - Suc 0)) \<le> sint (a::'a word) smod sint (b::'a word)"
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply simp_all
+  apply (cases \<open>sint b = 0\<close>)
+   apply simp_all
+   apply (metis diff_Suc_1 sint_ge)
+  using smod_int_range [where a="sint a" and b="sint b"]
+  apply auto
+  apply (rule order_trans)
+   defer
+   apply assumption
+  apply (auto simp add: algebra_simps abs_le_iff)
+   apply (metis abs_zero add.left_neutral add_mono_thms_linordered_semiring(1) diff_Suc_1 le_cases linorder_not_less sint_lt zabs_less_one_iff)
+  apply (metis abs_zero add.inverse_inverse add.left_neutral add_mono_thms_linordered_semiring(1) diff_Suc_1 le_cases le_minus_iff linorder_not_less sint_ge zabs_less_one_iff)
+  done
+
+lemma smod_word_alt_def:
+  "(a :: ('a::len) word) smod b = a - (a sdiv b) * b"
+  apply (cases \<open>a \<noteq> - (2 ^ (LENGTH('a) - 1)) \<or> b \<noteq> - 1\<close>)
+   apply (clarsimp simp: smod_word_def sdiv_word_def signed_modulo_int_def
+     simp flip: wi_hom_sub wi_hom_mult)
+  apply (clarsimp simp: smod_word_def signed_modulo_int_def)
+  done
+
+lemmas word_smod_numerals_lhs = smod_word_def[where v="numeral x" for x]
+    smod_word_def[where v=0] smod_word_def[where v=1]
+
+lemmas word_smod_numerals = word_smod_numerals_lhs[where w="numeral y" for y]
+    word_smod_numerals_lhs[where w=0] word_smod_numerals_lhs[where w=1]
+
 end
\ No newline at end of file
diff --git a/thys/Word_Lib/Signed_Words.thy b/thys/Word_Lib/Signed_Words.thy
--- a/thys/Word_Lib/Signed_Words.thy
+++ b/thys/Word_Lib/Signed_Words.thy
@@ -1,66 +1,98 @@
 (*
  * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section "Signed Words"
 
 theory Signed_Words
   imports "HOL-Library.Word"
 begin
 
 text \<open>Signed words as separate (isomorphic) word length class. Useful for tagging words in C.\<close>
 
 typedef ('a::len0) signed = "UNIV :: 'a set" ..
 
 lemma card_signed [simp]: "CARD (('a::len0) signed) = CARD('a)"
   unfolding type_definition.card [OF type_definition_signed]
   by simp
 
 instantiation signed :: (len0) len0
 begin
 
 definition
   len_signed [simp]: "len_of (x::'a::len0 signed itself) = LENGTH('a)"
 
 instance ..
 
 end
 
 instance signed :: (len) len
   by (intro_classes, simp)
 
 lemma scast_scast_id [simp]:
   "scast (scast x :: ('a::len) signed word) = (x :: 'a word)"
   "scast (scast y :: ('a::len) word) = (y :: 'a signed word)"
   by (auto simp: is_up scast_up_scast_id)
 
 lemma ucast_scast_id [simp]:
   "ucast (scast (x :: 'a::len signed word) :: 'a word) = x"
   by transfer (simp add: take_bit_signed_take_bit)
 
 lemma scast_of_nat [simp]:
   "scast (of_nat x :: 'a::len signed word) = (of_nat x :: 'a word)"
   by transfer (simp add: take_bit_signed_take_bit)
 
 lemma scast_ucast_id [simp]:
   "scast (ucast (x :: 'a::len word) :: 'a signed word) = x"
   by transfer (simp add: take_bit_signed_take_bit) 
 
 lemma scast_eq_scast_id [simp]:
   "((scast (a :: 'a::len signed word) :: 'a word) = scast b) = (a = b)"
   by (metis ucast_scast_id)
 
 lemma ucast_eq_ucast_id [simp]:
   "((ucast (a :: 'a::len word) :: 'a signed word) = ucast b) = (a = b)"
   by (metis scast_ucast_id)
 
 lemma scast_ucast_norm [simp]:
   "(ucast (a :: 'a::len word) = (b :: 'a signed word)) = (a = scast b)"
   "((b :: 'a signed word) = ucast (a :: 'a::len word)) = (a = scast b)"
   by (metis scast_ucast_id ucast_scast_id)+
 
+lemma scast_2_power [simp]: "scast ((2 :: 'a::len signed word) ^ x) = ((2 :: 'a word) ^ x)"
+  by (rule bit_word_eqI) (auto simp add: bit_simps)
+
+lemma ucast_nat_def':
+  "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> ('b :: len) signed word) x"
+  by (fact of_nat_unat)
+
+lemma zero_sle_ucast_up:
+  "\<not> is_down (ucast :: 'a word \<Rightarrow> 'b signed word) \<Longrightarrow>
+          (0 <=s ((ucast (b::('a::len) word)) :: ('b::len) signed word))"
+  by transfer (simp add: bit_simps)
+
+lemma word_le_ucast_sless:
+  "\<lbrakk> x \<le> y; y \<noteq> -1; LENGTH('a) < LENGTH('b) \<rbrakk> \<Longrightarrow>
+    (ucast x :: ('b :: len) signed word) <s ucast (y + 1)"
+  for x y :: \<open>'a::len word\<close>
+  apply (cases \<open>LENGTH('b)\<close>)
+  apply simp_all
+  apply transfer
+  apply (simp add: signed_take_bit_take_bit)
+  apply (metis add.commute mask_eq_exp_minus_1 mask_eq_take_bit_minus_one take_bit_incr_eq zle_add1_eq_le)
+  done
+
+lemma zero_sle_ucast:
+  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
+                = (uint b < 2 ^ (LENGTH('a) - 1))"
+  apply transfer
+  apply (cases \<open>LENGTH('a)\<close>)
+   apply (simp_all add: take_bit_Suc_from_most bit_simps)
+  apply (simp_all add: bit_simps disjunctive_add)
+  done
+
 type_synonym 'a sword = "'a signed word"
 
 end
diff --git a/thys/Word_Lib/Traditional_Infix_Syntax.thy b/thys/Word_Lib/Traditional_Infix_Syntax.thy
--- a/thys/Word_Lib/Traditional_Infix_Syntax.thy
+++ b/thys/Word_Lib/Traditional_Infix_Syntax.thy
@@ -1,914 +1,1060 @@
 (*  Author:     Jeremy Dawson, NICTA
 *)
 
 section \<open>Operation variants with traditional syntax\<close>
 
 theory Traditional_Infix_Syntax
-  imports "HOL-Library.Word" More_Word
+  imports "HOL-Library.Word" More_Word Signed_Words
 begin
 
 class semiring_bit_syntax = semiring_bit_shifts
 begin
 
 definition test_bit :: \<open>'a \<Rightarrow> nat \<Rightarrow> bool\<close>  (infixl "!!" 100)
   where test_bit_eq_bit: \<open>test_bit = bit\<close>
 
 definition shiftl :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl "<<" 55)
   where shiftl_eq_push_bit: \<open>a << n = push_bit n a\<close>
 
 definition shiftr :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl ">>" 55)
   where shiftr_eq_drop_bit: \<open>a >> n = drop_bit n a\<close>
 
 end
 
 instance word :: (len) semiring_bit_syntax ..
 
 context
   includes lifting_syntax
 begin
 
 lemma test_bit_word_transfer [transfer_rule]:
   \<open>(pcr_word ===> (=)) (\<lambda>k n. n < LENGTH('a) \<and> bit k n) (test_bit :: 'a::len word \<Rightarrow> _)\<close>
   by (unfold test_bit_eq_bit) transfer_prover
 
 lemma shiftl_word_transfer [transfer_rule]:
   \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. push_bit n k) shiftl\<close>
   by (unfold shiftl_eq_push_bit) transfer_prover
 
 lemma shiftr_word_transfer [transfer_rule]:
   \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. (drop_bit n \<circ> take_bit LENGTH('a)) k) (shiftr :: 'a::len word \<Rightarrow> _)\<close>
   by (unfold shiftr_eq_drop_bit) transfer_prover
 
 end
 
 
 lemma test_bit_word_eq:
   \<open>test_bit = (bit :: 'a::len word \<Rightarrow> _)\<close>
   by (fact test_bit_eq_bit)
 
 lemma shiftl_word_eq:
   \<open>w << n = push_bit n w\<close> for w :: \<open>'a::len word\<close>
   by (fact shiftl_eq_push_bit)
 
 lemma shiftr_word_eq:
   \<open>w >> n = drop_bit n w\<close> for w :: \<open>'a::len word\<close>
   by (fact shiftr_eq_drop_bit)
 
 lemma test_bit_eq_iff: "test_bit u = test_bit v \<longleftrightarrow> u = v"
   for u v :: "'a::len word"
   by (simp add: bit_eq_iff test_bit_eq_bit fun_eq_iff)
 
 lemma test_bit_size: "w !! n \<Longrightarrow> n < size w"
   for w :: "'a::len word"
   by transfer simp
 
 lemma word_eq_iff: "x = y \<longleftrightarrow> (\<forall>n<LENGTH('a). x !! n = y !! n)" (is \<open>?P \<longleftrightarrow> ?Q\<close>)
   for x y :: "'a::len word"
   by transfer (auto simp add: bit_eq_iff bit_take_bit_iff)
 
 lemma word_eqI: "(\<And>n. n < size u \<longrightarrow> u !! n = v !! n) \<Longrightarrow> u = v"
   for u :: "'a::len word"
   by (simp add: word_size word_eq_iff)
 
 lemma word_eqD: "u = v \<Longrightarrow> u !! x = v !! x"
   for u v :: "'a::len word"
   by simp
 
 lemma test_bit_bin': "w !! n \<longleftrightarrow> n < size w \<and> bit (uint w) n"
   by transfer (simp add: bit_take_bit_iff)
 
 lemmas test_bit_bin = test_bit_bin' [unfolded word_size]
 
 lemma word_test_bit_def: 
   \<open>test_bit a = bit (uint a)\<close>
   by transfer (simp add: fun_eq_iff bit_take_bit_iff)
 
 lemmas test_bit_def' = word_test_bit_def [THEN fun_cong]
 
 lemma word_test_bit_transfer [transfer_rule]:
   "(rel_fun pcr_word (rel_fun (=) (=)))
     (\<lambda>x n. n < LENGTH('a) \<and> bit x n) (test_bit :: 'a::len word \<Rightarrow> _)"
   by (simp only: test_bit_eq_bit) transfer_prover
 
 lemma test_bit_wi [simp]:
   "(word_of_int x :: 'a::len word) !! n \<longleftrightarrow> n < LENGTH('a) \<and> bit x n"
   by transfer simp
 
 lemma word_ops_nth_size:
   "n < size x \<Longrightarrow>
     (x OR y) !! n = (x !! n | y !! n) \<and>
     (x AND y) !! n = (x !! n \<and> y !! n) \<and>
     (x XOR y) !! n = (x !! n \<noteq> y !! n) \<and>
     (NOT x) !! n = (\<not> x !! n)"
   for x :: "'a::len word"
   by transfer (simp add: bit_or_iff bit_and_iff bit_xor_iff bit_not_iff)
 
 lemma word_ao_nth:
   "(x OR y) !! n = (x !! n | y !! n) \<and>
     (x AND y) !! n = (x !! n \<and> y !! n)"
   for x :: "'a::len word"
   by transfer (auto simp add: bit_or_iff bit_and_iff)
 
 lemmas msb0 = len_gt_0 [THEN diff_Suc_less, THEN word_ops_nth_size [unfolded word_size]]
 lemmas msb1 = msb0 [where i = 0]
 
 lemma test_bit_numeral [simp]:
   "(numeral w :: 'a::len word) !! n \<longleftrightarrow>
     n < LENGTH('a) \<and> bit (numeral w :: int) n"
   by transfer (rule refl)
 
 lemma test_bit_neg_numeral [simp]:
   "(- numeral w :: 'a::len word) !! n \<longleftrightarrow>
     n < LENGTH('a) \<and> bit (- numeral w :: int) n"
   by transfer (rule refl)
 
 lemma test_bit_1 [iff]: "(1 :: 'a::len word) !! n \<longleftrightarrow> n = 0"
   by transfer (auto simp add: bit_1_iff) 
 
 lemma nth_0 [simp]: "\<not> (0 :: 'a::len word) !! n"
   by transfer simp
 
 lemma nth_minus1 [simp]: "(-1 :: 'a::len word) !! n \<longleftrightarrow> n < LENGTH('a)"
   by transfer simp
 
 lemma shiftl1_code [code]:
   \<open>shiftl1 w = push_bit 1 w\<close>
   by transfer (simp add: ac_simps)
 
 lemma uint_shiftr_eq:
   \<open>uint (w >> n) = uint w div 2 ^ n\<close>
   by transfer (simp flip: drop_bit_eq_div add: drop_bit_take_bit min_def le_less less_diff_conv)
 
 lemma shiftr1_code [code]:
   \<open>shiftr1 w = drop_bit 1 w\<close>
   by transfer (simp add: drop_bit_Suc)
 
 lemma shiftl_def:
   \<open>w << n = (shiftl1 ^^ n) w\<close>
 proof -
   have \<open>push_bit n = (((*) 2 ^^ n) :: int \<Rightarrow> int)\<close> for n
     by (induction n) (simp_all add: fun_eq_iff funpow_swap1, simp add: ac_simps)
   then show ?thesis
     by transfer simp
 qed
 
 lemma shiftr_def:
   \<open>w >> n = (shiftr1 ^^ n) w\<close>
 proof -
   have \<open>shiftr1 ^^ n = (drop_bit n :: 'a word \<Rightarrow> 'a word)\<close>
     apply (induction n)
     apply simp
     apply (simp only: shiftr1_eq_div_2 [abs_def] drop_bit_eq_div [abs_def] funpow_Suc_right)
     apply (use div_exp_eq [of _ 1, where ?'a = \<open>'a word\<close>] in simp)
     done
   then show ?thesis
     by (simp add: shiftr_eq_drop_bit)
 qed
 
 lemma bit_shiftl_word_iff [bit_simps]:
   \<open>bit (w << m) n \<longleftrightarrow> m \<le> n \<and> n < LENGTH('a) \<and> bit w (n - m)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: shiftl_word_eq bit_push_bit_iff exp_eq_zero_iff not_le)
 
 lemma bit_shiftr_word_iff [bit_simps]:
   \<open>bit (w >> m) n \<longleftrightarrow> bit w (m + n)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: shiftr_word_eq bit_drop_bit_eq)
 
 lift_definition sshiftr :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>  (infixl \<open>>>>\<close> 55)
   is \<open>\<lambda>k n. take_bit LENGTH('a) (drop_bit n (signed_take_bit (LENGTH('a) - Suc 0) k))\<close>
   by (simp flip: signed_take_bit_decr_length_iff)
 
 lemma sshiftr_eq [code]:
   \<open>w >>> n = signed_drop_bit n w\<close>
   by transfer simp
 
 lemma sshiftr_eq_funpow_sshiftr1:
   \<open>w >>> n = (sshiftr1 ^^ n) w\<close>
   apply (rule sym)
   apply (simp add: sshiftr1_eq_signed_drop_bit_Suc_0 sshiftr_eq)
   apply (induction n)
    apply simp_all
   done
 
 lemma uint_sshiftr_eq:
   \<open>uint (w >>> n) = take_bit LENGTH('a) (sint w div 2 ^  n)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer (simp flip: drop_bit_eq_div)
 
 lemma sshift1_code [code]:
   \<open>sshiftr1 w = signed_drop_bit 1 w\<close>
   by transfer (simp add: drop_bit_Suc)
 
 lemma sshiftr_0 [simp]: "0 >>> n = 0"
   by transfer simp
 
 lemma sshiftr_n1 [simp]: "-1 >>> n = -1"
   by transfer simp
 
 lemma bit_sshiftr_word_iff [bit_simps]:
   \<open>bit (w >>> m) n \<longleftrightarrow> bit w (if LENGTH('a) - m \<le> n \<and> n < LENGTH('a) then LENGTH('a) - 1 else (m + n))\<close>
   for w :: \<open>'a::len word\<close>
   apply transfer
   apply (auto simp add: bit_take_bit_iff bit_drop_bit_eq bit_signed_take_bit_iff min_def not_le simp flip: bit_Suc)
   using le_less_Suc_eq apply fastforce
   using le_less_Suc_eq apply fastforce
   done
 
 lemma nth_sshiftr :
   "(w >>> m) !! n =
     (n < size w \<and> (if n + m \<ge> size w then w !! (size w - 1) else w !! (n + m)))"
   apply transfer
   apply (auto simp add: bit_take_bit_iff bit_drop_bit_eq bit_signed_take_bit_iff min_def not_le ac_simps)
   using le_less_Suc_eq apply fastforce
   using le_less_Suc_eq apply fastforce
   done
 
 lemma sshiftr_numeral [simp]:
   \<open>(numeral k >>> numeral n :: 'a::len word) =
     word_of_int (drop_bit (numeral n) (signed_take_bit (LENGTH('a) - 1) (numeral k)))\<close>
   apply (rule word_eqI)
   apply (cases \<open>LENGTH('a)\<close>)
    apply (simp_all add: word_size bit_drop_bit_eq nth_sshiftr bit_signed_take_bit_iff min_def not_le not_less less_Suc_eq_le ac_simps)
   done
 
 setup \<open>
   Context.theory_map (fold SMT_Word.add_word_shift' [
     (\<^term>\<open>shiftl :: 'a::len word \<Rightarrow> _\<close>, "bvshl"),
     (\<^term>\<open>shiftr :: 'a::len word \<Rightarrow> _\<close>, "bvlshr"),
     (\<^term>\<open>sshiftr :: 'a::len word \<Rightarrow> _\<close>, "bvashr")
   ])
 \<close>
 
 lemma revcast_down_us [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (w >>> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_ucast_iff bit_sshiftr_word_iff ac_simps)
   done
 
 lemma revcast_down_ss [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (w >>> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_scast_iff bit_sshiftr_word_iff ac_simps)
   done
 
 lemma sshiftr_div_2n: "sint (w >>> n) = sint w div 2 ^ n"
   using sint_signed_drop_bit_eq [of n w]
   by (simp add: drop_bit_eq_div sshiftr_eq) 
 
 lemmas lsb0 = len_gt_0 [THEN word_ops_nth_size [unfolded word_size]]
 
 lemma nth_sint:
   fixes w :: "'a::len word"
   defines "l \<equiv> LENGTH('a)"
   shows "bit (sint w) n = (if n < l - 1 then w !! n else w !! (l - 1))"
   unfolding sint_uint l_def
   by (auto simp: bit_signed_take_bit_iff word_test_bit_def not_less min_def)
 
 lemma test_bit_2p: "(word_of_int (2 ^ n)::'a::len word) !! m \<longleftrightarrow> m = n \<and> m < LENGTH('a)"
   by transfer (auto simp add: bit_exp_iff)
 
 lemma nth_w2p: "((2::'a::len word) ^ n) !! m \<longleftrightarrow> m = n \<and> m < LENGTH('a::len)"
   by transfer (auto simp add: bit_exp_iff)
 
 lemma bang_is_le: "x !! m \<Longrightarrow> 2 ^ m \<le> x"
   for x :: "'a::len word"
   apply (rule xtrans(3))
    apply (rule_tac [2] y = "x" in le_word_or2)
   apply (rule word_eqI)
   apply (auto simp add: word_ao_nth nth_w2p word_size)
   done
 
 lemma mask_eq:
   \<open>mask n = (1 << n) - (1 :: 'a::len word)\<close>
   by transfer (simp add: mask_eq_exp_minus_1 push_bit_of_1) 
 
 lemma nth_ucast:
   "(ucast w::'a::len word) !! n = (w !! n \<and> n < LENGTH('a))"
   by transfer (simp add: bit_take_bit_iff ac_simps)
 
 lemma shiftl_0 [simp]: "(0::'a::len word) << n = 0"
   by transfer simp
 
 lemma shiftr_0 [simp]: "(0::'a::len word) >> n = 0"
   by transfer simp
 
 lemma nth_shiftl1: "shiftl1 w !! n \<longleftrightarrow> n < size w \<and> n > 0 \<and> w !! (n - 1)"
   by transfer (auto simp add: bit_double_iff)
 
 lemma nth_shiftl': "(w << m) !! n \<longleftrightarrow> n < size w \<and> n >= m \<and> w !! (n - m)"
   for w :: "'a::len word"
   by transfer (auto simp add: bit_push_bit_iff)
 
 lemmas nth_shiftl = nth_shiftl' [unfolded word_size]
 
 lemma nth_shiftr1: "shiftr1 w !! n = w !! Suc n"
   by transfer (auto simp add: bit_take_bit_iff simp flip: bit_Suc)
 
 lemma nth_shiftr: "(w >> m) !! n = w !! (n + m)"
   for w :: "'a::len word"
   apply (unfold shiftr_def)
   apply (induct "m" arbitrary: n)
    apply (auto simp add: nth_shiftr1)
   done
 
 lemma nth_sshiftr1: "sshiftr1 w !! n = (if n = size w - 1 then w !! n else w !! Suc n)"
   apply transfer
   apply (auto simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def simp flip: bit_Suc)
   using le_less_Suc_eq apply fastforce
   using le_less_Suc_eq apply fastforce
   done
 
 lemma shiftr_div_2n: "uint (shiftr w n) = uint w div 2 ^ n"
   by (fact uint_shiftr_eq)
 
 lemma shiftl_rev: "shiftl w n = word_reverse (shiftr (word_reverse w) n)"
   by (induct n) (auto simp add: shiftl_def shiftr_def shiftl1_rev)
 
 lemma rev_shiftl: "word_reverse w << n = word_reverse (w >> n)"
   by (simp add: shiftl_rev)
 
 lemma shiftr_rev: "w >> n = word_reverse (word_reverse w << n)"
   by (simp add: rev_shiftl)
 
 lemma rev_shiftr: "word_reverse w >> n = word_reverse (w << n)"
   by (simp add: shiftr_rev)
 
 lemma shiftl_numeral [simp]:
   \<open>numeral k << numeral l = (push_bit (numeral l) (numeral k) :: 'a::len word)\<close>
   by (fact shiftl_word_eq)
 
 lemma shiftl_zero_size: "size x \<le> n \<Longrightarrow> x << n = 0"
   for x :: "'a::len word"
   apply transfer
   apply (simp add: take_bit_push_bit)
   done
 
 lemma shiftl_t2n: "shiftl w n = 2 ^ n * w"
   for w :: "'a::len word"
   by (induct n) (auto simp: shiftl_def shiftl1_2t)
 
 lemma shiftr_numeral [simp]:
   \<open>(numeral k >> numeral n :: 'a::len word) = drop_bit (numeral n) (numeral k)\<close>
   by (fact shiftr_word_eq)
 
 lemma nth_mask [simp]:
   \<open>(mask n :: 'a::len word) !! i \<longleftrightarrow> i < n \<and> i < size (mask n :: 'a word)\<close>
   by (auto simp add: test_bit_word_eq word_size Word.bit_mask_iff)
 
 lemma slice_shiftr: "slice n w = ucast (w >> n)"
   apply (rule bit_word_eqI)
   apply (cases \<open>n \<le> LENGTH('b)\<close>)
    apply (auto simp add: bit_slice_iff bit_ucast_iff bit_shiftr_word_iff ac_simps
     dest: bit_imp_le_length)
   done
 
 lemma nth_slice: "(slice n w :: 'a::len word) !! m = (w !! (m + n) \<and> m < LENGTH('a))"
   by (simp add: slice_shiftr nth_ucast nth_shiftr)
 
 lemma revcast_down_uu [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (w >> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_ucast_iff bit_shiftr_word_iff ac_simps)
   done
 
 lemma revcast_down_su [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (w >> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_scast_iff bit_shiftr_word_iff ac_simps)
   done
 
 lemma cast_down_rev [OF refl]:
   "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow> uc w = revcast (w << n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_ucast_iff bit_shiftl_word_iff)
   done
 
 lemma revcast_up [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc + n = target_size rc \<Longrightarrow>
     rc w = (ucast w :: 'a::len word) << n"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_ucast_iff bit_shiftl_word_iff)
   apply auto
   apply (metis add.commute add_diff_cancel_right)
   apply (metis diff_add_inverse2 diff_diff_add)
   done
 
 lemmas rc1 = revcast_up [THEN
   revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
 lemmas rc2 = revcast_down_uu [THEN
   revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
 
 lemmas ucast_up =
   rc1 [simplified rev_shiftr [symmetric] revcast_ucast [symmetric]]
 lemmas ucast_down =
   rc2 [simplified rev_shiftr revcast_ucast [symmetric]]
 
 \<comment> \<open>problem posed by TPHOLs referee:
       criterion for overflow of addition of signed integers\<close>
 
 lemma sofl_test:
   \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
     (x + y XOR x) AND (x + y XOR y) >> (size x - 1) = 0\<close>
   for x y :: \<open>'a::len word\<close>
 proof -
   obtain n where n: \<open>LENGTH('a) = Suc n\<close>
     by (cases \<open>LENGTH('a)\<close>) simp_all
   have *: \<open>sint x + sint y + 2 ^ Suc n > signed_take_bit n (sint x + sint y) \<Longrightarrow> sint x + sint y \<ge> - (2 ^ n)\<close>
     \<open>signed_take_bit n (sint x + sint y) > sint x + sint y - 2 ^ Suc n \<Longrightarrow> 2 ^ n > sint x + sint y\<close>
     using signed_take_bit_int_greater_eq [of \<open>sint x + sint y\<close> n] signed_take_bit_int_less_eq [of n \<open>sint x + sint y\<close>]
     by (auto intro: ccontr)
   have \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
     (sint (x + y) < 0 \<longleftrightarrow> sint x < 0) \<or>
     (sint (x + y) < 0 \<longleftrightarrow> sint y < 0)\<close>
     using sint_less [of x] sint_greater_eq [of x] sint_less [of y] sint_greater_eq [of y]
     signed_take_bit_int_eq_self [of \<open>LENGTH('a) - 1\<close> \<open>sint x + sint y\<close>]
     apply (auto simp add: not_less)
        apply (unfold sint_word_ariths)
        apply (subst signed_take_bit_int_eq_self)
          prefer 4
        apply (subst signed_take_bit_int_eq_self)
          prefer 7
        apply (subst signed_take_bit_int_eq_self)
          prefer 10
              apply (subst signed_take_bit_int_eq_self)
        apply (auto simp add: signed_take_bit_int_eq_self signed_take_bit_eq_take_bit_minus take_bit_Suc_from_most n not_less intro!: *)
     done
   then show ?thesis
     apply (simp only: One_nat_def word_size shiftr_word_eq drop_bit_eq_zero_iff_not_bit_last bit_and_iff bit_xor_iff)
     apply (simp add: bit_last_iff)
     done
 qed
 
 lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = 0"
   for x :: "'a :: len word"
   by (rule word_eqI) (auto simp add: nth_shiftr dest: test_bit_size)
 
 lemma test_bit_cat [OF refl]:
   "wc = word_cat a b \<Longrightarrow> wc !! n = (n < size wc \<and>
     (if n < size b then b !! n else a !! (n - size b)))"
   apply (simp add: word_size not_less; transfer)
        apply (auto simp add: bit_concat_bit_iff bit_take_bit_iff)
   done
 
 \<comment> \<open>keep quantifiers for use in simplification\<close>
 lemma test_bit_split':
   "word_split c = (a, b) \<longrightarrow>
     (\<forall>n m.
       b !! n = (n < size b \<and> c !! n) \<and>
       a !! m = (m < size a \<and> c !! (m + size b)))"
   by (auto simp add: word_split_bin' test_bit_bin bit_unsigned_iff word_size
     bit_drop_bit_eq ac_simps exp_eq_zero_iff
     dest: bit_imp_le_length)
 
 lemma test_bit_split:
   "word_split c = (a, b) \<Longrightarrow>
     (\<forall>n::nat. b !! n \<longleftrightarrow> n < size b \<and> c !! n) \<and>
     (\<forall>m::nat. a !! m \<longleftrightarrow> m < size a \<and> c !! (m + size b))"
   by (simp add: test_bit_split')
 
 lemma test_bit_split_eq:
   "word_split c = (a, b) \<longleftrightarrow>
     ((\<forall>n::nat. b !! n = (n < size b \<and> c !! n)) \<and>
      (\<forall>m::nat. a !! m = (m < size a \<and> c !! (m + size b))))"
   apply (rule_tac iffI)
    apply (rule_tac conjI)
     apply (erule test_bit_split [THEN conjunct1])
    apply (erule test_bit_split [THEN conjunct2])
   apply (case_tac "word_split c")
   apply (frule test_bit_split)
   apply (erule trans)
   apply (fastforce intro!: word_eqI simp add: word_size)
   done
 
 lemma test_bit_rcat:
   "sw = size (hd wl) \<Longrightarrow> rc = word_rcat wl \<Longrightarrow> rc !! n =
     (n < size rc \<and> n div sw < size wl \<and> (rev wl) ! (n div sw) !! (n mod sw))"
   for wl :: "'a::len word list"
   by (simp add: word_size word_rcat_def foldl_map rev_map bit_horner_sum_uint_exp_iff)
     (simp add: test_bit_eq_bit)
 
 lemmas test_bit_cong = arg_cong [where f = "test_bit", THEN fun_cong]
 
 lemma max_test_bit: "(max_word::'a::len word) !! n \<longleftrightarrow> n < LENGTH('a)"
   by (fact nth_minus1)
 
 lemma shiftr_x_0 [iff]: "x >> 0 = x"
   for x :: "'a::len word"
   by transfer simp
 
 lemma shiftl_x_0 [simp]: "x << 0 = x"
   for x :: "'a::len word"
   by (simp add: shiftl_t2n)
 
 lemma shiftl_1 [simp]: "(1::'a::len word) << n = 2^n"
   by (simp add: shiftl_t2n)
 
 lemma shiftr_1[simp]: "(1::'a::len word) >> n = (if n = 0 then 1 else 0)"
   by (induct n) (auto simp: shiftr_def)
 
 lemma map_nth_0 [simp]: "map ((!!) (0::'a::len word)) xs = replicate (length xs) False"
   by (induct xs) auto
 
 lemma word_and_1:
   "n AND 1 = (if n !! 0 then 1 else 0)" for n :: "_ word"
   by (rule bit_word_eqI) (auto simp add: bit_and_iff test_bit_eq_bit bit_1_iff intro: gr0I)
 
 lemma test_bit_1' [simp]:
   "(1 :: 'a :: len word) !! n \<longleftrightarrow> 0 < LENGTH('a) \<and> n = 0"
   by simp
 
 lemma shiftl0:
   "x << 0 = (x :: 'a :: len word)"
   by (fact shiftl_x_0)
 
 lemma word_ops_nth [simp]:
   fixes x y :: \<open>'a::len word\<close>
   shows
   word_or_nth:  "(x OR y) !! n = (x !! n \<or> y !! n)" and
   word_and_nth: "(x AND y) !! n = (x !! n \<and> y !! n)" and
   word_xor_nth: "(x XOR y) !! n = (x !! n \<noteq> y !! n)"
   by ((cases "n < size x",
       auto dest: test_bit_size simp: word_ops_nth_size word_size)[1])+
 
 lemma and_not_mask:
   "w AND NOT (mask n) = (w >> n) << n"
   for w :: \<open>'a::len word\<close>
   apply (rule word_eqI)
   apply (simp add : word_ops_nth_size word_size)
   apply (simp add : nth_shiftr nth_shiftl)
   by auto
 
 lemma and_mask:
   "w AND mask n = (w << (size w - n)) >> (size w - n)"
   for w :: \<open>'a::len word\<close>
   apply (rule word_eqI)
   apply (simp add : word_ops_nth_size word_size)
   apply (simp add : nth_shiftr nth_shiftl)
   by auto
 
 lemma nth_w2p_same:
   "(2^n :: 'a :: len word) !! n = (n < LENGTH('a))"
   by (simp add : nth_w2p)
 
 lemma shiftr_div_2n_w: "n < size w \<Longrightarrow> w >> n = w div (2^n :: 'a :: len word)"
   apply (unfold word_div_def)
   apply (simp add: uint_2p_alt word_size)
   apply (metis uint_shiftr_eq word_of_int_uint)
   done
 
 lemma le_shiftr:
   "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len word) >> n"
   apply (unfold shiftr_def)
   apply (induct_tac "n")
    apply auto
   apply (erule le_shiftr1)
   done
 
 lemma shiftr_mask_le:
   "n <= m \<Longrightarrow> mask n >> m = (0 :: 'a::len word)"
   apply (rule word_eqI)
   apply (simp add: word_size nth_shiftr)
   done
 
 lemma shiftr_mask [simp]:
   \<open>mask m >> m = (0::'a::len word)\<close>
   by (rule shiftr_mask_le) simp
   
 lemma word_leI:
   "(\<And>n.  \<lbrakk>n < size (u::'a::len word); u !! n \<rbrakk> \<Longrightarrow> (v::'a::len word) !! n) \<Longrightarrow> u <= v"
   apply (rule xtrans(4))
    apply (rule word_and_le2)
   apply (rule word_eqI)
   apply (simp add: word_ao_nth)
   apply safe
     apply assumption
    apply (erule_tac [2] asm_rl)
   apply (unfold word_size)
   by auto
 
 lemma le_mask_iff:
   "(w \<le> mask n) = (w >> n = 0)"
   for w :: \<open>'a::len word\<close>
   apply safe
    apply (rule word_le_0_iff [THEN iffD1])
    apply (rule xtrans(3))
     apply (erule_tac [2] le_shiftr)
    apply simp
   apply (rule word_leI)
   apply (rename_tac n')
   apply (drule_tac x = "n' - n" in word_eqD)
   apply (simp add : nth_shiftr word_size)
   apply (case_tac "n <= n'")
   by auto
 
 lemma and_mask_eq_iff_shiftr_0:
   "(w AND mask n = w) = (w >> n = 0)"
   for w :: \<open>'a::len word\<close>
   apply (unfold test_bit_eq_iff [THEN sym])
   apply (rule iffI)
    apply (rule ext)
    apply (rule_tac [2] ext)
    apply (auto simp add : word_ao_nth nth_shiftr)
     apply (drule arg_cong)
     apply (drule iffD2)
      apply assumption
     apply (simp add : word_ao_nth)
    prefer 2
    apply (simp add : word_size test_bit_bin)
   apply transfer
   apply (auto simp add: fun_eq_iff bit_simps)
   apply (metis add_diff_inverse_nat)
   done
 
 lemma mask_shiftl_decompose:
   "mask m << n = mask (m + n) AND NOT (mask n :: 'a::len word)"
   by (auto intro!: word_eqI simp: and_not_mask nth_shiftl nth_shiftr word_size)
 
 lemma bang_eq:
   fixes x :: "'a::len word"
   shows "(x = y) = (\<forall>n. x !! n = y !! n)"
   by (subst test_bit_eq_iff[symmetric]) fastforce
 
 lemma shiftl_over_and_dist:
   fixes a::"'a::len word"
   shows "(a AND b) << c = (a << c) AND (b << c)"
   apply(rule word_eqI)
   apply(simp add: word_ao_nth nth_shiftl, safe)
   done
 
 lemma shiftr_over_and_dist:
   fixes a::"'a::len word"
   shows "a AND b >> c = (a >> c) AND (b >> c)"
   apply(rule word_eqI)
   apply(simp add:nth_shiftr word_ao_nth)
   done
 
 lemma sshiftr_over_and_dist:
   fixes a::"'a::len word"
   shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
   apply(rule word_eqI)
   apply(simp add:nth_sshiftr word_ao_nth word_size)
   done
 
 lemma shiftl_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b << c = (a << c) OR (b << c)"
   apply(rule word_eqI)
   apply(simp add:nth_shiftl word_ao_nth, safe)
   done
 
 lemma shiftr_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b >> c = (a >> c) OR (b >> c)"
   apply(rule word_eqI)
   apply(simp add:nth_shiftr word_ao_nth)
   done
 
 lemma sshiftr_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
   apply(rule word_eqI)
   apply(simp add:nth_sshiftr word_ao_nth word_size)
   done
 
 lemmas shift_over_ao_dists =
   shiftl_over_or_dist shiftr_over_or_dist
   sshiftr_over_or_dist shiftl_over_and_dist
   shiftr_over_and_dist sshiftr_over_and_dist
 
 lemma shiftl_shiftl:
   fixes a::"'a::len word"
   shows "a << b << c = a << (b + c)"
   apply(rule word_eqI)
   apply(auto simp:word_size nth_shiftl add.commute add.left_commute)
   done
 
 lemma shiftr_shiftr:
   fixes a::"'a::len word"
   shows "a >> b >> c = a >> (b + c)"
   apply(rule word_eqI)
   apply(simp add:word_size nth_shiftr add.left_commute add.commute)
   done
 
 lemma shiftl_shiftr1:
   fixes a::"'a::len word"
   shows "c \<le> b \<Longrightarrow> a << b >> c = a AND (mask (size a - b)) << (b - c)"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth)
   done
 
 lemma shiftl_shiftr2:
   fixes a::"'a::len word"
   shows "b < c \<Longrightarrow> a << b >> c = (a >> (c - b)) AND (mask (size a - c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth)
   done
 
 lemma shiftr_shiftl1:
   fixes a::"'a::len word"
   shows "c \<le> b \<Longrightarrow> a >> b << c = (a >> (b - c)) AND (NOT (mask c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ops_nth_size)
   done
 
 lemma shiftr_shiftl2:
   fixes a::"'a::len word"
   shows "b < c \<Longrightarrow> a >> b << c = (a << (c - b)) AND (NOT (mask c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ops_nth_size)
   done
 
 lemmas multi_shift_simps =
   shiftl_shiftl shiftr_shiftr
   shiftl_shiftr1 shiftl_shiftr2
   shiftr_shiftl1 shiftr_shiftl2
 
 lemma shiftr_mask2:
   "n \<le> LENGTH('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
   apply (rule word_eqI)
   apply (simp add: nth_shiftr word_size)
   apply arith
   done
 
 lemma word_shiftl_add_distrib:
   fixes x :: "'a :: len word"
   shows "(x + y) << n = (x << n) + (y << n)"
   by (simp add: shiftl_t2n ring_distribs)
 
 lemma mask_shift:
   "(x AND NOT (mask y)) >> y = x >> y"
   for x :: \<open>'a::len word\<close>
   apply (rule bit_eqI)
   apply (simp add: bit_and_iff bit_not_iff bit_shiftr_word_iff bit_mask_iff not_le)
   using bit_imp_le_length apply auto
   done
 
 lemma shiftr_div_2n':
   "unat (w >> n) = unat w div 2 ^ n"
   apply (unfold unat_eq_nat_uint)
   apply (subst shiftr_div_2n)
   apply (subst nat_div_distrib)
    apply simp
   apply (simp add: nat_power_eq)
   done
 
 lemma shiftl_shiftr_id:
   assumes nv: "n < LENGTH('a)"
   and     xv: "x < 2 ^ (LENGTH('a) - n)"
   shows "x << n >> n = (x::'a::len word)"
   apply (simp add: shiftl_t2n)
   apply (rule word_eq_unatI)
   apply (subst shiftr_div_2n')
   apply (cases n)
    apply simp
   apply (subst iffD1 [OF unat_mult_lem])+
    apply (subst unat_power_lower[OF nv])
    apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
    apply (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl])
    apply (rule unat_power_lower)
    apply simp
   apply (subst unat_power_lower[OF nv])
   apply simp
   done
 
 lemma ucast_shiftl_eq_0:
   fixes w :: "'a :: len word"
   shows "\<lbrakk> n \<ge> LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (w << n) = (0 :: 'b :: len word)"
   by transfer (simp add: take_bit_push_bit)
 
 lemma word_shift_nonzero:
   "\<lbrakk> (x::'a::len word) \<le> 2 ^ m; m + n < LENGTH('a::len); x \<noteq> 0\<rbrakk>
    \<Longrightarrow> x << n \<noteq> 0"
   apply (simp only: word_neq_0_conv word_less_nat_alt
                     shiftl_t2n mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (subst mod_less)
    apply (rule order_le_less_trans)
     apply (erule mult_le_mono2)
    apply (subst power_add[symmetric])
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_shiftr_lt:
   fixes w :: "'a::len word"
   shows "unat (w >> n) < (2 ^ (LENGTH('a) - n))"
   apply (subst shiftr_div_2n')
   apply transfer
   apply (simp flip: drop_bit_eq_div add: drop_bit_nat_eq drop_bit_take_bit)
   done
 
 lemma neg_mask_test_bit:
   "(NOT(mask n) :: 'a :: len word) !! m = (n \<le> m \<and> m < LENGTH('a))"
   by (metis not_le nth_mask test_bit_bin word_ops_nth_size word_size)
 
 lemma upper_bits_unset_is_l2p:
   \<open>(\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n') \<longleftrightarrow> (p < 2 ^ n)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
     if \<open>n < LENGTH('a)\<close>
     for p :: "'a :: len word"
 proof
   assume ?Q
   then show ?P
     by (meson bang_is_le le_less_trans not_le word_power_increasing)
 next
   assume ?P
   have \<open>take_bit n p = p\<close>
   proof (rule bit_word_eqI)
     fix q
     assume \<open>q < LENGTH('a)\<close>
     show \<open>bit (take_bit n p) q \<longleftrightarrow> bit p q\<close>
     proof (cases \<open>q < n\<close>)
       case True
       then show ?thesis 
         by (auto simp add: bit_simps)
     next
       case False
       then have \<open>n \<le> q\<close>
         by simp
       with \<open>?P\<close> \<open>q < LENGTH('a)\<close> have \<open>\<not> bit p q\<close>
         by (simp add: test_bit_eq_bit)
       then show ?thesis
         by (simp add: bit_simps)
     qed
   qed
   with that show ?Q
     using take_bit_word_eq_self_iff [of n p] by auto
 qed
 
 lemma less_2p_is_upper_bits_unset:
   "p < 2 ^ n \<longleftrightarrow> n < LENGTH('a) \<and> (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n')" for p :: "'a :: len word"
   by (meson le_less_trans le_mask_iff_lt_2n upper_bits_unset_is_l2p word_zero_le)
 
 lemma test_bit_over:
   "n \<ge> size (x::'a::len word) \<Longrightarrow> (x !! n) = False"
   by transfer auto
 
 lemma le_mask_high_bits:
   "w \<le> mask n \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. \<not> w !! i)"
   for w :: \<open>'a::len word\<close>
   by (auto simp: word_size and_mask_eq_iff_le_mask[symmetric] word_eq_iff)
 
 lemma test_bit_conj_lt:
   "(x !! m \<and> m < LENGTH('a)) = x !! m" for x :: "'a :: len word"
   using test_bit_bin by blast
 
 lemma neg_test_bit:
   "(NOT x) !! n = (\<not> x !! n \<and> n < LENGTH('a))" for x :: "'a::len word"
   by (cases "n < LENGTH('a)") (auto simp add: test_bit_over word_ops_nth_size word_size)
 
 lemma shiftr_less_t2n':
   "\<lbrakk> x AND mask (n + m) = x; m < LENGTH('a) \<rbrakk> \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
   apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_drop_bit ac_simps)
   done
 
 lemma shiftr_less_t2n:
   "x < 2 ^ (n + m) \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
   apply (rule shiftr_less_t2n')
    apply (erule less_mask_eq)
   apply (rule ccontr)
   apply (simp add: not_less)
   apply (subst (asm) p2_eq_0[symmetric])
   apply (simp add: power_add)
   done
 
 lemma shiftr_eq_0:
   "n \<ge> LENGTH('a) \<Longrightarrow> ((w::'a::len word) >> n) = 0"
   apply (cut_tac shiftr_less_t2n'[of w n 0], simp)
    apply (simp add: mask_eq_iff)
   apply (simp add: lt2p_lem)
   apply simp
   done
 
 lemma shiftr_not_mask_0:
   "n+m \<ge> LENGTH('a :: len) \<Longrightarrow> ((w::'a::len word) >> n) AND NOT (mask m) = 0"
   by (rule bit_word_eqI) (auto simp add: bit_simps dest: bit_imp_le_length)
 
 lemma shiftl_less_t2n:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x < (2 ^ (m - n)); m < LENGTH('a) \<rbrakk> \<Longrightarrow> (x << n) < 2 ^ m"
   apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_push_bit)
   done
 
 lemma shiftl_less_t2n':
   "(x::'a::len word) < 2 ^ m \<Longrightarrow> m+n < LENGTH('a) \<Longrightarrow> x << n < 2 ^ (m + n)"
   by (rule shiftl_less_t2n) simp_all
 
+lemma nth_w2p_scast [simp]:
+  "((scast ((2::'a::len signed word) ^ n) :: 'a word) !! m)
+         \<longleftrightarrow> ((((2::'a::len  word) ^ n) :: 'a word) !! m)"
+  by transfer (auto simp add: bit_simps)
+
+lemma scast_bit_test [simp]:
+    "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
+  by (clarsimp simp: word_eq_iff)
+
+lemma signed_shift_guard_to_word:
+  "\<lbrakk> n < len_of TYPE ('a); n > 0 \<rbrakk>
+    \<Longrightarrow> (unat (x :: 'a :: len word) * 2 ^ y < 2 ^ n)
+    = (x = 0 \<or> x < (1 << n >> y))"
+  apply (simp only: nat_mult_power_less_eq)
+  apply (cases "y \<le> n")
+   apply (simp only: shiftl_shiftr1)
+   apply (subst less_mask_eq)
+    apply (simp add: word_less_nat_alt word_size)
+    apply (rule order_less_le_trans[rotated], rule power_increasing[where n=1])
+      apply simp
+     apply simp
+    apply simp
+   apply (simp add: nat_mult_power_less_eq word_less_nat_alt word_size)
+   apply auto[1]
+  apply (simp only: shiftl_shiftr2, simp add: unat_eq_0)
+  done
+
+lemma nth_bounded:
+  "\<lbrakk>(x :: 'a :: len word) !! n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
+  apply (rule ccontr)
+  apply (auto simp add: not_less test_bit_word_eq)
+  apply (meson bit_imp_le_length bit_uint_iff less_2p_is_upper_bits_unset test_bit_bin)
+  done
+
+lemma shiftl_mask_is_0[simp]:
+  "(x << n) AND mask n = 0"
+  for x :: \<open>'a::len word\<close>
+  by (simp flip: take_bit_eq_mask add: shiftl_eq_push_bit take_bit_push_bit)
+
+lemma rshift_sub_mask_eq:
+  "(a >> (size a - b)) AND mask b = a >> (size a - b)"
+  for a :: \<open>'a::len word\<close>
+  using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
+  apply (cases "b < size a")
+   apply simp
+  apply (simp add: linorder_not_less mask_eq_decr_exp word_size
+                   p2_eq_0[THEN iffD2])
+  done
+
+lemma shiftl_shiftr3:
+  "b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) AND mask (size a - c)"
+  for a :: \<open>'a::len word\<close>
+  apply (cases "b = c")
+   apply (simp add: shiftl_shiftr1)
+  apply (simp add: shiftl_shiftr2)
+  done
+
+lemma and_mask_shiftr_comm:
+  "m \<le> size w \<Longrightarrow> (w AND mask m) >> n = (w >> n) AND mask (m-n)"
+  for w :: \<open>'a::len word\<close>
+  by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)
+
+lemma and_mask_shiftl_comm:
+  "m+n \<le> size w \<Longrightarrow> (w AND mask m) << n = (w << n) AND mask (m+n)"
+  for w :: \<open>'a::len word\<close>
+  by (simp add: and_mask word_size shiftl_shiftl) (simp add: shiftl_shiftr1)
+
+lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
+  for x :: \<open>'a::len word\<close>
+  by (simp add: le_mask_iff shiftl_shiftr3)
+
+lemma word_and_1_shiftl:
+  "x AND (1 << n) = (if x !! n then (1 << n) else 0)" for x :: "'a :: len word"
+  apply (rule bit_word_eqI; transfer)
+  apply (auto simp add: bit_simps not_le ac_simps)
+  done
+
+lemmas word_and_1_shiftls'
+    = word_and_1_shiftl[where n=0]
+      word_and_1_shiftl[where n=1]
+      word_and_1_shiftl[where n=2]
+
+lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]
+
+lemma word_and_mask_shiftl:
+  "x AND (mask n << m) = ((x >> m) AND mask n) << m"
+  for x :: \<open>'a::len word\<close>
+  apply (rule bit_word_eqI; transfer)
+  apply (auto simp add: bit_simps not_le ac_simps)
+  done
+
+lemma shift_times_fold:
+  "(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
+  by (simp add: shiftl_t2n ac_simps power_add)
+
+lemma of_bool_nth:
+  "of_bool (x !! v) = (x >> v) AND 1"
+  for x :: \<open>'a::len word\<close>
+  by (simp add: test_bit_word_eq shiftr_word_eq bit_eq_iff)
+    (auto simp add: bit_1_iff bit_and_iff bit_drop_bit_eq intro: ccontr)
+
+lemma shiftr_mask_eq:
+  "(x >> n) AND mask (size x - n) = x >> n" for x :: "'a :: len word"
+  apply (simp flip: take_bit_eq_mask)
+  apply transfer
+  apply (simp add: take_bit_drop_bit)
+  done
+
+lemma shiftr_mask_eq':
+  "m = (size x - n) \<Longrightarrow> (x >> n) AND mask m = x >> n" for x :: "'a :: len word"
+  by (simp add: shiftr_mask_eq)
+
+lemma and_eq_0_is_nth:
+  fixes x :: "'a :: len word"
+  shows "y = 1 << n \<Longrightarrow> ((x AND y) = 0) = (\<not> (x !! n))"
+  apply safe
+   apply (drule_tac u="(x AND (1 << n))" and x=n in word_eqD)
+   apply (simp add: nth_w2p)
+   apply (simp add: test_bit_bin)
+  apply (rule bit_word_eqI)
+  apply (auto simp add: bit_simps test_bit_eq_bit)
+  done
+
+lemma and_neq_0_is_nth:
+  \<open>x AND y \<noteq> 0 \<longleftrightarrow> x !! n\<close> if \<open>y = 2 ^ n\<close> for x y :: \<open>'a::len word\<close>
+  apply (simp add: bit_eq_iff bit_simps)
+  using that apply (simp add: bit_simps not_le)
+  apply transfer
+  apply auto
+  done
+
+lemma nth_is_and_neq_0:
+  "(x::'a::len word) !! n = (x AND 2 ^ n \<noteq> 0)"
+  by (subst and_neq_0_is_nth; rule refl)
+
+lemma word_shift_zero:
+  "\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
+  apply (rule ccontr)
+  apply (drule (2) word_shift_nonzero)
+  apply simp
+  done
+
+lemma mask_shift_and_negate[simp]:"(w AND mask n << m) AND NOT (mask n << m) = 0"
+  for w :: \<open>'a::len word\<close>
+  by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff shiftl_word_eq bit_push_bit_iff)
+
 end
diff --git a/thys/Word_Lib/Typedef_Morphisms.thy b/thys/Word_Lib/Typedef_Morphisms.thy
--- a/thys/Word_Lib/Typedef_Morphisms.thy
+++ b/thys/Word_Lib/Typedef_Morphisms.thy
@@ -1,365 +1,362 @@
 (*
   Author:     Jeremy Dawson and Gerwin Klein, NICTA
 
   Consequences of type definition theorems, and of extended type definition.
 *)
 
 section \<open>Type Definition Theorems\<close>
 
 theory Typedef_Morphisms
   imports Main "HOL-Library.Word" Bit_Comprehension Bits_Int
 begin
 
 subsection "More lemmas about normal type definitions"
 
 lemma tdD1: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Rep x \<in> A"
   and tdD2: "type_definition Rep Abs A \<Longrightarrow> \<forall>x. Abs (Rep x) = x"
   and tdD3: "type_definition Rep Abs A \<Longrightarrow> \<forall>y. y \<in> A \<longrightarrow> Rep (Abs y) = y"
   by (auto simp: type_definition_def)
 
 lemma td_nat_int: "type_definition int nat (Collect ((\<le>) 0))"
   unfolding type_definition_def by auto
 
 context type_definition
 begin
 
 declare Rep [iff] Rep_inverse [simp] Rep_inject [simp]
 
 lemma Abs_eqD: "Abs x = Abs y \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x = y"
   by (simp add: Abs_inject)
 
 lemma Abs_inverse': "r \<in> A \<Longrightarrow> Abs r = a \<Longrightarrow> Rep a = r"
   by (safe elim!: Abs_inverse)
 
 lemma Rep_comp_inverse: "Rep \<circ> f = g \<Longrightarrow> Abs \<circ> g = f"
   using Rep_inverse by auto
 
 lemma Rep_eqD [elim!]: "Rep x = Rep y \<Longrightarrow> x = y"
   by simp
 
 lemma Rep_inverse': "Rep a = r \<Longrightarrow> Abs r = a"
   by (safe intro!: Rep_inverse)
 
 lemma comp_Abs_inverse: "f \<circ> Abs = g \<Longrightarrow> g \<circ> Rep = f"
   using Rep_inverse by auto
 
 lemma set_Rep: "A = range Rep"
 proof (rule set_eqI)
   show "x \<in> A \<longleftrightarrow> x \<in> range Rep" for x
     by (auto dest: Abs_inverse [of x, symmetric])
 qed
 
 lemma set_Rep_Abs: "A = range (Rep \<circ> Abs)"
 proof (rule set_eqI)
   show "x \<in> A \<longleftrightarrow> x \<in> range (Rep \<circ> Abs)" for x
     by (auto dest: Abs_inverse [of x, symmetric])
 qed
 
 lemma Abs_inj_on: "inj_on Abs A"
   unfolding inj_on_def
   by (auto dest: Abs_inject [THEN iffD1])
 
 lemma image: "Abs ` A = UNIV"
   by (fact Abs_image)
 
 lemmas td_thm = type_definition_axioms
 
 lemma fns1: "Rep \<circ> fa = fr \<circ> Rep \<or> fa \<circ> Abs = Abs \<circ> fr \<Longrightarrow> Abs \<circ> fr \<circ> Rep = fa"
   by (auto dest: Rep_comp_inverse elim: comp_Abs_inverse simp: o_assoc)
 
 lemmas fns1a = disjI1 [THEN fns1]
 lemmas fns1b = disjI2 [THEN fns1]
 
 lemma fns4: "Rep \<circ> fa \<circ> Abs = fr \<Longrightarrow> Rep \<circ> fa = fr \<circ> Rep \<and> fa \<circ> Abs = Abs \<circ> fr"
   by auto
 
 end
 
 interpretation nat_int: type_definition int nat "Collect ((\<le>) 0)"
   by (rule td_nat_int)
 
 declare
   nat_int.Rep_cases [cases del]
   nat_int.Abs_cases [cases del]
   nat_int.Rep_induct [induct del]
   nat_int.Abs_induct [induct del]
 
 
 subsection "Extended form of type definition predicate"
 
 lemma td_conds:
   "norm \<circ> norm = norm \<Longrightarrow>
     fr \<circ> norm = norm \<circ> fr \<longleftrightarrow> norm \<circ> fr \<circ> norm = fr \<circ> norm \<and> norm \<circ> fr \<circ> norm = norm \<circ> fr"
   apply safe
     apply (simp_all add: comp_assoc)
    apply (simp_all add: o_assoc)
   done
 
 lemma fn_comm_power: "fa \<circ> tr = tr \<circ> fr \<Longrightarrow> fa ^^ n \<circ> tr = tr \<circ> fr ^^ n"
   apply (rule ext)
   apply (induct n)
    apply (auto dest: fun_cong)
   done
 
 lemmas fn_comm_power' =
   ext [THEN fn_comm_power, THEN fun_cong, unfolded o_def]
 
 
 locale td_ext = type_definition +
   fixes norm
   assumes eq_norm: "\<And>x. Rep (Abs x) = norm x"
 begin
 
 lemma Abs_norm [simp]: "Abs (norm x) = Abs x"
   using eq_norm [of x] by (auto elim: Rep_inverse')
 
 lemma td_th: "g \<circ> Abs = f \<Longrightarrow> f (Rep x) = g x"
   by (drule comp_Abs_inverse [symmetric]) simp
 
 lemma eq_norm': "Rep \<circ> Abs = norm"
   by (auto simp: eq_norm)
 
 lemma norm_Rep [simp]: "norm (Rep x) = Rep x"
   by (auto simp: eq_norm' intro: td_th)
 
 lemmas td = td_thm
 
 lemma set_iff_norm: "w \<in> A \<longleftrightarrow> w = norm w"
   by (auto simp: set_Rep_Abs eq_norm' eq_norm [symmetric])
 
 lemma inverse_norm: "Abs n = w \<longleftrightarrow> Rep w = norm n"
   apply (rule iffI)
    apply (clarsimp simp add: eq_norm)
   apply (simp add: eq_norm' [symmetric])
   done
 
 lemma norm_eq_iff: "norm x = norm y \<longleftrightarrow> Abs x = Abs y"
   by (simp add: eq_norm' [symmetric])
 
 lemma norm_comps:
   "Abs \<circ> norm = Abs"
   "norm \<circ> Rep = Rep"
   "norm \<circ> norm = norm"
   by (auto simp: eq_norm' [symmetric] o_def)
 
 lemmas norm_norm [simp] = norm_comps
 
 lemma fns5: "Rep \<circ> fa \<circ> Abs = fr \<Longrightarrow> fr \<circ> norm = fr \<and> norm \<circ> fr = fr"
   by (fold eq_norm') auto
 
 text \<open>
   following give conditions for converses to \<open>td_fns1\<close>
   \<^item> the condition \<open>norm \<circ> fr \<circ> norm = fr \<circ> norm\<close> says that
     \<open>fr\<close> takes normalised arguments to normalised results
   \<^item> \<open>norm \<circ> fr \<circ> norm = norm \<circ> fr\<close> says that \<open>fr\<close>
     takes norm-equivalent arguments to norm-equivalent results
   \<^item> \<open>fr \<circ> norm = fr\<close> says that \<open>fr\<close>
     takes norm-equivalent arguments to the same result
   \<^item> \<open>norm \<circ> fr = fr\<close> says that \<open>fr\<close> takes any argument to a normalised result
 \<close>
 lemma fns2: "Abs \<circ> fr \<circ> Rep = fa \<Longrightarrow> norm \<circ> fr \<circ> norm = fr \<circ> norm \<longleftrightarrow> Rep \<circ> fa = fr \<circ> Rep"
   apply (fold eq_norm')
   apply safe
    prefer 2
    apply (simp add: o_assoc)
   apply (rule ext)
   apply (drule_tac x="Rep x" in fun_cong)
   apply auto
   done
 
 lemma fns3: "Abs \<circ> fr \<circ> Rep = fa \<Longrightarrow> norm \<circ> fr \<circ> norm = norm \<circ> fr \<longleftrightarrow> fa \<circ> Abs = Abs \<circ> fr"
   apply (fold eq_norm')
   apply safe
    prefer 2
    apply (simp add: comp_assoc)
   apply (rule ext)
   apply (drule_tac f="a \<circ> b" for a b in fun_cong)
   apply simp
   done
 
 lemma fns: "fr \<circ> norm = norm \<circ> fr \<Longrightarrow> fa \<circ> Abs = Abs \<circ> fr \<longleftrightarrow> Rep \<circ> fa = fr \<circ> Rep"
   apply safe
    apply (frule fns1b)
    prefer 2
    apply (frule fns1a)
    apply (rule fns3 [THEN iffD1])
      prefer 3
      apply (rule fns2 [THEN iffD1])
        apply (simp_all add: comp_assoc)
    apply (simp_all add: o_assoc)
   done
 
 lemma range_norm: "range (Rep \<circ> Abs) = A"
   by (simp add: set_Rep_Abs)
 
 end
 
 lemmas td_ext_def' =
   td_ext_def [unfolded type_definition_def td_ext_axioms_def]
 
 
 subsection \<open>Type-definition locale instantiations\<close>
 
 definition uints :: "nat \<Rightarrow> int set"
   \<comment> \<open>the sets of integers representing the words\<close>
   where "uints n = range (take_bit n)"
 
 definition sints :: "nat \<Rightarrow> int set"
   where "sints n = range (signed_take_bit (n - 1))"
 
 lemma uints_num: "uints n = {i. 0 \<le> i \<and> i < 2 ^ n}"
   by (simp add: uints_def range_bintrunc)
 
 lemma sints_num: "sints n = {i. - (2 ^ (n - 1)) \<le> i \<and> i < 2 ^ (n - 1)}"
   by (simp add: sints_def range_sbintrunc)
 
 definition unats :: "nat \<Rightarrow> nat set"
   where "unats n = {i. i < 2 ^ n}"
 
 \<comment> \<open>naturals\<close>
 lemma uints_unats: "uints n = int ` unats n"
   apply (unfold unats_def uints_num)
   apply safe
     apply (rule_tac image_eqI)
      apply (erule_tac nat_0_le [symmetric])
   by auto
 
 lemma unats_uints: "unats n = nat ` uints n"
   by (auto simp: uints_unats image_iff)
 
 lemma td_ext_uint:
   "td_ext (uint :: 'a word \<Rightarrow> int) word_of_int (uints (LENGTH('a::len)))
     (\<lambda>w::int. w mod 2 ^ LENGTH('a))"
   apply (unfold td_ext_def')
   apply transfer
   apply (simp add: uints_num take_bit_eq_mod)
   done
 
 interpretation word_uint:
   td_ext
     "uint::'a::len word \<Rightarrow> int"
     word_of_int
     "uints (LENGTH('a::len))"
     "\<lambda>w. w mod 2 ^ LENGTH('a::len)"
   by (fact td_ext_uint)
 
 lemmas td_uint = word_uint.td_thm
 lemmas int_word_uint = word_uint.eq_norm
 
 lemma td_ext_ubin:
   "td_ext (uint :: 'a word \<Rightarrow> int) word_of_int (uints (LENGTH('a::len)))
     (take_bit (LENGTH('a)))"
   apply standard
   apply transfer
   apply simp
   done
 
 interpretation word_ubin:
   td_ext
     "uint::'a::len word \<Rightarrow> int"
     word_of_int
     "uints (LENGTH('a::len))"
     "take_bit (LENGTH('a::len))"
   by (fact td_ext_ubin)
 
 lemma td_ext_unat [OF refl]:
   "n = LENGTH('a::len) \<Longrightarrow>
     td_ext (unat :: 'a word \<Rightarrow> nat) of_nat (unats n) (\<lambda>i. i mod 2 ^ n)"
   apply (standard; transfer)
      apply (simp_all add: unats_def take_bit_of_nat take_bit_nat_eq_self_iff
       flip: take_bit_eq_mod)
   done
 
 lemmas unat_of_nat = td_ext_unat [THEN td_ext.eq_norm]
 
 interpretation word_unat:
   td_ext
     "unat::'a::len word \<Rightarrow> nat"
     of_nat
     "unats (LENGTH('a::len))"
     "\<lambda>i. i mod 2 ^ LENGTH('a::len)"
   by (rule td_ext_unat)
 
 lemmas td_unat = word_unat.td_thm
 
 lemma unat_le: "y \<le> unat z \<Longrightarrow> y \<in> unats (LENGTH('a))"
   for z :: "'a::len word"
   apply (unfold unats_def)
   apply clarsimp
   apply (rule xtrans, rule unat_lt2p, assumption)
   done
 
 lemma td_ext_sbin:
   "td_ext (sint :: 'a word \<Rightarrow> int) word_of_int (sints (LENGTH('a::len)))
     (signed_take_bit (LENGTH('a) - 1))"
   by (standard; transfer) (auto simp add: sints_def)
 
 lemma td_ext_sint:
   "td_ext (sint :: 'a word \<Rightarrow> int) word_of_int (sints (LENGTH('a::len)))
      (\<lambda>w. (w + 2 ^ (LENGTH('a) - 1)) mod 2 ^ LENGTH('a) -
          2 ^ (LENGTH('a) - 1))"
   using td_ext_sbin [where ?'a = 'a] by (simp add: no_sbintr_alt2)
 
 text \<open>
   We do \<open>sint\<close> before \<open>sbin\<close>, before \<open>sint\<close> is the user version
   and interpretations do not produce thm duplicates. I.e.
   we get the name \<open>word_sint.Rep_eqD\<close>, but not \<open>word_sbin.Req_eqD\<close>,
   because the latter is the same thm as the former.
 \<close>
 interpretation word_sint:
   td_ext
     "sint ::'a::len word \<Rightarrow> int"
     word_of_int
     "sints (LENGTH('a::len))"
     "\<lambda>w. (w + 2^(LENGTH('a::len) - 1)) mod 2^LENGTH('a::len) -
       2 ^ (LENGTH('a::len) - 1)"
   by (rule td_ext_sint)
 
 interpretation word_sbin:
   td_ext
     "sint ::'a::len word \<Rightarrow> int"
     word_of_int
     "sints (LENGTH('a::len))"
     "signed_take_bit (LENGTH('a::len) - 1)"
   by (rule td_ext_sbin)
 
 lemmas int_word_sint = td_ext_sint [THEN td_ext.eq_norm]
 
 lemmas td_sint = word_sint.td
 
 lemma uints_mod: "uints n = range (\<lambda>w. w mod 2 ^ n)"
   by (fact uints_def [unfolded no_bintr_alt1])
 
-lemmas uint_range' = word_uint.Rep [unfolded uints_num mem_Collect_eq]
-lemmas sint_range' = word_sint.Rep [unfolded One_nat_def sints_num mem_Collect_eq]
-
 lemmas bintr_num =
   word_ubin.norm_eq_iff [of "numeral a" "numeral b", symmetric, folded word_numeral_alt] for a b
 lemmas sbintr_num =
   word_sbin.norm_eq_iff [of "numeral a" "numeral b", symmetric, folded word_numeral_alt] for a b
 
 lemmas uint_div_alt = word_div_def [THEN trans [OF uint_cong int_word_uint]]
 lemmas uint_mod_alt = word_mod_def [THEN trans [OF uint_cong int_word_uint]]
 
 interpretation test_bit:
   td_ext
     "(!!) :: 'a::len word \<Rightarrow> nat \<Rightarrow> bool"
     set_bits
     "{f. \<forall>i. f i \<longrightarrow> i < LENGTH('a::len)}"
     "(\<lambda>h i. h i \<and> i < LENGTH('a::len))"
   by standard (auto simp add: test_bit_word_eq bit_imp_le_length bit_set_bits_word_iff set_bits_bit_eq)
 
 lemmas td_nth = test_bit.td_thm
 
 lemma sints_subset:
   "m \<le> n \<Longrightarrow> sints m \<subseteq> sints n"
   apply (simp add: sints_num)
   apply clarsimp
   apply (rule conjI)
    apply (erule order_trans[rotated])
    apply simp
   apply (erule order_less_le_trans)
   apply simp
   done
 
 end
diff --git a/thys/Word_Lib/Word_Lemmas.thy b/thys/Word_Lib/Word_Lemmas.thy
--- a/thys/Word_Lib/Word_Lemmas.thy
+++ b/thys/Word_Lib/Word_Lemmas.thy
@@ -1,3224 +1,1899 @@
 (*
  * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section "Lemmas with Generic Word Length"
 
 theory Word_Lemmas
   imports
     Type_Syntax
     Signed_Division_Word
     Signed_Words
     More_Word
     Most_significant_bit
     Enumeration_Word
     Aligned
 begin
 
-text \<open>Lemmas about words\<close>
-
-lemma nth_bounded:
-  "\<lbrakk>(x :: 'a :: len word) !! n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
-  apply (rule ccontr)
-  apply (auto simp add: not_less test_bit_word_eq)
-  apply (meson bit_imp_le_length bit_uint_iff less_2p_is_upper_bits_unset test_bit_bin)
-  done
-
-lemma shiftl_mask_is_0[simp]:
-  "(x << n) AND mask n = 0"
-  for x :: \<open>'a::len word\<close>
-  apply (rule iffD1 [OF is_aligned_mask])
-  apply (rule is_aligned_shiftl_self)
-  done
-
-lemma is_aligned_addD1:
-  assumes al1: "is_aligned (x + y) n"
-  and     al2: "is_aligned (x::'a::len word) n"
-  shows "is_aligned y n"
-  using al2
-proof (rule is_aligned_get_word_bits)
-  assume "x = 0" then show ?thesis using al1 by simp
-next
-  assume nv: "n < LENGTH('a)"
-  from al1 obtain q1
-    where xy: "x + y = 2 ^ n * of_nat q1" and "q1 < 2 ^ (LENGTH('a) - n)"
-    by (rule is_alignedE)
-  moreover from al2 obtain q2
-    where x: "x = 2 ^ n * of_nat q2" and "q2 < 2 ^ (LENGTH('a) - n)"
-    by (rule is_alignedE)
-  ultimately have "y = 2 ^ n * (of_nat q1 - of_nat q2)"
-    by (simp add: field_simps)
-  then show ?thesis using nv by (simp add: is_aligned_mult_triv1)
-qed
-
-lemmas is_aligned_addD2 =
-       is_aligned_addD1[OF subst[OF add.commute,
-                                 of "%x. is_aligned x n" for n]]
-
-lemma is_aligned_add:
-  "\<lbrakk>is_aligned p n; is_aligned q n\<rbrakk> \<Longrightarrow> is_aligned (p + q) n"
-  by (simp add: is_aligned_mask mask_add_aligned)
-
-lemmas word_unat_Rep_inject1 = word_unat.Rep_inject[where y=1]
-lemmas unat_eq_1 = unat_eq_0 word_unat_Rep_inject1[simplified]
-
-
-lemma rshift_sub_mask_eq:
-  "(a >> (size a - b)) AND mask b = a >> (size a - b)"
-  for a :: \<open>'a::len word\<close>
-  using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
-  apply (cases "b < size a")
-   apply simp
-  apply (simp add: linorder_not_less mask_eq_decr_exp word_size
-                   p2_eq_0[THEN iffD2])
-  done
-
-lemma shiftl_shiftr3:
-  "b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) AND mask (size a - c)"
-  for a :: \<open>'a::len word\<close>
-  apply (cases "b = c")
-   apply (simp add: shiftl_shiftr1)
-  apply (simp add: shiftl_shiftr2)
-  done
-
-lemma and_mask_shiftr_comm:
-  "m \<le> size w \<Longrightarrow> (w AND mask m) >> n = (w >> n) AND mask (m-n)"
-  for w :: \<open>'a::len word\<close>
-  by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)
-
-lemma and_mask_shiftl_comm:
-  "m+n \<le> size w \<Longrightarrow> (w AND mask m) << n = (w << n) AND mask (m+n)"
-  for w :: \<open>'a::len word\<close>
-  by (simp add: and_mask word_size shiftl_shiftl) (simp add: shiftl_shiftr1)
-
-lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
-  for x :: \<open>'a::len word\<close>
-  by (simp add: le_mask_iff shiftl_shiftr3)
-
-lemma and_not_mask_twice:
-  "(w AND NOT (mask n)) AND NOT (mask m) = w AND NOT (mask (max m n))"
-  for w :: \<open>'a::len word\<close>
-  apply (simp add: and_not_mask)
-  apply (case_tac "n<m";
-         simp add: shiftl_shiftr2 shiftl_shiftr1 not_less max_def shiftr_shiftr shiftl_shiftl)
-   apply (cut_tac and_mask_shiftr_comm [where w=w and m="size w" and n=m, simplified,symmetric])
-   apply (simp add: word_size mask_eq_decr_exp)
-  apply (cut_tac and_mask_shiftr_comm [where w=w and m="size w" and n=n, simplified,symmetric])
-  apply (simp add: word_size mask_eq_decr_exp)
-  done
-
-lemma word_less_cases:
-  "x < y \<Longrightarrow> x = y - 1 \<or> x < y - (1 ::'a::len word)"
-  apply (drule word_less_sub_1)
-  apply (drule order_le_imp_less_or_eq)
-  apply auto
-  done
-
-lemma eq_eqI:
-  "a = b \<Longrightarrow> (a = x) = (b = x)"
-  by simp
-
-lemma mask_and_mask:
-  "mask a AND mask b = (mask (min a b) :: 'a::len word)"
-  by (simp flip: take_bit_eq_mask ac_simps)
-
-lemma mask_eq_0_eq_x:
-  "(x AND w = 0) = (x AND NOT w = x)"
-  for x w :: \<open>'a::len word\<close>
-  using word_plus_and_or_coroll2[where x=x and w=w]
-  by auto
-
-lemma mask_eq_x_eq_0:
-  "(x AND w = x) = (x AND NOT w = 0)"
-  for x w :: \<open>'a::len word\<close>
-  using word_plus_and_or_coroll2[where x=x and w=w]
-  by auto
-
-lemma compl_of_1: "NOT 1 = (-2 :: 'a :: len word)"
-  by (fact not_one)
-
-lemma split_word_eq_on_mask:
-  "(x = y) = (x AND m = y AND m \<and> x AND NOT m = y AND NOT m)"
-  for x y m :: \<open>'a::len word\<close>
-  apply transfer
-  apply (simp add: bit_eq_iff)
-  apply (auto simp add: bit_simps ac_simps)
-  done
-
-lemma map2_Cons_2_3:
-  "(map2 f xs (y # ys) = (z # zs)) = (\<exists>x xs'. xs = x # xs' \<and> f x y = z \<and> map2 f xs' ys = zs)"
-  by (case_tac xs, simp_all)
-
-lemma map2_xor_replicate_False:
-  "map2 (\<lambda>x y. x \<longleftrightarrow> \<not> y) xs (replicate n False) = take n xs"
-  apply (induct xs arbitrary: n, simp)
-  apply (case_tac n; simp)
-  done
-
-lemma word_and_1_shiftl:
-  "x AND (1 << n) = (if x !! n then (1 << n) else 0)" for x :: "'a :: len word"
-  apply (rule bit_word_eqI; transfer)
-  apply (auto simp add: bit_simps not_le ac_simps)
-  done
-
-lemmas word_and_1_shiftls'
-    = word_and_1_shiftl[where n=0]
-      word_and_1_shiftl[where n=1]
-      word_and_1_shiftl[where n=2]
-
-lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]
-
-lemma word_and_mask_shiftl:
-  "x AND (mask n << m) = ((x >> m) AND mask n) << m"
-  for x :: \<open>'a::len word\<close>
-  apply (rule bit_word_eqI; transfer)
-  apply (auto simp add: bit_simps not_le ac_simps)
-  done
-
-lemma plus_Collect_helper:
-  "(+) x ` {xa. P (xa :: 'a :: len word)} = {xa. P (xa - x)}"
-  by (fastforce simp add: image_def)
-
-lemma plus_Collect_helper2:
-  "(+) (- x) ` {xa. P (xa :: 'a :: len word)} = {xa. P (x + xa)}"
-  using plus_Collect_helper [of "- x" P] by (simp add: ac_simps)
-
-lemma word_FF_is_mask:
-  "0xFF = (mask 8 :: 'a::len word)"
-  by (simp add: mask_eq_decr_exp)
-
-lemma word_1FF_is_mask:
-  "0x1FF = (mask 9 :: 'a::len word)"
-  by (simp add: mask_eq_decr_exp)
-
-lemma ucast_of_nat_small:
-  "x < 2 ^ LENGTH('a) \<Longrightarrow> ucast (of_nat x :: 'a :: len word) = (of_nat x :: 'b :: len word)"
-  apply (rule sym, subst word_unat.inverse_norm)
-  apply (simp add: ucast_eq of_nat_nat[symmetric] take_bit_eq_mod)
-  done
-
-lemma word_le_make_less:
-  fixes x :: "'a :: len word"
-  shows "y \<noteq> -1 \<Longrightarrow> (x \<le> y) = (x < (y + 1))"
-  apply safe
-  apply (erule plus_one_helper2)
-  apply (simp add: eq_diff_eq[symmetric])
-  done
-
-lemmas finite_word = finite [where 'a="'a::len word"]
-
-lemma word_to_1_set:
-  "{0 ..< (1 :: 'a :: len word)} = {0}"
-  by fastforce
-
-lemma range_subset_eq2:
-  "{a :: 'a :: len word .. b} \<noteq> {} \<Longrightarrow> ({a .. b} \<subseteq> {c .. d}) = (c \<le> a \<and> b \<le> d)"
-  by simp
-
-lemma word_leq_minus_one_le:
-  fixes x :: "'a::len word"
-  shows "\<lbrakk>y \<noteq> 0; x \<le> y - 1 \<rbrakk> \<Longrightarrow> x < y"
-  using le_m1_iff_lt word_neq_0_conv by blast
-
-lemma word_count_from_top:
-  "n \<noteq> 0 \<Longrightarrow> {0 ..< n :: 'a :: len word} = {0 ..< n - 1} \<union> {n - 1}"
-  apply (rule set_eqI, rule iffI)
-   apply simp
-   apply (drule word_le_minus_one_leq)
-   apply (rule disjCI)
-   apply simp
-  apply simp
-  apply (erule word_leq_minus_one_le)
-  apply fastforce
-  done
-
-lemma word_minus_one_le_leq:
-  "\<lbrakk> x - 1 < y \<rbrakk> \<Longrightarrow> x \<le> (y :: 'a :: len word)"
-  apply (cases "x = 0")
-   apply simp
-  apply (simp add: word_less_nat_alt word_le_nat_alt)
-  apply (subst(asm) unat_minus_one)
-   apply (simp add: word_less_nat_alt)
-  apply (cases "unat x")
-   apply (simp add: unat_eq_zero)
-  apply arith
-  done
-
-lemma word_div_less:
-  "m < n \<Longrightarrow> m div n = 0" for m :: "'a :: len word"
-  by (simp add: unat_mono word_arith_nat_defs(6))
-
-lemma word_must_wrap:
-  "\<lbrakk> x \<le> n - 1; n \<le> x \<rbrakk> \<Longrightarrow> n = (0 :: 'a :: len word)"
-  using dual_order.trans sub_wrap word_less_1 by blast
-
-lemma range_subset_card:
-  "\<lbrakk> {a :: 'a :: len word .. b} \<subseteq> {c .. d}; b \<ge> a \<rbrakk> \<Longrightarrow> d \<ge> c \<and> d - c \<ge> b - a"
-  using word_sub_le word_sub_mono by fastforce
-
-lemma less_1_simp:
-  "n - 1 < m = (n \<le> (m :: 'a :: len word) \<and> n \<noteq> 0)"
-  by unat_arith
-
-lemma nat_mod_power_lem:
-  fixes a :: nat
-  shows "1 < a \<Longrightarrow> a ^ n mod a ^ m = (if m \<le> n then 0 else a ^ n)"
-  apply (clarsimp)
-  apply (clarsimp simp add: le_iff_add power_add)
-  done
-
-lemma word_power_mod_div:
-  fixes x :: "'a::len word"
-  shows "\<lbrakk> n < LENGTH('a); m < LENGTH('a)\<rbrakk>
-  \<Longrightarrow> x mod 2 ^ n div 2 ^ m = x div 2 ^ m mod 2 ^ (n - m)"
-  apply (simp add: word_arith_nat_div unat_mod power_mod_div)
-  apply (subst unat_arith_simps(3))
-  apply (subst unat_mod)
-  apply (subst unat_of_nat)+
-  apply (simp add: mod_mod_power min.commute)
-  done
-
-lemma word_range_minus_1':
-  fixes a :: "'a :: len word"
-  shows "a \<noteq> 0 \<Longrightarrow> {a - 1<..b} = {a..b}"
-  by (simp add: greaterThanAtMost_def atLeastAtMost_def greaterThan_def atLeast_def less_1_simp)
-
-lemma word_range_minus_1:
-  fixes a :: "'a :: len word"
-  shows "b \<noteq> 0 \<Longrightarrow> {a..b - 1} = {a..<b}"
-  apply (simp add: atLeastLessThan_def atLeastAtMost_def atMost_def lessThan_def)
-  apply (rule arg_cong [where f = "\<lambda>x. {a..} \<inter> x"])
-  apply rule
-   apply clarsimp
-   apply (erule contrapos_pp)
-   apply (simp add: linorder_not_less linorder_not_le word_must_wrap)
-  apply (clarsimp)
-  apply (drule word_le_minus_one_leq)
-  apply (auto simp: word_less_sub_1)
-  done
-
-lemma ucast_nat_def:
-  "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> 'b :: len word) x"
-  by transfer simp
-
-lemma i_hate_words_helper:
-  "i \<le> (j - k :: nat) \<Longrightarrow> i \<le> j"
-  by simp
-
-lemma i_hate_words:
-  "unat (a :: 'a word) \<le> unat (b :: 'a :: len word) - Suc 0
-    \<Longrightarrow> a \<noteq> -1"
-  apply (frule i_hate_words_helper)
-  apply (subst(asm) word_le_nat_alt[symmetric])
-  apply (clarsimp simp only: word_minus_one_le)
-  apply (simp only: linorder_not_less[symmetric])
-  apply (erule notE)
-  apply (rule diff_Suc_less)
-  apply (subst neq0_conv[symmetric])
-  apply (subst unat_eq_0)
-  apply (rule notI, drule arg_cong[where f="(+) 1"])
-  apply simp
-  done
-
-lemma overflow_plus_one_self:
-  "(1 + p \<le> p) = (p = (-1 :: 'a :: len word))"
-  apply rule
-  apply (rule ccontr)
-   apply (drule plus_one_helper2)
-   apply (rule notI)
-   apply (drule arg_cong[where f="\<lambda>x. x - 1"])
-   apply simp
-   apply (simp add: field_simps)
-  apply simp
-  done
-
-lemma plus_1_less:
-  "(x + 1 \<le> (x :: 'a :: len word)) = (x = -1)"
-  apply (rule iffI)
-   apply (rule ccontr)
-   apply (cut_tac plus_one_helper2[where x=x, OF order_refl])
-    apply simp
-   apply clarsimp
-   apply (drule arg_cong[where f="\<lambda>x. x - 1"])
-   apply simp
-  apply simp
-  done
-
-lemma pos_mult_pos_ge:
-  "[|x > (0::int); n>=0 |] ==> n * x >= n*1"
-  apply (simp only: mult_left_mono)
-  done
-
-lemma If_eq_obvious:
-  "x \<noteq> z \<Longrightarrow> ((if P then x else y) = z) = (\<not> P \<and> y = z)"
-  by simp
-
-lemma Some_to_the:
-  "v = Some x \<Longrightarrow> x = the v"
-  by simp
-
-lemma dom_if_Some:
-  "dom (\<lambda>x. if P x then Some (f x) else g x) = {x. P x} \<union> dom g"
-  by fastforce
-
-lemma dom_insert_absorb:
-  "x \<in> dom f \<Longrightarrow> insert x (dom f) = dom f" by auto
-
-lemma emptyE2:
-  "\<lbrakk> S = {}; x \<in> S \<rbrakk> \<Longrightarrow> P"
-  by simp
-
-lemma mod_div_equality_div_eq:
-  "a div b * b = (a - (a mod b) :: int)"
-  by (simp add: field_simps)
-
-lemma zmod_helper:
-  "n mod m = k \<Longrightarrow> ((n :: int) + a) mod m = (k + a) mod m"
-  by (metis add.commute mod_add_right_eq)
-
-lemma int_div_sub_1:
-  "\<lbrakk> m \<ge> 1 \<rbrakk> \<Longrightarrow> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)"
-  apply (subgoal_tac "m = 0 \<or> (n - (1 :: int)) div m = (if m dvd n then (n div m) - 1 else n div m)")
-   apply fastforce
-  apply (subst mult_cancel_right[symmetric])
-  apply (simp only: left_diff_distrib split: if_split)
-  apply (simp only: mod_div_equality_div_eq)
-  apply (clarsimp simp: field_simps)
-  apply (clarsimp simp: dvd_eq_mod_eq_0)
-  apply (cases "m = 1")
-   apply simp
-  apply (subst mod_diff_eq[symmetric], simp add: zmod_minus1)
-  apply clarsimp
-  apply (subst diff_add_cancel[where b=1, symmetric])
-  apply (subst mod_add_eq[symmetric])
-  apply (simp add: field_simps)
-  apply (rule mod_pos_pos_trivial)
-   apply (subst add_0_right[where a=0, symmetric])
-   apply (rule add_mono)
-    apply simp
-   apply simp
-  apply (cases "(n - 1) mod m = m - 1")
-   apply (drule zmod_helper[where a=1])
-   apply simp
-  apply (subgoal_tac "1 + (n - 1) mod m \<le> m")
-   apply simp
-  apply (subst field_simps, rule zless_imp_add1_zle)
-  apply simp
-  done
-
-lemma ptr_add_image_multI:
-  "\<lbrakk> \<And>x y. (x * val = y * val') = (x * val'' = y); x * val'' \<in> S \<rbrakk> \<Longrightarrow>
-     ptr_add ptr (x * val) \<in> (\<lambda>p. ptr_add ptr (p * val')) ` S"
-  apply (simp add: image_def)
-  apply (erule rev_bexI)
-  apply (rule arg_cong[where f="ptr_add ptr"])
-  apply simp
-  done
-
-lemma shift_times_fold:
-  "(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
-  by (simp add: shiftl_t2n ac_simps power_add)
-
-lemma word_plus_strict_mono_right:
-  fixes x :: "'a :: len word"
-  shows "\<lbrakk>y < z; x \<le> x + z\<rbrakk> \<Longrightarrow> x + y < x + z"
-  by unat_arith
-
-lemma replicate_minus:
-  "k < n \<Longrightarrow> replicate n False = replicate (n - k) False @ replicate k False"
-  by (subst replicate_add [symmetric]) simp
-
-lemmas map_prod_split_imageI'
-  = map_prod_imageI[where f="case_prod f" and g="case_prod g"
-                    and a="(a, b)" and b="(c, d)" for a b c d f g]
-lemmas map_prod_split_imageI = map_prod_split_imageI'[simplified]
-
-lemma word_div_mult:
-  "0 < c \<Longrightarrow> a < b * c \<Longrightarrow> a div c < b" for a b c :: "'a::len word"
-  by (rule classical)
-     (use div_to_mult_word_lt [of b a c] in
-      \<open>auto simp add: word_less_nat_alt word_le_nat_alt unat_div\<close>)
-
-lemma word_less_power_trans_ofnat:
-  "\<lbrakk>n < 2 ^ (m - k); k \<le> m; m < LENGTH('a)\<rbrakk>
-   \<Longrightarrow> of_nat n * 2 ^ k < (2::'a::len word) ^ m"
-  apply (subst mult.commute)
-  apply (rule word_less_power_trans)
-    apply (simp_all add: word_less_nat_alt less_le_trans take_bit_eq_mod)
-  done
-
-lemma word_1_le_power:
-  "n < LENGTH('a) \<Longrightarrow> (1 :: 'a :: len word) \<le> 2 ^ n"
-  by (rule inc_le[where i=0, simplified], erule iffD2[OF p2_gt_0])
-
-lemma of_bool_nth:
-  "of_bool (x !! v) = (x >> v) AND 1"
-  for x :: \<open>'a::len word\<close>
-  by (simp add: test_bit_word_eq shiftr_word_eq bit_eq_iff)
-    (auto simp add: bit_1_iff bit_and_iff bit_drop_bit_eq intro: ccontr)
-
-lemma unat_1_0:
-  "1 \<le> (x::'a::len word) = (0 < unat x)"
-  by (auto simp add: word_le_nat_alt)
-
-lemma x_less_2_0_1':
-  fixes x :: "'a::len word"
-  shows "\<lbrakk>LENGTH('a) \<noteq> 1; x < 2\<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
-  apply (cases \<open>2 \<le> LENGTH('a)\<close>)
-  apply simp_all
-  apply transfer
-  apply auto
-  apply (metis add.commute add.right_neutral even_two_times_div_two mod_div_trivial mod_pos_pos_trivial mult.commute mult_zero_left not_less not_take_bit_negative odd_two_times_div_two_succ) 
-  done
-
-lemmas word_add_le_iff2 = word_add_le_iff [folded no_olen_add_nat]
-
-lemma of_nat_power:
-  shows "\<lbrakk> p < 2 ^ x; x < len_of TYPE ('a) \<rbrakk> \<Longrightarrow> of_nat p < (2 :: 'a :: len word) ^ x"
-  apply (rule order_less_le_trans)
-   apply (rule of_nat_mono_maybe)
-    apply (erule power_strict_increasing)
-    apply simp
-   apply assumption
-  apply (simp add: word_unat_power del: of_nat_power)
-  done
-
-lemma of_nat_n_less_equal_power_2:
-  "n < LENGTH('a::len) \<Longrightarrow> ((of_nat n)::'a word) < 2 ^ n"
-  apply (induct n)
-   apply clarsimp
-  apply clarsimp
-  apply (metis of_nat_power n_less_equal_power_2 of_nat_Suc power_Suc)
-  done
-
-lemma eq_mask_less:
-  fixes w :: "'a::len word"
-  assumes eqm: "w = w AND mask n"
-  and      sz: "n < len_of TYPE ('a)"
-  shows "w < (2::'a word) ^ n"
-  by (subst eqm, rule and_mask_less' [OF sz])
-
-lemma of_nat_mono_maybe':
-  fixes Y :: "nat"
-  assumes xlt: "x < 2 ^ len_of TYPE ('a)"
-  assumes ylt: "y < 2 ^ len_of TYPE ('a)"
-  shows   "(y < x) = (of_nat y < (of_nat x :: 'a :: len word))"
-  apply (subst word_less_nat_alt)
-  apply (subst unat_of_nat)+
-  apply (subst mod_less)
-   apply (rule ylt)
-  apply (subst mod_less)
-   apply (rule xlt)
-  apply simp
-  done
-
-lemma shiftr_mask_eq:
-  "(x >> n) AND mask (size x - n) = x >> n" for x :: "'a :: len word"
-  apply (simp flip: take_bit_eq_mask)
-  apply transfer
-  apply (simp add: take_bit_drop_bit)
-  done
-
-lemma shiftr_mask_eq':
-  "m = (size x - n) \<Longrightarrow> (x >> n) AND mask m = x >> n" for x :: "'a :: len word"
-  by (simp add: shiftr_mask_eq)
-
-lemma dom_if:
-  "dom (\<lambda>a. if a \<in> addrs then Some (f a) else g a)  = addrs \<union> dom g"
-  by (auto simp: dom_def split: if_split)
-
-lemma of_nat_mono_maybe_le:
-  "\<lbrakk>x < 2 ^ LENGTH('a); y < 2 ^ LENGTH('a)\<rbrakk> \<Longrightarrow>
-  (y \<le> x) = ((of_nat y :: 'a :: len word) \<le> of_nat x)"
-  apply (clarsimp simp: le_less)
-  apply (rule disj_cong)
-   apply (rule of_nat_mono_maybe', assumption+)
-  apply (simp add: word_unat.norm_eq_iff [symmetric])
-  done
-
-lemma mask_AND_NOT_mask:
-  "(w AND NOT (mask n)) AND mask n = 0"
-  for w :: \<open>'a::len word\<close>
-  by (rule bit_word_eqI) (simp add: bit_simps)
-
-lemma AND_NOT_mask_plus_AND_mask_eq:
-  "(w AND NOT (mask n)) + (w AND mask n) = w"
-  for w :: \<open>'a::len word\<close>
-  apply (subst disjunctive_add)
-  apply (auto simp add: bit_simps)
-  apply (rule bit_word_eqI)
-  apply (auto simp add: bit_simps)
-  done
-
-lemma mask_eqI:
-  fixes x :: "'a :: len word"
-  assumes m1: "x AND mask n = y AND mask n"
-  and     m2: "x AND NOT (mask n) = y AND NOT (mask n)"
-  shows "x = y"
-proof (subst bang_eq, rule allI)
-  fix m
-
-  show "x !! m = y !! m"
-  proof (cases "m < n")
-    case True
-    then have "x !! m = ((x AND mask n) !! m)"
-      by (simp add: word_size test_bit_conj_lt)
-    also have "\<dots> = ((y AND mask n) !! m)" using m1 by simp
-    also have "\<dots> = y !! m" using True
-      by (simp add: word_size test_bit_conj_lt)
-    finally show ?thesis .
-  next
-    case False
-    then have "x !! m = ((x AND NOT (mask n)) !! m)"
-      by (simp add: neg_mask_test_bit test_bit_conj_lt)
-    also have "\<dots> = ((y AND NOT (mask n)) !! m)" using m2 by simp
-    also have "\<dots> = y !! m" using False
-      by (simp add: neg_mask_test_bit test_bit_conj_lt)
-    finally show ?thesis .
-  qed
-qed
-
-lemma nat_less_power_trans2:
-  fixes n :: nat
-  shows "\<lbrakk>n < 2 ^ (m - k); k \<le> m\<rbrakk> \<Longrightarrow> n * 2 ^ k  < 2 ^ m"
-  by (subst mult.commute, erule (1) nat_less_power_trans)
-
-lemma nat_move_sub_le: "(a::nat) + b \<le> c \<Longrightarrow> a \<le> c - b" by arith
-
-lemma neq_0_no_wrap:
-  fixes x :: "'a :: len word"
-  shows "\<lbrakk> x \<le> x + y; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
-  by clarsimp
-
-lemma plus_minus_one_rewrite:
-  "v + (- 1 :: ('a :: {ring, one, uminus})) \<equiv> v - 1"
-  by (simp add: field_simps)
-
-lemma power_minus_is_div:
-  "b \<le> a \<Longrightarrow> (2 :: nat) ^ (a - b) = 2 ^ a div 2 ^ b"
-  apply (induct a arbitrary: b)
-   apply simp
-  apply (erule le_SucE)
-   apply (clarsimp simp:Suc_diff_le le_iff_add power_add)
-  apply simp
-  done
-
-lemma two_pow_div_gt_le:
-  "v < 2 ^ n div (2 ^ m :: nat) \<Longrightarrow> m \<le> n"
-  by (clarsimp dest!: less_two_pow_divD)
-
-lemma unatSuc2:
-  fixes n :: "'a :: len word"
-  shows "n + 1 \<noteq> 0 \<Longrightarrow> unat (n + 1) = Suc (unat n)"
-  by (simp add: add.commute unatSuc)
-
-lemma word_of_nat_le:
-  "n \<le> unat x \<Longrightarrow> of_nat n \<le> x"
-  apply (simp add: word_le_nat_alt unat_of_nat)
-  apply (erule order_trans[rotated])
-  apply (simp add: take_bit_eq_mod)
-  done
-
-lemma word_unat_less_le:
-   "a \<le> of_nat b \<Longrightarrow> unat a \<le> b"
-   by (metis eq_iff le_cases le_unat_uoi word_of_nat_le)
-
-lemma and_eq_0_is_nth:
-  fixes x :: "'a :: len word"
-  shows "y = 1 << n \<Longrightarrow> ((x AND y) = 0) = (\<not> (x !! n))"
-  apply safe
-   apply (drule_tac u="(x AND (1 << n))" and x=n in word_eqD)
-   apply (simp add: nth_w2p)
-   apply (simp add: test_bit_bin)
-  apply (rule bit_word_eqI)
-  apply (auto simp add: bit_simps test_bit_eq_bit)
-  done
-
-lemmas arg_cong_Not = arg_cong [where f=Not]
-lemmas and_neq_0_is_nth = arg_cong_Not [OF and_eq_0_is_nth, simplified]
-
-lemma nth_is_and_neq_0:
-  "(x::'a::len word) !! n = (x AND 2 ^ n \<noteq> 0)"
-  by (subst and_neq_0_is_nth; rule refl)
-
-lemma mask_Suc_0 : "mask (Suc 0) = (1 :: 'a::len word)"
-  by (simp add: mask_eq_decr_exp)
-
-lemma ucast_ucast_add:
-  fixes x :: "'a :: len word"
-  fixes y :: "'b :: len word"
-  shows
-  "LENGTH('b) \<ge> LENGTH('a) \<Longrightarrow>
-    ucast (ucast x + y) = x + ucast y"
-  apply (rule word_unat.Rep_eqD)
-  apply (simp add: unat_ucast unat_word_ariths mod_mod_power
-                   min.absorb2 unat_of_nat)
-  apply (subst mod_add_left_eq[symmetric])
-  apply (simp add: mod_mod_power min.absorb2)
-  apply (subst mod_add_right_eq)
-  apply simp
-  done
-
-lemma word_shift_zero:
-  "\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
-  apply (rule ccontr)
-  apply (drule (2) word_shift_nonzero)
-  apply simp
-  done
-
-lemma bool_mask':
-  fixes x :: "'a :: len word"
-  shows "2 < LENGTH('a) \<Longrightarrow> (0 < x AND 1) = (x AND 1 = 1)"
-  by (simp add: and_one_eq mod_2_eq_odd)
-
-lemma scast_eq_ucast:
-  "\<not> msb x \<Longrightarrow> scast x = ucast x"
-  apply (cases \<open>LENGTH('a)\<close>)
-  apply simp
-  apply (rule bit_word_eqI)
-  apply (auto simp add: bit_signed_iff bit_unsigned_iff min_def msb_word_eq)
-  apply (erule notE)
-  apply (metis le_less_Suc_eq test_bit_bin test_bit_word_eq)
-  done
-
-lemma lt1_neq0:
-  fixes x :: "'a :: len word"
-  shows "(1 \<le> x) = (x \<noteq> 0)" by unat_arith
-
-lemma word_plus_one_nonzero:
-  fixes x :: "'a :: len word"
-  shows "\<lbrakk>x \<le> x + y; y \<noteq> 0\<rbrakk> \<Longrightarrow> x + 1 \<noteq> 0"
-  apply (subst lt1_neq0 [symmetric])
-  apply (subst olen_add_eqv [symmetric])
-  apply (erule word_random)
-  apply (simp add: lt1_neq0)
-  done
-
-lemma word_sub_plus_one_nonzero:
-  fixes n :: "'a :: len word"
-  shows "\<lbrakk>n' \<le> n; n' \<noteq> 0\<rbrakk> \<Longrightarrow> (n - n') + 1 \<noteq> 0"
-  apply (subst lt1_neq0 [symmetric])
-  apply (subst olen_add_eqv [symmetric])
-  apply (rule word_random [where x' = n'])
-   apply simp
-   apply (erule word_sub_le)
-  apply (simp add: lt1_neq0)
-  done
-
-lemma word_le_minus_mono_right:
-  fixes x :: "'a :: len word"
-  shows "\<lbrakk> z \<le> y; y \<le> x; z \<le> x \<rbrakk> \<Longrightarrow> x - y \<le> x - z"
-  apply (rule word_sub_mono)
-     apply simp
-    apply assumption
-   apply (erule word_sub_le)
-  apply (erule word_sub_le)
-  done
-
-lemma drop_append_miracle:
-  "n = length xs \<Longrightarrow> drop n (xs @ ys) = ys"
-  by simp
-
-lemma foldr_does_nothing_to_xf:
-  "\<lbrakk> \<And>x s. x \<in> set xs \<Longrightarrow> xf (f x s) = xf s \<rbrakk> \<Longrightarrow> xf (foldr f xs s) = xf s"
-  by (induct xs, simp_all)
-
-lemma nat_less_mult_monoish: "\<lbrakk> a < b; c < (d :: nat) \<rbrakk> \<Longrightarrow> (a + 1) * (c + 1) <= b * d"
-  apply (drule Suc_leI)+
-  apply (drule(1) mult_le_mono)
-  apply simp
-  done
-
-lemma word_0_sle_from_less:
-  \<open>0 \<le>s x\<close> if \<open>x < 2 ^ (LENGTH('a) - 1)\<close> for x :: \<open>'a::len word\<close>
-  using that
-  apply transfer
-  apply (cases \<open>LENGTH('a)\<close>)
-   apply simp_all
-  apply (metis bit_take_bit_iff min_def nat_less_le not_less_eq take_bit_int_eq_self_iff take_bit_take_bit)
-  done
-
-lemma ucast_sub_ucast:
-  fixes x :: "'a::len word"
-  assumes "y \<le> x"
-  assumes T: "LENGTH('a) \<le> LENGTH('b)"
-  shows "ucast (x - y) = (ucast x - ucast y :: 'b::len word)"
-proof -
-  from T
-  have P: "unat x < 2 ^ LENGTH('b)" "unat y < 2 ^ LENGTH('b)"
-    by (fastforce intro!: less_le_trans[OF unat_lt2p])+
-  then show ?thesis
-    by (simp add: unat_arith_simps unat_ucast assms[simplified unat_arith_simps])
-qed
-
-lemma word_1_0:
-  "\<lbrakk>a + (1::('a::len) word) \<le> b; a < of_nat x\<rbrakk> \<Longrightarrow> a < b"
-  apply transfer
-  apply (subst (asm) take_bit_incr_eq)
-   apply (auto simp add: diff_less_eq)
-  using take_bit_int_less_exp le_less_trans by blast
-
-lemma unat_of_nat_less:"\<lbrakk> a < b; unat b = c \<rbrakk> \<Longrightarrow> a < of_nat c"
-  by fastforce
-
-lemma word_le_plus_1: "\<lbrakk> (y::('a::len) word) < y + n; a < n \<rbrakk> \<Longrightarrow> y + a \<le> y + a + 1"
-  by unat_arith
-
-lemma word_le_plus:"\<lbrakk>(a::('a::len) word) < a + b; c < b\<rbrakk> \<Longrightarrow> a \<le> a + c"
-by (metis order_less_imp_le word_random)
-
-(*
- * Basic signed arithemetic properties.
- *)
-
-lemma sint_minus1 [simp]: "(sint x = -1) = (x = -1)"
-  by (metis sint_n1 word_sint.Rep_inverse')
-
-lemma sint_0 [simp]: "(sint x = 0) = (x = 0)"
-  by (metis sint_0 word_sint.Rep_inverse')
-
-(* It is not always that case that "sint 1 = 1", because of 1-bit word sizes.
- * This lemma produces the different cases. *)
-lemma sint_1_cases:
-  P if \<open>\<lbrakk> len_of TYPE ('a::len) = 1; (a::'a word) = 0; sint a = 0 \<rbrakk> \<Longrightarrow> P\<close>
-     \<open>\<lbrakk> len_of TYPE ('a) = 1; a = 1; sint (1 :: 'a word) = -1 \<rbrakk> \<Longrightarrow> P\<close>
-     \<open>\<lbrakk> len_of TYPE ('a) > 1; sint (1 :: 'a word) = 1 \<rbrakk> \<Longrightarrow> P\<close>
-proof (cases \<open>LENGTH('a) = 1\<close>)
-  case True
-  then have \<open>a = 0 \<or> a = 1\<close>
-    by transfer auto
-  with True that show ?thesis
-    by auto
-next
-  case False
-  with that show ?thesis
-    by (simp add: less_le Suc_le_eq)
-qed
-
-lemma sint_int_min:
-  "sint (- (2 ^ (LENGTH('a) - Suc 0)) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
-  apply (subst word_sint.Abs_inverse' [where r="- (2 ^ (LENGTH('a) - Suc 0))"])
-    apply (clarsimp simp: sints_num)
-   apply (clarsimp simp: wi_hom_syms word_of_int_2p)
-  apply clarsimp
-  done
-
-lemma sint_int_max_plus_1:
-  "sint (2 ^ (LENGTH('a) - Suc 0) :: ('a::len) word) = - (2 ^ (LENGTH('a) - Suc 0))"
-  apply (cases \<open>LENGTH('a)\<close>)
-   apply simp_all
-  apply (subst word_of_int_2p [symmetric])
-  apply (subst int_word_sint)
-  apply simp
-  done
-
-lemma sbintrunc_eq_in_range:
-  "(sbintrunc n x = x) = (x \<in> range (sbintrunc n))"
-  "(x = sbintrunc n x) = (x \<in> range (sbintrunc n))"
-  apply (simp_all add: image_def)
-  apply (metis sbintrunc_sbintrunc)+
-  done
-
-lemma sbintrunc_If:
-  "- 3 * (2 ^ n) \<le> x \<and> x < 3 * (2 ^ n)
-    \<Longrightarrow> sbintrunc n x = (if x < - (2 ^ n) then x + 2 * (2 ^ n)
-        else if x \<ge> 2 ^ n then x - 2 * (2 ^ n) else x)"
-  apply (simp add: no_sbintr_alt2, safe)
-   apply (simp add: mod_pos_geq)
-  apply (subst mod_add_self1[symmetric], simp)
-  done
-
-lemma signed_arith_eq_checks_to_ord:
-  "(sint a + sint b = sint (a + b ))
-    = ((a <=s a + b) = (0 <=s b))"
-  "(sint a - sint b = sint (a - b ))
-    = ((0 <=s a - b) = (b <=s a))"
-  "(- sint a = sint (- a)) = (0 <=s (- a) = (a <=s 0))"
-  using sint_range'[where x=a] sint_range'[where x=b]
-  by (simp_all add: sint_word_ariths word_sle_eq word_sless_alt sbintrunc_If)
-
-(* Signed word arithmetic overflow constraints. *)
-
-lemma signed_arith_ineq_checks_to_eq:
-  "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
-    = (sint a + sint b = sint (a + b ))"
-  "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
-    = (sint a - sint b = sint (a - b))"
-  "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
-    = ((- sint a) = sint (- a))"
-  "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
-    = (sint a * sint b = sint (a * b))"
-  "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
-    = (sint a sdiv sint b = sint (a sdiv b))"
-  "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
-    = (sint a smod sint b = sint (a smod b))"
-  by (auto simp: sint_word_ariths word_size signed_div_arith signed_mod_arith
-                    sbintrunc_eq_in_range range_sbintrunc)
-
-lemma signed_arith_sint:
-  "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
-    \<Longrightarrow> sint (a + b) = (sint a + sint b)"
-  "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
-    \<Longrightarrow> sint (a - b) = (sint a - sint b)"
-  "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
-    \<Longrightarrow> sint (- a) = (- sint a)"
-  "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
-    \<Longrightarrow> sint (a * b) = (sint a * sint b)"
-  "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
-    \<Longrightarrow> sint (a sdiv b) = (sint a sdiv sint b)"
-  "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
-    \<Longrightarrow> sint (a smod b) = (sint a smod sint b)"
-  by (subst (asm) signed_arith_ineq_checks_to_eq; simp)+
-
-lemma signed_mult_eq_checks_double_size:
-  assumes mult_le: "(2 ^ (len_of TYPE ('a) - 1) + 1) ^ 2 \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
-           and le: "2 ^ (LENGTH('a) - 1) \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
-  shows "(sint (a :: 'a :: len word) * sint b = sint (a * b))
-       = (scast a * scast b = (scast (a * b) :: 'b :: len word))"
-proof -
-  have P: "sbintrunc (size a - 1) (sint a * sint b) \<in> range (sbintrunc (size a - 1))"
-    by simp
-
-  have abs: "!! x :: 'a word. abs (sint x) < 2 ^ (size a - 1) + 1"
-    apply (cut_tac x=x in sint_range')
-    apply (simp add: abs_le_iff word_size)
-    done
-  have abs_ab: "abs (sint a * sint b) < 2 ^ (LENGTH('b) - 1)"
-    using abs_mult_less[OF abs[where x=a] abs[where x=b]] mult_le
-    by (simp add: abs_mult power2_eq_square word_size)
-  define r s where \<open>r = LENGTH('a) - 1\<close> \<open>s = LENGTH('b) - 1\<close>
-  then have \<open>LENGTH('a) = Suc r\<close> \<open>LENGTH('b) = Suc s\<close>
-    \<open>size a = Suc r\<close> \<open>size b = Suc r\<close>
-    by (simp_all add: word_size)
-  then show ?thesis
-    using P[unfolded range_sbintrunc] abs_ab le
-    apply clarsimp
-    apply (transfer fixing: r s)
-    apply (auto simp add: signed_take_bit_int_eq_self simp flip: signed_take_bit_eq_iff_take_bit_eq)
-    done
-qed
-
-(* Properties about signed division. *)
-
-lemma int_sdiv_simps [simp]:
-    "(a :: int) sdiv 1 = a"
-    "(a :: int) sdiv 0 = 0"
-    "(a :: int) sdiv -1 = -a"
-  apply (auto simp: signed_divide_int_def sgn_if)
-  done
-
-lemma sgn_div_eq_sgn_mult:
-    "a div b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) div b) = sgn (a * b)"
-  apply (clarsimp simp: sgn_if zero_le_mult_iff neg_imp_zdiv_nonneg_iff not_less)
-  apply (metis less_le mult_le_0_iff neg_imp_zdiv_neg_iff not_less pos_imp_zdiv_neg_iff zdiv_eq_0_iff)
-  done
-
-lemma sgn_sdiv_eq_sgn_mult:
-  "a sdiv b \<noteq> 0 \<Longrightarrow> sgn ((a :: int) sdiv b) = sgn (a * b)"
-  by (auto simp: signed_divide_int_def sgn_div_eq_sgn_mult sgn_mult)
-
-lemma int_sdiv_same_is_1 [simp]:
-    "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = a) = (b = 1)"
-  apply (rule iffI)
-   apply (clarsimp simp: signed_divide_int_def)
-   apply (subgoal_tac "b > 0")
-    apply (case_tac "a > 0")
-     apply (clarsimp simp: sgn_if)
-    apply (clarsimp simp: algebra_split_simps not_less)
-    apply (metis int_div_same_is_1 le_neq_trans minus_minus neg_0_le_iff_le neg_equal_0_iff_equal)
-   apply (case_tac "a > 0")
-    apply (case_tac "b = 0")
-     apply clarsimp
-    apply (rule classical)
-    apply (clarsimp simp: sgn_mult not_less)
-    apply (metis le_less neg_0_less_iff_less not_less_iff_gr_or_eq pos_imp_zdiv_neg_iff)
-   apply (rule classical)
-   apply (clarsimp simp: algebra_split_simps sgn_mult not_less sgn_if split: if_splits)
-   apply (metis antisym less_le neg_imp_zdiv_nonneg_iff)
-  apply (clarsimp simp: signed_divide_int_def sgn_if)
-  done
-
-lemma int_sdiv_negated_is_minus1 [simp]:
-    "a \<noteq> 0 \<Longrightarrow> ((a :: int) sdiv b = - a) = (b = -1)"
-  apply (clarsimp simp: signed_divide_int_def)
-  apply (rule iffI)
-   apply (subgoal_tac "b < 0")
-    apply (case_tac "a > 0")
-     apply (clarsimp simp: sgn_if algebra_split_simps not_less)
-    apply (case_tac "sgn (a * b) = -1")
-     apply (clarsimp simp: not_less algebra_split_simps)
-    apply (clarsimp simp: algebra_split_simps not_less)
-   apply (rule classical)
-   apply (case_tac "b = 0")
-    apply (clarsimp simp: not_less sgn_mult)
-   apply (case_tac "a > 0")
-    apply (clarsimp simp: not_less sgn_mult)
-    apply (metis less_le neg_less_0_iff_less not_less_iff_gr_or_eq pos_imp_zdiv_neg_iff)
-   apply (clarsimp simp: not_less sgn_mult)
-   apply (metis antisym_conv div_minus_right neg_imp_zdiv_nonneg_iff neg_le_0_iff_le not_less)
-  apply (clarsimp simp: sgn_if)
-  done
-
-lemma sdiv_int_range:
-    "(a :: int) sdiv b \<in> { - (abs a) .. (abs a) }"
-  apply (unfold signed_divide_int_def)
-  apply (subgoal_tac "(abs a) div (abs b) \<le> (abs a)")
-   apply (auto simp add: sgn_if not_less)
-      apply (metis le_less le_less_trans neg_equal_0_iff_equal neg_less_iff_less not_le pos_imp_zdiv_neg_iff)
-     apply (metis add.inverse_neutral div_int_pos_iff le_less neg_le_iff_le order_trans)
-    apply (metis div_minus_right le_less_trans neg_imp_zdiv_neg_iff neg_less_0_iff_less not_le)
-  using div_int_pos_iff apply fastforce
-  apply (metis abs_0_eq abs_ge_zero div_by_0 zdiv_le_dividend zero_less_abs_iff)
-  done
-
-lemma word_sdiv_div1 [simp]:
-    "(a :: ('a::len) word) sdiv 1 = a"
-  apply (rule sint_1_cases [where a=a])
-    apply (clarsimp simp: sdiv_word_def signed_divide_int_def)
-   apply (clarsimp simp: sdiv_word_def signed_divide_int_def simp del: sint_minus1)
-  apply (clarsimp simp: sdiv_word_def)
-  done
-
-lemma sdiv_int_div_0 [simp]:
-  "(x :: int) sdiv 0 = 0"
-  by (clarsimp simp: signed_divide_int_def)
-
-lemma sdiv_int_0_div [simp]:
-  "0 sdiv (x :: int) = 0"
-  by (clarsimp simp: signed_divide_int_def)
-
-lemma word_sdiv_div0 [simp]:
-    "(a :: ('a::len) word) sdiv 0 = 0"
-  apply (auto simp: sdiv_word_def signed_divide_int_def sgn_if)
-  done
-
-lemma word_sdiv_div_minus1 [simp]:
-    "(a :: ('a::len) word) sdiv -1 = -a"
-  apply (auto simp: sdiv_word_def signed_divide_int_def sgn_if)
-  done
-
-lemmas word_sdiv_0 = word_sdiv_div0
-
-lemma sdiv_word_min:
-    "- (2 ^ (size a - 1)) \<le> sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word)"
-  apply (clarsimp simp: word_size)
-  apply (cut_tac sint_range' [where x=a])
-  apply (cut_tac sint_range' [where x=b])
-  apply clarsimp
-  apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
-  apply (clarsimp simp: max_def abs_if split: if_split_asm)
-  done
-
-lemma sdiv_word_max:
-    "(sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word) < (2 ^ (size a - 1))) =
-          ((a \<noteq> - (2 ^ (size a - 1)) \<or> (b \<noteq> -1)))"
-    (is "?lhs = (\<not> ?a_int_min \<or> \<not> ?b_minus1)")
-proof (rule classical)
-  assume not_thesis: "\<not> ?thesis"
-
-  have not_zero: "b \<noteq> 0"
-    using not_thesis
-    by (clarsimp)
-
-  have result_range: "sint a sdiv sint b \<in> (sints (size a)) \<union> {2 ^ (size a - 1)}"
-    apply (cut_tac sdiv_int_range [where a="sint a" and b="sint b"])
-    apply (erule rev_subsetD)
-    using sint_range' [where x=a]  sint_range' [where x=b]
-    apply (auto simp: max_def abs_if word_size sints_num)
-    done
-
-  have result_range_overflow: "(sint a sdiv sint b = 2 ^ (size a - 1)) = (?a_int_min \<and> ?b_minus1)"
-    apply (rule iffI [rotated])
-     apply (clarsimp simp: signed_divide_int_def sgn_if word_size sint_int_min)
-    apply (rule classical)
-    apply (case_tac "?a_int_min")
-     apply (clarsimp simp: word_size sint_int_min)
-     apply (metis diff_0_right
-              int_sdiv_negated_is_minus1 minus_diff_eq minus_int_code(2)
-              power_eq_0_iff sint_minus1 zero_neq_numeral)
-    apply (subgoal_tac "abs (sint a) < 2 ^ (size a - 1)")
-     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
-     apply (clarsimp simp: word_size)
-    apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
-    apply (insert word_sint.Rep [where x="a"])[1]
-    apply (clarsimp simp: minus_le_iff word_size abs_if sints_num split: if_split_asm)
-    apply (metis minus_minus sint_int_min word_sint.Rep_inject)
-    done
-
-  have result_range_simple: "(sint a sdiv sint b \<in> (sints (size a))) \<Longrightarrow> ?thesis"
-    apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
-    apply (clarsimp simp: word_size sints_num sint_int_min)
-    done
-
-  show ?thesis
-    apply (rule UnE [OF result_range result_range_simple])
-     apply simp
-    apply (clarsimp simp: word_size)
-    using result_range_overflow
-    apply (clarsimp simp: word_size)
-    done
-qed
-
-lemmas sdiv_word_min' = sdiv_word_min [simplified word_size, simplified]
-lemmas sdiv_word_max' = sdiv_word_max [simplified word_size, simplified]
-
-lemmas word_sdiv_numerals_lhs = sdiv_word_def[where v="numeral x" for x]
-    sdiv_word_def[where v=0] sdiv_word_def[where v=1]
-
-lemmas word_sdiv_numerals = word_sdiv_numerals_lhs[where w="numeral y" for y]
-    word_sdiv_numerals_lhs[where w=0] word_sdiv_numerals_lhs[where w=1]
-
-(*
- * Signed modulo properties.
- *)
-
-lemma smod_int_alt_def:
-     "(a::int) smod b = sgn (a) * (abs a mod abs b)"
-  apply (clarsimp simp: signed_modulo_int_def signed_divide_int_def)
-  apply (clarsimp simp: minus_div_mult_eq_mod [symmetric] abs_sgn sgn_mult sgn_if algebra_split_simps)
-  done
-
-lemma smod_int_range:
-  "b \<noteq> 0 \<Longrightarrow> (a::int) smod b \<in> { - abs b + 1 .. abs b - 1 }"
-  apply (case_tac  "b > 0")
-   apply (insert pos_mod_conj [where a=a and b=b])[1]
-   apply (insert pos_mod_conj [where a="-a" and b=b])[1]
-   apply (auto simp: smod_int_alt_def algebra_simps sgn_if
-              abs_if not_less add1_zle_eq [simplified add.commute])[1]
-    apply (metis add_nonneg_nonneg int_one_le_iff_zero_less le_less less_add_same_cancel2 not_le pos_mod_conj)
-  apply (metis (full_types) add.inverse_inverse eucl_rel_int eucl_rel_int_iff le_less_trans neg_0_le_iff_le)
-  apply (insert neg_mod_conj [where a=a and b="b"])[1]
-  apply (insert neg_mod_conj [where a="-a" and b="b"])[1]
-  apply (clarsimp simp: smod_int_alt_def algebra_simps sgn_if
-            abs_if not_less add1_zle_eq [simplified add.commute])
-  apply (metis neg_0_less_iff_less neg_mod_conj not_le not_less_iff_gr_or_eq order_trans pos_mod_conj)
-  done
-
-lemma smod_int_compares:
-   "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b < b"
-   "\<lbrakk> 0 \<le> a; 0 < b \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
-   "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> -b < (a :: int) smod b"
-   "\<lbrakk> a \<le> 0; 0 < b \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
-   "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b < - b"
-   "\<lbrakk> 0 \<le> a; b < 0 \<rbrakk> \<Longrightarrow> 0 \<le> (a :: int) smod b"
-   "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> (a :: int) smod b \<le> 0"
-   "\<lbrakk> a \<le> 0; b < 0 \<rbrakk> \<Longrightarrow> b \<le> (a :: int) smod b"
-  apply (insert smod_int_range [where a=a and b=b])
-  apply (auto simp: add1_zle_eq smod_int_alt_def sgn_if)
-  done
-
-lemma smod_int_mod_0 [simp]:
-  "x smod (0 :: int) = x"
-  by (clarsimp simp: signed_modulo_int_def)
-
-lemma smod_int_0_mod [simp]:
-  "0 smod (x :: int) = 0"
-  by (clarsimp simp: smod_int_alt_def)
-
-lemma smod_word_mod_0 [simp]:
-  "x smod (0 :: ('a::len) word) = x"
-  by (clarsimp simp: smod_word_def)
-
-lemma smod_word_0_mod [simp]:
-  "0 smod (x :: ('a::len) word) = 0"
-  by (clarsimp simp: smod_word_def)
-
-lemma smod_word_max:
-    "sint (a::'a word) smod sint (b::'a word) < 2 ^ (LENGTH('a::len) - Suc 0)"
-  apply (case_tac "b = 0")
-   apply (insert word_sint.Rep [where x=a, simplified sints_num])[1]
-   apply (clarsimp)
-  apply (insert word_sint.Rep [where x="b", simplified sints_num])[1]
-  apply (insert smod_int_range [where a="sint a" and b="sint b"])
-  apply (clarsimp simp: abs_if split: if_split_asm)
-  done
-
-lemma smod_word_min:
-    "- (2 ^ (LENGTH('a::len) - Suc 0)) \<le> sint (a::'a word) smod sint (b::'a word)"
-  apply (case_tac "b = 0")
-   apply (insert word_sint.Rep [where x=a, simplified sints_num])[1]
-   apply clarsimp
-  apply (insert word_sint.Rep [where x=b, simplified sints_num])[1]
-  apply (insert smod_int_range [where a="sint a" and b="sint b"])
-  apply (clarsimp simp: abs_if add1_zle_eq split: if_split_asm)
-  done
-
-lemma smod_word_alt_def:
-  "(a :: ('a::len) word) smod b = a - (a sdiv b) * b"
-  apply (cases \<open>a \<noteq> - (2 ^ (LENGTH('a) - 1)) \<or> b \<noteq> - 1\<close>)
-   apply (clarsimp simp: smod_word_def sdiv_word_def signed_modulo_int_def
-     simp flip: wi_hom_sub wi_hom_mult)
-  apply (clarsimp simp: smod_word_def signed_modulo_int_def)
-  done
-
-lemmas word_smod_numerals_lhs = smod_word_def[where v="numeral x" for x]
-    smod_word_def[where v=0] smod_word_def[where v=1]
-
-lemmas word_smod_numerals = word_smod_numerals_lhs[where w="numeral y" for y]
-    word_smod_numerals_lhs[where w=0] word_smod_numerals_lhs[where w=1]
-
-lemma sint_of_int_eq:
-  "\<lbrakk> - (2 ^ (LENGTH('a) - 1)) \<le> x; x < 2 ^ (LENGTH('a) - 1) \<rbrakk> \<Longrightarrow> sint (of_int x :: ('a::len) word) = x"
-  by (simp add: signed_take_bit_int_eq_self)
-
-lemma of_int_sint:
-  "of_int (sint a) = a"
-  by simp
-
-lemma nth_w2p_scast [simp]:
-  "((scast ((2::'a::len signed word) ^ n) :: 'a word) !! m)
-         \<longleftrightarrow> ((((2::'a::len  word) ^ n) :: 'a word) !! m)"
-  by transfer (auto simp add: bit_simps)
-
-lemma scast_2_power [simp]: "scast ((2 :: 'a::len signed word) ^ x) = ((2 :: 'a word) ^ x)"
-  by (clarsimp simp: word_eq_iff)
-
-lemma scast_bit_test [simp]:
-    "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
-  by (clarsimp simp: word_eq_iff)
-
-lemma ucast_nat_def':
-  "of_nat (unat x) = (ucast :: 'a :: len word \<Rightarrow> ('b :: len) signed word) x"
-  by (fact ucast_nat_def)
-
-lemma mod_mod_power_int:
-  fixes k :: int
-  shows "k mod 2 ^ m mod 2 ^ n = k mod 2 ^ (min m n)"
-  by (metis bintrunc_bintrunc_min bintrunc_mod2p min.commute)
-
-(* Normalise combinations of scast and ucast. *)
-
-lemma ucast_distrib:
-  fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
-  fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
-  fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
-  assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
-  assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
-  assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
-                               = (L x y) mod (2 ^ LENGTH('b))"
-  assumes is_down: "is_down (ucast :: 'a word \<Rightarrow> 'b word)"
-  shows "ucast (M a b) = M' (ucast a) (ucast b)"
-  apply (simp only: ucast_eq)
-  apply (subst lift_M)
-  apply (subst of_int_uint [symmetric], subst lift_M')
-  apply (subst (1 2) int_word_uint)
-  apply (subst word_ubin.norm_eq_iff [symmetric])
-  apply (subst (1 2) bintrunc_mod2p)
-  apply (insert is_down)
-  apply (unfold is_down_def)
-  apply (clarsimp simp: target_size source_size)
-  apply (clarsimp simp: mod_mod_power_int min_def)
-  apply (rule distrib [symmetric])
-  done
-
-lemma ucast_down_add:
-    "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) + b) = (ucast a + ucast b :: 'b::len word)"
-  by (rule ucast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
-
-lemma ucast_down_minus:
-    "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) - b) = (ucast a - ucast b :: 'b::len word)"
-  apply (rule ucast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
-  apply (metis mod_diff_left_eq mod_diff_right_eq)
-  apply simp
-  done
-
-lemma ucast_down_mult:
-    "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) * b) = (ucast a * ucast b :: 'b::len word)"
-  apply (rule ucast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
-  apply (metis mod_mult_eq)
-  apply simp
-  done
-
-lemma scast_distrib:
-  fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
-  fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
-  fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
-  assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
-  assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
-  assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
-                               = (L x y) mod (2 ^ LENGTH('b))"
-  assumes is_down: "is_down (scast :: 'a word \<Rightarrow> 'b word)"
-  shows "scast (M a b) = M' (scast a) (scast b)"
-  apply (subst (1 2 3) down_cast_same [symmetric])
-   apply (insert is_down)
-   apply (clarsimp simp: is_down_def target_size source_size is_down)
-  apply (rule ucast_distrib [where L=L, OF lift_M lift_M' distrib])
-  apply (insert is_down)
-  apply (clarsimp simp: is_down_def target_size source_size is_down)
-  done
-
-lemma scast_down_add:
-    "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) + b) = (scast a + scast b :: 'b::len word)"
-  by (rule scast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
-
-lemma scast_down_minus:
-    "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) - b) = (scast a - scast b :: 'b::len word)"
-  apply (rule scast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
-  apply (metis mod_diff_left_eq mod_diff_right_eq)
-  apply simp
-  done
-
-lemma scast_down_mult:
-    "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) * b) = (scast a * scast b :: 'b::len word)"
-  apply (rule scast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
-  apply (metis mod_mult_eq)
-  apply simp
-  done
-
-lemma scast_ucast_1:
-  "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
-  by (metis down_cast_same ucast_eq ucast_down_wi)
-
-lemma scast_ucast_3:
-  "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
-  by (metis down_cast_same ucast_eq ucast_down_wi)
-
-lemma scast_ucast_4:
-  "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
-  by (metis down_cast_same ucast_eq ucast_down_wi)
-
-lemma scast_scast_b:
-  "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
-     (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
-  by (metis scast_eq sint_up_scast)
-
-lemma ucast_scast_1:
-  "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-            (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
-  by (metis scast_eq ucast_down_wi)
-
-lemma ucast_scast_3:
-  "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
-  by (metis scast_eq ucast_down_wi)
-
-lemma ucast_scast_4:
-  "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
-  by (metis down_cast_same scast_eq sint_up_scast)
-
-lemma ucast_ucast_a:
-  "\<lbrakk> is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-        (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
-  by (metis down_cast_same ucast_eq ucast_down_wi)
-
-lemma ucast_ucast_b:
-  "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
-     (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
-  by (metis ucast_up_ucast)
-
-lemma scast_scast_a:
-  "\<lbrakk> is_down (scast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
-            (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
-  apply (simp only: scast_eq)
-  apply (metis down_cast_same is_up_down scast_eq ucast_down_wi)
-  done
-
-lemma scast_down_wi [OF refl]:
-  "uc = scast \<Longrightarrow> is_down uc \<Longrightarrow> uc (word_of_int x) = word_of_int x"
-  by (metis down_cast_same is_up_down ucast_down_wi)
-
-lemmas cast_simps =
-  is_down is_up
-  scast_down_add scast_down_minus scast_down_mult
-  ucast_down_add ucast_down_minus ucast_down_mult
-  scast_ucast_1 scast_ucast_3 scast_ucast_4
-  ucast_scast_1 ucast_scast_3 ucast_scast_4
-  ucast_ucast_a ucast_ucast_b
-  scast_scast_a scast_scast_b
-  ucast_down_wi scast_down_wi
-  ucast_of_nat scast_of_nat
-  uint_up_ucast sint_up_scast
-  up_scast_surj up_ucast_surj
-
-lemma smod_mod_positive:
-    "\<lbrakk> 0 \<le> (a :: int); 0 \<le> b \<rbrakk> \<Longrightarrow> a smod b = a mod b"
-  by (clarsimp simp: smod_int_alt_def zsgn_def)
-
-lemma nat_mult_power_less_eq:
-  "b > 0 \<Longrightarrow> (a * b ^ n < (b :: nat) ^ m) = (a < b ^ (m - n))"
-  using mult_less_cancel2[where m = a and k = "b ^ n" and n="b ^ (m - n)"]
-        mult_less_cancel2[where m="a * b ^ (n - m)" and k="b ^ m" and n=1]
-  apply (simp only: power_add[symmetric] nat_minus_add_max)
-  apply (simp only: power_add[symmetric] nat_minus_add_max ac_simps)
-  apply (simp add: max_def split: if_split_asm)
-  done
-
-lemma signed_shift_guard_to_word:
-  "\<lbrakk> n < len_of TYPE ('a); n > 0 \<rbrakk>
-    \<Longrightarrow> (unat (x :: 'a :: len word) * 2 ^ y < 2 ^ n)
-    = (x = 0 \<or> x < (1 << n >> y))"
-  apply (simp only: nat_mult_power_less_eq)
-  apply (cases "y \<le> n")
-   apply (simp only: shiftl_shiftr1)
-   apply (subst less_mask_eq)
-    apply (simp add: word_less_nat_alt word_size)
-    apply (rule order_less_le_trans[rotated], rule power_increasing[where n=1])
-      apply simp
-     apply simp
-    apply simp
-   apply (simp add: nat_mult_power_less_eq word_less_nat_alt word_size)
-   apply auto[1]
-  apply (simp only: shiftl_shiftr2, simp add: unat_eq_0)
-  done
-
-lemma sint_ucast_eq_uint:
-    "\<lbrakk> \<not> is_down (ucast :: ('a::len word \<Rightarrow> 'b::len word)) \<rbrakk>
-            \<Longrightarrow> sint ((ucast :: ('a::len word \<Rightarrow> 'b::len word)) x) = uint x"
-  apply (subst sint_eq_uint)
-   apply (simp add: msb_word_eq)
-   apply transfer
-   apply (simp add: bit_take_bit_iff)
-  apply transfer
-  apply simp
-  done
-
-lemma word_less_nowrapI':
-  "(x :: 'a :: len word) \<le> z - k \<Longrightarrow> k \<le> z \<Longrightarrow> 0 < k \<Longrightarrow> x < x + k"
-  by uint_arith
-
-lemma mask_plus_1:
-  "mask n + 1 = (2 ^ n :: 'a::len word)"
-  by (clarsimp simp: mask_eq_decr_exp)
-
-lemma unat_inj: "inj unat"
-  by (metis eq_iff injI word_le_nat_alt)
-
-lemma unat_ucast_upcast:
-  "is_up (ucast :: 'b word \<Rightarrow> 'a word)
-      \<Longrightarrow> unat (ucast x :: ('a::len) word) = unat (x :: ('b::len) word)"
-  unfolding ucast_eq unat_eq_nat_uint
-  apply (subst int_word_uint)
-  apply (subst mod_pos_pos_trivial)
-    apply simp
-   apply (rule lt2p_lem)
-   apply (clarsimp simp: is_up)
-  apply simp
-  done
-
-lemma ucast_mono:
-  "\<lbrakk> (x :: 'b :: len word) < y; y < 2 ^ LENGTH('a) \<rbrakk>
-   \<Longrightarrow> ucast x < ((ucast y) :: 'a :: len word)"
-  apply (simp only: flip: ucast_nat_def)
-  apply (rule of_nat_mono_maybe)
-  apply (rule unat_less_helper)
-  apply (simp add: Power.of_nat_power)
-  apply (simp add: word_less_nat_alt)
-  done
-
-lemma ucast_mono_le:
-  "\<lbrakk>x \<le> y; y < 2 ^ LENGTH('b)\<rbrakk> \<Longrightarrow> (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> ucast y"
-  apply (simp only: flip: ucast_nat_def)
-  apply (subst of_nat_mono_maybe_le[symmetric])
-    apply (rule unat_less_helper)
-    apply (simp add: Power.of_nat_power)
-   apply (rule unat_less_helper)
-   apply (erule le_less_trans)
-   apply (simp add: Power.of_nat_power)
-  apply (simp add: word_le_nat_alt)
-  done
-
-lemma ucast_mono_le':
-  "\<lbrakk> unat y < 2 ^ LENGTH('b); LENGTH('b::len) < LENGTH('a::len); x \<le> y \<rbrakk>
-   \<Longrightarrow> UCAST('a \<rightarrow> 'b) x \<le> UCAST('a \<rightarrow> 'b) y"
-  by (auto simp: word_less_nat_alt intro: ucast_mono_le)
-
-lemma zero_sle_ucast_up:
-  "\<not> is_down (ucast :: 'a word \<Rightarrow> 'b signed word) \<Longrightarrow>
-          (0 <=s ((ucast (b::('a::len) word)) :: ('b::len) signed word))"
-  by transfer (simp add: bit_simps)
-
-lemma word_le_ucast_sless:
-  "\<lbrakk> x \<le> y; y \<noteq> -1; LENGTH('a) < LENGTH('b) \<rbrakk> \<Longrightarrow>
-    UCAST (('a :: len) \<rightarrow> ('b :: len) signed) x <s ucast (y + 1)"
-  by (clarsimp simp: word_le_make_less word_sless_alt sint_ucast_eq_uint is_down word_less_def)
-
-lemma msb_ucast_eq:
-    "LENGTH('a) = LENGTH('b) \<Longrightarrow>
-         msb (ucast x :: ('a::len) word) = msb (x :: ('b::len) word)"
-  by (simp add: msb_word_eq bit_simps)
-
-lemma msb_big:
-     "msb (a :: ('a::len) word) = (a \<ge> 2 ^ (LENGTH('a)  - Suc 0))"
-  apply (rule iffI)
-   apply (clarsimp simp: msb_nth)
-   apply (drule bang_is_le)
-   apply simp
-  apply (rule ccontr)
-  apply (subgoal_tac "a = a AND mask (LENGTH('a) - Suc 0)")
-   apply (cut_tac and_mask_less' [where w=a and n="LENGTH('a) - Suc 0"])
-    apply (clarsimp simp: word_not_le [symmetric])
-   apply clarsimp
-  apply (rule sym, subst and_mask_eq_iff_shiftr_0)
-  apply (clarsimp simp: msb_shift)
-  done
-
-lemma zero_sle_ucast:
-  "(0 <=s ((ucast (b::('a::len) word)) :: ('a::len) signed word))
-                = (uint b < 2 ^ (LENGTH('a) - 1))"
-  apply transfer
-  apply (cases \<open>LENGTH('a)\<close>)
-   apply (simp_all add: take_bit_Suc_from_most bit_simps)
-  apply (simp_all add: bit_simps disjunctive_add)
-  done
-
-lemma aligned_shift:
-  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
-   \<Longrightarrow> x + y >> n = y >> n"
-  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
-   apply (auto simp add: bit_simps is_aligned_nth test_bit_eq_bit)
-   apply (metis nth_bounded test_bit_eq_bit)
-  apply (metis bit_imp_le_length le_add1 less_2p_is_upper_bits_unset test_bit_eq_bit)
-  done
-
-lemma aligned_shift':
-  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
-   \<Longrightarrow> y + x >> n = y >> n"
-  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
-   apply (auto simp add: bit_simps is_aligned_nth test_bit_eq_bit)
-   apply (metis nth_bounded test_bit_eq_bit)
-  apply (metis bit_imp_le_length le_add1 less_2p_is_upper_bits_unset test_bit_eq_bit)
-  done
-
-lemma neg_mask_add_mask:
-  "((x:: 'a :: len word) AND NOT (mask n)) + (2 ^ n - 1) = x OR mask n"
-  unfolding mask_2pm1 [symmetric]
-  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
-   apply (auto simp add: bit_simps)
-  done
-
-lemma and_neg_mask_plus_mask_mono: "(p AND NOT (mask n)) + mask n \<ge> p"
-  for p :: \<open>'a::len word\<close>
-  apply (rule word_le_minus_cancel[where x = "p AND NOT (mask n)"])
-   apply (clarsimp simp: subtract_mask)
-   using word_and_le1[where a = "mask n" and y = p]
-   apply (clarsimp simp: mask_eq_decr_exp word_le_less_eq)
-  apply (rule is_aligned_no_overflow'[folded mask_2pm1])
-  apply (clarsimp simp: is_aligned_neg_mask)
-  done
-
-lemma word_neg_and_le:
-  "ptr \<le> (ptr AND NOT (mask n)) + (2 ^ n - 1)"
-  for ptr :: \<open>'a::len word\<close>
-  by (simp add: and_neg_mask_plus_mask_mono mask_2pm1[symmetric])
-
-lemma is_aligned_sub_helper:
-  "\<lbrakk> is_aligned (p - d) n; d < 2 ^ n \<rbrakk>
-     \<Longrightarrow> (p AND mask n = d) \<and> (p AND (NOT (mask n)) = p - d)"
-  by (drule(1) is_aligned_add_helper, simp)
-
-lemma is_aligned_after_mask:
-  "\<lbrakk>is_aligned k m;m\<le> n\<rbrakk> \<Longrightarrow> is_aligned (k AND mask n) m"
-  by (rule is_aligned_andI1)
-
-lemma and_mask_plus:
-  "\<lbrakk>is_aligned ptr m; m \<le> n; a < 2 ^ m\<rbrakk>
-   \<Longrightarrow> ptr + a AND mask n = (ptr AND mask n) + a"
-  apply (rule mask_eqI[where n = m])
-   apply (simp add:mask_twice min_def)
-    apply (simp add:is_aligned_add_helper)
-    apply (subst is_aligned_add_helper[THEN conjunct1])
-      apply (erule is_aligned_after_mask)
-     apply simp
-    apply simp
-   apply simp
-  apply (subgoal_tac "(ptr + a AND mask n) AND NOT (mask m)
-     = (ptr + a AND NOT (mask m) ) AND mask n")
-   apply (simp add:is_aligned_add_helper)
-   apply (subst is_aligned_add_helper[THEN conjunct2])
-     apply (simp add:is_aligned_after_mask)
-    apply simp
-   apply simp
-  apply (simp add:word_bw_comms word_bw_lcs)
-  done
-
-lemma le_step_down_word:"\<lbrakk>(i::('a::len) word) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
-  by unat_arith
-
-lemma le_step_down_word_2:
-  fixes x :: "'a::len word"
-  shows "\<lbrakk>x \<le>  y; x \<noteq> y\<rbrakk> \<Longrightarrow> x \<le> y - 1"
-  by (subst (asm) word_le_less_eq,
-      clarsimp,
-      simp add: word_le_minus_one_leq)
-
-lemma NOT_mask_AND_mask[simp]: "(w AND mask n) AND NOT (mask n) = 0"
-  by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff bit_mask_iff)
-
-lemma and_and_not[simp]:"(a AND b) AND NOT b = 0"
-  for a b :: \<open>'a::len word\<close>
-  apply (subst word_bw_assocs(1))
-  apply clarsimp
-  done
-
-lemma mask_shift_and_negate[simp]:"(w AND mask n << m) AND NOT (mask n << m) = 0"
-  for w :: \<open>'a::len word\<close>
-  by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff shiftl_word_eq bit_push_bit_iff)
-
-lemma le_step_down_nat:"\<lbrakk>(i::nat) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
-  by arith
-
-lemma le_step_down_int:"\<lbrakk>(i::int) \<le> n; i = n \<longrightarrow> P; i \<le> n - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
-  by arith
-
-lemma ex_mask_1[simp]: "(\<exists>x. mask x = (1 :: 'a::len word))"
-  apply (rule_tac x=1 in exI)
-  apply (simp add:mask_eq_decr_exp)
-  done
-
-lemma not_switch:"NOT a = x \<Longrightarrow> a = NOT x"
-  by auto
-
 (* The seL4 bitfield generator produces functions containing mask and shift operations, such that
  * invoking two of them consecutively can produce something like the following.
  *)
 lemma bitfield_op_twice:
   "(x AND NOT (mask n << m) OR ((y AND mask n) << m)) AND NOT (mask n << m) = x AND NOT (mask n << m)"
   for x :: \<open>'a::len word\<close>
   by (induct n arbitrary: m) (auto simp: word_ao_dist)
 
 lemma bitfield_op_twice'':
   "\<lbrakk>NOT a = b << c; \<exists>x. b = mask x\<rbrakk> \<Longrightarrow> (x AND a OR (y AND b << c)) AND a = x AND a"
   for a b :: \<open>'a::len word\<close>
   apply clarsimp
   apply (cut_tac n=xa and m=c and x=x and y=y in bitfield_op_twice)
   apply (clarsimp simp:mask_eq_decr_exp)
   apply (drule not_switch)
   apply clarsimp
   done
 
 lemma bit_twiddle_min:
   "(y::'a::len word) XOR (((x::'a::len word) XOR y) AND (if x < y then -1 else 0)) = min x y"
   by (auto simp add: Parity.bit_eq_iff bit_xor_iff min_def)
 
 lemma bit_twiddle_max:
   "(x::'a::len word) XOR (((x::'a::len word) XOR y) AND (if x < y then -1 else 0)) = max x y"
   by (auto simp add: Parity.bit_eq_iff bit_xor_iff max_def)
 
 lemma swap_with_xor:
   "\<lbrakk>(x::'a::len word) = a XOR b; y = b XOR x; z = x XOR y\<rbrakk> \<Longrightarrow> z = b \<and> y = a"
   by (auto simp add: Parity.bit_eq_iff bit_xor_iff max_def)
 
 lemma scast_nop1 [simp]:
   "((scast ((of_int x)::('a::len) word))::'a sword) = of_int x"
   apply (simp only: scast_eq)
   by (metis len_signed sint_sbintrunc' word_sint.Rep_inverse)
 
 lemma scast_nop2 [simp]:
   "((scast ((of_int x)::('a::len) sword))::'a word) = of_int x"
   apply (simp only: scast_eq)
   by (metis len_signed sint_sbintrunc' word_sint.Rep_inverse)
 
 lemmas scast_nop = scast_nop1 scast_nop2 scast_id
 
 lemma le_mask_imp_and_mask:
   "(x::'a::len word) \<le> mask n \<Longrightarrow> x AND mask n = x"
   by (metis and_mask_eq_iff_le_mask)
 
 lemma or_not_mask_nop:
   "((x::'a::len word) OR NOT (mask n)) AND mask n = x AND mask n"
   by (metis word_and_not word_ao_dist2 word_bw_comms(1) word_log_esimps(3))
 
 lemma mask_subsume:
   "\<lbrakk>n \<le> m\<rbrakk> \<Longrightarrow> ((x::'a::len word) OR y AND mask n) AND NOT (mask m) = x AND NOT (mask m)"
   by (auto simp add: Parity.bit_eq_iff bit_not_iff bit_or_iff bit_and_iff bit_mask_iff)
 
 lemma and_mask_0_iff_le_mask:
   fixes w :: "'a::len word"
   shows "(w AND NOT(mask n) = 0) = (w \<le> mask n)"
   by (simp add: mask_eq_0_eq_x le_mask_imp_and_mask and_mask_eq_iff_le_mask)
 
 lemma mask_twice2:
   "n \<le> m \<Longrightarrow> ((x::'a::len word) AND mask m) AND mask n = x AND mask n"
   by (metis mask_twice min_def)
 
 lemma uint_2_id:
   "LENGTH('a) \<ge> 2 \<Longrightarrow> uint (2::('a::len) word) = 2"
   by simp
 
 lemma bintrunc_id:
   "\<lbrakk>m \<le> of_nat n; 0 < m\<rbrakk> \<Longrightarrow> bintrunc n m = m"
   by (simp add: bintrunc_mod2p le_less_trans)
 
 lemma shiftr1_unfold: "shiftr1 x = x >> 1"
   by (metis One_nat_def comp_apply funpow.simps(1) funpow.simps(2) id_apply shiftr_def)
 
 lemma shiftr1_is_div_2: "(x::('a::len) word) >> 1 = x div 2"
   by transfer (simp add: drop_bit_Suc)
 
 lemma shiftl1_is_mult: "(x << 1) = (x :: 'a::len word) * 2"
   by (metis One_nat_def mult_2 mult_2_right one_add_one
         power_0 power_Suc shiftl_t2n)
 
 lemma div_of_0_id[simp]:"(0::('a::len) word) div n = 0"
   by (simp add: word_div_def)
 
 lemma degenerate_word:"LENGTH('a) = 1 \<Longrightarrow> (x::('a::len) word) = 0 \<or> x = 1"
   by (metis One_nat_def less_irrefl_nat sint_1_cases)
 
 lemma div_by_0_word:"(x::('a::len) word) div 0 = 0"
   by (metis div_0 div_by_0 unat_0 word_arith_nat_defs(6) word_div_1)
 
 lemma div_less_dividend_word:"\<lbrakk>x \<noteq> 0; n \<noteq> 1\<rbrakk> \<Longrightarrow> (x::('a::len) word) div n < x"
   apply (cases \<open>n = 0\<close>)
    apply clarsimp
    apply (simp add:word_neq_0_conv)
   apply (subst word_arith_nat_div)
   apply (rule word_of_nat_less)
   apply (rule div_less_dividend)
   using unat_eq_zero word_unat_Rep_inject1 apply force
   apply (simp add:unat_gt_0)
   done
 
 lemma shiftr1_lt:"x \<noteq> 0 \<Longrightarrow> (x::('a::len) word) >> 1 < x"
   apply (subst shiftr1_is_div_2)
   apply (rule div_less_dividend_word)
    apply simp+
   done
 
 lemma word_less_div:
   fixes x :: "('a::len) word"
     and y :: "('a::len) word"
   shows "x div y = 0 \<Longrightarrow> y = 0 \<or> x < y"
   apply (case_tac "y = 0", clarsimp+)
   by (metis One_nat_def Suc_le_mono le0 le_div_geq not_less unat_0 unat_div unat_gt_0 word_less_nat_alt zero_less_one)
 
 lemma not_degenerate_imp_2_neq_0:"LENGTH('a) > 1 \<Longrightarrow> (2::('a::len) word) \<noteq> 0"
   by (metis numerals(1) power_not_zero power_zero_numeral)
 
 lemma shiftr1_0_or_1:"(x::('a::len) word) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x = 1"
   apply (subst (asm) shiftr1_is_div_2)
   apply (drule word_less_div)
   apply (case_tac "LENGTH('a) = 1")
    apply (simp add:degenerate_word)
   apply (erule disjE)
    apply (subgoal_tac "(2::'a word) \<noteq> 0")
     apply simp
    apply (rule not_degenerate_imp_2_neq_0)
    apply (subgoal_tac "LENGTH('a) \<noteq> 0")
     apply arith
    apply simp
   apply (rule x_less_2_0_1', simp+)
   done
 
 lemma word_overflow:"(x::('a::len) word) + 1 > x \<or> x + 1 = 0"
   apply clarsimp
   by (metis diff_0 eq_diff_eq less_x_plus_1)
 
 lemma word_overflow_unat:"unat ((x::('a::len) word) + 1) = unat x + 1 \<or> x + 1 = 0"
   by (metis Suc_eq_plus1 add.commute unatSuc)
 
 lemma even_word_imp_odd_next:"even (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> odd (unat (x + 1))"
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   done
 
 lemma odd_word_imp_even_next:"odd (unat (x::('a::len) word)) \<Longrightarrow> x + 1 = 0 \<or> even (unat (x + 1))"
   apply (cut_tac x=x in word_overflow_unat)
   apply clarsimp
   done
 
 lemma overflow_imp_lsb:"(x::('a::len) word) + 1 = 0 \<Longrightarrow> x !! 0"
   using even_plus_one_iff [of x] by (simp add: test_bit_word_eq)
 
 lemma odd_iff_lsb:"odd (unat (x::('a::len) word)) = x !! 0"
   by transfer (simp add: even_nat_iff)
 
 lemma of_nat_neq_iff_word:
       "x mod 2 ^ LENGTH('a) \<noteq> y mod 2 ^ LENGTH('a) \<Longrightarrow>
          (((of_nat x)::('a::len) word) \<noteq> of_nat y) = (x \<noteq> y)"
   apply (rule iffI)
    apply (case_tac "x = y")
    apply (subst (asm) of_nat_eq_iff[symmetric])
    apply simp+
   apply (case_tac "((of_nat x)::('a::len) word) = of_nat y")
    apply (subst (asm) word_unat.norm_eq_iff[symmetric])
    apply simp+
   done
 
 lemma shiftr1_irrelevant_lsb:"(x::('a::len) word) !! 0 \<or> x >> 1 = (x + 1) >> 1"
   apply (cases \<open>LENGTH('a)\<close>; transfer)
    apply (simp_all add: take_bit_drop_bit)
   apply (simp add: drop_bit_take_bit drop_bit_Suc)
   done
 
 lemma shiftr1_0_imp_only_lsb:"((x::('a::len) word) + 1) >> 1 = 0 \<Longrightarrow> x = 0 \<or> x + 1 = 0"
   by (metis One_nat_def shiftr1_0_or_1 word_less_1 word_overflow)
 
 lemma shiftr1_irrelevant_lsb':"\<not>((x::('a::len) word) !! 0) \<Longrightarrow> x >> 1 = (x + 1) >> 1"
   by (metis shiftr1_irrelevant_lsb)
 
 lemma lsb_this_or_next:"\<not>(((x::('a::len) word) + 1) !! 0) \<Longrightarrow> x !! 0"
   by (metis (poly_guards_query) even_word_imp_odd_next odd_iff_lsb overflow_imp_lsb)
 
 (* Perhaps this one should be a simp lemma, but it seems a little dangerous. *)
 lemma cast_chunk_assemble_id:
   "\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
   (((ucast ((ucast (x::'b word))::'a word))::'b word) OR (((ucast ((ucast (x >> n))::'a word))::'b word) << n)) = x"
   apply (subgoal_tac "((ucast ((ucast (x >> n))::'a word))::'b word) = x >> n")
    apply clarsimp
    apply (subst and_not_mask[symmetric])
    apply (subst ucast_ucast_mask)
    apply (subst word_ao_dist2[symmetric])
    apply clarsimp
   apply (rule ucast_ucast_len)
   apply (rule shiftr_less_t2n')
    apply (subst and_mask_eq_iff_le_mask)
    apply (simp_all add: mask_eq_decr_exp flip: mult_2_right)
   apply (metis add_diff_cancel_left' len_gt_0 mult_2_right zero_less_diff)
   done
 
 lemma cast_chunk_scast_assemble_id:
   "\<lbrakk>n = LENGTH('a::len); m = LENGTH('b::len); n * 2 = m\<rbrakk> \<Longrightarrow>
   (((ucast ((scast (x::'b word))::'a word))::'b word) OR
    (((ucast ((scast (x >> n))::'a word))::'b word) << n)) = x"
   apply (subgoal_tac "((scast x)::'a word) = ((ucast x)::'a word)")
    apply (subgoal_tac "((scast (x >> n))::'a word) = ((ucast (x >> n))::'a word)")
     apply (simp add:cast_chunk_assemble_id)
    apply (subst down_cast_same[symmetric], subst is_down, arith, simp)+
   done
 
 lemma mask_or_not_mask:
   "x AND mask n OR x AND NOT (mask n) = x"
   for x :: \<open>'a::len word\<close>
   apply (subst word_oa_dist, simp)
   apply (subst word_oa_dist2, simp)
   done
 
 lemma is_aligned_add_not_aligned:
   "\<lbrakk>is_aligned (p::'a::len word) n; \<not> is_aligned (q::'a::len word) n\<rbrakk> \<Longrightarrow> \<not> is_aligned (p + q) n"
   by (metis is_aligned_addD1)
 
 lemma word_gr0_conv_Suc: "(m::'a::len word) > 0 \<Longrightarrow> \<exists>n. m = n + 1"
   by (metis add.commute add_minus_cancel)
 
 lemma neg_mask_add_aligned:
   "\<lbrakk> is_aligned p n; q < 2 ^ n \<rbrakk> \<Longrightarrow> (p + q) AND NOT (mask n) = p AND NOT (mask n)"
   by (metis is_aligned_add_helper is_aligned_neg_mask_eq)
 
 lemma word_sless_sint_le:"x <s y \<Longrightarrow> sint x \<le> sint y - 1"
   by (metis word_sless_alt zle_diff1_eq)
 
 
 lemma upper_trivial:
   fixes x :: "'a::len word"
   shows "x \<noteq> 2 ^ LENGTH('a) - 1 \<Longrightarrow> x < 2 ^ LENGTH('a) - 1"
   by (simp add: less_le)
 
 lemma constraint_expand:
   fixes x :: "'a::len word"
   shows "x \<in> {y. lower \<le> y \<and> y \<le> upper} = (lower \<le> x \<and> x \<le> upper)"
   by (rule mem_Collect_eq)
 
 lemma card_map_elide:
   "card ((of_nat :: nat \<Rightarrow> 'a::len word) ` {0..<n}) = card {0..<n}"
     if "n \<le> CARD('a::len word)"
 proof -
   let ?of_nat = "of_nat :: nat \<Rightarrow> 'a word"
   from word_unat.Abs_inj_on
   have "inj_on ?of_nat {i. i < CARD('a word)}"
     by (simp add: unats_def card_word)
   moreover have "{0..<n} \<subseteq> {i. i < CARD('a word)}"
     using that by auto
   ultimately have "inj_on ?of_nat {0..<n}"
     by (rule inj_on_subset)
   then show ?thesis
     by (simp add: card_image)
 qed
 
 lemma card_map_elide2:
   "n \<le> CARD('a::len word) \<Longrightarrow> card ((of_nat::nat \<Rightarrow> 'a::len word) ` {0..<n}) = n"
   by (subst card_map_elide) clarsimp+
 
 lemma le_max_word_ucast_id:
   \<open>UCAST('b \<rightarrow> 'a) (UCAST('a \<rightarrow> 'b) x) = x\<close>
     if \<open>x \<le> UCAST('b::len \<rightarrow> 'a) (- 1)\<close>
     for x :: \<open>'a::len word\<close>
 proof -
   from that have a1: \<open>x \<le> word_of_int (uint (word_of_int (2 ^ LENGTH('b) - 1) :: 'b word))\<close>
     by simp
   have f2: "((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
             \<not> (0::int) \<le> - 1 + 2 ^ LENGTH('b) \<or> (0::int) \<le> - 1 + 2 ^ LENGTH('b) + - 1 * 2 ^ LENGTH('b) \<or>
             (- (1::int) + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b) =
               - 1 + 2 ^ LENGTH('b)) = ((\<exists>i ia. (0::int) \<le> i \<and> \<not> 0 \<le> i + - 1 * ia \<and> i mod ia \<noteq> i) \<or>
             \<not> (1::int) \<le> 2 ^ LENGTH('b) \<or>
             2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)) = 1)"
     by force
   have f3: "\<forall>i ia. \<not> (0::int) \<le> i \<or> 0 \<le> i + - 1 * ia \<or> i mod ia = i"
     using mod_pos_pos_trivial by force
   have "(1::int) \<le> 2 ^ LENGTH('b)"
     by simp
   then have "2 ^ LENGTH('b) + - (1::int) * ((- 1 + 2 ^ LENGTH('b)) mod 2 ^ len_of TYPE ('b)) = 1"
     using f3 f2 by blast
   then have f4: "- (1::int) + 2 ^ LENGTH('b) = (- 1 + 2 ^ LENGTH('b)) mod 2 ^ LENGTH('b)"
     by linarith
   have f5: "x \<le> word_of_int (uint (word_of_int (- 1 + 2 ^ LENGTH('b))::'b word))"
     using a1 by force
   have f6: "2 ^ LENGTH('b) + - (1::int) = - 1 + 2 ^ LENGTH('b)"
     by force
   have f7: "- (1::int) * 1 = - 1"
     by auto
   have "\<forall>x0 x1. (x1::int) - x0 = x1 + - 1 * x0"
     by force
   then have "x \<le> 2 ^ LENGTH('b) - 1"
     using f7 f6 f5 f4 by (metis uint_word_of_int wi_homs(2) word_arith_wis(8) word_of_int_2p)
   then have \<open>uint x \<le> uint (2 ^ LENGTH('b) - (1 :: 'a word))\<close>
     by (simp add: word_le_def)
   then have \<open>uint x \<le> 2 ^ LENGTH('b) - 1\<close>
     by (simp add: uint_word_ariths)
       (metis \<open>1 \<le> 2 ^ LENGTH('b)\<close> \<open>uint x \<le> uint (2 ^ LENGTH('b) - 1)\<close> linorder_not_less lt2p_lem uint_1 uint_minus_simple_alt uint_power_lower word_le_def zle_diff1_eq)
   then show ?thesis
     apply (simp add: word_ubin.eq_norm bintrunc_mod2p unsigned_ucast_eq)
     apply (metis \<open>x \<le> 2 ^ LENGTH('b) - 1\<close> and_mask_eq_iff_le_mask mask_eq_decr_exp take_bit_eq_mask)
     done
 qed
 
 lemma remdups_enum_upto:
   fixes s::"'a::len word"
   shows "remdups [s .e. e] = [s .e. e]"
   by simp
 
 lemma card_enum_upto:
   fixes s::"'a::len word"
   shows "card (set [s .e. e]) = Suc (unat e) - unat s"
   by (subst List.card_set) (simp add: remdups_enum_upto)
 
 lemma complement_nth_w2p:
   shows "n' < LENGTH('a) \<Longrightarrow> (NOT (2 ^ n :: 'a::len word)) !! n' = (n' \<noteq> n)"
   by (fastforce simp: word_ops_nth_size word_size nth_w2p)
 
 lemma word_unat_and_lt:
   "unat x < n \<or> unat y < n \<Longrightarrow> unat (x AND y) < n"
   by (meson le_less_trans word_and_le1 word_and_le2 word_le_nat_alt)
 
 lemma word_unat_mask_lt:
   "m \<le> size w \<Longrightarrow> unat ((w::'a::len word) AND mask m) < 2 ^ m"
   by (rule word_unat_and_lt) (simp add: unat_mask word_size)
 
 lemma unat_shiftr_less_t2n:
   fixes x :: "'a :: len word"
   shows "unat x < 2 ^ (n + m) \<Longrightarrow> unat (x >> n) < 2 ^ m"
   by (simp add: shiftr_div_2n' power_add mult.commute td_gal_lt)
 
 lemma le_or_mask:
   "w \<le> w' \<Longrightarrow> w OR mask x \<le> w' OR mask x"
   for w w' :: \<open>'a::len word\<close>
   by (metis neg_mask_add_mask add.commute le_word_or1 mask_2pm1 neg_mask_mono_le word_plus_mono_left)
 
 lemma le_shiftr1':
   "\<lbrakk> shiftr1 u \<le> shiftr1 v ; shiftr1 u \<noteq> shiftr1 v \<rbrakk> \<Longrightarrow> u \<le> v"
   apply transfer
   apply simp
   done
 
 lemma le_shiftr':
   "\<lbrakk> u >> n \<le> v >> n ; u >> n \<noteq> v >> n \<rbrakk> \<Longrightarrow> (u::'a::len word) \<le> v"
   apply (induct n; simp add: shiftr_def)
   apply (case_tac "(shiftr1 ^^ n) u = (shiftr1 ^^ n) v", simp)
   apply (fastforce dest: le_shiftr1')
   done
 
 lemma word_add_no_overflow:"(x::'a::len word) < max_word \<Longrightarrow> x < x + 1"
   using less_x_plus_1 order_less_le by blast
 
 lemma lt_plus_1_le_word:
   fixes x :: "'a::len word"
   assumes bound:"n < unat (maxBound::'a word)"
   shows "x < 1 + of_nat n = (x \<le> of_nat n)"
   by (metis add.commute bound max_word_max word_Suc_leq word_not_le word_of_nat_less)
 
 lemma unat_ucast_up_simp:
   fixes x :: "'a::len word"
   assumes "LENGTH('a) \<le> LENGTH('b)"
   shows "unat (ucast x :: 'b::len word) = unat x"
   unfolding ucast_eq unat_eq_nat_uint
   apply (subst int_word_uint)
   apply (subst mod_pos_pos_trivial; simp?)
   apply (rule lt2p_lem)
   apply (simp add: assms)
   done
 
 lemma unat_ucast_less_no_overflow:
   "\<lbrakk>n < 2 ^ LENGTH('a); unat f < n\<rbrakk> \<Longrightarrow> (f::('a::len) word) < of_nat n"
   by (erule (1)  order_le_less_trans[OF _ of_nat_mono_maybe,rotated]) simp
 
 lemma unat_ucast_less_no_overflow_simp:
   "n < 2 ^ LENGTH('a) \<Longrightarrow> (unat f < n) = ((f::('a::len) word) < of_nat n)"
   using unat_less_helper unat_ucast_less_no_overflow by blast
 
 lemma unat_ucast_no_overflow_le:
   assumes no_overflow: "unat b < (2 :: nat) ^ LENGTH('a)"
   and upward_cast: "LENGTH('a) < LENGTH('b)"
   shows "(ucast (f::'a::len word) < (b :: 'b :: len word)) = (unat f < unat b)"
 proof -
   have LR: "ucast f < b \<Longrightarrow> unat f < unat b"
     apply (rule unat_less_helper)
     apply (simp add:ucast_nat_def)
     apply (rule_tac 'b1 = 'b in  ucast_less_ucast[OF order.strict_implies_order, THEN iffD1])
      apply (rule upward_cast)
     apply (simp add: ucast_ucast_mask less_mask_eq word_less_nat_alt
                      unat_power_lower[OF upward_cast] no_overflow)
     done
   have RL: "unat f < unat b \<Longrightarrow> ucast f < b"
   proof-
     assume ineq: "unat f < unat b"
     have "ucast (f::'a::len word) < ((ucast (ucast b ::'a::len word)) :: 'b :: len word)"
       apply (simp add: ucast_less_ucast[OF order.strict_implies_order] upward_cast)
       apply (simp only: flip: ucast_nat_def)
       apply (rule unat_ucast_less_no_overflow[OF no_overflow ineq])
       done
     then show ?thesis
       apply (rule order_less_le_trans)
       apply (simp add:ucast_ucast_mask word_and_le2)
       done
   qed
   then show ?thesis by (simp add:RL LR iffI)
 qed
 
 lemmas ucast_up_mono = ucast_less_ucast[THEN iffD2]
 
 lemma minus_one_word:
   "(-1 :: 'a :: len word) = 2 ^ LENGTH('a) - 1"
   by simp
 
 lemma mask_exceed:
   "n \<ge> LENGTH('a) \<Longrightarrow> (x::'a::len word) AND NOT (mask n) = 0"
   by (simp add: and_not_mask shiftr_eq_0)
 
 lemma word_shift_by_2:
   "x * 4 = (x::'a::len word) << 2"
   by (simp add: shiftl_t2n)
 
 lemma le_2p_upper_bits:
   "\<lbrakk> (p::'a::len word) \<le> 2^n - 1; n < LENGTH('a) \<rbrakk> \<Longrightarrow>
   \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'"
   by (subst upper_bits_unset_is_l2p; simp)
 
 lemma le2p_bits_unset:
   "p \<le> 2 ^ n - 1 \<Longrightarrow> \<forall>n'\<ge>n. n' < LENGTH('a) \<longrightarrow> \<not> (p::'a::len word) !! n'"
   using upper_bits_unset_is_l2p [where p=p]
   by (cases "n < LENGTH('a)") auto
 
 lemma ucast_less_shiftl_helper:
   "\<lbrakk> LENGTH('b) + 2 < LENGTH('a); 2 ^ (LENGTH('b) + 2) \<le> n\<rbrakk>
     \<Longrightarrow> (ucast (x :: 'b::len word) << 2) < (n :: 'a::len word)"
   apply (erule order_less_le_trans[rotated])
   using ucast_less[where x=x and 'a='a]
   apply (simp only: shiftl_t2n field_simps)
   apply (rule word_less_power_trans2; simp)
   done
 
 lemma word_power_nonzero:
   "\<lbrakk> (x :: 'a::len word) < 2 ^ (LENGTH('a) - n); n < LENGTH('a); x \<noteq> 0 \<rbrakk>
   \<Longrightarrow> x * 2 ^ n \<noteq> 0"
   by (metis and_mask_eq_iff_shiftr_0 less_mask_eq p2_gt_0 semiring_normalization_rules(7)
             shiftl_shiftr_id shiftl_t2n)
 
 lemma less_1_helper:
   "n \<le> m \<Longrightarrow> (n - 1 :: int) < m"
   by arith
 
 lemma div_power_helper:
   "\<lbrakk> x \<le> y; y < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 ^ y - 1) div (2 ^ x :: 'a::len word) = 2 ^ (y - x) - 1"
   apply (rule word_uint.Rep_eqD)
   apply (simp only: uint_word_ariths uint_div uint_power_lower)
   apply (subst mod_pos_pos_trivial, fastforce, fastforce)+
   apply (subst mod_pos_pos_trivial)
     apply (simp add: le_diff_eq uint_2p_alt)
    apply (rule less_1_helper)
    apply (rule power_increasing; simp)
   apply (subst mod_pos_pos_trivial)
     apply (simp add: uint_2p_alt)
    apply (rule less_1_helper)
    apply (rule power_increasing; simp)
   apply (subst int_div_sub_1; simp add: uint_2p_alt)
   apply (subst power_0[symmetric])
   apply (simp add: uint_2p_alt le_imp_power_dvd power_sub_int)
   done
 
 
 lemma word_add_power_off:
   fixes a :: "'a :: len word"
   assumes ak: "a < k"
   and kw: "k < 2 ^ (LENGTH('a) - m)"
   and mw: "m < LENGTH('a)"
   and off: "off < 2 ^ m"
   shows "(a * 2 ^ m) + off < k * 2 ^ m"
 proof (cases "m = 0")
   case True
   then show ?thesis using off ak by simp
 next
   case False
 
   from ak have ak1: "a + 1 \<le> k" by (rule inc_le)
   then have "(a + 1) * 2 ^ m \<noteq> 0"
     apply -
     apply (rule word_power_nonzero)
     apply (erule order_le_less_trans  [OF _ kw])
     apply (rule mw)
     apply (rule less_is_non_zero_p1 [OF ak])
     done
   then have "(a * 2 ^ m) + off < ((a + 1) * 2 ^ m)" using kw mw
     apply -
     apply (simp add: distrib_right)
     apply (rule word_plus_strict_mono_right [OF off])
     apply (rule is_aligned_no_overflow'')
     apply (rule is_aligned_mult_triv2)
     apply assumption
     done
   also have "\<dots> \<le> k * 2 ^ m" using ak1 mw kw False
     apply -
     apply (erule word_mult_le_mono1)
     apply (simp add: p2_gt_0)
     apply (simp add: word_less_nat_alt)
     apply (rule nat_less_power_trans2[simplified])
     apply (simp add: word_less_nat_alt)
     apply simp
     done
   finally show ?thesis .
 qed
 
 lemma offset_not_aligned:
   "\<lbrakk> is_aligned (p::'a::len word) n; i > 0; i < 2 ^ n; n < LENGTH('a)\<rbrakk> \<Longrightarrow>
    \<not> is_aligned (p + of_nat i) n"
   apply (erule is_aligned_add_not_aligned)
   apply transfer
   apply (auto simp add: is_aligned_iff_udvd)
   apply (metis bintrunc_bintrunc_ge int_ops(1) nat_int_comparison(1) nat_less_le take_bit_eq_0_iff take_bit_nat_eq_self_iff take_bit_of_nat)
   done
 
 lemma length_upto_enum_one:
   fixes x :: "'a :: len word"
   assumes lt1: "x < y" and lt2: "z < y" and lt3: "x \<le> z"
   shows "[x , y .e. z] = [x]"
   unfolding upto_enum_step_def
 proof (subst upto_enum_red, subst if_not_P [OF leD [OF lt3]], clarsimp, rule conjI)
   show "unat ((z - x) div (y - x)) = 0"
   proof (subst unat_div, rule div_less)
     have syx: "unat (y - x) = unat y - unat x"
       by (rule unat_sub [OF order_less_imp_le]) fact
     moreover have "unat (z - x) = unat z - unat x"
       by (rule unat_sub) fact
 
     ultimately show "unat (z - x) < unat (y - x)"
       using lt2 lt3 unat_mono word_less_minus_mono_left by blast
   qed
 
   then show "(z - x) div (y - x) * (y - x) = 0"
     by (metis mult_zero_left unat_0 word_unat.Rep_eqD)
 qed
 
 lemma max_word_mask:
   "(max_word :: 'a::len word) = mask LENGTH('a)"
   unfolding mask_eq_decr_exp by simp
 
 lemmas mask_len_max = max_word_mask[symmetric]
 
 lemma mask_out_first_mask_some:
   "\<lbrakk> x AND NOT (mask n) = y; n \<le> m \<rbrakk> \<Longrightarrow> x AND NOT (mask m) = y AND NOT (mask m)"
   for x y :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma mask_lower_twice:
   "n \<le> m \<Longrightarrow> (x AND NOT (mask n)) AND NOT (mask m) = x AND NOT (mask m)"
   for x :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma mask_lower_twice2:
   "(a AND NOT (mask n)) AND NOT (mask m) = a AND NOT (mask (max n m))"
   for a :: \<open>'a::len word\<close>
   by (rule bit_word_eqI) (auto simp add: bit_simps)
 
 lemma ucast_and_neg_mask:
   "ucast (x AND NOT (mask n)) = ucast x AND NOT (mask n)"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma ucast_and_mask:
   "ucast (x AND mask n) = ucast x AND mask n"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 lemma ucast_mask_drop:
   "LENGTH('a :: len) \<le> n \<Longrightarrow> (ucast (x AND mask n) :: 'a word) = ucast x"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps dest: bit_imp_le_length)
   done
 
 (* negating a mask which has been shifted to the very left *)
 lemma NOT_mask_shifted_lenword:
   "NOT (mask len << (LENGTH('a) - len) ::'a::len word) = mask (LENGTH('a) - len)"
   by (rule bit_word_eqI)
     (auto simp add: shiftl_word_eq word_size bit_not_iff bit_push_bit_iff bit_mask_iff)
 
 (* Comparisons between different word sizes. *)
 
 lemma eq_ucast_ucast_eq:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> x = ucast y \<Longrightarrow> ucast x = y"
   for x :: "'a::len word" and y :: "'b::len word"
-  by (simp add: is_down ucast_ucast_a)
+  by transfer simp
 
 lemma le_ucast_ucast_le:
   "x \<le> ucast y \<Longrightarrow> ucast x \<le> y"
   for x :: "'a::len word" and y :: "'b::len word"
   by (smt le_unat_uoi linorder_not_less order_less_imp_le ucast_nat_def unat_arith_simps(1))
 
 lemma less_ucast_ucast_less:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> x < ucast y \<Longrightarrow> ucast x < y"
   for x :: "'a::len word" and y :: "'b::len word"
   by (metis ucast_nat_def unat_mono unat_ucast_up_simp word_of_nat_less)
 
 lemma ucast_le_ucast:
   "LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> (ucast x \<le> (ucast y::'b::len word)) = (x \<le> y)"
   for x :: "'a::len word"
   by (simp add: unat_arith_simps(1) unat_ucast_up_simp)
 
 lemmas ucast_up_mono_le = ucast_le_ucast[THEN iffD2]
 
 lemma ucast_le_ucast_eq:
   fixes x y :: "'a::len word"
   assumes x: "x < 2 ^ n"
   assumes y: "y < 2 ^ n"
   assumes n: "n = LENGTH('b::len)"
   shows "(UCAST('a \<rightarrow> 'b) x \<le> UCAST('a \<rightarrow> 'b) y) = (x \<le> y)"
   apply (rule iffI)
    apply (cases "LENGTH('b) < LENGTH('a)")
     apply (subst less_mask_eq[OF x, symmetric])
     apply (subst less_mask_eq[OF y, symmetric])
     apply (unfold n)
     apply (subst ucast_ucast_mask[symmetric])+
     apply (simp add: ucast_le_ucast)+
   apply (erule ucast_mono_le[OF _ y[unfolded n]])
   done
 
 lemma ucast_or_distrib:
   fixes x :: "'a::len word"
   fixes y :: "'a::len word"
   shows "(ucast (x OR y) :: ('b::len) word) = ucast x OR ucast y"
   by transfer simp
 
 lemma shiftr_less:
   "(w::'a::len word) < k \<Longrightarrow> w >> n < k"
   by (metis div_le_dividend le_less_trans shiftr_div_2n' unat_arith_simps(2))
 
 lemma word_and_notzeroD:
   "w AND w' \<noteq> 0 \<Longrightarrow> w \<noteq> 0 \<and> w' \<noteq> 0"
   by auto
 
 lemma word_exists_nth:
   "(w::'a::len word) \<noteq> 0 \<Longrightarrow> \<exists>i. w !! i"
   by (simp add: bit_eq_iff test_bit_word_eq)
 
 lemma shiftr_le_0:
   "unat (w::'a::len word) < 2 ^ n \<Longrightarrow> w >> n = (0::'a::len word)"
   by (rule word_unat.Rep_eqD) (simp add: shiftr_div_2n')
 
 lemma of_nat_shiftl:
   "(of_nat x << n) = (of_nat (x * 2 ^ n) :: ('a::len) word)"
 proof -
   have "(of_nat x::'a word) << n = of_nat (2 ^ n) * of_nat x"
     using shiftl_t2n by (metis word_unat_power)
   thus ?thesis by simp
 qed
 
 lemma shiftl_1_not_0:
   "n < LENGTH('a) \<Longrightarrow> (1::'a::len word) << n \<noteq> 0"
   by (simp add: shiftl_t2n)
 
 lemma max_word_not_0 [simp]:
   "- 1 \<noteq> (0 :: 'a::len word)"
   by simp
 
 lemma ucast_zero_is_aligned:
   "UCAST('a::len \<rightarrow> 'b::len) w = 0 \<Longrightarrow> n \<le> LENGTH('b) \<Longrightarrow> is_aligned w n"
   by (clarsimp simp: is_aligned_mask word_eq_iff word_size nth_ucast)
 
 lemma unat_ucast_eq_unat_and_mask:
   "unat (UCAST('b::len \<rightarrow> 'a::len) w) = unat (w AND mask LENGTH('a))"
-  proof -
-    have "unat (UCAST('b \<rightarrow> 'a) w) = unat (UCAST('a \<rightarrow> 'b) (UCAST('b \<rightarrow> 'a) w))"
-      by (cases "LENGTH('a) < LENGTH('b)"; simp add: is_down ucast_ucast_a unat_ucast_up_simp)
-    thus ?thesis using ucast_ucast_mask by simp
-  qed
+  apply (simp flip: take_bit_eq_mask)
+  apply transfer
+  apply (simp add: ac_simps)
+  done
 
 lemma unat_max_word_pos[simp]: "0 < unat (- 1 :: 'a::len word)"
   using unat_gt_0 [of \<open>- 1 :: 'a::len word\<close>] by simp
 
 
 (* Miscellaneous conditional injectivity rules. *)
 
 lemma mult_pow2_inj:
   assumes ws: "m + n \<le> LENGTH('a)"
   assumes le: "x \<le> mask m" "y \<le> mask m"
   assumes eq: "x * 2 ^ n = y * (2 ^ n::'a::len word)"
   shows "x = y"
 proof (rule bit_word_eqI)
   fix q
   assume \<open>q < LENGTH('a)\<close>
   from eq have \<open>push_bit n x = push_bit n y\<close>
     by (simp add: push_bit_eq_mult)
   moreover from le have \<open>take_bit m x = x\<close> \<open>take_bit m y = y\<close>
     by (simp_all add: less_eq_mask_iff_take_bit_eq_self)
   ultimately have \<open>push_bit n (take_bit m x) = push_bit n (take_bit m y)\<close>
     by simp_all
   with \<open>q < LENGTH('a)\<close> ws show \<open>bit x q \<longleftrightarrow> bit y q\<close>
     apply (simp add: push_bit_take_bit)
     unfolding bit_eq_iff
     apply (simp add: bit_simps not_le)
     apply (metis (full_types) \<open>take_bit m x = x\<close> \<open>take_bit m y = y\<close> add.commute add_diff_cancel_right' add_less_cancel_right bit_take_bit_iff le_add2 less_le_trans)
     done
 qed
 
 lemma word_of_nat_inj:
   assumes bounded: "x < 2 ^ LENGTH('a)" "y < 2 ^ LENGTH('a)"
   assumes of_nats: "of_nat x = (of_nat y :: 'a::len word)"
   shows "x = y"
   by (rule contrapos_pp[OF of_nats]; cases "x < y"; cases "y < x")
      (auto dest: bounded[THEN of_nat_mono_maybe])
 
 (* Uints *)
 
 lemma uints_mono_iff: "uints l \<subseteq> uints m \<longleftrightarrow> l \<le> m"
   using power_increasing_iff[of "2::int" l m]
   apply (auto simp: uints_num subset_iff simp del: power_increasing_iff)
   by (meson less_irrefl not_less zle2p)
 
 lemmas uints_monoI = uints_mono_iff[THEN iffD2]
 
 lemma Bit_in_uints_Suc: "of_bool c + 2 * w \<in> uints (Suc m)" if "w \<in> uints m"
   using that
   by (auto simp: uints_num)
 
 lemma Bit_in_uintsI: "of_bool c + 2 * w \<in> uints m" if "w \<in> uints (m - 1)" "m > 0"
   using Bit_in_uints_Suc[OF that(1)] that(2)
   by auto
 
 lemma bin_cat_in_uintsI:
   \<open>bin_cat a n b \<in> uints m\<close> if \<open>a \<in> uints l\<close> \<open>m \<ge> l + n\<close>
 proof -
   from \<open>m \<ge> l + n\<close> obtain q where \<open>m = l + n + q\<close>
     using le_Suc_ex by blast
   then have \<open>(2::int) ^ m = 2 ^ n * 2 ^ (l + q)\<close>
     by (simp add: ac_simps power_add)
   moreover have \<open>a mod 2 ^ (l + q) = a\<close>
     using \<open>a \<in> uints l\<close>
     by (auto simp add: uints_def take_bit_eq_mod power_add Divides.mod_mult2_eq)
   ultimately have \<open>concat_bit n b a = take_bit m (concat_bit n b a)\<close>
     by (simp add: concat_bit_eq take_bit_eq_mod push_bit_eq_mult Divides.mod_mult2_eq)
   then show ?thesis
     by (simp add: uints_def)
 qed
 
 lemma bin_cat_cong: "bin_cat a n b = bin_cat c m d"
   if "n = m" "a = c" "bintrunc m b = bintrunc m d"
   using that(3) unfolding that(1,2) by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma bin_cat_eqD1: "bin_cat a n b = bin_cat c n d \<Longrightarrow> a = c"
   by (metis drop_bit_bin_cat_eq)
 
 lemma bin_cat_eqD2: "bin_cat a n b = bin_cat c n d \<Longrightarrow> bintrunc n b = bintrunc n d"
   by (metis take_bit_bin_cat_eq)
   
 lemma bin_cat_inj: "(bin_cat a n b) = bin_cat c n d \<longleftrightarrow> a = c \<and> bintrunc n b = bintrunc n d"
   by (auto intro: bin_cat_cong bin_cat_eqD1 bin_cat_eqD2)
 
 lemma word_of_int_bin_cat_eq_iff:
   "(word_of_int (bin_cat (uint a) LENGTH('b) (uint b))::'c::len word) =
   word_of_int (bin_cat (uint c) LENGTH('b) (uint d)) \<longleftrightarrow> b = d \<and> a = c"
   if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
   for a::"'a::len word" and b::"'b::len word"
   by (subst word_uint.Abs_inject)
      (auto simp: bin_cat_inj intro!: that bin_cat_in_uintsI)
 
 lemma word_cat_inj: "(word_cat a b::'c::len word) = word_cat c d \<longleftrightarrow> a = c \<and> b = d"
   if "LENGTH('a) + LENGTH('b) \<le> LENGTH('c)"
   for a::"'a::len word" and b::"'b::len word"
   using word_of_int_bin_cat_eq_iff [OF that, of b a d c]
   by transfer auto
 
 lemma p2_eq_1: "2 ^ n = (1::'a::len word) \<longleftrightarrow> n = 0"
 proof -
   have "2 ^ n = (1::'a word) \<Longrightarrow> n = 0"
     by (metis One_nat_def not_less one_less_numeral_iff p2_eq_0 p2_gt_0 power_0 power_0
         power_inject_exp semiring_norm(76) unat_power_lower zero_neq_one)
   then show ?thesis by auto
 qed
 
 (* usually: x,y = (len_of TYPE ('a)) *)
 lemma bitmagic_zeroLast_leq_or1Last:
   "(a::('a::len) word) AND (mask len << x - len) \<le> a OR mask (y - len)"
   by (meson le_word_or2 order_trans word_and_le2)
 
 
 lemma zero_base_lsb_imp_set_eq_as_bit_operation:
   fixes base ::"'a::len word"
   assumes valid_prefix: "mask (LENGTH('a) - len) AND base = 0"
   shows "(base = NOT (mask (LENGTH('a) - len)) AND a) \<longleftrightarrow>
          (a \<in> {base .. base OR mask (LENGTH('a) - len)})"
 proof
   have helper3: "x OR y = x OR y AND NOT x" for x y ::"'a::len word" by (simp add: word_oa_dist2)
   from assms show "base = NOT (mask (LENGTH('a) - len)) AND a \<Longrightarrow>
                     a \<in> {base..base OR mask (LENGTH('a) - len)}"
     apply(simp add: word_and_le1)
     apply(metis helper3 le_word_or2 word_bw_comms(1) word_bw_comms(2))
   done
 next
   assume "a \<in> {base..base OR mask (LENGTH('a) - len)}"
   hence a: "base \<le> a \<and> a \<le> base OR mask (LENGTH('a) - len)" by simp
   show "base = NOT (mask (LENGTH('a) - len)) AND a"
   proof -
     have f2: "\<forall>x\<^sub>0. base AND NOT (mask x\<^sub>0) \<le> a AND NOT (mask x\<^sub>0)"
       using a neg_mask_mono_le by blast
     have f3: "\<forall>x\<^sub>0. a AND NOT (mask x\<^sub>0) \<le> (base OR mask (LENGTH('a) - len)) AND NOT (mask x\<^sub>0)"
       using a neg_mask_mono_le by blast
     have f4: "base = base AND NOT (mask (LENGTH('a) - len))"
       using valid_prefix by (metis mask_eq_0_eq_x word_bw_comms(1))
     hence f5: "\<forall>x\<^sub>6. (base OR x\<^sub>6) AND NOT (mask (LENGTH('a) - len)) =
                       base OR x\<^sub>6 AND NOT (mask (LENGTH('a) - len))"
       using word_ao_dist by (metis)
     have f6: "\<forall>x\<^sub>2 x\<^sub>3. a AND NOT (mask x\<^sub>2) \<le> x\<^sub>3 \<or>
                       \<not> (base OR mask (LENGTH('a) - len)) AND NOT (mask x\<^sub>2) \<le> x\<^sub>3"
       using f3 dual_order.trans by auto
     have "base = (base OR mask (LENGTH('a) - len)) AND NOT (mask (LENGTH('a) - len))"
       using f5 by auto
     hence "base = a AND NOT (mask (LENGTH('a) - len))"
       using f2 f4 f6 by (metis eq_iff)
     thus "base = NOT (mask (LENGTH('a) - len)) AND a"
       by (metis word_bw_comms(1))
   qed
 qed
 
 lemma of_nat_eq_signed_scast:
   "(of_nat x = (y :: ('a::len) signed word))
    = (of_nat x = (scast y :: 'a word))"
   by (metis scast_of_nat scast_scast_id(2))
 
 lemma word_aligned_add_no_wrap_bounded:
   "\<lbrakk> w + 2^n \<le> x; w + 2^n \<noteq> 0; is_aligned w n \<rbrakk> \<Longrightarrow> (w::'a::len word) < x"
   by (blast dest: is_aligned_no_overflow le_less_trans word_leq_le_minus_one)
 
 lemma mask_Suc:
   "mask (Suc n) = (2 :: 'a::len word) ^ n + mask n"
   by (simp add: mask_eq_decr_exp)
 
 lemma mask_mono:
   "sz' \<le> sz \<Longrightarrow> mask sz' \<le> (mask sz :: 'a::len word)"
   by (simp add: le_mask_iff shiftr_mask_le)
 
 lemma aligned_mask_disjoint:
   "\<lbrakk> is_aligned (a :: 'a :: len word) n; b \<le> mask n \<rbrakk> \<Longrightarrow> a AND b = 0"
   by (metis and_zero_eq is_aligned_mask le_mask_imp_and_mask word_bw_lcs(1))
 
 lemma word_and_or_mask_aligned:
   "\<lbrakk> is_aligned a n; b \<le> mask n \<rbrakk> \<Longrightarrow> a + b = a OR b"
   by (simp add: aligned_mask_disjoint word_plus_and_or_coroll)
 
 lemma word_and_or_mask_aligned2:
   \<open>is_aligned b n \<Longrightarrow> a \<le> mask n \<Longrightarrow> a + b = a OR b\<close>
   using word_and_or_mask_aligned [of b n a] by (simp add: ac_simps)
   
 lemma is_aligned_ucastI:
   "is_aligned w n \<Longrightarrow> is_aligned (ucast w) n"
   apply transfer
   apply (auto simp add: min_def)
   apply (metis bintrunc_bintrunc_ge bintrunc_n_0 nat_less_le not_le take_bit_eq_0_iff)
   done
 
 lemma ucast_le_maskI:
   "a \<le> mask n \<Longrightarrow> UCAST('a::len \<rightarrow> 'b::len) a \<le> mask n"
   by (metis and_mask_eq_iff_le_mask ucast_and_mask)
 
 lemma ucast_add_mask_aligned:
   "\<lbrakk> a \<le> mask n; is_aligned b n \<rbrakk> \<Longrightarrow> UCAST ('a::len \<rightarrow> 'b::len) (a + b) = ucast a + ucast b"
   by (metis add.commute is_aligned_ucastI ucast_le_maskI ucast_or_distrib word_and_or_mask_aligned)
 
 lemma ucast_shiftl:
   "LENGTH('b) \<le> LENGTH ('a) \<Longrightarrow> UCAST ('a::len \<rightarrow> 'b::len) x << n = ucast (x << n)"
   by word_eqI_solve
 
 lemma ucast_leq_mask:
   "LENGTH('a) \<le> n \<Longrightarrow> ucast (x::'a::len word) \<le> mask n"
   apply (simp add: less_eq_mask_iff_take_bit_eq_self)
   apply transfer
   apply (simp add: ac_simps)
   done
 
 lemma shiftl_inj:
   "\<lbrakk> x << n = y << n; x \<le> mask (LENGTH('a)-n); y \<le> mask (LENGTH('a)-n) \<rbrakk> \<Longrightarrow>
    x = (y :: 'a :: len word)"
   apply word_eqI
   apply (rename_tac n')
   apply (case_tac "LENGTH('a) - n \<le> n'", simp)
   by (metis add.commute add.right_neutral diff_add_inverse le_diff_conv linorder_not_less zero_order(1))
 
 lemma distinct_word_add_ucast_shift_inj:
   "\<lbrakk> p + (UCAST('a::len \<rightarrow> 'b::len) off << n) = p' + (ucast off' << n);
      is_aligned p n'; is_aligned p' n'; n' = n + LENGTH('a); n' < LENGTH('b) \<rbrakk>
    \<Longrightarrow> p' = p \<and> off' = off"
   apply (simp add: word_and_or_mask_aligned le_mask_shiftl_le_mask[where n="LENGTH('a)"]
                    ucast_leq_mask)
   apply (simp add: is_aligned_nth)
   apply (rule conjI; word_eqI)
    apply (metis add.commute test_bit_conj_lt diff_add_inverse le_diff_conv nat_less_le)
   apply (rename_tac i)
   apply (erule_tac x="i+n" in allE)
   apply simp
   done
 
 lemma word_upto_Nil:
   "y < x \<Longrightarrow> [x .e. y ::'a::len word] = []"
   by (simp add: upto_enum_red not_le word_less_nat_alt)
 
 lemma word_enum_decomp_elem:
   assumes "[x .e. (y ::'a::len word)] = as @ a # bs"
   shows "x \<le> a \<and> a \<le> y"
 proof -
   have "set as \<subseteq> set [x .e. y] \<and> a \<in> set [x .e. y]"
     using assms by (auto dest: arg_cong[where f=set])
   then show ?thesis by auto
 qed
 
 lemma max_word_not_less[simp]:
    "\<not> max_word < x"
   by (simp add: not_less)
 
 lemma word_enum_prefix:
   "[x .e. (y ::'a::len word)] = as @ a # bs \<Longrightarrow> as = (if x < a then [x .e. a - 1] else [])"
   apply (induct as arbitrary: x; clarsimp)
    apply (case_tac "x < y")
     prefer 2
     apply (case_tac "x = y", simp)
     apply (simp add: not_less)
     apply (drule (1) dual_order.not_eq_order_implies_strict)
     apply (simp add: word_upto_Nil)
    apply (simp add: word_upto_Cons_eq)
   apply (case_tac "x < y")
    prefer 2
    apply (case_tac "x = y", simp)
    apply (simp add: not_less)
    apply (drule (1) dual_order.not_eq_order_implies_strict)
    apply (simp add: word_upto_Nil)
   apply (clarsimp simp: word_upto_Cons_eq)
   apply (frule word_enum_decomp_elem)
   apply clarsimp
   apply (rule conjI)
    prefer 2
    apply (subst word_Suc_le[symmetric]; clarsimp)
   apply (drule meta_spec)
   apply (drule (1) meta_mp)
   apply clarsimp
   apply (rule conjI; clarsimp)
   apply (subst (2) word_upto_Cons_eq)
    apply unat_arith
   apply simp
   done
 
 lemma word_enum_decomp_set:
   "[x .e. (y ::'a::len word)] = as @ a # bs \<Longrightarrow> a \<notin> set as"
   by (metis distinct_append distinct_enum_upto' not_distinct_conv_prefix)
 
 lemma word_enum_decomp:
   assumes "[x .e. (y ::'a::len word)] = as @ a # bs"
   shows "x \<le> a \<and> a \<le> y \<and> a \<notin> set as \<and> (\<forall>z \<in> set as. x \<le> z \<and> z \<le> y)"
 proof -
   from assms
   have "set as \<subseteq> set [x .e. y] \<and> a \<in> set [x .e. y]"
     by (auto dest: arg_cong[where f=set])
   with word_enum_decomp_set[OF assms]
   show ?thesis by auto
 qed
 
 lemma of_nat_unat_le_mask_ucast:
   "\<lbrakk>of_nat (unat t) = w; t \<le> mask LENGTH('a)\<rbrakk> \<Longrightarrow> t = UCAST('a::len \<rightarrow> 'b::len) w"
   by (clarsimp simp: ucast_nat_def ucast_ucast_mask simp flip: and_mask_eq_iff_le_mask)
 
 lemma less_diff_gt0:
   "a < b \<Longrightarrow> (0 :: 'a :: len word) < b - a"
   by unat_arith
 
 lemma unat_plus_gt:
   "unat ((a :: 'a :: len word) + b) \<le> unat a + unat b"
   by (clarsimp simp: unat_plus_if_size)
 
 lemma const_less:
   "\<lbrakk> (a :: 'a :: len word) - 1 < b; a \<noteq> b \<rbrakk> \<Longrightarrow> a < b"
   by (metis less_1_simp word_le_less_eq)
 
 lemma add_mult_aligned_neg_mask:
   \<open>(x + y * m) AND NOT(mask n) = (x AND NOT(mask n)) + y * m\<close>
   if \<open>m AND (2 ^ n - 1) = 0\<close>
   for x y m :: \<open>'a::len word\<close>
   by (metis (no_types, hide_lams)
     add.assoc add.commute add.right_neutral add_uminus_conv_diff
    mask_eq_decr_exp mask_eqs(2) mask_eqs(6) mult.commute mult_zero_left
    subtract_mask(1) that)
 
 lemma unat_of_nat_minus_1:
   "\<lbrakk> n < 2 ^ LENGTH('a); n \<noteq> 0 \<rbrakk> \<Longrightarrow> unat ((of_nat n:: 'a :: len word) - 1) = n - 1"
   by (simp add: of_nat_diff unat_eq_of_nat)
 
 lemma word_eq_zeroI:
   "a \<le> a - 1 \<Longrightarrow> a = 0" for a :: "'a :: len word"
   by (simp add: word_must_wrap)
 
 lemma word_add_format:
   "(-1 :: 'a :: len  word) + b + c = b + (c - 1)"
   by simp
 
 lemma upto_enum_word_nth:
   "\<lbrakk> i \<le> j; k \<le> unat (j - i) \<rbrakk> \<Longrightarrow> [i .e. j] ! k = i + of_nat k"
   apply (clarsimp simp: upto_enum_def nth_append)
   apply (clarsimp simp: word_le_nat_alt[symmetric])
   apply (rule conjI, clarsimp)
    apply (subst toEnum_of_nat, unat_arith)
    apply unat_arith
   apply (clarsimp simp: not_less unat_sub[symmetric])
   apply unat_arith
   done
 
 lemma upto_enum_step_nth:
   "\<lbrakk> a \<le> c; n \<le> unat ((c - a) div (b - a)) \<rbrakk>
    \<Longrightarrow> [a, b .e. c] ! n = a + of_nat n * (b - a)"
   by (clarsimp simp: upto_enum_step_def not_less[symmetric] upto_enum_word_nth)
 
 lemma upto_enum_inc_1_len:
   "a < - 1 \<Longrightarrow> [(0 :: 'a :: len word) .e. 1 + a] = [0 .e. a] @ [1 + a]"
   apply (simp add: upto_enum_word)
   apply (subgoal_tac "unat (1+a) = 1 + unat a")
    apply simp
   apply (subst unat_plus_simple[THEN iffD1])
    apply (metis add.commute no_plus_overflow_neg olen_add_eqv)
   apply unat_arith
   done
 
 lemma neg_mask_add:
   "y AND mask n = 0 \<Longrightarrow> x + y AND NOT(mask n) = (x AND NOT(mask n)) + y"
   for x y :: \<open>'a::len word\<close>
   by (clarsimp simp: mask_out_sub_mask mask_eqs(7)[symmetric] mask_twice)
 
 lemma shiftr_shiftl_shiftr[simp]:
   "(x :: 'a :: len word)  >> a << a >> a = x >> a"
   by word_eqI_solve
 
 lemma add_right_shift:
   "\<lbrakk> x AND mask n = 0; y AND mask n = 0; x \<le> x + y \<rbrakk>
    \<Longrightarrow> (x + y :: ('a :: len) word) >> n = (x >> n) + (y >> n)"
   apply (simp add: no_olen_add_nat is_aligned_mask[symmetric])
   apply (simp add: unat_arith_simps shiftr_div_2n' split del: if_split)
   apply (subst if_P)
    apply (erule order_le_less_trans[rotated])
    apply (simp add: add_mono)
   apply (simp add: shiftr_div_2n' is_aligned_iff_dvd_nat)
   done
 
 lemma sub_right_shift:
   "\<lbrakk> x AND mask n = 0; y AND mask n = 0; y \<le> x \<rbrakk>
    \<Longrightarrow> (x - y) >> n = (x >> n :: 'a :: len word) - (y >> n)"
   using add_right_shift[where x="x - y" and y=y and n=n]
   by (simp add: aligned_sub_aligned is_aligned_mask[symmetric] word_sub_le)
 
 lemma and_and_mask_simple:
   "y AND mask n = mask n \<Longrightarrow> (x AND y) AND mask n = x AND mask n"
   by (simp add: ac_simps)
 
 lemma and_and_mask_simple_not:
   "y AND mask n = 0 \<Longrightarrow> (x AND y) AND mask n = 0"
   by (simp add: ac_simps)
 
 lemma word_and_le':
   "b \<le> c \<Longrightarrow> (a :: 'a :: len word) AND b \<le> c"
   by (metis word_and_le1 order_trans)
 
 lemma word_and_less':
   "b < c \<Longrightarrow> (a :: 'a :: len word) AND b < c"
   by transfer simp
 
 lemma shiftr_w2p:
   "x < LENGTH('a) \<Longrightarrow> 2 ^ x = (2 ^ (LENGTH('a) - 1) >> (LENGTH('a) - 1 - x) :: 'a :: len word)"
   by word_eqI_solve
 
 lemma t2p_shiftr:
   "\<lbrakk> b \<le> a; a < LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ a >> b = 2 ^ (a - b)"
   by word_eqI_solve
 
 lemma scast_1[simp]:
   "scast (1 :: 'a :: len signed word) = (1 :: 'a word)"
   by simp
 
 lemma ucast_ucast_mask_eq:
   "\<lbrakk> UCAST('a::len \<rightarrow> 'b::len) x = y; x AND mask LENGTH('b) = x \<rbrakk> \<Longrightarrow> x = ucast y"
   by word_eqI_solve
 
 lemma ucast_up_eq:
   "\<lbrakk> ucast x = (ucast y::'b::len word); LENGTH('a) \<le> LENGTH ('b) \<rbrakk>
    \<Longrightarrow> ucast x = (ucast y::'a::len word)"
   by word_eqI_solve
 
 lemma ucast_up_neq:
   "\<lbrakk> ucast x \<noteq> (ucast y::'b::len word); LENGTH('b) \<le> LENGTH ('a) \<rbrakk>
    \<Longrightarrow> ucast x \<noteq> (ucast y::'a::len word)"
   by (fastforce dest: ucast_up_eq)
 
 lemma mask_AND_less_0:
   "\<lbrakk> x AND mask n = 0; m \<le> n \<rbrakk> \<Longrightarrow> x AND mask m = 0"
   for x :: \<open>'a::len word\<close>
   by (metis mask_twice2 word_and_notzeroD)
 
 lemma mask_len_id [simp]:
   "(x :: 'a :: len word) AND mask LENGTH('a) = x"
   using uint_lt2p [of x] by (simp add: mask_eq_iff)
 
 lemma scast_ucast_down_same:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow> SCAST('a \<rightarrow> 'b) = UCAST('a::len \<rightarrow> 'b::len)"
   by (simp add: down_cast_same is_down)
 
 lemma word_aligned_0_sum:
   "\<lbrakk> a + b = 0; is_aligned (a :: 'a :: len word) n; b \<le> mask n; n < LENGTH('a) \<rbrakk>
    \<Longrightarrow> a = 0 \<and> b = 0"
   by (simp add: word_plus_and_or_coroll aligned_mask_disjoint word_or_zero)
 
 lemma mask_eq1_nochoice:
   "\<lbrakk> LENGTH('a) > 1; (x :: 'a :: len word) AND 1 = x \<rbrakk> \<Longrightarrow> x = 0 \<or> x = 1"
   by (metis word_and_1)
 
 lemma shiftr_and_eq_shiftl:
   "(w >> n) AND x = y \<Longrightarrow> w AND (x << n) = (y << n)" for y :: "'a:: len word"
   by (metis (no_types, lifting) and_not_mask bit.conj_ac(1) bit.conj_ac(2) mask_eq_0_eq_x shiftl_mask_is_0 shiftl_over_and_dist)
 
 lemma add_mask_lower_bits':
   "\<lbrakk> len = LENGTH('a); is_aligned (x :: 'a :: len word) n;
      \<forall>n' \<ge> n. n' < len \<longrightarrow> \<not> p !! n' \<rbrakk>
    \<Longrightarrow> x + p AND NOT(mask n) = x"
   using add_mask_lower_bits by auto
 
 lemma leq_mask_shift:
   "(x :: 'a :: len word) \<le> mask (low_bits + high_bits) \<Longrightarrow> (x >> low_bits) \<le> mask high_bits"
   by (simp add: le_mask_iff shiftr_shiftr)
 
 lemma ucast_ucast_eq_mask_shift:
   "(x :: 'a :: len word) \<le> mask (low_bits + LENGTH('b))
    \<Longrightarrow> ucast((ucast (x >> low_bits)) :: 'b :: len word) = x >> low_bits"
   by (meson and_mask_eq_iff_le_mask eq_ucast_ucast_eq not_le_imp_less shiftr_less_t2n'
             ucast_ucast_len)
 
 lemma const_le_unat:
   "\<lbrakk> b < 2 ^ LENGTH('a); of_nat b \<le> a \<rbrakk> \<Longrightarrow> b \<le> unat (a :: 'a :: len word)"
   apply (simp add: word_le_def)
   apply (simp only: uint_nat zle_int)
   apply transfer
   apply (simp add: take_bit_nat_eq_self)
   done
 
 lemma upt_enum_offset_trivial:
   "\<lbrakk> x < 2 ^ LENGTH('a) - 1 ; n \<le> unat x \<rbrakk>
    \<Longrightarrow> ([(0 :: 'a :: len word) .e. x] ! n) = of_nat n"
   apply (induct x arbitrary: n)
     apply simp
   by (simp add: upto_enum_word_nth)
 
 lemma word_le_mask_out_plus_2sz:
   "x \<le> (x AND NOT(mask sz)) + 2 ^ sz - 1"
   for x :: \<open>'a::len word\<close>
   by (metis add_diff_eq word_neg_and_le)
 
 lemma ucast_add:
   "ucast (a + (b :: 'a :: len word)) = ucast a + (ucast b :: ('a signed word))"
   by transfer (simp add: take_bit_add)
 
 lemma ucast_minus:
   "ucast (a - (b :: 'a :: len word)) = ucast a - (ucast b :: ('a signed word))"
   apply (insert ucast_add[where a=a and b="-b"])
   apply (metis (no_types, hide_lams) add_diff_eq diff_add_cancel ucast_add)
   done
 
 lemma scast_ucast_add_one [simp]:
   "scast (ucast (x :: 'a::len word) + (1 :: 'a signed word)) = x + 1"
   apply (subst ucast_1[symmetric])
   apply (subst ucast_add[symmetric])
   apply clarsimp
   done
 
 lemma word_and_le_plus_one:
   "a > 0 \<Longrightarrow> (x :: 'a :: len word) AND (a - 1) < a"
   by (simp add: gt0_iff_gem1 word_and_less')
 
 lemma unat_of_ucast_then_shift_eq_unat_of_shift[simp]:
   "LENGTH('b) \<ge> LENGTH('a)
    \<Longrightarrow> unat ((ucast (x :: 'a :: len word) :: 'b :: len word) >> n) = unat (x >> n)"
   by (simp add: shiftr_div_2n' unat_ucast_up_simp)
 
 lemma unat_of_ucast_then_mask_eq_unat_of_mask[simp]:
   "LENGTH('b) \<ge> LENGTH('a)
    \<Longrightarrow> unat ((ucast (x :: 'a :: len word) :: 'b :: len word) AND mask m) = unat (x AND mask m)"
   by (metis ucast_and_mask unat_ucast_up_simp)
 
 lemma shiftr_less_t2n3:
   "\<lbrakk> (2 :: 'a word) ^ (n + m) = 0; m < LENGTH('a) \<rbrakk>
    \<Longrightarrow> (x :: 'a :: len word) >> n < 2 ^ m"
   by (fastforce intro: shiftr_less_t2n' simp: mask_eq_decr_exp power_overflow)
 
 lemma unat_shiftr_le_bound:
   "\<lbrakk> 2 ^ (LENGTH('a :: len) - n) - 1 \<le> bnd; 0 < n \<rbrakk>
    \<Longrightarrow> unat ((x :: 'a word) >> n) \<le> bnd"
-  using less_not_refl3 le_step_down_nat le_trans less_or_eq_imp_le word_shiftr_lt
-  by (metis (no_types, lifting))
+  apply transfer
+  apply (simp add: take_bit_drop_bit)
+  apply (simp add: drop_bit_take_bit)
+  apply (rule order_trans)
+   defer
+   apply assumption
+  apply (simp add: nat_le_iff of_nat_diff)
+  done
 
 lemma shiftr_eqD:
   "\<lbrakk> x >> n = y >> n; is_aligned x n; is_aligned y n \<rbrakk>
    \<Longrightarrow> x = y"
   by (metis is_aligned_shiftr_shiftl)
 
 lemma word_shiftr_shiftl_shiftr_eq_shiftr:
   "a \<ge> b \<Longrightarrow> (x :: 'a :: len word) >> a << b >> b = x >> a"
   by (simp add: mask_shift multi_shift_simps(5) shiftr_shiftr)
 
 lemma of_int_uint_ucast:
    "of_int (uint (x :: 'a::len word)) = (ucast x :: 'b::len word)"
   by (fact Word.of_int_uint)
 
 lemma mod_mask_drop:
   "\<lbrakk> m = 2 ^ n; 0 < m; mask n AND msk = mask n \<rbrakk>
    \<Longrightarrow> (x mod m) AND msk = x mod m"
   for x :: \<open>'a::len word\<close>
   by (simp add: word_mod_2p_is_mask word_bw_assocs)
 
 lemma mask_eq_ucast_eq:
   "\<lbrakk> x AND mask LENGTH('a) = (x :: ('c :: len word));
      LENGTH('a) \<le> LENGTH('b)\<rbrakk>
     \<Longrightarrow> ucast (ucast x :: ('a :: len word)) = (ucast x :: ('b :: len word))"
   by (metis ucast_and_mask ucast_id ucast_ucast_mask ucast_up_eq)
 
 lemma of_nat_less_t2n:
   "of_nat i < (2 :: ('a :: len) word) ^ n \<Longrightarrow> n < LENGTH('a) \<and> unat (of_nat i :: 'a word) < 2 ^ n"
   by (metis order_less_trans p2_gt_0 unat_less_power word_neq_0_conv)
 
 lemma two_power_increasing_less_1:
   "\<lbrakk> n \<le> m; m \<le> LENGTH('a) \<rbrakk> \<Longrightarrow> (2 :: 'a :: len word) ^ n - 1 \<le> 2 ^ m - 1"
   by (metis diff_diff_cancel le_m1_iff_lt less_imp_diff_less p2_gt_0 two_power_increasing
             word_1_le_power word_le_minus_mono_left word_less_sub_1)
 
 lemma word_sub_mono4:
   "\<lbrakk> y + x \<le> z + x; y \<le> y + x; z \<le> z + x \<rbrakk> \<Longrightarrow> y \<le> z" for y :: "'a :: len word"
   by (simp add: word_add_le_iff2)
 
 lemma eq_or_less_helperD:
   "\<lbrakk> n = unat (2 ^ m - 1 :: 'a :: len word) \<or> n < unat (2 ^ m - 1 :: 'a word); m < LENGTH('a) \<rbrakk>
    \<Longrightarrow> n < 2 ^ m"
   by (meson le_less_trans nat_less_le unat_less_power word_power_less_1)
 
 lemma mask_sub:
   "n \<le> m \<Longrightarrow> mask m - mask n = mask m AND NOT(mask n :: 'a::len word)"
   by (metis (full_types) and_mask_eq_iff_shiftr_0 mask_out_sub_mask shiftr_mask_le word_bw_comms(1))
 
 lemma neg_mask_diff_bound:
   "sz'\<le> sz \<Longrightarrow> (ptr AND NOT(mask sz')) - (ptr AND NOT(mask sz)) \<le> 2 ^ sz - 2 ^ sz'"
   (is "_ \<Longrightarrow> ?lhs \<le> ?rhs")
   for ptr :: \<open>'a::len word\<close>
 proof -
   assume lt: "sz' \<le> sz"
   hence "?lhs = ptr AND (mask sz AND NOT(mask sz'))"
     by (metis add_diff_cancel_left' multiple_mask_trivia)
   also have "\<dots> \<le> ?rhs" using lt
     by (metis (mono_tags) add_diff_eq diff_eq_eq eq_iff mask_2pm1 mask_sub word_and_le')
   finally show ?thesis by simp
 qed
 
 lemma mask_out_eq_0:
   "\<lbrakk> idx < 2 ^ sz; sz < LENGTH('a) \<rbrakk> \<Longrightarrow> (of_nat idx :: 'a :: len word) AND NOT(mask sz) = 0"
-  by (simp add: Word_Lemmas.of_nat_power less_mask_eq mask_eq_0_eq_x)
+  by (simp add: of_nat_power less_mask_eq mask_eq_0_eq_x)
 
 lemma is_aligned_neg_mask_eq':
   "is_aligned ptr sz = (ptr AND NOT(mask sz) = ptr)"
   using is_aligned_mask mask_eq_0_eq_x by blast
 
 lemma neg_mask_mask_unat:
   "sz < LENGTH('a)
    \<Longrightarrow> unat ((ptr :: 'a :: len word) AND NOT(mask sz)) + unat (ptr AND mask sz) = unat ptr"
   by (metis AND_NOT_mask_plus_AND_mask_eq unat_plus_simple word_and_le2)
 
 lemma unat_pow_le_intro:
   "LENGTH('a) \<le> n \<Longrightarrow> unat (x :: 'a :: len word) < 2 ^ n"
   by (metis lt2p_lem not_le of_nat_le_iff of_nat_numeral semiring_1_class.of_nat_power uint_nat)
 
 lemma unat_shiftl_less_t2n:
   "\<lbrakk> unat (x :: 'a :: len word) < 2 ^ (m - n); m < LENGTH('a) \<rbrakk> \<Longrightarrow> unat (x << n) < 2 ^ m"
-  by (metis (no_types) Word_Lemmas.of_nat_power diff_le_self le_less_trans shiftl_less_t2n
+  by (metis (no_types) of_nat_power diff_le_self le_less_trans shiftl_less_t2n
                        unat_less_power word_unat.Rep_inverse)
 
 lemma unat_is_aligned_add:
   "\<lbrakk> is_aligned p n; unat d < 2 ^ n \<rbrakk>
    \<Longrightarrow> unat (p + d AND mask n) = unat d \<and> unat (p + d AND NOT(mask n)) = unat p"
   by (metis add.right_neutral and_mask_eq_iff_le_mask and_not_mask le_mask_iff mask_add_aligned
             mask_out_add_aligned mult_zero_right shiftl_t2n shiftr_le_0)
 
 lemma unat_shiftr_shiftl_mask_zero:
   "\<lbrakk> c + a \<ge> LENGTH('a) + b ; c < LENGTH('a) \<rbrakk>
    \<Longrightarrow> unat (((q :: 'a :: len word) >> a << b) AND NOT(mask c)) = 0"
   by (fastforce intro: unat_is_aligned_add[where p=0 and n=c, simplified, THEN conjunct2]
                        unat_shiftl_less_t2n unat_shiftr_less_t2n unat_pow_le_intro)
 
 lemmas of_nat_ucast = ucast_of_nat[symmetric]
 
 lemma shift_then_mask_eq_shift_low_bits:
   "x \<le> mask (low_bits + high_bits) \<Longrightarrow> (x >> low_bits) AND mask high_bits = x >> low_bits"
   for x :: \<open>'a::len word\<close>
   by (simp add: leq_mask_shift le_mask_imp_and_mask)
 
 lemma leq_low_bits_iff_zero:
   "\<lbrakk> x \<le> mask (low bits + high bits); x >> low_bits = 0 \<rbrakk> \<Longrightarrow> (x AND mask low_bits = 0) = (x = 0)"
   for x :: \<open>'a::len word\<close>
   using and_mask_eq_iff_shiftr_0 by force
 
 lemma unat_less_iff:
   "\<lbrakk> unat (a :: 'a :: len word) = b; c < 2 ^ LENGTH('a) \<rbrakk> \<Longrightarrow> (a < of_nat c) = (b < c)"
   using unat_ucast_less_no_overflow_simp by blast
 
 lemma is_aligned_no_overflow3:
  "\<lbrakk> is_aligned (a :: 'a :: len word) n; n < LENGTH('a); b < 2 ^ n; c \<le> 2 ^ n; b < c \<rbrakk>
   \<Longrightarrow> a + b \<le> a + (c - 1)"
   by (meson is_aligned_no_wrap' le_m1_iff_lt not_le word_less_sub_1 word_plus_mono_right)
 
 lemma mask_add_aligned_right:
   "is_aligned p n \<Longrightarrow> (q + p) AND mask n = q AND mask n"
   by (simp add: mask_add_aligned add.commute)
 
 lemma leq_high_bits_shiftr_low_bits_leq_bits_mask:
   "x \<le> mask high_bits \<Longrightarrow> (x :: 'a :: len word) << low_bits \<le> mask (low_bits + high_bits)"
   by (metis le_mask_shiftl_le_mask)
 
 lemma word_two_power_neg_ineq:
   "2 ^ m \<noteq> (0 :: 'a word) \<Longrightarrow> 2 ^ n \<le> - (2 ^ m :: 'a :: len word)"
   apply (cases "n < LENGTH('a)"; simp add: power_overflow)
   apply (cases "m < LENGTH('a)"; simp add: power_overflow)
   apply (simp add: word_le_nat_alt unat_minus word_size)
   apply (cases "LENGTH('a)"; simp)
   apply (simp add: less_Suc_eq_le)
   apply (drule power_increasing[where a=2 and n=n] power_increasing[where a=2 and n=m], simp)+
   apply (drule(1) add_le_mono)
   apply simp
   done
 
 lemma unat_shiftl_absorb:
   "\<lbrakk> x \<le> 2 ^ p; p + k < LENGTH('a) \<rbrakk> \<Longrightarrow> unat (x :: 'a :: len word) * 2 ^ k = unat (x * 2 ^ k)"
   by (smt add_diff_cancel_right' add_lessD1 le_add2 le_less_trans mult.commute nat_le_power_trans
           unat_lt2p unat_mult_lem unat_power_lower word_le_nat_alt)
 
 lemma word_plus_mono_right_split:
   "\<lbrakk> unat ((x :: 'a :: len word) AND mask sz) + unat z < 2 ^ sz; sz < LENGTH('a) \<rbrakk>
    \<Longrightarrow> x \<le> x + z"
   apply (subgoal_tac "(x AND NOT(mask sz)) + (x AND mask sz) \<le> (x AND NOT(mask sz)) + ((x AND mask sz) + z)")
    apply (simp add:word_plus_and_or_coroll2 field_simps)
   apply (rule word_plus_mono_right)
    apply (simp add: less_le_trans no_olen_add_nat)
-  using Word_Lemmas.of_nat_power is_aligned_no_wrap' by force
+  using of_nat_power is_aligned_no_wrap' by force
 
 lemma mul_not_mask_eq_neg_shiftl:
   "NOT(mask n :: 'a::len word) = -1 << n"
   by (simp add: NOT_mask shiftl_t2n)
 
 lemma shiftr_mul_not_mask_eq_and_not_mask:
   "(x >> n) * NOT(mask n) = - (x AND NOT(mask n))"
   for x :: \<open>'a::len word\<close>
   by (metis NOT_mask and_not_mask mult_minus_left semiring_normalization_rules(7) shiftl_t2n)
 
 lemma mask_eq_n1_shiftr:
   "n \<le> LENGTH('a) \<Longrightarrow> (mask n :: 'a :: len word) = -1 >> (LENGTH('a) - n)"
   by (metis diff_diff_cancel eq_refl mask_full shiftr_mask2)
 
 lemma is_aligned_mask_out_add_eq:
   "is_aligned p n \<Longrightarrow> (p + x) AND NOT(mask n) = p + (x AND NOT(mask n))"
   by (simp add: mask_out_sub_mask mask_add_aligned)
 
 lemmas is_aligned_mask_out_add_eq_sub
     = is_aligned_mask_out_add_eq[where x="a - b" for a b, simplified field_simps]
 
 lemma aligned_bump_down:
   "is_aligned x n \<Longrightarrow> (x - 1) AND NOT(mask n) = x - 2 ^ n"
   by (drule is_aligned_mask_out_add_eq[where x="-1"]) (simp add: NOT_mask)
 
 lemma unat_2tp_if:
   "unat (2 ^ n :: ('a :: len) word) = (if n < LENGTH ('a) then 2 ^ n else 0)"
   by (split if_split, simp_all add: power_overflow)
 
 lemma mask_of_mask:
   "mask (n::nat) AND mask (m::nat) = (mask (min m n) :: 'a::len word)"
   by word_eqI_solve
 
 lemma unat_signed_ucast_less_ucast:
   "LENGTH('a) \<le> LENGTH('b) \<Longrightarrow> unat (ucast (x :: 'a :: len word) :: 'b :: len signed word) = unat x"
   by (simp add: unat_ucast_up_simp)
 
 lemma toEnum_of_ucast:
   "LENGTH('b) \<le> LENGTH('a) \<Longrightarrow>
    (toEnum (unat (b::'b :: len word))::'a :: len word) = of_nat (unat b)"
   by (simp add: unat_pow_le_intro)
 
 lemmas unat_ucast_mask = unat_ucast_eq_unat_and_mask[where w=a for a]
 
 lemma t2n_mask_eq_if:
   "2 ^ n AND mask m = (if n < m then 2 ^ n else (0 :: 'a::len word))"
     by (rule word_eqI, auto simp add: word_size nth_w2p split: if_split)
 
 lemma unat_ucast_le:
   "unat (ucast (x :: 'a :: len word) :: 'b :: len word) \<le> unat x"
   by (simp add: ucast_nat_def word_unat_less_le)
 
 lemma ucast_le_up_down_iff:
   "\<lbrakk> LENGTH('a) \<le> LENGTH('b); (x :: 'b :: len word) \<le> ucast (max_word :: 'a :: len word) \<rbrakk>
    \<Longrightarrow> (ucast x \<le> (y :: 'a word)) = (x \<le> ucast y)"
   using le_max_word_ucast_id ucast_le_ucast by metis
 
 lemma ucast_ucast_mask_shift:
   "a \<le> LENGTH('a) + b
    \<Longrightarrow> ucast (ucast (p AND mask a >> b) :: 'a :: len word) = p AND mask a >> b"
   by (metis add.commute le_mask_iff shiftr_mask_le ucast_ucast_eq_mask_shift word_and_le')
 
 lemma unat_ucast_mask_shift:
   "a \<le> LENGTH('a) + b
    \<Longrightarrow> unat (ucast (p AND mask a >> b) :: 'a :: len word) = unat (p AND mask a >> b)"
   by (metis linear ucast_ucast_mask_shift unat_ucast_up_simp)
 
 lemma mask_overlap_zero:
   "a \<le> b \<Longrightarrow> (p AND mask a) AND NOT(mask b) = 0"
   for p :: \<open>'a::len word\<close>
   by (metis NOT_mask_AND_mask mask_lower_twice2 max_def)
 
 lemma mask_shifl_overlap_zero:
   "a + c \<le> b \<Longrightarrow> (p AND mask a << c) AND NOT(mask b) = 0"
   for p :: \<open>'a::len word\<close>
   by (metis and_mask_0_iff_le_mask mask_mono mask_shiftl_decompose order_trans shiftl_over_and_dist word_and_le' word_and_le2)
 
 lemma mask_overlap_zero':
   "a \<ge> b \<Longrightarrow> (p AND NOT(mask a)) AND mask b = 0"
   for p :: \<open>'a::len word\<close>
   using mask_AND_NOT_mask mask_AND_less_0 by blast
 
 lemma mask_rshift_mult_eq_rshift_lshift:
   "((a :: 'a :: len word) >> b) * (1 << c) = (a >> b << c)"
   by (simp add: shiftl_t2n)
 
 lemma shift_alignment:
   "a \<ge> b \<Longrightarrow> is_aligned (p >> a << a) b"
   using is_aligned_shift is_aligned_weaken by blast
 
 lemma mask_split_sum_twice:
   "a \<ge> b \<Longrightarrow> (p AND NOT(mask a)) + ((p AND mask a) AND NOT(mask b)) + (p AND mask b) = p"
   for p :: \<open>'a::len word\<close>
   by (simp add: add.commute multiple_mask_trivia word_bw_comms(1) word_bw_lcs(1) word_plus_and_or_coroll2)
 
 lemma mask_shift_eq_mask_mask:
   "(p AND mask a >> b << b) = (p AND mask a) AND NOT(mask b)"
   for p :: \<open>'a::len word\<close>
   by (simp add: and_not_mask)
 
 lemma mask_shift_sum:
   "\<lbrakk> a \<ge> b; unat n = unat (p AND mask b) \<rbrakk>
    \<Longrightarrow> (p AND NOT(mask a)) + (p AND mask a >> b) * (1 << b) + n = (p :: 'a :: len word)"
   by (metis and_not_mask mask_rshift_mult_eq_rshift_lshift mask_split_sum_twice word_unat.Rep_eqD)
 
 lemma is_up_compose:
   "\<lbrakk> is_up uc; is_up uc' \<rbrakk> \<Longrightarrow> is_up (uc' \<circ> uc)"
   unfolding is_up_def by (simp add: Word.target_size Word.source_size)
 
 lemma of_int_sint_scast:
   "of_int (sint (x :: 'a :: len word)) = (scast x :: 'b :: len word)"
   by (fact Word.of_int_sint) 
 
 lemma scast_of_nat_to_signed [simp]:
   "scast (of_nat x :: 'a :: len word) = (of_nat x :: 'a signed word)"
   by transfer simp
 
 lemma scast_of_nat_signed_to_unsigned_add:
   "scast (of_nat x + of_nat y :: 'a :: len signed word) = (of_nat x + of_nat y :: 'a :: len word)"
   by (metis of_nat_add scast_of_nat)
 
 lemma scast_of_nat_unsigned_to_signed_add:
   "(scast (of_nat x + of_nat y :: 'a :: len word)) = (of_nat x + of_nat y :: 'a :: len signed word)"
   by (metis Abs_fnat_hom_add scast_of_nat_to_signed)
 
 lemma and_mask_cases:
   fixes x :: "'a :: len word"
   assumes len: "n < LENGTH('a)"
   shows "x AND mask n \<in> of_nat ` set [0 ..< 2 ^ n]"
   apply (simp flip: take_bit_eq_mask)
   apply (rule image_eqI [of _ _ \<open>unat (take_bit n x)\<close>])
   using len apply simp_all
   apply transfer
   apply simp
   done
 
 lemma sint_eq_uint_2pl:
   "\<lbrakk> (a :: 'a :: len word) < 2 ^ (LENGTH('a) - 1) \<rbrakk>
    \<Longrightarrow> sint a = uint a"
   by (simp add: not_msb_from_less sint_eq_uint word_2p_lem word_size)
 
 lemma pow_sub_less:
   "\<lbrakk> a + b \<le> LENGTH('a); unat (x :: 'a :: len word) = 2 ^ a \<rbrakk>
    \<Longrightarrow> unat (x * 2 ^ b - 1) < 2 ^ (a + b)"
   by (metis (mono_tags) eq_or_less_helperD not_less of_nat_numeral power_add
                         semiring_1_class.of_nat_power unat_pow_le_intro word_unat.Rep_inverse)
 
 lemma sle_le_2pl:
   "\<lbrakk> (b :: 'a :: len word) < 2 ^ (LENGTH('a) - 1); a \<le> b \<rbrakk> \<Longrightarrow> a <=s b"
   by (simp add: not_msb_from_less word_sle_msb_le)
 
 lemma sless_less_2pl:
   "\<lbrakk> (b :: 'a :: len word) < 2 ^ (LENGTH('a) - 1); a < b \<rbrakk> \<Longrightarrow> a <s b"
   using not_msb_from_less word_sless_msb_less by blast
 
 lemma and_mask2:
   "w << n >> n = w AND mask (size w - n)"
   for w :: \<open>'a::len word\<close>
   by (cases "n \<le> size w"; clarsimp simp: word_and_le2 and_mask shiftl_zero_size)
 
 lemma aligned_sub_aligned_simple:
   "\<lbrakk> is_aligned a n; is_aligned b n \<rbrakk> \<Longrightarrow> is_aligned (a - b) n"
   by (simp add: aligned_sub_aligned)
 
 lemma minus_one_shift:
   "- (1 << n) = (-1 << n :: 'a::len word)"
   by (simp add: mask_eq_decr_exp NOT_eq flip: mul_not_mask_eq_neg_shiftl)
 
 lemma ucast_eq_mask:
   "(UCAST('a::len \<rightarrow> 'b::len) x = UCAST('a \<rightarrow> 'b) y) =
    (x AND mask LENGTH('b) = y AND mask LENGTH('b))"
   by (rule iffI; word_eqI_solve)
 
 context
   fixes w :: "'a::len word"
 begin
 
 private lemma sbintrunc_uint_ucast:
   assumes "Suc n = LENGTH('b::len)"
   shows "sbintrunc n (uint (ucast w :: 'b word)) = sbintrunc n (uint w)"
   by (metis assms sbintrunc_bintrunc ucast_eq word_ubin.eq_norm)
 
 private lemma test_bit_sbintrunc:
   assumes "i < LENGTH('a)"
   shows "(word_of_int (sbintrunc n (uint w)) :: 'a word) !! i
            = (if n < i then w !! n else w !! i)"
   using assms by (simp add: nth_sbintr)
                  (simp add: test_bit_bin)
 
 private lemma test_bit_sbintrunc_ucast:
   assumes len_a: "i < LENGTH('a)"
   shows "(word_of_int (sbintrunc (LENGTH('b) - 1) (uint (ucast w :: 'b word))) :: 'a word) !! i
           = (if LENGTH('b::len) \<le> i then w !! (LENGTH('b) - 1) else w !! i)"
   apply (subst sbintrunc_uint_ucast)
    apply simp
   apply (subst test_bit_sbintrunc)
    apply (rule len_a)
   apply (rule if_cong[OF _ refl refl])
   using leD less_linear by fastforce
 
 lemma scast_ucast_high_bits:
   \<open>scast (ucast w :: 'b::len word) = w
      \<longleftrightarrow> (\<forall> i \<in> {LENGTH('b) ..< size w}. w !! i = w !! (LENGTH('b) - 1))\<close>
 proof (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
   case True
   moreover define m where \<open>m = LENGTH('b) - LENGTH('a)\<close>
   ultimately have \<open>LENGTH('b) = m + LENGTH('a)\<close>
     by simp
   then show ?thesis
     apply (simp_all add: signed_ucast_eq word_size)
     apply (rule bit_word_eqI)
     apply (simp add: bit_signed_take_bit_iff)
     done
 next
   case False
   define q where \<open>q = LENGTH('b) - 1\<close>
   then have \<open>LENGTH('b) = Suc q\<close>
     by simp
   moreover define m where \<open>m = Suc LENGTH('a) - LENGTH('b)\<close>
   with False \<open>LENGTH('b) = Suc q\<close> have \<open>LENGTH('a) = m + q\<close>
     by (simp add: not_le)
   ultimately show ?thesis
     apply (simp_all add: signed_ucast_eq word_size)
     apply (transfer fixing: m q)
     apply (simp add: signed_take_bit_take_bit)
     apply rule
     apply (subst bit_eq_iff)
     apply (simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def)
     apply (auto simp add: Suc_le_eq)
     using less_imp_le_nat apply blast
     using less_imp_le_nat apply blast
     done
 qed
   
 lemma scast_ucast_mask_compare:
   "scast (ucast w :: 'b::len word) = w
    \<longleftrightarrow> (w \<le> mask (LENGTH('b) - 1) \<or> NOT(mask (LENGTH('b) - 1)) \<le> w)"
   apply (clarsimp simp: le_mask_high_bits neg_mask_le_high_bits scast_ucast_high_bits word_size)
   apply (rule iffI; clarsimp)
    apply (rename_tac i j; case_tac "i = LENGTH('b) - 1"; case_tac "j = LENGTH('b) - 1")
   by auto
 
 lemma ucast_less_shiftl_helper':
   "\<lbrakk> LENGTH('b) + (a::nat) < LENGTH('a); 2 ^ (LENGTH('b) + a) \<le> n\<rbrakk>
    \<Longrightarrow> (ucast (x :: 'b::len word) << a) < (n :: 'a::len word)"
   apply (erule order_less_le_trans[rotated])
   using ucast_less[where x=x and 'a='a]
   apply (simp only: shiftl_t2n field_simps)
   apply (rule word_less_power_trans2; simp)
   done
 
 end
 
 lemma ucast_ucast_mask2:
   "is_down (UCAST ('a \<rightarrow> 'b)) \<Longrightarrow>
    UCAST ('b::len \<rightarrow> 'c::len) (UCAST ('a::len \<rightarrow> 'b::len) x) = UCAST ('a \<rightarrow> 'c) (x AND mask LENGTH('b))"
   by word_eqI_solve
 
 lemma ucast_NOT:
   "ucast (NOT x) = NOT(ucast x) AND mask (LENGTH('a))" for x::"'a::len word"
   by word_eqI
 
 lemma ucast_NOT_down:
   "is_down UCAST('a::len \<rightarrow> 'b::len) \<Longrightarrow> UCAST('a \<rightarrow> 'b) (NOT x) = NOT(UCAST('a \<rightarrow> 'b) x)"
   by word_eqI
 
 lemma upto_enum_step_shift:
   "\<lbrakk> is_aligned p n \<rbrakk> \<Longrightarrow>
   ([p , p + 2 ^ m .e. p + 2 ^ n - 1])
       = map ((+) p) [0, 2 ^ m .e. 2 ^ n - 1]"
   apply (erule is_aligned_get_word_bits)
    prefer 2
    apply (simp add: map_idI)
   apply (clarsimp simp: upto_enum_step_def)
   apply (frule is_aligned_no_overflow)
   apply (simp add: linorder_not_le [symmetric])
   done
 
 lemma upto_enum_step_shift_red:
   "\<lbrakk> is_aligned p sz; sz < LENGTH('a); us \<le> sz \<rbrakk>
      \<Longrightarrow> [p :: 'a :: len word, p + 2 ^ us .e. p + 2 ^ sz - 1]
           = map (\<lambda>x. p + of_nat x * 2 ^ us) [0 ..< 2 ^ (sz - us)]"
   apply (subst upto_enum_step_shift, assumption)
   apply (simp add: upto_enum_step_red)
   done
 
 lemma upto_enum_step_subset:
   "set [x, y .e. z] \<subseteq> {x .. z}"
   apply (clarsimp simp: upto_enum_step_def linorder_not_less)
   apply (drule div_to_mult_word_lt)
   apply (rule conjI)
    apply (erule word_random[rotated])
    apply simp
   apply (rule order_trans)
    apply (erule word_plus_mono_right)
    apply simp
   apply simp
   done
 
-lemma if_and_helper:
-  "(If x v v') AND v'' = If x (v AND v'') (v' AND v'')"
-  by (rule if_distrib)
+
+lemma ucast_distrib:
+  fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
+  fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
+  fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
+  assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
+  assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
+  assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
+                               = (L x y) mod (2 ^ LENGTH('b))"
+  assumes is_down: "is_down (ucast :: 'a word \<Rightarrow> 'b word)"
+  shows "ucast (M a b) = M' (ucast a) (ucast b)"
+  apply (simp only: ucast_eq)
+  apply (subst lift_M)
+  apply (subst of_int_uint [symmetric], subst lift_M')
+  apply (subst (1 2) int_word_uint)
+  apply (subst word_ubin.norm_eq_iff [symmetric])
+  apply (subst (1 2) bintrunc_mod2p)
+  apply (insert is_down)
+  apply (unfold is_down_def)
+  apply (clarsimp simp: target_size source_size)
+  apply (clarsimp simp: mod_exp_eq min_def)
+  apply (rule distrib [symmetric])
+  done
+
+lemma ucast_down_add:
+    "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) + b) = (ucast a + ucast b :: 'b::len word)"
+  by (rule ucast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
+
+lemma ucast_down_minus:
+    "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) - b) = (ucast a - ucast b :: 'b::len word)"
+  apply (rule ucast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
+  apply (metis mod_diff_left_eq mod_diff_right_eq)
+  apply simp
+  done
+
+lemma ucast_down_mult:
+    "is_down (ucast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  ucast ((a :: 'a::len word) * b) = (ucast a * ucast b :: 'b::len word)"
+  apply (rule ucast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
+  apply (metis mod_mult_eq)
+  apply simp
+  done
+
+lemma scast_distrib:
+  fixes M :: "'a::len word \<Rightarrow> 'a::len word \<Rightarrow> 'a::len word"
+  fixes M' :: "'b::len word \<Rightarrow> 'b::len word \<Rightarrow> 'b::len word"
+  fixes L :: "int \<Rightarrow> int \<Rightarrow> int"
+  assumes lift_M: "\<And>x y. uint (M x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('a)"
+  assumes lift_M': "\<And>x y. uint (M' x y) = L (uint x) (uint y)  mod 2 ^ LENGTH('b)"
+  assumes distrib: "\<And>x y. (L (x mod (2 ^ LENGTH('b))) (y mod (2 ^ LENGTH('b)))) mod (2 ^ LENGTH('b))
+                               = (L x y) mod (2 ^ LENGTH('b))"
+  assumes is_down: "is_down (scast :: 'a word \<Rightarrow> 'b word)"
+  shows "scast (M a b) = M' (scast a) (scast b)"
+  apply (subst (1 2 3) down_cast_same [symmetric])
+   apply (insert is_down)
+   apply (clarsimp simp: is_down_def target_size source_size is_down)
+  apply (rule ucast_distrib [where L=L, OF lift_M lift_M' distrib])
+  apply (insert is_down)
+  apply (clarsimp simp: is_down_def target_size source_size is_down)
+  done
+
+lemma scast_down_add:
+    "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) + b) = (scast a + scast b :: 'b::len word)"
+  by (rule scast_distrib [where L="(+)"], (clarsimp simp: uint_word_ariths)+, presburger, simp)
+
+lemma scast_down_minus:
+    "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) - b) = (scast a - scast b :: 'b::len word)"
+  apply (rule scast_distrib [where L="(-)"], (clarsimp simp: uint_word_ariths)+)
+  apply (metis mod_diff_left_eq mod_diff_right_eq)
+  apply simp
+  done
+
+lemma scast_down_mult:
+    "is_down (scast:: 'a word \<Rightarrow> 'b word) \<Longrightarrow>  scast ((a :: 'a::len word) * b) = (scast a * scast b :: 'b::len word)"
+  apply (rule scast_distrib [where L="(*)"], (clarsimp simp: uint_word_ariths)+)
+  apply (metis mod_mult_eq)
+  apply simp
+  done
+
+lemma scast_ucast_1:
+  "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
+  by (metis down_cast_same ucast_eq ucast_down_wi)
+
+lemma scast_ucast_3:
+  "\<lbrakk> is_down (ucast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
+  by (metis down_cast_same ucast_eq ucast_down_wi)
+
+lemma scast_ucast_4:
+  "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+         (scast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
+  by (metis down_cast_same ucast_eq ucast_down_wi)
+
+lemma scast_scast_b:
+  "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
+     (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
+  by (metis scast_eq sint_up_scast)
+
+lemma ucast_scast_1:
+  "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+            (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
+  by (metis scast_eq ucast_down_wi)
+
+lemma ucast_scast_3:
+  "\<lbrakk> is_down (scast :: 'a word \<Rightarrow> 'c word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
+  by (metis scast_eq ucast_down_wi)
+
+lemma ucast_scast_4:
+  "\<lbrakk> is_up (scast :: 'a word \<Rightarrow> 'b word); is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+     (ucast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
+  by (metis down_cast_same scast_eq sint_up_scast)
+
+lemma ucast_ucast_a:
+  "\<lbrakk> is_down (ucast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+        (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
+  by (metis down_cast_same ucast_eq ucast_down_wi)
+
+lemma ucast_ucast_b:
+  "\<lbrakk> is_up (ucast :: 'a word \<Rightarrow> 'b word) \<rbrakk> \<Longrightarrow>
+     (ucast (ucast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = ucast a"
+  by (metis ucast_up_ucast)
+
+lemma scast_scast_a:
+  "\<lbrakk> is_down (scast :: 'b word \<Rightarrow> 'c word) \<rbrakk> \<Longrightarrow>
+            (scast (scast (a :: 'a::len word) :: 'b::len word) :: 'c::len word) = scast a"
+  apply (simp only: scast_eq)
+  apply (metis down_cast_same is_up_down scast_eq ucast_down_wi)
+  done
+
+lemma scast_down_wi [OF refl]:
+  "uc = scast \<Longrightarrow> is_down uc \<Longrightarrow> uc (word_of_int x) = word_of_int x"
+  by (metis down_cast_same is_up_down ucast_down_wi)
+
+lemmas cast_simps =
+  is_down is_up
+  scast_down_add scast_down_minus scast_down_mult
+  ucast_down_add ucast_down_minus ucast_down_mult
+  scast_ucast_1 scast_ucast_3 scast_ucast_4
+  ucast_scast_1 ucast_scast_3 ucast_scast_4
+  ucast_ucast_a ucast_ucast_b
+  scast_scast_a scast_scast_b
+  ucast_down_wi scast_down_wi
+  ucast_of_nat scast_of_nat
+  uint_up_ucast sint_up_scast
+  up_scast_surj up_ucast_surj
+
+lemma sdiv_word_max:
+    "(sint (a :: ('a::len) word) sdiv sint (b :: ('a::len) word) < (2 ^ (size a - 1))) =
+          ((a \<noteq> - (2 ^ (size a - 1)) \<or> (b \<noteq> -1)))"
+    (is "?lhs = (\<not> ?a_int_min \<or> \<not> ?b_minus1)")
+proof (rule classical)
+  assume not_thesis: "\<not> ?thesis"
+
+  have not_zero: "b \<noteq> 0"
+    using not_thesis
+    by (clarsimp)
+
+  have result_range: "sint a sdiv sint b \<in> (sints (size a)) \<union> {2 ^ (size a - 1)}"
+    apply (cut_tac sdiv_int_range [where a="sint a" and b="sint b"])
+    apply (erule rev_subsetD)
+    using sint_range' [where x=a]  sint_range' [where x=b]
+    apply (auto simp: max_def abs_if word_size sints_num)
+    done
+
+  have result_range_overflow: "(sint a sdiv sint b = 2 ^ (size a - 1)) = (?a_int_min \<and> ?b_minus1)"
+    apply (rule iffI [rotated])
+     apply (clarsimp simp: signed_divide_int_def sgn_if word_size sint_int_min)
+    apply (rule classical)
+    apply (case_tac "?a_int_min")
+     apply (clarsimp simp: word_size sint_int_min)
+     apply (metis diff_0_right
+              int_sdiv_negated_is_minus1 minus_diff_eq minus_int_code(2)
+              power_eq_0_iff sint_minus1 zero_neq_numeral)
+    apply (subgoal_tac "abs (sint a) < 2 ^ (size a - 1)")
+     apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
+     apply (clarsimp simp: word_size)
+    apply (insert sdiv_int_range [where a="sint a" and b="sint b"])[1]
+    apply (insert word_sint.Rep [where x="a"])[1]
+    apply (clarsimp simp: minus_le_iff word_size abs_if sints_num split: if_split_asm)
+    apply (metis minus_minus sint_int_min word_sint.Rep_inject)
+    done
+
+  have result_range_simple: "(sint a sdiv sint b \<in> (sints (size a))) \<Longrightarrow> ?thesis"
+    apply (insert sdiv_int_range [where a="sint a" and b="sint b"])
+    apply (clarsimp simp: word_size sints_num sint_int_min)
+    done
+
+  show ?thesis
+    apply (rule UnE [OF result_range result_range_simple])
+     apply simp
+    apply (clarsimp simp: word_size)
+    using result_range_overflow
+    apply (clarsimp simp: word_size)
+    done
+qed
+
+lemmas sdiv_word_min' = sdiv_word_min [simplified word_size, simplified]
+lemmas sdiv_word_max' = sdiv_word_max [simplified word_size, simplified]
+
+lemma signed_arith_ineq_checks_to_eq:
+  "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
+    = (sint a + sint b = sint (a + b ))"
+  "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
+    = (sint a - sint b = sint (a - b))"
+  "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
+    = ((- sint a) = sint (- a))"
+  "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
+    = (sint a * sint b = sint (a * b))"
+  "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
+    = (sint a sdiv sint b = sint (a sdiv b))"
+  "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
+    = (sint a smod sint b = sint (a smod b))"
+  by (auto simp: sint_word_ariths word_size signed_div_arith signed_mod_arith
+                    sbintrunc_eq_in_range range_sbintrunc)
+
+lemma signed_arith_sint:
+  "((- (2 ^ (size a - 1)) \<le> (sint a + sint b)) \<and> (sint a + sint b \<le> (2 ^ (size a - 1) - 1)))
+    \<Longrightarrow> sint (a + b) = (sint a + sint b)"
+  "((- (2 ^ (size a - 1)) \<le> (sint a - sint b)) \<and> (sint a - sint b \<le> (2 ^ (size a - 1) - 1)))
+    \<Longrightarrow> sint (a - b) = (sint a - sint b)"
+  "((- (2 ^ (size a - 1)) \<le> (- sint a)) \<and> (- sint a) \<le> (2 ^ (size a - 1) - 1))
+    \<Longrightarrow> sint (- a) = (- sint a)"
+  "((- (2 ^ (size a - 1)) \<le> (sint a * sint b)) \<and> (sint a * sint b \<le> (2 ^ (size a - 1) - 1)))
+    \<Longrightarrow> sint (a * b) = (sint a * sint b)"
+  "((- (2 ^ (size a - 1)) \<le> (sint a sdiv sint b)) \<and> (sint a sdiv sint b \<le> (2 ^ (size a - 1) - 1)))
+    \<Longrightarrow> sint (a sdiv b) = (sint a sdiv sint b)"
+  "((- (2 ^ (size a - 1)) \<le> (sint a smod sint b)) \<and> (sint a smod sint b \<le> (2 ^ (size a - 1) - 1)))
+    \<Longrightarrow> sint (a smod b) = (sint a smod sint b)"
+  by (subst (asm) signed_arith_ineq_checks_to_eq; simp)+
 
 end
diff --git a/thys/Word_Lib/Word_Lib_Sumo.thy b/thys/Word_Lib/Word_Lib_Sumo.thy
--- a/thys/Word_Lib/Word_Lib_Sumo.thy
+++ b/thys/Word_Lib/Word_Lib_Sumo.thy
@@ -1,122 +1,123 @@
 
 section \<open>Ancient comprehensive Word Library\<close>
 
 theory Word_Lib_Sumo
 imports
   "HOL-Library.Word"
   Aligned
   Ancient_Numeral
   Bit_Comprehension
   Bits_Int
   Bitwise_Signed
   Bitwise
   Enumeration_Word
   Generic_set_bit
   Hex_Words
   Least_significant_bit
   More_Arithmetic
   More_Divides
   More_Sublist
   Even_More_List
   More_Misc
   Strict_part_mono
   Legacy_Aliasses
   Most_significant_bit
   Next_and_Prev
   Norm_Words
   Reversed_Bit_Lists
   Rsplit
   Signed_Words
   Traditional_Infix_Syntax
   Typedef_Morphisms
   Type_Syntax
   Word_EqI
   Word_Lemmas
   Word_8
   Word_16
   Word_32
   Word_64
   Word_Syntax
   Signed_Division_Word
   More_Word_Operations
+  Many_More
 begin
 
 declare signed_take_bit_Suc [simp]
 
 lemmas bshiftr1_def = bshiftr1_eq
 lemmas is_down_def = is_down_eq
 lemmas is_up_def = is_up_eq
 lemmas mask_def = mask_eq_decr_exp
 lemmas scast_def = scast_eq
 lemmas shiftl1_def = shiftl1_eq
 lemmas shiftr1_def = shiftr1_eq
 lemmas sshiftr1_def = sshiftr1_eq
 lemmas sshiftr_def = sshiftr_eq_funpow_sshiftr1
 lemmas to_bl_def = to_bl_eq
 lemmas ucast_def = ucast_eq
 lemmas unat_def = unat_eq_nat_uint
 lemmas word_cat_def = word_cat_eq
 lemmas word_reverse_def = word_reverse_eq_of_bl_rev_to_bl
 lemmas word_roti_def = word_roti_eq_word_rotr_word_rotl
 lemmas word_rotl_def = word_rotl_eq
 lemmas word_rotr_def = word_rotr_eq
 lemmas word_sle_def = word_sle_eq
 lemmas word_sless_def = word_sless_eq
 
 lemmas uint_0 = uint_nonnegative
 lemmas uint_lt = uint_bounded
 lemmas uint_mod_same = uint_idem
 lemmas of_nth_def = word_set_bits_def
 
 lemmas of_nat_word_eq_iff = word_of_nat_eq_iff
 lemmas of_nat_word_eq_0_iff = word_of_nat_eq_0_iff
 lemmas of_int_word_eq_iff = word_of_int_eq_iff
 lemmas of_int_word_eq_0_iff = word_of_int_eq_0_iff
 
 lemmas word_next_def = word_next_unfold
 
 lemmas word_prev_def = word_prev_unfold
 
 lemmas is_aligned_def = is_aligned_iff_dvd_nat
 
 lemma shiftl_transfer [transfer_rule]:
   includes lifting_syntax
   shows "(pcr_word ===> (=) ===> pcr_word) (<<) (<<)"
   by (unfold shiftl_eq_push_bit) transfer_prover
 
 lemmas word_and_max_simps =
   word8_and_max_simp
   word16_and_max_simp
   word32_and_max_simp
   word64_and_max_simp
 
 lemma distinct_lemma: "f x \<noteq> f y \<Longrightarrow> x \<noteq> y" by auto
 
 lemmas and_bang = word_and_nth
 
 lemmas sdiv_int_def = signed_divide_int_def
 lemmas smod_int_def = signed_modulo_int_def
 
 (* shortcut for some specific lengths *)
 lemma word_fixed_sint_1[simp]:
   "sint (1::8 word) = 1"
   "sint (1::16 word) = 1"
   "sint (1::32 word) = 1"
   "sint (1::64 word) = 1"
   by (auto simp: sint_word_ariths)
 
 declare of_nat_diff [simp]
 
 (* Haskellish names/syntax *)
 notation (input)
   test_bit ("testBit")
 
 lemmas cast_simps = cast_simps ucast_down_bl
 
 (* shadows the slightly weaker Word.nth_ucast *)
 lemma nth_ucast:
   "(ucast (w::'a::len word)::'b::len word) !! n =
    (w !! n \<and> n < min LENGTH('a) LENGTH('b))"
   by transfer (simp add: bit_take_bit_iff ac_simps)
 
 end