diff --git a/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy b/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy
--- a/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy
+++ b/thys/Berlekamp_Zassenhaus/Finite_Field_Record_Based.thy
@@ -1,1651 +1,1651 @@
 (*
     Authors:      Jose Divasón
                   Sebastiaan Joosten
                   René Thiemann
                   Akihisa Yamada
 *)
 subsection \<open>Finite Fields\<close>
 
 text \<open>We provide four implementations for $GF(p)$ -- the field with $p$ elements for some
   prime $p$ -- one by int, one by integers, one by 32-bit numbers and one 64-bit implementation. 
   Correctness of the implementations is proven by
   transfer rules to the type-based version of $GF(p)$.\<close>
 
 theory Finite_Field_Record_Based
 imports
   Finite_Field
   Arithmetic_Record_Based
   Native_Word.Uint32 
   Native_Word.Uint64
   Native_Word.Code_Target_Bits_Int
   "HOL-Library.Code_Target_Numeral"  
 begin
 
 (* mod on standard case which can immediately be mapped to 
    target languages without considering special cases *)
 definition mod_nonneg_pos :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
   "x \<ge> 0 \<Longrightarrow> y > 0 \<Longrightarrow> mod_nonneg_pos x y = (x mod y)"
   
 code_printing \<comment> \<open>FIXME illusion of partiality\<close>
   constant mod_nonneg_pos \<rightharpoonup>
         (SML) "IntInf.mod/ ( _,/ _ )"
     and (Eval) "IntInf.mod/ ( _,/ _ )"
     and (OCaml) "Z.rem"
     and (Haskell) "Prelude.mod/ ( _ )/ ( _ )"
     and (Scala) "!((k: BigInt) => (l: BigInt) =>/ (k '% l))"
 
 definition mod_nonneg_pos_int :: "int \<Rightarrow> int \<Rightarrow> int" where
   "mod_nonneg_pos_int x y = int_of_integer (mod_nonneg_pos (integer_of_int x) (integer_of_int y))" 
 
 lemma mod_nonneg_pos_int[simp]: "x \<ge> 0 \<Longrightarrow> y > 0 \<Longrightarrow> mod_nonneg_pos_int x y = (x mod y)" 
   unfolding mod_nonneg_pos_int_def using mod_nonneg_pos_def by simp
 
 context
   fixes p :: int
 begin
 definition plus_p :: "int \<Rightarrow> int \<Rightarrow> int" where
   "plus_p x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"
 
 definition minus_p :: "int \<Rightarrow> int \<Rightarrow> int" where
   "minus_p x y \<equiv> if y \<le> x then x - y else x + p - y"
 
 definition uminus_p :: "int \<Rightarrow> int" where
   "uminus_p x = (if x = 0 then 0 else p - x)"
 
 definition mult_p :: "int \<Rightarrow> int \<Rightarrow> int" where
   "mult_p x y = (mod_nonneg_pos_int (x * y) p)"
 
 fun power_p :: "int \<Rightarrow> nat \<Rightarrow> int" where
   "power_p x n = (if n = 0 then 1 else
     let (d,r) = Divides.divmod_nat n 2;
        rec = power_p (mult_p x x) d in
     if r = 0 then rec else mult_p rec x)"
 
 text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
   it turned out that taking the below implementation of inverse via exponentiation
   is faster than the one based on the extended Euclidean algorithm.\<close>
 
 definition inverse_p :: "int \<Rightarrow> int" where
   "inverse_p x = (if x = 0 then 0 else power_p x (nat (p - 2)))"
 
 definition divide_p :: "int \<Rightarrow> int \<Rightarrow> int"  where
   "divide_p x y = mult_p x (inverse_p y)"
 
 definition finite_field_ops_int :: "int arith_ops_record" where
   "finite_field_ops_int \<equiv> Arith_Ops_Record
       0
       1
       plus_p
       mult_p
       minus_p
       uminus_p
       divide_p
       inverse_p
       (\<lambda> x y . if y = 0 then x else 0)
       (\<lambda> x . if x = 0 then 0 else 1)
       (\<lambda> x . x)
       (\<lambda> x . x)
       (\<lambda> x . x)
       (\<lambda> x. 0 \<le> x \<and> x < p)"
 
 end
 
 context
   fixes p :: uint32
 begin
 definition plus_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
   "plus_p32 x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"
 
 definition minus_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
   "minus_p32 x y \<equiv> if y \<le> x then x - y else (x + p) - y"
 
 definition uminus_p32 :: "uint32 \<Rightarrow> uint32" where
   "uminus_p32 x = (if x = 0 then 0 else p - x)"
 
 definition mult_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
   "mult_p32 x y = (x * y mod p)"
 
 lemma int_of_uint32_shift: "int_of_uint32 (shiftr n k) = (int_of_uint32 n) div (2 ^ k)" 
   apply transfer
   apply transfer
   apply (simp add: take_bit_drop_bit min_def)
   apply (simp add: drop_bit_eq_div)
   done
 
 lemma int_of_uint32_0_iff: "int_of_uint32 n = 0 \<longleftrightarrow> n = 0" 
   by (transfer, rule uint_0_iff)
   
 lemma int_of_uint32_0: "int_of_uint32 0 = 0" unfolding int_of_uint32_0_iff by simp
 
 lemma int_of_uint32_ge_0: "int_of_uint32 n \<ge> 0" 
   by (transfer, auto)
 
 lemma two_32: "2 ^ LENGTH(32) = (4294967296 :: int)" by simp
 
 lemma int_of_uint32_plus: "int_of_uint32 (x + y) = (int_of_uint32 x + int_of_uint32 y) mod 4294967296" 
   by (transfer, unfold uint_word_ariths two_32, rule refl)  
 
 lemma int_of_uint32_minus: "int_of_uint32 (x - y) = (int_of_uint32 x - int_of_uint32 y) mod 4294967296" 
   by (transfer, unfold uint_word_ariths two_32, rule refl)  
 
 lemma int_of_uint32_mult: "int_of_uint32 (x * y) = (int_of_uint32 x * int_of_uint32 y) mod 4294967296" 
   by (transfer, unfold uint_word_ariths two_32, rule refl)  
 
 lemma int_of_uint32_mod: "int_of_uint32 (x mod y) = (int_of_uint32 x mod int_of_uint32 y)" 
   by (transfer, unfold uint_mod two_32, rule refl)  
 
 lemma int_of_uint32_inv: "0 \<le> x \<Longrightarrow> x < 4294967296 \<Longrightarrow> int_of_uint32 (uint32_of_int x) = x"
   by transfer (simp add: take_bit_int_eq_self)
 
 function power_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32" where
   "power_p32 x n = (if n = 0 then 1 else
     let rec = power_p32 (mult_p32 x x) (shiftr n 1) in
     if n AND 1 = 0 then rec else mult_p32 rec x)"
   by pat_completeness auto
 
 termination 
 proof -
   {
     fix n :: uint32
     assume "n \<noteq> 0" 
     with int_of_uint32_ge_0[of n] int_of_uint32_0_iff[of n] have "int_of_uint32 n > 0" by auto
     hence "0 < int_of_uint32 n" "int_of_uint32 n div 2 < int_of_uint32 n" by auto
   } note * = this
   show ?thesis
     by (relation "measure (\<lambda> (x,n). nat (int_of_uint32 n))", auto simp: int_of_uint32_shift *) 
 qed
 
 text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
   it turned out that taking the below implementation of inverse via exponentiation
   is faster than the one based on the extended Euclidean algorithm.\<close>
 
 definition inverse_p32 :: "uint32 \<Rightarrow> uint32" where
   "inverse_p32 x = (if x = 0 then 0 else power_p32 x (p - 2))"
 
 definition divide_p32 :: "uint32 \<Rightarrow> uint32 \<Rightarrow> uint32"  where
   "divide_p32 x y = mult_p32 x (inverse_p32 y)"
 
 definition finite_field_ops32 :: "uint32 arith_ops_record" where
   "finite_field_ops32 \<equiv> Arith_Ops_Record
       0
       1
       plus_p32
       mult_p32
       minus_p32
       uminus_p32
       divide_p32
       inverse_p32
       (\<lambda> x y . if y = 0 then x else 0)
       (\<lambda> x . if x = 0 then 0 else 1)
       (\<lambda> x . x)
       uint32_of_int
       int_of_uint32
       (\<lambda> x. 0 \<le> x \<and> x < p)"
 end 
 
 lemma shiftr_uint32_code [code_unfold]: "drop_bit 1 x = (uint32_shiftr x 1)"
   by (simp add: uint32_shiftr_def shiftr_eq_drop_bit)
 
 (* ******************************************************************************** *)
 subsubsection \<open>Transfer Relation\<close>
 locale mod_ring_locale =
   fixes p :: int and ty :: "'a :: nontriv itself"
   assumes p: "p = int CARD('a)"
 begin
 lemma nat_p: "nat p = CARD('a)" unfolding p by simp
 lemma p2: "p \<ge> 2" unfolding p using nontriv[where 'a = 'a] by auto
 lemma p2_ident: "int (CARD('a) - 2) = p - 2" using p2 unfolding p by simp
 
 definition mod_ring_rel :: "int \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
   "mod_ring_rel x x' = (x = to_int_mod_ring x')"
 
 (* domain transfer rules *)
 lemma Domainp_mod_ring_rel [transfer_domain_rule]:
   "Domainp (mod_ring_rel) = (\<lambda> v. v \<in> {0 ..< p})"
 proof -
   {
     fix v :: int
     assume *: "0 \<le> v" "v < p"
     have "Domainp mod_ring_rel v"
     proof
       show "mod_ring_rel v (of_int_mod_ring v)" unfolding mod_ring_rel_def using * p by auto
     qed
   } note * = this
   show ?thesis
     by (intro ext iffI, insert range_to_int_mod_ring[where 'a = 'a] *, auto simp: mod_ring_rel_def p)
 qed
 
 (* left/right/bi-unique *)
 lemma bi_unique_mod_ring_rel [transfer_rule]:
   "bi_unique mod_ring_rel" "left_unique mod_ring_rel" "right_unique mod_ring_rel"
   unfolding mod_ring_rel_def bi_unique_def left_unique_def right_unique_def
   by auto
 
 (* left/right-total *)
 lemma right_total_mod_ring_rel [transfer_rule]: "right_total mod_ring_rel"
   unfolding mod_ring_rel_def right_total_def by simp
 
 
 (* ************************************************************************************ *)
 subsubsection \<open>Transfer Rules\<close>
 
 (* 0 / 1 *)
 lemma mod_ring_0[transfer_rule]: "mod_ring_rel 0 0" unfolding mod_ring_rel_def by simp
 lemma mod_ring_1[transfer_rule]: "mod_ring_rel 1 1" unfolding mod_ring_rel_def by simp
 
 (* addition *)
 lemma plus_p_mod_def: assumes x: "x \<in> {0 ..< p}" and y: "y \<in> {0 ..< p}"
   shows "plus_p p x y = ((x + y) mod p)"
 proof (cases "p \<le> x + y")
   case False
   thus ?thesis using x y unfolding plus_p_def Let_def by auto
 next
   case True
   from True x y have *: "p > 0" "0 \<le> x + y - p" "x + y - p < p" by auto
   from True have id: "plus_p p x y = x + y - p" unfolding plus_p_def by auto
   show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
 qed
 
 lemma mod_ring_plus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (plus_p p) (+)"
 proof -
   {
     fix x y :: "'a mod_ring"
     have "plus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x + y)"
       by (transfer, subst plus_p_mod_def, auto, auto simp: p)
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *)
 qed
 
 (* subtraction *)
 lemma minus_p_mod_def: assumes x: "x \<in> {0 ..< p}" and y: "y \<in> {0 ..< p}"
   shows "minus_p p x y = ((x - y) mod p)"
 proof (cases "x - y < 0")
   case False
   thus ?thesis using x y unfolding minus_p_def Let_def by auto
 next
   case True
   from True x y have *: "p > 0" "0 \<le> x - y + p" "x - y + p < p" by auto
   from True have id: "minus_p p x y = x - y + p" unfolding minus_p_def by auto
   show ?thesis unfolding id using * using mod_pos_pos_trivial by fastforce
 qed
 
 lemma mod_ring_minus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (minus_p p) (-)"
 proof -
   {
     fix x y :: "'a mod_ring"
     have "minus_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x - y)"
       by (transfer, subst minus_p_mod_def, auto simp: p)
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *)
 qed
 
 (* unary minus *)
 lemma mod_ring_uminus[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (uminus_p p) uminus"
 proof -
   {
     fix x :: "'a mod_ring"
     have "uminus_p p (to_int_mod_ring x) = to_int_mod_ring (uminus x)"
       by (transfer, auto simp: uminus_p_def p)
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *)
 qed
 
 (* multiplication *)
 lemma mod_ring_mult[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) (mult_p p) ((*))"
 proof -
   {
     fix x y :: "'a mod_ring"
     have "mult_p p (to_int_mod_ring x) (to_int_mod_ring y) = to_int_mod_ring (x * y)"
       by (transfer, auto simp: mult_p_def p)
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *)
 qed
 
 (* equality *)
 lemma mod_ring_eq[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> (=)) (=) (=)"
   by (intro rel_funI, auto simp: mod_ring_rel_def)
 
 (* power *)
 lemma mod_ring_power[transfer_rule]: "(mod_ring_rel ===> (=) ===> mod_ring_rel) (power_p p) (^)"
 proof (intro rel_funI, clarify, unfold binary_power[symmetric], goal_cases)
   fix x y n
   assume xy: "mod_ring_rel x y"
   from xy show "mod_ring_rel (power_p p x n) (binary_power y n)"
   proof (induct y n arbitrary: x rule: binary_power.induct)
     case (1 x n y)
     note 1(2)[transfer_rule]
     show ?case
     proof (cases "n = 0")
       case True
       thus ?thesis by (simp add: mod_ring_1)
     next
       case False
       obtain d r where id: "Divides.divmod_nat n 2 = (d,r)" by force
       let ?int = "power_p p (mult_p p y y) d"
       let ?gfp = "binary_power (x * x) d"
       from False have id': "?thesis = (mod_ring_rel
          (if r = 0 then ?int else mult_p p ?int y)
          (if r = 0 then ?gfp else ?gfp * x))"
         unfolding power_p.simps[of _ _ n] binary_power.simps[of _ n] Let_def id split by simp
       have [transfer_rule]: "mod_ring_rel ?int ?gfp"
         by (rule 1(1)[OF False refl id[symmetric]], transfer_prover)
       show ?thesis unfolding id' by transfer_prover
     qed
   qed
 qed
 
 declare power_p.simps[simp del]
 
 lemma ring_finite_field_ops_int: "ring_ops (finite_field_ops_int p) mod_ring_rel"
   by (unfold_locales, auto simp:
   finite_field_ops_int_def
   bi_unique_mod_ring_rel
   right_total_mod_ring_rel
   mod_ring_plus
   mod_ring_minus
   mod_ring_uminus
   mod_ring_mult
   mod_ring_eq
   mod_ring_0
   mod_ring_1
   Domainp_mod_ring_rel)
 end
 
 locale prime_field = mod_ring_locale p ty for p and ty :: "'a :: prime_card itself"
 begin
 
 lemma prime: "prime p" unfolding p using prime_card[where 'a = 'a] by simp
 
 (* mod *)
 lemma mod_ring_mod[transfer_rule]:
  "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel) ((\<lambda> x y. if y = 0 then x else 0)) (mod)"
 proof -
   {
     fix x y :: "'a mod_ring"
     have "(if to_int_mod_ring y = 0 then to_int_mod_ring x else 0) = to_int_mod_ring (x mod y)"
       unfolding modulo_mod_ring_def by auto
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
 qed
 
 (* normalize *)
 lemma mod_ring_normalize[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) ((\<lambda> x. if x = 0 then 0 else 1)) normalize"
 proof -
   {
     fix x :: "'a mod_ring"
     have "(if to_int_mod_ring x = 0 then 0 else 1) = to_int_mod_ring (normalize x)"
       unfolding normalize_mod_ring_def by auto
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
 qed
 
 (* unit_factor *)
 lemma mod_ring_unit_factor[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (\<lambda> x. x) unit_factor"
 proof -
   {
     fix x :: "'a mod_ring"
     have "to_int_mod_ring x = to_int_mod_ring (unit_factor x)"
       unfolding unit_factor_mod_ring_def by auto
   } note * = this
   show ?thesis
     by (intro rel_funI, auto simp: mod_ring_rel_def *[symmetric])
 qed
 
 (* inverse *)
 lemma mod_ring_inverse[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel) (inverse_p p) inverse"
 proof (intro rel_funI)
   fix x y
   assume [transfer_rule]: "mod_ring_rel x y"
   show "mod_ring_rel (inverse_p p x) (inverse y)"
     unfolding inverse_p_def inverse_mod_ring_def
     apply (transfer_prover_start)
     apply (transfer_step)+
     apply (unfold p2_ident)
     apply (rule refl)
     done
 qed
 
 (* division *)
 lemma mod_ring_divide[transfer_rule]: "(mod_ring_rel ===> mod_ring_rel ===> mod_ring_rel)
   (divide_p p) (/)"
   unfolding divide_p_def[abs_def] divide_mod_ring_def[abs_def] inverse_mod_ring_def[symmetric]
   by transfer_prover
 
 lemma mod_ring_rel_unsafe: assumes "x < CARD('a)"
   shows "mod_ring_rel (int x) (of_nat x)" "0 < x \<Longrightarrow> of_nat x \<noteq> (0 :: 'a mod_ring)"
 proof -
   have id: "of_nat x = (of_int (int x) :: 'a mod_ring)" by simp
   show "mod_ring_rel (int x) (of_nat x)" "0 < x \<Longrightarrow> of_nat x \<noteq> (0 :: 'a mod_ring)" unfolding id
   unfolding mod_ring_rel_def
   proof (auto simp add: assms of_int_of_int_mod_ring)
     assume "0 < x" with assms
     have "of_int_mod_ring (int x) \<noteq> (0 :: 'a mod_ring)"
       by (metis (no_types) less_imp_of_nat_less less_irrefl of_nat_0_le_iff of_nat_0_less_iff to_int_mod_ring_hom.hom_zero to_int_mod_ring_of_int_mod_ring)
     thus "of_int_mod_ring (int x) = (0 :: 'a mod_ring) \<Longrightarrow> False" by blast
   qed
 qed
 
 lemma finite_field_ops_int: "field_ops (finite_field_ops_int p) mod_ring_rel"
   by (unfold_locales, auto simp:
   finite_field_ops_int_def
   bi_unique_mod_ring_rel
   right_total_mod_ring_rel
   mod_ring_divide
   mod_ring_plus
   mod_ring_minus
   mod_ring_uminus
   mod_ring_inverse
   mod_ring_mod
   mod_ring_unit_factor
   mod_ring_normalize
   mod_ring_mult
   mod_ring_eq
   mod_ring_0
   mod_ring_1
   Domainp_mod_ring_rel)
 
 end
 
 text \<open>Once we have proven the soundness of the implementation, we do not care any longer
   that @{typ "'a mod_ring"} has been defined internally via lifting. Disabling the transfer-rules
   will hide the internal definition in further applications of transfer.\<close>
 lifting_forget mod_ring.lifting
 
 text \<open>For soundness of the 32-bit implementation, we mainly prove that this implementation
   implements the int-based implementation of the mod-ring.\<close>
 context mod_ring_locale
 begin
 
 context fixes pp :: "uint32" 
   assumes ppp: "p = int_of_uint32 pp" 
   and small: "p \<le> 65535" 
 begin
 
 lemmas uint32_simps = 
   int_of_uint32_0
   int_of_uint32_plus 
   int_of_uint32_minus
   int_of_uint32_mult
   
 
 definition urel32 :: "uint32 \<Rightarrow> int \<Rightarrow> bool" where "urel32 x y = (y = int_of_uint32 x \<and> y < p)" 
 
 definition mod_ring_rel32 :: "uint32 \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
   "mod_ring_rel32 x y = (\<exists> z. urel32 x z \<and> mod_ring_rel z y)" 
 
 lemma urel32_0: "urel32 0 0" unfolding urel32_def using p2 by (simp, transfer, simp)
 
 lemma urel32_1: "urel32 1 1" unfolding urel32_def using p2 by (simp, transfer, simp)
 
 lemma le_int_of_uint32: "(x \<le> y) = (int_of_uint32 x \<le> int_of_uint32 y)" 
   by (transfer, simp add: word_le_def)
 
 lemma urel32_plus: assumes "urel32 x y" "urel32 x' y'"
   shows "urel32 (plus_p32 pp x x') (plus_p p y y')"
 proof -    
   let ?x = "int_of_uint32 x" 
   let ?x' = "int_of_uint32 x'" 
   let ?p = "int_of_uint32 pp" 
   from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' \<le> p" unfolding urel32_def by auto
   have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_uint32
     using rel small by (auto simp: uint32_simps)
   show ?thesis
   proof (cases "?p \<le> ?x + ?x'")
     case True
     hence True: "(?p \<le> ?x + ?x') = True" by simp
     show ?thesis unfolding id 
       using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def 
       unfolding ppp le True if_True
       using True by (auto simp: uint32_simps)
   next
     case False
     hence False: "(?p \<le> ?x + ?x') = False" by simp
     show ?thesis unfolding id 
       using small rel unfolding plus_p32_def plus_p_def Let_def urel32_def 
       unfolding ppp le False if_False
       using False by (auto simp: uint32_simps)
   qed
 qed
   
 lemma urel32_minus: assumes "urel32 x y" "urel32 x' y'"
   shows "urel32 (minus_p32 pp x x') (minus_p p y y')"
 proof -    
   let ?x = "int_of_uint32 x" 
   let ?x' = "int_of_uint32 x'" 
   from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' \<le> p" unfolding urel32_def by auto
   have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_uint32
     using rel small by (auto simp: uint32_simps)
   show ?thesis
   proof (cases "?x' \<le> ?x")
     case True
     hence True: "(?x' \<le> ?x) = True" by simp
     show ?thesis unfolding id 
       using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def 
       unfolding ppp le True if_True
       using True by (auto simp: uint32_simps)
   next
     case False
     hence False: "(?x' \<le> ?x) = False" by simp
     show ?thesis unfolding id 
       using small rel unfolding minus_p32_def minus_p_def Let_def urel32_def 
       unfolding ppp le False if_False
       using False by (auto simp: uint32_simps)
   qed
 qed
 
 lemma urel32_uminus: assumes "urel32 x y"
   shows "urel32 (uminus_p32 pp x) (uminus_p p y)"
 proof -    
   let ?x = "int_of_uint32 x"  
   from assms int_of_uint32_ge_0 have id: "y = ?x" 
     and rel: "0 \<le> ?x" "?x < p" 
       unfolding urel32_def by auto
   have le: "(x = 0) = (?x = 0)" unfolding int_of_uint32_0_iff
     using rel small by (auto simp: uint32_simps)
   show ?thesis
   proof (cases "?x = 0")
     case True
     hence True: "(?x = 0) = True" by simp
     show ?thesis unfolding id 
       using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def 
       unfolding ppp le True if_True
       using True by (auto simp: uint32_simps)
   next
     case False
     hence False: "(?x = 0) = False" by simp
     show ?thesis unfolding id 
       using small rel unfolding uminus_p32_def uminus_p_def Let_def urel32_def 
       unfolding ppp le False if_False
       using False by (auto simp: uint32_simps)
   qed
 qed
 
 lemma urel32_mult: assumes "urel32 x y" "urel32 x' y'"
   shows "urel32 (mult_p32 pp x x') (mult_p p y y')"
 proof -    
   let ?x = "int_of_uint32 x" 
   let ?x' = "int_of_uint32 x'" 
   from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' < p" unfolding urel32_def by auto
   from rel have "?x * ?x' < p * p" by (metis mult_strict_mono') 
   also have "\<dots> \<le> 65536 * 65536"
     by (rule mult_mono, insert p2 small, auto)
   finally have le: "?x * ?x' < 4294967296" by simp
   show ?thesis unfolding id
       using small rel unfolding mult_p32_def mult_p_def Let_def urel32_def 
       unfolding ppp 
     by (auto simp: uint32_simps, unfold int_of_uint32_mod int_of_uint32_mult, 
         subst mod_pos_pos_trivial[of _ 4294967296], insert le, auto)
 qed
 
 lemma urel32_eq: assumes "urel32 x y" "urel32 x' y'" 
   shows "(x = x') = (y = y')" 
 proof -    
   let ?x = "int_of_uint32 x" 
   let ?x' = "int_of_uint32 x'" 
   from assms int_of_uint32_ge_0 have id: "y = ?x" "y' = ?x'" 
     unfolding urel32_def by auto
-  show ?thesis unfolding id by (transfer, auto)
+  show ?thesis unfolding id by (transfer, transfer) rule
 qed
 
 lemma urel32_normalize: 
 assumes x: "urel32 x y"
 shows "urel32 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
  unfolding urel32_eq[OF x urel32_0] using urel32_0 urel32_1 by auto
 
 lemma urel32_mod: 
 assumes x: "urel32 x x'" and y: "urel32 y y'" 
 shows "urel32 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
   unfolding urel32_eq[OF y urel32_0] using urel32_0 x by auto 
 
 lemma urel32_power: "urel32 x x' \<Longrightarrow> urel32 y (int y') \<Longrightarrow> urel32 (power_p32 pp x y) (power_p p x' y')"
 proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
   case (1 x' y' x y)
   note x = 1(2) note y = 1(3)
   show ?case
   proof (cases "y' = 0")
     case True
     hence y: "y = 0" using urel32_eq[OF y urel32_0] by auto
     show ?thesis unfolding y True by (simp add: power_p.simps urel32_1)
   next
     case False
     hence id: "(y = 0) = False" "(y' = 0) = False" using urel32_eq[OF y urel32_0] by auto
     obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
     from divmod_nat_def[of y' 2, unfolded dr']
     have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
     have "urel32 (y AND 1) r'"
       unfolding r'
       using y
       unfolding urel32_def
       using small
       apply (simp add: ppp and_one_eq)
       apply transfer
       apply transfer
       apply (auto simp add: zmod_int take_bit_int_eq_self)
       apply (rule le_less_trans)
        apply (rule zmod_le_nonneg_dividend)
       apply simp_all
       done
     from urel32_eq[OF this urel32_0]     
     have rem: "(y AND 1 = 0) = (r' = 0)" by simp
     have div: "urel32 (shiftr y 1) (int d')" unfolding d' using y unfolding urel32_def using small
       unfolding ppp 
       apply transfer
       apply transfer
       apply (auto simp add: drop_bit_Suc)
       done
     note IH = 1(1)[OF False refl dr'[symmetric] urel32_mult[OF x x] div]
     show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p32.simps[of _ _ y] dr' id if_False rem
       using IH urel32_mult[OF IH x] by (auto simp: Let_def)
   qed
 qed
   
 
 lemma urel32_inverse: assumes x: "urel32 x x'" 
   shows "urel32 (inverse_p32 pp x) (inverse_p p x')" 
 proof -
   have p: "urel32 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel32_def unfolding ppp
     by (transfer, auto simp: uint_word_ariths)
   show ?thesis
     unfolding inverse_p32_def inverse_p_def urel32_eq[OF x urel32_0] using urel32_0 urel32_power[OF x p]
     by auto
 qed
 
 lemma mod_ring_0_32: "mod_ring_rel32 0 0"
   using urel32_0 mod_ring_0 unfolding mod_ring_rel32_def by blast
 
 lemma mod_ring_1_32: "mod_ring_rel32 1 1"
   using urel32_1 mod_ring_1 unfolding mod_ring_rel32_def by blast
 
 lemma mod_ring_uminus32: "(mod_ring_rel32 ===> mod_ring_rel32) (uminus_p32 pp) uminus"
   using urel32_uminus mod_ring_uminus unfolding mod_ring_rel32_def rel_fun_def by blast
 
 lemma mod_ring_plus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (plus_p32 pp) (+)"
   using urel32_plus mod_ring_plus unfolding mod_ring_rel32_def rel_fun_def by blast
 
 lemma mod_ring_minus32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (minus_p32 pp) (-)"
   using urel32_minus mod_ring_minus unfolding mod_ring_rel32_def rel_fun_def by blast
 
 lemma mod_ring_mult32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (mult_p32 pp) ((*))"
   using urel32_mult mod_ring_mult unfolding mod_ring_rel32_def rel_fun_def by blast
 
 lemma mod_ring_eq32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> (=)) (=) (=)" 
   using urel32_eq mod_ring_eq unfolding mod_ring_rel32_def rel_fun_def by blast
 
 lemma urel32_inj: "urel32 x y \<Longrightarrow> urel32 x z \<Longrightarrow> y = z" 
   using urel32_eq[of x y x z] by auto
 
 lemma urel32_inj': "urel32 x z \<Longrightarrow> urel32 y z \<Longrightarrow> x = y" 
   using urel32_eq[of x z y z] by auto
 
 lemma bi_unique_mod_ring_rel32:
   "bi_unique mod_ring_rel32" "left_unique mod_ring_rel32" "right_unique mod_ring_rel32"
   using bi_unique_mod_ring_rel urel32_inj'
   unfolding mod_ring_rel32_def bi_unique_def left_unique_def right_unique_def
   by (auto simp: urel32_def)  
 
 lemma right_total_mod_ring_rel32: "right_total mod_ring_rel32"
   unfolding mod_ring_rel32_def right_total_def
 proof 
   fix y :: "'a mod_ring" 
   from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
   obtain z where zy: "mod_ring_rel z y" by auto  
   hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
   hence "urel32 (uint32_of_int z) z" unfolding urel32_def using small unfolding ppp 
     by (auto simp: int_of_uint32_inv) 
   with zy show "\<exists> x z. urel32 x z \<and> mod_ring_rel z y" by blast
 qed
 
 lemma Domainp_mod_ring_rel32: "Domainp mod_ring_rel32 = (\<lambda>x. 0 \<le> x \<and> x < pp)"
 proof 
   fix x
   show "Domainp mod_ring_rel32 x = (0 \<le> x \<and> x < pp)"   
     unfolding Domainp.simps
     unfolding mod_ring_rel32_def
   proof
     let ?i = "int_of_uint32" 
     assume *: "0 \<le> x \<and> x < pp"     
     hence "0 \<le> ?i x \<and> ?i x < p" using small unfolding ppp
       by (transfer, auto simp: word_less_def)
     hence "?i x \<in> {0 ..< p}" by auto
     with Domainp_mod_ring_rel
     have "Domainp mod_ring_rel (?i x)" by auto
     from this[unfolded Domainp.simps]
     obtain b where b: "mod_ring_rel (?i x) b" by auto
     show "\<exists>a b. x = a \<and> (\<exists>z. urel32 a z \<and> mod_ring_rel z b)" 
     proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
       show "urel32 x (?i x)" unfolding urel32_def using small * unfolding ppp
         by (transfer, auto simp: word_less_def)
     qed
   next
     assume "\<exists>a b. x = a \<and> (\<exists>z. urel32 a z \<and> mod_ring_rel z b)" 
     then obtain b z where xz: "urel32 x z" and zb: "mod_ring_rel z b" by auto
     hence "Domainp mod_ring_rel z"  by auto
     with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
     with xz show "0 \<le> x \<and> x < pp" unfolding urel32_def using small unfolding ppp
       by (transfer, auto simp: word_less_def)
   qed
 qed
 
 lemma ring_finite_field_ops32: "ring_ops (finite_field_ops32 pp) mod_ring_rel32"
   by (unfold_locales, auto simp:
   finite_field_ops32_def
   bi_unique_mod_ring_rel32
   right_total_mod_ring_rel32
   mod_ring_plus32
   mod_ring_minus32
   mod_ring_uminus32
   mod_ring_mult32
   mod_ring_eq32
   mod_ring_0_32
   mod_ring_1_32
   Domainp_mod_ring_rel32)
 end
 end
 
 context prime_field
 begin
 context fixes pp :: "uint32" 
   assumes *: "p = int_of_uint32 pp" "p \<le> 65535" 
 begin
 
 lemma mod_ring_normalize32: "(mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x. if x = 0 then 0 else 1) normalize" 
   using urel32_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_mod32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x y. if y = 0 then x else 0) (mod)" 
   using urel32_mod[OF *] mod_ring_mod unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_unit_factor32: "(mod_ring_rel32 ===> mod_ring_rel32) (\<lambda>x. x) unit_factor" 
   using mod_ring_unit_factor unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_inverse32: "(mod_ring_rel32 ===> mod_ring_rel32) (inverse_p32 pp) inverse"
   using urel32_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel32_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_divide32: "(mod_ring_rel32 ===> mod_ring_rel32 ===> mod_ring_rel32) (divide_p32 pp) (/)"
   using mod_ring_inverse32 mod_ring_mult32[OF *]
   unfolding divide_p32_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
     rel_fun_def by blast
 
 lemma finite_field_ops32: "field_ops (finite_field_ops32 pp) mod_ring_rel32"
   by (unfold_locales, insert ring_finite_field_ops32[OF *], auto simp:
   ring_ops_def
   finite_field_ops32_def
   mod_ring_divide32
   mod_ring_inverse32
   mod_ring_mod32
   mod_ring_normalize32)
 
 end
 end
 
 (* now there is 64-bit time *)
 context
   fixes p :: uint64
 begin
 definition plus_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
   "plus_p64 x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"
 
 definition minus_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
   "minus_p64 x y \<equiv> if y \<le> x then x - y else (x + p) - y"
 
 definition uminus_p64 :: "uint64 \<Rightarrow> uint64" where
   "uminus_p64 x = (if x = 0 then 0 else p - x)"
 
 definition mult_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
   "mult_p64 x y = (x * y mod p)"
 
 lemma int_of_uint64_shift: "int_of_uint64 (shiftr n k) = (int_of_uint64 n) div (2 ^ k)" 
   apply transfer
   apply transfer
   apply (simp add: take_bit_drop_bit min_def)
   apply (simp add: drop_bit_eq_div)
   done
 
 lemma int_of_uint64_0_iff: "int_of_uint64 n = 0 \<longleftrightarrow> n = 0" 
   by (transfer, rule uint_0_iff)
   
 lemma int_of_uint64_0: "int_of_uint64 0 = 0" unfolding int_of_uint64_0_iff by simp
 
 lemma int_of_uint64_ge_0: "int_of_uint64 n \<ge> 0" 
   by (transfer, auto)
 
 lemma two_64: "2 ^ LENGTH(64) = (18446744073709551616 :: int)" by simp
 
 lemma int_of_uint64_plus: "int_of_uint64 (x + y) = (int_of_uint64 x + int_of_uint64 y) mod 18446744073709551616" 
   by (transfer, unfold uint_word_ariths two_64, rule refl)  
 
 lemma int_of_uint64_minus: "int_of_uint64 (x - y) = (int_of_uint64 x - int_of_uint64 y) mod 18446744073709551616" 
   by (transfer, unfold uint_word_ariths two_64, rule refl)  
 
 lemma int_of_uint64_mult: "int_of_uint64 (x * y) = (int_of_uint64 x * int_of_uint64 y) mod 18446744073709551616" 
   by (transfer, unfold uint_word_ariths two_64, rule refl)  
 
 lemma int_of_uint64_mod: "int_of_uint64 (x mod y) = (int_of_uint64 x mod int_of_uint64 y)" 
   by (transfer, unfold uint_mod two_64, rule refl)  
 
 lemma int_of_uint64_inv: "0 \<le> x \<Longrightarrow> x < 18446744073709551616 \<Longrightarrow> int_of_uint64 (uint64_of_int x) = x"
   by transfer (simp add: take_bit_int_eq_self)
 
 function power_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" where
   "power_p64 x n = (if n = 0 then 1 else
     let rec = power_p64 (mult_p64 x x) (shiftr n 1) in
     if n AND 1 = 0 then rec else mult_p64 rec x)"
   by pat_completeness auto
 
 termination 
 proof -
   {
     fix n :: uint64
     assume "n \<noteq> 0" 
     with int_of_uint64_ge_0[of n] int_of_uint64_0_iff[of n] have "int_of_uint64 n > 0" by auto
     hence "0 < int_of_uint64 n" "int_of_uint64 n div 2 < int_of_uint64 n" by auto
   } note * = this
   show ?thesis
     by (relation "measure (\<lambda> (x,n). nat (int_of_uint64 n))", auto simp: int_of_uint64_shift *) 
 qed
 
 text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
   it turned out that taking the below implementation of inverse via exponentiation
   is faster than the one based on the extended Euclidean algorithm.\<close>
 
 definition inverse_p64 :: "uint64 \<Rightarrow> uint64" where
   "inverse_p64 x = (if x = 0 then 0 else power_p64 x (p - 2))"
 
 definition divide_p64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"  where
   "divide_p64 x y = mult_p64 x (inverse_p64 y)"
 
 definition finite_field_ops64 :: "uint64 arith_ops_record" where
   "finite_field_ops64 \<equiv> Arith_Ops_Record
       0
       1
       plus_p64
       mult_p64
       minus_p64
       uminus_p64
       divide_p64
       inverse_p64
       (\<lambda> x y . if y = 0 then x else 0)
       (\<lambda> x . if x = 0 then 0 else 1)
       (\<lambda> x . x)
       uint64_of_int
       int_of_uint64
       (\<lambda> x. 0 \<le> x \<and> x < p)"
 end 
 
 lemma shiftr_uint64_code [code_unfold]: "drop_bit 1 x = (uint64_shiftr x 1)"
   by (simp add: uint64_shiftr_def)
 
 text \<open>For soundness of the 64-bit implementation, we mainly prove that this implementation
   implements the int-based implementation of GF(p).\<close>
 context mod_ring_locale
 begin
 
 context fixes pp :: "uint64" 
   assumes ppp: "p = int_of_uint64 pp" 
   and small: "p \<le> 4294967295" 
 begin
 
 lemmas uint64_simps = 
   int_of_uint64_0
   int_of_uint64_plus 
   int_of_uint64_minus
   int_of_uint64_mult
   
 
 definition urel64 :: "uint64 \<Rightarrow> int \<Rightarrow> bool" where "urel64 x y = (y = int_of_uint64 x \<and> y < p)" 
 
 definition mod_ring_rel64 :: "uint64 \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
   "mod_ring_rel64 x y = (\<exists> z. urel64 x z \<and> mod_ring_rel z y)" 
 
 lemma urel64_0: "urel64 0 0" unfolding urel64_def using p2 by (simp, transfer, simp)
 
 lemma urel64_1: "urel64 1 1" unfolding urel64_def using p2 by (simp, transfer, simp)
 
 lemma le_int_of_uint64: "(x \<le> y) = (int_of_uint64 x \<le> int_of_uint64 y)" 
   by (transfer, simp add: word_le_def)
 
 lemma urel64_plus: assumes "urel64 x y" "urel64 x' y'"
   shows "urel64 (plus_p64 pp x x') (plus_p p y y')"
 proof -    
   let ?x = "int_of_uint64 x" 
   let ?x' = "int_of_uint64 x'" 
   let ?p = "int_of_uint64 pp" 
   from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' \<le> p" unfolding urel64_def by auto
   have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_uint64
     using rel small by (auto simp: uint64_simps)
   show ?thesis
   proof (cases "?p \<le> ?x + ?x'")
     case True
     hence True: "(?p \<le> ?x + ?x') = True" by simp
     show ?thesis unfolding id 
       using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def 
       unfolding ppp le True if_True
       using True by (auto simp: uint64_simps)
   next
     case False
     hence False: "(?p \<le> ?x + ?x') = False" by simp
     show ?thesis unfolding id 
       using small rel unfolding plus_p64_def plus_p_def Let_def urel64_def 
       unfolding ppp le False if_False
       using False by (auto simp: uint64_simps)
   qed
 qed
   
 lemma urel64_minus: assumes "urel64 x y" "urel64 x' y'"
   shows "urel64 (minus_p64 pp x x') (minus_p p y y')"
 proof -    
   let ?x = "int_of_uint64 x" 
   let ?x' = "int_of_uint64 x'" 
   from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' \<le> p" unfolding urel64_def by auto
   have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_uint64
     using rel small by (auto simp: uint64_simps)
   show ?thesis
   proof (cases "?x' \<le> ?x")
     case True
     hence True: "(?x' \<le> ?x) = True" by simp
     show ?thesis unfolding id 
       using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def 
       unfolding ppp le True if_True
       using True by (auto simp: uint64_simps)
   next
     case False
     hence False: "(?x' \<le> ?x) = False" by simp
     show ?thesis unfolding id 
       using small rel unfolding minus_p64_def minus_p_def Let_def urel64_def 
       unfolding ppp le False if_False
       using False by (auto simp: uint64_simps)
   qed
 qed
 
 lemma urel64_uminus: assumes "urel64 x y"
   shows "urel64 (uminus_p64 pp x) (uminus_p p y)"
 proof -    
   let ?x = "int_of_uint64 x"  
   from assms int_of_uint64_ge_0 have id: "y = ?x" 
     and rel: "0 \<le> ?x" "?x < p" 
       unfolding urel64_def by auto
   have le: "(x = 0) = (?x = 0)" unfolding int_of_uint64_0_iff
     using rel small by (auto simp: uint64_simps)
   show ?thesis
   proof (cases "?x = 0")
     case True
     hence True: "(?x = 0) = True" by simp
     show ?thesis unfolding id 
       using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def 
       unfolding ppp le True if_True
       using True by (auto simp: uint64_simps)
   next
     case False
     hence False: "(?x = 0) = False" by simp
     show ?thesis unfolding id 
       using small rel unfolding uminus_p64_def uminus_p_def Let_def urel64_def 
       unfolding ppp le False if_False
       using False by (auto simp: uint64_simps)
   qed
 qed
 
 lemma urel64_mult: assumes "urel64 x y" "urel64 x' y'"
   shows "urel64 (mult_p64 pp x x') (mult_p p y y')"
 proof -    
   let ?x = "int_of_uint64 x" 
   let ?x' = "int_of_uint64 x'" 
   from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' < p" unfolding urel64_def by auto
   from rel have "?x * ?x' < p * p" by (metis mult_strict_mono') 
   also have "\<dots> \<le> 4294967296 * 4294967296"
     by (rule mult_mono, insert p2 small, auto)
   finally have le: "?x * ?x' < 18446744073709551616" by simp
   show ?thesis unfolding id
       using small rel unfolding mult_p64_def mult_p_def Let_def urel64_def 
       unfolding ppp 
     by (auto simp: uint64_simps, unfold int_of_uint64_mod int_of_uint64_mult, 
         subst mod_pos_pos_trivial[of _ 18446744073709551616], insert le, auto)
 qed
 
 lemma urel64_eq: assumes "urel64 x y" "urel64 x' y'" 
   shows "(x = x') = (y = y')" 
 proof -    
   let ?x = "int_of_uint64 x" 
   let ?x' = "int_of_uint64 x'" 
   from assms int_of_uint64_ge_0 have id: "y = ?x" "y' = ?x'" 
     unfolding urel64_def by auto
-  show ?thesis unfolding id by (transfer, auto)
+  show ?thesis unfolding id by (transfer, transfer) rule
 qed
 
 lemma urel64_normalize: 
 assumes x: "urel64 x y"
 shows "urel64 (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
  unfolding urel64_eq[OF x urel64_0] using urel64_0 urel64_1 by auto
 
 lemma urel64_mod: 
 assumes x: "urel64 x x'" and y: "urel64 y y'" 
 shows "urel64 (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
   unfolding urel64_eq[OF y urel64_0] using urel64_0 x by auto 
 
 lemma urel64_power: "urel64 x x' \<Longrightarrow> urel64 y (int y') \<Longrightarrow> urel64 (power_p64 pp x y) (power_p p x' y')"
 proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
   case (1 x' y' x y)
   note x = 1(2) note y = 1(3)
   show ?case
   proof (cases "y' = 0")
     case True
     hence y: "y = 0" using urel64_eq[OF y urel64_0] by auto
     show ?thesis unfolding y True by (simp add: power_p.simps urel64_1)
   next
     case False
     hence id: "(y = 0) = False" "(y' = 0) = False" using urel64_eq[OF y urel64_0] by auto
     obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
     from divmod_nat_def[of y' 2, unfolded dr']
     have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
     have "urel64 (y AND 1) r'"
       unfolding r'
       using y
       unfolding urel64_def
       using small
       apply (simp add: ppp and_one_eq)
       apply transfer apply transfer
       apply (auto simp add: int_eq_iff nat_take_bit_eq nat_mod_distrib zmod_int)
        apply (auto simp add: zmod_int mod_2_eq_odd)
        apply (metis (full_types) even_take_bit_eq le_less_trans odd_iff_mod_2_eq_one take_bit_nonnegative zero_neq_numeral zmod_le_nonneg_dividend)
       apply (auto simp add: less_le)
       apply (simp add: le_less)
       done
     from urel64_eq[OF this urel64_0]     
     have rem: "(y AND 1 = 0) = (r' = 0)" by simp
     have div: "urel64 (shiftr y 1) (int d')" unfolding d' using y unfolding urel64_def using small
       unfolding ppp
       apply transfer
       apply transfer
       apply (auto simp add: drop_bit_Suc)
       done
     note IH = 1(1)[OF False refl dr'[symmetric] urel64_mult[OF x x] div]
     show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p64.simps[of _ _ y] dr' id if_False rem
       using IH urel64_mult[OF IH x] by (auto simp: Let_def)
   qed
 qed
   
 
 lemma urel64_inverse: assumes x: "urel64 x x'" 
   shows "urel64 (inverse_p64 pp x) (inverse_p p x')" 
 proof -
   have p: "urel64 (pp - 2) (int (nat (p - 2)))" using p2 small unfolding urel64_def unfolding ppp
     by (transfer, auto simp: uint_word_ariths)
   show ?thesis
     unfolding inverse_p64_def inverse_p_def urel64_eq[OF x urel64_0] using urel64_0 urel64_power[OF x p]
     by auto
 qed
 
 lemma mod_ring_0_64: "mod_ring_rel64 0 0"
   using urel64_0 mod_ring_0 unfolding mod_ring_rel64_def by blast
 
 lemma mod_ring_1_64: "mod_ring_rel64 1 1"
   using urel64_1 mod_ring_1 unfolding mod_ring_rel64_def by blast
 
 lemma mod_ring_uminus64: "(mod_ring_rel64 ===> mod_ring_rel64) (uminus_p64 pp) uminus"
   using urel64_uminus mod_ring_uminus unfolding mod_ring_rel64_def rel_fun_def by blast
 
 lemma mod_ring_plus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (plus_p64 pp) (+)"
   using urel64_plus mod_ring_plus unfolding mod_ring_rel64_def rel_fun_def by blast
 
 lemma mod_ring_minus64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (minus_p64 pp) (-)"
   using urel64_minus mod_ring_minus unfolding mod_ring_rel64_def rel_fun_def by blast
 
 lemma mod_ring_mult64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (mult_p64 pp) ((*))"
   using urel64_mult mod_ring_mult unfolding mod_ring_rel64_def rel_fun_def by blast
 
 lemma mod_ring_eq64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> (=)) (=) (=)" 
   using urel64_eq mod_ring_eq unfolding mod_ring_rel64_def rel_fun_def by blast
 
 lemma urel64_inj: "urel64 x y \<Longrightarrow> urel64 x z \<Longrightarrow> y = z" 
   using urel64_eq[of x y x z] by auto
 
 lemma urel64_inj': "urel64 x z \<Longrightarrow> urel64 y z \<Longrightarrow> x = y" 
   using urel64_eq[of x z y z] by auto
 
 lemma bi_unique_mod_ring_rel64:
   "bi_unique mod_ring_rel64" "left_unique mod_ring_rel64" "right_unique mod_ring_rel64"
   using bi_unique_mod_ring_rel urel64_inj'
   unfolding mod_ring_rel64_def bi_unique_def left_unique_def right_unique_def
   by (auto simp: urel64_def)  
 
 lemma right_total_mod_ring_rel64: "right_total mod_ring_rel64"
   unfolding mod_ring_rel64_def right_total_def
 proof 
   fix y :: "'a mod_ring" 
   from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
   obtain z where zy: "mod_ring_rel z y" by auto  
   hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
   hence "urel64 (uint64_of_int z) z" unfolding urel64_def using small unfolding ppp 
     by (auto simp: int_of_uint64_inv) 
   with zy show "\<exists> x z. urel64 x z \<and> mod_ring_rel z y" by blast
 qed
 
 lemma Domainp_mod_ring_rel64: "Domainp mod_ring_rel64 = (\<lambda>x. 0 \<le> x \<and> x < pp)"
 proof 
   fix x
   show "Domainp mod_ring_rel64 x = (0 \<le> x \<and> x < pp)"   
     unfolding Domainp.simps
     unfolding mod_ring_rel64_def
   proof
     let ?i = "int_of_uint64" 
     assume *: "0 \<le> x \<and> x < pp"     
     hence "0 \<le> ?i x \<and> ?i x < p" using small unfolding ppp
       by (transfer, auto simp: word_less_def)
     hence "?i x \<in> {0 ..< p}" by auto
     with Domainp_mod_ring_rel
     have "Domainp mod_ring_rel (?i x)" by auto
     from this[unfolded Domainp.simps]
     obtain b where b: "mod_ring_rel (?i x) b" by auto
     show "\<exists>a b. x = a \<and> (\<exists>z. urel64 a z \<and> mod_ring_rel z b)" 
     proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
       show "urel64 x (?i x)" unfolding urel64_def using small * unfolding ppp
         by (transfer, auto simp: word_less_def)
     qed
   next
     assume "\<exists>a b. x = a \<and> (\<exists>z. urel64 a z \<and> mod_ring_rel z b)" 
     then obtain b z where xz: "urel64 x z" and zb: "mod_ring_rel z b" by auto
     hence "Domainp mod_ring_rel z"  by auto
     with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
     with xz show "0 \<le> x \<and> x < pp" unfolding urel64_def using small unfolding ppp
       by (transfer, auto simp: word_less_def)
   qed
 qed
 
 lemma ring_finite_field_ops64: "ring_ops (finite_field_ops64 pp) mod_ring_rel64"
   by (unfold_locales, auto simp:
   finite_field_ops64_def
   bi_unique_mod_ring_rel64
   right_total_mod_ring_rel64
   mod_ring_plus64
   mod_ring_minus64
   mod_ring_uminus64
   mod_ring_mult64
   mod_ring_eq64
   mod_ring_0_64
   mod_ring_1_64
   Domainp_mod_ring_rel64)
 end
 end
 
 context prime_field
 begin
 context fixes pp :: "uint64" 
   assumes *: "p = int_of_uint64 pp" "p \<le> 4294967295" 
 begin
 
 lemma mod_ring_normalize64: "(mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x. if x = 0 then 0 else 1) normalize" 
   using urel64_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_mod64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x y. if y = 0 then x else 0) (mod)" 
   using urel64_mod[OF *] mod_ring_mod unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_unit_factor64: "(mod_ring_rel64 ===> mod_ring_rel64) (\<lambda>x. x) unit_factor" 
   using mod_ring_unit_factor unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_inverse64: "(mod_ring_rel64 ===> mod_ring_rel64) (inverse_p64 pp) inverse"
   using urel64_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel64_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_divide64: "(mod_ring_rel64 ===> mod_ring_rel64 ===> mod_ring_rel64) (divide_p64 pp) (/)"
   using mod_ring_inverse64 mod_ring_mult64[OF *]
   unfolding divide_p64_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
     rel_fun_def by blast
 
 lemma finite_field_ops64: "field_ops (finite_field_ops64 pp) mod_ring_rel64"
   by (unfold_locales, insert ring_finite_field_ops64[OF *], auto simp:
   ring_ops_def
   finite_field_ops64_def
   mod_ring_divide64
   mod_ring_inverse64
   mod_ring_mod64
   mod_ring_normalize64)
 end
 end
 
 (* and a final implementation via integer *)
 context
   fixes p :: integer
 begin
 definition plus_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
   "plus_p_integer x y \<equiv> let z = x + y in if z \<ge> p then z - p else z"
 
 definition minus_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
   "minus_p_integer x y \<equiv> if y \<le> x then x - y else (x + p) - y"
 
 definition uminus_p_integer :: "integer \<Rightarrow> integer" where
   "uminus_p_integer x = (if x = 0 then 0 else p - x)"
 
 definition mult_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
   "mult_p_integer x y = (x * y mod p)"
 
 lemma int_of_integer_0_iff: "int_of_integer n = 0 \<longleftrightarrow> n = 0"
   using integer_eqI by auto
   
 lemma int_of_integer_0: "int_of_integer 0 = 0" unfolding int_of_integer_0_iff by simp
 
 lemma int_of_integer_plus: "int_of_integer (x + y) = (int_of_integer x + int_of_integer y)" 
   by simp
 
 lemma int_of_integer_minus: "int_of_integer (x - y) = (int_of_integer x - int_of_integer y)"
   by simp
 
 lemma int_of_integer_mult: "int_of_integer (x * y) = (int_of_integer x * int_of_integer y)" 
   by simp  
 
 lemma int_of_integer_mod: "int_of_integer (x mod y) = (int_of_integer x mod int_of_integer y)" 
   by simp  
 
 lemma int_of_integer_inv: "int_of_integer (integer_of_int x) = x" by simp
 
 lemma int_of_integer_shift: "int_of_integer (shiftr n k) = (int_of_integer n) div (2 ^ k)" 
   by transfer (simp add: int_of_integer_pow shiftr_integer_conv_div_pow2)
 
 
 function power_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer" where
   "power_p_integer x n = (if n \<le> 0 then 1 else
     let rec = power_p_integer (mult_p_integer x x) (shiftr n 1) in
     if n AND 1 = 0 then rec else mult_p_integer rec x)"
   by pat_completeness auto
 
 termination 
 proof -
   {
     fix n :: integer
     assume "\<not> (n \<le> 0)" 
     hence "n > 0" by auto
     hence "int_of_integer n > 0"
       by (simp add: less_integer.rep_eq)
     hence "0 < int_of_integer n" "int_of_integer n div 2 < int_of_integer n" by auto
   } note * = this
   show ?thesis
     by (relation "measure (\<lambda> (x,n). nat (int_of_integer n))", auto simp: * int_of_integer_shift) 
 qed
 
 text \<open>In experiments with Berlekamp-factorization (where the prime $p$ is usually small),
   it turned out that taking the below implementation of inverse via exponentiation
   is faster than the one based on the extended Euclidean algorithm.\<close>
 
 definition inverse_p_integer :: "integer \<Rightarrow> integer" where
   "inverse_p_integer x = (if x = 0 then 0 else power_p_integer x (p - 2))"
 
 definition divide_p_integer :: "integer \<Rightarrow> integer \<Rightarrow> integer"  where
   "divide_p_integer x y = mult_p_integer x (inverse_p_integer y)"
 
 definition finite_field_ops_integer :: "integer arith_ops_record" where
   "finite_field_ops_integer \<equiv> Arith_Ops_Record
       0
       1
       plus_p_integer
       mult_p_integer
       minus_p_integer
       uminus_p_integer
       divide_p_integer
       inverse_p_integer
       (\<lambda> x y . if y = 0 then x else 0)
       (\<lambda> x . if x = 0 then 0 else 1)
       (\<lambda> x . x)
       integer_of_int
       int_of_integer
       (\<lambda> x. 0 \<le> x \<and> x < p)"
 end 
 
 lemma shiftr_integer_code [code_unfold]: "drop_bit 1 x = (integer_shiftr x 1)"
   unfolding shiftr_integer_code using integer_of_nat_1 by auto
 
 text \<open>For soundness of the integer implementation, we mainly prove that this implementation
   implements the int-based implementation of GF(p).\<close>
 context mod_ring_locale
 begin
 
 context fixes pp :: "integer" 
   assumes ppp: "p = int_of_integer pp" 
 begin
 
 lemmas integer_simps = 
   int_of_integer_0
   int_of_integer_plus 
   int_of_integer_minus
   int_of_integer_mult
   
 
 definition urel_integer :: "integer \<Rightarrow> int \<Rightarrow> bool" where "urel_integer x y = (y = int_of_integer x \<and> y \<ge> 0 \<and> y < p)" 
 
 definition mod_ring_rel_integer :: "integer \<Rightarrow> 'a mod_ring \<Rightarrow> bool" where
   "mod_ring_rel_integer x y = (\<exists> z. urel_integer x z \<and> mod_ring_rel z y)" 
 
 lemma urel_integer_0: "urel_integer 0 0" unfolding urel_integer_def using p2 by simp
 
 lemma urel_integer_1: "urel_integer 1 1" unfolding urel_integer_def using p2 by simp
 
 lemma le_int_of_integer: "(x \<le> y) = (int_of_integer x \<le> int_of_integer y)" 
   by (rule less_eq_integer.rep_eq)
 
 lemma urel_integer_plus: assumes "urel_integer x y" "urel_integer x' y'"
   shows "urel_integer (plus_p_integer pp x x') (plus_p p y y')"
 proof -    
   let ?x = "int_of_integer x" 
   let ?x' = "int_of_integer x'" 
   let ?p = "int_of_integer pp" 
   from assms have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' \<le> p" unfolding urel_integer_def by auto
   have le: "(pp \<le> x + x') = (?p \<le> ?x + ?x')" unfolding le_int_of_integer
     using rel by auto
   show ?thesis
   proof (cases "?p \<le> ?x + ?x'")
     case True
     hence True: "(?p \<le> ?x + ?x') = True" by simp
     show ?thesis unfolding id 
       using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def 
       unfolding ppp le True if_True
       using True by auto
   next
     case False
     hence False: "(?p \<le> ?x + ?x') = False" by simp
     show ?thesis unfolding id 
       using rel unfolding plus_p_integer_def plus_p_def Let_def urel_integer_def 
       unfolding ppp le False if_False
       using False by auto
   qed
 qed
   
 lemma urel_integer_minus: assumes "urel_integer x y" "urel_integer x' y'"
   shows "urel_integer (minus_p_integer pp x x') (minus_p p y y')"
 proof -    
   let ?x = "int_of_integer x" 
   let ?x' = "int_of_integer x'" 
   from assms have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' \<le> p" unfolding urel_integer_def by auto
   have le: "(x' \<le> x) = (?x' \<le> ?x)" unfolding le_int_of_integer
     using rel by auto
   show ?thesis
   proof (cases "?x' \<le> ?x")
     case True
     hence True: "(?x' \<le> ?x) = True" by simp
     show ?thesis unfolding id 
       using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def 
       unfolding ppp le True if_True
       using True by auto
   next
     case False
     hence False: "(?x' \<le> ?x) = False" by simp
     show ?thesis unfolding id 
       using rel unfolding minus_p_integer_def minus_p_def Let_def urel_integer_def 
       unfolding ppp le False if_False
       using False by auto
   qed
 qed
 
 lemma urel_integer_uminus: assumes "urel_integer x y"
   shows "urel_integer (uminus_p_integer pp x) (uminus_p p y)"
 proof -    
   let ?x = "int_of_integer x"  
   from assms have id: "y = ?x" 
     and rel: "0 \<le> ?x" "?x < p" 
       unfolding urel_integer_def by auto
   have le: "(x = 0) = (?x = 0)" unfolding int_of_integer_0_iff
     using rel by auto
   show ?thesis
   proof (cases "?x = 0")
     case True
     hence True: "(?x = 0) = True" by simp
     show ?thesis unfolding id 
       using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def 
       unfolding ppp le True if_True
       using True by auto
   next
     case False
     hence False: "(?x = 0) = False" by simp
     show ?thesis unfolding id 
       using rel unfolding uminus_p_integer_def uminus_p_def Let_def urel_integer_def 
       unfolding ppp le False if_False
       using False by auto
   qed
 qed
 
 lemma pp_pos: "int_of_integer pp > 0" 
   using ppp nontriv[where 'a = 'a]  unfolding p
   by (simp add: less_integer.rep_eq)
 
 lemma urel_integer_mult: assumes "urel_integer x y" "urel_integer x' y'"
   shows "urel_integer (mult_p_integer pp x x') (mult_p p y y')"
 proof -    
   let ?x = "int_of_integer x" 
   let ?x' = "int_of_integer x'" 
   from assms  have id: "y = ?x" "y' = ?x'" 
     and rel: "0 \<le> ?x" "?x < p" 
       "0 \<le> ?x'" "?x' < p" unfolding urel_integer_def by auto
   from rel(1,3) have xx: "0 \<le> ?x * ?x'" by simp
   show ?thesis unfolding id
     using rel unfolding mult_p_integer_def mult_p_def Let_def urel_integer_def     
     unfolding ppp mod_nonneg_pos_int[OF xx pp_pos] using xx pp_pos by simp        
 qed
 
 lemma urel_integer_eq: assumes "urel_integer x y" "urel_integer x' y'" 
   shows "(x = x') = (y = y')" 
 proof -    
   let ?x = "int_of_integer x" 
   let ?x' = "int_of_integer x'" 
   from assms have id: "y = ?x" "y' = ?x'" 
     unfolding urel_integer_def by auto
   show ?thesis unfolding id integer_eq_iff ..
 qed
 
 lemma urel_integer_normalize: 
 assumes x: "urel_integer x y"
 shows "urel_integer (if x = 0 then 0 else 1) (if y = 0 then 0 else 1)"
  unfolding urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_1 by auto
 
 lemma urel_integer_mod: 
 assumes x: "urel_integer x x'" and y: "urel_integer y y'" 
 shows "urel_integer (if y = 0 then x else 0) (if y' = 0 then x' else 0)"
   unfolding urel_integer_eq[OF y urel_integer_0] using urel_integer_0 x by auto 
 
 lemma urel_integer_power: "urel_integer x x' \<Longrightarrow> urel_integer y (int y') \<Longrightarrow> urel_integer (power_p_integer pp x y) (power_p p x' y')"
 proof (induct x' y' arbitrary: x y rule: power_p.induct[of _ p])
   case (1 x' y' x y)
   note x = 1(2) note y = 1(3)
   show ?case
   proof (cases "y' \<le> 0")
     case True
     hence y: "y = 0" "y' = 0" using urel_integer_eq[OF y urel_integer_0] by auto
     show ?thesis unfolding y True by (simp add: power_p.simps urel_integer_1)
   next
     case False
     hence id: "(y \<le> 0) = False" "(y' = 0) = False" using False y
       by (auto simp add: urel_integer_def not_le) (metis of_int_integer_of of_int_of_nat_eq of_nat_0_less_iff)
     obtain d' r' where dr': "Divides.divmod_nat y' 2 = (d',r')" by force
     from divmod_nat_def[of y' 2, unfolded dr']
     have r': "r' = y' mod 2" and d': "d' = y' div 2" by auto
     have aux: "\<And> y'. int (y' mod 2) = int y' mod 2" by presburger
     have "urel_integer (y AND 1) r'" unfolding r' using y unfolding urel_integer_def 
       unfolding ppp
       apply (auto simp add: and_one_eq)
       apply (simp add: of_nat_mod)
       done
     from urel_integer_eq[OF this urel_integer_0]     
     have rem: "(y AND 1 = 0) = (r' = 0)" by simp
     have div: "urel_integer (shiftr y 1) (int d')" unfolding d' using y unfolding urel_integer_def
       unfolding ppp shiftr_integer_conv_div_pow2 by auto
     from id have "y' \<noteq> 0" by auto
     note IH = 1(1)[OF this refl dr'[symmetric] urel_integer_mult[OF x x] div]
     show ?thesis unfolding power_p.simps[of _ _ "y'"] power_p_integer.simps[of _ _ y] dr' id if_False rem
       using IH urel_integer_mult[OF IH x] by (auto simp: Let_def)
   qed
 qed
   
 
 lemma urel_integer_inverse: assumes x: "urel_integer x x'" 
   shows "urel_integer (inverse_p_integer pp x) (inverse_p p x')" 
 proof -
   have p: "urel_integer (pp - 2) (int (nat (p - 2)))" using p2 unfolding urel_integer_def unfolding ppp
     by auto
   show ?thesis
     unfolding inverse_p_integer_def inverse_p_def urel_integer_eq[OF x urel_integer_0] using urel_integer_0 urel_integer_power[OF x p]
     by auto
 qed
 
 lemma mod_ring_0__integer: "mod_ring_rel_integer 0 0"
   using urel_integer_0 mod_ring_0 unfolding mod_ring_rel_integer_def by blast
 
 lemma mod_ring_1__integer: "mod_ring_rel_integer 1 1"
   using urel_integer_1 mod_ring_1 unfolding mod_ring_rel_integer_def by blast
 
 lemma mod_ring_uminus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (uminus_p_integer pp) uminus"
   using urel_integer_uminus mod_ring_uminus unfolding mod_ring_rel_integer_def rel_fun_def by blast
 
 lemma mod_ring_plus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (plus_p_integer pp) (+)"
   using urel_integer_plus mod_ring_plus unfolding mod_ring_rel_integer_def rel_fun_def by blast
 
 lemma mod_ring_minus_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (minus_p_integer pp) (-)"
   using urel_integer_minus mod_ring_minus unfolding mod_ring_rel_integer_def rel_fun_def by blast
 
 lemma mod_ring_mult_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (mult_p_integer pp) ((*))"
   using urel_integer_mult mod_ring_mult unfolding mod_ring_rel_integer_def rel_fun_def by blast
 
 lemma mod_ring_eq_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> (=)) (=) (=)" 
   using urel_integer_eq mod_ring_eq unfolding mod_ring_rel_integer_def rel_fun_def by blast
 
 lemma urel_integer_inj: "urel_integer x y \<Longrightarrow> urel_integer x z \<Longrightarrow> y = z" 
   using urel_integer_eq[of x y x z] by auto
 
 lemma urel_integer_inj': "urel_integer x z \<Longrightarrow> urel_integer y z \<Longrightarrow> x = y" 
   using urel_integer_eq[of x z y z] by auto
 
 lemma bi_unique_mod_ring_rel_integer:
   "bi_unique mod_ring_rel_integer" "left_unique mod_ring_rel_integer" "right_unique mod_ring_rel_integer"
   using bi_unique_mod_ring_rel urel_integer_inj'
   unfolding mod_ring_rel_integer_def bi_unique_def left_unique_def right_unique_def
   by (auto simp: urel_integer_def)  
 
 lemma right_total_mod_ring_rel_integer: "right_total mod_ring_rel_integer"
   unfolding mod_ring_rel_integer_def right_total_def
 proof 
   fix y :: "'a mod_ring" 
   from right_total_mod_ring_rel[unfolded right_total_def, rule_format, of y]
   obtain z where zy: "mod_ring_rel z y" by auto  
   hence zp: "0 \<le> z" "z < p" unfolding mod_ring_rel_def p using range_to_int_mod_ring[where 'a = 'a] by auto
   hence "urel_integer (integer_of_int z) z" unfolding urel_integer_def unfolding ppp 
     by auto 
   with zy show "\<exists> x z. urel_integer x z \<and> mod_ring_rel z y" by blast
 qed
 
 lemma Domainp_mod_ring_rel_integer: "Domainp mod_ring_rel_integer = (\<lambda>x. 0 \<le> x \<and> x < pp)"
 proof 
   fix x
   show "Domainp mod_ring_rel_integer x = (0 \<le> x \<and> x < pp)"   
     unfolding Domainp.simps
     unfolding mod_ring_rel_integer_def
   proof
     let ?i = "int_of_integer" 
     assume *: "0 \<le> x \<and> x < pp"     
     hence "0 \<le> ?i x \<and> ?i x < p" unfolding ppp 
       by (simp add: le_int_of_integer less_integer.rep_eq)
     hence "?i x \<in> {0 ..< p}" by auto
     with Domainp_mod_ring_rel
     have "Domainp mod_ring_rel (?i x)" by auto
     from this[unfolded Domainp.simps]
     obtain b where b: "mod_ring_rel (?i x) b" by auto
     show "\<exists>a b. x = a \<and> (\<exists>z. urel_integer a z \<and> mod_ring_rel z b)" 
     proof (intro exI, rule conjI[OF refl], rule exI, rule conjI[OF _ b])
       show "urel_integer x (?i x)" unfolding urel_integer_def using * unfolding ppp
         by (simp add: le_int_of_integer less_integer.rep_eq)
     qed
   next
     assume "\<exists>a b. x = a \<and> (\<exists>z. urel_integer a z \<and> mod_ring_rel z b)" 
     then obtain b z where xz: "urel_integer x z" and zb: "mod_ring_rel z b" by auto
     hence "Domainp mod_ring_rel z"  by auto
     with Domainp_mod_ring_rel have "0 \<le> z" "z < p" by auto
     with xz show "0 \<le> x \<and> x < pp" unfolding urel_integer_def unfolding ppp
       by (simp add: le_int_of_integer less_integer.rep_eq)
   qed
 qed
 
 lemma ring_finite_field_ops_integer: "ring_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
   by (unfold_locales, auto simp:
   finite_field_ops_integer_def
   bi_unique_mod_ring_rel_integer
   right_total_mod_ring_rel_integer
   mod_ring_plus_integer
   mod_ring_minus_integer
   mod_ring_uminus_integer
   mod_ring_mult_integer
   mod_ring_eq_integer
   mod_ring_0__integer
   mod_ring_1__integer
   Domainp_mod_ring_rel_integer)
 end
 end
 
 context prime_field
 begin
 context fixes pp :: "integer" 
   assumes *: "p = int_of_integer pp"  
 begin
 
 lemma mod_ring_normalize_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x. if x = 0 then 0 else 1) normalize" 
   using urel_integer_normalize[OF *] mod_ring_normalize unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_mod_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x y. if y = 0 then x else 0) (mod)" 
   using urel_integer_mod[OF *] mod_ring_mod unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_unit_factor_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (\<lambda>x. x) unit_factor" 
   using mod_ring_unit_factor unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_inverse_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer) (inverse_p_integer pp) inverse"
   using urel_integer_inverse[OF *] mod_ring_inverse unfolding mod_ring_rel_integer_def[OF *] rel_fun_def by blast
 
 lemma mod_ring_divide_integer: "(mod_ring_rel_integer ===> mod_ring_rel_integer ===> mod_ring_rel_integer) (divide_p_integer pp) (/)"
   using mod_ring_inverse_integer mod_ring_mult_integer[OF *]
   unfolding divide_p_integer_def divide_mod_ring_def inverse_mod_ring_def[symmetric]
     rel_fun_def by blast
 
 lemma finite_field_ops_integer: "field_ops (finite_field_ops_integer pp) mod_ring_rel_integer"
   by (unfold_locales, insert ring_finite_field_ops_integer[OF *], auto simp:
   ring_ops_def
   finite_field_ops_integer_def
   mod_ring_divide_integer
   mod_ring_inverse_integer
   mod_ring_mod_integer
   mod_ring_normalize_integer)
 end
 end
 
 context prime_field
 begin
  (* four implementations of modular integer arithmetic for finite fields *)
 thm 
   finite_field_ops64
   finite_field_ops32
   finite_field_ops_integer
   finite_field_ops_int
 end
 
 context mod_ring_locale
 begin
  (* four implementations of modular integer arithmetic for finite rings *)
 thm 
   ring_finite_field_ops64
   ring_finite_field_ops32
   ring_finite_field_ops_integer
   ring_finite_field_ops_int
 end
 
 no_notation shiftr (infixl ">>" 55) (* to avoid conflict with bind *)
 end
