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,1652 @@
 (*
     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, 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, 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)
+        apply (auto simp add: le_less)
+       apply (metis linorder_neqE_linordered_idom mod_pos_pos_trivial not_take_bit_negative power_0 take_bit_0 take_bit_eq_mod take_bit_nonnegative)
+      apply (metis even_take_bit_eq mod_pos_pos_trivial neq0_conv numeral_eq_Suc power_0 take_bit_eq_mod take_bit_nonnegative zero_less_Suc)
       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/Markov_Models/Continuous_Time_Markov_Chain.thy b/thys/Markov_Models/Continuous_Time_Markov_Chain.thy
--- a/thys/Markov_Models/Continuous_Time_Markov_Chain.thy
+++ b/thys/Markov_Models/Continuous_Time_Markov_Chain.thy
@@ -1,1464 +1,1464 @@
 (* Author: Johannes Hölzl <hoelzl@in.tum.de> *)
 
 section \<open>Continuous-time Markov chains\<close>
 
 theory Continuous_Time_Markov_Chain
   imports Discrete_Time_Markov_Process Discrete_Time_Markov_Chain
 begin
 
 subsection \<open>Trace Operations: relate @{typ "('a \<times> real) stream"} and @{typ "real \<Rightarrow> 'a"}\<close>
 
 partial_function (tailrec) trace_at :: "'a \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> real \<Rightarrow> 'a"
 where
   "trace_at s \<omega> j = (case \<omega> of (t', s')##\<omega> \<Rightarrow> if t' \<le> j then trace_at s' \<omega> j else s)"
 
 lemma trace_at_simp[simp]: "trace_at s ((t', s')##\<omega>) j = (if t' \<le> j then trace_at s' \<omega> j else s)"
   by (subst trace_at.simps) simp
 
 lemma trace_at_eq:
   "trace_at s \<omega> j = (case sfirst (\<lambda>x. j < fst (shd x)) \<omega> of \<infinity> \<Rightarrow> undefined | enat i \<Rightarrow> (s ## smap snd \<omega>) !! i)"
 proof (split enat.split; safe)
   assume "sfirst (\<lambda>x. j < fst (shd x)) \<omega> = \<infinity>"
   with sfirst_finite[of "\<lambda>x. j < fst (shd x)" \<omega>]
   have "alw (\<lambda>x. fst (shd x) \<le> j) \<omega>"
     by (simp add: not_ev_iff not_less)
   then show "trace_at s \<omega> j = undefined"
     by (induction arbitrary: s \<omega> rule: trace_at.fixp_induct) (auto split: stream.split)
 next
   show "sfirst (\<lambda>x. j < fst (shd x)) \<omega> = enat n \<Longrightarrow> trace_at s \<omega> j = (s ## smap snd \<omega>) !! n" for n
   proof (induction n arbitrary: s \<omega>)
     case 0 then show ?case
       by (subst trace_at.simps) (auto simp add: enat_0 sfirst_eq_0 split: stream.split)
   next
     case (Suc n) show ?case
       using sfirst.simps[of "\<lambda>x. j < fst (shd x)" \<omega>] Suc.prems Suc.IH[of "stl \<omega>" "snd (shd \<omega>)"]
       by (cases \<omega>) (auto simp add: eSuc_enat[symmetric] split: stream.split if_split_asm)
   qed
 qed
 
 lemma trace_at_shift: "trace_at s (smap (\<lambda>(t, s'). (t + t', s')) \<omega>) t = trace_at s \<omega> (t - t')"
   by (induction arbitrary: s \<omega> rule: trace_at.fixp_induct) (auto split: stream.split)
 
 primcorec merge_at :: "(real \<times> 'a) stream \<Rightarrow> real \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> (real \<times> 'a) stream"
 where
   "merge_at \<omega> j \<omega>' = (case \<omega> of (t, s) ## \<omega> \<Rightarrow> if t \<le> j then (t, s)##merge_at \<omega> j \<omega>' else \<omega>')"
 
 lemma merge_at_simp[simp]: "merge_at (x##\<omega>) j \<omega>' = (if fst x \<le> j then x##merge_at \<omega> j \<omega>' else \<omega>')"
   by (cases x) (subst merge_at.code; simp)
 
 subsection \<open>Exponential Distribution\<close>
 
 definition exponential :: "real \<Rightarrow> real measure"
 where
   "exponential l = density lborel (exponential_density l)"
 
 lemma space_exponential: "space (exponential l) = UNIV"
   by (simp add: exponential_def)
 
 lemma sets_exponential[measurable_cong]: "sets (exponential l) = sets borel"
   by (simp add: exponential_def)
 
 lemma prob_space_exponential: "0 < l \<Longrightarrow> prob_space (exponential l)"
   unfolding exponential_def by (intro prob_space_exponential_density)
 
 lemma AE_exponential: "0 < l \<Longrightarrow> AE x in exponential l. 0 < x"
   unfolding exponential_def using AE_lborel_singleton[of 0] by (auto simp add: AE_density exponential_density_def)
 
 lemma emeasure_exponential_Ioi_cutoff:
   assumes "0 < l"
   shows "emeasure (exponential l) {x <..} = exp (- (max 0 x) * l)"
 proof -
   interpret prob_space "exponential l"
     unfolding exponential_def using \<open>0<l\<close> by (rule prob_space_exponential_density)
   have *: "prob {xa \<in> space (exponential l). max 0 x < xa} = exp (- max 0 x * l)"
     apply (rule exponential_distributedD_gt[OF _ _ \<open>0<l\<close>])
     apply (auto simp: exponential_def distributed_def)
     apply (subst (6) distr_id[symmetric])
     apply (subst (2) distr_cong)
     apply simp_all
     done
   have "emeasure (exponential l) {x <..} = emeasure (exponential l) {max 0 x <..}"
     using AE_exponential[OF \<open>0<l\<close>] by (intro emeasure_eq_AE) auto
   also have "\<dots> = exp (- (max 0 x) * l)"
     using * unfolding emeasure_eq_measure by (simp add: space_exponential greaterThan_def)
   finally show ?thesis .
 qed
 
 lemma emeasure_exponential_Ioi:
   "0 < l \<Longrightarrow> 0 \<le> x \<Longrightarrow> emeasure (exponential l) {x <..} = exp (- x * l)"
   using emeasure_exponential_Ioi_cutoff[of l x] by simp
 
 lemma exponential_eq_stretch:
   assumes "0 < l"
   shows "exponential l = distr (exponential 1) borel (\<lambda>x. (1/l) * x)"
 proof (intro measure_eqI)
   fix A assume "A \<in> sets (exponential l)"
   then have [measurable]: "A \<in> sets borel"
     by (simp add: sets_exponential)
   then have [measurable]: "(\<lambda>x. x / l) -` A \<in> sets borel"
     by (rule measurable_sets_borel[rotated]) simp
   have "emeasure (exponential l) A =
     (\<integral>\<^sup>+x. ennreal l * (indicator (((*) (1/l) -` A) \<inter> {0 ..}) (l * x) * ennreal (exp (- (l * x)))) \<partial>lborel)"
     using \<open>0 < l\<close>
     by (auto simp: ac_simps emeasure_distr exponential_def emeasure_density exponential_density_def
                    ennreal_mult zero_le_mult_iff
              intro!: nn_integral_cong split: split_indicator)
   also have "\<dots> = (\<integral>\<^sup>+x. indicator (((*) (1/l) -` A) \<inter> {0 ..}) x * ennreal (exp (- x)) \<partial>lborel)"
     using \<open>0<l\<close>
     apply (subst nn_integral_stretch)
       apply (auto simp: nn_integral_cmult)
     apply (simp add: ennreal_mult[symmetric] mult.assoc[symmetric])
     done
   also have "\<dots> = emeasure (distr (exponential 1) borel (\<lambda>x. (1/l) * x)) A"
     by (auto simp add: emeasure_distr exponential_def emeasure_density exponential_density_def
         intro!: nn_integral_cong split: split_indicator)
   finally show "emeasure (exponential l) A = emeasure (distr (exponential 1) borel (\<lambda>x. (1/l) * x)) A" .
 qed (simp add: sets_exponential)
 
 lemma uniform_measure_exponential:
   assumes "0 < l" "0 \<le> t"
   shows "uniform_measure (exponential l) {t <..} = distr (exponential l) borel ((+) t)" (is "?L = ?R")
 proof (rule measure_eqI_lessThan)
   fix x
   have "0 < emeasure (exponential l) {t<..}"
     unfolding emeasure_exponential_Ioi[OF assms] by simp
   with assms show "?L {x<..} < \<infinity>"
     by (simp add: ennreal_divide_eq_top_iff less_top[symmetric] lessThan_Int_lessThan
       emeasure_exponential_Ioi)
   have *: "((+) t -` {x<..} \<inter> space (exponential l)) = {x - t <..}"
     by (auto simp: space_exponential)
   show "?L {x<..} = ?R {x<..}"
     using assms by (simp add: lessThan_Int_lessThan emeasure_exponential_Ioi divide_ennreal
       emeasure_distr * emeasure_exponential_Ioi_cutoff exp_diff[symmetric] field_simps split: split_max)
 qed (auto simp: sets_exponential)
 
 lemma emeasure_PiM_exponential_Ioi_finite:
   assumes "J \<subseteq> I" "finite J" "\<And>i. i \<in> I \<Longrightarrow> 0 < R i" "0 \<le> x"
   shows "emeasure (\<Pi>\<^sub>M i\<in>I. exponential (R i)) (prod_emb I (\<lambda>i. exponential (R i)) J (\<Pi>\<^sub>E j\<in>J. {x<..})) = exp (- x * (\<Sum>i\<in>J. R i))"
 proof (subst emeasure_PiM_emb)
   from assms show "(\<Prod>i\<in>J. emeasure (exponential (R i)) {x<..}) = ennreal (exp (- x * sum R J))"
     by (subst prod.cong[OF refl emeasure_exponential_Ioi])
        (auto simp add: prod_ennreal exp_sum sum_negf[symmetric] sum_distrib_left)
 qed (insert assms, auto intro!: prob_space_exponential)
 
 lemma emeasure_PiM_exponential_Ioi_sequence:
   assumes R: "summable R" "\<And>i. 0 < R i" "0 \<le> x"
   shows "emeasure (\<Pi>\<^sub>M i\<in>UNIV. exponential (R i)) (\<Pi> i\<in>UNIV. {x<..}) = exp (- x * suminf R)"
 proof -
   let ?R = "\<lambda>i. exponential (R i)" let ?P = "\<Pi>\<^sub>M i\<in>UNIV. ?R i"
   let ?N = "\<lambda>n::nat. prod_emb UNIV ?R {..<n} (\<Pi>\<^sub>E i\<in>{..<n}. {x<..})"
   interpret prob_space ?P
     by (intro prob_space_PiM prob_space_exponential R)
   have "(\<Pi>\<^sub>M i\<in>UNIV. exponential (R i)) (\<Inter>n. ?N n) = (INF n. (\<Pi>\<^sub>M i\<in>UNIV. exponential (R i)) (?N n))"
     by (intro INF_emeasure_decseq[symmetric] decseq_emb_PiE) (auto simp: incseq_def)
   also have "\<dots> = (INF n. ennreal (exp (- x * (\<Sum>i<n. R i))))"
     using R by (intro INF_cong emeasure_PiM_exponential_Ioi_finite) auto
   also have "\<dots> = ennreal (exp (- x * (SUP n. (\<Sum>i<n. R i))))"
     using R
     by (subst continuous_at_Sup_antimono[where f="\<lambda>r. ennreal (exp (- x * r))"])
        (auto intro!: bdd_aboveI2[where M="\<Sum>i. R i"] sum_le_suminf summable_mult mult_left_mono
                      continuous_mult continuous_at_ennreal continuous_within_exp[THEN continuous_within_compose3] continuous_minus
              simp: less_imp_le antimono_def image_comp)
   also have "\<dots> = ennreal (exp (- x * (\<Sum>i. R i)))"
     using R by (subst suminf_eq_SUP_real) (auto simp: less_imp_le)
   also have "(\<Inter>n. ?N n) = (\<Pi> i\<in>UNIV. {x<..})"
     by (fastforce simp: prod_emb_def Pi_iff PiE_iff space_exponential)
   finally show ?thesis
     using R by simp
 qed
 
 lemma emeasure_PiM_exponential_Ioi_countable:
   assumes R: "J \<subseteq> I" "countable J" "\<And>i. i \<in> I \<Longrightarrow> 0 < R i" "0 \<le> x" and finite: "integrable (count_space J) R"
   shows "emeasure (\<Pi>\<^sub>M i\<in>I. exponential (R i)) (prod_emb I (\<lambda>i. exponential (R i)) J (\<Pi>\<^sub>E j\<in>J. {x<..})) =
     exp (- x * (LINT i|count_space J. R i))"
 proof cases
   assume "finite J" with assms show ?thesis
     by (subst emeasure_PiM_exponential_Ioi_finite)
        (auto simp: lebesgue_integral_count_space_finite)
 next
   assume "infinite J"
   let ?R = "\<lambda>i. exponential (R i)" let ?P = "\<Pi>\<^sub>M i\<in>I. ?R i"
   define f where "f = from_nat_into J"
   have J_eq: "J = range f" and f: "inj f" "f \<in> UNIV \<rightarrow> I"
     using from_nat_into_inj_infinite[of J] range_from_nat_into[of J] \<open>countable J\<close> \<open>infinite J\<close> \<open>J \<subseteq> I\<close>
     by (auto simp: inj_on_def f_def simp del: range_from_nat_into)
   have Bf: "bij_betw f UNIV J"
     unfolding J_eq using inj_on_imp_bij_betw[OF f(1)] .
 
   have summable_R: "summable (\<lambda>i. R (f i))"
     using finite unfolding integrable_bij_count_space[OF Bf, symmetric] integrable_count_space_nat_iff
     by (rule summable_norm_cancel)
 
   have "emeasure (\<Pi>\<^sub>M i\<in>UNIV. exponential (R (f i))) (\<Pi> i\<in>UNIV. {x<..}) = exp (- x * (\<Sum>i. R (f i)))"
     using finite assms unfolding J_eq by (intro emeasure_PiM_exponential_Ioi_sequence[OF summable_R]) auto
   also have "(\<Pi>\<^sub>M i\<in>UNIV. exponential (R (f i))) = distr ?P (\<Pi>\<^sub>M i\<in>UNIV. exponential (R (f i))) (\<lambda>\<omega>. \<lambda>i\<in>UNIV. \<omega> (f i))"
     using R by (intro distr_PiM_reindex[symmetric, OF _ f] prob_space_exponential) auto
   also have "\<dots> (\<Pi> i\<in>UNIV. {x<..}) = ?P ((\<lambda>\<omega>. \<lambda>i\<in>UNIV. \<omega> (f i)) -` (\<Pi> i\<in>UNIV. {x<..}) \<inter> space ?P)"
     using f(2) by (intro emeasure_distr infprod_in_sets) (auto simp: Pi_iff)
   also have "(\<lambda>\<omega>. \<lambda>i\<in>UNIV. \<omega> (f i)) -` (\<Pi> i\<in>UNIV. {x<..}) \<inter> space ?P = prod_emb I ?R J (\<Pi>\<^sub>E j\<in>J. {x<..})"
     by (auto simp: prod_emb_def space_PiM space_exponential Pi_iff J_eq)
   also have "(\<Sum>i. R (f i)) = (LINT i|count_space J. R i)"
     using finite
     by (subst integral_count_space_nat[symmetric])
        (auto simp: integrable_bij_count_space[OF Bf] integral_bij_count_space[OF Bf])
   finally show ?thesis .
 qed
 
 lemma AE_PiM_exponential_suminf_infty:
   fixes R :: "nat \<Rightarrow> real"
   assumes R: "\<And>n. 0 < R n" and finite: "(\<Sum>n. ennreal (1 / R n)) = top"
   shows "AE \<omega> in \<Pi>\<^sub>M n\<in>UNIV. exponential (R n). (\<Sum>n. ereal (\<omega> n)) = \<infinity>"
 proof -
   let ?P = "\<Pi>\<^sub>M n\<in>UNIV. exponential (R n)"
   interpret prob_space "exponential (R n)" for n
     by (intro prob_space_exponential R)
   interpret product_prob_space "\<lambda>n. exponential (R n)" UNIV
     proof qed
 
   have AE_pos: "AE \<omega> in ?P. \<forall>i. 0 < \<omega> i"
     unfolding AE_all_countable by (intro AE_PiM_component allI prob_space_exponential R AE_exponential) simp
 
   have indep: "indep_vars (\<lambda>i. borel) (\<lambda>i x. x i) UNIV"
     using PiM_component
     apply (subst P.indep_vars_iff_distr_eq_PiM)
      apply (auto simp: restrict_UNIV distr_id2)
     apply (subst distr_id2)
      apply (intro sets_PiM_cong)
       apply (auto simp: sets_exponential cong: distr_cong)
     done
 
   have [simp]: "0 \<le> x + x * R i \<longleftrightarrow> 0 \<le> x" for x i
     using zero_le_mult_iff[of x "1 + R i"] R[of i] by (simp add: field_simps)
 
   have "(\<integral>\<^sup>+\<omega>. eexp (\<Sum>n. - ereal (\<omega> n)) \<partial>?P) = (\<integral>\<^sup>+\<omega>. (INF n. \<Prod>i<n. eexp (- ereal (\<omega> i))) \<partial>?P)"
   proof (intro nn_integral_cong_AE, use AE_pos in eventually_elim)
     fix \<omega> :: "nat \<Rightarrow> real" assume \<omega>: "\<forall>i. 0 < \<omega> i"
     show "eexp (\<Sum>n. - ereal (\<omega> n)) = (\<Sqinter>n. \<Prod>i<n. eexp (- ereal (\<omega> i)))"
     proof (rule LIMSEQ_unique[OF _ LIMSEQ_INF])
       show "(\<lambda>i. \<Prod>i<i. eexp (- ereal (\<omega> i))) \<longlonglongrightarrow> eexp (\<Sum>n. - ereal (\<omega> n))"
         using \<omega> by (intro eexp_suminf summable_minus_ereal summable_ereal_pos) (auto intro: less_imp_le)
       show "decseq (\<lambda>n. \<Prod>i<n. eexp (- ereal (\<omega> i)))"
         using \<omega> by (auto simp: decseq_def intro!: prod_mono3 intro: less_imp_le)
     qed
   qed
   also have "\<dots> = (INF n. (\<integral>\<^sup>+\<omega>. (\<Prod>i<n. eexp (- ereal (\<omega> i))) \<partial>?P))"
   proof (intro nn_integral_monotone_convergence_INF_AE')
     show "AE \<omega> in ?P. (\<Prod>i<Suc n. eexp (- ereal (\<omega> i))) \<le> (\<Prod>i<n. eexp (- ereal (\<omega> i)))" for n
       using AE_pos
     proof eventually_elim
       case (elim \<omega>)
       show ?case
         by (rule prod_mono3) (auto simp: elim le_less)
     qed
   qed (auto simp: less_top[symmetric])
   also have "\<dots> = (INF n. (\<Prod>i<n. (\<integral>\<^sup>+\<omega>. eexp (- ereal (\<omega> i)) \<partial>?P)))"
   proof (intro INF_cong refl indep_vars_nn_integral)
     show "indep_vars (\<lambda>_. borel) (\<lambda>i \<omega>. eexp (- ereal (\<omega> i))) {..<n}" for n
     proof (rule indep_vars_compose2[of _ _ _ "\<lambda>i x. eexp(- ereal x)"])
       show "indep_vars (\<lambda>i. borel) (\<lambda>i x. x i) {..<n}"
         by (rule indep_vars_subset[OF indep]) auto
     qed auto
   qed auto
   also have "\<dots> = (INF n. (\<Prod>i<n. R i * (\<integral>\<^sup>+x. indicator {0 ..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) \<partial>lborel)))"
     by (subst product_nn_integral_component)
        (auto simp: field_simps exponential_def nn_integral_density ennreal_mult'[symmetric] ennreal_mult''[symmetric]
                    exponential_density_def exp_diff exp_minus nn_integral_cmult[symmetric]
              intro!: INF_cong prod.cong nn_integral_cong split: split_indicator)
   also have "\<dots> = (INF n. (\<Prod>i<n. ennreal (R i / (1 + R i))))"
   proof (intro INF_cong prod.cong refl)
     show "R i * (\<integral>\<^sup>+ x. indicator {0..} ((1 + R i) * x) * ennreal (exp (- ((1 + R i) * x))) \<partial>lborel) =
       ennreal (R i / (1 + R i))" for i
       using nn_intergal_power_times_exp_Ici[of 0] \<open>0 < R i\<close>
       by (subst nn_integral_stretch[where c="1 + R i"])
          (auto simp: mult.assoc[symmetric] ennreal_mult''[symmetric] less_imp_le mult.commute)
   qed
   also have "\<dots> = (INF n. ennreal (\<Prod>i<n. R i / (1 + R i)))"
     using R by (intro INF_cong refl prod_ennreal divide_nonneg_nonneg) (auto simp: less_imp_le)
   also have "\<dots> = (INF n. ennreal (inverse (\<Prod>i<n. (1 + R i) / R i)))"
     by (subst prod_inversef[symmetric]) simp_all
   also have "\<dots> = (INF n. inverse (ennreal (\<Prod>i<n. (1 + R i) / R i)))"
     using R by (subst inverse_ennreal) (auto intro!: prod_pos divide_pos_pos simp: add_pos_pos)
   also have "\<dots> = inverse (SUP n. ennreal (\<Prod>i<n. (1 + R i) / R i))"
     by (subst continuous_at_Sup_antimono [where f = inverse])
       (auto simp: antimono_def image_comp intro!: continuous_on_imp_continuous_within[OF continuous_on_inverse_ennreal'])
   also have "(SUP n. ennreal (\<Prod>i<n. (1 + R i) / R i)) = top"
   proof (cases "SUP n. ennreal (\<Prod>i<n. (1 + R i) / R i)")
     case (real r)
     have "(\<lambda>n. ennreal (\<Prod>i<n. (1 + R i) / R i)) \<longlonglongrightarrow> r"
       using R unfolding real(2)[symmetric]
       by (intro LIMSEQ_SUP monoI ennreal_leI prod_mono2) (auto intro!: divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le)
     then have "(\<lambda>n. (\<Prod>i<n. (1 + R i) / R i)) \<longlonglongrightarrow> r"
       by (rule tendsto_ennrealD)
          (use R real in \<open>auto intro!: always_eventually prod_nonneg divide_nonneg_nonneg add_nonneg_nonneg intro: less_imp_le\<close>)
     moreover have "(1 + R i) / R i = 1 / R i + 1" for i
       using \<open>0 < R i\<close> by (auto simp: field_simps)
     ultimately have "convergent (\<lambda>n. \<Prod>i<n. 1 / R i + 1)"
       by (auto simp: convergent_def)
     then have "summable (\<lambda>i. 1 / R i)"
       using R by (subst summable_iff_convergent_prod) (auto intro: less_imp_le)
     moreover have "0 \<le> 1 / R i" for i
       using R by (auto simp: less_imp_le)
     ultimately show ?thesis
       using finite ennreal_suminf_neq_top[of "\<lambda>i. 1 / R i"] by blast
   qed
   finally have "(\<integral>\<^sup>+\<omega>. eexp (\<Sum>n. - ereal (\<omega> n)) \<partial>?P) = 0"
     by simp
   then have "AE \<omega> in ?P. eexp (\<Sum>n. - ereal (\<omega> n)) = 0"
     by (subst (asm) nn_integral_0_iff_AE) auto
   then show ?thesis
     using AE_pos
   proof eventually_elim
     show "(\<forall>i. 0 < \<omega> i) \<Longrightarrow> eexp (\<Sum>n. - ereal (\<omega> n)) = 0 \<Longrightarrow> (\<Sum>n. ereal (\<omega> n)) = \<infinity>" for \<omega>
       apply (auto simp del: uminus_ereal.simps simp add: uminus_ereal.simps[symmetric]
                   intro!: summable_iff_suminf_neq_top intro: less_imp_le)
       apply (subst (asm) suminf_minus_ereal)
       apply (auto intro!: summable_ereal_pos intro: less_imp_le)
       done
   qed
 qed
 
 subsection \<open>Transition Rates\<close>
 
 locale transition_rates =
   fixes R :: "'a \<Rightarrow> 'a \<Rightarrow> real"
   assumes R_nonneg[simp]: "\<And>x y. 0 \<le> R x y"
   assumes R_diagonal_0[simp]: "\<And>x. R x x = 0"
   assumes finite_weight: "\<And>x. (\<integral>\<^sup>+y. R x y \<partial>count_space UNIV) < \<infinity>"
   assumes positive_weight: "\<And>x. 0 < (\<integral>\<^sup>+y. R x y \<partial>count_space UNIV)"
 begin
 
 abbreviation S :: "(real \<times> 'a) measure"
 where "S \<equiv> (borel \<Otimes>\<^sub>M count_space UNIV)"
 
 abbreviation T :: "(real \<times> 'a) stream measure"
 where "T \<equiv> stream_space S"
 
 abbreviation I :: "'a \<Rightarrow> 'a set"
 where "I x \<equiv> {y. 0 < R x y}"
 
 lemma I_countable: "countable (I x)"
 proof -
   let ?P = "point_measure UNIV (R x)"
   interpret finite_measure ?P
   proof
     show "emeasure ?P (space ?P) \<noteq> \<infinity>"
       using finite_weight
       by (simp add: emeasure_density point_measure_def less_top)
   qed
   from countable_support emeasure_point_measure_finite2[of "{_}" UNIV "R x"]
   show ?thesis
     by (simp add: emeasure_eq_measure less_le)
 qed
 
 definition escape_rate :: "'a \<Rightarrow> real" where
   "escape_rate x = \<integral>y. R x y \<partial>count_space UNIV"
 
 lemma ennreal_escape_rate: "ennreal (escape_rate x) = (\<integral>\<^sup>+y. R x y \<partial>count_space UNIV)"
   using finite_weight[of x] unfolding escape_rate_def
   by (intro nn_integral_eq_integral[symmetric]) (auto simp: integrable_iff_bounded)
 
 lemma escape_rate_pos: "0 < escape_rate x"
   using positive_weight unfolding ennreal_escape_rate[symmetric] by simp
 
 lemma nonneg_escape_rate[simp]: "0 \<le> escape_rate x"
   using escape_rate_pos[THEN less_imp_le] .
 
 lemma prob_space_exponential_escape_rate: "prob_space (exponential (escape_rate x))"
   using escape_rate_pos by (rule prob_space_exponential)
 
 lemma measurable_escape_rate[measurable]: "escape_rate \<in> count_space UNIV \<rightarrow>\<^sub>M borel"
   by auto
 
 lemma measurable_exponential_escape_rate[measurable]: "(\<lambda>x. exponential (escape_rate x)) \<in> count_space UNIV \<rightarrow>\<^sub>M prob_algebra borel"
   by (auto simp: space_prob_algebra sets_exponential prob_space_exponential_escape_rate)
 
 interpretation pmf_as_function .
 
 lift_definition J :: "'a \<Rightarrow> 'a pmf" is "\<lambda>x y.  R x y / escape_rate x"
 proof safe
   show "0 \<le> R x y / escape_rate x" for x y
     by (auto intro!: integral_nonneg_AE divide_nonneg_nonneg R_nonneg simp: escape_rate_def)
   show "(\<integral>\<^sup>+y. R x y / escape_rate x \<partial>count_space UNIV) = 1" for x
     using escape_rate_pos[of x]
     by (auto simp add: divide_ennreal[symmetric] nn_integral_divide ennreal_escape_rate[symmetric] intro!: ennreal_divide_self)
 qed
 
 lemma set_pmf_J: "set_pmf (J x) = I x"
   using escape_rate_pos[of x] by (auto simp: set_pmf_iff J.rep_eq less_le)
 
 interpretation exp_esc: pair_prob_space "distr (exponential (escape_rate x)) borel ((+) t)" "J x" for x
 proof -
   interpret prob_space "distr (exponential (escape_rate x)) borel ((+) t)"
     by (intro prob_space.prob_space_distr prob_space_exponential_escape_rate) simp
   show "pair_prob_space (distr (exponential (escape_rate x)) borel ((+) t)) (measure_pmf (J x))"
     by standard
 qed
 
 subsection \<open>Continuous-time Kernel\<close>
 
 definition K :: "(real \<times> 'a) \<Rightarrow> (real \<times> 'a) measure" where
   "K = (\<lambda>(t, x). (distr (exponential (escape_rate x)) borel ((+) t)) \<Otimes>\<^sub>M J x)"
 
 interpretation K: discrete_Markov_process "borel \<Otimes>\<^sub>M count_space UNIV" K
 proof
   show "K \<in> borel \<Otimes>\<^sub>M count_space UNIV \<rightarrow>\<^sub>M prob_algebra (borel \<Otimes>\<^sub>M count_space UNIV)"
     unfolding K_def
     apply measurable
     apply (rule measurable_snd[THEN measurable_compose])
     apply (auto simp: space_prob_algebra prob_space_measure_pmf)
     done
 qed
 
 interpretation DTMC: MC_syntax J .
 
 lemma in_space_S[simp]: "x \<in> space S"
   by (simp add: space_pair_measure)
 
 lemma in_space_T[simp]: "x \<in> space T"
   by (simp add: space_pair_measure space_stream_space)
 
 lemma in_space_lim_stream: "\<omega> \<in> space (K.lim_stream x)"
   unfolding K.space_lim_stream space_stream_space[symmetric] by simp
 
 lemma prob_space_K_lim: "prob_space (K.lim_stream x)"
   using K.lim_stream[THEN measurable_space] by (simp add: space_prob_algebra)
 
 definition select_first :: "'a \<Rightarrow> ('a \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow> bool"
 where "select_first x p y = (y \<in> I x \<and> (\<forall>y'\<in>I x - {y}. p y < p y'))"
 
 lemma select_firstD1: "select_first x p y \<Longrightarrow> y \<in> I x"
   by (simp add: select_first_def)
 
 lemma select_first_unique:
   assumes y: "select_first x p y1" " select_first x p y2" shows "y1 = y2"
 proof -
   have "y1 \<noteq> y2 \<Longrightarrow> p y1 < p y2" "y1 \<noteq> y2 \<Longrightarrow> p y2 < p y1"
     using y by (auto simp: select_first_def)
   then show "y1 = y2"
     by (rule_tac ccontr) auto
 qed
 
 lemma The_select_first[simp]: "select_first x p y \<Longrightarrow> The (select_first x p) = y"
   by (intro the_equality select_first_unique)
 
 lemma select_first_INF:
   "select_first x p y \<Longrightarrow> (INF x\<in>I x. p x) = p y"
   by (intro antisym cINF_greatest cINF_lower bdd_belowI2[where m="p y"])
      (auto simp: select_first_def le_less)
 
 lemma measurable_select_first[measurable]:
   "(\<lambda>p. select_first x p y) \<in> (\<Pi>\<^sub>M y\<in>I x. borel) \<rightarrow>\<^sub>M count_space UNIV"
   using I_countable unfolding select_first_def by (intro measurable_pred_countable pred_intros_conj1') measurable
 
 lemma measurable_THE_select_first[measurable]:
   "(\<lambda>p. The (select_first x p)) \<in> (\<Pi>\<^sub>M y\<in>I x. borel) \<rightarrow>\<^sub>M count_space UNIV"
   by (rule measurable_THE) (auto intro: select_first_unique I_countable dest: select_firstD1)
 
 lemma sets_S_eq: "sets S = sigma_sets UNIV { {t ..} \<times> A | t A. A \<subseteq> - I x \<or> (\<exists>s\<in>I x. A = {s}) }"
 proof (subst sets_pair_eq)
   let ?CI = "\<lambda>a::real. {a ..}" let ?Ea = "range ?CI"
 
   show "?Ea \<subseteq> Pow (space borel)" "sets borel = sigma_sets (space borel) ?Ea"
     unfolding borel_Ici by auto
   show "?CI`Rats \<subseteq> ?Ea" "(\<Union>i\<in>Rats. ?CI i) = space borel"
     using Rats_dense_in_real[of "x - 1" "x" for x] by (auto intro: less_imp_le)
 
   let ?Eb = "Pow (- I x) \<union> (\<lambda>s. {s}) ` I x"
   have "b \<in> sigma_sets UNIV (Pow (- I x) \<union> (\<lambda>s. {s}) ` I x)" for b
   proof -
     have "b = (b - I x) \<union> (\<Union>x\<in>b \<inter> I x. {x})"
       by auto
     also have "\<dots> \<in> sigma UNIV (Pow (- I x) \<union> (\<lambda>s. {s}) ` I x)"
       using I_countable by (intro sets.Un sets.countable_UN') auto
     finally show ?thesis
       by simp
   qed
   then show "sets (count_space UNIV) = sigma_sets (space (count_space UNIV)) ?Eb"
     by auto
   show "countable ({- I x} \<union> (\<Union>s\<in>I x. {{s}}))"
     using I_countable by auto
   show "sets (sigma (space borel \<times> space (count_space UNIV)) {a \<times> b |a b. a \<in> ?Ea \<and> b \<in> ?Eb}) =
     sigma_sets UNIV {{t ..} \<times> A |t A. A \<subseteq> - I x \<or> (\<exists>s\<in>I x. A = {s})}"
     apply simp
     apply (intro arg_cong[where f="sigma_sets _"])
     apply auto
     done
 qed (auto intro: countable_rat)
 
 subsection \<open>Kernel equals Parallel Choice\<close>
 
 abbreviation PAR :: "'a \<Rightarrow> ('a \<Rightarrow> real) measure"
 where
   "PAR x \<equiv> (\<Pi>\<^sub>M y\<in>I x. exponential (R x y))"
 
 lemma PAR_least:
   assumes y: "y \<in> I x"
   shows "PAR x {p\<in>space (PAR x). t \<le> p y \<and> select_first x p y} =
      emeasure (exponential (escape_rate x)) {t ..} * ennreal (pmf (J x) y)"
 proof -
   let ?E = "\<lambda>y. exponential (R x y)" let ?P' = "\<Pi>\<^sub>M y\<in>I x - {y}. ?E y"
   interpret P': prob_space ?P'
     by (intro prob_space_PiM prob_space_exponential) simp
   have *: "PAR x = (\<Pi>\<^sub>M y\<in>insert y (I x - {y}). ?E y)"
     using y by (intro PiM_cong) auto
   have "0 < R x y"
     using y by simp
   have **: "(\<lambda>(x, X). X(y := x)) \<in> exponential (R x y) \<Otimes>\<^sub>M Pi\<^sub>M (I x - {y}) (\<lambda>i. exponential (R x i)) \<rightarrow>\<^sub>M PAR x"
     using y
     apply (subst measurable_cong_sets[OF sets_pair_measure_cong[OF sets_exponential sets_PiM_cong[OF refl sets_exponential]] sets_PiM_cong[OF refl sets_exponential]])
     apply measurable
     apply (rule measurable_fun_upd[where J="I x - {y}"])
     apply auto
     done
   have "PAR x {p\<in>space (PAR x). t \<le> p y \<and> (\<forall>y'\<in>I x-{y}. p y < p y')} =
     (\<integral>\<^sup>+ty. indicator {t..} ty * ?P' {p\<in>space ?P'. \<forall>y'\<in>I x-{y}. ty < p y'} \<partial>?E y)"
     unfolding * using \<open>y \<in> I x\<close>
     apply (subst distr_pair_PiM_eq_PiM[symmetric])
     apply (auto intro!: prob_space_exponential simp: emeasure_distr insert_absorb)
     apply (subst emeasure_distr[OF **])
     subgoal
       using I_countable by (auto simp: pred_def[symmetric])
     apply (subst P'.emeasure_pair_measure_alt)
     subgoal
       using I_countable[of x]
       apply (intro measurable_sets[OF **])
       apply (auto simp: pred_def[symmetric])
       done
     apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator if_split_asm
       simp: space_exponential space_PiM space_pair_measure PiE_iff extensional_def)
     done
   also have "\<dots> = (\<integral>\<^sup>+ty. indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y))) \<partial>?E y)"
     apply (intro nn_integral_cong_AE)
     using AE_exponential[OF \<open>0 < R x y\<close>]
   proof eventually_elim
     fix ty :: real assume "0 < ty"
     have "escape_rate x =
       (\<integral>\<^sup>+y'. R x y' * indicator {y} y' \<partial>count_space UNIV) + (\<integral>\<^sup>+y'. R x y' * indicator (I x - {y}) y' \<partial>count_space UNIV)"
       unfolding ennreal_escape_rate by (subst nn_integral_add[symmetric]) (auto simp: less_le split: split_indicator intro!: nn_integral_cong)
     also have "\<dots> = R x y + (\<integral>\<^sup>+y'. R x y' \<partial>count_space (I x - {y}))"
       by (auto simp add: nn_integral_count_space_indicator less_le simp del: nn_integral_indicator_singleton
                intro!: arg_cong2[where f="(+)"] nn_integral_cong split: split_indicator)
     finally have "(\<integral>\<^sup>+y'. R x y' \<partial>count_space (I x - {y})) = escape_rate x - R x y \<and> R x y \<le> escape_rate x"
       using escape_rate_pos[THEN less_imp_le]
       by (cases "(\<integral>\<^sup>+y'. R x y' \<partial>count_space (I x - {y}))")
          (auto simp: add_top ennreal_plus[symmetric] simp del: ennreal_plus)
     then have "integrable (count_space (I x - {y})) (R x)" "(LINT y'|count_space (I x - {y}). R x y') = escape_rate x - R x y"
       by (auto simp: nn_integral_eq_integrable)
     then have "?P' (prod_emb (I x-{y}) ?E (I x-{y}) (\<Pi>\<^sub>E j\<in>(I x-{y}). {ty<..})) = exp (- ty * (escape_rate x - R x y))"
       using I_countable \<open>0 < ty\<close> by (subst emeasure_PiM_exponential_Ioi_countable) auto
     also have "prod_emb (I x-{y}) ?E (I x-{y}) (\<Pi>\<^sub>E j\<in>(I x-{y}). {ty<..}) = {p\<in>space ?P'. \<forall>y'\<in>I x-{y}. ty < p y'}"
       by (simp add: set_eq_iff prod_emb_def space_PiM space_exponential ac_simps Pi_iff)
     finally show "indicator {t..} ty * ?P' {p\<in>space ?P'. \<forall>y'\<in>I x-{y}. ty < p y'} =
       indicator {t..} ty * ennreal (exp (- ty * (escape_rate x - R x y)))"
       by simp
   qed
   also have "\<dots> = (\<integral>\<^sup>+ty. ennreal (R x y) * (ennreal (exp (- ty * escape_rate x)) * indicator {max 0 t..} ty) \<partial>lborel)"
     by (auto simp add: exponential_def exponential_density_def nn_integral_density ennreal_mult[symmetric] exp_add[symmetric] field_simps
                 intro!: nn_integral_cong split: split_indicator)
   also have "\<dots> = (R x y / escape_rate x) * emeasure (exponential (escape_rate x)) {max 0 t..}"
     using escape_rate_pos[of x]
     by (auto simp: exponential_def exponential_density_def emeasure_density nn_integral_cmult[symmetric] ennreal_mult[symmetric]
              split: split_indicator intro!: nn_integral_cong )
   also have "\<dots> = pmf (J x) y * emeasure (exponential (escape_rate x)) {t..}"
     using AE_exponential[OF escape_rate_pos[of x]]
     by (intro arg_cong2[where f="(*)"] emeasure_eq_AE) (auto simp: J.rep_eq )
   finally show ?thesis
     using assms by (simp add: mult_ac select_first_def)
 qed
 
 lemma AE_PAR_least: "AE p in PAR x. \<exists>y\<in>I x. select_first x p y"
 proof -
   have D: "disjoint_family_on (\<lambda>y. {p \<in> space (PAR x). select_first x p y}) (I x)"
     by (auto simp: disjoint_family_on_def dest: select_first_unique)
   have "PAR x {p\<in>space (PAR x). \<exists>y\<in>I x. select_first x p y} =
     PAR x (\<Union>y\<in>I x. {p\<in>space (PAR x). select_first x p y})"
     by (auto intro!: arg_cong2[where f=emeasure])
   also have "\<dots> = (\<integral>\<^sup>+y. PAR x {p\<in>space (PAR x). select_first x p y} \<partial>count_space (I x))"
     using I_countable by (intro emeasure_UN_countable D) auto
   also have "\<dots> = (\<integral>\<^sup>+y. PAR x {p\<in>space (PAR x). 0 \<le> p y \<and> select_first x p y} \<partial>count_space (I x))"
   proof (intro nn_integral_cong emeasure_eq_AE, goal_cases)
     case (1 y) with AE_PiM_component[of "I x" "\<lambda>y. exponential (R x y)" y "(<) 0"] AE_exponential[of "R x y"] show ?case
       by (auto simp: prob_space_exponential)
   qed (insert I_countable, auto)
   also have "\<dots> = (\<integral>\<^sup>+y. emeasure (exponential (escape_rate x)) {0 ..} * ennreal (pmf (J x) y) \<partial>count_space (I x))"
     by (auto simp add: PAR_least intro!: nn_integral_cong)
   also have "\<dots> = (\<integral>\<^sup>+y. emeasure (exponential (escape_rate x)) {0 ..} \<partial>J x)"
     by (auto simp: nn_integral_measure_pmf nn_integral_count_space_indicator ac_simps pmf_eq_0_set_pmf set_pmf_J
              simp del: nn_integral_const intro!: nn_integral_cong split: split_indicator)
   also have "\<dots> = 1"
     using AE_exponential[of "escape_rate x"]
     by (auto intro!: prob_space.emeasure_eq_1_AE prob_space_exponential simp: escape_rate_pos less_imp_le)
   finally show ?thesis
     using I_countable
     by (subst prob_space.AE_iff_emeasure_eq_1 prob_space_PiM prob_space_exponential)
        (auto intro!: prob_space_PiM prob_space_exponential simp del: Set.bex_simps(6))
 qed
 
 lemma K_alt: "K (t, x) = distr (\<Pi>\<^sub>M y\<in>I x. exponential (R x y)) S (\<lambda>p. (t + (INF y\<in>I x. p y), The (select_first x p)))" (is "_ = ?R")
 proof (rule measure_eqI_generator_eq_countable)
   let ?E = "{ {t ..} \<times> A | (t::real) A. A \<subseteq> - I x \<or> (\<exists>s\<in>I x. A = {s}) }"
   show "Int_stable ?E"
     apply (auto simp: Int_stable_def)
     subgoal for t1 A1 t2 A2
       by (intro exI[of _ "max t1 t2"] exI[of _ "A1 \<inter> A2"]) auto
     subgoal for t1 t2 y1 y2
       by (intro exI[of _ "max t1 t2"] exI[of _ "{y1} \<inter> {y2}"]) auto
     done
   show "sets (K (t, x)) = sigma_sets UNIV ?E"
     unfolding K.sets_K[OF in_space_S] by (subst sets_S_eq) rule
   show "sets ?R = sigma_sets UNIV ?E"
     using sets_S_eq by simp
   show "countable ((\<lambda>(t, A). {t ..} \<times> A) ` (\<rat> \<times> ({- I x} \<union> (\<lambda>s. {s}) ` I x)))"
     by (intro countable_image countable_SIGMA countable_rat countable_Un I_countable) auto
 
    have *: "(+) t -` {t'..} \<inter> space (exponential (escape_rate x)) = {t' - t..}" for t'
      by (auto simp: space_exponential)
   { fix X assume "X \<in> ?E"
     then consider
         t' s where "s \<in> I x" "X = {t' ..} \<times> {s}"
       | t' A where "A \<subseteq> - I x" "X = {t' ..} \<times> A"
       by auto
     then show "K (t, x) X = ?R X"
     proof cases
       case 1
       have "AE p in PAR x. (t' - t \<le> p s \<and> select_first x p s) =
               (t' \<le> t + (\<Sqinter>x\<in>I x. p x) \<and> The (select_first x p) = s)"
         using AE_PAR_least by eventually_elim (auto dest: select_first_unique simp: select_first_INF)
       with 1 I_countable show ?thesis
         by (auto simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr emeasure_pmf_single *
           PAR_least[symmetric] intro!: emeasure_eq_AE)
     next
       case 2
       moreover
       then have "emeasure (measure_pmf (J x)) A = 0"
         by (subst AE_iff_measurable[symmetric, where P="\<lambda>x. x \<notin> A"])
            (auto simp: AE_measure_pmf_iff set_pmf_J subset_eq)
       moreover
       have "PAR x ((\<lambda>p. (t + \<Sqinter>(p ` (I x)), The (select_first x p))) -` ({t'..} \<times> A) \<inter> space (PAR x)) = 0"
         using \<open>A \<subseteq> - I x\<close> AE_PAR_least[of x] I_countable
         by (subst AE_iff_measurable[symmetric, where P="\<lambda>p. (t + \<Sqinter>(p ` (I x)), The (select_first x p)) \<notin> {t'..} \<times> A"])
            (auto simp del: all_simps(5) simp add: imp_ex imp_conjL subset_eq)
       ultimately show ?thesis
         using I_countable
         by (simp add: K_def measure_pmf.emeasure_pair_measure_Times emeasure_distr *)
     qed }
 
   interpret prob_space "K ts" for ts
     by (rule K.prob_space_K) simp
   show "emeasure (K (t, x)) a \<noteq> \<infinity>" for a
     using emeasure_finite by simp
 qed (insert  Rats_dense_in_real[of "x - 1" x for x], auto, blast intro: less_imp_le)
 
 lemma AE_K: "AE y in K x. fst x < fst y \<and> snd y \<in> J (snd x)"
   unfolding K_def split_beta
   apply (subst exp_esc.AE_pair_iff[symmetric])
   apply measurable
   apply (simp_all add: AE_distr_iff AE_measure_pmf_iff exponential_def AE_density exponential_density_def cong del: AE_cong)
   using AE_lborel_singleton[of 0]
   apply eventually_elim
   apply simp
   done
 
 lemma AE_lim_stream:
   "AE \<omega> in K.lim_stream x. \<forall>i. snd ((x ## \<omega>) !! i) \<in> DTMC.acc``{snd x} \<and> snd (\<omega> !! i) \<in> J (snd ((x ## \<omega>) !! i)) \<and> fst ((x ## \<omega>) !! i) < fst (\<omega> !! i)"
   (is "AE \<omega> in K.lim_stream x. \<forall>i. ?P \<omega> i")
   unfolding AE_all_countable
 proof
   let ?F = "\<lambda>i x \<omega>. fst ((x ## \<omega>) !! i)" and ?S = "\<lambda>i x \<omega>. snd ((x ## \<omega>) !! i)"
   fix i show "AE \<omega> in K.lim_stream x. ?P \<omega> i"
   proof (induction i arbitrary: x)
     case 0 with AE_K[of x] show ?case
       by (subst K.AE_lim_stream) (auto simp add: space_pair_measure cong del: AE_cong)
   next
     case (Suc i)
     show ?case
     proof (subst K.AE_lim_stream, goal_cases)
       case 2 show ?case
         using DTMC.countable_reachable
         by (intro measurable_compose_countable_restrict[where f="?S (Suc i) x"])
            (simp_all del: Image_singleton_iff)
     next
       case 3 show ?case
         apply (simp del: AE_conj_iff cong del: AE_cong)
         using AE_K[of x]
         apply eventually_elim
         subgoal premises K_prems for y
           using Suc
           by eventually_elim (insert K_prems, auto intro: converse_rtrancl_into_rtrancl)
         done
     qed (simp add: space_pair_measure)
   qed
 qed
 
 lemma measurable_merge_at[measurable]: "(\<lambda>(\<omega>, \<omega>'). merge_at \<omega> j \<omega>') \<in> (T \<Otimes>\<^sub>M T) \<rightarrow>\<^sub>M T"
 proof (rule measurable_stream_space2)
   define F where "F x n = (case x of (\<omega>::(real \<times> 'a) stream, \<omega>') \<Rightarrow> merge_at \<omega> j \<omega>') !! n" for x n
   fix n
   have "(\<lambda>x. F x n) \<in> stream_space S \<Otimes>\<^sub>M stream_space S \<rightarrow>\<^sub>M S"
   proof (induction n)
     case 0 then show ?case
       by (simp add: F_def split_beta' stream.case_eq_if)
   next
     case (Suc n)
     from Suc[measurable]
     have eq: "F x (Suc n) = (case fst x of (t, s) ## \<omega> \<Rightarrow> if t \<le> j then F (\<omega>, snd x) n else snd x !! Suc n)" for x
       by (auto simp: F_def split: prod.split stream.split)
     show ?case
       unfolding eq stream.case_eq_if by measurable
   qed
   then show "(\<lambda>x. (case x of (\<omega>, \<omega>') \<Rightarrow> merge_at \<omega> j \<omega>') !! n) \<in> stream_space S \<Otimes>\<^sub>M stream_space S \<rightarrow>\<^sub>M S"
     unfolding F_def by auto
 qed
 
 lemma measurable_trace_at[measurable]: "(\<lambda>(s, \<omega>). trace_at s \<omega> j) \<in> (count_space UNIV \<Otimes>\<^sub>M T) \<rightarrow>\<^sub>M count_space UNIV"
   unfolding trace_at_eq by measurable
 
 lemma measurable_trace_at': "(\<lambda>((s, j), \<omega>). trace_at s \<omega> j) \<in> ((count_space UNIV \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M T) \<rightarrow>\<^sub>M count_space UNIV"
   unfolding trace_at_eq split_beta' by measurable
 
 lemma K_time_split:
   assumes "t \<le> j" and [measurable]: "f \<in> S \<rightarrow>\<^sub>M borel"
   shows "(\<integral>\<^sup>+x. f x * indicator {j <..} (fst x) \<partial>K (t, s)) = (\<integral>\<^sup>+x. f x \<partial>K (j, s)) * exponential (escape_rate s) {j - t <..}"
 proof -
   have "(\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (t + x, y) * indicator {j<..} (t + x) \<partial>exponential (escape_rate s) \<partial>J s) =
     (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (t + x, y) * indicator {j - t<..} x \<partial>exponential (escape_rate s) \<partial>J s)"
     by (intro nn_integral_cong) (auto split: split_indicator)
   also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (t + x, y) \<partial>uniform_measure (exponential (escape_rate s)) {j-t <..} \<partial>J s) *
       emeasure (exponential (escape_rate s)) {j - t <..}"
     using \<open>t \<le> j\<close> escape_rate_pos
     by (subst nn_integral_uniform_measure)
        (auto simp: nn_integral_divide ennreal_divide_times emeasure_exponential_Ioi)
   also have "\<dots> = (\<integral>\<^sup>+ y. \<integral>\<^sup>+ x. f (j + x, y) \<partial>exponential (escape_rate s) \<partial>J s) *
       emeasure (exponential (escape_rate s)) {j - t <..}"
     using \<open>t \<le> j\<close> escape_rate_pos by (simp add: uniform_measure_exponential nn_integral_distr)
   finally show ?thesis
     by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr)
 qed
 
 lemma K_in_space[simp]: "K x \<in> space (prob_algebra S)"
   by (rule measurable_space [OF K.K]) simp
 
 lemma L_in_space[simp]: "K.lim_stream x \<in> space (prob_algebra T)"
   by (rule measurable_space [OF K.lim_stream]) simp
 
 subsection \<open>Markov Chain Property\<close>
 
 lemma lim_time_split:
   "t \<le> j \<Longrightarrow> K.lim_stream (t, s) = do { \<omega> \<leftarrow> K.lim_stream (t, s) ; \<omega>' \<leftarrow> K.lim_stream (j, trace_at s \<omega> j) ; return T (merge_at \<omega> j \<omega>')}"
     (is "_ \<Longrightarrow> _ = ?DO t s")
 proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
   case step let ?L = K.lim_stream
 
   note measurable_compose[OF measurable_prob_algebraD measurable_emeasure_subprob_algebra, measurable (raw)]
 
   define B' where "B' = (\<lambda>(t', s). if t' \<le> j then ?DO t' s else ?L (t', s))"
   show ?case
   proof (intro bexI conjI AE_I2)
     show [measurable]: "B' \<in> S \<rightarrow>\<^sub>M prob_algebra T"
       unfolding B'_def by measurable
     show "(\<exists>t s. y = (t, s) \<and> B' y = ?DO t s \<and> t \<le> j) \<or> ?L y = B' y" for y
       by (cases y; cases "fst y \<le> j") (auto simp: B'_def)
     let ?C = "\<lambda>x. do { \<omega> \<leftarrow> ?L x; \<omega>' \<leftarrow> ?L (j, trace_at s (x##\<omega>) j); return T (merge_at (x##\<omega>) j \<omega>') }"
     have "?DO t s = do { x \<leftarrow> K (t, s); ?C x }"
       apply (subst K.lim_stream_eq[OF in_space_S])
       apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
       apply (subst measurable_cong_sets[OF K.sets_K[OF in_space_S] refl])
       apply measurable
       apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
       apply measurable
       apply (subst bind_cong[OF refl bind_cong[OF refl bind_return[OF measurable_prob_algebraD]]])
       apply measurable
       done
     also have "\<dots> = K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))" (is "?DO' = ?R")
     proof (rule measure_eqI)
       have "sets ?DO' = sets T"
         by (intro sets_bind'[OF K_in_space]) measurable
       moreover have "sets ?R = sets T"
         by (intro sets_bind'[OF K_in_space]) measurable
       ultimately show "sets ?DO' = sets ?R"
         by simp
       fix A assume "A \<in> sets ?DO'"
       then have A[measurable]: "A \<in> T"
         unfolding \<open>sets ?DO' = sets T\<close> .
       have "?DO' A = (\<integral>\<^sup>+x. ?C x A \<partial>K (t, s))"
         by (subst emeasure_bind_prob_algebra[OF K_in_space]) measurable
       also have "\<dots> = (\<integral>\<^sup>+x. ?C x A * indicator {.. j} (fst x) \<partial>K (t, s)) +
         (\<integral>\<^sup>+x. ?C x A * indicator {j <..} (fst x) \<partial>K (t, s))"
         by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
       also have "(\<integral>\<^sup>+x. ?C x A * indicator {.. j} (fst x) \<partial>K (t, s)) =
         (\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {.. j} (fst y) \<partial>K (t, s))"
       proof (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
         fix x :: "real \<times> 'a" assume "indicator {..j} (fst x) \<noteq> (0::ennreal)"
         then have "fst x \<le> j"
           by (auto split: split_indicator_asm)
         then show "?C x = (B' x \<bind> (\<lambda>\<omega>. return T (x ## \<omega>)))"
           apply (cases x)
           apply (simp add: B'_def)
           apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
           apply measurable
           apply (subst bind_assoc[OF measurable_prob_algebraD measurable_prob_algebraD])
           apply measurable
           apply (subst bind_return)
           apply measurable
           done
       qed
       also have "(\<integral>\<^sup>+x. ?C x A * indicator {j <..} (fst x) \<partial>K (t, s)) =
         (\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s))"
       proof -
         have *: "(+) t -` {j<..} = {j - t <..}"
           by auto
 
         have "(\<integral>\<^sup>+x. ?C x A * indicator {j <..} (fst x) \<partial>K (t, s)) =
           (\<integral>\<^sup>+x. ?L (j, s) A * indicator {j <..} (fst x) \<partial>K (t, s))"
           by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
              (auto simp: K.sets_lim_stream bind_return'' bind_const' prob_space_K_lim prob_space_imp_subprob_space split: split_indicator_asm)
         also have "\<dots> = ?L (j, s) A * exponential (escape_rate s) {j - t <..}"
           by (subst nn_integral_cmult) (simp_all add: K_def exp_esc.nn_integral_snd[symmetric] emeasure_distr space_exponential *)
         also have "\<dots> = (\<integral>\<^sup>+x. emeasure (?L x \<bind> (\<lambda>\<omega>. return T (x ## \<omega>))) A \<partial>K (j, s)) * exponential (escape_rate s) {j - t <..}"
           by (subst K.lim_stream_eq) (auto simp: emeasure_bind_prob_algebra[OF K_in_space _ A])
         also have "\<dots> = (\<integral>\<^sup>+y. emeasure (?L y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s))"
           using \<open>t \<le> j\<close> by (rule K_time_split[symmetric]) measurable
         also have "\<dots> = (\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s))"
           by (intro nn_integral_cong ennreal_mult_right_cong refl arg_cong2[where f=emeasure])
              (auto simp add: B'_def split: split_indicator_asm)
         finally show ?thesis .
       qed
       also have "(\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {.. j} (fst y) \<partial>K (t, s)) +
         (\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A * indicator {j <..} (fst y) \<partial>K (t, s)) =
         (\<integral>\<^sup>+y. emeasure (B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>))) A \<partial>K (t, s))"
         by (subst nn_integral_add[symmetric]) (auto intro!: nn_integral_cong split: split_indicator)
       also have "\<dots> = emeasure (K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))) A"
         by (rule emeasure_bind_prob_algebra[symmetric, OF K_in_space _ A]) auto
       finally show "?DO' A = emeasure (K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))) A" .
     qed
     finally show "?DO t s = K (t, s) \<bind> (\<lambda>y. B' y \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))" .
   qed
 qed (simp add: space_pair_measure)
 
 lemma K_eq: "K (t, s) = distr (exponential (escape_rate s) \<Otimes>\<^sub>M J s) S (\<lambda>(t', s). (t + t', s))"
 proof -
   have "distr (exponential (escape_rate s)) borel ((+) t) \<Otimes>\<^sub>M distr (J s) (J s) (\<lambda>x. x) =
     distr (exponential (escape_rate s) \<Otimes>\<^sub>M J s) (borel \<Otimes>\<^sub>M J s) (\<lambda>(x, y). (t + x, y))"
   proof (intro pair_measure_distr)
     interpret prob_space "distr (measure_pmf (J s)) (measure_pmf (J s)) (\<lambda>x. x)"
       by (intro measure_pmf.prob_space_distr) simp
     show "sigma_finite_measure (distr (measure_pmf (J s)) (measure_pmf (J s)) (\<lambda>x. x))"
       by unfold_locales
   qed auto
   also have "\<dots> = distr (exponential (escape_rate s) \<Otimes>\<^sub>M J s) S (\<lambda>(x, y). (t + x, y))"
     by (intro distr_cong refl sets_pair_measure_cong) simp
   finally show ?thesis
     by (simp add: K_def)
 qed
 
 lemma K_shift: "K (t + t', s) = distr (K (t, s)) S (\<lambda>(t, s). (t + t', s))"
   unfolding K_eq by (subst distr_distr) (auto simp: comp_def split_beta' ac_simps)
 
 lemma K_not_empty: "space (K x) \<noteq> {}"
   by (simp add: K_def space_pair_measure split: prod.split)
 
 lemma lim_stream_not_empty: "space (K.lim_stream x) \<noteq> {}"
   by (simp add: K.space_lim_stream space_pair_measure split: prod.split)
 
 lemma lim_shift: \<comment> \<open>Generalize to bijective function on @{const K.lim_stream} invariant on @{const K}\<close>
   "K.lim_stream (t + t', s) = distr (K.lim_stream (t, s)) T (smap (\<lambda>(t, s). (t + t', s)))"
   (is "_ = ?D t s")
 proof (coinduction arbitrary: t s rule: K.lim_stream_eq_coinduct)
   case step then show ?case
   proof (intro bexI[of _ "\<lambda>(t, s). ?D (t - t') s"] conjI)
     show "?D t s = K (t + t', s) \<bind> (\<lambda>y. (case y of (t, s) \<Rightarrow> ?D (t - t') s) \<bind> (\<lambda>\<omega>. return T (y ## \<omega>)))"
       apply (subst K.lim_stream_eq[OF in_space_S])
       apply (subst K_shift)
       apply (subst distr_bind[OF measurable_prob_algebraD K_not_empty])
       apply (measurable; fail)
       apply (measurable; fail)
       apply (subst bind_distr[OF _ measurable_prob_algebraD K_not_empty])
       apply (measurable; fail)
       apply (measurable; fail)
       apply (intro bind_cong refl)
       apply (subst distr_bind[OF measurable_prob_algebraD lim_stream_not_empty])
       apply (measurable; fail)
       apply (measurable; fail)
       apply (simp add: distr_return split_beta)
       apply (subst bind_distr[OF _ measurable_prob_algebraD lim_stream_not_empty])
       apply (measurable; fail)
       apply (measurable; fail)
       apply (simp add: split_beta')
       done
   qed (auto cong: conj_cong intro!: exI[of _ "_ - t'"])
 qed simp
 
 lemma lim_0: "K.lim_stream (t, s) = distr (K.lim_stream (0, s)) T (smap (\<lambda>(t', s). (t' + t, s)))"
   using lim_shift[of 0 t s] by simp
 
 subsection \<open>Explosion time\<close>
 
 definition explosion :: "(real \<times> 'a) stream \<Rightarrow> ereal"
   where "explosion \<omega> = (SUP i. ereal (fst (\<omega> !! i)))"
 
 lemma ball_less_Suc_eq: "(\<forall>i<Suc n. P i) \<longleftrightarrow> (P 0 \<and> (\<forall>i<n. P (Suc i)))"
   using less_Suc_eq_0_disj by auto
 
 lemma lim_stream_timediff_eq_exponential_1:
   "distr (K.lim_stream ts) (PiM UNIV (\<lambda>_. borel))
     (\<lambda>\<omega> i. escape_rate (snd ((ts##\<omega>) !! i)) * (fst (\<omega> !! i) - fst ((ts##\<omega>) !! i))) =
     PiM UNIV (\<lambda>_. exponential 1)"
   (is "?D = ?P")
 proof (rule measure_eqI_PiM_sequence)
   show "sets ?D = sets (PiM UNIV (\<lambda>_. borel))" "sets ?P = sets (PiM UNIV (\<lambda>_. borel))"
     by (auto intro!: sets_PiM_cong simp: sets_exponential)
   have [measurable]: "ts \<in> space S"
     by auto
   { interpret prob_space ?D
       by (intro prob_space.prob_space_distr K.prob_space_lim_stream measurable_abs_UNIV) auto
     show "finite_measure ?D"
       by unfold_locales }
 
   interpret E: prob_space "exponential 1"
     by (rule prob_space_exponential) simp
   interpret P: product_prob_space "\<lambda>_. exponential 1" UNIV
     by unfold_locales
 
   let "distr _ _ (?f ts)" = ?D
 
   fix A :: "nat \<Rightarrow> real set" and n :: nat assume A[measurable]: "\<And>i. A i \<in> sets borel"
   define n' where "n' = Suc n"
   have "emeasure ?D (prod_emb UNIV (\<lambda>_. borel) {..n} (Pi\<^sub>E {..n} A)) =
     emeasure (K.lim_stream ts) {\<omega>\<in>space (stream_space S). \<forall>i<n'. ?f ts \<omega> i \<in> A i}"
     apply (subst emeasure_distr)
       apply (auto intro!: measurable_abs_UNIV arg_cong[where f="emeasure _"])
       apply (auto simp: prod_emb_def K.space_lim_stream space_pair_measure n'_def)
     done
   also have "\<dots> = (\<Prod>i<n'. emeasure (exponential 1) (A i))"
     using A
   proof (induction n' arbitrary: A ts)
     case 0 then show ?case
       using prob_space.emeasure_space_1[OF prob_space_K_lim]
       by (simp add: K.space_lim_stream space_pair_measure)
   next
     case (Suc n A ts)
     from Suc.prems[measurable]
     have [measurable]: "ts \<in> space S"
       by auto
 
     have "emeasure (K.lim_stream ts) {\<omega> \<in> space (stream_space S). \<forall>i<Suc n. ?f ts \<omega> i \<in> A i} =
       (\<integral>\<^sup>+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) *
         emeasure (K.lim_stream ts') {\<omega> \<in> space (stream_space S). \<forall>i<n. ?f ts' \<omega> i \<in> A (Suc i)} \<partial>K ts)"
       apply (subst K.emeasure_lim_stream)
       apply simp
        apply measurable
       apply (auto intro!: nn_integral_cong arg_cong2[where f=emeasure] split: split_indicator
         simp: ball_less_Suc_eq)
       done
     also have "\<dots> = (\<integral>\<^sup>+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) \<partial>K ts) *
       (\<Prod>i<n. emeasure (exponential 1) (A (Suc i)))"
       by (subst Suc.IH) (simp_all add: nn_integral_multc)
     also have "(\<integral>\<^sup>+ts'. indicator (A 0) (escape_rate (snd ts) * (fst ts' - fst ts)) \<partial>K ts) =
       (\<integral>\<^sup>+t. indicator (A 0) (escape_rate (snd ts) * t) \<partial>exponential (escape_rate (snd ts)))"
       by (simp add: K_def exp_esc.nn_integral_snd[symmetric] nn_integral_distr split: prod.split)
     also have "\<dots> = emeasure (exponential 1) (A 0)"
       using escape_rate_pos[of "snd ts"]
       by (subst exponential_eq_stretch) (simp_all add: nn_integral_distr)
     also have "emeasure (exponential 1) (A 0) * (\<Prod>i<n. emeasure (exponential 1) (A (Suc i))) =
       (\<Prod>i<Suc n. emeasure (exponential 1) (A i))"
       by (rule prod.lessThan_Suc_shift[symmetric])
     finally show ?case .
   qed
   also have "\<dots> = emeasure ?P (prod_emb UNIV (\<lambda>_. borel) {..<n'} (Pi\<^sub>E {..<n'} A))"
     using P.emeasure_PiM_emb[of "{..<n'}" A] by (simp add: prod_emb_def space_exponential)
   finally show "emeasure ?D (prod_emb UNIV (\<lambda>_. borel) {..n} (Pi\<^sub>E {..n} A)) =
     emeasure ?P (prod_emb UNIV (\<lambda>_. borel) {..n} (Pi\<^sub>E {..n} A))"
     by (simp add: n'_def lessThan_Suc_atMost)
 qed
 
 lemma AE_explosion_infty:
   assumes bdd: "bdd_above (range escape_rate)"
   shows "AE \<omega> in K.lim_stream x. explosion \<omega> = \<infinity>"
 proof -
   have "escape_rate undefined \<le> (SUP x. escape_rate x)"
     using bdd by (intro cSUP_upper) auto
   then have SUP_escape_pos: "0 < (SUP x. escape_rate x)"
     using escape_rate_pos[of undefined] by simp
   then have SUP_escape_nonneg: "0 \<le> (SUP x. escape_rate x)"
     by (rule less_imp_le)
 
   have [measurable]: "x \<in> space S" by auto
   have "(\<Sum>i. 1::ennreal) = top"
     by (rule sums_unique[symmetric]) (auto simp: sums_def of_nat_tendsto_top_ennreal)
   then have "AE \<omega> in (PiM UNIV (\<lambda>_. exponential 1)). (\<Sum>i. ereal (\<omega> i)) = \<infinity>"
     by (intro AE_PiM_exponential_suminf_infty) auto
   then have "AE \<omega> in K.lim_stream x.
     (\<Sum>i. ereal (escape_rate (snd ((x##\<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x##\<omega>) !! i)))) = \<infinity>"
     apply (subst (asm) lim_stream_timediff_eq_exponential_1[symmetric, of x])
     apply (subst (asm) AE_distr_iff)
     apply (auto intro!: measurable_abs_UNIV)
     done
   then show ?thesis
     using AE_lim_stream
   proof eventually_elim
     case (elim \<omega>)
     then have le: "fst ((x##\<omega>) !! n) \<le> fst ((x ## \<omega>) !! m)" if "n \<le> m" for n m
       by (intro lift_Suc_mono_le[OF _ \<open>n \<le> m\<close>, of "\<lambda>i. fst ((x ## \<omega>) !! i)"]) (auto intro: less_imp_le)
     have [simp]: "fst x \<le> fst ((x##\<omega>) !! i)" "fst ((x##\<omega>) !! i) \<le> fst (\<omega> !! i)" for i
       using le[of "i" "Suc i"] le[of 0 i] by auto
 
     have "(\<Sum>i. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i)))) =
       (SUP n. \<Sum>i<n. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i))))"
       by (intro suminf_ereal_eq_SUP) (auto intro!: mult_nonneg_nonneg)
     also have "\<dots> \<le> (SUP n. (SUP x. escape_rate x) * (ereal (fst ((x ## \<omega>) !! n)) - ereal (fst x)))"
     proof (intro SUP_least SUP_upper2)
       fix n
       have "(\<Sum>i<n. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i)))) \<le>
         (\<Sum>i<n. ereal ((SUP i. escape_rate i) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i))))"
         using elim bdd by (intro sum_mono) (auto intro!: cSUP_upper)
       also have "\<dots> = (SUP i. escape_rate i) * (\<Sum>i<n. fst ((x ## \<omega>) !! Suc i) - fst ((x ## \<omega>) !! i))"
         using elim bdd by (subst sum_ereal) (auto simp: sum_distrib_left)
       also have "\<dots> = (SUP i. escape_rate i) * (fst ((x ## \<omega>) !! n) - fst x)"
         by (subst sum_lessThan_telescope) simp
       finally show "(\<Sum>i<n. ereal (escape_rate (snd ((x ## \<omega>) !! i)) * (fst (\<omega> !! i) - fst ((x ## \<omega>) !! i))))
          \<le> (SUP x. escape_rate x) * (ereal (fst ((x ## \<omega>) !! n)) - ereal (fst x))"
         by simp
     qed simp
     also have "\<dots> = (SUP x. escape_rate x) * ((SUP n. ereal (fst ((x ## \<omega>) !! n))) - ereal (fst x))"
       using elim SUP_escape_nonneg by (subst SUP_ereal_mult_left) (auto simp: SUP_ereal_minus_left[symmetric])
     also have "(SUP n. ereal (fst ((x ## \<omega>) !! n))) = explosion \<omega>"
       unfolding explosion_def
       apply (intro SUP_eq)
       subgoal for i by (intro bexI[of _ i]) auto
       subgoal for i by (intro bexI[of _ "Suc i"]) auto
       done
     finally show "explosion \<omega> = \<infinity>"
       using elim SUP_escape_pos by (cases "explosion \<omega>") (auto split: if_splits)
   qed
 qed
 
 subsection \<open>Transition probability $p_t$\<close>
 
 context
 begin
 
 declare [[inductive_internals = true]]
 
 inductive trace_in :: "'a set \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> bool" for S t
 where
   "t < t' \<Longrightarrow> s \<in> S \<Longrightarrow> trace_in S t s ((t', s')##\<omega>)"
 | "t \<ge> t' \<Longrightarrow> trace_in S t s' \<omega> \<Longrightarrow> trace_in S t s ((t', s')##\<omega>)"
 
 end
 
 lemma trace_in_simps[simp]:
   "trace_in ss t s (x##\<omega>) = (if t < fst x then s \<in> ss else trace_in ss t (snd x) \<omega>)"
   by (cases x) (subst trace_in.simps; auto)
 
 lemma trace_in_eq_lfp:
   "trace_in ss t = lfp (\<lambda>F s. \<lambda>(t', s')##\<omega> \<Rightarrow> if t < t' then s \<in> ss else F s' \<omega>)"
   unfolding trace_in_def by (intro arg_cong[where f=lfp] ext) (auto split: stream.splits)
 
 lemma trace_in_shiftD: "trace_in ss t s \<omega> \<Longrightarrow> trace_in ss (t + t') s (smap (\<lambda>(t, s'). (t + t', s')) \<omega>)"
   by (induction rule: trace_in.induct) auto
 
 lemma trace_in_shift[simp]: "trace_in ss t s (smap (\<lambda>(t, s'). (t + t', s')) \<omega>) \<longleftrightarrow> trace_in ss (t - t') s \<omega>"
   using trace_in_shiftD[of ss t s "smap (\<lambda>(t, s'). (t + t', s')) \<omega>" "- t'"]
     trace_in_shiftD[of ss "t - t'" s \<omega> t']
   by (auto simp add: stream.map_comp prod.case_eq_if)
 
 lemma measurable_trace_in':
   "Measurable.pred (borel \<Otimes>\<^sub>M count_space UNIV \<Otimes>\<^sub>M T) (\<lambda>(t, s, \<omega>). trace_in ss t s \<omega>)"
     (is "?M (\<lambda>(t, s, \<omega>). trace_in ss t s \<omega>)")
 proof -
   let ?F = "\<lambda>F. \<lambda>(t, s, (t', s')##\<omega>) \<Rightarrow> if t < t' then s \<in> ss else F (t, s', \<omega>)"
   have [measurable]: "Measurable.pred (count_space UNIV) (\<lambda>x. x \<in> ss)"
     by simp
   have "trace_in ss = (\<lambda>t s \<omega>. lfp ?F (t, s, \<omega>))"
     unfolding trace_in_def
     apply (subst lfp_arg)
     apply (subst lfp_rolling[where g="\<lambda>F t s \<omega>. F (t, s, \<omega>)"])
     subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
     subgoal by (auto simp: mono_def le_fun_def split: stream.splits)
     subgoal
       by (intro arg_cong[where f=lfp])
          (auto simp: mono_def le_fun_def split_beta' not_less fun_eq_iff split: stream.splits intro!: arg_cong[where f=lfp])
     done
   then have eq: "(\<lambda>(t, s, \<omega>). trace_in ss t s \<omega>) = lfp ?F"
     by simp
   have "sup_continuous ?F"
     by (auto simp: sup_continuous_def fun_eq_iff split: stream.splits)
   then show ?thesis
     unfolding eq
   proof (rule measurable_lfp)
     fix F assume "?M F" then show "?M (?F F)"
       by measurable
   qed
 qed
 
 lemma measurable_trace_in[measurable (raw)]:
   assumes [measurable]: "f \<in> M \<rightarrow>\<^sub>M borel" "g \<in> M \<rightarrow>\<^sub>M count_space UNIV" "h \<in> M \<rightarrow>\<^sub>M T"
   shows "Measurable.pred M (\<lambda>x. trace_in ss (f x) (g x) (h x))"
   using measurable_compose[of "\<lambda>x. (f x, g x, h x)" M, OF _ measurable_trace_in'[of ss]] by simp
 
 definition p :: "'a \<Rightarrow> 'a \<Rightarrow> real \<Rightarrow> real"
 where "p s s' t = \<P>(\<omega> in K.lim_stream (0, s). trace_in {s'} t s \<omega>)"
 
 lemma p[measurable]: "(\<lambda>(s, t). p s s' t) \<in> (count_space UNIV \<Otimes>\<^sub>M borel) \<rightarrow>\<^sub>M borel"
 proof -
   have *: "(SIGMA x:space (count_space UNIV \<Otimes>\<^sub>M borel). {\<omega> \<in> streams (space S). trace_in {s'} (snd x) (fst x) \<omega>}) =
     {x\<in>space ((count_space UNIV \<Otimes>\<^sub>M borel) \<Otimes>\<^sub>M T). trace_in {s'} (snd (fst x)) (fst (fst x)) (snd x)}"
     by (auto simp: space_pair_measure)
 
   note measurable_trace_at'[measurable]
   show ?thesis
     unfolding p_def[abs_def] split_beta'
     by (rule measure_measurable_prob_algebra2[where N=T])
        (auto simp: K.space_lim_stream * pred_def[symmetric]
                 intro!: pred_count_space_const1 measurable_trace_at'[unfolded split_beta'])
 qed
 
 lemma p_nonpos: assumes "t \<le> 0" shows "p s s' t = of_bool (s = s')"
 proof -
   have "AE \<omega> in K.lim_stream (0, s). trace_in {s'} t s \<omega> = (s = s')"
   proof (subst K.AE_lim_stream)
     show "AE y in K (0, s). AE \<omega> in K.lim_stream y. trace_in {s'} t s (y ## \<omega>) = (s = s')"
       using AE_K
     proof eventually_elim
       fix y :: "real \<times> 'a" assume "fst (0, s) < fst y \<and> snd y \<in> set_pmf (J (snd (0, s)))"
       with \<open>t\<le>0\<close> show "AE \<omega> in K.lim_stream y. trace_in {s'} t s (y ## \<omega>) = (s = s')"
         by (cases y) auto
     qed
   qed auto
   then have "p s s' t = \<P>(\<omega> in K.lim_stream (0, s). s = s')"
     unfolding p_def by (intro prob_space.prob_eq_AE K.prob_space_lim_stream) auto
   then show ?thesis
     using prob_space.prob_space[OF K.prob_space_lim_stream] by simp
 qed
 
 lemma p_0: "p s s' 0 = of_bool (s = s')"
   using p_nonpos[of 0] by simp
 
 lemma in_sets_T[measurable (raw)]: "Measurable.pred T P \<Longrightarrow> {\<omega>. P \<omega>} \<in> sets T"
   unfolding pred_def by simp
 
 lemma distr_id': "sets M = sets N \<Longrightarrow> distr M N (\<lambda>x. x) = M"
   by (subst distr_cong[of M M N M _ "\<lambda>x. x"] ) simp_all
 
 lemma p_nonneg[simp]: "0 \<le> p s s' t"
   by (simp add: p_def)
 
 lemma p_le_1[simp]: "p s s' t \<le> 1"
   unfolding p_def by (intro prob_space.prob_le_1 K.prob_space_lim_stream) simp
 
 lemma p_eq:
   assumes "0 \<le> t"
   shows "p s s'' t = (of_bool (s = s'') + (LINT u:{0..t}|lborel. escape_rate s * exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))) / exp (t * escape_rate s)"
 proof -
   have *: "(+) 0 = (\<lambda>x::real. x)"
     by auto
   interpret L: prob_space "K.lim_stream x" for x
     by (rule K.prob_space_lim_stream) simp
   interpret E: prob_space "exponential (escape_rate s)" for s
     by (intro escape_rate_pos prob_space_exponential)
   have "p s s'' t = emeasure (K.lim_stream (0, s)) {\<omega>\<in>space T. trace_in {s''} t s \<omega>}"
     by (simp add: p_def L.emeasure_eq_measure K.space_lim_stream space_stream_space del: in_space_T)
   also have "\<dots> = (\<integral>\<^sup>+y. emeasure (K.lim_stream y) {\<omega>\<in>space T. trace_in {s''} t s (y##\<omega>) } \<partial>K (0, s))"
     apply (subst K.lim_stream_eq[OF in_space_S])
     apply (subst emeasure_bind_prob_algebra[OF K_in_space])
     apply (measurable; fail)
     apply (measurable; fail)
     apply (subst bind_return_distr'[OF lim_stream_not_empty])
     apply (measurable; fail)
     apply (simp add: emeasure_distr)
     done
   also have "\<dots> = (\<integral>\<^sup>+y. indicator {t <..} (fst y) * of_bool (s = s'') + indicator {0<..t} (fst y) * p (snd y) s'' (t - fst y) \<partial>K (0, s))"
     apply (intro nn_integral_cong_AE)
     using AE_K
     apply eventually_elim
     subgoal for y
       using L.emeasure_space_1
       apply (cases y)
       apply (auto split: split_indicator simp del: in_space_T)
       subgoal for t' s2
         unfolding p_def L.emeasure_eq_measure[symmetric] K.space_lim_stream space_stream_space[symmetric]
         by (subst lim_0) (simp add: emeasure_distr)
       subgoal
         by (auto split: split_indicator cong: rev_conj_cong simp add: K.space_lim_stream space_stream_space simp del: in_space_T)
       done
     done
   also have "\<dots> = (\<integral>\<^sup>+u. \<integral>\<^sup>+s'. indicator {t <..} u * of_bool (s = s'') +
     indicator {0<..t} u * p s' s'' (t - u) \<partial>J s \<partial>exponential (escape_rate s))"
     unfolding K_def
     by (simp add: K_def measure_pmf.nn_integral_fst[symmetric] * distr_id' sets_exponential)
   also have "\<dots> = ennreal (exp (- t * escape_rate s) * of_bool (s = s'')) +
       (\<integral>\<^sup>+u. indicator {0<..t} u * \<integral>\<^sup>+s'. p s' s'' (t - u) \<partial>J s \<partial>exponential (escape_rate s))"
     using \<open>0\<le>t\<close> by (simp add: nn_integral_add nn_integral_cmult ennreal_indicator ennreal_mult emeasure_exponential_Ioi escape_rate_pos)
   also have "(\<integral>\<^sup>+u. indicator {0<..t} u * \<integral>\<^sup>+s'. p s' s'' (t - u) \<partial>J s \<partial>exponential (escape_rate s)) =
       (\<integral>\<^sup>+u. indicator {0<..t} u *\<^sub>R (LINT s'|J s. p s' s'' (t - u)) \<partial>exponential (escape_rate s))"
     by (simp add: measure_pmf.integrable_const_bound[of _ 1] nn_integral_eq_integral ennreal_mult ennreal_indicator)
   also have "\<dots> = (LINT u:{0<..t}|exponential (escape_rate s). (LINT s'|J s. p s' s'' (t - u)))"
     unfolding set_lebesgue_integral_def
     by (intro nn_integral_eq_integral E.integrable_const_bound[of _ 1] AE_I2)
        (auto intro!: mult_le_one measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
   also have "\<dots> = (LINT u:{0<..t}|lborel. escape_rate s * exp (- escape_rate s * u) * (LINT s'|J s. p s' s'' (t - u)))"
     unfolding exponential_def set_lebesgue_integral_def
     by (subst integral_density)
        (auto simp: ac_simps exponential_density_def fun_eq_iff split: split_indicator
              simp del: integral_mult_right integral_mult_right_zero intro!: arg_cong2[where f="integral\<^sup>L"])
   also have "\<dots> = (LINT u:{0..t}|lborel. escape_rate s * exp (- escape_rate s * (t - u)) * (LINT s'|J s. p s' s'' u))"
     using AE_lborel_singleton[of 0] AE_lborel_singleton[of t] unfolding set_lebesgue_integral_def
     by (subst lborel_integral_real_affine[where t=t and c="-1"])
        (auto intro!: integral_cong_AE split: split_indicator)
   also have "\<dots> = exp (- t * escape_rate s) * escape_rate s * (LINT u:{0..t}|lborel. exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))"
     by (simp add: field_simps exp_diff exp_minus)
   finally show "p s s'' t = (of_bool (s = s'') + (LBINT u:{0..t}. escape_rate s * exp (escape_rate s * u) * (LINT s'|J s. p s' s'' u))) / exp (t * escape_rate s)"
     unfolding set_lebesgue_integral_def
     by (simp del: ennreal_plus add: ennreal_plus[symmetric] exp_minus field_simps)
 qed
 
 lemma continuous_on_p: "continuous_on A (p s s')"
 proof -
   interpret E: prob_space "exponential (escape_rate s'')" for s''
     by (intro escape_rate_pos prob_space_exponential)
   have "continuous_on {..0} (p s s')"
     by (simp add: p_nonpos continuous_on_const cong: continuous_on_cong_simp)
   moreover have "continuous_on {0..} (p s s')"
   proof (subst continuous_on_cong[OF refl p_eq])
     let ?I = "\<lambda>t. escape_rate s * exp (escape_rate s * t) * (LINT s''|J s. p s'' s' t)"
     show "continuous_on {0..} (\<lambda>t. (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) / exp (t * escape_rate s))"
     proof (intro continuous_intros continuous_on_LBINT[THEN continuous_on_subset])
       fix t :: real assume t: "0 \<le> t"
       then have "0 \<le> x \<Longrightarrow> x \<le> t \<Longrightarrow> exp (x * escape_rate s) * (LINT s''|J s. p s'' s' x) \<le> exp (t * escape_rate s) * 1" for x
         by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
       with t show "set_integrable lborel {0..t} ?I"
         using escape_rate_pos[of s] unfolding set_integrable_def
         by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
            (auto simp: field_simps)
     qed auto
   qed simp
   ultimately have "continuous_on ({0..} \<union> {..0}) (p s s')"
     by (intro continuous_on_closed_Un) auto
   also have "{0..} \<union> {..0::real} = UNIV" by auto
   finally show ?thesis
     by (rule continuous_on_subset) simp
 qed
 
 lemma p_vector_derivative: \<comment> \<open>Backward equation\<close>
   assumes "0 \<le> t"
   shows "(p s s' has_vector_derivative (LINT s''|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t)
     (at t within {0..})"
     (is "(_ has_vector_derivative ?A) _")
 proof -
   let ?I = "\<lambda>t. escape_rate s * exp (escape_rate s * t) * (LINT s''|J s. p s'' s' t)"
   let ?p = "\<lambda>t. (of_bool (s = s') + integral {0..t} ?I) * exp (t *\<^sub>R - escape_rate s)"
 
   { fix t :: real assume "0 \<le> t"
     have "p s s' t = (of_bool (s = s') + (LBINT u:{0..t}. ?I u)) * exp (- t * escape_rate s)"
       using p_eq[OF \<open>0 \<le> t\<close>, of s s'] by (simp add: exp_minus field_simps)
     also have "(LBINT u:{0..t}. ?I u) = integral {0..t} ?I"
     proof (intro set_borel_integral_eq_integral)
       have "0 \<le> x \<Longrightarrow> x \<le> t \<Longrightarrow> exp (x * escape_rate s) * (LINT s''|J s. p s'' s' x) \<le> exp (t * escape_rate s) * 1" for x
         by (intro mult_mono) (auto intro!: mult_mono measure_pmf.integral_le_const measure_pmf.integrable_const_bound[of _ 1])
       with \<open>0\<le>t\<close> show "set_integrable lborel {0..t} ?I"
         using escape_rate_pos[of s] unfolding set_integrable_def
         by (intro integrableI_bounded_set_indicator[where B="escape_rate s * exp (escape_rate s * t)"])
            (auto simp: field_simps)
     qed
     finally have "p s s' t = ?p t"
       by simp }
   note p_eq = this
 
   have at_eq: "at t within {0..} = at t within {0 .. t + 1}"
     by (intro at_within_nhd[where S="{..< t+1}"]) auto
 
   have c_I: "continuous_on {0..t + 1} ?I"
     by (intro continuous_intros continuous_on_LINT_pmf[where B=1] continuous_on_p) simp
 
   show ?thesis
   proof (subst has_vector_derivative_cong_ev)
     show "\<forall>\<^sub>F u in nhds t. u \<in> {0..} \<longrightarrow> p s s' u = ?p u" "p s s' t = ?p t"
       using \<open>0\<le>t\<close> by (simp_all add: p_eq)
     have "(?p has_vector_derivative escape_rate s * ((LINT s''|J s. p s'' s' t) - p s s' t)) (at t within {0..})"
       unfolding at_eq
       apply (intro refl derivative_eq_intros)
       apply rule
       apply (rule integral_has_vector_derivative[OF c_I])
       apply (simp add: \<open>0 \<le> t\<close>)
       apply rule
       apply (rule exp_scaleR_has_vector_derivative_right)
       apply (simp add: field_simps exp_minus p_eq \<open>0\<le>t\<close> split del: split_of_bool)
       done
     also have "escape_rate s * ((LINT s''|J s. p s'' s' t) - p s s' t) =
         (LINT s''|count_space UNIV. R s s'' * p s'' s' t) - escape_rate s * p s s' t"
       using escape_rate_pos[of s]
       by (simp add: measure_pmf_eq_density integral_density J.rep_eq field_simps)
     finally show "(?p has_vector_derivative  ?A) (at t within {0..})" .
   qed
 qed
 
 coinductive wf_times :: "real \<Rightarrow> (real \<times> 'a) stream \<Rightarrow> bool"
 where
   "t < t' \<Longrightarrow> wf_times t' \<omega> \<Longrightarrow> wf_times t ((t', s') ## \<omega>)"
 
 lemma wf_times_simp[simp]: "wf_times t (x ## \<omega>) \<longleftrightarrow> t < fst x \<and> wf_times (fst x) \<omega>"
   by (cases x) (subst wf_times.simps; simp)
 
 lemma trace_in_merge_at:
   assumes \<omega>': "wf_times t' \<omega>'"
   shows "trace_in ss t x (merge_at \<omega> t' \<omega>') \<longleftrightarrow>
     (if t < t' then trace_in ss t x \<omega> else \<exists>y. trace_in {y} t' x \<omega> \<and> trace_in ss t y \<omega>')"
     (is "?merge \<longleftrightarrow> ?cases")
 proof safe
   assume ?merge from this \<omega>' show ?cases
   proof (induction \<omega>\<equiv>"merge_at \<omega> t' \<omega>'" arbitrary: \<omega> \<omega>')
     case (1 j s' y \<omega>'') then show ?case
       by (cases \<omega>) (auto split: if_splits)
   next
     case (2 j x \<omega>' s' \<omega> \<omega>'') then show ?case
       by (cases \<omega>) (auto split: if_splits)
   qed
 next
   assume ?cases then show ?merge
   proof (split if_split_asm)
     assume "trace_in ss t x \<omega>" "t < t'" from this \<omega>' show ?thesis
     proof induction
       case 1 then show ?case
         by (cases \<omega>') auto
     qed auto
   next
     assume "\<exists>y. trace_in {y} t' x \<omega> \<and> trace_in ss t y \<omega>'" "\<not> t < t'"
     then obtain y where "trace_in {y} t' x \<omega>" "trace_in ss t y \<omega>'" "t' \<le> t"
       by auto
     from this \<omega>' show ?thesis
       by induction auto
   qed
 qed
 
 lemma AE_lim_wf_times: "AE \<omega> in K.lim_stream (t, s). wf_times t \<omega>"
   using AE_lim_stream
 proof eventually_elim
   fix \<omega> assume *: "\<forall>i. snd (((t, s) ## \<omega>) !! i) \<in> DTMC.acc `` {snd (t, s)} \<and>
              snd (\<omega> !! i) \<in> J (snd (((t, s) ## \<omega>) !! i)) \<and>
              fst (((t, s) ## \<omega>) !! i) < fst (\<omega> !! i)"
   have "(t ## smap fst \<omega>) !! i < fst (\<omega> !! i)" for i
     using *[THEN spec, of i] by (cases i) auto
   then show "wf_times t \<omega>"
   proof (coinduction arbitrary: t \<omega>)
     case wf_times from this[THEN spec, of 0] this[THEN spec, of "Suc i" for i]  show ?case
       by (cases \<omega>) auto
   qed
 qed
 
 lemma wf_times_shiftD: "wf_times t' (smap (\<lambda>(t', y). (t' + t, y)) \<omega>) \<Longrightarrow> wf_times (t' - t) \<omega>"
   apply (coinduction arbitrary: t' t \<omega>)
   subgoal for t' t \<omega>
     apply (cases \<omega>; cases "shd \<omega>")
     apply (auto simp: )
     subgoal for \<omega>' j x
       by (rule exI[of _ "j + t"]) auto
     done
   done
 
 lemma wf_times_shift[simp]: "wf_times t' (smap (\<lambda>(t', y). (t' + t, y)) \<omega>) = wf_times (t' - t) \<omega>"
   using wf_times_shiftD[of "t' - t" "-t" "smap (\<lambda>(t', y). (t' + t, y)) \<omega>"]
   by (auto simp: stream.map_comp stream.case_eq_if prod.case_eq_if wf_times_shiftD)
 
 lemma trace_in_unique: "trace_in {y1} t x \<omega> \<Longrightarrow> trace_in {y2} t x \<omega> \<Longrightarrow> y1 = y2"
   by (induction rule: trace_in.induct) auto
 
 lemma trace_at_eq: "trace_in {z} t x \<omega> \<Longrightarrow> trace_at x \<omega> t = z"
   by (induction rule: trace_in.induct) auto
 
 lemma AE_lim_acc: "AE \<omega> in K.lim_stream (t, x). \<forall>t z. trace_in {z} t x \<omega> \<longrightarrow> (x, z) \<in> DTMC.acc"
   using AE_lim_stream
 proof (eventually_elim, safe)
   fix t' z \<omega> assume *: "\<forall>i. snd (((t, x) ## \<omega>) !! i) \<in> DTMC.acc `` {snd (t, x)} \<and>
     snd (\<omega> !! i) \<in> J (snd (((t, x) ## \<omega>) !! i)) \<and> fst (((t, x) ## \<omega>) !! i) < fst (\<omega> !! i)"
     and t: "trace_in {z} t' x \<omega>"
   define X where "X = DTMC.acc `` {x}"
   have "(x ## smap snd \<omega>) !! i \<in> X" for i
     using *[THEN spec, of i] by (cases i) (auto simp: X_def)
   from t this have "z \<in> X"
   proof induction
     case (1 j y x \<omega>) with "1.prems"[of 0] show ?case
       by simp
   next
     case (2 j y \<omega> x) with "2.prems"[of "Suc i" for i] show ?case
       by simp
   qed
   then show "(x, z) \<in> DTMC.acc"
     by (simp add: X_def)
 qed
 
 lemma p_add:
   assumes "0 \<le> t" "0 \<le> t'"
   shows "p x y (t + t') = (LINT z|count_space (DTMC.acc``{x}). p x z t * p z y t')"
 proof -
   interpret L: prob_space "K.lim_stream xy" for xy
     by (rule K.prob_space_lim_stream) simp
   interpret A: sigma_finite_measure "count_space (DTMC.acc``{x})"
     by (intro sigma_finite_measure_count_space_countable DTMC.countable_acc) simp
   interpret LA: pair_sigma_finite "count_space (DTMC.acc``{x})" "K.lim_stream xy" for xy
     by unfold_locales
 
   have "p x y (t + t') = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. indicator {\<omega>\<in>space T. trace_in {y} (t + t') x \<omega>} (merge_at \<omega> t \<omega>')
     \<partial>K.lim_stream (t, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
     unfolding p_def L.emeasure_eq_measure[symmetric]
     apply (subst lim_time_split[OF \<open>0 \<le> t\<close>])
     apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
     apply (measurable; fail)
     apply (measurable; fail)
     apply (intro nn_integral_cong)
     apply (subst emeasure_bind[OF lim_stream_not_empty measurable_prob_algebraD])
     apply (measurable; fail)
     apply (measurable; fail)
     apply (simp add: in_space_lim_stream)
     done
   also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. indicator {\<omega>\<in>space T. trace_in {y} (t + t') x \<omega>} (merge_at \<omega> t (smap (\<lambda>(t'', s). (t'' + t, s)) \<omega>'))
     \<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
     unfolding lim_0[of t] by (subst nn_integral_distr) (measurable; fail)+
   also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. of_bool (\<exists>z\<in>DTMC.acc``{x}. trace_in {z} t x \<omega> \<and> trace_in {y} t' z \<omega>')
     \<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
     apply (rule nn_integral_cong_AE)
     using AE_lim_wf_times AE_lim_acc
     apply eventually_elim
     subgoal premises \<omega> for \<omega>
       apply (rule nn_integral_cong_AE)
       using AE_lim_wf_times AE_lim_acc
       apply eventually_elim
       using \<omega> assms
-      apply (auto simp add: trace_in_merge_at indicator_def Bex_def)
+      apply (auto simp add: trace_in_merge_at indicator_eq_1_iff)
       done
     done
   also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+\<omega>'. \<integral>\<^sup>+z. of_bool (trace_in {z} t x \<omega> \<and> trace_in {y} t' z \<omega>')
     \<partial>count_space (DTMC.acc``{x}) \<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>K.lim_stream (0, x))"
     by (intro nn_integral_cong of_bool_Bex_eq_nn_integral) (auto dest: trace_in_unique)
   also have "\<dots> = (\<integral>\<^sup>+ \<omega>. \<integral>\<^sup>+z. \<integral>\<^sup>+\<omega>'. of_bool (trace_in {z} t x \<omega> \<and> trace_in {y} t' z \<omega>')
     \<partial>K.lim_stream (0, trace_at x \<omega> t) \<partial>count_space (DTMC.acc``{x}) \<partial>K.lim_stream (0, x))"
     apply (subst LA.Fubini')
     apply (subst measurable_split_conv)
     apply (rule measurable_compose_countable'[OF _ measurable_fst])
     apply (auto simp: DTMC.countable_acc)
     done
   also have "\<dots> = (\<integral>\<^sup>+z. \<integral>\<^sup>+ \<omega>. of_bool (trace_in {z} t x \<omega>) * \<integral>\<^sup>+\<omega>'. of_bool (trace_in {y} t' z \<omega>')
     \<partial>K.lim_stream (0, z) \<partial>K.lim_stream (0, x) \<partial>count_space (DTMC.acc``{x}))"
     apply (subst LA.Fubini')
     apply (subst measurable_split_conv)
     apply (rule measurable_compose_countable'[OF _ measurable_fst])
     apply (rule nn_integral_measurable_subprob_algebra2)
     apply (measurable; fail)
     apply (rule measurable_prob_algebraD)
     apply (auto simp: DTMC.countable_acc trace_at_eq intro!: nn_integral_cong)
     done
   also have "\<dots> = (\<integral>\<^sup>+z. (\<integral>\<^sup>+ \<omega>. of_bool (trace_in {z} t x \<omega>)\<partial>K.lim_stream (0, x)) *
       (\<integral>\<^sup>+\<omega>'. of_bool (trace_in {y} t' z \<omega>') \<partial>K.lim_stream (0, z)) \<partial>count_space (DTMC.acc``{x}))"
      by (auto intro!: nn_integral_cong simp: nn_integral_multc)
   also have "\<dots> = (\<integral>\<^sup>+z. ennreal (p x z t) * ennreal (p z y t') \<partial>count_space (DTMC.acc``{x}))"
     unfolding p_def L.emeasure_eq_measure[symmetric]
     by (auto intro!: nn_integral_cong arg_cong2[where f="(*)"]
              simp: nn_integral_indicator[symmetric] simp del: nn_integral_indicator )
   finally have "(\<integral>\<^sup>+z. p x z t * p z y t' \<partial>count_space (DTMC.acc``{x})) = p x y (t + t')"
     by (simp add: ennreal_mult)
   then show ?thesis
     by (subst (asm) nn_integral_eq_integrable) auto
 qed
 
 end
 
 end
diff --git a/thys/Native_Word/Code_Target_Word_Base.thy b/thys/Native_Word/Code_Target_Word_Base.thy
--- a/thys/Native_Word/Code_Target_Word_Base.thy
+++ b/thys/Native_Word/Code_Target_Word_Base.thy
@@ -1,393 +1,391 @@
 (*  Title:      Code_Target_Word_Base.thy
     Author:     Andreas Lochbihler, ETH Zurich
 *)
 
 chapter \<open>Common base for target language implementations of word types\<close>
 
 theory Code_Target_Word_Base imports
   "HOL-Library.Word"
   "Word_Lib.Signed_Division_Word"
   Bits_Integer
 begin
 
 text \<open>More lemmas\<close>
 
 lemma div_half_nat:
   fixes x y :: nat
   assumes "y \<noteq> 0"
   shows "(x div y, x mod y) = (let q = 2 * (x div 2 div y); r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
 proof -
   let ?q = "2 * (x div 2 div y)"
   have q: "?q = x div y - x div y mod 2"
     by(metis div_mult2_eq mult.commute minus_mod_eq_mult_div [symmetric])
   let ?r = "x - ?q * y"
   have r: "?r = x mod y + x div y mod 2 * y"
     by(simp add: q diff_mult_distrib minus_mod_eq_div_mult [symmetric])(metis diff_diff_cancel mod_less_eq_dividend mod_mult2_eq add.commute mult.commute)
 
   show ?thesis
   proof(cases "y \<le> x - ?q * y")
     case True
     with assms q have "x div y mod 2 \<noteq> 0" unfolding r
       by (metis Nat.add_0_right diff_0_eq_0 diff_Suc_1 le_div_geq mod2_gr_0 mod_div_trivial mult_0 neq0_conv numeral_1_eq_Suc_0 numerals(1)) 
     hence "x div y = ?q + 1" unfolding q
       by simp
     moreover hence "x mod y = ?r - y"
       by simp(metis minus_div_mult_eq_mod [symmetric] diff_commute diff_diff_left mult_Suc)
     ultimately show ?thesis using True by(simp add: Let_def)
   next
     case False
     hence "x div y mod 2 = 0" unfolding r
       by(simp add: not_le)(metis Nat.add_0_right assms div_less div_mult_self2 mod_div_trivial mult.commute)
     hence "x div y = ?q" unfolding q by simp
     moreover hence "x mod y = ?r" by (metis minus_div_mult_eq_mod [symmetric])
     ultimately show ?thesis using False by(simp add: Let_def)
   qed
 qed
 
 lemma div_half_word:
   fixes x y :: "'a :: len word"
   assumes "y \<noteq> 0"
   shows "(x div y, x mod y) = (let q = (x >> 1) div y << 1; r = x - q * y in if y \<le> r then (q + 1, r - y) else (q, r))"
 proof -
   obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat x\<close>]) simp_all
   moreover obtain m where m: "y = of_nat m" "m < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat y\<close>]) simp_all
   ultimately have [simp]: \<open>unat (of_nat n :: 'a word) = n\<close> \<open>unat (of_nat m :: 'a word) = m\<close>
     by (transfer, simp add: take_bit_of_nat take_bit_nat_eq_self_iff)+
   let ?q = "(x >> 1) div y << 1"
   let ?q' = "2 * (n div 2 div m)"
   have "n div 2 div m < 2 ^ LENGTH('a)" using n by (metis of_nat_inverse unat_lt2p uno_simps(2))
   hence q: "?q = of_nat ?q'" using n m
     by (auto simp add: shiftr_word_eq drop_bit_eq_div shiftl_t2n word_arith_nat_div uno_simps take_bit_nat_eq_self)
   from assms have "m \<noteq> 0" using m by -(rule notI, simp)
 
   from n have "2 * (n div 2 div m) < 2 ^ LENGTH('a)"
     by(metis mult.commute div_mult2_eq minus_mod_eq_mult_div [symmetric] less_imp_diff_less of_nat_inverse unat_lt2p uno_simps(2))
   moreover
   have "2 * (n div 2 div m) * m < 2 ^ LENGTH('a)" using n unfolding div_mult2_eq[symmetric]
     by(subst (2) mult.commute)(simp add: minus_mod_eq_div_mult [symmetric] diff_mult_distrib minus_mod_eq_mult_div [symmetric] div_mult2_eq)
   moreover have "2 * (n div 2 div m) * m \<le> n"
     by (simp flip: div_mult2_eq ac_simps)
   ultimately
   have r: "x - ?q * y = of_nat (n - ?q' * m)"
     and "y \<le> x - ?q * y \<Longrightarrow> of_nat (n - ?q' * m) - y = of_nat (n - ?q' * m - m)"
     using n m unfolding q
      apply (simp_all add: of_nat_diff)
     apply (subst of_nat_diff)
     apply (simp_all add: word_le_nat_alt take_bit_nat_eq_self unat_sub_if' unat_word_ariths)
-    apply (cases \<open>2 \<le> LENGTH('a)\<close>)
-    apply (simp_all add: unat_word_ariths take_bit_nat_eq_self)
     done
   then show ?thesis using n m div_half_nat [OF \<open>m \<noteq> 0\<close>, of n] unfolding q
     by (simp add: word_le_nat_alt word_div_def word_mod_def Let_def take_bit_nat_eq_self
       flip: zdiv_int zmod_int
       split del: if_split split: if_split_asm)
 qed
 
 lemma word_test_bit_set_bits: "(BITS n. f n :: 'a :: len word) !! n \<longleftrightarrow> n < LENGTH('a) \<and> f n"
   by (simp add: test_bit_eq_bit bit_set_bits_word_iff)
 
 lemma word_of_int_conv_set_bits: "word_of_int i = (BITS n. i !! n)"
   by (rule word_eqI) (auto simp add: word_test_bit_set_bits)
 
 lemma word_and_mask_or_conv_and_mask:
   "n !! index \<Longrightarrow> (n AND mask index) OR (1 << index) = n AND mask (index + 1)"
   for n :: \<open>'a::len word\<close>
 by(rule word_eqI)(auto simp add: word_ao_nth word_size nth_shiftl simp del: shiftl_1)
 
 lemma uint_and_mask_or_full:
   fixes n :: "'a :: len word"
   assumes "n !! (LENGTH('a) - 1)"
   and "mask1 = mask (LENGTH('a) - 1)"
   and "mask2 = 1 << LENGTH('a) - 1"
   shows "uint (n AND mask1) OR mask2 = uint n"
 proof -
   have "mask2 = uint (1 << LENGTH('a) - 1 :: 'a word)" using assms
     by (simp add: uint_shiftl word_size bintrunc_shiftl del: shiftl_1)
   hence "uint (n AND mask1) OR mask2 = uint (n AND mask1 OR (1 << LENGTH('a) - 1 :: 'a word))"
     by(simp add: uint_or)
   also have "\<dots> = uint (n AND mask (LENGTH('a) - 1 + 1))"
     using assms by(simp only: word_and_mask_or_conv_and_mask)
   also have "\<dots> = uint n" by simp
   finally show ?thesis .
 qed
 
 
 text \<open>Division on @{typ "'a word"} is unsigned, but Scala and OCaml only have signed division and modulus.\<close>
 
 lemmas word_sdiv_def = sdiv_word_def
 lemmas word_smod_def = smod_word_def
 
 lemma [code]:
   "x sdiv y =
    (let x' = sint x; y' = sint y;
         negative = (x' < 0) \<noteq> (y' < 0);
         result = abs x' div abs y'
     in word_of_int (if negative then -result else result))"
   for x y :: \<open>'a::len word\<close>
   by (simp add: sdiv_word_def signed_divide_int_def sgn_if Let_def not_less not_le)
 
 lemma [code]:
   "x smod y =
    (let x' = sint x; y' = sint y;
         negative = (x' < 0);
         result = abs x' mod abs y'
     in word_of_int (if negative then -result else result))"
   for x y :: \<open>'a::len word\<close>
 proof -
   have *: \<open>k mod l = k - k div l * l\<close> for k l :: int
     by (simp add: minus_div_mult_eq_mod)
   show ?thesis
     by (simp add: smod_word_def signed_modulo_int_def signed_divide_int_def * sgn_if Let_def)
 qed
 
 text \<open>
   This algorithm implements unsigned division in terms of signed division.
   Taken from Hacker's Delight.
 \<close>
 
 lemma divmod_via_sdivmod:
   fixes x y :: "'a :: len word"
   assumes "y \<noteq> 0"
   shows
   "(x div y, x mod y) =
   (if 1 << (LENGTH('a) - 1) \<le> y then if x < y then (0, x) else (1, x - y)
    else let q = ((x >> 1) sdiv y) << 1;
             r = x - q * y
         in if r \<ge> y then (q + 1, r - y) else (q, r))"
 proof(cases "1 << (LENGTH('a) - 1) \<le> y")
   case True
   note y = this
   show ?thesis
   proof(cases "x < y")
     case True
     then have "x mod y = x"
       by transfer simp
     thus ?thesis using True y by(simp add: word_div_lt_eq_0)
   next
     case False
     obtain n where n: "y = of_nat n" "n < 2 ^ LENGTH('a)"
       by (rule that [of \<open>unat y\<close>]) simp_all
     have "unat x < 2 ^ LENGTH('a)" by(rule unat_lt2p)
     also have "\<dots> = 2 * 2 ^ (LENGTH('a) - 1)"
       by(metis Suc_pred len_gt_0 power_Suc One_nat_def)
     also have "\<dots> \<le> 2 * n" using y n
       by transfer (simp add: push_bit_of_1 take_bit_eq_mod)
     finally have div: "x div of_nat n = 1" using False n
       by (simp add: word_div_eq_1_iff take_bit_nat_eq_self)
     moreover have "x mod y = x - x div y * y"
       by (simp add: minus_div_mult_eq_mod)
     with div n have "x mod y = x - y" by simp
     ultimately show ?thesis using False y n by simp
   qed
 next
   case False
   note y = this
   obtain n where n: "x = of_nat n" "n < 2 ^ LENGTH('a)"
     by (rule that [of \<open>unat x\<close>]) simp_all
   hence "int n div 2 + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
     by (cases \<open>LENGTH('a)\<close>)
       (auto dest: less_imp_of_nat_less [where ?'a = int])
   with y n have "sint (x >> 1) = uint (x >> 1)"
     by (simp add: sint_uint sbintrunc_mod2p shiftr_div_2n take_bit_nat_eq_self)
   moreover have "uint y + 2 ^ (LENGTH('a) - Suc 0) < 2 ^ LENGTH('a)"
     using y by (cases "LENGTH('a)")
       (simp_all add: not_le word_2p_lem word_size)
   then have "sint y = uint y"
     by (simp add: sint_uint sbintrunc_mod2p)
   ultimately show ?thesis using y
     apply (subst div_half_word [OF assms])
     apply (simp add: sdiv_word_def signed_divide_int_def flip: uint_div)
     done
 qed
 
 
 text \<open>More implementations tailored towards target-language implementations\<close>
 
 context
 includes integer.lifting
 begin
 lift_definition word_of_integer :: "integer \<Rightarrow> 'a :: len word" is word_of_int .
 
 lemma word_of_integer_code [code]: "word_of_integer n = word_of_int (int_of_integer n)"
 by(simp add: word_of_integer.rep_eq)
 end
 
 lemma word_of_int_code:
   "uint (word_of_int x :: 'a word) = x AND mask (LENGTH('a :: len))"
   by (simp add: take_bit_eq_mask)
 
 context fixes f :: "nat \<Rightarrow> bool" begin
 
 definition set_bits_aux :: \<open>'a word \<Rightarrow> nat \<Rightarrow> 'a :: len word\<close>
   where \<open>set_bits_aux w n = push_bit n w OR take_bit n (set_bits f)\<close>
 
 lemma set_bits_aux_conv:
   \<open>set_bits_aux w n = (w << n) OR (set_bits f AND mask n)\<close>
   for w :: \<open>'a::len word\<close>
   by (rule bit_word_eqI)
     (auto simp add: set_bits_aux_def shiftl_word_eq bit_and_iff bit_or_iff bit_push_bit_iff bit_take_bit_iff bit_mask_iff bit_set_bits_word_iff)
 
 corollary set_bits_conv_set_bits_aux:
   \<open>set_bits f = (set_bits_aux 0 (LENGTH('a)) :: 'a :: len word)\<close>
   by (simp add: set_bits_aux_conv)
 
 lemma set_bits_aux_0 [simp]:
   \<open>set_bits_aux w 0 = w\<close>
   by  (simp add: set_bits_aux_conv)
 
 lemma set_bits_aux_Suc [simp]:
   \<open>set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n\<close>
   by (simp add: set_bits_aux_def shiftl_word_eq bit_eq_iff bit_or_iff bit_push_bit_iff bit_take_bit_iff bit_set_bits_word_iff)
     (auto simp add: bit_exp_iff not_less bit_1_iff less_Suc_eq_le)
 
 lemma set_bits_aux_simps [code]:
   \<open>set_bits_aux w 0 = w\<close>
   \<open>set_bits_aux w (Suc n) = set_bits_aux ((w << 1) OR (if f n then 1 else 0)) n\<close>
   by simp_all
 
 end
 
 lemma word_of_int_via_signed:
   fixes mask
   assumes mask_def: "mask = Bit_Operations.mask (LENGTH('a))"
   and shift_def: "shift = 1 << LENGTH('a)"
   and index_def: "index = LENGTH('a) - 1"
   and overflow_def:"overflow = 1 << (LENGTH('a) - 1)"
   and least_def: "least = - overflow"
   shows
   "(word_of_int i :: 'a :: len word) =
    (let i' = i AND mask
     in if i' !! index then
          if i' - shift < least \<or> overflow \<le> i' - shift then arbitrary1 i' else word_of_int (i' - shift)
        else if i' < least \<or> overflow \<le> i' then arbitrary2 i' else word_of_int i')"
 proof -
   define i' where "i' = i AND mask"
   have "shift = mask + 1" unfolding assms by(simp add: bin_mask_p1_conv_shift)
   hence "i' < shift" by(simp add: mask_def i'_def int_and_le)
   show ?thesis
   proof(cases "i' !! index")
     case True
     then have unf: "i' = overflow OR i'"
       apply (simp add: assms i'_def shiftl_eq_push_bit push_bit_of_1 flip: take_bit_eq_mask)
       apply (rule bit_eqI)
       apply (auto simp add: bit_take_bit_iff bit_or_iff bit_exp_iff)
       done
     have "overflow \<le> i'" by(subst unf)(rule le_int_or, simp add: bin_sign_and assms i'_def)
     hence "i' - shift < least \<longleftrightarrow> False" unfolding assms
       by(cases "LENGTH('a)")(simp_all add: not_less)
     moreover
     have "overflow \<le> i' - shift \<longleftrightarrow> False" using \<open>i' < shift\<close> unfolding assms
       by(cases "LENGTH('a)")(auto simp add: not_le elim: less_le_trans)
     moreover
     have "word_of_int (i' - shift) = (word_of_int i :: 'a word)" using \<open>i' < shift\<close>
       by (simp add: i'_def shift_def mask_def shiftl_eq_push_bit push_bit_of_1 word_of_int_eq_iff flip: take_bit_eq_mask)
     ultimately show ?thesis using True by(simp add: Let_def i'_def)
   next
     case False
     hence "i' = i AND Bit_Operations.mask (LENGTH('a) - 1)" unfolding assms i'_def
       by(clarsimp simp add: i'_def bin_nth_ops intro!: bin_eqI)(cases "LENGTH('a)", auto simp add: less_Suc_eq)
     also have "\<dots> \<le> Bit_Operations.mask (LENGTH('a) - 1)" by(rule int_and_le) simp
     also have "\<dots> < overflow" unfolding overflow_def
       by(simp add: bin_mask_p1_conv_shift[symmetric])
     also
     have "least \<le> 0" unfolding least_def overflow_def by simp
     have "0 \<le> i'" by (simp add: i'_def mask_def)
     hence "least \<le> i'" using \<open>least \<le> 0\<close> by simp
     moreover
     have "word_of_int i' = (word_of_int i :: 'a word)"
       by(rule word_eqI)(auto simp add: i'_def bin_nth_ops mask_def)
     ultimately show ?thesis using False by(simp add: Let_def i'_def)
   qed
 qed
 
 
 
 text \<open>Quickcheck conversion functions\<close>
 
 context
   includes state_combinator_syntax
 begin
 
 definition qc_random_cnv ::
   "(natural \<Rightarrow> 'a::term_of) \<Rightarrow> natural \<Rightarrow> Random.seed
     \<Rightarrow> ('a \<times> (unit \<Rightarrow> Code_Evaluation.term)) \<times> Random.seed"
   where "qc_random_cnv a_of_natural i = Random.range (i + 1) \<circ>\<rightarrow> (\<lambda>k. Pair (
        let n = a_of_natural k
        in (n, \<lambda>_. Code_Evaluation.term_of n)))"
 
 end
 
 definition qc_exhaustive_cnv :: "(natural \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> (bool \<times> term list) option)
   \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "qc_exhaustive_cnv a_of_natural f d =
    Quickcheck_Exhaustive.exhaustive (%x. f (a_of_natural x)) d"
 
 definition qc_full_exhaustive_cnv ::
   "(natural \<Rightarrow> ('a::term_of)) \<Rightarrow> ('a \<times> (unit \<Rightarrow> term) \<Rightarrow> (bool \<times> term list) option)
   \<Rightarrow> natural \<Rightarrow> (bool \<times> term list) option"
 where
   "qc_full_exhaustive_cnv a_of_natural f d = Quickcheck_Exhaustive.full_exhaustive
   (%(x, xt). f (a_of_natural x, %_. Code_Evaluation.term_of (a_of_natural x))) d"
 
 declare [[quickcheck_narrowing_ghc_options = "-XTypeSynonymInstances"]]
 
 definition qc_narrowing_drawn_from :: "'a list \<Rightarrow> integer \<Rightarrow> _"
 where
   "qc_narrowing_drawn_from xs =
    foldr Quickcheck_Narrowing.sum (map Quickcheck_Narrowing.cons (butlast xs)) (Quickcheck_Narrowing.cons (last xs))"
 
 locale quickcheck_narrowing_samples =
   fixes a_of_integer :: "integer \<Rightarrow> 'a \<times> 'a :: {partial_term_of, term_of}"
   and zero :: "'a"
   and tr :: "typerep"
 begin
 
 function narrowing_samples :: "integer \<Rightarrow> 'a list"
 where
   "narrowing_samples i =
    (if i > 0 then let (a, a') = a_of_integer i in narrowing_samples (i - 1) @ [a, a'] else [zero])"
 by pat_completeness auto
 termination including integer.lifting
 proof(relation "measure nat_of_integer")
   fix i :: integer
   assume "0 < i"
   thus "(i - 1, i) \<in> measure nat_of_integer"
     by simp(transfer, simp)
 qed simp
 
 definition partial_term_of_sample :: "integer \<Rightarrow> 'a"
 where
   "partial_term_of_sample i =
   (if i < 0 then undefined
    else if i = 0 then zero
    else if i mod 2 = 0 then snd (a_of_integer (i div 2))
    else fst (a_of_integer (i div 2 + 1)))"
 
 lemma partial_term_of_code:
   "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_variable p t) \<equiv>
     Code_Evaluation.Free (STR ''_'') tr"
   "partial_term_of (ty :: 'a itself) (Quickcheck_Narrowing.Narrowing_constructor i []) \<equiv>
    Code_Evaluation.term_of (partial_term_of_sample i)"
 by (rule partial_term_of_anything)+
 
 end
 
 lemmas [code] =
   quickcheck_narrowing_samples.narrowing_samples.simps
   quickcheck_narrowing_samples.partial_term_of_sample_def
 
 
 text \<open>
   The separate code target \<open>SML_word\<close> collects setups for the
   code generator that PolyML does not provide.
 \<close>
 
 setup \<open>Code_Target.add_derived_target ("SML_word", [(Code_ML.target_SML, I)])\<close>
 
 code_identifier code_module Code_Target_Word_Base \<rightharpoonup>
   (SML) Word and (Haskell) Word and (OCaml) Word and (Scala) Word
 
 end
diff --git a/thys/Probabilistic_Prime_Tests/Fermat_Witness.thy b/thys/Probabilistic_Prime_Tests/Fermat_Witness.thy
--- a/thys/Probabilistic_Prime_Tests/Fermat_Witness.thy
+++ b/thys/Probabilistic_Prime_Tests/Fermat_Witness.thy
@@ -1,752 +1,752 @@
 (*
   File:     Fermat_Witness.thy
   Authors:  Daniel Stüwe
 
   Fermat witnesses as used in Fermat's test
 *)
 section \<open>Fermat Witnesses\<close>
 theory Fermat_Witness
   imports Euler_Witness Carmichael_Numbers
 begin
 
 definition divide_out :: "'a :: factorial_semiring \<Rightarrow> 'a \<Rightarrow> 'a \<times> nat" where
   "divide_out p x = (x div p ^ multiplicity p x, multiplicity p x)"
 
 lemma fst_divide_out [simp]: "fst (divide_out p x) = x div p ^ multiplicity p x"
   and snd_divide_out [simp]: "snd (divide_out p x) = multiplicity p x"
   by (simp_all add: divide_out_def)
 
 
 function divide_out_aux :: "'a :: factorial_semiring \<Rightarrow> 'a \<times> nat \<Rightarrow> 'a \<times> nat" where
   "divide_out_aux p (x, acc) =
      (if x = 0 \<or> is_unit p \<or> \<not>p dvd x then (x, acc) else divide_out_aux p (x div p, acc + 1))"
   by auto
 termination proof (relation "measure (\<lambda>(p, x, _). multiplicity p x)")
   fix p x :: 'a and acc :: nat
   assume "\<not>(x = 0 \<or> is_unit p \<or> \<not>p dvd x)"
   thus "((p, x div p, acc + 1), p, x, acc) \<in> measure (\<lambda>(p, x, _). multiplicity p x)"
     by (auto elim!: dvdE simp: multiplicity_times_same)
 qed auto
 
 lemmas [simp del] = divide_out_aux.simps
 
 lemma divide_out_aux_correct:
   "divide_out_aux p z = (fst z div p ^ multiplicity p (fst z), snd z + multiplicity p (fst z))"
 proof (induction p z rule: divide_out_aux.induct)
   case (1 p x acc)
   show ?case
   proof (cases "x = 0 \<or> is_unit p \<or> \<not>p dvd x")
     case False
     have "x div p div p ^ multiplicity p (x div p) = x div p ^ multiplicity p x"
       using False
       by (subst dvd_div_mult2_eq [symmetric])
          (auto elim!: dvdE simp: multiplicity_dvd multiplicity_times_same)
     with False show ?thesis using 1
       by (subst divide_out_aux.simps)
          (auto elim: dvdE simp: multiplicity_times_same multiplicity_unit_left
                                 not_dvd_imp_multiplicity_0)
   qed (auto simp: divide_out_aux.simps multiplicity_unit_left not_dvd_imp_multiplicity_0)
 qed
 
 lemma divide_out_code [code]: "divide_out p x = divide_out_aux p (x, 0)"
   by (simp add: divide_out_aux_correct divide_out_def)
 
 lemma multiplicity_code [code]: "multiplicity p x = snd (divide_out_aux p (x, 0))"
   by (simp add: divide_out_aux_correct)
 
 (* TODO Move *)
 lemma multiplicity_times_same_power:
   assumes "x \<noteq> 0" "\<not>is_unit p" "p \<noteq> 0"
   shows   "multiplicity p (p ^ k * x) = multiplicity p x + k"
   using assms by (induction k) (simp_all add: multiplicity_times_same mult.assoc)
 
 lemma divide_out_unique_nat:
   fixes n :: nat
   assumes "\<not>is_unit p" "p \<noteq> 0" "\<not>p dvd m" and "n = p ^ k * m"
   shows   "m = n div p ^ multiplicity p n" and "k = multiplicity p n"
 proof -
   from assms have "n \<noteq> 0" by (intro notI) auto
   thus *: "k = multiplicity p n"
     using assms by (auto simp: assms multiplicity_times_same_power not_dvd_imp_multiplicity_0)
   from assms show "m = n div p ^ multiplicity p n"
     unfolding * [symmetric] by auto
 qed
 
 
 context
   fixes a n :: nat 
 begin
 
 definition "fermat_liar \<longleftrightarrow> [a^(n-1) = 1] (mod n)"
 definition "fermat_witness \<longleftrightarrow> [a^(n-1) \<noteq> 1] (mod n)"
 
 definition "strong_fermat_liar \<longleftrightarrow>
               (\<forall>k m. odd m \<longrightarrow> n - 1 = 2^k * m \<longrightarrow>
                  [a^m = 1](mod n) \<or> (\<exists>i \<in> {0..< k}. [a^(2 ^ i * m) = n-1] (mod n)))"
 
 definition "strong_fermat_witness \<longleftrightarrow> \<not> strong_fermat_liar"
 
 lemma fermat_liar_witness_of_composition[iff]:
   "\<not>fermat_liar = fermat_witness"
   "\<not>fermat_witness = fermat_liar"
   unfolding fermat_liar_def and fermat_witness_def
   by simp_all
 
 lemma strong_fermat_liar_code [code]:
   "strong_fermat_liar \<longleftrightarrow> 
      (let (m, k) = divide_out 2 (n - 1)
       in [a^m = 1](mod n) \<or> (\<exists>i \<in> {0..< k}. [a^(2 ^ i * m) = n-1] (mod n)))"
   (is "?lhs = ?rhs")
 proof (cases "n > 1")
   case True
   define m where "m = (n - 1) div 2 ^ multiplicity 2 (n - 1)"
   define k where "k = multiplicity 2 (n - 1)"
   have mk: "odd m \<and> n - 1 = 2 ^ k * m"
     using True multiplicity_decompose[of "n - 1" 2] multiplicity_dvd[of 2 "n - 1"]
     by (auto simp: m_def k_def)
   show ?thesis
   proof
     assume ?lhs
     hence "[a^m = 1] (mod n) \<or> (\<exists>i \<in> {0..< k}. [a^(2 ^ i * m) = n-1] (mod n))"
       using True mk by (auto simp: divide_out_def strong_fermat_liar_def)
     thus ?rhs by (auto simp: Let_def divide_out_def m_def k_def)
   next
     assume ?rhs
     thus ?lhs using divide_out_unique_nat[of 2]
       by (auto simp: strong_fermat_liar_def divide_out_def)
   qed
 qed (auto simp: strong_fermat_liar_def divide_out_def)
 
 
 context
   assumes * : "a \<in> {1 ..< n}"
 begin
 
 lemma strong_fermat_witness_iff:
   "strong_fermat_witness =
      (\<exists>k m. odd m \<and> n - 1 = 2 ^ k * m \<and> [a ^ m \<noteq> 1] (mod n) \<and> 
             (\<forall>i\<in>{0..<k}. [a ^ (2 ^ i * m) \<noteq> n-1] (mod n)))"
   unfolding strong_fermat_witness_def strong_fermat_liar_def
   by blast
 
 lemma not_coprime_imp_witness: "\<not>coprime a n \<Longrightarrow> fermat_witness"
   using * lucas_coprime_lemma[of "n-1" a n]
   by (auto simp: fermat_witness_def)
 
 corollary liar_imp_coprime: "fermat_liar \<Longrightarrow> coprime a n"
   using not_coprime_imp_witness fermat_liar_witness_of_composition by blast
 
 lemma fermat_witness_imp_strong_fermat_witness:
   assumes "1 < n" "fermat_witness"
   shows "strong_fermat_witness"
 proof -
   from \<open>fermat_witness\<close> have "[a^(n-1) \<noteq> 1] (mod n)"
     unfolding fermat_witness_def .
 
   obtain k m where "odd m" and n: "n - 1 = 2 ^ k * m"
     using * by (auto intro: multiplicity_decompose'[of "(n-1)" 2])
 
   moreover have "[a ^ m \<noteq> 1] (mod n)"
     using \<open>[a^(n-1) \<noteq> 1] (mod n)\<close> n ord_divides by auto
 
   moreover {
     fix i :: nat
     assume "i \<in> {0..<k}"
     hence "i \<le> k - 1" "0 < k" by auto
     then have "[a ^ (2 ^ i * m) \<noteq> n - 1] (mod n)" "[a ^ (2 ^ i * m) \<noteq> 1] (mod n)"
     proof(induction i rule: inc_induct)
       case base
         have * :"a ^ (n - 1) = (a ^ (2 ^ (k - 1) * m))\<^sup>2"
           using \<open>0 < k\<close> n semiring_normalization_rules(27)[of "2 :: nat" "k - 1"]
           by (auto simp flip: power_even_eq simp add: algebra_simps)
   
         case 1
         from * show ?case 
           using \<open>[a^(n-1) \<noteq> 1] (mod n)\<close> and square_minus_one_cong_one[OF \<open>1 < n\<close>] by auto
        
         case 2
         from * show ?case using n \<open>[a^(n-1) \<noteq> 1] (mod n)\<close> and square_one_cong_one by metis
     next
       case (step q)
       then have
         IH2: "[a ^ (2 ^ Suc q * m) \<noteq> 1] (mod n)" using \<open>0 < k\<close> by blast+
 
       have * : "a ^ (2 ^ Suc q * m) = (a ^ (2 ^ q * m))\<^sup>2"
         by (auto simp flip: power_even_eq simp add: algebra_simps)
 
       case 1
       from * show ?case using IH2 and square_minus_one_cong_one[OF \<open>1 < n\<close>] by auto
 
       case 2
       from * show ?case using IH2 and square_one_cong_one by metis
     qed
   }
 
   ultimately show ?thesis unfolding strong_fermat_witness_iff by blast
 qed
 
 corollary strong_fermat_liar_imp_fermat_liar:
   assumes "1 < n" "strong_fermat_liar"
   shows  "fermat_liar" 
     using fermat_witness_imp_strong_fermat_witness assms
     and fermat_liar_witness_of_composition strong_fermat_witness_def
     by blast
 
 lemma euler_liar_is_fermat_liar:
   assumes "1 < n" "euler_liar a n" "coprime a n" "odd n"
   shows "fermat_liar"
 proof -
   have "[Jacobi a n = a ^ ((n - 1) div 2)] (mod n)"
     using \<open>euler_liar a n\<close> unfolding euler_witness_def by simp
 
   hence "[(Jacobi a n)^2 = (a ^ ((n - 1) div 2))^2] (mod n)"
     by (simp add: cong_pow)
 
   moreover have "Jacobi a n \<in> {1, -1}"
     using Jacobi_values Jacobi_eq_0_iff_not_coprime[of n] \<open>coprime a n\<close> \<open>1 < n\<close>
     by force
 
   ultimately have "[1 = (a ^ ((n - 1) div 2))^2] (mod n)"
     using cong_int_iff by force
 
   also have "(a ^ ((n - 1) div 2))^2 = a ^ (n - 1)"
     using \<open>odd n\<close> by (simp flip: power_mult)
 
   finally show ?thesis 
     using cong_sym fermat_liar_def 
     by blast
 qed
 
 corollary fermat_witness_is_euler_witness:
   assumes "1 < n" "fermat_witness" "coprime a n" "odd n"
   shows "euler_witness a n"
   using assms euler_liar_is_fermat_liar fermat_liar_witness_of_composition
   by blast
 
 end
 end
 
 lemma one_is_fermat_liar[simp]: "1 < n \<Longrightarrow> fermat_liar 1 n"
   using fermat_liar_def by auto
 
 lemma one_is_strong_fermat_liar[simp]: "1 < n \<Longrightarrow> strong_fermat_liar 1 n"
   using strong_fermat_liar_def by auto
 
 lemma prime_imp_fermat_liar:
   "prime p \<Longrightarrow> a \<in> {1 ..< p} \<Longrightarrow> fermat_liar a p"
   unfolding fermat_liar_def
   using fermat_theorem and nat_dvd_not_less by simp
 
 lemma not_Carmichael_numberD:
   assumes "\<not>Carmichael_number n" "\<not>prime n"  and "1 < n"
   shows "\<exists> a \<in> {2 ..< n} . fermat_witness a n \<and> coprime a n"
 proof -
   obtain a where "coprime a n" "[a^(n-1) \<noteq> 1] (mod n)"
     using assms unfolding Carmichael_number_def by blast
 
   moreover from this and \<open>1 < n\<close> have "a mod n \<in> {1..<n}"
     by (cases "a = 0") (auto intro! : gre1I_nat)
 
   ultimately have "a mod n \<in> {1 ..< n}"  "coprime (a mod n) n" "[(a mod n)^(n-1) \<noteq> 1] (mod n)"
     using \<open>1 < n\<close> by simp_all
 
   hence "fermat_witness (a mod n) n"
     using fermat_witness_def by blast
 
   hence "1 \<noteq> (a mod n)"
     using \<open>1 < n\<close> \<open>(a mod n) \<in> {1 ..< n}\<close> and one_is_fermat_liar fermat_liar_witness_of_composition(1)
     by metis
 
   thus ?thesis
     using \<open>fermat_witness (a mod n) n\<close> \<open>coprime (a mod n) n\<close> \<open>(a mod n) \<in> {1..<n}\<close>
     by fastforce
 qed
 
 proposition prime_imp_strong_fermat_witness:
   fixes p :: nat
   assumes "prime p" "2 < p" "a \<in> {1 ..< p}"
   shows "strong_fermat_liar a p"
 proof -
   { fix k m :: nat
     define j where "j \<equiv> LEAST k. [a ^ (2^k * m) = 1] (mod p)"
 
     have "[a ^ (p - 1) = 1] (mod p)"
       using fermat_theorem[OF \<open>prime p\<close>, of a] \<open>a \<in> {1 ..< p}\<close> by force
 
     moreover assume "odd m" and n: "p - 1 = 2 ^ k * m"
 
     ultimately have "[a ^ (2 ^ k * m) = 1] (mod p)" by simp
 
     moreover assume "[a ^ m \<noteq> 1] (mod p)"
     then have "0 < x" if "[a ^ (2 ^ x * m) = 1] (mod p)" for x
       using that by (auto intro: gr0I)
 
     ultimately have "0 < j" "j \<le> k" "[a ^ (2 ^ j * m) = 1] (mod p)"
       using LeastI2[of _ k "(<) 0"] Least_le[of _ k] LeastI[of _ k]
       by (simp_all add: j_def)
 
     moreover from this have "[a ^ (2^(j-1) * m) \<noteq> 1] (mod p)"
       using not_less_Least[of "j - 1" "\<lambda>k. [a ^ (2^k * m) = 1] (mod p)"]
       unfolding j_def by simp
 
     moreover have "a ^ (2 ^ (j - 1) * m) * a ^ (2 ^ (j - 1) * m) = a ^ (2 ^ j * m)"
       using \<open>0 < j\<close>
       by (simp add: algebra_simps semiring_normalization_rules(27) flip: power2_eq_square power_even_eq)
 
     ultimately have "(j-1)\<in>{0..<k} " "[a ^ (2 ^ (j-1) * m) = p - 1] (mod p)"
       using cong_square_alt[OF \<open>prime p\<close>, of "a ^ (2 ^ (j-1) * m)"]
       by simp_all
   }
 
   then show ?thesis unfolding strong_fermat_liar_def by blast
 qed
 
 lemma ignore_one:
   fixes P :: "_ \<Rightarrow> nat \<Rightarrow> bool"
   assumes "P 1 n" "1 < n"
   shows "card {a \<in> {1..<n}. P a n} = 1 + card {a. 2 \<le> a \<and> a < n \<and> P a n}"
 proof -
   have "insert 1 {a. 2 \<le> a \<and> a < n \<and> P a n} = {a. 1 \<le> a \<and> a < n \<and> P a n}"
     using assms by auto
 
   moreover have "card (insert 1 {a. 2 \<le> a \<and> a < n \<and> P a n}) = Suc (card {a. 2 \<le> a \<and> a < n \<and> P a n})"
     using card_insert_disjoint by auto
   
   ultimately show ?thesis by force
 qed
 
 text \<open>Proofs in the following section are inspired by \cite{Cornwell, MillerRabinTest, lecture_notes}.\<close>
 
 proposition not_Carmichael_number_imp_card_fermat_witness_bound:
   fixes n :: nat
   assumes "\<not>prime n" "\<not>Carmichael_number n" "odd n" "1 < n"
   shows "(n-1) div 2 < card {a \<in> {1 ..< n}. fermat_witness a n}"
     and "(card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n}) < real (n - 2) / 2"
     and "(card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n}) < real (n - 2) / 2"
 proof -
   define G where "G = Residues_Mult n"
   interpret residues_mult_nat n G
     by unfold_locales (use \<open>n > 1\<close> in \<open>simp_all only: G_def\<close>)
   define h where "h \<equiv> \<lambda>a. a ^ (n - 1) mod n"
   define ker where "ker = kernel G (G\<lparr>carrier := h ` carrier G\<rparr>) h"
 
   have "finite ker" by (auto simp: ker_def kernel_def)
   moreover have "1 \<in> ker" using \<open>n > 1\<close> by (auto simp: ker_def kernel_def h_def)
   ultimately have [simp]: "card ker > 0"
-    by (subst card_gt_0_iff) (auto simp: ker_def kernel_def h_def)
+    by (subst card_gt_0_iff) auto
 
   have totatives_eq: "totatives n = {k\<in>{1..<n}. coprime k n}"
     using totatives_less[of _ n] \<open>n > 1\<close> by (force simp: totatives_def)
   have ker_altdef: "ker = {a \<in> {1..<n}. fermat_liar a n}"
     unfolding ker_def fermat_liar_def carrier_eq kernel_def totatives_eq using \<open>n > 1\<close>
     by (force simp: h_def cong_def intro: coprimeI_power_mod)
 
   have h_is_hom: "h \<in> hom G G" 
     unfolding hom_def using nat_pow_closed
     by (auto simp: h_def power_mult_distrib mod_simps)
   then interpret h: group_hom G G h
     by unfold_locales
 
   obtain a where a: "a \<in> {2..<n}" "fermat_witness a n" "coprime a n" 
     using assms power_one not_Carmichael_numberD by blast
 
   have "h a \<noteq> 1" using a by (auto simp: fermat_witness_def cong_def h_def)
   hence "2 \<le> card {1, h a}" by simp
   also have "\<dots> \<le> card (h ` carrier G)"
   proof (intro card_mono; safe?)
     from \<open>n > 1\<close> have "1 = h 1" by (simp add: h_def)
     also have "\<dots> \<in> h ` carrier G" by (intro imageI) (use \<open>n > 1\<close> in auto)
     finally show "1 \<in> h ` carrier G" .
   next
     show "h a \<in> h ` carrier G"
       using a by (intro imageI) (auto simp: totatives_def)
   qed auto
   also have "\<dots> * card ker = order G"
     using homomorphism_thm_order[OF h.group_hom_axioms] by (simp add: ker_def order_def)
   also have "order G < n - 1"
     using totient_less_not_prime[of n] assms by (simp add: order_eq)
   finally have "card ker < (n - 1) div 2"
     using \<open>odd n\<close> by (auto elim!: oddE)
 
   have "(n - 1) div 2 < (n - 1) - card ker"
     using \<open>card ker < (n - 1) div 2\<close> by linarith
   also have "\<dots> = card ({1..<n} - ker)"
     by (subst card_Diff_subset) (auto simp: ker_altdef)
   also have "{1..<n} - ker = {a \<in> {1..<n}. fermat_witness a n}"
     by (auto simp: fermat_witness_def fermat_liar_def ker_altdef)
   finally show "(n - 1) div 2 < card {a \<in> {1..<n}. fermat_witness a n}" .
 
   have "card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n} \<le> card (ker - {1})"
     by (intro card_mono) (auto simp: ker_altdef fermat_liar_def fermat_witness_def)
   also have "\<dots> = card ker - 1"
     using \<open>n > 1\<close> by (subst card_Diff_subset) (auto simp: ker_altdef fermat_liar_def)
   also have "\<dots> < (n - 2) div 2"
     using \<open>card ker < (n - 1) div 2\<close> \<open>odd n\<close> \<open>card ker > 0\<close> by linarith
   finally show *: "card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n} < real (n - 2) / 2"
     by simp
 
   have "card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n} \<le>
           card {a. 2 \<le> a \<and> a < n \<and> fermat_liar a n}"
     by (intro card_mono) (auto intro!: strong_fermat_liar_imp_fermat_liar)
   moreover note *
   ultimately show "card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n} < real (n - 2) / 2"
     by simp
 qed
 
 
 proposition Carmichael_number_imp_lower_bound_on_strong_fermat_witness:
   fixes n :: nat
   assumes Carmichael_number: "Carmichael_number n"
   shows "(n - 1) div 2 < card {a \<in> {1..<n}. strong_fermat_witness a n}"
     and "real (card {a . 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n}) < real (n - 2) / 2"
 proof -
   from assms have "n > 3" by (intro Carmichael_number_gt_3)
   hence "n - 1 \<noteq> 0" "\<not>is_unit (2 :: nat)" by auto
   obtain k m where "odd m" and n_less: "n - 1 = 2 ^ k * m"
     using multiplicity_decompose'[OF \<open>n - 1 \<noteq> 0\<close> \<open>\<not>is_unit (2::nat)\<close>] by metis
 
   obtain p l where n: "n = p * l" and "prime p" "\<not> p dvd l" "2 < l"
     using Carmichael_number_imp_squarefree_alt[OF Carmichael_number] 
     by blast
 
   then have "coprime p l" using prime_imp_coprime_nat by blast
 
   have "odd n" using Carmichael_number_odd Carmichael_number by simp
 
   have "2 < n" using \<open>n > 3\<close> \<open>odd n\<close> by presburger
 
   note prime_gt_1_nat[OF \<open>prime p\<close>]
 
   have "2 < p" using \<open>odd n\<close> n \<open>prime p\<close> prime_ge_2_nat
                and dvd_triv_left le_neq_implies_less by blast 
 
   let ?P = "\<lambda> k. (\<forall> a. coprime a p \<longrightarrow> [a^(2^k * m) = 1] (mod p))"
   define j where "j \<equiv> LEAST k. ?P k"
 
   define H where "H \<equiv> {a \<in> {1..<n} . coprime a n \<and> ([a^(2^(j-1) * m) = 1] (mod n) \<or>
                                                      [a^(2^(j-1) * m) = n - 1] (mod n))}"
 
   have k : "\<forall>a. coprime a n \<longrightarrow> [a ^ (2 ^ k * m) = 1] (mod n)"
     using Carmichael_number unfolding Carmichael_number_def n_less by blast
 
   obtain k' m' where "odd m'" and p_less: "p - 1 = 2 ^ k' * m'"
     using \<open>1 < p\<close> by (auto intro: multiplicity_decompose'[of "(p-1)" 2])
 
   have "p - 1 dvd n - 1"
     using Carmichael_number_imp_dvd[OF Carmichael_number \<open>prime p\<close>] \<open>n = p * l\<close>
     by fastforce
 
   then have "p - 1 dvd 2 ^ k' * m"
     unfolding n_less p_less
     using \<open>odd m\<close> \<open>odd m'\<close>
       and coprime_dvd_mult_left_iff[of "2^k'" m "2^k"] coprime_dvd_mult_right_iff[of m' "2^k" m]
     by auto
 
   have k': "\<forall>a. coprime a p \<longrightarrow> [a ^ (2 ^ k' * m) = 1] (mod p)"
   proof safe
     fix a
     assume "coprime a p"
     hence "\<not> p dvd a" using p_coprime_right_nat[OF \<open>prime p\<close>] by simp
 
     have "[a ^ (2 ^ k' * m') = 1] (mod p)"
      unfolding p_less[symmetric]
       using fermat_theorem \<open>prime p\<close> \<open>\<not> p dvd a\<close> by blast
 
     then show "[a ^ (2 ^ k' * m) = 1] (mod p)"
       using \<open>p - 1 dvd 2 ^ k' * m\<close>
       unfolding p_less n_less
       by (meson dvd_trans ord_divides)
   qed
 
   have j_prop: "[a^(2^j * m) = 1] (mod p)" if "coprime a p" for a
     using that LeastI[of ?P k', OF k', folded j_def] cong_modulus_mult coprime_mult_right_iff 
     unfolding j_def n by blast
 
   have j_least: "[a^(2^i * m) = 1] (mod p)" if "coprime a p" "j \<le> i" for a i
   proof -
     obtain c where i: "i = j + c" using le_iff_add[of j i] \<open>j \<le> i\<close> by blast
 
     then have "[a ^ (2 ^ i * m) = a ^ (2 ^ (j + c) * m)] (mod p)" by simp
     
     also have "[a ^ (2 ^ (j + c) * m) = (a ^ (2 ^ j * m)) ^ (2 ^ c)] (mod p)"
       by (simp flip: power_mult add: algebra_simps power_add)
     
     also note j_prop[OF \<open>coprime a p\<close>]
    
     also have "[1 ^ (2 ^ c) = 1] (mod p)" by simp
     
     finally show ?thesis .
   qed
 
   have neq_p: "[p - 1 \<noteq> 1](mod p)"
     using \<open>2 < p\<close> and cong_less_modulus_unique_nat[of "p-1" 1 p]
     by linarith
 
   have "0 < j"
   proof (rule LeastI2[of ?P k', OF k', folded j_def], rule gr0I)
     fix x
     assume "\<forall>a. coprime a p \<longrightarrow> [a ^ (2 ^ x * m) = 1] (mod p)"
     then have "[(p - 1) ^ (2 ^ x * m) = 1] (mod p)"
       using coprime_diff_one_left_nat[of p]  prime_gt_1_nat[OF \<open>prime p\<close>]
       by simp
     
     moreover assume "x = 0"
     hence "[(p-1)^(2^x*m) = p - 1](mod p)"
       using \<open>odd m\<close> odd_pow_cong[OF _ \<open>odd m\<close>, of p] prime_gt_1_nat[OF \<open>prime p\<close>]
       by auto
 
     ultimately show False
       using \<open>[p - 1 \<noteq> 1] (mod p)\<close> by (simp add: cong_def)
   qed
 
   then have "j - 1 < j" by simp
 
   then obtain x where "coprime x p" "[x^(2^(j-1) * m) \<noteq> 1] (mod p)"
     using not_less_Least[of "j - 1" ?P, folded j_def] unfolding j_def by blast
 
   define G where "G = Residues_Mult n"
   interpret residues_mult_nat n G
     by unfold_locales (use \<open>n > 3\<close> in \<open>simp_all only: G_def\<close>)
 
   have H_subset: "H \<subseteq> carrier G" unfolding H_def by (auto simp: totatives_def)
 
   from \<open>n > 3\<close> have \<open>n > 1\<close> by simp
   interpret H: subgroup H G
   proof (rule subgroupI, goal_cases)
     case 1
     then show ?case using H_subset .
   next
     case 2
     then show ?case unfolding H_def using \<open>1 < n\<close> by force
   next
     case (3 a)
     define y where "y = inv\<^bsub>G\<^esub> a"
 
     then have "y \<in> carrier G"
       using H_subset \<open>a \<in> H\<close> by (auto simp del: carrier_eq)
 
     then have "1 \<le> y" "y < n" "coprime y n"
       using totatives_less[of y n] \<open>n > 3\<close> by (auto simp: totatives_def)
 
     moreover have "[y ^ (2 ^ (j - Suc 0) * m) = Suc 0] (mod n)" 
       if "[y ^ (2 ^ (j - Suc 0) * m) \<noteq> n - Suc 0] (mod n)"
     proof -
       from \<open>a \<in> H\<close> have "[a * y = 1] (mod n)"
         using H_subset r_inv[of a] y_def by (auto simp: cong_def)
       hence "[(a * y) ^ (2 ^ (j - 1) * m) = 1 ^ (2 ^ (j - 1) * m)] (mod n)"
         by (intro cong_pow)
       hence "[(a * y) ^ (2 ^ (j - 1) * m) = 1] (mod n)"
         by simp
       hence * : "[a ^ (2 ^ (j - 1) * m) * y ^ (2 ^ (j - 1) * m) = 1] (mod n)"
           by (simp add: power_mult_distrib) 
       from \<open>a \<in> H\<close> have "1 \<le> a" "a < n" "coprime a n"
         unfolding H_def by auto
 
       have "[a ^ (2 ^ (j - 1) * m) = 1] (mod n) \<or> [a ^ (2 ^ (j - 1) * m) = n - 1] (mod n)"
         using \<open>a \<in> H\<close> by (auto simp: H_def)
       thus ?thesis
       proof
         note *
         also assume "[a ^ (2 ^ (j - 1) * m) = 1] (mod n)"
         finally show ?thesis by simp
       next
         assume "[a ^ (2 ^ (j - 1) * m) = n - 1] (mod n)"
         then have "[y ^ (2 ^ (j - 1) * m) = n - 1] (mod n)" 
           using minus_one_cong_solve[OF \<open>1 < n\<close>] * \<open>coprime a n\<close> \<open>coprime y n \<close>coprime_power_left_iff
           by blast+
         thus ?thesis using that by simp
       qed
     qed
 
     ultimately show ?case using \<open>a \<in> H\<close> unfolding H_def y_def by auto
   next
     case (4 a b)
     hence "a \<in> totatives n" "b \<in> totatives n"
       by (auto simp: H_def totatives_def)
     hence "a * b mod n \<in> totatives n"
       using m_closed[of a b] by simp
     hence "a * b mod n \<in> {1..<n}" "coprime (a * b) n"
       using totatives_less[of "a * b" n] \<open>n > 3\<close> by (auto simp: totatives_def)
 
     moreover define x y where "x = a ^ (2 ^ (j - 1) * m)" and "y = b ^ (2 ^ (j - 1) * m)"
     have "[x * y = 1] (mod n) \<or> [x * y = n - 1] (mod n)"
     proof -
       have *: "x mod n \<in> {1, n - 1}" "y mod n \<in> {1, n - 1}"
         using 4 by (auto simp: H_def x_def y_def cong_def)
       have "[x * y = (x mod n) * (y mod n)] (mod n)"
         by (intro cong_mult) auto
       moreover have "((x mod n) * (y mod n)) mod n \<in> {1, n - 1}"
         using * square_minus_one_cong_one'[OF \<open>1 < n\<close>] \<open>n > 1\<close> by (auto simp: cong_def)
       ultimately show ?thesis using \<open>n > 1\<close> by (simp add: cong_def mod_simps)
     qed
 
     ultimately show ?case by (auto simp: H_def x_def y_def power_mult_distrib)
   qed
 
   { obtain a where "[a = x] (mod p)" "[a = 1] (mod l)" "a < p * l"
       using binary_chinese_remainder_unique_nat[of p l x 1]
         and \<open>\<not> p dvd l\<close> \<open>prime p\<close> prime_imp_coprime_nat
       by auto
   
     moreover have "coprime a p"
       using \<open>coprime x p\<close> cong_imp_coprime[OF cong_sym[OF \<open>[a = x] (mod p)\<close>]] coprime_mult_right_iff
       unfolding n by blast
   
     moreover have "coprime a l" 
       using coprime_1_left cong_imp_coprime[OF cong_sym[OF \<open>[a = 1] (mod l)\<close>]]
       by blast
 
     moreover from \<open>prime p\<close> and \<open>coprime a p\<close> have "a > 0"
       by (intro Nat.gr0I) auto
  
     ultimately have "a \<in> carrier G"
       using \<open>2 < l\<close> by (auto intro: gre1I_nat simp: n totatives_def)
   
     have "[a ^ (2^(j-1) * m) \<noteq> 1] (mod p)"
       using \<open>[x^(2^(j-1) * m) \<noteq> 1] (mod p)\<close> \<open>[a = x] (mod p)\<close> and cong_trans cong_pow cong_sym
       by blast
 
     then have "[a ^ (2^(j-1) * m) \<noteq> 1] (mod n)"
       using cong_modulus_mult_nat n by fast
 
     moreover 
     have "[a ^ (2 ^ (j - Suc 0) * m) \<noteq> n - 1] (mod n)"
     proof -
       have "[a ^ (2 ^ (j - 1) * m) = 1] (mod l)"
       using cong_pow[OF \<open>[a = 1] (mod l)\<close>] by auto
   
       moreover have "Suc 0 \<noteq> (n - Suc 0) mod l"
         using n \<open>2 < l\<close> \<open>odd n\<close>
         by (metis mod_Suc_eq mod_less mod_mult_self2_is_0 numeral_2_eq_2 odd_Suc_minus_one zero_neq_numeral)
 
       then have "[1 \<noteq> n - 1] (mod l)"
           using \<open>2 < l\<close> \<open>odd n\<close> unfolding cong_def by simp
 
       moreover have "l \<noteq> Suc 0" using \<open>2 < l\<close> by simp
 
       ultimately have "[a ^ (2 ^ (j - Suc 0) * m) \<noteq> n - 1] (mod l)"
         by (auto simp add: cong_def n mod_simps dest: cong_modulus_mult_nat)
 
       then show ?thesis
         using cong_modulus_mult_nat mult.commute n by metis
     qed
 
     ultimately have "a \<notin> H" unfolding H_def by auto
   
     hence "H \<subset> carrier (G)"
       using H_subset subgroup.mem_carrier and \<open>a \<in> carrier (G)\<close> 
       by fast
   }
 
   have "card H \<le> order G div 2"
     by (intro proper_subgroup_imp_bound_on_card) (use \<open>H \<subset> carrier G\<close> H.is_subgroup in \<open>auto\<close>)
   also from assms have "\<not>prime n" by (auto dest: Carmichael_number_not_prime)
   hence "order G div 2 < (n - 1) div 2"
     using totient_less_not_prime[OF \<open>\<not> prime n\<close> \<open>1 < n\<close>] \<open>odd n\<close>
     by (auto simp add: order_eq elim!: oddE)
   finally have "card H < (n - 1) div 2" .
 
   {
     { fix a
       assume "1 \<le> a" "a < n"
       hence "a \<in> {1..<n}" by simp
   
       assume "coprime a n"
       then have "coprime a p" 
       unfolding n by simp
                  
       assume "[a ^ (2 ^ (j - 1) * m) \<noteq> 1] (mod n)" 
       hence "[a ^ m \<noteq> 1] (mod n)"
         by (metis dvd_trans dvd_triv_right ord_divides)
     
       moreover assume "strong_fermat_liar a n"
   
       ultimately obtain i where "i \<in> {0 ..< k}" "[a^(2^i * m) = n-1](mod n)"
         unfolding strong_fermat_liar_def using \<open>odd m\<close> n_less by blast
   
       then have "[a ^ (2 ^ i * m) = n - 1] (mod p)"
         unfolding n using cong_modulus_mult_nat by blast
   
       moreover have "[n - 1 \<noteq> 1] (mod p)"
       proof(subst cong_altdef_nat, goal_cases)
         case 1
         then show ?case using \<open>1 < n\<close> by linarith
       next
         case 2
         have "\<not> p dvd 2" using \<open>2 < p\<close> by (simp add: nat_dvd_not_less)
 
         moreover have "2 \<le> n" using \<open>1 < n\<close> by linarith
 
         moreover have "p dvd n" using n by simp
 
         ultimately have "\<not> p dvd n - 2" using dvd_diffD1 by blast
         
         then show ?case by (simp add: numeral_2_eq_2)
       qed
 
       ultimately have "[a ^ (2 ^ i * m) \<noteq> Suc 0] (mod p)" using cong_sym by (simp add: cong_def)
   
       then have "i < j" using j_least[OF \<open>coprime a p\<close>, of i] by force
   
       have "[(a ^ (2 ^ Suc i * m)) = 1] (mod n)"
         using square_minus_one_cong_one[OF \<open>1 < n\<close> \<open>[a^(2^i * m) = n-1](mod n)\<close>]
         by (simp add: power2_eq_square power_mult power_mult_distrib)
   
       { assume "i < j - 1"
   
         have "(2 :: nat) ^ (j - Suc 0) = ((2 ^ i) * 2 ^ (j - Suc i))"
           unfolding power_add[symmetric] using \<open>i < j - 1\<close> by simp
   
         then have "[a ^ (2 ^ (j - 1) * m) = (a ^ (2 ^ i * m)) ^ (2^(j - 1 - i))] (mod n)"
           by (auto intro!: cong_pow_I simp flip: power_mult simp add: algebra_simps power_add)
           
         also note \<open>[a ^ (2 ^ i * m) = n - 1] (mod n)\<close>
   
         also have "[(n - 1) ^ (2^(j - 1 - i)) = 1] (mod n) "
           using \<open>1 < n\<close> \<open>i < j - 1\<close> using even_pow_cong by auto
   
         finally have False
           using \<open>[a ^ (2 ^ (j - 1) * m) \<noteq> 1] (mod n)\<close>
           by blast
       }
 
       hence "i = j - 1" using \<open>i < j\<close> by fastforce
   
       hence "[a ^ (2 ^ (j - 1) * m) = n - 1] (mod n)" using \<open>[a^(2^i * m) = n-1](mod n)\<close> by simp
     }
   
     hence "{a \<in> {1..<n}. strong_fermat_liar a n} \<subseteq> H"
       using strong_fermat_liar_imp_fermat_liar[of _ n, OF _ \<open>1 < n\<close>]  liar_imp_coprime
       by (auto simp: H_def)
   }
 
   moreover have "finite H" unfolding H_def by auto
 
   ultimately have strong_fermat_liar_bounded: "card {a \<in> {1..<n}. strong_fermat_liar a n} < (n - 1) div 2 "
     using card_mono[of H] le_less_trans[OF _ \<open>card H < (n - 1) div 2\<close>] by blast
 
   moreover {
     have "{1..<n} - {a \<in> {1..<n}. strong_fermat_liar a n} = {a \<in> {1..<n}. strong_fermat_witness a n}"
       using strong_fermat_witness_def by blast
   
     then have "card {a \<in> {1..<n}. strong_fermat_witness a n} = (n-1) - card {a \<in> {1..<n}. strong_fermat_liar a n}"
       using card_Diff_subset[of "{a \<in> {1..<n}. strong_fermat_liar a n}" "{1..<n}"]
       by fastforce
   }
   
   ultimately show "(n - 1) div 2 < card {a \<in> {1..<n}. strong_fermat_witness a n}"
     by linarith
 
   show "real (card {a . 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n}) < real (n - 2) / 2"
     using strong_fermat_liar_bounded ignore_one one_is_strong_fermat_liar \<open>1 < n\<close> 
     by simp
 qed
 
 corollary strong_fermat_witness_lower_bound:
   assumes "odd n" "n > 2" "\<not>prime n"
   shows   "card {a. 2 \<le> a \<and> a < n \<and> strong_fermat_liar a n} < real (n - 2) / 2"
   using Carmichael_number_imp_lower_bound_on_strong_fermat_witness(2)[of n]
         not_Carmichael_number_imp_card_fermat_witness_bound(2)[of n] assms
   by (cases "Carmichael_number n") auto
 
 end
\ No newline at end of file
diff --git a/thys/Probabilistic_Prime_Tests/Generalized_Primality_Test.thy b/thys/Probabilistic_Prime_Tests/Generalized_Primality_Test.thy
--- a/thys/Probabilistic_Prime_Tests/Generalized_Primality_Test.thy
+++ b/thys/Probabilistic_Prime_Tests/Generalized_Primality_Test.thy
@@ -1,108 +1,108 @@
 (*
   File:     Generalized_Primality_Test.thy
   Authors:  Daniel Stüwe, Manuel Eberl
 
   Generic probabilistic primality test
 *)
 section \<open>A Generic View on Probabilistic Prime Tests\<close>
 theory Generalized_Primality_Test
 imports 
   "HOL-Probability.Probability" 
   Algebraic_Auxiliaries
 begin
 
 definition primality_test :: "(nat \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bool pmf" where
   "primality_test P n = 
     (if n < 3 \<or> even n then return_pmf (n = 2) else
       do {
         a \<leftarrow> pmf_of_set {2..< n};
         return_pmf (P n a)
       })"
 
 (* TODO Move *)
 lemma expectation_of_bool_is_pmf: "measure_pmf.expectation M of_bool = pmf M True"
   by (simp add: integral_measure_pmf_real[where A=UNIV] UNIV_bool)
 
 lemma eq_bernoulli_pmfI:
   assumes "pmf p True = x"
   shows   "p = bernoulli_pmf x"
 proof (intro pmf_eqI)
   fix b :: bool
   from assms have "x \<in> {0..1}" by (auto simp: pmf_le_1)
   thus "pmf p b = pmf (bernoulli_pmf x) b"
     using assms by (cases b) (auto simp: pmf_False_conv_True)
 qed
 
 text \<open>
   We require a probabilistic primality test to never classify a prime as composite.
   It may, however, mistakenly classify composites as primes.
 \<close>
 locale prob_primality_test =
   fixes P :: "nat \<Rightarrow> nat \<Rightarrow> bool" and n :: nat
   assumes P_works: "odd n \<Longrightarrow> 2 \<le> a \<Longrightarrow> a < n \<Longrightarrow> prime n \<Longrightarrow> P n a"
 begin
 
 lemma FalseD:
   assumes false: "False \<in> set_pmf (primality_test P n)"
   shows   "\<not> prime n"
 proof -
   from false consider "n \<noteq> 2" "n < 3" | "n \<noteq> 2" "even n" | 
       a where "\<not> P n a" "odd n" "2 \<le> a" "a < n"
     by (auto simp: primality_test_def not_less split: if_splits)
 
   then show ?thesis proof cases
   case 1
   then show ?thesis 
     by (cases rule: linorder_neqE_nat) (use prime_ge_2_nat[of n] in auto)
   next
     case 2
     then show ?thesis using primes_dvd_imp_eq two_is_prime_nat by blast
   next
     case 3
     then show ?thesis using P_works by blast
   qed 
 qed
 
 theorem prime:
   assumes odd_prime: "prime n"
   shows   "primality_test P n = return_pmf True"
 proof -
   have "set_pmf (primality_test P n) \<subseteq> {True, False}"
     by auto
   moreover from assms have "False \<notin> set_pmf (primality_test P n)"
     using FalseD by auto
   ultimately have "set_pmf (primality_test P n) \<subseteq> {True}"
     by auto
   thus ?thesis
     by (subst (asm) set_pmf_subset_singleton)
 qed
 
 end
 
 text \<open>
   We call a primality test \<open>q\<close>-good for a fixed positive real number \<open>q\<close> if the probability
   that it mistakenly classifies a composite as a prime is less than \<open>q\<close>.
 \<close>
 locale good_prob_primality_test = prob_primality_test +
   fixes q :: real
   assumes q_pos: "q > 0"
   assumes composite_witness_bound:
             "\<not>prime n \<Longrightarrow> 2 < n \<Longrightarrow> odd n \<Longrightarrow>
                real (card {a . 2 \<le> a \<and> a < n \<and> P n a}) < q * real (n - 2)"
 begin
 
 lemma composite_aux:
   assumes "\<not>prime n"
   shows   "measure_pmf.expectation (primality_test P n) of_bool < q"
   unfolding primality_test_def using assms composite_witness_bound q_pos
-  by (auto simp: pmf_expectation_bind[where A = "{2..< n}"] sum_of_bool_eq_card field_simps
-           simp flip: sum_divide_distrib)
+  by (clarsimp simp add: pmf_expectation_bind[where A = "{2..< n}"] sum_of_bool_eq_card field_simps Int_def
+    simp flip: sum_divide_distrib)
 
 theorem composite:
   assumes "\<not>prime n"
   shows   "pmf (primality_test P n) True < q"
   using composite_aux[OF assms] by (simp add: expectation_of_bool_is_pmf)
 
 end
 
 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,2196 +1,2194 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 (* 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)
+    by simp (auto 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)
+   apply (simp_all 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)
+  apply (simp_all add: bin_to_bl_aux_alt)
+  apply (simp_all 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
+  by (simp add: length_concat comp_def sum_list_triv)
 
 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)
   done
 
 lemma bin_rcat_bl: "bin_rcat n wl = bl_to_bin (concat (map (bin_to_bl n) wl))"
   apply (unfold bin_rcat_eq_foldl)
   apply (rule sym)
   apply (induct wl)
    apply (auto simp add: bl_to_bin_append)
   apply (simp add: bl_to_bin_aux_alt sclem)
   apply (simp add: bin_cat_foldl_lem [symmetric])
   done
 
 lemma bin_last_bl_to_bin: "bin_last (bl_to_bin bs) \<longleftrightarrow> bs \<noteq> [] \<and> last bs"
 by(cases "bs = []")(auto simp add: bl_to_bin_def last_bin_last'[where w=0])
 
 lemma bin_rest_bl_to_bin: "bin_rest (bl_to_bin bs) = bl_to_bin (butlast bs)"
 by(cases "bs = []")(simp_all add: bl_to_bin_def butlast_rest_bl2bin_aux)
 
 lemma bl_xor_aux_bin:
   "map2 (\<lambda>x y. x \<noteq> y) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v XOR w) (map2 (\<lambda>x y. x \<noteq> y) bs cs)"
   apply (induction n arbitrary: v w bs cs)
    apply auto
   apply (case_tac v rule: bin_exhaust)
   apply (case_tac w rule: bin_exhaust)
   apply clarsimp
   done
 
 lemma bl_or_aux_bin:
   "map2 (\<or>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v OR w) (map2 (\<or>) bs cs)"
   by (induct n arbitrary: v w bs cs) simp_all
 
 lemma bl_and_aux_bin:
   "map2 (\<and>) (bin_to_bl_aux n v bs) (bin_to_bl_aux n w cs) =
     bin_to_bl_aux n (v AND w) (map2 (\<and>) bs cs)"
   by (induction n arbitrary: v w bs cs) simp_all
 
 lemma bl_not_aux_bin: "map Not (bin_to_bl_aux n w cs) = bin_to_bl_aux n (NOT w) (map Not cs)"
   by (induct n arbitrary: w cs) auto
 
 lemma bl_not_bin: "map Not (bin_to_bl n w) = bin_to_bl n (NOT w)"
   by (simp add: bin_to_bl_def bl_not_aux_bin)
 
 lemma bl_and_bin: "map2 (\<and>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v AND w)"
   by (simp add: bin_to_bl_def bl_and_aux_bin)
 
 lemma bl_or_bin: "map2 (\<or>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v OR w)"
   by (simp add: bin_to_bl_def bl_or_aux_bin)
 
 lemma bl_xor_bin: "map2 (\<noteq>) (bin_to_bl n v) (bin_to_bl n w) = bin_to_bl n (v XOR w)"
   using bl_xor_aux_bin by (simp add: bin_to_bl_def)
 
 
 subsection \<open>Type \<^typ>\<open>'a word\<close>\<close>
 
 lift_definition of_bl :: \<open>bool list \<Rightarrow> 'a::len word\<close>
   is bl_to_bin .
 
 lift_definition to_bl :: \<open>'a::len word \<Rightarrow> bool list\<close>
   is \<open>bin_to_bl LENGTH('a)\<close>
   by (simp add: bl_to_bin_inj)
 
 lemma to_bl_eq:
   \<open>to_bl w = bin_to_bl (LENGTH('a)) (uint w)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma bit_of_bl_iff [bit_simps]:
   \<open>bit (of_bl bs :: 'a word) n \<longleftrightarrow> rev bs ! n \<and> n < LENGTH('a::len) \<and> n < length bs\<close>
   by transfer (simp add: bin_nth_of_bl ac_simps)
 
 lemma rev_to_bl_eq:
   \<open>rev (to_bl w) = map (bit w) [0..<LENGTH('a)]\<close>
   for w :: \<open>'a::len word\<close>
   apply (rule nth_equalityI)
    apply (simp add: to_bl.rep_eq)
   apply (simp add: bin_nth_bl bit_word.rep_eq to_bl.rep_eq)
   done
 
 lemma to_bl_eq_rev:
   \<open>to_bl w = map (bit w) (rev [0..<LENGTH('a)])\<close>
   for w :: \<open>'a::len word\<close>
   using rev_to_bl_eq [of w]
   apply (subst rev_is_rev_conv [symmetric])
   apply (simp add: rev_map)
   done
 
 lemma of_bl_rev_eq:
   \<open>of_bl (rev bs) = horner_sum of_bool 2 bs\<close>
   apply (rule bit_word_eqI)
   apply (simp add: bit_of_bl_iff)
   apply transfer
   apply (simp add: bit_horner_sum_bit_iff ac_simps)
   done
 
 lemma of_bl_eq:
   \<open>of_bl bs = horner_sum of_bool 2 (rev bs)\<close>
   using of_bl_rev_eq [of \<open>rev bs\<close>] by simp
 
 lemma bshiftr1_eq:
   \<open>bshiftr1 b w = of_bl (b # butlast (to_bl w))\<close>
   apply transfer
   apply auto
    apply (subst bl_to_bin_app_cat [of \<open>[True]\<close>, simplified])
    apply simp
    apply (metis One_nat_def add.commute bin_bl_bin bin_last_bl_to_bin bin_rest_bl_to_bin butlast_bin_rest concat_bit_eq last.simps list.distinct(1) list.size(3) list.size(4) odd_iff_mod_2_eq_one plus_1_eq_Suc power_Suc0_right push_bit_of_1 size_bin_to_bl take_bit_eq_mod trunc_bl2bin_len)
   apply (simp add: butlast_rest_bl2bin)
   done
 
 lemma length_to_bl_eq:
   \<open>length (to_bl w) = LENGTH('a)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer simp
 
 lemma word_rotr_eq:
   \<open>word_rotr n w = of_bl (rotater n (to_bl w))\<close>
   apply (rule bit_word_eqI)
   subgoal for n
     apply (cases \<open>n < LENGTH('a)\<close>)
      apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff rotater_rev length_to_bl_eq nth_rotate rev_to_bl_eq ac_simps)
     done
   done
 
 lemma word_rotl_eq:
   \<open>word_rotl n w = of_bl (rotate n (to_bl w))\<close>
 proof -
   have \<open>rotate n (to_bl w) = rev (rotater n (rev (to_bl w)))\<close>
     by (simp add: rotater_rev')
   then show ?thesis
     apply (simp add: word_rotl_eq_word_rotr bit_of_bl_iff length_to_bl_eq rev_to_bl_eq)
     apply (rule bit_word_eqI)
     subgoal for n
       apply (cases \<open>n < LENGTH('a)\<close>)
        apply (simp_all add: bit_word_rotr_iff bit_of_bl_iff nth_rotater)
       done
     done
 qed
 
 lemma to_bl_def': "(to_bl :: 'a::len word \<Rightarrow> bool list) = bin_to_bl (LENGTH('a)) \<circ> uint"
   by transfer (simp add: fun_eq_iff)
 
 \<comment> \<open>type definitions theorem for in terms of equivalent bool list\<close>
 lemma td_bl:
   "type_definition
     (to_bl :: 'a::len word \<Rightarrow> bool list)
     of_bl
     {bl. length bl = LENGTH('a)}"
   apply (standard; transfer)
   apply (auto dest: sym)
   done
 
 interpretation word_bl:
   type_definition
     "to_bl :: 'a::len word \<Rightarrow> bool list"
     of_bl
     "{bl. length bl = LENGTH('a::len)}"
   by (fact td_bl)
 
 lemmas word_bl_Rep' = word_bl.Rep [unfolded mem_Collect_eq, iff]
 
 lemma word_size_bl: "size w = size (to_bl w)"
   by (auto simp: word_size)
 
 lemma to_bl_use_of_bl: "to_bl w = bl \<longleftrightarrow> w = of_bl bl \<and> length bl = length (to_bl w)"
   by (fastforce elim!: word_bl.Abs_inverse [unfolded mem_Collect_eq])
 
 lemma length_bl_gt_0 [iff]: "0 < length (to_bl x)"
   for x :: "'a::len word"
   unfolding word_bl_Rep' by (rule len_gt_0)
 
 lemma bl_not_Nil [iff]: "to_bl x \<noteq> []"
   for x :: "'a::len word"
   by (fact length_bl_gt_0 [unfolded length_greater_0_conv])
 
 lemma length_bl_neq_0 [iff]: "length (to_bl x) \<noteq> 0"
   for x :: "'a::len word"
   by (fact length_bl_gt_0 [THEN gr_implies_not0])
 
 lemma hd_bl_sign_sint: "hd (to_bl w) = (bin_sign (sint w) = -1)"
   apply transfer
   apply (auto simp add: bin_sign_def)
   using bin_sign_lem bl_sbin_sign apply fastforce
   using bin_sign_lem bl_sbin_sign apply force
   done
 
 lemma of_bl_drop':
   "lend = length bl - LENGTH('a::len) \<Longrightarrow>
     of_bl (drop lend bl) = (of_bl bl :: 'a word)"
   by transfer (simp flip: trunc_bl2bin)
 
 lemma test_bit_of_bl:
   "(of_bl bl::'a::len word) !! n = (rev bl ! n \<and> n < LENGTH('a) \<and> n < length bl)"
   by transfer (simp add: bin_nth_of_bl ac_simps)
 
 lemma no_of_bl: "(numeral bin ::'a::len word) = of_bl (bin_to_bl (LENGTH('a)) (numeral bin))"
   by transfer simp
 
 lemma uint_bl: "to_bl w = bin_to_bl (size w) (uint w)"
   by transfer simp
 
 lemma to_bl_bin: "bl_to_bin (to_bl w) = uint w"
   by (simp add: uint_bl word_size)
 
 lemma to_bl_of_bin: "to_bl (word_of_int bin::'a::len word) = bin_to_bl (LENGTH('a)) bin"
   by (auto simp: uint_bl word_ubin.eq_norm word_size)
 
 lemma to_bl_numeral [simp]:
   "to_bl (numeral bin::'a::len word) =
     bin_to_bl (LENGTH('a)) (numeral bin)"
   unfolding word_numeral_alt by (rule to_bl_of_bin)
 
 lemma to_bl_neg_numeral [simp]:
   "to_bl (- numeral bin::'a::len word) =
     bin_to_bl (LENGTH('a)) (- numeral bin)"
   unfolding word_neg_numeral_alt by (rule to_bl_of_bin)
 
 lemma to_bl_to_bin [simp] : "bl_to_bin (to_bl w) = uint w"
   by (simp add: uint_bl word_size)
 
 lemma uint_bl_bin: "bl_to_bin (bin_to_bl (LENGTH('a)) (uint x)) = uint x"
   for x :: "'a::len word"
   by (rule trans [OF bin_bl_bin word_ubin.norm_Rep])
 
 lemma ucast_bl: "ucast w = of_bl (to_bl w)"
   by transfer simp
 
 lemma ucast_down_bl:
   \<open>(ucast :: 'a::len word \<Rightarrow> 'b::len word) (of_bl bl) = of_bl bl\<close>
     if \<open>is_down (ucast :: 'a::len word \<Rightarrow> 'b::len word)\<close>
   using that by transfer simp
 
 lemma of_bl_append_same: "of_bl (X @ to_bl w) = w"
   by transfer (simp add: bl_to_bin_app_cat)
 
 lemma ucast_of_bl_up:
   \<open>ucast (of_bl bl :: 'a::len word) = of_bl bl\<close>
   if \<open>size bl \<le> size (of_bl bl :: 'a::len word)\<close>
   using that
   apply transfer
   apply (rule bit_eqI)
   apply (auto simp add: bit_take_bit_iff)
   apply (subst (asm) trunc_bl2bin_len [symmetric])
   apply (auto simp only: bit_take_bit_iff)
   done
 
 lemma word_rev_tf:
   "to_bl (of_bl bl::'a::len word) =
     rev (takefill False (LENGTH('a)) (rev bl))"
   by transfer (simp add: bl_bin_bl_rtf)
 
 lemma word_rep_drop:
   "to_bl (of_bl bl::'a::len word) =
     replicate (LENGTH('a) - length bl) False @
     drop (length bl - LENGTH('a)) bl"
   by (simp add: word_rev_tf takefill_alt rev_take)
 
 lemma to_bl_ucast:
   "to_bl (ucast (w::'b::len word) ::'a::len word) =
     replicate (LENGTH('a) - LENGTH('b)) False @
     drop (LENGTH('b) - LENGTH('a)) (to_bl w)"
   apply (unfold ucast_bl)
   apply (rule trans)
    apply (rule word_rep_drop)
   apply simp
   done
 
 lemma ucast_up_app:
   \<open>to_bl (ucast w :: 'b::len word) = replicate n False @ (to_bl w)\<close>
     if \<open>source_size (ucast :: 'a word \<Rightarrow> 'b word) + n = target_size (ucast :: 'a word \<Rightarrow> 'b word)\<close>
     for w :: \<open>'a::len word\<close>
   using that
   by (auto simp add : source_size target_size to_bl_ucast)
 
 lemma ucast_down_drop [OF refl]:
   "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow>
     to_bl (uc w) = drop n (to_bl w)"
   by (auto simp add : source_size target_size to_bl_ucast)
 
 lemma scast_down_drop [OF refl]:
   "sc = scast \<Longrightarrow> source_size sc = target_size sc + n \<Longrightarrow>
     to_bl (sc w) = drop n (to_bl w)"
   apply (subgoal_tac "sc = ucast")
    apply safe
    apply simp
    apply (erule ucast_down_drop)
   apply (rule down_cast_same [symmetric])
   apply (simp add : source_size target_size is_down)
   done
 
 lemma word_0_bl [simp]: "of_bl [] = 0"
   by transfer simp
 
 lemma word_1_bl: "of_bl [True] = 1"
   by transfer (simp add: bl_to_bin_def)
 
 lemma of_bl_0 [simp]: "of_bl (replicate n False) = 0"
   by transfer (simp add: bl_to_bin_rep_False)
 
 lemma to_bl_0 [simp]: "to_bl (0::'a::len word) = replicate (LENGTH('a)) False"
   by (simp add: uint_bl word_size bin_to_bl_zero)
 
 \<comment> \<open>links with \<open>rbl\<close> operations\<close>
 lemma word_succ_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_succ w) = rev (rbl_succ (rev bl))"
   by transfer (simp add: rbl_succ)
 
 lemma word_pred_rbl: "to_bl w = bl \<Longrightarrow> to_bl (word_pred w) = rev (rbl_pred (rev bl))"
   by transfer (simp add: rbl_pred)
 
 lemma word_add_rbl:
   "to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
     to_bl (v + w) = rev (rbl_add (rev vbl) (rev wbl))"
   apply transfer
   apply (drule sym)
   apply (drule sym)
   apply (simp add: rbl_add)
   done
 
 lemma word_mult_rbl:
   "to_bl v = vbl \<Longrightarrow> to_bl w = wbl \<Longrightarrow>
     to_bl (v * w) = rev (rbl_mult (rev vbl) (rev wbl))"
   apply transfer
   apply (drule sym)
   apply (drule sym)
   apply (simp add: rbl_mult)
   done
 
 lemma rtb_rbl_ariths:
   "rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_succ w)) = rbl_succ ys"
   "rev (to_bl w) = ys \<Longrightarrow> rev (to_bl (word_pred w)) = rbl_pred ys"
   "rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v * w)) = rbl_mult ys xs"
   "rev (to_bl v) = ys \<Longrightarrow> rev (to_bl w) = xs \<Longrightarrow> rev (to_bl (v + w)) = rbl_add ys xs"
   by (auto simp: rev_swap [symmetric] word_succ_rbl word_pred_rbl word_mult_rbl word_add_rbl)
 
 lemma of_bl_length_less:
   \<open>(of_bl x :: 'a::len word) < 2 ^ k\<close>
     if \<open>length x = k\<close> \<open>k < LENGTH('a)\<close>
 proof -
   from that have \<open>length x < LENGTH('a)\<close>
     by simp
   then have \<open>(of_bl x :: 'a::len word) < 2 ^ length x\<close>
     apply (simp add: of_bl_eq)
     apply transfer
     apply (simp add: take_bit_horner_sum_bit_eq)
     apply (subst length_rev [symmetric])
     apply (simp only: horner_sum_of_bool_2_less)
     done
   with that show ?thesis
     by simp
 qed
 
 lemma word_eq_rbl_eq: "x = y \<longleftrightarrow> rev (to_bl x) = rev (to_bl y)"
   by simp
 
 lemma bl_word_not: "to_bl (NOT w) = map Not (to_bl w)"
   by transfer (simp add: bl_not_bin)
 
 lemma bl_word_xor: "to_bl (v XOR w) = map2 (\<noteq>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_xor_bin)
 
 lemma bl_word_or: "to_bl (v OR w) = map2 (\<or>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_or_bin)
 
 lemma bl_word_and: "to_bl (v AND w) = map2 (\<and>) (to_bl v) (to_bl w)"
   by transfer (simp flip: bl_and_bin)
 
 lemma bin_nth_uint': "bin_nth (uint w) n \<longleftrightarrow> rev (bin_to_bl (size w) (uint w)) ! n \<and> n < size w"
   apply (unfold word_size)
   apply (safe elim!: bin_nth_uint_imp)
    apply (frule bin_nth_uint_imp)
    apply (fast dest!: bin_nth_bl)+
   done
 
 lemmas bin_nth_uint = bin_nth_uint' [unfolded word_size]
 
 lemma test_bit_bl: "w !! n \<longleftrightarrow> rev (to_bl w) ! n \<and> n < size w"
   by transfer (auto simp add: bin_nth_bl)
 
 lemma to_bl_nth: "n < size w \<Longrightarrow> to_bl w ! n = w !! (size w - Suc n)"
   by (simp add: word_size rev_nth test_bit_bl)
 
 lemma map_bit_interval_eq:
   \<open>map (bit w) [0..<n] = takefill False n (rev (to_bl w))\<close> for w :: \<open>'a::len word\<close>
 proof (rule nth_equalityI)
   show \<open>length (map (bit w) [0..<n]) =
     length (takefill False n (rev (to_bl w)))\<close>
     by simp
   fix m
   assume \<open>m < length (map (bit w) [0..<n])\<close>
   then have \<open>m < n\<close>
     by simp
   then have \<open>bit w m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
     by (auto simp add: nth_takefill not_less rev_nth to_bl_nth word_size test_bit_word_eq dest: bit_imp_le_length)
   with \<open>m < n \<close>show \<open>map (bit w) [0..<n] ! m \<longleftrightarrow> takefill False n (rev (to_bl w)) ! m\<close>
     by simp
 qed
 
 lemma to_bl_unfold:
   \<open>to_bl w = rev (map (bit w) [0..<LENGTH('a)])\<close> for w :: \<open>'a::len word\<close>
   by (simp add: map_bit_interval_eq takefill_bintrunc to_bl_def flip: bin_to_bl_def)
 
 lemma nth_rev_to_bl:
   \<open>rev (to_bl w) ! n \<longleftrightarrow> bit w n\<close>
   if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
   using that by (simp add: to_bl_unfold)
 
 lemma nth_to_bl:
   \<open>to_bl w ! n \<longleftrightarrow> bit w (LENGTH('a) - Suc n)\<close>
   if \<open>n < LENGTH('a)\<close> for w :: \<open>'a::len word\<close>
   using that by (simp add: to_bl_unfold rev_nth)
 
 lemma of_bl_rep_False: "of_bl (replicate n False @ bs) = of_bl bs"
   by (auto simp: of_bl_def bl_to_bin_rep_F)
 
 lemma [code abstract]:
   \<open>Word.the_int (of_bl bs :: 'a word) = horner_sum of_bool 2 (take LENGTH('a::len) (rev bs))\<close>
   apply (simp add: of_bl_eq flip: take_bit_horner_sum_bit_eq)
   apply transfer
   apply simp
   done
 
 lemma [code]:
   \<open>to_bl w = map (bit w) (rev [0..<LENGTH('a::len)])\<close>
   for w :: \<open>'a::len word\<close>
   by (fact to_bl_eq_rev)
 
 lemma word_reverse_eq_of_bl_rev_to_bl:
   \<open>word_reverse w = of_bl (rev (to_bl w))\<close>
   by (rule bit_word_eqI)
     (auto simp add: bit_word_reverse_iff bit_of_bl_iff nth_to_bl)
 
 lemmas word_reverse_no_def [simp] =
   word_reverse_eq_of_bl_rev_to_bl [of "numeral w"] for w
 
 lemma to_bl_word_rev: "to_bl (word_reverse w) = rev (to_bl w)"
   by (rule nth_equalityI) (simp_all add: nth_rev_to_bl word_reverse_def word_rep_drop flip: of_bl_eq)
 
 lemma to_bl_n1 [simp]: "to_bl (-1::'a::len word) = replicate (LENGTH('a)) True"
   apply (rule word_bl.Abs_inverse')
    apply simp
   apply (rule word_eqI)
   apply (clarsimp simp add: word_size)
   apply (auto simp add: word_bl.Abs_inverse test_bit_bl word_size)
   done
 
 lemma rbl_word_or: "rev (to_bl (x OR y)) = map2 (\<or>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_or rev_map)
 
 lemma rbl_word_and: "rev (to_bl (x AND y)) = map2 (\<and>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_and rev_map)
 
 lemma rbl_word_xor: "rev (to_bl (x XOR y)) = map2 (\<noteq>) (rev (to_bl x)) (rev (to_bl y))"
   by (simp add: zip_rev bl_word_xor rev_map)
 
 lemma rbl_word_not: "rev (to_bl (NOT x)) = map Not (rev (to_bl x))"
   by (simp add: bl_word_not rev_map)
 
 lemma bshiftr1_numeral [simp]:
   \<open>bshiftr1 b (numeral w :: 'a word) = of_bl (b # butlast (bin_to_bl LENGTH('a::len) (numeral w)))\<close>
   by (simp add: bshiftr1_eq)
 
 lemma bshiftr1_bl: "to_bl (bshiftr1 b w) = b # butlast (to_bl w)"
   unfolding bshiftr1_eq by (rule word_bl.Abs_inverse) simp
 
 lemma shiftl1_of_bl: "shiftl1 (of_bl bl) = of_bl (bl @ [False])"
   by transfer (simp add: bl_to_bin_append)
 
 lemma shiftl1_bl: "shiftl1 w = of_bl (to_bl w @ [False])"
   for w :: "'a::len word"
 proof -
   have "shiftl1 w = shiftl1 (of_bl (to_bl w))"
     by simp
   also have "\<dots> = of_bl (to_bl w @ [False])"
     by (rule shiftl1_of_bl)
   finally show ?thesis .
 qed
 
 lemma bl_shiftl1: "to_bl (shiftl1 w) = tl (to_bl w) @ [False]"
   for w :: "'a::len word"
   by (simp add: shiftl1_bl word_rep_drop drop_Suc drop_Cons') (fast intro!: Suc_leI)
 
 \<comment> \<open>Generalized version of \<open>bl_shiftl1\<close>. Maybe this one should replace it?\<close>
 lemma bl_shiftl1': "to_bl (shiftl1 w) = tl (to_bl w @ [False])"
   by (simp add: shiftl1_bl word_rep_drop drop_Suc del: drop_append)
 
 lemma shiftr1_bl:
   \<open>shiftr1 w = of_bl (butlast (to_bl w))\<close>
 proof (rule bit_word_eqI)
   fix n
   assume \<open>n < LENGTH('a)\<close>
   show \<open>bit (shiftr1 w) n \<longleftrightarrow> bit (of_bl (butlast (to_bl w)) :: 'a word) n\<close>
   proof (cases \<open>n = LENGTH('a) - 1\<close>)
     case True
     then show ?thesis
       by (simp add: bit_shiftr1_iff bit_of_bl_iff)
   next
     case False
     with \<open>n < LENGTH('a)\<close>
     have \<open>n < LENGTH('a) - 1\<close>
       by simp
     with \<open>n < LENGTH('a)\<close> show ?thesis
       by (simp add: bit_shiftr1_iff bit_of_bl_iff rev_nth nth_butlast
         word_size test_bit_word_eq to_bl_nth)
   qed
 qed
 
 lemma bl_shiftr1: "to_bl (shiftr1 w) = False # butlast (to_bl w)"
   for w :: "'a::len word"
   by (simp add: shiftr1_bl word_rep_drop len_gt_0 [THEN Suc_leI])
 
 \<comment> \<open>Generalized version of \<open>bl_shiftr1\<close>. Maybe this one should replace it?\<close>
 lemma bl_shiftr1': "to_bl (shiftr1 w) = butlast (False # to_bl w)"
   apply (rule word_bl.Abs_inverse')
    apply (simp del: butlast.simps)
   apply (simp add: shiftr1_bl of_bl_def)
   done
 
 lemma bl_sshiftr1: "to_bl (sshiftr1 w) = hd (to_bl w) # butlast (to_bl w)"
   for w :: "'a::len word"
 proof (rule nth_equalityI)
   fix n
   assume \<open>n < length (to_bl (sshiftr1 w))\<close>
   then have \<open>n < LENGTH('a)\<close>
     by simp
   then show \<open>to_bl (sshiftr1 w) ! n \<longleftrightarrow> (hd (to_bl w) # butlast (to_bl w)) ! n\<close>
     apply (cases n)
      apply (simp_all add: to_bl_nth word_size hd_conv_nth test_bit_eq_bit bit_sshiftr1_iff nth_butlast Suc_diff_Suc nth_to_bl)
     done
 qed simp
 
 lemma drop_shiftr: "drop n (to_bl (w >> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
   apply (unfold shiftr_def)
   apply (induct n)
    prefer 2
    apply (simp add: drop_Suc bl_shiftr1 butlast_drop [symmetric])
    apply (rule butlast_take [THEN trans])
     apply (auto simp: word_size)
   done
 
 lemma drop_sshiftr: "drop n (to_bl (w >>> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
    apply (simp_all add: word_size sshiftr_eq)
   apply (rule nth_equalityI)
    apply (simp_all add: word_size nth_to_bl bit_signed_drop_bit_iff)
   done
 
 lemma take_shiftr: "n \<le> size w \<Longrightarrow> take n (to_bl (w >> n)) = replicate n False"
   apply (unfold shiftr_def)
   apply (induct n)
    prefer 2
    apply (simp add: bl_shiftr1' length_0_conv [symmetric] word_size)
    apply (rule take_butlast [THEN trans])
     apply (auto simp: word_size)
   done
 
 lemma take_sshiftr':
   "n \<le> size w \<Longrightarrow> hd (to_bl (w >>> n)) = hd (to_bl w) \<and>
     take n (to_bl (w >>> n)) = replicate n (hd (to_bl w))"
   for w :: "'a::len word"
   apply (auto simp add: sshiftr_eq hd_bl_sign_sint bin_sign_def not_le word_size sint_signed_drop_bit_eq)
   apply (rule nth_equalityI)
     apply (auto simp add: nth_to_bl bit_signed_drop_bit_iff bit_last_iff)
   apply (rule nth_equalityI)
    apply (auto simp add: nth_to_bl bit_signed_drop_bit_iff bit_last_iff)
   done
 
 lemmas hd_sshiftr = take_sshiftr' [THEN conjunct1]
 lemmas take_sshiftr = take_sshiftr' [THEN conjunct2]
 
 lemma atd_lem: "take n xs = t \<Longrightarrow> drop n xs = d \<Longrightarrow> xs = t @ d"
   by (auto intro: append_take_drop_id [symmetric])
 
 lemmas bl_shiftr = atd_lem [OF take_shiftr drop_shiftr]
 lemmas bl_sshiftr = atd_lem [OF take_sshiftr drop_sshiftr]
 
 lemma shiftl_of_bl: "of_bl bl << n = of_bl (bl @ replicate n False)"
   by (induct n) (auto simp: shiftl_def shiftl1_of_bl replicate_app_Cons_same)
 
 lemma shiftl_bl: "w << n = of_bl (to_bl w @ replicate n False)"
   for w :: "'a::len word"
 proof -
   have "w << n = of_bl (to_bl w) << n"
     by simp
   also have "\<dots> = of_bl (to_bl w @ replicate n False)"
     by (rule shiftl_of_bl)
   finally show ?thesis .
 qed
 
 lemma bl_shiftl: "to_bl (w << n) = drop n (to_bl w) @ replicate (min (size w) n) False"
   by (simp add: shiftl_bl word_rep_drop word_size)
 
 lemma shiftr1_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
     shiftr1 (of_bl bl::'a::len word) = of_bl (butlast bl)"
   by transfer (simp add: butlast_rest_bl2bin trunc_bl2bin)
 
 lemma shiftr_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
     (of_bl bl::'a::len word) >> n = of_bl (take (length bl - n) bl)"
   apply (unfold shiftr_def)
   apply (induct n)
    apply clarsimp
   apply clarsimp
   apply (subst shiftr1_bl_of)
    apply simp
   apply (simp add: butlast_take)
   done
 
 lemma shiftr_bl: "x >> n \<equiv> of_bl (take (LENGTH('a) - n) (to_bl x))"
   for x :: "'a::len word"
   using shiftr_bl_of [where 'a='a, of "to_bl x"] by simp
 
 lemma aligned_bl_add_size [OF refl]:
   "size x - n = m \<Longrightarrow> n \<le> size x \<Longrightarrow> drop m (to_bl x) = replicate n False \<Longrightarrow>
     take m (to_bl y) = replicate m False \<Longrightarrow>
     to_bl (x + y) = take m (to_bl x) @ drop m (to_bl y)" for x :: \<open>'a::len word\<close>
   apply (subgoal_tac "x AND y = 0")
    prefer 2
    apply (rule word_bl.Rep_eqD)
    apply (simp add: bl_word_and)
    apply (rule align_lem_and [THEN trans])
        apply (simp_all add: word_size)[5]
    apply simp
   apply (subst word_plus_and_or [symmetric])
   apply (simp add : bl_word_or)
   apply (rule align_lem_or)
      apply (simp_all add: word_size)
   done
 
 lemma mask_bl: "mask n = of_bl (replicate n True)"
   by (auto simp add : test_bit_of_bl word_size intro: word_eqI)
 
 lemma bl_and_mask':
   "to_bl (w AND mask n :: 'a::len word) =
     replicate (LENGTH('a) - n) False @
     drop (LENGTH('a) - n) (to_bl w)"
   apply (rule nth_equalityI)
    apply simp
   apply (clarsimp simp add: to_bl_nth word_size)
   apply (auto simp add: word_size test_bit_bl nth_append rev_nth)
   done
 
 lemma slice1_eq_of_bl:
   \<open>(slice1 n w :: 'b::len word) = of_bl (takefill False n (to_bl w))\<close>
   for w :: \<open>'a::len word\<close>
 proof (rule bit_word_eqI)
   fix m
   assume \<open>m < LENGTH('b)\<close>
   show \<open>bit (slice1 n w :: 'b::len word) m \<longleftrightarrow> bit (of_bl (takefill False n (to_bl w)) :: 'b word) m\<close>
     by (cases \<open>m \<ge> n\<close>; cases \<open>LENGTH('a) \<ge> n\<close>)
       (auto simp add: bit_slice1_iff bit_of_bl_iff not_less rev_nth not_le nth_takefill nth_to_bl algebra_simps)
 qed
 
 lemma slice1_no_bin [simp]:
   "slice1 n (numeral w :: 'b word) = of_bl (takefill False n (bin_to_bl (LENGTH('b::len)) (numeral w)))"
   by (simp add: slice1_eq_of_bl) (* TODO: neg_numeral *)
 
 lemma slice_no_bin [simp]:
   "slice n (numeral w :: 'b word) = of_bl (takefill False (LENGTH('b::len) - n)
     (bin_to_bl (LENGTH('b::len)) (numeral w)))"
   by (simp add: slice_def) (* TODO: neg_numeral *)
 
 lemma slice_take': "slice n w = of_bl (take (size w - n) (to_bl w))"
   by (simp add: slice_def word_size slice1_eq_of_bl takefill_alt)
 
 lemmas slice_take = slice_take' [unfolded word_size]
 
 \<comment> \<open>shiftr to a word of the same size is just slice,
     slice is just shiftr then ucast\<close>
 lemmas shiftr_slice = trans [OF shiftr_bl [THEN meta_eq_to_obj_eq] slice_take [symmetric]]
 
 lemma slice1_down_alt':
   "sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs + k = n \<Longrightarrow>
     to_bl sl = takefill False fs (drop k (to_bl w))"
   apply (simp add: slice1_eq_of_bl)
   apply transfer
   apply (simp add: bl_bin_bl_rep_drop)
   using drop_takefill
   apply force
   done
 
 lemma slice1_up_alt':
   "sl = slice1 n w \<Longrightarrow> fs = size sl \<Longrightarrow> fs = n + k \<Longrightarrow>
     to_bl sl = takefill False fs (replicate k False @ (to_bl w))"
   apply (simp add: slice1_eq_of_bl)
   apply transfer
   apply (simp add: bl_bin_bl_rep_drop flip: takefill_append)
   apply (metis diff_add_inverse)
   done
 
 lemmas sd1 = slice1_down_alt' [OF refl refl, unfolded word_size]
 lemmas su1 = slice1_up_alt' [OF refl refl, unfolded word_size]
 lemmas slice1_down_alt = le_add_diff_inverse [THEN sd1]
 lemmas slice1_up_alts =
   le_add_diff_inverse [symmetric, THEN su1]
   le_add_diff_inverse2 [symmetric, THEN su1]
 
 lemma slice1_tf_tf':
   "to_bl (slice1 n w :: 'a::len word) =
     rev (takefill False (LENGTH('a)) (rev (takefill False n (to_bl w))))"
   unfolding slice1_eq_of_bl by (rule word_rev_tf)
 
 lemmas slice1_tf_tf = slice1_tf_tf' [THEN word_bl.Rep_inverse', symmetric]
 
 lemma revcast_eq_of_bl:
   \<open>(revcast w :: 'b::len word) = of_bl (takefill False (LENGTH('b)) (to_bl w))\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: revcast_def slice1_eq_of_bl)
 
 lemmas revcast_no_def [simp] = revcast_eq_of_bl [where w="numeral w", unfolded word_size] for w
 
 lemma to_bl_revcast:
   "to_bl (revcast w :: 'a::len word) = takefill False (LENGTH('a)) (to_bl w)"
   apply (rule nth_equalityI)
   apply simp
   apply (cases \<open>LENGTH('a) \<le> LENGTH('b)\<close>)
    apply (auto simp add: nth_to_bl nth_takefill bit_revcast_iff)
   done
 
 lemma word_cat_bl: "word_cat a b = of_bl (to_bl a @ to_bl b)"
   apply (rule bit_word_eqI)
   apply (simp add: bit_word_cat_iff bit_of_bl_iff nth_append not_less nth_rev_to_bl)
   apply (meson bit_word.rep_eq less_diff_conv2 nth_rev_to_bl)
   done
 
 lemma of_bl_append:
   "(of_bl (xs @ ys) :: 'a::len word) = of_bl xs * 2^(length ys) + of_bl ys"
   apply transfer
   apply (simp add: bl_to_bin_app_cat bin_cat_num)
   done
 
 lemma of_bl_False [simp]: "of_bl (False#xs) = of_bl xs"
   by (rule word_eqI) (auto simp: test_bit_of_bl nth_append)
 
 lemma of_bl_True [simp]: "(of_bl (True # xs) :: 'a::len word) = 2^length xs + of_bl xs"
   by (subst of_bl_append [where xs="[True]", simplified]) (simp add: word_1_bl)
 
 lemma of_bl_Cons: "of_bl (x#xs) = of_bool x * 2^length xs + of_bl xs"
   by (cases x) simp_all
 
 lemma word_split_bl':
   "std = size c - size b \<Longrightarrow> (word_split c = (a, b)) \<Longrightarrow>
     (a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c)))"
   apply (simp add: word_split_def)
   apply transfer
   apply (cases \<open>LENGTH('b) \<le> LENGTH('a)\<close>)
    apply (auto simp add: drop_bit_take_bit drop_bin2bl bin_to_bl_drop_bit [symmetric, of \<open>LENGTH('a)\<close> \<open>LENGTH('a) - LENGTH('b)\<close> \<open>LENGTH('b)\<close>] min_absorb2)
   done
 
 lemma word_split_bl: "std = size c - size b \<Longrightarrow>
     (a = of_bl (take std (to_bl c)) \<and> b = of_bl (drop std (to_bl c))) \<longleftrightarrow>
     word_split c = (a, b)"
   apply (rule iffI)
    defer
    apply (erule (1) word_split_bl')
   apply (case_tac "word_split c")
   apply (auto simp add: word_size)
   apply (frule word_split_bl' [rotated])
    apply (auto simp add: word_size)
   done
 
 lemma word_split_bl_eq:
   "(word_split c :: ('c::len word \<times> 'd::len word)) =
     (of_bl (take (LENGTH('a::len) - LENGTH('d::len)) (to_bl c)),
      of_bl (drop (LENGTH('a) - LENGTH('d)) (to_bl c)))"
   for c :: "'a::len word"
   apply (rule word_split_bl [THEN iffD1])
    apply (unfold word_size)
    apply (rule refl conjI)+
   done
 
 lemma word_rcat_bl:
   \<open>word_rcat wl = of_bl (concat (map to_bl wl))\<close>
 proof -
   define ws where \<open>ws = rev wl\<close>
   moreover have \<open>word_rcat (rev ws) = of_bl (concat (map to_bl (rev ws)))\<close>
     apply (simp add: word_rcat_def of_bl_eq rev_concat rev_map comp_def rev_to_bl_eq flip: horner_sum_of_bool_2_concat)
     apply transfer
     apply simp
     done
   ultimately show ?thesis
     by simp
 qed
 
 lemma size_rcat_lem': "size (concat (map to_bl wl)) = length wl * size (hd wl)"
   by (induct wl) (auto simp: word_size)
 
 lemmas size_rcat_lem = size_rcat_lem' [unfolded word_size]
 
 lemma nth_rcat_lem:
   "n < length (wl::'a word list) * LENGTH('a::len) \<Longrightarrow>
     rev (concat (map to_bl wl)) ! n =
     rev (to_bl (rev wl ! (n div LENGTH('a)))) ! (n mod LENGTH('a))"
   apply (induct wl)
    apply clarsimp
   apply (clarsimp simp add : nth_append size_rcat_lem)
   apply (simp flip: mult_Suc minus_div_mult_eq_mod add: less_Suc_eq_le not_less)
   apply (metis (no_types, lifting) diff_is_0_eq div_le_mono len_not_eq_0 less_Suc_eq less_mult_imp_div_less nonzero_mult_div_cancel_right not_le nth_Cons_0)
   done
 
 lemma foldl_eq_foldr: "foldl (+) x xs = foldr (+) (x # xs) 0"
   for x :: "'a::comm_monoid_add"
   by (induct xs arbitrary: x) (auto simp: add.assoc)
 
 lemmas word_cat_bl_no_bin [simp] =
   word_cat_bl [where a="numeral a" and b="numeral b", unfolded to_bl_numeral]
   for a b (* FIXME: negative numerals, 0 and 1 *)
 
 lemmas word_split_bl_no_bin [simp] =
   word_split_bl_eq [where c="numeral c", unfolded to_bl_numeral] for c
 
 lemmas word_rot_defs = word_roti_eq_word_rotr_word_rotl word_rotr_eq word_rotl_eq
 
 lemma to_bl_rotl: "to_bl (word_rotl n w) = rotate n (to_bl w)"
   by (simp add: word_rotl_eq to_bl_use_of_bl)
 
 lemmas blrs0 = rotate_eqs [THEN to_bl_rotl [THEN trans]]
 
 lemmas word_rotl_eqs =
   blrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotl [symmetric]]
 
 lemma to_bl_rotr: "to_bl (word_rotr n w) = rotater n (to_bl w)"
   by (simp add: word_rotr_eq to_bl_use_of_bl)
 
 lemmas brrs0 = rotater_eqs [THEN to_bl_rotr [THEN trans]]
 
 lemmas word_rotr_eqs =
   brrs0 [simplified word_bl_Rep' word_bl.Rep_inject to_bl_rotr [symmetric]]
 
 declare word_rotr_eqs (1) [simp]
 declare word_rotl_eqs (1) [simp]
 
 lemmas abl_cong = arg_cong [where f = "of_bl"]
 
 locale word_rotate
 begin
 
 lemmas word_rot_defs' = to_bl_rotl to_bl_rotr
 
 lemmas blwl_syms [symmetric] = bl_word_not bl_word_and bl_word_or bl_word_xor
 
 lemmas lbl_lbl = trans [OF word_bl_Rep' word_bl_Rep' [symmetric]]
 
 lemmas ths_map2 [OF lbl_lbl] = rotate_map2 rotater_map2
 
 lemmas ths_map [where xs = "to_bl v"] = rotate_map rotater_map for v
 
 lemmas th1s [simplified word_rot_defs' [symmetric]] = ths_map2 ths_map
 
 end
 
 lemmas bl_word_rotl_dt = trans [OF to_bl_rotl rotate_drop_take,
   simplified word_bl_Rep']
 
 lemmas bl_word_rotr_dt = trans [OF to_bl_rotr rotater_drop_take,
   simplified word_bl_Rep']
 
 lemma bl_word_roti_dt':
   "n = nat ((- i) mod int (size (w :: 'a::len word))) \<Longrightarrow>
     to_bl (word_roti i w) = drop n (to_bl w) @ take n (to_bl w)"
   apply (unfold word_roti_eq_word_rotr_word_rotl)
   apply (simp add: bl_word_rotl_dt bl_word_rotr_dt word_size)
   apply safe
    apply (simp add: zmod_zminus1_eq_if)
    apply safe
     apply (simp add: nat_mult_distrib)
    apply (simp add: nat_diff_distrib [OF pos_mod_sign pos_mod_conj
                                       [THEN conjunct2, THEN order_less_imp_le]]
                     nat_mod_distrib)
   apply (simp add: nat_mod_distrib)
   done
 
 lemmas bl_word_roti_dt = bl_word_roti_dt' [unfolded word_size]
 
 lemmas word_rotl_dt = bl_word_rotl_dt [THEN word_bl.Rep_inverse' [symmetric]]
 lemmas word_rotr_dt = bl_word_rotr_dt [THEN word_bl.Rep_inverse' [symmetric]]
 lemmas word_roti_dt = bl_word_roti_dt [THEN word_bl.Rep_inverse' [symmetric]]
 
 lemmas word_rotr_dt_no_bin' [simp] =
   word_rotr_dt [where w="numeral w", unfolded to_bl_numeral] for w
   (* FIXME: negative numerals, 0 and 1 *)
 
 lemmas word_rotl_dt_no_bin' [simp] =
   word_rotl_dt [where w="numeral w", unfolded to_bl_numeral] for w
   (* FIXME: negative numerals, 0 and 1 *)
 
 lemma max_word_bl: "to_bl (max_word::'a::len word) = replicate LENGTH('a) True"
   by (fact to_bl_n1)
 
 lemma to_bl_mask:
   "to_bl (mask n :: 'a::len word) =
   replicate (LENGTH('a) - n) False @
     replicate (min (LENGTH('a)) n) True"
   by (simp add: mask_bl word_rep_drop min_def)
 
 lemma map_replicate_True:
   "n = length xs \<Longrightarrow>
     map (\<lambda>(x,y). x \<and> y) (zip xs (replicate n True)) = xs"
   by (induct xs arbitrary: n) auto
 
 lemma map_replicate_False:
   "n = length xs \<Longrightarrow> map (\<lambda>(x,y). x \<and> y)
     (zip xs (replicate n False)) = replicate n False"
   by (induct xs arbitrary: n) auto
 
 lemma bl_and_mask:
   fixes w :: "'a::len word"
     and n :: nat
   defines "n' \<equiv> LENGTH('a) - n"
   shows "to_bl (w AND mask n) = replicate n' False @ drop n' (to_bl w)"
 proof -
   note [simp] = map_replicate_True map_replicate_False
   have "to_bl (w AND mask n) = map2 (\<and>) (to_bl w) (to_bl (mask n::'a::len word))"
     by (simp add: bl_word_and)
   also have "to_bl w = take n' (to_bl w) @ drop n' (to_bl w)"
     by simp
   also have "map2 (\<and>) \<dots> (to_bl (mask n::'a::len word)) =
       replicate n' False @ drop n' (to_bl w)"
     unfolding to_bl_mask n'_def by (subst zip_append) auto
   finally show ?thesis .
 qed
 
 lemma drop_rev_takefill:
   "length xs \<le> n \<Longrightarrow>
     drop (n - length xs) (rev (takefill False n (rev xs))) = xs"
   by (simp add: takefill_alt rev_take)
 
 declare bin_to_bl_def [simp]
 
 lemmas of_bl_reasoning = to_bl_use_of_bl of_bl_append
 
 lemma uint_of_bl_is_bl_to_bin_drop:
   "length (dropWhile Not l) \<le> LENGTH('a) \<Longrightarrow> uint (of_bl l :: 'a::len word) = bl_to_bin l"
   apply transfer
   apply (simp add: take_bit_eq_mod)
   apply (rule Divides.mod_less)
    apply (rule bl_to_bin_ge0)
   using bl_to_bin_lt2p_drop apply (rule order.strict_trans2)
   apply simp
   done
 
 corollary uint_of_bl_is_bl_to_bin:
   "length l\<le>LENGTH('a) \<Longrightarrow> uint ((of_bl::bool list\<Rightarrow> ('a :: len) word) l) = bl_to_bin l"
   apply(rule uint_of_bl_is_bl_to_bin_drop)
   using le_trans length_dropWhile_le by blast
 
 lemma bin_to_bl_or:
   "bin_to_bl n (a OR b) = map2 (\<or>) (bin_to_bl n a) (bin_to_bl n b)"
   using bl_or_aux_bin[where n=n and v=a and w=b and bs="[]" and cs="[]"]
   by simp
 
 lemma word_and_1_bl:
   fixes x::"'a::len word"
   shows "(x AND 1) = of_bl [x !! 0]"
   by (simp add: mod_2_eq_odd test_bit_word_eq and_one_eq)
 
 lemma word_1_and_bl:
   fixes x::"'a::len word"
   shows "(1 AND x) = of_bl [x !! 0]"
   by (simp add: mod_2_eq_odd test_bit_word_eq one_and_eq)
 
 lemma of_bl_drop:
   "of_bl (drop n xs) = (of_bl xs AND mask (length xs - n))"
   apply (clarsimp simp: bang_eq test_bit_of_bl rev_nth cong: rev_conj_cong)
   apply (safe; simp add: word_size to_bl_nth)
   done
 
 lemma to_bl_1:
   "to_bl (1::'a::len word) = replicate (LENGTH('a) - 1) False @ [True]"
   by (rule nth_equalityI) (auto simp add: to_bl_unfold nth_append rev_nth bit_1_iff not_less not_le)
 
 lemma eq_zero_set_bl:
   "(w = 0) = (True \<notin> set (to_bl w))"
   apply (auto simp add: to_bl_unfold)
   apply (rule bit_word_eqI)
   apply auto
   done
 
 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 unat_of_nat)
 next
   case False
   have "unat (of_bl xs::'a::len word) < 2 ^ LENGTH('a)"
     by (simp split: unat_split)
   also
   from False
   have "LENGTH('a) \<le> length xs" by simp
   then have "2 ^ LENGTH('a) \<le> (2::nat) ^ length xs"
     by (rule power_increasing) simp
   finally
   show ?thesis .
 qed
 
 lemma word_msb_alt: "msb w \<longleftrightarrow> hd (to_bl w)"
   for w :: "'a::len word"
   apply (simp add: msb_word_eq)
   apply (subst hd_conv_nth)
    apply simp
   apply (subst nth_to_bl)
    apply simp
   apply simp
   done
 
 lemma word_lsb_last:
   \<open>lsb w \<longleftrightarrow> last (to_bl w)\<close>
   for w :: \<open>'a::len word\<close>
   using nth_to_bl [of \<open>LENGTH('a) - Suc 0\<close> w]
   by (simp add: lsb_odd last_conv_nth)
 
 lemma is_aligned_to_bl:
   "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
   apply (simp add: is_aligned_mask eq_zero_set_bl)
   apply (clarsimp simp: in_set_conv_nth word_size)
   apply (simp add: to_bl_nth word_size cong: conj_cong)
   apply (simp add: diff_diff_less)
   apply safe
    apply (case_tac "n \<le> LENGTH('a)")
     prefer 2
     apply (rule_tac x=i in exI)
     apply clarsimp
    apply (subgoal_tac "\<exists>j < LENGTH('a). j < n \<and> LENGTH('a) - n + j = i")
     apply (erule exE)
     apply (rule_tac x=j in exI)
     apply clarsimp
    apply (thin_tac "w !! t" for t)
    apply (rule_tac x="i + n - LENGTH('a)" in exI)
    apply clarsimp
    apply arith
   apply (rule_tac x="LENGTH('a) - n + i" in exI)
   apply clarsimp
   apply arith
   done
 
 lemma is_aligned_replicate:
   fixes w::"'a::len word"
   assumes aligned: "is_aligned w n"
   and          nv: "n \<le> LENGTH('a)"
   shows   "to_bl w = (take (LENGTH('a) - n) (to_bl w)) @ replicate n False"
 proof -
   from nv have rl: "\<And>q. q < 2 ^ (LENGTH('a) - n) \<Longrightarrow>
       to_bl (2 ^ n * (of_nat q :: 'a word)) =
       drop n (to_bl (of_nat q :: 'a word)) @ replicate n False"
     by (metis bl_shiftl le_antisym min_def shiftl_t2n wsst_TYs(3))
   show ?thesis using aligned
     by (auto simp: rl elim: is_alignedE)
 qed
 
 lemma is_aligned_drop:
   fixes w::"'a::len word"
   assumes "is_aligned w n" "n \<le> LENGTH('a)"
   shows "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
 proof -
   have "to_bl w = take (LENGTH('a) - n) (to_bl w) @ replicate n False"
     by (rule is_aligned_replicate) fact+
   then have "drop (LENGTH('a) - n) (to_bl w) = drop (LENGTH('a) - n) \<dots>" by simp
   also have "\<dots> = replicate n False" by simp
   finally show ?thesis .
 qed
 
 lemma less_is_drop_replicate:
   fixes x::"'a::len word"
   assumes lt: "x < 2 ^ n"
   shows   "to_bl x = replicate (LENGTH('a) - n) False @ drop (LENGTH('a) - n) (to_bl x)"
   by (metis assms bl_and_mask' less_mask_eq)
 
 lemma is_aligned_add_conv:
   fixes off::"'a::len word"
   assumes aligned: "is_aligned w n"
   and        offv: "off < 2 ^ n"
   shows    "to_bl (w + off) =
    (take (LENGTH('a) - n) (to_bl w)) @ (drop (LENGTH('a) - n) (to_bl off))"
 proof cases
   assume nv: "n \<le> LENGTH('a)"
   show ?thesis
   proof (subst aligned_bl_add_size, simp_all only: word_size)
     show "drop (LENGTH('a) - n) (to_bl w) = replicate n False"
       by (subst is_aligned_replicate [OF aligned nv]) (simp add: word_size)
 
     from offv show "take (LENGTH('a) - n) (to_bl off) =
                     replicate (LENGTH('a) - n) False"
       by (subst less_is_drop_replicate, assumption) simp
   qed fact
 next
   assume "\<not> n \<le> LENGTH('a)"
   with offv show ?thesis by (simp add: power_overflow)
 qed
 
 lemma is_aligned_replicateI:
   "to_bl p = addr @ replicate n False \<Longrightarrow> is_aligned (p::'a::len word) n"
   apply (simp add: is_aligned_to_bl word_size)
   apply (subgoal_tac "length addr = LENGTH('a) - n")
    apply (simp add: replicate_not_True)
   apply (drule arg_cong [where f=length])
   apply simp
   done
 
 lemma to_bl_2p:
   "n < LENGTH('a) \<Longrightarrow>
    to_bl ((2::'a::len word) ^ n) =
    replicate (LENGTH('a) - Suc n) False @ True # replicate n False"
   apply (subst shiftl_1 [symmetric])
   apply (subst bl_shiftl)
   apply (simp add: to_bl_1 min_def word_size)
   done
 
 lemma xor_2p_to_bl:
   fixes x::"'a::len word"
   shows "to_bl (x XOR 2^n) =
   (if n < LENGTH('a)
    then take (LENGTH('a)-Suc n) (to_bl x) @ (\<not>rev (to_bl x)!n) # drop (LENGTH('a)-n) (to_bl x)
    else to_bl x)"
 proof -
   have x: "to_bl x = take (LENGTH('a)-Suc n) (to_bl x) @ drop (LENGTH('a)-Suc n) (to_bl x)"
     by simp
 
   show ?thesis
   apply simp
   apply (rule conjI)
    apply (clarsimp simp: word_size)
    apply (simp add: bl_word_xor to_bl_2p)
    apply (subst x)
    apply (subst zip_append)
     apply simp
    apply (simp add: map_zip_replicate_False_xor drop_minus)
   apply (auto simp add: word_size nth_w2p intro!: word_eqI)
   done
 qed
 
 lemma is_aligned_replicateD:
   "\<lbrakk> is_aligned (w::'a::len word) n; n \<le> LENGTH('a) \<rbrakk>
      \<Longrightarrow> \<exists>xs. to_bl w = xs @ replicate n False
                \<and> length xs = size w - n"
   apply (subst is_aligned_replicate, assumption+)
   apply (rule exI, rule conjI, rule refl)
   apply (simp add: word_size)
   done
 
 text \<open>right-padding a word to a certain length\<close>
 
 definition
   "bl_pad_to bl sz \<equiv> bl @ (replicate (sz - length bl) False)"
 
 lemma bl_pad_to_length:
   assumes lbl: "length bl \<le> sz"
   shows   "length (bl_pad_to bl sz) = sz"
   using lbl by (simp add: bl_pad_to_def)
 
 lemma bl_pad_to_prefix:
   "prefix bl (bl_pad_to bl sz)"
   by (simp add: bl_pad_to_def)
 
 
 lemma of_bl_length:
   "length xs < LENGTH('a) \<Longrightarrow> of_bl xs < (2 :: 'a::len word) ^ length xs"
   by (simp add: of_bl_length_less)
 
 lemma of_bl_mult_and_not_mask_eq:
   "\<lbrakk>is_aligned (a :: 'a::len word) n; length b + m \<le> n\<rbrakk>
    \<Longrightarrow> a + of_bl b * (2^m) AND NOT(mask n) = a"
   apply (simp flip: push_bit_eq_mult subtract_mask(1) take_bit_eq_mask)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps not_le not_less)
    apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
   apply (erule is_alignedE')
   apply (simp add: take_bit_push_bit)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps)
   done
 
 lemma bin_to_bl_of_bl_eq:
   "\<lbrakk>is_aligned (a::'a::len word) n; length b + c \<le> n; length b + c < LENGTH('a)\<rbrakk>
   \<Longrightarrow> bin_to_bl (length b) (uint ((a + of_bl b * 2^c) >> c)) = b"
   apply (simp flip: push_bit_eq_mult take_bit_eq_mask add: shiftr_eq_drop_bit)
   apply (subst disjunctive_add)
    apply (auto simp add: bit_simps not_le not_less unsigned_or_eq unsigned_drop_bit_eq
      unsigned_push_bit_eq bin_to_bl_or simp flip: bin_to_bl_def)
    apply (meson is_aligned_imp_not_bit is_aligned_weaken less_diff_conv2)
   apply (erule is_alignedE')
   apply (rule nth_equalityI)
    apply (auto simp add: nth_bin_to_bl bit_simps rev_nth simp flip: bin_to_bl_def)
   done
 
 (* FIXME: move to Word distribution *)
 lemma bin_nth_minus_Bit0[simp]:
   "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit0 w)) n = bin_nth (numeral w) (n - 1)"
   by (cases n; simp)
 
 lemma bin_nth_minus_Bit1[simp]:
   "0 < n \<Longrightarrow> bin_nth (numeral (num.Bit1 w)) n = bin_nth (numeral w) (n - 1)"
   by (cases n; simp)
 
 (* casting a long word to a shorter word and casting back to the long word
    is equal to the original long word -- if the word is small enough.
   'l is the longer word.
   's is the shorter word.
 *)
 lemma bl_cast_long_short_long_ingoreLeadingZero_generic:
   "\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
    (of_bl :: _ \<Rightarrow> 'l::len word) (to_bl ((of_bl::_ \<Rightarrow> 's::len word) (to_bl w))) = w"
   by (rule word_uint_eqI) (simp add: uint_of_bl_is_bl_to_bin uint_of_bl_is_bl_to_bin_drop)
 
 (*
  Casting between longer and shorter word.
   'l is the longer word.
   's is the shorter word.
  For example: 'l::len word is 128 word (full ipv6 address)
               's::len word is 16 word (address piece of ipv6 address in colon-text-representation)
 *)
 corollary ucast_short_ucast_long_ingoreLeadingZero:
   "\<lbrakk> length (dropWhile Not (to_bl w)) \<le> LENGTH('s); LENGTH('s) \<le> LENGTH('l) \<rbrakk> \<Longrightarrow>
    (ucast:: 's::len word \<Rightarrow> 'l::len word) ((ucast:: 'l::len word \<Rightarrow> 's::len word) w) = w"
   apply (subst ucast_bl)+
   apply (rule bl_cast_long_short_long_ingoreLeadingZero_generic; simp)
   done
 
 lemma length_drop_mask:
   fixes w::"'a::len word"
   shows "length (dropWhile Not (to_bl (w AND mask n))) \<le> n"
 proof -
   have "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
     for ls n by(subst takeWhile_append2) simp+
   then show ?thesis
     unfolding bl_and_mask by (simp add: dropWhile_eq_drop)
 qed
 
 lemma map_bits_rev_to_bl:
   "map ((!!) x) [0..<size x] = rev (to_bl x)"
   by (auto simp: list_eq_iff_nth_eq test_bit_bl word_size)
 
 lemma of_bl_length2:
   "length xs + c < LENGTH('a) \<Longrightarrow> of_bl xs * 2^c < (2::'a::len word) ^ (length xs + c)"
   by (simp add: of_bl_length word_less_power_trans2)
 
 lemma of_bl_max:
   "(of_bl xs :: 'a::len word) \<le> mask (length xs)"
 proof -
   define ys where \<open>ys = rev xs\<close>
   have \<open>take_bit (length ys) (horner_sum of_bool 2 ys :: 'a word) = horner_sum of_bool 2 ys\<close>
     by transfer (simp add: take_bit_horner_sum_bit_eq min_def)
   then have \<open>(of_bl (rev ys) :: 'a word) \<le> mask (length ys)\<close>
     by (simp only: of_bl_rev_eq less_eq_mask_iff_take_bit_eq_self)
   with ys_def show ?thesis
     by simp
 qed
 
 end
diff --git a/thys/Word_Lib/Strict_part_mono.thy b/thys/Word_Lib/Strict_part_mono.thy
--- a/thys/Word_Lib/Strict_part_mono.thy
+++ b/thys/Word_Lib/Strict_part_mono.thy
@@ -1,56 +1,56 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 theory Strict_part_mono
   imports "HOL-Library.Word" More_Word
 begin
 
 definition
   strict_part_mono :: "'a set \<Rightarrow> ('a :: order \<Rightarrow> 'b :: order) \<Rightarrow> bool" where
  "strict_part_mono S f \<equiv> \<forall>A\<in>S. \<forall>B\<in>S. A < B \<longrightarrow> f A < f B"
 
 lemma strict_part_mono_by_steps:
   "strict_part_mono {..n :: nat} f = (n \<noteq> 0 \<longrightarrow> f (n - 1) < f n \<and> strict_part_mono {.. n - 1} f)"
   apply (cases n; simp add: strict_part_mono_def)
   apply (safe; clarsimp)
   apply (case_tac "B = Suc nat"; simp)
   apply (case_tac "A = nat"; clarsimp)
   apply (erule order_less_trans [rotated])
   apply simp
   done
 
 lemma strict_part_mono_singleton[simp]:
   "strict_part_mono {x} f"
   by (simp add: strict_part_mono_def)
 
 lemma strict_part_mono_lt:
   "\<lbrakk> x < f 0; strict_part_mono {.. n :: nat} f \<rbrakk> \<Longrightarrow> \<forall>m \<le> n. x < f m"
-  by (metis atMost_iff le_0_eq le_cases neq0_conv order.strict_trans strict_part_mono_def)
+  by (auto simp add: strict_part_mono_def Ball_def intro: order.strict_trans)
 
 lemma strict_part_mono_reverseE:
   "\<lbrakk> f n \<le> f m; strict_part_mono {.. N :: nat} f; n \<le> N \<rbrakk> \<Longrightarrow> n \<le> m"
   by (rule ccontr) (fastforce simp: linorder_not_le strict_part_mono_def)
 
 lemma two_power_strict_part_mono:
   "strict_part_mono {..LENGTH('a) - 1} (\<lambda>x. (2 :: 'a :: len word) ^ x)"
 proof -
   { fix n
     have "n < LENGTH('a) \<Longrightarrow> strict_part_mono {..n} (\<lambda>x. (2 :: 'a :: len word) ^ x)"
     proof (induct n)
       case 0 then show ?case by simp
     next
       case (Suc n)
       from Suc.prems
       have "2 ^ n < (2 :: 'a :: len word) ^ Suc n"
         using power_strict_increasing unat_power_lower word_less_nat_alt by fastforce
       with Suc
       show ?case by (subst strict_part_mono_by_steps) simp
     qed
   }
   then show ?thesis by simp
 qed
 
 end
diff --git a/thys/Word_Lib/Traditional_Infix_Syntax.thy b/thys/Word_Lib/Traditional_Infix_Syntax.thy
--- a/thys/Word_Lib/Traditional_Infix_Syntax.thy
+++ b/thys/Word_Lib/Traditional_Infix_Syntax.thy
@@ -1,1073 +1,1077 @@
 (*
  * Copyright Data61, CSIRO (ABN 41 687 119 230)
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 (* Author: Jeremy Dawson, NICTA *)
 
 section \<open>Operation variants with traditional syntax\<close>
 
 theory Traditional_Infix_Syntax
   imports "HOL-Library.Word" More_Word Signed_Words
 begin
 
 class semiring_bit_syntax = semiring_bit_shifts
 begin
 
 definition test_bit :: \<open>'a \<Rightarrow> nat \<Rightarrow> bool\<close>  (infixl "!!" 100)
   where test_bit_eq_bit: \<open>test_bit = bit\<close>
 
 definition shiftl :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl "<<" 55)
   where shiftl_eq_push_bit: \<open>a << n = push_bit n a\<close>
 
 definition shiftr :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close>  (infixl ">>" 55)
   where shiftr_eq_drop_bit: \<open>a >> n = drop_bit n a\<close>
 
 end
 
 instance word :: (len) semiring_bit_syntax ..
 
 context
   includes lifting_syntax
 begin
 
 lemma test_bit_word_transfer [transfer_rule]:
   \<open>(pcr_word ===> (=)) (\<lambda>k n. n < LENGTH('a) \<and> bit k n) (test_bit :: 'a::len word \<Rightarrow> _)\<close>
   by (unfold test_bit_eq_bit) transfer_prover
 
 lemma shiftl_word_transfer [transfer_rule]:
   \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. push_bit n k) shiftl\<close>
   by (unfold shiftl_eq_push_bit) transfer_prover
 
 lemma shiftr_word_transfer [transfer_rule]:
   \<open>(pcr_word ===> (=) ===> pcr_word) (\<lambda>k n. (drop_bit n \<circ> take_bit LENGTH('a)) k) (shiftr :: 'a::len word \<Rightarrow> _)\<close>
   by (unfold shiftr_eq_drop_bit) transfer_prover
 
 end
 
 
 lemma test_bit_word_eq:
   \<open>test_bit = (bit :: 'a::len word \<Rightarrow> _)\<close>
   by (fact test_bit_eq_bit)
 
 lemma shiftl_word_eq:
   \<open>w << n = push_bit n w\<close> for w :: \<open>'a::len word\<close>
   by (fact shiftl_eq_push_bit)
 
 lemma shiftr_word_eq:
   \<open>w >> n = drop_bit n w\<close> for w :: \<open>'a::len word\<close>
   by (fact shiftr_eq_drop_bit)
 
 lemma test_bit_eq_iff: "test_bit u = test_bit v \<longleftrightarrow> u = v"
   for u v :: "'a::len word"
   by (simp add: bit_eq_iff test_bit_eq_bit fun_eq_iff)
 
 lemma test_bit_size: "w !! n \<Longrightarrow> n < size w"
   for w :: "'a::len word"
   by transfer simp
 
 lemma word_eq_iff: "x = y \<longleftrightarrow> (\<forall>n<LENGTH('a). x !! n = y !! n)" (is \<open>?P \<longleftrightarrow> ?Q\<close>)
   for x y :: "'a::len word"
   by transfer (auto simp add: bit_eq_iff bit_take_bit_iff)
 
 lemma word_eqI: "(\<And>n. n < size u \<longrightarrow> u !! n = v !! n) \<Longrightarrow> u = v"
   for u :: "'a::len word"
   by (simp add: word_size word_eq_iff)
 
 lemma word_eqD: "u = v \<Longrightarrow> u !! x = v !! x"
   for u v :: "'a::len word"
   by simp
 
 lemma test_bit_bin': "w !! n \<longleftrightarrow> n < size w \<and> bit (uint w) n"
   by transfer (simp add: bit_take_bit_iff)
 
 lemmas test_bit_bin = test_bit_bin' [unfolded word_size]
 
 lemma word_test_bit_def:
   \<open>test_bit a = bit (uint a)\<close>
   by transfer (simp add: fun_eq_iff bit_take_bit_iff)
 
 lemmas test_bit_def' = word_test_bit_def [THEN fun_cong]
 
 lemma word_test_bit_transfer [transfer_rule]:
   "(rel_fun pcr_word (rel_fun (=) (=)))
     (\<lambda>x n. n < LENGTH('a) \<and> bit x n) (test_bit :: 'a::len word \<Rightarrow> _)"
   by (simp only: test_bit_eq_bit) transfer_prover
 
 lemma test_bit_wi [simp]:
   "(word_of_int x :: 'a::len word) !! n \<longleftrightarrow> n < LENGTH('a) \<and> bit x n"
   by transfer simp
 
 lemma word_ops_nth_size:
   "n < size x \<Longrightarrow>
     (x OR y) !! n = (x !! n | y !! n) \<and>
     (x AND y) !! n = (x !! n \<and> y !! n) \<and>
     (x XOR y) !! n = (x !! n \<noteq> y !! n) \<and>
     (NOT x) !! n = (\<not> x !! n)"
   for x :: "'a::len word"
   by transfer (simp add: bit_or_iff bit_and_iff bit_xor_iff bit_not_iff)
 
 lemma word_ao_nth:
   "(x OR y) !! n = (x !! n | y !! n) \<and>
     (x AND y) !! n = (x !! n \<and> y !! n)"
   for x :: "'a::len word"
   by transfer (auto simp add: bit_or_iff bit_and_iff)
 
 lemmas msb0 = len_gt_0 [THEN diff_Suc_less, THEN word_ops_nth_size [unfolded word_size]]
 lemmas msb1 = msb0 [where i = 0]
 
 lemma test_bit_numeral [simp]:
   "(numeral w :: 'a::len word) !! n \<longleftrightarrow>
     n < LENGTH('a) \<and> bit (numeral w :: int) n"
   by transfer (rule refl)
 
 lemma test_bit_neg_numeral [simp]:
   "(- numeral w :: 'a::len word) !! n \<longleftrightarrow>
     n < LENGTH('a) \<and> bit (- numeral w :: int) n"
   by transfer (rule refl)
 
 lemma test_bit_1 [iff]: "(1 :: 'a::len word) !! n \<longleftrightarrow> n = 0"
   by transfer (auto simp add: bit_1_iff)
 
 lemma nth_0 [simp]: "\<not> (0 :: 'a::len word) !! n"
   by transfer simp
 
 lemma nth_minus1 [simp]: "(-1 :: 'a::len word) !! n \<longleftrightarrow> n < LENGTH('a)"
   by transfer simp
 
 lemma shiftl1_code [code]:
   \<open>shiftl1 w = push_bit 1 w\<close>
   by transfer (simp add: ac_simps)
 
 lemma uint_shiftr_eq:
   \<open>uint (w >> n) = uint w div 2 ^ n\<close>
   by transfer (simp flip: drop_bit_eq_div add: drop_bit_take_bit min_def le_less less_diff_conv)
 
 lemma shiftr1_code [code]:
   \<open>shiftr1 w = drop_bit 1 w\<close>
   by transfer (simp add: drop_bit_Suc)
 
 lemma shiftl_def:
   \<open>w << n = (shiftl1 ^^ n) w\<close>
 proof -
   have \<open>push_bit n = (((*) 2 ^^ n) :: int \<Rightarrow> int)\<close> for n
     by (induction n) (simp_all add: fun_eq_iff funpow_swap1, simp add: ac_simps)
   then show ?thesis
     by transfer simp
 qed
 
 lemma shiftr_def:
   \<open>w >> n = (shiftr1 ^^ n) w\<close>
 proof -
   have \<open>shiftr1 ^^ n = (drop_bit n :: 'a word \<Rightarrow> 'a word)\<close>
     apply (induction n)
     apply simp
     apply (simp only: shiftr1_eq_div_2 [abs_def] drop_bit_eq_div [abs_def] funpow_Suc_right)
     apply (use div_exp_eq [of _ 1, where ?'a = \<open>'a word\<close>] in simp)
     done
   then show ?thesis
     by (simp add: shiftr_eq_drop_bit)
 qed
 
 lemma bit_shiftl_word_iff [bit_simps]:
   \<open>bit (w << m) n \<longleftrightarrow> m \<le> n \<and> n < LENGTH('a) \<and> bit w (n - m)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: shiftl_word_eq bit_push_bit_iff not_le)
 
 lemma bit_shiftr_word_iff [bit_simps]:
   \<open>bit (w >> m) n \<longleftrightarrow> bit w (m + n)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: shiftr_word_eq bit_drop_bit_eq)
 
 lift_definition sshiftr :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> 'a word\<close>  (infixl \<open>>>>\<close> 55)
   is \<open>\<lambda>k n. take_bit LENGTH('a) (drop_bit n (signed_take_bit (LENGTH('a) - Suc 0) k))\<close>
   by (simp flip: signed_take_bit_decr_length_iff)
 
 lemma sshiftr_eq [code]:
   \<open>w >>> n = signed_drop_bit n w\<close>
   by transfer simp
 
 lemma sshiftr_eq_funpow_sshiftr1:
   \<open>w >>> n = (sshiftr1 ^^ n) w\<close>
   apply (rule sym)
   apply (simp add: sshiftr1_eq_signed_drop_bit_Suc_0 sshiftr_eq)
   apply (induction n)
    apply simp_all
   done
 
 lemma uint_sshiftr_eq:
   \<open>uint (w >>> n) = take_bit LENGTH('a) (sint w div 2 ^  n)\<close>
   for w :: \<open>'a::len word\<close>
   by transfer (simp flip: drop_bit_eq_div)
 
 lemma sshift1_code [code]:
   \<open>sshiftr1 w = signed_drop_bit 1 w\<close>
   by transfer (simp add: drop_bit_Suc)
 
 lemma sshiftr_0 [simp]: "0 >>> n = 0"
   by transfer simp
 
 lemma sshiftr_n1 [simp]: "-1 >>> n = -1"
   by transfer simp
 
 lemma bit_sshiftr_word_iff [bit_simps]:
   \<open>bit (w >>> m) n \<longleftrightarrow> bit w (if LENGTH('a) - m \<le> n \<and> n < LENGTH('a) then LENGTH('a) - 1 else (m + n))\<close>
   for w :: \<open>'a::len word\<close>
   apply transfer
   apply (auto simp add: bit_take_bit_iff bit_drop_bit_eq bit_signed_take_bit_iff min_def not_le simp flip: bit_Suc)
   using le_less_Suc_eq apply fastforce
   using le_less_Suc_eq apply fastforce
   done
 
 lemma nth_sshiftr :
   "(w >>> m) !! n =
     (n < size w \<and> (if n + m \<ge> size w then w !! (size w - 1) else w !! (n + m)))"
   apply transfer
   apply (auto simp add: bit_take_bit_iff bit_drop_bit_eq bit_signed_take_bit_iff min_def not_le ac_simps)
   using le_less_Suc_eq apply fastforce
   using le_less_Suc_eq apply fastforce
   done
 
 lemma sshiftr_numeral [simp]:
   \<open>(numeral k >>> numeral n :: 'a::len word) =
     word_of_int (drop_bit (numeral n) (signed_take_bit (LENGTH('a) - 1) (numeral k)))\<close>
   apply (rule word_eqI)
   apply (cases \<open>LENGTH('a)\<close>)
    apply (simp_all add: word_size bit_drop_bit_eq nth_sshiftr bit_signed_take_bit_iff min_def not_le not_less less_Suc_eq_le ac_simps)
   done
 
 setup \<open>
   Context.theory_map (fold SMT_Word.add_word_shift' [
     (\<^term>\<open>shiftl :: 'a::len word \<Rightarrow> _\<close>, "bvshl"),
     (\<^term>\<open>shiftr :: 'a::len word \<Rightarrow> _\<close>, "bvlshr"),
     (\<^term>\<open>sshiftr :: 'a::len word \<Rightarrow> _\<close>, "bvashr")
   ])
 \<close>
 
 lemma revcast_down_us [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (w >>> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_ucast_iff bit_sshiftr_word_iff ac_simps)
   done
 
 lemma revcast_down_ss [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (w >>> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_scast_iff bit_sshiftr_word_iff ac_simps)
   done
 
 lemma sshiftr_div_2n: "sint (w >>> n) = sint w div 2 ^ n"
   using sint_signed_drop_bit_eq [of n w]
   by (simp add: drop_bit_eq_div sshiftr_eq)
 
 lemmas lsb0 = len_gt_0 [THEN word_ops_nth_size [unfolded word_size]]
 
 lemma nth_sint:
   fixes w :: "'a::len word"
   defines "l \<equiv> LENGTH('a)"
   shows "bit (sint w) n = (if n < l - 1 then w !! n else w !! (l - 1))"
   unfolding sint_uint l_def
   by (auto simp: bit_signed_take_bit_iff word_test_bit_def not_less min_def)
 
 lemma test_bit_2p: "(word_of_int (2 ^ n)::'a::len word) !! m \<longleftrightarrow> m = n \<and> m < LENGTH('a)"
   by transfer (auto simp add: bit_exp_iff)
 
 lemma nth_w2p: "((2::'a::len word) ^ n) !! m \<longleftrightarrow> m = n \<and> m < LENGTH('a::len)"
   by transfer (auto simp add: bit_exp_iff)
 
 lemma bang_is_le: "x !! m \<Longrightarrow> 2 ^ m \<le> x"
   for x :: "'a::len word"
   apply (rule xtrans(3))
    apply (rule_tac [2] y = "x" in le_word_or2)
   apply (rule word_eqI)
   apply (auto simp add: word_ao_nth nth_w2p word_size)
   done
 
 lemma mask_eq:
   \<open>mask n = (1 << n) - (1 :: 'a::len word)\<close>
   by transfer (simp add: mask_eq_exp_minus_1 push_bit_of_1)
 
 lemma nth_ucast:
   "(ucast w::'a::len word) !! n = (w !! n \<and> n < LENGTH('a))"
   by transfer (simp add: bit_take_bit_iff ac_simps)
 
 lemma shiftl_0 [simp]: "(0::'a::len word) << n = 0"
   by transfer simp
 
 lemma shiftr_0 [simp]: "(0::'a::len word) >> n = 0"
   by transfer simp
 
 lemma nth_shiftl1: "shiftl1 w !! n \<longleftrightarrow> n < size w \<and> n > 0 \<and> w !! (n - 1)"
   by transfer (auto simp add: bit_double_iff)
 
 lemma nth_shiftl': "(w << m) !! n \<longleftrightarrow> n < size w \<and> n >= m \<and> w !! (n - m)"
   for w :: "'a::len word"
   by transfer (auto simp add: bit_push_bit_iff)
 
 lemmas nth_shiftl = nth_shiftl' [unfolded word_size]
 
 lemma nth_shiftr1: "shiftr1 w !! n = w !! Suc n"
   by transfer (auto simp add: bit_take_bit_iff simp flip: bit_Suc)
 
 lemma nth_shiftr: "(w >> m) !! n = w !! (n + m)"
   for w :: "'a::len word"
   apply (unfold shiftr_def)
   apply (induct "m" arbitrary: n)
    apply (auto simp add: nth_shiftr1)
   done
 
 lemma nth_sshiftr1: "sshiftr1 w !! n = (if n = size w - 1 then w !! n else w !! Suc n)"
   apply transfer
   apply (auto simp add: bit_take_bit_iff bit_signed_take_bit_iff min_def simp flip: bit_Suc)
   using le_less_Suc_eq apply fastforce
   using le_less_Suc_eq apply fastforce
   done
 
 lemma shiftr_div_2n: "uint (shiftr w n) = uint w div 2 ^ n"
   by (fact uint_shiftr_eq)
 
 lemma shiftl_rev: "shiftl w n = word_reverse (shiftr (word_reverse w) n)"
   by (induct n) (auto simp add: shiftl_def shiftr_def shiftl1_rev)
 
 lemma rev_shiftl: "word_reverse w << n = word_reverse (w >> n)"
   by (simp add: shiftl_rev)
 
 lemma shiftr_rev: "w >> n = word_reverse (word_reverse w << n)"
   by (simp add: rev_shiftl)
 
 lemma rev_shiftr: "word_reverse w >> n = word_reverse (w << n)"
   by (simp add: shiftr_rev)
 
 lemma shiftl_numeral [simp]:
   \<open>numeral k << numeral l = (push_bit (numeral l) (numeral k) :: 'a::len word)\<close>
   by (fact shiftl_word_eq)
 
 lemma shiftl_zero_size: "size x \<le> n \<Longrightarrow> x << n = 0"
   for x :: "'a::len word"
   apply transfer
   apply (simp add: take_bit_push_bit)
   done
 
 lemma shiftl_t2n: "shiftl w n = 2 ^ n * w"
   for w :: "'a::len word"
   by (induct n) (auto simp: shiftl_def shiftl1_2t)
 
 lemma shiftr_numeral [simp]:
   \<open>(numeral k >> numeral n :: 'a::len word) = drop_bit (numeral n) (numeral k)\<close>
   by (fact shiftr_word_eq)
 
 lemma shiftr_numeral_Suc [simp]:
   \<open>(numeral k >> Suc 0 :: 'a::len word) = drop_bit (Suc 0) (numeral k)\<close>
   by (fact shiftr_word_eq)
 
 lemma drop_bit_numeral_bit0_1 [simp]:
   \<open>drop_bit (Suc 0) (numeral k) =
     (word_of_int (drop_bit (Suc 0) (take_bit LENGTH('a) (numeral k))) :: 'a::len word)\<close>
   by (metis Word_eq_word_of_int drop_bit_word.abs_eq of_int_numeral)
 
 lemma nth_mask [simp]:
   \<open>(mask n :: 'a::len word) !! i \<longleftrightarrow> i < n \<and> i < size (mask n :: 'a word)\<close>
   by (auto simp add: test_bit_word_eq word_size Word.bit_mask_iff)
 
 lemma slice_shiftr: "slice n w = ucast (w >> n)"
   apply (rule bit_word_eqI)
   apply (cases \<open>n \<le> LENGTH('b)\<close>)
    apply (auto simp add: bit_slice_iff bit_ucast_iff bit_shiftr_word_iff ac_simps
     dest: bit_imp_le_length)
   done
 
 lemma nth_slice: "(slice n w :: 'a::len word) !! m = (w !! (m + n) \<and> m < LENGTH('a))"
   by (simp add: slice_shiftr nth_ucast nth_shiftr)
 
 lemma revcast_down_uu [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = ucast (w >> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_ucast_iff bit_shiftr_word_iff ac_simps)
   done
 
 lemma revcast_down_su [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc = target_size rc + n \<Longrightarrow> rc w = scast (w >> n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_scast_iff bit_shiftr_word_iff ac_simps)
   done
 
 lemma cast_down_rev [OF refl]:
   "uc = ucast \<Longrightarrow> source_size uc = target_size uc + n \<Longrightarrow> uc w = revcast (w << n)"
   for w :: "'a::len word"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_ucast_iff bit_shiftl_word_iff)
   done
 
 lemma revcast_up [OF refl]:
   "rc = revcast \<Longrightarrow> source_size rc + n = target_size rc \<Longrightarrow>
     rc w = (ucast w :: 'a::len word) << n"
   apply (simp add: source_size_def target_size_def)
   apply (rule bit_word_eqI)
   apply (simp add: bit_revcast_iff bit_word_ucast_iff bit_shiftl_word_iff)
   apply auto
   apply (metis add.commute add_diff_cancel_right)
   apply (metis diff_add_inverse2 diff_diff_add)
   done
 
 lemmas rc1 = revcast_up [THEN
   revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
 lemmas rc2 = revcast_down_uu [THEN
   revcast_rev_ucast [symmetric, THEN trans, THEN word_rev_gal, symmetric]]
 
 lemmas ucast_up =
   rc1 [simplified rev_shiftr [symmetric] revcast_ucast [symmetric]]
 lemmas ucast_down =
   rc2 [simplified rev_shiftr revcast_ucast [symmetric]]
 
 \<comment> \<open>problem posed by TPHOLs referee:
       criterion for overflow of addition of signed integers\<close>
 
 lemma sofl_test:
   \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
     (x + y XOR x) AND (x + y XOR y) >> (size x - 1) = 0\<close>
   for x y :: \<open>'a::len word\<close>
 proof -
   obtain n where n: \<open>LENGTH('a) = Suc n\<close>
     by (cases \<open>LENGTH('a)\<close>) simp_all
   have *: \<open>sint x + sint y + 2 ^ Suc n > signed_take_bit n (sint x + sint y) \<Longrightarrow> sint x + sint y \<ge> - (2 ^ n)\<close>
     \<open>signed_take_bit n (sint x + sint y) > sint x + sint y - 2 ^ Suc n \<Longrightarrow> 2 ^ n > sint x + sint y\<close>
     using signed_take_bit_int_greater_eq [of \<open>sint x + sint y\<close> n] signed_take_bit_int_less_eq [of n \<open>sint x + sint y\<close>]
     by (auto intro: ccontr)
   have \<open>sint x + sint y = sint (x + y) \<longleftrightarrow>
     (sint (x + y) < 0 \<longleftrightarrow> sint x < 0) \<or>
     (sint (x + y) < 0 \<longleftrightarrow> sint y < 0)\<close>
     using sint_less [of x] sint_greater_eq [of x] sint_less [of y] sint_greater_eq [of y]
     signed_take_bit_int_eq_self [of \<open>LENGTH('a) - 1\<close> \<open>sint x + sint y\<close>]
     apply (auto simp add: not_less)
        apply (unfold sint_word_ariths)
        apply (subst signed_take_bit_int_eq_self)
          prefer 4
-       apply (subst signed_take_bit_int_eq_self)
-         prefer 7
-       apply (subst signed_take_bit_int_eq_self)
-         prefer 10
+         apply (subst signed_take_bit_int_eq_self)
+           prefer 7
+           apply (subst signed_take_bit_int_eq_self)
+             prefer 10
              apply (subst signed_take_bit_int_eq_self)
-       apply (auto simp add: signed_take_bit_int_eq_self signed_take_bit_eq_take_bit_minus take_bit_Suc_from_most n not_less intro!: *)
+               apply (auto simp add: signed_take_bit_int_eq_self signed_take_bit_eq_take_bit_minus take_bit_Suc_from_most n not_less intro!: *)
+       apply (smt (z3) take_bit_nonnegative)
+      apply (smt (z3) take_bit_int_less_exp)
+     apply (smt (z3) take_bit_nonnegative)
+    apply (smt (z3) take_bit_int_less_exp)
     done
   then show ?thesis
     apply (simp only: One_nat_def word_size shiftr_word_eq drop_bit_eq_zero_iff_not_bit_last bit_and_iff bit_xor_iff)
     apply (simp add: bit_last_iff)
     done
 qed
 
 lemma shiftr_zero_size: "size x \<le> n \<Longrightarrow> x >> n = 0"
   for x :: "'a :: len word"
   by (rule word_eqI) (auto simp add: nth_shiftr dest: test_bit_size)
 
 lemma test_bit_cat [OF refl]:
   "wc = word_cat a b \<Longrightarrow> wc !! n = (n < size wc \<and>
     (if n < size b then b !! n else a !! (n - size b)))"
   apply (simp add: word_size not_less; transfer)
        apply (auto simp add: bit_concat_bit_iff bit_take_bit_iff)
   done
 
 \<comment> \<open>keep quantifiers for use in simplification\<close>
 lemma test_bit_split':
   "word_split c = (a, b) \<longrightarrow>
     (\<forall>n m.
       b !! n = (n < size b \<and> c !! n) \<and>
       a !! m = (m < size a \<and> c !! (m + size b)))"
   by (auto simp add: word_split_bin' test_bit_bin bit_unsigned_iff word_size bit_drop_bit_eq ac_simps
            dest: bit_imp_le_length)
 
 lemma test_bit_split:
   "word_split c = (a, b) \<Longrightarrow>
     (\<forall>n::nat. b !! n \<longleftrightarrow> n < size b \<and> c !! n) \<and>
     (\<forall>m::nat. a !! m \<longleftrightarrow> m < size a \<and> c !! (m + size b))"
   by (simp add: test_bit_split')
 
 lemma test_bit_split_eq:
   "word_split c = (a, b) \<longleftrightarrow>
     ((\<forall>n::nat. b !! n = (n < size b \<and> c !! n)) \<and>
      (\<forall>m::nat. a !! m = (m < size a \<and> c !! (m + size b))))"
   apply (rule_tac iffI)
    apply (rule_tac conjI)
     apply (erule test_bit_split [THEN conjunct1])
    apply (erule test_bit_split [THEN conjunct2])
   apply (case_tac "word_split c")
   apply (frule test_bit_split)
   apply (erule trans)
   apply (fastforce intro!: word_eqI simp add: word_size)
   done
 
 lemma test_bit_rcat:
   "sw = size (hd wl) \<Longrightarrow> rc = word_rcat wl \<Longrightarrow> rc !! n =
     (n < size rc \<and> n div sw < size wl \<and> (rev wl) ! (n div sw) !! (n mod sw))"
   for wl :: "'a::len word list"
   by (simp add: word_size word_rcat_def foldl_map rev_map bit_horner_sum_uint_exp_iff)
     (simp add: test_bit_eq_bit)
 
 lemmas test_bit_cong = arg_cong [where f = "test_bit", THEN fun_cong]
 
 lemma max_test_bit: "(max_word::'a::len word) !! n \<longleftrightarrow> n < LENGTH('a)"
   by (fact nth_minus1)
 
 lemma shiftr_x_0 [iff]: "x >> 0 = x"
   for x :: "'a::len word"
   by transfer simp
 
 lemma shiftl_x_0 [simp]: "x << 0 = x"
   for x :: "'a::len word"
   by (simp add: shiftl_t2n)
 
 lemma shiftl_1 [simp]: "(1::'a::len word) << n = 2^n"
   by (simp add: shiftl_t2n)
 
 lemma shiftr_1[simp]: "(1::'a::len word) >> n = (if n = 0 then 1 else 0)"
   by (induct n) (auto simp: shiftr_def)
 
 lemma map_nth_0 [simp]: "map ((!!) (0::'a::len word)) xs = replicate (length xs) False"
   by (induct xs) auto
 
 lemma word_and_1:
   "n AND 1 = (if n !! 0 then 1 else 0)" for n :: "_ word"
   by (rule bit_word_eqI) (auto simp add: bit_and_iff test_bit_eq_bit bit_1_iff intro: gr0I)
 
 lemma test_bit_1' [simp]:
   "(1 :: 'a :: len word) !! n \<longleftrightarrow> 0 < LENGTH('a) \<and> n = 0"
   by simp
 
 lemma shiftl0:
   "x << 0 = (x :: 'a :: len word)"
   by (fact shiftl_x_0)
 
 lemma word_ops_nth [simp]:
   fixes x y :: \<open>'a::len word\<close>
   shows
   word_or_nth:  "(x OR y) !! n = (x !! n \<or> y !! n)" and
   word_and_nth: "(x AND y) !! n = (x !! n \<and> y !! n)" and
   word_xor_nth: "(x XOR y) !! n = (x !! n \<noteq> y !! n)"
   by ((cases "n < size x",
       auto dest: test_bit_size simp: word_ops_nth_size word_size)[1])+
 
 lemma and_not_mask:
   "w AND NOT (mask n) = (w >> n) << n"
   for w :: \<open>'a::len word\<close>
   apply (rule word_eqI)
   apply (simp add : word_ops_nth_size word_size)
   apply (simp add : nth_shiftr nth_shiftl)
   by auto
 
 lemma and_mask:
   "w AND mask n = (w << (size w - n)) >> (size w - n)"
   for w :: \<open>'a::len word\<close>
   apply (rule word_eqI)
   apply (simp add : word_ops_nth_size word_size)
   apply (simp add : nth_shiftr nth_shiftl)
   by auto
 
 lemma nth_w2p_same:
   "(2^n :: 'a :: len word) !! n = (n < LENGTH('a))"
   by (simp add : nth_w2p)
 
 lemma shiftr_div_2n_w: "n < size w \<Longrightarrow> w >> n = w div (2^n :: 'a :: len word)"
   apply (unfold word_div_def)
   apply (simp add: uint_2p_alt word_size)
   apply (metis uint_shiftr_eq word_of_int_uint)
   done
 
 lemma le_shiftr:
   "u \<le> v \<Longrightarrow> u >> (n :: nat) \<le> (v :: 'a :: len word) >> n"
   apply (unfold shiftr_def)
   apply (induct_tac "n")
    apply auto
   apply (erule le_shiftr1)
   done
 
 lemma shiftr_mask_le:
   "n <= m \<Longrightarrow> mask n >> m = (0 :: 'a::len word)"
   apply (rule word_eqI)
   apply (simp add: word_size nth_shiftr)
   done
 
 lemma shiftr_mask [simp]:
   \<open>mask m >> m = (0::'a::len word)\<close>
   by (rule shiftr_mask_le) simp
 
 lemma word_leI:
   "(\<And>n.  \<lbrakk>n < size (u::'a::len word); u !! n \<rbrakk> \<Longrightarrow> (v::'a::len word) !! n) \<Longrightarrow> u <= v"
   apply (rule xtrans(4))
    apply (rule word_and_le2)
   apply (rule word_eqI)
   apply (simp add: word_ao_nth)
   apply safe
     apply assumption
    apply (erule_tac [2] asm_rl)
   apply (unfold word_size)
   by auto
 
 lemma le_mask_iff:
   "(w \<le> mask n) = (w >> n = 0)"
   for w :: \<open>'a::len word\<close>
   apply safe
    apply (rule word_le_0_iff [THEN iffD1])
    apply (rule xtrans(3))
     apply (erule_tac [2] le_shiftr)
    apply simp
   apply (rule word_leI)
   apply (rename_tac n')
   apply (drule_tac x = "n' - n" in word_eqD)
   apply (simp add : nth_shiftr word_size)
   apply (case_tac "n <= n'")
   by auto
 
 lemma and_mask_eq_iff_shiftr_0:
   "(w AND mask n = w) = (w >> n = 0)"
   for w :: \<open>'a::len word\<close>
   apply (unfold test_bit_eq_iff [THEN sym])
   apply (rule iffI)
    apply (rule ext)
    apply (rule_tac [2] ext)
    apply (auto simp add : word_ao_nth nth_shiftr)
     apply (drule arg_cong)
     apply (drule iffD2)
      apply assumption
     apply (simp add : word_ao_nth)
    prefer 2
    apply (simp add : word_size test_bit_bin)
   apply transfer
   apply (auto simp add: fun_eq_iff bit_simps)
   apply (metis add_diff_inverse_nat)
   done
 
 lemma mask_shiftl_decompose:
   "mask m << n = mask (m + n) AND NOT (mask n :: 'a::len word)"
   by (auto intro!: word_eqI simp: and_not_mask nth_shiftl nth_shiftr word_size)
 
 lemma bang_eq:
   fixes x :: "'a::len word"
   shows "(x = y) = (\<forall>n. x !! n = y !! n)"
   by (subst test_bit_eq_iff[symmetric]) fastforce
 
 lemma shiftl_over_and_dist:
   fixes a::"'a::len word"
   shows "(a AND b) << c = (a << c) AND (b << c)"
   apply(rule word_eqI)
   apply(simp add: word_ao_nth nth_shiftl, safe)
   done
 
 lemma shiftr_over_and_dist:
   fixes a::"'a::len word"
   shows "a AND b >> c = (a >> c) AND (b >> c)"
   apply(rule word_eqI)
   apply(simp add:nth_shiftr word_ao_nth)
   done
 
 lemma sshiftr_over_and_dist:
   fixes a::"'a::len word"
   shows "a AND b >>> c = (a >>> c) AND (b >>> c)"
   apply(rule word_eqI)
   apply(simp add:nth_sshiftr word_ao_nth word_size)
   done
 
 lemma shiftl_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b << c = (a << c) OR (b << c)"
   apply(rule word_eqI)
   apply(simp add:nth_shiftl word_ao_nth, safe)
   done
 
 lemma shiftr_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b >> c = (a >> c) OR (b >> c)"
   apply(rule word_eqI)
   apply(simp add:nth_shiftr word_ao_nth)
   done
 
 lemma sshiftr_over_or_dist:
   fixes a::"'a::len word"
   shows "a OR b >>> c = (a >>> c) OR (b >>> c)"
   apply(rule word_eqI)
   apply(simp add:nth_sshiftr word_ao_nth word_size)
   done
 
 lemmas shift_over_ao_dists =
   shiftl_over_or_dist shiftr_over_or_dist
   sshiftr_over_or_dist shiftl_over_and_dist
   shiftr_over_and_dist sshiftr_over_and_dist
 
 lemma shiftl_shiftl:
   fixes a::"'a::len word"
   shows "a << b << c = a << (b + c)"
   apply(rule word_eqI)
   apply(auto simp:word_size nth_shiftl add.commute add.left_commute)
   done
 
 lemma shiftr_shiftr:
   fixes a::"'a::len word"
   shows "a >> b >> c = a >> (b + c)"
   apply(rule word_eqI)
   apply(simp add:word_size nth_shiftr add.left_commute add.commute)
   done
 
 lemma shiftl_shiftr1:
   fixes a::"'a::len word"
   shows "c \<le> b \<Longrightarrow> a << b >> c = a AND (mask (size a - b)) << (b - c)"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth)
   done
 
 lemma shiftl_shiftr2:
   fixes a::"'a::len word"
   shows "b < c \<Longrightarrow> a << b >> c = (a >> (c - b)) AND (mask (size a - c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ao_nth)
   done
 
 lemma shiftr_shiftl1:
   fixes a::"'a::len word"
   shows "c \<le> b \<Longrightarrow> a >> b << c = (a >> (b - c)) AND (NOT (mask c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ops_nth_size)
   done
 
 lemma shiftr_shiftl2:
   fixes a::"'a::len word"
   shows "b < c \<Longrightarrow> a >> b << c = (a << (c - b)) AND (NOT (mask c))"
   apply(rule word_eqI)
   apply(auto simp:nth_shiftr nth_shiftl word_size word_ops_nth_size)
   done
 
 lemmas multi_shift_simps =
   shiftl_shiftl shiftr_shiftr
   shiftl_shiftr1 shiftl_shiftr2
   shiftr_shiftl1 shiftr_shiftl2
 
 lemma shiftr_mask2:
   "n \<le> LENGTH('a) \<Longrightarrow> (mask n >> m :: ('a :: len) word) = mask (n - m)"
   apply (rule word_eqI)
   apply (simp add: nth_shiftr word_size)
   apply arith
   done
 
 lemma word_shiftl_add_distrib:
   fixes x :: "'a :: len word"
   shows "(x + y) << n = (x << n) + (y << n)"
   by (simp add: shiftl_t2n ring_distribs)
 
 lemma mask_shift:
   "(x AND NOT (mask y)) >> y = x >> y"
   for x :: \<open>'a::len word\<close>
   apply (rule bit_eqI)
   apply (simp add: bit_and_iff bit_not_iff bit_shiftr_word_iff bit_mask_iff not_le)
   using bit_imp_le_length apply auto
   done
 
 lemma shiftr_div_2n':
   "unat (w >> n) = unat w div 2 ^ n"
   apply (unfold unat_eq_nat_uint)
   apply (subst shiftr_div_2n)
   apply (subst nat_div_distrib)
    apply simp
   apply (simp add: nat_power_eq)
   done
 
 lemma shiftl_shiftr_id:
   assumes nv: "n < LENGTH('a)"
   and     xv: "x < 2 ^ (LENGTH('a) - n)"
   shows "x << n >> n = (x::'a::len word)"
   apply (simp add: shiftl_t2n)
   apply (rule word_eq_unatI)
   apply (subst shiftr_div_2n')
   apply (cases n)
    apply simp
   apply (subst iffD1 [OF unat_mult_lem])+
    apply (subst unat_power_lower[OF nv])
    apply (rule nat_less_power_trans [OF _ order_less_imp_le [OF nv]])
    apply (rule order_less_le_trans [OF unat_mono [OF xv] order_eq_refl])
    apply (rule unat_power_lower)
    apply simp
   apply (subst unat_power_lower[OF nv])
   apply simp
   done
 
 lemma ucast_shiftl_eq_0:
   fixes w :: "'a :: len word"
   shows "\<lbrakk> n \<ge> LENGTH('b) \<rbrakk> \<Longrightarrow> ucast (w << n) = (0 :: 'b :: len word)"
   by transfer (simp add: take_bit_push_bit)
 
 lemma word_shift_nonzero:
   "\<lbrakk> (x::'a::len word) \<le> 2 ^ m; m + n < LENGTH('a::len); x \<noteq> 0\<rbrakk>
    \<Longrightarrow> x << n \<noteq> 0"
   apply (simp only: word_neq_0_conv word_less_nat_alt
                     shiftl_t2n mod_0 unat_word_ariths
                     unat_power_lower word_le_nat_alt)
   apply (subst mod_less)
    apply (rule order_le_less_trans)
     apply (erule mult_le_mono2)
    apply (subst power_add[symmetric])
    apply (rule power_strict_increasing)
     apply simp
    apply simp
   apply simp
   done
 
 lemma word_shiftr_lt:
   fixes w :: "'a::len word"
   shows "unat (w >> n) < (2 ^ (LENGTH('a) - n))"
   apply (subst shiftr_div_2n')
   apply transfer
   apply (simp flip: drop_bit_eq_div add: drop_bit_nat_eq drop_bit_take_bit)
   done
 
 lemma neg_mask_test_bit:
   "(NOT(mask n) :: 'a :: len word) !! m = (n \<le> m \<and> m < LENGTH('a))"
   by (metis not_le nth_mask test_bit_bin word_ops_nth_size word_size)
 
 lemma upper_bits_unset_is_l2p:
   \<open>(\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n') \<longleftrightarrow> (p < 2 ^ n)\<close> (is \<open>?P \<longleftrightarrow> ?Q\<close>)
     if \<open>n < LENGTH('a)\<close>
     for p :: "'a :: len word"
 proof
   assume ?Q
   then show ?P
     by (meson bang_is_le le_less_trans not_le word_power_increasing)
 next
   assume ?P
   have \<open>take_bit n p = p\<close>
   proof (rule bit_word_eqI)
     fix q
     assume \<open>q < LENGTH('a)\<close>
     show \<open>bit (take_bit n p) q \<longleftrightarrow> bit p q\<close>
     proof (cases \<open>q < n\<close>)
       case True
       then show ?thesis
         by (auto simp add: bit_simps)
     next
       case False
       then have \<open>n \<le> q\<close>
         by simp
       with \<open>?P\<close> \<open>q < LENGTH('a)\<close> have \<open>\<not> bit p q\<close>
         by (simp add: test_bit_eq_bit)
       then show ?thesis
         by (simp add: bit_simps)
     qed
   qed
   with that show ?Q
     using take_bit_word_eq_self_iff [of n p] by auto
 qed
 
 lemma less_2p_is_upper_bits_unset:
   "p < 2 ^ n \<longleftrightarrow> n < LENGTH('a) \<and> (\<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n')" for p :: "'a :: len word"
   by (meson le_less_trans le_mask_iff_lt_2n upper_bits_unset_is_l2p word_zero_le)
 
 lemma test_bit_over:
   "n \<ge> size (x::'a::len word) \<Longrightarrow> (x !! n) = False"
   by transfer auto
 
 lemma le_mask_high_bits:
   "w \<le> mask n \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. \<not> w !! i)"
   for w :: \<open>'a::len word\<close>
   by (auto simp: word_size and_mask_eq_iff_le_mask[symmetric] word_eq_iff)
 
 lemma test_bit_conj_lt:
   "(x !! m \<and> m < LENGTH('a)) = x !! m" for x :: "'a :: len word"
   using test_bit_bin by blast
 
 lemma neg_test_bit:
   "(NOT x) !! n = (\<not> x !! n \<and> n < LENGTH('a))" for x :: "'a::len word"
   by (cases "n < LENGTH('a)") (auto simp add: test_bit_over word_ops_nth_size word_size)
 
 lemma shiftr_less_t2n':
   "\<lbrakk> x AND mask (n + m) = x; m < LENGTH('a) \<rbrakk> \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
   apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_drop_bit ac_simps)
   done
 
 lemma shiftr_less_t2n:
   "x < 2 ^ (n + m) \<Longrightarrow> x >> n < 2 ^ m" for x :: "'a :: len word"
   apply (rule shiftr_less_t2n')
    apply (erule less_mask_eq)
   apply (rule ccontr)
   apply (simp add: not_less)
   apply (subst (asm) p2_eq_0[symmetric])
   apply (simp add: power_add)
   done
 
 lemma shiftr_eq_0:
   "n \<ge> LENGTH('a) \<Longrightarrow> ((w::'a::len word) >> n) = 0"
   apply (cut_tac shiftr_less_t2n'[of w n 0], simp)
    apply (simp add: mask_eq_iff)
   apply (simp add: lt2p_lem)
   apply simp
   done
 
 lemma shiftr_not_mask_0:
   "n+m \<ge> LENGTH('a :: len) \<Longrightarrow> ((w::'a::len word) >> n) AND NOT (mask m) = 0"
   by (rule bit_word_eqI) (auto simp add: bit_simps dest: bit_imp_le_length)
 
 lemma shiftl_less_t2n:
   fixes x :: "'a :: len word"
   shows "\<lbrakk> x < (2 ^ (m - n)); m < LENGTH('a) \<rbrakk> \<Longrightarrow> (x << n) < 2 ^ m"
   apply (simp add: word_size mask_eq_iff_w2p [symmetric] flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_push_bit)
   done
 
 lemma shiftl_less_t2n':
   "(x::'a::len word) < 2 ^ m \<Longrightarrow> m+n < LENGTH('a) \<Longrightarrow> x << n < 2 ^ (m + n)"
   by (rule shiftl_less_t2n) simp_all
 
 lemma nth_w2p_scast [simp]:
   "((scast ((2::'a::len signed word) ^ n) :: 'a word) !! m)
          \<longleftrightarrow> ((((2::'a::len  word) ^ n) :: 'a word) !! m)"
   by transfer (auto simp add: bit_simps)
 
 lemma scast_bit_test [simp]:
     "scast ((1 :: 'a::len signed word) << n) = (1 :: 'a word) << n"
   by (clarsimp simp: word_eq_iff)
 
 lemma signed_shift_guard_to_word:
   "\<lbrakk> n < len_of TYPE ('a); n > 0 \<rbrakk>
     \<Longrightarrow> (unat (x :: 'a :: len word) * 2 ^ y < 2 ^ n)
     = (x = 0 \<or> x < (1 << n >> y))"
   apply (simp only: nat_mult_power_less_eq)
   apply (cases "y \<le> n")
    apply (simp only: shiftl_shiftr1)
    apply (subst less_mask_eq)
     apply (simp add: word_less_nat_alt word_size)
     apply (rule order_less_le_trans[rotated], rule power_increasing[where n=1])
       apply simp
      apply simp
     apply simp
    apply (simp add: nat_mult_power_less_eq word_less_nat_alt word_size)
    apply auto[1]
   apply (simp only: shiftl_shiftr2, simp add: unat_eq_0)
   done
 
 lemma nth_bounded:
   "\<lbrakk>(x :: 'a :: len word) !! n; x < 2 ^ m; m \<le> len_of TYPE ('a)\<rbrakk> \<Longrightarrow> n < m"
   apply (rule ccontr)
   apply (auto simp add: not_less test_bit_word_eq)
   apply (meson bit_imp_le_length bit_uint_iff less_2p_is_upper_bits_unset test_bit_bin)
   done
 
 lemma shiftl_mask_is_0[simp]:
   "(x << n) AND mask n = 0"
   for x :: \<open>'a::len word\<close>
   by (simp flip: take_bit_eq_mask add: shiftl_eq_push_bit take_bit_push_bit)
 
 lemma rshift_sub_mask_eq:
   "(a >> (size a - b)) AND mask b = a >> (size a - b)"
   for a :: \<open>'a::len word\<close>
   using shiftl_shiftr2[where a=a and b=0 and c="size a - b"]
   apply (cases "b < size a")
    apply simp
   apply (simp add: linorder_not_less mask_eq_decr_exp word_size
                    p2_eq_0[THEN iffD2])
   done
 
 lemma shiftl_shiftr3:
   "b \<le> c \<Longrightarrow> a << b >> c = (a >> c - b) AND mask (size a - c)"
   for a :: \<open>'a::len word\<close>
   apply (cases "b = c")
    apply (simp add: shiftl_shiftr1)
   apply (simp add: shiftl_shiftr2)
   done
 
 lemma and_mask_shiftr_comm:
   "m \<le> size w \<Longrightarrow> (w AND mask m) >> n = (w >> n) AND mask (m-n)"
   for w :: \<open>'a::len word\<close>
   by (simp add: and_mask shiftr_shiftr) (simp add: word_size shiftl_shiftr3)
 
 lemma and_mask_shiftl_comm:
   "m+n \<le> size w \<Longrightarrow> (w AND mask m) << n = (w << n) AND mask (m+n)"
   for w :: \<open>'a::len word\<close>
   by (simp add: and_mask word_size shiftl_shiftl) (simp add: shiftl_shiftr1)
 
 lemma le_mask_shiftl_le_mask: "s = m + n \<Longrightarrow> x \<le> mask n \<Longrightarrow> x << m \<le> mask s"
   for x :: \<open>'a::len word\<close>
   by (simp add: le_mask_iff shiftl_shiftr3)
 
 lemma word_and_1_shiftl:
   "x AND (1 << n) = (if x !! n then (1 << n) else 0)" for x :: "'a :: len word"
   apply (rule bit_word_eqI; transfer)
   apply (auto simp add: bit_simps not_le ac_simps)
   done
 
 lemmas word_and_1_shiftls'
     = word_and_1_shiftl[where n=0]
       word_and_1_shiftl[where n=1]
       word_and_1_shiftl[where n=2]
 
 lemmas word_and_1_shiftls = word_and_1_shiftls' [simplified]
 
 lemma word_and_mask_shiftl:
   "x AND (mask n << m) = ((x >> m) AND mask n) << m"
   for x :: \<open>'a::len word\<close>
   apply (rule bit_word_eqI; transfer)
   apply (auto simp add: bit_simps not_le ac_simps)
   done
 
 lemma shift_times_fold:
   "(x :: 'a :: len word) * (2 ^ n) << m = x << (m + n)"
   by (simp add: shiftl_t2n ac_simps power_add)
 
 lemma of_bool_nth:
   "of_bool (x !! v) = (x >> v) AND 1"
   for x :: \<open>'a::len word\<close>
   by (simp add: test_bit_word_eq shiftr_word_eq bit_eq_iff)
     (auto simp add: bit_1_iff bit_and_iff bit_drop_bit_eq intro: ccontr)
 
 lemma shiftr_mask_eq:
   "(x >> n) AND mask (size x - n) = x >> n" for x :: "'a :: len word"
   apply (simp flip: take_bit_eq_mask)
   apply transfer
   apply (simp add: take_bit_drop_bit)
   done
 
 lemma shiftr_mask_eq':
   "m = (size x - n) \<Longrightarrow> (x >> n) AND mask m = x >> n" for x :: "'a :: len word"
   by (simp add: shiftr_mask_eq)
 
 lemma and_eq_0_is_nth:
   fixes x :: "'a :: len word"
   shows "y = 1 << n \<Longrightarrow> ((x AND y) = 0) = (\<not> (x !! n))"
   apply safe
    apply (drule_tac u="(x AND (1 << n))" and x=n in word_eqD)
    apply (simp add: nth_w2p)
    apply (simp add: test_bit_bin)
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps test_bit_eq_bit)
   done
 
 lemma and_neq_0_is_nth:
   \<open>x AND y \<noteq> 0 \<longleftrightarrow> x !! n\<close> if \<open>y = 2 ^ n\<close> for x y :: \<open>'a::len word\<close>
   apply (simp add: bit_eq_iff bit_simps)
   using that apply (simp add: bit_simps not_le)
   apply transfer
   apply auto
   done
 
 lemma nth_is_and_neq_0:
   "(x::'a::len word) !! n = (x AND 2 ^ n \<noteq> 0)"
   by (subst and_neq_0_is_nth; rule refl)
 
 lemma word_shift_zero:
   "\<lbrakk> x << n = 0; x \<le> 2^m; m + n < LENGTH('a)\<rbrakk> \<Longrightarrow> (x::'a::len word) = 0"
   apply (rule ccontr)
   apply (drule (2) word_shift_nonzero)
   apply simp
   done
 
 lemma mask_shift_and_negate[simp]:"(w AND mask n << m) AND NOT (mask n << m) = 0"
   for w :: \<open>'a::len word\<close>
   by (clarsimp simp add: mask_eq_decr_exp Parity.bit_eq_iff bit_and_iff bit_not_iff shiftl_word_eq bit_push_bit_iff)
 
 end