diff --git a/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy b/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
--- a/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
+++ b/thys/Ordinary_Differential_Equations/Numerics/Refine_Rigorous_Numerics_Aform.thy
@@ -1,1743 +1,1740 @@
 theory Refine_Rigorous_Numerics_Aform
   imports
     Refine_Rigorous_Numerics
     "HOL-Types_To_Sets.Types_To_Sets"
 begin
 
 lemma Joints_ne_empty[simp]: "Joints xs \<noteq> {}" "{} \<noteq> Joints xs"
   by (auto simp: Joints_def valuate_def)
 
 lemma Inf_aform_le_Affine: "x \<in> Affine X \<Longrightarrow> Inf_aform X \<le> x"
   by (auto simp: Affine_def valuate_def intro!: Inf_aform)
 lemma Sup_aform_ge_Affine: "x \<in> Affine X \<Longrightarrow> x \<le> Sup_aform X"
   by (auto simp: Affine_def valuate_def intro!: Sup_aform)
 
 lemmas Inf_aform'_Affine_le = order_trans[OF Inf_aform' Inf_aform_le_Affine]
 lemmas Sup_aform'_Affine_ge = order_trans[OF Sup_aform_ge_Affine Sup_aform']
 
 fun approx_form_aform :: "nat \<Rightarrow> form \<Rightarrow> real aform list \<Rightarrow> bool" where
 "approx_form_aform prec (Less a b) bs =
    (case (approx_floatariths prec [a - b] bs)
    of Some [r] \<Rightarrow> Sup_aform' prec r < 0
     | _ \<Rightarrow> False)"
 | "approx_form_aform prec (LessEqual a b) bs =
    (case (approx_floatariths prec [a - b] bs)
    of Some [r] \<Rightarrow> Sup_aform' prec r \<le> 0
     | _ \<Rightarrow> False)"
 | "approx_form_aform prec (AtLeastAtMost a b c) bs =
    (case (approx_floatariths prec [a - b, a - c] bs)
    of Some [r, s] \<Rightarrow> 0 \<le> Inf_aform' prec r \<and>  Sup_aform' prec s \<le> 0
     | _ \<Rightarrow> False)"
 | "approx_form_aform prec (Bound a b c d) bs = False"
 | "approx_form_aform prec (Assign a b c) bs = False"
 | "approx_form_aform prec (Conj a b) bs \<longleftrightarrow>
     approx_form_aform prec a bs \<and> approx_form_aform prec b bs"
 | "approx_form_aform prec (Disj a b) bs \<longleftrightarrow>
     approx_form_aform prec a bs \<or> approx_form_aform prec b bs"
 
 lemma in_Joints_intervalD:
   "x \<in> {Inf_aform' p X .. Sup_aform' p X} \<and> xs \<in> Joints XS"
   if "x#xs \<in> Joints (X#XS)"
   using that
   by (auto simp: Joints_def valuate_def Affine_def
       intro!: Inf_aform'_Affine_le Sup_aform'_Affine_ge)
 
 lemma approx_form_aform:
   "interpret_form f vs"
   if "approx_form_aform p f VS" "vs \<in> Joints VS"
   using that
   by (induction f)
     (auto split: option.splits list.splits simp: algebra_simps
       dest!: approx_floatariths_outer
       dest!: in_Joints_intervalD[where p=p])
 
 fun msum_aforms::"nat \<Rightarrow> real aform list \<Rightarrow> real aform list \<Rightarrow> real aform list"  where
   "msum_aforms d (x#xs) (y#ys) = msum_aform d x y#msum_aforms d xs ys"
 | "msum_aforms d _ _ = []"
 
 definition [simp]: "degree_aforms_real = (degree_aforms::real aform list \<Rightarrow> nat)"
 
 abbreviation "msum_aforms' \<equiv> \<lambda>X Y. msum_aforms (degree_aforms_real (X @ Y)) X Y"
 
 lemma aform_val_msum_aforms:
   assumes "degree_aforms xs \<le> d"
   shows "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\<lambda>i. e (i + d)) ys)"
   using assms
 proof (induction xs ys rule: msum_aforms.induct)
   case (1 d x xs y ys)
   from 1 have "degree_aforms xs \<le> d"
     by (auto simp: degrees_def)
   from 1(1)[OF this] 1
   have "aform_vals e (msum_aforms d xs ys) = List.map2 (+) (aform_vals e xs) (aform_vals (\<lambda>i. e (i + d)) ys)"
     by simp
   then show ?case
     using 1
     by (simp add: aform_vals_def aform_val_msum_aform degrees_def)
 qed (auto simp: aform_vals_def)
 
 lemma Joints_msum_aforms:
   assumes "degree_aforms xs \<le> d"
   assumes "degree_aforms ys \<le> d"
   shows "Joints (msum_aforms d xs ys) = {List.map2 (+) a b |a b. a \<in> Joints xs \<and> b \<in> Joints ys}"
   apply (auto simp: Joints_def valuate_def aform_vals_def[symmetric]
       aform_val_msum_aforms assms)
    apply force
   subgoal for e e'
     apply (rule image_eqI[where x="\<lambda>i. if i < d then e i else e' (i - d)"])
      apply (auto simp: Pi_iff)
   proof goal_cases
     case 1
     have "(aform_vals e xs) = aform_vals (\<lambda>i. if i < d then e i else e' (i - d)) xs"
       using assms
       by (auto intro!: simp: aform_vals_def aform_val_def degrees_def intro!: pdevs_val_degree_cong)
     then show ?case
       by simp
   qed
   done
 
 definition "split_aforms_largest_uncond_take n X =
   (let (i, x) = max_pdev (abssum_of_pdevs_list (map snd (take n X))) in split_aforms X i)"
 
 text \<open>intersection with plane\<close>
 
 definition
   "project_coord x b n = (\<Sum>i\<leftarrow>Basis_list. (if i = b then n else if i = -b then -n else x \<bullet> i) *\<^sub>R i)"
 
 lemma inner_eq_abs_times_sgn:
   "u \<bullet> b = abs u \<bullet> b * sgn (u \<bullet> b)" if "b \<in> Basis" for b::"'a::ordered_euclidean_space"
   by (subst sgn_mult_abs[symmetric]) (auto simp: that abs_inner )
 
 lemma inner_Basis_eq_zero_absI: "x \<in> Basis \<Longrightarrow> abs u \<in> Basis \<Longrightarrow> x \<noteq> \<bar>u\<bar> \<Longrightarrow> x \<noteq> 0 \<Longrightarrow> u \<bullet> x = 0"
   for x::"'a::ordered_euclidean_space"
   apply (subst euclidean_inner)
   apply (auto simp: inner_Basis if_distribR if_distrib cong: if_cong)
   apply (subst inner_eq_abs_times_sgn)
   by (auto simp: inner_Basis)
 
 lemma abs_in_BasisE:
   fixes u::"'a::ordered_euclidean_space"
   assumes "abs u \<in> Basis"
   obtains "abs u = u" | "abs u = - u"
 proof (cases "u \<bullet> abs u = 1")
   case True
   have "abs u = (\<Sum>i\<in>Basis. (if i = abs u then (abs u \<bullet> i) *\<^sub>R i else 0))"
     using assms
     by (auto simp: )
   also have "\<dots> = (\<Sum>i\<in>Basis. (if i = abs u then (u \<bullet> i) *\<^sub>R i else 0))"
     by (rule sum.cong) (auto simp: True)
   also have "\<dots> = (\<Sum>i\<in>Basis. (u \<bullet> i) *\<^sub>R i)"
     by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms)
   also have "\<dots> = u" by (simp add: euclidean_representation)
   finally show ?thesis ..
 next
   case False
   then have F: "u \<bullet> \<bar>u\<bar> = -1"
     apply (subst inner_eq_abs_times_sgn[OF assms]) 
     apply (subst (asm) inner_eq_abs_times_sgn[OF assms]) 
     using assms
     apply (auto simp: inner_Basis sgn_if)
     by (metis (full_types) abs_0_eq euclidean_all_zero_iff inner_Basis_eq_zero_absI nonzero_Basis)
   have "abs u = (\<Sum>i\<in>Basis. (if i = abs u then (abs u \<bullet> i) *\<^sub>R i else 0))"
     using assms
     by (auto simp: )
   also have "\<dots> = (\<Sum>i\<in>Basis. (if i = abs u then (- u \<bullet> i) *\<^sub>R i else 0))"
     by (rule sum.cong) (auto simp: F)
   also have "\<dots> = (\<Sum>i\<in>Basis. (- u \<bullet> i) *\<^sub>R i)"
     by (rule sum.cong) (auto simp: inner_Basis_eq_zero_absI assms)
   also have "\<dots> = - u" by (subst euclidean_representation) simp
   finally show ?thesis ..
 qed
   
 lemma abs_in_Basis_iff:
   fixes u::"'a::ordered_euclidean_space"
   shows "abs u \<in> Basis \<longleftrightarrow> u \<in> Basis \<or> - u \<in> Basis"
 proof -
   have u: "u = (\<Sum>i\<in>Basis. (u \<bullet> i) *\<^sub>R i)"
     by (simp add: euclidean_representation)
   have u': "- u = (\<Sum>i\<in>Basis. (- (u \<bullet> i)) *\<^sub>R i)"
     by (subst u) (simp add: sum_negf)
   have au: "abs u = (\<Sum>i\<in>Basis. \<bar>u \<bullet> i\<bar> *\<^sub>R i)"
     by (simp add: eucl_abs[where 'a='a])
   have "(u \<in> Basis \<or> - u \<in> Basis)" if "(\<bar>u\<bar> \<in> Basis)"
     apply (rule abs_in_BasisE[OF that])
     using that
     by auto
   show ?thesis
     apply safe
     subgoal premises prems
       using prems(1)
       apply (rule abs_in_BasisE)
       using prems
       by simp_all
     subgoal
       apply (subst au)
       apply (subst (asm) u)
       apply (subst sum.cong[OF refl])
        apply (subst abs_inner[symmetric]) apply auto
       using u apply auto[1]
       done
     subgoal
       apply (subst au)
       apply (subst (asm) u')
       apply (subst sum.cong[OF refl])
       apply (subst abs_inner[symmetric]) apply auto
       using u' apply auto
       by (metis Basis_nonneg abs_of_nonpos inner_minus_left neg_0_le_iff_le scaleR_left.minus)
     done
 qed
 
 lemma abs_inner_Basis:
   fixes u v::"'a::ordered_euclidean_space"
   assumes "abs u \<in> Basis" "abs v \<in> Basis"
   shows "inner u v = (if u = v then 1 else if u = -v then -1 else 0)"
 proof -
   define i where "i \<equiv> if u \<in> Basis then u else -u"
   define j where "j \<equiv> if v \<in> Basis then v else -v"
   have u: "u = (if u \<in> Basis then i else - i)"
     and v: "v = (if v \<in> Basis then j else - j)"
     by (auto simp: i_def j_def)
   have "i \<in> Basis" "j \<in> Basis"
     using assms
      by (auto simp: i_def j_def abs_in_Basis_iff)
    then show ?thesis
      apply (subst u)
      apply (subst v)
      apply (auto simp: inner_Basis)
      apply (auto simp: j_def i_def split: if_splits)
      using Basis_nonneg abs_of_nonpos by fastforce
  qed
 
 lemma
   project_coord_inner_Basis:
   assumes "i \<in> Basis"
   shows "(project_coord x b n) \<bullet> i = (if i = b then n else if i = -b then -n else x \<bullet> i)"
 proof -
   have "project_coord x b n \<bullet> i =
     (\<Sum>j\<in>Basis. (if j = b then n else if j = -b then -n else x \<bullet> j) * (if j = i then 1 else 0))"
     using assms
     by (auto simp: project_coord_def inner_sum_left inner_Basis)
   also have "\<dots> = (\<Sum>j\<in>Basis. (if j = i then (if j = b then n else if j = -b then -n else x \<bullet> j) else 0))"
     by (rule sum.cong) auto
   also have "\<dots> = (if i = b then n else if i = -b then -n else x \<bullet> i)"
     using assms
     by (subst sum.delta) auto
   finally show ?thesis by simp
 qed
 
 lemma
   project_coord_inner:
   assumes "abs i \<in> Basis"
   shows "(project_coord x b n) \<bullet> i = (if i = b then n else if i = -b then -n else x \<bullet> i)"
 proof -
   consider "i \<in> Basis" | "- i \<in> Basis"
     using assms
     by (auto simp: abs_in_Basis_iff)
   then show ?thesis
   proof cases
     case 1
     then show ?thesis by (simp add: project_coord_inner_Basis)
   next
     case 2
     have "project_coord x b n \<bullet> i = - (project_coord x b n \<bullet> - i)"
       by simp
     also have "\<dots> = - (if - i = b then n else if - i = -b then -n else x \<bullet> - i)"
       using 2
       by (subst project_coord_inner_Basis) simp_all
     also have "\<dots> = (if i = b then n else if i = -b then -n else x \<bullet> i)"
       using 2 by auto (metis Basis_nonneg abs_le_zero_iff abs_of_nonneg neg_le_0_iff_le nonzero_Basis)
     finally show ?thesis .
   qed
 qed
 
 lift_definition project_coord_pdevs::"'a::executable_euclidean_space sctn \<Rightarrow> 'a pdevs \<Rightarrow> 'a pdevs" is
   "\<lambda>sctn xs i. project_coord (xs i) (normal sctn) 0"
   by (rule finite_subset) (auto simp: project_coord_def cong: if_cong)
 
 definition "project_coord_aform sctn cxs =
   (project_coord (fst cxs) (normal sctn) (pstn sctn), project_coord_pdevs sctn (snd cxs))"
 
 definition project_coord_aform_lv :: "real aform list \<Rightarrow> nat \<Rightarrow> real \<Rightarrow> real aform list"
   where "project_coord_aform_lv xs b n = xs[b:=(n, zero_pdevs)]"
 
 definition "project_ncoord_aform x b n = project_coord_aform (Sctn (Basis_list ! b) n) x"
 
 lemma
   finite_sum_subset_aux_lemma:
   assumes "finite s"
   shows " {i. (\<Sum>x\<in>s. f x i) \<noteq> 0} \<subseteq> {i. \<exists>x\<in>s. f x i \<noteq> 0}"
 proof -
   have "{i. (\<Sum>x\<in>s. f x i) \<noteq> 0} = - {i. (\<Sum>x\<in>s. f x i) = 0}"
     by auto
   also have "\<dots> \<subseteq> - {i. \<forall>x \<in> s. f x i = 0}"
     by auto
   also have "\<dots> = {i. \<exists>x \<in> s. f x i \<noteq> 0}"
     by auto
   finally show ?thesis by simp
 qed
 
 lift_definition sum_pdevs::"('i \<Rightarrow> 'a::comm_monoid_add pdevs) \<Rightarrow> 'i set \<Rightarrow>  'a pdevs"
   is "\<lambda>f X. if finite X then (\<lambda>i. \<Sum>x\<in>X. f x i) else (\<lambda>_. 0)"
   apply auto
   apply (rule finite_subset)
    apply (rule finite_sum_subset_aux_lemma)
    apply auto
   done
 
 lemma pdevs_apply_sum_pdevs[simp]:
   "pdevs_apply (sum_pdevs f X) i = (\<Sum>x\<in>X. pdevs_apply (f x) i)"
   by transfer auto
 
 lemma sum_pdevs_empty[simp]: "sum_pdevs f {} = zero_pdevs"
   by transfer auto
 
 lemma sum_pdevs_insert[simp]:
   "finite xs \<Longrightarrow> sum_pdevs f (insert a xs) =
     (if a \<in> xs then sum_pdevs f xs else add_pdevs (f a) (sum_pdevs f xs))"
   by (auto simp: insert_absorb intro!: pdevs_eqI)
 
 lemma sum_pdevs_infinite[simp]: "infinite X \<Longrightarrow> sum_pdevs f X = zero_pdevs"
   by transfer auto
 
 lemma compute_sum_pdevs[code]:
   "sum_pdevs f (set XS) = foldr (\<lambda>a b. add_pdevs (f a) b) (remdups XS) zero_pdevs"
   by (induction XS) (auto simp: )
 
 lemma degree_sum_pdevs_le:
   "degree (sum_pdevs f X) \<le> Max (degree ` f ` X)"
   apply (rule degree_le)
   apply auto
   apply (cases "X = {}")
   subgoal by (simp add: )
   subgoal by (cases "finite X") simp_all
   done
 
 lemma pdevs_val_sum_pdevs:
   "pdevs_val e (sum_pdevs f X) = (\<Sum>x\<in>X. pdevs_val e (f x))"
   apply (cases "finite X")
   subgoal
     apply (subst pdevs_val_sum_le)
      apply (rule degree_sum_pdevs_le)
     apply (auto simp: scaleR_sum_right)
     apply (subst sum.swap)
     apply (rule sum.cong[OF refl])
     apply (subst pdevs_val_sum_le[where d="Max (degree ` f ` X)"])
      apply (auto simp: Max_ge_iff)
     done
   subgoal by simp
   done
 
 definition eucl_of_list_aform :: "(real \<times> real pdevs) list \<Rightarrow> 'a::executable_euclidean_space aform"
 where "eucl_of_list_aform xs =
   (eucl_of_list (map fst xs), sum_pdevs (\<lambda>i. pdevs_scaleR (snd (xs ! index Basis_list i)) i) Basis)"
 
 definition lv_aforms_rel::"(((real \<times> real pdevs) list) \<times> ('a::executable_euclidean_space aform)) set"
   where "lv_aforms_rel = br eucl_of_list_aform (\<lambda>xs. length xs = DIM('a))"
 
 
 definition "inner_aforms' p X Y =
   (let fas = [inner_floatariths (map floatarith.Var [0..<length X])
     (map floatarith.Var[length X..<length X + length Y])]
   in
     approx_slp_outer p (length fas) fas (X@Y)
     )"
 
 lemma
   affine_extension_AffineD:
   assumes "affine_extension2 (\<lambda>d x y. Some (F d x y)) f"
   assumes "[x, y] \<in> Joints [X, Y]"
   assumes "d \<ge> degree_aform X"
   assumes "d \<ge> degree_aform Y"
   shows "f x y \<in> Affine (F d X Y)"
 proof -
   from assms(2) obtain e where e:
     "e \<in> funcset UNIV {-1 .. 1}"
     "x = aform_val e X"
     "y = aform_val e Y"
     by (auto simp: Joints_def valuate_def)
   from affine_extension2E[OF assms(1) refl e(1) assms(3) assms(4)]
   obtain e' where "e' \<in> funcset UNIV {- 1..1}" "f (aform_val e X) (aform_val e Y) = aform_val e' (F d X Y)"
     "\<And>n. n < d \<Longrightarrow> e' n = e n" "aform_val e X = aform_val e' X" "aform_val e Y = aform_val e' Y"
     by auto
   then show ?thesis by (auto simp: Affine_def valuate_def e)
 qed
 
 lemma aform_val_zero_pdevs[simp]: "aform_val e (x, zero_pdevs) = x"
   by (auto simp: aform_val_def)
 
 lemma neg_equal_zero_eucl[simp]: "-a = a \<longleftrightarrow> a = 0" for a::"'a::euclidean_space"
   by (auto simp: algebra_simps euclidean_eq_iff[where 'a='a])
 
 context includes autoref_syntax begin
 
 lemma Option_bind_param[param, autoref_rules]:
   "((\<bind>), (\<bind>)) \<in> \<langle>S\<rangle>option_rel \<rightarrow> (S \<rightarrow> \<langle>R\<rangle>option_rel) \<rightarrow> \<langle>R\<rangle>option_rel"
   unfolding Option.bind_def
   by parametricity
 
 lemma zip_Basis_list_pat[autoref_op_pat_def]: "\<Sum>(b, m)\<leftarrow>zip Basis_list ms. m *\<^sub>R b \<equiv> OP eucl_of_list $ ms"
 proof (rule eq_reflection)
   have z: "zip ms (Basis_list::'a list) = map (\<lambda>(x, y). (y, x)) (zip Basis_list ms)"
     by (subst zip_commute) simp
   show "(\<Sum>(b, m)\<leftarrow>zip (Basis_list::'a list) ms. m *\<^sub>R b) = OP eucl_of_list $ ms"
     unfolding eucl_of_list_def autoref_tag_defs
     apply (subst z)
     apply (subst map_map)
     apply (auto cong: map_cong simp: split_beta')
     done
 qed
 
 lemma length_aforms_of_ivls: "length (aforms_of_ivls a b) = min (length a) (length b)"
   by (auto simp: aforms_of_ivls_def)
 
 lemma length_lv_rel:
   "(ys, y::'a) \<in> lv_rel \<Longrightarrow> length ys = DIM('a::executable_euclidean_space)"
   by (auto simp: lv_rel_def br_def)
 
 lemma lv_rel_nth[simp]: "(xs, x::'a::executable_euclidean_space) \<in> lv_rel \<Longrightarrow> b \<in> Basis \<Longrightarrow>
   xs ! index (Basis_list) b = x \<bullet> b"
   unfolding lv_rel_def
   by (auto simp: br_def eucl_of_list_inner)
 
 lemma aform_of_ivl_autoref[autoref_rules]:
   "(aforms_of_ivls, aform_of_ivl) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> lv_aforms_rel"
   apply (auto simp: lv_aforms_rel_def br_def eucl_of_list_aform_def length_aforms_of_ivls length_lv_rel)
   subgoal for xs x ys y
     apply (auto simp: aform_of_ivl_def aforms_of_ivls_def o_def eucl_of_list_inner inner_simps
         pdevs_apply_pdevs_of_ivl length_lv_rel
         intro!: euclidean_eqI[where 'a='a] pdevs_eqI)
     by (metis index_Basis_list_nth inner_not_same_Basis length_Basis_list nth_Basis_list_in_Basis)
   done
 
 lemma bound_intersect_2d_ud[autoref_rules]:
   shows "(bound_intersect_2d_ud, bound_intersect_2d_ud) \<in> nat_rel \<rightarrow> ((rnv_rel \<times>\<^sub>r rnv_rel) \<times>\<^sub>r Id) \<rightarrow> rnv_rel \<rightarrow> \<langle>rnv_rel \<times>\<^sub>r rnv_rel\<rangle>option_rel"
   by auto
 
 lemma eucl_of_list_autoref[autoref_rules]:
   includes autoref_syntax
   assumes "SIDE_PRECOND (length xs = DIM('a::executable_euclidean_space))"
   assumes "(xsi, xs) \<in> \<langle>rnv_rel\<rangle>list_rel"
   shows "(xsi, eucl_of_list $ xs::'a) \<in> lv_rel"
   using assms
   unfolding lv_rel_def
   by (auto simp: br_def)
 
 definition "inner2s x b c = (inner_lv_rel x b, inner_lv_rel x c)"
 
 lemma inner_lv_rel_autoref[autoref_rules]:
   "(inner_lv_rel, (\<bullet>)) \<in> lv_rel \<rightarrow> lv_rel \<rightarrow> rnv_rel"
   using lv_rel_inner[unfolded inner_lv_rel_def[symmetric]]
   by auto
 
 lemma inner_lv_rel_eq:
   "\<lbrakk>length xs = DIM('a::executable_euclidean_space); (xa, x'a) \<in> lv_rel\<rbrakk> \<Longrightarrow>
   inner_lv_rel xs xa = eucl_of_list xs \<bullet> (x'a::'a)"
   using inner_lv_rel_autoref[param_fo, of "xs" "eucl_of_list xs" xa x'a]
   unfolding lv_rel_def
   by (auto simp: br_def)
 
 definition "inner_pdevs xs ys = sum_pdevs (\<lambda>i. scaleR_pdevs (ys ! i) (xs ! i)) {..<length xs}"
 
 definition "pdevs_inner2s xs a b = prod_of_pdevs (inner_pdevs xs a) (inner_pdevs xs b)"
 
 lemma inner2_aform_autoref[autoref_rules]:
   shows "((\<lambda>xs a b. (inner2s (map fst xs) a b, pdevs_inner2s (map snd xs) a b)), inner2_aform) \<in> lv_aforms_rel \<rightarrow> lv_rel \<rightarrow> lv_rel \<rightarrow> ((rnv_rel \<times>\<^sub>r rnv_rel)\<times>\<^sub>rId)"
   unfolding inner2_aform_def
   apply (auto simp: lv_aforms_rel_def br_def eucl_of_list_aform_def inner2_aform_def )
    apply (auto simp: inner2s_def inner2_def inner_lv_rel_eq pdevs_inner2s_def inner_pdevs_def
       sum_Basis_sum_nth_Basis_list inner_sum_left inner_Basis mult.commute
       intro!: pdevs_eqI)
   subgoal for a b c d e f
     apply (rule sum.cong)
      apply force
     subgoal for n by (auto dest!: lv_rel_nth[where b="Basis_list ! n"] simp: inner_commute)
     done
   subgoal for a b c d e f
     apply (rule sum.cong)
      apply force
     subgoal for n by (auto dest!: lv_rel_nth[where b="Basis_list ! n"] simp: inner_commute)
     done
   done
 
 lemma RETURN_inter_aform_plane_ortho_annot:
   "RETURN (inter_aform_plane_ortho p (Z::'a aform) n g) =
     (case those (map (\<lambda>b. bound_intersect_2d_ud p (inner2_aform Z n b) g) Basis_list) of
       Some mMs \<Rightarrow>
       do {
         ASSERT (length mMs = DIM('a::executable_euclidean_space));
         let l = (\<Sum>(b, m)\<leftarrow>zip Basis_list (map fst mMs). m *\<^sub>R b);
         let u = (\<Sum>(b, M)\<leftarrow>zip Basis_list (map snd mMs). M *\<^sub>R b);
         RETURN (Some (aform_of_ivl l u))
       }
   | None \<Rightarrow> RETURN None)"
   apply (auto simp: inter_aform_plane_ortho_def split: option.splits)
   subgoal premises prems for x2
   proof -
     have "length x2 = DIM('a)" using prems
       using map_eq_imp_length_eq by (force simp: those_eq_Some_map_Some_iff)
     then show ?thesis using prems by auto
   qed
   done
 
 definition "inter_aform_plane_ortho_nres p Z n g = RETURN (inter_aform_plane_ortho p Z n g)"
 
 schematic_goal inter_aform_plane_ortho_lv:
   fixes Z::"'a::executable_euclidean_space aform"
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a) D"
   assumes [autoref_rules]: "(pp, p) \<in> nat_rel" "(Zi, Z) \<in> lv_aforms_rel"
     "(ni, n) \<in> lv_rel" "(gi, g) \<in> rnv_rel"
   notes [autoref_rules] = those_param param_map
   shows "(nres_of (?f::?'a dres), inter_aform_plane_ortho_nres $ p $ Z $ n $ g) \<in> ?R"
   unfolding autoref_tag_defs
   unfolding RETURN_inter_aform_plane_ortho_annot inter_aform_plane_ortho_nres_def
   including art
   by autoref_monadic
 concrete_definition inter_aform_plane_ortho_lv for pp Zi ni gi uses inter_aform_plane_ortho_lv
 lemmas [autoref_rules] = inter_aform_plane_ortho_lv.refine
 
 lemma project_coord_lv[autoref_rules]:
   assumes "(xs, x::'a::executable_euclidean_space aform) \<in> lv_aforms_rel" "(ni, n) \<in> nat_rel"
   assumes "SIDE_PRECOND (n < DIM('a))"
   shows "(project_coord_aform_lv xs ni, project_ncoord_aform $ x $ n) \<in> rnv_rel \<rightarrow> lv_aforms_rel"
   using assms
   apply (auto simp: project_coord_aform_lv_def project_ncoord_aform_def lv_rel_def
       project_coord_aform_def eucl_of_list_aform_def
       lv_aforms_rel_def br_def)
   subgoal
     apply (auto intro!: euclidean_eqI[where 'a='a])
     apply (subst project_coord_inner_Basis)
      apply (auto simp: eucl_of_list_inner )
      apply (subst nth_list_update)
       apply (auto simp: )
     using in_Basis_index_Basis_list apply force
     using inner_not_same_Basis nth_Basis_list_in_Basis apply fastforce
     apply (auto simp: nth_list_update)
     done
   subgoal for i
     apply (auto intro!: pdevs_eqI simp: project_coord_pdevs.rep_eq)
     apply (auto intro!: euclidean_eqI[where 'a='a])
     apply (subst project_coord_inner_Basis)
      apply (auto simp: eucl_of_list_inner )
      apply (subst nth_list_update)
       apply (auto simp: )
     using inner_not_same_Basis nth_Basis_list_in_Basis apply fastforce
     apply (auto simp: nth_list_update)
     done
   done
 
 definition inter_aform_plane
   where "inter_aform_plane prec Xs (sctn::'a sctn) =
     do {
       cxs \<leftarrow> inter_aform_plane_ortho_nres (prec) (Xs) (normal sctn) (pstn sctn);
       case cxs of
         Some cxs \<Rightarrow>
           (if normal sctn \<in> set Basis_list
             then do {
               ASSERT (index Basis_list (normal sctn) < DIM('a::executable_euclidean_space));
               RETURN ((project_ncoord_aform cxs (index Basis_list (normal sctn)) (pstn sctn)))
             }
           else if - normal sctn \<in> set Basis_list
             then do {
               ASSERT (index Basis_list (-normal sctn) < DIM('a));
               RETURN ((project_ncoord_aform cxs (index Basis_list (-normal sctn)) (- pstn sctn)))
             }
           else SUCCEED)
       | None \<Rightarrow> SUCCEED
     }"
 
 lemma [autoref_rules]:
   assumes [THEN GEN_OP_D, param]: "GEN_OP (=) (=) (A \<rightarrow> A \<rightarrow> bool_rel)"
   shows "(index, index) \<in> \<langle>A\<rangle>list_rel \<rightarrow> A \<rightarrow> nat_rel"
   unfolding index_def find_index_def
   by parametricity
 
 schematic_goal inter_aform_plane_lv:
   fixes Z::"'a::executable_euclidean_space aform"
   assumes [autoref_rules_raw]: "DIM_precond TYPE('a) D"
   assumes [autoref_rules]: "(preci, prec) \<in> nat_rel" "(Zi, Z) \<in> lv_aforms_rel"
       "(sctni, sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
   notes [autoref_rules] = those_param param_map
   shows "(nres_of (?f::?'a dres), inter_aform_plane prec Z sctn) \<in> ?R"
   unfolding autoref_tag_defs
   unfolding inter_aform_plane_def
   including art
   by (autoref_monadic )
 
 concrete_definition inter_aform_plane_lv for preci Zi sctni uses inter_aform_plane_lv
 lemmas [autoref_rules] = inter_aform_plane_lv.refine[autoref_higher_order_rule(1)]
 
 end
 
 
 lemma Basis_not_uminus:
   fixes i::"'a::euclidean_space"
   shows "i \<in> Basis \<Longrightarrow> - i \<notin> Basis"
   by (metis inner_Basis inner_minus_left one_neq_neg_one zero_neq_neg_one)
 
 lemma
   pdevs_apply_project_coord_pdevs:
   assumes "normal sctn \<in> Basis \<or> - normal sctn \<in> Basis"
   assumes "i \<in> Basis"
   shows "pdevs_apply (project_coord_pdevs sctn cxs) x \<bullet> i =
     (if i = abs (normal sctn) then 0 else pdevs_apply cxs x \<bullet> i)"
   using assms[unfolded abs_in_Basis_iff[symmetric]]
   apply (transfer fixing: sctn)
   apply (auto simp: project_coord_inner Basis_not_uminus)
   using Basis_nonneg apply force
   using Basis_nonneg assms(1) by force
 
 lemma pdevs_domain_project_coord_pdevs_subset:
   "pdevs_domain (project_coord_pdevs sctn X) \<subseteq> pdevs_domain X"
   apply (auto simp: )
   apply (auto simp: euclidean_eq_iff[where 'a='a] )
   by (metis add.inverse_neutral project_coord_inner_Basis project_coord_pdevs.rep_eq)
 
 lemma pdevs_val_project_coord_pdevs_inner_Basis:
   assumes "b \<in> Basis"
   shows "pdevs_val e (project_coord_pdevs sctn X) \<bullet> b =
     (if b = abs (normal sctn) then 0 else pdevs_val e X \<bullet> b)"
   using assms
   apply (auto simp: )
    apply (simp add: pdevs_val_pdevs_domain inner_sum_left )
    apply (subst sum.cong[OF refl])
     apply (subst pdevs_apply_project_coord_pdevs)
       apply (simp add: abs_in_Basis_iff)
      apply simp
     apply (rule refl)
    apply auto
   unfolding pdevs_val_pdevs_domain inner_sum_left
   apply (rule sum.mono_neutral_cong_left)
      apply simp
     apply (rule pdevs_domain_project_coord_pdevs_subset)
      apply auto
    apply (metis Basis_nonneg abs_minus_cancel abs_of_nonneg euclidean_all_zero_iff
       project_coord_inner_Basis project_coord_pdevs.rep_eq)
    apply (metis Basis_nonneg abs_minus_cancel abs_of_nonneg
       project_coord_inner_Basis project_coord_pdevs.rep_eq)
   done
 
 lemma inner_in_Sum: "b \<in> Basis \<Longrightarrow> x \<bullet> b = (\<Sum>i\<in>Basis. x \<bullet> i * (i \<bullet> b))"
   apply (subst euclidean_representation[of x, symmetric])
   unfolding inner_sum_left
   by (auto simp: intro!: )
 
 lemma aform_val_project_coord_aform:
   "aform_val e (project_coord_aform sctn X) = project_coord (aform_val e X) (normal sctn) (pstn sctn)"
   apply (auto simp: aform_val_def project_coord_def project_coord_aform_def)
   apply (rule euclidean_eqI)
   unfolding inner_add_left inner_sum_left
   apply (subst pdevs_val_project_coord_pdevs_inner_Basis)
    apply (auto simp: )
    apply (rule sum.cong)
   apply auto
    apply (metis abs_in_Basis_iff abs_inner abs_inner_Basis abs_zero inner_commute)
   apply (subst inner_in_Sum[where x="pdevs_val e (snd X)"], force)
   unfolding sum.distrib[symmetric]
   apply (rule sum.cong)
   apply auto
   apply (metis Basis_nonneg abs_inner_Basis abs_of_nonneg abs_of_nonpos inner_commute neg_0_le_iff_le)
    apply (metis Basis_nonneg abs_inner_Basis abs_of_nonneg abs_of_nonpos neg_0_le_iff_le)
   apply (auto simp: inner_Basis)
   done
 
 lemma project_coord_on_plane:
   assumes "x \<in> plane_of (Sctn n c)"
   shows "project_coord x n c = x"
   using assms
   by (auto simp: project_coord_def plane_of_def intro!: euclidean_eqI[where 'a='a])
 
 lemma
   mem_Affine_project_coord_aformI:
   assumes "x \<in> Affine X"
   assumes "x \<in> plane_of sctn"
   shows "x \<in> Affine (project_coord_aform sctn X)"
 proof -
   have "x = project_coord x (normal sctn) (pstn sctn)"
     using assms by (intro project_coord_on_plane[symmetric]) auto
   also
   from assms obtain e where "e \<in> funcset UNIV {-1 .. 1}" "x = aform_val e X"
     by (auto simp: Affine_def valuate_def)
   note this(2)
   also have "project_coord (aform_val e X) (normal sctn) (pstn sctn) =
     aform_val e (project_coord_aform sctn X)"
     by (simp add: aform_val_project_coord_aform)
   finally have "x = aform_val e (project_coord_aform sctn X)" unfolding \<open>x = aform_val e X\<close> .
   then show ?thesis using \<open>e \<in> _\<close>
     by (auto simp: Affine_def valuate_def)
 qed
 
 lemma
   mem_Affine_project_coord_aformD:
   assumes "x \<in> Affine (project_coord_aform sctn X)"
   assumes "abs (normal sctn) \<in> Basis"
   shows "x \<in> plane_of sctn"
   using assms
   by (auto simp: Affine_def valuate_def aform_val_project_coord_aform plane_of_def
       project_coord_inner)
 
 definition "reduce_aform prec t X =
     summarize_aforms (prec) (collect_threshold (prec) 0 t) (degree_aforms X) X"
 
 definition "correct_girard p m N (X::real aform list) =
   (let
     Xs = map snd X;
     M = pdevs_mapping Xs;
     D = domain_pdevs Xs;
     diff = m - card D
   in if 0 < diff then (\<lambda>_ _. True) else
     let
       Ds = sorted_list_of_set D;
       ortho_indices = map fst (take (diff + N) (sort_key (\<lambda>(i, r). r) (map (\<lambda>i. let xs = M i in (i, sum_list' p (map abs xs) - fold max (map abs xs) 0)) Ds)));
       _ = ()
     in (\<lambda>i (xs::real list). i \<notin> set ortho_indices))"
 
 definition "reduce_aforms prec C X = summarize_aforms (prec) C (degree_aforms X) X"
 
 definition "pdevs_of_real x = (x, zero_pdevs)"
 
 definition aform_inf_inner where "aform_inf_inner prec X n =
   (case inner_aforms' (prec) X (map pdevs_of_real n) of
     Some Xn \<Rightarrow> Inf_aform' (prec) (hd Xn))"
 definition aform_sup_inner where "aform_sup_inner prec X n =
   (case inner_aforms' (prec) X (map pdevs_of_real n) of
     Some Xn \<Rightarrow> Sup_aform' (prec) (hd Xn))"
 
 text \<open>cannot fail\<close>
 
 lemma approx_un_ne_None: "approx_un p (\<lambda>ivl. Some (f ivl)) (Some r) \<noteq> None"
   by (auto simp: approx_un_def split_beta')
 
 lemma approx_un_eq_Some:
   "approx_un p (\<lambda>ivl. Some (f ivl)) (Some r) = Some s \<longleftrightarrow>
   s = ivl_err (real_interval (f (ivl_of_aform_err p r)))"
   using approx_un_ne_None
   by (auto simp: approx_un_def split_beta')
 
 lemma is_float_uminus:
   "is_float aa \<Longrightarrow> is_float (- aa)"
   by (auto simp: is_float_def)
 
 lemma is_float_uminus_iff[simp]:
   "is_float (- aa) = is_float aa"
   using is_float_uminus[of aa] is_float_uminus[of "-aa"]
   by (auto simp: is_float_def)
 
 lemma is_float_simps[simp]:
   "is_float 0"
   "is_float 1"
   "is_float (real_of_float x)"
   "is_float (truncate_down p X)"
   "is_float (truncate_up p X)"
   "is_float (eucl_truncate_down p X)"
   "is_float (eucl_truncate_up p X)"
   by (auto simp: is_float_def eucl_truncate_down_def eucl_truncate_up_def truncate_down_def truncate_up_def)
 
 lemma is_float_sum_list'[simp]:
   "is_float (sum_list' p xs)"
   by (induction xs) (auto simp: is_float_def)
 
 lemma is_float_inverse_aform': "is_float (fst (fst (inverse_aform' p X)))"
   unfolding inverse_aform'_def
   by (simp add: Let_def trunc_bound_eucl_def)
 
 lemma is_float_min_range:
   "min_range_antimono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float a"
   "min_range_antimono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float c"
   "min_range_mono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float a"
   "min_range_mono p F D E X Y = Some ((a, b), c) \<Longrightarrow> is_float c"
   by (auto simp: min_range_antimono_def min_range_mono_def Let_def bind_eq_Some_conv
       prod_eq_iff trunc_bound_eucl_def
       mid_err_def affine_unop_def split: prod.splits)
 
 lemma is_float_ivl_err:
   assumes "ivl_err x = ((a, b), c)" "is_float (lower x)" "is_float (upper x)"
   shows "is_float a" "is_float c"
 proof -
   define x1 where "x1 = lower x"
   define x2 where "x2 = upper x"
   have "a = (x1 + x2) / 2" "c = (x2 - x1) / 2"
     using assms by (auto simp: ivl_err_def x1_def x2_def)
   moreover have "(x1 + x2) / 2 \<in> float" "(x2 - x1) / 2 \<in> float"
     using assms
     by (auto simp: is_float_def x1_def x2_def)
   ultimately show "is_float a" "is_float c"
     unfolding is_float_def by blast+
 qed
 
 lemma is_float_trunc_bound_eucl[simp]:
   "is_float (fst (trunc_bound_eucl p X))"
   by (auto simp: trunc_bound_eucl_def Let_def)
 
 lemma add_eq_times_2_in_float: "a + b = c * 2 \<Longrightarrow> is_float a \<Longrightarrow> is_float b \<Longrightarrow> is_float c"
 proof goal_cases
   case 1
   then have "c = (a + b) / 2"
     by simp
   also have "\<dots> \<in> float" using 1(3,2) by (simp add: is_float_def)
   finally show ?case by (simp add: is_float_def)
 qed
 
 
 lemma approx_floatarith_Some_is_float:
   "approx_floatarith p fa XS = Some ((a, b), ba) \<Longrightarrow>
   list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS \<Longrightarrow>
   is_float a \<and> is_float ba"
   apply (induction fa arbitrary: a b ba)
   subgoal by (auto simp: bind_eq_Some_conv add_aform'_def Let_def )
   subgoal by (auto simp: bind_eq_Some_conv uminus_aform_def Let_def)
   subgoal by (auto simp: bind_eq_Some_conv mult_aform'_def Let_def )
   subgoal by (auto simp: bind_eq_Some_conv inverse_aform_err_def map_aform_err_def
         prod_eq_iff is_float_inverse_aform'
         acc_err_def aform_to_aform_err_def aform_err_to_aform_def inverse_aform_def
         Let_def split: if_splits)
   subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv arctan_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal apply (auto simp: bind_eq_Some_conv uminus_aform_def Let_def is_float_min_range
         is_float_ivl_err set_of_eq real_interval_abs
         split: if_splits prod.splits)
     apply (metis is_float_ivl_err(1) is_float_simps(3) lower_real_interval real_interval_abs upper_real_interval)
     by (metis is_float_ivl_err(2) is_float_simps(3) lower_real_interval real_interval_abs upper_real_interval)
   subgoal by (auto simp: bind_eq_Some_conv max_aform_err_def Let_def is_float_min_range
         is_float_ivl_err max_def
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv min_aform_err_def Let_def is_float_min_range
         is_float_ivl_err min_def
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv arctan_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv sqrt_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv exp_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv powr_aform_err_def approx_bin_def
         exp_aform_err_def Let_def is_float_min_range
         is_float_ivl_err mult_aform'_def
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv ln_aform_err_def Let_def is_float_min_range
         is_float_ivl_err
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv power_aform_err_def Let_def is_float_min_range
         is_float_ivl_err mid_err_def dest!: add_eq_times_2_in_float
         split: if_splits prod.splits)
   subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
         approx_un_def is_float_ivl_err
         split: if_splits)
   subgoal by (auto simp: bind_eq_Some_conv cos_aform_err_def Let_def is_float_min_range
         list_all_length
         split: if_splits)
   subgoal by (auto simp: bind_eq_Some_conv num_aform_def Let_def)
   done
 
 lemma plain_floatarith_not_None:
   assumes "plain_floatarith N fa" "N \<le> length XS"
     "list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
   shows "approx_floatarith p fa XS \<noteq> None"
   using assms
   by (induction fa)
     (auto simp: Let_def split_beta' approx_un_eq_Some prod_eq_iff
       approx_floatarith_Some_is_float)
 
 lemma plain_floatarith_slp_not_None:
   assumes "\<And>fa. fa \<in> set fas \<Longrightarrow> plain_floatarith N fa" "N \<le> length XS"
     "list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
   shows "approx_slp p fas XS \<noteq> None"
   using assms 
   apply (induction fas arbitrary: XS)
   subgoal by simp
   subgoal for fa fas XS
     using plain_floatarith_not_None[of N fa XS p]
     by (auto simp: Let_def split_beta' approx_un_eq_Some prod_eq_iff
       bind_eq_Some_conv approx_floatarith_Some_is_float)
   done
 
 lemma plain_floatarithE:
   assumes "plain_floatarith N fa" "N \<le> length XS"
     "list_all (\<lambda>((a, b), c). is_float a \<and> is_float c) XS"
   obtains R where "approx_floatarith p fa XS = Some R"
   using plain_floatarith_not_None[OF assms]
   by force
 
 lemma approx_slp_outer_eq_None_iff:
   "approx_slp_outer p a b XS = None \<longleftrightarrow>
     approx_slp p b ((map (\<lambda>x. (x, 0)) XS)) = None"
   by (auto simp: approx_slp_outer_def Let_def bind_eq_None_conv)
 
 lemma approx_slp_sing_eq_None_iff:
   "approx_slp p [b] xs = None \<longleftrightarrow> approx_floatarith p b xs = None"
   by (auto simp: approx_slp_outer_def Let_def bind_eq_None_conv)
 
 lemma plain_inner_floatariths:
   "plain_floatarith N (inner_floatariths xs ys)"
   if "list_all (plain_floatarith N) xs"  "list_all (plain_floatarith N) ys"
   using that
   by (induction xs ys rule: inner_floatariths.induct) auto
 
 lemma aiN: "approx_floatarith p (inner_floatariths xs ys) zs \<noteq> None"
   if "\<And>x. x \<in> set xs \<Longrightarrow> approx_floatarith p x zs \<noteq> None"
   and "\<And>x. x \<in> set ys \<Longrightarrow> approx_floatarith p x zs \<noteq> None"
   using that
   apply (induction xs ys rule: inner_floatariths.induct)
   apply (auto simp: Let_def bind_eq_Some_conv)
   by (metis old.prod.exhaust)
 
 lemma aiVN: "approx_floatarith p
         (inner_floatariths (map floatarith.Var [0..<length a])
           (map floatarith.Var [length a..<length a + length b]))
         (map (\<lambda>x. (x, 0)) a @ map (\<lambda>x. (x, 0)) b) \<noteq> None"
   by (rule aiN) (auto simp: nth_append)
 
 lemma iaN: "inner_aforms' p a b \<noteq> None"
   unfolding inner_aforms'_def Let_def approx_slp_outer_def
   using aiVN[of p a b]
   by (auto simp: Let_def bind_eq_Some_conv)
 
 definition "support_aform prec b X = (let ia = inner_aform X b in fst X \<bullet> b + tdev' (prec) (snd ia))"
 
 definition "width_aforms prec X =
   (let t = tdev' (prec) ((abssum_of_pdevs_list (map snd X))) in t)"
 
 definition "inf_aforms prec xs = map (Inf_aform' (prec)) xs"
 definition "sup_aforms prec xs = map (Sup_aform' (prec)) xs"
 
 definition "fresh_index_aforms xs = Max (insert 0 (degree_aform ` set xs))"
 
 definition "independent_aforms x env = (msum_aform (fresh_index_aforms env) (0, zero_pdevs) x#env)"
 
 definition "aform_form_ivl prec form xs =
   dRETURN (approx_form prec form (ivls_of_aforms prec xs) [])"
 definition "aform_form prec form xs =
   dRETURN (approx_form_aform prec form xs)"
 definition "aform_slp prec n slp xs =
   dRETURN (approx_slp_outer prec n slp xs)"
 definition
   "aform_isFDERIV prec n ns fas xs =
     dRETURN (isFDERIV_approx prec n ns fas (ivls_of_aforms prec xs))"
 
 definition aform_rel_internal: "aform_rel R = br Affine top O \<langle>R\<rangle>set_rel"
 lemma aform_rel_def: "\<langle>rnv_rel\<rangle>aform_rel = br Affine top"
   unfolding relAPP_def
   by (auto simp: aform_rel_internal)
 definition "aforms_rel = br Joints top"
 
 definition aform_rell :: "((real \<times> real pdevs) list \<times> real list set) set"
 where "aform_rell = aforms_rel"
 
 definition aforms_relp_internal: "aforms_relp R = aforms_rel O \<langle>R\<rangle>set_rel"
 lemma aforms_relp_def: "\<langle>R\<rangle>aforms_relp = aforms_rel O \<langle>R\<rangle>set_rel"
   by (auto simp: aforms_relp_internal relAPP_def)
 
 definition "product_aforms x y = x @ msum_aforms (degree_aforms (x)) (replicate (length y) (0, zero_pdevs)) y"
 
 lemma
   eucl_of_list_mem_eucl_of_list_aform:
   assumes "x \<in> Joints a"
   assumes "length a = DIM('a::executable_euclidean_space)"
   shows "eucl_of_list x \<in> Affine (eucl_of_list_aform a::'a aform)"
   using assms
   by (auto simp: Joints_def Affine_def valuate_def eucl_of_list_aform_def
       aform_val_def pdevs_val_sum_pdevs inner_simps eucl_of_list_inner
       intro!: euclidean_eqI[where 'a='a])
 
 lemma
   in_image_eucl_of_list_eucl_of_list_aform:
   assumes "length x = DIM('a::executable_euclidean_space)" "xa \<in> Affine (eucl_of_list_aform x::'a aform)"
   shows "xa \<in> eucl_of_list ` Joints x"
   using assms
   by (auto intro!: nth_equalityI image_eqI[where x="list_of_eucl xa"]
       simp: aform_val_def eucl_of_list_aform_def Affine_def valuate_def Joints_def
       inner_simps pdevs_val_sum_pdevs eucl_of_list_inner)
 
 lemma
   eucl_of_list_image_Joints:
   assumes "length x = DIM('a::executable_euclidean_space)"
   shows "eucl_of_list ` Joints x = Affine (eucl_of_list_aform x::'a aform)"
   using assms
   by (auto intro!: eucl_of_list_mem_eucl_of_list_aform
       in_image_eucl_of_list_eucl_of_list_aform)
 
 definition "aform_ops =
 \<lparr>
   appr_of_ivl = aforms_of_ivls,
   product_appr = product_aforms,
   msum_appr = msum_aforms',
   inf_of_appr = \<lambda>optns. inf_aforms (precision optns),
   sup_of_appr = \<lambda>optns. sup_aforms (precision optns),
   split_appr = split_aforms_largest_uncond_take,
   appr_inf_inner = \<lambda>optns. aform_inf_inner (precision optns),
   appr_sup_inner = \<lambda>optns. aform_sup_inner (precision optns),
   inter_appr_plane = \<lambda>optns xs sctn. inter_aform_plane_lv (length xs) (precision optns) xs sctn,
   reduce_appr = \<lambda>optns. reduce_aforms (precision optns),
   width_appr = \<lambda>optns. width_aforms (precision optns),
   approx_slp_dres = \<lambda>optns. aform_slp (precision optns),
   approx_euclarithform = \<lambda>optns. aform_form (precision optns),
   approx_isFDERIV = \<lambda>optns. aform_isFDERIV  (precision optns)
 \<rparr>"
 
 lemma Affine_eq_permI:
   assumes "fst X = fst Y"
   assumes "map snd (list_of_pdevs (snd X)) <~~> map snd (list_of_pdevs (snd Y))" (is "?perm X Y")
   shows "Affine X = Affine Y"
 proof -
   {
     fix X Y and e::"nat \<Rightarrow> real"
     assume perm: "?perm X Y" and e: "e \<in> funcset UNIV {- 1..1}"
     from pdevs_val_of_list_of_pdevs2[OF e, of "snd X"]
     obtain e' where e':
       "pdevs_val e (snd X) = pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs (snd X))))"
       "e' \<in> funcset UNIV {- 1..1}"
       by auto
     note e'(1)
     also from pdevs_val_perm[OF perm e'(2)]
     obtain e'' where e'':
       "e'' \<in> funcset UNIV {- 1..1}"
       "pdevs_val e' (pdevs_of_list (map snd (list_of_pdevs (snd X)))) =
       pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (snd Y))))"
       by auto
     note e''(2)
     also from pdevs_val_of_list_of_pdevs[OF e''(1), of "snd Y", simplified]
     obtain e''' where e''':
       "pdevs_val e'' (pdevs_of_list (map snd (list_of_pdevs (snd Y)))) = pdevs_val e''' (snd Y)"
       "e''' \<in> funcset UNIV {- 1..1}"
       by auto
     note e'''(1)
     finally have "\<exists>e' \<in> funcset UNIV {-1 .. 1}. pdevs_val e (snd X) = pdevs_val e' (snd Y)"
       using e'''(2) by auto
   } note E = this
   note e1 = E[OF assms(2)]
     and e2 = E[OF perm_sym[OF assms(2)]]
   show ?thesis
     by (auto simp: Affine_def valuate_def aform_val_def assms dest: e1 e2)
 qed
 
 context includes autoref_syntax begin
 
 lemma aform_of_ivl_refine: "x \<le> y \<Longrightarrow> (aform_of_ivl x y, atLeastAtMost x y) \<in> \<langle>rnv_rel\<rangle>aform_rel"
   by (auto simp: aform_rel_def br_def Affine_aform_of_ivl)
 
 lemma aforms_of_ivl_leI1:
   fixes en::real
   assumes "-1 \<le> en" "xsn \<le> ysn"
   shows "xsn \<le> (xsn + ysn) / 2 + (ysn - xsn) * en / 2"
 proof -
   have "xsn * (1 + en) \<le> ysn * (1 + en)"
     using assms mult_right_mono by force
   then show ?thesis
     by (auto simp: algebra_simps divide_simps)
 qed
 
 lemma aforms_of_ivl_leI2:
   fixes en::real
   assumes "1 \<ge> en" "xsn \<le> ysn"
   shows "(xsn + ysn) / 2 + (ysn - xsn) * en / 2 \<le> ysn"
 proof -
   have "xsn * (1 - en) \<le> ysn * (1 - en)"
     using assms mult_right_mono by force
   then show ?thesis
     by (auto simp: algebra_simps divide_simps)
 qed
 
 lemma Joints_aforms_of_ivlsD1:
   "zs \<in> Joints (aforms_of_ivls xs ys) \<Longrightarrow> list_all2 (\<le>) xs ys \<Longrightarrow> list_all2 (\<le>) xs zs"
   by (auto simp: Joints_def valuate_def aforms_of_ivls_def aform_val_def Pi_iff
       list_all2_conv_all_nth intro!: list_all2_all_nthI aforms_of_ivl_leI1)
 
 lemma Joints_aforms_of_ivlsD2:
   "zs \<in> Joints (aforms_of_ivls xs ys) \<Longrightarrow> list_all2 (\<le>) xs ys \<Longrightarrow> list_all2 (\<le>) zs ys"
   by (auto simp: Joints_def valuate_def aforms_of_ivls_def aform_val_def Pi_iff
       list_all2_conv_all_nth intro!: list_all2_all_nthI aforms_of_ivl_leI2)
 
 lemma aforms_of_ivls_refine:
   "list_all2 (\<le>) xrs yrs \<Longrightarrow>
        (xri, xrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow>
        (yri, yrs) \<in> \<langle>rnv_rel\<rangle>list_rel \<Longrightarrow> (aforms_of_ivls xri yri, lv_ivl xrs yrs) \<in> aforms_rel"
   apply (auto simp: aforms_rel_def br_def list_all2_lengthD lv_ivl_def
       Joints_aforms_of_ivlsD1 Joints_aforms_of_ivlsD2 intro!: aforms_of_ivls)
   subgoal by (simp add: list_all2_conv_all_nth)
   subgoal by (simp add: list_all2_conv_all_nth)
   done
 
 lemma degrees_zero_pdevs[simp]: "degrees (replicate n zero_pdevs) = 0"
   by (auto simp: degrees_def intro!: Max_eqI)
 
 lemma Joints_product_aforms:
   "Joints (product_aforms a b) = product_listset (Joints a) (Joints b)"
   apply (auto simp: Joints_def valuate_def product_listset_def product_aforms_def
       aform_vals_def[symmetric] aform_val_msum_aforms)
   subgoal for e
     apply (rule image_eqI[where
           x="(aform_vals e a,
               List.map2 (+) (aform_vals e (replicate (length b) (0, zero_pdevs))) (aform_vals (\<lambda>i. e (i + degree_aforms a)) b))"])
      apply (auto simp: split_beta')
     apply (auto simp: aform_vals_def intro!: nth_equalityI image_eqI[where x="\<lambda>i. e (i + degree_aforms a)"])
     done
   subgoal for e1 e2
     apply (rule image_eqI[where x="\<lambda>i. if i < degree_aforms a then e1 i else e2 (i - degree_aforms a)"])
      apply (auto simp: aform_vals_def aform_val_def Pi_iff
         intro!: nth_equalityI pdevs_val_degree_cong)
     subgoal premises prems for x xs k
     proof -
       from prems
       have "degree xs \<le> degree_aforms a"
         by (auto simp: degrees_def Max_gr_iff)
       then show ?thesis using prems by auto
     qed
     done
   done
 
 lemma product_aforms_refine:
   "(product_aforms, product_listset) \<in> aforms_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
   by (auto simp: aforms_rel_def br_def Joints_product_aforms)
 
 lemma mem_lv_rel_set_rel_iff:
   fixes z::"'a::executable_euclidean_space set"
   shows "(y, z) \<in> \<langle>lv_rel\<rangle>set_rel \<longleftrightarrow> (z = eucl_of_list ` y \<and> (\<forall>x \<in> y. length x = DIM('a)))"
   unfolding lv_rel_def
   by (auto simp: set_rel_def br_def)
 
 lemma eucl_of_list_mem_lv_rel: "length x = DIM('a::executable_euclidean_space) \<Longrightarrow>
     (x, eucl_of_list x::'a) \<in> lv_rel"
   unfolding lv_rel_def
   by (auto simp:  br_def)
 
 lemma
   mem_Joints_msum_aforms'I:
   "a \<in> Joints x \<Longrightarrow> b \<in> Joints y \<Longrightarrow> List.map2 (+) a b \<in> Joints (msum_aforms' x y)"
   by (auto simp: Joints_msum_aforms degrees_def)
 
 lemma
   mem_Joints_msum_aforms'E:
   assumes "xa \<in> Joints (msum_aforms' x y)" 
   obtains a b where "xa = List.map2 (+) a b" "a \<in> Joints x" "b \<in> Joints y"
   using assms
   by (auto simp: Joints_msum_aforms degrees_def)
 
 lemma msum_aforms'_refine_raw:
   shows "(msum_aforms' x y, {List.map2 (+) a b|a b. a \<in> Joints x \<and> b \<in> Joints y}) \<in> aforms_rel"
   unfolding aforms_rel_def br_def
   by (safe elim!: mem_Joints_msum_aforms'E intro!: mem_Joints_msum_aforms'I) (auto simp: Joints_imp_length_eq)
 
 lemma aforms_relD: "(a, b) \<in> aforms_rel \<Longrightarrow> b = Joints a"
   by (auto simp: aforms_rel_def br_def)
 
 lemma msum_aforms'_refine:
   "(msum_aforms', \<lambda>xs ys. {List.map2 (+) x y |x y. x \<in> xs \<and> y \<in> ys}) \<in> aforms_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
   by (safe dest!: aforms_relD intro!: msum_aforms'_refine_raw)
 
 lemma length_inf_aforms[simp]: "length (inf_aforms optns x) = length x"
   and length_sup_aforms[simp]: "length (sup_aforms optns x) = length x"
   by (auto simp: inf_aforms_def sup_aforms_def)
 
 lemma inf_aforms_refine:
   "(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow> (RETURN (inf_aforms optns xi), Inf_specs d x) \<in> \<langle>rl_rel\<rangle>nres_rel"
   unfolding o_def
   apply (auto simp: br_def aforms_rel_def mem_lv_rel_set_rel_iff nres_rel_def Inf_specs_def
       intro!: RETURN_SPEC_refine)
   unfolding lv_rel_def
   by (auto simp: aforms_rel_def br_def Joints_imp_length_eq
       eucl_of_list_inner inf_aforms_def nth_in_AffineI
       intro!: Inf_aform'_Affine_le list_all2_all_nthI)
 
 lemma sup_aforms_refine:
   "(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow> (RETURN (sup_aforms optns xi), Sup_specs d x) \<in> \<langle>rl_rel\<rangle>nres_rel"
   unfolding o_def
   apply (auto simp: aforms_relp_def mem_lv_rel_set_rel_iff nres_rel_def Sup_specs_def
       intro!: RETURN_SPEC_refine)
   unfolding lv_rel_def
   by (auto simp: aforms_rel_def br_def Joints_imp_length_eq
       eucl_of_list_inner sup_aforms_def nth_in_AffineI
       intro!: Sup_aform'_Affine_ge list_all2_all_nthI)
 
 lemma nres_of_THE_DRES_le:
   assumes "\<And>v. x = Some v \<Longrightarrow> RETURN v \<le> y"
   shows "nres_of (THE_DRES x) \<le> y"
   using assms by (auto simp: THE_DRES_def split: option.split)
 
 lemma degree_le_fresh_index: "a \<in> set A \<Longrightarrow> degree_aform a \<le> fresh_index_aforms A"
   by (auto simp: fresh_index_aforms_def intro!: Max_ge)
 
 lemma zero_in_JointsI: "xs \<in> Joints XS \<Longrightarrow> z = (0, zero_pdevs) \<Longrightarrow> 0 # xs \<in> Joints (z # XS)"
   by (auto simp: Joints_def valuate_def)
 
 lemma cancel_nonneg_pos_add_multI: "0 \<le> c + c * x"
   if "c \<ge> 0" "1 + x \<ge> 0"
   for c x::real
 proof -
   have "0 \<le> c + c * x \<longleftrightarrow> 0 \<le> c * (1 + x)" by (auto simp: algebra_simps)
   also have "\<dots> \<longleftrightarrow> 0 \<le> 1 + x"
     using that
     by (auto simp: zero_le_mult_iff)
   finally show ?thesis 
     using that by simp
 qed
    
 lemma Joints_map_split_aform:
   fixes x::"real aform list"
   shows "Joints x \<subseteq> Joints (map (\<lambda>a. fst (split_aform a i)) x) \<union> Joints (map (\<lambda>b. snd (split_aform b i)) x)"
   unfolding subset_iff
   apply (intro allI impI)
 proof goal_cases
   case (1 xs)
   then obtain e where e: "e \<in> funcset UNIV {-1 .. 1}" "xs = map (aform_val e) x"
     by (auto simp: Joints_def valuate_def)
   consider "e i \<ge> 0" | "e i \<le> 0" by arith
   then show ?case
   proof cases
     case 1
     let ?e = "e(i:= 2 * e i - 1)"
     note e(2)
     also
     have "map (aform_val e) x = map (aform_val ?e) (map (\<lambda>b. snd (split_aform b i)) x)"
       by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps)
     also have "\<dots> \<in> Joints (map (\<lambda>b. snd (split_aform b i)) x)"
       using e \<open>0 \<le> e i\<close>
       by (auto simp: Joints_def valuate_def Pi_iff intro!: image_eqI[where x = ?e])
     finally show ?thesis by simp
   next
     case 2
     let ?e = "e(i:= 2 * e i + 1)"
     note e(2)
     also
     have "map (aform_val e) x = map (aform_val ?e) (map (\<lambda>b. fst (split_aform b i)) x)"
       by (auto simp: aform_val_def split_aform_def Let_def divide_simps algebra_simps)
     also have "\<dots> \<in> Joints (map (\<lambda>b. fst (split_aform b i)) x)"
       using e \<open>0 \<ge> e i\<close>
       by (auto simp: Joints_def valuate_def Pi_iff real_0_le_add_iff
           intro!: image_eqI[where x = ?e] cancel_nonneg_pos_add_multI)
     finally show ?thesis by simp
   qed
 qed
 
 
 lemma split_aforms_lemma:
   fixes x::"real aform list"
   assumes "(x, y) \<in> aforms_rel"
   assumes "z \<subseteq> y"
   assumes "l = (length x)"
   shows "\<exists>a b. (split_aforms x i, a, b)
      \<in> aforms_rel \<times>\<^sub>r aforms_rel \<and> env_len a l \<and> env_len b l \<and> z \<subseteq> a \<union> b"
   using assms
   apply (auto simp: split_aforms_def o_def)
   apply (rule exI[where x="Joints (map (\<lambda>x. fst (split_aform x i)) x)"])
   apply auto
   subgoal by (auto intro!: brI simp: aforms_rel_def)
   apply (rule exI[where x="Joints (map (\<lambda>x. snd (split_aform x i)) x)"])
   apply (rule conjI)
   subgoal by (auto intro!: brI simp: aforms_rel_def)
   subgoal
     using Joints_map_split_aform[of x i]
     by (auto simp: br_def aforms_rel_def env_len_def Joints_imp_length_eq)
   done
 
 lemma length_summarize_pdevs_list[simp]:
   "length (summarize_pdevs_list a b c d) = length d"
   by (auto simp: summarize_pdevs_list_def)
 
 lemma length_summarize_aforms[simp]:
   "length (summarize_aforms a b e d) = length d"
   by (auto simp: summarize_aforms_def Let_def)
 
 lemma
   split_aform_largest_take_refine:
   "(ni, n) \<in> nat_rel \<Longrightarrow>
        (xi::real aform list, x) \<in> aforms_rel \<Longrightarrow>
        length xi = d \<Longrightarrow> (RETURN (split_aforms_largest_uncond_take ni xi), split_spec_params d n x) \<in> \<langle>aforms_rel \<times>\<^sub>r aforms_rel\<rangle>nres_rel"
   apply (auto simp: split_spec_params_def nres_rel_def aforms_relp_def mem_lv_rel_set_rel_iff
       split_aforms_largest_uncond_take_def Let_def comps
       split: prod.splits
       intro!: RETURN_SPEC_refine)
   apply (rule split_aforms_lemma)
   by (auto simp add: aforms_rel_def)
 
 lemma aform_val_pdevs_of_real[simp]: "aform_val e (pdevs_of_real x) = x"
   by (auto simp: pdevs_of_real_def)
 
 lemma degree_aform_pdevs_of_real[simp]: "degree_aform (pdevs_of_real x) = 0"
   by (auto simp: pdevs_of_real_def)
 
 lemma interpret_floatarith_inner_eq:
   shows "interpret_floatarith (inner_floatariths xs ys) vs =
     (\<Sum>(x, y) \<leftarrow> (zip xs ys). (interpret_floatarith x vs) * (interpret_floatarith y vs))"
   by (induction xs ys rule: inner_floatariths.induct) auto
 
 lemma approx_slp_outer_sing:
   "approx_slp_outer p (Suc 0) [fa] XS = Some R \<longleftrightarrow> (\<exists>Y.
   approx_floatarith p fa (map (\<lambda>x. (x, 0)) XS) = Some Y \<and>
        [aform_err_to_aform Y (max (degree_aforms XS) (degree_aform_err Y))] = R)"
   by (auto simp: approx_slp_outer_def bind_eq_Some_conv degrees_def)
 
 lemma aforms_err_aform_valsI:
   assumes "vs = aform_vals e XS"
   shows "vs \<in> aforms_err e (map (\<lambda>x. (x, 0)) (XS))"
     by (auto simp: assms aforms_err_def o_def aform_err_def aform_vals_def)
 
 
 lemma aform_val_degree_cong:
   "b = d \<Longrightarrow> (\<And>i. i < degree_aform d \<Longrightarrow> a i = c i) \<Longrightarrow> aform_val a b = aform_val c d"
   by (auto simp: aform_val_def intro!: pdevs_val_degree_cong)
 
 lemma mem_degree_aformD: "x \<in> set XS \<Longrightarrow> degree_aform x \<le> degree_aforms XS"
   by (auto simp: degrees_def)
 lemma degrees_append_leD1: "(degrees xs) \<le> degrees (xs @ ys)"
   unfolding degrees_def
   by (rule Max_mono) (auto simp: degrees_def min_def max_def Max_ge_iff image_Un Max_gr_iff)
 
 lemma inner_aforms':
   assumes "xs \<in> Joints XS"
   assumes "inner_aforms' p XS (map pdevs_of_real rs) = Some R"
   shows "(\<Sum>(x, y) \<leftarrow> (zip xs rs). x * y) \<in> Affine (hd R)" (is ?th1) "length R = 1" (is ?th2)
 proof -
   from assms obtain e where "e \<in> funcset UNIV {-1 .. 1}" "xs = aform_vals e XS"
     by (auto simp: Joints_def valuate_def aform_vals_def)
   then have e: "xs @ rs = aform_vals e (XS @ map pdevs_of_real rs)"
     "xs @ rs \<in> Joints (XS @ map pdevs_of_real rs)"
     "length xs = length XS"
     "e \<in> funcset UNIV {- 1..1}"
     by (auto simp: aform_vals_def o_def degrees_def Joints_def valuate_def)
   have "approx_slp_outer p (Suc 0)
      ([inner_floatariths (map floatarith.Var [0..<length XS])
          (map floatarith.Var [length XS..<length XS + length rs])])
      (XS @ map pdevs_of_real rs) =
     Some R"
     using assms(2)
     by (auto simp: inner_aforms'_def)
   then obtain Y where Y:
     "approx_floatarith p
        (inner_floatariths (map floatarith.Var [0..<length XS])
          (map floatarith.Var [length XS..<length XS + length rs]))
        (map (\<lambda>x. (x, 0)) (XS @ map pdevs_of_real rs)) =
       Some Y"
     "R = [aform_err_to_aform Y (max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y))]"
     unfolding approx_slp_outer_sing by auto
   let ?m = "(max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y))"
   from approx_floatarith_Elem[OF Y(1) e(4) aforms_err_aform_valsI[OF e(1)]]
   have "interpret_floatarith
      (inner_floatariths (map floatarith.Var [0..<length XS]) (map floatarith.Var [length XS..<length XS + length rs]))
      (xs @ rs)
     \<in> aform_err e Y" "degree_aform_err Y \<le> max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y)"
     by auto
   from aform_err_to_aformE[OF this] obtain err where err:
     "interpret_floatarith
            (inner_floatariths (map floatarith.Var [0..<length XS])
              (map floatarith.Var [length XS..<length XS + length rs]))
            (xs @ rs) =
           aform_val (e(max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y) := err))
            (aform_err_to_aform Y (max (degree_aforms (XS @ map pdevs_of_real rs)) (degree_aform_err Y)))"
     "- 1 \<le> err" "err \<le> 1"
     by auto
   let ?e' = "(e(max (degrees (map snd XS @ map (snd \<circ> pdevs_of_real) rs)) (degree_aform_err Y) := err))"
   from e(1) have e': "xs @ rs = aform_vals ?e' (XS @ map pdevs_of_real rs)"
     apply (auto simp: aform_vals_def intro!: aform_val_degree_cong)
      apply (frule mem_degree_aformD)
      apply (frule le_less_trans[OF degrees_append_leD1])
      apply (auto simp: o_def)
     done
   from err have "interpret_floatarith
            (inner_floatariths (map floatarith.Var [0..<length XS])
              (map floatarith.Var [length XS..<length XS + length rs]))
            (xs @ rs)#xs@rs \<in> Joints (R @ XS @ map pdevs_of_real rs)"
     using e(1,3,4) e'
     apply (auto simp: valuate_def Joints_def
       intro!: nth_equalityI
         image_eqI[where x="?e'"])
      apply (simp add: Y aform_vals_def; fail)
     apply (simp add: Y o_def)
     apply (simp add: nth_append nth_Cons)
     apply (auto split: nat.splits simp: nth_append nth_Cons aform_vals_def)
     done
   then have "(\<Sum>(x, y)\<leftarrow>zip (map floatarith.Var [0..<length XS])
                 (map floatarith.Var
                   [length XS..<
                    length XS + length rs]). interpret_floatarith x (xs @ rs) * interpret_floatarith y (xs @ rs)) #
     xs @ rs
     \<in> Joints (R @ XS @ map pdevs_of_real rs)"
     apply (subst (asm)interpret_floatarith_inner_eq )
     apply (auto simp:  )
     done
   also have "(\<Sum>(x, y)\<leftarrow>zip (map floatarith.Var [0..<length XS])
                 (map floatarith.Var
                   [length XS..<
                    length XS + length rs]). interpret_floatarith x (xs @ rs) * interpret_floatarith y (xs @ rs)) =
     (\<Sum>(x, y)\<leftarrow>zip xs rs. x * y)"
     by (auto simp: sum_list_sum_nth assms e(3) nth_append intro!: sum.cong)
   finally show ?th1 ?th2
     by (auto simp: Affine_def valuate_def Joints_def Y)
 qed
 
 lemma inner_aforms'_inner_lv_rel:
   "(a, a') \<in> aforms_rel \<Longrightarrow>
        inner_aforms' prec a (map pdevs_of_real a'a) = Some R \<Longrightarrow>
        x \<in> a' \<Longrightarrow> inner_lv_rel x a'a \<in> Affine (hd R)"
   unfolding mem_lv_rel_set_rel_iff
   unfolding lv_rel_def aforms_rel_def
   apply (auto simp: br_def)
   apply (subst arg_cong2[where f="(\<in>)", OF _ refl])
   defer
    apply (rule inner_aforms')
      apply (auto simp: br_def Joints_imp_length_eq inner_lv_rel_def)
   done
 
 lemma aform_inf_inner_refine:
   "(RETURN o2 aform_inf_inner optns, Inf_inners) \<in> aforms_rel \<rightarrow> rl_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
   by (auto simp: aforms_relp_def nres_rel_def Inf_inners_def aform_inf_inner_def[abs_def] comp2_def
       iaN
       intro!: Inf_aform'_Affine_le inner_aforms'_inner_lv_rel
       split: option.splits list.splits)
 
 lemma aform_sup_inner_refine:
   "(RETURN o2 aform_sup_inner optns, Sup_inners) \<in> aforms_rel \<rightarrow> rl_rel \<rightarrow> \<langle>rnv_rel\<rangle>nres_rel"
   by (auto simp: aforms_relp_def nres_rel_def Sup_inners_def aform_sup_inner_def[abs_def] comp2_def
       iaN
       intro!: Sup_aform'_Affine_ge inner_aforms'_inner_lv_rel
       split: option.splits list.splits)
 
 lemma lv_aforms_rel_comp_br_Affine_le: "lv_aforms_rel O br Affine top \<subseteq> \<langle>lv_rel\<rangle>aforms_relp"
   apply (auto simp: lv_aforms_rel_def aforms_relp_def br_def)
   apply (rule relcompI)
    apply (auto simp: aforms_rel_def intro!: brI )
   by (auto simp: mem_lv_rel_set_rel_iff Joints_imp_length_eq
       intro!: eucl_of_list_mem_eucl_of_list_aform intro!: in_image_eucl_of_list_eucl_of_list_aform)
 
 lemma bijective_lv_rel[relator_props]: "bijective lv_rel"
   unfolding lv_rel_def bijective_def
   apply (auto simp: br_def)
   by (metis eucl_of_list_inj)
 
 lemma sv_lv_rel_inverse[relator_props]: "single_valued (lv_rel\<inverse>)"
   using bijective_lv_rel
   by (rule bijective_imp_sv)
 
 lemma list_of_eucl_image_lv_rel_inverse:
   "(x, list_of_eucl ` x) \<in> \<langle>lv_rel\<inverse>\<rangle>set_rel"
   unfolding set_rel_sv[OF sv_lv_rel_inverse]
   apply (auto simp: )
     apply (rule ImageI)
      apply (rule converseI)
      apply (rule lv_relI)
      apply auto
    apply (rule image_eqI)
     prefer 2 apply assumption
   unfolding lv_rel_def
    apply (auto simp: br_def)
   subgoal for y
     apply (rule exI[where x="list_of_eucl y"])
     apply auto
     done
   done
 
 lemma lv_rel_comp_lv_rel_inverse:
   "((lv_rel::(_\<times>'a::executable_euclidean_space) set) O lv_rel\<inverse>) = {(x, y). x = y \<and> length x = DIM('a)}"
   apply (auto simp: intro!: lv_relI)
   unfolding lv_rel_def
   by (auto simp: br_def intro!: eucl_of_list_inj)
 
 lemma inter_aform_plane_refine_aux:
   "d = CARD('n::enum) \<Longrightarrow>
   (xi, x) \<in> aforms_rel \<Longrightarrow> (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
   length xi = d \<Longrightarrow>
   length (normal si) = d \<Longrightarrow>
   (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
   \<in> \<langle>aforms_rel\<rangle>nres_rel"
 proof (goal_cases)
   case 1
   from 1 have sis: "si = s"
     by (cases si; cases s) (auto simp: sctn_rel_def)
   have Dp: "DIM_precond TYPE('n rvec) CARD('n)"
     by auto
   have a: "(xi, eucl_of_list_aform xi::'n rvec aform) \<in> lv_aforms_rel"
     by (auto simp: lv_aforms_rel_def br_def aforms_relp_def aforms_rel_def mem_lv_rel_set_rel_iff 1
         Joints_imp_length_eq)
   have b: "(si, (Sctn (eucl_of_list (normal si)) (pstn si))::'n rvec sctn) \<in> \<langle>lv_rel\<rangle>sctn_rel"
     using 1
     by (cases si)
       (auto simp: lv_aforms_rel_def br_def aforms_relp_def aforms_rel_def mem_lv_rel_set_rel_iff
         Joints_imp_length_eq sctn_rel_def intro!: lv_relI)
   have a: "(nres_of (inter_aform_plane_lv CARD('n) optns xi si),
     inter_aform_plane optns (eucl_of_list_aform xi::'n rvec aform) (Sctn (eucl_of_list (normal si)) (pstn si)))
     \<in> \<langle>lv_aforms_rel\<rangle>nres_rel"
     (is "(_, inter_aform_plane _ ?ea ?se) \<in> _")
     using inter_aform_plane_lv.refine[OF Dp IdI a b, of optns]
     by simp
   have b: "(inter_aform_plane optns ?ea ?se, inter_sctn_spec (Affine ?ea) ?se) \<in> \<langle>br Affine top\<rangle>nres_rel"
     using 1
     apply (auto simp: inter_sctn_spec_def nres_rel_def inter_aform_plane_def project_ncoord_aform_def
         inter_aform_plane_ortho_nres_def
         split: option.splits
         intro!: RETURN_SPEC_refine
         dest!: inter_inter_aform_plane_ortho)
      apply (auto simp: aform_rel_def br_def nres_rel_def comps bind_eq_Some_conv
         inter_sctn_spec_def inter_aform_plane_def plane_of_def aforms_relp_def aforms_rel_def
         mem_lv_rel_set_rel_iff
         intro!: RETURN_SPEC_refine nres_of_THE_DRES_le mem_Affine_project_coord_aformI
         dest!: inter_inter_aform_plane_ortho
         split: if_splits)
      apply (auto dest!: mem_Affine_project_coord_aformD simp: abs_in_Basis_iff plane_of_def)
     done
   from relcompI[OF a b]
   have "(nres_of (inter_aform_plane_lv CARD('n) optns xi si), inter_sctn_spec (Affine ?ea) ?se) \<in>
       \<langle>lv_aforms_rel\<rangle>nres_rel O \<langle>br Affine top\<rangle>nres_rel"
     by auto
   also have "\<langle>lv_aforms_rel\<rangle>nres_rel O \<langle>br Affine top\<rangle>nres_rel \<subseteq> \<langle>\<langle>lv_rel\<rangle>aforms_relp\<rangle>nres_rel"
     unfolding nres_rel_comp
     apply (rule nres_rel_mono)
     apply (rule lv_aforms_rel_comp_br_Affine_le)
     done
   finally
   have step1: "(nres_of (inter_aform_plane_lv CARD('n) optns xi si),
       inter_sctn_spec (Affine (eucl_of_list_aform xi)::'n rvec set) (Sctn (eucl_of_list (normal si)) (pstn si)))
       \<in> \<langle>\<langle>lv_rel\<rangle>aforms_relp\<rangle>nres_rel"
     by simp
   have step2: "(inter_sctn_spec (Affine (eucl_of_list_aform xi)::'n rvec set) (Sctn (eucl_of_list (normal si)) (pstn si)),
     inter_sctn_specs CARD('n) (Joints xi) si) \<in> \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel"
     apply (auto simp: inter_sctn_specs_def inter_sctn_spec_def simp: nres_rel_def intro!: SPEC_refine)
     subgoal for x
       apply (rule exI[where x="list_of_eucl ` x"])
       apply (auto simp: env_len_def plane_ofs_def intro: list_of_eucl_image_lv_rel_inverse)
       subgoal for y
         apply (rule image_eqI[where x="eucl_of_list y"])
           apply (subst list_of_eucl_eucl_of_list)
           apply (auto simp: 1 Joints_imp_length_eq)
         apply (rule subsetD, assumption)
         apply (auto simp: intro!: eucl_of_list_mem_eucl_of_list_aform 1)
         using inner_lv_rel_autoref[where 'a="'n rvec", param_fo, OF lv_relI lv_relI, of y "normal si"]
         by (auto simp: plane_of_def 1 Joints_imp_length_eq)
       subgoal for y
         apply (drule subsetD, assumption)
         using inner_lv_rel_autoref[where 'a="'n rvec", param_fo, OF lv_relI lv_relI, of "list_of_eucl y" "normal si"]
         by (auto simp: plane_of_def 1 Joints_imp_length_eq)
       done
     done
   from relcompI[OF step1 step2]
   have "(nres_of (inter_aform_plane_lv CARD('n) optns xi si), inter_sctn_specs CARD('n) (Joints xi) si)
     \<in> \<langle>\<langle>lv_rel::(real list \<times> 'n rvec)set\<rangle>aforms_relp\<rangle>nres_rel O \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel" by simp
   also have "\<langle>\<langle>lv_rel::(real list \<times> 'n rvec)set\<rangle>aforms_relp\<rangle>nres_rel O \<langle>\<langle>lv_rel\<inverse>\<rangle>set_rel\<rangle>nres_rel \<subseteq>
     \<langle>aforms_rel O Id\<rangle>nres_rel"
     unfolding nres_rel_comp O_assoc aforms_relp_def
     apply (rule nres_rel_mono)
     apply (rule relcomp_mono[OF order_refl])
     unfolding set_rel_sv[OF sv_lv_rel_inverse] set_rel_sv[OF lv_rel_sv]
     apply (auto simp: length_lv_rel)
     unfolding relcomp_Image[symmetric] lv_rel_comp_lv_rel_inverse
      apply (auto simp: Basis_not_uminus length_lv_rel)
     unfolding lv_rel_def
     subgoal for a b c d
       apply (auto dest!: brD simp: length_lv_rel)
       using eucl_of_list_inj[where 'a="'n rvec", of d b]
       by auto
     done
   finally show ?case using 1 by (simp add: aforms_rel_def br_def sis)
 qed
 
 end
 
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a list"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 
 lemmas inter_aform_plane_refine_unoverloaded0 =
   inter_aform_plane_refine_aux[internalize_sort "'n::enum",
     unoverload enum_class.enum,
     unoverload enum_class.enum_all,
     unoverload enum_class.enum_ex]
 
 theorem
   inter_aform_plane_refine_unoverloaded:
     "class.enum (enum::'a list) enum_all enum_ex \<and> d = CARD('a) \<Longrightarrow>
     (xi, x) \<in> aforms_rel \<Longrightarrow>
     (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
     length xi = d \<Longrightarrow>
     length (normal si) = d \<Longrightarrow>
     (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
     \<in> \<langle>aforms_rel\<rangle>nres_rel"
   by (rule inter_aform_plane_refine_unoverloaded0) auto
 
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum"}, SOME @{typ "'a::enum list"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_all"}, SOME @{typ "('a::enum \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 setup \<open>Sign.add_const_constraint (@{const_name "enum_class.enum_ex"}, SOME @{typ "('a::enum \<Rightarrow> bool) \<Rightarrow> bool"})\<close>
 
 context includes autoref_syntax begin
 
 text \<open>TODO: this is a special case of \<open>Cancel_Card_Constraint\<close> from \<open>AFP/Perron_Frobenius\<close>!\<close>
 lemma type_impl_card_n_enum:
   assumes "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< n :: nat}"
   obtains enum enum_all enum_ex
   where "class.enum (enum::'a list) enum_all enum_ex \<and> n = CARD('a)"
 proof -
-  from assms obtain rep :: "'a \<Rightarrow> nat" and abs :: "nat \<Rightarrow> 'a" where t: "type_definition rep abs {0 ..< n}" by auto
-  have "card (UNIV :: 'a set) = card {0 ..< n}" using t by (rule type_definition.card)
+  from assms obtain rep :: "'a \<Rightarrow> nat" and abs :: "nat \<Rightarrow> 'a"
+    where t: "type_definition rep abs {0 ..<n}" by auto
+  then interpret type_definition rep abs \<open>{0 ..<n}\<close> .
+  have "card (UNIV :: 'a set) = card {0 ..< n}"
+    by (rule card)
   also have "\<dots> = n" by auto
   finally have bn: "CARD ('a) = n" .
 
   let ?enum = "(map abs [0..<n])"
   have "class.enum ?enum (Ball (set ?enum)) (Bex (set ?enum))"
-    apply standard
-    using t
-    apply (auto simp: distinct_map type_definition_def)
-    using t type_definition.univ apply fastforce
-    using t type_definition.Abs_inj_on apply blast
-    apply (meson t type_definition.Abs_induct)
-    by (metis t tdD1)
+    by standard (auto simp: distinct_map univ Abs_inject intro: inj_onI)
   with bn have "class.enum ?enum (Ball (set ?enum)) (Bex (set ?enum)) \<and> n = CARD('a)"
     by simp
   then show ?thesis ..
 qed
 
 
 lemma inter_aform_plane_refine_ex_typedef:
   "(xi, x) \<in> aforms_rel \<Longrightarrow>
   (si, s) \<in> \<langle>rl_rel\<rangle>sctn_rel \<Longrightarrow>
   length xi = d \<Longrightarrow>
   length (normal si) = d \<Longrightarrow>
   (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
   \<in> \<langle>aforms_rel\<rangle>nres_rel"
   if "\<exists>(Rep :: 'a \<Rightarrow> nat) Abs. type_definition Rep Abs {0 ..< d :: nat}"
   by (rule type_impl_card_n_enum[OF that]) (rule inter_aform_plane_refine_unoverloaded; assumption)
 
 lemma inter_aform_plane_refine:
   "0 < d \<Longrightarrow>
   (xi, x) \<in> aforms_rel \<Longrightarrow>
   (si, s) \<in> \<langle>Id\<rangle>sctn_rel \<Longrightarrow>
   length xi = d \<Longrightarrow>
   length (normal si) = d \<Longrightarrow>
   (nres_of (inter_aform_plane_lv (length xi) optns xi si), inter_sctn_specs d x s)
   \<in> \<langle>aforms_rel\<rangle>nres_rel"
   by (rule inter_aform_plane_refine_ex_typedef[cancel_type_definition, simplified])
 
 lemma Joints_reduce_aforms: "x \<in> Joints X \<Longrightarrow> x \<in> Joints (reduce_aforms prec t X)"
 proof (auto simp: reduce_aforms_def summarize_threshold_def[abs_def] Joints_def valuate_def aform_val_def, goal_cases)
   case (1 e)
   from summarize_aformsE[OF \<open>e \<in> _\<close> order_refl, of "X" "prec" t]
   guess e' .
   thus ?case
     by (auto intro!: image_eqI[where x=e'] simp: aform_vals_def)
 qed
 
 lemma length_reduce_aform[simp]: "length (reduce_aforms optns a x) = length x"
   by (auto simp: reduce_aforms_def)
 
 lemma reduce_aform_refine:
   "(xi, x) \<in> aforms_rel \<Longrightarrow> length xi = d \<Longrightarrow>
     (RETURN (reduce_aforms prec C xi), reduce_specs d r x) \<in> \<langle>aforms_rel\<rangle>nres_rel"
   apply (auto simp: reduce_specs_def nres_rel_def comps aforms_relp_def mem_lv_rel_set_rel_iff
       aforms_rel_def env_len_def
       intro!: RETURN_SPEC_refine)
   apply (auto simp: br_def env_len_def)
   by (auto simp: mem_lv_rel_set_rel_iff Joints_imp_length_eq
       intro!: in_image_eucl_of_list_eucl_of_list_aform Joints_reduce_aforms
       eucl_of_list_mem_eucl_of_list_aform)
 
 lemma aform_euclarithform_refine:
   "(nres_of o2 aform_form optns, approx_form_spec) \<in> Id \<rightarrow> aforms_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
   by (auto simp: approx_form_spec_def nres_rel_def comps aform_form_def
       aforms_rel_def br_def approx_form_aform
       dest!: approx_form_aux
       intro!: ivls_of_aforms)
 
 lemma aform_isFDERIV:
   "(\<lambda>N xs fas vs. nres_of (aform_isFDERIV optns N xs fas vs), isFDERIV_spec)
     \<in> nat_rel \<rightarrow> \<langle>nat_rel\<rangle>list_rel \<rightarrow> \<langle>Id\<rangle>list_rel \<rightarrow> aforms_rel \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
   by (auto simp: isFDERIV_spec_def nres_rel_def comps aform_isFDERIV_def
       aforms_rel_def br_def
       dest!: approx_form_aux
       intro!: ivls_of_aforms isFDERIV_approx)
 
 lemma approx_slp_lengthD: "approx_slp p slp a = Some xs \<Longrightarrow>
   length xs = length slp + length a"
   by (induction slp arbitrary: xs a) (auto simp: bind_eq_Some_conv)
 
 lemma approx_slp_outer_lengthD: "approx_slp_outer p d slp a = Some xs \<Longrightarrow>
   length xs = min d (length slp + length a)"
   by (auto simp: approx_slp_outer_def Let_def bind_eq_Some_conv o_def
       aforms_err_to_aforms_def aform_err_to_aform_def dest!: approx_slp_lengthD)
 
 lemma approx_slp_refine:
   "(nres_of o3 aform_slp prec, approx_slp_spec fas) \<in> 
     nat_rel \<rightarrow> fas_rel \<rightarrow> aforms_rel \<rightarrow> \<langle>\<langle>aforms_rel\<rangle>option_rel\<rangle>nres_rel"
   apply (auto simp: approx_slp_spec_def comps aform_slp_def nres_rel_def
       intro!: RETURN_SPEC_refine ASSERT_refine_right)
   subgoal for a b
     apply (rule exI[where x = "map_option Joints (approx_slp_outer prec (length fas) (slp_of_fas fas) a)"])
     apply (auto simp: option.splits aforms_rel_def br_def env_len_def Joints_imp_length_eq)
     apply (auto dest!: approx_slp_outer_lengthD)[]
     using length_slp_of_fas_le trans_le_add1 approx_slp_outer_lengthD apply blast
     using approx_slp_outer_plain by blast
   done
 
 lemma fresh_index_aforms_Nil[simp]: "fresh_index_aforms [] = 0"
   by (auto simp: fresh_index_aforms_def)
 
 lemma independent_aforms_Nil[simp]:
   "independent_aforms x [] = [x]"
   by (auto simp: independent_aforms_def)
 
 lemma mem_Joints_zero_iff[simp]: "x # xs \<in> Joints ((0, zero_pdevs) # XS) \<longleftrightarrow> (x = 0 \<and> xs \<in> Joints XS)"
   by (auto simp: Joints_def valuate_def)
 
 lemma Joints_independent_aforms_eq: "Joints (independent_aforms x xs) = set_Cons (Affine x) (Joints xs)"
   by (simp add: independent_aforms_def Joints_msum_aform degree_le_fresh_index set_Cons_def)
 
 lemma independent_aforms_refine: "(independent_aforms, set_Cons) \<in> \<langle>rnv_rel\<rangle>aform_rel \<rightarrow> aforms_rel \<rightarrow> aforms_rel"
   by (auto simp: aforms_rel_def br_def aform_rel_def Joints_independent_aforms_eq)
 
 end
 
 
 locale aform_approximate_sets = approximate_sets
   aform_ops
   Joints
   aforms_rel
 begin
 
 lemma Joints_in_lv_rel_set_relD:
   "(Joints xs, X) \<in> \<langle>lv_rel\<rangle>set_rel \<Longrightarrow> X = Affine (eucl_of_list_aform xs)"
   unfolding lv_rel_def set_rel_br
   by (auto simp: br_def Joints_imp_length_eq eucl_of_list_image_Joints[symmetric])
 
 lemma ncc_precond: "ncc_precond TYPE('a::executable_euclidean_space)"
   unfolding ncc_precond_def ncc_def appr_rel_def
   by (auto simp: aforms_rel_def compact_Affine convex_Affine dest!: Joints_in_lv_rel_set_relD brD)
 
 lemma fst_eucl_of_list_aform_map: "fst (eucl_of_list_aform (map (\<lambda>x. (fst x, asdf x)) x)) =
   fst (eucl_of_list_aform x)"
   by (auto simp: eucl_of_list_aform_def o_def)
 
 lemma
   Affine_pdevs_of_list:\<comment> \<open>TODO: move!\<close>
   "Affine (fst x, pdevs_of_list (map snd (list_of_pdevs (snd x)))) = Affine x"
   by (auto simp: Affine_def valuate_def aform_val_def
       elim: pdevs_val_of_list_of_pdevs2[where X = "snd x"]
         pdevs_val_of_list_of_pdevs[where X = "snd x"])
 
 end
 
 lemma aform_approximate_sets: "aform_approximate_sets prec"
   apply (unfold_locales)
   unfolding aform_ops_def approximate_set_ops.simps
   subgoal unfolding relAPP_def aforms_rel_def .
   subgoal by (force simp: aforms_of_ivls_refine)
   subgoal by (rule product_aforms_refine)
   subgoal by (rule msum_aforms'_refine)
   subgoal by (rule inf_aforms_refine)
   subgoal by (rule sup_aforms_refine)
   subgoal by (rule split_aform_largest_take_refine)
   subgoal by (rule aform_inf_inner_refine)
   subgoal by (rule aform_sup_inner_refine)
   subgoal by (rule inter_aform_plane_refine) simp_all
   subgoal by (auto split: option.splits intro!: reduce_aform_refine)
   subgoal by (force simp: width_spec_def nres_rel_def)
   subgoal by (rule approx_slp_refine)
   subgoal by (rule aform_euclarithform_refine)
   subgoal by (rule aform_isFDERIV)
   subgoal by simp
   subgoal by (auto simp: Joints_imp_length_eq)
   subgoal by (force simp: Affine_def Joints_def valuate_def intro!:)
   subgoal by (force simp: Affine_def Joints_def valuate_def intro!:)
   subgoal by (auto simp: Joints_imp_length_eq)
   done
 
 end
diff --git a/thys/PAC_Checker/PAC_Checker_Relation.thy b/thys/PAC_Checker/PAC_Checker_Relation.thy
--- a/thys/PAC_Checker/PAC_Checker_Relation.thy
+++ b/thys/PAC_Checker/PAC_Checker_Relation.thy
@@ -1,387 +1,387 @@
 (*
   File:         PAC_Checker_Relation.thy
   Author:       Mathias Fleury, Daniela Kaufmann, JKU
   Maintainer:   Mathias Fleury, JKU
 *)
 theory PAC_Checker_Relation
   imports PAC_Checker WB_Sort "Native_Word.Uint64"
 begin
 
 section \<open>Various Refinement Relations\<close>
 
 text \<open>When writing this, it was not possible to share the definition with the IsaSAT version.\<close>
 definition uint64_nat_rel :: "(uint64 \<times> nat) set" where
  \<open>uint64_nat_rel = br nat_of_uint64 (\<lambda>_. True)\<close>
 
 abbreviation uint64_nat_assn where
   \<open>uint64_nat_assn \<equiv> pure uint64_nat_rel\<close>
 
 instantiation uint32 :: hashable
 begin
 definition hashcode_uint32 :: \<open>uint32 \<Rightarrow> uint32\<close> where
   \<open>hashcode_uint32 n = n\<close>
 
 definition def_hashmap_size_uint32 :: \<open>uint32 itself \<Rightarrow> nat\<close> where
   \<open>def_hashmap_size_uint32 = (\<lambda>_. 16)\<close>
   \<comment> \<open>same as @{typ nat}\<close>
 instance
   by standard (simp add: def_hashmap_size_uint32_def)
 end
 
 instantiation uint64 :: hashable
 begin
 definition hashcode_uint64 :: \<open>uint64 \<Rightarrow> uint32\<close> where
   \<open>hashcode_uint64 n = (uint32_of_nat (nat_of_uint64 ((n) AND ((2 :: uint64)^32 -1))))\<close>
 
 definition def_hashmap_size_uint64 :: \<open>uint64 itself \<Rightarrow> nat\<close> where
   \<open>def_hashmap_size_uint64 = (\<lambda>_. 16)\<close>
   \<comment> \<open>same as @{typ nat}\<close>
 instance
   by standard (simp add: def_hashmap_size_uint64_def)
 end
 
 lemma word_nat_of_uint64_Rep_inject[simp]: \<open>nat_of_uint64 ai = nat_of_uint64 bi \<longleftrightarrow> ai = bi\<close>
-  by transfer simp
+  by transfer (simp add: word_unat_eq_iff)
 
 instance uint64 :: heap
   by standard (auto simp: inj_def exI[of _ nat_of_uint64])
 
 instance uint64 :: semiring_numeral
   by standard
 
 lemma nat_of_uint64_012[simp]: \<open>nat_of_uint64 0 = 0\<close> \<open>nat_of_uint64 2 = 2\<close> \<open>nat_of_uint64 1 = 1\<close>
   by (transfer, auto)+
 
 definition uint64_of_nat_conv where
   [simp]: \<open>uint64_of_nat_conv (x :: nat) = x\<close>
 lemma less_upper_bintrunc_id: \<open>n < 2 ^b \<Longrightarrow> n \<ge> 0 \<Longrightarrow> bintrunc b n = n\<close>
   unfolding uint32_of_nat_def
   by (simp add: no_bintr_alt1)
 
 lemma nat_of_uint64_uint64_of_nat_id: \<open>n < 2^64 \<Longrightarrow> nat_of_uint64 (uint64_of_nat n) = n\<close>
   unfolding uint64_of_nat_def
   apply simp
   apply transfer
   apply (subst unat_eq_nat_uint)
   apply transfer
   by (auto simp: less_upper_bintrunc_id)
 
 lemma [sepref_fr_rules]:
   \<open>(return o uint64_of_nat, RETURN o uint64_of_nat_conv) \<in> [\<lambda>a. a < 2 ^64]\<^sub>a nat_assn\<^sup>k \<rightarrow> uint64_nat_assn\<close>
   by sepref_to_hoare
    (sep_auto simp: uint64_nat_rel_def br_def nat_of_uint64_uint64_of_nat_id)
 
 definition string_rel :: \<open>(String.literal \<times> string) set\<close> where
   \<open>string_rel = {(x, y). y = String.explode x}\<close>
 
 abbreviation string_assn :: \<open>string \<Rightarrow> String.literal \<Rightarrow> assn\<close> where
   \<open>string_assn \<equiv> pure string_rel\<close>
 
 lemma eq_string_eq:
   \<open>((=), (=)) \<in> string_rel \<rightarrow> string_rel \<rightarrow> bool_rel\<close>
  by (auto intro!: frefI simp: string_rel_def String.less_literal_def
     less_than_char_def rel2p_def literal.explode_inject)
 
 lemmas eq_string_eq_hnr =
    eq_string_eq[sepref_import_param]
 
 definition string2_rel :: \<open>(string \<times> string) set\<close> where
   \<open>string2_rel \<equiv> \<langle>Id\<rangle>list_rel\<close>
 
 abbreviation string2_assn :: \<open>string \<Rightarrow> string \<Rightarrow> assn\<close> where
   \<open>string2_assn \<equiv> pure string2_rel\<close>
 
 abbreviation monom_rel where
   \<open>monom_rel \<equiv> \<langle>string_rel\<rangle>list_rel\<close>
 
 abbreviation monom_assn where
   \<open>monom_assn \<equiv> list_assn string_assn\<close>
 
 abbreviation monomial_rel where
   \<open>monomial_rel \<equiv> monom_rel \<times>\<^sub>r int_rel\<close>
 
 abbreviation monomial_assn where
   \<open>monomial_assn \<equiv> monom_assn \<times>\<^sub>a int_assn\<close>
 
 abbreviation poly_rel where
   \<open>poly_rel \<equiv> \<langle>monomial_rel\<rangle>list_rel\<close>
 
 
 abbreviation poly_assn where
   \<open>poly_assn \<equiv> list_assn monomial_assn\<close>
 
 lemma poly_assn_alt_def:
   \<open>poly_assn = pure poly_rel\<close>
   by (simp add: list_assn_pure_conv)
 
 abbreviation polys_assn where
   \<open>polys_assn \<equiv> hm_fmap_assn uint64_nat_assn poly_assn\<close>
 
 lemma string_rel_string_assn:
   \<open>(\<up> ((c, a) \<in> string_rel)) = string_assn a c\<close>
   by (auto simp: pure_app_eq)
 
 lemma single_valued_string_rel:
    \<open>single_valued string_rel\<close>
    by (auto simp: single_valued_def string_rel_def)
 
 lemma IS_LEFT_UNIQUE_string_rel:
    \<open>IS_LEFT_UNIQUE string_rel\<close>
    by (auto simp: IS_LEFT_UNIQUE_def single_valued_def string_rel_def
      literal.explode_inject)
 
 lemma IS_RIGHT_UNIQUE_string_rel:
    \<open>IS_RIGHT_UNIQUE string_rel\<close>
    by (auto simp: single_valued_def string_rel_def
      literal.explode_inject)
 
 lemma single_valued_monom_rel: \<open>single_valued monom_rel\<close>
   by (rule list_rel_sv)
     (auto intro!: frefI simp: string_rel_def
     rel2p_def single_valued_def p2rel_def)
 
 lemma single_valued_monomial_rel:
   \<open>single_valued monomial_rel\<close>
   using single_valued_monom_rel
   by (auto intro!: frefI simp:
     rel2p_def single_valued_def p2rel_def)
 
 lemma single_valued_monom_rel': \<open>IS_LEFT_UNIQUE monom_rel\<close>
   unfolding IS_LEFT_UNIQUE_def inv_list_rel_eq string2_rel_def
   by (rule list_rel_sv)+
    (auto intro!: frefI simp: string_rel_def
     rel2p_def single_valued_def p2rel_def literal.explode_inject)
 
 
 lemma single_valued_monomial_rel':
   \<open>IS_LEFT_UNIQUE monomial_rel\<close>
   using single_valued_monom_rel'
   unfolding IS_LEFT_UNIQUE_def inv_list_rel_eq
   by (auto intro!: frefI simp:
     rel2p_def single_valued_def p2rel_def)
 
 lemma [safe_constraint_rules]:
   \<open>Sepref_Constraints.CONSTRAINT single_valued string_rel\<close>
   \<open>Sepref_Constraints.CONSTRAINT IS_LEFT_UNIQUE string_rel\<close>
   by (auto simp: CONSTRAINT_def single_valued_def
     string_rel_def IS_LEFT_UNIQUE_def literal.explode_inject)
 
 lemma eq_string_monom_hnr[sepref_fr_rules]:
   \<open>(uncurry (return oo (=)), uncurry (RETURN oo (=))) \<in> monom_assn\<^sup>k *\<^sub>a monom_assn\<^sup>k \<rightarrow>\<^sub>a bool_assn\<close>
   using single_valued_monom_rel' single_valued_monom_rel
   unfolding list_assn_pure_conv
   by sepref_to_hoare
    (sep_auto simp: list_assn_pure_conv string_rel_string_assn
        single_valued_def IS_LEFT_UNIQUE_def
      dest!: mod_starD
      simp flip: inv_list_rel_eq)
 
 
 definition term_order_rel' where
   [simp]: \<open>term_order_rel' x y = ((x, y) \<in> term_order_rel)\<close>
 
 lemma term_order_rel[def_pat_rules]:
   \<open>(\<in>)$(x,y)$term_order_rel \<equiv> term_order_rel'$x$y\<close>
   by auto
 
 lemma term_order_rel_alt_def:
   \<open>term_order_rel = lexord (p2rel char.lexordp)\<close>
   by (auto simp: p2rel_def char.lexordp_conv_lexord var_order_rel_def intro!: arg_cong[of _ _ lexord])
 
 
 instantiation char :: linorder
 begin
   definition less_char where [symmetric, simp]: "less_char = PAC_Polynomials_Term.less_char"
   definition less_eq_char where [symmetric, simp]: "less_eq_char = PAC_Polynomials_Term.less_eq_char"
 instance
   apply standard
   using char.linorder_axioms
   by (auto simp: class.linorder_def class.order_def class.preorder_def
        less_eq_char_def less_than_char_def class.order_axioms_def
        class.linorder_axioms_def p2rel_def less_char_def)
 end
 
 
 instantiation list :: (linorder) linorder
 begin
   definition less_list where  "less_list = lexordp (<)"
   definition less_eq_list where "less_eq_list = lexordp_eq"
 
 instance
 proof standard
   have [dest]: \<open>\<And>x y :: 'a :: linorder list. (x, y) \<in> lexord {(x, y). x < y} \<Longrightarrow>
            lexordp_eq y x \<Longrightarrow> False\<close>
     by (metis lexordp_antisym lexordp_conv_lexord lexordp_eq_conv_lexord)
   have [simp]: \<open>\<And>x y :: 'a :: linorder list. lexordp_eq x y \<Longrightarrow>
            \<not> lexordp_eq y x \<Longrightarrow>
            (x, y) \<in> lexord {(x, y). x < y}\<close>
     using lexordp_conv_lexord lexordp_conv_lexordp_eq by blast
   show
    \<open>(x < y) = Restricted_Predicates.strict (\<le>) x y\<close>
    \<open>x \<le> x\<close>
    \<open>x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z\<close>
    \<open>x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y\<close>
    \<open>x \<le> y \<or> y \<le> x\<close>
    for x y z :: \<open>'a :: linorder list\<close>
     by (auto simp: less_list_def less_eq_list_def List.lexordp_def
     lexordp_conv_lexord lexordp_into_lexordp_eq lexordp_antisym
     antisym_def lexordp_eq_refl lexordp_eq_linear intro: lexordp_eq_trans
     dest: lexordp_eq_antisym)
 qed
 
 end
 
 
 lemma term_order_rel'_alt_def_lexord:
     \<open>term_order_rel' x y = ord_class.lexordp x y\<close> and
   term_order_rel'_alt_def:
     \<open>term_order_rel' x y \<longleftrightarrow> x < y\<close>
 proof -
   show
     \<open>term_order_rel' x y = ord_class.lexordp x y\<close>
     \<open>term_order_rel' x y \<longleftrightarrow> x < y\<close>
     unfolding less_than_char_of_char[symmetric, abs_def]
     by (auto simp: lexordp_conv_lexord less_eq_list_def
          less_list_def lexordp_def var_order_rel_def
          rel2p_def term_order_rel_alt_def p2rel_def)
 qed
 
 lemma list_rel_list_rel_order_iff:
   assumes \<open>(a, b) \<in> \<langle>string_rel\<rangle>list_rel\<close> \<open>(a', b') \<in> \<langle>string_rel\<rangle>list_rel\<close>
   shows \<open>a < a' \<longleftrightarrow> b < b'\<close>
 proof
   have H: \<open>(a, b) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow>
        (a, cs) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow> b = cs\<close> for cs
      using single_valued_monom_rel' IS_RIGHT_UNIQUE_string_rel
      unfolding string2_rel_def
      by (subst (asm)list_rel_sv_iff[symmetric])
        (auto simp: single_valued_def)
   assume \<open>a < a'\<close>
   then consider
     u u' where \<open>a' = a @ u # u'\<close> |
     u aa v w aaa where \<open>a = u @ aa # v\<close> \<open>a' = u @ aaa # w\<close> \<open>aa < aaa\<close>
     by (subst (asm) less_list_def)
      (auto simp: lexord_def List.lexordp_def
       list_rel_append1 list_rel_split_right_iff)
   then show \<open>b < b'\<close>
   proof cases
     case 1
     then show \<open>b < b'\<close>
       using assms
       by (subst less_list_def)
         (auto simp: lexord_def List.lexordp_def
         list_rel_append1 list_rel_split_right_iff dest: H)
   next
     case 2
     then obtain u' aa' v' w' aaa' where
        \<open>b = u' @ aa' # v'\<close> \<open>b' = u' @ aaa' # w'\<close>
        \<open>(aa, aa') \<in> string_rel\<close>
        \<open>(aaa, aaa') \<in> string_rel\<close>
       using assms
       by (smt list_rel_append1 list_rel_split_right_iff single_valued_def single_valued_monom_rel)
     with \<open>aa < aaa\<close> have \<open>aa' < aaa'\<close>
       by (auto simp: string_rel_def less_literal.rep_eq less_list_def
         lexordp_conv_lexord lexordp_def char.lexordp_conv_lexord
           simp flip: less_char_def PAC_Polynomials_Term.less_char_def)
     then show \<open>b < b'\<close>
       using \<open>b = u' @ aa' # v'\<close> \<open>b' = u' @ aaa' # w'\<close>
       by (subst less_list_def)
         (fastforce simp: lexord_def List.lexordp_def
         list_rel_append1 list_rel_split_right_iff)
   qed
 next
   have H: \<open>(a, b) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow>
        (a', b) \<in> \<langle>string_rel\<rangle>list_rel \<Longrightarrow> a = a'\<close> for a a' b
      using single_valued_monom_rel'
      by (auto simp: single_valued_def IS_LEFT_UNIQUE_def
        simp flip: inv_list_rel_eq)
   assume \<open>b < b'\<close>
   then consider
     u u' where \<open>b' = b @ u # u'\<close> |
     u aa v w aaa where \<open>b = u @ aa # v\<close> \<open>b' = u @ aaa # w\<close> \<open>aa < aaa\<close>
     by (subst (asm) less_list_def)
      (auto simp: lexord_def List.lexordp_def
       list_rel_append1 list_rel_split_right_iff)
   then show \<open>a < a'\<close>
   proof cases
     case 1
     then show \<open>a < a'\<close>
       using assms
       by (subst less_list_def)
         (auto simp: lexord_def List.lexordp_def
         list_rel_append2 list_rel_split_left_iff dest: H)
   next
     case 2
     then obtain u' aa' v' w' aaa' where
        \<open>a = u' @ aa' # v'\<close> \<open>a' = u' @ aaa' # w'\<close>
        \<open>(aa', aa) \<in> string_rel\<close>
        \<open>(aaa', aaa) \<in> string_rel\<close>
       using assms
       by (auto simp: lexord_def List.lexordp_def
         list_rel_append2 list_rel_split_left_iff dest: H)
     with \<open>aa < aaa\<close> have \<open>aa' < aaa'\<close>
       by (auto simp: string_rel_def less_literal.rep_eq less_list_def
         lexordp_conv_lexord lexordp_def char.lexordp_conv_lexord
           simp flip: less_char_def PAC_Polynomials_Term.less_char_def)
     then show \<open>a < a'\<close>
       using \<open>a = u' @ aa' # v'\<close> \<open>a' = u' @ aaa' # w'\<close>
       by (subst less_list_def)
         (fastforce simp: lexord_def List.lexordp_def
         list_rel_append1 list_rel_split_right_iff)
   qed
 qed
 
 
 lemma string_rel_le[sepref_import_param]:
   shows \<open>((<), (<)) \<in> \<langle>string_rel\<rangle>list_rel \<rightarrow>  \<langle>string_rel\<rangle>list_rel \<rightarrow> bool_rel\<close>
   by (auto intro!: fun_relI simp: list_rel_list_rel_order_iff)
 
 (* TODO Move *)
 lemma [sepref_import_param]:
   assumes \<open>CONSTRAINT IS_LEFT_UNIQUE R\<close>  \<open>CONSTRAINT IS_RIGHT_UNIQUE R\<close>
   shows \<open>(remove1, remove1) \<in> R \<rightarrow> \<langle>R\<rangle>list_rel \<rightarrow> \<langle>R\<rangle>list_rel\<close>
   apply (intro fun_relI)
   subgoal premises p for x y xs ys
     using p(2) p(1) assms
     by (induction xs ys rule: list_rel_induct)
       (auto simp: IS_LEFT_UNIQUE_def single_valued_def)
   done
 
 instantiation pac_step :: (heap, heap, heap) heap
 begin
 
 instance
 proof standard
   obtain f :: \<open>'a \<Rightarrow> nat\<close> where
     f: \<open>inj f\<close>
     by blast
   obtain g :: \<open>nat \<times> nat \<times> nat \<times> nat \<times> nat \<Rightarrow> nat\<close> where
     g: \<open>inj g\<close>
     by blast
   obtain h :: \<open>'b \<Rightarrow> nat\<close> where
     h: \<open>inj h\<close>
     by blast
   obtain i :: \<open>'c \<Rightarrow> nat\<close> where
     i: \<open>inj i\<close>
     by blast
   have [iff]: \<open>g a = g b \<longleftrightarrow> a = b\<close>\<open>h a'' = h b'' \<longleftrightarrow> a'' = b''\<close>  \<open>f a' = f b' \<longleftrightarrow> a' = b'\<close>
     \<open>i a''' = i b''' \<longleftrightarrow> a''' = b'''\<close>  for a b a' b' a'' b'' a''' b'''
     using f g h i unfolding inj_def by blast+
   let ?f = \<open>\<lambda>x :: ('a, 'b, 'c) pac_step.
      g (case x of
         Add a b c d \<Rightarrow>     (0, i a,  i b,  i c, f d)
       | Del a  \<Rightarrow>          (1, i a,    0,   0,   0)
       | Mult a b c d \<Rightarrow>    (2, i a, f b, i c, f d)
       | Extension a b c \<Rightarrow> (3, i a, f c, 0, h b))\<close>
    have \<open>inj ?f\<close>
      apply (auto simp: inj_def)
      apply (case_tac x; case_tac y)
      apply auto
      done
    then show \<open>\<exists>f :: ('a, 'b, 'c) pac_step \<Rightarrow> nat. inj f\<close>
      by blast
 qed
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/VerifyThis2018/Challenge1_short.thy b/thys/VerifyThis2018/Challenge1_short.thy
--- a/thys/VerifyThis2018/Challenge1_short.thy
+++ b/thys/VerifyThis2018/Challenge1_short.thy
@@ -1,198 +1,197 @@
 section \<open>Shorter Solution\<close>
 theory Challenge1_short
 imports "lib/VTcomp"
 begin
 
 text \<open>Small specification of textbuffer ADT,
   and its implementation by a gap buffer.
   
   Annotated and elaborated version of just the challenge requirements.
 \<close>
 subsection \<open>Abstract Specification\<close>
 
   datatype 'a textbuffer = BUF ("pos": "nat") ("text": "'a list")
   \<comment> \<open>Note that we do not model the abstract invariant --- pos in range --- here,
     as it is not strictly required for the challenge spec.\<close>
 
   text \<open>These are the operations that were specified in the challenge.
     Note: Isabelle has type inference, so we do not need to specify types.
     Note: We exploit that, in Isabelle, we have @{lemma "(0::nat)-1=0" by simp}.
   \<close>
   primrec move_left where "move_left (BUF p t) = BUF (p-1) t" 
   primrec move_right where "move_right (BUF p t) = BUF (min (length t) (p+1)) t"
   primrec insert where "insert x (BUF p t) = BUF (p+1) (take p t@x#drop p t)"
   primrec delete where "delete (BUF p t) = BUF (p-1) (take (p-1) t@drop p t)"
   
 subsection \<open>Refinement 1: List with Gap\<close>  
   
   subsection \<open>Implementation on List-Level\<close>  
   type_synonym 'a gap_buffer = "nat \<times> nat \<times> 'a list"
 
   subsubsection \<open>Abstraction Relation\<close>
   text \<open>We define an invariant on the concrete gap-buffer, and its mapping to the
     abstract model. From these two, we define a relation \<open>gap_rel\<close> between
     concrete and abstract buffers. \<close>
   definition "gap_\<alpha> \<equiv> \<lambda>(l,r,buf). BUF l (take l buf @ drop r buf)"
   definition "gap_invar \<equiv> \<lambda>(l,r,buf). l\<le>r \<and> r\<le>length buf"
   abbreviation "gap_rel \<equiv> br gap_\<alpha> gap_invar"
 
   subsubsection \<open>Left\<close>
   
   text \<open>For the operations, we insert assertions. These are not required to prove
     the list-level specification correct (during the proof, they are inferred easily).
     However, they are required in the subsequent automatic refinement step to arrays,
     to give our tool the information that all indexes are, indeed, in bounds.\<close>
   
   definition "move_left1 \<equiv> \<lambda>(l,r,buf). doN {
     if l\<noteq>0 then doN {
       ASSERT(r-1<length buf \<and> l-1<length buf);
       RETURN (l-1,r-1,buf[r-1:=buf!(l-1)])
     } else RETURN (l,r,buf)
   }"
 
   lemma move_left1_correct: 
     "(move_left1, RETURN o move_left) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
     apply clarsimp
     unfolding move_left1_def
     apply refine_vcg
     apply (auto 
       simp: in_br_conv gap_\<alpha>_def gap_invar_def move_left1_def 
       split: prod.splits)
     (* sledgehammer! *)  
     by (smt Cons_nth_drop_Suc Suc_pred append.assoc append_Cons append_Nil 
       diff_Suc_less drop_update_cancel hd_drop_conv_nth length_list_update 
       less_le_trans nth_list_update_eq take_hd_drop)  
 
   subsubsection \<open>Right\<close>        
   definition "move_right1 \<equiv> \<lambda>(l,r,buf). doN {
     if r<length buf then doN {
       ASSERT (l<length buf);
       RETURN (l+1,r+1,buf[l:=buf!r])
     } else RETURN (l,r,buf)
   }"
     
   lemma move_right1_correct: 
     "(move_right1,RETURN o move_right) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
     apply clarsimp
     unfolding move_right1_def
     apply refine_vcg
     unfolding gap_\<alpha>_def gap_invar_def
     apply (auto simp: in_br_conv split: prod.split)
-    (* sledgehammer *)
-    by (metis Cons_eq_appendI Cons_nth_drop_Suc append_eq_append_conv2 
-      atd_lem drop_0 dual_order.strict_trans2 take_eq_Nil take_update_last)
-    (* Manual: by (simp add: hd_drop_conv_nth take_update_last Cons_nth_drop_Suc) *)
-        
+    apply (rule nth_equalityI)
+     apply (simp_all add: Cons_nth_drop_Suc take_update_last)
+    done
+
   subsubsection \<open>Insert and Grow\<close>
      
   definition "can_insert \<equiv> \<lambda>(l,r,buf). l<r"
   
   definition "grow1 K \<equiv> \<lambda>(l,r,buf). doN {
     let b = op_array_replicate (length buf + K) default;
     b \<leftarrow> mop_list_blit buf 0 b 0 l;
     b \<leftarrow> mop_list_blit buf r b (r+K) (length buf - r);
     RETURN (l,r+K,b)
   }"
   \<comment> \<open>Note: Most operations have also a variant prefixed with \<open>mop\<close>.
     These are defined in the refinement monad and already contain the assertion 
     of their precondition. The backside is that they cannot be easily used in as part
     of expressions, e.g., in @{term "buf[l:=buf!r]"}, we would have to explicitly bind
     each intermediate value: @{term "doN { v \<leftarrow> mop_list_get buf r; mop_list_set buf l v }"}.
   \<close>
   
   lemma grow1_correct[THEN SPEC_trans, refine_vcg]: 
     \<comment> \<open>Declares this as a rule to be used by the VCG\<close>
     assumes "gap_invar gb"
     shows "grow1 K gb \<le> (SPEC (\<lambda>gb'. 
         gap_invar gb' 
       \<and> gap_\<alpha> gb' = gap_\<alpha> gb 
       \<and> (K>0 \<longrightarrow> can_insert gb')))"
     unfolding grow1_def
     apply refine_vcg    
     using assms
     unfolding gap_\<alpha>_def gap_invar_def can_insert_def
     apply (auto simp: op_list_blit_def)
     done  
   
   definition "insert1 x \<equiv> \<lambda>(l,r,buf). doN {
     (l,r,buf) \<leftarrow> 
       if (l=r) then grow1 (length buf+1) (l,r,buf) else RETURN (l,r,buf);
     ASSERT (l<length buf);
     RETURN (l+1,r,buf[l:=x])
   }" 
   
   lemma insert1_correct: 
     "(insert1,RETURN oo insert) \<in> Id \<rightarrow> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
     apply clarsimp
     unfolding insert1_def
     apply refine_vcg \<comment> \<open>VCG knows the rule for grow1 already\<close>
     unfolding insert_def gap_\<alpha>_def gap_invar_def can_insert_def
     apply (auto simp: in_br_conv take_update_last split: prod.split)
     done
   
 
   subsubsection \<open>Delete\<close>
   definition "delete1 
     \<equiv> \<lambda>(l,r,buf). if l>0 then RETURN (l-1,r,buf) else RETURN (l,r,buf)" 
   lemma delete1_correct: 
     "(delete1,RETURN o delete) \<in> gap_rel \<rightarrow> \<langle>gap_rel\<rangle>nres_rel"
     apply clarsimp
     unfolding delete1_def
     apply refine_vcg
     unfolding gap_\<alpha>_def gap_invar_def
     by (auto simp: in_br_conv butlast_take split: prod.split)
   
 subsection \<open>Imperative Arrays\<close>  
   text \<open>The following indicates how we will further refine the gap-buffer:
     The list will become an array, the indices and the content will not be 
     refined (expressed by @{const nat_assn} and @{const id_assn}).
   \<close>
   abbreviation "gap_impl_assn \<equiv> nat_assn \<times>\<^sub>a nat_assn \<times>\<^sub>a array_assn id_assn"  
   
   sepref_definition move_left_impl 
     is move_left1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
     unfolding move_left1_def by sepref
 
   sepref_definition move_right_impl 
     is move_right1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
     unfolding move_right1_def by sepref
   
   sepref_definition insert_impl 
     is "uncurry insert1" :: "id_assn\<^sup>k*\<^sub>agap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
     unfolding insert1_def grow1_def by sepref 
     \<comment> \<open>We inline @{const grow1} here\<close>
     
   sepref_definition delete_impl 
     is delete1 :: "gap_impl_assn\<^sup>d\<rightarrow>\<^sub>agap_impl_assn"
     unfolding delete1_def by sepref
   
   
   text \<open>Finally, we combine the two refinement steps, to get overall correctness theorems\<close>  
   definition "gap_assn \<equiv> hr_comp gap_impl_assn gap_rel" 
     \<comment> \<open>@{const hr_comp} is composition of refinement relations\<close>
   context notes gap_assn_def[symmetric,fcomp_norm_unfold] begin
     lemmas move_left_impl_correct = move_left_impl.refine[FCOMP move_left1_correct]
        and move_right_impl_correct = move_right_impl.refine[FCOMP move_right1_correct]
        and insert_impl_correct = insert_impl.refine[FCOMP insert1_correct]
        and delete_impl_correct = delete_impl.refine[FCOMP delete1_correct]
     text \<open>Proves:
       @{thm [display] move_left_impl_correct}
       @{thm [display] move_right_impl_correct}
       @{thm [display] insert_impl_correct}
       @{thm [display] delete_impl_correct}
     \<close>
        
   
   end
   
 subsection \<open>Executable Code\<close>  
   text \<open>Isabelle/HOL can generate code in various target languages.\<close>
 
   export_code move_left_impl move_right_impl insert_impl delete_impl  
     in SML_imp module_name Gap_Buffer
     in OCaml_imp module_name Gap_Buffer
     in Haskell module_name Gap_Buffer
     in Scala module_name Gap_Buffer
     
         
 end
diff --git a/thys/WebAssembly/Wasm_Ast.thy b/thys/WebAssembly/Wasm_Ast.thy
--- a/thys/WebAssembly/Wasm_Ast.thy
+++ b/thys/WebAssembly/Wasm_Ast.thy
@@ -1,180 +1,185 @@
 section \<open>WebAssembly Core AST\<close>
 
-theory Wasm_Ast imports Main "Native_Word.Uint8" begin
+theory Wasm_Ast
+  imports
+    Main
+    "Native_Word.Uint8"
+    "Word_Lib.Reversed_Bit_Lists"
+begin
 
 type_synonym \<comment> \<open>immediate\<close>
   i = nat
 type_synonym \<comment> \<open>static offset\<close>
   off = nat
 type_synonym \<comment> \<open>alignment exponent\<close>
   a = nat
 
 \<comment> \<open>primitive types\<close>
 typedecl i32
 typedecl i64
 typedecl f32
 typedecl f64
 
 \<comment> \<open>memory\<close>
 type_synonym byte = uint8
 
 typedef bytes = "UNIV :: (byte list) set" ..
 setup_lifting type_definition_bytes
 declare Quotient_bytes[transfer_rule]
 
 lift_definition bytes_takefill :: "byte \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> bytes" is "(\<lambda>a n as. takefill (Abs_uint8 a) n as)" .
 lift_definition bytes_replicate :: "nat \<Rightarrow> byte \<Rightarrow> bytes" is "(\<lambda>n b. replicate n (Abs_uint8 b))" .
 definition msbyte :: "bytes \<Rightarrow> byte" where
   "msbyte bs = last (Rep_bytes bs)"
 
 typedef mem = "UNIV :: (byte list) set" ..
 setup_lifting type_definition_mem
 declare Quotient_mem[transfer_rule]
 
 lift_definition read_bytes :: "mem \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bytes" is "(\<lambda>m n l. take l (drop n m))" .
 lift_definition write_bytes :: "mem \<Rightarrow> nat \<Rightarrow> bytes \<Rightarrow> mem" is "(\<lambda>m n bs. (take n m) @ bs @ (drop (n + length bs) m))" .
 lift_definition mem_append :: "mem \<Rightarrow> bytes \<Rightarrow> mem" is append .
 
 \<comment> \<open>host\<close>
 typedecl host
 typedecl host_state
 
 datatype \<comment> \<open>value types\<close>
   t = T_i32 | T_i64 | T_f32 | T_f64
 
 datatype \<comment> \<open>packed types\<close>
   tp = Tp_i8 | Tp_i16 | Tp_i32
 
 datatype \<comment> \<open>mutability\<close>
   mut = T_immut | T_mut
 
 record tg = \<comment> \<open>global types\<close>
   tg_mut :: mut
   tg_t :: t
 
 datatype \<comment> \<open>function types\<close>
   tf = Tf "t list" "t list" ("_ '_> _" 60)
 
 (* TYPING *)
 record t_context =
   types_t :: "tf list"
   func_t :: "tf list"
   global :: "tg list"
   table :: "nat option"
   memory :: "nat option"
   local :: "t list"
   label :: "(t list) list"
   return :: "(t list) option"
 
 record s_context =
   s_inst :: "t_context list"
   s_funcs :: "tf list"
   s_tab  :: "nat list"
   s_mem  :: "nat list"
   s_globs :: "tg list"
 
 datatype
   sx = S | U
 
 datatype
   unop_i = Clz | Ctz | Popcnt
 
 datatype
   unop_f = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt
 
 datatype
   binop_i = Add | Sub | Mul | Div sx | Rem sx | And | Or | Xor | Shl | Shr sx | Rotl | Rotr
 
 datatype
   binop_f = Addf | Subf | Mulf | Divf | Min | Max | Copysign
   
 datatype
   testop = Eqz
   
 datatype
   relop_i = Eq | Ne | Lt sx | Gt sx | Le sx | Ge sx
   
 datatype
   relop_f = Eqf | Nef | Ltf | Gtf | Lef | Gef
   
 datatype
   cvtop = Convert | Reinterpret
 
 datatype \<comment> \<open>values\<close>
   v =
     ConstInt32 i32
     | ConstInt64 i64
     | ConstFloat32 f32
     | ConstFloat64 f64
 
 datatype \<comment> \<open>basic instructions\<close>
   b_e =
     Unreachable
     | Nop
     | Drop
     | Select
     | Block tf "b_e list"
     | Loop tf "b_e list"
     | If tf "b_e list" "b_e list"
     | Br i
     | Br_if i
     | Br_table "i list" i
     | Return
     | Call i
     | Call_indirect i
     | Get_local i
     | Set_local i
     | Tee_local i
     | Get_global i
     | Set_global i
     | Load t "(tp \<times> sx) option" a off
     | Store t "tp option" a off
     | Current_memory
     | Grow_memory
     | EConst v ("C _" 60)
     | Unop_i t unop_i
     | Unop_f t unop_f
     | Binop_i t binop_i
     | Binop_f t binop_f
     | Testop t testop
     | Relop_i t relop_i
     | Relop_f t relop_f
     | Cvtop t cvtop t "sx option"
 
 datatype cl = \<comment> \<open>function closures\<close>
   Func_native i tf "t list" "b_e list"
 | Func_host tf host
 
 record inst = \<comment> \<open>instances\<close>
   types :: "tf list"
   funcs :: "i list"
   tab :: "i option"
   mem :: "i option"
   globs :: "i list"
 
 type_synonym tabinst = "(cl option) list"
 
 record global =
   g_mut :: mut
   g_val :: v
 
 record s = \<comment> \<open>store\<close>
   inst :: "inst list"
   funcs :: "cl list"
   tab :: "tabinst list"
   mem :: "mem list"
   globs :: "global list"
 
 datatype e = \<comment> \<open>administrative instruction\<close>
   Basic b_e ("$_" 60)
   | Trap
   | Callcl cl
   | Label nat "e list" "e list"
   | Local nat i "v list" "e list"
 
 datatype Lholed =
     \<comment> \<open>L0 = v* [<hole>] e*\<close>
     LBase "e list" "e list"
     \<comment> \<open>L(i+1) = v* (label n {e* } Li) e*\<close>
   | LRec "e list" nat "e list" Lholed "e list"
 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,1081 +1,929 @@
 (*
  * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section "Word Alignment"
 
 theory Aligned
   imports
-  "HOL-Library.Word"
-  Reversed_Bit_Lists
-  More_Word
-  Word_EqI
+    "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 [elim?]:
+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 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 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 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 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 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 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 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 aligned_add_xor:
-  assumes al: "is_aligned (x::'a::len word) n'" and le: "n < n'"
-  shows "(x + 2^n) XOR 2^n = x"
-proof cases
-  assume "n' < LENGTH('a)"
-  with assms show ?thesis
-  apply -
-  apply (rule word_bl.Rep_eqD)
-  apply (subst xor_2p_to_bl)
-  apply simp
-  apply (subst is_aligned_add_conv, simp, simp add: word_less_nat_alt)+
-  apply (simp add: to_bl_2p nth_append)
-  apply (cases "n' = Suc n")
-   apply simp
-   apply (subst is_aligned_replicate [where n="Suc n", simplified, symmetric]; simp)
-  apply (subgoal_tac "\<not> LENGTH('a) - Suc n \<le> LENGTH('a) - n'")
-   prefer 2
-   apply arith
-  apply (subst replicate_Suc [symmetric])
-  apply (subst replicate_add [symmetric])
-  apply (simp add: is_aligned_replicate [simplified, symmetric])
-  done
-next
-  assume "\<not> n' < LENGTH('a)"
-  show ?thesis
-    using al apply (rule is_alignedE)
-    using \<open>\<not> n' < LENGTH('a)\<close> by auto
+  \<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_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
-
 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"
-  apply (erule is_aligned_get_word_bits)
-   apply (frule is_aligned_add_conv [rotated, where w=0])
-    apply (simp add: is_aligned_iff_dvd_nat)
-   apply simp
-   apply (drule is_aligned_replicateD)
-    apply simp
-   apply (clarsimp simp: word_size)
-   apply (subst (asm) replicate_add [symmetric])
-   apply (drule arg_cong[where f="of_bl :: bool list \<Rightarrow> 'a::len word"])
-   apply simp
-  apply (simp only: replicate.simps[symmetric, where x=False]
-                    drop_replicate)
-  done
+  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 (simp add: word_size_bl)
+       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)
 
 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,290 +1,314 @@
 
 section \<open>Arithmetic lemmas\<close>
 
 theory More_Arithmetic
   imports Main
 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
+
 end
diff --git a/thys/Word_Lib/More_Word_Operations.thy b/thys/Word_Lib/More_Word_Operations.thy
--- a/thys/Word_Lib/More_Word_Operations.thy
+++ b/thys/Word_Lib/More_Word_Operations.thy
@@ -1,663 +1,664 @@
 
 section \<open>Misc word operations\<close>
 
 theory More_Word_Operations
   imports
     "HOL-Library.Word"
     Aligned
+    Reversed_Bit_Lists
     More_Misc
 begin
 
 definition
   ptr_add :: "'a :: len word \<Rightarrow> nat \<Rightarrow> 'a word" where
   "ptr_add ptr n \<equiv> ptr + of_nat n"
 
 definition
   alignUp :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word" where
  "alignUp x n \<equiv> x + 2 ^ n - 1 AND NOT (2 ^ n - 1)"
 
 (* standard notation for blocks of 2^n-1 words, usually aligned;
    abbreviation so it simplifies directly *)
 abbreviation mask_range :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" where
   "mask_range p n \<equiv> {p .. p + mask n}"
 
 definition
   w2byte :: "'a :: len word \<Rightarrow> 8 word" where
   "w2byte \<equiv> ucast"
 
 (* Count leading zeros  *)
 definition
   word_clz :: "'a::len word \<Rightarrow> nat"
 where
   "word_clz w \<equiv> length (takeWhile Not (to_bl w))"
 
 (* Count trailing zeros  *)
 definition
   word_ctz :: "'a::len word \<Rightarrow> nat"
 where
   "word_ctz w \<equiv> length (takeWhile Not (rev (to_bl w)))"
 
 lemma word_ctz_le:
   "word_ctz (w :: ('a::len word)) \<le> LENGTH('a)"
   apply (clarsimp simp: word_ctz_def)
   apply (rule nat_le_Suc_less_imp[where y="LENGTH('a) + 1" , simplified])
   apply (rule order_le_less_trans[OF List.length_takeWhile_le])
   apply simp
   done
 
 lemma word_ctz_less:
   "w \<noteq> 0 \<Longrightarrow> word_ctz (w :: ('a::len word)) < LENGTH('a)"
   apply (clarsimp simp: word_ctz_def eq_zero_set_bl)
   apply (rule order_less_le_trans[OF length_takeWhile_less])
    apply fastforce+
   done
 
 lemma word_ctz_not_minus_1:
   "1 < LENGTH('a) \<Longrightarrow> of_nat (word_ctz (w :: 'a :: len word)) \<noteq> (- 1 :: 'a::len word)"
   by (metis (mono_tags) One_nat_def add.right_neutral add_Suc_right le_diff_conv le_less_trans
                         n_less_equal_power_2 not_le suc_le_pow_2 unat_minus_one_word unat_of_nat_len
                         word_ctz_le)
 
 definition
   word_log2 :: "'a::len word \<Rightarrow> nat"
 where
   "word_log2 (w::'a::len word) \<equiv> size w - 1 - word_clz w"
 
 (* Bit population count. Equivalent of __builtin_popcount. *)
 definition
   pop_count :: "('a::len) word \<Rightarrow> nat"
 where
   "pop_count w \<equiv> length (filter id (to_bl w))"
 
 (* Sign extension from bit n *)
 definition
   sign_extend :: "nat \<Rightarrow> 'a::len word \<Rightarrow> 'a word"
 where
   "sign_extend n w \<equiv> if w !! n then w OR NOT (mask n) else w AND mask n"
 
 lemma sign_extend_eq_signed_take_bit:
   \<open>sign_extend = signed_take_bit\<close>
 proof (rule ext)+
   fix n and w :: \<open>'a::len word\<close>
   show \<open>sign_extend n w = signed_take_bit n w\<close>
   proof (rule bit_word_eqI)
     fix q
     assume \<open>q < LENGTH('a)\<close>
     then show \<open>bit (sign_extend n w) q \<longleftrightarrow> bit (signed_take_bit n w) q\<close>
       by (auto simp add: test_bit_eq_bit bit_signed_take_bit_iff
         sign_extend_def bit_and_iff bit_or_iff bit_not_iff bit_mask_iff not_less
         exp_eq_0_imp_not_bit not_le min_def)
   qed
 qed
 
 definition
   sign_extended :: "nat \<Rightarrow> 'a::len word \<Rightarrow> bool"
 where
   "sign_extended n w \<equiv> \<forall>i. n < i \<longrightarrow> i < size w \<longrightarrow> w !! i = w !! n"
 
 lemma ptr_add_0 [simp]:
   "ptr_add ref 0 = ref "
   unfolding ptr_add_def by simp
 
 lemma pop_count_0[simp]:
   "pop_count 0 = 0"
   by (clarsimp simp:pop_count_def)
 
 lemma pop_count_1[simp]:
   "pop_count 1 = 1"
   by (clarsimp simp:pop_count_def to_bl_1)
 
 lemma pop_count_0_imp_0:
   "(pop_count w = 0) = (w = 0)"
   apply (rule iffI)
    apply (clarsimp simp:pop_count_def)
    apply (subst (asm) filter_empty_conv)
    apply (clarsimp simp:eq_zero_set_bl)
    apply fast
   apply simp
   done
 
 lemma word_log2_nth_same:
   "w \<noteq> 0 \<Longrightarrow> w !! word_log2 w"
   unfolding word_log2_def
   using nth_length_takeWhile[where P=Not and xs="to_bl w"]
   apply (simp add: word_clz_def word_size to_bl_nth)
   apply (fastforce simp: linorder_not_less eq_zero_set_bl
                    dest: takeWhile_take_has_property)
   done
 
 lemma word_log2_nth_not_set:
   "\<lbrakk> word_log2 w < i ; i < size w \<rbrakk> \<Longrightarrow> \<not> w !! i"
   unfolding word_log2_def word_clz_def
   using takeWhile_take_has_property_nth[where P=Not and xs="to_bl w" and n="size w - Suc i"]
   by (fastforce simp add: to_bl_nth word_size)
 
 lemma word_log2_highest:
   assumes a: "w !! i"
   shows "i \<le> word_log2 w"
 proof -
   from a have "i < size w" by - (rule test_bit_size)
   with a show ?thesis
     by - (rule ccontr, simp add: word_log2_nth_not_set)
 qed
 
 lemma word_log2_max:
   "word_log2 w < size w"
   unfolding word_log2_def word_clz_def
   by simp
 
 lemma word_clz_0[simp]:
   "word_clz (0::'a::len word) = LENGTH('a)"
   unfolding word_clz_def
   by (simp add: takeWhile_replicate)
 
 lemma word_clz_minus_one[simp]:
   "word_clz (-1::'a::len word) = 0"
   unfolding word_clz_def
   by (simp add: takeWhile_replicate)
 
 lemma is_aligned_alignUp[simp]:
   "is_aligned (alignUp p n) n"
   by (simp add: alignUp_def is_aligned_mask mask_eq_decr_exp word_bw_assocs)
 
 lemma alignUp_le[simp]:
   "alignUp p n \<le> p + 2 ^ n - 1"
   unfolding alignUp_def by (rule word_and_le2)
 
 lemma alignUp_idem:
   fixes a :: "'a::len word"
   assumes "is_aligned a n" "n < LENGTH('a)"
   shows "alignUp a n = a"
   using assms unfolding alignUp_def
   by (metis mask_eq_decr_exp is_aligned_add_helper p_assoc_help power_2_ge_iff)
 
 lemma alignUp_not_aligned_eq:
   fixes a :: "'a :: len word"
   assumes al: "\<not> is_aligned a n"
   and     sz: "n < LENGTH('a)"
   shows   "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
 proof -
   have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz) fact+
 
   then have um: "unat (a mod 2 ^ n - 1) div 2 ^ n = 0" using sz
     by (meson Euclidean_Division.div_eq_0_iff le_m1_iff_lt measure_unat order_less_trans
               unat_less_power word_less_sub_le word_mod_less_divisor)
 
   have "a + 2 ^ n - 1 = (a div 2 ^ n) * 2 ^ n + (a mod 2 ^ n) + 2 ^ n - 1"
     by (simp add: word_mod_div_equality)
   also have "\<dots> = (a mod 2 ^ n - 1) + (a div 2 ^ n + 1) * 2 ^ n"
     by (simp add: field_simps)
   finally show "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n" using sz
     unfolding alignUp_def
     apply (subst mask_eq_decr_exp [symmetric])
     apply (erule ssubst)
     apply (subst neg_mask_is_div)
     apply (simp add: word_arith_nat_div)
     apply (subst unat_word_ariths(1) unat_word_ariths(2))+
     apply (subst uno_simps)
     apply (subst unat_1)
     apply (subst mod_add_right_eq)
     apply simp
     apply (subst power_mod_div)
     apply (subst div_mult_self1)
      apply simp
     apply (subst um)
     apply simp
     apply (subst mod_mod_power)
     apply simp
     apply (subst word_unat_power, subst Abs_fnat_hom_mult)
     apply (subst mult_mod_left)
     apply (subst power_add [symmetric])
     apply simp
     apply (subst Abs_fnat_hom_1)
     apply (subst Abs_fnat_hom_add)
     apply (subst word_unat_power, subst Abs_fnat_hom_mult)
     apply (subst word_unat.Rep_inverse[symmetric], subst Abs_fnat_hom_mult)
     apply simp
     done
 qed
 
 lemma alignUp_ge:
   fixes a :: "'a :: len word"
   assumes sz: "n < LENGTH('a)"
   and nowrap: "alignUp a n \<noteq> 0"
   shows "a \<le> alignUp a n"
 proof (cases "is_aligned a n")
   case True
   then show ?thesis using sz
     by (subst alignUp_idem, simp_all)
 next
   case False
 
   have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
     by (metis shiftr_div_2n' word_shiftr_lt)
 
   have"2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
     by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right lt0 nat_le_power_trans nat_less_le)
   moreover have "2 ^ n * (unat a div 2 ^ n + 1) \<noteq> 2 ^ LENGTH('a)" using nowrap sz
     apply -
     apply (erule contrapos_nn)
     apply (subst alignUp_not_aligned_eq [OF False sz])
     apply (subst unat_arith_simps)
     apply (subst unat_word_ariths)
     apply (subst unat_word_ariths)
     apply simp
     apply (subst mult_mod_left)
     apply (simp add: unat_div field_simps power_add[symmetric] mod_mod_power min.absorb2)
     done
   ultimately have lt: "2 ^ n * (unat a div 2 ^ n + 1) < 2 ^ LENGTH('a)" by simp
 
   have "a = a div 2 ^ n * 2 ^ n + a mod 2 ^ n" by (rule word_mod_div_equality [symmetric])
   also have "\<dots> < (a div 2 ^ n + 1) * 2 ^ n" using sz lt
     apply (simp add: field_simps)
     apply (rule word_add_less_mono1)
     apply (rule word_mod_less_divisor)
     apply (simp add: word_less_nat_alt)
     apply (subst unat_word_ariths)
     apply (simp add: unat_div)
     done
   also have "\<dots> =  alignUp a n"
     by (rule alignUp_not_aligned_eq [symmetric]) fact+
   finally show ?thesis by (rule order_less_imp_le)
 qed
 
 lemma alignUp_le_greater_al:
   fixes x :: "'a :: len word"
   assumes le: "a \<le> x"
   and     sz: "n < LENGTH('a)"
   and     al: "is_aligned x n"
   shows   "alignUp a n \<le> x"
 proof (cases "is_aligned a n")
   case True
   then show ?thesis using sz le by (simp add: alignUp_idem)
 next
   case False
 
   then have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz)
 
   from al obtain k where xk: "x = 2 ^ n * of_nat k" and kv: "k < 2 ^ (LENGTH('a) - n)"
     by (auto elim!: is_alignedE)
 
   then have kn: "unat (of_nat k :: 'a word) * unat ((2::'a word) ^ n) < 2 ^ LENGTH('a)"
     using sz
     apply (subst unat_of_nat_eq)
      apply (erule order_less_le_trans)
      apply simp
     apply (subst mult.commute)
     apply simp
     apply (rule nat_less_power_trans)
      apply simp
     apply simp
     done
 
   have au: "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
     by (rule alignUp_not_aligned_eq) fact+
   also have "\<dots> \<le> of_nat k * 2 ^ n"
   proof (rule word_mult_le_mono1 [OF inc_le _ kn])
     show "a div 2 ^ n < of_nat k" using kv xk le sz anz
       by (simp add: alignUp_div_helper)
 
     show "(0:: 'a word) < 2 ^ n" using sz by (simp add: p2_gt_0 sz)
   qed
 
   finally show ?thesis using xk by (simp add: field_simps)
 qed
 
 lemma alignUp_is_aligned_nz:
   fixes a :: "'a :: len word"
   assumes al: "is_aligned x n"
   and     sz: "n < LENGTH('a)"
   and     ax: "a \<le> x"
   and     az: "a \<noteq> 0"
   shows   "alignUp (a::'a :: len word) n \<noteq> 0"
 proof (cases "is_aligned a n")
   case True
   then have "alignUp a n = a" using sz by (simp add: alignUp_idem)
   then show ?thesis using az by simp
 next
   case False
   then have anz: "a mod 2 ^ n \<noteq> 0"
     by (rule not_aligned_mod_nz)
 
   {
     assume asm: "alignUp a n = 0"
 
     have lt0: "unat a div 2 ^ n < 2 ^ (LENGTH('a) - n)" using sz
       by (metis shiftr_div_2n' word_shiftr_lt)
 
     have leq: "2 ^ n * (unat a div 2 ^ n + 1) \<le> 2 ^ LENGTH('a)" using sz
       by (metis One_nat_def Suc_leI add.right_neutral add_Suc_right lt0 nat_le_power_trans
                 order_less_imp_le)
 
     from al obtain k where  kv: "k < 2 ^ (LENGTH('a) - n)" and xk: "x = 2 ^ n * of_nat k"
       by (auto elim!: is_alignedE)
 
     then have "a div 2 ^ n < of_nat k" using ax sz anz
       by (rule alignUp_div_helper)
 
     then have r: "unat a div 2 ^ n < k" using sz
       by (simp flip: drop_bit_eq_div unat_drop_bit_eq) (metis leI le_unat_uoi unat_mono)
 
     have "alignUp a n = (a div 2 ^ n + 1) * 2 ^ n"
       by (rule alignUp_not_aligned_eq) fact+
 
     then have "\<dots> = 0" using asm by simp
     then have "2 ^ LENGTH('a) dvd 2 ^ n * (unat a div 2 ^ n + 1)"
       using sz by (simp add: unat_arith_simps ac_simps)
                   (simp add: unat_word_ariths mod_simps mod_eq_0_iff_dvd)
     with leq have "2 ^ n * (unat a div 2 ^ n + 1) = 2 ^ LENGTH('a)"
       by (force elim!: le_SucE)
     then have "unat a div 2 ^ n = 2 ^ LENGTH('a) div 2 ^ n - 1"
       by (metis (no_types, hide_lams) Groups.add_ac(2) add.right_neutral
                 add_diff_cancel_left' div_le_dividend div_mult_self4 gr_implies_not0
                 le_neq_implies_less power_eq_0_iff zero_neq_numeral)
     then have "unat a div 2 ^ n = 2 ^ (LENGTH('a) - n) - 1"
       using sz by (simp add: power_sub)
     then have "2 ^ (LENGTH('a) - n) - 1 < k" using r
       by simp
     then have False using kv by simp
   } then show ?thesis by clarsimp
 qed
 
 lemma alignUp_ar_helper:
   fixes a :: "'a :: len word"
   assumes al: "is_aligned x n"
   and     sz: "n < LENGTH('a)"
   and    sub: "{x..x + 2 ^ n - 1} \<subseteq> {a..b}"
   and    anz: "a \<noteq> 0"
   shows "a \<le> alignUp a n \<and> alignUp a n + 2 ^ n - 1 \<le> b"
 proof
   from al have xl: "x \<le> x + 2 ^ n - 1" by (simp add: is_aligned_no_overflow)
 
   from xl sub have ax: "a \<le> x"
     by (clarsimp elim!: range_subset_lower [where x = x])
 
   show "a \<le> alignUp a n"
   proof (rule alignUp_ge)
     show "alignUp a n \<noteq> 0" using al sz ax anz
       by (rule alignUp_is_aligned_nz)
   qed fact+
 
   show "alignUp a n + 2 ^ n - 1 \<le> b"
   proof (rule order_trans)
     from xl show tp: "x + 2 ^ n - 1 \<le> b" using sub
       by (clarsimp elim!: range_subset_upper [where x = x])
 
     from ax have "alignUp a n \<le> x"
       by (rule alignUp_le_greater_al) fact+
     then have "alignUp a n + (2 ^ n - 1) \<le> x + (2 ^ n - 1)"
       using xl al is_aligned_no_overflow' olen_add_eqv word_plus_mcs_3 by blast
     then show "alignUp a n + 2 ^ n - 1 \<le> x + 2 ^ n - 1"
       by (simp add: field_simps)
   qed
 qed
 
 lemma alignUp_def2:
   "alignUp a sz = a + 2 ^ sz - 1 AND NOT (mask sz)"
   by (simp add: alignUp_def flip: mask_eq_decr_exp)
 
 lemma alignUp_def3:
   "alignUp a sz = 2^ sz + (a - 1 AND NOT (mask sz))"
   by (simp add: alignUp_def2 is_aligned_triv field_simps mask_out_add_aligned)
 
 lemma  alignUp_plus:
   "is_aligned w us \<Longrightarrow> alignUp (w + a) us  = w + alignUp a us"
   by (clarsimp simp: alignUp_def2 mask_out_add_aligned field_simps)
 
 lemma alignUp_distance:
   "alignUp (q :: 'a :: len word) sz - q \<le> mask sz"
   by (metis (no_types) add.commute add_diff_cancel_left alignUp_def2 diff_add_cancel
                        mask_2pm1 subtract_mask(2) word_and_le1 word_sub_le_iff)
 
 lemma is_aligned_diff_neg_mask:
   "is_aligned p sz \<Longrightarrow> (p - q AND NOT (mask sz)) = (p - ((alignUp q sz) AND NOT (mask sz)))"
   apply (clarsimp simp only:word_and_le2 diff_conv_add_uminus)
   apply (subst mask_out_add_aligned[symmetric]; simp)
   apply (rule sum_to_zero)
   apply (subst add.commute)
   apply (simp add: alignUp_distance is_aligned_neg_mask_eq mask_out_add_aligned)
   apply (metis add_cancel_right_right alignUp_distance and_mask_eq_iff_le_mask word_plus_and_or_coroll2)
   done
 
 lemma word_clz_max:
   "word_clz w \<le> size (w::'a::len word)"
   unfolding word_clz_def
   by (metis length_takeWhile_le word_size_bl)
 
 lemma word_clz_nonzero_max:
   fixes w :: "'a::len word"
   assumes nz: "w \<noteq> 0"
   shows "word_clz w < size (w::'a::len word)"
 proof -
   {
     assume a: "word_clz w = size (w::'a::len word)"
     hence "length (takeWhile Not (to_bl w)) = length (to_bl w)"
       by (simp add: word_clz_def word_size)
     hence allj: "\<forall>j\<in>set(to_bl w). \<not> j"
       by (metis a length_takeWhile_less less_irrefl_nat word_clz_def)
     hence "to_bl w = replicate (length (to_bl w)) False"
       by (fastforce intro!: list_of_false)
     hence "w = 0"
       by (metis to_bl_0 word_bl.Rep_eqD word_bl_Rep')
     with nz have False by simp
   }
   thus ?thesis using word_clz_max
     by (fastforce intro: le_neq_trans)
 qed
 
 (* Sign extension from bit n. *)
 
 lemma sign_extend_bitwise_if:
   "i < size w \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> (if i < e then w !! i else w !! e)"
   by (simp add: sign_extend_def neg_mask_test_bit word_size)
 
 lemma sign_extend_bitwise_if'  [word_eqI_simps]:
   \<open>i < LENGTH('a) \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> (if i < e then w !! i else w !! e)\<close>
   for w :: \<open>'a::len word\<close>
   using sign_extend_bitwise_if [of i w e] by (simp add: word_size)
 
 lemma sign_extend_bitwise_disj:
   "i < size w \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> i \<le> e \<and> w !! i \<or> e \<le> i \<and> w !! e"
   by (auto simp: sign_extend_bitwise_if)
 
 lemma sign_extend_bitwise_cases:
   "i < size w \<Longrightarrow> sign_extend e w !! i \<longleftrightarrow> (i \<le> e \<longrightarrow> w !! i) \<and> (e \<le> i \<longrightarrow> w !! e)"
   by (auto simp: sign_extend_bitwise_if)
 
 lemmas sign_extend_bitwise_disj' = sign_extend_bitwise_disj[simplified word_size]
 lemmas sign_extend_bitwise_cases' = sign_extend_bitwise_cases[simplified word_size]
 
 (* Often, it is easier to reason about an operation which does not overwrite
    the bit which determines which mask operation to apply. *)
 lemma sign_extend_def':
   "sign_extend n w = (if w !! n then w OR NOT (mask (Suc n)) else w AND mask (Suc n))"
   by (rule bit_word_eqI) (auto simp add: bit_simps sign_extend_eq_signed_take_bit min_def test_bit_eq_bit less_Suc_eq_le)
 
 lemma sign_extended_sign_extend:
   "sign_extended n (sign_extend n w)"
   by (clarsimp simp: sign_extended_def word_size sign_extend_bitwise_if)
 
 lemma sign_extended_iff_sign_extend:
   "sign_extended n w \<longleftrightarrow> sign_extend n w = w"
   apply auto
    apply (auto simp add: bit_eq_iff)
     apply (simp_all add: bit_simps sign_extend_eq_signed_take_bit not_le min_def sign_extended_def test_bit_eq_bit word_size split: if_splits)
   using le_imp_less_or_eq apply auto[1]
    apply (metis bit_imp_le_length nat_less_le)
   apply (metis Suc_leI Suc_n_not_le_n le_trans nat_less_le)
   done
 
 lemma sign_extended_weaken:
   "sign_extended n w \<Longrightarrow> n \<le> m \<Longrightarrow> sign_extended m w"
   unfolding sign_extended_def by (cases "n < m") auto
 
 lemma sign_extend_sign_extend_eq:
   "sign_extend m (sign_extend n w) = sign_extend (min m n) w"
   by (rule bit_word_eqI) (simp add: sign_extend_eq_signed_take_bit bit_simps)
 
 lemma sign_extended_high_bits:
   "\<lbrakk> sign_extended e p; j < size p; e \<le> i; i < j \<rbrakk> \<Longrightarrow> p !! i = p !! j"
   by (drule (1) sign_extended_weaken; simp add: sign_extended_def)
 
 lemma sign_extend_eq:
   "w AND mask (Suc n) = v AND mask (Suc n) \<Longrightarrow> sign_extend n w = sign_extend n v"
   by (simp flip: take_bit_eq_mask add: sign_extend_eq_signed_take_bit signed_take_bit_eq_iff_take_bit_eq)
 
 lemma sign_extended_add:
   assumes p: "is_aligned p n"
   assumes f: "f < 2 ^ n"
   assumes e: "n \<le> e"
   assumes "sign_extended e p"
   shows "sign_extended e (p + f)"
 proof (cases "e < size p")
   case True
   note and_or = is_aligned_add_or[OF p f]
   have "\<not> f !! e"
     using True e less_2p_is_upper_bits_unset[THEN iffD1, OF f]
     by (fastforce simp: word_size)
   hence i: "(p + f) !! e = p !! e"
     by (simp add: and_or)
   have fm: "f AND mask e = f"
     by (fastforce intro: subst[where P="\<lambda>f. f AND mask e = f", OF less_mask_eq[OF f]]
                   simp: mask_twice e)
   show ?thesis
     using assms
      apply (simp add: sign_extended_iff_sign_extend sign_extend_def i)
      apply (simp add: and_or word_bw_comms[of p f])
      apply (clarsimp simp: word_ao_dist fm word_bw_assocs split: if_splits)
     done
 next
   case False thus ?thesis
     by (simp add: sign_extended_def word_size)
 qed
 
 lemma sign_extended_neq_mask:
   "\<lbrakk>sign_extended n ptr; m \<le> n\<rbrakk> \<Longrightarrow> sign_extended n (ptr AND NOT (mask m))"
   by (fastforce simp: sign_extended_def word_size neg_mask_test_bit)
 
 definition
   "limited_and (x :: 'a :: len word) y \<longleftrightarrow> (x AND y = x)"
 
 lemma limited_and_eq_0:
   "\<lbrakk> limited_and x z; y AND NOT z = y \<rbrakk> \<Longrightarrow> x AND y = 0"
   unfolding limited_and_def
   apply (subst arg_cong2[where f="(AND)"])
     apply (erule sym)+
   apply (simp(no_asm) add: word_bw_assocs word_bw_comms word_bw_lcs)
   done
 
 lemma limited_and_eq_id:
   "\<lbrakk> limited_and x z; y AND z = z \<rbrakk> \<Longrightarrow> x AND y = x"
   unfolding limited_and_def
   by (erule subst, fastforce simp: word_bw_lcs word_bw_assocs word_bw_comms)
 
 lemma lshift_limited_and:
   "limited_and x z \<Longrightarrow> limited_and (x << n) (z << n)"
   unfolding limited_and_def
   by (simp add: shiftl_over_and_dist[symmetric])
 
 lemma rshift_limited_and:
   "limited_and x z \<Longrightarrow> limited_and (x >> n) (z >> n)"
   unfolding limited_and_def
   by (simp add: shiftr_over_and_dist[symmetric])
 
 lemmas limited_and_simps1 = limited_and_eq_0 limited_and_eq_id
 
 lemmas is_aligned_limited_and
     = is_aligned_neg_mask_eq[unfolded mask_eq_decr_exp, folded limited_and_def]
 
 lemmas limited_and_simps = limited_and_simps1
        limited_and_simps1[OF is_aligned_limited_and]
        limited_and_simps1[OF lshift_limited_and]
        limited_and_simps1[OF rshift_limited_and]
        limited_and_simps1[OF rshift_limited_and, OF is_aligned_limited_and]
        not_one shiftl_shiftr1[unfolded word_size mask_eq_decr_exp]
        shiftl_shiftr2[unfolded word_size mask_eq_decr_exp]
 
 definition
   from_bool :: "bool \<Rightarrow> 'a::len word" where
   "from_bool b \<equiv> case b of True \<Rightarrow> of_nat 1
                          | False \<Rightarrow> of_nat 0"
 
 lemma from_bool_eq:
   \<open>from_bool = of_bool\<close>
   by (simp add: fun_eq_iff from_bool_def)
 
 lemma from_bool_0:
   "(from_bool x = 0) = (\<not> x)"
   by (simp add: from_bool_def split: bool.split)
 
 lemma from_bool_eq_if':
   "((if P then 1 else 0) = from_bool Q) = (P = Q)"
   by (cases Q) (simp_all add: from_bool_def)
 
 definition
   to_bool :: "'a::len word \<Rightarrow> bool" where
   "to_bool \<equiv> (\<noteq>) 0"
 
 lemma to_bool_and_1:
   "to_bool (x AND 1) = (x !! 0)"
   by (simp add: test_bit_word_eq to_bool_def and_one_eq mod_2_eq_odd)
 
 lemma to_bool_from_bool [simp]:
   "to_bool (from_bool r) = r"
   unfolding from_bool_def to_bool_def
   by (simp split: bool.splits)
 
 lemma from_bool_neq_0 [simp]:
   "(from_bool b \<noteq> 0) = b"
   by (simp add: from_bool_def split: bool.splits)
 
 lemma from_bool_mask_simp [simp]:
   "(from_bool r :: 'a::len word) AND 1 = from_bool r"
   unfolding from_bool_def
   by (clarsimp split: bool.splits)
 
 lemma from_bool_1 [simp]:
   "(from_bool P = 1) = P"
   by (simp add: from_bool_def split: bool.splits)
 
 lemma ge_0_from_bool [simp]:
   "(0 < from_bool P) = P"
   by (simp add: from_bool_def split: bool.splits)
 
 lemma limited_and_from_bool:
   "limited_and (from_bool b) 1"
   by (simp add: from_bool_def limited_and_def split: bool.split)
 
 lemma to_bool_1 [simp]: "to_bool 1" by (simp add: to_bool_def)
 lemma to_bool_0 [simp]: "\<not>to_bool 0" by (simp add: to_bool_def)
 
 lemma from_bool_eq_if:
   "(from_bool Q = (if P then 1 else 0)) = (P = Q)"
   by (cases Q) (simp_all add: from_bool_def)
 
 lemma to_bool_eq_0:
   "(\<not> to_bool x) = (x = 0)"
   by (simp add: to_bool_def)
 
 lemma to_bool_neq_0:
   "(to_bool x) = (x \<noteq> 0)"
   by (simp add: to_bool_def)
 
 lemma from_bool_all_helper:
   "(\<forall>bool. from_bool bool = val \<longrightarrow> P bool)
       = ((\<exists>bool. from_bool bool = val) \<longrightarrow> P (val \<noteq> 0))"
   by (auto simp: from_bool_0)
 
 lemma fold_eq_0_to_bool:
   "(v = 0) = (\<not> to_bool v)"
   by (simp add: to_bool_def)
 
 lemma from_bool_to_bool_iff:
   "w = from_bool b \<longleftrightarrow> to_bool w = b \<and> (w = 0 \<or> w = 1)"
   by (cases b) (auto simp: from_bool_def to_bool_def)
 
 lemma from_bool_eqI:
   "from_bool x = from_bool y \<Longrightarrow> x = y"
   unfolding from_bool_def
   by (auto split: bool.splits)
 
 end
\ No newline at end of file
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,1965 +1,2094 @@
 (*  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>uint (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 (simp add: to_bl_unfold rev_map)
 
 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)
 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)
 
 end