diff --git a/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy b/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
--- a/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
+++ b/thys/Affine_Arithmetic/Executable_Euclidean_Space.thy
@@ -1,1078 +1,1075 @@
 section \<open>Euclidean Space: Executability\<close>
 theory Executable_Euclidean_Space
 imports
   "HOL-Analysis.Multivariate_Analysis"
   "List-Index.List_Index"
   "HOL-Library.Float"
   "HOL-Library.Code_Cardinality"
   Affine_Arithmetic_Auxiliarities
 begin
 
 subsection \<open>Ordered representation of Basis and Rounding of Components\<close>
 
 class executable_euclidean_space = ordered_euclidean_space +
   fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
   assumes eucl_down_def:
     "eucl_down p b = (\<Sum>i \<in> Basis. round_down p (b \<bullet> i) *\<^sub>R i)"
   assumes eucl_truncate_down_def:
     "eucl_truncate_down q b = (\<Sum>i \<in> Basis. truncate_down q (b \<bullet> i) *\<^sub>R i)"
   assumes eucl_truncate_up_def:
     "eucl_truncate_up q b = (\<Sum>i \<in> Basis. truncate_up q (b \<bullet> i) *\<^sub>R i)"
   assumes Basis_list[simp]: "set Basis_list = Basis"
   assumes distinct_Basis_list[simp]: "distinct Basis_list"
 begin
 
 lemma length_Basis_list:
   "length Basis_list = card Basis"
   by (metis Basis_list distinct_Basis_list distinct_card)
 
 end
 
 lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
   by (auto simp: eucl_truncate_down_def truncate_down_zero)
 
 lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
   by (auto simp: eucl_truncate_up_def)
 
 subsection \<open>Instantiations\<close>
 
 instantiation real::executable_euclidean_space
 begin
 
 definition Basis_list_real :: "real list" where
   "Basis_list_real = [1]"
 
 definition "eucl_down prec b = round_down prec b"
 definition "eucl_truncate_down prec b = truncate_down prec b"
 definition "eucl_truncate_up prec b = truncate_up prec b"
 
 instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
   eucl_truncate_up_real_def)
 
 end
 
 instantiation prod::(executable_euclidean_space, executable_euclidean_space)
   executable_euclidean_space
 begin
 
 definition Basis_list_prod :: "('a \<times> 'b) list" where
   "Basis_list_prod =
     zip Basis_list (replicate (length (Basis_list::'a list)) 0) @
     zip (replicate (length (Basis_list::'b list)) 0) Basis_list"
 
 definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
 definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
 definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"
 
 instance
 proof
   show "set Basis_list = (Basis::('a*'b) set)"
     by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
       (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
   show "distinct (Basis_list::('a*'b)list)"
     using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
     by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
       elim!: in_set_zipE)
 qed
   (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
     sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def
     eucl_truncate_down_def eucl_truncate_up_def
     intro!: euclidean_eqI[where 'a="'a*'b"])
 
 end
 
 lemma eucl_truncate_down_Basis[simp]:
   "i \<in> Basis \<Longrightarrow> eucl_truncate_down e x \<bullet> i = truncate_down e (x \<bullet> i)"
   by (simp add: eucl_truncate_down_def)
 
 lemma eucl_truncate_down_correct:
   "dist (x::'a::executable_euclidean_space) (eucl_down e x) \<in>
     {0..sqrt (DIM('a)) * 2 powr of_int (- e)}"
 proof -
   have "dist x (eucl_down e x) = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (eucl_down e x \<bullet> i))\<^sup>2)"
     unfolding euclidean_dist_l2[where 'a='a] L2_set_def ..
   also have "\<dots> \<le> sqrt (\<Sum>i\<in>(Basis::'a set). ((2 powr of_int (- e))\<^sup>2))"
     by (intro real_sqrt_le_mono sum_mono power_mono)
       (auto simp: dist_real_def eucl_down_def abs_round_down_le)
   finally show ?thesis
     by (simp add: real_sqrt_mult)
 qed
 
 lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) \<le> x"
   by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)
 
 lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) \<le> x"
   by (auto simp add: eucl_le[where 'a='a] truncate_down)
 
 lemma eucl_truncate_down_le:
   "x \<le> y \<Longrightarrow> eucl_truncate_down w x \<le> (y::'a::executable_euclidean_space)"
   using eucl_truncate_down
   by (rule order.trans)
 
 lemma eucl_truncate_up_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_up e x \<bullet> i = truncate_up e (x \<bullet> i)"
   by (simp add: eucl_truncate_up_def truncate_up_def)
 
 lemma eucl_truncate_up: "x \<le> eucl_truncate_up e (x::'a::executable_euclidean_space)"
   by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)
 
 lemma eucl_truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> eucl_truncate_up e (y::'a::executable_euclidean_space)"
   using _ eucl_truncate_up
   by (rule order.trans)
 
 lemma eucl_truncate_down_mono:
   fixes x::"'a::executable_euclidean_space"
   shows "x \<le> y \<Longrightarrow> eucl_truncate_down p x \<le> eucl_truncate_down p y"
   by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)
 
 lemma eucl_truncate_up_mono:
   fixes x::"'a::executable_euclidean_space"
   shows "x \<le> y \<Longrightarrow> eucl_truncate_up p x \<le> eucl_truncate_up p y"
   by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)
 
 lemma infnorm[code]:
   fixes x::"'a::executable_euclidean_space"
   shows "infnorm x = fold max (map (\<lambda>i. abs (x \<bullet> i)) Basis_list) 0"
   by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
     intro!: max.absorb2[symmetric])
 
 declare Inf_real_def[code del]
 declare Sup_real_def[code del]
 declare Inf_prod_def[code del]
 declare Sup_prod_def[code del]
 declare [[code abort: "Inf::real set \<Rightarrow> real"]]
 declare [[code abort: "Sup::real set \<Rightarrow> real"]]
 declare [[code abort: "Inf::('a::Inf * 'b::Inf) set \<Rightarrow> 'a * 'b"]]
 declare [[code abort: "Sup::('a::Sup * 'b::Sup) set \<Rightarrow> 'a * 'b"]]
 
 lemma nth_Basis_list_in_Basis[simp]:
   "n < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> Basis_list ! n \<in> (Basis::'a set)"
   by (metis Basis_list nth_mem)
 
 subsection \<open>Representation as list\<close>
 
 lemma nth_eq_iff_index:
   "distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> xs ! n = i \<longleftrightarrow> n = index xs i"
   using index_nth_id by fastforce
 
 lemma in_Basis_index_Basis_list: "i \<in> Basis \<Longrightarrow> i = Basis_list ! index Basis_list i"
   by simp
 
 lemmas [simp] = length_Basis_list
 
 lemma sum_Basis_sum_nth_Basis_list:
   "(\<Sum>i\<in>Basis. f i) = (\<Sum>i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))"
   apply (rule sum.reindex_cong[OF _ _ refl])
    apply (auto intro!: inj_on_nth)
   by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff)
 
 definition "eucl_of_list xs = (\<Sum>(x, i)\<leftarrow>zip xs Basis_list. x *\<^sub>R i)"
 
 lemma eucl_of_list_nth:
   assumes "length xs = DIM('a)"
   shows "eucl_of_list xs = (\<Sum>i<DIM('a::executable_euclidean_space). (xs ! i) *\<^sub>R ((Basis_list::'a list) ! i))"
   by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan)
 
 lemma eucl_of_list_inner:
   fixes i::"'a::executable_euclidean_space"
   assumes i: "i \<in> Basis"
   assumes l: "length xs = DIM('a)"
   shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
   by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis
       nth_eq_iff_index sum.delta if_distrib cong: if_cong)
 
 lemma inner_eucl_of_list:
   fixes i::"'a::executable_euclidean_space"
   assumes i: "i \<in> Basis"
   assumes l: "length xs = DIM('a)"
   shows "i \<bullet> eucl_of_list xs = xs ! (index Basis_list i)"
   using eucl_of_list_inner[OF assms] by (auto simp: inner_commute)
 
 
 definition "list_of_eucl x = map ((\<bullet>) x) Basis_list"
 
 lemma index_Basis_list_nth[simp]:
   "i < DIM('a::executable_euclidean_space) \<Longrightarrow> index Basis_list ((Basis_list::'a list) ! i) = i"
   by (simp add: index_nth_id)
 
 lemma list_of_eucl_eucl_of_list[simp]:
   "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl (eucl_of_list xs::'a) = xs"
   by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI)
 
 lemma eucl_of_list_list_of_eucl[simp]:
   "eucl_of_list (list_of_eucl x) = x"
   by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])
 
 
 lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)"
   by (auto simp: list_of_eucl_def)
 
 lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl x ! n = x \<bullet> (Basis_list ! n::'a)"
   by (auto simp: list_of_eucl_def)
 
 lemma nth_ge_len: "n \<ge> length xs \<Longrightarrow> xs ! n = [] ! (n - length xs)"
   by (induction xs arbitrary: n) auto
 
 lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x \<bullet> (Basis_list ! n::'a) else [] ! (n - DIM('a)))"
   apply (auto simp: list_of_eucl_def )
   apply (subst nth_ge_len)
    apply auto
   done
 
 lemma list_of_eucl_eq_iff:
   "list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) \<longleftrightarrow>
   (DIM('a) = DIM('b) \<and> (\<forall>i < DIM('b). x \<bullet> Basis_list ! i = y \<bullet> Basis_list ! i))"
   by (auto simp: list_eq_iff_nth_eq)
 
 lemma eucl_le_Basis_list_iff:
   "(x::'a::executable_euclidean_space) \<le> y \<longleftrightarrow>
   (\<forall>i<DIM('a). x \<bullet> Basis_list ! i \<le> y \<bullet> Basis_list ! i)"
   apply (auto simp:  eucl_le[where 'a='a])
   subgoal for i
     subgoal by (auto dest!: spec[where x="index Basis_list i"])
     done
   done
 
 lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> length ys = DIM('a) \<Longrightarrow>
   (eucl_of_list xs::'a) = eucl_of_list (ys) \<Longrightarrow> xs = ys"
   apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner)
   using nth_Basis_list_in_Basis[where 'a="'a"]
   by fastforce
 
 lemma eucl_of_list_map_plus[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. f x + g x) xs)::'a) =
     eucl_of_list (map f xs) + eucl_of_list (map g xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_uminus[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. - f x) xs)::'a) = - eucl_of_list (map f xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_mult_left[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. r * f x) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_mult_right[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. f x * r) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma eucl_of_list_map_divide_right[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. f x / r) xs)::'a) = eucl_of_list (map f xs) /\<^sub>R r"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps)
 
 lemma eucl_of_list_map_const[simp]:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
   shows "(eucl_of_list (map (\<lambda>x. c) xs)::'a) = c *\<^sub>R One"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)
 
 lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)"
   by (auto intro!: nth_equalityI)
 
 lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs"
   unfolding eucl_of_list_def
   apply (auto simp: sum_list_sum_nth)
   apply (rule sum.mono_neutral_cong_right)
   by (auto simp: nth_append)
 
 lemma Basis_prodD:
   assumes "(i, j) \<in> Basis"
   shows "i \<in> Basis \<and> j = 0 \<or> i = 0 \<and> j \<in> Basis"
   using assms
   by (auto simp: Basis_prod_def)
 
 lemma eucl_of_list_take_DIM[simp]:
   assumes "d = DIM('b::executable_euclidean_space)"
   shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)"
   by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD)
 
 lemma eucl_of_list_eqI:
   assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) =
     take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)"
   shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)"
 proof -
   have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))"
     by simp
   also note assms
   also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)"
     by simp
   finally show ?thesis .
 qed
 
 lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0"
 proof -
   have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)"
     by simp
   also have "\<dots> = eucl_of_list (replicate DIM('a) 0)"
     apply (rule eucl_of_list_eqI)
     by (auto simp: min_def nth_append intro!: nth_equalityI)
   also have "\<dots> = 0"
     by (simp add: replicate_eq_list_of_eucl_zero)
   finally show ?thesis by simp
 qed
 
 lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0"
   using eucl_of_list_replicate_zero[of 0] by simp
 
 
 lemma fst_eucl_of_list_prod:
   shows "fst (eucl_of_list xs::'b::executable_euclidean_space  \<times> _) = (eucl_of_list (take DIM('b) xs)::'b)"
   apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD)
   apply (simp add: sum_list_sum_nth)
   apply (rule sum.mono_neutral_cong_right)
   subgoal by simp
   subgoal by auto
   subgoal by (auto simp: Basis_list_prod_def nth_append)
   subgoal by (auto simp: Basis_list_prod_def nth_append)
   done
 
 lemma index_zip_replicate1[simp]: "index (zip (replicate d a) bs) (a, b) = index bs b"
   if "d = length bs"
   using that
   by (induction bs arbitrary: d) auto
 
 lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a"
   if "d = length as"
   using that
   by (induction as arbitrary: d) auto
 
 lemma index_Basis_list_prod[simp]:
   fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space"
   shows "a \<in> Basis \<Longrightarrow> index Basis_list (a, 0::'b) = index Basis_list a"
     "b \<in> Basis \<Longrightarrow> index Basis_list (0::'a, b) = DIM('a) + index Basis_list b"
   by (auto simp: Basis_list_prod_def index_append
       in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"])
 
 lemma eucl_of_list_eq_takeI:
   assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x"
   shows "eucl_of_list xs = x"
   using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms
   by auto
 
 lemma eucl_of_list_inner_le:
   fixes i::"'a::executable_euclidean_space"
   assumes i: "i \<in> Basis"
   assumes l: "length xs \<ge> DIM('a)"
   shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
 proof -
   have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))"
     by (rule eucl_of_list_eq_takeI) simp
   also have "\<dots> \<bullet> i = xs ! (index Basis_list i)"
     using assms
     by (subst eucl_of_list_inner) auto
   finally show ?thesis .
 qed
 
 lemma eucl_of_list_prod_if:
   assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)"
   shows "eucl_of_list xs =
     (eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)"
   apply (rule euclidean_eqI)
   using assms
   apply (auto simp: eucl_of_list_inner dest!: Basis_prodD)
    apply (subst eucl_of_list_inner_le)
   apply (auto simp: Basis_list_prod_def index_append in_set_zip)
   done
 
 
 lemma snd_eucl_of_list_prod:
   shows "snd (eucl_of_list xs::'b::executable_euclidean_space  \<times> 'c::executable_euclidean_space) =
     (eucl_of_list (drop DIM('b) xs)::'c)"
 proof (cases "length xs \<le> DIM('b)")
   case True
   then show ?thesis
     by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD)
       (simp add: sum_list_sum_nth Basis_list_prod_def nth_append)
 next
   case False
   have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp
   also have "eucl_of_list \<dots> = (eucl_of_list (\<dots> @ replicate (length xs - DIM('c)) 0)::'b \<times> 'c)"
     by simp
   finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b \<times> 'c)"
     by simp
   also have "\<dots> = eucl_of_list (take (DIM ('b \<times> 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
     by simp
   finally have *: "(eucl_of_list xs::'b\<times>'c) = eucl_of_list (take DIM('b \<times> 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
     by simp
   show ?thesis
     apply (subst *)
     apply (subst eucl_of_list_prod_if)
     subgoal by simp
     subgoal
       apply simp
       apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
       apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
       apply (rule arg_cong[where f=eucl_of_list])
       by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits)
     done
 qed
 
 lemma eucl_of_list_prod:
   shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space,
     eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)"
   using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c]
   using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c]
   by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff)
 
 lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)"
   by (auto simp: eucl_of_list_def Basis_list_real_def)
 
 lemma eucl_of_list_append[simp]:
   assumes "length xs = DIM('i::executable_euclidean_space)"
   assumes "length ys = DIM('j::executable_euclidean_space)"
   shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)"
   using assms
   by (auto simp: eucl_of_list_prod)
 
 lemma list_allI: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> list_all P xs"
   by (auto simp: list_all_iff)
 
 lemma
   concat_map_nthI:
   assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set (f x) \<Longrightarrow> P y"
   assumes "j < length (concat (map f xs))"
   shows "P (concat (map f xs) ! j)"
 proof -
   have "list_all P (concat (map f xs))"
     by (rule list_allI) (auto simp: assms)
   then show ?thesis
     by (auto simp: list_all_length assms)
 qed
 
 lemma map_nth_append1:
   assumes "length xs = d"
   shows "map ((!) (xs @ ys)) [0..<d] = xs"
   using assms
   by (auto simp: nth_append intro!: nth_equalityI)
 
 lemma map_nth_append2:
   assumes "length ys = d"
   shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys"
   using assms
   by (auto simp: intro!: nth_equalityI)
 
 lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)"
   by simp
 
 lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)"
   if "n < length xs" "n < length ys"
   using that by simp
 
 lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)"
   by (auto intro!: nth_equalityI simp: inner_simps)
 
 lemma list_of_eucl_inj:
   "list_of_eucl z = list_of_eucl y \<Longrightarrow> y = z"
   by (metis eucl_of_list_list_of_eucl)
 
 lemma length_Basis_list_pos[simp]: "length Basis_list > 0"
   by (metis length_pos_if_in_set Basis_list SOME_Basis)
 
 lemma Basis_list_nth_nonzero:
   "i < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> (Basis_list::'a list) ! i \<noteq> 0"
   by (auto dest!: nth_mem simp: nonzero_Basis)
 
 lemma nth_Basis_list_prod:
   "i < DIM('a) + DIM('b) \<Longrightarrow> (Basis_list::('a::executable_euclidean_space \<times> 'b::executable_euclidean_space) list) ! i =
     (if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))"
   by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less)
 
 lemma eucl_of_list_if:
   assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
   shows "eucl_of_list (map (\<lambda>xa. if xa = x then 1 else 0) (xs::nat list)) =
     (if x \<in> set xs then Basis_list ! index xs x else 0::'a)"
   by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id)
 
 
 lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS"
   by (auto intro!: nth_equalityI simp: nth_append min_def)
 
 lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (\<Sum>b\<in>Basis. f b)"
   by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list)
 
 lemma hd_Basis_list[simp]: "hd Basis_list \<in> Basis"
   unfolding Basis_list[symmetric]
   by (rule hd_in_set) (auto simp: set_empty[symmetric])
 
 definition "inner_lv_rel a b = sum_list (map2 (*) a b)"
 
 lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) \<bullet> eucl_of_list ys = inner_lv_rel xs ys"
   if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)"
   using that
   by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
       (auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)
 
 
 lemma euclidean_vec_componentwise:
   "(\<Sum>(xa::'a::euclidean_space^'b::finite)\<in>Basis. f xa) = (\<Sum>a\<in>Basis. (\<Sum>b::'b\<in>UNIV. f (axis b a)))"
   apply (auto simp: Basis_vec_def)
   apply (subst sum.swap)
   apply (subst sum.Union_disjoint)
     apply auto
       apply (simp add: axis_eq_axis nonzero_Basis)
    apply (simp add: axis_eq_axis nonzero_Basis)
   apply (subst sum.reindex)
    apply (auto intro!: injI)
   subgoal
     apply (auto simp: set_eq_iff)
     by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis)
   apply (rule sum.cong[OF refl])
   apply (auto )
   apply (rule sum.reindex_cong[OF _ _ refl])
   apply (auto intro!: inj_onI)
   using axis_eq_axis by blast
 
 lemma vec_nth_inner_scaleR_craziness:
   "f (x $ i \<bullet> j) *\<^sub>R j = (\<Sum>xa\<in>UNIV. f (x $ xa \<bullet> j) *\<^sub>R axis xa j) $ i"
   by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong)
 
 instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space
 begin
 
 definition Basis_list_vec :: "('a, 'b) vec list" where
   "Basis_list_vec = concat (map (\<lambda>n. map (axis n) Basis_list) enum_class.enum)"
 
 definition eucl_down_vec :: "int \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
   "eucl_down_vec p x = (\<chi> i. eucl_down p (x $ i))"
 
 definition eucl_truncate_down_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
   "eucl_truncate_down_vec p x = (\<chi> i. eucl_truncate_down p (x $ i))"
 
 definition eucl_truncate_up_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
   "eucl_truncate_up_vec p x = (\<chi> i. eucl_truncate_up p (x $ i))"
 
 instance
 proof
   show *: "set (Basis_list::('a, 'b) vec list) = Basis"
     unfolding Basis_list_vec_def Basis_vec_def
     apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def
         intro!: distinct_concat inj_onI split: if_splits)
     apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct
         UNIV_enum[symmetric]
         intro!: distinct_concat inj_onI split: if_splits)
     done
   have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)"
     by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct
         sum_list_distinct_conv_sum_set UNIV_enum[symmetric])
   then show "distinct (Basis_list::('a, 'b) vec list)"
     using * by (auto intro!: card_distinct)
 qed (simp_all only: vector_cart[symmetric] vec_eq_iff
     eucl_down_vec_def eucl_down_def
     eucl_truncate_down_vec_def eucl_truncate_down_def
     eucl_truncate_up_vec_def eucl_truncate_up_def,
     auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def
     vec_nth_inner_scaleR_craziness
     intro!: sum.cong[OF refl])
 end
 
 
 lemma concat_same_lengths_nth:
   assumes "\<And>xs. xs \<in> set XS \<Longrightarrow> length xs = N"
   assumes "i < length XS * N" "N > 0"
   shows "concat XS ! i = XS ! (i div N) ! (i mod N)"
-  using assms
-  apply (induction XS arbitrary: i)
-   apply (auto simp: nth_append nth_Cons split: nat.splits)
-   apply (simp add: div_eq_0_iff)
-  by (metis Suc_inject div_geq mod_geq)
+using assms by (induction XS arbitrary: i)
+  (auto simp: nth_append nth_Cons div_eq_0_iff le_div_geq le_mod_geq split: nat.splits)
 
 lemma concat_map_map_index:
   shows "concat (map (\<lambda>n. map (f n) xs) ys) =
     map (\<lambda>i. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]"
   apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth)
   apply (subst concat_same_lengths_nth)
      apply auto
   apply (subst nth_map_upt)
   apply (auto simp: ac_simps)
   apply (subst nth_map)
   apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0)
   apply (subst nth_map)
   subgoal for i
     using gr_implies_not_zero by fastforce
   subgoal by simp
   done
 
 lemma
   sum_list_zip_map:
   assumes "distinct xs"
   shows "(\<Sum>(x, y)\<leftarrow>zip xs (map g xs). f x y) = (\<Sum>x\<in>set xs. f x (g x))"
   by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
     in_set_zip in_set_conv_nth inj_on_convol_ident
     intro!: sum.reindex_cong[where l="\<lambda>x. (x, g x)"])
 
 lemma
   sum_list_zip_map_of:
   assumes "distinct bs"
   assumes "length xs = length bs"
   shows "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
 proof -
   have "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>(y, x)\<leftarrow>zip bs xs. f x y)"
     by (subst zip_commute) (auto simp: o_def split_beta')
   also have "\<dots> = (\<Sum>(x, y)\<leftarrow>zip bs (map (the o map_of (zip bs xs)) bs). f y x)"
   proof (rule arg_cong, rule map_cong)
     have "xs = (map (the \<circ> map_of (zip bs xs)) bs)"
       using assms
       by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth)
     then show "zip bs xs = zip bs (map (the \<circ> map_of (zip bs xs)) bs)"
       by simp
   qed auto
   also have "\<dots> = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
     using assms(1)
     by (subst sum_list_zip_map) (auto simp: o_def)
   finally show ?thesis .
 qed
 
 
 
 lemma vec_nth_matrix:
   "vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i"
   unfolding matrix_def by simp
 
 lemma matrix_eqI:
   assumes "\<And>x. x \<in> Basis \<Longrightarrow> A *v x = B *v x"
   shows "(A::real^'n^'n) = B"
   apply vector
   using assms
   apply (auto simp: Basis_vec_def)
   by (metis cart_eq_inner_axis matrix_vector_mul_component)
 
 lemma matrix_columnI:
   assumes "\<And>i. column i A = column i B"
   shows "(A::real^'n^'n) = B"
   using assms
   apply vector
   apply (auto simp: column_def)
   apply vector
   by (metis iso_tuple_UNIV_I vec_lambda_inject)
 
 lemma
   vec_nth_Basis:
   fixes x::"real^'n"
   shows "x \<in> Basis \<Longrightarrow> vec_nth x i = (if x = axis i 1 then 1 else 0)"
   apply (auto simp: Basis_vec_def)
   by (metis cart_eq_inner_axis inner_axis_axis)
 
 lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) \<Longrightarrow>
   vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))"
   apply (auto simp: eucl_of_list_def)
   apply (subst sum_list_zip_map_of)
    apply (auto intro!: distinct_zipI2 simp: split_beta')
   apply (subst sum.cong[OF refl])
    apply (subst vec_nth_Basis)
     apply (force simp: set_zip)
   apply (rule refl)
   apply (auto simp: if_distrib sum.delta cong: if_cong)
   subgoal
     apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)")
     subgoal premises prems
     proof -
       have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems
         by (auto simp: in_set_zip)
       then show ?thesis
         using prems
         by (subst (asm) map_of_eq_None_iff) simp
     qed
     subgoal for a
       apply (auto simp: in_set_zip)
       subgoal premises prems for n
         by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3))
       done
     done
   done
 
 lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i"
   apply (auto simp: Basis_list_vec_def Basis_list_real_def )
   apply (subst index_map_inj)
   by (auto intro!: injI simp: axis_eq_axis)
 
 lemma vec_nth_eq_list_of_eucl1:
   "(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)"
   apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
   apply (subst vec_nth_eucl_of_list_eq)
   unfolding index_Basis_list_axis1
   by auto
 
 lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]"
   by code_simp+
 
 lemma three_eq_zero: "(3::3) = 0" by simp
 
 lemma forall_3': "(\<forall>i::3. P i) \<longleftrightarrow> P 0 \<and> P 1 \<and> P 2"
   using forall_3 three_eq_zero by auto
 
 lemma euclidean_eq_list_of_euclI: "x = y" if "list_of_eucl x = list_of_eucl y"
   using that
   by (metis eucl_of_list_list_of_eucl)
 
 lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) \<noteq> 0"
   by (auto simp: axis_def vec_eq_iff)
 
 
 lemma eucl_of_list_vec_nth3[simp]:
   "(eucl_of_list [g, h, i]::real^3) $ 0 = g"
   "(eucl_of_list [g, h, i]::real^3) $ 1 = h"
   "(eucl_of_list [g, h, i]::real^3) $ 2 = i"
   "(eucl_of_list [g, h, i]::real^3) $ 3 = g"
   by (auto simp: cart_eq_inner_axis eucl_of_list_inner vec_nth_eq_list_of_eucl1 index_Basis_list_axis1)
 
 type_synonym R3 = "real*real*real"
 
 lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]"
   by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def)
 
 lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]"
   by (auto simp: Basis_list_vec_def Basis_list_real_def)
 
 lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)"
   by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def
       Basis_prod_def Basis_list_vec3 Basis_list_R3
       intro!: euclidean_eqI[where 'a=R3])
 
 
 subsection \<open>Bounded Linear Functions\<close>
 
 subsection \<open>bounded linear functions\<close>
 
 locale blinfun_syntax
 begin
 no_notation vec_nth (infixl "$" 90)
 notation blinfun_apply (infixl "$" 999)
 end
 
 lemma bounded_linear_via_derivative:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector" \<comment> \<open>TODO: generalize?\<close>
   assumes "\<And>i. ((\<lambda>x. blinfun_apply (f x) i) has_derivative (\<lambda>x. f' y x i)) (at y)"
   shows "bounded_linear (f' y x)"
 proof -
   interpret linear "f' y x"
   proof (unfold_locales, goal_cases)
     case (1 v w)
     from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps]
       has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x]
     show ?case .
   next
     case (2 r v)
     from has_derivative_unique[OF assms[of "r *\<^sub>R v", unfolded blinfun.bilinear_simps]
       has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x]
     show ?case .
   qed
   let ?bnd = "\<Sum>i\<in>Basis. norm (f' y x i)"
   {
     fix v
     have "f' y x v = (\<Sum>i\<in>Basis. (v \<bullet> i) *\<^sub>R f' y x i)"
       by (subst euclidean_representation[symmetric]) (simp add: sum scaleR)
     also have "norm \<dots> \<le> norm v * ?bnd"
       by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono
         simp: sum_distrib_left Basis_le_norm)
     finally have "norm (f' y x v) \<le> norm v * ?bnd" .
   }
   then show ?thesis by unfold_locales auto
 qed
 
 definition blinfun_scaleR::"('a::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)"
   where "blinfun_scaleR a b = blinfun_scaleR_left b o\<^sub>L a"
 
 lemma blinfun_scaleR_transfer[transfer_rule]:
   "rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=)))
     (\<lambda>a b c. a c *\<^sub>R b) blinfun_scaleR"
   by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def)
 
 lemma blinfun_scaleR_rep_eq[simp]:
   "blinfun_scaleR a b c = a c *\<^sub>R b"
   by (simp add: blinfun_scaleR_def)
 
 lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)"
   unfolding blinfun_scaleR_def[abs_def]
   by (auto intro!: bounded_linear_intros)
 
 lemma blinfun_scaleR_has_derivative[derivative_intros]:
   assumes "(f has_derivative f') (at x within s)"
   shows "((\<lambda>x. blinfun_scaleR a (f x)) has_derivative (\<lambda>x. blinfun_scaleR a (f' x))) (at x within s)"
   using bounded_linear_blinfun_scaleR assms
   by (rule bounded_linear.has_derivative)
 
 lemma blinfun_componentwise:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
   shows "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
   by (auto intro!: blinfun_eqI
     simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric]
       blinfun.sum_right[symmetric])
 
 lemma
   blinfun_has_derivative_componentwiseI:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
   assumes "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. f x i) has_derivative blinfun_apply (f' i)) (at x)"
   shows "(f has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)"
   by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps)
 
 lemma
   has_derivative_BlinfunI:
   fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
   assumes "\<And>i. ((\<lambda>x. f x i) has_derivative (\<lambda>x. f' y x i)) (at y)"
   shows "(f has_derivative (\<lambda>x. Blinfun (f' y x))) (at y)"
 proof -
   have 1: "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
     by (rule blinfun_componentwise)
   moreover have 2: "(\<dots> has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)"
     by (force intro: assms derivative_eq_intros)
   moreover
   interpret f': bounded_linear "f' y x" for x
     by (rule bounded_linear_via_derivative) (rule assms)
   have 3: "(\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i
     by (auto simp: if_distrib if_distribR blinfun.bilinear_simps
       f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation
       intro!: blinfun_euclidean_eqI)
   have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x
     apply (subst bounded_linear_Blinfun_apply)
     subgoal by unfold_locales
     subgoal by simp
     done
   show ?thesis
     apply (subst 1)
     apply (rule 2[THEN has_derivative_eq_rhs])
     apply (rule ext)
     apply (rule blinfun_eqI)
     apply (subst 3)
     apply (subst 4)
     apply (rule refl)
     done
 qed
 
 lemma
   has_derivative_Blinfun:
   assumes "(f has_derivative f') F"
   shows "(f has_derivative Blinfun f') F"
   using assms
   by (subst bounded_linear_Blinfun_apply) auto
 
 lift_definition flip_blinfun::
   "('a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'a \<Rightarrow>\<^sub>L 'c" is
   "\<lambda>f x y. f y x"
   using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip
   by auto
 
 lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a"
   by transfer simp
 
 lemma le_norm_blinfun:
   shows "norm (blinfun_apply f x) / norm x \<le> norm f"
   by transfer (rule le_onorm)
 
 lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r")
 proof (rule antisym)
   from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x]
   show "?l \<le> ?r"
     by (auto intro!: norm_blinfun_bound simp: ac_simps)
   have "norm (x a b) \<le> norm (flip_blinfun x) * norm a * norm b" for a b
   proof -
     have "norm (x a b) / norm a \<le> norm (flip_blinfun x b)"
       by (rule order_trans[OF _ le_norm_blinfun]) auto
     also have "\<dots> \<le> norm (flip_blinfun x) * norm b"
       by (rule norm_blinfun)
     finally show ?thesis
       by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm)
   qed
   then show "?r \<le> ?l"
     by (auto intro!: norm_blinfun_bound)
 qed
 
 lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun"
   by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1])
 
 lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g"
   by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2)
     norm_flip_blinfun)
 
 
 context includes blinfun.lifting begin
 
 lift_definition blinfun_of_vmatrix::"(real^'m^'n) \<Rightarrow> ((real^('m::finite)) \<Rightarrow>\<^sub>L (real^('n::finite)))" is
   "matrix_vector_mult:: ((real, 'm) vec, 'n) vec \<Rightarrow> ((real, 'm) vec \<Rightarrow> (real, 'n) vec)"
   unfolding linear_linear
   by (rule matrix_vector_mul_linear)
 
 lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M"
   apply vector
   apply (auto simp: matrix_def)
   apply transfer
   by (metis cart_eq_inner_axis matrix_vector_mul_component)
 
 end
 
 lemma blinfun_apply_componentwise:
   "B = (\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))"
   using blinfun_componentwise[of "\<lambda>x. B", unfolded fun_eq_iff]
   by blast
 
 lemma blinfun_apply_eq_sum:
   assumes [simp]: "length v = CARD('n)"
   shows "blinfun_apply (B::(real^'n::enum)\<Rightarrow>\<^sub>L(real^'m::enum)) (eucl_of_list v) =
     (\<Sum>i<CARD('m). \<Sum>j<CARD('n). ((B (Basis_list ! j) \<bullet> Basis_list ! i) * v ! j) *\<^sub>R (Basis_list ! i))"
   apply (subst blinfun_apply_componentwise[of B])
   apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"]
       simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib
         sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR
         cong: if_cong)
   apply (subst sum.swap)
   by (auto simp: sum.delta algebra_simps)
 
 lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat
 proof -
   have "x * C + y < (D - 1) * C + C"
     apply (rule add_le_less_mono)
      apply (rule mult_right_mono)
     using that
     by auto
   also have "\<dots> \<le> D * C"
     using that
     by (auto simp: algebra_simps)
   finally show ?thesis .
 qed
 
 lemma less_square_imp_div_less[intro, simp]: "i < E * D \<Longrightarrow>  i div E < D" for i::nat
   by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero)
 
 lemma in_square_lemma'[intro, simp]: "i < L \<Longrightarrow> n < N \<Longrightarrow> i * N + n < N * L" for i n::nat
   by (metis in_square_lemma mult.commute)
 
 lemma
   distinct_nth_eq_iff:
   "distinct xs \<Longrightarrow> x < length xs \<Longrightarrow> y < length xs \<Longrightarrow> xs ! x = xs ! y \<longleftrightarrow> x = y"
   by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD)
 
 lemma index_Basis_list_axis2:
   "index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) =
     (index enum_class.enum j) * CARD('i) + index enum_class.enum i"
   apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def)
   apply (subst concat_map_map_index)
   unfolding card_UNIV_length_enum[symmetric]
   subgoal
   proof -
     have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i
       by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
     have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j
       by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
     have *: "axis j (axis i 1) =
       (\<lambda>i. axis (enum_class.enum ! (i div CARD('i)))
                       (axis (enum_class.enum ! (i mod CARD('i))) 1))
       ((index enum_class.enum j) * CARD('i) + index enum_class.enum i)"
       by (auto simp: index_less_cardi enum_UNIV)
     note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i]
     show ?thesis
       apply (subst *)
       apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"])
       subgoal
         apply (auto intro!: inj_onI simp: axis_eq_axis )
          apply (subst (asm) distinct_nth_eq_iff)
         apply (auto simp: enum_distinct card_UNIV_length_enum)
         subgoal for x y
           using gr_implies_not0 by fastforce
         subgoal for x y
           using gr_implies_not0 by fastforce
         subgoal for x y
           apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated])
              apply (auto simp: card_UNIV_length_enum mult.commute)
           subgoal
             by (metis mod_mult_div_eq)
           done
         done
       subgoal using less by auto
       subgoal by (auto simp: card_UNIV_length_enum ac_simps)
       subgoal apply (subst index_upt)
         subgoal using less by auto
         subgoal using less by (auto simp: ac_simps)
         subgoal using less by auto
         done
       done
   qed
   done
 
 lemma
   vec_nth_Basis2:
   fixes x::"real^'n^'m"
   shows "x \<in> Basis \<Longrightarrow> vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))"
   by (auto simp: Basis_vec_def axis_def)
 
 lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) \<Longrightarrow>
   vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))"
   apply (auto simp: eucl_of_list_def)
   apply (subst sum_list_zip_map_of)
    apply (auto intro!: distinct_zipI2 simp: split_beta')
   apply (subst sum.cong[OF refl])
    apply (subst vec_nth_Basis2)
     apply (force simp: set_zip)
   apply (rule refl)
   apply (auto simp: if_distrib sum.delta cong: if_cong)
   subgoal
     apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)")
     subgoal premises prems
     proof -
       have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems
         by (auto simp: in_set_zip)
       then show ?thesis
         using prems
         by (subst (asm) map_of_eq_None_iff) auto
     qed
     subgoal for a
       apply (auto simp: in_set_zip)
       subgoal premises prems for n
       proof -
         have "n < card (Basis::(real^'n::_^'m::_) set)"
           by (simp add: prems(4))
         then show ?thesis
           by (metis index_Basis_list_nth prems(2))
       qed
       done
     done
   done
 
 lemma vec_nth_eq_list_of_eucl2:
   "vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j =
     list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)"
   apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
   apply (subst vec_nth_eucl_of_list_eq2)
   unfolding index_Basis_list_axis2
   by auto
 
 theorem
   eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list:
   assumes "length M = CARD('n) * CARD('m)"
   assumes "length v = CARD('n)"
   shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v =
     (\<Sum>i<CARD('m).
       (\<Sum>j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *\<^sub>R Basis_list ! i)"
   apply (vector matrix_vector_mult_def)
   apply auto
   apply (subst vec_nth_eucl_of_list_eq2)
    apply (auto simp: assms)
   apply (subst vec_nth_eucl_of_list_eq)
    apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta
       nth_eq_iff_index
       if_distrib cong: if_cong)
   subgoal for i
     apply (rule sum.reindex_cong[where l="nth enum_class.enum"])
       apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI)
      apply (rule image_eqI[OF ])
       apply (rule nth_index[symmetric])
       apply (auto simp: enum_UNIV)
     by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id)
   subgoal for i
     using index_less[of i "enum_class.enum" "CARD('n)"]
     by (auto simp: enum_UNIV card_UNIV_length_enum)
   done
 
 lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)"
   by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum)
 
 lemmas [intro, simp] = enum_distinct
 lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV
 
 lemma sum_index_enum_eq:
   "(\<Sum>(k::'n::enum)\<in>UNIV. f (index enum_class.enum k)) = (\<Sum>i<CARD('n). f i)"
   by (rule sum.reindex_cong[where l="nth enum_class.enum"])
     (force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+
 
 end
\ No newline at end of file
diff --git a/thys/BenOr_Kozen_Reif/BKR_Proofs.thy b/thys/BenOr_Kozen_Reif/BKR_Proofs.thy
--- a/thys/BenOr_Kozen_Reif/BKR_Proofs.thy
+++ b/thys/BenOr_Kozen_Reif/BKR_Proofs.thy
@@ -1,2224 +1,2225 @@
 theory BKR_Proofs
   imports "Matrix_Equation_Construction"
 
 begin
 
 definition well_def_signs:: "nat => rat list list \<Rightarrow> bool"
   where "well_def_signs num_polys sign_conds \<equiv> \<forall> signs \<in> set(sign_conds). (length signs = num_polys)"
 
 definition satisfies_properties:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat list list \<Rightarrow> rat mat \<Rightarrow> bool"
   where "satisfies_properties p qs subsets signs matrix = 
   ( all_list_constr subsets (length qs) \<and> well_def_signs (length qs) signs \<and> distinct signs
   \<and> satisfy_equation p qs subsets signs \<and>  invertible_mat matrix  \<and> matrix = matrix_A signs subsets
   \<and> set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)
   )"
 
 section "Base Case"
 
 lemma mat_base_case:
   shows "matrix_A [[1],[-1]] [[],[0]] = (mat_of_rows_list 2 [[1, 1], [1, -1]])"
   unfolding matrix_A_def mtx_row_def z_def apply (auto)
   by (simp add: numeral_2_eq_2)
 
 lemma base_case_sgas:
   fixes q p:: "real poly"
   assumes nonzero: "p \<noteq> 0"
   assumes rel_prime: "coprime p q"
   shows "set (characterize_consistent_signs_at_roots_copr p [q]) \<subseteq> {[1], [- 1]}"
   unfolding characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def by auto
 
 lemma base_case_sgas_alt:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   assumes len1: "length qs = 1"
   assumes nonzero: "p \<noteq> 0"
   assumes rel_prime: "\<forall>q. (List.member qs q) \<longrightarrow> coprime p q"
   shows "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> {[1], [- 1]}"
 proof - 
   have ex_q: "\<exists>(q::real poly). qs = [q]" 
     using len1    
     using length_Suc_conv[of qs 0] by auto
   then show ?thesis using base_case_sgas nonzero rel_prime
     apply (auto)
     using characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def by auto
 qed
 
 lemma base_case_satisfy_equation:
   fixes q p:: "real poly"
   assumes nonzero: "p \<noteq> 0"
   assumes rel_prime: "coprime p q"
   shows "satisfy_equation p [q] [[],[0]] [[1],[-1]]"
 proof - 
   have h1: "set (characterize_consistent_signs_at_roots_copr p [q]) \<subseteq> {[1], [- 1]}"
     using base_case_sgas assms by auto
   have h2: " \<forall>qa. List.member [q] qa \<longrightarrow> coprime p qa" using rel_prime
     by (simp add: member_rec(1) member_rec(2))
   have h3: "all_list_constr [[], [0]] (Suc 0)" unfolding all_list_constr_def
     by (simp add: list_constr_def member_def)
   then show ?thesis using matrix_equation[where p = "p", where qs = "[q]", where signs = "[[1],[-1]]", where subsets = "[[],[0]]"]
       nonzero h1 h2 h3 by auto
 qed
 
 lemma base_case_satisfy_equation_alt:
   fixes p:: "real poly"
   fixes qs:: "real poly list"
   assumes len1: "length qs = 1"
   assumes nonzero: "p \<noteq> 0"
   assumes rel_prime: "\<forall>q. (List.member qs q) \<longrightarrow> coprime p q"
   shows "satisfy_equation p qs [[],[0]] [[1],[-1]]"
 proof - 
   have ex_q: "\<exists>(q::real poly). qs = [q]" 
     using len1    
     using length_Suc_conv[of qs 0] by auto
   then show ?thesis using base_case_satisfy_equation nonzero rel_prime
     apply (auto)
     by (simp add: member_rec(1)) 
 qed
 
 lemma base_case_matrix_eq:
   fixes q p:: "real poly"
   assumes nonzero: "p \<noteq> 0"
   assumes rel_prime: "coprime p q"
   shows "(mult_mat_vec (mat_of_rows_list 2 [[1, 1], [1, -1]]) (construct_lhs_vector p [q] [[1],[-1]]) = 
     (construct_rhs_vector p [q] [[],[0]]))"                      
   using mat_base_case base_case_satisfy_equation unfolding satisfy_equation_def
   by (simp add: nonzero rel_prime)
 
 lemma less_two:
   shows "j < Suc (Suc 0) \<longleftrightarrow> j = 0 \<or> j = 1" by auto 
 
 lemma inverse_mat_base_case: 
   shows "inverts_mat (mat_of_rows_list 2 [[1/2, 1/2], [1/2, -(1/2)]]::rat mat) (mat_of_rows_list 2 [[1, 1], [1, -1]]::rat mat)"
   unfolding inverts_mat_def mat_of_rows_list_def mat_eq_iff apply auto
   unfolding less_two by (auto simp add: scalar_prod_def)
 
 lemma inverse_mat_base_case_2: 
   shows "inverts_mat (mat_of_rows_list 2 [[1, 1], [1, -1]]::rat mat) (mat_of_rows_list 2 [[1/2, 1/2], [1/2, -(1/2)]]::rat mat) "
   unfolding inverts_mat_def mat_of_rows_list_def mat_eq_iff apply auto
   unfolding less_two by (auto simp add: scalar_prod_def)
 
 lemma base_case_invertible_mat: 
   shows "invertible_mat (matrix_A [[1], [- 1]] [[], [0]])"
   unfolding invertible_mat_def using inverse_mat_base_case inverse_mat_base_case_2
   apply (auto)
    apply (simp add: mat_base_case mat_of_rows_list_def)
   using mat_base_case by auto 
 
 section "Inductive Step"
 
 subsection "Lemmas on smashing subsets and signs"
 
 lemma signs_smash_property:
   fixes signs1 signs2 :: "'a list list"
   fixes a b:: "nat"
   shows "\<forall> (elem :: 'a list). (elem \<in> (set (signs_smash signs1 signs2)) \<longrightarrow> 
     (\<exists> n m :: nat. 
       elem = ((nth signs1 n)@(nth signs2 m))))"
 proof clarsimp 
   fix elem 
   assume assum: "elem \<in> set (signs_smash signs1 signs2)"
   show "\<exists>n m. elem = signs1 ! n @ signs2 ! m"
     using assum unfolding signs_smash_def apply (auto)
     by (metis in_set_conv_nth) 
 qed
 
 lemma signs_smash_property_set:
   fixes signs1 signs2 :: "'a list list"
   fixes a b:: "nat"
   shows "\<forall> (elem :: 'a list). (elem \<in> (set (signs_smash signs1 signs2)) \<longrightarrow> 
     (\<exists> (elem1::'a list). \<exists> (elem2::'a list). 
       (elem1 \<in> set(signs1) \<and> elem2 \<in> set(signs2) \<and> elem = (elem1@elem2))))"
 proof clarsimp 
   fix elem 
   assume assum: "elem \<in> set (signs_smash signs1 signs2)"
   show "\<exists>elem1. elem1 \<in> set signs1 \<and> (\<exists>elem2. elem2 \<in> set signs2 \<and> elem = elem1 @ elem2)"
     using assum unfolding signs_smash_def by auto
 qed
 
 lemma subsets_smash_property:
   fixes subsets1 subsets2 :: "nat list list"
   fixes n:: "nat"
   shows "\<forall> (elem :: nat list). (List.member (subsets_smash n subsets1 subsets2) elem) \<longrightarrow> 
     (\<exists> (elem1::nat list). \<exists> (elem2::nat list).
       (elem1 \<in> set(subsets1) \<and> elem2 \<in> set(subsets2) \<and> elem = (elem1 @ ((map ((+) n) elem2)))))"
 proof - 
   let ?new_subsets = "(map (map ((+) n)) subsets2)"
     (* a slightly unorthodox use of signs_smash, but it closes the proof *)
   have "subsets_smash n subsets1 subsets2 = signs_smash subsets1 ?new_subsets" 
     unfolding subsets_smash_def signs_smash_def apply (auto)
     by (simp add: comp_def) 
   then show ?thesis
     by (smt imageE in_set_member set_map signs_smash_property_set)
 qed
 
   (* If subsets for smaller systems are well-defined, then subsets for combined systems
    are well-defined *)
 subsection "Well-defined subsets preserved when smashing"
 
 lemma list_constr_append:
   "list_constr a n \<and> list_constr b n \<longrightarrow> list_constr (a@b) n"
   apply (auto) unfolding list_constr_def
   using list_all_append by blast 
 
 lemma well_def_step: 
   fixes qs1 qs2 :: "real poly list"
   fixes subsets1 subsets2 :: "nat list list"
   assumes well_def_subsets1: "all_list_constr (subsets1) (length qs1)"
   assumes well_def_subsets2: "all_list_constr (subsets2) (length qs2)"
   shows "all_list_constr ((subsets_smash (length qs1) subsets1 subsets2))
      (length (qs1 @ qs2))"
 proof - 
   have h1: "\<forall>elem.
      List.member (subsets_smash (length qs1) subsets1 subsets2) elem \<longrightarrow>
      (\<exists>elem1 elem2. elem1 \<in> set subsets1 \<and> elem2 \<in> set subsets2 \<and> elem = elem1 @ map ((+) (length qs1)) elem2)"
     using subsets_smash_property by blast
   have h2: "\<forall>elem1 elem2. (elem1 \<in> set subsets1 \<and> elem2 \<in> set subsets2) \<longrightarrow> list_constr (elem1 @ map ((+) (length qs1)) elem2) (length (qs1 @ qs2))"
   proof clarsimp 
     fix elem1
     fix elem2
     assume e1: "elem1 \<in> set subsets1"
     assume e2: "elem2 \<in> set subsets2"
     have h1: "list_constr elem1  (length qs1 + length qs2) " 
     proof - 
       have h1: "list_constr elem1  (length qs1)"  using e1 well_def_subsets1 
         unfolding all_list_constr_def
         by (simp add: in_set_member) 
       then show ?thesis unfolding list_constr_def
         by (simp add: list.pred_mono_strong) 
     qed
     have h2: "list_constr (map ((+) (length qs1)) elem2) (length qs1 + length qs2)"
     proof - 
       have h1: "list_constr elem2  (length qs2)"  using e2 well_def_subsets2 
         unfolding all_list_constr_def
         by (simp add: in_set_member) 
       then show ?thesis unfolding list_constr_def
         by (simp add: list_all_length)
     qed    
     show "list_constr (elem1 @ map ((+) (length qs1)) elem2) (length qs1 + length qs2)" 
       using h1 h2 list_constr_append
       by blast 
   qed
   then show ?thesis using h1 unfolding all_list_constr_def by auto
 qed
 
 subsection "Well def signs preserved when smashing"
 lemma well_def_signs_step: 
   fixes qs1 qs2 :: "real poly list"
   fixes signs1 signs2 :: "rat list list"
   assumes "length qs1 > 0"
   assumes "length qs2 > 0"
   assumes well_def1: "well_def_signs (length qs1) signs1"
   assumes well_def2: "well_def_signs (length qs2) signs2"
   shows "well_def_signs (length (qs1@qs2)) (signs_smash signs1 signs2)"
   using well_def1 well_def2 unfolding well_def_signs_def using signs_smash_property_set[of signs1 signs2] length_append by auto
 
 subsection "Distinct signs preserved when smashing"
 
 lemma distinct_map_append:
   assumes "distinct ls"
   shows "distinct (map ((@) xs) ls)"
   unfolding distinct_map inj_on_def using assms by auto
 
 lemma length_eq_append:
   assumes "length y = length b"
   shows "(x @ y = a @ b) \<longleftrightarrow> x=a \<and> y = b"
   by (simp add: assms)
 
 lemma distinct_step:
   fixes qs1 qs2 :: "real poly list"
   fixes signs1 signs2 :: "rat list list"
   assumes well_def1: "well_def_signs n1 signs1"
   assumes well_def2: "well_def_signs n2 signs2"
   assumes distinct1: "distinct signs1"
   assumes distinct2: "distinct signs2"
   shows "distinct (signs_smash signs1 signs2)"
   unfolding signs_smash_def
   using distinct1
 proof(induction signs1)
   case Nil
   then show ?case by auto
 next
   case (Cons a signs1)
   then show ?case apply (auto simp add: distinct2 distinct_map_append)
     using assms unfolding well_def_signs_def
     by (simp add: distinct1 distinct2 length_eq_append)
 qed
 
 (* In this section we will show that if signs1 contains all consistent sign assignments and signs2 
 contains all consistent sign assignments, then their smash contains all consistent sign assignments.  
 Intuitively, this makes sense because signs1 and signs2 are carrying information about different 
 sets of polynomials, and their smash contains all possible combinations of that information.
 *)
 subsection "Consistent sign assignments preserved when smashing"
 
 lemma subset_smash_signs: 
   fixes a1 b1 a2 b2:: "rat list list"
   assumes sub1: "set a1 \<subseteq> set a2"
   assumes sub2: "set b1 \<subseteq> set b2"
   shows "set (signs_smash a1 b1) \<subseteq> set (signs_smash a2 b2)"
 proof -
   have h1: "\<forall>x\<in>set (signs_smash a1 b1). x\<in>set (signs_smash a2 b2)"
   proof clarsimp 
     fix x
     assume x_in: "x \<in> set (signs_smash a1 b1)"
     have h1: "\<exists> n m :: nat. x = (nth a1 n)@(nth b1 m)"
       using signs_smash_property[of a1 b1] x_in
       by blast
     then have h2: "\<exists> p q::nat. x = (nth a2 p)@(nth b2 q)"
       using sub1 sub2 apply (auto)
       by (metis nth_find_first signs_smash_property_set subset_code(1) x_in) 
     then show "x \<in> set (signs_smash a2 b2)" 
       unfolding signs_smash_def apply (auto)
       using signs_smash_property_set sub1 sub2 x_in by fastforce 
   qed
   then show ?thesis
     by blast 
 qed
 
 lemma subset_helper:
   fixes p:: "real poly"
   fixes qs1 qs2 :: "real poly list"
   fixes signs1 signs2 :: "rat list list"
   shows "\<forall> x \<in> set (characterize_consistent_signs_at_roots_copr p (qs1 @ qs2)). 
         \<exists> x1 \<in> set (characterize_consistent_signs_at_roots_copr p qs1). 
         \<exists> x2 \<in> set (characterize_consistent_signs_at_roots_copr p qs2).
         x = x1@x2"
 proof clarsimp 
   fix x
   assume  x_in: "x \<in> set (characterize_consistent_signs_at_roots_copr p (qs1 @ qs2))" 
   have x_in_csv: "x \<in> set(map (consistent_sign_vec_copr (qs1 @ qs2)) (characterize_root_list_p p))"  
     using x_in unfolding characterize_consistent_signs_at_roots_copr_def by simp
   have csv_hyp: "\<forall>r. consistent_sign_vec_copr (qs1 @ qs2) r = (consistent_sign_vec_copr qs1 r)@(consistent_sign_vec_copr qs2 r)"
     unfolding consistent_sign_vec_copr_def by auto
   have exr_iff: "(\<exists>r \<in> set (characterize_root_list_p p). x = consistent_sign_vec_copr (qs1 @ qs2) r) \<longleftrightarrow> (\<exists>r \<in> set (characterize_root_list_p p). x = (consistent_sign_vec_copr qs1 r)@(consistent_sign_vec_copr qs2 r))"
     using csv_hyp by auto
   have exr: "x \<in> set(map (consistent_sign_vec_copr (qs1 @ qs2)) (characterize_root_list_p p)) \<longrightarrow> (\<exists>r \<in> set (characterize_root_list_p p). x = consistent_sign_vec_copr (qs1 @ qs2) r)"
     by auto
   have mem_list1: "\<forall> r \<in> set (characterize_root_list_p p). (consistent_sign_vec_copr qs1 r) \<in> set(map (consistent_sign_vec_copr qs1) (characterize_root_list_p p))"
     by simp
   have mem_list2: "\<forall> r \<in> set (characterize_root_list_p p). (consistent_sign_vec_copr qs2 r) \<in> set(map (consistent_sign_vec_copr qs2) (characterize_root_list_p p))"
     by simp
   then show "\<exists>x1\<in>set (characterize_consistent_signs_at_roots_copr p qs1).
             \<exists>x2\<in>set (characterize_consistent_signs_at_roots_copr p qs2). x = x1 @ x2"
     using x_in_csv exr mem_list1 mem_list2 characterize_consistent_signs_at_roots_copr_def exr_iff by auto
 qed
 
 lemma subset_step:  
   fixes p:: "real poly"
   fixes qs1 qs2 :: "real poly list"
   fixes signs1 signs2 :: "rat list list"
   assumes csa1: "set (characterize_consistent_signs_at_roots_copr p qs1) \<subseteq> set (signs1)"
   assumes csa2: "set (characterize_consistent_signs_at_roots_copr p qs2) \<subseteq> set (signs2)"  
   shows "set (characterize_consistent_signs_at_roots_copr p
           (qs1 @ qs2))
     \<subseteq> set (signs_smash signs1 signs2)"
 proof - 
   have h0: "\<forall> x \<in> set (characterize_consistent_signs_at_roots_copr p (qs1 @ qs2)). \<exists> x1 \<in> set (characterize_consistent_signs_at_roots_copr p qs1). \<exists> x2 \<in> set (characterize_consistent_signs_at_roots_copr p qs2).
      (x = x1@x2)" using subset_helper[of p qs1 qs2]
     by blast 
   then have "\<forall>x \<in> set (characterize_consistent_signs_at_roots_copr p (qs1 @ qs2)). 
           x \<in> set (signs_smash (characterize_consistent_signs_at_roots_copr p qs1) 
           (characterize_consistent_signs_at_roots_copr p qs2))"
     unfolding signs_smash_def apply (auto)
     by fastforce 
   then have "\<forall>x \<in> set (characterize_consistent_signs_at_roots_copr p
           (qs1 @ qs2)). x \<in> set (signs_smash signs1 signs2)"
     using csa1 csa2 subset_smash_signs[of _ signs1 _ signs2] apply (auto)
     by blast 
   thus ?thesis
     by blast 
 qed
 
 subsection "Main Results"
 
 lemma dim_row_mat_of_rows_list[simp]:
   shows "dim_row (mat_of_rows_list nr ls) = length ls"
   unfolding mat_of_rows_list_def by auto
 
 lemma dim_col_mat_of_rows_list[simp]:
   shows "dim_col (mat_of_rows_list nr ls) = nr"
   unfolding mat_of_rows_list_def by auto
 
 lemma dim_row_matrix_A[simp]:
   shows "dim_row (matrix_A signs subsets) = length subsets"
   unfolding matrix_A_def by auto
 
 lemma dim_col_matrix_A[simp]:
   shows "dim_col (matrix_A signs subsets) = length signs"
   unfolding matrix_A_def by auto
 
 lemma length_signs_smash:
   shows
     "length (signs_smash signs1 signs2) = length signs1 * length signs2"
   unfolding signs_smash_def length_concat
   by (auto simp add: o_def sum_list_triv)
 
 lemma length_subsets_smash:
   shows
     "length (subsets_smash n subs1 subs2) = length subs1 * length subs2"
   unfolding subsets_smash_def length_concat
   by (auto simp add: o_def sum_list_triv)
 
 lemma length_eq_concat:
   assumes "\<And>x. x \<in> set ls \<Longrightarrow> length x = n"
   assumes "i < n * length ls"
   shows "concat ls ! i = ls ! (i div n) ! (i mod n)"
   using assms
 proof (induct ls arbitrary: i)
   case Nil
   then show ?case
     by simp
 next
   case (Cons a ls)
-  then show ?case
-    apply (auto simp add: nth_append)
-    using div_if mod_geq by auto
+  moreover have \<open>n > 0\<close>
+    by (rule ccontr) (use assms in auto)
+  ultimately show ?case
+    by (auto simp add: nth_append not_less dest: le_Suc_ex)
 qed
 
 lemma z_append:
   assumes "\<And>i. i \<in> set xs \<Longrightarrow> i < length as"
   shows "z (xs @ (map ((+) (length as)) ys)) (as @ bs) = z xs as * z ys bs"
 proof -
   have 1: "map ((!) (as @ bs)) xs = map ((!) as) xs"
     unfolding list_eq_iff_nth_eq
     using assms by (auto simp add:nth_append)
   have 2: "map ((!) (as @ bs) \<circ> (+) (length as)) ys = map ((!) bs) ys"
     unfolding list_eq_iff_nth_eq
     using assms by auto
   show ?thesis
     unfolding z_def apply auto
     unfolding 1 2 by auto
 qed
 
 (* Shows that the matrix of a smashed system is the Kronecker product of the matrices of the two
   systems being combined *)
 lemma matrix_construction_is_kronecker_product: 
   fixes qs1 :: "real poly list"
   fixes subs1 subs2 :: "nat list list"
   fixes signs1 signs2 :: "rat list list"
     (* n1 is the number of polynomials in the "1" sets *)
   assumes "\<And>l i. l \<in> set subs1 \<Longrightarrow> i \<in> set l \<Longrightarrow> i < n1"
   assumes "\<And>j. j \<in> set signs1 \<Longrightarrow> length j = n1"
   shows "
     (matrix_A (signs_smash signs1 signs2) (subsets_smash n1 subs1 subs2)) =
     kronecker_product (matrix_A signs1 subs1) (matrix_A signs2 subs2)"
   unfolding mat_eq_iff dim_row_matrix_A dim_col_matrix_A
     length_subsets_smash length_signs_smash dim_kronecker
 proof safe
   fix i j
   assume i: "i < length subs1 * length subs2"
      and j: "j < length signs1 * length signs2"
   have ld: "i div length subs2 < length subs1"
     "j div length signs2 < length signs1"
     using i j less_mult_imp_div_less by auto
   have lm: "i mod length subs2 < length subs2"
     "j mod length signs2 < length signs2"
     using i j less_mult_imp_mod_less by auto
 
   have n1: "n1 = length (signs1 ! (j div length signs2))"
     using assms(2) ld(2) nth_mem by blast
 
   have 1: "matrix_A (signs_smash signs1 signs2) (subsets_smash n1 subs1 subs2) $$ (i, j) =
     z (subsets_smash n1 subs1 subs2 ! i) (signs_smash signs1 signs2 ! j)"
     unfolding mat_of_rows_list_def matrix_A_def mtx_row_def
     using i j
     by (simp add: length_signs_smash length_subsets_smash)
   have 2: " ... = z (subs1 ! (i div length subs2) @ map ((+) n1) (subs2 ! (i mod length subs2)))
      (signs1 ! (j div length signs2) @ signs2 ! (j mod length signs2))"
     unfolding signs_smash_def subsets_smash_def
     apply (subst length_eq_concat)
     using i apply (auto simp add: mult.commute)
     apply (subst length_eq_concat)
     using j apply (auto simp add: mult.commute)
     using ld lm by auto
   have 3: "... =
   z (subs1 ! (i div length subs2)) (signs1 ! (j div length signs2)) *
   z (subs2 ! (i mod length subs2)) (signs2 ! (j mod length signs2))"
     unfolding n1
     apply (subst z_append)
      apply (auto simp add: n1[symmetric])
     using assms(1) ld(1) nth_mem by blast
   have 4: "kronecker_product (matrix_A signs1 subs1) (matrix_A signs2 subs2) $$ (i,j) =
     z (subs1 ! (i div length subs2))
      (signs1 ! (j div length signs2)) *
     z (subs2 ! (i mod length subs2))
      (signs2 ! (j mod length signs2))"
     unfolding kronecker_product_def matrix_A_def mat_of_rows_list_def mtx_row_def
     using i j apply (auto simp add: Let_def)
     apply (subst index_mat(1)[OF ld])
     apply (subst index_mat(1)[OF lm])
     using ld lm by auto
   show "matrix_A (signs_smash signs1 signs2) (subsets_smash n1 subs1 subs2) $$ (i, j) =
         kronecker_product (matrix_A signs1 subs1) (matrix_A signs2 subs2) $$ (i, j)"
     using 1 2 3 4 by auto 
 qed
 
 (* Given that two smaller systems satisfy some mild constraints, show that their combined system
   (after smashing the signs and subsets) satisfies the matrix equation, and that the matrix of the
   combined system is invertible. *)
 lemma inductive_step:
   fixes p:: "real poly"
   fixes qs1 qs2 :: "real poly list"
   fixes subsets1 subsets2 :: "nat list list"
   fixes signs1 signs2 :: "rat list list"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes nontriv2: "length qs2 > 0"
   assumes pairwise_rel_prime1: "\<forall>q. ((List.member qs1 q) \<longrightarrow> (coprime p q))"
   assumes pairwise_rel_prime2: "\<forall>q. ((List.member qs2 q) \<longrightarrow> (coprime p q))"
   assumes welldefined_signs1: "well_def_signs (length qs1) signs1"
   assumes welldefined_signs2: "well_def_signs (length qs2) signs2"
   assumes distinct_signs1: "distinct signs1"
   assumes distinct_signs2: "distinct signs2"
   assumes all_info1: "set (characterize_consistent_signs_at_roots_copr p qs1) \<subseteq> set(signs1)"
   assumes all_info2: "set (characterize_consistent_signs_at_roots_copr p qs2) \<subseteq> set(signs2)"
   assumes welldefined_subsets1: "all_list_constr (subsets1) (length qs1)"
   assumes welldefined_subsets2: "all_list_constr (subsets2) (length qs2)"
   assumes invertibleMtx1: "invertible_mat (matrix_A signs1 subsets1)"
   assumes invertibleMtx2: "invertible_mat (matrix_A signs2 subsets2)"
   shows "satisfy_equation p (qs1@qs2) (subsets_smash (length qs1) subsets1 subsets2) (signs_smash signs1 signs2) 
         \<and> invertible_mat (matrix_A (signs_smash signs1 signs2) (subsets_smash (length qs1) subsets1 subsets2))"
 proof - 
   have h1: "invertible_mat (matrix_A (signs_smash signs1 signs2) (subsets_smash (length qs1) subsets1 subsets2))"
     using matrix_construction_is_kronecker_product
       kronecker_invertible invertibleMtx1 invertibleMtx2
       welldefined_subsets1 welldefined_subsets2 unfolding all_list_constr_def list_constr_def
     by (smt in_set_conv_nth in_set_member list_all_length well_def_signs_def welldefined_signs1)
   have h2a: "distinct (signs_smash signs1 signs2)" 
     using distinct_signs1 distinct_signs2 welldefined_signs1 welldefined_signs2 nontriv1 nontriv2 
       distinct_step by auto
   have h2ba: "\<forall> q. List.member (qs1 @ qs2) q \<longrightarrow> (List.member qs1 q \<or> List.member qs2 q)" 
     unfolding member_def 
     by auto
   have h2b: "\<forall>q. ((List.member (qs1@qs2) q) \<longrightarrow> (coprime p q))" 
     using h2ba pairwise_rel_prime1 pairwise_rel_prime2 by auto
   have h2c: "all_list_constr ((subsets_smash (length qs1) subsets1 subsets2)) (length (qs1@qs2))" 
     using well_def_step
       welldefined_subsets1 welldefined_subsets2
     by blast
   have h2d: "set (characterize_consistent_signs_at_roots_copr p (qs1@qs2)) \<subseteq> set(signs_smash signs1 signs2)" 
     using subset_step all_info1 all_info2
     by simp 
   have h2: "satisfy_equation p (qs1@qs2) (subsets_smash (length qs1) subsets1 subsets2) (signs_smash signs1 signs2)"
     using matrix_equation[where p="p", where qs="qs1@qs2", where subsets = "subsets_smash (length qs1) subsets1 subsets2",
         where signs = "signs_smash signs1 signs2"] 
         h2a h2b h2c h2d apply (auto) using nonzero by blast
   show ?thesis using h1 h2 by blast
 qed
 
 section "Reduction Step Proofs"
   
 (* Some definitions *)
 definition get_matrix:: "(rat mat \<times> (nat list list \<times> rat list list)) \<Rightarrow> rat mat"
   where "get_matrix data = fst(data)"
 
 definition get_subsets:: "(rat mat \<times> (nat list list \<times> rat list list)) \<Rightarrow> nat list list"
   where "get_subsets data = fst(snd(data))"
 
 definition get_signs:: "(rat mat \<times> (nat list list \<times> rat list list)) \<Rightarrow> rat list list"
   where "get_signs data = snd(snd(data))"
 
 definition reduction_signs:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat \<Rightarrow> rat list list" 
   where "reduction_signs p qs signs subsets matr = 
     (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets matr)))"
 
 definition reduction_subsets:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat \<Rightarrow> nat list list" 
   where "reduction_subsets p qs signs subsets matr = 
     (take_indices subsets (rows_to_keep (reduce_mat_cols matr (solve_for_lhs p qs subsets matr))))"
 
 (* Some basic lemmas *)
 lemma reduction_signs_is_get_signs: "reduction_signs p qs signs subsets m =  get_signs (reduce_system p (qs, (m, (subsets, signs))))"
   unfolding reduction_signs_def get_signs_def
   by (metis reduce_system.simps reduction_step.elims snd_conv) 
 
 lemma reduction_subsets_is_get_subsets: "reduction_subsets p qs signs subsets m =  get_subsets (reduce_system p (qs, (m, (subsets, signs))))"
   unfolding reduction_subsets_def get_subsets_def
   by (metis fst_conv reduce_system.simps reduction_step.elims snd_conv)
 
 lemma find_zeros_from_vec_prop:
   fixes input_vec :: "rat vec"
   shows "\<forall>n < (dim_vec input_vec). ((input_vec $ n \<noteq> 0) \<longleftrightarrow>
          List.member (find_nonzeros_from_input_vec input_vec) n)"
 proof - 
   have h1: "\<forall>n < (dim_vec input_vec). ((input_vec $ n \<noteq> 0) \<longrightarrow>  List.member (find_nonzeros_from_input_vec input_vec) n)" 
     unfolding find_nonzeros_from_input_vec_def List.member_def  by auto
   have h2: "\<forall>n < (dim_vec input_vec). (List.member (find_nonzeros_from_input_vec input_vec) n \<longrightarrow> (input_vec $ n \<noteq> 0) )" 
     unfolding find_nonzeros_from_input_vec_def List.member_def by auto
   show ?thesis using h1 h2 by auto
 qed
 
 
 subsection "Showing sign conditions preserved when reducing"
 
 lemma take_indices_lem:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes arb_list :: "'a list list"
   fixes index_list :: "nat list" 
   fixes n:: "nat"
   assumes lest: "n < length (take_indices arb_list index_list)"
   assumes well_def: "\<forall>q.(List.member index_list q \<longrightarrow> q < length arb_list)"
   shows "\<exists>k<length arb_list.
             (take_indices arb_list index_list) ! n =  arb_list ! k"
   using lest well_def unfolding take_indices_def apply (auto)
   by (metis in_set_member nth_mem)
 
 lemma invertible_means_mult_id:
   fixes A:: "'a::field mat"
   assumes assm: "invertible_mat A"
   shows "matr_option (dim_row A)
      (mat_inverse (A))*A = 1\<^sub>m (dim_row A)"
 proof (cases "mat_inverse(A)")
   obtain n where n: "A \<in> carrier_mat n n"
     using assms invertible_mat_def square_mat.simps by blast
   case None
   then have "A \<notin> Units (ring_mat TYPE('a) n n)"
     by (simp add: mat_inverse(1) n)
   thus ?thesis
     by (meson assms det_non_zero_imp_unit invertible_Units n unit_imp_det_non_zero) 
 next
   case (Some a)
   then show ?thesis
     by (metis assms carrier_matI invertible_mat_def mat_inverse(2) matr_option.simps(2) square_mat.elims(2))
 qed
 
 lemma dim_invertible:
   fixes A:: "'a::field mat"
   fixes n:: "nat"
   assumes assm: "invertible_mat A"
   assumes dim: "A \<in> carrier_mat n n"
   shows "matr_option (dim_row A)
      (mat_inverse (A)) \<in> carrier_mat n n"
 proof (cases "mat_inverse(A)")
   obtain n where n: "A \<in> carrier_mat n n"
     using assms invertible_mat_def square_mat.simps by blast
   case None
   then have "A \<notin> Units (ring_mat TYPE('a) n n)"
     by (simp add: mat_inverse(1) n)
   thus ?thesis
     by (meson assms det_non_zero_imp_unit invertible_Units n unit_imp_det_non_zero) 
 next
   case (Some a)
   then show ?thesis
     using dim mat_inverse(2) by auto 
 qed
 
 lemma mult_assoc:
   fixes A B:: "rat mat"
   fixes v:: "rat vec"
   fixes n:: "nat"
   assumes "A \<in> carrier_mat n n"
   assumes "B \<in> carrier_mat n n"
   assumes "dim_vec v = n"
   shows "A *\<^sub>v (mult_mat_vec B v) =  (A*B)*\<^sub>v v"
   using assms(1) assms(2) assms(3) by auto
 
 lemma size_of_mat:
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   shows "(matrix_A signs subsets) \<in> carrier_mat (length subsets) (length signs)"
   unfolding matrix_A_def carrier_mat_def by auto
 
 lemma size_of_lhs: 
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes signs :: "rat list list" 
   shows "dim_vec (construct_lhs_vector p qs signs) = length signs"
   unfolding construct_lhs_vector_def
   by simp
 
 lemma size_of_rhs: 
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list" 
   shows "dim_vec (construct_rhs_vector p qs subsets) = length subsets"
   unfolding construct_rhs_vector_def
   by simp
 
 lemma same_size:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes invertible_mat: "invertible_mat (matrix_A signs subsets)"
   shows "length subsets = length signs"
   using invertible_mat unfolding invertible_mat_def
   using size_of_mat[of signs subsets] size_of_lhs[of p qs signs] size_of_rhs[of p qs subsets]
   by simp
 
 lemma mat_equal_list_lem:
   fixes A:: "'a::field mat"
   fixes B:: "'a::field mat"
   shows "(dim_row A = dim_row B \<and> dim_col A = dim_col B \<and> mat_to_list A = mat_to_list B)
     \<Longrightarrow> A = B"
 proof - 
   assume hyp: "dim_row A = dim_row B \<and> dim_col A = dim_col B \<and> mat_to_list A = mat_to_list B"
   then have "\<And>i j. i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> B $$ (i, j) = A $$ (i, j)"
     unfolding mat_to_list_def by auto
   then show ?thesis using hyp
     unfolding mat_to_list_def
     using eq_matI[of A B]
     by metis 
 qed
 
 lemma mat_inverse_same: "mat_inverse_var A = mat_inverse A"
   unfolding mat_inverse_var_def mat_inverse_def mat_equal_def
   using mat_equal_list_lem apply (simp)
   by (smt case_prod_beta index_one_mat(2) index_one_mat(3) mat_equal_list_lem) 
 
 lemma construct_lhs_matches_solve_for_lhs:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes match: "satisfy_equation p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A signs subsets)"
   shows "(construct_lhs_vector p qs signs) = solve_for_lhs p qs subsets (matrix_A signs subsets)"
 proof -
   have matrix_equation_hyp: "(mult_mat_vec (matrix_A signs subsets) (construct_lhs_vector p qs signs) = (construct_rhs_vector p qs subsets))"
     using match unfolding satisfy_equation_def by blast
   then have eqn_hyp: " ((matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) *\<^sub>v (mult_mat_vec (matrix_A signs subsets) (construct_lhs_vector p qs signs)) = 
       mult_mat_vec (matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) (construct_rhs_vector p qs subsets))"
     using invertible_mat 
     by (simp add: matrix_equation_hyp) 
   have match_hyp: "length subsets = length signs" using same_size invertible_mat by auto 
   then have dim_hyp1: "matrix_A signs subsets \<in> carrier_mat (length signs) (length signs)"
     using size_of_mat
     by auto 
   then have dim_hyp2: "matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets)) \<in> carrier_mat (length signs) (length signs)"
     using invertible_mat dim_invertible
     by blast 
   have mult_assoc_hyp: "((matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) *\<^sub>v (mult_mat_vec (matrix_A signs subsets) (construct_lhs_vector p qs signs)))
     = (((matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) * (matrix_A signs subsets)) *\<^sub>v  (construct_lhs_vector p qs signs))"
     using mult_assoc dim_hyp1 dim_hyp2 size_of_lhs by auto
   have cancel_helper: "(((matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) * (matrix_A signs subsets)) *\<^sub>v  (construct_lhs_vector p qs signs))
   = (1\<^sub>m (length signs)) *\<^sub>v   (construct_lhs_vector p qs signs)"
     using invertible_means_mult_id[where A= "matrix_A signs subsets"] dim_hyp1
     by (simp add: invertible_mat match_hyp) 
   then have cancel_hyp: "(((matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) * (matrix_A signs subsets)) *\<^sub>v  (construct_lhs_vector p qs signs))
   = (construct_lhs_vector p qs signs)"
     apply (auto)
     by (metis carrier_vec_dim_vec one_mult_mat_vec size_of_lhs)
   then have mult_hyp: "((matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) *\<^sub>v (mult_mat_vec (matrix_A signs subsets) (construct_lhs_vector p qs signs)))
     = (construct_lhs_vector p qs signs)"
     using mult_assoc_hyp cancel_hyp  
     by simp
   then have "(construct_lhs_vector p qs signs) =  (mult_mat_vec (matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets))) (construct_rhs_vector p qs subsets)) "
     using eqn_hyp
     by simp 
   then show ?thesis
     unfolding solve_for_lhs_def
     by (simp add: mat_inverse_same)
 qed
 
 (* If set(A) is a subset of B then for all n, nth c n = 0 means nth a n not in B  *)
 lemma reduction_signs_set_helper_lemma:
   fixes A:: "rat list set"
   fixes C:: "rat vec"
   fixes B:: "rat list list"
   assumes "dim_vec C = length B"
   assumes sub: "A \<subseteq> set(B)"
   assumes not_in_hyp: "\<forall> n < dim_vec C. C $ n = 0 \<longrightarrow> (nth B n) \<notin> A"
   shows "A \<subseteq> set (take_indices B
              (find_nonzeros_from_input_vec C))"
 proof - 
   have unfold: "\<And> x. (x \<in> A \<Longrightarrow> x \<in> set (take_indices B
              (find_nonzeros_from_input_vec C)))"   
   proof -
     fix x
     assume in_a: "x \<in> A"
     have "x \<in> set (B)" 
       using sub in_a by blast
     then have "\<exists> n < length B. nth B n = x"
       by (simp add: in_set_conv_nth)
     then have "\<exists> n < length B. (nth B n = x \<and> (List.member (find_nonzeros_from_input_vec C) n) = True)"
       using not_in_hyp find_zeros_from_vec_prop[of C]
       using assms(1) in_a by auto 
     thus "x \<in> set (take_indices B
              (find_nonzeros_from_input_vec C))" 
       unfolding take_indices_def
       using member_def by fastforce 
   qed
   then show ?thesis
     by blast 
 qed
 
 lemma reduction_signs_set_helper_lemma2:
   fixes A:: "rat list set"
   fixes C:: "rat vec"
   fixes B:: "rat list list"
   assumes dist: "distinct B"
   assumes eq_len: "dim_vec C = length B"
   assumes sub: "A \<subseteq> set(B)"
   assumes not_in_hyp: "\<forall> n < dim_vec C. C $ n \<noteq> 0 \<longrightarrow> (nth B n) \<in> A"
   shows "set (take_indices B
              (find_nonzeros_from_input_vec C)) \<subseteq> A"
 proof - 
   have unfold: "\<And> x. (x \<in> (set (take_indices B
              (find_nonzeros_from_input_vec C))) \<Longrightarrow> x \<in> A)"   
   proof -
     fix x
     assume in_set: "x \<in> set (take_indices B (find_nonzeros_from_input_vec C))"
     have h: "\<exists>n< dim_vec C. (C $ n \<noteq> 0 \<and> (nth B n) = x)"
     proof - 
       have h1: "\<exists>n < length B.(nth B n) = x" 
         using in_set unfolding take_indices_def
           find_nonzeros_from_input_vec_def eq_len by auto
       have h2: "\<forall>n< length B. (nth B n = x \<longrightarrow> List.member (find_nonzeros_from_input_vec C) n)"
       proof clarsimp 
         fix n
         assume leq_hyp: "n < length B"
         assume x_eq: "x = B ! n"
         have h: "(B !n) \<in> set (map ((!) B) (find_nonzeros_from_input_vec C))"
           using x_eq in_set
           by (simp add: take_indices_def) 
         then have h2: "List.member (map ((!) B) (find_nonzeros_from_input_vec C)) (B ! n)"
           using in_set
           by (meson in_set_member) 
         then have h3: "\<exists>k< length B. (List.member (find_nonzeros_from_input_vec C) k \<and> ((B ! k) = (B ! n)))"
           by (smt atLeastLessThan_iff eq_len find_nonzeros_from_input_vec_def imageE in_set_member mem_Collect_eq set_filter set_map set_upt)
         have h4: "\<forall>v< length B. ((B ! v) = (B ! n) \<longrightarrow> v = n)"
           using dist apply (auto)
           using leq_hyp nth_eq_iff_index_eq by blast
         then show "List.member (find_nonzeros_from_input_vec C) n"
           using h2 h3 h4 by auto
       qed
       then have "\<forall>n<length B. (nth B n = x \<longrightarrow> C $ n \<noteq> 0)" 
         using find_zeros_from_vec_prop [of C]
         by (simp add: eq_len)
       then show ?thesis using h1 eq_len
         by auto 
     qed
     thus "x \<in> A" using not_in_hyp 
       by blast 
   qed
   then show ?thesis
     by blast 
 qed
 
 (* Show that dropping columns doesn't affect the consistent sign assignments *)
 lemma reduction_doesnt_break_things_signs:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A signs subsets)"
   shows "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(reduction_signs p qs signs subsets (matrix_A signs subsets))"
 proof - 
   have dim_hyp2: "matr_option (dim_row (matrix_A signs subsets))
      (mat_inverse (matrix_A signs subsets)) \<in> carrier_mat (length signs) (length signs)"
     using invertible_mat dim_invertible
     using same_size by fastforce 
   have "(construct_lhs_vector p qs signs) = solve_for_lhs p qs subsets (matrix_A signs subsets)"
     using construct_lhs_matches_solve_for_lhs assms by auto
   then have "(solve_for_lhs p qs subsets (matrix_A signs subsets)) =
    vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) signs))" 
     using construct_lhs_vector_cleaner assms
     by (metis (mono_tags, lifting) list.map_cong map_map o_apply of_int_of_nat_eq)
   then have "\<forall> n < (dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))). 
        (((solve_for_lhs p qs subsets (matrix_A signs subsets)) $ n = 0) \<longrightarrow>
        (nth signs n) \<notin> set (characterize_consistent_signs_at_roots_copr p qs))"
   proof - 
     have h0: "\<forall> n < (dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))). 
        (((solve_for_lhs p qs subsets (matrix_A signs subsets)) $ n = 0) \<longrightarrow> 
        rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = (nth signs n)}) = 0)"
       by (metis (mono_tags, lifting) \<open>construct_lhs_vector p qs signs = solve_for_lhs p qs subsets (matrix_A signs subsets)\<close> construct_lhs_vector_clean nonzero of_nat_0_eq_iff of_rat_of_nat_eq size_of_lhs)
     have h1: "\<forall> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}) = 0 \<longrightarrow> 
         (\<nexists> x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w))"
     proof clarsimp 
       fix x
       assume card_asm: "card {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = consistent_sign_vec_copr qs x} = 0"
       assume zero_asm: "poly p x = 0"
       have card_hyp: "{xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = consistent_sign_vec_copr qs x} = {}"
         using card_eq_0_iff
         using card_asm nonzero poly_roots_finite by fastforce 
       have "x \<in> {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = consistent_sign_vec_copr qs x}"
         using zero_asm by auto
       thus "False" using card_hyp
         by blast
     qed
     have h2: "\<And> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}) = 0 \<Longrightarrow>
        (\<not>List.member (characterize_consistent_signs_at_roots_copr p qs) w))"
       by (smt (verit, best) characterize_consistent_signs_at_roots_copr_def characterize_root_list_p_def h1 imageE in_set_member mem_Collect_eq nonzero poly_roots_finite set_map set_remdups sorted_list_of_set(1))
     then have h3: "\<forall> w. rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}) = 0 \<longrightarrow> 
         w \<notin> set (characterize_consistent_signs_at_roots_copr p qs)"
       by (simp add: in_set_member)
     show ?thesis using h0 h3
       by blast 
   qed
   then have "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set (take_indices signs
              (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"
     using all_info
       reduction_signs_set_helper_lemma[where A = "set (characterize_consistent_signs_at_roots_copr p qs)", where B = "signs",
       where C = "(solve_for_lhs p qs subsets (matrix_A signs subsets))"]
     using dim_hyp2 solve_for_lhs_def by (simp add: mat_inverse_same)
   then show ?thesis unfolding reduction_signs_def by auto
 qed
 
 lemma reduction_deletes_bad_sign_conds:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A signs subsets)"
   shows "set (characterize_consistent_signs_at_roots_copr p qs) = set(reduction_signs p qs signs subsets (matrix_A signs subsets))"
 proof - 
   have dim_hyp2: "matr_option (dim_row (matrix_A signs subsets))
        (mat_inverse (matrix_A signs subsets)) \<in> carrier_mat (length signs) (length signs)"
     using invertible_mat dim_invertible
     using same_size by fastforce 
   have supset: "set (characterize_consistent_signs_at_roots_copr p qs) \<supseteq> set(reduction_signs p qs signs subsets (matrix_A signs subsets))" 
   proof - 
     have "(construct_lhs_vector p qs signs) = solve_for_lhs p qs subsets (matrix_A signs subsets)"
       using construct_lhs_matches_solve_for_lhs assms by auto
     then have "(solve_for_lhs p qs subsets (matrix_A signs subsets)) =
        vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) signs))" 
       using construct_lhs_vector_cleaner assms
       by (metis (mono_tags, lifting) list.map_cong map_map o_apply of_int_of_nat_eq)
     then have "\<forall> n < (dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))). 
            (((solve_for_lhs p qs subsets (matrix_A signs subsets)) $ n \<noteq> 0) \<longrightarrow>
            (nth signs n) \<in> set (characterize_consistent_signs_at_roots_copr p qs))"
     proof - 
       have h0: "\<forall> n < (dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))). 
            (((solve_for_lhs p qs subsets (matrix_A signs subsets)) $ n = 0) \<longrightarrow> 
            rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = (nth signs n)}) = 0)"
         by (metis (mono_tags, lifting) \<open>construct_lhs_vector p qs signs = solve_for_lhs p qs subsets (matrix_A signs subsets)\<close> construct_lhs_vector_clean nonzero of_nat_0_eq_iff of_rat_of_nat_eq size_of_lhs)
       have h1: "\<forall> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}) \<noteq> 0 \<longrightarrow> 
             (\<exists> x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w))"
       proof clarsimp 
         fix w
         assume card_asm: "0 < card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}"
         show "\<exists>x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w"
           by (metis (mono_tags, lifting) Collect_empty_eq card_asm card_eq_0_iff gr_implies_not0)
       qed
       have h2: "\<And> w. (rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}) \<noteq> 0 \<Longrightarrow>
            (List.member (characterize_consistent_signs_at_roots_copr p qs) w))"
       proof clarsimp 
         fix w
         assume card_asm: " 0 < card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}"
         have h0: "\<exists>x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w"
           using card_asm
           by (simp add: h1) 
         then show "List.member (characterize_consistent_signs_at_roots_copr p qs) w" 
           unfolding characterize_consistent_signs_at_roots_copr_def
           using in_set_member nonzero poly_roots_finite characterize_root_list_p_def by fastforce
       qed
       then have h3: "\<forall> w. rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = w}) \<noteq> 0 \<longrightarrow> 
             w \<in> set (characterize_consistent_signs_at_roots_copr p qs)"
         by (simp add: in_set_member)
       show ?thesis using h0 h3
         by (metis (no_types, lifting) \<open>solve_for_lhs p qs subsets (matrix_A signs subsets) = vec_of_list (map rat_of_nat (map (\<lambda>s. card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) signs))\<close> dim_vec_of_list length_map nth_map vec_of_list_index)
     qed
     then have "set (take_indices signs
                  (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) \<subseteq>
               set (characterize_consistent_signs_at_roots_copr p qs)"
       using all_info
         reduction_signs_set_helper_lemma2[where A = "set (characterize_consistent_signs_at_roots_copr p qs)", where B = "signs",
         where C = "(solve_for_lhs p qs subsets (matrix_A signs subsets))"]
       using distinct_signs dim_hyp2 solve_for_lhs_def
       by (simp add: mat_inverse_same)
     then show ?thesis unfolding reduction_signs_def by auto
   qed
   have subset: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(reduction_signs p qs signs subsets (matrix_A signs subsets))" 
     using reduction_doesnt_break_things_signs[of p qs signs subsets] assms
     by blast 
   then show ?thesis using supset subset by auto 
 qed
 
 theorem reduce_system_sign_conditions:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A signs subsets)"
   shows "set (get_signs (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs))))) = set (characterize_consistent_signs_at_roots_copr p qs)"
   unfolding get_signs_def
   using reduction_deletes_bad_sign_conds[of p qs signs subsets] apply (auto)
    apply (simp add: all_info distinct_signs match nonzero reduction_signs_def welldefined_signs1)
   using nonzero invertible_mat apply (metis snd_conv)
   by (metis all_info distinct_signs invertible_mat match nonzero reduction_signs_def snd_conv welldefined_signs1) 
 
 subsection "Showing matrix equation preserved when reducing"
 lemma rows_to_keep_lem:
   fixes A:: "('a::field) mat"
   shows "\<And>ell. ell \<in> set (rows_to_keep A) \<Longrightarrow> ell < dim_row A"
   unfolding rows_to_keep_def
   apply auto
   using rref_pivot_positions
   by (metis carrier_mat_triv gauss_jordan_single(2) gauss_jordan_single(3) index_transpose_mat(3)) 
 
 lemma reduce_system_matrix_equation_preserved:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs: "well_def_signs (length qs) signs"
   assumes welldefined_subsets: "all_list_constr (subsets) (length qs)"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   assumes invertible_mat: "invertible_mat (matrix_A signs subsets)"
   assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   shows "satisfy_equation p qs (get_subsets (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
   (get_signs (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))"
 proof - 
   have poly_type_hyp: "p \<noteq> 0" using nonzero by auto
   have distinct_signs_hyp: "distinct (snd (snd (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs))))))" 
   proof - 
     let ?sym = "(find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
     have h1: "\<forall> i < length (take_indices signs ?sym). \<forall>j < length(take_indices signs ?sym).
       i \<noteq> j \<longrightarrow> nth (take_indices signs ?sym) i \<noteq> nth (take_indices signs ?sym) j" 
       using distinct_signs unfolding take_indices_def 
     proof clarsimp 
       fix i
       fix j
       assume "distinct signs"
       assume "i < length
                 (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
       assume "j < length
                 (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
       assume neq_hyp: "i \<noteq> j"
       assume "signs ! (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets 
               (matrix_A signs subsets)) ! i) =
            signs ! (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets 
               (matrix_A signs subsets)) ! j)"
       have h1: "find_nonzeros_from_input_vec (solve_for_lhs p qs subsets 
               (matrix_A signs subsets)) ! i \<noteq> find_nonzeros_from_input_vec (solve_for_lhs p qs subsets 
               (matrix_A signs subsets)) ! j"
         unfolding find_nonzeros_from_input_vec_def using neq_hyp
         by (metis \<open>i < length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> \<open>j < length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> distinct_conv_nth distinct_filter distinct_upt find_nonzeros_from_input_vec_def) 
       then show "False" using distinct_signs
       proof -
         have f1: "\<forall>p ns n. ((n::nat) \<in> {n \<in> set ns. p n}) = (n \<in> set ns \<and> n \<in> Collect p)"
           by simp
         then have f2: "filter (\<lambda>n. solve_for_lhs p qs subsets (matrix_A signs subsets) $ n \<noteq> 0) [0..<dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))] ! i \<in> set [0..<length signs]"
           by (metis (full_types) \<open>i < length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> construct_lhs_matches_solve_for_lhs find_nonzeros_from_input_vec_def invertible_mat match nth_mem set_filter size_of_lhs)
         have "filter (\<lambda>n. solve_for_lhs p qs subsets (matrix_A signs subsets) $ n \<noteq> 0) [0..<dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))] ! j \<in> set [0..<length signs]"
           using f1 by (metis (full_types) \<open>j < length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> construct_lhs_matches_solve_for_lhs find_nonzeros_from_input_vec_def invertible_mat match nth_mem set_filter size_of_lhs)
         then show ?thesis
           using f2 by (metis \<open>signs ! (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)) ! i) = signs ! (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)) ! j)\<close> atLeastLessThan_iff distinct_conv_nth distinct_signs find_nonzeros_from_input_vec_def h1 set_upt)
       qed
     qed
     then have "distinct (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"
       using distinct_conv_nth by blast 
     then show ?thesis
       using get_signs_def reduction_signs_def reduction_signs_is_get_signs by auto 
   qed
   have all_info_hyp: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(snd (snd (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs))))))"
     using reduce_system_sign_conditions assms unfolding get_signs_def by auto
   have pairwise_rel_prime_hyp: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))" 
     using pairwise_rel_prime by auto
   have welldefined_hyp: "all_list_constr (fst (snd (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))) (length qs)"
     using welldefined_subsets rows_to_keep_lem
     unfolding all_list_constr_def List.member_def list_constr_def list_all_def
     apply (auto simp add: Let_def take_indices_def take_cols_from_matrix_def)
     using nth_mem by fastforce
   then show ?thesis using poly_type_hyp distinct_signs_hyp all_info_hyp pairwise_rel_prime_hyp welldefined_hyp
     using matrix_equation unfolding get_subsets_def get_signs_def
     by blast 
 qed
 
 (* Show that we are tracking the correct matrix in the algorithm *)
 subsection "Showing matrix preserved"
 lemma reduce_system_matrix_signs_helper_aux:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length signs"
   assumes nonzero: "p \<noteq> 0"
   shows "alt_matrix_A (take_indices signs S) subsets = take_cols_from_matrix (alt_matrix_A signs subsets) S"
 proof - 
   have h0a: "dim_col (take_cols_from_matrix (alt_matrix_A signs subsets) S) = length (take_indices signs S)" 
     unfolding take_cols_from_matrix_def apply (auto) unfolding take_indices_def by auto
   have h0: "\<forall>i < length (take_indices signs S). (col (alt_matrix_A (take_indices signs S) subsets ) i = 
 col (take_cols_from_matrix (alt_matrix_A signs subsets) S) i)" 
   proof clarsimp
     fix i
     assume asm: "i < length (take_indices signs S)"
     have i_lt: "i < length (map ((!) (cols (alt_matrix_A signs subsets))) S)" using asm
       apply (auto) unfolding take_indices_def by auto
     have h0: " vec (length subsets) (\<lambda>j. z (subsets ! j) (map ((!) signs) S ! i)) = 
       vec (length subsets) (\<lambda>j. z (subsets ! j) (signs ! (S ! i)))" using nth_map
       by (metis \<open>i < length (take_indices signs S)\<close> length_map take_indices_def) 
     have dim: "(map ((!) (cols (alt_matrix_A signs subsets))) S) ! i \<in> carrier_vec (dim_row (alt_matrix_A signs subsets))"
     proof - 
       have "dim_col (alt_matrix_A signs subsets) = length (signs)"
         by (simp add: alt_matrix_A_def) 
       have well_d: "S ! i < length (signs)" using well_def_h
         using i_lt in_set_member by fastforce 
       have 
         map_eq: "(map ((!) (cols (alt_matrix_A signs subsets))) S) ! i  = nth (cols (alt_matrix_A signs subsets))  (S ! i)"
         using i_lt by auto
       have "nth (cols (alt_matrix_A signs subsets))  (S ! i) \<in> carrier_vec (dim_row (alt_matrix_A signs subsets))"
         using col_dim unfolding cols_def using nth_map well_d
         by (simp add: \<open>dim_col (alt_matrix_A signs subsets) = length signs\<close>) 
       then show ?thesis using map_eq unfolding alt_matrix_A_def by auto
     qed
     have h1: "col (take_cols_from_matrix (alt_matrix_A signs subsets) S) i = 
       col (mat_of_cols (dim_row (alt_matrix_A signs subsets)) (map ((!) (cols (alt_matrix_A signs subsets))) S)) i "
       by (simp add: take_cols_from_matrix_def take_indices_def)
     have h2: "col (mat_of_cols (dim_row (alt_matrix_A signs subsets)) (map ((!) (cols (alt_matrix_A signs subsets))) S)) i 
       = nth (map ((!) (cols (alt_matrix_A signs subsets))) S) i " 
       using dim i_lt asm col_mat_of_cols[where j = "i", where n = "(dim_row (alt_matrix_A signs subsets))",
           where vs = "(map ((!) (cols (alt_matrix_A signs subsets))) S)"]
       by blast 
     have h3: "col (take_cols_from_matrix (alt_matrix_A signs subsets) S) i = (col (alt_matrix_A signs subsets) (S !i))"
       using h1 h2 apply (auto)
       by (metis alt_matrix_char asm cols_nth dim_col_mat(1) in_set_member length_map mat_of_rows_list_def matrix_A_def nth_map nth_mem take_indices_def well_def_h)
     have "vec (length subsets) (\<lambda>j. z (subsets ! j) (signs ! (S ! i))) = (col (alt_matrix_A signs subsets) (S !i))"
       by (metis asm in_set_member length_map nth_mem signs_are_cols take_indices_def well_def_h)
     then have "vec (length subsets) (\<lambda>j. z (subsets ! j) (take_indices signs S ! i)) =
       col (take_cols_from_matrix (alt_matrix_A signs subsets) S) i "
       using h0 h3
       by (simp add: take_indices_def) 
     then show "col (alt_matrix_A (take_indices signs S) subsets) i =
          col (take_cols_from_matrix (alt_matrix_A signs subsets) S) i "
       using asm signs_are_cols[where signs = "(take_indices signs S)", where subsets = "subsets"] 
       by auto
   qed
   then show ?thesis   unfolding alt_matrix_A_def take_cols_from_matrix_def apply (auto) 
     using h0a mat_col_eqI
     by (metis alt_matrix_A_def dim_col_mat(1) dim_row_mat(1) h0 mat_of_cols_def take_cols_from_matrix_def) 
 qed
 
 
 lemma reduce_system_matrix_signs_helper:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length signs"
   assumes nonzero: "p \<noteq> 0"
   shows "matrix_A (take_indices signs S) subsets = take_cols_from_matrix (matrix_A signs subsets) S"
   using reduce_system_matrix_signs_helper_aux alt_matrix_char assms by auto
 
 lemma reduce_system_matrix_subsets_helper_aux:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes inv: "length subsets \<ge> length signs"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length subsets"
   assumes nonzero: "p \<noteq> 0"
   shows "alt_matrix_A signs (take_indices subsets S) = take_rows_from_matrix (alt_matrix_A signs subsets) S"
 proof - 
   have h0a: "dim_row (take_rows_from_matrix (alt_matrix_A signs subsets) S) = length (take_indices subsets S)" 
     unfolding take_rows_from_matrix_def apply (auto) unfolding take_indices_def by auto
   have h0: "\<forall>i < length (take_indices subsets S). (row (alt_matrix_A signs (take_indices subsets S) ) i = 
 row (take_rows_from_matrix (alt_matrix_A signs subsets) S) i)" 
   proof clarsimp
     fix i
     assume asm: "i < length (take_indices subsets S)"
     have i_lt: "i < length (map ((!) (rows (alt_matrix_A signs subsets))) S)" using asm
       apply (auto) unfolding take_indices_def by auto
     have h0: "row (take_rows_from_matrix (alt_matrix_A signs subsets) S) i =
     row (mat_of_rows (dim_col (alt_matrix_A signs subsets)) (map ((!) (rows (alt_matrix_A signs subsets))) S)) i "
       unfolding take_rows_from_matrix_def take_indices_def by auto
     have dim: "(map ((!) (rows (alt_matrix_A signs subsets))) S) ! i \<in> carrier_vec (dim_col (alt_matrix_A signs subsets))"
     proof - 
       have "dim_col (alt_matrix_A signs subsets) = length (signs)"
         by (simp add: alt_matrix_A_def) 
       then have lenh: "dim_col (alt_matrix_A signs subsets) \<le> length (subsets)"
         using assms
         by auto 
       have well_d: "S ! i < length (subsets)" using well_def_h
         using i_lt in_set_member by fastforce 
       have 
         map_eq: "(map ((!) (rows (alt_matrix_A signs subsets))) S) ! i  = nth (rows (alt_matrix_A signs subsets))  (S ! i)"
         using i_lt by auto
       have "nth (rows (alt_matrix_A signs subsets))  (S ! i) \<in> carrier_vec (dim_col (alt_matrix_A signs subsets))"
         using col_dim unfolding rows_def using nth_map well_d
         using lenh
         by (simp add: alt_matrix_A_def) 
       then show ?thesis using map_eq unfolding alt_matrix_A_def by auto
     qed
     have h1: " row (mat_of_rows (dim_col (alt_matrix_A signs subsets)) (map ((!) (rows (alt_matrix_A signs subsets))) S)) i
       = (row  (alt_matrix_A signs subsets) (S ! i)) "
       using dim i_lt mat_of_rows_row[where i = "i", where n = "(dim_col (alt_matrix_A signs subsets))",
           where vs = "(map ((!) (rows (alt_matrix_A signs subsets))) S)"]
       using alt_matrix_char in_set_member nth_mem well_def_h by fastforce
     have "row (alt_matrix_A signs (take_indices subsets S) ) i = (row  (alt_matrix_A signs subsets) (S ! i))"
       using subsets_are_rows
     proof -
       have f1: "i < length S"
         by (metis (no_types) asm length_map take_indices_def)
       then have "List.member S (S ! i)"
         by (meson in_set_member nth_mem)
       then show ?thesis
         using f1 by (simp add: \<open>\<And>subsets signs. \<forall>i<length subsets. row (alt_matrix_A signs subsets) i = vec (length signs) (\<lambda>j. z (subsets ! i) (signs ! j))\<close> take_indices_def well_def_h)
     qed 
     then show "(row (alt_matrix_A signs (take_indices subsets S) ) i = 
       row (take_rows_from_matrix (alt_matrix_A signs subsets) S) i)" 
       using h0 h1 unfolding take_indices_def by auto
   qed
   then show ?thesis  unfolding alt_matrix_A_def take_rows_from_matrix_def apply (auto) 
     using eq_rowI
     by (metis alt_matrix_A_def dim_col_mat(1) dim_row_mat(1) h0 length_map mat_of_rows_def take_indices_def take_rows_from_matrix_def) 
 qed
 
 
 lemma reduce_system_matrix_subsets_helper:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   fixes S:: "nat list"
   assumes nonzero: "p \<noteq> 0"
   assumes inv: "length subsets \<ge> length signs"
   assumes well_def_h: "\<forall>x. List.member S x \<longrightarrow> x < length subsets"
   shows "matrix_A signs (take_indices subsets S) = take_rows_from_matrix (matrix_A signs subsets) S"
   using assms reduce_system_matrix_subsets_helper_aux alt_matrix_char
   by auto
 
 lemma reduce_system_matrix_match:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   assumes inv: "invertible_mat (matrix_A signs subsets)"
   shows "matrix_A (get_signs (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
   (get_subsets (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs))))) = 
   (get_matrix (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))"
 proof -
   let ?A = "(matrix_A signs subsets)"
   let ?lhs_vec = "(solve_for_lhs p qs subsets (matrix_A signs subsets))"
   let ?red_mtx = "(take_rows_from_matrix (reduce_mat_cols (matrix_A signs subsets) ?lhs_vec) (rows_to_keep (reduce_mat_cols (matrix_A signs subsets) ?lhs_vec)))"
   have h1: "matrix_A (get_signs (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
   (get_subsets (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
    = matrix_A (reduction_signs p qs signs subsets (matrix_A signs subsets)) (reduction_subsets p qs signs subsets (matrix_A signs subsets))"
     using reduction_signs_is_get_signs reduction_subsets_is_get_subsets by auto
   have h1_var: "matrix_A (get_signs (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
   (get_subsets (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
    = matrix_A (take_indices signs (find_nonzeros_from_input_vec ?lhs_vec)) (take_indices subsets (rows_to_keep (reduce_mat_cols ?A ?lhs_vec)))"
     using h1 reduction_signs_def reduction_subsets_def by auto 
   have h2: "?red_mtx = (take_rows_from_matrix (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec)) (rows_to_keep (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec))))"
     by simp
   have h30: "(construct_lhs_vector p qs signs) = ?lhs_vec"
     using assms construct_lhs_matches_solve_for_lhs
     by simp 
   have h3a: "\<forall>x. List.member (find_nonzeros_from_input_vec ?lhs_vec) x \<longrightarrow>x < length (signs)" 
     using h30 size_of_lhs unfolding find_nonzeros_from_input_vec_def apply (auto)
     by (metis atLeastLessThan_iff filter_is_subset member_def set_upt subset_eq) 
   have h3b_a: "\<forall>x. List.member (find_nonzeros_from_input_vec ?lhs_vec) x \<longrightarrow>x < length (subsets)" 
     using assms h30 size_of_lhs same_size unfolding find_nonzeros_from_input_vec_def apply (auto)
     by (simp add: find_nonzeros_from_input_vec_def h3a)
   have h3ba: "length
      (filter (\<lambda>i. solve_for_lhs p qs subsets (matrix_A signs subsets) $ i \<noteq> 0)
        [0..<length subsets])
     \<le> length subsets" using length_filter_le[where P = "(\<lambda>i. solve_for_lhs p qs subsets (matrix_A signs subsets) $ i \<noteq> 0)",
     where xs = "[0..<length subsets]"] length_upto by auto
   have " length subsets = dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))"
     using h30 inv size_of_lhs same_size[of signs subsets] apply (auto)
     by metis 
   then have "length
      (filter (\<lambda>i. solve_for_lhs p qs subsets (matrix_A signs subsets) $ i \<noteq> 0)
        [0..<dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))])
     \<le> length subsets" using h3ba
     by auto
   then have h3b: "length subsets \<ge> length (take_indices signs (find_nonzeros_from_input_vec ?lhs_vec))" 
     unfolding take_indices_def find_nonzeros_from_input_vec_def by auto
   have h3c: "\<forall>x. List.member (rows_to_keep (reduce_mat_cols ?A ?lhs_vec)) x \<longrightarrow> x < length (subsets)"
   proof clarsimp
     fix x
     assume x_mem: "List.member (rows_to_keep
             (take_cols_from_matrix (matrix_A signs subsets)
               (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))) x"
     obtain nn :: "rat list list \<Rightarrow> nat list \<Rightarrow> nat" where
       "\<forall>x2 x3. (\<exists>v4. v4 \<in> set x3 \<and> \<not> v4 < length x2) = (nn x2 x3 \<in> set x3 \<and> \<not> nn x2 x3 < length x2)"
       by moura
     then have f4: "nn signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<in> set (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<and> \<not> nn signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) < length signs \<or> matrix_A (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) subsets = take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
       using h3a nonzero reduce_system_matrix_signs_helper by auto
     then have "matrix_A (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) subsets = take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<and> x \<in> set (map snd (pivot_positions (gauss_jordan_single (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))\<^sup>T)))"
       using f4
       by (metis h3a in_set_member rows_to_keep_def x_mem)
     thus "x < length (subsets)" using x_mem unfolding rows_to_keep_def
       by (metis (no_types) dim_row_matrix_A rows_to_keep_def rows_to_keep_lem)
   qed
   have h3: "matrix_A (take_indices signs (find_nonzeros_from_input_vec ?lhs_vec)) (take_indices subsets (rows_to_keep (reduce_mat_cols ?A ?lhs_vec))) = 
     (take_rows_from_matrix (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec)) (rows_to_keep (take_cols_from_matrix ?A (find_nonzeros_from_input_vec ?lhs_vec))))" 
     using inv h3a h3b h3c reduce_system_matrix_subsets_helper reduce_system_matrix_signs_helper
       assms by auto
   show ?thesis using h1 h2 h3
     by (metis fst_conv get_matrix_def h1_var reduce_system.simps reduction_step.simps)
 qed
 
 (* gauss_jordan_single_rank is crucial in this section *)
 subsection "Showing invertibility preserved when reducing"
 
 (* Overall:
   Start with a matrix equation.
   Input a matrix, subsets, and signs.
   Drop columns of the matrix based on the 0's on the LHS---so extract a list of 0's. Reduce signs accordingly.
   Then find a list of rows to delete based on using rank (use the transpose result, pivot positions!),
    and delete those rows.  Reduce subsets accordingly.
   End with a reduced system! *)
 lemma well_def_find_zeros_from_lhs_vec:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   shows "(\<And>j. j \<in> set (find_nonzeros_from_input_vec
                     (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<Longrightarrow>
           j < length (cols (matrix_A signs subsets)))"
 proof - 
   fix i
   fix j
   assume j_in: " j \<in> set (find_nonzeros_from_input_vec
                       (solve_for_lhs p qs subsets (matrix_A signs subsets))) "
   let ?og_mat = "(matrix_A signs subsets)"
   let ?lhs = "(solve_for_lhs p qs subsets ?og_mat)"
   let ?new_mat = "(take_rows_from_matrix (reduce_mat_cols ?og_mat ?lhs) (rows_to_keep (reduce_mat_cols ?og_mat ?lhs)))"
   have "square_mat (matrix_A signs subsets)" using inv
     using invertible_mat_def by blast
   then have mat_size: "?og_mat \<in> carrier_mat (length signs) (length signs)" 
     using size_of_mat
     by auto 
   have "dim_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)) = (length signs)"
     using size_of_lhs construct_lhs_matches_solve_for_lhs assms
     by (metis (full_types))
   then have h: "j < (length signs)"
     using j_in unfolding find_nonzeros_from_input_vec_def
     by simp 
   then show "j <  length (cols (matrix_A signs subsets))" 
     using mat_size by auto
 qed
 
 lemma take_cols_subsets_og_cols:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   shows "set (take_indices (cols (matrix_A signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))
     \<subseteq> set (cols (matrix_A signs subsets))"
 proof -
   have well_def: "(\<And>j. j \<in> set (find_nonzeros_from_input_vec
                     (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<Longrightarrow>
           j < length (cols (matrix_A signs subsets)))"
     using assms well_def_find_zeros_from_lhs_vec by auto
   have "\<forall>x. x \<in> set (take_indices (cols (matrix_A signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) 
     \<longrightarrow> x \<in>  set (cols (matrix_A signs subsets))" 
   proof clarsimp 
     fix x
     let ?og_list = "(cols (matrix_A signs subsets))"
     let ?ind_list = "(find_nonzeros_from_input_vec
                      (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
     assume x_in: "x \<in> set (take_indices ?og_list ?ind_list)"
     show "x \<in> set (cols (matrix_A signs subsets))" 
       using x_in unfolding take_indices_def using in_set_member apply (auto)
       using in_set_conv_nth well_def by fastforce
   qed
   then show ?thesis
     by blast 
 qed
 
 lemma reduction_doesnt_break_things_invertibility_step1:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   shows "vec_space.rank (length signs) (reduce_mat_cols (matrix_A signs subsets) (solve_for_lhs p qs subsets (matrix_A signs subsets))) =
     (length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"
 proof - 
   let ?og_mat = "(matrix_A signs subsets)"
   let ?lhs = "(solve_for_lhs p qs subsets ?og_mat)"
   let ?new_mat = "(take_rows_from_matrix (reduce_mat_cols ?og_mat ?lhs) (rows_to_keep (reduce_mat_cols ?og_mat ?lhs)))"
   have "square_mat (matrix_A signs subsets)" using inv
     using invertible_mat_def by blast
   then have mat_size: "?og_mat \<in> carrier_mat (length signs) (length signs)" 
     using size_of_mat
     by auto 
   then have mat_size_alt: "?og_mat \<in> carrier_mat (length subsets) (length subsets)" 
     using size_of_mat same_size assms 
     by auto 
   have det_h: "det ?og_mat \<noteq> 0"
     using invertible_det[where A = "matrix_A signs subsets"] mat_size
     using inv by blast
   then have rank_h: "vec_space.rank (length signs) ?og_mat = (length signs)" 
     using vec_space.det_rank_iff  mat_size
     by auto
   then have dist_cols: "distinct (cols ?og_mat)" using mat_size vec_space.non_distinct_low_rank[where A = ?og_mat, where n = "length signs"]
     by auto
   have well_def: "(\<And>j. j \<in> set (find_nonzeros_from_input_vec
                     (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<Longrightarrow>
           j < length (cols (matrix_A signs subsets)))"
     using assms well_def_find_zeros_from_lhs_vec by auto
   have dist1: "distinct
      (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
     unfolding find_nonzeros_from_input_vec_def by auto
   have clear: "set (take_indices (cols (matrix_A signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))
     \<subseteq> set (cols (matrix_A signs subsets))"
     using assms take_cols_subsets_og_cols by auto
   then have "distinct (take_indices (cols (matrix_A signs subsets))
           (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"
     unfolding take_indices_def
     using dist1 dist_cols well_def conjugatable_vec_space.distinct_map_nth[where ls = "cols (matrix_A signs subsets)", where inds = "(find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"]
     by auto
   then have unfold_thesis: "vec_space.rank (length signs) (mat_of_cols (dim_row ?og_mat) (take_indices (cols ?og_mat) (find_nonzeros_from_input_vec ?lhs)))
 = (length (find_nonzeros_from_input_vec ?lhs))" 
     using clear inv conjugatable_vec_space.rank_invertible_subset_cols[where A= "matrix_A signs subsets", where B = "(take_indices (cols (matrix_A signs subsets))
          (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"]
     by (simp add: len_eq mat_size take_indices_def)
   then show ?thesis apply (simp) unfolding take_cols_from_matrix_def by auto
 qed
 
 lemma rechar_take_cols: "take_cols_var A B = take_cols_from_matrix A B"
   unfolding take_cols_var_def take_cols_from_matrix_def take_indices_def by auto
 
 lemma rows_and_cols_transpose: "rows M = cols M\<^sup>T"
   using row_transpose  by simp 
 
 lemma take_rows_and_take_cols:  "(take_rows_from_matrix M r) = (take_cols_from_matrix M\<^sup>T r)\<^sup>T"
   unfolding take_rows_from_matrix_def take_cols_from_matrix_def
   using transpose_carrier_mat rows_and_cols_transpose apply (auto)
   by (simp add: transpose_mat_of_cols) 
 
 lemma reduction_doesnt_break_things_invertibility:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes len_eq: "length subsets = length signs"
   assumes inv: "invertible_mat (matrix_A signs subsets)"
   assumes nonzero: "p \<noteq> 0"
   assumes welldefined_signs1: "well_def_signs (length qs) signs"
   assumes distinct_signs: "distinct signs"
   assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
   assumes match: "satisfy_equation p qs subsets signs"
   shows "invertible_mat (get_matrix (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))"
 proof - 
   let ?og_mat = "(matrix_A signs subsets)"
   let ?lhs = "(solve_for_lhs p qs subsets ?og_mat)"
   let ?step1_mat = "(reduce_mat_cols ?og_mat ?lhs)"
   let ?new_mat = "take_rows_from_matrix ?step1_mat (rows_to_keep ?step1_mat)"
   let ?ind_list = "(find_nonzeros_from_input_vec  ?lhs)"
   have "square_mat (matrix_A signs subsets)" using inv
     using invertible_mat_def by blast
   then have og_mat_size: "?og_mat \<in> carrier_mat (length signs) (length signs)" 
     using size_of_mat
     by auto 
   have "dim_col (mat_of_cols (dim_row ?og_mat) (take_indices (cols ?og_mat) ?ind_list))
       = (length (find_nonzeros_from_input_vec ?lhs))"
     by (simp add: take_indices_def) 
   then have "mat_of_cols (dim_row ?og_mat) (take_indices (cols ?og_mat) ?ind_list)
       \<in> carrier_mat (length signs) (length (find_nonzeros_from_input_vec ?lhs))"
     by (simp add: len_eq mat_of_cols_def)
   then have step1_mat_size: "?step1_mat \<in> carrier_mat (length signs) (length (find_nonzeros_from_input_vec ?lhs))"
     by (simp add: take_cols_from_matrix_def)
   then have "dim_row ?step1_mat \<ge> dim_col ?step1_mat"
     by (metis carrier_matD(1) carrier_matD(2) construct_lhs_matches_solve_for_lhs diff_zero find_nonzeros_from_input_vec_def inv length_filter_le length_upt match size_of_lhs)
   then have gt_eq_assm: "dim_col ?step1_mat\<^sup>T  \<ge> dim_row  ?step1_mat\<^sup>T"
     by simp 
   have det_h: "det ?og_mat \<noteq> 0"
     using invertible_det[where A = "matrix_A signs subsets"] og_mat_size
     using inv by blast
   then have rank_h: "vec_space.rank (length signs) ?og_mat = (length signs)" 
     using vec_space.det_rank_iff  og_mat_size
     by auto
   have rank_drop_cols: "vec_space.rank (length signs) ?step1_mat = (dim_col ?step1_mat)"
     using assms reduction_doesnt_break_things_invertibility_step1 step1_mat_size 
     by auto
   let ?step1_T = "?step1_mat\<^sup>T"
   have rank_transpose: "vec_space.rank (length signs) ?step1_mat = vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) ?step1_T"
     using transpose_rank[of ?step1_mat]
     using step1_mat_size by auto  
   have obv: "?step1_T \<in> carrier_mat (dim_row ?step1_T) (dim_col ?step1_T)" by auto
   have should_have_this:"vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) (take_cols ?step1_T (map snd (pivot_positions (gauss_jordan_single (?step1_T))))) = vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) ?step1_T"
     using obv gt_eq_assm conjugatable_vec_space.gauss_jordan_single_rank[where A = "?step1_T", where n = "dim_row ?step1_T", where nc = "dim_col ?step1_T"]
     by (simp add: take_cols_from_matrix_def take_indices_def)
   then have "vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) (take_cols ?step1_T (map snd (pivot_positions (gauss_jordan_single (?step1_T))))) = dim_col ?step1_mat"
     using rank_drop_cols rank_transpose by auto
   then have with_take_cols_from_matrix: "vec_space.rank (length (find_nonzeros_from_input_vec ?lhs)) (take_cols_from_matrix ?step1_T (map snd (pivot_positions (gauss_jordan_single (?step1_T))))) = dim_col ?step1_mat"
     using rank_transpose rechar_take_cols conjugatable_vec_space.gjs_and_take_cols_var
     apply (auto)
     by (smt conjugatable_vec_space.gjs_and_take_cols_var gt_eq_assm obv rechar_take_cols reduce_mat_cols.simps)
   have "(take_rows_from_matrix ?step1_mat (rows_to_keep ?step1_mat)) = (take_cols_from_matrix ?step1_T  (rows_to_keep ?step1_mat))\<^sup>T"
     using take_rows_and_take_cols
     by blast 
   then have rank_new_mat: "vec_space.rank (dim_row ?new_mat) ?new_mat = dim_col ?step1_mat"
     using with_take_cols_from_matrix transpose_rank apply (auto)
   proof -
     assume a1: "vec_space.rank (length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) (take_cols_from_matrix (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))\<^sup>T (map snd (pivot_positions (gauss_jordan_single (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))\<^sup>T)))) = dim_col (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"
     have f2: "\<forall>m. vec_space.rank (dim_row (m::rat mat)) m = vec_space.rank (dim_row m\<^sup>T) m\<^sup>T"
       by (simp add: transpose_rank)
     have f3: "dim_row (mat_of_cols (dim_row (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (take_indices (cols (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (map snd (pivot_positions (gauss_jordan_single (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T))))) = length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
       using \<open>dim_col (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))) = length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> by force
     have "vec_space.rank (length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) (mat_of_cols (dim_row (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (take_indices (cols (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (map snd (pivot_positions (gauss_jordan_single (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T))))) = dim_row (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T"
       using a1 by (simp add: take_cols_from_matrix_def)
     then have "vec_space.rank (dim_row (mat_of_cols (dim_row (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (take_indices (cols (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (map snd (pivot_positions (gauss_jordan_single (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T)))))\<^sup>T) (mat_of_cols (dim_row (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (take_indices (cols (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T) (map snd (pivot_positions (gauss_jordan_single (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T)))))\<^sup>T = dim_row (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))\<^sup>T"
       using f3 f2 by presburger
     then show "vec_space.rank (dim_col (take_cols_from_matrix (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))\<^sup>T (rows_to_keep (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))))) (take_cols_from_matrix (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))\<^sup>T (rows_to_keep (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))))\<^sup>T = dim_col (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))"
       by (simp add: rows_to_keep_def take_cols_from_matrix_def)
   qed 
   have "length (pivot_positions (gauss_jordan_single (?step1_mat\<^sup>T))) \<le> (length (find_nonzeros_from_input_vec ?lhs))"
     using obv length_pivot_positions_dim_row[where A = "(gauss_jordan_single (?step1_mat\<^sup>T))"]
     by (metis carrier_matD(1) carrier_matD(2) gauss_jordan_single(2) gauss_jordan_single(3) index_transpose_mat(2) step1_mat_size) 
   then have len_lt_eq: "length (pivot_positions (gauss_jordan_single (?step1_mat\<^sup>T))) \<le> dim_col ?step1_mat"
     using step1_mat_size
     by simp 
   have len_gt_false: "length (rows_to_keep ?step1_mat) < (dim_col ?step1_mat) \<Longrightarrow> False"
   proof - 
     assume length_lt: "length (rows_to_keep ?step1_mat) < (dim_col ?step1_mat)"
     have h: "dim_row ?new_mat < (dim_col ?step1_mat)"
       by (metis Matrix.transpose_transpose index_transpose_mat(3) length_lt length_map mat_of_cols_carrier(3) take_cols_from_matrix_def take_indices_def take_rows_and_take_cols)
     then show "False" using rank_new_mat
       by (metis Matrix.transpose_transpose carrier_matI index_transpose_mat(2) nat_less_le not_less_iff_gr_or_eq transpose_rank vec_space.rank_le_nc)    
   qed
   then have len_gt_eq: "length (rows_to_keep ?step1_mat) \<ge> (dim_col ?step1_mat)"
     using not_less by blast
   have len_match: "length (rows_to_keep ?step1_mat) = (dim_col ?step1_mat)"
     using len_lt_eq len_gt_eq
     by (simp add: rows_to_keep_def) 
   have mat_match: "matrix_A (get_signs (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))
   (get_subsets (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs))))) = 
   (get_matrix (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))"
     using reduce_system_matrix_match[of p qs signs subsets]  assms
     by blast 
   have f2: "length (get_subsets (take_rows_from_matrix (mat_of_cols (dim_row (matrix_A signs subsets)) (map ((!) (cols (matrix_A signs subsets))) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))) (rows_to_keep (mat_of_cols (dim_row (matrix_A signs subsets)) (map ((!) (cols (matrix_A signs subsets))) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))), map ((!) subsets) (rows_to_keep (mat_of_cols (dim_row (matrix_A signs subsets)) (map ((!) (cols (matrix_A signs subsets))) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))), map ((!) signs) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))) = length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
     by (metis (no_types) \<open>dim_col (mat_of_cols (dim_row (matrix_A signs subsets)) (take_indices (cols (matrix_A signs subsets)) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))) = length (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> \<open>length (rows_to_keep (reduce_mat_cols (matrix_A signs subsets) (solve_for_lhs p qs subsets (matrix_A signs subsets)))) = dim_col (reduce_mat_cols (matrix_A signs subsets) (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> length_map reduce_mat_cols.simps reduce_system.simps reduction_step.simps reduction_subsets_def reduction_subsets_is_get_subsets take_cols_from_matrix_def take_indices_def)
   have f3: "\<forall>p ps rss nss m. map ((!) rss) (find_nonzeros_from_input_vec (solve_for_lhs p ps nss m)) = get_signs (reduce_system p (ps, m, nss, rss))"
     by (metis (no_types) reduction_signs_def reduction_signs_is_get_signs take_indices_def)
   have square_final_mat: "square_mat (get_matrix (reduce_system p (qs, ((matrix_A signs subsets), (subsets, signs)))))"
     using mat_match assms size_of_mat same_size   
     apply (auto) using f2 f3
     by (metis (no_types, lifting) Matrix.transpose_transpose fst_conv get_matrix_def index_transpose_mat(2) len_match length_map mat_of_cols_carrier(2) mat_of_cols_carrier(3) reduce_mat_cols.simps take_cols_from_matrix_def take_indices_def take_rows_and_take_cols) 
   have rank_match: "vec_space.rank (dim_row ?new_mat) ?new_mat = dim_row ?new_mat"
     using len_match rank_new_mat
     by (simp add: take_cols_from_matrix_def take_indices_def take_rows_and_take_cols) 
   have "invertible_mat ?new_mat"
     using invertible_det og_mat_size
     using vec_space.det_rank_iff square_final_mat
     by (metis dim_col_matrix_A dim_row_matrix_A fst_conv get_matrix_def mat_match rank_match reduce_system.simps reduction_step.simps size_of_mat square_mat.elims(2))
   then show ?thesis apply (simp)
     by (metis fst_conv get_matrix_def)
 qed
 
 subsection "Well def signs preserved when reducing"
 
 lemma reduction_doesnt_break_length_signs:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes length_init : "\<forall> x\<in> set(signs). length x = length qs"
   assumes sat_eq: "satisfy_equation p qs subsets signs"
   assumes inv_mat: "invertible_mat (matrix_A signs subsets)"
   shows "\<forall>x \<in> set(reduction_signs p qs signs subsets (matrix_A signs subsets)). 
     length x = length qs"
 proof clarsimp 
   fix x
   assume x_in_set: "x \<in> set (reduction_signs p qs signs subsets (matrix_A signs subsets))"
   have "List.member (reduction_signs p qs signs subsets (matrix_A signs subsets)) x"
     using x_in_set by (simp add: in_set_member)
   then have take_ind: "List.member (take_indices signs
      (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) x"
     unfolding reduction_signs_def by auto
   have find_nz_len: "\<forall>y. List.member (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) y \<longrightarrow>  y < length signs"
     using size_of_lhs sat_eq inv_mat construct_lhs_matches_solve_for_lhs[of p qs subsets signs] unfolding find_nonzeros_from_input_vec_def
     by (metis atLeastLessThan_iff filter_is_subset in_set_member set_upt subset_code(1)) 
   then have "\<exists> n < length signs. x = signs ! n"
     using take_ind
     by (metis in_set_conv_nth reduction_signs_def take_indices_lem x_in_set) 
   then show "length x = length qs" using length_init take_indices_lem
     using nth_mem by blast
 qed
 
 subsection "Distinct signs preserved when reducing"
 
 lemma reduction_signs_are_distinct:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes sat_eq: "satisfy_equation p qs subsets signs"
   assumes inv_mat: "invertible_mat (matrix_A signs subsets)"
   assumes distinct_init: "distinct signs"
   shows "distinct (reduction_signs p qs signs subsets (matrix_A signs subsets))"
 proof -
   have solve_construct: "construct_lhs_vector p qs signs =
   solve_for_lhs p qs subsets (matrix_A signs subsets)"
     using construct_lhs_matches_solve_for_lhs assms
     by simp
   have h1: "distinct (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
     unfolding find_nonzeros_from_input_vec_def 
     using distinct_filter
     using distinct_upt by blast 
   have h2: "(\<And>j. j \<in> set (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<Longrightarrow>
           j < length signs)"
   proof - 
     fix j
     assume "j \<in> set (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
     show "j < length signs" using solve_construct size_of_lhs
       by (metis \<open>j \<in> set (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))\<close> atLeastLessThan_iff filter_is_subset find_nonzeros_from_input_vec_def set_upt subset_iff)
   qed
   then show ?thesis unfolding reduction_signs_def unfolding take_indices_def
     using distinct_init h1 h2 conjugatable_vec_space.distinct_map_nth[where ls = "signs", where inds = "(find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"]
     by blast
 qed
 
 subsection "Well def subsets preserved when reducing"
 
 lemma reduction_doesnt_break_subsets:  
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes length_init : "all_list_constr subsets (length qs)"
   assumes sat_eq: "satisfy_equation p qs subsets signs"
   assumes inv_mat: "invertible_mat (matrix_A signs subsets)"
   shows "all_list_constr (reduction_subsets p qs signs subsets (matrix_A signs subsets)) (length qs)"
   unfolding all_list_constr_def 
 proof clarsimp
   fix x
   assume in_red_subsets: "List.member (reduction_subsets p qs signs subsets (matrix_A signs subsets)) x "
   have solve_construct: "construct_lhs_vector p qs signs =
   solve_for_lhs p qs subsets (matrix_A signs subsets)"
     using construct_lhs_matches_solve_for_lhs assms
     by simp
   have rows_to_keep_hyp: "\<forall>y. y \<in> set (rows_to_keep (reduce_mat_cols (matrix_A signs subsets) (solve_for_lhs p qs subsets (matrix_A signs subsets)))) \<longrightarrow> 
       y < length subsets" 
   proof clarsimp 
     fix y
     assume in_set: "y \<in> set (rows_to_keep
                    (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))))"
     have in_set_2: "y \<in> set (rows_to_keep
                    (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (construct_lhs_vector p qs signs))))"
       using in_set solve_construct by simp
     let ?lhs_vec = "(solve_for_lhs p qs subsets (matrix_A signs subsets))"
     have h30: "(construct_lhs_vector p qs signs) = ?lhs_vec"
       using assms construct_lhs_matches_solve_for_lhs
       by simp 
     have h3a: "\<forall>x. List.member (find_nonzeros_from_input_vec ?lhs_vec) x \<longrightarrow>x < length (signs)" 
       using h30 size_of_lhs unfolding find_nonzeros_from_input_vec_def apply (auto)
       by (metis atLeastLessThan_iff filter_is_subset member_def set_upt subset_eq) 
     have h3c: "\<forall>x. List.member (rows_to_keep (reduce_mat_cols (matrix_A signs subsets) (solve_for_lhs p qs subsets (matrix_A signs subsets)))) x \<longrightarrow> x < length (subsets)"
     proof clarsimp
       fix x
       assume x_mem: "List.member (rows_to_keep
             (take_cols_from_matrix (matrix_A signs subsets)
               (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))) x"
       obtain nn :: "rat list list \<Rightarrow> nat list \<Rightarrow> nat" where
         "\<forall>x2 x3. (\<exists>v4. v4 \<in> set x3 \<and> \<not> v4 < length x2) = (nn x2 x3 \<in> set x3 \<and> \<not> nn x2 x3 < length x2)"
         by moura
       then have f4: "nn signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<in> set (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<and> \<not> nn signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) < length signs \<or> matrix_A (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) subsets = take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))"
         using h3a nonzero reduce_system_matrix_signs_helper by auto
       then have "matrix_A (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets)))) subsets = take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))) \<and> x \<in> set (map snd (pivot_positions (gauss_jordan_single (take_cols_from_matrix (matrix_A signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (matrix_A signs subsets))))\<^sup>T)))"
         by (metis h3a in_set_member rows_to_keep_def x_mem)
       thus "x < length (subsets)" using x_mem unfolding rows_to_keep_def using pivot_positions
         using  dim_row_matrix_A h3a in_set_member nonzero reduce_system_matrix_signs_helper rows_to_keep_def rows_to_keep_lem
         apply (auto)
         by (smt (z3) \<open>M_mat (take_indices signs (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (M_mat signs subsets)))) subsets = take_cols_from_matrix (M_mat signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (M_mat signs subsets))) \<and> x \<in> set (map snd (pivot_positions (gauss_jordan_single (take_cols_from_matrix (M_mat signs subsets) (find_nonzeros_from_input_vec (solve_for_lhs p qs subsets (M_mat signs subsets))))\<^sup>T)))\<close> dim_row_matrix_A rows_to_keep_def rows_to_keep_lem)
     qed
     then show "y < length subsets" using in_set_member apply (auto)
       using in_set_2 solve_construct by fastforce  
   qed
   show "list_constr x (length qs)" using in_red_subsets  unfolding  reduction_subsets_def 
     using take_indices_lem[of _ subsets]  rows_to_keep_hyp
     by (metis all_list_constr_def in_set_conv_nth in_set_member length_init) 
 qed
 
 section "Overall Lemmas"
 
 lemma combining_to_smash:  "combine_systems p (qs1, m1, (sub1, sgn1)) (qs2, m2, (sub2, sgn2))
  =  smash_systems p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2"
   by simp
 
 lemma getter_functions: "calculate_data p qs = (get_matrix (calculate_data p qs), (get_subsets (calculate_data p qs), get_signs (calculate_data p qs))) "
   unfolding get_matrix_def get_subsets_def get_signs_def by auto
 
 subsection "Key properties preserved"
 
 subsubsection "Properties preserved when combining and reducing systems"
 lemma combining_sys_satisfies_properties_helper:
   fixes p:: "real poly"
   fixes qs1 :: "real poly list"
   fixes qs2 :: "real poly list"
   fixes subsets1 subsets2 :: "nat list list"
   fixes signs1 signs2 :: "rat list list" 
   fixes matrix1 matrix2:: "rat mat"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes pairwise_rel_prime1: "\<forall>q. ((List.member qs1 q) \<longrightarrow> (coprime p q))"
   assumes nontriv2: "length qs2 > 0"
   assumes pairwise_rel_prime2: "\<forall>q. ((List.member qs2 q) \<longrightarrow> (coprime p q))"
   assumes satisfies_properties_sys1: "satisfies_properties p qs1 subsets1 signs1 matrix1"
   assumes satisfies_properties_sys2: "satisfies_properties p qs2 subsets2 signs2 matrix2"
   shows  "satisfies_properties p (qs1@qs2) (get_subsets (snd ((combine_systems p (qs1,(matrix1, (subsets1, signs1))) (qs2,(matrix2, (subsets2, signs2))))))) 
   (get_signs (snd ((combine_systems p (qs1,(matrix1, (subsets1, signs1))) (qs2,(matrix2, (subsets2, signs2))))))) 
   (get_matrix (snd ((combine_systems p (qs1,(matrix1, (subsets1, signs1))) (qs2,(matrix2, (subsets2, signs2)))))))"
 proof -     
   let ?subsets = "(get_subsets (snd (combine_systems p (qs1, matrix1, subsets1, signs1)
               (qs2, matrix2, subsets2, signs2))))"
   let ?signs = "(get_signs (snd (combine_systems p (qs1, matrix1, subsets1, signs1) (qs2, matrix2, subsets2, signs2))))"
   let ?matrix = "(get_matrix (snd (combine_systems p (qs1, matrix1, subsets1, signs1) (qs2, matrix2, subsets2, signs2))))"
   have h1: "all_list_constr ?subsets (length (qs1 @ qs2))"
     using well_def_step[of subsets1 qs1 subsets2 qs2] assms
     by (simp add: nontriv2 get_subsets_def satisfies_properties_def smash_systems_def) 
   have h2: "well_def_signs (length (qs1 @ qs2)) ?signs"
     using well_def_signs_step[of qs1 qs2 signs1 signs2]
     using get_signs_def nontriv1 nontriv2 satisfies_properties_def satisfies_properties_sys1 satisfies_properties_sys2 smash_systems_def by auto 
   have h3: "distinct ?signs" 
     using distinct_step[of _ signs1 _ signs2] assms
     using combine_systems.simps get_signs_def satisfies_properties_def smash_systems_def snd_conv by auto
   have h4: "satisfy_equation p (qs1 @ qs2) ?subsets ?signs" 
     using assms inductive_step[of p qs1 qs2 signs1 signs2 subsets1 subsets2]
     using get_signs_def get_subsets_def satisfies_properties_def smash_systems_def
     by auto  
   have h5: " invertible_mat ?matrix"
     using assms inductive_step[of p qs1 qs2 signs1 signs2 subsets1 subsets2]
     by (metis combining_to_smash fst_conv get_matrix_def kronecker_invertible satisfies_properties_def smash_systems_def snd_conv)
   have h6: "?matrix = matrix_A ?signs ?subsets" 
     unfolding get_matrix_def combine_systems.simps smash_systems_def get_signs_def get_subsets_def
     apply simp
     apply (subst matrix_construction_is_kronecker_product[of subsets1 _ signs1 signs2 subsets2])
     apply (metis Ball_set all_list_constr_def in_set_member list_constr_def satisfies_properties_def satisfies_properties_sys1)
     using satisfies_properties_def satisfies_properties_sys1 well_def_signs_def apply blast
     using satisfies_properties_def satisfies_properties_sys1 satisfies_properties_sys2 by auto
   have h7: "set (characterize_consistent_signs_at_roots_copr p (qs1 @ qs2))
     \<subseteq> set (?signs)"
     using subset_step[of p qs1 signs1 qs2  signs2] assms
     by (simp add: nonzero get_signs_def satisfies_properties_def smash_systems_def) 
   then show ?thesis unfolding satisfies_properties_def using h1 h2 h3 h4 h5 h6 h7 by blast
 qed
 
 lemma combining_sys_satisfies_properties:
   fixes p:: "real poly"
   fixes qs1 :: "real poly list"
   fixes qs2 :: "real poly list"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes pairwise_rel_prime1: "\<forall>q. ((List.member qs1 q) \<longrightarrow> (coprime p q))"
   assumes nontriv2: "length qs2 > 0"
   assumes pairwise_rel_prime2: "\<forall>q. ((List.member qs2 q) \<longrightarrow> (coprime p q))"
   assumes satisfies_properties_sys1: "satisfies_properties p qs1 (get_subsets (calculate_data p qs1)) (get_signs (calculate_data p qs1)) (get_matrix (calculate_data p qs1))"
   assumes satisfies_properties_sys2: "satisfies_properties p qs2 (get_subsets (calculate_data p qs2)) (get_signs (calculate_data p qs2)) (get_matrix (calculate_data p qs2))"
   shows  "satisfies_properties p (qs1@qs2) (get_subsets (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2))))) 
   (get_signs (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2))))) 
   (get_matrix (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2)))))"
   using combining_sys_satisfies_properties_helper
   by (metis getter_functions nontriv1 nontriv2 nonzero pairwise_rel_prime1 pairwise_rel_prime2 nonzero satisfies_properties_sys1 satisfies_properties_sys2) 
 
 lemma reducing_sys_satisfies_properties:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   fixes matrix:: "rat mat"
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv: "length qs > 0"
   assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   assumes satisfies_properties_sys: "satisfies_properties p qs subsets signs matrix"
   shows  "satisfies_properties p qs (get_subsets (reduce_system p (qs,matrix,subsets,signs)))
   (get_signs (reduce_system p (qs,matrix,subsets,signs)))
   (get_matrix (reduce_system p (qs,matrix,subsets,signs)))"
 proof -
   have h1: " all_list_constr (get_subsets (reduce_system p (qs, matrix, subsets, signs))) (length qs)"
     using reduction_doesnt_break_subsets assms reduction_subsets_is_get_subsets satisfies_properties_def satisfies_properties_sys by auto
   have h2: "well_def_signs (length qs) (get_signs (reduce_system p (qs, matrix, subsets, signs)))"
     using reduction_doesnt_break_length_signs[of signs qs p subsets] assms reduction_signs_is_get_signs satisfies_properties_def well_def_signs_def by auto
   have h3: "distinct (get_signs (reduce_system p (qs, matrix, subsets, signs)))"
     using reduction_signs_are_distinct[of p qs subsets signs] assms reduction_signs_is_get_signs satisfies_properties_def by auto 
   have h4: "satisfy_equation p qs (get_subsets (reduce_system p (qs, matrix, subsets, signs)))
      (get_signs (reduce_system p (qs, matrix, subsets, signs)))"
     using reduce_system_matrix_equation_preserved[of p qs signs subsets] assms satisfies_properties_def by auto
   have h5: "invertible_mat (get_matrix (reduce_system p (qs, matrix, subsets, signs)))"
     using reduction_doesnt_break_things_invertibility assms same_size satisfies_properties_def by auto 
   have h6: "get_matrix (reduce_system p (qs, matrix, subsets, signs)) =
     matrix_A (get_signs (reduce_system p (qs, matrix, subsets, signs)))
      (get_subsets (reduce_system p (qs, matrix, subsets, signs)))"
     using reduce_system_matrix_match[of p qs signs subsets] assms satisfies_properties_def by auto
   have h7: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set (get_signs (reduce_system p (qs, matrix, subsets, signs)))"
     using reduction_doesnt_break_things_signs[of p qs signs subsets] assms reduction_signs_is_get_signs satisfies_properties_def by auto
   then show ?thesis unfolding satisfies_properties_def using h1 h2 h3 h4 h5 h6 h7
     by blast
 qed
 
 subsubsection "For length 1 qs"
 
 lemma  length_1_calculate_data_satisfies_properties:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes len1: "length qs = 1"
   assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   shows "satisfies_properties p qs (get_subsets (calculate_data p qs)) (get_signs (calculate_data p qs)) (get_matrix (calculate_data p qs))"
 proof - 
   have h1: "all_list_constr [[],[0]] (length qs)"
     using len1 unfolding all_list_constr_def list_constr_def apply (auto)
     by (metis (full_types) length_Cons less_Suc0 list.size(3) list_all_length list_all_simps(2) member_rec(1) member_rec(2) nth_Cons_0) 
   have h2: "well_def_signs (length qs) [[1],[-1]]"
     unfolding well_def_signs_def using len1 in_set_member 
     by auto
   have h3: "distinct ([[1],[-1]]::rat list list)" 
     unfolding distinct_def using in_set_member by auto
   have h4: "satisfy_equation p qs [[],[0]] [[1],[-1]]"
     using assms base_case_satisfy_equation_alt[of qs p] by auto
   have h6: "(mat_of_rows_list 2 [[1,1], [1,-1]]::rat mat) = (matrix_A ([[1],[-1]]) ([[],[0]]) :: rat mat)" 
     using mat_base_case by auto
   then have h5: "invertible_mat (mat_of_rows_list 2 [[1,1], [1,-1]]:: rat mat)" 
     using base_case_invertible_mat
     by simp
   have h7:  "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set ([[1],[-1]])"
     using assms base_case_sgas_alt[of qs p]
     by simp  
   have base_case_hyp: "satisfies_properties p qs [[],[0]] [[1],[-1]] (mat_of_rows_list 2 [[1,1], [1,-1]])"
     using h1 h2 h3 h4 h5 h6 h7
     using satisfies_properties_def by blast 
   then have key_hyp: "satisfies_properties p qs (get_subsets (reduce_system p (qs,base_case_info))) (get_signs (reduce_system p (qs,base_case_info))) (get_matrix (reduce_system p (qs,base_case_info)))"
     using reducing_sys_satisfies_properties
     by (metis base_case_info_def len1 nonzero pairwise_rel_prime nonzero zero_less_one_class.zero_less_one) 
   show ?thesis
     by (simp add: key_hyp len1) 
 qed
 
 subsubsection "For arbitrary qs"
 lemma append_not_distinct_helper: "(List.member l1 m \<and> List.member l2 m) \<longrightarrow> (distinct (l1@l2) = False)"
 proof - 
   have h1: "List.member l1 m \<longrightarrow> (\<exists> n. n < length l1 \<and> (nth l1 n) = m)"
     using member_def nth_find_first
     by (simp add: member_def in_set_conv_nth) 
   have h2: "\<forall>n. n < length l1 \<and> (nth l1 n) = m \<longrightarrow> (nth (l1@l2) n) = m"
   proof clarsimp 
     fix n
     assume lt: "n < length l1"
     assume nth_l1: "m = l1 ! n"
     show "(l1 @ l2) ! n = l1 ! n" 
     proof (induct l2)
       case Nil
       then show ?case
         by simp 
     next
       case (Cons a l2)
       then show ?case
         by (simp add: lt nth_append)
     qed
   qed
   have h3: "List.member l1 m \<longrightarrow> (\<exists>n.  n < length l1 \<and> (nth (l1@l2) n) = m)" 
     using h1 h2 by auto
   have h4: "List.member l2 m \<longrightarrow> (\<exists> n. (nth l2 n) = m)"
     by (meson member_def nth_find_first) 
   have h5: "\<forall>n. (nth l2 n) = m \<longrightarrow> (nth (l1@l2) (n + length l1)) = m"
   proof clarsimp 
     fix n
     assume nth_l2: "m = l2 ! n"
     show "(l1 @ l2) ! (n + length l1) = l2 ! n" 
     proof (induct l2)
       case Nil
       then show ?case
         by (metis add.commute nth_append_length_plus) 
     next
       case (Cons a l2)
       then show ?case
         by (simp add: nth_append) 
     qed
   qed
   have h6: "List.member l2 m \<longrightarrow> (\<exists>n. (nth (l1@l2) (n + length l1)) = m)" 
     using h4 h5
     by blast 
   show ?thesis using h3 h6
     by (metis distinct_append equalityI insert_disjoint(1) insert_subset member_def order_refl) 
 qed
 
 lemma  calculate_data_satisfies_properties:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   shows "(p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) )
     \<longrightarrow> satisfies_properties p qs (get_subsets (calculate_data p qs)) (get_signs (calculate_data p qs)) (get_matrix (calculate_data p qs))"
 proof (induction "length qs" arbitrary: qs rule: less_induct)
   case less
   have len1_h: "length qs = 1 \<longrightarrow> ( p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) ) \<longrightarrow> satisfies_properties p qs (get_subsets (calculate_data p qs)) (get_signs (calculate_data p qs)) (get_matrix (calculate_data p qs))"
     using  length_1_calculate_data_satisfies_properties
     by blast
   let ?len = "length qs"
   let ?q1 = "take (?len div 2) qs"
   let ?left = "calculate_data p ?q1"
   let ?q2 = "drop (?len div 2) qs"
   let ?right = "calculate_data p ?q2"
   let ?comb = "combine_systems p (?q1,?left) (?q2,?right)"
   let ?red =  "reduce_system p ?comb"
   have h_q1_len: "length qs > 1 \<longrightarrow> (length ?q1 > 0)" by auto 
   have h_q2_len: "length qs > 1 \<longrightarrow> (length ?q2 > 0)" by auto
   have h_q1_copr: "(\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) \<longrightarrow> (\<forall>q. ((List.member ?q1 q) \<longrightarrow> (coprime p q)))"
   proof -
     have mem_hyp: "(\<forall>q. ((List.member ?q1 q) \<longrightarrow> (List.member qs q)))"
       by (meson in_set_member in_set_takeD)
     then show ?thesis
       by blast 
   qed
   have h_q2_copr: "(\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) \<longrightarrow> (\<forall>q. ((List.member ?q2 q) \<longrightarrow> (coprime p q)))"
   proof -
     have mem_hyp: "(\<forall>q. ((List.member ?q2 q) \<longrightarrow> (List.member qs q)))"
       by (meson in_set_dropD in_set_member)
     then show ?thesis
       by blast 
   qed
   have q1_sat_props: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) ) \<longrightarrow> satisfies_properties p ?q1 (get_subsets (calculate_data p ?q1)) (get_signs (calculate_data p ?q1)) (get_matrix (calculate_data p ?q1))"
     using less.hyps[of ?q1] h_q1_len h_q1_copr
     by (auto simp add: Let_def)
   have q2_help: "length qs > 1 \<longrightarrow> length (drop (length qs div 2) qs) < length qs"
     using h_q1_len by auto  
   then have q2_sat_props: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) ) \<longrightarrow> satisfies_properties p ?q2 (get_subsets (calculate_data p ?q2)) (get_signs (calculate_data p ?q2)) (get_matrix (calculate_data p ?q2))"
     using less.hyps[of ?q2] h_q2_len h_q2_copr
     by blast
   have put_tog: "?q1@?q2 = qs"
     using append_take_drop_id by blast 
   then have comb_sat_props: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) ) \<longrightarrow> (satisfies_properties p (qs) (get_subsets (snd ((combine_systems p (?q1,calculate_data p ?q1) (?q2,calculate_data p ?q2))))) 
   (get_signs (snd ((combine_systems p (?q1,calculate_data p ?q1) (?q2,calculate_data p ?q2))))) 
   (get_matrix (snd ((combine_systems p (?q1,calculate_data p ?q1) (?q2,calculate_data p ?q2))))))"
     using q1_sat_props q2_sat_props  combining_sys_satisfies_properties
     using h_q1_copr h_q1_len h_q2_copr h_q2_len  put_tog
     by metis
   then have comb_sat: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) ) \<longrightarrow> 
       (satisfies_properties p (qs) (get_subsets (snd ?comb)) (get_signs (snd ?comb)) (get_matrix (snd ?comb)))"
     by blast
   have red_char: "?red = (reduce_system p (qs,(get_matrix (snd ?comb)),(get_subsets (snd ?comb)),(get_signs (snd ?comb))))"
     using getter_functions
       by (smt Pair_inject combining_to_smash get_matrix_def get_signs_def get_subsets_def prod.collapse put_tog smash_systems_def)
   then have "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) )  \<longrightarrow> (satisfies_properties p qs (get_subsets ?red) (get_signs ?red) (get_matrix ?red))"
     using reducing_sys_satisfies_properties comb_sat  by presburger 
   have len_gt1: "length qs > 1 \<longrightarrow> (p \<noteq> 0 \<and> (length qs > 0) \<and> (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))) ) \<longrightarrow> satisfies_properties p qs (get_subsets (calculate_data p qs)) (get_signs (calculate_data p qs)) (get_matrix (calculate_data p qs))"
     by (smt \<open>1 < length qs \<longrightarrow>  p \<noteq> 0 \<and> 0 < length qs \<and> (\<forall>q. List.member qs q \<longrightarrow> coprime p q) \<longrightarrow> satisfies_properties p qs (get_subsets (reduce_system p (combine_systems p (take (length qs div 2) qs, calculate_data p (take (length qs div 2) qs)) (drop (length qs div 2) qs, calculate_data p (drop (length qs div 2) qs))))) (get_signs (reduce_system p (combine_systems p (take (length qs div 2) qs, calculate_data p (take (length qs div 2) qs)) (drop (length qs div 2) qs, calculate_data p (drop (length qs div 2) qs))))) (get_matrix (reduce_system p (combine_systems p (take (length qs div 2) qs, calculate_data p (take (length qs div 2) qs)) (drop (length qs div 2) qs, calculate_data p (drop (length qs div 2) qs)))))\<close> calculate_data.simps neq0_conv not_less)
   then show ?case using len1_h len_gt1
     by (metis One_nat_def Suc_lessI) 
 qed
 
 
 subsection "Some key results on consistent sign assignments"
 
 lemma find_consistent_signs_at_roots_len1:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes len1: "length qs = 1"
   assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
   shows "set (find_consistent_signs_at_roots p qs) = set (characterize_consistent_signs_at_roots_copr p qs)"
 proof - 
   let ?signs = "[[1],[-1]]::rat list list"
   let ?subsets = "[[],[0]]::nat list list"
   have mat_help: "matrix_A [[1],[-1]] [[],[0]] = (mat_of_rows_list 2 [[1,1], [1,-1]])"
     using mat_base_case by auto
   have well_def_signs: "well_def_signs (length qs) ?signs" unfolding well_def_signs_def 
     using len1 by auto
   have distinct_signs: "distinct ?signs"
     unfolding distinct_def by auto
   have ex_q: "\<exists>(q::real poly). qs = [q]" 
     using len1    
     using length_Suc_conv[of qs 0] by auto
   then have all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(?signs)"
     using assms base_case_sgas apply (auto)
     by (meson in_mono insertE insert_absorb insert_not_empty member_rec(1)) 
   have match: "satisfy_equation p qs ?subsets ?signs"
     using ex_q base_case_satisfy_equation nonzero pairwise_rel_prime
     apply (auto)
     by (simp add: member_rec(1)) 
   have invertible_mat: "invertible_mat (matrix_A ?signs ?subsets)"
     using inverse_mat_base_case inverse_mat_base_case_2 unfolding invertible_mat_def using mat_base_case 
     by auto
   have h: "set (get_signs (reduce_system p (qs, ((matrix_A ?signs ?subsets), (?subsets, ?signs))))) = 
     set (characterize_consistent_signs_at_roots_copr p qs)" 
     using nonzero nonzero well_def_signs distinct_signs all_info match invertible_mat
       reduce_system_sign_conditions[where p = "p", where qs = "qs", where signs = "[[1],[-1]]", where subsets = "[[],[0]]"]
     by blast 
   then have  "set (snd (snd (reduce_system p (qs, ((mat_of_rows_list 2 [[1,1], [1,-1]]), ([[],[0]], [[1],[-1]])))))) = 
     set (characterize_consistent_signs_at_roots_copr p qs)"
     unfolding get_signs_def using mat_help by auto
   then have "set (snd (snd (reduce_system p (qs, base_case_info)))) = set (characterize_consistent_signs_at_roots_copr p qs)"
     unfolding base_case_info_def
     by auto
   then show ?thesis using len1
     by (simp add: find_consistent_signs_at_roots_thm)
 qed
 
 
 lemma smaller_sys_are_good:
   fixes p:: "real poly"
   fixes qs1 :: "real poly list"
   fixes qs2 :: "real poly list"
   fixes subsets :: "nat list list"
   fixes signs :: "rat list list" 
   assumes nonzero: "p \<noteq> 0"
   assumes nontriv1: "length qs1 > 0"
   assumes pairwise_rel_prime1: "\<forall>q. ((List.member qs1 q) \<longrightarrow> (coprime p q))"
   assumes nontriv2: "length qs2 > 0"
   assumes pairwise_rel_prime2: "\<forall>q. ((List.member qs2 q) \<longrightarrow> (coprime p q))"
   assumes "set(find_consistent_signs_at_roots p qs1) = set(characterize_consistent_signs_at_roots_copr p qs1)"
   assumes "set(find_consistent_signs_at_roots p qs2) = set(characterize_consistent_signs_at_roots_copr p qs2)"
   shows "set(snd(snd(reduce_system p (combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2)))))
     = set(characterize_consistent_signs_at_roots_copr p (qs1@qs2))"
 proof - 
   let ?signs = "(get_signs (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2))))) "
   let ?subsets = "(get_subsets (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2))))) "
   have h0: "satisfies_properties p (qs1@qs2) ?subsets ?signs
     (get_matrix (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2)))))"
     using calculate_data_satisfies_properties combining_sys_satisfies_properties
     using nontriv1 nontriv2 nonzero pairwise_rel_prime1 pairwise_rel_prime2 nonzero
     by simp
   then have h1: "set(characterize_consistent_signs_at_roots_copr p (qs1@qs2)) \<subseteq> set ?signs"
     unfolding satisfies_properties_def
     by linarith 
   have h2: "well_def_signs (length (qs1@qs2)) ?signs"
     using calculate_data_satisfies_properties
     using h0 satisfies_properties_def by blast 
   have h3: "distinct ?signs" 
     using calculate_data_satisfies_properties
     using h0 satisfies_properties_def by blast 
   have h4: "satisfy_equation p (qs1@qs2) ?subsets ?signs"
     using calculate_data_satisfies_properties
     using h0 satisfies_properties_def by blast 
   have h5: "invertible_mat (matrix_A ?signs ?subsets) "
     using calculate_data_satisfies_properties  
     using h0 satisfies_properties_def
     by auto
   have h: "set (take_indices ?signs 
             (find_nonzeros_from_input_vec (solve_for_lhs p (qs1@qs2) ?subsets  (matrix_A ?signs ?subsets))))
         =  set(characterize_consistent_signs_at_roots_copr p (qs1@qs2))" 
     using h1 h2 h3 h4 h5 reduction_deletes_bad_sign_conds
     using nonzero nonzero reduction_signs_def by auto
   then have h: "set (characterize_consistent_signs_at_roots_copr p (qs1@qs2)) =
     set (reduction_signs p (qs1@qs2) ?signs ?subsets  (matrix_A ?signs ?subsets ))" 
     unfolding reduction_signs_def get_signs_def
     by blast  
   have help_h: "reduction_signs p (qs1@qs2) ?signs ?subsets  (matrix_A ?signs ?subsets) 
       = (take_indices ?signs (find_nonzeros_from_input_vec (solve_for_lhs p (qs1@qs2) ?subsets  (matrix_A ?signs ?subsets))))"
     unfolding reduction_signs_def by auto
   have clear_signs: "(signs_smash (get_signs (calculate_data p qs1)) (get_signs (calculate_data p qs2))) = (get_signs (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2)))))"
     by (smt combining_to_smash get_signs_def getter_functions smash_systems_def snd_conv)
   have clear_subsets: "(subsets_smash (length qs1) (get_subsets(calculate_data p qs1)) (get_subsets (calculate_data p qs2))) = (get_subsets (snd ((combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2)))))"
     by (smt Pair_inject combining_to_smash get_subsets_def prod.collapse smash_systems_def)
   have "well_def_signs (length qs1) (get_signs (calculate_data p qs1))" 
     using calculate_data_satisfies_properties
     using nontriv1 nonzero pairwise_rel_prime1 nonzero satisfies_properties_def
     by auto 
   then have well_def_signs1: "(\<And>j. j \<in> set (get_signs (calculate_data p qs1)) \<Longrightarrow> length j = (length qs1))"
     using well_def_signs_def by blast 
   have "all_list_constr (get_subsets(calculate_data p qs1))  (length qs1) "
     using calculate_data_satisfies_properties
     using nontriv1 nonzero pairwise_rel_prime1 nonzero satisfies_properties_def
     by auto 
   then have well_def_subsets1: "(\<And>l i. l \<in> set (get_subsets(calculate_data p qs1)) \<Longrightarrow> i \<in> set l \<Longrightarrow> i < (length qs1))"
     unfolding all_list_constr_def list_constr_def using in_set_member
     by (metis in_set_conv_nth list_all_length) 
   have extra_matrix_same: "matrix_A (signs_smash (get_signs (calculate_data p qs1)) (get_signs (calculate_data p qs2)))
          (subsets_smash (length qs1) (get_subsets(calculate_data p qs1)) (get_subsets (calculate_data p qs2))) 
         = kronecker_product (get_matrix (calculate_data p qs1)) (get_matrix (calculate_data p qs2))"
     using  well_def_signs1 well_def_subsets1
     using matrix_construction_is_kronecker_product
     using calculate_data_satisfies_properties nontriv1 nontriv2 nonzero pairwise_rel_prime1 pairwise_rel_prime2 nonzero satisfies_properties_def by auto 
   then have matrix_same: "matrix_A ?signs ?subsets = kronecker_product (get_matrix (calculate_data p qs1)) (get_matrix (calculate_data p qs2))"
     using clear_signs clear_subsets
     by simp
   have comb_sys_h: "snd(snd(reduce_system p (combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2)))) =
       snd(snd(reduce_system p (qs1@qs2, (matrix_A ?signs ?subsets, (?subsets, ?signs)))))"
     unfolding get_signs_def get_subsets_def using matrix_same
     by (smt combining_to_smash get_signs_def get_subsets_def getter_functions prod.collapse prod.inject smash_systems_def)   
   then have extra_h: " snd(snd(reduce_system p (qs1@qs2, (matrix_A ?signs ?subsets, (?subsets, ?signs))))) = 
       snd(snd(reduction_step (matrix_A ?signs ?subsets) ?signs ?subsets (solve_for_lhs p (qs1@qs2) ?subsets (matrix_A ?signs ?subsets)))) "
     by simp
   then have same_h: "set(snd(snd(reduce_system p (combine_systems p (qs1,calculate_data p qs1) (qs2,calculate_data p qs2))))) 
       = set (reduction_signs p (qs1@qs2) ?signs ?subsets  (matrix_A ?signs ?subsets ))"
     using comb_sys_h unfolding reduction_signs_def
     by (metis get_signs_def help_h reduction_signs_is_get_signs) 
   then show ?thesis using h
     by blast 
 qed
 
 lemma find_consistent_signs_at_roots_1:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   shows "(p \<noteq> 0 \<and> length qs > 0 \<and>
     (\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q)))) \<longrightarrow> 
     set(find_consistent_signs_at_roots p qs) = set(characterize_consistent_signs_at_roots_copr p qs)"
 proof (induction "length qs" arbitrary: qs rule: less_induct)
   case less 
   then show ?case
   proof clarsimp
     assume ind_hyp: "(\<And>qsa.
         length qsa < length qs \<Longrightarrow> qsa \<noteq> [] \<and> (\<forall>q. List.member qsa q \<longrightarrow> coprime p q) \<longrightarrow>
         set (find_consistent_signs_at_roots p qsa) =
         set (characterize_consistent_signs_at_roots_copr p qsa))"
     assume nonzero: "p \<noteq> 0"  
     assume nontriv: "qs \<noteq> []"
     assume copr:" \<forall>q. List.member qs q \<longrightarrow> coprime p q"
     let ?len = "length qs"
     let ?q1 = "take ((?len) div 2) qs"
     let ?left = "calculate_data p ?q1"
     let ?q2 = "drop ((?len) div 2) qs"
     let ?right = "calculate_data p ?q2"
     have nontriv_q1: "length qs>1 \<longrightarrow> length ?q1 > 0" 
       by auto
     have qs_more_q1: "length qs>1 \<longrightarrow> length qs > length ?q1" 
       by auto
     have pairwise_rel_prime_q1: "\<forall>q. ((List.member ?q1 q) \<longrightarrow> (coprime p q))"
     proof clarsimp 
       fix q 
       assume mem: "List.member (take (length qs div 2) qs) q"
       have "List.member qs q" using mem set_take_subset[where n = "length qs div 2"]
       proof -
         show ?thesis
           by (meson \<open>List.member (take (length qs div 2) qs) q\<close> in_set_member in_set_takeD)
       qed  
       then show "coprime p q" 
         using copr by blast 
     qed
     have nontriv_q2: "length qs>1 \<longrightarrow>length ?q2 > 0" 
       by auto
     have qs_more_q2: "length qs>1 \<longrightarrow> length qs > length ?q2" 
       by auto
     have pairwise_rel_prime_q2: "\<forall>q. ((List.member ?q2 q) \<longrightarrow> (coprime p q))" 
     proof clarsimp 
       fix q 
       assume mem: "List.member (drop (length qs div 2) qs) q"
       have "List.member qs q" using mem set_take_subset[where n = "length qs div 2"]
       proof -
         show ?thesis
           by (meson \<open>List.member (drop (length qs div 2) qs) q\<close> in_set_dropD in_set_member)
       qed
       then show "coprime p q" 
         using copr by blast 
     qed
     have key_h: "set (snd (snd (if ?len \<le> Suc 0 then reduce_system p (qs, base_case_info)
                         else   Let (combine_systems p (?q1, ?left) (?q2, ?right))
                                   (reduce_system p)))) =
        set (characterize_consistent_signs_at_roots_copr p qs)" 
     proof - 
       have h_len1 : "?len = 1 \<longrightarrow> set (snd (snd (if ?len \<le> Suc 0 then reduce_system p (qs, base_case_info)
                         else   Let (combine_systems p (?q1, ?left) (?q2, ?right))
                                   (reduce_system p)))) =
        set (characterize_consistent_signs_at_roots_copr p qs)" 
         using find_consistent_signs_at_roots_len1[of p qs] copr nonzero nontriv
         by (simp add: find_consistent_signs_at_roots_thm)
       have h_len_gt1 : "?len > 1 \<longrightarrow> set (snd (snd (if ?len \<le> Suc 0 then reduce_system p (qs, base_case_info)
                         else   Let (combine_systems p (?q1, ?left) (?q2, ?right))
                                   (reduce_system p)))) =
        set (characterize_consistent_signs_at_roots_copr p qs)" 
       proof - 
         have h_imp_a: "?len > 1 \<longrightarrow> set (snd (snd (reduce_system p (combine_systems p (?q1, ?left) (?q2, ?right))))) =
               set (characterize_consistent_signs_at_roots_copr p qs)"
         proof - 
           have h1: "?len > 1 \<longrightarrow> set(snd(snd(?left))) = set (characterize_consistent_signs_at_roots_copr p ?q1)"
             using nontriv_q1 pairwise_rel_prime_q1 ind_hyp[of ?q1] qs_more_q1             by (metis find_consistent_signs_at_roots_thm less_numeral_extra(3) list.size(3))
           have h2: "?len > 1 \<longrightarrow> set(snd(snd(?right))) = set (characterize_consistent_signs_at_roots_copr p ?q2)"
             using nontriv_q2 pairwise_rel_prime_q2 ind_hyp[of ?q2] qs_more_q2
             by (metis (full_types) find_consistent_signs_at_roots_thm list.size(3) not_less_zero)
           show ?thesis using nonzero nontriv_q1 pairwise_rel_prime_q1 nontriv_q2 pairwise_rel_prime_q2 h1 h2
               smaller_sys_are_good
             by (metis append_take_drop_id find_consistent_signs_at_roots_thm)
         qed
         then have h_imp: "?len > 1 \<longrightarrow> set (snd (snd (Let (combine_systems p (?q1, ?left) (?q2, ?right))
                                   (reduce_system p)))) =
        set (characterize_consistent_signs_at_roots_copr p qs)"
           by auto
         then show ?thesis by auto 
       qed
       show ?thesis using h_len1 h_len_gt1
         by (meson \<open>qs \<noteq> []\<close> length_0_conv less_one nat_neq_iff) 
     qed
     then show "set (find_consistent_signs_at_roots p qs) = set (characterize_consistent_signs_at_roots_copr p qs)"
       by (smt One_nat_def calculate_data.simps find_consistent_signs_at_roots_thm length_0_conv nontriv)
   qed
 qed
 
 lemma find_consistent_signs_at_roots_0:
   fixes p:: "real poly"
   assumes "p \<noteq> 0"
   shows "set(find_consistent_signs_at_roots p []) =
          set(characterize_consistent_signs_at_roots_copr p [])"
 proof -
   obtain a b c where abc: "reduce_system p ([1], base_case_info) = (a,b,c)"
     using prod_cases3 by blast 
   have "find_consistent_signs_at_roots p [1] = c" using abc
     by (simp add: find_consistent_signs_at_roots_thm) 
   have *: "set (find_consistent_signs_at_roots p [1]) = set (characterize_consistent_signs_at_roots_copr p [1])"
     apply (subst find_consistent_signs_at_roots_1)
     using assms apply auto
     by (simp add: member_rec(1) member_rec(2))
   have "set(characterize_consistent_signs_at_roots_copr p []) = drop 1 ` set(characterize_consistent_signs_at_roots_copr p [1])"
     unfolding characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def apply simp
     by (smt drop0 drop_Suc_Cons image_cong image_image)
   thus ?thesis using abc *
     apply (auto) apply (simp add: find_consistent_signs_at_roots_thm)
     by (simp add: find_consistent_signs_at_roots_thm) 
 qed
 
 lemma find_consistent_signs_at_roots_copr:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   assumes "p \<noteq> 0"
   assumes "\<And>q. q \<in> set qs \<Longrightarrow> coprime p q"
   shows "set(find_consistent_signs_at_roots p qs) = set(characterize_consistent_signs_at_roots_copr p qs)"
   by (metis assms find_consistent_signs_at_roots_0 find_consistent_signs_at_roots_1 in_set_member length_greater_0_conv)
 
 lemma find_consistent_signs_at_roots:
   fixes p:: "real poly"
   fixes qs :: "real poly list"
   assumes "p \<noteq> 0"
   assumes "\<And>q. q \<in> set qs \<Longrightarrow> coprime p q"
   shows "set(find_consistent_signs_at_roots p qs) = set(characterize_consistent_signs_at_roots p qs)"
   using assms find_consistent_signs_at_roots_copr csa_list_copr_rel
   by (simp add: in_set_member)
 
 end
\ No newline at end of file
diff --git a/thys/Berlekamp_Zassenhaus/Poly_Mod_Finite_Field_Record_Based.thy b/thys/Berlekamp_Zassenhaus/Poly_Mod_Finite_Field_Record_Based.thy
--- a/thys/Berlekamp_Zassenhaus/Poly_Mod_Finite_Field_Record_Based.thy
+++ b/thys/Berlekamp_Zassenhaus/Poly_Mod_Finite_Field_Record_Based.thy
@@ -1,314 +1,314 @@
 (*
     Authors:      Jose Divasón
                   Sebastiaan Joosten
                   René Thiemann
                   Akihisa Yamada
 *)
 subsubsection \<open>Over a Finite Field\<close>
 theory Poly_Mod_Finite_Field_Record_Based
 imports
   Poly_Mod_Finite_Field
   Finite_Field_Record_Based
   Polynomial_Record_Based
 begin
 
 locale arith_ops_record = arith_ops ops + poly_mod m for ops :: "'i arith_ops_record" and m :: int
 begin
 definition M_rel_i :: "'i \<Rightarrow> int \<Rightarrow> bool" where 
   "M_rel_i f F = (arith_ops_record.to_int ops f = M F)" 
 
 definition Mp_rel_i :: "'i list \<Rightarrow> int poly \<Rightarrow> bool" where 
   "Mp_rel_i f F = (map (arith_ops_record.to_int ops) f = coeffs (Mp F))" 
 
 lemma Mp_rel_i_Mp[simp]: "Mp_rel_i f (Mp F) = Mp_rel_i f F" unfolding Mp_rel_i_def by auto
 
 lemma Mp_rel_i_Mp_to_int_poly_i: "Mp_rel_i f F \<Longrightarrow> Mp (to_int_poly_i ops f) = to_int_poly_i ops f" 
   unfolding Mp_rel_i_def to_int_poly_i_def by simp
 end
 
 locale mod_ring_gen = ring_ops ff_ops R for ff_ops :: "'i arith_ops_record" and
   R :: "'i \<Rightarrow> 'a :: nontriv mod_ring \<Rightarrow> bool" +
   fixes p :: int 
   assumes p: "p = int CARD('a)"
   and of_int: "0 \<le> x \<Longrightarrow> x < p \<Longrightarrow> R (arith_ops_record.of_int ff_ops x) (of_int x)" 
   and to_int: "R y z \<Longrightarrow> arith_ops_record.to_int ff_ops y = to_int_mod_ring z" 
   and to_int': "0 \<le> arith_ops_record.to_int ff_ops y \<Longrightarrow> arith_ops_record.to_int ff_ops y < p \<Longrightarrow> 
     R y (of_int (arith_ops_record.to_int ff_ops y))" 
 begin
 
 lemma nat_p: "nat p = CARD('a)" unfolding p by simp
 
 sublocale poly_mod_type p "TYPE('a)"
   by (unfold_locales, rule p)
 
 lemma coeffs_to_int_poly: "coeffs (to_int_poly (x :: 'a mod_ring poly)) = map to_int_mod_ring (coeffs x)" 
   by (rule coeffs_map_poly, auto)
 
 lemma coeffs_of_int_poly: "coeffs (of_int_poly (Mp x) :: 'a mod_ring poly) = map of_int (coeffs (Mp x))"
   apply (rule coeffs_map_poly)
   by (metis M_0 M_M Mp_coeff leading_coeff_0_iff of_int_hom.hom_zero to_int_mod_ring_of_int_M)
 
 lemma to_int_poly_i: assumes "poly_rel f g" shows "to_int_poly_i ff_ops f = to_int_poly g"
 proof -
   have *: "map (arith_ops_record.to_int ff_ops) f = coeffs (to_int_poly g)"
     unfolding coeffs_to_int_poly 
     by (rule nth_equalityI, insert assms, auto simp: list_all2_conv_all_nth poly_rel_def to_int)
   show ?thesis unfolding coeffs_eq_iff to_int_poly_i_def poly_of_list_def coeffs_Poly *
     strip_while_coeffs..
 qed
 
 lemma poly_rel_of_int_poly: assumes id: "f' = of_int_poly_i ff_ops (Mp f)" "f'' = of_int_poly (Mp f)" 
   shows "poly_rel f' f''" unfolding id poly_rel_def
   unfolding list_all2_conv_all_nth coeffs_of_int_poly of_int_poly_i_def length_map
   by (rule conjI[OF refl], intro allI impI, simp add: nth_coeffs_coeff Mp_coeff M_def, rule of_int,
     insert p, auto)
 
 sublocale arith_ops_record ff_ops p .
 
 lemma Mp_rel_iI: "poly_rel f1 f2 \<Longrightarrow> MP_Rel f3 f2 \<Longrightarrow> Mp_rel_i f1 f3" 
   unfolding Mp_rel_i_def MP_Rel_def poly_rel_def
   by (auto simp add: list_all2_conv_all_nth to_int intro: nth_equalityI)
 
 lemma M_rel_iI: "R f1 f2 \<Longrightarrow> M_Rel f3 f2 \<Longrightarrow> M_rel_i f1 f3" 
   unfolding M_rel_i_def M_Rel_def by (simp add: to_int)
 
 lemma M_rel_iI': assumes "R f1 f2" 
   shows "M_rel_i f1 (arith_ops_record.to_int ff_ops f1)" 
   by (rule M_rel_iI[OF assms], simp add: to_int[OF assms] M_Rel_def M_to_int_mod_ring)
 
 lemma Mp_rel_iI': assumes "poly_rel f1 f2" 
   shows "Mp_rel_i f1 (to_int_poly_i ff_ops f1)" 
 proof (rule Mp_rel_iI[OF assms], unfold to_int_poly_i[OF assms]) 
   show "MP_Rel (to_int_poly f2) f2" unfolding MP_Rel_def by (simp add: Mp_to_int_poly)
 qed
 
 lemma M_rel_iD: assumes "M_rel_i f1 f3"
   shows 
     "R f1 (of_int (M f3))"
     "M_Rel f3 (of_int (M f3))"  
 proof -
   show "M_Rel f3 (of_int (M f3))"
     using M_Rel_def to_int_mod_ring_of_int_M by auto
   from assms show "R f1 (of_int (M f3))" 
     unfolding M_rel_i_def
-    by (metis int_one_le_iff_zero_less leD linear m1 poly_mod.M_def pos_mod_conj to_int')
+    by (metis int_one_le_iff_zero_less leD linear m1 poly_mod.M_def pos_mod_sign pos_mod_bound to_int')
 qed
 
 lemma Mp_rel_iD: assumes "Mp_rel_i f1 f3"
   shows 
     "poly_rel f1 (of_int_poly (Mp f3))"
     "MP_Rel f3 (of_int_poly (Mp f3))"  
 proof -
   show Rel: "MP_Rel f3 (of_int_poly (Mp f3))"
     using MP_Rel_def Mp_Mp Mp_f_representative by auto
   let ?ti = "arith_ops_record.to_int ff_ops" 
   from assms[unfolded Mp_rel_i_def] have
     *: "coeffs (Mp f3) = map ?ti f1" by auto
   {
     fix x
     assume "x \<in> set f1"
     hence "?ti x \<in> set (map ?ti f1)" by auto
     from this[folded *] have "?ti x \<in> range M"
       by (metis (no_types, lifting) MP_Rel_def M_to_int_mod_ring Rel coeffs_to_int_poly ex_map_conv range_eqI)    
     hence "?ti x \<ge> 0" "?ti x < p" unfolding M_def using m1 by auto
     hence "R x (of_int (?ti x))"
       by (rule to_int')
   }
   thus "poly_rel f1 (of_int_poly (Mp f3))" using *
     unfolding poly_rel_def coeffs_of_int_poly
     by (auto simp: list_all2_map2 list_all2_same)
 qed
 end
 
 locale prime_field_gen = field_ops ff_ops R + mod_ring_gen ff_ops R p for ff_ops :: "'i arith_ops_record" and
   R :: "'i \<Rightarrow> 'a :: prime_card mod_ring \<Rightarrow> bool" and p :: int
 begin
 
 sublocale poly_mod_prime_type p "TYPE('a)"
   by (unfold_locales, rule p)
 
 end
 
 lemma (in mod_ring_locale) mod_ring_rel_of_int: 
   "0 \<le> x \<Longrightarrow> x < p \<Longrightarrow> mod_ring_rel x (of_int x)" 
   unfolding mod_ring_rel_def
   by (transfer, auto simp: p)
 
 context prime_field
 begin
 
 
 lemma prime_field_finite_field_ops_int: "prime_field_gen (finite_field_ops_int p) mod_ring_rel p" 
 proof -
   interpret field_ops "finite_field_ops_int p" mod_ring_rel by (rule finite_field_ops_int)
   show ?thesis
     by (unfold_locales, rule p, 
     auto simp: finite_field_ops_int_def p mod_ring_rel_def of_int_of_int_mod_ring)
 qed
 
 lemma prime_field_finite_field_ops_integer: "prime_field_gen (finite_field_ops_integer (integer_of_int p)) mod_ring_rel_integer p" 
 proof -
   interpret field_ops "finite_field_ops_integer (integer_of_int p)" mod_ring_rel_integer by (rule finite_field_ops_integer, simp)
   have pp: "p = int_of_integer (integer_of_int p)" by auto
   interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
     by (rule prime_field_finite_field_ops_int)
   show ?thesis
     by (unfold_locales, rule p, auto simp: finite_field_ops_integer_def 
       mod_ring_rel_integer_def[OF pp] urel_integer_def[OF pp] mod_ring_rel_of_int
       int.to_int[symmetric] finite_field_ops_int_def) 
 qed
 
 lemma prime_field_finite_field_ops32: assumes small: "p \<le> 65535" 
   shows "prime_field_gen (finite_field_ops32 (uint32_of_int p)) mod_ring_rel32 p" 
 proof -
   let ?pp = "uint32_of_int p" 
   have ppp: "p = int_of_uint32 ?pp"
     by (subst int_of_uint32_inv, insert small p2, auto)
   note * = ppp small 
   interpret field_ops "finite_field_ops32 ?pp" mod_ring_rel32 
     by (rule finite_field_ops32, insert *)
   interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
     by (rule prime_field_finite_field_ops_int)
   show ?thesis
   proof (unfold_locales, rule p, auto simp: finite_field_ops32_def)
     fix x
     assume x: "0 \<le> x" "x < p" 
     from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
     thus "mod_ring_rel32 (uint32_of_int x) (of_int x)" unfolding mod_ring_rel32_def[OF *]
       by (intro exI[of _ x], auto simp: urel32_def[OF *], subst int_of_uint32_inv, insert * x, auto)
   next
     fix y z
     assume "mod_ring_rel32 y z" 
     from this[unfolded mod_ring_rel32_def[OF *]] obtain x where yx: "urel32 y x" and xz: "mod_ring_rel x z" by auto
     from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
     show "int_of_uint32 y = to_int_mod_ring z" unfolding zx using yx unfolding urel32_def[OF *] by simp
   next
     fix y
     show "0 \<le> int_of_uint32 y \<Longrightarrow> int_of_uint32 y < p \<Longrightarrow> mod_ring_rel32 y (of_int (int_of_uint32 y))"
       unfolding mod_ring_rel32_def[OF *] urel32_def[OF *]
       by (intro exI[of _ "int_of_uint32 y"], auto simp: mod_ring_rel_of_int)
   qed
 qed
 
 lemma prime_field_finite_field_ops64: assumes small: "p \<le> 4294967295" 
   shows "prime_field_gen (finite_field_ops64 (uint64_of_int p)) mod_ring_rel64 p" 
 proof -
   let ?pp = "uint64_of_int p" 
   have ppp: "p = int_of_uint64 ?pp"
     by (subst int_of_uint64_inv, insert small p2, auto)
   note * = ppp small 
   interpret field_ops "finite_field_ops64 ?pp" mod_ring_rel64
     by (rule finite_field_ops64, insert *)
   interpret int: prime_field_gen "finite_field_ops_int p" mod_ring_rel
     by (rule prime_field_finite_field_ops_int)
   show ?thesis
   proof (unfold_locales, rule p, auto simp: finite_field_ops64_def)
     fix x
     assume x: "0 \<le> x" "x < p" 
     from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
     thus "mod_ring_rel64 (uint64_of_int x) (of_int x)" unfolding mod_ring_rel64_def[OF *]
       by (intro exI[of _ x], auto simp: urel64_def[OF *], subst int_of_uint64_inv, insert * x, auto)
   next
     fix y z
     assume "mod_ring_rel64 y z" 
     from this[unfolded mod_ring_rel64_def[OF *]] obtain x where yx: "urel64 y x" and xz: "mod_ring_rel x z" by auto
     from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
     show "int_of_uint64 y = to_int_mod_ring z" unfolding zx using yx unfolding urel64_def[OF *] by simp
   next
     fix y
     show "0 \<le> int_of_uint64 y \<Longrightarrow> int_of_uint64 y < p \<Longrightarrow> mod_ring_rel64 y (of_int (int_of_uint64 y))"
       unfolding mod_ring_rel64_def[OF *] urel64_def[OF *]
       by (intro exI[of _ "int_of_uint64 y"], auto simp: mod_ring_rel_of_int)
   qed
 qed
 end
 
 context mod_ring_locale
 begin
 lemma mod_ring_finite_field_ops_int: "mod_ring_gen (finite_field_ops_int p) mod_ring_rel p" 
 proof -
   interpret ring_ops "finite_field_ops_int p" mod_ring_rel by (rule ring_finite_field_ops_int)
   show ?thesis
     by (unfold_locales, rule p, 
       auto simp: finite_field_ops_int_def p mod_ring_rel_def of_int_of_int_mod_ring)
 qed
 
 lemma mod_ring_finite_field_ops_integer: "mod_ring_gen (finite_field_ops_integer (integer_of_int p)) mod_ring_rel_integer p" 
 proof -
   interpret ring_ops "finite_field_ops_integer (integer_of_int p)" mod_ring_rel_integer by (rule ring_finite_field_ops_integer, simp)
   have pp: "p = int_of_integer (integer_of_int p)" by auto
   interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
     by (rule mod_ring_finite_field_ops_int)
   show ?thesis
     by (unfold_locales, rule p, auto simp: finite_field_ops_integer_def 
       mod_ring_rel_integer_def[OF pp] urel_integer_def[OF pp] mod_ring_rel_of_int
       int.to_int[symmetric] finite_field_ops_int_def) 
 qed
 
 
 lemma mod_ring_finite_field_ops32: assumes small: "p \<le> 65535" 
   shows "mod_ring_gen (finite_field_ops32 (uint32_of_int p)) mod_ring_rel32 p" 
 proof -
   let ?pp = "uint32_of_int p" 
   have ppp: "p = int_of_uint32 ?pp"
     by (subst int_of_uint32_inv, insert small p2, auto)
   note * = ppp small 
   interpret ring_ops "finite_field_ops32 ?pp" mod_ring_rel32 
     by (rule ring_finite_field_ops32, insert *)
   interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
     by (rule mod_ring_finite_field_ops_int)
   show ?thesis
   proof (unfold_locales, rule p, auto simp: finite_field_ops32_def)
     fix x
     assume x: "0 \<le> x" "x < p" 
     from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
     thus "mod_ring_rel32 (uint32_of_int x) (of_int x)" unfolding mod_ring_rel32_def[OF *]
       by (intro exI[of _ x], auto simp: urel32_def[OF *], subst int_of_uint32_inv, insert * x, auto)
   next
     fix y z
     assume "mod_ring_rel32 y z" 
     from this[unfolded mod_ring_rel32_def[OF *]] obtain x where yx: "urel32 y x" and xz: "mod_ring_rel x z" by auto
     from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
     show "int_of_uint32 y = to_int_mod_ring z" unfolding zx using yx unfolding urel32_def[OF *] by simp
   next
     fix y
     show "0 \<le> int_of_uint32 y \<Longrightarrow> int_of_uint32 y < p \<Longrightarrow> mod_ring_rel32 y (of_int (int_of_uint32 y))"
       unfolding mod_ring_rel32_def[OF *] urel32_def[OF *]
       by (intro exI[of _ "int_of_uint32 y"], auto simp: mod_ring_rel_of_int)
   qed
 qed
 
 lemma mod_ring_finite_field_ops64: assumes small: "p \<le> 4294967295" 
   shows "mod_ring_gen (finite_field_ops64 (uint64_of_int p)) mod_ring_rel64 p" 
 proof -
   let ?pp = "uint64_of_int p" 
   have ppp: "p = int_of_uint64 ?pp"
     by (subst int_of_uint64_inv, insert small p2, auto)
   note * = ppp small 
   interpret ring_ops "finite_field_ops64 ?pp" mod_ring_rel64 
     by (rule ring_finite_field_ops64, insert *)
   interpret int: mod_ring_gen "finite_field_ops_int p" mod_ring_rel
     by (rule mod_ring_finite_field_ops_int)
   show ?thesis
   proof (unfold_locales, rule p, auto simp: finite_field_ops64_def)
     fix x
     assume x: "0 \<le> x" "x < p" 
     from int.of_int[OF this] have "mod_ring_rel x (of_int x)" by (simp add: finite_field_ops_int_def)
     thus "mod_ring_rel64 (uint64_of_int x) (of_int x)" unfolding mod_ring_rel64_def[OF *]
       by (intro exI[of _ x], auto simp: urel64_def[OF *], subst int_of_uint64_inv, insert * x, auto)
   next
     fix y z
     assume "mod_ring_rel64 y z" 
     from this[unfolded mod_ring_rel64_def[OF *]] obtain x where yx: "urel64 y x" and xz: "mod_ring_rel x z" by auto
     from int.to_int[OF xz] have zx: "to_int_mod_ring z = x" by (simp add: finite_field_ops_int_def)
     show "int_of_uint64 y = to_int_mod_ring z" unfolding zx using yx unfolding urel64_def[OF *] by simp
   next
     fix y
     show "0 \<le> int_of_uint64 y \<Longrightarrow> int_of_uint64 y < p \<Longrightarrow> mod_ring_rel64 y (of_int (int_of_uint64 y))"
       unfolding mod_ring_rel64_def[OF *] urel64_def[OF *]
       by (intro exI[of _ "int_of_uint64 y"], auto simp: mod_ring_rel_of_int)
   qed
 qed
 end
 
 end
diff --git a/thys/CRYSTALS-Kyber/Abs_Qr.thy b/thys/CRYSTALS-Kyber/Abs_Qr.thy
--- a/thys/CRYSTALS-Kyber/Abs_Qr.thy
+++ b/thys/CRYSTALS-Kyber/Abs_Qr.thy
@@ -1,577 +1,577 @@
 theory Abs_Qr
 
 imports Mod_Plus_Minus
         Kyber_spec
 
 begin
 context kyber_spec
 begin 
 
 section \<open>Re-centered "Norm" Function\<close>
 
 text \<open>We want to show that \<open>abs_infty_q\<close> is a function induced by the 
   Euclidean norm on the \<open>mod_ring\<close> using a re-centered representative via \<open>mod+-\<close>.
 
   \<open>abs_infty_poly\<close> is the induced norm by \<open>abs_infty_q\<close> on polynomials over the polynomial 
   ring over the \<open>mod_ring\<close>. 
 
   Unfortunately this is not a norm per se, as the homogeneity only holds in 
   inequality, not equality. Still, it fulfils its purpose, since we only 
   need the triangular inequality.\<close>
 
 definition abs_infty_q :: "('a mod_ring) \<Rightarrow> int" where
   "abs_infty_q p = abs ((to_int_mod_ring p) mod+- q)"
 
 definition abs_infty_poly :: "'a qr \<Rightarrow> int" where
   "abs_infty_poly p = Max (range (abs_infty_q \<circ> poly.coeff (of_qr p)))"
 
 text \<open>Helping lemmas and properties of \<open>Max\<close>, \<open>range\<close> and \<open>finite\<close>.\<close>
 
 lemma to_int_mod_ring_range: 
   "range (to_int_mod_ring :: 'a mod_ring \<Rightarrow> int) = {0 ..< q}"
 using CARD_a by (simp add: range_to_int_mod_ring)
 
 lemma finite_Max:
   "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))"
 proof -
   have finite_range: "finite (range (\<lambda>xa. (poly.coeff (of_qr x) xa)))" 
   using MOST_coeff_eq_0[of "of_qr x"] by auto
   have "range (\<lambda>xa. \<bar>to_int_mod_ring (poly.coeff (of_qr x) xa) mod+- q\<bar>)
     = (\<lambda>z. \<bar>to_int_mod_ring z mod+- q\<bar>) ` range (poly.coeff (of_qr x))"
   using range_composition[of "(\<lambda>z. abs (to_int_mod_ring z mod+- q))" 
     "poly.coeff (of_qr x)"] by auto
   then show ?thesis 
     using finite_range finite_image_set[where 
       f = "(\<lambda>z. abs (to_int_mod_ring z) mod+- q)"] 
     by (auto simp add: abs_infty_q_def)
 qed
 
 lemma finite_Max_scale:
   "finite (range (\<lambda>xa. abs_infty_q (of_int_mod_ring s *
     poly.coeff (of_qr x) xa)))"
 proof -
   have "of_int_mod_ring s * poly.coeff (of_qr x) xa = 
     poly.coeff (of_qr (to_module s * x)) xa" for xa
   by (metis coeff_smult of_qr_to_qr_smult to_qr_of_qr 
     to_qr_smult_to_module to_module_def)
   then show ?thesis
   using finite_Max by presburger
 qed
 
 lemma finite_Max_sum: 
   "finite (range (\<lambda>xa. abs_infty_q 
     (poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)))"
 proof -
   have finite_range: "finite (range (\<lambda>xa. (poly.coeff (of_qr x) xa + 
     poly.coeff (of_qr y) xa)))" 
   using MOST_coeff_eq_0[of "of_qr x"] by auto
   have "range (\<lambda>xa. \<bar>to_int_mod_ring (poly.coeff (of_qr x) xa + 
     poly.coeff (of_qr y) xa) mod+- q\<bar>) = 
     (\<lambda>z. \<bar>to_int_mod_ring z mod+- q\<bar>) ` 
     range (\<lambda>xa. poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)"
   using range_composition[of "(\<lambda>z. abs (to_int_mod_ring z mod+- q))" 
     "(\<lambda>xa. poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa)"] 
   by auto
   then show ?thesis 
     using finite_range finite_image_set[where 
       f = "(\<lambda>z. abs (to_int_mod_ring z) mod+- q)" ] 
     by (auto simp add: abs_infty_q_def)
 qed
 
 
 lemma finite_range_plus: 
   assumes "finite (range f)"
           "finite (range g)"
   shows "finite (range (\<lambda>x. f x + g x))"
 proof -
   have subs: "range (\<lambda>x. (f x, g x)) \<subseteq> range f \<times> range g" by auto
   have cart: "finite (range f \<times> range g)" using assms by auto
   have finite: "finite (range (\<lambda>x. (f x, g x)))" 
     using rev_finite_subset[OF cart subs] .
   have "range (\<lambda>x. f x + g x) = (\<lambda>(a,b). a+b) ` range (\<lambda>x. (f x, g x))"
     using range_composition[of "(\<lambda>(a,b). a+b)" "(\<lambda>x. (f x, g x))"] 
     by auto
   then show ?thesis 
     using finite finite_image_set[where f = "(\<lambda>(a,b). a+b)"] 
     by auto
 qed
 
 lemma finite_Max_sum':
   "finite (range
      (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa) + 
       abs_infty_q (poly.coeff (of_qr y) xa)))"
 proof -
   have finite_range_x: 
     "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))" 
     using finite_Max[of x] by auto
   have finite_range_y: 
     "finite (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr y) xa)))" 
     using finite_Max[of y] by auto
   show ?thesis 
     using finite_range_plus[OF finite_range_x finite_range_y] by auto
 qed
 
 
 lemma all_impl_Max: 
   assumes "\<forall>x. f x \<ge> (a::int)"
           "finite (range f)"
   shows "(MAX x. f x) \<ge> a"
 by (simp add: Max_ge_iff assms(1) assms(2))
 
 lemma Max_scale:
 "(MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa)) =
     \<bar>s\<bar> * (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
 proof -
   have "(MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa)) =
     (Max (range (\<lambda>xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa))))"
     by auto
   moreover have "\<dots> = (Max ((\<lambda>a. \<bar>s\<bar> * a) `
     (range (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa)))))"
     by (metis range_composition)
   moreover have "\<dots> = \<bar>s\<bar> * (Max (range 
     (\<lambda>xa. abs_infty_q (poly.coeff (of_qr x) xa))))"
     by (subst mono_Max_commute[symmetric])
        (auto simp add: finite_Max Rings.mono_mult)
   moreover have "\<dots> =  \<bar>s\<bar> * 
     (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
     by auto
   ultimately show ?thesis by auto
 qed
 
 lemma Max_mono':
   assumes "\<forall>x. f x \<le> g x"
           "finite (range f)"
           "finite (range g)"
   shows "(MAX x. f x) \<le> (MAX x. g x)"
 using assms 
 by (metis (no_types, lifting) Max_ge_iff Max_in UNIV_not_empty 
   image_is_empty rangeE rangeI)  
 
 lemma Max_mono_plus:
   assumes "finite (range (f::_\<Rightarrow>_::ordered_ab_semigroup_add))" 
           "finite (range g)"
   shows "(MAX x. f x + g x) \<le> (MAX x. f x) + (MAX x. g x)"
 proof -
   obtain xmax where xmax_def: "f xmax + g xmax = (MAX x. f x + g x)" 
     using finite_range_plus[OF assms] Max_in by fastforce
   have "(MAX x. f x + g x) = f xmax + g xmax" using xmax_def by auto
   also have "\<dots> \<le> (MAX x. f x) + g xmax" 
     using Max_ge[OF assms(1), of "f xmax"] 
     by (auto simp add: add_right_mono[of "f xmax"]) 
   also have "\<dots> \<le> (MAX x. f x) + (MAX x. g x)" 
     using Max_ge[OF assms(2), of "g xmax"]
     by (auto simp add: add_left_mono[of "g xmax"])
   finally show ?thesis by auto
 qed
 
 text \<open>Show that \<open>abs_infty_q\<close> is definite, positive and fulfils the triangle inequality.\<close>
 
 lemma abs_infty_q_definite:
   "abs_infty_q x = 0 \<longleftrightarrow> x = 0"
 proof (auto simp add: abs_infty_q_def 
   mod_plus_minus_zero'[OF q_gt_zero q_odd])
   assume "to_int_mod_ring x mod+- q = 0"
   then have "to_int_mod_ring x mod q = 0" 
     using mod_plus_minus_zero[of "to_int_mod_ring x" q] 
     by auto
   then have "to_int_mod_ring x = 0" 
     using to_int_mod_ring_range CARD_a
     by (metis mod_rangeE range_eqI)
   then show "x = 0" by force
 qed
 
 lemma abs_infty_q_pos:
   "abs_infty_q x \<ge> 0"
 by (auto simp add: abs_infty_q_def) 
 
 
 lemma abs_infty_q_minus:
   "abs_infty_q (- x) = abs_infty_q x"
 proof (cases "x=0")
 case True
   then show ?thesis by auto
 next
 case False
   have minus_x: "to_int_mod_ring (-x) = q - to_int_mod_ring x"
   proof -
     have "to_int_mod_ring (-x) = to_int_mod_ring (-x) mod q"
       by (metis CARD_a Rep_mod_ring_mod to_int_mod_ring.rep_eq)
     also have "\<dots> = (- to_int_mod_ring x) mod q" 
       by (metis (no_types, opaque_lifting) CARD_a diff_eq_eq 
         mod_add_right_eq plus_mod_ring.rep_eq to_int_mod_ring.rep_eq 
         uminus_add_conv_diff)
     also have "\<dots> = q - to_int_mod_ring x" 
     proof -
       have "- to_int_mod_ring x \<in> {-q<..<0}"
       using CARD_a range_to_int_mod_ring False 
         by (smt (verit, best) Rep_mod_ring_mod greaterThanLessThan_iff 
           q_gt_zero to_int_mod_ring.rep_eq to_int_mod_ring_hom.eq_iff 
           to_int_mod_ring_hom.hom_zero zmod_trivial_iff)
       then have "q-to_int_mod_ring x\<in>{0<..<q}" by auto
       then show ?thesis 
         using minus_mod_self1 mod_rangeE
         by (simp add: to_int_mod_ring.rep_eq zmod_zminus1_eq_if)
     qed
     finally show ?thesis by auto
   qed
   then have "\<bar>to_int_mod_ring (- x) mod+- q\<bar> = 
     \<bar>(q - (to_int_mod_ring x)) mod+- q\<bar>" 
     by auto
   also have "\<dots> = \<bar> (- to_int_mod_ring x) mod+- q\<bar>" 
     unfolding mod_plus_minus_def by (smt (z3) mod_add_self2)
   also have "\<dots> = \<bar> - (to_int_mod_ring x mod+- q)\<bar>" 
     using neg_mod_plus_minus[OF q_odd q_gt_zero, 
       of "to_int_mod_ring x"] by simp
   also have "\<dots> = \<bar>to_int_mod_ring x mod+- q\<bar>" by auto
   finally show ?thesis unfolding abs_infty_q_def by auto
 qed
 
 
 
 lemma to_int_mod_ring_mult:
   "to_int_mod_ring (a*b) =  to_int_mod_ring (a::'a mod_ring) * 
     to_int_mod_ring (b::'a mod_ring) mod q"
 by (metis (no_types, lifting) CARD_a of_int_hom.hom_mult 
   of_int_mod_ring.rep_eq of_int_mod_ring_to_int_mod_ring 
   of_int_of_int_mod_ring to_int_mod_ring.rep_eq)
 
 lemma mod_plus_minus_mult: 
   "s*x mod+- q = (s mod+- q) * (x mod+- q) mod+- q"
 unfolding mod_plus_minus_def
 by (smt (verit, del_insts) mod_add_eq mod_diff_left_eq 
   mod_mult_left_eq mod_mult_right_eq)
 
 text \<open>Scaling only with inequality not equality! This causes a problem in proof of the 
   Kyber scheme. Needed to add $q\equiv 1 \mod 4$ to change proof.\<close>
 lemma mod_plus_minus_leq_mod: 
   "\<bar>x mod+- q\<bar> \<le> \<bar>x\<bar>"
 by (smt (verit, best) atLeastAtMost_iff mod_plus_minus_range
   mod_plus_minus_rangeE' q_gt_zero q_odd)
 
 lemma abs_infty_q_scale_pos:
   assumes "s\<ge>0"
   shows "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le> 
     \<bar>s\<bar> * (abs_infty_q x)"
 proof -
   have "\<bar>to_int_mod_ring (of_int_mod_ring s * x) mod+- q\<bar> = 
         \<bar>(to_int_mod_ring (of_int_mod_ring s ::'a mod_ring) * 
           to_int_mod_ring x mod q) mod+- q\<bar>"
     using to_int_mod_ring_mult[of "of_int_mod_ring s" x] by simp
   also have "\<dots> = \<bar>(s mod q * to_int_mod_ring x) mod+- q\<bar>" 
     by (metis CARD_a mod_add_left_eq mod_plus_minus_def 
       of_int_mod_ring.rep_eq to_int_mod_ring.rep_eq)
   also have "\<dots> \<le> \<bar>s mod q\<bar> * \<bar>to_int_mod_ring x mod+- q\<bar>" 
   proof -
     have "\<bar>s mod q * to_int_mod_ring x mod+- q\<bar> = 
           \<bar>(s mod q mod+- q) * (to_int_mod_ring x mod+- q) mod+- q\<bar>"
       using mod_plus_minus_mult by auto
     also have "\<dots> \<le> \<bar>(s mod q mod+- q) * (to_int_mod_ring x mod+- q)\<bar>" 
       using mod_plus_minus_leq_mod by blast
     also have "\<dots> \<le> \<bar>s mod q mod+- q\<bar> * \<bar>(to_int_mod_ring x mod+- q)\<bar>" 
       by (simp add: abs_mult)
     also have "\<dots> \<le> \<bar>s mod q\<bar> * \<bar>(to_int_mod_ring x mod+- q)\<bar>"
       using mod_plus_minus_leq_mod[of "s mod q"] 
       by (simp add: mult_right_mono)
     finally show ?thesis by auto
   qed 
   also have "\<dots> \<le> \<bar>s\<bar> * \<bar>to_int_mod_ring x mod+- q\<bar>" using assms
     by (simp add: mult_mono' q_gt_zero zmod_le_nonneg_dividend)
   finally show ?thesis unfolding abs_infty_q_def by auto
 qed
 
 lemma abs_infty_q_scale_neg:
   assumes "s<0"
   shows "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le> 
     \<bar>s\<bar> * (abs_infty_q x)"
 using abs_infty_q_minus abs_infty_q_scale_pos 
 by (smt (verit, best) mult_minus_left of_int_minus of_int_of_int_mod_ring)
 
 lemma abs_infty_q_scale:
   "abs_infty_q ((of_int_mod_ring s :: 'a mod_ring) * x) \<le> 
     \<bar>s\<bar> * (abs_infty_q x)"
 apply (cases "s\<ge>0") 
 using abs_infty_q_scale_pos apply presburger 
 using abs_infty_q_scale_neg by force
 
 
 text \<open>Lemmas for porting to \<open>qr\<close>.\<close>
 
 lemma of_qr_mult:
   "of_qr (a * b) = of_qr a * of_qr b mod qr_poly"
 by (metis of_qr_to_qr to_qr_mult to_qr_of_qr)
 
 lemma of_qr_scale:
   "of_qr (to_module s * b) = 
   Polynomial.smult (of_int_mod_ring s) (of_qr b)"
 unfolding to_module_def
   by (auto simp add: of_qr_mult[of "to_qr [:of_int_mod_ring s:]" "b"] 
   of_qr_to_qr) (simp add: mod_mult_left_eq mod_smult_left of_qr.rep_eq)
 
 lemma to_module_mult:
   "poly.coeff (of_qr (to_module s * a)) x1 = 
    of_int_mod_ring (s) * poly.coeff (of_qr a) x1"
 using of_qr_scale[of s a] by simp
 
 text \<open>Lemmas on \<open>round\<close> and \<open>floor\<close>.\<close>
 lemma odd_round_up:
 assumes "odd x"
 shows "round (real_of_int x / 2) = (x+1) div 2"
 proof -
   have "round (real_of_int x / 2) = round (real_of_int (x+1) /2)"
     using assms unfolding round_def 
     by (metis (no_types, opaque_lifting) add.commute 
       add_divide_distrib even_add even_succ_div_2 
       floor_divide_of_int_eq odd_one of_int_add 
       of_int_hom.hom_one of_int_numeral)
   also have "\<dots> = (x+1) div 2"
     by (metis add_divide_distrib calculation 
     floor_divide_of_int_eq of_int_add of_int_hom.hom_one 
     of_int_numeral round_def)
   finally show ?thesis by blast
 qed
 
 lemma floor_unique:
 assumes "real_of_int a \<le> x" "x < a+1"
 shows "floor x = a"
   using assms(1) assms(2) by linarith
 
 lemma same_floor:
 assumes "real_of_int a \<le> x" "real_of_int a \<le> y" 
   "x < a+1" "y < a+1"
 shows "floor x = floor y"
 using assms floor_unique  by presburger
 
 lemma one_mod_four_round:
 assumes "x mod 4 = 1"
 shows "round (real_of_int x / 4) = (x-1) div 4"
 proof -
   have leq: "(x-1) div 4 \<le> real_of_int x / 4  + 1 / 2"
     using assms by linarith 
   have gr: "real_of_int x / 4  + 1 / 2 < (x-1) div 4 + 1" 
   proof -
     have "x+2 < 4 * ((x-1) div 4 + 1)" 
     proof -
       have *:  "(x-1) div 4 + 1 = (x+3) div 4" by auto
       have "4 dvd x + 3" using assms by presburger
       then have "4 * ((x+3) div 4) = x+3" 
         by (subst dvd_imp_mult_div_cancel_left, auto)
       then show ?thesis unfolding * by auto
     qed
     then show ?thesis by auto
   qed
   show "round (real_of_int x / 4) = (x-1) div 4"
     using floor_unique[OF leq gr] unfolding round_def by auto
 qed
 
 lemma odd_half_floor:
 assumes "odd x"
 shows "\<lfloor>real_of_int x / 2\<rfloor> = (x-1) div 2"
 using assms by (metis add.commute diff_add_cancel even_add 
  even_succ_div_2 floor_divide_of_int_eq odd_one of_int_numeral)
 
 text \<open>Estimation inequality using message bit.\<close>
 
 lemma abs_infty_poly_ineq_pm_1:
 assumes "\<exists>x. poly.coeff (of_qr a) x \<in> {of_int_mod_ring (-1),1}"
 shows "abs_infty_poly (to_module (round((real_of_int q)/2)) * a) \<ge> 
               2 * round (real_of_int q / 4)"
 proof -
   let ?x = "to_module (round((real_of_int q)/2)) * a"
   obtain x1 where x1_def: 
     "poly.coeff (of_qr a) x1 \<in> {of_int_mod_ring(-1),1}" 
     using assms by auto
   have "abs_infty_poly (to_module (round((real_of_int q)/2)) * a)
     \<ge> abs_infty_q (poly.coeff (of_qr (to_module 
       (round (real_of_int q / 2)) * a)) x1)" 
     unfolding abs_infty_poly_def using x1_def 
     by (simp add: finite_Max)
   also have "abs_infty_q (poly.coeff (of_qr (to_module 
     (round (real_of_int q / 2)) * a)) x1)
   = abs_infty_q (of_int_mod_ring (round (real_of_int q / 2))
     * (poly.coeff (of_qr a) x1))" 
     using to_module_mult[of "round (real_of_int q / 2)" a] 
     by simp
   also have "\<dots> = abs_infty_q (of_int_mod_ring 
     (round (real_of_int q / 2)))" 
   proof -
     consider "poly.coeff (of_qr a) x1=1" | 
       "poly.coeff (of_qr a) x1 = of_int_mod_ring (-1)" 
       using x1_def by auto
     then show ?thesis 
     proof (cases)
       case 2
       then show ?thesis
       by (metis abs_infty_q_minus mult.right_neutral mult_minus_right
           of_int_hom.hom_one of_int_minus of_int_of_int_mod_ring)
     qed (auto)
   qed
   also have "\<dots> = \<bar>round (real_of_int q / 2) mod+- q\<bar>" 
     unfolding abs_infty_q_def 
     using to_int_mod_ring_of_int_mod_ring 
     by (simp add: CARD_a mod_add_left_eq mod_plus_minus_def 
       of_int_mod_ring.rep_eq to_int_mod_ring.rep_eq)
   also have "\<dots> = \<bar>((q + 1) div 2) mod+- q\<bar>" 
     using odd_round_up[OF q_odd] by auto 
   also have "\<dots> = \<bar>((2 * q) div 2) mod q - (q - 1) div 2\<bar>" 
     unfolding mod_plus_minus_def odd_half_floor[OF q_odd] 
     using q_odd 
     by (smt (verit, ccfv_SIG) even_plus_one_iff even_succ_div_2 
       odd_two_times_div_two_succ)
   also have "\<dots> = \<bar>(q-1) div 2\<bar>" using q_odd 
     by (subst nonzero_mult_div_cancel_left[of 2 q], simp) 
        (simp add: abs_div abs_minus_commute)
   also have "\<dots> = 2 * ((q-1) div 4)" 
   proof -
-    have "(q-1) div 2 > 0" by (simp add: div_positive_int q_gt_two)
+    from q_gt_two have "(q-1) div 2 > 0" by simp
     then have "\<bar>(q-1) div 2\<bar> = (q-1) div 2" by auto
     also have "\<dots> = 2 * ((q-1) div 4)" 
       by (subst div_mult_swap) (use q_mod_4 in 
       \<open>metis dvd_minus_mod\<close>, force)
     finally show ?thesis by blast
   qed
   also have "\<dots> = 2 * round (real_of_int q / 4)" 
     unfolding odd_round_up[OF q_odd] one_mod_four_round[OF q_mod_4] 
     by (simp add: round_def)
   finally show ?thesis unfolding abs_infty_poly_def by simp
 qed
 
 text \<open>Triangle inequality for \<open>abs_infty_q\<close>.\<close>
 
 lemma abs_infty_q_triangle_ineq:
   "abs_infty_q (x+y) \<le> abs_infty_q x + abs_infty_q y"
 proof -
   have "to_int_mod_ring (x + y) mod+- q = 
         (to_int_mod_ring x + to_int_mod_ring y) mod q mod+-q"
     by (simp add: to_int_mod_ring_def CARD_a plus_mod_ring.rep_eq)
   also have "\<dots> = (to_int_mod_ring x + to_int_mod_ring y) mod+-q"
     unfolding mod_plus_minus_def by presburger
   also have "\<dots> = (to_int_mod_ring x mod+- q + 
     to_int_mod_ring y mod+- q) mod+- q"
     unfolding mod_plus_minus_def 
     by (smt (verit, ccfv_threshold) mod_add_eq mod_diff_left_eq)
   finally have rewrite:"to_int_mod_ring (x + y) mod+- q = 
     (to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q) mod+- q" .
   then have "\<bar>to_int_mod_ring (x + y) mod+- q\<bar>
     \<le> \<bar>to_int_mod_ring x mod+- q\<bar> + \<bar>to_int_mod_ring y mod+- q\<bar>"
     proof (cases 
     "(to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q) \<in> 
        {-\<lfloor>real_of_int q/2\<rfloor>..<\<lfloor>real_of_int q/2\<rfloor>}")
     case True
       then have "(to_int_mod_ring x mod+- q + 
         to_int_mod_ring y mod+- q) mod+- q
        = to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q" 
         using mod_plus_minus_rangeE[OF True q_odd] by auto 
       then show ?thesis by (simp add: rewrite)
     next
     case False
       then have "\<bar>(to_int_mod_ring x mod+- q + 
         to_int_mod_ring y mod+- q)\<bar> \<ge> \<lfloor>real_of_int q /2\<rfloor>" 
         by auto
       then have "\<bar>(to_int_mod_ring x mod+- q + 
         to_int_mod_ring y mod+- q)\<bar> \<ge> \<bar>(to_int_mod_ring x mod+- q +
         to_int_mod_ring y mod+- q) mod+- q\<bar>"
       using mod_plus_minus_range[OF q_gt_zero, 
         of "(to_int_mod_ring x mod+- q + to_int_mod_ring y mod+- q)"]
       by auto
       then show ?thesis by (simp add: rewrite)
     qed
   then show ?thesis 
     by (auto simp add: abs_infty_q_def mod_plus_minus_def)
 qed
 
 text \<open>Show that \<open>abs_infty_poly\<close> is definite, positive and fulfils the triangle inequality.\<close>
 
 lemma abs_infty_poly_definite:
   "abs_infty_poly x = 0 \<longleftrightarrow> x = 0"
 proof (auto simp add: abs_infty_poly_def abs_infty_q_definite)
   assume "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) = 0"
   then have abs_le_zero: "abs_infty_q (poly.coeff (of_qr x) xa) \<le> 0"
     for xa
     using Max_ge[OF finite_Max[of x], 
       of "abs_infty_q (poly.coeff (of_qr x) xa)"]
     by (auto simp add: Max_ge[OF finite_Max])
   have "abs_infty_q (poly.coeff (of_qr x) xa) = 0" for xa 
     using abs_infty_q_pos[of "poly.coeff (of_qr x) xa"] 
     abs_le_zero[of xa] by auto
   then have "poly.coeff (of_qr x) xa = 0" for xa
     by (auto simp add: abs_infty_q_definite)
   then show "x = 0" 
     using leading_coeff_0_iff of_qr_eq_0_iff by blast
 qed
 
 
 
 lemma abs_infty_poly_pos:
   "abs_infty_poly x \<ge> 0"
 proof (auto simp add: abs_infty_poly_def)
   have f_ge_zero: "\<forall>xa. abs_infty_q (poly.coeff (of_qr x) xa) \<ge> 0"
     by (auto simp add: abs_infty_q_pos)
   then show " 0 \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa))"
     using all_impl_Max[OF f_ge_zero finite_Max] by auto
 qed
 
 
 text \<open>Again, homogeneity is only true for inequality not necessarily equality! 
   Need to add $q\equiv 1\mod 4$ such that proof of crypto scheme works out.\<close>
 lemma abs_infty_poly_scale:
   "abs_infty_poly ((to_module s) * x) \<le> (abs s) * (abs_infty_poly x)"
 proof -
   have fin1: "finite (range (\<lambda>xa. abs_infty_q (of_int_mod_ring s *
     poly.coeff (of_qr x) xa)))"
     using finite_Max_scale by auto
   have fin2: "finite (range (\<lambda>xa. \<bar>s\<bar> *
      abs_infty_q (poly.coeff (of_qr x) xa)))"
     by (metis finite_Max finite_imageI range_composition)
   have "abs_infty_poly (to_module s * x) = 
         (MAX xa. abs_infty_q
          ((of_int_mod_ring s) * poly.coeff (of_qr x) xa))"
   using abs_infty_poly_def to_module_mult by force    
   also have "\<dots> \<le> (MAX xa. \<bar>s\<bar> * abs_infty_q (poly.coeff (of_qr x) xa))"
     using abs_infty_q_scale fin1 fin2 by (subst Max_mono', auto)
   also have "\<dots> = \<bar>s\<bar> * abs_infty_poly x"
     unfolding abs_infty_poly_def comp_def using Max_scale by auto
   finally show ?thesis by blast
 qed
 
 
 text \<open>Triangle inequality for \<open>abs_infty_poly\<close>.\<close>
 lemma abs_infty_poly_triangle_ineq:
   "abs_infty_poly (x+y) \<le> abs_infty_poly x + abs_infty_poly y"
 proof -
   have "abs_infty_q (poly.coeff (of_qr x) xa + 
     poly.coeff (of_qr y) xa) \<le> 
     abs_infty_q (poly.coeff (of_qr x) xa) + 
     abs_infty_q (poly.coeff (of_qr y) xa)"
     for xa
     using abs_infty_q_triangle_ineq[of 
       "poly.coeff (of_qr x) xa" "poly.coeff (of_qr y) xa"]
     by auto
   then have abs_q_triang: "\<forall>xa. 
     abs_infty_q (poly.coeff (of_qr x) xa + poly.coeff (of_qr y) xa) \<le>
     abs_infty_q (poly.coeff (of_qr x) xa) + 
     abs_infty_q (poly.coeff (of_qr y) xa)"
     by auto
   have "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa + 
       poly.coeff (of_qr y) xa))
     \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa) + 
       abs_infty_q (poly.coeff (of_qr y) xa))"
     using Max_mono'[OF abs_q_triang finite_Max_sum finite_Max_sum'] 
     by auto
   also have "\<dots> \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) +
        (MAX xb. abs_infty_q (poly.coeff (of_qr y) xb))" 
     using Max_mono_plus[OF finite_Max[of x] finite_Max[of y]] 
     by auto
   finally have "(MAX xa. abs_infty_q (poly.coeff (of_qr x) xa + 
       poly.coeff (of_qr y) xa))
     \<le> (MAX xa. abs_infty_q (poly.coeff (of_qr x) xa)) +
        (MAX xb. abs_infty_q (poly.coeff (of_qr y) xb))"
     by auto
   then show ?thesis 
     by (auto simp add: abs_infty_poly_def)
 qed
 
 
 
 
 end
 end
\ No newline at end of file
diff --git a/thys/Case_Labeling/Examples/Monadic_Language.thy b/thys/Case_Labeling/Examples/Monadic_Language.thy
--- a/thys/Case_Labeling/Examples/Monadic_Language.thy
+++ b/thys/Case_Labeling/Examples/Monadic_Language.thy
@@ -1,310 +1,310 @@
 subsection \<open>A labeling VCG for a monadic language\<close>
 
 theory Monadic_Language
 imports
   Complex_Main
   "../Case_Labeling"
   "HOL-Eisbach.Eisbach"
 begin
 
 ML_file \<open>../util.ML\<close>
 
 ML \<open>
   fun vcg_tac nt_rules nt_comb ctxt =
     let
       val rules = Named_Theorems.get ctxt nt_rules
       val comb = Named_Theorems.get ctxt nt_comb
     in REPEAT_ALL_NEW_FWD ( resolve_tac ctxt rules ORELSE' (resolve_tac ctxt comb THEN' resolve_tac ctxt rules)) end
 \<close>
 
 
 text \<open>This language is inspired by the languages used in AutoCorres @{cite greenaway_bridging_2012}\<close>
 
 consts bind :: "'a option \<Rightarrow> ('a \<Rightarrow> 'b option) \<Rightarrow> 'b option" (infixr "|>>" 4)
 consts return :: "'a \<Rightarrow> 'a option"
 consts while :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a option) \<Rightarrow> ('a \<Rightarrow> 'a option)"
 consts valid :: "bool \<Rightarrow> 'a option \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool"
 
 named_theorems vcg
 named_theorems vcg_comb
 
 method_setup vcg = \<open>
   Scan.succeed (fn ctxt => SIMPLE_METHOD (FIRSTGOAL (vcg_tac @{named_theorems "vcg"} @{named_theorems "vcg_comb"} ctxt)))
 \<close>
 
 
 axiomatization where
    return[vcg]: "valid (Q x) (return x) Q" and
    bind[vcg]: "\<lbrakk>\<And>x. valid (R x) (c2 x) Q; valid P c1 R\<rbrakk> \<Longrightarrow> valid P (bind c1 c2) Q" and
    while[vcg]: "\<And>c. \<lbrakk>\<And>x. valid (I x \<and> b x) (c x) I; \<And>x. I x \<and> \<not>b x \<Longrightarrow> Q x\<rbrakk> \<Longrightarrow> valid (I x) (while b I c x) Q" and
    cond[vcg]: "\<And>b c1 c2. valid P1 c1 Q \<Longrightarrow> valid P2 c2 Q \<Longrightarrow> valid (if b then P1 else P2) (if b then c1 else c2) Q" and
    case_prod[vcg]: "\<And>P. \<lbrakk>\<And>x y. v = (x,y) \<Longrightarrow> valid (P x y) (B x y) Q\<rbrakk>
     \<Longrightarrow> valid (case v of (x,y) \<Rightarrow> P x y) (case v of (x,y) \<Rightarrow> B x y) Q" and
    conseq[vcg_comb]: "\<lbrakk>valid P' c Q; P \<Longrightarrow> P'\<rbrakk> \<Longrightarrow> valid P c Q"
 
 
 text \<open>Labeled rules\<close>
 
 named_theorems vcg_l
 named_theorems vcg_l_comb
 named_theorems vcg_elim
 
 method_setup vcg_l = \<open>
   Scan.succeed (fn ctxt => SIMPLE_METHOD (FIRSTGOAL (vcg_tac @{named_theorems "vcg_l"} @{named_theorems "vcg_l_comb"} ctxt)))
 \<close>
 
 method vcg_l' = (vcg_l; (elim vcg_elim)?)
 
 context begin
   interpretation Labeling_Syntax .
 
   lemma L_return[vcg_l]: "CTXT inp ct (Suc inp) (valid (P x) (return x) P)"
     unfolding LABEL_simps by (rule return)
 
   lemma L_bind[vcg_l]:
     assumes "\<And>x. CTXT (Suc outp') ((''bind'',outp', [VAR x]) # ct) outp (valid (R x) (c2 x) Q)"
     assumes "CTXT inp ct outp' (valid P c1 R)"
     shows "CTXT inp ct outp (valid P (bind c1 c2) Q)"
     using assms unfolding LABEL_simps by (rule bind)
 
   lemma L_while[vcg_l]:
     fixes inp ct defines "ct' \<equiv> \<lambda>x. (''while'', inp, [VAR x])  # ct"
     assumes "\<And>x. CTXT (Suc inp) (ct' x) outp'
       (valid (BIND ''inv_pre'' inp (I x) \<and> BIND ''lcond'' inp (b x)) (c x) (\<lambda>x. BIND ''inv_post'' inp (I x)))"
     assumes "\<And>x. B\<langle>''inv_pre'',inp: I x\<rangle> \<and> B\<langle>''lcond'',inp: \<not>b x\<rangle> \<Longrightarrow> VC (''post'',outp' , []) (ct' x) (P x)"
     shows "CTXT inp ct (Suc outp') (valid (I x) (while b I c x) P)"
     using assms(2-) unfolding LABEL_simps by (rule while)
 
   lemma L_cond[vcg_l]:
     fixes inp ct defines "ct' \<equiv> (''if'',inp,[]) # ct"
     assumes "C\<langle>Suc inp, (''then'',inp,[]) # ct',outp: valid P1 c1 Q\<rangle>"
     assumes "C\<langle>Suc outp, (''else'',outp,[]) # ct',outp': valid P2 c2 Q\<rangle>"
     shows "C\<langle>inp,ct,outp': valid (if B\<langle>''cond'',inp: b\<rangle> then B\<langle>''then'',inp: P1\<rangle> else B\<langle>''else'',inp: P2\<rangle>) (if b then c1 else c2) Q\<rangle>"
     using assms(2-) unfolding LABEL_simps by (rule cond)
 
   lemma L_case_prod[vcg_l]:
     assumes "\<And>x y. v = (x,y) \<Longrightarrow> CTXT inp ct outp (valid (P x y) (B x y) Q)"
     shows "CTXT inp ct outp (valid (case v of (x,y) \<Rightarrow> P x y) (case v of (x,y) \<Rightarrow> B x y) Q)"
     using assms unfolding LABEL_simps by (rule case_prod)
 
   lemma L_conseq[vcg_l_comb]:
     assumes "CTXT (Suc inp) ct outp (valid P' c Q)"
     assumes "P \<Longrightarrow> VC (''conseq'',inp,[]) ct P'"
     shows "CTXT inp ct outp (valid P c Q)"
     using assms unfolding LABEL_simps by (rule conseq)
 
   lemma L_assm_conjE[vcg_elim]:
     assumes "BIND name inp (P \<and> Q)" obtains "BIND name inp P" "BIND name inp Q"
     using assms unfolding LABEL_simps by auto
 
   declare conjE[vcg_elim]
 
 end
 
 
 
 lemma dvd_div:
   fixes a b c :: int
   assumes "a dvd b" "c dvd b" "coprime a c"
   shows "a dvd (b div c)"
   using assms coprime_dvd_mult_left_iff by fastforce
 
 lemma divides: "
 valid
   (0 < (a :: int))
   (
     return a
     |>> (\<lambda>n.
       while
         (\<lambda>n. even n)
         (\<lambda>n. 0 < n \<and> n dvd a \<and> (\<forall>m. odd m \<and> m dvd a \<longrightarrow> m dvd n))
         (\<lambda>n. return (n div 2))
         n
     )
   )
   (\<lambda>r. odd r \<and> r dvd a \<and> (\<forall>m. odd m \<and> m dvd a \<longrightarrow> m \<le> r))
 "
   apply vcg
-    apply (auto simp add: zdvd_imp_le dvd_div div_positive_int elim!:
+    apply (auto simp add: zdvd_imp_le dvd_div elim!:
       evenE intro: dvd_mult_right)
   done
 
 lemma L_divides: "
 valid
   (0 < (a :: int))
   (
     return a
     |>> (\<lambda>n.
       while
         (\<lambda>n. even n)
         (\<lambda>n. 0 < n \<and> n dvd a \<and> (\<forall>m. odd m \<and> m dvd a \<longrightarrow> m dvd n))
         (\<lambda>n. return (n div 2))
         n
     )
   )
   (\<lambda>r. odd r \<and> r dvd a \<and> (\<forall>m. odd m \<and> m dvd a \<longrightarrow> m \<le> r))
 "
   apply (rule Initial_Label)
   apply vcg_l'
 proof casify
 print_nested_cases
   case bind
   { case (while n)
     { case post then show ?case by (auto simp: zdvd_imp_le)
     next
       case conseq
       from \<open>0 < n\<close> \<open>even n\<close> have "0 < n div 2"
         by (simp add: pos_imp_zdiv_pos_iff zdvd_imp_le)
       moreover
       from \<open>n dvd a\<close> \<open>even n\<close> have "n div 2 dvd a"
         by (metis dvd_div_mult_self dvd_mult_left)
       moreover
       { fix m assume "odd m" "m dvd a"
         then have "m dvd n" using conseq.inv_pre(3) by simp
         moreover note \<open>even n\<close>
         moreover from \<open>odd m\<close> have "coprime m 2"
          by (metis dvd_eq_mod_eq_0 invertible_coprime mult_cancel_left2 not_mod_2_eq_1_eq_0)
         ultimately
         have "m dvd n div 2" by (rule dvd_div)
       }
       ultimately show ?case by auto
     }
   next
     case conseq then show ?case by auto
   }
 qed
 
 
 
 lemma add: "
 valid
   True
   (
     while
       \<comment> \<open>COND:\<close> (\<lambda>(r,j). j < (b :: nat))
       \<comment> \<open>INV:\<close> (\<lambda>(r,j). j \<le> b \<and> r = a + j)
       \<comment> \<open>BODY:\<close> (\<lambda>(r,j). return (r + 1, j + 1))
       \<comment> \<open>START:\<close> (a,0)
     |>> (\<lambda>(r,_). return r)
   )
   (\<lambda>r. r = a + b)
 "
   by vcg auto
 
 
 lemma mult: "
 valid
   True
   (
     while
       \<comment> \<open>COND:\<close> (\<lambda>(r,i). i < (a :: nat))
       \<comment> \<open>INV:\<close> (\<lambda>(r,i). i \<le> a \<and> r = i * b)
       \<comment> \<open>BODY:\<close> (\<lambda>(r,i).
         while
           \<comment> \<open>COND:\<close> (\<lambda>(r,j). j < b)
           \<comment> \<open>INV:\<close> (\<lambda>(r,j). i < a \<and> j \<le> b \<and> r = i * b + j)
           \<comment> \<open>BODY:\<close> (\<lambda>(r,j). return (r + 1, j + 1))
           \<comment> \<open>START:\<close> (r,0)
         |>> (\<lambda>(r,_). return (r, i + 1))
       )
       \<comment> \<open>START:\<close> (0,0)
     |>> (\<lambda>(r,_). return r)
   )
   (\<lambda>r. r = a * b)
 "
   by vcg auto
 
 
 section \<open>Labeled\<close>
 
 lemma L_mult: "
 valid
   True
   (
     while
       \<comment> \<open>COND:\<close> (\<lambda>(r,i). i < (a :: nat))
       \<comment> \<open>INV:\<close> (\<lambda>(r,i). i \<le> a \<and> r = i * b)
       \<comment> \<open>BODY:\<close> (\<lambda>(r,i).
         while
           \<comment> \<open>COND:\<close> (\<lambda>(r,j). j < b)
           \<comment> \<open>INV:\<close> (\<lambda>(r,j). i < a \<and> j \<le> b \<and> r = i * b + j)
           \<comment> \<open>BODY:\<close> (\<lambda>(r,j). return (r + 1, j + 1))
           \<comment> \<open>START:\<close> (r,0)
         |>> (\<lambda>(r,_). return (r, i + 1))
       )
       \<comment> \<open>START:\<close> (0,0)
     |>> (\<lambda>(r,_). return r)
   )
   (\<lambda>r. r = a * b)
 "
   apply (rule Initial_Label)
   apply vcg_l'
 proof casify
   case while
   { case while
     { case post then show ?case by auto
     next
       case conseq then show ?case by auto
     }
   next
     case post then show ?case by auto
   next
     case conseq then show ?case by auto
   }
 next
   case conseq then show ?case by auto
 qed
 
 lemma L_paths: "
 valid
   (path \<noteq> [])
   ( while
       \<comment> \<open>COND:\<close> (\<lambda>(p,r). p \<noteq> [])
       \<comment> \<open>INV:\<close> (\<lambda>(p,r). distinct r \<and> hd (r @ p) = hd path \<and> last (r @ p) = last path)
       \<comment> \<open>BODY:\<close> (\<lambda>(p,r).
         return (hd p)
         |>> (\<lambda>x.
           if (r \<noteq> [] \<and> x = hd r)
           then return []
           else (if x \<in> set r
             then return (takeWhile (\<lambda>y. y \<noteq> x) r)
             else return (r))
         |>> (\<lambda>r'. return (tl p, r' @ [x])
         )
         )
         )
       \<comment> \<open>START:\<close> (path, [])
     |>> (\<lambda>(_,r). return r)
   )
   (\<lambda>r. distinct r \<and> hd r = hd path \<and> last r = last path)
 "
   apply (rule Initial_Label)
   apply vcg_l'
 proof casify
   case conseq then show ?case by auto
 next
   case (while p r)
   { case conseq
     from conseq have "r = [] \<Longrightarrow> ?case" by (cases p) auto
     moreover
     from conseq have "r \<noteq> [] \<Longrightarrow> hd p = hd r \<Longrightarrow> ?case" by (cases p) auto
     moreover
     { assume A: "r \<noteq> []" "hd p \<noteq> hd r"
       have "hd (takeWhile (\<lambda>y. y \<noteq> hd p) r @ hd p # tl p) = hd r"
         using A by (cases r) auto
       moreover
       have "last (takeWhile (\<lambda>y. y \<noteq> hd p) r @ hd p # tl p) = last (r @ p)"
         using A \<open>p \<noteq> []\<close> by auto
       moreover
       have "distinct (takeWhile (\<lambda>y. y \<noteq> hd p) r @ [hd p])"
         using conseq by (auto dest: set_takeWhileD)
       ultimately
       have ?case using A conseq by auto
     }
     ultimately show ?case by blast
   next
     case post then show ?case by auto
   }
 qed
 
 end
diff --git a/thys/Consensus_Refined/Consensus_Misc.thy b/thys/Consensus_Refined/Consensus_Misc.thy
--- a/thys/Consensus_Refined/Consensus_Misc.thy
+++ b/thys/Consensus_Refined/Consensus_Misc.thy
@@ -1,304 +1,292 @@
 (*<*)
 theory Consensus_Misc
 imports Main
 begin
 (*>*)
 
 subsection \<open>Miscellaneous lemmas\<close>
 
 method_setup clarsimp_all =
   \<open>Method.sections clasimp_modifiers >>
     K (SIMPLE_METHOD o CHANGED_PROP o PARALLEL_ALLGOALS o clarsimp_tac)\<close>
   "clarify simplified, all goals"
 
-lemma div_Suc:
-  "Suc m div n = (if Suc m mod n = 0 then Suc (m div n) else m div n)" (is "_ = ?rhs")
-proof (cases "Suc m mod n = 0")
-  case True
-  then show ?thesis
-    by simp (metis Zero_not_Suc diff_Suc_Suc div_geq minus_mod_eq_mult_div mod_Suc mod_less neq0_conv nonzero_mult_div_cancel_left)
-next
-  case False
-  then show ?thesis
-    by simp (metis diff_Suc_Suc div_eq_0_iff minus_mod_eq_mult_div mod_Suc neq0_conv nonzero_mult_div_cancel_left)
-qed
-
 definition flip where
   flip_def: "flip f \<equiv> \<lambda>x y. f y x"
 
 lemma option_expand':
   "\<lbrakk>(option = None) = (option' = None); \<And>x y. \<lbrakk>option = Some x; option' = Some y\<rbrakk> \<Longrightarrow> x = y\<rbrakk> \<Longrightarrow> 
     option = option'"
   by(rule option.expand, auto)
 
 (*********************************)
 subsection \<open>Argmax\<close>
 definition Max_by :: "('a \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a set \<Rightarrow> 'a" where
   "Max_by f S = (SOME x. x \<in> S \<and> f x = Max (f ` S))"
 
 lemma Max_by_dest:
   assumes "finite A" and "A \<noteq> {}"
   shows "Max_by f A \<in> A \<and> f (Max_by f A) = Max (f ` A)" (is "?P (Max_by f A)")
 proof(simp only: Max_by_def some_eq_ex[where P="?P"])
   from assms have "finite (f ` A)" "f ` A \<noteq> {}" by auto
   from Max_in[OF this] show "\<exists>x. x \<in> A \<and> f x = Max (f ` A)"
     by (metis image_iff)
 qed
 
 lemma Max_by_in:
   assumes "finite A" and "A \<noteq> {}"
   shows "Max_by f A \<in> A" using assms
   by(rule Max_by_dest[THEN conjunct1])
 
 lemma Max_by_ge:
   assumes "finite A" "x \<in> A"
   shows "f x \<le> f (Max_by f A)"
 proof-
   from assms(1) have fin_image: "finite (f ` A)" by simp
   from assms(2) have non_empty: "A \<noteq> {}" by auto
   have "f x \<in> f ` A" using assms(2) by simp
   from Max_ge[OF fin_image this] and Max_by_dest[OF assms(1) non_empty, of f] show ?thesis
     by(simp)
 qed
 
 lemma finite_UN_D:
   "finite (\<Union>S) \<Longrightarrow> \<forall>A \<in> S. finite A"
   by (metis Union_upper finite_subset)
 
 lemma Max_by_eqI:
   assumes
     fin: "finite A"
     and "\<And>y. y \<in> A \<Longrightarrow> cmp_f y \<le> cmp_f x" 
     and in_X: "x \<in> A"
     and inj: "inj_on cmp_f A"
   shows "Max_by cmp_f A = x"
 proof-
   have in_M: "Max_by cmp_f A \<in> A" using assms
     by(auto intro!: Max_by_in)
   hence "cmp_f (Max_by cmp_f A) \<le> cmp_f x" using assms 
     by auto
   also have "cmp_f x \<le> cmp_f (Max_by cmp_f A)"
     by (intro Max_by_ge assms)
   finally show ?thesis  using inj in_M in_X
     by(auto simp add: inj_on_def)
 qed
     
 lemma Max_by_Union_distrib:
   "\<lbrakk> finite A; A = \<Union>S; S \<noteq> {}; {} \<notin> S; inj_on cmp_f A \<rbrakk> \<Longrightarrow> 
     Max_by cmp_f A = Max_by cmp_f (Max_by cmp_f ` S)"
 proof(rule Max_by_eqI, assumption)
   fix y
   assume assms: "finite A" "A = \<Union>S" "{} \<notin> S" "y \<in> A"
   then obtain B where B_def: "B \<in> S" "y \<in> B" by auto
   hence "cmp_f y \<le> cmp_f (Max_by cmp_f B)" using assms
     by (metis Max_by_ge finite_UN_D)
   also have "... \<le> cmp_f (Max_by cmp_f (Max_by cmp_f ` S))" using B_def(1) assms
     by (metis Max_by_ge finite_UnionD finite_imageI imageI)
   finally show "cmp_f y \<le> cmp_f (Max_by cmp_f (Max_by cmp_f ` S))" .
 next
   assume assms: "finite A" "A = \<Union>S" "{} \<notin> S" "S \<noteq> {}"
   hence "Max_by cmp_f ` S \<noteq> {}" "finite (Max_by cmp_f ` S)"
     apply (metis image_is_empty)
     by (metis assms(1) assms(2) finite_UnionD finite_imageI)
   hence "Max_by cmp_f (Max_by cmp_f ` S) \<in> (Max_by cmp_f ` S)"
     by(blast intro!: Max_by_in)
   also have "(Max_by cmp_f ` S) \<subseteq> A"
   proof -
     have f1: "\<forall>v0 v1. (\<not> finite v0 \<or> v0 = {}) \<or> Max_by (v1::'a \<Rightarrow> 'b) v0 \<in> v0" using Max_by_in by blast
     have "\<forall>v1. v1 \<notin> S \<or> finite v1" using assms(1) assms(2) finite_UN_D by blast
     then obtain v2_13 :: "'a set set \<Rightarrow> 'a \<Rightarrow> 'a set" where "Max_by cmp_f ` S \<subseteq> \<Union>S" using f1 assms(3) by blast
     thus "Max_by cmp_f ` S \<subseteq> A" using assms(2) by presburger
   qed
   finally show "Max_by cmp_f (Max_by cmp_f ` S) \<in> A" .
 qed
 
 lemma Max_by_UNION_distrib:
   "\<lbrakk>finite A; A = (\<Union>x\<in>S. f x); S \<noteq> {}; {} \<notin> f ` S; inj_on cmp_f A\<rbrakk> \<Longrightarrow> 
     Max_by cmp_f A = Max_by cmp_f (Max_by cmp_f ` (f ` S))"
   by(force intro!: Max_by_Union_distrib)
 
 lemma Max_by_eta:
   "Max_by f = (\<lambda>S. (SOME x. x \<in> S \<and> f x = Max (f ` S)))"
   by(auto simp add: Max_by_def)
 
 lemma Max_is_Max_by_id:
   "\<lbrakk> finite S; S \<noteq> {} \<rbrakk> \<Longrightarrow> Max S = Max_by id S "
   apply(clarsimp simp add: Max_by_def)
   by (metis (mono_tags, lifting) Max_in someI_ex)
 
 definition option_Max_by :: "('a \<Rightarrow> 'b :: linorder) \<Rightarrow> 'a set \<Rightarrow> 'a option" where
   "option_Max_by cmp_f A \<equiv> if A = {} then None else Some (Max_by cmp_f A)"
 
 (*********************************)
 
 subsection \<open>Function and map graphs\<close>
 
 definition fun_graph where
   "fun_graph f = {(x, f x)|x. True}"
 
 definition map_graph :: "('a, 'b)map \<Rightarrow> ('a \<times> 'b) set" where
   "map_graph f = {(x, y)|x y. (x, Some y) \<in> fun_graph f}"
 
 lemma map_graph_mem[simp]:
   "((x, y) \<in> map_graph f) = (f x = Some y)"
   by(auto simp add: dom_def map_graph_def fun_graph_def)
 
 lemma finite_fun_graph:
   "finite A \<Longrightarrow> finite (fun_graph f \<inter> (A \<times> UNIV))"
   apply(rule bij_betw_finite[where A=A and f="\<lambda>x. (x, f x)", THEN iffD1])
   by(auto simp add: fun_graph_def bij_betw_def inj_on_def)
 
 lemma finite_map_graph:
   "finite A \<Longrightarrow> finite (map_graph f \<inter> (A \<times> UNIV))"
   by(force simp add: map_graph_def
     dest!: finite_fun_graph[where f=f]
     intro!: finite_surj[where A="fun_graph f \<inter> (A \<times> UNIV)" and f="apsnd the"] 
   )
 
 lemma finite_dom_finite_map_graph:
   "finite (dom f) \<Longrightarrow> finite (map_graph f)"
   apply(simp add: dom_def map_graph_def fun_graph_def)
   apply(erule finite_surj[where f="\<lambda>x. (x, the (f x))"])
   apply(clarsimp simp add: image_def)
   by (metis option.sel)
 
 (*******************************************************************)
 lemma ran_map_addD:
   "x \<in> ran (m ++ f) \<Longrightarrow> x \<in> ran m \<or> x \<in> ran f"
   by(auto simp add: ran_def)
 
 subsection \<open>Constant maps\<close>
 
 definition const_map :: "'v \<Rightarrow> 'k set \<Rightarrow> ('k, 'v)map" where
   "const_map v S \<equiv> (\<lambda>_. Some v) |` S"
 
 lemma const_map_empty[simp]:
   "const_map v {} = Map.empty"
   by(auto simp add: const_map_def)
 
 lemma const_map_ran[simp]: "x \<in> ran (const_map v S) = (S \<noteq> {} \<and> x = v)"
   by(auto simp add: const_map_def ran_def restrict_map_def)
 
 lemma const_map_is_None:
   "(const_map y A  x = None) = (x \<notin> A)"
   by(auto simp add: const_map_def restrict_map_def)
 
 lemma const_map_is_Some:
   "(const_map y A x = Some z) = (z = y \<and> x \<in> A)"
   by(auto simp add: const_map_def restrict_map_def)
 
 lemma const_map_in_set:
   "x \<in> A \<Longrightarrow> const_map v A x = Some v"
   by(auto simp add: const_map_def)
 
 lemma const_map_notin_set:
   "x \<notin> A \<Longrightarrow> const_map v A x = None"
   by(auto simp add: const_map_def)
 
 lemma dom_const_map:
   "dom (const_map v S) = S"
   by(auto simp add: const_map_def)
 
 (*******************************************************************)
 subsection \<open>Votes with maximum timestamps.\<close>
 (*******************************************************************)
 
 definition vote_set :: "('round \<Rightarrow> ('process, 'val)map) \<Rightarrow> 'process set \<Rightarrow> ('round \<times> 'val)set" where
   "vote_set vs Q \<equiv> {(r, v)|a r v. ((r, a), v) \<in> map_graph (case_prod vs) \<and> a \<in> Q}"
 
 lemma inj_on_fst_vote_set:
   "inj_on fst (vote_set v_hist {p})"
   by(clarsimp simp add: inj_on_def vote_set_def)
 
 lemma finite_vote_set:
   assumes "\<forall>r'\<ge>(r :: nat). v_hist r' = Map.empty"
     "finite S"
   shows "finite (vote_set v_hist S)"
 proof-
   define vs where "vs = {((r, a), v)|r a v. ((r, a), v) \<in> map_graph (case_prod v_hist) \<and> a \<in> S}"
   have "vs
       = (\<Union>p\<in>S. ((\<lambda>(r, v). ((r, p), v)) ` (map_graph (\<lambda>r. v_hist r p))))"
       by(auto simp add: map_graph_def fun_graph_def vs_def)
   also have "... \<le> (\<Union>p\<in>S. (\<lambda>r. ((r, p), the (v_hist r p))) ` {0..<r})" 
     using assms(1)
     apply auto
     apply (auto simp add: map_graph_def fun_graph_def image_def)
     apply (metis le_less_linear option.distinct(1))
     done
   also note I=finite_subset[OF calculation] 
   have "finite vs"
     by(auto intro: I assms(2) nat_seg_image_imp_finite[where n=r])    
     
   thus ?thesis
     apply(clarsimp simp add: map_graph_def fun_graph_def vote_set_def vs_def)
     apply(erule finite_surj[where f="\<lambda>((r, a), v). (r, v)"])
     by(force simp add: image_def)
 qed
 
 definition mru_of_set 
   :: "('round :: linorder \<Rightarrow> ('process, 'val)map) \<Rightarrow> ('process set, 'round \<times> 'val)map" where
   "mru_of_set vs \<equiv> \<lambda>Q. option_Max_by fst (vote_set vs Q)"
 
 definition process_mru 
   :: "('round :: linorder \<Rightarrow> ('process, 'val)map) \<Rightarrow> ('process, 'round \<times> 'val)map" where
   "process_mru vs \<equiv> \<lambda>a. mru_of_set vs {a}"
 
 lemma process_mru_is_None:
   "(process_mru v_f a = None) = (vote_set v_f {a} = {})"
   by(auto simp add: process_mru_def mru_of_set_def option_Max_by_def)
 
 lemma process_mru_is_Some:
   "(process_mru v_f a = Some rv) = (vote_set v_f {a} \<noteq> {} \<and> rv = Max_by fst (vote_set v_f {a}))"
   by(auto simp add: process_mru_def mru_of_set_def option_Max_by_def)
 
 lemma vote_set_upd:
   "vote_set (v_hist(r := v_f)) {p} = 
       (if p \<in> dom v_f 
         then insert (r, the (v_f p))
         else id
       )
       (if v_hist r p = None
         then vote_set v_hist {p}
         else vote_set v_hist {p} - {(r, the (v_hist r p))}
       )
   "
   by(auto simp add: vote_set_def const_map_is_Some split: if_split_asm)
 
 lemma finite_vote_set_upd:
   " finite (vote_set v_hist {a}) \<Longrightarrow> 
     finite (vote_set (v_hist(r := v_f)) {a})"
   by(simp add: vote_set_upd)
 
 lemma vote_setD:
   "rv \<in> vote_set v_f {a} \<Longrightarrow> v_f (fst rv) a = Some (snd rv)"
   by(auto simp add: vote_set_def)
 
 lemma process_mru_new_votes:
   assumes
     "\<forall>r' \<ge> (r :: nat). v_hist r' = Map.empty"
   shows 
     "process_mru (v_hist(r := v_f)) = 
     (process_mru v_hist ++ (\<lambda>p. map_option (Pair r) (v_f p)))"
 proof(rule ext, rule option_expand')
   fix p
   show  
     "(process_mru (v_hist(r := v_f)) p = None) =
     ((process_mru v_hist ++ (\<lambda>p. map_option (Pair r) (v_f p))) p = None)" using assms
     by(force simp add: vote_set_def restrict_map_def  const_map_is_None process_mru_is_None)
 next
   fix p rv rv'
   assume eqs:
     "process_mru (v_hist(r := v_f)) p = Some rv"
     "(process_mru v_hist ++ (\<lambda>p. map_option (Pair r) (v_f p))) p = Some rv'"
   moreover have "v_hist (r) p = None" using assms(1)
     by(auto)
 
   ultimately show "rv = rv'"  using eqs assms 
     by(auto simp add: map_add_Some_iff const_map_is_Some const_map_is_None 
       process_mru_is_Some vote_set_upd dest!: vote_setD intro!: Max_by_eqI
       finite_vote_set[OF assms]
       intro: ccontr inj_on_fst_vote_set)
 qed
 
 
 end
diff --git a/thys/Digit_Expansions/Carries.thy b/thys/Digit_Expansions/Carries.thy
--- a/thys/Digit_Expansions/Carries.thy
+++ b/thys/Digit_Expansions/Carries.thy
@@ -1,321 +1,321 @@
 theory Carries
   imports Bits_Digits
 begin
 
 section \<open>Carries in base-b expansions\<close>
 
 text \<open>Some auxiliary lemmas\<close>
 lemma rev_induct[consumes 1, case_names base step]:
   fixes i k :: nat
   assumes le: "i \<le> k"
     and base: "P k"
     and step: "\<And>i. i \<le> k \<Longrightarrow> P i \<Longrightarrow> P (i - 1)"
   shows "P i"
 proof -
   have "\<And>i::nat. n = k-i \<Longrightarrow> i \<le> k \<Longrightarrow> P i" for n
   proof (induct n)
     case 0
     then have "i = k" by arith
     with base show "P i" by simp
   next
     case (Suc n)
     then have "n = (k - (i + 1))" by arith
     moreover have k: "i + 1 \<le> k" using Suc.prems by arith
     ultimately have "P (i + 1)" by (rule Suc.hyps)
     from step[OF k this] show ?case by simp
   qed
   with le show ?thesis by fast
 qed
 
 subsection \<open>Definition of carry received at position k\<close>
 text \<open>When adding two numbers m and n, the carry is \emph{introduced}
       at position 1 but is \emph{received} at position 2. The function below
       accounts for the latter case. 
 
 \begin{center} \begin{verbatim}
         k: 6 5 4 3 2 1 0
         c:         1
    - - - - - - - - - - - -
         m:   1 0 1 0 1 0
         n:           1 1
     ----------------------
     m + n: 0 1 0 1 1 0 0
 \end{verbatim} \end{center} \<close>
 
 definition bin_carry :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
   "bin_carry a b k = (a mod 2^k + b mod 2^k) div 2^k"
 
 text \<open>Carry in the subtraction of two natural numbers\<close>
 
 definition bin_narry :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
   "bin_narry a b k = (if b mod 2^k > a mod 2^k then 1 else 0)"
 
 text \<open>Equivalent definition\<close>
 definition bin_narry2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
   "bin_narry2 a b k = ((2^k + a mod 2^k - b mod 2^k) div 2^k + 1) mod 2"
 
 lemma bin_narry_equiv: "bin_narry a b c = bin_narry2 a b c"
   apply (auto simp add: bin_narry_def bin_narry2_def)
   subgoal by (smt add.commute div_less dvd_0_right even_Suc le_add_diff_inverse2 less_add_eq_less 
         mod_greater_zero_iff_not_dvd neq0_conv not_mod2_eq_Suc_0_eq_0 order_le_less zero_less_diff 
         zero_less_numeral zero_less_power)
   subgoal by (simp add: le_div_geq less_imp_diff_less)
   done
 
 subsection \<open>Properties of carries\<close>
 
 lemma div_sub:
   fixes a b c :: nat
   shows "(a - b) div c = (if(a mod c < b mod c) then a div c - b div c - 1 else  a div c - b div c)"
 proof-
   consider (alb) "a<b" | (ageb) "a\<ge>b" by linarith
   then show ?thesis
   proof cases
     case alb
     then show ?thesis using div_le_mono by auto
   next
     case ageb
     obtain a1 a2 where a1_def: "a1 = a div c" and a2_def: "a2 = a mod c" and a_def: "a=a1*c+a2" 
       using mod_div_decomp by blast
     obtain b1 b2 where b1_def: "b1 = b div c" and b2_def: "b2 = b mod c" and b_def: "b=b1*c+b2" 
       using mod_div_decomp by blast
     have a1geb1: "a1\<ge>b1" using ageb a1_def b1_def using div_le_mono by blast
     show ?thesis
     proof(cases "c=0")
       assume "c=0"
       then show ?thesis by simp
     next
       assume cneq0: "c \<noteq> 0"
       then show ?thesis
       proof(cases "a2 < b2")
         assume a2lb2: "a2 < b2"
         then show ?thesis 
         proof(cases "a1=b1")
           case True
           then show ?thesis using ageb a2lb2 a_def b_def by force 
         next
           assume "\<not>(a1=b1)"
           hence a1gb1: "a1>b1" using a1geb1 by auto
           have boundc: "a2+c-b2<c" using a2lb2 cneq0 by linarith
           have "a-b = (a1 - b1) * c + a2 - b2"
             using a_def b_def a1geb1 nat_diff_add_eq1[of b1 a1 c a2 b2] by auto
           also have "... = (a1 - b1-1+1) * c + a2 - b2"
             using a1gb1 Suc_diff_Suc[of b1 a1] by auto
           also have "... = (a1 - b1 - 1) * c + (a2 + c - b2)" 
             using div_eq_0_iff[of b2 c] mod_div_trivial[of b c] b2_def by force
           finally have "(a-b) div c = a1 - b1 - 1 + (a2 + c - b2) div c"
             using a_def b_def cneq0 by auto
           then show ?thesis 
             using boundc div_less by (simp add: a1_def a2_def b1_def b2_def)
         qed
       next
         assume a2geb2: "\<not> a2 < b2"
         then have "(a - b) div c = ((a1 - b1) * c + (a2 - b2)) div c" 
           using a1geb1 a_def b_def nat_diff_add_eq1 by auto
         then show ?thesis using a2geb2 div_add1_eq[of "(a1-b1)*c" "a2-b2" c]
           by(auto simp add: b2_def a2_def a1_def b1_def less_imp_diff_less)
       qed
     qed
   qed
 qed
 
 lemma dif_digit_formula:"a \<ge> b \<longrightarrow> (a - b)\<exclamdown>k = (a\<exclamdown>k + b\<exclamdown>k + bin_narry a b k) mod 2"
 proof -
   {
     presume asm: "a\<ge>b" "a mod 2 ^ k < b mod 2 ^ k"
     then have "Suc((a - b) div 2 ^ k) = a div 2 ^ k - b div 2 ^ k"
       by (smt Nat.add_diff_assoc One_nat_def Suc_pred add.commute diff_is_0_eq div_add_self1 
           div_le_mono div_sub mod_add_self1 nat_le_linear neq0_conv plus_1_eq_Suc power_not_zero 
           zero_neq_numeral) 
     then have "(a - b) div 2 ^ k mod 2 = Suc (a div 2 ^ k mod 2 + b div 2 ^ k mod 2) mod 2"
       by (smt diff_is_0_eq even_Suc even_diff_nat even_iff_mod_2_eq_zero le_less mod_add_eq 
           nat.simps(3) not_mod_2_eq_1_eq_0)
   }
   moreover
   {
     presume asm2: "\<not> a mod 2 ^ k < b mod 2 ^ k" "b \<le> a"
     then have "(a - b) div 2 ^ k mod 2 = (a div 2 ^ k mod 2 + b div 2 ^ k mod 2) mod 2"
       using div_sub[of b "2^k" a] div_le_mono even_add even_iff_mod_2_eq_zero 
         le_add_diff_inverse2[of "b div 2 ^ k" "a div 2 ^ k"] mod_mod_trivial[of _ 2] 
         not_less[of "a mod 2 ^ k" "b mod 2 ^ k"] not_mod_2_eq_1_eq_0 div_sub by smt
 
   }
 
   ultimately show ?thesis
     by (auto simp add: bin_narry_def nth_bit_def) 
 qed
 
 
 lemma dif_narry_formula: 
   "a\<ge>b \<longrightarrow> bin_narry a b (k + 1) = (if (a\<exclamdown>k < b\<exclamdown>k + bin_narry a b k) then 1 else 0)"
 proof -
   {
     presume a1: "a mod (2 * 2 ^ k) < b mod (2 * 2 ^ k)"
     presume a2: "\<not> a div 2 ^ k mod 2 < Suc (b div 2 ^ k mod 2)"
     have f3: "2 ^ k \<noteq> (0::nat)"
       by simp
     have f4: "a div 2 ^ k mod 2 = 1"
       using a2 by (meson le_less_trans mod2_eq_if mod_greater_zero_iff_not_dvd not_less 
           zero_less_Suc)
     then have "b mod (2 * 2 ^ k) = b mod 2 ^ k"
       using a2 by (metis (no_types) One_nat_def le_simps(3) mod_less_divisor mod_mult2_eq 
           mult.left_neutral neq0_conv not_less semiring_normalization_rules(7))
     then have "False"
       using f4 f3 a1 by (metis One_nat_def add.commute div_add_self1 div_le_mono less_imp_le 
           mod_div_trivial mod_mult2_eq mult.left_neutral not_less plus_1_eq_Suc 
           semiring_normalization_rules(7) zero_less_Suc)
   }
   moreover
   {
     presume a1: "\<not> a mod 2 ^ k < b mod 2 ^ k"
     presume a2: "a mod (2 * 2 ^ k) < b mod (2 * 2 ^ k)"
     presume a3: "\<not> a div 2 ^ k mod 2 < b div 2 ^ k mod 2"
     presume a4: "b \<le> a"
     have f6: "a mod 2 ^ Suc k < b mod 2 ^ Suc k"
     using a2 by simp
     obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where f7: "b + nn a b = a" using a4 le_add_diff_inverse by auto
     have "(a div 2 ^ k - b div 2 ^ k) div 2 = a div 2 ^ k div 2 - b div 2 ^ k div 2"
     using a3 div_sub by presburger
       then have f8: "(a - b) div 2 ^ Suc k = a div 2 ^ Suc k - b div 2 ^ Suc k"
         using a1 by (metis (no_types) div_mult2_eq div_sub power_Suc power_commutes)
       have f9: "\<forall>n na. Suc (na div n) = (n + na) div n \<or> 0 = n"
         by (metis (no_types) add_Suc_right add_cancel_left_right div_add_self1 lessI 
             less_Suc_eq_0_disj less_one zero_neq_one)
       then have "\<forall>n na nb. (na + nb - n) div na = Suc (nb div na) - n div na - 1 \<or>
          \<not> (na + nb) mod na < n mod na \<or> 0 = na" by (metis (no_types) div_sub)
       then have f10: "\<forall>n na nb. \<not> (nb::nat) mod na < n mod na \<or> nb div na - n div na 
           = (na + nb - n) div na \<or> 0 = na"
         by (metis (no_types) diff_Suc_Suc diff_commute diff_diff_left mod_add_self1 plus_1_eq_Suc)
       have "\<forall>n. Suc n \<noteq> n" by linarith
     then have "(0::nat) = 2 ^ Suc k"
       using f10 f9 f8 f7 f6 a4 by (metis add_diff_cancel_left' add_diff_assoc)
     then have "False"
       by simp
   }
 
   ultimately show ?thesis
-    using bin_narry_def apply (auto simp add: nth_bit_def)
-    subgoal by (smt add_0_left add_less_cancel_left divmod_digit_0(2) le_less_trans mod_less_divisor
+    apply (auto simp add: nth_bit_def not_less bin_narry_def)
+    subgoal by (smt add_0_left add_less_cancel_left Divides.divmod_digit_0(2) le_less_trans mod_less_divisor
         mod_mult2_eq mult_zero_right nat_neq_iff not_less not_mod2_eq_Suc_0_eq_0 
         semiring_normalization_rules(7) zero_less_numeral zero_less_power)
-    subgoal by (smt One_nat_def add.left_neutral divmod_digit_0(1) le_less_trans less_imp_le
+    subgoal by (smt One_nat_def add.left_neutral Divides.divmod_digit_0(1) le_less_trans less_imp_le
           mod_less_divisor mod_mult2_eq mod_mult_self1_is_0 mult_zero_right not_less
           not_mod2_eq_Suc_0_eq_0 not_one_le_zero semiring_normalization_rules(7) zero_less_numeral 
           zero_less_power)
     done
 qed
  
 lemma sum_digit_formula:"(a + b)\<exclamdown>k =(a\<exclamdown>k + b\<exclamdown>k + bin_carry a b k) mod 2"
   by (simp add: bin_carry_def nth_bit_def) (metis div_add1_eq mod_add_eq)
 
 lemma sum_carry_formula:"bin_carry a b (k + 1) =(a\<exclamdown>k + b\<exclamdown>k + bin_carry a b k) div 2"
   by (simp add: bin_carry_def nth_bit_def)
      (smt div_mult2_eq div_mult_self4 mod_mult2_eq power_not_zero semiring_normalization_rules(20)
           semiring_normalization_rules(34) semiring_normalization_rules(7) zero_neq_numeral)
 
 lemma bin_carry_bounded:
   shows "bin_carry a b k = bin_carry a b k mod 2"
 proof-
   have "a mod 2 ^ k <  2 ^k" by simp
   moreover have "b mod 2 ^ k < 2 ^ k" by simp
   ultimately have "(a mod 2 ^ k + b mod 2 ^ k) <  2 ^(Suc k)" by (simp add: mult_2 add_strict_mono)
   then have "(a mod 2 ^ k + b mod 2 ^ k) div 2^k  \<le> 1" using less_mult_imp_div_less by force
   then have "bin_carry a b k \<le> 1" using div_le_mono bin_carry_def by fastforce
   then show ?thesis by auto
 qed
 
 lemma carry_bounded: "bin_carry a b k \<le> 1"
   using bin_carry_bounded not_mod_2_eq_1_eq_0[of "bin_carry a b k"] by auto
 
 lemma no_carry:
   "(\<forall>r< n.((nth_bit a r) + (nth_bit b r) \<le> 1)) \<Longrightarrow>
           (nth_bit (a + b) n) = (nth_bit a n + nth_bit b n) mod 2"
   (is "?P \<Longrightarrow> ?Q n")
 proof (rule ccontr)
   assume p: "?P"
   assume nq: "\<not>?Q n"
   then obtain k where k1:"\<not>?Q k" and k2:"\<forall>r<k. ?Q r" by (auto dest: obtain_smallest)
 
   have c1: "1 = bin_carry a b k"
     using k1 sum_digit_formula bin_carry_bounded
     by auto (metis add.commute not_mod2_eq_Suc_0_eq_0 plus_nat.add_0)
 
   have "bin_carry a b (k-1) = 0" using sum_digit_formula
     by (metis bin_carry_bounded bin_carry_def diff_is_0_eq' diff_less div_by_1 even_add
               even_iff_mod_2_eq_zero k2 less_numeral_extra(1) mod_by_1 neq0_conv nth_bit_bounded
               power_0)
 
   moreover have "a \<exclamdown> (k-1) + b \<exclamdown> (k-1) < 1"
     by (smt add.right_neutral c1 calculation diff_le_self k2 leI le_add_diff_inverse2 le_less_trans
             mod_by_1 mod_if nat_less_le nq one_div_two_eq_zero one_neq_zero p sum_carry_formula)
 
   ultimately have "0 = bin_carry a b k" using k2 sum_carry_formula
     by auto (metis Suc_eq_plus1_left add_diff_inverse_nat less_imp_diff_less mod_0 mod_Suc
               mod_add_self1 mod_div_trivial mod_less n_not_Suc_n plus_nat.add_0)
 
   then show False using c1 by auto
 qed
 
 lemma no_carry_mult_equiv:"(\<forall>k. nth_bit a k * nth_bit b k = 0) \<longleftrightarrow> (\<forall>k. bin_carry a b k = 0)"
   (is "?P \<longleftrightarrow> ?Q")
 proof
   assume P: ?P 
   {
     fix k
     from P have "bin_carry a b k = 0"
     proof (induction k)
       case 0
       then show ?case using bin_carry_def by (simp)
     next
       case (Suc k)
       then show ?case using sum_carry_formula P
         by (metis One_nat_def Suc_eq_plus1 add.right_neutral div_less lessI
         mult_is_0 not_mod_2_eq_0_eq_1 nth_bit_def numeral_2_eq_2 zero_less_Suc)
     qed
   }
   then show ?Q by auto
 next
   assume Q: ?Q
   {
     fix k
     from Q have "a \<exclamdown> k * b \<exclamdown> k = 0"
     proof (induction k)
       case 0
       then show ?case using bin_carry_def nth_bit_def
         by simp (metis add_self_div_2 not_mod2_eq_Suc_0_eq_0 power_one_right)
     next
       case (Suc k)
       then show ?case
         using nth_bit_def  sum_carry_formula
         by simp (metis One_nat_def add.right_neutral add_self_div_2 not_mod_2_eq_1_eq_0 power_Suc)+
     qed
   }
   then show ?P by auto 
 qed
 
 
 (* NEW LEMMAS FROM DIGIT COMPARISON *)
 
 lemma carry_digit_impl: "bin_carry a b k \<noteq> 0 \<Longrightarrow> \<exists>r<k. a \<exclamdown> r + b \<exclamdown> r = 2"
 proof(rule ccontr)
   assume "\<not> (\<exists>r<k. a \<exclamdown> r + b \<exclamdown> r = 2)"
   hence bound: "\<forall>r<k. a \<exclamdown> r + b \<exclamdown> r \<le> 1" using nth_bit_def by auto
   assume bk:"bin_carry a b k \<noteq> 0"
   hence base: "bin_carry a b k = 1" using carry_bounded le_less[of "bin_carry a b k" 1] by auto
   have step: "i \<le> k \<Longrightarrow> bin_carry a b i = 1 \<Longrightarrow> bin_carry a b (i - 1) = 1" for i
     proof(rule ccontr)
       assume ik: "i \<le> k"
       assume carry: "bin_carry a b i = 1"
       assume "bin_carry a b (i- 1) \<noteq> 1"
       hence "bin_carry a b (i - 1) = 0" using bin_carry_bounded not_mod_2_eq_1_eq_0[of "bin_carry a b (i - 1)"] by auto
       then show False using ik carry bound sum_carry_formula[of a b "i-1"] 
         apply simp
         by (metis Suc_eq_plus1 Suc_pred add_lessD1 bot_nat_0.not_eq_extremum carry diff_is_0_eq' div_le_mono le_eq_less_or_eq less_add_one one_div_two_eq_zero)
     qed 
   have "\<forall>i\<le>k. bin_carry a b i = 1" using rev_induct[where ?P="\<lambda>c.(bin_carry a b c = 1)"] step base by blast
   moreover have "bin_carry a b 0 = 0" using bin_carry_def by simp
   ultimately show False by auto
 qed
 
 
 end
\ No newline at end of file
diff --git a/thys/Diophantine_Eqns_Lin_Hom/Linear_Diophantine_Equations.thy b/thys/Diophantine_Eqns_Lin_Hom/Linear_Diophantine_Equations.thy
--- a/thys/Diophantine_Eqns_Lin_Hom/Linear_Diophantine_Equations.thy
+++ b/thys/Diophantine_Eqns_Lin_Hom/Linear_Diophantine_Equations.thy
@@ -1,1162 +1,1161 @@
 (*
 Author:  Florian Messner <florian.g.messner@uibk.ac.at>
 Author:  Julian Parsert <julian.parsert@gmail.com>
 Author:  Jonas Schöpf <jonas.schoepf@uibk.ac.at>
 Author:  Christian Sternagel <c.sternagel@gmail.com>
 License: LGPL
 *)
 
 section \<open>Homogeneous Linear Diophantine Equations\<close>
 
 theory Linear_Diophantine_Equations
   imports List_Vector
 begin
 
 (*TODO: move*)
 lemma lcm_div_le:
   fixes a :: nat
   shows "lcm a b div b \<le> a"
   by (metis div_by_0 div_le_dividend div_le_mono div_mult_self_is_m lcm_nat_def neq0_conv)
 
 (*TODO: move*)
 lemma lcm_div_le':
   fixes a :: nat
   shows "lcm a b div a \<le> b"
   by (metis lcm.commute lcm_div_le)
 
 (*TODO: move*)
 lemma lcm_div_gt_0:
   fixes a :: nat
   assumes "a > 0" and "b > 0"
   shows "lcm a b div a > 0"
 proof -
   have "lcm a b = (a * b) div (gcd a b)"
     using lcm_nat_def by blast
   moreover have "\<dots> > 0"
     using  assms
     by (metis assms calculation lcm_pos_nat)
   ultimately show ?thesis
     using assms
-    by (metis div_by_0 div_mult2_eq div_positive gcd_le2_nat nat_mult_div_cancel_disj neq0_conv
-              semiring_normalization_rules(7))
+    by simp (metis div_greater_zero_iff div_le_mono2 div_mult_self_is_m gcd_le2_nat not_gr0)
 qed
 
 (*TODO: move*)
 lemma sum_list_list_update_Suc:
   assumes "i < length u"
   shows "sum_list (u[i := Suc (u ! i)]) = Suc (sum_list u)"
   using assms
 proof (induct u arbitrary: i)
   case (Cons x xs)
   then show ?case by (simp_all split: nat.splits)
 qed (simp)
 
 (*TODO: move*)
 lemma lessThan_conv:
   assumes "card A = n" and "\<forall>x\<in>A. x < n"
   shows "A = {..<n}"
   using assms by (simp add: card_subset_eq subsetI)
 
 text \<open>
   Given a non-empty list \<open>xs\<close> of \<open>n\<close> natural numbers,
   either there is a value in \<open>xs\<close> that is \<open>0\<close> modulo \<open>n\<close>,
   or there are two values whose moduli coincide.
 \<close>
 lemma list_mod_cases:
   assumes "length xs = n" and "n > 0"
   shows "(\<exists>x\<in>set xs. x mod n = 0) \<or>
     (\<exists>i<length xs. \<exists>j<length xs. i \<noteq> j \<and> (xs ! i) mod n = (xs ! j) mod n)"
 proof -
   let ?f = "\<lambda>x. x mod n" and ?X = "set xs"
   have *: "\<forall>x \<in> ?f ` ?X. x < n" using \<open>n > 0\<close> by auto
   consider (eq) "card (?f ` ?X) = card ?X" | (less) "card (?f ` ?X) < card ?X"
     using antisym_conv2 and card_image_le by blast
   then show ?thesis
   proof (cases)
     case eq
     show ?thesis
     proof (cases "distinct xs")
       assume "distinct xs"
       with eq have "card (?f ` ?X) = n"
         using \<open>distinct xs\<close> by (simp add: assms card_distinct distinct_card)
       from lessThan_conv [OF this *] and \<open>n > 0\<close>
       have "\<exists>x\<in>set xs. x mod n = 0" by (metis imageE lessThan_iff)
       then show ?thesis ..
     next
       assume "\<not> distinct xs"
       then show ?thesis by (auto) (metis distinct_conv_nth)
     qed
   next
     case less
     from pigeonhole [OF this]
     show ?thesis by (auto simp: inj_on_def iff: in_set_conv_nth)
   qed
 qed
 
 text \<open>
   Homogeneous linear Diophantine equations:
   \<open>a\<^sub>1x\<^sub>1 + \<cdots> + a\<^sub>mx\<^sub>m = b\<^sub>1y\<^sub>1 + \<cdots> + b\<^sub>ny\<^sub>n\<close>
 \<close>
 locale hlde_ops =
   fixes a b :: "nat list"
 begin
 
 abbreviation "m \<equiv> length a"
 abbreviation "n \<equiv> length b"
 
 \<comment> \<open>The set of all solutions.\<close>
 definition Solutions :: "(nat list \<times> nat list) set"
   where
     "Solutions = {(x, y). a \<bullet> x = b \<bullet> y \<and> length x = m \<and> length y = n}"
 
 lemma in_Solutions_iff:
   "(x, y) \<in> Solutions \<longleftrightarrow> length x = m \<and> length y = n \<and> a \<bullet> x = b \<bullet> y"
   by (auto simp: Solutions_def)
 
 \<comment> \<open>The set of pointwise minimal solutions.\<close>
 definition Minimal_Solutions :: "(nat list \<times> nat list) set"
   where
     "Minimal_Solutions = {(x, y) \<in> Solutions. nonzero x \<and>
       \<not> (\<exists>(u, v) \<in> Solutions. nonzero u \<and> u @ v <\<^sub>v x @ y)}"
 
 definition dij :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "dij i j = lcm (a ! i) (b ! j) div (a ! i)"
 
 definition eij :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "eij i j = lcm (a ! i) (b ! j) div (b ! j)"
 
 definition sij :: "nat \<Rightarrow> nat \<Rightarrow> (nat list \<times> nat list)"
   where
     "sij i j = ((zeroes m)[i := dij i j], (zeroes n)[j := eij i j])"
 
 
 subsection \<open>Further Constraints on Minimal Solutions\<close>
 
 definition Ej :: "nat \<Rightarrow> nat list \<Rightarrow> nat set"
   where
     "Ej j x = { eij i j - 1 | i. i < length x \<and> x ! i \<ge> dij i j }"
 
 definition Di :: "nat \<Rightarrow> nat list \<Rightarrow> nat set"
   where
     "Di i y = { dij i j - 1 | j. j < length y \<and> y ! j \<ge> eij i j }"
 
 definition Di' :: "nat \<Rightarrow> nat list \<Rightarrow> nat set"
   where
     "Di' i y = { dij i (j + length b - length y) - 1 | j. j < length y \<and> y ! j \<ge> eij i (j + length b - length y) }"
 
 lemma Ej_take_subset:
   "Ej j (take k x) \<subseteq> Ej j x"
   by (auto simp: Ej_def)
 
 lemma Di_take_subset:
   "Di i (take l y) \<subseteq> Di i y"
   by (auto simp: Di_def)
 
 lemma Di'_drop_subset:
   "Di' i (drop l y) \<subseteq> Di' i y"
   by (auto simp: Di'_def) (metis add.assoc add.commute less_diff_conv)
 
 lemma finite_Ej:
   "finite (Ej j x)"
   by (rule finite_subset [of _ "(\<lambda>i. eij i j - 1) ` {0 ..< length x}"]) (auto simp: Ej_def)
 
 lemma finite_Di:
   "finite (Di i y)"
   by (rule finite_subset [of _ "(\<lambda>j. dij i j - 1) ` {0 ..< length y}"]) (auto simp: Di_def)
 
 lemma finite_Di':
   "finite (Di' i y)"
   by (rule finite_subset [of _ "(\<lambda>j. dij i (j + length b - length y) - 1) ` {0 ..< length y}"])
     (auto simp: Di'_def)
 
 definition max_y :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "max_y x j = (if j < n \<and> Ej j x \<noteq> {} then Min (Ej j x) else Max (set a))"
 
 definition max_x :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "max_x y i = (if i < m \<and> Di i y \<noteq> {} then Min (Di i y) else Max (set b))"
 
 definition max_x' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "max_x' y i = (if i < m \<and> Di' i y \<noteq> {} then Min (Di' i y) else Max (set b))"
 
 lemma Min_Ej_le:
   assumes "j < n"
     and "e \<in> Ej j x"
     and "length x \<le> m"
   shows "Min (Ej j x) \<le> Max (set a)" (is "?m \<le> _")
 proof -
   have "?m \<in> Ej j x"
     using assms and finite_Ej and Min_in by blast
   then obtain i where
     i: "?m = eij i j - 1" "i < length x" "x ! i \<ge> dij i j"
     by (auto simp: Ej_def)
   have "lcm (a ! i) (b ! j) div b ! j \<le> a ! i" by (rule lcm_div_le)
   then show ?thesis
     using i and assms
     by (auto simp: eij_def)
       (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
 qed
 
 lemma Min_Di_le:
   assumes "i < m"
     and "e \<in> Di i y"
     and "length y \<le> n"
   shows "Min (Di i y) \<le> Max (set b)" (is "?m \<le> _")
 proof -
   have "?m \<in> Di i y"
     using assms and finite_Di and Min_in by blast
   then obtain j where
     j: "?m = dij i j - 1" "j < length y" "y ! j \<ge> eij i j"
     by (auto simp: Di_def)
   have "lcm (a ! i) (b ! j) div a ! i \<le> b ! j" by (rule lcm_div_le')
   then show ?thesis
     using j and assms
     by (auto simp: dij_def)
       (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
 qed
 
 lemma Min_Di'_le:
   assumes "i < m"
     and "e \<in> Di' i y"
     and "length y \<le> n"
   shows "Min (Di' i y) \<le> Max (set b)" (is "?m \<le> _")
 proof -
   have "?m \<in> Di' i y"
     using assms and finite_Di' and Min_in by blast
   then obtain j where
     j: "?m = dij i (j + length b - length y) - 1" "j < length y" "y ! j \<ge> eij i (j + length b - length y)"
     by (auto simp: Di'_def)
   then have "j + length b - length y < length b" using assms by auto
   moreover
   have "lcm (a ! i) (b ! (j + length b - length y)) div a ! i \<le> b ! (j + length b - length y)" by (rule lcm_div_le')
   ultimately show ?thesis
     using j and assms
     by (auto simp: dij_def)
       (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
 qed
 
 lemma max_y_le_take:
   assumes "length x \<le> m"
   shows "max_y x j \<le> max_y (take k x) j"
   using assms and Min_Ej_le and Ej_take_subset and Min.subset_imp [OF _ _ finite_Ej]
   by (auto simp: max_y_def) blast
 
 lemma max_x_le_take:
   assumes "length y \<le> n"
   shows "max_x y i \<le> max_x (take l y) i"
   using assms and Min_Di_le and Di_take_subset and Min.subset_imp [OF _ _ finite_Di]
   by (auto simp: max_x_def) blast
 
 lemma max_x'_le_drop:
   assumes "length y \<le> n"
   shows "max_x' y i \<le> max_x' (drop l y) i"
   using assms and Min_Di'_le and Di'_drop_subset and Min.subset_imp [OF _ _ finite_Di']
   by (auto simp: max_x'_def) blast
 
 end
 
 abbreviation "Solutions \<equiv> hlde_ops.Solutions"
 abbreviation "Minimal_Solutions \<equiv> hlde_ops.Minimal_Solutions"
 
 abbreviation "dij \<equiv> hlde_ops.dij"
 abbreviation "eij \<equiv> hlde_ops.eij"
 abbreviation "sij \<equiv> hlde_ops.sij"
 
 declare hlde_ops.dij_def [code]
 declare hlde_ops.eij_def [code]
 declare hlde_ops.sij_def [code]
 
 lemma Solutions_sym: "(x, y) \<in> Solutions a b \<longleftrightarrow> (y, x) \<in> Solutions b a"
   by (auto simp: hlde_ops.in_Solutions_iff)
 
 lemma Minimal_Solutions_imp_Solutions: "(x, y) \<in> Minimal_Solutions a b \<Longrightarrow> (x, y) \<in> Solutions a b"
   by (auto simp: hlde_ops.Minimal_Solutions_def)
 
 lemma Minimal_SolutionsI:
   assumes "(x, y) \<in> Solutions a b"
     and "nonzero x"
     and "\<not> (\<exists>(u, v) \<in> Solutions a b. nonzero u \<and> u @ v <\<^sub>v x @ y)"
   shows "(x, y) \<in> Minimal_Solutions a b"
   using assms by (auto simp: hlde_ops.Minimal_Solutions_def)
 
 lemma minimize_nonzero_solution:
   assumes "(x, y) \<in> Solutions a b" and "nonzero x"
   obtains u and v where "u @ v \<le>\<^sub>v x @ y" and "(u, v) \<in> Minimal_Solutions a b"
   using assms
 proof (induct "x @ y" arbitrary: x y thesis rule: wf_induct [OF wf_less])
   case 1
   then show ?case
   proof (cases "(x, y) \<in> Minimal_Solutions a b")
     case False
     then obtain u and v where "nonzero u" and "(u, v) \<in> Solutions a b" and uv: "u @ v <\<^sub>v x @ y"
       using 1(3,4) by (auto simp: hlde_ops.Minimal_Solutions_def)
     with 1(1) [rule_format, of "u @ v" u v] obtain u' and v' where uv': "u' @ v' \<le>\<^sub>v u @ v"
       and "(u', v') \<in> Minimal_Solutions a b" by blast
     moreover have "u' @ v' \<le>\<^sub>v x @ y" using uv and uv' by auto
     ultimately show ?thesis by (intro 1(2))
   qed blast
 qed
 
 lemma Minimal_SolutionsI':
   assumes "(x, y) \<in> Solutions a b"
     and "nonzero x"
     and "\<not> (\<exists>(u, v) \<in> Minimal_Solutions a b. u @ v <\<^sub>v x @ y)"
   shows "(x, y) \<in> Minimal_Solutions a b"
 proof (rule Minimal_SolutionsI [OF assms(1,2)])
   show "\<not> (\<exists>(u, v) \<in> Solutions a b. nonzero u \<and> u @ v <\<^sub>v x @ y)"
   proof
     assume "\<exists>(u, v) \<in> Solutions a b. nonzero u \<and> u @ v <\<^sub>v x @ y"
     then obtain u and v where "(u, v) \<in> Solutions a b" and "nonzero u"
       and uv: "u @ v <\<^sub>v x @ y" by blast
     then obtain u' and v' where "(u', v') \<in> Minimal_Solutions a b"
       and uv': "u' @ v' \<le>\<^sub>v u @ v" by (blast elim: minimize_nonzero_solution)
     moreover have "u' @ v' <\<^sub>v x @ y" using uv and uv' by auto
     ultimately show False using assms by blast
   qed
 qed
 
 lemma Minimal_Solutions_length:
   "(x, y) \<in> Minimal_Solutions a b \<Longrightarrow> length x = length a \<and> length y = length b"
   by (auto simp: hlde_ops.Minimal_Solutions_def hlde_ops.in_Solutions_iff)
 
 lemma Minimal_Solutions_gt0:
   "(x, y) \<in> Minimal_Solutions a b \<Longrightarrow> zeroes (length x) <\<^sub>v x"
   using zero_less by (auto simp: hlde_ops.Minimal_Solutions_def)
 
 lemma Minimal_Solutions_sym:
   assumes "0 \<notin> set a" and "0 \<notin> set b"
   shows "(xs, ys) \<in> Minimal_Solutions a b \<longrightarrow> (ys, xs) \<in> Minimal_Solutions b a"
   using assms
   by (auto simp: hlde_ops.Minimal_Solutions_def hlde_ops.Solutions_def
            dest: dotprod_eq_nonzero_iff dest!: less_append_swap [of _ _ ys xs])
 
 locale hlde = hlde_ops +
   assumes no0: "0 \<notin> set a" "0 \<notin> set b"
 begin
 
 lemma nonzero_Solutions_iff:
   assumes "(x, y) \<in> Solutions"
   shows "nonzero x \<longleftrightarrow> nonzero y"
   using assms and no0 by (auto simp: in_Solutions_iff dest: dotprod_eq_nonzero_iff)
 
 lemma Minimal_Solutions_min:
   assumes "(x, y) \<in> Minimal_Solutions"
     and "u @ v <\<^sub>v x @ y"
     and "a \<bullet> u = b \<bullet> v"
     and [simp]: "length u = m"
     and non0: "nonzero (u @ v)"
   shows False
 proof -
   have [simp]: "length v = n" using assms by (force dest: less_appendD Minimal_Solutions_length)
   have "(u, v) \<in> Solutions" using \<open>a \<bullet> u = b \<bullet> v\<close> by (simp add: in_Solutions_iff)
   moreover from nonzero_Solutions_iff [OF this] have "nonzero u" using non0 by auto
   ultimately show False using assms by (auto simp: hlde_ops.Minimal_Solutions_def)
 qed
 
 lemma Solutions_snd_not_0:
   assumes "(x, y) \<in> Solutions"
     and "nonzero x"
   shows "nonzero y"
   using assms by (metis nonzero_Solutions_iff)
 
 end
 
 subsection \<open>Pointwise Restricting Solutions\<close>
 
 text \<open>
   Constructing the list of \<open>u\<close> vectors from Huet's proof @{cite "Huet1978"}, satisfying
   \<^item> \<open>\<forall>i<length u. u ! i \<le> y ! i\<close> and
   \<^item> \<open>0 < sum_list u \<le> a\<^sub>k\<close>.
 \<close>
 
 text \<open>
   Given \<open>y\<close>, increment a "previous" \<open>u\<close> vector at first position
   starting from \<open>i\<close> where \<open>u\<close> is strictly smaller than \<open>y\<close>. If this
   is not possible, return \<open>u\<close> unchanged.
 \<close>
 function inc :: "nat list \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list"
   where
     "inc y i u =
       (if i < length y then
         if u ! i < y ! i then u[i := u ! i + 1]
         else inc y (Suc i) u
       else u)"
   by (pat_completeness) auto
 termination inc
   by (relation "measure (\<lambda>(y, i, u). max (length y) (length u) - i)") auto
 (*inc.simps may cause simplification to loop*)
 declare inc.simps [simp del]
 
 text \<open>
   Starting from the 0-vector produce \<open>u\<close>s by iteratively
   incrementing with respect to \<open>y\<close>.
 \<close>
 definition huets_us :: "nat list \<Rightarrow> nat \<Rightarrow> nat list" ("\<^bold>u" 1000)
   where
     "\<^bold>u y i = ((inc y 0) ^^ Suc i) (zeroes (length y))"
 
 lemma huets_us_simps [simp]:
   "\<^bold>u y 0 = inc y 0 (zeroes (length y))"
   "\<^bold>u y (Suc i) = inc y 0 (\<^bold>u y i)"
   by (auto simp: huets_us_def)
 
 lemma length_inc [simp]: "length (inc y i u) = length u"
   by (induct y i u rule: inc.induct) (simp add: inc.simps)
 
 lemma length_us [simp]:
   "length (\<^bold>u y i) = length y"
   by (induct i) (simp_all)
 
 text \<open>
   \<open>inc\<close> produces vectors that are pointwise smaller than \<open>y\<close>
 \<close>
 lemma inc_le:
   assumes "length u = length y" and "i < length y" and "u \<le>\<^sub>v y"
   shows "inc y i u \<le>\<^sub>v y"
   using assms by (induct y i u rule: inc.induct)
     (auto simp: inc.simps nth_list_update less_eq_def)
 
 lemma us_le:
   assumes "length y > 0"
   shows "\<^bold>u y i \<le>\<^sub>v y"
   using assms by (induct i) (auto simp: inc_le le_length)
 
 lemma sum_list_inc_le:
   "u \<le>\<^sub>v y \<Longrightarrow> sum_list (inc y i u) \<le> sum_list y"
   by (induct y i u rule: inc.induct)
     (auto simp: inc.simps intro: le_sum_list_mono)
 
 lemma sum_list_inc_gt0:
   assumes "sum_list u > 0" and "length y = length u"
   shows "sum_list (inc y i u) > 0"
   using assms
 proof (induct y i u rule: inc.induct)
   case (1 y i u)
   then show ?case
     by (auto simp add: inc.simps)
       (meson Suc_neq_Zero gr_zeroI set_update_memI sum_list_eq_0_iff)
 qed
 
 lemma sum_list_inc_gt0':
   assumes "length u = length y" and "i < length y" and "y ! i > 0" and "j \<le> i"
   shows "sum_list (inc y j u) > 0"
   using assms
 proof (induct y j u rule: inc.induct)
   case (1 y i u)
   then show ?case
     by (auto simp: inc.simps [of y i] sum_list_update)
       (metis elem_le_sum_list le_antisym le_zero_eq neq0_conv not_less_eq_eq sum_list_inc_gt0)
 qed
 
 lemma sum_list_us_gt0:
   assumes "sum_list y \<noteq> 0"
   shows "0 < sum_list (\<^bold>u y i)"
   using assms by (induct i) (auto simp: in_set_conv_nth sum_list_inc_gt0' sum_list_inc_gt0)
 
 lemma sum_list_inc_le':
   assumes "length u = length y"
   shows "sum_list (inc y i u) \<le> sum_list u + 1"
   using assms
   by (induct y i u rule: inc.induct) (auto simp: inc.simps sum_list_update)
 
 lemma sum_list_us_le:
   "sum_list (\<^bold>u y i) \<le> i + 1"
 proof (induct i)
   case 0
   then show ?case
     by (auto simp: sum_list_update)
       (metis Suc_eq_plus1 in_set_replicate length_replicate sum_list_eq_0_iff sum_list_inc_le')
 next
   case (Suc i)
   then show ?case
     by auto (metis Suc_le_mono add.commute le_trans length_us plus_1_eq_Suc sum_list_inc_le')
 qed
 
 lemma sum_list_us_bounded:
   assumes "i < k"
   shows "sum_list (\<^bold>u y i) \<le> k"
   using assms and sum_list_us_le [of y i] by force
 
 lemma sum_list_inc_eq_sum_list_Suc:
   assumes "length u = length y" and "i < length y"
     and "\<exists>j\<ge>i. j < length y \<and> u ! j < y ! j"
   shows "sum_list (inc y i u) = Suc (sum_list u)"
   using assms
   by (induct y i u rule: inc.induct)
     (metis  inc.simps Suc_eq_plus1 Suc_leI antisym_conv2 leD sum_list_list_update_Suc)
 
 lemma sum_list_us_eq:
   assumes "i < sum_list y"
   shows "sum_list (\<^bold>u y i) = i + 1"
   using assms
 proof (induct i)
   case (Suc i)
   then show ?case
     by (auto)
       (metis (no_types, lifting) Suc_eq_plus1 gr_implies_not0 length_pos_if_in_set
        length_us less_Suc_eq_le less_imp_le_nat antisym_conv2 not_less_eq_eq
        sum_list_eq_0_iff sum_list_inc_eq_sum_list_Suc sum_list_less_diff_Ex us_le)
 qed (metis Suc_eq_plus1 Suc_leI antisym_conv gr_implies_not0 sum_list_us_gt0 sum_list_us_le)
 
 lemma inc_ge: "length u = length y \<Longrightarrow> u \<le>\<^sub>v inc y i u"
   by (induct y i u rule: inc.induct) (auto simp: inc.simps nth_list_update less_eq_def)
 
 lemma us_le_mono:
   assumes "i < j"
   shows "\<^bold>u y i \<le>\<^sub>v \<^bold>u y j"
   using assms
 proof (induct "j - i" arbitrary: j i)
   case (Suc n)
   then show ?case
     by (simp add: Suc.prems inc_ge order.strict_implies_order order_vec.lift_Suc_mono_le)
 qed simp
 
 lemma us_mono:
   assumes "i < j" and "j < sum_list y"
   shows "\<^bold>u y i <\<^sub>v \<^bold>u y j"
 proof -
   let ?u = "\<^bold>u y i" and ?v = "\<^bold>u y j"
   have "?u \<le>\<^sub>v ?v"
     using us_le_mono [OF \<open>i < j\<close>] by simp
   moreover have "sum_list ?u < sum_list ?v"
     using assms by (auto simp: sum_list_us_eq)
   ultimately show ?thesis by (intro le_sum_list_less) (auto simp: less_eq_def)
 qed
 
 context hlde
 begin
 
 lemma max_coeff_bound_right:
   assumes "(xs, ys) \<in> Minimal_Solutions"
   shows "\<forall>x \<in> set xs. x \<le> maxne0 ys b" (is "\<forall>x\<in>set xs. x \<le> ?m")
 proof (rule ccontr)
   assume "\<not> ?thesis"
   then obtain k
     where k_def: "k < length xs \<and> \<not> (xs ! k \<le> ?m)"
     by (metis in_set_conv_nth)
   have sol: "(xs, ys) \<in> Solutions"
     using assms Minimal_Solutions_def by auto
   then have len: "m = length xs" by (simp add: in_Solutions_iff)
   have max_suml: "?m * sum_list ys \<ge> b \<bullet> ys"
     using maxne0_times_sum_list_gt_dotprod sol by (auto simp: in_Solutions_iff)
   then have is_sol: "b \<bullet> ys = a \<bullet> xs"
     using sol by (auto simp: in_Solutions_iff)
   then have a_ge_ak: "a \<bullet> xs \<ge> a ! k * xs ! k"
     using dotprod_pointwise_le k_def len by auto
   then have ak_gt_max: "a ! k * xs ! k > a ! k * ?m"
     using no0 in_set_conv_nth k_def len by fastforce
   then have sl_ys_g_ak: "sum_list ys > a ! k"
     by (metis a_ge_ak is_sol less_le_trans max_suml
         mult.commute mult_le_mono1 not_le)
   define Seq where
     Seq_def: "Seq = map (\<^bold>u ys) [0 ..< a ! k]"
   have ak_n0: "a ! k \<noteq> 0"
     using \<open>a ! k * ?m < a ! k * xs ! k\<close> by auto
   have "zeroes (length ys) <\<^sub>v ys"
     by (intro zero_less) (metis gr_implies_not0 nonzero_iff sl_ys_g_ak sum_list_eq_0_iff)
   then have "length Seq > 0"
     using ak_n0 Seq_def by auto
   have u_in_nton: "\<forall>u \<in> set Seq. length u = length ys"
     by (simp add: Seq_def)
   have prop_3: "\<forall>u \<in> set Seq. u \<le>\<^sub>v ys"
   proof -
     have "length ys > 0"
       using sl_ys_g_ak by auto
     then show ?thesis
       using us_le [of ys ] less_eq_def Seq_def by (simp)
   qed
   have prop_4_1: "\<forall>u \<in> set Seq. sum_list u > 0"
     by (metis Seq_def sl_ys_g_ak gr_implies_not_zero imageE
         set_map sum_list_us_gt0)
   have prop_4_2: "\<forall>u \<in> set Seq. sum_list u \<le> a ! k"
     by (simp add: Seq_def sum_list_us_bounded)
   have prop_5: "\<exists>u. length u = length ys \<and> u \<le>\<^sub>v ys \<and> sum_list u > 0 \<and> sum_list u \<le> a ! k"
     using \<open>0 < length Seq\<close> nth_mem prop_3 prop_4_1 prop_4_2 u_in_nton by blast
   define Us where
     "Us = {u. length u = length ys \<and> u \<le>\<^sub>v ys \<and> sum_list u > 0 \<and> sum_list u \<le> a ! k}"
   have "\<exists>u \<in> Us. b \<bullet> u mod a ! k = 0"
   proof (rule ccontr)
     assume neg_th: "\<not> ?thesis"
     define Seq_p where
       "Seq_p = map (dotprod b) Seq"
     have "length Seq = a ! k"
       by (simp add: Seq_def)
     then consider (eq_0)  "(\<exists>x\<in>set Seq_p. x mod (a ! k) = 0)" |
       (not_0) "(\<exists>i<length Seq_p. \<exists>j<length Seq_p. i \<noteq> j \<and>
                (Seq_p ! i) mod (a!k) = (Seq_p ! j) mod (a!k))"
       using list_mod_cases[of Seq_p] Seq_p_def ak_n0 by auto force
     then show False
     proof (cases)
       case eq_0
       have "\<exists>u \<in> set Seq. b \<bullet> u mod a ! k = 0"
         using Seq_p_def eq_0 by auto
       then show False
         by (metis (mono_tags, lifting) Us_def mem_Collect_eq
             neg_th prop_3 prop_4_1 prop_4_2 u_in_nton)
     next
       case not_0
       obtain i and j where
         i_j: "i<length Seq_p" "j<length Seq_p" " i \<noteq> j"
         " Seq_p ! i mod a ! k = Seq_p ! j mod a ! k"
         using not_0 by blast
       define v where
         v_def: "v = Seq!i"
       define w where
         w_def: "w = Seq!j"
       have mod_eq: "b \<bullet> v mod a!k = b \<bullet> w mod a!k"
         using Seq_p_def i_j w_def v_def i_j  by auto
       have "v <\<^sub>v w \<or> w <\<^sub>v v"
         using \<open>i \<noteq> j\<close> and i_j
       proof (cases "i < j")
         case True
         then show ?thesis
           using Seq_p_def sl_ys_g_ak i_j(2) local.Seq_def us_mono v_def w_def by auto
       next
         case False
         then show ?thesis
           using Seq_p_def sl_ys_g_ak \<open>i \<noteq> j\<close> i_j(1) local.Seq_def us_mono v_def w_def by auto
       qed
       then show False
       proof
         assume ass: "v <\<^sub>v w"
         define u where
           u_def: "u = w -\<^sub>v v"
         have "w \<le>\<^sub>v ys"
           using Seq_p_def w_def i_j(2) prop_3 by force
         then have prop_3: "less_eq u ys"
           using vdiff_le ass less_eq_def order_vec.less_imp_le u_def by auto
         have prop_4_1: "sum_list u > 0"
           using le_sum_list_mono [of v w] ass u_def sum_list_vdiff_distr [of v w]
           by (simp add: less_vec_sum_list_less)
         have prop_4_2: "sum_list u \<le> a ! k"
         proof -
           have "u \<le>\<^sub>v w" using u_def
             using ass less_eq_def order_vec.less_imp_le vdiff_le by auto
           then show ?thesis
             by (metis Seq_p_def i_j(2) length_map le_sum_list_mono
                 less_le_trans not_le nth_mem prop_4_2 w_def)
         qed
         have "b \<bullet> u mod a ! k = 0"
           by (metis (mono_tags, lifting) in_Solutions_iff \<open>w \<le>\<^sub>v ys\<close> u_def ass no0(2)
               less_eq_def mem_Collect_eq mod_eq mods_with_vec_2 prod.simps(2) sol)
         then show False using neg_th
           by (metis (mono_tags, lifting) Us_def less_eq_def mem_Collect_eq
               prop_3 prop_4_1 prop_4_2)
       next
         assume ass: "w <\<^sub>v v"
         define u where
           u_def: "u = v -\<^sub>v w"
         have "v \<le>\<^sub>v ys"
           using Seq_p_def v_def i_j(1) prop_3 by force
         then have prop_3: "u \<le>\<^sub>v ys"
           using vdiff_le ass less_eq_def order_vec.less_imp_le u_def by auto
         have prop_4_1: "sum_list u > 0"
           using le_sum_list_mono [of w v] sum_list_vdiff_distr [of w v]
             \<open>u \<equiv> v -\<^sub>v w\<close> ass less_vec_sum_list_less by auto
         have prop_4_2: "sum_list u \<le> a!k"
         proof -
           have "u \<le>\<^sub>v v" using u_def
             using ass less_eq_def order_vec.less_imp_le vdiff_le by auto
           then show ?thesis
             by (metis Seq_p_def i_j(1) le_neq_implies_less length_map less_imp_le_nat
                 less_le_trans nth_mem prop_4_2 le_sum_list_mono v_def)
         qed
         have "b \<bullet> u mod a ! k = 0"
           by (metis (mono_tags, lifting) in_Solutions_iff \<open>v \<le>\<^sub>v ys\<close> u_def ass no0(2)
               less_eq_def mem_Collect_eq mod_eq mods_with_vec_2 prod.simps(2) sol)
         then show False
           by (metis (mono_tags, lifting) neg_th Us_def less_eq_def mem_Collect_eq prop_3 prop_4_1 prop_4_2)
       qed
     qed
   qed
   then obtain u where
     u3_4: "u \<le>\<^sub>v ys" "sum_list u > 0" "sum_list u \<le> a ! k" " b \<bullet> u mod (a ! k) = 0"
     "length u = length ys"
     unfolding Us_def by auto
   have u_b_len: "length u = n"
     using  less_eq_def u3_4 in_Solutions_iff sol by simp
   have "b \<bullet> u \<le> maxne0 u b * sum_list u"
     by (simp add: maxne0_times_sum_list_gt_dotprod u_b_len)
   also have "... \<le> ?m * a ! k"
     by (intro mult_le_mono) (simp_all add: u3_4 maxne0_mono)
   also have "... < a ! k * xs ! k"
     using ak_gt_max by auto
   then obtain zk where
     zk: "b \<bullet> u = zk * a ! k"
     using u3_4(4) by auto
   have "length xs > k"
     by (simp add: k_def)
   have "zk \<noteq> 0"
   proof -
     have "\<exists>e \<in> set u. e \<noteq> 0"
       using u3_4
       by (metis neq0_conv sum_list_eq_0_iff)
     then have "b \<bullet> u > 0"
       using assms no0 u3_4
       unfolding dotprod_gt0_iff[OF u_b_len [symmetric]]
       by (fastforce simp add: in_set_conv_nth u_b_len)
     then have "a ! k > 0"
       using \<open>a ! k \<noteq> 0\<close> by blast
     then show ?thesis
       using \<open>0 < b \<bullet> u\<close> zk by auto
   qed
   define z where
     z_def: "z = (zeroes (length xs))[k := zk]"
   then have zk_zk: "z ! k = zk"
     by (auto simp add: \<open>k < length xs\<close>)
   have "length z = length xs"
     using assms z_def \<open>k < length xs\<close> by auto
   then have bu_eq_akzk: "b \<bullet> u = a ! k * z ! k"
     by (simp add: \<open>b \<bullet> u = zk * a ! k\<close> zk_zk)
   then have "z!k < xs!k"
     using ak_gt_max  calculation by auto
   then have z_less_xs: "z <\<^sub>v xs"
     by (auto simp add: z_def) (metis \<open>k < length xs\<close> le0 le_list_update less_def
         less_imp_le order_vec.dual_order.antisym nat_neq_iff z_def zk_zk)
   then have "z @ u <\<^sub>v xs @ ys"
     by (intro less_append) (auto simp add: u3_4(1) z_less_xs)
   moreover have "(z, u) \<in> Solutions"
     by (auto simp add: bu_eq_akzk in_Solutions_iff z_def u_b_len \<open>k < length xs\<close> len)
   moreover have "nonzero z"
     using \<open>length z = length xs\<close> and \<open>zk \<noteq> 0\<close> and k_def and zk_zk by (auto simp: nonzero_iff)
   ultimately show False using assms by (auto simp: Minimal_Solutions_def)
 qed
 
 text \<open>Proof of Lemma 1 of Huet's paper.\<close>
 lemma max_coeff_bound:
   assumes "(xs, ys) \<in> Minimal_Solutions"
   shows "(\<forall>x \<in> set xs. x \<le> maxne0 ys b) \<and> (\<forall>y \<in> set ys. y \<le> maxne0 xs a)"
 proof -
   interpret ba: hlde b a by (standard) (auto simp: no0)
   show ?thesis
     using assms and Minimal_Solutions_sym [OF no0, of xs ys]
     by (auto simp: max_coeff_bound_right ba.max_coeff_bound_right)
 qed
 
 lemma max_coeff_bound':
   assumes "(x, y) \<in> Minimal_Solutions"
   shows "\<forall>i<length x. x ! i \<le> Max (set b)" and "\<forall>j<length y. y ! j \<le> Max (set a)"
   using max_coeff_bound [OF assms] and maxne0_le_Max
   by auto (metis le_eq_less_or_eq less_le_trans nth_mem)+
 
 lemma Minimal_Solutions_alt_def:
   "Minimal_Solutions = {(x, y)\<in>Solutions.
     (x, y) \<noteq> (zeroes m, zeroes n) \<and>
     x \<le>\<^sub>v replicate m (Max (set b)) \<and>
     y \<le>\<^sub>v replicate n (Max (set a)) \<and>
     \<not> (\<exists>(u, v)\<in>Solutions. nonzero u \<and> u @ v <\<^sub>v x @ y)}"
   by (auto simp: not_nonzero_iff Minimal_Solutions_imp_Solutions less_eq_def Minimal_Solutions_length max_coeff_bound'
     intro!: Minimal_SolutionsI' dest: Minimal_Solutions_gt0)
     (auto simp: Minimal_Solutions_def nonzero_Solutions_iff not_nonzero_iff)
 
 
 subsection \<open>Special Solutions\<close>
 
 definition Special_Solutions :: "(nat list \<times> nat list) set"
   where
     "Special_Solutions = {sij i j | i j. i < m \<and> j < n}"
 
 lemma dij_neq_0:
   assumes "i < m"
     and "j < n"
   shows "dij i j \<noteq> 0"
 proof -
   have "a ! i > 0" and "b ! j > 0"
     using assms and no0 by (simp_all add: in_set_conv_nth)
   then have "dij i j > 0"
     using lcm_div_gt_0 [of "a ! i" "b ! j"] by (simp add: dij_def)
   then show ?thesis by simp
 qed
 
 lemma eij_neq_0:
   assumes "i < m"
     and "j < n"
   shows "eij i j \<noteq> 0"
 proof -
   have "a ! i > 0" and "b ! j > 0"
     using assms and no0  by (simp_all add: in_set_conv_nth)
   then have "eij i j > 0"
     using lcm_div_gt_0[of "b ! j"  "a ! i"] by (simp add: eij_def lcm.commute)
   then show ?thesis
     by simp
 qed
 
 lemma Special_Solutions_in_Solutions:
   "x \<in> Special_Solutions \<Longrightarrow> x \<in> Solutions"
   by (auto simp: in_Solutions_iff Special_Solutions_def sij_def dij_def eij_def)
 
 lemma Special_Solutions_in_Minimal_Solutions:
   assumes "(x, y) \<in> Special_Solutions"
   shows "(x, y) \<in> Minimal_Solutions"
 proof (intro Minimal_SolutionsI')
   show "(x, y) \<in> Solutions" by (fact Special_Solutions_in_Solutions [OF assms])
   then have [simp]: "length x = m" "length y = n" by (auto simp: in_Solutions_iff)
   show "nonzero x" using assms and dij_neq_0
     by (auto simp: Special_Solutions_def sij_def nonzero_iff)
      (metis length_replicate set_update_memI)
   show "\<not> (\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y)"
   proof
     assume "\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y"
     then obtain u and v where uv: "(u, v) \<in> Minimal_Solutions" and "u @ v <\<^sub>v x @ y"
       and [simp]: "length u = m" "length v = n"
       and "nonzero u" by (auto simp: Minimal_Solutions_def in_Solutions_iff)
     then consider "u <\<^sub>v x" and "v \<le>\<^sub>v y" | "v <\<^sub>v y" and "u \<le>\<^sub>v x" by (auto elim: less_append_cases)
     then show False
     proof (cases)
       case 1
       then obtain i and j where ij: "i < m" "j < n"
         and less_dij: "u ! i < dij i j"
         and "u \<le>\<^sub>v (zeroes m)[i := dij i j]"
         and "v \<le>\<^sub>v (zeroes n)[j := eij i j]"
         using assms by (auto simp: Special_Solutions_def sij_def unit_less)
       then have u: "u = (zeroes m)[i := u ! i]" and v: "v = (zeroes n)[j := v ! j]"
         by (auto simp: less_eq_def list_eq_iff_nth_eq)
           (metis le_zero_eq length_list_update length_replicate rep_upd_unit)+
       then have "u ! i > 0" using \<open>nonzero u\<close> and ij
         by (metis gr_implies_not0 neq0_conv unit_less zero_less)
 
       define c where "c = a ! i * u ! i"
       then have ac: "a ! i dvd c" by simp
 
       have "a \<bullet> u = b \<bullet> v" using uv by (auto simp: Minimal_Solutions_def in_Solutions_iff)
       then have "c = b ! j * v ! j"
         using ij unfolding c_def by (subst (asm) u, subst (asm)v, subst u, subst v) auto
       then have bc: "b ! j dvd c" by simp
 
       have "a ! i * u ! i < a ! i * dij i j"
         using less_dij and no0 and ij by (auto simp: in_set_conv_nth)
       then have "c < lcm (a ! i) (b ! j)" by (auto simp: dij_def c_def)
       moreover have "lcm (a ! i) (b ! j) dvd c" by (simp add: ac bc)
       moreover have "c > 0" using \<open>u ! i > 0\<close> and no0 and ij by (auto simp: c_def in_set_conv_nth)
       ultimately show False using ac and bc by (auto dest: nat_dvd_not_less)
     next
       case 2
       then obtain i and j where ij: "i < m" "j < n"
         and less_dij: "v ! j < eij i j"
         and "u \<le>\<^sub>v (zeroes m)[i := dij i j]"
         and "v \<le>\<^sub>v (zeroes n)[j := eij i j]"
         using assms by (auto simp: Special_Solutions_def sij_def unit_less)
       then have u: "u = (zeroes m)[i := u ! i]" and v: "v = (zeroes n)[j := v ! j]"
         by (auto simp: less_eq_def list_eq_iff_nth_eq)
           (metis le_zero_eq length_list_update length_replicate rep_upd_unit)+
       moreover have "nonzero v"
         using \<open>nonzero u\<close> and \<open>(u, v) \<in> Minimal_Solutions\<close>
           and Minimal_Solutions_imp_Solutions Solutions_snd_not_0 by blast
       ultimately have "v ! j > 0" using ij
         by (metis gr_implies_not0 neq0_conv unit_less zero_less)
 
       define c where "c = b ! j * v ! j"
       then have bc: "b ! j dvd c" by simp
 
       have "a \<bullet> u = b \<bullet> v" using uv by (auto simp: Minimal_Solutions_def in_Solutions_iff)
       then have "c = a ! i * u ! i"
         using ij unfolding c_def by (subst (asm) u, subst (asm)v, subst u, subst v) auto
       then have ac: "a ! i dvd c" by simp
 
       have "b ! j * v ! j < b ! j * eij i j"
         using less_dij and no0 and ij by (auto simp: in_set_conv_nth)
       then have "c < lcm (a ! i) (b ! j)" by (auto simp: eij_def c_def)
       moreover have "lcm (a ! i) (b ! j) dvd c" by (simp add: ac bc)
       moreover have "c > 0" using \<open>v ! j > 0\<close> and no0 and ij by (auto simp: c_def in_set_conv_nth)
       ultimately show False using ac and bc by (auto dest: nat_dvd_not_less)
     qed
   qed
 qed
 
 (*Lemma 2 of Huet*)
 lemma non_special_solution_non_minimal:
   assumes "(x, y) \<in> Solutions - Special_Solutions"
     and ij: "i < m" "j < n"
     and "x ! i \<ge> dij i j" and "y ! j \<ge> eij i j"
   shows "(x, y) \<notin> Minimal_Solutions"
 proof
   assume min: "(x, y) \<in> Minimal_Solutions"
   moreover have "sij i j \<in> Solutions"
     using ij by (intro Special_Solutions_in_Solutions) (auto simp: Special_Solutions_def)
   moreover have "(case sij i j of (u, v) \<Rightarrow> u @ v) <\<^sub>v x @ y"
     using assms and min
     apply (cases "sij i j")
     apply (auto simp: sij_def Special_Solutions_def)
     by (metis List_Vector.le0 Minimal_Solutions_length le_append le_list_update less_append order_vec.dual_order.strict_iff_order same_append_eq)
   moreover have "(case sij i j of (u, v) \<Rightarrow> nonzero u)"
     apply (auto simp: sij_def)
     by (metis dij_neq_0 ij length_replicate nonzero_iff set_update_memI)
   ultimately show False
     by (auto simp: Minimal_Solutions_def)
 qed
 
 
 subsection \<open>Huet's conditions\<close>
 
 (*A*)
 definition "cond_A xs ys \<longleftrightarrow> (\<forall>x\<in>set xs. x \<le> maxne0 ys b)"
 
 (*B*)
 definition "cond_B x \<longleftrightarrow>
   (\<forall>k\<le>m. take k a \<bullet> take k x \<le> b \<bullet> map (max_y (take k x)) [0 ..< n])"
 
 (*C*)
 definition "boundr x y \<longleftrightarrow> (\<forall>j<n. y ! j \<le> max_y x j)"
 
 (*D*)
 definition "cond_D x y \<longleftrightarrow> (\<forall>l\<le>n. take l b \<bullet> take l y \<le> a \<bullet> x)"
 
 
 subsection \<open>New conditions: facilitating generation of candidates from right to left\<close>
 
 (*condition on right sub-dotproduct*)
 definition "subdprodr y \<longleftrightarrow>
   (\<forall>l\<le>n. take l b \<bullet> take l y \<le> a \<bullet> map (max_x (take l y)) [0 ..< m])"
 
 (*condition on left sub-dotproduct*)
 definition "subdprodl x y \<longleftrightarrow> (\<forall>k\<le>m. take k a \<bullet> take k x \<le> b \<bullet> y)"
 
 (*bound on elements of left vector*)
 definition "boundl x y \<longleftrightarrow> (\<forall>i<m. x ! i \<le> max_x y i)"
 
 lemma boundr:
   assumes min: "(x, y) \<in> Minimal_Solutions"
     and "(x, y) \<notin> Special_Solutions"
   shows "boundr x y"
 proof (unfold boundr_def, intro allI impI)
   fix j
   assume ass: "j < n"
   have ln: "m = length x \<and> n = length y"
     using assms Minimal_Solutions_def in_Solutions_iff min by auto
   have is_sol: "(x, y) \<in> Solutions"
     using assms Minimal_Solutions_def min by auto
   have j_less_l: "j < n"
     using assms ass le_less_trans by linarith
   consider (notemp) "Ej j x \<noteq> {}"  | (empty) " Ej j x = {}"
     by blast
   then show "y ! j \<le> max_y x j"
   proof (cases)
     case notemp
     have max_y_def: "max_y x j =  Min (Ej j x)"
       using j_less_l max_y_def notemp by auto
     have fin_e: "finite (Ej j x)"
       using finite_Ej [of j x] by auto
     have e_def': "\<forall>e \<in> Ej j x. (\<exists>i<length x. x ! i \<ge> dij i j \<and> eij i j - 1 = e)"
       using Ej_def [of j x] by auto
     then have "\<exists>i<length x. x ! i \<ge> dij i j \<and> eij i j - 1 = Min (Ej j x)"
       using notemp Min_in e_def' fin_e by blast
     then obtain i where
       i: "i < length x" "x ! i \<ge> dij i j" "eij i j - 1 = Min (Ej j x)"
       by blast
     show ?thesis
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with non_special_solution_non_minimal [of x y i j]
         and i and ln and assms and is_sol and j_less_l
       have "case sij i j of (u, v) \<Rightarrow> u @ v \<le>\<^sub>v x @ y"
         by (force simp: max_y_def)
       then have cs:"case sij i j of (u, v) \<Rightarrow> u @ v <\<^sub>v x @ y"
         using assms by(auto simp: Special_Solutions_def) (metis append_eq_append_conv
             i(1) j_less_l length_list_update length_replicate sij_def
             order_vec.le_neq_trans ln prod.sel(1))
       then obtain u v where
         u_v: "sij i j = (u, v)" "u @ v <\<^sub>v x @ y"
         by blast
       have dij_gt0: "dij i j > 0"
         using assms(1) assms(2) dij_neq_0 i(1) j_less_l ln by auto
       then have not_0_u: "nonzero u"
       proof (unfold nonzero_iff)
         have "i < length (zeroes m)" by (simp add: i(1) ln)
         then show "\<exists>i\<in>set u. i \<noteq> 0"
           by (metis (no_types) Pair_inject dij_gt0 set_update_memI sij_def u_v(1) neq0_conv)
       qed
       then have "sij i j \<in> Solutions"
         by (metis (mono_tags, lifting) Special_Solutions_def i(1)
             Special_Solutions_in_Solutions j_less_l ln mem_Collect_eq u_v(1))
       then show False
         using assms cs u_v not_0_u Minimal_Solutions_def min by auto
     qed
   next
     case empty
     have "\<forall>y\<in>set y. y \<le> Max (set a)"
       using assms and max_coeff_bound and maxne0_le_Max
       using le_trans by blast
     then  show ?thesis
       using empty j_less_l ln max_y_def by auto
   qed
 qed
 
 lemma boundl:
   assumes min: "(x, y) \<in> Minimal_Solutions"
     and "(x, y) \<notin> Special_Solutions"
   shows "boundl x y"
 proof (unfold boundl_def, intro allI impI)
   fix i
   assume ass: "i < m"
   have ln: "n = length y \<and> m = length x"
     using assms Minimal_Solutions_def in_Solutions_iff min by auto
   have is_sol: "(x, y) \<in> Solutions"
     using assms Minimal_Solutions_def min by auto
   have i_less_l: "i < m"
     using assms ass le_less_trans by linarith
   consider (notemp) "Di i y \<noteq> {}"  | (empty) " Di i y = {}"
     by blast
   then show "x ! i \<le> max_x y i"
   proof (cases)
     case notemp
     have max_x_def: "max_x y i =  Min (Di i y)"
       using i_less_l max_x_def notemp by auto
     have fin_e: "finite (Di i y)"
       using finite_Di [of i y] by auto
     have e_def': "\<forall>e \<in> Di i y. (\<exists>j<length y. y ! j \<ge> eij i j \<and> dij i j - 1 = e)"
       using Di_def [of i y] by auto
     then have "\<exists>j<length y. y ! j \<ge> eij i j \<and> dij i j - 1 = Min (Di i y)"
       using notemp Min_in e_def' fin_e by blast
     then obtain j where
       j: "j < length y" "y ! j \<ge> eij i j" "dij i j - 1 = Min (Di i y)"
       by blast
     show ?thesis
     proof (rule ccontr)
       assume "\<not> ?thesis"
       with non_special_solution_non_minimal [of x y i j]
         and j and ln and assms and is_sol and i_less_l
       have "case sij i j of (u, v) \<Rightarrow> u @ v \<le>\<^sub>v x @ y"
         by (force simp: max_x_def)
       then have cs: "case sij i j of (u, v) \<Rightarrow> u @ v <\<^sub>v x @ y"
         using assms by(auto simp: Special_Solutions_def) (metis append_eq_append_conv
             j(1) i_less_l length_list_update length_replicate sij_def
             order_vec.le_neq_trans ln prod.sel(1))
       then obtain u v where
         u_v: "sij i j = (u, v)" "u @ v <\<^sub>v x @ y"
         by blast
       have dij_gt0: "dij i j > 0"
         using assms(1) assms(2) dij_neq_0 j(1) i_less_l ln by auto
       then have not_0_u: "nonzero u"
       proof (unfold nonzero_iff)
         have "i < length (zeroes m)"
           using ass by simp
         then show "\<exists>i\<in>set u. i \<noteq> 0"
           by (metis (no_types) Pair_inject dij_gt0 set_update_memI sij_def u_v(1) neq0_conv)
       qed
       then have "sij i j \<in> Solutions"
         by (metis (mono_tags, lifting) Special_Solutions_def j(1)
             Special_Solutions_in_Solutions i_less_l ln mem_Collect_eq u_v(1))
       then show False
         using assms cs u_v not_0_u Minimal_Solutions_def min by auto
     qed
   next
     case empty
     have "\<forall>x\<in>set x. x \<le> Max (set b)"
       using assms and max_coeff_bound and maxne0_le_Max
       using le_trans by blast
     then  show ?thesis
       using empty i_less_l ln max_x_def by auto
   qed
 qed
 
 lemma Solution_imp_cond_D:
   assumes "(x, y) \<in> Solutions"
   shows "cond_D x y"
   using assms and dotprod_le_take by (auto simp: cond_D_def in_Solutions_iff)
 
 lemma Solution_imp_subdprodl:
   assumes "(x, y) \<in> Solutions"
   shows "subdprodl x y"
   using assms and dotprod_le_take
   by (auto simp: subdprodl_def in_Solutions_iff) metis
 
 theorem conds:
   assumes min: "(x, y) \<in> Minimal_Solutions"
   shows cond_A: "cond_A x y"
     and cond_B: "(x, y) \<notin> Special_Solutions \<Longrightarrow> cond_B x"
     and "(x, y) \<notin> Special_Solutions \<Longrightarrow> boundr x y"
     and cond_D: "cond_D x y"
     and subdprodr: "(x, y) \<notin> Special_Solutions \<Longrightarrow> subdprodr y"
     and subdprodl: "subdprodl x y"
 proof -
   have sol: "a \<bullet> x = b \<bullet> y" and ln: "m = length x \<and> n = length y"
     using min by (auto simp: Minimal_Solutions_def in_Solutions_iff)
   then have "\<forall>i<m. x ! i \<le> maxne0 y b"
     by (metis min max_coeff_bound_right nth_mem)
   then show "cond_A x y"
     using min and le_less_trans by (auto simp: cond_A_def max_coeff_bound)
   show "(x, y) \<notin> Special_Solutions \<Longrightarrow> cond_B x"
   proof (unfold cond_B_def, intro allI impI)
     fix k assume non_spec: "(x, y) \<notin> Special_Solutions" and k: "k \<le> m"
     from k have "take k a \<bullet> take k x \<le> a \<bullet> x"
       using dotprod_le_take ln by blast
     also have "... = b \<bullet> y" by fact
     also have map_b_dot_p: "... \<le> b \<bullet> map (max_y x) [0..<n]" (is "_ \<le> _ b \<bullet> ?nt")
       using non_spec and less_eq_def and ln and boundr and min
       by (fastforce intro!: dotprod_le_right simp: boundr_def)
     also have "... \<le> b \<bullet> map (max_y (take k x)) [0..<n]" (is "_ \<le> _ \<bullet> ?t")
     proof -
       have "\<forall>j<n. ?nt!j \<le> ?t!j"
         using min and ln and max_y_le_take and k by auto
       then have "?nt \<le>\<^sub>v ?t"
         using less_eq_def by auto
       then show ?thesis
         by (simp add:  dotprod_le_right)
     qed
     finally show "take k a \<bullet> take k x \<le> b \<bullet> map (max_y (take k x)) [0..<n]"
       by (auto simp: cond_B_def)
   qed
 
   show "(x, y) \<notin> Special_Solutions \<Longrightarrow> subdprodr y"
   proof (unfold subdprodr_def, intro allI impI)
     fix l assume non_spec: "(x, y) \<notin> Special_Solutions" and l: "l \<le> n"
     from l have "take l b \<bullet> take l y \<le> b \<bullet> y"
       using dotprod_le_take ln by blast
     also have "... = a \<bullet> x" by (simp add: sol)
     also have map_b_dot_p: "... \<le> a \<bullet> map (max_x y) [0..<m]" (is "_ \<le> _ a \<bullet> ?nt")
       using non_spec and less_eq_def and ln and boundl and min
       by (fastforce intro!: dotprod_le_right simp: boundl_def)
     also have "... \<le> a \<bullet> map (max_x (take l y)) [0..<m]" (is "_ \<le> _ \<bullet> ?t")
     proof -
       have "\<forall>i<m. ?nt ! i \<le> ?t ! i"
         using min and ln and max_x_le_take and l by auto
       then have "?nt \<le>\<^sub>v ?t"
         using less_eq_def by auto
       then show ?thesis
         by (simp add:  dotprod_le_right)
     qed
     finally show "take l b \<bullet> take l y \<le> a \<bullet> map (max_x (take l y)) [0..<m]"
       by (auto simp: cond_B_def)
   qed
 
   show "(x, y) \<notin> Special_Solutions \<Longrightarrow> boundr x y"
     using boundr [of x y] and min by blast
 
   show "cond_D x y"
     using ln and dotprod_le_take and sol by (auto simp: cond_D_def)
 
   show "subdprodl x y"
     using ln and dotprod_le_take and sol by (force simp: subdprodl_def)
 qed
 
 lemma le_imp_Ej_subset:
   assumes "u \<le>\<^sub>v x"
   shows "Ej j u \<subseteq> Ej j x"
   using assms and le_trans by (force simp: Ej_def less_eq_def dij_def eij_def)
 
 lemma le_imp_max_y_ge:
   assumes "u \<le>\<^sub>v x"
     and "length x \<le> m"
   shows "max_y u j \<ge> max_y x j"
   using assms and le_imp_Ej_subset and Min_Ej_le [of j, OF _ _ assms(2)]
   by (metis Min.subset_imp Min_in emptyE finite_Ej max_y_def order_refl subsetCE)
 
 lemma le_imp_Di_subset:
   assumes "v \<le>\<^sub>v y"
   shows "Di i v \<subseteq> Di i y"
   using assms and le_trans by (force simp: Di_def less_eq_def dij_def eij_def)
 
 lemma le_imp_max_x_ge:
   assumes "v \<le>\<^sub>v y"
     and "length y \<le> n"
   shows "max_x v i \<ge> max_x y i"
   using assms and le_imp_Di_subset and Min_Di_le [of i, OF _ _ assms(2)]
   by (metis Min.subset_imp Min_in emptyE finite_Di max_x_def order_refl subsetCE)
 
 end
 
 end
diff --git a/thys/Dirichlet_L/Dirichlet_Characters.thy b/thys/Dirichlet_L/Dirichlet_Characters.thy
--- a/thys/Dirichlet_L/Dirichlet_Characters.thy
+++ b/thys/Dirichlet_L/Dirichlet_Characters.thy
@@ -1,463 +1,463 @@
 (*
     File:      Dirichlet_Characters.thy
     Author:    Manuel Eberl, TU München
 *)
 section \<open>Dirichlet Characters\<close>
 theory Dirichlet_Characters
 imports
   Multiplicative_Characters
   "HOL-Number_Theory.Residues"
   "Dirichlet_Series.Multiplicative_Function"
 begin
 
 text \<open>
   Dirichlet characters are essentially just the characters of the multiplicative group of
   integer residues $\mathbb{ZZ}/n\mathbb{ZZ}$ for some fixed $n$. For convenience, these residues
   are usually represented by natural numbers from $0$ to $n - 1$, and we extend the characters to 
   all natural numbers periodically, so that $\chi(k\mod n) = \chi(k)$ holds.
 
   Numbers that are not coprime to $n$ are not in the group and therefore are assigned $0$ by
   all characters.
 \<close>
 
 subsection \<open>The multiplicative group of residues\<close>
 
 definition residue_mult_group :: "nat \<Rightarrow> nat monoid" where
   "residue_mult_group n = \<lparr> carrier = totatives n, monoid.mult = (\<lambda>x y. (x * y) mod n), one = 1 \<rparr>"
 
 definition principal_dchar :: "nat \<Rightarrow> nat \<Rightarrow> complex" where
   "principal_dchar n = (\<lambda>k. if coprime k n then 1 else 0)"
 
 lemma principal_dchar_coprime [simp]: "coprime k n \<Longrightarrow> principal_dchar n k = 1"
   and principal_dchar_not_coprime [simp]: "\<not>coprime k n \<Longrightarrow> principal_dchar n k = 0"
   by (simp_all add: principal_dchar_def)
 
 lemma principal_dchar_1 [simp]: "principal_dchar n 1 = 1"
   by simp
 
 lemma principal_dchar_minus1 [simp]:
   assumes "n > 0"
   shows   "principal_dchar n (n - Suc 0) = 1"
 proof (cases "n = 1")
   case False
   with assms have "n > 1" by linarith
   thus ?thesis using coprime_diff_one_left_nat[of n]
     by (intro principal_dchar_coprime) auto
 qed auto
 
 lemma mod_in_totatives: "n > 1 \<Longrightarrow> a mod n \<in> totatives n \<longleftrightarrow> coprime a n"
   by (auto simp: totatives_def mod_greater_zero_iff_not_dvd dest: coprime_common_divisor_nat)
 
 bundle dcharacter_syntax
 begin
 notation principal_dchar ("\<chi>\<^sub>0\<index>")
 end
 
 locale residues_nat =
   fixes n :: nat (structure) and G
   assumes n: "n > 1"
   defines "G \<equiv> residue_mult_group n"
 begin
 
 lemma order [simp]: "order G = totient n"
   by (simp add: order_def G_def totient_def residue_mult_group_def)
 
 lemma totatives_mod [simp]: "x \<in> totatives n \<Longrightarrow> x mod n = x"
   using n by (intro mod_less) (auto simp: totatives_def intro!: order.not_eq_order_implies_strict)
 
 lemma principal_dchar_minus1 [simp]: "principal_dchar n (n - Suc 0) = 1"
   using principal_dchar_minus1[of n] n by simp
 
 sublocale finite_comm_group G
 proof
   fix x y assume xy: "x \<in> carrier G" "y \<in> carrier G"
   hence "coprime (x * y) n" 
     by (auto simp: G_def residue_mult_group_def totatives_def)
   with xy and n show "x \<otimes>\<^bsub>G\<^esub> y \<in> carrier G"
     using coprime_common_divisor_nat[of "x * y" n]
     by (auto simp: G_def residue_mult_group_def totatives_def
                    mod_greater_zero_iff_not_dvd le_Suc_eq simp del: coprime_mult_left_iff)
 next
   fix x y z assume xyz: "x \<in> carrier G" "y \<in> carrier G" "z \<in> carrier G"
   thus "x \<otimes>\<^bsub>G\<^esub> y \<otimes>\<^bsub>G\<^esub> z = x \<otimes>\<^bsub>G\<^esub> (y \<otimes>\<^bsub>G\<^esub> z)"
     by (auto simp: G_def residue_mult_group_def mult_ac mod_mult_right_eq)
 next
   fix x assume "x \<in> carrier G"
   with n have "x < n" by (auto simp: G_def residue_mult_group_def totatives_def 
                                intro!: order.not_eq_order_implies_strict)
   thus " \<one>\<^bsub>G\<^esub> \<otimes>\<^bsub>G\<^esub> x = x" and "x \<otimes>\<^bsub>G\<^esub> \<one>\<^bsub>G\<^esub> = x"
     by (simp_all add: G_def residue_mult_group_def)
 next
   have "x \<in> Units G" if "x \<in> carrier G" for x unfolding Units_def
   proof safe
     from that have "x > 0" "coprime x n" 
       by (auto simp: G_def residue_mult_group_def totatives_def)
     from \<open>coprime x n\<close> and n obtain y where y: "y < n" "[x * y = 1] (mod n)"
       by (subst (asm) coprime_iff_invertible'_nat) auto
     hence "x * y mod n = 1" 
       using n by (simp add: cong_def mult_ac)
     moreover from y have "coprime y n"
       by (subst coprime_iff_invertible_nat) (auto simp: mult.commute)
     ultimately show "\<exists>a\<in>carrier G. a \<otimes>\<^bsub>G\<^esub> x = \<one>\<^bsub>G\<^esub> \<and> x \<otimes>\<^bsub>G\<^esub> a = \<one>\<^bsub>G\<^esub>" using y
       by (intro bexI[of _ y]) 
          (auto simp: G_def residue_mult_group_def totatives_def mult.commute intro!: Nat.gr0I)
   qed fact+
   thus "carrier G \<subseteq> Units G" ..
 qed (insert n, auto simp: G_def residue_mult_group_def mult_ac)
 
 
 subsection \<open>Definition of Dirichlet characters\<close>
 
 text \<open>
   The following two functions make the connection between Dirichlet characters and the
   multiplicative characters of the residue group.
 \<close>
 definition c2dc :: "(nat \<Rightarrow> complex) \<Rightarrow> (nat \<Rightarrow> complex)" where
   "c2dc \<chi> = (\<lambda>x. \<chi> (x mod n))"
 
 definition dc2c :: "(nat \<Rightarrow> complex) \<Rightarrow> (nat \<Rightarrow> complex)" where
   "dc2c \<chi> = (\<lambda>x. if x < n then \<chi> x else 0)"
 
 lemma dc2c_c2dc [simp]:
   assumes "character G \<chi>"
   shows   "dc2c (c2dc \<chi>) = \<chi>"
 proof -
   interpret character G \<chi> by fact
   show ?thesis
     using n by (auto simp: fun_eq_iff dc2c_def c2dc_def char_eq_0_iff G_def
                            residue_mult_group_def totatives_def)
 qed
 
 end
 
 locale dcharacter = residues_nat +
   fixes \<chi> :: "nat \<Rightarrow> complex"
   assumes mult_aux: "a \<in> totatives n \<Longrightarrow> b \<in> totatives n \<Longrightarrow> \<chi> (a * b) = \<chi> a * \<chi> b"
   assumes eq_zero:  "\<not>coprime a n \<Longrightarrow> \<chi> a = 0"
   assumes periodic: "\<chi> (a + n) = \<chi> a"
   assumes one_not_zero: "\<chi> 1 \<noteq> 0"
 begin
 
 lemma zero_eq_0 [simp]: "\<chi> 0 = 0"
   using n by (intro eq_zero) auto
 
 lemma Suc_0 [simp]: "\<chi> (Suc 0) = 1"
   using n mult_aux[of 1 1] one_not_zero by (simp add: totatives_def)   
 
 lemma periodic_mult: "\<chi> (a + m * n) = \<chi> a"
 proof (induction m)
   case (Suc m)
   have "a + Suc m * n = a + m * n+ n" by simp
   also have "\<chi> \<dots> = \<chi> (a + m * n)" by (rule periodic)
   also have "\<dots> = \<chi> a" by (rule Suc.IH)
   finally show ?case .
 qed simp_all
 
 lemma minus_one_periodic [simp]:
   assumes "k > 0"
   shows   "\<chi> (k * n - 1) = \<chi> (n - 1)"
 proof -
   have "k * n - 1 = n - 1 + (k - 1) * n"
     using assms n by (simp add: algebra_simps)
   also have "\<chi> \<dots> = \<chi> (n - 1)"
     by (rule periodic_mult)
   finally show ?thesis .
 qed
 
 lemma cong:
   assumes "[a = b] (mod n)"
   shows   "\<chi> a = \<chi> b"
 proof -
   from assms obtain k1 k2 where *: "b + k1 * n = a + k2 * n"
     by (subst (asm) cong_iff_lin_nat) auto
   have "\<chi> a = \<chi> (a + k2 * n)" by (rule periodic_mult [symmetric])
   also note * [symmetric]
   also have "\<chi> (b + k1 * n) = \<chi> b" by (rule periodic_mult)
   finally show ?thesis .
 qed
 
 lemma mod [simp]: "\<chi> (a mod n) = \<chi> a"
   by (rule cong) (simp_all add: cong_def)
 
 lemma mult [simp]: "\<chi> (a * b) = \<chi> a * \<chi> b"
 proof (cases "coprime a n \<and> coprime b n")
   case True
   hence "a mod n \<in> totatives n" "b mod n \<in> totatives n"
     using n by (auto simp: totatives_def mod_greater_zero_iff_not_dvd coprime_absorb_right)
   hence "\<chi> ((a mod n) * (b mod n)) = \<chi> (a mod n) * \<chi> (b mod n)"
     by (rule mult_aux)
   also have "\<chi> ((a mod n) * (b mod n)) = \<chi> (a * b)"
     by (rule cong) (auto simp: cong_def mod_mult_eq)
   finally show ?thesis by simp
 next
   case False
   hence "\<not>coprime (a * b) n" by simp
   with False show ?thesis by (auto simp: eq_zero)
 qed
 
 sublocale mult: completely_multiplicative_function \<chi>
   by standard auto
 
 lemma eq_zero_iff: "\<chi> x = 0 \<longleftrightarrow> \<not>coprime x n"
 proof safe
   assume "\<chi> x = 0" and "coprime x n"
   from cong_solve_coprime_nat [OF this(2)] 
     obtain y where "[x * y = Suc 0] (mod n)" by blast
   hence "\<chi> (x * y) = \<chi> (Suc 0)" by (rule cong)
   with \<open>\<chi> x = 0\<close> show False by simp
 qed (auto simp: eq_zero)
 
 lemma minus_one': "\<chi> (n - 1) \<in> {-1, 1}"
 proof -
   define n' where "n' = n - 2"
   have n: "n = Suc (Suc n')" using n by (simp add: n'_def)
   have "(n - 1) ^ 2 = 1 + (n - 2) * n"
     by (simp add: power2_eq_square algebra_simps n)
   also have "\<chi> \<dots> = 1"
     by (subst periodic_mult) auto
   also have "\<chi> ((n - 1) ^ 2) = \<chi> (n - 1) ^ 2"
     by (rule mult.power)
   finally show ?thesis
     by (subst (asm) power2_eq_1_iff) auto
 qed
 
 lemma c2dc_dc2c [simp]: "c2dc (dc2c \<chi>) = \<chi>"
   using n by (auto simp: c2dc_def dc2c_def fun_eq_iff intro!: cong simp: cong_def)
 
 lemma character_dc2c: "character G (dc2c \<chi>)"
   by standard (insert n, auto simp: G_def residue_mult_group_def dc2c_def totatives_def
                               intro!: eq_zero)
 
 sublocale dc2c: character G "dc2c \<chi>"
   by (fact character_dc2c)
 
 lemma dcharacter_inv_character [intro]: "dcharacter n (inv_character \<chi>)"
   by standard (auto simp: inv_character_def eq_zero periodic)
 
 lemma norm: "norm (\<chi> k) = (if coprime k n then 1 else 0)"
 proof -
   have "\<chi> k = \<chi> (k mod n)" by (intro cong) (auto simp: cong_def)
   also from n have "\<dots> = dc2c \<chi> (k mod n)" by (simp add: dc2c_def)
   also from n have "norm \<dots> = (if coprime k n then 1 else 0)"
     by (subst dc2c.norm_char) (auto simp: G_def residue_mult_group_def mod_in_totatives)
   finally show ?thesis .
 qed
 
 lemma norm_le_1: "norm (\<chi> k) \<le> 1"
   by (subst norm) auto
 
 end
 
 
 definition dcharacters :: "nat \<Rightarrow> (nat \<Rightarrow> complex) set" where
   "dcharacters n = {\<chi>. dcharacter n \<chi>}"
 
 context residues_nat
 begin
 
 lemma character_dc2c: "dcharacter n \<chi> \<Longrightarrow> character G (dc2c \<chi>)"
   using dcharacter.character_dc2c[of n \<chi>] by (simp add: G_def)
 
 lemma dcharacter_c2dc: 
   assumes "character G \<chi>"
   shows   "dcharacter n (c2dc \<chi>)"
 proof -
   interpret character G \<chi> by fact
   show ?thesis
   proof
     fix x assume "\<not>coprime x n"
     thus "c2dc \<chi> x = 0"
       by (auto simp: c2dc_def char_eq_0_iff G_def residue_mult_group_def totatives_def)
   qed (insert char_mult char_one n, 
        auto simp: c2dc_def G_def residue_mult_group_def simp del: char_mult char_one)
 qed
 
 lemma principal_dchar_altdef: "principal_dchar n = c2dc (principal_char G)"
   using n by (auto simp: c2dc_def principal_dchar_def principal_char_def G_def
                 residue_mult_group_def fun_eq_iff mod_in_totatives)
 
 sublocale principal: dcharacter n G "principal_dchar n"
   by (simp add: principal_dchar_altdef dcharacter_c2dc | rule G_def)+
 
 lemma c2dc_principal [simp]: "c2dc (principal_char G) = principal_dchar n"
   by (simp add: principal_dchar_altdef)
 
 lemma dc2c_principal [simp]: "dc2c (principal_dchar n) = principal_char G"
 proof -
   have "dc2c (c2dc (principal_char G)) = dc2c (principal_dchar n)"
     by (subst c2dc_principal) (rule refl)
   thus ?thesis by (subst (asm) dc2c_c2dc) simp_all
 qed
 
 
 lemma bij_betw_dcharacters_characters:
   "bij_betw dc2c (dcharacters n) (characters G)"
   by (intro bij_betwI[where ?g = c2dc])
      (auto simp: characters_def dcharacters_def dcharacter_c2dc 
                  character_dc2c dcharacter.c2dc_dc2c)
 
 lemma bij_betw_characters_dcharacters:
   "bij_betw c2dc (characters G) (dcharacters n)"
   by (intro bij_betwI[where ?g = dc2c])
      (auto simp: characters_def dcharacters_def dcharacter_c2dc 
                  character_dc2c dcharacter.c2dc_dc2c)
 
 lemma finite_dcharacters [intro]: "finite (dcharacters n)"
   using bij_betw_finite [OF bij_betw_dcharacters_characters] by auto
 
 lemma card_dcharacters [simp]: "card (dcharacters n) = totient n"
   using bij_betw_same_card [OF bij_betw_dcharacters_characters] card_characters by simp
 
 end
 
 lemma inv_character_eq_principal_dchar_iff [simp]: 
   "inv_character \<chi> = principal_dchar n \<longleftrightarrow> \<chi> = principal_dchar n"
   by (auto simp add: fun_eq_iff inv_character_def principal_dchar_def)
 
 
 subsection \<open>Sums of Dirichlet characters\<close>
 
 lemma (in dcharacter) sum_dcharacter_totatives:
   "(\<Sum>x\<in>totatives n. \<chi> x) = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
 proof -
   from n have "(\<Sum>x\<in>totatives n. \<chi> x) = (\<Sum>x\<in>carrier G. dc2c \<chi> x)"
     by (intro sum.cong) (auto simp: totatives_def dc2c_def G_def residue_mult_group_def)
   also have "\<dots> = (if dc2c \<chi> = principal_char G then of_nat (order G) else 0)"
     by (rule dc2c.sum_character)
   also have "dc2c \<chi> = principal_char G \<longleftrightarrow> \<chi> = principal_dchar n"
     by (metis c2dc_dc2c dc2c_principal principal_dchar_altdef)
   finally show ?thesis by simp
 qed
 
 lemma (in dcharacter) sum_dcharacter_block:
   "(\<Sum>x<n. \<chi> x) = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
 proof -
   from n have "(\<Sum>x<n. \<chi> x) = (\<Sum>x\<in>totatives n. \<chi> x)"
     by (intro sum.mono_neutral_right) 
        (auto simp: totatives_def eq_zero_iff intro!: Nat.gr0I order.not_eq_order_implies_strict)
   also have "\<dots> = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
     by (rule sum_dcharacter_totatives)
   finally show ?thesis .
 qed
 
 lemma (in dcharacter) sum_dcharacter_block':
   "sum \<chi> {Suc 0..n} = (if \<chi> = principal_dchar n then of_nat (totient n) else 0)"
 proof -
   let ?f = "\<lambda>k. if k = n then 0 else k" and ?g = "\<lambda>k. if k = 0 then n else k"
   have "sum \<chi> {1..n} = sum \<chi> {..<n}"
     using n by (intro sum.reindex_bij_witness[where j = ?f and i = ?g]) (auto simp: eq_zero_iff)
   thus ?thesis by (simp add: sum_dcharacter_block)
 qed
 
 lemma (in dcharacter) sum_lessThan_dcharacter:
   assumes "\<chi> \<noteq> principal_dchar n"
   shows   "(\<Sum>x<m. \<chi> x) = (\<Sum>x<m mod n. \<chi> x)"
 proof (induction m rule: less_induct)
   case (less m)
   show ?case
   proof (cases "m < n")
     case True
     thus ?thesis by simp
   next
     case False
     hence "{..<m} = {..<n} \<union> {n..<m}" by auto
     also have "(\<Sum>x\<in>\<dots>. \<chi> x) = (\<Sum>x<n. \<chi> x) + (\<Sum>x\<in>{n..<m}. \<chi> x)"
       by (intro sum.union_disjoint) auto
     also from assms have "(\<Sum>x<n. \<chi> x) = 0"
       by (subst sum_dcharacter_block) simp_all
     also from False have "(\<Sum>x\<in>{n..<m}. \<chi> x) = (\<Sum>x\<in>{..<m - n}. \<chi> (x + n))"
       by (intro sum.reindex_bij_witness[of _ "\<lambda>x. x + n" "\<lambda>x. x - n"]) (auto simp: periodic)
     also have "\<dots> = (\<Sum>x\<in>{..<m - n}. \<chi> x)" by (simp add: periodic)
     also have "\<dots> = (\<Sum>x<(m - n) mod n. \<chi> x)"
       using False and n by (intro less.IH) auto
     also from False and n have "(m - n) mod n = m mod n" 
-      by (simp add: mod_geq [symmetric])
+      by (simp add: le_mod_geq)
     finally show ?thesis by simp
   qed
 qed
 
 lemma (in dcharacter) sum_dcharacter_lessThan_le:
   assumes "\<chi> \<noteq> principal_dchar n"
   shows   "norm (\<Sum>x<m. \<chi> x) \<le> totient n"
 proof -
   have "(\<Sum>x<m. \<chi> x) = (\<Sum>x<m mod n. \<chi> x)" by (rule sum_lessThan_dcharacter) fact
   also have "\<dots> = (\<Sum>x | x < m mod n \<and> coprime x n. \<chi> x)"
     by (intro sum.mono_neutral_right) (auto simp: eq_zero_iff)
   also have "norm \<dots> \<le> (\<Sum>x | x < m mod n \<and> coprime x n. 1)"
     by (rule sum_norm_le) (auto simp: norm)
   also have "\<dots> = card {x. x < m mod n \<and> coprime x n}" by simp
   also have "\<dots> \<le> card (totatives n)" unfolding of_nat_le_iff
   proof (intro card_mono subsetI)
     fix x assume x: "x \<in> {x. x < m mod n \<and> coprime x n}"
     hence "x < m mod n" by simp
     also have "\<dots> < n" using n by simp
     finally show "x \<in> totatives n" using x
       by (auto simp: totatives_def intro!: Nat.gr0I)
   qed auto
   also have "\<dots> = totient n" by (simp add: totient_def)
   finally show ?thesis .
 qed
 
 lemma (in dcharacter) sum_dcharacter_atMost_le:
   assumes "\<chi> \<noteq> principal_dchar n"
   shows   "norm (\<Sum>x\<le>m. \<chi> x) \<le> totient n"
   using sum_dcharacter_lessThan_le[OF assms, of "Suc m"] by (subst (asm) lessThan_Suc_atMost)
 
 lemma (in residues_nat) sum_dcharacters:
   "(\<Sum>\<chi>\<in>dcharacters n. \<chi> x) = (if [x = 1] (mod n) then of_nat (totient n) else 0)"
 proof (cases "coprime x n")
   case True
   with n have x: "x mod n \<in> totatives n" by (auto simp: mod_in_totatives)
   have "(\<Sum>\<chi>\<in>dcharacters n. \<chi> x) = (\<Sum>\<chi>\<in>characters G. c2dc \<chi> x)"
     by (rule sum.reindex_bij_betw [OF bij_betw_characters_dcharacters, symmetric])
   also from x have "\<dots> = (\<Sum>\<chi>\<in>characters G. \<chi> (x mod n))"
     by (simp add: c2dc_def)
   also from x have "\<dots> = (if x mod n = 1 then order G else 0)"
     by (subst sum_characters) (unfold G_def residue_mult_group_def, auto)
   also from n have "x mod n = 1 \<longleftrightarrow> [x = 1] (mod n)"
     by (simp add: cong_def)
   finally show ?thesis by simp
 next
   case False
   have "x mod n \<noteq> 1"
   proof
     assume *: "x mod n = 1"
     have "gcd (x mod n) n = 1" by (subst *) simp
     also have "gcd (x mod n) n = gcd x n" 
       by (subst gcd.commute) (simp only: gcd_red_nat [symmetric])
     finally show False using \<open>\<not>coprime x n\<close> unfolding coprime_iff_gcd_eq_1 by contradiction
   qed
   from False have "(\<Sum>\<chi>\<in>dcharacters n. \<chi> x) = 0"
     by (intro sum.neutral) (auto simp: dcharacters_def dcharacter.eq_zero)
   with \<open>x mod n \<noteq> 1\<close> and n show ?thesis by (simp add: cong_def)
 qed
 
 lemma (in dcharacter) even_dcharacter_linear_sum_eq_0 [simp]:
   assumes "\<chi> \<noteq> principal_dchar n" and "\<chi> (n - 1) = 1"
   shows   "(\<Sum>k=Suc 0..<n. of_nat k * \<chi> k) = 0"
 proof -
   have "(\<Sum>k=1..<n. of_nat k * \<chi> k) = (\<Sum>k=1..<n. (of_nat n - of_nat k) * \<chi> (n - k))"
     by (intro sum.reindex_bij_witness[where i = "\<lambda>k. n - k" and j = "\<lambda>k. n - k"])
        (auto simp: of_nat_diff)
   also have "\<dots> = n * (\<Sum>k=1..<n. \<chi> (n - k)) - (\<Sum>k=1..<n. k * \<chi> (n - k))"
     by (simp add: algebra_simps sum_subtractf sum_distrib_left)
   also have "(\<Sum>k=1..<n. \<chi> (n - k)) = (\<Sum>k=1..<n. \<chi> k)"
     by (intro sum.reindex_bij_witness[where i = "\<lambda>k. n - k" and j = "\<lambda>k. n - k"]) auto
   also have "\<dots> = (\<Sum>k<n. \<chi> k)"
     by (intro sum.mono_neutral_left) (auto simp: Suc_le_eq)
   also have "\<dots> = 0" using assms by (simp add: sum_dcharacter_block)
   also have "(\<Sum>k=1..<n. of_nat k * \<chi> (n - k)) = (\<Sum>k=1..<n. k * \<chi> k)"
   proof (intro sum.cong refl)
     fix k assume k: "k \<in> {1..<n}"
     have "of_nat k * \<chi> k = of_nat k * \<chi> ((n - 1) * k)"
       using assms by (subst mult) simp_all
     also have "(n - 1) * k = n - k + (k - 1) * n"
       using k by (simp add: algebra_simps)
     also have "\<chi> \<dots> = \<chi> (n - k)"
       by (rule periodic_mult)
     finally show "of_nat k * \<chi> (n - k) = of_nat k * \<chi> k" ..
   qed
   finally show ?thesis by simp
 qed
 
 end
diff --git a/thys/Gauss_Sums/Gauss_Sums.thy b/thys/Gauss_Sums/Gauss_Sums.thy
--- a/thys/Gauss_Sums/Gauss_Sums.thy
+++ b/thys/Gauss_Sums/Gauss_Sums.thy
@@ -1,1704 +1,1705 @@
 (*
   File:     Gauss_Sums.thy
   Authors:  Rodrigo Raya, EPFL; Manuel Eberl, TUM
 
   Gauss sums and more on Dirichlet characters: induced moduli, separability, primitive characters
 *)
 theory Gauss_Sums
 imports 
   "HOL-Algebra.Coset"
   "HOL-Real_Asymp.Real_Asymp"
   Ramanujan_Sums
 begin
 
 section \<open>Gauss sums\<close>
 
 bundle vec_lambda_notation
 begin
 notation vec_lambda (binder "\<chi>" 10)
 end
 
 bundle no_vec_lambda_notation
 begin
 no_notation vec_lambda (binder "\<chi>" 10)
 end
 
 unbundle no_vec_lambda_notation
 
 
 subsection \<open>Definition and basic properties\<close>
 context dcharacter
 begin                            
 
 (* TODO remove when integrating periodic and periodic_function *)
 lemma dir_periodic_arithmetic: "periodic_arithmetic \<chi> n"
   unfolding periodic_arithmetic_def by (simp add: periodic)
 
 definition "gauss_sum k = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
 
 lemma gauss_sum_periodic: 
   "periodic_arithmetic (\<lambda>n. gauss_sum n) n"
 proof - 
   have "periodic_arithmetic \<chi> n" using dir_periodic_arithmetic by simp
   let ?h = "\<lambda>m k. \<chi>(m) * unity_root n (m*k)"
   {fix m :: nat
   have "periodic_arithmetic (\<lambda>k. unity_root n (m*k)) n"
     using unity_periodic_arithmetic_mult[of n m] by simp
   have "periodic_arithmetic (?h m) n" 
     using scalar_mult_periodic_arithmetic[OF \<open>periodic_arithmetic (\<lambda>k. unity_root n (m*k)) n\<close>]
     by blast}
   then have per_all: "\<forall>m \<in> {1..n}. periodic_arithmetic (?h m) n" by blast
   have "periodic_arithmetic (\<lambda>k. (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))) n" 
     using fin_sum_periodic_arithmetic_set[OF per_all] by blast
   then show ?thesis
     unfolding gauss_sum_def by blast
 qed
 
 lemma ramanujan_sum_conv_gauss_sum:
   assumes "\<chi> = principal_dchar n"
   shows "ramanujan_sum n k = gauss_sum k" 
 proof -
   {fix m
   from assms  
     have 1: "coprime m n \<Longrightarrow> \<chi>(m) = 1" and
          2: "\<not> coprime m n \<Longrightarrow> \<chi>(m) = 0"  
       unfolding principal_dchar_def by auto}
   note eq = this
 
   have "gauss_sum k = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
     unfolding gauss_sum_def by simp
   also have "\<dots> = (\<Sum>m | m \<in> {1..n} \<and> coprime m n . \<chi>(m) * unity_root n (m*k))"
     by (rule sum.mono_neutral_right,simp,blast,simp add: eq) 
   also have "\<dots> = (\<Sum>m | m \<in> {1..n} \<and> coprime m n . unity_root n (m*k))"
     by (simp add: eq)
   also have "\<dots> = ramanujan_sum n k" unfolding ramanujan_sum_def by blast
   finally show ?thesis ..
 qed
 
 lemma cnj_mult_self:
   assumes "coprime k n"
   shows "cnj (\<chi> k) * \<chi> k = 1"
 proof -
   have "cnj (\<chi> k) * \<chi> k = norm (\<chi> k)^2"
     by (simp add: mult.commute complex_mult_cnj cmod_def)
   also have "\<dots> = 1" 
     using norm[of k] assms by simp
   finally show ?thesis .
 qed
 
 text \<open>Theorem 8.9\<close>
 theorem gauss_sum_reduction:
   assumes "coprime k n" 
   shows "gauss_sum k = cnj (\<chi> k) * gauss_sum 1"
 proof -
   from n have n_pos: "n > 0" by simp
   have "gauss_sum k = (\<Sum>r = 1..n . \<chi>(r) * unity_root n (r*k))"
     unfolding gauss_sum_def by simp
   also have "\<dots> = (\<Sum>r = 1..n . cnj (\<chi>(k)) * \<chi> k * \<chi> r * unity_root n (r*k))"
     using assms by (intro sum.cong) (auto simp: cnj_mult_self)
   also have "\<dots> = (\<Sum>r = 1..n . cnj (\<chi>(k)) * \<chi> (k*r) * unity_root n (r*k))"
     by (intro sum.cong) auto
   also have "\<dots> = cnj (\<chi>(k)) * (\<Sum>r = 1..n . \<chi> (k*r) * unity_root n (r*k))"
     by (simp add: sum_distrib_left algebra_simps)
   also have "\<dots>= cnj (\<chi>(k)) * (\<Sum>r = 1..n . \<chi> r * unity_root n r)"
   proof -
     have 1: "periodic_arithmetic (\<lambda>r. \<chi> r * unity_root n r) n"
       using dir_periodic_arithmetic unity_periodic_arithmetic mult_periodic_arithmetic by blast
     have "(\<Sum>r = 1..n . \<chi> (k*r) * unity_root n (r*k)) = 
           (\<Sum>r = 1..n . \<chi> (r)* unity_root n r)"
       using periodic_arithmetic_remove_homothecy[OF assms(1) 1 n_pos]
       by (simp add: algebra_simps n)
     then show ?thesis by argo
   qed
   also have "\<dots> = cnj (\<chi>(k)) * gauss_sum 1" 
     using gauss_sum_def by simp
   finally show ?thesis .
 qed
 
 
 text \<open>
   The following variant takes an integer argument instead.
 \<close>
 definition "gauss_sum_int k = (\<Sum>m=1..n. \<chi> m * unity_root n (int m*k))"
 
 sublocale gauss_sum_int: periodic_fun_simple gauss_sum_int "int n"
 proof
   fix k
   show "gauss_sum_int (k + int n) = gauss_sum_int k"
     by (simp add: gauss_sum_int_def ring_distribs unity_root_add)
 qed
 
 lemma gauss_sum_int_cong:
   assumes "[a = b] (mod int n)"
   shows   "gauss_sum_int a = gauss_sum_int b"
 proof -
   from assms obtain k where k: "b = a + int n * k"
     by (subst (asm) cong_iff_lin) auto
   thus ?thesis
     using gauss_sum_int.plus_of_int[of a k] by (auto simp: algebra_simps)
 qed
 
 lemma gauss_sum_conv_gauss_sum_int:
   "gauss_sum k = gauss_sum_int (int k)" 
   unfolding gauss_sum_def gauss_sum_int_def by auto
 
 lemma gauss_sum_int_conv_gauss_sum:
   "gauss_sum_int k = gauss_sum (nat (k mod n))"
 proof -
   have "gauss_sum (nat (k mod n)) = gauss_sum_int (int (nat (k mod n)))"
     by (simp add: gauss_sum_conv_gauss_sum_int)
   also have "\<dots> = gauss_sum_int k"
     using n
     by (intro gauss_sum_int_cong) (auto simp: cong_def)
   finally show ?thesis ..
 qed
 
 lemma gauss_int_periodic: "periodic_arithmetic gauss_sum_int n" 
   unfolding periodic_arithmetic_def gauss_sum_int_conv_gauss_sum by simp
 
 proposition dcharacter_fourier_expansion:
   "\<chi> m = (\<Sum>k=1..n. 1 / n * gauss_sum_int (-k) * unity_root n (m*k))"
 proof -
   define g where "g = (\<lambda>x. 1 / of_nat n *
       (\<Sum>m<n. \<chi> m * unity_root n (- int x * int m)))"
   have per: "periodic_arithmetic \<chi> n" using dir_periodic_arithmetic by simp
   have "\<chi> m = (\<Sum>k<n. g k * unity_root n (m * int k))"
     using fourier_expansion_periodic_arithmetic(2)[OF _ per, of m] n by (auto simp: g_def)
   also have "\<dots> = (\<Sum>k = 1..n. g k * unity_root n (m * int k))"
   proof -
     have g_per: "periodic_arithmetic g n"
       using fourier_expansion_periodic_arithmetic(1)[OF _ per] n by (simp add: g_def)
     have fact_per: "periodic_arithmetic (\<lambda>k. g k * unity_root n (int m * int k)) n"
       using mult_periodic_arithmetic[OF g_per] unity_periodic_arithmetic_mult by auto
     show ?thesis
     proof -
       have "(\<Sum>k<n. g k * unity_root n (int m * int k)) =
             (\<Sum>l = 0..n - Suc 0. g l * unity_root n (int m * int l))"
         using n by (intro sum.cong) auto
       also have "\<dots> = (\<Sum>l = Suc 0..n. g l * unity_root n (int m * int l))"
         using periodic_arithmetic_sum_periodic_arithmetic_shift[OF fact_per, of 1] n by auto
       finally show ?thesis by simp
     qed
   qed
   also have "\<dots> = (\<Sum>k = 1..n. (1 / of_nat n) * gauss_sum_int (-k) * unity_root n (m*k))"
   proof -
     {fix k :: nat
     have shift: "(\<Sum>m<n. \<chi> m * unity_root n (- int k * int m)) = 
         (\<Sum>m = 1..n. \<chi> m * unity_root n (- int k * int m))"
     proof -
       have per_unit: "periodic_arithmetic (\<lambda>m. unity_root n (- int k * int m)) n"
         using unity_periodic_arithmetic_mult by blast
       then have prod_per: "periodic_arithmetic (\<lambda>m. \<chi> m * unity_root n (- int k * int m)) n"
         using per mult_periodic_arithmetic by blast
       show ?thesis
       proof -
         have "(\<Sum>m<n. \<chi> m * unity_root n (- int k * int m)) =
               (\<Sum>l = 0..n - Suc 0. \<chi> l * unity_root n (- int k * int l))"
           using n by (intro sum.cong) auto
         also have "\<dots> = (\<Sum>m = 1..n. \<chi> m * unity_root n (- int k * int m))"
           using periodic_arithmetic_sum_periodic_arithmetic_shift[OF prod_per, of 1] n by auto
         finally show ?thesis by simp
       qed
     qed
     have "g k = 1 / of_nat n *
       (\<Sum>m<n. \<chi> m * unity_root n (- int k * int m))"
       using g_def by auto
     also have "\<dots> = 1 / of_nat n *
       (\<Sum>m = 1..n. \<chi> m * unity_root n (- int k * int m))"
       using shift by simp
     also have "\<dots> = 1 / of_nat n * gauss_sum_int (-k)"
       unfolding gauss_sum_int_def 
       by (simp add: algebra_simps)
     finally have "g k = 1 / of_nat n * gauss_sum_int (-k)" by simp} 
     note g_expr = this
       show ?thesis
         by (rule sum.cong, simp, simp add: g_expr) 
     qed
     finally show ?thesis by auto
 qed
 
 
 subsection \<open>Separability\<close>
 
 definition "separable k \<longleftrightarrow> gauss_sum k = cnj (\<chi> k) * gauss_sum 1"
 
 corollary gauss_coprime_separable:
   assumes "coprime k n" 
   shows   "separable k" 
   using gauss_sum_reduction[OF assms] unfolding separable_def by simp
 
 text \<open>Theorem 8.10\<close>
 theorem global_separability_condition:
   "(\<forall>n>0. separable n) \<longleftrightarrow> (\<forall>k>0. \<not>coprime k n \<longrightarrow> gauss_sum k = 0)"
 proof -
   {fix k 
   assume "\<not> coprime k n"
   then have "\<chi>(k) = 0" by (simp add: eq_zero)
   then have "cnj (\<chi> k) = 0" by blast
   then have "separable k \<longleftrightarrow> gauss_sum k = 0" 
     unfolding separable_def by auto} 
   note not_case = this
   
   show ?thesis
     using gauss_coprime_separable not_case separable_def by blast      
 qed
 
 lemma of_real_moebius_mu [simp]: "of_real (moebius_mu k) = moebius_mu k"
   by (simp add: moebius_mu_def)
 
 corollary principal_not_totally_separable:
   assumes "\<chi> = principal_dchar n"
   shows "\<not>(\<forall>k > 0. separable k)"
 proof -
   have n_pos: "n > 0" using n by simp  
   have tot_0: "totient n \<noteq> 0" by (simp add: n_pos)
   have "moebius_mu (n div gcd n n) \<noteq> 0" by (simp add: \<open>n > 0\<close>)
   then have moeb_0: "\<exists>k. moebius_mu (n div gcd k n) \<noteq> 0" by blast
   
   have lem: "gauss_sum k = totient n * moebius_mu (n div gcd k n) / totient (n div gcd k n)"
     if "k > 0" for k
   proof -
     have "gauss_sum k = ramanujan_sum n k"
       using ramanujan_sum_conv_gauss_sum[OF assms(1)] ..
     also have "\<dots> = totient n * moebius_mu (n div gcd k n) / (totient (n div gcd k n))"
       by (simp add: ramanujan_sum_k_n_dirichlet_expr[OF n_pos that])
     finally show ?thesis .
   qed
   have 2: "\<not> coprime n n" using n by auto
   have 3: "gauss_sum n \<noteq> 0" 
     using lem[OF n_pos] tot_0 moebius_mu_1 by simp
   from n_pos 2 3 have
     "\<exists>k>0. \<not>coprime k n \<and> gauss_sum k \<noteq> 0" by blast
   then obtain k where "k > 0 \<and> \<not> coprime k n \<and> gauss_sum k \<noteq> 0" by blast
   note right_not_zero = this
 
   have "cnj (\<chi> k) * gauss_sum 1 = 0" if "\<not>coprime k n" for k
     using that assms by (simp add: principal_dchar_def)
   then show ?thesis 
      unfolding separable_def using right_not_zero by auto
 qed
 
 text \<open>Theorem 8.11\<close>
 theorem gauss_sum_1_mod_square_eq_k: 
   assumes "(\<forall>k. k > 0 \<longrightarrow> separable k)" 
   shows "norm (gauss_sum 1) ^ 2 = real n" 
 proof -
   have "(norm (gauss_sum 1))^2 = gauss_sum 1 * cnj (gauss_sum 1)"
     using complex_norm_square by blast
   also have "\<dots> = gauss_sum 1 * (\<Sum>m = 1..n. cnj (\<chi>(m)) * unity_root n (-m))"
   proof -
     have "cnj (gauss_sum 1) = (\<Sum>m = 1..n. cnj (\<chi>(m)) * unity_root n (-m))"
       unfolding gauss_sum_def by (simp add: unity_root_uminus)
     then show ?thesis by argo
   qed
   also have "\<dots> = (\<Sum>m = 1..n. gauss_sum 1 * cnj (\<chi>(m)) * unity_root n (-m))"
     by (subst sum_distrib_left)(simp add: algebra_simps)
   also have "\<dots> = (\<Sum>m = 1..n. gauss_sum m * unity_root n (-m))"
   proof (rule sum.cong,simp)   
     fix x
     assume as: "x \<in> {1..n}"
     show "gauss_sum 1 * cnj (\<chi> x) * unity_root n (-x) =
           gauss_sum x * unity_root n (-x)"
       using assms(1) unfolding separable_def 
       by (rule allE[of _ x]) (use as in auto)
   qed
   also have "\<dots> = (\<Sum>m = 1..n. (\<Sum>r = 1..n. \<chi> r * unity_root n (r*m) * unity_root n (-m)))"
     unfolding gauss_sum_def 
     by (rule sum.cong,simp,rule sum_distrib_right)
   also have "\<dots> = (\<Sum>m = 1..n. (\<Sum>r = 1..n. \<chi> r * unity_root n (m*(r-1)) ))"
     by (intro sum.cong refl) (auto simp: unity_root_diff of_nat_diff unity_root_uminus field_simps)
   also have "\<dots> = (\<Sum>r=1..n. (\<Sum>m=1..n.  \<chi>(r) *unity_root n (m*(r-1))))"
     by (rule sum.swap)
   also have "\<dots> = (\<Sum>r=1..n. \<chi>(r) *(\<Sum>m=1..n. unity_root n (m*(r-1))))"
     by (rule sum.cong, simp, simp add: sum_distrib_left)
   also have "\<dots> = (\<Sum>r=1..n. \<chi>(r) * unity_root_sum n (r-1))" 
   proof (intro sum.cong refl)
     fix x
     assume "x \<in> {1..n}" 
     then have 1: "periodic_arithmetic (\<lambda>m. unity_root n (int (m * (x - 1)))) n"
       using unity_periodic_arithmetic_mult[of n "x-1"] 
       by (simp add: mult.commute)
     have "(\<Sum>m = 1..n. unity_root n (int (m * (x - 1)))) = 
           (\<Sum>m = 0..n-1. unity_root n (int (m * (x - 1))))"
       using periodic_arithmetic_sum_periodic_arithmetic_shift[OF 1 _, of 1] n by simp
     also have "\<dots> = unity_root_sum n (x-1)"
       using n unfolding unity_root_sum_def by (intro sum.cong) (auto simp: mult_ac)
     finally have "(\<Sum>m = 1..n. unity_root n (int (m * (x - 1)))) =
                   unity_root_sum n (int (x - 1))" .
     then show "\<chi> x * (\<Sum>m = 1..n. unity_root n (int (m * (x - 1)))) =
                \<chi> x * unity_root_sum n (int (x - 1))" by argo
   qed
   also have "\<dots> = (\<Sum>r \<in> {1}. \<chi> r * unity_root_sum n (int (r - 1)))"    
     using n unity_root_sum_nonzero_iff int_ops(6)
     by (intro sum.mono_neutral_right) auto
   also have "\<dots> = \<chi> 1 * n" using n by simp 
   also have "\<dots> = n" by simp
   finally show ?thesis
     using of_real_eq_iff by fastforce
 qed
 
 text \<open>Theorem 8.12\<close>
 theorem gauss_sum_nonzero_noncoprime_necessary_condition:
   assumes "gauss_sum k \<noteq> 0" "\<not>coprime k n" "k > 0"
   defines "d \<equiv> n div gcd k n"  
   assumes "coprime a n" "[a = 1] (mod d)" 
   shows   "d dvd n" "d < n" "\<chi> a = 1" 
 proof -
   show "d dvd n" 
     unfolding d_def using n by (subst div_dvd_iff_mult) auto
   from assms(2) have "gcd k n \<noteq> 1" by blast
   then have "gcd k n > 1" using assms(3,4) by (simp add: nat_neq_iff)
   with n show "d < n" by (simp add: d_def)
 
   have "periodic_arithmetic (\<lambda>r. \<chi> (r)* unity_root n (k*r)) n" 
     using mult_periodic_arithmetic[OF dir_periodic_arithmetic unity_periodic_arithmetic_mult] by auto
   then have 1: "periodic_arithmetic (\<lambda>r. \<chi> (r)* unity_root n (r*k)) n" 
     by (simp add: algebra_simps)
   
   have "gauss_sum k = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
     unfolding gauss_sum_def by blast
   also have "\<dots> = (\<Sum>m = 1..n . \<chi>(m*a) * unity_root n (m*a*k))"
     using periodic_arithmetic_remove_homothecy[OF assms(5) 1] n by auto
   also have "\<dots> = (\<Sum>m = 1..n . \<chi>(m*a) * unity_root n (m*k))"  
   proof (intro sum.cong refl)
     fix m
     from assms(6) obtain b where "a = 1 + b*d" 
       using \<open>d < n\<close> assms(5) cong_to_1'_nat by auto
     then have "m*a*k = m*k+m*b*(n div gcd k n)*k"
       by (simp add: algebra_simps d_def)
     also have "\<dots> = m*k+m*b*n*(k div gcd k n)"
       by (simp add: div_mult_swap dvd_div_mult)
     also obtain p where "\<dots> = m*k+m*b*n*p" by blast
     finally have "m*a*k = m*k+m*b*p*n" by simp
     then have 1: "m*a*k mod n= m*k mod n" 
       using mod_mult_self1 by simp
     then have "unity_root n (m * a * k) = unity_root n (m * k)" 
     proof -
       have "unity_root n (m * a * k) = unity_root n ((m * a * k) mod n)"
         using unity_root_mod[of n] zmod_int by simp
       also have "\<dots> = unity_root n (m * k)" 
         using unity_root_mod[of n] zmod_int 1 by presburger
       finally show ?thesis by blast
     qed
     then show "\<chi> (m * a) * unity_root n (int (m * a * k)) =
                \<chi> (m * a) * unity_root n (int (m * k))" by auto
   qed
   also have "\<dots> = (\<Sum>m = 1..n . \<chi>(a) * (\<chi>(m) * unity_root n (m*k)))"
     by (rule sum.cong,simp,subst mult,simp)
   also have "\<dots> =  \<chi>(a) * (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*k))"
     by (simp add: sum_distrib_left[symmetric]) 
   also have "\<dots> = \<chi>(a) * gauss_sum k" 
     unfolding gauss_sum_def by blast
   finally have "gauss_sum k = \<chi>(a) * gauss_sum k" by blast
   then show "\<chi> a = 1" 
     using assms(1) by simp
 qed
 
 
 subsection \<open>Induced moduli and primitive characters\<close>
 
 definition "induced_modulus d \<longleftrightarrow> d dvd n \<and> (\<forall>a. coprime a n \<and> [a = 1] (mod d) \<longrightarrow> \<chi> a = 1)"
 
 lemma induced_modulus_dvd: "induced_modulus d \<Longrightarrow> d dvd n"
   unfolding induced_modulus_def by blast
 
 lemma induced_modulusI [intro?]:
   "d dvd n \<Longrightarrow> (\<And>a. coprime a n \<Longrightarrow> [a = 1] (mod d) \<Longrightarrow> \<chi> a = 1) \<Longrightarrow> induced_modulus d"
   unfolding induced_modulus_def by auto
 
 lemma induced_modulusD: "induced_modulus d \<Longrightarrow> coprime a n \<Longrightarrow> [a = 1] (mod d) \<Longrightarrow> \<chi> a = 1"
   unfolding induced_modulus_def by blast
 
 lemma zero_not_ind_mod: "\<not>induced_modulus 0" 
   unfolding induced_modulus_def using n by simp
 
 lemma div_gcd_dvd1: "(a :: 'a :: semiring_gcd) div gcd a b dvd a"
   by (metis dvd_def dvd_div_mult_self gcd_dvd1)
 
 lemma div_gcd_dvd2: "(b :: 'a :: semiring_gcd) div gcd a b dvd b"
   by (metis div_gcd_dvd1 gcd.commute)
 
 lemma g_non_zero_ind_mod:
   assumes "gauss_sum k \<noteq> 0" "\<not>coprime k n" "k > 0"
   shows  "induced_modulus (n div gcd k n)"
 proof
   show "n div gcd k n dvd n"
     by (metis dvd_div_mult_self dvd_triv_left gcd.commute gcd_dvd1)
   fix a :: nat
   assume "coprime a n" "[a = 1] (mod n div gcd k n)"
   thus "\<chi> a = 1"
     using assms n gauss_sum_nonzero_noncoprime_necessary_condition(3) by auto
 qed
 
 lemma induced_modulus_modulus: "induced_modulus n"
   unfolding induced_modulus_def 
 proof (rule conjI,simp,safe) 
   fix a 
   assume "[a = 1] (mod n)" 
   then have "a mod n = 1 mod n" 
     using cong_def[of a 1 n] by blast
   also have "\<dots> = 1" 
     using eq_zero_iff zero_eq_0 by fastforce
   finally have 1: "a mod n = 1" by simp
   
   have "\<chi> a = \<chi> (a mod n)" by simp
   also have "\<dots> = \<chi> 1" using cong_def 1 by auto
   also have "\<dots> = 1" by simp
   finally show "\<chi> a = 1" by blast
 qed
 
 text \<open>Theorem 8.13\<close>
 theorem one_induced_iff_principal:
  "induced_modulus 1 \<longleftrightarrow> \<chi> = principal_dchar n"
 proof
   assume "induced_modulus 1" 
   then have "(\<forall>a. coprime a n \<longrightarrow> \<chi> a = 1)"
     unfolding induced_modulus_def by simp
   then show "\<chi> = principal_dchar n" 
     unfolding principal_dchar_def using eq_zero by auto
 next
   assume as: "\<chi> = principal_dchar n"
   {fix a
   assume "coprime a n"
   then have "\<chi> a = 1" 
     using principal_dchar_def as by simp}
   then show "induced_modulus 1"
     unfolding induced_modulus_def by auto
 qed
 
 end
 
 
 locale primitive_dchar = dcharacter +
   assumes no_induced_modulus: "\<not>(\<exists>d<n. induced_modulus d)"
 
 locale nonprimitive_dchar = dcharacter +
   assumes induced_modulus: "\<exists>d<n. induced_modulus d"
 
 lemma (in nonprimitive_dchar) nonprimitive: "\<not>primitive_dchar n \<chi>"
 proof
   assume "primitive_dchar n \<chi>"
   then interpret A: primitive_dchar n "residue_mult_group n" \<chi>
     by auto
   from A.no_induced_modulus induced_modulus show False by contradiction
 qed
 
 lemma (in dcharacter) primitive_dchar_iff:
   "primitive_dchar n \<chi> \<longleftrightarrow> \<not>(\<exists>d<n. induced_modulus d)"
   unfolding primitive_dchar_def primitive_dchar_axioms_def
   using dcharacter_axioms by metis
 
 lemma (in residues_nat) principal_not_primitive: 
   "\<not>primitive_dchar n (principal_dchar n)"
   unfolding principal.primitive_dchar_iff
   using principal.one_induced_iff_principal n by auto
 
 lemma (in dcharacter) not_primitive_imp_nonprimitive:
   assumes "\<not>primitive_dchar n \<chi>"
   shows   "nonprimitive_dchar n \<chi>"
   using assms dcharacter_axioms
   unfolding nonprimitive_dchar_def primitive_dchar_def
             primitive_dchar_axioms_def nonprimitive_dchar_axioms_def by auto
 
 
 text \<open>Theorem 8.14\<close>
 theorem (in dcharacter) prime_nonprincipal_is_primitive:
   assumes "prime n"
   assumes "\<chi> \<noteq> principal_dchar n" 
   shows   "primitive_dchar n \<chi>"
 proof -
   {fix m
   assume "induced_modulus m" 
   then have "m = n" 
     using assms prime_nat_iff induced_modulus_def
           one_induced_iff_principal by blast}
   then show ?thesis using primitive_dchar_iff by blast
 qed
 
 text \<open>Theorem 8.15\<close>
 corollary (in primitive_dchar) primitive_encoding:
   "\<forall>k>0. \<not>coprime k n \<longrightarrow> gauss_sum k = 0" 
   "\<forall>k>0. separable k"
   "norm (gauss_sum 1) ^ 2 = n"
 proof safe
   show 1: "gauss_sum k = 0" if "k > 0" and "\<not>coprime k n" for k
   proof (rule ccontr)
     assume "gauss_sum k \<noteq> 0"
     hence "induced_modulus (n div gcd k n)"
       using that by (intro g_non_zero_ind_mod) auto
     moreover have "n div gcd k n < n"
       using n that
       by (meson coprime_iff_gcd_eq_1 div_eq_dividend_iff le_less_trans
                 linorder_neqE_nat nat_dvd_not_less principal.div_gcd_dvd2 zero_le_one)
     ultimately show False using no_induced_modulus by blast
   qed
 
   have "(\<forall>n>0. separable n)"
     unfolding global_separability_condition by (auto intro!: 1)
   thus "separable n" if "n > 0" for n
     using that by blast
   thus "norm (gauss_sum 1) ^ 2 = n"
     using gauss_sum_1_mod_square_eq_k by blast
 qed
 
 text \<open>Theorem 8.16\<close>
 lemma (in dcharacter) induced_modulus_altdef1:
   "induced_modulus d \<longleftrightarrow>
      d dvd n \<and> (\<forall>a b. coprime a n \<and> coprime b n \<and> [a = b] (mod d) \<longrightarrow> \<chi> a = \<chi> b)"
 proof 
   assume 1: "induced_modulus d"
   with n have d: "d dvd n" "d > 0"
     by (auto simp: induced_modulus_def intro: Nat.gr0I)
   show " d dvd n \<and> (\<forall>a b. coprime a n \<and> coprime b n \<and> [a = b] (mod d) \<longrightarrow> \<chi>(a) = \<chi>(b))"
   proof safe
     fix a b
     assume 2: "coprime a n" "coprime b n" "[a = b] (mod d)"
     show "\<chi>(a) = \<chi>(b)" 
     proof -
       from 2(1) obtain a' where eq: "[a*a' = 1] (mod n)"
         using cong_solve by blast
       from this d have "[a*a' = 1] (mod d)"
         using cong_dvd_modulus_nat by blast
       from this 1 have "\<chi>(a*a') = 1" 
         unfolding induced_modulus_def
         by (meson "2"(2) eq cong_imp_coprime cong_sym coprime_divisors gcd_nat.refl one_dvd)
       then have 3: "\<chi>(a)*\<chi>(a') = 1" 
         by simp
 
       from 2(3) have "[a*a' = b*a'] (mod d)" 
         by (simp add: cong_scalar_right)
       moreover have 4: "[b*a' = 1] (mod d)" 
         using \<open>[a * a' = 1] (mod d)\<close> calculation cong_sym cong_trans by blast
       have "\<chi>(b*a') = 1" 
       proof -
         have "coprime (b*a') n"
           using "2"(2) cong_imp_coprime[OF cong_sym[OF eq]] by simp
         then show ?thesis using 4 induced_modulus_def 1 by blast
       qed
       then have 4: "\<chi>(b)*\<chi>(a') = 1" 
         by simp
       from 3 4 show "\<chi>(a) = \<chi>(b)" 
         using mult_cancel_left
         by (cases "\<chi>(a') = 0") (fastforce simp add: field_simps)+
     qed
   qed fact+
 next 
   assume *: "d dvd n \<and> (\<forall>a b. coprime a n \<and> coprime b n \<and> [a = b] (mod d) \<longrightarrow> \<chi> a = \<chi> b)"
   then have "\<forall>a . coprime a n \<and> coprime 1 n \<and> [a = 1] (mod d) \<longrightarrow> \<chi> a = \<chi> 1"
     by blast
   then have "\<forall>a . coprime a n \<and> [a = 1] (mod d) \<longrightarrow> \<chi> a = 1"
     using coprime_1_left by simp
   then show "induced_modulus d"
     unfolding induced_modulus_def using * by blast
 qed
 
 text \<open>Exercise 8.4\<close>
 
 lemma induced_modulus_altdef2_lemma:
   fixes n a d q :: nat
   defines "q \<equiv> (\<Prod> p | prime p \<and> p dvd n \<and> \<not> (p dvd a). p)"
   defines "m \<equiv> a + q * d"
   assumes "n > 0" "coprime a d"
   shows "[m = a] (mod d)" and "coprime m n"
 proof (simp add: assms(2) cong_add_lcancel_0_nat cong_mult_self_right)
   have fin: "finite {p. prime p \<and> p dvd n \<and> \<not> (p dvd a)}" by (simp add: assms)
   { fix p
     assume 4: "prime p" "p dvd m" "p dvd n"
     have "p = 1"
     proof (cases "p dvd a")
       case True
       from this assms 4(2) have "p dvd q*d" 
        by (simp add: dvd_add_right_iff)
       then have a1: "p dvd q \<or> p dvd d"
        using 4(1) prime_dvd_mult_iff by blast
     
       have a2: "\<not> (p dvd q)" 
       proof (rule ccontr,simp)  
        assume "p dvd q"
        then have "p dvd (\<Prod> p | prime p \<and> p dvd n \<and> \<not> (p dvd a). p)" 
          unfolding assms by simp
        then have "\<exists>x\<in>{p. prime p \<and> p dvd n \<and> \<not> p dvd a}. p dvd x"
         using prime_dvd_prod_iff[OF fin 4(1)] by simp
        then obtain x where c: "p dvd x \<and> prime x \<and> \<not> x dvd a" by blast
        then have "p = x" using 4(1) by (simp add: primes_dvd_imp_eq)
        then show "False" using True c by auto
       qed
       have a3: "\<not> (p dvd d)" 
         using True assms "4"(1) coprime_def not_prime_unit by auto
   
       from a1 a2 a3 show ?thesis by simp
     next
       case False
       then have "p dvd q" 
       proof -
        have in_s: "p \<in> {p. prime p \<and> p dvd n \<and> \<not> p dvd a}"
         using False 4(3) 4(1) by simp
        show "p dvd q" 
         unfolding assms using dvd_prodI[OF fin in_s ] by fast
       qed
       then have "p dvd q*d" by simp
       then have "p dvd a" using 4(2) assms
         by (simp add: dvd_add_left_iff)
       then show ?thesis using False by auto
     qed
   }
   note lem = this
   show "coprime m n" 
   proof (subst coprime_iff_gcd_eq_1)
     {fix a 
      assume "a dvd m" "a dvd n" "a \<noteq> 1"
      {fix p
       assume "prime p" "p dvd a"
       then have "p dvd m" "p dvd n" 
        using \<open>a dvd m\<close> \<open>a dvd n\<close> by auto
       from lem have "p = a" 
        using not_prime_1 \<open>prime p\<close> \<open>p dvd m\<close> \<open>p dvd n\<close> by blast}
       then have "prime a" 
        using prime_prime_factor[of a] \<open>a \<noteq> 1\<close> by blast
       then have "a = 1" using lem \<open>a dvd m\<close> \<open>a dvd n\<close> by blast
       then have "False" using \<open>a = 1\<close> \<open>a \<noteq> 1\<close> by blast
     }
     then show "gcd m n = 1" by blast
   qed
 qed
 
 text \<open>Theorem 8.17\<close>
 text\<open>The case \<open>d = 1\<close> is exactly the case described in @{thm dcharacter.one_induced_iff_principal}.\<close>
 theorem (in dcharacter) induced_modulus_altdef2:
   assumes "d dvd n" "d \<noteq> 1" 
   defines "\<chi>\<^sub>1 \<equiv> principal_dchar n"
   shows "induced_modulus d \<longleftrightarrow> (\<exists>\<Phi>. dcharacter d \<Phi> \<and> (\<forall>k. \<chi> k = \<Phi> k * \<chi>\<^sub>1 k))"
 proof
   from n have n_pos: "n > 0" by simp
   assume as_im: "induced_modulus d" 
   define f where
     "f \<equiv> (\<lambda>k. k + 
       (if k = 1 then
          0
        else (prod id {p. prime p \<and> p dvd n \<and> \<not> (p dvd k)})*d)
       )"
   have [simp]: "f (Suc 0) = 1" unfolding f_def by simp
   {
     fix k
     assume as: "coprime k d" 
     hence "[f k = k] (mod d)" "coprime (f k) n" 
       using induced_modulus_altdef2_lemma[OF n_pos as] by (simp_all add: f_def)
   }
   note m_prop = this
   
   define \<Phi> where
    "\<Phi> \<equiv> (\<lambda>n. (if \<not> coprime n d then 0 else \<chi>(f n)))"
 
   have \<Phi>_1: "\<Phi> 1 = 1" 
     unfolding \<Phi>_def by simp
 
   from assms(1,2) n have "d > 0" by (intro Nat.gr0I) auto
   from induced_modulus_altdef1 assms(1) \<open>d > 0\<close> as_im 
     have b: "(\<forall>a b. coprime a n \<and> coprime b n \<and> 
                  [a = b] (mod d) \<longrightarrow> \<chi> a = \<chi> b)" by blast
 
   have \<Phi>_periodic:  " \<forall>a. \<Phi> (a + d) = \<Phi> a" 
   proof 
     fix a
     have "gcd (a+d) d = gcd a d" by auto
     then have cop: "coprime (a+d) d = coprime a d"  
       using coprime_iff_gcd_eq_1 by presburger
     show "\<Phi> (a + d) = \<Phi> a"
     proof (cases "coprime a d")
       case True
       from True cop have cop_ad: "coprime (a+d) d" by blast      
       have p1: "[f (a+d) = f a] (mod d)" 
         using m_prop(1)[of "a+d", OF cop_ad] 
               m_prop(1)[of "a",OF True] by (simp add: cong_def)
       have p2: "coprime (f (a+d)) n" "coprime (f a) n" 
         using m_prop(2)[of "a+d", OF cop_ad]
               m_prop(2)[of "a", OF True] by blast+ 
       from b p1 p2 have eq: "\<chi> (f (a + d)) = \<chi> (f a)" by blast
       show ?thesis 
         unfolding \<Phi>_def 
         by (subst cop,simp,safe, simp add: eq) 
     next
       case False
       then show ?thesis unfolding \<Phi>_def by (subst cop,simp)
     qed  
   qed
 
   have \<Phi>_mult: "\<forall>a b. a \<in> totatives d \<longrightarrow>
           b \<in> totatives d \<longrightarrow> \<Phi> (a * b) = \<Phi> a * \<Phi> b"
   proof (safe)
     fix a b
     assume "a \<in> totatives d" "b \<in> totatives d"  
     consider (ab) "coprime a d \<and> coprime b d" | 
              (a)  "coprime a d \<and> \<not> coprime b d" |
              (b)  "coprime b d \<and> \<not> coprime a d" |
              (n)  "\<not> coprime a d \<and> \<not> coprime b d" by blast
     then show "\<Phi> (a * b) = \<Phi> a * \<Phi> b" 
     proof cases
       case ab 
       then have c_ab: 
         "coprime (a*b) d" "coprime a d" "coprime b d" by simp+ 
       then have p1: "[f (a * b) = a * b] (mod d)" "coprime (f (a * b)) n"
         using m_prop[of "a*b", OF c_ab(1)] by simp+
       moreover have p2: "[f a = a] (mod d)" "coprime (f a) n"
                     "[f b = b] (mod d)" "coprime (f b) n"
         using m_prop[of "a",OF c_ab(2)]
               m_prop[of "b",OF c_ab(3) ] by simp+
       have p1s: "[f (a * b) = (f a) * (f b)] (mod d)"
       proof -
         have "[f (a * b) = a * b] (mod d)"
           using p1(1) by blast
         moreover have "[a * b = f(a) * f(b)] (mod d)" 
           using p2(1) p2(3) by (simp add: cong_mult cong_sym)
         ultimately show ?thesis using cong_trans by blast
       qed
       have p2s: "coprime (f a*f b) n"
         using p2(2) p2(4) by simp
       have "\<chi> (f (a * b)) = \<chi> (f a * f b)" 
         using p1s p2s p1(2) b by blast 
       then show ?thesis 
         unfolding \<Phi>_def by (simp add: c_ab)
     qed (simp_all add: \<Phi>_def)
   qed
   have d_gr_1: "d > 1" using assms(1,2) 
     using \<open>0 < d\<close> by linarith
   show "\<exists>\<Phi>. dcharacter d \<Phi> \<and> (\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n)" 
   proof (standard,rule conjI) 
     show "dcharacter d \<Phi>" 
       unfolding dcharacter_def residues_nat_def dcharacter_axioms_def 
       using d_gr_1 \<Phi>_def f_def \<Phi>_mult \<Phi>_1 \<Phi>_periodic by simp
     show "\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n" 
     proof
       fix k
       show "\<chi> k = \<Phi> k * \<chi>\<^sub>1 k"
       proof (cases "coprime k n")
         case True
         then have "coprime k d" using assms(1) by auto
         then have "\<Phi>(k) = \<chi>(f k)" using \<Phi>_def by simp
         moreover have "[f k = k] (mod d)" 
           using m_prop[OF \<open>coprime k d\<close>] by simp
         moreover have "\<chi>\<^sub>1 k = 1" 
           using assms(3) principal_dchar_def \<open>coprime k n\<close> by auto
         ultimately show "\<chi>(k) = \<Phi>(k) * \<chi>\<^sub>1(k)" 
         proof -
           assume "\<Phi> k = \<chi> (f k)" "[f k = k] (mod d)" "\<chi>\<^sub>1 k = 1"
           then have "\<chi> k = \<chi> (f k)"
             using \<open>local.induced_modulus d\<close> induced_modulus_altdef1 assms(1) \<open>d > 0\<close>
                   True \<open>coprime k d\<close> m_prop(2) by auto
           also have "\<dots> = \<Phi> k" by (simp add: \<open>\<Phi> k = \<chi> (f k)\<close>)
           also have "\<dots> = \<Phi> k * \<chi>\<^sub>1 k" by (simp add: \<open>\<chi>\<^sub>1 k = 1\<close>)
           finally show ?thesis by simp
         qed
       next
         case False
         hence "\<chi> k = 0"
           using eq_zero_iff by blast 
         moreover have "\<chi>\<^sub>1 k = 0"
           using False assms(3) principal_dchar_def by simp       
         ultimately show ?thesis by simp
       qed      
     qed
   qed
 next
   assume "(\<exists>\<Phi>. dcharacter d \<Phi> \<and> (\<forall>k. \<chi> k = \<Phi> k * \<chi>\<^sub>1 k))"
   then obtain \<Phi> where 1: "dcharacter d \<Phi>" "(\<forall>k. \<chi> k = \<Phi> k * \<chi>\<^sub>1 k)" by blast
   show "induced_modulus d"
     unfolding induced_modulus_def    
   proof (rule conjI,fact,safe)
     fix k
     assume 2: "coprime k n" "[k = 1] (mod d)"
     then have "\<chi>\<^sub>1 k = 1" "\<Phi> k = 1" 
     proof (simp add: assms(3) principal_dchar_def)
       have "\<Phi> k = \<Phi> (k mod d)" by (simp add: dcharacter.mod[OF 1(1), of k])
       also have "\<dots> = \<Phi> (1 mod d)" using cong_def[of k 1 d] 2(2) by simp
       also have "\<dots> = \<Phi> 1" using assms(2) "1"(1) dcharacter.mod by blast
       also have "\<dots> = 1" using dcharacter.Suc_0[OF 1(1)] by simp
       finally show "\<Phi> k = 1" by simp
     qed
     then show "\<chi> k = 1" using 1(2) by simp    
   qed
 qed
 
 
 subsection \<open>The conductor of a character\<close>
 
 context dcharacter
 begin
 
 definition "conductor = Min {d. induced_modulus d}"
 
 lemma conductor_fin: "finite {d. induced_modulus d}"
 proof -
   let ?A = "{d. induced_modulus d}" 
   have "?A \<subseteq> {d. d dvd n}" 
     unfolding induced_modulus_def by blast
   moreover have "finite {d. d dvd n}" using n by simp
   ultimately show "finite ?A" using finite_subset by auto
 qed
 
 lemma conductor_induced: "induced_modulus conductor"
 proof -
   have "{d. induced_modulus d} \<noteq> {}" using induced_modulus_modulus by blast
   then show "induced_modulus conductor"             
     using Min_in[OF conductor_fin ] conductor_def by auto
 qed
 
 lemma conductor_le_iff: "conductor \<le> a \<longleftrightarrow> (\<exists>d\<le>a. induced_modulus d)"
   unfolding conductor_def using conductor_fin induced_modulus_modulus by (subst Min_le_iff) auto
 
 lemma conductor_ge_iff: "conductor \<ge> a \<longleftrightarrow> (\<forall>d. induced_modulus d \<longrightarrow> d \<ge> a)"
   unfolding conductor_def using conductor_fin induced_modulus_modulus by (subst Min_ge_iff) auto
 
 lemma conductor_leI: "induced_modulus d \<Longrightarrow> conductor \<le> d"
   by (subst conductor_le_iff) auto
 
 lemma conductor_geI: "(\<And>d. induced_modulus d \<Longrightarrow> d \<ge> a) \<Longrightarrow> conductor \<ge> a"
   by (subst conductor_ge_iff) auto
 
 lemma conductor_dvd: "conductor dvd n"
   using conductor_induced unfolding induced_modulus_def by blast
 
 lemma conductor_le_modulus: "conductor \<le> n"
   using conductor_dvd by (rule dvd_imp_le) (use n in auto)
 
 lemma conductor_gr_0: "conductor > 0"
   unfolding conductor_def using zero_not_ind_mod 
   using conductor_def conductor_induced neq0_conv by fastforce
 
 lemma conductor_eq_1_iff_principal: "conductor = 1 \<longleftrightarrow> \<chi> = principal_dchar n" 
 proof
   assume "conductor = 1" 
   then have "induced_modulus 1"
     using conductor_induced by auto
   then show "\<chi> = principal_dchar n"
     using one_induced_iff_principal by blast
 next
   assume "\<chi> = principal_dchar n"
   then have im_1: "induced_modulus 1" using one_induced_iff_principal by auto
   show "conductor = 1" 
   proof -
     have "conductor \<le> 1" 
       using conductor_fin Min_le[OF conductor_fin,simplified,OF im_1]
       by (simp add: conductor_def[symmetric])
     then show ?thesis using conductor_gr_0 by auto
   qed
 qed
 
 lemma conductor_principal [simp]: "\<chi> = principal_dchar n \<Longrightarrow> conductor = 1"
   by (subst conductor_eq_1_iff_principal)
   
 lemma nonprimitive_imp_conductor_less:
   assumes "\<not>primitive_dchar n \<chi>"
   shows "conductor < n" 
 proof -
   obtain d where d: "induced_modulus d" "d < n" 
     using primitive_dchar_iff assms by blast
   from d(1) have "conductor \<le> d"
     by (rule conductor_leI)
   also have "\<dots> < n" by fact
   finally show ?thesis .
 qed
 
 lemma (in nonprimitive_dchar) conductor_less_modulus: "conductor < n"
   using nonprimitive_imp_conductor_less nonprimitive by metis
 
 
 text \<open>Theorem 8.18\<close>
 theorem primitive_principal_form:
   defines "\<chi>\<^sub>1 \<equiv> principal_dchar n"
   assumes "\<chi> \<noteq> principal_dchar n"
   shows "\<exists>\<Phi>. primitive_dchar conductor \<Phi> \<and> (\<forall>n. \<chi>(n) = \<Phi>(n) * \<chi>\<^sub>1(n))"
 proof -
   (*
     TODO: perhaps residues_nat should be relaxed to allow n = 1.
     Then we could remove the unnecessary precondition here.
     It makes no real difference though.
   *)
   from n have n_pos: "n > 0" by simp
   define d where "d = conductor" 
   have induced: "induced_modulus d" 
     unfolding d_def using conductor_induced by blast
   then have d_not_1: "d \<noteq> 1" 
     using one_induced_iff_principal assms by auto
   hence d_gt_1: "d > 1" using conductor_gr_0 by (auto simp: d_def)
   
   from induced obtain \<Phi> where \<Phi>_def: "dcharacter d \<Phi> \<and> (\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n)"
     using d_not_1
     by (subst (asm) induced_modulus_altdef2) (auto simp: d_def conductor_dvd \<chi>\<^sub>1_def)
   have phi_dchars: "\<Phi> \<in> dcharacters d" using \<Phi>_def dcharacters_def by auto
 
   interpret \<Phi>: dcharacter d "residue_mult_group d" \<Phi>
     using \<Phi>_def by auto
 
   have \<Phi>_prim: "primitive_dchar d \<Phi>" 
   proof (rule ccontr)
     assume "\<not> primitive_dchar d \<Phi>"   
     then obtain q where 
       1: "q dvd d \<and> q < d \<and> \<Phi>.induced_modulus q"
       unfolding \<Phi>.induced_modulus_def \<Phi>.primitive_dchar_iff by blast
     then have 2: "induced_modulus q" 
     proof -
       {fix k
       assume mod_1: "[k = 1] (mod q)" 
       assume cop: "coprime k n" 
       have "\<chi>(k) = \<Phi>(k)*\<chi>\<^sub>1(k)" using \<Phi>_def by auto
       also have "\<dots> = \<Phi>(k)" 
         using cop by (simp add: assms principal_dchar_def)  
       also have "\<dots> = 1" 
           using 1 mod_1 \<Phi>.induced_modulus_def 
                 \<open>induced_modulus d\<close> cop induced_modulus_def by auto
       finally have "\<chi>(k) = 1" by blast}
 
       then show ?thesis 
         using induced_modulus_def "1" \<open>induced_modulus d\<close> by auto
     qed
      
     from 1 have "q < d" by simp
     moreover have "d \<le> q" unfolding d_def
       by (intro conductor_leI) fact
     ultimately show False by linarith
   qed     
 
   from \<Phi>_def \<Phi>_prim d_def phi_dchars show ?thesis by blast
 qed
 
 definition primitive_extension :: "nat \<Rightarrow> complex" where
   "primitive_extension =
      (SOME \<Phi>. primitive_dchar conductor \<Phi> \<and> (\<forall>k. \<chi> k = \<Phi> k * principal_dchar n k))"
 
 lemma
   assumes nonprincipal: "\<chi> \<noteq> principal_dchar n"
   shows primitive_primitive_extension: "primitive_dchar conductor primitive_extension"
     and principal_decomposition:       "\<chi> k = primitive_extension k * principal_dchar n k"
 proof -
   note * = someI_ex[OF primitive_principal_form[OF nonprincipal], folded primitive_extension_def]
   from * show "primitive_dchar conductor primitive_extension" by blast
   from * show "\<chi> k = primitive_extension k * principal_dchar n k" by blast
 qed
 
 end
 
 
 subsection \<open>The connection between primitivity and separability\<close>
 
 lemma residue_mult_group_coset:
   fixes m n m1 m2 :: nat and f :: "nat \<Rightarrow> nat" and G H
   defines "G \<equiv> residue_mult_group n"
   defines "H \<equiv> residue_mult_group m"
   defines "f \<equiv> (\<lambda>k. k mod m)"
   assumes "b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f)"
   assumes "m1 \<in> b" "m2 \<in> b"
   assumes "n > 1" "m dvd n"
   shows "m1 mod m = m2 mod m"
 proof -
   have h_1: "\<one>\<^bsub>H\<^esub> = 1" 
     using assms(2) unfolding residue_mult_group_def totatives_def by simp
     
   from assms(4)
   obtain a :: nat where cos_expr: "b = (kernel G H f) #>\<^bsub>G\<^esub> a \<and> a \<in> carrier G" 
     using RCOSETS_def[of G "kernel G H f"] by blast
   then have cop: "coprime a n" 
     using assms(1) unfolding residue_mult_group_def totatives_def by auto
   
   obtain a' where "[a * a' = 1] (mod n)"
     using cong_solve_coprime_nat[OF cop] by auto
   then have a_inv: "(a*a') mod n = 1" 
     using cong_def[of "a*a'" 1 n] assms(7) by simp
 
   have "m1 \<in> (\<Union>h\<in>kernel G H f. {h \<otimes>\<^bsub>G\<^esub> a})"
        "m2 \<in> (\<Union>h\<in>kernel G H f. {h \<otimes>\<^bsub>G\<^esub> a})"
     using r_coset_def[of G "kernel G H f" a] cos_expr assms(5,6) by blast+
   then have "m1 \<in> (\<Union>h\<in>kernel G H f. {(h * a) mod n})"
             "m2 \<in> (\<Union>h\<in>kernel G H f. {(h * a) mod n})"
     using assms(1) unfolding residue_mult_group_def[of n] by auto
   then obtain m1' m2' where 
     m_expr: "m1 = (m1'* a) mod n \<and> m1' \<in> kernel G H f" 
             "m2 = (m2'* a) mod n \<and> m2' \<in> kernel G H f" 
     by blast
 
   have eq_1: "m1 mod m = a mod m" 
   proof -
     have "m1 mod m = ((m1'* a) mod n) mod m" using m_expr by blast
     also have "\<dots> = (m1' * a) mod m" 
       using euclidean_semiring_cancel_class.mod_mod_cancel assms(8) by blast
     also have "\<dots> = (m1' mod m) * (a mod m) mod m" 
       by (simp add: mod_mult_eq)
     also have "\<dots> = (a mod m) mod m" 
       using m_expr(1) h_1 unfolding kernel_def assms(3) by simp
     also have "\<dots> = a mod m" by auto
     finally show ?thesis by simp
   qed
 
   have eq_2: "m2 mod m = a mod m" 
   proof -
     have "m2 mod m = ((m2'* a) mod n) mod m" using m_expr by blast
     also have "\<dots> = (m2' * a) mod m" 
       using euclidean_semiring_cancel_class.mod_mod_cancel assms(8) by blast
     also have "\<dots> = (m2' mod m) * (a mod m) mod m" 
       by (simp add: mod_mult_eq)
     also have "\<dots> = (a mod m) mod m" 
       using m_expr(2) h_1 unfolding kernel_def assms(3) by simp
     also have "\<dots> = a mod m" by auto
     finally show ?thesis by simp
   qed
 
   from eq_1 eq_2 show ?thesis by argo
 qed
 
 lemma residue_mult_group_kernel_partition:
   fixes m n :: nat and f :: "nat \<Rightarrow> nat" and G H
   defines "G \<equiv> residue_mult_group n"
   defines "H \<equiv> residue_mult_group m"
   defines "f \<equiv> (\<lambda>k. k mod m)"
   assumes "m > 1" "n > 0" "m dvd n" 
   shows "partition (carrier G) (rcosets\<^bsub>G\<^esub> kernel G H f)"
         and "card (rcosets\<^bsub>G\<^esub> kernel G H f) = totient m"
         and "card (kernel G H f) = totient n div totient m"
         and "b \<in>(rcosets\<^bsub>G\<^esub> kernel G H f) \<Longrightarrow> b \<noteq> {}"
         and "b \<in>(rcosets\<^bsub>G\<^esub> kernel G H f) \<Longrightarrow> card (kernel G H f) = card b"
         and "bij_betw (\<lambda>b. (the_elem (f ` b))) (rcosets\<^bsub>G\<^esub> kernel G H f) (carrier H)"
 proof -
   have "1 < m" by fact
   also have "m \<le> n" using \<open>n > 0\<close> \<open>m dvd n\<close> by (intro dvd_imp_le) auto
   finally have "n > 1" .
   note mn = \<open>m > 1\<close> \<open>n > 1\<close> \<open>m dvd n\<close> \<open>m \<le> n\<close>
 
   interpret n: residues_nat n G
     using mn by unfold_locales (auto simp: assms)
   interpret m: residues_nat m H
     using mn by unfold_locales (auto simp: assms)
   
   from mn have subset: "f ` carrier G \<subseteq> carrier H"
     by (auto simp: assms(1-3) residue_mult_group_def totatives_def
              dest: coprime_common_divisor_nat intro!: Nat.gr0I)
   moreover have super_set: "carrier H \<subseteq> f ` carrier G"
   proof safe
     fix k assume "k \<in> carrier H"
     hence k: "k > 0" "k \<le> m" "coprime k m"             
       by (auto simp: assms(2) residue_mult_group_def totatives_def)
     from mn \<open>k \<in> carrier H\<close> have "k < m"
       by (simp add: totatives_less assms(2) residue_mult_group_def)
     define P where "P = {p \<in> prime_factors n. \<not>(p dvd m)}"
     define a where "a = \<Prod>P"
     have [simp]: "a \<noteq> 0" by (auto simp: P_def a_def intro!: Nat.gr0I)
     have [simp]: "prime_factors a = P"
     proof -
       have "prime_factors a = set_mset (sum prime_factorization P)"
         unfolding a_def using mn
         by (subst prime_factorization_prod)
            (auto simp: P_def prime_factors_dvd prime_gt_0_nat)
       also have "sum prime_factorization P = (\<Sum>p\<in>P. {#p#})"
         using mn by (intro sum.cong) (auto simp: P_def prime_factorization_prime prime_factors_dvd)
       finally show ?thesis by (simp add: P_def)
     qed
 
     from mn have "coprime m a"
       by (subst coprime_iff_prime_factors_disjoint) (auto simp: P_def)
     hence "\<exists>x. [x = k] (mod m) \<and> [x = 1] (mod a)"
       by (intro binary_chinese_remainder_nat)
     then obtain x where x: "[x = k] (mod m)" "[x = 1] (mod a)"
       by auto
     from x(1) mn k have [simp]: "x \<noteq> 0"
       using coprime_common_divisor[of k m] by (auto intro!: Nat.gr0I simp: cong_def)
       
     from x(2) have "coprime x a"
       using cong_imp_coprime cong_sym by force
     hence "coprime x (a * m)"
       using k cong_imp_coprime[OF cong_sym[OF x(1)]] by auto
     also have "?this \<longleftrightarrow> coprime x n" using mn
       by (intro coprime_cong_prime_factors)
          (auto simp: prime_factors_product P_def in_prime_factors_iff)
     finally have "x mod n \<in> totatives n"
       using mn by (auto simp: totatives_def intro!: Nat.gr0I)
 
     moreover have "f (x mod n) = k"
       using x(1) k mn \<open>k < m\<close> by (auto simp: assms(3) cong_def mod_mod_cancel)
     ultimately show "k \<in> f ` carrier G"
       by (auto simp: assms(1) residue_mult_group_def)
   qed
 
   ultimately have image_eq: "f ` carrier G = carrier H" by blast
 
   have [simp]: "f (k \<otimes>\<^bsub>G\<^esub> l) = f k \<otimes>\<^bsub>H\<^esub> f l" if "k \<in> carrier G" "l \<in> carrier G" for k l
     using that mn by (auto simp: assms(1-3) residue_mult_group_def totatives_def
                                  mod_mod_cancel mod_mult_eq)
   interpret f: group_hom G H f
     using subset by unfold_locales (auto simp: hom_def)
 
   show "bij_betw (\<lambda>b. (the_elem (f ` b))) (rcosets\<^bsub>G\<^esub> kernel G H f) (carrier H)"
     unfolding bij_betw_def  
   proof 
     show "inj_on (\<lambda>b. (the_elem (f ` b))) (rcosets\<^bsub>G\<^esub> kernel G H f)"
       using f.FactGroup_inj_on unfolding FactGroup_def by auto
     have eq: "f ` carrier G = carrier H" 
       using subset super_set by blast
     show "(\<lambda>b. the_elem (f ` b)) ` (rcosets\<^bsub>G\<^esub> kernel G H f) = carrier H"
       using f.FactGroup_onto[OF eq] unfolding FactGroup_def by simp
   qed
   
   show "partition (carrier G) (rcosets\<^bsub>G\<^esub> kernel G H f)"
   proof 
     show "\<And>a. a \<in> carrier G \<Longrightarrow>
          \<exists>!b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<and> a \<in> b"
     proof -
       fix a
       assume a_in: "a \<in> carrier G"
       show "\<exists>!b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<and> a \<in> b"
       proof -
        (*exists*)
         have "\<exists>b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<and> a \<in> b"
           using a_in n.rcosets_part_G[OF f.subgroup_kernel]
           by blast
         then show ?thesis
           using group.rcos_disjoint[OF n.is_group f.subgroup_kernel]
           by (auto simp: disjoint_def)
       qed       
     qed
   next
     show "\<And>b. b \<in> rcosets\<^bsub>G\<^esub> kernel G H f \<Longrightarrow> b \<subseteq> carrier G"
       using n.rcosets_part_G f.subgroup_kernel by auto
   qed
    
   (* sizes *)
   have lagr: "card (carrier G) = card (rcosets\<^bsub>G\<^esub> kernel G H f) * card (kernel G H f)" 
         using group.lagrange_finite[OF n.is_group n.fin f.subgroup_kernel] Coset.order_def[of G] by argo
   have k_size: "card (kernel G H f) > 0" 
     using f.subgroup_kernel finite_subset n.subgroupE(1) n.subgroupE(2) by fastforce
   have G_size: "card (carrier G) = totient n"
     using n.order Coset.order_def[of G] by simp
   have H_size: " totient m = card (carrier H)"
     using n.order Coset.order_def[of H] by simp
   also have "\<dots> = card (carrier (G Mod kernel G H f))" 
     using f.FactGroup_iso[OF image_eq] card_image f.FactGroup_inj_on f.FactGroup_onto image_eq by fastforce
   also have "\<dots> = card (carrier G) div card (kernel G H f)"
   proof -    
     have "card (carrier (G Mod kernel G H f)) = 
           card (rcosets\<^bsub>G\<^esub> kernel G H f)" 
       unfolding FactGroup_def by simp
     also have "\<dots> = card (carrier G) div card (kernel G H f)"
       by (simp add: lagr k_size)
     finally show ?thesis by blast
   qed
   also have "\<dots> = totient n div card (kernel G H f)"
     using G_size by argo
   finally have eq: "totient m = totient n div card (kernel G H f)" by simp
   show "card (kernel G H f) = totient n div totient m"
   proof -
     have "totient m \<noteq> 0" 
       using totient_0_iff[of m] assms(4) by blast
     have "card (kernel G H f) dvd totient n" 
       using lagr \<open>card (carrier G) = totient n\<close> by auto
     have "totient m * card (kernel G H f) = totient n"
       unfolding eq using \<open>card (kernel G H f) dvd totient n\<close> by auto
     have "totient n div totient m = totient m * card (kernel G H f) div totient m"
       using \<open>totient m * card (kernel G H f) = totient n\<close> by auto
     also have "\<dots> = card (kernel G H f)"
       using nonzero_mult_div_cancel_left[OF \<open>totient m \<noteq> 0\<close>] by blast
     finally show ?thesis by auto
   qed
 
   show "card (rcosets\<^bsub>G\<^esub> kernel G H f) = totient m"
   proof -
     have H_size: " totient m = card (carrier H)"
       using n.order Coset.order_def[of H] by simp
     also have "\<dots> = card (carrier (G Mod kernel G H f))" 
       using f.FactGroup_iso[OF image_eq] card_image f.FactGroup_inj_on f.FactGroup_onto image_eq by fastforce
     also have "card (carrier (G Mod kernel G H f)) = 
           card (rcosets\<^bsub>G\<^esub> kernel G H f)" 
       unfolding FactGroup_def by simp 
     finally show "card (rcosets\<^bsub>G\<^esub> kernel G H f) = totient m"
       by argo
   qed
 
   assume "b \<in> rcosets\<^bsub>G\<^esub> kernel G H f"
   then show "b \<noteq> {}"
   proof -
     have "card b = card (kernel G H f)"
       using \<open>b \<in> rcosets\<^bsub>G\<^esub> kernel G H f\<close> f.subgroup_kernel n.card_rcosets_equal n.subgroupE(1) by auto
     then have "card b > 0" 
       by (simp add: k_size)
     then show ?thesis by auto
   qed
 
   assume b_cos: "b \<in> rcosets\<^bsub>G\<^esub> kernel G H f"
   show "card (kernel G H f) = card b" 
     using group.card_rcosets_equal[OF n.is_group b_cos] 
           f.subgroup_kernel subgroup.subset by blast    
 qed
 
 
 lemma primitive_iff_separable_lemma:
  assumes prod: "(\<forall>n. \<chi> n = \<Phi> n * \<chi>\<^sub>1 n) \<and> primitive_dchar d \<Phi>"
  assumes \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close> \<open>k > 1\<close>
  shows "(\<Sum>m | m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
         (totient k div totient d) * (\<Sum>m | m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
 proof -
   from assms interpret \<Phi>: primitive_dchar d "residue_mult_group d" \<Phi>
     by auto
   define G where "G = residue_mult_group k"
   define H where "H = residue_mult_group d"
   define f where "f = (\<lambda>t. t mod d)" 
   
   from residue_mult_group_kernel_partition(2)[OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close>]
   have fin_cosets: "finite (rcosets\<^bsub>G\<^esub> kernel G H f)"         
    using \<open>1 < d\<close> card.infinite by (fastforce simp: G_def H_def f_def)
           
   have fin_G: "finite (carrier G)"
     unfolding G_def residue_mult_group_def by simp
   
   have eq: "(\<Sum>m | m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
          (\<Sum>m | m \<in> carrier G . \<Phi>(m) * unity_root d m)"
    unfolding residue_mult_group_def totatives_def G_def
    by (rule sum.cong,auto)
   also have "\<dots> = sum (\<lambda>m. \<Phi>(m) * unity_root d m) (carrier G)" by simp
   also have eq': "\<dots> = sum (sum (\<lambda>m. \<Phi> m * unity_root d (int m))) (rcosets\<^bsub>G\<^esub> kernel G H f)"
     by (rule disjoint_sum [symmetric])
        (use fin_G fin_cosets residue_mult_group_kernel_partition(1)[OF \<open>d > 1\<close> \<open>k > 0\<close> \<open>d dvd k\<close>] in
           \<open>auto simp: G_def H_def f_def\<close>)
   also have "\<dots> =
    (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)))" by simp
   finally have 1: "(\<Sum>m | m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) =
                    (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)))" 
     using eq eq' by auto
   have eq''': "\<dots> =
     (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
   proof (rule sum.cong,simp) 
     fix b
     assume b_in: "b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f)" 
     note b_not_empty = residue_mult_group_kernel_partition(4)
                          [OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close> b_in[unfolded G_def H_def f_def]] 
   
     {
       fix m1 m2
       assume m_in: "m1 \<in> b" "m2 \<in> b" 
       have m_mod: "m1 mod d = m2 mod d"   
         using residue_mult_group_coset[OF b_in[unfolded G_def H_def f_def] m_in \<open>k > 1\<close> \<open>d dvd k\<close>]
         by blast
     } note m_mod = this
     {
       fix m1 m2
       assume m_in: "m1 \<in> b" "m2 \<in> b" 
       have "\<Phi> m1 * unity_root d (int m1) = \<Phi> m2 * unity_root d (int m2)"
       proof -
         have \<Phi>_periodic: "periodic_arithmetic \<Phi> d" using \<Phi>.dir_periodic_arithmetic by blast
         have 1: "\<Phi> m1 = \<Phi> m2" 
          using mod_periodic_arithmetic[OF \<open>periodic_arithmetic \<Phi> d\<close> m_mod[OF m_in]] by simp 
        have 2: "unity_root d m1 = unity_root d m2"
          using m_mod[OF m_in] by (intro unity_root_cong) (auto simp: cong_def simp flip: zmod_int)
        from 1 2 show ?thesis by simp
       qed
     } note all_eq_in_coset = this   
    
     from all_eq_in_coset b_not_empty 
     obtain l where l_prop: "l \<in> b \<and> (\<forall>y \<in> b. \<Phi> y * unity_root d (int y) = 
                                 \<Phi> l * unity_root d (int l))" by blast
      
     have "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) =
             ((totient k div totient d) * (\<Phi> l * unity_root d (int l)))"
     proof -
       have "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) =
               (\<Sum>m \<in> b. \<Phi> l * unity_root d (int l))"              
           by (rule sum.cong,simp) (use all_eq_in_coset l_prop in blast)
       also have "\<dots> = card b * \<Phi> l * unity_root d (int l)"
         by simp
       also have "\<dots> = (totient k div totient d) * \<Phi> l * unity_root d (int l)"
         using residue_mult_group_kernel_partition(3)[OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close>] 
               residue_mult_group_kernel_partition(5)
                 [OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close> b_in [unfolded G_def H_def f_def]]
         by argo
       finally have 2:
         "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) = 
          (totient k div totient d) * \<Phi> l * unity_root d (int l)" 
         by blast
       from b_not_empty 2 show ?thesis by auto
     qed
     also have "\<dots> = ((totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
     proof -
       have foral: "(\<And>y. y \<in> b \<Longrightarrow> f y = f l)" 
          using m_mod l_prop unfolding f_def by blast
       have eq: "the_elem (f ` b) = f l"
         using the_elem_image_unique[of _ f l, OF b_not_empty foral] by simp
       have per: "periodic_arithmetic \<Phi> d" using prod \<Phi>.dir_periodic_arithmetic by blast
       show ?thesis
         unfolding eq using mod_periodic_arithmetic[OF per, of "l mod d" l]
         by (auto simp: f_def unity_root_mod zmod_int)
     qed
   finally show "(\<Sum>m \<in> b. \<Phi> m * unity_root d (int m)) = 
                  ((totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
     by blast
   qed
   have "\<dots> =
              (\<Sum>b \<in> (rcosets\<^bsub>G\<^esub> kernel G H f) . (totient k div totient d) * (\<Phi> (the_elem (f ` b)) * unity_root d (int (the_elem (f ` b)))))"
     by blast
   also have eq'': "
      \<dots> = (\<Sum>h \<in> carrier H . (totient k div totient d) * (\<Phi> (h) * unity_root d (int (h))))"
     unfolding H_def G_def f_def
     by (rule sum.reindex_bij_betw[OF residue_mult_group_kernel_partition(6)[OF \<open>d > 1\<close> \<open>0 < k\<close> \<open>d dvd k\<close>]])
   finally have 2: "(\<Sum>m | m \<in> {1..k} \<and> coprime m k. \<Phi>(m) * unity_root d m) = 
                   (totient k div totient d)*(\<Sum>h \<in> carrier H .  (\<Phi> (h) * unity_root d (int (h))))"
     using 1 by (simp add: eq'' eq''' sum_distrib_left)
   also have "\<dots> = (totient k div totient d)*(\<Sum>m | m \<in> {1..d} \<and> coprime m d . (\<Phi> (m) * unity_root d (int (m))))"
     unfolding H_def residue_mult_group_def by (simp add: totatives_def Suc_le_eq)
   finally show ?thesis by simp
 qed
 
 
 text \<open>Theorem 8.19\<close>
 theorem (in dcharacter) primitive_iff_separable:
   "primitive_dchar n \<chi> \<longleftrightarrow> (\<forall>k>0. separable k)"
 proof (cases "\<chi> = principal_dchar n")
   case True
   thus ?thesis
     using principal_not_primitive principal_not_totally_separable by auto
 next
   case False
   note nonprincipal = this
   show ?thesis
   proof 
     assume "primitive_dchar n \<chi>" 
     then interpret A: primitive_dchar n "residue_mult_group n" \<chi> by auto
     show "(\<forall>k. k > 0 \<longrightarrow> separable k)" 
       using n A.primitive_encoding(2) by blast
   next
     assume tot_separable: "\<forall>k>0. separable k" 
     {
       assume as: "\<not> primitive_dchar n \<chi>"
       have "\<exists>r. r \<noteq> 0 \<and> \<not> coprime r n \<and> gauss_sum r \<noteq> 0"
       proof -
         from n have "n > 0" by simp
         define d where "d = conductor"
         have "d > 0" unfolding d_def using conductor_gr_0 .
         then have "d > 1" using nonprincipal d_def conductor_eq_1_iff_principal by auto
         have "d < n" unfolding d_def using nonprimitive_imp_conductor_less[OF as] .
         have "d dvd n" unfolding d_def using conductor_dvd by blast
         define r where "r = n div d"
         have 0: "r \<noteq> 0" unfolding r_def 
           using \<open>0 < n\<close> \<open>d dvd n\<close> dvd_div_gt0 by auto
         have "gcd r n > 1" 
           unfolding r_def 
         proof -  
           have "n div d > 1" using \<open>1 < n\<close> \<open>d < n\<close> \<open>d dvd n\<close> by auto
           have "n div d dvd n" using \<open>d dvd n\<close> by force 
           have "gcd (n div d) n = n div d" using gcd_nat.absorb1[OF \<open>n div d dvd n\<close>] by blast
           then show "1 < gcd (n div d) n" using \<open>n div d > 1\<close> by argo
         qed
         then have 1: "\<not> coprime r n" by auto
         define \<chi>\<^sub>1 where "\<chi>\<^sub>1 = principal_dchar n"
         from primitive_principal_form[OF nonprincipal]
         obtain \<Phi> where 
            prod: "(\<forall>k. \<chi>(k) = \<Phi>(k)*\<chi>\<^sub>1(k)) \<and> primitive_dchar d \<Phi>" 
           using d_def unfolding \<chi>\<^sub>1_def by blast
         then have prod1: "(\<forall>k. \<chi>(k) = \<Phi>(k)*\<chi>\<^sub>1(k))" "primitive_dchar d \<Phi>" by blast+ 
         then interpret \<Phi>: primitive_dchar d "residue_mult_group d" \<Phi>
           by auto
     
         have "gauss_sum r  = (\<Sum>m = 1..n . \<chi>(m) * unity_root n (m*r))"
           unfolding gauss_sum_def by blast
         also have "\<dots> = (\<Sum>m = 1..n . \<Phi>(m)*\<chi>\<^sub>1(m) * unity_root n (m*r))"
           by (rule sum.cong,auto simp add: prod) 
         also have "\<dots> = (\<Sum>m | m \<in> {1..n} \<and> coprime m n. \<Phi>(m)*\<chi>\<^sub>1(m) * unity_root n (m*r))"
           by (intro sum.mono_neutral_right) (auto simp: \<chi>\<^sub>1_def principal_dchar_def)
         also have "\<dots> = (\<Sum>m | m \<in> {1..n} \<and> coprime m n. \<Phi>(m)*\<chi>\<^sub>1(m) * unity_root d m)"
         proof (rule sum.cong,simp)
           fix x
           assume "x \<in> {m \<in> {1..n}. coprime m n}" 
           have "unity_root n (int (x * r)) = unity_root d (int x)"
             using unity_div_num[OF \<open>n > 0\<close> \<open>d > 0\<close> \<open>d dvd n\<close>]
             by (simp add: algebra_simps r_def)
           then show "\<Phi> x * \<chi>\<^sub>1 x * unity_root n (int (x * r)) =
                      \<Phi> x * \<chi>\<^sub>1 x * unity_root d (int x)" by auto
         qed
         also have "\<dots> = (\<Sum>m | m \<in> {1..n} \<and> coprime m n. \<Phi>(m) * unity_root d m)"
           by (rule sum.cong,auto simp add: \<chi>\<^sub>1_def principal_dchar_def)
         also have "\<dots> = (totient n div totient d) * (\<Sum>m | m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
           using primitive_iff_separable_lemma[OF prod \<open>d > 1\<close> \<open>n > 0\<close> \<open>d dvd n\<close> \<open>n > 1\<close>] by blast
         also have "\<dots> = (totient n div totient d) * \<Phi>.gauss_sum 1"
         proof -
           have "\<Phi>.gauss_sum 1 = (\<Sum>m = 1..d . \<Phi> m * unity_root d (int (m )))"
             by (simp add: \<Phi>.gauss_sum_def)
           also have "\<dots> = (\<Sum>m | m \<in> {1..d} . \<Phi> m * unity_root d (int m))"
             by (rule sum.cong,auto)
           also have "\<dots> = (\<Sum>m | m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
             by (rule sum.mono_neutral_right) (use \<Phi>.eq_zero in auto)
           finally have "\<Phi>.gauss_sum 1 = (\<Sum>m | m \<in> {1..d} \<and> coprime m d. \<Phi>(m) * unity_root d m)"
             by blast
           then show ?thesis by metis
         qed
         finally have g_expr: "gauss_sum r = (totient n div totient d) * \<Phi>.gauss_sum 1"
           by blast
         have t_non_0: "totient n div totient d \<noteq> 0"
           by (simp add: \<open>0 < n\<close> \<open>d dvd n\<close> dvd_div_gt0 totient_dvd) 
         have "(norm (\<Phi>.gauss_sum 1))\<^sup>2 = d" 
           using \<Phi>.primitive_encoding(3) by simp  
         then have "\<Phi>.gauss_sum 1 \<noteq> 0" 
           using \<open>0 < d\<close> by auto
         then have 2: "gauss_sum r \<noteq> 0"
           using g_expr t_non_0 by auto
         from 0 1 2 show "\<exists>r. r \<noteq> 0 \<and> \<not> coprime r n \<and> gauss_sum r \<noteq> 0" 
           by blast
       qed
     }
     note contr = this
    
     show "primitive_dchar n \<chi>"
     proof (rule ccontr)
       assume "\<not> primitive_dchar n \<chi>"
       then obtain r where 1: "r \<noteq> 0 \<and> \<not> coprime r n \<and> gauss_sum r \<noteq> 0"
         using contr by blast
       from global_separability_condition tot_separable 
       have 2: "(\<forall>k>0. \<not> coprime k n \<longrightarrow> gauss_sum k = 0)" 
         by blast
       from 1 2 show "False" by blast
     qed
   qed
 qed
 
 
 text\<open>Theorem 8.20\<close>
 theorem (in primitive_dchar) fourier_primitive:
   includes no_vec_lambda_notation
   fixes \<tau> :: complex
   defines "\<tau> \<equiv> gauss_sum 1 / sqrt n"
   shows   "\<chi> m = \<tau> / sqrt n * (\<Sum>k=1..n. cnj (\<chi> k) * unity_root n (-m*k))"
   and     "norm \<tau> = 1"
 proof -
   have chi_not_principal: "\<chi> \<noteq> principal_dchar n" 
     using principal_not_totally_separable primitive_encoding(2) by blast
 
   then have case_0: "(\<Sum>k=1..n. \<chi> k) = 0"
   proof -
     have "sum \<chi> {0..n-1} = sum \<chi> {1..n}"
       using periodic_arithmetic_sum_periodic_arithmetic_shift[OF dir_periodic_arithmetic, of 1] n
       by auto
     also have "{0..n-1} = {..<n}"
       using n by auto
     finally show "(\<Sum>n = 1..n . \<chi> n) = 0"
       using sum_dcharacter_block chi_not_principal by simp
   qed
 
   have "\<chi> m =
     (\<Sum>k = 1..n. 1 / of_nat n * gauss_sum_int (- int k) *
       unity_root n (int (m * k)))"
     using dcharacter_fourier_expansion[of m] by auto
   also have "\<dots> = (\<Sum>k = 1..n. 1 / of_nat n * gauss_sum (nat ((- k) mod n)) *
       unity_root n (int (m * k)))"
     by (auto simp: gauss_sum_int_conv_gauss_sum)
   also have "\<dots> = (\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat ((- k) mod n))) * gauss_sum 1 * unity_root n (int (m * k)))"
   proof (rule sum.cong,simp)
     fix k
     assume "k \<in> {1..n}" 
     have "gauss_sum (nat (- int k mod int n)) = 
           cnj (\<chi> (nat (- int k mod int n))) * gauss_sum 1"
     proof (cases "nat ((- k) mod n) > 0")
       case True
       then show ?thesis 
         using mp[OF spec[OF primitive_encoding(2)] True]
         unfolding separable_def by auto
     next
       case False
       then have nat_0: "nat ((- k) mod n) = 0" by blast
       show ?thesis 
       proof -
         have "gauss_sum (nat (- int k mod int n)) = gauss_sum 0" 
           using nat_0 by argo
         also have "\<dots> =  (\<Sum>m = 1..n. \<chi> m)" 
           unfolding gauss_sum_def by (rule sum.cong) auto
         also have "\<dots> = 0" using case_0 by blast
         finally have 1: "gauss_sum (nat (- int k mod int n)) = 0"
           by blast
 
         have 2: "cnj (\<chi> (nat (- int k mod int n))) = 0"
           using nat_0 zero_eq_0 by simp
         show ?thesis using 1 2 by simp
       qed
     qed
     then show "1 / of_nat n * gauss_sum (nat (- int k mod int n)) * unity_root n (int (m * k)) =
                1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) * gauss_sum 1 * unity_root n (int (m * k))" 
       by auto
   qed
   also have "\<dots> = (\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) * 
                     gauss_sum 1 * unity_root n (int (m * (nat (int k mod int n)))))"
   proof (rule sum.cong,simp)
     fix x   
     assume "x \<in> {1..n}" 
     have "unity_root n (m * x) = unity_root n (m * x mod n)"
       using unity_root_mod_nat[of n "m*x"] by (simp add: nat_mod_as_int)
     also have "\<dots> = unity_root n (m * (x mod n))"
       by (rule unity_root_cong)
          (auto simp: cong_def mod_mult_right_eq simp flip: zmod_int of_nat_mult)
     finally have "unity_root n (m * x) = unity_root n (m * (x mod n))" by blast
     then show "1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
                  gauss_sum 1 * unity_root n (int (m * x)) =
                1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) * gauss_sum 1 *
                  unity_root n (int (m * nat (int x mod int n)))" 
       by (simp add: nat_mod_as_int)    
   qed
   also have "\<dots> = (\<Sum>k = 0..n-1. 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 * unity_root n (- int (m * k)))"
   proof -
     have b: "bij_betw (\<lambda>k. nat((-k) mod n)) {1..n} {0..n-1}"
       unfolding bij_betw_def
     proof 
       show "inj_on (\<lambda>k. nat (- int k mod int n)) {1..n}"
         unfolding inj_on_def
       proof (safe)
         fix x y
         assume a1: "x \<in> {1..n}" "y \<in> {1..n}"
         assume a2: "nat (- x mod n) = nat (- y mod n)"
         then have "(- x) mod n = - y mod n"
           using n eq_nat_nat_iff by auto
         then have "[-int x = - int y] (mod n)" 
           using cong_def by blast
         then have "[x = y] (mod n)" 
           by (simp add: cong_int_iff cong_minus_minus_iff)
         then have cong: "x mod n = y mod n" using cong_def by blast
         then show "x = y"
         proof (cases "x = n")
           case True then show ?thesis using cong a1(2) by auto
         next
           case False
           then have "x mod n = x" using a1(1) by auto
           then have "y \<noteq> n" using a1(1) local.cong by fastforce
           then have "y mod n = y" using a1(2) by auto
           then show ?thesis using \<open>x mod n = x\<close> cong by linarith
         qed
       qed
       show "(\<lambda>k. nat (- int k mod int n)) ` {1..n} = {0..n - 1}"
         unfolding image_def 
       proof
         let ?A = "{y. \<exists>x\<in>{1..n}. y = nat (- int x mod int n)}"
         let ?B = "{0..n - 1}" 
         show "?A \<subseteq> ?B" 
         proof
           fix y
           assume "y \<in> {y. \<exists>x\<in>{1..n}. y = nat (- int x mod int n)}"
           then obtain x where "x\<in>{1..n} \<and> y = nat (- int x mod int n)" by blast
           then show "y \<in> {0..n - 1}" by (simp add: nat_le_iff of_nat_diff)
         qed
         show "?A \<supseteq> ?B" 
         proof 
           fix x
           assume 1: "x \<in> {0..n-1}"
           then have "n - x \<in> {1..n}"
             using n by auto
           have "x = nat (- int (n-x) mod int n)"
           proof -
             have "nat (- int (n-x) mod int n) = nat (int x) mod int n"
               apply(simp add: int_ops(6),rule conjI)
               using \<open>n - x \<in> {1..n}\<close> by force+
             also have "\<dots> = x" 
               using 1 n by auto
             finally show ?thesis by presburger
           qed
           then show "x \<in> {y. \<exists>x\<in>{1..n}. y = nat (- int x mod int n)}"
             using \<open>n - x \<in> {1..n}\<close> by blast
         qed
       qed
     qed
     show ?thesis 
     proof -
       have 1: "(\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) *
         gauss_sum 1 * unity_root n (int (m * nat (int k mod int n)))) = 
             (\<Sum>x = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
         gauss_sum 1 * unity_root n (- int (m * nat (- int x mod int n))))"
       proof (rule sum.cong,simp)
         fix x        
         have "(int m * (int x mod int n)) mod n = (m*x) mod n"
           by (simp add: mod_mult_right_eq zmod_int)
         also have "\<dots> = (- ((- int (m*x) mod n))) mod n"
           by (simp add: mod_minus_eq of_nat_mod)
         have "(int m * (int x mod int n)) mod n = (- (int m * (- int x mod int n))) mod n"
           apply(subst mod_mult_right_eq,subst add.inverse_inverse[symmetric],subst (5) add.inverse_inverse[symmetric])
           by (subst minus_mult_minus,subst mod_mult_right_eq[symmetric],auto)
         then have "unity_root n (int m * (int x mod int n)) =
                    unity_root n (- (int m * (- int x mod int n)))"
           using unity_root_mod[of n "int m * (int x mod int n)"] 
                  unity_root_mod[of n " - (int m * (- int x mod int n))"] by argo
         then show "1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
          gauss_sum 1 *
          unity_root n (int (m * nat (int x mod int n))) =
          1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
          gauss_sum 1 *
-         unity_root n (- int (m * nat (- int x mod int n)))" by auto
+         unity_root n (- int (m * nat (- int x mod int n)))"
+          by clarsimp
       qed
       also have 2: "(\<Sum>x = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int x mod int n))) *
           gauss_sum 1 * unity_root n (- int (m * nat (- int x mod int n)))) =
             (\<Sum>md = 0..n - 1. 1 / of_nat n * cnj (\<chi> md) * gauss_sum 1 *
           unity_root n (- int (m * md)))"
        using sum.reindex_bij_betw[OF b, of "\<lambda>md. 1 / of_nat n * cnj (\<chi> md) * gauss_sum 1 * unity_root n (- int (m * md))"]
        by blast
       also have 3: "\<dots> = (\<Sum>k = 0..n - 1.
         1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 *
         unity_root n (- int (m * k)))" by blast
       finally have "(\<Sum>k = 1..n. 1 / of_nat n * cnj (\<chi> (nat (- int k mod int n))) *
         gauss_sum 1 * unity_root n (int (m * nat (int k mod int n)))) = 
           (\<Sum>k = 0..n - 1.
         1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 *
         unity_root n (- int (m * k)))" using 1 2 3 by argo
       then show ?thesis by blast
     qed
   qed
   also have "\<dots> = (\<Sum>k = 1..n.
          1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 *
          unity_root n (- int (m * k)))"
   proof -
     let ?f = "(\<lambda>k. 1 / of_nat n * cnj (\<chi> k) * gauss_sum 1 * unity_root n (- int (m * k)))"
     have "?f 0 = 0" 
       using zero_eq_0 by auto
     have "?f n = 0" 
       using zero_eq_0 mod_periodic_arithmetic[OF dir_periodic_arithmetic, of n 0]
       by simp
     have "(\<Sum>n = 0..n - 1. ?f n) = (\<Sum>n = 1..n - 1. ?f n)"
       using sum_shift_lb_Suc0_0[of ?f, OF \<open>?f 0 = 0\<close>]
       by auto
     also have "\<dots> = (\<Sum>n = 1..n. ?f n)"
     proof (rule sum.mono_neutral_left,simp,simp,safe)
       fix i
       assume "i \<in> {1..n}" "i \<notin> {1..n - 1}" 
       then have "i = n" using n by auto
       then show "1 / of_nat n * cnj (\<chi> i) * gauss_sum 1 * unity_root n (- int (m * i)) = 0" 
         using \<open>?f n = 0\<close> by blast
     qed
     finally show ?thesis by blast
   qed
   also have "\<dots> = (\<Sum>k = 1..n. (\<tau> / sqrt n) * cnj (\<chi> k) * unity_root n (- int (m * k)))"
   proof (rule sum.cong,simp)
     fix x
     assume "x \<in> {1..n}"
     have "\<tau> / sqrt (real n) = 1 / of_nat n  * gauss_sum 1"
     proof -
       have "\<tau> / sqrt (real n) = gauss_sum 1 / sqrt n / sqrt n"
         using assms by auto
       also have "\<dots> = gauss_sum 1 / (sqrt n * sqrt n)"
         by (subst divide_divide_eq_left,subst of_real_mult,blast) 
       also have "\<dots> = gauss_sum 1 / n" 
         using real_sqrt_mult_self by simp
       finally show ?thesis by simp
     qed
     then show 
      "1 / of_nat n * cnj (\<chi> x) * gauss_sum 1 * unity_root n (- int (m * x)) =
       (\<tau> / sqrt n) * cnj (\<chi> x) * unity_root n (- int (m * x))" by simp
   qed
   also have "\<dots> = \<tau> / sqrt (real n) * 
          (\<Sum>k = 1..n. cnj (\<chi> k) * unity_root n (- int (m * k)))"
   proof -
     have "(\<Sum>k = 1..n. \<tau> / sqrt (real n) * cnj (\<chi> k) * unity_root n (- int (m * k))) = 
           (\<Sum>k = 1..n. \<tau> / sqrt (real n) * (cnj (\<chi> k) *  unity_root n (- int (m * k))))" 
       by (rule sum.cong,simp, simp add: algebra_simps)
     also have "\<dots> = \<tau> / sqrt (real n) * (\<Sum>k = 1..n. cnj (\<chi> k) * unity_root n (- int (m * k)))"
       by (rule sum_distrib_left[symmetric])
     finally show ?thesis by blast
   qed
 
   finally show "\<chi> m = (\<tau> / sqrt (real n)) *
     (\<Sum>k=1..n. cnj (\<chi> k) * unity_root n (- int m * int k))" by simp
 
   have 1: "norm (gauss_sum 1) = sqrt n" 
     using gauss_sum_1_mod_square_eq_k[OF primitive_encoding(2)]
     by (simp add: cmod_def)
   from assms have 2: "norm \<tau> = norm (gauss_sum 1) / \<bar>sqrt n\<bar>"
     by (simp add: norm_divide)
   show "norm \<tau> = 1" using 1 2 n by simp
 qed
 
 unbundle vec_lambda_notation
 
 end
\ No newline at end of file
diff --git a/thys/Group-Ring-Module/Algebra4.thy b/thys/Group-Ring-Module/Algebra4.thy
--- a/thys/Group-Ring-Module/Algebra4.thy
+++ b/thys/Group-Ring-Module/Algebra4.thy
@@ -1,6922 +1,6922 @@
 (**       Algebra4
                             author Hidetsune Kobayashi
                                    Lingjun Chen (part of Chap 4. section 2,
                                    with revision by H. Kobayashi)
                              Group You Santo
                              Department of Mathematics
                              Nihon University
                              h_coba@math.cst.nihon-u.ac.jp
                              May 3, 2004.
                              April 6, 2007 (revised)
 
  chapter 3.  Group Theory. Focused on Jordan Hoelder theorem (continued)
      section 20.   abelian groups
      subsection 20-1. Homomorphism of abelian groups
      subsection 20-2  quotient abelian group
    section 21  direct product and direct sum of abelian groups,
                in general case
 
  chapter 4.  Ring theory
    section 1.  Definition of a ring and an ideal
    section 2.  Calculation of elements
    section 3.  ring homomorphisms
    section 4.  quotient rings
    section 5.  primary ideals, prime ideals
  **)
 
 theory Algebra4
 imports Algebra3
 begin
 
 section "Abelian groups"
 
 record 'a aGroup = "'a carrier" +
   pop      :: "['a, 'a ] \<Rightarrow> 'a"  (infixl "\<plusminus>\<index>" 62)
   mop      :: "'a  \<Rightarrow> 'a"        ("(-\<^sub>a\<index> _)" [64]63 )
   zero     :: "'a"               ("\<zero>\<index>")
 
 locale aGroup =
   fixes A (structure)
  assumes
          pop_closed: "pop A \<in> carrier A \<rightarrow> carrier A \<rightarrow> carrier A"
  and     aassoc : "\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A\<rbrakk> \<Longrightarrow>
          (a \<plusminus> b) \<plusminus> c = a \<plusminus> (b \<plusminus> c)"
  and     pop_commute:"\<lbrakk>a \<in> carrier A; b \<in> carrier A\<rbrakk> \<Longrightarrow> a \<plusminus> b = b \<plusminus> a"
  and     mop_closed:"mop A \<in> carrier A \<rightarrow> carrier A"
  and     l_m :"a \<in> carrier A \<Longrightarrow>  (-\<^sub>a a) \<plusminus> a = \<zero>"
  and     ex_zero: "\<zero> \<in> carrier A"
  and     l_zero:"a \<in> carrier A \<Longrightarrow> \<zero> \<plusminus> a = a"
 
 definition
   b_ag :: "_  \<Rightarrow>
    \<lparr>carrier:: 'a set, top:: ['a, 'a] \<Rightarrow> 'a , iop:: 'a \<Rightarrow> 'a, one:: 'a \<rparr>" where
   "b_ag A = \<lparr>carrier = carrier A, top = pop A, iop = mop A, one = zero A \<rparr>"
 
 definition
   asubGroup :: "[_ , 'a set] \<Rightarrow> bool" where
   "asubGroup A H \<longleftrightarrow> (b_ag A) \<guillemotright> H"
 
 definition
   aqgrp :: "[_ , 'a set] \<Rightarrow>
          \<lparr> carrier::'a set set, pop::['a  set, 'a set] \<Rightarrow> 'a set,
            mop::'a set \<Rightarrow> 'a set, zero :: 'a set \<rparr>" where
   "aqgrp A H = \<lparr>carrier = set_rcs (b_ag A) H,
          pop = \<lambda>X. \<lambda>Y. (c_top (b_ag A) H X Y),
          mop = \<lambda>X. (c_iop (b_ag A) H X), zero = H \<rparr>"
 
 definition
   ag_idmap :: "_ \<Rightarrow> ('a \<Rightarrow> 'a)"  ("(aI\<^bsub>_\<^esub>)") where
   "aI\<^bsub>A\<^esub> = (\<lambda>x\<in>carrier A. x)"
 
 abbreviation
   ASubG :: "[('a, 'more) aGroup_scheme, 'a set] => bool"   (infixl "+>" 58) where
   "A +> H == asubGroup A H"
 
 definition
   Ag_ind :: "[_ , 'a \<Rightarrow> 'd] \<Rightarrow> 'd aGroup" where
   "Ag_ind A f = \<lparr>carrier = f`(carrier A),
     pop = \<lambda>x \<in> f`(carrier A). \<lambda>y \<in> f`(carrier A).
                f(((invfun (carrier A) (f`(carrier A)) f) x) \<plusminus>\<^bsub>A\<^esub>
                     ((invfun (carrier A) (f`(carrier A)) f) y)),
     mop = \<lambda>x\<in>(f`(carrier A)). f (-\<^sub>a\<^bsub>A\<^esub> ((invfun (carrier A) (f`(carrier A)) f) x)),
     zero = f (\<zero>\<^bsub>A\<^esub>)\<rparr>"
 
 definition
   Agii :: "[_ , 'a \<Rightarrow> 'd] \<Rightarrow> ('a \<Rightarrow> 'd)" where
   "Agii A f = (\<lambda>x\<in>carrier A. f x)"   (** Ag_induced_isomorphism **)
 
 lemma (in aGroup) ag_carrier_carrier:"carrier (b_ag A) = carrier A"
 by (simp add:b_ag_def)
 
 lemma (in aGroup) ag_pOp_closed:"\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow>
                                      pop A x y \<in> carrier A"
 apply (cut_tac pop_closed)
 apply (frule funcset_mem[of "(\<plusminus>) " "carrier A" "carrier A \<rightarrow> carrier A" "x"],
         assumption+)
 apply (rule funcset_mem[of "(\<plusminus>) x" "carrier A" "carrier A" "y"], assumption+)
 done
 
 lemma (in aGroup) ag_mOp_closed:"x \<in> carrier A \<Longrightarrow> (-\<^sub>a x)  \<in> carrier A"
 apply (cut_tac mop_closed)
 apply (rule funcset_mem[of "mop A" "carrier A" "carrier A" "x"], assumption+)
 done
 
 lemma (in aGroup) asubg_subset:"A +> H \<Longrightarrow> H \<subseteq> carrier A"
 apply (simp add:asubGroup_def)
 apply (simp add:sg_def, (erule conjE)+)
 apply (simp add:ag_carrier_carrier)
 done
 
 lemma (in aGroup) ag_pOp_commute:"\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk>  \<Longrightarrow>
            pop A x y = pop A y x"
 by (simp add:pop_commute)
 
 lemma (in aGroup) b_ag_group:"Group (b_ag A)"
 apply (unfold Group_def)
  apply (simp add:b_ag_def)
 apply (simp add:pop_closed mop_closed ex_zero)
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:aassoc)
 apply (rule conjI)
  apply (rule allI, rule impI)
  apply (simp add:l_m)
 
  apply (rule allI, rule impI)
  apply (simp add:l_zero)
 done
 
 lemma (in aGroup) agop_gop:"top (b_ag A) = pop A" (*agpop_gtop*)
  apply (simp add:b_ag_def)
 done
 
 lemma (in aGroup) agiop_giop:"iop (b_ag A) = mop A" (*agmop_giop*)
 apply (simp add:b_ag_def)
 done
 
 lemma (in aGroup) agunit_gone:"one (b_ag A) = \<zero>"
 apply (simp add:b_ag_def)
 done
 
 lemma (in aGroup) ag_pOp_add_r:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;
                  a = b\<rbrakk>  \<Longrightarrow> a \<plusminus> c =  b \<plusminus> c"
 apply simp
 done
 
 lemma (in aGroup) ag_add_commute:"\<lbrakk>a \<in> carrier A; b \<in> carrier A\<rbrakk> \<Longrightarrow>
                                                   a \<plusminus> b = b \<plusminus> a"
 by (simp add:pop_commute)
 
 lemma (in aGroup) ag_pOp_add_l:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;
                  a = b\<rbrakk>  \<Longrightarrow> c \<plusminus> a =  c \<plusminus> b"
 apply simp
 done
 
 lemma (in aGroup) asubg_pOp_closed:"\<lbrakk>asubGroup A H; x \<in> H; y \<in> H\<rbrakk>
                                    \<Longrightarrow> pop A x y \<in> H"
 apply (simp add:asubGroup_def)
  apply (cut_tac b_ag_group)
  apply (frule Group.sg_mult_closed [of "b_ag A" "H" "x" "y"], assumption+)
 apply (simp only:agop_gop)
 done
 
 lemma (in aGroup) asubg_mOp_closed:"\<lbrakk>asubGroup A H; x \<in> H\<rbrakk> \<Longrightarrow> -\<^sub>a x \<in> H"
 apply (simp add:asubGroup_def)
 apply (cut_tac b_ag_group)
 apply (frule Group.sg_i_closed[of "b_ag A" "H" "x"], assumption+)
 apply (simp add:agiop_giop)
 done
 
 lemma (in aGroup) asubg_subset1:"\<lbrakk>asubGroup A H; x \<in> H\<rbrakk> \<Longrightarrow> x \<in> carrier A"
 apply (simp add:asubGroup_def)
 apply (cut_tac b_ag_group)
 apply (frule Group.sg_subset_elem[of "b_ag A" "H" "x"], assumption+)
 apply (simp add:ag_carrier_carrier)
 done
 
 lemma (in aGroup) asubg_inc_zero:"asubGroup A H \<Longrightarrow> \<zero> \<in> H"
 apply (simp add:asubGroup_def)
 apply (cut_tac b_ag_group)
 apply (frule Group.sg_unit_closed[of "b_ag A" "H"], assumption)
 apply (simp add:b_ag_def)
 done
 
 lemma (in aGroup) ag_inc_zero:"\<zero> \<in> carrier A"
 by (simp add:ex_zero)
 
 lemma (in aGroup) ag_l_zero:"x \<in> carrier A \<Longrightarrow> \<zero> \<plusminus> x = x"
 by (simp add:l_zero)
 
 lemma (in aGroup) ag_r_zero:"x \<in> carrier A \<Longrightarrow> x \<plusminus> \<zero> = x"
 apply (cut_tac ex_zero)
 apply (subst pop_commute, assumption+)
 apply (rule ag_l_zero, assumption)
 done
 
 lemma (in aGroup) ag_l_inv1:"x \<in> carrier A \<Longrightarrow> (-\<^sub>a x) \<plusminus> x = \<zero>"
 by (simp add:l_m)
 
 lemma (in aGroup) ag_r_inv1:"x \<in> carrier A \<Longrightarrow> x \<plusminus> (-\<^sub>a x) = \<zero>"
 by (frule ag_mOp_closed[of "x"],
        subst ag_pOp_commute, assumption+,
        simp add:ag_l_inv1)
 
 lemma (in aGroup) ag_pOp_assoc:"\<lbrakk>x \<in> carrier A; y \<in> carrier A; z \<in> carrier A\<rbrakk>
                 \<Longrightarrow> (x \<plusminus> y) \<plusminus> z = x \<plusminus> (y \<plusminus> z)"
 by (simp add:aassoc)
 
 lemma (in aGroup) ag_inv_unique:"\<lbrakk>x \<in> carrier A; y \<in> carrier A; x \<plusminus> y = \<zero>\<rbrakk> \<Longrightarrow>
                                      y = -\<^sub>a x"
 apply (frule ag_mOp_closed[of "x"],
        frule aassoc[of "-\<^sub>a x" "x" "y"], assumption+,
        simp add:l_m l_zero ag_r_zero)
 done
 
 lemma (in aGroup) ag_inv_inj:"\<lbrakk>x \<in> carrier A; y \<in> carrier A; x \<noteq> y\<rbrakk> \<Longrightarrow>
                                           (-\<^sub>a x) \<noteq> (-\<^sub>a y)"
 apply (rule contrapos_pp, simp+)
 apply (frule ag_mOp_closed[of "y"],
        frule aassoc[of "y" "-\<^sub>a y" "x"], assumption+)
 apply (simp only:ag_r_inv1,
        frule sym, thin_tac "-\<^sub>a x = -\<^sub>a y", simp add:l_m)
 apply (simp add:l_zero ag_r_zero)
 done
 
 lemma (in aGroup) pOp_assocTr41:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;
  d \<in> carrier A\<rbrakk> \<Longrightarrow> a \<plusminus> b \<plusminus> c \<plusminus> d = a \<plusminus> b \<plusminus> (c \<plusminus> d)"
 by (frule ag_pOp_closed[of "a" "b"], assumption+,
     rule aassoc[of "a \<plusminus> b" "c" "d"], assumption+)
 
 lemma (in aGroup) pOp_assocTr42:"\<lbrakk>a \<in> carrier A; b \<in> carrier A;
  c \<in> carrier A; d \<in> carrier A\<rbrakk> \<Longrightarrow> a \<plusminus> b \<plusminus> c \<plusminus> d = a \<plusminus> (b \<plusminus> c) \<plusminus> d"
 by (simp add:aassoc[THEN sym, of "a" "b" "c"])
 
 lemma (in aGroup) pOp_assocTr43:"\<lbrakk>a \<in> carrier A; b \<in> carrier A;
  c \<in> carrier A; d \<in> carrier A\<rbrakk> \<Longrightarrow> a \<plusminus> b \<plusminus> (c \<plusminus> d) = a \<plusminus> (b \<plusminus> c) \<plusminus> d"
 by (subst  pOp_assocTr41[THEN sym], assumption+,
        rule pOp_assocTr42, assumption+)
 
 lemma (in aGroup) pOp_assoc_cancel:"\<lbrakk>a \<in> carrier A; b \<in> carrier A;
  c \<in> carrier A\<rbrakk> \<Longrightarrow> a \<plusminus> -\<^sub>a b \<plusminus> (b \<plusminus> -\<^sub>a c) = a \<plusminus> -\<^sub>a c"
 apply (subst pOp_assocTr43, assumption)
 apply (simp add:ag_l_inv1 ag_mOp_closed)+
 apply (simp add:ag_r_zero)
 done
 
 lemma (in aGroup) ag_p_inv:"\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow>
                                      (-\<^sub>a (x \<plusminus> y)) = (-\<^sub>a x) \<plusminus> (-\<^sub>a y)"
 apply (frule ag_mOp_closed[of "x"], frule ag_mOp_closed[of "y"],
        frule ag_pOp_closed[of "x" "y"], assumption+)
 apply (frule aassoc[of "x \<plusminus> y" "-\<^sub>a x" "-\<^sub>a y"], assumption+,
        simp add:pOp_assocTr43, simp add:pop_commute[of "y" "-\<^sub>a x"],
        simp add:aassoc[THEN sym, of "x" "-\<^sub>a x" "y"],
        simp add:ag_r_inv1 l_zero)
 apply (frule ag_pOp_closed[of "-\<^sub>a x" "-\<^sub>a y"], assumption+,
        simp add:pOp_assocTr41,
        rule ag_inv_unique[THEN sym, of "x \<plusminus> y" "-\<^sub>a x \<plusminus> -\<^sub>a y"], assumption+)
 done
 
 lemma (in aGroup) gEQAddcross: "\<lbrakk>l1 \<in> carrier A; l2 \<in> carrier A;
       r1 \<in> carrier A; r1 \<in> carrier A; l1 = r2; l2 = r1\<rbrakk> \<Longrightarrow>
                           l1 \<plusminus> l2 = r1 \<plusminus> r2"
   apply (simp add:ag_pOp_commute)
   done
 
 lemma (in aGroup) ag_eq_sol1:"\<lbrakk>a \<in> carrier A; x\<in> carrier A; b\<in> carrier A;
                                a \<plusminus> x = b\<rbrakk> \<Longrightarrow> x = (-\<^sub>a a) \<plusminus> b"
 apply (frule ag_mOp_closed[of "a"])
 apply (frule aassoc[of "-\<^sub>a a" "a" "x"], assumption+)
 apply (simp add:l_m l_zero)
 done
 
 lemma (in aGroup) ag_eq_sol2:"\<lbrakk>a \<in> carrier A; x\<in> carrier A; b\<in> carrier A;
                                 x \<plusminus> a = b\<rbrakk> \<Longrightarrow> x = b \<plusminus> (-\<^sub>a a)"
 apply (frule ag_mOp_closed[of "a"],
        frule aassoc[of "x" "a" "-\<^sub>a a"], assumption+,
        simp add:ag_r_inv1 ag_r_zero)
 done
 
 lemma (in aGroup) ag_add4_rel:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;
  d \<in> carrier A \<rbrakk> \<Longrightarrow> a \<plusminus> b \<plusminus> (c \<plusminus> d) =  a \<plusminus> c \<plusminus> (b \<plusminus> d)"
 apply (simp add:pOp_assocTr43[of "a" "b" "c" "d"],
        simp add:ag_pOp_commute[of "b" "c"],
        simp add:pOp_assocTr43[THEN sym, of "a" "c" "b" "d"])
 done
 
 lemma (in aGroup) ag_inv_inv:"x \<in> carrier A \<Longrightarrow> -\<^sub>a (-\<^sub>a x) = x"
 by (frule ag_l_inv1[of "x"], frule ag_mOp_closed[of "x"],
        rule  ag_inv_unique[THEN sym, of "-\<^sub>a x" "x"], assumption+)
 
 lemma (in aGroup) ag_inv_zero:"-\<^sub>a \<zero> = \<zero>"
 apply (cut_tac ex_zero)
 apply (frule l_zero[of "\<zero>"])
 apply (rule ag_inv_unique[THEN sym], assumption+)
 done
 
 lemma (in aGroup) ag_diff_minus:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;
                    a \<plusminus> (-\<^sub>a b) = c\<rbrakk> \<Longrightarrow> b \<plusminus> (-\<^sub>a a) = (-\<^sub>a c)"
 apply (frule sym, thin_tac "a \<plusminus> -\<^sub>a b = c", simp, thin_tac "c = a \<plusminus> -\<^sub>a b")
 apply (frule ag_mOp_closed[of "b"], frule ag_mOp_closed[of "a"],
        subst ag_p_inv, assumption+, subst ag_inv_inv, assumption)
 apply (simp add:ag_pOp_commute)
 done
 
 lemma (in aGroup) pOp_cancel_l:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;                    c \<plusminus> a =  c \<plusminus> b \<rbrakk> \<Longrightarrow> a = b"
 apply (frule ag_mOp_closed[of "c"],
        frule aassoc[of "-\<^sub>a c" "c" "a"], assumption+,
        simp only:l_m l_zero)
 apply (simp only:aassoc[THEN sym, of "-\<^sub>a c" "c" "b"],
         simp only:l_m l_zero)
 done
 
 lemma (in aGroup) pOp_cancel_r:"\<lbrakk>a \<in> carrier A; b \<in> carrier A; c \<in> carrier A;               a \<plusminus> c =  b \<plusminus> c \<rbrakk> \<Longrightarrow> a = b"
 by (simp add:ag_pOp_commute pOp_cancel_l)
 
 lemma (in aGroup) ag_eq_diffzero:"\<lbrakk>a \<in> carrier A; b \<in> carrier A\<rbrakk> \<Longrightarrow>
                        (a = b) = (a \<plusminus> (-\<^sub>a b) = \<zero>)"
 apply (rule iffI)
  apply (simp add:ag_r_inv1)
  apply (frule ag_mOp_closed[of "b"])
  apply (simp add:ag_pOp_commute[of "a" "-\<^sub>a b"])
  apply (subst ag_inv_unique[of "-\<^sub>a b" "a"], assumption+,
         simp add:ag_inv_inv)
 done
 
 lemma (in aGroup) ag_eq_diffzero1:"\<lbrakk>a \<in> carrier A; b \<in> carrier A\<rbrakk> \<Longrightarrow>
                        (a = b) = ((-\<^sub>a a) \<plusminus> b = \<zero>)"
 apply (frule ag_mOp_closed[of a],
        simp add:ag_pOp_commute)
 apply (subst ag_eq_diffzero[THEN sym], assumption+)
 apply (rule iffI, rule sym, assumption)
 apply (rule sym, assumption)
 done
 
 lemma (in aGroup) ag_neq_diffnonzero:"\<lbrakk>a \<in> carrier A; b \<in> carrier A\<rbrakk> \<Longrightarrow>
          (a \<noteq> b) = (a \<plusminus> (-\<^sub>a b) \<noteq>  \<zero>)"
 apply (rule iffI)
  apply (rule contrapos_pp, simp+)
  apply (simp add:ag_eq_diffzero[THEN sym])
 apply (rule contrapos_pp, simp+)
  apply (simp add:ag_r_inv1)
 done
 
 lemma (in aGroup) ag_plus_zero:"\<lbrakk>x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow>
                      (x = -\<^sub>a y)  = (x \<plusminus> y = \<zero>)"
 apply (rule iffI)
  apply (simp add:ag_l_inv1)
 apply (simp add:ag_pOp_commute[of "x" "y"])
 apply (rule ag_inv_unique[of "y" "x"], assumption+)
 done
 
 lemma (in aGroup) asubg_nsubg:"A +> H \<Longrightarrow>  (b_ag A) \<triangleright> H"
 apply (cut_tac b_ag_group)
 apply (simp add:asubGroup_def)
 apply (rule Group.cond_nsg[of "b_ag A" "H"], assumption+)
 apply (rule ballI)+
 apply(simp add:agop_gop agiop_giop)
  apply (frule Group.sg_subset[of "b_ag A" "H"], assumption)
  apply (simp add:ag_carrier_carrier)
 apply (frule_tac c = h in subsetD[of "H" "carrier A"], assumption+)
  apply (subst ag_pOp_commute, assumption+)
  apply (frule_tac x = a in ag_mOp_closed)
  apply (subst aassoc, assumption+, simp add:ag_r_inv1 ag_r_zero)
 done
 
 lemma (in aGroup) subg_asubg:"b_ag G \<guillemotright> H \<Longrightarrow> G +> H"
 apply (simp add:asubGroup_def)
 done
 
 lemma (in aGroup) asubg_test:"\<lbrakk>H \<subseteq> carrier A; H \<noteq> {};
                \<forall>a\<in>H. \<forall>b\<in>H. (a \<plusminus> (-\<^sub>a b) \<in> H)\<rbrakk> \<Longrightarrow> A +> H"
 apply (simp add:asubGroup_def) apply (cut_tac b_ag_group)
 apply (rule Group.sg_condition [of "b_ag A" "H"], assumption+)
  apply (simp add:ag_carrier_carrier) apply assumption
 apply (rule allI)+ apply (rule impI)
 apply (simp add:agop_gop agiop_giop)
 done
 
 lemma (in aGroup) asubg_zero:"A +> {\<zero>}"
 apply (rule asubg_test[of "{\<zero>}"])
  apply (simp add:ag_inc_zero)
  apply simp
  apply (simp, cut_tac ag_inc_zero, simp add:ag_r_inv1)
 done
 
 lemma (in aGroup) asubg_whole:"A +> carrier A"
 apply (rule asubg_test[of "carrier A"])
 apply (simp,
        cut_tac ag_inc_zero, simp add:nonempty)
 apply ((rule ballI)+,
        rule ag_pOp_closed, assumption,
        rule_tac x = b in ag_mOp_closed, assumption)
 done
 
 lemma (in aGroup) Ag_ind_carrier:"bij_to f (carrier A) (D::'d set) \<Longrightarrow>
                carrier (Ag_ind A f) = f ` (carrier A)"
 by (simp add:Ag_ind_def)
 
 lemma (in aGroup) Ag_ind_aGroup:"\<lbrakk>f \<in> carrier A \<rightarrow> D;
       bij_to f (carrier A) (D::'d set)\<rbrakk> \<Longrightarrow> aGroup (Ag_ind A f)"
 apply (simp add:bij_to_def, frule conjunct1, frule conjunct2, fold bij_to_def)
 apply (simp add:aGroup_def)
  apply (rule conjI)
  apply (rule Pi_I)+
  apply (simp add:Ag_ind_carrier surj_to_def)
  apply (frule_tac b = x in invfun_mem1[of "f" "carrier A" "D"], assumption+,
         frule_tac b = xa in invfun_mem1[of "f" "carrier A" "D"], assumption+)
 apply (simp add:Ag_ind_def)
  apply (rule funcset_mem[of "f" "carrier A" "D"], assumption)
  apply (simp add:ag_pOp_closed)
 
  apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add: Ag_ind_carrier surj_to_def)
  apply (frule_tac b = a in invfun_mem1[of "f" "carrier A" "D"], assumption+,
         frule_tac b = b in invfun_mem1[of "f" "carrier A" "D"], assumption+,
         frule_tac b = c in invfun_mem1[of "f" "carrier A" "D"], assumption+)
  apply (simp add:Ag_ind_def)
  apply (frule_tac x = "invfun (carrier A) D f a" and
                   y = "invfun (carrier A) D f b" in ag_pOp_closed, assumption+,
         frule_tac x = "invfun (carrier A) D f b" and
                   y = "invfun (carrier A) D f c" in ag_pOp_closed, assumption+)
  apply (simp add:Pi_def)
  apply (unfold bij_to_def, frule conjunct1, fold bij_to_def)
  apply (simp add:invfun_l)
  apply (subst injective_iff[of "f" "carrier A", THEN sym], assumption)
  apply (simp add:ag_pOp_closed)+
  apply (simp add:ag_pOp_assoc)
 
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:Ag_ind_def)
  apply (subst injective_iff[of "f" "carrier A", THEN sym], assumption)
  apply (frule_tac b = a in invfun_mem1[of "f" "carrier A" "D"], assumption+,
         frule_tac b = b in invfun_mem1[of "f" "carrier A" "D"], assumption+)
        apply (simp add:surj_to_def) apply (simp add:surj_to_def)
 
  apply (simp add:surj_to_def)
  apply (frule_tac b = b in invfun_mem1[of "f" "carrier A" "D"], assumption+)
  apply (simp add:ag_pOp_closed)
 
  apply (simp add:surj_to_def)
  apply (frule_tac b = a in invfun_mem1[of "f" "carrier A" "D"], assumption+,
         frule_tac b = b in invfun_mem1[of "f" "carrier A" "D"], assumption+)
        apply (simp add:ag_pOp_closed)
 
  apply (simp add:surj_to_def)
  apply (frule_tac b = a in invfun_mem1[of "f" "carrier A" "D"], assumption+,
         frule_tac b = b in invfun_mem1[of "f" "carrier A" "D"], assumption+)
        apply (simp add:ag_pOp_commute)
 
 apply (rule conjI)
  apply (rule Pi_I)
  apply (simp add:Ag_ind_def surj_to_def)
  apply (rule funcset_mem[of "f" "carrier A" "D"], assumption)
  apply (frule_tac b = x in invfun_mem1[of "f" "carrier A" "D"], assumption+)
  apply (simp add:ag_mOp_closed)
 
 apply (rule conjI)
  apply (rule allI, rule impI)
  apply (simp add:Ag_ind_def surj_to_def)
  apply (frule_tac b = a in invfun_mem1[of "f" "carrier A" "D"], assumption+)
 
  apply (frule_tac x = "invfun (carrier A) D f a" in ag_mOp_closed)
  apply (simp add:Pi_def)
  apply (subst injective_iff[of "f" "carrier A", THEN sym], assumption)
  apply (unfold bij_to_def, frule conjunct1, fold bij_to_def)
  apply (simp add:invfun_l)
  apply (simp add:ag_pOp_closed)
  apply (simp add:ag_inc_zero)
  apply (unfold bij_to_def, frule conjunct1, fold bij_to_def)
  apply (simp add:invfun_l l_m)
 
 apply (rule conjI)
  apply (simp add:Ag_ind_def surj_to_def)
  apply (rule funcset_mem[of "f" "carrier A" "D"], assumption)
  apply (simp add:ag_inc_zero)
 
 apply (rule allI, rule impI)
   apply (simp add:Ag_ind_def surj_to_def)
   apply (cut_tac ag_inc_zero, simp add:funcset_mem del:Pi_I)
   apply (unfold bij_to_def, frule conjunct1, fold bij_to_def)
   apply (simp add:invfun_l)
  apply (frule_tac b = a in invfun_mem1[of "f" "carrier A" "D"], assumption+)
  apply (simp add:l_zero)
  apply (simp add:invfun_r)
 done
 
 subsection "Homomorphism of abelian groups"
 
 definition
   aHom :: "[('a, 'm) aGroup_scheme, ('b, 'm1) aGroup_scheme] \<Rightarrow> ('a \<Rightarrow> 'b) set" where
   "aHom A B = {f. f \<in> carrier A \<rightarrow> carrier B \<and> f \<in> extensional (carrier A) \<and>
                (\<forall>a\<in>carrier A. \<forall>b\<in>carrier A. f (a \<plusminus>\<^bsub>A\<^esub> b) = (f a) \<plusminus>\<^bsub>B\<^esub> (f b))}"
 
 definition
   compos :: "[('a, 'm) aGroup_scheme, 'b \<Rightarrow> 'c, 'a \<Rightarrow> 'b] \<Rightarrow> 'a \<Rightarrow> 'c" where
   "compos A g f = compose (carrier A) g f"
 
 definition
   ker :: "[('a, 'm) aGroup_scheme, ('b, 'm1) aGroup_scheme] \<Rightarrow> ('a \<Rightarrow> 'b)
         \<Rightarrow> 'a set" ("(3ker\<^bsub>_,_\<^esub> _)" [82,82,83]82) where
   "ker\<^bsub>F,G\<^esub> f = {a. a \<in> carrier F \<and> f a = (\<zero>\<^bsub>G\<^esub>)}"
 
 definition
  injec :: "[('a, 'm) aGroup_scheme, ('b, 'm1) aGroup_scheme, 'a \<Rightarrow> 'b]
             \<Rightarrow> bool"             ("(3injec\<^bsub>_,_\<^esub> _)" [82,82,83]82) where
   "injec\<^bsub>F,G\<^esub> f \<longleftrightarrow> f \<in> aHom F G \<and> ker\<^bsub>F,G\<^esub> f = {\<zero>\<^bsub>F\<^esub>}"
 
 definition
   surjec :: "[('a, 'm) aGroup_scheme, ('b, 'm1) aGroup_scheme, 'a \<Rightarrow> 'b]
             \<Rightarrow> bool"             ("(3surjec\<^bsub>_,_\<^esub> _)" [82,82,83]82) where
   "surjec\<^bsub>F,G\<^esub> f \<longleftrightarrow> f \<in> aHom F G \<and> surj_to f (carrier F) (carrier G)"
 
 definition
   bijec :: "[('a, 'm) aGroup_scheme, ('b, 'm1) aGroup_scheme, 'a \<Rightarrow> 'b]
             \<Rightarrow> bool"             ("(3bijec\<^bsub>_,_\<^esub> _)" [82,82,83]82) where
   "bijec\<^bsub>F,G\<^esub> f \<longleftrightarrow> injec\<^bsub>F,G\<^esub> f \<and> surjec\<^bsub>F,G\<^esub> f"
 
 definition
   ainvf :: "[('a, 'm) aGroup_scheme, ('b, 'm1) aGroup_scheme, 'a \<Rightarrow> 'b]
             \<Rightarrow> ('b \<Rightarrow> 'a)"             ("(3ainvf\<^bsub>_,_\<^esub> _)" [82,82,83]82) where
   "ainvf\<^bsub>F,G\<^esub> f = invfun (carrier F) (carrier G) f"
 
 lemma aHom_mem:"\<lbrakk>aGroup F; aGroup G; f \<in> aHom F G; a \<in> carrier F\<rbrakk> \<Longrightarrow>
                        f a \<in> carrier G"
 apply (simp add:aHom_def) apply (erule conjE)+
 apply (simp add:Pi_def)
 done
 
 lemma aHom_func:"f \<in> aHom F G \<Longrightarrow> f \<in> carrier F \<rightarrow> carrier G"
 by (simp add:aHom_def)
 
 lemma aHom_add:"\<lbrakk>aGroup F; aGroup G; f \<in> aHom F G; a \<in> carrier F;
  b \<in> carrier F\<rbrakk> \<Longrightarrow> f (a \<plusminus>\<^bsub>F\<^esub> b) = (f a) \<plusminus>\<^bsub>G\<^esub> (f b)"
 apply (simp add:aHom_def)
 done
 
 lemma aHom_0_0:"\<lbrakk>aGroup F; aGroup G; f \<in> aHom F G\<rbrakk> \<Longrightarrow> f (\<zero>\<^bsub>F\<^esub>) = \<zero>\<^bsub>G\<^esub>"
 apply (frule aGroup.ag_inc_zero [of "F"])
 apply (subst aGroup.ag_l_zero [THEN sym, of "F" "\<zero>\<^bsub>F\<^esub>"], assumption+)
 apply (simp add:aHom_add)
 apply (frule aGroup.ag_l_zero [THEN sym, of "F" "\<zero>\<^bsub>F\<^esub>"], assumption+)
 apply (subgoal_tac "f (\<zero>\<^bsub>F\<^esub>) = f (\<zero>\<^bsub>F\<^esub> \<plusminus>\<^bsub>F\<^esub> \<zero>\<^bsub>F\<^esub>)") prefer 2 apply simp
 apply (thin_tac "\<zero>\<^bsub>F\<^esub> = \<zero>\<^bsub>F\<^esub> \<plusminus>\<^bsub>F\<^esub> \<zero>\<^bsub>F\<^esub>")
 apply (simp add:aHom_add) apply (frule sym)
 apply (thin_tac "f \<zero>\<^bsub>F\<^esub> = f \<zero>\<^bsub>F\<^esub> \<plusminus>\<^bsub>G\<^esub> f \<zero>\<^bsub>F\<^esub>")
 apply (frule aHom_mem[of "F" "G" "f" "\<zero>\<^bsub>F\<^esub>"], assumption+)
 apply (frule aGroup.ag_mOp_closed[of "G" "f \<zero>\<^bsub>F\<^esub>"], assumption+)
 apply (frule aGroup.aassoc[of "G" "-\<^sub>a\<^bsub>G\<^esub> (f \<zero>\<^bsub>F\<^esub>)" "f \<zero>\<^bsub>F\<^esub>" "f \<zero>\<^bsub>F\<^esub>"], assumption+)
 apply (simp add:aGroup.l_m aGroup.l_zero)
 done
 
 lemma ker_inc_zero:"\<lbrakk>aGroup F; aGroup G; f \<in> aHom F G\<rbrakk> \<Longrightarrow> \<zero>\<^bsub>F\<^esub> \<in> ker\<^bsub>F,G\<^esub> f"
 by (frule aHom_0_0[of "F" "G" "f"], assumption+,
        simp add:ker_def, simp add:aGroup.ag_inc_zero [of "F"])
 
 lemma aHom_inv_inv:"\<lbrakk>aGroup F; aGroup G; f \<in> aHom F G; a \<in> carrier F\<rbrakk> \<Longrightarrow>
                          f (-\<^sub>a\<^bsub>F\<^esub> a) = -\<^sub>a\<^bsub>G\<^esub> (f a)"
 apply (frule aGroup.ag_l_inv1 [of "F" "a"], assumption+,
        frule sym, thin_tac "-\<^sub>a\<^bsub>F\<^esub> a \<plusminus>\<^bsub>F\<^esub> a = \<zero>\<^bsub>F\<^esub>",
        frule aHom_0_0[of "F" "G" "f"], assumption+,
        frule aGroup.ag_mOp_closed[of "F" "a"], assumption+)
  apply (simp add:aHom_add, thin_tac "\<zero>\<^bsub>F\<^esub> = -\<^sub>a\<^bsub>F\<^esub> a \<plusminus>\<^bsub>F\<^esub> a")
  apply (frule aHom_mem[of "F" "G" "f" "-\<^sub>a\<^bsub>F\<^esub> a"], assumption+,
         frule aHom_mem[of "F" "G" "f" "a"], assumption+,
         simp only:aGroup.ag_pOp_commute[of "G" "f (-\<^sub>a\<^bsub>F\<^esub> a)" "f a"])
  apply (rule aGroup.ag_inv_unique[of "G"], assumption+)
 done
 
 lemma aHom_compos:"\<lbrakk>aGroup L; aGroup M; aGroup N; f \<in> aHom L M; g \<in> aHom M N \<rbrakk>
   \<Longrightarrow> compos L g f \<in> aHom L N"
 apply (simp add:aHom_def [of "L" "N"])
 apply (rule conjI)
  apply (rule Pi_I)
  apply (simp add:compos_def compose_def)
  apply (rule aHom_mem [of "M" "N" "g"], assumption+)
  apply (simp add:aHom_mem [of "L" "M" "f"])
 apply (rule conjI)
  apply (simp add:compos_def compose_def extensional_def)
 apply (rule ballI)+
  apply (simp add:compos_def compose_def)
  apply (simp add:aGroup.ag_pOp_closed)
  apply (simp add:aHom_add)
  apply (rule aHom_add, assumption+)
  apply (simp add:aHom_mem)+
 done
 
 lemma aHom_compos_assoc:"\<lbrakk>aGroup K; aGroup L; aGroup M; aGroup N; f \<in> aHom K L;
       g \<in> aHom L M; h \<in> aHom M N \<rbrakk>  \<Longrightarrow>
       compos K h (compos K g f) = compos K (compos L h g) f"
 apply (simp add:compos_def compose_def)
 apply (rule funcset_eq[of _ "carrier K"])
 apply (simp add:restrict_def extensional_def)
 apply (simp add:restrict_def extensional_def)
 apply (rule ballI, simp)
 apply (simp add:aHom_mem)
 done
 
 lemma injec_inj_on:"\<lbrakk>aGroup F; aGroup G; injec\<^bsub>F,G\<^esub> f\<rbrakk> \<Longrightarrow> inj_on f (carrier F)"
 apply (simp add:inj_on_def)
  apply (rule ballI)+ apply (rule impI)
  apply (simp add:injec_def, erule conjE)
  apply (frule_tac a = x in aHom_mem[of "F" "G" "f"], assumption+,
         frule_tac a = x in aHom_mem[of "F" "G" "f"], assumption+)
  apply (frule_tac x = "f x" in aGroup.ag_r_inv1[of "G"], assumption+)
  apply (simp only:aHom_inv_inv[THEN sym, of "F" "G" "f"])
  apply (frule sym, thin_tac "f x = f y", simp)
  apply (frule_tac x = y in aGroup.ag_mOp_closed[of "F"], assumption+)
  apply (simp add:aHom_add[THEN sym], simp add:ker_def)
  apply (subgoal_tac "x \<plusminus>\<^bsub>F\<^esub> -\<^sub>a\<^bsub>F\<^esub> y \<in> {a \<in> carrier F. f a = \<zero>\<^bsub>G\<^esub>}",
         simp)
  apply (subst aGroup.ag_eq_diffzero[of "F"], assumption+)
 apply (frule_tac x = x and y = "-\<^sub>a\<^bsub>F\<^esub> y" in aGroup.ag_pOp_closed[of "F"],
            assumption+)
  apply simp apply blast
 done
 
 lemma surjec_surj_to:"surjec\<^bsub>R,S\<^esub> f \<Longrightarrow> surj_to f (carrier R) (carrier S)"
 by (simp add:surjec_def)
 
 lemma compos_bijec:"\<lbrakk>aGroup E; aGroup F; aGroup G; bijec\<^bsub>E,F\<^esub> f; bijec\<^bsub>F,G\<^esub> g\<rbrakk> \<Longrightarrow>
                      bijec\<^bsub>E,G\<^esub> (compos E g f)"
 apply (simp add:bijec_def, (erule conjE)+)
 apply (rule conjI)
  apply (simp add:injec_def, (erule conjE)+)
  apply (simp add:aHom_compos[of "E" "F" "G" "f" "g"])
  apply (rule equalityI, rule subsetI, simp add:ker_def, erule conjE)
  apply (simp add:compos_def compose_def)
  apply (frule_tac a = x in aHom_mem[of "E" "F" "f"], assumption+)
  apply (subgoal_tac "(f x) \<in> {a \<in> carrier F. g a = \<zero>\<^bsub>G\<^esub>}", simp)
  apply (subgoal_tac "x \<in> {a \<in> carrier E. f a = \<zero>\<^bsub>F\<^esub>}", simp)
  apply blast apply blast
  apply (rule subsetI, simp)
  apply (simp add:ker_def compos_def compose_def)
  apply (simp add:aGroup.ag_inc_zero) apply (simp add:aHom_0_0)
 
 apply (simp add:surjec_def, (erule conjE)+)
  apply (simp add:aHom_compos)
  apply (simp add:aHom_def, (erule conjE)+) apply (simp add:compos_def)
  apply (rule compose_surj[of "f" "carrier E" "carrier F" "g" "carrier G"],
             assumption+)
 done
 
 lemma ainvf_aHom:"\<lbrakk>aGroup F; aGroup G; bijec\<^bsub>F,G\<^esub> f\<rbrakk> \<Longrightarrow>
                       ainvf\<^bsub>F,G\<^esub> f \<in> aHom G F"
 apply (subst aHom_def, simp)
  apply (simp add:ainvf_def)
  apply (simp add:bijec_def, erule conjE)
  apply (frule injec_inj_on[of "F" "G" "f"], assumption+)
  apply (simp add:surjec_def, (erule conjE)+)
  apply (simp add:aHom_def, (erule conjE)+)
  apply (frule inv_func[of "f" "carrier F" "carrier G"], assumption+, simp)
 apply (rule conjI)
  apply (simp add:invfun_def)
 apply (rule ballI)+
  apply (frule_tac x = a in funcset_mem[of "Ifn F G f" "carrier G" "carrier F"],
       assumption+,
       frule_tac x = b in funcset_mem[of "Ifn F G f" "carrier G" "carrier F"],
       assumption+,
       frule_tac x = a and y = b in aGroup.ag_pOp_closed[of "G"], assumption+,
       frule_tac x = "a \<plusminus>\<^bsub>G\<^esub> b" in funcset_mem[of "Ifn F G f" "carrier G"
        "carrier F"], assumption+)
  apply (frule_tac a = "(Ifn F G f) a" and b = "(Ifn F G f) b" in
            aHom_add[of "F" "G" "f"], assumption+, simp add:injec_def,
            assumption+,
            thin_tac "\<forall>a\<in>carrier F. \<forall>b\<in>carrier F. f (a \<plusminus>\<^bsub>F\<^esub> b) = f a \<plusminus>\<^bsub>G\<^esub> f b")
  apply (simp add:invfun_r[of "f" "carrier F" "carrier G"])
  apply (frule_tac x = a and y = b in aGroup.ag_pOp_closed[of "G"], assumption+) apply (frule_tac b = "a \<plusminus>\<^bsub>G\<^esub> b" in invfun_r[of "f" "carrier F" "carrier G"],
            assumption+)
  apply (simp add:inj_on_def)
  apply (frule_tac x = "(Ifn F G f) a" and y = "(Ifn F G f) b" in
           aGroup.ag_pOp_closed, assumption+)
  apply (frule_tac x = "(Ifn F G f) (a \<plusminus>\<^bsub>G\<^esub> b)" in bspec, assumption,
         thin_tac "\<forall>x\<in>carrier F. \<forall>y\<in>carrier F. f x = f y \<longrightarrow> x = y")
  apply (frule_tac x = "(Ifn F G f) a \<plusminus>\<^bsub>F\<^esub> (Ifn F G f) b" in bspec,
             assumption,
         thin_tac "\<forall>y\<in>carrier F.
               f ((Ifn F G f) (a \<plusminus>\<^bsub>G\<^esub> b)) = f y \<longrightarrow> (Ifn F G f) (a \<plusminus>\<^bsub>G\<^esub> b) = y")
  apply simp
 done
 
 lemma ainvf_bijec:"\<lbrakk>aGroup F; aGroup G; bijec\<^bsub>F,G\<^esub> f\<rbrakk> \<Longrightarrow> bijec\<^bsub>G,F\<^esub> (ainvf\<^bsub>F,G\<^esub> f)"
 apply (subst bijec_def)
 apply (simp add:injec_def surjec_def)
 apply (simp add:ainvf_aHom)
 apply (rule conjI)
  apply (rule equalityI)
  apply (rule subsetI, simp add:ker_def, erule conjE)
  apply (simp add:ainvf_def)
  apply (simp add:bijec_def,(erule conjE)+, simp add:surjec_def,
          (erule conjE)+, simp add:aHom_def, (erule conjE)+)
  apply (frule injec_inj_on[of "F" "G" "f"], assumption+)
  apply (subst invfun_r[THEN sym, of "f" "carrier F" "carrier G"], assumption+)
  apply (simp add:injec_def, (erule conjE)+, simp add:aHom_0_0)
 
  apply (rule subsetI, simp add:ker_def)
  apply (simp add:aGroup.ex_zero)
  apply (frule ainvf_aHom[of "F" "G" "f"], assumption+)
  apply (simp add:aHom_0_0)
 
 apply (frule ainvf_aHom[of "F" "G" "f"], assumption+,
         simp add:aHom_def, (erule conjE)+,
        rule surj_to_test[of "ainvf\<^bsub>F,G\<^esub> f" "carrier G" "carrier F"],
         assumption+)
  apply (rule ballI,
         thin_tac "\<forall>a\<in>carrier G. \<forall>b\<in>carrier G.
                (ainvf\<^bsub>F,G\<^esub> f) (a \<plusminus>\<^bsub>G\<^esub> b) = (ainvf\<^bsub>F,G\<^esub> f) a \<plusminus>\<^bsub>F\<^esub> (ainvf\<^bsub>F,G\<^esub> f) b")
  apply (simp add:bijec_def, erule conjE)
   apply (frule injec_inj_on[of "F" "G" "f"], assumption+)
   apply (simp add:surjec_def aHom_def, (erule conjE)+)
   apply (subst ainvf_def)
  apply (frule_tac a = b in invfun_l[of "f" "carrier F" "carrier G"],
                   assumption+,
         frule_tac x = b in funcset_mem[of "f" "carrier F" "carrier G"],
                   assumption+, blast)
 done
 
 lemma ainvf_l:"\<lbrakk>aGroup E; aGroup F; bijec\<^bsub>E,F\<^esub> f; x \<in> carrier E\<rbrakk> \<Longrightarrow>
                       (ainvf\<^bsub>E,F\<^esub> f) (f x) = x"
 apply (simp add:bijec_def, erule conjE)
 apply (frule injec_inj_on[of "E" "F" "f"], assumption+)
 apply (simp add:surjec_def aHom_def, (erule conjE)+)
 apply (frule invfun_l[of "f" "carrier E" "carrier F" "x"], assumption+)
 apply (simp add:ainvf_def)
 done
 
 lemma (in aGroup) aI_aHom:"aI\<^bsub>A\<^esub> \<in> aHom A A"
 by (simp add:aHom_def ag_idmap_def ag_idmap_def ag_pOp_closed)
 
 lemma compos_aI_l:"\<lbrakk>aGroup A; aGroup B; f \<in> aHom A B\<rbrakk> \<Longrightarrow> compos A aI\<^bsub>B\<^esub> f = f"
 apply (simp add:compos_def)
 apply (rule funcset_eq[of _ "carrier A"])
  apply (simp add:compose_def extensional_def)
  apply (simp add:aHom_def)
 apply (rule ballI)
  apply (frule_tac a = x in aHom_mem[of "A" "B" "f"], assumption+)
  apply (simp add:compose_def ag_idmap_def)
 done
 
 lemma compos_aI_r:"\<lbrakk>aGroup A; aGroup B; f \<in> aHom A B\<rbrakk> \<Longrightarrow> compos A f aI\<^bsub>A\<^esub> = f"
 apply (simp add:compos_def)
 apply (rule funcset_eq[of _ "carrier A"])
  apply (simp add:compose_def extensional_def)
  apply (simp add:aHom_def)
 apply (rule ballI)
  apply (simp add:compose_def ag_idmap_def)
 done
 
 lemma compos_aI_surj:"\<lbrakk>aGroup A; aGroup B; f \<in> aHom A B; g \<in> aHom B A;
                       compos A g f = aI\<^bsub>A\<^esub>\<rbrakk> \<Longrightarrow> surjec\<^bsub>B,A\<^esub> g"
 apply (simp add:surjec_def)
 apply (rule surj_to_test[of "g" "carrier B" "carrier A"])
  apply (simp add:aHom_def)
 apply (rule ballI)
  apply (subgoal_tac "compos A g f b = aI\<^bsub>A\<^esub> b",
         thin_tac "compos A g f = aI\<^bsub>A\<^esub>")
  apply (simp add:compos_def compose_def ag_idmap_def)
  apply (frule_tac a = b in aHom_mem[of "A" "B" "f"], assumption+, blast)
  apply simp
 done
 
 lemma compos_aI_inj:"\<lbrakk>aGroup A; aGroup B; f \<in> aHom A B; g \<in> aHom B A;
                       compos A g f = aI\<^bsub>A\<^esub>\<rbrakk> \<Longrightarrow> injec\<^bsub>A,B\<^esub> f"
 apply (simp add:injec_def)
 apply (simp add:ker_def)
 apply (rule equalityI)
  apply (rule subsetI, simp, erule conjE)
  apply (subgoal_tac "compos A g f x = aI\<^bsub>A\<^esub> x",
         thin_tac "compos A g f = aI\<^bsub>A\<^esub>")
  apply (simp add:compos_def compose_def)
  apply (simp add:aHom_0_0 ag_idmap_def) apply simp
 
  apply (rule subsetI, simp)
  apply (simp add:aGroup.ag_inc_zero aHom_0_0)
 done
 
 lemma (in aGroup) Ag_ind_aHom:"\<lbrakk>f \<in> carrier A \<rightarrow> D;
       bij_to f (carrier A) (D::'d set)\<rbrakk> \<Longrightarrow> Agii A f \<in> aHom A (Ag_ind A f)"
 apply (simp add:aHom_def)
  apply (unfold bij_to_def, frule conjunct1, frule conjunct2, fold bij_to_def)
  apply (simp add:Ag_ind_carrier surj_to_def)
 apply (rule conjI)
  apply (simp add:Agii_def Pi_def)
  apply (simp add:Agii_def)
  apply (simp add:Ag_ind_def Pi_def)
  apply (unfold bij_to_def, frule conjunct1, fold bij_to_def)
  apply (simp add:invfun_l)
  apply (simp add:ag_pOp_closed)
 done
 
 lemma (in aGroup) Agii_mem:"\<lbrakk>f \<in> carrier A \<rightarrow> D; x \<in> carrier A;
       bij_to f (carrier A) (D::'d set)\<rbrakk> \<Longrightarrow> Agii A f x \<in> carrier (Ag_ind A f)"
 apply (simp add:Agii_def Ag_ind_carrier)
 done
 
 lemma Ag_ind_bijec:"\<lbrakk>aGroup A; f \<in> carrier A \<rightarrow> D;
       bij_to f (carrier A) (D::'d set)\<rbrakk> \<Longrightarrow> bijec\<^bsub>A, (Ag_ind A f)\<^esub> (Agii A f)"
 apply (frule aGroup.Ag_ind_aHom[of "A" "f" "D"], assumption+)
 apply (frule aGroup.Ag_ind_aGroup[of "A" "f" "D"], assumption+)
 apply (simp add:bijec_def)
  apply (rule conjI)
  apply (simp add:injec_def)
  apply (rule equalityI)
  apply (rule subsetI)
  apply (simp add:ker_def, erule conjE)
 apply (frule aHom_0_0[of "A" "Ag_ind A f" "Agii A f"], assumption+)
  apply (rotate_tac -2, frule sym, thin_tac "Agii A f x = \<zero>\<^bsub>Ag_ind A f\<^esub>", simp)
  apply (frule aGroup.ag_inc_zero[of "A"], simp add:Agii_def)
  apply (unfold bij_to_def, frule conjunct2, fold bij_to_def)
  apply (frule aGroup.ag_inc_zero[of "A"])
  apply (simp add:injective_iff[THEN sym, of "f" "carrier A" "\<zero>\<^bsub>A\<^esub>"])
  apply (rule subsetI, simp)
  apply (subst ker_def, simp)
  apply (simp add:aGroup.ag_inc_zero, simp add:aHom_0_0)
 
 apply (subst surjec_def)
 apply (unfold bij_to_def, frule conjunct1, fold bij_to_def, simp)
  apply (simp add:aGroup.Ag_ind_carrier surj_to_def Agii_def)
 done
 
 definition
   aimg :: "[('b, 'm1) aGroup_scheme, _, 'b \<Rightarrow> 'a]
             \<Rightarrow> 'a aGroup"  ("(3aimg\<^bsub>_,_\<^esub> _)" [82,82,83]82) where
   "aimg\<^bsub>F,A\<^esub> f = A \<lparr> carrier := f ` (carrier F), pop := pop A, mop := mop A,
                   zero := zero A\<rparr>"
 
 lemma ker_subg:"\<lbrakk>aGroup F; aGroup G; f \<in> aHom F G \<rbrakk> \<Longrightarrow> F +> ker\<^bsub>F,G\<^esub> f"
 apply (rule aGroup.asubg_test, assumption+)
 apply (rule subsetI)
  apply (simp add:ker_def)
 apply (simp add:ker_def)
 apply (frule aHom_0_0 [of "F" "G" "f"], assumption+)
 apply (frule aGroup.ex_zero [of "F"]) apply blast
 apply (rule ballI)+
 apply (simp add:ker_def) apply (erule conjE)+
 apply (frule_tac x = b in aGroup.ag_mOp_closed[of "F"], assumption+)
 apply (rule conjI)
 apply (rule aGroup.ag_pOp_closed, assumption+)
 apply (simp add:aHom_add)
 apply (simp add:aHom_inv_inv)
 apply (simp add:aGroup.ag_inv_zero[of "G"])
 apply (cut_tac aGroup.ex_zero[of "G"], simp add:aGroup.l_zero)
 apply assumption
 done
 
 subsection "Quotient abelian group"
 
 definition
   ar_coset :: "['a, _ , 'a set] \<Rightarrow> 'a set" (** a_rcs **)
      ("(3_ \<uplus>\<^bsub>_\<^esub> _)" [66,66,67]66) where
   "ar_coset a A H = H \<bullet>\<^bsub>(b_ag A)\<^esub> a"
 
 definition
   set_ar_cos :: "[_ , 'a set] \<Rightarrow> 'a set set" where
   "set_ar_cos A I = {X. \<exists>a\<in>carrier A. X = ar_coset a A I}"
 
 definition
   aset_sum :: "[_ , 'a set, 'a set] \<Rightarrow> 'a set" where
   "aset_sum A H K = s_top (b_ag A) H K"
 
 abbreviation
   ASBOP1  (infix "\<minusplus>\<index>" 60) where
   "H \<minusplus>\<^bsub>A\<^esub> K == aset_sum A H K"
 
 lemma (in aGroup) ag_a_in_ar_cos:"\<lbrakk>A +> H; a \<in> carrier A\<rbrakk> \<Longrightarrow> a \<in> a \<uplus>\<^bsub>A\<^esub> H"
 apply (simp add:ar_coset_def)
 apply (simp add:asubGroup_def)
 apply (cut_tac b_ag_group)
 apply (rule Group.a_in_rcs[of "b_ag A" "H" "a"], assumption+)
 apply (simp add:ag_carrier_carrier[THEN sym])
 done
 
 lemma (in aGroup) r_cos_subset:"\<lbrakk>A +> H; X \<in> set_rcs (b_ag A) H\<rbrakk> \<Longrightarrow>
                    X \<subseteq> carrier A"
 apply (simp add:asubGroup_def set_rcs_def)
 apply (erule bexE)
 apply (cut_tac  b_ag_group)
 apply (frule_tac a = a in Group.rcs_subset[of "b_ag A" "H"], assumption+)
 apply (simp add:ag_carrier_carrier)
 done
 
 lemma (in aGroup) asubg_costOp_commute:"\<lbrakk>A +> H; x \<in> set_rcs (b_ag A) H;
        y \<in> set_rcs (b_ag A) H\<rbrakk> \<Longrightarrow>
              c_top (b_ag A) H x y = c_top (b_ag A) H y x"
 apply (simp add:set_rcs_def, (erule bexE)+, simp)
 apply (cut_tac b_ag_group)
 apply (subst Group.c_top_welldef[THEN sym], assumption+,
        simp add:asubg_nsubg,
        (simp add:ag_carrier_carrier)+)
 apply (subst Group.c_top_welldef[THEN sym], assumption+,
        simp add:asubg_nsubg,
        (simp add:ag_carrier_carrier)+)
 apply (simp add:agop_gop)
  apply (simp add:ag_pOp_commute)
 done
 
 lemma (in aGroup) Subg_Qgroup:"A +> H \<Longrightarrow> aGroup (aqgrp A H)"
 apply (frule asubg_nsubg[of "H"])
 apply (cut_tac b_ag_group)
 apply (simp add:aGroup_def)
  apply (simp add:aqgrp_def)
  apply (simp add:Group.Qg_top [of "b_ag A" "H"])
  apply (simp add:Group.Qg_iop [of "b_ag A" "H"])
  apply (frule Group.nsg_sg[of "b_ag A" "H"], assumption+,
         simp add:Group.unit_rcs_in_set_rcs[of "b_ag A" "H"])
 apply (simp add:Group.Qg_tassoc)
 apply (simp add:asubg_costOp_commute)
 apply (simp add:Group.Qg_i[of "b_ag A" "H"])
 apply (simp add:Group.Qg_unit[of "b_ag A" "H"])
 done
 
 lemma (in aGroup) plus_subgs:"\<lbrakk>A +> H1; A +> H2\<rbrakk> \<Longrightarrow> A +> H1 \<minusplus> H2"
 apply (simp add:aset_sum_def)
  apply (frule asubg_nsubg[of "H2"])
  apply (simp add:asubGroup_def[of _ "H1"])
 apply (cut_tac "b_ag_group")
 apply (frule Group.smult_sg_nsg[of "b_ag A" "H1" "H2"], assumption+)
 apply (simp add:asubGroup_def)
 done
 
 lemma (in aGroup) set_sum:"\<lbrakk>H \<subseteq> carrier A; K \<subseteq> carrier A\<rbrakk> \<Longrightarrow>
                     H \<minusplus> K = {x. \<exists>h\<in>H. \<exists>k\<in>K. x = h \<plusminus> k}"
  apply (cut_tac b_ag_group)
 apply (rule equalityI)
  apply (rule subsetI)
  apply (simp add:aset_sum_def)
  apply (simp add:agop_gop[THEN sym] s_top_def, (erule bexE)+,
         frule sym, thin_tac "xa \<cdot>\<^bsub>b_ag A\<^esub> y = x", simp, blast)
  apply (rule subsetI, simp add:aset_sum_def, (erule bexE)+)
  apply (frule_tac c = h in subsetD[of H "carrier A"], assumption+,
         frule_tac c = k in subsetD[of K "carrier A"], assumption+)
  apply (simp add:agop_gop[THEN sym], simp add:s_top_def, blast)
 done
 
 lemma (in aGroup) mem_set_sum:"\<lbrakk>H \<subseteq> carrier A; K \<subseteq> carrier A;
                   x \<in> H \<minusplus> K \<rbrakk> \<Longrightarrow> \<exists>h\<in>H. \<exists>k\<in>K. x = h \<plusminus> k"
 by (simp add:set_sum)
 
 lemma (in aGroup) mem_sum_subgs:"\<lbrakk>A +> H; A +> K; h \<in> H; k \<in> K\<rbrakk> \<Longrightarrow>
                     h \<plusminus> k \<in> H \<minusplus> K"
 apply (frule asubg_subset[of H],
        frule asubg_subset[of K],
        simp add:set_sum, blast)
 done
 
 lemma (in aGroup) aqgrp_carrier:"A +> H \<Longrightarrow>
                    set_rcs (b_ag A ) H = set_ar_cos A H"
 apply (simp add:set_ar_cos_def)
 apply (simp add:ag_carrier_carrier [THEN sym])
 apply (simp add:ar_coset_def set_rcs_def)
 done
 
 lemma (in aGroup) unit_in_set_ar_cos:"A +> H \<Longrightarrow> H \<in> set_ar_cos A H"
 apply (simp add:aqgrp_carrier[THEN sym])
 apply (cut_tac b_ag_group) apply (simp add:asubGroup_def)
 apply (simp add:Group.unit_rcs_in_set_rcs[of "b_ag A" "H"])
 done
 
 lemma (in aGroup) aqgrp_pOp_maps:"\<lbrakk>A +> H; a \<in> carrier A; b \<in> carrier A\<rbrakk> \<Longrightarrow>
       pop (aqgrp A H) (a \<uplus>\<^bsub>A\<^esub> H) (b \<uplus>\<^bsub>A\<^esub> H) = (a \<plusminus> b) \<uplus>\<^bsub>A\<^esub> H"
 apply (simp add:aqgrp_def ar_coset_def)
 apply (cut_tac b_ag_group)
 apply (frule asubg_nsubg)
 apply (simp add:ag_carrier_carrier [THEN sym])
 apply (subst Group.c_top_welldef [THEN sym], assumption+)
 apply (simp add:agop_gop)
 done
 
 lemma (in aGroup) aqgrp_mOp_maps:"\<lbrakk>A +> H; a \<in> carrier A\<rbrakk> \<Longrightarrow>
                    mop (aqgrp A H) (a \<uplus>\<^bsub>A\<^esub> H) = (-\<^sub>a a) \<uplus>\<^bsub>A\<^esub> H"
 apply (simp add:aqgrp_def ar_coset_def)
 apply (cut_tac b_ag_group)
 apply (frule asubg_nsubg)
 apply (simp add:ag_carrier_carrier [THEN sym])
 apply (subst Group.c_iop_welldef, assumption+)
 apply (simp add:agiop_giop)
 done
 
 lemma (in aGroup) aqgrp_zero:"A +> H \<Longrightarrow> zero (aqgrp A H) = H"
 apply (simp add:aqgrp_def)
 done
 
 lemma (in aGroup) arcos_fixed:"\<lbrakk>A +> H; a \<in> carrier A; h \<in> H \<rbrakk> \<Longrightarrow>
                               a \<uplus>\<^bsub>A\<^esub> H = (h \<plusminus> a) \<uplus>\<^bsub>A\<^esub> H"
  apply (cut_tac b_ag_group)
  apply (simp add:agop_gop[THEN sym])
  apply (simp add:ag_carrier_carrier[THEN sym])
  apply (simp add:ar_coset_def)
  apply (simp add:asubGroup_def)
  apply (simp add:Group.rcs_fixed1[of "b_ag A" "H"])
 done
 
 definition
   rind_hom :: "[('a, 'more) aGroup_scheme, ('b, 'more1) aGroup_scheme,
                 ('a  \<Rightarrow> 'b)] \<Rightarrow> ('a set  \<Rightarrow> 'b )" where
   "rind_hom A B f = (\<lambda>X\<in>(set_ar_cos A (ker\<^bsub>A,B\<^esub> f)). f (SOME x. x \<in> X))"
 
 abbreviation
   RIND_HOM  ("(3_\<degree>\<^bsub>_,_\<^esub>)" [82,82,83]82)  where
   "f\<degree>\<^bsub>F,G\<^esub> == rind_hom F G f"
                                                           (* tOp \<rightarrow> pOp *)
 
 section "Direct product and direct sum of abelian groups, in general case"
 
 definition
   Un_carrier :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow> 'a set" where
   "Un_carrier I A = \<Union>{X. \<exists>i\<in>I. X = carrier (A i)}"
 
 definition
   carr_prodag :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow> ('i  \<Rightarrow> 'a ) set" where
   "carr_prodag I A = {f. f \<in> extensional I \<and> f \<in> I \<rightarrow> (Un_carrier I A) \<and>
                                                (\<forall>i\<in>I. f i \<in> carrier (A i))}"
 
 definition
   prod_pOp :: "['i set,  'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow>
                                  ('i \<Rightarrow> 'a) \<Rightarrow> ('i \<Rightarrow> 'a) \<Rightarrow>  ('i \<Rightarrow> 'a)" where
   "prod_pOp I A = (\<lambda>f\<in>carr_prodag I A. \<lambda>g\<in>carr_prodag I A.
                                         \<lambda>x\<in>I. (f x) \<plusminus>\<^bsub>(A x)\<^esub> (g x))"
 
 definition
   prod_mOp :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow>
                                   ('i \<Rightarrow> 'a) \<Rightarrow> ('i \<Rightarrow> 'a)" where
   "prod_mOp I A = (\<lambda>f\<in>carr_prodag I A. \<lambda>x\<in>I. (-\<^sub>a\<^bsub>(A x)\<^esub> (f x)))"
 
 definition
   prod_zero :: "['i set,  'i  \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow> ('i \<Rightarrow> 'a)" where
   "prod_zero I A = (\<lambda>x\<in>I. \<zero>\<^bsub>(A x)\<^esub>)"
 
 definition
   prodag :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow> ('i \<Rightarrow> 'a) aGroup" where
   "prodag I A = \<lparr> carrier = carr_prodag I A,
     pop = prod_pOp I A, mop = prod_mOp I A,
     zero = prod_zero I A\<rparr>"
 
 definition
   PRoject :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme, 'i]
                    \<Rightarrow> ('i \<Rightarrow> 'a) \<Rightarrow> 'a" ("(3\<pi>\<^bsub>_,_,_\<^esub>)" [82,82,83]82) where
   "PRoject I A x = (\<lambda>f \<in> carr_prodag I A. f x)"
 
 abbreviation
   PRODag  ("(a\<Pi>\<^bsub>_\<^esub> _)" [72,73]72) where
   "a\<Pi>\<^bsub>I\<^esub> A == prodag I A"
 
 lemma prodag_comp_i:"\<lbrakk>a \<in> carr_prodag I A; i \<in> I\<rbrakk> \<Longrightarrow> (a i) \<in> carrier (A i)"
 by (simp add:carr_prodag_def)
 
 lemma prod_pOp_func:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
     prod_pOp I A \<in> carr_prodag I A \<rightarrow> carr_prodag I A \<rightarrow> carr_prodag I A"
 apply (rule Pi_I)+
 apply(rename_tac a b)
  apply (subst carr_prodag_def) apply (simp add:CollectI)
 apply (rule conjI)
  apply (simp add:prod_pOp_def restrict_def extensional_def)
 apply (rule conjI)
  apply (rule Pi_I)
  apply (simp add:prod_pOp_def)
  apply (subst Un_carrier_def) apply (simp add:CollectI)
  apply (frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (A k)")
  apply (simp add:carr_prodag_def) apply (erule conjE)+
  apply (thin_tac "a \<in> I \<rightarrow> Un_carrier I A")
  apply (thin_tac "b \<in> I \<rightarrow> Un_carrier I A")
  apply (frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>i\<in>I. a i \<in> carrier (A i)",
         frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>i\<in>I. b i \<in> carrier (A i)")
  apply (frule_tac x = "a x" and y = "b x" in aGroup.ag_pOp_closed, assumption+)
  apply blast
 apply (rule ballI)
  apply (simp add:prod_pOp_def)
  apply (rule_tac A = "A i" and x = "a i" and y = "b i" in aGroup.ag_pOp_closed)
  apply simp
  apply (simp add:carr_prodag_def)+
 done
 
 lemma prod_pOp_mem:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); X \<in> carr_prodag I A;
  Y \<in> carr_prodag I A\<rbrakk> \<Longrightarrow> prod_pOp I A X Y \<in> carr_prodag I A"
 apply (frule prod_pOp_func)
 apply (frule funcset_mem[of "prod_pOp I A"
                         "carr_prodag I A" "carr_prodag I A \<rightarrow> carr_prodag I A"
                          "X"], assumption+)
 apply (rule funcset_mem[of "prod_pOp I A X" "carr_prodag I A"
                            "carr_prodag I A" "Y"], assumption+)
 done
 
 lemma prod_pOp_mem_i:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); X \<in> carr_prodag I A;
  Y \<in> carr_prodag I A; i \<in> I\<rbrakk> \<Longrightarrow> prod_pOp I A X Y i = (X i) \<plusminus>\<^bsub>(A i)\<^esub> (Y i)"
 apply (simp add:prod_pOp_def)
 done
 
 lemma prod_mOp_func:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   prod_mOp I A \<in> carr_prodag I A \<rightarrow> carr_prodag I A"
 apply (rule Pi_I)
  apply (simp add:prod_mOp_def carr_prodag_def)
  apply (erule conjE)+
 apply (rule conjI)
  apply (rule Pi_I) apply simp
  apply (rename_tac f j)
  apply (frule_tac f = f and x = j in funcset_mem [of _ "I" "Un_carrier I A"],
                              assumption+)
  apply (thin_tac "f \<in> I \<rightarrow> Un_carrier I A")
  apply (frule_tac x = j in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (A k)",
         frule_tac x = j in bspec, assumption,
         thin_tac "\<forall>i\<in>I. f i \<in> carrier (A i)")
  apply (thin_tac "f j \<in> Un_carrier I A")
  apply (simp add:Un_carrier_def)
  apply (frule aGroup.ag_mOp_closed, assumption+)
  apply blast
 apply (rule ballI)
  apply (rule_tac A = "A i" and x = "x i" in aGroup.ag_mOp_closed)
  apply simp+
 done
 
 lemma prod_mOp_mem:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); X \<in> carr_prodag I A\<rbrakk> \<Longrightarrow>
                          prod_mOp I A X \<in> carr_prodag I A"
 apply (frule prod_mOp_func)
 apply (simp add:Pi_def)
 done
 
 lemma prod_mOp_mem_i:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); X \<in> carr_prodag I A; i \<in> I\<rbrakk> \<Longrightarrow>
                          prod_mOp I A X i = -\<^sub>a\<^bsub>(A i)\<^esub> (X i)"
 apply (simp add:prod_mOp_def)
 done
 
 lemma prod_zero_func:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                            prod_zero I A \<in> carr_prodag I A"
 apply (simp add:prod_zero_def prodag_def)
 apply (simp add:carr_prodag_def)
 apply (rule conjI)
  apply (rule Pi_I) apply simp
  apply (subgoal_tac "aGroup (A x)") prefer 2 apply simp
  apply (thin_tac "\<forall>k\<in>I. aGroup (A k)")
  apply (simp add:Un_carrier_def)
  apply (frule aGroup.ex_zero)
  apply auto
 apply (frule_tac x = i in bspec, assumption,
        thin_tac "\<forall>k\<in>I. aGroup (A k)")
  apply (simp add:aGroup.ex_zero)
 done
 
 lemma prod_zero_i:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); i \<in> I\<rbrakk> \<Longrightarrow>
                            prod_zero I A i = \<zero>\<^bsub>(A i)\<^esub> "
 by (simp add:prod_zero_def)
 
 lemma carr_prodag_mem_eq:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); X \<in> carr_prodag I A;
 Y \<in> carr_prodag I A; \<forall>l\<in>I. (X l) = (Y l) \<rbrakk> \<Longrightarrow> X = Y"
 apply (simp add:carr_prodag_def)
 apply (erule conjE)+
 apply (simp add:funcset_eq)
 done
 
 lemma prod_pOp_assoc:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); a \<in> carr_prodag I A;
       b \<in> carr_prodag I A; c \<in> carr_prodag I A\<rbrakk> \<Longrightarrow>
       prod_pOp I A (prod_pOp I A a b) c =
                                prod_pOp I A a (prod_pOp I A b c)"
  apply (frule_tac X = a and Y = b in prod_pOp_mem[of "I" "A"], assumption+,
         frule_tac X = b and Y = c in prod_pOp_mem[of "I" "A"], assumption+,
         frule_tac X = "prod_pOp I A a b" and Y = c in prod_pOp_mem[of "I"
             "A"], assumption+,
         frule_tac X = a and Y = "prod_pOp I A b c" in prod_pOp_mem[of "I"
             "A"], assumption+)
  apply (rule carr_prodag_mem_eq[of "I" "A"], assumption+,
        rule ballI)
  apply (simp add:prod_pOp_mem_i)
  apply (frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (A k)")
  apply (rule aGroup.ag_pOp_assoc, assumption)
  apply (simp add:prodag_comp_i)+
 done
 
 lemma prod_pOp_commute:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); a \<in> carr_prodag I A;
                            b \<in> carr_prodag I A\<rbrakk> \<Longrightarrow>
                            prod_pOp I A a b = prod_pOp I A b a"
 apply (frule_tac X = a and Y = b in prod_pOp_mem[of "I" "A"], assumption+,
          frule_tac X = b and Y = a in prod_pOp_mem[of "I" "A"], assumption+)
 apply (rule carr_prodag_mem_eq[of "I" "A"], assumption+,
         rule ballI)
  apply (simp add:prod_pOp_mem_i)
  apply (frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (A k)",
         rule aGroup.ag_pOp_commute, assumption)
  apply (simp add:prodag_comp_i)+
 done
 
 lemma prodag_aGroup:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow> aGroup (prodag I A)"
 apply (simp add:aGroup_def [of "(prodag I A)"])
 apply (simp add:prodag_def)
  apply (simp add:prod_pOp_func)
  apply (simp add:prod_mOp_func)
  apply (simp add:prod_zero_func)
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:prod_pOp_assoc)
 apply (rule conjI)
   apply (rule allI, rule impI)+
   apply (simp add:prod_pOp_commute)
 apply (rule conjI)
  apply (rule allI, rule impI)
  apply (frule_tac X = a in prod_mOp_mem [of "I" "A"], assumption+)
  apply (frule_tac X = "prod_mOp I A a" and Y = a in prod_pOp_mem[of "I" "A"],
         assumption+)
  apply (rule carr_prodag_mem_eq[of "I" "A"], assumption+)
  apply (simp add:prod_zero_func)
  apply (rule ballI)
  apply (simp add:prod_pOp_mem_i,
          simp add:prod_zero_i) apply (
          simp add:prod_mOp_mem_i)
   apply (frule_tac x = l in bspec, assumption,
          thin_tac "\<forall>k\<in>I. aGroup (A k)",
          rule aGroup.l_m, assumption+, simp add:prodag_comp_i)
 apply (rule allI, rule impI)
   apply (frule_tac prod_zero_func[of "I" "A"],
          frule_tac Y = a in prod_pOp_mem[of "I" "A" "prod_zero I A"],
           assumption+)
   apply (rule carr_prodag_mem_eq[of "I" "A"], assumption+)
   apply (rule ballI)
   apply (subst prod_pOp_mem_i[of "I" "A"], assumption+,
          subst prod_zero_i[of "I" "A"], assumption+)
   apply (frule_tac x = l in bspec, assumption,
          rule aGroup.l_zero, assumption+,
          simp add:prodag_comp_i)
 done
 
 lemma prodag_carrier:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
             carrier (prodag I A) = carr_prodag I A"
 by (simp add:prodag_def)
 
 lemma prodag_elemfun:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); f \<in> carrier (prodag I A)\<rbrakk> \<Longrightarrow>
          f \<in> extensional I"
 apply (simp add:prodag_carrier)
 apply (simp add:carr_prodag_def)
 done
 
 lemma prodag_component:"\<lbrakk>f \<in> carrier (prodag I A); i \<in> I \<rbrakk> \<Longrightarrow>
                               f i \<in> carrier (A i)"
 by (simp add:prodag_def carr_prodag_def)
 
 lemma prodag_pOp:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   pop (prodag I A) = prod_pOp I A"
 apply (simp add:prodag_def)
 done
 
 lemma prodag_iOp:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   mop (prodag I A) = prod_mOp I A"
 apply (simp add:prodag_def)
 done
 
 lemma prodag_zero:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   zero (prodag I A) = prod_zero I A"
 apply (simp add:prodag_def)
 done
 
 lemma prodag_sameTr0:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); \<forall>k\<in>I. A k = B k\<rbrakk>
                                \<Longrightarrow> Un_carrier I A = Un_carrier I B"
 apply (simp add:Un_carrier_def)
 done
 
 lemma prodag_sameTr1:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); \<forall>k\<in>I. A k = B k\<rbrakk>
                                \<Longrightarrow> carr_prodag I A = carr_prodag I B"
 apply (rule equalityI)
  apply (rule subsetI)
  apply (simp add:carr_prodag_def, (erule conjE)+)
  apply (rule Pi_I)
  apply (subst Un_carrier_def, simp, blast)
 
 apply (rule subsetI)
  apply (simp add:carr_prodag_def, (erule conjE)+)
  apply (rule Pi_I)
  apply (subst Un_carrier_def, simp)
  apply blast
 done
 
 lemma prodag_sameTr2:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); \<forall>k\<in>I. A k = B k\<rbrakk>
                                \<Longrightarrow> prod_pOp I A = prod_pOp I B"
 apply (frule prodag_sameTr1 [of "I" "A" "B"], assumption+)
 apply (simp add:prod_pOp_def)
 apply (rule bivar_func_eq)
 apply (rule ballI)+
 apply (rule funcset_eq [of _ "I"])
  apply (simp add:restrict_def extensional_def)+
 done
 
 lemma prodag_sameTr3:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); \<forall>k\<in>I. A k = B k\<rbrakk>
                                \<Longrightarrow> prod_mOp I A = prod_mOp I B"
 apply (frule prodag_sameTr1 [of "I" "A" "B"], assumption+)
 apply (simp add:prod_mOp_def)
 apply (rule funcset_eq [of _ "carr_prodag I B"])
  apply (simp add:restrict_def extensional_def)
  apply (simp add:restrict_def extensional_def)
 apply (rule ballI)
 apply (rename_tac g) apply simp
 apply (rule funcset_eq [of _ "I"])
  apply (simp add:restrict_def extensional_def)+
 done
 
 lemma prodag_sameTr4:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); \<forall>k\<in>I. A k = B k\<rbrakk>
                                \<Longrightarrow> prod_zero I A = prod_zero I B"
 apply (simp add:prod_zero_def)
 apply (rule funcset_eq [of _ "I"])
  apply (simp add:restrict_def extensional_def)+
 done
 
 lemma prodag_same:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); \<forall>k\<in>I. A k = B k\<rbrakk>
                                \<Longrightarrow> prodag I A = prodag I B"
 apply (frule prodag_sameTr1, assumption+)
 apply (frule prodag_sameTr2, assumption+)
 apply (frule prodag_sameTr3, assumption+)
 apply (frule prodag_sameTr4, assumption+)
 apply (simp add:prodag_def)
 done
 
 lemma project_mem:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); j \<in> I; x \<in> carrier (prodag I A)\<rbrakk> \<Longrightarrow>
                          (PRoject I A j) x  \<in> carrier (A j)"
 apply (simp add:PRoject_def)
 apply (simp add:prodag_def)
 apply (simp add:carr_prodag_def)
 done
 
 lemma project_aHom:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); j \<in> I\<rbrakk> \<Longrightarrow>
                          PRoject I A j \<in> aHom (prodag I A) (A j)"
 apply (simp add:aHom_def)
 apply (rule conjI)
  apply (simp add:project_mem)
 apply (rule conjI)
  apply (simp add:PRoject_def restrict_def extensional_def)
  apply (rule allI, rule impI, simp add:prodag_def)
 apply (rule ballI)+
  apply (simp add:prodag_def)
  apply (simp add:prod_pOp_def)
  apply (frule_tac X = a and Y = b in prod_pOp_mem[of I A], assumption+)
  apply (simp add:prod_pOp_def)
  apply (simp add:PRoject_def)
 done
 
 lemma project_aHom1:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                       \<forall>j \<in> I. PRoject I A j \<in> aHom (prodag I A) (A j)"
 apply (rule ballI)
 apply (rule project_aHom, assumption+)
 done
 
 definition
   A_to_prodag :: "[('a, 'm) aGroup_scheme, 'i set, 'i \<Rightarrow>('a \<Rightarrow> 'b),
    'i  \<Rightarrow> ('b, 'm1) aGroup_scheme] \<Rightarrow> ('a \<Rightarrow> ('i \<Rightarrow>'b))" where
  "A_to_prodag A I S B = (\<lambda>a\<in>carrier A. \<lambda>k\<in>I. S k a)"
 
  (* I is an index set, A is an abelian group, S: I \<rightarrow> carrier A \<rightarrow>
   carrier (prodag I B),   s i \<in> carrier A \<rightarrow> B i  *)
 
 lemma A_to_prodag_mem:"\<lbrakk>aGroup A; \<forall>k\<in>I. aGroup (B k);  \<forall>k\<in>I. (S k) \<in>
  aHom A (B k); x \<in> carrier A \<rbrakk> \<Longrightarrow> A_to_prodag A I S B x \<in> carr_prodag I B"
 apply (simp add:carr_prodag_def)
 apply (rule conjI)
 apply (simp add:A_to_prodag_def extensional_def restrict_def)
 apply (simp add:Pi_def restrict_def A_to_prodag_def)
 apply (rule conjI)
 apply (rule allI) apply (rule impI)
 apply (simp add:Un_carrier_def)
  apply (rotate_tac 2,
         frule_tac x = xa in bspec, assumption,
         thin_tac "\<forall>k\<in>I. S k \<in> aHom A (B k)")
  apply (simp add:aHom_def) apply (erule conjE)+
  apply (frule_tac f = "S xa" and A = "carrier A" and B = "carrier (B xa)"
            and x = x in funcset_mem, assumption+)
  apply blast
 apply (rule ballI)
  apply (rotate_tac 2,
         frule_tac x = i in bspec, assumption,
         thin_tac "\<forall>k\<in>I. S k \<in> aHom A (B k)")
  apply (simp add:aHom_def) apply (erule conjE)+
  apply (simp add:Pi_def)
 done
 
 lemma A_to_prodag_aHom:"\<lbrakk>aGroup A; \<forall>k\<in>I. aGroup (B k); \<forall>k\<in>I. (S k) \<in>
  aHom A (B k) \<rbrakk>  \<Longrightarrow> A_to_prodag A I S B \<in> aHom A (a\<Pi>\<^bsub>I\<^esub> B)"
 apply (simp add:aHom_def [of "A" "a\<Pi>\<^bsub>I\<^esub> B"])
 apply (rule conjI)
  apply (simp add:prodag_def A_to_prodag_mem)
 
 apply (rule conjI)
 apply (simp add:A_to_prodag_def restrict_def extensional_def)
 apply (rule ballI)+
  apply (frule_tac x = a and y = b in aGroup.ag_pOp_closed, assumption+)
  apply (frule_tac x = "a \<plusminus>\<^bsub>A\<^esub> b" in A_to_prodag_mem [of "A" "I" "B" "S"],
                                                        assumption+)
  apply (frule_tac x = a in A_to_prodag_mem [of "A" "I" "B" "S"],
                                                        assumption+)
  apply (frule_tac x = b in A_to_prodag_mem [of "A" "I" "B" "S"],
                                                        assumption+)
  apply (frule prodag_aGroup [of "I" "B"])
  apply (frule_tac x = a in A_to_prodag_mem[of "A" "I" "B" "S"], assumption+,
         frule_tac x = b in A_to_prodag_mem[of "A" "I" "B" "S"], assumption+,
         frule_tac x = "a \<plusminus>\<^bsub>A\<^esub> b" in A_to_prodag_mem[of "A" "I" "B" "S"],
                                                  assumption+)
  apply (frule prodag_aGroup[of "I" "B"],
         frule_tac x = "A_to_prodag A I S B a" and
  y = "A_to_prodag A I S B b" in aGroup.ag_pOp_closed [of "a\<Pi>\<^bsub>I\<^esub> B"])
  apply (simp add:prodag_carrier)
  apply (simp add:prodag_carrier)
  apply (rule carr_prodag_mem_eq, assumption+)
  apply (simp add:prodag_carrier)
  apply (rule ballI)
  apply (simp add:A_to_prodag_def prod_pOp_def)
  apply (rotate_tac 2,
         frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>k\<in>I. S k \<in> aHom A (B k)")
  apply (simp add:prodag_def prod_pOp_def)
  apply (frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (B k)")
 apply (simp add: aHom_add)
 done
 
 definition
   finiteHom :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme, 'i \<Rightarrow> 'a] \<Rightarrow> bool" where
   "finiteHom I A f \<longleftrightarrow> f \<in> carr_prodag I A \<and> (\<exists>H. H \<subseteq> I \<and> finite H \<and> (
     \<forall>j \<in> (I - H). (f j) = \<zero>\<^bsub>(A j)\<^esub>))"
 
 definition
   carr_dsumag :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow> ('i  \<Rightarrow> 'a ) set" where
   "carr_dsumag I A = {f. finiteHom I A f}"
 
 definition
   dsumag :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme] \<Rightarrow> ('i \<Rightarrow> 'a) aGroup" where
   "dsumag I A = \<lparr> carrier = carr_dsumag I A,
      pop = prod_pOp I A, mop = prod_mOp I A,
      zero = prod_zero I A\<rparr>"
 
 definition
   dProj :: "['i set, 'i \<Rightarrow> ('a, 'more) aGroup_scheme, 'i]
                    \<Rightarrow> ('i \<Rightarrow> 'a) \<Rightarrow> 'a" where
   "dProj I A x = (\<lambda>f\<in>carr_dsumag I A. f x)"
 
 abbreviation
   DSUMag  ("(a\<Oplus>\<^bsub>_\<^esub> _)" [72,73]72) where
   "a\<Oplus>\<^bsub>I\<^esub> A == dsumag I A"
 
 lemma dsum_pOp_func:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
     prod_pOp I A \<in> carr_dsumag I A \<rightarrow> carr_dsumag I A \<rightarrow> carr_dsumag I A"
 apply (rule Pi_I)+
  apply (subst carr_dsumag_def) apply (simp add:CollectI)
 apply (simp add:finiteHom_def)
  apply (rule conjI)
  apply (simp add:carr_dsumag_def) apply (simp add:finiteHom_def)
  apply (erule conjE)+ apply (simp add:prod_pOp_mem)
 apply (simp add:carr_dsumag_def finiteHom_def) apply (erule conjE)+
  apply ((erule exE)+, (erule conjE)+)
  apply (frule_tac F = H and G = Ha in finite_UnI, assumption+)
  apply (subgoal_tac "\<forall>j\<in>I - (H \<union> Ha). prod_pOp I A x xa j = \<zero>\<^bsub>A j\<^esub>")
  apply (frule_tac A = H and B = Ha in Un_least[of _ "I"], assumption+)
   apply blast
 
  apply (rule ballI)
  apply (simp, (erule conjE)+)
  apply (frule_tac x = j in bspec, assumption,
          thin_tac "\<forall>k\<in>I. aGroup (A k)",
         frule_tac x = j in bspec, simp,
          thin_tac "\<forall>j\<in>I - H. x j = \<zero>\<^bsub>A j\<^esub>",
         frule_tac x = j in bspec, simp,
          thin_tac "\<forall>j\<in>I - Ha. xa j = \<zero>\<^bsub>A j\<^esub>")
  apply (simp add:prod_pOp_def)
  apply (rule aGroup.ag_l_zero) apply simp
  apply (rule aGroup.ex_zero) apply assumption
 done
 
 lemma dsum_pOp_mem:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); X \<in> carr_dsumag I A;
  Y \<in> carr_dsumag I A\<rbrakk> \<Longrightarrow> prod_pOp I A X Y \<in> carr_dsumag I A"
 apply (frule dsum_pOp_func[of "I" "A"])
 apply (frule funcset_mem[of "prod_pOp I A" "carr_dsumag I A"
               "carr_dsumag I A \<rightarrow> carr_dsumag I A" "X"], assumption+)
 apply (rule funcset_mem[of "prod_pOp I A X" "carr_dsumag I A"
             "carr_dsumag I A" "Y"], assumption+)
 done
 
 lemma dsum_iOp_func:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   prod_mOp I A \<in> carr_dsumag I A \<rightarrow> carr_dsumag I A"
 apply (rule Pi_I)
  apply (simp add:carr_dsumag_def) apply (simp add:finiteHom_def)
  apply (erule conjE)+ apply (simp add:prod_mOp_mem)
  apply (erule exE, (erule conjE)+)
  apply (simp add:prod_mOp_def)
  apply (subgoal_tac "\<forall>j\<in>I - H. -\<^sub>a\<^bsub>A j\<^esub> (x j) = \<zero>\<^bsub>A j\<^esub>")
  apply blast
 
 apply (rule ballI)
  apply (frule_tac x = j in bspec, simp,
         thin_tac "\<forall>k\<in>I. aGroup (A k)",
         frule_tac x = j in bspec, simp,
         thin_tac "\<forall>j\<in>I - H. x j = \<zero>\<^bsub>A j\<^esub>", simp add:aGroup.ag_inv_zero)
 done
 
 lemma dsum_iOp_mem:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); X \<in> carr_dsumag I A\<rbrakk> \<Longrightarrow>
                          prod_mOp I A X \<in> carr_dsumag I A"
 apply (frule dsum_iOp_func)
 apply (simp add:Pi_def)
 done
 
 lemma dsum_zero_func:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                            prod_zero I A \<in> carr_dsumag I A"
 apply (simp add:carr_dsumag_def) apply (simp add:finiteHom_def)
 apply (rule conjI) apply (simp add:prod_zero_func)
  apply (subgoal_tac "{} \<subseteq> I") prefer 2 apply simp
  apply (subgoal_tac "finite {}") prefer 2 apply simp
  apply (subgoal_tac "\<forall>j\<in>I - {}. prod_zero I A j = \<zero>\<^bsub>A j\<^esub>")
  apply blast
  apply (rule ballI) apply simp
  apply (simp add:prod_zero_def)
 done
 
 lemma dsumag_sub_prodag:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                               carr_dsumag I A \<subseteq> carr_prodag I A"
 by (rule subsetI,
        simp add:carr_dsumag_def finiteHom_def)
 
 lemma carrier_dsumag:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
          carrier (dsumag I A) = carr_dsumag I A"
 apply (simp add:dsumag_def)
 done
 
 lemma dsumag_elemfun:"\<lbrakk>\<forall>k\<in>I. aGroup (A k); f \<in> carrier (dsumag I A)\<rbrakk> \<Longrightarrow>
          f \<in> extensional I"
 apply (simp add:carrier_dsumag)
 apply (simp add:carr_dsumag_def) apply (simp add:finiteHom_def)
 apply (erule conjE) apply (simp add:carr_prodag_def)
 done
 
 lemma dsumag_aGroup:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow> aGroup (dsumag I A)"
 apply (simp add:aGroup_def [of "dsumag I A"])
 apply (simp add:dsumag_def)
 apply (simp add:dsum_pOp_func)
 apply (simp add:dsum_iOp_func)
 apply (simp add:dsum_zero_func)
 apply (frule dsumag_sub_prodag[of "I" "A"])
 
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (frule_tac X = a and Y = b in dsum_pOp_mem, assumption+)
  apply (frule_tac X = b and Y = c in dsum_pOp_mem, assumption+)
  apply (frule_tac X = "prod_pOp I A a b" and Y = c in dsum_pOp_mem,
                     assumption+)
  apply (frule_tac Y = "prod_pOp I A b c" and X = a in dsum_pOp_mem,
                     assumption+)
  apply (rule carr_prodag_mem_eq [of "I" "A"], assumption+)
  apply (simp add:subsetD) apply (simp add:subsetD)
  apply (rule ballI)
  apply (subst prod_pOp_mem_i, assumption+, (simp add:subsetD)+)
  apply (subst prod_pOp_mem_i, assumption+)
   apply (simp add:subsetD)+
  apply (subst prod_pOp_mem_i, assumption+, (simp add:subsetD)+)
  apply (subst prod_pOp_mem_i, assumption+) apply (simp add:subsetD)+
  apply (thin_tac "prod_pOp I A a b \<in> carr_dsumag I A",
         thin_tac "prod_pOp I A b c \<in> carr_dsumag I A",
         thin_tac "prod_pOp I A (prod_pOp I A a b) c \<in> carr_dsumag I A",
         thin_tac "prod_pOp I A a (prod_pOp I A b c) \<in> carr_dsumag I A",
         thin_tac "carr_dsumag I A \<subseteq> carr_prodag I A")
 
  apply (frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (A k)",
         simp add:carr_dsumag_def finiteHom_def, (erule conjE)+,
         simp add:carr_prodag_def, (erule conjE)+)
  apply (frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>i\<in>I. a i \<in> carrier (A i)",
         frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>i\<in>I. b i \<in> carrier (A i)",
         frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>i\<in>I. c i \<in> carrier (A i)")
  apply (simp add:aGroup.aassoc)
 
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (rule carr_prodag_mem_eq [of "I" "A"], assumption+)
   apply (frule_tac X = a and Y = b in prod_pOp_mem[of "I" "A"],
          (simp add:subsetD)+)
   apply (frule_tac X = b and Y = a in prod_pOp_mem[of "I" "A"],
          (simp add:subsetD)+)
   apply (rule ballI,
          subst prod_pOp_mem_i, assumption+, (simp add:subsetD)+)
   apply (subst prod_pOp_mem_i, assumption+, (simp add:subsetD)+)
   apply (frule_tac x = l in bspec, assumption,
          thin_tac "\<forall>k\<in>I. aGroup (A k)")
   apply (frule_tac c = a in subsetD[of "carr_dsumag I A" "carr_prodag I A"],
           assumption+, thin_tac "a \<in> carr_dsumag I A",
          frule_tac c = b in subsetD[of "carr_dsumag I A" "carr_prodag I A"],
           assumption+, thin_tac "b \<in> carr_dsumag I A",
           thin_tac "carr_dsumag I A \<subseteq> carr_prodag I A")
   apply (simp add:carr_prodag_def, (erule conjE)+,
          simp add:aGroup.ag_pOp_commute)
 
 apply (rule conjI)
  apply (rule allI, rule impI)
  apply (frule_tac X = a in prod_mOp_mem[of "I" "A"],
         simp add:subsetD)
  apply (frule_tac X = "prod_mOp I A a" and Y = a in prod_pOp_mem[of "I" "A"],
         simp add:subsetD, simp add:subsetD)
  apply (rule carr_prodag_mem_eq [of "I" "A"], assumption+,
         simp add:prod_zero_func)
  apply (rule ballI)
  apply (subst prod_pOp_mem_i, assumption+,
         simp add:subsetD, assumption)
  apply (subst prod_mOp_mem_i, assumption+, simp add:subsetD, assumption)
  apply (simp add:prod_zero_i)
  apply (frule_tac x = l in bspec, assumption,
          thin_tac "\<forall>k\<in>I. aGroup (A k)",
          thin_tac "prod_mOp I A a \<in> carr_prodag I A",
          thin_tac "prod_pOp I A (prod_mOp I A a) a \<in> carr_prodag I A",
         frule_tac c = a in subsetD[of "carr_dsumag I A" "carr_prodag I A"],
          assumption,
         thin_tac "carr_dsumag I A \<subseteq> carr_prodag I A",
         simp add:carr_prodag_def, (erule conjE)+)
   apply (frule_tac x = l in bspec, assumption,
          thin_tac "\<forall>i\<in>I. a i \<in> carrier (A i)")
   apply (rule aGroup.l_m, assumption+)
 
 apply (rule allI, rule impI)
  apply (frule prod_zero_func[of "I" "A"])
  apply (frule_tac X = "prod_zero I A" and Y = a in prod_pOp_mem[of "I" "A"],
             assumption+, simp add:subsetD)
  apply (rule carr_prodag_mem_eq [of "I" "A"], assumption+,
         simp add:subsetD)
  apply (rule ballI)
  apply (subst prod_pOp_mem_i, assumption+)
         apply (simp add:subsetD, assumption)
  apply (simp add:prod_zero_i,
         frule_tac x = l in bspec, assumption,
         thin_tac "\<forall>k\<in>I. aGroup (A k)",
         frule_tac c = a in subsetD[of "carr_dsumag I A" "carr_prodag I A"],
                   assumption+,
         thin_tac "carr_dsumag I A \<subseteq> carr_prodag I A",
         thin_tac "a \<in> carr_dsumag I A",
         thin_tac "prod_pOp I A (prod_zero I A) a \<in> carr_prodag I A")
  apply (simp add:carr_prodag_def, (erule conjE)+)
  apply (rule aGroup.l_zero, assumption)
  apply blast
 done
 
 lemma dsumag_pOp:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   pop (dsumag I A) = prod_pOp I A"
 apply (simp add:dsumag_def)
 done
 
 lemma dsumag_mOp:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   mop (dsumag I A) = prod_mOp I A"
 apply (simp add:dsumag_def)
 done
 
 lemma dsumag_zero:"\<forall>k\<in>I. aGroup (A k) \<Longrightarrow>
                   zero (dsumag I A) = prod_zero I A"
 apply (simp add:dsumag_def)
 done
 
 
 subsection "Characterization of a direct product"
 
 lemma direct_prod_mem_eq:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A);
        g \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A); \<forall>j\<in>I. (PRoject I A j) f = (PRoject I A j) g\<rbrakk> \<Longrightarrow>
        f = g"
 apply (rule funcset_eq[of "f" "I" "g"])
  apply (thin_tac "\<forall>j\<in>I. aGroup (A j)",
         thin_tac "g \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A)",
         thin_tac "\<forall>j\<in>I. (\<pi>\<^bsub>I,A,j\<^esub>) f = (\<pi>\<^bsub>I,A,j\<^esub>) g",
         simp add:prodag_def carr_prodag_def)
   apply (thin_tac "\<forall>j\<in>I. aGroup (A j)",
         thin_tac "f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A)",
         thin_tac "\<forall>j\<in>I. (\<pi>\<^bsub>I,A,j\<^esub>) f = (\<pi>\<^bsub>I,A,j\<^esub>) g",
         simp add:prodag_def carr_prodag_def)
  apply (simp add:PRoject_def prodag_def)
 done
 
 lemma map_family_fun:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); aGroup S;
       \<forall>j\<in>I. ((g j) \<in> aHom S (A j)); x \<in> carrier S\<rbrakk> \<Longrightarrow>
          (\<lambda>y \<in> carrier S. (\<lambda>j\<in>I. (g j) y)) x \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A)"
 apply (simp add:prodag_def carr_prodag_def)
  apply (simp add:aHom_mem)
  apply (rule Pi_I, simp add:Un_carrier_def)
  apply (frule_tac x = xa in bspec, assumption,
         thin_tac "\<forall>j\<in>I. aGroup (A j)",
         frule_tac x = xa in bspec, assumption,
         thin_tac "\<forall>j\<in>I. g j \<in> aHom S (A j)")
  apply (frule_tac G = "A xa" and f = "g xa" and a = x in aHom_mem[of "S"],
         assumption+, blast)
 done
 
 lemma map_family_aHom:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); aGroup S;
       \<forall>j\<in>I. ((g j) \<in> aHom S (A j))\<rbrakk> \<Longrightarrow>
          (\<lambda>y \<in> carrier S. (\<lambda>j\<in>I. (g j) y)) \<in> aHom S (a\<Pi>\<^bsub>I\<^esub> A)"
 apply (subst aHom_def, simp)
  apply (simp add:aGroup.ag_pOp_closed)
 
 apply (rule conjI)
  apply (rule Pi_I)
  apply (rule map_family_fun[of "I" "A" "S" "g"], assumption+)
 apply (rule ballI)+
  apply (frule_tac x = a and y = b in aGroup.ag_pOp_closed[of "S"],
                    assumption+)
  apply (frule_tac x = "a \<plusminus>\<^bsub>S\<^esub> b" in map_family_fun[of "I" "A" "S" "g"],
           assumption+, simp)
  apply (frule_tac x = a in map_family_fun[of "I" "A" "S" "g"],
           assumption+, simp,
          frule_tac x = b in map_family_fun[of "I" "A" "S" "g"],
           assumption+, simp)
  apply (frule prodag_aGroup[of "I" "A"])
  apply (frule_tac x = "(\<lambda>j\<in>I. g j a)" and y = "(\<lambda>j\<in>I. g j b)" in
         aGroup.ag_pOp_closed[of "a\<Pi>\<^bsub>I\<^esub> A"], assumption+)
  apply (simp only:prodag_carrier)
 
 apply (rule carr_prodag_mem_eq, assumption+)
  apply (rule ballI)
  apply (subst prodag_def, simp add:prod_pOp_def)
  apply (simp add:aHom_add)
 done
 
 lemma map_family_triangle:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); aGroup S;
          \<forall>j\<in>I. ((g j) \<in> aHom S (A j))\<rbrakk> \<Longrightarrow> \<exists>!f. f \<in> aHom S (a\<Pi>\<^bsub>I\<^esub> A) \<and>
                   (\<forall>j\<in>I. compos S (PRoject I A j) f =  (g j))"
 apply (rule ex_ex1I)
 apply (frule map_family_aHom[of "I" "A" "S" "g"], assumption+)
 apply (subgoal_tac "\<forall>j\<in>I. compos S (\<pi>\<^bsub>I,A,j\<^esub>) (\<lambda>y\<in>carrier S. \<lambda>j\<in>I. g j y) = g j")
 apply blast
 apply (rule ballI)
 apply (simp add:compos_def)
 apply (rule funcset_eq[of _ "carrier S"])
  apply (simp add:compose_def) apply (simp add:aHom_def)
  apply (rule ballI)
  apply (frule prodag_aGroup[of "I" "A"])
  apply (frule prodag_carrier[of "I" "A"])
  apply (frule_tac f = "\<lambda>y\<in>carrier S. \<lambda>j\<in>I. g j y" and a = x in
         aHom_mem[of "S" "a\<Pi>\<^bsub>I\<^esub> A"], assumption+)
  apply (simp add:compose_def, simp add:PRoject_def)
 apply (rename_tac f f1)
  apply (erule conjE)+
  apply (rule funcset_eq[of _ "carrier S"])
  apply (simp add:aHom_def, simp add:aHom_def)
  apply (rule ballI)
  apply (frule prodag_aGroup[of "I" "A"])
  apply (frule_tac f = f and a = x in aHom_mem[of "S" "a\<Pi>\<^bsub>I\<^esub> A"], assumption+,
         frule_tac f = f1 and a = x in aHom_mem[of "S" "a\<Pi>\<^bsub>I\<^esub> A"], assumption+)
  apply (rule_tac f = "f x" and g = "f1 x" in direct_prod_mem_eq[of "I" "A"],
         assumption+)
  apply (rule ballI)
  apply (rotate_tac 4,
         frule_tac x = j in bspec, assumption,
         thin_tac "\<forall>j\<in>I. compos S (\<pi>\<^bsub>I,A,j\<^esub>) f = g j",
          frule_tac x = j in bspec, assumption,
         thin_tac "\<forall>j\<in>I. compos S (\<pi>\<^bsub>I,A,j\<^esub>) f1 = g j",
         simp add:compos_def compose_def)
  apply (subgoal_tac "(\<lambda>x\<in>carrier S. (\<pi>\<^bsub>I,A,j\<^esub>) (f x)) x = g j x",
         subgoal_tac "(\<lambda>x\<in>carrier S. (\<pi>\<^bsub>I,A,j\<^esub>) (f1 x)) x = g j x",
         thin_tac "(\<lambda>x\<in>carrier S. (\<pi>\<^bsub>I,A,j\<^esub>) (f x)) = g j",
         thin_tac "(\<lambda>x\<in>carrier S. (\<pi>\<^bsub>I,A,j\<^esub>) (f1 x)) = g j",
 simp+)
 done
 
 lemma Ag_ind_triangle:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); j \<in> I; f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) (B::'d set); j \<in> I\<rbrakk> \<Longrightarrow>
 compos (a\<Pi>\<^bsub>I\<^esub> A) (compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)(PRoject I A j) (ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),
  (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)\<^esub> (Agii (a\<Pi>\<^bsub>I\<^esub> A) f))) (Agii (a\<Pi>\<^bsub>I\<^esub> A) f) =
                                        PRoject I A j"
 apply (frule prodag_aGroup[of "I" "A"])
 apply (frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (simp add:compos_def)
 apply (rule funcset_eq[of _ "carrier (a\<Pi>\<^bsub>I\<^esub> A)"])
 apply simp
 apply (simp add:PRoject_def  prodag_carrier extensional_def)
 apply (rule ballI)
 apply (simp add:compose_def invfun_l)
 apply (simp add:aGroup.Agii_mem)
 apply (frule Ag_ind_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule_tac x = x in ainvf_l[of "a\<Pi>\<^bsub>I\<^esub> A" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f"
                                      "Agii (a\<Pi>\<^bsub>I\<^esub> A) f"], assumption+)
 apply simp
 done
 
 (** Note               f'
                  a\<Pi>\<^bsub>I\<^esub> A \<rightarrow> Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f
                      \     |
                       \    |
         PRoject I A j  \   | (PRoject I A j) o (f'\<inverse>\<^sup>1)
                         \  |
                           A j             , where f' = Agii (a\<Pi>\<^bsub>I\<^esub> A) f **)
 
 definition
   ProjInd :: "['i set, 'i \<Rightarrow> ('a, 'm) aGroup_scheme, ('i \<Rightarrow> 'a) \<Rightarrow> 'd, 'i] \<Rightarrow>
                        ('d \<Rightarrow> 'a)" where
   "ProjInd I A f j = compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)(PRoject I A j) (ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A), (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)\<^esub> (Agii (a\<Pi>\<^bsub>I\<^esub> A) f))"
 
 (** Note               f'
                  a\<Pi>\<^bsub>I\<^esub> A \<rightarrow> Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f
                      \     |
                       \    |
         PRoject I A j  \   | PRojInd I A f j
                         \  |
                           A j              **)
 
 lemma ProjInd_aHom:"\<lbrakk>\<forall>j\<in> I. aGroup (A j); j \<in> I; f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) (B::'d set); j \<in> I\<rbrakk> \<Longrightarrow>
         (ProjInd I A f j) \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) (A j)"
 apply (frule prodag_aGroup[of "I" "A"])
 apply (frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule_tac x = j in bspec, assumption)
 apply (frule aGroup.Ag_ind_aHom[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (simp add:ProjInd_def)
 apply (frule Ag_ind_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule ainvf_aHom[of "a\<Pi>\<^bsub>I\<^esub> A" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "Agii (a\<Pi>\<^bsub>I\<^esub> A) f"],
              assumption+)
 apply (frule project_aHom[of "I" "A" "j"], assumption)
 apply (simp add:aHom_compos)
 done
 
 lemma ProjInd_aHom1:"\<lbrakk>\<forall>j\<in> I. aGroup (A j); f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) (B::'d set)\<rbrakk> \<Longrightarrow>
         \<forall>j\<in>I. (ProjInd I A f j) \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) (A j)"
 apply (rule ballI)
 apply (simp add:ProjInd_aHom)
 done
 
 lemma ProjInd_mem_eq:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) B; aGroup S; x \<in> carrier (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f);
       y \<in> carrier (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f);
       \<forall>j\<in>I. (ProjInd I A f j x = ProjInd I A f j y)\<rbrakk> \<Longrightarrow> x = y"
 apply (simp add:ProjInd_def)
 apply (simp add:compos_def compose_def)
 apply (frule prodag_aGroup[of "I" "A"])
 apply (frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule aGroup.Ag_ind_aHom[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule Ag_ind_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule ainvf_aHom[of "a\<Pi>\<^bsub>I\<^esub> A" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "Agii (a\<Pi>\<^bsub>I\<^esub> A) f"],
          assumption+)
 apply (frule aHom_mem[of "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "a\<Pi>\<^bsub>I\<^esub> A" "ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f" "x"], assumption+,
        frule aHom_mem[of "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "a\<Pi>\<^bsub>I\<^esub> A" "ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f" "y"], assumption+)
 
 apply (frule direct_prod_mem_eq[of "I" "A" "(ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f) x" "(ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f) y"], assumption+)
 apply (thin_tac "ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f
      \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) (a\<Pi>\<^bsub>I\<^esub> A)")
 apply (frule ainvf_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "Agii (a\<Pi>\<^bsub>I\<^esub> A) f"],
                    assumption+)
 apply (thin_tac "bijec\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f")
 apply (unfold bijec_def, frule conjunct1, fold bijec_def)
 apply (frule injec_inj_on[of "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "a\<Pi>\<^bsub>I\<^esub> A" "ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f"], assumption+)
 apply (simp add:injective_iff[THEN sym, of "ainvf\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) f" "carrier (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)" "x" "y"])
 done
 
 lemma ProjInd_mem_eq1:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) B; aGroup S;
       h \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f);
       \<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) (ProjInd I A f j) h = ProjInd I A f j\<rbrakk>       \<Longrightarrow> h = ag_idmap (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)"
 apply (rule funcset_eq[of _ "carrier (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f)"])
  apply (simp add:aHom_def)
  apply (simp add:ag_idmap_def)
 apply (rule ballI)
  apply (simp add:ag_idmap_def)
  apply (frule prodag_aGroup[of "I" "A"],
         frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
  apply (frule_tac a = x in aHom_mem[of "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f"
         "h"], assumption+)
  apply (rule_tac x = "h x" and y = x in ProjInd_mem_eq[of "I" "A" "f" "B" "S"],
         assumption+)
  apply (rotate_tac 1,
         rule ballI,
         frule_tac x = j in bspec, assumption,
         thin_tac "\<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) (ProjInd I A f j) h =
                ProjInd I A f j")
  apply (simp add:compos_def compose_def)
  apply (subgoal_tac "(\<lambda>x\<in>carrier (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f). ProjInd I A f j (h x)) x
                     = ProjInd I A f j x",
         thin_tac "(\<lambda>x\<in>carrier (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f). ProjInd I A f j (h x)) =
            ProjInd I A f j")
  apply simp+
 done
 
 lemma Ag_ind_triangle1:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) (B::'d set); j \<in> I\<rbrakk> \<Longrightarrow>
       compos (a\<Pi>\<^bsub>I\<^esub> A) (ProjInd I A f j) (Agii (a\<Pi>\<^bsub>I\<^esub> A) f) =  PRoject I A j"
 apply (simp add:ProjInd_def)
 apply (simp add:Ag_ind_triangle)
 done
 
 lemma map_family_triangle1:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); f \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
       bij_to f (carrier (a\<Pi>\<^bsub>I\<^esub> A)) (B::'d set); aGroup S;
      \<forall>j\<in>I. ((g j) \<in> aHom S (A j))\<rbrakk> \<Longrightarrow> \<exists>!h. h \<in> aHom S (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f) \<and>
                   (\<forall>j\<in>I. compos S (ProjInd I A f j) h =  (g j))"
 apply (frule prodag_aGroup[of "I" "A"])
 apply (frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (frule Ag_ind_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" "f" "B"], assumption+)
 apply (rule ex_ex1I)
 apply (frule map_family_triangle[of "I" "A" "S" "g"], assumption+)
 apply (frule ex1_implies_ex)
 apply (erule exE)
 apply (erule conjE)
 apply (unfold bijec_def, frule conjunct2, fold bijec_def)
 apply (unfold surjec_def, frule conjunct1, fold surjec_def)
 apply (rename_tac fa,
        frule_tac f = fa in aHom_compos[of "S" "a\<Pi>\<^bsub>I\<^esub> A" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f" _
                  "Agii (a\<Pi>\<^bsub>I\<^esub> A) f"], assumption+)
 apply (subgoal_tac "\<forall>j\<in>I. compos S (ProjInd I A f j)
                            (compos S (Agii (a\<Pi>\<^bsub>I\<^esub> A) f) fa) = g j")
 apply blast
 apply (rule ballI)
 apply (frule_tac N = "A j" and f = fa and g = "Agii (a\<Pi>\<^bsub>I\<^esub> A) f" and
  h = "ProjInd I A f j" in aHom_compos_assoc[of "S" "a\<Pi>\<^bsub>I\<^esub> A" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f"],
  assumption+) apply simp apply assumption+
 apply (simp add:ProjInd_aHom)
 apply simp
 apply (thin_tac "compos S (ProjInd I A f j) (compos S (Agii (a\<Pi>\<^bsub>I\<^esub> A) f) fa) =
         compos S (compos (a\<Pi>\<^bsub>I\<^esub> A) (ProjInd I A f j) (Agii (a\<Pi>\<^bsub>I\<^esub> A) f)) fa")
 apply (simp add:Ag_ind_triangle1)
 apply (rename_tac h h1)
  apply (erule conjE)+
  apply (rule funcset_eq[of _ "carrier S"])
  apply (simp add:aHom_def, simp add:aHom_def)
  apply (rule ballI)
  apply (simp add:compos_def)
 
 apply (frule_tac f = h and a = x in aHom_mem[of "S" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f"],
           assumption+,
        frule_tac f = h1 and a = x in aHom_mem[of "S" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) f"],
           assumption+)
 apply (rule_tac x = "h x" and y = "h1 x" in ProjInd_mem_eq[of "I" "A" "f"
        "B" "S"], assumption+)
 apply (rule ballI)
 apply (rotate_tac 5,
        frule_tac x = j in bspec, assumption,
        thin_tac "\<forall>j\<in>I. compose (carrier S) (ProjInd I A f j) h = g j",
        frule_tac x = j in bspec, assumption,
        thin_tac "\<forall>j\<in>I. compose (carrier S) (ProjInd I A f j) h1 = g j")
 apply (simp add:compose_def,
        subgoal_tac "(\<lambda>x\<in>carrier S. ProjInd I A f j (h x)) x = g j x",
        thin_tac "(\<lambda>x\<in>carrier S. ProjInd I A f j (h x)) = g j",
        subgoal_tac "(\<lambda>x\<in>carrier S. ProjInd I A f j (h1 x)) x = g j x",
        thin_tac "(\<lambda>x\<in>carrier S. ProjInd I A f j (h1 x)) = g j", simp+)
 done
 
 lemma  map_family_triangle2:"\<lbrakk>I \<noteq> {}; \<forall>j\<in>I. aGroup (A j); aGroup S;
        \<forall>j\<in>I. g j \<in> aHom S (A j); ff \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
         bij_to ff (carrier (a\<Pi>\<^bsub>I\<^esub> A)) B;
         h1 \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) S;
         \<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (g j) h1 = ProjInd I A ff j;
         h2 \<in> aHom S (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff);
         \<forall>j\<in>I. compos S (ProjInd I A ff j) h2 = g j\<rbrakk>
        \<Longrightarrow> \<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (ProjInd I A ff j)
                  (compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) h2 h1) =
                 ProjInd I A ff j"
 apply (rule ballI)
 apply (frule prodag_aGroup[of "I" "A"])
 apply (frule_tac f = ff in aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" _ "B"], assumption+)
 
 apply (frule_tac N = "A j" and h = "ProjInd I A ff j" in aHom_compos_assoc[of "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" "S" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" _ "h1" "h2"], assumption+)
  apply simp apply assumption+ apply (simp add:ProjInd_aHom)
 apply simp
 done
 
 lemma  map_family_triangle3:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); aGroup S; aGroup S1;
        \<forall>j\<in>I. f j \<in> aHom S (A j); \<forall>j\<in>I. g j \<in> aHom S1 (A j);
         h1 \<in> aHom S1 S; h2 \<in> aHom S S1;
         \<forall>j\<in>I. compos S (g j) h2 = f j;
         \<forall>j\<in>I. compos S1 (f j) h1 = g j\<rbrakk>
        \<Longrightarrow> \<forall>j\<in>I. compos S (f j) (compos S h1 h2) = f j"
 apply (rule ballI)
 apply (frule_tac h = "f j" and N = "A j" in aHom_compos_assoc[of "S" "S1"
                               "S" _ "h2" "h1"], assumption+)
 apply simp apply assumption+ apply simp
 apply simp
 done
 
 lemma map_family_triangle4:"\<lbrakk>\<forall>j\<in>I. aGroup (A j); aGroup S;
                 \<forall>j\<in>I. f j \<in> aHom S (A j)\<rbrakk> \<Longrightarrow>
                \<forall>j\<in>I. compos S (f j) (ag_idmap S) = f j"
 apply (rule ballI)
 apply (frule_tac x = j in bspec, assumption,
        thin_tac "\<forall>j\<in>I. aGroup (A j)",
        frule_tac x = j in bspec, assumption,
        thin_tac "\<forall>j\<in>I. f j \<in> aHom S (A j)")
 apply (simp add:compos_aI_r)
 done
 
 lemma  prod_triangle:"\<lbrakk>I \<noteq> {}; \<forall>j\<in>I. aGroup (A j); aGroup S;
        \<forall>j\<in>I. g j \<in> aHom S (A j); ff \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> B;
         bij_to ff (carrier (a\<Pi>\<^bsub>I\<^esub> A)) B;
         h1 \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) S;
         \<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (g j) h1 = ProjInd I A ff j;
         h2 \<in> aHom S (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff);
         \<forall>j\<in>I. compos S (ProjInd I A ff j) h2 = g j\<rbrakk>
        \<Longrightarrow> (compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) h2 h1) = ag_idmap (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff)"
 apply (frule map_family_triangle2[of "I" "A" "S" "g" "ff" "B" "h1" "h2"], assumption+)
 apply (frule prodag_aGroup[of "I" "A"],
        frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" "ff" "B"], assumption+)
 apply (frule aHom_compos[of "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" "S" "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" "h1"
                             "h2"], assumption+)
 apply (rule ProjInd_mem_eq1[of "I" "A" "ff" "B" "S"
                             "compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) h2 h1"], assumption+)
 done
 
 lemma characterization_prodag:"\<lbrakk>I \<noteq> {}; \<forall>j\<in>(I::'i set). aGroup ((A j)::
     ('a, 'm) aGroup_scheme); aGroup (S::'d aGroup);
     \<forall>j\<in>I. ((g j) \<in> aHom S (A j)); \<exists>ff. ff \<in> carrier (a\<Pi>\<^bsub>I\<^esub> A) \<rightarrow> (B::'d set) \<and>
           bij_to ff (carrier (a\<Pi>\<^bsub>I\<^esub> A)) B;
     \<forall>(S':: 'd aGroup). aGroup S' \<longrightarrow>
         (\<forall>g'. (\<forall>j\<in>I. (g' j) \<in> aHom S' (A j) \<longrightarrow>
          (\<exists>! f. f \<in> aHom S' S \<and> (\<forall>j\<in>I. compos S' (g j) f =  (g' j)))))\<rbrakk> \<Longrightarrow>
      \<exists>h. bijec\<^bsub>(prodag I A),S\<^esub> h"
 apply (frule prodag_aGroup[of "I" "A"])
 apply (erule exE)
 apply (frule_tac f = ff in aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" _ "B"], erule conjE,
        assumption, simp, erule conjE)
 apply (frule aGroup.Ag_ind_aGroup[of "a\<Pi>\<^bsub>I\<^esub> A" _ "B"], assumption+,
        frule_tac a = S in forall_spec, assumption+)
 apply (rotate_tac -1,
        frule_tac x = g in spec,
        thin_tac "\<forall>g'. \<forall>j\<in>I. g' j \<in> aHom S (A j) \<longrightarrow>
               (\<exists>!f. f \<in> aHom S S \<and> (\<forall>j\<in>I. compos S (g j) f = g' j))")
 apply (frule_tac a = "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" in forall_spec, assumption+,
        thin_tac "\<forall>S'. aGroup S' \<longrightarrow> (\<forall>g'. \<forall>j\<in>I. g' j \<in> aHom S' (A j) \<longrightarrow>
                 (\<exists>!f. f \<in> aHom S' S \<and> (\<forall>j\<in>I. compos S' (g j) f = g' j)))")
 apply (frule_tac x = "ProjInd I A ff" in spec,
        thin_tac "\<forall>g'. \<forall>j\<in>I. g' j \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (A j) \<longrightarrow>
                      (\<exists>!f. f \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) S \<and>
                           (\<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (g j) f =
                                  g' j))")
 apply (frule_tac f = ff in ProjInd_aHom1[of "I" "A" _ "B"], assumption+)
 apply (simp add:nonempty_ex[of "I"],
        rotate_tac -2,
        frule ex1_implies_ex,
        thin_tac "\<exists>!f. f \<in> aHom (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) S \<and>
          (\<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (g j) f = ProjInd I A ff j)",
        rotate_tac -1, erule exE, erule conjE)
 apply (rename_tac ff h1,
        frule_tac f = ff in map_family_triangle1[of "I" "A" _  "B" "S" "g"],
            assumption+,
        rotate_tac -1,
        frule ex1_implies_ex,
        thin_tac "\<exists>!h. h \<in> aHom S (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) \<and>
              (\<forall>j\<in>I. compos S (ProjInd I A ff j) h = g j)",
        rotate_tac -1,
        erule exE, erule conjE)
 apply (rename_tac ff h1 h2)
 apply (frule_tac ff = ff and ?h1.0 = h1 and ?h2.0 = h2 in prod_triangle[of "I"
         "A" "S" "g" _ "B"], assumption+,
        frule_tac ?S1.0 = "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" in map_family_triangle3[of "I"
                 "A" "S" _ "g"],
         assumption+,
        frule_tac f = h2 and g = h1 and M =  "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" in
                 aHom_compos[of "S" _ "S" ], assumption+)
 apply (erule ex1E)
  apply (rotate_tac -1,
         frule_tac x = "compos S h1 h2" in spec,
         frule map_family_triangle4[of "I" "A" "S" "g"], assumption+,
         frule aGroup.aI_aHom[of "S"])
  apply (frule_tac x = "aI\<^bsub>S\<^esub>" in spec,
    thin_tac "\<forall>y. y \<in> aHom S S \<and> (\<forall>j\<in>I. compos S (g j) y = g j) \<longrightarrow> y = f",
    simp,
    thin_tac "\<forall>j\<in>I. compos S (ProjInd I A ff j) h2 = g j",
    thin_tac "\<forall>j\<in>I. compos S (g j) f = g j",
    thin_tac "\<forall>j\<in>I. compos (Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff) (g j) h1 = ProjInd I A ff j")
  apply (rotate_tac -1, frule sym, thin_tac "aI\<^bsub>S\<^esub> = f", simp,
         frule_tac A = "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" and f = h1 and g = h2 in
          compos_aI_inj[of _ "S"], assumption+,
         frule_tac B = "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" and f = h2 and g = h1 in
          compos_aI_surj[of "S"], assumption+)
  apply (frule_tac f = ff in Ag_ind_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" _ "B"], assumption+,
         frule_tac F = "Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff" and f = "Agii (a\<Pi>\<^bsub>I\<^esub> A) ff" and g = h1
            in compos_bijec[of "a\<Pi>\<^bsub>I\<^esub> A" _ "S"], assumption+)
 apply (subst bijec_def, simp)
  apply (thin_tac "bijec\<^bsub>(a\<Pi>\<^bsub>I\<^esub> A),Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff\<^esub> Agii (a\<Pi>\<^bsub>I\<^esub> A) ff",
         thin_tac "injec\<^bsub>Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff,S\<^esub> h1",
         thin_tac "surjec\<^bsub>Ag_ind (a\<Pi>\<^bsub>I\<^esub> A) ff,S\<^esub> h1")
 apply (rule exI, simp)
 done
 
 (***  Note.
                                      f
                                   S' \<rightarrow> S
                                     \   |
                                  g' j\  | g j
                                       \ |
                                         A j
 
        ***)
 
 
 
 chapter "Ring theory"
 
 section "Definition of a ring and an ideal"
 
 record 'a Ring = "'a aGroup" +
   tp ::  "['a, 'a ] \<Rightarrow> 'a" (infixl "\<cdot>\<^sub>r\<index>" 70)
   un :: "'a"   ("1\<^sub>r\<index>")
 
 locale Ring =
  fixes R (structure)
 
  assumes
          pop_closed: "pop R \<in> carrier R \<rightarrow> carrier R \<rightarrow> carrier R"
  and     pop_aassoc : "\<lbrakk>a \<in> carrier R; b \<in> carrier R; c \<in> carrier R\<rbrakk> \<Longrightarrow>
          (a \<plusminus> b) \<plusminus> c = a \<plusminus> (b \<plusminus> c)"
  and     pop_commute:"\<lbrakk>a \<in> carrier R; b \<in> carrier R\<rbrakk> \<Longrightarrow> a \<plusminus> b = b \<plusminus> a"
  and     mop_closed:"mop R \<in> carrier R \<rightarrow> carrier R"
  and     l_m :"a \<in> carrier R \<Longrightarrow>  (-\<^sub>a a) \<plusminus> a = \<zero>"
  and     ex_zero: "\<zero> \<in> carrier R"
  and     l_zero:"a \<in> carrier R \<Longrightarrow> \<zero> \<plusminus> a = a"
  and     tp_closed: "tp R \<in> carrier R \<rightarrow> carrier R \<rightarrow> carrier R"
  and     tp_assoc : "\<lbrakk>a \<in> carrier R; b \<in> carrier R; c \<in> carrier R\<rbrakk> \<Longrightarrow>
                   (a \<cdot>\<^sub>r b) \<cdot>\<^sub>r c = a \<cdot>\<^sub>r (b \<cdot>\<^sub>r c)"
  and     tp_commute: "\<lbrakk>a \<in> carrier R; b \<in> carrier R\<rbrakk> \<Longrightarrow> a \<cdot>\<^sub>r b = b  \<cdot>\<^sub>r a"
  and     un_closed: "(1\<^sub>r) \<in> carrier R"
  and     rg_distrib: "\<lbrakk>a \<in> carrier R; b \<in> carrier R; c \<in> carrier R\<rbrakk> \<Longrightarrow>
                      a \<cdot>\<^sub>r (b \<plusminus> c) = a \<cdot>\<^sub>r b  \<plusminus>  a \<cdot>\<^sub>r c"
  and     rg_l_unit: "a \<in> carrier R \<Longrightarrow> (1\<^sub>r) \<cdot>\<^sub>r a = a"
 
 definition
   zeroring :: "('a, 'more) Ring_scheme \<Rightarrow> bool" where
   "zeroring R \<longleftrightarrow> Ring R \<and> carrier R = {\<zero>\<^bsub>R\<^esub>}"
 
 primrec nscal ::  "('a, 'more) Ring_scheme  => 'a => nat  => 'a"
 where
   nscal_0:  "nscal R x 0 = \<zero>\<^bsub>R\<^esub>"
 | nscal_suc:  "nscal R x (Suc n) = (nscal R x n) \<plusminus>\<^bsub>R\<^esub> x"
 
 primrec npow ::  "('a, 'more) Ring_scheme  => 'a => nat  => 'a"
 where
   npow_0: "npow R x 0 = 1\<^sub>r\<^bsub>R\<^esub>"
 | npow_suc: "npow R x (Suc n) = (npow R x n) \<cdot>\<^sub>r\<^bsub>R\<^esub> x"
 
 primrec nprod  :: "('a, 'more) Ring_scheme => (nat => 'a) => nat => 'a"
 where
   nprod_0: "nprod R f 0 = f 0"
 | nprod_suc: "nprod R f (Suc n) = (nprod R f n) \<cdot>\<^sub>r\<^bsub>R\<^esub> (f (Suc n))"
 
 primrec nsum :: "('a, 'more) aGroup_scheme => (nat => 'a) => nat => 'a"
 where
   nsum_0: "nsum R f 0 = f 0"
 | nsum_suc: "nsum R f (Suc n) = (nsum R f n) \<plusminus>\<^bsub>R\<^esub> (f (Suc n))"
 
 abbreviation
   NSCAL :: "[nat, ('a, 'more) Ring_scheme, 'a] \<Rightarrow> 'a"
     ("(3 _ \<times>\<^bsub>_\<^esub> _)" [75,75,76]75) where
   "n \<times>\<^bsub>R\<^esub> x == nscal R x n"
 
 abbreviation
   NPOW :: "['a, ('a, 'more) Ring_scheme, nat] \<Rightarrow>  'a"
     ("(3_^\<^bsup>_ _\<^esup>)" [77,77,78]77) where
   "a^\<^bsup>R n\<^esup> == npow R a n"
 
 abbreviation
   SUM :: "('a, 'more) aGroup_scheme => (nat => 'a) => nat => 'a"
     ("(3\<Sigma>\<^sub>e _ _ _)" [85,85,86]85) where
   "\<Sigma>\<^sub>e G f n == nsum G f n"
 
 abbreviation
   NPROD :: "[('a, 'm) Ring_scheme, nat, nat \<Rightarrow> 'a] \<Rightarrow> 'a"
     ("(3e\<Pi>\<^bsub>_,_\<^esub> _)" [98,98,99]98) where
   "e\<Pi>\<^bsub>R,n\<^esub> f == nprod R f n"
 
 definition
   fSum :: "[_, (nat => 'a), nat, nat] \<Rightarrow> 'a" where
   "fSum A f n m = (if n \<le> m then nsum A (cmp f (slide n))(m - n)
                        else \<zero>\<^bsub>A\<^esub>)"
 
 abbreviation
   FSUM :: "[('a, 'more) aGroup_scheme, (nat \<Rightarrow> 'a), nat, nat] \<Rightarrow> 'a"
     ("(4\<Sigma>\<^sub>f _ _ _ _)" [85,85,85,86]85) where
   "\<Sigma>\<^sub>f G f n m == fSum G f n m"
 
 lemma (in aGroup) nsum_zeroGTr:"(\<forall>j \<le> n. f j = \<zero>) \<longrightarrow> nsum A f n = \<zero>"
 apply (induct_tac n)
  apply (rule impI, simp)
 
 apply (rule impI)
 apply (cut_tac n = n in Nsetn_sub_mem1, simp)
 apply (cut_tac ex_zero)
 apply (simp add:l_zero[of \<zero>])
 done
 
 lemma (in aGroup) nsum_zeroA:"\<forall>j \<le> n. f j = \<zero> \<Longrightarrow>   nsum A f n = \<zero>"
 apply (simp add:nsum_zeroGTr)
 done
 
 definition
   sr :: "[_ , 'a set] \<Rightarrow> bool" where
   "sr R S == S \<subseteq> carrier R \<and> 1\<^sub>r\<^bsub>R\<^esub> \<in> S \<and> (\<forall>x\<in>S. \<forall>y \<in> S. x  \<plusminus>\<^bsub>R\<^esub> (-\<^sub>a\<^bsub>R\<^esub> y) \<in> S \<and>
                x \<cdot>\<^sub>r\<^bsub>R\<^esub> y \<in> S)"
 
 definition
   Sr :: "[_ , 'a set] \<Rightarrow> _" where
   "Sr R S = R \<lparr>carrier := S, pop := \<lambda>x\<in>S. \<lambda>y\<in>S. x \<plusminus>\<^bsub>R\<^esub> y, mop := \<lambda>x\<in>S. (-\<^sub>a\<^bsub>R\<^esub> x),
     zero := \<zero>\<^bsub>R\<^esub>, tp := \<lambda>x\<in>S. \<lambda>y\<in>S. x \<cdot>\<^sub>r\<^bsub>R\<^esub> y, un := 1\<^sub>r\<^bsub>R\<^esub> \<rparr>"
 
 (** sr is a subring without ring structure, Sr is a subring with Ring structure
      **)
 
 
 lemma (in Ring) Ring: "Ring R" ..
 
 lemma (in Ring) ring_is_ag:"aGroup R"
 apply (rule aGroup.intro,
        rule pop_closed,
        rule pop_aassoc, assumption+,
        rule pop_commute, assumption+,
        rule mop_closed,
        rule l_m, assumption,
        rule ex_zero,
        rule l_zero, assumption)
 done
 
 lemma (in Ring) ring_zero:"\<zero> \<in> carrier R"
 by (simp add: ex_zero)
 
 lemma (in Ring) ring_one:"1\<^sub>r \<in> carrier R"
 by (simp add:un_closed)
 
 lemma (in Ring) ring_tOp_closed:"\<lbrakk> x \<in> carrier R; y \<in> carrier R\<rbrakk> \<Longrightarrow>
                      x \<cdot>\<^sub>r y \<in> carrier R"
 apply (cut_tac tp_closed)
  apply (frule funcset_mem[of "(\<cdot>\<^sub>r)" "carrier R" "carrier R \<rightarrow> carrier R"
             "x"], assumption+,
         thin_tac "(\<cdot>\<^sub>r) \<in> carrier R \<rightarrow> carrier R \<rightarrow> carrier R")
  apply (rule funcset_mem[of "(\<cdot>\<^sub>r) x" "carrier R" "carrier R" "y"],
               assumption+)
 done
 
 lemma (in Ring) ring_tOp_commute:"\<lbrakk>x \<in> carrier R; y \<in> carrier R\<rbrakk> \<Longrightarrow>
                 x \<cdot>\<^sub>r y = y \<cdot>\<^sub>r x"
 by (simp add:tp_commute)
 
 lemma (in Ring) ring_distrib1:"\<lbrakk>x \<in> carrier R; y \<in> carrier R; z \<in> carrier R \<rbrakk>
                  \<Longrightarrow> x \<cdot>\<^sub>r (y \<plusminus> z) = x \<cdot>\<^sub>r y \<plusminus> x \<cdot>\<^sub>r z"
 by (simp add:rg_distrib)
 
 lemma (in Ring) ring_distrib2:"\<lbrakk>x \<in> carrier R; y \<in> carrier R; z \<in> carrier R \<rbrakk>
                 \<Longrightarrow> (y \<plusminus> z) \<cdot>\<^sub>r x = y \<cdot>\<^sub>r x \<plusminus>  z \<cdot>\<^sub>r x"
 apply (subst tp_commute[of "y \<plusminus> z" "x"])
  apply (cut_tac ring_is_ag, simp add:aGroup.ag_pOp_closed)
  apply assumption
 apply (subst ring_distrib1, assumption+)
  apply (simp add:tp_commute)
 done
 
 lemma (in Ring) ring_distrib3:"\<lbrakk>a \<in> carrier R; b \<in> carrier R; x \<in> carrier R;
       y \<in> carrier R \<rbrakk> \<Longrightarrow> (a \<plusminus> b) \<cdot>\<^sub>r (x \<plusminus> y) =
                                           a \<cdot>\<^sub>r x \<plusminus> a \<cdot>\<^sub>r y \<plusminus> b \<cdot>\<^sub>r x \<plusminus> b \<cdot>\<^sub>r y"
 apply (subst ring_distrib2)+
  apply (cut_tac ring_is_ag)
  apply (rule aGroup.ag_pOp_closed, assumption+)
  apply ((subst ring_distrib1)+, assumption+)
  apply (subst ring_distrib1, assumption+)
  apply (rule pop_aassoc [THEN sym, of "a \<cdot>\<^sub>r x \<plusminus> a \<cdot>\<^sub>r y" "b \<cdot>\<^sub>r x" "b \<cdot>\<^sub>r y"])
  apply (cut_tac ring_is_ag, rule aGroup.ag_pOp_closed, assumption)
  apply (simp add:ring_tOp_closed)+
 done
 
 lemma (in Ring) rEQMulR:
   "\<lbrakk>x \<in> carrier R; y \<in> carrier R; z \<in> carrier R; x = y \<rbrakk>
         \<Longrightarrow> x \<cdot>\<^sub>r z = y \<cdot>\<^sub>r z"
 by simp
 
 lemma (in Ring) ring_tOp_assoc:"\<lbrakk>x \<in> carrier R; y \<in> carrier R; z \<in> carrier R \<rbrakk>
  \<Longrightarrow> (x \<cdot>\<^sub>r y) \<cdot>\<^sub>r z = x \<cdot>\<^sub>r (y \<cdot>\<^sub>r z)"
 by (simp add:tp_assoc)
 
 lemma (in Ring) ring_l_one:"x \<in> carrier R \<Longrightarrow> 1\<^sub>r \<cdot>\<^sub>r x = x"
 by (simp add:rg_l_unit)
 
 lemma (in Ring) ring_r_one:"x \<in> carrier R  \<Longrightarrow> x \<cdot>\<^sub>r 1\<^sub>r = x"
  apply (subst ring_tOp_commute, assumption+)
  apply (simp add:un_closed)
  apply (simp add:ring_l_one)
 done
 
 lemma (in Ring) ring_times_0_x:"x \<in> carrier R \<Longrightarrow> \<zero> \<cdot>\<^sub>r x = \<zero>"
 apply (cut_tac ring_is_ag)
 apply (cut_tac ring_zero)
 apply (frule ring_distrib2 [of "x" "\<zero>" "\<zero>"], assumption+)
 apply (simp add:aGroup.ag_l_zero [of "R" "\<zero>"])
 apply (frule ring_tOp_closed [of "\<zero>" "x"], assumption+)
 apply (frule sym, thin_tac "\<zero> \<cdot>\<^sub>r x = \<zero> \<cdot>\<^sub>r x \<plusminus> \<zero> \<cdot>\<^sub>r x")
 apply (frule aGroup.ag_eq_sol2 [of "R" "\<zero> \<cdot>\<^sub>r x" "\<zero> \<cdot>\<^sub>r x" "\<zero> \<cdot>\<^sub>r x"],
         assumption+)
 apply (thin_tac "\<zero> \<cdot>\<^sub>r x \<plusminus> \<zero> \<cdot>\<^sub>r x = \<zero> \<cdot>\<^sub>r x")
 apply (simp add:aGroup.ag_r_inv1)
 done
 
 lemma (in Ring) ring_times_x_0:"x \<in> carrier R \<Longrightarrow>  x \<cdot>\<^sub>r \<zero> = \<zero>"
 apply (cut_tac ring_zero)
 apply (subst ring_tOp_commute, assumption+, simp add:ring_zero)
 apply (simp add:ring_times_0_x)
 done
 
 lemma (in Ring) rMulZeroDiv:
      "\<lbrakk> x \<in> carrier R; y \<in> carrier R; x = \<zero> \<or> y = \<zero> \<rbrakk> \<Longrightarrow> x  \<cdot>\<^sub>r  y = \<zero>"
 apply (erule disjE, simp)
 apply (rule ring_times_0_x, assumption+)
 apply (simp, rule ring_times_x_0, assumption+)
 done
 
 lemma (in Ring) ring_inv1:"\<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow>
       -\<^sub>a (a \<cdot>\<^sub>r b) = (-\<^sub>a a) \<cdot>\<^sub>r b \<and> -\<^sub>a (a \<cdot>\<^sub>r b) = a \<cdot>\<^sub>r (-\<^sub>a b)"
 apply (cut_tac ring_is_ag)
 apply (rule conjI)
 apply (frule ring_distrib2 [THEN sym, of "b" "a" "-\<^sub>a a"], assumption+)
  apply (frule aGroup.ag_mOp_closed [of "R" "a"], assumption+)
  apply (simp add:aGroup.ag_r_inv1 [of "R" "a"])
  apply (simp add:ring_times_0_x)
  apply (frule aGroup.ag_mOp_closed [of "R" "a"], assumption+)
  apply (frule ring_tOp_closed [of "a" "b"], assumption+)
  apply (frule ring_tOp_closed [of "-\<^sub>a a" "b"], assumption+)
  apply (frule aGroup.ag_eq_sol1 [of "R" "a \<cdot>\<^sub>r b" "(-\<^sub>a a) \<cdot>\<^sub>r b" "\<zero>"],
            assumption+)
  apply (rule ring_zero, assumption+)
  apply (thin_tac "a \<cdot>\<^sub>r b \<plusminus> (-\<^sub>a a) \<cdot>\<^sub>r b = \<zero>")
  apply (frule sym) apply (thin_tac "(-\<^sub>a a) \<cdot>\<^sub>r b = -\<^sub>a (a \<cdot>\<^sub>r b) \<plusminus> \<zero>")
  apply (frule aGroup.ag_mOp_closed [of "R" " a \<cdot>\<^sub>r b"], assumption+)
  apply (simp add:aGroup.ag_r_zero)
 apply (frule ring_distrib1 [THEN sym, of "a" "b" "-\<^sub>a b"], assumption+)
  apply (simp add:aGroup.ag_mOp_closed)
   apply (simp add:aGroup.ag_r_inv1 [of "R" "b"])
   apply (simp add:ring_times_x_0)
  apply (frule aGroup.ag_mOp_closed [of "R" "b"], assumption+)
  apply (frule ring_tOp_closed [of "a" "b"], assumption+)
  apply (frule ring_tOp_closed [of "a" "-\<^sub>a b"], assumption+)
  apply (frule aGroup.ag_eq_sol1 [THEN sym, of "R" "a \<cdot>\<^sub>r b" "a \<cdot>\<^sub>r (-\<^sub>a b)" "\<zero>"],
                                                       assumption+)
  apply (simp add:ring_zero) apply assumption
  apply (frule aGroup.ag_mOp_closed [of "R" " a \<cdot>\<^sub>r b"], assumption+)
   apply (simp add:aGroup.ag_r_zero)
 done
 
 lemma (in Ring) ring_inv1_1:"\<lbrakk>a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow>
       -\<^sub>a (a \<cdot>\<^sub>r b) = (-\<^sub>a a) \<cdot>\<^sub>r b"
 apply (simp add:ring_inv1)
 done
 
 lemma (in Ring) ring_inv1_2:"\<lbrakk> a \<in> carrier R; b \<in> carrier R \<rbrakk> \<Longrightarrow>
                                 -\<^sub>a (a \<cdot>\<^sub>r b) = a \<cdot>\<^sub>r (-\<^sub>a b)"
 apply (frule ring_inv1 [of "a" "b"], assumption+)
 apply (frule conjunct2)
 apply (thin_tac "-\<^sub>a a \<cdot>\<^sub>r b = (-\<^sub>a a) \<cdot>\<^sub>r b \<and> -\<^sub>a (a \<cdot>\<^sub>r b) = a \<cdot>\<^sub>r (-\<^sub>a b)")
 apply simp
 done
 
 lemma (in Ring) ring_times_minusl:"a \<in> carrier R \<Longrightarrow>  -\<^sub>a a = (-\<^sub>a 1\<^sub>r) \<cdot>\<^sub>r a"
 apply (cut_tac ring_one)
 apply (frule ring_inv1_1[of "1\<^sub>r" "a"], assumption+)
 apply (simp add:ring_l_one)
 done
 
 lemma (in Ring) ring_times_minusr:"a \<in> carrier R \<Longrightarrow>  -\<^sub>a a = a \<cdot>\<^sub>r (-\<^sub>a 1\<^sub>r)"
 apply (cut_tac ring_one)
 apply (frule ring_inv1_2[of "a" "1\<^sub>r"], assumption+)
 apply (simp add:ring_r_one)
 done
 
 lemma (in Ring) ring_inv1_3:"\<lbrakk>a \<in> carrier R; b \<in> carrier R\<rbrakk> \<Longrightarrow>
                            a \<cdot>\<^sub>r b = (-\<^sub>a a) \<cdot>\<^sub>r (-\<^sub>a b)"
 apply (cut_tac ring_is_ag)
 apply (subst  aGroup.ag_inv_inv[THEN sym], assumption+)
 apply (frule aGroup.ag_mOp_closed[of "R" "a"], assumption+)
 apply (subst ring_inv1_1[THEN sym, of "-\<^sub>a a" "b"], assumption+)
 apply (subst ring_inv1_2[of "-\<^sub>a a" "b"], assumption+, simp)
 done
 
 lemma (in Ring) ring_distrib4:"\<lbrakk>a \<in> carrier R; b \<in> carrier R;
                                 x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow>
       a \<cdot>\<^sub>r b \<plusminus> (-\<^sub>a x \<cdot>\<^sub>r y) = a \<cdot>\<^sub>r (b \<plusminus> (-\<^sub>a y)) \<plusminus> (a \<plusminus> (-\<^sub>a x)) \<cdot>\<^sub>r y"
 apply (cut_tac ring_is_ag)
 apply (subst ring_distrib1, assumption+)
 apply (rule aGroup.ag_mOp_closed, assumption+)
 apply (subst ring_distrib2, assumption+)
 apply (rule aGroup.ag_mOp_closed, assumption+)
 apply (subst aGroup.pOp_assocTr43, assumption+)
 apply (rule ring_tOp_closed, assumption+)+
  apply (rule aGroup.ag_mOp_closed, assumption+)
  apply (rule ring_tOp_closed, assumption+)
  apply (rule ring_tOp_closed)
  apply (simp add:aGroup.ag_mOp_closed)+
 apply (subst ring_distrib1 [THEN sym, of "a" _], assumption+)
  apply (rule aGroup.ag_mOp_closed, assumption+)
 apply (simp add:aGroup.ag_l_inv1)
 apply (simp add:ring_times_x_0)
 apply (subst aGroup.ag_r_zero, assumption+)
 apply (simp add:ring_tOp_closed)
 apply (simp add: ring_inv1_1)
 done
 
 lemma (in Ring) rMulLC:
      "\<lbrakk>x \<in> carrier R; y \<in> carrier R; z \<in> carrier R\<rbrakk>
         \<Longrightarrow> x \<cdot>\<^sub>r (y \<cdot>\<^sub>r z) = y \<cdot>\<^sub>r (x \<cdot>\<^sub>r z)"
   apply (subst ring_tOp_assoc [THEN sym], assumption+)
   apply (subst ring_tOp_commute [of "x" "y"], assumption+)
   apply (subst ring_tOp_assoc, assumption+)
   apply simp
   done
 
 lemma (in Ring) Zero_ring:"1\<^sub>r = \<zero> \<Longrightarrow> zeroring R"
 apply (simp add:zeroring_def)
 apply (rule conjI)
  apply (rule Ring_axioms)
 apply (rule equalityI)
  apply (rule subsetI)
  apply (frule_tac x = x in ring_r_one, simp add:ring_times_x_0)
 
  apply (simp add:ring_zero)
 done
 
 lemma (in Ring) Zero_ring1:"\<not> (zeroring R) \<Longrightarrow>  1\<^sub>r \<noteq> \<zero>"
 apply (rule contrapos_pp, simp+,
        cut_tac Zero_ring, simp+)
 done
 
 lemma (in Ring) Sr_one:"sr R S \<Longrightarrow> 1\<^sub>r \<in> S"
 apply (simp add:sr_def)
 done
 
 lemma (in Ring) Sr_zero:"sr R S \<Longrightarrow> \<zero> \<in> S"
 apply (cut_tac ring_is_ag, frule Sr_one[of "S"])
 apply (simp add:sr_def) apply (erule conjE)+
 apply (frule_tac x = "1\<^sub>r" in bspec, assumption,
        thin_tac "\<forall>x\<in>S. \<forall>y\<in>S. x \<plusminus> -\<^sub>a y \<in> S \<and> x \<cdot>\<^sub>r y \<in> S",
        frule_tac x = "1\<^sub>r" in bspec, assumption,
        thin_tac "\<forall>y\<in>S. 1\<^sub>r \<plusminus> -\<^sub>a y \<in> S \<and> 1\<^sub>r \<cdot>\<^sub>r y \<in> S",
        erule conjE)
 apply (cut_tac ring_one,
        simp add:aGroup.ag_r_inv1[of "R" "1\<^sub>r"])
 done
 
 lemma (in Ring) Sr_mOp_closed:"\<lbrakk>sr R S; x \<in> S\<rbrakk> \<Longrightarrow> -\<^sub>a x \<in> S"
 apply (frule Sr_zero[of "S"])
 apply (simp add:sr_def, (erule conjE)+)
 apply (cut_tac ring_is_ag)
  apply (frule_tac x = "\<zero>" in bspec, assumption,
         thin_tac "\<forall>x\<in>S. \<forall>y\<in>S. x \<plusminus> -\<^sub>a y \<in> S \<and> x \<cdot>\<^sub>r y \<in> S",
         frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>y\<in>S. \<zero> \<plusminus> -\<^sub>a y \<in> S \<and> \<zero> \<cdot>\<^sub>r y \<in> S", erule conjE)
  apply (frule subsetD[of "S" "carrier R" "\<zero>"], assumption+,
         frule subsetD[of "S" "carrier R" "x"], assumption+)
  apply (frule aGroup.ag_mOp_closed [of "R" "x"], assumption)
  apply (simp add:aGroup.ag_l_zero)
 done
 
 lemma (in Ring) Sr_pOp_closed:"\<lbrakk>sr R S; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> x \<plusminus> y \<in> S"
 apply (frule Sr_mOp_closed[of "S" "y"], assumption+)
 apply (unfold sr_def, (erule conjE)+)
  apply (frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>x\<in>S. \<forall>y\<in>S. x \<plusminus> -\<^sub>a y \<in> S \<and> x \<cdot>\<^sub>r y \<in> S",
         frule_tac x = "-\<^sub>a y" in bspec, assumption,
         thin_tac "\<forall>y\<in>S. x \<plusminus> -\<^sub>a y \<in> S \<and> x \<cdot>\<^sub>r y \<in> S", erule conjE)
 
  apply (cut_tac ring_is_ag )
  apply (frule subsetD[of "S" "carrier R" "y"], assumption+)
  apply (simp add:aGroup.ag_inv_inv)
 done
 
 lemma (in Ring) Sr_tOp_closed:"\<lbrakk>sr R S; x \<in> S; y \<in> S\<rbrakk> \<Longrightarrow> x \<cdot>\<^sub>r y \<in> S"
 by (simp add:sr_def)
 
 lemma (in Ring) Sr_ring:"sr R S \<Longrightarrow> Ring (Sr R S)"
 apply (simp add:Ring_def [of "Sr R S"],
        cut_tac ring_is_ag)
  apply (rule conjI)
  apply (simp add:Sr_def Sr_pOp_closed)
 
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:Sr_def,
         frule_tac x = a and y = b in Sr_pOp_closed, assumption+,
         frule_tac x = b and y = c in Sr_pOp_closed, assumption+,
         simp add:Sr_def sr_def, (erule conjE)+)
  apply (frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
         frule_tac c = b in subsetD[of "S" "carrier R"], assumption+,
         frule_tac c = c in subsetD[of "S" "carrier R"], assumption+)
  apply (simp add:aGroup.ag_pOp_assoc)
 
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:Sr_def sr_def, (erule conjE)+,
         frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
         frule_tac c = b in subsetD[of "S" "carrier R"], assumption+)
  apply (simp add:aGroup.ag_pOp_commute)
 
 apply (rule conjI)
   apply ((subst Sr_def)+, simp)
   apply (simp add:Sr_mOp_closed)
 
 apply (rule conjI)
   apply (rule allI)
   apply ((subst Sr_def)+, simp add:Sr_mOp_closed, rule impI)
   apply (unfold sr_def, frule conjunct1, fold sr_def,
          frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
          simp add:aGroup.ag_l_inv1)
 
 apply (rule conjI)
   apply (simp add:Sr_def Sr_zero)
 
 apply (rule conjI)
   apply (rule allI, simp add:Sr_def Sr_zero)
   apply (rule impI)
   apply (unfold sr_def, frule conjunct1, fold sr_def,
          frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
          simp add:aGroup.ag_l_zero)
 
 apply (rule conjI)
   apply (simp add:Sr_def Sr_tOp_closed)
 
 apply (rule conjI)
   apply (rule allI, rule impI)+
   apply (simp add:Sr_def Sr_tOp_closed)
   apply (unfold sr_def, frule conjunct1, fold sr_def,
          frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
          frule_tac c = b in subsetD[of "S" "carrier R"], assumption+,
          frule_tac c = c in subsetD[of "S" "carrier R"], assumption+)
   apply (simp add:ring_tOp_assoc)
 
 apply (rule conjI)
   apply ((rule allI, rule impI)+, simp add:Sr_def)
   apply (unfold sr_def, frule conjunct1, fold sr_def,
          frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
          frule_tac c = b in subsetD[of "S" "carrier R"], assumption+,
          simp add:ring_tOp_commute)
 
 apply (rule conjI)
   apply (simp add:Sr_def Sr_one)
 
 apply (rule conjI)
   apply (simp add:Sr_def Sr_pOp_closed Sr_tOp_closed)
   apply (rule allI, rule impI)+
   apply (unfold sr_def, frule conjunct1, fold sr_def,
          frule_tac c = a in subsetD[of "S" "carrier R"], assumption+,
          frule_tac c = b in subsetD[of "S" "carrier R"], assumption+,
          frule_tac c = c in subsetD[of "S" "carrier R"], assumption+)
   apply (simp add:ring_distrib1)
 
 apply (simp add:Sr_def Sr_one)
  apply (rule allI, rule impI)
    apply (unfold sr_def, frule conjunct1, fold sr_def,
          frule_tac c = a in subsetD[of "S" "carrier R"], assumption+)
  apply (simp add:ring_l_one)
 done
 
 
 section "Calculation of elements"
  (** The author of this part is L. Chen, revised by H. Murao and Y.
      Santo  **)
 
 subsection "nscale"
 
 lemma (in Ring) ring_tOp_rel:"\<lbrakk>x\<in>carrier R; xa\<in>carrier R; y\<in>carrier R;
 ya \<in> carrier R \<rbrakk> \<Longrightarrow> (x \<cdot>\<^sub>r xa) \<cdot>\<^sub>r (y \<cdot>\<^sub>r ya) = (x \<cdot>\<^sub>r y) \<cdot>\<^sub>r (xa \<cdot>\<^sub>r ya)"
 apply (frule ring_tOp_closed[of "y" "ya"], assumption+,
        simp add:ring_tOp_assoc[of "x" "xa"])
 apply (simp add:ring_tOp_assoc[THEN sym, of "xa" "y" "ya"],
        simp add:ring_tOp_commute[of "xa" "y"],
        simp add:ring_tOp_assoc[of "y" "xa" "ya"])
 apply (frule ring_tOp_closed[of "xa" "ya"], assumption+,
        simp add:ring_tOp_assoc[THEN sym, of "x" "y"])
 done
 
 lemma (in Ring) nsClose:
   "\<And> n. \<lbrakk> x \<in> carrier R \<rbrakk>  \<Longrightarrow> nscal R x n \<in> carrier R"
   apply (induct_tac n)
   apply (simp add:ring_zero)
   apply (cut_tac ring_is_ag, simp add:aGroup.ag_pOp_closed)
 done
 
 lemma (in Ring) nsZero:
              "nscal R \<zero> n = \<zero>"
   apply (cut_tac ring_is_ag)
   apply (induct_tac n)
   apply simp
 
   apply simp
    apply (cut_tac ring_zero, simp add:aGroup.ag_l_zero)
   done
 
 lemma (in Ring) nsZeroI: "\<And> n.  x = \<zero>  \<Longrightarrow> nscal R x n = \<zero>"
   by (simp only:nsZero)
 
 lemma (in Ring) nsEqElm:  "\<lbrakk> x \<in> carrier R; y \<in> carrier R; x = y \<rbrakk>
         \<Longrightarrow> (nscal R x n) = (nscal R y n)"
   by simp
 
 lemma (in Ring) nsDistr:  "x \<in> carrier R
         \<Longrightarrow> (nscal R x n) \<plusminus> (nscal R x m) = nscal R x (n + m)"
 apply (cut_tac ring_is_ag)
   apply (induct_tac m)
   apply simp
   apply (frule nsClose[of "x" "n"])
   apply ( simp add:aGroup.ag_r_zero)
 
   apply simp
   apply (frule_tac x = x and n = n in nsClose,
          frule_tac x = x and n = na in nsClose)
   apply (subst aGroup.ag_pOp_assoc[THEN sym], assumption+, simp)
   done
 
 lemma (in Ring) nsDistrL:  "\<lbrakk>x \<in> carrier R; y \<in> carrier R \<rbrakk>
         \<Longrightarrow> (nscal R x n) \<plusminus> (nscal R y n) = nscal R (x \<plusminus> y) n"
   apply (cut_tac ring_is_ag)
   apply (induct_tac n)
   apply simp
   apply (cut_tac ring_zero,
          simp add:aGroup.ag_l_zero)
 
   apply simp
   apply (frule_tac x = x and n = n in nsClose,
          frule_tac x = y and n = n in nsClose)
   apply (subst aGroup.pOp_assocTr43[of R _ x _ y], assumption+)
   apply (frule_tac x = x and y = "n \<times>\<^bsub>R\<^esub> y" in aGroup.ag_pOp_commute[of "R"],
          assumption+)
    apply simp
    apply (subst aGroup.pOp_assocTr43[THEN sym, of R _ _ x y], assumption+)
    apply simp
 done
 
 lemma (in Ring) nsMulDistrL:"\<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk>
         \<Longrightarrow> x \<cdot>\<^sub>r (nscal R y n) = nscal R (x \<cdot>\<^sub>r y) n"
   apply (induct_tac n)
   apply simp
   apply (simp add:ring_times_x_0)
 
   apply simp apply (subst ring_distrib1, assumption+)
   apply (rule nsClose, assumption+)
   apply simp
 done
 
 lemma (in Ring) nsMulDistrR:"\<lbrakk> x \<in> carrier R; y \<in> carrier R\<rbrakk>
         \<Longrightarrow> (nscal R y n) \<cdot>\<^sub>r x = nscal R (y \<cdot>\<^sub>r x) n"
   apply (frule_tac x = y and n = n in nsClose,
          simp add:ring_tOp_commute[of "n \<times>\<^bsub>R\<^esub> y" "x"],
          simp add:nsMulDistrL,
          simp add:ring_tOp_commute[of "y" "x"])
 done
 
 subsection "npow"
 
 lemma (in Ring) npClose:"x \<in> carrier R \<Longrightarrow> npow R x n \<in> carrier R"
   apply (induct_tac n)
   apply simp apply (simp add:ring_one)
 
   apply simp
   apply (rule ring_tOp_closed, assumption+)
   done
 
 lemma (in Ring) npMulDistr:"\<And> n m. x \<in> carrier R  \<Longrightarrow>
                  (npow R x n) \<cdot>\<^sub>r (npow R x m) = npow R x (n + m)"
   apply (induct_tac m)
   apply simp apply (rule ring_r_one, simp add:npClose)
 
   apply simp
   apply (frule_tac x = x and n = n in npClose,
          frule_tac x = x and n = na in npClose)
   apply (simp add:ring_tOp_assoc[THEN sym])
 done
 
 lemma (in Ring) npMulExp:"\<And>n m. x \<in> carrier R
         \<Longrightarrow>  npow R (npow R x n) m = npow R x (n * m)"
 apply (induct_tac m)
 apply simp
 apply simp
 apply (simp add:npMulDistr)
 apply (simp add:add.commute)
 done
 
 
 lemma (in Ring) npGTPowZero_sub:
   " \<And> n. \<lbrakk> x \<in> carrier R; npow R x m = \<zero> \<rbrakk>
         \<Longrightarrow>(m \<le> n) \<longrightarrow> (npow R x n = \<zero> )"
   apply (rule impI)
   apply (subgoal_tac "npow R x n = (npow R x (n-m)) \<cdot>\<^sub>r (npow R x m)")
   apply simp
   apply (rule ring_times_x_0) apply (simp add:npClose)
   apply (thin_tac "x^\<^bsup>R m\<^esup> = \<zero>")
   apply (subst npMulDistr, assumption)
   apply simp
   done
 
 lemma (in Ring) npGTPowZero:
   "\<And> n. \<lbrakk> x \<in> carrier R; npow R x m = \<zero>; m \<le> n \<rbrakk>
         \<Longrightarrow> npow R x n = \<zero>"
   apply (cut_tac x = x and m = m and n = n in npGTPowZero_sub, assumption+)
   apply simp
   done
 
 
 lemma (in Ring) npOne: " npow R (1\<^sub>r) n = 1\<^sub>r"
   apply (induct_tac n) apply simp
 
   apply simp
     apply (rule ring_r_one, simp add:ring_one)
 done
 
 lemma (in Ring) npZero_sub: "0 < n \<longrightarrow> npow R \<zero> n = \<zero>"
   apply (induct_tac "n")
   apply simp
 
   apply simp
     apply (cut_tac ring_zero,
            frule_tac n = n in npClose[of "\<zero>"])
     apply (simp add:ring_times_x_0)
 done
 
 lemma (in Ring) npZero: "0 < n  \<Longrightarrow> npow R \<zero> n = \<zero>"
   apply (simp add:npZero_sub)
 done
 
 lemma (in Ring) npMulElmL: "\<And> n. \<lbrakk> x \<in> carrier R; 0 \<le> n\<rbrakk>
         \<Longrightarrow> x \<cdot>\<^sub>r (npow R x n) = npow R x (Suc n)"
 apply (simp only:npow_suc,
        frule_tac n = n and x = x in npClose,
        simp add:ring_tOp_commute)
 done
 
 lemma (in Ring) npMulEleL: "\<And> n. x \<in> carrier R
         \<Longrightarrow> (npow R x n) \<cdot>\<^sub>r x =  npow R x (Suc n)"
 by (simp add:npMulElmL[THEN sym])
 
 lemma (in Ring) npMulElmR: "\<And> n. x \<in> carrier R
         \<Longrightarrow> (npow R x n) \<cdot>\<^sub>r x =  npow R x (Suc n)"
   apply ( frule_tac n = n in npClose[of "x"])
    apply (simp only:ring_tOp_commute,
           subst npMulElmL, assumption, simp, simp)
   done
 
 lemma (in Ring) np_1:"a \<in> carrier R \<Longrightarrow> npow R a (Suc 0) = a"  (* Y. Santo*)
 apply simp
  apply (simp add:ring_l_one)
 done
 
 subsection  "nsum and fSum"
 
 lemma (in aGroup) nsum_memTr: "(\<forall>j \<le> n. f j \<in> carrier A) \<longrightarrow>
                                  nsum A f n \<in> carrier A"
   apply (induct_tac "n")
   apply simp
   apply (rule impI)
   apply (cut_tac n = n in Nsetn_sub_mem1, simp)
   apply (frule_tac a = "Suc n" in forall_spec, simp,
          thin_tac "\<forall>j\<le>Suc n. f j \<in> carrier A")
    apply (rule ag_pOp_closed, assumption+)
    done
 
 lemma (in aGroup) nsum_mem:"\<forall>j \<le> n. f j \<in> carrier A \<Longrightarrow>
                                  nsum A f n \<in> carrier A"
 apply (simp add:nsum_memTr)
 done
 
 lemma (in aGroup) nsum_eqTr:"(\<forall>j \<le> n. f j \<in> carrier A \<and>
                                       g j \<in> carrier A \<and>
                                       f j = g j)
                            \<longrightarrow>  nsum A f n = nsum A g n"
 apply (induct_tac n)
  apply simp
 apply (rule impI)
  apply (cut_tac n = n in Nsetn_sub_mem1, simp)
 done
 
 lemma (in aGroup) nsum_eq:"\<lbrakk>\<forall>j \<le> n. f j \<in> carrier A; \<forall>j \<le> n. g j \<in> carrier A;
                            \<forall>j \<le> n. f j = g j\<rbrakk> \<Longrightarrow>  nsum A f n = nsum A g n"
 by (simp add:nsum_eqTr)
 
 lemma (in aGroup) nsum_cmp_assoc:"\<lbrakk>\<forall>j \<le> n. f j \<in> carrier A;
        g \<in> {j. j \<le> n} \<rightarrow> {j. j \<le> n}; h \<in> {j. j \<le> n} \<rightarrow> {j. j \<le> n}\<rbrakk> \<Longrightarrow>
        nsum A (cmp (cmp f h) g) n = nsum A (cmp f (cmp h g)) n"
 apply (rule nsum_eq)
 apply (rule allI, rule impI, simp add:cmp_def)
 apply (frule_tac x = j in funcset_mem[of g "{j. j \<le> n}" "{j. j \<le> n}"], simp,
        frule_tac x = "g j" in funcset_mem[of h "{j. j \<le> n}" "{j. j \<le> n}"],
        assumption, simp)
  apply (rule allI, rule impI, simp add:cmp_def,
        frule_tac x = j in funcset_mem[of g "{j. j \<le> n}" "{j. j \<le> n}"], simp,
        frule_tac x = "g j" in funcset_mem[of h "{j. j \<le> n}" "{j. j \<le> n}"],
        assumption, simp)
  apply (rule allI, simp add:cmp_def)
 done
 
 lemma (in aGroup) fSum_Suc:"\<forall>j \<in> nset n (n + Suc m). f j \<in> carrier A \<Longrightarrow>
               fSum A f n (n + Suc m) = fSum A f n (n + m) \<plusminus> f (n + Suc m)"
 by (simp add:fSum_def, simp add:cmp_def slide_def)
 
 lemma (in aGroup) fSum_eqTr:"(\<forall>j \<in> nset n (n + m). f j \<in> carrier A \<and>
          g j \<in> carrier A \<and>  f j = g j)  \<longrightarrow>
                        fSum A f  n (n + m) = fSum A g n (n + m)"
 apply (induct_tac m)
  apply (simp add:fSum_def,
         simp add:cmp_def slide_def,
         simp add:nset_def)
 
 apply (rule impI)
  apply (subst fSum_Suc,
         rule ballI, simp, simp)
  apply (cut_tac n = n and m = na and f = g in fSum_Suc,
         rule ballI, simp, simp,
         thin_tac "\<Sigma>\<^sub>f A g n (Suc (n + na)) =
                                    \<Sigma>\<^sub>f A g n (n + na) \<plusminus> g (Suc (n + na))")
 
  apply (cut_tac n = n and m = na in nsetnm_sub_mem, simp,
         thin_tac "\<forall>j. j \<in> nset n (n + na) \<longrightarrow> j \<in> nset n (Suc (n + na))")
 apply (frule_tac x = "Suc (n + na)" in bspec,
        simp add:nset_def, simp)
 done
 
 lemma (in aGroup) fSum_eq:"\<lbrakk> \<forall>j \<in> nset n (n + m). f j \<in> carrier A;
       \<forall>j \<in> nset n (n + m). g j \<in> carrier A; (\<forall>j\<in> nset n (n + m). f j = g j)\<rbrakk>
        \<Longrightarrow>
          fSum A f n (n + m) = fSum A g n (n + m)"
 by (simp add:fSum_eqTr)
 
 lemma (in aGroup) fSum_eq1:"\<lbrakk>n \<le> m; \<forall>j\<in>nset n m. f j \<in> carrier A;
        \<forall>j\<in>nset n m. g j \<in> carrier A;  \<forall>j\<in>nset n m. f j = g j\<rbrakk> \<Longrightarrow>
          fSum A f n m = fSum A g n m"
 apply (cut_tac fSum_eq[of n "m - n" f g])
 apply simp+
 done
 
 lemma (in aGroup) fSum_zeroTr:"(\<forall>j \<in> nset n (n + m). f j = \<zero>)  \<longrightarrow>
                        fSum A f  n (n + m) = \<zero>"
 apply (induct_tac m)
  apply (simp add:fSum_def cmp_def slide_def nset_def)
  apply (rule impI)
  apply (subst fSum_Suc)
  apply (rule ballI, simp add:ag_inc_zero)
 apply (frule_tac x = "n + Suc na" in bspec, simp add:nset_def,
        simp)
  apply (simp add:nset_def)
  apply (cut_tac ag_inc_zero, simp add:ag_l_zero)
 done
 
 lemma (in aGroup) fSum_zero:"\<forall>j \<in> nset n (n + m). f j = \<zero>  \<Longrightarrow>
                        fSum A f  n (n + m) = \<zero>"
 by (simp add:fSum_zeroTr)
 
 lemma (in aGroup) fSum_zero1:"\<lbrakk>n < m; \<forall>j \<in> nset (Suc n) m. f j = \<zero>\<rbrakk>  \<Longrightarrow>
                        fSum A f  (Suc n) m = \<zero>"
 apply (cut_tac fSum_zero[of "Suc n" "m - Suc n" f])
  apply simp+
 done
 
 lemma (in Ring) nsumMulEleL: "\<And> n. \<lbrakk> \<forall> i. f i \<in> carrier R; x \<in> carrier R \<rbrakk>
         \<Longrightarrow> x \<cdot>\<^sub>r (nsum R f n) = nsum R (\<lambda> i. x \<cdot>\<^sub>r (f i)) n"
   apply (cut_tac ring_is_ag)
   apply (induct_tac "n")
   apply simp
 
   apply simp
   apply (subst ring_distrib1, assumption)
   apply (rule aGroup.nsum_mem, assumption)
  apply (rule allI, simp+)
 done
 
 lemma (in Ring) nsumMulElmL:
   "\<And> n. \<lbrakk> \<forall> i. f i \<in> carrier R; x \<in> carrier R \<rbrakk>
         \<Longrightarrow> x \<cdot>\<^sub>r (nsum R f n) = nsum R (\<lambda> i. x \<cdot>\<^sub>r (f i)) n"
   apply (cut_tac ring_is_ag)
   apply (induct_tac "n")
   apply simp
 
   apply simp
   apply (subst ring_distrib1, assumption+)
     apply (simp add:aGroup.nsum_mem)+
   done
 
 lemma (in aGroup) nsumTailTr:
          "(\<forall>j\<le>(Suc n). f j \<in> carrier A) \<longrightarrow>
           nsum A f (Suc n) = (nsum A (\<lambda> i. (f (Suc i))) n) \<plusminus> (f 0)"
   apply (induct_tac "n")
   apply simp
   apply (rule impI,
          rule ag_pOp_commute)
   apply (cut_tac Nset_inc_0[of "Suc 0"],
          simp add:Pi_def,
          cut_tac n_in_Nsetn[of "Suc 0"],
          simp add:Pi_def)
 
   apply (rule impI)
    apply (cut_tac n = "Suc n" in Nsetn_sub_mem1, simp)
    apply (frule_tac a = 0 in forall_spec, simp,
           frule_tac a = "Suc (Suc n)" in forall_spec, simp)
     apply (cut_tac n = n in nsum_mem[of  _  "\<lambda>i. f (Suc i)"],
           rule allI, rule impI,
           frule_tac a = "Suc j" in forall_spec, simp, simp,
           thin_tac "\<forall>j\<le>Suc (Suc n). f j \<in> carrier A")
     apply (subst ag_pOp_assoc, assumption+)
        apply (simp add:ag_pOp_commute[of  "f 0"])
     apply (subst ag_pOp_assoc[THEN sym], assumption+)
     apply simp
   done
 
 lemma (in aGroup) nsumTail:
       "\<forall>j \<le> (Suc n). f j \<in> carrier A \<Longrightarrow>
             nsum A f (Suc n) = (nsum A (\<lambda> i. (f (Suc i))) n) \<plusminus> (f 0)"
   by (cut_tac nsumTailTr[of n f], simp)
 
 lemma (in aGroup) nsumElmTail:
   "\<forall>i. f i \<in> carrier A
         \<Longrightarrow> nsum A f (Suc n) = (nsum A (\<lambda> i. (f (Suc i))) n) \<plusminus> (f 0)"
   apply (cut_tac n = n and f = f in nsumTail,
          rule allI, simp, simp)
 done
 
 lemma (in aGroup) nsum_addTr:
   "(\<forall>j \<le> n. f j \<in> carrier A \<and> g j \<in> carrier A) \<longrightarrow>
    nsum A (\<lambda> i. (f i) \<plusminus> (g i)) n = (nsum A f n) \<plusminus> (nsum A g n)"
   apply (induct_tac "n")
   apply simp
 
   apply (simp, rule impI)
   apply (cut_tac n = n in Nsetn_sub_mem1, simp)
  apply (thin_tac "\<Sigma>\<^sub>e A (\<lambda>i. f i \<plusminus> g i) n = \<Sigma>\<^sub>e A f n \<plusminus> \<Sigma>\<^sub>e A g n")
   apply (rule aGroup.ag_add4_rel, rule aGroup_axioms)
   apply (rule aGroup.nsum_mem, rule aGroup_axioms, rule allI, simp)
   apply (rule aGroup.nsum_mem, rule aGroup_axioms, rule allI, simp)
   apply simp+
   done
 
 lemma (in aGroup) nsum_add:
   "\<lbrakk> \<forall>j \<le> n. f j \<in> carrier A; \<forall>j \<le> n. g j \<in> carrier A\<rbrakk>  \<Longrightarrow>
    nsum A (\<lambda> i. (f i) \<plusminus> (g i)) n = (nsum A f n) \<plusminus> (nsum A g n)"
 by (cut_tac nsum_addTr[of n f g], simp)
 
 lemma (in aGroup) nsumElmAdd:
   "\<lbrakk> \<forall> i. f i \<in> carrier A; \<forall> i. g i \<in> carrier A\<rbrakk>
         \<Longrightarrow> nsum A (\<lambda> i. (f i) \<plusminus> (g i)) n = (nsum A f n) \<plusminus> (nsum A g n)"
  apply (cut_tac nsum_add[of n f g])
  apply simp
  apply (rule allI, simp)+
  done
 
 lemma (in aGroup) nsum_add_nmTr:
   "(\<forall>j \<le> n. f j \<in> carrier A) \<and> (\<forall>j \<le> m. g j \<in> carrier A) \<longrightarrow>
    nsum A (jointfun n f m g) (Suc (n + m)) = (nsum A f n) \<plusminus> (nsum A g m)"
 apply (induct_tac m)
  apply (simp add:jointfun_def sliden_def)
  apply (rule impI)
  apply (rule ag_pOp_add_r)
  apply (rule nsum_mem, rule allI, erule conjE, rule impI, simp)
  apply (erule conjE, simp add:nsum_mem, simp)
  apply (rule nsum_eq[of n], simp+)
 apply (simp add:jointfun_def)
  apply (rule impI, simp)
  apply (erule conjE, simp add:sliden_def)
  apply (thin_tac "\<Sigma>\<^sub>e A (\<lambda>i. if i \<le> n then f i else g (sliden (Suc n) i))
         (n + na) \<plusminus> g na = \<Sigma>\<^sub>e A f n \<plusminus> \<Sigma>\<^sub>e A g na")
  apply (subst ag_pOp_assoc)
  apply (simp add:nsum_mem)
  apply (simp add:nsum_mem, simp)
  apply simp
 done
 
 lemma (in aGroup) nsum_add_nm:
 "\<lbrakk>\<forall>j \<le> n. f j \<in> carrier A; \<forall>j \<le> m. g j \<in> carrier A\<rbrakk> \<Longrightarrow>
    nsum A (jointfun n f m g) (Suc (n + m)) = (nsum A f n) \<plusminus> (nsum A g m)"
 apply (cut_tac nsum_add_nmTr[of n f m g])
  apply simp
 done
 
 lemma (in Ring) npeSum2_sub_muly:
   "\<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow>
         y \<cdot>\<^sub>r(nsum R (\<lambda>i. nscal R ((npow R x (n-i)) \<cdot>\<^sub>r (npow R y i))
                                 (n choose i)) n)
         = nsum R (\<lambda>i. nscal R ((npow R x (n-i)) \<cdot>\<^sub>r (npow R y (i+1)))
                                 (n choose i)) n"
   apply (cut_tac ring_is_ag)
   apply (subst nsumMulElmL)
     apply (rule allI)
       apply (simp only:nsClose add:ring_tOp_closed
              add:npClose)
     apply assumption
   apply (simp only:nsMulDistrL add:nsClose add:ring_tOp_closed
          add:npClose)
   apply (simp only: rMulLC [of "y"] add:npClose)
 
  apply (simp del:npow_suc add:ring_tOp_commute[of y])
  apply (rule aGroup.nsum_eq, assumption)
   apply (rule allI, rule impI, rule nsClose,
          rule ring_tOp_closed, simp add:npClose,
          rule ring_tOp_closed, assumption, simp add:npClose)
   apply (rule allI, rule impI, rule nsClose,
          rule ring_tOp_closed, simp add:npClose,
          rule npClose, assumption)
  apply (rule allI, rule impI)
   apply (frule_tac n = j in npClose[of y])
   apply (simp add:ring_tOp_commute[of y])
 done
 
 (********)(********)(********)(********)
 lemma binomial_n0: "(Suc n choose 0) = (n choose 0)"
   by simp
 
 lemma binomial_ngt_diff:
   "(n choose Suc n) = (Suc n choose Suc n) - (n choose n)"
   by (subst binomial_Suc_Suc, arith)
 
 
 lemma binomial_ngt_0: "(n choose Suc n) = 0"
   apply (subst binomial_ngt_diff,
          (subst binomial_n_n)+)
   apply simp
   done
 
 lemma diffLessSuc: "m \<le> n \<Longrightarrow> Suc (n-m) = Suc n - m"
   by arith
 
 lemma (in Ring) npow_suc_i:
   "\<lbrakk> x \<in> carrier R; i \<le> n \<rbrakk>
         \<Longrightarrow> npow R x (Suc n - i) =  x \<cdot>\<^sub>r (npow R x (n-i))"
   apply (subst diffLessSuc [THEN sym, of "i" "n"], assumption)
   apply (frule_tac n = "n - i" in npClose,
          simp add:ring_tOp_commute[of x])
   done
 (**
 lemma (in Ring) nsumEqFunc_sub:
   "\<lbrakk>  \<And> i. f i \<in> carrier R; \<And> i. g i \<in> carrier R \<rbrakk>
         \<Longrightarrow> ( \<forall> i. i \<le> n \<longrightarrow> f i = g i) \<longrightarrow> (nsum0 R f n = nsum0 R g n)";
   apply (induct_tac "n")
   apply simp+
   done
 
 lemma (in Ring) nsumEqFunc:
   "\<lbrakk> \<And> i. f i \<in> carrier R; \<And> i. g i \<in> carrier R;
      \<And> i. i \<le> n \<longrightarrow> f i = g i \<rbrakk> \<Longrightarrow>  nsum0 R f n = nsum0 R g n"
   apply (cut_tac nsumEqFunc_sub [of "f" "g" "n"])
   apply simp+
   done          nsumEqFunc \<longrightarrow> nsum_eq       **)
 (********)(********)
 
 lemma (in Ring) npeSum2_sub_mulx: "\<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow>
   x \<cdot>\<^sub>r (nsum R (\<lambda> i. nscal R ((npow R x (n-i)) \<cdot>\<^sub>r (npow R y i))
                                                         (n choose i)) n)
    = (nsum R (\<lambda>i. nscal R
                           ((npow R x (Suc n - Suc i)) \<cdot>\<^sub>r (npow R y (Suc i)))
                           (n choose Suc i)) n) \<plusminus>
                 (nscal R ((npow R x (Suc n - 0)) \<cdot>\<^sub>r (npow R y 0))
                         (Suc n choose 0))"
   apply (cut_tac ring_is_ag)
   apply (simp only: binomial_n0)
   apply (subst aGroup.nsumElmTail [THEN sym, of R "\<lambda> i. nscal R ((npow R x (Suc n - i)) \<cdot>\<^sub>r (npow R y i)) (n choose i)"], assumption+)
   apply (rule allI)
       apply (simp only:nsClose add:ring_tOp_closed add:npClose)
 
   apply (simp only:nsum_suc)
   apply (subst binomial_ngt_0)
   apply (simp only:nscal_0)
   apply (subst aGroup.ag_r_zero, assumption)
     apply (simp add:aGroup.nsum_mem nsClose ring_tOp_closed npClose)
   apply (subst nsumMulElmL [of  _ "x"])
     apply (rule allI, rule nsClose, rule ring_tOp_closed, simp add:npClose,
            simp add:npClose, assumption)
 
   apply (simp add: nsMulDistrL [of "x"] ring_tOp_closed npClose)
   apply (simp add:ring_tOp_assoc [THEN sym, of "x"] npClose)
   apply (rule aGroup.nsum_eq, assumption)
    apply (rule allI, rule impI,
           rule nsClose, (rule ring_tOp_closed)+, assumption,
           simp add:npClose, simp add:npClose)
    apply (rule allI, rule impI,
           rule nsClose, rule ring_tOp_closed,
           simp add:npClose, simp add:npClose)
   apply (rule allI, rule impI)
   apply (frule_tac n = "n - j" in npClose[of x],
         simp add:ring_tOp_commute[of x],
         subst npow_suc[THEN sym])
   apply (simp add:Suc_diff_le)
 done
 
 lemma (in Ring) npeSum2_sub_mulx2:
   "\<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk> \<Longrightarrow>
         x \<cdot>\<^sub>r (nsum R (\<lambda> i. nscal R ((npow R x (n-i)) \<cdot>\<^sub>r (npow R y i))
                                 (n choose i)) n)
         = (nsum R  (\<lambda>i. nscal R
                           ((npow R x (n - i)) \<cdot>\<^sub>r ((npow R y i) \<cdot>\<^sub>r y ))
                           (n choose Suc i)) n) \<plusminus>
                 (\<zero> \<plusminus> ((x \<cdot>\<^sub>r (npow R x n)) \<cdot>\<^sub>r (1\<^sub>r)))"
 apply (subst  npeSum2_sub_mulx, assumption+, simp)
 apply (frule npClose[of x n])
 apply (subst ring_tOp_commute[of x], assumption+)
  apply (cut_tac ring_is_ag)
  apply (cut_tac aGroup.nsum_eq[of R n
         "\<lambda>i.  (n choose Suc i) \<times>\<^bsub>R\<^esub> (x^\<^bsup>R (n - i)\<^esup> \<cdot>\<^sub>r y^\<^bsup>R (Suc i)\<^esup>)"
         "\<lambda>i.  (n choose Suc i) \<times>\<^bsub>R\<^esub> (x^\<^bsup>R (n - i)\<^esup> \<cdot>\<^sub>r (y^\<^bsup>R i\<^esup> \<cdot>\<^sub>r y))"])
  apply (simp del:npow_suc)+
   apply (rule allI, rule impI,
          rule nsClose, rule ring_tOp_closed, simp add:npClose,
          simp only:npClose)
   apply (rule allI, rule impI,
          rule nsClose, rule ring_tOp_closed, simp add:npClose,
          rule ring_tOp_closed, simp add:npClose, assumption)
   apply (rule allI, rule impI)
  apply (frule_tac n = j in npClose[of y])
  apply simp
 done
 
 
 lemma (in Ring) npeSum2:
   "\<And> n. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk>
         \<Longrightarrow> npow R (x \<plusminus> y) n =
                 nsum R (\<lambda> i. nscal R ((npow R x (n-i)) \<cdot>\<^sub>r (npow R y i))
                                        ( n choose i) ) n"
   apply (cut_tac ring_is_ag)
   apply (induct_tac "n")
 
   (*1*)
   apply simp
     apply (cut_tac ring_one, simp add:ring_r_one, simp add:aGroup.ag_l_zero)
   (*1:done*)
 
   apply (subst aGroup.nsumElmTail, assumption+)
     apply (rule allI)
     apply (simp add:nsClose ring_tOp_closed npClose)
 
 (**
 thm binomial_Suc_Suc
 **)
   apply (simp only:binomial_Suc_Suc)
   apply (simp only: nsDistr [THEN sym] add:npClose ring_tOp_closed)
   apply (subst aGroup.nsumElmAdd, assumption+)
     apply (rule allI,
            simp add:nsClose ring_tOp_closed npClose)
     apply (rule allI,
            simp add:nsClose add:ring_tOp_closed npClose)
   apply (subst aGroup.ag_pOp_assoc, assumption)
     apply (rule aGroup.nsum_mem, assumption,
            rule allI, rule impI,  simp add:nsClose ring_tOp_closed npClose)
     apply (rule aGroup.nsum_mem, assumption,
            rule allI, rule impI,  simp add:nsClose ring_tOp_closed npClose)
     apply (simp add:nsClose ring_tOp_closed npClose)
     apply (rule aGroup.ag_pOp_closed, assumption)
     apply (simp add:aGroup.ag_inc_zero)
     apply (rule ring_tOp_closed)+
     apply (simp add:npClose, assumption, simp add:ring_one)
 
   apply (subst npMulElmL [THEN sym, of "x \<plusminus> y"],
          simp add:aGroup.ag_pOp_closed, simp)
    apply simp
   apply (subst ring_distrib2 [of _ "x" "y"])
   apply (rule aGroup.nsum_mem,assumption,
          rule allI, rule impI, rule nsClose, rule ring_tOp_closed,
          simp add:npClose, simp add:npClose, assumption+)
   apply (rule aGroup.gEQAddcross [THEN sym], assumption+,
          rule aGroup.nsum_mem, assumption, rule allI, rule impI, rule nsClose,
          (rule ring_tOp_closed)+, simp add:npClose,
          rule ring_tOp_closed, simp add:npClose, assumption)
     apply (rule aGroup.ag_pOp_closed, assumption)
     apply (rule aGroup.nsum_mem, assumption,
            rule allI, rule impI, rule nsClose, rule ring_tOp_closed,
           simp add:npClose, rule ring_tOp_closed, simp add:npClose, assumption)
     apply (rule aGroup.ag_pOp_closed, assumption, simp add:ring_zero)
     apply ((rule ring_tOp_closed)+,
            simp add:npClose,assumption, simp add:ring_one)
     apply (rule ring_tOp_closed, assumption,
            rule aGroup.nsum_mem, assumption, rule allI, rule impI,
            rule nsClose, rule ring_tOp_closed,
            (simp add:npClose)+)
     apply (rule ring_tOp_closed, assumption+,
            rule aGroup.nsum_mem, assumption, rule allI, rule impI,
            rule nsClose,
            rule ring_tOp_closed,
            simp add:npClose, simp add:npClose)
     apply (subst npeSum2_sub_muly [of "x" "y"], assumption+, simp)
 
   (* final part *)
   apply (subst npeSum2_sub_mulx2 [of x y], assumption+)
   apply (frule_tac n = na in npClose[of x],
          simp add:ring_tOp_commute[of _ x])
   done
 
 lemma (in aGroup) nsum_zeroTr:
   "\<And> n. (\<forall> i. i \<le> n \<longrightarrow>  f i = \<zero>) \<longrightarrow> (nsum A f n = \<zero>)"
   apply (induct_tac "n")
   apply simp
 
   apply (rule impI)
   apply (cut_tac n = na in Nsetn_sub_mem1, simp)
     apply (subst aGroup.ag_l_zero, rule aGroup_axioms)
     apply (simp add:ag_inc_zero)
   apply simp
   done
 
 lemma (in Ring) npAdd:
   "\<lbrakk> x \<in> carrier R; y \<in> carrier R;
      npow R x m = \<zero>; npow R y n = \<zero> \<rbrakk>
         \<Longrightarrow> npow R (x \<plusminus> y) (m + n) = \<zero>"
   apply (subst npeSum2, assumption+)
 
   apply (rule aGroup.nsum_zeroTr [THEN mp])
   apply (simp add:ring_is_ag)
   apply (rule allI, rule impI)
   apply (rule nsZeroI)
   apply (rule rMulZeroDiv, simp add:npClose, simp add:npClose)
 
   apply (case_tac "i \<le> n")
 
   apply (rule disjI1)
   apply (rule npGTPowZero [of "x" "m"], assumption+)
     apply arith
 
   apply (rule disjI2)
   apply (rule npGTPowZero [of "y" "n"], assumption+)
     apply (arith)
   done
 
 lemma (in Ring) npInverse:
   "\<And>n. x \<in> carrier R
         \<Longrightarrow> npow R (-\<^sub>a x) n = npow R x n
             \<or> npow R (-\<^sub>a x) n = -\<^sub>a (npow R x n)"
   apply (induct_tac n)
  (* n=0 *)
   apply simp
 
  apply (erule disjE)
  apply simp
  apply (subst ring_inv1_2,
         simp add:npClose, assumption, simp)
  apply (cut_tac ring_is_ag)
 
  apply simp
  apply (subst ring_inv1_2[THEN sym, of _ x])
  apply (rule aGroup.ag_mOp_closed, assumption+,
         simp add:npClose, assumption)
  apply (thin_tac "(-\<^sub>a x)^\<^bsup>R na\<^esup> = -\<^sub>a (x^\<^bsup>R na\<^esup>)",
         frule_tac n = na in npClose[of x],
         frule_tac x = "x^\<^bsup>R na\<^esup>" in aGroup.ag_mOp_closed[of R], simp add:npClose)
  apply (simp add: ring_inv1_1[of _ x])
  apply (simp add:aGroup.ag_inv_inv[of R])
 done
 
 lemma (in Ring) npMul:
   "\<And> n. \<lbrakk> x \<in> carrier R; y \<in> carrier R \<rbrakk>
         \<Longrightarrow> npow R (x \<cdot>\<^sub>r y) n = (npow R x n) \<cdot>\<^sub>r (npow R y n)"
   apply (induct_tac "n")
  (* n=0 *)
   apply simp
   apply (rule ring_r_one [THEN sym]) apply (simp add:ring_one)
  (* n>0 *)
   apply (simp only:npow_suc)
   apply (rule ring_tOp_rel[THEN sym])
     apply (rule npClose, assumption+)+
   done
 
 section "Ring homomorphisms"
 
 definition
   rHom :: "[('a, 'm) Ring_scheme, ('b, 'm1) Ring_scheme]
                       \<Rightarrow> ('a  \<Rightarrow> 'b) set" where
   "rHom A R = {f. f \<in> aHom A R \<and>
     (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. f ( x \<cdot>\<^sub>r\<^bsub>A\<^esub> y) =  (f x) \<cdot>\<^sub>r\<^bsub>R\<^esub> (f y))
     \<and> f (1\<^sub>r\<^bsub>A\<^esub>) = (1\<^sub>r\<^bsub>R\<^esub>)}"
 
 definition
   rInvim :: "[('a, 'm) Ring_scheme, ('b, 'm1) Ring_scheme, 'a \<Rightarrow> 'b, 'b set]
                \<Rightarrow> 'a set" where
   "rInvim A R f K = {a. a \<in> carrier A \<and> f a \<in> K}"
 
 definition
   rimg :: "[('a, 'm) Ring_scheme, ('b, 'm1) Ring_scheme, 'a \<Rightarrow> 'b] \<Rightarrow>
             'b Ring" where
   "rimg A R f = \<lparr>carrier= f `(carrier A), pop = pop R, mop = mop R,
     zero = zero R, tp = tp R, un = un R \<rparr>"
 
 definition
   ridmap :: "('a, 'm) Ring_scheme \<Rightarrow> ('a \<Rightarrow> 'a)" where
   "ridmap R = (\<lambda>x\<in>carrier R. x)"
 
 definition
   r_isom :: "[('a, 'm) Ring_scheme, ('b, 'm1) Ring_scheme] \<Rightarrow> bool"
                        (infixr "\<cong>\<^sub>r" 100) where
   "r_isom R R' \<longleftrightarrow> (\<exists>f\<in>rHom R R'. bijec\<^bsub>R,R'\<^esub> f)"
 
 definition
   Subring :: "[('a, 'm) Ring_scheme, ('a, 'm1) Ring_scheme] \<Rightarrow> bool" where
   "Subring R S == Ring S \<and> (carrier S \<subseteq> carrier R) \<and> (ridmap S) \<in> rHom S R"
 
 lemma ridmap_surjec:"Ring A \<Longrightarrow> surjec\<^bsub>A,A\<^esub> (ridmap A)"
 by(simp add:surjec_def aHom_def ridmap_def Ring.ring_is_ag aGroup.ag_pOp_closed surj_to_def)
 
 lemma rHom_aHom:"f \<in> rHom A R \<Longrightarrow> f \<in> aHom A R"
 by (simp add:rHom_def)
 
 lemma rimg_carrier:"f \<in> rHom A R \<Longrightarrow> carrier (rimg A R f) = f ` (carrier A)"
 by (simp add:rimg_def)
 
 lemma rHom_mem:"\<lbrakk> f \<in> rHom A R; a \<in> carrier A \<rbrakk> \<Longrightarrow> f a \<in> carrier R"
 apply (simp add:rHom_def, frule conjunct1)
  apply (thin_tac "f \<in> aHom A R \<and>
      (\<forall>x\<in>carrier A. \<forall>y\<in>carrier A. f (x \<cdot>\<^sub>r\<^bsub>A\<^esub> y) = f x \<cdot>\<^sub>r\<^bsub>R\<^esub> f y) \<and> f 1\<^sub>r\<^bsub>A\<^esub> = 1\<^sub>r\<^bsub>R\<^esub>")
  apply (simp add:aHom_def, frule conjunct1)
  apply (thin_tac "f \<in> carrier A \<rightarrow> carrier R \<and>
      f \<in> extensional (carrier A) \<and>
      (\<forall>a\<in>carrier A. \<forall>b\<in>carrier A. f (a \<plusminus>\<^bsub>A\<^esub> b) = f a \<plusminus>\<^bsub>R\<^esub> f b)")
  apply (simp add:funcset_mem)
 done
 
 lemma rHom_func:"f \<in> rHom A R \<Longrightarrow> f \<in> carrier A \<rightarrow> carrier R"
 by (simp add:rHom_def aHom_def)
 
 lemma ringhom1:"\<lbrakk> Ring A; Ring R; x \<in> carrier A; y \<in> carrier A;
                     f \<in> rHom A R \<rbrakk> \<Longrightarrow> f (x \<plusminus>\<^bsub>A\<^esub> y) = (f x) \<plusminus>\<^bsub>R\<^esub> (f y)"
 apply (simp add:rHom_def) apply (erule conjE)
 apply (frule Ring.ring_is_ag [of "A"])
 apply (frule Ring.ring_is_ag [of "R"])
 apply (rule aHom_add, assumption+)
 done
 
 lemma rHom_inv_inv:"\<lbrakk> Ring A; Ring R; x \<in> carrier A; f \<in> rHom A R \<rbrakk>
  \<Longrightarrow> f (-\<^sub>a\<^bsub>A\<^esub> x) = -\<^sub>a\<^bsub>R\<^esub> (f x)"
 apply (frule Ring.ring_is_ag [of "A"],
        frule Ring.ring_is_ag [of "R"])
 apply (simp add:rHom_def, erule conjE)
 apply (simp add:aHom_inv_inv)
 done
 
 lemma rHom_0_0:"\<lbrakk> Ring A; Ring R; f \<in> rHom A R \<rbrakk>  \<Longrightarrow> f (\<zero>\<^bsub>A\<^esub>) = \<zero>\<^bsub>R\<^esub>"
 apply (frule Ring.ring_is_ag [of "A"], frule Ring.ring_is_ag [of "R"])
 apply (simp add:rHom_def, (erule conjE)+, simp add:aHom_0_0)
 done
 
 lemma rHom_tOp:"\<lbrakk> Ring A; Ring R; x \<in> carrier A; y \<in> carrier A;
  f \<in> rHom A R \<rbrakk> \<Longrightarrow> f (x \<cdot>\<^sub>r\<^bsub>A\<^esub> y) = (f x) \<cdot>\<^sub>r\<^bsub>R\<^esub> (f y)"
 by (simp add:rHom_def)
 
 lemma rHom_add:"\<lbrakk>f \<in> rHom A R; x \<in> carrier A; y \<in> carrier A\<rbrakk> \<Longrightarrow>
                    f (x \<plusminus>\<^bsub>A\<^esub> y) = (f x) \<plusminus>\<^bsub>R\<^esub> (f y)"
 by (simp add:rHom_def aHom_def)
 
 lemma rHom_one:"\<lbrakk> Ring A; Ring R;f \<in> rHom A R \<rbrakk> \<Longrightarrow> f (1\<^sub>r\<^bsub>A\<^esub>) = (1\<^sub>r\<^bsub>R\<^esub>)"
 by (simp add:rHom_def)
 
 lemma rHom_npow:"\<lbrakk> Ring A; Ring R; x \<in> carrier A; f \<in> rHom A R \<rbrakk> \<Longrightarrow>
                     f (x^\<^bsup>A n\<^esup>) = (f x)^\<^bsup>R n\<^esup>"
 apply (induct_tac n)
 apply (simp add:rHom_one)
 apply (simp,
       frule_tac n = n in Ring.npClose[of "A" "x"], assumption+,
       subst rHom_tOp[of "A" "R" _ "x" "f"], assumption+, simp)
 done
 
 lemma rHom_compos:"\<lbrakk>Ring A; Ring B; Ring C; f \<in> rHom A B; g \<in> rHom B C\<rbrakk> \<Longrightarrow>
                    compos A g f \<in> rHom A C"
 apply (subst rHom_def, simp)
 apply (frule Ring.ring_is_ag[of "A"], frule Ring.ring_is_ag[of "B"],
        frule Ring.ring_is_ag[of "C"],
        frule rHom_aHom[of "f" "A" "B"], frule rHom_aHom[of "g" "B" "C"],
        simp add:aHom_compos)
 apply (rule conjI)
  apply ((rule ballI)+, simp add:compos_def compose_def,
         frule_tac x = x and y = y in Ring.ring_tOp_closed[of "A"], assumption+,
         simp)
 apply (simp add:rHom_tOp)
  apply (frule_tac a = x in rHom_mem[of "f" "A" "B"], assumption+,
         frule_tac a = y in rHom_mem[of "f" "A" "B"], assumption+,
          simp add:rHom_tOp)
  apply (frule Ring.ring_one[of "A"], frule Ring.ring_one[of "B"],
         simp add:compos_def compose_def, simp add:rHom_one)
 done
 
 lemma rimg_ag:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow> aGroup (rimg A R f)"
 apply (frule Ring.ring_is_ag [of "A"],
        frule Ring.ring_is_ag [of "R"])
 apply (simp add:rHom_def, (erule conjE)+)
 apply (subst aGroup_def)
 apply (simp add:rimg_def)
 apply (rule conjI)
  apply (rule Pi_I)+
  apply (simp add:image_def)
  apply (erule bexE)+
  apply simp
  apply (subst aHom_add [THEN sym, of "A" "R" "f"], assumption+)
  apply (blast dest: aGroup.ag_pOp_closed)
 apply (rule conjI)
  apply ((rule allI, rule impI)+, simp add:image_def, (erule bexE)+, simp)
  apply (frule_tac x = x and y = xa in aGroup.ag_pOp_closed, assumption+,
         frule_tac x = xa and y = xb in aGroup.ag_pOp_closed, assumption+)
  apply (simp add:aHom_add[of "A" "R" "f", THEN sym] aGroup.ag_pOp_assoc)
 apply (rule conjI)
  apply ((rule allI, rule impI)+, simp add:image_def, (erule bexE)+, simp)
  apply (simp add:aHom_add[of "A" "R" "f", THEN sym] aGroup.ag_pOp_commute)
 apply (rule conjI)
  apply (rule Pi_I)
  apply (simp add:image_def, erule bexE, simp)
  apply (simp add:aHom_inv_inv[THEN sym],
         frule_tac x = xa in aGroup.ag_mOp_closed[of "A"], assumption+, blast)
 apply (rule conjI)
   apply (rule allI, rule impI, simp add:image_def, (erule bexE)+, simp)
    apply (simp add:aHom_inv_inv[THEN sym],
         frule_tac x = x in aGroup.ag_mOp_closed[of "A"], assumption+,
         simp add:aHom_add[of "A" "R" "f", THEN sym])
  apply (simp add:aGroup.ag_l_inv1 aHom_0_0)
 apply (rule conjI)
  apply (simp add:image_def)
  apply (frule aHom_0_0[THEN sym, of "A" "R" "f"], assumption+,
         frule Ring.ring_zero[of "A"], blast)
 
 apply (rule allI, rule impI,
        simp add:image_def, erule bexE,
        frule_tac a = x in aHom_mem[of "A" "R" "f"], assumption+, simp)
  apply (simp add:aGroup.ag_l_zero)
 done
 
 lemma rimg_ring:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R \<rbrakk> \<Longrightarrow> Ring (rimg A R f)"
 apply (unfold Ring_def [of "rimg A R f"])
 apply (frule rimg_ag[of "A" "R" "f"], assumption+)
  apply (rule conjI, simp add:aGroup_def[of "rimg A R f"])
 apply(rule conjI)
  apply (rule conjI, rule allI, rule impI)
  apply (frule aGroup.ag_inc_zero[of "rimg A R f"],
         subst aGroup.ag_pOp_commute, assumption+,
         simp add:aGroup.ag_r_zero[of "rimg A R f"])
 
 apply (rule conjI)
 apply (rule Pi_I)+
 apply (thin_tac "aGroup (rimg A R f)",
        simp add:rimg_def, simp add:image_def, (erule bexE)+,
        simp add:rHom_tOp[THEN sym])
  apply (blast dest:Ring.ring_tOp_closed)
  apply ((rule allI)+, (rule impI)+)
  apply (thin_tac "aGroup (rimg A R f)", simp add:rimg_def,
         simp add:image_def, (erule bexE)+, simp)
  apply (frule_tac x = x and y = xa in Ring.ring_tOp_closed, assumption+,
         frule_tac x = xa and y = xb in Ring.ring_tOp_closed, assumption+,
         simp add:rHom_tOp[THEN sym],
         simp add:Ring.ring_tOp_assoc)
 apply (rule conjI, rule conjI, (rule allI)+, (rule impI)+)
  apply (thin_tac "aGroup (rimg A R f)", simp add:rimg_def,
         simp add:image_def, (erule bexE)+, simp,
         simp add:rHom_tOp[THEN sym],
         simp add:Ring.ring_tOp_commute)
   apply (thin_tac "aGroup (rimg A R f)", simp add:rimg_def,
          simp add:image_def)
   apply (subst rHom_one [THEN sym, of "A" "R" "f"], assumption+,
          frule Ring.ring_one[of "A"], blast)
 apply (rule conjI, (rule allI)+, (rule impI)+)
 apply (simp add:rimg_def, fold rimg_def,
        simp add:image_def, (erule bexE)+, simp)
  apply (frule rHom_aHom[of "f" "A" "R"],
         frule Ring.ring_is_ag [of "A"],
         frule Ring.ring_is_ag [of "R"],
         simp add:aHom_add[THEN sym],
         simp add:rHom_tOp[THEN sym])
  apply (frule_tac x = xa and y = xb in aGroup.ag_pOp_closed[of "A"],
           assumption+,
         frule_tac x = x and y = xa in Ring.ring_tOp_closed[of "A"],
           assumption+,
         frule_tac x = x and y = xb in Ring.ring_tOp_closed[of "A"],
           assumption+,
         simp add:aHom_add[THEN sym],
         simp add:rHom_tOp[THEN sym],
         simp add:Ring.ring_distrib1)
  apply (rule allI, rule impI,
         thin_tac "aGroup (rimg A R f)")
  apply (simp add:rimg_def,
         simp add:image_def, erule bexE, simp add:rHom_tOp[THEN sym],
         frule_tac a = x in rHom_mem[of "f" "A" "R"], assumption+,
          simp add:Ring.ring_l_one)
 done
 
 definition
   ideal :: "[_ , 'a set] \<Rightarrow> bool" where
   "ideal R I \<longleftrightarrow> (R +> I) \<and> (\<forall>r\<in>carrier R. \<forall>x\<in>I. (r \<cdot>\<^sub>r\<^bsub>R\<^esub> x \<in> I))"
 
 
 lemma (in Ring) ideal_asubg:"ideal R I \<Longrightarrow> R +> I"
 by (simp add:ideal_def)
 
 lemma (in Ring) ideal_pOp_closed:"\<lbrakk>ideal R I; x \<in> I; y \<in> I \<rbrakk>
                                                    \<Longrightarrow> x \<plusminus> y \<in> I"
 apply (unfold ideal_def, frule conjunct1, fold ideal_def)
 apply (cut_tac ring_is_ag,
        simp add:aGroup.asubg_pOp_closed)
 done
 
 lemma (in Ring) ideal_nsum_closedTr:"ideal R I \<Longrightarrow>
                                       (\<forall>j \<le> n. f j \<in> I) \<longrightarrow>  nsum R f n \<in> I"
 apply (induct_tac n)
  apply (rule impI)
  apply simp
 
  apply (rule impI)
  apply (cut_tac n = n in Nsetn_sub_mem1, simp)
  apply (rule ideal_pOp_closed, assumption+)
  apply simp
 done
 
 lemma (in Ring) ideal_nsum_closed:"\<lbrakk>ideal R I; \<forall>j \<le> n. f j \<in> I\<rbrakk> \<Longrightarrow>
                                              nsum R f n \<in> I"
 by (simp add:ideal_nsum_closedTr)
 
 lemma (in Ring) ideal_subset1:"ideal R I \<Longrightarrow> I \<subseteq> carrier R"
 apply (unfold ideal_def, frule conjunct1, fold ideal_def)
   apply (simp add:asubGroup_def sg_def, (erule conjE)+)
   apply (cut_tac ring_is_ag,
          simp add:aGroup.ag_carrier_carrier)
 done
 
 lemma (in Ring) ideal_subset:"\<lbrakk>ideal R I; h \<in> I\<rbrakk> \<Longrightarrow> h \<in> carrier R"
 by (frule ideal_subset1[of "I"],
        simp add:subsetD)
 
 lemma (in Ring) ideal_ring_multiple:"\<lbrakk>ideal R I; x \<in> I; r \<in> carrier R\<rbrakk> \<Longrightarrow>
        r \<cdot>\<^sub>r x \<in> I"
 by (simp add:ideal_def)
 
 lemma (in Ring) ideal_ring_multiple1:"\<lbrakk>ideal R I; x \<in> I; r \<in> carrier R \<rbrakk> \<Longrightarrow>
        x \<cdot>\<^sub>r r \<in> I"
 apply (frule ideal_subset[of "I" "x"], assumption+)
 apply (simp add:ring_tOp_commute ideal_ring_multiple)
 done
 
 lemma (in Ring) ideal_npow_closedTr:"\<lbrakk>ideal R I; x \<in> I\<rbrakk> \<Longrightarrow>
                                         0 < n \<longrightarrow> x^\<^bsup>R n\<^esup> \<in> I"
 apply (induct_tac n,
        simp)
 apply (rule impI)
  apply simp
  apply (case_tac "n = 0", simp)
  apply (frule ideal_subset[of "I" "x"], assumption+,
         simp add:ring_l_one)
 
  apply simp
 apply (frule ideal_subset[of "I" "x"], assumption+,
        rule ideal_ring_multiple, assumption+,
        simp add:ideal_subset)
 done
 
 lemma (in Ring) ideal_npow_closed:"\<lbrakk>ideal R I; x \<in> I; 0 < n\<rbrakk> \<Longrightarrow> x^\<^bsup>R n\<^esup> \<in> I"
 by (simp add:ideal_npow_closedTr)
 
 lemma (in Ring) times_modTr:"\<lbrakk>a \<in> carrier R; a' \<in> carrier R; b \<in> carrier R;
  b' \<in> carrier R; ideal R I; a \<plusminus> (-\<^sub>a b) \<in> I; a' \<plusminus> (-\<^sub>a b') \<in> I\<rbrakk> \<Longrightarrow>
                            a \<cdot>\<^sub>r a' \<plusminus> (-\<^sub>a (b \<cdot>\<^sub>r b')) \<in> I"
 apply (cut_tac ring_is_ag)
 apply (subgoal_tac "a \<cdot>\<^sub>r a' \<plusminus> (-\<^sub>a (b \<cdot>\<^sub>r b')) = a \<cdot>\<^sub>r a' \<plusminus> (-\<^sub>a (a \<cdot>\<^sub>r b'))
                        \<plusminus> (a \<cdot>\<^sub>r b' \<plusminus> (-\<^sub>a (b \<cdot>\<^sub>r b')))")
 apply simp
  apply (simp add:ring_inv1_2[of "a" "b'"], simp add:ring_inv1_1[of "b" "b'"])
  apply (frule aGroup.ag_mOp_closed[of "R" "b'"], assumption+)
  apply (simp add:ring_distrib1[THEN sym, of "a" "a'" "-\<^sub>a b'"])
  apply (frule aGroup.ag_mOp_closed[of "R" "b"], assumption+)
  apply (frule ring_distrib2[THEN sym, of "b'" "a" "-\<^sub>a b" ], assumption+)
  apply simp
 
 apply (thin_tac "a \<cdot>\<^sub>r a' \<plusminus> (-\<^sub>a b) \<cdot>\<^sub>r b' = a \<cdot>\<^sub>r (a' \<plusminus> -\<^sub>a b') \<plusminus> (a \<plusminus> -\<^sub>a b) \<cdot>\<^sub>r b'",
        thin_tac "a \<cdot>\<^sub>r b' \<plusminus> (-\<^sub>a b) \<cdot>\<^sub>r b' = (a \<plusminus> -\<^sub>a b) \<cdot>\<^sub>r b'")
  apply (frule ideal_ring_multiple[of "I" "a' \<plusminus> (-\<^sub>a b')" "a"], assumption+,
         frule ideal_ring_multiple1[of "I" "a \<plusminus> (-\<^sub>a b)" "b'"], assumption+)
  apply (simp add:ideal_pOp_closed)
 
 apply (frule ring_tOp_closed[of "a" "a'"], assumption+,
        frule ring_tOp_closed[of "a" "b'"], assumption+,
        frule ring_tOp_closed[of "b" "b'"], assumption+,
        frule aGroup.ag_mOp_closed[of "R" "b \<cdot>\<^sub>r b'"], assumption+,
        frule aGroup.ag_mOp_closed[of "R" "a \<cdot>\<^sub>r b'"], assumption+)
 
  apply (subst aGroup.ag_pOp_assoc[of "R"], assumption+)
  apply (rule aGroup.ag_pOp_closed, assumption+)
  apply (simp add:aGroup.ag_pOp_assoc[THEN sym, of "R" "-\<^sub>a (a \<cdot>\<^sub>r b')" "a \<cdot>\<^sub>r b'"
                           "-\<^sub>a (b \<cdot>\<^sub>r b')"],
         simp add:aGroup.ag_l_inv1 aGroup.ag_l_zero)
 done
 
 lemma (in Ring) ideal_inv1_closed:"\<lbrakk> ideal R I; x \<in> I \<rbrakk> \<Longrightarrow> -\<^sub>a x \<in> I"
 apply (cut_tac ring_is_ag)
 apply (unfold ideal_def, frule conjunct1, fold ideal_def)
 apply (simp add:aGroup.asubg_mOp_closed[of "R" "I"])
 done
 
 lemma (in Ring) ideal_zero:"ideal R I  \<Longrightarrow> \<zero> \<in> I"
 
 apply (cut_tac ring_is_ag)
 apply (unfold ideal_def, frule conjunct1, fold ideal_def)
 apply (simp add:aGroup.asubg_inc_zero)
 done
 
 lemma (in Ring) ideal_zero_forall:"\<forall>I. ideal R I \<longrightarrow>  \<zero> \<in> I"
 by (simp add:ideal_zero)
 
 lemma (in Ring) ideal_ele_sumTr1:"\<lbrakk> ideal R I; a \<in> carrier R; b \<in> carrier R;
           a \<plusminus> b \<in> I; a \<in> I \<rbrakk> \<Longrightarrow> b \<in> I"
 apply (frule ideal_inv1_closed[of "I" "a"], assumption+)
 apply (frule ideal_pOp_closed[of "I" "-\<^sub>a a" "a \<plusminus> b"], assumption+)
 apply (frule ideal_subset[of "I" "-\<^sub>a a"], assumption+)
 apply (cut_tac ring_is_ag,
        simp add:aGroup.ag_pOp_assoc[THEN sym],
        simp add:aGroup.ag_l_inv1,
        simp add:aGroup.ag_l_zero)
 done
 
 lemma (in Ring) ideal_ele_sumTr2:"\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R;
                 a \<plusminus> b \<in> I; b \<in> I\<rbrakk> \<Longrightarrow> a \<in> I"
 apply (cut_tac ring_is_ag,
        simp add:aGroup.ag_pOp_commute[of "R" "a" "b"])
 apply (simp add:ideal_ele_sumTr1[of "I" "b" "a"])
 done
 
 lemma (in Ring) ideal_condition:"\<lbrakk>I \<subseteq> carrier R; I \<noteq> {};
        \<forall>x\<in>I. \<forall>y\<in>I. x \<plusminus> (-\<^sub>a y) \<in> I; \<forall>r\<in>carrier R. \<forall>x\<in>I. r \<cdot>\<^sub>r x \<in> I \<rbrakk> \<Longrightarrow>
                                    ideal R I"
 apply (simp add:ideal_def)
  apply (cut_tac ring_is_ag)
  apply (rule aGroup.asubg_test[of "R" "I"], assumption+)
 done
 
 lemma (in Ring) ideal_condition1:"\<lbrakk>I \<subseteq> carrier R; I \<noteq> {};
   \<forall>x\<in>I. \<forall>y\<in>I. x \<plusminus> y \<in> I; \<forall>r\<in>carrier R. \<forall>x\<in>I. r \<cdot>\<^sub>r x \<in> I \<rbrakk> \<Longrightarrow> ideal R I"
 apply (rule ideal_condition[of "I"], assumption+)
 apply (rule ballI)+
 apply (cut_tac ring_is_ag,
        cut_tac ring_one,
        frule aGroup.ag_mOp_closed[of "R" "1\<^sub>r"], assumption+)
  apply (frule_tac x = "-\<^sub>a 1\<^sub>r " in bspec, assumption+,
         thin_tac "\<forall>r\<in>carrier R. \<forall>x\<in>I. r \<cdot>\<^sub>r x \<in> I",
         rotate_tac -1,
         frule_tac x = y in bspec, assumption,
         thin_tac "\<forall>x\<in>I. (-\<^sub>a 1\<^sub>r) \<cdot>\<^sub>r x \<in> I")
  apply (frule_tac c = y in subsetD[of "I" "carrier R"], assumption+,
         simp add:ring_times_minusl[THEN sym], simp add:ideal_pOp_closed)
 done
 
 lemma (in Ring) zero_ideal:"ideal R {\<zero>}"
 apply (cut_tac ring_is_ag)
 apply (rule ideal_condition1)
  apply (simp add:ring_zero)
  apply simp
  apply simp
 apply (cut_tac ring_zero, simp add:aGroup.ag_l_zero)
 apply simp
  apply (rule ballI, simp add:ring_times_x_0)
 done
 
 lemma (in Ring) whole_ideal:"ideal R (carrier R)"
 apply (rule ideal_condition1)
  apply simp
  apply (cut_tac ring_zero, blast)
  apply (cut_tac ring_is_ag,
         simp add:aGroup.ag_pOp_closed,
         simp add:ring_tOp_closed)
 done
 
 lemma (in Ring) ideal_inc_one:"\<lbrakk>ideal R I; 1\<^sub>r \<in> I \<rbrakk> \<Longrightarrow> I = carrier R"
 apply (rule equalityI)
 apply (simp add:ideal_subset1)
 apply (rule subsetI,
        frule_tac r = x in ideal_ring_multiple[of "I" "1\<^sub>r"], assumption+,
        simp add:ring_r_one)
 done
 
 lemma (in Ring) ideal_inc_one1:"ideal R I \<Longrightarrow>
                               (1\<^sub>r \<in> I) = (I = carrier R)"
 apply (rule iffI)
  apply (simp add:ideal_inc_one)
  apply (frule sym, thin_tac "I = carrier R",
         cut_tac ring_one, simp)
 done
 
 definition
   Unit :: "_ \<Rightarrow> 'a \<Rightarrow> bool" where
   "Unit R a \<longleftrightarrow> a \<in> carrier R \<and> (\<exists>b\<in>carrier R. a \<cdot>\<^sub>r\<^bsub>R\<^esub> b = 1\<^sub>r\<^bsub>R\<^esub>)"
 
 lemma (in Ring) ideal_inc_unit:"\<lbrakk>ideal R I; a \<in> I; Unit R a\<rbrakk> \<Longrightarrow> 1\<^sub>r \<in> I"
 by (simp add:Unit_def, erule conjE, erule bexE,
        frule_tac r = b in ideal_ring_multiple1[of "I" "a"], assumption+,
        simp)
 
 lemma (in Ring) proper_ideal:"\<lbrakk>ideal R I; 1\<^sub>r \<notin> I\<rbrakk> \<Longrightarrow> I \<noteq> carrier R"
 apply (rule contrapos_pp, simp+)
 apply (simp add: ring_one)
 done
 
 lemma (in Ring) ideal_inc_unit1:"\<lbrakk>a \<in> carrier R; Unit R a; ideal R I; a \<in> I\<rbrakk>
                         \<Longrightarrow> I = carrier R"
 apply (frule ideal_inc_unit[of "I" "a"], assumption+)
 apply (rule ideal_inc_one[of "I"], assumption+)
 done
 
 lemma (in Ring) int_ideal:"\<lbrakk>ideal R I; ideal R J\<rbrakk> \<Longrightarrow> ideal R (I \<inter> J)"
 apply (rule ideal_condition1)
 apply (frule ideal_subset1[of "I"], frule ideal_subset1[of "J"])
  apply blast
  apply (frule ideal_zero[of "I"], frule ideal_zero[of "J"], blast)
 
  apply ((rule ballI)+, simp, (erule conjE)+,
          simp add:ideal_pOp_closed)
  apply ((rule ballI)+, simp, (erule conjE)+)
  apply (simp add:ideal_ring_multiple)
 done
 
 definition
   ideal_prod::"[_, 'a set, 'a set] \<Rightarrow> 'a set" (infix "\<diamondsuit>\<^sub>r\<index>" 90 ) where
   "ideal_prod R I J == \<Inter> {L. ideal R L \<and>
                               {x.(\<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r\<^bsub>R\<^esub> j)} \<subseteq> L}"
 
 lemma (in Ring) set_sum_mem:"\<lbrakk>a \<in> I; b \<in> J; I \<subseteq> carrier R; J \<subseteq> carrier R\<rbrakk> \<Longrightarrow>
              a \<plusminus> b \<in> I \<minusplus> J"
 apply (cut_tac ring_is_ag)
 apply (simp add:aGroup.set_sum, blast)
 done
 
 lemma (in Ring) sum_ideals:"\<lbrakk>ideal R I1; ideal R I2\<rbrakk> \<Longrightarrow> ideal R (I1 \<minusplus> I2)"
 apply (cut_tac ring_is_ag)
 apply (frule ideal_subset1[of "I1"], frule ideal_subset1[of "I2"])
 apply (rule ideal_condition1)
  apply (rule subsetI, simp add:aGroup.set_sum, (erule bexE)+)
  apply (frule_tac h = h in ideal_subset[of "I1"], assumption+,
         frule_tac h = k in ideal_subset[of "I2"], assumption+,
         cut_tac ring_is_ag,
         simp add:aGroup.ag_pOp_closed)
  apply (frule ideal_zero[of "I1"], frule ideal_zero[of "I2"],
         frule set_sum_mem[of "\<zero>" "I1" "\<zero>" "I2"], assumption+, blast)
 apply (rule ballI)+
  apply (simp add:aGroup.set_sum, (erule bexE)+, simp)
  apply (rename_tac x y i ia j ja)
  apply (frule_tac h = i in ideal_subset[of "I1"], assumption+,
         frule_tac h = ia in ideal_subset[of "I1"], assumption+,
         frule_tac h = j in ideal_subset[of "I2"], assumption+,
         frule_tac h = ja in ideal_subset[of "I2"], assumption+)
  apply (subst aGroup.pOp_assocTr43, assumption+)
  apply (frule_tac x = j and y = ia in aGroup.ag_pOp_commute[of "R"],
           assumption+, simp)
  apply (subst aGroup.pOp_assocTr43[THEN sym], assumption+)
  apply (frule_tac x = i and y = ia in ideal_pOp_closed[of "I1"], assumption+,
         frule_tac x = j and y = ja in ideal_pOp_closed[of "I2"], assumption+,
         blast)
 apply (rule ballI)+
  apply (simp add:aGroup.set_sum, (erule bexE)+, simp)
  apply (rename_tac r x i j)
  apply (frule_tac h = i in ideal_subset[of "I1"], assumption+,
         frule_tac h = j in ideal_subset[of "I2"], assumption+)
  apply (simp add:ring_distrib1)
  apply (frule_tac x = i and r = r in ideal_ring_multiple[of "I1"], assumption+,
         frule_tac x = j and r = r in ideal_ring_multiple[of "I2"], assumption+,
         blast)
 done
 
 lemma (in Ring) sum_ideals_la1:"\<lbrakk>ideal R I1; ideal R I2\<rbrakk> \<Longrightarrow> I1 \<subseteq> (I1 \<minusplus> I2)"
 apply (cut_tac ring_is_ag)
 apply (rule subsetI)
 apply (frule ideal_zero[of "I2"],
        frule_tac h = x in ideal_subset[of "I1"], assumption+,
        frule_tac x = x in aGroup.ag_r_zero[of "R"], assumption+)
 apply (subst aGroup.set_sum, assumption,
        simp add:ideal_subset1, simp add:ideal_subset1, simp,
        frule sym, thin_tac "x \<plusminus> \<zero> = x", blast)
 done
 
 lemma (in Ring) sum_ideals_la2:"\<lbrakk>ideal R I1; ideal R I2 \<rbrakk> \<Longrightarrow> I2 \<subseteq> (I1 \<minusplus> I2)"
 apply (cut_tac ring_is_ag)
 apply (rule subsetI)
 apply (frule ideal_zero[of "I1"],
        frule_tac h = x in ideal_subset[of "I2"], assumption+,
        frule_tac x = x in aGroup.ag_l_zero[of "R"], assumption+)
 apply (subst aGroup.set_sum, assumption,
        simp add:ideal_subset1, simp add:ideal_subset1, simp,
        frule sym, thin_tac "\<zero> \<plusminus> x = x", blast)
 done
 
 lemma (in Ring) sum_ideals_cont:"\<lbrakk>ideal R I;  A \<subseteq> I; B \<subseteq> I \<rbrakk> \<Longrightarrow> A \<minusplus> B \<subseteq> I"
 apply (cut_tac ring_is_ag)
 apply (rule subsetI)
  apply (frule ideal_subset1[of I],
         frule subset_trans[of A I "carrier R"], assumption+,
         frule subset_trans[of B I "carrier R"], assumption+)
  apply (simp add:aGroup.set_sum[of R], (erule bexE)+, simp)
  apply (frule_tac c = h in subsetD[of "A" "I"], assumption+,
         frule_tac c = k in subsetD[of "B" "I"], assumption+)
  apply (simp add:ideal_pOp_closed)
 done
 
 lemma (in Ring) ideals_set_sum:"\<lbrakk>ideal R A; ideal R B; x \<in> A \<minusplus> B\<rbrakk> \<Longrightarrow>
              \<exists>h\<in>A. \<exists>k\<in>B. x = h \<plusminus> k"
 apply (frule ideal_subset1[of A],
        frule ideal_subset1[of B])
 apply (cut_tac ring_is_ag,
        simp add:aGroup.set_sum)
 done
 
 definition
   Rxa :: "[_, 'a ] \<Rightarrow> 'a set" (infixl "\<diamondsuit>\<^sub>p" 200)  where
   "Rxa R a = {x. \<exists>r\<in>carrier R. x = (r \<cdot>\<^sub>r\<^bsub>R\<^esub> a)}"
 
 lemma (in Ring) a_in_principal:"a \<in> carrier R \<Longrightarrow> a \<in> Rxa R a"
 apply (cut_tac ring_one,
        frule ring_l_one[THEN sym, of "a"])
 apply (simp add:Rxa_def, blast)
 done
 
 lemma (in Ring) principal_ideal:"a \<in> carrier R \<Longrightarrow> ideal R (Rxa R a)"
 apply (rule ideal_condition1)
   apply (rule subsetI,
          simp add:Rxa_def, erule bexE, simp add:ring_tOp_closed)
 apply (frule a_in_principal[of "a"], blast)
 apply ((rule ballI)+,
         simp add:Rxa_def, (erule bexE)+, simp,
         subst ring_distrib2[THEN sym], assumption+,
         cut_tac ring_is_ag,
         frule_tac x = r and y = ra in aGroup.ag_pOp_closed, assumption+,
         blast)
 apply ((rule ballI)+,
         simp add:Rxa_def, (erule bexE)+, simp,
         simp add:ring_tOp_assoc[THEN sym])
  apply (frule_tac x = r and y = ra in ring_tOp_closed, assumption, blast)
 done
 
 lemma (in Ring) rxa_in_Rxa:"\<lbrakk>a \<in> carrier R; r \<in> carrier R\<rbrakk> \<Longrightarrow>
                                      r \<cdot>\<^sub>r a \<in> Rxa R a"
 by (simp add:Rxa_def, blast)
 
 lemma (in Ring) Rxa_one:"Rxa R 1\<^sub>r = carrier R"
 apply (rule equalityI)
  apply (rule subsetI, simp add:Rxa_def, erule bexE)
  apply (simp add:ring_r_one)
 
  apply (rule subsetI, simp add:Rxa_def)
  apply (frule_tac t = x in ring_r_one[THEN sym], blast)
 done
 
 lemma (in Ring) Rxa_zero:"Rxa R \<zero> = {\<zero>}"
 apply (rule equalityI)
 apply (rule subsetI)
  apply (simp add:Rxa_def, erule bexE, simp add:ring_times_x_0)
 apply (rule subsetI)
  apply (simp add:Rxa_def)
  apply (cut_tac ring_zero,
         frule ring_times_x_0[THEN sym, of "\<zero>"], blast)
 done
 
 lemma (in Ring) Rxa_nonzero:"\<lbrakk>a \<in> carrier R; a \<noteq> \<zero>\<rbrakk> \<Longrightarrow> Rxa R a \<noteq> {\<zero>}"
 apply (rule contrapos_pp, simp+)
  apply (frule a_in_principal[of "a"])
  apply simp
 done
 
 lemma (in Ring) ideal_cont_Rxa:"\<lbrakk>ideal R I; a \<in> I\<rbrakk> \<Longrightarrow> Rxa R a \<subseteq> I"
 apply (rule subsetI)
  apply (simp add:Rxa_def, erule bexE, simp)
  apply (simp add:ideal_ring_multiple)
 done
 
 lemma (in Ring) Rxa_mult_smaller:"\<lbrakk> a \<in> carrier R; b \<in> carrier R\<rbrakk> \<Longrightarrow>
                     Rxa R (a \<cdot>\<^sub>r b) \<subseteq> Rxa R b"
 apply (frule rxa_in_Rxa[of b a], assumption,
        frule principal_ideal[of b])
 apply (rule ideal_cont_Rxa[of "R \<diamondsuit>\<^sub>p b" "a \<cdot>\<^sub>r b"], assumption+)
 done
 
 lemma (in Ring) id_ideal_psub_sum:"\<lbrakk>ideal R I; a \<in> carrier R; a \<notin> I\<rbrakk> \<Longrightarrow>
                                              I \<subset> I \<minusplus> Rxa R a"
 apply (cut_tac ring_is_ag)
 apply (simp add:psubset_eq)
 apply (frule principal_ideal)
 apply (rule conjI)
 apply (rule sum_ideals_la1, assumption+)
 apply (rule contrapos_pp) apply simp+
 apply (frule sum_ideals_la2[of "I" "Rxa R a"], assumption+)
 apply (frule a_in_principal[of "a"],
        frule subsetD[of "Rxa R a" "I \<minusplus> Rxa R a" "a"], assumption+)
 apply simp
 done
 
 lemma (in Ring) mul_two_principal_idealsTr:"\<lbrakk>a \<in> carrier R; b \<in> carrier R;
          x \<in> Rxa R a; y \<in> Rxa R b\<rbrakk> \<Longrightarrow> \<exists>r\<in>carrier R. x \<cdot>\<^sub>r y = r \<cdot>\<^sub>r (a \<cdot>\<^sub>r b)"
 apply (simp add:Rxa_def, (erule bexE)+)
 apply simp
 apply (frule_tac x = ra and y = b in ring_tOp_closed, assumption+)
 apply (simp add:ring_tOp_assoc)
 apply (simp add:ring_tOp_assoc[THEN sym, of a _ b])
 apply (simp add:ring_tOp_commute[of a], simp add:ring_tOp_assoc)
 apply (frule_tac x = a and y = b in ring_tOp_closed, assumption+,
        thin_tac "ra \<cdot>\<^sub>r b \<in> carrier R",
        simp add:ring_tOp_assoc[THEN sym, of _ _ "a \<cdot>\<^sub>r b"],
        frule_tac x = r and y = ra in ring_tOp_closed, assumption+)
 apply (simp add:ring_tOp_commute[of b a])
 apply blast
 done
 
 
 primrec sum_pr_ideals::"[('a, 'm) Ring_scheme, nat \<Rightarrow> 'a, nat] \<Rightarrow> 'a set"
 where
   sum_pr0: "sum_pr_ideals R f 0 = Rxa R (f 0)"
 | sum_prn: "sum_pr_ideals R f (Suc n) =
                   (Rxa R (f (Suc n))) \<minusplus>\<^bsub>R\<^esub> (sum_pr_ideals R f n)"
 
 lemma (in Ring) sum_of_prideals0:
       "\<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<longrightarrow> ideal R (sum_pr_ideals R f n)"
 apply (induct_tac n)
 apply (rule allI) apply (rule impI)
  apply simp
  apply (rule Ring.principal_ideal, rule Ring_axioms, assumption)
 (** case n **)
 apply (rule allI, rule impI)
  apply (frule_tac x = f in spec,
         thin_tac "\<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<longrightarrow>
                ideal R (sum_pr_ideals R f n)")
  apply (cut_tac n = n in Nsetn_sub_mem1, simp)
  apply (cut_tac a = "f (Suc n)" in  principal_ideal,
        simp)
  apply (rule_tac ?I1.0 = "Rxa R (f (Suc n))" and
         ?I2.0 = "sum_pr_ideals R f n" in Ring.sum_ideals, rule Ring_axioms, assumption+)
 done
 
 lemma (in Ring) sum_of_prideals:"\<lbrakk>\<forall>l \<le> n. f l \<in> carrier R\<rbrakk> \<Longrightarrow>
                       ideal R (sum_pr_ideals R f n)"
 apply (simp add:sum_of_prideals0)
 done
 
 text \<open>later, we show \<open>sum_pr_ideals\<close> is the least ideal containing
         \<open>{f 0, f 1,\<dots>, f n}\<close>\<close>
 
 lemma (in Ring) sum_of_prideals1:"\<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<longrightarrow>
                                     f ` {i. i \<le> n} \<subseteq> (sum_pr_ideals R f n)"
 apply (induct_tac n)
  apply (rule allI, rule impI)
 apply (simp, simp add:a_in_principal)
 
 apply (rule allI, rule impI)
  apply (frule_tac a = f in forall_spec,
         thin_tac "\<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<longrightarrow>
                f ` {i. i \<le> n} \<subseteq> sum_pr_ideals R f n")
  apply (rule allI, cut_tac n = n in Nset_un, simp)
 
  apply (subst Nset_un)
  apply (cut_tac A = "{i. i \<le> (Suc n)}" and f = f and B = "carrier R" and
         ?A1.0 = "{i. i \<le> n}" and ?A2.0 = "{Suc n}" in im_set_un1,
         simp, rule Nset_un)
  apply (thin_tac "\<forall>f. (\<forall>l\<le>n. f l \<in> carrier R) \<longrightarrow>
                f ` {i. i \<le> n} \<subseteq> sum_pr_ideals R f n",
         simp)
  apply (cut_tac n = n and f = f in sum_of_prideals,
         cut_tac n = n in Nsetn_sub_mem1, simp)
  apply (cut_tac a = "f (Suc n)" in principal_ideal, simp)
  apply (frule_tac ?I1.0 = "Rxa R (f (Suc n))" and ?I2.0 = "sum_pr_ideals R f n"
                  in sum_ideals_la1, assumption+,
         cut_tac a = "f (Suc n)" in a_in_principal, simp,
         frule_tac A = "R \<diamondsuit>\<^sub>p f (Suc n)" and
          B = "R \<diamondsuit>\<^sub>p f (Suc n) \<minusplus> sum_pr_ideals R f n" and c = "f (Suc n)" in
          subsetD, simp+)
   apply (frule_tac ?I1.0 = "Rxa R (f (Suc n))" and
          ?I2.0 = "sum_pr_ideals R f n" in sum_ideals_la2, assumption+)
   apply (rule_tac A = "f ` {j. j \<le> n}" and B = "sum_pr_ideals R f n" and
          C = "Rxa R (f (Suc n)) \<minusplus> sum_pr_ideals R f n" in subset_trans,
          assumption+)
 done
 
 lemma (in Ring) sum_of_prideals2:"\<forall>l \<le> n. f l \<in> carrier R
                \<Longrightarrow>  f ` {i. i \<le> n} \<subseteq> (sum_pr_ideals R f n)"
 apply (simp add:sum_of_prideals1)
 done
 
 lemma (in Ring) sum_of_prideals3:"ideal R I \<Longrightarrow>
       \<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<and> (f ` {i. i \<le> n} \<subseteq> I) \<longrightarrow>
           (sum_pr_ideals R f n \<subseteq> I)"
 apply (induct_tac n)
  apply (rule allI, rule impI, erule conjE)
  apply simp
  apply (rule ideal_cont_Rxa[of I], assumption+)
 
 apply (rule allI, rule impI, erule conjE)
  apply (frule_tac a = f in forall_spec,
         thin_tac "\<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<and> f `{i. i \<le> n} \<subseteq> I \<longrightarrow>
                sum_pr_ideals R f n \<subseteq> I")
  apply (simp add:Nset_un)
  apply (thin_tac "\<forall>f. (\<forall>l \<le> n. f l \<in> carrier R) \<and> f ` {i. i \<le> n} \<subseteq> I \<longrightarrow>
                sum_pr_ideals R f n \<subseteq> I")
  apply (frule_tac x = "Suc n" in spec,
         thin_tac "\<forall>l \<le> (Suc n). f l \<in> carrier R", simp)
    apply (cut_tac a = "Suc n" and A = "{i. i \<le> Suc n}" and
           f = f in mem_in_image2, simp)
    apply (frule_tac A = "f ` {i. i \<le> Suc n}" and B = I and c = "f (Suc n)" in
           subsetD,  assumption+)
  apply (rule_tac A = "Rxa R  (f (Suc n))" and B = "sum_pr_ideals R f n" in
         sum_ideals_cont[of I], assumption)
  apply (rule ideal_cont_Rxa[of I], assumption+)
 done
 
 lemma (in Ring) sum_of_prideals4:"\<lbrakk>ideal R I; \<forall>l \<le> n. f l \<in> carrier R;
        (f ` {i. i \<le> n} \<subseteq> I)\<rbrakk> \<Longrightarrow> sum_pr_ideals R f n \<subseteq> I"
 apply (simp add:sum_of_prideals3)
 done
 
 lemma ker_ideal:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow> ideal A (ker\<^bsub>A,R\<^esub> f)"
 apply (frule Ring.ring_is_ag[of "A"], frule Ring.ring_is_ag[of "R"])
 apply (rule Ring.ideal_condition1, assumption+)
 apply (rule subsetI,
        simp add:ker_def)
 apply (simp add:rHom_def, frule conjunct1)
 apply (frule ker_inc_zero[of "A" "R" "f"], assumption+, blast)
 
 apply (rule ballI)+
  apply (simp add:ker_def, (erule conjE)+)
  apply (simp add:aGroup.ag_pOp_closed)
  apply (simp add:rHom_def, frule conjunct1,
         simp add:aHom_add,
         frule Ring.ring_zero[of "R"],
         simp add:aGroup.ag_l_zero)
 apply (rule ballI)+
  apply (simp add:ker_def, (erule conjE)+)
  apply (simp add:Ring.ring_tOp_closed)
  apply (simp add:rHom_tOp)
  apply (frule_tac a = r in rHom_mem[of "f" "A" "R"], assumption+,
         simp add:Ring.ring_times_x_0)
 done
 
 subsection "Ring of integers"
 
 definition
   Zr :: "int Ring" where
   "Zr = \<lparr> carrier = Zset, pop = \<lambda>n\<in>Zset. \<lambda>m\<in>Zset. (m + n),
     mop = \<lambda>l\<in>Zset. -l, zero = 0, tp = \<lambda>m\<in>Zset. \<lambda>n\<in>Zset. m * n, un = 1\<rparr>"
 
 lemma ring_of_integers:"Ring Zr"
 apply (simp add:Ring_def)
 apply (rule conjI)
  apply (simp add:Zr_def Zset_def)
 apply (rule conjI)
  apply (simp add:Zr_def Zset_def)
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:Zr_def Zset_def)
 apply (rule conjI)
  apply (simp add:Zr_def Zset_def)
 apply (rule conjI,
        rule allI, rule impI, simp add:Zr_def Zset_def)
 apply (rule conjI, simp add:Zr_def Zset_def)
 apply (rule conjI,
        rule allI, rule impI, simp add:Zr_def Zset_def)
 apply (rule conjI)
  apply (simp add:Zr_def Zset_def)
 apply (rule conjI,
        (rule allI, rule impI)+, simp add:Zr_def Zset_def)
 apply (rule conjI,
        (rule allI, rule impI)+, simp add:Zr_def Zset_def)
 apply (rule conjI)
  apply (simp add:Zr_def Zset_def)
 apply (rule conjI,
        (rule allI, rule impI)+, simp add:Zr_def Zset_def)
  apply (simp add: distrib_left)
 apply (rule allI, rule impI)
   apply (simp add:Zr_def Zset_def)
 done
 
 lemma Zr_zero:"\<zero>\<^bsub>Zr\<^esub> = 0"
 by (simp add:Zr_def)
 
 lemma Zr_one:"1\<^sub>r\<^bsub>Zr\<^esub> = 1"
 by (simp add:Zr_def)
 
 lemma Zr_minus:"-\<^sub>a\<^bsub>Zr\<^esub> n = - n"
 by (simp add:Zr_def Zset_def)
 
 lemma Zr_add:"n \<plusminus>\<^bsub>Zr\<^esub> m = n + m"
 by (simp add:Zr_def Zset_def)
 
 lemma Zr_times:"n \<cdot>\<^sub>r\<^bsub>Zr\<^esub> m = n * m"
 by (simp add:Zr_def Zset_def)
 
 definition
   lev :: "int set \<Rightarrow> int" where
   "lev I = Zleast {n. n \<in> I \<and> 0 < n}"
 
 lemma Zr_gen_Zleast:"\<lbrakk>ideal Zr I; I \<noteq> {0::int}\<rbrakk> \<Longrightarrow>
                        Rxa Zr (lev I) = I"
  apply (cut_tac ring_of_integers)
  apply (simp add:lev_def)
  apply (subgoal_tac "{n. n \<in> I \<and> 0 < n} \<noteq> {}")
  apply (subgoal_tac "{n. n \<in> I \<and> 0 < n} \<subseteq> Zset")
  apply (subgoal_tac "LB {n. n \<in> I \<and> 0 < n} 0")
  apply (frule_tac A = "{n. n \<in> I \<and> 0 < n}" and n = 0 in Zleast, assumption+)
  apply (erule conjE)+
  apply (fold lev_def)
 defer
  apply (simp add:LB_def)
  apply (simp add:Zset_def)
  apply (frule Ring.ideal_zero[of "Zr" "I"], assumption+, simp add:Zr_zero)
  apply (frule singleton_sub[of "0" "I"])
  apply (frule sets_not_eq[of "I" "{0}"], assumption+, erule bexE, simp)
  apply (case_tac "0 < a", blast)
  apply (frule Ring.ring_one[of "Zr"])
  apply (frule Ring.ring_is_ag[of "Zr"],
          frule aGroup.ag_mOp_closed[of "Zr" "1\<^sub>r\<^bsub>Zr\<^esub>"], assumption)
  apply (frule_tac x = a in Ring.ideal_ring_multiple[of "Zr" "I" _ "-\<^sub>a\<^bsub>Zr\<^esub> 1\<^sub>r\<^bsub>Zr\<^esub>"],
         assumption+)
  apply (simp add:Zr_one Zr_minus,
         thin_tac "ideal Zr I", thin_tac "Ring Zr", thin_tac "1 \<in> carrier Zr",
         thin_tac "-1 \<in> carrier Zr", thin_tac "aGroup Zr")
  apply (simp add:Zr_def Zset_def)
  apply (subgoal_tac "0 < - a", blast)
  apply arith
  apply (thin_tac "{n \<in> I. 0 < n} \<noteq> {}", thin_tac "{n \<in> I. 0 < n} \<subseteq> Zset",
         thin_tac "LB {n \<in> I. 0 < n} 0")
 
 apply simp
  apply (erule conjE)
  apply (frule Ring.ideal_cont_Rxa[of "Zr" "I" "lev I"], assumption+)
  apply (rule equalityI, assumption,
         thin_tac "Rxa Zr (lev I) \<subseteq> I")
  apply (rule subsetI)
   apply (simp add:Rxa_def, simp add:Zr_times)
  apply (cut_tac t = x and b = "lev I" in mult_div_mod_eq [symmetric])
  apply (subgoal_tac "x = (x div lev I) * (lev I)",
         subgoal_tac "x div lev I \<in> carrier Zr", blast)
  apply (simp add:Zr_def Zset_def)
 apply (subgoal_tac "x mod lev I = 0", simp)
  apply (subst mult.commute, assumption)
  apply (subgoal_tac "x mod lev I \<in> I")
- apply (thin_tac "x = lev I * (x div lev I) + x mod lev I")
- apply (frule_tac a = x in pos_mod_conj[of "lev I"])
+   apply (thin_tac "x = lev I * (x div lev I) + x mod lev I")
+ apply (frule_tac a = x in Divides.pos_mod_conj[of "lev I"])
  apply (rule contrapos_pp, simp+)
  apply (erule conjE)
  apply (frule_tac a = "x mod (lev I)" in forall_spec)
   apply simp apply arith
   apply (frule_tac r = "x div (lev I)" in
           Ring.ideal_ring_multiple1[of "Zr" "I" "lev I"], assumption+,
           simp add:Zr_def Zset_def)
   apply (frule sym, thin_tac "x = lev I * (x div lev I) + x mod lev I")
   apply (rule_tac a = "lev I * (x div lev I)" and b = "x mod lev I " in
          Ring.ideal_ele_sumTr1[of "Zr" "I"], assumption+)
  apply (simp add:Zr_def Zset_def)
  apply (simp add:Zr_def Zset_def)
  apply (subst Zr_add)
  apply simp
  apply (simp add:Zr_times)
 done
 
 lemma Zr_pir:"ideal Zr I \<Longrightarrow> \<exists>n. Rxa Zr n = I" (** principal ideal ring *)
 apply (case_tac "I = {(0::int)}")
  apply (subgoal_tac "Rxa Zr 0 = I") apply blast
  apply (rule equalityI)
  apply (rule subsetI) apply (simp add:Rxa_def)
  apply (simp add:Zr_def Zset_def)
  apply (rule subsetI)
  apply (simp add:Rxa_def Zr_def Zset_def)
 apply (frule Zr_gen_Zleast [of "I"], assumption+)
  apply blast
 done
 
 section "Quotient rings"
 
 lemma (in Ring) mem_set_ar_cos:"\<lbrakk>ideal R I; a \<in> carrier R\<rbrakk> \<Longrightarrow>
                                          a \<uplus>\<^bsub>R\<^esub> I \<in> set_ar_cos R I"
 by (simp add:set_ar_cos_def, blast)
 
 lemma (in Ring) I_in_set_ar_cos:"ideal R I \<Longrightarrow> I \<in> set_ar_cos R I"
 apply (cut_tac ring_is_ag,
        frule ideal_asubg[of "I"],
        rule aGroup.unit_in_set_ar_cos, assumption+)
 done
 
 lemma (in Ring) ar_coset_same1:"\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R;
        b \<plusminus> (-\<^sub>a a) \<in> I \<rbrakk> \<Longrightarrow> a \<uplus>\<^bsub>R\<^esub> I = b \<uplus>\<^bsub>R\<^esub> I"
 apply (cut_tac ring_is_ag)
  apply (frule aGroup.b_ag_group[of "R"])
  apply (simp add:ideal_def asubGroup_def) apply (erule conjE)
  apply (frule aGroup.ag_carrier_carrier[THEN sym, of "R"])
  apply simp
  apply (frule Group.rcs_eq[of "b_ag R" "I" "a" "b"], assumption+)
  apply (frule aGroup.agop_gop [of "R"])
  apply (frule aGroup.agiop_giop[of "R"]) apply simp
  apply (simp add:ar_coset_def rcs_def)
 done
 
 lemma (in Ring) ar_coset_same2:"\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R;
                                   a \<uplus>\<^bsub>R\<^esub> I = b \<uplus>\<^bsub>R\<^esub> I\<rbrakk> \<Longrightarrow>  b \<plusminus> (-\<^sub>a a) \<in> I"
 apply (cut_tac ring_is_ag)
 apply (simp add:ar_coset_def)
  apply (frule aGroup.b_ag_group[of "R"])
  apply (simp add:ideal_def asubGroup_def, frule conjunct1, fold asubGroup_def,
         fold ideal_def, simp add:asubGroup_def)
  apply (subgoal_tac "a \<in> carrier (b_ag R)",
          subgoal_tac "b \<in> carrier (b_ag R)")
  apply (simp add:Group.rcs_eq[THEN sym, of "b_ag R" "I" "a" "b"])
  apply (frule aGroup.agop_gop [of "R"])
  apply (frule aGroup.agiop_giop[of "R"]) apply simp
  apply (simp add:b_ag_def)+
 done
 
 lemma (in Ring) ar_coset_same3:"\<lbrakk>ideal R I; a \<in> carrier R; a \<uplus>\<^bsub>R\<^esub> I = I\<rbrakk> \<Longrightarrow>
                                a\<in>I"
 apply (cut_tac ring_is_ag)
 apply (simp add:ar_coset_def)
 apply (rule Group.rcs_fixed [of "b_ag R" "I" "a" ])
 apply (rule aGroup.b_ag_group, assumption)
 apply (simp add:ideal_def asubGroup_def)
 apply (simp add:b_ag_def)
 apply assumption
 done
 
 lemma (in Ring) ar_coset_same3_1:"\<lbrakk>ideal R I; a \<in> carrier R; a \<notin> I\<rbrakk> \<Longrightarrow>
                                                     a \<uplus>\<^bsub>R\<^esub> I \<noteq> I"
 apply (rule contrapos_pp, simp+)
 apply (simp add:ar_coset_same3)
 done
 
 lemma (in Ring) ar_coset_same4:"\<lbrakk>ideal R I; a \<in> I\<rbrakk> \<Longrightarrow>
                                      a \<uplus>\<^bsub>R\<^esub> I = I"
 apply (cut_tac ring_is_ag)
 apply (frule ideal_subset[of "I" "a"], assumption+)
 apply (simp add:ar_coset_def)
 apply (rule Group.rcs_Unit2 [of "b_ag R" "I""a"])
 apply (rule aGroup.b_ag_group, assumption)
 apply (simp add:ideal_def asubGroup_def)
 apply assumption
 done
 
 lemma (in Ring) ar_coset_same4_1:"\<lbrakk>ideal R I; a \<uplus>\<^bsub>R\<^esub> I \<noteq> I\<rbrakk> \<Longrightarrow> a \<notin> I"
 apply (rule contrapos_pp, simp+)
 apply (simp add:ar_coset_same4)
 done
 
 lemma (in Ring) belong_ar_coset1:"\<lbrakk>ideal R I; a \<in> carrier R; x \<in> carrier R;
                  x \<plusminus> (-\<^sub>a a) \<in> I\<rbrakk> \<Longrightarrow>  x \<in> a \<uplus>\<^bsub>R\<^esub> I"
 apply (frule ar_coset_same1 [of "I" "a" "x"], assumption+)
 apply (subgoal_tac "x \<in> x \<uplus>\<^bsub>R\<^esub> I")
  apply simp
  apply (cut_tac ring_is_ag)
  apply (subgoal_tac "carrier R = carrier (b_ag R)")
  apply (frule aGroup.agop_gop[THEN sym, of "R"])
  apply (frule aGroup.agiop_giop [THEN sym, of "R"])
  apply (simp add:ar_coset_def)
  apply (simp add:ideal_def asubGroup_def)
 
 apply (rule Group.a_in_rcs [of "b_ag R" "I" "x"])
  apply (simp add: aGroup.b_ag_group)
  apply simp
  apply simp
  apply (simp add:b_ag_def)
 done
 
 lemma (in Ring) a_in_ar_coset:"\<lbrakk>ideal R I; a \<in> carrier R\<rbrakk> \<Longrightarrow> a \<in> a \<uplus>\<^bsub>R\<^esub> I"
 apply (rule belong_ar_coset1, assumption+)
 apply (cut_tac ring_is_ag)
 apply (simp add:aGroup.ag_r_inv1)
 apply (simp add:ideal_zero)
 done
 
 lemma (in Ring) ar_coset_subsetD:"\<lbrakk>ideal R I; a \<in> carrier R; x \<in> a \<uplus>\<^bsub>R\<^esub> I \<rbrakk> \<Longrightarrow>
                            x \<in> carrier R"
  apply (subgoal_tac "carrier R = carrier (b_ag R)")
  apply (cut_tac ring_is_ag)
  apply (frule aGroup.agop_gop [THEN sym, of "R"])
  apply (frule aGroup.agiop_giop [THEN sym, of "R"])
  apply (simp add:ar_coset_def)
  apply (simp add:ideal_def asubGroup_def)
 apply (rule Group.rcs_subset_elem[of "b_ag R" "I" "a" "x"])
  apply (simp add:aGroup.b_ag_group)
  apply simp
  apply assumption+
  apply (simp add:b_ag_def)
 done
 
 lemma (in Ring) ar_cos_mem:"\<lbrakk>ideal R I; a \<in> carrier R\<rbrakk> \<Longrightarrow>
                                  a \<uplus>\<^bsub>R\<^esub> I \<in> set_rcs (b_ag R) I"
 apply (cut_tac ring_is_ag)
  apply (simp add:set_rcs_def ar_coset_def)
  apply (frule aGroup.ag_carrier_carrier[THEN sym, of "R"]) apply simp
  apply blast
 done
 
 lemma (in Ring) mem_ar_coset1:"\<lbrakk>ideal R I; a \<in> carrier R; x \<in> a \<uplus>\<^bsub>R\<^esub> I\<rbrakk> \<Longrightarrow>
                                  \<exists>h\<in>I. h \<plusminus> a = x"
  apply (cut_tac ring_is_ag)
  apply (frule aGroup.ag_carrier_carrier[THEN sym, of "R"])
  apply (frule aGroup.agop_gop [THEN sym, of "R"])
  apply (frule aGroup.agiop_giop [THEN sym, of "R"])
  apply (simp add:ar_coset_def)
  apply (simp add:ideal_def asubGroup_def)
 apply (simp add:rcs_def)
 done
 
 lemma (in Ring) ar_coset_mem2:"\<lbrakk>ideal R I; a \<in> carrier R; x \<in> a \<uplus>\<^bsub>R\<^esub> I\<rbrakk> \<Longrightarrow>
                            \<exists>h\<in>I. x = a \<plusminus> h"
 apply (cut_tac ring_is_ag)
 apply (frule mem_ar_coset1 [of "I" "a" "x"], assumption+)
 apply (erule bexE,
        frule_tac h = h in ideal_subset[of "I"], assumption+)
 apply (simp add:aGroup.ag_pOp_commute[of "R" _ "a"],
        frule sym, thin_tac "a \<plusminus> h = x", blast)
 done
 
 lemma (in Ring) belong_ar_coset2:"\<lbrakk>ideal R I; a \<in> carrier R; x \<in> a \<uplus>\<^bsub>R\<^esub> I \<rbrakk>
                                     \<Longrightarrow> x \<plusminus> (-\<^sub>a a) \<in> I"
 apply (cut_tac ring_is_ag)
 apply (frule mem_ar_coset1, assumption+, erule bexE)
  apply (frule sym, thin_tac "h \<plusminus> a = x", simp)
  apply (frule_tac h = h in ideal_subset[of "I"], assumption)
  apply (frule aGroup.ag_mOp_closed[of "R" "a"], assumption)
  apply (subst aGroup.ag_pOp_assoc, assumption+,
         simp add:aGroup.ag_r_inv1,
         simp add:aGroup.ag_r_zero)
 done
 
 lemma (in Ring) ar_c_top: "\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R\<rbrakk>
        \<Longrightarrow> (c_top (b_ag R) I (a \<uplus>\<^bsub>R\<^esub> I) (b \<uplus>\<^bsub>R\<^esub> I)) = (a \<plusminus> b) \<uplus>\<^bsub>R\<^esub> I"
 apply (cut_tac ring_is_ag, frule ideal_asubg,
        frule aGroup.asubg_nsubg[of "R" "I"], assumption,
        frule aGroup.b_ag_group[of "R"])
 apply (simp add:ar_coset_def)
 apply (subst Group.c_top_welldef[THEN sym], assumption+)
 apply (simp add:aGroup.ag_carrier_carrier)+
 apply (simp add:aGroup.agop_gop)
 done
 
 text\<open>Following lemma is not necessary to define a quotient ring. But
 it makes clear that the binary operation2 of the quotient ring is well
 defined.\<close>
 
 lemma (in Ring) quotient_ring_tr1:"\<lbrakk>ideal R I; a1 \<in> carrier R; a2 \<in> carrier R;
                 b1 \<in> carrier R; b2 \<in> carrier R;
                 a1 \<uplus>\<^bsub>R\<^esub> I = a2 \<uplus>\<^bsub>R\<^esub> I; b1 \<uplus>\<^bsub>R\<^esub> I = b2 \<uplus>\<^bsub>R\<^esub> I\<rbrakk> \<Longrightarrow>
                              (a1 \<cdot>\<^sub>r b1) \<uplus>\<^bsub>R\<^esub> I = (a2 \<cdot>\<^sub>r b2) \<uplus>\<^bsub>R\<^esub> I"
 apply (rule ar_coset_same1, assumption+)
  apply (simp add: ring_tOp_closed)+
 apply (frule ar_coset_same2 [of "I" "a1" "a2"], assumption+)
 apply (frule ar_coset_same2 [of "I" "b1" "b2"], assumption+)
 apply (frule ring_distrib4[of "a2" "b2" "a1" "b1"], assumption+)
  apply simp
  apply (rule ideal_pOp_closed[of "I"], assumption)
  apply (simp add:ideal_ring_multiple, simp add:ideal_ring_multiple1)
 done
 
 definition
   rcostOp :: "[_, 'a set] \<Rightarrow> (['a set, 'a set] \<Rightarrow> 'a set)" where
   "rcostOp R I = (\<lambda>X\<in>(set_rcs (b_ag R) I). \<lambda>Y\<in>(set_rcs (b_ag R) I).
                 {z. \<exists> x \<in> X. \<exists> y \<in> Y. \<exists>h\<in>I. (x \<cdot>\<^sub>r\<^bsub>R\<^esub> y) \<plusminus>\<^bsub>R\<^esub> h = z})"
 
 lemma (in Ring) rcostOp:"\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R\<rbrakk> \<Longrightarrow>
                     rcostOp R I (a \<uplus>\<^bsub>R\<^esub> I) (b \<uplus>\<^bsub>R\<^esub> I) = (a \<cdot>\<^sub>r b) \<uplus>\<^bsub>R\<^esub> I"
 apply (cut_tac ring_is_ag)
  apply (frule ar_cos_mem[of "I" "a"], assumption+)
  apply (frule ar_cos_mem[of "I" "b"], assumption+)
 apply (simp add:rcostOp_def)
 apply (rule equalityI)
  apply (rule subsetI, simp) apply (erule bexE)+
  apply (rule belong_ar_coset1, assumption+)
  apply (simp add:ring_tOp_closed)
  apply (frule sym, thin_tac "xa \<cdot>\<^sub>r y \<plusminus> h = x", simp)
  apply (rule aGroup.ag_pOp_closed, assumption)
  apply (frule_tac x = xa in ar_coset_mem2[of "I" "a"], assumption+,
         frule_tac x = y in ar_coset_mem2[of "I" "b"], assumption+,
         (erule bexE)+, simp)
  apply (rule ring_tOp_closed, rule aGroup.ag_pOp_closed, assumption+,
         simp add:ideal_subset)
  apply (rule aGroup.ag_pOp_closed, assumption+, simp add:ideal_subset,
         simp add:ideal_subset)
  apply (frule sym, thin_tac "xa \<cdot>\<^sub>r y \<plusminus> h = x", simp)
  apply (frule_tac x = xa in belong_ar_coset2[of "I" "a"], assumption+,
         frule_tac x = y in belong_ar_coset2[of "I" "b"], assumption+)
  apply (frule_tac x = xa in ar_coset_subsetD[of "I" "a"], assumption+,
         frule_tac x = y in ar_coset_subsetD[of "I" "b"], assumption+)
  apply (subst aGroup.ag_pOp_commute, assumption,
         simp add:ring_tOp_closed, simp add:ideal_subset)
  apply (subst aGroup.ag_pOp_assoc, assumption,
         simp add:ideal_subset, simp add:ring_tOp_closed,
         rule aGroup.ag_mOp_closed, simp add:ring_tOp_closed,
         simp add:ring_tOp_closed)
  apply (rule ideal_pOp_closed, assumption+)
  apply (rule_tac a = xa and a' = y and b = a and b' = b in times_modTr,
         assumption+)
 
  apply (rule subsetI, simp)
  apply (frule_tac x = x in ar_coset_mem2[of "I" "a \<cdot>\<^sub>r b"],
         simp add:ring_tOp_closed, assumption)
  apply (erule bexE) apply simp
  apply (frule a_in_ar_coset[of "I" "a"], assumption+,
         frule a_in_ar_coset[of "I" "b"], assumption+)
  apply blast
 done
 
 definition
   qring ::  "[('a, 'm) Ring_scheme, 'a set] \<Rightarrow> \<lparr> carrier :: 'a set set,
     pop :: ['a  set, 'a set] \<Rightarrow> 'a set, mop :: 'a set \<Rightarrow> 'a set,
     zero :: 'a set, tp :: ['a  set, 'a set] \<Rightarrow> 'a set, un :: 'a set \<rparr>" where
   "qring R I = \<lparr> carrier = set_rcs (b_ag R) I,
     pop = c_top (b_ag R) I,
     mop = c_iop (b_ag R) I,
     zero = I,
     tp = rcostOp R I,
     un = 1\<^sub>r\<^bsub>R\<^esub> \<uplus>\<^bsub>R\<^esub> I\<rparr>"
 
 abbreviation
   QRING  (infixl "'/\<^sub>r" 200) where
   "R /\<^sub>r I == qring R I"
 
 lemma (in Ring) carrier_qring:"ideal R I \<Longrightarrow>
                                carrier (qring R I) = set_rcs (b_ag R) I"
 by (simp add:qring_def)
 
 lemma (in Ring) carrier_qring1:"ideal R I \<Longrightarrow>
                                 carrier (qring R I) = set_ar_cos R I"
 apply (cut_tac ring_is_ag)
 apply (simp add:carrier_qring set_rcs_def set_ar_cos_def)
 apply (simp add:ar_coset_def aGroup.ag_carrier_carrier)
 done
 
 lemma (in Ring) qring_ring:"ideal R I \<Longrightarrow> Ring (qring R I)"
 apply (cut_tac ring_is_ag)
 apply (frule ideal_asubg[of "I"],
         frule aGroup.asubg_nsubg[of "R" "I"], assumption,
         frule aGroup.b_ag_group[of "R"])
 apply (subst Ring_def, simp)
 apply (rule conjI)
  apply (rule Pi_I)+
  apply (simp add:carrier_qring, simp add:set_rcs_def, (erule bexE)+)
  apply (subst qring_def, simp)
  apply (subst Group.c_top_welldef[THEN sym, of "b_ag R" "I"], assumption+)
  apply (blast dest: Group.mult_closed[of "b_ag R"])
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:qring_def)
  apply (simp add:Group.Qg_tassoc[of "b_ag R" "I"])
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:qring_def)
  apply (simp add:set_rcs_def, (erule bexE)+, simp)
  apply (subst Group.c_top_welldef[THEN sym, of "b_ag R" "I"], assumption+)+
  apply (simp add:aGroup.agop_gop)
  apply (simp add:aGroup.ag_carrier_carrier)
  apply (simp add:aGroup.ag_pOp_commute)
 apply (rule conjI)
  apply (simp add:qring_def Group.Qg_iop_closed)
 apply (rule conjI)
  apply (rule allI, rule impI)
  apply (simp add:qring_def)
  apply (simp add:Group.Qg_i[of "b_ag R" "I"])
 apply (rule conjI)
  apply (simp add:qring_def)
  apply (frule Group.nsg_sg[of "b_ag R" "I"], assumption)
  apply (simp add:Group.unit_rcs_in_set_rcs)
 apply (rule conjI)
  apply (rule allI, rule impI)
  apply (simp add:qring_def)
  apply (simp add:Group.Qg_unit[of "b_ag R" "I"])
 apply (rule conjI)
 apply(rule Pi_I)+
  apply (simp add:qring_def aGroup.aqgrp_carrier)
  apply (simp add:set_ar_cos_def, (erule bexE)+, simp add:rcostOp,
         blast dest: ring_tOp_closed)
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:qring_def aGroup.aqgrp_carrier)
  apply (simp add:set_ar_cos_def, (erule bexE)+, simp add:rcostOp)
  apply (frule_tac x = aa and y = ab in ring_tOp_closed, assumption+,
         frule_tac x = ab and y = ac in ring_tOp_closed, assumption+,
         simp add:rcostOp, simp add:ring_tOp_assoc)
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:qring_def aGroup.aqgrp_carrier)
  apply (simp add:set_ar_cos_def, (erule bexE)+, simp add:rcostOp,
         simp add:ring_tOp_commute)
 apply (rule conjI)
  apply (simp add:qring_def aGroup.aqgrp_carrier)
  apply (cut_tac ring_one, simp add:set_ar_cos_def, blast)
 apply (rule conjI)
  apply (rule allI, rule impI)+
  apply (simp add:qring_def aGroup.aqgrp_carrier)
  apply (simp add:set_ar_cos_def, (erule bexE)+, simp)
  apply (simp add:ar_c_top rcostOp)
  apply (frule_tac x = ab and y = ac in aGroup.ag_pOp_closed,
                   assumption+,
         frule_tac x = aa and y = ab in ring_tOp_closed, assumption+ ,
         frule_tac x = aa and y = ac in ring_tOp_closed, assumption+)
  apply (simp add:ar_c_top rcostOp, simp add:ring_distrib1)
 apply (rule allI, rule impI)
   apply (simp add:qring_def aGroup.aqgrp_carrier)
   apply (simp add:set_ar_cos_def, erule bexE, simp)
   apply (cut_tac ring_one)
   apply (simp add:rcostOp, simp add:ring_l_one)
 done
 
 lemma (in Ring) qring_carrier:"ideal R I \<Longrightarrow>
               carrier (qring R I)  = {X. \<exists>a\<in> carrier R. a \<uplus>\<^bsub>R\<^esub> I = X}"
 apply (simp add:carrier_qring1 set_ar_cos_def)
 apply (rule equalityI)
  apply (rule subsetI, simp, erule bexE, frule sym, thin_tac "x = a \<uplus>\<^bsub>R\<^esub> I",
         blast)
 apply (rule subsetI, simp, erule bexE, frule sym, thin_tac "a \<uplus>\<^bsub>R\<^esub> I = x",
        blast)
 done
 
 lemma (in Ring) qring_mem:"\<lbrakk>ideal R I; a \<in> carrier R\<rbrakk> \<Longrightarrow>
                                  a \<uplus>\<^bsub>R\<^esub> I \<in> carrier (qring R I)"
 apply (simp add:qring_carrier)
 apply blast
 done
 
 lemma (in Ring) qring_pOp:"\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R \<rbrakk>
  \<Longrightarrow> pop (qring R I) (a \<uplus>\<^bsub>R\<^esub> I) (b \<uplus>\<^bsub>R\<^esub> I) = (a \<plusminus> b) \<uplus>\<^bsub>R\<^esub> I"
 by (simp add:qring_def, simp add:ar_c_top)
 
 lemma (in Ring) qring_zero:"ideal R I \<Longrightarrow> zero (qring R I) = I"
 apply (simp add:qring_def)
 done
 
 lemma (in Ring) qring_zero_1:"\<lbrakk>a \<in> carrier R; ideal R I; a \<uplus>\<^bsub>R\<^esub> I = I\<rbrakk> \<Longrightarrow>
                                     a \<in> I"
 by (frule a_in_ar_coset [of "I" "a"], assumption+, simp)
 
 lemma (in Ring) Qring_fix1:"\<lbrakk>a \<in> carrier R; ideal R I; a \<in> I\<rbrakk> \<Longrightarrow> a \<uplus>\<^bsub>R\<^esub> I = I"
 apply (cut_tac ring_is_ag, frule aGroup.b_ag_group)
 apply (simp add:ar_coset_def)
 apply (frule ideal_asubg[of "I"], simp add:asubGroup_def)
 apply (simp add:Group.rcs_fixed2[of "b_ag R" "I"])
 done
 
 lemma (in Ring) ar_cos_same:"\<lbrakk>a \<in> carrier R; ideal R I; x \<in> a \<uplus>\<^bsub>R\<^esub> I\<rbrakk> \<Longrightarrow>
                                 x \<uplus>\<^bsub>R\<^esub> I = a \<uplus>\<^bsub>R\<^esub> I"
 apply (cut_tac ring_is_ag)
 apply (rule ar_coset_same1[of "I" "x" "a"], assumption+)
 apply (rule ar_coset_subsetD[of "I"], assumption+)
 apply (frule ar_coset_mem2[of "I" "a" "x"], assumption+,
        erule bexE)
 apply (frule_tac h = h in ideal_subset[of "I"], assumption,
       simp add:aGroup.ag_p_inv)
 apply (frule_tac x = a in aGroup.ag_mOp_closed[of "R"], assumption+,
        frule_tac x = h in aGroup.ag_mOp_closed[of "R"], assumption+)
 apply (simp add:aGroup.ag_pOp_assoc[THEN sym],
        simp add:aGroup.ag_r_inv1 aGroup.ag_l_zero)
 apply (simp add:ideal_inv1_closed)
 done
 
 lemma (in Ring) qring_tOp:"\<lbrakk>ideal R I; a \<in> carrier R; b \<in> carrier R\<rbrakk> \<Longrightarrow>
                 tp (qring R I) (a \<uplus>\<^bsub>R\<^esub> I) (b \<uplus>\<^bsub>R\<^esub> I) = (a \<cdot>\<^sub>r b) \<uplus>\<^bsub>R\<^esub> I"
 by (simp add:qring_def, simp add:rcostOp)
 
 lemma rind_hom_well_def:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R; a \<in> carrier A \<rbrakk> \<Longrightarrow>
                                    f a = (f\<degree>\<^bsub>A,R\<^esub>) (a \<uplus>\<^bsub>A\<^esub> (ker\<^bsub>A,R\<^esub> f))"
 apply (frule ker_ideal[of "A" "R" "f"], assumption+)
 apply (frule Ring.mem_set_ar_cos[of "A" "ker\<^bsub>A,R\<^esub> f" "a"], assumption+)
 apply (simp add:rind_hom_def)
  apply (rule someI2_ex)
  apply (frule Ring.a_in_ar_coset [of "A" "ker\<^bsub>A,R\<^esub> f" "a"], assumption+, blast)
  apply (frule_tac x = x in Ring.ar_coset_mem2[of "A" "ker\<^bsub>A,R\<^esub> f" "a"],
            assumption+, erule bexE, simp,
         frule_tac h = h in Ring.ideal_subset[of "A" "ker\<^bsub>A,R\<^esub> f"], assumption+)
  apply (frule_tac Ring.ring_is_ag[of "A"],
         frule_tac Ring.ring_is_ag[of "R"],
         simp add:rHom_def, frule conjunct1, simp add:aHom_add)
  apply (simp add:ker_def)
  apply (frule aHom_mem[of "A" "R" "f" "a"], assumption+,
         simp add:aGroup.ag_r_zero)
 done
 
 lemma (in Ring) set_r_ar_cos:"ideal R I \<Longrightarrow>
                  set_rcs (b_ag R) I = set_ar_cos R I"
  apply (simp add:set_ar_cos_def set_rcs_def ar_coset_def)
  apply (cut_tac ring_is_ag)
  apply (simp add:aGroup.ag_carrier_carrier)
 done
 
 lemma set_r_ar_cos_ker:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R \<rbrakk> \<Longrightarrow>
                      set_rcs (b_ag A) (ker\<^bsub>A,R\<^esub> f) = set_ar_cos A (ker\<^bsub>A,R\<^esub> f)"
 apply (frule ker_ideal[of "A" "R" "f"], assumption+)
  apply (simp add:Ring.carrier_qring[THEN sym],
         simp add:Ring.carrier_qring1[THEN sym])
 done
 
 lemma ind_hom_rhom:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow>
                                     (f\<degree>\<^bsub>A,R\<^esub>) \<in> rHom (qring A (ker\<^bsub>A,R\<^esub> f)) R"
 apply (simp add:rHom_def [of "qring A (ker\<^bsub>A,R\<^esub> f)" "R"])
 apply (rule conjI)
  apply (simp add:aHom_def)
  apply (rule conjI)
  apply (simp add:qring_def)
 apply (simp add:rind_hom_def extensional_def)
 apply (rule Pi_I)
  apply (frule Ring.ring_is_ag [of "A"], frule Ring.ring_is_ag [of "R"],
         frule aGroup.b_ag_group [of "R"])
  apply (simp add:aGroup.ag_carrier_carrier [THEN sym])
  apply (simp add:set_ar_cos_def)
  apply (rule conjI)
  apply (rule impI)
  apply (erule bexE, simp)
  apply (frule ker_ideal [of "A" "R" "f"], assumption+)
  apply (frule_tac a = a in Ring.a_in_ar_coset [of "A" "ker\<^bsub>A,R\<^esub> f"],
         assumption+)
  apply (rule someI2_ex, blast)
  apply (frule_tac I = "ker\<^bsub>A,R\<^esub> f" and a = a and x = xa in
                    Ring.ar_coset_subsetD[of "A"], assumption+)
  apply (simp add:aGroup.ag_carrier_carrier, simp add:rHom_mem)
  apply (simp add:set_r_ar_cos_ker, simp add:set_ar_cos_def, rule impI, blast)
 apply (rule conjI)
  apply (simp add:qring_def)
  apply (simp add:set_r_ar_cos_ker)
  apply (simp add:rind_hom_def extensional_def)
 apply (rule ballI)+
  apply (simp add:qring_def)
  apply (simp add:set_r_ar_cos_ker)
  apply (simp add:set_ar_cos_def)
  apply ((erule bexE)+, simp)
  apply (frule ker_ideal[of "A" "R" "f"], assumption+)
  apply (simp add:Ring.ar_c_top)
  apply (frule Ring.ring_is_ag[of "A"],
         frule Ring.ring_is_ag[of "R"],
         frule_tac x = aa and y = ab in aGroup.ag_pOp_closed[of "A"],
         assumption+)
  apply (simp add:rind_hom_well_def[THEN sym])
  apply (simp add:rHom_def, frule conjunct1, simp add:aHom_add)
 apply (rule conjI)
  apply (rule ballI)+
  apply (frule ker_ideal[of "A" "R" "f"], assumption+,
         simp add:Ring.carrier_qring1, simp add:set_ar_cos_def,
         (erule bexE)+, simp add:qring_def Ring.rcostOp)
  apply (frule Ring.ring_is_ag[of "A"],
          frule_tac x = a and y = aa in Ring.ring_tOp_closed[of "A"],
          assumption+)
  apply (simp add:rind_hom_well_def[THEN sym], simp add:rHom_tOp)
 
 apply (simp add:qring_def)
  apply (frule Ring.ring_one[of "A"],
         simp add:rind_hom_well_def[THEN sym],
         simp add:rHom_one)
 done
 
 lemma ind_hom_injec:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow>
                               injec\<^bsub>(qring A (ker\<^bsub>A,R\<^esub> f)),R\<^esub> (f\<degree>\<^bsub>A,R\<^esub>)"
 apply (simp add:injec_def)
 apply (frule ind_hom_rhom [of "A" "R" "f"], assumption+)
 apply (frule rHom_aHom[of "f\<degree>\<^bsub>A,R\<^esub>" "A /\<^sub>r (ker\<^bsub>A,R\<^esub> f)" "R"], simp)
  apply (simp add:ker_def[of _ _ "f\<degree>\<^bsub>A,R\<^esub>"])
 apply ((subst qring_def)+, simp)
  apply (simp add:set_r_ar_cos_ker)
 
 apply (frule Ring.ring_is_ag[of "A"],
        frule Ring.ring_is_ag[of "R"],
        frule ker_ideal[of "A" "R" "f"], assumption+)
 apply (rule equalityI)
  apply (rule subsetI)
  apply (simp, erule conjE)
  apply (simp add:set_ar_cos_def, erule bexE, simp)
  apply (simp add:rind_hom_well_def[THEN sym, of "A" "R" "f"],
         thin_tac "x = a \<uplus>\<^bsub>A\<^esub> ker\<^bsub>A,R\<^esub> f")
  apply (rule_tac a = a in Ring.Qring_fix1[of "A" _ "ker\<^bsub>A,R\<^esub> f"], assumption+)
  apply (simp add:ker_def)
 
  apply (rule subsetI, simp)
  apply (simp add:Ring.I_in_set_ar_cos[of "A" "ker\<^bsub>A,R\<^esub> f"])
  apply (frule Ring.ideal_zero[of "A" "ker\<^bsub>A,R\<^esub> f"], assumption+,
         frule Ring.ring_zero[of "A"])
 
  apply (frule Ring.ar_coset_same4[of "A" "ker\<^bsub>A,R\<^esub> f" "\<zero>\<^bsub>A\<^esub>"], assumption+)
  apply (frule rind_hom_well_def[THEN sym, of "A" "R" "f" "\<zero>\<^bsub>A\<^esub>"], assumption+)
  apply simp
 
  apply (rule rHom_0_0, assumption+)
 done
 
 lemma rhom_to_rimg:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow>
                                    f \<in> rHom A (rimg A R f)"
 apply (frule Ring.ring_is_ag[of "A"], frule Ring.ring_is_ag[of "R"])
 apply (subst rHom_def, simp)
 apply (rule conjI)
  apply (subst aHom_def, simp)
  apply (rule conjI)
  apply (simp add:rimg_def)
  apply (rule conjI)
   apply (simp add:rHom_def aHom_def)
   apply ((rule ballI)+, simp add:rimg_def)
  apply (rule aHom_add, assumption+)
   apply (simp add:rHom_aHom, assumption+)
 
  apply (rule conjI)
  apply ((rule ballI)+, simp add:rimg_def, simp add:rHom_tOp)
 
  apply (simp add:rimg_def, simp add:rHom_one)
 done
 
 lemma ker_to_rimg:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R \<rbrakk> \<Longrightarrow>
                          ker\<^bsub>A,R\<^esub> f = ker\<^bsub>A,(rimg A R f)\<^esub> f"
 apply (frule rhom_to_rimg [of "A" "R" "f"], assumption+)
 apply (simp add:ker_def)
 apply (simp add:rimg_def)
 done
 
 lemma indhom_eq:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow> f\<degree>\<^bsub>A,(rimg A R f)\<^esub> = f\<degree>\<^bsub>A,R\<^esub>"
 apply (frule rimg_ring[of "A" "R" "f"], assumption+)
 apply (frule rhom_to_rimg[of "A" "R" "f"], assumption+,
        frule ind_hom_rhom[of "A" "rimg A R f"], assumption+,
        frule ind_hom_rhom[of "A" "R" "f"], assumption+) (** extensional **)
 apply (rule funcset_eq[of "f\<degree>\<^bsub>A,rimg A R f\<^esub> " "carrier (A /\<^sub>r (ker\<^bsub>A,R\<^esub> f))" "f\<degree>\<^bsub>A,R\<^esub>"])
  apply (simp add:ker_to_rimg[THEN sym],
         simp add:rHom_def[of _ "rimg A R f"] aHom_def)
  apply (simp add:rHom_def[of _ "R"] aHom_def)
 
 apply (simp add:ker_to_rimg[THEN sym])
  apply (rule ballI)
  apply (frule ker_ideal[of "A" "R" "f"], assumption+,
         simp add:Ring.carrier_qring1)
  apply (simp add:set_ar_cos_def, erule bexE, simp)
  apply (simp add:rind_hom_well_def[THEN sym])
  apply (frule rind_hom_well_def[THEN sym, of "A" "rimg A R f" "f"],
          assumption+, simp add:ker_to_rimg[THEN sym])
 done
 
 lemma indhom_bijec2_rimg:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R\<rbrakk> \<Longrightarrow>
                     bijec\<^bsub>(qring A (ker\<^bsub>A,R\<^esub> f)),(rimg A R f)\<^esub> (f\<degree>\<^bsub>A,R\<^esub>)"
 apply (frule rimg_ring [of "A" "R" "f"], assumption+)
 apply (frule rhom_to_rimg[of "A" "R" "f"], assumption+)
 apply (frule ind_hom_rhom[of "A" "rimg A R f" "f"], assumption+)
  apply (frule ker_to_rimg[THEN sym, of "A" "R" "f"], assumption+)
  apply (frule indhom_eq[of "A" "R" "f"], assumption+)
 apply simp
  apply (simp add:bijec_def)
  apply (rule conjI)
   apply (simp add:injec_def)
    apply (rule conjI)
    apply (simp add:rHom_def)
    apply (frule ind_hom_injec [of "A" "R" "f"], assumption+)
    apply (simp add:injec_def)
    apply (simp add:ker_def [of _ _ "f\<degree>\<^bsub>A,R\<^esub>"])
    apply (simp add:rimg_def)
 
   apply (simp add:surjec_def)
    apply (rule conjI)
    apply (simp add:rHom_def)
    apply (rule surj_to_test)
    apply (simp add:rHom_def aHom_def)
    apply (rule ballI)
    apply (simp add:rimg_carrier)
    apply (simp add:image_def)
    apply (erule bexE, simp)
    apply (frule_tac a1 = x in rind_hom_well_def[THEN sym, of "A" "R" "f"],
                    assumption+)
    apply (frule ker_ideal[of "A" "R" "f"], assumption+,
         simp add:Ring.carrier_qring1,
         frule_tac a = x in Ring.mem_set_ar_cos[of "A" "ker\<^bsub>A,R\<^esub> f"], assumption+)
  apply blast
 done
 
 lemma surjec_ind_bijec:"\<lbrakk>Ring A; Ring R; f \<in> rHom A R; surjec\<^bsub>A,R\<^esub> f\<rbrakk> \<Longrightarrow>
      bijec\<^bsub>(qring A (ker\<^bsub>A,R\<^esub> f)),R\<^esub> (f\<degree>\<^bsub>A,R\<^esub>)"
 apply (frule ind_hom_rhom[of "A" "R" "f"], assumption+)
 apply (simp add:surjec_def)
 apply (simp add:bijec_def)
  apply (simp add:ind_hom_injec)
 
  apply (simp add:surjec_def)
    apply (simp add:rHom_aHom)
    apply (rule surj_to_test)
    apply (simp add:rHom_def aHom_def)
    apply (rule ballI)
    apply (simp add:surj_to_def, frule sym,
                         thin_tac "f ` carrier A = carrier R", simp,
                         thin_tac "carrier R = f ` carrier A")
    apply (simp add:image_def, erule bexE)
    apply (frule_tac a1 = x in rind_hom_well_def[THEN sym, of "A" "R" "f"],
                    assumption+)
    apply (frule ker_ideal[of "A" "R" "f"], assumption+,
         simp add:Ring.carrier_qring1,
         frule_tac a = x in Ring.mem_set_ar_cos[of "A" "ker\<^bsub>A,R\<^esub> f"], assumption+)
  apply blast
 done
 
 lemma ridmap_ind_bijec:"Ring A \<Longrightarrow>
      bijec\<^bsub>(qring A (ker\<^bsub>A,A\<^esub> (ridmap A))),A\<^esub> ((ridmap A)\<degree>\<^bsub>A,A\<^esub>)"
 apply (frule ridmap_surjec[of "A"])
 apply (rule surjec_ind_bijec [of "A" "A" "ridmap A"], assumption+)
  apply (simp add:rHom_def, simp add:surjec_def)
 
  apply (rule conjI)
   apply (rule ballI)+
   apply (frule_tac x = x and y = y in Ring.ring_tOp_closed[of "A"],
           assumption+, simp add:ridmap_def)
   apply (simp add:ridmap_def Ring.ring_one)
 
  apply assumption
 done
 
 lemma ker_of_idmap:"Ring A \<Longrightarrow> ker\<^bsub>A,A\<^esub> (ridmap A) = {\<zero>\<^bsub>A\<^esub>}"
 apply (simp add:ker_def)
 apply (simp add:ridmap_def)
 apply (rule equalityI)
  apply (rule subsetI) apply (simp add:CollectI)
  apply (rule subsetI) apply (simp add:CollectI)
 
  apply (simp add:Ring.ring_zero)
 done
 
 lemma ring_natural_isom:"Ring A \<Longrightarrow>
          bijec\<^bsub>(qring A {\<zero>\<^bsub>A\<^esub>}),A\<^esub> ((ridmap A)\<degree>\<^bsub>A,A\<^esub>)"
 apply (frule ridmap_ind_bijec)
 apply (simp add: ker_of_idmap)
 done           (** A /\<^sub>r {0\<^sub>A}\<^sub> \<cong> A **)
 
 definition
   pj :: "[('a, 'm) Ring_scheme, 'a set] \<Rightarrow> ('a => 'a set)" where
   "pj R I = (\<lambda>x. Pj (b_ag R) I x)"
 
  (* pj is projection homomorphism *)
 
 lemma pj_Hom:"\<lbrakk>Ring R; ideal R I\<rbrakk> \<Longrightarrow> (pj R I) \<in> rHom R (qring R I)"
 apply (simp add:rHom_def)
 apply (rule conjI)
 apply (simp add:aHom_def)
  apply (rule conjI)
  apply (rule Pi_I)
  apply (simp add:qring_def)
  apply (frule Ring.ring_is_ag)
  apply (simp add:aGroup.ag_carrier_carrier [THEN sym])
  apply (simp add:pj_def Pj_def)
  apply (simp add:set_rcs_def) apply blast
 apply (rule conjI)
  apply (simp add:pj_def Pj_def extensional_def)
  apply (frule Ring.ring_is_ag) apply (simp add:aGroup.ag_carrier_carrier)
 apply (rule ballI)+
  apply (frule Ring.ring_is_ag)
  apply (frule_tac x = a and y = b in aGroup.ag_pOp_closed, assumption+)
  apply (simp add:aGroup.ag_carrier_carrier [THEN sym])
  apply (simp add:pj_def Pj_def)
  apply (simp add:qring_def) apply (frule aGroup.b_ag_group)
  apply (simp add:aGroup.agop_gop [THEN sym])
  apply (subst Group.c_top_welldef[of "b_ag R" "I"], assumption+)
  apply (frule Ring.ideal_asubg[of "R" "I"], assumption+)
  apply (simp add:aGroup.asubg_nsubg)
  apply assumption+
  apply simp
 
 apply (rule conjI)
  apply (rule ballI)+
  apply (simp add: qring_def)
  apply (frule_tac x = x and y = y in Ring.ring_tOp_closed, assumption+)
  apply (frule Ring.ring_is_ag)
  apply (simp add:aGroup.ag_carrier_carrier [THEN sym])
  apply (simp add:pj_def Pj_def)
  apply (simp add:aGroup.ag_carrier_carrier)
 
  apply (frule_tac a1 = x and b1 = y in Ring.rcostOp [THEN sym, of "R" "I"],
                                                              assumption+)
  apply (simp add:ar_coset_def)
 apply (simp add:qring_def)
  apply (frule Ring.ring_one)
  apply (frule Ring.ring_is_ag)
  apply (simp add:aGroup.ag_carrier_carrier [THEN sym])
  apply (simp add:pj_def Pj_def)
  apply (simp add:ar_coset_def)
 done
 
 lemma pj_mem:"\<lbrakk>Ring R; ideal R I; x \<in> carrier R\<rbrakk> \<Longrightarrow> pj R I x = x \<uplus>\<^bsub>R\<^esub> I"
 apply (frule Ring.ring_is_ag)
 apply (simp add:aGroup.ag_carrier_carrier [THEN sym])
 apply (simp add:pj_def Pj_def)
 apply (simp add:ar_coset_def)
 done
 
 lemma pj_zero:"\<lbrakk>Ring R; ideal R I; x \<in> carrier R\<rbrakk> \<Longrightarrow>
                          (pj R I x = \<zero>\<^bsub>(R /\<^sub>r I)\<^esub>) = (x \<in> I)"
 apply (rule iffI)
 apply (simp add:pj_mem Ring.qring_zero,
        simp add:Ring.qring_zero_1[of "R" "x" "I"])
 apply (simp add:pj_mem Ring.qring_zero,
        rule Ring.Qring_fix1, assumption+)
 done
 
 lemma pj_surj_to:"\<lbrakk>Ring R; ideal R J; X \<in> carrier (R /\<^sub>r J)\<rbrakk> \<Longrightarrow>
                    \<exists>r\<in> carrier R. pj R J r = X"
 apply (simp add:qring_def set_rcs_def,
        fold ar_coset_def, simp add:b_ag_def, erule bexE,
        frule_tac x = a in pj_mem[of R J], assumption+, simp)
  apply blast
 done
 
 lemma invim_of_ideal:"\<lbrakk>Ring R; ideal R I; ideal (qring R I) J \<rbrakk> \<Longrightarrow>
   ideal R (rInvim R (qring R I) (pj R I) J)"
 apply (rule Ring.ideal_condition, assumption)
  apply (simp add:rInvim_def) 
 apply (subgoal_tac "\<zero>\<^bsub>R\<^esub> \<in> rInvim R (qring R I) (pj R I) J")
 apply (simp add:nonempty)
 apply (simp add:rInvim_def)
 apply (simp add: Ring.ring_zero)
  apply (frule Ring.ring_is_ag)
  apply (frule pj_Hom [of "R" "I"], assumption+)
  apply (frule Ring.qring_ring [of "R" "I"], assumption+)
  apply (frule rHom_0_0 [of "R" "R /\<^sub>r I" "pj R I"], assumption+)
  apply (simp add:Ring.ideal_zero)
 apply (rule ballI)+
  apply (simp add:rInvim_def) apply (erule conjE)+
  apply (rule conjI)
  apply (frule Ring.ring_is_ag)
  apply (rule aGroup.ag_pOp_closed, assumption+)
  apply (rule aGroup.ag_mOp_closed, assumption+)
  apply (frule pj_Hom [of "R" "I"], assumption+)
  apply (frule Ring.ring_is_ag)
  apply (frule_tac x = y in aGroup.ag_mOp_closed [of "R"], assumption+)
  apply (simp add:rHom_def) apply (erule conjE)+
  apply (subst aHom_add [of "R" "R /\<^sub>r I" "pj R I"], assumption+)
  apply (simp add:Ring.qring_ring Ring.ring_is_ag)
  apply assumption+
 apply (frule Ring.qring_ring [of "R" "I"], assumption+)
  apply (rule Ring.ideal_pOp_closed, assumption+)
  apply (subst aHom_inv_inv[of "R" "R /\<^sub>r I" "pj R I"], assumption+)
  apply (simp add:Ring.ring_is_ag) apply assumption+
  apply (frule_tac x = "pj R I y" in Ring.ideal_inv1_closed [of "R /\<^sub>r I" "J"],
                                               assumption+)
 apply (rule ballI)+
  apply (simp add:rInvim_def) apply (erule conjE)
  apply (simp add:Ring.ring_tOp_closed)
  apply (frule pj_Hom [of "R" "I"], assumption+)
  apply (subst rHom_tOp [of "R" "R /\<^sub>r I" _ _ "pj R I"], assumption+)
  apply (frule Ring.qring_ring[of "R" "I"], assumption+)
  apply (rule Ring.ideal_ring_multiple [of "R /\<^sub>r I" "J"])
  apply (simp add:Ring.qring_ring) apply assumption+
  apply (simp add:rHom_mem)
 done
 
 lemma pj_invim_cont_I:"\<lbrakk>Ring R; ideal R I; ideal (qring R I) J\<rbrakk> \<Longrightarrow>
                          I \<subseteq> (rInvim R (qring R I) (pj R I) J)"
 apply (rule subsetI)
  apply (simp add:rInvim_def)
  apply (frule Ring.ideal_subset [of "R" "I"], assumption+)
  apply simp
  apply (frule  pj_mem [of "R" "I"  _], assumption+)
  apply (simp add:Ring.ar_coset_same4)
 apply (frule  Ring.qring_ring[of "R" "I"], assumption+)
 apply (frule Ring.ideal_zero [of "qring R I" "J"], assumption+)
 
 apply (frule Ring.qring_zero[of "R" "I"], assumption)
  apply simp
 done
 
 lemma pj_invim_mono1:"\<lbrakk>Ring R; ideal R I; ideal (qring R I) J1;
       ideal (qring R I) J2; J1 \<subseteq> J2 \<rbrakk> \<Longrightarrow>
       (rInvim R (qring R I) (pj R I) J1) \<subseteq> (rInvim R (qring R I) (pj R I) J2)"
 apply (rule subsetI)
 apply (simp add:rInvim_def)
 apply (simp add:subsetD)
 done
 
 lemma pj_img_ideal:"\<lbrakk>Ring R; ideal R I; ideal R J; I \<subseteq> J\<rbrakk> \<Longrightarrow>
                                   ideal (qring R I) ((pj R I)`J)"
 apply (rule Ring.ideal_condition [of "qring R I" "(pj R I) `J"])
 apply (simp add:Ring.qring_ring)
 apply (rule subsetI, simp add:image_def)
  apply (erule bexE)
  apply (frule_tac h = xa in Ring.ideal_subset [of "R" "J"], assumption+)
  apply (frule pj_Hom [of "R" "I"], assumption+)
  apply (simp add:rHom_mem)
  apply (frule Ring.ideal_zero [of "R" "J"], assumption+)
  apply (simp add:image_def) apply blast
 apply (rule ballI)+
  apply (simp add:image_def)
  apply (erule bexE)+
  apply (frule pj_Hom [of "R" "I"], assumption+)
  apply (rename_tac x y s t)
  apply (frule_tac h = s in Ring.ideal_subset [of "R" "J"], assumption+)
  apply (frule_tac h = t in Ring.ideal_subset [of "R" "J"], assumption+)
  apply (simp add:rHom_def)   apply (erule conjE)+
  apply (frule Ring.ring_is_ag)
  apply (frule Ring.qring_ring [of "R" "I"], assumption+)
  apply (frule Ring.ring_is_ag [of "R /\<^sub>r I"])
   apply (frule_tac x = t in aGroup.ag_mOp_closed [of "R"], assumption+)
  apply (frule_tac a1 = s and b1 = "-\<^sub>a\<^bsub>R\<^esub> t" in aHom_add [of "R" "R /\<^sub>r I"
   "pj R I", THEN sym], assumption+) apply (simp add:aHom_inv_inv)
  apply (frule_tac x = t in Ring.ideal_inv1_closed [of "R" "J"], assumption+)
  apply (frule_tac x = s and y = "-\<^sub>a\<^bsub>R\<^esub> t" in Ring.ideal_pOp_closed [of "R" "J"],
                                              assumption+)
  apply blast
 apply (rule ballI)+
 apply (simp add:qring_def)
  apply (simp add:Ring.set_r_ar_cos)
  apply (simp add:set_ar_cos_def, erule bexE)
  apply simp
  apply (simp add:image_def)
  apply (erule bexE)
  apply (frule_tac x = xa in pj_mem [of "R" "I"], assumption+)
  apply (simp add:Ring.ideal_subset) apply simp
  apply (subst Ring.rcostOp, assumption+)
     apply (simp add:Ring.ideal_subset)
  apply (frule_tac x = xa and r = a in Ring.ideal_ring_multiple [of "R" "J"],
                                                   assumption+)
  apply (frule_tac h = "a \<cdot>\<^sub>r\<^bsub>R\<^esub> xa" in Ring.ideal_subset [of "R" "J"],
                                                                  assumption+)
  apply (frule_tac x1 = "a \<cdot>\<^sub>r\<^bsub>R\<^esub> xa" in pj_mem [THEN sym, of "R" "I"],
                                                                  assumption+)
  apply simp
  apply blast
 done
 
 lemma npQring:"\<lbrakk>Ring R; ideal R I; a \<in> carrier R\<rbrakk> \<Longrightarrow>
       npow (qring R I) (a \<uplus>\<^bsub>R\<^esub> I) n = (npow R a n) \<uplus>\<^bsub>R\<^esub> I"
 apply (induct_tac n)
 apply (simp add:qring_def)
 
 apply (simp add:qring_def)
 apply (rule Ring.rcostOp, assumption+)
 apply (rule Ring.npClose, assumption+)
 done
 
 section "Primary ideals, Prime ideals"
 
 definition
   maximal_set :: "['a set set, 'a set] \<Rightarrow> bool" where
   "maximal_set S mx \<longleftrightarrow> mx \<in> S \<and> (\<forall>s\<in>S. mx \<subseteq> s \<longrightarrow> s = mx)"
 
 definition
   nilpotent :: "[_, 'a] \<Rightarrow> bool" where
   "nilpotent R a \<longleftrightarrow> (\<exists>(n::nat). a^\<^bsup>R n\<^esup> = \<zero>\<^bsub>R\<^esub>)"
 
 definition
  zero_divisor :: "[_, 'a] \<Rightarrow> bool" where
   "zero_divisor R a \<longleftrightarrow> (\<exists>x\<in> carrier R. x \<noteq> \<zero>\<^bsub>R\<^esub> \<and> x \<cdot>\<^sub>r\<^bsub>R\<^esub> a = \<zero>\<^bsub>R\<^esub>)"
 
 definition
   primary_ideal :: "[_, 'a set] \<Rightarrow> bool" where
   "primary_ideal R q \<longleftrightarrow> ideal R q \<and> (1\<^sub>r\<^bsub>R\<^esub>) \<notin> q \<and>
     (\<forall>x\<in> carrier R. \<forall>y\<in> carrier R.
       x \<cdot>\<^sub>r\<^bsub>R\<^esub> y \<in> q  \<longrightarrow> (\<exists>n. (npow R x n) \<in> q \<or> y \<in> q))"
 
 definition
   prime_ideal :: "[_, 'a set] \<Rightarrow> bool" where
   "prime_ideal R p \<longleftrightarrow> ideal R p \<and> (1\<^sub>r\<^bsub>R\<^esub>) \<notin> p \<and> (\<forall>x\<in> carrier R. \<forall>y\<in> carrier R.
     (x \<cdot>\<^sub>r\<^bsub>R\<^esub> y \<in> p \<longrightarrow> x \<in> p \<or> y \<in> p))"
 
 definition
   maximal_ideal :: "[_, 'a set] \<Rightarrow> bool" where
   "maximal_ideal R mx \<longleftrightarrow> ideal R mx \<and> 1\<^sub>r\<^bsub>R\<^esub> \<notin> mx \<and>
         {J. (ideal R J \<and> mx \<subseteq> J)} = {mx, carrier R}"
 
 lemma (in Ring) maximal_ideal_ideal:"\<lbrakk>maximal_ideal R mx\<rbrakk> \<Longrightarrow> ideal R mx"
 by (simp add:maximal_ideal_def)
 
 lemma (in Ring) maximal_ideal_proper:"maximal_ideal R mx \<Longrightarrow> 1\<^sub>r \<notin> mx"
 by (simp add:maximal_ideal_def)
 
 lemma (in Ring) prime_ideal_ideal:"prime_ideal R I \<Longrightarrow> ideal R I"
 by (simp add:prime_ideal_def)
 
 lemma (in Ring) prime_ideal_proper:"prime_ideal R I \<Longrightarrow> I \<noteq> carrier R"
 apply (simp add:prime_ideal_def, (erule conjE)+)
 apply (simp add:proper_ideal)
 done
 
 lemma (in Ring) prime_ideal_proper1:"prime_ideal R p \<Longrightarrow> 1\<^sub>r \<notin> p"
 by (simp add:prime_ideal_def)
 
 lemma (in Ring) primary_ideal_ideal:"primary_ideal R q \<Longrightarrow> ideal R q"
 by (simp add:primary_ideal_def)
 
 lemma (in Ring)  primary_ideal_proper1:"primary_ideal R q \<Longrightarrow> 1\<^sub>r \<notin> q"
 by (simp add:primary_ideal_def)
 
 lemma (in Ring) prime_elems_mult_not:"\<lbrakk>prime_ideal R P; x \<in> carrier R;
                 y \<in> carrier R; x \<notin> P; y \<notin> P \<rbrakk> \<Longrightarrow> x \<cdot>\<^sub>r y \<notin> P"
 apply (simp add:prime_ideal_def, (erule conjE)+)
 apply (rule contrapos_pp, simp+)
  apply (frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>x\<in>carrier R. \<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> P \<longrightarrow> x \<in> P \<or> y \<in> P",
         frule_tac x = y in bspec, assumption,
         thin_tac "\<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> P \<longrightarrow> x \<in> P \<or> y \<in> P", simp)
 done
 
 
 lemma (in Ring) prime_is_primary:"prime_ideal R p \<Longrightarrow> primary_ideal R p"
 apply (unfold primary_ideal_def)
 apply (rule conjI, simp add:prime_ideal_def)
 apply (rule conjI, simp add:prime_ideal_def)
 apply ((rule ballI)+, rule impI)
 apply (simp add:prime_ideal_def, (erule conjE)+)
  apply (frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>x\<in>carrier R. \<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> p \<longrightarrow> x \<in> p \<or> y \<in> p",
         frule_tac x = y in bspec, assumption,
         thin_tac "\<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> p \<longrightarrow> x \<in> p \<or> y \<in> p", simp)
  apply (erule disjE)
  apply (frule_tac t = x in np_1[THEN sym])
  apply (frule_tac a = x and A = p and b = "x^\<^bsup>R (Suc 0)\<^esup>" in eq_elem_in,
                                                assumption)
  apply blast
 apply simp
 done
 
 lemma (in Ring) maximal_prime_Tr0:"\<lbrakk>maximal_ideal R mx; x \<in> carrier R; x \<notin> mx\<rbrakk>
               \<Longrightarrow>  mx \<minusplus> (Rxa R x) = carrier R"
 apply (frule principal_ideal [of "x"])
  apply (frule maximal_ideal_ideal[of "mx"])
  apply (frule sum_ideals [of "mx" "Rxa R x"], assumption)
  apply (frule sum_ideals_la1 [of "mx" "Rxa R x"], assumption)
  apply (simp add:maximal_ideal_def)
  apply (erule conjE)+
  apply (subgoal_tac "mx \<minusplus> (Rxa R x) \<in> {J. ideal R J \<and> mx \<subseteq> J}")
  apply simp
 apply (frule sum_ideals_la2 [of "mx" "Rxa R x"], assumption+)
   apply (frule a_in_principal [of "x"])
   apply (frule subsetD [of "Rxa R x" "mx \<minusplus> (Rxa R x)" "x"], assumption+)
  apply (thin_tac "{J. ideal R J \<and> mx \<subseteq> J} = {mx, carrier R}")
 apply (erule disjE)
  apply simp apply simp
 
 apply (thin_tac "{J. ideal R J \<and> mx \<subseteq> J} = {mx, carrier R}")
  apply simp
 done
 
 lemma (in Ring) maximal_prime:"maximal_ideal R mx \<Longrightarrow> prime_ideal R mx"
 apply (cut_tac ring_is_ag)
 apply (simp add:prime_ideal_def)
 apply (simp add:maximal_ideal_ideal)
 apply (simp add:maximal_ideal_proper)
 
 apply ((rule ballI)+, rule impI)
 apply (rule contrapos_pp, simp+, erule conjE)
 apply (frule_tac x = x in maximal_prime_Tr0[of "mx"], assumption+,
        frule_tac x = y in maximal_prime_Tr0[of "mx"], assumption+,
        frule maximal_ideal_ideal[of mx],
        frule ideal_subset1[of mx],
        frule_tac a = x in principal_ideal,
        frule_tac a = y in principal_ideal,
        frule_tac I = "R \<diamondsuit>\<^sub>p x" in ideal_subset1,
        frule_tac I = "R \<diamondsuit>\<^sub>p y" in ideal_subset1)
 apply (simp add:aGroup.set_sum)
  apply (cut_tac ring_one)
  apply (frule sym,
         thin_tac "{xa. \<exists>h\<in>mx. \<exists>k\<in>R \<diamondsuit>\<^sub>p x. xa = h \<plusminus> k} = carrier R",
         frule sym,
         thin_tac "{x. \<exists>h\<in>mx. \<exists>k\<in>R \<diamondsuit>\<^sub>p y. x = h \<plusminus> k} = carrier R")
  apply (frule_tac a = "1\<^sub>r" and B = "{xa. \<exists>i\<in>mx. \<exists>j\<in>(Rxa R x). xa = i \<plusminus> j}" in
                          eq_set_inc[of _ "carrier R"], assumption,
         frule_tac a = "1\<^sub>r" and B = "{xa. \<exists>i\<in>mx. \<exists>j\<in>(Rxa R y). xa = i \<plusminus> j}" in
                          eq_set_inc[of _ "carrier R"], assumption,
         thin_tac "carrier R = {xa. \<exists>i\<in>mx. \<exists>j\<in>(Rxa R x). xa = i \<plusminus> j}",
         thin_tac "carrier R = {x. \<exists>i\<in>mx. \<exists>j\<in>(Rxa R y). x = i \<plusminus> j}")
  apply (drule CollectD, (erule bexE)+,
         frule sym, thin_tac "1\<^sub>r = i \<plusminus> j")
  apply (drule CollectD, (erule bexE)+, rotate_tac -1,
         frule sym, thin_tac "1\<^sub>r = ia \<plusminus> ja")
  apply (frule_tac h = i in ideal_subset[of mx], assumption,
         frule_tac h = ia in ideal_subset[of mx], assumption,
         frule_tac h = j in ideal_subset, assumption+,
         frule_tac h = ja in ideal_subset, assumption+)
  apply (cut_tac ring_one)
  apply (frule_tac x = i and y = j in aGroup.ag_pOp_closed, assumption+)
  apply (frule_tac x = "i \<plusminus> j" and y = ia and z = ja in ring_distrib1,
            assumption+)
  apply (frule_tac x = ia and y = i and z = j in ring_distrib2, assumption+,
         frule_tac x = ja and y = i and z = j in ring_distrib2, assumption+,
         simp)
  apply (thin_tac "1\<^sub>r \<cdot>\<^sub>r ia = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia",
         thin_tac "1\<^sub>r \<cdot>\<^sub>r ja = i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja",
         simp add:ring_l_one[of "1\<^sub>r"])
  apply (frule_tac x = ia and r = i in ideal_ring_multiple[of mx], assumption+,
         frule_tac x = i and r = j in ideal_ring_multiple1[of mx], assumption+,
         frule_tac x = i and r = ja in ideal_ring_multiple1[of mx], assumption+,
         frule_tac r = j and x = ia in ideal_ring_multiple[of mx], assumption+)
  apply (subgoal_tac "j \<cdot>\<^sub>r ja \<in> mx")
  apply (frule_tac x = "i \<cdot>\<^sub>r ia" and y = "j \<cdot>\<^sub>r ia" in ideal_pOp_closed[of mx],
                    assumption+) apply (
         frule_tac x = "i \<cdot>\<^sub>r ja" and y = "j \<cdot>\<^sub>r ja" in ideal_pOp_closed[of mx],
            assumption+)
  apply (frule_tac x = "i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia" and y = "i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja" in
           ideal_pOp_closed[of mx], assumption+,
         thin_tac "i \<plusminus> j = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja)",
         thin_tac "ia \<plusminus> ja = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja)")
  apply (frule sym, thin_tac "1\<^sub>r = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja)",
        simp)
  apply (simp add:maximal_ideal_def)
 
 apply (thin_tac "i \<plusminus> j = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja)",
        thin_tac "ia \<plusminus> ja = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja)",
        thin_tac "i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja) \<in> carrier R",
        thin_tac "1\<^sub>r = i \<cdot>\<^sub>r ia \<plusminus> j \<cdot>\<^sub>r ia \<plusminus> (i \<cdot>\<^sub>r ja \<plusminus> j \<cdot>\<^sub>r ja)",
        thin_tac "i \<cdot>\<^sub>r j \<in> mx", thin_tac "i \<cdot>\<^sub>r ja \<in> mx",
        thin_tac "R \<diamondsuit>\<^sub>p y \<subseteq> carrier R", thin_tac "R \<diamondsuit>\<^sub>p x \<subseteq> carrier R",
        thin_tac "ideal R (R \<diamondsuit>\<^sub>p y)", thin_tac "ideal R (R \<diamondsuit>\<^sub>p x)")
  apply (simp add:Rxa_def, (erule bexE)+, simp)
  apply (simp add:ring_tOp_assoc)
  apply (simp add:ring_tOp_assoc[THEN sym])
  apply (frule_tac x = x and y = ra in ring_tOp_commute, assumption+, simp)
  apply (simp add:ring_tOp_assoc,
         frule_tac x = x and y = y in ring_tOp_closed, assumption+)
  apply (frule_tac x1 = r and y1 = ra and z1 = "x \<cdot>\<^sub>r y" in
         ring_tOp_assoc[THEN sym], assumption+, simp)
  apply (frule_tac x = r and y = ra in ring_tOp_closed, assumption+,
         rule ideal_ring_multiple[of mx], assumption+)
 done
 
 lemma (in Ring) chains_un:"\<lbrakk>c \<in> chains {I. ideal R I \<and> I \<subset> carrier R}; c \<noteq> {}\<rbrakk>
        \<Longrightarrow> ideal R (\<Union>c)"
 apply (rule ideal_condition1)
 apply (rule Union_least[of "c" "carrier R"])
  apply (simp add:chains_def,
        erule conjE,
        frule_tac c = X in subsetD[of "c" "{I. ideal R I \<and> I \<subset> carrier R}"],
        assumption+, simp add:psubset_imp_subset)
  apply (simp add:chains_def,
        erule conjE)
  apply (frule nonempty_ex[of "c"], erule exE)
  apply (frule_tac c = x in subsetD[of "c" "{I. ideal R I \<and> I \<subset> carrier R}"],
         assumption+, simp, erule conjE)
  apply (frule_tac I = x in ideal_zero, blast)
 
 apply (rule ballI)+
  apply simp
  apply (erule bexE)+
 apply (simp add: chains_def chain_subset_def)
  apply (frule conjunct1) apply (frule conjunct2)
  apply (thin_tac "c \<subseteq> {I. ideal R I \<and> I \<subset> carrier R} \<and> (\<forall>x\<in>c. \<forall>y\<in>c. x \<subseteq> y \<or> y \<subseteq> x)")
  apply (frule_tac x = X in bspec, assumption,
         thin_tac "\<forall>x\<in>c. \<forall>y\<in>c. x \<subseteq> y \<or> y \<subseteq> x",
         frule_tac x = Xa in bspec, assumption,
         thin_tac "\<forall>y\<in>c. X \<subseteq> y \<or> y \<subseteq> X")
  apply (frule_tac c = Xa in subsetD[of "c" "{I. ideal R I \<and> I \<subset> carrier R}"],
           assumption+,
         frule_tac c = X in subsetD[of "c" "{I. ideal R I \<and> I \<subset> carrier R}"],
           assumption+, simp)
  apply (erule conjE)+
  apply (erule disjE,
         frule_tac c = x and A = X and B = Xa in subsetD, assumption+,
         frule_tac x = x and y = y and I = Xa in ideal_pOp_closed, assumption+,
         blast)
  apply (frule_tac c = y and A = Xa and B = X in subsetD, assumption+,
         frule_tac x = x and y = y and I = X in ideal_pOp_closed, assumption+,
         blast)
 
 apply (rule ballI)+
  apply (simp, erule bexE)
  apply (simp add:chains_def, erule conjE)
  apply (frule_tac c = X in subsetD[of "c" "{I. ideal R I \<and> I \<subset> carrier R}"],
         assumption+, simp, erule conjE)
  apply (frule_tac I = X and x = x and r = r in ideal_ring_multiple,
         assumption+, blast)
 done
 
 lemma (in Ring) zeroring_no_maximal:"zeroring R \<Longrightarrow> \<not> (\<exists>I. maximal_ideal R I)"
 apply (rule contrapos_pp, simp+, erule exE,
        frule_tac mx = x in maximal_ideal_ideal)
 apply (frule_tac I = x in ideal_zero)
 apply (simp add:zeroring_def, erule conjE,
        cut_tac ring_one, simp, thin_tac "carrier R = {\<zero>}",
         frule sym, thin_tac "1\<^sub>r = \<zero>", simp, thin_tac "\<zero> = 1\<^sub>r")
 apply (simp add:maximal_ideal_def)
 done
 
 lemma (in Ring) id_maximal_Exist:"\<not>(zeroring R) \<Longrightarrow> \<exists>I. maximal_ideal R I"
  apply (cut_tac A="{ I. ideal R I \<and> I \<subset> carrier R }" in Zorn_Lemma2)
  apply (rule ballI)
 
  apply (case_tac "C={}", simp)
    apply (cut_tac zero_ideal)
    apply (simp add:zeroring_def)
     apply (cut_tac Ring, simp,
            frule not_sym, thin_tac "carrier R \<noteq> {\<zero>}")
    apply (cut_tac ring_zero,
          frule singleton_sub[of "\<zero>" "carrier R"],
          thin_tac "\<zero> \<in> carrier R")
    apply (subst psubset_eq)
    apply blast
  apply (subgoal_tac "\<Union>C \<in> {I. ideal R I \<and> I \<subset> carrier R}")
  apply (subgoal_tac "\<forall>x\<in>C. x \<subseteq> (\<Union>C)", blast)
   apply (rule ballI, rule Union_upper, assumption)
   apply (simp add:chains_un)
   apply (cut_tac A = C in Union_least[of _ "carrier R"])
   apply (simp add:chains_def, erule conjE,
         frule_tac c = X and A = C in
           subsetD[of _ "{I. ideal R I \<and> I \<subset> carrier R}"], assumption+,
           simp add:ideal_subset1, simp add:psubset_eq)
   apply (rule contrapos_pp, simp+,
          cut_tac ring_one, frule sym, thin_tac "\<Union>C = carrier R")
   apply (frule_tac B = "\<Union>C" in eq_set_inc[of "1\<^sub>r" "carrier R"], assumption,
          thin_tac "carrier R = \<Union>C")
   apply (simp, erule bexE)
   apply (simp add:chains_def, erule conjE)
   apply (frule_tac c = X and A = C in
          subsetD[of _ "{I. ideal R I \<and> I \<subseteq> carrier R \<and> I \<noteq> carrier R}"],
          assumption+, simp, (erule conjE)+)
   apply (frule_tac I = X in ideal_inc_one, assumption+, simp)
 
  apply (erule bexE, simp, erule conjE)
  apply (subgoal_tac "maximal_ideal R M", blast)
  apply (simp add:maximal_ideal_def)
 
 apply (rule conjI, rule contrapos_pp, simp+,
        frule_tac  I = M in ideal_inc_one, assumption+, simp)
 
 apply (rule equalityI)
  apply (rule subsetI, simp)
  apply (erule conjE)
  apply (frule_tac x = x in spec,
         thin_tac "\<forall>x. ideal R x \<and> x \<subset> carrier R \<longrightarrow> M \<subseteq> x \<longrightarrow> x = M", simp)
  apply (frule_tac I = x in ideal_subset1, simp add:psubset_eq)
  apply (case_tac "x = carrier R", simp)
  apply simp
 
  apply (rule subsetI, simp)
  apply (erule disjE)
  apply simp
  apply (simp add:whole_ideal)
 done
 
 definition
   ideal_Int :: "[_, 'a set set] \<Rightarrow> 'a set" where
   "ideal_Int R S == \<Inter> S"
 
 lemma (in Ring) ideal_Int_ideal:"\<lbrakk>S \<subseteq> {I. ideal R I}; S\<noteq>{}\<rbrakk> \<Longrightarrow>
                                                  ideal R (\<Inter> S)"
 apply (rule ideal_condition1)
  apply (frule nonempty_ex[of "S"], erule exE)
  apply (frule_tac c = x in subsetD[of "S" "{I. ideal R I}"], assumption+)
  apply (simp, frule_tac I = x in ideal_subset1)
  apply (frule_tac B = x and A = S in Inter_lower)
  apply (rule_tac A = "\<Inter>S" and B = x and C = "carrier R" in subset_trans,
          assumption+)
 
  apply (cut_tac ideal_zero_forall, blast)
  apply (simp, rule ballI)
 
 apply (rule ballI)+
  apply simp
  apply (frule_tac x = X in bspec, assumption,
         thin_tac "\<forall>X\<in>S. x \<in> X",
         frule_tac x = X in bspec, assumption,
         thin_tac "\<forall>X\<in>S. y \<in> X")
 apply (frule_tac c = X in subsetD[of "S" "{I. ideal R I}"], assumption+,
        simp, rule_tac x = x and y = y in ideal_pOp_closed, assumption+)
 
 apply (rule ballI)+
  apply (simp, rule ballI)
  apply (frule_tac x = X in bspec, assumption,
         thin_tac "\<forall>X\<in>S. x \<in> X",
         frule_tac c = X in subsetD[of "S" "{I. ideal R I}"], assumption+,
         simp add:ideal_ring_multiple)
 done
 
 lemma (in Ring) sum_prideals_Int:"\<lbrakk>\<forall>l \<le> n. f l \<in> carrier R;
                 S = {I. ideal R I \<and> f ` {i. i \<le> n} \<subseteq> I}\<rbrakk> \<Longrightarrow>
                                   (sum_pr_ideals R f n) = \<Inter> S"
 apply (rule equalityI)
 apply (subgoal_tac "\<forall>X\<in>S. sum_pr_ideals R f n \<subseteq> X")
 apply blast
  apply (rule ballI)
  apply (simp, erule conjE)
  apply (rule_tac I = X and n = n and f = f in sum_of_prideals4, assumption+)
 apply (subgoal_tac "(sum_pr_ideals R f n) \<in> S")
  apply blast
  apply (simp add:CollectI)
  apply (simp add: sum_of_prideals2)
  apply (simp add: sum_of_prideals)
 done
 
 text\<open>This proves that \<open>(sum_pr_ideals R f n)\<close> is the smallest ideal containing
  \<open>f ` (Nset n)\<close>\<close>
 
 primrec ideal_n_prod::"[('a, 'm) Ring_scheme, nat,  nat \<Rightarrow> 'a set] \<Rightarrow> 'a set"
 where
   ideal_n_prod0: "ideal_n_prod R 0 J = J 0"
 | ideal_n_prodSn: "ideal_n_prod R (Suc n) J =
                           (ideal_n_prod R n J) \<diamondsuit>\<^sub>r\<^bsub>R\<^esub> (J (Suc n))"
 
 abbreviation
   IDNPROD  ("(3i\<Pi>\<^bsub>_,_\<^esub> _)" [98,98,99]98) where
   "i\<Pi>\<^bsub>R,n\<^esub> J == ideal_n_prod R n J"
 
 primrec
   ideal_pow :: "['a set, ('a, 'more) Ring_scheme, nat] \<Rightarrow> 'a set"
                ("(3_/ \<^bsup>\<diamondsuit>_ _\<^esup>)" [120,120,121]120)
 where
   ip0:  "I \<^bsup>\<diamondsuit>R 0\<^esup> = carrier R"
 | ipSuc:  "I \<^bsup>\<diamondsuit>R (Suc n)\<^esup> = I \<diamondsuit>\<^sub>r\<^bsub>R\<^esub> (I \<^bsup>\<diamondsuit>R n\<^esup>)"
 
 lemma (in Ring) prod_mem_prod_ideals:"\<lbrakk>ideal R I; ideal R J; i \<in> I; j \<in> J\<rbrakk> \<Longrightarrow>
                             i \<cdot>\<^sub>r j \<in> (I \<diamondsuit>\<^sub>r J)"
 apply (simp add:ideal_prod_def)
 apply (rule allI, rule impI, erule conjE, rename_tac X)
  apply (rule_tac A = "{x. \<exists>i\<in>I. \<exists>j\<in>J. x = Ring.tp R i j}" and B = X and c = "i \<cdot>\<^sub>r j" in  subsetD, assumption)
  apply simp apply blast
 done
 
 lemma (in Ring) ideal_prod_ideal:"\<lbrakk>ideal R I; ideal R J \<rbrakk> \<Longrightarrow>
                                         ideal R (I \<diamondsuit>\<^sub>r J)"
 apply (rule ideal_condition1)
  apply (simp add:ideal_prod_def)
  apply (rule subsetI, simp)
  apply (cut_tac whole_ideal)
  apply (frule_tac x = "carrier R" in spec,
         thin_tac "\<forall>xa. ideal R xa \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j} \<subseteq> xa \<longrightarrow>
                                                                    x \<in> xa")
  apply (subgoal_tac "{x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j} \<subseteq> carrier R", simp)
      apply (thin_tac "ideal R (carrier R) \<and>
             {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j} \<subseteq> carrier R \<longrightarrow> x \<in> carrier R")
  apply (rule subsetI, simp, (erule bexE)+, simp)
  apply (frule_tac h = i in ideal_subset[of "I"], assumption+,
         frule_tac h = j in ideal_subset[of "J"], assumption+)
  apply (rule_tac x = i and y = j in ring_tOp_closed, assumption+)
 
  apply (frule ideal_zero[of "I"],
         frule ideal_zero[of "J"],
         subgoal_tac "\<zero> \<in> I \<diamondsuit>\<^sub>r\<^bsub> R\<^esub> J", blast)
  apply (simp add:ideal_prod_def)
  apply (rule allI, rule impI, erule conjE)
  apply (rule ideal_zero, assumption)
 
  apply (rule ballI)+
  apply (simp add:ideal_prod_def)
  apply (rule allI, rule impI)
  apply (frule_tac x = xa in spec,
         thin_tac "\<forall>xa. ideal R xa \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j} \<subseteq> xa
                                             \<longrightarrow> x \<in> xa",
         frule_tac x = xa in spec,
         thin_tac "\<forall>x. ideal R x \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j} \<subseteq> x \<longrightarrow> y \<in> x",
         erule conjE, simp,
         rule_tac x = x and y = y in ideal_pOp_closed, assumption+)
  apply (rule ballI)+
         apply (simp add:ideal_prod_def)
         apply (rule allI, rule impI, erule conjE)
         apply (frule_tac x = xa in spec,
                thin_tac "\<forall>xa. ideal R xa \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j}
                             \<subseteq> xa \<longrightarrow> x \<in> xa", simp)
  apply (simp add:ideal_ring_multiple)
 done
 
 lemma (in Ring) ideal_prod_commute:"\<lbrakk>ideal R I; ideal R J\<rbrakk> \<Longrightarrow>
                                               I \<diamondsuit>\<^sub>r J = J \<diamondsuit>\<^sub>r I"
 apply (simp add:ideal_prod_def)
 apply (subgoal_tac "{K. ideal R K \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j}
        \<subseteq> K}  = {K. ideal R K \<and> {x. \<exists>i\<in>J. \<exists>j\<in>I. x = i \<cdot>\<^sub>r j} \<subseteq> K}")
 apply simp
 apply (rule equalityI)
 apply (rule subsetI, rename_tac X, simp, erule conjE)
  apply (rule subsetI, simp)
  apply ((erule bexE)+)
  apply (subgoal_tac "x \<in> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j}",
         rule_tac c = x and A = "{x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j}" and B = X in
         subsetD, assumption+,
         frule_tac h = i in ideal_subset[of "J"], assumption,
         frule_tac h = j in ideal_subset[of "I"], assumption,
         frule_tac x = i and y = j in ring_tOp_commute, assumption+, simp,
         blast)
  apply (rule subsetI, simp, erule conjE,
         rule subsetI, simp,
         (erule bexE)+,
         subgoal_tac "xa \<in> {x. \<exists>i\<in>J. \<exists>j\<in>I. x = i \<cdot>\<^sub>r j}",
         rule_tac c = xa and A = "{x. \<exists>i\<in>J. \<exists>j\<in>I. x = i \<cdot>\<^sub>r j}" and B = x in
                  subsetD, assumption+,
         frule_tac h = i in ideal_subset[of "I"], assumption,
         frule_tac h = j in ideal_subset[of "J"], assumption,
         frule_tac x = i and y = j in ring_tOp_commute, assumption+, simp,
         blast)
 done
 
 lemma (in Ring) ideal_prod_subTr:"\<lbrakk>ideal R I; ideal R J; ideal R C;
                         \<forall>i\<in>I. \<forall>j\<in>J. i \<cdot>\<^sub>r j \<in> C\<rbrakk> \<Longrightarrow> I \<diamondsuit>\<^sub>r J \<subseteq> C"
 apply (simp add:ideal_prod_def)
  apply (rule_tac B = C and
         A = "{L. ideal R L \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x = i \<cdot>\<^sub>r j} \<subseteq> L}" in
         Inter_lower)
  apply simp
  apply (rule subsetI, simp, (erule bexE)+, simp)
 done
 
 lemma (in Ring) n_prod_idealTr:
      "(\<forall>k \<le> n. ideal R (J k)) \<longrightarrow> ideal R (ideal_n_prod R n J)"
 apply (induct_tac n)
 apply (rule impI)
 apply simp
 
 apply (rule impI)
 apply (simp only:ideal_n_prodSn)
  apply (cut_tac n = n in Nsetn_sub_mem1, simp)
  apply (rule ideal_prod_ideal, assumption)
  apply simp
 done
 
 lemma (in Ring) n_prod_ideal:"\<lbrakk>\<forall>k \<le> n. ideal R (J k)\<rbrakk>
                                \<Longrightarrow>  ideal R (ideal_n_prod R n J)"
 apply (simp add:n_prod_idealTr)
 done
 
 lemma (in Ring) ideal_prod_la1:"\<lbrakk>ideal R I; ideal R J\<rbrakk> \<Longrightarrow> (I \<diamondsuit>\<^sub>r J) \<subseteq> I"
  apply (simp add:ideal_prod_def)
  apply (rule subsetI)
  apply (simp add:CollectI)
  apply (subgoal_tac "{x. \<exists>i\<in>I. \<exists>j\<in>J. x =  i \<cdot>\<^sub>r j} \<subseteq> I")
  apply blast
 apply (thin_tac "\<forall>xa. ideal R xa \<and> {x. \<exists>i\<in>I. \<exists>j\<in>J. x =  i \<cdot>\<^sub>r j} \<subseteq> xa
                                                               \<longrightarrow> x \<in> xa")
  apply (rule subsetI, simp add:CollectI,
         (erule bexE)+, frule_tac h = j in ideal_subset[of "J"], assumption+)
  apply (simp add:ideal_ring_multiple1)
 done
 
 lemma (in Ring) ideal_prod_el1:"\<lbrakk>ideal R I; ideal R J; a \<in> (I \<diamondsuit>\<^sub>r J)\<rbrakk> \<Longrightarrow>
                            a \<in> I"
 apply (frule ideal_prod_la1 [of "I" "J"], assumption+)
 apply (rule subsetD, assumption+)
 done
 
 lemma (in Ring) ideal_prod_la2:"\<lbrakk>ideal R I; ideal R J \<rbrakk> \<Longrightarrow> (I \<diamondsuit>\<^sub>r J) \<subseteq> J"
  apply (subst ideal_prod_commute, assumption+,
         rule ideal_prod_la1[of "J" "I"], assumption+)
 done
 
 lemma (in Ring) ideal_prod_sub_Int:"\<lbrakk>ideal R I; ideal R J \<rbrakk> \<Longrightarrow>
                      (I \<diamondsuit>\<^sub>r J) \<subseteq> I \<inter> J"
 by (simp add:ideal_prod_la1 ideal_prod_la2)
 
 lemma (in Ring) ideal_prod_el2:"\<lbrakk>ideal R I; ideal R J; a \<in> (I \<diamondsuit>\<^sub>r J)\<rbrakk> \<Longrightarrow>
                                  a \<in> J"
 by (frule ideal_prod_la2 [of "I" "J"], assumption+,
        rule subsetD, assumption+)
 
 text\<open>\<open>i\<Pi>\<^bsub>R,n\<^esub> J\<close> is the product of ideals\<close>
 lemma (in Ring) ele_n_prodTr0:"\<lbrakk>\<forall>k \<le> (Suc n). ideal R (J k);
              a \<in> i\<Pi>\<^bsub>R,(Suc n)\<^esub> J \<rbrakk> \<Longrightarrow> a \<in> (i\<Pi>\<^bsub>R,n\<^esub> J) \<and> a \<in> (J (Suc n))"
 apply (simp add:Nset_Suc[of n])
  apply (cut_tac n_prod_ideal[of n J])
 apply (rule conjI)
  apply (rule ideal_prod_el1 [of "i\<Pi>\<^bsub>R,n\<^esub> J" "J (Suc n)"], assumption, simp+)
  apply (rule ideal_prod_el2[of "i\<Pi>\<^bsub>R,n\<^esub> J" "J (Suc n)"], assumption+, simp+)
 done
 
 lemma (in Ring) ele_n_prodTr1:
       "(\<forall>k \<le> n. ideal R (J k)) \<and> a \<in> ideal_n_prod R n J \<longrightarrow>
                                              (\<forall>k \<le> n. a \<in> (J k))"
 apply (induct_tac n)
 (** n = 0 **)
  apply simp
 (** n **)
  apply (rule impI)
  apply (rule allI, rule impI)
  apply (cut_tac n = n in Nsetn_sub_mem1, simp)
  apply (erule conjE)
  apply (frule_tac n = n in ele_n_prodTr0[of _ J a])
  apply simp
 
  apply (erule conjE,
         thin_tac "\<forall>k\<le>Suc n. ideal R (J k)")
  apply simp
  apply (case_tac "k = Suc n", simp)
  apply (frule_tac m = k and n = "Suc n" in noteq_le_less, assumption+,
         thin_tac "k \<le> Suc n")
  apply (frule_tac x = k and n = "Suc n" in less_le_diff, simp)
 done
 
 lemma (in Ring) ele_n_prod:"\<lbrakk>\<forall>k \<le> n. ideal R (J k);
                        a \<in> ideal_n_prod R n J \<rbrakk> \<Longrightarrow>  \<forall>k \<le> n. a \<in> (J k)"
 by (simp add: ele_n_prodTr1 [of "n" "J" "a"])
 
 lemma (in Ring) idealprod_whole_l:"ideal R I \<Longrightarrow> (carrier R) \<diamondsuit>\<^sub>r\<^bsub>R\<^esub> I = I"
 apply (rule equalityI)
  apply (rule subsetI)
  apply (simp add:ideal_prod_def)
  apply (subgoal_tac "{x. \<exists>i\<in>carrier R. \<exists>j\<in>I. x = i \<cdot>\<^sub>r j} \<subseteq> I")
  apply blast
  apply (thin_tac "\<forall>xa. ideal R xa \<and> {x. \<exists>i\<in>carrier R. \<exists>j\<in>I.
                        x = i \<cdot>\<^sub>r j} \<subseteq> xa \<longrightarrow> x \<in> xa")
  apply (rule subsetI)
  apply simp
  apply ((erule bexE)+, simp)
  apply (thin_tac "xa = i \<cdot>\<^sub>r j", simp add:ideal_ring_multiple)
 apply (rule subsetI)
  apply (simp add:ideal_prod_def)
  apply (rule allI, rule impI) apply (erule conjE)
  apply (rename_tac xa X)
  apply (cut_tac ring_one)
  apply (frule_tac h = xa in ideal_subset[of "I"], assumption,
         frule_tac x = xa in ring_l_one)
  apply (subgoal_tac "1\<^sub>r \<cdot>\<^sub>r xa \<in> {x. \<exists>i\<in>carrier R. \<exists>j\<in>I. x = i \<cdot>\<^sub>r j}")
  apply (rule_tac c = xa and A = "{x. \<exists>i\<in>carrier R. \<exists>j\<in>I. x = i \<cdot>\<^sub>r j}" and
          B = X in subsetD, assumption+)
  apply simp
  apply simp
  apply (frule sym, thin_tac "1\<^sub>r \<cdot>\<^sub>r xa = xa", blast)
 done
 
 lemma (in Ring) idealprod_whole_r:"ideal R I \<Longrightarrow> I \<diamondsuit>\<^sub>r (carrier R) = I"
 by (cut_tac whole_ideal,
        simp add:ideal_prod_commute[of "I" "carrier R"],
        simp add:idealprod_whole_l)
 
 lemma (in Ring) idealpow_1_self:"ideal R I \<Longrightarrow> I \<^bsup>\<diamondsuit>R (Suc 0)\<^esup> = I"
 apply simp
 apply (simp add:idealprod_whole_r)
 done
 
 lemma (in Ring) ideal_pow_ideal:"ideal R I \<Longrightarrow> ideal R (I \<^bsup>\<diamondsuit>R n\<^esup>)"
 apply (induct_tac n)
 apply (simp add:whole_ideal)
 apply simp
 apply (simp add:ideal_prod_ideal)
 done
 
 lemma (in Ring) ideal_prod_prime:"\<lbrakk>ideal R I; ideal R J; prime_ideal R P;
                           I \<diamondsuit>\<^sub>r J \<subseteq> P \<rbrakk> \<Longrightarrow> I \<subseteq> P \<or> J \<subseteq> P"
 apply (rule contrapos_pp, simp+)
 apply (erule conjE, simp add:subset_eq, (erule bexE)+)
 apply (frule_tac i = x and j = xa in prod_mem_prod_ideals[of "I" "J"],
           assumption+)
  apply (frule_tac x = "x \<cdot>\<^sub>r xa" in bspec, assumption,
         thin_tac "\<forall>x\<in>I \<diamondsuit>\<^sub>r\<^bsub> R\<^esub> J. x \<in> P")
  apply (simp add: prime_ideal_def, (erule conjE)+)
  apply (frule_tac h = x in ideal_subset, assumption,
         frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>x\<in>carrier R. \<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> P \<longrightarrow> x \<in> P \<or> y \<in> P",
         frule_tac h = xa in ideal_subset, assumption,
         frule_tac x = xa in bspec, assumption,
         thin_tac "\<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> P \<longrightarrow> x \<in> P \<or> y \<in> P",
         simp)
 done
 
 lemma (in Ring) ideal_n_prod_primeTr:"prime_ideal R P \<Longrightarrow>
        (\<forall>k \<le> n. ideal R (J k)) \<longrightarrow> (ideal_n_prod R n J \<subseteq> P) \<longrightarrow>
                                                (\<exists>i \<le> n. (J i) \<subseteq> P)"
 apply (induct_tac n)
 apply simp
 
 apply (rule impI)
  apply (rule impI, simp)
  apply (cut_tac I = "i\<Pi>\<^bsub>R,n\<^esub> J" and J = "J (Suc n)" in
                       ideal_prod_prime[of _ _ "P"],
         rule_tac n = n and J = J in n_prod_ideal,
          rule allI, simp+)
  apply (erule disjE, simp)
  apply (cut_tac n = n in Nsetn_sub_mem1,
         blast)
  apply blast
 done
 
 lemma (in Ring) ideal_n_prod_prime:"\<lbrakk>prime_ideal R P;
             \<forall>k \<le> n. ideal R (J k); ideal_n_prod R n J \<subseteq> P\<rbrakk> \<Longrightarrow>
                                             \<exists>i \<le> n. (J i) \<subseteq> P"
 apply (simp add:ideal_n_prod_primeTr)
 done
 
 definition
   ppa::"[_, nat \<Rightarrow> 'a set, 'a set, nat] \<Rightarrow> (nat \<Rightarrow> 'a)" where
   "ppa R P A i l = (SOME x. x \<in> A \<and> x \<in> (P (skip i l)) \<and> x \<notin> P i)"
      (** Note (ppa R P A) is used to prove prime_ideal_cont1,
          some element x of A such that x \<in> P j for (i \<noteq> j) and x \<notin> P i **)
 
 lemma (in Ring) prod_primeTr:"\<lbrakk>prime_ideal R P; ideal R A; \<not> A \<subseteq> P;
                 ideal R B; \<not> B \<subseteq> P \<rbrakk> \<Longrightarrow> \<exists>x. x \<in> A \<and> x \<in> B \<and> x \<notin> P"
 apply (simp add:subset_eq)
  apply (erule bexE)+
 apply (subgoal_tac "x \<cdot>\<^sub>r xa \<in> A \<and> x \<cdot>\<^sub>r xa \<in> B \<and> x \<cdot>\<^sub>r xa \<notin> P")
  apply blast
  apply (rule conjI)
  apply (rule ideal_ring_multiple1, assumption+)
   apply (simp add:ideal_subset)
  apply (rule conjI)
   apply (rule ideal_ring_multiple, assumption+)
   apply (simp add:ideal_subset)
 
  apply (rule contrapos_pp, simp+)
 apply (simp add:prime_ideal_def, (erule conjE)+)
  apply (frule_tac h = x in ideal_subset[of "A"], assumption+,
         frule_tac h = xa in ideal_subset[of "B"], assumption+,
         frule_tac x = x in bspec, assumption,
         thin_tac "\<forall>x\<in>carrier R. \<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> P \<longrightarrow> x \<in> P \<or> y \<in> P",
         frule_tac x = xa in bspec, assumption,
         thin_tac "\<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> P \<longrightarrow> x \<in> P \<or> y \<in> P")
   apply simp
 done
 
 lemma (in Ring) prod_primeTr1:"\<lbrakk>\<forall>k \<le> (Suc n). prime_ideal R (P k);
        ideal R A; \<forall>l \<le> (Suc n). \<not> (A \<subseteq> P l);
        \<forall>k \<le> (Suc n). \<forall>l \<le> (Suc n). k = l \<or> \<not> (P k) \<subseteq> (P l); i \<le> (Suc n)\<rbrakk> \<Longrightarrow>
        \<forall>l \<le> n. ppa R P A i l \<in> A \<and>
                   ppa R P A i l \<in> (P (skip i l)) \<and> ppa R P A i l \<notin> (P i)"
 apply (rule allI, rule impI)
 apply (cut_tac i = i and l = l in skip_il_neq_i)
 apply (rotate_tac 2)
       apply (frule_tac x = i in spec,
              thin_tac "\<forall>l \<le> (Suc n). \<not> A \<subseteq> P l", simp)
 
       apply (cut_tac l = l in skip_mem[of _ "n" "i"], simp,
              frule_tac x = "skip i l" in spec,
              thin_tac "\<forall>k \<le> (Suc n). \<forall>l \<le> (Suc n). k = l \<or> \<not> P k \<subseteq> P l",
              simp)
      apply (rotate_tac -1,
             frule_tac x = i in spec,
             thin_tac "\<forall>la \<le> (Suc n). skip i l = la \<or> \<not> P (skip i l) \<subseteq> P la",
             simp)
 apply (cut_tac P = "P i" and A = A and B = "P (skip i l)" in prod_primeTr,
        simp, assumption+)
  apply (frule_tac x = "skip i l" in spec,
         thin_tac "\<forall>k\<le>Suc n. prime_ideal R (P k)", simp,
         rule prime_ideal_ideal, assumption+)
  apply (simp add:ppa_def)
  apply (rule someI2_ex, assumption+)
 done
 
 lemma (in Ring) ppa_mem:"\<lbrakk>\<forall>k \<le> (Suc n). prime_ideal R (P k); ideal R A;
       \<forall>l \<le> (Suc n). \<not> (A \<subseteq> P l);
       \<forall>k \<le> (Suc n). \<forall>l \<le> (Suc n). k = l \<or> \<not> (P k) \<subseteq> (P l);
       i  \<le> (Suc n); l \<le> n\<rbrakk> \<Longrightarrow> ppa R P A i l \<in> carrier R"
 apply (frule_tac prod_primeTr1[of n P A], assumption+)
  apply (rotate_tac -1, frule_tac x = l in spec,
         thin_tac "\<forall>l\<le>n. ppa R P A i l \<in> A \<and>
            ppa R P A i l \<in> P (skip i l) \<and> ppa R P A i l \<notin> P i", simp)
  apply (simp add:ideal_subset)
 done
 
 lemma (in Ring) nsum_memrTr:"(\<forall>i \<le> n. f i \<in> carrier R) \<longrightarrow>
                              (\<forall>l \<le> n. nsum R f l \<in> carrier R)"
 apply (cut_tac ring_is_ag)
 apply (induct_tac n)
 (** n = 0 **)
  apply (rule impI, rule allI, rule impI)
  apply simp
 (** n **)
 apply (rule impI)
  apply (rule allI, rule impI)
 
  apply (rule aGroup.nsum_mem, assumption)
  apply (rule allI, simp)
 done
 
 lemma (in Ring) nsum_memr:"\<forall>i \<le> n. f i \<in> carrier R \<Longrightarrow>
                           \<forall>l \<le> n. nsum R f l \<in> carrier R"
 by (simp add:nsum_memrTr)
 
 lemma (in Ring) nsum_ideal_incTr:"ideal R A \<Longrightarrow>
                (\<forall>i \<le> n. f i \<in> A) \<longrightarrow>  nsum R f n \<in> A"
  apply (induct_tac n)
  apply (rule impI)
   apply simp
 (** n **)
 apply (rule impI)
 apply simp
 apply (rule ideal_pOp_closed, assumption+)
  apply simp
 done
 
 lemma (in Ring) nsum_ideal_inc:"\<lbrakk>ideal R A; \<forall>i \<le> n. f i \<in> A\<rbrakk> \<Longrightarrow>
                     nsum R f n \<in> A"
 by (simp add:nsum_ideal_incTr)
 
 lemma (in Ring) nsum_ideal_excTr:"ideal R A \<Longrightarrow>
       (\<forall>i \<le> n. f i \<in> carrier R) \<and> (\<exists>j \<le> n. (\<forall>l \<in> {i. i \<le> n} -{j}. f l \<in> A)
        \<and> (f j \<notin> A)) \<longrightarrow> nsum R f n \<notin> A"
 apply (induct_tac n)
 (** n = 0 **)
  apply simp
 (** n **)
  apply (rule impI)
  apply (erule conjE)+
 apply (erule exE)
 apply (case_tac "j = Suc n", simp) apply (
        thin_tac "(\<exists>j\<le>n. f j \<notin> A) \<longrightarrow> \<Sigma>\<^sub>e R f n \<notin> A")
  apply (erule conjE)
  apply (cut_tac n = n and f = f in nsum_ideal_inc[of A], assumption,
         rule allI, simp)
  apply (rule contrapos_pp, simp+)
  apply (frule_tac a = "\<Sigma>\<^sub>e R f n" and b = "f (Suc n)" in
                    ideal_ele_sumTr1[of A],
         simp add:ideal_subset, simp, assumption+, simp)
 
 apply (erule conjE,
        frule_tac m = j and n = "Suc n" in noteq_le_less, assumption,
        frule_tac x = j and n = "Suc n" in less_le_diff,
        thin_tac "j \<le> Suc n", thin_tac "j < Suc n", simp,
        cut_tac n = n in Nsetn_sub_mem1, simp)
 apply (erule conjE,
        frule_tac x = "Suc n" in bspec, simp)
 apply (rule contrapos_pp, simp+)
  apply (frule_tac a = "\<Sigma>\<^sub>e R f n" and b = "f (Suc n)" in
                    ideal_ele_sumTr2[of A])
  apply (cut_tac ring_is_ag,
         rule_tac n = n in aGroup.nsum_mem[of R _ f], assumption+,
         rule allI, simp, simp, assumption+, simp)
  apply (subgoal_tac "\<exists>j\<le>n. (\<forall>l\<in>{i. i \<le> n} - {j}. f l \<in> A) \<and> f j \<notin> A",
         simp,
         thin_tac "(\<exists>j\<le>n. (\<forall>l\<in>{i. i \<le> n} - {j}. f l \<in> A) \<and> f j \<notin> A)
                      \<longrightarrow> \<Sigma>\<^sub>e R f n \<notin> A")
  apply (subgoal_tac "\<forall>l\<in>{i. i \<le> n} - {j}. f l \<in> A", blast,
         thin_tac "\<Sigma>\<^sub>e R f n \<plusminus> f (Suc n) \<in> A",
         thin_tac "\<Sigma>\<^sub>e R f n \<in> A")
  apply (rule ballI)
  apply (frule_tac x = l in bspec, simp, assumption)
 done
 
 lemma (in Ring) nsum_ideal_exc:"\<lbrakk>ideal R A; \<forall>i \<le> n. f i \<in> carrier R;
       \<exists>j \<le> n. (\<forall>l\<in>{i. i \<le> n} -{j}. f l \<in> A) \<and> (f j \<notin> A) \<rbrakk> \<Longrightarrow> nsum R f n \<notin> A"
 by (simp add:nsum_ideal_excTr)
 
 lemma (in Ring) nprod_memTr:"(\<forall>i \<le> n. f i \<in> carrier R) \<longrightarrow>
                              (\<forall>l. l \<le> n \<longrightarrow>  nprod R f l \<in> carrier R)"
 apply (induct_tac n)
 apply (rule impI, rule allI, rule impI, simp)
 
 apply (rule impI, rule allI, rule impI)
 apply (case_tac "l \<le> n")
  apply (cut_tac n = n in Nset_Suc, blast)
  apply (cut_tac m = l and n = "Suc n" in Nat.le_antisym, assumption)
  apply (simp add: not_less)
  apply simp
  apply (rule ring_tOp_closed, simp)
  apply (cut_tac n = n in Nset_Suc, blast)
 done
 
 lemma (in Ring) nprod_mem:"\<lbrakk>\<forall>i \<le> n. f i \<in> carrier R; l \<le> n\<rbrakk> \<Longrightarrow>
                               nprod R f l \<in> carrier R"
 by (simp add:nprod_memTr)
 
 lemma (in Ring) ideal_nprod_incTr:"ideal R A \<Longrightarrow>
                 (\<forall>i \<le> n. f i \<in> carrier R) \<and>
                              (\<exists>l \<le> n. f l \<in> A) \<longrightarrow> nprod R f n \<in> A"
 apply (induct_tac n)
 (** n = 0 **)
 apply simp
 (** n **)
 apply (rule impI)
  apply (erule conjE)+
 apply simp
  apply (erule exE)
  apply (case_tac "l = Suc n", simp)
  apply (rule_tac x = "f (Suc n)" and r = "nprod R f n" in
                  ideal_ring_multiple[of "A"], assumption+)
  apply (rule_tac n = "Suc n" and f = f and l = n in nprod_mem,
                  assumption+, simp)
  apply (erule conjE)
  apply (frule_tac m = l and n = "Suc n" in noteq_le_less, assumption,
        frule_tac x = l and n = "Suc n" in less_le_diff,
        thin_tac "l \<le> Suc n", thin_tac "l < Suc n", simp)
 apply (rule_tac x = "nprod R f n" and r = "f (Suc n)" in
                       ideal_ring_multiple1[of "A"], assumption+)
  apply blast
  apply simp
 done
 
 lemma (in Ring) ideal_nprod_inc:"\<lbrakk>ideal R A; \<forall>i \<le> n. f i \<in> carrier R;
                 \<exists>l \<le> n. f l \<in> A\<rbrakk> \<Longrightarrow> nprod R f n \<in> A"
 by (simp add:ideal_nprod_incTr)
 
 lemma (in Ring) nprod_excTr:"prime_ideal R P \<Longrightarrow>
           (\<forall>i \<le> n. f i \<in> carrier R) \<and> (\<forall>l \<le> n. f l \<notin> P) \<longrightarrow>
                                                      nprod R f n \<notin> P"
 apply (induct_tac n)
 (** n = 0 **)
  apply simp  (* n = 0 done *)
 (** n **)
 apply (rule impI)
 apply (erule conjE)+
  apply simp
   apply (rule_tac y = "f (Suc n)" and x = "nprod R f n" in
           prime_elems_mult_not[of "P"], assumption,
          rule_tac n = n in  nprod_mem, rule allI, simp+)
 done
 
 lemma (in Ring) prime_nprod_exc:"\<lbrakk>prime_ideal R P; \<forall>i \<le> n. f i \<in> carrier R;
                 \<forall>l \<le> n. f l \<notin> P\<rbrakk> \<Longrightarrow> nprod R f n \<notin> P"
 by (simp add:nprod_excTr)
 
 definition
   nilrad :: "_ \<Rightarrow> 'a set" where
   "nilrad R = {x. x \<in> carrier R \<and> nilpotent R x}"
 
 lemma (in Ring) id_nilrad_ideal:"ideal R (nilrad R)"
 apply (cut_tac ring_is_ag)
 apply (rule ideal_condition1[of "nilrad R"])
  apply (rule subsetI) apply (simp add:nilrad_def CollectI)
  apply (simp add:nilrad_def)
  apply (cut_tac ring_zero)
  apply (subgoal_tac "nilpotent R \<zero>")
  apply blast
  apply (simp add:nilpotent_def)
  apply (frule np_1[of "\<zero>"], blast)
 
  apply (rule ballI)+
 apply (simp add:nilrad_def nilpotent_def, (erule conjE)+)
  apply (erule exE)+
  apply (simp add:aGroup.ag_pOp_closed[of "R"])
  apply (frule_tac x = x and y = y and m = n and n = na in npAdd,
         assumption+, blast)
 
  apply (rule ballI)+
  apply (simp add:nilrad_def nilpotent_def, erule conjE, erule exE)
  apply (simp add:ring_tOp_closed,
         frule_tac x = r and y = x and n = n in npMul, assumption+,
            simp,
         frule_tac x = r and n = n in npClose)
         apply (simp add:ring_times_x_0, blast)
 done
 
 definition
   rad_ideal :: "[_, 'a set ] \<Rightarrow> 'a set" where
   "rad_ideal R I = {a. a \<in> carrier R \<and> nilpotent (qring R I) ((pj R I) a)}"
 
 lemma (in Ring) id_rad_invim:"ideal R I \<Longrightarrow>
        rad_ideal R I = (rInvim R (qring R I) (pj R I ) (nilrad (qring R I)))"
 apply (cut_tac ring_is_ag)
 apply (rule equalityI)
  apply (rule subsetI)
  apply (simp add:rad_ideal_def)
  apply (erule conjE)+
  apply (simp add:rInvim_def)
  apply (simp add:nilrad_def)
  apply (subst pj_mem, rule Ring_axioms)
  apply assumption+
  apply (simp add:qring_def ar_coset_def set_rcs_def)
  apply (simp add:aGroup.ag_carrier_carrier)
  apply blast
 
 apply (rule subsetI)
  apply (simp add:rInvim_def nilrad_def)
 apply (simp add: rad_ideal_def)
 done
 
 lemma (in Ring) id_rad_ideal:"ideal R I \<Longrightarrow> ideal R (rad_ideal R I)"
 (* thm invim_of_ideal *)
 apply (subst id_rad_invim [of "I"], assumption)
 apply (rule invim_of_ideal, rule Ring_axioms, assumption)
 apply (rule Ring.id_nilrad_ideal)
 apply (simp add:qring_ring)
 done
 
 lemma (in Ring) id_rad_cont_I:"ideal R I \<Longrightarrow> I \<subseteq> (rad_ideal R I)"
 apply (simp add:rad_ideal_def)
 apply (rule subsetI, simp,
        simp add:ideal_subset)
 apply (simp add:nilpotent_def)
 apply (subst pj_mem, rule Ring_axioms, assumption+,
        simp add:ideal_subset) (* thm npQring *)
 
  apply (frule_tac h = x in ideal_subset[of "I"], assumption,
         frule_tac a = x in npQring[OF Ring, of "I" _ "Suc 0"], assumption,
         simp only:np_1, simp only:Qring_fix1,
         subst qring_zero[of "I"], assumption)
  apply blast
 done
 
 lemma (in Ring) id_rad_set:"ideal R I \<Longrightarrow>
        rad_ideal R I = {x. x \<in> carrier R \<and> (\<exists>n. npow R x n \<in> I)}"
 apply (simp add:rad_ideal_def)
 apply (rule equalityI)
  apply (rule subsetI)
  apply (simp add:nilpotent_def, erule conjE, erule exE)
  apply (simp add: pj_mem[OF Ring], simp add:npQring[OF Ring])
 apply ( simp add:qring_zero)
  apply (frule_tac x = x and n = n in npClose)
  apply (frule_tac a = "x^\<^bsup>R n\<^esup>" in ar_coset_same3[of "I"], assumption+,
         blast)
 apply (rule subsetI, simp, erule conjE, erule exE)
  apply (simp add:nilpotent_def)
  apply (simp add: pj_mem[OF Ring], simp add:npQring[OF Ring],
                                             simp add:qring_zero)
  apply (frule_tac a = "x^\<^bsup>R n\<^esup>" in ar_coset_same4[of "I"], assumption+)
  apply blast
 done
 
 lemma (in Ring) rad_primary_prime:"primary_ideal R q \<Longrightarrow>
                                     prime_ideal R (rad_ideal R q)"
 apply (simp add:prime_ideal_def)
 apply (frule primary_ideal_ideal[of "q"])
 apply (simp add:id_rad_ideal)
 apply (rule conjI)
  apply (rule contrapos_pp, simp+)
  apply (simp add:id_rad_set, erule conjE, erule exE)
  apply (simp add:npOne)
  apply (simp add:primary_ideal_proper1[of "q"])
 
 apply ((rule ballI)+, rule impI)
  apply (rule contrapos_pp, simp+, erule conjE)
  apply (simp add:id_rad_set, erule conjE, erule exE)
  apply (simp add:npMul)
  apply (simp add:primary_ideal_def, (erule conjE)+)
  apply (frule_tac x = x and n = n in npClose,
         frule_tac x = y and n = n in npClose)
  apply (frule_tac x = "x^\<^bsup>R n\<^esup>" in bspec, assumption,
         thin_tac "\<forall>x\<in>carrier R. \<forall>y\<in>carrier R. x \<cdot>\<^sub>r y \<in> q \<longrightarrow>
                                     (\<exists>n. x^\<^bsup>R n\<^esup> \<in> q) \<or> y \<in> q",
         frule_tac x = "y^\<^bsup>R n\<^esup>" in bspec, assumption,
         thin_tac "\<forall>y\<in>carrier R. x^\<^bsup>R n\<^esup> \<cdot>\<^sub>r y \<in> q \<longrightarrow>
                              (\<exists>na. x^\<^bsup>R n\<^esup>^\<^bsup>R na\<^esup> \<in> q) \<or> y \<in> q", simp)
  apply (simp add:npMulExp)
 done
 
 lemma (in Ring) npow_notin_prime:"\<lbrakk>prime_ideal R P; x \<in> carrier R; x \<notin> P\<rbrakk>
                                 \<Longrightarrow> \<forall>n. npow R x n \<notin> P"
 apply (rule allI)
 apply (induct_tac n)
  apply simp
  apply (simp add:prime_ideal_proper1)
 
  apply simp
  apply (frule_tac x = x and n = na in npClose)
  apply (simp add:prime_elems_mult_not)
 done
 
 lemma (in Ring) npow_in_prime:"\<lbrakk>prime_ideal R P; x \<in> carrier R;
                                \<exists>n. npow R x n \<in> P \<rbrakk> \<Longrightarrow> x \<in> P"
 apply (rule contrapos_pp, simp+)
 apply (frule npow_notin_prime, assumption+)
 apply blast
 done
 
 definition
   mul_closed_set::"[_, 'a set ] \<Rightarrow> bool" where
   "mul_closed_set R S \<longleftrightarrow> S \<subseteq> carrier R \<and> (\<forall>s\<in>S. \<forall>t\<in>S. s \<cdot>\<^sub>r\<^bsub>R\<^esub> t \<in> S)"
 
 locale Idomain = Ring +
        assumes idom:
        "\<lbrakk>a \<in> carrier R; b \<in> carrier R; a \<cdot>\<^sub>r b = \<zero>\<rbrakk> \<Longrightarrow> a = \<zero> \<or> b = \<zero>"
   (* integral domain *)
 
 locale Corps =
        fixes K (structure)
        assumes f_is_ring: "Ring K"
        and f_inv: "\<forall>x\<in>carrier K - {\<zero>}. \<exists>x' \<in> carrier K. x' \<cdot>\<^sub>r x = 1\<^sub>r"
   (** integral domain **)
 
 lemma (in Ring) mul_closed_set_sub:"mul_closed_set R S \<Longrightarrow> S \<subseteq> carrier R"
 by (simp add:mul_closed_set_def)
 
 lemma (in Ring) mul_closed_set_tOp_closed:"\<lbrakk>mul_closed_set R S; s \<in> S;
                             t \<in> S\<rbrakk> \<Longrightarrow> s \<cdot>\<^sub>r t \<in> S"
 by (simp add:mul_closed_set_def)
 
 lemma (in Corps) f_inv_unique:"\<lbrakk> x \<in> carrier K - {\<zero>}; x' \<in> carrier K;
       x'' \<in> carrier K; x' \<cdot>\<^sub>r  x = 1\<^sub>r; x'' \<cdot>\<^sub>r x = 1\<^sub>r \<rbrakk> \<Longrightarrow> x' = x''"
 apply (cut_tac  f_is_ring)
  apply (cut_tac x = x' and y = x and z = x'' in Ring.ring_tOp_assoc[of K],
         assumption+, simp, assumption, simp)
  apply (simp add:Ring.ring_l_one[of K],
         simp add:Ring.ring_tOp_commute[of K x x''] Ring.ring_r_one[of K])
 done
 
 definition
   invf :: "[_, 'a] \<Rightarrow> 'a" where
   "invf K x = (THE y. y \<in> carrier K \<and> y \<cdot>\<^sub>r\<^bsub>K\<^esub> x = 1\<^sub>r\<^bsub>K\<^esub>)"
 
 lemma (in Corps) invf_inv:"x \<in> carrier K - {\<zero>} \<Longrightarrow>
                 (invf K x) \<in> carrier K \<and> (invf K x) \<cdot>\<^sub>r x = 1\<^sub>r "
 apply (simp add:invf_def)
 apply (rule theI')
 apply (rule ex_ex1I)
 apply (cut_tac f_inv, blast)
 apply (rule_tac x' = xa and x'' = y in f_inv_unique[of x])
        apply simp+
 done
 
 
 
 definition
   npowf :: "_  \<Rightarrow> 'a \<Rightarrow> int  \<Rightarrow> 'a" where
   "npowf K x n =
     (if 0 \<le> n then npow K x (nat n) else npow K (invf K x) (nat (- n)))"
 
 abbreviation
   NPOWF ::  "['a, _, int] \<Rightarrow>  'a"  ("(3_\<^bsub>_\<^esub>\<^bsup>_\<^esup>)" [77,77,78]77) where
   "a\<^bsub>K\<^esub>\<^bsup>n\<^esup> == npowf K a n"
 
 abbreviation
   IOP :: "['a, _] \<Rightarrow> 'a" ("(_\<^bsup>\<hyphen> _\<^esup>)" [87,88]87) where
   "a\<^bsup>\<hyphen>K\<^esup> == invf K a"
 
 lemma (in Idomain) idom_is_ring: "Ring R" ..
 
 lemma (in Idomain) idom_tOp_nonzeros:"\<lbrakk>x \<in> carrier R;
        y \<in> carrier R; x \<noteq> \<zero>;  y \<noteq> \<zero>\<rbrakk> \<Longrightarrow> x \<cdot>\<^sub>r y \<noteq> \<zero>"
 apply (rule contrapos_pp, simp+)
 apply (cut_tac idom[of x y]) apply (erule disjE, simp+)
 done
 
 lemma (in Idomain) idom_potent_nonzero:
        "\<lbrakk>x \<in> carrier R; x \<noteq> \<zero>\<rbrakk>  \<Longrightarrow> npow R x n \<noteq> \<zero> "
 apply (induct_tac n)
  apply simp  (* case 0 *)
  apply (rule contrapos_pp, simp+)
  apply (frule ring_l_one[of "x", THEN sym]) apply simp
  apply (simp add:ring_times_0_x)
  (* case (Suc n) *)
 
  apply (rule contrapos_pp, simp+)
  apply (frule_tac n = n in npClose[of x],
         cut_tac a = "x^\<^bsup>R n\<^esup>" and b = x in idom, assumption+)
  apply (erule disjE, simp+)
 done
 
 lemma (in Idomain) idom_potent_unit:"\<lbrakk>a \<in> carrier R; 0 < n\<rbrakk>
                  \<Longrightarrow> (Unit R a) = (Unit R (npow R a n))"
 apply (rule iffI)
  apply (simp add:Unit_def, erule bexE)
  apply (simp add:npClose)
  apply (frule_tac x1 = a and y1 = b and n1 = n in npMul[THEN sym], assumption,
         simp add:npOne)
   apply (frule_tac x = b and n = n in npClose, blast)
 
 apply (case_tac "n = Suc 0", simp only: np_1)
  apply (simp add:Unit_def, erule conjE, erule bexE)
  apply (cut_tac x = a and n = "n - Suc 0" in npow_suc[of R], simp del:npow_suc,
       thin_tac "a^\<^bsup>R n\<^esup> = a^\<^bsup>R (n - Suc 0)\<^esup> \<cdot>\<^sub>r a",
       frule_tac x = a and n = "n - Suc 0" in npClose,
       frule_tac x = "a^\<^bsup>R (n - Suc 0)\<^esup>" and y = a in ring_tOp_commute, assumption+,
       simp add:ring_tOp_assoc,
       frule_tac x = "a^\<^bsup>R (n - Suc 0)\<^esup>" and y = b in ring_tOp_closed, assumption+)
  apply blast
 done
 
 lemma (in Idomain) idom_mult_cancel_r:"\<lbrakk>a \<in> carrier R;
        b \<in> carrier R; c \<in> carrier R; c \<noteq> \<zero>; a \<cdot>\<^sub>r c = b \<cdot>\<^sub>r c\<rbrakk> \<Longrightarrow> a = b"
 apply (cut_tac ring_is_ag)
  apply (frule ring_tOp_closed[of "a" "c"], assumption+,
         frule ring_tOp_closed[of "b" "c"], assumption+)
  apply (simp add:aGroup.ag_eq_diffzero[of "R" "a \<cdot>\<^sub>r c" "b \<cdot>\<^sub>r c"],
         simp add:ring_inv1_1,
         frule aGroup.ag_mOp_closed[of "R" "b"], assumption,
         simp add:ring_distrib2[THEN sym, of "c" "a" "-\<^sub>a b"])
  apply (frule aGroup.ag_pOp_closed[of "R" "a" "-\<^sub>a b"], assumption+)
  apply (subst aGroup.ag_eq_diffzero[of R a b], assumption+)
  apply (rule contrapos_pp, simp+)
  apply (frule idom_tOp_nonzeros[of "a \<plusminus> -\<^sub>a b" c], assumption+, simp)
 done
 
 lemma (in Idomain) idom_mult_cancel_l:"\<lbrakk>a \<in> carrier R;
       b \<in> carrier R; c \<in> carrier R; c \<noteq> \<zero>; c \<cdot>\<^sub>r a = c \<cdot>\<^sub>r b\<rbrakk> \<Longrightarrow> a = b"
 apply (simp add:ring_tOp_commute)
 apply (simp add:idom_mult_cancel_r)
 done
 
 lemma (in Corps) invf_closed1:"x \<in> carrier K - {\<zero>} \<Longrightarrow>
                                invf K x \<in> (carrier K) - {\<zero>}"
 apply (frule  invf_inv[of x], erule conjE)
  apply (rule contrapos_pp, simp+)
  apply (cut_tac f_is_ring) apply (
         simp add:Ring.ring_times_0_x[of K])
  apply (frule sym, thin_tac "\<zero> = 1\<^sub>r", simp, erule conjE)
  apply (frule Ring.ring_l_one[of K x], assumption)
  apply (rotate_tac -1, frule sym, thin_tac "1\<^sub>r \<cdot>\<^sub>r x = x",
         simp add:Ring.ring_times_0_x)
 done
 
 lemma (in Corps) linvf:"x \<in> carrier K - {\<zero>} \<Longrightarrow> (invf K x) \<cdot>\<^sub>r x = 1\<^sub>r"
 by (simp add:invf_inv)
 
 lemma (in Corps) field_is_ring:"Ring K"
 by (simp add:f_is_ring)
 
 lemma (in Corps) invf_one:"1\<^sub>r \<noteq> \<zero>  \<Longrightarrow> invf K (1\<^sub>r) = 1\<^sub>r"
 apply (cut_tac field_is_ring)
  apply (frule_tac Ring.ring_one)
  apply (cut_tac invf_closed1 [of "1\<^sub>r"])
  apply (cut_tac linvf[of "1\<^sub>r"])
  apply (simp add:Ring.ring_r_one[of "K"])
  apply simp+
 done
 
 lemma (in Corps) field_tOp_assoc:"\<lbrakk>x \<in> carrier K; y \<in> carrier K; z \<in> carrier K\<rbrakk>
                                 \<Longrightarrow> x \<cdot>\<^sub>r y \<cdot>\<^sub>r z =  x \<cdot>\<^sub>r (y \<cdot>\<^sub>r z)"
 apply (cut_tac field_is_ring)
 apply (simp add:Ring.ring_tOp_assoc)
 done
 
 lemma (in Corps) field_tOp_commute:"\<lbrakk>x \<in> carrier K; y \<in> carrier K\<rbrakk>
                                 \<Longrightarrow> x \<cdot>\<^sub>r y  =  y \<cdot>\<^sub>r x"
 apply (cut_tac field_is_ring)
 apply (simp add:Ring.ring_tOp_commute)
 done
 
 lemma (in Corps) field_inv_inv:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow> (x\<^bsup>\<hyphen>K\<^esup>)\<^bsup>\<hyphen>K\<^esup> = x"
 apply (cut_tac invf_closed1[of "x"])
  apply (cut_tac invf_inv[of "x\<^bsup>\<hyphen>K\<^esup>"], erule conjE)
  apply (frule field_tOp_assoc[THEN sym, of "x\<^bsup>\<hyphen> K\<^esup>\<^bsup>\<hyphen> K\<^esup>" "x\<^bsup>\<hyphen> K\<^esup>" "x"],
         simp, assumption, simp)
  apply (cut_tac field_is_ring,
         simp add:Ring.ring_l_one Ring.ring_r_one, erule conjE,
         cut_tac invf_inv[of x], erule conjE, simp add:Ring.ring_r_one)
  apply simp+
 done
 
 lemma (in Corps) field_is_idom:"Idomain K"
 apply (rule Idomain.intro)
  apply (simp add:field_is_ring)
  apply (cut_tac field_is_ring)
  apply (rule Idomain_axioms.intro)
  apply (rule contrapos_pp, simp+, erule conjE)
  apply (cut_tac x = a in invf_closed1, simp, simp, erule conjE)
  apply (frule_tac x = "a\<^bsup>\<hyphen> K\<^esup>" and y = a and z = b in field_tOp_assoc,
          assumption+)
  apply (simp add:linvf Ring.ring_times_x_0 Ring.ring_l_one)
 done
 
 lemma (in Corps) field_potent_nonzero:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                                        x^\<^bsup>K n\<^esup> \<noteq> \<zero>"
 apply (cut_tac field_is_idom)
 apply (cut_tac field_is_ring,
        simp add:Idomain.idom_potent_nonzero)
 done
 
 lemma (in Corps) field_potent_nonzero1:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow> x\<^bsub>K\<^esub>\<^bsup>n\<^esup>  \<noteq> \<zero>"
 apply (simp add:npowf_def)
 apply (case_tac "0 \<le> n")
 apply (simp add:field_potent_nonzero)
 
 apply simp
  apply (cut_tac invf_closed1[of "x"], simp+, (erule conjE)+)
  apply (simp add:field_potent_nonzero)
  apply simp
 done
 
 lemma (in Corps) field_nilp_zero:"\<lbrakk>x \<in> carrier K; x^\<^bsup>K n\<^esup> = \<zero>\<rbrakk> \<Longrightarrow> x = \<zero>"
 by (rule contrapos_pp, simp+, simp add:field_potent_nonzero)
 
 lemma (in Corps) npowf_mem:"\<lbrakk>a \<in> carrier K; a \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                                     npowf K a n \<in> carrier K"
 apply (simp add:npowf_def)
 apply (cut_tac field_is_ring)
 apply (case_tac "0 \<le> n", simp,
        simp add:Ring.npClose, simp)
 
 apply (cut_tac invf_closed1[of "a"], simp, erule conjE,
        simp add:Ring.npClose, simp)
 done
 
 lemma (in Corps) field_npowf_exp_zero:"\<lbrakk>a \<in> carrier K; a \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                                     npowf K a 0 = 1\<^sub>r"
 by (cut_tac field_is_ring, simp add:npowf_def)
 
 lemma (in Corps) npow_exp_minusTr1:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>; 0 \<le> i\<rbrakk>  \<Longrightarrow>
        0 \<le> i - (int j) \<longrightarrow>  x\<^bsub>K\<^esub>\<^bsup>(i - (int j))\<^esup> = x^\<^bsup>K (nat i)\<^esup> \<cdot>\<^sub>r (x\<^bsup>\<hyphen>K\<^esup>)^\<^bsup>K j\<^esup>"
 apply (cut_tac field_is_ring,
        cut_tac invf_closed1[of "x"], simp,
        simp add:npowf_def, erule conjE)
 apply (induct_tac "j", simp)
  apply (frule Ring.npClose[of "K" "x" "nat i"], assumption+,
         simp add:Ring.ring_r_one)
 apply (rule impI, simp)
  apply (subst zdiff)
  apply (simp add:add.commute[of "1"])
  apply (cut_tac z = i and w = "int n + 1" in zdiff,
        simp only:minus_add_distrib,
        thin_tac "i - (int n + 1) = i + (- int n + - 1)")
  apply (cut_tac z = "i + - int n" in nat_diff_distrib[of "1"],
          simp, simp)
  apply (simp only:zdiff[of _ "1"], simp)
 
 apply (cut_tac field_is_idom)
 apply (frule_tac n = "nat i" in Ring.npClose[of "K" "x"], assumption+,
        frule_tac n = "nat i" in Ring.npClose[of "K" "x\<^bsup>\<hyphen> K\<^esup>"], assumption+,
        frule_tac n = n in Ring.npClose[of "K" "x\<^bsup>\<hyphen> K\<^esup>"], assumption+ )
 apply (rule_tac a = "x^\<^bsup>K (nat (i + (- int n - 1)))\<^esup>" and
        b = "x^\<^bsup>K (nat i)\<^esup> \<cdot>\<^sub>r (x\<^bsup>\<hyphen> K\<^esup>^\<^bsup>K n\<^esup> \<cdot>\<^sub>r x\<^bsup>\<hyphen> K\<^esup>)" and c = x in
        Idomain.idom_mult_cancel_r[of "K"], assumption+)
  apply (simp add:Ring.npClose, rule Ring.ring_tOp_closed, assumption+,
         rule Ring.ring_tOp_closed, assumption+)
  apply (subgoal_tac "0 < nat (i - int n)")
  apply (subst Ring.npMulElmR, assumption+, simp,
         simp add:field_tOp_assoc[THEN sym, of "x^\<^bsup>K (nat i)\<^esup>" _ "x\<^bsup>\<hyphen> K\<^esup>"])
  apply (subst field_tOp_assoc[of _ _ x])
  apply (rule Ring.ring_tOp_closed[of K], assumption+)
  apply (simp add: linvf)
  apply (subst Ring.ring_r_one[of K], assumption)
  apply auto
  apply (metis Ring.npClose)
  apply (simp only: uminus_add_conv_diff [symmetric] add.assoc [symmetric])
  apply (simp add: algebra_simps nat_diff_distrib Suc_diff_Suc)
  apply (smt Ring.npMulElmR Suc_nat_eq_nat_zadd1 nat_diff_distrib' nat_int of_nat_0_le_iff)
 done
 
 lemma (in Corps) npow_exp_minusTr2:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>; 0 \<le> i; 0 \<le> j;
                  0 \<le> i - j\<rbrakk>  \<Longrightarrow>  x\<^bsub>K\<^esub>\<^bsup>(i - j)\<^esup> = x^\<^bsup>K (nat i)\<^esup> \<cdot>\<^sub>r (x\<^bsup>\<hyphen>K\<^esup>)^\<^bsup>K (nat j)\<^esup>"
 apply (frule npow_exp_minusTr1[of "x" "i" "nat j"], assumption+)
 apply simp
 done
 
 lemma (in Corps) npowf_inv:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>; 0 \<le> j\<rbrakk> \<Longrightarrow> x\<^bsub>K\<^esub>\<^bsup>j\<^esup> = (x\<^bsup>\<hyphen>K\<^esup>)\<^bsub>K\<^esub>\<^bsup>(-j)\<^esup>"
 apply (simp add:npowf_def)
  apply (rule impI, simp add:zle)
  apply (simp add:field_inv_inv)
 done
 
 lemma (in Corps) npowf_inv1:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>; \<not> 0 \<le> j\<rbrakk> \<Longrightarrow>
                                       x\<^bsub>K\<^esub>\<^bsup>j\<^esup> = (x\<^bsup>\<hyphen>K\<^esup>)\<^bsub>K\<^esub>\<^bsup>(-j)\<^esup>"
 apply (simp add:npowf_def)
 done
 
 lemma (in Corps) npowf_inverse:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow> x\<^bsub>K\<^esub>\<^bsup>j\<^esup> = (x\<^bsup>\<hyphen>K\<^esup>)\<^bsub>K\<^esub>\<^bsup>(-j)\<^esup>"
 apply (case_tac "0 \<le> j")
 apply (simp add:npowf_inv, simp add:npowf_inv1)
 done
 
 lemma (in Corps) npowf_expTr1:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>; 0 \<le> i; 0 \<le> j;
                  0 \<le> i - j\<rbrakk> \<Longrightarrow> x\<^bsub>K\<^esub>\<^bsup>(i - j)\<^esup> = x\<^bsub>K\<^esub>\<^bsup>i\<^esup> \<cdot>\<^sub>r x\<^bsub>K\<^esub>\<^bsup>(- j)\<^esup>"
 apply (simp add:npow_exp_minusTr2)
 apply (simp add:npowf_def)
 done
 
 lemma (in Corps) npowf_expTr2:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>; 0 \<le> i + j\<rbrakk> \<Longrightarrow>
                           x\<^bsub>K\<^esub>\<^bsup>(i + j)\<^esup> = x\<^bsub>K\<^esub>\<^bsup>i\<^esup> \<cdot>\<^sub>r x\<^bsub>K\<^esub>\<^bsup>j\<^esup>"
 apply (cut_tac field_is_ring)
  apply (case_tac "0 \<le> i")
   apply (case_tac "0 \<le> j")
   apply (simp add:npowf_def, simp add:nat_add_distrib,
          rule Ring.npMulDistr[THEN sym], assumption+)
  apply (subst zminus_minus[THEN sym, of "i" "j"],
         subst npow_exp_minusTr2[of "x" "i" "-j"], assumption+)
   apply (simp add:zle, simp add:zless_imp_zle, simp add:npowf_def)
  apply (simp add:add.commute[of "i" "j"],
         subst zminus_minus[THEN sym, of "j" "i"],
         subst npow_exp_minusTr2[of "x" "j" "-i"], assumption+)
   apply (simp add:zle, simp add:zless_imp_zle, simp)
   apply (frule npowf_mem[of "x" "i"], assumption+,
          frule npowf_mem[of "x" "j"], assumption+,
          simp add:field_tOp_commute[of "x\<^bsub>K\<^esub>\<^bsup>i\<^esup>" "x\<^bsub>K\<^esub>\<^bsup>j\<^esup>"])
   apply (simp add:npowf_def)
 done
 
 lemma (in Corps) npowf_exp_add:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                           x\<^bsub>K\<^esub>\<^bsup>(i + j)\<^esup> = x\<^bsub>K\<^esub>\<^bsup>i\<^esup> \<cdot>\<^sub>r x\<^bsub>K\<^esub>\<^bsup>j\<^esup>"
 apply (case_tac "0 \<le> i + j")
 apply (simp add:npowf_expTr2)
 apply (simp add:npowf_inv1[of "x" "i + j"])
  apply (simp add:zle)
 apply (subgoal_tac "0 < -i + -j") prefer 2 apply simp
  apply (thin_tac "i + j < 0")
  apply (frule zless_imp_zle[of "0" "-i + -j"])
  apply (thin_tac "0 < -i + -j")
 apply (cut_tac invf_closed1[of "x"])
 apply (simp, erule conjE,
        frule npowf_expTr2[of "x\<^bsup>\<hyphen>K\<^esup>" "-i" "-j"], assumption+)
  apply (simp add:zdiff[THEN sym])
 apply (simp add:npowf_inverse, simp)
 done
 
 lemma (in Corps) npowf_exp_1_add:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                                         x\<^bsub>K\<^esub>\<^bsup>(1 + j)\<^esup> = x \<cdot>\<^sub>r x\<^bsub>K\<^esub>\<^bsup>j\<^esup>"
 apply (simp add:npowf_exp_add[of "x" "1" "j"])
 apply (cut_tac field_is_ring)
 apply (simp add:npowf_def, simp add:Ring.ring_l_one)
 done
 
 lemma (in Corps) npowf_minus:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow> (x\<^bsub>K\<^esub>\<^bsup>j\<^esup>)\<^bsup>\<hyphen>K\<^esup> = x\<^bsub>K\<^esub>\<^bsup>(- j)\<^esup>"
 apply (frule npowf_exp_add[of "x" "j" "-j"], assumption+)
  apply (simp add:field_npowf_exp_zero)
 apply (cut_tac field_is_ring)
 apply (frule npowf_mem[of "x" "j"], assumption+)
  apply (frule field_potent_nonzero1[of "x" "j"], assumption+)
 apply (cut_tac invf_closed1[of "x\<^bsub>K\<^esub>\<^bsup>j\<^esup>"], simp, erule conjE,
        frule Ring.ring_r_one[of "K" "(x\<^bsub>K\<^esub>\<^bsup>j\<^esup>)\<^bsup>\<hyphen>K\<^esup>"], assumption, simp,
       thin_tac "1\<^sub>r = x\<^bsub>K\<^esub>\<^bsup>j\<^esup> \<cdot>\<^sub>r x\<^bsub>K\<^esub>\<^bsup>- j\<^esup>",
       frule npowf_mem[of "x" "-j"], assumption+)
 apply (simp add:field_tOp_assoc[THEN sym], simp add:linvf,
        simp add:Ring.ring_l_one, simp)
 done
 
 lemma (in Ring) residue_fieldTr:"\<lbrakk>maximal_ideal R mx; x \<in> carrier(qring R mx);
  x \<noteq> \<zero>\<^bsub>(qring R mx)\<^esub>\<rbrakk> \<Longrightarrow>\<exists>y\<in>carrier (qring R mx). y \<cdot>\<^sub>r\<^bsub>(qring R mx)\<^esub> x = 1\<^sub>r\<^bsub>(qring R mx)\<^esub>"
 apply (frule maximal_ideal_ideal[of "mx"])
 apply (simp add:qring_carrier)
  apply (simp add:qring_zero)
  apply (simp add:qring_def)
  apply (erule bexE)
  apply (frule sym, thin_tac "a \<uplus>\<^bsub>R\<^esub> mx = x", simp)
  apply (frule_tac a = a in ar_coset_same4_1[of "mx"], assumption+)
  apply (frule_tac x = a in maximal_prime_Tr0[of "mx"], assumption+)
  apply (cut_tac ring_one)
  apply (rotate_tac -2, frule sym, thin_tac "mx \<minusplus> R \<diamondsuit>\<^sub>p a = carrier R")
  apply (frule_tac B = "mx \<minusplus> R \<diamondsuit>\<^sub>p a" in eq_set_inc[of "1\<^sub>r" "carrier R"],
                   assumption+,
         thin_tac "carrier R = mx \<minusplus> R \<diamondsuit>\<^sub>p a")
  apply (frule ideal_subset1[of mx])
  apply (frule_tac a = a in principal_ideal,
         frule_tac I = "R \<diamondsuit>\<^sub>p a" in ideal_subset1)
  apply (cut_tac ring_is_ag,
         simp add:aGroup.set_sum, (erule bexE)+)
  apply (thin_tac "ideal R (R \<diamondsuit>\<^sub>p a)", thin_tac "R \<diamondsuit>\<^sub>p a \<subseteq> carrier R",
         simp add:Rxa_def, (erule bexE)+, simp, thin_tac "k = r \<cdot>\<^sub>r a")
  apply (frule_tac a = r and b = a in rcostOp[of "mx"], assumption+)
  apply (frule_tac x = r and y = a in ring_tOp_closed, assumption+)
  apply (frule_tac a = "r \<cdot>\<^sub>r a" and x = h and b = "1\<^sub>r" in
         aGroup.ag_eq_sol2[of "R"], assumption+)
        apply (simp add:ideal_subset) apply (simp add:ring_one, simp)
        apply (frule_tac a = h and b = "1\<^sub>r \<plusminus> -\<^sub>a (r \<cdot>\<^sub>r a)" and A = mx in
               eq_elem_in, assumption+)
  apply (frule_tac a = "r \<cdot>\<^sub>r a" and b = "1\<^sub>r" in ar_coset_same1[of "mx"],
         rule ring_tOp_closed, assumption+, rule ring_one, assumption)
   apply (frule_tac a1 = "r \<cdot>\<^sub>r a" and h1 = h in aGroup.arcos_fixed[THEN sym,
          of R mx],  unfold ideal_def, erule conjE, assumption+,
          thin_tac "R +> mx \<and> (\<forall>r\<in>carrier R. \<forall>x\<in>mx. r \<cdot>\<^sub>r x \<in> mx)",
          thin_tac "x = a \<uplus>\<^bsub>R\<^esub> mx",
          thin_tac "1\<^sub>r = h \<plusminus> r \<cdot>\<^sub>r a",
          thin_tac "h = 1\<^sub>r \<plusminus> -\<^sub>a (r \<cdot>\<^sub>r a)", thin_tac "1\<^sub>r \<plusminus> -\<^sub>a (r \<cdot>\<^sub>r a) \<in> mx")
   apply (rename_tac b h k r) apply simp
   apply blast
 done
 
 (*
 constdefs (structure R)
  field_cd::"_ \<Rightarrow> bool"
  "field_cd R  == \<forall>x\<in>(carrier R - {\<zero>}). \<exists>y\<in>carrier R.
                                                 y \<cdot>\<^sub>r x = 1\<^sub>r" *)
 (* field condition  *) (*
 constdefs (structure R)
  rIf :: "_ \<Rightarrow> 'a  \<Rightarrow> 'a " *) (** rIf is ring_invf **) (*
  "rIf R == \<lambda>x. (SOME y. y \<in> carrier R \<and> y \<cdot>\<^sub>r x = 1\<^sub>r)"
 *) (*
 constdefs (structure R)
   Rf::"_ \<Rightarrow> 'a field"
   "Rf R == \<lparr>carrier = carrier R, pop = pop R, mop = mop R, zero = zero R,
                tp = tp R, un = un R, invf = rIf R\<rparr>" *)
 
 (*
 constdefs (structure R)
  Rf ::  "_ \<Rightarrow> \<lparr> carrier :: 'a set,
   pOp :: ['a, 'a] \<Rightarrow> 'a, mOp ::'a \<Rightarrow> 'a, zero :: 'a, tOp :: ['a, 'a] \<Rightarrow> 'a,
   one ::'a, iOp ::'a \<Rightarrow> 'a\<rparr>"
 
   "Rf R  == \<lparr> carrier = carrier R, pOp = pOp R, mOp = mOp R, zero = zero R,
   tOp = tOp R, one = one R, iOp = ring_iOp R\<rparr>" *)
 (*
 lemma (in Ring) rIf_mem:"\<lbrakk>field_cd R; x \<in> carrier R - {\<zero>}\<rbrakk> \<Longrightarrow>
                      rIf R x \<in> carrier R \<and> rIf R x \<noteq> \<zero>"
 apply (simp add:rIf_def)
 apply (rule someI2_ex)
 apply (simp add:field_cd_def, blast)
 apply (simp add:field_cd_def)
  apply (thin_tac "\<forall>x\<in>carrier R - {\<zero>}. \<exists>y\<in>carrier R. y \<cdot>\<^sub>r x = 1\<^sub>r")
  apply (erule conjE)+
  apply (rule contrapos_pp, simp+)
  apply (frule sym, thin_tac "\<zero> \<cdot>\<^sub>r x = 1\<^sub>r", simp add:ring_times_0_x)
   apply (frule ring_l_one[of "x"])
  apply (simp add:ring_times_0_x)
 done
 
 lemma (in Ring) rIf:"\<lbrakk>field_cd R; x \<in> carrier R - {\<zero>}\<rbrakk> \<Longrightarrow>
                                            (rIf R x) \<cdot>\<^sub>r x = 1\<^sub>r"
 apply (simp add:rIf_def)
 apply (rule someI2_ex)
 apply (simp add:field_cd_def, blast)
 apply simp
 done
 
 lemma (in Ring) field_cd_integral:"field_cd R \<Longrightarrow> Idomain R"
 apply (rule Idomain.intro)
  apply assumption
  apply (rule Idomain_axioms.intro)
 
 apply (rule contrapos_pp, simp+, erule conjE)
 apply (cut_tac x = a in rIf_mem, assumption, simp, erule conjE)
 apply (frule_tac x = "rIf R a" and y = a and z = b in ring_tOp_assoc,
                  assumption+, simp add:rIf)
 apply (simp add:ring_l_one ring_times_x_0)
 done
 
 lemma (in Ring) Rf_field:"field_cd R \<Longrightarrow> field (Rf R)"
 apply (rule field.intro)
  apply (simp add:Rf_def)
  apply (rule Ring.intro)
  apply (simp add:pop_closed)
  apply ( cut_tac ring_is_ag, simp add:aGroup.ag_pOp_assoc)
  apply (simp add:Rf_def,
          cut_tac ring_is_ag, simp add:aGroup.ag_pOp_commute)
  apply (simp add:mop_closed)
  apply (simp add:
 
 
 apply (rule conjI)
  prefer 2
  apply (rule conjI)
  apply (rule univar_func_test, rule ballI)
  apply (simp, erule conjE, simp add:Rf_def)
  apply (rule rIf_mem, assumption+, simp)
 apply (rule allI, rule impI)
  apply (simp add:Rf_def)
  apply (frule_tac x = x in rIf, simp, assumption)
 
  apply (subst Rf_def, simp add:Ring_def)
  apply (cut_tac ring_is_ag)
  apply (rule conjI, simp add:aGroup_def)
  apply (rule conjI, (rule allI, rule impI)+, simp add:aGroup.ag_pOp_assoc)
  apply (rule conjI, (rule allI, rule impI)+, simp add:aGroup.ag_pOp_commute)
  apply (rule conjI, rule univar_func_test, rule ballI,
                                               simp add:aGroup.ag_mOp_closed)
  apply (rule conjI, rule allI, rule impI, simp add:aGroup.ag_l_inv1)
  apply (simp add:aGroup.ag_inc_zero)
  apply (rule conjI, rule allI, rule impI, simp add:aGroup.ag_l_zero)
 
  apply (rule conjI, rule bivar_func_test, (rule ballI)+,
                                           simp add:ring_tOp_closed)
  apply (rule conjI, (rule allI, rule impI)+, simp add:ring_tOp_assoc)
  apply (rule conjI, (rule allI, rule impI)+, simp add:ring_tOp_commute)
  apply (simp add:ring_one)
  apply (rule conjI, (rule allI, rule impI)+, simp add:ring_distrib1)
  apply (rule allI, rule impI, simp add:ring_l_one)
 done
  *)
 
 lemma (in Ring) residue_field_cd:"maximal_ideal R mx \<Longrightarrow>
                                            Corps (qring R mx)"
 apply (rule Corps.intro)
 apply (rule Ring.qring_ring, rule Ring_axioms)
 apply (simp add:maximal_ideal_ideal)
 apply (simp add:residue_fieldTr[of "mx"])
 done
 
 (*
 lemma (in Ring) qRf_field:"maximal_ideal R mx \<Longrightarrow> field (Rf (qring R mx))"
 apply (frule maximal_ideal_ideal[of "mx"])
 apply (frule qring_ring [of "mx"])
  apply (frule residue_field_cd[of "mx"])
  apply (rule Ring.Rf_field, assumption+)
 done
 
 lemma (in Ring) qRf_pj_rHom:"maximal_ideal R mx \<Longrightarrow>
                           (pj R mx) \<in> rHom R (Rf (qring R mx))"
 apply (frule maximal_ideal_ideal[of "mx"])
 apply (frule pj_Hom[OF Ring, of "mx"])
 apply (simp add:rHom_def aHom_def Rf_def)
 done *)
 
 lemma (in Ring) maximal_set_idealTr:
        "maximal_set {I. ideal R I \<and> S \<inter> I = {}} mx \<Longrightarrow> ideal R mx"
 by (simp add:maximal_set_def)
 
 lemma (in Ring) maximal_setTr:"\<lbrakk>maximal_set {I. ideal R I \<and> S \<inter> I = {}} mx;
                                          ideal R J; mx \<subset> J \<rbrakk> \<Longrightarrow> S \<inter> J \<noteq> {}"
 by (rule contrapos_pp, simp+, simp add:psubset_eq, erule conjE,
        simp add:maximal_set_def, blast)
 
 lemma (in Ring) mulDisj:"\<lbrakk>mul_closed_set R S; 1\<^sub>r \<in> S; \<zero> \<notin> S;
     T = {I. ideal R I \<and> S \<inter> I = {}}; maximal_set T mx \<rbrakk> \<Longrightarrow> prime_ideal R mx"
 apply (simp add:prime_ideal_def)
 apply (rule conjI, simp add:maximal_set_def,
        rule conjI, simp add:maximal_set_def)
 apply (rule contrapos_pp, simp+)
 apply ((erule conjE)+, blast)
 
 apply ((rule ballI)+, rule impI)
 apply (rule contrapos_pp, simp+, (erule conjE)+)
 apply (cut_tac a = x in id_ideal_psub_sum[of "mx"],
                simp add:maximal_set_def, assumption+,
        cut_tac a = y in id_ideal_psub_sum[of "mx"],
                simp add:maximal_set_def, assumption+)
 apply (frule_tac J = "mx \<minusplus> R \<diamondsuit>\<^sub>p x" in maximal_setTr[of "S" "mx"],
        rule sum_ideals, simp add:maximal_set_def,
        simp add:principal_ideal, assumption,
        thin_tac "mx \<subset> mx \<minusplus> R \<diamondsuit>\<^sub>p x")
 apply (frule_tac J = "mx \<minusplus> R \<diamondsuit>\<^sub>p y" in maximal_setTr[of "S" "mx"],
        rule sum_ideals, simp add:maximal_set_def,
        simp add:principal_ideal, assumption,
        thin_tac "mx \<subset> mx \<minusplus> R \<diamondsuit>\<^sub>p y")
 apply (frule_tac A = "S \<inter> (mx \<minusplus> R \<diamondsuit>\<^sub>p x)" in nonempty_ex,
        frule_tac A = "S \<inter> (mx \<minusplus> R \<diamondsuit>\<^sub>p y)" in nonempty_ex,
        (erule exE)+, simp, (erule conjE)+)
 apply (rename_tac x y s1 s2,
        thin_tac "S \<inter> (mx \<minusplus> R \<diamondsuit>\<^sub>p x) \<noteq> {}",
        thin_tac "S \<inter> (mx \<minusplus> R \<diamondsuit>\<^sub>p y) \<noteq> {}")
 apply (frule maximal_set_idealTr,
        frule_tac a = x in principal_ideal,
        frule_tac a = y in principal_ideal,
        frule ideal_subset1[of mx],
        frule_tac I = "R \<diamondsuit>\<^sub>p x" in ideal_subset1,
        frule_tac I = "R \<diamondsuit>\<^sub>p y" in ideal_subset1)
 apply (cut_tac ring_is_ag,
        simp add:aGroup.set_sum[of R mx],
        erule bexE, erule bexE, simp)
 apply (frule_tac s = s1 and t = s2 in mul_closed_set_tOp_closed, simp,
        assumption, simp,
        frule_tac c = h in subsetD[of mx "carrier R"], assumption+,
        frule_tac c = k and A = "R \<diamondsuit>\<^sub>p x" in subsetD[of _ "carrier R"],
        assumption+)
 apply (
        cut_tac mul_closed_set_sub,
        frule_tac c = s2 in subsetD[of S "carrier R"], assumption+,
        simp add:ring_distrib2)
 apply ((erule bexE)+, simp,
        frule_tac c = ha in subsetD[of mx "carrier R"], assumption+,
        frule_tac c = ka and A = "R \<diamondsuit>\<^sub>p y" in subsetD[of _ "carrier R"],
        assumption+,
        simp add:ring_distrib1)
 apply (frule_tac x = h and r = ha in ideal_ring_multiple1[of mx], assumption+)
 apply (frule_tac x = h and r = ka in ideal_ring_multiple1[of mx], assumption+,
        frule_tac x = ha and r = k in ideal_ring_multiple[of mx], assumption+)
 apply (frule_tac a = x and b = y and x = k and y = ka in
                   mul_two_principal_idealsTr, assumption+,
        erule bexE,
        frule_tac x = "x \<cdot>\<^sub>r y" and r = r in ideal_ring_multiple[of mx],
        assumption+,
        rotate_tac -2, frule sym, thin_tac "k \<cdot>\<^sub>r ka = r \<cdot>\<^sub>r (x \<cdot>\<^sub>r y)", simp)
  apply (frule_tac x = "h \<cdot>\<^sub>r ha \<plusminus> h \<cdot>\<^sub>r ka" and y = "k \<cdot>\<^sub>r ha \<plusminus> k \<cdot>\<^sub>r ka" in
         ideal_pOp_closed[of mx])
  apply (rule ideal_pOp_closed, assumption+)+
  apply (simp add:maximal_set_def)
  apply blast
  apply assumption
 done
 
 lemma (in Ring) ex_mulDisj_maximal:"\<lbrakk>mul_closed_set R S; \<zero> \<notin> S; 1\<^sub>r \<in> S;
        T = {I. ideal R I \<and> S \<inter> I = {}}\<rbrakk> \<Longrightarrow>  \<exists>mx. maximal_set T mx"
 apply (cut_tac A="{ I. ideal R I \<and> S \<inter> I = {}}" in Zorn_Lemma2)
 prefer 2
   apply (simp add:maximal_set_def)
 
 apply (rule ballI)
 apply (case_tac "C = {}")
  apply (cut_tac zero_ideal, blast)
 
 apply (subgoal_tac "C \<in> chains {I. ideal R I \<and> I \<subset> carrier R}")
 apply (frule chains_un, assumption)
  apply (subgoal_tac "S \<inter> (\<Union> C) = {}")
  apply (subgoal_tac "\<forall>x\<in>C. x \<subseteq> \<Union> C",  blast)
 apply (rule ballI, rule subsetI, simp add:CollectI)
  apply blast
 
 apply (rule contrapos_pp, simp+)
  apply (frule_tac A = S and B = "\<Union> C" in nonempty_int)
  apply (erule exE)
  apply (simp, erule conjE, erule bexE)
  apply (simp add:chains_def, erule conjE)
  apply (frule_tac c = X and A = C and B = "{I. ideal R I \<and> S \<inter> I = {}}" in
         subsetD, assumption+,
         thin_tac "C \<subseteq> {I. ideal R I \<and> I \<subset> carrier R}",
         thin_tac "C \<subseteq> {I. ideal R I \<and> S \<inter> I = {}}")
  apply (simp, blast)
 
 apply (simp add:chains_def chain_subset_def, erule conjE)
  apply (rule subsetI)
  apply (frule_tac c = x and A = C and B = "{I. ideal R I \<and> S \<inter> I = {}}" in
                   subsetD, assumption+,
         thin_tac "C \<subseteq> {I. ideal R I \<and> S \<inter> I = {}}",
         thin_tac "T = {I. ideal R I \<and> S \<inter> I = {}}")
  apply (simp, thin_tac "\<forall>x\<in>C. \<forall>y\<in>C. x \<subseteq> y \<or> y \<subseteq> x", erule conjE)
  apply (simp add:psubset_eq ideal_subset1)
  apply (rule contrapos_pp, simp+)
  apply (rotate_tac -1, frule sym, thin_tac "x = carrier R",
         thin_tac "carrier R = x")
  apply (cut_tac ring_one, blast)
 done
 
 lemma (in Ring) ex_mulDisj_prime:"\<lbrakk>mul_closed_set R S; \<zero> \<notin> S; 1\<^sub>r \<in> S\<rbrakk> \<Longrightarrow>
                             \<exists>mx. prime_ideal R mx \<and> S \<inter> mx = {}"
 apply (frule ex_mulDisj_maximal[of "S" "{I. ideal R I \<and> S \<inter> I = {}}"],
                assumption+, simp, erule exE)
  apply (frule_tac mx = mx in mulDisj [of "S" "{I. ideal R I \<and> S \<inter> I = {}}"],
                   assumption+, simp, assumption)
  apply (simp add:maximal_set_def, (erule conjE)+, blast)
 done
 
 lemma (in Ring) nilradTr1:"\<not> zeroring R \<Longrightarrow> nilrad R = \<Inter> {p. prime_ideal R p}"
 apply (rule equalityI)
  (* nilrad R \<subseteq> \<Inter>Collect (prime_ideal R) *)
 apply (rule subsetI)
  apply (simp add:nilrad_def CollectI nilpotent_def)
  apply (erule conjE, erule exE)
  apply (rule allI, rule impI)
  apply (frule_tac prime_ideal_ideal)
  apply (frule sym, thin_tac "x^\<^bsup>R n\<^esup> = \<zero>", frule ideal_zero, simp)
  apply (case_tac "n = 0", simp)
  apply (frule Zero_ring1[THEN not_sym], simp)
  apply (rule_tac P = xa and x = x in npow_in_prime,assumption+, blast)
 
 apply (rule subsetI)
  apply (rule contrapos_pp, simp+)
  apply (frule id_maximal_Exist, erule exE,
         frule maximal_prime)
  apply (frule_tac a = I in forall_spec, assumption,
         frule_tac I = I in prime_ideal_ideal,
         frule_tac h = x and I = I in ideal_subset, assumption)
 apply (subgoal_tac "\<zero> \<notin> {s. \<exists>n. s = npow R x n} \<and>
                                   1\<^sub>r \<in> {s. \<exists>n. s = npow R x n}")
 apply (subgoal_tac "mul_closed_set R {s. \<exists>n. s = npow R x n}")
 apply (erule conjE)
 apply (frule_tac S = "{s. \<exists>n. s = npow R x n}" in ex_mulDisj_prime,
        assumption+, erule exE, erule conjE)
 apply (subgoal_tac "x \<in> {s. \<exists>n. s = x^\<^bsup>R n\<^esup>}", blast)
 
 apply simp
 apply (cut_tac t = x in np_1[THEN sym], assumption, blast)
 
 apply (thin_tac "\<zero> \<notin> {s. \<exists>n. s = x^\<^bsup>R n\<^esup>} \<and> 1\<^sub>r \<in> {s. \<exists>n. s = x^\<^bsup>R n\<^esup>}",
        thin_tac "\<forall>xa. prime_ideal R xa \<longrightarrow> x \<in> xa")
 apply (subst mul_closed_set_def)
  apply (rule conjI)
  apply (rule subsetI, simp, erule exE)
  apply (simp add:npClose)
 apply ((rule ballI)+, simp, (erule exE)+, simp)
  apply (simp add:npMulDistr, blast)
 
 apply (rule conjI)
  apply simp
  apply (rule contrapos_pp, simp+, erule exE)
  apply (frule sym, thin_tac "\<zero> = x^\<^bsup>R n\<^esup>")
  apply (simp add:nilrad_def nilpotent_def)
 
 apply simp
  apply (cut_tac x1 = x in npow_0[THEN sym, of "R"], blast)
 done
 
 lemma (in Ring) nonilp_residue_nilrad:"\<lbrakk>\<not> zeroring R; x \<in> carrier R;
         nilpotent (qring R (nilrad R)) (x \<uplus>\<^bsub>R\<^esub> (nilrad R))\<rbrakk> \<Longrightarrow>
                    x \<uplus>\<^bsub>R\<^esub> (nilrad R) = \<zero>\<^bsub>(qring R (nilrad R))\<^esub>"
 apply (simp add:nilpotent_def)
  apply (erule exE)
  apply (cut_tac id_nilrad_ideal)
  apply (simp add:qring_zero)
  apply (cut_tac "Ring")
  apply (simp add:npQring)
  apply (frule_tac x = x and n = n in npClose)
  apply (frule_tac I = "nilrad R" and a = "x^\<^bsup>R n\<^esup>" in ar_coset_same3,
              assumption+)
  apply (rule_tac I = "nilrad R" and a = x in ar_coset_same4, assumption)
  apply (thin_tac "x^\<^bsup>R n\<^esup> \<uplus>\<^bsub>R\<^esub> nilrad R = nilrad R",
         simp add:nilrad_def nilpotent_def, erule exE)
  apply (simp add:npMulExp, blast)
 done
 
 lemma (in Ring) ex_contid_maximal:"\<lbrakk> S = {1\<^sub>r}; \<zero> \<notin> S; ideal R I; I \<inter> S = {};
 T = {J. ideal R J \<and> S \<inter> J = {} \<and> I \<subseteq> J}\<rbrakk> \<Longrightarrow> \<exists>mx. maximal_set T mx"
 apply (cut_tac A="{J. ideal R J \<and> S \<inter> J = {} \<and> I \<subseteq> J}" in Zorn_Lemma2)
 apply (rule ballI)
 apply (case_tac "C = {}") (** case C = {} **)
  apply blast             (** case C = {} done **)
      (** existence of sup in C **)
 apply (subgoal_tac "\<Union>C\<in>{J. ideal R J \<and> S \<inter> J = {} \<and> I \<subseteq> J} \<and>
                                          (\<forall>x\<in>C. x \<subseteq>  \<Union>C)")
  apply blast
 apply (rule conjI,
        simp add:CollectI)
 apply (subgoal_tac "C \<in> chains {I. ideal R I \<and> I \<subset> carrier R}")
 apply (rule conjI,
        simp add:chains_un)
 apply (rule conjI)
 apply (rule contrapos_pp, simp+, erule bexE)
  apply (thin_tac " C \<in> chains {I. ideal R I \<and> I \<subset> carrier R}")
  apply (simp add:chains_def, erule conjE)
  apply (frule_tac c = x and A = C and B = "{J. ideal R J \<and> 1\<^sub>r \<notin> J \<and> I \<subseteq> J}"
          in subsetD, assumption+, simp,
         thin_tac "C \<in> chains {I. ideal R I \<and> I \<subset> carrier R}")
  apply (frule_tac A = C in nonempty_ex, erule exE, simp add:chains_def,
         erule conjE,
         frule_tac c = x and A = C and B = "{J. ideal R J \<and> 1\<^sub>r \<notin> J \<and> I \<subseteq> J}" in
                   subsetD, assumption+, simp, (erule conjE)+)
  apply (rule_tac A = I and B = x and C = "\<Union>C" in subset_trans, assumption,
         rule_tac B = x and A = C in Union_upper, assumption+)
  apply (simp add:chains_def, erule conjE)
  apply (rule subsetI, simp)
  apply (frule_tac c = x and A = C and B = "{J. ideal R J \<and> 1\<^sub>r \<notin> J \<and> I \<subseteq> J}"
         in subsetD, assumption+, simp, (erule conjE)+)
  apply (subst psubset_eq, simp add:ideal_subset1)
  apply (rule contrapos_pp, simp+, simp add:ring_one)
 
  apply (rule ballI)
  apply (rule Union_upper, assumption)
  apply (erule bexE)
  apply (simp add:maximal_set_def)
  apply blast
 done
 
 lemma (in Ring) contid_maximal:"\<lbrakk>S = {1\<^sub>r}; \<zero> \<notin> S; ideal R I; I \<inter> S = {};
              T = {J. ideal R J \<and> S \<inter> J = {} \<and> I \<subseteq> J}; maximal_set T mx\<rbrakk> \<Longrightarrow>
                                                 maximal_ideal R mx"
 apply (simp add:maximal_set_def maximal_ideal_def)
 apply (erule conjE)+
 apply (rule equalityI)
   (** {J. ideal R J \<and> mx \<subseteq> J} \<subseteq> {mx, carrier R} **)
   apply (rule subsetI, simp add:CollectI, erule conjE)
  apply (case_tac "x = mx", simp, simp)
  apply (subgoal_tac "1\<^sub>r \<in> x")
  apply (rule_tac  I = x in ideal_inc_one, assumption+)
  apply (rule contrapos_pp, simp+)
 apply (drule spec[of _ mx])
  apply (simp add:whole_ideal,
         rule subsetI, rule ideal_subset[of "mx"], assumption+)
 done
 
 lemma (in Ring) ideal_contained_maxid:"\<lbrakk>\<not>(zeroring R); ideal R I; 1\<^sub>r \<notin> I\<rbrakk> \<Longrightarrow>
                     \<exists>mx. maximal_ideal R mx \<and> I \<subseteq> mx"
 apply (cut_tac ex_contid_maximal[of "{1\<^sub>r}" "I"
                       "{J. ideal R J \<and> {1\<^sub>r} \<inter> J = {} \<and> I \<subseteq> J}"])
 apply (erule exE,
        cut_tac mx = mx in contid_maximal[of "{1\<^sub>r}" "I"
                          "{J. ideal R J \<and> {1\<^sub>r} \<inter> J = {} \<and> I \<subseteq> J}"])
 apply simp
  apply (frule Zero_ring1, simp,
         assumption, simp, simp, simp,
         simp add:maximal_set_def, (erule conjE)+, blast,
         simp, frule Zero_ring1, simp)
  apply (assumption, simp, simp)
 done
 
 lemma (in Ring) nonunit_principal_id:"\<lbrakk>a \<in> carrier R; \<not> (Unit R a)\<rbrakk> \<Longrightarrow>
                                              (R \<diamondsuit>\<^sub>p a) \<noteq> (carrier R)"
 apply (rule contrapos_pp, simp+)
 apply (frule sym, thin_tac "R \<diamondsuit>\<^sub>p a = carrier R")
 apply (cut_tac ring_one)
  apply (frule eq_set_inc[of "1\<^sub>r" "carrier R" "R \<diamondsuit>\<^sub>p a"], assumption,
         thin_tac "carrier R = R \<diamondsuit>\<^sub>p a", thin_tac "1\<^sub>r \<in> carrier R")
 apply (simp add:Rxa_def, erule bexE, simp add:ring_tOp_commute[of _ "a"],
        frule sym, thin_tac "1\<^sub>r = a \<cdot>\<^sub>r r")
 apply (simp add:Unit_def)
 done
 
 lemma (in Ring) nonunit_contained_maxid:"\<lbrakk>\<not>(zeroring R); a \<in> carrier R;
                 \<not> Unit R a \<rbrakk>  \<Longrightarrow>  \<exists>mx. maximal_ideal R mx \<and> a \<in>  mx"
 apply (frule principal_ideal[of "a"],
        frule ideal_contained_maxid[of "R \<diamondsuit>\<^sub>p a"], assumption)
  apply (rule contrapos_pp, simp+,
         frule ideal_inc_one[of "R \<diamondsuit>\<^sub>p a"], assumption,
         simp add:nonunit_principal_id)
 apply (erule exE, erule conjE)
  apply (frule a_in_principal[of "a"])
  apply (frule_tac B = mx in subsetD[of "R \<diamondsuit>\<^sub>p a" _ "a"], assumption, blast)
 done
 
 definition
   local_ring :: "_ \<Rightarrow> bool" where
   "local_ring R == Ring R \<and> \<not> zeroring R \<and> card {mx. maximal_ideal R mx} = 1"
 
 lemma (in Ring) local_ring_diff:"\<lbrakk>\<not> zeroring R; ideal R mx; mx \<noteq> carrier R;
   \<forall>a\<in> (carrier R - mx). Unit R a \<rbrakk> \<Longrightarrow> local_ring R \<and> maximal_ideal R mx"
 apply (subgoal_tac "{mx} = {m. maximal_ideal R m}")
  apply (cut_tac singletonI[of "mx"], simp)
  apply (frule sym, thin_tac "{mx} = {m. maximal_ideal R m}")
  apply (simp add:local_ring_def, simp add:Ring)
 apply (rule equalityI)
  apply (rule subsetI, simp)
  apply (simp add:maximal_ideal_def)
  apply (simp add:ideal_inc_one1[of "mx", THEN sym])
  apply (thin_tac "x = mx", simp)
  apply (rule equalityI)
   apply (rule subsetI, simp, erule conjE)
   apply (case_tac "x \<noteq> mx")
   apply (frule_tac A = x and B = mx in sets_not_eq, assumption)
   apply (erule bexE)
   apply (frule_tac h = a and I = x in ideal_subset, assumption+)
   apply (frule_tac x = a in bspec, simp)
   apply (frule_tac I = x and a = a in ideal_inc_unit1, assumption+,
         simp)
   apply simp
 
   apply (rule subsetI, simp)
   apply (erule disjE)
   apply simp
   apply (simp add:whole_ideal ideal_subset1)
 
 apply (rule subsetI)
  apply simp
  apply (subgoal_tac "x \<subseteq> mx",
         thin_tac "\<forall>a\<in>carrier R - mx. Unit R a",
         simp add:maximal_ideal_def, (erule conjE)+)
  apply (subgoal_tac "mx \<in> {J. ideal R J \<and> x \<subseteq> J}", simp)
  apply (thin_tac "{J. ideal R J \<and> x \<subseteq> J} = {x, carrier R}")
  apply simp
 
  apply (rule contrapos_pp, simp+)
  apply (simp add:subset_eq, erule bexE)
  apply (frule_tac mx = x in maximal_ideal_ideal,
         frule_tac x = xa in bspec,
         thin_tac "\<forall>a\<in>carrier R - mx. Unit R a", simp,
         simp add:ideal_subset)
  apply (frule_tac I = x and a = xa in ideal_inc_unit, assumption+,
                   simp add:maximal_ideal_def)
 done
 
 lemma (in Ring) localring_unit:"\<lbrakk>\<not> zeroring R; maximal_ideal R mx;
                 \<forall>x. x \<in> mx \<longrightarrow> Unit R (x \<plusminus> 1\<^sub>r) \<rbrakk> \<Longrightarrow> local_ring R"
 apply (frule maximal_ideal_ideal[of "mx"])
 apply (frule local_ring_diff[of "mx"], assumption)
  apply (simp add:maximal_ideal_def, erule conjE)
  apply (simp add:ideal_inc_one1[THEN sym, of "mx"])
  apply (rule ballI, simp, erule conjE)
 
  apply (frule_tac x = a in maximal_prime_Tr0[of "mx"], assumption+)
 
  apply (frule sym, thin_tac "mx \<minusplus> R \<diamondsuit>\<^sub>p a = carrier R",
         cut_tac ring_one,
         frule_tac a = "1\<^sub>r" and A = "carrier R" and B = "mx \<minusplus> R \<diamondsuit>\<^sub>p a" in
                   eq_set_inc, assumption+,
         thin_tac "carrier R = mx \<minusplus> R \<diamondsuit>\<^sub>p a")
  apply (frule_tac a = a in principal_ideal,
        frule ideal_subset1[of mx],
        frule_tac I = "R \<diamondsuit>\<^sub>p a" in ideal_subset1)
  apply (cut_tac ring_is_ag,
         simp add:aGroup.set_sum, (erule bexE)+)
  apply (simp add:Rxa_def, erule bexE, simp)
  apply (frule sym, thin_tac "1\<^sub>r = h \<plusminus> r \<cdot>\<^sub>r a",
         frule_tac x = r and y = a in ring_tOp_closed, assumption+,
         frule_tac h = h in ideal_subset[of "mx"], assumption+)
  apply (frule_tac I = mx and x = h in ideal_inv1_closed, assumption)
  apply (frule_tac a = "-\<^sub>a h" in forall_spec, assumption,
         thin_tac "\<forall>x. x \<in> mx \<longrightarrow> Unit R (x \<plusminus> (h \<plusminus> r \<cdot>\<^sub>r a))",
         thin_tac "h \<plusminus> r \<cdot>\<^sub>r a = 1\<^sub>r")
  apply (frule_tac h = "-\<^sub>a h" in ideal_subset[of "mx"], assumption,
         frule_tac x1 = "-\<^sub>a h" and y1 = h and z1 = "r \<cdot>\<^sub>r a" in
         aGroup.ag_pOp_assoc[THEN sym], assumption+,
         simp add:aGroup.ag_l_inv1 aGroup.ag_l_zero,
         thin_tac "k = r \<cdot>\<^sub>r a", thin_tac "h \<plusminus> r \<cdot>\<^sub>r a \<in> carrier R",
         thin_tac "h \<in> carrier R", thin_tac "-\<^sub>a h \<in> mx",
         thin_tac "-\<^sub>a h \<plusminus> (h \<plusminus> r \<cdot>\<^sub>r a) = r \<cdot>\<^sub>r a")
  apply (simp add:ring_tOp_commute, simp add:Unit_def, erule bexE,
         simp add:ring_tOp_assoc,
         frule_tac x = r and y = b in ring_tOp_closed, assumption+, blast)
  apply simp
 done
 
 definition
   J_rad ::"_ \<Rightarrow> 'a set" where
   "J_rad R = (if (zeroring R) then (carrier R) else
                  \<Inter> {mx. maximal_ideal R mx})"
   (** if zeroring R then \<Inter> {mx. maximal_ideal R mx} is UNIV, hence
       we restrict UNIV to carrier R **)
 
 lemma (in Ring) zeroring_J_rad_empty:"zeroring R \<Longrightarrow> J_rad R = carrier R"
 by (simp add:J_rad_def)
 
 lemma (in Ring) J_rad_mem:"x \<in> J_rad R \<Longrightarrow> x \<in> carrier R"
 apply (simp add:J_rad_def)
 apply (case_tac "zeroring R", simp)
 apply simp
 apply (frule id_maximal_Exist, erule exE)
  apply (frule_tac a = I in forall_spec, assumption,
         thin_tac "\<forall>xa. maximal_ideal R xa \<longrightarrow> x \<in> xa")
  apply (frule maximal_ideal_ideal,
         simp add:ideal_subset)
 done
 
 lemma (in Ring) J_rad_unit:"\<lbrakk>\<not> zeroring R; x \<in> J_rad R\<rbrakk> \<Longrightarrow>
             \<forall>y. (y\<in> carrier R \<longrightarrow> Unit R (1\<^sub>r \<plusminus> (-\<^sub>a x) \<cdot>\<^sub>r y))"
 apply (cut_tac ring_is_ag,
        rule allI, rule impI,
        rule contrapos_pp, simp+)
 apply (frule J_rad_mem[of "x"],
        frule_tac x = x and y = y in ring_tOp_closed, assumption,
        frule_tac x = "x \<cdot>\<^sub>r y" in aGroup.ag_mOp_closed, assumption+)
 apply (cut_tac ring_one,
       frule_tac x = "1\<^sub>r" and y = "-\<^sub>a (x \<cdot>\<^sub>r y)" in aGroup.ag_pOp_closed,
       assumption+)
  apply (frule_tac a = "1\<^sub>r \<plusminus> -\<^sub>a (x \<cdot>\<^sub>r y)" in nonunit_contained_maxid,
         assumption+, simp add:ring_inv1_1)
 apply (erule exE, erule conjE)
  apply (simp add:J_rad_def,
         frule_tac a = mx in forall_spec, assumption,
         thin_tac "\<forall>xa. maximal_ideal R xa \<longrightarrow> x \<in> xa",
         frule_tac mx = mx in maximal_ideal_ideal,
         frule_tac I = mx and x = x and r = y in ideal_ring_multiple1,
         assumption+)
  apply (frule_tac I = mx and x = "x \<cdot>\<^sub>r y" in ideal_inv1_closed,
            assumption+)
 
  apply (frule_tac I = mx and a = "1\<^sub>r" and b = "-\<^sub>a (x \<cdot>\<^sub>r y)" in ideal_ele_sumTr2,
         assumption+)
  apply (simp add:maximal_ideal_def)
 done
 
 end
diff --git a/thys/List-Infinite/CommonArith/Util_Div.thy b/thys/List-Infinite/CommonArith/Util_Div.thy
--- a/thys/List-Infinite/CommonArith/Util_Div.thy
+++ b/thys/List-Infinite/CommonArith/Util_Div.thy
@@ -1,1239 +1,1239 @@
 (*  Title:      Util_Div.thy
     Date:       Oct 2006
     Author:     David Trachtenherz
 *)
 
 section \<open>Results for division and modulo operators on integers\<close>
 
 theory Util_Div
 imports Util_Nat
 begin
 
 subsection \<open>Additional (in-)equalities with \<open>div\<close> and \<open>mod\<close>\<close>
 
 corollary Suc_mod_le_divisor: "0 < m \<Longrightarrow> Suc (n mod m) \<le> m"
 by (rule Suc_leI, rule mod_less_divisor)
 
 lemma mod_less_dividend: "\<lbrakk> 0 < m; m \<le> n \<rbrakk> \<Longrightarrow> n mod m < (n::nat)"
 by (rule less_le_trans[OF mod_less_divisor])
 (*lemma mod_le_dividend: "n mod m \<le> (n::nat)"*)
 lemmas mod_le_dividend = mod_less_eq_dividend
 
 
 
 lemma diff_mod_le: "(t - r) mod m \<le> (t::nat)"
 by (rule le_trans[OF mod_le_dividend, OF diff_le_self])
 
 
 (*corollary div_mult_cancel: "m div n * n = m - m mod (n::nat)"*)
 lemmas div_mult_cancel = minus_mod_eq_div_mult [symmetric]
 
 lemma mod_0_div_mult_cancel: "(n mod (m::nat) = 0) = (n div m * m = n)"
 apply (insert eq_diff_left_iff[OF mod_le_dividend le0, of n m])
 apply (simp add: mult.commute minus_mod_eq_mult_div [symmetric])
 done
 
 lemma div_mult_le: "(n::nat) div m * m \<le> n"
 by (simp add: mult.commute minus_mod_eq_mult_div [symmetric])
 lemma less_div_Suc_mult: "0 < (m::nat) \<Longrightarrow> n < Suc (n div m) * m"
 apply (simp add: mult.commute minus_mod_eq_mult_div [symmetric])
 apply (rule less_add_diff)
 by (rule mod_less_divisor)
 
 lemma nat_ge2_conv: "((2::nat) \<le> n) = (n \<noteq> 0 \<and> n \<noteq> 1)"
 by fastforce
 
 lemma Suc0_mod: "m \<noteq> Suc 0 \<Longrightarrow> Suc 0 mod m = Suc 0"
 by (case_tac m, simp_all)
 corollary Suc0_mod_subst: "
   \<lbrakk> m \<noteq> Suc 0; P (Suc 0) \<rbrakk> \<Longrightarrow> P (Suc 0 mod m)"
 by (blast intro: subst[OF Suc0_mod[symmetric]])
 corollary Suc0_mod_cong: "
   m \<noteq> Suc 0 \<Longrightarrow> f (Suc 0 mod m) = f (Suc 0)"
 by (blast intro: arg_cong[OF Suc0_mod])
 
 
 subsection \<open>Additional results for addition and subtraction with \<open>mod\<close>\<close>
 
 lemma mod_Suc_conv: "
   ((Suc a) mod m = (Suc b) mod m) = (a mod m = b mod m)"
 by (simp add: mod_Suc)
 
 lemma mod_Suc': "
   0 < n \<Longrightarrow> Suc m mod n = (if m mod n < n - Suc 0 then Suc (m mod n) else 0)"
 apply (simp add: mod_Suc)
 apply (intro conjI impI)
  apply simp
 apply (insert le_neq_trans[OF mod_less_divisor[THEN Suc_leI, of n m]], simp)
 done
 
 lemma mod_add:"
   ((a + k) mod m = (b + k) mod m) =
   ((a::nat) mod m = b mod m)"
 by (induct "k", simp_all add: mod_Suc_conv)
 
 corollary mod_sub_add: "
   k \<le> (a::nat) \<Longrightarrow>
   ((a - k) mod m = b mod m) = (a mod m = (b + k) mod m)"
 by (simp add: mod_add[where m=m and a="a-k" and b=b and k=k, symmetric])
 
 
 lemma mod_sub_eq_mod_0_conv: "
   a + b \<le> (n::nat) \<Longrightarrow>
   ((n - a) mod m = b mod m) = ((n - (a + b)) mod m = 0)"
 by (insert mod_add[of "n-(a+b)" b m 0], simp)
 lemma mod_sub_eq_mod_swap: "
   \<lbrakk> a \<le> (n::nat); b \<le> n \<rbrakk> \<Longrightarrow>
   ((n - a) mod m = b mod m) = ((n - b) mod m = a mod m)"
 by (simp add: mod_sub_add add.commute)
 
 lemma le_mod_greater_imp_div_less: "
   \<lbrakk> a \<le> (b::nat); a mod m > b mod m \<rbrakk> \<Longrightarrow> a div m < b div m"
 apply (rule ccontr, simp add: linorder_not_less)
 apply (drule mult_le_mono1[of "b div m" _ m])
 apply (drule add_less_le_mono[of "b mod m" "a mod m" "b div m * m" "a div m * m"])
 apply simp_all
 done
 
 lemma less_mod_ge_imp_div_less: "\<lbrakk> a < (b::nat); a mod m \<ge> b mod m \<rbrakk> \<Longrightarrow> a div m < b div m"
 apply (case_tac "m = 0", simp)
 apply (rule mult_less_cancel1[of m, THEN iffD1, THEN conjunct2])
 apply (simp add: minus_mod_eq_mult_div [symmetric])
 apply (rule order_less_le_trans[of _ "b - a mod m"])
 apply (rule diff_less_mono)
 apply simp+
 done
 corollary less_mod_0_imp_div_less: "\<lbrakk> a < (b::nat); b mod m = 0 \<rbrakk> \<Longrightarrow> a div m < b div m"
 by (simp add: less_mod_ge_imp_div_less)
 
 lemma mod_diff_right_eq: "
   (a::nat) \<le> b \<Longrightarrow> (b - a) mod m = (b - a mod m) mod m"
 proof -
   assume a_as:"a \<le> b"
   have "(b - a) mod m = (b - a + a div m * m) mod m" by simp
   also have "\<dots> = (b + a div m * m - a) mod m" using a_as by simp
   also have "\<dots> = (b + a div m * m - (a div m * m + a mod m)) mod m" by simp
   also have "\<dots> = (b + a div m * m - a div m * m - a mod m) mod m"
     by (simp only: diff_diff_left[symmetric])
   also have "\<dots> = (b - a mod m) mod m" by simp
   finally show ?thesis .
 qed
 corollary mod_eq_imp_diff_mod_eq: "
   \<lbrakk> x mod m = y mod m; x \<le> (t::nat); y \<le> t \<rbrakk> \<Longrightarrow>
   (t - x) mod m = (t - y) mod m"
 by (simp only: mod_diff_right_eq)
 lemma mod_eq_imp_diff_mod_eq2: "
   \<lbrakk> x mod m = y mod m; (t::nat) \<le> x; t \<le> y \<rbrakk> \<Longrightarrow>
   (x - t) mod m = (y - t) mod m"
 apply (case_tac "m = 0", simp+)
 apply (subst mod_mult_self2[of "x - t" m t, symmetric])
 apply (subst mod_mult_self2[of "y - t" m t, symmetric])
 apply (simp only: add_diff_assoc2 diff_add_assoc gr0_imp_self_le_mult2)
 apply (simp only: mod_add)
 done
 
 lemma divisor_add_diff_mod_if: "
   (m + b mod m - a mod m) mod (m::nat)= (
   if a mod m \<le> b mod m
   then (b mod m - a mod m)
   else (m + b mod m - a mod m))"
 apply (case_tac "m = 0", simp)
 apply clarsimp
 apply (subst diff_add_assoc, assumption)
 apply (simp only: mod_add_self1)
 apply (rule mod_less)
 apply (simp add: less_imp_diff_less)
 done
 corollary divisor_add_diff_mod_eq1: "
   a mod m \<le> b mod m \<Longrightarrow>
   (m + b mod m - a mod m) mod (m::nat) = b mod m - a mod m"
 by (simp add: divisor_add_diff_mod_if)
 corollary divisor_add_diff_mod_eq2: "
   b mod m < a mod m \<Longrightarrow>
   (m + b mod m - a mod m) mod (m::nat) = m + b mod m - a mod m"
 by (simp add: divisor_add_diff_mod_if)
 
 lemma mod_add_mod_if: "
   (a mod m + b mod m) mod (m::nat)= (
   if a mod m + b mod m < m
   then a mod m + b mod m
   else a mod m + b mod m - m)"
 apply (case_tac "m = 0", simp_all)
 apply (clarsimp simp: linorder_not_less)
 apply (simp add: mod_if[of "a mod m + b mod m"])
 apply (rule mod_less)
 apply (rule diff_less_conv[THEN iffD2], assumption)
 apply (simp add: add_less_mono)
 done
 corollary mod_add_mod_eq1: "
   a mod m + b mod m < m \<Longrightarrow>
   (a mod m + b mod m) mod (m::nat) = a mod m + b mod m"
 by (simp add: mod_add_mod_if)
 corollary mod_add_mod_eq2: "
   m \<le> a mod m + b mod m\<Longrightarrow>
   (a mod m + b mod m) mod (m::nat) = a mod m + b mod m - m"
 by (simp add: mod_add_mod_if)
 
 lemma mod_add1_eq_if: "
   (a + b) mod (m::nat) = (
   if (a mod m + b mod m < m) then a mod m + b mod m
   else a mod m + b mod m - m)"
 by (simp add: mod_add_eq[symmetric, of a b] mod_add_mod_if)
 
 lemma mod_add_eq_mod_conv: "0 < (m::nat) \<Longrightarrow>
   ((x + a) mod m = b mod m ) =
   (x mod m = (m + b mod m - a mod m) mod m)"
 apply (simp only: mod_add_eq[symmetric, of x a])
 apply (rule iffI)
  apply (drule sym)
  apply (simp add: mod_add_mod_if)
 apply (simp add: mod_add_left_eq le_add_diff_inverse2[OF trans_le_add1[OF mod_le_divisor]])
 done
 
 
 
 
 lemma mod_diff1_eq: "
   (a::nat) \<le> b \<Longrightarrow> (b - a) mod m = (m + b mod m - a mod m) mod m"
 apply (case_tac "m = 0", simp)
 apply simp
 proof -
   assume a_as:"a \<le> b"
     and m_as: "0 < m"
   have a_mod_le_b_s: "a mod m \<le> b"
     by (rule le_trans[of _ a], simp only: mod_le_dividend, simp only: a_as)
   have "(b - a) mod m = (b - a mod m) mod m"
     using a_as by (simp only: mod_diff_right_eq)
   also have "\<dots> = (b - a mod m + m) mod m"
     by simp
   also have "\<dots> = (b + m - a mod m) mod m"
     using a_mod_le_b_s by simp
   also have "\<dots> = (b div m * m + b mod m + m - a mod m) mod m"
     by simp
   also have "\<dots> = (b div m * m + (b mod m + m - a mod m)) mod m"
     by (simp add: diff_add_assoc[OF mod_le_divisor, OF m_as])
   also have "\<dots> = ((b mod m + m - a mod m) + b div m * m) mod m"
     by simp
   also have "\<dots> = (b mod m + m - a mod m) mod m"
     by simp
   also have "\<dots> = (m + b mod m - a mod m) mod m"
     by (simp only: add.commute)
   finally show ?thesis .
 qed
 corollary mod_diff1_eq_if: "
   (a::nat) \<le> b \<Longrightarrow> (b - a) mod m = (
     if a mod m \<le> b mod m then b mod m - a mod m
     else m + b mod m - a mod m)"
 by (simp only: mod_diff1_eq divisor_add_diff_mod_if)
 corollary mod_diff1_eq1: "
   \<lbrakk> (a::nat) \<le> b; a mod m \<le> b mod m \<rbrakk>
   \<Longrightarrow> (b - a) mod m = b mod m - a mod m"
 by (simp add: mod_diff1_eq_if)
 corollary mod_diff1_eq2: "
   \<lbrakk> (a::nat) \<le> b; b mod m < a mod m\<rbrakk>
   \<Longrightarrow> (b - a) mod m = m + b mod m - a mod m"
 by (simp add: mod_diff1_eq_if)
 
 
 subsubsection \<open>Divisor subtraction with \<open>div\<close> and \<open>mod\<close>\<close>
 
 lemma mod_diff_self1: "
   0 < (n::nat) \<Longrightarrow> (m - n) mod m = m - n"
 by (case_tac "m = 0", simp_all)
 lemma mod_diff_self2: "
   m \<le> (n::nat) \<Longrightarrow> (n - m) mod m = n mod m"
 by (simp add: mod_diff_right_eq)
 lemma mod_diff_mult_self1: "
   k * m \<le> (n::nat) \<Longrightarrow> (n - k * m) mod m = n mod m"
 by (simp add: mod_diff_right_eq)
 lemma mod_diff_mult_self2: "
   m * k \<le> (n::nat) \<Longrightarrow> (n - m * k) mod m = n mod m"
 by (simp only: mult.commute[of m k] mod_diff_mult_self1)
 
 lemma div_diff_self1: "0 < (n::nat) \<Longrightarrow> (m - n) div m = 0"
 by (case_tac "m = 0", simp_all)
 lemma div_diff_self2: "(n - m) div m = n div m - Suc 0"
 apply (case_tac "m = 0", simp)
 apply (case_tac "n < m", simp)
 apply (case_tac "n = m", simp)
 apply (simp add: div_if)
 done
 
 lemma div_diff_mult_self1: "
   (n - k * m) div m = n div m - (k::nat)"
 apply (case_tac "m = 0", simp)
 apply (case_tac "n < k * m")
  apply simp
  apply (drule div_le_mono[OF less_imp_le, of n _ m])
  apply simp
 apply (simp add: linorder_not_less)
 apply (rule iffD1[OF mult_cancel1_gr0[where k=m]], assumption)
 apply (subst diff_mult_distrib2)
 apply (simp only: minus_mod_eq_mult_div [symmetric])
 apply (simp only: diff_commute[of _ "k*m"])
 apply (simp only: mult.commute[of m])
 apply (simp only: mod_diff_mult_self1)
 done
 lemma div_diff_mult_self2: "
   (n - m * k) div m = n div m - (k::nat)"
 by (simp only: mult.commute div_diff_mult_self1)
 
 
 subsubsection \<open>Modulo equality and modulo of difference\<close>
 
 lemma mod_eq_imp_diff_mod_0:"
   (a::nat) mod m = b mod m \<Longrightarrow> (b - a) mod m = 0"
   (is "?P \<Longrightarrow> ?Q")
 proof -
   assume as1: ?P
   have "b - a = b div m * m + b mod m - (a div m * m + a mod m)"
     by simp
   also have "\<dots> = b div m * m + b mod m - (a mod m + a div m * m)"
     by simp
   also have "\<dots> = b div m * m + b mod m - a mod m - a div m * m"
     by simp
   also have "\<dots> = b div m * m + b mod m - b mod m - a div m * m"
     using as1 by simp
   also have "\<dots> = b div m * m - a div m * m"
     by (simp only: diff_add_inverse2)
   also have "\<dots> = (b div m - a div m) * m"
     by (simp only: diff_mult_distrib)
   finally have "b - a = (b div m - a div m) * m" .
   hence "(b - a) mod m = (b div m - a div m) * m mod m"
     by (rule arg_cong)
   thus ?thesis by (simp only: mod_mult_self2_is_0)
 qed
 corollary mod_eq_imp_diff_dvd: "
   (a::nat) mod m = b mod m \<Longrightarrow> m dvd b - a"
 by (rule dvd_eq_mod_eq_0[THEN iffD2, OF mod_eq_imp_diff_mod_0])
 
 lemma mod_neq_imp_diff_mod_neq0:"
   \<lbrakk> (a::nat) mod m \<noteq> b mod m; a \<le> b \<rbrakk> \<Longrightarrow> 0 < (b - a) mod m"
 apply (case_tac "m = 0", simp)
 apply (drule le_imp_less_or_eq, erule disjE)
  prefer 2
  apply simp
 apply (drule neq_iff[THEN iffD1], erule disjE)
  apply (simp add: mod_diff1_eq1)
 apply (simp add: mod_diff1_eq2[OF less_imp_le] trans_less_add1[OF mod_less_divisor])
 done
 corollary mod_neq_imp_diff_not_dvd:"
   \<lbrakk> (a::nat) mod m \<noteq> b mod m; a \<le> b \<rbrakk> \<Longrightarrow> \<not> m dvd b - a"
 by (simp add: dvd_eq_mod_eq_0 mod_neq_imp_diff_mod_neq0)
 
 lemma diff_mod_0_imp_mod_eq:"
   \<lbrakk> (b - a) mod m = 0; a \<le> b \<rbrakk> \<Longrightarrow> (a::nat) mod m = b mod m"
 apply (rule ccontr)
 apply (drule mod_neq_imp_diff_mod_neq0)
 apply simp_all
 done
 corollary diff_dvd_imp_mod_eq:"
   \<lbrakk> m dvd b - a; a \<le> b \<rbrakk> \<Longrightarrow> (a::nat) mod m = b mod m"
 by (rule dvd_eq_mod_eq_0[THEN iffD1, THEN diff_mod_0_imp_mod_eq])
 
 
 
 lemma mod_eq_diff_mod_0_conv: "
   a \<le> (b::nat) \<Longrightarrow> (a mod m = b mod m) = ((b - a) mod m = 0)"
 apply (rule iffI)
 apply (rule mod_eq_imp_diff_mod_0, assumption)
 apply (rule diff_mod_0_imp_mod_eq, assumption+)
 done
 corollary mod_eq_diff_dvd_conv: "
   a \<le> (b::nat) \<Longrightarrow> (a mod m = b mod m) = (m dvd b - a)"
 by (rule dvd_eq_mod_eq_0[symmetric, THEN subst], rule mod_eq_diff_mod_0_conv)
 
 
 subsection \<open>Some additional lemmata about integer \<open>div\<close> and \<open>mod\<close>\<close>
 
 lemma zmod_eq_imp_diff_mod_0:
   "a mod m = b mod m \<Longrightarrow> (b - a) mod m = 0" for a b m :: int
   by (simp add: mod_diff_cong)
   
 (*lemma int_mod_distrib: "int (n mod m) = int n mod int m"*)
 lemmas int_mod_distrib = zmod_int
 
 lemma zdiff_mod_0_imp_mod_eq__pos:"
   \<lbrakk> (b - a) mod m = 0; 0 < (m::int) \<rbrakk> \<Longrightarrow> a mod m = b mod m"
   (is "\<lbrakk> ?P; ?Pm \<rbrakk> \<Longrightarrow> ?Q")
 proof -
   assume as1: ?P
     and as2: "0 < m"
 
   obtain r1 where a_r1:"r1 = a mod m" by blast
   obtain r2 where b_r2:"r2 = b mod m" by blast
 
   obtain q1 where a_q1: "q1 = a div m" by blast
   obtain q2 where b_q2: "q2 = b div m" by blast
 
   have a_r1_q1: "a = m * q1 + r1"
     using a_r1 a_q1 by simp
   have b_r2_q2: "b = m * q2 + r2"
     using b_r2 b_q2 by simp
 
   have "b - a = m * q2 + r2 - (m * q1 + r1)"
     using a_r1_q1 b_r2_q2 by simp
   also have "\<dots> = m * q2 + r2 - m * q1 - r1"
     by simp
   also have "\<dots> = m * q2 - m * q1 + r2 - r1"
     by simp
   finally have "b - a = m * (q2 - q1) + (r2 - r1)"
     by (simp add: right_diff_distrib)
   hence "(b - a) mod m = (r2 - r1) mod m"
     by (simp add: mod_add_eq)
   hence r2_r1_mod_m_0:"(r2 - r1) mod m = 0" (is "?R1")
     by (simp only: as1)
 
   have "r1 = r2"
   proof (rule notI[of "r1 \<noteq> r2", simplified])
     assume as1': "r1 \<noteq> r2"
     have diff_le_s: "\<And>a b (m::int). \<lbrakk> 0 \<le> a; b < m \<rbrakk> \<Longrightarrow> b - a < m"
       by simp
-    have s_r1:"0 \<le> r1 \<and> r1 < m" and s_r2:"0 \<le> r2 \<and> r2 < m"
-      by (simp add: as2 a_r1 b_r2 pos_mod_conj)+
+    from as2 a_r1 b_r2 have s_r1:"0 \<le> r1 \<and> r1 < m" and s_r2:"0 \<le> r2 \<and> r2 < m"
+      by simp_all
     have mr2r1:"-m < r2 - r1" and r2r1m:"r2 - r1 < m"
       by (simp add: minus_less_iff[of m] s_r1 s_r2 diff_le_s)+
     have "0 \<le> r2 - r1 \<Longrightarrow> (r2 - r1) mod m = (r2 - r1)"
       using r2r1m by (blast intro: mod_pos_pos_trivial)
     hence s1_pos: "0 \<le> r2 - r1 \<Longrightarrow> r2 - r1 = 0"
       using r2_r1_mod_m_0 by simp
 
     have "(r2-r1) mod -m = 0"
       by (simp add: zmod_zminus2_eq_if[of "r2-r1" m, simplified] r2_r1_mod_m_0)
     moreover
     have "r2 - r1 \<le> 0 \<Longrightarrow> (r2 - r1) mod -m = r2 - r1"
       using mr2r1
       by (simp add: mod_neg_neg_trivial)
     ultimately have s1_neg:"r2 - r1 \<le> 0 \<Longrightarrow> r2 - r1 = 0"
       by simp
 
     have "r2 - r1 = 0"
       using s1_pos s1_neg linorder_linear by blast
     hence "r1 = r2" by simp
     thus False
       using as1' by blast
   qed
   thus ?thesis
     using a_r1 b_r2 by blast
 qed
 
 lemma zmod_zminus_eq_conv_pos: "
   0 < (m::int) \<Longrightarrow> (a mod - m = b mod - m) = (a mod m = b mod m)"
 apply (simp only: mod_minus_right neg_equal_iff_equal)
 apply (simp only: zmod_zminus1_eq_if)
 apply (split if_split)+
 apply (safe, simp_all)
 apply (insert pos_mod_bound[of m a] pos_mod_bound[of m b], simp_all)
 done
 lemma zmod_zminus_eq_conv: "
   ((a::int) mod - m = b mod - m) = (a mod m = b mod m)"
 apply (insert linorder_less_linear[of 0 m], elim disjE)
 apply (blast dest: zmod_zminus_eq_conv_pos)
 apply simp
 apply (simp add: zmod_zminus_eq_conv_pos[of "-m", symmetric])
 done
 
 lemma zdiff_mod_0_imp_mod_eq:"
   (b - a) mod m = 0 \<Longrightarrow> (a::int) mod m = b mod m"
 by (metis dvd_eq_mod_eq_0 mod_eq_dvd_iff)
 
 lemma zmod_eq_diff_mod_0_conv: "
   ((a::int) mod m = b mod m) = ((b - a) mod m = 0)"
 apply (rule iffI)
 apply (rule zmod_eq_imp_diff_mod_0, assumption)
 apply (rule zdiff_mod_0_imp_mod_eq, assumption)
 done
 
 lemma "\<not>(\<exists>(a::int) b m. (b - a) mod m = 0 \<and> a mod m \<noteq> b mod m)"
 by (simp add: zmod_eq_diff_mod_0_conv)
 lemma "\<exists>(a::nat) b m. (b - a) mod m = 0 \<and> a mod m \<noteq> b mod m"
 apply (rule_tac x=1 in exI)
 apply (rule_tac x=0 in exI)
 apply (rule_tac x=2 in exI)
 apply simp
 done
 
 
 
 lemma zmult_div_leq_mono:"
   \<lbrakk> (0::int) \<le> x; a \<le> b; 0 < d \<rbrakk> \<Longrightarrow> x * a div d \<le> x * b div d"
 by (metis mult_right_mono zdiv_mono1 mult.commute)
 
 lemma zmult_div_leq_mono_neg:"
   \<lbrakk> x \<le> (0::int); a \<le> b; 0 < d \<rbrakk> \<Longrightarrow> x * b div d \<le> x * a div d"
 by (metis mult_left_mono_neg zdiv_mono1)
 
 lemma zmult_div_pos_le:"
   \<lbrakk> (0::int) \<le> a; 0 \<le> b; b \<le> c \<rbrakk> \<Longrightarrow> a * b div c \<le> a"
 apply (case_tac "b = 0", simp)
 apply (subgoal_tac "b * a \<le> c * a")
  prefer 2
  apply (simp only: mult_right_mono)
 apply (simp only: mult.commute)
 apply (subgoal_tac "a * b div c \<le> a * c div c")
  prefer 2
  apply (simp only: zdiv_mono1)
 apply simp
 done
 
 lemma zmult_div_neg_le:"
   \<lbrakk> a \<le> (0::int); 0 < c; c \<le> b \<rbrakk> \<Longrightarrow> a * b div c \<le> a"
 apply (subgoal_tac "b * a \<le> c * a")
  prefer 2
  apply (simp only: mult_right_mono_neg)
 apply (simp only: mult.commute)
 apply (subgoal_tac "a * b div c \<le> a * c div c")
  prefer 2
  apply (simp only: zdiv_mono1)
 apply simp
 done
 
 lemma zmult_div_ge_0:"\<lbrakk> (0::int) \<le> x; 0 \<le> a; 0 < c \<rbrakk> \<Longrightarrow> 0 \<le> a * x div c"
 by (metis pos_imp_zdiv_nonneg_iff split_mult_pos_le)
 
 corollary zmult_div_plus_ge_0: "
   \<lbrakk> (0::int) \<le> x; 0 \<le> a; 0 \<le> b; 0 < c\<rbrakk> \<Longrightarrow> 0 \<le> a * x div c + b"
 by (insert zmult_div_ge_0[of x a c], simp)
 
 
 lemma zmult_div_abs_ge: "
   \<lbrakk> (0::int) \<le> b; b \<le> b'; 0 \<le> a; 0 < c\<rbrakk> \<Longrightarrow>
   \<bar>a * b div c\<bar> \<le> \<bar>a * b' div c\<bar>"
 apply (insert zmult_div_ge_0[of b a c] zmult_div_ge_0[of "b'" a c], simp)
 by (metis zmult_div_leq_mono)
 
 lemma zmult_div_plus_abs_ge: "
   \<lbrakk> (0::int) \<le> b; b \<le> b'; 0 \<le> a; 0 < c \<rbrakk> \<Longrightarrow>
   \<bar>a * b div c + a\<bar> \<le> \<bar>a * b' div c + a\<bar>"
 apply (insert zmult_div_plus_ge_0[of b a a c] zmult_div_plus_ge_0[of "b'" a a c], simp)
 by (metis zmult_div_leq_mono)
 
 
 subsection \<open>Some further (in-)equality results for \<open>div\<close> and \<open>mod\<close>\<close>
 
 lemma less_mod_eq_imp_add_divisor_le: "
   \<lbrakk> (x::nat) < y; x mod m = y mod m \<rbrakk> \<Longrightarrow> x + m \<le> y"
 apply (case_tac "m = 0")
  apply simp
 apply (rule contrapos_pp[of "x mod m = y mod m"])
  apply blast
 apply (rule ccontr, simp only: not_not, clarify)
 proof -
   assume m_greater_0: "0 < m"
   assume x_less_y:"x < y"
   hence y_x_greater_0:"0 < y - x"
     by simp
   assume "x mod m = y mod m"
   hence y_x_mod_m: "(y - x) mod m = 0"
     by (simp only: mod_eq_imp_diff_mod_0)
   assume "\<not> x + m \<le> y"
   hence "y < x + m" by simp
   hence "y - x < x + m - x"
     by (simp add: diff_add_inverse diff_less_conv m_greater_0)
   hence y_x_less_m: "y - x < m"
     by simp
   have "(y - x) mod m = y - x"
     using y_x_less_m by simp
   hence "y - x = 0"
     using y_x_mod_m by simp
   thus False
     using y_x_greater_0 by simp
 qed
 
 
 lemma less_div_imp_mult_add_divisor_le: "
   (x::nat) < n div m \<Longrightarrow> x * m + m \<le> n"
 apply (case_tac "m = 0", simp)
 apply (case_tac "n < m", simp)
 apply (simp add: linorder_not_less)
 apply (subgoal_tac "m \<le> n - n mod m")
  prefer 2
  apply (drule div_le_mono[of m _ m])
  apply (simp only: div_self)
  apply (drule mult_le_mono2[of 1 _ m])
  apply (simp only: mult_1_right minus_mod_eq_mult_div [symmetric])
 apply (drule less_imp_le_pred[of x])
 apply (drule mult_le_mono2[of x _ m])
 apply (simp add: diff_mult_distrib2 minus_mod_eq_mult_div [symmetric] del: diff_diff_left)
 apply (simp only: le_diff_conv2[of m])
 apply (drule le_diff_imp_le[of "m * x + m"])
 apply (simp only: mult.commute[of _ m])
 done
 
 lemma mod_add_eq_imp_mod_0: "
   ((n + k) mod (m::nat) = n mod m) = (k mod m = 0)"
 by (metis add_eq_if mod_add mod_add_self1 mod_self add.commute)
 
 lemma between_imp_mod_between: "
   \<lbrakk> b < (m::nat); m * k + a \<le> n; n \<le> m * k + b \<rbrakk> \<Longrightarrow>
   a \<le> n mod m \<and> n mod m \<le> b"
   apply (case_tac "m = 0", simp_all)
   apply (frule gr_implies_gr0)
   apply (subgoal_tac "k = n div m")
    prefer 2
    apply (rule sym, rule div_nat_eqI) apply simp
    apply simp
   apply clarify
   apply (rule conjI)
    apply (rule add_le_imp_le_left[where c="m * (n div m)"], simp)+
   done
 
 corollary between_imp_mod_le: "
   \<lbrakk> b < (m::nat); m * k \<le> n; n \<le> m * k + b \<rbrakk> \<Longrightarrow> n mod m \<le> b"
 by (insert between_imp_mod_between[of b m k 0 n], simp)
 corollary between_imp_mod_gr0: "
   \<lbrakk> (m::nat) * k < n; n < m * k + m \<rbrakk> \<Longrightarrow> 0 < n mod m"
 apply (case_tac "m = 0", simp_all)
 apply (rule Suc_le_lessD)
 apply (rule between_imp_mod_between[THEN conjunct1, of "m - Suc 0" m k "Suc 0" n])
 apply simp_all
 done
 
 corollary le_less_div_conv: "
   0 < m \<Longrightarrow> (k * m \<le> n \<and> n < Suc k * m) = (n div m = k)"
   by (auto simp add: ac_simps intro: div_nat_eqI dividend_less_times_div)
 
 lemma le_less_imp_div: "
   \<lbrakk> k * m \<le> n; n < Suc k * m \<rbrakk> \<Longrightarrow> n div m = k"
   by (auto simp add: ac_simps intro: div_nat_eqI)  
 
 lemma div_imp_le_less: "
   \<lbrakk> n div m = k; 0 < m \<rbrakk> \<Longrightarrow> k * m \<le> n \<and> n < Suc k * m"
   by (auto simp add: ac_simps intro: dividend_less_times_div)
 
 lemma div_le_mod_le_imp_le: "
   \<lbrakk> (a::nat) div m \<le> b div m; a mod m \<le> b mod m \<rbrakk> \<Longrightarrow> a \<le> b"
 apply (rule subst[OF mult_div_mod_eq[of m a]])
 apply (rule subst[OF mult_div_mod_eq[of m b]])
 apply (rule add_le_mono)
 apply (rule mult_le_mono2)
 apply assumption+
 done
 
 lemma le_mod_add_eq_imp_add_mod_le: "
   \<lbrakk> a \<le> b; (a + k) mod m = (b::nat) mod m \<rbrakk> \<Longrightarrow> a + k mod m \<le> b"
 by (metis add_le_mono2 diff_add_inverse le_add1 le_add_diff_inverse mod_diff1_eq mod_less_eq_dividend)
 
 corollary mult_divisor_le_mod_ge_imp_ge: "
   \<lbrakk> (m::nat) * k \<le> n; r \<le> n mod m \<rbrakk> \<Longrightarrow> m * k + r \<le> n"
 apply (insert le_mod_add_eq_imp_add_mod_le[of "m * k" n "n mod m" m])
 apply (simp add: add.commute[of "m * k"])
 done
 
 
 subsection \<open>Additional multiplication results for \<open>mod\<close> and \<open>div\<close>\<close>
 
 lemma mod_0_imp_mod_mult_right_0: "
   n mod m = (0::nat) \<Longrightarrow> n * k mod m = 0"
 by fastforce
 lemma mod_0_imp_mod_mult_left_0: "
   n mod m = (0::nat) \<Longrightarrow> k * n mod m = 0"
 by fastforce
 
 lemma mod_0_imp_div_mult_left_eq: "
   n mod m = (0::nat) \<Longrightarrow> k * n div m = k * (n div m)"
 by fastforce
 lemma mod_0_imp_div_mult_right_eq: "
   n mod m = (0::nat) \<Longrightarrow> n * k div m = k * (n div m)"
 by fastforce
 
 
 lemma mod_0_imp_mod_factor_0_left: "
   n mod (m * m') = (0::nat) \<Longrightarrow> n mod m = 0"
 by fastforce
 lemma mod_0_imp_mod_factor_0_right: "
   n mod (m * m') = (0::nat) \<Longrightarrow> n mod m' = 0"
 by fastforce
 
 
 subsection \<open>Some factor distribution facts for \<open>mod\<close>\<close>
 
 lemma mod_eq_mult_distrib: "
   (a::nat) mod m = b mod m \<Longrightarrow>
   a * k mod (m * k) = b * k mod (m * k)"
 by simp
 
 lemma mod_mult_eq_imp_mod_eq: "
   (a::nat) mod (m * k) = b mod (m * k) \<Longrightarrow> a mod m = b mod m"
 apply (simp only: mod_mult2_eq)
 apply (drule_tac arg_cong[where f="\<lambda>x. x mod m"])
 apply (simp add: add.commute)
 done
 corollary mod_eq_mod_0_imp_mod_eq: "
   \<lbrakk> (a::nat) mod m' = b mod m'; m' mod m = 0 \<rbrakk>
   \<Longrightarrow> a mod m = b mod m"
   using mod_mod_cancel [of m m' a] mod_mod_cancel [of m m' b] by auto
 
 lemma mod_factor_imp_mod_0: "
   \<lbrakk>(x::nat) mod (m * k) = y * k mod (m * k)\<rbrakk> \<Longrightarrow> x mod k = 0"
   (is "\<lbrakk> ?P1 \<rbrakk> \<Longrightarrow> ?Q")
 proof -
   assume as1: ?P1
   have "y * k mod (m * k) = y mod m * k"
     by simp
   hence "x mod (m * k) = y mod m * k"
     using as1 by simp
   hence "y mod m * k = k * (x div k mod m) + x mod k" (is "?l1 = ?r1")
     by (simp only: ac_simps mod_mult2_eq)
   hence "(y mod m * k) mod k = ?r1 mod k"
     by simp
   hence "0 = ?r1 mod k"
     by simp
   thus "x mod k = 0"
     by (simp add: mod_add_eq)
 qed
 corollary mod_factor_div: "
   \<lbrakk>(x::nat) mod (m * k) = y * k mod (m * k)\<rbrakk> \<Longrightarrow> x div k * k = x"
 by (blast intro: mod_factor_imp_mod_0[THEN mod_0_div_mult_cancel[THEN iffD1]])
 
 lemma mod_factor_div_mod:"
   \<lbrakk> (x::nat) mod (m * k) = y * k mod (m * k); 0 < k \<rbrakk>
   \<Longrightarrow> x div k mod m = y mod m"
   (is "\<lbrakk> ?P1; ?P2 \<rbrakk> \<Longrightarrow> ?L = ?R")
 proof -
   assume as1: ?P1
   assume as2: ?P2
   have x_mod_k_0: "x mod k = 0"
     using as1 by (blast intro: mod_factor_imp_mod_0)
   have "?L * k + x mod k = x mod (k * m)"
     by (simp only: mod_mult2_eq mult.commute[of _ k])
   hence "?L * k = x mod (k * m)"
     using x_mod_k_0 by simp
   hence "?L * k = y * k mod (m * k)"
     using as1 by (simp only: ac_simps)
   hence "?L * k = y mod m * k"
     by (simp only: mult_mod_left)
   thus ?thesis
     using as2 by simp
 qed
 
 
 subsection \<open>More results about quotient \<open>div\<close> with addition and subtraction\<close>
 
 lemma div_add1_eq_if: "0 < m \<Longrightarrow>
   (a + b) div (m::nat) = a div m + b div m + (
     if a mod m + b mod m < m then 0 else Suc 0)"
 apply (simp only: div_add1_eq[of a b])
 apply (rule arg_cong[of "(a mod m + b mod m) div m"])
 apply (clarsimp simp: linorder_not_less)
 apply (rule le_less_imp_div[of "Suc 0" m "a mod m + b mod m"], simp)
 apply simp
 apply (simp only: add_less_mono[OF mod_less_divisor mod_less_divisor])
 done
 corollary div_add1_eq1: "
   a mod m + b mod m < (m::nat) \<Longrightarrow>
   (a + b) div (m::nat) = a div m + b div m"
 apply (case_tac "m = 0", simp)
 apply (simp add: div_add1_eq_if)
 done
 corollary div_add1_eq1_mod_0_left: "
   a mod m = 0 \<Longrightarrow> (a + b) div (m::nat) = a div m + b div m"
 apply (case_tac "m = 0", simp)
 apply (simp add: div_add1_eq1)
 done
 corollary div_add1_eq1_mod_0_right: "
   b mod m = 0 \<Longrightarrow> (a + b) div (m::nat) = a div m + b div m"
 by (fastforce simp: div_add1_eq1_mod_0_left)
 corollary div_add1_eq2: "
   \<lbrakk> 0 < m; (m::nat) \<le> a mod m + b mod m \<rbrakk> \<Longrightarrow>
   (a + b) div (m::nat) = Suc (a div m + b div m)"
 by (simp add: div_add1_eq_if)
 
 lemma div_Suc: "
   0 < n \<Longrightarrow> Suc m div n = (if Suc (m mod n) = n then Suc (m div n) else m div n)"
 apply (drule Suc_leI, drule le_imp_less_or_eq)
 apply (case_tac "n = Suc 0", simp)
 apply (split if_split, intro conjI impI)
  apply (rule_tac t="Suc m" and s="m + 1" in subst, simp)
  apply (subst div_add1_eq2, simp+)
 apply (insert le_neq_trans[OF mod_less_divisor[THEN Suc_leI, of n m]], simp)
 apply (rule_tac t="Suc m" and s="m + 1" in subst, simp)
 apply (subst div_add1_eq1, simp+)
 done
 lemma div_Suc': "
   0 < n \<Longrightarrow> Suc m div n = (if m mod n < n - Suc 0 then m div n else Suc (m div n))"
 apply (simp add: div_Suc)
 apply (intro conjI impI)
  apply simp
 apply (insert le_neq_trans[OF mod_less_divisor[THEN Suc_leI, of n m]], simp)
 done
 
 lemma div_diff1_eq_if: "
   (b - a) div (m::nat) =
   b div m - a div m - (if a mod m \<le> b mod m then 0 else Suc 0)"
 apply (case_tac "m = 0", simp)
 apply (case_tac "b < a")
  apply (frule less_imp_le[of b])
  apply (frule div_le_mono[of _ _ m])
  apply simp
 apply (simp only: linorder_not_less neq0_conv)
 proof -
   assume le_as: "a \<le> b"
     and m_as: "0 < m"
   have div_le:"a div m \<le> b div m"
     using le_as by (simp only: div_le_mono)
   have "b - a = b div m * m + b mod m - (a div m * m + a mod m)"
     by simp
   also have "\<dots> = b div m * m + b mod m - a div m * m - a mod m"
     by simp
   also have "\<dots> = b div m * m - a div m * m + b mod m - a mod m"
     by (simp only: diff_add_assoc2[OF mult_le_mono1[OF div_le]])
   finally have b_a_s1: "b - a = (b div m - a div m) * m + b mod m - a mod m"
     (is "?b_a = ?b_a1")
     by (simp only: diff_mult_distrib)
   hence b_a_div_s: "(b - a) div m =
     ((b div m - a div m) * m + b mod m - a mod m) div m"
     by (rule arg_cong)
 
   show ?thesis
   proof (cases "a mod m \<le> b mod m")
     case True
     hence as': "a mod m \<le> b mod m" .
 
     have "(b - a) div m = ?b_a1 div m"
       using b_a_div_s .
     also have "\<dots> = ((b div m - a div m) * m + (b mod m - a mod m)) div m"
       using as' by simp
     also have "\<dots> = b div m - a div m + (b mod m - a mod m) div m"
       apply (simp only: add.commute)
       by (simp only: div_mult_self1[OF less_imp_neq[OF m_as, THEN not_sym]])
     finally have b_a_div_s': "(b - a) div m = \<dots>" .
     have "(b mod m - a mod m) div m = 0"
       by (rule div_less, rule less_imp_diff_less,
           rule mod_less_divisor, rule m_as)
     thus ?thesis
       using b_a_div_s' as'
       by simp
   next
     case False
     hence as1': "\<not> a mod m \<le> b mod m" .
     hence as': "b mod m < a mod m" by simp
 
     have a_div_less: "a div m < b div m"
       using le_as as'
       by (blast intro: le_mod_greater_imp_div_less)
 
     have "b div m - a div m = b div m - a div m - (Suc 0 - Suc 0)"
       by simp
     also have "\<dots> = b div m - a div m + Suc 0 - Suc 0"
       by simp
     also have "\<dots> = b div m - a div m - Suc 0 + Suc 0"
       by (simp only: diff_add_assoc2
         a_div_less[THEN zero_less_diff[THEN iffD2], THEN Suc_le_eq[THEN iffD2]])
     finally have b_a_div_s': "b div m - a div m = \<dots>" .
 
     have "(b - a) div m = ?b_a1 div m"
       using b_a_div_s .
     also have "\<dots> = ((b div m - a div m - Suc 0 + Suc 0) * m
       + b mod m - a mod m ) div m"
       using b_a_div_s' by (rule arg_cong)
     also have "\<dots> = ((b div m - a div m - Suc 0) * m
       + Suc 0 * m + b mod m - a mod m ) div m"
       by (simp only: add_mult_distrib)
     also have "\<dots> = ((b div m - a div m - Suc 0) * m
       + m + b mod m - a mod m ) div m"
       by simp
     also have "\<dots> = ((b div m - a div m - Suc 0) * m
       + (m + b mod m - a mod m) ) div m"
       by (simp only: add.assoc m_as
         diff_add_assoc[of "a mod m" "m + b mod m"]
         trans_le_add1[of "a mod m" m, OF mod_le_divisor])
     also have "\<dots> = b div m - a div m - Suc 0
       + (m + b mod m - a mod m) div m"
       by (simp only: add.commute div_mult_self1[OF less_imp_neq[OF m_as, THEN not_sym]])
     finally have b_a_div_s': "(b - a) div m = \<dots>" .
 
     have div_0_s: "(m + b mod m - a mod m) div m = 0"
       by (rule div_less, simp only: add_diff_less m_as as')
     show ?thesis
       by (simp add: as1' b_a_div_s' div_0_s)
   qed
 qed
 
 corollary div_diff1_eq: "
   (b - a) div (m::nat) =
   b div m - a div m - (m + a mod m - Suc (b mod m)) div m"
 apply (case_tac "m = 0", simp)
 apply (simp only: neq0_conv)
 apply (rule subst[of
   "if a mod m \<le> b mod m then 0 else Suc 0"
   "(m + a mod m - Suc(b mod m)) div m"])
  prefer 2 apply (rule div_diff1_eq_if)
 apply (split if_split, rule conjI)
  apply simp
 apply (clarsimp simp: linorder_not_le)
 apply (rule sym)
 apply (drule Suc_le_eq[of "b mod m", THEN iffD2])
 apply (simp only: diff_add_assoc)
 apply (simp only: div_add_self1)
 apply (simp add: less_imp_diff_less)
 done
 
 corollary div_diff1_eq1: "
   a mod m \<le> b mod m \<Longrightarrow>
   (b - a) div (m::nat) = b div m - a div m"
 by (simp add: div_diff1_eq_if)
 corollary div_diff1_eq1_mod_0: "
   a mod m = 0 \<Longrightarrow>
   (b - a) div (m::nat) = b div m - a div m"
 by (simp add: div_diff1_eq1)
 corollary div_diff1_eq2: "
   b mod m < a mod m \<Longrightarrow>
   (b - a) div (m::nat) = b div m - Suc (a div m)"
 by (simp add: div_diff1_eq_if)
 
 
 subsection \<open>Further results about \<open>div\<close> and \<open>mod\<close>\<close>
 
 subsubsection \<open>Some auxiliary facts about \<open>mod\<close>\<close>
 
 lemma diff_less_divisor_imp_sub_mod_eq: "
   \<lbrakk> (x::nat) \<le> y; y - x < m \<rbrakk> \<Longrightarrow> x = y - (y - x) mod m"
 by simp
 lemma diff_ge_divisor_imp_sub_mod_less: "
   \<lbrakk> (x::nat) \<le> y; m \<le> y - x; 0 < m \<rbrakk> \<Longrightarrow> x < y - (y - x) mod m"
 apply (simp only: less_diff_conv)
 apply (simp only: le_diff_conv2 add.commute[of m])
 apply (rule less_le_trans[of _ "x + m"])
 apply simp_all
 done
 
 lemma le_imp_sub_mod_le: "
   (x::nat) \<le> y \<Longrightarrow> x \<le> y - (y - x) mod m"
 apply (case_tac "m = 0", simp_all)
 apply (case_tac "m \<le> y - x")
 apply (drule diff_ge_divisor_imp_sub_mod_less[of x y m])
 apply simp_all
 done
 
 lemma mod_less_diff_mod: "
   \<lbrakk> n mod m < r; r \<le> m; r \<le> (n::nat) \<rbrakk> \<Longrightarrow>
   (n - r) mod m = m + n mod m - r"
 apply (case_tac "r = m")
  apply (simp add: mod_diff_self2)
 apply (simp add: mod_diff1_eq[of r n m])
 done
 
 lemma mod_0_imp_mod_pred: "
   \<lbrakk> 0 < (n::nat); n mod m = 0 \<rbrakk> \<Longrightarrow>
   (n - Suc 0) mod m = m - Suc 0"
 apply (case_tac "m = 0", simp_all)
 apply (simp only: Suc_le_eq[symmetric])
 apply (simp only: mod_diff1_eq)
 apply (case_tac "m = Suc 0")
 apply simp_all
 done
 
 lemma mod_pred: "
   0 < n \<Longrightarrow>
   (n - Suc 0) mod m = (
     if n mod m = 0 then m - Suc 0 else n mod m - Suc 0)"
 apply (split if_split, rule conjI)
  apply (simp add: mod_0_imp_mod_pred)
 apply clarsimp
 apply (case_tac "m = Suc 0", simp)
 apply (frule subst[OF Suc0_mod[symmetric], where P="\<lambda>x. x \<le> n mod m"], simp)
 apply (simp only: mod_diff1_eq1)
 apply (simp add: Suc0_mod)
 done
 corollary mod_pred_Suc_mod: "
   0 < n \<Longrightarrow> Suc ((n - Suc 0) mod m) mod m = n mod m"
 apply (case_tac "m = 0", simp)
 apply (simp add: mod_pred)
 done
 corollary diff_mod_pred: "
   a < b \<Longrightarrow>
   (b - Suc a) mod m = (
     if a mod m = b mod m then m - Suc 0 else (b - a) mod m - Suc 0)"
 apply (rule_tac t="b - Suc a" and s="b - a - Suc 0" in subst, simp)
 apply (subst mod_pred, simp)
 apply (simp add: mod_eq_diff_mod_0_conv)
 done
 corollary diff_mod_pred_Suc_mod: "
   a < b \<Longrightarrow> Suc ((b - Suc a) mod m) mod m = (b - a) mod m"
 apply (case_tac "m = 0", simp)
 apply (simp add: diff_mod_pred mod_eq_diff_mod_0_conv)
 done
 
 lemma mod_eq_imp_diff_mod_eq_divisor: "
   \<lbrakk> a < b; 0 < m; a mod m = b mod m \<rbrakk> \<Longrightarrow>
   Suc ((b - Suc a) mod m) = m"
 apply (drule mod_eq_imp_diff_mod_0[of a])
 apply (frule iffD2[OF zero_less_diff])
 apply (drule mod_0_imp_mod_pred[of "b-a" m], assumption)
 apply simp
 done
 
 
 lemma sub_diff_mod_eq: "
   r \<le> t \<Longrightarrow> (t - (t - r) mod m) mod (m::nat) = r mod m"
 by (metis mod_diff_right_eq diff_diff_cancel diff_le_self)
 
 lemma sub_diff_mod_eq': "
   r \<le> t \<Longrightarrow> (k * m + t - (t - r) mod m) mod (m::nat) = r mod m"
 apply (simp only: diff_mod_le[of t r m, THEN add_diff_assoc, symmetric])
 apply (simp add: sub_diff_mod_eq)
 done
 
 lemma mod_eq_Suc_0_conv: "Suc 0 < k \<Longrightarrow> ((x + k - Suc 0) mod k = 0) = (x mod k = Suc 0)"
 apply (simp only: mod_pred)
 apply (case_tac "x mod k = Suc 0")
 apply simp_all
 done
 
 lemma mod_eq_divisor_minus_Suc_0_conv: "Suc 0 < k \<Longrightarrow> (x mod k = k - Suc 0) = (Suc x mod k = 0)"
 by (simp only: mod_Suc, split if_split, fastforce)
 
 
 subsubsection \<open>Some auxiliary facts about \<open>div\<close>\<close>
 
 lemma sub_mod_div_eq_div: "((n::nat) - n mod m) div m = n div m"
 apply (case_tac "m = 0", simp)
 apply (simp add: minus_mod_eq_mult_div)
 done
 
 lemma mod_less_imp_diff_div_conv: "
   \<lbrakk> n mod m < r; r \<le> m + n mod m\<rbrakk> \<Longrightarrow> (n - r) div m = n div m - Suc 0"
   apply (case_tac "m = 0", simp)
   apply (simp only: neq0_conv)
   apply (case_tac "n < m", simp)
   apply (simp only: linorder_not_less)
   apply (rule div_nat_eqI)
    apply (simp_all add: algebra_simps minus_mod_eq_mult_div [symmetric])
   done
 
 corollary mod_0_le_imp_diff_div_conv: "
   \<lbrakk> n mod m = 0; 0 < r; r \<le> m \<rbrakk> \<Longrightarrow> (n - r) div m = n div m - Suc 0"
 by (simp add: mod_less_imp_diff_div_conv)
 corollary mod_0_less_imp_diff_Suc_div_conv: "
   \<lbrakk> n mod m = 0; r < m \<rbrakk> \<Longrightarrow> (n - Suc r) div m = n div m - Suc 0"
 by (drule mod_0_le_imp_diff_div_conv[where r="Suc r"], simp_all)
 corollary mod_0_imp_diff_Suc_div_conv: "
   (n - r) mod m = 0 \<Longrightarrow> (n - Suc r) div m = (n - r) div m - Suc 0"
 apply (case_tac "m = 0", simp)
 apply (rule_tac t="n - Suc r" and s="n - r - Suc 0" in subst, simp)
 apply (rule mod_0_le_imp_diff_div_conv, simp+)
 done
 corollary mod_0_imp_sub_1_div_conv: "
   n mod m = 0 \<Longrightarrow> (n - Suc 0) div m = n div m - Suc 0"
 apply (case_tac "m = 0", simp)
 apply (simp add: mod_0_less_imp_diff_Suc_div_conv)
 done
 corollary sub_Suc_mod_div_conv: "
   (n - Suc (n mod m)) div m = n div m - Suc 0"
 apply (case_tac "m = 0", simp)
 apply (simp add: mod_less_imp_diff_div_conv)
 done
 
 
 lemma div_le_conv: "0 < m \<Longrightarrow> n div m \<le> k = (n \<le> Suc k * m - Suc 0)"
 apply (rule iffI)
  apply (drule mult_le_mono1[of _ _ m])
  apply (simp only: mult.commute[of _ m] minus_mod_eq_mult_div [symmetric])
  apply (drule le_diff_conv[THEN iffD1])
  apply (rule le_trans[of _ "m * k + n mod m"], assumption)
  apply (simp add: add.commute[of m])
  apply (simp only: diff_add_assoc[OF Suc_leI])
  apply (rule add_le_mono[OF le_refl])
  apply (rule less_imp_le_pred)
  apply (rule mod_less_divisor, assumption)
 apply (drule div_le_mono[of _ _ m])
 apply (simp add: mod_0_imp_sub_1_div_conv)
 done
 
 lemma le_div_conv: "0 < (m::nat) \<Longrightarrow> (n \<le> k div m) = (n * m \<le> k)"
 apply (rule iffI)
  apply (drule mult_le_mono1[of _ _ m])
  apply (simp add: div_mult_cancel)
 apply (drule div_le_mono[of _ _ m])
 apply simp
 done
 
 lemma less_mult_imp_div_less: "n < k * m \<Longrightarrow> n div m < (k::nat)"
 apply (case_tac "k = 0", simp)
 apply (case_tac "m = 0", simp)
 apply simp
 apply (drule less_imp_le_pred[of n])
 apply (drule div_le_mono[of _ _ m])
 apply (simp add: mod_0_imp_sub_1_div_conv)
 done
 
 lemma div_less_imp_less_mult: "\<lbrakk> 0 < (m::nat); n div m < k \<rbrakk> \<Longrightarrow> n < k * m"
 apply (rule ccontr, simp only: linorder_not_less)
 apply (drule div_le_mono[of _ _ m])
 apply simp
 done
 
 lemma div_less_conv: "0 < (m::nat) \<Longrightarrow> (n div m < k) = (n < k * m)"
 apply (rule iffI)
 apply (rule div_less_imp_less_mult, assumption+)
 apply (rule less_mult_imp_div_less, assumption)
 done
 
 lemma div_eq_0_conv: "(n div (m::nat) = 0) = (m = 0 \<or> n < m)"
 apply (rule iffI)
  apply (case_tac "m = 0", simp)
  apply (rule ccontr)
  apply (simp add: linorder_not_less)
  apply (drule div_le_mono[of _ _ m])
  apply simp
 apply fastforce
 done
 lemma div_eq_0_conv': "0 < m \<Longrightarrow> (n div (m::nat) = 0) = (n < m)"
 by (simp add: div_eq_0_conv)
 corollary div_gr_imp_gr_divisor: "x < n div (m::nat) \<Longrightarrow> m \<le> n"
 apply (drule gr_implies_gr0, drule neq0_conv[THEN iffD2])
 apply (simp add: div_eq_0_conv)
 done
 
 lemma mod_0_less_div_conv: "
   n mod (m::nat) = 0 \<Longrightarrow> (k * m < n) = (k < n div m)"
 apply (case_tac "m = 0", simp)
 apply fastforce
 done
 
 lemma add_le_divisor_imp_le_Suc_div: "
   \<lbrakk> x div m \<le> n; y \<le> m \<rbrakk> \<Longrightarrow> (x + y) div m \<le> Suc n"
 apply (case_tac "m = 0", simp)
 apply (simp only: div_add1_eq_if[of _ x])
 apply (drule order_le_less[of y, THEN iffD1], fastforce)
 done
 
 
 text \<open>List of definitions and lemmas\<close>
 
 thm
   minus_mod_eq_mult_div [symmetric]
   mod_0_div_mult_cancel
   div_mult_le
   less_div_Suc_mult
 thm
   Suc0_mod
   Suc0_mod_subst
   Suc0_mod_cong
 
 thm
   mod_Suc_conv
 
 thm
   mod_add
   mod_sub_add
 
 thm
   mod_sub_eq_mod_0_conv
   mod_sub_eq_mod_swap
 
 thm
   le_mod_greater_imp_div_less
 thm
   mod_diff_right_eq
   mod_eq_imp_diff_mod_eq
 
 thm
   divisor_add_diff_mod_if
   divisor_add_diff_mod_eq1
   divisor_add_diff_mod_eq2
 
 thm
   mod_add_eq
   mod_add1_eq_if
 thm
   mod_diff1_eq_if
   mod_diff1_eq
   mod_diff1_eq1
   mod_diff1_eq2
 
 thm
   nat_mod_distrib
   int_mod_distrib
 
 thm
   zmod_zminus_eq_conv
 
 thm
   mod_eq_imp_diff_mod_0
   zmod_eq_imp_diff_mod_0
 
 thm
   mod_neq_imp_diff_mod_neq0
   diff_mod_0_imp_mod_eq
   zdiff_mod_0_imp_mod_eq
 
 thm
   zmod_eq_diff_mod_0_conv
   mod_eq_diff_mod_0_conv
 
 thm
   less_mod_eq_imp_add_divisor_le
 thm
   mod_add_eq_imp_mod_0
 thm
   mod_eq_mult_distrib
   mod_factor_imp_mod_0
   mod_factor_div
   mod_factor_div_mod
 
 
 thm
   mod_diff_self1
   mod_diff_self2
   mod_diff_mult_self1
   mod_diff_mult_self2
 
 thm
   div_diff_self1
   div_diff_self2
   div_diff_mult_self1
   div_diff_mult_self2
 
 thm
   le_less_imp_div
   div_imp_le_less
 thm
   le_less_div_conv
 
 thm
   diff_less_divisor_imp_sub_mod_eq
   diff_ge_divisor_imp_sub_mod_less
   le_imp_sub_mod_le
 
 thm
   sub_mod_div_eq_div
 
 thm
   mod_less_imp_diff_div_conv
   mod_0_le_imp_diff_div_conv
   mod_0_less_imp_diff_Suc_div_conv
   mod_0_imp_sub_1_div_conv
 
 
 thm
   sub_Suc_mod_div_conv
 
 thm
   mod_less_diff_mod
   mod_0_imp_mod_pred
 
 thm
   mod_pred
   mod_pred_Suc_mod
 
 thm
   mod_eq_imp_diff_mod_eq_divisor
 
 thm
   diff_mod_le
   sub_diff_mod_eq
   sub_diff_mod_eq'
 
 thm
   div_diff1_eq_if
   div_diff1_eq
   div_diff1_eq1
   div_diff1_eq2
 
 
 thm
   div_le_conv
 
 end
diff --git a/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy b/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy
--- a/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy
+++ b/thys/Ordinary_Differential_Equations/Numerics/Example_Utilities.thy
@@ -1,2708 +1,2708 @@
 theory Example_Utilities
 imports
   Init_ODE_Solver
 begin
 
 definition "true_form = Less (floatarith.Num 0) (floatarith.Num 1)"
 
 lemma open_true_form[intro, simp]: "open_form true_form"
   by (auto simp: true_form_def)
 
 lemma max_Var_form_true_form[simp]: "max_Var_form true_form = 0"
   by (auto simp: true_form_def)
 
 lemma interpret_form_true_form[simp]: "interpret_form true_form = (\<lambda>_. True)"
   by (auto simp: true_form_def)
 
 lemmas [simp] = length_aforms_of_ivls
 
 declare INF_cong_simp [cong] SUP_cong_simp [cong] image_cong_simp [cong del]
 
 declare [[ cd_patterns "_ = interpret_floatariths ?fas _" "_ = interpret_floatarith ?fa _"]]
 
 concrete_definition reify_example for i j k uses reify_example
 
 hide_const (open) Print.file_output
 definition "file_output s f =
   (if s = STR ''''      then f (\<lambda>_. ())
   else if s = STR ''-'' then f print
   else                                  Print.file_output s f)"
 
 definition "aforms_of_point xs = aforms_of_ivls xs xs"
 
 definition "unit_matrix_list D = concat (map (\<lambda>i. map (\<lambda>j. if i = j then 1 else 0::real) [0..<D]) [0..<D])"
 
 definition "with_unit_matrix D X = (fst X @ unit_matrix_list D, snd X @ unit_matrix_list D)"
 
 definition "list_interval l u = {x. list_all2 (\<le>) l x \<and> list_all2 (\<le>) x u}"
 
 context includes lifting_syntax begin
 lemma list_interval_transfer[transfer_rule]:
   "((list_all2 A) ===> (list_all2 A) ===> rel_set (list_all2 A))
     list_interval list_interval"
   if [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)" "bi_total A"
   unfolding list_interval_def
   by transfer_prover
 end
 
 lemma in_list_interval_lengthD: "x \<in> list_interval a b \<Longrightarrow> length x = length a"
   by (auto simp: list_interval_def list_all2_lengthD)
 
 context includes floatarith_notation begin
 
 definition "varvec_fas' D C = ((map Var [0..<D]) @
       concat (map (\<lambda>b.
         (map (\<lambda>i. (Num (C i)) +
           Var (D + D * D) * (mvmult_fa D D (map Var [D..<D + D * D]) (map Num ((replicate D 0)[i:=1])) ! b)) [0..<D])) [0..<D]))"
 
 definition "varvec_fas D C = ((map Var [0..<D]) @
       concat (map (\<lambda>i. (map (\<lambda>j. (Num (C i)) + Var (D + D * D) * Var (D + D * i + j)) [0..<D])) [0..<D]))"
 
 lemma \<comment> \<open>for illustration\<close>
   assumes[simp]: "D=3" "rf = real_of_float"
   shows "interpret_floatariths (varvec_fas D (\<lambda>i. [a, b, c] ! i))
   [a, b, c, d11, d12, d13,
             d21, d22, d23,
             d31, d32, d33, 2] =
   [rf a, rf b, rf c,
   rf a + 2 * rf d11, rf a + 2 * rf d12, rf a + 2 * rf d13,
   rf b + 2 * rf d21, rf b + 2 * rf d22, rf b + 2 * rf d23,
   rf c + 2 * rf d31, rf c + 2 * rf d32, rf c + 2 * rf d33]"
   by (simp add: varvec_fas_def mvmult_fa_def eval_nat_numeral)
 
 definition "vareq_projections
     n  \<comment> \<open>dimension\<close>
     ps \<comment> \<open>pairs of coordinates to project onto\<close>
     ds \<comment> \<open>partial derivatives w.r.t. which variables\<close>
     cs \<comment> \<open>(color) coding for partial derivatives\<close>
   =
   [(i + n * (x + 1)::nat, i + n * (y + 1), c). (i, c) \<leftarrow> zip ds cs, (x, y) \<leftarrow> ps]"
 
 definition "varvec_aforms_line D X line =
   approx_floatariths
     30
     (varvec_fas D (\<lambda>i. float_of (fst (X ! i))))
     (take (D + D*D) X @ line)"
 
 definition "varvec_aforms_head D X s = varvec_aforms_line D X (aforms_of_point [s])"
 definition "varvec_aforms_vec D X s = varvec_aforms_line D (map (\<lambda>x. (fst x, zero_pdevs)) X) [aform_of_ivl 0 s]"
 
 definition
   "shows_aforms_vareq
       n                \<comment> \<open>dimension\<close>
       ps               \<comment> \<open>pairs of coordinates to project onto\<close>
       ds               \<comment> \<open>partial derivatives w.r.t. which variables\<close>
       csl              \<comment> \<open>color coding for partial derivatives ('arrow' heads)\<close>
       csh              \<comment> \<open>color coding for partial derivatives (lines)\<close>
       s                \<comment> \<open>scale vectors for partial derivatives\<close>
       (no_str::string) \<comment> \<open>default string if no C1 info is present\<close>
       X                \<comment> \<open>affine form with C1 info\<close>
    =
     (case (varvec_aforms_head n X s, varvec_aforms_vec n X s) of (Some X, Some Y) \<Rightarrow>
         shows_sep (\<lambda>(x, y, c). shows_segments_of_aform x y X c) shows_nl (vareq_projections n ps ds csl) o shows_nl
       o shows_sep (\<lambda>(x, y, c). shows_segments_of_aform x y Y c) shows_nl (vareq_projections n ps ds csh) o shows_nl
     | _ \<Rightarrow> shows_string no_str o shows_nl)"
 
 abbreviation "print_string s \<equiv> print (String.implode s)"
 abbreviation "print_show s \<equiv> print_string (s '''')"
 
 value [code] "print_show (shows_aforms_vareq 3 [(x, y). x \<leftarrow> [0..<3], y \<leftarrow> [0..<3], x < y]
   [0..<3] [''0x0000ff'', ''0x00ff00'', ''0xff0000''] [''0x0000ff'', ''0x00ff00'', ''0xff0000'']
   (FloatR 1 (-1)) ''# no C1 info''
     ((((\<lambda>(a, b). aforms_of_ivls a b) (with_unit_matrix 3 ([10, 20, 30], [12, 22, 32]))))))"
 
 method_setup guess_rhs = \<open>
 let
   fun compute ctxt var lhs =
     let
       val lhs' = Code_Evaluation.dynamic_value_strict ctxt lhs;
       val clhs' = Thm.cterm_of ctxt lhs';
       val inst = Thm.instantiate (TVars.empty, Vars.make [(var, clhs')]);
     in PRIMITIVE inst end;
   fun eval_schematic_rhs ctxt t = (case try (HOLogic.dest_eq o HOLogic.dest_Trueprop) t of
       SOME (lhs, Var var) => compute ctxt var lhs
     | _ => no_tac);
 in
   Scan.succeed (fn ctxt =>
     SIMPLE_METHOD (HEADGOAL (SUBGOAL (fn (t, _) => eval_schematic_rhs ctxt t))))
 end
 \<close>
 
 lemma length_aforms_of_point[simp]: "length (aforms_of_point xs) = length xs"
   by (auto simp: aforms_of_point_def)
 
 definition "aform2d_plot_segments x y a = shows_segments_of_aform x y a ''0x000000''"
 
 lemma list_of_eucl_prod[simp]: "list_of_eucl (x, y) = list_of_eucl x @ list_of_eucl y"
   by (auto simp: list_of_eucl_def Basis_list_prod_def intro!: nth_equalityI)
 
 lemma list_of_eucl_real[simp]: "list_of_eucl (x::real) = [x]"
   by (auto simp: list_of_eucl_def Basis_list_real_def)
 
 lemma Joints_aforms_of_ivls_self[simp]: "xs \<in> Joints (aforms_of_ivls xs xs)"
   by (auto intro!: aforms_of_ivls)
 
 lemma Joints_aforms_of_ivls_self_eq[simp]: "Joints (aforms_of_ivls xs xs) = {xs}"
   apply (auto )
   by (auto simp: aforms_of_ivls_def Joints_def valuate_def aform_val_def
       intro!: nth_equalityI)
 
 lemma local_lipschitz_c1_euclideanI:
   fixes T::"real set" and X::"'a::euclidean_space set"
     and f::"real \<Rightarrow> 'a \<Rightarrow> 'a"
   assumes f': "\<And>t x. t \<in> T \<Longrightarrow> x \<in> X \<Longrightarrow> (f t has_derivative f' t x) (at x)"
   assumes cont_f': "\<And>i. i \<in> Basis \<Longrightarrow> continuous_on (T \<times> X) (\<lambda>(t, x). f' t x i)"
   assumes "open T"
   assumes "open X"
   shows "local_lipschitz T X f"
   using assms
   apply (intro c1_implies_local_lipschitz[where f'="\<lambda>(t, x). Blinfun (f' t x)"])
      apply (auto simp: bounded_linear_Blinfun_apply has_derivative_bounded_linear split_beta'
       intro!: has_derivative_Blinfun continuous_on_blinfun_componentwise)
   apply (subst continuous_on_cong[OF refl]) defer apply assumption
   apply auto
   apply (subst bounded_linear_Blinfun_apply)
    apply (rule has_derivative_bounded_linear)
   by auto
 
 definition "list_aform_of_aform (x::real aform) = (fst x, list_of_pdevs (snd x))"
 primrec split_aforms_list:: "(real aform) list list
    \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (real aform) list list" where
   "split_aforms_list Xs i 0 = Xs"
 | "split_aforms_list Xs i (Suc n) = split_aforms_list (concat (map (\<lambda>x. (let (a, b) = split_aforms x i in [a, b])) Xs)) i n"
 
 definition "shows_aforms x y c X = shows_lines (map (\<lambda>b. (shows_segments_of_aform x y b c ''\<newline>'')) X)"
 
 end
 
 definition "the_odo ode_fas safe_form = the(mk_ode_ops ode_fas safe_form)"
 
 locale ode_interpretation =
   fixes safe_form::form and safe_set::"'a::executable_euclidean_space set"
     and ode_fas::"floatarith list"
     and ode::"'a \<Rightarrow> 'a"
     and finite::"'n::enum"
   assumes dims: "DIM('a) = CARD('n)"
   assumes len: "length ode_fas = CARD('n)"
   assumes safe_set_form: "safe_set = {x. interpret_form safe_form (list_of_eucl x)}"
   assumes interpret_fas: "\<And>x. x \<in> safe_set \<Longrightarrow> einterpret ode_fas (list_of_eucl x) = ode x"
   assumes odo: "mk_ode_ops ode_fas safe_form \<noteq> None"
   assumes isFDERIV: "\<And>xs. interpret_form safe_form xs \<Longrightarrow>
     isFDERIV (length ode_fas) [0..<length ode_fas] ode_fas xs"
 begin
 
 abbreviation "odo \<equiv> the_odo ode_fas safe_form"
 lemmas odo_def = the_odo_def
 
 lemma odo_simps[simp]: "ode_expression odo = ode_fas" "safe_form_expr odo = safe_form"
   using odo
   by (auto simp: odo_def ode_expression_mk_ode_ops safe_form_expr_mk_ode_ops)
 
 lemma safe_set: "safe_set = aform.Csafe odo"
   using odo dims safe_set_form isFDERIV
   unfolding aform.Csafe_def aform.safe_def aform.safe_form_def aform.ode_e_def
   by (auto simp: mk_ode_ops_def safe_set_form len split: if_splits)
 
 lemma ode: "\<And>x. x \<in> safe_set \<Longrightarrow> ode x = aform.ode odo x"
   by (auto simp: aform.ode_def aform.ode_e_def interpret_fas)
 
 sublocale auto_ll_on_open ode safe_set
   by (rule aform.auto_ll_on_open_congI[OF safe_set[symmetric] ode[symmetric]])
 
 lemma ode_has_derivative_ode_d1: "(ode has_derivative blinfun_apply (aform.ode_d1 odo x)) (at x)"
   if "x \<in> safe_set" for x
 proof -
   from aform.fderiv[OF that[unfolded safe_set]]
   have "(aform.ode odo has_derivative blinfun_apply (aform.ode_d1 odo x)) (at x)"
     by simp
   moreover
   from topological_tendstoD[OF tendsto_ident_at open_domain(2) that]
   have "\<forall>\<^sub>F x' in at x. x' \<in> safe_set" .
   then have "\<forall>\<^sub>F x' in at x. aform.ode odo x' = ode x'"
     by eventually_elim (auto simp: ode)
   ultimately show ?thesis
     by (rule has_derivative_transform_eventually) (auto simp: ode that)
 qed
 
 sublocale c1_on_open_euclidean ode "aform.ode_d1 odo" safe_set
   apply unfold_locales
   subgoal by simp
   subgoal by (simp add: ode_has_derivative_ode_d1)
   subgoal by (rule aform.cont_fderiv') (auto intro!: continuous_intros simp: safe_set)
   done
 
 sublocale transfer_eucl_vec for a::'a and n::'n
   by unfold_locales (simp add: dims)
 
 lemma flow_eq: "t \<in> existence_ivl0 x \<Longrightarrow> aform.flow0 odo x t = flow0 x t"
   and Dflow_eq: "t \<in> existence_ivl0 x \<Longrightarrow> aform.Dflow odo x t = Dflow x t"
   and ex_ivl_eq: "t \<in> aform.existence_ivl0 odo x \<Longrightarrow> aform.existence_ivl0 odo x = existence_ivl0 x"
   and poincare_mapsto_eq: "closed a \<Longrightarrow> aform.poincare_mapsto odo a b c d e = poincare_mapsto a b c d e"
   and flowsto_eq: "aform.flowsto odo = flowsto"
       apply -
   subgoal by (rule flow0_cong[symmetric]) (auto simp: safe_set ode)
   subgoal by (rule Dflow_cong[symmetric]) (auto simp: safe_set ode)
   subgoal by (rule existence_ivl0_cong[symmetric]) (auto simp: safe_set ode)
   subgoal
     apply (subst aform.poincare_mapsto_cong[OF safe_set[symmetric]])
     by (auto simp: ode)
   subgoal
     apply (intro ext)
     apply (subst flowsto_congI[OF safe_set ode])
     by (auto simp: safe_set)
   done
 
 definition "avf \<equiv> \<lambda>x::'n rvec. cast (aform.ode odo (cast x)::'a)::'n rvec"
 
 context includes lifting_syntax begin
 lemma aform_ode_transfer[transfer_rule]: "((=) ===> rel_ve ===> rel_ve) aform.ode aform.ode"
   unfolding aform.ode_def
   by transfer_prover
 lemma cast_aform_ode: "cast (aform.ode odo (cast (x::'n rvec))::'a) = aform.ode odo x"
   by transfer simp
 
 lemma aform_safe_transfer[transfer_rule]: "((=) ===> rel_ve ===> (=)) aform.safe aform.safe"
   unfolding aform.safe_def
   by transfer_prover
 
 lemma aform_Csafe_transfer[transfer_rule]: "((=) ===> rel_set rel_ve) aform.Csafe aform.Csafe"
   unfolding aform.Csafe_def
   by transfer_prover
 
 lemma cast_safe_set: "(cast ` safe_set::'n rvec set) = aform.Csafe odo"
   unfolding safe_set
   by transfer simp
 
 lemma aform_ode_d_raw_transfer[transfer_rule]:
   "((=) ===> (=) ===> rel_ve ===> rel_ve ===> rel_ve ===> rel_ve) aform.ode_d_raw aform.ode_d_raw"
   unfolding aform.ode_d_raw_def
   by transfer_prover
 
 lemma
   aform_ode_d_raw_aux_transfer:
   "((=) ===> rel_ve ===> rel_ve ===> rel_ve)
     (\<lambda>x xb xa. if xb \<in> aform.Csafe x then aform.ode_d_raw x 0 xb 0 xa else 0)
     (\<lambda>x xb xa. if xb \<in> aform.Csafe x then aform.ode_d_raw x 0 xb 0 xa else 0)"
   by transfer_prover
 
 lemma aform_ode_d1_transfer[transfer_rule]:
   "((=) ===> rel_ve ===> rel_blinfun rel_ve rel_ve) aform.ode_d1 aform.ode_d1"
   apply (auto simp: rel_blinfun_def aform.ode_d1_def intro!: rel_funI)
   unfolding aform.ode_d.rep_eq
   using aform_ode_d_raw_aux_transfer
   apply -
   apply (drule rel_funD, rule refl)
   apply (drule rel_funD, assumption)
   apply (drule rel_funD; assumption)
   done
 
 lemma cast_bl_transfer[transfer_rule]:
   "(rel_blinfun (=) (=) ===> rel_blinfun rel_ve rel_ve) id_blinfun cast_bl"
   by (auto simp: rel_ve_cast rel_blinfun_def intro!: rel_funI dest!: rel_funD)
 lemma cast_bl_transfer'[transfer_rule]:
   "(rel_blinfun rel_ve rel_ve ===> rel_blinfun (=) (=)) id_blinfun cast_bl"
   apply (auto simp: rel_ve_cast rel_blinfun_def cast_cast intro!: rel_funI dest!: rel_funD)
   by (subst cast_cast) auto
 
 lemma rel_blinfun_eq[relator_eq]: "rel_blinfun (=) (=) = (=)"
   by (auto simp: Rel_def rel_blinfun_def blinfun_ext rel_fun_eq intro!: rel_funI ext)
 
 lemma cast_aform_ode_D1:
   "cast_bl (aform.ode_d1 odo (cast (x::'n rvec))::'a\<Rightarrow>\<^sub>L'a) =
     (aform.ode_d1 odo x::'n rvec \<Rightarrow>\<^sub>L 'n rvec)"
   by transfer simp
 
 end
 
 definition "vf \<equiv> \<lambda>x. cast (ode (cast x))"
 definition "vf' \<equiv> \<lambda>x::'n rvec. cast_bl (aform.ode_d1 odo (cast x::'a))
   ::'n rvec \<Rightarrow>\<^sub>L 'n rvec"
 definition "vX \<equiv> cast ` safe_set"
 sublocale a?: transfer_c1_on_open_euclidean a n ode "aform.ode_d1 odo" safe_set vf vf' vX
   for a::'a and n::'n
   by unfold_locales
     (simp_all add: dims vf_def vf'_def vX_def)
 
 sublocale av: transfer_c1_on_open_euclidean a n "aform.ode odo" "aform.ode_d1 odo"
   "(aform.Csafe odo)" avf vf' vX
   for a::'a and n::'n
      apply unfold_locales
   unfolding vX_def
   by (simp_all add: dims avf_def  safe_set)
 
 lemma vflow_eq: "t \<in> v.existence_ivl0 x \<Longrightarrow> aform.flow0 odo x t = v.flow0 x t"
   thm flow_eq[of t "cast x"] flow_eq[of t "cast x", untransferred]
   apply (subst flow_eq[of t "cast x", untransferred, symmetric])
    apply simp
   unfolding avf_def vX_def cast_aform_ode cast_safe_set
   ..
 
 lemma vf'_eq: "vf' = aform.ode_d1 odo"
   unfolding vf'_def cast_aform_ode_D1 ..
 
 lemma vDflow_eq: "t \<in> v.existence_ivl0 x \<Longrightarrow> aform.Dflow odo x t = v.Dflow x t"
   apply (subst Dflow_eq[of t "cast x", untransferred, symmetric])
    apply simp
   unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
   ..
 
 lemma vex_ivl_eq: "t \<in> aform.existence_ivl0 odo x \<Longrightarrow> aform.existence_ivl0 odo x = v.existence_ivl0 x"
   apply (subst ex_ivl_eq[of t "cast x", untransferred, symmetric])
   unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
   by auto
 
 context includes lifting_syntax begin
 lemma id_cast_eucl1_transfer_eq: "(\<lambda>x. x) = (\<lambda>x. (fst x, 1\<^sub>L o\<^sub>L snd x o\<^sub>L 1\<^sub>L))"
   by auto
 lemma cast_eucl1_transfer[transfer_rule]:
   "(rel_prod (=) (rel_blinfun (=) (=)) ===> rel_prod rel_ve (rel_blinfun rel_ve rel_ve)) (\<lambda>x. x) cast_eucl1"
   unfolding cast_eucl1_def id_cast_eucl1_transfer_eq
   apply transfer_prover_start
        apply (transfer_step)
       apply (transfer_step)
      apply (transfer_step)
     apply (transfer_step)
    apply (transfer_step)
   apply simp
   done
 
 end
 
 lemma avpoincare_mapsto_eq:
   "aform.poincare_mapsto odo a (b::'n eucl1 set) c d e = av.v.poincare_mapsto a b c d e"
   if "closed a"
   unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
   by auto
 
 lemma vpoincare_mapsto_eq:
   "aform.poincare_mapsto odo a (b::'n eucl1 set) c d e = v.poincare_mapsto a b c d e"
   if "closed a"
 proof -
   have "closed (cast ` a::'a set)" using that
     by transfer auto
   from poincare_mapsto_eq[of "cast ` a::'a set"
       "cast_eucl1 ` b::('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set"
       "cast ` c::'a set" "cast ` d::'a set" "cast_eucl1 ` e::('a \<times> 'a \<Rightarrow>\<^sub>L 'a) set", OF this, untransferred]
   have "v.poincare_mapsto a b c d e = av.v.poincare_mapsto a b c d e"
     by auto
   also have "\<dots> = aform.poincare_mapsto odo a (b::'n eucl1 set) c d e"
     unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
     by auto
   finally show ?thesis by simp
 qed
 
 lemma avflowsto_eq: "aform.flowsto odo = (av.v.flowsto::'n eucl1 set \<Rightarrow> _)"
 proof (intro ext, goal_cases)
   case (1 a b c d)
   have "av.v.flowsto a b c d = aform.flowsto odo a b c d"
     unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
     by auto
   then show ?case by simp
 qed
 
 lemma vflowsto_eq: "aform.flowsto odo = (v.flowsto::'n eucl1 set \<Rightarrow> _)"
 proof (intro ext, goal_cases)
   case (1 a b c d)
   have "aform.flowsto odo (cast_eucl1 ` a::'a c1_info set) b
     (cast_eucl1 ` c)  (cast_eucl1 ` d) =
     flowsto (cast_eucl1 ` a::'a c1_info set) b (cast_eucl1 ` c)  (cast_eucl1 ` d)"
     by (subst flowsto_eq) auto
   from this[untransferred] have "v.flowsto a b c d = av.v.flowsto a b c d" by auto
   also have "\<dots> = aform.flowsto odo a b c d"
     unfolding avf_def vX_def cast_aform_ode cast_safe_set vf'_eq
     by auto
   finally show ?case by simp
 qed
 
 context includes lifting_syntax begin
 lemma flow1_of_list_transfer[transfer_rule]:
   "(list_all2 (=) ===> rel_prod rel_ve (rel_blinfun rel_ve rel_ve))
    flow1_of_list flow1_of_list"
   unfolding flow1_of_list_def blinfun_of_list_def o_def flow1_of_vec1_def
   by transfer_prover
 
 lemma c1_info_of_appr_transfer[transfer_rule]:
   "(rel_prod (list_all2 (=)) (rel_option (list_all2 (=))) ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
     aform.c1_info_of_appr
     aform.c1_info_of_appr"
   unfolding aform.c1_info_of_appr_def
   by transfer_prover
 
 lemma c0_info_of_appr_transfer[transfer_rule]:
   "((list_all2 (=)) ===> rel_set rel_ve) aform.c0_info_of_appr aform.c0_info_of_appr"
   unfolding aform.c0_info_of_appr_def
   by transfer_prover
 
 lemma aform_scaleR2_transfer[transfer_rule]:
   "((=) ===> (=) ===> rel_set (rel_prod A B) ===> rel_set (rel_prod A B))
     scaleR2 scaleR2"
   if [unfolded Rel_def, transfer_rule]: "((=) ===> B ===> B) (*\<^sub>R) (*\<^sub>R)"
   unfolding scaleR2_def
   by transfer_prover
 lemma scaleR_rel_blinfun_transfer[transfer_rule]: "((=) ===> rel_blinfun rel_ve rel_ve ===> rel_blinfun rel_ve rel_ve) (*\<^sub>R) (*\<^sub>R)"
   apply (auto intro!: rel_funI simp: rel_blinfun_def blinfun.bilinear_simps)
   apply (drule rel_funD)
    apply assumption
   apply (rule scaleR_transfer[THEN rel_funD, THEN rel_funD])
    apply auto
   done
 lemma c1_info_of_appre_transfer[transfer_rule]:
   "(rel_prod (rel_prod (=) (=)) (rel_prod (list_all2 (=)) (rel_option (list_all2 (=)))) ===>
       rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
     aform.c1_info_of_appre
     aform.c1_info_of_appre"
   unfolding aform.c1_info_of_appre_def
   by transfer_prover
 
 lemma c1_info_of_apprs_transfer[transfer_rule]:
   "((=) ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
     aform.c1_info_of_apprs
     aform.c1_info_of_apprs"
   unfolding aform.c1_info_of_apprs_def
   by transfer_prover
 lemma c1_info_of_appr'_transfer[transfer_rule]:
   "(rel_option (list_all2 (=)) ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
     aform.c1_info_of_appr' aform.c1_info_of_appr'"
   unfolding aform.c1_info_of_appr'_def
   by transfer_prover
 
 lemma c0_info_of_apprs_transfer[transfer_rule]:
   "((=) ===> rel_set rel_ve)
     aform.c0_info_of_apprs
     aform.c0_info_of_apprs"
   unfolding aform.c0_info_of_apprs_def
   by transfer_prover
 lemma c0_info_of_appr'_transfer[transfer_rule]:
   "(rel_option (list_all2 (=)) ===> rel_set rel_ve)
     aform.c0_info_of_appr' aform.c0_info_of_appr'"
   unfolding aform.c0_info_of_appr'_def
   by transfer_prover
 
 lemma aform_Csafe_vX[simp]: "aform.Csafe odo = (vX::'n rvec set)"
   by (simp add: vX_def cast_safe_set)
 
 definition blinfuns_of_lvivl::"real list \<times> real list \<Rightarrow> ('b \<Rightarrow>\<^sub>L 'b::executable_euclidean_space) set"
   where "blinfuns_of_lvivl x = blinfun_of_list ` list_interval (fst x) (snd x)"
 
 lemma blinfun_of_list_transfer[transfer_rule]:
   "(list_all2 (=) ===> rel_blinfun rel_ve rel_ve) blinfun_of_list blinfun_of_list"
   unfolding blinfun_of_list_def
   by transfer_prover
 
 lemma blinfuns_of_lvivl_transfer[transfer_rule]:
   "(rel_prod (list_all2 (=)) (list_all2 (=)) ===> rel_set (rel_blinfun rel_ve rel_ve))
     blinfuns_of_lvivl
     blinfuns_of_lvivl"
   unfolding blinfuns_of_lvivl_def
   by transfer_prover
 
 definition "blinfuns_of_lvivl' x = (case x of None \<Rightarrow> UNIV | Some x \<Rightarrow> blinfuns_of_lvivl x)"
 
 lemma blinfuns_of_lvivl'_transfer[transfer_rule]:
   "(rel_option (rel_prod (list_all2 (=)) (list_all2 (=))) ===> rel_set (rel_blinfun rel_ve rel_ve))
     blinfuns_of_lvivl'
     blinfuns_of_lvivl'"
   unfolding blinfuns_of_lvivl'_def
   by transfer_prover
 
 
 lemma atLeastAtMost_transfer[transfer_rule]:
   "(A ===> A ===> rel_set A) atLeastAtMost atLeastAtMost"
   if [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)" "bi_total A" "bi_unique A"
   unfolding atLeastAtMost_def atLeast_def atMost_def
   by transfer_prover
 
 lemma set_of_ivl_transfer[transfer_rule]:
   "(rel_prod A A ===> rel_set A) set_of_ivl set_of_ivl"
   if [transfer_rule]: "(A ===> A ===> (=)) (\<le>) (\<le>)" "bi_total A" "bi_unique A"
   unfolding set_of_ivl_def
   by transfer_prover
 
 lemma set_of_lvivl_transfer[transfer_rule]:
   "(rel_prod (list_all2 (=)) (list_all2 (=)) ===> rel_set rel_ve) set_of_lvivl set_of_lvivl"
   unfolding set_of_lvivl_def
   by transfer_prover
 
 lemma set_of_lvivl_eq: "set_of_lvivl I =
     (eucl_of_list ` list_interval (fst I) (snd I)::'b::executable_euclidean_space set)"
   if [simp]: "length (fst I) = DIM('b)" "length (snd I) = DIM('b)"
 proof (auto simp: set_of_lvivl_def list_interval_def set_of_ivl_def, goal_cases)
   case (1 x)
   with lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of  "fst I" "list_of_eucl x"]
     lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of "list_of_eucl x" "snd I"]
   show ?case by force
 next
   case (2 x)
   with lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of  "fst I" "x"]
   show ?case by (auto simp: list_all2_lengthD)
 next
   case (3 x)
   with lv_rel_le[where 'a='b, param_fo, OF lv_relI lv_relI, of "x" "snd I"]
   show ?case by (auto simp: list_all2_lengthD)
 qed
 
 lemma bounded_linear_matrix_vector_mul[THEN bounded_linear_compose, bounded_linear_intros]:
   "bounded_linear ((*v) x)" for x::"real^'x^'y"
   unfolding linear_linear
   by (rule matrix_vector_mul_linear)
 
 lemma blinfun_of_list_eq: "blinfun_of_list x = blinfun_of_vmatrix (eucl_of_list x::((real, 'b) vec, 'b) vec)"
   if "length x = CARD('b::enum)*CARD('b)"
   unfolding blinfun_of_list_def
   apply (transfer fixing: x)
   apply (rule linear_eq_stdbasis)
   unfolding linear_conv_bounded_linear
     apply (auto intro!: bounded_linear_intros)
 proof goal_cases
   case (1 b)
   have "(eucl_of_list x::((real, 'b) vec, 'b) vec) *v b = (eucl_of_list x::((real, 'b) vec, 'b) vec) *v eucl_of_list (list_of_eucl b)"
     by simp
   also have "\<dots> = (\<Sum>i<CARD('b).
         (\<Sum>j<CARD('b). x ! (i * CARD('b) + j) * (b \<bullet> Basis_list ! j)) *\<^sub>R Basis_list ! i)"
     by (subst eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list)
       (auto simp: that)
   also have "\<dots> = (\<Sum>i\<in>Basis.
        \<Sum>j\<in>Basis. (b \<bullet> j * x ! (index Basis_list i * CARD('b) + index Basis_list j)) *\<^sub>R i)"
     apply (subst sum_list_Basis_list[symmetric])+
     apply (subst sum_list_sum_nth)+
     by (auto simp add: atLeast0LessThan scaleR_sum_left intro!: sum.cong)
   finally show ?case by simp
 qed
 
 lemma blinfuns_of_lvivl_eq: "blinfuns_of_lvivl x =
     (blinfun_of_vmatrix ` set_of_lvivl x::((real, 'b) vec \<Rightarrow>\<^sub>L (real, 'b) vec) set)"
   if "length (fst x) = CARD('b::enum)*CARD('b)" "length (snd x) = CARD('b)*CARD('b)"
   apply (subst set_of_lvivl_eq)
   subgoal by (simp add: that)
   subgoal by (simp add: that)
   unfolding blinfuns_of_lvivl_def image_image
   by (auto simp: that blinfun_of_list_eq[symmetric] in_list_interval_lengthD cong: image_cong)
 
 lemma range_blinfun_of_vmatrix[simp]: "range blinfun_of_vmatrix = UNIV"
   apply auto
   apply transfer
   subgoal for x by (rule image_eqI[where x="matrix x"]) auto
   done
 
 lemma blinfun_of_vmatrix_image:
   "blinfun_of_vmatrix ` aform.set_of_lvivl' x =
     (blinfuns_of_lvivl' x::((real, 'b) vec \<Rightarrow>\<^sub>L (real, 'b) vec) set)"
   if "aform.lvivl'_invar (CARD('b)*CARD('b::enum)) x"
   using that
   by (auto simp: aform.set_of_lvivl'_def blinfuns_of_lvivl'_def blinfuns_of_lvivl_eq 
     aform.lvivl'_invar_def
       split: option.splits)
 
 lemma one_step_result123:
   "solves_one_step_until_time_aform optns odo X0i t1 t2 E dE \<Longrightarrow>
     (x0, d0) \<in> aform.c1_info_of_appre X0i \<Longrightarrow>
     t \<in> {t1 .. t2} \<Longrightarrow>
     set_of_lvivl E \<subseteq> S \<Longrightarrow>
     blinfuns_of_lvivl' dE \<subseteq> dS \<Longrightarrow>
     length (fst E) = CARD('n) \<Longrightarrow> length (snd E) = CARD('n) \<Longrightarrow>
     aform.lvivl'_invar (CARD('n) * CARD('n)) dE \<Longrightarrow>
     aform.c1_info_invare DIM('a) X0i \<Longrightarrow>
     aform.D odo = DIM('a) \<Longrightarrow>
       (t \<in> existence_ivl0 (x0::'a) \<and> flow0 x0 t \<in> S) \<and> Dflow x0 t o\<^sub>L d0 \<in> dS"
   apply (transfer fixing: optns X0i t1 t2 t E dE)
   subgoal premises prems for x0 d0 S dS
   proof -
     have "t \<in> aform.existence_ivl0 odo x0 \<and> aform.flow0 odo x0 t \<in> S \<and> aform.Dflow odo x0 t o\<^sub>L d0 \<in> dS"
       apply (rule one_step_in_ivl[of t t1 t2 x0 d0 X0i "fst E" "snd E" S dE dS odo optns])
       using prems
       by (auto simp: eucl_of_list_prod set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image aform.D_def
           solves_one_step_until_time_aform_def)
     with vflow_eq[of t x0] vDflow_eq[of t x0] vex_ivl_eq[symmetric, of t x0] 
     show ?thesis
       by simp
   qed
   done
 
 lemmas one_step_result12 = one_step_result123[THEN conjunct1]
   and one_step_result3 = one_step_result123[THEN conjunct2]
 lemmas one_step_result1 = one_step_result12[THEN conjunct1]
   and one_step_result2 = one_step_result12[THEN conjunct2]
 
 lemma plane_of_transfer[transfer_rule]: "(rel_sctn A ===> rel_set A) plane_of plane_of"
   if [transfer_rule]: "(A ===> A ===> (=)) (\<bullet>) (\<bullet>)" "bi_total A"
   unfolding plane_of_def
   by transfer_prover
 
 lemma below_halfspace_transfer[transfer_rule]: "(rel_sctn A ===> rel_set A) below_halfspace below_halfspace"
   if [transfer_rule]: "(A ===> A ===> (=)) (\<bullet>) (\<bullet>)" "bi_total A"
   unfolding below_halfspace_def le_halfspace_def
   by transfer_prover
 
 definition "rel_nres A a b \<longleftrightarrow> (a, b) \<in> \<langle>{(a, b). A a b}\<rangle>nres_rel"
 
 lemma FAILi_transfer[transfer_rule]: "(rel_nres B) FAILi FAILi"
   by (auto simp: rel_nres_def nres_rel_def)
 
 lemma RES_transfer[transfer_rule]: "(rel_set B ===> rel_nres B) RES RES"
   by (auto simp: rel_nres_def nres_rel_def rel_set_def intro!: rel_funI RES_refine)
 
 context includes autoref_syntax begin
 lemma RETURN_dres_nres_relI:
   "(fi, f) \<in> A \<rightarrow> B \<Longrightarrow> (\<lambda>x. dRETURN (fi x), (\<lambda>x. RETURN (f x))) \<in> A \<rightarrow> \<langle>B\<rangle>dres_nres_rel"
   by (auto simp: dres_nres_rel_def dest: fun_relD)
 end
 
 lemma br_transfer[transfer_rule]:
   "((B ===> C) ===> (B ===> (=)) ===> rel_set (rel_prod B C)) br br"
   if [transfer_rule]: "bi_total B"  "bi_unique C" "bi_total C"
   unfolding br_def
   by transfer_prover
 
 lemma aform_appr_rel_transfer[transfer_rule]:
   "(rel_set (rel_prod (list_all2 (=)) (rel_set rel_ve))) aform.appr_rel aform.appr_rel"
   unfolding aform.appr_rel_br
   by (transfer_prover)
 
 lemma appr1_rel_transfer[transfer_rule]: "(rel_set (rel_prod
   (rel_prod (list_all2 (=)) (rel_option (list_all2 (=))))
   (rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))))) aform.appr1_rel aform.appr1_rel"
   unfolding aform.appr1_rel_internal
   by transfer_prover
 
 lemma relAPP_transfer[transfer_rule]:
   "((rel_set (rel_prod B C) ===> D) ===> rel_set (rel_prod B C) ===> D) Relators.relAPP Relators.relAPP"
   unfolding relAPP_def
   by transfer_prover
 
 lemma prod_rel_transfer[transfer_rule]:
   "(rel_set (rel_prod B C) ===> rel_set (rel_prod D E) ===> rel_set (rel_prod (rel_prod B D) (rel_prod C E)))
     prod_rel prod_rel"
   if [transfer_rule]:
   "bi_total B" "bi_unique B"
   "bi_unique C" "bi_total C"
   "bi_unique D" "bi_total D"
   "bi_unique E" "bi_total E"
   unfolding prod_rel_def_internal
   by transfer_prover
 
 lemma Domain_transfer[transfer_rule]:
   "(rel_set (rel_prod A B) ===> rel_set A) Domain Domain"
   if [transfer_rule]:
   "bi_total A" "bi_unique A"
   "bi_total B" "bi_unique B"
   unfolding Domain_unfold
   by transfer_prover
 
 lemma set_rel_transfer[transfer_rule]:
   "(rel_set (rel_prod B C) ===> rel_set (rel_prod (rel_set B) (rel_set C))) set_rel set_rel"
   if [transfer_rule]:
   "bi_total B" "bi_unique B"
   "bi_unique C" "bi_total C"
   unfolding set_rel_def_internal
   by transfer_prover
 
 lemma relcomp_transfer[transfer_rule]:
   "(rel_set (rel_prod B C) ===> rel_set (rel_prod C D) ===> rel_set (rel_prod B D)) relcomp relcomp"
   if [transfer_rule]:
   "bi_total B" "bi_unique B"
   "bi_unique C" "bi_total C"
   "bi_unique D" "bi_total D"
   unfolding relcomp_unfold
   by transfer_prover
 
 lemma Union_rel_transfer[transfer_rule]:
   "(rel_set (rel_prod B (rel_set C)) ===> rel_set (rel_prod C (rel_set D)) ===> rel_set (rel_prod B (rel_set D)))
     Union_rel Union_rel"
   if [transfer_rule]:
   "bi_total B" "bi_unique B"
   "bi_unique C" "bi_total C"
   "bi_unique D" "bi_total D"
   unfolding Union_rel_internal top_fun_def top_bool_def
   by transfer_prover
 
 lemma fun_rel_transfer[transfer_rule]:
   "(rel_set (rel_prod B C) ===> rel_set (rel_prod D E) ===> rel_set (rel_prod (B ===> D) (C ===> E))) Relators.fun_rel Relators.fun_rel"
   if [transfer_rule]:
   "bi_unique B"
   "bi_unique C"
   "bi_unique D" "bi_total D"
   "bi_unique E" "bi_total E"
   unfolding fun_rel_def_internal
   by transfer_prover
 
 lemma c1_info_of_apprse_transfer[transfer_rule]:
   "(list_all2 (rel_prod (rel_prod (=) (=)) (rel_prod (list_all2 (=)) (rel_option (list_all2 (=)))))
     ===> rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve)))
     aform.c1_info_of_apprse
     aform.c1_info_of_apprse"
   unfolding aform.c1_info_of_apprse_def
   by transfer_prover
 
 term scaleR2_rel
 (*
 "scaleR2_rel"
   ::
   "('b \<times> ('c \<times> 'd) set) set
    \<Rightarrow> (((ereal \<times> ereal) \<times> 'b) \<times> ('c \<times> 'd) set) set"
 *)
 lemma scaleR2_rel_transfer[transfer_rule]:
   "(rel_set (rel_prod (=) (rel_set (rel_prod (=) (=)))) ===>
     rel_set (rel_prod (rel_prod (rel_prod (=) (=)) (=)) (rel_set (rel_prod (=) (=))))) scaleR2_rel scaleR2_rel"
   unfolding scaleR2_rel_internal
   by transfer_prover
 
 lemma appr1_rele_transfer[transfer_rule]:
   "(rel_set (rel_prod
     (rel_prod (rel_prod (=) (=)) (rel_prod (list_all2 (=)) (rel_option (list_all2 (=)))))
     (rel_set (rel_prod rel_ve (rel_blinfun rel_ve rel_ve))))) aform.appr1e_rel aform.appr1e_rel"
   unfolding scaleR2_rel_internal
   by transfer_prover
 
 lemma flow1_of_vec1_times: "flow1_of_vec1 ` (A \<times> B) = A \<times> blinfun_of_vmatrix ` B"
   by (auto simp: flow1_of_vec1_def vec1_of_flow1_def)
 
 lemma stable_on_transfer[transfer_rule]:
   "(rel_set rel_ve ===> rel_set rel_ve ===> (=)) v.stable_on stable_on"
   unfolding stable_on_def v.stable_on_def
   by transfer_prover
 
 theorem solves_poincare_map_aform:
   "solves_poincare_map_aform optns odo (\<lambda>x. dRETURN (symstart x)) [S] guards ivl sctn roi XS RET dRET \<Longrightarrow>
     (symstart, symstarta) \<in> fun_rel (aform.appr1e_rel) (clw_rel aform.appr_rel \<times>\<^sub>r clw_rel aform.appr1e_rel) \<Longrightarrow>
     (\<And>X0. (\<lambda>(CX, X). flowsto (X0 - trap \<times> UNIV) {0..} (CX \<times> UNIV) X) (symstarta X0)) \<Longrightarrow>
     stable_on (aform.Csafe odo - set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn)) trap \<Longrightarrow>
     (\<And>X. X \<in> set XS \<Longrightarrow> aform.c1_info_invare DIM('a) X) \<Longrightarrow>
     aform.D odo = DIM('a) \<Longrightarrow>
     length (normal sctn) = DIM('a) \<Longrightarrow>
     length (fst ivl) = DIM('a) \<Longrightarrow>
     length (snd ivl) = DIM('a) \<Longrightarrow>
     length (normal S) = DIM('a) \<Longrightarrow>
     (\<And>a xs b ba ro.
         (xs, ro) \<in> set guards \<Longrightarrow>
         ((a, b), ba) \<in> set xs \<Longrightarrow>
         length a = DIM('a) \<and>
         length b = DIM('a) \<and> length (normal ba) = DIM('a)) \<Longrightarrow>
     length (fst RET) = CARD('n) \<Longrightarrow> length (snd RET) = CARD('n) \<Longrightarrow>
     aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \<Longrightarrow>
     poincare_mapsto
      ((set_of_lvivl ivl::('a set)) \<inter> plane_of (map_sctn eucl_of_list sctn))
      (aform.c1_info_of_apprse XS - trap \<times> UNIV)
      (below_halfspace (map_sctn eucl_of_list S))
      (aform.Csafe odo -
       set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
      (set_of_lvivl RET \<times> blinfuns_of_lvivl' dRET)"
   apply (transfer fixing: optns symstart S guards ivl sctn roi XS RET dRET)
   subgoal premises prems for symstarta trap
   proof -
     have "aform.poincare_mapsto odo (set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
      (aform.c1_info_of_apprse XS - trap \<times> UNIV) (below_halfspace (map_sctn eucl_of_list S))
      (aform.Csafe odo - set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
      (flow1_of_vec1 ` ({eucl_of_list (fst RET)..eucl_of_list (snd RET)} \<times> aform.set_of_lvivl' dRET))"
       apply (rule solves_poincare_map[OF _ RETURN_dres_nres_relI RETURN_rule,
         of optns odo symstart S guards ivl sctn roi XS "fst RET" "snd RET" dRET symstarta trap])
       subgoal using prems(1) by (simp add: solves_poincare_map_aform_def)
       subgoal using prems(2) by (auto simp: fun_rel_def_internal)
       subgoal for X0
         using prems(3)[of X0] vflowsto_eq
         by auto
       subgoal
         unfolding aform.stable_on_def
       proof (safe, goal_cases)
         case (1 t x0)
         from 1 have a: "t \<in> v.existence_ivl0 x0" using vex_ivl_eq by blast
         with 1 have b: "v.flow0 x0 t \<in> trap" using vflow_eq by simp
         have c: "v.flow0 x0 s \<in> vX - set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn)"
           if s: "s \<in> {0<..t}"
           for s
           using 1(4)[rule_format, OF s]
           apply (subst (asm) vflow_eq)
           unfolding aform_Csafe_vX[symmetric]
           using s a
           by (auto dest!: a.v.ivl_subset_existence_ivl)
         from a b c show ?case 
           using prems(4)[unfolded v.stable_on_def, rule_format, OF b a 1(3) c]
           by simp
       qed
       subgoal using prems by auto
       subgoal using prems by (auto simp: aform.D_def)
       subgoal using prems by auto
       subgoal using prems by auto
       subgoal using prems by auto
       subgoal using prems by auto
       subgoal using prems by auto
       subgoal using prems by auto
       subgoal using prems by auto
       subgoal using prems by auto
       done
     then show ?thesis
       using vflow_eq vex_ivl_eq vflowsto_eq prems
       apply (subst vpoincare_mapsto_eq[symmetric])
       by (auto simp: set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image flow1_of_vec1_times)
   qed
   done
 
 theorem solves_poincare_map_aform':
   "solves_poincare_map_aform' optns odo S guards ivl sctn roi XS RET dRET\<Longrightarrow>
     (\<And>X. X \<in> set XS \<Longrightarrow> aform.c1_info_invare DIM('a) X) \<Longrightarrow>
     aform.D odo = DIM('a) \<Longrightarrow>
     length (normal sctn) = DIM('a) \<Longrightarrow>
     length (fst ivl) = DIM('a) \<Longrightarrow>
     length (snd ivl) = DIM('a) \<Longrightarrow>
     length (normal S) = DIM('a) \<Longrightarrow>
     (\<And>a xs b ba ro.
         (xs, ro) \<in> set guards \<Longrightarrow>
         ((a, b), ba) \<in> set xs \<Longrightarrow>
         length a = DIM('a) \<and>
         length b = DIM('a) \<and> length (normal ba) = DIM('a)) \<Longrightarrow>
     length (fst RET) = CARD('n) \<Longrightarrow> length (snd RET) = CARD('n) \<Longrightarrow>
     aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \<Longrightarrow>
     poincare_mapsto
      ((set_of_lvivl ivl::('a set)) \<inter> plane_of (map_sctn eucl_of_list sctn))
      (aform.c1_info_of_apprse XS)
      (below_halfspace (map_sctn eucl_of_list S))
      (aform.Csafe odo -
       set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
      (set_of_lvivl RET \<times> blinfuns_of_lvivl' dRET)"
   apply (transfer fixing: optns S guards ivl sctn roi XS RET dRET)
   subgoal
     using solves_poincare_map'[of optns odo S guards ivl sctn roi XS "fst RET" "snd RET" dRET]
     using vflow_eq vex_ivl_eq vflowsto_eq
     apply (subst vpoincare_mapsto_eq[symmetric])
     by (auto intro!: closed_Int simp: set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image
         flow1_of_vec1_times aform.D_def solves_poincare_map_aform'_def)
   done
 
 theorem solves_poincare_map_onto_aform:
   "solves_poincare_map_onto_aform optns odo guards ivl sctn roi XS RET dRET\<Longrightarrow>
     (\<And>X. X \<in> set XS \<Longrightarrow> aform.c1_info_invare DIM('a) X) \<Longrightarrow>
     aform.D odo = DIM('a) \<Longrightarrow>
     length (normal sctn) = DIM('a) \<Longrightarrow>
     length (fst ivl) = DIM('a) \<Longrightarrow>
     length (snd ivl) = DIM('a) \<Longrightarrow>
     (\<And>a xs b ba ro.
         (xs, ro) \<in> set guards \<Longrightarrow>
         ((a, b), ba) \<in> set xs \<Longrightarrow>
         length a = DIM('a) \<and>
         length b = DIM('a) \<and> length (normal ba) = DIM('a)) \<Longrightarrow>
     length (fst RET) = CARD('n) \<Longrightarrow> length (snd RET) = CARD('n) \<Longrightarrow>
     aform.lvivl'_invar (CARD('n) * CARD('n)) dRET \<Longrightarrow>
     poincare_mapsto
      ((set_of_lvivl ivl::('a set)) \<inter> plane_of (map_sctn eucl_of_list sctn))
      (aform.c1_info_of_apprse XS)
      UNIV
      (aform.Csafe odo -
       set_of_lvivl ivl \<inter> plane_of (map_sctn eucl_of_list sctn))
      (set_of_lvivl RET \<times> blinfuns_of_lvivl' dRET)"
   apply (transfer fixing: optns guards ivl sctn roi XS RET dRET)
   subgoal
     using solves_poincare_map_onto[of optns odo guards ivl sctn roi XS "fst RET" "snd RET" dRET, where 'n='n,
           unfolded aform.poincare_maps_onto_def]
     using vflow_eq vex_ivl_eq vflowsto_eq
     apply (subst vpoincare_mapsto_eq[symmetric])
     by (auto intro!: closed_Int simp: set_of_lvivl_def set_of_ivl_def blinfun_of_vmatrix_image
         flow1_of_vec1_times aform.D_def solves_poincare_map_onto_aform_def)
   done
 
 end
 
 end
 
 subsection \<open>Example Utilities!\<close>
 
 hide_const floatarith.Max floatarith.Min
 
 lemma degree_sum_pdevs_scaleR_Basis:
   "degree (sum_pdevs (\<lambda>i. pdevs_scaleR (a i) i) (Basis::'b::euclidean_space set)) = Max ((\<lambda>i. degree (a i)) ` Basis)"
   apply (rule antisym)
   subgoal apply (rule degree_le)
     by (auto )
   subgoal
     apply (rule Max.boundedI)
       apply simp
      apply simp
     apply (auto simp: intro!: degree_leI)
     by (auto simp: euclidean_eq_iff[where 'a='b])
   done
 
 lemma Inf_aform_eucl_of_list_aform:
   assumes "length a = DIM('b::executable_euclidean_space)"
   shows "Inf_aform (eucl_of_list_aform a::'b aform) = eucl_of_list (map Inf_aform a)"
   using assms
   apply (auto simp: eucl_of_list_aform_def Inf_aform_def[abs_def] algebra_simps
       eucl_of_list_inner inner_sum_left
       intro!: euclidean_eqI[where 'a='b])
   apply (auto simp: tdev_def inner_sum_left abs_inner inner_Basis if_distrib cong: if_cong)
   apply (rule sum.mono_neutral_cong_left)
      apply simp
   by (auto simp: degree_sum_pdevs_scaleR_Basis)
 
 lemma Sup_aform_eucl_of_list_aform:
   assumes "length a = DIM('b::executable_euclidean_space)"
   shows "Sup_aform (eucl_of_list_aform a::'b aform) = eucl_of_list (map Sup_aform a)"
   using assms
   apply (auto simp: eucl_of_list_aform_def Sup_aform_def[abs_def] algebra_simps
       eucl_of_list_inner inner_sum_left
       intro!: euclidean_eqI[where 'a='b])
   apply (auto simp: tdev_def inner_sum_left abs_inner inner_Basis if_distrib cong: if_cong)
   apply (rule sum.mono_neutral_cong_right)
      apply simp
   by (auto simp: degree_sum_pdevs_scaleR_Basis)
 
 lemma
   eucl_of_list_map_Inf_aform_leI:
   assumes "x \<in> Affine (eucl_of_list_aform a::'b::executable_euclidean_space aform)"
   assumes "length a = DIM('b)"
   shows "eucl_of_list (map Inf_aform a) \<le> x"
   using Inf_aform_le_Affine[OF assms(1)] assms(2)
   by (auto simp: Inf_aform_eucl_of_list_aform)
 
 lemma
   eucl_of_list_map_Sup_aform_geI:
   assumes "x \<in> Affine (eucl_of_list_aform a::'b::executable_euclidean_space aform)"
   assumes "length a = DIM('b)"
   shows "x \<le> eucl_of_list (map Sup_aform a)"
   using Sup_aform_ge_Affine[OF assms(1)] assms(2)
   by (auto simp: Sup_aform_eucl_of_list_aform)
 
 lemma
   mem_Joints_appendE:
   assumes "x \<in> Joints (xs @ ys)"
   obtains x1 x2 where "x = x1 @ x2" "x1 \<in> Joints xs" "x2 \<in> Joints ys"
   using assms
   by (auto simp: Joints_def valuate_def)
 
 lemma c1_info_of_appr_subsetI1:
   fixes X1::"'b::executable_euclidean_space set"
   assumes subset: "{eucl_of_list (map Inf_aform (fst R)) .. eucl_of_list (map Sup_aform (fst R))} \<subseteq> X1"
   assumes len: "length (fst R) = DIM('b)"
   shows "aform.c1_info_of_appr R \<subseteq> X1 \<times> UNIV"
   using len
   apply (auto simp: aform.c1_info_of_appr_def flow1_of_list_def
       split: option.splits
       intro!: subsetD[OF subset] elim!: mem_Joints_appendE)
   subgoal
     by (auto intro!: eucl_of_list_mem_eucl_of_list_aform eucl_of_list_map_Inf_aform_leI eucl_of_list_map_Sup_aform_geI)
   subgoal
     by (auto intro!: eucl_of_list_mem_eucl_of_list_aform eucl_of_list_map_Inf_aform_leI eucl_of_list_map_Sup_aform_geI)
   subgoal
     apply (subst (2) eucl_of_list_take_DIM[symmetric, OF refl])
       apply (auto simp: min_def)
     apply (simp add: Joints_imp_length_eq eucl_of_list_map_Inf_aform_leI eucl_of_list_mem_eucl_of_list_aform)
     apply (simp add: Joints_imp_length_eq eucl_of_list_map_Inf_aform_leI eucl_of_list_mem_eucl_of_list_aform)
       done
   subgoal
     apply (subst (2) eucl_of_list_take_DIM[symmetric, OF refl])
       apply (auto simp: min_def)
     by (simp add: Joints_imp_length_eq eucl_of_list_map_Sup_aform_geI eucl_of_list_mem_eucl_of_list_aform)
   done
 
 lemmas [simp] = compute_tdev
 
 syntax product_aforms::"(real aform) list \<Rightarrow> (real aform) list \<Rightarrow> (real aform) list"
   (infixr "\<times>\<^sub>a" 70)
 
 lemma matrix_inner_Basis_list:
   includes vec_syntax
   assumes "k < CARD('n) * CARD('m)"
   shows "(f::(('n::enum rvec, 'm::enum) vec)) \<bullet> Basis_list ! k =
     vec_nth (vec_nth f (enum_class.enum ! (k div CARD('n)))) (enum_class.enum ! (k mod CARD('n)))"
 proof -
   have "f \<bullet> Basis_list ! k =
     (\<Sum>x\<in>UNIV.
        \<Sum>xa\<in>UNIV.
          if enum_class.enum ! (k mod CARD('n)) = xa \<and> enum_class.enum ! (k div CARD('n)) = x then f $ x $ xa else 0)"
     using assms
     unfolding inner_vec_def
     apply (auto simp: Basis_list_vec_def concat_map_map_index)
     apply (subst (2) sum.cong[OF refl])
      apply (subst sum.cong[OF refl])
       apply (subst (2) vec_nth_Basis2)
        apply (force simp add: Basis_vec_def Basis_list_real_def)
       apply (rule refl)
      apply (rule refl)
     apply (auto simp: if_distribR if_distrib axis_eq_axis Basis_list_real_def cong: if_cong)
     done
   also have "\<dots> = f $ enum_class.enum ! (k div CARD('n)) $ enum_class.enum ! (k mod CARD('n))"
     apply (subst if_conn)
     apply (subst sum.delta')
      apply simp
     by (simp add: sum.delta')
   finally show ?thesis by simp
 qed
 
 lemma list_of_eucl_matrix:
   includes vec_syntax
   shows "(list_of_eucl (M::(('n::enum rvec, 'm::enum) vec))) =
     concat (map (\<lambda>i. map (\<lambda>j. M $ (enum_class.enum ! i)$ (enum_class.enum ! j) )
       [0..<CARD('n)]) [0..<CARD('m)])"
   by (auto intro!: nth_equalityI simp: length_concat o_def sum_list_distinct_conv_sum_set ac_simps
       concat_map_map_index matrix_inner_Basis_list)
 
 lemma axis_eq_eucl_of_list:
   "(axis i 1::'n::enum rvec) = eucl_of_list ((replicate CARD('n) 0)[index enum_class.enum i := 1])"
   apply (auto intro!: euclidean_eqI[where 'a="'n rvec"]
       simp: eucl_of_list_inner nth_list_update )
    apply (auto simp: index_Basis_list_axis1[symmetric])
   by (simp add: inner_axis inner_commute vec_nth_Basis)
 
 lemma eucl_of_list_012: "eucl_of_list [vec_nth A 0, vec_nth A 1, vec_nth A 2] = A" for A::"3 rvec"
   apply vector
   apply (auto simp: vec_nth_eucl_of_list_eq index_Basis_list_axis1)
   using exhaust_3 three_eq_zero by blast
 
 
 definition "ldec x = (case quotient_of x of (i, j) \<Rightarrow> real_of_float (lapprox_rat 20 i j))"
 definition "udec x = (case quotient_of x of (i, j) \<Rightarrow> real_of_float (rapprox_rat 20 i j))"
 
 lemma ldec: "ldec x \<le> real_of_rat x"
   and udec: "real_of_rat x \<le> udec x"
    apply (auto simp: ldec_def udec_def split: prod.splits
       intro!: lapprox_rat[le] rapprox_rat[ge])
    apply (metis Fract_of_int_quotient less_eq_real_def less_int_code(1) of_rat_rat
       quotient_of_denom_pos quotient_of_div)
   apply (metis Fract_of_int_quotient less_eq_real_def less_int_code(1) of_rat_rat
       quotient_of_denom_pos quotient_of_div)
   done
 
 context includes floatarith_notation begin
 
 definition "matrix_of_degrees\<^sub>e =
   (let
     ur = Rad_of (Var 0);
     vr = Rad_of (Var 1)
    in
     [Cos ur, Cos vr, 0,
      Sin ur, Sin vr, 0,
      0, 0, 0])"
 
 definition "matrix_of_degrees u v =
   approx_floatariths 30 matrix_of_degrees\<^sub>e (aforms_of_point ([u, v, 0]))"
 
 lemma interpret_floatariths_matrix_of_degrees:
   "interpret_floatariths matrix_of_degrees\<^sub>e
     (([u::real, v::real, 0]))
    =
   [cos (rad_of u), cos (rad_of v), 0,
    sin (rad_of u), sin (rad_of v), 0,
    0, 0, 0]"
   by (auto simp: matrix_of_degrees\<^sub>e_def Let_def inverse_eq_divide)
 
 definition "num_options p sstep m N a projs print_fun =
   \<lparr>
     precision = p,
     adaptive_atol = FloatR 1 (- a),
     adaptive_rtol = FloatR 1 (- a),
     method_id = 2,
     start_stepsize  = FloatR 1 (- sstep),
     iterations = 40,
     halve_stepsizes = 40,
     widening_mod = 10,
     rk2_param = FloatR 1 0,
     default_reduce = correct_girard (p) (m) (N),
     printing_fun = (\<lambda>a b.
         let
            _ = fold (\<lambda>(x, y, c) _.
                print_fun (String.implode (shows_segments_of_aform (x) (y) b c ''\<newline>''))) projs ();
            _ = print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\<newline>''))
         in
          ()
     ),
     tracing_fun = (\<lambda>a b.
       let
         _ = print_fun (String.implode (''# '' @ a @ ''\<newline>''))
       in case b of Some b \<Rightarrow>
         (let
           _ = ()
         in print_fun (String.implode (''# '' @ shows_box_of_aforms_hr (b) '''' @ ''\<newline>'')))
         | None \<Rightarrow> ())
   \<rparr>"
 
 definition "num_options_c1 p sstep m N a projs dcolors print_fun =
   (let
     no = num_options p sstep m N a (map (\<lambda>(x, y, c, ds). (x, y, c)) projs) print_fun;
     D = length dcolors
   in no
     \<lparr>printing_fun:=
       (\<lambda>a b. let _ = printing_fun no a b
           in if a then ()
           else fold (\<lambda>(x, y, c, ds) _. print_fun
               (String.implode (shows_aforms_vareq D [(x, y)] ds
                 dcolors
                 dcolors
             (FloatR 1 (-1)) ''# no C1 info'' b ''''))) projs ()
       )
     \<rparr>)"
 
 definition "num_options_code p sstep m N a projs print_fun =
   num_options (nat_of_integer p) (int_of_integer sstep) (nat_of_integer m) (nat_of_integer N)
     (int_of_integer a) (map (\<lambda>(i, j, k). (nat_of_integer i, nat_of_integer j, k)) projs) print_fun"
 
 definition "ro s n M g0 g1 inter_step =
   \<lparr>max_tdev_thres = FloatR 1 s,
       pre_split_reduce = correct_girard 30 n M,
       pre_inter_granularity = FloatR 1 g0,
       post_inter_granularity = (FloatR 1 g1),
       pre_collect_granularity = FloatR 1 g0,
       max_intersection_step = FloatR 1 inter_step\<rparr>"
 
 definition "code_ro s n m g0 g1 inter_step =
   ro (int_of_integer s) (nat_of_integer n) (nat_of_integer m) (int_of_integer g0) (int_of_integer g1) (int_of_integer inter_step)"
 
 fun xsec:: "real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "xsec x (y0, y1) (z0, z1) = (([x, y0, z0], [x, y1, z1]), Sctn [1,0,0] x)"
 fun xsec':: "real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "xsec' x (y0, y1) (z0, z1) = (([x, y0, z0], [x, y1, z1]), Sctn [-1,0,0] (-x))"
 
 fun ysec:: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "ysec (x0, x1) y (z0, z1) = (([x0, y, z0], [x1, y, z1]), Sctn [0, 1,0] y)"
 fun ysec':: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "ysec' (x0, x1) y (z0, z1) = (([x0, y, z0], [x1, y, z1]), Sctn [0, -1,0] (-y))"
 
 fun zsec:: "real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "zsec (x0, x1) (y0, y1) z = (([x0, y0, z], [x1, y1, z]), Sctn [0, 0, 1] z)"
 fun zsec':: "real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "zsec' (x0, x1) (y0, y1) z = (([x0, y0, z], [x1, y1, z]), Sctn [0, 0, -1] (-z))"
 
 
 fun xsec2:: "real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "xsec2 x (y0, y1) = (([x, y0], [x, y1]), Sctn [1,0] x)"
 fun xsec2':: "real \<Rightarrow> real \<times> real \<Rightarrow>(real list \<times> real list) \<times> real list sctn"
   where "xsec2' x (y0, y1) = (([x, y0], [x, y1]), Sctn [-1,0] (-x))"
 
 fun ysec2:: "real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "ysec2 (x0, x1) y = (([x0, y], [x1, y]), Sctn [0, 1] y)"
 fun ysec2':: "real \<times> real \<Rightarrow> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "ysec2' (x0, x1) y = (([x0, y], [x1, y]), Sctn [0, -1] (-y))"
 
 fun ysec4:: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "ysec4 (x0, x1) y (z0, z1) (m0, m1) = (([x0, y, z0, m0], [x1, y, z1, m1]), Sctn [0, 1,0, 0] (y))"
 
 fun ysec4':: "real \<times> real \<Rightarrow> real \<Rightarrow> real \<times> real \<Rightarrow> real \<times> real \<Rightarrow> (real list \<times> real list) \<times> real list sctn"
   where "ysec4' (x0, x1) y (z0, z1) (m0, m1) = (([x0, y, z0, m0], [x1, y, z1, m1]), Sctn [0, -1,0, 0] (-y))"
 
 definition "code_sctn N n c = Sctn ((replicate (nat_of_integer N) (0::real))[nat_of_integer n := 1]) c"
 definition "code_sctn' N n c = Sctn ((replicate (nat_of_integer N) (0::real))[nat_of_integer n := -1]) (-c)"
 
 definition "lrat i j = real_of_float (lapprox_rat 30 (int_of_integer i) (int_of_integer j))"
 definition "urat i j = real_of_float (lapprox_rat 30 (int_of_integer i) (int_of_integer j))"
 
 definition [simp]: "TAG_optns (optns::string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow> (real aform) numeric_options)) = True"
 lemma TAG_optns: "P \<Longrightarrow> (TAG_optns optns \<Longrightarrow> P)"
   by auto
 
 definition [simp]: "TAG_reach_optns (roi::real aform reach_options) = True"
 lemma TAG_reach_optns: "P \<Longrightarrow> (TAG_reach_optns optns \<Longrightarrow> P)"
   by auto
 
 definition [simp]: "TAG_sctn (b::bool) = True"
 lemma TAG_sctn: "P \<Longrightarrow> (TAG_sctn optns \<Longrightarrow> P)"
   by auto
 
 subsection \<open>Integrals and Computation\<close>
 
 lemma has_vderiv_on_PairD:
   assumes "((\<lambda>t. (f t, g t)) has_vderiv_on fg') T"
   shows "(f has_vderiv_on (\<lambda>t. fst (fg' t))) T" "(g has_vderiv_on (\<lambda>t. snd (fg' t))) T"
 proof -
   from assms have "((\<lambda>x. (f x, g x)) has_derivative (\<lambda>xa. xa *\<^sub>R fg' t)) (at t within T)"
      if "t \<in> T" for t
     by (auto simp: has_vderiv_on_def has_vector_derivative_def that
         intro!: derivative_eq_intros)
   from diff_chain_within[OF this has_derivative_fst[OF has_derivative_ident]]
     diff_chain_within[OF this has_derivative_snd[OF has_derivative_ident]]
   show "(f has_vderiv_on (\<lambda>t. fst (fg' t))) T" "(g has_vderiv_on (\<lambda>t. snd (fg' t))) T"
     by (auto simp: has_vderiv_on_def has_vector_derivative_def o_def)
 qed
 
 lemma solves_autonomous_odeI:
   assumes "((\<lambda>t. (t, phi t)) solves_ode (\<lambda>t x. (1, f (fst x) (snd x)))) S (T \<times> X)"
   shows "(phi solves_ode f) S X"
 proof (rule solves_odeI)
   from solves_odeD[OF assms]
   have
     "((\<lambda>t. (t, phi t)) has_vderiv_on (\<lambda>t. (1, f (fst (t, phi t)) (snd (t, phi t))))) S"
     "\<And>t. t \<in> S \<Longrightarrow> (phi t) \<in> X"
     by auto
   from has_vderiv_on_PairD(2)[OF this(1)] this(2)
   show "(phi has_vderiv_on (\<lambda>t. f t (phi t))) S" "\<And>t. t \<in> S \<Longrightarrow> phi t \<in> X"
     by auto
 qed
 
 lemma integral_solves_autonomous_odeI:
   fixes f::"real \<Rightarrow> 'a::executable_euclidean_space"
   assumes "(phi solves_ode (\<lambda>t _. f t)) {a .. b} X" "phi a = 0"
   assumes "a \<le> b"
   shows "(f has_integral phi b) {a .. b}"
 proof -
   have "(f has_integral phi b - phi a) {a..b}"
     apply (rule fundamental_theorem_of_calculus[of a b phi f])
     unfolding has_vderiv_on_def[symmetric]
      apply fact
     using solves_odeD[OF assms(1)]
     by (simp add: has_vderiv_on_def)
   then show ?thesis by (simp add: assms)
 qed
 
 lemma zero_eq_eucl_of_list_rep_DIM: "(0::'a::executable_euclidean_space) = eucl_of_list (replicate (DIM('a)) 0)"
   by (auto intro!: euclidean_eqI[where 'a='a] simp: eucl_of_list_inner)
 
 lemma zero_eq_eucl_of_list_rep: "(0::'a::executable_euclidean_space) = eucl_of_list (replicate D 0)"
   if "D \<ge> DIM('a)"
 proof -
   from that have "replicate D (0::real) = replicate (DIM('a)) 0 @ replicate (D - DIM('a)) 0"
     by (auto simp: replicate_add[symmetric])
   also have "eucl_of_list \<dots> = (eucl_of_list (replicate DIM('a) 0)::'a)"
     by (rule eucl_of_list_append_zeroes)
   also have "\<dots> = 0"
     by (rule zero_eq_eucl_of_list_rep_DIM[symmetric])
   finally show ?thesis by simp
 qed
 
 lemma one_has_ivl_integral: "((\<lambda>x. 1::real) has_ivl_integral b - a) a b"
   using has_integral_const_real[of "1::real" a b] has_integral_const_real[of "1::real" b a]
   by (auto simp: has_ivl_integral_def split: if_splits)
 
 lemma Joints_aforms_of_point_self[simp]: "xs \<in> Joints (aforms_of_point xs)"
   by (simp add: aforms_of_point_def)
 
 lemma bind_eq_dRETURN_conv:
   "(f \<bind> g = dRETURN S) \<longleftrightarrow> (\<exists>R. f = dRETURN R \<and> g R = dRETURN S)"
   by (cases f) auto
 
 end
 
 lemma list_of_eucl_memI: "list_of_eucl (x::'x::executable_euclidean_space) \<in> S"
   if "x \<in> eucl_of_list ` S" "\<And>x. x \<in> S \<Longrightarrow> length x = DIM('x)"
   using that
   by auto
 
 lemma Joints_aforms_of_ivls_append_point:
   "Joints (xs @ aforms_of_ivls p p) = (\<lambda>x. x @ p) ` Joints xs"
   using aform.set_of_appr_of_ivl_append_point[unfolded aform_ops_def approximate_set_ops.simps] .
 
 
 context ode_interpretation begin
 
 theorem solves_one_step_ivl:
   assumes T: "T \<subseteq> {t1 .. t2}"
   assumes X: "X \<subseteq> {eucl_of_list lx .. eucl_of_list ux}" "length lx = DIM('a)" "length ux = DIM('a)"
   assumes S: "{eucl_of_list ls::'a .. eucl_of_list us} \<subseteq> S"
   assumes lens: "length ls = DIM('a)" "length us = DIM('a)" \<comment> \<open>TODO: this could be verified\<close>
   assumes [simp]: "aform.D odo = DIM('a)"
   assumes r: "solves_one_step_until_time_aform optns odo ((1,1), aforms_of_ivls lx ux, None) t1 t2 (ls, us) None"
   shows "t \<in> T \<longrightarrow> x0 \<in> X \<longrightarrow> t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S"
 proof (intro impI)
   assume t: "t \<in> T" and x0: "x0 \<in> X"
   from S have S: "set_of_lvivl (ls, us) \<subseteq> S"
     by (auto simp: set_of_lvivl_def set_of_ivl_def)
   have lens: "length (fst (ls, us)) = CARD('n)" "length (snd (ls, us)) = CARD('n)"
     by (auto simp: lens)
   have x0: "list_of_eucl x0 \<in> Joints (aforms_of_ivls lx ux)"
     apply (rule aforms_of_ivls)
     subgoal by (simp add: X)
     subgoal by (simp add: X)
     using subsetD[OF X(1) x0]
     apply (auto simp: eucl_le[where 'a='a] X)
     apply (metis assms(3) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
     apply (metis assms(4) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
     done
   from t T have t: "t \<in> {t1 .. t2}" by auto
   show "t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S"
     by (rule one_step_result12[OF r aform.c1_info_of_appre_c0_I[OF x0] t S subset_UNIV lens])
       (auto simp: aform.c1_info_invare_None lens X)
 qed
 
 theorem solves_one_step_ivl':
   assumes T: "T \<subseteq> {t1 .. t2}"
   assumes X: "X \<subseteq> {eucl_of_list lx .. eucl_of_list ux}"
     "length lx = DIM('a)" "length ux = DIM('a)"
   assumes DS: "list_interval lds uds \<subseteq> list_interval ld ud"
     and lends: "length lds = DIM('a)*DIM('a)" "length uds = DIM('a)*DIM('a)"
   assumes S: "{eucl_of_list ls::'a .. eucl_of_list us} \<subseteq> S"
   assumes lens0: "length ls = DIM('a)" "length us = DIM('a)" \<comment> \<open>TODO: this could be verified\<close>
     "length dx0s = DIM('a)*DIM('a)"
   assumes [simp]: "aform.D odo = DIM('a)"
   assumes r: "solves_one_step_until_time_aform optns odo
     ((1,1), aforms_of_ivls lx ux, Some (aforms_of_point dx0s)) t1 t2 (ls, us) (Some (lds, uds))"
   shows "t \<in> T \<longrightarrow> x0 \<in> X \<longrightarrow> t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S \<and>
     Dflow x0 t o\<^sub>L blinfun_of_list dx0s \<in> blinfuns_of_lvivl (ld, ud)"
 proof (intro impI)
   assume t: "t \<in> T" and x0: "x0 \<in> X"
   from S have S: "set_of_lvivl (ls, us) \<subseteq> S"
     by (auto simp: set_of_lvivl_def set_of_ivl_def)
   have lens: "length (fst (ls, us)) = CARD('n)" "length (snd (ls, us)) = CARD('n)"
     by (auto simp: lens0)
   have x0: "list_of_eucl x0 \<in> Joints (aforms_of_ivls lx ux)"
     apply (rule aforms_of_ivls)
     subgoal by (simp add: X)
     subgoal by (simp add: X)
     using subsetD[OF X(1) x0]
     apply (auto simp: eucl_le[where 'a='a] X)
     apply (metis assms(3) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
     apply (metis assms(4) dim length_Basis_list list_of_eucl_eucl_of_list list_of_eucl_nth nth_Basis_list_in_Basis)
     done
   have x0dx0: "(x0, blinfun_of_list dx0s) \<in>
       aform.c1_info_of_appre ((1, 1), aforms_of_ivls lx ux, Some (aforms_of_point dx0s))"
     apply (auto simp: aform.c1_info_of_appre_def aform.c1_info_of_appr_def)
     apply (rule image_eqI[where x="list_of_eucl x0@dx0s"])
     using lens0
      apply (auto simp: flow1_of_list_def aforms_of_point_def Joints_aforms_of_ivls_append_point)
     apply (rule imageI)
     apply (rule x0)
     done
   from t T have t: "t \<in> {t1 .. t2}" by auto
   have DS: "blinfuns_of_lvivl' (Some (lds, uds)) \<subseteq> blinfun_of_list ` list_interval ld ud"
     using DS
     by (auto simp: blinfuns_of_lvivl'_def blinfuns_of_lvivl_def)
   have inv: "aform.lvivl'_invar (CARD('n) * CARD('n)) (Some (lds, uds))"
     "aform.c1_info_invare DIM('a) ((1::ereal, 1), aforms_of_ivls lx ux, Some (aforms_of_point dx0s))"
     by (auto simp: aform.lvivl'_invar_def lends aform.c1_info_invare_def X lens0 power2_eq_square
         aform.c1_info_invar_def)
   from one_step_result123[OF r x0dx0 t S DS lens inv \<open>aform.D _ = _\<close>]
   show "t \<in> existence_ivl0 x0 \<and> flow0 x0 t \<in> S \<and> Dflow x0 t o\<^sub>L blinfun_of_list dx0s \<in> blinfuns_of_lvivl (ld, ud)"
     by (auto simp: blinfuns_of_lvivl_def)
 qed
 
 end
 
 definition "zero_aforms D = map (\<lambda>_. (0, zero_pdevs)) [0..<D]"
 
 definition "solves_one_step_until_time_aform_fo soptns a b c d e f =
   file_output (String.implode (fst soptns)) (\<lambda>pf. solves_one_step_until_time_aform (snd soptns pf) a b c d e f)"
 
 definition "solves_poincare_map_aform'_fo soptns a b c d e f g h i =
   file_output (String.implode (fst soptns)) (\<lambda>pf. solves_poincare_map_aform' (snd soptns pf) a b c d e f g h i)"
 
 definition "solves_poincare_map_onto_aform_fo soptns a b c d e f g h =
   file_output (String.implode (fst soptns)) (\<lambda>pf. solves_poincare_map_onto_aform (snd soptns pf) a b c d e f g h)"
 
 lemma solves_one_step_until_time_aform_foI:
   "solves_one_step_until_time_aform (snd optns (\<lambda>_. ())) a b c d e f"
   if "solves_one_step_until_time_aform_fo optns a b c d e f"
   using that
   by (auto simp: solves_one_step_until_time_aform_fo_def file_output_def Print.file_output_def
       print_def[abs_def]
       split: if_splits)
 
 lemma solves_poincare_map_aform'_foI:
   "solves_poincare_map_aform' (snd optns (\<lambda>_. ())) a b c d e f g h i"
   if "solves_poincare_map_aform'_fo optns a b c d e f g h i"
   using that
   by (auto simp: solves_poincare_map_aform'_fo_def file_output_def Print.file_output_def
       print_def[abs_def]
       split: if_splits)
 
 lemma solves_poincare_map_onto_aform_foI:
   "solves_poincare_map_onto_aform (snd optns (\<lambda>_. ())) a b c d e f g h"
   if "solves_poincare_map_onto_aform_fo optns a b c d e f g h"
   using that
   by (auto simp: solves_poincare_map_onto_aform_fo_def file_output_def Print.file_output_def
       print_def[abs_def]
       split: if_splits)
 
 definition "can_mk_ode_ops fas safe_form \<longleftrightarrow> mk_ode_ops fas safe_form \<noteq> None"
 
 theorem solve_one_step_until_time_aform_integral_bounds:
   fixes f::"real \<Rightarrow> 'a::executable_euclidean_space"
   assumes "a \<le> b"
   assumes ba: "b - a \<in> {t1 .. t2}"
   assumes a: "a \<in> {a1 .. a2}"
   assumes ls_us_subset: "{eucl_of_list ls .. eucl_of_list us} \<subseteq> {l .. u}"
   assumes fas: "\<And>xs::real list. length xs > 0 \<Longrightarrow> interpret_form safe_form xs \<Longrightarrow>
     (1::real, f (xs ! 0)) = einterpret fas xs"
   assumes D: "D = DIM('a) + 1" "D = CARD('i::enum)"
   assumes lenlu: "length ls + 1 = D" "length us + 1 = D"
   assumes lfas: "length fas = D"
   assumes mv: "can_mk_ode_ops fas safe_form"
   assumes FDERIV: "\<And>xs. interpret_form safe_form xs \<Longrightarrow> isFDERIV (length fas) [0..<length fas] fas xs"
   assumes sos[THEN solves_one_step_until_time_aform_foI]:
     "solves_one_step_until_time_aform_fo optns (the(mk_ode_ops fas safe_form))
       ((1,1), (aforms_of_ivls (a1#replicate (D - 1) 0) (a2#replicate (D - 1) 0)), None) t1 t2 (0#ls, t2#us) None"
   shows "integral {a .. b} f \<in> {l .. u}"
 proof -
   have lens0: "length ((x::real) # replicate (D - 1) 0) = DIM(real \<times> 'a)" for x
     using assms
     by auto
   have a0: "(a, 0) \<in> {eucl_of_list (a1 # replicate (D - 1) 0)..eucl_of_list (a2 # replicate (D - 1) 0)}"
     using assms
     by (auto simp: eucl_of_list_prod)
   let ?U = "{x::real\<times>'a. interpret_form safe_form (list_of_eucl x)}"
   interpret ode_interpretation safe_form ?U fas "\<lambda>x. (1::real, f (fst x))" "undefined::'i"
     apply unfold_locales
     subgoal using assms by simp
     subgoal using assms by simp
     subgoal using mv by (simp add: D lfas)
     subgoal for x
       apply (cases x)
       by (rule HOL.trans[OF fas[symmetric]]) (auto simp: fas)
     subgoal using mv by (simp add: can_mk_ode_ops_def)
     subgoal by (rule FDERIV)
     done
   have lens: "length (0 # ls) = DIM(real \<times> 'a)" "length (t2 # us) = DIM(real \<times> 'a)" "aform.D odo = DIM(real \<times> 'a)"
     using lenlu
     by (simp_all add: lfas aform.D_def D aform.ode_e_def )
   have D_odo: "aform.D odo = DIM(real \<times> 'a)"
     by (auto simp: aform.D_def aform.ode_e_def lfas D)
   from solves_one_step_ivl[rule_format, OF order_refl order_refl lens0 lens0 order_refl lens(1,2) D_odo,
     unfolded odo_def,
     OF sos ba a0]
   have lsus: "flow0 (a, 0) (b - a) \<in> {eucl_of_list (0#ls)..eucl_of_list (t2#us)}"
     and exivl: "b - a \<in> existence_ivl0 (a, 0)"
     by auto
   have flow: "flow0 (a, 0) (b - a) \<in> UNIV \<times> {l..u}"
     using lsus
     apply (rule rev_subsetD)
     using ls_us_subset
     by (auto simp: eucl_of_list_prod)
   from ivl_subset_existence_ivl[OF exivl] \<open>a \<le> b\<close> exivl
   have "0 \<in> existence_ivl0 (a, 0)"
     by (auto simp del: existence_ivl_initial_time_iff)
   from mem_existence_ivl_iv_defined(2)[OF this]
   have safe: "(a, 0::'a) \<in> ?U" by simp
   from flow_solves_ode[OF UNIV_I this]
   have fs: "((\<lambda>t. (fst (flow0 (a, 0) t), snd (flow0 (a, 0) t))) solves_ode (\<lambda>_ x. (1, f (fst x)))) (existence_ivl0 (a, 0)) ?U"
     by simp
   with solves_odeD[OF fs]
   have vdp: "((\<lambda>t. (fst (flow0 (a, 0) t), snd (flow0 (a, 0) t))) has_vderiv_on (\<lambda>t. (1, f (fst (flow0 (a, 0) t))))) (existence_ivl0 (a, 0))"
     by simp
   have "fst (flow0 (a, 0) t) = a + t" if "t \<in> existence_ivl0 (a, 0)" for t
   proof -
     have "fst (flow0 (a, 0) 0) = a" using safe
       by auto
     have "((\<lambda>t. fst (flow0 (a, 0) t)) has_vderiv_on (\<lambda>x. 1)) (existence_ivl0 (a, 0))"
       using has_vderiv_on_PairD[OF vdp] by auto
     then have "((\<lambda>t. fst (flow0 (a, 0) t)) has_vderiv_on (\<lambda>x. 1)) {0--t}"
       apply (rule has_vderiv_on_subset)
       using closed_segment_subset_existence_ivl[OF that]
       by auto
     from fundamental_theorem_of_calculus_ivl_integral[OF this, THEN ivl_integral_unique]
       one_has_ivl_integral[of t 0, THEN ivl_integral_unique] safe
     show ?thesis
       by auto
   qed
   with vdp have "((\<lambda>t. (t, snd (flow0 (a, 0) t))) solves_ode (\<lambda>t x. (1, f (a + fst x))))
     (existence_ivl0 (a, 0)) ((existence_ivl0 (a, 0)) \<times> UNIV)"
     apply (intro solves_odeI)
      apply auto
     apply (auto simp: has_vderiv_on_def has_vector_derivative_def)
   proof goal_cases
     case (1 x)
     have r: "((\<lambda>(x, y). (x - a, y::'a)) has_derivative (\<lambda>x. x)) (at x within t)" for x t
       by (auto intro!: derivative_eq_intros)
     from 1 have "((\<lambda>x. (a + x, snd (flow0 (a, 0) x))) has_derivative (\<lambda>xa. (xa, xa *\<^sub>R f (a + x))))
         (at x within existence_ivl0 (a, 0))"
       by auto
     from has_derivative_in_compose2[OF r subset_UNIV _ this, simplified] 1
     have "((\<lambda>x. (x, snd (flow0 (a, 0) x))) has_derivative (\<lambda>y. (y, y *\<^sub>R f (a + x)))) (at x within existence_ivl0 (a, 0))"
       by auto
     then show ?case
       by simp
   qed
   from solves_autonomous_odeI[OF this]
   have "((\<lambda>t. snd (flow0 (a, 0) t)) solves_ode (\<lambda>b c. f (a + b))) (existence_ivl0 (a, 0)) UNIV"
     by simp \<comment> \<open>TODO: do non-autonomous -- autonomous conversion automatically!\<close>
   then have "((\<lambda>t. snd (flow0 (a, 0) t)) solves_ode (\<lambda>b c. f (a + b))) {0 .. b - a} UNIV"
     apply (rule solves_ode_on_subset)
     using exivl
     by (rule ivl_subset_existence_ivl) (rule order_refl)
   from integral_solves_autonomous_odeI[OF this]
   have "((\<lambda>b. f (a + b)) has_integral snd (flow0 (a, 0) (b - a))) (cbox 0 (b - a))"
     using \<open>a \<le> b\<close> safe
     by auto
   from has_integral_affinity[OF this, where m=1 and c="-a"]
   have "(f has_integral snd (flow0 (a, 0) (b - a))) {a..b}"
     by auto
   then have "integral {a..b} f = snd (flow0 (a, 0) (b - a))" by blast
   also have "\<dots> \<in> {l .. u}"
     using flow
     by auto
   finally show ?thesis by simp
 qed
 
 lemma [code_computation_unfold]:
   "numeral x = real_of_int (Code_Target_Int.positive x)"
   by simp
 lemma [code_computation_unfold]: "numeral x \<equiv> Float (Code_Target_Int.positive x) 0"
   by (simp add: Float_def float_of_numeral)
 
 definition no_print::"String.literal \<Rightarrow> unit" where "no_print x = ()"
 
 lemmas [approximation_preproc] = list_of_eucl_real list_of_eucl_prod append.simps
 
 named_theorems DIM_simps
 lemmas [DIM_simps] =
   DIM_real DIM_prod length_nth_simps
   add_numeral_special
   add_numeral_special card_sum card_prod card_bit0 card_bit1 card_num0 card_num1
   numeral_times_numeral numeral_mult mult_1_right mult_1
   aform.D_def
 
 lemma numeral_refl: "numeral x = numeral x" by simp
 
 lemma plain_floatarith_approx_eq_SomeD:
   "approx prec fa [] = Some (the (approx prec fa []))"
   if "plain_floatarith 0 fa"
   using that
   by (auto dest!: plain_floatarith_approx_not_None[where p=prec and XS=Nil])
 
 definition [simp]: "approx1 p f xs = real_of_float (lower (the (approx p f xs)))"
 definition [simp]: "approx2 p f xs = real_of_float (upper (the (approx p f xs)))"
 definition [simp]: "approx_defined p f xs \<longleftrightarrow> approx p f xs \<noteq> None"
 
 definition "approxs p fs xs = those (map (\<lambda>f. approx p f xs) fs)"
 definition [simp]: "approxs1 p f xs =
   (case approxs p f xs of Some y \<Rightarrow> (map (real_of_float o lower) y) | None \<Rightarrow> replicate (length f) 0)"
 definition [simp]: "approxs2 p f xs =
   (case approxs p f xs of Some y \<Rightarrow> (map (real_of_float o upper) y) | None \<Rightarrow> replicate (length f) 0)"
 definition "approxs_defined p fs xs \<longleftrightarrow> (those (map (\<lambda>f. approx p f xs) fs) \<noteq> None)"
 
 lemma length_approxs:
   "length (approxs1 p f xs) = length f"
   "length (approxs2 p f xs) = length f"
   by (auto simp: approxs_def dest!: those_eq_SomeD split: option.splits)
 
 lemma real_in_approxI:
   "x \<in> {(approx1 prec fa []) .. (approx2 prec fa [])}"
   if "x = interpret_floatarith fa []"
     "approx_defined prec fa []"
   using that
   by (force dest: approx_emptyD simp: set_of_eq)
 
 lemma real_subset_approxI:
   "{a .. b} \<subseteq> {(approx1 prec fa []) .. (approx2 prec fb [])}"
   if "a = interpret_floatarith fa []"
     "b = interpret_floatarith fb []"
     "approx_defined prec fa []"
     "approx_defined prec fb []"
   using that
   by (force dest: approx_emptyD simp: set_of_eq)
 
 
 lemma approxs_eq_Some_lengthD: "length ys = length fas" if "approxs prec fas XS = Some ys"
   using that
   by (auto simp: approxs_def dest!: those_eq_SomeD)
 
 lemma approxs_pointwise:
   "interpret_floatarith (fas ! ia) xs \<in> {real_of_float (lower (ys ! ia)) .. (upper (ys ! ia))}"
   if "approxs prec fas XS = Some ys" "bounded_by xs XS" "ia < length fas"
 proof -
   from those_eq_SomeD[OF that(1)[unfolded approxs_def]]
   have ys: "ys = map (the \<circ> (\<lambda>f. approx prec f XS)) fas"
     and ex: "\<exists>y. i < length fas \<longrightarrow> approx prec (fas ! i) XS = Some y" for i
     by auto
   from ex[of ia] that obtain ivl where ivl: "approx prec (fas ! ia) XS = Some ivl" by auto
   from approx[OF that(2) this]
   have "interpret_floatarith (fas ! ia) xs \<in>\<^sub>r ivl"
     by auto
   moreover
   have "ys ! ia = ivl"
     unfolding ys
     apply (auto simp: o_def)
     apply (subst nth_map)
      apply (simp add: that)
     using ivl by simp
   ultimately show ?thesis
     using that
     by (auto simp: approxs_eq_Some_lengthD set_of_eq split: prod.splits)
 qed
 
 lemmas approxs_pointwise_le = approxs_pointwise[simplified, THEN conjunct1]
   and approxs_pointwise_ge = approxs_pointwise[simplified, THEN conjunct2]
 
 lemma approxs_eucl:
   "eucl_of_list (interpret_floatariths fas xs) \<in>
     {eucl_of_list (map lower ys) .. eucl_of_list (map upper ys)::'a::executable_euclidean_space}"
   if "approxs prec fas XS = Some ys"
     "length fas = DIM('a)"
     "bounded_by xs XS"
   using that
   by (auto simp: eucl_le[where 'a='a] eucl_of_list_inner o_def approxs_eq_Some_lengthD
       intro!: approxs_pointwise_le approxs_pointwise_ge)
 
 lemma plain_floatariths_approx_eq_SomeD:
   "approxs prec fas [] = Some (the (approxs prec fas []))"
   if "list_all (plain_floatarith 0) fas"
   using that
   apply (induction fas)
    apply (auto simp: approxs_def split: option.splits dest!: plain_floatarith_approx_eq_SomeD)
   subgoal for a fas aa
     apply (cases "those (map (\<lambda>f. approx prec f []) fas)")
     by auto
   done
 
 lemma approxs_definedD:
   "approxs prec fas xs = Some (the (approxs prec fas xs))"
   if "approxs_defined prec fas xs"
   using that
   by (auto simp: approxs_defined_def approxs_def)
 
 lemma approxs_defined_ne_None[simp]:
   "approxs prec fas xs \<noteq> None"
   if "approxs_defined prec fas xs"
   using that
   by (auto simp: approxs_defined_def approxs_def)
 
 lemma approx_subset_euclI:
   "{eucl_of_list (approxs2 prec fals [])::'a .. eucl_of_list (approxs1 prec faus [])} \<subseteq> {l .. u}"
   if "list_of_eucl l = interpret_floatariths fals []"
     and "list_of_eucl u = interpret_floatariths faus []"
     and "length fals = DIM('a::executable_euclidean_space)"
     and "length faus = DIM('a::executable_euclidean_space)"
     and "approxs_defined prec fals []"
     and "approxs_defined prec faus []"
   using that
   by (auto intro!: bounded_by_Nil
       dest!: approxs_eucl[where 'a='a] list_of_eucl_eqD plain_floatariths_approx_eq_SomeD[where prec=prec]
         split: option.splits)
 
 lemma eucl_subset_approxI:
   "{l .. u} \<subseteq> {eucl_of_list (approxs1 prec fals [])::'a .. eucl_of_list (approxs2 prec faus [])}"
   if "list_of_eucl l = interpret_floatariths fals []"
     and "list_of_eucl u = interpret_floatariths faus []"
     and "length fals = DIM('a::executable_euclidean_space)"
     and "length faus = DIM('a::executable_euclidean_space)"
     and "approxs_defined prec fals []"
     and "approxs_defined prec faus []"
   using that
   by (auto intro!: bounded_by_Nil
       dest!: approxs_eucl[where 'a='a] list_of_eucl_eqD plain_floatariths_approx_eq_SomeD[where prec=prec]
         split: option.splits)
 
 lemma approx_subset_listI:
   "list_interval (approxs2 prec fals []) (approxs1 prec faus []) \<subseteq> list_interval l u"
   if "l = interpret_floatariths fals []"
     and "u = interpret_floatariths faus []"
     and "length fals = length l"
     and "length faus = length u"
     and "approxs_defined prec fals []"
     and "approxs_defined prec faus []"
   using that
   apply (auto
       simp: list_interval_def list_all2_conv_all_nth
       dest: approxs_eq_Some_lengthD
       intro!: bounded_by_Nil
       dest!: plain_floatariths_approx_eq_SomeD[where prec=prec]
       split: option.splits)
    apply (rule order_trans)
     apply (rule approxs_pointwise_ge)
       apply assumption
      apply (rule bounded_by_Nil)
     apply (auto dest: approxs_eq_Some_lengthD)
   apply (subst interpret_floatariths_nth)
    apply (auto dest: approxs_eq_Some_lengthD)
     apply (rule approxs_pointwise_le[ge])
       apply assumption
      apply (rule bounded_by_Nil)
   apply (auto dest: approxs_eq_Some_lengthD)
   done
 
 
 definition "unit_list D n = (replicate D 0)[n:=1]"
 
 definition "mirror_sctn (sctn::real list sctn) = Sctn (map uminus (normal sctn)) (- pstn sctn)"
 definition "mirrored_sctn b (sctn::real list sctn) = (if b then mirror_sctn sctn else sctn)"
 
 lemma mirror_sctn_simps[simp]: "pstn (mirror_sctn sctn) = - pstn sctn"
   "normal (mirror_sctn sctn) = map uminus (normal sctn)"
   by (cases sctn) (auto simp: mirror_sctn_def)
 
 lemma length_unit_list[simp]: "length (unit_list D n) = D"
   by (auto simp: unit_list_def)
 
 lemma eucl_of_list_unit_list[simp]:
   "(eucl_of_list (unit_list D n)::'a::executable_euclidean_space) = Basis_list ! n"
   if "D = DIM('a)" "n < D"
   using that
   by (auto simp: unit_list_def eucl_of_list_inner inner_Basis nth_list_update'
       intro!: euclidean_eqI[where 'a='a])
 
 lemma le_eucl_of_list_iff: "(t::'a::executable_euclidean_space) \<le> eucl_of_list uX0 \<longleftrightarrow>
   (\<forall>i. i < DIM('a) \<longrightarrow> t \<bullet> Basis_list ! i \<le> uX0 ! i)"
   if "length uX0 = DIM('a)"
   using that
   apply (auto simp: eucl_le[where 'a='a] eucl_of_list_inner)
   using nth_Basis_list_in_Basis apply force
   by (metis Basis_list in_Basis_index_Basis_list index_less_size_conv length_Basis_list)
 
 lemma eucl_of_list_le_iff: "eucl_of_list uX0 \<le> (t::'a::executable_euclidean_space) \<longleftrightarrow>
   (\<forall>i. i < DIM('a) \<longrightarrow> uX0 ! i \<le> t \<bullet> Basis_list ! i)"
   if "length uX0 = DIM('a)"
   using that
   apply (auto simp: eucl_le[where 'a='a] eucl_of_list_inner)
   using nth_Basis_list_in_Basis apply force
   by (metis Basis_list in_Basis_index_Basis_list index_less_size_conv length_Basis_list)
 
 lemma Joints_aforms_of_ivls: "Joints (aforms_of_ivls lX0 uX0) = list_interval lX0 uX0"
   if "list_all2 (\<le>) lX0 uX0"
   using that
   apply (auto simp: list_interval_def dest: Joints_aforms_of_ivlsD1[OF _ that]
       Joints_aforms_of_ivlsD2[OF _ that] list_all2_lengthD
       intro!: aforms_of_ivls)
   by (auto simp: list_all2_conv_all_nth)
 
 lemma list_of_eucl_in_list_interval_iff:
   "list_of_eucl x0 \<in> list_interval lX0 uX0 \<longleftrightarrow> x0 \<in> {eucl_of_list lX0 .. eucl_of_list uX0::'a}"
   if "length lX0 = DIM('a::executable_euclidean_space)"
      "length uX0 = DIM('a::executable_euclidean_space)"
   using that
   by (auto simp: list_interval_def eucl_of_list_le_iff le_eucl_of_list_iff list_all2_conv_all_nth)
 
 
 text \<open>TODO: make a tactic out of this?!\<close>
 
 lemma file_output_iff: "file_output s f = f (\<lambda>_. ())"
   by (auto simp: file_output_def print_def[abs_def] Print.file_output_def)
 
 context ode_interpretation begin
 
 lemma poincare_mapsto_subset:
      "poincare_mapsto P  X0 SS CX R"
   if "poincare_mapsto P' Y0 RR CZ S" "X0 \<subseteq> Y0" "CZ \<subseteq> CX" "S \<subseteq> R" "RR = SS" "P = P'"
   using that
   by (force simp: poincare_mapsto_def)
 
 theorem solves_poincare_map_aform'_derivI:
   assumes solves:
     "solves_poincare_map_aform'_fo optns odo
       (Sctn (unit_list D n) (lP ! n))
       guards
       (lP, uP)
       (Sctn (unit_list D n) (lP ! n))
       roi
       [((1,1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))]
       (lR, uR)
       (Some (lDR, uDR))"
     and D: "D = DIM('a)"
   assumes DS: "list_interval lDR uDR \<subseteq> list_interval lDS uDS"
   and dim: "aform.D odo = DIM('a)"
   and lens:
     "length (lP) = DIM('a)" "length (uP) = DIM('a)"
     "length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
     "length (lR) = DIM('a)" "length (uR) = DIM('a)"
     "length DX0 = DIM('a)*DIM('a)"
     "length lDR = CARD('n) * CARD('n)"
     "length uDR = CARD('n) * CARD('n)"
     and guards:
     "(\<And>a xs b ba ro.
         (xs, ro) \<in> set guards \<Longrightarrow>
       ((a, b), ba) \<in> set xs \<Longrightarrow>
           length a = DIM('a) \<and> length b = DIM('a) \<and> length (normal ba) = DIM('a))"
   and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
   and plane: "uP ! n = lP ! n"
   and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
   and nD: "n < DIM('a)"
   and SS: "SS = {x::'a. x \<bullet> Basis_list ! n \<le> lP ! n}"
   and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
   shows "\<forall>x\<in>X0. returns_to P x \<and>
     return_time P differentiable at x within SS \<and>
     (\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
          poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
 proof (rule ballI)
   fix x assume "x \<in> X0"
   then have la2: "list_all2 (\<le>) lX0 uX0"
     using X0
     by (force simp: subset_iff eucl_of_list_le_iff le_eucl_of_list_iff lens list_all2_conv_all_nth)
   have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))] \<Longrightarrow>
       aform.c1_info_invare DIM('a) X"
     for X
     by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens power2_eq_square)
   have 2: "length (normal (Sctn (unit_list D n) (lP ! n))) = DIM('a)"
     by (auto simp: D)
   have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
     by (auto simp: lens)
   have 4: "length (normal (Sctn (unit_list D n) (lP ! n))) = DIM('a)"
     by (auto simp: D)
   have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
     "aform.lvivl'_invar (CARD('n) * CARD('n)) (Some (lDR, uDR))"
     by (auto simp: lens aform.lvivl'_invar_def)
   note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff]
   have "poincare_mapsto
      (set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
      (aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))])
      (below_halfspace
        (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
      (aform.Csafe odo -
       set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
      (set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' (Some (lDR, uDR)))"
     by (rule solves_poincare_map_aform'[OF solves, OF 1 dim 2 3 4 guards 5])
       auto
   then have "poincare_mapsto P (X0 \<times> {blinfun_of_list DX0}::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set) SS UNIV
     (R \<times> blinfuns_of_lvivl (lDS, uDS))"
     apply (rule poincare_mapsto_subset)
     subgoal using X0
       apply (auto simp: aform.c1_info_of_appre_def aform.c1_info_of_appr_def
           aform.c1_info_of_apprse_def)
       subgoal for x0
         apply (rule image_eqI[where x="list_of_eucl x0@DX0"])
         using lens
          apply (auto simp: flow1_of_list_def aforms_of_point_def Joints_aforms_of_ivls_append_point)
         apply (rule imageI)
         using X0
         by (auto simp: Joints_aforms_of_ivls la2 list_of_eucl_in_list_interval_iff)
       done
     subgoal by simp
     subgoal using R DS
       by (auto simp: set_of_lvivl_def set_of_ivl_def blinfuns_of_lvivl'_def blinfuns_of_lvivl_def
           lens)
     subgoal
       using assms
       by (simp add: below_halfspace_def le_halfspace_def[abs_def])
     subgoal
       using assms
       by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
           le_eucl_of_list_iff eucl_of_list_le_iff)
     done
   then show "returns_to P x \<and>
     return_time P differentiable at x within SS \<and>
     (\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
          poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
     using \<open>x \<in> X0\<close>
     by (auto simp: poincare_mapsto_def)
 qed
 
 definition guards_invar::"nat \<Rightarrow> (((real list \<times> real list) \<times> real list sctn) list \<times>
     (real \<times> real pdevs) reach_options) list \<Rightarrow> bool"
   where "guards_invar D guards = (\<forall>(xs, ro) \<in> set guards.
     \<forall>((a, b), ba) \<in> set xs. length a = D \<and> length b = D \<and> length (normal ba) = D)"
 
 theorem solves_poincare_map_aform'I:
   assumes "TAG_optns optns"
   assumes "TAG_reach_optns roi"
   assumes "TAG_sctn mirrored"
   assumes D: "D = DIM('a)"
   assumes guards: "guards_invar DIM('a) guards"
   and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
   and plane: "uP ! n = lP ! n"
   and dim: "aform.D odo = DIM('a)"
   and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
   and nD: "n < DIM('a)"
   and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
   and lens:
     "length (lP) = DIM('a)" "length (uP) = DIM('a)"
     "length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
     "length (lR) = DIM('a)" "length (uR) = DIM('a)"
   and solves:
     "solves_poincare_map_aform'_fo optns odo
       (Sctn (unit_list D n) (lP ! n))
       guards
       (lP, uP)
       (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))
       roi
       [((1,1), aforms_of_ivls lX0 uX0, None)]
       (lR, uR)
       None"
 shows "\<forall>x\<in>X0. returns_to P x \<and> poincare_map P x \<in> R"
 proof -
   note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff]
   have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, None)] \<Longrightarrow>
       aform.c1_info_invare DIM('a) X"
     for X
     by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens)
   have 2: "length (normal ((mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) = DIM('a)"
     by (auto simp: D mirrored_sctn_def)
   have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
     by (auto simp: lens)
   have 4: "length (normal (((Sctn (unit_list D n) (lP ! n))))) = DIM('a)"
     by (auto simp: D mirrored_sctn_def)
   from guards have guards: "(xs, ro) \<in> set guards \<Longrightarrow>
        ((a, b), ba) \<in> set xs \<Longrightarrow>
        length a = DIM('a) \<and>
        length b = DIM('a) \<and> length (normal ba) = DIM('a)" for xs ro a b ba
     by (auto simp: guards_invar_def)
   have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
     "aform.lvivl'_invar (CARD('n) * CARD('n)) None"
     by (auto simp: lens)
   have "poincare_mapsto
     (set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
     (aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, None)])
     (below_halfspace (map_sctn eucl_of_list (Sctn (unit_list D n) (lP ! n))))
     (aform.Csafe odo -
       set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
      (set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' None)"
     by (rule solves_poincare_map_aform'[OF solves, OF 1 dim 2 3 4 guards 5])
   then have "poincare_mapsto P (X0 \<times> UNIV::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set)
       (below_halfspace (map_sctn eucl_of_list (((Sctn (unit_list D n) (lP ! n)))))) UNIV (R \<times> UNIV)"
     apply (rule poincare_mapsto_subset)
     subgoal using X0
       apply (auto simp: aform.c1_info_of_apprse_def aform.c1_info_of_appre_def
           aform.c1_info_of_appr_def)
       apply (rule image_eqI) apply (rule eucl_of_list_list_of_eucl[symmetric])
       apply (rule aforms_of_ivls)
       by (auto simp add: lens subset_iff le_eucl_of_list_iff eucl_of_list_le_iff)
     subgoal by simp
     subgoal using R by (auto simp: set_of_lvivl_def set_of_ivl_def)
     subgoal
       using assms
       by (simp add: below_halfspace_def le_halfspace_def[abs_def])
     subgoal
       using assms
       by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
           le_eucl_of_list_iff eucl_of_list_le_iff mirrored_sctn_def mirror_sctn_def)  
     done
   then show "\<forall>x\<in>X0. returns_to P x \<and> poincare_map P x \<in> R"
     by (auto simp: poincare_mapsto_def)
 qed
 
 definition "poincare_map_from_outside = poincare_map"
 
 theorem poincare_maps_onto_aformI:
   assumes "TAG_optns optns"
   assumes "TAG_reach_optns roi"
   assumes "TAG_sctn mirrored"
   assumes D: "D = DIM('a)"
   assumes guards: "guards_invar DIM('a) guards"
   and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
   and plane: "uP ! n = lP ! n"
   and dim: "aform.D odo = DIM('a)"
   and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
   and nD: "n < DIM('a)"
   and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
   and lens:
     "length (lP) = DIM('a)" "length (uP) = DIM('a)"
     "length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
     "length (lR) = DIM('a)" "length (uR) = DIM('a)"
   and solves:
     "solves_poincare_map_onto_aform_fo optns odo
       guards
       (lP, uP)
       (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))
       roi
       [((1,1), aforms_of_ivls lX0 uX0, None)]
       (lR, uR)
       None"
 shows "\<forall>x\<in>X0. returns_to P x \<and> poincare_map_from_outside P x \<in> R"
 proof -
   note solves = solves[unfolded solves_poincare_map_onto_aform_fo_def file_output_iff]
   have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, None)] \<Longrightarrow>
       aform.c1_info_invare DIM('a) X"
     for X
     by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens)
   have 2: "length (normal ((mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n))))) = DIM('a)"
     by (auto simp: D mirrored_sctn_def)
   have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
     by (auto simp: lens)
   from guards have guards: "(xs, ro) \<in> set guards \<Longrightarrow>
        ((a, b), ba) \<in> set xs \<Longrightarrow>
        length a = DIM('a) \<and>
        length b = DIM('a) \<and> length (normal ba) = DIM('a)" for xs ro a b ba
     by (auto simp: guards_invar_def)
   have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
     "aform.lvivl'_invar (CARD('n) * CARD('n)) None"
     by (auto simp: lens)
   have "poincare_mapsto
     (set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
     (aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, None)])
     UNIV
     (aform.Csafe odo -
       set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
      (set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' None)"
     by (rule solves_poincare_map_onto_aform[OF solves, OF 1 dim 2 3 guards 5])
   then have "poincare_mapsto P (X0 \<times> UNIV::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set) UNIV UNIV (R \<times> UNIV)"
     apply (rule poincare_mapsto_subset)
     subgoal using X0
       apply (auto simp: aform.c1_info_of_apprse_def aform.c1_info_of_appre_def
           aform.c1_info_of_appr_def)
       apply (rule image_eqI) apply (rule eucl_of_list_list_of_eucl[symmetric])
       apply (rule aforms_of_ivls)
       by (auto simp add: lens subset_iff le_eucl_of_list_iff eucl_of_list_le_iff)
     subgoal by simp
     subgoal using R by (auto simp: set_of_lvivl_def set_of_ivl_def)
     subgoal by simp
     subgoal
       using assms
       by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
           le_eucl_of_list_iff eucl_of_list_le_iff mirrored_sctn_def mirror_sctn_def)  
     done
   then show "\<forall>x\<in>X0. returns_to P x \<and> poincare_map_from_outside P x \<in> R"
     by (auto simp: poincare_mapsto_def poincare_map_from_outside_def)
 qed
 
 end
 
 lemmas [simp] = length_approxs
 
 context includes ode_ops.lifting begin
 lift_definition empty_ode_ops::"ode_ops" is "([], true_form)"
   by auto
 end
 
 ML \<open>val ode_numerics_conv = @{computation_check
   terms:
     Trueprop
 
     Not
 
     solves_one_step_until_time_aform_fo
     solves_poincare_map_aform'_fo
     solves_poincare_map_onto_aform_fo
 
     num_options
     num_options_c1
     ro
 
     (* nat *)
     Suc "0::nat" "1::nat" "(+)::nat \<Rightarrow> nat \<Rightarrow> nat" "(-) ::nat \<Rightarrow> nat \<Rightarrow> nat" "(=)::nat\<Rightarrow>nat\<Rightarrow>bool"
     "(^)::nat\<Rightarrow>nat\<Rightarrow>nat"
 
     (* int / integer*)
     "(=)::int\<Rightarrow>int\<Rightarrow>bool"
     "(+)::int\<Rightarrow>int\<Rightarrow>int"
     "uminus::_\<Rightarrow>int"
     "uminus::_\<Rightarrow>integer"
     int_of_integer integer_of_int
     "0::int"
     "1::int"
     "(^)::int\<Rightarrow>nat\<Rightarrow>int"
 
     (* real *)
     "(=)::real\<Rightarrow>real\<Rightarrow>bool"
     "real_of_float"
     "(/)::real\<Rightarrow>real\<Rightarrow>real"
     "(^)::real\<Rightarrow>nat\<Rightarrow>real"
     "uminus::real\<Rightarrow>_"
     "(+)::real\<Rightarrow>real\<Rightarrow>real" "(-)::real\<Rightarrow>real\<Rightarrow>real"  "(*)::real\<Rightarrow>real\<Rightarrow>real"
     real_divl real_divr
     real_of_int
     "0::real"
     "1::real"
 
     (* rat *)
     Fract
     "0::rat"
     "1::rat"
     "(+)::rat\<Rightarrow>rat\<Rightarrow>rat"
     "(-)::rat\<Rightarrow>rat\<Rightarrow>rat"
     "(*)::rat\<Rightarrow>rat\<Rightarrow>rat"
     "uminus::rat\<Rightarrow>_"
     "(/)::rat\<Rightarrow>rat\<Rightarrow>rat"
     "(^)::rat\<Rightarrow>nat\<Rightarrow>rat"
 
     (* ereal *)
     "1::ereal"
 
     (* lists: *)
     "replicate::_\<Rightarrow>real\<Rightarrow>_"
     "unit_list::_\<Rightarrow>_\<Rightarrow>real list"
     "Nil::(nat \<times> nat \<times> string) list"
     "Cons::_\<Rightarrow>_\<Rightarrow>(nat \<times> nat \<times> string) list"
     "Nil::(nat \<times> nat \<times> string \<times> nat list) list"
     "Cons::_\<Rightarrow>_\<Rightarrow>(nat \<times> nat \<times> string \<times> nat list) list"
     "Nil::real list"
     "Cons::_\<Rightarrow>_\<Rightarrow>real list"
     "Nil::nat list"
     "Cons::_\<Rightarrow>_\<Rightarrow>nat list"
     "Nil::string list"
     "Cons::_\<Rightarrow>_\<Rightarrow>string list"
     "Nil::real aform list"
     "Cons::_\<Rightarrow>_\<Rightarrow>real aform list"
     "Nil::(float interval) option list"
     "Cons::_\<Rightarrow>_\<Rightarrow>(float interval) option list"
 
     "nth::_\<Rightarrow>_\<Rightarrow>real"
     "upt"
 
     (* products: *)
     "Pair::_\<Rightarrow>_\<Rightarrow>(nat \<times> string)"
     "Pair::_\<Rightarrow>_\<Rightarrow>(nat \<times> nat \<times> string)"
 
     "Pair::_\<Rightarrow>_\<Rightarrow>char list \<times> nat list"
     "Pair::_\<Rightarrow>_\<Rightarrow>nat \<times> char list \<times> nat list"
     "Pair::_\<Rightarrow>_\<Rightarrow>nat \<times> nat \<times> char list \<times> nat list"
 
     "Pair::_\<Rightarrow>_\<Rightarrow>char list \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow> (real \<times> real pdevs) numeric_options)"
     "Pair::_\<Rightarrow>_\<Rightarrow>ereal\<times>ereal"
     "Pair::_\<Rightarrow>_\<Rightarrow>real aform list \<times> real aform list option"
     "Pair::_\<Rightarrow>_\<Rightarrow>(ereal \<times> ereal) \<times> real aform list \<times> real aform list option"
 
     "Pair::_\<Rightarrow>_\<Rightarrow>real aform"
     "Pair::_\<Rightarrow>_\<Rightarrow>real list \<times> real list"
 
     "Nil::(((real list \<times> real list) \<times> real list sctn) list \<times> (real aform) reach_options) list"
     "Cons::_\<Rightarrow>_\<Rightarrow>(((real list \<times> real list) \<times> real list sctn) list \<times> (real aform) reach_options) list"
     "Nil::((real list \<times> real list) \<times> real list sctn) list"
     "Cons::_\<Rightarrow>_\<Rightarrow>((real list \<times> real list) \<times> real list sctn) list"
 
     "Pair::_\<Rightarrow>_\<Rightarrow>((real list \<times> real list) \<times> real list sctn) list \<times> real aform reach_options"
 
     "Nil::((ereal \<times> ereal) \<times> (real aform) list \<times> (real aform) list option) list"
     "Cons::_\<Rightarrow>_\<Rightarrow>((ereal \<times> ereal) \<times> (real aform) list \<times> (real aform) list option) list"
 
     (* option *)
     "None::(real aform) list option"
     "Some::_\<Rightarrow>(real aform) list option"
     "None::(real list \<times> real list) option"
     "Some::_\<Rightarrow>(real list \<times> real list) option"
 
     (* aforms *)
     "aform_of_ivl::_\<Rightarrow>_\<Rightarrow>real aform"
     aforms_of_ivls
     aforms_of_point
 
     (* pdevs*)
     "zero_pdevs::real pdevs"
     "zero_aforms::_ \<Rightarrow> real aform list"
 
     (* ode_ops *)
     mk_ode_ops
     init_ode_ops
     empty_ode_ops
     can_mk_ode_ops
     "the::ode_ops option \<Rightarrow> ode_ops"
     the_odo
 
     (* Characters/Strings *)
     String.Char
     String.implode
     "Nil::string"
     "Cons::_\<Rightarrow>_\<Rightarrow>string"
 
     (* float *)
     "(=)::float\<Rightarrow>float\<Rightarrow>bool" "(+)::float\<Rightarrow>float\<Rightarrow>float" "uminus::_\<Rightarrow>float" "(-)::_\<Rightarrow>_\<Rightarrow>float"
     Float float_of_int float_of_nat
 
     (* approximation... *)
     approx
     approx1
     approx2
     approxs1
     approxs2
     approx_defined
     approxs_defined
 
     (* floatarith *)
     "0::floatarith"
     "1::floatarith"
     "(+)::_\<Rightarrow>_\<Rightarrow>floatarith"
     "(-)::_\<Rightarrow>_\<Rightarrow>floatarith"
     "(*)::_\<Rightarrow>_\<Rightarrow>floatarith"
     "(/)::_\<Rightarrow>_\<Rightarrow>floatarith"
     "inverse::_\<Rightarrow>floatarith"
     "uminus::_\<Rightarrow>floatarith"
     "Sum\<^sub>e::_\<Rightarrow>nat list\<Rightarrow>floatarith"
     Sin Half Tan
     R\<^sub>e Norm
 
     (* form *)
     true_form
     Half
 
     (* Printing *)
     print
     no_print
 
     (* sections *)
     xsec xsec' ysec ysec' zsec zsec'
     xsec2 xsec2' ysec2 ysec2'
     ysec4 ysec4'
     mirrored_sctn
 
     Code_Target_Nat.natural
     Code_Target_Int.positive
     Code_Target_Int.negative
     Code_Numeral.positive
     Code_Numeral.negative
 
   datatypes:
     bool
     num
     floatarith
     "floatarith list"
     form
     "real list sctn"
     "real \<times> real"
 }
 \<close>
 ML \<open>fun ode_numerics_tac ctxt =
   CONVERSION (ode_numerics_conv ctxt) THEN' (resolve_tac ctxt [TrueI])\<close>
 
 lemma eq_einterpretI:
   assumes "list_of_eucl (VS::'a::executable_euclidean_space) = interpret_floatariths fas xs"
   assumes "length fas = DIM('a)"
   shows "VS = eucl_of_list (interpret_floatariths fas xs)"
   using assms
   apply (subst (asm) list_of_eucl_eucl_of_list[symmetric])
   apply (auto intro!: )
   by (metis eucl_of_list_list_of_eucl)
 
 lemma one_add_square_ne_zero[simp]: "1 + t * t \<noteq> 0" for t::real
   by (metis semiring_normalization_rules(12) sum_squares_eq_zero_iff zero_neq_one)
 
 lemma abs_rat_bound:
   "abs (x - y) \<le> e / f" if "y \<in> {yl .. yu}" "x \<in> {yu - real_divl p e f.. yl + real_divl p e f}" for x y e::real
 proof -
   note \<open>x \<in> _\<close>
   also have "{yu - real_divl p e f.. yl + real_divl p e f} \<subseteq> {yu - e / f .. yl + e / f}"
     by (auto intro!: diff_mono real_divl)
   finally show ?thesis
     using that
     unfolding abs_diff_le_iff
     by auto
 qed
 
 lemma in_ivl_selfI: "a \<in> {a .. a}" for a::real by auto
 
 lemma pi4_bnds: "pi / 4 \<in> {real_divl 80 (lb_pi 80) 4 .. real_divr 80 (ub_pi 80) 4}"
   using pi_boundaries[of 80]
   unfolding atLeastAtMost_iff
   by (intro conjI real_divl[le] real_divr[ge] divide_right_mono) auto
 
 lemma abs_minus_leI: "\<bar>x - x'\<bar> \<le> e" if "x \<in> {x' - e .. x' + e}" for x e::real
   using that
   by auto
 
 lemmas [DIM_simps] = Suc_numeral One_nat_def[symmetric] TrueI Suc_1 length_approxs arith_simps
 lemma (in ode_interpretation) length_ode_e[DIM_simps]: "length (ode_expression odo) = DIM('a)"
   by (auto simp: len)
 
 
 named_theorems solves_one_step_ivl_thms
 
 context ode_interpretation begin
 
 lemmas [solves_one_step_ivl_thms] =
   TAG_optns[OF solves_one_step_ivl[OF _ _ _ _ _ _ _ _ solves_one_step_until_time_aform_foI], rotated -1,
     of optns _ _ _ _ _ _ _ _ _ optns for optns]
 
 lemmas [solves_one_step_ivl_thms] =
   TAG_optns[OF solves_one_step_ivl'[OF _ _ _ _ _ _ _ _ _ _ _ _ solves_one_step_until_time_aform_foI], rotated -1,
     of optns _ _ _ _ _ _ _ _ _ _ _ _ _ _ optns for optns]
 
 lemmas [solves_one_step_ivl_thms] = solves_poincare_map_aform'I poincare_maps_onto_aformI
 
 end
 
 lemma TAG_optnsI: "TAG_optns optns" by simp
 
 named_theorems poincare_tac_theorems
 
 lemmas [DIM_simps] = one_less_numeral_iff rel_simps
 
 
 abbreviation "point_ivl a \<equiv> {a .. a}"
 
 lemma isFDERIV_compute: "isFDERIV D vs fas xs \<longleftrightarrow>
    (list_all (\<lambda>i. list_all (\<lambda>j. isDERIV (vs ! i) (fas ! j) xs) [0..<D]) [0..<D]) \<and> length fas = D \<and> length vs = D"
   unfolding isFDERIV_def
   by (auto simp: list.pred_set)
 
 
 theorem (in ode_interpretation) solves_poincare_map_aform'_derivI'[solves_one_step_ivl_thms]:
 \<comment> \<open>TODO: replace @{thm solves_poincare_map_aform'_derivI}\<close>
   assumes "TAG_optns optns"
   assumes "TAG_reach_optns roi"
   assumes "TAG_sctn mirrored"
     and D: "D = DIM('a)"
   assumes DS: "list_interval lDR uDR \<subseteq> list_interval lDS uDS"
     and ode_fas: "aform.D odo = DIM('a)"
     and guards: "guards_invar DIM('a) guards"
     and P: "P = {eucl_of_list lP .. eucl_of_list uP}"
     and plane: "uP ! n = lP ! n"
     and X0: "X0 \<subseteq> {eucl_of_list lX0 .. eucl_of_list uX0}"
     and nD: "n < DIM('a)"
     and R: "{eucl_of_list lR .. eucl_of_list uR} \<subseteq> R"
     and lens:
     "length (lP) = DIM('a)" "length (uP) = DIM('a)"
     "length (lX0) = DIM('a)" "length (uX0) = DIM('a)"
     "length (lR) = DIM('a)" "length (uR) = DIM('a)"
     "length DX0 = DIM('a)*DIM('a)"
     "length lDR = CARD('n) * CARD('n)"
     "length uDR = CARD('n) * CARD('n)"
     and SS: "SS = {x::'a. if mirrored then x \<bullet> Basis_list ! n \<le> lP ! n
         else x \<bullet> Basis_list ! n \<ge> lP ! n}"
   assumes solves:
     "solves_poincare_map_aform'_fo optns odo
       (mirrored_sctn (\<not>mirrored) (Sctn (unit_list D n) (lP ! n)))
       guards
       (lP, uP)
       (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))
       roi
       [((1,1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))]
       (lR, uR)
       (Some (lDR, uDR))"
   shows "\<forall>x\<in>X0. returns_to P x \<and>
     return_time P differentiable at x within SS \<and>
     (\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
          poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
 proof (rule ballI)
   fix x assume "x \<in> X0"
   then have la2: "list_all2 (\<le>) lX0 uX0"
     using X0
     by (force simp: subset_iff eucl_of_list_le_iff le_eucl_of_list_iff lens list_all2_conv_all_nth)
   have 1: "\<And>X. X \<in> set [((1::ereal, 1::ereal), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))] \<Longrightarrow>
       aform.c1_info_invare DIM('a) X"
     for X
     by (auto simp: aform.c1_info_invare_def aform.c1_info_invar_def lens power2_eq_square)
   have 2: "length (normal (mirrored_sctn (\<not>mirrored) (Sctn (unit_list D n) (lP ! n)))) = DIM('a)"
     by (auto simp: D mirrored_sctn_def)
   have 3: "length (fst (lP, uP)) = DIM('a)" "length (snd (lP, uP)) = DIM('a)"
     by (auto simp: lens)
   have 4: "length (normal (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))) = DIM('a)"
     by (auto simp: D mirrored_sctn_def)
   have 5: "length (fst (lR, uR)) = CARD('n)" "length (snd (lR, uR)) = CARD('n)"
     "aform.lvivl'_invar (CARD('n) * CARD('n)) (Some (lDR, uDR))"
     by (auto simp: lens aform.lvivl'_invar_def)
   note solves = solves[unfolded solves_poincare_map_aform'_fo_def file_output_iff]
   have "poincare_mapsto
      (set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
      (aform.c1_info_of_apprse [((1, 1), aforms_of_ivls lX0 uX0, Some (aforms_of_point DX0))])
      (below_halfspace (map_sctn eucl_of_list (mirrored_sctn (\<not>mirrored) (Sctn (unit_list D n) (lP ! n)))))
      (aform.Csafe odo -
       set_of_lvivl (lP, uP) \<inter>
       plane_of (map_sctn eucl_of_list (mirrored_sctn mirrored (Sctn (unit_list D n) (lP ! n)))))
      (set_of_lvivl (lR, uR) \<times> blinfuns_of_lvivl' (Some (lDR, uDR)))"
     by (rule solves_poincare_map_aform'[OF solves, OF 1 ode_fas 4 3 2 _ 5])
       (use guards in \<open>auto simp: guards_invar_def\<close>)
   then have "poincare_mapsto P (X0 \<times> {blinfun_of_list DX0}::('a \<times> ('a \<Rightarrow>\<^sub>L 'a)) set) SS UNIV
     (R \<times> blinfuns_of_lvivl (lDS, uDS))"
     apply (rule poincare_mapsto_subset)
     subgoal using X0
       apply (auto simp: aform.c1_info_of_appre_def aform.c1_info_of_appr_def
           aform.c1_info_of_apprse_def)
       subgoal for x0
         apply (rule image_eqI[where x="list_of_eucl x0@DX0"])
         using lens
          apply (auto simp: flow1_of_list_def aforms_of_point_def Joints_aforms_of_ivls_append_point)
         apply (rule imageI)
         using X0
         by (auto simp: Joints_aforms_of_ivls la2 list_of_eucl_in_list_interval_iff)
       done
     subgoal by simp
     subgoal using R DS
       by (auto simp: set_of_lvivl_def set_of_ivl_def blinfuns_of_lvivl'_def blinfuns_of_lvivl_def
           lens)
     subgoal
       using assms
       by (auto simp:
           below_halfspace_def le_halfspace_def[abs_def] mirrored_sctn_def mirror_sctn_def)
     subgoal
       using assms
       by (fastforce simp add: P set_of_lvivl_def set_of_ivl_def plane_of_def
           le_eucl_of_list_iff eucl_of_list_le_iff mirrored_sctn_def mirror_sctn_def)
     done
   then show "returns_to P x \<and>
     return_time P differentiable at x within SS \<and>
     (\<exists>D. (poincare_map P has_derivative blinfun_apply D) (at x within SS) \<and>
          poincare_map P x \<in> R \<and> D o\<^sub>L blinfun_of_list DX0 \<in> blinfuns_of_lvivl (lDS, uDS))"
     using \<open>x \<in> X0\<close>
     by (auto simp: poincare_mapsto_def)
 qed
 
 lemmas [DIM_simps] = aform.ode_e_def
 
 ML \<open>
 structure ODE_Numerics_Tac = struct
 fun mk_nat n = HOLogic.mk_number @{typ nat} n
 fun mk_int n = HOLogic.mk_number @{typ int} n
 fun mk_integer n = @{term integer_of_int} $ (HOLogic.mk_number @{typ int} n)
 fun mk_bool b = if b then @{term True} else @{term False}
 
 fun mk_numeralT n =
   let
     fun mk_bit 0 ty = Type (@{type_name bit0}, [ty])
       | mk_bit 1 ty = Type (@{type_name bit1}, [ty]);
     fun bin_of n =
       if n = 1 then @{typ num1}
       else if n = 0 then @{typ num0}
       else if n = ~1 then raise TERM ("negative type numeral", [])
       else
         let val (q, r) = Integer.div_mod n 2;
         in mk_bit r (bin_of q) end;
   in bin_of n end;
 
 fun print_tac' ctxt s = K (print_tac ctxt s)
 
 val using_master_directory =
   File.full_path o Resources.master_directory o Proof_Context.theory_of;
 
 fun using_master_directory_term ctxt s =
   (if s = "-" orelse s = ""
   then s
   else
     Path.explode s
     |> using_master_directory ctxt
     |> Path.implode)
   |> HOLogic.mk_string
 
 fun real_in_approx_tac ctxt p =
   let
     val inst_approx =
        (TVars.empty, Vars.make [((("prec", 0), @{typ nat}), mk_nat p |> Thm.cterm_of ctxt)])
     val approx_thm = Thm.instantiate inst_approx @{thm real_in_approxI}
   in
     resolve_tac ctxt [approx_thm]
       THEN' SOLVED' (reify_floatariths_tac ctxt)
       THEN' ode_numerics_tac ctxt
   end
 
 fun real_subset_approx_tac ctxt p =
   let
     val inst_approx =
        (TVars.empty, Vars.make [((("prec", 0), @{typ nat}), mk_nat p |> Thm.cterm_of ctxt)])
     val approx_thm = Thm.instantiate inst_approx @{thm real_subset_approxI}
   in
     resolve_tac ctxt [approx_thm]
       THEN' SOLVED' (reify_floatariths_tac ctxt)
       THEN' SOLVED' (reify_floatariths_tac ctxt)
       THEN' ode_numerics_tac ctxt
       THEN' ode_numerics_tac ctxt
   end
 
 fun basic_nt_ss ctxt nt =
   put_simpset HOL_basic_ss ctxt addsimps Named_Theorems.get ctxt nt
 
 fun DIM_tac defs ctxt = (Simplifier.simp_tac (basic_nt_ss ctxt @{named_theorems DIM_simps} addsimps defs))
 
 fun subset_approx_preconds_tac ctxt p thm =
   let
     val inst_approx = (TVars.empty, Vars.make [((("prec", 0), @{typ nat}), mk_nat p |> Thm.cterm_of ctxt)])
   in
             resolve_tac ctxt [Thm.instantiate inst_approx thm]
       THEN' SOLVED' (reify_floatariths_tac ctxt)
       THEN' SOLVED' (reify_floatariths_tac ctxt)
       THEN' SOLVED' (DIM_tac [] ctxt)
       THEN' SOLVED' (DIM_tac [] ctxt)
       THEN' SOLVED' (ode_numerics_tac ctxt)
       THEN' SOLVED' (ode_numerics_tac ctxt)
   end
 
 val cfg_trace = Attrib.setup_config_bool @{binding ode_numerics_trace} (K false)
 fun tracing_tac ctxt = if Config.get ctxt cfg_trace then print_tac ctxt else K all_tac
 fun tracing_tac' ctxt = fn s => K (tracing_tac ctxt s)
 
 fun eucl_subset_approx_tac ctxt p = subset_approx_preconds_tac ctxt p @{thm eucl_subset_approxI}
 fun approx_subset_eucl_tac ctxt p = subset_approx_preconds_tac ctxt p @{thm approx_subset_euclI}
 fun approx_subset_list_tac ctxt p = subset_approx_preconds_tac ctxt p @{thm approx_subset_listI}
 
 val static_simpset = Simplifier.simpset_of @{context}
 
 fun nth_tac ctxt =
   Simplifier.simp_tac
     (put_simpset HOL_basic_ss ctxt addsimps @{thms nth_Cons_0 nth_Cons_Suc numeral_nat})
 fun nth_list_eq_tac ctxt n = Subgoal.FOCUS_PARAMS (fn {context, concl, ...} =>
   case try (Thm.term_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq) concl
   of
     SOME (@{const List.nth(real)} $ xs $ Var _, @{const List.nth(real)} $ ys $ Var _) =>
     let
       val i = find_index (op=) (HOLogic.dest_list xs ~~ HOLogic.dest_list ys)
       val thm = Goal.prove context [] []
         (HOLogic.mk_eq (@{const List.nth(real)} $ xs $ HOLogic.mk_number @{typ nat} i,
           @{const List.nth(real)} $ ys $ HOLogic.mk_number @{typ nat} i) |> HOLogic.mk_Trueprop)
         (fn {context, ...} => HEADGOAL (nth_tac context))
     in
       SOLVE (HEADGOAL (resolve_tac context [thm]))
     end
   | _ => no_tac
   ) ctxt n
 
 fun numeric_precond_step_tac defs thms p = Subgoal.FOCUS_PARAMS (fn {context, concl, ...} =>
   let
     val prems = Logic.strip_imp_prems (Thm.term_of concl)
     val conclusion = Logic.strip_imp_concl (Thm.term_of concl)
   in
     (case conclusion |> HOLogic.dest_Trueprop of
       @{const Set.member(real)} $ _ $ _ =>
         tracing_tac context "numeric_precond_step: real in approx"
         THEN HEADGOAL (real_in_approx_tac context p)
     | Const(@{const_name less_eq}, _) $
       (Const (@{const_name atLeastAtMost}, _) $ _ $ _) $
       (Const (@{const_name atLeastAtMost}, _) $ Var _ $ Var _)  =>
         tracing_tac context "numeric_precond_step: approx subset eucl"
         THEN HEADGOAL (real_subset_approx_tac context p)
     | Const (@{const_name less_eq}, _) $
         (Const (@{const_name atLeastAtMost}, _) $ (Const (@{const_name eucl_of_list}, _) $ Var _) $ _) $ _ =>
         tracing_tac context "numeric_precond_step: approx subset eucl"
         THEN HEADGOAL (approx_subset_eucl_tac context p)
     | Const (@{const_name less_eq}, _) $ _ $
         (Const (@{const_name atLeastAtMost}, _) $ (Const (@{const_name eucl_of_list}, _) $ Var _) $ _) =>
         tracing_tac context "numeric_precond_step: eucl subset approx"
         THEN HEADGOAL (eucl_subset_approx_tac context p)
     | Const (@{const_name less_eq}, _) $
       (@{const list_interval(real)} $ _ $ _) $
       (@{const list_interval(real)} $ _ $ _) =>
         tracing_tac context "numeric_precond_step: approx subset list"
         THEN HEADGOAL (approx_subset_list_tac context p)
     | @{const HOL.eq(nat)} $ _ $ _ =>
         tracing_tac context "numeric_precond_step: DIM_tac"
         THEN HEADGOAL (SOLVED' (DIM_tac [] context))
     | @{const less(nat)} $ _ $ _ =>
         tracing_tac context "numeric_precond_step: DIM_tac"
         THEN HEADGOAL (SOLVED' (DIM_tac [] context))
     | @{const HOL.eq(real)} $ (@{const nth(real)} $ _ $ _) $ (@{const nth(real)} $ _ $ _) =>
         tracing_tac context "numeric_precond_step: nth_list_eq_tac"
         THEN HEADGOAL (SOLVED' (nth_list_eq_tac context))
     | Const (@{const_name "HOL.eq"}, _) $ _ $
         (Const (@{const_name eucl_of_list}, _) $ (@{const interpret_floatariths} $ _ $ _)) =>
         tracing_tac context "numeric_precond_step: reify floatariths"
         THEN HEADGOAL (resolve_tac context @{thms eq_einterpretI} THEN' reify_floatariths_tac context)
     | t as _ $ _ =>
       let
         val (c, args) = strip_comb t
       in
         if member (op=)
           [@{const "solves_one_step_until_time_aform_fo"},
            @{const "solves_poincare_map_aform'_fo"},
            @{const "solves_poincare_map_onto_aform_fo"},
            @{const "can_mk_ode_ops"}
           ] c
         then
           tracing_tac context "numeric_precond_step: ode_numerics_tac"
           THEN HEADGOAL (
             CONVERSION (Simplifier.rewrite (put_simpset HOL_basic_ss context addsimps defs))
             THEN' tracing_tac' context "numeric_precond_step: ode_numerics_tac (unfolded)"
             THEN' ode_numerics_tac context)
         else if member (op=)
           [@{const "isFDERIV"}] c
         then
           tracing_tac context "numeric_precond_step: isFDERIV"
           THEN HEADGOAL (SOLVED'(Simplifier.asm_full_simp_tac
               (put_simpset static_simpset context addsimps (@{thms isFDERIV_def less_Suc_eq_0_disj isDERIV_Power_iff} @ thms @ defs))
               THEN' tracing_tac' context "numeric_precond_step: simplified isFDERIV"
           ))
         else
           tracing_tac context "numeric_precond_step: boolean, try thms"
           THEN HEADGOAL (SOLVED' (resolve_tac context thms))
       end
     | _ =>
         tracing_tac context "numeric_precond_step: boolean constant"
         THEN no_tac
     )
   end)
 
 fun integral_bnds_tac_gen_start sstep d p m N atol filename ctxt i =
   let
     val insts =
        (TVars.make [((("'i", 0), @{sort "{enum}"}), mk_numeralT (d + 1) |> Thm.ctyp_of ctxt)],
         Vars.make [((("optns", 0), @{typ "string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow>(real aform) numeric_options)"}),
            HOLogic.mk_prod
              (using_master_directory_term ctxt filename,
               (@{term num_options} $ mk_nat p $ mk_int sstep $ mk_nat m $ mk_nat N $ mk_int atol $
               @{term "[(0::nat, 1::nat, ''0x000000'')]"}))
           |> Thm.cterm_of ctxt),
         ((("safe_form", 0), @{typ form}), @{cterm true_form})
         ])
   in
           resolve_tac ctxt [Thm.instantiate insts @{thm solve_one_step_until_time_aform_integral_bounds}] i
     THEN (Lin_Arith.tac ctxt i ORELSE Simplifier.simp_tac ctxt i)
   end
 fun integral_bnds_tac_gen sstep d p m N atol filename thms ctxt =
   integral_bnds_tac_gen_start sstep d p m N atol filename ctxt
   THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (numeric_precond_step_tac [] thms p ctxt)
 
 val integral_bnds_tac = integral_bnds_tac_gen 5
 
 fun mk_proj (m, n, s) = HOLogic.mk_tuple [mk_nat m, mk_nat n, HOLogic.mk_string s]
 fun mk_projs projs = HOLogic.mk_list @{typ "nat \<times> nat \<times> string"} (map mk_proj projs)
 
 fun mk_string_list ds = HOLogic.mk_list @{typ "string"} (map HOLogic.mk_string ds)
 fun mk_nat_list ds = HOLogic.mk_list @{typ "nat"} (map mk_nat ds)
 fun mk_proj_c1 (m, n, s, ds) = HOLogic.mk_tuple [mk_nat m, mk_nat n, HOLogic.mk_string s, mk_nat_list ds]
 fun mk_projs_c1 projs = HOLogic.mk_list @{typ "nat \<times> nat \<times> string \<times> nat list"} (map mk_proj_c1 projs)
 
 fun TAG_optns_thm p sstep m N atol projs filename ctxt =
   Thm.instantiate (TVars.empty,
           Vars.make [((("optns", 0), @{typ "string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow>(real aform) numeric_options)"}),
            HOLogic.mk_prod
              (using_master_directory_term ctxt filename,
              @{term num_options} $ mk_nat p $ mk_int sstep $ mk_nat m $ mk_nat N $ mk_int atol $ mk_projs projs)
           |> Thm.cterm_of ctxt)]) @{thm TAG_optnsI}
 
 fun TAG_optns_c1_thm p sstep m N atol projs ds filename ctxt =
   Thm.instantiate (TVars.empty,
         Vars.make [((("optns", 0), @{typ "string \<times> ((String.literal \<Rightarrow> unit) \<Rightarrow>(real aform) numeric_options)"}),
            HOLogic.mk_prod
              (using_master_directory_term ctxt filename,
              @{term num_options_c1} $ mk_nat p $ mk_int sstep $ mk_nat m $ mk_nat N $ mk_int atol $ mk_projs_c1 projs $
               mk_string_list ds)
           |> Thm.cterm_of ctxt)]) @{thm TAG_optnsI}
 
 fun ode_bnds_tac_gen_start sstep p m N atol projs filename ctxt =
   tracing_tac' ctxt "solves_one_step_ivl_thms"
   THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
   THEN' tracing_tac' ctxt "resolved solves_one_step_ivl_thms"
   THEN' resolve_tac ctxt [TAG_optns_thm p sstep m N atol projs filename ctxt]
 
 fun ode_bnds_tac_gen sstep ode_defs p m N atol projs filename ctxt =
   ode_bnds_tac_gen_start sstep p m N atol projs filename ctxt
   THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (numeric_precond_step_tac ode_defs [] p ctxt)
 val ode_bnds_tac = ode_bnds_tac_gen 5
 
 fun ode'_bnds_tac_gen_start sstep p m N atol projs ds filename ctxt =
   tracing_tac' ctxt "solves_one_step_ivl_thms"
   THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
   THEN' tracing_tac' ctxt "resolved solves_one_step_ivl_thms"
   THEN' resolve_tac ctxt [TAG_optns_c1_thm p sstep m N atol projs ds filename ctxt]
 fun ode'_bnds_tac_gen sstep ode_defs p m N atol projs ds filename ctxt =
   ode'_bnds_tac_gen_start sstep p m N atol projs ds filename ctxt
   THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (numeric_precond_step_tac ode_defs [] p ctxt)
 
 val ode'_bnds_tac = ode'_bnds_tac_gen 5
 
 fun poincare_bnds_tac_gen_start sstep p m N atol projs filename ctxt =
   tracing_tac' ctxt "solves_one_step_ivl_thms"
   THEN' resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
   THEN' tracing_tac' ctxt "resolved solves_one_step_ivl_thms"
   THEN' resolve_tac ctxt [TAG_optns_thm p sstep m N atol projs filename ctxt]
 fun poincare_bnds_tac_gen sstep ode_defs p m N atol projs filename ctxt =
    poincare_bnds_tac_gen_start sstep p m N atol projs filename ctxt
   THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (
     numeric_precond_step_tac ode_defs
       (Named_Theorems.get ctxt @{named_theorems poincare_tac_theorems})
       p
       ctxt)
 
 val poincare_bnds_tac = poincare_bnds_tac_gen 5
 
 fun poincare'_bnds_tac_gen_start sstep p m N atol projs filename ctxt =
          resolve_tac ctxt (Named_Theorems.get ctxt @{named_theorems solves_one_step_ivl_thms})
     THEN' resolve_tac ctxt [TAG_optns_thm p sstep m N atol projs filename ctxt]
 fun poincare'_bnds_tac_gen sstep ode_defs p m N atol projs filename ctxt =
   poincare'_bnds_tac_gen_start sstep p m N atol projs filename ctxt
   THEN_ALL_NEW_FWD REPEAT_ALL_NEW_FWD (
     numeric_precond_step_tac ode_defs
       (Named_Theorems.get ctxt @{named_theorems poincare_tac_theorems})
       p
       ctxt)
 val poincare'_bnds_tac = poincare'_bnds_tac_gen 5
 end
 \<close>
 
 lemma (in auto_ll_on_open) Poincare_Banach_fixed_pointI:
   assumes "convex S" and c: "complete S" "S \<noteq> {}" and "S \<subseteq> T"
   assumes derivative_bounded: "\<forall>x\<in>S.
     poincare_map \<Sigma> x \<in> S \<and> (\<exists>D. (poincare_map \<Sigma> has_derivative D) (at x within T) \<and> onorm D \<le> B)"
   assumes B: "B < 1"
   shows "\<exists>!x. x \<in> S \<and> poincare_map \<Sigma> x = x"
   using c _ B
 proof (rule banach_fix)
   from derivative_bounded c show "0 \<le> B"
     by (auto dest!: has_derivative_bounded_linear onorm_pos_le)
   from derivative_bounded show "poincare_map \<Sigma> ` S \<subseteq> S" by auto
   obtain D where D:
     "\<forall>x \<in> S. (poincare_map \<Sigma> has_derivative D x) (at x within T) \<and>
       onorm (D x) \<le> B"
     apply atomize_elim
     apply (rule bchoice)
     using derivative_bounded
     by auto
   with \<open>S \<subseteq> T\<close> have "(\<And>x. x \<in> S \<Longrightarrow> (poincare_map \<Sigma> has_derivative D x) (at x within S))"
     by (auto intro: has_derivative_subset)
   from bounded_derivative_imp_lipschitz[of S "poincare_map \<Sigma>" D B, OF this] \<open>convex S\<close> D c
     \<open>0 \<le> B\<close>
   have "B-lipschitz_on S (poincare_map \<Sigma>)" by auto
   then show "\<forall>x\<in>S. \<forall>y\<in>S. dist (poincare_map \<Sigma> x) (poincare_map \<Sigma> y) \<le> B * dist x y"
     by (auto simp: lipschitz_on_def)
 qed
 
 ML \<open>open ODE_Numerics_Tac\<close>
 
 lemma isFDERIV_product: "isFDERIV n xs fas vs \<longleftrightarrow>
   length fas = n \<and> length xs = n \<and>
   list_all (\<lambda>(x, f). isDERIV x f vs) (List.product xs fas)"
   apply (auto simp: isFDERIV_def list_all2_iff in_set_zip list_all_length product_nth)
    apply auto
-  apply (metis gr_implies_not_zero gr_zeroI less_mult_imp_div_less pos_mod_bound)
+  apply (metis add_lessD1 less_mult_imp_div_less mod_less_divisor add_0)
   done
 
 end
diff --git a/thys/Padic_Field/Padic_Field_Powers.thy b/thys/Padic_Field/Padic_Field_Powers.thy
--- a/thys/Padic_Field/Padic_Field_Powers.thy
+++ b/thys/Padic_Field/Padic_Field_Powers.thy
@@ -1,11439 +1,11441 @@
 theory Padic_Field_Powers
   imports Ring_Powers Padic_Field_Polynomials Generated_Boolean_Algebra
           Padic_Field_Topology
 
 
 begin
 
 text\<open>This theory is intended to develop the necessary background on subsets of powers of a $p$-adic
 field to prove Macintyre's quantifier elimination theorem. In particular, we define semi-algebraic
 subsets of $\mathbb{Q}_p^n$, semi-algebraic functions $\mathbb{Q}_p^n \to \mathbb{Q}_p$, and semi-
 algebraic mappings $\mathbb{Q}_p^n \to \mathbb{Q}_p^m$  for arbitrary $n, m \in \mathbb{N}$. In
 addition we prove that many common sets and functions are semi-algebraic. We are closely following
 the paper \cite{denef1986} by Denef, where an algebraic proof of Mactinyre's theorem is developed.\<close>
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 section\<open>Cartesian Powers of $p$-adic Fields\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 lemma list_tl:
 "tl (t#x) = x"
   using List.list.sel(3) by auto
 
 lemma list_hd:
 "hd (t#x) = t"
   unfolding List.list.sel(1) by auto
 
 
 sublocale padic_fields <  cring_coord_rings Q\<^sub>p "UP Q\<^sub>p"
   unfolding  cring_coord_rings_axioms_def cring_coord_rings_def
   using Qp.zero_not_one UPQ.R_cring
   apply (simp add: UPQ.is_UP_cring)
   by auto
 
 sublocale padic_fields < Qp: domain_coord_rings Q\<^sub>p "UP Q\<^sub>p"
   unfolding domain_coord_rings_def cring_coord_rings_axioms_def cring_coord_rings_def
   using Qp.domain_axioms Qp.zero_not_one UPQ.R_cring
   apply (simp add: UPQ.UP_cring_axioms)
   by auto
 
 context padic_fields
 begin
 no_notation Zp.to_fun (infixl\<open>\<bullet>\<close> 70)
 no_notation ideal_prod (infixl "\<cdot>\<index>" 80)
 
 notation
 evimage (infixr "\<inverse>\<index>" 90) and
 euminus_set ("_ \<^sup>c\<index>" 70)
 
 
 type_synonym padic_tuple = "padic_number list"
 type_synonym padic_function = "padic_number \<Rightarrow> padic_number"
 type_synonym padic_nary_function = "padic_tuple \<Rightarrow> padic_number"
 type_synonym padic_function_tuple = "padic_nary_function list"
 type_synonym padic_nary_function_poly = "nat \<Rightarrow> padic_nary_function"
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Polynomials over $\mathbb{Q}_p$ and Polynomial Maps\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 lemma last_closed':
   assumes "x@[t] \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "t \<in> carrier  Q\<^sub>p"
   using assms last_closed[of n "x@[t]" Q\<^sub>p]
   by (metis (full_types) cartesian_power_car_memE gr0I last_snoc
       length_append_singleton less_not_refl zero_less_Suc)
 
 lemma segment_in_car':
   assumes "x@[t] \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
   shows "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
 proof-
   have 0: "length x = n"
     by (metis Suc_inject assms cartesian_power_car_memE length_append_singleton)
   have  "set x \<subseteq> set (x@[t])"
     by (metis rotate1.simps(2) set_rotate1 set_subset_Cons)
   then have 1: "set x \<subseteq> carrier Q\<^sub>p"
     using assms cartesian_power_car_memE''[of "x@[t]" Q\<^sub>p "Suc n"]
     by blast
   show ?thesis
     using 0 1 assms cartesian_power_car_memI[of x n Q\<^sub>p]
     by blast
 qed
 
 lemma Qp_zero:
 "Q\<^sub>p\<^bsup>0\<^esup> = nil_ring"
   unfolding cartesian_power_def
   by simp
 
 lemma Qp_zero_carrier:
 "carrier (Q\<^sub>p\<^bsup>0\<^esup>) = {[]}"
   by (simp add: Qp_zero)
 
 text\<open>Abbreviation for constant polynomials\<close>
 
 abbreviation(input) Qp_to_IP where
 "Qp_to_IP k \<equiv> Qp.indexed_const k"
 
 lemma Qp_to_IP_car:
   assumes "k \<in> carrier Q\<^sub>p"
   shows "Qp_to_IP k \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   using assms
   unfolding coord_ring_def
   using Qp.indexed_const_closed by blast
 
 lemma(in cring_coord_rings) smult_closed:
   assumes "a \<in> carrier R"
   assumes "q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
   shows "a \<odot>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
   using assms unfolding coord_ring_def
   using Pring_smult_closed
   by (simp add: R.Pring_smult_closed)
 
 
 lemma Qp_poly_smult_cfs:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "(a \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> P) m = a \<otimes> (P m)"
   using assms unfolding coord_ring_def
   using Qp.Pring_smult_cfs by blast
 
 lemma Qp_smult_r_distr:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "a \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (P \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> q) = (a \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> P)  \<oplus>\<^bsub> Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (a \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> q)"
   using assms unfolding coord_ring_def
   using Qp.Pring_smult_r_distr by blast
 
 lemma Qp_smult_l_distr:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "(a \<oplus> b) \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> P = (a \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> P)  \<oplus>\<^bsub> Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (b \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> P)"
   using assms unfolding coord_ring_def
   using Qp.Pring_smult_l_distr by blast
 
 abbreviation(input) Qp_funs  where
 "Qp_funs n \<equiv> Fun\<^bsub>n\<^esub> Q\<^sub>p"
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Evaluation of Polynomials in $\mathbb{Q}_p$\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 
 abbreviation(input) Qp_ev where
 "Qp_ev P q \<equiv> (eval_at_point Q\<^sub>p q P)"
 
 lemma Qp_ev_one:
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "Qp_ev \<one>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> a = \<one>" unfolding coord_ring_def
   by (metis Qp.Pring_one eval_at_point_const Qp.one_closed assms)
 
 lemma Qp_ev_zero:
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "Qp_ev \<zero>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> a = \<zero>"unfolding coord_ring_def
   by (metis Qp.Pring_zero eval_at_point_const Qp.zero_closed assms)
 
 lemma Qp_eval_pvar_pow:
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "k < n"
   assumes "(m::nat) \<noteq> 0"
   shows "Qp_ev ((pvar Q\<^sub>p k)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> m) a = ((a!k)[^]m)"
   by (metis eval_at_point_nat_pow eval_pvar assms(1) assms(2) pvar_closed)
 
 text\<open>composition of polynomials over $\mathbb{Q}_p$\<close>
 
 definition Qp_poly_comp where
 "Qp_poly_comp m fs = poly_compose (length fs) m fs"
 
 text\<open>lemmas about polynomial maps\<close>
 
 lemma Qp_is_poly_tupleI:
   assumes "\<And>i. i < length fs\<Longrightarrow> fs!i \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
   shows "is_poly_tuple m fs"
   unfolding is_poly_tuple_def using assms
   using cartesian_power_car_memE'' cartesian_power_car_memI' by blast
 
 lemma Qp_is_poly_tuple_append:
   assumes "is_poly_tuple m fs"
   assumes "is_poly_tuple m gs"
   shows "is_poly_tuple m (fs@gs)"
 proof(rule Qp_is_poly_tupleI)
   show "\<And>i. i < length (fs @ gs) \<Longrightarrow> (fs @ gs) ! i \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
   proof- fix i assume A: "i < length (fs @ gs)"
   show "(fs @ gs) ! i \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
     apply(cases "i < length fs")
     using assms is_poly_tupleE[of m fs i] nth_append[of fs gs i]
      apply presburger
   proof-
     assume B: "\<not> i < length fs"
     then have C: "length fs \<le> i \<and> i < length (fs @ gs)"
       using A  not_le
       by blast
     then have "i - length fs < length gs"
       using length_append[of fs gs]
       by linarith
     then show ?thesis
       using A assms is_poly_tupleE[of m gs "i - length fs"] nth_append[of fs gs i] B
       by presburger
   qed
   qed
 qed
 
 lemma Qp_poly_mapE:
   assumes "is_poly_tuple n fs"
   assumes "length fs = m"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "j < m"
   shows "(poly_map n fs as)!j \<in> carrier Q\<^sub>p"
   using assms  poly_map_closed cartesian_power_car_memE' by blast
 
 lemma Qp_poly_mapE':
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "length (poly_map n fs as) = length fs"
   unfolding poly_map_def
   using Qp.cring_axioms poly_tuple_evalE'
   by (metis assms restrict_def)
 
 lemma Qp_poly_mapE'':
   assumes "is_poly_tuple n fs"
   assumes "length fs = m"
   assumes "n \<noteq> 0"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "j < m"
   shows "(poly_map n fs as)!j = (Qp_ev (fs!j) as)"
   using assms
   unfolding poly_map_def poly_tuple_eval_def
   by (metis (no_types, lifting) nth_map restrict_apply')
 
 lemma poly_map_apply:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "poly_map n fs as = poly_tuple_eval fs as"
   unfolding poly_map_def restrict_def
   by (simp add: assms)
 
 lemma poly_map_pullbackI:
   assumes "is_poly_tuple n fs"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "poly_map n fs as \<in> S"
   shows "as \<in> poly_map n fs \<inverse>\<^bsub>n\<^esub> S"
   using assms poly_map_apply
   by blast
 
 lemma poly_map_pullbackI':
   assumes "is_poly_tuple n fs"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "poly_map n fs as \<in> S"
   shows "as \<in> ((poly_map n fs) -` S)"
   by (simp add: assms(3))
 
 text\<open>lemmas about polynomial composition\<close>
 lemma  poly_compose_ring_hom:
   assumes "is_poly_tuple m fs"
   assumes "length fs = n"
   shows  "(ring_hom_ring (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (Q\<^sub>p[\<X>\<^bsub>m\<^esub>]) (Qp_poly_comp m fs))"
   unfolding Qp_poly_comp_def
   by (simp add: assms(1) assms(2)  poly_compose_ring_hom)
 
 lemma poly_compose_closed:
   assumes "is_poly_tuple m fs"
   assumes "length fs = n"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "(Qp_poly_comp m fs f) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
   using Qp.cring_axioms assms
   unfolding Qp_poly_comp_def
   using poly_compose_closed by blast
 
 
 lemma poly_compose_add:
   assumes "is_poly_tuple m fs"
   assumes "length fs = n"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "Qp_poly_comp m fs (f \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> g) = (Qp_poly_comp m fs f) \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>m\<^esub>]\<^esub>  (Qp_poly_comp m fs g)"
   using Qp.cring_axioms assms poly_compose_add
   unfolding is_poly_tuple_def Qp_poly_comp_def
   by blast
 
 lemma poly_compose_mult:
   assumes "is_poly_tuple m fs"
   assumes "length fs = n"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "Qp_poly_comp m fs (f \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> g) = (Qp_poly_comp m fs f) \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>m\<^esub>]\<^esub>  (Qp_poly_comp m fs g)"
   using Qp.cring_axioms assms poly_compose_mult
   unfolding is_poly_tuple_def Qp_poly_comp_def
   by blast
 
 lemma poly_compose_const:
   assumes "is_poly_tuple m fs"
   assumes "length fs = n"
   assumes "a \<in> carrier Q\<^sub>p"
   shows "Qp_poly_comp m fs (Qp_to_IP a) = Qp_to_IP a"
   using Qp.cring_axioms assms poly_compose_const
   unfolding is_poly_tuple_def Qp_poly_comp_def
   by metis
 
 lemma Qp_poly_comp_eval:
   assumes "is_poly_tuple m fs"
   assumes "length fs = n"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   shows "Qp_ev (Qp_poly_comp m fs f) as = Qp_ev f (poly_map m fs as)"
 proof-
   have "(restrict (poly_tuple_eval fs) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) as) = poly_tuple_eval fs as"
     unfolding restrict_def
     by (simp add: assms)
   thus ?thesis
   using assms Qp.cring_axioms poly_compose_eval
   unfolding Qp_poly_comp_def poly_map_def
   by presburger
 qed
 
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Mapping Univariate Polynomials to Multivariable Polynomials in One Variable\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 
 abbreviation(input) to_Qp_x where
 "to_Qp_x \<equiv> (IP_to_UP (0::nat) :: (nat multiset \<Rightarrow> padic_number) \<Rightarrow> nat \<Rightarrow> padic_number)"
 
 abbreviation(input) from_Qp_x where
 "from_Qp_x \<equiv> UP_to_IP Q\<^sub>p (0::nat)"
 
 lemma from_Qp_x_closed:
   assumes "q \<in> carrier Q\<^sub>p_x"
   shows "from_Qp_x q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1\<^esub>])"
   using assms UP_to_IP_closed unfolding coord_ring_def
   by (metis One_nat_def lessThan_0 lessThan_Suc)
 
 lemma to_Qp_x_closed:
   assumes "q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1\<^esub>])"
   shows "to_Qp_x q \<in> carrier Q\<^sub>p_x"
   using assms Qp.IP_to_UP_closed[of q "0::nat"] Qp.cring_axioms
   unfolding coord_ring_def
   by (metis One_nat_def lessThan_0 lessThan_Suc)
 
 lemma to_Qp_x_from_Qp_x:
   assumes "q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1\<^esub>])"
   shows "from_Qp_x (to_Qp_x q) = q"
   using assms UP_to_IP_inv[of q "0::nat"] Qp.Pring_car
   unfolding coord_ring_def
     by (metis One_nat_def lessThan_0 lessThan_Suc)
 
 lemma from_Qp_x_to_Qp_x:
   assumes "q \<in> carrier Q\<^sub>p_x"
   shows "to_Qp_x (from_Qp_x q) = q"
   by (meson UPQ.IP_to_UP_inv assms)
 
 text\<open>ring hom properties of these maps\<close>
 
 lemma to_Qp_x_ring_hom:
 "to_Qp_x \<in> ring_hom (Q\<^sub>p[\<X>\<^bsub>1\<^esub>]) Q\<^sub>p_x"
   using IP_to_UP_ring_hom[of "0::nat"] ring_hom_ring.homh
   unfolding coord_ring_def
     by (metis One_nat_def lessThan_0 lessThan_Suc)
 
 lemma from_Qp_x_ring_hom:
 "from_Qp_x \<in> ring_hom Q\<^sub>p_x (Q\<^sub>p[\<X>\<^bsub>1\<^esub>])"
   using  UP_to_IP_ring_hom ring_hom_ring.homh
   unfolding coord_ring_def
     by (metis One_nat_def lessThan_0 lessThan_Suc)
 
 
 lemma from_Qp_x_add:
   assumes "a \<in> carrier Q\<^sub>p_x"
   assumes "b \<in> carrier Q\<^sub>p_x"
   shows "from_Qp_x (a \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> b) = from_Qp_x a \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>1\<^esub>]\<^esub> from_Qp_x b"
   by (metis (mono_tags, lifting) assms(1) assms(2) from_Qp_x_ring_hom ring_hom_add)
 
 lemma from_Qp_x_mult:
   assumes "a \<in> carrier Q\<^sub>p_x"
   assumes "b \<in> carrier Q\<^sub>p_x"
   shows "from_Qp_x (a \<otimes>\<^bsub>Q\<^sub>p_x\<^esub> b) = from_Qp_x a \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>1\<^esub>]\<^esub> from_Qp_x b"
   by (metis assms(1) assms(2) from_Qp_x_ring_hom ring_hom_mult)
 
 text\<open>equivalence of evaluation maps\<close>
 
 lemma Qp_poly_Qp_x_eval:
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1\<^esub>])"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
   shows "Qp_ev P a = (to_Qp_x P)\<bullet>(Qp.to_R a)"
 proof-
   have 0: "(IP_to_UP 0 P) \<bullet> (a ! 0) = ((IP_to_UP 0 P) \<bullet> (if 0 < length a then a ! 0 else \<zero>))"
     using assms
     by (metis (mono_tags, lifting) cartesian_power_car_memE gr0I zero_neq_one)
   have 1: "closed_fun Q\<^sub>p (\<lambda>n. if n < length a then a ! n else \<zero>)"
   proof
     fix n
     show "(if n < length a then a ! n else \<zero>) \<in> carrier Q\<^sub>p"
       apply(cases "n < length a")
       using assms
       apply (metis cartesian_power_car_memE cartesian_power_car_memE')
       by (meson Qp.cring_axioms cring.cring_simprules(2))
   qed
   have 2: " P \<in> Pring_set Q\<^sub>p {0::nat}"
     using assms unfolding coord_ring_def
    by (metis Qp.Pring_car UPQ.UP_to_IP_closed assms(1) to_Qp_x_closed to_Qp_x_from_Qp_x)
   have 3: "total_eval Q\<^sub>p (\<lambda>i. if i < length a then a ! i else \<zero>) P = IP_to_UP 0 P \<bullet> (if 0 < length a then a ! 0 else \<zero>)"
     using 1 2 assms IP_to_UP_poly_eval[of P "0::nat" "(\<lambda>i. if i < length a then a ! i else \<zero>)" ]
           UPQ.to_fun_def by presburger
   then show ?thesis
     using 0
     unfolding eval_at_point_def
     by blast
 qed
 
 lemma Qp_x_Qp_poly_eval:
   assumes "P \<in> carrier Q\<^sub>p_x"
   assumes "a \<in> carrier Q\<^sub>p"
   shows "P \<bullet> a = Qp_ev (from_Qp_x P) (to_R1 a)"
 proof-
   have "Qp_ev (from_Qp_x P) (to_R1 a) = (to_Qp_x (from_Qp_x P))\<bullet>(Qp.to_R (Qp.to_R1 a))"
     using Qp_poly_Qp_x_eval assms(1) assms(2) from_Qp_x_closed Qp.to_R1_closed by blast
   then show ?thesis using assms
     by (metis UPQ.IP_to_UP_inv Qp.to_R_to_R1)
 qed
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>$n^{th}$-Power Sets over $\mathbb{Q}_p$\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 definition P_set where
 "P_set (n::nat) = {a \<in> nonzero Q\<^sub>p.  (\<exists>y \<in> carrier Q\<^sub>p . (y[^] n) = a)}"
 
 lemma P_set_carrier:
 "P_set n \<subseteq> carrier Q\<^sub>p"
   unfolding P_set_def nonzero_def
   by blast
 
 lemma P_set_memI:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "a \<noteq> \<zero>"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "b[^](n::nat) = a"
   shows "a \<in> P_set n"
   unfolding P_set_def
   using assms
   by (metis (mono_tags, lifting) mem_Collect_eq not_nonzero_Qp)
 
 lemma P_set_nonzero:
 "P_set n \<subseteq> nonzero Q\<^sub>p"
   unfolding P_set_def by blast
 
 
 lemma P_set_nonzero':
   assumes "a \<in> P_set n"
   shows "a \<in> nonzero Q\<^sub>p"
         "a \<in> carrier  Q\<^sub>p"
   using assms P_set_nonzero P_set_carrier
    apply blast using assms P_set_carrier  by blast
 
 lemma P_set_one:
   assumes "n \<noteq> 0"
   shows "\<one> \<in> P_set (n::nat)"
 proof-
   have 0: "\<one>[^]n = \<one>"
     using Qp.nat_pow_one by blast
   have 1: "\<one> \<in> carrier Q\<^sub>p"
     by blast
   then show ?thesis
     using one_nonzero unfolding P_set_def
     using 0 by blast
 qed
 
 lemma zeroth_P_set:
 "P_set 0 = {\<one>}"
 proof
   show "P_set 0 \<subseteq> {\<one>}"
   unfolding P_set_def
   proof
     fix x
     assume "x \<in> {a \<in> nonzero Q\<^sub>p. \<exists>y\<in>carrier Q\<^sub>p. (y[^](0::nat)) = a}"
     then have "\<exists>y\<in>carrier Q\<^sub>p. (y[^](0::nat)) = x"
       by blast
     then obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> (a[^](0::nat)) = x"
       by blast
     then show "x \<in> {\<one>}"
       using Qp.nat_pow_0 by blast
   qed
   show "{\<one>} \<subseteq> P_set 0"
     using P_set_memI[of \<one> \<one> 0] Qp.nat_pow_one Qp.one_closed local.one_neq_zero
     by blast
 qed
 
 lemma P_set_mult_closed:
   assumes "n \<noteq> 0"
   assumes "a \<in> P_set n"
   assumes "b \<in> P_set n"
   shows "a \<otimes> b \<in> P_set n"
 proof-
   obtain a0 where a0_def: "a0 \<in> carrier Q\<^sub>p \<and> (a0 [^] n = a)"
     using assms(2)
     unfolding P_set_def
     by blast
   obtain b0 where b0_def: "b0 \<in> carrier Q\<^sub>p \<and> (b0 [^] n = b)"
     using assms(3)
     unfolding P_set_def
     by blast
   have "(a0 \<otimes> b0) [^] n = a0 [^] n \<otimes> b0 [^] n"
     using a0_def b0_def Qp.nat_pow_distrib by blast
   then have 0: "a \<otimes> b  = (a0 \<otimes> b0) [^] n"
     using a0_def b0_def by blast
   have 1: "a0 \<otimes> b0 \<in> carrier Q\<^sub>p"
     by (meson Qp.cring_axioms a0_def b0_def cring.cring_simprules(5))
   have 2: "a \<otimes> b \<in> nonzero Q\<^sub>p"
     using assms nonzero_is_submonoid  unfolding P_set_def
     by (metis (no_types, lifting) "0" "1" Qp.integral Qp_nat_pow_nonzero a0_def b0_def mem_Collect_eq not_nonzero_Qp)
   then show ?thesis
     using 0 1 assms
     unfolding P_set_def by blast
 qed
 
 lemma P_set_inv_closed:
   assumes "a \<in> P_set n"
   shows "inv a \<in> P_set n"
 proof(cases "n = 0")
   case True
   then show ?thesis
     using assms zeroth_P_set
     by (metis Qp.inv_one singletonD)
 next
   case False
   then show ?thesis proof-
     obtain a0 where a0_def: "a0 \<in> carrier Q\<^sub>p \<and> a0[^]n = a"
       using assms P_set_def[of n] by blast
   have "a0 \<in> nonzero Q\<^sub>p"
     apply(rule ccontr)
   proof-
     assume "a0 \<notin> nonzero Q\<^sub>p "
     then have "a0 = \<zero>"
       using a0_def
       by (meson not_nonzero_Qp)
     then show False using a0_def assms
       by (metis (mono_tags, lifting) False P_set_def Qp.cring_axioms \<open>a0 \<notin> nonzero Q\<^sub>p\<close>
           cring_def mem_Collect_eq neq0_conv ring.pow_zero)
   qed
   then have "(inv a0)[^]n = inv a"
     using a0_def  \<open>a0 \<in> carrier Q\<^sub>p \<and> (a0[^]n) = a\<close> \<open>a0 \<in> nonzero Q\<^sub>p\<close> Units_nonzero
           monoid.nat_pow_of_inv[of Q\<^sub>p a n] Qp.nat_pow_of_inv Units_eq_nonzero by presburger
   then show ?thesis
     by (metis P_set_memI Qp.nat_pow_closed Qp.nonzero_memE(2) Qp.nonzero_pow_nonzero \<open>a0 \<in> nonzero Q\<^sub>p\<close> a0_def inv_in_frac(1) inv_in_frac(2))
   qed
 qed
 
 lemma P_set_val:
   assumes "a \<in> P_set (n::nat)"
   shows  "(ord a) mod n = 0"
 proof(cases "n = 0")
   case True
   then show ?thesis
     using assms zeroth_P_set
     by (metis mod_by_0 of_nat_0 ord_one singletonD)
 next
   case False
   then show ?thesis
   proof-
     obtain b where b_def: "b \<in> carrier Q\<^sub>p \<and> (b[^] n) = a"
       using assms P_set_def  by blast
     have an: "a \<in> nonzero Q\<^sub>p"
       using P_set_def assms by blast
     have bn: "b \<in> nonzero Q\<^sub>p"
     proof(rule ccontr)
       assume "b \<notin> nonzero Q\<^sub>p"
       then have "b = \<zero>\<^bsub> Q\<^sub>p\<^esub>"
         using b_def not_nonzero_Qp
         by metis
       then have "(b[^] n) = \<zero>"
         using False Qp.cring_axioms cring_def ring.pow_zero
         by blast
       then show False
         using b_def an  Qp.not_nonzero_memI by blast
     qed
     then have "ord a = n * (ord b)"
       using b_def an nonzero_nat_pow_ord
       by blast
     then show ?thesis
       by (metis mod_mult_self1_is_0)
   qed
 qed
 
 
 lemma P_set_pow:
   assumes "n > 0"
   assumes "s \<in> P_set n"
   shows "s[^]k \<in> P_set (n*k)"
 proof-
   obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> y[^]n = s"
     using assms unfolding P_set_def by blast
   then have 0: "y \<in> nonzero Q\<^sub>p"
     using assms P_set_nonzero'(1) Qp_nonzero_nat_pow by blast
   have 1: "y[^](n*k) = s[^] k"
     using 0 y_def assms Qp.nat_pow_pow by blast
   hence 2: "s[^]k \<in> nonzero Q\<^sub>p"
     using 0 by (metis Qp_nat_pow_nonzero)
   thus ?thesis unfolding P_set_def using 1 y_def by blast
 qed
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Semialgebraic Sets\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 text\<open>
   In this section we introduce the notion of a $p$-adic semialgebraic set. Intuitively, these are
   the subsets of $\mathbb{Q}_p^n$ which are definable by first order quantifier-free formulas in
   the standard first-order language of rings, with an additional relation symbol included for the
   relation $\text{ val}(x) \leq \text{ val}(y)$, interpreted according to the definiton of the
   $p$-adic valuation on $\mathbb{Q}_p$. In fact, by Macintyre's quantifier elimination theorem
   for the first-order theory of $\mathbb{Q}_p$ in this language, one can equivalently remove the
   ``quantifier-free" clause from the latter definition. The definition we give here is also
   equivalent, and due to Denef in \cite{denef1986}. The given definition here is desirable mainly
   for its utility in producing a proof of Macintyre's theorem, which is our overarching goal.
 \<close>
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Defining Semialgebraic Sets\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 definition basic_semialg_set where
 "basic_semialg_set (m::nat) (n::nat) P = {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<exists>y \<in> carrier Q\<^sub>p. Qp_ev P q = (y[^]n)}"
 
 lemma basic_semialg_set_zero_set:
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
   assumes "q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "Qp_ev P q = \<zero>"
   assumes "n \<noteq>  0"
   shows "q \<in> basic_semialg_set (m::nat) (n::nat) P"
 proof-
   have "\<zero> = (\<zero>[^]n)"
     using assms(4) Qp.nat_pow_zero by blast
   then show ?thesis
     unfolding basic_semialg_set_def
     using assms Qp.cring_axioms cring.cring_simprules(2)
     by blast
 qed
 
 lemma basic_semialg_set_def':
   assumes "n \<noteq> 0"
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
   shows "basic_semialg_set (m::nat) (n::nat) P = {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> (P_set n)}"
 proof
   show "basic_semialg_set m n P \<subseteq> {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> P_set n}"
   proof
     fix x
     assume A: "x \<in> basic_semialg_set m n P"
      show "x \<in> {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> P_set n}"
       apply(cases "Qp_ev P x = \<zero>")
       using A basic_semialg_set_def apply blast
       unfolding basic_semialg_set_def P_set_def
     proof
       assume A0: "Qp_ev P x \<noteq> \<zero>"
       have A1: " \<exists>y\<in>carrier Q\<^sub>p. Qp_ev P x = (y[^]n)"
         using A basic_semialg_set_def
         by blast
       have A2: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
         using A basic_semialg_set_def
         by blast
       show " x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> (Qp_ev P x = \<zero> \<or> Qp_ev P x \<in> {a \<in> nonzero Q\<^sub>p. \<exists>y\<in>carrier Q\<^sub>p. (y[^]n) = a})"
         by (metis (mono_tags, lifting) A1 A2 Qp.nonzero_memI assms(2) eval_at_point_closed mem_Collect_eq)
     qed
   qed
   show "{q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> P_set n} \<subseteq> basic_semialg_set m n P"
   proof
     fix x
     assume A: " x \<in> {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> P_set n}"
     then have A':"x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       by blast
     show "x \<in>  basic_semialg_set m n P"
       using A A'
       apply(cases "Qp_ev P x = \<zero>")
       using assms basic_semialg_set_zero_set[of P m x n]
        apply blast
     proof-
       assume B: "x \<in> {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> P_set n} "
       assume B': "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       assume B'': "Qp_ev P x \<noteq> \<zero> "
       show "x \<in> basic_semialg_set m n P"
         unfolding basic_semialg_set_def  P_set_def
       proof
         have "\<exists>y\<in>carrier Q\<^sub>p. Qp_ev P x = (y[^]n) "
           using A nonzero_def [of Q\<^sub>p] unfolding P_set_def
         proof -
           assume "x \<in> {q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). Qp_ev P q = \<zero> \<or> Qp_ev P q \<in> {a \<in> nonzero Q\<^sub>p. \<exists>y\<in>carrier Q\<^sub>p. (y[^]n) = a}}"
           then have "Qp_ev P x \<in> nonzero Q\<^sub>p \<and> (\<exists>r. r \<in> carrier Q\<^sub>p \<and> (r[^]n) = Qp_ev P x)"
             using B'' by blast
           then show ?thesis
             by blast
         qed
         then show "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> (\<exists>y\<in>carrier Q\<^sub>p. Qp_ev P x = (y[^]n))"
           using B'
           by blast
       qed
     qed
   qed
 qed
 
 lemma basic_semialg_set_memI:
   assumes "q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "y \<in> carrier Q\<^sub>p"
   assumes "Qp_ev P q = (y[^]n)"
   shows "q \<in> basic_semialg_set m n P"
   using assms(1) assms(2) assms(3) basic_semialg_set_def
   by blast
 
 lemma basic_semialg_set_memE:
   assumes  "q \<in> basic_semialg_set m n P"
   shows "q \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
         "\<exists>y \<in> carrier Q\<^sub>p. Qp_ev P q = (y[^]n)"
   using assms basic_semialg_set_def apply blast
   using assms basic_semialg_set_def by blast
 
 definition is_basic_semialg :: "nat \<Rightarrow> ((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set list set \<Rightarrow> bool" where
 "is_basic_semialg m S \<equiv> (\<exists> (n::nat) \<noteq> 0. (\<exists> P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>]). S = basic_semialg_set m n P))"
 
 abbreviation(input) basic_semialgs where
 "basic_semialgs m \<equiv> {S. (is_basic_semialg m S)}"
 
 definition semialg_sets where
 "semialg_sets n = gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n)"
 
 lemma carrier_is_semialg:
 "(carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<in> semialg_sets n "
   unfolding semialg_sets_def
   using gen_boolean_algebra.universe by blast
 
 lemma empty_set_is_semialg:
 " {} \<in> semialg_sets n"
   using carrier_is_semialg[of n]
   unfolding semialg_sets_def using gen_boolean_algebra.complement
   by (metis Diff_cancel)
 
 lemma semialg_intersect:
   assumes "A \<in> semialg_sets n"
   assumes "B \<in> semialg_sets n"
   shows "(A \<inter> B) \<in> semialg_sets n "
   using assms(1) assms(2) gen_boolean_algebra_intersect semialg_sets_def
   by blast
 
 lemma semialg_union:
   assumes "A \<in> semialg_sets n"
   assumes "B \<in> semialg_sets n"
   shows "(A \<union> B) \<in> semialg_sets n "
   using assms gen_boolean_algebra.union semialg_sets_def
   by blast
 
 lemma semialg_complement:
   assumes "A \<in> semialg_sets n"
   shows "(carrier (Q\<^sub>p\<^bsup>n\<^esup>) - A) \<in> semialg_sets n "
   using assms gen_boolean_algebra.complement semialg_sets_def
   by blast
 
 lemma semialg_zero:
   assumes "A \<in> semialg_sets 0"
   shows "A = {[]} \<or> A = {}"
   using assms
   unfolding semialg_sets_def cartesian_power_def
 proof-
   assume A0:  " A \<in> gen_boolean_algebra (carrier (RDirProd_list (R_list 0 Q\<^sub>p))) (basic_semialgs 0)"
   show " A = {[]} \<or> A = {}"
   proof-
     have "A \<noteq> {[]} \<longrightarrow> A = {}"
     proof
       assume A1: "A \<noteq> {[]}"
       show "A = {}"
       proof-
         have "(R_list 0 Q\<^sub>p) = []"
           by simp
         then have "(carrier (RDirProd_list (R_list 0 Q\<^sub>p))) = {[]}"
           using RDirProd_list_nil
           by simp
         then show ?thesis
           using A0 A1
           by (metis gen_boolean_algebra_subset subset_singletonD)
       qed
     qed
     then show ?thesis
       by linarith
   qed
 qed
 
 lemma basic_semialg_is_semialg:
   assumes "is_basic_semialg n A"
   shows "A \<in> semialg_sets n"
   by (metis (no_types, lifting) assms gen_boolean_algebra.simps inf_absorb1
       is_basic_semialg_def mem_Collect_eq basic_semialg_set_def
       semialg_sets_def subsetI)
 
 lemma basic_semialg_is_semialg':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "m \<noteq>0"
   assumes "A = basic_semialg_set n m f"
   shows "A \<in> semialg_sets n"
   using assms basic_semialg_is_semialg is_basic_semialg_def
   by blast
 
 definition is_semialgebraic where
 "is_semialgebraic n S = (S \<in> semialg_sets n)"
 
 lemma is_semialgebraicE:
   assumes "is_semialgebraic n S"
   shows "S \<in> semialg_sets n"
   using assms is_semialgebraic_def by blast
 
 lemma is_semialgebraic_closed:
   assumes "is_semialgebraic n S"
   shows "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   using is_semialgebraicE[of n S] unfolding semialg_sets_def
   using assms gen_boolean_algebra_subset is_semialgebraicE semialg_sets_def
   by blast
 
 lemma is_semialgebraicI:
   assumes "S \<in> semialg_sets n"
   shows "is_semialgebraic n S"
   by (simp add: assms is_semialgebraic_def)
 
 lemma basic_semialg_is_semialgebraic:
   assumes "is_basic_semialg n A"
   shows "is_semialgebraic n A"
   using assms basic_semialg_is_semialg is_semialgebraicI by blast
 
 lemma basic_semialg_is_semialgebraic':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "m \<noteq>0"
   assumes "A = basic_semialg_set n m f"
   shows "is_semialgebraic n A"
   using assms(1) assms(2) assms(3) basic_semialg_is_semialg' is_semialgebraicI by blast
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Algebraic Sets over $p$-adic Fields\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 lemma p_times_square_not_square:
   assumes "a \<in> nonzero Q\<^sub>p"
   shows "\<pp> \<otimes> (a [^] (2::nat)) \<notin> P_set (2::nat)"
 proof
   assume A: "\<pp> \<otimes> (a[^](2::nat)) \<in> P_set (2::nat)"
   then have "\<pp> \<otimes> (a[^](2::nat)) \<in> nonzero Q\<^sub>p"
     unfolding P_set_def
     by blast
   then obtain b where b_def: "b \<in> carrier Q\<^sub>p \<and> b[^](2::nat) = \<pp> \<otimes> (a[^](2::nat))"
     using A P_set_def by blast
    have "b \<in> nonzero Q\<^sub>p"
      apply(rule ccontr) using b_def assms
      by (metis A P_set_nonzero'(1) Qp.nat_pow_zero not_nonzero_Qp zero_neq_numeral)
    then have LHS: "ord (b[^](2::nat)) = 2* (ord b)"
      using nonzero_nat_pow_ord
      by presburger
    have "ord( \<pp> \<otimes> (a[^](2::nat))) = 1 + 2* ord a"
      using assms nonzero_nat_pow_ord Qp_nat_pow_nonzero ord_mult ord_p p_nonzero
      by presburger
    then show False
      using b_def LHS
      by presburger
 qed
 
 lemma p_times_square_not_square':
   assumes "a \<in> carrier Q\<^sub>p"
   shows "\<pp> \<otimes> (a [^] (2::nat)) = \<zero> \<Longrightarrow> a = \<zero>"
   by (metis Qp.integral Qp.nat_pow_closed Qp.nonzero_closed Qp.nonzero_memE(2) Qp.nonzero_pow_nonzero assms p_nonzero)
 
 lemma zero_set_semialg_set:
   assumes "q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "Qp_ev q a = \<zero> \<longleftrightarrow>( \<exists>y \<in> carrier Q\<^sub>p. \<pp> \<otimes> ((Qp_ev q a) [^] (2::nat)) = y[^](2::nat)) "
 proof
   show "Qp_ev q a = \<zero> \<Longrightarrow> \<exists>y\<in>carrier Q\<^sub>p. \<pp> \<otimes> (Qp_ev q a[^] (2::nat)) = (y[^] (2::nat))"
   proof-
     assume "Qp_ev q a = \<zero>"
     then have "\<pp> \<otimes> (Qp_ev q a[^](2::nat)) = (\<zero>[^](2::nat))"
       by (metis Qp.int_inc_closed Qp.nat_pow_zero Qp.r_null zero_neq_numeral)
     then have "\<zero> \<in> carrier Q\<^sub>p \<and> \<pp> \<otimes> (Qp_ev q a[^](2::nat)) = (\<zero>[^](2::nat))"
       using Qp.cring_axioms cring.cring_simprules(2)
       by blast
     then show "\<exists>y\<in>carrier Q\<^sub>p. \<pp> \<otimes> (Qp_ev q a[^] (2::nat)) = (y[^] (2::nat))"
       by blast
   qed
   show " \<exists>y\<in>carrier Q\<^sub>p. \<pp> \<otimes> (Qp_ev q a[^](2::nat)) = (y[^](2::nat)) \<Longrightarrow> Qp_ev q a = \<zero>"
   proof-
     assume A: " \<exists>y\<in>carrier Q\<^sub>p. \<pp> \<otimes> (Qp_ev q a[^](2::nat)) = (y[^](2::nat))"
     then obtain b where b_def: "b\<in>carrier Q\<^sub>p \<and> \<pp> \<otimes> (Qp_ev q a[^](2::nat)) = (b[^](2::nat))"
       by blast
     show "Qp_ev q a = \<zero>"
     proof(rule ccontr)
       assume " Qp_ev q a \<noteq> \<zero>"
       then have " Qp_ev q a \<in> nonzero Q\<^sub>p" using assms eval_at_point_closed[of a n q]  nonzero_def
       proof -
         have "Qp_ev q a \<in> carrier Q\<^sub>p"
           using \<open>\<lbrakk>a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>); q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])\<rbrakk> \<Longrightarrow>
                   Qp_ev q a \<in> carrier Q\<^sub>p\<close> \<open>a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)\<close> \<open>q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])\<close>
           by fastforce
         then have "Qp_ev q a \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>}"
           using \<open>Qp_ev q a \<noteq> \<zero>\<close> by force
         then show ?thesis
           by (metis nonzero_def )
       qed
       then have "\<pp> \<otimes> (Qp_ev q a[^](2::nat)) \<in> nonzero Q\<^sub>p"
         by (metis Qp.nonzero_closed Qp.nonzero_mult_closed Qp_nat_pow_nonzero not_nonzero_Qp p_nonzero p_times_square_not_square')
       then have "\<pp> \<otimes> (Qp_ev q a[^](2::nat)) \<in> P_set (2::nat)"
         using b_def
         unfolding P_set_def
         by blast
       then show False
         using \<open>Qp_ev q a \<in> nonzero Q\<^sub>p\<close> p_times_square_not_square
         by blast
     qed
   qed
 qed
 
 lemma alg_as_semialg:
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "q = \<pp> \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (P[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (2::nat))"
   shows "zero_set Q\<^sub>p n P = basic_semialg_set n (2::nat) q"
 proof
   have 00: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> Qp_ev q x = \<pp> \<otimes> (Qp_ev P x) [^] (2::nat)"
     using assms eval_at_point_smult MP.nat_pow_closed Qp.int_inc_closed eval_at_point_nat_pow
     by presburger
   show "V\<^bsub>Q\<^sub>p\<^esub> n P \<subseteq> basic_semialg_set n 2 q"
   proof
     fix x
     assume A: "x \<in> V\<^bsub>Q\<^sub>p\<^esub> n P "
     show "x \<in> basic_semialg_set n (2::nat) q "
     proof-
       have P: "Qp_ev P x = \<zero>"
         using A zero_setE(2)
         by blast
       have "Qp_ev q x = \<zero>"
       proof-
         have "Qp_ev q x = \<pp> \<otimes> (Qp_ev (P[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (2::nat)) x)"
           using assms eval_at_point_smult[of x n "(P[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (2::nat))" \<pp>] basic_semialg_set_def
           by (meson A MP.nat_pow_closed Qp.int_inc_closed zero_setE(1))
         then show ?thesis
           by (metis A P Qp.int_inc_closed Qp.integral_iff Qp.nat_pow_zero Qp.zero_closed assms(1)
               eval_at_point_nat_pow neq0_conv zero_less_numeral zero_setE(1))
       qed
       then have 0: "Qp_ev q x = \<zero> \<or> Qp_ev q x \<in> P_set (2::nat)"
         by blast
       have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
         using A zero_setE(1)
         by blast
       then show ?thesis using 0 basic_semialg_set_def'
         by (metis (no_types, opaque_lifting) Qp.nat_pow_zero Qp.zero_closed
             \<open>eval_at_point Q\<^sub>p x q = \<zero>\<close> basic_semialg_set_memI zero_neq_numeral)
     qed
   qed
   show "basic_semialg_set n 2 q \<subseteq> V\<^bsub>Q\<^sub>p\<^esub> n P"
   proof
     fix x
     assume A: "x \<in> basic_semialg_set n 2 q"
     have 0: "\<not> Qp_ev q x \<in> P_set 2"
     proof
       assume "Qp_ev q x \<in> P_set 2"
       then have 0: "Qp_ev q x \<in> nonzero Q\<^sub>p \<and>  (\<exists>y \<in> carrier Q\<^sub>p . (y[^] (2::nat)) = Qp_ev q x)"
         using P_set_def by blast
       have "( \<exists>y \<in> carrier Q\<^sub>p. \<pp> \<otimes> ((Qp_ev P x) [^] (2::nat)) = y[^](2::nat))"
       proof-
         obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> (y[^] (2::nat)) = Qp_ev q x"
           using 0 by blast
         have "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
           using A basic_semialg_set_memE(1) by blast
         then have "Qp_ev q x = \<pp> \<otimes> ((Qp_ev P x) [^] (2::nat))"
           using assms eval_at_point_scalar_mult 00 by blast
         then have "(y[^] (2::nat)) = \<pp> \<otimes> ((Qp_ev P x) [^] (2::nat))"
           using y_def by blast
         then show ?thesis using y_def by blast
       qed
       then have "Qp_ev P x = \<zero>"
         by (metis (no_types, lifting) A assms(1) basic_semialg_set_def mem_Collect_eq zero_set_semialg_set)
       then have "Qp_ev q x = \<zero>"
         using assms eval_at_point_smult
         by (metis "00" A Qp.int_inc_closed Qp.nat_pow_zero Qp.r_null basic_semialg_set_memE(1) zero_neq_numeral)
       then show False
         using 0 Qp.not_nonzero_memI by blast
     qed
     show " x \<in> V\<^bsub>Q\<^sub>p\<^esub> n P"
       apply(rule zero_setI)
       using A basic_semialg_set_memE(1) apply blast
       using A 0 00[of x]
       by (metis assms(1) basic_semialg_set_memE(1) basic_semialg_set_memE(2) zero_set_semialg_set)
   qed
 qed
 
 lemma is_zero_set_imp_basic_semialg:
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "S = zero_set Q\<^sub>p n P"
   shows "is_basic_semialg n S"
   unfolding is_basic_semialg_def
 proof-
   obtain q where q_def: "q = \<pp> \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (P[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (2::nat))"
     by blast
   have 0: "zero_set Q\<^sub>p n P = basic_semialg_set n (2::nat) q"
     using alg_as_semialg[of P n q]  q_def assms(1) by linarith
   have "(P [^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (2::nat)) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
     using assms(1)
     by blast
   then have "\<pp> \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub>(P [^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (2::nat)) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
     using assms q_def Qp.int_inc_closed local.smult_closed by blast
   then have 1: "q \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
     by (metis q_def )
   then show "\<exists>m. m \<noteq> 0 \<and> (\<exists>P\<in>carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]). S = basic_semialg_set n m P)"
     using 0 assms
     by (metis zero_neq_numeral)
 qed
 
 lemma is_zero_set_imp_semialg:
   assumes "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "S = zero_set Q\<^sub>p n P"
   shows "is_semialgebraic n S"
   using assms(1) assms(2) basic_semialg_is_semialg is_semialgebraicI is_zero_set_imp_basic_semialg
   by blast
 
 text\<open>Algebraic sets are semialgebraic\<close>
 
 lemma is_algebraic_imp_is_semialg:
   assumes "is_algebraic Q\<^sub>p n S"
   shows "is_semialgebraic n S"
   proof(rule is_semialgebraicI)
     obtain ps where ps_def: "finite ps \<and> ps \<subseteq> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> S =  affine_alg_set Q\<^sub>p n ps"
       using is_algebraicE
       by (metis  assms)
     have "ps \<subseteq> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<longrightarrow> affine_alg_set Q\<^sub>p n ps \<in> semialg_sets n"
       apply(rule finite.induct[of ps])
         apply (simp add: ps_def)
       using affine_alg_set_empty[of n]
        apply (simp add: carrier_is_semialg)
     proof
       fix A a
       assume IH: "A \<subseteq> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<longrightarrow> affine_alg_set Q\<^sub>p n A \<in> semialg_sets n"
       assume P: "insert a A \<subseteq> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
       have "A \<subseteq> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
         using P by blast
       then
       show "affine_alg_set Q\<^sub>p n (insert a A) \<in> semialg_sets n"
         using IH P semialg_intersect[of "affine_alg_set Q\<^sub>p n A" n "affine_alg_set Q\<^sub>p n {a}" ]
                is_zero_set_imp_semialg affine_alg_set_insert[of n a A]
         by (metis Int_commute affine_alg_set_singleton insert_subset is_semialgebraicE)
     qed
     then show "S \<in> semialg_sets n"
       using ps_def by blast
   qed
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Basic Lemmas about the Semialgebraic Predicate\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 text\<open>Finite and cofinite sets are semialgebraic\<close>
 
 lemma finite_is_semialg:
   assumes "F \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "finite F"
   shows "is_semialgebraic n F"
   using Qp.finite_sets_are_algebraic is_algebraic_imp_is_semialg[of n F]
            assms(1) assms(2)
   by blast
 
 definition is_cofinite where
 "is_cofinite n F = finite (ring_pow_comp Q\<^sub>p n F)"
 
 lemma is_cofiniteE:
   assumes "F \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "is_cofinite n F"
   shows "finite (carrier (Q\<^sub>p\<^bsup>n\<^esup>) - F)"
   using assms(2) is_cofinite_def
   by (simp add: ring_pow_comp_def)
 
 lemma complement_is_semialg:
   assumes "is_semialgebraic n F"
   shows "is_semialgebraic n ((carrier (Q\<^sub>p\<^bsup>n\<^esup>)) - F)"
   using assms is_semialgebraic_def semialg_complement by blast
 
 lemma cofinite_is_semialgebraic:
   assumes "F \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "is_cofinite n F"
   shows "is_semialgebraic n F"
   using assms ring_pow_comp_inv[of F Q\<^sub>p n] complement_is_semialg[of n "(carrier (Q\<^sub>p\<^bsup>n\<^esup>) - F)"]
         finite_is_semialg[of "(carrier (Q\<^sub>p\<^bsup>n\<^esup>) - F)"]  is_cofiniteE[of F]
   by (simp add: ring_pow_comp_def)
 
 lemma diff_is_semialgebraic:
   assumes "is_semialgebraic n A"
   assumes "is_semialgebraic n B"
   shows "is_semialgebraic n (A - B)"
   apply(rule is_semialgebraicI)
   using assms unfolding semialg_sets_def
   using gen_boolean_algebra_diff is_semialgebraicE semialg_sets_def
   by blast
 
 lemma intersection_is_semialg:
   assumes "is_semialgebraic n A"
   assumes "is_semialgebraic n B"
   shows "is_semialgebraic n (A \<inter> B)"
   using assms(1) assms(2) is_semialgebraicE is_semialgebraicI semialg_intersect
   by blast
 
 lemma union_is_semialgebraic:
   assumes "is_semialgebraic n A"
   assumes "is_semialgebraic n B"
   shows "is_semialgebraic n (A \<union> B)"
   using assms(1) assms(2) is_semialgebraicE is_semialgebraicI semialg_union by blast
 
 lemma carrier_is_semialgebraic:
 "is_semialgebraic n (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
 using carrier_is_semialg
   by (simp add: carrier_is_semialg is_semialgebraic_def)
 
 lemma empty_is_semialgebraic:
 "is_semialgebraic n {}"
   by (simp add: empty_set_is_semialg is_semialgebraic_def)
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>One-Dimensional Semialgebraic Sets\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 definition one_var_semialg where
 "one_var_semialg S =  ((to_R1 ` S) \<in> (semialg_sets 1))"
 
 definition univ_basic_semialg_set where
 "univ_basic_semialg_set (m::nat) P = {a \<in> carrier Q\<^sub>p. (\<exists>y \<in> carrier Q\<^sub>p. (P \<bullet> a = (y[^]m)))}"
 
 text\<open>Equivalence of univ\_basic\_semialg\_sets and semialgebraic subsets of $\mathbb{Q}^1$ \<close>
 
 lemma univ_basic_semialg_set_to_semialg_set:
   assumes "P \<in> carrier Q\<^sub>p_x"
   assumes "m \<noteq> 0"
   shows "to_R1 ` (univ_basic_semialg_set m P) = basic_semialg_set 1 m (from_Qp_x P)"
 proof
   show "(\<lambda>a. [a]) ` univ_basic_semialg_set m P \<subseteq> basic_semialg_set 1 m (from_Qp_x P)"
   proof fix x
     assume A: "x \<in> (\<lambda>a. [a]) ` univ_basic_semialg_set m P"
     then obtain b y where by_def:"b \<in> carrier Q\<^sub>p \<and> y \<in> carrier Q\<^sub>p \<and> (P \<bullet> b) = (y[^]m) \<and> x = [b]"
       unfolding univ_basic_semialg_set_def
       by blast
     then have "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
       using A Qp.to_R1_closed[of b]
       unfolding univ_basic_semialg_set_def
       by blast
     then show "x \<in> basic_semialg_set 1 m (from_Qp_x P)"
       using by_def Qp_x_Qp_poly_eval assms
       unfolding basic_semialg_set_def
       by blast
   qed
   show "basic_semialg_set 1 m (from_Qp_x P) \<subseteq> (\<lambda>a. [a]) ` univ_basic_semialg_set m P"
   proof
     fix x
     assume A: "x \<in> basic_semialg_set 1 m (from_Qp_x P)"
     then obtain b where b_def:  "b \<in> carrier Q\<^sub>p \<and> x = [b]"
       unfolding basic_semialg_set_def
       by (metis (mono_tags, lifting) mem_Collect_eq Qp.to_R1_to_R Qp.to_R_pow_closed)
     obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> (Qp_ev (from_Qp_x P) [b]  = (y[^]m))"
       using A b_def
       unfolding basic_semialg_set_def
       by blast
     have " P \<bullet> b = (y[^]m)"
       using assms y_def b_def Qp_x_Qp_poly_eval by blast
     then show " x \<in> (\<lambda>a. [a]) ` univ_basic_semialg_set m P"
       using y_def b_def
       unfolding basic_semialg_set_def univ_basic_semialg_set_def
       by blast
   qed
 qed
 
 definition is_univ_semialgebraic where
 "is_univ_semialgebraic S = (S \<subseteq> carrier Q\<^sub>p \<and> is_semialgebraic 1 (to_R1 ` S))"
 
 lemma is_univ_semialgebraicE:
   assumes "is_univ_semialgebraic S"
   shows "is_semialgebraic 1 (to_R1 ` S)"
   using assms is_univ_semialgebraic_def by blast
 
 lemma is_univ_semialgebraicI:
   assumes "is_semialgebraic 1 (to_R1 ` S)"
   shows "is_univ_semialgebraic S"
 proof-
   have "S \<subseteq> carrier Q\<^sub>p"
   proof fix x assume "x \<in> S"
     then have "(to_R1 x) \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
       using assms
       by (smt Collect_mono_iff gen_boolean_algebra_subset image_def is_semialgebraicE mem_Collect_eq semialg_sets_def Qp.to_R1_carrier)
     then show "x \<in> carrier Q\<^sub>p"
       using assms
       by (metis nth_Cons_0 Qp.to_R_pow_closed)
   qed
   then show ?thesis
     using assms
     unfolding is_univ_semialgebraic_def
     by blast
 qed
 
 lemma univ_basic_semialg_set_is_univ_semialgebraic:
   assumes "P \<in> carrier Q\<^sub>p_x"
   assumes "m \<noteq> 0"
   shows "is_univ_semialgebraic (univ_basic_semialg_set m P)"
   using assms
   by (metis (mono_tags, lifting) basic_semialg_is_semialgebraic'
       from_Qp_x_closed is_univ_semialgebraic_def mem_Collect_eq subsetI
       univ_basic_semialg_set_def univ_basic_semialg_set_to_semialg_set)
 
 lemma intersection_is_univ_semialgebraic:
   assumes "is_univ_semialgebraic A"
   assumes "is_univ_semialgebraic B"
   shows "is_univ_semialgebraic (A \<inter> B)"
   using assms intersection_is_semialg[of 1 "((\<lambda>a. [a]) ` A)" "((\<lambda>a. [a]) ` B)"]
   unfolding is_univ_semialgebraic_def
   by (metis le_infI1 Qp.to_R1_intersection)
 
 lemma union_is_univ_semialgebraic:
   assumes "is_univ_semialgebraic A"
   assumes "is_univ_semialgebraic B"
   shows "is_univ_semialgebraic (A \<union> B)"
   using assms union_is_semialgebraic[of 1 "((\<lambda>a. [a]) ` A)" "((\<lambda>a. [a]) ` B)"]
   unfolding is_univ_semialgebraic_def
   by (metis Un_subset_iff image_Un)
 
 lemma diff_is_univ_semialgebraic:
   assumes "is_univ_semialgebraic A"
   assumes "is_univ_semialgebraic B"
   shows "is_univ_semialgebraic (A - B)"
   using assms diff_is_semialgebraic[of 1 "((\<lambda>a. [a]) ` A)" "((\<lambda>a. [a]) ` B)"]
   unfolding is_univ_semialgebraic_def
   by (smt Diff_subset subset_trans Qp.to_R1_diff)
 
 lemma finite_is_univ_semialgebraic:
   assumes "A \<subseteq> carrier Q\<^sub>p"
   assumes "finite A"
   shows "is_univ_semialgebraic A"
   using assms finite_is_semialg[of "((\<lambda>a. [a]) ` A)" ]  to_R1_finite[of A]
   unfolding is_univ_semialgebraic_def
   by (metis Qp.to_R1_carrier Qp.to_R1_subset)
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Defining the $p$-adic Valuation Semialgebraically\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 lemma Qp_square_root_criterion0:
   assumes "p \<noteq> 2"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "val a \<le> val b"
   assumes "a \<noteq> \<zero>"
   assumes "b \<noteq> \<zero>"
   assumes "val a \<ge> 0"
   shows "\<exists>y \<in> carrier Q\<^sub>p. a[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp>\<otimes>b[^](2::nat) = (y [^] (2::nat))"
 proof-
   have 0: "(to_Zp a) \<in> carrier Z\<^sub>p"
     using assms(2) to_Zp_closed
     by blast
   have 1: "(to_Zp b) \<in> carrier Z\<^sub>p"
     using assms(3) to_Zp_closed
     by blast
   have 2: "a \<in> \<O>\<^sub>p"
     using val_ring_val_criterion assms(2) assms(5) assms(7) by blast
   have 3: "b \<in> \<O>\<^sub>p"
     using assms val_ring_val_criterion[of b] dual_order.trans by blast
   have 4: "val_Zp (to_Zp b) = val b"
     using 3 Zp_def \<iota>_def padic_fields.to_Zp_val padic_fields_axioms by blast
   have 5:  "val_Zp (to_Zp a) = val a"
     using Q\<^sub>p_def Zp_def assms(2) assms(7) padic_fields.Qp_val_ringI padic_fields.to_Zp_val padic_fields_axioms
     by blast
   have "\<exists>y \<in> carrier Z\<^sub>p. (to_Zp a)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat) \<oplus>\<^bsub>Z\<^sub>p\<^esub> \<p> \<otimes>\<^bsub>Z\<^sub>p\<^esub>(to_Zp b)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat) = (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat))"
     using 0 1 2 4 5 assms Zp_square_root_criterion[of "(to_Zp a)" "(to_Zp b)"]
     by (metis "3" to_Zp_inc to_Zp_zero zero_in_val_ring)
   then obtain y where y_def: "y \<in> carrier Z\<^sub>p \<and> (to_Zp a)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat) \<oplus>\<^bsub>Z\<^sub>p\<^esub> \<p> \<otimes>\<^bsub>Z\<^sub>p\<^esub>(to_Zp b)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat) = (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat))"
     by blast
   have 6: "a[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes>b[^](2::nat) = ((\<iota> y) [^] (2::nat))"
   proof-
     have 0: "\<iota> (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat)) = ((\<iota> y) [^] (2::nat))"
       using Qp_nonzero_nat_pow nat_pow_closed inc_pow nat_inc_zero inc_is_hom \<iota>_def y_def ring_hom_nat_pow[of Z\<^sub>p Q\<^sub>p \<iota> y 2]
             Q\<^sub>p_def Qp.ring_axioms Zp.ring_axioms
       by blast
     have 1: "\<iota> (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat)) = \<iota> ((to_Zp a)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat) \<oplus>\<^bsub>Z\<^sub>p\<^esub> \<p> \<otimes>\<^bsub>Z\<^sub>p\<^esub>(to_Zp b)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat))"
       using y_def by presburger
     have 2: "\<iota> (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat)) = \<iota> ((to_Zp a)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<iota> ( \<p> \<otimes>\<^bsub>Z\<^sub>p\<^esub>(to_Zp b)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat))"
       using "1" Zp.m_closed Zp_int_inc_closed assms(2) assms(3) inc_of_sum pow_closed to_Zp_closed by presburger
     hence 3: "\<iota> (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat)) = (\<iota> (to_Zp a))[^](2::nat) \<oplus> (\<iota>  \<p>) \<otimes> \<iota> ((to_Zp b)[^]\<^bsub>Z\<^sub>p\<^esub>(2::nat))"
       using Qp_nonzero_nat_pow nat_pow_closed inc_pow nat_inc_zero inc_is_hom \<iota>_def y_def ring_hom_nat_pow[of Z\<^sub>p Q\<^sub>p \<iota> _ 2]
             Q\<^sub>p_def Qp.ring_axioms Zp.ring_axioms Zp_int_inc_closed assms(2) assms(3) inc_of_prod pow_closed to_Zp_closed
       by metis
     then show ?thesis
       using "0" "4" val_ring_ord_criterion assms(2) assms(3) assms(4) assms(5)
           assms(6) assms(7) inc_pow not_nonzero_Zp ord_of_nonzero(1) p_inc to_Zp_closed to_Zp_inc
       by (metis to_Zp_zero val_pos val_ringI zero_in_val_ring)
   qed
   have "(\<iota> y) \<in> carrier Q\<^sub>p"
     using frac_closed local.inc_def y_def inc_closed by blast
   then show ?thesis
     using 6
     by blast
 qed
 
 lemma eint_minus_ineq':
   assumes "(a::eint) \<ge> b"
   shows "a -b \<ge> 0"
   by (metis assms eint_minus_ineq eint_ord_simps(3) idiff_infinity idiff_self order_trans top.extremum_unique top_eint_def)
 
 lemma Qp_square_root_criterion:
   assumes "p \<noteq> 2"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "ord b \<ge> ord a"
   assumes "a \<noteq> \<zero>"
   assumes "b \<noteq> \<zero>"
   shows "\<exists>y \<in> carrier Q\<^sub>p. a[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp>\<otimes>b[^](2::nat) = (y [^] (2::nat))"
 proof-
   have "\<exists>k::int. k \<le> min (ord a) (ord b) \<and> k mod 2 = 0"
   proof-
       let ?k = "if (min (ord a) (ord b)) mod 2 = 0 then min (ord a) (ord b)  else (min (ord a) (ord b)) - 1"
       have "?k \<le> min (ord a) (ord b) \<and> ?k mod 2 = 0"
         apply(cases "(min (ord a) (ord b)) mod 2 = 0 ")
        apply presburger
         by presburger
       then show ?thesis
         by meson
   qed
   then obtain k where k_def: "k \<le> min (ord a) (ord b) \<and> k mod 2 = 0"
     by meson
   obtain a0 where a0_def: "a0 = (\<pp>[^](-k)) \<otimes> a"
     by blast
   obtain b0 where b0_def: "b0 = (\<pp>[^](-k)) \<otimes> b"
     by blast
   have 0: "a0 \<in> nonzero Q\<^sub>p"
     using Qp.cring_axioms Qp.field_axioms Ring.integral a0_def assms(2) assms(5) cring_simprules(5)
           not_nonzero_Qp p_intpow_closed(1) p_nonzero
     by (metis Qp_int_pow_nonzero cring.cring_simprules(5))
   have 1: "val a0 =  val a - k"
     using a0_def assms(2) assms(5) val_mult p_nonzero  p_intpow_closed(1)
     by (metis Qp.m_comm Qp_int_pow_nonzero p_intpow_inv'' val_fract val_p_int_pow)
   have 11: "val b0 =  val b - k"
     using assms(3) assms(6) b0_def val_mult p_nonzero p_intpow_closed(1)
     by (metis Qp.m_lcomm Qp.one_closed Qp.r_one Qp_int_pow_nonzero p_intpow_inv'' val_fract val_p_int_pow)
   have A: "val a \<ge> k"
     using k_def val_ord assms by (smt eint_ord_simps(1) not_nonzero_Qp)
   have B: "val b \<ge> k"
     using  k_def val_ord assms by (smt eint_ord_simps(1) not_nonzero_Qp)
   then have 2: "val a0 \<ge> 0"
     using A 1 assms k_def eint_minus_ineq eint_ord_code(5) local.eint_minus_ineq' by presburger
   have 3: "val a0 \<le> val b0"
     using 1 11 assms
     by (metis eint.distinct(2) eint_minus_ineq eint_ord_simps(1) val_def)
   have 4: "a0 \<noteq> \<zero>"
     using a0_def "0" Qp.nonzero_memE(2) by blast
   have 5: "b0 \<noteq> \<zero>"
     using b0_def
     by (metis "4" Qp.integral_iff a0_def assms(2) assms(3) assms(6) p_intpow_closed(1))
   have "\<exists>y \<in> carrier Q\<^sub>p. a0[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp>\<otimes>b0[^](2::nat) = (y [^] (2::nat))"
     using Qp_square_root_criterion0[of a0 b0] assms 2 3 4 5 b0_def a0_def Qp.m_closed p_intpow_closed(1)
     by metis
   then obtain y where y_def: " y \<in> carrier Q\<^sub>p \<and> a0[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp>\<otimes>b0[^](2::nat) = (y [^] (2::nat))"
     by blast
   then have 6: " (\<pp>[^] (2 * k)) \<otimes>  (a0[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp>\<otimes>b0[^](2::nat)) =  (\<pp>[^] (2 * k))  \<otimes> (y [^] (2::nat))"
     by presburger
   then have 8: "((\<pp>[^] (2 * k)) \<otimes>  (a0[^](2::nat))) \<oplus>\<^bsub>Q\<^sub>p\<^esub>((\<pp>[^] (2 * k)) \<otimes> (\<pp>\<otimes>b0[^](2::nat))) =  (\<pp>[^] (2 * k))  \<otimes> (y [^] (2::nat))"
     using 6 Qp.r_distr[of "(a0[^](2::nat))" " (\<pp>\<otimes>b0[^](2::nat))" "(\<pp>[^] (2 * k))"]
     by (metis Qp.add.int_pow_closed Qp.m_closed Qp.nat_pow_closed Qp.one_closed a0_def assms(2) assms(3) b0_def p_inc p_intpow_closed(1) y_def)
   have 9: "(\<pp>[^](int 2*k)) = (\<pp>[^]k)[^](2::nat)"
     using Qp_int_nat_pow_pow[of \<pp> k 2]
     by (metis mult_of_nat_commute p_nonzero)
   then have "((\<pp>[^]k)[^](2::nat) \<otimes>  (a0[^](2::nat))) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^]k)[^](2::nat) \<otimes> (\<pp>\<otimes>b0[^](2::nat)) =  (\<pp>[^]k)[^](2::nat) \<otimes> (y [^] (2::nat))"
     by (metis "8" int_eq_iff_numeral)
   then have "((\<pp>[^]k) \<otimes> a0)[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>((\<pp>[^]k)[^](2::nat)) \<otimes> (\<pp>\<otimes>b0[^](2::nat)) = ((\<pp>[^]k)[^](2::nat))  \<otimes> (y [^] (2::nat))"
     by (metis Qp.cring_axioms a0_def assms(2) comm_monoid.nat_pow_distrib cring.cring_simprules(5) cring_def p_intpow_closed(1))
   then have 10:  "((\<pp>[^]k) \<otimes> a0)[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>((\<pp>[^]k)[^](2::nat)) \<otimes> (\<pp>\<otimes>b0[^](2::nat)) =  ((\<pp>[^]k)  \<otimes> y) [^] (2::nat)"
     using comm_monoid.nat_pow_distrib y_def
     by (metis Qp.comm_monoid_axioms p_intpow_closed(1))
   then have "((\<pp>[^]k) \<otimes> a0)[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>((((\<pp>[^]k)[^](2::nat)) \<otimes> \<pp>)\<otimes>b0[^](2::nat)) =  ((\<pp>[^]k)  \<otimes> y) [^] (2::nat)"
     using 10 monoid.m_assoc[of Q\<^sub>p "((\<pp>[^]k)[^](2::nat))" \<pp> " b0[^](2::nat)"]
     by (metis Qp.int_inc_closed Qp.m_assoc Qp.m_closed Qp.nat_pow_closed assms(3) b0_def p_intpow_closed(1))
   then have "((\<pp>[^]k) \<otimes> a0)[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>((\<pp> \<otimes> ((\<pp>[^]k)[^](2::nat)) )\<otimes>b0[^](2::nat)) =  ((\<pp>[^]k)  \<otimes> y) [^] (2::nat)"
     by (metis Qp.group_commutes_pow Qp.int_inc_closed Qp.m_comm p_intpow_closed(1))
   then have "((\<pp>[^]k) \<otimes> a0)[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>\<pp> \<otimes> (((\<pp>[^]k)[^](2::nat)) \<otimes>b0[^](2::nat)) =  ((\<pp>[^]k)  \<otimes> y) [^] (2::nat)"
     by (metis "10" Qp.int_inc_closed Qp.m_closed Qp.m_lcomm Qp.nat_pow_closed assms(3) b0_def p_intpow_closed(1))
   then have "((\<pp>[^]k) \<otimes> a0)[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>\<pp> \<otimes> ((\<pp>[^]k) \<otimes>b0)[^](2::nat) =  ((\<pp>[^]k)  \<otimes> y) [^] (2::nat)"
     by (metis Qp.m_closed Qp.nat_pow_distrib assms(3) b0_def p_intpow_closed(1))
   then have "a[^](2::nat) \<oplus>\<^bsub>Q\<^sub>p\<^esub>\<pp> \<otimes> b[^](2::nat) =  ((\<pp>[^]k)  \<otimes> y) [^] (2::nat)"
     by (metis Qp.l_one Qp.m_assoc a0_def assms(2) assms(3) b0_def p_intpow_closed(1) p_intpow_inv)
   then show ?thesis
     by (meson Qp.cring_axioms cring.cring_simprules(5) p_intpow_closed(1) y_def)
 qed
 
 lemma Qp_val_ring_alt_def0:
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "ord a \<ge> 0"
   shows "\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
 proof-
   have "\<exists>y \<in> carrier Z\<^sub>p. \<one>\<^bsub>Z\<^sub>p\<^esub> \<oplus>\<^bsub>Z\<^sub>p\<^esub> (\<p> [^]\<^bsub>Z\<^sub>p\<^esub> (3::nat))\<otimes>\<^bsub>Z\<^sub>p\<^esub> ((to_Zp a) [^]\<^bsub>Z\<^sub>p\<^esub> (4::nat)) = (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat))"
     using padic_integers.Zp_semialg_eq[of p "to_Zp a"] prime assms to_Zp_def
     by (metis (no_types, lifting) Qp.nonzero_closed Qp.not_nonzero_memI Zp_def val_ring_ord_criterion not_nonzero_Zp padic_integers_axioms to_Zp_closed to_Zp_inc to_Zp_zero zero_in_val_ring)
   then obtain y where y_def: "y \<in> carrier Z\<^sub>p \<and> \<one>\<^bsub>Z\<^sub>p\<^esub> \<oplus>\<^bsub>Z\<^sub>p\<^esub> (\<p> [^]\<^bsub>Z\<^sub>p\<^esub> (3::nat))\<otimes>\<^bsub>Z\<^sub>p\<^esub> ((to_Zp a) [^]\<^bsub>Z\<^sub>p\<^esub> (4::nat)) = (y [^]\<^bsub>Z\<^sub>p\<^esub> (2::nat))"
     by blast
   then have "\<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = ((\<iota> y)[^](2::nat))"
     using  Group.nat_pow_0 Group.nat_pow_Suc nonzero_def
         val_ring_ord_criterion  assms inc_of_nonzero inc_of_prod inc_of_sum inc_pow
         m_closed nat_inc_closed nat_pow_closed  not_nonzero_Zp
         numeral_2_eq_2 p_natpow_inc to_Zp_closed to_Zp_inc
     by (smt Qp.nonzero_closed Qp.nonzero_memE(2) Zp.monom_term_car p_pow_nonzero(1) pow_closed to_Zp_zero zero_in_val_ring)
   then have "(\<iota> y) \<in> carrier Q\<^sub>p \<and> \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = ((\<iota> y)[^](2::nat))"
     using y_def inc_closed by blast
   then show ?thesis
     by blast
 qed
 
 text\<open>Defining the valuation semialgebraically for odd primes\<close>
 
 lemma P_set_ord_semialg_odd_p:
   assumes "p \<noteq> 2"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   shows  "val a \<le> val b \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp> \<otimes> (b[^](2::nat))) = (y[^](2::nat)))"
 proof(cases "a = \<zero>")
   case True
   show "val a \<le> val b \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp> \<otimes> (b[^](2::nat))) = (y[^](2::nat)))"
   proof
     show "val b \<ge> val a \<Longrightarrow> \<exists>y\<in>carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
     proof-
       assume A: "val b \<ge> val a"
       then have "val b \<ge> \<infinity>"
         by (metis True local.val_zero)
       then have "b = \<zero>"
         using assms(3) local.val_zero val_ineq by presburger
       then have "(a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (\<zero>[^](2::nat))"
         using True
         by (metis Qp.int_inc_zero Qp.int_nat_pow_rep Qp.nonzero_closed Qp.r_null Qp.r_zero assms(3) p_nonzero zero_power2)
       then show ?thesis
         using \<open>b = \<zero>\<close> assms(3) by blast
     qed
     show "\<exists>y\<in>carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat)) \<Longrightarrow> val b \<ge> val a"
     proof-
       assume "\<exists>y\<in>carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
       then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and>(a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
         by blast
       then have 0: "\<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
         by (metis (no_types, lifting) Qp.add.r_cancel_one' Qp.int_inc_closed Qp.nat_pow_closed
             Qp.not_nonzero_memI Qp_nonzero_nat_pow True assms(2) assms(3) local.monom_term_car not_nonzero_Qp zero_less_numeral)
       have "b = \<zero>"
         apply(rule ccontr)
         using 0 assms y_def p_times_square_not_square[of b]
         unfolding P_set_def
         by (metis (no_types, opaque_lifting) P_set_memI Qp.nat_pow_closed True
             \<open>b \<in> nonzero Q\<^sub>p \<Longrightarrow> \<pp> \<otimes> b [^] 2 \<notin> P_set 2\<close> not_nonzero_Qp p_times_square_not_square')
       then show ?thesis
         using eint_ord_code(3) local.val_zero by presburger
     qed
   qed
 next
   case False
   then show ?thesis
   proof(cases "b = \<zero>")
     case True
     then have "(a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp> \<otimes> (b[^](2::nat))) =  (a[^](2::nat))"
       by (metis Qp.add.l_cancel_one' Qp.int_inc_zero Qp.int_nat_pow_rep Qp.nat_pow_closed Qp.nonzero_closed Qp.r_null assms(2) assms(3) p_nonzero zero_power2)
     then have 0: "(\<exists>y \<in> carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp> \<otimes> (b[^](2::nat))) = (y[^](2::nat)))"
       using assms(2)
       by blast
     have 1: "val a \<le> val b"
       using True assms local.val_zero  eint_ord_code(3) by presburger
     show "val a \<le> val b \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp> \<otimes> (b[^](2::nat))) = (y[^](2::nat)))"
       using 0 1
       by blast
   next
     case F: False
     show "val a \<le> val b \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp> \<otimes> (b[^](2::nat))) = (y[^](2::nat)))"
     proof
       show "val b \<ge> val a \<Longrightarrow> \<exists>y\<in>carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
       proof-
         assume  "val b \<ge> val a "
         then have "ord b \<ge> ord a"
           using F False
           by (metis eint_ord_simps(1) val_def)
         then show "\<exists>y\<in>carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
           using assms Qp_square_root_criterion[of a b] False F
           by blast
       qed
       show "\<exists>y\<in>carrier Q\<^sub>p.(a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat)) \<Longrightarrow> val b \<ge> val a"
       proof-
         assume "\<exists>y\<in>carrier Q\<^sub>p. (a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
         then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and>(a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat)) = (y[^](2::nat))"
           by blast
         have 0: "ord (a[^](2::nat)) =  2* ord a"
           by (metis (mono_tags, opaque_lifting) False Suc_1 assms(2) int_eq_iff_numeral nat_numeral
               nonzero_nat_pow_ord not_nonzero_Qp)
         have 1: "ord (\<pp> \<otimes> (b[^](2::nat))) = 1 + 2* ord b"
         proof-
           have 0: "ord (\<pp> \<otimes> (b[^](2::nat))) = ord \<pp> + ord  (b[^](2::nat))"
             using F Qp_nat_pow_nonzero assms(3) not_nonzero_Qp ord_mult p_nonzero
             by metis
           have 1: "ord  (b[^](2::nat)) = 2* ord b"
             using F assms
             by (metis (mono_tags, opaque_lifting)  Suc_1  int_eq_iff_numeral nat_numeral
               nonzero_nat_pow_ord not_nonzero_Qp)
           then show ?thesis
             using "0" ord_p
             by linarith
         qed
         show "val b \<ge> val a"
         proof(rule ccontr)
           assume "\<not> val b \<ge> val a"
           then have "val b \<noteq> val a \<and> val a \<ge> val b"
             by (metis linear)
           then have "ord a > ord b"
             using F False assms
             by (metis \<open>\<not> val a \<le> val b\<close> eint_ord_simps(1) le_less not_less_iff_gr_or_eq val_def)
           then have "ord (a[^](2::nat)) > ord (\<pp> \<otimes> (b[^](2::nat)))"
             using 0 1
             by linarith
           then have "ord ((a[^](2::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^](2::nat))) = ord (\<pp> \<otimes> (b[^](2::nat)))"
             by (meson F False Qp.int_inc_closed Qp_nat_pow_nonzero assms(2) assms(3)
                 local.monom_term_car not_nonzero_Qp ord_ultrametric_noteq p_times_square_not_square')
           then have A0: "ord (y[^](2::nat)) = 1 + 2* ord b"
             by (metis "1" \<open>y \<in> carrier Q\<^sub>p \<and> (a[^]2) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<pp> \<otimes> (b[^]2) = (y[^]2)\<close>)
           have A1: "(y[^](2::nat)) \<in> nonzero Q\<^sub>p"
             using y_def 0 1
             by (smt F False Qp.nonzero_closed Qp_nat_pow_nonzero assms(2) assms(3) diff_ord_nonzero
                 local.monom_term_car not_nonzero_Qp p_nonzero p_times_square_not_square')
           have A2: "y \<in> nonzero Q\<^sub>p"
             using A1 Qp_nonzero_nat_pow pos2 y_def by blast
           have A3: "ord (y[^](2::nat)) = 2* ord y"
             using  A2  nonzero_nat_pow_ord
             by presburger
           then show False using A0
             by presburger
         qed
       qed
     qed
   qed
 qed
 
 text\<open>Defining the valuation ring semialgebraically for all primes\<close>
 
 lemma Qp_val_ring_alt_def:
   assumes "a \<in> carrier Q\<^sub>p"
   shows "a \<in> \<O>\<^sub>p \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)))"
 proof(cases "a = \<zero>")
   case True
   then have "\<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = \<one>"
     by (metis Qp.add.l_cancel_one' Qp.integral_iff Qp.nat_pow_closed Qp.not_nonzero_memI
         Qp.one_closed Qp_nonzero_nat_pow assms not_nonzero_Qp p_natpow_closed(1) zero_less_numeral)
   then have "\<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (\<one>[^](2::nat))"
     using Qp.nat_pow_one by blast
   then show ?thesis
     using True zero_in_val_ring by blast
 next
   case False
   show "a \<in> \<O>\<^sub>p \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)))"
   proof
     show "a \<in> \<O>\<^sub>p \<Longrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)))"
       using assms Qp_val_ring_alt_def0[of a] False
       by (meson not_nonzero_Qp ord_nonneg)
     show "(\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))) \<Longrightarrow> a \<in> \<O>\<^sub>p"
     proof-
       assume "(\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)))"
       then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and>\<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
         by blast
       then have "(\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>"
         using Qp.ring_simprules
         by (smt Qp.nat_pow_closed assms p_natpow_closed(1))
       then have "ord ((\<pp>[^](3::nat))\<otimes> (a[^](4::nat))) = ord ((y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>)"
         by presburger
       then have "3 + ord (a[^](4::nat)) = ord ((y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>)"
         by (metis False Qp_nat_pow_nonzero assms not_nonzero_Qp of_nat_numeral ord_mult ord_p_pow_nat p_nonzero)
       then have 0: "3 + 4* ord a = ord ((y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>)"
         using assms False nonzero_nat_pow_ord[of a "(4::nat)"]
         by (metis nonzero_nat_pow_ord not_nonzero_Qp of_nat_numeral)
       have "ord a \<ge> 0"
       proof(rule ccontr)
         assume "\<not> 0 \<le> ord a"
         then have 00: "ord ((y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>) < 0"
           using 0
           by linarith
         have yn: "y \<in> nonzero Q\<^sub>p"
           apply(rule ccontr)
           using y_def 0
           by (metis "00" Qp.not_eq_diff_nonzero Qp.one_closed Qp.one_nonzero Qp.pow_zero
               \<open>\<pp> [^] 3 \<otimes> a [^] 4 = y [^] 2 \<ominus> \<one>\<close> diff_ord_nonzero less_numeral_extra(3)
               local.one_neq_zero not_nonzero_Qp ord_one zero_less_numeral)
         then have "ord ((y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>) = ord (y[^](2::nat))"
           using y_def ord_ultrametric_noteq''[of  "(y[^](2::nat))" "\<one>" ]
           by (metis "00" False Qp.integral Qp.nat_pow_closed Qp.nonzero_closed Qp.nonzero_pow_nonzero
               Qp.not_eq_diff_nonzero Qp.one_nonzero Qp.r_right_minus_eq \<open>\<pp> [^] 3 \<otimes> a [^] 4 = y [^] 2 \<ominus> \<one>\<close>
               assms ord_one ord_ultrametric_noteq p_nonzero)
         then have "ord ((y[^](2::nat)) \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<one>) = 2* ord y"
           using y_def Qp_nat_pow_nonzero Qp_nonzero_nat_pow nonzero_nat_pow_ord[of y "(2::nat)"]  yn
           by linarith
         then have "3 + (4* ord a) = 2* ord y"
           using "00" "0"
           by linarith
         then show False
           by presburger
       qed
       then show "a \<in> \<O>\<^sub>p"
         using False val_ring_ord_criterion assms by blast
     qed
   qed
 qed
 
 lemma Qp_val_alt_def:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   shows "val b \<le> val a \<longleftrightarrow> (\<exists>y \<in> carrier Q\<^sub>p. (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)))"
 proof
   show "val a \<ge> val b \<Longrightarrow> \<exists>y\<in>carrier Q\<^sub>p. (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
   proof-
     assume A: "val a \<ge> val b"
     show "\<exists>y\<in>carrier Q\<^sub>p. (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
     proof(cases "b = \<zero>")
       case True
       then have "a = \<zero>"
         using A assms(1) val_ineq
         by blast
       then have "(b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (\<zero>[^](2::nat))"
         by (metis Qp.nat_pow_zero Qp.r_null Qp.r_zero True assms(2) p_natpow_closed(1) zero_neq_numeral)
       then show ?thesis
         using True A assms(2)
         by blast
     next
       case False
       assume B: "b \<noteq> \<zero>"
       show "\<exists>y\<in>carrier Q\<^sub>p. (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat)) \<otimes> (a[^](4::nat)) = (y[^](2::nat))"
       proof(cases "a = \<zero>")
         case True
         then have "(b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (b[^](4::nat))"
           using Qp.cring_axioms Qp.nat_pow_closed assms(2) cring_def p_natpow_closed(1) ring.pow_zero zero_less_numeral
           by (metis Qp.add.l_cancel_one' Qp.integral_iff assms(1))
         then have "(b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = ((b[^](2::nat))[^] (2::nat))"
           by (metis Qp_nat_pow_pow assms(2) mult_2_right numeral_Bit0)
         then have "(b[^](2::nat)) \<in> carrier Q\<^sub>p \<and> (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = ((b[^](2::nat))[^] (2::nat))"
           using Qp.nat_pow_closed assms(2)
           by blast
         then show ?thesis
           by blast
       next
         case False
         have F0:  "b \<in> nonzero Q\<^sub>p"
           using B assms(2) not_nonzero_Qp
           by metis
         have F1: "a \<in> nonzero Q\<^sub>p"
           using False assms(1) not_nonzero_Qp
           by metis
         then have "(a \<div> b) \<in> nonzero Q\<^sub>p"
           using B
           by (meson Localization.submonoid.m_closed Qp.nonzero_is_submonoid assms(2) inv_in_frac(3))
         then have "val a \<ge> val b"
           using F0 F1 A by blast
         then have "val (a \<div> b) \<ge> 0"
           using F0 F1 val_fract assms(1) local.eint_minus_ineq' by presburger
         obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat)) = (y[^](2::nat))"
           using Qp_val_ring_alt_def0
           by (meson B False Qp.integral Qp.nonzero_closed \<open>(a \<div> b) \<in> nonzero Q\<^sub>p\<close> \<open>0 \<le> val (a \<div> b)\<close>
               assms(1) assms(2) inv_in_frac(1) inv_in_frac(2) ord_nonneg val_ringI)
         then have "(b[^](4::nat)) \<otimes> (\<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat))) =
                (b[^](4::nat)) \<otimes> (y[^](2::nat))"
           by presburger
         then have  F2: "(b[^](4::nat)) \<otimes> (\<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat))) =
                ((b[^](2::nat)) [^] (2::nat)) \<otimes> (y[^](2::nat))"
           by (metis Qp.nat_pow_pow assms(2) mult_2_right numeral_Bit0)
         have  F3: "((b[^](4::nat)) \<otimes> \<one>) \<oplus>\<^bsub>Q\<^sub>p\<^esub> ((b[^](4::nat)) \<otimes>((\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat)))) =
                ((b[^](2::nat))[^] (2::nat)) \<otimes> (y[^](2::nat))"
         proof-
           have 0: "(\<pp>[^](3::nat)) \<otimes> (a \<div> b[^](4::nat)) \<in> carrier Q\<^sub>p "
           proof-
             have "(a \<div> b[^](4::nat)) \<in> carrier Q\<^sub>p"
               using F0 Qp.nat_pow_closed assms(1) fract_closed Qp_nat_pow_nonzero by presburger
             then show ?thesis
               by (meson Qp.cring_axioms cring.cring_simprules(5) p_natpow_closed(1))
           qed
           have 1: "(b[^](4::nat)) \<in> carrier Q\<^sub>p"
             using Qp.nat_pow_closed assms(2)
             by blast
           then show ?thesis
             using 0 F2  ring.ring_simprules(23)[of Q\<^sub>p "\<one>" "(\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat))" "(b[^](4::nat))"]
                   Qp.cring_axioms Qp.nonzero_mult_closed Qp.ring_axioms Qp_nat_pow_nonzero \<open>(a \<div> b) \<in> nonzero Q\<^sub>p\<close> p_nonzero
             by blast
         qed
         have F4: "(b[^](4::nat)) \<in> carrier Q\<^sub>p"
           using Qp.nat_pow_closed assms(2)
           by blast
         then have "((b[^](4::nat)) \<otimes> \<one>) = (b[^](4::nat))"
           using Qp.r_one by blast
         then have F5:  "(b[^](4::nat))\<oplus>\<^bsub>Q\<^sub>p\<^esub> ((b[^](4::nat)) \<otimes>((\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat)))) =
                ((b[^](2::nat)) [^] (2::nat)) \<otimes> (y[^](2::nat))"
           using F3
           by presburger
         have "((b[^](4::nat)) \<otimes>((\<pp>[^](3::nat))\<otimes> ((a \<div> b)[^](4::nat)))) = (\<pp>[^](3::nat))\<otimes>((b[^](4::nat)) \<otimes> ((a \<div> b)[^](4::nat)))"
         proof-
           have 0: "(b[^](4::nat)) \<in> carrier Q\<^sub>p"
             using F4 by blast
           have 1: "(\<pp>[^](3::nat)) \<in> carrier Q\<^sub>p"
             by blast
           have  2: "((a \<div> b)[^](4::nat)) \<in> carrier Q\<^sub>p"
             using F0 Qp.nat_pow_closed assms(1) fract_closed
             by blast
           show ?thesis using 0 1 2  monoid.m_assoc[of Q\<^sub>p] comm_monoid.m_comm[of Q\<^sub>p]
             using Qp.m_lcomm by presburger
         qed
         then have  "(b[^](4::nat))\<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes>((b[^](4::nat)) \<otimes> ((a \<div> b)[^](4::nat))) =
                ((b[^](2::nat)) [^] (2::nat)) \<otimes> (y[^](2::nat))"
           using F5  by presburger
         then have  "(b[^](4::nat))\<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes>((b \<otimes>(a \<div> b))[^](4::nat)) =
                ((b[^](2::nat)) [^] (2::nat)) \<otimes> (y[^](2::nat))"
           using F0 Qp.nat_pow_distrib assms(1) assms(2) fract_closed by presburger
         then have  "(b[^](4::nat))\<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes>(a[^](4::nat)) =
                ((b[^](2::nat)) [^] (2::nat)) \<otimes> (y[^](2::nat))"
           by (metis F0 assms(1) local.fract_cancel_right)
         then have  "(b[^](4::nat))\<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes>(a[^](4::nat)) =
                (((b[^](2::nat))\<otimes> y)[^](2::nat))"
           using Qp.nat_pow_closed Qp.nat_pow_distrib assms(2) y_def by blast
         then have  "((b[^](2::nat))\<otimes> y) \<in> carrier Q\<^sub>p \<and> (b[^](4::nat))\<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes>(a[^](4::nat)) =
                (((b[^](2::nat))\<otimes> y)[^](2::nat))"
           by (meson Qp.cring_axioms Qp.nat_pow_closed assms(2) cring.cring_simprules(5) y_def)
         then show ?thesis
           by blast
       qed
     qed
   qed
   show "\<exists>y \<in> carrier Q\<^sub>p. (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat)) \<Longrightarrow> val a \<ge> val b"
   proof-
     assume A: "\<exists>y \<in> carrier Q\<^sub>p. (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
     show "val a \<ge> val b"
     proof(cases "a = \<zero>")
       case True
       then show ?thesis
         using eint_ord_code(3) local.val_zero by presburger
     next
       case False
       have  "b \<noteq> \<zero>"
       proof(rule ccontr)
         assume  "\<not> b \<noteq> \<zero>"
         then have "\<exists>y \<in> carrier Q\<^sub>p.  (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
           using A
           by (metis (no_types, lifting) Qp.add.r_cancel_one' Qp.nat_pow_closed Qp.nonzero_memE(2)
               Qp_nonzero_nat_pow assms(1) assms(2) local.monom_term_car not_nonzero_Qp
               p_natpow_closed(1) zero_less_numeral)
         then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
           by blast
         have 0: "ord ((\<pp>[^](3::nat))\<otimes> (a[^](4::nat))) = 3 +  4* ord a"
         proof-
           have 00: "(\<pp>[^](3::nat)) \<in> nonzero Q\<^sub>p"
             using Qp_nat_pow_nonzero p_nonzero by blast
           have 01: "(a[^](4::nat)) \<in> nonzero Q\<^sub>p"
             using False Qp_nat_pow_nonzero assms(1) not_nonzero_Qp Qp.nonzero_memI by presburger
           then show ?thesis using ord_mult[of "\<pp>[^](3::nat)" "a[^](4::nat)"]
             by (metis (no_types, lifting) "00" False assms(1) nonzero_nat_pow_ord
                 not_nonzero_Qp of_nat_numeral ord_p_pow_nat)
         qed
         have 1: "ord ((\<pp>[^](3::nat))\<otimes> (a[^](4::nat))) = 2* (ord y)"
         proof-
           have "y \<noteq> \<zero>"
           proof(rule ccontr)
             assume " \<not> y \<noteq> \<zero>"
             then have "(\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = \<zero>"
               using y_def  Qp.cring_axioms cring_def pos2 ring.pow_zero by blast
             then show False
               by (metis False Qp.integral Qp.nat_pow_closed Qp.nonzero_pow_nonzero
                   Qp.not_nonzero_memI Qp_nat_pow_nonzero assms(1) p_natpow_closed(1) p_nonzero)
           qed
           then show ?thesis
             using y_def
             by (metis nonzero_nat_pow_ord not_nonzero_Qp of_nat_numeral)
         qed
         then show False
           using 0
           by presburger
       qed
       then have F0: "b \<in> nonzero Q\<^sub>p"
         using assms(2) not_nonzero_Qp  by metis
 
       have F1: "a \<in> nonzero Q\<^sub>p"
         using False assms(1) not_nonzero_Qp by metis
       obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat)) = (y[^](2::nat))"
         using A by blast
       show ?thesis
       proof(rule ccontr)
         assume " \<not> val a \<ge> val b "
         then have F2: "ord a < ord b"
           using F0 F1 assms
           by (metis False \<open>b \<noteq> \<zero>\<close> eint_ord_simps(1) leI val_def)
         have 0: "ord ((\<pp>[^](3::nat))\<otimes> (a[^](4::nat))) = 3 + 4* ord a"
           using F0 ord_mult F1 Qp_nat_pow_nonzero nonzero_nat_pow_ord ord_p_pow_nat p_natpow_closed(2)
           by presburger
         have 1: " ord (b[^](4::nat)) = 4* ord b"
           using F0 nonzero_nat_pow_ord
           by presburger
         have 2: "(4 * (ord b)) > 4 * (ord a)"
           using F2 by linarith
         have 3: "(4 * (ord b)) \<le> 3 + 4* ord a"
         proof(rule ccontr)
           assume "\<not> (4 * (ord b)) \<le> 3 + 4* ord a"
           then have "(4 * (ord b)) > 3 + 4* ord a"
             by linarith
           then have 30: "ord ((b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat))) = 3 + 4* ord a"
             using "0" "1" F0 F1  Qp_nat_pow_nonzero Qp.nat_pow_closed assms(1) monom_term_car not_nonzero_Qp ord_ultrametric_noteq
                 p_natpow_closed(1) p_nonzero
             by (metis Qp.integral)
           have "y \<in> nonzero Q\<^sub>p"
           proof(rule ccontr)
             assume A: "y \<notin> nonzero Q\<^sub>p"
             then have "y = \<zero>"
               using y_def  Qp.nonzero_memI by blast
             then have "b [^] 4 \<oplus> \<pp> [^] 3 \<otimes> a [^] 4 = \<zero>"
               by (smt "0" "1" A F0 False Qp.integral Qp.nat_pow_closed Qp.nonzero_closed
                 Qp.nonzero_mult_closed Qp.nonzero_pow_nonzero Qp.pow_zero assms(1) diff_ord_nonzero not_nonzero_Qp p_nonzero pos2 y_def)
             then show False
               by (smt "0" "1" A F0 F1 Qp.integral Qp.nat_pow_closed Qp.nonzero_mult_closed
                 Qp_nat_pow_nonzero assms(1) diff_ord_nonzero not_nonzero_Qp p_natpow_closed(1) p_nonzero y_def)
           qed
           then have 31: "ord ((b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat))) = 2* ord y"
             using nonzero_nat_pow_ord y_def
             by presburger
           then show False using 30 by presburger
         qed
         show False
           using 2 3
           by presburger
       qed
     qed
   qed
 qed
 
 text\<open>The polynomial in two variables which semialgebraically defines the valuation relation\<close>
 
 definition Qp_val_poly where
 "Qp_val_poly = (pvar Q\<^sub>p 1)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat) \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> (\<pp>[^](3::nat) \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> ((pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat)))"
 
 lemma Qp_val_poly_closed:
 "Qp_val_poly \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
 proof-
   have "(pvar Q\<^sub>p 1) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
     using local.pvar_closed one_less_numeral_iff semiring_norm(76) by blast
   then have 0: "(pvar Q\<^sub>p 1)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
 
     using  ring.Pring_is_ring[of Q\<^sub>p "{0::nat..2-1}"]
           monoid.nat_pow_closed[of "coord_ring Q\<^sub>p 2"] Qp.cring_axioms cring.axioms(1) ring.Pring_is_monoid
     by blast
   have 1: "(pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
     using local.pvar_closed pos2 by blast
   have 2: "\<pp>[^](3::nat) \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
     using 1 local.smult_closed p_natpow_closed(1) by blast
   then show ?thesis
     unfolding Qp_val_poly_def
     using 0 by blast
 qed
 
 lemma Qp_val_poly_eval:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   shows "Qp_ev Qp_val_poly [a, b] =  (b[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (a[^](4::nat))"
 proof-
   have 0: "[a,b] \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
   proof(rule cartesian_power_car_memI)
     show "length [a, b] = 2"
       by simp
     have "set [a,b] = {a,b}"
       by auto
     then show "set [a, b] \<subseteq> carrier Q\<^sub>p"
       using assms
       by (simp add: \<open>a \<in> carrier Q\<^sub>p\<close> \<open>b \<in> carrier Q\<^sub>p\<close>)
   qed
   obtain f where f_def: "f = ((pvar Q\<^sub>p 1)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat))"
     by blast
   obtain g where g_def: "g = (\<pp>[^](3::nat) \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> ((pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat)))"
     by blast
   have 1: "Qp_val_poly = f \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> g"
     unfolding Qp_val_poly_def
     using f_def g_def by blast
   have 1: "Qp_ev (pvar Q\<^sub>p (0::nat)) [a,b] = a"
     using eval_pvar
     by (metis \<open>[a, b] \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)\<close> nth_Cons_0 pos2)
   have 2: "Qp_ev (pvar Q\<^sub>p (1::nat)) [a,b] = b"
     using eval_pvar
     by (metis (no_types, lifting) "0" One_nat_def add_diff_cancel_right' assms(2)
         cartesian_power_car_memE gr_zeroI less_numeral_extra(1) less_numeral_extra(4)
         list.size(4) nth_Cons_pos Qp.to_R1_closed Qp.to_R_to_R1 zero_less_diff)
   have 3: "Qp_ev ((pvar Q\<^sub>p 1)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat)) [a,b] = (b[^](4::nat))"
     by (metis "0" "2" eval_at_point_nat_pow local.pvar_closed one_less_numeral_iff semiring_norm(76))
   have 4: "Qp_ev ((pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat)) [a,b] = (a[^](4::nat))"
     using "0" "1" eval_at_point_nat_pow local.pvar_closed pos2 by presburger
   then have 5: "Qp_ev (poly_scalar_mult Q\<^sub>p (\<pp>[^](3::nat)) ((pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat))) [a,b] = (\<pp>[^](3::nat))\<otimes> (a[^](4::nat))"
     using eval_at_point_smult[of "[a,b]" 2 "(pvar Q\<^sub>p 0)[^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>(4::nat)" "\<pp>[^](3::nat)" ] 2
     by (metis "0" MP.nat_pow_closed eval_at_point_scalar_mult local.pvar_closed p_natpow_closed(1) zero_less_numeral)
   then show ?thesis
   proof-
     have 00: "[a, b] \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
       by (simp add: "0")
     have 01: " pvar Q\<^sub>p 1 [^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> (4::nat) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
       by (meson MP.nat_pow_closed local.pvar_closed one_less_numeral_iff semiring_norm(76))
     have 02: "\<pp>[^](3::nat) \<odot>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub>  (pvar Q\<^sub>p 0 [^]\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> (4::nat)) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>2\<^esub>])"
       by (meson MP.nat_pow_closed local.pvar_closed local.smult_closed p_natpow_closed(1) zero_less_numeral)
     then show ?thesis
       unfolding Qp_val_poly_def
       using 00 01 02
       by (metis (no_types, lifting) "3" "4" MP.nat_pow_closed eval_at_point_add eval_at_point_smult
           local.pvar_closed p_natpow_closed(1) zero_less_numeral)
   qed
 qed
 
 lemma Qp_2I:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   shows "[a,b] \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
   apply(rule cartesian_power_car_memI)
   using assms
   apply (simp add: assms(1) assms(2))
   using assms
   by (simp add: assms(1) assms(2))
 
 lemma pair_id:
   assumes "length as = 2"
   shows "as = [as!0, as!1]"
   using assms
   by (smt One_nat_def diff_Suc_1 length_Cons less_Suc0 less_SucE list.size(3)
       nth_Cons' nth_equalityI numeral_2_eq_2)
 
 lemma Qp_val_semialg:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   shows "val b \<le> val a \<longleftrightarrow> [a,b] \<in> basic_semialg_set 2 (2::nat) Qp_val_poly"
 proof
   show "val a \<ge> val b \<Longrightarrow> [a, b] \<in> basic_semialg_set 2 2 Qp_val_poly"
     using Qp_val_alt_def[of a b] Qp_2I[of a b]  Qp_val_poly_eval[of a b]
     unfolding basic_semialg_set_def
     by (metis (mono_tags, lifting) assms(1) assms(2) mem_Collect_eq)
   show "[a, b] \<in> basic_semialg_set 2 2 Qp_val_poly \<Longrightarrow> val a \<ge> val b"
     using Qp_val_alt_def[of a b] Qp_2I[of a b]  Qp_val_poly_eval[of a b]
     unfolding basic_semialg_set_def
     using assms(1) assms(2)
     by blast
 qed
 
 definition val_relation_set where
 "val_relation_set = {as \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (as!1) \<le> val (as!0)}"
 
 lemma val_relation_setE:
   assumes "as \<in> val_relation_set"
   shows "as!0 \<in> carrier Q\<^sub>p \<and> as!1 \<in> carrier Q\<^sub>p \<and> as = [as!0,as!1] \<and> val (as!1) \<le> val (as!0)"
   using assms  unfolding val_relation_set_def
   by (smt cartesian_power_car_memE cartesian_power_car_memE' mem_Collect_eq one_less_numeral_iff pair_id pos2 semiring_norm(76))
 
 lemma val_relation_setI:
   assumes "as!0 \<in> carrier Q\<^sub>p"
   assumes "as!1 \<in> carrier Q\<^sub>p"
   assumes "length as = 2"
   assumes "val (as!1) \<le> val(as!0)"
   shows "as \<in> val_relation_set"
   unfolding val_relation_set_def using assms Qp_2I[of "as!0" "as!1"]
   by (metis (no_types, lifting) mem_Collect_eq pair_id)
 
 lemma val_relation_semialg:
 "val_relation_set  = basic_semialg_set 2 (2::nat) Qp_val_poly"
 proof
   show "val_relation_set \<subseteq>  basic_semialg_set 2 (2::nat) Qp_val_poly"
   proof fix as
     assume A: "as \<in> val_relation_set"
     have 0: "length as = 2"
       unfolding val_relation_set_def
       by (metis (no_types, lifting) A cartesian_power_car_memE mem_Collect_eq val_relation_set_def)
     have 1: "as = [as ! 0, as ! 1]"
       by (metis (no_types, lifting) A cartesian_power_car_memE mem_Collect_eq pair_id val_relation_set_def)
     show "as \<in>   basic_semialg_set 2 (2::nat) Qp_val_poly"
       using A 1 val_relation_setE[of as]  Qp_val_semialg[of  "as!0" "as!1"]
       by presburger
   qed
   show "basic_semialg_set 2 (2::nat) Qp_val_poly \<subseteq> val_relation_set"
   proof
     fix as
     assume "as \<in> basic_semialg_set 2 (2::nat) Qp_val_poly"
     then show "as \<in> val_relation_set"
       using val_relation_setI[of as]
       by (smt cartesian_power_car_memE cartesian_power_car_memE' mem_Collect_eq
           one_less_numeral_iff Qp_val_semialg basic_semialg_set_def
           val_relation_set_def padic_fields_axioms pair_id pos2 semiring_norm(76))
   qed
 qed
 
 lemma val_relation_is_semialgebraic:
 "is_semialgebraic 2 val_relation_set"
 proof -
 have "{rs \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (rs ! 0) \<ge> val (rs ! 1)} = basic_semialg_set (Suc 1) (Suc 1) Qp_val_poly"
 using Suc_1 val_relation_semialg val_relation_set_def by presburger
   then show ?thesis
     by (metis (no_types) Qp_val_poly_closed Suc_1 basic_semialg_is_semialgebraic' val_relation_set_def zero_neq_numeral)
 qed
 
 lemma Qp_val_ring_is_semialg:
   obtains P where "P \<in> carrier Q\<^sub>p_x \<and> \<O>\<^sub>p = univ_basic_semialg_set 2 P"
 proof-
   obtain P where P_def: "P = (\<pp>[^](3::nat)) \<odot>\<^bsub>Q\<^sub>p_x \<^esub>(X_poly Q\<^sub>p) [^]\<^bsub>Q\<^sub>p_x\<^esub> (4::nat) \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> \<one>\<^bsub>Q\<^sub>p_x\<^esub>"
     by blast
   have 0: "P \<in> carrier Q\<^sub>p_x"
   proof-
     have 0: "(X_poly Q\<^sub>p) \<in> carrier Q\<^sub>p_x"
       using UPQ.X_closed by blast
     then show ?thesis
       using P_def UPQ.P.nat_pow_closed p_natpow_closed(1) by blast
   qed
   have 1: "\<O>\<^sub>p = univ_basic_semialg_set 2 P"
   proof
     show "\<O>\<^sub>p \<subseteq> univ_basic_semialg_set 2 P"
     proof
       fix x
       assume A: "x \<in> \<O>\<^sub>p"
       show "x \<in> univ_basic_semialg_set 2 P"
       proof-
         have x_car: "x \<in> carrier Q\<^sub>p"
           using A val_ring_memE by blast
         then have "(\<exists>y \<in> carrier Q\<^sub>p. \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (x[^](4::nat)) = (y[^](2::nat)))"
           using A Qp_val_ring_alt_def[of x]
           by blast
         then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (x[^](4::nat)) = (y[^](2::nat))"
           by blast
         have "y \<in> carrier Q\<^sub>p \<and> P \<bullet> x = (y[^](2::nat))"
         proof-
           have "P \<bullet> x = \<one> \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<pp>[^](3::nat))\<otimes> (x[^](4::nat))"
           proof-
             have "((\<pp>[^](3::nat)) \<odot>\<^bsub>Q\<^sub>p_x\<^esub> (X_poly Q\<^sub>p) [^]\<^bsub>Q\<^sub>p_x\<^esub>  (4::nat)) \<in> carrier Q\<^sub>p_x"
               using UPQ.monom_closed p_natpow_closed(1) by blast
             then have "P \<bullet> x = (((\<pp>[^](3::nat)) \<odot>\<^bsub>Q\<^sub>p_x\<^esub> (X_poly Q\<^sub>p) [^]\<^bsub>Q\<^sub>p_x\<^esub>  (4::nat))\<bullet> x) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<one>\<^bsub>Q\<^sub>p_x\<^esub> \<bullet> x)"
               using P_def x_car UPQ.to_fun_plus by blast
             then have 0: "P \<bullet> x = (\<pp>[^](3::nat)) \<otimes>(( (X_poly Q\<^sub>p) [^]\<^bsub>Q\<^sub>p_x\<^esub>  (4::nat))\<bullet> x) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (\<one>\<^bsub>Q\<^sub>p_x\<^esub> \<bullet> x)"
               using UPQ.P.nat_pow_closed UPQ.X_closed UPQ.to_fun_smult p_natpow_closed(1) x_car by presburger
             have "(( (X_poly Q\<^sub>p) [^]\<^bsub>Q\<^sub>p_x\<^esub>  (4::nat))\<bullet> x) = (x[^](4::nat))"
               using UPQ.to_fun_X_pow x_car by blast
             then have "P \<bullet> x = (\<pp>[^](3::nat)) \<otimes>(x[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<one>"
               using "0" UPQ.to_fun_one x_car by presburger
             then show ?thesis
               using y_def Qp.add.m_comm Qp.one_closed local.monom_term_car p_natpow_closed(1) x_car
               by presburger
           qed
           then show ?thesis
             using y_def
             by blast
         qed
         then show ?thesis
           unfolding  univ_basic_semialg_set_def
           using x_car
           by blast
       qed
     qed
     show "univ_basic_semialg_set 2 P \<subseteq> \<O>\<^sub>p"
     proof fix x
       assume A: "x \<in> univ_basic_semialg_set (2::nat) P"
       then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> (P \<bullet> x) = (y[^](2::nat))"
         unfolding univ_basic_semialg_set_def
         by blast
       have x_car: "x \<in> carrier Q\<^sub>p"
         using A
         by (metis (no_types, lifting) mem_Collect_eq univ_basic_semialg_set_def)
       have 0: "(P \<bullet> x) = (\<pp>[^](3::nat)) \<otimes> (x[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<one>"
         using P_def x_car UPQ.UP_one_closed UPQ.monom_closed UPQ.monom_rep_X_pow UPQ.to_fun_monom
           UPQ.to_fun_one UPQ.to_fun_plus p_natpow_closed(1) by presburger
       have 1: "y \<in> carrier Q\<^sub>p \<and> (\<pp>[^](3::nat)) \<otimes> (x[^](4::nat)) \<oplus>\<^bsub>Q\<^sub>p\<^esub> \<one> = (y[^](2::nat))"
         using "0" y_def
         by blast
       then show "x \<in> \<O>\<^sub>p"
         using x_car Qp_val_ring_alt_def[of x] y_def
         by (metis Qp.add.m_comm Qp.one_closed local.monom_term_car p_natpow_closed(1))
     qed
   qed
   show ?thesis
     using 0 1 that
     by blast
 qed
 
 lemma Qp_val_ring_is_univ_semialgebraic:
 "is_univ_semialgebraic \<O>\<^sub>p"
 proof-
   obtain P where "P \<in> carrier Q\<^sub>p_x \<and> \<O>\<^sub>p = univ_basic_semialg_set 2 P"
     using Qp_val_ring_is_semialg by blast
   then show ?thesis
     by (metis univ_basic_semialg_set_is_univ_semialgebraic zero_neq_numeral)
 qed
 
 lemma Qp_val_ring_is_semialgebraic:
 "is_semialgebraic 1 (to_R1` \<O>\<^sub>p)"
   using Qp_val_ring_is_univ_semialgebraic is_univ_semialgebraic_def by blast
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Inverse Images of Semialgebraic Sets by Polynomial Maps\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 lemma basic_semialg_pullback:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>k\<^esub>])"
   assumes "is_poly_tuple n fs"
   assumes "length fs = k"
   assumes "S = basic_semialg_set k m f"
   assumes "m  \<noteq>0"
   shows "poly_map n fs  \<inverse>\<^bsub>n\<^esub> S = basic_semialg_set n m (Qp_poly_comp n fs f)"
 proof
   show "poly_map n fs  \<inverse>\<^bsub>n\<^esub> S \<subseteq> basic_semialg_set n m (Qp_poly_comp n fs f)"
   proof
     fix x
     assume A: "x \<in> poly_map n fs  \<inverse>\<^bsub>n\<^esub> S"
     then have 0: "poly_map n fs x \<in> S"
     proof -
       have "\<exists>n f. {rs. rs \<in> S} \<subseteq> {rs \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). \<exists>r. r \<in> carrier Q\<^sub>p \<and> Qp_ev f rs = (r[^](n::nat))}"
         by (metis (no_types) Collect_mem_eq \<open>S = basic_semialg_set k m f\<close> basic_semialg_set_def eq_iff)
       then show ?thesis
         using A by blast
     qed
     have 1: "x \<in> carrier  (Q\<^sub>p\<^bsup>n\<^esup>)"
       using A assms
       by (meson evimage_eq)
     have "\<exists>y \<in> (carrier Q\<^sub>p). Qp_ev f (poly_map n fs x) = (y[^]m)"
       using A 0 assms basic_semialg_set_def
       by blast
     then have "\<exists>y \<in> (carrier Q\<^sub>p). Qp_ev (Qp_poly_comp n fs f) x = (y[^]m)"
       using 1 assms Qp_poly_comp_eval
       by blast
     then show "x \<in> basic_semialg_set n m (Qp_poly_comp n fs f)"
       using "1" basic_semialg_set_def
       by blast
   qed
   show "basic_semialg_set n m (Qp_poly_comp n fs f) \<subseteq> poly_map n fs  \<inverse>\<^bsub>n\<^esub> S"
   proof fix x
     assume A: "x \<in> basic_semialg_set n m (Qp_poly_comp n fs f)"
     have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       using A basic_semialg_set_def
       by blast
     have 1: "(poly_map n fs x) \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
       using "0" poly_map_closed assms(2) assms(3)  by blast
     show "x \<in> poly_map n fs  \<inverse>\<^bsub>n\<^esub> S"
     proof-
       have "\<exists>y \<in> carrier Q\<^sub>p. Qp_ev (Qp_poly_comp n fs f) x = (y[^]m)"
         using A basic_semialg_set_def
         by blast
       then have 2: "\<exists>y \<in> carrier Q\<^sub>p. Qp_ev f (poly_map n fs x) = (y[^]m)"
         using assms Qp_poly_comp_eval
         by (metis (no_types, lifting) A basic_semialg_set_def mem_Collect_eq)
       have 3: "poly_map n fs x \<in> S"
         using assms 0 1 basic_semialg_set_def[of k m f] "2"
         by blast
       show ?thesis
         using "0" "3" by blast
     qed
   qed
 qed
 
 lemma basic_semialg_pullback':
   assumes "is_poly_tuple n fs"
   assumes "length fs = k"
   assumes "A \<in> basic_semialgs k"
   shows "poly_map n fs  \<inverse>\<^bsub>n\<^esub> A \<in> (basic_semialgs n)"
 proof-
   obtain f m where fm_def: "m \<noteq>0 \<and>f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>k\<^esub>]) \<and> A = basic_semialg_set k m f"
     using assms
     by (metis is_basic_semialg_def mem_Collect_eq)
   then have "poly_map n fs  \<inverse>\<^bsub>n\<^esub> A  = basic_semialg_set n m (Qp_poly_comp n fs f)"
     using assms basic_semialg_pullback[of f k n fs A m]
     by linarith
   then show ?thesis unfolding is_basic_semialg_def
     by (metis (mono_tags, lifting) assms(1) assms(2) fm_def mem_Collect_eq poly_compose_closed)
 qed
 
 lemma semialg_pullback:
   assumes "is_poly_tuple n fs"
   assumes "length fs = k"
   assumes "S \<in> semialg_sets k"
   shows "poly_map n fs  \<inverse>\<^bsub>n\<^esub> S \<in> semialg_sets n"
   unfolding semialg_sets_def
   apply(rule gen_boolean_algebra.induct[of S "(carrier (Q\<^sub>p\<^bsup>k\<^esup>))" "basic_semialgs k"])
   using assms semialg_sets_def apply blast
   apply (metis assms(1) assms(2) carrier_is_semialgebraic evimageI2 extensional_vimage_closed is_semialgebraicE poly_map_closed semialg_sets_def subsetI subset_antisym)
   apply (metis Int_absorb2 assms(1) assms(2) basic_semialg_is_semialg basic_semialg_is_semialgebraic basic_semialg_pullback' is_semialgebraic_closed mem_Collect_eq semialg_sets_def)
   apply (metis evimage_Un semialg_sets_def semialg_union)
   by (metis assms(1) assms(2) carrier_is_semialgebraic diff_is_semialgebraic evimage_Diff extensional_vimage_closed is_semialgebraicE is_semialgebraicI poly_map_closed poly_map_pullbackI semialg_sets_def subsetI subset_antisym)
 
 lemma pullback_is_semialg:
   assumes "is_poly_tuple n fs"
   assumes "length fs = k"
   assumes "S \<in> semialg_sets k"
   shows "is_semialgebraic n (poly_map n fs  \<inverse>\<^bsub>n\<^esub> S)"
   using assms(1) assms(2) assms(3)  is_semialgebraicI padic_fields_axioms semialg_pullback
   by blast
 
 text\<open>Equality and inequality sets for a pair of polynomials\<close>
 
 definition val_ineq_set where
 "val_ineq_set n f g = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)}"
 
 lemma poly_map_length :
   assumes "length fs = m"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "length (poly_map n fs as) = m"
   using assms unfolding poly_map_def poly_tuple_eval_def
   by (metis (no_types, lifting) length_map restrict_apply')
 
 lemma val_ineq_set_pullback:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "val_ineq_set n f g = poly_map n [g,f] \<inverse>\<^bsub>n\<^esub> val_relation_set "
 proof
   show "val_ineq_set n f g \<subseteq> poly_map n [g,f]  \<inverse>\<^bsub>n\<^esub> val_relation_set"
   proof
     fix x
     assume "x \<in> val_ineq_set n f g"
     then have 0: "x \<in>  carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> val (Qp_ev f x) \<le> val (Qp_ev g x)"
       by (metis (mono_tags, lifting) mem_Collect_eq val_ineq_set_def)
     have 1: "poly_map n [g,f] x = [Qp_ev g x, Qp_ev f x]"
       unfolding  poly_map_def poly_tuple_eval_def  using 0
       by (metis (no_types, lifting) Cons_eq_map_conv list.simps(8) restrict_apply')
     have 2: "poly_map n [g,f] x \<in> val_relation_set"
       apply(rule val_relation_setI)
       using 1 0 assms  apply (metis eval_at_point_closed nth_Cons_0)
       using 1 0 assms  apply (metis One_nat_def eval_at_point_closed diff_Suc_1 less_numeral_extra(1) nth_Cons_pos Qp.to_R_to_R1)
       using poly_map_length assms 0  apply (metis "1" Qp_2I cartesian_power_car_memE eval_at_point_closed)
       by (metis "0" "1" One_nat_def nth_Cons_0 nth_Cons_Suc)
     have 3: "is_poly_tuple n [g, f]"
       using assms
       by (smt One_nat_def diff_Suc_1 Qp_is_poly_tupleI length_Suc_conv less_SucE less_one list.size(3) nth_Cons')
     then show "x \<in> poly_map n [g,f]  \<inverse>\<^bsub>n\<^esub> val_relation_set"
       using 0 1 2
       by blast
   qed
   show "poly_map n [g,f] \<inverse>\<^bsub>n\<^esub> val_relation_set \<subseteq> val_ineq_set n f g"
   proof fix x
     have 0: "is_poly_tuple n [g, f]"
       using Qp_is_poly_tupleI assms
       by (metis (no_types, lifting) diff_Suc_1 length_Cons less_Suc0 less_SucE list.size(3) nth_Cons')
     assume A: "x \<in> poly_map n [g,f] \<inverse>\<^bsub>n\<^esub> val_relation_set"
     then have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> poly_map n [g,f] x \<in> val_relation_set"
       using 0
       by (meson evimageD extensional_vimage_closed subsetD)
     have 2: "poly_map n [g,f] x = [Qp_ev g x, Qp_ev f x]"
       by (metis "1" Qp_poly_mapE' length_0_conv poly_map_cons)
     show "x \<in> val_ineq_set n f g"
        using 0 1 2 unfolding val_ineq_set_def  val_relation_set_def
        by (metis (no_types, lifting) "1" list.inject mem_Collect_eq nth_Cons_0 poly_map_apply val_relation_setE)
    qed
 qed
 
 lemma val_ineq_set_is_semialg:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "val_ineq_set n f g \<in> semialg_sets n"
 proof-
   have 0: "val_relation_set \<in> semialg_sets 2"
     using val_relation_semialg basic_semialg_is_semialg'
     by (metis Qp_val_poly_closed zero_neq_numeral)
   show ?thesis using val_ineq_set_pullback semialg_pullback[of n "[g,f]" 2 "val_relation_set" ]
     by (metis (no_types, lifting) "0" assms(1) assms(2) diff_Suc_1 Qp_is_poly_tupleI
         length_Cons less_Suc0 less_SucE list.size(3) nth_Cons_0 nth_Cons_pos numeral_2_eq_2
         zero_neq_numeral)
 qed
 
 lemma val_ineq_set_is_semialgebraic:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n (val_ineq_set n f g)"
   using assms(1) assms(2) is_semialgebraicI val_ineq_set_is_semialg by blast
 
 lemma val_ineq_setI:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "x \<in> (val_ineq_set n f g)"
   shows "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
         "val (Qp_ev f x) \<le> val (Qp_ev g x)"
   using assms unfolding val_ineq_set_def  apply blast
   using assms unfolding val_ineq_set_def by blast
 
 lemma val_ineq_setE:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes      "val (Qp_ev f x) \<le> val (Qp_ev g x)"
   shows "x \<in> (val_ineq_set n f g)"
   using assms unfolding val_ineq_set_def
   by blast
 
 lemma val_ineq_set_is_semialgebraic':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)}"
   using assms val_ineq_set_is_semialgebraic unfolding val_ineq_set_def by blast
 
 lemma val_eq_set_is_semialgebraic:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = val (Qp_ev g x)}"
 proof-
   have 0: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)}"
     using assms val_ineq_set_is_semialgebraic unfolding val_ineq_set_def
     by blast
   have 1: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) \<le> val (Qp_ev f x)}"
     using assms val_ineq_set_is_semialgebraic unfolding val_ineq_set_def
     by blast
   have 2: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = val (Qp_ev g x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)} \<inter>
                                                    {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) \<le>  val (Qp_ev f x)}"
     apply(rule equalityI, rule  subsetI , rule IntI) unfolding mem_Collect_eq
     using le_less apply blast apply (metis order_refl)
     apply(rule  subsetI, erule IntE) unfolding mem_Collect_eq
     by (meson less_le_trans not_less_iff_gr_or_eq)
   show ?thesis unfolding 2 apply(rule intersection_is_semialg)
     using 0 apply blast using 1 by blast
 qed
 
 lemma equalityI'':
   assumes "\<And>x. A x \<Longrightarrow> B x"
   assumes "\<And>x. B x \<Longrightarrow> A x"
   shows "{x. A x} = {x. B x}"
   using assms by blast
 
 lemma val_strict_ineq_set_is_semialgebraic:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) < val (Qp_ev g x)}"
 proof-
   have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) < val (Qp_ev g x)} =
              {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)} - {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = val (Qp_ev g x)}"
     apply(rule equalityI', rule DiffI) unfolding le_less mem_Collect_eq  apply blast
     unfolding mem_Collect_eq using neq_iff apply blast
     apply(erule DiffE) unfolding mem_Collect_eq by blast
   show ?thesis unfolding 0
     apply(rule diff_is_semialgebraic)
     using assms val_ineq_set_is_semialgebraic[of f n g] unfolding val_ineq_set_def apply blast
     using assms val_eq_set_is_semialgebraic[of f n g] unfolding val_ineq_set_def by blast
 qed
 
 lemma constant_poly_val_exists:
   shows "\<exists>g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]). (\<forall> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) = c)"
 proof-
   obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> val a = c"
     by (meson Qp.minus_closed Qp.nonzero_closed dist_nonempty' p_nonzero)
   obtain g where g_def: "g = coord_const a"
     by blast
   show ?thesis using a_def g_def Qp_to_IP_car
     by (metis (no_types, opaque_lifting) Qp_to_IP_car a_def eval_at_point_const g_def le_less subset_iff)
 qed
 
 lemma val_ineq_set_is_semialgebraic'':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> c}"
 proof-
   obtain g where g_def: "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> (\<forall> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) = c)"
     using constant_poly_val_exists by blast
   have 0: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)}"
     apply(rule val_ineq_set_is_semialgebraic')
     using assms apply blast using  g_def by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> val (Qp_ev g x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) \<le> c}"
     apply(rule equalityI'') using g_def apply fastforce using g_def by fastforce
   show ?thesis using 0 unfolding 1 by blast
 qed
 
 lemma val_ineq_set_is_semialgebraic''':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). c \<le> val (Qp_ev f x)}"
 proof-
   obtain g where g_def: "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> (\<forall> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) = c)"
     using constant_poly_val_exists by blast
   have 0: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) \<le> val (Qp_ev f x)}"
     apply(rule val_ineq_set_is_semialgebraic')
      using  g_def apply blast using assms by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) \<le> val (Qp_ev f x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>).  c \<le> val (Qp_ev f x)}"
     apply(rule equalityI'') using g_def apply fastforce using g_def by fastforce
   show ?thesis using 0 unfolding 1 by blast
 qed
 
 lemma val_eq_set_is_semialgebraic':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = c}"
 proof-
   obtain g where g_def: "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> (\<forall> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) = c)"
     using constant_poly_val_exists by blast
   have 0: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = val (Qp_ev g x)}"
     apply(rule val_eq_set_is_semialgebraic)
     using assms apply blast using  g_def by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = val (Qp_ev g x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) = c}"
     apply(rule equalityI'') using g_def apply fastforce using g_def by metis
   show ?thesis using 0 unfolding 1 by blast
 qed
 
 lemma val_strict_ineq_set_is_semialgebraic':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) < c}"
 proof-
   obtain g where g_def: "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> (\<forall> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) = c)"
     using constant_poly_val_exists by blast
   have 0: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) < val (Qp_ev g x)}"
     apply(rule val_strict_ineq_set_is_semialgebraic)
     using assms apply blast using  g_def by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) < val (Qp_ev g x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev f x) < c}"
     apply(rule equalityI'') using g_def apply fastforce using g_def
     by fastforce
   show ?thesis using 0 g_def unfolding 1
     by blast
 qed
 
 lemma val_strict_ineq_set_is_semialgebraic'':
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). c < val (Qp_ev f x)}"
 proof-
   obtain g where g_def: "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> (\<forall> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) = c)"
     using constant_poly_val_exists by blast
   have 0: "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>).  val (Qp_ev g x) < val (Qp_ev f x)}"
     apply(rule val_strict_ineq_set_is_semialgebraic)
     using   g_def apply blast using assms  by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). val (Qp_ev g x) < val (Qp_ev f x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). c < val (Qp_ev f x)}"
     apply(rule equalityI'') using assms g_def apply fastforce using assms g_def by fastforce
   show ?thesis using 0 g_def unfolding 1
     by blast
 qed
 
 lemma(in cring) R1_memE:
   assumes "x \<in> carrier (R\<^bsup>1\<^esup>)"
   shows "x = [(hd x)]"
   using assms cartesian_power_car_memE
   by (metis diff_is_0_eq' hd_conv_nth le_eq_less_or_eq length_0_conv length_tl list.exhaust list.sel(3) normalize.cases nth_Cons_0 zero_neq_one)
 
 lemma(in cring) R1_memE':
  assumes "x \<in> carrier (R\<^bsup>1\<^esup>)"
  shows "hd x \<in> carrier R"
   using R1_memE assms cartesian_power_car_memE[of x R 1] cartesian_power_car_memE'[of x R 1 0]
   by (metis hd_conv_nth less_numeral_extra(1) list.size(3) zero_neq_one)
 
 lemma univ_val_ineq_set_is_univ_semialgebraic:
 "is_univ_semialgebraic {x \<in> carrier Q\<^sub>p. val x \<le> c}"
 proof-
   have 0: "is_semialgebraic 1 {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (Qp_ev (pvar Q\<^sub>p 0) x) \<le> c}"
     apply(rule val_ineq_set_is_semialgebraic'')
     using pvar_closed by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (Qp_ev (pvar Q\<^sub>p 0) x) \<le> c} = to_R1 ` {x \<in> carrier Q\<^sub>p. val x \<le> c}"
   proof(rule equalityI')
     show " \<And>x. x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) \<le> c} \<Longrightarrow> x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x \<le> c}"
     proof- fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) \<le> c}"
       then have 0: "x = [(hd x)] \<and> hd x \<in> carrier Q\<^sub>p"
         using Qp.R1_memE Qp.R1_memE' by blast
       have 1: "eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0) = hd x"
         using A 0
         by (metis (no_types, lifting) One_nat_def eval_pvar lessI nth_Cons_0 Qp.to_R1_closed)
       then show "x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x \<le> c}"
         using A 0 unfolding mem_Collect_eq
         by (metis (no_types, lifting) image_iff mem_Collect_eq)
     qed
     show "\<And>x. x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x \<le> c} \<Longrightarrow> x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) \<le> c}"
     proof fix x assume A: "x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x \<le> c} "
       then obtain a where a_def: "x = [a] \<and> a \<in> carrier Q\<^sub>p \<and> val a \<le> c"
         by blast
       then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using cartesian_power_car_memI Qp.to_R1_closed by presburger
       then have 1: "(eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = a"
         using a_def  by (metis eval_pvar less_one Qp.to_R_to_R1)
       show "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>) \<and> val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) \<le> c"
         unfolding 1 using a_def 0 by blast
     qed
   qed
   show ?thesis using 0 unfolding 1
     using is_univ_semialgebraicI by blast
 qed
 
 lemma univ_val_strict_ineq_set_is_univ_semialgebraic:
 "is_univ_semialgebraic {x \<in> carrier Q\<^sub>p. val x < c}"
 proof-
   have 0: "is_semialgebraic 1 {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (Qp_ev (pvar Q\<^sub>p 0) x) <c}"
     apply(rule val_strict_ineq_set_is_semialgebraic')
     using pvar_closed by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (Qp_ev (pvar Q\<^sub>p 0) x) < c} = to_R1 ` {x \<in> carrier Q\<^sub>p. val x < c}"
   proof(rule equalityI')
     show " \<And>x. x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) < c} \<Longrightarrow> x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x < c}"
     proof- fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) < c}"
       then have 0: "x = [(hd x)] \<and> hd x \<in> carrier Q\<^sub>p"
         using Qp.R1_memE Qp.R1_memE' by blast
       have 1: "eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0) = hd x"
         using A 0
         by (metis (no_types, lifting) One_nat_def eval_pvar lessI nth_Cons_0 Qp.to_R1_closed)
       then show "x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x < c}"
         using A 0 unfolding mem_Collect_eq
         by (metis (no_types, lifting) image_iff mem_Collect_eq)
     qed
     show "\<And>x. x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x < c} \<Longrightarrow> x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) < c}"
     proof fix x assume A: "x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x < c} "
       then obtain a where a_def: "x = [a] \<and> a \<in> carrier Q\<^sub>p \<and> val a < c"
         by blast
       then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using cartesian_power_car_memI Qp.to_R1_closed by presburger
       then have 1: "(eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = a"
         using a_def  by (metis eval_pvar less_one Qp.to_R_to_R1)
       show "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>) \<and> val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) < c"
         unfolding 1 using a_def 0 by blast
     qed
   qed
   show ?thesis using 0 unfolding 1
     using is_univ_semialgebraicI by blast
 qed
 
 lemma univ_val_eq_set_is_univ_semialgebraic:
 "is_univ_semialgebraic {x \<in> carrier Q\<^sub>p. val x = c}"
 proof-
   have 0: "is_semialgebraic 1 {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (Qp_ev (pvar Q\<^sub>p 0) x) = c}"
     apply(rule val_eq_set_is_semialgebraic')
     using pvar_closed by blast
   have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (Qp_ev (pvar Q\<^sub>p 0) x) = c} = to_R1 ` {x \<in> carrier Q\<^sub>p. val x = c}"
   proof(rule equalityI')
     show " \<And>x. x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = c} \<Longrightarrow> x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x = c}"
     proof- fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = c}"
       then have 0: "x = [(hd x)] \<and> hd x \<in> carrier Q\<^sub>p"
         using Qp.R1_memE Qp.R1_memE' by blast
       have 1: "eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0) = hd x"
         using A 0
         by (metis (no_types, lifting) One_nat_def eval_pvar lessI nth_Cons_0 Qp.to_R1_closed)
       show "x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x = c}"
         using A 0 unfolding mem_Collect_eq 1 by blast
     qed
     show "\<And>x. x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x = c} \<Longrightarrow> x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>). val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = c}"
     proof fix x assume A: "x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. val x = c} "
       then obtain a where a_def: "x = [a] \<and> a \<in> carrier Q\<^sub>p \<and> val a = c"
         by blast
       then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using cartesian_power_car_memI Qp.to_R1_closed by presburger
       then have 1: "(eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = a"
         using a_def  by (metis eval_pvar less_one Qp.to_R_to_R1)
       show "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>) \<and> val (eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0)) = c"
         unfolding 1 using a_def 0 by blast
     qed
   qed
   show ?thesis using 0 unfolding 1
     using is_univ_semialgebraicI by blast
 qed
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>One Dimensional $p$-adic Balls are Semialgebraic\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 lemma coord_ring_one_def:
 "Pring Q\<^sub>p {(0::nat)} = (Q\<^sub>p[\<X>\<^bsub>1\<^esub>])"
 proof-
   have "{(0::nat)} = {..<1}"
     by auto
   thus ?thesis
   unfolding coord_ring_def
   by auto
 qed
 
 lemma times_p_pow_val:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b = \<pp>[^]n \<otimes> a"
   shows "val b = val a + n"
   using  val_mult[of "\<pp>[^]n" a] assms unfolding assms(2) val_p_int_pow
   by (metis add.commute p_intpow_closed(1))
 
 lemma times_p_pow_neg_val:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b = \<pp>[^]-n \<otimes> a"
   shows "val b = val a - n"
   by (metis Qp.m_comm Qp_int_pow_nonzero assms(1) assms(2) p_intpow_closed(1) p_intpow_inv'' p_nonzero val_fract val_p_int_pow)
 
 lemma eint_minus_int_pos:
   assumes "a - eint n \<ge> 0"
   shows "a \<ge> n"
   using assms apply(induction a)
   apply (metis diff_ge_0_iff_ge eint_ord_simps(1) idiff_eint_eint zero_eint_def)
   by simp
 
 text\<open>\<open>p\<close>-adic balls as pullbacks of polynomial maps\<close>
 
 lemma balls_as_pullbacks:
   assumes "c \<in> carrier Q\<^sub>p"
   shows "\<exists>P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1\<^esub>]). to_R1` B\<^bsub>n\<^esub>[c] = poly_map 1 [P]  \<inverse>\<^bsub>1\<^esub> (to_R1 ` \<O>\<^sub>p)"
 proof-
   obtain P0 where P0_def: "P0 = (to_poly (\<pp>[^](-n))) \<otimes>\<^bsub>Q\<^sub>p_x\<^esub>((X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c)"
     by blast
   have 0: "P0 \<in> carrier Q\<^sub>p_x"
   proof-
     have P0: "(X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c \<in> carrier Q\<^sub>p_x"
       using UPQ.X_closed UPQ.to_poly_closed assms by blast
     have P1: "(to_poly (\<pp>[^](-n))) \<in> carrier Q\<^sub>p_x"
       using UPQ.to_poly_closed p_intpow_closed(1) by blast
     then show ?thesis
       using P0_def P0 P1
       by blast
   qed
   have 1: "\<And>x. x \<in> carrier Q\<^sub>p \<Longrightarrow> P0 \<bullet> x = (\<pp>[^](-n)) \<otimes>  (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> c)"
   proof- fix x assume A: "x \<in> carrier Q\<^sub>p"
     have P0: "(to_poly (\<pp>[^](-n))) \<bullet> x = (\<pp>[^](-n))"
       using A UPQ.to_fun_to_poly p_intpow_closed(1) by blast
     have P1: "((X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c) \<bullet> x =  (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> c)"
       by (metis A UPQ.to_fun_X_minus X_poly_minus_def assms)
     have P2: "to_poly (\<pp>[^](-n)) \<in> carrier Q\<^sub>p_x"
       using UPQ.to_poly_closed p_intpow_closed(1) by blast
     have P3: "((X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c) \<in> carrier Q\<^sub>p_x"
       using UPQ.X_closed UPQ.to_poly_closed assms by blast
     have "to_poly (\<pp>[^]- n) \<otimes>\<^bsub>Q\<^sub>p_x\<^esub> ((X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c) \<bullet> x = to_poly (\<pp>[^]- n) \<bullet> x \<otimes> (((X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c) \<bullet> x)"
       using A P0_def P0 P1 P2 P3 to_fun_mult[of "to_poly (\<pp>[^](-n))" "(X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c" x] UPQ.to_fun_mult
       by blast
     then have "to_poly (\<pp>[^]- n) \<otimes>\<^bsub>Q\<^sub>p_x\<^esub> ((X_poly Q\<^sub>p) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> to_poly c) \<bullet> x = (\<pp>[^](-n)) \<otimes>  (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> c) "
       by (metis P0 P1)
     then show "P0 \<bullet> x = (\<pp>[^](-n)) \<otimes>  (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> c)"
       using P0_def by metis
   qed
   have 2: " (\<lambda>a. [a]) ` B\<^bsub>n\<^esub>[c] = poly_map 1  [from_Qp_x P0]  \<inverse>\<^bsub>1\<^esub>  ((\<lambda>a. [a]) ` \<O>\<^sub>p)"
   proof
     show "(\<lambda>a. [a]) ` B\<^bsub>n\<^esub>[c] \<subseteq> poly_map 1  [from_Qp_x P0]  \<inverse>\<^bsub>1\<^esub>  ((\<lambda>a. [a]) ` \<O>\<^sub>p)"
     proof
       fix x
       assume A: "x \<in> (\<lambda>a. [a]) ` B\<^bsub>n\<^esub>[c]"
       then obtain a where a_def: "x = [a] \<and> a \<in> B\<^bsub>n\<^esub>[c]"
         by blast
       have P0: "P0 \<bullet> a \<in> \<O>\<^sub>p"
       proof-
         have "B\<^bsub>n\<^esub>[c] \<subseteq> carrier Q\<^sub>p"
           using c_ball_in_Qp by blast
         hence a_closed: "a \<in> carrier Q\<^sub>p"
           using a_def by blast
         have P0: "P0 \<bullet> a = (\<pp>[^](-n)) \<otimes>  (a \<ominus> c)"
           using 1 a_def c_ballE(1)
           by blast
         then have P1: "val (P0 \<bullet> a) = val (\<pp>[^](-n)) + val (a \<ominus> c)"
           using val_mult[of "\<pp>[^]-n" "a \<ominus> c"] a_closed assms Qp.minus_closed p_intpow_closed(1)
           by presburger
          then have P2: "val (P0 \<bullet> a) = val (a \<ominus>\<^bsub>Q\<^sub>p\<^esub> c) - n"
            by (metis P0 Qp.m_comm Qp.minus_closed Qp_int_pow_nonzero assms local.a_closed
                p_intpow_closed(1) p_intpow_inv'' p_nonzero val_fract val_p_int_pow)
          have P3: "val (a \<ominus>\<^bsub>Q\<^sub>p\<^esub> c) \<ge> n"
            using a_def c_ballE(2)
            by blast
          then have "val (P0 \<bullet> a) \<ge> -n + n"
            using P2 by (metis add.commute diff_conv_add_uminus diff_self local.eint_minus_ineq' zero_eint_def)
          then have P4: "val (P0 \<bullet> a) \<ge> 0"
            by (metis add.commute add.right_inverse zero_eint_def)
          have P5: "P0 \<bullet> a \<in> carrier Q\<^sub>p"
            using "0" UPQ.to_fun_closed local.a_closed by blast
          then show ?thesis using P4
            using val_ring_val_criterion
            by blast
       qed
       have "poly_map 1 [from_Qp_x P0] x = [Qp_ev (from_Qp_x P0) [a]] "
         using a_def poly_map_def[of 1 "[from_Qp_x P0]"] poly_tuple_eval_def[of ]
         by (metis Qp_poly_mapE' c_ballE(1) length_0_conv poly_map_cons Qp.to_R1_closed)
       then have "poly_map 1 [from_Qp_x P0] x = [P0 \<bullet> a] "
         using Qp_x_Qp_poly_eval[of P0 a]
         by (metis "0" a_def c_ballE(1))
       then have P1: "poly_map 1 [from_Qp_x P0] x \<in> ((\<lambda>a. [a]) ` \<O>\<^sub>p)"
         using P0
         by blast
       have P2: "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using A c_ballE(1) Qp.to_R1_closed
         by blast
       have P3: "is_poly_tuple 1 [from_Qp_x P0]"
         apply(rule Qp_is_poly_tupleI)
         by (metis "0" Qp_is_poly_tupleI from_Qp_x_closed gr_implies_not0 is_poly_tupleE is_poly_tuple_Cons list.size(3) zero_neq_one)
       show "x \<in> poly_map 1 [UP_to_IP Q\<^sub>p 0 P0] \<inverse>\<^bsub>1\<^esub> (\<lambda>a. [a]) ` \<O>\<^sub>p"
         using P3 P2 P1 unfolding evimage_def poly_map_def
         by blast
     qed
     have 20: "is_poly_tuple 1 [from_Qp_x P0]"
       using 0 UP_to_IP_closed[of P0 "0::nat"]
       unfolding is_poly_tuple_def
       by (metis (no_types, lifting) empty_set from_Qp_x_closed list.simps(15) singletonD subset_code(1))
     show "poly_map 1 [UP_to_IP Q\<^sub>p 0 P0] \<inverse>\<^bsub>1\<^esub> (\<lambda>a. [a]) ` \<O>\<^sub>p \<subseteq> (\<lambda>a. [a]) ` B\<^bsub>n\<^esub>[c]"
     proof fix x assume A: "x \<in> poly_map 1 [UP_to_IP Q\<^sub>p 0 P0] \<inverse>\<^bsub>1\<^esub> ((\<lambda>a. [a]) ` \<O>\<^sub>p)"
       have A0: "(\<lambda>a. [a]) ` \<O>\<^sub>p \<subseteq> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using Qp_val_ring_is_univ_semialgebraic is_univ_semialgebraic_def Qp.to_R1_car_subset
               Qp_val_ring_is_semialgebraic is_semialgebraic_closed by presburger
       have "poly_map 1 [from_Qp_x P0] x \<in>  ((\<lambda>a. [a]) ` \<O>\<^sub>p)"
         using A0 A 20  by blast
       then obtain a where a_def:  "a \<in> \<O>\<^sub>p \<and> (poly_map 1 [from_Qp_x P0] x) = [a]"
         by blast
       have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using A
         by (meson evimage_eq)
       then obtain y where y_def: "x = [y] \<and> y \<in> carrier Q\<^sub>p"
         using A
         by (metis Qp.to_R1_to_R Qp.to_R_pow_closed)
       have "(poly_map 1 [from_Qp_x P0] x) = [(Qp_ev (from_Qp_x P0) [y])]"
         unfolding poly_map_def poly_tuple_eval_def using x_closed
         by (smt "20" One_nat_def length_Suc_conv list.size(3) nth_Cons_0 nth_map
             poly_tuple_eval_closed poly_tuple_eval_def restrict_apply' Qp.to_R1_to_R y_def zero_less_Suc)
       then have "(poly_map 1 [from_Qp_x P0] x) = [P0 \<bullet> y]"
         by (metis "0" Qp_x_Qp_poly_eval y_def)
       then have "[a] = [P0 \<bullet> y]"
         using a_def
         by presburger
       then have A1: "a =  (\<pp>[^](-n)) \<otimes>  (y \<ominus>\<^bsub>Q\<^sub>p\<^esub> c)"
         using 1[of y] y_def
         by blast
       have "y \<in> B\<^bsub>n\<^esub>[c]"
       proof-
         have B0: "val a =  val (y \<ominus>\<^bsub>Q\<^sub>p\<^esub> c) - n"
           using A1 y_def Qp.minus_closed assms times_p_pow_neg_val by blast
         have B1: "val a \<ge> 0"
           using a_def val_ring_memE by blast
         then have  "val (y \<ominus>\<^bsub>Q\<^sub>p\<^esub> c) - n \<ge> 0"
           using B0
           by metis
         then have  "val (y \<ominus>\<^bsub>Q\<^sub>p\<^esub> c) \<ge> n"
           using eint_minus_int_pos by blast
         then show "y \<in> B\<^bsub>n\<^esub>[c]"
           using c_ballI y_def by blast
       qed
       then show "x \<in> (\<lambda>a. [a]) ` B\<^bsub>n\<^esub>[c]"
         using y_def by blast
     qed
   qed
   then show ?thesis
     by (meson "0" from_Qp_x_closed)
 qed
 
 lemma ball_is_semialgebraic:
   assumes "c \<in> carrier Q\<^sub>p"
   shows "is_semialgebraic 1 (to_R1` B\<^bsub>n\<^esub>[c])"
 proof-
   obtain P where P_def: "P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1\<^esub>]) \<and> to_R1` B\<^bsub>n\<^esub>[c] = poly_map 1 [P]  \<inverse>\<^bsub>1\<^esub> (to_R1 ` \<O>\<^sub>p) "
     using assms balls_as_pullbacks[of c n] by meson
   have "is_poly_tuple 1 [P]"
     using P_def unfolding is_poly_tuple_def
     by (metis (no_types, opaque_lifting) list.inject list.set_cases neq_Nil_conv subset_code(1))
   then show ?thesis
     using assms P_def pullback_is_semialg[of 1 "[P]" 1 "((\<lambda>a. [a]) ` \<O>\<^sub>p) "]
     by (metis (mono_tags, lifting) One_nat_def
         Qp_val_ring_is_semialgebraic is_semialgebraic_def length_Suc_conv
         list.distinct(1) list.size(3))
 qed
 
 lemma ball_is_univ_semialgebraic:
   assumes "c \<in> carrier Q\<^sub>p"
   shows "is_univ_semialgebraic (B\<^bsub>n\<^esub>[c])"
   using assms ball_is_semialgebraic c_ball_in_Qp is_univ_semialgebraic_def
   by presburger
 
 abbreviation Qp_to_R1_set  where
 "Qp_to_R1_set S \<equiv> to_R1 ` S"
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Finite Unions and Intersections of Semialgebraic Sets\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 definition are_semialgebraic where
 "are_semialgebraic n Xs = (\<forall> x. x \<in> Xs \<longrightarrow> is_semialgebraic n x)"
 
 lemma are_semialgebraicI:
   assumes "\<And>x. x \<in> Xs \<Longrightarrow> is_semialgebraic n x "
   shows "are_semialgebraic n Xs"
   using are_semialgebraic_def assms by blast
 
 lemma are_semialgebraicE:
   assumes "are_semialgebraic n Xs"
   assumes "x \<in> Xs"
   shows "is_semialgebraic n x"
   using are_semialgebraic_def assms(1) assms(2) by blast
 
 definition are_univ_semialgebraic where
 "are_univ_semialgebraic Xs = (\<forall> x. x \<in> Xs \<longrightarrow> is_univ_semialgebraic x)"
 
 lemma are_univ_semialgebraicI:
   assumes "\<And>x. x \<in> Xs \<Longrightarrow> is_univ_semialgebraic x "
   shows "are_univ_semialgebraic Xs"
   using are_univ_semialgebraic_def assms by blast
 
 lemma are_univ_semialgebraicE:
   assumes "are_univ_semialgebraic Xs"
   assumes "x \<in> Xs"
   shows "is_univ_semialgebraic x"
   using are_univ_semialgebraic_def assms(1) assms(2) by blast
 
 lemma are_univ_semialgebraic_semialgebraic:
   assumes "are_univ_semialgebraic Xs"
   shows "are_semialgebraic 1 (Qp_to_R1_set ` Xs)"
   apply(rule  are_semialgebraicI)
   using  are_univ_semialgebraicE assms image_iff is_univ_semialgebraicE
   by (metis (no_types, lifting))
 
 lemma to_R1_set_union:
 "to_R1 ` (\<Union> Xs) = \<Union> (Qp_to_R1_set ` Xs)"
   using image_iff by blast
 
 lemma to_R1_inter:
   assumes "Xs \<noteq> {}"
   shows "to_R1 ` (\<Inter> Xs) = \<Inter> (Qp_to_R1_set ` Xs)"
 proof
   show "to_R1 ` (\<Inter> Xs)  \<subseteq> \<Inter> (Qp_to_R1_set ` Xs)"
     by blast
   show "\<Inter> (Qp_to_R1_set ` Xs) \<subseteq> to_R1 ` (\<Inter> Xs)"
   proof fix x
     assume  A: "x \<in> \<Inter> (Qp_to_R1_set ` Xs)"
     then have 0: "\<And>S. S \<in> Xs \<Longrightarrow> x \<in> (Qp_to_R1_set S)"
       by blast
     obtain S where "S \<in> Xs \<and> x \<in> (Qp_to_R1_set S)"
       using assms 0
       by blast
     then obtain b where b_def: "b \<in> S \<and> x = [b]"
       by blast
     have "b \<in> (\<Inter> Xs)"
       using "0" b_def by blast
     then show "x \<in> to_R1 ` (\<Inter> Xs)"
       using b_def by blast
   qed
 qed
 
 lemma finite_union_is_semialgebraic:
   assumes "finite Xs"
   shows "Xs \<subseteq> semialg_sets n \<longrightarrow> is_semialgebraic n (\<Union> Xs)"
   apply(rule finite.induct[of Xs])
     apply (simp add: assms)
   apply (simp add: empty_is_semialgebraic)
   by (metis Sup_insert insert_subset is_semialgebraicI union_is_semialgebraic)
 
 lemma finite_union_is_semialgebraic':
   assumes "finite Xs"
   assumes "Xs \<subseteq> semialg_sets n "
   shows "is_semialgebraic n (\<Union> Xs)"
   using assms(1) assms(2) finite_union_is_semialgebraic by blast
 
 lemma(in padic_fields) finite_union_is_semialgebraic'':
   assumes "finite S"
   assumes  "\<And>x. x \<in> S \<Longrightarrow> is_semialgebraic m (F x)"
   shows "is_semialgebraic m (\<Union> x \<in> S. F x)"
   using assms  finite_union_is_semialgebraic[of "F`S" m] unfolding is_semialgebraic_def
   by blast
 
 lemma finite_union_is_univ_semialgebraic':
   assumes "finite Xs"
   assumes "are_univ_semialgebraic Xs"
   shows "is_univ_semialgebraic (\<Union> Xs)"
 proof-
   have "is_semialgebraic 1 (Qp_to_R1_set (\<Union> Xs))"
     using assms finite_union_is_semialgebraic'[of "((`) (\<lambda>a. [a]) ` Xs)"] to_R1_set_union[of Xs]
     by (metis (no_types, lifting) are_semialgebraicE are_univ_semialgebraic_semialgebraic
         finite_imageI is_semialgebraicE subsetI)
   then show ?thesis
     using is_univ_semialgebraicI by blast
 qed
 
 lemma finite_intersection_is_semialgebraic:
   assumes "finite Xs"
   shows "Xs \<subseteq> semialg_sets n \<and> Xs \<noteq>{} \<longrightarrow> is_semialgebraic n (\<Inter> Xs)"
   apply(rule finite.induct[of Xs])
   apply (simp add: assms)
   apply auto[1]
 proof fix A::"((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set list set set" fix a
   assume 0: "finite A"
   assume 1: "A \<subseteq> semialg_sets n \<and> A \<noteq> {} \<longrightarrow> is_semialgebraic n (\<Inter> A) "
   assume 2: "insert a A \<subseteq> semialg_sets n \<and> insert a A \<noteq> {}"
   show "is_semialgebraic n (\<Inter> (insert a A))"
   proof(cases "A = {}")
     case True
     then have "insert a A = {a}"
       by simp
     then show ?thesis
       by (metis "2" cInf_singleton insert_subset is_semialgebraicI)
   next
     case False
     then have "A \<subseteq> semialg_sets n \<and> A \<noteq> {}"
       using "2" by blast
     then have "is_semialgebraic n (\<Inter> A) "
       using "1" by linarith
     then show ?thesis
       using 0 1 2 intersection_is_semialg
       by (metis Inf_insert insert_subset is_semialgebraicI)
   qed
 qed
 
 lemma finite_intersection_is_semialgebraic':
   assumes "finite Xs"
   assumes "Xs \<subseteq> semialg_sets n \<and> Xs \<noteq>{}"
   shows  " is_semialgebraic n (\<Inter> Xs)"
   by (simp add: assms(1) assms(2) finite_intersection_is_semialgebraic)
 
 lemma finite_intersection_is_semialgebraic'':
   assumes "finite Xs"
   assumes "are_semialgebraic n Xs \<and> Xs \<noteq>{}"
   shows  " is_semialgebraic n (\<Inter> Xs)"
   by (meson are_semialgebraicE assms(1) assms(2)
       finite_intersection_is_semialgebraic' is_semialgebraicE subsetI)
 
 lemma finite_intersection_is_univ_semialgebraic:
   assumes "finite Xs"
   assumes "are_univ_semialgebraic Xs"
   assumes "Xs \<noteq> {}"
   shows  "is_univ_semialgebraic (\<Inter> Xs)"
 proof-
   have "are_semialgebraic 1 (Qp_to_R1_set ` Xs)"
     using are_univ_semialgebraic_semialgebraic assms(2) by blast
   then have  "is_semialgebraic 1 (\<Inter> (Qp_to_R1_set ` Xs))"
     using assms finite_intersection_is_semialgebraic''[of "Qp_to_R1_set ` Xs" 1]
     by blast
   then  have "is_semialgebraic 1 (Qp_to_R1_set (\<Inter> Xs))"
     using assms  to_R1_inter[of Xs]
     by presburger
   then show ?thesis
     using is_univ_semialgebraicI by blast
 qed
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Cartesian Products of Semialgebraic Sets\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 lemma Qp_times_basic_semialg_right:
   assumes "a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) = basic_semialg_set (n+ m) k a"
 proof
   show "cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) \<subseteq> basic_semialg_set (n + m) k a"
   proof fix x
     assume "x \<in> cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>))"
     then obtain as bs where as_bs_def: "as \<in> (basic_semialg_set n k a) \<and> bs \<in> (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) \<and> x = as@bs"
       using cartesian_product_memE[of x "basic_semialg_set n k a" "carrier (Q\<^sub>p\<^bsup>m\<^esup>)" Q\<^sub>p n]
             basic_semialg_set_def
       by (metis (no_types, lifting) append_take_drop_id basic_semialg_set_memE(1) subsetI)
     have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n+m\<^esup>)"
       using as_bs_def basic_semialg_set_memE(1) cartesian_product_closed'
       by blast
     have 1: "(Qp_ev a x = Qp_ev a as)"
       using as_bs_def  poly_eval_cartesian_prod[of as n bs m a] assms basic_semialg_set_memE(1) by blast
     obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> (Qp_ev a as = (y[^]k))"
       using as_bs_def using basic_semialg_set_memE(2)[of as n k a] by blast
     show "x \<in> basic_semialg_set (n + m) k a"
       apply(rule basic_semialg_set_memI[of _ _ y])
         apply (simp add: "0")
        apply (simp add: y_def)
       using "1" y_def by blast
   qed
   show "basic_semialg_set (n + m) k a \<subseteq> cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>))"
   proof fix x
     assume A: "x \<in> basic_semialg_set (n + m) k a"
     have A0: "x \<in> carrier (Q\<^sub>p\<^bsup>n+m\<^esup>)"
       using A basic_semialg_set_memE(1) by blast
     have A1: "set x \<subseteq> carrier Q\<^sub>p"
       using A0
       by (metis (no_types, lifting) cartesian_power_car_memE cartesian_power_car_memE' in_set_conv_nth subsetI)
     have A2: "length x = n + m"
       using A0 cartesian_power_car_memE
       by blast
     obtain as where as_def: "as = take n x"
       by blast
     obtain bs where bs_def: "bs = drop n x"
       by blast
     have 0:  "x = as@bs"
       using A as_def bs_def
         by (metis append_take_drop_id)
       have 1: "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
         apply(rule cartesian_power_car_memI)
         using as_def A2
         apply (simp add: A2 min.absorb2)
         by (metis (no_types, lifting) A1 as_def dual_order.trans set_take_subset)
       have 2:  "bs \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
         apply(rule cartesian_power_car_memI)
         using bs_def A2
         apply (simp add: A2)
         by (metis A1 bs_def order.trans set_drop_subset)
       obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and>  Qp_ev a x = (y[^]k)"
         using basic_semialg_set_memE A by meson
       have 3: "as \<in> basic_semialg_set n k a"
         apply(rule basic_semialg_set_memI[of _ _ y])
           apply (simp add: "1")
         using \<open>y \<in> carrier Q\<^sub>p \<and> Qp_ev a x = (y[^]k)\<close> apply blast
         using y_def A 1 0 2 assms(1) poly_eval_cartesian_prod by blast
       show " x \<in> cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>))"
         using 3 2 "0"
         by (metis (mono_tags, lifting) as_def basic_semialg_set_memE(1) bs_def cartesian_product_memI subsetI)
     qed
 qed
 
 lemma Qp_times_basic_semialg_right_is_semialgebraic:
   assumes "k > 0"
   assumes "a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic (n + m) (cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)))"
 proof-
   have 0: "cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) = basic_semialg_set (n+ m) k a"
     using Qp_times_basic_semialg_right assms
     by presburger
   have 1: " a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n+m\<^esub>])"
     using assms poly_ring_car_mono'(2) by blast
   have 2: "is_semialgebraic (n + m) (basic_semialg_set (n + m) k a)"
     using  assms basic_semialg_is_semialgebraic'[of a "n+m" k "basic_semialg_set (n + m) k a"]
           "1" by blast
   show ?thesis
     using 0 2
     by metis
 qed
 
 lemma Qp_times_basic_semialg_right_is_semialgebraic':
   assumes "A \<in> basic_semialgs n"
   shows "is_semialgebraic (n + m) (cartesian_product A (carrier (Q\<^sub>p\<^bsup>m\<^esup>)))"
 proof-
   obtain k P where "k \<noteq> 0 \<and> P\<in>carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])\<and> A = basic_semialg_set n k P"
     using assms  is_basic_semialg_def
     by (metis mem_Collect_eq)
   then show ?thesis using
       Qp_times_basic_semialg_right_is_semialgebraic[of  k P]
     using assms(1) by blast
 qed
 
 lemma cartesian_product_memE':
   assumes "x \<in> cartesian_product A B"
   obtains a b where "a \<in> A \<and> b \<in> B \<and> x = a@b"
   using assms unfolding cartesian_product_def by blast
 
 lemma Qp_times_basic_semialg_left:
   assumes "a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialg_set n k a)  = basic_semialg_set (n+m) k (shift_vars n m a)"
 proof
   show "cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialg_set n k a) \<subseteq> basic_semialg_set (n + m) k (shift_vars n m a)"
   proof fix x
     assume A: "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialg_set n k a)"
     then obtain as bs where as_bs_def: "as \<in> (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) \<and> bs \<in> (basic_semialg_set n k a) \<and> x = as@bs "
      using cartesian_product_memE' by blast
     have 0: "Qp_ev (shift_vars n m a) x = Qp_ev a bs"
       using A as_bs_def assms shift_vars_eval[of a n as m bs ]
       by (metis (no_types, lifting) basic_semialg_set_memE(1))
     obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> Qp_ev a bs = (y[^]k)"
       using as_bs_def basic_semialg_set_memE(2)
       by blast
     have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n+m\<^esup>)"
       using A as_bs_def
       by (metis (no_types, lifting) add.commute basic_semialg_set_memE(1) cartesian_product_closed')
     show "x \<in> basic_semialg_set (n + m) k (shift_vars n m a)"
       apply(rule basic_semialg_set_memI[of _ _ y])
         apply (simp add: "1")
           using y_def apply blast
            using "0" y_def by blast
   qed
   show "basic_semialg_set (n + m) k (shift_vars n m a) \<subseteq> cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialg_set n k a) "
   proof fix x
     assume A: "x \<in> basic_semialg_set (n + m) k (shift_vars n m a)"
     then obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> Qp_ev (shift_vars n m a) x = (y[^]k)"
       using assms basic_semialg_set_memE[of x "n + m" k "shift_vars n m a"]
             shift_vars_closed[of a m] Qp.cring_axioms
       by blast
     have "x \<in> carrier (Q\<^sub>p\<^bsup>m+n\<^esup>)"
       using A basic_semialg_set_memE(1)
       by (metis add.commute)
     then have "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
       using cartesian_product_carrier by blast
     then obtain as bs where as_bs_def: "x = as@bs \<and> as \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> bs \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       by (meson cartesian_product_memE')
     have "bs \<in> (basic_semialg_set n k a)"
     apply(rule basic_semialg_set_memI[of _ _ y])
       using as_bs_def apply blast
        apply (simp add: y_def)
         using y_def shift_vars_eval[of a n as m bs ] as_bs_def assms(1)
         by metis
     then show "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialg_set n k a)"
       using as_bs_def unfolding cartesian_product_def
       by blast
   qed
 qed
 
 lemma Qp_times_basic_semialg_left_is_semialgebraic:
   assumes "k > 0"
   assumes "a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialg_set n k a))"
   using basic_semialg_is_semialgebraic'[of a "n+m" k] Qp_times_basic_semialg_left
   by (metis assms(1) assms(2) basic_semialg_is_semialgebraic is_basic_semialg_def neq0_conv shift_vars_closed)
 
 lemma Qp_times_basic_semialg_left_is_semialgebraic':
   assumes "A \<in> basic_semialgs n"
   shows "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) A)"
 proof-
   obtain k P where "k \<noteq> 0 \<and> P\<in>carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])\<and> A = basic_semialg_set n k P"
     using assms  is_basic_semialg_def
     by (metis mem_Collect_eq)
   then show ?thesis using
       Qp_times_basic_semialg_left_is_semialgebraic[of k P]
     using assms(1)  by blast
 qed
 
 lemma product_of_basic_semialgs_is_semialg:
   assumes "k > 0"
   assumes "l > 0"
   assumes "a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "b \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
   shows "is_semialgebraic (n + m) (cartesian_product (basic_semialg_set n k a) (basic_semialg_set m l b))"
 proof-
   have 0:  "cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) =  basic_semialg_set (n+ m) k a"
     using Qp_times_basic_semialg_right assms  by presburger
   have 1:  "cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialg_set m l b)  = basic_semialg_set (m + n) l (shift_vars m n b)"
     using Qp_times_basic_semialg_left assms by blast
   have 2: "(cartesian_product (basic_semialg_set n k a) (basic_semialg_set m l b)) =
                 cartesian_product (basic_semialg_set n k a) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) \<inter>
                  cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialg_set m l b)"
   proof-
     have 0: "basic_semialg_set n k a \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       using basic_semialg_set_memE(1) by blast
     have 1: "carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       by simp
     have 2: "carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       by simp
     have 3: "basic_semialg_set m l b \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       using basic_semialg_set_memE(1) by blast
     show ?thesis
       using 0 1 2 3 cartesian_product_intersection[of "(basic_semialg_set n k a)" Q\<^sub>p n
                                               "(carrier (Q\<^sub>p\<^bsup>m\<^esup>))" m
                                               "(carrier (Q\<^sub>p\<^bsup>n\<^esup>))" "(basic_semialg_set m l b)"]
       by (smt Collect_cong inf.absorb_iff1 inf.absorb_iff2)
   qed
   then show ?thesis
     using Qp_times_basic_semialg_left_is_semialgebraic
           Qp_times_basic_semialg_right_is_semialgebraic  assms
     by (metis (no_types, lifting) add.commute intersection_is_semialg)
 qed
 
 lemma product_of_basic_semialgs_is_semialg':
   assumes "A \<in> (basic_semialgs n)"
   assumes "B \<in> (basic_semialgs m)"
   shows "is_semialgebraic (n + m) (cartesian_product A B)"
 proof-
   obtain k a where ka_def: "k > 0 \<and> a \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) \<and> A = (basic_semialg_set n k a)"
     using assms
     by (metis is_basic_semialg_def mem_Collect_eq neq0_conv)
   obtain l b where lb_def: "l > 0 \<and> b \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>]) \<and> B = (basic_semialg_set m l b)"
     by (metis assms(2) gr_zeroI is_basic_semialg_def mem_Collect_eq)
   show ?thesis using ka_def lb_def assms product_of_basic_semialgs_is_semialg
   by blast
 qed
 
 lemma car_times_semialg_is_semialg:
   assumes "is_semialgebraic m B"
   shows "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) B)"
   apply(rule gen_boolean_algebra.induct[of B "carrier (Q\<^sub>p\<^bsup>m\<^esup>)""basic_semialgs m"])
   using assms is_semialgebraic_def semialg_sets_def apply blast
   apply (simp add: carrier_is_semialgebraic cartesian_product_carrier)
 proof-
   show "\<And>A. A \<in> basic_semialgs m \<Longrightarrow> is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (A \<inter> carrier (Q\<^sub>p\<^bsup>m\<^esup>)))"
   proof-
     fix A assume A: "A \<in> basic_semialgs m "
     then have " (A \<inter> carrier (Q\<^sub>p\<^bsup>m\<^esup>)) = A"
       by (metis basic_semialg_set_memE(1) inf_absorb1 is_basic_semialg_def mem_Collect_eq subsetI)
     then show "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (A \<inter> carrier (Q\<^sub>p\<^bsup>m\<^esup>)))"
       using add.commute[of n m] assms A
             Qp_times_basic_semialg_left_is_semialgebraic'
       by (simp add: \<open>n + m = m + n\<close>)
   qed
   show "\<And>A C. A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m) \<Longrightarrow>
            is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) A) \<Longrightarrow>
            C \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m) \<Longrightarrow>
            is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) C) \<Longrightarrow>
            is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (A \<union> C))"
   proof- fix A C assume A: " A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m)"
            "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) A)"
            "C \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m)"
           " is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) C)"
     then have B: "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) A \<union> cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) C)"
       using union_is_semialgebraic by blast
     show "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (A \<union> C))"
     proof-
       have 0: "A \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
         using A(1) gen_boolean_algebra_subset
         by blast
       have  1: " C \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
         using A(3) gen_boolean_algebra_subset
         by blast
       then show ?thesis using 0 A B
         using cartesian_product_binary_union_right[of A Q\<^sub>p m C "(carrier (Q\<^sub>p\<^bsup>n\<^esup>))"]
         unfolding is_semialgebraic_def semialg_sets_def
         by presburger
     qed
   qed
   show "\<And>A. A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m) \<Longrightarrow>
          is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) A) \<Longrightarrow>
          is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (carrier (Q\<^sub>p\<^bsup>m\<^esup>) - A))"
   proof- fix A assume A: "A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m)"
                       "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) A)"
     then have "A \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       using gen_boolean_algebra_subset
       by blast
     then show "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (carrier (Q\<^sub>p\<^bsup>m\<^esup>) - A))"
       using A cartesian_product_car_complement_right[of A Q\<^sub>p m n]
       unfolding is_semialgebraic_def semialg_sets_def
       by (metis (mono_tags, lifting) semialg_complement semialg_sets_def)
   qed
 qed
 
 lemma basic_semialg_times_semialg_is_semialg:
   assumes "A \<in> basic_semialgs n"
   assumes "is_semialgebraic m B"
   shows " is_semialgebraic (n + m) (cartesian_product A B)"
   apply(rule gen_boolean_algebra.induct[of B "carrier (Q\<^sub>p\<^bsup>m\<^esup>)""basic_semialgs m"])
   using assms(2) is_semialgebraic_def semialg_sets_def apply blast
   using Qp_times_basic_semialg_right_is_semialgebraic' assms(1) apply blast
   apply (metis assms(1) basic_semialg_is_semialgebraic inf.absorb1 is_semialgebraic_closed mem_Collect_eq product_of_basic_semialgs_is_semialg')
     apply (metis (no_types, lifting) cartesian_product_binary_union_right is_semialgebraicI is_semialgebraic_closed semialg_sets_def union_is_semialgebraic)
 proof-
   show "\<And>Aa. Aa \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m) \<Longrightarrow>
           is_semialgebraic (n + m) (cartesian_product A Aa) \<Longrightarrow> is_semialgebraic (n + m) (cartesian_product A (carrier (Q\<^sub>p\<^bsup>m\<^esup>) - Aa))"
    proof- fix B assume A:  "B \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) (basic_semialgs m)"
                          "is_semialgebraic (n + m) (cartesian_product A B)"
     show "is_semialgebraic (n + m) (cartesian_product A (carrier (Q\<^sub>p\<^bsup>m\<^esup>) - B))"
     using A assms cartesian_product_complement_right[of B Q\<^sub>p m A n] add.commute[of n m]
   proof -
    have f1: "\<forall>n B. \<not> is_semialgebraic n B \<or> B \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
      by (meson is_semialgebraic_closed)
    have "is_basic_semialg n A"
      using \<open>A \<in> {S. is_basic_semialg n S}\<close> by blast
    then have f2: "is_semialgebraic n A"
      using padic_fields.basic_semialg_is_semialgebraic padic_fields_axioms by blast
    have "B \<in> semialg_sets m"
      using \<open>B \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) {S. is_basic_semialg m S}\<close> semialg_sets_def by blast
    then have "is_semialgebraic m B"
      by (meson padic_fields.is_semialgebraicI padic_fields_axioms)
    then show ?thesis
      using f2 f1 by (metis (no_types) Qp_times_basic_semialg_right_is_semialgebraic' \<open>A \<in> {S. is_basic_semialg n S}\<close> \<open>\<lbrakk>B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>); A \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)\<rbrakk> \<Longrightarrow> cartesian_product A (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) - cartesian_product A B = cartesian_product A (carrier (Q\<^sub>p\<^bsup>m\<^esup>) - B)\<close> \<open>is_semialgebraic (n + m) (cartesian_product A B)\<close> diff_is_semialgebraic)
   qed
   qed
 qed
 
 text\<open>Semialgebraic sets are closed under cartesian products\<close>
 
 lemma cartesian_product_is_semialgebraic:
   assumes "is_semialgebraic n A"
   assumes "is_semialgebraic m B"
   shows "is_semialgebraic (n + m) (cartesian_product A B)"
   apply(rule gen_boolean_algebra.induct[of A "carrier (Q\<^sub>p\<^bsup>n\<^esup>)""basic_semialgs n"])
   using assms is_semialgebraicE semialg_sets_def apply blast
   using assms car_times_semialg_is_semialg  apply blast
   using assms basic_semialg_times_semialg_is_semialg
   apply (simp add: Int_absorb2 basic_semialg_is_semialgebraic is_semialgebraic_closed)
 proof-
   show "\<And>A C. A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n) \<Longrightarrow>
            is_semialgebraic (n + m) (cartesian_product A B) \<Longrightarrow>
            C \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n) \<Longrightarrow>
            is_semialgebraic (n + m) (cartesian_product C B) \<Longrightarrow> is_semialgebraic (n + m) (cartesian_product (A \<union> C) B)"
   proof- fix A C assume A: "A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n)"
                            "is_semialgebraic (n + m) (cartesian_product A B)"
                            "C \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n)"
                            "is_semialgebraic (n + m) (cartesian_product C B)"
     show "is_semialgebraic (n + m) (cartesian_product (A \<union> C) B)"
       using A cartesian_product_binary_union_left[of A Q\<^sub>p n C B]
       by (metis (no_types, lifting) gen_boolean_algebra_subset union_is_semialgebraic)
   qed
   show "\<And>A. A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n) \<Longrightarrow>
          is_semialgebraic (n + m) (cartesian_product A B) \<Longrightarrow> is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>) - A) B)"
   proof- fix A assume A: "A \<in> gen_boolean_algebra (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) (basic_semialgs n)"
                         "is_semialgebraic (n + m) (cartesian_product A B)"
     show "is_semialgebraic (n + m) (cartesian_product (carrier (Q\<^sub>p\<^bsup>n\<^esup>) - A) B)"
       using assms  A cartesian_product_complement_left[of A Q\<^sub>p n B m]
       unfolding is_semialgebraic_def semialg_sets_def
       by (metis car_times_semialg_is_semialg diff_is_semialgebraic is_semialgebraicE is_semialgebraicI
           is_semialgebraic_closed semialg_sets_def)
   qed
 qed
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>$N^{th}$ Power Residues\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 
 definition nth_root_poly where
 "nth_root_poly (n::nat) a = ((X_poly Q\<^sub>p) [^]\<^bsub>Q\<^sub>p_x\<^esub>  n) \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> (to_poly a)"
 
 lemma nth_root_poly_closed:
   assumes "a \<in> carrier Q\<^sub>p"
   shows "nth_root_poly n a \<in> carrier Q\<^sub>p_x"
   using assms unfolding nth_root_poly_def
   by (meson UPQ.P.minus_closed UPQ.P.nat_pow_closed UPQ.X_closed UPQ.to_poly_closed)
 
 lemma nth_root_poly_eval:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   shows "(nth_root_poly n a) \<bullet> b = (b[^]n) \<ominus>\<^bsub>Q\<^sub>p\<^esub> a"
   using assms unfolding nth_root_poly_def
   using UPQ.P.nat_pow_closed UPQ.X_closed UPQ.to_fun_X_pow UPQ.to_fun_diff UPQ.to_fun_to_poly UPQ.to_poly_closed by presburger
 
 text\<open>Hensel's lemma gives us this criterion for the existence of \<open>n\<close>-th roots\<close>
 
 lemma nth_root_poly_root:
   assumes "(n::nat) > 1"
   assumes "a \<in> \<O>\<^sub>p"
   assumes "a \<noteq> \<one>"
   assumes "val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> a) > 2* val ([n]\<cdot>\<one>)"
   shows "(\<exists> b \<in> \<O>\<^sub>p. ((b[^]n) = a))"
 proof-
   obtain \<alpha> where alpha_def: "\<alpha> \<in> carrier Z\<^sub>p \<and> \<iota> \<alpha> = a"
     using assms(2) by blast
   have 0: "\<alpha> \<in> carrier Z\<^sub>p"
     by (simp add: alpha_def)
   have 1: "\<alpha> \<noteq> \<one>\<^bsub>Z\<^sub>p\<^esub>"
     using assms alpha_def inc_of_one
     by blast
   obtain N where N_def: "N = [n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
     by blast
   have N_closed: "N \<in> carrier Z\<^sub>p"
     using N_def Zp_nat_mult_closed
     by blast
   have 2: "\<iota> ([n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) = ([n]\<cdot> \<one>)"
   proof(induction n)
     case 0
     have 00: "[(0::nat)] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
       using Zp_nat_inc_zero by blast
     have 01: "[(0::nat)] \<cdot>\<^bsub>Q\<^sub>p\<^esub> \<one> = \<zero>"
       using Qp.nat_inc_zero by blast
     then show ?case
       using 00 inc_of_nat by blast
   next
     case (Suc n)
     then show ?case
       using inc_of_nat by blast
   qed
   have 3: "val_Zp (\<one>\<^bsub>Z\<^sub>p\<^esub> \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>) = val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> a)"
     using alpha_def Zp.one_closed ring_hom_one[of \<iota> Z\<^sub>p Q\<^sub>p]  inc_is_hom Zp.ring_hom_minus[of Q\<^sub>p \<iota> "\<one>\<^bsub>Z\<^sub>p\<^esub>" \<alpha> ]
     Qp.ring_axioms
     unfolding \<iota>_def
     by (metis Q\<^sub>p_def Zp.minus_closed Zp_def padic_fields.val_of_inc padic_fields_axioms)
   have 4: "([n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) \<in> nonzero Z\<^sub>p"
   proof-
     have 40: "int n \<ge> 0"
       using of_nat_0_le_iff by blast
     have "nat (int n) = n"
       using nat_int by blast
     hence "[n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> = [int n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
       using 40  unfolding add_pow_def int_pow_def nat_pow_def
       proof -
         have "(if int n < 0 then inv\<^bsub>add_monoid Z\<^sub>p\<^esub> rec_nat \<one>\<^bsub>add_monoid Z\<^sub>p\<^esub> (\<lambda>n f. f \<otimes>\<^bsub>add_monoid Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) 0 else rec_nat \<one>\<^bsub>add_monoid Z\<^sub>p\<^esub> (\<lambda>n f. f \<otimes>\<^bsub>add_monoid Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) n) = rec_nat \<one>\<^bsub>add_monoid Z\<^sub>p\<^esub> (\<lambda>n f. f \<otimes>\<^bsub>add_monoid Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) n"
           by (meson of_nat_less_0_iff)
         then show "rec_nat \<one>\<^bsub>add_monoid Z\<^sub>p\<^esub> (\<lambda>n f. f \<otimes>\<^bsub>add_monoid Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) n = (let f = rec_nat \<one>\<^bsub>add_monoid Z\<^sub>p\<^esub> (\<lambda>n f. f \<otimes>\<^bsub>add_monoid Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) in if int n < 0 then inv\<^bsub>add_monoid Z\<^sub>p\<^esub> f (nat (- int n)) else f (nat (int n)))"
           using \<open>nat (int n) = n\<close> by presburger
       qed
       thus ?thesis
         using Zp_char_0[of n] Zp.not_nonzero_memE Zp_char_0' assms(1) gr_implies_not_zero by blast
     qed
   then have 5: "val_Zp ([n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) = val ([n]\<cdot>\<^bsub>Q\<^sub>p\<^esub> (\<one>))"
     using 2 ord_of_inc
     by (metis N_closed N_def val_of_inc)
   then have 6: "(val_Zp (\<one>\<^bsub>Z\<^sub>p\<^esub> \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>)) > 2*(val_Zp ([n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>))"
     using assms 3  by presburger
   have "\<exists> b \<in> carrier Z\<^sub>p. (b[^]\<^bsub>Z\<^sub>p\<^esub>n= \<alpha>)"
     using Zp_nth_root_lemma[of \<alpha> n] assms "0" "1" "6" by blast
   then obtain b where b_def: "b \<in> carrier Z\<^sub>p \<and>    (b[^]\<^bsub>Z\<^sub>p\<^esub>n= \<alpha>)"
     by blast
   then have "\<iota> (b [^]\<^bsub>Z\<^sub>p\<^esub>n) = a"
     using alpha_def by blast
   then have "(\<iota> b) [^] n = a"
     by (metis Qp.nat_inc_zero Q\<^sub>p_def Qp.nat_pow_zero Zp.nat_pow_0 Zp.nat_pow_zero
         Zp_nat_inc_zero \<iota>_def alpha_def assms(3) b_def frac_inc_of_nat inc_of_one inc_pow not_nonzero_Qp)
   then show ?thesis
     using b_def by blast
 qed
 
 text\<open>All points sufficiently close to 1 have nth roots\<close>
 
 lemma eint_nat_times_2:
 "2*(n::nat) = 2*eint n"
   using times_eint_simps(1)
   by (metis mult.commute mult_2_right of_nat_add)
 
 lemma P_set_of_one:
 "P_set 1 = nonzero Q\<^sub>p"
   apply(rule equalityI) apply(rule subsetI)
   unfolding P_set_def nonzero_def mem_Collect_eq  apply blast
   apply(rule subsetI)  unfolding P_set_def nonzero_def mem_Collect_eq
   using Qp.nat_pow_eone by blast
 
 lemma nth_power_fact:
   assumes "(n::nat) \<ge> 1"
   shows "\<exists> (m::nat) > 0. \<forall> u \<in> carrier Q\<^sub>p. ac m u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n"
 proof(cases "n = 1")
   case True
   have "\<forall> u \<in> carrier Q\<^sub>p. ac 1 u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n"
     unfolding True P_set_of_one
     by (metis iless_Suc_eq padic_fields.val_ring_memE padic_fields.zero_in_val_ring padic_fields_axioms val_nonzero zero_eint_def)
   then show ?thesis  by blast
 next
   case F: False
   obtain m where m_def: "m = 1 + nat ( 2*(ord ([n]\<cdot>\<^bsub>Q\<^sub>p\<^esub> (\<one>))))"
     by blast
   then have m_pos: "m > 0"
     by linarith
   have "\<forall> u \<in> carrier Q\<^sub>p. ac m u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n"
   proof
     fix u
     assume A: "u \<in> carrier Q\<^sub>p"
     show " ac m u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n"
     proof
       assume B: "ac m u = 1 \<and> val u = 0"
       then have 0: "val u = val \<one>"
         by (smt A ac_def not_nonzero_Qp val_one val_ord zero_eint_def)
       have 1: "ac m u = ac m \<one>"
         by (metis B Qp.one_nonzero ac_p ac_p_int_pow_factor angular_component_factors_x angular_component_p inc_of_one m_pos p_nonzero)
       have 2: "u \<in> nonzero Q\<^sub>p"
       proof-
         have "ac m \<zero> = 0"
           by (meson ac_def)
         then have "u \<noteq> \<zero>"
           by (metis B zero_neq_one)
         then show ?thesis
           using A not_nonzero_Qp Qp.nonzero_memI by presburger
       qed
       then have 3: "val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> u) \<ge> m" using m_pos 0 1 ac_ord_prop[of "\<one>" u "0::int" m]
         by (metis B Qp.one_nonzero add.right_neutral eint.inject val_ord zero_eint_def)
       show "u \<in> P_set n"
       proof(cases "u = \<one>")
         case True
         then show ?thesis
           by (metis P_set_one insert_iff zeroth_P_set)
       next
         case False
         have F0: "u \<in> \<O>\<^sub>p"
           apply(rule val_ring_memI, rule A)
           unfolding 0 val_one by auto
         have F1: "val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> u) \<ge> m"
           using False 3 by blast
         have "ord (\<one> \<ominus> u) \<ge> m"
           by (metis A F1 False Qp.not_eq_diff_nonzero Qp.one_closed eint_ord_simps(1) val_ord)
         hence F2: "ord (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> u) > 2*(ord ([n]\<cdot> \<one>))"
           using m_def F1 A False Qp.not_eq_diff_nonzero Qp.one_closed eint_ord_simps(1)
             int_nat_eq of_nat_1 of_nat_add val_ord[of "\<one> \<ominus> u"] eint_nat_times_2
           by linarith
         have "val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> u) > 2*(val ([n]\<cdot> \<one>))"
         proof-
           have 0: "val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> u) > 2*(ord ([n]\<cdot> \<one>))"
             using F2 val_ord[of "\<one> \<ominus> u"] A False Qp.not_eq_diff_nonzero Qp.one_closed eint_ord_simps(2) by presburger
           have "n > 0"
             using assms  by linarith
           hence "eint (ord ([n] \<cdot> \<one>)) = val ([n] \<cdot> \<one>)"
             using val_ord_nat_inc[of n]
             by blast
           hence "2*ord ([n]\<cdot> \<one>) = 2*val ([n]\<cdot> \<one>)"
             by (metis inc_of_nat times_eint_simps(1))
           thus ?thesis
             using 0 val_ord[of "\<one> \<ominus> u"] assms
             by presburger
         qed
         then have "(\<exists> b \<in> \<O>\<^sub>p. ((b[^]n) = u))"
           using m_def False nth_root_poly_root[of n u] F0 assms  F by linarith
         then have "(\<exists> b \<in> carrier Q\<^sub>p. ((b[^]n) = u))"
           using val_ring_memE by blast
         then show "u \<in> P_set n"
           using P_set_def[of n] 2
           by blast
       qed
     qed
   qed
   then show ?thesis using m_pos by blast
 qed
 
 definition pow_res where
 "pow_res (n::nat) x = {a. a \<in> carrier Q\<^sub>p \<and>  (\<exists>y \<in> nonzero Q\<^sub>p. (a = x \<otimes> (y[^]n)))}"
 
 lemma nonzero_pow_res:
   assumes "x \<in> nonzero Q\<^sub>p"
   shows "pow_res (n::nat) x \<subseteq> nonzero Q\<^sub>p"
 proof
   fix a
   assume "a \<in> pow_res n x"
   then obtain y where y_def: "y \<in> nonzero Q\<^sub>p \<and> (a = x \<otimes> (y[^]n))"
     using pow_res_def by blast
   then show "a \<in> nonzero Q\<^sub>p"
     using assms Qp.Units_m_closed Qp_nat_pow_nonzero Units_eq_nonzero by blast
 qed
 
 lemma pow_res_of_zero:
   shows "pow_res n \<zero> = {\<zero>}"
   unfolding pow_res_def  apply(rule equalityI)
   apply(rule subsetI)
   unfolding mem_Collect_eq
   apply (metis Qp.integral_iff Qp.nat_pow_closed Qp.nonzero_closed Qp.zero_closed insertCI)
   apply(rule subsetI) unfolding mem_Collect_eq
   by (metis Qp.nat_pow_one Qp.one_nonzero Qp.r_one Qp.zero_closed equals0D insertE)
 
 lemma equal_pow_resI:
   assumes "x \<in> carrier Q\<^sub>p"
   assumes "y \<in> pow_res n x"
   shows "pow_res n x = pow_res n y"
 proof
   have y_closed: "y \<in> carrier Q\<^sub>p"
     using assms unfolding pow_res_def by blast
   obtain c where c_def: "c \<in> nonzero Q\<^sub>p \<and> y = x \<otimes> (c[^]n)"
     using assms pow_res_def by blast
   have "((inv c)[^]n) = inv (c[^]n)"
     using c_def Qp.field_axioms Qp.nat_pow_of_inv Units_eq_nonzero by blast
   then have "y \<otimes> ((inv c)[^]n) = x"
     using y_closed c_def assms Qp.inv_cancelL(2) Qp.nonzero_closed Qp_nat_pow_nonzero Units_eq_nonzero
     by presburger
   then have P0: "(inv c) \<in> nonzero Q\<^sub>p \<and> x =y \<otimes> ((inv c)[^]n) "
     using c_def  nonzero_inverse_Qp by blast
   show "pow_res n x \<subseteq> pow_res n y"
   proof
     fix a
     assume A: "a \<in> pow_res n x"
     then have "a \<in> carrier Q\<^sub>p"
       by (metis (no_types, lifting) mem_Collect_eq pow_res_def)
     obtain b  where b_def: "b \<in> nonzero Q\<^sub>p \<and> a = x \<otimes> (b[^]n)"
       using A pow_res_def by blast
     then have 0: "b \<in> nonzero Q\<^sub>p \<and> a = y \<otimes> ((inv c)[^]n) \<otimes> (b[^]n)"
       using \<open>y \<otimes> inv c [^] n = x\<close> by blast
     have "b \<in> nonzero Q\<^sub>p \<and> a = y \<otimes> (((inv c)  \<otimes> b)[^]n)"
     proof-
       have "(inv c)[^]n \<otimes> (b[^]n) = ((inv c)  \<otimes> b)[^]n"
         using c_def b_def assms P0 Qp.nat_pow_distrib Qp.nonzero_closed by presburger
       then have " y \<otimes> (((inv c)[^]n) \<otimes> (b[^]n)) = y \<otimes> (((inv c)  \<otimes> b)[^]n)"
         by presburger
       then show ?thesis
         using y_closed 0 P0 Qp.m_assoc Qp.nat_pow_closed Qp.nonzero_closed assms(1) by presburger
     qed
     then have "((inv c)  \<otimes> b) \<in> nonzero Q\<^sub>p \<and> a = y \<otimes> (((inv c)  \<otimes> b)[^]n)"
       by (metis P0 Qp.integral_iff Qp.nonzero_closed Qp.nonzero_mult_closed not_nonzero_Qp)
     then show "a \<in> pow_res n y" using pow_res_def \<open>a \<in> carrier Q\<^sub>p\<close> by blast
   qed
   show "pow_res n y \<subseteq> pow_res n x"
   proof
     fix a
     assume A: "a \<in> pow_res n y"
     then have 0: "a \<in> carrier Q\<^sub>p"
       by (metis (no_types, lifting) mem_Collect_eq pow_res_def)
     obtain b  where b_def: "b \<in> nonzero Q\<^sub>p \<and> a = y \<otimes> (b[^]n)"
       using A pow_res_def by blast
     then have "a = (x \<otimes> (c[^]n)) \<otimes> (b[^]n)"
       using c_def by blast
     then have "a = x \<otimes> ((c[^]n) \<otimes> (b[^]n))"
       by (meson Qp.m_assoc Qp.nat_pow_closed Qp.nonzero_closed assms(1) b_def c_def)
     then have "a = x \<otimes> ((c \<otimes> b)[^]n)"
       using Qp.nat_pow_distrib Qp.nonzero_closed b_def c_def by presburger
     then have "(c \<otimes> b) \<in> nonzero Q\<^sub>p \<and>   a = x \<otimes> ((c \<otimes> b)[^]n)"
       by (metis Qp.integral_iff Qp.nonzero_closed Qp.nonzero_mult_closed b_def c_def not_nonzero_Qp)
     then show "a \<in> pow_res n x"
       using pow_res_def 0  by blast
   qed
 qed
 
 lemma zeroth_pow_res:
   assumes "x \<in> carrier Q\<^sub>p"
   shows "pow_res 0 x = {x}"
   apply(rule equalityI)
   apply(rule subsetI)
   unfolding pow_res_def mem_Collect_eq
   using assms apply (metis Qp.nat_pow_0 Qp.r_one singletonI)
   apply(rule subsetI)
   unfolding pow_res_def mem_Collect_eq
   using assms by (metis Qp.nat_pow_0 Qp.one_nonzero Qp.r_one equals0D insertE)
 
 lemma Zp_car_zero_res: assumes "x \<in> carrier Z\<^sub>p"
   shows "x 0 = 0"
   using assms unfolding Zp_def
   using Zp_def Zp_defs(3) padic_set_zero_res prime by blast
 
 lemma zeroth_ac:
   assumes "x \<in> carrier Q\<^sub>p"
   shows "ac 0 x = 0"
   apply(cases "x = \<zero> ")
   unfolding ac_def apply presburger
   using assms angular_component_closed[of x] Zp_car_zero_res unfolding nonzero_def mem_Collect_eq
   by presburger
 
 lemma nonzero_ac_imp_nonzero:
   assumes "x \<in> carrier Q\<^sub>p"
   assumes "ac m x \<noteq> 0"
   shows "x \<in> nonzero Q\<^sub>p"
   using assms unfolding ac_def nonzero_def mem_Collect_eq
   by presburger
 
 lemma nonzero_ac_val_ord:
   assumes "x \<in> carrier Q\<^sub>p"
   assumes "ac m x \<noteq> 0"
   shows "val x = ord x"
   using nonzero_ac_imp_nonzero assms val_ord by blast
 
 lemma pow_res_equal_ord:
   assumes "n > 0"
   shows  "\<exists>m > 0. \<forall>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<longrightarrow> pow_res n x = pow_res n y"
 proof-
   obtain m where m_def_0: "m > 0 \<and> ( \<forall> u \<in> carrier Q\<^sub>p. ac m u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n)"
     using assms nth_power_fact[of n]
     by (metis less_imp_le_nat less_one linorder_neqE_nat nat_le_linear zero_less_iff_neq_zero)
   then have  m_def: "m > 0 \<and> ( \<forall> u \<in> carrier Q\<^sub>p. ac m u = 1 \<and> ord u = 0 \<longrightarrow> u \<in> P_set n)"
     by (smt nonzero_ac_val_ord zero_eint_def)
   have  "\<forall>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<longrightarrow> pow_res n x = pow_res n y"
   proof
     fix x
     show "\<forall>y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<longrightarrow> pow_res n x = pow_res n y"
     proof fix y
       show "x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<longrightarrow> pow_res n x = pow_res n y"
       proof
         assume A: "x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y "
         then have 0: "ac m (x \<div> y) = 1"
           using ac_inv[of y m] ac_mult
           by (metis ac_inv'''(1) ac_mult'  m_def nonzero_inverse_Qp)
         have 1: "ord (x \<div> y) = 0"
           using A  ord_fract by presburger
         have 2: "(x \<div> y) \<in> nonzero Q\<^sub>p"
           using A
           by (metis Qp.nonzero_closed Qp.nonzero_mult_closed local.fract_cancel_right nonzero_inverse_Qp not_nonzero_Qp zero_fract)
         have 3: "(x \<div> y) \<in> P_set n"
           using m_def 0 1 2 nonzero_def
           by (smt Qp.nonzero_closed)
         then obtain b where b_def: "b \<in> carrier Q\<^sub>p \<and> (b[^]n) = (x \<div> y)"
           using P_set_def
           by blast
         then have "(x \<div> y) \<otimes> y = (b[^]n) \<otimes> y"
           by presburger
         then have "x = (b[^]n) \<otimes> y"
           using A b_def
           by (metis Qp.nonzero_closed local.fract_cancel_left)
         then have "x = y \<otimes>(b[^]n)"
           using A b_def
           by (metis Qp.nonzero_closed local.fract_cancel_right)
         then have "x \<in> pow_res n y"
           unfolding pow_res_def using A b_def
           by (metis (mono_tags, lifting) "2" Qp.nat_pow_0 Qp.nonzero_closed Qp_nonzero_nat_pow mem_Collect_eq not_gr_zero)
         then show "pow_res n x = pow_res n y"
           using  A equal_pow_resI[of x y n] unfolding nonzero_def
           by (metis (mono_tags, lifting) A Qp.nonzero_closed equal_pow_resI)
       qed
     qed
   qed
   then show ?thesis using m_def by blast
 qed
 
 lemma pow_res_equal:
   assumes "n > 0"
   shows  "\<exists>m> 0. \<forall>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = (ord y mod n) \<longrightarrow> pow_res n x = pow_res n y"
 proof-
   obtain m where m_def: "m > 0 \<and> (\<forall>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<longrightarrow> pow_res n x = pow_res n y)"
     using assms pow_res_equal_ord
     by meson
   have "\<forall>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y mod int n \<longrightarrow> pow_res n x = pow_res n y"
   proof fix x
     show  "\<forall>y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y mod int n \<longrightarrow> pow_res n x = pow_res n y"
     proof fix y
       show "x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y mod int n \<longrightarrow> pow_res n x = pow_res n y"
       proof
         assume A: "x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y mod int n"
         show "pow_res n x = pow_res n y"
         proof-
           have A0: "x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p"
             using A by blast
           have A1: "ac m x = ac m y"
             using A by blast
           have A2: "ord x = ord y mod int n"
             using A by blast
           obtain k where k_def: "k = ord x"
             by blast
           obtain l where l_def: "ord y = ord x + (l:: int)*(int n)"
             using assms A2
             by (metis A k_def mod_eqE mod_mod_trivial mult_of_nat_commute)
           have m_def': "\<And>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<Longrightarrow>  pow_res n x = pow_res n y"
             using m_def
             by blast
           have 0: "ord (y \<otimes> (\<pp>[^](- l*n))) = ord x"
           proof-
             have 0: "ord (y \<otimes> (\<pp>[^](- l*n))) = ord y + (ord  (\<pp>[^](- l*n)))"
               using ord_mult p_nonzero  A0 Qp_int_pow_nonzero
               by blast
             have 1: "ord (\<pp>[^](- l*n)) = - l*n"
               using ord_p_pow_int[of "-l*n"]
               by blast
             then have "ord (y \<otimes> (\<pp>[^](- l*n))) = ord y - l*n"
               using 0
               by linarith
             then show ?thesis
               using k_def l_def by linarith
           qed
           have 1: "ac m (y \<otimes> (\<pp>[^](- l*n))) = ac m y"
             using assms ac_p_int_pow_factor_right[of ] m_def A Qp.nonzero_closed by presburger
           have 2: "y \<otimes> (\<pp>[^](- l*n)) \<in> nonzero Q\<^sub>p"
             using A0 Qp_int_pow_nonzero[of \<pp> "- l*n"] Qp.cring_axioms nonzero_def cring.cring_simprules(5)
               fract_cancel_left not_nonzero_Qp p_intpow_inv'' p_nonzero zero_fract Qp.integral_iff
               Qp.nonzero_closed Qp.nonzero_memE(2) Qp.nonzero_memI Qp.nonzero_mult_closed
               minus_mult_commute mult_minus_right p_intpow_closed(1) p_intpow_closed(2)
             by presburger
           then have 3: "pow_res n (y \<otimes> (\<pp>[^](- l*n))) = pow_res n x"
             using 2 A0 m_def'[of "y \<otimes> (\<pp>[^](- l*n))" x] "0" "1" A1
             by linarith
           have 4: "(y \<otimes> (\<pp>[^](- l*n))) = (y \<otimes> ((\<pp>[^]- l)[^]n))"
             using Qp_int_nat_pow_pow[of \<pp> "-l" n] p_nonzero
             by presburger
           have "y \<otimes> (\<pp>[^](- l*n))\<in> pow_res n y "
             using "2" "4" Qp_int_pow_nonzero nonzero_def p_nonzero
             unfolding pow_res_def nonzero_def
           proof -
             assume a1: "\<And>x n. x \<in> {a \<in> carrier Q\<^sub>p. a \<noteq> \<zero>} \<Longrightarrow> x [^] (n::int) \<in> {a \<in> carrier Q\<^sub>p. a \<noteq> \<zero>}"
             assume a2: "\<pp> \<in> {a \<in> carrier Q\<^sub>p. a \<noteq> \<zero>}"
             assume a3: "y \<otimes> \<pp> [^] (- l * int n) \<in> {a \<in> carrier Q\<^sub>p. a \<noteq> \<zero>}"
             have f4: "\<pp> [^] (- 1 * l) \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>}"
               using a2 a1 by presburger
             have f5: "- l = - 1 * l"
               by linarith
             then have f6: "y \<otimes> \<pp> [^] (- 1 * l * int n) = y \<otimes> (\<pp> [^] (- 1 * l)) [^] n"
               using \<open>y \<otimes> \<pp> [^] (- l * int n) = y \<otimes> (\<pp> [^] - l) [^] n\<close> by presburger
             then have "y \<otimes> (\<pp> [^] (- 1 * l)) [^] n \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>}"
               using f5 a3 by presburger
             then have "y \<otimes> (\<pp> [^] (- 1 * l)) [^] n \<in> {r \<in> carrier Q\<^sub>p. \<exists>ra. ra \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>} \<and> r = y \<otimes> ra [^] n}"
               using f4 by blast
             then have "y \<otimes> \<pp> [^] (- l * int n) \<in> {r \<in> carrier Q\<^sub>p. \<exists>ra. ra \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>} \<and> r = y \<otimes> ra [^] n}"
               using f6 f5 by presburger
             then show "y \<otimes> \<pp> [^] (- l * int n) \<in> {r \<in> carrier Q\<^sub>p. \<exists>ra\<in>{r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>}. r = y \<otimes> ra [^] n}"
               by meson
           qed
           then have "pow_res n (y \<otimes> (\<pp>[^](- l*n))) = pow_res n y"
             using equal_pow_resI[of "(y \<otimes> (\<pp>[^](- l*n)))" y n] "2" A0 assms
                   Qp.nonzero_mult_closed p_intpow_closed(2)
             by (metis (mono_tags, opaque_lifting) "3" A Qp.nonzero_closed equal_pow_resI)
           then show ?thesis using 3 by blast
         qed
       qed
     qed
   qed
   then show ?thesis
     using m_def
     by blast
 qed
 
 definition pow_res_classes where
 "pow_res_classes n = {S. \<exists>x \<in> nonzero Q\<^sub>p. S = pow_res n x }"
 
 lemma pow_res_semialg_def:
   assumes "x \<in> nonzero Q\<^sub>p"
   assumes "n \<ge> 1"
   shows "\<exists>P \<in> carrier Q\<^sub>p_x. pow_res n x = (univ_basic_semialg_set n P) - {\<zero>}"
 proof-
   have 0: "pow_res n x = {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. (inv x) \<otimes> a = (y[^]n)}"
   proof
     show "pow_res n x \<subseteq> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n)}"
     proof
       fix a
       assume A: "a \<in> pow_res n x"
       then have "a \<in> carrier Q\<^sub>p \<and>  (\<exists>y\<in>nonzero Q\<^sub>p. a = x \<otimes> (y[^]n))"
         unfolding pow_res_def
         by blast
       then obtain y where y_def: "y \<in> nonzero Q\<^sub>p \<and>a = x \<otimes> (y[^]n)"
         by blast
       then have "y \<in> nonzero Q\<^sub>p \<and> inv x \<otimes> a = (y[^]n)"
       proof -
         show ?thesis
           by (metis (no_types, opaque_lifting) Qp.m_assoc Qp.m_comm Qp.nat_pow_closed Qp.nonzero_closed
               \<open>a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. a = x \<otimes> y [^] n)\<close> assms(1) local.fract_cancel_right nonzero_inverse_Qp y_def)
       qed
       then show "a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n)}"
         using assms \<open>a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. a = x \<otimes> (y[^]n))\<close>
         by blast
     qed
 
     show "{a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n)} \<subseteq> pow_res n x"
     proof
       fix a
       assume A: "a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n)}"
       show "a \<in> pow_res n x"
       proof-
         have "a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n))"
           using A by blast
         then obtain y where y_def: "y\<in>nonzero Q\<^sub>p \<and> inv x \<otimes> a = (y[^]n)"
           by blast
         then have "y\<in>nonzero Q\<^sub>p \<and>  a = x \<otimes>(y[^]n)"
           by (metis Qp.l_one Qp.m_assoc Qp.nonzero_closed Qp.not_nonzero_memI
               \<open>a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = y [^] n)\<close> assms(1) field_inv(2) inv_in_frac(1))
         then show ?thesis
           by (metis (mono_tags, lifting) \<open>a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n))\<close> mem_Collect_eq pow_res_def)
       qed
     qed
   qed
   obtain P where P_def: "P = up_ring.monom Q\<^sub>p_x (inv x) 1"
     by blast
   have P_closed: "P \<in> carrier Q\<^sub>p_x"
     using P_def Qp.nonzero_closed Qp.nonzero_memE(2) UPQ.is_UP_monomE(1) UPQ.is_UP_monomI assms(1) inv_in_frac(1) by presburger
   have P_eval: "\<And>a. a \<in> carrier Q\<^sub>p \<Longrightarrow> (P \<bullet> a) = (inv x) \<otimes> a"
     using P_def to_fun_monom[of ]
     by (metis Qp.nat_pow_eone Qp.nonzero_closed Qp.not_nonzero_memI assms(1) inv_in_frac(1))
   have 0: "pow_res n x = {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. (P \<bullet> a) = (y[^]n)}"
   proof
     show "pow_res n x \<subseteq> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}"
     proof fix a
       assume "a \<in> pow_res n x"
       then have "a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n))"
         using 0
         by blast
       then show "a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}"
         using P_eval
         by (metis (mono_tags, lifting) mem_Collect_eq)
      qed
     show "{a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)} \<subseteq> pow_res n x"
     proof fix a
       assume "a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}"
       then obtain y where y_def: "y\<in>nonzero Q\<^sub>p \<and> P \<bullet> a = (y[^]n)"
         by blast
       then have "y\<in>nonzero Q\<^sub>p \<and> inv x \<otimes> a = (y[^]n)"
         using P_eval \<open>a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}\<close>
         by blast
       then have "a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>nonzero Q\<^sub>p. inv x \<otimes> a = (y[^]n))"
          using \<open>a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}\<close> by blast
       then show "a \<in> pow_res n x"
       using 0
       by blast
     qed
   qed
   have 1: "univ_basic_semialg_set n P - {\<zero>} = {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. (P \<bullet> a) = (y[^]n)}"
   proof
     show "univ_basic_semialg_set n P - {\<zero>} \<subseteq> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}"
     proof
       fix a
       assume A: "a \<in> univ_basic_semialg_set n P - {\<zero>}"
       then have A0: "a \<in> carrier Q\<^sub>p \<and> (\<exists>y\<in>carrier Q\<^sub>p. P \<bullet> a = (y[^]n))"
         unfolding univ_basic_semialg_set_def by blast
       then have A0': "a \<in> nonzero Q\<^sub>p \<and> (\<exists>y\<in>carrier Q\<^sub>p. P \<bullet> a = (y[^]n))"
         using A
         by (metis DiffD2 not_nonzero_Qp singletonI)
       then obtain y where y_def: "y\<in>carrier Q\<^sub>p \<and> P \<bullet> a = (y[^]n)"
         by blast
       have A1: "(P \<bullet> a) \<noteq> \<zero>"
         using P_eval A0' Qp.integral_iff Qp.nonzero_closed Qp.nonzero_memE(2) assms(1) inv_in_frac(1) inv_in_frac(2) by presburger
       have A2: "y \<in> nonzero Q\<^sub>p"
       proof-
         have A20: "(y[^]n) \<noteq>\<zero>"
           using A1 y_def
           by blast
         have "y \<noteq> \<zero>"
           apply(rule ccontr) using A20 assms
           by (metis Qp.nat_pow_eone Qp.semiring_axioms Qp.zero_closed le_zero_eq semiring.nat_pow_zero)
         then show ?thesis
           using y_def A1 not_nonzero_Qp Qp.not_nonzero_memE by blast
       qed
       then have "y \<in> nonzero  Q\<^sub>p \<and> P \<bullet> a = (y[^]n)" using y_def
         by blast
       then show "a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}"
         using A0 nonzero_def
         by blast
     qed
     show "{a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)} \<subseteq> univ_basic_semialg_set n P - {\<zero>}"
     proof
       fix a
       assume A: "a \<in> {a \<in> carrier Q\<^sub>p. \<exists>y\<in>nonzero Q\<^sub>p. P \<bullet> a = (y[^]n)}"
       then obtain y where y_def: "y\<in>nonzero Q\<^sub>p \<and> P \<bullet> a = (y[^]n)"
         by blast
       then have "y \<noteq>\<zero> \<and> y\<in> carrier Q\<^sub>p \<and> P \<bullet> a = (y[^]n)"
         by (metis (mono_tags, opaque_lifting) Qp.nonzero_closed Qp.not_nonzero_memI)
       then have "a \<noteq>\<zero>"
         using  P_eval
         by (metis Qp.m_comm Qp.nonzero_closed Qp.nonzero_memE(2) Qp.nonzero_pow_nonzero Qp.zero_closed assms(1) inv_in_frac(1) zero_fract)
       then show "a \<in> univ_basic_semialg_set n P - {\<zero>}"
         unfolding univ_basic_semialg_set_def
         using A \<open>y \<noteq> \<zero> \<and> y \<in> carrier Q\<^sub>p \<and> P \<bullet> a = (y[^]n)\<close>
         by blast
     qed
   qed
   show ?thesis using 0 1
     by (metis (no_types, lifting) P_closed)
 qed
 
 lemma pow_res_is_univ_semialgebraic:
   assumes "x \<in> carrier Q\<^sub>p"
   shows "is_univ_semialgebraic (pow_res n x)"
 proof(cases "n = 0")
   case True
   have T0: "pow_res n x = {x}"
     unfolding True using assms
     by (simp add: assms zeroth_pow_res)
   have "[x] \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
     using assms Qp.to_R1_closed by blast
   hence "is_semialgebraic 1 {[x]}"
     using is_algebraic_imp_is_semialg singleton_is_algebraic by blast
   thus ?thesis unfolding T0 using assms
     by (simp add: \<open>x \<in> carrier Q\<^sub>p\<close> finite_is_univ_semialgebraic)
 next
   case False
   show ?thesis
   proof(cases "x = \<zero>")
     case True
     then show ?thesis using finite_is_univ_semialgebraic False pow_res_of_zero
       by (metis Qp.zero_closed empty_subsetI finite.emptyI finite.insertI insert_subset)
   next
     case F: False
     then show ?thesis
       using False pow_res_semialg_def[of x n] diff_is_univ_semialgebraic[of _ "{\<zero>}"]  finite_is_univ_semialgebraic[of "{\<zero>}"]
       by (metis Qp.zero_closed assms empty_subsetI finite.emptyI finite.insertI insert_subset less_one less_or_eq_imp_le linorder_neqE_nat not_nonzero_Qp univ_basic_semialg_set_is_univ_semialgebraic)
   qed
 qed
 
 lemma pow_res_is_semialg:
   assumes "x \<in> carrier Q\<^sub>p"
   shows "is_semialgebraic 1 (to_R1 ` (pow_res n x))"
   using assms pow_res_is_univ_semialgebraic is_univ_semialgebraicE
   by blast
 
 lemma pow_res_refl:
   assumes "x \<in> carrier Q\<^sub>p"
   shows "x \<in> pow_res n x"
 proof-
   have "x = x \<otimes> (\<one> [^]n)"
     using assms Qp.nat_pow_one Qp.r_one by presburger
   thus ?thesis
     using assms unfolding pow_res_def mem_Collect_eq
     using Qp.one_nonzero by blast
 qed
 
 lemma equal_pow_resE:
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "n > 0"
   assumes "pow_res n a = pow_res n b"
   shows "\<exists> s \<in> P_set n. a = b \<otimes> s"
 proof-
   have "a \<in> pow_res n b"
     using assms pow_res_refl by blast
   then obtain y where y_def: " y \<in> nonzero Q\<^sub>p \<and> a = b \<otimes> y[^]n"
     unfolding pow_res_def by blast
   thus ?thesis  unfolding P_set_def
     using Qp.nonzero_closed Qp_nat_pow_nonzero by blast
 qed
 
 lemma pow_res_one:
   assumes "x \<in> nonzero Q\<^sub>p"
   shows "pow_res 1 x = nonzero Q\<^sub>p"
 proof show "pow_res 1 x \<subseteq> nonzero Q\<^sub>p"
       using  assms nonzero_pow_res[of x 1] by blast
     show "nonzero Q\<^sub>p \<subseteq> pow_res 1 x"
     proof fix y assume A: "y \<in> nonzero Q\<^sub>p"
       then have 0: "\<one> \<in> nonzero Q\<^sub>p \<and> y = x \<otimes> ((inv x)\<otimes> y)[^](1::nat)"
         using assms  Qp.m_comm Qp.nat_pow_eone Qp.nonzero_closed Qp.nonzero_mult_closed
           Qp.one_nonzero local.fract_cancel_right nonzero_inverse_Qp by presburger
       have 1: "(inv x)\<otimes> y \<in> nonzero Q\<^sub>p"
         using A assms by (metis Qp.Units_m_closed Units_eq_nonzero nonzero_inverse_Qp)
       then show "y \<in> pow_res 1 x"
         unfolding pow_res_def using 0 1 A Qp.nonzero_closed by blast
     qed
 qed
 
 
 lemma pow_res_zero:
   assumes "n > 0"
   shows "pow_res n \<zero> = {\<zero>}"
 proof
   show "pow_res n \<zero> \<subseteq> {\<zero>}"
   unfolding pow_res_def
   using Qp.l_null Qp.nat_pow_closed Qp.nonzero_closed by blast
   show "{\<zero>} \<subseteq> pow_res n \<zero>"
     using assms unfolding pow_res_def
     using Qp.l_null Qp.one_closed Qp.one_nonzero empty_subsetI insert_subset by blast
 qed
 
 
 lemma equal_pow_resI':
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "c \<in> P_set n"
   assumes "a = b \<otimes> c"
   assumes "n > 0"
   shows "pow_res n a = pow_res n b"
 proof-
   obtain y where y_def: "c = y[^]n \<and> y \<in> carrier Q\<^sub>p"
     using assms unfolding P_set_def by blast
   have c_nonzero: "c \<in> nonzero Q\<^sub>p"
     using P_set_nonzero'(1) assms(3) by blast
   have y_nonzero: "y \<in> nonzero Q\<^sub>p"
     using y_def c_nonzero  Qp_nonzero_nat_pow assms(5) by blast
   have 0: "a \<in> pow_res n b"
     using assms y_nonzero y_def unfolding pow_res_def
     by blast
   show ?thesis
     apply(cases "b = \<zero>")
     using pow_res_zero Qp.l_null Qp.nonzero_closed assms(4) c_nonzero apply presburger
     by (metis "0" assms(1) assms(2) assms(5) not_nonzero_Qp equal_pow_resI)
 qed
 
 lemma equal_pow_resI'':
   assumes "n > 0"
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "b \<in> nonzero Q\<^sub>p"
   assumes "a \<otimes> inv b \<in> P_set n"
   shows "pow_res n a = pow_res n b"
   using assms equal_pow_resI'[of a b "a \<otimes> inv b" n] Qp.nonzero_closed local.fract_cancel_right
   by blast
 
 lemma equal_pow_resI''':
   assumes "n > 0"
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "b \<in> nonzero Q\<^sub>p"
   assumes "c \<in> nonzero Q\<^sub>p"
   assumes "pow_res n (c \<otimes> a) = pow_res n (c \<otimes> b)"
   shows "pow_res n a = pow_res n b"
 proof-
   have 0: "c \<otimes>a \<in> nonzero Q\<^sub>p"
     by (meson Localization.submonoid.m_closed Qp.nonzero_is_submonoid assms(2) assms(4))
   have 1: "c \<otimes>b \<in> nonzero Q\<^sub>p"
     by (meson Localization.submonoid.m_closed Qp.nonzero_is_submonoid assms(3) assms(4))
   have "c\<otimes>a \<in> pow_res n (c\<otimes>b)"
   proof(cases "n = 1")
     case True
     then show ?thesis
       using assms 0 1 pow_res_one[of "c\<otimes>b"] by blast
   next
     case False
     then have "n \<ge> 2"
       using assms(1) by linarith
     then show ?thesis
       using assms 0 1 pow_res_refl[of "c\<otimes>a" n] unfolding nonzero_def
       by blast
   qed
   then obtain y where y_def: "y \<in> nonzero Q\<^sub>p \<and> (c \<otimes> a) = (c \<otimes> b)\<otimes>y[^]n"
     using assms unfolding pow_res_def by blast
   then have "a = b\<otimes>y[^]n"
     using assms
     by (metis Qp.m_assoc Qp.m_lcancel Qp.nonzero_closed Qp.nonzero_mult_closed Qp.not_nonzero_memI Qp_nat_pow_nonzero)
   then show ?thesis
     by (metis P_set_memI Qp.nonzero_closed Qp.nonzero_mult_closed Qp.not_nonzero_memI Qp_nat_pow_nonzero assms(1) assms(3) equal_pow_resI' y_def)
 qed
 
 lemma equal_pow_resI'''':
   assumes "n > 0"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "a = b \<otimes> u"
   assumes "u \<in> P_set n"
   shows "pow_res n a = pow_res n b"
 proof(cases "a = \<zero>")
   case True
   then have "b = \<zero>"
     using assms unfolding P_set_def
     by (metis (no_types, lifting) Qp.integral Qp.nonzero_closed Qp.not_nonzero_memI mem_Collect_eq)
   then show ?thesis using pow_res_zero
     using True by blast
 next
   case False
   then have 0: "a \<in> nonzero Q\<^sub>p"
     using Qp.not_nonzero_memE assms(2) by blast
   have 1: "b \<in> nonzero Q\<^sub>p"
     using 0 assms unfolding P_set_def
     by (metis (no_types, lifting) Qp.integral_iff Qp.nonzero_closed mem_Collect_eq not_nonzero_Qp)
   have 2: "a \<otimes> (inv b)\<in> P_set n"
     using assms 0 1
     by (metis P_set_nonzero'(2) Qp.inv_cancelR(1) Qp.m_comm Qp.nonzero_memE(2) Units_eq_nonzero inv_in_frac(1))
   then show ?thesis using equal_pow_resI''
     by (meson "0" "1" assms(1) equal_pow_resI)
 qed
 
 
 lemma Zp_Units_ord_zero:
   assumes "a \<in> Units Z\<^sub>p"
   shows "ord_Zp a = 0"
 proof-
   have "inv\<^bsub>Z\<^sub>p\<^esub> a \<in> nonzero Z\<^sub>p"
     apply(rule Zp.nonzero_memI, rule Zp.Units_inv_closed, rule assms)
     using assms Zp.Units_inverse in_Units_imp_not_zero by blast
   then have "ord_Zp (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv \<^bsub>Z\<^sub>p\<^esub> a) = ord_Zp a + ord_Zp (inv \<^bsub>Z\<^sub>p\<^esub> a)"
     using assms ord_Zp_mult Zp.Units_nonzero zero_not_one
     by (metis Zp.zero_not_one)
   then show ?thesis
     by (smt Zp.Units_closed Zp.Units_r_inv Zp.integral_iff Zp.nonzero_closed \<open>inv\<^bsub>Z\<^sub>p\<^esub> a \<in> nonzero Z\<^sub>p\<close> assms ord_Zp_one ord_pos)
 qed
 
 lemma pow_res_nth_pow:
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "n > 0"
   shows "pow_res n (a[^]n) = pow_res n \<one>"
 proof
   show "pow_res n (a [^] n) \<subseteq> pow_res n \<one>"
   proof fix x assume A: "x \<in> pow_res n (a [^] n)"
     then show "x \<in> pow_res n \<one>"
       by (metis P_set_memI Qp.l_one Qp.nat_pow_closed Qp.nonzero_closed Qp.nonzero_memE(2)
           Qp.nonzero_pow_nonzero Qp.one_closed assms(1) assms(2) equal_pow_resI')
   qed
   show "pow_res n \<one> \<subseteq> pow_res n (a [^] n)"
   proof fix x assume A: "x \<in> pow_res n \<one>"
     then obtain y where y_def: "y \<in> nonzero Q\<^sub>p \<and> x = \<one>\<otimes>y[^]n"
       unfolding pow_res_def by blast
     then have 0: "x = y[^]n"
       using Qp.l_one Qp.nonzero_closed by blast
     have "y[^]n = a[^]n \<otimes> (inv a \<otimes> y)[^]n"
     proof-
       have "a[^]n \<otimes> (inv a \<otimes> y)[^]n = a[^]n \<otimes> (inv a)[^]n \<otimes> y[^]n"
         using Qp.Units_inv_closed Qp.m_assoc Qp.nat_pow_closed Qp.nat_pow_distrib Qp.nonzero_closed Units_eq_nonzero assms(1) y_def by presburger
       then show ?thesis
         by (metis Qp.Units_inv_inv Qp.inv_cancelR(1) Qp.nat_pow_distrib Qp.nonzero_closed Qp.nonzero_mult_closed Units_eq_nonzero assms(1) nonzero_inverse_Qp y_def)
     qed
     then show "x \<in> pow_res n (a [^] n)"
       using y_def  A assms unfolding pow_res_def mem_Collect_eq
       by (metis "0" Qp.integral Qp.m_closed Qp.nonzero_closed Qp.not_nonzero_memI inv_in_frac(1) inv_in_frac(2) not_nonzero_Qp)
   qed
 qed
 
 lemma pow_res_of_p_pow:
   assumes "n > 0"
   shows "pow_res n (\<pp>[^]((l::int)*n)) = pow_res n \<one>"
 proof-
   have 0: "\<pp>[^]((l::int)*n) = (\<pp>[^]l)[^]n"
     using Qp_p_int_nat_pow_pow by blast
   have "\<pp>[^]((l::int)*n) \<in> P_set n"
     using  P_set_memI[of _ "\<pp>[^]l"]
     by (metis "0" Qp.not_nonzero_memI Qp_int_pow_nonzero p_intpow_closed(1) p_nonzero)
   thus ?thesis
     using "0" assms p_intpow_closed(2) pow_res_nth_pow by presburger
 qed
 
 lemma pow_res_nonzero:
   assumes "n > 0"
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "pow_res n a = pow_res n b"
   shows "b \<in> nonzero Q\<^sub>p"
   using assms nonzero_pow_res[of a n] pow_res_zero[of n]
   by (metis insert_subset not_nonzero_Qp)
 
 lemma pow_res_mult:
   assumes "n > 0"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "c \<in> carrier Q\<^sub>p"
   assumes "d \<in> carrier Q\<^sub>p"
   assumes "pow_res n a = pow_res n c"
   assumes "pow_res n b = pow_res n d"
   shows "pow_res n (a \<otimes> b) = pow_res n (c \<otimes> d)"
 proof(cases "a \<in> nonzero Q\<^sub>p")
   case True
   then have "c \<in> nonzero Q\<^sub>p"
     using assms pow_res_nonzero by blast
   then obtain \<alpha> where alpha_def: "\<alpha> \<in> nonzero Q\<^sub>p \<and> a = c \<otimes> \<alpha>[^]n"
     using  assms True pow_res_refl[of a n] unfolding assms unfolding pow_res_def
      by blast
   show ?thesis
   proof(cases "b \<in> nonzero Q\<^sub>p")
     case T: True
     then have "d \<in> nonzero Q\<^sub>p"
       using assms pow_res_nonzero by blast
     then obtain \<beta> where beta_def: "\<beta> \<in> nonzero Q\<^sub>p \<and> b = d \<otimes> \<beta>[^]n"
       using  T pow_res_refl[of b n] unfolding assms unfolding pow_res_def
       using assms by blast
     then have "a \<otimes> b = (c \<otimes> d) \<otimes> (\<alpha>[^]n \<otimes> \<beta>[^] n)"
       using Qp.m_assoc Qp.m_lcomm Qp.nonzero_closed Qp.nonzero_mult_closed Qp_nat_pow_nonzero alpha_def assms(3) assms(4) assms(5) by presburger
     then have 0: "a \<otimes> b = (c \<otimes> d) \<otimes> ((\<alpha> \<otimes> \<beta>)[^] n)"
         by (metis Qp.nat_pow_distrib Qp.nonzero_closed alpha_def beta_def)
       show ?thesis
         apply(intro equal_pow_resI'[of _ _  "(\<alpha> \<otimes> \<beta>)[^] n"] Qp.ring_simprules assms
                     P_set_memI[of _ "\<alpha> \<otimes> \<beta>"] Qp.nat_pow_closed nonzero_memE 0 Qp_nat_pow_nonzero
                     )
         using alpha_def beta_def apply auto
         apply(intro nonzero_memI Qp.nonzero_mult_closed)
         using alpha_def beta_def nonzero_memE  apply auto
         by (meson Qp.integral_iff)
   next
     case False
     then have "b = \<zero>"
       by (meson assms not_nonzero_Qp)
     then have "d = \<zero>"
       using assms by (metis False not_nonzero_Qp pow_res_nonzero)
     then show ?thesis
       using Qp.r_null \<open>b = \<zero>\<close> assms  by presburger
   qed
 next
   case False
   then have "a = \<zero>"
       by (meson assms  not_nonzero_Qp)
     then have "c = \<zero>"
       using assms by (metis False not_nonzero_Qp pow_res_nonzero)
     then show ?thesis
       using Qp.r_null \<open>a = \<zero>\<close> assms Qp.l_null by presburger
   qed
 
 lemma pow_res_p_pow_factor:
   assumes "n > 0"
   assumes "a \<in> carrier Q\<^sub>p"
   shows "pow_res n a = pow_res n (\<pp>[^]((l::int)*n) \<otimes> a)"
 proof(cases "a  = \<zero>")
   case True
   then show ?thesis
     using Qp.r_null p_intpow_closed(1) by presburger
 next
   case False
   then show ?thesis using assms pow_res_of_p_pow
     using Qp.m_comm Qp.one_closed Qp.r_one p_intpow_closed(1) pow_res_mult by presburger
 qed
 
 lemma pow_res_classes_finite:
   assumes "n \<ge> 1"
   shows "finite (pow_res_classes n)"
 proof(cases "n = 1")
   case True
   have "pow_res_classes n = {(nonzero Q\<^sub>p)}"
     using True pow_res_one unfolding pow_res_classes_def
     using Qp.one_nonzero by blast
   then show ?thesis by auto
 next
   case False
   then have n_bound: "n \<ge> 2"
     using assms by linarith
   obtain m where m_def: "m > 0 \<and> (\<forall>x y. x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p \<and> ac m x = ac m y \<and> ord x = ord y \<longrightarrow> pow_res n x = pow_res n y)"
     using assms  False pow_res_equal_ord n_bound
     by (metis gr_zeroI le_numeral_extra(2))
   obtain f where f_def: "f  = (\<lambda> \<eta> \<nu>. (SOME y. y \<in> (pow_res_classes n) \<and> (\<exists> x \<in> y. ac m x = \<eta> \<and> ord x = \<nu>)))"
     by blast
   have 0: "\<And>x. x \<in> nonzero Q\<^sub>p \<Longrightarrow> pow_res n x = f (ac m x) (ord x)"
   proof- fix x assume A: "x \<in> nonzero Q\<^sub>p"
     obtain \<eta> where eta_def: "\<eta> = ac m x"
       by blast
     obtain \<nu> where nu_def: "\<nu> = ord x"
       by blast
     have "\<exists>y \<in>pow_res n x. ac m y = ac m x \<and> ord y = ord x"
       using pow_res_refl A assms neq0_conv Qp.nonzero_closed by blast
     hence "pow_res n x \<in> (pow_res_classes n) \<and> (\<exists> y \<in> (pow_res n x). ac m y = \<eta> \<and> ord y = \<nu>)"
       unfolding nu_def eta_def using assms unfolding pow_res_classes_def
       using A by blast
     then have 0: "(\<exists> y. y \<in> (pow_res_classes n) \<and> (\<exists> x \<in> y. ac m x = \<eta> \<and> ord x = \<nu>))"
       by blast
     have  "f \<eta> \<nu> = (SOME y. y \<in> (pow_res_classes n) \<and> (\<exists> x \<in> y. ac m x = \<eta> \<and> ord x = \<nu>))"
       using f_def by blast
     then have 1: "f \<eta> \<nu> \<in> (pow_res_classes n) \<and> ((\<exists> y \<in> (f \<eta> \<nu>).  ac m y = \<eta> \<and> ord y = \<nu>))"
       using  0  someI_ex[of "\<lambda> y. y \<in> (pow_res_classes n) \<and> (\<exists> x \<in> y. ac m x = \<eta> \<and> ord x = \<nu>)"]
       unfolding f_def by blast
     then obtain y where y_def: "y \<in> (f \<eta> \<nu>) \<and> ac m y = ac m x \<and> ord y =  ord x"
       unfolding nu_def eta_def by blast
     obtain a where a_def: "a \<in> nonzero Q\<^sub>p \<and> (f \<eta> \<nu>) = pow_res n a"
       using 1 unfolding pow_res_classes_def by blast
     then have 2: "y \<in> pow_res n a"
       using y_def by blast
     have 3: "y \<in> nonzero Q\<^sub>p"
       using y_def nonzero_pow_res[of a n] a_def by blast
     then have 4: "pow_res n y = pow_res n a"
       using 3 y_def a_def equal_pow_resI[of y a n]  n_bound Qp.nonzero_closed
       by (metis equal_pow_resI)
     have 5: "pow_res n y = f \<eta> \<nu>"
       using 4 a_def by blast
     then show "pow_res n x = f (ac m x) (ord x)"
       unfolding eta_def nu_def
       using "3" A m_def y_def by blast
   qed
   obtain N where N_def: "N > 0 \<and> (\<forall> u \<in> carrier Q\<^sub>p. ac N u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n)"
     using n_bound nth_power_fact assms by blast
   have 1: "\<And>x. x \<in> nonzero Q\<^sub>p \<Longrightarrow> (\<exists>y \<in> nonzero Q\<^sub>p. ord y \<ge> 0 \<and> ord y < n \<and> pow_res n x = pow_res n y)"
   proof- fix x assume x_def: "x \<in> nonzero Q\<^sub>p"
     then obtain k where k_def: "k = ord x mod n"
       by blast
     then obtain l where l_def: "ord x = (int n)*l + k"
       using cancel_div_mod_rules(2)[of n "ord x"0] unfolding k_def
       by (metis group_add_class.add.right_cancel)
     have "x = (\<pp>[^](ord x)) \<otimes> \<iota> (angular_component x)"
       using x_def angular_component_factors_x by blast
     then have "x = (\<pp>[^](n*l + k)) \<otimes> \<iota> (angular_component x)"
       unfolding l_def by blast
     hence "x = \<pp>[^](int n*l) \<otimes> (\<pp>[^] k) \<otimes> \<iota> (angular_component x)"
       by (metis p_intpow_add)
     hence 0: "x = (\<pp>[^]l)[^]n \<otimes> (\<pp>[^] k) \<otimes> \<iota> (angular_component x)"
       using p_pow_factor[of n l k] \<open>x = \<pp> [^] (int n * l + k) \<otimes> \<iota> (angular_component x)\<close> by presburger
     have 1: "\<iota> (angular_component x) \<in> carrier Q\<^sub>p"
       using x_def angular_component_closed inc_closed by blast
     hence 2: "x = (\<pp>[^]l)[^]n \<otimes> ((\<pp>[^] k) \<otimes> \<iota> (angular_component x))"
       using 0 by (metis Qp.m_assoc Qp.nat_pow_closed p_intpow_closed(1))
     obtain a where a_def: "a = (\<pp>[^] k) \<otimes> \<iota> (angular_component x)"
       by blast
     have 30: "angular_component x \<in> Units Z\<^sub>p"
       using angular_component_unit x_def by blast
     then have 3: "\<iota> (angular_component x) \<in> Units Q\<^sub>p"
       by (metis Units_eq_nonzero Zp.Units_closed in_Units_imp_not_zero inc_of_nonzero not_nonzero_Qp)
     have 4: "\<iota> (angular_component x) \<in> nonzero Q\<^sub>p"
       using 3 Units_nonzero_Qp by blast
     have a_nonzero: "a \<in> nonzero Q\<^sub>p"
       unfolding a_def  4
       by (meson "3" Qp.UnitsI(1) Qp.Units_m_closed Units_nonzero_Qp p_intpow_closed(1) p_intpow_inv)
     have 5: "x = a \<otimes>(\<pp>[^]l)[^]n"
       using 2 a_nonzero unfolding a_def
       using Qp.m_comm Qp.nat_pow_closed Qp.nonzero_closed p_intpow_closed(1) by presburger
     hence "x \<in> pow_res n a"
       unfolding pow_res_def
       using Qp.nonzero_closed Qp_int_pow_nonzero p_nonzero x_def by blast
     hence 6:"pow_res n a = pow_res n x"
       using x_def a_def equal_pow_resI[of x  a n]  a_nonzero n_bound Qp.nonzero_closed equal_pow_resI
       by blast
     have 7: "ord (\<iota> (angular_component x)) = 0"
     proof-
       have "ord_Zp (angular_component x) = 0" using 30 Zp_Units_ord_zero by blast
       then have "val_Zp (angular_component x) = 0"
         using "30" unit_imp_val_Zp0 by blast
       then have "val (\<iota> (angular_component x)) = 0"
         by (metis angular_component_closed val_of_inc x_def)
       then show ?thesis using angular_component_closed x_def
         by (metis "30" Zp.Units_closed \<open>ord_Zp (angular_component x) = 0\<close> in_Units_imp_not_zero not_nonzero_Qp ord_of_inc)
     qed
     have 8: "ord a = k"
       unfolding a_def using 3 4 7 ord_mult[of "\<pp> [^] k" "\<iota> (angular_component x)"] ord_p_pow_int[of k]
                 p_pow_nonzero
       using Qp_int_pow_nonzero p_nonzero by presburger
     have 9: "k < n"
       unfolding k_def
       using assms by auto
-    show " \<exists>y\<in>nonzero Q\<^sub>p. 0 \<le> ord y \<and> ord y < int n \<and> pow_res n x = pow_res n y"
-      by (metis "6" "8" a_nonzero assms k_def less_imp_of_nat_less of_nat_eq_0_iff pos_mod_conj rel_simps(45) zero_less_iff_neq_zero)
+    from 6 8 9 assms have \<open>0 \<le> ord a\<close> \<open>ord a < int n\<close> \<open>pow_res n x = pow_res n a\<close>
+      by (auto simp add: k_def)
+    with a_nonzero show "\<exists>y\<in>nonzero Q\<^sub>p. 0 \<le> ord y \<and> ord y < int n \<and> pow_res n x = pow_res n y"
+      by auto
   qed
   have 2: "\<And>x. x \<in> (pow_res_classes n) \<Longrightarrow> \<exists> \<eta> \<nu>. \<eta> \<in> Units (Zp_res_ring m) \<and> \<nu> \<in> {0..<int n} \<and> x = f \<eta> \<nu>"
   proof- fix a assume A: "a \<in> (pow_res_classes n)"
     then obtain x where x_def: "x \<in> nonzero Q\<^sub>p \<and> a = pow_res n x"
       unfolding pow_res_classes_def by blast
     then obtain x' where x'_def: "x' \<in> nonzero Q\<^sub>p \<and> ord x' \<ge> 0 \<and> ord x' < n \<and> pow_res n x' = a"
       using 1[of x] unfolding x_def by blast
     hence 20: "f (ac m x') (ord x') = a"
       using 0 by blast
     have 21: "ac m x' \<in> Units (Zp_res_ring m)"
       using x'_def ac_units m_def by presburger
     then have 22: "ac m x' \<in> Units (Zp_res_ring m) \<and> (ord x') \<in> ({0..<n}::int set ) \<and> a = f (ac m x') (ord x')"
       using x'_def 20 atLeastLessThan_iff by blast
     then show "\<exists> \<eta> \<nu>. \<eta> \<in> Units (Zp_res_ring m) \<and> \<nu> \<in> {0..<int n} \<and> a = f \<eta> \<nu>" by blast
   qed
   obtain F where F_def: "F = (\<lambda>ps. f (fst ps) (snd ps))"
     by blast
   have 3: "\<And>x. x \<in> (pow_res_classes n) \<Longrightarrow> \<exists> ps \<in> Units (Zp_res_ring m) \<times> {0..<int n}.  x = f (fst ps) (snd ps)"
   proof- fix x assume A: "x \<in> pow_res_classes n"
     obtain \<eta> \<nu> where eta_nu_def: " \<eta> \<in> Units (Zp_res_ring m) \<and> \<nu> \<in> {0..<int n} \<and> x = f \<eta> \<nu>"
       using 2 A by blast
     then have "F (\<eta>, \<nu>) = x"
       unfolding F_def by (metis fst_conv snd_conv)
     then show " \<exists> ps \<in> Units (Zp_res_ring m) \<times> {0..<int n}.  x = f (fst ps) (snd ps)"
       using eta_nu_def local.F_def by blast
   qed
   have 4: "pow_res_classes n \<subseteq> F ` (Units (Zp_res_ring m) \<times> {0..<int n})"
     unfolding F_def using 3
     by blast
   have "finite (Units (Zp_res_ring m))"
     using m_def residues.finite_Units unfolding residues_def
     by (metis Qp.one_nonzero ac_in_res_ring ac_one' p_res_ring_one p_residue_ring_car_memE(1))
   hence "finite (Units (Zp_res_ring m) \<times> {0..<int n})"
     by blast
   then show "finite (pow_res_classes n)"
     using 4 by (meson finite_surj)
 qed
 
 lemma pow_res_classes_univ_semialg:
   assumes "S \<in> pow_res_classes n"
   shows "is_univ_semialgebraic S"
 proof-
   obtain x where x_def: "x\<in>nonzero Q\<^sub>p \<and> S = pow_res n x"
   using assms unfolding pow_res_classes_def by blast
   then show ?thesis using pow_res_is_univ_semialgebraic
     using Qp.nonzero_closed by blast
 qed
 
 lemma pow_res_classes_semialg:
   assumes "S \<in> pow_res_classes n"
   shows "is_semialgebraic 1 (to_R1` S)"
   using pow_res_classes_univ_semialg
     assms(1)  is_univ_semialgebraicE by blast
 
 definition nth_pow_wits where
 "nth_pow_wits n = (\<lambda> S. (SOME x. x \<in> (S \<inter> \<O>\<^sub>p)))` (pow_res_classes n)"
 
 lemma nth_pow_wits_finite:
   assumes "n > 0"
   shows "finite (nth_pow_wits n)"
 proof-
   have "n \<ge> 1"
     by (simp add: assms leI)
   thus ?thesis
     unfolding nth_pow_wits_def using assms pow_res_classes_finite[of n] by blast
 qed
 
 lemma nth_pow_wits_covers:
   assumes "n > 0"
   assumes "x \<in> nonzero Q\<^sub>p"
   shows "\<exists>y \<in> (nth_pow_wits n). y \<in> nonzero Q\<^sub>p \<and> y \<in> \<O>\<^sub>p \<and> x \<in> pow_res n y"
 proof-
   have PP: "(pow_res n x) \<in> pow_res_classes n"
     unfolding pow_res_classes_def using assms by blast
   obtain k where k_def: "val x = eint k"
     using assms val_ord by blast
   obtain N::int where N_def: "N = (if  k < 0 then -k else k)" by blast
   then have N_nonneg: "N \<ge> 0"
     unfolding N_def
     by presburger
   have 0: "int n \<ge> 1"
     using assms by linarith
   have "N*(int n) + k \<ge> 0"
   proof(cases "k<0")
     case True then have "N = -k" unfolding N_def
       by presburger
     then have "N*n + k = k*(1- int n)"
       using distrib_left[of k 1 "-int n"] mult_cancel_left2 mult_minus_left
       by (metis add.inverse_inverse diff_minus_eq_add minus_mult_minus neg_equal_iff_equal uminus_add_conv_diff)
     then show ?thesis using 0 True  zero_less_mult_iff[of k "1 - int n"]
    proof -
      have "0 \<le> N * (int n - 1)"
        by (meson "0" N_nonneg diff_ge_0_iff_ge zero_le_mult_iff)
      then show ?thesis
        by (metis (no_types) \<open>N = - k\<close> add.commute distrib_left minus_add_cancel mult_minus1_right uminus_add_conv_diff)
    qed
   next
     case False
     then have "N = k" unfolding N_def
       by presburger
     then show ?thesis using 0 False
       by (metis N_nonneg add_increasing2 mult_nonneg_nonneg of_nat_0_le_iff)
   qed
   then have 1: "ord (\<pp>[^](N*n)\<otimes>x) \<ge> 0"
     using ord_mult k_def val_ord assms
     by (metis Qp_int_pow_nonzero eint.inject ord_p_pow_int p_nonzero)
   have 2: "\<pp>[^](N*n)\<otimes>x \<in> pow_res n x"
   proof-
     have "\<pp>[^](N*n) = (\<pp>[^]N)[^]n"
       using Qp_p_int_nat_pow_pow by blast
     then have "\<pp>[^]N \<in> nonzero Q\<^sub>p  \<and> \<pp>[^](N*n)\<otimes>x = x \<otimes> (\<pp>[^]N)[^]n"
       by (metis Qp.m_comm Qp.nonzero_closed Qp_int_pow_nonzero assms(2) p_nonzero)
     then show ?thesis unfolding pow_res_def
       by (metis (mono_tags, lifting) Qp.m_closed Qp.nonzero_closed assms(2) mem_Collect_eq p_intpow_closed(1))
   qed
   have 3: "\<pp>[^](N*n)\<otimes>x \<in> \<O>\<^sub>p"
     using 1 assms
     by (metis Q\<^sub>p_def Qp.nonzero_mult_closed Qp_int_pow_nonzero Z\<^sub>p_def val_ring_ord_criterion \<iota>_def p_nonzero padic_fields.zero_in_val_ring padic_fields_axioms)
   have 4: "x \<in> pow_res n (\<pp>[^](N*n)\<otimes>x)"
     using 2 equal_pow_resI[of x "\<pp>[^](N*n)\<otimes>x" n] pow_res_refl[of "\<pp>[^](N*n)\<otimes>x" n] assms
          Qp.nonzero_mult_closed p_intpow_closed(2) pow_res_refl Qp.nonzero_closed by metis
   have 5: "\<pp>[^](N*n)\<otimes>x \<in> (pow_res n x \<inter> \<O>\<^sub>p)"
     using 2 3 by blast
   have 6: "(SOME z. z \<in> (pow_res n x) \<inter> \<O>\<^sub>p) \<in> pow_res n x \<inter> \<O>\<^sub>p" using 5
     by (meson someI)
   obtain y where y_def: "y = (SOME z. z \<in> (pow_res n x) \<inter> \<O>\<^sub>p)"
     by blast
   then have A: "y \<in> pow_res n x"
     using "6" by blast
   then have "pow_res n x = pow_res n y"
     using equal_pow_resI[of x y n] assms y_def Qp.nonzero_closed nonzero_pow_res by blast
   then have 7: "x \<in> pow_res n y"
     using pow_res_refl[of x n] assms unfolding nonzero_def by blast
   have 8: "y \<in> nonzero Q\<^sub>p  "
     using y_def PP 6 A nonzero_pow_res[of x n] assms
     by blast
   have 9: "y \<in> \<O>\<^sub>p"
     using y_def "6" by blast
   have "y\<in>(\<lambda>S. SOME x. x \<in> S \<inter> \<O>\<^sub>p) ` pow_res_classes n \<and> y \<in> nonzero Q\<^sub>p \<and> y \<in> \<O>\<^sub>p \<and> x \<in> pow_res n y"
         using y_def PP 6 7 8 9 A nonzero_pow_res[of x n] assms
         by blast
   then show ?thesis unfolding nth_pow_wits_def by blast
 qed
 
 lemma nth_pow_wits_closed:
   assumes "n > 0"
   assumes "x \<in> nth_pow_wits n"
   shows "x \<in> carrier Q\<^sub>p" "x \<in> \<O>\<^sub>p" "x \<in> nonzero Q\<^sub>p" "\<exists> y \<in> pow_res_classes n. y = pow_res n x"
 proof-
   obtain c where c_def: "c \<in> pow_res_classes n \<and> x =   (SOME x. x \<in> (c \<inter> \<O>\<^sub>p))"
     by (metis (no_types, lifting) assms(2) image_iff nth_pow_wits_def)
   then obtain y where y_def: "y \<in> nonzero Q\<^sub>p \<and> c = pow_res n y"
     unfolding pow_res_classes_def by blast
   then obtain a where a_def: "a \<in> (nth_pow_wits n) \<and> a \<in> nonzero Q\<^sub>p \<and> a \<in> \<O>\<^sub>p \<and> y \<in> pow_res n a"
     using nth_pow_wits_covers[of n y] assms(1) by blast
   have 00: "pow_res n a = c"
     using equal_pow_resI[of a y n] y_def assms a_def unfolding nonzero_def by blast
   then have P :"a \<in> c \<inter> \<O>\<^sub>p"
     using pow_res_refl[of a n] assms a_def unfolding 00 nonzero_def by blast
   then show 0: "x \<in> \<O>\<^sub>p" using c_def
     by (metis Collect_mem_eq Int_Collect tfl_some)
   then show "x \<in> carrier Q\<^sub>p"
     using val_ring_memE by blast
   have 1: "c \<subseteq> nonzero Q\<^sub>p"
     using c_def nonzero_pow_res[of y n] unfolding pow_res_classes_def
     using assms(1) y_def by blast
   have "(SOME x. x \<in> (c \<inter> \<O>\<^sub>p)) \<in> (c \<inter> \<O>\<^sub>p)"
     using P tfl_some
     by (smt Int_def someI_ex)
   then have 2: "x \<in> c"
     using c_def by blast
   thus "x \<in> nonzero Q\<^sub>p"
     using 1  by blast
   show "\<exists> y \<in> pow_res_classes n. y = pow_res n x"
     using 00 2 c_def P a_def equal_pow_resI[of a x n] 0 val_ring_memE assms(1) by blast
 qed
 
 lemma finite_extensional_funcset:
   assumes "finite A"
   assumes "finite (B::'b set)"
   shows "finite (A \<rightarrow>\<^sub>E B)"
   using finite_PiE[of A "\<lambda>_. B"] assms by blast
 
 lemma nth_pow_wits_exists:
   assumes  "m > 0"
   assumes "c \<in> pow_res_classes m"
   shows "\<exists>x. x \<in> c \<inter> \<O>\<^sub>p"
 proof-
   obtain x where x_def: "x \<in> nonzero Q\<^sub>p \<and> pow_res m x = c"
     using assms unfolding pow_res_classes_def by blast
   obtain y where y_def: "y \<in> (nth_pow_wits m) \<and> y \<in> nonzero Q\<^sub>p \<and> y \<in> \<O>\<^sub>p \<and> x \<in> pow_res m y"
     using nth_pow_wits_covers assms x_def
     by blast
   have 0: "pow_res m x = pow_res m y"
     using x_def y_def equal_pow_resI Qp.nonzero_closed assms(1) by blast
   then have 1: "y \<in> pow_res m  x"
     using pow_res_refl[of y m ] y_def assms unfolding nonzero_def  by blast
   thus ?thesis using x_def y_def assms
     by blast
 qed
 
 lemma pow_res_classes_mem_eq:
   assumes "m > 0"
   assumes "a \<in> pow_res_classes m"
   assumes "x \<in> a"
   shows  "a = pow_res m x"
 proof-
   obtain y where y_def: "y \<in> nonzero Q\<^sub>p \<and> a = pow_res m y"
     using assms unfolding pow_res_classes_def by blast
   then show ?thesis using assms equal_pow_resI[of y x m]
     by (meson Qp.nonzero_closed nonzero_pow_res equal_pow_resI subsetD)
 qed
 
 lemma nth_pow_wits_neq_pow_res:
   assumes  "m > 0"
   assumes "x \<in> nth_pow_wits m"
   assumes "y \<in> nth_pow_wits m"
   assumes "x \<noteq> y"
   shows "pow_res m x \<noteq> pow_res m y"
 proof-
   obtain a where a_def: "a \<in> pow_res_classes m \<and> x = (\<lambda> S. (SOME x. x \<in> (S \<inter> \<O>\<^sub>p))) a"
     using assms unfolding nth_pow_wits_def by blast
   obtain b where b_def: "b \<in> pow_res_classes m \<and> y = (\<lambda> S. (SOME x. x \<in> (S \<inter> \<O>\<^sub>p))) b"
     using assms unfolding nth_pow_wits_def by blast
   have a_neq_b: "a \<noteq> b"
     using assms a_def b_def by blast
   have 0: "x \<in> a \<inter> \<O>\<^sub>p"
     using a_def nth_pow_wits_exists[of m a] assms
     by (meson someI_ex)
   have 1: "y \<in> b \<inter> \<O>\<^sub>p"
     using b_def nth_pow_wits_exists[of m b] assms
     by (meson someI_ex)
   have 2: "pow_res m x = a"
     using a_def  pow_res_classes_mem_eq[of m a x] assms 0
     by blast
   have 3: "pow_res m y = b"
     using b_def  pow_res_classes_mem_eq[of m b y] assms 1
     by blast
   show ?thesis
     by (simp add: "2" "3" a_neq_b)
 qed
 
 lemma nth_pow_wits_disjoint_pow_res:
   assumes  "m > 0"
   assumes "x \<in> nth_pow_wits m"
   assumes "y \<in> nth_pow_wits m"
   assumes "x \<noteq> y"
   shows "pow_res m x \<inter> pow_res m y =  {}"
   using assms nth_pow_wits_neq_pow_res disjoint_iff_not_equal
   by (metis (no_types, opaque_lifting) nth_pow_wits_closed(4) pow_res_classes_mem_eq)
 
 lemma nth_power_fact':
   assumes "0 < (n::nat)"
   shows "\<exists>m>0. \<forall>u\<in>carrier Q\<^sub>p. ac m u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n"
   using nth_power_fact[of n] assms
   by (metis less_one less_or_eq_imp_le linorder_neqE_nat neq0_conv)
 
 lemma equal_pow_res_criterion:
   assumes "N > 0"
   assumes "n > 0"
   assumes "\<forall> u \<in> carrier Q\<^sub>p. ac N u = 1 \<and> val u = 0 \<longrightarrow> u \<in> P_set n"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "c \<in> carrier Q\<^sub>p"
   assumes "a = b \<otimes> (\<one> \<oplus> c)"
   assumes "val c \<ge> N"
   shows "pow_res n a = pow_res n b"
 proof(cases "b = \<zero>")
   case True
   then have "a = \<zero>"
     using assms Qp.add.m_closed Qp.l_null Qp.one_closed by presburger
   then show ?thesis using True
     by blast
 next
   case False
   then have F0: "a \<div> b = \<one> \<oplus> c"
     by (metis Qp.Units_one_closed Qp.add.m_closed Qp.inv_cancelR(2) Qp.one_closed Qp.unit_factor assms(4) assms(5) assms(6) assms(7) field_inv(2) inv_in_frac(1))
   have "0 < eint N"
     using assms by (metis eint_ord_simps(2) of_nat_0_less_iff zero_eint_def)
   hence F1: "val \<one> < val c"
     using assms less_le_trans[of 0 N "val c"] unfolding val_one
     by blast
   hence F2: " val \<one> = val (\<one> \<oplus> c)"
     using assms val_one one_nonzero Qp.add.m_comm Qp.one_closed val_ultrametric_noteq by metis
   have "val \<one> + eint (int N) \<le> val (\<one> \<ominus> (\<one> \<oplus> c))"
   proof-
     have "val (\<one> \<ominus> (\<one> \<oplus> c)) = val c"
       using Qp.add.inv_closed Qp.minus_eq Qp.minus_sum Qp.one_closed Qp.r_neg2 assms(6) val_minus by presburger
     thus ?thesis
     unfolding val_one using assms F1 by (metis add.left_neutral)
   qed
   hence F3: "ac N \<one> = ac N (\<one> \<oplus> c)"
     using F2  F1 assms ac_val[of \<one> "\<one> \<oplus> c" N]
     by (metis Qp.add.m_closed Qp.one_closed val_nonzero)
   have F4: "\<one> \<oplus> c \<in> P_set n"
     using assms F1 F2 F3 val_one ac_one
     by (metis Qp.add.m_closed Qp.one_closed Qp.one_nonzero ac_inv'' ac_inv'''(1) ac_one')
   then show ?thesis
     using assms(2) assms(4) assms(5) assms(7) equal_pow_resI' by blast
 qed
 
 
 
 lemma pow_res_nat_pow:
   assumes "n > 0"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "pow_res n a = pow_res n b"
   shows "pow_res n (a[^](k::nat)) = pow_res n (b[^]k)"
   apply(induction k)
   using assms apply (metis Group.nat_pow_0)
   using assms pow_res_mult by (smt Qp.nat_pow_Suc2 Qp.nat_pow_closed)
 
 lemma pow_res_mult':
   assumes "n > 0"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> carrier Q\<^sub>p"
   assumes "c \<in> carrier Q\<^sub>p"
   assumes "d \<in> carrier Q\<^sub>p"
   assumes "e \<in> carrier Q\<^sub>p"
   assumes "f \<in> carrier Q\<^sub>p"
   assumes "pow_res n a = pow_res n d"
   assumes "pow_res n b = pow_res n e"
   assumes "pow_res n c = pow_res n f"
   shows "pow_res n (a \<otimes> b \<otimes> c) = pow_res n (d \<otimes> e \<otimes> f)"
 proof-
   have "pow_res n (a \<otimes> b) = pow_res n (d \<otimes> e)"
     using pow_res_mult assms  by meson
   then show ?thesis using pow_res_mult assms
     by (meson Qp.m_closed)
 qed
 
 lemma pow_res_disjoint:
   assumes "n > 0"
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "a \<notin> pow_res n \<one>"
   shows "\<not> (\<exists>y \<in> nonzero Q\<^sub>p. a = y[^]n)"
   using assms unfolding pow_res_def
   using Qp.l_one Qp.nonzero_closed by blast
 
 lemma pow_res_disjoint':
   assumes "n > 0"
   assumes "a \<in> nonzero Q\<^sub>p"
   assumes "pow_res n a \<noteq> pow_res n \<one>"
   shows "\<not> (\<exists>y \<in> nonzero Q\<^sub>p. a = y[^]n)"
 using assms pow_res_disjoint pow_res_refl
   by (metis pow_res_nth_pow)
 
 lemma pow_res_one_imp_nth_pow:
   assumes "n > 0"
   assumes "a \<in> pow_res n \<one>"
   shows "\<exists>y \<in> nonzero Q\<^sub>p. a = y[^]n"
   using assms unfolding pow_res_def
   using Qp.l_one Qp.nat_pow_closed Qp.nonzero_closed by blast
 
 lemma pow_res_eq:
   assumes "n > 0"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "b \<in> pow_res n a"
   shows "pow_res n b = pow_res n a"
 proof(cases "a = \<zero>")
   case True
   then show ?thesis using assms by (metis pow_res_zero singletonD)
 next
   case False
   then have a_nonzero: "a \<in> nonzero Q\<^sub>p" using Qp.not_nonzero_memE assms(2) by blast
   show ?thesis
   proof(cases "n = 1")
     case True
     then show ?thesis using a_nonzero assms
       using pow_res_one Q\<^sub>p_def Zp_def padic_fields_axioms by blast
   next
     case False
     then have "n \<ge> 2"
       using assms(1) by linarith
     then show ?thesis using False a_nonzero assms Qp.nonzero_closed nonzero_pow_res equal_pow_resI
       by blast
   qed
 qed
 
 lemma pow_res_classes_n_eq_one:
 "pow_res_classes 1 = {nonzero Q\<^sub>p}"
   unfolding pow_res_classes_def using pow_res_one Qp.one_nonzero by blast
 
 lemma nth_pow_wits_closed':
   assumes "n > 0"
   assumes "x \<in> nth_pow_wits n"
   shows "x \<in> \<O>\<^sub>p \<and> x \<in> nonzero Q\<^sub>p" using nth_pow_wits_closed
   assms  by blast
 
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Semialgebraic Sets Defined by Congruences\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>$p$-adic ord Congruence Sets\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 lemma carrier_is_univ_semialgebraic:
 "is_univ_semialgebraic (carrier Q\<^sub>p)"
   apply(rule is_univ_semialgebraicI)
   using Qp.to_R1_carrier carrier_is_semialgebraic
   by presburger
 
 lemma nonzero_is_univ_semialgebraic:
 "is_univ_semialgebraic (nonzero Q\<^sub>p)"
 proof-
   have "nonzero Q\<^sub>p = carrier Q\<^sub>p - {\<zero>}"
     unfolding nonzero_def by blast
   then show ?thesis using  diff_is_univ_semialgebraic[of "carrier Q\<^sub>p" "{\<zero>}"]
     by (metis Diff_empty Diff_insert0 carrier_is_univ_semialgebraic empty_subsetI
         finite.emptyI finite.insertI finite_is_univ_semialgebraic insert_subset)
 qed
 
 definition ord_congruence_set where
 "ord_congruence_set n a = {x \<in> nonzero Q\<^sub>p. ord x mod n = a}"
 
 lemma ord_congruence_set_nonzero:
 "ord_congruence_set n a \<subseteq> nonzero Q\<^sub>p"
   by (metis (no_types, lifting) mem_Collect_eq ord_congruence_set_def subsetI)
 
 lemma ord_congruence_set_closed:
 "ord_congruence_set n a \<subseteq> carrier Q\<^sub>p"
   using nonzero_def ord_congruence_set_nonzero
   unfolding nonzero_def
   by (meson Qp.nonzero_closed ord_congruence_set_nonzero subset_iff)
 
 lemma ord_congruence_set_memE:
   assumes "x \<in> ord_congruence_set n a"
   shows "x \<in> nonzero Q\<^sub>p"
         "ord x mod n = a"
   using assms ord_congruence_set_nonzero apply blast
   by (metis (mono_tags, lifting) assms mem_Collect_eq ord_congruence_set_def)
 
 lemma ord_congruence_set_memI:
   assumes "x \<in> nonzero Q\<^sub>p"
   assumes "ord x mod n = a"
   shows "x \<in> ord_congruence_set n a"
   using assms
   by (metis (mono_tags, lifting) mem_Collect_eq ord_congruence_set_def)
 
 text\<open>
   We want to prove that ord\_congruence\_set is a finite union of semialgebraic sets,
   hence is also semialgebraic.
 \<close>
 
 lemma pow_res_ord_cong:
   assumes "x \<in> carrier Q\<^sub>p"
   assumes "x \<in> ord_congruence_set n a"
   shows "pow_res n x \<subseteq> ord_congruence_set n a"
 proof fix y
   assume A: "y  \<in> pow_res n x"
   show "y \<in> ord_congruence_set (int n) a"
   proof-
     obtain a where a_def: "a \<in> nonzero Q\<^sub>p \<and> y = x \<otimes> (a[^]n)"
       using A pow_res_def[of n x] by blast
     have 0: "x \<in> nonzero Q\<^sub>p"
       using assms(2) ord_congruence_set_memE(1)
       by blast
     have 1: "y \<in> nonzero Q\<^sub>p"
       using A
       by (metis "0" Qp.integral Qp.nonzero_closed Qp.nonzero_mult_closed Qp_nat_pow_nonzero a_def not_nonzero_Qp)
     have 2: "ord y = ord x + n* ord  a"
       using a_def 0 1 Qp_nat_pow_nonzero nonzero_nat_pow_ord ord_mult
       by presburger
     show ?thesis
       apply(rule ord_congruence_set_memI)
       using assms ord_congruence_set_memE 2 1
        apply blast
       using "2" assms(2) ord_congruence_set_memE(2)
       by presburger
   qed
 qed
 
 lemma pow_res_classes_are_univ_semialgebraic:
   shows "are_univ_semialgebraic (pow_res_classes n)"
   apply(rule are_univ_semialgebraicI)
   using pow_res_classes_univ_semialg by blast
 
 lemma ord_congruence_set_univ_semialg:
   assumes "n \<ge> 0"
   shows "is_univ_semialgebraic (ord_congruence_set n a)"
 proof(cases "n = 0")
   case True
   have T0: "ord_congruence_set n a = {x \<in> nonzero Q\<^sub>p. ord x = a}"
     unfolding ord_congruence_set_def True by presburger
   have T1: "{x \<in> nonzero Q\<^sub>p. ord x = a} = {x \<in> nonzero Q\<^sub>p. val x = a}"
     apply(rule equalityI'')
     using val_ord apply blast
     using val_ord
     by (metis eint.inject)
   have T2: "{x \<in> nonzero Q\<^sub>p. val x = a} = {x \<in> carrier Q\<^sub>p. val x = a}"
     apply(rule equalityI'')
     using Qp.nonzero_closed apply blast
     by (metis iless_Suc_eq val_nonzero val_val_ring_prod zero_in_val_ring)
   show ?thesis unfolding T0 T1 T2 using univ_val_eq_set_is_univ_semialgebraic by blast
 next
   case False
   obtain F where F_def: "F = {S \<in> (pow_res_classes (nat n)). S \<subseteq>(ord_congruence_set n a) }"
     by blast
   have 0: "F \<subseteq> pow_res_classes (nat n)"
     using F_def by blast
   have 1: "finite F"
     using 0 False nat_mono[of 1 n] nat_numeral[] pow_res_classes_finite[of "nat n"] rev_finite_subset
     by (smt assms nat_one_as_int)
   have 2: "are_univ_semialgebraic F"
     apply(rule are_univ_semialgebraicI) using 0 pow_res_classes_are_univ_semialgebraic
     by (metis (mono_tags) are_univ_semialgebraicE are_univ_semialgebraic_def assms  nat_mono nat_numeral subset_iff)
   have 3: "\<Union> F = (ord_congruence_set n a)"
   proof
     show "\<Union> F \<subseteq> ord_congruence_set n a"
       using F_def
       by blast
     show "ord_congruence_set n a \<subseteq> \<Union> F"
     proof fix x
       assume A: "x \<in> ord_congruence_set n a"
       have x_nonzero: "x \<in> nonzero Q\<^sub>p"
         using A ord_congruence_set_memE(1) by blast
       have 0: "pow_res (nat n) x \<in> F"
         using A pow_res_classes_def F_def
         by (smt nonzero_def assms mem_Collect_eq nat_0_le ord_congruence_set_memE(1) pow_res_ord_cong)
       have 1: "x \<in> pow_res (nat n) x" using False x_nonzero assms pow_res_refl[of x "nat n"]
         using Qp.nonzero_closed by blast
       show "x \<in> \<Union> F"
         using 0 1
         by blast
     qed
   qed
   then show ?thesis
     using "1" "2" finite_union_is_univ_semialgebraic'
     by fastforce
 qed
 
 lemma ord_congruence_set_is_semialg:
   assumes "n \<ge> 0"
   shows "is_semialgebraic 1 (Qp_to_R1_set (ord_congruence_set n a))"
   using assms is_univ_semialgebraicE ord_congruence_set_univ_semialg
   by blast
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Congruence Sets for the order of the Evaluation of a Polynomial\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 lemma poly_map_singleton:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "poly_map n [f] x = [(Qp_ev f x)]"
   unfolding poly_map_def poly_tuple_eval_def
   using assms
   by (metis (no_types, lifting) Cons_eq_map_conv list.simps(8) restrict_apply')
 
 definition poly_cong_set where
 "poly_cong_set n f m a = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). (Qp_ev f x) \<noteq> \<zero>  \<and> (ord (Qp_ev f x) mod m = a)}"
 
 lemma poly_cong_set_as_pullback:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "poly_cong_set n f m a = poly_map n [f]  \<inverse>\<^bsub>n\<^esub>(Qp_to_R1_set (ord_congruence_set m a))"
 proof
   show "poly_cong_set n f m a \<subseteq> poly_map n [f]  \<inverse>\<^bsub>n\<^esub> ((\<lambda>a. [a]) ` ord_congruence_set m a)"
   proof fix x
     assume A: "x \<in> poly_cong_set n f m a"
     then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       by (metis (no_types, lifting) mem_Collect_eq poly_cong_set_def)
     have 1: "(Qp_ev f x) \<noteq> \<zero> "
       by (metis (mono_tags, lifting) A mem_Collect_eq poly_cong_set_def)
     have 2: "(ord (Qp_ev f x) mod m = a)"
       by (metis (mono_tags, lifting) A mem_Collect_eq poly_cong_set_def)
     have 3: "(Qp_ev f x) \<in> (ord_congruence_set m a)"
       using "0" "1" "2" eval_at_point_closed assms not_nonzero_Qp ord_congruence_set_memI
       by metis
     show "x \<in> poly_map n [f]  \<inverse>\<^bsub>n\<^esub> ((\<lambda>a. [a]) ` ord_congruence_set m a)"
     proof-
       have 00: "poly_map n [f] x = [(Qp_ev f x)]"
         using "0" assms poly_map_singleton by blast
       have 01: "[eval_at_point Q\<^sub>p x f] \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         using "0" assms eval_at_point_closed Qp.to_R1_closed by blast
       hence 02: "poly_map n [f] x \<in> (\<lambda>a. [a]) ` ord_congruence_set m a"
         using 3 "00" by blast
       then show "x \<in> poly_map n [f]  \<inverse>\<^bsub>n\<^esub> ((\<lambda>a. [a]) ` ord_congruence_set m a)"
         using 0 unfolding evimage_def
         by blast
     qed
   qed
   show "poly_map n [f] \<inverse>\<^bsub>n\<^esub> (\<lambda>a. [a]) ` ord_congruence_set m a
               \<subseteq> poly_cong_set n f m a"
   proof fix x
     assume A: "x \<in> poly_map n [f] \<inverse>\<^bsub>n\<^esub> ((\<lambda>a. [a]) ` (ord_congruence_set m a))"
     have 0: "((\<lambda>a. [a]) ` ord_congruence_set m a) \<subseteq> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
       using ord_congruence_set_closed Qp.to_R1_carrier by blast
     have "is_poly_tuple n [f]"
       using assms unfolding is_poly_tuple_def
       by (simp add: assms)
     then have 1:"poly_map n [f] \<inverse>\<^bsub>n\<^esub>((\<lambda>a. [a]) ` ord_congruence_set m a) \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       using 0 A assms One_nat_def
       by (metis extensional_vimage_closed)
    then have 2: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
      using A unfolding evimage_def by blast
     then have 3: "poly_map n [f] x \<in> ((\<lambda>a. [a]) ` ord_congruence_set m a)"
       using A assms 0 One_nat_def
       by blast
     have "poly_map n [f] x = [(Qp_ev f x)]"
       using "2" assms poly_map_singleton by blast
     then have "Qp_ev f x \<in> ord_congruence_set m a"
       using 3
       by (metis (mono_tags, lifting) image_iff list.inject)
     then show "x \<in> poly_cong_set n f m a"
       unfolding poly_cong_set_def
       by (metis (mono_tags, lifting) "2" Qp.nonzero_memE(2)
           mem_Collect_eq ord_congruence_set_memE(1) ord_congruence_set_memE(2))
   qed
 qed
 
 lemma singleton_poly_tuple:
 "is_poly_tuple n [f] \<longleftrightarrow> f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   unfolding is_poly_tuple_def
   by (metis (no_types, lifting) list.distinct(1) list.set_cases list.set_intros(1) set_ConsD subset_code(1))
 
 lemma poly_cong_set_is_semialgebraic:
   assumes "m \<ge> 0"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialgebraic n (poly_cong_set n f m a)"
 proof-
   have 0: "(\<lambda>a. [a]) ` ord_congruence_set m a \<in> semialg_sets 1"
   using assms
         ord_congruence_set_is_semialg[of m a]
   unfolding is_semialgebraic_def
   by blast
   have 1: "length [f] = 1"
   by simp
   hence " poly_map n [f] \<inverse>\<^bsub>n\<^esub> (\<lambda>a. [a]) ` ord_congruence_set m a \<in> semialg_sets n"
     using 0 singleton_poly_tuple[of n f] zero_neq_one assms
     pullback_is_semialg[of n "[f]" 1 "(\<lambda>a. [a]) ` ord_congruence_set m a"]
   unfolding is_semialgebraic_def
   by blast
   thus ?thesis using assms poly_cong_set_as_pullback[of f n m a]
   unfolding is_semialgebraic_def
   by presburger
 qed
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Congruence Sets for Angular Components\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 text\<open>If a set is a union of \<open>n\<close>-th power residues, then it is semialgebraic.\<close>
 
 lemma pow_res_union_imp_semialg:
   assumes "n \<ge> 1"
   assumes "S \<subseteq> nonzero Q\<^sub>p"
   assumes "\<And>x. x \<in> S \<Longrightarrow> pow_res n x \<subseteq> S"
   shows "is_univ_semialgebraic S"
 proof-
   obtain F where F_def: "F = {T. T \<in> pow_res_classes n \<and> T \<subseteq> S}"
     by blast
   have 0: "F \<subseteq> pow_res_classes n"
     using F_def by blast
   have 1: "finite F"
     using 0 pow_res_classes_finite[of n] assms(1) finite_subset
     by auto
   have 2: "are_univ_semialgebraic F"
     using 0
     by (meson are_univ_semialgebraicE are_univ_semialgebraicI assms(1)
         pow_res_classes_are_univ_semialgebraic padic_fields_axioms subsetD)
   have 3: "S = \<Union> F"
   proof
     show "S \<subseteq> \<Union> F"
     proof fix x
       assume A: "x \<in> S"
       then have "pow_res n x \<subseteq> S"
         using assms(3) by blast
       then have "pow_res n x \<in> F"
         using A assms(2) F_def pow_res_classes_def
         by (smt mem_Collect_eq subsetD)
       then have "pow_res n x \<subseteq> \<Union> F"
         by blast
       then show "x \<in> \<Union> F"
         using A assms(1) assms(2) pow_res_refl[of x n] unfolding nonzero_def by blast
     qed
     show "\<Union> F \<subseteq> S"
       using F_def
       by blast
   qed
   show ?thesis
     using 1 2 3 finite_union_is_univ_semialgebraic'
     by blast
 qed
 
 definition ac_cong_set1 where
 "ac_cong_set1 n y = {x \<in> carrier Q\<^sub>p. x \<noteq> \<zero> \<and> ac n x = ac n y}"
 
 lemma ac_cong_set1_is_univ_semialg:
   assumes "n > 0"
   assumes "b \<in> nonzero Q\<^sub>p"
   assumes "b \<in> \<O>\<^sub>p"
   shows "is_univ_semialgebraic (ac_cong_set1 n b)"
 proof(cases "n = 1 \<and> p = 2")
   case True
   have "(ac_cong_set1 n b) = nonzero Q\<^sub>p"
   proof
     have 0: "Units (Zp_res_ring n) = {1}"
     proof show "Units (Zp_res_ring n) \<subseteq> {1}"
       proof fix x assume A: "x \<in> Units (Zp_res_ring n)"
         have 0: "carrier (Zp_res_ring n) = {0..(int 2) - 1}"
           using True
           by (metis assms(1) int_ops(3) p_residues power_one_right residues.res_carrier_eq)
         have 1: "carrier (Zp_res_ring n) = {0..(1::int)}"
         proof- have "int 2 - 1 = (1::int)"
                     by linarith
                   then show ?thesis
                     using 0
                     by presburger
         qed
         have 15: "{0..(1::int)} = {0, (1::int)}"
           using atLeastAtMostPlus1_int_conv [of 0 "0::int"]
           by (smt atLeastAtMost_singleton insert_commute)
         have 2: "carrier (Zp_res_ring n) = {0,(1::int)}"
           using "1" "15"
           by blast
         have 3: "0 \<notin> Units (Zp_res_ring n)"
           using True zero_not_in_residue_units by blast
         have "x \<in> carrier (Zp_res_ring n)"
           using A unfolding Units_def by blast
         then have "x = 1" using A  2 3
           by (metis "1" atLeastAtMost_iff atLeastatMost_empty
               atLeastatMost_empty_iff2 linorder_neqE_linordered_idom mod_by_1 mod_pos_pos_trivial )
         then show "x \<in> {1}"
           by simp
       qed
       show "{1} \<subseteq> Units (Zp_res_ring n)"
         by (meson assms(1) empty_subsetI insert_subset residue_1_unit(1))
     qed
     show "ac_cong_set1 n b \<subseteq> nonzero Q\<^sub>p"
       by (metis (mono_tags, lifting) ac_cong_set1_def mem_Collect_eq not_nonzero_Qp subsetI)
     show "nonzero Q\<^sub>p \<subseteq> ac_cong_set1 n b"
     proof fix x
       assume A: "x \<in> nonzero Q\<^sub>p"
       then have P0: "ac n x = 1"
         using 0 ac_units assms(1) by blast
       have P1: "ac n b = 1"
         using assms 0 ac_units assms(1) by blast
       then have "ac n x = ac n b"
         using P0 by metis
       then show " x \<in> ac_cong_set1 n b"
         unfolding ac_cong_set1_def using A
       proof -
         have "x \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero>}"
           by (metis (no_types) \<open>x \<in> nonzero Q\<^sub>p\<close> nonzero_def )
         then show "x \<in> {r \<in> carrier Q\<^sub>p. r \<noteq> \<zero> \<and> ac n r = ac n b}"
           using \<open>ac n x = ac n b\<close> by force
       qed
     qed
   qed
   then show "is_univ_semialgebraic (ac_cong_set1 n b)"
     by (simp add: nonzero_is_univ_semialgebraic)
 next
   case F: False
   have F0: "2 \<le> card (Units (Zp_res_ring n))"
   proof(cases "n = 1")
     case True
     then have "field (Zp_res_ring n)"
        using p_res_ring_1_field by blast
     then have F00: "Units (Zp_res_ring n) = carrier (Zp_res_ring n) - {\<zero>\<^bsub>Zp_res_ring n\<^esub>}"
       using field.field_Units by blast
     have F01: "\<zero>\<^bsub>Zp_res_ring n\<^esub> \<in> carrier (Zp_res_ring n)"
       using assms(1) cring.cring_simprules(2) padic_integers.R_cring padic_integers_axioms by blast
     have F02: "card (carrier (Zp_res_ring n)) = p \<and> finite (carrier (Zp_res_ring n))"
       by (smt F01 True nat_eq_iff2 p_res_ring_zero p_residue_ring_car_memE(1) power_one_right residue_ring_card)
     have F03: "\<zero>\<^bsub>residue_ring (p ^ n)\<^esub> \<in> carrier (residue_ring (p ^ n)) "
       using F01 by blast
     have F04: "int (card (carrier (residue_ring (p ^ n)))) \<ge> int (card {\<zero>\<^bsub>residue_ring (p ^ n)\<^esub>}) "
       by (smt F02 F03 nat_int of_nat_0_le_iff of_nat_1 of_nat_power p_res_ring_0 p_res_ring_zero
           p_residue_ring_car_memE(1) power_increasing power_one_right residue_ring_card)
     have "card (carrier (residue_ring (p ^ n))) - 1 = p - 1"
       using F02 prime
       by (metis Totient.of_nat_eq_1_iff True less_imp_le_nat less_one nat_int nat_less_eq_zless
           of_nat_1 of_nat_diff of_nat_zero_less_power_iff p_residues pos_int_cases
           power_0 power_one_right residue_ring_card residues.m_gt_one zero_le_one)
     hence F05: "card (carrier (residue_ring (p ^ n)) - {\<zero>\<^bsub>residue_ring (p ^ n)\<^esub>}) = p - 1"
       using F02 F03 F04 card_Diff_singleton_if[of "(carrier (Zp_res_ring n))" "\<zero>\<^bsub>residue_ring (p^n)\<^esub>"]
            True int_ops(6)[of "card (carrier (residue_ring (p ^ n)))" "card {\<zero>\<^bsub>residue_ring (p ^ n)\<^esub>}"]
            p_res_ring_zero p_residue_ring_car_memE(1)
       by (metis)
   hence F06: "card (Units (Zp_res_ring n)) = p -1"
       using True F02 F01 F00
       by (metis p_res_ring_zero)
     have F04: "p - 1 \<ge>2 "
       using F prime
       by (meson True linorder_cases not_less prime_ge_2_int zle_diff1_eq)
     then show ?thesis
       using F03 F06
       by linarith
   next
     case False
     then show ?thesis
       by (metis assms(1) less_imp_le_nat mod2_gr_0 mod_less nat_le_linear nat_neq_iff residue_units_card_geq_2)
   qed
   show ?thesis
   apply(rule pow_res_union_imp_semialg[of "card (Units (Zp_res_ring n))"])
   using F0 assms apply linarith
   apply (metis (mono_tags, lifting) ac_cong_set1_def mem_Collect_eq not_nonzero_Qp subsetI)
 proof-
   fix x
   assume AA: "x \<in> ac_cong_set1 n b"
   show "pow_res (card (Units (Zp_res_ring n))) x \<subseteq> ac_cong_set1 n b"
   proof
     fix y
     assume A: "y \<in> pow_res (card (Units (Zp_res_ring n))) x"
     show "y \<in> ac_cong_set1 n b"
     proof-
       obtain k where k_def: "k = card (Units (Zp_res_ring n))"
         by blast
       have "k \<ge>2"
         using assms k_def  F F0 by blast
       then obtain a where a_def: "a \<in> nonzero Q\<^sub>p \<and> y = x \<otimes> (a[^]k)"
         using  k_def A pow_res_def[of k x]
         by blast
       have 0: "x \<in> nonzero Q\<^sub>p"
         using AA ac_cong_set1_def
         by (metis (mono_tags, lifting) mem_Collect_eq not_nonzero_Qp)
       have 1: "y \<in> nonzero Q\<^sub>p"
         by (metis "0" Qp.Units_m_closed Qp_nat_pow_nonzero Units_eq_nonzero \<open>\<And>thesis. (\<And>a. a \<in> nonzero Q\<^sub>p \<and> y = x \<otimes> a [^] k \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close>)
       have "ac n y = ac n x \<otimes>\<^bsub>Zp_res_ring n\<^esub> ac n (a[^]k)"
         using a_def 0 1 Qp_nat_pow_nonzero ac_mult'
         by blast
       then have 2: "ac n y = ac n x \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n a)[^]\<^bsub>Zp_res_ring n\<^esub> k"
       proof-
         have "ac n (a[^]k) = ac n a [^]\<^bsub>Zp_res_ring n\<^esub> k"
           using a_def assms(1) ac_nat_pow'[of a n k]
           by linarith
         then show ?thesis
           using \<open>ac n y = ac n x \<otimes>\<^bsub>Zp_res_ring n\<^esub> ac n (a[^]k)\<close>
           by presburger
       qed
       then have "ac n y = ac n x"
       proof-
         have "(ac n a) \<in> Units (Zp_res_ring n)"
           by (metis (mono_tags, opaque_lifting) a_def ac_units assms(1) )
         then have "(ac n a)^k mod (p^n) = 1"
           using k_def a_def ac_nat_pow ac_nat_pow' assms(1) residue_units_nilpotent
           using neq0_conv by presburger
         then have 00: "(ac n a)[^]\<^bsub>Zp_res_ring n\<^esub> k = 1"
           by (metis a_def ac_nat_pow ac_nat_pow' mod_by_1 power_0
               zero_neq_one)
         have "ac n x \<otimes>\<^bsub>residue_ring (p ^ n)\<^esub> ac n a [^]\<^bsub>residue_ring (p ^ n)\<^esub> k = ac n x \<otimes>\<^bsub>Zp_res_ring n\<^esub> \<one>\<^bsub>Zp_res_ring n\<^esub>"
           using 00  assms(1) p_res_ring_one by presburger
         hence "ac n x \<otimes>\<^bsub>residue_ring (p ^ n)\<^esub> ac n a [^]\<^bsub>residue_ring (p ^ n)\<^esub> k = ac n x"
           by (metis "0" Qp.nonzero_closed Qp.one_nonzero Qp.r_one ac_mult' ac_one' assms(1))
         then show ?thesis
           using 2 "0" 00
           by linarith
       qed
       then show ?thesis
         using  "1" AA nonzero_def
             ac_cong_set1_def[of n b] mem_Collect_eq
         by smt
     qed
   qed
 qed
 qed
 
 definition ac_cong_set where
 "ac_cong_set n k = {x \<in> carrier Q\<^sub>p. x \<noteq> \<zero> \<and> ac n x = k}"
 
 lemma ac_cong_set_is_univ_semialg:
   assumes "n >0 "
   assumes "k \<in> Units (Zp_res_ring n)"
   shows "is_univ_semialgebraic (ac_cong_set n k)"
 proof-
   have "k \<in> carrier (Zp_res_ring n)"
     using assms(2) Units_def[of "Zp_res_ring n"]
     by blast
   then have k_n: "([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) n = k"
     using assms
     by (metis Zp_int_inc_res mod_pos_pos_trivial p_residue_ring_car_memE(1) p_residue_ring_car_memE(2))
   obtain b where b_def: "b = \<iota> ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
     by blast
   have 0: "k mod p \<noteq> 0"
     using assms residue_UnitsE[of n k]
     by (metis le_eq_less_or_eq le_refl less_one nat_le_linear p_residues power_0
         power_one_right residues.mod_in_res_units residues_def zero_less_one
         zero_neq_one zero_not_in_residue_units zero_power)
   then have "val_Zp ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) = 0"
     using val_Zp_p_int_unit by blast
   then have 1: "val b = 0"
     by (metis Zp_int_inc_closed b_def val_of_inc)
   have 2: "b \<in> \<O>\<^sub>p"
     using b_def Zp_int_mult_closed
     by blast
   have "ord_Zp ([k] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) = 0"
     using 0 ord_Zp_p_int_unit by blast
   have "ac_Zp ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) = ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
     using "0" Zp_int_inc_closed ac_Zp_of_Unit ord_Zp_p_int_unit \<open>val_Zp ([k] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) = 0\<close>
     by blast
   then have "(angular_component b) = ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
     using b_def 1 2 angular_component_ord_zero[of b]
     by (metis Qp.int_inc_zero Qp.one_closed val_ring_memE Zp.int_inc_zero Zp.one_closed
         Zp.one_nonzero Zp_int_inc_closed angular_component_of_inclusion inc_closed inc_of_int
         inc_of_one inc_to_Zp local.val_zero not_nonzero_Qp val_ineq val_one zero_in_val_ring)
   then have "ac n b = k"
     using ac_def[of n b] k_n
     by (metis Qp_char_0_int Zp_defs(1) ac_def b_def inc_of_int inc_of_one)
   then have 3: "(ac_cong_set n k) = (ac_cong_set1 n b)"
     unfolding ac_cong_set_def ac_cong_set1_def
     by meson
   have 4: "b \<in> nonzero Q\<^sub>p"
     using 1 2 val_nonzero
     by (metis Qp.one_closed val_ring_memE Zp_def \<iota>_def local.one_neq_zero
         not_nonzero_Qp padic_fields.val_ring_memE padic_fields_axioms val_ineq val_one)
   then show ?thesis
     using 1 2 3 assms ac_cong_set1_is_univ_semialg[of n b] val_nonzero[of b 1]
     by presburger
 qed
 
 definition val_ring_constant_ac_set where
 "val_ring_constant_ac_set n k = {a \<in> \<O>\<^sub>p. val a = 0 \<and> ac n a = k}"
 
 lemma val_nonzero':
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "val a = eint k"
   shows "a \<in> nonzero Q\<^sub>p"
   using val_nonzero[of a "k + 1"]
   by (metis Suc_ile_eq assms(1) assms(2) eint_ord_code(3) val_nonzero)
 
 lemma val_ord':
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "a \<noteq>\<zero>"
   shows "val a = ord a"
   by (meson assms(1) assms(2) not_nonzero_Qp val_ord)
 
 lemma val_ring_constant_ac_set_is_univ_semialgebraic:
   assumes "n > 0"
   assumes "k \<noteq> 0"
   shows "is_univ_semialgebraic (val_ring_constant_ac_set n k)"
 proof(cases "val_ring_constant_ac_set n k = {}")
   case True
   then show ?thesis
     by (metis equals0D order_refl pow_res_union_imp_semialg subsetI)
 next
   case False
   then obtain b where b_def: "b \<in> val_ring_constant_ac_set n k"
     by blast
   have 0: "val_ring_constant_ac_set n k = q_ball n k 0 \<zero>"
   proof
     show "val_ring_constant_ac_set n k \<subseteq> q_ball n k 0 \<zero>"
     proof fix x assume A: "x \<in> val_ring_constant_ac_set n k" then
       show "x \<in> q_ball n k 0 \<zero>"
       proof-
         have 0: "x \<in> \<O>\<^sub>p \<and> val x = 0 \<and> ac n x = k"
           using A
           unfolding val_ring_constant_ac_set_def
           by blast
         then have x_car: "x \<in> carrier Q\<^sub>p"
           using val_ring_memE
           by blast
         then have 00: "x = x \<ominus> \<zero>"
           using Qp.ring_simprules by metis
         then have 1: "ac n (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<zero>) = k"
           using 0
           by presburger
         have 2: "val (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<zero>) = 0"
           using 0 00
           by metis
         have 3: "x \<in> nonzero Q\<^sub>p"
         proof(rule ccontr)
           assume " x \<notin> nonzero Q\<^sub>p "
           then have "x = \<zero>"
             using Qp.nonzero_memI x_car by blast
           then show False
             using 0 val_zero
             by (metis ac_def assms(2))
         qed
         have 4: "ord (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<zero>) = 0"
         proof(rule ccontr)
           assume "ord (x \<ominus> \<zero>) \<noteq> 0"
           then have "val (x \<ominus> \<zero>) \<noteq> 0"
             by (metis "00" "3" Qp.one_closed equal_val_imp_equal_ord(1) ord_one val_one)
           then show False
             using "2"
             by blast
         qed
         show ?thesis
           using 0 1 4
           unfolding  q_ball_def
           using x_car by blast
       qed
     qed
     show "q_ball n k 0 \<zero> \<subseteq> val_ring_constant_ac_set n k"
     proof fix x
       assume A: "x \<in> q_ball n k 0 \<zero>"
       then have 0: "ac n (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<zero>) = k"
         using q_ballE'(1) by blast
       have 1: "ord (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> \<zero>) = 0"
         using q_ball_def A
         by blast
       have 2: "x \<in> carrier Q\<^sub>p"
         using A q_ball_def by blast
       have 3: "ord x = 0"
         using 2 1 ring.ring_simprules[of Q\<^sub>p]
         by (metis Qp.ring_axioms)
       have 4: "ac n x = k"
         using 0 2 1  cring.axioms(1)[of Q\<^sub>p] ring.ring_simprules[of Q\<^sub>p]
          by (metis Qp.ring_axioms)
        have 5: "x \<in> \<O>\<^sub>p"
          using Qp_val_ringI[of x] 2 3 val_ord val_nonzero'
          by (metis Qp.integral_iff val_ring_memE Zp.nonzero_closed angular_component_closed
              angular_component_ord_zero image_eqI local.numer_denom_facts(1) local.numer_denom_facts(2)
              local.numer_denom_facts(4) not_nonzero_Qp)
        have 6: "x \<noteq> \<zero>"
          using 4 assms ac_def[of n x]
          by meson
        have 7: "val x = 0"
          using 6 3 2 assms val_ord' zero_eint_def by presburger
        show " x \<in> val_ring_constant_ac_set n k"
          unfolding val_ring_constant_ac_set_def
          using 7 6 5 4
          by blast
     qed
   qed
   obtain b where b_def: "b \<in> q_ball n k (0::int) \<zero>"
     using "0" b_def by blast
   have 1: "b \<in> carrier Q\<^sub>p \<and> ac n b = k"
     using b_def unfolding q_ball_def
     by (metis (mono_tags, lifting) "0" b_def mem_Collect_eq val_ring_constant_ac_set_def)
   then have 2: "b \<in> nonzero Q\<^sub>p"
     using 1 assms
     by (metis ac_def not_nonzero_Qp)
   have "q_ball n k 0 \<zero> = B\<^bsub>0 + int n\<^esub>[b]"
     using  1 b_def nonzero_def [of Q\<^sub>p] assms 0 2 c_ball_q_ball[of b n k "\<zero>" b 0]
     by (meson Qp.cring_axioms cring.cring_simprules(2))
   then have "is_univ_semialgebraic (q_ball n k (0::int) \<zero>) "
     using 1 ball_is_univ_semialgebraic[of b "0 + int n"]
     by  metis
   then show ?thesis
     using 0 by presburger
 qed
 
 definition val_ring_constant_ac_sets where
 "val_ring_constant_ac_sets n = val_ring_constant_ac_set n ` (Units (Zp_res_ring n))"
 
 lemma val_ring_constant_ac_sets_are_univ_semialgebraic:
   assumes "n > 0"
   shows "are_univ_semialgebraic (val_ring_constant_ac_sets n)"
 proof(rule are_univ_semialgebraicI)
   have 0: "\<not> coprime 0 p"
     using coprime_0_right_iff[of p] coprime_commute[of p 0] coprime_int_iff[of "nat p" 0]
         nat_dvd_1_iff_1 prime_gt_1_nat zdvd1_eq
     by (metis not_prime_unit prime)
   have "(0::int) \<notin>(Units (Zp_res_ring n))"
     apply(rule ccontr)
     using 0 assms residues.cring[of "p ^ n"] unfolding residues_def
       by (smt less_one not_gr_zero power_le_imp_le_exp power_less_imp_less_exp residue_UnitsE)
   fix x
   assume A: "x \<in> val_ring_constant_ac_sets n"
   then obtain k where k_def: "x = val_ring_constant_ac_set n k \<and> k \<in> Units (Zp_res_ring n)"
     by (metis image_iff val_ring_constant_ac_sets_def)
   then show "is_univ_semialgebraic x"
     using assms
     by (metis \<open>0 \<notin> Units (Zp_res_ring n)\<close> val_ring_constant_ac_set_is_univ_semialgebraic)
 qed
 
 definition ac_cong_set3 where
 "ac_cong_set3 n  = {as. \<exists> a b. a \<in> nonzero Q\<^sub>p \<and> b \<in> \<O>\<^sub>p \<and> val b = 0 \<and> (ac n a = ac n b) \<and> as = [a, b] }"
 
 definition ac_cong_set2 where
 "ac_cong_set2 n k = {as. \<exists> a b. a \<in> nonzero Q\<^sub>p \<and> b \<in> \<O>\<^sub>p \<and> val b = 0 \<and> (ac n a = k) \<and> (ac n b) = k \<and> as = [a, b] }"
 
 lemma ac_cong_set2_cartesian_product:
   assumes "k \<in> Units (Zp_res_ring n)"
   assumes "n > 0"
   shows "ac_cong_set2 n k = cartesian_product (to_R1` (ac_cong_set n k)) (to_R1` (val_ring_constant_ac_set n k))"
 proof
   show "ac_cong_set2 n k \<subseteq> cartesian_product ((\<lambda>a. [a]) ` ac_cong_set n k) ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k)"
   proof fix x
     assume A: "x \<in> ac_cong_set2 n k"
     show "x \<in> (cartesian_product ((\<lambda>a. [a]) ` ac_cong_set n k) ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k))"
       unfolding ac_cong_set_def val_ring_constant_ac_set_def ac_cong_set2_def
       apply(rule cartesian_product_memI[of _ Q\<^sub>p 1 _ 1])
        apply (metis (mono_tags, lifting) mem_Collect_eq subsetI Qp.to_R1_car_subset)
         apply (metis (no_types, lifting) val_ring_memE mem_Collect_eq subsetI Qp.to_R1_car_subset)
      proof-
        obtain a b where ab_def: "x = [a,b] \<and> a \<in> nonzero Q\<^sub>p \<and> b \<in> \<O>\<^sub>p \<and> val b = 0 \<and> (ac n a = k) \<and> (ac n b) = k"
          using A
          unfolding ac_cong_set_def val_ring_constant_ac_set_def ac_cong_set2_def
          by blast
        have 0: "take 1 x = [a]"
          by (simp add: ab_def)
        have 1: "drop 1 x = [b]"
          by (simp add: ab_def)
        have 2: "a \<in> {x \<in> carrier Q\<^sub>p. x \<noteq> \<zero> \<and> ac n x = k}"
          using ab_def nonzero_def
          by (smt mem_Collect_eq)
        have 3: "b \<in>  {a \<in> \<O>\<^sub>p. val a = 0 \<and> ac n a = k}"
          using ab_def
          by blast
        show "take 1 x \<in> (\<lambda>a. [a]) ` {x \<in> carrier Q\<^sub>p. x \<noteq> \<zero> \<and> ac n x = k}"
          using  0 2 by blast
        show "drop 1 x \<in> (\<lambda>a. [a]) ` {a \<in> \<O>\<^sub>p. val a = 0 \<and> ac n a = k}"
          using 1 3 by blast
      qed
   qed
   show "cartesian_product ((\<lambda>a. [a]) ` ac_cong_set n k) ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k) \<subseteq> ac_cong_set2 n k"
   proof fix x
     have 0: "(\<lambda>a. [a]) ` ac_cong_set n k \<subseteq> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
       using assms
       by (metis (no_types, lifting) ac_cong_set_def mem_Collect_eq subsetI Qp.to_R1_car_subset)
     have 1: "((\<lambda>a. [a]) ` val_ring_constant_ac_set n k) \<subseteq> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
       by (smt val_ring_memE mem_Collect_eq subsetI Qp.to_R1_carrier Qp.to_R1_subset val_ring_constant_ac_set_def)
     assume A: "x \<in> cartesian_product ((\<lambda>a. [a]) ` ac_cong_set n k) ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k)"
     then have "length x = 2"
       using 0 1 A cartesian_product_closed[of "((\<lambda>a. [a]) ` ac_cong_set n k)" Q\<^sub>p 1 "((\<lambda>a. [a]) ` val_ring_constant_ac_set n k)" 1]
       by (metis (no_types, lifting) cartesian_power_car_memE one_add_one subset_iff)
     then obtain a b where ab_def: "take 1 x = [a] \<and> drop 1 x = [b]"
       by (metis One_nat_def add_diff_cancel_left' drop0 drop_Cons_numeral numerals(1) pair_id plus_1_eq_Suc take0 take_Cons_numeral)
     have 2: " a \<in> (ac_cong_set n k) \<and> b \<in> (val_ring_constant_ac_set n k)"
     proof-
       have P0: "take 1 x \<in> (\<lambda>a. [a]) ` ac_cong_set n k"
         using 0 A cartesian_product_memE[of x "((\<lambda>a. [a]) ` ac_cong_set n k) " " ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k)" Q\<^sub>p 1]
         by blast
       have P1: "drop 1 x \<in> (\<lambda>a. [a]) ` val_ring_constant_ac_set n k"
         using 0 A cartesian_product_memE[of x "((\<lambda>a. [a]) ` ac_cong_set n k) " " ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k)" Q\<^sub>p 1]
         by blast
       have P2: "[a] \<in> (\<lambda>a. [a]) ` ac_cong_set n k"
         using P0 ab_def
         by metis
       have P3: "[b] \<in> (\<lambda>a. [a]) ` val_ring_constant_ac_set n k"
         using P1 ab_def by metis
       show ?thesis
         using P2 P3
         by blast
     qed
     have 3: "a \<in> nonzero Q\<^sub>p"
       using 2 assms nonzero_def [of Q\<^sub>p]  ac_cong_set_def[of n k]
       by blast
     have 4: "x = [a,b]"
       by (metis (no_types, lifting) \<open>length x = 2\<close> ab_def less_numeral_extra(1) nth_Cons_0 nth_take nth_via_drop pair_id)
     then have "\<exists>a b. a \<in> nonzero Q\<^sub>p \<and> b \<in> \<O>\<^sub>p \<and> val b = 0 \<and> ac n a = k \<and> ac n b = k \<and> x = [a, b]"
       using 2 3 ab_def  unfolding val_ring_constant_ac_set_def ac_cong_set_def
       by blast
     then show "x \<in> ac_cong_set2 n k"
       unfolding ac_cong_set2_def val_ring_constant_ac_set_def ac_cong_set_def
       by blast
   qed
 qed
 
 lemma ac_cong_set2_is_semialg:
   assumes "k \<in> Units (Zp_res_ring n)"
   assumes "n > 0"
   shows "is_semialgebraic 2 (ac_cong_set2 n k)"
   using  ac_cong_set_is_univ_semialg ac_cong_set2_cartesian_product[of k n]
       cartesian_product_is_semialgebraic[of 1 "((\<lambda>a. [a]) ` ac_cong_set n k)" 1 " ((\<lambda>a. [a]) ` val_ring_constant_ac_set n k)"]
   by (metis assms(1) assms(2) is_univ_semialgebraicE less_one less_or_eq_imp_le nat_neq_iff
       one_add_one val_ring_constant_ac_set_is_univ_semialgebraic zero_not_in_residue_units)
 
 lemma ac_cong_set3_as_union:
   assumes "n > 0"
   shows "ac_cong_set3 n = \<Union> (ac_cong_set2 n ` (Units (Zp_res_ring n)) )"
 proof
   show "ac_cong_set3 n \<subseteq> \<Union> (ac_cong_set2 n ` Units (Zp_res_ring n))"
   proof fix x assume A: "x \<in> ac_cong_set3 n"
     then have 0: "x \<in> (ac_cong_set2 n (ac n (x!0)))"
       unfolding ac_cong_set2_def ac_cong_set3_def
       by (smt mem_Collect_eq nth_Cons_0)
     have 1: "(ac n (x!0)) \<in> Units (Zp_res_ring n)"
       using A unfolding ac_cong_set3_def
       by (smt ac_units assms mem_Collect_eq nth_Cons_0)
     then show "x \<in> \<Union> (ac_cong_set2 n ` Units (Zp_res_ring n))"
       using 0
       by blast
   qed
   show "\<Union> (ac_cong_set2 n ` Units (Zp_res_ring n)) \<subseteq> ac_cong_set3 n"
   proof fix x assume A: "x \<in> \<Union> (ac_cong_set2 n ` Units (Zp_res_ring n))"
     obtain k where k_def: "x \<in> (ac_cong_set2 n k) \<and> k \<in> (Units (Zp_res_ring n))"
       using A by blast
     have 0: "k mod p \<noteq> 0"
       using k_def One_nat_def  Suc_le_eq assms less_numeral_extra(1)
           power_one_right residues.m_gt_one residues.mod_in_res_units
       by (metis p_residues residue_UnitsE zero_not_in_residue_units)
     obtain b where b_def: "b = ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
       by blast
     have "k \<noteq>0"
       using 0 mod_0
       by blast
     then have 1: "b \<in> nonzero Z\<^sub>p"
       using 0 b_def int_unit
       by (metis Zp.Units_nonzero Zp.zero_not_one)
     have 10: "ord_Zp b = 0" using 0 1
       using b_def ord_Zp_p_int_unit by blast
     have 2: "\<iota> b \<in> nonzero Q\<^sub>p" using k_def
       using "1" inc_of_nonzero by blast
     have 3: "angular_component (\<iota> b) = ac_Zp b"
       using "1" angular_component_of_inclusion
       by blast
     have 4: "ac_Zp b = b"
       using 1 10
       by (metis "3" Zp.r_one ac_Zp_factors' angular_component_closed inc_of_nonzero int_pow_0 mult_comm ord_Zp_def)
     have 5: "ac_Zp b n = k"
     proof-
       have "k \<in> carrier (Zp_res_ring n)"
         using k_def unfolding Units_def by blast
       then show ?thesis
         using b_def k_def 4 Zp_int_inc_res  mod_pos_pos_trivial
         by (metis p_residue_ring_car_memE(1) p_residue_ring_car_memE(2))
     qed
     then have "ac n (\<iota> b) = k"
       using 10 1 2 3 4 unfolding ac_def
       using Qp.not_nonzero_memI by metis
     then show "x \<in> ac_cong_set3 n"
       unfolding ac_cong_set3_def
       using k_def unfolding ac_cong_set2_def
       by (smt mem_Collect_eq)
   qed
 qed
 
 lemma ac_cong_set3_is_semialgebraic:
   assumes "n > 0"
   shows "is_semialgebraic 2 (ac_cong_set3 n)"
 proof-
   have 0: "finite (ac_cong_set2 n ` (Units (Zp_res_ring n)) )"
     using assms residues.finite_Units[of "p^n"] unfolding residues_def
     using p_residues residues.finite_Units by blast
   have 1: "are_semialgebraic 2 (ac_cong_set2 n ` (Units (Zp_res_ring n)) )"
     apply(rule are_semialgebraicI)
     using ac_cong_set2_is_semialg assms by blast
   show ?thesis
     using 0 1 ac_cong_set3_as_union
     by (metis (no_types, lifting) are_semialgebraicE assms finite_union_is_semialgebraic' is_semialgebraicE subsetI)
 qed
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Permutations of indices of semialgebraic sets\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 
 lemma fun_inv_permute:
   assumes "\<sigma> permutes {..<n}"
   shows "fun_inv \<sigma> permutes {..<n}"
         "\<sigma> \<circ> (fun_inv \<sigma>) = id"
         "(fun_inv \<sigma>) \<circ> \<sigma> = id"
   using assms unfolding fun_inv_def
   using permutes_inv apply blast
   using assms permutes_inv_o(1) apply blast
   using assms permutes_inv_o(2) by blast
 
 lemma poly_tuple_pullback_eq_poly_map_vimage:
   assumes "is_poly_tuple n fs"
   assumes "length fs = m"
   assumes "S \<subseteq> carrir (Q\<^sub>p\<^bsup>m\<^esup>)"
   shows "poly_map n fs  \<inverse>\<^bsub>n\<^esub> S = poly_tuple_pullback n S fs"
   unfolding poly_map_def poly_tuple_pullback_def evimage_def restrict_def
   using assms
   by (smt vimage_inter_cong)
 
 lemma permutation_is_semialgebraic:
   assumes "is_semialgebraic n S"
   assumes "\<sigma> permutes {..<n}"
   shows "is_semialgebraic n (permute_list \<sigma> ` S)"
 proof-
   have "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
     using assms gen_boolean_algebra_subset is_semialgebraic_def semialg_sets_def
     by blast
   then have "(permute_list \<sigma> ` S) = poly_tuple_pullback n S (permute_list (fun_inv \<sigma>) (pvar_list Q\<^sub>p n))"
     using Qp.cring_axioms assms pullback_by_permutation_of_poly_list'[of  \<sigma> n S] unfolding poly_map_def
     by blast
   then have 0: "(permute_list \<sigma> ` S) = poly_tuple_pullback n S (permute_list (fun_inv \<sigma>) (pvar_list Q\<^sub>p n))"
     using poly_tuple_pullback_def
     by blast
   have 1: "(fun_inv \<sigma>) permutes {..<n}"
     using assms  unfolding fun_inv_def
     using permutes_inv by blast
   then show ?thesis using 1 pullback_is_semialg[of n "(permute_list (fun_inv \<sigma>) (pvar_list Q\<^sub>p n))"]
                          permutation_of_poly_list_is_poly_list[of  n "(pvar_list Q\<^sub>p n)" "fun_inv \<sigma>"]
                          pvar_list_is_poly_tuple[of n] assms poly_tuple_pullback_eq_poly_map_vimage
   by (metis "0" \<open>S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)\<close> is_semialgebraic_def length_permute_list pvar_list_length)
 qed
 
 lemma permute_list_closed:
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "\<sigma> permutes {..<n}"
   shows "permute_list \<sigma> a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   apply(rule cartesian_power_car_memI)
   using assms cartesian_power_car_memE length_permute_list apply blast
   using assms cartesian_power_car_memE'' permute_list_set by blast
 
 lemma permute_list_closed':
   assumes "\<sigma> permutes {..<n}"
   assumes "permute_list \<sigma> a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   apply(rule cartesian_power_car_memI)
   apply (metis assms(2) cartesian_power_car_memE length_permute_list)
   using assms cartesian_power_car_memE'[of "permute_list \<sigma> a" Q\<^sub>p n]
   by (metis cartesian_power_car_memE in_set_conv_nth length_permute_list set_permute_list subsetI)
 
 lemma permute_list_compose_inv:
   assumes "\<sigma> permutes {..<n}"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "permute_list \<sigma> (permute_list (fun_inv \<sigma>) a) = a"
         "permute_list (fun_inv \<sigma>) (permute_list \<sigma> a) = a"
   using assms apply (metis cartesian_power_car_memE fun_inv_permute(3) permute_list_compose permute_list_id)
   using assms by (metis cartesian_power_car_memE fun_inv_permute(2) fun_inv_permute(1) permute_list_compose permute_list_id)
 
 lemma permutation_is_semialgebraic_imp_is_semialgebraic:
   assumes "is_semialgebraic n (permute_list \<sigma> ` S)"
   assumes "\<sigma> permutes {..<n}"
   shows "is_semialgebraic n S"
 proof-
   have "permute_list (fun_inv \<sigma>) ` (permute_list \<sigma> ` S) = S"
   proof-
     have 0: "(permute_list \<sigma> ` S) \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       using assms unfolding is_semialgebraic_def semialg_sets_def
       using gen_boolean_algebra_subset by blast
     have 1: "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
     proof fix x assume "x \<in> S" then show "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
         using 0 assms
         by (meson image_subset_iff permute_list_closed')
     qed
     show ?thesis
     proof show "permute_list (fun_inv \<sigma>) ` permute_list \<sigma> ` S \<subseteq> S"
         using 0 assms permute_list_compose_inv[of \<sigma>]  "1" image_iff image_subset_iff subsetD
         by smt
         show "S \<subseteq> permute_list (fun_inv \<sigma>) ` permute_list \<sigma> ` S"
         using 0 assms permute_list_compose_inv[of \<sigma>]
         by (smt "1" image_iff subset_eq)
     qed
   qed
   then show ?thesis using permutation_is_semialgebraic
     by (metis assms(1) assms(2)  fun_inv_permute(1))
 qed
 
 lemma split_cartesian_product_is_semialgebraic:
   assumes "i \<le> n"
   assumes "is_semialgebraic n A"
   assumes "is_semialgebraic m B"
   shows "is_semialgebraic (n + m) (split_cartesian_product n m i A B)"
   using assms cartesian_product_is_semialgebraic scp_permutes[of i n m]
         permutation_is_semialgebraic[of "n + m" "cartesian_product A B" "(scp_permutation n m i)"]
   unfolding split_cartesian_product_def
   by blast
 
 definition reverse_val_relation_set where
 "reverse_val_relation_set = {as \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (as ! 0) \<le> val (as ! 1)}"
 
 lemma  Qp_2_car_memE:
   assumes  "x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
   shows "x = [x!0, x!1]"
 proof-
   have "length x = 2"
     using assms cartesian_power_car_memE by blast
   then show ?thesis
     using pair_id by blast
 qed
 
 definition flip where
 "flip =  (\<lambda>i::nat. (if i = 0 then 1 else (if i = 1 then 0 else i)))"
 
 lemma flip_permutes:
 "flip permutes {0,1}"
  unfolding permutes_def flip_def
  by (smt mem_simps(1))
 
 lemma flip_eval:
 "flip 0 = 1"
 "flip 1 = 0"
   unfolding flip_def
   by auto
 
 lemma flip_x:
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
   shows "permute_list flip x = [x!1, x!0]"
 proof-
   have 0: "x = [x!0, x!1]"
     using assms Qp_2_car_memE by blast
   have 1: "length (permute_list flip x) = length [x!1, x!0]"
     using 0 unfolding permute_list_def
     by (metis length_Cons length_map map_nth)
   have 2: "\<And>i. i < 2 \<Longrightarrow> permute_list flip x ! i = [x!1, x!0] ! i"
   proof- fix i::nat assume A: "i < 2"
     show "permute_list flip x ! i = [x!1, x!0] ! i"
       using 0 unfolding permute_list_def
       by (smt flip_eval(1) flip_eval(2) length_Cons length_greater_0_conv list.simps(8) map_upt_Suc numeral_nat(7) upt_rec)
   qed
   have "\<And>i. i < length x \<Longrightarrow> permute_list flip x ! i = [x!1, x!0] ! i"
   proof-
   have 0:  "length x = 2"
       using assms cartesian_power_car_memE by blast
       show  "\<And>i. i < length x \<Longrightarrow> permute_list flip x ! i = [x!1, x!0] ! i" using 2 unfolding 0
         by blast
   qed
   thus ?thesis using 1
     by (metis length_permute_list nth_equalityI)
 qed
 
 lemma permute_with_flip_closed:
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>2::nat\<^esup>)"
   shows  "permute_list  flip x \<in> carrier (Q\<^sub>p\<^bsup>2::nat\<^esup>)"
   apply(rule permute_list_closed)
   using assms apply blast
 proof-
   have "{0::nat, 1} = {..<2::nat}"
     by auto
   thus "flip permutes {..<2}"
   using flip_permutes
   by auto
 qed
 
 lemma reverse_val_relation_set_semialg:
 "is_semialgebraic 2 reverse_val_relation_set"
 proof-
   have 1: "reverse_val_relation_set = permute_list flip `  val_relation_set"
     apply(rule equalityI')
   proof-
     show " \<And>x. x \<in> reverse_val_relation_set \<Longrightarrow> x \<in> permute_list flip ` val_relation_set"
       proof- fix x assume A: "x \<in> reverse_val_relation_set"
     have 0: "permute_list flip x = [x ! 1, x ! 0]"
       using flip_x[of x] A unfolding reverse_val_relation_set_def
       by blast
     have 1: "permute_list flip x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
       apply(rule permute_with_flip_closed) using A unfolding reverse_val_relation_set_def by blast
     have 2: "permute_list flip x \<in> val_relation_set"
       using 1 A unfolding 0 reverse_val_relation_set_def val_relation_set_def mem_Collect_eq
       by (metis Qp_2_car_memE list_hd list_tl)
     show "x \<in> permute_list flip ` val_relation_set"
       using flip_x[of x] A unfolding reverse_val_relation_set_def val_relation_set_def mem_Collect_eq
       by (metis (no_types, lifting) "1" "2" Qp_2_car_memE flip_x image_eqI list_tl nth_Cons_0 val_relation_set_def)
     qed
     show "\<And>x. x \<in> permute_list flip ` val_relation_set \<Longrightarrow> x \<in> reverse_val_relation_set"
     proof- fix x assume a: " x \<in> permute_list flip ` val_relation_set"
       then obtain y where y_def: "y \<in> val_relation_set \<and>x = permute_list flip y"
         by blast
       have y_closed: "y \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
         using y_def basic_semialg_set_memE(1) val_relation_semialg by blast
       have y_length: " length y = 2"
         using y_def basic_semialg_set_memE  val_relation_semialg
         by (metis cartesian_power_car_memE)
       obtain a b where ab_def: "y = [a,b]"
         using y_length pair_id by blast
       have 0: "a = y!0"
         using ab_def
         by (metis nth_Cons_0)
       have 1: "b = y!1"
         using ab_def
         by (metis cancel_comm_monoid_add_class.diff_cancel eq_numeral_extra(2) nth_Cons')
       have a_closed: "a \<in> carrier Q\<^sub>p"
         using 0 y_closed unfolding 0
         by (meson cartesian_power_car_memE' rel_simps(75) zero_order(5))
       have b_closed: "b \<in> carrier Q\<^sub>p"
       proof-
         have "1 < (2::nat)" by linarith
         thus ?thesis
         using y_closed unfolding 1
         by (meson cartesian_power_car_memE')
       qed
       have 2: "x = [b, a]" using flip_x[of y] y_def y_closed unfolding  ab_def unfolding 0 1
         using \<open>y \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>) \<Longrightarrow> permute_list flip y = [y ! 1, y ! 0]\<close> y_closed y_def by presburger
       have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
         using  y_def unfolding val_relation_set_def using permute_with_flip_closed[of y]
         by blast
       show " x \<in> reverse_val_relation_set"
         using x_closed  y_def
         unfolding val_relation_set_def reverse_val_relation_set_def  mem_Collect_eq 2 0 1
         by (metis Qp_2_car_memE list_hd list_tl)
     qed
   qed
   show ?thesis unfolding 1
     apply(rule permutation_is_semialgebraic)
     using val_relation_is_semialgebraic apply blast
     using flip_permutes
     by (metis Suc_1 insert_commute lessThan_0 lessThan_Suc numeral_nat(7))
 qed
 
 definition strict_val_relation_set where
 "strict_val_relation_set = {as \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (as ! 0) < val (as ! 1)}"
 
 definition val_diag where
 "val_diag = {as \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (as ! 0) = val (as ! 1)}"
 
 lemma val_diag_semialg:
 "is_semialgebraic 2 val_diag"
 proof-
   have "val_diag = val_relation_set \<inter>reverse_val_relation_set"
     apply(rule equalityI')
     apply(rule IntI)
     unfolding val_diag_def val_relation_set_def reverse_val_relation_set_def mem_Collect_eq
   apply simp
   apply simp
       apply(erule IntE) unfolding mem_Collect_eq
     using basic_trans_rules(24) by blast
   then show ?thesis using intersection_is_semialg
     by (simp add: reverse_val_relation_set_semialg val_relation_is_semialgebraic)
 qed
 
 lemma strict_val_relation_set_is_semialg:
 "is_semialgebraic 2 strict_val_relation_set"
 proof-
   have 0: "strict_val_relation_set = reverse_val_relation_set - val_diag"
     apply(rule equalityI')
     apply(rule DiffI)
     unfolding strict_val_relation_set_def val_diag_def val_relation_set_def reverse_val_relation_set_def mem_Collect_eq
     using order_le_less apply blast
   proof
     show "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>) \<and> val (x ! 0) < val (x ! 1) \<Longrightarrow> x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>) \<and> val (x ! 0) = val (x ! 1) \<Longrightarrow> False"
       using order_less_le by blast
     show " \<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (as ! 0) \<le> val (as ! 1)} - {as \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>). val (as ! 0) = val (as ! 1)} \<Longrightarrow>
          x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>) \<and> val (x ! 0) < val (x ! 1)"
       apply(erule DiffE) unfolding mem_Collect_eq using order_le_less by blast
   qed
   show ?thesis unfolding 0
     apply(rule diff_is_semialgebraic )
     using reverse_val_relation_set_semialg apply blast
         using val_diag_semialg by blast
 qed
 
 lemma singleton_length:
   "length [a] = 1"
   by auto
 
 lemma take_closed':
   assumes "m > 0"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)"
   shows "take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   apply(rule take_closed[of m "m+l"])
   apply simp using assms by blast
 
 lemma triple_val_ineq_set_semialg:
   shows "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1) \<and> val (as!1) \<le> val (as!2)}"
 proof-
   have 0: "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1)}"
   proof-
     have 0: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1)} = cartesian_product (reverse_val_relation_set) (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
     proof(rule equalityI')
       show " \<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 0) \<le> val (as ! 1)} \<Longrightarrow> x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
       proof- fix x assume A: " x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 0) \<le> val (as ! 1)}"
         then have 0: "length x = 3" unfolding mem_Collect_eq
           using cartesian_power_car_memE by blast
         obtain a where a_def: "a = [x!0, x!1]"
           by blast
         have a_length: "length a = 2"
         proof-
           have "a = x!0 #[x!1]"
             unfolding a_def
             by blast
           thus ?thesis using  length_Cons[of "x!0" "[x!1]"] unfolding singleton_length[of "x!1"]
             by presburger
         qed
         obtain b where b_def: "b = [x!2]"
           by blast
         have b_length: "length b = 1"
           unfolding b_def singleton_length by auto
         have a_closed: "a \<in> reverse_val_relation_set"
         proof-
           have 0: "a = take 2 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_take[of 2 x]
              apply linarith
           proof- fix i::nat assume  a: "i < 2" show "a ! i = take 2 x ! i "
               apply(cases "i = 0")
                apply (metis a_def nth_Cons_0 nth_take zero_less_numeral)
               by (smt "0" \<open>length (take 2 x) = min (length x) 2\<close> a_def linorder_neqE_nat min.commute min.strict_order_iff nth_take numeral_eq_iff one_less_numeral_iff pair_id pos2 rel_simps(22) rel_simps(48) rel_simps(9) semiring_norm(81))
           qed
           have 1: "a \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
             apply(rule cartesian_power_car_memI')
              apply (simp add: a_length)
             unfolding 0 using A unfolding mem_Collect_eq
             using cartesian_power_car_memE' by fastforce
           show ?thesis using 1 A unfolding a_def reverse_val_relation_set_def A mem_Collect_eq
              by (metis Qp_2_car_memE list_tl nth_Cons_0)
         qed
         have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
           apply(rule cartesian_power_car_memI)
           unfolding b_length apply blast
           apply(rule subsetI)
           unfolding b_def using A unfolding mem_Collect_eq using cartesian_power_car_memE'[of x Q\<^sub>p "3::nat"  "2::nat"]
           by simp
         have 2: "x = a@b"
           apply(rule nth_equalityI)
           using 0 unfolding a_length b_length  length_append[of a b] apply presburger
         proof- fix i assume A: "i < length x"
           then have A1: "i < 3"
             unfolding 0 by blast
           show "x ! i = (a @ b) ! i"
             apply(cases "i = 0")
              apply (metis a_def append.simps(2) nth_Cons_0)
             apply(cases "(i:: nat) = 1")
              apply (simp add: a_def)
 
           proof- assume a: "i \<noteq>0" "i \<noteq> 1"
             then have "i = 2"
               using A1 by presburger
             thus ?thesis
               by (metis a_length b_def nth_append_length)
           qed
         qed
         have 3: "a = take 2 x"
           apply(rule nth_equalityI)
           unfolding a_length  0 length_take[of 2 x]
            apply linarith
           proof- fix i::nat assume  a: "i < 2" show "a ! i = take 2 x ! i "
               apply(cases "i = 0")
                apply (metis a_def nth_Cons_0 nth_take zero_less_numeral)
               by (smt "0" \<open>length (take 2 x) = min (length x) 2\<close> a_def linorder_neqE_nat min.commute min.strict_order_iff nth_take numeral_eq_iff one_less_numeral_iff pair_id pos2 rel_simps(22) rel_simps(48) rel_simps(9) semiring_norm(81))
           qed
         show " x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
           apply(rule cartesian_product_memI[of _ Q\<^sub>p 2 _ 1])
              apply (simp add: is_semialgebraic_closed reverse_val_relation_set_semialg)
             apply blast
           using 3  a_closed apply blast
         proof-
           have "drop 2 x = b"
             unfolding 2 unfolding 3 using 0
             by simp
           then show "drop 2 x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
             using b_closed by blast
         qed
       qed
       show "\<And>x. x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) \<Longrightarrow> x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 0) \<le> val (as ! 1)}"
       proof fix x assume A: "x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
         then obtain a b where ab_def: "a \<in> reverse_val_relation_set" "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)" "x = a@b"
           using cartesian_product_memE'[of x reverse_val_relation_set "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
           by metis
         have a_length: "length a = 2"
           using ab_def unfolding reverse_val_relation_set_def
           using cartesian_power_car_memE by blast
         have "(0::nat)< 2" by presburger
         hence  0: "x!0 = a!0"
           unfolding ab_def using a_length
           by (metis append.simps(2) nth_Cons_0 pair_id)
         have "(1::nat)< 2" by presburger
         hence 1: "x!1 = a!1"
           unfolding ab_def using  a_length
           by (metis append.simps(2) less_2_cases nth_Cons_0 nth_Cons_Suc pair_id)
         obtain b' where b'_def: "b = [b']"
           using ab_def cartesian_power_car_memE
           by (metis (no_types, opaque_lifting) append_Cons append_Nil append_eq_append_conv min_list.cases singleton_length)
         have b'_closed: "b' \<in> carrier Q\<^sub>p"
           using b'_def ab_def cartesian_power_car_memE
           by (metis Qp.R1_memE' list_hd)
         have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>)"
           using  ab_def cartesian_power_append[of a Q\<^sub>p 2 b'] b'_def b'_closed
           unfolding b'_def ab_def(3) reverse_val_relation_set_def mem_Collect_eq
           by simp
         show "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>) \<and> val (x ! 0) \<le> val (x ! 1)"
           using x_closed ab_def unfolding reverse_val_relation_set_def mem_Collect_eq  0 1 by blast
       qed
     qed
     show ?thesis unfolding 0
       using cartesian_product_is_semialgebraic[of 2 reverse_val_relation_set 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
       by (simp add: carrier_is_semialgebraic reverse_val_relation_set_semialg)
   qed
   have 1: "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) \<le> val (as!2)}"
   proof-
     have 0: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) \<le> val (as!2)} = cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) (reverse_val_relation_set)"
     proof(rule equalityI')
       show "\<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) \<le> val (as ! 2)} \<Longrightarrow> x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set"
       proof-
        fix x assume A: " x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) \<le> val (as ! 2)}"
         then have 0: "length x = 3" unfolding mem_Collect_eq
           using cartesian_power_car_memE by blast
         obtain a where a_def: "a = [x!1, x!2]"
           by blast
         have a_length: "length a = 2"
         proof-
           have "a = x!1 #[x!2]"
             unfolding a_def
             by blast
           thus ?thesis using  length_Cons[of "x!1" "[x!2]"] unfolding singleton_length[of "x!2"]
             by presburger
         qed
         obtain b where b_def: "b = [x!0]"
           by blast
         have b_length: "length b = 1"
           unfolding b_def singleton_length by auto
         have a_closed: "a \<in> reverse_val_relation_set"
         proof-
           have 0: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
           proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
           qed
            have 1: "a \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
              using a_def  A drop_closed[of 1 3 x Q\<^sub>p] unfolding 0 mem_Collect_eq
               by (metis One_nat_def Suc_1 diff_Suc_1 numeral_3_eq_3 rel_simps(49) semiring_norm(77))
            show ?thesis using 1 A unfolding a_def reverse_val_relation_set_def A mem_Collect_eq
              by (metis Qp_2_car_memE list_tl nth_Cons_0)
         qed
         have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
           apply(rule cartesian_power_car_memI)
           unfolding b_length apply blast
           apply(rule subsetI)
           unfolding b_def using A unfolding mem_Collect_eq using cartesian_power_car_memE'[of x Q\<^sub>p "3::nat"  "0::nat"]
           by (metis b_def b_length in_set_conv_nth less_one Qp.to_R_to_R1 zero_less_numeral)
         have 2: "x = b@a"
           apply(rule nth_equalityI)
           using 0 unfolding a_length b_length  length_append[of b a] apply presburger
         proof- fix i assume A: "i < length x"
           then have A1: "i < 3"
             unfolding 0 by blast
           show "x ! i = (b @ a) ! i"
             apply(cases "i = 0")
              apply (metis append.simps(2) b_def nth_Cons_0)
             apply(cases "(i:: nat) = (1::nat)")
             using  append.simps a_def nth_Cons
              apply (metis b_length nth_append_length)
             apply(cases "(i:: nat) = (2::nat)")
             using A unfolding 0
             apply (metis a_def a_length arith_special(3) b_length list.inject nth_append_length_plus pair_id)
           proof-  assume A0: "i \<noteq>0" "i \<noteq> 1" "i \<noteq>2"
             then have "i \<ge> 3" by presburger
             then show "x ! i = (b @ a) ! i"
               using A unfolding 0 by presburger
           qed
         qed
         have 3: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
         proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
         qed
         show "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set"
           apply(rule cartesian_product_memI[of _ Q\<^sub>p 1 _ 2])
              apply (simp add: is_semialgebraic_closed reverse_val_relation_set_semialg)
           using reverse_val_relation_set_def apply blast
           using take_closed[of 1 3 x] A unfolding mem_Collect_eq apply auto[1]
           using a_closed unfolding 3 by blast
       qed
       show "\<And>x. x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set \<Longrightarrow> x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) \<le> val (as ! 2)}"
       proof fix x assume A: "x \<in>  cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set "
         then obtain a b where ab_def: "a \<in> reverse_val_relation_set" "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)" "x = b@a"
           using cartesian_product_memE'[of x  "carrier (Q\<^sub>p\<^bsup>1\<^esup>)" reverse_val_relation_set]
           by metis
         have a_length: "length a = 2"
           using ab_def unfolding reverse_val_relation_set_def
           using cartesian_power_car_memE by blast
         obtain b' where b'_def: "b = [b']"
           using ab_def cartesian_power_car_memE
           by (metis (no_types, opaque_lifting) append_Cons append_Nil append_eq_append_conv min_list.cases singleton_length)
         have b'_closed: "b' \<in> carrier Q\<^sub>p"
           using b'_def ab_def cartesian_power_car_memE
           by (metis Qp.R1_memE' list_hd)
         have b_length: "length b = 1"
           by (simp add: b'_def)
         have x_id: "x = b'#a"
           unfolding ab_def b'_def by auto
         have "(1::nat)< 2" by presburger
         hence  0: "x!1 = a!0"
           unfolding ab_def b'_def using a_length
           by (metis b'_def b_length nth_append_length pair_id)
         have 00: "2 = Suc 1"
           by auto
         have 1: "x!2 = a!1"
           using a_length nth_Cons[of b' a "2::nat"]
           unfolding x_id 00
           by (meson nth_Cons_Suc)
         have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>)"
           unfolding x_id b'_def using b'_closed cartesian_power_cons[of a Q\<^sub>p 2 b'] ab_def
           unfolding reverse_val_relation_set_def mem_Collect_eq
           by simp
 
         show "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>) \<and> val (x ! 1) \<le> val (x ! 2)"
           using x_closed ab_def unfolding reverse_val_relation_set_def mem_Collect_eq  0 1 by blast
       qed
     qed
     show ?thesis unfolding 0
       using cartesian_product_is_semialgebraic[of 2 reverse_val_relation_set 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
       by (metis add_num_simps(2) car_times_semialg_is_semialg one_plus_numeral reverse_val_relation_set_semialg)
   qed
   have 2: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1) \<and> val (as!1) \<le> val (as!2)}=
           {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1)} \<inter> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) \<le> val (as!2)}"
     by blast
   show ?thesis using intersection_is_semialg 0 1 unfolding 2 by blast
 qed
 
 lemma triple_val_ineq_set_semialg':
   shows "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1) \<and> val (as!1) < val (as!2)}"
 proof-
   have 0: "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1)}"
   proof-
     have 0: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1)} = cartesian_product (reverse_val_relation_set) (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
     proof(rule equalityI')
       show " \<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 0) \<le> val (as ! 1)} \<Longrightarrow> x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
       proof- fix x assume A: " x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 0) \<le> val (as ! 1)}"
         then have 0: "length x = 3" unfolding mem_Collect_eq
           using cartesian_power_car_memE by blast
         obtain a where a_def: "a = [x!0, x!1]"
           by blast
         have a_length: "length a = 2"
         proof-
           have "a = x!0 #[x!1]"
             unfolding a_def
             by blast
           thus ?thesis using  length_Cons[of "x!0" "[x!1]"] unfolding singleton_length[of "x!1"]
             by presburger
         qed
         obtain b where b_def: "b = [x!2]"
           by blast
         have b_length: "length b = 1"
           unfolding b_def singleton_length by auto
         have a_closed: "a \<in> reverse_val_relation_set"
         proof-
           have 0: "a = take 2 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_take[of 2 x]
              apply linarith
           proof- fix i::nat assume  a: "i < 2" show "a ! i = take 2 x ! i "
               apply(cases "i = 0")
                apply (metis a_def nth_Cons_0 nth_take zero_less_numeral)
               by (smt "0" \<open>length (take 2 x) = min (length x) 2\<close> a_def linorder_neqE_nat min.commute min.strict_order_iff nth_take numeral_eq_iff one_less_numeral_iff pair_id pos2 rel_simps(22) rel_simps(48) rel_simps(9) semiring_norm(81))
           qed
            have 1: "a \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
              using a_def 0  A unfolding mem_Collect_eq
              by (meson Qp_2I cartesian_power_car_memE' rel_simps(49) rel_simps(51) semiring_norm(77))
            show ?thesis using 1 A unfolding a_def reverse_val_relation_set_def A mem_Collect_eq
              by (metis Qp_2_car_memE list_tl nth_Cons_0)
         qed
         have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
           apply(rule cartesian_power_car_memI)
           unfolding b_length apply blast
           apply(rule subsetI)
           unfolding b_def using A unfolding mem_Collect_eq using cartesian_power_car_memE'[of x Q\<^sub>p "3::nat"  "2::nat"]
           by simp
         have 2: "x = a@b"
           apply(rule nth_equalityI)
           using 0 unfolding a_length b_length  length_append[of a b] apply presburger
         proof- fix i assume A: "i < length x"
           then have A1: "i < 3"
             unfolding 0 by blast
           show "x ! i = (a @ b) ! i"
             apply(cases "i = 0")
              apply (metis a_def append.simps(2) nth_Cons_0)
             apply(cases "(i:: nat) = 1")
              apply (simp add: a_def)
           proof- assume a: "i \<noteq>0" "i \<noteq> 1"
             then have "i = 2"
               using A1 by presburger
             thus ?thesis
               by (metis a_length b_def nth_append_length)
           qed
         qed
         have 3: "a = take 2 x"
           apply(rule nth_equalityI)
           unfolding a_length  0 length_take[of 2 x]
            apply linarith
           proof- fix i::nat assume  a: "i < 2" show "a ! i = take 2 x ! i "
               apply(cases "i = 0")
                apply (metis a_def nth_Cons_0 nth_take zero_less_numeral)
               by (smt "0" \<open>length (take 2 x) = min (length x) 2\<close> a_def linorder_neqE_nat min.commute min.strict_order_iff nth_take numeral_eq_iff one_less_numeral_iff pair_id pos2 rel_simps(22) rel_simps(48) rel_simps(9) semiring_norm(81))
           qed
         show " x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
           apply(rule cartesian_product_memI[of _ Q\<^sub>p 2 _ 1])
              apply (simp add: is_semialgebraic_closed reverse_val_relation_set_semialg)
             apply blast
           using 3  a_closed apply blast
         proof-
           have "drop 2 x = b"
             unfolding 2 unfolding 3 using 0
             by simp
           then show "drop 2 x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
             using b_closed by blast
         qed
       qed
       show "\<And>x. x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) \<Longrightarrow> x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 0) \<le> val (as ! 1)}"
       proof fix x assume A: "x \<in> cartesian_product reverse_val_relation_set (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
         then obtain a b where ab_def: "a \<in> reverse_val_relation_set" "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)" "x = a@b"
           using cartesian_product_memE'[of x reverse_val_relation_set "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
           by metis
         have a_length: "length a = 2"
           using ab_def unfolding reverse_val_relation_set_def
           using cartesian_power_car_memE by blast
         have "(0::nat)< 2" by presburger
         hence  0: "x!0 = a!0"
           unfolding ab_def using a_length
           by (metis append.simps(2) nth_Cons_0 pair_id)
         have "(1::nat)< 2" by presburger
         hence 1: "x!1 = a!1"
           unfolding ab_def using  a_length
           by (metis append.simps(2) less_2_cases nth_Cons_0 nth_Cons_Suc pair_id)
         obtain b' where b'_def: "b = [b']"
           using ab_def cartesian_power_car_memE
           by (metis (no_types, opaque_lifting) append_Cons append_Nil append_eq_append_conv min_list.cases singleton_length)
         have b'_closed: "b' \<in> carrier Q\<^sub>p"
           using b'_def ab_def cartesian_power_car_memE
           by (metis Qp.R1_memE' list_hd)
         have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>)"
           using  ab_def cartesian_power_append[of a Q\<^sub>p 2 b'] b'_def b'_closed
           unfolding b'_def ab_def(3) reverse_val_relation_set_def mem_Collect_eq
           by simp
         show "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>) \<and> val (x ! 0) \<le> val (x ! 1)"
           using x_closed ab_def unfolding reverse_val_relation_set_def mem_Collect_eq  0 1 by blast
       qed
     qed
     show ?thesis unfolding 0
       using cartesian_product_is_semialgebraic[of 2 reverse_val_relation_set 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
       by (simp add: carrier_is_semialgebraic reverse_val_relation_set_semialg)
   qed
   have 1: "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) < val (as!2)}"
   proof-
     have 0: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) < val (as!2)} = cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) (strict_val_relation_set)"
     proof(rule equalityI')
       show "\<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) < val (as ! 2)} \<Longrightarrow> x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set"
       proof- fix x assume A: " x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) < val (as ! 2)}"
         then have 0: "length x = 3" unfolding mem_Collect_eq
           using cartesian_power_car_memE by blast
         obtain a where a_def: "a = [x!1, x!2]"
           by blast
         have a_length: "length a = 2"
         proof-
           have "a = x!1 #[x!2]"
             unfolding a_def
             by blast
           thus ?thesis using  length_Cons[of "x!1" "[x!2]"] unfolding singleton_length[of "x!2"]
             by presburger
         qed
         obtain b where b_def: "b = [x!0]"
           by blast
         have b_length: "length b = 1"
           unfolding b_def singleton_length by auto
         have a_closed: "a \<in> strict_val_relation_set"
         proof-
           have 0: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
           proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
           qed
            have 1: "a \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
              using a_def  A drop_closed[of 1 3 x Q\<^sub>p] unfolding 0 mem_Collect_eq
               by (metis One_nat_def Suc_1 diff_Suc_1 numeral_3_eq_3 rel_simps(49) semiring_norm(77))
            show ?thesis using 1 A unfolding a_def strict_val_relation_set_def A mem_Collect_eq
              by (metis Qp_2_car_memE list_tl nth_Cons_0)
         qed
         have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
           apply(rule cartesian_power_car_memI)
           unfolding b_length apply blast
           apply(rule subsetI)
           unfolding b_def using A unfolding mem_Collect_eq using cartesian_power_car_memE'[of x Q\<^sub>p "3::nat"  "0::nat"]
           by (metis b_def b_length in_set_conv_nth less_one Qp.to_R_to_R1 zero_less_numeral)
         have 2: "x = b@a"
           apply(rule nth_equalityI)
           using 0 unfolding a_length b_length  length_append[of b a] apply presburger
         proof- fix i assume A: "i < length x"
           then have A1: "i < 3"
             unfolding 0 by blast
           show "x ! i = (b @ a) ! i"
             apply(cases "i = 0")
              apply (metis append.simps(2) b_def nth_Cons_0)
             apply(cases "(i:: nat) = (1::nat)")
             using  append.simps a_def nth_Cons
              apply (metis b_length nth_append_length)
             apply(cases "(i:: nat) = (2::nat)")
             using A unfolding 0
             apply (metis a_def a_length arith_special(3) b_length list.inject nth_append_length_plus pair_id)
           proof-  assume A0: "i \<noteq>0" "i \<noteq> 1" "i \<noteq>2"
             then have "i \<ge> 3" by presburger
             then show "x ! i = (b @ a) ! i"
               using A unfolding 0 by presburger
           qed
         qed
         have 3: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
         proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
         qed
         show "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set"
           apply(rule cartesian_product_memI[of _ Q\<^sub>p 1 _ 2])
              apply (simp add: is_semialgebraic_closed strict_val_relation_set_is_semialg)
           using strict_val_relation_set_def apply blast
           using take_closed[of 1 3 x Q\<^sub>p] A unfolding mem_Collect_eq apply auto[1]
           using a_closed unfolding 3 by blast
       qed
       show "\<And>x. x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set \<Longrightarrow> x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) < val (as ! 2)}"
       proof fix x assume A: "x \<in>  cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set "
         then obtain a b where ab_def: "a \<in> strict_val_relation_set" "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)" "x = b@a"
           using cartesian_product_memE'[of x  "carrier (Q\<^sub>p\<^bsup>1\<^esup>)" strict_val_relation_set]
           by metis
         have a_length: "length a = 2"
           using ab_def unfolding strict_val_relation_set_def
           using cartesian_power_car_memE by blast
         obtain b' where b'_def: "b = [b']"
           using ab_def cartesian_power_car_memE
           by (metis (no_types, opaque_lifting) append_Cons append_Nil append_eq_append_conv min_list.cases singleton_length)
         have b'_closed: "b' \<in> carrier Q\<^sub>p"
           using b'_def ab_def
           by (metis Qp.R1_memE' list_hd)
         have b_length: "length b = 1"
           by (simp add: b'_def)
         have x_id: "x = b'#a"
           unfolding ab_def b'_def by auto
         have "(1::nat)< 2" by presburger
         hence  0: "x!1 = a!0"
           unfolding ab_def b'_def using a_length
           by (metis b'_def b_length nth_append_length pair_id)
         have 00: "2 = Suc 1"
           by auto
         have 1: "x!2 = a!1"
           using a_length nth_Cons[of b' a "2::nat"]
           unfolding x_id 00
           by (meson nth_Cons_Suc)
         have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>)"
           unfolding x_id b'_def using b'_closed cartesian_power_cons[of a Q\<^sub>p 2 b'] ab_def
           unfolding strict_val_relation_set_def mem_Collect_eq
           by simp
         show "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>) \<and> val (x ! 1) < val (x ! 2)"
           using x_closed ab_def unfolding strict_val_relation_set_def mem_Collect_eq  0 1 by blast
       qed
     qed
     show ?thesis unfolding 0
       using cartesian_product_is_semialgebraic[of 2 reverse_val_relation_set 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
       by (metis add_num_simps(2) car_times_semialg_is_semialg one_plus_numeral strict_val_relation_set_is_semialg)
   qed
   have 2: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1) \<and> val (as!1) < val (as!2)}=
           {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!0) \<le> val (as!1)} \<inter> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) < val (as!2)}"
     by blast
   show ?thesis using intersection_is_semialg 0 1 unfolding 2 by blast
 qed
 
 lemma triple_val_ineq_set_semialg'':
   shows "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) < val (as!2)}"
 proof-
     have 0: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) < val (as!2)} = cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) (strict_val_relation_set)"
     proof(rule equalityI')
       show "\<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) < val (as ! 2)} \<Longrightarrow> x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set"
       proof- fix x assume A: " x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) < val (as ! 2)}"
         then have 0: "length x = 3" unfolding mem_Collect_eq
           using cartesian_power_car_memE by blast
         obtain a where a_def: "a = [x!1, x!2]"
           by blast
         have a_length: "length a = 2"
         proof-
           have "a = x!1 #[x!2]"
             unfolding a_def
             by blast
           thus ?thesis using  length_Cons[of "x!1" "[x!2]"] unfolding singleton_length[of "x!2"]
             by presburger
         qed
         obtain b where b_def: "b = [x!0]"
           by blast
         have b_length: "length b = 1"
           unfolding b_def singleton_length by auto
         have a_closed: "a \<in> strict_val_relation_set"
         proof-
           have 0: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
           proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
           qed
            have 1: "a \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
              using a_def  A drop_closed[of 1 3 x Q\<^sub>p] unfolding 0 mem_Collect_eq
               by (metis One_nat_def Suc_1 diff_Suc_1 numeral_3_eq_3 rel_simps(49) semiring_norm(77))
            show ?thesis using 1 A unfolding a_def strict_val_relation_set_def A mem_Collect_eq
              by (metis Qp_2_car_memE list_tl nth_Cons_0)
         qed
         have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
           apply(rule cartesian_power_car_memI)
           unfolding b_length apply blast
           apply(rule subsetI)
           unfolding b_def using A unfolding mem_Collect_eq using cartesian_power_car_memE'[of x Q\<^sub>p "3::nat"  "0::nat"]
           by (metis b_def b_length in_set_conv_nth less_one Qp.to_R_to_R1 zero_less_numeral)
         have 2: "x = b@a"
           apply(rule nth_equalityI)
           using 0 unfolding a_length b_length  length_append[of b a] apply presburger
         proof- fix i assume A: "i < length x"
           then have A1: "i < 3"
             unfolding 0 by blast
           show "x ! i = (b @ a) ! i"
             apply(cases "i = 0")
              apply (metis append.simps(2) b_def nth_Cons_0)
             apply(cases "(i:: nat) = (1::nat)")
             using  append.simps a_def nth_Cons
              apply (metis b_length nth_append_length)
             apply(cases "(i:: nat) = (2::nat)")
             using A unfolding 0
             apply (metis a_def a_length arith_special(3) b_length list.inject nth_append_length_plus pair_id)
           proof-  assume A0: "i \<noteq>0" "i \<noteq> 1" "i \<noteq>2"
             then have "i \<ge> 3" by presburger
             then show "x ! i = (b @ a) ! i"
               using A unfolding 0 by presburger
           qed
         qed
         have 3: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
         proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
         qed
         show "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set"
           apply(rule cartesian_product_memI[of _ Q\<^sub>p 1 _ 2])
              apply (simp add: is_semialgebraic_closed strict_val_relation_set_is_semialg)
           using strict_val_relation_set_def apply blast
           using take_closed[of 1 3 x] A unfolding mem_Collect_eq
           using one_le_numeral apply blast
           using a_closed unfolding 3 by blast
       qed
       show "\<And>x. x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set \<Longrightarrow> x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) < val (as ! 2)}"
       proof fix x assume A: "x \<in>  cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) strict_val_relation_set "
         then obtain a b where ab_def: "a \<in> strict_val_relation_set" "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)" "x = b@a"
           using cartesian_product_memE'[of x  "carrier (Q\<^sub>p\<^bsup>1\<^esup>)" strict_val_relation_set]
           by metis
         have a_length: "length a = 2"
           using ab_def unfolding strict_val_relation_set_def
           using cartesian_power_car_memE by blast
         obtain b' where b'_def: "b = [b']"
           using ab_def cartesian_power_car_memE
           by (metis (no_types, opaque_lifting) append_Cons append_Nil append_eq_append_conv min_list.cases singleton_length)
         have b'_closed: "b' \<in> carrier Q\<^sub>p"
           using b'_def ab_def cartesian_power_car_memE
           by (metis Qp.R1_memE' list_hd)
         have b_length: "length b = 1"
           by (simp add: b'_def)
         have x_id: "x = b'#a"
           unfolding ab_def b'_def by auto
         have "(1::nat)< 2" by presburger
         hence  0: "x!1 = a!0"
           unfolding ab_def b'_def using a_length
           by (metis b'_def b_length nth_append_length pair_id)
         have 00: "2 = Suc 1"
           by auto
         have 1: "x!2 = a!1"
           using a_length nth_Cons[of b' a "2::nat"]
           unfolding x_id 00
           by (meson nth_Cons_Suc)
         have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>)"
           unfolding x_id b'_def using b'_closed cartesian_power_cons[of a Q\<^sub>p 2 b'] ab_def
           unfolding strict_val_relation_set_def mem_Collect_eq
           by simp
 
         show "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>) \<and> val (x ! 1) < val (x ! 2)"
           using x_closed ab_def unfolding strict_val_relation_set_def mem_Collect_eq  0 1 by blast
       qed
     qed
     show ?thesis unfolding 0
       using cartesian_product_is_semialgebraic[of 2 reverse_val_relation_set 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
       by (metis add_num_simps(2) car_times_semialg_is_semialg one_plus_numeral strict_val_relation_set_is_semialg)
 qed
 
 lemma triple_val_ineq_set_semialg''':
   shows "is_semialgebraic 3 {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) \<le> val (as!2)}"
 proof-
     have 0: "{as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as!1) \<le> val (as!2)} = cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) (reverse_val_relation_set)"
     proof(rule equalityI')
       show "\<And>x. x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) \<le> val (as ! 2)} \<Longrightarrow> x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set"
       proof- fix x assume A: " x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) \<le> val (as ! 2)}"
         then have 0: "length x = 3" unfolding mem_Collect_eq
           using cartesian_power_car_memE by blast
         obtain a where a_def: "a = [x!1, x!2]"
           by blast
         have a_length: "length a = 2"
         proof-
           have "a = x!1 #[x!2]"
             unfolding a_def
             by blast
           thus ?thesis using  length_Cons[of "x!1" "[x!2]"] unfolding singleton_length[of "x!2"]
             by presburger
         qed
         obtain b where b_def: "b = [x!0]"
           by blast
         have b_length: "length b = 1"
           unfolding b_def singleton_length by auto
         have a_closed: "a \<in> reverse_val_relation_set"
         proof-
           have 0: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
           proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
           qed
            have 1: "a \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
              using a_def  A drop_closed[of 1 3 x Q\<^sub>p] unfolding 0 mem_Collect_eq
               by (metis One_nat_def Suc_1 diff_Suc_1 numeral_3_eq_3 rel_simps(49) semiring_norm(77))
            show ?thesis using 1 A unfolding a_def reverse_val_relation_set_def A mem_Collect_eq
              by (metis Qp_2_car_memE list_tl nth_Cons_0)
         qed
         have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
           apply(rule cartesian_power_car_memI)
           unfolding b_length apply blast
           apply(rule subsetI)
           unfolding b_def using A unfolding mem_Collect_eq using cartesian_power_car_memE'[of x Q\<^sub>p "3::nat"  "0::nat"]
           by (metis b_def b_length in_set_conv_nth less_one Qp.to_R_to_R1 zero_less_numeral)
         have 2: "x = b@a"
           apply(rule nth_equalityI)
           using 0 unfolding a_length b_length  length_append[of b a] apply presburger
         proof- fix i assume A: "i < length x"
           then have A1: "i < 3"
             unfolding 0 by blast
           show "x ! i = (b @ a) ! i"
             apply(cases "i = 0")
              apply (metis append.simps(2) b_def nth_Cons_0)
             apply(cases "(i:: nat) = (1::nat)")
             using  append.simps a_def nth_Cons
             apply (metis b_length nth_append_length)
             apply(cases "(i:: nat) = (2::nat)")
             using A unfolding 0
             apply (metis a_def a_length arith_special(3) b_length list.inject nth_append_length_plus pair_id)
           proof-  assume A0: "i \<noteq>0" "i \<noteq> 1" "i \<noteq>2"
             then have "i \<ge> 3" by presburger
             then show "x ! i = (b @ a) ! i"
               using A unfolding 0 by presburger
           qed
         qed
         have 3: "a = drop 1 x"
             apply(rule nth_equalityI)
             unfolding a_length  0 length_drop[of 1 x]
              apply linarith
         proof- fix i::nat assume  a: "i < 2" show " a ! i = drop 1 x ! i"
               apply(cases "i = 0")
               unfolding a_def using nth_drop[of 1 x i]
               apply (metis (no_types, opaque_lifting) "0" a_def arith_extra_simps(6) diff_is_0_eq' eq_imp_le eq_numeral_extra(1) flip_def flip_eval(1) less_numeral_extra(1) less_one less_or_eq_imp_le nat_add_left_cancel_le nat_le_linear nat_less_le nth_Cons_0 nth_drop numeral_neq_zero trans_less_add2 zero_less_diff)
               apply(cases "i = 1")
               using nth_drop[of 1 x i] unfolding 0
               apply (metis "0" a_def a_length list.simps(1) nat_1_add_1 nth_drop one_le_numeral pair_id semiring_norm(3))
               using a by presburger
         qed
         show "x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set"
           apply(rule cartesian_product_memI[of _ Q\<^sub>p 1 _ 2])
              apply (simp add: is_semialgebraic_closed reverse_val_relation_set_semialg)
           using reverse_val_relation_set_def apply blast
           using take_closed[of 1 3 x] A unfolding mem_Collect_eq  apply auto[1]
           using a_closed unfolding 3 by blast
       qed
       show "\<And>x. x \<in> cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set \<Longrightarrow> x \<in> {as \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>). val (as ! 1) \<le> val (as ! 2)}"
       proof fix x assume A: "x \<in>  cartesian_product (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) reverse_val_relation_set "
         then obtain a b where ab_def: "a \<in> reverse_val_relation_set" "b \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)" "x = b@a"
           using cartesian_product_memE'[of x  "carrier (Q\<^sub>p\<^bsup>1\<^esup>)" reverse_val_relation_set]
           by metis
         have a_length: "length a = 2"
           using ab_def unfolding reverse_val_relation_set_def
           using cartesian_power_car_memE by blast
         obtain b' where b'_def: "b = [b']"
           using ab_def cartesian_power_car_memE
           by (metis (no_types, opaque_lifting) append_Cons append_Nil append_eq_append_conv min_list.cases singleton_length)
         have b'_closed: "b' \<in> carrier Q\<^sub>p"
           using b'_def ab_def cartesian_power_car_memE
           by (metis Qp.R1_memE' list_hd)
         have b_length: "length b = 1"
           by (simp add: b'_def)
         have x_id: "x = b'#a"
           unfolding ab_def b'_def by auto
         have "(1::nat)< 2" by presburger
         hence  0: "x!1 = a!0"
           unfolding ab_def b'_def using a_length
           by (metis b'_def b_length nth_append_length pair_id)
         have 00: "2 = Suc 1"
           by auto
         have 1: "x!2 = a!1"
           using a_length nth_Cons[of b' a "2::nat"]
           unfolding x_id 00
           by (meson nth_Cons_Suc)
         have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>)"
           unfolding x_id b'_def using b'_closed cartesian_power_cons[of a Q\<^sub>p 2 b'] ab_def
           unfolding reverse_val_relation_set_def mem_Collect_eq
           by simp
 
         show "x \<in> carrier (Q\<^sub>p\<^bsup>3\<^esup>) \<and> val (x ! 1) \<le> val (x ! 2)"
           using x_closed ab_def unfolding reverse_val_relation_set_def mem_Collect_eq  0 1 by blast
       qed
     qed
     show ?thesis unfolding 0
       using cartesian_product_is_semialgebraic[of 2 reverse_val_relation_set 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]
       by (metis add_num_simps(2) car_times_semialg_is_semialg one_plus_numeral reverse_val_relation_set_semialg)
 qed
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Semialgebraic Functions\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 text\<open>
   The most natural way to define a semialgebraic function $f: \mathbb{Q}_p^n \to \mathbb{Q}_p$ is a
   function whose graph is a semialgebraic subset of $\mathbb{Q}_p^{n+1}$. However, the definition
   given here is slightly different, and devised by Denef in \cite{denef1986} in order to prove
   Macintyre's theorem. As Denef notes, we can use Macintyre's theorem to deduce that the given
   definition perfectly aligns with the intuitive one.
 \<close>
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Defining Semialgebraic Functions\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 text\<open>Apply a function f to the tuple consisting of the first n indices, leaving the remaining indices
 unchanged\<close>
 
 definition partial_image where
 "partial_image m f xs = (f (take m xs))#(drop m xs)"
 
 definition partial_pullback where
 "partial_pullback m f l S = (partial_image m f)  \<inverse>\<^bsub>m+l\<^esub> S "
 
 lemma partial_pullback_memE:
   assumes "as \<in> partial_pullback m f l S"
   shows "as \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)" "partial_image m f as \<in> S"
   using assms apply (metis evimage_eq partial_pullback_def)
   using assms unfolding partial_pullback_def
   by blast
 
 lemma partial_pullback_closed:
 "partial_pullback m f l S \<subseteq> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   using partial_pullback_memE(1) by blast
 
 lemma partial_pullback_memI:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>m + k\<^esup>)"
   assumes "(f (take m as))#(drop m as) \<in> S"
   shows "as \<in> partial_pullback m f k S"
   using assms unfolding partial_pullback_def partial_image_def evimage_def
   by blast
 
 lemma partial_image_eq:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "bs \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   assumes "x = as @ bs"
   shows "partial_image n f x = (f as)#bs"
 proof-
   have 0: "(take n x) = as"
     by (metis append_eq_conv_conj assms(1) assms(3) cartesian_power_car_memE)
   have 1: "drop n x = bs"
     by (metis "0" append_take_drop_id assms(3) same_append_eq)
   show ?thesis using 0 1 unfolding partial_image_def
     by blast
 qed
 
 lemma partial_pullback_memE':
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "bs \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   assumes "x = as @ bs"
   assumes "x \<in> partial_pullback n f k S"
   shows "(f as)#bs \<in> S"
   using partial_pullback_memE[of x n f k S] partial_image_def[of n f x]
   by (metis assms(1) assms(2) assms(3) assms(4) partial_image_eq)
 
 text\<open>Partial pullbacks have the same algebraic properties as pullbacks\<close>
 
 lemma partial_pullback_intersect:
 "partial_pullback m f l (S1 \<inter> S2) = (partial_pullback m f l S1) \<inter> (partial_pullback m f l S2)"
   unfolding partial_pullback_def
   by simp
 
 lemma partial_pullback_union:
 "partial_pullback m f l (S1 \<union> S2) = (partial_pullback m f l S1) \<union> (partial_pullback m f l S2)"
   unfolding partial_pullback_def
   by simp
 
 lemma cartesian_power_drop:
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
   shows "drop n x \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
   apply(rule cartesian_power_car_memI)
   using assms cartesian_power_car_memE
    apply (metis add_diff_cancel_left' length_drop)
   using assms cartesian_power_car_memE''
   by (metis order.trans set_drop_subset)
 
 lemma partial_pullback_complement:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>) - S) = carrier (Q\<^sub>p\<^bsup>m + l\<^esup>) - (partial_pullback m f l S) "
   apply(rule equalityI)
   using partial_pullback_def[of m f l "(carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>) - S)"]
         partial_pullback_def[of m f l S]
    apply (smt Diff_iff evimage_Diff partial_pullback_memE(1) subsetI)
 proof fix x assume A: " x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>) - partial_pullback m f l S"
   show " x \<in> partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>) - S) "
     apply(rule partial_pullback_memI)
     using A
      apply blast
   proof
     have 00: "Suc l = l + 1"
       by auto
     have 0: "drop m x \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
       by (meson A DiffD1 cartesian_power_drop)
     have 1: "take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       using A by (meson DiffD1 le_add1 take_closed)
     have "f (take m x) # drop m x \<in> carrier (Q\<^sub>p\<^bsup>l+1\<^esup>) "
       using assms 0 1 00 cartesian_power_cons[of "drop m x" Q\<^sub>p l "f (take m x)"]
       by blast
     thus "f (take m x) # drop m x \<in> carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>) "
       using 00 by metis
     show "f (take m x) # drop m x \<notin> S"
       using A unfolding partial_pullback_def partial_image_def
       by blast
   qed
 qed
 
 lemma partial_pullback_carrier:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>)) = carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   apply(rule equalityI)
   using partial_pullback_memE(1) apply blast
 proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   show "x \<in> partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>))"
     apply(rule partial_pullback_memI)
   using A cartesian_power_drop[of x m l] assms
    apply blast
 proof-
   have "f (take m x) \<in> carrier Q\<^sub>p"
     using A  assms take_closed[of m "m+l" x Q\<^sub>p]
     by (meson Pi_mem le_add1)
   then show "f (take m x) # drop m x \<in> carrier (Q\<^sub>p\<^bsup>Suc l\<^esup>)"
     using cartesian_power_drop[of x m l]
     by (metis A add.commute cartesian_power_cons plus_1_eq_Suc)
 qed
 qed
 
 text\<open>Definition 1.4 from Denef\<close>
 
 definition is_semialg_function where
 "is_semialg_function m f = ((f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p)  \<and>
                           (\<forall>l \<ge> 0. \<forall>S \<in> semialg_sets (1 + l). is_semialgebraic (m + l) (partial_pullback m f l S)))"
 
 lemma is_semialg_function_closed:
   assumes "is_semialg_function m f"
   shows "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   using is_semialg_function_def assms by blast
 
 lemma is_semialg_functionE:
   assumes "is_semialg_function m f"
   assumes "is_semialgebraic (1 + k) S"
   shows " is_semialgebraic (m + k) (partial_pullback m f k S)"
   using is_semialg_function_def assms
   by (meson is_semialgebraicE le0)
 
 lemma is_semialg_functionI:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "\<And>k  S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (m + k) (partial_pullback m f k S)"
   shows "is_semialg_function m f"
   using assms unfolding is_semialg_function_def
   by blast
 
 text\<open>Semialgebraicity for functions can be verified on basic semialgebraic sets \<close>
 
 lemma is_semialg_functionI':
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "\<And>k  S. S \<in> basic_semialgs (1 + k) \<Longrightarrow> is_semialgebraic (m + k) (partial_pullback m f k S)"
   shows "is_semialg_function m f"
   apply(rule is_semialg_functionI)
   using assms(1) apply blast
 proof-
   show "\<And>k S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (m + k) (partial_pullback m f k S)"
   proof- fix k S assume A: "S \<in> semialg_sets (1 + k)"
     show "is_semialgebraic (m + k) (partial_pullback m f k S)"
       apply(rule gen_boolean_algebra.induct[of S "carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)" "basic_semialgs (1 + k)"])
         using A unfolding semialg_sets_def
           apply blast
         using partial_pullback_carrier assms carrier_is_semialgebraic plus_1_eq_Suc apply presburger
         apply (metis assms(1) assms(2) carrier_is_semialgebraic intersection_is_semialg partial_pullback_carrier partial_pullback_intersect plus_1_eq_Suc)
         using partial_pullback_union union_is_semialgebraic apply presburger
         using assms(1) complement_is_semialg partial_pullback_complement plus_1_eq_Suc by presburger
   qed
 qed
 
 text\<open>Graphs of semialgebraic functions are semialgebraic\<close>
 abbreviation graph where
 "graph \<equiv> fun_graph Q\<^sub>p"
 
 lemma graph_memE:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "x \<in> graph m f"
   shows "f (take m x) = x!m"
         "x = (take m x)@[f (take m x)]"
         "take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
 proof-
   obtain a where a_def:  "a\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> x = a @ [f a]"
     using assms
     unfolding fun_graph_def
     by blast
   then have 0: "a = take m x"
     by (metis append_eq_conv_conj cartesian_power_car_memE)
   then show "f (take m x) = x!m"
     by (metis a_def cartesian_power_car_memE nth_append_length)
   show "x = (take m x)@[f (take m x)]"
     using "0" a_def
     by blast
   show "take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
     using "0" a_def by blast
 qed
 
 lemma graph_memI:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "f (take m x) = x!m"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m+1\<^esup>)"
   shows "x \<in> graph m f"
 proof-
   have 0: "take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
     apply(rule take_closed[of _ "m + 1"])
      apply simp
        using assms(3) by blast
   have "x = (take m x)@[x!m]"
   by (metis \<open>take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)\<close> add.commute
       assms(3) cartesian_power_car_memE length_append_singleton lessI
       nth_equalityI nth_take plus_1_eq_Suc take_Suc_conv_app_nth)
   then have "x = (take m x)@[f (take m x)]"
     using assms(2)
     by presburger
   then show ?thesis
     using assms 0
     unfolding fun_graph_def
     by blast
 qed
 
 lemma graph_mem_closed:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "x \<in> graph m f"
   shows "x \<in> carrier (Q\<^sub>p\<^bsup>m+1\<^esup>)"
 proof(rule cartesian_power_car_memI')
   show "length x = m + 1"
     using assms graph_memE[of f m x]
     by (smt Groups.add_ac(2) cartesian_power_car_memE fun_graph_def length_append_singleton mem_Collect_eq plus_1_eq_Suc)
   show "\<And>i. i < m + 1 \<Longrightarrow> x ! i \<in> carrier Q\<^sub>p"
   proof- fix i assume A: "i < m + 1"
     then show "x ! i \<in> carrier Q\<^sub>p"
     proof(cases "i = m")
       case True
       then show ?thesis using graph_memE[of f m x]
         by (metis PiE assms(1) assms(2))
     next
       case False
       then show ?thesis using graph_memE[of f m x]
         by (metis \<open>i < m + 1\<close> add.commute assms(1) assms(2) cartesian_power_car_memE' less_SucE nth_take plus_1_eq_Suc)
     qed
   qed
 qed
 
 lemma graph_closed:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "graph m f \<subseteq> carrier (Q\<^sub>p\<^bsup>m+1\<^esup>)"
   using assms graph_mem_closed
   by blast
 
 text\<open>The \<open>m\<close>-dimensional diagonal set is semialgebraic\<close>
 
 notation diagonal ("\<Delta> ")
 
 lemma diag_is_algebraic:
   shows "is_algebraic Q\<^sub>p (n + n) (\<Delta> n)"
   using Qp.cring_axioms diagonal_is_algebraic
   by blast
 
 lemma diag_is_semialgebraic:
   shows "is_semialgebraic (n + n) (\<Delta> n)"
   using diag_is_algebraic is_algebraic_imp_is_semialg
   by blast
 
 text\<open>Transposition permutations\<close>
 
 definition transpose where
 "transpose i j = (Fun.swap i j id)"
 
 lemma transpose_permutes:
   assumes "i< n"
   assumes "j < n"
   shows "transpose i j permutes {..<n}"
   unfolding permutes_def transpose_def
 proof
   show "\<forall>x. x \<notin> {..<n} \<longrightarrow> Fun.swap i j id x = x"
     using assms by (auto simp: Transposition.transpose_def)
   show "\<forall>y. \<exists>!x. Fun.swap i j id x = y"
   proof  fix y show "\<exists>!x. Fun.swap i j id x = y"
       using swap_id_eq[of i j y]
   by (metis eq_id_iff swap_apply(1) swap_apply(2) swap_id_eq swap_self)
 qed
 qed
 
 lemma transpose_alt_def:
 "transpose a b x = (if x = a then b else if x = b then a else x)"
   using swap_id_eq
   by (simp add: transpose_def)
 
 definition last_to_first where
 "last_to_first n = (\<lambda>i. if i = (n-1) then 0 else if i < n-1 then i + 1 else i)"
 
 definition first_to_last where
 "first_to_last n = fun_inv (last_to_first n)"
 
 lemma last_to_first_permutes:
   assumes "(n::nat) > 0"
   shows "last_to_first n permutes {..<n}"
   unfolding permutes_def
 proof
   show "\<forall>x. x \<notin> {..<n} \<longrightarrow> last_to_first n x = x"
   proof fix x show " x \<notin> {..<n} \<longrightarrow> last_to_first n x = x"
     proof assume A: "x \<notin> {..<n}" then have "\<not> x < n"
         by blast then have "x \<ge> n" by linarith
       then show  "last_to_first n x = x"
         unfolding last_to_first_def using assms
         by auto
     qed
   qed
   show "\<forall>y. \<exists>!x. last_to_first n x = y"
   proof fix y
     show "\<exists>!x. last_to_first n x = y"
     proof(cases "y = 0")
       case True
       then have 0: "last_to_first n (n-1) = y"
         using last_to_first_def
         by (simp add: last_to_first_def)
       have 1: "\<And>x. last_to_first n x = y \<Longrightarrow> x = n-1"
         unfolding last_to_first_def using True
         by (metis add_gr_0 less_numeral_extra(1) not_gr_zero)
       show ?thesis
         using 0 1
         by blast
     next
       case False
       then show ?thesis
       proof(cases "y < n")
         case True
         then have 0: "last_to_first n (y-1) = y"
           using False True
           unfolding last_to_first_def
           using add.commute by auto
         have 1: "\<And>x. last_to_first n x = y \<Longrightarrow> x =(y-1)"
           unfolding last_to_first_def
           using True False
           by auto
         show ?thesis using 0 1 by blast
       next
         case F: False
         then have 0: "y \<ge> n"
           using not_less by blast
         then have 1: "last_to_first n y = y"
           by (simp add: \<open>\<forall>x. x \<notin> {..<n} \<longrightarrow> last_to_first n x = x\<close>)
         have 2: "\<And>x. last_to_first n x = y \<Longrightarrow> x =y"
           using 0 unfolding last_to_first_def
           using False by presburger
         then show ?thesis using 1 2 by blast
       qed
     qed
   qed
 qed
 
 definition graph_swap where
 "graph_swap n f = permute_list ((first_to_last (n+1))) ` (graph n f)"
 
 lemma last_to_first_eq:
   assumes "length as = n"
   shows "permute_list (last_to_first (n+1)) (a#as)  = (as@[a])"
 proof-
   have 0: "\<And>i. i < (n+1) \<Longrightarrow> permute_list (last_to_first (n + 1)) (a # as) ! i = (as@[a]) ! i"
   proof-
     fix i assume A: "i < n+1"
     show "permute_list (last_to_first (n + 1)) (a # as) ! i = (as @ [a]) ! i"
     proof(cases "i = n")
       case True
       have 0: "(as @ [a]) ! i = a"
         by (metis True assms nth_append_length)
       have 1: "length (a#as) = n + 1"
         by (simp add: assms)
       have 2: "i < length (a # as)"
         using "1" A by linarith
       have 3: "last_to_first (n + 1) permutes {..<length (a # as)}"
         by (metis "1" add_gr_0 last_to_first_permutes less_numeral_extra(1))
       have 4: "permute_list (last_to_first (n + 1)) (a # as) ! i = (a # as) ! last_to_first (n + 1) i"
         using  2 3  permute_list_nth[of "last_to_first (n + 1)" "a#as" i]
         by blast
       have 5: "permute_list (last_to_first (n + 1)) (a # as) ! i = (a # as) ! 0"
         using 4 unfolding last_to_first_def
         by (simp add: True)
       have 6: "permute_list (last_to_first (n + 1)) (a # as) ! i = a"
         using 5
         by simp
       then show ?thesis using 0   by auto
     next
       case False
       then show ?thesis
         by (smt A add.commute add.right_neutral add_diff_cancel_right' add_gr_0
             add_less_cancel_left append.simps(1) append.simps(2) assms last_to_first_def
             last_to_first_permutes less_SucE less_numeral_extra(1) list.size(3) list.size(4)
             nth_append permute_list_nth plus_1_eq_Suc)
     qed
   qed
   have 1: "length (a#as) = n + 1"
     by (simp add: assms)
   have 2: "length (permute_list (last_to_first (n+1)) (a#as)) = n + 1"
     by (metis "1" length_permute_list)
   have 3: "length (as@[a]) = n + 1"
     by (simp add: assms)
   then show ?thesis using 0 2
     by (metis nth_equalityI)
 qed
 
 lemma first_to_last_eq:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "a \<in> carrier Q\<^sub>p"
   shows "permute_list (first_to_last (n+1)) (as@[a])  = (a#as)"
 proof-
   have "length as = n"
     using assms(1) cartesian_power_car_memE by blast
   then show ?thesis
   using last_to_first_eq last_to_first_permutes[of n]
         permute_list_compose_inv(2)[of  "(last_to_first (n + 1))" n "a # as"]
   unfolding first_to_last_def
   by (metis add_gr_0 assms(1) assms(2) cartesian_power_append last_to_first_permutes
       less_one permute_list_closed' permute_list_compose_inv(2))
 qed
 
 lemma graph_swapI:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "(f as)#as \<in> graph_swap n f"
 proof-
   have 0: "as@[f as] \<in> graph n f"
     using assms using graph_memI[of f n] fun_graph_def
     by blast
   have 1: "f as \<in> carrier Q\<^sub>p"
     using assms
     by blast
   then show ?thesis
   using assms 0 first_to_last_eq[of as "n" "f as"]
   unfolding graph_swap_def
   by (metis image_eqI)
 qed
 
 lemma graph_swapE:
   assumes "x \<in> graph_swap n f"
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "hd x = f (tl x)"
 proof-
   obtain y where y_def: "y \<in> graph n f \<and> x = permute_list (first_to_last (n+1)) y"
     using assms graph_swap_def
     by (smt image_def mem_Collect_eq)
   then have "take n y \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
     using assms(2) graph_memE(3)
     by blast
   then show "hd x = f (tl x)"
     by (metis (no_types, lifting) add.commute assms(2) cartesian_power_car_memE'
         first_to_last_eq graph_memE(1) graph_memE(2) graph_mem_closed lessI list.sel(1)
         list.sel(3) plus_1_eq_Suc y_def)
 qed
 
 text\<open>Semialgebraic functions have semialgebraic graphs\<close>
 
 lemma graph_as_partial_pullback:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "partial_pullback n f 1 (\<Delta> 1) = graph n f"
 proof
   show "partial_pullback n f 1 (\<Delta> 1) \<subseteq> graph n f"
   proof fix x assume A: "x \<in> partial_pullback n f 1 (\<Delta> 1)"
     then have 0: "f (take n x) # drop n x \<in> \<Delta>  1"
       by (metis local.partial_image_def partial_pullback_memE(2))
     then have 1: "length (f (take n x) # drop n x)  = 2"
       using diagonal_def
       by (metis (no_types, lifting) cartesian_power_car_memE mem_Collect_eq one_add_one)
     then obtain b where b_def: "[b] = drop n x"
       by (metis list.inject pair_id)
     then have "[f (take n x), b] \<in> \<Delta>  1"
       using "0"
       by presburger
     then have "b = f (take n x)"
       using 0
       by (smt One_nat_def Qp.cring_axioms diagonal_def drop0 drop_Suc_Cons list.inject mem_Collect_eq take_Suc_Cons)
     then have "x = (take n x)@[f (take n x)]"
       by (metis append_take_drop_id b_def)
     then show "x \<in> graph n f" using graph_memI[of f n x]
       by (metis (no_types, lifting) A \<open>b = f (take n x)\<close>
           assms b_def nth_via_drop partial_pullback_memE(1))
   qed
   show "graph n f \<subseteq> partial_pullback n f 1 (\<Delta>  1)"
   proof fix x
     assume A: "x \<in> graph n f "
     then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n+1\<^esup>)"
       using assms graph_mem_closed by blast
     have "x = (take n x) @ [f (take n x)]"
       using A graph_memE(2)[of f n x] assms
       by blast
     then have "partial_image n f x =  [f (take n x), f (take n x)]"
       by (metis append_take_drop_id local.partial_image_def same_append_eq)
     then have "partial_image n f x \<in> \<Delta> 1"
       using assms 0 diagonal_def[of 1] Qp.cring_axioms diagonalI[of  "partial_image n f x"]
        by (metis (no_types, lifting) A append_Cons append_eq_conv_conj
            cartesian_power_car_memE cartesian_power_car_memE' graph_memE(1)
            less_add_one self_append_conv2 Qp.to_R1_closed)
     then show "x \<in> partial_pullback n f 1 (\<Delta>  1)"
       unfolding partial_pullback_def using 0
       by blast
   qed
 qed
 
 lemma semialg_graph:
   assumes "is_semialg_function n f"
   shows "is_semialgebraic (n + 1) (graph n f)"
   using assms graph_as_partial_pullback[of f n] unfolding is_semialg_function_def
   by (metis diag_is_semialgebraic is_semialgebraicE less_imp_le_nat less_numeral_extra(1))
 
 text\<open>Functions induced by polynomials are semialgebraic\<close>
 
 definition var_list_segment where
 "var_list_segment i j = map (\<lambda>i. pvar Q\<^sub>p i) [i..< j]"
 
 lemma var_list_segment_length:
   assumes "i \<le> j"
   shows "length (var_list_segment i j) = j - i"
   using assms var_list_segment_def
   by fastforce
 
 lemma var_list_segment_entry:
   assumes "k < j - i"
   assumes "i \<le> j"
   shows "var_list_segment i j ! k = pvar Q\<^sub>p (i + k)"
   using assms var_list_segment_length
   unfolding var_list_segment_def
   using nth_map_upt by blast
 
 lemma var_list_segment_is_poly_tuple:
   assumes "i \<le>j"
   assumes "j \<le> n"
   shows "is_poly_tuple n (var_list_segment i j)"
   apply(rule Qp_is_poly_tupleI)
   using assms var_list_segment_entry var_list_segment_length  Qp.cring_axioms pvar_closed[of  _ n]
   by (metis (no_types, opaque_lifting)  add.commute add_lessD1 diff_add_inverse le_Suc_ex
       less_diff_conv)
 
 lemma map_by_var_list_segment:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "j \<le> n"
   assumes "i \<le> j"
   shows "poly_map n (var_list_segment i j) as = list_segment i j as"
   apply(rule nth_equalityI )
   unfolding poly_map_def var_list_segment_def  list_segment_def restrict_def poly_tuple_eval_def
   apply (metis (full_types) assms(1) length_map)
   using assms  eval_pvar[of  _ n as] Qp.cring_axioms length_map add.commute
         length_upt less_diff_conv less_imp_add_positive nth_map nth_upt
         trans_less_add2
   by (smt le_add_diff_inverse2)
 
 lemma map_by_var_list_segment_to_length:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "i \<le> n"
   shows "poly_map n (var_list_segment i n) as = drop i as"
   apply(rule nth_equalityI )
   apply (metis Qp_poly_mapE' assms(1) assms(2) cartesian_power_car_memE length_drop var_list_segment_length)
   using assms map_by_var_list_segment[of as n n i] list_segment_drop[of i as]  cartesian_power_car_memE[of as Q\<^sub>p n]
         map_nth[of ] nth_drop nth_map[of _ "[i..<n]" "(pvar Q\<^sub>p)" ] nth_map[of _ "map (pvar Q\<^sub>p) [i..<n]" "eval_at_point Q\<^sub>p as"]
   unfolding poly_map_def poly_tuple_eval_def var_list_segment_def restrict_def list_segment_def
   by (smt add.commute add_eq_self_zero drop_map drop_upt le_Suc_ex le_refl)
 
 lemma map_tail_by_var_list_segment:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "a \<in> carrier Q\<^sub>p"
   assumes "i < n"
   shows "poly_map (n+1) (var_list_segment 1 (n+1)) (a#as) = as"
 proof-
   have 0: "(a#as) \<in> carrier (Q\<^sub>p\<^bsup>n+1\<^esup>)"
     using assms
     by (meson cartesian_power_cons)
   have 1: "length as = n"
     using assms cartesian_power_car_memE
     by blast
   have 2: "drop 1 (a # as) = as"
     using 0 1 using list_segment_drop[of 1 "a#as"]
     by (metis One_nat_def drop0 drop_Suc_Cons )
   have "1 \<le>n + 1" by auto
   then show ?thesis
     using 0 2  map_by_var_list_segment_to_length[of "a#as" "n+1" 1]
   by presburger
 qed
 
 lemma Qp_poly_tuple_Cons:
   assumes "is_poly_tuple n fs"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>k\<^esub>])"
   assumes "k \<le>n"
   shows "is_poly_tuple n (f#fs)"
   using is_poly_tuple_Cons[of n fs f] poly_ring_car_mono[of  k n] assms
   by blast
 
 lemma poly_map_Cons:
   assumes "is_poly_tuple n fs"
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "poly_map n (f#fs) a = (Qp_ev f a)#poly_map n fs a"
   using assms poly_map_cons by blast
 
 lemma poly_map_append':
   assumes "is_poly_tuple n fs"
   assumes "is_poly_tuple n gs"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "poly_map n (fs@gs) a = poly_map n fs a @ poly_map n gs a"
   using assms(3) poly_map_append by blast
 
 lemma partial_pullback_by_poly:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
   shows "partial_pullback n (Qp_ev f) k S = poly_tuple_pullback (n+k) S (f# (var_list_segment n (n+k)))"
 proof
   show "partial_pullback n (Qp_ev f) k S \<subseteq> poly_tuple_pullback (n+k) S (f # var_list_segment n (n + k))"
   proof fix x assume A: " x \<in> partial_pullback n (Qp_ev f) k S"
     then obtain as bs where as_bs_def: "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> bs \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> x = as @ bs"
       using  partial_pullback_memE(1)[of x n "(Qp_ev f)" k S] cartesian_power_decomp
       by metis
     then have 0: "(Qp_ev f as#bs) \<in> S"
       using A partial_pullback_memE'
       by blast
     have 1: "Qp_ev f as = Qp_ev f (as@bs)"
       using assms as_bs_def poly_eval_cartesian_prod[of as n bs k f]
         Qp.cring_axioms [of ]
       by metis
     then have 2: "((Qp_ev f x) #bs) \<in> S"
       using "0" as_bs_def
       by presburger
     have 3: "bs = list_segment n (n+k) x"
       using as_bs_def list_segment_drop[of n x]
       by (metis (no_types, lifting) add_cancel_right_right add_diff_cancel_left'
           append_eq_append_conv append_take_drop_id cartesian_power_car_memE
           length_0_conv length_append length_map length_upt linorder_neqE_nat
           list_segment_def not_add_less1)
     have 4: "is_poly_tuple (n+k) (f # var_list_segment n (n + k))"
       using Qp_poly_tuple_Cons
         var_list_segment_is_poly_tuple
       by (metis add.commute assms(1) dual_order.refl le_add2)
     have 5: "f \<in> carrier (Q\<^sub>p [\<X>\<^bsub>n + k\<^esub>])"
       using poly_ring_car_mono[of n "n + k"] assms le_add1 by blast
     have 6: "is_poly_tuple (n + k) (var_list_segment n (n + k))"
       by (simp add: var_list_segment_is_poly_tuple)
     have 7: "x \<in> carrier (Q\<^sub>p\<^bsup>n + k\<^esup>)"
       using as_bs_def cartesian_power_concat(1) by blast
     hence 8: "poly_map (n+k) (f # var_list_segment n (n + k)) x = (Qp_ev f x)#poly_map (n+k) (var_list_segment n (n + k)) x"
       using 5 6 7 A poly_map_Cons[of "n + k" "var_list_segment n (n + k)" f x] 4
       unfolding partial_pullback_def evimage_def
       by blast
     hence 6: "poly_map (n+k) (f # var_list_segment n (n + k)) x = (Qp_ev f x)#bs"
       using 3 "7" le_add1 le_refl map_by_var_list_segment by presburger
     show " x \<in> poly_tuple_pullback (n+k) S (f # var_list_segment n (n + k))"
       unfolding poly_tuple_pullback_def using 6
       by (metis "2" "7" IntI poly_map_apply vimage_eq)
   qed
   show "poly_tuple_pullback (n + k) S (f # var_list_segment n (n + k)) \<subseteq> partial_pullback n (Qp_ev f) k S"
   proof fix x
     assume A: "x \<in> poly_tuple_pullback (n + k) S (f # var_list_segment n (n + k))"
     have 0: "is_poly_tuple (n+k) (f # var_list_segment n (n + k))"
       using Qp_poly_tuple_Cons assms(1) le_add1 var_list_segment_is_poly_tuple
       by blast
     have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
       using A unfolding poly_tuple_pullback_def
       by blast
     have 2: "poly_map (n+k) (f # var_list_segment n (n + k)) x \<in> S"
       using 1 assms A unfolding poly_map_def poly_tuple_pullback_def restrict_def
       by (metis (no_types, opaque_lifting) Int_commute add.commute evimage_def evimage_eq)
     have 3: "poly_map (n+k) (f # var_list_segment n (n + k)) x = (Qp_ev f x)#(drop n x)"
       using poly_map_Cons[of "n + k" "var_list_segment n (n + k)" f x] 1 assms(1) map_by_var_list_segment_to_length
             le_add1 poly_map_cons by presburger
     have 4: "poly_map (n+k) (f # var_list_segment n (n + k)) x = (Qp_ev f (take n x))#(drop n x)"
       using assms 1 3 eval_at_points_higher_pow[of  f n "n + k" "x"] le_add1
       by (metis  nat_le_iff_add)
     show "x \<in> partial_pullback n (Qp_ev f) k S"
       apply(rule partial_pullback_memI)
       using 1 apply blast
       using 2 3 4 by metis
   qed
 qed
 
 lemma poly_is_semialg:
   assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
   shows "is_semialg_function n (Qp_ev f)"
 proof(rule is_semialg_functionI)
   show "Qp_ev f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
     using assms
     by (meson Pi_I eval_at_point_closed)
   show "\<And>k S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (n + k) (partial_pullback n (Qp_ev f) k S)"
   proof- fix k::nat fix S
     assume A: "S \<in> semialg_sets (1 + k)"
     have 0: "is_poly_tuple (n + k) (f # var_list_segment n (n + k))"
       by (metis add.commute assms  le_add2 order_refl Qp_poly_tuple_Cons
           var_list_segment_is_poly_tuple)
     have 1: "length (f # var_list_segment n (n + k)) = k + 1"
       by (metis add.commute add_diff_cancel_left' le_add1 length_Cons
           plus_1_eq_Suc var_list_segment_length)
     have 2: "partial_pullback n (Qp_ev f) k S = poly_tuple_pullback (n + k) S (f # var_list_segment n (n + k))"
       using A assms partial_pullback_by_poly[of f n S k]
       unfolding semialg_sets_def
       using gen_boolean_algebra_subset
       by blast
     then show "is_semialgebraic (n + k) (partial_pullback n (Qp_ev f) k S)"
       using  add.commute[of 1 k] 0 1 assms(1)
             pullback_is_semialg[of "n+k" "(f # var_list_segment n (n + k))" "k+1" S]
       by (metis A is_semialgebraicI is_semialgebraic_closed poly_tuple_pullback_eq_poly_map_vimage)
   qed
 qed
 
 text\<open>Families of polynomials defined by semialgebraic coefficient functions\<close>
 
 lemma semialg_function_on_carrier:
   assumes "is_semialg_function n f"
   assumes "restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
   shows "is_semialg_function n g"
 proof(rule is_semialg_functionI)
   have 0: "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
     using assms(1) is_semialg_function_closed
     by blast
   show "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)" then show " g x \<in> carrier Q\<^sub>p"
       using assms(2) 0
       by (metis (no_types, lifting) PiE restrict_Pi_cancel)
   qed
   show "\<And>k S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (n + k) (partial_pullback n g k S)"
   proof- fix k S
     assume A: "S \<in> semialg_sets (1 + k)"
     have 1: "is_semialgebraic (n + k) (partial_pullback n f k S)"
       using A assms(1) is_semialg_functionE is_semialgebraicI
       by blast
     have 2: "(partial_pullback n f k S) = (partial_pullback n g k S)"
       unfolding partial_pullback_def partial_image_def evimage_def
     proof
       show "(\<lambda>xs. f (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>) \<subseteq> (\<lambda>xs. g (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
       proof fix x assume "x \<in> (\<lambda>xs. f (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>) "
         have "(take n x) \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
           using assms
           by (meson \<open>x \<in> (\<lambda>xs. f (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)\<close>
               inf_le2 le_add1 subset_iff take_closed)
         then have "f (take n x) = g (take n x)"
           using assms unfolding  restrict_def
           by meson
         then show " x \<in> (\<lambda>xs. g (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
           using assms \<open>x \<in> (\<lambda>xs. f (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)\<close>
           by blast
       qed
       show "(\<lambda>xs. g (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>) \<subseteq> (\<lambda>xs. f (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
       proof fix x assume A: "x \<in> (\<lambda>xs. g (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
         have "(take n x) \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
           using assms
           by (meson A  inf_le2 le_add1 subset_iff take_closed)
         then have "f (take n x) = g (take n x)"
           using assms unfolding  restrict_def
           by meson
         then show "x \<in> (\<lambda>xs. f (take n xs) # drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
           using A by blast
       qed
     qed
     then show "is_semialgebraic (n + k) (partial_pullback n g k S)"
       using 1 by auto
   qed
 qed
 
 lemma semialg_function_on_carrier':
   assumes "is_semialg_function n f"
   assumes "\<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> f a = g a"
   shows "is_semialg_function n g"
   using assms semialg_function_on_carrier unfolding restrict_def
   by (meson restrict_ext semialg_function_on_carrier)
 
 lemma constant_function_is_semialg:
   assumes "n > 0"
   assumes "x \<in> carrier Q\<^sub>p"
   assumes "\<And> a. a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> f a = x"
   shows "is_semialg_function n f"
 proof(rule semialg_function_on_carrier[of _ "Qp_ev (Qp_to_IP x)"])
   show "is_semialg_function n (Qp_ev (Qp_to_IP x))"
     using assms poly_is_semialg[of "(Qp_to_IP x)"] Qp_to_IP_car
     by blast
   have 0: "\<And> a. a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> f a = Qp_ev (Qp_to_IP x) a"
     using eval_at_point_const assms
     by blast
   then show "restrict (Qp_ev (Qp_to_IP x)) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
     by (metis (no_types, lifting) restrict_ext)
 qed
 
 lemma cartesian_product_singleton_factor_projection_is_semialg:
   assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "b \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "is_semialgebraic (m+n) (cartesian_product A {b})"
   shows "is_semialgebraic m A"
 proof-
   obtain f where f_def: "f = map (pvar Q\<^sub>p) [0..<m]"
     by blast
   have 0: "is_poly_tuple m f"
     using assms var_list_segment_is_poly_tuple[of 0 m m]
     unfolding var_list_segment_def f_def by blast
   have 4: "length f = m"
     unfolding f_def using length_map[of "pvar Q\<^sub>p" "[0..<m]"] by auto
   obtain g where g_def: "(g::(nat multiset \<Rightarrow> ((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set) list) = map (\<lambda>i::nat. Qp.indexed_const (b ! i)) [(0::nat)..<n]"
     by blast
   have 1: "is_poly_tuple m g"
   proof-
     have 0: "set [0::nat..< n] = {..<n}"
       using atLeast_upt by blast
     then have "\<And>i. i \<in> set [0::nat..< n] \<Longrightarrow> b!i \<in> carrier Q\<^sub>p"
       using assms(2) cartesian_power_car_memE'[of b Q\<^sub>p n]  by blast
     hence 1: "\<And>i. i \<in> set [0::nat..< n] \<Longrightarrow> Qp.indexed_const (b ! i) \<in> carrier (Q\<^sub>p[\<X>\<^bsub>m\<^esub>])"
       using assms Qp_to_IP_car by blast
     show ?thesis
       unfolding is_poly_tuple_def g_def
       apply(rule subsetI)
        using set_map[of "\<lambda>i. Qp.indexed_const (b ! i)" "[0..<n]"]  1 unfolding 0
        by (smt image_iff)
   qed
   have 2: "is_poly_tuple m (f@g)"
     using 0 1 Qp_is_poly_tuple_append assms(3) by blast
   have 3: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> poly_tuple_eval (f@g) x = x@b"
   proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
     have 30: "poly_tuple_eval f x = x"
     proof-
       have 300: "length (poly_tuple_eval f x) = length x"
         unfolding poly_tuple_eval_def using cartesian_power_car_memE
         by (metis "4" A length_map)
       have "\<And>i. i < length x \<Longrightarrow> poly_tuple_eval f x ! i = x ! i"
         unfolding f_def poly_tuple_eval_def using nth_map
         by (metis "4" A add_cancel_right_left cartesian_power_car_memE eval_pvar f_def length_map nth_upt)
       thus ?thesis using 300
         by (metis nth_equalityI)
     qed
     have 31: "poly_tuple_eval g x = b"
     proof-
       have 310: "length (poly_tuple_eval g x) = length b"
         unfolding poly_tuple_eval_def g_def  using cartesian_power_car_memE
         by (metis assms(2) length_map map_nth)
       have 311: "length b = n" using assms cartesian_power_car_memE by blast
       hence "\<And>i. i < n \<Longrightarrow> poly_tuple_eval g x ! i = b ! i" proof- fix i assume "i < n"
         thus "poly_tuple_eval g x ! i = b ! i"
           unfolding g_def poly_tuple_eval_def  using eval_at_point_const[of "b!i" x m] 310 nth_map
           by (metis "311" A assms(2) cartesian_power_car_memE' length_map map_nth)
       qed
       thus ?thesis using 311 310 nth_equalityI
         by (metis list_eq_iff_nth_eq)
     qed
     have 32: "poly_tuple_eval (f @ g) x = poly_map  m (f@g) x"
       unfolding poly_map_def restrict_def using A
       by (simp add: A)
     have 33: "poly_tuple_eval f x = poly_map  m f x"
       unfolding poly_map_def restrict_def using A
       by (simp add: A)
     have 34: "poly_tuple_eval g x = poly_map  m g x"
       unfolding poly_map_def restrict_def using A
       by (simp add: A)
     show "poly_tuple_eval (f @ g) x = x @ b"
       using assms 1 2 30 31  poly_map_append[of x m f g] A unfolding 32 33 34
       by (simp add: A \<open>b \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)\<close>)
   qed
   have 4: "A = (poly_tuple_eval (f@g)  \<inverse>\<^bsub>m\<^esub> (cartesian_product A {b}))"
   proof
     show "A \<subseteq> poly_tuple_eval (f @ g) \<inverse>\<^bsub>m\<^esub> cartesian_product A {b}"
     proof(rule subsetI) fix x assume A: "x \<in> A"
       then have 0: "poly_tuple_eval (f@g) x = x@b"
         using 3 assms by blast
       then show " x \<in> poly_tuple_eval (f @ g) \<inverse>\<^bsub>m\<^esub> cartesian_product A {b}"
         using A cartesian_product_memE
         by (smt Un_upper1 assms(1) assms(2) cartesian_product_memI' evimageI2 in_mono insert_is_Un mk_disjoint_insert singletonI)
     qed
     show "poly_tuple_eval (f @ g) \<inverse>\<^bsub>m\<^esub> cartesian_product A {b} \<subseteq> A"
     proof(rule subsetI) fix x assume A: "x \<in> (poly_tuple_eval (f @ g) \<inverse>\<^bsub>m\<^esub> cartesian_product A {b})"
       then have "poly_tuple_eval (f @ g) x \<in> cartesian_product A {b}"
         by blast
       then have "x@b \<in> cartesian_product A {b}"
         using A 3 by (metis evimage_eq)
       then show "x \<in> A"
         using A
         by (metis append_same_eq cartesian_product_memE' singletonD)
     qed
   qed
   have 5: "A = poly_map m (f@g)  \<inverse>\<^bsub>m\<^esub> (cartesian_product A {b})"
   proof
     show "A \<subseteq> poly_map m (f @ g) \<inverse>\<^bsub>m\<^esub> cartesian_product A {b}"
       unfolding poly_map_def evimage_def restrict_def using 4
       by (smt IntI assms(1) evimageD in_mono subsetI vimageI)
     show "poly_map m (f @ g) \<inverse>\<^bsub>m\<^esub> cartesian_product A {b} \<subseteq> A"
       unfolding poly_map_def evimage_def restrict_def using 4
       by (smt Int_iff evimageI2 subsetI vimage_eq)
   qed
   have 6: "length (f @ g) = m + n"
     unfolding f_def g_def by (metis index_list_length length_append length_map map_nth)
   show ?thesis using 2 5 6 assms pullback_is_semialg[of m "f@g" "m+n" "cartesian_product A {b}"]
     by (metis is_semialgebraicE zero_eq_add_iff_both_eq_0)
 qed
 
 lemma cartesian_product_factor_projection_is_semialg:
   assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "B \<noteq> {}"
   assumes "is_semialgebraic (m+n) (cartesian_product A B)"
   shows "is_semialgebraic m A"
 proof-
   obtain b where b_def: "b \<in> B"
     using assms by blast
   have "is_semialgebraic n {b}"
     using assms b_def is_algebraic_imp_is_semialg singleton_is_algebraic by blast
   hence 0: "is_semialgebraic (m+n) (cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) {b})"
     using car_times_semialg_is_semialg assms(4)  by blast
   have "(cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) {b}) \<inter> (cartesian_product A B)
           = (cartesian_product A {b})"
     using assms b_def cartesian_product_intersection[of "carrier (Q\<^sub>p\<^bsup>m\<^esup>)" Q\<^sub>p m "{b}" n A B]
     by (metis (no_types, lifting) Int_absorb1 Int_empty_left Int_insert_left_if1 \<open>is_semialgebraic n {b}\<close> is_semialgebraic_closed set_eq_subset)
   hence "is_semialgebraic (m+n) (cartesian_product A {b})"
     using assms 0  intersection_is_semialg by metis
   thus ?thesis using assms cartesian_product_singleton_factor_projection_is_semialg
     by (meson \<open>is_semialgebraic n {b}\<close> insert_subset is_semialgebraic_closed)
 qed
 
 lemma partial_pullback_cartesian_product:
   assumes "\<xi> \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
   shows "cartesian_product (partial_pullback m \<xi> 0 S) (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) = partial_pullback m \<xi> 1 (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))) "
 proof
   show "cartesian_product (partial_pullback m \<xi> 0 S) (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) \<subseteq> partial_pullback m \<xi> 1 (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)))"
   proof fix x assume A: "x \<in> cartesian_product (partial_pullback m \<xi> 0 S) (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
     then obtain y t where yt_def: "x = y@[t] \<and> y \<in> partial_pullback m \<xi> 0 S \<and> t \<in> carrier Q\<^sub>p"
       by (metis cartesian_product_memE' Qp.to_R1_to_R Qp.to_R_pow_closed)
     then have "[\<xi> y] \<in> S"
       using partial_pullback_memE unfolding partial_image_def
       by (metis (no_types, lifting) add.right_neutral append.right_neutral cartesian_power_drop le_zero_eq take_closed partial_pullback_memE' take_eq_Nil)
     then have 0: "[\<xi> y]@[t] \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
       using cartesian_product_memI' yt_def
       by (metis assms(2) carrier_is_semialgebraic is_semialgebraic_closed Qp.to_R1_closed)
     have 1: " x \<in> carrier (Q\<^sub>p\<^bsup>m + 1\<^esup>)"
       using A yt_def
       by (metis add.right_neutral cartesian_power_append partial_pullback_memE(1))
     show "x \<in> partial_pullback m \<xi> 1 (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)))"
       apply(rule partial_pullback_memI)
       using "1" apply blast
       using yt_def 0
       by (smt Cons_eq_appendI add.right_neutral local.partial_image_def partial_image_eq partial_pullback_memE(1) self_append_conv2 Qp.to_R1_closed)
   qed
   show "partial_pullback m \<xi> 1 (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))) \<subseteq> cartesian_product (partial_pullback m \<xi> 0 S) (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
   proof(rule subsetI) fix x assume A: "x \<in> partial_pullback m \<xi> 1 (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)))"
     then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>m + 1\<^esup>)"
       using assms partial_pullback_memE[of x m \<xi> 1 "cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"]
       by blast
     have 1: "\<xi> (take m x) # drop m x \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
       using A assms partial_pullback_memE[of x m \<xi> 1 "cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"]
       unfolding partial_image_def
       by blast
     have 2: "\<xi> (take m (take m x)) # drop m (take m x)  = [\<xi> (take m x)]"
       using 0 1
       by (metis add.commute add.right_neutral append.right_neutral append_take_drop_id take0 take_drop)
     show "x \<in> cartesian_product (partial_pullback m \<xi> 0 S) (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
       apply(rule cartesian_product_memI[of _  Q\<^sub>p m _ 1])
          apply (metis add_cancel_right_right partial_pullback_closed)
         apply blast
         apply(rule partial_pullback_memI[of _ m 0 \<xi> S]) using 0
        apply (metis Nat.add_0_right le_iff_add take_closed)
       using 2 apply (metis (no_types, lifting) "1" add.commute add.right_neutral assms(2) cartesian_product_memE(1) list.inject plus_1_eq_Suc take_Suc_Cons take_drop)
     using 0  cartesian_power_drop by blast
   qed
 qed
 
 lemma cartesian_product_swap:
   assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "is_semialgebraic (m+n) (cartesian_product A B)"
   shows "is_semialgebraic (m+n) (cartesian_product B A)"
 proof-
   obtain f where f_def: "f = (\<lambda>i. (if i < m then n + i else (if i < m+n then i - m else i)))"
     by blast
   have 0: "\<And>i. i \<in> {..<m} \<longrightarrow> f i \<in> {n..<m+n}"
     unfolding f_def by simp
   have 1: "\<And>i. i \<in> {m..<m+n} \<longrightarrow> f i \<in> {..<n}"
     unfolding f_def by (simp add: less_diff_conv2)
   have 2: "\<And>i. i \<notin> {..<m + n} \<longrightarrow> f i \<notin> {..<m + n}"
     unfolding f_def by simp
   have f_permutes: "f permutes {..<m+n}"
     unfolding permutes_def
   proof
     show "\<forall>x. x \<notin> {..<m + n} \<longrightarrow> f x = x"
       unfolding f_def by simp
     show "\<forall>y. \<exists>!x. f x = y"
     proof fix y
       show "\<exists>!x. f x = y"
       proof(cases "y < n")
         case True
         have T0: "f (y+m) = y"
           unfolding f_def using True
           by simp
         have "\<And>i. f i = y \<Longrightarrow> i \<in> {m..<m+n}"
           using 0 1 2 True f_def nat_neq_iff by fastforce
         hence "\<And>i. f i = y \<Longrightarrow> i = y+m"
           using T0 unfolding f_def by auto
         thus ?thesis using T0 by blast
       next
         case False
         show ?thesis
         proof(cases  "y \<in> {n..<m+n}")
           case True
           have T0: "f (y-n) = y"
             using True unfolding f_def by auto
           have "\<And>i. f i = y \<Longrightarrow> i \<in> {..<m}"
             using 0 1 2 True f_def
             by (metis False atLeastLessThan_iff diff_add_inverse2 diff_diff_cancel diff_le_self
                 lessThan_iff less_imp_diff_less linordered_semidom_class.add_diff_inverse nat_neq_iff not_add_less1)
           hence "\<And>i. f i = y \<Longrightarrow> i = y- n"
             using f_def by force
           then show ?thesis using T0 by blast
         next
           case F: False
           then show ?thesis using 0 1 2 unfolding f_def
             using False add_diff_inverse_nat lessThan_iff by auto
         qed
       qed
     qed
   qed
   have "permute_list f ` (cartesian_product A B) = (cartesian_product B A)"
   proof
     show "permute_list f ` cartesian_product A B \<subseteq> cartesian_product B A"
     proof fix x assume A: " x \<in> permute_list f ` cartesian_product A B"
       then obtain a b where ab_def: "a \<in> A \<and>b \<in> B \<and> x = permute_list f (a@b)"
         by (metis (mono_tags, lifting) cartesian_product_memE' image_iff)
       have 0: "x = permute_list f (a@b)"
         using ab_def by blast
       have 1: "length a = n"
         using ab_def assms cartesian_power_car_memE[of a Q\<^sub>p n] by blast
       have 2: "length b = m"
         using ab_def assms cartesian_power_car_memE[of b Q\<^sub>p m] by blast
       have 3: "length x = m + n"
         using 1 2 0 f_permutes by simp
       have 4: "\<And>i. i < m \<Longrightarrow> x ! i = (a@b) ! (f i)"
         unfolding 0 using permute_list_nth
         by (metis "0" "3" f_permutes length_permute_list trans_less_add1)
       hence 5: "\<And>i. i < m \<Longrightarrow> x ! i = b!i"
         unfolding f_def using 1 2
         by (metis "4" f_def nth_append_length_plus)
       have 6: "\<And>i. i \<in> {m..<m+n} \<Longrightarrow> x ! i = (a@b) ! (i - m)"
         unfolding 0 using f_def permute_list_nth  f_permutes
         by (metis (no_types, lifting) "0" "3" atLeastLessThan_iff length_permute_list not_add_less2
             ordered_cancel_comm_monoid_diff_class.diff_add)
       have 7: "x = b@a"
       proof(rule nth_equalityI)
         show "length x = length (b @ a)"
           using 1 2 3 by simp
         show "\<And>i. i < length x \<Longrightarrow> x ! i = (b @ a) ! i"
           unfolding 3 using 1 2 4 5
           by (smt "0" add.commute add_diff_inverse_nat f_def f_permutes length_append nat_add_left_cancel_less nth_append permute_list_nth)
       qed
       show "x \<in> cartesian_product B A" unfolding 7 using ab_def unfolding cartesian_product_def by blast
     qed
     show "cartesian_product B A \<subseteq> permute_list f ` cartesian_product A B"
     proof fix y assume A: "y \<in> cartesian_product B A"
       then obtain b a where ab_def: "b \<in> B \<and> a \<in> A \<and> y = b@a"
         using cartesian_product_memE' by blast
       obtain x where 0: "x = permute_list f (a@b)"
         by blast
       have 1: "length a = n"
         using ab_def assms cartesian_power_car_memE[of a Q\<^sub>p n] by blast
       have 2: "length b = m"
         using ab_def assms cartesian_power_car_memE[of b Q\<^sub>p m] by blast
       have 3: "length x = m + n"
         using 1 2 0 f_permutes by simp
       have 4: "\<And>i. i < m \<Longrightarrow> x ! i = (a@b) ! (f i)"
         unfolding 0 using permute_list_nth
         by (metis "0" "3" f_permutes length_permute_list trans_less_add1)
       hence 5: "\<And>i. i < m \<Longrightarrow> x ! i = b!i"
         unfolding f_def using 1 2
         by (metis "4" f_def nth_append_length_plus)
       have 6: "\<And>i. i \<in> {m..<m+n} \<Longrightarrow> x ! i = (a@b) ! (i - m)"
         unfolding 0 using f_def permute_list_nth  f_permutes
         by (metis (no_types, lifting) "0" "3" atLeastLessThan_iff length_permute_list not_add_less2
             ordered_cancel_comm_monoid_diff_class.diff_add)
       have 7: "x = b@a"
       proof(rule nth_equalityI)
         show "length x = length (b @ a)"
           using 1 2 3 by simp
         show "\<And>i. i < length x \<Longrightarrow> x ! i = (b @ a) ! i"
           unfolding 3 using 1 2 4 5
           by (smt "0" add.commute add_diff_inverse_nat f_def f_permutes length_append nat_add_left_cancel_less nth_append permute_list_nth)
       qed
       show "y \<in> permute_list f ` cartesian_product A B"
         using ab_def 7 cartesian_product_memI'[of _ Q\<^sub>p] unfolding 0
         by (metis assms(1) assms(2) image_eqI)
     qed
   qed
   thus ?thesis using assms f_permutes permutation_is_semialgebraic
     by metis
 qed
 
 lemma Qp_zero_subset_is_semialg:
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>0\<^esup>)"
   shows "is_semialgebraic 0 S"
 proof(cases "S = {}")
   case True
   then show ?thesis
     by (simp add: empty_is_semialgebraic)
 next
   case False
   then have "S = carrier (Q\<^sub>p\<^bsup>0\<^esup>)"
     using assms unfolding Qp_zero_carrier  by blast
   then show ?thesis
     by (simp add: carrier_is_semialgebraic)
 qed
 
 lemma cartesian_product_empty_list:
 "cartesian_product A {[]} = A"
 "cartesian_product {[]} A = A"
 proof
   show "cartesian_product A {[]} \<subseteq> A"
     apply(rule subsetI)
     unfolding cartesian_product_def
     by (smt append_Nil2 empty_iff insert_iff mem_Collect_eq)
   show "A \<subseteq> cartesian_product A {[]}"
     apply(rule subsetI)
     unfolding cartesian_product_def
     by (smt append_Nil2 empty_iff insert_iff mem_Collect_eq)
   show "cartesian_product {[]} A = A"
   proof
     show "cartesian_product {[]} A \<subseteq> A"
     apply(rule subsetI)
     unfolding cartesian_product_def
     by (smt append_self_conv2 bex_empty insert_compr mem_Collect_eq)
   show "A \<subseteq> cartesian_product {[]} A"
     apply(rule subsetI)
     unfolding cartesian_product_def
     by blast
   qed
 qed
 
 lemma cartesian_product_singleton_factor_projection_is_semialg':
   assumes "A \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "b \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "is_semialgebraic (m+n) (cartesian_product A {b})"
   shows "is_semialgebraic m A"
 proof(cases "n > 0")
   case True
   show ?thesis
   proof(cases "m > 0")
     case T: True
     then show ?thesis
       using assms True cartesian_product_singleton_factor_projection_is_semialg by blast
   next
     case False
     then show ?thesis using Qp_zero_subset_is_semialg assms by blast
   qed
 next
   case False
   then have F0: "b = []"
     using assms Qp_zero_carrier by blast
   have "cartesian_product A {b} = A"
     unfolding F0
     by (simp add: cartesian_product_empty_list(1))
   then show ?thesis using assms False
     by (metis add.right_neutral gr0I)
 qed
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection \<open>More on graphs of functions\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 
 text\<open>This section lays the groundwork for showing that semialgebraic functions are closed under
      various algebraic operations\<close>
 
 text\<open>The take and drop functions on lists are polynomial maps\<close>
 
 lemma function_restriction:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> S"
   assumes "n \<le> k"
   shows "(g \<circ> (take n)) \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<rightarrow> S"
 proof fix x
   assume "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   then have "take n x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
     using assms(2) take_closed
     by blast
   then show "(g \<circ> take n) x \<in> S"
     using assms comp_apply
     by (metis Pi_iff comp_def)
 qed
 
 lemma partial_pullback_restriction:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "n < k"
   shows "partial_pullback k (g \<circ> take n) m S =
          split_cartesian_product  (n + m) (k - n) n (partial_pullback n g m S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>))"
 proof(rule equalityI)
   show "partial_pullback k (g \<circ> take n) m S \<subseteq> split_cartesian_product (n + m) (k - n) n (partial_pullback n g m S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>))"
   proof fix x assume A: "x \<in> partial_pullback k (g \<circ> take n) m S"
     obtain as bs where asbs_def: "x = as@bs \<and> as \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> bs \<in> carrier  (Q\<^sub>p\<^bsup>m\<^esup>)"
       using partial_pullback_memE[of x k "g \<circ> take n" m S] A cartesian_power_decomp[of x Q\<^sub>p k m]
       by metis
     have 0: "((g \<circ> (take n)) as)#bs \<in> S"
       using asbs_def partial_pullback_memE'[of as k bs m x] A
       by blast
     have 1: "(g (take n as))#bs \<in> S"
       using 0
       by (metis comp_apply)
     have 2: "take n as @ bs \<in> carrier (Q\<^sub>p\<^bsup>n+m\<^esup>)"
       by (meson asbs_def assms(2) cartesian_power_concat(1) less_imp_le_nat take_closed)
     have 3: "(take n as)@bs \<in> (partial_pullback n g m S)"
       using 1 2 partial_pullback_memI[of "(take n as)@bs" n m g S]
       by (metis (mono_tags, opaque_lifting) asbs_def assms(2) local.partial_image_def nat_less_le
           partial_image_eq subsetD  subset_refl take_closed)
     have 4: "drop n as \<in> (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>))"
       using asbs_def assms(2) drop_closed
       by blast
     show " x \<in> split_cartesian_product (n + m) (k - n) n (partial_pullback n g m S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>))"
       using split_cartesian_product_memI[of "take n as" bs
                                         "partial_pullback n g m S" "drop n as"
                                          "carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)" Q\<^sub>p "n + m" "k - n" n ]  4
       by (metis (no_types, lifting) "3" append.assoc append_take_drop_id
           asbs_def assms(2) cartesian_power_car_memE less_imp_le_nat partial_pullback_memE(1)
           subsetI take_closed)
   qed
   show "split_cartesian_product (n + m) (k - n) n (partial_pullback n g m S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)) \<subseteq> partial_pullback k (g \<circ> take n) m S"
   proof fix x assume A: "x \<in> split_cartesian_product (n + m) (k - n) n (partial_pullback n g m S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>))"
     show "x \<in> partial_pullback k (g \<circ> take n) m S"
     proof(rule partial_pullback_memI)
       have 0: "(partial_pullback n g m S) \<subseteq> carrier (Q\<^sub>p\<^bsup>n+m\<^esup>)"
         using partial_pullback_closed by blast
       then  have "split_cartesian_product (n + m) (k - n) n (partial_pullback n g m S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)) \<subseteq> carrier (Q\<^sub>p\<^bsup>n + m + (k - n)\<^esup>)"
         using assms A  split_cartesian_product_closed[of "partial_pullback n g m S" Q\<^sub>p "n + m"
                                                 "carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)" "k - n" n]
         using le_add1 by blast
       then show P: "x \<in> carrier (Q\<^sub>p\<^bsup>k+m\<^esup>)"
         by (smt A Nat.add_diff_assoc2 add.commute add_diff_cancel_left' assms(2) le_add1 less_imp_le_nat subsetD)
       have "take n x @ drop (n + (k - n)) x \<in> partial_pullback n g m S"
         using 0 A split_cartesian_product_memE[of x "n + m" "k - n" n "partial_pullback n g m S" "carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)" Q\<^sub>p]
              le_add1 by blast
       have 1: "g (take n x) # drop k x \<in> S"
         using  partial_pullback_memE
         by (metis (no_types, lifting) \<open>take n x @ drop (n + (k - n)) x \<in> partial_pullback n g m S\<close>
               \<open>x \<in> carrier (Q\<^sub>p\<^bsup>k+m\<^esup>)\<close> add.assoc assms(2) cartesian_power_drop le_add1
               le_add_diff_inverse less_imp_le_nat partial_pullback_memE' take_closed)
       have 2: "g (take n x) = (g \<circ> take n) (take k x)"
         using assms P comp_apply[of g "take n" "take k x"]
         by (metis add.commute append_same_eq append_take_drop_id less_imp_add_positive take_add take_drop)
       then show "(g \<circ> take n) (take k x) # drop k x \<in> S"
         using "1" by presburger
     qed
   qed
 qed
 
 lemma comp_take_is_semialg:
   assumes "is_semialg_function n g"
   assumes "n < k"
   assumes "0 < n"
   shows "is_semialg_function k (g \<circ> (take n))"
 proof(rule is_semialg_functionI)
   show "g \<circ> take n \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<rightarrow> carrier Q\<^sub>p"
     using assms function_restriction[of g n "carrier Q\<^sub>p" k]  dual_order.strict_implies_order
         is_semialg_function_closed
     by blast
   show "\<And>ka S. S \<in> semialg_sets (1 + ka) \<Longrightarrow> is_semialgebraic (k + ka) (partial_pullback k (g \<circ> take n) ka S)"
   proof- fix l S assume A: "S \<in> semialg_sets (1 + l)"
     have 0: "is_semialgebraic (n + l) (partial_pullback n g l S) "
       using assms A is_semialg_functionE is_semialgebraicI
       by blast
     have "is_semialgebraic (n + l + (k - n)) (split_cartesian_product (n + l) (k - n) n (partial_pullback n g l S) (carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)))"
       using A 0 split_cartesian_product_is_semialgebraic[of _ _
                                                   "partial_pullback n g l S" _ "carrier (Q\<^sub>p\<^bsup>k - n\<^esup>)"]
             add_gr_0 assms(2) assms(3) carrier_is_semialgebraic le_add1 zero_less_diff
       by presburger
     then  show "is_semialgebraic (k + l) (partial_pullback k (g \<circ> take n) l S)"
       using partial_pullback_restriction[of g n k l S]
   by (metis (no_types, lifting) add.assoc add.commute assms(1) assms(2) is_semialg_function_closed le_add_diff_inverse less_imp_le_nat)
   qed
 qed
 
 text\<open>Restriction of a graph to a semialgebraic domain\<close>
 
 lemma graph_formula:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "graph n g = {as \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>). g (take n as) = as!n}"
   using assms graph_memI fun_graph_def[of Q\<^sub>p n g]
   by (smt Collect_cong Suc_eq_plus1 graph_memE(1) graph_mem_closed mem_Collect_eq)
 
 definition restricted_graph where
 "restricted_graph n g S = {as \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>). take n as \<in> S \<and> g (take n as) = as!n }"
 
 lemma restricted_graph_closed:
  "restricted_graph n g S \<subseteq> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
   by (metis (no_types, lifting) mem_Collect_eq restricted_graph_def subsetI)
 
 lemma restricted_graph_memE:
   assumes "a \<in> restricted_graph n g S"
   shows "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)" "take n a \<in> S" "g (take n a) = a!n"
   using assms
   using restricted_graph_closed apply blast
   apply (metis (no_types, lifting) assms mem_Collect_eq restricted_graph_def)
   using assms unfolding restricted_graph_def
   by blast
 
 lemma restricted_graph_mem_formula:
   assumes "a \<in> restricted_graph n g S"
   shows "a = (take n a)@[g (take n a)]"
 proof-
   have "length a = Suc n"
     using assms
     by (metis (no_types, lifting) cartesian_power_car_memE mem_Collect_eq restricted_graph_def)
   then have "a = (take n a)@[a!n]"
     by (metis append_eq_append_conv_if hd_drop_conv_nth lessI take_hd_drop)
   then show ?thesis
     by (metis assms restricted_graph_memE(3))
 qed
 
 lemma restricted_graph_memI:
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
   assumes "take n a \<in> S"
   assumes "g (take n a) = a!n"
   shows "a \<in> restricted_graph n g S"
   using assms restricted_graph_def
   by blast
 
 lemma restricted_graph_memI':
   assumes "a \<in> S"
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "(a@[g a]) \<in> restricted_graph n g S"
 proof-
   have "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
     using assms(1) assms(3) by blast
   then have "g a \<in> carrier Q\<^sub>p"
     using assms by blast
   then have 0: "a @ [g a] \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
     using assms
     by (metis (no_types, lifting) add.commute cartesian_power_append plus_1_eq_Suc subsetD)
   have 1: "take n (a @ [g a]) \<in> S"
     using assms
     by (metis (no_types, lifting) append_eq_conv_conj cartesian_power_car_memE subsetD)
   show ?thesis
     using assms restricted_graph_memI[of "a@[g a]" n S g]
     by (metis "0" \<open>a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)\<close> append_eq_conv_conj cartesian_power_car_memE nth_append_length)
 qed
 
 lemma restricted_graph_subset:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "restricted_graph n g S \<subseteq> graph n g"
 proof fix x  assume A: "x \<in> restricted_graph n g S"
   show "x \<in> graph n g"
     apply(rule graph_memI)
   using assms(1) apply blast
   using A restricted_graph_memE(3) apply blast
   by (metis A add.commute plus_1_eq_Suc restricted_graph_memE(1))
 qed
 
 lemma restricted_graph_subset':
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "restricted_graph n g S \<subseteq> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
 proof fix a assume A: "a \<in> restricted_graph n g S"
   then have "a = (take n a)@[g (take n a)]"
     using restricted_graph_mem_formula by blast
   then show "a \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
     using cartesian_product_memI' A unfolding restricted_graph_def
     by (metis (mono_tags, lifting) assms(2) last_closed' mem_Collect_eq subsetI Qp.to_R1_closed)
 qed
 
 lemma restricted_graph_intersection:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "restricted_graph n g S = graph n g \<inter> (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)))"
 proof
   show "restricted_graph n g S \<subseteq> graph n g \<inter> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
     using assms restricted_graph_subset restricted_graph_subset'
     by (meson Int_subset_iff)
   show "graph n g \<inter> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)) \<subseteq> restricted_graph n g S"
   proof fix x assume A: " x \<in> graph n g \<inter> cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"
     show "x \<in> restricted_graph n g S"
       apply(rule restricted_graph_memI)
       using A graph_memE[of g n x]
       apply (metis (no_types, lifting) Int_iff add.commute assms(1) graph_mem_closed plus_1_eq_Suc)
           using A graph_memE[of g n x] cartesian_product_memE[of x S "carrier (Q\<^sub>p\<^bsup>1\<^esup>)" Q\<^sub>p n]
           using assms(2) apply blast
           using A graph_memE[of g n x] cartesian_product_memE[of x S "carrier (Q\<^sub>p\<^bsup>1\<^esup>)" Q\<^sub>p n]
           using assms(1) by blast
    qed
  qed
 
 lemma restricted_graph_is_semialgebraic:
   assumes "is_semialg_function n g"
   assumes "is_semialgebraic n S"
   shows "is_semialgebraic (n+1) (restricted_graph n g S)"
 proof-
   have 0: "restricted_graph n g S = graph n g \<inter> (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)))"
     using assms is_semialg_function_closed is_semialgebraic_closed
       restricted_graph_intersection by presburger
   have 1: "is_semialgebraic (n + 1) (graph n g)"
     using assms semialg_graph
     by blast
   have 2: "is_semialgebraic (n + 1) (cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>)))"
     using cartesian_product_is_semialgebraic[of n S 1 "carrier (Q\<^sub>p\<^bsup>1\<^esup>)"]  assms
       carrier_is_semialgebraic less_one
     by presburger
   then show ?thesis
     using 0 1 2 intersection_is_semialg[of "n+1" "graph n g" "cartesian_product S (carrier (Q\<^sub>p\<^bsup>1\<^esup>))"]
     by presburger
 qed
 
 lemma take_closed:
   assumes "n \<le> k"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   shows "take n x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   using assms take_closed
   by blast
 
 lemma take_compose_closed:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "n < k"
   shows "g \<circ> take n \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<rightarrow> carrier Q\<^sub>p"
 proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   then have "(take n x) \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
     using assms  less_imp_le_nat take_closed
     by blast
   then have "g (take n x) \<in> carrier Q\<^sub>p"
     using assms(1) by blast
   then show "(g \<circ> take n) x \<in> carrier Q\<^sub>p"
     using comp_apply[of g "take n" x]
     by presburger
 qed
 
 lemma take_graph_formula:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "n < k"
   assumes "0 < n"
   shows "graph k (g \<circ> (take n)) = {as \<in> carrier (Q\<^sub>p\<^bsup>k+1\<^esup>). g (take n as) = as!k}"
 proof-
   have "\<And>as. as \<in> carrier (Q\<^sub>p\<^bsup>k+1\<^esup>) \<Longrightarrow> (g \<circ> take n) (take k as) = g (take n as) "
     using assms comp_apply take_take[of n k]
   proof -
     fix as :: "((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set list"
     show "(g \<circ> take n) (take k as) = g (take n as)"
       by (metis (no_types) \<open>n < k\<close> comp_eq_dest_lhs min.strict_order_iff take_take)
   qed
   then show ?thesis
     using take_compose_closed[of g n k] assms comp_apply[of g "take n"] graph_formula[of "g \<circ> (take n)" k]
    by (smt Collect_cong Suc_eq_plus1)
 qed
 
 lemma graph_memI':
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
   assumes "take n a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "g (take n a) = a!n"
   shows "a \<in> graph n g"
   using assms fun_graph_def[of Q\<^sub>p n g]
   by (smt cartesian_power_car_memE eq_imp_le lessI mem_Collect_eq take_Suc_conv_app_nth take_all)
 
 lemma graph_memI'':
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "(a@[g a]) \<in> graph n g "
   using assms fun_graph_def
   by blast
 
 lemma graph_as_restricted_graph:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows  "graph n f = restricted_graph n f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
   apply(rule equalityI)
   apply (metis Suc_eq_plus1 assms graph_memE(1) graph_memE(3) graph_mem_closed restricted_graph_memI subsetI)
   by (simp add: assms restricted_graph_subset)
 
 definition double_graph where
 "double_graph n f g = {as \<in> carrier (Q\<^sub>p\<^bsup>n+2\<^esup>). f (take n as) = as!n \<and> g (take n as) = as!(n + 1)}"
 
 lemma double_graph_rep:
   assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   shows "double_graph n f g = restricted_graph (n + 1) (g \<circ> take n) (graph n f)"
 proof
   show "double_graph n f g \<subseteq> restricted_graph (n + 1) (g \<circ> take n) (graph n f)"
   proof fix x assume A: "x \<in> double_graph n f g"
     then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n+2\<^esup>) \<and> f (take n x) = x!n \<and> g (take n x) = x!(n + 1)"
       using double_graph_def by blast
      have 1: "take (n+1) x \<in> graph n f"
       apply(rule graph_memI)
        using assms(2) apply blast
         apply (metis "0" append_eq_conv_conj cartesian_power_car_memE le_add1 length_take
       less_add_same_cancel1 less_numeral_extra(1) min.absorb2 nth_take take_add)
        by (metis (no_types, opaque_lifting) "0" Suc_eq_plus1 Suc_n_not_le_n add_cancel_right_right
            dual_order.antisym le_iff_add not_less_eq_eq one_add_one plus_1_eq_Suc take_closed)
      show " x \<in> restricted_graph (n + 1) (g \<circ> take n) (graph n f)"
        apply(rule restricted_graph_memI)
          apply (metis "0" One_nat_def add_Suc_right numeral_2_eq_2)
        using "1" apply blast
        using 0 take_take[of n "n + 1" x] comp_apply
        by (metis le_add1 min.absorb1)
   qed
   show "restricted_graph (n + 1) (g \<circ> take n) (graph n f) \<subseteq> double_graph n f g"
   proof fix x
     assume A: "x \<in> restricted_graph (n + 1) (g \<circ> take n) (graph n f)"
     then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>Suc (n + 1)\<^esup>) \<and> take (n + 1) x \<in> graph n f \<and> (g \<circ> take n) (take (n + 1) x) = x ! (n + 1)"
       using restricted_graph_memE[of x "n+1" "(g \<circ> take n)" "graph n f" ]
       by blast
     then have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n+2\<^esup>)"
       using 0
       by (metis Suc_1 add_Suc_right)
     have 2: " f (take n x) = x ! n"
       using 0 take_take[of n "n + 1" x] graph_memE[of f n "take (n + 1) x"]
       by (metis assms(2) le_add1 less_add_same_cancel1 less_numeral_extra(1) min.absorb1 nth_take)
     have 3: "g (take n x) = x ! (n + 1)"
       using 0 comp_apply take_take[of n "n + 1" x]
       by (metis le_add1 min.absorb1)
     then show "x \<in> double_graph n f g"
       unfolding double_graph_def using 1 2 3
       by blast
   qed
 qed
 
 lemma double_graph_is_semialg:
   assumes "n > 0"
   assumes "is_semialg_function n f"
   assumes "is_semialg_function n g"
   shows "is_semialgebraic (n+2) (double_graph n f g)"
   using double_graph_rep[of g n f] assms restricted_graph_is_semialgebraic[of n "g \<circ> take n" "graph n f"]
   by (metis (no_types, lifting) Suc_eq_plus1 add_Suc_right is_semialg_function_closed
       less_add_same_cancel1 less_numeral_extra(1) one_add_one restricted_graph_is_semialgebraic
       comp_take_is_semialg semialg_graph)
 
 definition add_vars :: "nat \<Rightarrow> nat  \<Rightarrow>  padic_tuple \<Rightarrow> padic_number" where
 "add_vars i j as = as!i \<oplus>\<^bsub>Q\<^sub>p\<^esub> as!j"
 
 lemma add_vars_rep:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "i < n"
   assumes "j < n"
   shows "add_vars i j as = Qp_ev ((pvar Q\<^sub>p i) \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar Q\<^sub>p j)) as"
   unfolding add_vars_def
   using assms eval_at_point_add[of as n "pvar Q\<^sub>p i" "pvar Q\<^sub>p j"]
         eval_pvar  by (metis  pvar_closed)
 
 lemma add_vars_is_semialg:
   assumes "i < n"
   assumes "j < n"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "is_semialg_function n (add_vars i j)"
 proof-
   have "pvar Q\<^sub>p i \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> pvar Q\<^sub>p j \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
     using  assms pvar_closed[of ]
     by blast
   then have "is_semialg_function n (Qp_ev (pvar Q\<^sub>p i \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> pvar Q\<^sub>p j))"
     using assms poly_is_semialg[of "(pvar Q\<^sub>p i) \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar Q\<^sub>p j)"]
     by blast
   then show ?thesis
     using assms add_vars_rep
       semialg_function_on_carrier[of n  "Qp_ev ((pvar Q\<^sub>p i) \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar Q\<^sub>p j))" "add_vars i j"  ]
   by (metis (no_types, lifting) restrict_ext)
 qed
 
 definition mult_vars :: "nat \<Rightarrow> nat  \<Rightarrow>  padic_tuple \<Rightarrow> padic_number" where
 "mult_vars i j as = as!i \<otimes> as!j"
 
 lemma mult_vars_rep:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "i < n"
   assumes "j < n"
   shows "mult_vars i j as = Qp_ev ((pvar Q\<^sub>p i) \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar Q\<^sub>p j)) as"
   unfolding mult_vars_def
   using assms eval_at_point_mult[of as n "pvar Q\<^sub>p i" "pvar Q\<^sub>p j"]
         eval_pvar[of i n as] eval_pvar[of j n as ]
   by (metis pvar_closed)
 
 lemma mult_vars_is_semialg:
   assumes "i < n"
   assumes "j < n"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "is_semialg_function n (mult_vars i j)"
 proof-
   have "pvar Q\<^sub>p i \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> pvar Q\<^sub>p j \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
     using  assms pvar_closed[of ]
     by blast
   then have "is_semialg_function n (Qp_ev (pvar Q\<^sub>p i \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> pvar Q\<^sub>p j))"
     using assms poly_is_semialg[of "(pvar Q\<^sub>p i) \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar Q\<^sub>p j)"]
     by blast
   then show ?thesis
     using assms mult_vars_rep
       semialg_function_on_carrier[of n  "Qp_ev ((pvar Q\<^sub>p i) \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar Q\<^sub>p j))" "mult_vars i j"  ]
     by (metis (no_types, lifting) restrict_ext)
 qed
 
 definition minus_vars :: "nat  \<Rightarrow>  padic_tuple \<Rightarrow> padic_number" where
 "minus_vars i as =  \<ominus>\<^bsub>Q\<^sub>p\<^esub> as!i"
 
 lemma minus_vars_rep:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "i < n"
   shows "minus_vars i as = Qp_ev (\<ominus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub>(pvar Q\<^sub>p i)) as"
   unfolding minus_vars_def
   using assms eval_pvar[of i n as] eval_at_point_a_inv[of as n "pvar Q\<^sub>p i"]
   by (metis pvar_closed)
 
 lemma minus_vars_is_semialg:
   assumes "i < n"
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "is_semialg_function n (minus_vars i)"
 proof-
   have 0: "pvar Q\<^sub>p i  \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
     using  assms pvar_closed[of ] Qp.cring_axioms by presburger
   have "is_semialg_function n  (Qp_ev (\<ominus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub>(pvar Q\<^sub>p i)))"
     apply(rule poly_is_semialg )
     using "0" by blast
   then show ?thesis
     using assms minus_vars_rep[of a i n]
       semialg_function_on_carrier[of n  _ "minus_vars i"  ]
     by (metis (no_types, lifting) minus_vars_rep restrict_ext)
 qed
 
 definition extended_graph where
 "extended_graph n f g h = {as \<in> carrier (Q\<^sub>p\<^bsup>n+3\<^esup>).
                       f (take n as) = as!n \<and> g (take n as) = as! (n + 1) \<and> h [(f (take n as)),(g (take n as))] = as! (n + 2) }"
 
 lemma extended_graph_rep:
 "extended_graph n f g h = restricted_graph (n + 2) (h \<circ> (drop n)) (double_graph n f g)"
 proof
   show "extended_graph n f g h \<subseteq> restricted_graph (n + 2) (h \<circ> drop n) (double_graph n f g)"
   proof fix x
     assume "x \<in> extended_graph n f g h"
     then have A: "x \<in> carrier (Q\<^sub>p\<^bsup>n+3\<^esup>) \<and>f (take n x) = x!n \<and> g (take n x) = x! (n + 1) \<and>
                  h [(f (take n x)),(g (take n x))] = x! (n + 2)"
       unfolding extended_graph_def by blast
     then have 0: "take (n + 2) x  \<in> carrier (Q\<^sub>p\<^bsup>n+2\<^esup>)"
     proof -
       have "Suc (Suc n) \<le> n + numeral (num.One + num.Bit0 num.One)"
         by simp
       then show ?thesis
         by (metis (no_types) \<open>x \<in> carrier (Q\<^sub>p\<^bsup>n+3\<^esup>) \<and> f (take n x) = x ! n \<and> g (take n x) = x ! (n + 1) \<and> h [f (take n x), g (take n x)] = x ! (n + 2)\<close> add_2_eq_Suc' add_One_commute semiring_norm(5) take_closed)
     qed
     have 1: "f (take n (take (n + 2) x)) = (take (n + 2) x) ! n"
       using A
       by (metis Suc_1 add.commute append_same_eq append_take_drop_id
           less_add_same_cancel1 nth_take take_add take_drop zero_less_Suc)
     have 2: " g (take n (take (n + 2) x)) = (take (n + 2) x) ! (n + 1)"
       using A
       by (smt add.assoc add.commute append_same_eq append_take_drop_id less_add_same_cancel1
           less_numeral_extra(1) nth_take one_add_one take_add take_drop)
     then have 3: "take (n + 2) x \<in> double_graph n f g"
       unfolding double_graph_def
       using 0 1 2
       by blast
     have 4: "drop n (take (n + 2) x) = [(f (take n x)),(g (take n x))]"
     proof-
       have 40: "take (n + 2) x ! (n + 1) = x! (n + 1)"
         by (metis add.commute add_2_eq_Suc' lessI nth_take plus_1_eq_Suc)
       have 41: "take (n + 2) x ! n = x! n"
         by (metis Suc_1 less_SucI less_add_same_cancel1 less_numeral_extra(1) nth_take)
       have 42: "take (n + 2) x ! (n + 1) = g (take n x)"
         using 40 A
         by blast
       have 43: "take (n + 2) x ! n = f (take n x)"
         using 41 A
         by blast
       show ?thesis using A 42 43
         by (metis "0" add_cancel_right_right cartesian_power_car_memE cartesian_power_drop
             le_add_same_cancel1 nth_drop pair_id zero_le_numeral)
     qed
     then have 5: "(h \<circ> drop n) (take (n + 2) x) = x ! (n + 2)"
       using 3 A
       by (metis add_2_eq_Suc' comp_eq_dest_lhs)
     show "x \<in> restricted_graph (n + 2) (h \<circ> drop n) (double_graph n f g)"
       using restricted_graph_def A 3 5
       by (metis (no_types, lifting) One_nat_def Suc_1
           add_Suc_right numeral_3_eq_3 restricted_graph_memI)
   qed
   show "restricted_graph (n + 2) (h \<circ> drop n) (double_graph n f g) \<subseteq> extended_graph n f g h"
   proof fix x assume A: "x \<in> restricted_graph (n + 2) (h \<circ> drop n) (double_graph n f g)"
     then have 0: "take (n+2) x \<in> double_graph n f g"
       using restricted_graph_memE(2) by blast
     have 1: "(h \<circ> drop n) (take (n+2) x) = x! (n+2) "
       by (meson A restricted_graph_memE(3) padic_fields_axioms)
     have 2: "x \<in> carrier (Q\<^sub>p\<^bsup>n+3\<^esup>)"
       using A
       by (metis (no_types, opaque_lifting) Suc3_eq_add_3 add.commute add_2_eq_Suc'
           restricted_graph_closed subsetD)
     have 3: "length x = n + 3"
       using "2" cartesian_power_car_memE by blast
     have 4: "drop n (take (n+2) x) = [x!n, x!(n+1)]"
     proof-
       have "length (take (n+2) x) = n+2"
         by (simp add: "3")
       then have 40:"length (drop n (take (n+2) x)) = 2"
         by (metis add_2_eq_Suc' add_diff_cancel_left' length_drop)
       have 41: "(drop n (take (n+2) x))!0 = x!n"
         using 3
         by (metis Nat.add_0_right \<open>length (take (n + 2) x) = n + 2\<close> add_gr_0 le_add1 less_add_same_cancel1 less_numeral_extra(1) nth_drop nth_take one_add_one)
       have 42: "(drop n (take (n+2) x))!1 = x!(n+1)"
         using 3 nth_take nth_drop A
         by (metis add.commute le_add1 less_add_same_cancel1 less_numeral_extra(1) one_add_one take_drop)
       show ?thesis
         using 40 41 42
         by (metis pair_id)
     qed
     have "(take n x) = take n (take (n+2) x)"
       using take_take 3
       by (metis le_add1 min.absorb1)
     then have 5: "f (take n x) = x ! n"
       using 0 double_graph_def[of n f g] 3
       by (smt Suc_1 less_add_same_cancel1 mem_Collect_eq nth_take zero_less_Suc)
     have 6: "g (take n x) = x ! (n + 1) "
       using 0 double_graph_def[of n f g] 3 take_take[of n "n+2" x]
       by (smt Suc_1 \<open>take n x = take n (take (n + 2) x)\<close> add_Suc_right lessI mem_Collect_eq nth_take)
     have 7: " h [f (take n x), g (take n x)] = x ! (n + 2)"
       using 4 A comp_apply
       by (metis "1" "5" "6")
     show " x \<in> extended_graph n f g h"
       unfolding extended_graph_def
       using 2  5 6 7 A
       by blast
   qed
 qed
 
 lemma function_tuple_eval_closed:
   assumes "is_function_tuple Q\<^sub>p n fs"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "function_tuple_eval Q\<^sub>p n fs x \<in> carrier (Q\<^sub>p\<^bsup>length fs\<^esup>)"
   using function_tuple_eval_closed[of Q\<^sub>p n fs x] assms by blast
 
 definition k_graph where
 "k_graph n fs = {x \<in> carrier (Q\<^sub>p\<^bsup>n + length fs\<^esup>). x = (take n x)@ (function_tuple_eval Q\<^sub>p n fs (take n x)) }"
 
 lemma k_graph_memI:
   assumes "is_function_tuple Q\<^sub>p n fs"
   assumes "x = as@function_tuple_eval Q\<^sub>p n fs as"
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "x \<in> k_graph n fs"
 proof-
   have "take n x = as"
     using assms
     by (metis append_eq_conv_conj cartesian_power_car_memE)
   then show ?thesis unfolding k_graph_def using assms
     by (smt append_eq_conv_conj cartesian_power_car_memE cartesian_power_car_memI'' length_append local.function_tuple_eval_closed mem_Collect_eq)
 qed
 
 text\<open>composing a function with a function tuple\<close>
 
 lemma Qp_function_tuple_comp_closed:
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "length fs = n"
   assumes "is_function_tuple Q\<^sub>p m fs"
   shows "function_tuple_comp Q\<^sub>p fs f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   using assms function_tuple_comp_closed
   by blast
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Tuples of Semialgebraic Functions\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 text\<open>Predicate for a tuple of semialgebraic functions\<close>
 
 definition is_semialg_function_tuple where
 "is_semialg_function_tuple n fs = (\<forall> f \<in> set fs. is_semialg_function n f)"
 
 lemma is_semialg_function_tupleI:
   assumes "\<And> f. f \<in> set fs \<Longrightarrow> is_semialg_function n f"
   shows "is_semialg_function_tuple n fs"
   using assms is_semialg_function_tuple_def
   by blast
 
 lemma is_semialg_function_tupleE:
   assumes "is_semialg_function_tuple n fs"
   assumes "i < length fs"
   shows "is_semialg_function n (fs ! i)"
   by (meson assms(1) assms(2) in_set_conv_nth is_semialg_function_tuple_def padic_fields_axioms)
 
 lemma is_semialg_function_tupleE':
   assumes "is_semialg_function_tuple n fs"
   assumes "f \<in> set fs"
   shows "is_semialg_function n f"
   using assms(1) assms(2) is_semialg_function_tuple_def
   by blast
 
 lemma semialg_function_tuple_is_function_tuple:
   assumes "is_semialg_function_tuple n fs"
   shows "is_function_tuple Q\<^sub>p n fs"
   apply(rule is_function_tupleI)
   using assms is_semialg_function_closed is_semialg_function_tupleE' by blast
 
 lemma const_poly_function_tuple_comp_is_semialg:
   assumes "n > 0"
   assumes "is_semialg_function_tuple n fs"
   assumes "a \<in> carrier Q\<^sub>p"
   shows "is_semialg_function n (poly_function_tuple_comp Q\<^sub>p n fs (Qp_to_IP a))"
   apply(rule semialg_function_on_carrier[of n "Qp_ev (Qp_to_IP a)"])
   using poly_is_semialg[of  "(Qp_to_IP a)"]
   using assms(1) assms(3) Qp_to_IP_car apply blast
   using poly_function_tuple_comp_eq[of n fs "(Qp_to_IP a)"]  assms unfolding restrict_def
   by (metis (no_types, opaque_lifting) eval_at_point_const poly_function_tuple_comp_constant semialg_function_tuple_is_function_tuple)
 
 lemma pvar_poly_function_tuple_comp_is_semialg:
   assumes "n > 0"
   assumes "is_semialg_function_tuple n fs"
   assumes "i < length fs"
   shows "is_semialg_function n (poly_function_tuple_comp Q\<^sub>p n fs (pvar Q\<^sub>p i))"
   apply(rule semialg_function_on_carrier[of n "fs!i"])
   using assms(2) assms(3) is_semialg_function_tupleE apply blast
   by (metis assms(2) assms(3) poly_function_tuple_comp_pvar
       restrict_ext semialg_function_tuple_is_function_tuple)
 
 text\<open>Polynomial functions with semialgebraic coefficients\<close>
 
 definition point_to_univ_poly :: "nat \<Rightarrow> padic_tuple \<Rightarrow> padic_univ_poly" where
 "point_to_univ_poly n a = ring_cfs_to_univ_poly n a"
 
 definition tuple_partial_image where
 "tuple_partial_image m fs x = (function_tuple_eval Q\<^sub>p m fs (take m x))@(drop m x)"
 
 lemma tuple_partial_image_closed:
   assumes "length fs > 0"
   assumes "is_function_tuple Q\<^sub>p n fs"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
   shows "tuple_partial_image n fs x \<in> carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>)"
   using assms unfolding tuple_partial_image_def
   by (meson cartesian_power_concat(1) cartesian_power_drop
       function_tuple_eval_closed le_add1 take_closed)
 
 lemma tuple_partial_image_indices:
   assumes "length fs > 0"
   assumes "is_function_tuple Q\<^sub>p n fs"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
   assumes "i < length fs"
   shows "(tuple_partial_image n fs x) ! i = (fs!i) (take n x)"
 proof-
   have 0: "(function_tuple_eval Q\<^sub>p n fs (take n x)) ! i = (fs!i) (take n x)"
     using assms unfolding function_tuple_eval_def
     by (meson nth_map)
   have 1: "length (function_tuple_eval Q\<^sub>p n fs (take n x)) > i"
     by (metis assms(4) function_tuple_eval_def length_map)
   show ?thesis
     using 0 1 assms unfolding tuple_partial_image_def
     by (metis nth_append)
 qed
 
 lemma tuple_partial_image_indices':
   assumes "length fs > 0"
   assumes "is_function_tuple Q\<^sub>p n fs"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
   assumes "i < l"
   shows "(tuple_partial_image n fs x) ! (length fs + i) = x!(n + i)"
   using assms unfolding tuple_partial_image_def
   by (metis (no_types, lifting) cartesian_power_car_memE function_tuple_eval_closed le_add1
       nth_append_length_plus nth_drop take_closed)
 
 definition tuple_partial_pullback where
 "tuple_partial_pullback n fs l S = ((tuple_partial_image n fs)-`S)  \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
 
 lemma tuple_partial_pullback_memE:
   assumes "as \<in> tuple_partial_pullback m fs l S"
   shows "as \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)" "tuple_partial_image m fs as \<in> S"
   using assms
   apply (metis (no_types, opaque_lifting) Int_iff add.commute tuple_partial_pullback_def)
   using assms unfolding tuple_partial_pullback_def
   by blast
 
 lemma tuple_partial_pullback_closed:
 "tuple_partial_pullback m fs l S \<subseteq> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   using tuple_partial_pullback_memE by blast
 
 lemma tuple_partial_pullback_memI:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>m + k\<^esup>)"
   assumes "is_function_tuple Q\<^sub>p m fs"
   assumes "((function_tuple_eval Q\<^sub>p m fs) (take m as))@(drop m as) \<in> S"
   shows "as \<in> tuple_partial_pullback m fs k S"
   using assms unfolding tuple_partial_pullback_def tuple_partial_image_def
   by blast
 
 lemma tuple_partial_image_eq:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "bs \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   assumes "x = as @ bs"
   shows "tuple_partial_image n fs x = ((function_tuple_eval Q\<^sub>p n fs) as)@bs"
 proof-
   have 0: "(take n x) = as"
     by (metis append_eq_conv_conj assms(1) assms(3) cartesian_power_car_memE)
   have 1: "drop n x = bs"
     by (metis "0" append_take_drop_id assms(3) same_append_eq)
   show ?thesis using assms 0 1 unfolding tuple_partial_image_def
     by presburger
 qed
 
 lemma tuple_partial_pullback_memE':
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "bs \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
   assumes "x = as @ bs"
   assumes "x \<in> tuple_partial_pullback n fs k S"
   shows "(function_tuple_eval Q\<^sub>p n fs as)@bs \<in> S"
   using tuple_partial_pullback_memE[of x n fs k S] tuple_partial_image_def[of n fs x]
   by (metis assms(1) assms(2) assms(3) assms(4) tuple_partial_image_eq)
 
 text\<open>tuple partial pullbacks have the same algebraic properties as pullbacks\<close>
 
 lemma tuple_partial_pullback_intersect:
 "tuple_partial_pullback m f l (S1 \<inter> S2) = (tuple_partial_pullback m f l S1) \<inter> (tuple_partial_pullback m f l S2)"
   unfolding tuple_partial_pullback_def
   by blast
 
 lemma tuple_partial_pullback_union:
 "tuple_partial_pullback m f l (S1 \<union> S2) = (tuple_partial_pullback m f l S1) \<union> (tuple_partial_pullback m f l S2)"
   unfolding tuple_partial_pullback_def
   by blast
 
 lemma tuple_partial_pullback_complement:
   assumes "is_function_tuple Q\<^sub>p m fs"
   shows "tuple_partial_pullback m fs l ((carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>)) - S) = carrier (Q\<^sub>p\<^bsup>m + l\<^esup>) - (tuple_partial_pullback m fs l S) "
   apply(rule equalityI)
   using tuple_partial_pullback_def[of m fs l "((carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>)) - S)"]
         tuple_partial_pullback_def[of m fs l S]
    apply blast
 proof fix x assume A: " x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>) - tuple_partial_pullback m fs l S"
   show " x \<in> tuple_partial_pullback m fs l (carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>) - S) "
     apply(rule tuple_partial_pullback_memI)
     using A
       apply blast
     using assms
     apply blast
   proof
     have 0: "drop m x \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
       by (meson A DiffD1 cartesian_power_drop)
     have 1: "take m x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       using A
       by (meson DiffD1 le_add1 take_closed)
     show "function_tuple_eval Q\<^sub>p m fs (take m x) @ drop m x
     \<in> carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>)"
       using 0 1 assms
       using cartesian_power_concat(1) function_tuple_eval_closed by blast
     show "function_tuple_eval Q\<^sub>p m fs (take m x) @ drop m x \<notin> S"
       using A unfolding tuple_partial_pullback_def tuple_partial_image_def
       by blast
   qed
 qed
 
 lemma tuple_partial_pullback_carrier:
   assumes "is_function_tuple Q\<^sub>p m fs"
   shows "tuple_partial_pullback m fs l (carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>)) = carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   apply(rule equalityI)
   using tuple_partial_pullback_memE(1) apply blast
 proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   show "x \<in> tuple_partial_pullback m fs l (carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>))"
     apply(rule tuple_partial_pullback_memI)
   using A cartesian_power_drop[of x m l] take_closed assms
     apply blast
   using assms apply blast
   proof-
     have "function_tuple_eval Q\<^sub>p m fs (take m x) \<in> carrier (Q\<^sub>p\<^bsup>length fs\<^esup>)"
       using A take_closed assms
           function_tuple_eval_closed le_add1
       by blast
     then show "function_tuple_eval Q\<^sub>p m fs (take m x) @ drop m x
     \<in> carrier (Q\<^sub>p\<^bsup>length fs + l\<^esup>)"
     using cartesian_power_drop[of x m l] A cartesian_power_concat(1)
     by blast
   qed
 qed
 
 definition is_semialg_map_tuple where
 "is_semialg_map_tuple m fs = (is_function_tuple Q\<^sub>p m fs \<and>
                           (\<forall>l \<ge> 0. \<forall>S \<in> semialg_sets ((length fs) + l). is_semialgebraic (m + l) (tuple_partial_pullback m fs l S)))"
 
 lemma is_semialg_map_tuple_closed:
   assumes "is_semialg_map_tuple m fs"
   shows "is_function_tuple Q\<^sub>p m fs"
   using is_semialg_map_tuple_def assms by blast
 
 lemma is_semialg_map_tupleE:
   assumes "is_semialg_map_tuple m fs"
   assumes "is_semialgebraic ((length fs) + l) S"
   shows " is_semialgebraic (m + l) (tuple_partial_pullback m fs l S)"
   using is_semialg_map_tuple_def[of m fs] assms is_semialgebraicE[of "((length fs) + l)" S]
   by blast
 
 lemma is_semialg_map_tupleI:
   assumes "is_function_tuple Q\<^sub>p m fs"
   assumes "\<And>k  S. S \<in> semialg_sets ((length fs) + k) \<Longrightarrow> is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
   shows "is_semialg_map_tuple m fs"
   using assms unfolding is_semialg_map_tuple_def
   by blast
 
 text\<open>Semialgebraicity for maps can be verified on basic semialgebraic sets\<close>
 
 lemma is_semialg_map_tupleI':
   assumes "is_function_tuple Q\<^sub>p m fs"
   assumes "\<And>k  S. S \<in> basic_semialgs ((length fs) + k) \<Longrightarrow> is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
   shows "is_semialg_map_tuple m fs"
   apply(rule is_semialg_map_tupleI)
   using assms(1) apply blast
 proof-
   show "\<And>k S. S \<in> semialg_sets ((length fs) + k) \<Longrightarrow> is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
   proof- fix k S assume A: "S \<in> semialg_sets ((length fs) + k)"
     show "is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
       apply(rule gen_boolean_algebra.induct[of S "carrier (Q\<^sub>p\<^bsup>length fs + k\<^esup>)" "basic_semialgs ((length fs) + k)"])
         using A unfolding semialg_sets_def
             apply blast
         using tuple_partial_pullback_carrier assms carrier_is_semialgebraic plus_1_eq_Suc apply presburger
         using assms(1) assms(2) carrier_is_semialgebraic intersection_is_semialg tuple_partial_pullback_carrier tuple_partial_pullback_intersect apply presburger
                 using tuple_partial_pullback_union union_is_semialgebraic apply presburger
         using assms(1) complement_is_semialg tuple_partial_pullback_complement plus_1_eq_Suc by presburger
   qed
 qed
 
 text\<open>
   The goal of this section is to show that tuples of semialgebraic functions are semialgebraic maps.
 \<close>
 
 text\<open>The function $(x_0, x, y) \mapsto (x_0, f(x), y)$\<close>
 
 definition twisted_partial_image where
 "twisted_partial_image n m f xs = (take n xs)@ partial_image m f (drop n xs)"
 
 text\<open>The set ${(x_0, x, y) \mid (x_0, f(x), y) \in S}$\<close>
 
 text\<open>Convention: a function which produces a subset of (Qp (i + j +k)) will receive the 3 arity
 parameters in sequence, at the very beginning of the function\<close>
 
 definition twisted_partial_pullback where
 "twisted_partial_pullback n m l f S = ((twisted_partial_image n m f)-`S)  \<inter> carrier (Q\<^sub>p\<^bsup>n+m+l\<^esup>)"
 
 lemma twisted_partial_pullback_memE:
   assumes "as \<in> twisted_partial_pullback n m l f S"
   shows "as \<in> carrier (Q\<^sub>p\<^bsup>n+m+l\<^esup>)" "twisted_partial_image n m f as \<in> S"
   using assms
   apply (metis (no_types, opaque_lifting) Int_iff add.commute twisted_partial_pullback_def subset_iff)
   using assms unfolding twisted_partial_pullback_def
   by blast
 
 lemma twisted_partial_pullback_closed:
 "twisted_partial_pullback n m l f S \<subseteq> carrier (Q\<^sub>p\<^bsup>n+m+l\<^esup>)"
   using twisted_partial_pullback_memE(1) by blast
 
 lemma twisted_partial_pullback_memI:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n+m+l\<^esup>)"
   assumes "(take n as)@((f (take m (drop n as)))#(drop (n + m) as)) \<in> S"
   shows "as \<in> twisted_partial_pullback n m l f S"
   using assms unfolding twisted_partial_pullback_def twisted_partial_image_def
   by (metis (no_types, lifting) IntI add.commute drop_drop local.partial_image_def vimageI)
 
 lemma twisted_partial_image_eq:
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "bs \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "cs \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
   assumes "x = as @ bs @ cs"
   shows "twisted_partial_image n m f x = as@((f bs)#cs)"
 proof-
   have 0: "(take n x) = as"
     by (metis append_eq_conv_conj assms(1) assms(4)
         cartesian_power_car_memE)
   have 1: "twisted_partial_image n m f x = as@(partial_image m f (bs@cs))"
     using 0 assms twisted_partial_image_def
     by (metis append_eq_conv_conj cartesian_power_car_memE)
   have 2: "(partial_image m f (bs@cs)) = (f bs)#cs"
     using partial_image_eq[of bs m cs l "bs@cs" f] assms
     by blast
   show ?thesis using assms 0 1 2
     by (metis )
 qed
 
 lemma twisted_partial_pullback_memE':
   assumes "as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   assumes "bs \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
   assumes "cs \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
   assumes "x = as @ bs @ cs"
   assumes "x \<in> twisted_partial_pullback n m l f S"
   shows "as@((f bs)#cs) \<in> S"
   by (metis (no_types, lifting) assms(1) assms(2) assms(3) assms(4) assms(5)
       twisted_partial_image_eq twisted_partial_pullback_memE(2))
 
 text\<open>partial pullbacks have the same algebraic properties as pullbacks\<close>
 
 text\<open>permutation which moves the entry at index \<open>i\<close> to 0\<close>
 
 definition twisting_permutation where
 "twisting_permutation (i::nat) = (\<lambda>j. if j < i then j + 1 else
                                  (if j = i then 0 else j))"
 
 lemma twisting_permutation_permutes:
   assumes "i < n"
   shows "twisting_permutation i permutes {..<n}"
 proof-
   have 0: "\<And>x. x > i \<Longrightarrow> twisting_permutation i x = x"
     unfolding twisting_permutation_def
     by auto
   have 1: "(\<forall>x. x \<notin> {..<n} \<longrightarrow> twisting_permutation i x = x)"
     using 0 assms
     by auto
   have 2: "(\<forall>y. \<exists>!x. twisting_permutation i x = y)"
   proof fix y
     show " \<exists>!x. twisting_permutation i x = y"
     proof(cases "y = 0")
       case True
       show "\<exists>!x. twisting_permutation i x = y"
         by (metis  Suc_eq_plus1 True  add_eq_0_iff_both_eq_0 less_nat_zero_code
             nat_neq_iff twisting_permutation_def zero_neq_one)
     next
       case False
       show ?thesis
       proof(cases "y \<le>i")
         case True
         show ?thesis
         proof
           show "twisting_permutation i (y - 1) = y"
             using True
             by (metis False add.commute add_diff_inverse_nat diff_less gr_zeroI le_eq_less_or_eq
                   less_imp_diff_less less_one twisting_permutation_def)
           show "\<And>x. twisting_permutation i x = y \<Longrightarrow> x = y - 1"
             using True False twisting_permutation_def by force
         qed
       next
         case F: False
         then show ?thesis using False
           unfolding twisting_permutation_def
           by (metis  add_leD1 add_leD2 add_le_same_cancel2 discrete le_numeral_extra(3)
               less_imp_not_less )
       qed
     qed
   qed
   show ?thesis
     using 1 2
     by (simp add: permutes_def)
 qed
 
 lemma twisting_permutation_action:
   assumes "length as = i"
   shows "permute_list (twisting_permutation i) (b#(as@bs)) =  as@(b#bs)"
 proof-
   have 0: "length (permute_list (twisting_permutation i) (b#(as@bs))) = length  (as@(b#bs))"
     by (metis add.assoc length_append length_permute_list list.size(4))
   have "\<And>j. j < length (as@(b#bs))
           \<Longrightarrow> (permute_list (twisting_permutation i) (b#(as@bs))) ! j =  (as@(b#bs)) ! j"
   proof-
     fix j assume A: "j < length (as@(b#bs))"
     show "(permute_list (twisting_permutation i) (b#(as@bs))) ! j =  (as@(b#bs)) ! j"
     proof(cases "j < i")
       case True
       then have T0: "twisting_permutation i j = j + 1"
         using twisting_permutation_def by auto
       then have T1: "(b # as @ bs) ! twisting_permutation i j = as!j"
         using assms
         by (simp add: assms True nth_append)
       have T2: "(permute_list (twisting_permutation i) (b # as @ bs)) ! j = as!j"
       proof-
         have "twisting_permutation i permutes {..<length (b # as @ bs)}"
           by (metis (full_types) assms length_Cons length_append
               not_add_less1 not_less_eq twisting_permutation_permutes)
         then show ?thesis
           using True permute_list_nth[of "twisting_permutation i" "b#(as@bs)" j ]
               twisting_permutation_permutes[of i "length (b#(as@bs))"] assms
           by (metis T0 T1 add_cancel_right_right lessThan_iff
               permutes_not_in zero_neq_one)
       qed
       have T3: "(as @ b # bs) ! j = as!j"
         using assms True
         by (simp add: assms nth_append)
       show "(permute_list (twisting_permutation i) (b #( as @ bs))) ! j = (as @ b # bs) ! j"
         using T3 T2
         by simp
     next
       case False
       show ?thesis
       proof(cases "j = i")
         case True
       then have T0: "twisting_permutation i j = 0"
         using twisting_permutation_def by auto
       then have T1: "(b # as @ bs) ! twisting_permutation i j = b"
         using assms
         by (simp add: assms True nth_append)
       have T2: "(permute_list (twisting_permutation i) (b # as @ bs)) ! j = b"
       proof-
         have "twisting_permutation i permutes {..<length (b # as @ bs)}"
           by (metis (full_types) assms length_Cons length_append
               not_add_less1 not_less_eq twisting_permutation_permutes)
         then show ?thesis
           using True permute_list_nth[of "twisting_permutation i" "b#(as@bs)" j ]
               twisting_permutation_permutes[of i "length (b#(as@bs))"] assms
           by (metis "0" A T1 length_permute_list)
       qed
       have T3: "(as @ b # bs) ! j = b"
         by (metis True assms nth_append_length)
       show ?thesis
         by (simp add: T2 T3)
       next
         case F: False
         then have F0: "twisting_permutation i j = j"
           by (simp add: False twisting_permutation_def)
         then have F1: "(b # as @ bs) ! twisting_permutation i j = bs! (j - i - 1)"
           using assms
           by (metis (mono_tags, lifting) F False Suc_diff_1
               cancel_ab_semigroup_add_class.diff_right_commute linorder_neqE_nat not_gr_zero
               not_less_eq nth_Cons' nth_append)
         have F2: "(permute_list (twisting_permutation i) (b # as @ bs)) ! j = bs ! (j - i - 1)"
           using F1 assms permute_list_nth
           by (metis A add_cancel_right_right append.assoc last_to_first_eq le_add1
               le_eq_less_or_eq length_0_conv length_append length_permute_list list.distinct(1)
               twisting_permutation_permutes)
         have F3: "(as @ b # bs) ! j = bs!(j - i - 1)"
           by (metis F False assms linorder_neqE_nat nth_Cons_pos nth_append zero_less_diff)
         then show ?thesis
           using F2 F3
           by presburger
       qed
     qed
   qed
   then show ?thesis
     using 0
     by (metis nth_equalityI)
 qed
 
 lemma twisting_permutation_action':
   assumes "length as = i"
   shows "permute_list (fun_inv (twisting_permutation i)) (as@(b#bs)) = (b#(as@bs)) "
 proof-
   obtain TI where TI_def: "TI = twisting_permutation i"
     by blast
   have 0: "TI permutes {..<length (as@(b#bs))}"
     using assms TI_def twisting_permutation_permutes[of i "length (as@(b#bs))"]
     by (metis add_diff_cancel_left' gr0I length_0_conv length_append list.distinct(1) zero_less_diff)
   have 1: "(fun_inv TI) permutes {..<length (as@(b#bs))}"
     by (metis "0" Nil_is_append_conv fun_inv_permute(1) length_greater_0_conv list.distinct(1))
   have "permute_list (fun_inv (twisting_permutation i)) (as@(b#bs)) =
         permute_list (fun_inv (twisting_permutation i)) (permute_list (twisting_permutation i) (b#(as@bs)))"
     using twisting_permutation_action[of as i b bs] assms
     by (simp add: \<open>length as = i\<close>)
   then have "permute_list (fun_inv TI) (as@(b#bs)) =
   permute_list ((fun_inv TI) \<circ> TI) (b#(as@bs))"
     using 0 1
     by (metis TI_def fun_inv_permute(2) fun_inv_permute(3) length_greater_0_conv
         length_permute_list permute_list_compose)
   then show ?thesis
     by (metis "0" Nil_is_append_conv TI_def fun_inv_permute(3)
         length_greater_0_conv list.distinct(1) permute_list_id)
 qed
 
 lemma twisting_semialg:
   assumes "is_semialgebraic n S"
   assumes "n > i"
   shows "is_semialgebraic n ((permute_list ((twisting_permutation i)) ` S))"
 proof-
   obtain TI where TI_def: "TI = twisting_permutation i"
     by blast
   have 0: "TI permutes {..<(n::nat)}"
     using assms TI_def twisting_permutation_permutes[of i n]
     by blast
   have "(TI) permutes {..<n}"
     using TI_def  "0"
     by auto
   then show ?thesis
     using assms permutation_is_semialgebraic[of n S "TI"] TI_def
     by blast
 qed
 
 lemma twisting_semialg':
   assumes "is_semialgebraic n S"
   assumes "n > i"
   shows "is_semialgebraic n ((permute_list (fun_inv (twisting_permutation i)) ` S))"
 proof-
   obtain TI where TI_def: "TI = twisting_permutation i"
     by blast
   have 0: "TI permutes {..<(n::nat)}"
     using assms TI_def twisting_permutation_permutes[of i n]
     by blast
   have "(fun_inv TI) permutes {..<n}" using 0 permutes_inv[of TI "{..<n}"]
     unfolding fun_inv_def
     by blast
   then show ?thesis
     using assms permutation_is_semialgebraic[of n S "fun_inv TI"] TI_def
     by blast
 qed
 
 text\<open>Defining a permutation that does: $(x0, x1, y) \mapsto (x_1, x0, y)$\<close>
 
 definition tp_1 where
 "tp_1 i j = (\<lambda> n. (if n<i then j + n else
                   (if i \<le> n \<and> n < i + j then n - i else
                    n)))"
 lemma permutes_I:
   assumes "\<And>x. x \<notin> S \<Longrightarrow> f x = x"
   assumes "\<And>y. y \<in> S \<Longrightarrow> \<exists>!x \<in> S. f x = y"
   assumes "\<And>x. x \<in> S \<Longrightarrow> f x \<in> S"
   shows "f permutes S"
 proof-
   have 0 : "(\<forall>x. x \<notin> S \<longrightarrow> f x = x) "
     using assms(1) by blast
   have 1: "(\<forall>y. \<exists>!x. f x = y)"
   proof fix y
     show "\<exists>!x. f x = y"
       apply(cases "y \<in> S")
        apply (metis "0" assms(2))
     proof-
       assume "y \<notin> S"
       then show "\<exists>!x. f x = y"
         by (metis assms(1) assms(3))
     qed
   qed
   show ?thesis
     using assms 1
     unfolding permutes_def
     by blast
 qed
 
 lemma tp_1_permutes:
 "(tp_1 (i::nat) j) permutes {..< i + j}"
 proof(rule permutes_I)
   show "\<And>x. x \<notin> {..<i + j} \<Longrightarrow> tp_1 i j x = x"
   proof- fix x assume A: "x \<notin> {..<i + j}"
     then show "tp_1 i j x = x"
       unfolding tp_1_def
       by auto
   qed
   show "\<And>y. y \<in> {..<i + j} \<Longrightarrow> \<exists>!x. x \<in> {..<i + j} \<and> tp_1 i j x = y"
   proof- fix y assume A: "y \<in> {..<i + j}"
     show "\<exists>!x. x \<in> {..<i + j} \<and> tp_1 i j x = y"
     proof(cases "y < j")
       case True
       then have 0:"tp_1 i j (y + i) = y"
         by (simp add: tp_1_def)
       have 1: "\<And>x. x \<noteq> y + i \<Longrightarrow> tp_1 i j x \<noteq> y"
       proof- fix x assume A: " x \<noteq> y + i"
         show "tp_1 i j x \<noteq> y"
           apply(cases "x < j")
            apply (metis A True add.commute le_add_diff_inverse le_eq_less_or_eq nat_neq_iff not_add_less1 tp_1_def trans_less_add2)
           by (metis A True add.commute le_add_diff_inverse less_not_refl tp_1_def trans_less_add1)
       qed
       show ?thesis using 0 1
         by (metis A \<open>\<And>x. x \<notin> {..<i + j} \<Longrightarrow> tp_1 i j x = x\<close>)
     next
       case False
       then have "y - j < i"
         using A by auto
       then have "tp_1 i j (y - j) = y"
         using False tp_1_def
         by (simp add: tp_1_def)
       then show ?thesis
         by (smt A False \<open>\<And>x. x \<notin> {..<i + j} \<Longrightarrow> tp_1 i j x = x\<close>
             add.commute add_diff_inverse_nat add_left_imp_eq
             less_diff_conv2 not_less tp_1_def
             padic_fields_axioms)
     qed
   qed
   show "\<And>x. x \<in> {..<i + j} \<Longrightarrow> tp_1 i j x \<in> {..<i + j}"
   proof fix x assume A: "x \<in> {..<i + j}"
     show "tp_1 i j x < i + j"
       unfolding tp_1_def using A
       by (simp add: trans_less_add2)
   qed
 qed
 
 lemma tp_1_permutes':
 "(tp_1 (i::nat) j) permutes {..< i + j + k}"
   using tp_1_permutes
   by (simp add: permutes_def)
 
 lemma tp_1_permutation_action:
   assumes "a \<in> carrier (Q\<^sub>p\<^bsup>i\<^esup>)"
   assumes "b \<in> carrier (Q\<^sub>p\<^bsup>j\<^esup>)"
   assumes "c \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
   shows "permute_list (tp_1 i j) (b@a@c)= a@b@c"
 proof-
   have 0:"length (permute_list (tp_1 i j) (b@a@c))= length (a@b@c)"
     by (metis add.commute append.assoc length_append length_permute_list)
   have "\<And>x. x < length (a@b@c) \<Longrightarrow> (permute_list (tp_1 i j) (b@a@c)) ! x= (a@b@c) ! x"
   proof- fix x assume A: "x < length (a@b@c)"
     have B: "length (a @ b @ c) = i + j + length c"
       using add.assoc assms(1) assms(2) cartesian_power_car_memE length_append
       by metis
     have C: "tp_1 i j permutes {..<length (a @ b @ c)}"
       using B assms tp_1_permutes'[of i j "length b"] tp_1_permutes'
       by presburger
     have D: "length a = i"
       using assms(1) cartesian_power_car_memE by blast
     have E: "length b = j"
       using assms(2) cartesian_power_car_memE by blast
     show "(permute_list (tp_1 i j) (b@a@c)) ! x= (a@b@c) ! x"
     proof(cases "x < i")
       case True
       have T0: "(tp_1 i j x) = j + x"
         using tp_1_def[of i j ] True
         by auto
       then have "(b@ a @ c) ! (tp_1 i j x) = a!x"
         using D E assms(1) assms(2) assms(3) True nth_append
         by (metis nth_append_length_plus)
       then show ?thesis
         using A B C assms permute_list_nth[of "tp_1 i j" "a@b@c"]
         by (metis D True \<open>length (permute_list (tp_1 i j) (b @ a @ c)) =
              length (a @ b @ c)\<close> length_permute_list nth_append permute_list_nth)
     next
       case False
       show ?thesis
       proof(cases "x < i + j")
         case True
         then have T0: "(tp_1 i j x) = x - i"
           by (meson False not_less tp_1_def)
         have "x - i < length b"
           using E False True by linarith
         then have T1: "permute_list (tp_1 i j) (b@ a @ c) ! x = b!(x-i)"
           using nth_append
           by (metis A C T0 \<open>length (permute_list (tp_1 i j) (b @ a @ c)) = length (a @ b @ c)\<close>
               length_permute_list permute_list_nth)
         then show ?thesis
           by (metis D False \<open>x - i < length b\<close> nth_append)
       next
         case False
         then have "(tp_1 i j x) = x"
           by (meson tp_1_def trans_less_add1)
         then show ?thesis
           by (smt A C D E False add.commute add_diff_inverse_nat append.assoc
               length_append nth_append_length_plus permute_list_nth)
       qed
     qed
 qed
   then show ?thesis
     using 0
     by (metis list_eq_iff_nth_eq)
 qed
 
 definition tw where
 "tw i j = permute_list (tp_1 j i)"
 
 lemma tw_is_semialg:
   assumes "n > 0"
   assumes "is_semialgebraic n S"
   assumes "n \<ge> i + j"
   shows "is_semialgebraic n ((tw i j)`S)"
   unfolding tw_def
   using assms tp_1_permutes'[of j i "n - (j + i)"]
         permutation_is_semialgebraic[of n S]
   by (metis add.commute le_add_diff_inverse)
 
 lemma twisted_partial_pullback_factored:
   assumes "f \<in> (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) \<rightarrow> carrier Q\<^sub>p"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n+1+ l\<^esup>)"
   assumes "Y = partial_pullback m f (n + l) (permute_list (fun_inv (twisting_permutation n)) ` S)"
   shows "twisted_partial_pullback n m l f S = (tw m n) ` Y"
 proof
   show "twisted_partial_pullback n m l f S \<subseteq> tw m n ` Y"
   proof fix x
     assume A: "x \<in> twisted_partial_pullback n m l f S"
     then have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n+m+l\<^esup>)"
       using twisted_partial_pullback_memE(1) by blast
     obtain a where a_def: "a = take n x"
       by blast
     obtain b where b_def: "b = take m (drop n x)"
       by blast
     obtain c where c_def: "c = (drop (n + m) x)"
       by blast
     have x_eq:"x = a@(b@c)"
       by (metis a_def append.assoc append_take_drop_id b_def c_def take_add)
     have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       by (metis (no_types, lifting) a_def dual_order.trans le_add1 take_closed x_closed)
     have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
     proof-
       have "drop n x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
         by (metis (no_types, lifting) add.assoc cartesian_power_drop x_closed)
       then show ?thesis
         using b_def le_add1 take_closed by blast
     qed
     have c_closed: "c \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
       using c_def cartesian_power_drop x_closed by blast
     have B: "a@((f b)#c) \<in> S"
       using A twisted_partial_pullback_memE'
       by (smt a_closed a_def add.commute append_take_drop_id b_closed
           b_def c_closed c_def drop_drop)
     have  "permute_list (fun_inv (twisting_permutation n)) (a@((f b)#c)) = (f b)#(a@c)"
        using assms twisting_permutation_action'[of a n "f b" c]
                a_closed cartesian_power_car_memE
        by blast
     then have  C: "(f b)#(a@c) \<in> (permute_list (fun_inv (twisting_permutation n)) ` S)"
        by (metis B image_eqI)
     have C: "b@(a@c) \<in>  partial_pullback m f (n + l) (permute_list (fun_inv (twisting_permutation n)) ` S)"
     proof(rule partial_pullback_memI)
       show "b @ a @ c \<in> carrier (Q\<^sub>p\<^bsup>m + (n + l)\<^esup>)"
         using a_closed b_closed c_closed cartesian_power_concat(1)
         by blast
       have 0: "(take m (b @ a @ c)) = b"
         by (metis append.right_neutral b_closed  cartesian_power_car_memE
             diff_is_0_eq diff_self_eq_0 take0 take_all take_append)
       have 1: "drop m (b @ a @ c) = a@c"
         by (metis "0" append_take_drop_id same_append_eq)
       show "f (take m (b @ a @ c)) # drop m (b @ a @ c) \<in> permute_list (fun_inv (twisting_permutation n)) ` S"
         using 0 1 C
         by presburger
     qed
     have D: "tw m n (b@(a@c)) = a@(b@c)"
       using assms tw_def a_closed b_closed c_closed
       by (metis tp_1_permutation_action x_eq)
     then show "x \<in> tw m n ` Y"
       using x_eq C assms
       by (metis image_eqI)
   qed
   show "tw m n ` Y \<subseteq> twisted_partial_pullback n m l f S"
   proof fix x
     assume A: "x \<in> tw m n ` Y"
     then obtain y where y_def: "x = tw m n y \<and> y \<in> Y"
       by blast
     obtain as where as_def: "as \<in> (permute_list (fun_inv (twisting_permutation n)) ` S) \<and>
                             as = partial_image m f y"
       using partial_pullback_memE
       by (metis assms(3) y_def)
     obtain s where s_def: "s \<in> S \<and> permute_list (fun_inv (twisting_permutation n)) s = as"
       using as_def by blast
     obtain b where b_def: "b = take m y"
       by blast
     obtain a where a_def: "a = take n (drop m y)"
       by blast
     obtain c where c_def: "c = drop (n + m) y"
       by blast
     have y_closed: "y \<in> carrier (Q\<^sub>p\<^bsup>m  + n + l\<^esup>)"
       by (metis add.assoc assms(3) partial_pullback_memE(1) y_def)
     then have y_eq: "y = b@a@c"
       using a_def b_def c_def
       by (metis append_take_drop_id drop_drop)
     have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
       by (metis a_def add.commute cartesian_power_drop le_add1 take_closed take_drop y_closed)
     have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
       using add_leD2 b_def le_add1 take_closed y_closed
       by (meson trans_le_add1)
     have c_closed: "c \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
       using c_def cartesian_power_drop y_closed
       by (metis add.commute)
     have ac_closed: "a@c \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
       using a_closed c_closed cartesian_power_concat(1) by blast
     then have C: " local.partial_image m f y = f b # a @ c"
       using b_closed y_eq partial_image_eq[of b m "a@c" "n + l" y f]
       by blast
     then have as_eq: "as = (f b)#(a@c)"
       using  as_def
       by force
     have B: "(tw m n) y = a@b@c" using y_eq tw_def[of n m] tp_1_permutation_action
       by (smt a_closed b_closed c_closed tw_def)
     then have "x = a@(b@c)"
       by (simp add: y_def)
     then have "twisted_partial_image n m f x =  a@((f b)# c)"
       using a_closed b_closed c_closed twisted_partial_image_eq
       by blast
     then have D: "permute_list (twisting_permutation n) as = twisted_partial_image n m f x"
       using as_eq twisting_permutation_action[of a n "f b" c ]
       by (metis a_closed cartesian_power_car_memE)
     have "permute_list (twisting_permutation n) as \<in> S"
     proof-
       have S: "length s > n"
         using s_def assms cartesian_power_car_memE le_add1 le_neq_implies_less
             le_trans less_add_same_cancel1 less_one not_add_less1
         by (metis (no_types, lifting) subset_iff)
       have "permute_list (twisting_permutation n) as = permute_list (twisting_permutation n) (permute_list (fun_inv (twisting_permutation n)) s)"
         using fun_inv_def  s_def by blast
       then have "permute_list (twisting_permutation n) as =
           permute_list ((twisting_permutation n) \<circ> (fun_inv (twisting_permutation n))) s"
         using fun_inv_permute(2) fun_inv_permute(3) length_greater_0_conv
               length_permute_list twisting_permutation_permutes[of n "length s"]
               permute_list_compose[of "fun_inv (twisting_permutation n)" s "twisting_permutation n"]
         by (metis S permute_list_compose)
       then have "permute_list (twisting_permutation n) as =
           permute_list (id) s"
         by (metis S \<open>permute_list (twisting_permutation n) as = permute_list
             (twisting_permutation n) (permute_list (fun_inv (twisting_permutation n)) s)\<close>
             fun_inv_permute(3) length_greater_0_conv length_permute_list permute_list_compose
             twisting_permutation_permutes)
       then have "permute_list (twisting_permutation n) as = s"
         by simp
       then show ?thesis
         using s_def
         by (simp add: \<open>s \<in> S \<and> permute_list (fun_inv (twisting_permutation n)) s = as\<close>)
     qed
     then show "x \<in> twisted_partial_pullback n m l f S"
       unfolding twisted_partial_pullback_def using D
       by (smt \<open>x = a @ b @ c\<close> a_closed append.assoc append_eq_conv_conj b_closed
           c_closed cartesian_power_car_memE cartesian_power_concat(1) length_append
           list.inject local.partial_image_def twisted_partial_image_def
           twisted_partial_pullback_def twisted_partial_pullback_memI)
   qed
 qed
 
 lemma twisted_partial_pullback_is_semialgebraic:
   assumes "is_semialg_function m f"
   assumes "is_semialgebraic (n + 1 + l) S"
   shows "is_semialgebraic (n + m + l)(twisted_partial_pullback n m l f S)"
 proof-
   have "(fun_inv (twisting_permutation n)) permutes {..<n + 1 + l}"
     by (simp add: fun_inv_permute(1) twisting_permutation_permutes)
   then have "is_semialgebraic (1 + n + l) (permute_list (fun_inv (twisting_permutation n)) ` S)"
     using add_gr_0 assms(2) permutation_is_semialgebraic
     by (metis add.commute)
   then have "is_semialgebraic (n + m + l)
               (partial_pullback m f (n + l) (permute_list (fun_inv (twisting_permutation n)) ` S))"
     using assms is_semialg_functionE[of m f "n + l" "(permute_list (fun_inv (twisting_permutation n)) ` S)"]
     by (metis (no_types, lifting) add.assoc add.commute)
   then have "is_semialgebraic (n + m + l)
               ((tw m n) `(partial_pullback m f (n + l) (permute_list (fun_inv (twisting_permutation n)) ` S)))"
     unfolding tw_def
     using  tp_1_permutes'[of n m l] assms permutation_is_semialgebraic[of "n + m + l"
           "partial_pullback m f (n + l) (permute_list (fun_inv (twisting_permutation n)) ` S)"
           "tp_1 n m" ]
     by blast
   then show ?thesis
     using twisted_partial_pullback_factored assms(1) assms(2)
       is_semialg_function_closed is_semialgebraic_closed
     by presburger
 qed
 
 definition augment where
 "augment n x = take n x @ take n x @ drop n x"
 
 lemma augment_closed:
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
   shows "augment n x \<in> carrier (Q\<^sub>p\<^bsup>n+n+ l\<^esup>)"
   apply(rule cartesian_power_car_memI)
   apply (smt ab_semigroup_add_class.add_ac(1) add.commute append_take_drop_id
     assms augment_def cartesian_power_car_memE cartesian_power_drop length_append)
   using assms cartesian_power_car_memE'' unfolding augment_def
   by (metis (no_types, opaque_lifting) append_take_drop_id cartesian_power_concat(2) nat_le_iff_add take_closed)
 
 lemma tuple_partial_image_factor:
   assumes "is_function_tuple Q\<^sub>p m fs"
   assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   assumes "length fs = n"
   assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
   shows "tuple_partial_image m (fs@[f]) x = twisted_partial_image n m f (tuple_partial_image m fs (augment m x))"
 proof-
   obtain a where a_def: "a = take m x"
     by blast
   obtain b where b_def: "b = drop m x"
     by blast
   have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
     using a_def assms(4) le_add1 take_closed
     by (meson dual_order.trans)
   have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
     using assms(4) b_def cartesian_power_drop
     by (metis (no_types, lifting))
   have A: "(augment m x) = a @ (a @ b)"
     using a_def augment_def b_def
     by blast
   have 0: "tuple_partial_image m fs (augment m x) = ((function_tuple_eval Q\<^sub>p m fs) a) @ a @ b"
     using A a_closed b_closed tuple_partial_image_eq[of a m "a@b" "m + l" "augment m x" fs]
       cartesian_power_concat(1)
     by blast
   have 1: "tuple_partial_image m (fs@[f]) x = ((function_tuple_eval Q\<^sub>p m fs a) @ [f a])@b"
     using 0 tuple_partial_image_eq[of a m b l x "fs@[f]"] unfolding function_tuple_eval_def
     by (metis (no_types, lifting) a_closed a_def append_take_drop_id b_closed b_def
         list.simps(8) list.simps(9) map_append)
   have 2: "tuple_partial_image m (fs@[f]) x = (function_tuple_eval Q\<^sub>p m fs a) @ ((f a)#b)"
     using 1
     by (metis (no_types, lifting) append_Cons append_Nil2 append_eq_append_conv2 same_append_eq)
   have 3: "tuple_partial_image m fs x = (function_tuple_eval Q\<^sub>p m fs a) @ b"
     using a_def b_def 2 tuple_partial_image_eq[of a m b l x fs ] assms  tuple_partial_image_def
     by blast
   have 4: "twisted_partial_image n m f (tuple_partial_image m fs (augment m x)) =
                   (function_tuple_eval Q\<^sub>p m fs a) @ ((f a)#b)"
     using twisted_partial_image_eq[of _ n _ m _ l] 0  assms(1) assms(3) b_closed
       local.a_closed local.function_tuple_eval_closed by blast
   show ?thesis using 2 4
     by presburger
 qed
 
 definition diagonalize where
 "diagonalize n m S = S \<inter> cartesian_product (\<Delta> n) (carrier (Q\<^sub>p\<^bsup>m\<^esup>))"
 
 lemma diagaonlize_is_semiaglebraic:
   assumes "is_semialgebraic (n + n + m) S"
   shows "is_semialgebraic (n + n + m) (diagonalize n m S)"
 proof(cases "m = 0")
   case True
   then have 0: "carrier (Q\<^sub>p\<^bsup>m\<^esup>) = {[]}"
     unfolding  cartesian_power_def
     by simp
   have 1: "\<Delta> n \<subseteq> carrier (Q\<^sub>p\<^bsup>n+n\<^esup>)"
     using Qp.cring_axioms assms diagonalE(2)
     by blast
   then have "cartesian_product (\<Delta> n) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) = \<Delta> n"
     using 0 cartesian_product_empty_right[of "\<Delta> n" Q\<^sub>p "n + n"  "carrier (Q\<^sub>p\<^bsup>m\<^esup>)"]
     by linarith
   then have "diagonalize n m S = S \<inter> (\<Delta> n)"
     using diagonalize_def
     by presburger
   then show ?thesis
     using intersection_is_semialg True assms diag_is_semialgebraic
     by auto
 next
   case False
   have "is_semialgebraic (n + n + m) (cartesian_product (\<Delta> n) (carrier (Q\<^sub>p\<^bsup>m\<^esup>)))"
     using carrier_is_semialgebraic[of m]
           cartesian_product_is_semialgebraic[of "n + n" "\<Delta> n" m "carrier (Q\<^sub>p\<^bsup>m\<^esup>)"]
           diag_is_semialgebraic[of n]  False
     by blast
   then show ?thesis
     using intersection_is_semialg assms(1) diagonalize_def
     by presburger
 qed
 
 lemma list_segment_take:
   assumes "length a \<ge>n"
   shows "list_segment 0 n a = take n a"
 proof-
   have 0: "length (list_segment 0 n a) = length (take n a)"
     using assms unfolding list_segment_def
     by (metis (no_types, lifting) Groups.add_ac(2) add_diff_cancel_left'
         append_take_drop_id le_Suc_ex length_append length_drop length_map map_nth)
   have "\<And>i. i < n \<Longrightarrow> list_segment 0 n a !i = take n a ! i"
     unfolding list_segment_def using assms
     by (metis add.left_neutral diff_zero nth_map_upt nth_take)
   then show ?thesis using 0
     by (metis assms diff_zero le0 list_segment_length nth_equalityI)
 qed
 
 lemma augment_inverse_is_semialgebraic:
   assumes "is_semialgebraic (n+n+l) S"
   shows "is_semialgebraic (n+l) ((augment n -` S) \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>))"
 proof-
   obtain Ps where Ps_def: "Ps = (var_list_segment 0 n)"
     by blast
   obtain Qs where Qs_def: "Qs = (var_list_segment n (n+l))"
     by blast
   obtain Fs where Fs_def: "Fs = Ps@Ps@Qs"
     by blast
   have 0: "is_poly_tuple (n+l) Ps"
     by (simp add: Ps_def var_list_segment_is_poly_tuple)
   have 1: "is_poly_tuple (n+l) Qs"
     by (simp add: Qs_def var_list_segment_is_poly_tuple)
   have 2: "is_poly_tuple (n+l) (Ps@Qs)"
     using Qp_is_poly_tuple_append[of "n+l" Ps Qs]
     by (metis (no_types, opaque_lifting) "0" "1" add.commute)
   have "is_poly_tuple (n+l) Fs"
     using 0 2 Qp_is_poly_tuple_append[of "n + l" Ps "Ps@Qs"] Fs_def assms
     by blast
   have 3: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) \<Longrightarrow> augment n x = poly_map (n + l) Fs x"
   proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
     have 30: "poly_map (n+l) Ps x = take n x"
       using Ps_def  map_by_var_list_segment[of x "n + l" n 0]
             list_segment_take[of n x] cartesian_power_car_memE[of x Q\<^sub>p "n+l"]
       by (simp add: A)
     have 31: "poly_map (n + l) Qs x = drop n x"
       using Qs_def map_by_var_list_segment_to_length[of x "n + l" n] A le_add1
       by blast
     have 32: "poly_map (n + l) (Ps@Qs) x = take n x @ drop n x"
       using poly_map_append[of x "n+l" Ps Qs ]
       by (metis "30" "31" A append_take_drop_id)
     show "augment n x = poly_map (n + l) Fs x"
       using 30 32 poly_map_append
       by (metis A Fs_def poly_map_append augment_def)
   qed
   have 4: "(augment n -` S) \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) = poly_tuple_pullback (n + l) S Fs"
   proof
     show "augment n -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) \<subseteq> poly_tuple_pullback (n + l) S Fs"
     proof fix x assume A: "x \<in> augment n -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
       then have 40: "augment n x \<in> S"
         by blast
       have 41: "augment n x \<in> carrier (Q\<^sub>p\<^bsup>n+n+ l\<^esup>)"
         using 40 assms unfolding augment_def
         using is_semialgebraic_closed
         by blast
       have "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
       proof-
         have "take n x @ x \<in> carrier (Q\<^sub>p\<^bsup>n+n+ l\<^esup>)"
           using augment_def A
           by (metis "41" append_take_drop_id)
         then have 0: "drop n (take n x @ x) \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
           by (metis (no_types, lifting) add.assoc cartesian_power_drop)
         have "drop n (take n x @ x) = x"
         proof-
           have "length x \<ge> n"
             using A
             by (metis IntD2 cartesian_power_car_memE le_add1)
           then have "length (take n x) = n"
             by (metis add_right_cancel append_take_drop_id
                 le_add_diff_inverse length_append length_drop)
           then show ?thesis
             by (metis append_eq_conv_conj)
         qed
         then show ?thesis
           using 0
           by presburger
       qed
       then show "x \<in> poly_tuple_pullback (n + l) S Fs"
         using  41 3 unfolding poly_tuple_pullback_def
         by (metis (no_types, opaque_lifting) "40" add.commute cartesian_power_car_memE evimageI evimage_def poly_map_apply)
     qed
     show "poly_tuple_pullback (n + l) S Fs \<subseteq> augment n -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
     proof fix x assume A: "x \<in> poly_tuple_pullback (n + l) S Fs"
       have "x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
         using A unfolding poly_tuple_pullback_def by blast
       then show "x \<in> augment n -` S \<inter> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)"
         using 3
         by (metis (no_types, lifting) A poly_map_apply poly_tuple_pullback_def vimage_inter_cong)
     qed
   qed
   then show ?thesis using assms pullback_is_semialg[of "n + l" Fs]
     using poly_tuple_pullback_eq_poly_map_vimage
     unfolding restrict_def evimage_def Fs_def
     by (smt "4" Ex_list_of_length Fs_def Ps_def Qs_def \<open>is_poly_tuple (n + l) Fs\<close> add.commute
         add_diff_cancel_left' append_assoc diff_zero is_semialgebraic_closed le_add2 length_append
         not_add_less1 not_gr_zero padic_fields.is_semialgebraicE padic_fields_axioms var_list_segment_length zero_le)
 qed
 
 lemma tuple_partial_pullback_is_semialg_map_tuple_induct:
   assumes "is_semialg_map_tuple m fs"
   assumes "is_semialg_function m f"
   assumes "length fs = n"
   shows "is_semialg_map_tuple m (fs@[f])"
 proof(rule is_semialg_map_tupleI)
   have 0: "is_function_tuple Q\<^sub>p m fs"
     using assms is_semialg_map_tuple_def
     by blast
   show "is_function_tuple Q\<^sub>p m (fs @ [f])"
   proof(rule is_function_tupleI)
     have A0: "set (fs @ [f]) = insert f (set fs)"
       by simp
     have A1: "set fs \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
       using 0 is_function_tuple_def
       by blast
     then show "set (fs @ [f]) \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
       using assms 0
       by (metis (no_types, lifting) A0 is_semialg_function_closed list.simps(15) set_ConsD subset_code(1))
   qed
   show "\<And>k S. S \<in> semialg_sets (length (fs @ [f]) + k) \<Longrightarrow>
                  is_semialgebraic (m + k) (tuple_partial_pullback m (fs @ [f]) k S)"
   proof- fix l S
     assume A: "S \<in> semialg_sets (length (fs @ [f]) + l)"
     then have B: "S \<in> semialg_sets (n + l + 1)"
       using assms
       by (metis (no_types, lifting) add.commute add_Suc_right add_diff_cancel_left'
           append_Nil2 diff_Suc_1 length_Suc_conv length_append)
     show "is_semialgebraic (m + l) (tuple_partial_pullback m (fs @ [f]) l S)"
     proof-
       obtain S0 where S0_def: "S0 = tuple_partial_pullback m fs (l+1) S"
         by blast
       have 0: "is_semialgebraic (m + l + 1) S0"
         using B assms is_semialg_map_tupleE[of m fs "l + 1" S]
         by (metis S0_def add.assoc is_semialgebraicI)
       obtain S1 where S1_def: "S1 = twisted_partial_pullback m m l f S0"
         by blast
       then have "is_semialgebraic (m + m + l) S1"
         using S1_def assms(1) 0 twisted_partial_pullback_is_semialgebraic[of m f m l S0]
         by (simp add: assms(2))
       then have L: "is_semialgebraic (m + m + l) (diagonalize m l S1)"
         using assms  diagaonlize_is_semiaglebraic
         by blast
       have 1: "(tuple_partial_pullback m (fs @ [f]) l S)
                 = (augment m -` (diagonalize m l S1)) \<inter> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
       proof
         show "tuple_partial_pullback m (fs @ [f]) l S \<subseteq>
                       augment m -` diagonalize m l S1 \<inter> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
 
         proof fix x assume P0: "x \<in> tuple_partial_pullback m (fs @ [f]) l S "
           show "x \<in> augment m -` diagonalize m l S1 \<inter> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
           proof
             show "x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
               using tuple_partial_pullback_closed P0
               by blast
             show "x \<in> augment m -` diagonalize m l S1"
             proof-
               obtain a where a_def: "a = take m x"
                 by blast
               then have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
                 using \<open>x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)\<close> le_add1 take_closed
                 by blast
               obtain b where b_def: "b = drop m x"
                 by blast
               then have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
                 using \<open>x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)\<close> cartesian_power_drop
                 by blast
               have x_eq: "x = a@b"
                 using a_def b_def
                 by (metis append_take_drop_id)
               have X0: "a @ a @ b = augment m x"
                 by (metis a_def augment_def b_def)
               have "a @ a @ b \<in>  diagonalize m l S1"
               proof-
                 have "length (a@a) = m + m"
                   using a_closed cartesian_power_car_memE length_append
                   by blast
                 then have "take (m + m) (a @ a @ b) = a@a"
                   by (metis append.assoc append_eq_conv_conj)
                 then have X00: "take (m + m) (a @ a @ b) \<in> \<Delta>  m"
                   using diagonalI[of  "a@a"] a_def a_closed
                   by (metis append_eq_conv_conj cartesian_power_car_memE)
                 then have X01: "a @ a @ b \<in> cartesian_product (\<Delta> m) (carrier (Q\<^sub>p\<^bsup>l\<^esup>))"
                   using a_closed b_closed cartesian_product_memI[of "\<Delta> m" Q\<^sub>p "m+m" "carrier (Q\<^sub>p\<^bsup>l\<^esup>)" l "a @ a @ b"]
                   unfolding diagonal_def
                   by (metis (no_types, lifting) X0 \<open>x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)\<close> augment_closed cartesian_power_drop mem_Collect_eq subsetI)
                 have X02: "twisted_partial_image m m f (a @ a @ b) = a @ ((f a)# b)"
                   using twisted_partial_image_eq[of a m a m b l _ f] a_closed b_closed
                   by blast
                 have "a @ a @ b \<in> S1"
                 proof-
                   have "twisted_partial_image m m f (a @ a @ b) \<in> S0"
                   proof-
                     have X020:"tuple_partial_image m fs (a @ ((f a)# b))
                               = (function_tuple_eval Q\<^sub>p m fs a)@[f a]@b"
                       using tuple_partial_image_eq[of a m "(f a)# b" "l + 1" _ fs]
                       by (metis (no_types, lifting) a_closed append_Cons append_eq_conv_conj
                           cartesian_power_car_memE self_append_conv2 tuple_partial_image_def)
                     have X021: "(function_tuple_eval Q\<^sub>p m fs a)@[f a]@b \<in> S"
                     proof-
                       have X0210: "(function_tuple_eval Q\<^sub>p m fs a)@[f a]@b =
                                 (function_tuple_eval Q\<^sub>p m (fs@[f]) a)@b"
                         unfolding function_tuple_eval_def
                         by (metis (mono_tags, lifting) append.assoc list.simps(8) list.simps(9) map_append)
                       have X0211: "(function_tuple_eval Q\<^sub>p m (fs@[f]) a)@b =
                                 tuple_partial_image m (fs @ [f]) x"
                         using x_eq tuple_partial_image_eq[of a m b l x "fs@[f]"]
                         by (simp add: a_closed b_closed)
                       have "tuple_partial_image m (fs @ [f]) x \<in> S"
                         using P0 tuple_partial_pullback_memE(2)
                         by blast
                       then show ?thesis using X0211 X0210 by presburger
                     qed
                     have X022: "tuple_partial_image m fs (twisted_partial_image m m f (a @ a @ b))
                                  = (function_tuple_eval Q\<^sub>p m fs a)@[f a]@b"
                     proof-
                       have X0220: "tuple_partial_image m fs (twisted_partial_image m m f (a @ a @ b)) =
                                     tuple_partial_image m fs (a @ ((f a)# b))"
                         using X02 by presburger
                       have X0221: "tuple_partial_image m fs (twisted_partial_image m m f (a @ a @ b)) =
                                     (function_tuple_eval Q\<^sub>p m fs a) @ ((f a)# b)"
                         using tuple_partial_image_eq
                         by (metis X02 X020 append_Cons self_append_conv2)
                       then show ?thesis
                         unfolding function_tuple_eval_def
                         by (metis X02 X020 X0221 append_same_eq)
                     qed
                     have X023: "tuple_partial_image m fs (twisted_partial_image m m f (a @ a @ b)) \<in> S"
                       using X02 X020 X021 by presburger
                     have "twisted_partial_image m m f (a @ a @ b) \<in> carrier (Q\<^sub>p\<^bsup>m + (l+1)\<^esup>)"
                     proof-
                       have "a @ ((f a)# b) \<in> carrier (Q\<^sub>p\<^bsup>m + (l+1)\<^esup>)"
                         apply(rule cartesian_power_car_memI)
                          apply (metis a_closed add.commute b_closed cartesian_power_car_memE
                             length_Cons length_append plus_1_eq_Suc)
                       proof-
                         have "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
                           using assms(2) is_semialg_function_closed by blast
                         then have "f a \<in> carrier Q\<^sub>p"
                           using a_closed assms
                           by blast
                         then show "set (a @ f a # b) \<subseteq> carrier Q\<^sub>p"
                           using  assms a_closed b_closed
                           by (meson cartesian_power_car_memE'' cartesian_power_concat(1) cartesian_power_cons)
                       qed
                       then show ?thesis
                         using X02
                         by presburger
                     qed
                     then show ?thesis
                       using S0_def X023 tuple_partial_pullback_def[of m fs "l+1" S ]
                       by blast
                   qed
                   then show ?thesis using X02 S1_def twisted_partial_pullback_def
                     by (metis (no_types, lifting) X0 \<open>x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)\<close> augment_closed
                         drop_drop local.partial_image_def twisted_partial_image_def
                         twisted_partial_pullback_memI)
                 qed
                 then show ?thesis using X01 diagonalize_def[of m l S1]
                   by blast
               qed
               then show ?thesis
                 by (metis X0 vimageI)
             qed
           qed
         qed
         show "augment m -` diagonalize m l S1 \<inter> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>) \<subseteq> tuple_partial_pullback m (fs @ [f]) l S"
         proof
           fix x
           assume A: "x \<in> augment m -` diagonalize m l S1 \<inter> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
           then have X0: "x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)"
             by blast
           obtain a where a_def: "a = take m x"
             by blast
           then have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
             using X0 le_add1 take_closed by blast
           obtain b where b_def: "b = drop m x"
             by blast
           then have a_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>l\<^esup>)"
             using X0 cartesian_power_drop
             by blast
           have X1: "augment m x = a@a@b"
             using a_def augment_def b_def
             by blast
           have X2: "a@a@b \<in> diagonalize m l S1"
             using A X1
             by (metis Int_iff vimage_eq)
           have X3: "a@a@b \<in>  S1"
             using X2 diagonalize_def
             by blast
           have X4: "twisted_partial_image m m f (a@a@b) \<in> S0"
             using X3 S1_def twisted_partial_pullback_memE(2)
             by blast
           have X5: "a@((f a)#b) \<in> S0"
             using X4 twisted_partial_image_eq[of a m a m b l _ f]
             by (metis X0 a_closed a_def le_add1 take_closed)
           have X6: "tuple_partial_image m fs (a@((f a)#b)) \<in> S"
             using S0_def X5 tuple_partial_pullback_memE(2)
             by blast
           have X7: "((function_tuple_eval Q\<^sub>p m fs a)@((f a)#b)) \<in> S"
             using X6 using tuple_partial_image_eq
             by (metis X0 a_def append_eq_conv_conj cartesian_power_car_memE
                 le_add1 take_closed tuple_partial_image_def)
           have X8: "((function_tuple_eval Q\<^sub>p m fs a)@((f a)#b)) =
                         tuple_partial_image m (fs @ [f]) x"
           proof-
             have X80: "tuple_partial_image m (fs @ [f]) x = (function_tuple_eval Q\<^sub>p m (fs@[f]) a)@b"
               using tuple_partial_image_def a_def b_def
               by blast
             then show ?thesis unfolding function_tuple_eval_def
               by (metis (no_types, lifting) append_Cons append_eq_append_conv2 list.simps(9) map_append self_append_conv2)
           qed
           show "x \<in> tuple_partial_pullback m (fs @ [f]) l S"
             using X8 X7 tuple_partial_pullback_def
             by (metis X0 \<open>is_function_tuple Q\<^sub>p m (fs @ [f])\<close>
                 tuple_partial_image_def tuple_partial_pullback_memI)
         qed
       qed
       then show ?thesis
         using augment_inverse_is_semialgebraic
         by (simp add: L)
     qed
   qed
 qed
 
 lemma singleton_tuple_partial_pullback_is_semialg_map_tuple:
   assumes "is_semialg_function_tuple m fs"
   assumes "length fs = 1"
   shows "is_semialg_map_tuple m fs"
 proof(rule is_semialg_map_tupleI)
   show "is_function_tuple Q\<^sub>p m fs"
     by (simp add: assms(1) semialg_function_tuple_is_function_tuple)
   show "\<And>k S. S \<in> semialg_sets (length fs + k) \<Longrightarrow> is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
   proof- fix k S assume A: "S \<in> semialg_sets (length fs + k)"
     show "is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
     proof-
       obtain f where f_def: "fs = [f]"
         using assms
         by (metis One_nat_def length_0_conv length_Suc_conv)
       have 0: "is_semialg_function m f"
         using f_def assms is_semialg_function_tupleE'[of m fs f]
         by simp
       have 1: "\<And>x. tuple_partial_image m fs x = partial_image m f x"
         unfolding function_tuple_eval_def tuple_partial_image_def partial_image_def
         by (metis (no_types, lifting) append_Cons append_Nil2 append_eq_append_conv_if
             f_def list.simps(8) list.simps(9))
       have 2: "tuple_partial_pullback m fs k S = partial_pullback m f k S"
       proof
         show "tuple_partial_pullback m fs k S \<subseteq> partial_pullback m f k S"
             using 1 unfolding tuple_partial_pullback_def  partial_pullback_def evimage_def
             by (metis (no_types, lifting) set_eq_subset vimage_inter_cong)
         show "partial_pullback m f k S \<subseteq> tuple_partial_pullback m fs k S"
           using 1 unfolding tuple_partial_pullback_def  partial_pullback_def evimage_def
             by blast
       qed
       then show ?thesis
         by (metis "0" A assms(2) is_semialg_functionE is_semialgebraicI)
     qed
   qed
 qed
 
 lemma empty_tuple_partial_pullback_is_semialg_map_tuple:
   assumes "is_semialg_function_tuple m fs"
   assumes "length fs = 0"
   shows "is_semialg_map_tuple m fs"
   apply(rule is_semialg_map_tupleI)
   using assms(1) semialg_function_tuple_is_function_tuple apply blast
 proof-
   fix k S assume A: "S \<in> semialg_sets (length fs + k)"
   then have 0: "is_semialgebraic k S"
     by (metis add.left_neutral assms(2) is_semialgebraicI)
   have 1: "tuple_partial_pullback m fs k S = cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) S"
   proof
     have 1: "\<And>x. function_tuple_eval Q\<^sub>p m fs (take m x) = []"
       using assms unfolding function_tuple_eval_def
       by blast
     show "tuple_partial_pullback m fs k S \<subseteq> cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) S"
       apply(rule subsetI) apply(rule cartesian_product_memI[of "carrier (Q\<^sub>p\<^bsup>m\<^esup>)" Q\<^sub>p m S k])
       apply blast using 0 is_semialgebraic_closed apply blast
       using  0 assms unfolding 1 tuple_partial_pullback_def tuple_partial_image_def
       apply (meson IntD2 le_add1 take_closed)
      by (metis append_Nil evimageD evimage_def)
    have 2: "cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) S \<subseteq> carrier (Q\<^sub>p\<^bsup>m + k\<^esup>)"
      using is_semialgebraic_closed[of k S] 0 assms cartesian_product_closed[of "carrier (Q\<^sub>p\<^bsup>m\<^esup>)" Q\<^sub>p m S k]  by blast
    show "cartesian_product (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) S \<subseteq> tuple_partial_pullback m fs k S"
      apply(rule subsetI)  apply(rule tuple_partial_pullback_memI)
      using 2 apply blast
      using assms semialg_function_tuple_is_function_tuple apply blast
      unfolding 1
      by (metis carrier_is_semialgebraic cartesian_product_memE(2) is_semialgebraic_closed self_append_conv2)
   qed
   show "is_semialgebraic (m + k) (tuple_partial_pullback m fs k S)"
     unfolding 1
     using "0" car_times_semialg_is_semialg by blast
 qed
 
 lemma tuple_partial_pullback_is_semialg_map_tuple:
   assumes "is_semialg_function_tuple m fs"
   shows "is_semialg_map_tuple m fs"
 proof-
   have "\<And>n fs. is_semialg_function_tuple m fs \<and> length fs = n \<Longrightarrow> is_semialg_map_tuple m fs"
   proof- fix n
     show " \<And> fs. is_semialg_function_tuple m fs \<and> length fs = n \<Longrightarrow> is_semialg_map_tuple m fs"
       apply(induction n)
       using singleton_tuple_partial_pullback_is_semialg_map_tuple empty_tuple_partial_pullback_is_semialg_map_tuple apply blast
     proof-
       fix n fs
       assume IH: "(\<And>fs. is_semialg_function_tuple m fs \<and> length fs = n \<Longrightarrow> is_semialg_map_tuple m fs)"
       assume A: "is_semialg_function_tuple m fs \<and> length fs = Suc n"
       then obtain gs f where gs_f_def: "fs = gs@[f]"
         by (metis length_Suc_conv list.discI rev_exhaust)
       have gs_length: "length gs = n"
         using gs_f_def
         by (metis A length_append_singleton nat.inject)
       have 0: "set gs \<subseteq> set fs"
         by (simp add: gs_f_def subsetI)
       have 1: "is_semialg_function_tuple m gs"
         apply(rule is_semialg_function_tupleI)
         using 0 A gs_f_def is_semialg_function_tupleE'[of m fs]
         by blast
       then have 2: "is_semialg_map_tuple m gs"
         using IH gs_length
         by blast
       have 3: "is_semialg_function m f"
         using gs_f_def A
         by (metis gs_length is_semialg_function_tupleE lessI nth_append_length)
       then show "is_semialg_map_tuple m fs"
         using assms 2 gs_f_def tuple_partial_pullback_is_semialg_map_tuple_induct
         by blast
     qed
   qed
   then show ?thesis
     using assms by blast
 qed
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Semialgebraic Functions are Closed under Composition with Semialgebraic Tuples\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 lemma function_tuple_comp_partial_pullback:
   assumes "is_semialg_function_tuple m fs"
   assumes "length fs = n"
   assumes "is_semialg_function n f"
   assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
   shows "partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S =
              tuple_partial_pullback m fs k (partial_pullback n f k S)"
 proof-
   have 0: "\<And>x. partial_image m (function_tuple_comp Q\<^sub>p fs f) x =
         partial_image n f (tuple_partial_image m fs x)"
     unfolding partial_image_def function_tuple_comp_def tuple_partial_image_def
     using comp_apply[of f "function_tuple_eval Q\<^sub>p 0 fs"]
     unfolding function_tuple_eval_def
   proof -
     fix x :: "((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set list"
     assume a1: "\<And>x. (f \<circ> (\<lambda>x. map (\<lambda>f. f x) fs)) x = f (map (\<lambda>f. f x) fs)"
     have f2: "\<forall>f rs. drop n (map f fs @ (rs::((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set list)) = rs"
       by (simp add: assms(2))
     have "\<forall>f rs. take n (map f fs @ (rs::((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set list)) = map f fs"
       by (simp add: assms(2))
     then show "(f \<circ> (\<lambda>rs. map (\<lambda>f. f rs) fs)) (take m x) # drop m x =
               f (take n (map (\<lambda>f. f (take m x)) fs @ drop m x)) # drop n (map (\<lambda>f. f (take m x)) fs @ drop m x)"
       using f2 a1 by presburger
   qed
   show "partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S =
               tuple_partial_pullback m fs k (partial_pullback n f k S)"
   proof
     show "partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S \<subseteq> tuple_partial_pullback m fs k (partial_pullback n f k S)"
     proof fix x assume A: "x \<in> partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S"
       then have 1: "partial_image m (function_tuple_comp Q\<^sub>p fs f) x \<in> S"
         using partial_pullback_memE(2) by blast
       have 2: "  partial_image n f (tuple_partial_image m fs x) \<in> S"
         using 0 1
         by presburger
       have 3: "x \<in> carrier (Q\<^sub>p\<^bsup>m + k\<^esup>)"
         using A assms
         by (metis partial_pullback_memE(1))
       have 4: "tuple_partial_image m fs x \<in> partial_pullback n f k S"
         apply(rule partial_pullback_memI)
          apply (metis "0" "3" add_cancel_left_left assms(1) assms(2) cartesian_power_drop drop0
             list.inject local.partial_image_def not_gr_zero semialg_function_tuple_is_function_tuple
             tuple_partial_image_closed)
         by (metis "2" local.partial_image_def)
       show " x \<in> tuple_partial_pullback m fs k (partial_pullback n f k S)"
         apply(rule tuple_partial_pullback_memI)
         apply (simp add: "3")
         using assms(1) semialg_function_tuple_is_function_tuple apply blast
         by (metis "4" tuple_partial_image_def)
     qed
     show " tuple_partial_pullback m fs k (partial_pullback n f k S) \<subseteq> partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S"
     proof fix x assume A: "x \<in> tuple_partial_pullback m fs k (partial_pullback n f k S)"
       show "x \<in> partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S "
       proof-
         have "partial_image n f (tuple_partial_image m fs x) \<in> S"
           using A partial_pullback_memE(2) tuple_partial_pullback_memE(2)
           by blast
         show ?thesis
           apply(rule partial_pullback_memI)
            apply (meson A subset_eq tuple_partial_pullback_closed)
           by (metis "0" \<open>local.partial_image n f (tuple_partial_image m fs x) \<in> S\<close>
               local.partial_image_def)
       qed
     qed
   qed
 qed
 
 lemma semialg_function_tuple_comp:
   assumes "is_semialg_function_tuple m fs"
   assumes "length fs = n"
   assumes "is_semialg_function n f"
   shows "is_semialg_function m (function_tuple_comp Q\<^sub>p fs f)"
 proof(rule is_semialg_functionI)
   show "function_tuple_comp Q\<^sub>p fs f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"
     using function_tuple_comp_closed[of f Q\<^sub>p n fs] assms(1) assms(2)
       assms(3) is_semialg_function_closed semialg_function_tuple_is_function_tuple
     by blast
   show "\<And>k S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (m + k) (partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S)"
   proof- fix k S
     assume A0: "S \<in> semialg_sets (1 + k)"
     show "is_semialgebraic (m + k) (partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S)"
     proof-
       have 0: "partial_pullback m (function_tuple_comp Q\<^sub>p fs f) k S =
              tuple_partial_pullback m fs k (partial_pullback n f k S)"
         using  function_tuple_comp_partial_pullback[of m fs n f S k] assms
             \<open>S \<in> semialg_sets (1 + k)\<close> is_semialgebraicI is_semialgebraic_closed
         by blast
       have 1: "is_semialgebraic (n + k) (partial_pullback n f k S)"
         using assms A0 is_semialg_functionE is_semialgebraicI
         by blast
       have 2: "is_semialgebraic (m + k) (tuple_partial_pullback m fs k (partial_pullback n f k S))"
         using 1 0 assms tuple_partial_pullback_is_semialg_map_tuple[of m fs]
           is_semialg_map_tupleE[of m fs k "partial_pullback n f k S"]
         by blast
       then show ?thesis
         using 0
         by simp
     qed
   qed
 qed
 
 
       (********************************************************************************************)
       (********************************************************************************************)
       subsubsection\<open>Algebraic Operations on Semialgebraic Functions\<close>
       (********************************************************************************************)
       (********************************************************************************************)
 
 
 text\<open>Defining the set of extensional semialgebraic functions\<close>
 
 definition Qp_add_fun where
 "Qp_add_fun xs = xs!0 \<oplus>\<^bsub>Q\<^sub>p\<^esub> xs!1"
 
 definition Qp_mult_fun where
 "Qp_mult_fun xs = xs!0 \<otimes> xs!1"
 
 text\<open>Inversion function on first coordinates of Qp tuples. Arbitrarily redefined at 0 to map to 0\<close>
 
 definition Qp_invert where
 "Qp_invert xs = (if ((xs!0) = \<zero>) then \<zero> else (inv (xs!0)))"
 
 text\<open>Addition is semialgebraic\<close>
 
 lemma addition_is_semialg:
 "is_semialg_function 2 Qp_add_fun"
 proof-
   have 0: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>) \<Longrightarrow> Qp_add_fun x = Qp_ev (pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1) x"
   proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
     have "Qp_ev (pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1) x = (Qp_ev (pvar Q\<^sub>p 0) x) \<oplus>\<^bsub>Q\<^sub>p\<^esub> (Qp_ev (pvar Q\<^sub>p 1) x)"
       by (metis A One_nat_def eval_at_point_add  pvar_closed less_Suc_eq numeral_2_eq_2)
     then show " Qp_add_fun x = Qp_ev (pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1) x"
       by (metis A Qp_add_fun_def add_vars_def add_vars_rep one_less_numeral_iff
           pos2 semiring_norm(76))
   qed
   then have 1: "restrict Qp_add_fun (carrier (Q\<^sub>p\<^bsup>2\<^esup>)) =
       restrict (Qp_ev (pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1)) (carrier (Q\<^sub>p\<^bsup>2\<^esup>))"
     by (meson restrict_ext)
   have "is_semialg_function 2 (Qp_ev (pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1))"
     using poly_is_semialg[of "pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1"]
     by (meson MP.add.m_closed local.pvar_closed one_less_numeral_iff pos2 semiring_norm(76))
   then show ?thesis
     using 1 semialg_function_on_carrier[of 2 "Qp_add_fun" "Qp_ev (pvar Q\<^sub>p 0 \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1)"]
           semialg_function_on_carrier
     by presburger
 qed
 
 text\<open>Multiplication is semialgebraic:\<close>
 
 lemma multiplication_is_semialg:
 "is_semialg_function 2 Qp_mult_fun"
 proof-
   have 0: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>) \<Longrightarrow> Qp_mult_fun x = Qp_ev (pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1) x"
   proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
     have "Qp_ev (pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1) x =
                 (Qp_ev (pvar Q\<^sub>p 0) x) \<otimes> (Qp_ev (pvar Q\<^sub>p 1) x)"
       by (metis A One_nat_def eval_at_point_mult pvar_closed less_Suc_eq numeral_2_eq_2)
     then show " Qp_mult_fun x = Qp_ev (pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1) x"
       by (metis A Qp_mult_fun_def mult_vars_def mult_vars_rep
           one_less_numeral_iff pos2 semiring_norm(76))
   qed
   then have 1: "restrict Qp_mult_fun (carrier (Q\<^sub>p\<^bsup>2\<^esup>)) =
       restrict (Qp_ev (pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1)) (carrier (Q\<^sub>p\<^bsup>2\<^esup>))"
     by (meson restrict_ext)
   have "is_semialg_function 2 (Qp_ev (pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1))"
     using poly_is_semialg[of "pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1"]
     by (meson MP.m_closed local.pvar_closed one_less_numeral_iff pos2 semiring_norm(76))
   thus ?thesis
     using 1 semialg_function_on_carrier[of 2 "Qp_mult_fun" "Qp_ev (pvar Q\<^sub>p 0 \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>2\<^esub>]\<^esub> pvar Q\<^sub>p 1)"]
           semialg_function_on_carrier
     by presburger
 qed
 
 text\<open>Inversion is semialgebraic:\<close>
 
 lemma(in field) field_nat_pow_inv:
   assumes "a \<in> carrier R"
   assumes "a \<noteq> \<zero>"
   shows "inv (a [^] (n::nat)) = (inv a) [^] (n :: nat)"
   apply(induction n)
   using inv_one local.nat_pow_0 apply presburger
   using assms nat_pow_of_inv
   by (metis Units_one_closed field_inv(2) field_inv(3) unit_factor)
 
 lemma Qp_invert_basic_semialg:
   assumes "is_basic_semialg (1 + k)  S"
   shows "is_semialgebraic (1 + k) (partial_pullback 1 Qp_invert k S)"
 proof-
   obtain P n where P_n_def: "(n::nat) \<noteq> 0 \<and> P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1+k\<^esub>]) \<and> S = basic_semialg_set (1+k) n P \<and> P \<in> carrier (Q\<^sub>p[\<X>\<^bsub>1+k\<^esub>])"
     using assms is_basic_semialg_def
     by meson
   obtain d::nat where d_def: "d =  deg (coord_ring Q\<^sub>p k) (to_univ_poly (Suc k) 0 P)"
     by auto
   obtain l where l_def: "l =  ((- d) mod n)"
     by blast
   have 1: "(l + d) mod n = 0"
     by (metis add_eq_0_iff equation_minus_iff l_def mod_0 mod_add_cong mod_minus_eq zmod_int)
   then  obtain m::int where m_def:  " (l + d) = m*n "
     using d_def l_def
     by (metis mult_of_nat_commute zmod_eq_0D)
   have 2: "m \<ge>0"
   proof-
     have 10: "n > 0"
       using P_n_def
       by blast
     have 11: "l \<ge> 0"
       using l_def 10 Euclidean_Division.pos_mod_sign of_nat_0_less_iff
       by blast
     then show ?thesis
       using m_def
       by (metis "10" le_add_same_cancel1 minus_add_cancel negative_zle
         neq0_conv  of_nat_le_0_iff zero_le_imp_eq_int zero_le_mult_iff)
   qed
   obtain N where N_def: "N = m*n"
     by blast
   have 3: "N \<ge> d"
   proof-
     have "l \<ge> 0"
       using l_def d_def m_def  Euclidean_Division.pos_mod_sign[of n "-d"] P_n_def
       by linarith
     then show ?thesis
       using d_def N_def m_def
       by linarith
   qed
   have 4: "deg (coord_ring Q\<^sub>p k) (to_univ_poly (Suc k) 0 P) \<le> nat N"
     using d_def N_def 3
     by linarith
   have 5: " P \<in> carrier (coord_ring Q\<^sub>p (Suc k))"
     by (metis P_n_def  plus_1_eq_Suc)
   have 6: " \<exists>q\<in>carrier (coord_ring Q\<^sub>p (Suc k)).
        \<forall>x\<in>carrier Q\<^sub>p - {\<zero>}. \<forall>a\<in>carrier (Q\<^sub>p\<^bsup>k\<^esup>). Qp_ev q (insert_at_index a x 0) = (x[^]nat N) \<otimes> Qp_ev P (insert_at_index a (inv x) 0)"
     using 3 4 d_def to_univ_poly_one_over_poly''[of 0 k P "nat N"] "5"  Qp.field_axioms
     by blast
   obtain q where q_def: "q \<in> carrier (coord_ring Q\<^sub>p (Suc k)) \<and> ( \<forall> x \<in> carrier Q\<^sub>p - {\<zero>}. ( \<forall> a \<in>  carrier (Q\<^sub>p\<^bsup>k\<^esup>).
         eval_at_point Q\<^sub>p (insert_at_index a x 0) q =  (x[^] (nat N)) \<otimes> (eval_at_point Q\<^sub>p (insert_at_index a (inv x) 0) P)))"
     using 6
     by blast
   obtain T where T_def: "T = basic_semialg_set (1+k) n q"
     by auto
   have "is_basic_semialg (1 + k) T"
   proof-
     have "q \<in> carrier ( Q\<^sub>p[\<X>\<^bsub>Suc k\<^esub>])"
       using q_def
       by presburger
     then show ?thesis
       using T_def is_basic_semialg_def
       by (metis P_n_def plus_1_eq_Suc)
   qed
   then have T_semialg: "is_semialgebraic (1+k) T"
     using T_def basic_semialg_is_semialg[of "1+k" T] is_semialgebraicI
     by blast
   obtain Nz where Nz_def: "Nz = {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs!0 \<noteq> \<zero>}"
     by blast
   have Nz_semialg: "is_semialgebraic (1+k) Nz"
   proof-
     obtain Nzc where Nzc_def: "Nzc = {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs!0 = \<zero>}"
       by blast
     have 0: "Nzc = zero_set Q\<^sub>p (Suc k) (pvar Q\<^sub>p 0)"
       unfolding zero_set_def
       using Nzc_def
       by (metis (no_types, lifting) Collect_cong eval_pvar zero_less_Suc)
     have 1: "is_algebraic Q\<^sub>p (1+k)  Nzc"
       using 0 pvar_closed[of ]
       by (metis is_algebraicI' plus_1_eq_Suc zero_less_Suc)
     then have 2: "is_semialgebraic  (1+k) Nzc"
       using is_algebraic_imp_is_semialg by blast
     have 3: "Nz = carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>) - Nzc"
       using Nz_def Nzc_def
       by blast
     then show ?thesis
       using 2
       by (simp add: complement_is_semialg)
   qed
   have 7: "(partial_pullback 1 Qp_invert k S) \<inter> Nz = T \<inter> Nz"
   proof
     show "partial_pullback 1 Qp_invert k S \<inter> Nz \<subseteq> T \<inter> Nz"
     proof fix c assume A: "c \<in> partial_pullback 1 Qp_invert k S \<inter> Nz"
       show "c  \<in> T \<inter> Nz"
       proof-
         have c_closed: "c \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
           using A partial_pullback_closed[of 1  Qp_invert  k S]
           by blast
         obtain x a where xa_def: "c = (x#a)"
           using c_closed
           by (metis Suc_eq_plus1 add.commute cartesian_power_car_memE length_Suc_conv)
         have x_closed: "x \<in> carrier Q\<^sub>p"
           using xa_def  c_closed
           by (metis (no_types, lifting) append_Cons cartesian_power_decomp
               list.inject Qp.to_R1_to_R Qp.to_R_pow_closed)
         have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
           using  xa_def c_closed
           by (metis One_nat_def cartesian_power_drop drop0 drop_Suc_Cons)
         have 0: "c \<in> Nz"
           using A by blast
         then have "x \<noteq> \<zero>"
           using Nz_def xa_def
           by (metis (mono_tags, lifting) mem_Collect_eq nth_Cons_0)
         have 1: "Qp_invert [x] = inv x"
           unfolding Qp_invert_def
           by (metis \<open>x \<noteq> \<zero>\<close> nth_Cons_0)
         have 2: "partial_image 1 Qp_invert c \<in> S"
           using A partial_pullback_memE[of c 1 "Qp_invert" k S]
           by blast
         have 3: "inv x # a  \<in> S"
         proof-
           have 30: "[x] = take 1 c"
             by (simp add: xa_def)
           have 31: "a = drop 1 c"
             by (simp add: xa_def)
           show ?thesis
             using 1 30 31 partial_image_def[of 1 "Qp_invert" c] xa_def  "2"
             by metis
         qed
         obtain y where y_def: "y \<in> carrier Q\<^sub>p \<and> eval_at_point Q\<^sub>p (inv x # a) P = y [^] n"
           using 3 P_n_def basic_semialg_set_memE(2)
           by blast
         then have 4: "x [^] (nat N) \<otimes> eval_at_point Q\<^sub>p (inv x # a) P
                       = x [^] (nat N) \<otimes> y [^] n"
           by presburger
         have 5: "x [^] (nat N) \<otimes> y [^] n = ((x[^]m)\<otimes>y)[^]n"
         proof-
           have 50: "x [^] (N) \<otimes> y [^] n = x [^] (m*n) \<otimes> y [^] n"
             using N_def by blast
           have 51: "x [^] (m*n) = (x[^]m)[^]n"
             using Qp_int_nat_pow_pow \<open>x \<noteq> \<zero>\<close> not_nonzero_Qp x_closed
             by metis
           have 52: "x [^] (m*n)\<otimes> y [^] n = ((x[^]m) \<otimes> y) [^] n"
           proof-
             have 0: "x [^] (m*n)\<otimes> y [^] n= (x[^]m)[^]n \<otimes> (y[^] n)"
               using "51" by presburger
             have 1: "(x[^]m)[^]n \<otimes> (y[^] n) = ((x[^]m) \<otimes> y) [^] n"
               apply(induction n)
               using Qp.nat_pow_0 Qp.one_closed Qp.r_one apply presburger
               using x_closed y_def
               by (metis Qp.nat_pow_distrib Qp.nonzero_closed Qp_int_pow_nonzero \<open>x \<noteq> \<zero>\<close> not_nonzero_Qp)
             then show ?thesis
               using "0" by blast
           qed
           have 53: "x [^] N = x [^] (nat N)"
           proof-
             have "N \<ge> 0"
               by (metis (full_types) Euclidean_Division.pos_mod_sign N_def P_n_def
                   add_increasing2 int.lless_eq l_def  m_def  of_nat_0_le_iff of_nat_le_0_iff )
             then show ?thesis
                by (metis pow_nat)
           qed
           then show ?thesis
             using 50 52
             by presburger
         qed
         have 6: "x [^] (nat N) \<otimes> eval_at_point Q\<^sub>p (inv x # a) P = ((x[^]m)\<otimes>y)[^]n"
           using "4" "5"
           by blast
         have 7: "eval_at_point Q\<^sub>p c q = ((x[^]m)\<otimes>y)[^]n"
         proof-
           have 70: "(insert_at_index a (inv x) 0) = inv x # a"
             using insert_at_index.simps
             by (metis (no_types, lifting) append_eq_append_conv2 append_same_eq append_take_drop_id drop0 same_append_eq)
           have 71: "(insert_at_index a x) 0 =  x # a"
             by simp
           then show ?thesis using 6 q_def
             by (metis "70" DiffI \<open>x \<noteq> \<zero>\<close> a_closed empty_iff insert_iff x_closed xa_def)
         qed
         have 8: "(x[^]m)\<otimes>y \<in> carrier Q\<^sub>p"
         proof-
           have 80: "x[^]m \<in> carrier Q\<^sub>p"
             using  \<open>x \<noteq> \<zero>\<close> x_closed Qp_int_pow_nonzero[of x m] unfolding nonzero_def
             by blast
           then show ?thesis
             using y_def by blast
         qed
         then have "c \<in> T"
           using T_def basic_semialg_set_def "7" c_closed by blast
         then show ?thesis
           by (simp add: \<open>c \<in> T\<close> "0")
       qed
     qed
     show "T \<inter> Nz \<subseteq> partial_pullback 1 Qp_invert k S \<inter> Nz"
     proof fix x assume A: "x \<in> T \<inter> Nz"
       show " x \<in> partial_pullback 1 Qp_invert k S \<inter> Nz "
       proof-
         have " x \<in> partial_pullback 1 Qp_invert k S"
         proof(rule partial_pullback_memI)
           show x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
             using T_def A
             by (meson IntD1 basic_semialg_set_memE(1))
           show "Qp_invert (take 1 x) # drop 1 x \<in> S"
           proof-
             have 00: "x!0  \<noteq> \<zero>"
               using A Nz_def
               by blast
             then have 0: "Qp_invert (take 1 x) # drop 1 x = inv (x!0) # drop 1 x"
               unfolding Qp_invert_def
               by (smt One_nat_def lessI nth_take)
             have "drop 1 x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
               using \<open>x \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)\<close> cartesian_power_drop by blast
             obtain a where a_def: "a = (x!0)"
               by blast
             have a_closed: "a \<in> carrier Q\<^sub>p"
               using 00 a_def A Nz_def cartesian_power_car_memE'[of x Q\<^sub>p "Suc k" 0] inv_in_frac(1)
               by blast
             have a_nz: "a \<noteq> \<zero>"
               using a_def Nz_def  A
               by blast
             obtain b where b_def: "b = drop 1 x"
               by blast
             have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
               using b_def A Nz_def  \<open>drop 1 x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)\<close>
               by blast
             have abx: "x = a#b"
               using a_def b_def x_closed
               by (metis (no_types, lifting) One_nat_def append_Cons append_Nil
                   append_eq_conv_conj cartesian_power_car_memE cartesian_power_decomp
                   lessI nth_take Qp.to_R1_to_R)
             have 1: "Qp_invert (take 1 x) # drop 1 x = (inv a)#b"
               using "0" a_def b_def
               by blast
             have 22: "eval_at_point Q\<^sub>p (insert_at_index b a 0) q =
                 (a[^] (nat N)) \<otimes> (eval_at_point Q\<^sub>p (insert_at_index b (inv a) 0) P)"
               using q_def a_closed a_nz b_closed
               by blast
             obtain c where c_def: "c \<in> carrier Q\<^sub>p \<and> Qp_ev q x = (c[^]n)"
               using  A T_def unfolding basic_semialg_set_def
               by blast
             obtain c' where c'_def: "c' = (inv a)[^]m  \<otimes>  c"
               by blast
             have c'_closed: "c' \<in> carrier Q\<^sub>p"
               using c_def a_def a_closed a_nz Qp_int_pow_nonzero nonzero_def
                  c'_def inv_in_frac(3) Qp.m_closed Qp.nonzero_closed by presburger
             have 3: "(eval_at_point Q\<^sub>p ((inv a) # b) P) = (c'[^]n)"
             proof-
               have 30: "x = insert_at_index b a 0"
                 using abx
                 by simp
               have 31: "(c[^]n) =
                 (a[^] (nat N)) \<otimes> (eval_at_point Q\<^sub>p (insert_at_index b (inv a) 0) P)"
                 using 22 30 c_def
                 by blast
               have 32: "insert_at_index b (inv a) 0 = (inv a) # b"
                 using insert_at_index.simps
                 by (metis drop0 self_append_conv2 take0)
               have 33: "(c[^]n) =
                 (a[^] (nat N)) \<otimes> (eval_at_point Q\<^sub>p ((inv a) # b) P)"
                using "31" "32" by presburger
               have 34: "(inv a) # b \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
                 apply(rule cartesian_power_car_memI'')
                  apply (metis b_closed cartesian_power_car_memE length_Suc_conv plus_1_eq_Suc)
                 using a_closed a_nz b_closed
                 apply (metis One_nat_def inv_in_frac(1) take0 take_Suc_Cons Qp.to_R1_closed)
                 by (metis abx b_closed b_def drop_Cons' not_Cons_self2)
               have 35: "(eval_at_point Q\<^sub>p ((inv a) # b) P) \<in> carrier Q\<^sub>p"
                 using 34 P_n_def  eval_at_point_closed
                 by blast
               have  "inv(a[^] (nat N)) \<otimes> (c[^]n) =
                inv(a[^] (nat N)) \<otimes> ((a[^] (nat N)) \<otimes> (eval_at_point Q\<^sub>p ((inv a) # b) P))"
                 using 31 "33"  by presburger
               then have 6: "inv(a[^] (nat N)) \<otimes> (c[^]n) =
                inv(a[^] (nat N)) \<otimes> (a[^] (nat N)) \<otimes> (eval_at_point Q\<^sub>p ((inv a) # b) P)"
                 using 35 monoid.m_assoc[of Q\<^sub>p] Qp.monoid_axioms Qp.nat_pow_closed
                   Qp.nonzero_pow_nonzero a_nz inv_in_frac(1) local.a_closed by presburger
               have 37:"inv(a[^] (nat N)) \<otimes> (c[^]n) = (eval_at_point Q\<^sub>p ((inv a) # b) P)"
               proof-
                 have "inv(a[^] (nat N)) \<otimes> (a[^] (nat N)) = \<one> "
                   using  a_closed  a_nz Qp.nat_pow_closed Qp.nonzero_pow_nonzero field_inv(1)
                   by blast
                 then have "inv(a[^] (nat N)) \<otimes> (c[^]n) =
                         \<one> \<otimes> (eval_at_point Q\<^sub>p ((inv a) # b) P)"
                   using 6 by presburger
                 then show ?thesis using 35 Qp.l_one by blast
               qed
               have 38:"(inv a)[^] (nat N) \<otimes> (c[^]n) = (eval_at_point Q\<^sub>p ((inv a) # b) P)"
                 using 37 group.nat_pow_inv[of Q\<^sub>p a "nat N"] a_closed Qp.field_axioms field.field_nat_pow_inv[of Q\<^sub>p]
                 by (metis a_nz)
               have 39:"((inv a)[^]m) [^] \<^bsub>Q\<^sub>p\<^esub> n \<otimes> (c[^]n) = (eval_at_point Q\<^sub>p ((inv a) # b) P)"
                 using 2  38 monoid.nat_pow_pow[of Q\<^sub>p "inv a" ] N_def
                 by (smt "3" Qp_int_nat_pow_pow a_closed a_nz inv_in_frac(3) of_nat_0_le_iff pow_nat)
               have 310:"((((inv a)[^]m) \<otimes> c)[^]n) = (eval_at_point Q\<^sub>p ((inv a) # b) P)"
               proof-
                 have AA: "(inv a)[^]m \<in> carrier Q\<^sub>p"
                   using Qp_int_pow_nonzero nonzero_def a_closed a_nz inv_in_frac(3) Qp.nonzero_closed
                   by presburger
                 have "((inv a)[^]m) [^] \<^bsub>Q\<^sub>p\<^esub> n \<otimes> (c[^]n) = ((((inv a)[^]m) \<otimes> c)[^]n)"
                   using Qp.nat_pow_distrib[of  "(inv a)[^]m" c n]  a_closed a_def c_def AA by blast
                 then show ?thesis
                   using "39" by blast
               qed
               then show ?thesis using c'_def
                 by blast
             qed
             have 4: "inv a # b \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
               by (metis a_closed a_nz add.commute b_closed cartesian_power_cons inv_in_frac(1))
             then have 5: "((inv a) # b) \<in> S"
               using 3 P_n_def c'_closed  basic_semialg_set_memI[of "(inv a) # b" "1 + k" c' P n]
               by blast
             have 6: "Qp_invert (take 1 x) # drop 1 x = inv a # b"
               using a_def b_def unfolding Qp_invert_def using "1" Qp_invert_def
               by blast
             show ?thesis using 5 6
               by presburger
           qed
         qed
         then show ?thesis
           using A by blast
       qed
     qed
   qed
   have 8: "is_semialgebraic (1+k) ((partial_pullback 1 Qp_invert k S) \<inter> Nz)"
     using "7" Nz_semialg T_semialg intersection_is_semialg
     by auto
   have 9: "(partial_pullback 1 Qp_invert k S) - Nz = {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs!0 = \<zero>} \<inter>S"
   proof
     show "partial_pullback 1 Qp_invert k S - Nz \<subseteq> {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs ! 0 = \<zero>} \<inter>  S"
     proof fix x assume A: " x \<in> partial_pullback 1 Qp_invert k S - Nz"
       have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>)"
         using A
         by (metis DiffD1 partial_pullback_memE(1) plus_1_eq_Suc)
       have 1: "take 1 x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
         by (metis "0" le_add1 plus_1_eq_Suc take_closed)
       have 2: "drop 1 x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
         using "0" cartesian_power_drop plus_1_eq_Suc
         by presburger
       have 3: " x = take 1 x @ drop 1 x "
         using 0
         by (metis append_take_drop_id)
       have 4: "Qp_invert (take 1 x) # drop 1 x \<in> S"
         using A partial_pullback_memE'[of "take 1 x" 1 "drop 1 x" k x Qp_invert S] 1 2 3
         by blast
       have 5: "x!0 = \<zero>"
         using A 0 Nz_def by blast
       have 6: "Qp_invert (take 1 x) # drop 1 x = x"
       proof-
         have "(take 1 x) =[x!0]"
           using 0
           by (metis "1" "3" append_Cons nth_Cons_0 Qp.to_R1_to_R)
         then have "Qp_invert (take 1 x) = \<zero>"
           unfolding Qp_invert_def using 5
           by (metis less_one nth_take)
         then show ?thesis using 0 5
           by (metis "3" Cons_eq_append_conv \<open>take 1 x = [x ! 0]\<close> self_append_conv2)
       qed
       have "x \<in> S"
         using 6 4
         by presburger
       then show "x \<in> {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs ! 0 = \<zero>} \<inter>  S"
         using Nz_def A 0
         by blast
     qed
     show "{xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs ! 0 = \<zero>} \<inter> S \<subseteq> partial_pullback 1 Qp_invert k S - Nz"
     proof fix x assume A: "x \<in> {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs ! 0 = \<zero>} \<inter> S"
       have A0: "x \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>)"
         using A by blast
       have A1: "x!0  = \<zero>"
         using A by blast
       have A2: "x \<in> S"
         using A by blast
       show " x \<in> partial_pullback 1 Qp_invert k S - Nz"
       proof
         show "x \<notin> Nz"
           using Nz_def A1 by blast
         show " x \<in> partial_pullback 1 Qp_invert k S"
         proof(rule partial_pullback_memI)
           show "x \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)"
             using A0
             by (simp add: A0)
           show "Qp_invert (take 1 x) # drop 1 x \<in> S"
           proof-
             have "Qp_invert (take 1 x) = \<zero>"
               unfolding Qp_invert_def  using A0 A1
               by (metis less_numeral_extra(1) nth_take)
             then have "Qp_invert (take 1 x) # drop 1 x = x"
               using A0 A1 A2
               by (metis (no_types, lifting) Cons_eq_append_conv Qp_invert_def \<open>x \<in> carrier (Q\<^sub>p\<^bsup>1+k\<^esup>)\<close>
                   append_take_drop_id inv_in_frac(2) le_add_same_cancel1 self_append_conv2
                   take_closed Qp.to_R1_to_R Qp.to_R_pow_closed zero_le)
             then show ?thesis
               using A2 by presburger
           qed
         qed
       qed
     qed
   qed
   have 10: "is_semialgebraic (1+k) {xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs!0 = \<zero>}"
   proof-
     have "{xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs!0 = \<zero>} = V\<^bsub>Q\<^sub>p\<^esub> (Suc k) (pvar Q\<^sub>p 0)"
       unfolding zero_set_def using eval_pvar[of  0 "Suc k"] Qp.cring_axioms
       by blast
     then show ?thesis using
         is_zero_set_imp_basic_semialg pvar_closed[of  0 "Suc k"] Qp.cring_axioms
         is_zero_set_imp_semialg plus_1_eq_Suc zero_less_Suc
       by presburger
   qed
   have 11: "is_semialgebraic (1+k) ({xs \<in> carrier (Q\<^sub>p\<^bsup>Suc k\<^esup>). xs!0 = \<zero>} \<inter>S)"
     using 10 assms basic_semialg_is_semialgebraic intersection_is_semialg
     by blast
   have 12: "(partial_pullback 1 Qp_invert k S) = ((partial_pullback 1 Qp_invert k S) \<inter> Nz) \<union>
                                                   ((partial_pullback 1 Qp_invert k S) - Nz)"
     by blast
   have 13: "is_semialgebraic (1+k) ((partial_pullback 1 Qp_invert k S) - Nz)"
     using 11  9 by metis
   show ?thesis
     using 8  12 13
     by (metis "7" Int_Diff_Un Int_commute plus_1_eq_Suc union_is_semialgebraic)
 qed
 
 lemma Qp_invert_is_semialg:
 "is_semialg_function 1 Qp_invert"
 proof(rule is_semialg_functionI')
   show 0: "Qp_invert \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>) \<rightarrow> carrier Q\<^sub>p"
   proof fix x
     assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
     then obtain a where a_def: "x = [a]"
       by (metis Qp.to_R1_to_R)
     have a_closed: "a \<in> carrier Q\<^sub>p"
       using a_def A cartesian_power_concat(1) last_closed'
       by blast
     show " Qp_invert x \<in> carrier Q\<^sub>p"
     apply(cases "a = \<zero>")
     unfolding Qp_invert_def using a_def a_closed
     apply (meson Qp.to_R_to_R1)
     by (metis a_closed a_def inv_in_frac(1) Qp.to_R_to_R1)
   qed
   show "\<And>k S. S \<in> basic_semialgs (1 + k) \<Longrightarrow> is_semialgebraic (1 + k) (partial_pullback 1 Qp_invert k S)"
     using Qp_invert_basic_semialg
     by blast
 qed
 
 lemma Taylor_deg_1_expansion'':
   assumes "f \<in> carrier Q\<^sub>p_x"
   assumes "\<And>n. f n \<in> \<O>\<^sub>p"
   assumes "a \<in> \<O>\<^sub>p "
   assumes "b \<in> \<O>\<^sub>p"
   shows "\<exists>c c' c''. c = to_fun f a \<and> c' = deriv f a \<and> c \<in> \<O>\<^sub>p \<and> c' \<in> \<O>\<^sub>p \<and>c'' \<in> \<O>\<^sub>p \<and>
                   to_fun f (b) = c \<oplus> c' \<otimes> (b \<ominus> a) \<oplus> (c'' \<otimes> (b \<ominus> a)[^](2::nat))"
 proof-
   obtain S where S_def: "S = (Q\<^sub>p  \<lparr> carrier := \<O>\<^sub>p \<rparr>)"
     by blast
   have 1: "f \<in> carrier (UP S)"
     unfolding S_def using val_ring_subring UPQ.poly_cfs_subring[of \<O>\<^sub>p f] assms
     by blast
   have 2: " f \<in> carrier (UP (Q\<^sub>p\<lparr>carrier := \<O>\<^sub>p\<rparr>))"
     using val_ring_subring 1 assms poly_cfs_subring[of \<O>\<^sub>p]
     by blast
   have 3: "\<exists>c\<in>\<O>\<^sub>p. f \<bullet> b = f \<bullet> a \<oplus> UPQ.deriv f a \<otimes> (b \<ominus> a) \<oplus> c \<otimes> (b \<ominus> a) [^] (2::nat)"
     using UP_subring_taylor_appr'[of \<O>\<^sub>p f b a] UP_subring_taylor_appr[of \<O>\<^sub>p f b a] val_ring_subring 1 2 assms
     by blast
   then show ?thesis
     using UP_subring_taylor_appr[of \<O>\<^sub>p f b a] assms UP_subring_deriv_closed[of \<O>\<^sub>p f a]
       UP_subring_eval_closed[of \<O>\<^sub>p f a] 2 val_ring_subring by blast
 qed
 
 end
 
 (**************************************************************************************************)
 (**************************************************************************************************)
 subsection\<open>Sets Defined by Residues of Valuation Ring Elements\<close>
 (**************************************************************************************************)
 (**************************************************************************************************)
 
 sublocale padic_fields < Res: cring "Zp_res_ring (Suc n)"
   using p_residues residues.cring
   by blast
 
 context padic_fields
 begin
 
 definition Qp_res where
 "Qp_res x n =  to_Zp x n "
 
 lemma Qp_res_closed:
   assumes "x \<in> \<O>\<^sub>p"
   shows "Qp_res  x n \<in> carrier (Zp_res_ring n)"
   unfolding Qp_res_def using assms val_ring_memE residue_closed to_Zp_closed by blast
 
 lemma Qp_res_add:
   assumes "x \<in> \<O>\<^sub>p"
   assumes "y \<in> \<O>\<^sub>p"
   shows "Qp_res (x \<oplus> y) n = Qp_res x n \<oplus>\<^bsub>Zp_res_ring n\<^esub> Qp_res y n"
   unfolding Qp_res_def
   using assms residue_of_sum to_Zp_add by presburger
 
 lemma Qp_res_mult:
   assumes "x \<in> \<O>\<^sub>p"
   assumes "y \<in> \<O>\<^sub>p"
   shows "Qp_res (x \<otimes> y) n = Qp_res x n \<otimes>\<^bsub>Zp_res_ring n\<^esub> Qp_res y n"
   unfolding Qp_res_def
   using assms residue_of_prod to_Zp_mult by presburger
 
 lemma Qp_res_diff:
   assumes "x \<in> \<O>\<^sub>p"
   assumes "y \<in> \<O>\<^sub>p"
   shows "Qp_res (x \<ominus> y) n = Qp_res x n \<ominus>\<^bsub>Zp_res_ring n\<^esub> Qp_res y n"
   unfolding Qp_res_def
   using assms residue_of_diff to_Zp_minus
   by (meson val_ring_res)
 
 lemma Qp_res_zero:
   shows  "Qp_res \<zero> n = 0"
   unfolding Qp_res_def to_Zp_zero
   using residue_of_zero(2) by blast
 
 lemma Qp_res_one:
   assumes "n > 0"
   shows  "Qp_res \<one> n = (1::int)"
   using assms
   unfolding Qp_res_def to_Zp_one
   using residue_of_one(2) by blast
 
 lemma Qp_res_nat_inc:
   shows  "Qp_res ([(n::nat)]\<cdot>\<one>) n = n mod p^n"
   unfolding Qp_res_def unfolding to_Zp_nat_inc
   using Zp_nat_inc_res by blast
 
 lemma Qp_res_int_inc:
   shows  "Qp_res ([(k::int)]\<cdot>\<one>) n = k mod p^n"
   unfolding Qp_res_def unfolding to_Zp_int_inc
   using Zp_int_inc_res by blast
 
 lemma Qp_poly_res_monom:
 assumes "a \<in> \<O>\<^sub>p"
 assumes "x \<in> \<O>\<^sub>p"
 assumes "Qp_res a n = 0"
 assumes "k > 0"
 shows "Qp_res (up_ring.monom (UP Q\<^sub>p) a k \<bullet> x) n = 0"
 proof-
   have 0: "up_ring.monom (UP Q\<^sub>p) a k \<bullet> x = a \<otimes> x [^] k"
     apply(rule UPQ.to_fun_monom[of a x k])
     using assms val_ring_memE apply blast
     using assms val_ring_memE by blast
   have 1: "x[^]k \<in> \<O>\<^sub>p"
     using assms val_ring_nat_pow_closed by blast
   show ?thesis unfolding 0
     using Qp_res_mult[of a "x[^]k" n] assms
     using "1" residue_times_zero_r by presburger
 qed
 
 lemma Qp_poly_res_zero:
   assumes "q \<in> carrier (UP Q\<^sub>p)"
   assumes "\<And>i. q i \<in> \<O>\<^sub>p"
   assumes "\<And>i. Qp_res (q i) n = 0"
   assumes "x \<in> \<O>\<^sub>p"
   shows "Qp_res (q \<bullet> x) n = 0"
 proof-
   have "(\<forall>i. q i \<in> \<O>\<^sub>p \<and> Qp_res (q i) n = 0) \<longrightarrow> Qp_res (q \<bullet> x) n = 0"
   proof(rule UPQ.poly_induct[of q], rule assms, rule )
     fix p assume A: "p \<in> carrier (UP Q\<^sub>p)" " deg Q\<^sub>p p = 0" " \<forall>i. p i \<in> \<O>\<^sub>p \<and> Qp_res (p i) n = 0"
     have 0: "p \<bullet> x = p 0"
       using assms
       by (metis A(1) A(2) val_ring_memE UPQ.ltrm_deg_0 UPQ.to_fun_ctrm)
     show "Qp_res (p \<bullet> x) n = 0"
       unfolding 0 using A by blast
   next
     fix p
     assume A0: "(\<And>q. q \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> deg Q\<^sub>p q < deg Q\<^sub>p p \<Longrightarrow> (\<forall>i. q i \<in> \<O>\<^sub>p \<and> Qp_res (q i) n = 0) \<longrightarrow> Qp_res (q \<bullet> x) n = 0)"
       "p \<in> carrier (UP Q\<^sub>p)" "0 < deg Q\<^sub>p p"
     show "(\<forall>i. p i \<in> \<O>\<^sub>p \<and> Qp_res (p i) n = 0) \<longrightarrow> Qp_res (p \<bullet> x) n = 0"
     proof assume A1: " \<forall>i. p i \<in> \<O>\<^sub>p \<and> Qp_res (p i) n = 0"
       obtain k where k_def: "k = deg Q\<^sub>p p"
         by blast
       obtain q where q_def: "q = UPQ.trunc p"
         by blast
       have q_closed: "q \<in> carrier (UP Q\<^sub>p)"
         unfolding q_def
         using A0(2) UPQ.trunc_closed by blast
       have q_deg: "deg Q\<^sub>p q < deg Q\<^sub>p p"
         unfolding q_def
         using A0(2) A0(3) UPQ.trunc_degree by blast
       have 9: "\<And>i. i < deg Q\<^sub>p p \<Longrightarrow> q i = p i"
         unfolding q_def
         using A0(2) UPQ.trunc_cfs by blast
       have 90:  "\<And>i. \<not> i < deg Q\<^sub>p p \<Longrightarrow> q i = \<zero>"
         unfolding q_def
       proof -
         fix i :: nat
         assume "\<not> i < deg Q\<^sub>p p"
         then have "deg Q\<^sub>p q < i"
           using q_deg by linarith
         then show "Cring_Poly.truncate Q\<^sub>p p i = \<zero>"
           using UPQ.deg_gtE q_closed q_def by blast
       qed
       have 10: "(\<forall>i. q i \<in> \<O>\<^sub>p \<and> Qp_res (q i) n = 0)"
       proof fix i
         show "q i \<in> \<O>\<^sub>p \<and> Qp_res (q i) n = 0"
           apply(cases "i < deg Q\<^sub>p p")
            using A1  9[of i] apply presburger
            unfolding q_def using Qp_res_zero  90
            by (metis q_def zero_in_val_ring)
       qed
       have 11: "Qp_res (q \<bullet> x) n = 0"
         using 10 A1 A0 q_closed q_deg by blast
       have 12: "p = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> up_ring.monom (UP Q\<^sub>p) (p k) k"
         unfolding k_def q_def
         using A0(2) UPQ.trunc_simps(1) by blast
       have 13: "p \<bullet> x = q \<bullet> x \<oplus> (up_ring.monom (UP Q\<^sub>p) (p k) k) \<bullet> x"
       proof-
         have 0: " (q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> up_ring.monom (UP Q\<^sub>p) (p k) k) \<bullet> x = q \<bullet> x \<oplus> up_ring.monom (UP Q\<^sub>p) (p k) k \<bullet> x"
           apply(rule UPQ.to_fun_plus)
           using A0(2) UPQ.ltrm_closed k_def apply blast
           unfolding q_def apply(rule UPQ.trunc_closed, rule A0)
           using assms val_ring_memE by blast
         show ?thesis
           using 0 12 by metis
       qed
       have 14: "(up_ring.monom (UP Q\<^sub>p) (p k) k) \<bullet> x \<in> \<O>\<^sub>p"
         apply(rule val_ring_poly_eval)
           using A0(2) UPQ.ltrm_closed k_def apply blast
           using UPQ.cfs_monom[of "p k" k ] A1 zero_in_val_ring
           using A0(2) UPQ.ltrm_cfs k_def apply presburger
           using assms(4) by blast
       have 15: "Qp_res ((up_ring.monom (UP Q\<^sub>p) (p k) k) \<bullet> x) n = 0"
         apply(rule Qp_poly_res_monom)
         using A1 apply blast using assms apply blast
         using A1 apply blast unfolding k_def using A0 by blast
       have 16: "Qp_res (q \<bullet> x) n = 0"
         using A0 10 11 by blast
       have 17: "q \<bullet> x \<in> \<O>\<^sub>p"
         apply(rule val_ring_poly_eval, rule q_closed)
         using 10 apply blast by(rule assms)
       have 18: "Qp_res (q \<bullet> x \<oplus> (up_ring.monom (UP Q\<^sub>p) (p k) k) \<bullet> x) n = 0"
         using Qp_res_add[of "q \<bullet> x" "up_ring.monom (UP Q\<^sub>p) (p k) k \<bullet> x" n] 14  17
         unfolding 15 16
         by (metis "10" Qp_res_add UPQ.cfs_add UPQ.coeff_of_sum_diff_degree0 q_closed q_deg)
       show "Qp_res (p \<bullet> x) n = 0"
         using 13 18 by metis
     qed
   qed
   thus ?thesis using assms by blast
 qed
 
 lemma Qp_poly_res_eval_0:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "g \<in> carrier (UP Q\<^sub>p)"
   assumes "x \<in> \<O>\<^sub>p"
   assumes "\<And>i. f i \<in> \<O>\<^sub>p"
   assumes "\<And>i. g i \<in> \<O>\<^sub>p"
   assumes "\<And>i. Qp_res (f i) n = Qp_res (g i) n"
   shows "Qp_res (f \<bullet> x) n = Qp_res (g \<bullet> x) n"
 proof-
     obtain F where F_def: "F = f \<ominus>\<^bsub>UP Q\<^sub>p\<^esub>g"
       by blast
     have F_closed: "F \<in> carrier (UP Q\<^sub>p)"
       unfolding F_def
       using assms by blast
     have F_cfs: "\<And>i. F i = (f i) \<ominus> (g i)"
       unfolding F_def
       using assms UPQ.cfs_minus by blast
     have F_cfs_res: "\<And>i. Qp_res (F i) n = Qp_res (f i) n \<ominus>\<^bsub>Zp_res_ring n\<^esub> Qp_res (g i) n"
       unfolding F_cfs apply(rule Qp_res_diff)
       using assms apply blast using assms by blast
     have 0: "\<And>i. Qp_res (f i) n = Qp_res (g i) n"
       using assms by blast
     have F_cfs_res': "\<And>i. Qp_res (F i) n = 0"
       unfolding F_cfs_res 0
       by (metis diff_self mod_0 residue_minus)
     have 1: "\<And>i. F i \<in> \<O>\<^sub>p"
       unfolding F_cfs using assms
       using val_ring_minus_closed by blast
     have 2: "Qp_res (F \<bullet> x) n = 0"
       by(rule Qp_poly_res_zero, rule F_closed, rule 1, rule F_cfs_res', rule assms)
     have 3: "F \<bullet> x = f \<bullet> x \<ominus> g \<bullet> x"
       unfolding F_def using assms
       by (meson assms UPQ.to_fun_diff val_ring_memE)
     have 4: "Qp_res (F \<bullet> x) n = Qp_res (f \<bullet> x) n \<ominus>\<^bsub>Zp_res_ring n\<^esub> Qp_res (g \<bullet> x) n"
       unfolding 3 apply(rule Qp_res_diff, rule val_ring_poly_eval, rule assms)
       using assms apply blast using assms apply blast
       apply(rule val_ring_poly_eval, rule assms)
       using assms apply blast by(rule assms)
     have 5: "f \<bullet> x \<in> \<O>\<^sub>p"
       apply(rule val_ring_poly_eval, rule assms)
       using assms apply blast using assms by blast
     have 6: "g \<bullet> x \<in> \<O>\<^sub>p"
       apply(rule val_ring_poly_eval, rule assms)
       using assms apply blast by(rule assms)
     show "Qp_res (f \<bullet> x) n = Qp_res (g \<bullet> x) n"
       using 5 6 2 Qp_res_closed[of "f \<bullet> x" n] Qp_res_closed[of "g \<bullet> x" n]
       unfolding 4
     proof -
       assume "Qp_res (f \<bullet> x) n \<ominus>\<^bsub>Zp_res_ring n\<^esub> Qp_res (g \<bullet> x) n = 0"
       then show ?thesis
         by (metis (no_types) Qp_res_def 5 6 res_diff_zero_fact(1) residue_of_diff to_Zp_closed val_ring_memE)
     qed
 qed
 
 lemma Qp_poly_res_eval_1:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "x \<in> \<O>\<^sub>p"
   assumes "y \<in> \<O>\<^sub>p"
   assumes "\<And>i. f i \<in> \<O>\<^sub>p"
   assumes "Qp_res x n = Qp_res y n"
   shows "Qp_res (f \<bullet> x) n = Qp_res (f \<bullet> y) n"
 proof-
   have "(\<forall>i. f i \<in> \<O>\<^sub>p) \<longrightarrow> Qp_res (f \<bullet> x) n = Qp_res (f \<bullet> y) n"
     apply(rule UPQ.poly_induct[of f], rule assms)
   proof fix f assume A: "f \<in> carrier (UP Q\<^sub>p)" "deg Q\<^sub>p f = 0" "\<forall>i. f i \<in> \<O>\<^sub>p"
     show "Qp_res (f \<bullet> x) n = Qp_res (f \<bullet> y) n"
     proof-
       obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> f = to_polynomial Q\<^sub>p a"
         using assms
         by (metis A(1) A(2) UPQ.lcf_closed UPQ.to_poly_inverse)
       have a_eq: "f = to_polynomial Q\<^sub>p a"
         using a_def  by blast
       have 0: "f \<bullet> x = a"
         using a_def assms unfolding a_eq
         by (meson UPQ.to_fun_to_poly val_ring_memE)
       have 1: "f \<bullet> y = a"
         using a_def assms unfolding a_eq
         by (meson UPQ.to_fun_to_poly val_ring_memE)
       show " Qp_res (f \<bullet> x) n = Qp_res (f \<bullet> y) n"
         unfolding 0 1 by blast
     qed
   next
     fix f
     assume A: " (\<And>q. q \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> deg Q\<^sub>p q < deg Q\<^sub>p f \<Longrightarrow> (\<forall>i. q i \<in> \<O>\<^sub>p) \<longrightarrow> Qp_res (q \<bullet> x) n = Qp_res (q \<bullet> y) n)"
         "f \<in> carrier (UP Q\<^sub>p)" " 0 < deg Q\<^sub>p f"
     show "(\<forall>i. f i \<in> \<O>\<^sub>p) \<longrightarrow> Qp_res (f \<bullet> x) n = Qp_res (f \<bullet> y) n"
     proof assume A1: "\<forall>i. f i \<in> \<O>\<^sub>p"
       obtain q where q_def: "q = UPQ.trunc f"
         by blast
       have q_closed: "q \<in> carrier (UP Q\<^sub>p)"
         using q_def A UPQ.trunc_closed by presburger
       have q_deg: "deg Q\<^sub>p q < deg Q\<^sub>p f"
         using q_def A UPQ.trunc_degree by blast
       have q_cfs: "\<forall>i. q i \<in> \<O>\<^sub>p"
       proof fix i show "q i \<in> \<O>\<^sub>p"
         apply(cases "i < deg Q\<^sub>p f")
         unfolding q_def using A A1 UPQ.trunc_cfs
          apply presburger
         using q_deg q_closed
         proof -
         assume "\<not> i < deg Q\<^sub>p f"
         then have "deg Q\<^sub>p f \<le> i"
           by (meson diff_is_0_eq neq0_conv zero_less_diff)
         then show "Cring_Poly.truncate Q\<^sub>p f i \<in> \<O>\<^sub>p"
           by (metis (no_types) UPQ.deg_eqI diff_is_0_eq' le_trans nat_le_linear neq0_conv q_closed q_def q_deg zero_in_val_ring zero_less_diff)
         qed
       qed
       hence 0: "Qp_res (q \<bullet> x) n = Qp_res (q \<bullet> y) n"
         using A q_closed q_deg by blast
       have 1: "Qp_res (UPQ.ltrm f \<bullet> x) n = Qp_res (UPQ.ltrm f \<bullet> y) n"
       proof-
         have 10: "UPQ.ltrm f \<bullet> x =  (f (deg Q\<^sub>p f)) \<otimes> x[^](deg Q\<^sub>p f)"
           using A assms  A1 UPQ.to_fun_monom val_ring_memE by presburger
         have 11: "UPQ.ltrm f \<bullet> y =  (f (deg Q\<^sub>p f)) \<otimes> y[^](deg Q\<^sub>p f)"
           using A assms  A1 UPQ.to_fun_monom val_ring_memE by presburger
         obtain d where d_def: "d = deg Q\<^sub>p f"
           by blast
         have 12: "Qp_res (x[^]d) n = Qp_res (y[^]d) n"
           apply(induction d)
           using Qp.nat_pow_0 apply presburger
           using Qp_res_mult assms Qp.nat_pow_Suc val_ring_nat_pow_closed by presburger
         hence 13: "Qp_res (x [^] deg Q\<^sub>p f) n = Qp_res (y [^] deg Q\<^sub>p f) n"
           unfolding d_def by blast
         have 14: "x [^] deg Q\<^sub>p f \<in> \<O>\<^sub>p"
           using assms val_ring_nat_pow_closed by blast
         have 15: "y [^] deg Q\<^sub>p f \<in> \<O>\<^sub>p"
           using assms val_ring_nat_pow_closed by blast
         have 16: "Qp_res (f (deg Q\<^sub>p f) \<otimes> x [^] deg Q\<^sub>p f) n = Qp_res (f (deg Q\<^sub>p f)) n \<otimes>\<^bsub>residue_ring (p ^ n)\<^esub> Qp_res (x [^] deg Q\<^sub>p f) n"
           apply(rule Qp_res_mult[of "f (deg Q\<^sub>p f)" " x[^](deg Q\<^sub>p f)" n])
           using A1 apply blast by(rule 14)
         have 17: "Qp_res (f (deg Q\<^sub>p f) \<otimes> y [^] deg Q\<^sub>p f) n = Qp_res (f (deg Q\<^sub>p f)) n \<otimes>\<^bsub>residue_ring (p ^ n)\<^esub> Qp_res (y [^] deg Q\<^sub>p f) n"
           apply(rule Qp_res_mult[of "f (deg Q\<^sub>p f)" " y[^](deg Q\<^sub>p f)" n])
           using A1 apply blast by(rule 15)
         show ?thesis
           unfolding 10 11 16 17 13 by blast
       qed
       have f_decomp: "f = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> UPQ.ltrm f"
         using A unfolding q_def
         using UPQ.trunc_simps(1) by blast
       have 2: "f \<bullet> x = q \<bullet> x \<oplus> (UPQ.ltrm f \<bullet> x)"
         using A f_decomp q_closed q_cfs
         by (metis val_ring_memE UPQ.ltrm_closed UPQ.to_fun_plus assms(2))
       have 3: "f \<bullet> y = q \<bullet> y \<oplus> (UPQ.ltrm f \<bullet> y)"
         using A f_decomp q_closed q_cfs
         by (metis val_ring_memE UPQ.ltrm_closed UPQ.to_fun_plus assms(3))
       show 4: " Qp_res (f \<bullet> x) n = Qp_res (f \<bullet> y) n "
         unfolding 2 3 using assms q_cfs Qp_res_add 0 1
         by (metis (no_types, opaque_lifting) "2" "3" A(2) A1 Qp_res_def poly_eval_cong)
     qed
   qed
   thus ?thesis using assms by blast
 qed
 
 lemma Qp_poly_res_eval_2:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "g \<in> carrier (UP Q\<^sub>p)"
   assumes "x \<in> \<O>\<^sub>p"
   assumes "y \<in> \<O>\<^sub>p"
   assumes "\<And>i. f i \<in> \<O>\<^sub>p"
   assumes "\<And>i. g i \<in> \<O>\<^sub>p"
   assumes "\<And>i. Qp_res (f i) n = Qp_res (g i) n"
   assumes "Qp_res x n = Qp_res y n"
   shows "Qp_res (f \<bullet> x) n = Qp_res (g \<bullet> y) n"
 proof-
   have 0: "Qp_res (f \<bullet> x) n = Qp_res (g \<bullet> x) n"
     using Qp_poly_res_eval_0 assms by blast
   have 1: "Qp_res (g \<bullet> x) n = Qp_res (g \<bullet> y) n"
     using Qp_poly_res_eval_1 assms by blast
   show ?thesis unfolding 0 1 by blast
 qed
 
 definition poly_res_class where
 "poly_res_class n d f = {q \<in> carrier (UP Q\<^sub>p). deg Q\<^sub>p q \<le> d \<and> (\<forall>i. q i \<in> \<O>\<^sub>p \<and> Qp_res (f i) n = Qp_res (q i) n) }"
 
 lemma poly_res_class_closed:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "g \<in> carrier (UP Q\<^sub>p)"
   assumes "deg Q\<^sub>p f \<le> d"
   assumes "deg Q\<^sub>p g \<le> d"
   assumes "g \<in> poly_res_class n d f"
   shows "poly_res_class n d f = poly_res_class n d g"
   unfolding poly_res_class_def
   apply(rule equalityI)
 apply(rule subsetI)
   unfolding mem_Collect_eq apply(rule conjI, blast, rule conjI, blast)
   using assms unfolding poly_res_class_def mem_Collect_eq
    apply presburger
 apply(rule subsetI) unfolding mem_Collect_eq
   apply(rule conjI, blast, rule conjI, blast)
   using assms unfolding poly_res_class_def mem_Collect_eq
   by presburger
 
 lemma poly_res_class_memE:
   assumes "f \<in> poly_res_class n d g"
   shows "f \<in> carrier (UP Q\<^sub>p)"
         "deg Q\<^sub>p f \<le> d"
         "f i \<in> \<O>\<^sub>p"
         "Qp_res (g i) n = Qp_res (f i) n"
   using assms unfolding poly_res_class_def mem_Collect_eq apply blast
   using assms unfolding poly_res_class_def mem_Collect_eq apply blast
   using assms unfolding poly_res_class_def mem_Collect_eq apply blast
   using assms unfolding poly_res_class_def mem_Collect_eq by blast
 
 definition val_ring_polys where
 "val_ring_polys = {f \<in> carrier (UP Q\<^sub>p). (\<forall>i. f i \<in> \<O>\<^sub>p)} "
 
 lemma val_ring_polys_closed:
 "val_ring_polys \<subseteq> carrier (UP Q\<^sub>p)"
   unfolding val_ring_polys_def by blast
 
 lemma val_ring_polys_memI:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "\<And>i. f i \<in> \<O>\<^sub>p"
   shows "f \<in> val_ring_polys"
   using assms   unfolding val_ring_polys_def by blast
 
 lemma val_ring_polys_memE:
   assumes "f \<in> val_ring_polys"
   shows "f \<in> carrier (UP Q\<^sub>p)"
         "f i \<in> \<O>\<^sub>p"
   using assms unfolding val_ring_polys_def apply blast
   using assms unfolding val_ring_polys_def by blast
 
 definition val_ring_polys_grad where
 "val_ring_polys_grad d = {f \<in> val_ring_polys. deg Q\<^sub>p f \<le> d}"
 
 lemma val_ring_polys_grad_closed:
 "val_ring_polys_grad d \<subseteq> val_ring_polys"
   unfolding val_ring_polys_grad_def by blast
 
 lemma val_ring_polys_grad_closed':
 "val_ring_polys_grad d \<subseteq> carrier (UP Q\<^sub>p)"
   unfolding val_ring_polys_grad_def val_ring_polys_def by blast
 
 lemma val_ring_polys_grad_memI:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "\<And>i. f i \<in> \<O>\<^sub>p"
   assumes "deg Q\<^sub>p f \<le> d"
   shows "f \<in> val_ring_polys_grad d"
   using assms unfolding val_ring_polys_grad_def val_ring_polys_def by blast
 
 lemma val_ring_polys_grad_memE:
   assumes "f \<in> val_ring_polys_grad d"
   shows "f \<in> carrier (UP Q\<^sub>p)"
         "deg Q\<^sub>p f \<le> d"
         "f i \<in> \<O>\<^sub>p"
   using assms unfolding val_ring_polys_grad_def val_ring_polys_def apply blast
   using assms unfolding val_ring_polys_grad_def val_ring_polys_def apply blast
   using assms unfolding val_ring_polys_grad_def val_ring_polys_def by blast
 
 lemma poly_res_classes_in_val_ring_polys_grad:
   assumes "f \<in> val_ring_polys_grad d"
   shows "poly_res_class n d f \<subseteq> val_ring_polys_grad d"
   apply(rule subsetI, rule val_ring_polys_grad_memI)
     apply(rule poly_res_class_memE[of _ n d f], blast)
    apply(rule poly_res_class_memE[of _ n d f], blast)
   by(rule poly_res_class_memE[of _ n d f], blast)
 
 lemma poly_res_class_disjoint:
   assumes "f \<in> val_ring_polys_grad d"
   assumes "f \<notin> poly_res_class n d g"
   shows "poly_res_class n d f \<inter> poly_res_class n d g = {}"
   apply(rule equalityI)
   apply(rule subsetI)
   using assms
   unfolding poly_res_class_def mem_Collect_eq Int_iff
   apply (metis val_ring_polys_grad_memE(1) val_ring_polys_grad_memE(2) val_ring_polys_grad_memE(3))
   by blast
 
 lemma poly_res_class_refl:
   assumes "f \<in> val_ring_polys_grad d"
   shows "f \<in> poly_res_class n d f"
   unfolding poly_res_class_def mem_Collect_eq
   using assms val_ring_polys_grad_memE(1) val_ring_polys_grad_memE(2) val_ring_polys_grad_memE(3) by blast
 
 lemma poly_res_class_memI:
   assumes "f \<in> carrier (UP Q\<^sub>p)"
   assumes "deg Q\<^sub>p f \<le> d"
   assumes "\<And>i. f i \<in> \<O>\<^sub>p"
   assumes "\<And>i. Qp_res (f i) n = Qp_res (g i) n"
   shows "f \<in> poly_res_class n d g"
   unfolding poly_res_class_def mem_Collect_eq using assms
   by metis
 
 definition poly_res_classes where
 "poly_res_classes n d = poly_res_class n d ` val_ring_polys_grad d"
 
 lemma poly_res_classes_disjoint:
   assumes "A \<in> poly_res_classes n d"
   assumes "B \<in> poly_res_classes n d"
   assumes "g \<in> A - B"
   shows "A \<inter> B = {}"
 proof-
   obtain a where a_def: "a \<in> val_ring_polys_grad d \<and> A = poly_res_class n d a"
     using assms unfolding poly_res_classes_def by blast
   obtain b where b_def: "b \<in> val_ring_polys_grad d \<and> B = poly_res_class n d b"
     using assms unfolding poly_res_classes_def by blast
   have 0: "\<And>f. f \<in> A \<inter> B \<Longrightarrow> False"
   proof-
     fix f assume A: "f \<in> A \<inter> B"
     have 1: "\<exists>i. Qp_res (g i) n \<noteq> Qp_res (f i) n"
     proof(rule ccontr)
       assume B: "\<nexists>i. Qp_res (g i) n \<noteq> Qp_res (f i) n"
       then have 2: "\<And>i.  Qp_res (g i) n = Qp_res (f i) n"
         by blast
       have 3: "g \<in> poly_res_class n d a"
         using a_def assms by blast
       have 4: "\<And>i. Qp_res (b i) n = Qp_res (f i) n"
         apply(rule poly_res_class_memE[of _ n d])
         using assms A b_def by blast
       have 5: "\<And>i. Qp_res (a i) n = Qp_res (g i) n"
         apply(rule poly_res_class_memE[of _ n d])
         using assms A a_def by blast
       have 6: "g \<in> poly_res_class n d b"
         apply(rule poly_res_class_memI, rule poly_res_class_memE[of _ n d a], rule 3,
             rule poly_res_class_memE[of _ n d a], rule 3,  rule poly_res_class_memE[of _ n d a], rule 3)
         unfolding 2 4 by blast
       show False using 6 b_def assms by blast
     qed
     then obtain i where i_def: "Qp_res (g i) n \<noteq> Qp_res (f i) n"
       by blast
     have 2: "\<And>i. Qp_res (a i) n = Qp_res (f i) n"
       apply(rule poly_res_class_memE[of _ n d])
       using A a_def by blast
     have 3: "\<And>i. Qp_res (b i) n = Qp_res (f i) n"
       apply(rule poly_res_class_memE[of _ n d])
       using A b_def by blast
     have 4: "\<And>i. Qp_res (a i) n = Qp_res (g i) n"
       apply(rule poly_res_class_memE[of _ n d])
       using assms a_def by blast
     show False using i_def 2 unfolding 4 2 by blast
   qed
   show ?thesis using 0 by blast
 qed
 
 definition int_fun_to_poly where
 "int_fun_to_poly (f::nat \<Rightarrow> int) i = [(f i)]\<cdot>\<one>"
 
 lemma int_fun_to_poly_closed:
   assumes "\<And>i. i > d \<Longrightarrow> f i = 0"
   shows "int_fun_to_poly f \<in> carrier (UP Q\<^sub>p)"
   apply(rule UPQ.UP_car_memI[of d])
   using assms unfolding int_fun_to_poly_def
   using Qp.int_inc_zero apply presburger
   by(rule Qp.int_inc_closed)
 
 lemma int_fun_to_poly_deg:
   assumes "\<And>i. i > d \<Longrightarrow> f i = 0"
   shows "deg Q\<^sub>p (int_fun_to_poly f) \<le> d"
   apply(rule UPQ.deg_leqI, rule int_fun_to_poly_closed, rule assms, blast)
   unfolding int_fun_to_poly_def using assms
   using Qp.int_inc_zero by presburger
 
 lemma Qp_res_mod_triv:
   assumes "a \<in> \<O>\<^sub>p"
   shows "Qp_res a n mod p ^ n = Qp_res a n"
   using assms Qp_res_closed[of a n]
   by (meson mod_pos_pos_trivial p_residue_ring_car_memE(1) p_residue_ring_car_memE(2))
 
 lemma int_fun_to_poly_is_class_wit:
   assumes "f \<in> poly_res_class n d g"
   shows "(int_fun_to_poly (\<lambda>i::nat. Qp_res (f i) n)) \<in> poly_res_class n d g"
 proof(rule poly_res_class_memI[of   ], rule int_fun_to_poly_closed[of d])
   show 0: "\<And>i. d < i \<Longrightarrow> Qp_res (f i) n = 0"
   proof- fix i assume A: "d < i"
     hence 0: "deg Q\<^sub>p f < i"
       using A  assms poly_res_class_memE(2)[of f n d g]
       by linarith
     have 1: "f i = \<zero>"
       using 0 assms poly_res_class_memE[of f n d g]
       using UPQ.UP_car_memE(2) by blast
     show "Qp_res (f i) n = 0"
       unfolding 1 Qp_res_zero by blast
   qed
   show "deg Q\<^sub>p (int_fun_to_poly (\<lambda>i. Qp_res (f i) n)) \<le> d"
     by(rule int_fun_to_poly_deg, rule 0, blast)
   show "\<And>i. int_fun_to_poly (\<lambda>i. Qp_res (f i) n) i \<in> \<O>\<^sub>p"
     unfolding int_fun_to_poly_def
     using Qp.int_mult_closed Qp_val_ringI val_of_int_inc by blast
   show "\<And>i. Qp_res (int_fun_to_poly (\<lambda>i. Qp_res (f i) n) i) n = Qp_res (g i) n"
     unfolding int_fun_to_poly_def Qp_res_int_inc
     using Qp_res_mod_triv assms poly_res_class_memE(4) Qp_res_closed UPQ.cfs_closed
     by (metis poly_res_class_memE(3))
 qed
 
 lemma finite_support_funs_finite:
 "finite (({..d} \<rightarrow> carrier (Zp_res_ring n)) \<inter> {(f::nat \<Rightarrow> int). \<forall>i > d. f i = 0})"
 proof-
   have 0: "finite (\<Pi>\<^sub>E i \<in> {..d}.carrier (Zp_res_ring n))"
     apply(rule finite_PiE, blast)
     using residue_ring_card[of n] by blast
   obtain g where g_def: "g = (\<lambda>f. (\<lambda>i::nat. if i \<in> {..d} then f i else (0::int)))"
     by blast
   have 1: "g `  (\<Pi>\<^sub>E i \<in> {..d}.carrier (Zp_res_ring n)) = (({..d} \<rightarrow> carrier (Zp_res_ring n)) \<inter> {(f::nat \<Rightarrow> int). \<forall>i > d. f i = 0})"
   proof(rule equalityI, rule subsetI)
     fix x assume A: "x \<in> g ` ({..d} \<rightarrow>\<^sub>E carrier (residue_ring (p ^ n)))"
     obtain f where f_def: "f \<in> (\<Pi>\<^sub>E i \<in> {..d}.carrier (Zp_res_ring n)) \<and> x = g f"
       using A by blast
     have x_eq: "x = g f"
       using f_def by blast
     show "x \<in> ({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0}"
     proof(rule, rule)
       fix i assume A: "i \<in> {..d}"
       show "x i \<in> carrier (Zp_res_ring n)"
       proof(cases "i \<in> {..d}")
         case True
         then have T0: "f i \<in> carrier (Zp_res_ring n)"
           using f_def by blast
         have "x i = f i"
           unfolding x_eq g_def
           using True by metis
         thus ?thesis using T0 by metis
       next
         case False
         then have F0: "x i = 0"
           unfolding x_eq g_def by metis
         show ?thesis
           unfolding F0
           by (metis residue_mult_closed residue_times_zero_r)
       qed
     next
       show "x \<in> {f. \<forall>i>d. f i = 0}"
       proof(rule, rule, rule)
         fix i assume A: "d < i"
         then have 0: "i \<notin> {..d}"
           by simp
         thus "x i = 0"
           unfolding x_eq g_def
           by metis
       qed
     qed
   next
     show "({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0}
     \<subseteq> g ` ({..d} \<rightarrow>\<^sub>E carrier (residue_ring (p ^ n)))"
     proof(rule subsetI)
     fix x
     assume A: " x \<in> ({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0}"
     show " x \<in> g ` ({..d} \<rightarrow>\<^sub>E carrier (residue_ring (p ^ n)))"
     proof-
       obtain h where h_def: "h = restrict x {..d}"
         by blast
       have 0: "\<And>i. i \<in> {..d} \<Longrightarrow> h i = x i"
         unfolding h_def restrict_apply by metis
       have 1: "\<And>i. i \<notin> {..d} \<Longrightarrow> h i = undefined"
         unfolding h_def restrict_apply by metis
       have 2: "\<And>i. i \<in> {..d} \<Longrightarrow> h i \<in> carrier (Zp_res_ring n)"
         using A 0 unfolding 0 by blast
       have 3: "h \<in> {..d} \<rightarrow>\<^sub>E carrier (residue_ring (p ^ n))"
         by(rule, rule 2, blast, rule 1, blast)
       have 4: "\<And>i. i \<notin> {..d} \<Longrightarrow> x i = 0"
         using A unfolding Int_iff mem_Collect_eq
         by (metis atMost_iff eq_imp_le le_simps(1) linorder_neqE_nat)
       have 5: "x = g h"
       proof fix i
         show "x i = g h i"
           unfolding g_def
           apply(cases "i \<in> {..d}")
           using 0 apply metis unfolding 4
           by metis
       qed
       show ?thesis unfolding 5 using 3 by blast
      qed
    qed
   qed
   have 2: "finite (g `  (\<Pi>\<^sub>E i \<in> {..d}.carrier (Zp_res_ring n)))"
     using 0 by blast
   show ?thesis using 2 unfolding 1 by blast
 qed
 
 lemma poly_res_classes_finite:
 "finite (poly_res_classes n d)"
 proof-
   have 0: "poly_res_class n d ` int_fun_to_poly ` (({..d} \<rightarrow> carrier (Zp_res_ring n)) \<inter> {(f::nat \<Rightarrow> int). \<forall>i > d. f i = 0}) = poly_res_classes n d"
   proof(rule equalityI, rule subsetI)
     fix x assume A: " x \<in> poly_res_class n d ` int_fun_to_poly ` (({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0})"
     then obtain f where f_def: "f \<in> ({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0} \<and>
                                 x = poly_res_class n d (int_fun_to_poly f)"
       by blast
     have x_eq: "x = poly_res_class n d (int_fun_to_poly f)"
       using f_def by blast
     show "x \<in> poly_res_classes n d"
     proof-
       have 0: "int_fun_to_poly f \<in> val_ring_polys_grad d"
         apply(rule val_ring_polys_grad_memI, rule int_fun_to_poly_closed[of d])
         using f_def apply blast
         using int_fun_to_poly_def
          apply (metis Qp.int_inc_closed padic_fields.int_fun_to_poly_def padic_fields.val_of_int_inc padic_fields_axioms val_ring_memI)
         apply(rule int_fun_to_poly_deg)
         using f_def by blast
       show ?thesis unfolding poly_res_classes_def x_eq
         using 0 by blast
     qed
   next
     show "poly_res_classes n d
     \<subseteq> poly_res_class n d `
        int_fun_to_poly `
        (({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter>
         {f. \<forall>i>d. f i = 0})"
     proof(rule subsetI)
     fix x assume A: " x \<in> poly_res_classes n d"
     show "x \<in> poly_res_class n d ` int_fun_to_poly ` (({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0})"
     proof-
       obtain f where f_def: "f \<in> val_ring_polys_grad d \<and> x = poly_res_class n d f"
         using A unfolding poly_res_classes_def by blast
       have x_eq: "x = poly_res_class n d f"
         using f_def by blast
       obtain h where h_def: "h = (\<lambda>i::nat. Qp_res (f i) n)"
         by blast
       have 0: "\<And>i. i > d \<Longrightarrow> f i = \<zero>"
       proof- fix i assume A: "i > d"
          have "i > deg Q\<^sub>p f"
            apply(rule le_less_trans[of _ d])
            using f_def unfolding val_ring_polys_grad_def val_ring_polys_def mem_Collect_eq
             apply blast
            by(rule A)
         then show "f i = \<zero>"
           using f_def unfolding val_ring_polys_grad_def val_ring_polys_def mem_Collect_eq
           using UPQ.deg_leE by blast
       qed
       have 1: "\<And>i. i > d \<Longrightarrow> h i = 0"
         unfolding h_def 0 Qp_res_zero by blast
       have 2: "x = poly_res_class n d (int_fun_to_poly h)"
         unfolding x_eq
         apply(rule poly_res_class_closed)
         using f_def unfolding val_ring_polys_grad_def val_ring_polys_def mem_Collect_eq apply blast
            apply(rule int_fun_to_poly_closed[of d], rule 1, blast)
         using f_def unfolding val_ring_polys_grad_def val_ring_polys_def mem_Collect_eq apply blast
          apply(rule int_fun_to_poly_deg, rule 1, blast)
         unfolding h_def
         apply(rule int_fun_to_poly_is_class_wit, rule poly_res_class_refl)
         using f_def by blast
       have 3: "h \<in> ({..d} \<rightarrow> carrier (residue_ring (p ^ n))) \<inter> {f. \<forall>i>d. f i = 0}"
         apply(rule , rule )
         unfolding h_def apply(rule Qp_res_closed, rule val_ring_polys_grad_memE[of _ d])
         using f_def apply blast
         unfolding mem_Collect_eq apply(rule, rule)
         unfolding 0 Qp_res_zero by blast
       show ?thesis
         unfolding 2 using 3 by blast
       qed
     qed
   qed
   have 1: "finite (poly_res_class n d ` int_fun_to_poly ` (({..d} \<rightarrow> carrier (Zp_res_ring n)) \<inter> {(f::nat \<Rightarrow> int). \<forall>i > d. f i = 0}))"
     using finite_support_funs_finite by blast
   show ?thesis using 1 unfolding 0 by blast
 qed
 
 lemma Qp_res_eq_zeroI:
   assumes "a \<in> \<O>\<^sub>p"
   assumes "val a \<ge> n"
   shows "Qp_res a n = 0"
 proof-
   have 0: "val_Zp (to_Zp a) \<ge> n"
     using assms to_Zp_val by presburger
   have 1: "to_Zp a n = 0"
     apply(rule zero_below_val_Zp, rule to_Zp_closed)
     using val_ring_closed assms apply blast
     by(rule 0)
   thus ?thesis unfolding Qp_res_def by blast
 qed
 
 lemma Qp_res_eqI:
   assumes "a \<in> \<O>\<^sub>p"
   assumes "b \<in> \<O>\<^sub>p"
   assumes "Qp_res (a \<ominus> b) n = 0"
   shows "Qp_res a n = Qp_res b n"
   using assms by (metis Qp_res_def val_ring_memE res_diff_zero_fact(1) to_Zp_closed to_Zp_minus)
 
 lemma Qp_res_eqI':
   assumes "a \<in> \<O>\<^sub>p"
   assumes "b \<in> \<O>\<^sub>p"
   assumes "val (a \<ominus> b) \<ge> n"
   shows "Qp_res a n = Qp_res b n"
   apply(rule Qp_res_eqI, rule assms, rule assms, rule Qp_res_eq_zeroI)
   using assms Q\<^sub>p_def Zp_def \<iota>_def padic_fields.val_ring_minus_closed padic_fields_axioms apply blast
   by(rule assms)
 
 lemma Qp_res_eqE:
   assumes "a \<in> \<O>\<^sub>p"
   assumes "b \<in> \<O>\<^sub>p"
   assumes "Qp_res a n = Qp_res b n"
   shows "val (a \<ominus> b) \<ge> n"
 proof-
   have 0: "val (a \<ominus> b) = val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b)"
     using assms
     by (metis to_Zp_minus to_Zp_val val_ring_minus_closed)
   have 1: "(to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b) n = 0"
     using assms unfolding Qp_res_def
     by (meson val_ring_memE res_diff_zero_fact'' to_Zp_closed)
   have 2: "val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b) \<ge> n"
     apply(cases "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b = \<zero>\<^bsub>Z\<^sub>p\<^esub>")
   proof -
     assume a1: "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
     have "\<forall>n. eint (int n) \<le> val_Zp \<zero>\<^bsub>Z\<^sub>p\<^esub>"
       by (metis (no_types) Zp.r_right_minus_eq Zp.zero_closed val_Zp_dist_def val_Zp_dist_res_eq2)
        then show ?thesis
       using a1 by presburger
   next
     assume a1: "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
     have 00: "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b \<in> carrier Z\<^sub>p"
       using assms
       by (meson val_ring_memE Zp.cring_simprules(4) to_Zp_closed)
     show ?thesis
       using 1 a1 ord_Zp_geq[of "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b" n] 00
             val_ord_Zp[of "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b"] eint_ord_code by metis
   qed
   thus ?thesis unfolding 0 by blast
 qed
 
 lemma notin_closed:
 "(\<not> ((c::eint) \<le> x \<and> x \<le> d)) = (x < c \<or> d < x)"
   by auto
 
 lemma Qp_res_neqI:
   assumes "a \<in> \<O>\<^sub>p"
   assumes "b \<in> \<O>\<^sub>p"
   assumes "val (a \<ominus> b) < n"
   shows "Qp_res a n \<noteq> Qp_res b n"
   apply(rule ccontr)
   using Qp_res_eqE[of a b n] assms
   using notin_closed by blast
 
 lemma Qp_res_equal:
   assumes "a \<in> \<O>\<^sub>p"
   assumes "l = Qp_res a n"
   shows "Qp_res a n = Qp_res ([l]\<cdot>\<one>) n "
   unfolding Qp_res_int_inc assms using assms Qp_res_mod_triv by presburger
 
 definition Qp_res_class where
 "Qp_res_class n b = {a \<in> \<O>\<^sub>p. Qp_res a n = Qp_res b n}"
 
 definition Qp_res_classes where
 "Qp_res_classes n = Qp_res_class n ` \<O>\<^sub>p"
 
 lemma val_ring_int_inc_closed:
 "[(k::int)]\<cdot>\<one> \<in> \<O>\<^sub>p"
 proof-
   have 0: "[(k::int)]\<cdot>\<one> = \<iota> ([(k::int)]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
     using inc_of_int by blast
   thus ?thesis
     by blast
 qed
 
 lemma val_ring_nat_inc_closed:
 "[(k::nat)]\<cdot>\<one> \<in> \<O>\<^sub>p"
 proof-
  have 0: "[k]\<cdot>\<one> = \<iota> ([k]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
    using inc_of_nat by blast
   thus ?thesis
     by blast
 qed
 
 lemma Qp_res_classes_wits:
 "Qp_res_classes n  =  (\<lambda>l::int. Qp_res_class n ([l]\<cdot>\<one>)) ` (carrier (Zp_res_ring n))"
 proof-
  obtain F where F_def: "F = (\<lambda>l::int. Qp_res_class n ([l]\<cdot>\<one>))"
     by blast
   have 0: "Qp_res_classes n  = F ` (carrier (Zp_res_ring n))"
   proof(rule equalityI, rule subsetI)
     fix x assume A: "x \<in> Qp_res_classes n"
     then obtain a where a_def: "a \<in> \<O>\<^sub>p \<and> x = Qp_res_class n a"
       unfolding Qp_res_classes_def by blast
     have 1: "Qp_res a n = Qp_res ([(Qp_res a n)]\<cdot>\<one>) n "
       apply(rule Qp_res_equal)
       using a_def apply blast by blast
     have 2: "Qp_res_class n a = Qp_res_class n ([(Qp_res a n)]\<cdot>\<one>)"
       unfolding Qp_res_class_def using 1 by metis
     have 3: "x =  Qp_res_class n ([(Qp_res a n)]\<cdot>\<one>)"
       using a_def unfolding 2 by blast
     have 4: "a \<in> \<O>\<^sub>p"
       using a_def by blast
     show " x \<in> F ` carrier (Zp_res_ring n)"
       unfolding F_def  3
       using Qp_res_closed[of a n] 4 by blast
   next
     show "F ` carrier (residue_ring (p ^ n)) \<subseteq> Qp_res_classes n"
     proof(rule subsetI)
     fix x assume A: "x \<in> F ` (carrier (Zp_res_ring n))"
     then obtain l where l_def: "l \<in> carrier (Zp_res_ring n) \<and> x = F l"
       using A by blast
     have 0: "x = F l"
       using l_def by blast
     show "x \<in> Qp_res_classes n"
       unfolding 0 F_def Qp_res_classes_def using val_ring_int_inc_closed by blast
     qed
   qed
   then show ?thesis unfolding F_def by blast
 qed
 
 lemma Qp_res_classes_finite:
 "finite (Qp_res_classes n)"
 by (metis Qp_res_classes_wits finite_atLeastLessThan_int finite_imageI p_res_ring_car)
 
 definition Qp_cong_set where
 "Qp_cong_set \<alpha> a =  {x \<in> \<O>\<^sub>p. to_Zp x \<alpha> = a \<alpha>}"
 
 lemma Qp_cong_set_as_ball:
   assumes "a \<in> carrier Z\<^sub>p"
   assumes "a \<alpha> = 0"
   shows "Qp_cong_set \<alpha> a = B\<^bsub>\<alpha>\<^esub>[\<zero>]"
 proof-
   have 0: "\<iota> a \<in> carrier Q\<^sub>p"
     using assms inc_closed[of a] by blast
   show ?thesis
   proof
     show "Qp_cong_set \<alpha> a \<subseteq> B\<^bsub>\<alpha>\<^esub>[\<zero>]"
     proof fix x assume A: "x \<in> Qp_cong_set \<alpha> a"
       show "x \<in> B\<^bsub>\<alpha> \<^esub>[\<zero>]"
       proof(rule c_ballI)
         show t0: "x \<in> carrier Q\<^sub>p"
           using A unfolding Qp_cong_set_def
           using val_ring_memE by blast
         show "eint (int \<alpha>) \<le> val (x \<ominus> \<zero>)"
         proof-
           have t1: "to_Zp x \<alpha> = 0"
             using A unfolding Qp_cong_set_def
             by (metis (mono_tags, lifting) assms(2) mem_Collect_eq)
           have t2: "val_Zp (to_Zp x) \<ge> \<alpha>"
             apply(cases "to_Zp x = \<zero>\<^bsub>Z\<^sub>p\<^esub>")
              apply (metis Zp.r_right_minus_eq Zp.zero_closed val_Zp_dist_def val_Zp_dist_res_eq2)
               using ord_Zp_geq[of "to_Zp x" \<alpha>] A unfolding Qp_cong_set_def
               by (metis (no_types, lifting) val_ring_memE eint_ord_simps(1) t1 to_Zp_closed to_Zp_def val_ord_Zp)
           then show ?thesis using A unfolding Qp_cong_set_def mem_Collect_eq
             using val_ring_memE
              by (metis Qp_res_eqE Qp_res_eq_zeroI Qp_res_zero to_Zp_val zero_in_val_ring)
          qed
       qed
     qed
     show "B\<^bsub>int \<alpha>\<^esub>[\<zero>] \<subseteq> Qp_cong_set \<alpha> a"
     proof fix x assume A: "x \<in> B\<^bsub>int \<alpha>\<^esub>[\<zero>]"
       then have 0: "val x \<ge> \<alpha>"
         using assms c_ballE[of x \<alpha> \<zero>]
         by (smt Qp.minus_closed Qp.r_right_minus_eq Qp_diff_diff)
       have 1: "to_Zp x \<in> carrier Z\<^sub>p"
         using A 0 assms c_ballE(1) to_Zp_closed by blast
       have 2: "x \<in> \<O>\<^sub>p"
         using 0 A val_ringI c_ballE
         by (smt Q\<^sub>p_def Zp_def \<iota>_def eint_ord_simps(1) of_nat_0 of_nat_le_0_iff val_ring_ord_criterion padic_fields_axioms val_ord' zero_in_val_ring)
       then have "val_Zp (to_Zp  x) \<ge> \<alpha>"
         using 0 1 A assms c_ballE[of x \<alpha> \<zero>] to_Zp_val by presburger
       then have "to_Zp x \<alpha> = 0"
         using 1 zero_below_val_Zp by blast
       then show " x \<in> Qp_cong_set \<alpha> a"
         unfolding Qp_cong_set_def using assms(2) 2
         by (metis (mono_tags, lifting) mem_Collect_eq)
     qed
   qed
 qed
 
 lemma Qp_cong_set_as_ball':
   assumes "a \<in> carrier Z\<^sub>p"
   assumes "val_Zp a < eint (int \<alpha>)"
   shows "Qp_cong_set \<alpha> a = B\<^bsub>\<alpha>\<^esub>[(\<iota> a)]"
 proof
   show "Qp_cong_set \<alpha> a \<subseteq> B\<^bsub>\<alpha>\<^esub>[\<iota> a]"
   proof fix x
     assume A:  "x \<in> Qp_cong_set \<alpha> a"
     then have 0: "to_Zp x \<alpha> = a \<alpha>"
       unfolding Qp_cong_set_def  by blast
     have 1:  "x \<in> \<O>\<^sub>p"
       using A unfolding Qp_cong_set_def by blast
     have 2: "to_Zp x \<in> carrier Z\<^sub>p"
       using 1 val_ring_memE to_Zp_closed by blast
     have 3: "val_Zp (to_Zp x \<ominus>\<^bsub>Z\<^sub>p\<^esub> a) \<ge> \<alpha>"
       using 0 assms 2 val_Zp_dist_def val_Zp_dist_res_eq2 by presburger
     have 4: "val_Zp (to_Zp x \<ominus>\<^bsub>Z\<^sub>p\<^esub> a) > val_Zp a"
       using 3 assms(2) less_le_trans[of "val_Zp a" "eint (int \<alpha>)" "val_Zp (to_Zp x \<ominus>\<^bsub>Z\<^sub>p\<^esub> a)" ]
       by blast
     then have 5: "val_Zp (to_Zp x) = val_Zp a"
       using assms 2 equal_val_Zp by blast
     have 7: "val (x \<ominus> (\<iota> a)) \<ge> \<alpha>"
       using 3 5 1 by (metis "2" Zp.minus_closed assms(1) inc_of_diff to_Zp_inc val_of_inc)
     then show "x \<in> B\<^bsub>int \<alpha>\<^esub>[\<iota> a]"
       using c_ballI[of x \<alpha> "\<iota> a"]  1 assms val_ring_memE by blast
   qed
   show "B\<^bsub>int \<alpha>\<^esub>[\<iota> a] \<subseteq> Qp_cong_set \<alpha> a"
   proof fix x
     assume A: "x \<in> B\<^bsub>int \<alpha>\<^esub>[\<iota> a]"
     then have 0: "val (x \<ominus> \<iota> a) \<ge> \<alpha>"
       using c_ballE by blast
     have 1: "val (\<iota> a) = val_Zp a"
       using assms  Zp_def \<iota>_def padic_fields.val_of_inc padic_fields_axioms
       by metis
     then have 2: "val (x \<ominus> \<iota> a) > val (\<iota> a)"
       using 0 assms less_le_trans[of "val (\<iota> a)" "eint (int \<alpha>)" "val (x \<ominus> \<iota> a)"]
       by metis
     have "\<iota> a \<in> carrier Q\<^sub>p"
       using assms(1) inc_closed by blast
     then have B: "val x = val (\<iota> a)"
       using 2  A assms c_ballE(1)[of x \<alpha> "\<iota> a"]
       by (metis ultrametric_equal_eq)
     have 3: "val_Zp (to_Zp x) = val_Zp a"
       by (metis "1" A \<open>val x = val (\<iota> a)\<close> assms(1) c_ballE(1) to_Zp_val val_pos val_ringI)
     have 4: "val_Zp (to_Zp x \<ominus>\<^bsub>Z\<^sub>p\<^esub> a) \<ge> \<alpha>"
       using 0 A 3
       by (metis B Zp.minus_closed assms(1) c_ballE(1) inc_of_diff to_Zp_closed to_Zp_inc val_of_inc val_pos val_ring_val_criterion)
     then have 5: "to_Zp x \<alpha> = a \<alpha>"
       by (meson A Zp.minus_closed assms(1) c_ballE(1) res_diff_zero_fact(1) to_Zp_closed zero_below_val_Zp)
     have 6: "x \<in> \<O>\<^sub>p"
     proof-
       have "val x \<ge> 0"
         using B assms 1 val_pos by presburger
       then show ?thesis
         using A c_ballE(1) val_ringI by blast
     qed
     then show "x \<in> Qp_cong_set \<alpha> a" unfolding Qp_cong_set_def
       using "5" by blast
   qed
 qed
 
 lemma Qp_cong_set_is_univ_semialgebraic:
   assumes "a \<in> carrier Z\<^sub>p"
   shows "is_univ_semialgebraic (Qp_cong_set \<alpha> a)"
 proof(cases "a \<alpha> = 0")
   case True
   then show ?thesis
     using ball_is_univ_semialgebraic[of \<zero> \<alpha>] Qp.zero_closed  Qp_cong_set_as_ball assms
     by metis
 next
   case False
   then have "\<alpha> \<noteq> 0"
     using assms residues_closed[of a 0]
     by (meson p_res_ring_0')
   then obtain n where n_def: "Suc n = \<alpha>"
     by (metis lessI less_Suc_eq_0_disj)
   then have "val_Zp a < eint (int \<alpha>)"
     using below_val_Zp_zero[of a n]
     by (smt False assms eint_ile eint_ord_simps(1) eint_ord_simps(2) zero_below_val_Zp)
   then show ?thesis
     using ball_is_univ_semialgebraic[of "\<iota> a" \<alpha>] Qp.zero_closed  Qp_cong_set_as_ball'[of a \<alpha>] assms
          inc_closed by presburger
 qed
 
 lemma constant_res_set_semialg:
   assumes "l \<in> carrier (Zp_res_ring n)"
   shows "is_univ_semialgebraic {x \<in> \<O>\<^sub>p. Qp_res x n = l}"
 proof-
   have 0: "{x \<in> \<O>\<^sub>p. Qp_res x n = l} = Qp_cong_set n ([l]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
     apply(rule equalityI')
     unfolding mem_Collect_eq Qp_cong_set_def Qp_res_def
     apply (metis val_ring_memE Zp_int_inc_rep nat_le_linear p_residue_padic_int to_Zp_closed)
     using assms
     by (metis Zp_int_inc_res mod_pos_pos_trivial p_residue_ring_car_memE(1) p_residue_ring_car_memE(2))
   show ?thesis unfolding 0
     apply(rule Qp_cong_set_is_univ_semialgebraic)
     by(rule Zp.int_inc_closed)
 qed
 
 end
 
 end
diff --git a/thys/Probabilistic_Prime_Tests/Jacobi_Symbol.thy b/thys/Probabilistic_Prime_Tests/Jacobi_Symbol.thy
--- a/thys/Probabilistic_Prime_Tests/Jacobi_Symbol.thy
+++ b/thys/Probabilistic_Prime_Tests/Jacobi_Symbol.thy
@@ -1,545 +1,545 @@
 (*
   File:     Jacobi_Symbol.thy
   Authors:  Daniel Stüwe, Manuel Eberl
 
   The Jacobi symbol, a generalisation of the Legendre symbol.
   This is used in the Solovay--Strassen test.
 *)
 section \<open>The Jacobi Symbol\<close>
 theory Jacobi_Symbol
 imports 
   Legendre_Symbol
   Algebraic_Auxiliaries
 begin
 
 text \<open>
   The Jacobi symbol is a generalisation of the Legendre symbol to non-primes \cite{Legendre_Symbol, Jacobi_Symbol}.
   It is defined as
   \[\left(\frac{a}{n}\right) =
       \left(\frac{a}{p_1}\right)^{k_1} \ldots \left(\frac{a}{p_l}\right)^{k_l}\]
   where $(\frac{a}{p})$ denotes the Legendre symbol, \<open>a\<close> is an integer, \<open>n\<close> is an odd natural
   number and $p_1^{k_1}\ldots p_l^{k_l}$ is its prime factorisation.
 
   There is, however, a fairly natural generalisation to all non-zero integers for \<open>n\<close>.
   It is less clear what a good choice for \<open>n = 0\<close> is; Mathematica and Maxima adopt
   the convention that $(\frac{\pm 1}{0}) = 1$ and $(\frac{a}{0}) = 0$ otherwise. However,
   we chose the slightly different convention $(\frac{a}{0}) = 0$ for \<^emph>\<open>all\<close> \<open>a\<close> because then
   the Jacobi symbol is completely multiplicative in both arguments without any restrictions.
 \<close>
 definition Jacobi :: "int \<Rightarrow> int \<Rightarrow> int" where
   "Jacobi a n = (if n = 0 then 0 else
                   (\<Prod>p\<in>#prime_factorization n. Legendre a p))"
 
 lemma Jacobi_0_right [simp]: "Jacobi a 0 = 0"
   by (simp add: Jacobi_def)
 
 lemma Jacobi_mult_left [simp]: "Jacobi (a * b) n = Jacobi a n * Jacobi b n"
 proof (cases "n = 0")
   case False
   have *: "{# Legendre (a * b) p          . p \<in># prime_factorization n #} =
            {# Legendre a p * Legendre b p . p \<in># prime_factorization n #}"
     by (meson Legendre_mult in_prime_factors_imp_prime image_mset_cong)
 
   show ?thesis using False unfolding Jacobi_def * prod_mset.distrib by auto
 qed auto
 
 lemma Jacobi_mult_right [simp]: "Jacobi a (n * m) = Jacobi a n * Jacobi a m"
   by (cases "m = 0"; cases "n = 0")
      (auto simp: Jacobi_def prime_factorization_mult)
 
 lemma prime_p_Jacobi_eq_Legendre[intro!]: "prime p \<Longrightarrow> Jacobi a p = Legendre a p"
   unfolding Jacobi_def prime_factorization_prime by simp
 
 lemma Jacobi_mod [simp]: "Jacobi (a mod m) n = Jacobi a n" if "n dvd m"
 proof -
   have *: "{# Legendre (a mod m) p . p \<in># prime_factorization n #} =
            {# Legendre a p . p \<in># prime_factorization n #}" using that
     by (intro image_mset_cong, subst Legendre_mod)
        (auto intro: dvd_trans[OF in_prime_factors_imp_dvd])
   thus ?thesis by (simp add: Jacobi_def)
 qed
 
 lemma Jacobi_mod_cong: "[a = b] (mod n) \<Longrightarrow> Jacobi a n = Jacobi b n"
   by (metis Jacobi_mod cong_def dvd_refl)
 
 lemma Jacobi_1_eq_1 [simp]: "p \<noteq> 0 \<Longrightarrow> Jacobi 1 p = 1"
   by (simp add: Jacobi_def in_prime_factors_imp_prime cong: image_mset_cong)
 
 lemma Jacobi_eq_0_not_coprime:
   assumes "n \<noteq> 0" "\<not>coprime a n"
   shows   "Jacobi a n = 0"
 proof -
   from assms have "\<exists>p. p dvd gcd a n \<and> prime p"
     by (intro prime_divisor_exists) auto
   then obtain p where p: "p dvd a" "p dvd n" "prime p"
     by auto
   hence "Legendre a p = 0" using assms
     by (auto simp: prime_int_iff)
   thus ?thesis using p assms
     unfolding Jacobi_def 
     by (auto simp: image_iff prime_factors_dvd)
 qed
 
 lemma Jacobi_p_eq_2'[simp]: "n > 0 \<Longrightarrow> Jacobi a (2^n) = a mod 2"
   by (auto simp add: Jacobi_def prime_factorization_prime_power)
 
 lemma Jacobi_prod_mset[simp]: "n \<noteq> 0 \<Longrightarrow> Jacobi (prod_mset M) n = (\<Prod>q\<in>#M. Jacobi q n)"
   by (induction M) simp_all
 
 lemma non_trivial_coprime_neq:
   "1 < a \<Longrightarrow> 1 < b \<Longrightarrow> coprime a b \<Longrightarrow> a \<noteq> b" for a b :: int by auto
 
 
 lemma odd_odd_even: 
   fixes a b :: int 
   assumes "odd a" "odd b"
   shows "even ((a*b-1) div 2) = even ((a-1) div 2 + (b-1) div 2)"
   using assms by (auto elim!: oddE simp: algebra_simps)
 
 lemma prime_nonprime_wlog [case_names primes nonprime sym]:
   assumes "\<And>p q. prime p \<Longrightarrow> prime q \<Longrightarrow> P p q"
   assumes "\<And>p q. \<not>prime p \<Longrightarrow> P p q"
   assumes "\<And>p q. P p q \<Longrightarrow> P q p"
   shows   "P p q"
   by (cases "prime p"; cases "prime q") (auto intro: assms)
 
 lemma Quadratic_Reciprocity_Jacobi:
   fixes p q :: int
   assumes "coprime p q"
       and "2 < p" "2 < q"
       and "odd p" "odd q"
     shows "Jacobi p q * Jacobi q p =
            (- 1) ^ (nat ((p - 1) div 2 * ((q - 1) div 2)))"
   using assms
 proof (induction "nat p" "nat q" arbitrary: p q 
          rule: measure_induct_rule[where f = "\<lambda>(a, b). a + b", split_format(complete), simplified])
   case (1 p q)
   thus ?case
   proof (induction p q rule: prime_nonprime_wlog)
     case (sym p q)
     thus ?case by (simp only: add_ac coprime_commute mult_ac) blast
   next
     case (primes p q)
     from \<open>prime p\<close> \<open>prime q\<close> have "prime (nat p)" "prime (nat q)" "p \<noteq> q"
       using prime_int_nat_transfer primes(4) non_trivial_coprime_neq prime_gt_1_int
       by blast+
 
     with Quadratic_Reciprocity_int and prime_p_Jacobi_eq_Legendre
     show ?case
       using \<open>prime p\<close> \<open>prime q\<close> primes(5-) 
       by presburger
   next
     case (nonprime p q)
     from \<open>\<not>prime p\<close> obtain a b where *: "p = a * b" "1 < b" "1 < a"
       using \<open>2 < p\<close> prime_divisor_exists_strong[of p] by auto
 
     hence odd_ab: "odd a" "odd b" using \<open>odd p\<close> by simp_all
 
     moreover have "2 < b" and "2 < a" 
       using odd_ab and * by presburger+
 
     moreover have "coprime a q" and "coprime b q" using \<open>coprime p q\<close> 
       unfolding * by simp_all
 
     ultimately have IH: "Jacobi a q * Jacobi q a = (- 1) ^ nat ((a - 1) div 2 * ((q - 1) div 2))"
                         "Jacobi b q * Jacobi q b = (- 1) ^ nat ((b - 1) div 2 * ((q - 1) div 2))"
       by (auto simp: * nonprime)
 
     have pos: "0 < q" "0 < p" "0 < a" "0 < b" 
       using * \<open>2 < q\<close> by simp_all
 
     have "Jacobi p q * Jacobi q p = (Jacobi a q * Jacobi q a) * (Jacobi b q * Jacobi q b)"
       using * by simp
 
     also have "... = (- 1) ^ nat ((a - 1) div 2 * ((q - 1) div 2)) *
                      (- 1) ^ nat ((b - 1) div 2 * ((q - 1) div 2))"
       using IH by presburger
 
     also from odd_odd_even[OF odd_ab]
     have "... = (- 1) ^ nat ((p - 1) div 2 * ((q - 1) div 2))"
       unfolding * minus_one_power_iff using \<open>2 < q\<close> *
       by (auto simp add: even_nat_iff pos_imp_zdiv_nonneg_iff)
 
     finally show ?case .
   qed
 qed
 
 lemma Jacobi_values: "Jacobi p q \<in> {1, -1, 0}"
 proof (cases "q = 0")
   case False
   hence "\<bar>Legendre p x\<bar> = 1" if "x \<in># prime_factorization q" "Jacobi p q \<noteq> 0" for x
     using that prod_mset_zero_iff Legendre_values[of p x]
     unfolding Jacobi_def is_unit_prod_mset_iff set_image_mset
     by fastforce
 
   then have "is_unit (prod_mset (image_mset (Legendre p) (prime_factorization q)))"
     if "Jacobi p q \<noteq> 0"
     using that False
     unfolding Jacobi_def is_unit_prod_mset_iff 
     by auto
 
   thus ?thesis by (auto simp: Jacobi_def)
 qed auto
 
 lemma Quadratic_Reciprocity_Jacobi':
   fixes p q :: int
   assumes "coprime p q"
       and "2 < p" "2 < q"
       and "odd p" "odd q"
     shows "Jacobi q p = (if p mod 4 = 3 \<and> q mod 4 = 3 then -1 else 1) * Jacobi p q"
 proof -
   have aux: "a \<in> {1, -1, 0} \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> a*b = c \<Longrightarrow> b = c * a" for b c a :: int by auto
 
   from Quadratic_Reciprocity_Jacobi[OF assms] 
   have "Jacobi q p = (-1) ^ nat ((p - 1) div 2 * ((q - 1) div 2)) * Jacobi p q"
     using Jacobi_values by (fastforce intro!: aux)
 
   also have "(-1 :: int) ^ nat ((p - 1) div 2 * ((q - 1) div 2)) = (if even ((p - 1) div 2) \<or> even ((q - 1) div 2) then 1 else - 1)"
     unfolding minus_one_power_iff using \<open>2 < p\<close> \<open>2 < q\<close>
     by (auto simp: even_nat_iff)
 
   also have "... = (if p mod 4 = 3 \<and> q mod 4 = 3 then -1 else 1)"
     using \<open>odd p\<close> \<open>odd q\<close> by presburger
 
   finally show ?thesis .
 
 qed
 
 lemma dvd_odd_square: "8 dvd a\<^sup>2 - 1" if "odd a" for a :: int 
 proof -
   obtain x where "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
   thus ?thesis
     by(cases "odd x") 
       (auto elim: oddE simp: power2_eq_square algebra_simps)
 qed 
 
 lemma odd_odd_even': 
   fixes a b :: int 
   assumes "odd a" "odd b"
   shows "even (((a * b)\<^sup>2 - 1) div 8) \<longleftrightarrow> even (((a\<^sup>2 - 1) div 8) + ((b\<^sup>2 - 1) div 8))"
 proof -
   obtain x where [simp]: "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
   obtain y where [simp]: "b = 2*y + 1" using \<open>odd b\<close> by (auto elim: oddE)
   show ?thesis
     by (cases "even x"; cases "even y"; elim oddE evenE)
        (auto simp: power2_eq_square algebra_simps)
 qed
 
 lemma odd_odd_even_nat': 
   fixes a b :: nat 
   assumes "odd a" "odd b"
   shows "even (((a * b)\<^sup>2 - 1) div 8) \<longleftrightarrow> even (((a\<^sup>2 - 1) div 8) + ((b\<^sup>2 - 1) div 8))"
 proof -
   obtain x where [simp]: "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
   obtain y where [simp]: "b = 2*y + 1" using \<open>odd b\<close> by (auto elim: oddE)
   show ?thesis
     by (cases "even x"; cases "even y"; elim oddE evenE)
        (auto simp: power2_eq_square algebra_simps)
 qed
 
 lemma supplement2_Jacobi: "odd p \<Longrightarrow> p > 1 \<Longrightarrow> Jacobi 2 p = (- 1) ^ (((nat p)\<^sup>2 - 1) div 8)"
 proof (induction p rule: prime_divisors_induct)
   case (factor p x)
 
   then have "odd x" by force
 
   have "2 < p" 
     using \<open>odd (p * x)\<close> prime_gt_1_int[OF \<open>prime p\<close>] 
     by (cases "p = 2") auto
 
   have "odd p" using prime_odd_int[OF \<open>prime p\<close> \<open>2 < p\<close>] .
 
   have "0 < x"
     using \<open>1 < (p * x)\<close> prime_gt_0_int[OF \<open>prime p\<close>]
     and less_trans less_numeral_extra(1) zero_less_mult_pos by blast
 
   have base_case : "Jacobi 2 p = (- 1) ^ (((nat p)\<^sup>2 - 1) div 8)" 
     using \<open>2 < p\<close> \<open>prime p\<close> supplement2_Legendre and prime_p_Jacobi_eq_Legendre
     by presburger
 
   show ?case proof (cases "x = 1")
     case True
     thus ?thesis using base_case by force
   next
     case False
     have "Jacobi 2 (p * x) = Jacobi 2 p * Jacobi 2 x"
       using \<open>2 < p\<close> \<open>0 < x\<close> by simp
 
     also have "Jacobi 2 x = (- 1) ^ (((nat x)\<^sup>2 - 1) div 8)"
       using \<open>odd x\<close> \<open>0 < x\<close> \<open>x \<noteq> 1\<close> by (intro factor.IH) auto
 
     also note base_case
 
     also have "(-1) ^ (((nat p)\<^sup>2 - 1) div 8) * (-1) ^ (((nat x)\<^sup>2 - 1) div 8)
              = (-1 :: int) ^ (((nat (p * x))\<^sup>2 - 1) div 8)" 
       unfolding minus_one_power_iff
       using \<open>2 < p\<close> \<open>0 < x\<close> \<open>odd x\<close> \<open>odd p\<close> and odd_odd_even_nat'
       using [[linarith_split_limit = 0]]
       by (force simp add: nat_mult_distrib even_nat_iff)
 
     finally show ?thesis .
   qed
 qed simp_all
 
 lemma mod_nat_wlog [consumes 1, case_names modulo]:
   fixes P :: "nat \<Rightarrow> bool"
   assumes "b > 0"
   assumes "\<And>k. k \<in> {0..<b} \<Longrightarrow> n mod b = k \<Longrightarrow> P n"
   shows   "P n"
   using assms and mod_less_divisor 
   by fastforce
 
 lemma mod_int_wlog [consumes 1, case_names modulo]:
   fixes P :: "int \<Rightarrow> bool"
   assumes "b > 0"
   assumes "\<And>k. 0 \<le> k \<Longrightarrow> k < b \<Longrightarrow> n mod b = k \<Longrightarrow> P n"
   shows   "P n"
-  using assms and pos_mod_conj by blast 
+  using \<open>b > 0\<close> assms(2) [of \<open>n mod b\<close>] by simp
 
 lemma supplement2_Jacobi':
   assumes "odd p" and "p > 1"
   shows "Jacobi 2 p = (if p mod 8 = 1 \<or> p mod 8 = 7 then 1 else -1)"
 proof -
   have "0 < (4 :: nat)" by simp
   then have *: "even ((p\<^sup>2 - 1) div 8) = (p mod 8 = 1 \<or> p mod 8 = 7)" if "odd p" for p :: nat
   proof(induction p rule: mod_nat_wlog)
     case (modulo k)
     then consider "p mod 4 = 1" | "p mod 4 = 3"
       using \<open>odd p\<close>
       by (metis dvd_0_right even_even_mod_4_iff even_numeral mod_exhaust_less_4)
 
     then show ?case proof (cases)
       case 1
       then obtain l where l: "p = 4 * l + 1" using mod_natE by blast
       have "even l = ((4 * l + 1) mod 8 = 1 \<or> (4 * l + 1) mod 8 = 7)" by presburger
       thus ?thesis by (simp add: l power2_eq_square algebra_simps)
     next
       case 2
       then obtain l where l: "p = 4 * l + 3" using mod_natE by blast
       have "odd l = ((3 + l * 4) mod 8 = Suc 0 \<or> (3 + l * 4) mod 8 = 7)" by presburger
       thus ?thesis by (simp add: l power2_eq_square algebra_simps)
     qed
   qed
 
   have [simp]: "nat p mod 8 = nat (p mod 8)"
     using \<open>p > 1\<close> using nat_mod_distrib[of p 8] by simp
   from assms have "odd (nat p)" by (simp add: even_nat_iff)
   show ?thesis
     unfolding supplement2_Jacobi[OF assms]
               minus_one_power_iff *[OF \<open>odd (nat p)\<close>]
     by (simp add: nat_eq_iff)
 qed
 
 theorem supplement1_Jacobi:
   "odd p \<Longrightarrow> 1 < p \<Longrightarrow> Jacobi (-1) p = (-1) ^ (nat ((p - 1) div 2))"
 proof (induction p rule: prime_divisors_induct)
   case (factor p x)
   then have "odd x" by force
 
   have "2 < p" 
     using \<open>odd (p * x)\<close> prime_gt_1_int[OF \<open>prime p\<close>]
     by (cases "p = 2") auto
 
   have "prime (nat p)"
     using \<open>prime p\<close> prime_int_nat_transfer
     by blast
 
   have "Jacobi (-1) p = Legendre (-1) p"
     using prime_p_Jacobi_eq_Legendre[OF \<open>prime p\<close>] .
 
   also have "... = (-1) ^ ((nat p - 1) div 2)"
     using \<open>prime p\<close> \<open>2 < p\<close> and supplement1_Legendre[of "nat p"]
     by (metis int_nat_eq nat_mono_iff nat_numeral_as_int prime_gt_0_int prime_int_nat_transfer) 
 
   also have "((nat p - 1) div 2) = nat ((p - 1) div 2)" by force
 
   finally have base_case: "Jacobi (-1) p = (-1) ^ nat ((p - 1) div 2)" .
 
   show ?case proof (cases "x = 1")
     case True
     then show ?thesis using base_case by simp
   next
     case False
     have "0 < x" 
       using \<open>1 < (p * x)\<close> prime_gt_0_int[OF \<open>prime p\<close>]
       by (meson int_one_le_iff_zero_less not_less not_less_iff_gr_or_eq zero_less_mult_iff)
   
     have "odd p" using \<open>prime p\<close> \<open>2 < p\<close> by (simp add: prime_odd_int) 
 
     have "Jacobi (-1) (p * x) = Jacobi (-1) p * Jacobi (-1) x"
       using \<open>2 < p\<close> \<open>0 < x\<close> by simp
 
     also note base_case
 
     also have "Jacobi (-1) x = (-1) ^ nat ((x - 1) div 2)"
       using \<open>0 < x\<close> False \<open>odd x\<close> factor.IH 
       by fastforce
 
     also have "(- 1) ^ nat ((p - 1) div 2) * (- 1) ^ nat ((x - 1) div 2) =
                (- 1 :: int) ^ nat ((p*x - 1) div 2)"
       unfolding minus_one_power_iff
       using \<open>2 < p\<close> \<open>0 < x\<close> and \<open>odd x\<close> \<open>odd p\<close>
       by (fastforce elim!: oddE simp: even_nat_iff algebra_simps)
 
     finally show ?thesis .
   qed
 qed simp_all
 
 theorem supplement1_Jacobi':
   "odd n \<Longrightarrow> 1 < n \<Longrightarrow> Jacobi (-1) n = (if n mod 4 = 1 then 1 else -1)"
   by (simp add: even_nat_iff minus_one_power_iff supplement1_Jacobi)
      presburger?
 
 lemma Jacobi_0_eq_0: "\<not>is_unit n \<Longrightarrow> Jacobi 0 n = 0"
   by (cases "prime_factorization n = {#}")
      (auto simp: Jacobi_def prime_factorization_empty_iff image_iff intro: Nat.gr0I)
 
 lemma is_unit_Jacobi_aux: "is_unit x \<Longrightarrow> Jacobi a x = 1"
   unfolding Jacobi_def using prime_factorization_empty_iff[of x] by auto
 
 lemma is_unit_Jacobi[simp]: "Jacobi a 1 = 1" "Jacobi a (-1) = 1"
   using is_unit_Jacobi_aux by simp_all
 
 lemma Jacobi_neg_right [simp]:
   "Jacobi a (-n) = Jacobi a n"
 proof -
   have * : "-n = (-1) * n" by simp
   show ?thesis unfolding *
     by (subst Jacobi_mult_right) auto
 qed
 
 lemma Jacobi_neg_left:
   assumes "odd n" "1 < n" 
   shows   "Jacobi (-a) n = (if n mod 4 = 1 then 1 else -1) * Jacobi a n"
 proof -
   have * : "-a = (-1) * a" by simp
   show ?thesis unfolding * Jacobi_mult_left supplement1_Jacobi'[OF assms] ..
 qed
 
 function jacobi_code :: "int \<Rightarrow> int \<Rightarrow> int" where
 "jacobi_code a n = ( 
         if n = 0 then 0
    else if n = 1 then 1
    else if a = 1 then 1
    else if n < 0 then jacobi_code a (-n)
    else if even n then if even a then 0 else jacobi_code a (n div 2)
    else if a < 0 then (if n mod 4 = 1 then 1 else -1) * jacobi_code (-a) n
    else if a = 0 then 0
    else if a \<ge> n then jacobi_code (a mod n) n
    else if even a      then (if n mod 8 \<in> {1, 7} then 1 else -1) * jacobi_code (a div 2) n
    else if coprime a n then (if n mod 4 = 3 \<and> a mod 4 = 3 then -1 else 1) * jacobi_code n a
    else 0)"
   by auto
 termination
 proof (relation "measure (\<lambda>(a, n). nat(abs(a) + abs(n)*2) + 
                    (if n < 0 then 1 else 0) + (if a < 0 then 1 else 0))", goal_cases)
   case (5 a n)
   thus ?case by (fastforce intro!: less_le_trans[OF pos_mod_bound])
 qed auto
 
 lemmas [simp del] = jacobi_code.simps
 
 lemma Jacobi_code [code]: "Jacobi a n = jacobi_code a n"
 proof (induction a n rule: jacobi_code.induct)
   case (1 a n)
   show ?case
   proof (cases "n = 0")
     case 2: False
     then show ?thesis proof (cases "n = 1")
       case 3: False
       then show ?thesis proof (cases "a = 1")
         case 4: False
           then show ?thesis proof (cases "n < 0")
             case True
             then show ?thesis using 2 3 4 1(1) by (subst jacobi_code.simps) simp
             next
             case 5: False
             then show ?thesis proof (cases "even n")
               case True
               then show ?thesis using 2 3 4 5 1(2)
                 by (elim evenE, subst jacobi_code.simps) (auto simp: prime_p_Jacobi_eq_Legendre)
             next
               case 6: False
               then show ?thesis  proof (cases "a < 0")
                 case True
                 then show ?thesis using 2 3 4 5 6
                   by(subst jacobi_code.simps, subst 1(3)[symmetric]) (simp_all add: Jacobi_neg_left)
               next
                 case 7: False
                 then show ?thesis proof (cases "a = 0")
                   case True
                   have *: "\<not> is_unit n" using 3 5 by simp
                   then show ?thesis
                     using Jacobi_0_eq_0[OF *] 2 3 4 5 7 True
                     by (subst jacobi_code.simps) simp
                 next
                   case 8: False
                   then show ?thesis proof (cases "a \<ge> n")
                     case True
                     then show ?thesis using 2 3 4 5 6 7 8 1(4)
                       by (subst jacobi_code.simps) simp
                   next
                     case 9: False
                     then show ?thesis proof (cases "even a")
                       case True
                       hence "a = 2 * (a div 2)" by simp
                       also have "Jacobi \<dots> n = Jacobi 2 n * Jacobi (a div 2) n"
                         by simp
                       also have "Jacobi (a div 2) n = jacobi_code (a div 2) n"
                         using 2 3 4 5 6 7 8 9 True by (intro 1(5))
                       also have "Jacobi 2 n = (if n mod 8 \<in> {1, 7} then 1 else - 1)"
                         using 2 3 5 supplement2_Jacobi'[OF 6] by simp
                       also have "\<dots> * jacobi_code (a div 2) n = jacobi_code a n"
                         using 2 3 4 5 6 7 8 9 True
                         by (subst (2) jacobi_code.simps) (simp only: if_False if_True HOL.simp_thms)
                       finally show ?thesis .
                     next
                       case 10: False
                       note foo = 1 2 3
                       then show ?thesis proof (cases "coprime a n")
                         case True
                         note this_case = 2 3 4 5 6 7 8 9 10 True
                         have "2 < a" using 10 4 7 by presburger
                         moreover have "2 < n" using 3 5 6 by presburger
                         ultimately have "jacobi_code a n = (if n mod 4 = 3 \<and> a mod 4 = 3 then - 1 else 1)
                                                         * jacobi_code n a"
                           using this_case by (subst jacobi_code.simps) simp
                         also have "jacobi_code n a = Jacobi n a"
                           using this_case by (intro 1(6) [symmetric]) auto
                         also have "(if n mod 4 = 3 \<and> a mod 4 = 3 then -1 else 1) * \<dots> = Jacobi a n"
                           using this_case and \<open>2 < a\<close>
                           by (intro Quadratic_Reciprocity_Jacobi' [symmetric])
                              (auto simp: coprime_commute)
                         finally show ?thesis ..
                       next
                         case False
                         have *: "0 < a" "0 < n" using 5 7 8 9 by linarith+ 
                         show ?thesis
                           using 1 2 3 4 5 6 7 8 9 10 False *
                           by (subst jacobi_code.simps) (auto simp: Jacobi_eq_0_not_coprime)
                       qed
                     qed
                   qed
                 qed
               qed
             qed
         qed
       qed (subst jacobi_code.simps, simp)
     qed (subst jacobi_code.simps, simp)
   qed (subst jacobi_code.simps, simp)
 qed
 
 lemma Jacobi_eq_0_imp_not_coprime:
   assumes "p \<noteq> 0" "p \<noteq> 1"
   shows   "Jacobi n p = 0 \<Longrightarrow> \<not>coprime n p"
   using assms Jacobi_mod_cong coprime_iff_invertible_int by force
 
 lemma Jacobi_eq_0_iff_not_coprime:
   assumes "p \<noteq> 0" "p \<noteq> 1"
   shows "Jacobi n p = 0 \<longleftrightarrow> \<not>coprime n p"
 proof -
   from assms and Jacobi_eq_0_imp_not_coprime 
   show ?thesis using Jacobi_eq_0_not_coprime by auto
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Rank_Nullity_Theorem/Mod_Type.thy b/thys/Rank_Nullity_Theorem/Mod_Type.thy
--- a/thys/Rank_Nullity_Theorem/Mod_Type.thy
+++ b/thys/Rank_Nullity_Theorem/Mod_Type.thy
@@ -1,557 +1,555 @@
 (*
     Title:      Mod_Type.thy
     Author:     Jose Divasón <jose.divasonm at unirioja.es>
     Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
 *)
 
 section\<open>Class for modular arithmetic\<close>
 
 theory Mod_Type
 imports
   "HOL-Library.Numeral_Type"
   "HOL-Analysis.Cartesian_Euclidean_Space"
   Dual_Order
 begin
 
 subsection\<open>Definition and properties\<close>
 
 text\<open>Class for modular arithmetic. It is inspired by the locale mod\_type.\<close>
 
 class mod_type = times + wellorder + neg_numeral +
 fixes Rep :: "'a => int"
   and Abs :: "int => 'a"
   assumes type: "type_definition Rep Abs {0..<int CARD ('a)}"
   and size1: "1 < int CARD ('a)"
   and zero_def: "0 = Abs 0"
   and one_def:  "1 = Abs 1"
   and add_def:  "x + y = Abs ((Rep x + Rep y) mod (int CARD ('a)))"
   and mult_def: "x * y = Abs ((Rep x * Rep y) mod (int CARD ('a)))"
   and diff_def: "x - y = Abs ((Rep x - Rep y) mod (int CARD ('a)))"
   and minus_def: "- x = Abs ((- Rep x) mod (int CARD ('a)))"
   and strict_mono_Rep: "strict_mono Rep"
 begin
 
 lemma size0: "0 < int CARD ('a)"
   using size1 by simp
 
 lemmas definitions =
   zero_def one_def add_def mult_def minus_def diff_def
 
 lemma Rep_less_n: "Rep x < int CARD ('a)"
   by (rule type_definition.Rep [OF type, simplified, THEN conjunct2])
 
 lemma Rep_le_n: "Rep x \<le> int CARD ('a)"
   by (rule Rep_less_n [THEN order_less_imp_le])
 
 lemma Rep_inject_sym: "x = y \<longleftrightarrow> Rep x = Rep y"
   by (rule type_definition.Rep_inject [OF type, symmetric])
 
 lemma Rep_inverse: "Abs (Rep x) = x"
   by (rule type_definition.Rep_inverse [OF type])
 
 lemma Abs_inverse: "m \<in> {0..<int CARD ('a)} \<Longrightarrow> Rep (Abs m) = m"
   by (rule type_definition.Abs_inverse [OF type])
 
 lemma Rep_Abs_mod: "Rep (Abs (m mod int CARD ('a))) = m mod int CARD ('a)"
-  by (simp add: Abs_inverse pos_mod_conj [OF size0])
+  using size0 by (auto simp add: Abs_inverse)
 
 lemma Rep_Abs_0: "Rep (Abs 0) = 0"
   apply (rule Abs_inverse [of 0])
   using size0 by simp
 
 lemma Rep_0: "Rep 0 = 0"
   by (simp add: zero_def Rep_Abs_0)
 
 lemma Rep_Abs_1: "Rep (Abs 1) = 1"
   by (simp add: Abs_inverse size1)
 
 lemma Rep_1: "Rep 1 = 1"
   by (simp add: one_def Rep_Abs_1)
 
 lemma Rep_mod: "Rep x mod int CARD ('a) = Rep x"
   apply (rule_tac x=x in type_definition.Abs_cases [OF type])
   apply (simp add: type_definition.Abs_inverse [OF type])
 done
 
 lemmas Rep_simps =
   Rep_inject_sym Rep_inverse Rep_Abs_mod Rep_mod Rep_Abs_0 Rep_Abs_1
 
 subsection\<open>Conversion between a modular class and the subset of natural numbers associated.\<close>
 text\<open>Definitions to make transformations among elements of a modular class and naturals\<close>
 definition to_nat :: "'a => nat"
   where "to_nat = nat \<circ> Rep"
 
 definition Abs' :: "int => 'a"
   where "Abs' x = Abs(x mod int CARD ('a))"
 
 definition from_nat :: "nat \<Rightarrow> 'a"
   where "from_nat = (Abs' \<circ> int)"
 
 lemma bij_Rep: "bij_betw (Rep) (UNIV::'a set) {0..<int CARD('a)}"
 proof (unfold bij_betw_def, rule conjI)
   show "inj Rep" by (metis strict_mono_imp_inj_on strict_mono_Rep)
   show "range Rep = {0..<int CARD('a)}" using Typedef.type_definition.Rep_range[OF type] .
 qed
 
 lemma mono_Rep: "mono Rep" by (metis strict_mono_Rep strict_mono_mono)
 
 lemma Rep_ge_0: "0 \<le> Rep x" using bij_Rep unfolding bij_betw_def by auto
 
 lemma bij_Abs: "bij_betw (Abs) {0..<int CARD('a)} (UNIV::'a set)"
 proof (unfold bij_betw_def, rule conjI)
   show "inj_on Abs {0..<int CARD('a)}" by (metis inj_on_inverseI type type_definition.Abs_inverse)
   show "Abs ` {0..<int CARD('a)} = (UNIV::'a set)" by (metis type type_definition.univ)
 qed
 
 corollary bij_Abs': "bij_betw (Abs') {0..<int CARD('a)} (UNIV::'a set)"
 proof (unfold bij_betw_def, rule conjI)
   show "inj_on Abs' {0..<int CARD('a)}"
     unfolding inj_on_def Abs'_def
     by (auto, metis Rep_Abs_mod mod_pos_pos_trivial)
   show "Abs' ` {0..<int CARD('a)} = (UNIV::'a set)"
   proof (unfold image_def Abs'_def, auto)
     fix x show "\<exists>xa\<in>{0..<int CARD('a)}. x = Abs xa"
       by (rule bexI[of _ "Rep x"], auto simp add: Rep_less_n[of x] Rep_ge_0[of x], metis Rep_inverse)
   qed
 qed
 
 lemma bij_from_nat: "bij_betw (from_nat) {0..<CARD('a)} (UNIV::'a set)"
 proof (unfold bij_betw_def, rule conjI)
   have set_eq: "{0::int..<int CARD('a)} = int` {0..<CARD('a)}" apply (auto)
   proof -
     fix x::int  assume x1: "(0::int) \<le> x" and x2: "x < int CARD('a)" show "x \<in> int ` {0::nat..<CARD('a)}"
     proof (unfold image_def, auto, rule bexI[of _ "nat x"])
       show " x = int (nat x)" using x1 by auto
       show "nat x \<in> {0::nat..<CARD('a)}" using x1 x2 by auto
     qed
   qed
   show "inj_on (from_nat::nat\<Rightarrow>'a) {0::nat..<CARD('a)}"
   proof (unfold from_nat_def , rule comp_inj_on)
     show "inj_on int {0::nat..<CARD('a)}" by (metis inj_of_nat subset_inj_on top_greatest)
     show "inj_on (Abs'::int=>'a) (int ` {0::nat..<CARD('a)})"
       using bij_Abs unfolding bij_betw_def set_eq
       by (metis (opaque_lifting, no_types) Abs'_def Abs_inverse Rep_inverse Rep_mod inj_on_def set_eq)
   qed
   show "(from_nat::nat=>'a)` {0::nat..<CARD('a)} = UNIV"
     unfolding from_nat_def using bij_Abs'
     unfolding bij_betw_def set_eq o_def by blast
 qed
 
 lemma to_nat_is_inv: "the_inv_into {0..<CARD('a)} (from_nat::nat=>'a) = (to_nat::'a=>nat)"
 proof (unfold the_inv_into_def fun_eq_iff from_nat_def to_nat_def o_def, clarify)
   fix x::"'a" show "(THE y::nat. y \<in> {0::nat..<CARD('a)} \<and> Abs' (int y) = x) = nat (Rep x)"
   proof (rule the_equality, auto)
     show " Abs' (Rep x) = x" by (metis Abs'_def Rep_inverse Rep_mod)
     show "nat (Rep x) < CARD('a)" by (metis (full_types) Rep_less_n nat_int size0 zless_nat_conj)
     assume x:  "\<not> (0::int) \<le> Rep x" show "(0::nat) < CARD('a)" and "Abs' (0::int) = x"
       using Rep_ge_0 x by auto
   next
     fix y::nat assume y: "y < CARD('a)"
     have "(Rep(Abs'(int y)::'a)) = (Rep((Abs(int y mod int CARD('a)))::'a))" unfolding Abs'_def ..
     also have "... =  (Rep (Abs (int y)::'a))" using zmod_int[of y "CARD('a)"]
       using y mod_less by auto
     also have "... =  (int y)" proof (rule Abs_inverse) show "int y \<in> {0::int..<int CARD('a)}"
       using y by auto qed
     finally show "y = nat (Rep (Abs' (int y)::'a))" by (metis nat_int)
   qed
 qed
 
 lemma bij_to_nat: "bij_betw (to_nat) (UNIV::'a set) {0..<CARD('a)}"
   using bij_betw_the_inv_into[OF bij_from_nat] unfolding to_nat_is_inv .
 
 lemma finite_mod_type: "finite (UNIV::'a set)"
   using finite_imageD[of "to_nat" "UNIV::'a set"] using bij_to_nat unfolding bij_betw_def by auto
 
 subclass (in mod_type) finite by (intro_classes, rule finite_mod_type)
 
 lemma least_0: "(LEAST n. n \<in> (UNIV::'a set)) = 0"
 proof (rule Least_equality, auto)
   fix y::"'a"
   have "(0::'a) \<le> Abs (Rep y mod int CARD('a))" using strict_mono_Rep unfolding strict_mono_def
   by (metis (opaque_lifting, mono_tags) Rep_0 Rep_ge_0 strict_mono_Rep strict_mono_less_eq)
   also have "... = y" by (metis Rep_inverse Rep_mod)
   finally show "(0::'a) \<le> y" .
 qed
 
 lemma add_to_nat_def: "x + y = from_nat (to_nat x + to_nat y)"
   unfolding from_nat_def to_nat_def o_def using Rep_ge_0[of x] using Rep_ge_0[of y]
   using Rep_less_n[of x] Rep_less_n[of y]
   unfolding Abs'_def unfolding add_def[of x y] by auto
 
 lemma to_nat_1: "to_nat 1 = 1"
   by (simp add: to_nat_def Rep_1)
 
 lemma add_def':
   shows "x + y = Abs' (Rep x + Rep y)" unfolding Abs'_def using add_def by simp
 
 lemma Abs'_0:
   shows "Abs' (CARD('a))=(0::'a)" by (metis (opaque_lifting, mono_tags) Abs'_def mod_self zero_def)
 
 lemma Rep_plus_one_le_card:
   assumes a: "a + 1 \<noteq> 0"
   shows "(Rep a) + 1 < CARD ('a)"
 proof (rule ccontr)
   assume "\<not> Rep a + 1 < CARD('a)" hence to_nat_eq_card: "Rep a + 1 = CARD('a)"
     using Rep_less_n
     by (simp add: add1_zle_eq order_class.less_le)
   have "a+1 = Abs' (Rep a + Rep (1::'a))" using add_def' by auto
   also have "... = Abs' ((Rep a) + 1)" using Rep_1 by simp
   also have "... = Abs' (CARD('a))" unfolding to_nat_eq_card ..
   also have "... = 0" using Abs'_0 by auto
   finally show False using a by contradiction
 qed
 
 lemma to_nat_plus_one_less_card: "\<forall>a. a+1 \<noteq> 0 --> to_nat a + 1 < CARD('a)"
 proof (clarify)
 fix a
 assume a: "a + 1 \<noteq> 0"
 have "Rep a + 1 < int CARD('a)" using Rep_plus_one_le_card[OF a] by auto
 hence "nat (Rep a + 1) < nat (int CARD('a))" unfolding zless_nat_conj using size0 by fast
 thus "to_nat a + 1 < CARD('a)" unfolding to_nat_def o_def using nat_add_distrib[OF Rep_ge_0] by simp
 qed
 
 corollary to_nat_plus_one_less_card':
 assumes "a+1 \<noteq> 0"
 shows "to_nat a + 1 < CARD('a)" using to_nat_plus_one_less_card assms by simp
 
 lemma strict_mono_to_nat: "strict_mono to_nat"
   using strict_mono_Rep
   unfolding strict_mono_def to_nat_def using Rep_ge_0 by (metis comp_apply nat_less_eq_zless)
 
 lemma to_nat_eq [simp]: "to_nat x = to_nat y \<longleftrightarrow> x = y"
   using injD [OF bij_betw_imp_inj_on[OF bij_to_nat]] by blast
 
 lemma mod_type_forall_eq [simp]: "(\<forall>j::'a. (to_nat j)<CARD('a) \<longrightarrow> P j) = (\<forall>a. P a)"
 proof (auto)
   fix a assume a: "\<forall>j. (to_nat::'a=>nat) j < CARD('a) \<longrightarrow> P j"
   have "(to_nat::'a=>nat) a < CARD('a)" using bij_to_nat unfolding bij_betw_def by auto
   thus "P a" using a by auto
 qed
 
 lemma to_nat_from_nat:
   assumes t:"to_nat j = k"
   shows "from_nat k = j"
 proof -
   have "from_nat k = from_nat (to_nat j)"  unfolding t ..
   also have "... = from_nat (the_inv_into {0..<CARD('a)} (from_nat) j)" unfolding to_nat_is_inv ..
   also have "... = j"
   proof (rule f_the_inv_into_f)
     show "inj_on from_nat {0..<CARD('a)}" by (metis bij_betw_imp_inj_on bij_from_nat)
     show "j \<in> from_nat ` {0..<CARD('a)}" by (metis UNIV_I bij_betw_def bij_from_nat)
   qed
   finally show "from_nat k = j" .
 qed
 
 lemma to_nat_mono:
   assumes ab: "a < b"
   shows "to_nat a < to_nat b"
   using strict_mono_to_nat unfolding strict_mono_def using assms by fast
 
 lemma to_nat_mono':
   assumes ab: "a \<le> b"
   shows "to_nat a \<le> to_nat b"
 proof (cases "a=b")
   case True thus ?thesis by auto
 next
   case False
   hence "a<b" using ab by simp
   thus ?thesis using to_nat_mono by fastforce
 qed
 
 lemma least_mod_type:
   shows "0 \<le> (n::'a)"
   using least_0 by (metis (full_types) Least_le UNIV_I)
 
 lemma to_nat_from_nat_id:
   assumes x: "x<CARD('a)"
   shows "to_nat ((from_nat x)::'a) = x"
   unfolding to_nat_is_inv[symmetric] proof (rule the_inv_into_f_f)
   show "inj_on (from_nat::nat=>'a) {0..<CARD('a)}" using bij_from_nat unfolding bij_betw_def by auto
   show "x \<in> {0..<CARD('a)}" using x by simp
 qed
 
 lemma from_nat_to_nat_id[simp]:
   shows "from_nat (to_nat x) = x" by (metis to_nat_from_nat)
 
 lemma from_nat_to_nat:
   assumes t:"from_nat j = k" and j: "j<CARD('a)"
   shows "to_nat k = j" by (metis j t to_nat_from_nat_id)
 
 lemma from_nat_mono:
   assumes i_le_j: "i<j" and j: "j<CARD('a)"
   shows "(from_nat i::'a) < from_nat j"
 proof -
 have i: "i<CARD('a)" using i_le_j j by simp
 obtain a where a: "i=to_nat a"
   using bij_to_nat unfolding bij_betw_def using i to_nat_from_nat_id by metis
 obtain b where b: "j=to_nat b"
   using bij_to_nat unfolding bij_betw_def using j to_nat_from_nat_id by metis
 show ?thesis by (metis a b from_nat_to_nat_id i_le_j strict_mono_less strict_mono_to_nat)
 qed
 
 lemma from_nat_mono':
   assumes i_le_j: "i \<le> j" and "j<CARD ('a)"
   shows "(from_nat i::'a) \<le> from_nat j"
 proof (cases "i=j")
   case True
   have "(from_nat i::'a) = from_nat j" using True by simp
   thus ?thesis by simp
 next
   case False
   hence "i<j" using i_le_j by simp
   thus ?thesis by (metis assms(2) from_nat_mono less_imp_le)
 qed
 
 lemma to_nat_suc:
   assumes "to_nat (x)+1 < CARD ('a)"
   shows "to_nat (x + 1::'a) = (to_nat x) + 1"
 proof -
   have "(x::'a) + 1 = from_nat (to_nat x + to_nat (1::'a))" unfolding add_to_nat_def ..
   hence "to_nat ((x::'a) + 1) = to_nat (from_nat (to_nat x + to_nat (1::'a))::'a)" by presburger
   also have "... = to_nat (from_nat (to_nat x + 1)::'a)" unfolding to_nat_1 ..
   also have "... = (to_nat x + 1)" by (metis assms to_nat_from_nat_id)
   finally show ?thesis .
 qed
 
 lemma to_nat_le:
   assumes "y < from_nat k"
   shows  "to_nat y < k"
 proof (cases "k<CARD('a)")
   case True show ?thesis by (metis (full_types) True assms to_nat_from_nat_id to_nat_mono)
 next
   case False have "to_nat y < CARD ('a)" using bij_to_nat unfolding bij_betw_def by auto
   thus ?thesis using False by auto
 qed
 
 lemma le_Suc:
   assumes ab: "a < (b::'a)"
   shows "a + 1 \<le> b"
 proof -
   have "a + 1 = (from_nat (to_nat (a + 1))::'a)" using from_nat_to_nat_id [of "a+1",symmetric] .
   also have "... \<le> (from_nat (to_nat (b::'a))::'a)"
   proof (rule from_nat_mono')
     have "to_nat a < to_nat b" using ab by (metis to_nat_mono)
     hence "to_nat a + 1 \<le> to_nat b" by simp
     thus "to_nat b < CARD ('a)" using bij_to_nat unfolding  bij_betw_def by auto
     hence "to_nat a + 1 < CARD ('a)" by (metis \<open>to_nat a + 1 \<le> to_nat b\<close> preorder_class.le_less_trans)
     thus "to_nat (a + 1) \<le> to_nat b" by (metis \<open>to_nat a + 1 \<le> to_nat b\<close> to_nat_suc)
   qed
   also have "... = b" by (metis from_nat_to_nat_id)
   finally show "a + (1::'a) \<le> b" .
 qed
 
 lemma le_Suc':
 assumes ab: "a + 1 \<le> b"
   and less_card: "(to_nat a) + 1 < CARD ('a)"
   shows "a < b"
 proof -
   have "a = (from_nat (to_nat a)::'a)" using from_nat_to_nat_id [of "a",symmetric] .
   also have "... < (from_nat (to_nat b)::'a)"
   proof (rule from_nat_mono)
     show "to_nat b < CARD('a)" using bij_to_nat unfolding  bij_betw_def by auto
     have "to_nat (a + 1) \<le>  to_nat b" using ab by (metis to_nat_mono')
     hence "to_nat (a) + 1 \<le>  to_nat b"  using to_nat_suc[OF less_card] by auto
     thus "to_nat a < to_nat b" by simp
   qed
   finally show "a < b" by (metis to_nat_from_nat)
 qed
 
 lemma Suc_le:
   assumes less_card: "(to_nat a) + 1 < CARD ('a)"
   shows "a < a + 1"
 proof -
   have "(to_nat a) < (to_nat a) + 1" by simp
   hence "(to_nat a) < to_nat (a + 1)" by (metis less_card to_nat_suc)
   hence "(from_nat (to_nat a)::'a) < from_nat (to_nat (a + 1))"
     by (rule from_nat_mono, metis less_card to_nat_suc)
   thus "a < a + 1" by (metis to_nat_from_nat)
 qed
 
 lemma Suc_le':
   fixes a::'a
   assumes "a + 1 \<noteq> 0"
   shows "a < a + 1" using Suc_le to_nat_plus_one_less_card assms by blast
 
 lemma from_nat_not_eq:
   assumes a_eq_to_nat: "a \<noteq> to_nat b"
   and a_less_card: "a<CARD('a)"
   shows "from_nat a \<noteq> b"
 proof (rule ccontr)
   assume "\<not> from_nat a \<noteq> b" hence "from_nat a = b" by simp
   hence "to_nat ((from_nat a)::'a) = to_nat b" by auto
   thus False by (metis a_eq_to_nat a_less_card to_nat_from_nat_id)
 qed
 
 lemma Suc_less:
   fixes i::'a
   assumes "i<j"
   and "i+1 \<noteq> j"
   shows "i+1<j" by (metis assms le_Suc le_neq_trans)
 
 
 lemma Greatest_is_minus_1: "\<forall>a::'a. a \<le> -1"
 proof (clarify)
   fix a::'a
   have zero_ge_card_1: "0 \<le> int CARD('a) - 1" using size1 by auto
   have card_less: "int CARD('a) - 1 < int CARD('a)" by auto
   have not_zero: "1 mod int CARD('a) \<noteq> 0"
     by (metis (opaque_lifting, mono_tags) Rep_Abs_1 Rep_mod zero_neq_one)
   have int_card: "int (CARD('a) - 1) = int CARD('a) - 1" using of_nat_diff[of 1 "CARD ('a)"]
     using size1 by simp
   have "a = Abs' (Rep a)" by (metis (opaque_lifting, mono_tags) Rep_0 add_0_right add_def'
       monoid_add_class.add.right_neutral)
   also have "... = Abs' (int (nat (Rep a)))" by (metis Rep_ge_0 int_nat_eq)
   also have "...  \<le> Abs' (int (CARD('a) - 1))"
   proof (rule from_nat_mono'[unfolded from_nat_def o_def, of "nat (Rep a)" "CARD('a) - 1"])
     show "nat (Rep a) \<le> CARD('a) - 1" using Rep_less_n
       using int_card nat_le_iff by auto
     show "CARD('a) - 1 < CARD('a)" using finite_UNIV_card_ge_0 finite_mod_type by fastforce
   qed
   also have "... = - 1"
   unfolding Abs'_def unfolding minus_def zmod_zminus1_eq_if unfolding Rep_1
   apply (rule cong [of Abs], rule refl)
   unfolding if_not_P [OF not_zero]
   unfolding int_card
   unfolding mod_pos_pos_trivial[OF zero_ge_card_1 card_less]
   using mod_pos_pos_trivial[OF _ size1] by presburger
   finally show "a \<le> -1" by fastforce
 qed
 
 lemma a_eq_minus_1: "\<forall>a::'a. a+1 = 0 \<longrightarrow> a = -1"
   by (metis eq_neg_iff_add_eq_0)
 
 
 lemma forall_from_nat_rw:
   shows "(\<forall>x\<in>{0..<CARD('a)}. P (from_nat x::'a)) = (\<forall>x. P (from_nat x))"
 proof (auto)
   fix y assume *: "\<forall>x\<in>{0..<CARD('a)}. P (from_nat x)"
   have "from_nat y \<in> (UNIV::'a set)" by auto
   from this obtain x where x1: "from_nat y = (from_nat x::'a)" and x2: "x\<in>{0..<CARD('a)}"
     using bij_from_nat unfolding bij_betw_def
     by (metis from_nat_to_nat_id rangeI the_inv_into_onto to_nat_is_inv)
   show "P (from_nat y::'a)" unfolding x1 using * x2 by simp
 qed
 
 lemma from_nat_eq_imp_eq:
   assumes f_eq: "from_nat x = (from_nat xa::'a)"
 and x: "x<CARD('a)" and xa: "xa<CARD('a)"
   shows "x=xa" using assms from_nat_not_eq by metis
 
 lemma to_nat_less_card:
   fixes j::"'a"
   shows "to_nat j < CARD ('a)"
   using bij_to_nat unfolding bij_betw_def by auto
 
 lemma from_nat_0: "from_nat 0 = 0"
   unfolding from_nat_def o_def of_nat_0 Abs'_def mod_0 zero_def ..
 lemma to_nat_0: "to_nat 0 = 0" unfolding to_nat_def o_def Rep_0 nat_0 ..
 lemma to_nat_eq_0: "(to_nat x = 0) = (x = 0)"
   by (auto simp add: to_nat_0 from_nat_0 dest: to_nat_from_nat)
 
 lemma suc_not_zero:
   assumes "to_nat a + 1 \<noteq> CARD('a)"
   shows "a+1 \<noteq> 0"
 proof (rule ccontr, simp)
   assume a_plus_one_zero: "a + 1 = 0"
   hence rep_eq_card: "Rep a + 1 = CARD('a)"
     using assms to_nat_0 Suc_eq_plus1 Suc_lessI Zero_not_Suc to_nat_less_card to_nat_suc
     by (metis (opaque_lifting, mono_tags))
   moreover have "Rep a + 1 < CARD('a)"
     using Abs'_0 Rep_1 Suc_eq_plus1 Suc_lessI Suc_neq_Zero add_def' assms
     rep_eq_card to_nat_0 to_nat_less_card to_nat_suc by (metis (opaque_lifting, mono_tags))
   ultimately show False by fastforce
 qed
 
 
 lemma from_nat_suc:
 shows "from_nat (j + 1) = from_nat j + 1"
 unfolding from_nat_def o_def Abs'_def add_def' Rep_1 Rep_Abs_mod
 unfolding of_nat_add apply (subst mod_add_left_eq) unfolding of_nat_1 ..
 
 lemma to_nat_plus_1_set:
 shows "to_nat a + 1 \<in> {1..<CARD('a)+1}"
 using to_nat_less_card by simp
 
 end
 
 lemma from_nat_CARD:
   shows "from_nat (CARD('a)) = (0::'a::{mod_type})"
   unfolding from_nat_def o_def Abs'_def by (simp add: zero_def)
 
 
 subsection\<open>Instantiations\<close>
 
 instantiation bit0 and bit1:: (finite) mod_type
 begin
 
 definition "(Rep::'a bit0 => int)  x = Rep_bit0 x"
 definition "(Abs::int => 'a bit0) x = Abs_bit0' x"
 
 definition "(Rep::'a bit1 => int)  x = Rep_bit1 x"
 definition "(Abs::int => 'a bit1) x = Abs_bit1' x"
 
 instance
 proof
   show "(0::'a bit0) = Abs (0::int)" unfolding Abs_bit0_def Abs_bit0'_def zero_bit0_def by auto
   show "(1::int) < int CARD('a bit0)" by (metis bit0.size1)
   show "type_definition (Rep::'a bit0 => int) (Abs:: int => 'a bit0) {0::int..<int CARD('a bit0)}"
   proof (unfold type_definition_def Rep_bit0_def [abs_def]
       Abs_bit0_def [abs_def] Abs_bit0'_def, intro conjI)
     show "\<forall>x::'a bit0. Rep_bit0 x \<in> {0::int..<int CARD('a bit0)}"
       unfolding card_bit0 unfolding of_nat_mult
       using Rep_bit0 [where ?'a = "'a"] by simp
     show "\<forall>x::'a bit0. Abs_bit0 (Rep_bit0 x mod int CARD('a bit0)) = x"
       by (metis Rep_bit0_inverse bit0.Rep_mod)
     show "\<forall>y::int. y \<in> {0::int..<int CARD('a bit0)}
       \<longrightarrow> Rep_bit0 ((Abs_bit0::int => 'a bit0) (y mod int CARD('a bit0))) = y"
       by (metis bit0.Abs_inverse bit0.Rep_mod)
   qed
   show "(1::'a bit0) = Abs (1::int)" unfolding Abs_bit0_def Abs_bit0'_def one_bit0_def
     by (metis bit0.of_nat_eq of_nat_1 one_bit0_def)
   fix x y :: "'a bit0"
   show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit0))"
     unfolding Abs_bit0_def Rep_bit0_def plus_bit0_def Abs_bit0'_def by fastforce
   show "x * y = Abs (Rep x * Rep y mod int CARD('a bit0))"
     unfolding Abs_bit0_def Rep_bit0_def times_bit0_def Abs_bit0'_def by fastforce
   show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit0))"
     unfolding Abs_bit0_def Rep_bit0_def minus_bit0_def Abs_bit0'_def by fastforce
   show "- x = Abs (- Rep x mod int CARD('a bit0))"
     unfolding Abs_bit0_def Rep_bit0_def uminus_bit0_def Abs_bit0'_def by fastforce
   show "(0::'a bit1) = Abs (0::int)" unfolding Abs_bit1_def Abs_bit1'_def zero_bit1_def by auto
   show "(1::int) < int CARD('a bit1)" by (metis bit1.size1)
   show "(1::'a bit1) = Abs (1::int)" unfolding Abs_bit1_def Abs_bit1'_def one_bit1_def
     by (metis bit1.of_nat_eq of_nat_1 one_bit1_def)
   fix x y :: "'a bit1"
   show "x + y = Abs ((Rep x + Rep y) mod int CARD('a bit1))"
     unfolding Abs_bit1_def Abs_bit1'_def Rep_bit1_def plus_bit1_def by fastforce
   show "x * y = Abs (Rep x * Rep y mod int CARD('a bit1))"
     unfolding Abs_bit1_def Rep_bit1_def times_bit1_def Abs_bit1'_def by fastforce
   show "x - y = Abs ((Rep x - Rep y) mod int CARD('a bit1))"
     unfolding Abs_bit1_def Rep_bit1_def minus_bit1_def Abs_bit1'_def by fastforce
   show "- x = Abs (- Rep x mod int CARD('a bit1))"
     unfolding Abs_bit1_def Rep_bit1_def uminus_bit1_def Abs_bit1'_def by fastforce
   show "type_definition (Rep::'a bit1 => int) (Abs:: int => 'a bit1) {0::int..<int CARD('a bit1)}"
   proof (unfold type_definition_def Rep_bit1_def [abs_def]
       Abs_bit1_def [abs_def] Abs_bit1'_def, intro conjI)
     have int_2: "int 2 = 2" by auto
    show "\<forall>x::'a bit1. Rep_bit1 x \<in> {0::int..<int CARD('a bit1)}"
       unfolding card_bit1
       unfolding of_nat_Suc of_nat_mult
       using Rep_bit1 [where ?'a = "'a"]
       unfolding int_2 ..
    show "\<forall>x::'a bit1. Abs_bit1 (Rep_bit1 x mod int CARD('a bit1)) = x"
       by (metis Rep_bit1_inverse bit1.Rep_mod)
    show "\<forall>y::int. y \<in> {0::int..<int CARD('a bit1)}
     \<longrightarrow> Rep_bit1 ((Abs_bit1::int => 'a bit1) (y mod int CARD('a bit1))) = y"
    by (metis bit1.Abs_inverse bit1.Rep_mod)
   qed
   show "strict_mono (Rep::'a bit0 => int)" unfolding strict_mono_def
     by (metis Rep_bit0_def less_bit0_def)
   show "strict_mono (Rep::'a bit1 => int)" unfolding strict_mono_def
     by (metis Rep_bit1_def less_bit1_def)
 qed
 end
 
 end
-
-
diff --git a/thys/SumSquares/FourSquares.thy b/thys/SumSquares/FourSquares.thy
--- a/thys/SumSquares/FourSquares.thy
+++ b/thys/SumSquares/FourSquares.thy
@@ -1,461 +1,461 @@
 (*  Title:      FourSquares.thy
     Author:     Roelof Oosterhuis, 2007  Rijksuniversiteit Groningen
 *)
 
 section \<open>Lagrange's four-square theorem\<close>
 
 theory FourSquares
   imports "HOL-Number_Theory.Number_Theory"
 begin
 
 context
 
   fixes sum4sq_nat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   defines "sum4sq_nat a b c d \<equiv> a^2+b^2+c^2+d^2"
   
   fixes is_sum4sq_nat :: "nat \<Rightarrow> bool"
   defines "is_sum4sq_nat n \<equiv> (\<exists> a b c d. n = sum4sq_nat a b c d)"
   
 begin
 
 (* TODO: move this lemma to the distribution (?). (It is used also in QuadForm and TwoSquares) *)
 private lemma best_division_abs: "(n::int) > 0 \<Longrightarrow> \<exists> k. 2 * \<bar>a - k*n\<bar> \<le> n"
 proof -
   assume a: "n > 0"
   define k where "k = a div n"
   have h: "a - k * n = a mod n" by (simp add: div_mult_mod_eq algebra_simps k_def)
   thus ?thesis
   proof (cases "2 * (a mod n) \<le> n")
     case True
     hence "2 * \<bar>a - k*n\<bar> \<le> n" using h pos_mod_sign a by auto
     thus ?thesis by blast
   next
     case False
     hence "2 * (n - a mod n) \<le> n" by auto
     have "a - (k+1)*n = a mod n - n" using h by (simp add: algebra_simps)
     hence "2 * \<bar>a - (k+1)*n\<bar> \<le> n" using h pos_mod_bound[of n a] a False by fastforce
     thus ?thesis by blast
   qed
 qed
 
 text \<open>Shows that all nonnegative integers can be written as the sum of four squares. The proof consists of the following steps:
 \begin{itemize}\item For every prime $p=2n+1$ the two sets of residue classes $$\{x^2 \bmod p\mid 0\le x\le n\} ~{\rm and}~ \{-1-y^2 \bmod p \mid 0 \le y \le n\}$$ both contain $n+1$ different elements and therefore they must have at least one element in common.
 \item Hence there exist $x,y$ such that $x^2+y^2+1^2+0^2$ is a multiple of $p$.
 \item The next step is to show, by an infinite descent, that $p$ itself can be written as the sum of four squares.
 \item Finally, using the multiplicity of this form, the same holds for all positive numbers.
 \end{itemize}\<close>
 
 private definition
   sum4sq_int :: "int \<times> int \<times> int \<times> int \<Rightarrow> int" where
   "sum4sq_int = (\<lambda>(a,b,c,d). a^2+b^2+c^2+d^2)"
 
 private definition
   is_sum4sq_int :: "int \<Rightarrow> bool" where
   "is_sum4sq_int n \<longleftrightarrow> (\<exists> a b c d. n = sum4sq_int(a,b,c,d))"
 
 private lemma mult_sum4sq_int: "sum4sq_int(a,b,c,d) * sum4sq_int(p,q,r,s) =
   sum4sq_int(a*p+b*q+c*r+d*s, a*q-b*p-c*s+d*r,
          a*r+b*s-c*p-d*q, a*s-b*r+c*q-d*p)"
   by (unfold sum4sq_int_def, simp add: eval_nat_numeral field_simps)
 
 private lemma sum4sq_int_nat_eq: "sum4sq_nat a b c d = sum4sq_int (a, b, c, d)"
   unfolding sum4sq_nat_def sum4sq_int_def by simp
 
 private lemma is_sum4sq_int_nat_eq: "is_sum4sq_nat n = is_sum4sq_int (int n)"
   unfolding is_sum4sq_nat_def is_sum4sq_int_def
 proof
   assume "\<exists>a b c d. n = sum4sq_nat a b c d"
   thus "\<exists>a b c d. int n = sum4sq_int (a, b, c, d)" using sum4sq_int_nat_eq by force
 next
   assume "\<exists>a b c d. int n = sum4sq_int (a, b, c, d)"
   then obtain a b c d where "int n = sum4sq_int (a, b, c, d)" by blast
   hence "int n = sum4sq_int (int (nat \<bar>a\<bar>), int (nat \<bar>b\<bar>), int (nat \<bar>c\<bar>), int (nat \<bar>d\<bar>))"
     unfolding sum4sq_int_def by simp
   hence "int n = int (sum4sq_nat (nat \<bar>a\<bar>) (nat \<bar>b\<bar>) (nat \<bar>c\<bar>) (nat \<bar>d\<bar>))"
     using sum4sq_int_nat_eq by presburger
   thus "\<exists>a b c d. n = sum4sq_nat a b c d" by auto
 qed
 
 private lemma is_mult_sum4sq_int: "is_sum4sq_int x \<Longrightarrow> is_sum4sq_int y \<Longrightarrow> is_sum4sq_int (x*y)"
   by (unfold is_sum4sq_int_def, auto simp only: mult_sum4sq_int, blast)
 
 private lemma is_mult_sum4sq_nat: "is_sum4sq_nat x \<Longrightarrow> is_sum4sq_nat y \<Longrightarrow> is_sum4sq_nat (x*y)"
   using is_mult_sum4sq_int is_sum4sq_int_nat_eq by simp
 
 private lemma mult_oddprime_is_sum4sq: "\<lbrakk> prime (nat p); odd p \<rbrakk> \<Longrightarrow>
   \<exists> t. 0<t \<and> t<p \<and> is_sum4sq_int (p*t)"
 proof -
   assume p1: "prime (nat p)"
   then have p0: "p > 1" and "prime p"
     by (simp_all add: prime_int_nat_transfer prime_nat_iff)
   assume p2: "odd p"
   then obtain n where n: "p = 2*n+1" using oddE by blast
   with p1 have n0: "n > 0" by (auto simp add: prime_nat_iff)
   let ?C = "{0 ..< p}"
   let ?D = "{0 .. n}"
   let ?f = "%x. x^2 mod p"
   let ?g = "%x. (-1-x^2) mod p"
   let ?A = "?f ` ?D"
   let ?B = "?g ` ?D"
   have finC: "finite ?C" by simp
   have finD: "finite ?D" by simp
   from p0 have AsubC: "?A \<subseteq> ?C" and BsubC: "?B \<subseteq> ?C"
-    by (auto simp add: pos_mod_conj)
+    by auto
   with finC have finA: "finite ?A" and finB: "finite ?B"
     by (auto simp add: finite_subset)
   from AsubC BsubC have AunBsubC: "?A \<union> ?B \<subseteq> ?C" by (rule Un_least)
   from p0 have cardC: "card ?C = nat p" using card_atLeastZeroLessThan_int by blast
   from n0 have cardD: "card ?D = 1+ nat n" by simp
   have cardA: "card ?A = card ?D"
   proof -
     have "inj_on ?f ?D"
     proof (unfold inj_on_def, auto)
       fix x fix y
       assume x0: "0 \<le> x" and xn: "x \<le> n" and y0: "0 \<le> y" and yn: " y \<le> n"
         and xyp: "x^2 mod p = y^2 mod p"
       with p0 have "[x^2 = y^2] (mod p)" using cong_def by blast
       hence "p dvd x^2-y^2" using cong_iff_dvd_diff by blast
       hence "p dvd (x+y)*(x-y)" by (simp add: power2_eq_square algebra_simps)
       hence "p dvd x+y \<or> p dvd x-y" using \<open>prime p\<close> p0 
         by (auto dest: prime_dvd_multD)
       moreover
       { assume "p dvd x+y"
         moreover from xn yn n have "x+y < p" by auto
         ultimately have "\<not> x+y > 0" by (auto simp add: zdvd_not_zless)
         with x0 y0 have "x = y" by auto } \<comment> \<open>both are zero\<close>
       moreover
       { assume ass: "p dvd x-y"
         have "x = y"
         proof (rule ccontr, case_tac "x-y \<ge> 0")
           assume "x-y \<ge> 0" and "x \<noteq> y" hence "x-y > 0" by auto
           with ass have "\<not> x-y < p" by (auto simp add: zdvd_not_zless)
           with xn y0 n p0 show "False" by auto
         next
           assume "\<not> 0 \<le> x-y" hence "y-x > 0" by auto
           moreover from x0 yn n p0 have "y-x < p" by auto
           ultimately have "\<not> p dvd y-x" by (auto simp add: zdvd_not_zless)
           moreover from ass have "p dvd -(x-y)" by (simp only: dvd_minus_iff)
           ultimately show "False" by auto
         qed }
       ultimately show "x=y" by auto
     qed
     with finD show ?thesis by (simp only: inj_on_iff_eq_card)
   qed
   have cardB: "card ?B = card ?D"
   proof -
     have "inj_on ?g ?D"
     proof (unfold inj_on_def, auto)
       fix x fix y
       assume x0: "0 \<le> x" and xn: "x \<le> n" and y0: "0 \<le> y" and yn: " y \<le> n"
         and xyp: "(-1-x^2) mod p = (-1-y^2) mod p"
       with p0 have "[-1-y^2 = -1-x^2] (mod p)" by (simp only: cong_def)
       hence "p dvd (-1-y^2) - (-1-x^2)" by (simp only: cong_iff_dvd_diff)
       moreover have "-1-y^2 - (-1-x^2) = x^2 - y^2" by arith
       ultimately have "p dvd x^2-y^2" by simp
       hence "p dvd (x+y)*(x-y)" by (simp add: power2_eq_square algebra_simps)
       with p1 have "p dvd x+y \<or> p dvd x-y" using \<open>prime p\<close> p0 
         by (auto dest: prime_dvd_multD)
       moreover
       { assume "p dvd x+y"
         moreover from xn yn n have "x+y < p" by auto
         ultimately have "\<not> x+y > 0" by (auto simp add: zdvd_not_zless)
         with x0 y0 have "x = y" by auto } \<comment> \<open>both are zero\<close>
       moreover
       { assume ass: "p dvd x-y"
         have "x = y"
         proof (rule ccontr, case_tac "x-y \<ge> 0")
           assume "x-y \<ge> 0" and "x \<noteq> y" hence "x-y > 0" by auto
           with ass have "\<not> x-y < p" by (auto simp add: zdvd_not_zless)
           with xn y0 n p0 show "False" by auto
         next
           assume "\<not> 0 \<le> x-y" hence "y-x > 0" by auto
           moreover from x0 yn n p0 have "y-x < p" by auto
           ultimately have "\<not> p dvd y-x" by (auto simp add: zdvd_not_zless)
           moreover from ass have "p dvd -(x-y)" by (simp only: dvd_minus_iff)
           ultimately show "False" by auto
         qed }
       ultimately show "x=y" by auto
     qed
     with finD show ?thesis by (simp only: inj_on_iff_eq_card)
   qed
   have "?A \<inter> ?B \<noteq> {}"
   proof (rule ccontr, auto)
     assume ABdisj: "?A \<inter> ?B = {}"
     from cardA cardB cardD have "2 + 2*(nat n) = card ?A + card ?B" by auto
     also with finA finB ABdisj have "\<dots> = card (?A \<union> ?B)"
       by (simp only: card_Un_disjoint)
     also with finC AunBsubC have "\<dots> \<le> card ?C" by (simp only: card_mono)
     also with cardC have "\<dots> = nat p" by simp
     finally have "2 + 2*(nat n) \<le> nat p" by simp
     with n show "False" by arith
   qed
   then obtain z where "z \<in> ?A \<and> z \<in> ?B" by auto
   then obtain x y where xy: "x \<in> ?D \<and> y \<in> ?D \<and> z = x^2 mod p \<and> z = (-1-y^2) mod p" by blast
   with p0 have "[x^2=-1-y^2](mod p)" by (simp add: cong_def)
   hence "p dvd x^2-(-1-y^2)" by (simp only: cong_iff_dvd_diff)
   moreover have "x^2-(-1-y^2)=x^2+y^2+1" by arith
   ultimately have "p dvd sum4sq_int(x,y,1,0)" by (auto simp add: sum4sq_int_def)
   then obtain t where t: "p * t = sum4sq_int(x,y,1,0)" by (auto simp only: dvd_def eq_refl)
   hence "is_sum4sq_int (p*t)" by (unfold is_sum4sq_int_def, auto)
   moreover have "t > 0 \<and> t < p"
   proof
     have "x^2 \<ge> 0 \<and> y^2 \<ge> 0" by simp
     hence "x^2+y^2+1 > 0" by arith
     with t have "p*t > 0" by (unfold sum4sq_int_def, auto)
     moreover
     { assume "t < 0" with p0 have "p*t < p*0" by (simp only: zmult_zless_mono2)
       hence "p*t < 0" by simp }
     moreover
     { assume "t = 0" hence "p*t = 0" by simp }
     ultimately have "\<not> t < 0 \<and> t \<noteq> 0" by auto
     thus "t > 0" by simp
     from xy have "x^2 \<le> n^2 \<and> y^2 \<le> n^2" by (auto simp add: power_mono)
     hence "x^2+y^2+1 \<le> 2*n^2 + 1" by auto
     with t have contr: "p*t \<le> 2*n^2+1" by (simp add: sum4sq_int_def)
     moreover
     { assume "t > n+1"
       with p0 have "p*(n+1) < p*t" by (simp only: zmult_zless_mono2)
       with n have "p*t > (2*n+1)*n + (2*n+1)*1" by (simp only: distrib_left)
       hence "p*t > 2*n*n + n + 2*n + 1" by (simp only: distrib_right mult_1_left)
       with n0 have "p*t > 2*n^2 + 1" by (simp add: power2_eq_square) }
     ultimately have "\<not> t > n+1" by auto
     with n0 n show "t < p" by auto
   qed
   ultimately show ?thesis by blast
 qed
 
 private lemma zprime_is_sum4sq: "prime (nat p) \<Longrightarrow> is_sum4sq_int p"
 proof (cases)
   assume p2: "p=2"
   hence "p = sum4sq_int(1,1,0,0)" by (auto simp add: sum4sq_int_def)
   thus ?thesis by (auto simp add: is_sum4sq_int_def)
 next
   assume "\<not> p =2" and prp: "prime (nat p)"
   hence "\<not> nat p = 2" by simp
   with prp have "2 < nat p" using prime_nat_iff by force
   moreover with prp have "odd (nat p)" using prime_odd_nat[of "nat p"] by blast
   ultimately have "odd p" by (simp add: even_nat_iff)
   with prp have "\<exists> t. 0<t \<and> t<p \<and> is_sum4sq_int (p*t)" by (rule mult_oddprime_is_sum4sq)
   then obtain a b c d t where pt_sol: "0<t \<and> t<p \<and> p*t = sum4sq_int(a,b,c,d)"
     by (unfold is_sum4sq_int_def, blast)
   hence Qt: "0<t \<and> t<p \<and> (\<exists> a1 a2 a3 a4. p*t = sum4sq_int(a1,a2,a3,a4))"
     (is "?Q t") by blast
   have "?Q 1"
   proof (rule ccontr)
     assume nQ1: "\<not> ?Q 1"
     have "\<not> ?Q t"
     proof (induct t rule: infinite_descent0_measure[where V="\<lambda>x. (nat x)- 1"], clarify)
       fix x a b c d
       assume "nat x - 1 = 0" and "x > 0" and s: "p*x=sum4sq_int(a,b,c,d)" and "x < p"
       moreover hence "x = 1" by arith
       ultimately have "?Q 1" by auto
       with nQ1 show False by auto
     next
       fix x
       assume "0 < nat x - 1" and "\<not> \<not> ?Q x"
       then obtain a1 a2 a3 a4 where ass: "1<x \<and> x<p \<and> p*x = sum4sq_int(a1,a2,a3,a4)"
         by auto
       have "\<exists> y. nat y - 1 < nat x - 1 \<and> ?Q y"
       proof (cases)
         assume evx: "even x"
         hence "even (x*p)" by simp
         with ass have ev1234: "even (a1^2+a2^2 + a3^2+a4^2)"
           by (auto simp add: sum4sq_int_def ac_simps)
         have "\<exists> b1 b2 b3 b4. p*x=sum4sq_int(b1,b2,b3,b4) \<and> even (b1+b2) \<and> even (b3+b4)"
         proof (cases)
           assume ev12: "even (a1^2+a2^2)"
           with ev1234 ass show ?thesis by auto
         next
           assume "\<not> even (a1^2+a2^2)"
           hence odd12: "odd (a1^2+a2^2)" by simp
           with ev1234 have odd34: "odd (a3^2+a4^2)" by auto
           show ?thesis
           proof (cases)
             assume ev1: "even (a1^2)"
             with odd12 have odd2: "odd (a2^2)" by simp
             show ?thesis
             proof (cases)
               assume "even (a3^2)"
               moreover from ass have "p*x = sum4sq_int(a1,a3,a2,a4)" by (auto simp add: sum4sq_int_def)
               ultimately show ?thesis using odd2 odd34 ev1 by auto
             next
               assume "\<not> even (a3^2)"
               moreover from ass have "p*x = sum4sq_int(a1,a4,a2,a3)" by (auto simp add: sum4sq_int_def)
               ultimately show ?thesis using odd34 odd2 ev1 by auto
             qed
           next
             assume odd1: "\<not> even (a1^2)"
             with odd12 have ev2: "even (a2^2)" by simp
             show ?thesis
             proof (cases)
               assume "even (a3^2)"
               moreover from ass have "sum4sq_int(a1,a4,a2,a3)=p*x" by (auto simp add: sum4sq_int_def)
               ultimately show ?thesis using odd34 odd1 ev2 by force
             next
               assume "\<not> even (a3^2)"
               moreover from ass have "sum4sq_int(a1,a3,a2,a4)=p*x" by (auto simp add: sum4sq_int_def)
               ultimately show ?thesis using odd34 odd1 ev2 by force
             qed
           qed
         qed
         then obtain b1 b2 b3 b4
           where b: "p*x = sum4sq_int(b1,b2,b3,b4) \<and> even (b1+b2) \<and> even (b3+b4)" by auto
         then obtain c1 c3 where c13: "b1+b2 = 2*c1 \<and> b3+b4 = 2*c3"
           using evenE[of "b1+b2"] evenE[of "b3+b4"] by meson
         from b have "even (b1-b2) \<and> even (b3-b4)" by simp
         then obtain c2 c4 where c24: "b1-b2 = 2*c2 \<and> b3-b4 = 2*c4"
           using evenE[of "b1-b2"] evenE[of "b3-b4"] by meson
         from evx obtain y where y: "x = 2*y" using evenE by blast
         hence "4*(p*y) = 2*(p*x)" by (simp add: ac_simps)
         also from b have "\<dots> = 2*b1^2 + 2*b2^2 + 2*b3^2 + 2*b4^2"
           by (auto simp: sum4sq_int_def)
         also have "\<dots> = (b1 + b2)^2 + (b1 - b2)^2 + (b3 + b4)^2 + (b3 - b4)^2"
           by (auto simp add: power2_eq_square algebra_simps)
         also with c13 c24 have "\<dots> = 4*(c1^2 + c2^2 + c3^2 + c4^2)"
           by (auto simp add: power_mult_distrib)
         finally have "p * y = sum4sq_int(c1,c2,c3,c4)" by (auto simp add: sum4sq_int_def)
         moreover from y ass have "0 < y \<and> y < p \<and> (nat y) - 1 < (nat x) - 1" by arith
         ultimately show ?thesis by blast
       next
         assume xodd: "\<not> even x"
         with ass have "\<exists> c1 c2 c3 c4. 2*\<bar>a1-c1*x\<bar>\<le>x \<and> 2*\<bar>a2-c2*x\<bar>\<le>x \<and> 2*\<bar>a3-c3*x\<bar>\<le>x \<and> 2*\<bar>a4-c4*x\<bar>\<le>x"
           by (simp add: best_division_abs)
         then obtain b1 c1 b2 c2 b3 c3 b4 c4 where
           bc_def: "b1 = a1-c1*x \<and> b2 = a2-c2*x \<and> b3 = a3-c3*x \<and> b4 = a4-c4*x"
           and "2*\<bar>b1\<bar>\<le>x \<and> 2*\<bar>b2\<bar>\<le>x \<and> 2*\<bar>b3\<bar>\<le>x \<and> 2*\<bar>b4\<bar>\<le>x"
           by blast
         moreover have "2*\<bar>b1\<bar>\<noteq>x \<and> 2*\<bar>b2\<bar>\<noteq>x \<and> 2*\<bar>b3\<bar>\<noteq>x \<and> 2*\<bar>b4\<bar>\<noteq>x" using xodd by fastforce
         ultimately have bc_abs: "2*\<bar>b1\<bar><x \<and> 2*\<bar>b2\<bar><x \<and> 2*\<bar>b3\<bar><x \<and> 2*\<bar>b4\<bar><x" by auto
         let ?B = "b1^2 + b2^2 + b3^2 + b4^2"
         let ?C = "c1^2 + c2^2 + c3^2 + c4^2"
         have "x dvd ?B"
         proof
           from bc_def ass have
             "?B = p*x - 2*(a1*c1+a2*c2+a3*c3+a4*c4)*x + ?C*x^2"
             unfolding sum4sq_int_def by (auto simp add: power2_eq_square algebra_simps)
           thus "?B = x*(p - 2*(a1*c1+a2*c2+a3*c3+a4*c4) + ?C*x)"
             by (auto simp add: ac_simps power2_eq_square
               distrib_left right_diff_distrib)
         qed
         then obtain y where y: "?B = x * y" by (auto simp add: dvd_def)
         let ?A1 = "a1*b1 + a2*b2 + a3*b3 + a4*b4"
         let ?A2 = "a1*b2 - a2*b1 - a3*b4 + a4*b3"
         let ?A3 = "a1*b3 + a2*b4 - a3*b1 - a4*b2"
         let ?A4 = "a1*b4 - a2*b3 + a3*b2 - a4*b1"
         let ?A = "sum4sq_int(?A1,?A2,?A3,?A4)"
         have "x dvd ?A1 \<and> x dvd ?A2 \<and> x dvd ?A3 \<and> x dvd ?A4"
         proof (safe)
           from bc_def have
             "?A1 = (b1+c1*x)*b1 + (b2+c2*x)*b2 + (b3+c3*x)*b3 + (b4+c4*x)*b4"
             by simp
           also with y have "\<dots> = x*(y + c1*b1 + c2*b2 + c3*b3 + c4*b4)"
             by (auto simp add: distrib_left power2_eq_square ac_simps)
           finally show "x dvd ?A1" by auto
           from bc_def have
             "?A2 = (b1+c1*x)*b2 - (b2+c2*x)*b1 - (b3+c3*x)*b4 + (b4+c4*x)*b3"
             by simp
           also have "\<dots> = x*(c1*b2 - c2*b1 - c3*b4 + c4*b3)"
             by (auto simp add: distrib_left right_diff_distrib ac_simps)
           finally show "x dvd ?A2" by auto
           from bc_def have
             "?A3 = (b1+c1*x)*b3 + (b2+c2*x)*b4 - (b3+c3*x)*b1 - (b4+c4*x)*b2"
             by simp
           also have "\<dots> = x*(c1*b3 + c2*b4 - c3*b1 - c4*b2)"
             by (auto simp add: distrib_left right_diff_distrib ac_simps)
           finally show "x dvd ?A3" by auto
           from bc_def have
             "?A4 = (b1+c1*x)*b4 - (b2+c2*x)*b3 + (b3+c3*x)*b2 - (b4+c4*x)*b1"
             by simp
           also have "\<dots> = x*(c1*b4 - c2*b3 + c3*b2 - c4*b1)"
             by (auto simp add: distrib_left right_diff_distrib ac_simps)
           finally show "x dvd ?A4" by auto
         qed
         then obtain d1 d2 d3 d4 where d:
           "?A1=x*d1 \<and> ?A2=x*d2 \<and> ?A3=x*d3 \<and> ?A4=x*d4"
           by (auto simp add: dvd_def)
         let ?D = "sum4sq_int(d1,d2,d3,d4)"
         from d have "x^2*?D = ?A"
           by (auto simp only: sum4sq_int_def power_mult_distrib distrib_left)
         also have "\<dots> = sum4sq_int(a1,a2,a3,a4)*sum4sq_int(b1,b2,b3,b4)"
           by (simp only: mult_sum4sq_int)
         also with y ass have "\<dots> = (p*x)*(x*y)" by (auto simp add: sum4sq_int_def)
         also have "\<dots> = x^2*(p*y)" by (simp only: power2_eq_square ac_simps)
         finally have "x^2*(?D - p*y) = 0" by (auto simp add: right_diff_distrib)
         with ass have "p*y = ?D" by auto
         moreover have y_l_x: "y < x"
         proof -
           have "4*b1^2 = (2*\<bar>b1\<bar>)^2 \<and> 4*b2^2 = (2*\<bar>b2\<bar>)^2 \<and>
             4*b3^2 = (2*\<bar>b3\<bar>)^2 \<and> 4*b4^2 = (2*\<bar>b4\<bar>)^2" by simp
           with bc_abs have "4*b1^2<x^2 \<and> 4*b2^2<x^2 \<and> 4*b3^2<x^2 \<and> 4*b4^2<x^2"
             using power_strict_mono [of "2*\<bar>b\<bar>" x 2 for b]
             by auto
           hence "?B < x^2" by auto
           with y have "x*(x-y) > 0"
             by (auto simp add: power2_eq_square right_diff_distrib)
           moreover from ass have "x > 0" by simp
           ultimately show ?thesis using zero_less_mult_pos by fastforce
         qed
         moreover have "y > 0"
         proof -
           have b2pos: "b1^2 \<ge> 0 \<and> b2^2 \<ge> 0 \<and> b3^2 \<ge> 0 \<and> b4^2 \<ge> 0" by simp
           hence "?B = 0 \<or> ?B > 0" by arith
           moreover
           { assume "?B = 0"
             moreover from b2pos have
               "?B-b1^2 \<ge> 0 \<and> ?B-b2^2 \<ge> 0 \<and> ?B-b3^2 \<ge> 0 \<and> ?B-b4^2 \<ge> 0" by arith
             ultimately have "b1^2 \<le> 0 \<and> b2^2 \<le> 0 \<and> b3^2 \<le> 0 \<and> b4^2 \<le> 0" by auto
             with b2pos have  "b1^2 = 0 \<and> b2^2 = 0 \<and> b3^2 = 0 \<and> b4^2 = 0" by arith
             hence "b1 = 0 \<and> b2 = 0 \<and> b3 = 0 \<and> b4 = 0" by auto
             with bc_def have "x dvd a1 \<and> x dvd a2 \<and> x dvd a3 \<and> x dvd a4"
               by auto
             hence "x^2 dvd a1^2 \<and> x^2 dvd a2^2 \<and> x^2 dvd a3^2 \<and> x^2 dvd a4^2" by simp
             hence "x^2 dvd a1^2+a2^2+a3^2+a4^2" by (simp only: dvd_add)
             with ass have "x^2 dvd p*x" by (auto simp only: sum4sq_int_def)
             hence "x*x dvd x*p" by (simp only: power2_eq_square ac_simps)
             with ass have "nat x dvd nat p"
               by (simp add: nat_dvd_iff)
             moreover from ass prp have "x \<ge> 0 \<and> x \<noteq> 1 \<and> x \<noteq> p \<and> prime (nat p)" by simp
             ultimately have "False" unfolding prime_nat_iff by auto }
           moreover
           { assume "?B > 0"
             with y have "x*y > 0" by simp
             moreover from ass have "x > 0" by simp
             ultimately have ?thesis using zero_less_mult_pos by blast }
           ultimately show ?thesis by auto
         qed
         moreover with y_l_x have "(nat y) - 1 < (nat x) - 1" by arith
         moreover from y_l_x ass have "y < p" by auto
         ultimately show ?thesis by blast
       qed
       thus "\<exists> y. nat y - 1 < nat x - 1 \<and> \<not> \<not> ?Q y" by blast
     qed
     with Qt show "False" by simp
   qed
   thus "is_sum4sq_int p" by (auto simp add: is_sum4sq_int_def)
 qed
 
 private lemma prime_is_sum4sq: "prime p \<Longrightarrow> is_sum4sq_nat p"
   using zprime_is_sum4sq is_sum4sq_int_nat_eq by simp
 
 theorem sum_of_four_squares: "is_sum4sq_nat n"
 proof (induction n rule: nat_less_induct)
 case (1 n)
   show ?case
   proof (cases "n>1")
   case False
     hence "n = 0 \<or> n = 1" by auto
     moreover have "0 = sum4sq_nat 0 0 0 0" "1 = sum4sq_nat 1 0 0 0" unfolding sum4sq_nat_def by auto
     ultimately show ?thesis unfolding is_sum4sq_nat_def by blast
   next
   case True
     then obtain p m where dec: "prime p \<and> n = p * m" using prime_factor_nat[of n] 
       by (auto elim: dvdE)
     moreover hence "m<n" using n_less_m_mult_n[of m p] prime_gt_Suc_0_nat[of p] True by linarith
     ultimately have "is_sum4sq_nat m" "is_sum4sq_nat p" using 1 prime_is_sum4sq by blast+
     thus ?thesis using dec is_mult_sum4sq_nat by blast
   qed
 qed
 
 end
 
 end
diff --git a/thys/Valuation/Valuation1.thy b/thys/Valuation/Valuation1.thy
--- a/thys/Valuation/Valuation1.thy
+++ b/thys/Valuation/Valuation1.thy
@@ -1,3900 +1,3901 @@
 (**        Valuation1
                             author Hidetsune Kobayashi
                             Group You Santo
                             Department of Mathematics
                             Nihon University
                             h_coba@math.cst.nihon-u.ac.jp
                             June 24, 2005(revised)
                             July 20, 2007(revised)
 
    chapter 1. elementary properties of a valuation
     section 1. definition of a valuation
     section 2. the normal valuation of v
     section 3. valuation ring
     section 4. ideals in a valuation ring
     section 5. pow of vp and n_value -- convergence --
     section 6. equivalent valuations
     section 7. prime divisors
     section 8. approximation
 
    **)
 
 
 theory Valuation1
 imports  "Group-Ring-Module.Algebra9"
 begin
 
 declare ex_image_cong_iff [simp del]
 
 chapter "Preliminaries"
 
 section "Int and ant (augmented integers)"
 
 lemma int_less_mono:"(a::nat) < b \<Longrightarrow> int a < int b"
 apply simp
 done
 
 lemma zless_trans:"\<lbrakk>(i::int) < j; j < k\<rbrakk> \<Longrightarrow> i < k"
 apply simp
 done
 
 lemma zmult_pos_bignumTr0:"\<exists>L. \<forall>m. L < m \<longrightarrow> z < x + int m"
 by (subgoal_tac "\<forall>m. (nat((abs z) + (abs x))) < m \<longrightarrow> z < x + int m",
        blast, rule allI, rule impI, arith)
 
 lemma zle_less_trans:"\<lbrakk>(i::int) \<le> j; j < k\<rbrakk> \<Longrightarrow> i < k"
 apply (simp add:less_le)
 done
 
 lemma  zless_le_trans:"\<lbrakk>(i::int) < j; j \<le> k\<rbrakk> \<Longrightarrow> i < k"
 apply (simp add:less_le)
 done
 
 lemma zmult_pos_bignumTr:"0 < (a::int) \<Longrightarrow>
                    \<exists>l. \<forall>m. l < m \<longrightarrow> z < x + (int m) * a"
 apply (cut_tac zmult_pos_bignumTr0[of "z" "x"])
  apply (erule exE)
  apply (subgoal_tac "\<forall>m. L < m \<longrightarrow> z < x + int m * a", blast)
 apply (rule allI, rule impI)
  apply (drule_tac a = m in forall_spec, assumption)
  apply (subgoal_tac "0 \<le> int m")
  apply (frule_tac a = "int m" and b = a in pos_zmult_pos, assumption)
  apply (cut_tac order_refl[of "x"])
  apply (frule_tac z' = "int m" and z = "int m * a" in
          zadd_zle_mono[of "x" "x"], assumption+)
  apply (rule_tac y = "x + int m" and z = "x + (int m)* a" in
          less_le_trans[of "z"], assumption+)
  apply simp
 done
 
 lemma  ale_shift:"\<lbrakk>(x::ant)\<le> y; y = z\<rbrakk> \<Longrightarrow> x \<le> z"
 by simp
 
 lemma aneg_na_0[simp]:"a < 0 \<Longrightarrow> na a = 0"
 by (simp add:na_def)
 
 lemma amult_an_an:"an (m * n) = (an m) * (an n)"
 apply (simp add:an_def)
 apply (simp add: of_nat_mult a_z_z)
 done
 
 definition
   adiv :: "[ant, ant] \<Rightarrow> ant" (infixl "adiv" 200) where
   "x adiv y = ant ((tna x) div (tna y))"
 
 definition
   amod :: "[ant, ant] \<Rightarrow> ant" (infixl "amod" 200) where
   "x amod y = ant ((tna x) mod (tna y))"
 
 lemma apos_amod_conj:"0 < ant b \<Longrightarrow>
                   0 \<le> (ant a) amod (ant b) \<and> (ant a) amod (ant b) < (ant b)"
 by (simp add:amod_def tna_ant, simp only:ant_0[THEN sym],
        simp add:aless_zless)
 
 lemma  amod_adiv_equality:
        "(ant a) = (a div b) *\<^sub>a (ant b) + ant (a mod b)"
 apply (simp add:adiv_def tna_ant a_z_z a_zpz  asprod_mult)
 done
 
 lemma asp_z_Z:"z *\<^sub>a ant x \<in> Z\<^sub>\<infinity>"
 by (simp add:asprod_mult z_in_aug_inf)
 
 lemma apos_in_aug_inf:"0 \<le> a \<Longrightarrow> a \<in> Z\<^sub>\<infinity>"
 by (simp add:aug_inf_def, rule contrapos_pp, simp+,
     cut_tac minf_le_any[of "0"], frule ale_antisym[of "0" "-\<infinity>"],
     assumption+, simp)
 
 lemma  amult_1_both:"\<lbrakk>0 < (w::ant); x * w = 1\<rbrakk> \<Longrightarrow> x = 1 \<and> w = 1"
 apply (cut_tac mem_ant[of "x"], cut_tac mem_ant[of "w"],
       (erule disjE)+, simp,
       (frule sym, thin_tac "\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1))
 apply (erule disjE, erule exE, simp,
        (frule sym, thin_tac "-\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1), simp)
 apply (frule sym, thin_tac "-\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1)
 apply ((erule disjE)+, erule exE, simp,
        frule_tac aless_imp_le[of "0" "-\<infinity>"],
        cut_tac minf_le_any[of "0"],
        frule ale_antisym[of "0" "-\<infinity>"], assumption+,
        simp only:ant_0[THEN sym], simp,
        frule sym, thin_tac "-\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1)
 apply ((erule disjE)+, (erule exE)+, simp only:ant_1[THEN sym],
        simp del:ant_1 add:a_z_z,
        (cut_tac a = z and b = za in mult.commute, simp,
         cut_tac z = za and z' = z in  times_1_both, assumption+),
        simp)
 apply (erule exE, simp,
        cut_tac x = z and y = 0 in less_linear, erule disjE, simp,
        frule sym, thin_tac "-\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1,
        erule disjE, simp add:ant_0, simp,
        frule sym, thin_tac "\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1,
        erule disjE, erule exE, simp,
        frule sym, thin_tac "\<infinity> = 1", simp only:ant_1[THEN sym],
        simp del:ant_1, simp)
 done
 
 lemma poss_int_neq_0:"0 < (z::int) \<Longrightarrow> z \<noteq> 0"
 by simp
 
 lemma aadd_neg_negg[simp]:"\<lbrakk>a \<le> (0::ant); b < 0\<rbrakk> \<Longrightarrow> a + b < 0"
 apply (frule ale_minus[of "a" "0"], simp,
        frule aless_minus[of "b" "0"], simp)
 apply (frule aadd_pos_poss[of "-a" "-b"], assumption+,
        simp add:aminus_add_distrib[THEN sym, of "a" "b"],
        frule aless_minus[of "0" "-(a + b)"], simp add:a_minus_minus)
 done
 
 lemma aadd_two_negg[simp]:"\<lbrakk>a < (0::ant); b < 0\<rbrakk> \<Longrightarrow> a + b < 0"
 by auto
 
 lemma amin_aminTr:"(z::ant) \<le> z' \<Longrightarrow> amin z w \<le> amin z' w"
 by (simp add:amin_def)
 
 lemma amin_le1:"(z::ant) \<le> z' \<Longrightarrow> (amin z w) \<le> z'"
 by (simp add:amin_def, simp add:aneg_le,
        rule impI, frule aless_le_trans[of "w" "z" "z'"],
        assumption+, simp add:aless_imp_le)
 
 lemma amin_le2:"(z::ant) \<le> z' \<Longrightarrow> (amin w z) \<le> z'"
 by (simp add:amin_def, rule impI,
        frule ale_trans[of "w" "z" "z'"], assumption+)
 
 lemma  Amin_geTr:"(\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>j \<le> n. z \<le> (f j)) \<longrightarrow>
                                  z \<le> (Amin n f)"
 apply (induct_tac n)
  apply (rule impI, erule conjE, simp)
 apply (rule impI, (erule conjE)+,
        cut_tac Nsetn_sub_mem1[of n], simp,
        drule_tac x = "Suc n" in spec, simp,
        rule_tac z = z and x = "Amin n f" and y = "f(Suc n)" in amin_ge1,
        simp+)
 done
 
 lemma Amin_ge:"\<lbrakk>\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity>; \<forall>j \<le> n. z \<le> (f j)\<rbrakk> \<Longrightarrow>
                              z \<le> (Amin n f)"
 by (simp add:Amin_geTr)
 
 definition
   Abs :: "ant \<Rightarrow> ant" where
   "Abs z = (if z < 0 then -z else z)"
 
 lemma Abs_pos:"0 \<le> Abs z"
 by (simp add:Abs_def, rule conjI, rule impI,
        cut_tac aless_minus[of "z" "0"], simp,
        assumption,
        rule impI, simp add:aneg_less[of "z" "0"])
 
 lemma Abs_x_plus_x_pos:"0 \<le> (Abs x) + x"
 apply (case_tac "x < 0",
        simp add:Abs_def, simp add:aadd_minus_inv)
 
 apply (simp add:aneg_less,
        simp add:Abs_def, simp add:aneg_less[THEN sym, of "0" "x"],
        simp add:aneg_less[of "x" "0"], simp add:aadd_two_pos)
 done
 
 lemma  Abs_ge_self:"x \<le> Abs x"
 apply (simp add:Abs_def, rule impI,
        cut_tac ale_minus[of "x" "0"],
        simp add:aminus_0, simp add:aless_imp_le)
 done
 
 lemma  na_1:"na 1 = Suc 0"
 apply (simp only:ant_1[THEN sym], simp only:na_def,
        simp only:ant_0[THEN sym], simp only:aless_zless[of "1" "0"],
        simp, subgoal_tac "\<infinity> \<noteq> 1", simp)
 apply (simp only:ant_1[THEN sym], simp only:tna_ant,
        rule not_sym, simp only:ant_1[THEN sym], simp del:ant_1)
 done
 
 lemma ant_int:"ant (int n) = an n"
 by (simp add:an_def)
 
 lemma int_nat:"0 < z \<Longrightarrow> int (nat z) = z"
 by arith
 
 lemma int_ex_nat:"0 < z \<Longrightarrow> \<exists>n. int n = z"
 by (cut_tac int_nat[of z], blast, assumption)
 
 lemma eq_nat_pos_ints:
   "\<lbrakk>nat (z::int) = nat (z'::int); 0 \<le> z; 0 \<le> z'\<rbrakk> \<Longrightarrow> z = z'"
 by simp
 
 lemma a_p1_gt[simp]:"\<lbrakk>a \<noteq> \<infinity>; a \<noteq> -\<infinity>\<rbrakk>  \<Longrightarrow> a < a + 1"
 apply (cut_tac aadd_poss_less[of a 1],
        simp add:aadd_commute, assumption+)
 apply (cut_tac zposs_aposss[of 1], simp)
 done
 
 lemma  gt_na_poss:"(na a) < m \<Longrightarrow> 0 < m"
 apply (simp add:na_def)
 done
 
 lemma azmult_less:"\<lbrakk>a \<noteq> \<infinity>; na a < m; 0 < x\<rbrakk>
                          \<Longrightarrow> a < int m *\<^sub>a x"
 apply (cut_tac mem_ant[of "a"])
  apply (erule disjE)
  apply (case_tac "x = \<infinity>") apply simp
  apply (subst less_le[of "-\<infinity>" "\<infinity>"]) apply simp
  apply (frule aless_imp_le[of "0" "x"], frule apos_neq_minf[of "x"])
  apply (cut_tac mem_ant[of "x"], simp, erule exE, simp)
  apply (simp add:asprod_amult a_z_z)
 apply (simp, erule exE, simp)
 
 apply (frule_tac a = "ant z" in gt_na_poss[of _ "m"])
  apply (case_tac "x = \<infinity>", simp)
  apply (frule aless_imp_le[of "0" "x"])
  apply (frule apos_neq_minf[of "x"])
  apply (cut_tac mem_ant[of "x"], simp, erule exE,
         simp add:asprod_amult a_z_z)
  apply (subst aless_zless)
  apply (cut_tac a = "ant z" in gt_na_poss[of _ "m"], assumption)
  apply (smt a0_less_int_conv aposs_na_poss int_less_mono int_nat na_def of_nat_0_le_iff pos_zmult_pos tna_ant z_neq_inf)
  done
 
 lemma  zmult_gt_one:"\<lbrakk>2 \<le> m; 0 < xa\<rbrakk> \<Longrightarrow> 1 < int m * xa"
 by (metis ge2_zmult_pos mult.commute)
 
 lemma zmult_pos:"\<lbrakk> 0 < m; 0 < (a::int)\<rbrakk> \<Longrightarrow> 0 < (int m) * a"
 by (frule zmult_zless_mono2[of "0" "a" "int m"], simp, simp)
 
 lemma  ant_int_na:"\<lbrakk>0 \<le> a; a \<noteq> \<infinity> \<rbrakk> \<Longrightarrow> ant (int (na a)) = a"
 by (frule an_na[of "a"], assumption, simp add:an_def)
 
 lemma zpos_nat:"0 \<le> (z::int) \<Longrightarrow> \<exists>n. z = int n"
 apply (subgoal_tac "z = int (nat z)")
 apply blast apply simp
 done
 
 section "nsets"
 
 lemma nsetTr1:"\<lbrakk>j \<in> nset a b; j \<noteq> a\<rbrakk> \<Longrightarrow> j \<in> nset (Suc a) b"
 apply (simp add:nset_def)
 done
 
 lemma nsetTr2:"j \<in> nset (Suc a) (Suc b) \<Longrightarrow> j - Suc 0 \<in> nset a b"
 apply (simp add:nset_def, erule conjE,
        simp add:skip_im_Tr4[of "j" "b"])
 done
 
 lemma  nsetTr3:"\<lbrakk>j \<noteq> Suc (Suc 0); j - Suc 0 \<in> nset (Suc 0) (Suc n)\<rbrakk>
        \<Longrightarrow>  Suc 0 < j - Suc 0"
 apply (simp add:nset_def, erule conjE, subgoal_tac "j \<noteq> 0",
        rule contrapos_pp, simp+)
 done
 
 lemma Suc_leD1:"Suc m \<le> n \<Longrightarrow> m < n"
 apply (insert lessI[of "m"],
        rule less_le_trans[of "m" "Suc m" "n"], assumption+)
 done
 
 lemma leI1:"n < m \<Longrightarrow> \<not> ((m::nat) \<le> n)"
 apply (rule contrapos_pp, simp+)
 done
 
 lemma neg_zle:"\<not> (z::int) \<le> z' \<Longrightarrow> z' < z"
 apply (simp add: not_le)
 done
 
 lemma nset_m_m:"nset m m = {m}"
 by (simp add:nset_def,
        rule equalityI, rule subsetI, simp,
        rule subsetI, simp)
 
 lemma nset_Tr51:"\<lbrakk>j \<in> nset (Suc 0) (Suc (Suc n)); j \<noteq> Suc 0\<rbrakk>
        \<Longrightarrow> j - Suc 0 \<in> nset (Suc 0) (Suc n)"
 apply (simp add:nset_def, (erule conjE)+,
        frule_tac m = j and n = "Suc (Suc n)" and l = "Suc 0" in diff_le_mono,
        simp)
 done
 
 lemma nset_Tr52:"\<lbrakk>j \<noteq> Suc (Suc 0); Suc 0 \<le> j - Suc 0\<rbrakk>
        \<Longrightarrow> \<not> j - Suc 0 \<le> Suc 0"
 by auto
 
 lemma nset_Suc:"nset (Suc 0) (Suc (Suc n)) =
                   nset (Suc 0) (Suc n) \<union> {Suc (Suc n)}"
 by (auto simp add:nset_def)
 
 lemma AinequalityTr0:"x \<noteq> -\<infinity> \<Longrightarrow> \<exists>L. (\<forall>N. L < N \<longrightarrow>
                           (an m) < (x + an N))"
 apply (case_tac "x = \<infinity>", simp add:an_def)
 apply (cut_tac mem_ant[of "x"], simp, erule exE, simp add:an_def a_zpz,
        simp add:aless_zless,
        cut_tac x = z in zmult_pos_bignumTr0[of "int m"], simp)
 done
 
 lemma AinequalityTr:"\<lbrakk>0 < b \<and> b \<noteq> \<infinity>; x \<noteq> -\<infinity>\<rbrakk> \<Longrightarrow> \<exists>L. (\<forall>N. L < N \<longrightarrow>
                           (an m) < (x + (int N) *\<^sub>a b))"
 apply (frule_tac AinequalityTr0[of "x" "m"],
        erule exE,
        subgoal_tac "\<forall>N. L < N \<longrightarrow> an m < x + (int N) *\<^sub>a b",
        blast, rule allI, rule impI)
 apply (drule_tac a = N in forall_spec, assumption,
        erule conjE,
        cut_tac N = N in asprod_ge[of "b"], assumption,
        thin_tac "x \<noteq> - \<infinity>", thin_tac "b \<noteq> \<infinity>", thin_tac "an m < x + an N",
         simp)
  apply (frule_tac x = "an N" and y = "int N *\<^sub>a b" and z = x in aadd_le_mono,
         simp only:aadd_commute[of _ "x"])
 done
 
 lemma two_inequalities:"\<lbrakk>\<forall>(n::nat). x < n \<longrightarrow> P n; \<forall>(n::nat). y < n \<longrightarrow> Q n\<rbrakk>
  \<Longrightarrow>  \<forall>n. (max x y) < n \<longrightarrow> (P n) \<and> (Q n)"
 by auto
 
 lemma multi_inequalityTr0:"(\<forall>j \<le> (n::nat). (x j) \<noteq> -\<infinity> ) \<longrightarrow>
       (\<exists>L. (\<forall>N. L < N \<longrightarrow>  (\<forall>l \<le> n. (an m) < (x l) + (an N))))"
 apply (induct_tac n)
  apply (rule impI, simp)
  apply (rule AinequalityTr0[of "x 0" "m"], assumption)
 (** n **)
 apply (rule impI)
  apply (subgoal_tac "\<forall>l. l \<le> n \<longrightarrow> l \<le> (Suc n)", simp)
  apply (erule exE)
  apply (frule_tac a = "Suc n" in forall_spec, simp)
 
  apply (frule_tac x = "x (Suc n)" in AinequalityTr0[of _ "m"])
  apply (erule exE)
  apply (subgoal_tac "\<forall>N. (max L La) < N \<longrightarrow>
                  (\<forall>l \<le> (Suc n). an m < x l + an N)", blast)
  apply (rule allI, rule impI, rule allI, rule impI)
  apply (rotate_tac 1)
  apply (case_tac "l = Suc n", simp,
         drule_tac m = l and n = "Suc n" in noteq_le_less, assumption+,
         drule_tac x = l and n = "Suc n" in less_le_diff, simp,
         simp)
 done
 
 lemma multi_inequalityTr1:"\<lbrakk>\<forall>j \<le> (n::nat). (x j) \<noteq> - \<infinity>\<rbrakk> \<Longrightarrow>
        \<exists>L. (\<forall>N. L < N \<longrightarrow>  (\<forall>l \<le> n. (an m) < (x l) + (an N)))"
 by (simp add:multi_inequalityTr0)
 
 lemma gcoeff_multi_inequality:"\<lbrakk>\<forall>N. 0 < N \<longrightarrow> (\<forall>j \<le> (n::nat). (x j) \<noteq> -\<infinity> \<and>
      0 < (b N j) \<and> (b N j) \<noteq> \<infinity>)\<rbrakk> \<Longrightarrow>
 \<exists>L. (\<forall>N. L < N \<longrightarrow>  (\<forall>l \<le> n.(an m) < (x l) + (int N) *\<^sub>a (b N l)))"
 apply (subgoal_tac "\<forall>j \<le> n. x j \<noteq> - \<infinity>")
 apply (frule  multi_inequalityTr1[of "n" "x" "m"])
 apply (erule exE)
 apply (subgoal_tac "\<forall>N. L < N \<longrightarrow>
                      (\<forall>l \<le> n. an m < x l + (int N) *\<^sub>a (b N l))")
 apply blast
 
 apply (rule allI, rule impI, rule allI, rule impI,
        drule_tac a = N in forall_spec, simp,
        drule_tac a = l in forall_spec, assumption,
        drule_tac a = N in forall_spec, assumption,
        drule_tac a = l in forall_spec, assumption,
        drule_tac a = l in forall_spec, assumption)
  apply (cut_tac b = "b N l" and N = N in asprod_ge, simp, simp,
         (erule conjE)+, simp, thin_tac "x l \<noteq> - \<infinity>", thin_tac "b N l \<noteq> \<infinity>")
 apply (frule_tac x = "an N" and y = "int N *\<^sub>a b N l" and z = "x l" in
        aadd_le_mono, simp add:aadd_commute,
        rule allI, rule impI,
        cut_tac lessI[of "(0::nat)"],
        drule_tac a = "Suc 0" in forall_spec, assumption)
  apply simp
 done
 
 primrec m_max :: "[nat, nat \<Rightarrow> nat] \<Rightarrow> nat"
 where
   m_max_0: "m_max 0 f = f 0"
 | m_max_Suc: "m_max (Suc n) f  = max (m_max n f) (f (Suc n))"
 
    (** maximum value of f **)
 
 lemma m_maxTr:"\<forall>l \<le> n. (f l) \<le> m_max n f"
 apply (induct_tac n)
  apply simp
 
 apply (rule allI, rule impI)
  apply simp
  apply (case_tac "l = Suc n", simp)
  apply (cut_tac m = l and n = "Suc n" in noteq_le_less, assumption+,
         thin_tac "l \<le> Suc n", thin_tac "l \<noteq> Suc n",
         frule_tac x = l and n = "Suc n" in less_le_diff,
         thin_tac "l < Suc n", simp)
  apply (drule_tac a = l in forall_spec, assumption)
  apply simp
 done
 
 lemma m_max_gt:"l \<le> n \<Longrightarrow> (f l) \<le> m_max n f"
 apply (simp add:m_maxTr)
 done
 
 lemma ASum_zero:" (\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>l \<le> n. f l = 0) \<longrightarrow> ASum f n = 0"
 apply (induct_tac n)
 apply (rule impI, erule conjE, simp)
 apply (rule impI)
 apply (subgoal_tac "(\<forall>j\<le>n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>l\<le>n. f l = 0)", simp)
  apply (simp add:aadd_0_l, erule conjE,
         thin_tac "(\<forall>j\<le>n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>l\<le>n. f l = 0) \<longrightarrow> ASum f n = 0")
  apply (rule conjI)
  apply (rule allI, rule impI,
         drule_tac a = j in forall_spec, simp, assumption+)
  apply (thin_tac "\<forall>j\<le>Suc n. f j \<in> Z\<^sub>\<infinity>")
  apply (rule allI, rule impI,
         drule_tac a = l in forall_spec, simp+)
 done
 
 lemma eSum_singleTr:"(\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity>) \<and> (j \<le> n \<and> (\<forall>l \<in>{h. h \<le> n} - {j}. f l = 0))  \<longrightarrow> ASum f n = f j"
 apply (induct_tac n)
  apply (simp, rule impI, (erule conjE)+)
  apply (case_tac "j \<le> n")
  apply simp
  apply (simp add:aadd_0_r)
  apply simp
  apply (simp add:nat_not_le_less[of j])
  apply (frule_tac m = n and n = j in Suc_leI)
  apply (frule_tac m = j and n = "Suc n" in le_antisym, assumption+, simp)
  apply (cut_tac n = n in ASum_zero [of _ "f"])
  apply (subgoal_tac "(\<forall>j\<le>n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>l\<le>n. f l = 0)")
  apply (thin_tac "\<forall>j\<le>Suc n. f j \<in> Z\<^sub>\<infinity>",
         thin_tac "\<forall>l\<in>{h. h \<le> Suc n} - {Suc n}. f l = 0", simp only:mp)
  apply (simp add:aadd_0_l)
 
  apply (thin_tac "(\<forall>j\<le>n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>l\<le>n. f l = 0) \<longrightarrow> ASum f n = 0")
  apply (rule conjI,
         thin_tac "\<forall>l\<in>{h. h \<le> Suc n} - {Suc n}. f l = 0", simp)
  apply (thin_tac "\<forall>j\<le>Suc n. f j \<in> Z\<^sub>\<infinity>", simp)
 done
 
 lemma eSum_single:"\<lbrakk>\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity> ; j \<le> n; \<forall>l \<in> {h. h \<le> n} - {j}. f l = 0\<rbrakk>
  \<Longrightarrow> ASum  f n = f j"
 apply (simp add:eSum_singleTr)
 done
 
 lemma ASum_eqTr:"(\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity>) \<and> (\<forall>j \<le> n. g j \<in> Z\<^sub>\<infinity>) \<and>
                 (\<forall>j \<le> n. f j = g j) \<longrightarrow> ASum f n = ASum g n"
 apply (induct_tac n)
  apply (rule impI, simp)
 
 apply (rule impI, (erule conjE)+)
 apply simp
 done
 
 lemma ASum_eq:"\<lbrakk>\<forall>j \<le> n. f j \<in> Z\<^sub>\<infinity>; \<forall>j \<le> n. g j \<in> Z\<^sub>\<infinity>; \<forall>j \<le> n. f j = g j\<rbrakk> \<Longrightarrow>
                ASum f n = ASum g n"
 by (cut_tac ASum_eqTr[of n f g], simp)
 
 
 definition
   Kronecker_delta :: "[nat, nat] \<Rightarrow> ant"
     ("(\<delta>\<^bsub>_ _\<^esub>)" [70,71]70) where
   "\<delta>\<^bsub>i j\<^esub> = (if i = j then 1 else 0)"
 
 definition
   K_gamma :: "[nat, nat] \<Rightarrow> int"
     ("(\<gamma>\<^bsub>_ _\<^esub>)" [70,71]70) where
   "\<gamma>\<^bsub>i j\<^esub> = (if i = j then 0 else 1)"
 
 abbreviation
   TRANSPOS  ("(\<tau>\<^bsub>_ _\<^esub>)" [90,91]90) where
   "\<tau>\<^bsub>i j\<^esub> == transpos i j"
 
 lemma Kdelta_in_Zinf:"\<lbrakk>j \<le> (Suc n); k \<le> (Suc n)\<rbrakk>  \<Longrightarrow>
                  z *\<^sub>a (\<delta>\<^bsub>j k\<^esub>) \<in> Z\<^sub>\<infinity>"
 apply (simp add:Kronecker_delta_def)
 apply (simp add:z_in_aug_inf Zero_in_aug_inf)
 apply (simp add:asprod_n_0 Zero_in_aug_inf)
 done
 
 lemma Kdelta_in_Zinf1:"\<lbrakk>j \<le> n; k \<le> n\<rbrakk>  \<Longrightarrow> \<delta>\<^bsub>j k\<^esub> \<in> Z\<^sub>\<infinity>"
 apply (simp add:Kronecker_delta_def)
 apply (simp add:z_in_aug_inf Zero_in_aug_inf)
 apply (rule impI)
 apply (simp only:ant_1[THEN sym], simp del:ant_1 add:z_in_aug_inf)
 done
 
 primrec m_zmax :: "[nat, nat \<Rightarrow> int] \<Rightarrow> int"
 where
   m_zmax_0: "m_zmax 0 f = f 0"
 | m_zmax_Suc: "m_zmax (Suc n) f = zmax (m_zmax n f) (f (Suc n))"
 
 lemma m_zmax_gt_eachTr:
       "(\<forall>j \<le> n. f j \<in> Zset) \<longrightarrow> (\<forall>j \<le> n. (f j) \<le> m_zmax n f)"
 apply (induct_tac n)
 apply (rule impI, rule allI, rule impI, simp)
  apply (rule impI)
  apply simp
  apply (rule allI, rule impI)
  apply (case_tac "j = Suc n", simp)
  apply (simp add:zmax_def)
  apply (drule_tac m = j and n = "Suc n" in noteq_le_less, assumption,
         drule_tac x = j and n = "Suc n" in less_le_diff, simp)
  apply (drule_tac a = j in forall_spec, assumption)
  apply (simp add:zmax_def)
 done
 
 lemma m_zmax_gt_each:"(\<forall>j \<le> n. f j \<in> Zset) \<Longrightarrow> (\<forall>j \<le> n. (f j) \<le> m_zmax n f)"
 apply (simp add:m_zmax_gt_eachTr)
 done
 
 lemma n_notin_Nset_pred:" 0 < n \<Longrightarrow> \<not> n \<le> (n - Suc 0)"
 apply simp
 done
 
 lemma Nset_preTr:"\<lbrakk>0 < n; j \<le> (n - Suc 0)\<rbrakk> \<Longrightarrow> j \<le> n"
 apply simp
 done
 
 lemma Nset_preTr1:"\<lbrakk>0 < n; j \<le> (n - Suc 0)\<rbrakk> \<Longrightarrow> j \<noteq> n"
 apply simp
 done
 
 lemma transpos_noteqTr:"\<lbrakk>0 < n; k \<le> (n - Suc 0); j \<le> n; j \<noteq> n\<rbrakk>
                     \<Longrightarrow> j \<noteq> (\<tau>\<^bsub>j n\<^esub>) k"
 apply (rule contrapos_pp, simp+)
  apply (simp add:transpos_def)
  apply (case_tac "k = j", simp, simp)
  apply (case_tac "k = n", simp)
  apply (simp add:n_notin_Nset_pred)
 done
 
 chapter "Elementary properties of a valuation"
 
 
 section "Definition of a valuation"
 
 definition
   valuation :: "[('b, 'm) Ring_scheme, 'b \<Rightarrow> ant] \<Rightarrow> bool" where
   "valuation K v \<longleftrightarrow>
      v \<in> extensional (carrier K) \<and>
      v \<in> carrier K \<rightarrow> Z\<^sub>\<infinity>  \<and>
      v (\<zero>\<^bsub>K\<^esub>) = \<infinity> \<and> (\<forall>x\<in>((carrier K) - {\<zero>\<^bsub>K\<^esub>}). v x \<noteq> \<infinity>) \<and>
     (\<forall>x\<in>(carrier K). \<forall>y\<in>(carrier K). v (x \<cdot>\<^sub>r\<^bsub>K\<^esub> y) = (v x) + (v y)) \<and>
     (\<forall>x\<in>(carrier K). 0 \<le> (v x) \<longrightarrow> 0 \<le> (v (1\<^sub>r\<^bsub>K\<^esub> \<plusminus>\<^bsub>K\<^esub> x))) \<and>
     (\<exists>x. x \<in> carrier K \<and> (v x) \<noteq> \<infinity> \<and> (v x) \<noteq> 0)"
 
 lemma (in Corps) invf_closed:"x \<in> carrier K - {\<zero>} \<Longrightarrow> x\<^bsup>\<hyphen> K\<^esup> \<in> carrier K"
 by (cut_tac invf_closed1[of x], simp, assumption)
 
 lemma (in Corps) valuation_map:"valuation K v \<Longrightarrow> v \<in> carrier K \<rightarrow> Z\<^sub>\<infinity>"
 by (simp add:valuation_def)
 
 lemma (in Corps) value_in_aug_inf:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
        v x \<in> Z\<^sub>\<infinity>"
 by (simp add:valuation_def, (erule conjE)+, simp add:funcset_mem)
 
 lemma (in Corps) value_of_zero:"valuation K v  \<Longrightarrow> v (\<zero>) = \<infinity>"
 by (simp add:valuation_def)
 
 lemma (in Corps) val_nonzero_noninf:"\<lbrakk>valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk>
      \<Longrightarrow> (v x) \<noteq> \<infinity>"
 by (simp add:valuation_def)
 
 lemma (in Corps) value_inf_zero:"\<lbrakk>valuation K v; x \<in> carrier K; v x = \<infinity>\<rbrakk>
      \<Longrightarrow> x = \<zero>"
 by (rule contrapos_pp, simp+,
     frule val_nonzero_noninf[of v x], assumption+, simp)
 
 lemma (in Corps) val_nonzero_z:"\<lbrakk>valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                       \<exists>z. (v x) = ant z"
 by (frule value_in_aug_inf[of v x], assumption+,
     frule val_nonzero_noninf[of v x], assumption+,
     cut_tac mem_ant[of "v x"],  simp add:aug_inf_def)
 
 lemma (in Corps) val_nonzero_z_unique:"\<lbrakk>valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk>
        \<Longrightarrow> \<exists>!z. (v x) = ant z"
 by (rule ex_ex1I, simp add:val_nonzero_z, simp)
 
 lemma (in Corps) value_noninf_nonzero:"\<lbrakk>valuation K v; x \<in> carrier K; v x \<noteq> \<infinity>\<rbrakk>
          \<Longrightarrow> x \<noteq> \<zero>"
 by (rule contrapos_pp, simp+, simp add:value_of_zero)
 
 lemma (in Corps) val1_neq_0:"\<lbrakk>valuation K v; x \<in> carrier K; v x = 1\<rbrakk> \<Longrightarrow>
                                          x \<noteq> \<zero>"
 apply (rule contrapos_pp, simp+, simp add:value_of_zero)
 apply (simp only:ant_1[THEN sym], cut_tac z_neq_inf[THEN not_sym, of 1], simp)
 done
 
 lemma (in Corps) val_Zmin_sym:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K\<rbrakk>
                  \<Longrightarrow>  amin (v x) (v y) = amin (v y ) (v x)"
 by (simp add:amin_commute)
 
 lemma (in Corps) val_t2p:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K\<rbrakk>
                          \<Longrightarrow> v (x \<cdot>\<^sub>r y ) = v x + v y"
 by (simp add:valuation_def)
 
 lemma (in Corps) val_axiom4:"\<lbrakk>valuation K v; x \<in> carrier K; 0 \<le> v x\<rbrakk> \<Longrightarrow>
                       0 \<le> v (1\<^sub>r \<plusminus> x)"
 by (simp add:valuation_def)
 
 lemma (in Corps) val_axiom5:"valuation K v \<Longrightarrow>
                   \<exists>x. x \<in> carrier K \<and> v x \<noteq> \<infinity> \<and> v x \<noteq> 0"
 by (simp add:valuation_def)
 
 lemma (in Corps) val_field_nonzero:"valuation K v \<Longrightarrow> carrier K \<noteq> {\<zero>}"
 by (rule contrapos_pp, simp+,
        frule val_axiom5[of v],
        erule exE, (erule conjE)+, simp add:value_of_zero)
 
 lemma (in Corps) val_field_1_neq_0:"valuation K v \<Longrightarrow> 1\<^sub>r \<noteq> \<zero>"
 apply (rule contrapos_pp, simp+)
 apply (frule val_axiom5[of v])
 apply (erule exE, (erule conjE)+)
 apply (cut_tac field_is_ring,
        frule_tac t = x in  Ring.ring_l_one[THEN sym, of "K"], assumption+,
        simp add:Ring.ring_times_0_x, simp add:value_of_zero)
 done
 
 lemma (in Corps) value_of_one:"valuation K v \<Longrightarrow> v (1\<^sub>r) = 0"
 apply (cut_tac field_is_ring, frule Ring.ring_one[of "K"])
 apply (frule val_t2p[of v "1\<^sub>r" "1\<^sub>r"], assumption+,
        simp add:Ring.ring_l_one, frule val_field_1_neq_0[of v],
        frule val_nonzero_z[of v "1\<^sub>r"], assumption+,
        erule exE, simp add:a_zpz)
 done
 
 lemma (in Corps) has_val_one_neq_zero:"valuation K v \<Longrightarrow> 1\<^sub>r \<noteq> \<zero>"
 by (frule value_of_one[of "v"],
        rule contrapos_pp, simp+, simp add:value_of_zero)
 
 lemma (in Corps) val_minus_one:"valuation K v \<Longrightarrow> v (-\<^sub>a 1\<^sub>r) = 0"
 apply (cut_tac field_is_ring, frule Ring.ring_one[of "K"],
        frule Ring.ring_is_ag[of "K"],
        frule val_field_1_neq_0[of v],
        frule aGroup.ag_inv_inj[of "K" "1\<^sub>r" "\<zero>"], assumption+,
        simp add:Ring.ring_zero, assumption)
  apply (frule val_nonzero_z[of v "-\<^sub>a 1\<^sub>r"],
         rule aGroup.ag_mOp_closed, assumption+, simp add:aGroup.ag_inv_zero,
         erule exE, frule val_t2p [THEN sym, of v "-\<^sub>a 1\<^sub>r" "-\<^sub>a 1\<^sub>r"])
 apply (simp add:aGroup.ag_mOp_closed[of "K" "1\<^sub>r"],
        simp add:aGroup.ag_mOp_closed[of "K" "1\<^sub>r"],
        frule Ring.ring_inv1_3[THEN sym, of "K" "1\<^sub>r" "1\<^sub>r"], assumption+,
        simp add:Ring.ring_l_one, simp add:value_of_one a_zpz)
 done
 
 lemma (in Corps) val_minus_eq:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
                             v (-\<^sub>a x) = v x"
 apply (cut_tac field_is_ring,
      simp add:Ring.ring_times_minusl[of K x],
      subst val_t2p[of v], assumption+,
      frule Ring.ring_is_ag[of "K"], rule aGroup.ag_mOp_closed, assumption+,
      simp add:Ring.ring_one, assumption, simp add:val_minus_one,
      simp add:aadd_0_l)
 done
 
 lemma (in Corps) value_of_inv:"\<lbrakk>valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                         v (x\<^bsup>\<hyphen>K\<^esup>) = - (v x)"
 apply (cut_tac invf_inv[of x], erule conjE,
        frule val_t2p[of v "x\<^bsup>\<hyphen>K\<^esup>" x], assumption+,
        simp+, simp add:value_of_one, simp add:a_inv)
 apply simp
 done
 
 lemma (in Corps) val_exp_ring:"\<lbrakk> valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk>
            \<Longrightarrow> (int n) *\<^sub>a (v x) = v (x^\<^bsup>K n\<^esup>)"
 apply (cut_tac field_is_ring,
        induct_tac n, simp add:Ring.ring_r_one, simp add:value_of_one)
 apply (drule sym, simp)
 apply (subst val_t2p[of v _ x], assumption+,
        rule Ring.npClose, assumption+,
        frule val_nonzero_z[of v x], assumption+,
               erule exE, simp add:asprod_mult a_zpz,
        simp add: distrib_right)
 done
 
 text\<open>exponent in a field\<close>
 lemma (in Corps) val_exp:"\<lbrakk> valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                         z *\<^sub>a (v x) = v (x\<^bsub>K\<^esub>\<^bsup>z\<^esup>)"
 apply (simp add:npowf_def)
 apply (case_tac "0 \<le> z",
        simp, frule val_exp_ring [of v x "nat z"], assumption+,
        simp, simp)
  apply (simp add:zle,
        cut_tac invf_closed1[of x], simp,
        cut_tac  val_exp_ring [THEN sym, of v "x\<^bsup>\<hyphen> K\<^esup>" "nat (- z)"], simp,
        thin_tac "v (x\<^bsup>\<hyphen> K\<^esup>^\<^bsup>K (nat (- z))\<^esup>) = (- z) *\<^sub>a v (x\<^bsup>\<hyphen> K\<^esup>)", erule conjE)
  apply (subst value_of_inv[of v x], assumption+)
  apply (frule val_nonzero_z[of v x], assumption+, erule exE, simp,
        simp add:asprod_mult aminus, simp+)
 done
 
 lemma (in Corps) value_zero_nonzero:"\<lbrakk>valuation K v; x \<in> carrier K; v x = 0\<rbrakk>
                    \<Longrightarrow> x \<noteq> \<zero>"
 by (frule value_noninf_nonzero[of v x], assumption+, simp,
         assumption)
 
 lemma (in Corps) v_ale_diff:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K;
         x \<noteq> \<zero>; v x \<le> v y \<rbrakk> \<Longrightarrow> 0 \<le> v(y \<cdot>\<^sub>r x\<^bsup>\<hyphen> K\<^esup>)"
 apply (frule value_in_aug_inf[of v x], simp+,
        frule value_in_aug_inf[of v y], simp+,
        frule val_nonzero_z[of v x], assumption+,
        erule exE)
 apply (cut_tac invf_closed[of x], simp+,
        simp add:val_t2p,
        simp add:value_of_inv[of v "x"],
        frule_tac x = "ant z" in ale_diff_pos[of _ "v y"],
        simp add:diff_ant_def)
 apply simp
 done
 
 lemma (in Corps) amin_le_plusTr:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K;
        v x \<noteq> \<infinity>; v y \<noteq> \<infinity>; v x \<le> v y\<rbrakk> \<Longrightarrow> amin (v x) (v y) \<le> v ( x \<plusminus> y)"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag,
        frule value_noninf_nonzero[of v x], assumption+,
        frule v_ale_diff[of v x y], assumption+,
        cut_tac invf_closed1[of x],
        frule Ring.ring_tOp_closed[of K y "x\<^bsup>\<hyphen> K\<^esup>"], assumption+, simp,
        frule Ring.ring_one[of "K"],
        frule aGroup.ag_pOp_closed[of "K" "1\<^sub>r" "y \<cdot>\<^sub>r x\<^bsup>\<hyphen> K\<^esup>"], assumption+,
        frule val_axiom4[of v "y \<cdot>\<^sub>r ( x\<^bsup>\<hyphen> K\<^esup>)"], assumption+)
 apply (frule aadd_le_mono[of "0" "v (1\<^sub>r \<plusminus> y \<cdot>\<^sub>r x\<^bsup>\<hyphen> K\<^esup>)" "v x"],
        simp add:aadd_0_l, simp add:aadd_commute[of _ "v x"],
        simp add:val_t2p[THEN sym, of v x],
        simp add:Ring.ring_distrib1 Ring.ring_r_one,
        simp add:Ring.ring_tOp_commute[of "K" "x"],
        simp add:Ring.ring_tOp_assoc, simp add:linvf,
        simp add:Ring.ring_r_one,
        cut_tac amin_le_l[of "v x" "v y"],
        rule ale_trans[of "amin (v x) (v y)" "v x" "v (x \<plusminus> y)"], assumption+)
 apply simp
 done
 
 lemma (in Corps) amin_le_plus:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K\<rbrakk>
                    \<Longrightarrow> (amin (v x) (v y)) \<le> (v (x \<plusminus> y))"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag)
 apply (case_tac "v x = \<infinity> \<or> v y = \<infinity>")
 apply (erule disjE, simp,
        frule value_inf_zero[of v x], assumption+,
        simp add:aGroup.ag_l_zero amin_def,
        frule value_inf_zero[of v y], assumption+,
        simp add:aGroup.ag_r_zero amin_def, simp, erule conjE)
 apply (cut_tac z = "v x" and w = "v y" in ale_linear,
        erule disjE, simp add:amin_le_plusTr,
        frule_tac amin_le_plusTr[of v y x], assumption+,
        simp add:aGroup.ag_pOp_commute amin_commute)
 done
 
 lemma (in Corps) value_less_eq:"\<lbrakk> valuation K v; x \<in> carrier K; y \<in> carrier K;
                        (v x) < (v y)\<rbrakk> \<Longrightarrow> (v x) = (v (x \<plusminus> y))"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule amin_le_plus[of v x y], assumption+,
        frule aless_imp_le[of "v x" "v y"],
        simp add: amin_def)
 apply (frule amin_le_plus[of v "x \<plusminus> y" "-\<^sub>a y"],
        rule aGroup.ag_pOp_closed, assumption+,
        rule aGroup.ag_mOp_closed, assumption+,
        simp add:val_minus_eq,
        frule aGroup.ag_mOp_closed[of "K" "y"], assumption+,
        simp add:aGroup.ag_pOp_assoc[of "K" "x" "y"],
        simp add:aGroup.ag_r_inv1, simp add:aGroup.ag_r_zero,
        simp add:amin_def)
  apply (case_tac "\<not> (v (x \<plusminus>\<^bsub>K\<^esub> y) \<le> (v y))", simp+)
 done
 
 lemma (in Corps) value_less_eq1:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K;
       (v x) < (v y)\<rbrakk> \<Longrightarrow> v x =  v (y \<plusminus> x)"
 apply (cut_tac field_is_ring,
        frule Ring.ring_is_ag[of "K"],
        frule value_less_eq[of v x y], assumption+)
 apply (subst aGroup.ag_pOp_commute, assumption+)
 done
 
 lemma (in Corps) val_1px:"\<lbrakk>valuation K v; x \<in> carrier K; 0 \<le> (v (1\<^sub>r \<plusminus> x))\<rbrakk>
          \<Longrightarrow> 0 \<le> (v x)"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule Ring.ring_one[of "K"])
 apply (rule contrapos_pp, simp+,
        case_tac "x = \<zero>\<^bsub>K\<^esub>",
         simp add:aGroup.ag_r_zero, simp add:value_of_zero,
         simp add: aneg_le[of "0" "v x"],
         frule value_less_eq[of v x "1\<^sub>r"], assumption+,
         simp add:value_of_one)
 apply (drule sym,
        simp add:aGroup.ag_pOp_commute[of "K" "x"])
 done
 
 lemma (in Corps) val_1mx:"\<lbrakk>valuation K v; x \<in> carrier K;
                   0 \<le> (v (1\<^sub>r \<plusminus> (-\<^sub>a x)))\<rbrakk> \<Longrightarrow> 0 \<le> (v x)"
 by (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule val_1px[of v "-\<^sub>a x"],
        simp add:aGroup.ag_mOp_closed, assumption, simp add:val_minus_eq)
 
 section "The normal valuation of v"
 
 definition
   Lv :: "[('r, 'm) Ring_scheme , 'r \<Rightarrow> ant] \<Rightarrow> ant" (* Least nonnegative value *) where
   "Lv K v = AMin {x. x \<in> v ` carrier K \<and> 0 < x}"
 
 definition
   n_val :: "[('r, 'm) Ring_scheme, 'r \<Rightarrow> ant] \<Rightarrow> ('r \<Rightarrow> ant)" where
   "n_val K v = (\<lambda>x\<in> carrier K.  (THE l. (l * (Lv K v)) = v x))"
                      (* normal valuation *)
 
 definition
   Pg :: "[('r, 'm) Ring_scheme, 'r \<Rightarrow> ant] \<Rightarrow> 'r" (* Positive generator *) where
   "Pg K v = (SOME x. x \<in> carrier K - {\<zero>\<^bsub>K\<^esub>} \<and> v x = Lv K v)"
 
 lemma (in Corps) vals_pos_nonempty:"valuation K v \<Longrightarrow>
                        {x. x \<in> v ` carrier K \<and> 0 < x} \<noteq> {}"
   using val_axiom5[of v] value_noninf_nonzero[of v] value_of_inv[THEN sym, of v]
   by (auto simp: ex_image_cong_iff) (metis Ring.ring_is_ag aGroup.ag_mOp_closed aGroup.ag_pOp_closed aGroup.ag_r_inv1 f_is_ring zero_lt_inf)
 
 lemma (in Corps) vals_pos_LBset:"valuation K v \<Longrightarrow>
             {x. x \<in> v ` carrier K \<and> 0 < x} \<subseteq> LBset 1"
 by (rule subsetI, simp add:LBset_def, erule conjE,
        rule_tac x = x in gt_a0_ge_1, assumption)
 
 lemma (in Corps) Lv_pos:"valuation K v \<Longrightarrow> 0 < Lv K v"
 apply (simp add:Lv_def,
        frule vals_pos_nonempty[of v],
        frule vals_pos_LBset[of v],
        simp only:ant_1[THEN sym],
        frule AMin[of "{x. x \<in> v ` carrier K \<and> 0 < x}" "1"], assumption+,
        erule conjE)
 apply simp
 done
 
 lemma (in Corps) AMin_z:"valuation K v \<Longrightarrow>
          \<exists>a. AMin {x. x \<in> v ` carrier K \<and> 0 < x} = ant a"
 apply (frule vals_pos_nonempty[of v],
        frule vals_pos_LBset[of v],
        simp only:ant_1[THEN sym],
        frule AMin[of "{x. x \<in> v ` carrier K \<and> 0 < x}" "1"], assumption+,
        erule conjE)
 apply (frule val_axiom5[of v],
        erule exE, (erule conjE)+,
        cut_tac x = "v x" in aless_linear[of _ "0"], simp,
        erule disjE,
        frule_tac x = x in value_noninf_nonzero[of v], assumption+,
        frule_tac x1 = x in value_of_inv[THEN sym, of v], assumption+)
 apply (frule_tac x = "v x" in aless_minus[of _ "0"], simp,
        cut_tac x = x in invf_closed1, simp, erule conjE,
        frule valuation_map[of v],
        frule_tac a = "x\<^bsup>\<hyphen> K\<^esup>" in mem_in_image[of "v" "carrier K" "Z\<^sub>\<infinity>"], simp)
 apply (drule_tac a = "v (x\<^bsup>\<hyphen> K\<^esup>)" in forall_spec, simp,
        frule_tac x = "x\<^bsup>\<hyphen> K\<^esup>" in val_nonzero_noninf[of v],
        thin_tac "v (x\<^bsup>\<hyphen> K\<^esup>) \<in> v ` carrier K",
        thin_tac "{x \<in> v ` carrier K. 0 < x} \<subseteq> LBset 1",
        thin_tac "AMin {x \<in> v ` carrier K. 0 < x} \<in> v ` carrier K",
        thin_tac "0 < AMin {x \<in> v ` carrier K. 0 < x}", simp,
        thin_tac "v (x\<^bsup>\<hyphen> K\<^esup>) \<in> v ` carrier K",
        thin_tac "{x \<in> v ` carrier K. 0 < x} \<subseteq> LBset 1",
        thin_tac "AMin {x \<in> v ` carrier K. 0 < x} \<in> v ` carrier K",
        thin_tac "0 < AMin {x \<in> v ` carrier K. 0 < x}", simp)
 apply (rule noninf_mem_Z[of "AMin {x \<in> v ` carrier K. 0 < x}"],
        frule image_sub[of v "carrier K" "Z\<^sub>\<infinity>" "carrier K"],
        rule subset_refl)
 apply (rule subsetD[of "v ` carrier K" "Z\<^sub>\<infinity>"
                     "AMin {x \<in> v ` carrier K. 0 < x}"], assumption+)
   apply auto
   by (metis (no_types, lifting) aneg_le aug_inf_noninf_is_z image_eqI value_in_aug_inf z_less_i)
 
 lemma (in Corps) Lv_z:"valuation K v \<Longrightarrow> \<exists>z. Lv K v = ant z"
 by (simp add:Lv_def, rule AMin_z, assumption+)
 
 lemma (in Corps) AMin_k:"valuation K v \<Longrightarrow>
          \<exists>k\<in> carrier K - {\<zero>}. AMin {x. x \<in> v ` carrier K \<and> 0 < x} = v k"
 
 apply (frule vals_pos_nonempty[of v],
        frule vals_pos_LBset[of v],
        simp only:ant_1[THEN sym],
        frule AMin[of "{x. x \<in> v ` carrier K \<and> 0 < x}" "1"], assumption+,
        erule conjE)
 apply (thin_tac "\<forall>x\<in>{x. x \<in> v ` carrier K \<and> 0 < x}.
                    AMin {x. x \<in> v ` carrier K \<and> 0 < x} \<le> x")
 apply (simp add:image_def, erule conjE, erule bexE,
        thin_tac "{x. (\<exists>xa\<in>carrier K. x = v xa) \<and> 0 < x} \<subseteq> LBset 1",
        thin_tac "\<exists>x. (\<exists>xa\<in>carrier K. x = v xa) \<and> 0 < x",
        subgoal_tac "x \<in> carrier K - {\<zero>}", blast,
        frule AMin_z[of v],  erule exE, simp)
 apply (simp add:image_def,
        thin_tac "AMin {x. (\<exists>xa\<in>carrier K. x = v xa) \<and> 0 < x} = ant a",
        rule contrapos_pp, simp+, frule sym, thin_tac "v (\<zero>) = ant a",
        simp add:value_of_zero)
 done
 
 lemma (in Corps) val_Pg:" valuation K v \<Longrightarrow>
                   Pg K v \<in> carrier K - {\<zero>} \<and> v (Pg K v) = Lv K v"
 apply (frule AMin_k[of v], unfold Lv_def, unfold Pg_def)
 apply (rule someI2_ex)
  apply (erule bexE, drule sym, unfold Lv_def, blast)
  apply simp
 done
 
 lemma (in Corps) amin_generateTr:"valuation K v \<Longrightarrow>
   \<forall>w\<in>carrier K - {\<zero>}. \<exists>z. v w = z *\<^sub>a AMin {x. x \<in> v ` carrier K \<and> 0 < x}"
 apply (frule vals_pos_nonempty[of v],
        frule vals_pos_LBset[of v],
        simp only:ant_1[THEN sym],
        frule AMin[of "{x. x \<in> v ` carrier K \<and> 0 < x}" "1"], assumption+,
        frule AMin_z[of v], erule exE, simp,
        thin_tac "\<exists>x. x \<in> v ` carrier K \<and> 0 < x",
        (erule conjE)+, rule ballI, simp, erule conjE,
        frule_tac x = w in val_nonzero_noninf[of v], assumption+,
        frule_tac x = w in value_in_aug_inf[of v], assumption+,
        simp add:aug_inf_def,
        cut_tac a = "v w" in mem_ant, simp, erule exE,
        cut_tac a = z and b = a in amod_adiv_equality)
 apply (case_tac "z mod a = 0", simp add:ant_0 aadd_0_r, blast,
        thin_tac "{x. x \<in> v ` carrier K \<and> 0 < x} \<subseteq> LBset 1",
        thin_tac "v w \<noteq> \<infinity>", thin_tac "v w \<noteq> - \<infinity>")
 
 apply (frule AMin_k[of v], erule bexE,
        drule sym,
        drule sym,
        drule sym,
        rotate_tac -1, drule sym)
 
 apply (cut_tac z = z in z_in_aug_inf,
        cut_tac z = "(z div a)" and x = a in asp_z_Z,
        cut_tac z = "z mod a" in z_in_aug_inf,
        frule_tac a = "ant z" and b = "(z div a) *\<^sub>a ant a" and
        c = "ant (z mod a)" in ant_sol, assumption+,
        subst asprod_mult, simp, assumption, simp,
        frule_tac x = k and z = "z div a" in val_exp[of v],
         (erule conjE)+, assumption, simp, simp,
        thin_tac "(z div a) *\<^sub>a v k = v (k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)",
        erule conjE)
 apply (frule_tac x = k and n = "z div a" in field_potent_nonzero1,
          assumption+,
       frule_tac a = k and n = "z div a" in npowf_mem, assumption,
       frule_tac x1 = "k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>" in value_of_inv[THEN sym, of v], assumption+,
       simp add:diff_ant_def,
        thin_tac "- v (k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>) = v ((k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup>)",
        cut_tac x = "k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>" in invf_closed1, simp,
        simp, erule conjE,
        frule_tac x1 = w and y1 = "(k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup>"  in
         val_t2p[THEN sym, of  v], assumption+, simp,
        cut_tac field_is_ring,
        thin_tac "v w + v ((k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup>) = ant (z mod a)",
        thin_tac "v (k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>) + ant (z mod a) = v w",
        frule_tac x = w and y = "(k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup>" in
                  Ring.ring_tOp_closed[of "K"], assumption+)
 apply (frule valuation_map[of v],
        frule_tac a = "w \<cdot>\<^sub>r (k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup>" in mem_in_image[of "v"
         "carrier K" "Z\<^sub>\<infinity>"], assumption+, simp)
 apply (thin_tac "AMin {x. x \<in> v ` carrier K \<and> 0 < x} = v k",
        thin_tac "v \<in> carrier K \<rightarrow> Z\<^sub>\<infinity>",
        subgoal_tac "0 < v (w \<cdot>\<^sub>r (k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup> )",
        drule_tac a = "v (w \<cdot>\<^sub>r (k\<^bsub>K\<^esub>\<^bsup>(z div a)\<^esup>)\<^bsup>\<hyphen> K\<^esup>)" in forall_spec,
        simp add:image_def)
-apply (drule sym, simp)
-apply (frule_tac b = a and a = z in pos_mod_conj, erule conjE,
+   apply (drule sym, simp)
+
+apply (frule_tac b = a and a = z in Divides.pos_mod_conj, erule conjE,
        simp, simp,
-       frule_tac b = a and a = z in pos_mod_conj, erule conjE, simp)
+       frule_tac b = a and a = z in Divides.pos_mod_conj, erule conjE, simp)
 done
 
 lemma (in Corps) val_principalTr1:"\<lbrakk> valuation K v\<rbrakk>  \<Longrightarrow>
             Lv K v \<in> v ` (carrier K - {\<zero>}) \<and>
              (\<forall>w\<in>v ` carrier K. \<exists>a. w = a * Lv K v) \<and> 0 < Lv K v"
  apply (rule conjI,
         frule val_Pg[of v], erule conjE,
         simp add:image_def, frule sym, thin_tac "v (Pg K v) = Lv K v",
         erule conjE, blast)
  apply (rule conjI,
        rule ballI, simp add:image_def, erule bexE)
 
  apply  (
         frule_tac x = x in value_in_aug_inf[of v], assumption,
         frule sym, thin_tac "w = v x", simp add:aug_inf_def,
         cut_tac a = w in mem_ant, simp, erule disjE, erule exE,
         frule_tac x = x in value_noninf_nonzero[of v], assumption+,
         simp, frule amin_generateTr[of v])
  apply (drule_tac x = x in bspec, simp,
         erule exE,
         frule AMin_z[of v], erule exE, simp add:Lv_def,
         simp add:asprod_mult, frule sym, thin_tac "za * a = z",
         simp, subst a_z_z[THEN sym], blast)
 
  apply (simp add:Lv_def,
         frule AMin_z[of v], erule exE, simp,
         frule Lv_pos[of v], simp add:Lv_def,
         frule_tac m1 = a in a_i_pos[THEN sym], blast,
         simp add:Lv_pos)
 done
 
 lemma (in Corps) val_principalTr2:"\<lbrakk>valuation K v;
   c \<in> v ` (carrier K - {\<zero>}) \<and> (\<forall>w\<in>v ` carrier K. \<exists>a. w = a * c) \<and> 0 < c;
   d \<in> v ` (carrier K - {\<zero>}) \<and> (\<forall>w\<in>v ` carrier K. \<exists>a. w = a * d) \<and> 0 < d\<rbrakk>
        \<Longrightarrow> c = d"
 apply ((erule conjE)+,
        drule_tac x = d in bspec,
        simp add:image_def, erule bexE, blast,
        drule_tac x = c in bspec,
        simp add:image_def, erule bexE, blast)
 
 apply ((erule exE)+,
        drule sym, simp,
        simp add:image_def, (erule bexE)+, simp,
        (erule conjE)+,
        frule_tac x = x in val_nonzero_z[of v], assumption+, erule exE,
        frule_tac x = xa in val_nonzero_z[of v], assumption+, erule exE,
        simp) apply (
        subgoal_tac "a \<noteq> \<infinity> \<and> a \<noteq> -\<infinity>", subgoal_tac "aa \<noteq> \<infinity> \<and> aa \<noteq> -\<infinity>",
        cut_tac a = a in mem_ant, cut_tac a = aa in mem_ant, simp,
        (erule exE)+, simp add:a_z_z,
        thin_tac "c = ant z", frule sym, thin_tac "zb * z = za", simp)
 apply (subgoal_tac "0 < zb",
        cut_tac a = zc and b = zb in mult.commute, simp,
        simp add:pos_zmult_eq_1_iff,
        rule contrapos_pp, simp+,
        cut_tac x = 0 and y = zb in less_linear, simp,
        thin_tac "\<not> 0 < zb",
        erule disjE, simp,
        frule_tac i = 0 and j = z and k = zb in zmult_zless_mono_neg,
              assumption+, simp add:mult.commute)
 apply (rule contrapos_pp, simp+, thin_tac "a \<noteq> \<infinity> \<and> a \<noteq> - \<infinity>",
        erule disjE, simp, rotate_tac 5, drule sym,
        simp, simp, rotate_tac 5, drule sym, simp)
 apply (rule contrapos_pp, simp+,
        erule disjE, simp, rotate_tac 4,
        drule sym, simp, simp,
        rotate_tac 4, drule sym,
        simp)
 done
 
 lemma (in Corps) val_principal:"valuation K v \<Longrightarrow>
   \<exists>!x0. x0 \<in> v ` (carrier K - {\<zero>}) \<and>
      (\<forall>w \<in> v ` (carrier K). \<exists>(a::ant). w = a * x0) \<and> 0 < x0"
 by (rule ex_ex1I,
     frule val_principalTr1[of v], blast,
     rule_tac c = x0 and d = y in val_principalTr2[of v],
                  assumption+)
 
 lemma (in Corps) n_val_defTr:"\<lbrakk>valuation K v; w \<in> carrier K\<rbrakk> \<Longrightarrow>
                            \<exists>!a. a * Lv K v = v w"
 apply (rule ex_ex1I,
       frule AMin_k[of v],
       frule Lv_pos[of v], simp add:Lv_def,
       erule bexE,
       frule_tac x = k in val_nonzero_z[of v], simp, simp,
       erule exE, simp, (erule conjE)+)
 apply (case_tac "w = \<zero>\<^bsub>K\<^esub>", simp add:value_of_zero,
        frule_tac m = z in a_i_pos, blast)
 apply (frule amin_generateTr[of v],
        drule_tac x = w in bspec, simp, simp)
 apply (
        erule exE, simp add:asprod_mult,
        subst a_z_z[THEN sym], blast)
 apply (frule AMin_k[of v]) apply (erule bexE,
       frule Lv_pos[of v], simp add:Lv_def) apply (
       erule conjE,
       frule_tac x = k in val_nonzero_z[of v], assumption+,
       erule exE, simp) apply (
       case_tac "w = \<zero>\<^bsub>K\<^esub>", simp del:a_i_pos add:value_of_zero,
       subgoal_tac "y = \<infinity>", simp, rule contrapos_pp, simp+,
       cut_tac a = a in mem_ant, simp,
       erule disjE, simp, erule exE, simp add:a_z_z)
 apply (rule contrapos_pp, simp+,
       cut_tac a = y in mem_ant, simp, erule disjE, simp,
       erule exE, simp add:a_z_z,
       frule_tac x = w in val_nonzero_z[of v], assumption+,
       erule exE, simp, cut_tac a = a in mem_ant,
       erule disjE, simp, frule sym, thin_tac "- \<infinity> = ant za", simp,
       erule disjE, erule exE, simp add:a_z_z)
 apply (cut_tac a = y in mem_ant,
       erule disjE, simp, rotate_tac 3, drule sym,
       simp, erule disjE, erule exE, simp add:a_z_z, frule sym,
       thin_tac "zb * z = za", simp, simp,
       rotate_tac 3, drule sym,
       simp, simp, frule sym, thin_tac "\<infinity> = ant za", simp)
 done
 
 lemma (in Corps) n_valTr:"\<lbrakk> valuation K v; x \<in> carrier K\<rbrakk>  \<Longrightarrow>
              (THE l. (l * (Lv K v)) = v x)*(Lv K v) = v x"
 by (rule theI', rule n_val_defTr, assumption+)
 
 lemma (in Corps) n_val:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk>  \<Longrightarrow>
                            (n_val K v x)*(Lv K v) = v x"
 by (frule n_valTr[of v x], assumption+, simp add:n_val_def)
 
 lemma (in Corps) val_pos_n_val_pos:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk>  \<Longrightarrow>
            (0 \<le> v x) = (0 \<le> n_val K v x)"
 apply (frule n_val[of v x], assumption+,
        drule sym,
        frule Lv_pos[of v],
        frule Lv_z[of v], erule exE, simp)
 apply (frule_tac w = z and x = 0 and y = "n_val K v x" in amult_pos_mono_r,
        simp add:amult_0_l)
 done
 
 lemma (in Corps) n_val_in_aug_inf:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
                            n_val K v x \<in> Z\<^sub>\<infinity>"
 apply (cut_tac field_is_ring, frule Ring.ring_zero[of "K"],
        frule Lv_pos[of v],
        frule Lv_z[of v], erule exE,
        simp add:aug_inf_def)
 apply (rule contrapos_pp, simp+)
 apply (case_tac "x = \<zero>\<^bsub>K\<^esub>", simp,
        frule n_val[of v "\<zero>"],
        simp add:value_of_zero, simp add:value_of_zero)
 
 apply (frule n_val[of v x], simp,
        frule val_nonzero_z[of v x], assumption+,
        erule exE, simp, rotate_tac -2, drule sym,
        simp)
 done
 
 lemma (in Corps) n_val_0:"\<lbrakk>valuation K v; x \<in> carrier K; v x = 0\<rbrakk>
        \<Longrightarrow>  n_val K v x = 0"
 by (frule Lv_z[of v], erule exE,
        frule Lv_pos[of v],
        frule n_val[of v x], simp, simp,
        rule_tac z = z and a = "n_val K v x" in a_a_z_0, assumption+)
 
 lemma (in Corps) value_n0_n_val_n0:"\<lbrakk>valuation K v; x \<in> carrier K; v x \<noteq> 0\<rbrakk> \<Longrightarrow>
                              n_val K v x \<noteq> 0"
 apply (frule n_val[of v x],
        rule contrapos_pp, simp+, frule Lv_z[of v],
        erule exE, simp, simp only:ant_0[THEN sym])
 apply (rule contrapos_pp, simp+,
        simp add:a_z_z)
 done
 
 lemma (in Corps) val_0_n_val_0:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
                          (v x = 0) = (n_val K v x = 0)"
 apply (rule iffI,
        simp add:n_val_0)
 apply (rule contrapos_pp, simp+,
        frule value_n0_n_val_n0[of v x], assumption+)
 apply simp
 done
 
 lemma (in Corps) val_noninf_n_val_noninf:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
       (v x \<noteq> \<infinity>) = (n_val K v x \<noteq> \<infinity>)"
 by (frule Lv_z[of v], erule exE,
        frule Lv_pos[of v], simp,
        frule n_val[THEN sym, of v x],simp, simp,
        thin_tac "v x = n_val K v x * ant z",
        rule iffI, rule contrapos_pp, simp+,
        cut_tac mem_ant[of "n_val K v x"], erule disjE, simp,
        erule disjE, erule exE, simp add:a_z_z, simp, simp)
 
 lemma (in Corps) val_inf_n_val_inf:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
       (v x = \<infinity>) = (n_val K v x = \<infinity>)"
 by (cut_tac val_noninf_n_val_noninf[of v x], simp, assumption+)
 
 lemma (in Corps) val_eq_n_val_eq:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K\<rbrakk>
   \<Longrightarrow>  (v x = v y) = (n_val K v x = n_val K v y)"
 apply (subst n_val[THEN sym, of v x], assumption+,
        subst n_val[THEN sym, of v y], assumption+,
        frule Lv_pos[of v], frule Lv_z[of v], erule exE, simp,
        frule_tac s = z in zless_neq[THEN not_sym, of "0"])
 apply (rule iffI)
 apply (rule_tac z = z in amult_eq_eq_r[of _ "n_val K v x" "n_val K v y"],
          assumption+)
 apply simp
 done
 
 lemma (in Corps) val_poss_n_val_poss:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk>  \<Longrightarrow>
            (0 < v x) = (0 < n_val K v x)"
 apply (simp add:less_le,
        frule val_pos_n_val_pos[of v x], assumption+,
        rule iffI, erule conjE, simp,
        simp add:value_n0_n_val_n0[of v x])
 apply (drule sym,
        erule conjE, simp,
        frule_tac val_0_n_val_0[THEN sym, of v x], assumption+,
        simp)
 done
 
 lemma (in Corps) n_val_Pg:"valuation K v \<Longrightarrow> n_val K v (Pg K v) = 1"
 apply (frule val_Pg[of v], simp, (erule conjE)+,
        frule n_val[of v "Pg K v"], simp, frule Lv_z[of v], erule exE, simp,
        frule Lv_pos[of v], simp, frule_tac i = 0 and j = z in zless_neq)
 apply (rotate_tac -1, frule not_sym, thin_tac "0 \<noteq> z",
        subgoal_tac "n_val K v (Pg K v) * ant z = 1 * ant z",
        rule_tac z = z in adiv_eq[of _ "n_val K v (Pg K v)" "1"], assumption+,
        simp add:amult_one_l)
 done
 
 lemma (in Corps) n_val_valuationTr1:"valuation K v \<Longrightarrow>
                            \<forall>x\<in>carrier K. n_val K v x \<in> Z\<^sub>\<infinity>"
 by (rule ballI,
       frule n_val[of v], assumption,
       frule_tac x = x in value_in_aug_inf[of v], assumption,
       frule Lv_pos[of v], simp add:aug_inf_def,
       frule Lv_z[of v], erule exE, simp,
       rule contrapos_pp, simp+)
 
 lemma (in Corps) n_val_t2p:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K\<rbrakk> \<Longrightarrow>
                    n_val K v (x \<cdot>\<^sub>r y) = n_val K v x + (n_val K v y)"
 apply (cut_tac field_is_ring,
        frule Ring.ring_tOp_closed[of K x y], assumption+,
        frule n_val[of v "x \<cdot>\<^sub>r y"], assumption+,
        frule Lv_pos[of "v"],
        simp add:val_t2p,
        frule n_val[THEN sym, of v x], assumption+,
        frule n_val[THEN sym, of v y], assumption+, simp,
        frule Lv_z[of v], erule exE, simp)
 apply (subgoal_tac "ant z \<noteq> 0")
 apply (frule_tac z1 = z in amult_distrib1[THEN sym, of _ "n_val K v x"
        "n_val K v y"], simp,
        thin_tac "n_val K v x * ant z + n_val K v y * ant z =
            (n_val K v x + n_val K v y) * ant z",
        rule_tac z = z and a = "n_val K v (x \<cdot>\<^sub>r y)" and
         b = "n_val K v x + n_val K v y" in adiv_eq, simp, assumption+, simp)
 done
 
 lemma (in Corps) n_val_valuationTr2:"\<lbrakk> valuation K v; x \<in> carrier K;
       y \<in> carrier K\<rbrakk>  \<Longrightarrow>
        amin (n_val K v x) (n_val K v y) \<le> (n_val K v ( x \<plusminus> y))"
 apply (frule n_val[THEN sym, of v x], assumption+,
        frule n_val[THEN sym, of v y], assumption+,
        frule n_val[THEN sym, of v "x \<plusminus> y"],
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        rule aGroup.ag_pOp_closed, assumption+)
 apply (frule amin_le_plus[of v x y], assumption+, simp,
        simp add:amult_commute[of _ "Lv K v"],
        frule Lv_z[of v], erule exE, simp,
        frule Lv_pos[of v], simp,
        simp add:amin_amult_pos, simp add:amult_pos_mono_l)
 done
 
 lemma (in Corps) n_val_valuation:"valuation K v \<Longrightarrow>
                                       valuation K (n_val K v)"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag)
 apply (frule Lv_z[of v], erule exE, frule Lv_pos[of v], simp,
        subst valuation_def)
 apply (rule conjI, simp add:n_val_def restrict_def extensional_def)
 apply (rule conjI, simp add:n_val_valuationTr1)
 apply (rule conjI, frule n_val[of v \<zero>],
        simp add:Ring.ring_zero,
        frule Lv_z[of v], erule exE, frule Lv_pos[of v],
        cut_tac mem_ant[of "n_val K v (\<zero>)"], erule disjE,
        simp add:value_of_zero,
        erule disjE, erule exE, simp add:a_z_z value_of_zero, assumption+)
 apply (rule conjI, rule ballI,
        frule_tac x = x in val_nonzero_noninf[of v], simp+,
        simp add:val_noninf_n_val_noninf)
 apply (rule conjI, (rule ballI)+, simp add:n_val_t2p,
        rule conjI, rule ballI, rule impI,
        frule Lv_z[of v], erule exE,
             frule Lv_pos[of v], simp,
        frule_tac x = x in n_val[of v], simp,
        frule_tac w1 = z and x1 = 0 and y1 = "n_val K v x" in
             amult_pos_mono_r[THEN sym], simp add:amult_0_l,
        frule_tac x = x in val_axiom4[of v], assumption+,
        frule_tac x1 = "1\<^sub>r \<plusminus> x" in n_val[THEN sym, of v],
        frule Ring.ring_is_ag[of "K"],
            rule aGroup.ag_pOp_closed, assumption+, simp add:Ring.ring_one,
            assumption,
        frule_tac w = z and x = 0 and y = "n_val K v (1\<^sub>r \<plusminus> x)"
            in amult_pos_mono_r,
        simp add:amult_0_l)
 
 apply (frule val_axiom5[of v], erule exE,
        (erule conjE)+,
        frule_tac x = x in value_n0_n_val_n0[of v], assumption+,
        frule_tac x = x in val_noninf_n_val_noninf, simp,
        blast)
 done
 
 lemma (in Corps) n_val_le_val:"\<lbrakk>valuation K v; x \<in> carrier K; 0 \<le> (v x)\<rbrakk>  \<Longrightarrow>
                  (n_val K v x) \<le>(v x)"
 by (subst n_val[THEN sym, of v x], assumption+,
        frule Lv_pos[of v],
        simp add:val_pos_n_val_pos[of v x],
        frule Lv_z[of v], erule exE,
        cut_tac b = z and x = "n_val K v x" in amult_pos, simp+,
        simp add:asprod_amult, simp add:amult_commute)
 
 lemma (in Corps) n_val_surj:"valuation K v \<Longrightarrow>
                                    \<exists>x\<in> carrier K. n_val K v x = 1"
 apply (frule Lv_z[of v], erule exE,
        frule Lv_pos[of v],
        frule AMin_k[of v], erule bexE, frule_tac x = k in n_val[of v], simp,
        simp add:Lv_def)
 apply (subgoal_tac "n_val K v k * ant z = 1 * ant z",
        subgoal_tac "z \<noteq> 0",
        frule_tac z = z and a = "n_val K v k" and b = 1 in amult_eq_eq_r,
          assumption, blast, simp, simp add:amult_one_l)
 done
 
 lemma (in Corps) n_value_in_aug_inf:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
                              n_val K v x \<in> Z\<^sub>\<infinity>"
 by (frule n_val[of v x], assumption,
     simp add:aug_inf_def, rule contrapos_pp, simp+,
     frule Lv_pos[of v], frule Lv_z[of v], erule exE, simp,
     frule value_in_aug_inf[of v x], assumption+, simp add:aug_inf_def)
 
 lemma (in Corps) val_surj_n_valTr:"\<lbrakk>valuation K v; \<exists>x \<in> carrier K. v x = 1\<rbrakk>
       \<Longrightarrow>  Lv K v = 1"
 apply (erule bexE,
        frule_tac x = x in n_val[of v],
        simp, frule Lv_pos[of v])
 apply (frule_tac w = "Lv K v" and x = "n_val K v x" in amult_1_both)
 apply simp+
 done
 
 lemma (in Corps) val_surj_n_val:"\<lbrakk>valuation K v; \<exists>x \<in> carrier K. v x = 1\<rbrakk> \<Longrightarrow>
                        (n_val K v) = v"
 apply (rule funcset_eq[of _ "carrier K"],
       simp add:n_val_def restrict_def extensional_def,
       simp add:valuation_def)
 apply (rule ballI,
        frule val_surj_n_valTr[of v], assumption+,
        frule_tac x = x in n_val[of v], assumption+,
        simp add:amult_one_r)
 done
 
 lemma (in Corps) n_val_n_val:"valuation K v \<Longrightarrow>
         n_val K (n_val K v)  = n_val K v"
 by (frule n_val_valuation[of v],
        frule n_val_surj[of v],
        simp add:val_surj_n_val)
 
 lemma nnonzero_annonzero:"0 < N \<Longrightarrow> an N \<noteq> 0"
 apply (simp only:an_0[THEN sym])
 apply (subst aneq_natneq, simp)
 done
 
 
 section "Valuation ring"
 
 definition
   Vr :: "[('r, 'm) Ring_scheme, 'r \<Rightarrow> ant] \<Rightarrow> ('r, 'm) Ring_scheme" where
   "Vr K v = Sr K ({x. x \<in> carrier K \<and> 0 \<le> (v x)})"
 
 definition
   vp :: "[('r, 'm) Ring_scheme, 'r \<Rightarrow> ant] \<Rightarrow> 'r set" where
   "vp K v = {x. x \<in> carrier (Vr K v) \<and> 0 < (v x)}"
 
 definition
   r_apow :: "[('r, 'm) Ring_scheme, 'r set, ant] \<Rightarrow> 'r set" where
   "r_apow R I a = (if a = \<infinity> then {\<zero>\<^bsub>R\<^esub>} else
                    (if a = 0 then carrier R else I\<^bsup>\<diamondsuit>R (na a)\<^esup>))"
                                           (** 0 \<le> a and a \<noteq> -\<infinity> **)
 
 abbreviation
   RAPOW  ("(3_\<^bsup> _ _\<^esup>)" [62,62,63]62) where
   "I\<^bsup>R a\<^esup> == r_apow R I a"
 
 lemma (in Ring) ring_pow_apow:"ideal R I \<Longrightarrow>
                   I\<^bsup>\<diamondsuit>R n\<^esup> =  I\<^bsup>R (an n)\<^esup>"
 apply (simp add:r_apow_def)
 apply (case_tac "n = 0", simp)
 apply (simp add:nnonzero_annonzero)
 apply (simp add:an_neq_inf na_an)
 done
 
 lemma (in Ring) r_apow_Suc:"ideal R I \<Longrightarrow> I\<^bsup>R (an (Suc 0))\<^esup> = I"
 apply (cut_tac an_1, simp add:r_apow_def)
 apply (simp add:a0_neq_1[THEN not_sym])
   apply (simp only:ant_1[THEN sym])
   apply (simp del:ant_1 add:z_neq_inf[of 1, THEN not_sym])
   apply (simp add:na_1)
   apply (simp add:idealprod_whole_r)
 done
 
 lemma (in Ring) apow_ring_pow:"ideal R I \<Longrightarrow>
                   I\<^bsup>\<diamondsuit>R n\<^esup> =  I\<^bsup>R (an n)\<^esup>"
 apply (simp add:r_apow_def)
 apply (case_tac "n = 0", simp add:an_0)
 apply (simp add: aless_nat_less[THEN sym],
        cut_tac an_neq_inf[of n],
        simp add: less_le[of 0 "an n"] na_an)
 done
 
 lemma (in Corps) Vr_ring:"valuation K v \<Longrightarrow> Ring (Vr K v)"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        simp add:Vr_def, rule Ring.Sr_ring, assumption+)
   apply (simp add:sr_def)
   apply (intro conjI subsetI)
 apply (simp_all add: value_of_one Ring.ring_one[of "K"])
 apply ((rule allI, rule impI)+,
        (erule conjE)+, rule conjI, rule aGroup.ag_pOp_closed, assumption+,
        rule aGroup.ag_mOp_closed, assumption+)
 apply (frule_tac x = x and y = "-\<^sub>a y" in amin_le_plus[of v], assumption+,
        rule aGroup.ag_mOp_closed, assumption+,
        simp add:val_minus_eq[of v]) apply (
        frule_tac z = 0 and x = "v x" and y = "v y" in amin_ge1, assumption+,
        frule_tac i = 0 and j = "amin (v x) (v y)" and k = "v (x \<plusminus> -\<^sub>a y)" in
        ale_trans, assumption+, simp)
   by (simp add: Ring.ring_tOp_closed aadd_two_pos val_t2p)
 
 lemma (in Corps) val_pos_mem_Vr:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
                              (0 \<le> (v x)) = (x \<in> carrier (Vr K v))"
 by (rule iffI, (simp add:Vr_def Sr_def)+)
 
 lemma (in Corps) val_poss_mem_Vr:"\<lbrakk>valuation K v; x \<in> carrier K; 0 < (v x)\<rbrakk>
                         \<Longrightarrow>  x \<in> carrier (Vr K v)"
 by (frule aless_imp_le[of "0" "v x"], simp add:val_pos_mem_Vr)
 
 lemma (in Corps) Vr_one:"valuation K v \<Longrightarrow> 1\<^sub>r\<^bsub>K\<^esub> \<in> carrier (Vr K v)"
 by (cut_tac field_is_ring, frule Ring.ring_one[of "K"],
        frule val_pos_mem_Vr[of v "1\<^sub>r"], assumption+,
        simp add:value_of_one)
 
 lemma (in Corps) Vr_mem_f_mem:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v)\<rbrakk>
      \<Longrightarrow>  x \<in> carrier K"
 by (simp add:Vr_def Sr_def)
 
 lemma (in Corps) Vr_0_f_0:"valuation K v \<Longrightarrow> \<zero>\<^bsub>Vr K v\<^esub> = \<zero>"
 by (simp add:Vr_def Sr_def)
 
 lemma (in Corps) Vr_1_f_1:"valuation K v \<Longrightarrow> 1\<^sub>r\<^bsub>(Vr K v)\<^esub> = 1\<^sub>r"
 by (simp add:Vr_def Sr_def)
 
 lemma (in Corps) Vr_pOp_f_pOp:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
        y \<in> carrier (Vr K v)\<rbrakk> \<Longrightarrow>  x \<plusminus>\<^bsub>Vr K v\<^esub> y = x \<plusminus> y"
 by (simp add:Vr_def Sr_def)
 
 lemma (in Corps) Vr_mOp_f_mOp:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v)\<rbrakk>
                      \<Longrightarrow> -\<^sub>a\<^bsub>(Vr K v)\<^esub> x = -\<^sub>a x"
 by (simp add:Vr_def Sr_def)
 
 lemma (in Corps) Vr_tOp_f_tOp:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
                      y \<in> carrier(Vr K  v)\<rbrakk> \<Longrightarrow>  x \<cdot>\<^sub>r\<^bsub>(Vr K v)\<^esub> y = x \<cdot>\<^sub>r y"
 by (simp add:Vr_def Sr_def)
 
 lemma (in Corps) Vr_pOp_le:"\<lbrakk>valuation K v; x \<in> carrier K;
        y \<in> carrier (Vr K v)\<rbrakk>  \<Longrightarrow> v x \<le> (v x + (v y))"
 apply (frule val_pos_mem_Vr[THEN sym, of v y],
        simp add:Vr_mem_f_mem, simp, frule aadd_pos_le[of "v y" "v x"],
        simp add:aadd_commute)
 done
 
 lemma (in Corps) Vr_integral:"valuation K v \<Longrightarrow> Idomain (Vr K v)"
 apply (simp add:Idomain_def,
        simp add:Vr_ring, simp add:Idomain_axioms_def,
        rule allI, rule impI, rule allI, (rule impI)+,
        simp add:Vr_tOp_f_tOp, simp add:Vr_0_f_0)
 apply (rule contrapos_pp, simp+, erule conjE,
        cut_tac field_is_idom,
        frule_tac x = a in Vr_mem_f_mem[of v], assumption,
        frule_tac x = b in Vr_mem_f_mem[of v], assumption,
        frule_tac x = a and y = b in Idomain.idom_tOp_nonzeros[of "K"],
        assumption+, simp)
 done
 
 lemma (in Corps) Vr_exp_mem:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v)\<rbrakk>
       \<Longrightarrow>  x^\<^bsup>K n\<^esup> \<in> carrier (Vr K v)"
 by (frule Vr_ring[of v],
        induct_tac n, simp add:Vr_one,
        simp add:Vr_tOp_f_tOp[THEN sym, of v],
        simp add:Ring.ring_tOp_closed)
 
 lemma (in Corps) Vr_exp_f_exp:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v)\<rbrakk> \<Longrightarrow>
                                     x^\<^bsup>(Vr K v) n\<^esup> =  x^\<^bsup>K n\<^esup>"
 apply (induct_tac n,
       simp, simp add:Vr_1_f_1, simp,
       thin_tac "x^\<^bsup>(Vr K v) n\<^esup> = x^\<^bsup>K n\<^esup>")
 apply (rule Vr_tOp_f_tOp, assumption+,
       simp add:Vr_exp_mem, assumption)
 done
 
 lemma (in Corps) Vr_potent_nonzero:"\<lbrakk>valuation K v;
       x \<in> carrier (Vr K v) - {\<zero>\<^bsub>Vr K v\<^esub>}\<rbrakk>  \<Longrightarrow> x^\<^bsup>K n\<^esup> \<noteq> \<zero>\<^bsub>Vr K v\<^esub>"
 apply (frule Vr_mem_f_mem[of v x], simp,
        simp add:Vr_0_f_0, erule conjE)
 apply (frule Vr_mem_f_mem[of v x], assumption+,
         simp add:field_potent_nonzero)
 done
 
 lemma (in Corps) elem_0_val_if:"\<lbrakk>valuation K v; x \<in> carrier K; v x = 0\<rbrakk>
               \<Longrightarrow> x \<in> carrier (Vr K v) \<and> x\<^bsup>\<hyphen> K\<^esup> \<in> carrier (Vr K v)"
 apply (frule val_pos_mem_Vr[of v x], assumption, simp)
 apply (frule value_zero_nonzero[of "v" "x"], simp add:Vr_mem_f_mem, simp)
 apply (frule value_of_inv[of v x], assumption+,
        simp, subst val_pos_mem_Vr[THEN sym, of v "x\<^bsup>\<hyphen>K\<^esup>"], assumption+,
        cut_tac invf_closed[of x], simp+)
 done
 
 lemma (in Corps) elem0val:"\<lbrakk>valuation K v; x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
       (v x = 0) = ( x \<in> carrier (Vr K v) \<and> x\<^bsup>\<hyphen> K\<^esup> \<in> carrier (Vr K v))"
 apply (rule iffI, rule elem_0_val_if[of v], assumption+,
        erule conjE)
 apply (simp add:val_pos_mem_Vr[THEN sym, of v x],
       frule Vr_mem_f_mem[of v "x\<^bsup>\<hyphen>K\<^esup>"], assumption+,
       simp add:val_pos_mem_Vr[THEN sym, of v "x\<^bsup>\<hyphen>K\<^esup>"],
       simp add:value_of_inv, frule ale_minus[of "0" "- v x"],
       simp add:a_minus_minus)
 done
 
 lemma (in Corps) ideal_inc_elem0val_whole:"\<lbrakk> valuation K v; x \<in> carrier K;
  v x = 0; ideal (Vr K v) I; x \<in> I\<rbrakk> \<Longrightarrow>  I = carrier (Vr K v)"
 apply (frule elem_0_val_if[of v x], assumption+, erule conjE,
        frule value_zero_nonzero[of v x], assumption+,
        frule Vr_ring[of v],
        frule_tac I = I and x = x and r = "x\<^bsup>\<hyphen>K\<^esup>" in
        Ring.ideal_ring_multiple[of "Vr K v"], assumption+,
        cut_tac invf_closed1[of x], simp+, (erule conjE)+)
 apply (simp add:Vr_tOp_f_tOp, cut_tac invf_inv[of x], simp+,
        simp add: Vr_1_f_1[THEN sym, of v],
        simp add:Ring.ideal_inc_one, simp+)
 done
 
 lemma (in Corps) vp_mem_Vr_mem:"\<lbrakk>valuation K v; x \<in> (vp K v)\<rbrakk> \<Longrightarrow>
                                                 x \<in> carrier (Vr K v)"
 by (rule val_poss_mem_Vr[of v x], assumption+, (simp add:vp_def
        Vr_def Sr_def)+)
 
 lemma (in Corps) vp_mem_val_poss:"\<lbrakk> valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
                                    (x \<in> vp K v) = (0 < (v x))"
 by (simp add:vp_def, simp add:Vr_def Sr_def less_ant_def)
 
 lemma (in Corps) Pg_in_Vr:"valuation K v \<Longrightarrow>  Pg K v \<in> carrier (Vr K v)"
 by (frule val_Pg[of v], erule conjE,
     frule Lv_pos[of v], drule sym,
     simp, erule conjE,
     simp add:val_poss_mem_Vr)
 
 lemma (in Corps) vp_ideal:"valuation K v \<Longrightarrow>  ideal (Vr K v) (vp K v)"
 apply (cut_tac field_is_ring,
        frule Vr_ring[of v],
        rule Ring.ideal_condition1, assumption+,
        rule subsetI, simp add:vp_mem_Vr_mem,
        simp add:vp_def)
 apply (frule val_Pg[of v],
        frule Lv_pos[of v], simp, (erule conjE)+,
        drule sym, simp,
        frule val_poss_mem_Vr[of v "Pg K v"], assumption+, blast)
 
 apply ((rule ballI)+,
        frule_tac x = x in vp_mem_Vr_mem[of v], assumption) apply (
        frule_tac x = y in vp_mem_Vr_mem[of v], assumption,
        simp add:vp_def,
        frule Ring.ring_is_ag[of "Vr K v"],
        frule_tac x = x and y = y in aGroup.ag_pOp_closed, assumption+, simp)
  apply (simp add:Vr_pOp_f_pOp,
         cut_tac x = "v x" and y = "v y" in amin_le_l,
         frule_tac x = x and y = y in amin_le_plus,
         (simp add:Vr_mem_f_mem)+,
        (frule_tac z = 0 and x = "v x" and y = "v y" in amin_gt, assumption+),
        rule_tac x = 0 and y = "amin (v x) (v y)" and z = "v (x \<plusminus> y)" in
        less_le_trans, assumption+)
 apply ((rule ballI)+,
        frule_tac x1 = r in val_pos_mem_Vr[THEN sym, of v],
        simp add:Vr_mem_f_mem, simp,
        frule_tac x = x in vp_mem_Vr_mem[of v], simp add:Vr_pOp_f_pOp,
        simp add:vp_def, simp add:Ring.ring_tOp_closed,
        simp add:Vr_tOp_f_tOp)
 apply (frule_tac x = r in Vr_mem_f_mem[of v], assumption+,
        frule_tac x = x in Vr_mem_f_mem[of v], assumption+,
        simp add:val_t2p, simp add:aadd_pos_poss)
 done
 
 lemma (in Corps) vp_not_whole:"valuation K v \<Longrightarrow>
                        (vp K v) \<noteq> carrier (Vr K v)"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule Vr_ring[of v])
 apply (rule contrapos_pp, simp+,
        drule sym,
        frule Ring.ring_one[of "Vr K v"], simp,
        simp add:Vr_1_f_1,
        frule Ring.ring_one[of "K"])
 apply (simp only:vp_mem_val_poss[of v "1\<^sub>r"],
         simp add:value_of_one)
 done
 
 lemma (in Ring) elem_out_ideal_nonzero:"\<lbrakk>ideal R I; x \<in> carrier R;
         x \<notin> I\<rbrakk> \<Longrightarrow> x \<noteq> \<zero>\<^bsub>R\<^esub>"
 by (rule contrapos_pp, simp+, frule ideal_zero[of I],
        simp)
 
 lemma (in Corps) vp_prime:"valuation K v \<Longrightarrow> prime_ideal (Vr K v) (vp K v)"
 apply (simp add:prime_ideal_def, simp add:vp_ideal)
 apply (rule conjI)
 (** if the unit is contained in (vp K v), then (vp K v) is
     the whole ideal, this contradicts vp_not_whole **)
 apply (rule contrapos_pp, simp+,
        frule Vr_ring[of v],
        frule vp_ideal[of v],
        frule Ring.ideal_inc_one[of "Vr K v" "vp K v"], assumption+,
        simp add:vp_not_whole[of v]) (* done*)
 
 (** if x \<cdot>\<^bsub>(Vr K v)\<^esub> y is in (vp K v), then 0 < v (x \<cdot>\<^sub>K y). We have
     0 \<le> (v x) and 0 \<le> (v y), because x and y are elements of Vr K v.
     Since v (x \<cdot>\<^sub>K y) = (v x) + (v y), we have 0 < (v x) or 0 < (v y).
    To obtain the final conclusion, we suppose \<not> (x \<in> vp K v \<or> y \<in> vp K v)
    then, we have (v x) = 0 and (v y) = 0. Frome this, we have v (x \<cdot>\<^sub>K y) =
    0. Contradiction.  *)
 apply ((rule ballI)+, rule impI, rule contrapos_pp, simp+, (erule conjE)+,
        frule Vr_ring[of v]) apply (
        frule_tac x = x in Vr_mem_f_mem[of v], assumption) apply (
        frule_tac x = y in Vr_mem_f_mem[of v], assumption) apply (
        frule vp_ideal[of v],
        frule_tac x = x in Ring.elem_out_ideal_nonzero[of "Vr K v" "vp K v"],
        assumption+) apply (
        frule_tac x = y in Ring.elem_out_ideal_nonzero[of "Vr K v" "vp K v"],
        assumption+, simp add:Vr_0_f_0,
        simp add:Vr_tOp_f_tOp) apply (
        frule_tac x = "x \<cdot>\<^sub>r y" in vp_mem_val_poss[of v],
        cut_tac field_is_ring, simp add:Ring.ring_tOp_closed, simp)
 apply (cut_tac field_is_ring,
        frule_tac x = x and y = y in Ring.ring_tOp_closed, assumption+,
        simp add:Ring.ring_tOp_closed[of "Vr K v"],
        simp add:vp_def, simp add:aneg_less,
        frule_tac x1 = x in val_pos_mem_Vr[THEN sym, of v], assumption+,
        frule_tac x1 = y in val_pos_mem_Vr[THEN sym, of v], assumption+,
        frule_tac P = "x \<in> carrier (Vr K v)" and Q = "0 \<le> v x" in eq_prop,
           assumption,
        frule_tac P = "y \<in> carrier (Vr K v)" and Q = "0 \<le> v y" in eq_prop,
           assumption,
        frule_tac x = "v x" and y = 0 in ale_antisym, assumption+,
        frule_tac x = "v y" and y = 0 in ale_antisym, assumption+,
        simp add:val_t2p aadd_0_l)
 done
 
 lemma (in Corps) vp_pow_ideal:"valuation K v \<Longrightarrow>
                       ideal (Vr K v) ((vp K v)\<^bsup>\<diamondsuit>(Vr K v) n\<^esup>)"
 by (frule Vr_ring[of v], frule vp_ideal[of v],
        simp add:Ring.ideal_pow_ideal)
 
 lemma (in Corps) vp_apow_ideal:"\<lbrakk>valuation K v; 0 \<le> n\<rbrakk> \<Longrightarrow>
                       ideal (Vr K v) ((vp K v)\<^bsup>(Vr K v) n\<^esup>)"
 apply (frule Vr_ring[of v])
 apply (case_tac "n = 0",
         simp add:r_apow_def, simp add:Ring.whole_ideal[of "Vr K v"])
 apply (case_tac "n = \<infinity>",
         simp add:r_apow_def, simp add:Ring.zero_ideal)
 apply (simp add:r_apow_def, simp add:vp_pow_ideal)
 done
 
 lemma (in Corps) mem_vp_apow_mem_Vr:"\<lbrakk>valuation K v;
        0 \<le> N; x \<in> vp K v \<^bsup>(Vr K v) N\<^esup>\<rbrakk>  \<Longrightarrow> x \<in> carrier (Vr K v)"
 by (frule Vr_ring[of v], frule vp_apow_ideal[of v N], assumption,
     simp add:Ring.ideal_subset)
 
 lemma (in Corps) elem_out_vp_unit:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
       x \<notin> vp K v\<rbrakk>  \<Longrightarrow> v x = 0"
 by (metis Vr_mem_f_mem ale_antisym aneg_le val_pos_mem_Vr vp_mem_val_poss)
 
 lemma (in Corps) vp_maximal:"valuation K v \<Longrightarrow>
                           maximal_ideal (Vr K v) (vp K v)"
 apply (frule Vr_ring[of v],
        simp add:maximal_ideal_def, simp add:vp_ideal)
 (** we know that vp is not a whole ideal, and so vp does not include 1 **)
 apply (frule vp_not_whole[of v],
        rule conjI, rule contrapos_pp, simp+, frule vp_ideal[of v],
        frule Ring.ideal_inc_one[of "Vr K v" "vp K v"], assumption+)
  apply simp
 (** onemore condition of maximal ideal **)
 apply (rule equalityI,
        rule subsetI, simp, erule conjE,
        case_tac "x = vp K v", simp, simp, rename_tac X)
 (** show exists a unit contained in X **)
 apply (frule_tac A = X in sets_not_eq[of _ "vp K v"], assumption+,
        erule bexE,
        frule_tac I = X and h = a in Ring.ideal_subset[of "Vr K v"],
        assumption+,
        frule_tac x = a in elem_out_vp_unit[of v], assumption+)
 (** since v a = 0, we see a is a unit **)
  apply (frule_tac x = a and I = X in ideal_inc_elem0val_whole [of v],
         simp add:Vr_mem_f_mem, assumption+)
 
  apply (rule subsetI, simp, erule disjE,
        simp add:prime_ideal_def, simp add:vp_ideal,
        simp add:Ring.whole_ideal, rule subsetI, simp add:vp_mem_Vr_mem)
 done
 
 lemma (in Corps) ideal_sub_vp:"\<lbrakk> valuation K v; ideal (Vr K v) I;
  I \<noteq> carrier (Vr K v)\<rbrakk> \<Longrightarrow> I \<subseteq> (vp K v)"
 apply (frule Vr_ring[of v], rule contrapos_pp, simp+)
  apply (simp add:subset_eq,
         erule bexE)
  apply (frule_tac h = x in Ring.ideal_subset[of "Vr K v" I], assumption+,
         frule_tac x = x in elem_out_vp_unit[of v], assumption+,
         frule_tac x = x in ideal_inc_elem0val_whole[of v _ I],
         simp add:Vr_mem_f_mem, assumption+, simp)
 done
 
 lemma (in Corps) Vr_local:"\<lbrakk>valuation K v; maximal_ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                    (vp K v) = I"
 apply (frule Vr_ring[of v],
        frule ideal_sub_vp[of v I], simp add:Ring.maximal_ideal_ideal)
 apply (simp add:maximal_ideal_def,
        frule conjunct2, fold maximal_ideal_def, frule conjunct1,
        rule Ring.proper_ideal, assumption+,simp add:maximal_ideal_def, assumption)
 apply (rule equalityI) prefer 2 apply assumption
  apply (rule contrapos_pp, simp+,
         frule sets_not_eq[of "vp K v" I], assumption+, erule bexE)
 apply (frule_tac x = a in vp_mem_Vr_mem[of v],
  frule Ring.maximal_ideal_ideal[of "Vr K v" "I"], assumption,
  frule_tac x = a in Ring.elem_out_ideal_nonzero[of "Vr K v" "I"],
            assumption+,
  frule vp_ideal[of v], rule Ring.ideal_subset[of "Vr K v" "vp K v"],
  assumption+)
 
 apply (frule_tac a = a in Ring.principal_ideal[of "Vr K v"], assumption+,
        frule Ring.maximal_ideal_ideal[of "Vr K v" I], assumption+,
        frule_tac ?I2.0 = "Vr K v \<diamondsuit>\<^sub>p a"in Ring.sum_ideals[of "Vr K v" "I"],
         simp add:Ring.maximal_ideal_ideal, assumption,
    frule_tac ?I2.0 = "Vr K v \<diamondsuit>\<^sub>p a"in Ring.sum_ideals_la1[of "Vr K v" "I"],
       assumption+,
    frule_tac ?I2.0 = "Vr K v \<diamondsuit>\<^sub>p a"in Ring.sum_ideals_la2[of "Vr K v" "I"],
       assumption+,
    frule_tac a = a in Ring.a_in_principal[of "Vr K v"], assumption+,
    frule_tac A = "Vr K v \<diamondsuit>\<^sub>p a" and B = "I \<minusplus>\<^bsub>(Vr K v)\<^esub> (Vr K v \<diamondsuit>\<^sub>p a)"
        and c = a in subsetD, assumption+)
    thm Ring.sum_ideals_cont[of "Vr K v" "vp K v" I ]
 apply (frule_tac B = "Vr K v \<diamondsuit>\<^sub>p a" in Ring.sum_ideals_cont[of "Vr K v"
        "vp K v" I], simp add:vp_ideal, assumption)
  apply (frule_tac a = a in Ring.ideal_cont_Rxa[of "Vr K v" "vp K v"],
         simp add:vp_ideal, assumption+)
  apply (simp add:maximal_ideal_def, (erule conjE)+,
       subgoal_tac "I \<minusplus>\<^bsub>(Vr K v)\<^esub> (Vr K v \<diamondsuit>\<^sub>p a) \<in> {J. ideal (Vr K v) J \<and> I \<subseteq> J}",
       simp, thin_tac "{J. ideal (Vr K v) J \<and> I \<subseteq> J} = {I, carrier (Vr K v)}")
  apply (erule disjE, simp)
  apply (cut_tac A = "carrier (Vr K v)" and B = "I \<minusplus>\<^bsub>Vr K v\<^esub> Vr K v \<diamondsuit>\<^sub>p a" and
         C = "vp K v" in subset_trans, simp, assumption,
         frule Ring.ideal_subset1[of "Vr K v" "vp K v"], simp add:vp_ideal,
         frule equalityI[of "vp K v" "carrier (Vr K v)"], assumption+,
         frule vp_not_whole[of v], simp)
  apply blast
 done
 
 lemma (in Corps) v_residue_field:"valuation K v \<Longrightarrow>
                                 Corps ((Vr K v)  /\<^sub>r (vp K v))"
 by (frule Vr_ring[of v],
        rule Ring.residue_field_cd [of "Vr K v" "vp K v"], assumption+,
        simp add:vp_maximal)
 
 lemma (in Corps) Vr_n_val_Vr:"valuation K v \<Longrightarrow>
      carrier (Vr K v) = carrier (Vr K (n_val K v))"
 by (simp add:Vr_def Sr_def,
        rule equalityI,
       (rule subsetI, simp, erule conjE, simp add:val_pos_n_val_pos),
       (rule subsetI, simp, erule conjE, simp add:val_pos_n_val_pos[THEN sym]))
 
 
 section "Ideals in a valuation ring"
 
 lemma (in Corps) Vr_has_poss_elem:"valuation K v \<Longrightarrow>
                  \<exists>x\<in>carrier (Vr K v) - {\<zero>\<^bsub>Vr K v\<^esub>}. 0 < v x"
 apply (frule val_Pg[of v], erule conjE,
        frule Lv_pos[of v], drule sym,
        subst Vr_0_f_0, assumption+)
 apply (frule aeq_ale[of "Lv K v" "v (Pg K v)"],
        frule aless_le_trans[of "0" "Lv K v" "v (Pg K v)"], assumption+,
        frule val_poss_mem_Vr[of v "Pg K v"],
        simp, assumption, blast)
 done
 
 lemma (in Corps) vp_nonzero:"valuation K v \<Longrightarrow>  vp K v \<noteq>  {\<zero>\<^bsub>Vr K v\<^esub>}"
 apply (frule Vr_has_poss_elem[of v], erule bexE,
        simp, erule conjE,
        frule_tac x1 = x in vp_mem_val_poss[THEN sym, of v],
        simp add:Vr_mem_f_mem, simp, rule contrapos_pp, simp+)
 done
 
 lemma (in Corps) field_frac_mul:"\<lbrakk>x \<in> carrier K; y \<in> carrier K; y \<noteq> \<zero>\<rbrakk>
         \<Longrightarrow>   x = (x \<cdot>\<^sub>r  (y\<^bsup>\<hyphen>K\<^esup>)) \<cdot>\<^sub>r y"
 apply (cut_tac invf_closed[of y],
        cut_tac field_is_ring,
        simp add:Ring.ring_tOp_assoc,
        subst linvf[of y], simp, simp add:Ring.ring_r_one[of K], simp)
 done
 
 lemma (in Corps) elems_le_val:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K;
        x \<noteq> \<zero>; v x \<le> (v y)\<rbrakk>  \<Longrightarrow> \<exists>r\<in>carrier (Vr K v). y = r \<cdot>\<^sub>r x"
 apply (frule ale_diff_pos[of "v x" "v y"], simp add:diff_ant_def,
        simp add:value_of_inv[THEN sym, of v x],
        cut_tac invf_closed[of "x"],
        simp only:val_t2p[THEN sym, of v y "x\<^bsup>\<hyphen>K\<^esup>"])
 apply (cut_tac field_is_ring,
        frule_tac x = y and y = "x\<^bsup>\<hyphen>K\<^esup>" in Ring.ring_tOp_closed[of "K"],
        assumption+,
        simp add:val_pos_mem_Vr[of v "y \<cdot>\<^sub>r (x\<^bsup>\<hyphen>K\<^esup>)"],
        frule field_frac_mul[of y x], assumption+, blast)
 apply simp
 done
 
 lemma (in Corps) val_Rxa_gt_a:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v) - {\<zero>};
  y \<in> carrier (Vr K v);  y \<in> Rxa (Vr K v) x\<rbrakk> \<Longrightarrow> v x \<le> (v y)"
 apply (simp add:Rxa_def,
        erule bexE,
        simp add:Vr_tOp_f_tOp, (erule conjE)+,
         frule_tac x = r in Vr_mem_f_mem[of v], assumption+,
         frule_tac x = x in Vr_mem_f_mem[of v], assumption+)
 apply (subst val_t2p, assumption+,
        simp add:val_pos_mem_Vr[THEN sym, of v],
        frule_tac y = "v r" in aadd_le_mono[of "0" _ "v x"],
        simp add:aadd_0_l)
 done
 
 lemma (in Corps) val_Rxa_gt_a_1:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
 y \<in> carrier (Vr K v); x \<noteq> \<zero>; v x \<le> (v y)\<rbrakk> \<Longrightarrow> y \<in> Rxa (Vr K v) x"
 apply (frule_tac x = x in Vr_mem_f_mem[of v], assumption+,
        frule_tac x = y in Vr_mem_f_mem[of v], assumption+,
        frule v_ale_diff[of v x y], assumption+,
        cut_tac invf_closed[of x],
        cut_tac field_is_ring, frule Ring.ring_tOp_closed[of K y "x\<^bsup>\<hyphen>K\<^esup>"],
         assumption+)
 apply (simp add:val_pos_mem_Vr[of "v" "y \<cdot>\<^sub>r (x\<^bsup>\<hyphen>K\<^esup>)"],
        frule field_frac_mul[of "y" "x"], assumption+,
        simp add:Rxa_def, simp add:Vr_tOp_f_tOp, blast, simp)
 done
 
 lemma (in Corps) eqval_inv:"\<lbrakk>valuation K v; x \<in> carrier K; y \<in> carrier K;
        y \<noteq> \<zero>; v x = v y\<rbrakk> \<Longrightarrow>  0 = v (x \<cdot>\<^sub>r (y\<^bsup>\<hyphen>K\<^esup>))"
 by (cut_tac invf_closed[of y],
        simp add:val_t2p value_of_inv, simp add:aadd_minus_r,
        simp)
 
 lemma (in Corps) eq_val_eq_idealTr:"\<lbrakk>valuation K v;
       x \<in> carrier (Vr K v) - {\<zero>}; y \<in> carrier  (Vr K v); v x \<le> (v y)\<rbrakk> \<Longrightarrow>
                        Rxa (Vr K v) y \<subseteq>  Rxa (Vr K v) x"
 apply (frule val_Rxa_gt_a_1[of v x y], simp+,
        erule conjE)
 apply (frule_tac x = x in Vr_mem_f_mem[of v], assumption+,
        frule Vr_ring[of v],
        frule Ring.principal_ideal[of "Vr K v" "x"], assumption,
        frule Ring.ideal_cont_Rxa[of "Vr K v" "(Vr K v) \<diamondsuit>\<^sub>p x" "y"],
   assumption+)
 done
 
 lemma (in Corps) eq_val_eq_ideal:"\<lbrakk>valuation K v;
       x \<in> carrier (Vr K v); y \<in> carrier  (Vr K v); v x = v y\<rbrakk>
        \<Longrightarrow> Rxa (Vr K v) x = Rxa (Vr K v) y"
 apply (case_tac "x = \<zero>\<^bsub>K\<^esub>",
        simp add:value_of_zero,
        frule value_inf_zero[of v y],
        simp add:Vr_mem_f_mem, rule sym, assumption, simp)
 apply (rule equalityI,
        rule eq_val_eq_idealTr[of v y x], assumption+,
        drule sym, simp,
        rule contrapos_pp, simp+, simp add:value_of_zero,
        frule Vr_mem_f_mem[of v x], assumption+,
        frule value_inf_zero[of v x], assumption+,
        rule sym, assumption, simp, simp, simp)
 apply (rule eq_val_eq_idealTr[of v x y], assumption+, simp,
        assumption, rule aeq_ale, assumption+)
 done
 
 lemma (in Corps) eq_ideal_eq_val:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
 y \<in> carrier (Vr K v); Rxa (Vr K v) x = Rxa (Vr K v) y\<rbrakk>  \<Longrightarrow> v x = v y"
 apply (case_tac "x = \<zero>\<^bsub>K\<^esub>", simp,
        drule sym,
        frule Vr_ring[of v],
        frule Ring.a_in_principal[of "Vr K v" y], assumption+, simp,
        thin_tac "Vr K v \<diamondsuit>\<^sub>p y = Vr K v \<diamondsuit>\<^sub>p (\<zero>)", simp add:Rxa_def,
        erule bexE, simp add:Vr_0_f_0[of v, THEN sym])
 apply (simp add:Vr_tOp_f_tOp, simp add:Vr_0_f_0,
        frule_tac x = r in Vr_mem_f_mem[of v], assumption+,
        cut_tac field_is_ring, simp add:Ring.ring_times_x_0)
 apply (frule Vr_ring[of v],
        frule val_Rxa_gt_a[of v x y], simp,
        simp)
 apply (drule sym,
        frule Ring.a_in_principal[of "Vr K v" "y"], simp, simp)
 apply (frule val_Rxa_gt_a[of v y x],
        simp, rule contrapos_pp, simp+,
        frule Ring.a_in_principal[of "Vr K v" "x"], assumption+,
        simp add:Rxa_def,
        erule bexE, simp add:Vr_tOp_f_tOp, cut_tac field_is_ring,
        frule_tac x = r in Vr_mem_f_mem[of v], assumption+,
        simp add:Ring.ring_times_x_0, simp,
        frule Ring.a_in_principal[of "Vr K v" "x"], assumption+, simp,
        rule ale_antisym, assumption+)
 done
 
 lemma (in Corps) zero_val_gen_whole:
  "\<lbrakk>valuation K v; x \<in> carrier (Vr K v)\<rbrakk> \<Longrightarrow>
              (v x = 0) = (Rxa (Vr K v) x = carrier (Vr K v))"
 apply (frule Vr_mem_f_mem[of v x], assumption,
        frule Vr_ring[of v])
 apply (rule iffI,
        frule Ring.principal_ideal[of "Vr K v" "x"], assumption+,
        frule Ring.a_in_principal[of "Vr K v" "x"], assumption+,
        rule ideal_inc_elem0val_whole[of v x "Vr K v \<diamondsuit>\<^sub>p x"], assumption+,
        frule Ring.ring_one[of "Vr K v"],
        frule eq_set_inc[of "1\<^sub>r\<^bsub>(Vr K v)\<^esub>"
               "carrier (Vr K v)" "Vr K v \<diamondsuit>\<^sub>p x"], drule sym, assumption,
        thin_tac "1\<^sub>r\<^bsub>(Vr K v)\<^esub> \<in> carrier (Vr K v)",
        thin_tac "Vr K v \<diamondsuit>\<^sub>p x = carrier (Vr K v)")
 apply (simp add:Rxa_def, erule bexE,
        simp add:Vr_1_f_1, simp add:Vr_tOp_f_tOp,
        frule value_of_one[of v], simp,
        frule_tac x = r in Vr_mem_f_mem[of v], assumption+,
        cut_tac field_is_ring, simp add:val_t2p,
        simp add:val_pos_mem_Vr[THEN sym, of v],
        rule contrapos_pp, simp+,
        cut_tac less_le[THEN sym, of "0" "v x"], drule not_sym, simp,
        frule_tac x = "v r" and y = "v x" in aadd_pos_poss, assumption+,
        simp)
 done
 
 lemma (in Corps) elem_nonzeroval_gen_proper:"\<lbrakk> valuation K v;
       x \<in> carrier (Vr K v); v x \<noteq> 0\<rbrakk> \<Longrightarrow> Rxa (Vr K v) x \<noteq> carrier (Vr K v)"
 apply (rule contrapos_pp, simp+)
 apply (simp add: zero_val_gen_whole[THEN sym])
 done
 
 text\<open>We prove that Vr K v is a principal ideal ring\<close>
 
 definition
   LI :: "[('r, 'm) Ring_scheme, 'r \<Rightarrow> ant, 'r set] \<Rightarrow> ant" where
          (** The least nonzero value of I **)
  "LI K v I = AMin (v ` I)"
 
 definition
   Ig :: "[('r, 'm) Ring_scheme, 'r \<Rightarrow> ant, 'r set] \<Rightarrow> 'r" where
                                           (** Generator of I **)
   "Ig K v I = (SOME x. x \<in> I \<and> v x = LI K v I)"
 
 lemma (in Corps) val_in_image:"\<lbrakk>valuation K v; ideal (Vr K v) I; x \<in> I\<rbrakk> \<Longrightarrow>
                             v x \<in> v ` I"
 by (simp add:image_def, blast)
 
 lemma (in Corps) I_vals_nonempty:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                            v ` I \<noteq> {}"
 by (frule Vr_ring[of v],
     frule Ring.ideal_zero[of "Vr K v" "I"],
     assumption+, rule contrapos_pp, simp+)
 
 lemma (in Corps) I_vals_LBset:"\<lbrakk> valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                                           v ` I  \<subseteq> LBset 0"
 apply (frule Vr_ring[of v],
        rule subsetI, simp add:LBset_def, simp add:image_def)
 apply (erule bexE,
        frule_tac h = xa in Ring.ideal_subset[of "Vr K v" "I"], assumption+)
 apply (frule_tac x1 = xa in val_pos_mem_Vr[THEN sym, of v],
        simp add:Vr_mem_f_mem, simp)
 done
 
 lemma (in Corps) LI_pos:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow> 0 \<le> LI K v I"
 apply (simp add:LI_def,
        frule I_vals_LBset[of v],
        simp add:ant_0[THEN sym],
        frule I_vals_nonempty[of v], simp only:ant_0)
 
 apply (simp only:ant_0[THEN sym], frule AMin[of "v ` I" "0"], assumption,
        erule conjE, frule subsetD[of "v ` I" "LBset (ant 0)" "AMin (v ` I)"],
        assumption+, simp add:LBset_def)
 done
 
 lemma (in Corps) LI_poss:"\<lbrakk>valuation K v; ideal (Vr K v) I;
                  I \<noteq> carrier (Vr K v)\<rbrakk> \<Longrightarrow> 0 < LI K v I"
 apply (subst less_le)
 apply (simp add:LI_pos)
 apply (rule contrapos_pp, simp+)
 
 apply (simp add:LI_def,
        frule I_vals_LBset[of v], assumption+,
        simp add:ant_0[THEN sym],
        frule I_vals_nonempty[of v], assumption+, simp only:ant_0)
 
 apply (simp only:ant_0[THEN sym], frule AMin[of "v ` I" "0"], assumption,
        erule conjE, frule subsetD[of "v ` I" "LBset (ant 0)" "AMin (v ` I)"],
        assumption+, simp add:LBset_def)
 
 apply (thin_tac "\<forall>x\<in>I. ant 0 \<le> v x",
        thin_tac "v ` I \<subseteq> {x. ant 0 \<le> x}", simp add:image_def,
        erule bexE, simp add:ant_0)
 apply (frule Vr_ring[of v],
        frule_tac h = x in Ring.ideal_subset[of "Vr K v" "I"], assumption+,
        frule_tac x = x in zero_val_gen_whole[of v], assumption+,
        simp,
        frule_tac a = x in Ring.ideal_cont_Rxa[of "Vr K v" "I"], assumption+,
        simp, frule Ring.ideal_subset1[of "Vr K v" "I"], assumption+)
 apply (frule equalityI[of "I" "carrier (Vr K v)"], assumption+, simp)
 done
 
 lemma (in Corps) LI_z:"\<lbrakk>valuation K v; ideal (Vr K v) I; I \<noteq> {\<zero>\<^bsub>Vr K v\<^esub>}\<rbrakk> \<Longrightarrow>
                  \<exists>z. LI K v I = ant z"
 apply (frule Vr_ring[of v],
        frule Ring.ideal_zero[of "Vr K v" "I"], assumption+,
        cut_tac mem_ant[of "LI K v I"],
        frule LI_pos[of v I], assumption,
        erule disjE, simp,
        cut_tac minf_le_any[of "0"],
        frule ale_antisym[of "0" "-\<infinity>"], assumption+, simp)
 apply (erule disjE, simp,
        frule singleton_sub[of "\<zero>\<^bsub>Vr K v\<^esub>" "I"],
        frule sets_not_eq[of "I" "{\<zero>\<^bsub>Vr K v\<^esub>}"], assumption+,
        erule bexE, simp)
 
 apply (simp add:LI_def,
        frule I_vals_LBset[of v], assumption+,
        simp only:ant_0[THEN sym],
        frule I_vals_nonempty[of v], assumption+,
        frule AMin[of "v ` I" "0"], assumption, erule conjE)
 apply (frule_tac x = a in val_in_image[of v I], assumption+,
        drule_tac x = "v a" in bspec, simp,
        simp add:Vr_0_f_0,
        frule_tac x = a in val_nonzero_z[of v],
        simp add:Ring.ideal_subset Vr_mem_f_mem, assumption+,
        erule exE, simp,
        cut_tac x = "ant z" in inf_ge_any, frule_tac x = "ant z" in
        ale_antisym[of _ "\<infinity>"], assumption+, simp)
 done
 
 lemma (in Corps) LI_k:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                                 \<exists>k\<in> I. LI K v I = v k"
 by (simp add:LI_def,
        frule I_vals_LBset[of v], assumption+,
        simp only:ant_0[THEN sym],
        frule I_vals_nonempty[of v], assumption+,
        frule AMin[of "v ` I" "0"], assumption, erule conjE,
        thin_tac "\<forall>x\<in>v ` I. AMin (v ` I) \<le> x", simp add:image_def)
 
 lemma (in Corps) LI_infinity:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
              (LI K v I = \<infinity>)  = (I = {\<zero>\<^bsub>Vr K v\<^esub>})"
 apply (frule Vr_ring[of v])
 apply (rule iffI)
 apply (rule contrapos_pp, simp+,
        frule Ring.ideal_zero[of "Vr K v" "I"], assumption+,
        frule singleton_sub[of "\<zero>\<^bsub>Vr K v\<^esub>" "I"],
        frule sets_not_eq[of "I" "{\<zero>\<^bsub>Vr K v\<^esub>}"], assumption+,
        erule bexE,
        frule_tac h = a in Ring.ideal_subset[of "Vr K v" "I"], assumption+,
        simp add:Vr_0_f_0,
        frule_tac x = a in Vr_mem_f_mem[of v], assumption+,
        frule_tac x = a in val_nonzero_z[of v], assumption+,
        erule exE,
        simp add:LI_def,
        frule I_vals_LBset[of v], assumption+,
        simp only:ant_0[THEN sym],
        frule I_vals_nonempty[of v], assumption+,
        frule AMin[of "v ` I" "0"], assumption, erule conjE)
 apply (frule_tac h = a in Ring.ideal_subset[of "Vr K v" "I"], assumption+,
        frule_tac x = a in val_in_image[of v I], assumption+,
        drule_tac x = "v a" in bspec, simp)
  apply (frule_tac x = a in val_nonzero_z[of v], assumption+,
        erule exE, simp,
        cut_tac x = "ant z" in inf_ge_any, frule_tac x = "ant z" in
        ale_antisym[of _ "\<infinity>"], assumption+, simp)
 
 apply (frule sym, thin_tac "I = {\<zero>\<^bsub>Vr K v\<^esub>}",
        simp add:LI_def,
        frule I_vals_LBset[of v], assumption+,
        simp only:ant_0[THEN sym],
        frule I_vals_nonempty[of v], assumption+,
        frule AMin[of "v ` I" "0"], assumption, erule conjE,
        drule sym, simp,
        simp add:Vr_0_f_0 value_of_zero)
 done
 
 lemma (in Corps) val_Ig:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                            (Ig K v I) \<in> I \<and> v (Ig K v I) = LI K v I"
 by (simp add:Ig_def, rule someI2_ex,
     frule LI_k[of v I], assumption+, erule bexE,
     drule sym, blast, assumption)
 
 lemma (in Corps) Ig_nonzero:"\<lbrakk>valuation K v; ideal (Vr K v) I; I \<noteq> {\<zero>\<^bsub>Vr K v\<^esub>}\<rbrakk>
                   \<Longrightarrow> (Ig K v I) \<noteq> \<zero>"
 by (rule contrapos_pp, simp+,
     frule LI_infinity[of v I], assumption+,
     frule val_Ig[of v I], assumption+, erule conjE,
     simp add:value_of_zero)
 
 lemma (in Corps) Vr_ideal_npowf_closed:"\<lbrakk>valuation K v; ideal (Vr K v) I;
        x \<in> I; 0 < n\<rbrakk> \<Longrightarrow> x\<^bsub>K\<^esub>\<^bsup>n\<^esup> \<in> I"
 by (simp add:npowf_def, frule Vr_ring[of v],
       frule Ring.ideal_npow_closed[of "Vr K v" "I" "x" "nat n"], assumption+,
       simp, frule Ring.ideal_subset[of "Vr K v" "I" "x"], assumption+,
       simp add:Vr_exp_f_exp)
 
 lemma (in Corps) Ig_generate_I:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                         (Vr K v) \<diamondsuit>\<^sub>p (Ig K v I) = I"
 apply (frule Vr_ring[of v])
 apply (case_tac "I = carrier (Vr K v)",
    frule sym, thin_tac "I = carrier (Vr K v)",
    frule Ring.ring_one[of "Vr K v"],
    simp, simp add: Vr_1_f_1,
    frule val_Ig[of v I], assumption+, erule conjE,
    frule LI_pos[of v I], assumption+,
 
    simp add: LI_def cong del: image_cong_simp,
    frule I_vals_LBset[of v], assumption+,
    simp only: ant_0[THEN sym],
    frule I_vals_nonempty[of v], assumption+,
    frule AMin[of "v ` I" "0"], assumption, erule conjE,
 
    frule val_in_image[of v I "1\<^sub>r"], assumption+,
    drule_tac x = "v (1\<^sub>r)" in bspec, assumption+,
    simp add: value_of_one ant_0 cong del: image_cong_simp,
    simp add: zero_val_gen_whole[of v "Ig K v I"])
 
 apply (frule val_Ig[of v I], assumption+, (erule conjE)+,
        frule Ring.ideal_cont_Rxa[of "Vr K v" "I" "Ig K v I"], assumption+,
        rule equalityI, assumption+)
 
 apply (case_tac "LI K v I = \<infinity>",
        frule LI_infinity[of v I], simp,
        simp add:Rxa_def, simp add:Ring.ring_times_x_0,
        frule Ring.ring_zero, blast)
 
 apply (rule subsetI,
        case_tac "v x = 0",
        frule_tac x = x in Vr_mem_f_mem[of v],
        simp add:Ring.ideal_subset,
        frule_tac x = x in zero_val_gen_whole[of v],
        simp add:Ring.ideal_subset, simp,
        frule_tac a = x in Ring.ideal_cont_Rxa[of "Vr K v" "I"], assumption+,
        simp, frule Ring.ideal_subset1[of "Vr K v" "I"], assumption,
        frule equalityI[of "I" "carrier (Vr K v)"], assumption+, simp)
 apply (simp add:LI_def,
        frule I_vals_LBset[of v], assumption+,
        simp only:ant_0[THEN sym],
        frule I_vals_nonempty[of v], assumption+,
        frule AMin[of "v ` I" "0"], assumption, erule conjE,
        frule_tac x = "v x" in bspec,
        frule_tac x = x in val_in_image[of v I], assumption+,
        simp)
 apply (drule_tac x =  x in bspec, assumption,
        frule_tac y = x in eq_val_eq_idealTr[of v "Ig K v I"],
            simp add:Ring.ideal_subset,
        rule contrapos_pp, simp+, simp add:value_of_zero,
        simp add:Ring.ideal_subset, simp)
 
 apply (frule_tac a = x in Ring.a_in_principal[of "Vr K v"],
        simp add:Ring.ideal_subset, rule subsetD, assumption+)
 done
 
 lemma (in Corps) Pg_gen_vp:"valuation K v  \<Longrightarrow>
                           (Vr K v) \<diamondsuit>\<^sub>p (Pg K v) = vp K v"
 apply (frule vp_ideal[of v],
        frule Ig_generate_I[of v "vp K v"], assumption+,
        frule vp_not_whole[of v],
        frule eq_val_eq_ideal[of v "Ig K v (vp K v)" "Pg K v"],
        frule val_Ig [of v "vp K v"], assumption+, erule conjE,
        simp add:vp_mem_Vr_mem)
 
 apply (frule val_Pg[of v], erule conjE,
        frule Lv_pos[of v],
        rotate_tac -2, drule sym, simp,
        simp add:val_poss_mem_Vr)
 
 apply (thin_tac "Vr K v \<diamondsuit>\<^sub>p Ig K v (vp K v) = vp K v",
        frule val_Pg[of v], erule conjE,
        simp, frule val_Ig[of v "vp K v"], assumption+, erule conjE,
        simp, thin_tac "v (Pg K v) = Lv K v",
        thin_tac "Ig K v (vp K v) \<in> vp K v \<and> v (Ig K v (vp K v)) =
         LI K v (vp K v)", simp add:LI_def Lv_def,
        subgoal_tac "v ` vp K v = {x. x \<in> v ` carrier K \<and> 0 < x}",
        simp)
 
 apply (thin_tac "ideal (Vr K v) (vp K v)", thin_tac "Pg K v \<in> carrier K",
        thin_tac "Pg K v \<noteq> \<zero>",
        rule equalityI, rule subsetI,
        simp add:image_def vp_def, erule exE, erule conjE,
        (erule conjE)+,
        frule_tac x = xa in Vr_mem_f_mem[of v], assumption+, simp, blast)
 
 apply (rule subsetI, simp add:image_def vp_def, erule conjE, erule bexE, simp,
        frule_tac x = xa in val_poss_mem_Vr[of v], assumption+,
        cut_tac y = "v xa" in less_le[of "0"], simp, blast, simp)
 done
 
 lemma (in Corps) vp_gen_t:"valuation K v  \<Longrightarrow>
                 \<exists>t\<in>carrier (Vr K v). vp K v = (Vr K v) \<diamondsuit>\<^sub>p t"
 by (frule Pg_gen_vp[of v], frule Pg_in_Vr[of v], blast)
 
 lemma (in Corps) vp_gen_nonzero:"\<lbrakk>valuation K v; vp K v = (Vr K v) \<diamondsuit>\<^sub>p t\<rbrakk> \<Longrightarrow>
                  t \<noteq> \<zero>\<^bsub>Vr K v\<^esub>"
 apply (rule contrapos_pp, simp+,
        cut_tac Ring.Rxa_zero[of "Vr K v"], drule sym, simp,
        simp add:vp_nonzero)
 apply (simp add:Vr_ring)
 done
 
 lemma (in Corps) n_value_idealTr:"\<lbrakk>valuation K v; 0 \<le> n\<rbrakk> \<Longrightarrow>
         (vp K v) \<^bsup>\<diamondsuit>(Vr K v) n\<^esup> = Vr K v \<diamondsuit>\<^sub>p ((Pg K v)^\<^bsup>(Vr K v) n\<^esup>)"
 apply (frule Vr_ring[of v],
        frule Pg_gen_vp[THEN sym, of v],
        simp add:vp_ideal,
        frule val_Pg[of v], simp, (erule conjE)+)
 apply (subst Ring.principal_ideal_n_pow[of "Vr K v" "Pg K v"
        "Vr K v \<diamondsuit>\<^sub>p Pg K v"], assumption+,
        frule Lv_pos[of v], rotate_tac -2, frule sym,
        thin_tac "v (Pg K v) = Lv K v", simp, simp add:val_poss_mem_Vr,
        simp+)
 done
 
 lemma (in Corps) ideal_pow_vp:"\<lbrakk>valuation K v; ideal (Vr K v) I;
                      I \<noteq> carrier (Vr K v); I \<noteq> {\<zero>\<^bsub>Vr K v\<^esub>}\<rbrakk>  \<Longrightarrow>
                      I = (vp K v)\<^bsup>\<diamondsuit> (Vr K v) (na (n_val K v (Ig K v I)))\<^esup>"
 apply (frule Vr_ring[of v],
        frule Ig_generate_I[of v I], assumption+)
 
 apply (frule n_val[of v "Ig K v I"],
        frule val_Ig[of v I], assumption+, erule conjE,
        simp add:Ring.ideal_subset[of "Vr K v" "I" "Ig K v I"] Vr_mem_f_mem)
 
 apply (frule val_Pg[of v], erule conjE,
        rotate_tac -1, drule sym, simp,
        frule Ig_nonzero[of v I], assumption+,
        frule LI_pos[of v I], assumption+,
        frule Lv_pos[of v],
        frule val_Ig[of v I], assumption+, (erule conjE)+,
        rotate_tac -1, drule sym, simp,
        frule val_pos_n_val_pos[of v "Ig K v I"],
        simp add:Ring.ideal_subset Vr_mem_f_mem,
        simp)
 apply (frule zero_val_gen_whole[THEN sym, of v "Ig K v I"],
        simp add:Ring.ideal_subset,
        simp, rotate_tac -1, drule not_sym,
        cut_tac less_le[THEN sym, of "0" "v (Ig K v I)"], simp,
               thin_tac "0 \<le> v (Ig K v I)",
        frule Ring.ideal_subset[of "Vr K v" I "Ig K v I"], assumption+,
        frule Vr_mem_f_mem[of v "Ig K v I"], assumption+,
        frule val_poss_n_val_poss[of v "Ig K v I"], assumption+, simp)
 apply (frule Ig_nonzero[of v I],
        frule val_nonzero_noninf[of v "Ig K v I"], assumption+,
        simp add:val_noninf_n_val_noninf[of v "Ig K v I"],
        frule val_poss_mem_Vr[of v "Pg K v"], assumption+,
        subst n_value_idealTr[of v "na (n_val K v (Ig K v I))"],
           assumption+, simp add:na_def)
 
 apply (frule eq_val_eq_ideal[of v "Ig K v I"
                "(Pg K v)^\<^bsup>(Vr K v) (na (n_val K v (Ig K v I)))\<^esup>"], assumption+,
        rule Ring.npClose, assumption+,
        simp add:Vr_exp_f_exp[of v "Pg K v"],
        subst val_exp_ring[THEN sym, of v "Pg K v"
                           "na (n_val K v (Ig K v I))"], assumption+)
 apply (frule Lv_z[of v], erule exE, simp,
       rotate_tac 6, drule sym, simp,
       subst asprod_amult,
       simp add:val_poss_n_val_poss[of v "Ig K v I"],
       frule val_nonzero_noninf[of v "Ig K v I"], assumption+,
       frule val_noninf_n_val_noninf[of v "Ig K v I"], assumption+, simp,
       rule aposs_na_poss[of "n_val K v (Ig K v I)"], assumption+)
 apply (fold an_def)
 apply (subst an_na[THEN sym, of "n_val K v (Ig K v I)"],
       frule val_nonzero_noninf[of v "Ig K v I"], assumption+,
       frule val_noninf_n_val_noninf[of v "Ig K v I"], assumption+, simp,
       simp add:aless_imp_le, simp)
 apply simp
 done
 
 lemma (in Corps) ideal_apow_vp:"\<lbrakk>valuation K v; ideal (Vr K v) I\<rbrakk> \<Longrightarrow>
                      I = (vp K v)\<^bsup> (Vr K v) (n_val K v (Ig K v I))\<^esup>"
 apply (frule Vr_ring[of v])
 apply (case_tac "v (Ig K v I) = \<infinity>",
        frule val_Ig[of v I], assumption,
        frule val_inf_n_val_inf[of v "Ig K v I"],
        simp add:Ring.ideal_subset Vr_mem_f_mem, simp, simp add:r_apow_def,
        simp add:LI_infinity[of v I])
 
 apply (case_tac "v (Ig K v I) = 0",
        frule val_0_n_val_0[of v "Ig K v I"],
        frule val_Ig[of v I], assumption+, erule conjE,
        simp add:Ring.ideal_subset Vr_mem_f_mem, simp,
 
        frule val_Ig[of v I], assumption,
        frule zero_val_gen_whole[of v "Ig K v I"],
        simp add:Ring.ideal_subset, (erule conjE)+, simp,
        frule Ring.ideal_cont_Rxa[of "Vr K v" "I" "Ig K v I"], assumption+)
 apply (simp,
        frule Ring.ideal_subset1[of "Vr K v" "I"], assumption+,
        frule equalityI[of "I" "carrier (Vr K v)"], assumption+,
        simp add:r_apow_def)
 apply (frule val_noninf_n_val_noninf[of v "Ig K v I"],
        frule val_Ig[of v I], assumption,
        simp add:Ring.ideal_subset Vr_mem_f_mem, simp,
        frule value_n0_n_val_n0[of v "Ig K v I"],
        frule val_Ig[of v I], assumption,
        simp add:Ring.ideal_subset Vr_mem_f_mem, assumption)
 
 apply (simp add:r_apow_def,
        rule ideal_pow_vp, assumption+,
        frule elem_nonzeroval_gen_proper[of v "Ig K v I"],
        frule val_Ig[of v I], assumption+, erule conjE,
        simp add:Ring.ideal_subset, assumption, simp add:Ig_generate_I)
 
 apply (frule val_Ig[of v I], assumption+, erule conjE, simp,
        simp add:LI_infinity[of v I])
 done
 
 (* A note to the above lemma (in Corps).
   Let K be a field and v be a valuation. Let R be the valuaiton ring of v,
 and let P be the maximal ideal of R. If I is an ideal of R such that I \<noteq> 0
 and I \<noteq> R, then I = P^n. Here n = nat znt n_valuation K G a i v (I_gen
 K v I)) which is nat of the integer part of the normal value of
 (I_gen K v I).  Let b be a generator of I, then n = v (b) / v (p), where
 p is a generator of P in R:
                            I = P \<^bsup>\<diamondsuit>R n\<^esup>
 
 Here
           P = vp K v,
           R = Vr K v,
           b = Ig K v I,,
           n = nat n_val K v (Ig K v I).
 It is easy to see that n = v\<^sup>* b. Here v\<^sup>* is the normal valuation derived from
 v. *)
 
 lemma (in Corps) ideal_apow_n_val:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v)\<rbrakk> \<Longrightarrow>
                         (Vr K v) \<diamondsuit>\<^sub>p x = (vp K v)\<^bsup>(Vr K v) (n_val K v x)\<^esup>"
 apply (frule Vr_ring[of v],
        frule Ring.principal_ideal[of "Vr K v" "x"], assumption+,
        frule ideal_apow_vp[of v "Vr K v \<diamondsuit>\<^sub>p x"], assumption+)
 apply (frule val_Ig[of v "Vr K v \<diamondsuit>\<^sub>p x"], assumption+, erule conjE,
        frule Ring.ideal_subset[of "Vr K v" "Vr K v \<diamondsuit>\<^sub>p x"
              "Ig K v (Vr K v \<diamondsuit>\<^sub>p x)"], assumption+,
        frule Ig_generate_I[of v "Vr K v \<diamondsuit>\<^sub>p x"], assumption+)
 apply (frule eq_ideal_eq_val[of v "Ig K v (Vr K v \<diamondsuit>\<^sub>p x)" x],
        assumption+,
        thin_tac "Vr K v \<diamondsuit>\<^sub>p Ig K v (Vr K v \<diamondsuit>\<^sub>p x) = Vr K v \<diamondsuit>\<^sub>p x",
        thin_tac "v (Ig K v (Vr K v \<diamondsuit>\<^sub>p x)) = LI K v (Vr K v \<diamondsuit>\<^sub>p x)",
        frule n_val[THEN sym, of v x],
        simp add:Vr_mem_f_mem, simp,
        thin_tac "v x = n_val K v x * Lv K v",
        frule n_val[THEN sym, of v "Ig K v (Vr K v \<diamondsuit>\<^sub>p x)"],
        simp add:Vr_mem_f_mem, simp,
        thin_tac "v (Ig K v (Vr K v \<diamondsuit>\<^sub>p x)) = n_val K v x * Lv K v")
 apply (frule Lv_pos[of v],
        frule Lv_z[of v], erule exE, simp,
        frule_tac s = z in zless_neq[THEN not_sym, of "0"],
        frule_tac z = z in adiv_eq[of _ "n_val K v (Ig K v (Vr K v \<diamondsuit>\<^sub>p x))"
         "n_val K v x"], assumption+, simp)
 done
 
 lemma (in Corps) t_gen_vp:"\<lbrakk>valuation K v; t \<in> carrier K; v t = 1\<rbrakk> \<Longrightarrow>
                         (Vr K v) \<diamondsuit>\<^sub>p t = vp K v"
 (*
 apply (frule val_surj_n_val[of v], blast)
 apply (frule ideal_apow_n_val[of v t])
 apply (cut_tac a0_less_1)
 apply (rule val_poss_mem_Vr[of v t], assumption+, simp)
 apply (simp add:r_apow_def)
 apply (simp only:ant_1[THEN sym], simp only:ant_0[THEN sym])
 apply (simp only:aeq_zeq, simp)
 apply (cut_tac z_neq_inf[THEN not_sym, of "1"], simp)
 apply (simp only:an_1[THEN sym]) apply (simp add:na_an)
 apply (rule Ring.idealprod_whole_r[of "Vr K v" "vp K v"])
 apply (simp add:Vr_ring)
 apply (simp add:vp_ideal)
 done *)
 
 proof -
 assume  a1:"valuation K v" and
         a2:"t \<in> carrier K" and
         a3:"v t = 1"
  from a1 and a2 and a3 have h1:"t \<in> carrier (Vr K v)"
           apply (cut_tac a0_less_1)
           apply (rule val_poss_mem_Vr[of v t], assumption+, simp) done
  from a1 and a2 and a3 have h2:"n_val K v = v"
           apply (subst val_surj_n_val[of v]) apply assumption
           apply blast  apply simp done
  from a1 and h1 have h3:"Vr K v \<diamondsuit>\<^sub>p t = vp K v\<^bsup> (Vr K v) (n_val K v t)\<^esup>"
           apply (simp add:ideal_apow_n_val[of v t]) done
  from a1 and a3 and h2 and h3 show ?thesis
         apply (simp add:r_apow_def)
         apply (simp only:ant_1[THEN sym], simp only:ant_0[THEN sym])
         apply (simp only:aeq_zeq, simp)
         apply (cut_tac z_neq_inf[THEN not_sym, of "1"], simp)
         apply (simp only:an_1[THEN sym]) apply (simp add:na_an)
         apply (rule Ring.idealprod_whole_r[of "Vr K v" "vp K v"])
         apply (simp add:Vr_ring)
         apply (simp add:vp_ideal) done
 qed
 
 lemma (in Corps) t_vp_apow:"\<lbrakk>valuation K v; t \<in> carrier K; v t = 1\<rbrakk> \<Longrightarrow>
                         (Vr K v) \<diamondsuit>\<^sub>p (t^\<^bsup>(Vr K v) n\<^esup>) = (vp K v)\<^bsup>(Vr K v) (an n)\<^esup>"
 (*
 apply (frule Vr_ring[of v],
        subst Ring.principal_ideal_n_pow[THEN sym, of "Vr K v" t "vp K v" n],
        assumption+)
 apply (cut_tac a0_less_1, rule val_poss_mem_Vr[of v], assumption+)
 apply (simp, simp add:t_gen_vp,
        simp add:r_apow_def)
  apply (rule conjI, rule impI,
         simp only:an_0[THEN sym], frule an_inj[of n 0], simp)
 apply (rule impI)
  apply (rule conjI, rule impI)
  apply (simp add:an_def)
 apply (rule impI, cut_tac an_nat_pos[of n], simp add:na_an)
 done *)
 
 proof -
 assume  a1:"valuation K v" and
         a2:"t \<in> carrier K" and
         a3:"v t = 1"
 from a1 have h1:"Ring (Vr K v)"  by (simp add:Vr_ring[of v])
 from a1 and a2 and a3 have h2:"t \<in> carrier (Vr K v)"
         apply (cut_tac a0_less_1)
         apply (rule val_poss_mem_Vr) apply assumption+ apply simp done
 from a1 and a2 and a3 and h1 and h2 show ?thesis
  apply (subst Ring.principal_ideal_n_pow[THEN sym, of "Vr K v" t "vp K v" n])
  apply assumption+
  apply (simp add:t_gen_vp)
  apply (simp add:r_apow_def)
  apply (rule conjI, rule impI,
         simp only:an_0[THEN sym], frule an_inj[of n 0], simp)
  apply (rule impI)
  apply (rule conjI, rule impI)
  apply (simp add:an_def)
  apply (rule impI, cut_tac an_nat_pos[of n], simp add:na_an)
 done
 qed
 
 lemma (in Corps) nonzeroelem_gen_nonzero:"\<lbrakk>valuation K v; x \<noteq> \<zero>;
                  x \<in> carrier (Vr K v)\<rbrakk> \<Longrightarrow>  Vr K v \<diamondsuit>\<^sub>p x \<noteq> {\<zero>\<^bsub>Vr K v\<^esub>}"
 by (frule Vr_ring[of v],
     frule_tac a = x in Ring.a_in_principal[of "Vr K v"], assumption+,
     rule contrapos_pp, simp+, simp add:Vr_0_f_0)
 
 subsection "Amin lemma (in Corps)s "
 
 lemma (in Corps)  Amin_le_addTr:"valuation K v \<Longrightarrow>
 (\<forall>j \<le> n. f j \<in> carrier K) \<longrightarrow> Amin n (v \<circ> f) \<le> (v (nsum K f n))"
 apply (induct_tac n)
  apply (rule impI, simp)
 
 apply (rule impI,
        simp,
        frule_tac x = "\<Sigma>\<^sub>e K f n" and y = "f (Suc n)" in amin_le_plus[of v],
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        cut_tac n = n in aGroup.nsum_mem[of K _ f], assumption,
        rule allI, simp add:funcset_mem, assumption, simp)
  apply (frule_tac z = "Amin n (\<lambda>u. v (f u))" and z' = "v (\<Sigma>\<^sub>e K f n)" and
         w = "v (f (Suc n))" in amin_aminTr,
         rule_tac i = "amin (Amin n (\<lambda>u. v (f u))) (v (f (Suc n)))" and
         j = "amin (v (\<Sigma>\<^sub>e K f n)) (v (f (Suc n)))" and
         k = "v (\<Sigma>\<^sub>e K f n \<plusminus> (f (Suc n)))" in ale_trans, assumption+)
 done
 
 lemma (in Corps) Amin_le_add:"\<lbrakk>valuation K v; \<forall>j \<le> n. f j \<in> carrier K\<rbrakk> \<Longrightarrow>
                       Amin n (v \<circ> f) \<le> (v (nsum K f n))"
 by (frule Amin_le_addTr[of v n f], simp)
 
 lemma (in Corps) value_ge_add:"\<lbrakk>valuation K v; \<forall>j \<le> n. f j \<in> carrier K;
                      \<forall>j \<le> n. z \<le> ((v \<circ> f) j)\<rbrakk>  \<Longrightarrow> z \<le> (v (\<Sigma>\<^sub>e K f n))"
 apply (frule Amin_le_add[of v n f], assumption+,
        cut_tac Amin_ge[of n "v \<circ> f" z],
        rule ale_trans, assumption+)
 apply (rule allI, rule impI,
        simp add:comp_def Zset_def,
        rule value_in_aug_inf[of v], assumption+, simp+)
 done
 
 lemma (in Corps) Vr_ideal_powTr1:"\<lbrakk>valuation K v; ideal (Vr K v) I;
  I \<noteq> carrier (Vr K v); b \<in> I\<rbrakk>  \<Longrightarrow> b \<in> (vp K v)"
 by (frule ideal_sub_vp[of v I], assumption+, simp add:subsetD)
 
 section \<open>pow of vp and \<open>n_value\<close> -- convergence --\<close>
 
 lemma (in Corps) n_value_x_1:"\<lbrakk>valuation K v; 0 \<le> n;
                     x \<in> (vp K v) \<^bsup>(Vr K v) n\<^esup>\<rbrakk> \<Longrightarrow>  n \<le> (n_val K v x)"
 (* 1. prove that x \<in> carrier (Vr K v) and that x \<in> carrier K *)
 apply ((case_tac "n = \<infinity>", simp add:r_apow_def,
         simp add:Vr_0_f_0, cut_tac field_is_ring,
         frule Ring.ring_zero[of "K"], frule val_inf_n_val_inf[of v \<zero>],
         assumption+, simp add:value_of_zero),
        (case_tac "n = 0", simp add:r_apow_def,
         subst val_pos_n_val_pos[THEN sym, of v x], assumption+,
         simp add:Vr_mem_f_mem,
         subst val_pos_mem_Vr[of v x], assumption+,
         simp add:Vr_mem_f_mem, assumption,
         simp add:r_apow_def, frule Vr_ring[of v],
         frule vp_pow_ideal[of v "na n"],
         frule Ring.ideal_subset[of "Vr K v" "(vp K v) \<^bsup>\<diamondsuit>(Vr K v) (na n)\<^esup>" x],
         assumption+, frule Vr_mem_f_mem[of v x], assumption+))
 (* 1. done *)
 
 (** 2. Show that
   v (I_gen K v (vpr K  v)^\<^sup>Vr K v\<^sup> \<^sup>nat n) \<le> v x.  the key lemma (in Corps)  is
  "val_Rxa_gt_a"                  **)
 
 apply (case_tac "x = \<zero>\<^bsub>K\<^esub>", simp,
       frule value_of_zero[of v],
       simp add:val_inf_n_val_inf,
       simp add:n_value_idealTr[of v "na n"],
 
       frule val_Pg[of v], erule conjE, simp, erule conjE,
       frule Lv_pos[of v],
       rotate_tac -4, frule sym, thin_tac "v (Pg K v) = Lv K v", simp,
       frule val_poss_mem_Vr[of v "Pg K v"], assumption+,
       frule val_Rxa_gt_a[of v "Pg K v^\<^bsup>(Vr K v) (na n)\<^esup>" x],
 
       frule Vr_integral[of v],
       simp only:Vr_0_f_0[of v, THEN sym],
       frule Idomain.idom_potent_nonzero[of "Vr K v" "Pg K v" "na n"],
       assumption+, simp, simp add:Ring.npClose, assumption+)
 
 apply (thin_tac "x \<in> Vr K v \<diamondsuit>\<^sub>p (Pg K v^\<^bsup>(Vr K v) (na n)\<^esup>)",
        thin_tac "ideal (Vr K v) (Vr K v \<diamondsuit>\<^sub>p (Pg K v^\<^bsup>(Vr K v) (na n)\<^esup>))")
 
 apply (simp add:Vr_exp_f_exp[of v "Pg K v"],
        simp add:val_exp_ring[THEN sym, of v "Pg K v"],
        simp add:n_val[THEN sym, of v x],
        frule val_nonzero_z[of v "Pg K v"], assumption+,
          erule exE, simp,
        frule aposs_na_poss[of "n"], simp add: less_le,
        simp add:asprod_amult,
 
        frule_tac w = z in amult_pos_mono_r[of _ "ant (int (na n))"
                    "n_val K v x"], simp,
        cut_tac an_na[of "n"], simp add:an_def, assumption+)
 done
 
 lemma (in Corps) n_value_x_1_nat:"\<lbrakk>valuation K v; x \<in> (vp K v)\<^bsup>\<diamondsuit>(Vr K v) n\<^esup> \<rbrakk> \<Longrightarrow>
              (an n) \<le> (n_val K v x)"
 apply (cut_tac an_nat_pos[of "n"])
 apply( frule n_value_x_1[of  "v" "an n" "x"], assumption+)
 apply (simp add:r_apow_def)
 apply (case_tac "n = 0", simp, simp)
 apply (cut_tac aless_nat_less[THEN sym, of "0" "n"])
 apply simp
 unfolding less_le
 apply simp
 apply (cut_tac an_neq_inf [of "n"])
 apply simp
 apply (simp add: na_an)
 apply assumption
 done
 
 lemma (in Corps) n_value_x_2:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
         n \<le> (n_val K v x);  0 \<le> n\<rbrakk> \<Longrightarrow>  x \<in> (vp K v) \<^bsup>(Vr K v) n\<^esup>"
 apply (frule Vr_ring[of v],
        frule val_Pg[of v], erule conjE,
        simp, erule conjE, drule sym,
        frule Lv_pos[of v], simp,
        frule val_poss_mem_Vr[of v "Pg K v"], assumption+)
 
 apply (case_tac "n = \<infinity>",
        simp add:r_apow_def, cut_tac inf_ge_any[of "n_val K v x"],
        frule ale_antisym[of "n_val K v x" "\<infinity>"], assumption+,
        frule val_inf_n_val_inf[THEN sym, of v "x"],
        simp add:Vr_mem_f_mem, simp,
        frule value_inf_zero[of v x],
        simp add:Vr_mem_f_mem, simp+, simp add:Vr_0_f_0)
 
 apply (case_tac "n = 0",
        simp add:r_apow_def,
        simp add:r_apow_def,
        subst n_value_idealTr[of v "na n"], assumption+,
        simp add:apos_na_pos)
 apply (rule val_Rxa_gt_a_1[of v "Pg K v^\<^bsup>(Vr K v) (na n)\<^esup>" x],
             assumption+,
        rule Ring.npClose, assumption+,
        simp add:Vr_0_f_0[THEN sym, of v],
        frule Vr_integral[of v],
        frule val_poss_mem_Vr[of v "Pg K v"], assumption+,
        simp add:Idomain.idom_potent_nonzero)
 
 apply (simp add:Vr_exp_f_exp,
       simp add:val_exp_ring[THEN sym, of v],
       rotate_tac -5, drule sym,
       frule Lv_z[of v], erule exE, simp,
       frule aposs_na_poss[of "n"], simp add: less_le,
       simp add:asprod_amult, subst n_val[THEN sym, of v x],
       assumption+,
       simp add:Vr_mem_f_mem, simp,
       subst amult_pos_mono_r[of _ "ant (int (na n))" "n_val K v x"],
          assumption,
       cut_tac an_na[of "n"], simp add:an_def, assumption+)
 done
 
 
 
 lemma (in Corps) n_value_x_2_nat:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
       (an n) \<le> ((n_val K v) x)\<rbrakk> \<Longrightarrow>  x \<in> (vp K v)\<^bsup>\<diamondsuit>(Vr K  v)  n\<^esup>"
 by (frule n_value_x_2[of v x "an n"], assumption+,
        simp, simp add:r_apow_def,
        case_tac "an n = \<infinity>", simp add:an_def, simp,
        case_tac "n = 0", simp,
        subgoal_tac "an n \<noteq> 0", simp, simp add:na_an,
        rule contrapos_pp, simp+, simp add:an_def)
 
 lemma (in Corps) n_val_n_pow:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v); 0 \<le> n\<rbrakk> \<Longrightarrow>
          (n \<le> (n_val K v x)) = (x \<in> (vp K v) \<^bsup>(Vr K v)  n\<^esup>)"
 by (rule iffI, simp add:n_value_x_2, simp add:n_value_x_1)
 
 lemma (in Corps) eqval_in_vpr_apow:"\<lbrakk>valuation K v; x \<in> carrier K; 0 \<le> n;
       y \<in> carrier K; n_val K v x = n_val K v y; x \<in> (vp K v)\<^bsup>(Vr K v) n\<^esup>\<rbrakk> \<Longrightarrow>
       y \<in> (vp K v) \<^bsup>(Vr K v) n\<^esup>"
 apply (frule n_value_x_1[of v n x], assumption+, simp,
        rule n_value_x_2[of v y n], assumption+,
        frule mem_vp_apow_mem_Vr[of v n x], assumption+)
 apply (frule val_pos_mem_Vr[THEN sym, of v x], assumption+, simp,
        simp add:val_pos_n_val_pos[of v x],
        simp add:val_pos_n_val_pos[THEN sym, of v y],
        simp add:val_pos_mem_Vr, assumption+)
 done
 
 lemma (in Corps) convergenceTr:"\<lbrakk>valuation K v; x \<in> carrier K; b \<in> carrier K;
   b \<in> (vp K v)\<^bsup>(Vr K v) n\<^esup>; (Abs (n_val K v x)) \<le> n\<rbrakk> \<Longrightarrow>
                 x \<cdot>\<^sub>r b \<in> (vp K v)\<^bsup>(Vr K v) (n + (n_val K v x))\<^esup>"
 (** Valuation ring is a ring **)
 apply (cut_tac Abs_pos[of "n_val K v x"],
        frule ale_trans[of "0" "Abs (n_val K v x)" "n"], assumption+,
        thin_tac "0 \<le> Abs (n_val K v x)")
 apply (frule Vr_ring[of v],
        frule_tac aadd_le_mono[of "Abs (n_val K v x)" "n" "n_val K v x"],
        cut_tac Abs_x_plus_x_pos[of "n_val K v x"],
        frule ale_trans[of "0" "Abs (n_val K v x) + n_val K v x"
         "n + n_val K v x"], assumption+,
        thin_tac "0 \<le> Abs (n_val K v x) + n_val K v x",
        thin_tac "Abs (n_val K v x) + n_val K v x \<le> n + n_val K v x",
        rule n_value_x_2[of v "x \<cdot>\<^sub>r b" "n + n_val K v x"], assumption+)
 apply (frule n_value_x_1[of v n b], assumption+)
  apply (frule aadd_le_mono[of "n" "n_val K v b" "n_val K v x"],
        frule ale_trans[of "0" "n + n_val K v x" "n_val K v b + n_val K v x"],
        assumption)
  apply (thin_tac "0 \<le> n + n_val K v x",
         thin_tac "n \<le> n_val K v b",
         thin_tac "n + n_val K v x \<le> n_val K v b + n_val K v x",
        simp add:aadd_commute[of "n_val K v b" "n_val K v x"])
 apply (frule n_val_valuation[of v],
        simp add:val_t2p[THEN sym, of "n_val K v" x b],
        cut_tac field_is_ring,
        frule Ring.ring_tOp_closed[of "K" "x" "b"], assumption+,
        simp add:val_pos_n_val_pos[THEN sym, of v "x \<cdot>\<^sub>r b"],
        simp add:val_pos_mem_Vr,
        frule n_val_valuation[of v],
        subst val_t2p[of "n_val K v"], assumption+,
        frule n_value_x_1[of v n b], assumption+,
        simp add:aadd_commute[of "n_val K v x" "n_val K v b"],
        rule aadd_le_mono[of n "n_val K v b" "n_val K v x"], assumption+)
 done
 
 lemma (in Corps) convergenceTr1:"\<lbrakk>valuation K v; x \<in> carrier K;
       b \<in> (vp K v)\<^bsup>(Vr K v) (n + Abs (n_val K v x))\<^esup>; 0 \<le> n\<rbrakk> \<Longrightarrow>
                                  x \<cdot>\<^sub>r b \<in> (vp K v) \<^bsup>(Vr K v) n\<^esup>"
 apply (cut_tac field_is_ring,
        frule Vr_ring[of v],
        frule vp_apow_ideal[of v "n + Abs (n_val K v x)"],
        cut_tac Abs_pos[of "n_val K v x"],
        rule aadd_two_pos[of "n" "Abs (n_val K v x)"], assumption+)
 
 apply (frule Ring.ideal_subset[of "Vr K v" "vp K v\<^bsup> (Vr K v) (n + Abs (n_val K v x))\<^esup>"
         "b"], assumption+,
        frule Vr_mem_f_mem[of v b], assumption,
        frule convergenceTr[of v x b "n +  Abs (n_val K v x)"], assumption+,
        rule aadd_pos_le[of "n" "Abs (n_val K v x)"], assumption)
 
 apply (frule  apos_in_aug_inf[of "n"],
        cut_tac Abs_pos[of "n_val K v x"],
        frule apos_in_aug_inf[of "Abs (n_val K v x)"],
        frule n_value_in_aug_inf[of v x], assumption+,
        frule aadd_assoc_i[of "n" "Abs (n_val K v x)" "n_val K v x"],
               assumption+,
        cut_tac Abs_x_plus_x_pos[of "n_val K v x"])
 
 apply (frule_tac Ring.ring_tOp_closed[of K x b], assumption+,
        rule n_value_x_2[of v "x \<cdot>\<^sub>r b" n], assumption+)
 
 apply (subst val_pos_mem_Vr[THEN sym, of v "x \<cdot>\<^sub>r b"], assumption+,
        subst val_pos_n_val_pos[of v "x \<cdot>\<^sub>r b"], assumption+)
 
 apply (frule n_value_x_1[of "v" "n + Abs(n_val K v x) + n_val K v x" "x \<cdot>\<^sub>r b"],
        subst aadd_assoc_i, assumption+,
        rule aadd_two_pos[of "n"], assumption+,
        rule ale_trans[of "0" "n + Abs (n_val K v x) + n_val K v x"
                 "n_val K v (x \<cdot>\<^sub>r b)"],
        simp, simp add:aadd_two_pos, assumption,
        frule n_value_x_1[of "v" "n + Abs (n_val K v x)" " b"],
        cut_tac Abs_pos[of "n_val K v x"],
        rule aadd_two_pos[of "n" "Abs (n_val K v x)"], assumption+)
 
 apply (frule n_val_valuation[of v],
         subst val_t2p[of  "n_val K v"], assumption+)
 apply (frule aadd_le_mono[of "n + Abs (n_val K v x)" "n_val K v b"
                               "n_val K v x"],
         simp add:aadd_commute[of "n_val K v b" "n_val K v x"],
         rule ale_trans[of "n" "n + (Abs (n_val K v x) + n_val K v x)"
            "n_val K v x + n_val K v b"],
         frule aadd_pos_le[of "Abs (n_val K v x) + n_val K v x" "n"],
         simp add:aadd_commute[of "n"], assumption+)
 done
 
 lemma (in Corps) vp_potent_zero:"\<lbrakk>valuation K v; 0 \<le> n\<rbrakk> \<Longrightarrow>
              (n = \<infinity>) = (vp K v \<^bsup>(Vr K v) n\<^esup> = {\<zero>\<^bsub>Vr K v\<^esub>})"
 apply (rule iffI)
 apply (simp add:r_apow_def, rule contrapos_pp, simp+,
        frule apos_neq_minf[of "n"],
        cut_tac mem_ant[of "n"], simp, erule exE, simp,
        simp add:ant_0[THEN sym], thin_tac "n = ant z")
 
 apply (case_tac "z = 0", simp add:ant_0, simp add:r_apow_def,
        frule Vr_ring[of v],
        frule Ring.ring_one[of "Vr K v"], simp,
        simp add:Vr_0_f_0, simp add:Vr_1_f_1,
        frule value_of_one[of v], simp, simp add:value_of_zero,
        cut_tac n = z in zneq_aneq[of _ "0"], simp only:ant_0)
 apply (simp add:r_apow_def,
        frule_tac n = "na (ant z)" in n_value_idealTr[of v],
        simp add:na_def,
        simp, thin_tac "vp K v \<^bsup>\<diamondsuit>(Vr K v) (na (ant z))\<^esup> = {\<zero>\<^bsub>Vr K v\<^esub>}",
        frule Vr_ring[of v],
        frule  Pg_in_Vr[of v],
        frule_tac n = "na (ant z)" in Ring.npClose[of "Vr K v" "Pg K v"],
        assumption)
 apply (frule_tac a = "(Pg K v)^\<^bsup>(Vr K v) (na (ant z))\<^esup>" in
                    Ring.a_in_principal[of "Vr K v"], assumption,
        simp, frule Vr_integral[of "v"],
        frule val_Pg[of v], simp, (erule conjE)+,
        frule_tac n = "na (ant z)" in Idomain.idom_potent_nonzero[of "Vr K v"
         "Pg K v"], assumption+,
        simp add:Vr_0_f_0, simp)
 done
 
 lemma (in Corps) Vr_potent_eqTr1:"\<lbrakk>valuation K v; 0 \<le> n; 0 \<le> m;
         (vp K v) \<^bsup>(Vr K v) n\<^esup> = (vp K v) \<^bsup>(Vr K v) m\<^esup>; m = 0\<rbrakk>  \<Longrightarrow>  n = m"
 (*** compare the value of the generator of each ideal ***)
 (** express each ideal as a principal ideal **)
 apply (frule Vr_ring[of v],
        simp add:r_apow_def,
        case_tac "n = 0", simp,
        case_tac "n = \<infinity>", simp,
        frule val_Pg[of v], erule conjE, simp,
        erule conjE,
        rotate_tac -3, drule sym,
        frule Lv_pos[of v], simp,
        frule val_poss_mem_Vr[of v "Pg K v"], assumption+,
        drule sym, simp, simp add:Vr_0_f_0)
 
 apply (simp,
        drule sym,
        frule Ring.ring_one[of "Vr K v"], simp,
 
        frule n_value_x_1_nat[of v "1\<^sub>r\<^bsub>(Vr K v)\<^esub>" "na n"], assumption,
        simp add:an_na, simp add:Vr_1_f_1,
        frule n_val_valuation[of v],
        simp add:value_of_one[of "n_val K v"])
 done
 
 lemma (in Corps) Vr_potent_eqTr2:"\<lbrakk>valuation K v;
         (vp K v) \<^bsup>\<diamondsuit>(Vr K v) n\<^esup> = (vp K v) \<^bsup>\<diamondsuit>(Vr K v) m\<^esup>\<rbrakk>  \<Longrightarrow>   n = m"
 
 (** 1. express each ideal as a principal ideal **)
 apply (frule Vr_ring[of v],
        frule val_Pg[of v], simp, (erule conjE)+,
        rotate_tac -1, frule sym, thin_tac "v (Pg K v) = Lv K v",
        frule Lv_pos[of v], simp)
 
 apply (subgoal_tac "0 \<le> int n", subgoal_tac "0 \<le> int m",
        frule n_value_idealTr[of "v" "m"]) apply simp apply simp
  apply(
        thin_tac "vp K v \<^bsup>\<diamondsuit>(Vr K v) m\<^esup> = Vr K v \<diamondsuit>\<^sub>p (Pg K v^\<^bsup>(Vr K v) m\<^esup>)",
        frule n_value_idealTr[of "v" "n"], simp, simp,
        thin_tac "vp K v \<^bsup>\<diamondsuit>(Vr K v) n\<^esup> = Vr K v \<diamondsuit>\<^sub>p (Pg K v^\<^bsup>(Vr K v) m\<^esup>)",
        frule val_poss_mem_Vr[of  "v" "Pg K v"], assumption+)
 
 (** 2. the value of generators should coincide **)
  apply (frule Lv_z[of v], erule exE,
         rotate_tac -4, drule sym, simp,
         frule eq_ideal_eq_val[of "v" "Pg K v^\<^bsup>(Vr K v) n\<^esup>" "Pg K v^\<^bsup>(Vr K v) m\<^esup>"])
  apply (rule Ring.npClose, assumption+, rule Ring.npClose, assumption+)
  apply (simp only:Vr_exp_f_exp,
         simp add:val_exp_ring[THEN sym, of v "Pg K v"],
         thin_tac "Vr K v \<diamondsuit>\<^sub>p (Pg K v^\<^bsup>K n\<^esup>) = Vr K v \<diamondsuit>\<^sub>p (Pg K v^\<^bsup>K m\<^esup>)")
 
 apply (case_tac "n = 0", simp, case_tac "m = 0", simp,
        simp only:of_nat_0_less_iff[THEN sym, of "m"],
        simp only:asprod_amult a_z_z,
        simp only:ant_0[THEN sym], simp only:aeq_zeq, simp)
 apply (auto simp add: asprod_mult)
 done
 
 lemma (in Corps) Vr_potent_eq:"\<lbrakk>valuation K v; 0 \<le> n; 0 \<le> m;
               (vp K v) \<^bsup>(Vr K v) n\<^esup> = (vp K v) \<^bsup>(Vr K v) m\<^esup>\<rbrakk> \<Longrightarrow>  n = m"
 apply (frule n_val_valuation[of v],
        case_tac "m = 0",
        simp add:Vr_potent_eqTr1)
 apply (case_tac "n = 0",
        frule sym, thin_tac "vp K v\<^bsup> (Vr K v) n\<^esup> = vp K v\<^bsup> (Vr K v) m\<^esup>",
        frule Vr_potent_eqTr1[of v m n], assumption+,
        rule sym, assumption,
        frule vp_potent_zero[of  "v" "n"], assumption+)
 apply (case_tac "n = \<infinity>", simp,
        thin_tac "vp K v\<^bsup> (Vr K v) \<infinity>\<^esup> = {\<zero>\<^bsub>Vr K v\<^esub>}",
        frule vp_potent_zero[THEN sym, of v m], assumption+, simp,
        simp,
        frule vp_potent_zero[THEN sym, of v "m"], assumption+, simp,
        thin_tac "vp K v\<^bsup> (Vr K v) m\<^esup> \<noteq> {\<zero>\<^bsub>Vr K v\<^esub>}")
 
 apply (frule aposs_na_poss[of "n"], subst less_le, simp,
        frule aposs_na_poss[of "m"], subst less_le, simp,
        simp add:r_apow_def,
        frule Vr_potent_eqTr2[of  "v" "na n" "na m"], assumption+,
        thin_tac "vp K v \<^bsup>\<diamondsuit>(Vr K v) (na n)\<^esup> = vp K v \<^bsup>\<diamondsuit>(Vr K v) (na m)\<^esup>",
        simp add:aeq_nat_eq[THEN sym])
 done
 
 text\<open>the following two lemma (in Corps) s are used in completion of K\<close>
 
 lemma (in Corps) Vr_prime_maximalTr1:"\<lbrakk>valuation K v; x \<in> carrier (Vr K v);
        Suc 0 < n\<rbrakk>  \<Longrightarrow> x \<cdot>\<^sub>r\<^bsub>(Vr K v)\<^esub> (x^\<^bsup>K (n - Suc 0)\<^esup>) \<in> (Vr K v) \<diamondsuit>\<^sub>p (x^\<^bsup>K n\<^esup>)"
 apply (frule Vr_ring[of v],
        subgoal_tac "x^\<^bsup>K n\<^esup> = x^\<^bsup>K (Suc (n - Suc 0))\<^esup>",
        simp del:Suc_pred,
        rotate_tac -1, drule sym)
 apply (subst Vr_tOp_f_tOp, assumption+,
        subst Vr_exp_f_exp[of v, THEN sym], assumption+,
        simp only:Ring.npClose, simp del:Suc_pred)
  apply (cut_tac field_is_ring,
        frule Ring.npClose[of K x "n - Suc 0"],
        frule Vr_mem_f_mem[of v x], assumption+,
        frule Vr_mem_f_mem[of v x], assumption+)
        apply (simp add:Ring.ring_tOp_commute[of K x "x^\<^bsup>K (n - Suc 0)\<^esup>"])
  apply (rule Ring.a_in_principal, assumption)
  apply (frule Ring.npClose[of "Vr K v" x n], assumption,
         simp add:Vr_exp_f_exp)
  apply (simp only:Suc_pred)
 done
 
 lemma (in Corps) Vr_prime_maximalTr2:"\<lbrakk> valuation K v; x \<in> vp K v; x \<noteq> \<zero>;
   Suc 0 < n\<rbrakk> \<Longrightarrow> x \<notin> Vr K v \<diamondsuit>\<^sub>p (x^\<^bsup>K n\<^esup>) \<and> x^\<^bsup>K (n - Suc 0)\<^esup> \<notin> (Vr K v) \<diamondsuit>\<^sub>p (x^\<^bsup>K n\<^esup>)"
 apply (frule Vr_ring[of v])
 apply (frule vp_mem_Vr_mem[of v x], assumption,
        frule Ring.npClose[of "Vr K v" x n],
        simp only:Vr_exp_f_exp)
 apply (cut_tac field_is_ring,
        cut_tac field_is_idom,
        frule Vr_mem_f_mem[of v x], assumption+,
        frule Idomain.idom_potent_nonzero[of K x n], assumption+)
 apply (rule conjI)
  apply (rule contrapos_pp, simp+)
  apply (frule val_Rxa_gt_a[of v "x^\<^bsup>K n\<^esup>" x],
         simp, simp add:Vr_exp_f_exp, assumption+)
  apply (simp add:val_exp_ring[THEN sym, of v x n])
  apply (frule val_nonzero_z[of v x], assumption+, erule exE,
         simp add:asprod_amult a_z_z)
  apply (simp add:vp_mem_val_poss[of v x])
 apply (rule contrapos_pp, simp+)
 apply (frule val_Rxa_gt_a[of v "x^\<^bsup>K n\<^esup>" "x^\<^bsup>K (n - Suc 0)\<^esup>"])
    apply (simp, frule Ring.npClose[of "Vr K v" "x" "n - Suc 0"], assumption+)
    apply (simp add:Vr_exp_f_exp)
   apply (frule Ring.npClose[of "Vr K v" "x" "n - Suc 0"], assumption+,
         simp add:Vr_exp_f_exp, assumption)
 apply (simp add:val_exp_ring[THEN sym, of v x])
 apply (simp add:vp_mem_val_poss[of "v" "x"])
 apply (frule val_nonzero_z[of  "v" "x"], assumption+, erule exE,
         simp add:asprod_amult a_z_z)
 done
 
 lemma (in Corps) Vring_prime_maximal:"\<lbrakk>valuation K v; prime_ideal (Vr K v) I;
       I \<noteq> {\<zero>\<^bsub>Vr K v\<^esub>}\<rbrakk> \<Longrightarrow> maximal_ideal (Vr K v) I"
 apply (frule Vr_ring[of v],
        frule Ring.prime_ideal_proper[of "Vr K v" "I"], assumption+,
        frule Ring.prime_ideal_ideal[of "Vr K v" "I"], assumption+,
        frule ideal_pow_vp[of v I],
        frule n_value_idealTr[of "v" "na (n_val K v (Ig K v I))"],
                   simp, simp, assumption+)
 
 apply (case_tac "na (n_val K v (Ig K v I)) = 0",
        simp, frule Ring.Rxa_one[of "Vr K v"], simp,
        frule Suc_leI[of "0" "na (n_val K v (Ig K v I))"],
        thin_tac "0 < na (n_val K v (Ig K v I))")
 apply (case_tac "na (n_val K v (Ig K v I)) = Suc 0", simp,
        frule Pg_in_Vr[of v])
 apply (frule vp_maximal[of v],
        frule Ring.maximal_ideal_ideal[of "Vr K v" "vp K v"], assumption+,
        subst Ring.idealprod_whole_r[of "Vr K v" "vp K v"], assumption+)
 
 apply (rotate_tac -1, drule not_sym,
        frule le_neq_implies_less[of "Suc 0" "na (n_val K v (Ig K v I))"],
        assumption+,
        thin_tac "Suc 0 \<le> na (n_val K v (Ig K v I))",
        thin_tac "Suc 0 \<noteq> na (n_val K v (Ig K v I))",
        thin_tac "Vr K v \<diamondsuit>\<^sub>p 1\<^sub>r\<^bsub>Vr K v\<^esub> = carrier (Vr K v)")
 apply (frule val_Pg[of v], simp, (erule conjE)+,
        frule Lv_pos[of v], rotate_tac -2, drule sym)
  apply (frule val_poss_mem_Vr[of "v" "Pg K v"],
         frule vp_mem_val_poss[THEN sym, of "v" "Pg K v"], assumption+, simp)
 
 apply (frule Vr_prime_maximalTr2[of v "Pg K v"
                             "na (n_val K v (Ig K v I))"],
        simp add:vp_mem_val_poss[of v "Pg K v"], assumption+, erule conjE)
 apply (frule Ring.npMulDistr[of "Vr K v" "Pg K v" "na 1" "na (n_val K v (Ig K v I)) - Suc 0"], assumption+, simp add:na_1)
 
 apply (rotate_tac 8, drule sym)
 apply (frule Ring.a_in_principal[of "Vr K v"
          "Pg K v^\<^bsup>(Vr K v) (na (n_val K v (Ig K v I)))\<^esup>"], simp add:Ring.npClose)
 
 apply (simp add:Vr_exp_f_exp[of "v"])
     apply (simp add:Ring.ring_l_one[of "Vr K v"])
     apply (frule n_value_idealTr[THEN sym,
                        of v "na (n_val K v (Ig K v I))"], simp)
     apply (simp add:Vr_exp_f_exp)
     apply (rotate_tac 6, drule sym, simp)
 apply (thin_tac "I \<noteq> carrier (Vr K v)",
    thin_tac "I = vp K v \<^bsup>\<diamondsuit>(Vr K v) (na (n_val K v (Ig K v I)))\<^esup>",
    thin_tac "v (Pg K v) = Lv K v",
  thin_tac "(Vr K v) \<diamondsuit>\<^sub>p ((Pg K v) \<cdot>\<^sub>r\<^bsub>(Vr K v)\<^esub>
                    ((Pg K v)^\<^bsup>K (na ((n_val K v) (Ig K v I)) - (Suc 0))\<^esup>)) =
     I",
    thin_tac "Pg K v \<in> carrier K",
    thin_tac "Pg K v \<noteq> \<zero>",
    thin_tac "Pg K v^\<^bsup>K (na ((n_val K v) (Ig K v I)))\<^esup> =
      Pg K v \<cdot>\<^sub>r\<^bsub>Vr K v\<^esub> Pg K v^\<^bsup>K ((na ((n_val K v) (Ig K v I))) - Suc 0)\<^esup>")
 
 
 apply (simp add:prime_ideal_def, erule conjE,
       drule_tac x = "Pg K v" in bspec, assumption,
       drule_tac x = "Pg K v^\<^bsup>K (na (n_val K v (Ig K v I)) - Suc 0)\<^esup> " in bspec)
       apply (simp add:Vr_exp_f_exp[THEN sym, of v])
 apply (rule Ring.npClose[of "Vr K v" "Pg K v"], assumption+)
 apply simp
 done
 
 text\<open>From the above lemma (in Corps) , we see that a valuation ring is of dimension one.\<close>
 
 lemma (in Corps) field_frac1:"\<lbrakk>1\<^sub>r \<noteq> \<zero>; x \<in> carrier K\<rbrakk> \<Longrightarrow> x = x \<cdot>\<^sub>r ((1\<^sub>r)\<^bsup>\<hyphen>K\<^esup>)"
 by (simp add:invf_one,
        cut_tac field_is_ring,
        simp add:Ring.ring_r_one[THEN sym])
 
 lemma (in Corps) field_frac2:"\<lbrakk>x \<in> carrier K; x \<noteq> \<zero>\<rbrakk> \<Longrightarrow> x = (1\<^sub>r) \<cdot>\<^sub>r ((x\<^bsup>\<hyphen>K\<^esup>)\<^bsup>\<hyphen>K\<^esup>)"
 by (cut_tac field_is_ring, simp add:field_inv_inv,
        simp add:Ring.ring_l_one[THEN sym])
 
 lemma (in Corps) val_nonpos_inv_pos:"\<lbrakk>valuation K v; x \<in> carrier K;
         \<not> 0 \<le> (v x)\<rbrakk>  \<Longrightarrow> 0 < (v (x\<^bsup>\<hyphen>K\<^esup>))"
 by (case_tac "x = \<zero>\<^bsub>K\<^esub>", simp add:value_of_zero,
        frule Vr_ring[of v],
        simp add:aneg_le[of "0" "v x"],
        frule value_of_inv[THEN sym, of v x], assumption+,
        frule aless_minus[of "v x" "0"], simp)
 
 lemma (in Corps) frac_Vr_is_K:"\<lbrakk>valuation K v; x \<in> carrier K\<rbrakk> \<Longrightarrow>
  \<exists>s\<in>carrier (Vr K v). \<exists>t\<in>carrier (Vr K v) - {\<zero>}. x = s \<cdot>\<^sub>r (t\<^bsup>\<hyphen>K\<^esup>)"
 apply (frule Vr_ring[of v],
        frule has_val_one_neq_zero[of v])
 apply (case_tac "x = \<zero>\<^bsub>K\<^esub>",
        frule Ring.ring_one[of "Vr K v"],
        frule field_frac1[of x],
        simp only:Vr_1_f_1, frule Ring.ring_zero[of "Vr K v"],
        simp add:Vr_0_f_0 Vr_1_f_1, blast)
 apply (case_tac "0 \<le> (v x)",
        frule val_pos_mem_Vr[THEN sym, of v x], assumption+, simp,
        frule field_frac1[of x], assumption+,
        frule has_val_one_neq_zero[of v],
        frule Ring.ring_one[of "Vr K v"], simp only:Vr_1_f_1, blast)
 apply (frule val_nonpos_inv_pos[of v x], assumption+,
        cut_tac invf_inv[of x], erule conjE,
        frule val_poss_mem_Vr[of v "x\<^bsup>\<hyphen>K\<^esup>"], assumption+)
 apply (frule Ring.ring_one[of "Vr K v"], simp only:Vr_1_f_1,
        frule field_frac2[of x], assumption+)
 apply (cut_tac invf_closed1[of x], blast, simp+)
 done
 
 lemma (in Corps) valuations_eqTr1:"\<lbrakk>valuation K v; valuation K v';
  Vr K v = Vr K v'; \<forall>x\<in>carrier (Vr K v). v x = v' x\<rbrakk> \<Longrightarrow> v = v'"
 apply (rule funcset_eq [of _  "carrier K"],
        simp add:valuation_def, simp add:valuation_def,
        rule ballI,
        frule_tac x = x in frac_Vr_is_K[of v], assumption+,
         (erule bexE)+, simp, erule conjE)
 apply (frule_tac x = t in Vr_mem_f_mem[of v'], assumption,
        cut_tac x = t in invf_closed1, simp, simp, erule conjE)
  apply (frule_tac x = s in Vr_mem_f_mem[of "v'"], assumption+,
        simp add:val_t2p, simp add:value_of_inv)
 done
 
 lemma (in Corps) ridmap_rhom:"\<lbrakk> valuation K v; valuation K v';
  carrier (Vr K v) \<subseteq> carrier (Vr K v')\<rbrakk> \<Longrightarrow>
       ridmap (Vr K v) \<in> rHom (Vr K v) (Vr K v')"
 apply (frule Vr_ring[of "v"], frule Vr_ring[of "v'"],
        subst rHom_def, simp, rule conjI)
 apply (simp add:aHom_def, rule conjI,
        rule Pi_I, simp add:ridmap_def subsetD,
        simp add:ridmap_def restrict_def extensional_def,
        (rule ballI)+,
        frule Ring.ring_is_ag[of "Vr K v"], simp add:aGroup.ag_pOp_closed,
         simp add:Vr_pOp_f_pOp subsetD)
 apply (rule conjI, (rule ballI)+, simp add:ridmap_def,
        simp add:Ring.ring_tOp_closed, simp add:Vr_tOp_f_tOp subsetD,
       frule Ring.ring_one[of "Vr K v"], frule Ring.ring_one[of "Vr K v'"],
       simp add:Vr_1_f_1, simp add:ridmap_def )
 done
 
 lemma (in Corps) contract_ideal:"\<lbrakk>valuation K v; valuation K v';
                  carrier (Vr K v) \<subseteq> carrier (Vr K v')\<rbrakk> \<Longrightarrow>
                        ideal (Vr K v) (carrier (Vr K v) \<inter> vp K v')"
 apply (frule_tac ridmap_rhom[of "v" "v'"], assumption+,
       frule Vr_ring[of "v"], frule Vr_ring[of "v'"])
 apply (cut_tac TwoRings.i_contract_ideal[of "Vr K v" "Vr K v'"
         "ridmap (Vr K v)" "vp K v'"],
        subgoal_tac "(i_contract (ridmap (Vr K v)) (Vr K v) (Vr K v')
                       (vp K v')) = (carrier (Vr K v) \<inter> vp K v')")
        apply simp
 apply(thin_tac "ideal (Vr K v) (i_contract (ridmap (Vr K v))
             (Vr K v) (Vr K v') (vp K v'))",
        simp add:i_contract_def invim_def ridmap_def, blast)
 apply (simp add:TwoRings_def TwoRings_axioms_def, simp)
  apply (simp add:vp_ideal)
 done
 
 lemma (in Corps) contract_prime:"\<lbrakk>valuation K v; valuation K v';
       carrier (Vr K v) \<subseteq> carrier (Vr K v')\<rbrakk>  \<Longrightarrow>
       prime_ideal (Vr K v) (carrier (Vr K v) \<inter> vp K v')"
 apply (frule_tac ridmap_rhom[of "v" "v'"], assumption+,
      frule Vr_ring[of "v"],
      frule Vr_ring[of "v'"],
      cut_tac TwoRings.i_contract_prime[of "Vr K v" "Vr K v'" "ridmap (Vr K v)"
         "vp K v'"])
 apply (subgoal_tac "(i_contract (ridmap (Vr K v)) (Vr K v) (Vr K v')
           (vp K v')) = (carrier (Vr K v) \<inter> vp K v')",
       simp,
       thin_tac "prime_ideal (Vr K v) (i_contract
        (ridmap (Vr K v))  (Vr K  v) (Vr K v') (vp K v'))",
       simp add:i_contract_def invim_def ridmap_def, blast)
 apply (simp add:TwoRings_def TwoRings_axioms_def, simp)
 apply (simp add:vp_prime)
 done
 
 (* \<forall>x\<in>carrier K. 0 \<le> (v x) \<longrightarrow> 0 \<le> (v' x) *)
 lemma (in Corps) valuation_equivTr:"\<lbrakk>valuation K v; valuation K v';
       x \<in> carrier K;  0 < (v' x); carrier (Vr K v) \<subseteq> carrier (Vr K v')\<rbrakk>
       \<Longrightarrow> 0 \<le> (v x)"
 apply (rule contrapos_pp, simp+,
        frule val_nonpos_inv_pos[of "v" "x"], assumption+,
        case_tac "x = \<zero>\<^bsub>K\<^esub>", simp add:value_of_zero[of "v"]) apply (
        cut_tac invf_closed1[of  "x"], simp, erule conjE,
        frule aless_imp_le[of "0" "v (x\<^bsup>\<hyphen>K\<^esup>)"])
 apply (simp add:val_pos_mem_Vr[of v "x\<^bsup>\<hyphen>K\<^esup>"],
       frule subsetD[of "carrier (Vr K v)" "carrier (Vr K v')" "x\<^bsup>\<hyphen>K\<^esup>"],
       assumption+,
       frule val_pos_mem_Vr[THEN sym, of "v'" "x\<^bsup>\<hyphen>K\<^esup>"], assumption+)
 apply (simp, simp add:value_of_inv[of "v'" "x"],
        cut_tac ale_minus[of "0" "- v' x"], thin_tac "0 \<le> - v' x",
        simp only:a_minus_minus,
        cut_tac aneg_less[THEN sym, of "v' x" "- 0"], simp,
        assumption, simp)
 done
 
 lemma (in Corps) contract_maximal:"\<lbrakk>valuation K v; valuation K v';
   carrier (Vr K v) \<subseteq> carrier (Vr K v')\<rbrakk> \<Longrightarrow>
   maximal_ideal (Vr K v) (carrier (Vr K v) \<inter> vp K v')"
 apply (frule Vr_ring[of "v"],
        frule Vr_ring[of "v'"],
        rule Vring_prime_maximal, assumption+,
        simp add:contract_prime)
 apply (frule vp_nonzero[of  "v'"],
        frule vp_ideal[of  "v'"],
        frule Ring.ideal_zero[of "Vr K v'" "vp K v'"], assumption+,
        frule sets_not_eq[of "vp K v'" "{\<zero>\<^bsub>(Vr K v')\<^esub>}"],
        simp add: singleton_sub[of "\<zero>\<^bsub>(Vr K v')\<^esub>" "carrier (Vr K v')"],
        erule bexE, simp add:Vr_0_f_0)
 
 apply (case_tac "a \<in> carrier (Vr K v)", blast,
        frule_tac x = a in vp_mem_Vr_mem[of "v'"], assumption+,
        frule_tac x = a in Vr_mem_f_mem[of  "v'"], assumption+,
        subgoal_tac "a \<in> carrier (Vr K v)", blast,
        frule_tac x1 = a in val_pos_mem_Vr[THEN sym, of "v"], assumption+,
        simp, frule val_nonpos_inv_pos[of  "v"], assumption+)
 
 apply (frule_tac y = "v (a\<^bsup>\<hyphen>K\<^esup>)" in aless_imp_le[of "0"],
        cut_tac x = a in invf_closed1, simp,
        frule_tac x = "a\<^bsup>\<hyphen>K\<^esup>" in val_poss_mem_Vr[of v], simp, assumption+)
 apply (frule_tac c = "a\<^bsup>\<hyphen>K\<^esup>" in subsetD[of "carrier (Vr K v)"
         "carrier (Vr K v')"], assumption+) apply (
         frule_tac x = "a\<^bsup>\<hyphen>K\<^esup>" in val_pos_mem_Vr[of "v'"],
         simp, simp only:value_of_inv[of "v'"], simp,
         simp add:value_of_inv[of  "v'"])
 apply (frule_tac y = "- v' a" in ale_minus[of "0"], simp add:a_minus_minus,
        frule_tac x = a in vp_mem_val_poss[of "v'"], assumption+,
        simp)
 done
 
 section "Equivalent valuations"
 
 definition
   v_equiv :: "[_ , 'r \<Rightarrow> ant, 'r \<Rightarrow> ant] \<Rightarrow> bool" where
   "v_equiv K v1 v2 \<longleftrightarrow> n_val K v1 = n_val K v2"
 
 
 lemma (in Corps) valuation_equivTr1:"\<lbrakk>valuation K v; valuation K v';
  \<forall>x\<in>carrier K. 0 \<le> (v x) \<longrightarrow> 0 \<le> (v' x)\<rbrakk> \<Longrightarrow>
                 carrier (Vr K v) \<subseteq> carrier (Vr K v')"
 apply (frule Vr_ring[of  "v"],
        frule Vr_ring[of  "v'"])
 apply (rule subsetI,
        case_tac "x = \<zero>\<^bsub>K\<^esub>", simp, simp add:Vr_def Sr_def,
        frule_tac x1 = x in val_pos_mem_Vr[THEN sym, of "v"],
        frule_tac x = x in Vr_mem_f_mem[of "v"],
        simp, frule_tac x = x in Vr_mem_f_mem[of "v"], assumption+)
 apply (drule_tac x = x in bspec, simp add:Vr_mem_f_mem)
 apply simp
 apply (subst val_pos_mem_Vr[THEN sym, of v'], assumption+,
        simp add:Vr_mem_f_mem, assumption+)
 done
 
 lemma (in Corps) valuation_equivTr2:"\<lbrakk>valuation K v; valuation K v';
  carrier (Vr K v) \<subseteq> carrier (Vr K v'); vp K v = carrier (Vr K v) \<inter> vp K v'\<rbrakk>
   \<Longrightarrow>  carrier (Vr K v') \<subseteq> carrier (Vr K v)"
 apply (frule Vr_ring[of "v"], frule Vr_ring[of "v'"])
 apply (rule subsetI)
 apply (case_tac "x = \<zero>\<^bsub>(Vr K v')\<^esub>", simp,
        subst Vr_0_f_0[of "v'"], assumption+,
        subst Vr_0_f_0[of "v", THEN sym], assumption,
        simp add:Ring.ring_zero)
 apply (rule contrapos_pp, simp+)
 apply (frule_tac x = x in Vr_mem_f_mem[of "v'"], assumption+)
 apply (simp add:val_pos_mem_Vr[THEN sym, of "v"])
 apply (cut_tac y = "v x" in aneg_le[of "0"], simp)
 apply (simp add:Vr_0_f_0[of "v'"])
 apply (frule_tac x = "v x" in aless_minus[of _ "0"], simp,
        thin_tac "v x < 0", thin_tac "\<not> 0 \<le> v x")
 apply (simp add:value_of_inv[THEN sym, of "v"])
 apply (cut_tac x = x in invf_closed1, simp, simp, erule conjE)
 apply (frule_tac x1 = "x\<^bsup>\<hyphen>K\<^esup>" in vp_mem_val_poss[THEN sym, of "v"],
        assumption, simp, erule conjE)
 apply (frule vp_ideal [of "v'"])
 apply (frule_tac x = "x\<^bsup>\<hyphen>K\<^esup>" and r = x in Ring.ideal_ring_multiple[of "Vr K v'"
        "vp K v'"], assumption+)
 apply (frule_tac x = "x\<^bsup>\<hyphen>K\<^esup>" in vp_mem_Vr_mem[of "v'"], assumption+)
 apply (frule_tac x = x and y = "x\<^bsup>\<hyphen>K\<^esup>" in Ring.ring_tOp_commute[of "Vr K v'"],
         assumption+, simp,
         thin_tac "x \<cdot>\<^sub>r\<^bsub>Vr K v'\<^esub> x\<^bsup>\<hyphen> K\<^esup> = x\<^bsup>\<hyphen> K\<^esup> \<cdot>\<^sub>r\<^bsub>Vr K v'\<^esub> x")
 apply (simp add:Vr_tOp_f_tOp)
  apply (cut_tac x = x in  linvf, simp, simp)
  apply (cut_tac field_is_ring, frule Ring.ring_one[of "K"])
  apply (frule ideal_inc_elem0val_whole[of "v'" "1\<^sub>r" "vp K v'"],
         assumption+, simp add:value_of_one, assumption+)
  apply (frule vp_not_whole[of "v'"], simp)
 done
 
 lemma (in Corps) eq_carr_eq_Vring:" \<lbrakk>valuation K v; valuation K v';
      carrier (Vr K v) = carrier (Vr K v')\<rbrakk> \<Longrightarrow> Vr K v = Vr K v'"
 apply (simp add:Vr_def Sr_def)
 done
 
 lemma (in Corps) valuations_equiv:"\<lbrakk>valuation K v; valuation K v';
     \<forall>x\<in>carrier K. 0 \<le> (v x) \<longrightarrow> 0 \<le> (v' x)\<rbrakk>  \<Longrightarrow> v_equiv K v v'"
 (** step0. preliminaries. **)
 apply (frule Vr_ring[of "v"], frule Vr_ring[of "v'"])
 
 (** step1.  show carrier (Vr K v) \<subseteq> carrier (Vr K v') **)
 apply (frule valuation_equivTr1[of "v" "v'"], assumption+)
 
 (** step2.  maximal_ideal (Vr K v) (carrier (Vr K v) \<inter> (vp K v')).
     contract of the maximal ideal is prime, and a prime is maximal **)
 apply (frule contract_maximal [of "v" "v'"], assumption+)
 
 (** step3. Vring is a local ring, we have (vp K v) =
     (carrier (Vr K v) \<inter> (vp  K v')) **)
 apply (frule Vr_local[of "v" "(carrier (Vr K v) \<inter> vp K v')"],
         assumption+)
 
 (** step4. show  carrier (Vr K v') \<subseteq> carrier (Vr K v) **)
  apply (frule valuation_equivTr2[of "v" "v'"], assumption+,
         frule equalityI[of "carrier (Vr K v)" "carrier (Vr K v')"],
                                           assumption+,
         thin_tac "carrier (Vr K v) \<subseteq> carrier (Vr K v')",
         thin_tac "carrier (Vr K v') \<subseteq> carrier (Vr K v)")
 (** step5. vp K v' = vp K v **)
  apply (frule vp_ideal[of "v'"],
         frule Ring.ideal_subset1[of "Vr K v'" "vp K v'"], assumption,
         simp add:Int_absorb1,
         thin_tac "\<forall>x\<in>carrier K. 0 \<le> v x \<longrightarrow> 0 \<le> v' x",
         thin_tac "vp K v' \<subseteq> carrier (Vr K v')",
         thin_tac "ideal (Vr K v') (vp K v')",
         thin_tac "maximal_ideal (Vr K v) (vp K v')")
 (** step6. to show v_equiv K v v', we check whether the normal valuations
     derived from the valuations have the same value or not. if (Vr K
 (n_valuation K v)) = (Vr K (n_valuation K v')), then we have only to
 check the values of the elements in this valuation ring.
 We see (Vr K v) = (Vr K  (n_valuation K G a i v)). **)
 apply (simp add:v_equiv_def,
        rule valuations_eqTr1[of  "n_val K v" "n_val K v'"],
        (simp add:n_val_valuation)+,
        rule eq_carr_eq_Vring[of  "n_val K v" "n_val K v'"],
        (simp add:n_val_valuation)+,
        subst Vr_n_val_Vr[THEN sym, of "v"], assumption+,
        subst Vr_n_val_Vr[THEN sym, of "v'"], assumption+)
 apply (rule ballI,
        frule n_val_valuation[of "v"],
        frule n_val_valuation[of "v'"],
        frule_tac x1 = x in val_pos_mem_Vr[THEN sym, of "n_val K v"],
        simp add:Vr_mem_f_mem, simp,
        frule Vr_n_val_Vr[THEN sym, of "v"], simp,
        thin_tac "carrier (Vr K (n_val K v)) = carrier (Vr K v')",
        frule_tac x1 = x in val_pos_mem_Vr[THEN sym, of "v'"],
                             simp add:Vr_mem_f_mem,
        simp,
        frule_tac x = x in val_pos_n_val_pos[of "v'"],
        simp add:Vr_mem_f_mem, simp,
        frule_tac x = x in ideal_apow_n_val[of "v"],
        simp add:Vr_n_val_Vr[THEN sym, of "v"], simp)
 apply (frule eq_carr_eq_Vring[of "v" "v'"], assumption+,
        frule_tac x = x in ideal_apow_n_val[of "v'"], assumption,
        simp add:Vr_n_val_Vr[THEN sym, of "v"],
        thin_tac "Vr K v' \<diamondsuit>\<^sub>p x = vp K v'\<^bsup> (Vr K v') (n_val K v x)\<^esup>",
        frule_tac n = "n_val K v' x" and m = "n_val K v x" in
                         Vr_potent_eq[of  "v'"], assumption+,
        frule sym, assumption+)
 done
 
 lemma (in Corps) val_equiv_axiom1:"valuation K v \<Longrightarrow> v_equiv K v v"
 apply (simp add:v_equiv_def)
 done
 
 lemma (in Corps) val_equiv_axiom2:"\<lbrakk> valuation K v; valuation K v';
       v_equiv K v v'\<rbrakk> \<Longrightarrow> v_equiv K v' v"
 apply (simp add:v_equiv_def)
 done
 
 lemma (in Corps) val_equiv_axiom3:"\<lbrakk> valuation K v; valuation K v';
  valuation K v'; v_equiv K v v'; v_equiv K v' v''\<rbrakk> \<Longrightarrow>  v_equiv K v v''"
 apply (simp add:v_equiv_def)
 done
 
 lemma (in Corps) n_val_equiv_val:"\<lbrakk> valuation K v\<rbrakk> \<Longrightarrow>
                                v_equiv K v (n_val K v)"
 apply (frule valuations_equiv[of "v" "n_val K v"], simp add:n_val_valuation)
 apply (rule ballI, rule impI, simp add:val_pos_n_val_pos,
        assumption)
 done
 
 section "Prime divisors"
 
 definition
   prime_divisor :: "[_, 'b \<Rightarrow> ant] \<Rightarrow>
         ('b \<Rightarrow> ant) set"  ("(2P\<^bsub> _ _\<^esub>)" [96,97]96) where
  "P\<^bsub>K v\<^esub> = {v'. valuation K v' \<and> v_equiv K v v'}"
 
 definition
   prime_divisors :: "_ \<Rightarrow> ('b \<Rightarrow> ant) set set" ("Pds\<index>" 96) where
   "Pds\<^bsub>K\<^esub> = {P. \<exists>v. valuation K v \<and> P = P\<^bsub> K v\<^esub> }"
 
 definition
   normal_valuation_belonging_to_prime_divisor ::
     "[_ ,  ('b \<Rightarrow> ant) set] \<Rightarrow> ('b \<Rightarrow> ant)"  ("(\<nu>\<^bsub>_ _\<^esub>)" [96,97]96) where
   "\<nu>\<^bsub>K P\<^esub> = n_val K (SOME v. v \<in> P)"
 
 lemma (in Corps) val_in_P_valuation:"\<lbrakk>valuation K v; v' \<in> P\<^bsub>K v\<^esub>\<rbrakk> \<Longrightarrow>
        valuation K v'"
 apply (simp add:prime_divisor_def)
 done
 
 lemma (in Corps) vals_in_P_equiv:"\<lbrakk> valuation K v; v' \<in> P\<^bsub>K v\<^esub>\<rbrakk> \<Longrightarrow>
        v_equiv K v v'"
 apply (simp add:prime_divisor_def)
 done
 
 lemma (in Corps) v_in_prime_v:"valuation K v \<Longrightarrow> v \<in> P\<^bsub>K v\<^esub>"
 apply (simp add:prime_divisor_def,
        frule val_equiv_axiom1[of "v"], assumption+)
 done
 
 lemma (in Corps) some_in_prime_divisor:"valuation K v \<Longrightarrow>
              (SOME w. w \<in> P\<^bsub>K v\<^esub>) \<in>  P\<^bsub>K v\<^esub>"
 apply (subgoal_tac "P\<^bsub> K v\<^esub> \<noteq> {}",
        rule nonempty_some[of "P\<^bsub> K v\<^esub>"], assumption+,
        frule v_in_prime_v[of "v"])
 apply blast
 done
 
 lemma (in Corps) valuation_some_in_prime_divisor:"valuation K v
           \<Longrightarrow>  valuation K (SOME w. w \<in> P\<^bsub>K v\<^esub>)"
 apply (frule some_in_prime_divisor[of "v"],
        simp add:prime_divisor_def)
 done
 
 lemma (in Corps) valuation_some_in_prime_divisor1:"P \<in> Pds  \<Longrightarrow>
                   valuation K (SOME w. w \<in> P)"
 apply (simp add:prime_divisors_def, erule exE)
  apply (simp add:valuation_some_in_prime_divisor)
 done
 
 lemma (in Corps) representative_of_pd_valuation:
            "P \<in> Pds \<Longrightarrow> valuation K (\<nu>\<^bsub>K P\<^esub>)"
 apply (simp add:prime_divisors_def,
        erule exE, erule conjE,
        simp add:normal_valuation_belonging_to_prime_divisor_def,
        frule_tac v = v in valuation_some_in_prime_divisor)
 
 apply (rule n_val_valuation, assumption+)
 done
 
 lemma (in Corps) some_in_P_equiv:"valuation K v \<Longrightarrow>
                   v_equiv K v (SOME w. w \<in> P\<^bsub>K v\<^esub>)"
 apply (frule some_in_prime_divisor[of v])
 apply (rule vals_in_P_equiv, assumption+)
 done
 
 lemma (in Corps) n_val_n_val1:"P \<in> Pds  \<Longrightarrow> n_val K (\<nu>\<^bsub>K P\<^esub>) = (\<nu>\<^bsub>K P\<^esub>)"
 apply (simp add: normal_valuation_belonging_to_prime_divisor_def,
        frule valuation_some_in_prime_divisor1[of P])
 apply (rule n_val_n_val[of "SOME v. v \<in> P"], assumption+)
 done
 
 lemma (in Corps) P_eq_val_equiv:"\<lbrakk>valuation K v; valuation K v'\<rbrakk> \<Longrightarrow>
         (v_equiv K v v') = (P\<^bsub>K v\<^esub> =  P\<^bsub>K v'\<^esub>)"
 apply (rule iffI,
        rule equalityI,
        rule subsetI, simp add:prime_divisor_def, erule conjE,
        frule val_equiv_axiom2[of "v" "v'"], assumption+,
        rule val_equiv_axiom3[of "v'" "v"], assumption+,
        rule subsetI, simp add:prime_divisor_def, erule conjE)
 apply (rule val_equiv_axiom3[of "v" "v'"], assumption+,
        frule v_in_prime_v[of  "v"], simp,
        thin_tac "P\<^bsub>K v\<^esub> = P\<^bsub>K v'\<^esub>",
        simp add:prime_divisor_def,
        rule val_equiv_axiom2[of "v'" "v"], assumption+)
 done
 
 lemma (in Corps) unique_n_valuation:"\<lbrakk> P \<in> Pds\<^bsub>K\<^esub>; P' \<in> Pds\<rbrakk> \<Longrightarrow>
                 (P = P') =  (\<nu>\<^bsub>K P\<^esub> = \<nu>\<^bsub>K P'\<^esub>)"
 apply (rule iffI, simp)
 apply (simp add:prime_divisors_def,
        (erule exE)+, (erule conjE)+)
 apply (simp add:normal_valuation_belonging_to_prime_divisor_def,
        frule_tac v = v in some_in_P_equiv,
        frule_tac v = va in some_in_P_equiv,
        subgoal_tac "v_equiv K (SOME w. w \<in> P\<^bsub>K v\<^esub>) (SOME w. w \<in> P\<^bsub>K va\<^esub>)")
 apply (frule_tac v = v in some_in_prime_divisor,
        frule_tac v = va in some_in_prime_divisor,
        frule_tac v = v and v' = "SOME w. w \<in> P\<^bsub>K v\<^esub>" and v'' =
        "SOME w. w \<in> P\<^bsub>K va\<^esub>" in val_equiv_axiom3)
 apply (simp add:prime_divisor_def,
        simp add:prime_divisor_def, assumption+,
        frule_tac v = va and v' = "SOME w. w \<in> P\<^bsub>K va\<^esub>" in
                       val_equiv_axiom2,
        simp add:prime_divisor_def, assumption+)
 apply (frule_tac v = v and v' = "SOME w. w \<in> P\<^bsub>K va\<^esub>" and v'' = va in
        val_equiv_axiom3,
       simp add:prime_divisor_def,
       simp add:prime_divisor_def, assumption+,
       frule_tac v = v and v' = va in P_eq_val_equiv, assumption+)
 apply simp
 apply (simp add:v_equiv_def)
 done
 
 lemma (in Corps) n_val_representative:"P \<in> Pds \<Longrightarrow>  (\<nu>\<^bsub>K P\<^esub>) \<in> P"
 apply (simp add:prime_divisors_def,
        erule exE, erule conjE,
        simp add:normal_valuation_belonging_to_prime_divisor_def,
        frule_tac v = v in valuation_some_in_prime_divisor,
        frule_tac v = "SOME w. w \<in> P\<^bsub>K v\<^esub>" in
            n_val_equiv_val,
        frule_tac v = v in some_in_P_equiv,
        frule_tac v = v and v' = "SOME w. w \<in> P\<^bsub> K v\<^esub>" and v'' =
         "n_val K (SOME w. w \<in> P\<^bsub>K v\<^esub>)" in val_equiv_axiom3,
        assumption+,
        frule_tac v = v in n_val_valuation,
        simp add:prime_divisor_def, simp add:n_val_valuation)
 done
 
 lemma (in Corps) val_equiv_eq_pdiv:"\<lbrakk> P \<in> Pds\<^bsub>K\<^esub>; P'\<in> Pds\<^bsub>K\<^esub>; valuation K v;
          valuation K v'; v_equiv K v v'; v \<in> P; v' \<in> P' \<rbrakk> \<Longrightarrow>  P = P'"
 apply (simp add:prime_divisors_def,
        (erule exE)+, (erule conjE)+)
 apply (rename_tac w w',
        frule_tac v = w in vals_in_P_equiv[of _ "v"], simp,
        frule_tac v = w' in vals_in_P_equiv[of _ "v'"], simp,
        frule_tac v = w and v' = v and  v'' = v' in val_equiv_axiom3,
        assumption+,
        frule_tac v = w' in val_equiv_axiom2[of _ "v'"], assumption+,
        frule_tac v = w and v' = v' and  v'' = w' in val_equiv_axiom3,
           assumption+) apply simp+
 apply (simp add:P_eq_val_equiv)
 done
 
 lemma (in Corps) distinct_p_divisors:"\<lbrakk> P \<in> Pds\<^bsub>K\<^esub>; P' \<in> Pds\<^bsub>K\<^esub>\<rbrakk> \<Longrightarrow>
           (\<not> P = P') =  (\<not> v_equiv K (\<nu>\<^bsub>K P\<^esub>) (\<nu>\<^bsub>K P'\<^esub>))"
 apply (rule iffI,
        rule contrapos_pp, simp+,
        frule val_equiv_eq_pdiv[of "P" "P'" "\<nu>\<^bsub>K P\<^esub>" "\<nu>\<^bsub>K P'\<^esub>"], assumption+,
        simp add: representative_of_pd_valuation,
        simp add: representative_of_pd_valuation, assumption)
 apply (rule n_val_representative[of "P"], assumption,
        rule n_val_representative[of "P'"], assumption,
        simp,
        rule contrapos_pp, simp+, frule sym, thin_tac "P = P'",
        simp,
        frule representative_of_pd_valuation[of P],
        frule val_equiv_axiom1[of "\<nu>\<^bsub>K P\<^esub>"], simp)
 done
 
 section "Approximation"
 
 definition
   valuations :: "[_ , nat, nat \<Rightarrow> ('r \<Rightarrow> ant)] \<Rightarrow> bool" where
   "valuations K n vv \<longleftrightarrow> (\<forall>j \<le> n. valuation K (vv j))"
 
 definition
   vals_nonequiv :: "[_, nat, nat \<Rightarrow> ('r \<Rightarrow> ant)] \<Rightarrow> bool" where
   "vals_nonequiv K n vv \<longleftrightarrow> valuations K n vv \<and>
   (\<forall>j\<le>n. \<forall>l \<le> n. j \<noteq> l \<longrightarrow> \<not> (v_equiv K (vv j) (vv l)))"
 
 definition
   Ostrowski_elem :: "[_, nat, nat \<Rightarrow> ('b \<Rightarrow> ant), 'b] \<Rightarrow> bool" where
   "Ostrowski_elem K n vv x \<longleftrightarrow>
        (0 < (vv 0 (1\<^sub>r\<^bsub>K\<^esub> \<plusminus>\<^bsub>K\<^esub> (-\<^sub>a\<^bsub>K\<^esub> x)))) \<and>  (\<forall>j\<in>nset (Suc 0) n. 0 < (vv j x))"
 
  (** vv 0, vv 1, vv 2,\<dots>, vv n are valuations **)
 
 lemma (in Corps) Ostrowski_elem_0:"\<lbrakk>vals_nonequiv K n vv; x \<in> carrier K;
  Ostrowski_elem K n vv x\<rbrakk> \<Longrightarrow> 0 < (vv 0 (1\<^sub>r \<plusminus> (-\<^sub>a x)))"
 apply (simp add:Ostrowski_elem_def)
 done
 
 lemma (in Corps) Ostrowski_elem_Suc:"\<lbrakk>vals_nonequiv K n vv; x \<in> carrier K;
   Ostrowski_elem K n vv x; j \<in> nset (Suc 0) n\<rbrakk> \<Longrightarrow> 0 < (vv j x)"
 apply (simp add:Ostrowski_elem_def)
 done
 
 lemma (in Corps) vals_nonequiv_valuation:"\<lbrakk>vals_nonequiv K n vv; m \<le> n\<rbrakk> \<Longrightarrow>
        valuation K (vv m)"
 apply (simp add:vals_nonequiv_def, erule conjE)
  apply (thin_tac "\<forall>j\<le>n. \<forall>l\<le> n. j \<noteq> l \<longrightarrow> \<not> v_equiv K (vv j) (vv l)")
  apply (simp add:valuations_def)
 done
 
 lemma (in Corps) vals_nonequiv:"\<lbrakk> vals_nonequiv K (Suc (Suc n)) vv;
  i \<le> (Suc (Suc n)); j \<le> (Suc (Suc n)); i \<noteq> j\<rbrakk> \<Longrightarrow>
                                    \<not> (v_equiv K (vv i) (vv j))"
 apply (simp add:vals_nonequiv_def)
 done
 
 lemma (in Corps) skip_vals_nonequiv:"vals_nonequiv K (Suc (Suc n)) vv \<Longrightarrow>
   vals_nonequiv K (Suc n) (compose {l. l \<le> (Suc n)} vv (skip j))"
 apply (subst vals_nonequiv_def)
 apply (rule conjI)
 apply (subst valuations_def, rule allI, rule impI,
        simp add:compose_def)
 apply (cut_tac l = ja and n = "Suc n" in skip_mem[of _ _ "j"], simp,
        frule_tac m = "skip j ja" in vals_nonequiv_valuation[of
          "Suc (Suc n)" "vv"], simp, assumption)
 apply ((rule allI, rule impI)+, rule impI,
        cut_tac l = ja and n = "Suc n" in skip_mem[of _ _ "j"], simp,
        cut_tac l = l and n = "Suc n" in skip_mem[of _ _ "j"], simp+)
 apply (cut_tac i = ja and j = l in skip_inj[of _ "Suc n" _ "j"], simp+,
        simp add:compose_def,
        rule_tac i = "skip j ja" and j = "skip j l" in
        vals_nonequiv[of "n"], assumption+)
 done
 
 lemma (in Corps) not_v_equiv_reflex:"\<lbrakk>valuation K v; valuation K v';
  \<not> v_equiv K v v'\<rbrakk> \<Longrightarrow> \<not> v_equiv K v' v "
 apply (simp add:v_equiv_def)
 done
 
 lemma (in Corps) nonequiv_ex_Ostrowski_elem:"\<lbrakk>valuation K v; valuation K v';
  \<not> v_equiv K v v'\<rbrakk> \<Longrightarrow> \<exists>x\<in>carrier K. 0 \<le> (v x) \<and> (v' x) < 0"
  apply (subgoal_tac "\<not> (\<forall>x\<in>carrier K. 0 \<le> (v x) \<longrightarrow> 0 \<le> (v' x))")
  prefer 2
  apply (rule contrapos_pp, simp+,
         frule valuations_equiv[of "v" "v'"], assumption+,
         simp add:val_equiv_axiom2[of v v'])
 apply (simp, erule bexE, erule conjE, simp add:aneg_le)
  apply blast
 done
 
 lemma (in Corps) field_op_minus:"\<lbrakk>a \<in> carrier K; b \<in> carrier K; b \<noteq> \<zero>\<rbrakk> \<Longrightarrow>
                               -\<^sub>a (a \<cdot>\<^sub>r (b\<^bsup>\<hyphen>K\<^esup>)) = (-\<^sub>a a) \<cdot>\<^sub>r (b\<^bsup>\<hyphen>K\<^esup>)"
 apply (cut_tac invf_closed1[of "b"], simp,
        erule conjE, cut_tac field_is_ring,
         simp add:Ring.ring_inv1[of "K" "a" "b\<^bsup>\<hyphen>K\<^esup>"], simp)
 done
 
 lemma (in Corps) field_one_plus_frac1:"\<lbrakk>a \<in> carrier K; b \<in> carrier K; b \<noteq> \<zero>\<rbrakk>
  \<Longrightarrow> 1\<^sub>r \<plusminus> (a \<cdot>\<^sub>r (b\<^bsup>\<hyphen>K\<^esup>)) = (b \<plusminus> a) \<cdot>\<^sub>r (b\<^bsup>\<hyphen>K\<^esup>)"
 apply (cut_tac field_is_ring,
        cut_tac invf_closed1[of b], simp+, erule conjE,
        cut_tac field_is_idom)
  apply (rule Idomain.idom_mult_cancel_r[of K "1\<^sub>r \<plusminus> (a \<cdot>\<^sub>r (b\<^bsup>\<hyphen>K\<^esup>))"
         "(b \<plusminus> a) \<cdot>\<^sub>r (b\<^bsup>\<hyphen>K\<^esup>)" "b"],  assumption+,
        frule Idomain.idom_is_ring[of "K"], frule Ring.ring_is_ag[of "K"],
        rule aGroup.ag_pOp_closed [of "K"], assumption+,
        simp add:Ring.ring_one,rule Ring.ring_tOp_closed, assumption+,
        rule Ring.ring_tOp_closed, assumption+,
        frule Ring.ring_is_ag[of "K"],
        rule aGroup.ag_pOp_closed, assumption+,
        subst Ring.ring_distrib2[of "K" "b"], assumption+,
        simp add:Ring.ring_one, simp add:Ring.ring_tOp_closed,
        simp add:Ring.ring_l_one) thm Ring.ring_distrib2[of K "b\<^bsup>\<hyphen>K\<^esup>"]
  apply (subst Ring.ring_distrib2[of K "b\<^bsup>\<hyphen>K\<^esup>"], assumption+,
        simp add:Ring.ring_tOp_commute[of "K" "b" "b\<^bsup>\<hyphen>K\<^esup>"],
        subst linvf[of "b"], simp,
        subst  Ring.ring_distrib2[of "K" "b"], assumption+,
        simp add:Ring.ring_one, simp add:Ring.ring_tOp_closed,
        simp add:Ring.ring_l_one, simp)
 done
 
 lemma (in Corps) field_one_plus_frac2:"\<lbrakk>a \<in> carrier K; b \<in> carrier K;
  a \<plusminus> b \<noteq> \<zero>\<rbrakk>  \<Longrightarrow> 1\<^sub>r \<plusminus> (-\<^sub>a (a \<cdot>\<^sub>r (a \<plusminus> b)\<^bsup>\<hyphen>K\<^esup>)) = b \<cdot>\<^sub>r ((a \<plusminus> b)\<^bsup>\<hyphen>K\<^esup>)"
 apply (frule field_op_minus[of "a" "a \<plusminus> b"],
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        simp add:aGroup.ag_pOp_closed, assumption, simp,
        thin_tac "-\<^sub>a (a \<cdot>\<^sub>r (a \<plusminus> b)\<^bsup>\<hyphen> K\<^esup>) = (-\<^sub>a a) \<cdot>\<^sub>r (a \<plusminus> b)\<^bsup>\<hyphen> K\<^esup>")
  apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
         frule aGroup.ag_mOp_closed[of "K" "a"], assumption,
         frule field_one_plus_frac1[of "-\<^sub>a a" "a \<plusminus> b"],
         simp add:aGroup.ag_pOp_closed, simp, simp,
         thin_tac "1\<^sub>r \<plusminus> (-\<^sub>a a) \<cdot>\<^sub>r (a \<plusminus> b)\<^bsup>\<hyphen> K\<^esup> = (a \<plusminus> b \<plusminus> -\<^sub>a a) \<cdot>\<^sub>r (a \<plusminus> b)\<^bsup>\<hyphen> K\<^esup>",
         simp add:aGroup.ag_pOp_assoc[of "K" "a" "b" "-\<^sub>a a"],
         simp add:aGroup.ag_pOp_commute[of "K" "b" "-\<^sub>a a"],
         simp add:aGroup.ag_pOp_assoc[THEN sym],
         simp add:aGroup.ag_r_inv1,
         simp add:aGroup.ag_l_zero)
 done
 
 lemma (in Corps) field_one_plus_frac3:"\<lbrakk>x \<in> carrier K; x \<noteq> 1\<^sub>r;
       1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x) \<noteq> \<zero> \<rbrakk> \<Longrightarrow>
       1\<^sub>r \<plusminus> -\<^sub>a x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen> K\<^esup> =
                     (1\<^sub>r \<plusminus> -\<^sub>a x^\<^bsup>K (Suc (Suc 0))\<^esup>) \<cdot>\<^sub>r (1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen> K\<^esup>"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag, frule Ring.ring_one,
        cut_tac invf_closed1[of "1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)"], simp, erule conjE)
 apply (subst Ring.ring_inv1_1, assumption+,
         subst field_one_plus_frac1[of "-\<^sub>a x" "1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)"])
  apply (rule aGroup.ag_mOp_closed, assumption+,
         rule aGroup.ag_pOp_closed, assumption+,
         rule Ring.ring_tOp_closed, assumption+)
  apply (rule aGroup.ag_pOp_closed, assumption+, rule aGroup.ag_mOp_closed,
         assumption+,
         subst Ring.ring_distrib1, assumption+,
         rule aGroup.ag_mOp_closed, assumption+)
  apply (simp add:Ring.ring_r_one)
  apply (simp add:Ring.ring_inv1_2[THEN sym, of K x x])
  apply (subgoal_tac "1\<^sub>r \<plusminus> (x \<plusminus> -\<^sub>a x \<cdot>\<^sub>r x) \<plusminus> -\<^sub>a x = 1\<^sub>r \<plusminus> -\<^sub>a x^\<^bsup>K (Suc (Suc 0))\<^esup>",
         simp,
         frule Ring.ring_tOp_closed[of K x x], assumption+)
 
  apply (frule Ring.ring_tOp_closed[of K x x], assumption+,
         frule aGroup.ag_mOp_closed[of K "x \<cdot>\<^sub>r x"], assumption+,
         frule aGroup.ag_mOp_closed[of K x], assumption+)
  apply (subst aGroup.ag_pOp_assoc, assumption+,
         rule aGroup.ag_pOp_closed, assumption+)
   apply (rule aGroup.ag_pOp_add_l[of K "x \<plusminus> -\<^sub>a x \<cdot>\<^sub>r x \<plusminus> -\<^sub>a x"
          "-\<^sub>a x^\<^bsup>K (Suc (Suc 0))\<^esup>" "1\<^sub>r"], assumption+,
          (rule aGroup.ag_pOp_closed, assumption+)+,
          rule aGroup.ag_mOp_closed, assumption+, rule Ring.npClose,
          assumption+,
          subst aGroup.ag_pOp_commute, assumption+,
          simp add:aGroup.ag_pOp_assoc aGroup.ag_r_inv1 aGroup.ag_r_zero)
    apply (simp add:Ring.ring_l_one)
 apply simp
  apply (rule aGroup.ag_pOp_closed, assumption+,
         rule Ring.ring_tOp_closed, assumption+,
         rule aGroup.ag_pOp_closed, assumption+,
         rule aGroup.ag_mOp_closed[of K x], assumption+)
 done
 
 lemma (in Corps) OstrowskiTr1:"\<lbrakk> valuation K v; s \<in> carrier K; t \<in> carrier K;
       0 \<le> (v s); v t < 0\<rbrakk>  \<Longrightarrow> s \<plusminus> t \<noteq> \<zero>"
 apply (rule contrapos_pp, simp+,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        simp only:aGroup.ag_plus_zero[THEN sym, of "K" "s" "t"])
 apply (simp add:val_minus_eq[of "v" "t"])
 done
 
 lemma (in Corps) OstrowskiTr2:"\<lbrakk>valuation K v; s \<in> carrier K; t \<in> carrier K;
   0 \<le> (v s); v t < 0\<rbrakk>  \<Longrightarrow> 0 < (v (1\<^sub>r \<plusminus> (-\<^sub>a ((t \<cdot>\<^sub>r ((s \<plusminus> t)\<^bsup>\<hyphen>K\<^esup>))))))"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule OstrowskiTr1[of "v" "s" "t"], assumption+,
        frule field_one_plus_frac2[of "t" "s"], assumption+,
        simp add:aGroup.ag_pOp_commute)
 apply (subst aGroup.ag_pOp_commute[of "K" "s" "t"], assumption+, simp,
        simp add:aGroup.ag_pOp_commute[of "K" "t" "s"],
        thin_tac "1\<^sub>r \<plusminus> -\<^sub>a (t \<cdot>\<^sub>r (s \<plusminus> t)\<^bsup>\<hyphen> K\<^esup>) = s \<cdot>\<^sub>r (s \<plusminus> t)\<^bsup>\<hyphen> K\<^esup>",
        frule aGroup.ag_pOp_closed[of "K" "s" "t"], assumption+,
        cut_tac invf_closed1[of "s \<plusminus> t"], simp, erule conjE)
 apply (simp add:val_t2p,
        simp add:value_of_inv,
        frule aless_le_trans[of "v t" "0" "v s"], assumption+,
        frule value_less_eq[THEN sym, of v t s], assumption+,
        simp add:aGroup.ag_pOp_commute,
        frule aless_diff_poss[of "v t" "v s"], simp add:diff_ant_def, simp)
 done
 
 lemma (in Corps) OstrowskiTr3:"\<lbrakk>valuation K v; s \<in> carrier K; t \<in> carrier K;
       0 \<le> (v t); v s < 0\<rbrakk>  \<Longrightarrow> 0 < (v (t \<cdot>\<^sub>r (( s \<plusminus> t)\<^bsup>\<hyphen>K\<^esup>)))"
 apply (frule aless_le_trans[of "v s" "0" "v t"], assumption+,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule aGroup.ag_pOp_closed[of "K" "s" "t"], assumption+,
        frule OstrowskiTr1[of v t s], assumption+,
        frule value_less_eq[THEN sym, of v s t], assumption+)
 apply (simp add:aGroup.ag_pOp_commute[of K t s],
        cut_tac invf_closed1[of "s \<plusminus> t"], simp) apply (
        erule conjE, simp add:val_t2p[of v], simp add:value_of_inv)
        apply (cut_tac aless_diff_poss[of "v s" "v t"],
               simp add:diff_ant_def, simp+)
 done
 
 lemma (in Corps) restrict_Ostrowski_elem:"\<lbrakk> x \<in> carrier K;
   Ostrowski_elem K (Suc (Suc n)) vv x\<rbrakk> \<Longrightarrow> Ostrowski_elem K (Suc n) vv x"
 apply (simp add:Ostrowski_elem_def,
        erule conjE, rule ballI, simp add:nset_def,
        insert lessI [of "Suc n"])
 done
 
 lemma (in Corps) restrict_vals_nonequiv:"vals_nonequiv K (Suc (Suc n)) vv \<Longrightarrow>
                   vals_nonequiv K (Suc n) vv"
 apply (simp add:vals_nonequiv_def,
        erule conjE, simp add:valuations_def)
 done
 
 lemma (in Corps) restrict_vals_nonequiv1:"vals_nonequiv K (Suc (Suc n)) vv \<Longrightarrow>
        vals_nonequiv K (Suc n) (compose {h. h \<le> (Suc n)} vv (skip 1))"
 apply (simp add:vals_nonequiv_def, (erule conjE)+,
        rule conjI,
        thin_tac "\<forall>j\<le>Suc (Suc n). \<forall>l\<le>Suc (Suc n). j \<noteq> l \<longrightarrow>
                                        \<not> v_equiv K (vv j) (vv l)",
       simp add:valuations_def, rule allI, rule impI,
       simp add:compose_def skip_def nset_def)
  apply ((rule allI, rule impI)+, rule impI)
  apply (simp add:compose_def skip_def nset_def)
 done
 
 lemma (in Corps) restrict_vals_nonequiv2:"\<lbrakk>vals_nonequiv K (Suc (Suc n)) vv\<rbrakk>
       \<Longrightarrow> vals_nonequiv K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 2))"
 apply (simp add:vals_nonequiv_def, (erule conjE)+,
       rule conjI,
       thin_tac "\<forall>j\<le>Suc (Suc n). \<forall>l\<le>Suc (Suc n). j \<noteq> l \<longrightarrow>
                                               \<not> v_equiv K (vv j) (vv l)",
       simp add:valuations_def,
       rule allI, rule impI)
  apply (simp add:compose_def skip_def nset_def,
        (rule allI, rule impI)+, rule impI,
        simp add:compose_def skip_def nset_def)
 done
 
 lemma (in Corps)  OstrowskiTr31:"\<lbrakk>valuation K v; s \<in> carrier K;
         0 < (v (1\<^sub>r \<plusminus> (-\<^sub>a s)))\<rbrakk> \<Longrightarrow> s \<noteq> \<zero>"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"])
 apply (rule contrapos_pp, simp+)
  apply (simp add:aGroup.ag_inv_zero,
         frule Ring.ring_one[of "K"], simp add:aGroup.ag_r_zero)
  apply (simp add:value_of_one)
 done
 
 lemma (in Corps) OstrowskiTr32:"\<lbrakk>valuation K v; s \<in> carrier K;
            0 < (v (1\<^sub>r \<plusminus> (-\<^sub>a s)))\<rbrakk> \<Longrightarrow> 0 \<le> (v s)"
 apply (rule contrapos_pp, simp+,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        simp add:aneg_le,
        frule has_val_one_neq_zero[of "v"])
 apply (frule OstrowskiTr31[of v s], assumption+,
        frule not_sym,
        frule Ring.ring_one[of "K"])
 apply (frule value_less_eq[THEN sym, of v "-\<^sub>a s" "1\<^sub>r"],
        simp add:aGroup.ag_mOp_closed, assumption+,
        simp add:val_minus_eq)
 apply (simp add:value_of_one,
        frule aGroup.ag_mOp_closed[of "K" "s"], assumption+,
        simp add:aGroup.ag_pOp_commute[of "K" "-\<^sub>a s" "1\<^sub>r"],
        simp add:val_minus_eq)
 done
 
 lemma (in Corps) OstrowskiTr4:"\<lbrakk>valuation K v; s \<in> carrier K; t \<in> carrier K;
       0 < (v (1\<^sub>r \<plusminus> (-\<^sub>a s))); 0 < (v (1\<^sub>r \<plusminus> (-\<^sub>a t)))\<rbrakk>  \<Longrightarrow>
                               0 < (v (1\<^sub>r \<plusminus> (-\<^sub>a (s \<cdot>\<^sub>r t))))"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule Ring.ring_one[of "K"])
 apply (subgoal_tac "1\<^sub>r \<plusminus> (-\<^sub>a (s \<cdot>\<^sub>r t)) =
                     1\<^sub>r \<plusminus> (-\<^sub>a s) \<plusminus> (s \<cdot>\<^sub>r (1\<^sub>r \<plusminus> (-\<^sub>a t)))", simp,
        thin_tac "1\<^sub>r \<plusminus> -\<^sub>a (s \<cdot>\<^sub>r t) = 1\<^sub>r \<plusminus> -\<^sub>a s \<plusminus> s \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a t)")
 apply (frule aGroup.ag_mOp_closed[of K s], assumption+,
        frule aGroup.ag_pOp_closed[of K "1\<^sub>r" "-\<^sub>a s"], assumption+,
        frule aGroup.ag_mOp_closed[of "K" "t"], assumption+,
        frule aGroup.ag_pOp_closed[of "K" "1\<^sub>r" "-\<^sub>a t"], assumption+,
        frule Ring.ring_tOp_closed[of "K" "s" "1\<^sub>r \<plusminus> (-\<^sub>a t)"], assumption+,
        frule amin_le_plus[of v "1\<^sub>r \<plusminus> (-\<^sub>a s)" "s \<cdot>\<^sub>r (1\<^sub>r \<plusminus> (-\<^sub>a t))"], assumption+)
 apply (frule amin_gt[of "0" "v (1\<^sub>r \<plusminus> -\<^sub>a s)" "v (s \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a t))"])
 apply (simp add:val_t2p,
        frule OstrowskiTr32[of v s], assumption+,
        rule aadd_pos_poss[of "v s" "v (1\<^sub>r \<plusminus> -\<^sub>a t)"], assumption+,
        simp add:Ring.ring_distrib1)
 apply (frule aGroup.ag_mOp_closed[of K t], assumption,
        simp add:Ring.ring_distrib1 Ring.ring_r_one,
        frule aGroup.ag_mOp_closed[of K s], assumption+,
        subst aGroup.pOp_assocTr43, assumption+,
        simp add:Ring.ring_tOp_closed,
        simp add:aGroup.ag_l_inv1 aGroup.ag_r_zero,
        simp add:Ring.ring_inv1_2)
 done
 
 lemma (in Corps) OstrowskiTr5:"\<lbrakk> vals_nonequiv K (Suc (Suc n)) vv;
   s \<in> carrier K; t \<in> carrier K;
   0 \<le> (vv (Suc 0)) s \<and> 0 \<le> (vv (Suc (Suc 0))) t;
   Ostrowski_elem K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 1)) s;
   Ostrowski_elem K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 2)) t\<rbrakk> \<Longrightarrow>
   Ostrowski_elem K (Suc (Suc n)) vv (s \<cdot>\<^sub>r t)"
 apply (erule conjE,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule_tac x = s and y = t in Ring.ring_tOp_closed[of "K"], assumption+,
        frule skip_vals_nonequiv[of n "vv" "1"],
        frule skip_vals_nonequiv[of n "vv" "2"],
        subst Ostrowski_elem_def, rule conjI)
 
 apply (rule  OstrowskiTr4,
        simp add:vals_nonequiv_valuation[of "Suc (Suc n)" "vv" "0"],
        assumption+,
        frule Ostrowski_elem_0[of  "Suc n"
          "compose {j. j \<le> (Suc n)} vv (skip 1)" "s"], assumption+,
        simp add:skip_def compose_def,
        frule Ostrowski_elem_0[of "Suc n"
          "compose {j. j \<le> (Suc n)} vv (skip 2)" "t"], assumption+,
        simp add:skip_def compose_def)
 
 apply (rule ballI,
       case_tac "j = Suc 0",
       frule_tac j = " Suc 0" in Ostrowski_elem_Suc[of "Suc n"
         "compose {j. j \<le> (Suc n)} vv (skip 2)" "t"], assumption+,
         simp add:nset_def) apply (
  thin_tac "Ostrowski_elem K (Suc n) (compose {j. j \<le> Suc n} vv (skip 1)) s",
  thin_tac "Ostrowski_elem K (Suc n) (compose {j. j \<le> Suc n} vv (skip 2)) t",
  thin_tac "vals_nonequiv K (Suc n) (compose {l. l \<le> Suc n} vv (skip 1))",
       frule vals_nonequiv_valuation[of  "Suc n"
        "compose {j. j \<le> (Suc n)} vv (skip 2)" "Suc 0"])
  apply simp+
  apply (simp add:skip_def compose_def,
         simp add:val_t2p, simp add:aadd_pos_poss)
 
  (** Ostrowski_elem_Suc case j = Suc (Suc 0) **)
 apply (case_tac "j = Suc (Suc 0)",
        frule vals_nonequiv_valuation[of "Suc n"
         "compose {j. j \<le> Suc n} vv (skip 1)" "Suc 0"],
         simp,
        frule_tac j = " Suc 0" in Ostrowski_elem_Suc[of "Suc n"
         "compose {j. j \<le> (Suc n)} vv (skip 1)" "s"],
          assumption+, simp add:nset_def,
          simp add:skip_def compose_def,
        simp add:val_t2p, rule aadd_poss_pos, assumption+)
 apply (frule_tac j = j in nsetTr1[of _ "Suc 0" "Suc (Suc n)"], assumption,
        frule_tac j = j in nsetTr2[of _ "Suc 0" "Suc n"],
        thin_tac "j \<in> nset (Suc (Suc 0)) (Suc (Suc n))",
        frule_tac j = "j - Suc 0" in Ostrowski_elem_Suc[of "Suc n"
                 "compose {j. j \<le> (Suc n)} vv (skip 1)" "s"], assumption+)
 
 apply (frule_tac j = "j - Suc 0" in Ostrowski_elem_Suc[of "Suc n"
                  "compose {j. j \<le> (Suc n)} vv (skip 2)" "t"], assumption+,
  thin_tac "Ostrowski_elem K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 1)) s",
  thin_tac "Ostrowski_elem K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 2)) t",
  thin_tac "vals_nonequiv K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 1))",
  thin_tac "vals_nonequiv K (Suc n) (compose {j. j \<le> (Suc n)} vv (skip 2))")
 
 apply (simp add:compose_def skip_def nset_def,
       (erule conjE)+, simp, subgoal_tac "\<not> (j - Suc 0 \<le> Suc 0)", simp)
 apply (frule_tac m = j in vals_nonequiv_valuation[of "Suc (Suc n)"],
        assumption+,
       simp add:val_t2p,
       rule_tac x = "vv j s" and y = "vv j t" in aadd_pos_poss,
       simp add:aless_imp_le, assumption)
 apply simp
 done
 
 lemma (in Corps) one_plus_x_nonzero:"\<lbrakk>valuation K v; x \<in> carrier K; v x < 0\<rbrakk>
       \<Longrightarrow> 1\<^sub>r \<plusminus> x \<in> carrier K \<and> v (1\<^sub>r \<plusminus> x) < 0"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule Ring.ring_one[of "K"],
        frule aGroup.ag_pOp_closed[of "K" "1\<^sub>r" "x"], assumption+,
        simp)
 apply (frule value_less_eq[of "v" "x" "1\<^sub>r"], assumption+,
        simp add:value_of_one, simp add:aGroup.ag_pOp_commute)
 done
 
 lemma (in Corps)  val_neg_nonzero:"\<lbrakk>valuation K v; x \<in> carrier K; v x < 0\<rbrakk> \<Longrightarrow>
                                      x \<noteq> \<zero>"
 apply (rule contrapos_pp, simp+, simp add:value_of_zero)
 apply (frule aless_imp_le[of "\<infinity>" "0"],
         cut_tac inf_ge_any[of "0"],
         frule ale_antisym[of "0" "\<infinity>"], assumption+, simp)
 done
 
 lemma (in Corps) OstrowskiTr6:"\<lbrakk>valuation K v; x \<in> carrier K; \<not> 0 \<le> (v x)\<rbrakk> \<Longrightarrow>
        (1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)) \<in> carrier K - {\<zero>}"
 apply (simp add:aneg_le,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule aGroup.ag_mOp_closed[of "K" "x"], assumption+,
        frule one_plus_x_nonzero[of "v" "-\<^sub>a x"], assumption+,
         simp add:val_minus_eq, erule conjE)
 
 apply (rule conjI,
        rule aGroup.ag_pOp_closed[of "K"], assumption+,
        simp add:Ring.ring_one, rule Ring.ring_tOp_closed[of "K"], assumption+)
 
 apply (frule val_t2p[of v x "1\<^sub>r \<plusminus> (-\<^sub>a x)"], assumption+,
        frule val_neg_nonzero[of v x], assumption+,
        frule val_nonzero_z[of v x], assumption+, erule exE,
        frule_tac z = z in aadd_less_mono_z[of "v (1\<^sub>r \<plusminus> (-\<^sub>a x))" "0"],
        simp add:aadd_0_l,
        simp only:aadd_commute[of "v (1\<^sub>r \<plusminus> -\<^sub>a x)"],
        frule_tac x = "ant z + v (1\<^sub>r \<plusminus> -\<^sub>a x)" and y ="ant z" in
          aless_trans[of _ _ "0"], assumption,
        drule sym, simp)
 
 apply (frule_tac x = x and y = "1\<^sub>r \<plusminus> -\<^sub>a x" in Ring.ring_tOp_closed[of "K"],
              assumption+,
        frule one_plus_x_nonzero[of v "x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> (-\<^sub>a x))"],
                       assumption+, erule conjE,
        rule val_neg_nonzero[of v], assumption+)
 done
 
 lemma (in Corps) OstrowskiTr7:"\<lbrakk>valuation K v; x \<in> carrier K; \<not> 0 \<le> (v x)\<rbrakk> \<Longrightarrow>
   1\<^sub>r \<plusminus> -\<^sub>a (x \<cdot>\<^sub>r ((1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen>K\<^esup>)) =
      (1\<^sub>r \<plusminus> -\<^sub>a x \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)) \<cdot>\<^sub>r ((1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen>K\<^esup>)"
 apply (cut_tac field_is_ring,
        frule OstrowskiTr6[of v x], assumption+, simp, erule conjE,
        cut_tac field_is_idom,
        cut_tac invf_closed1[of "1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)"], simp,
        frule Ring.ring_is_ag[of "K"],
        frule aGroup.ag_mOp_closed[of "K" "x"], assumption+,
        frule Ring.ring_one[of "K"],
        frule aGroup.ag_pOp_closed[of "K" "1\<^sub>r" "-\<^sub>a x"], assumption+,
        rule Idomain.idom_mult_cancel_r[of K "1\<^sub>r \<plusminus> -\<^sub>a (x \<cdot>\<^sub>r ((1\<^sub>r \<plusminus> x \<cdot>\<^sub>r
        (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen>K\<^esup>))" "(1\<^sub>r \<plusminus> -\<^sub>a x \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)) \<cdot>\<^sub>r
        ((1\<^sub>r \<plusminus>  x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen>K\<^esup>)" "(1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))"],
        assumption+)
 apply (rule aGroup.ag_pOp_closed, assumption+, rule aGroup.ag_mOp_closed,
        assumption+,
        rule Ring.ring_tOp_closed, assumption+, simp, rule Ring.ring_tOp_closed,
        assumption+,
        (rule aGroup.ag_pOp_closed, assumption+)+,
        rule  Ring.ring_tOp_closed, assumption+, simp, assumption+,
        subst Ring.ring_tOp_assoc, assumption+,
        rule aGroup.ag_pOp_closed, assumption+,
        simp add:Ring.ring_tOp_closed, simp, simp)
 apply (subst linvf[of "1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x)"], simp,
        (subst Ring.ring_distrib2, assumption+)+, erule conjE)
 apply (rule aGroup.ag_mOp_closed, assumption,
        rule Ring.ring_tOp_closed, assumption+,
        subst Ring.ring_r_one, assumption+)
 apply (rule aGroup.ag_pOp_closed, assumption+,
        rule Ring.ring_tOp_closed, assumption+,
        erule conjE,
        simp add:Ring.ring_inv1_1,
        simp add:Ring.ring_tOp_assoc[of K "-\<^sub>a x" "(1\<^sub>r \<plusminus> x \<cdot>\<^sub>r (1\<^sub>r \<plusminus> -\<^sub>a x))\<^bsup>\<hyphen> K\<^esup>"],
        simp add:linvf, simp add:Ring.ring_r_one Ring.ring_l_one,
        frule Ring.ring_tOp_closed[of K x "1\<^sub>r \<plusminus> -\<^sub>a x"], assumption+,
        simp add:aGroup.ag_pOp_assoc, simp add:aGroup.ag_pOp_commute)
 apply simp
 done
 
 lemma (in Corps) Ostrowski_elem_nonzero:"\<lbrakk>vals_nonequiv K (Suc n) vv;
  x \<in> carrier K; Ostrowski_elem K (Suc n) vv x\<rbrakk> \<Longrightarrow> x \<noteq> \<zero>"
 apply (simp add:Ostrowski_elem_def,
        frule conjunct1, fold Ostrowski_elem_def,
        frule vals_nonequiv_valuation[of "Suc n" "vv" "0"], simp)
 apply (rule contrapos_pp, simp+,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        simp add:aGroup.ag_inv_zero, frule Ring.ring_one[of "K"],
        simp add:aGroup.ag_r_zero, simp add:value_of_one)
 done
 
 lemma (in Corps) Ostrowski_elem_not_one:"\<lbrakk>vals_nonequiv K (Suc n) vv;
       x \<in> carrier K; Ostrowski_elem K (Suc n) vv x\<rbrakk>  \<Longrightarrow>  1\<^sub>r \<plusminus> -\<^sub>a x \<noteq> \<zero>"
 apply (frule vals_nonequiv_valuation [of "Suc n" "vv" "Suc 0"],
        simp,
        simp add:Ostrowski_elem_def, frule conjunct2,
        fold Ostrowski_elem_def)
 apply (subgoal_tac "0 < (vv (Suc 0) x)",
        rule contrapos_pp, simp+,
        cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule Ring.ring_one[of "K"],
        simp only:aGroup.ag_eq_diffzero[THEN sym, of "K" "1\<^sub>r" "x"],
        drule sym, simp, simp add:value_of_one,
        subgoal_tac "Suc 0 \<in> nset (Suc 0) (Suc n)", simp,
        simp add:nset_def)
 done
 
 lemma (in Corps) val_unit_cond:"\<lbrakk> valuation K v; x \<in> carrier K;
       0 < (v (1\<^sub>r \<plusminus> -\<^sub>a x))\<rbrakk>  \<Longrightarrow> v x = 0"
 apply (cut_tac field_is_ring, frule Ring.ring_is_ag[of "K"],
        frule Ring.ring_one[of "K"])
 
 apply (frule aGroup.ag_mOp_closed[of "K" "1\<^sub>r"], assumption+,
        frule has_val_one_neq_zero[of v])
 
 apply (frule aGroup.ag_pOp_assoc[of "K" "-\<^sub>a 1\<^sub>r" "1\<^sub>r" "-\<^sub>a x"], assumption+,
        simp add:aGroup.ag_mOp_closed, simp add:aGroup.ag_l_inv1,
        frule aGroup.ag_mOp_closed[of "K" "x"], assumption+,
        simp add:aGroup.ag_l_zero)
 apply (subgoal_tac "v (-\<^sub>a x) = v ( -\<^sub>a 1\<^sub>r \<plusminus> (1\<^sub>r \<plusminus> -\<^sub>a x))") prefer 2
   apply simp
 apply (thin_tac "-\<^sub>a x =  -\<^sub>a 1\<^sub>r \<plusminus> (1\<^sub>r \<plusminus> -\<^sub>a x)",
        frule value_less_eq[of "v" "-\<^sub>a 1\<^sub>r" "1\<^sub>r \<plusminus> -\<^sub>a x"],
                                   assumption+,
        rule aGroup.ag_pOp_closed, assumption+,
        simp add:val_minus_eq value_of_one, simp add:val_minus_eq)
 apply (simp add: value_of_one)
 done
 
 end
diff --git a/thys/Virtual_Substitution/OptimizationProofs.thy b/thys/Virtual_Substitution/OptimizationProofs.thy
--- a/thys/Virtual_Substitution/OptimizationProofs.thy
+++ b/thys/Virtual_Substitution/OptimizationProofs.thy
@@ -1,702 +1,704 @@
 subsection "Optimization Proofs"
 theory OptimizationProofs
   imports Optimizations
 begin
 
 lemma neg_nnf : "\<forall>\<Gamma>. (\<not> eval (nnf (Neg \<phi>)) \<Gamma>) = eval (nnf \<phi>) \<Gamma>"
   apply(induction \<phi>)
            apply(simp_all)
   using aNeg_aEval apply blast
   using aNeg_aEval by blast
 
 theorem eval_nnf : "\<forall>\<Gamma>. eval \<phi> \<Gamma> = eval (nnf \<phi>) \<Gamma>"
   apply(induction \<phi>)apply(simp_all) using neg_nnf by blast
 
 
 theorem negation_free_nnf : "negation_free (nnf \<phi>)"
 proof(induction "depth \<phi>" arbitrary : \<phi> rule: nat_less_induct )
   case 1
   then show ?case
   proof(induction \<phi>)
     case (And \<phi>1 \<phi>2)
     then show ?case apply simp
       by (metis less_Suc_eq_le max.cobounded1 max.cobounded2)
   next
     case (Or \<phi>1 \<phi>2)
     then show ?case apply simp
       by (metis less_Suc_eq_le max.cobounded1 max.cobounded2)
   next
     case (Neg \<phi>)
     then show ?case proof (induction \<phi>)
       case (And \<phi>1 \<phi>2)
       then show ?case apply simp
         by (metis less_Suc_eq max_less_iff_conj not_less_eq)
     next
       case (Or \<phi>1 \<phi>2)
       then show ?case apply simp
         by (metis less_Suc_eq max_less_iff_conj not_less_eq)
     next
       case (Neg \<phi>)
       then show ?case
         by (metis Suc_eq_plus1 add_lessD1 depth.simps(6) lessI nnf.simps(12))
     qed auto
   qed auto
 qed
 
 
 lemma groupQuantifiers_eval : "eval F L = eval (groupQuantifiers F) L"
   apply(induction F arbitrary: L  rule:groupQuantifiers.induct) 
   unfolding doubleExist unwrapExist unwrapExist' unwrapExist'' doubleForall unwrapForall unwrapForall' unwrapForall''
   apply (auto)
   using doubleExist doubleExist unwrapExist unwrapExist' unwrapExist'' doubleForall unwrapForall unwrapForall' unwrapForall''  apply auto
   by metis+
 
 
 theorem simp_atom_eval : "aEval a xs = eval (simp_atom a) xs"
 proof(cases a)
   case (Less p)
   then show ?thesis by(cases "get_if_const p")(simp_all add:get_if_const_insertion)
 next
   case (Eq p)
   then show ?thesis by(cases "get_if_const p")(simp_all add:get_if_const_insertion)
 next
   case (Leq p)
   then show ?thesis by(cases "get_if_const p")(simp_all add:get_if_const_insertion)
 next
   case (Neq p)
   then show ?thesis by(cases "get_if_const p")(simp_all add:get_if_const_insertion)
 qed
 
 lemma simpfm_eval : "\<forall>L. eval \<phi> L = eval (simpfm \<phi>) L"
   apply(induction \<phi>)
   apply(simp_all add: simp_atom_eval eval_and eval_or)
   using eval_neg by blast
 
 lemma exQ_clearQuantifiers:
   assumes ExQ : "\<And>xs. eval (clearQuantifiers \<phi>) xs = eval \<phi> xs"
   shows "eval (clearQuantifiers (ExQ \<phi>)) xs = eval (ExQ \<phi>) xs"
 proof-
   define \<phi>' where "\<phi>' = clearQuantifiers \<phi>"
   have h : "freeIn 0 \<phi>' \<Longrightarrow> (eval (lowerFm 0 1 \<phi>') xs = eval (ExQ \<phi>') xs)"
     using eval_lowerFm by simp
   have "eval (clearQuantifiers (ExQ \<phi>)) xs = 
       eval (if freeIn 0 \<phi>' then lowerFm 0 1 \<phi>' else ExQ \<phi>') xs"
     using \<phi>'_def by simp
   also have "... = eval (ExQ \<phi>) xs"
     apply(cases "freeIn 0 \<phi>'")
     using h ExQ \<phi>'_def by(simp_all)
   finally show ?thesis
     by simp
 qed
 
 lemma allQ_clearQuantifiers :
   assumes AllQ : "\<And>xs. eval (clearQuantifiers \<phi>) xs = eval \<phi> xs"
   shows "eval (clearQuantifiers (AllQ \<phi>)) xs = eval (AllQ \<phi>) xs"
 proof-
   define \<phi>' where "\<phi>' = clearQuantifiers \<phi>"
   have "freeIn 0 \<phi>' \<Longrightarrow> (eval (ExQ \<phi>') xs) = eval (AllQ \<phi>') xs"
     by (simp add: var_not_in_eval2)
   then have h : "freeIn 0 \<phi>' \<Longrightarrow> (eval (lowerFm 0 1 \<phi>') xs = eval (AllQ \<phi>') xs)"
     using eval_lowerFm by simp
   have "eval (clearQuantifiers (AllQ \<phi>)) xs = 
       eval (if freeIn 0 \<phi>' then lowerFm 0 1 \<phi>' else AllQ \<phi>') xs"
     using \<phi>'_def by simp
   also have "... = eval (AllQ \<phi>) xs"
     apply(cases "freeIn 0 \<phi>'")
     using h AllQ \<phi>'_def by(simp_all)
   finally show ?thesis 
     by simp
 qed
 
 lemma clearQuantifiers_eval : "eval (clearQuantifiers \<phi>) xs = eval \<phi> xs"
 proof(induction \<phi> arbitrary : xs)
   case (Atom x)
   then show ?case using simp_atom_eval by simp
 next
   case (And \<phi>1 \<phi>2)
   then show ?case using eval_and by simp
 next
   case (Or \<phi>1 \<phi>2)
   then show ?case using eval_or by simp
 next
   case (Neg \<phi>)
   then show ?case using eval_neg by auto
 next
   case (ExQ \<phi>)
   then show ?case using exQ_clearQuantifiers by simp
 next
   case (AllQ \<phi>)
   then show ?case using allQ_clearQuantifiers by simp
 next
   case (ExN x1 \<phi>)
   then show ?case proof(induction x1 arbitrary:\<phi>)
     case 0
     then show ?case by auto
   next
     case (Suc x1)
     show ?case
       using Suc(1)[of "ExQ \<phi>", OF exQ_clearQuantifiers[OF Suc(2)]]
       apply simp
       using Suc_eq_plus1 \<open>eval (clearQuantifiers (ExN x1 (ExQ \<phi>))) xs = eval (ExN x1 (ExQ \<phi>)) xs\<close> eval.simps(10) unwrapExist' by presburger
   qed
 next
   case (AllN x1 \<phi>)
   then show ?case proof(induction x1 arbitrary:\<phi>)
     case 0
     then show ?case by auto
   next
     case (Suc x1)
     show ?case
       using Suc(1)[of "AllQ \<phi>", OF allQ_clearQuantifiers[OF Suc(2)]]
       apply simp
       using unwrapForall' by force
   qed
 qed auto
 
 lemma  push_forall_eval_AllQ : "\<forall>xs. eval (AllQ \<phi>) xs = eval (push_forall (AllQ \<phi>)) xs"
 proof(induction \<phi>)
   case TrueF
   then show ?case by simp
 next
   case FalseF
   then show ?case by simp
 next
   case (Atom x)
   then show ?case
     using aEval_lowerAtom eval.simps(1) eval.simps(8) push_forall.simps(11) by presburger
 next
   case (And \<phi>1 \<phi>2)
   {fix xs
     have "eval (AllQ (And \<phi>1 \<phi>2)) xs = (\<forall>x. eval \<phi>1 (x#xs) \<and> eval \<phi>2 (x#xs))"
       by simp
     also have "... = ((\<forall>x. eval \<phi>1 (x#xs)) \<and> (\<forall>x. eval \<phi>2 (x#xs)))"
       by blast
     also have "... = eval (push_forall (AllQ (And \<phi>1 \<phi>2))) xs"
       using And eval_and by(simp)
     finally have "eval (AllQ (And \<phi>1 \<phi>2)) xs = eval (push_forall (AllQ (And \<phi>1 \<phi>2))) xs"
       by simp
   }
   then show ?case by simp 
 next
   case (Or \<phi>1 \<phi>2)
   then show ?case proof(cases "freeIn 0 \<phi>1")
     case True
     then have h : "freeIn 0 \<phi>1"
       by simp
     then show ?thesis proof(cases "freeIn 0 \<phi>2")
       case True
       {fix xs
         have "\<exists>x. eval \<phi>1 (x # xs) = eval (lowerFm 0 1 \<phi>1) xs"
           using eval_lowerFm h eval.simps(7) by blast 
         then have h1 : "\<forall>x. eval \<phi>1 (x # xs) = eval (lowerFm 0 1 \<phi>1) xs"
           using h var_not_in_eval2 by blast
         have "\<exists>x. eval \<phi>2 (x # xs) = eval (lowerFm 0 1 \<phi>2) xs"
           using eval_lowerFm True eval.simps(7) by blast 
         then have h2 : "\<forall>x. eval \<phi>2 (x # xs) = eval (lowerFm 0 1 \<phi>2) xs"
           using True var_not_in_eval2 by blast
         have "eval (AllQ (Or \<phi>1 \<phi>2)) xs = eval (push_forall (AllQ (Or \<phi>1 \<phi>2))) xs"
           by(simp add:h h1 h2 True eval_or)
       }
       then show ?thesis by simp
     next
       case False
       {fix xs
         have "\<exists>x. eval \<phi>1 (x # xs) = eval (lowerFm 0 1 \<phi>1) xs"
           using eval_lowerFm h eval.simps(7) by blast 
         then have "\<forall>x. eval \<phi>1 (x # xs) = eval (lowerFm 0 1 \<phi>1) xs"
           using True var_not_in_eval2 by blast
         then have "eval (AllQ (Or \<phi>1 \<phi>2)) xs = eval (push_forall (AllQ (Or \<phi>1 \<phi>2))) xs"
           by(simp add:h False eval_or)
       }
       then show ?thesis by simp
     qed
   next
     case False
     then have h : "\<not>freeIn 0 \<phi>1"
       by simp
     then show ?thesis proof(cases "freeIn 0 \<phi>2")
       case True
       {fix xs
         have "\<exists>x. eval \<phi>2 (x # xs) = eval (lowerFm 0 1 \<phi>2) xs"
           using eval_lowerFm True eval.simps(7) by blast 
         then have "\<forall>x. eval \<phi>2 (x # xs) = eval (lowerFm 0 1 \<phi>2) xs"
           using True var_not_in_eval2 by blast
         then have "eval (AllQ (Or \<phi>1 \<phi>2)) xs = eval (push_forall (AllQ (Or \<phi>1 \<phi>2))) xs"
           by(simp add:h True eval_or)
       }
       then show ?thesis by simp
     next
       case False
       then show ?thesis by(simp add:h False eval_or)
     qed
   qed
 next
   case (Neg \<phi>)
   {fix xs
     have "freeIn 0 (Neg \<phi>) \<Longrightarrow> (eval (ExQ (Neg \<phi>)) xs) = eval (AllQ (Neg \<phi>)) xs"
       using var_not_in_eval2 eval.simps(7) eval.simps(8) by blast
     then have h : "freeIn 0 (Neg \<phi>) \<Longrightarrow> (eval (lowerFm 0 1 (Neg \<phi>)) xs = eval (AllQ (Neg \<phi>)) xs)"
       using eval_lowerFm by blast
     have "eval (push_forall (AllQ (Neg \<phi>))) xs = 
       eval (if freeIn 0 (Neg \<phi>) then lowerFm 0 1 (Neg \<phi>) else AllQ (Neg \<phi>)) xs"
       by simp
     also have "... = eval (AllQ (Neg \<phi>)) xs"
       apply(cases "freeIn 0 (Neg \<phi>)")
       using h  by(simp_all)
     finally have "eval (push_forall (AllQ (Neg \<phi>))) xs = eval (AllQ (Neg \<phi>)) xs"
       by simp
   }
   then show ?case by simp
 next
   case (ExQ \<phi>)
   {fix xs
     have "freeIn 0 (ExQ \<phi>) \<Longrightarrow> (eval (ExQ (ExQ \<phi>)) xs) = eval (AllQ (ExQ \<phi>)) xs"
       using var_not_in_eval2 eval.simps(7) eval.simps(8) by blast
     then have h : "freeIn 0 (ExQ \<phi>) \<Longrightarrow> (eval (lowerFm 0 1 (ExQ \<phi>)) xs = eval (AllQ (ExQ \<phi>)) xs)"
       using eval_lowerFm by blast
     have "eval (push_forall (AllQ (ExQ \<phi>))) xs = 
       eval (if freeIn 0 (ExQ \<phi>) then lowerFm 0 1 (ExQ \<phi>) else AllQ (ExQ \<phi>)) xs"
       by simp
     also have "... = eval (AllQ (ExQ \<phi>)) xs"
       apply(cases "freeIn 0 (ExQ \<phi>)")
       using h  by(simp_all)
     finally have "eval (push_forall (AllQ (ExQ \<phi>))) xs = eval (AllQ (ExQ \<phi>)) xs"
       by simp
   }
   then show ?case by simp
 next
   case (AllQ \<phi>)
   {fix xs
     have "freeIn 0 (AllQ \<phi>) \<Longrightarrow> (eval (ExQ (AllQ \<phi>)) xs) = eval (AllQ (AllQ \<phi>)) xs"
       using var_not_in_eval2 eval.simps(7) eval.simps(8) by blast
     then have h : "freeIn 0 (AllQ \<phi>) \<Longrightarrow> (eval (lowerFm 0 1 (AllQ \<phi>)) xs = eval (AllQ (AllQ \<phi>)) xs)"
       using eval_lowerFm by blast
     have "eval (push_forall (AllQ (AllQ \<phi>))) xs = 
       eval (if freeIn 0 (AllQ \<phi>) then lowerFm 0 1 (AllQ \<phi>) else AllQ (AllQ \<phi>)) xs"
       by simp
     also have "... = eval (AllQ (AllQ \<phi>)) xs"
       apply(cases "freeIn 0 (AllQ \<phi>)")
       using h AllQ  by(simp_all)
     finally have "eval (push_forall (AllQ (AllQ \<phi>))) xs = eval (AllQ (AllQ \<phi>)) xs"
       by simp
   }
   then show ?case by simp
 next
   case (ExN x1 \<phi>)
   then show ?case
     using eval.simps(7) eval.simps(8) eval_lowerFm push_forall.simps(17) var_not_in_eval2 by presburger
 next
   case (AllN x1 \<phi>)
   then show ?case
     using eval.simps(7) eval.simps(8) eval_lowerFm push_forall.simps(18) var_not_in_eval2 by presburger
 qed
 
 lemma push_forall_eval : "\<forall>xs. eval \<phi> xs = eval (push_forall \<phi>) xs"
 proof(induction \<phi>)
   case (Atom x)
   then show ?case using simp_atom_eval by simp
 next
   case (And \<phi>1 \<phi>2)
   then show ?case using eval_and by auto
 next
   case (Or \<phi>1 \<phi>2)
   then show ?case using eval_or by auto
 next
   case (Neg \<phi>)
   then show ?case using eval_neg by auto
 next
   case (AllQ \<phi>)
   then show ?case using push_forall_eval_AllQ by blast 
 next
   case (ExN x1 \<phi>)
   then show ?case
     using eval.simps(10) push_forall.simps(7) by presburger
 qed auto
 
 lemma map_fm_binders_negation_free : 
   assumes "negation_free \<phi>"
   shows "negation_free (map_fm_binders f \<phi> n)"
   using assms apply(induction \<phi> arbitrary : n) by auto
 
 lemma negation_free_and : 
   assumes "negation_free \<phi>"
   assumes "negation_free \<psi>"
   shows "negation_free (and \<phi> \<psi>)"
   using assms unfolding and_def by simp 
 
 lemma negation_free_or : 
   assumes "negation_free \<phi>"
   assumes "negation_free \<psi>"
   shows "negation_free (or \<phi> \<psi>)"
   using assms unfolding or_def by simp 
 
 lemma push_forall_negation_free_all :
   assumes "negation_free \<phi>"
   shows "negation_free (push_forall (AllQ \<phi>))"
   using assms proof(induction \<phi>)
   case (And \<phi>1 \<phi>2)
   show ?case apply auto
     apply(rule negation_free_and)
     using And by auto
 next
   case (Or \<phi>1 \<phi>2)
   show ?case
     apply auto
     apply(rule negation_free_or)   
     using Or map_fm_binders_negation_free negation_free_or by auto
 next
   case (ExQ \<phi>)
   then show ?case using map_fm_binders_negation_free by auto
 next
   case (AllQ \<phi>)
   then show ?case using map_fm_binders_negation_free by auto
 next
   case (ExN x1 \<phi>)
   then show ?case using map_fm_binders_negation_free by auto
 next
   case (AllN x1 \<phi>)
   then show ?case using map_fm_binders_negation_free by auto
 qed auto
 
 lemma push_forall_negation_free : 
   assumes "negation_free \<phi>"  
   shows "negation_free(push_forall \<phi>)"
   using assms proof(induction \<phi>)
   case (Atom A)
   then show ?case apply(cases A) by auto
 next
   case (And \<phi>1 \<phi>2)
   then show ?case by (auto simp add: and_def)
 next
   case (Or \<phi>1 \<phi>2)
   then show ?case by (auto simp add: or_def)
 next
   case (AllQ \<phi>)
   then show ?case using push_forall_negation_free_all by auto
 qed auto
 
 
 lemma to_list_insertion: "insertion f p = sum_list [insertion f term * (f v) ^ i. (term,i)\<leftarrow>(to_list v p)]"
 proof-
   have h1 :  "insertion f p = insertion f (\<Sum>i\<le>MPoly_Type.degree p v. isolate_variable_sparse p v i * Var v ^ i)"
     using sum_over_zero by auto
   have h2 : "insertion f (Var v) = f v" by (auto simp: monomials_Var coeff_Var insertion_code)
   define d where "d = MPoly_Type.degree p v"
   define g where "g = (\<lambda>x. insertion f (isolate_variable_sparse p v x) * f v ^ x)"
   have h3 : "insertion f (isolate_variable_sparse p v d) * f v ^ d = g d" using g_def by auto
   show ?thesis unfolding h1
       insertion_sum' insertion_mult insertion_pow h2 apply auto unfolding d_def[symmetric] g_def[symmetric]
       h3  proof(induction d)
     case 0
     then show ?case by auto
   next
     case (Suc d)
     show ?case
       apply (auto simp add: Suc ) unfolding g_def by auto
   qed
 qed
 
 lemma to_list_p: "p = sum_list [term * (Var v) ^ i. (term,i)\<leftarrow>(to_list v p)]"
 proof-
   define d where "d = MPoly_Type.degree p v"
   have "(\<Sum>i\<le>MPoly_Type.degree p v. isolate_variable_sparse p v i * Var v ^ i) = (\<Sum>(term, i)\<leftarrow>to_list v p. term * Var v ^ i)"
     unfolding to_list.simps d_def[symmetric] apply(induction d) by auto
   then show ?thesis 
     using sum_over_zero[of p v]
     by auto
 qed
 
 
 fun chophelper :: "(real mpoly * nat) list \<Rightarrow> (real mpoly * nat) list \<Rightarrow> (real mpoly * nat) list * (real mpoly * nat) list" where
   "chophelper [] L = (L,[])"|
   "chophelper ((p,i)#L) R = (if p=0 then chophelper L (R @ [(p,i)]) else (R,(p,i)#L))"
 
 lemma preserve :
   assumes "(a,b)=chophelper L L'"
   shows "a@b=L'@L"
   using assms
 proof(induction L arbitrary : a b L')
   case Nil
   then show ?case using assms by auto
 next
   case (Cons A L)
   then show ?case proof(cases A)
     case (Pair p i)
     show ?thesis using Cons unfolding Pair apply(cases "p=0") by auto
   qed
 qed
 lemma compare : 
   assumes "(a,b)=chophelper L L'"
   shows "chop L = b"
   using assms
 proof(induction L arbitrary : a b L')
   case Nil
   then show ?case by auto
 next
   case (Cons A L)
   then show ?case proof(cases A)
     case (Pair p i)
     show ?thesis using Cons unfolding Pair apply(cases "p=0") by auto
   qed
 qed
 lemma allzero:
   assumes "\<forall>(p,i)\<in>set(L'). p=0"
   assumes "(a,b)=chophelper L L'"
   shows "\<forall>(p,i)\<in>set(a). p=0"
   using assms proof(induction L arbitrary : a b L')
   case Nil
   then show ?case by auto
 next
   case (Cons t L)
   then show ?case
   proof(cases t)
     case (Pair p i)
     show ?thesis proof(cases "p=0")
       case True
       have h1: "\<forall>x\<in>set (L' @ [(0, i)]). case x of (p, i) \<Rightarrow> p = 0"
         using Cons(2) by auto
       show ?thesis using Cons(1)[OF h1] Cons(3) True unfolding Pair by auto
     next
       case False
       then show ?thesis using Cons unfolding Pair by auto
     qed
   qed
 qed 
 
 lemma separate:
   assumes "(a,b)=chophelper (to_list v p) []"
   shows "insertion f p = sum_list [insertion f term * (f v) ^ i. (term,i)\<leftarrow>a] + sum_list [insertion f term * (f v) ^ i. (term,i)\<leftarrow>b]"
   using to_list_insertion[of f p v]  preserve[OF assms, symmetric] unfolding List.append.left_neutral
   by (simp del: to_list.simps)
 
 lemma chopped : 
   assumes "(a,b)=chophelper (to_list v p) []"
   shows "insertion f p = sum_list [insertion f term * (f v) ^ i. (term,i)\<leftarrow>b]"
 proof-
   have h1 : "\<forall>(p, i)\<in>set []. p = 0" by auto
   have "(\<Sum>(term, i)\<leftarrow>a. insertion f term * f v ^ i) = 0"
     using allzero[OF h1 assms] proof(induction a)
     case Nil
     then show ?case by auto
   next
     case (Cons a1 a2)
     then show ?case
       apply(cases a1) by simp
   qed 
   then show ?thesis using separate[OF assms, of f] by auto
 qed
 
 lemma insertion_chop : 
   shows "insertion f p = sum_list [insertion f term * (f v) ^ i. (term,i)\<leftarrow>(chop (to_list v p))]" 
 proof(cases "chophelper (to_list v p) []")
   case (Pair a b)
   show ?thesis using chopped[OF Pair[symmetric], of f] unfolding compare[OF Pair[symmetric], symmetric] .
 qed
 
 lemma sorted : "sorted_wrt (\<lambda>(_,i).\<lambda>(_,i'). i<i') (to_list v p)"
 proof -
   define d  where "d = MPoly_Type.degree p v"
   show ?thesis unfolding to_list.simps d_def[symmetric] 
   proof(induction d)
     case 0
     then show ?case by auto
   next
     case (Suc d)
     have h : "(map (\<lambda>x. (isolate_variable_sparse p v x, x)) [0..<Suc d + 1]) = 
         (map (\<lambda>x. (isolate_variable_sparse p v x, x)) [0..<Suc d]) @ [(isolate_variable_sparse p v (Suc d), (Suc d))]"
       by auto
     show ?case
       unfolding sorted_wrt_append h
       using Suc
       by auto
   qed
 qed
 
 lemma sublist : "sublist (chop L) L"
 proof(induction L)
   case Nil
   then show ?case by auto
 next
   case (Cons a L)
   then show ?case proof(cases a)
     case (Pair a b)
     show ?thesis using Cons unfolding Pair apply auto
       by (simp add: sublist_Cons_right)
   qed
 qed
 
 
 
 lemma move_exp :
   assumes "(p',i)#L = (chop (to_list v p))"
   shows "insertion f p = sum_list [insertion f term * (f v) ^ (d-i). (term,d)\<leftarrow>(chop (to_list v p))] * (f v)^i" 
 proof-
   have h : "sorted_wrt (\<lambda>(_, i) (_, y). i < y) (chop (to_list v p))"
   proof-
     define L where "L = to_list v p"
     show ?thesis using sublist[of "to_list v p"] sorted[of v p] unfolding L_def[symmetric]
       by (metis sorted_wrt_append sublist_def)
   qed
   then have "\<forall>(term,d)\<in>set(chop (to_list v p)). d\<ge>i"
     unfolding assms[symmetric]  by fastforce
   then have simp : "\<forall>(term,d)\<in>set(chop(to_list v p)). f v ^ (d - i) * f v ^ i = f v ^ d"
     unfolding semiring_normalization_rules(26) by(auto simp del: to_list.simps)
   have "insertion f p = sum_list [insertion f term * (f v) ^ i. (term,i)\<leftarrow>(chop (to_list v p))]" using insertion_chop[of f p v] .
   also have "...= (\<Sum>(term, d)\<leftarrow>chop (to_list v p). insertion f term * f v ^ (d-i) * f v ^ i)" 
     using simp
     by (smt Pair_inject case_prodE map_eq_conv mult.assoc split_cong) 
   also have "... =  (\<Sum>(term, d)\<leftarrow>chop (to_list v p). insertion f term * f v ^ (d - i)) * f v ^ i"
   proof-
     define d where "d = chop(to_list v p)"
     define a where "a = f v ^ i"
     define b where "b = (\<lambda>(term, d). insertion f term * f v ^ (d - i))"
     have h : "(\<Sum>(term, d)\<leftarrow>d. insertion f term * f v ^ (d - i) * a) = (\<Sum>(term, d)\<leftarrow>d. b (term,d) * a)"
       using b_def by auto
     show ?thesis unfolding d_def[symmetric] a_def[symmetric]  b_def[symmetric] h  apply(induction d) apply simp apply auto
       by (simp add: ring_class.ring_distribs(2))
   qed
   finally show ?thesis by auto
 qed
 
 lemma insert_Var_Zero : "insertion f (Var v) = f v"
   unfolding insertion_code monomials_Var apply auto
   unfolding coeff_Var by simp
 
 
 lemma decreasePower_insertion :
   assumes "decreasePower v p = (p',i)"
   shows "insertion f p = insertion f p'* (f v)^i"
 proof(cases "chop (to_list v p)")
   case Nil
   then show ?thesis
     using assms by auto
 next
   case (Cons a list)
   then show ?thesis
   proof(cases a)
     case (Pair coef i')
     have i'_def : "i'=i" using Cons assms Pair by auto
     have chop: "chop (to_list v p) = (coef, i) # list" using Cons assms unfolding i'_def Pair by auto
     have p'_def :  "p' = (\<Sum>(term, x)\<leftarrow>chop (to_list v p). term * Var v ^ (x - i))"
       using assms Cons Pair by auto 
     have p'_insertion : "insertion f p' = (\<Sum>(term, x)\<leftarrow>chop (to_list v p). insertion f term * f v ^ (x - i))"
     proof-
       define d where "d = chop (to_list v p)"
       have "insertion f p' = insertion f (\<Sum>(term, x)\<leftarrow>chop (to_list v p). term * Var v ^ (x - i))" using p'_def by auto
       also have "... = (\<Sum>(term, x)\<leftarrow>chop (to_list v p).  insertion f (term * Var v ^ (x - i)))" 
         unfolding d_def[symmetric] apply(induction d) apply simp apply(simp add:insertion_add) by auto
       also have "... = (\<Sum>(term, x)\<leftarrow>chop (to_list v p). insertion f term * f v ^ (x - i))" unfolding insertion_mult insertion_pow insert_Var_Zero by auto
       finally show ?thesis by auto
     qed
     have h : "(coef, i') # list = chop (to_list v p)"  using Cons unfolding Pair by auto
     show ?thesis unfolding p'_insertion
       using move_exp[OF h, of f] unfolding i'_def .
   qed
 qed 
 
 
 lemma unpower_eval: "eval (unpower v \<phi>) L = eval \<phi> L"
 proof(induction \<phi> arbitrary: v L)
   case TrueF
   then show ?case by auto
 next
   case FalseF
   then show ?case by auto
 next
   case (Atom At)
   then show ?case proof(cases At)
     case (Less p)
     obtain q i where h: "decreasePower v p = (q, i)"
       using prod.exhaust_sel by blast
     have p : "\<And>f. insertion f p = insertion f q* (f v)^i"
       using decreasePower_insertion[OF h] by auto
     show ?thesis
     proof(cases "i=0")
       case True
       then show ?thesis unfolding Less unpower.simps h  by auto
     next
       case False
       obtain x where x_def : "Suc x = i" using False
         using not0_implies_Suc by auto 
       have h1 : "i mod 2 = 0 \<Longrightarrow>
     (insertion (nth_default 0 L) q < 0 \<and>
      insertion (nth_default 0 L) (Var v) \<noteq> 0) =
     (insertion (nth_default 0 L) q * nth_default 0 L v ^ i < 0)"
       proof -
         assume "i mod 2 = 0"
         then have "\<forall>r. \<not> (r::real) ^ i < 0"
           by presburger
         then show ?thesis
           by (metis \<open>\<And>thesis. (\<And>x. Suc x = i \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> insert_Var_Zero linorder_neqE_linordered_idom mult_less_0_iff power_0_Suc power_eq_0_iff)
       qed
-      show ?thesis unfolding Less unpower.simps h x_def[symmetric] apply simp
-        unfolding x_def p apply(cases "i mod 2 = 0") using h1 apply simp_all
-        by (smt insert_Var_Zero insertion_neg mod_Suc mod_eq_0D mult_less_0_iff nat.inject odd_power_less_zero power_0 power_Suc0_right power_eq_0_iff x_def zero_less_Suc zero_less_power)
+      show ?thesis
+        unfolding Less unpower.simps h x_def [symmetric] apply simp
+        unfolding x_def p apply (cases \<open>even i\<close>)
+        using h1 apply (auto simp add: insertion_neg insert_Var_Zero mult_less_0_iff not_less zero_less_mult_iff elim: oddE)
+        done
     qed 
   next
     case (Eq p)
     obtain q i where h: "decreasePower v p = (q, i)"
       using prod.exhaust_sel by blast
     have p : "\<And>f. insertion f p = insertion f q* (f v)^i"
       using decreasePower_insertion[OF h] by auto
     show ?thesis unfolding Eq unpower.simps h apply simp apply(cases i) apply simp
       apply simp unfolding p apply simp
       by (metis insert_Var_Zero)
   next
     case (Leq p)
     obtain q i where h: "decreasePower v p = (q, i)"
       using prod.exhaust_sel by blast
     have p : "\<And>f. insertion f p = insertion f q* (f v)^i"
       using decreasePower_insertion[OF h] by auto
     show ?thesis
     proof(cases "i=0")
       case True
       then show ?thesis unfolding Leq unpower.simps h  by auto
     next
       case False
       obtain x where x_def : "Suc x = i" using False
         using not0_implies_Suc by auto 
       define a where "a = insertion (nth_default 0 L) q"
       define x' where "x' = nth_default 0 L v"
       show ?thesis unfolding Leq unpower.simps h x_def[symmetric] apply simp
         unfolding x_def p apply(cases "i mod 2 = 0") unfolding insert_Var_Zero insertion_mult insertion_pow insertion_neg apply simp_all
         unfolding a_def[symmetric] x'_def[symmetric]
       proof-
         assume "i mod 2 = 0"
         then have "x' ^ i \<ge>0"
           by (simp add: \<open>i mod 2 = 0\<close> even_iff_mod_2_eq_zero zero_le_even_power) 
         then show "(a \<le> 0 \<or> x' = 0) = (a * x' ^ i \<le> 0)"
           using Rings.ordered_semiring_0_class.mult_nonpos_nonneg[of a "x'^i"]
           apply auto
           unfolding Rings.linordered_ring_strict_class.mult_le_0_iff
           apply auto
           by (simp add: False power_0_left)
       next
         assume h:  "i mod 2 = Suc 0"
         show "(a = 0 \<or> a < 0 \<and> 0 \<le> x' \<or> 0 < a \<and> x' \<le> 0) = (a * x' ^ i \<le> 0)"
           using h
           by (smt even_iff_mod_2_eq_zero mult_less_cancel_right mult_neg_neg mult_nonneg_nonpos mult_pos_pos not_mod2_eq_Suc_0_eq_0 power_0_Suc x_def zero_le_power_eq zero_less_mult_pos2 zero_less_power)
       qed
     qed 
   next
     case (Neq p)
     obtain q i where h: "decreasePower v p = (q, i)"
       using prod.exhaust_sel by blast
     have p : "\<And>f. insertion f p = insertion f q* (f v)^i"
       using decreasePower_insertion[OF h] by auto
     show ?thesis unfolding Neq unpower.simps h apply simp apply(cases i) apply simp
       apply simp unfolding p apply simp
       by (metis insert_Var_Zero)
   qed
 qed auto
 
 lemma to_list_filter: "p = sum_list [term * (Var v) ^ i. (term,i)\<leftarrow>((filter (\<lambda>(x,_). x\<noteq>0) (to_list v p)))]"
 proof-
   define L where "L = to_list v p"
   have "(\<Sum>(term, i)\<leftarrow>to_list v p. term * Var v ^ i) = (\<Sum>(term, i)\<leftarrow>filter (\<lambda>(x, _). x \<noteq> 0) (to_list v p). term * Var v ^ i)"
     unfolding L_def[symmetric] apply(induction L) by auto
   then show ?thesis
     using to_list_p[of p v] by auto
 qed
 
 end
\ No newline at end of file
diff --git a/thys/Word_Lib/Bits_Int.thy b/thys/Word_Lib/Bits_Int.thy
--- a/thys/Word_Lib/Bits_Int.thy
+++ b/thys/Word_Lib/Bits_Int.thy
@@ -1,1558 +1,1558 @@
 (*
  * Copyright Brian Huffman, PSU; Jeremy Dawson and Gerwin Klein, NICTA
  *
  * SPDX-License-Identifier: BSD-2-Clause
  *)
 
 section \<open>Bitwise Operations on integers\<close>
 
 theory Bits_Int
   imports
     "Word_Lib.Most_significant_bit"
     "Word_Lib.Least_significant_bit"
     "Word_Lib.Generic_set_bit"
     "Word_Lib.Bit_Comprehension"
 begin
 
 subsection \<open>Implicit bit representation of \<^typ>\<open>int\<close>\<close>
 
 lemma bin_last_def:
   "(odd :: int \<Rightarrow> bool) w \<longleftrightarrow> w mod 2 = 1"
   by (fact odd_iff_mod_2_eq_one)
 
 lemma bin_last_numeral_simps [simp]:
   "\<not> odd (0 :: int)"
   "odd (1 :: int)"
   "odd (- 1 :: int)"
   "odd (Numeral1 :: int)"
   "\<not> odd (numeral (Num.Bit0 w) :: int)"
   "odd (numeral (Num.Bit1 w) :: int)"
   "\<not> odd (- numeral (Num.Bit0 w) :: int)"
   "odd (- numeral (Num.Bit1 w) :: int)"
   by simp_all
 
 lemma bin_rest_numeral_simps [simp]:
   "(\<lambda>k::int. k div 2) 0 = 0"
   "(\<lambda>k::int. k div 2) 1 = 0"
   "(\<lambda>k::int. k div 2) (- 1) = - 1"
   "(\<lambda>k::int. k div 2) Numeral1 = 0"
   "(\<lambda>k::int. k div 2) (numeral (Num.Bit0 w)) = numeral w"
   "(\<lambda>k::int. k div 2) (numeral (Num.Bit1 w)) = numeral w"
   "(\<lambda>k::int. k div 2) (- numeral (Num.Bit0 w)) = - numeral w"
   "(\<lambda>k::int. k div 2) (- numeral (Num.Bit1 w)) = - numeral (w + Num.One)"
   by simp_all
 
 lemma bin_rl_eqI: "\<lbrakk>(\<lambda>k::int. k div 2) x = (\<lambda>k::int. k div 2) y; odd x = odd y\<rbrakk> \<Longrightarrow> x = y"
   by (auto elim: oddE)
 
 lemma [simp]:
   shows bin_rest_lt0: "(\<lambda>k::int. k div 2) i < 0 \<longleftrightarrow> i < 0"
   and  bin_rest_ge_0: "(\<lambda>k::int. k div 2) i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by auto
 
 lemma bin_rest_gt_0 [simp]: "(\<lambda>k::int. k div 2) x > 0 \<longleftrightarrow> x > 1"
   by auto
 
 
 subsection \<open>Bit projection\<close>
 
 lemma bin_nth_eq_iff: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) x = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y \<longleftrightarrow> x = y"
   by (simp add: bit_eq_iff fun_eq_iff)
 
 lemma bin_eqI:
   "x = y" if "\<And>n. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   using that by (rule bit_eqI)
 
 lemma bin_eq_iff: "x = y \<longleftrightarrow> (\<forall>n. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n)"
   by (metis bit_eq_iff)
 
 lemma bin_nth_zero [simp]: "\<not> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) 0 n"
   by simp
 
 lemma bin_nth_1 [simp]: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) 1 n \<longleftrightarrow> n = 0"
   by (cases n) (simp_all add: bit_Suc)
 
 lemma bin_nth_minus1 [simp]: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (- 1) n"
   by simp
 
 lemma bin_nth_numeral: "(\<lambda>k::int. k div 2) x = y \<Longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (numeral n) = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y (pred_numeral n)"
   by (simp add: numeral_eq_Suc bit_Suc)
 
 lemmas bin_nth_numeral_simps [simp] =
   bin_nth_numeral [OF bin_rest_numeral_simps(8)]
 
 lemmas bin_nth_simps =
   bit_0 bit_Suc bin_nth_zero bin_nth_minus1
   bin_nth_numeral_simps
 
 lemma nth_2p_bin: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (2 ^ n) m = (m = n)" \<comment> \<open>for use when simplifying with \<open>bin_nth_Bit\<close>\<close>
   by (auto simp add: bit_exp_iff)
 
 lemma nth_rest_power_bin: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (((\<lambda>k::int. k div 2) ^^ k) w) n = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w (n + k)"
   apply (induct k arbitrary: n)
    apply clarsimp
   apply clarsimp
   apply (simp only: bit_Suc [symmetric] add_Suc)
   done
 
 lemma bin_nth_numeral_unfold:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (num.Bit0 x)) n \<longleftrightarrow> n > 0 \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral x) (n - 1)"
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (num.Bit1 x)) n \<longleftrightarrow> (n > 0 \<longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral x) (n - 1))"
   by (cases n; simp)+
 
 
 subsection \<open>Truncating\<close>
 
 definition bin_sign :: "int \<Rightarrow> int"
   where "bin_sign k = (if k \<ge> 0 then 0 else - 1)"
 
 lemma bin_sign_simps [simp]:
   "bin_sign 0 = 0"
   "bin_sign 1 = 0"
   "bin_sign (- 1) = - 1"
   "bin_sign (numeral k) = 0"
   "bin_sign (- numeral k) = -1"
   by (simp_all add: bin_sign_def)
 
 lemma bin_sign_rest [simp]: "bin_sign ((\<lambda>k::int. k div 2) w) = bin_sign w"
   by (simp add: bin_sign_def)
 
 lemma bintrunc_mod2p: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w = w mod 2 ^ n"
   by (fact take_bit_eq_mod)
 
 lemma sbintrunc_mod2p: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w = (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n"
   by (simp add: bintrunc_mod2p signed_take_bit_eq_take_bit_shift)
 
 lemma sbintrunc_eq_take_bit:
   \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k = take_bit (Suc n) (k + 2 ^ n) - 2 ^ n\<close>
   by (fact signed_take_bit_eq_take_bit_shift)
 
 lemma sign_bintr: "bin_sign ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = 0"
   by (simp add: bin_sign_def)
 
 lemma bintrunc_n_0: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 0"
   by (fact take_bit_of_0)
 
 lemma sbintrunc_n_0: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 0"
   by (fact signed_take_bit_of_0)
 
 lemma sbintrunc_n_minus1: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = -1"
   by (fact signed_take_bit_of_minus_1)
 
 lemma bintrunc_Suc_numeral:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) 1 = 1"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- 1) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit0 w)) = 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit0 w)) = 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral (w + Num.One))"
   by (simp_all add: take_bit_Suc del: take_bit_minus_one_eq_mask)
 
 lemma sbintrunc_0_numeral [simp]:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 1 = -1"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (numeral (Num.Bit0 w)) = 0"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (numeral (Num.Bit1 w)) = -1"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (- numeral (Num.Bit0 w)) = 0"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) 0 (- numeral (Num.Bit1 w)) = -1"
   by simp_all
 
 lemma sbintrunc_Suc_numeral:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) 1 = 1"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit0 w)) = 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (numeral (Num.Bit1 w)) = 1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit0 w)) = 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- numeral (Num.Bit1 w)) = 1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- numeral (w + Num.One))"
   by (simp_all add: signed_take_bit_Suc)
 
 lemma bin_sign_lem: "(bin_sign ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = -1) = bit bin n"
   by (simp add: bin_sign_def)
 
 lemma nth_bintr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) n \<longleftrightarrow> n < m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n"
   by (fact bit_take_bit_iff)
 
 lemma nth_sbintr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) n = (if n < m then (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w m)"
   by (simp add: bit_signed_take_bit_iff min_def)
 
 lemma bin_nth_Bit0:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (Num.Bit0 w)) n \<longleftrightarrow>
     (\<exists>m. n = Suc m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral w) m)"
   using bit_double_iff [of \<open>numeral w :: int\<close> n]
   by (auto intro: exI [of _ \<open>n - 1\<close>])
 
 lemma bin_nth_Bit1:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral (Num.Bit1 w)) n \<longleftrightarrow>
     n = 0 \<or> (\<exists>m. n = Suc m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (numeral w) m)"
   using even_bit_succ_iff [of \<open>2 * numeral w :: int\<close> n]
     bit_double_iff [of \<open>numeral w :: int\<close> n]
   by auto
 
 lemma bintrunc_bintrunc_l: "n \<le> m \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by simp
 
 lemma sbintrunc_sbintrunc_l: "n \<le> m \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by simp
 
 lemma bintrunc_bintrunc_ge: "n \<le> m \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (rule bin_eqI) (auto simp: nth_bintr)
 
 lemma bintrunc_bintrunc_min [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) w"
   by (rule take_bit_take_bit)
 
 lemma sbintrunc_sbintrunc_min [simp]: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) w"
   by (rule signed_take_bit_signed_take_bit)
 
 lemmas sbintrunc_Suc_Pls =
   signed_take_bit_Suc [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Suc_Min =
   signed_take_bit_Suc [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Sucs = sbintrunc_Suc_Pls sbintrunc_Suc_Min
   sbintrunc_Suc_numeral
 
 lemmas sbintrunc_Pls =
   signed_take_bit_0 [where a="0::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_Min =
   signed_take_bit_0 [where a="-1::int", simplified bin_last_numeral_simps bin_rest_numeral_simps]
 
 lemmas sbintrunc_0_simps =
   sbintrunc_Pls sbintrunc_Min
 
 lemmas sbintrunc_simps = sbintrunc_0_simps sbintrunc_Sucs
 
 lemma bintrunc_minus: "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc (n - 1)) w = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by auto
 
 lemma sbintrunc_minus: "0 < n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc (n - 1)) w = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by auto
 
 lemmas sbintrunc_minus_simps =
   sbintrunc_Sucs [THEN [2] sbintrunc_minus [symmetric, THEN trans]]
 
 lemma sbintrunc_BIT_I:
   \<open>0 < n \<Longrightarrow>
   (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) 0 = y \<Longrightarrow>
   (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n 0 = 2 * y\<close>
   by simp
 
 lemma sbintrunc_Suc_Is:
   \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = y \<Longrightarrow>
   (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) (- 1) = 1 + 2 * y\<close>
   by auto
 
 lemma sbintrunc_Suc_lem: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) x = y \<Longrightarrow> m = Suc n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m x = y"
   by (rule ssubst)
 
 lemmas sbintrunc_Suc_Ialts =
   sbintrunc_Suc_Is [THEN sbintrunc_Suc_lem]
 
 lemma sbintrunc_bintrunc_lt: "m > n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (rule bin_eqI) (auto simp: nth_sbintr nth_bintr)
 
 lemma bintrunc_sbintrunc_le: "m \<le> Suc n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w"
   by (rule take_bit_signed_take_bit)
 
 lemmas bintrunc_sbintrunc [simp] = order_refl [THEN bintrunc_sbintrunc_le]
 lemmas sbintrunc_bintrunc [simp] = lessI [THEN sbintrunc_bintrunc_lt]
 lemmas bintrunc_bintrunc [simp] = order_refl [THEN bintrunc_bintrunc_l]
 lemmas sbintrunc_sbintrunc [simp] = order_refl [THEN sbintrunc_sbintrunc_l]
 
 lemma bintrunc_sbintrunc' [simp]: "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) w) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (cases n) simp_all
 
 lemma sbintrunc_bintrunc' [simp]: "0 < n \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) w"
   by (cases n) simp_all
 
 lemma bin_sbin_eq_iff: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) y \<longleftrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y"
   apply (rule iffI)
    apply (rule box_equals [OF _ sbintrunc_bintrunc sbintrunc_bintrunc])
    apply simp
   apply (rule box_equals [OF _ bintrunc_sbintrunc bintrunc_sbintrunc])
   apply simp
   done
 
 lemma bin_sbin_eq_iff':
   "0 < n \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y \<longleftrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) y"
   by (cases n) (simp_all add: bin_sbin_eq_iff)
 
 lemmas bintrunc_sbintruncS0 [simp] = bintrunc_sbintrunc' [unfolded One_nat_def]
 lemmas sbintrunc_bintruncS0 [simp] = sbintrunc_bintrunc' [unfolded One_nat_def]
 
 lemmas bintrunc_bintrunc_l' = le_add1 [THEN bintrunc_bintrunc_l]
 lemmas sbintrunc_sbintrunc_l' = le_add1 [THEN sbintrunc_sbintrunc_l]
 
 (* although bintrunc_minus_simps, if added to default simpset,
   tends to get applied where it's not wanted in developing the theories,
   we get a version for when the word length is given literally *)
 
 lemmas nat_non0_gr =
   trans [OF iszero_def [THEN Not_eq_iff [THEN iffD2]] refl]
 
 lemma bintrunc_numeral:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
   by (simp add: numeral_eq_Suc take_bit_Suc mod_2_eq_odd)
 
 lemma sbintrunc_numeral:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) x = of_bool (odd x) + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (x div 2)"
   by (simp add: numeral_eq_Suc signed_take_bit_Suc mod2_eq_if)
 
 lemma bintrunc_numeral_simps [simp]:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit0 w)) =
     2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit1 w)) =
     1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit0 w)) =
     2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral w)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit1 w)) =
     1 + 2 * (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral (w + Num.One))"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) 1 = 1"
   by (simp_all add: bintrunc_numeral)
 
 lemma sbintrunc_numeral_simps [simp]:
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit0 w)) =
     2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (numeral (Num.Bit1 w)) =
     1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit0 w)) =
     2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral w)"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) (- numeral (Num.Bit1 w)) =
     1 + 2 * (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (pred_numeral k) (- numeral (w + Num.One))"
   "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (numeral k) 1 = 1"
   by (simp_all add: sbintrunc_numeral)
 
 lemma no_bintr_alt1: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>w. w mod 2 ^ n :: int)"
   by (rule ext) (rule bintrunc_mod2p)
 
 lemma range_bintrunc: "range ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) = {i. 0 \<le> i \<and> i < 2 ^ n}"
   by (auto simp add: take_bit_eq_mod image_iff) (metis mod_pos_pos_trivial)
 
 lemma no_sbintr_alt2: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>w. (w + 2 ^ n) mod 2 ^ Suc n - 2 ^ n :: int)"
   by (rule ext) (simp add : sbintrunc_mod2p)
 
 lemma range_sbintrunc: "range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) = {i. - (2 ^ n) \<le> i \<and> i < 2 ^ n}"
 proof -
   have \<open>surj (\<lambda>k::int. k + 2 ^ n)\<close>
     by (rule surjI [of _ \<open>(\<lambda>k. k - 2 ^ n)\<close>]) simp
   moreover have \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = ((\<lambda>k. k - 2 ^ n) \<circ> take_bit (Suc n) \<circ> (\<lambda>k. k + 2 ^ n))\<close>
     by (simp add: sbintrunc_eq_take_bit fun_eq_iff)
   ultimately show ?thesis
     apply (simp only: fun.set_map range_bintrunc)
     apply (auto simp add: image_iff)
     apply presburger
     done
 qed
 
 lemma sbintrunc_inc:
   \<open>k + 2 ^ Suc n \<le> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k\<close> if \<open>k < - (2 ^ n)\<close>
   using that by (fact signed_take_bit_int_greater_eq)
 
 lemma sbintrunc_dec:
   \<open>(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n k \<le> k - 2 ^ (Suc n)\<close> if \<open>k \<ge> 2 ^ n\<close>
   using that by (fact signed_take_bit_int_less_eq)
 
 lemma bintr_ge0: "0 \<le> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: bintrunc_mod2p)
 
 lemma bintr_lt2p: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w < 2 ^ n"
   by (simp add: bintrunc_mod2p)
 
 lemma bintr_Min: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1) = 2 ^ n - 1"
   by (simp add: stable_imp_take_bit_eq mask_eq_exp_minus_1)
 
 lemma sbintr_ge: "- (2 ^ n) \<le> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (fact signed_take_bit_int_greater_eq_minus_exp)
 
 lemma sbintr_lt: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w < 2 ^ n"
   by (fact signed_take_bit_int_less_exp)
 
 lemma sign_Pls_ge_0: "bin_sign bin = 0 \<longleftrightarrow> bin \<ge> 0"
   for bin :: int
   by (simp add: bin_sign_def)
 
 lemma sign_Min_lt_0: "bin_sign bin = -1 \<longleftrightarrow> bin < 0"
   for bin :: int
   by (simp add: bin_sign_def)
 
 lemma bin_rest_trunc: "(\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - 1) ((\<lambda>k::int. k div 2) bin)"
   by (simp add: take_bit_rec [of n bin])
 
 lemma bin_rest_power_trunc:
   "((\<lambda>k::int. k div 2) ^^ k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (n - k) (((\<lambda>k::int. k div 2) ^^ k) bin)"
   by (induct k) (auto simp: bin_rest_trunc)
 
 lemma bin_rest_trunc_i: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) bin) = (\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) bin)"
   by (auto simp add: take_bit_Suc)
 
 lemma bin_rest_strunc: "(\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (Suc n) bin) = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) bin)"
   by (simp add: signed_take_bit_Suc)
 
 lemma bintrunc_rest [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)) = (\<lambda>k::int. k div 2) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)"
   by (induct n arbitrary: bin) (simp_all add: take_bit_Suc)
 
 lemma sbintrunc_rest [simp]: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)) = (\<lambda>k::int. k div 2) ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n bin)"
   by (induct n arbitrary: bin) (simp_all add: signed_take_bit_Suc mod2_eq_if)
 
 lemma bintrunc_rest': "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n \<circ> (\<lambda>k::int. k div 2) \<circ> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>k::int. k div 2) \<circ> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n"
   by (rule ext) auto
 
 lemma sbintrunc_rest': "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n \<circ> (\<lambda>k::int. k div 2) \<circ> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n = (\<lambda>k::int. k div 2) \<circ> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n"
   by (rule ext) auto
 
 lemma rco_lem: "f \<circ> g \<circ> f = g \<circ> f \<Longrightarrow> f \<circ> (g \<circ> f) ^^ n = g ^^ n \<circ> f"
   apply (rule ext)
   apply (induct_tac n)
    apply (simp_all (no_asm))
   apply (drule fun_cong)
   apply (unfold o_def)
   apply (erule trans)
   apply simp
   done
 
 lemmas rco_bintr = bintrunc_rest'
   [THEN rco_lem [THEN fun_cong], unfolded o_def]
 lemmas rco_sbintr = sbintrunc_rest'
   [THEN rco_lem [THEN fun_cong], unfolded o_def]
 
 
 subsection \<open>Splitting and concatenation\<close>
 
 definition bin_split :: \<open>nat \<Rightarrow> int \<Rightarrow> int \<times> int\<close>
   where [simp]: \<open>bin_split n k = (drop_bit n k, take_bit n k)\<close>
 
 lemma [code]:
   "bin_split (Suc n) w = (let (w1, w2) = bin_split n (w div 2) in (w1, of_bool (odd w) + 2 * w2))"
   "bin_split 0 w = (w, 0)"
   by (simp_all add: drop_bit_Suc take_bit_Suc mod_2_eq_odd)
 
 lemma bin_cat_eq_push_bit_add_take_bit:
   \<open>concat_bit n l k = push_bit n k + take_bit n l\<close>
   by (simp add: concat_bit_eq)
 
 lemma bin_sign_cat: "bin_sign ((\<lambda>k n l. concat_bit n l k) x n y) = bin_sign x"
 proof -
   have \<open>0 \<le> x\<close> if \<open>0 \<le> x * 2 ^ n + y mod 2 ^ n\<close>
   proof -
     have \<open>y mod 2 ^ n < 2 ^ n\<close>
       using pos_mod_bound [of \<open>2 ^ n\<close> y] by simp
     then have \<open>\<not> y mod 2 ^ n \<ge> 2 ^ n\<close>
       by (simp add: less_le)
     with that have \<open>x \<noteq> - 1\<close>
       by auto
     have *: \<open>- 1 \<le> (- (y mod 2 ^ n)) div 2 ^ n\<close>
       by (simp add: zdiv_zminus1_eq_if)
     from that have \<open>- (y mod 2 ^ n) \<le> x * 2 ^ n\<close>
       by simp
     then have \<open>(- (y mod 2 ^ n)) div 2 ^ n \<le> (x * 2 ^ n) div 2 ^ n\<close>
       using zdiv_mono1 zero_less_numeral zero_less_power by blast
     with * have \<open>- 1 \<le> x * 2 ^ n div 2 ^ n\<close> by simp
     with \<open>x \<noteq> - 1\<close> show ?thesis
       by simp
   qed
   then show ?thesis
     by (simp add: bin_sign_def not_le not_less bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult take_bit_eq_mod)
 qed
 
 lemma bin_cat_assoc: "(\<lambda>k n l. concat_bit n l k) ((\<lambda>k n l. concat_bit n l k) x m y) n z = (\<lambda>k n l. concat_bit n l k) x (m + n) ((\<lambda>k n l. concat_bit n l k) y n z)"
   by (fact concat_bit_assoc)
 
 lemma bin_cat_assoc_sym: "(\<lambda>k n l. concat_bit n l k) x m ((\<lambda>k n l. concat_bit n l k) y n z) = (\<lambda>k n l. concat_bit n l k) ((\<lambda>k n l. concat_bit n l k) x (m - n) y) (min m n) z"
   by (fact concat_bit_assoc_sym)
 
 definition bin_rcat :: \<open>nat \<Rightarrow> int list \<Rightarrow> int\<close>
   where \<open>bin_rcat n = horner_sum (take_bit n) (2 ^ n) \<circ> rev\<close>
 
 lemma bin_rcat_eq_foldl:
   \<open>bin_rcat n = foldl (\<lambda>u v. (\<lambda>k n l. concat_bit n l k) u n v) 0\<close>
 proof
   fix ks :: \<open>int list\<close>
   show \<open>bin_rcat n ks = foldl (\<lambda>u v. (\<lambda>k n l. concat_bit n l k) u n v) 0 ks\<close>
     by (induction ks rule: rev_induct)
       (simp_all add: bin_rcat_def concat_bit_eq push_bit_eq_mult)
 qed
 
 fun bin_rsplit_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
   where "bin_rsplit_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else
       let (a, b) = bin_split n c
       in bin_rsplit_aux n (m - n) a (b # bs))"
 
 definition bin_rsplit :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
   where "bin_rsplit n w = bin_rsplit_aux n (fst w) (snd w) []"
 
 fun bin_rsplitl_aux :: "nat \<Rightarrow> nat \<Rightarrow> int \<Rightarrow> int list \<Rightarrow> int list"
   where "bin_rsplitl_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else
       let (a, b) = bin_split (min m n) c
       in bin_rsplitl_aux n (m - n) a (b # bs))"
 
 definition bin_rsplitl :: "nat \<Rightarrow> nat \<times> int \<Rightarrow> int list"
   where "bin_rsplitl n w = bin_rsplitl_aux n (fst w) (snd w) []"
 
 declare bin_rsplit_aux.simps [simp del]
 declare bin_rsplitl_aux.simps [simp del]
 
 lemma bin_nth_cat:
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) ((\<lambda>k n l. concat_bit n l k) x k y) n =
     (if n < k then (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (n - k))"
   by (simp add: bit_concat_bit_iff)
 
 lemma bin_nth_drop_bit_iff:
   \<open>(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (drop_bit n c) k \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c (n + k)\<close>
   by (simp add: bit_drop_bit_eq)
 
 lemma bin_nth_take_bit_iff:
   \<open>(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (take_bit n c) k \<longleftrightarrow> k < n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c k\<close>
   by (fact bit_take_bit_iff)
 
 lemma bin_nth_split:
   "bin_split n c = (a, b) \<Longrightarrow>
     (\<forall>k. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) a k = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c (n + k)) \<and>
     (\<forall>k. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) b k = (k < n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) c k))"
   by (auto simp add: bin_nth_drop_bit_iff bin_nth_take_bit_iff)
 
 lemma bin_cat_zero [simp]: "(\<lambda>k n l. concat_bit n l k) 0 n w = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma bintr_cat1: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (k + n) ((\<lambda>k n l. concat_bit n l k) a n b) = (\<lambda>k n l. concat_bit n l k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) k a) n b"
   by (metis bin_cat_assoc bin_cat_zero)
 
 lemma bintr_cat: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m ((\<lambda>k n l. concat_bit n l k) a n b) =
     (\<lambda>k n l. concat_bit n l k) ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (min m n) b)"
   by (rule bin_eqI) (auto simp: bin_nth_cat nth_bintr)
 
 lemma bintr_cat_same [simp]: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((\<lambda>k n l. concat_bit n l k) a n b) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b"
   by (auto simp add : bintr_cat)
 
 lemma cat_bintr [simp]: "(\<lambda>k n l. concat_bit n l k) a n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b) = (\<lambda>k n l. concat_bit n l k) a n b"
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma split_bintrunc: "bin_split n c = (a, b) \<Longrightarrow> b = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n c"
   by simp
 
 lemma bin_cat_split: "bin_split n w = (u, v) \<Longrightarrow> w = (\<lambda>k n l. concat_bit n l k) u n v"
   by (auto simp add: bin_cat_eq_push_bit_add_take_bit bits_ident)
 
 lemma drop_bit_bin_cat_eq:
   \<open>drop_bit n ((\<lambda>k n l. concat_bit n l k) v n w) = v\<close>
   by (rule bit_eqI) (simp add: bit_drop_bit_eq bit_concat_bit_iff)
 
 lemma take_bit_bin_cat_eq:
   \<open>take_bit n ((\<lambda>k n l. concat_bit n l k) v n w) = take_bit n w\<close>
   by (rule bit_eqI) (simp add: bit_concat_bit_iff)
 
 lemma bin_split_cat: "bin_split n ((\<lambda>k n l. concat_bit n l k) v n w) = (v, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w)"
   by (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
 
 lemma bin_split_zero [simp]: "bin_split n 0 = (0, 0)"
   by simp
 
 lemma bin_split_minus1 [simp]:
   "bin_split n (- 1) = (- 1, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (- 1))"
   by simp
 
 lemma bin_split_trunc:
   "bin_split (min m n) c = (a, b) \<Longrightarrow>
     bin_split n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m c) = ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a, b)"
   apply (induct n arbitrary: m b c, clarsimp)
   apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
   apply (case_tac m)
    apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
   done
 
 lemma bin_split_trunc1:
   "bin_split n c = (a, b) \<Longrightarrow>
     bin_split n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m c) = ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (m - n) a, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m b)"
   apply (induct n arbitrary: m b c, clarsimp)
   apply (simp add: bin_rest_trunc Let_def split: prod.split_asm)
   apply (case_tac m)
    apply (auto simp: Let_def drop_bit_Suc take_bit_Suc mod_2_eq_odd split: prod.split_asm)
   done
 
 lemma bin_cat_num: "(\<lambda>k n l. concat_bit n l k) a n b = a * 2 ^ n + (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n b"
   by (simp add: bin_cat_eq_push_bit_add_take_bit push_bit_eq_mult)
 
 lemma bin_split_num: "bin_split n b = (b div 2 ^ n, b mod 2 ^ n)"
   by (simp add: drop_bit_eq_div take_bit_eq_mod)
 
 lemmas bin_rsplit_aux_simps = bin_rsplit_aux.simps bin_rsplitl_aux.simps
 lemmas rsplit_aux_simps = bin_rsplit_aux_simps
 
 lemmas th_if_simp1 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct1, THEN mp] for l
 lemmas th_if_simp2 = if_split [where P = "(=) l", THEN iffD1, THEN conjunct2, THEN mp] for l
 
 lemmas rsplit_aux_simp1s = rsplit_aux_simps [THEN th_if_simp1]
 
 lemmas rsplit_aux_simp2ls = rsplit_aux_simps [THEN th_if_simp2]
 \<comment> \<open>these safe to \<open>[simp add]\<close> as require calculating \<open>m - n\<close>\<close>
 lemmas bin_rsplit_aux_simp2s [simp] = rsplit_aux_simp2ls [unfolded Let_def]
 lemmas rbscl = bin_rsplit_aux_simp2s (2)
 
 lemmas rsplit_aux_0_simps [simp] =
   rsplit_aux_simp1s [OF disjI1] rsplit_aux_simp1s [OF disjI2]
 
 lemma bin_rsplit_aux_append: "bin_rsplit_aux n m c (bs @ cs) = bin_rsplit_aux n m c bs @ cs"
   apply (induct n m c bs rule: bin_rsplit_aux.induct)
   apply (subst bin_rsplit_aux.simps)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp split: prod.split)
   done
 
 lemma bin_rsplitl_aux_append: "bin_rsplitl_aux n m c (bs @ cs) = bin_rsplitl_aux n m c bs @ cs"
   apply (induct n m c bs rule: bin_rsplitl_aux.induct)
   apply (subst bin_rsplitl_aux.simps)
   apply (subst bin_rsplitl_aux.simps)
   apply (clarsimp split: prod.split)
   done
 
 lemmas rsplit_aux_apps [where bs = "[]"] =
   bin_rsplit_aux_append bin_rsplitl_aux_append
 
 lemmas rsplit_def_auxs = bin_rsplit_def bin_rsplitl_def
 
 lemmas rsplit_aux_alts = rsplit_aux_apps
   [unfolded append_Nil rsplit_def_auxs [symmetric]]
 
 lemma bin_split_minus: "0 < n \<Longrightarrow> bin_split (Suc (n - 1)) w = bin_split n w"
   by auto
 
 lemma bin_split_pred_simp [simp]:
   "(0::nat) < numeral bin \<Longrightarrow>
     bin_split (numeral bin) w =
       (let (w1, w2) = bin_split (numeral bin - 1) ((\<lambda>k::int. k div 2) w)
        in (w1, of_bool (odd w) + 2 * w2))"
   by (simp add: take_bit_rec drop_bit_rec mod_2_eq_odd)
 
 lemma bin_rsplit_aux_simp_alt:
   "bin_rsplit_aux n m c bs =
     (if m = 0 \<or> n = 0 then bs
      else let (a, b) = bin_split n c in bin_rsplit n (m - n, a) @ b # bs)"
   apply (simp add: bin_rsplit_aux.simps [of n m c bs])
   apply (subst rsplit_aux_alts)
   apply (simp add: bin_rsplit_def)
   done
 
 lemmas bin_rsplit_simp_alt =
   trans [OF bin_rsplit_def bin_rsplit_aux_simp_alt]
 
 lemmas bthrs = bin_rsplit_simp_alt [THEN [2] trans]
 
 lemma bin_rsplit_size_sign' [rule_format]:
   "n > 0 \<Longrightarrow> rev sw = bin_rsplit n (nw, w) \<Longrightarrow> \<forall>v\<in>set sw. (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n v = v"
   apply (induct sw arbitrary: nw w)
    apply clarsimp
   apply clarsimp
   apply (drule bthrs)
   apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
   apply clarify
   apply simp
   done
 
 lemmas bin_rsplit_size_sign = bin_rsplit_size_sign' [OF asm_rl
   rev_rev_ident [THEN trans] set_rev [THEN equalityD2 [THEN subsetD]]]
 
 lemma bin_nth_rsplit [rule_format] :
   "n > 0 \<Longrightarrow> m < n \<Longrightarrow>
     \<forall>w k nw.
       rev sw = bin_rsplit n (nw, w) \<longrightarrow>
       k < size sw \<longrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (sw ! k) m = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w (k * n + m)"
   apply (induct sw)
    apply clarsimp
   apply clarsimp
   apply (drule bthrs)
   apply (simp (no_asm_use) add: Let_def split: prod.split_asm if_split_asm)
   apply (erule allE, erule impE, erule exI)
   apply (case_tac k)
    apply clarsimp
    prefer 2
    apply clarsimp
    apply (erule allE)
    apply (erule (1) impE)
    apply (simp add: bit_drop_bit_eq ac_simps)
   apply (simp add: bit_take_bit_iff ac_simps)
   done
 
 lemma bin_rsplit_all: "0 < nw \<Longrightarrow> nw \<le> n \<Longrightarrow> bin_rsplit n (nw, w) = [(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w]"
   by (auto simp: bin_rsplit_def rsplit_aux_simp2ls split: prod.split dest!: split_bintrunc)
 
 lemma bin_rsplit_l [rule_format]:
   "\<forall>bin. bin_rsplitl n (m, bin) = bin_rsplit n (m, (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m bin)"
   apply (rule_tac a = "m" in wf_less_than [THEN wf_induct])
   apply (simp (no_asm) add: bin_rsplitl_def bin_rsplit_def)
   apply (rule allI)
   apply (subst bin_rsplitl_aux.simps)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp simp: Let_def split: prod.split)
   apply (simp add: ac_simps)
   apply (subst rsplit_aux_alts(1))
   apply (subst rsplit_aux_alts(2))
   apply clarsimp
   unfolding bin_rsplit_def bin_rsplitl_def
   apply (simp add: drop_bit_take_bit)
   apply (case_tac \<open>x < n\<close>)
   apply (simp_all add: not_less min_def)
   done
 
 lemma bin_rsplit_rcat [rule_format]:
   "n > 0 \<longrightarrow> bin_rsplit n (n * size ws, bin_rcat n ws) = map ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n) ws"
   apply (unfold bin_rsplit_def bin_rcat_eq_foldl)
   apply (rule_tac xs = ws in rev_induct)
    apply clarsimp
   apply clarsimp
   apply (subst rsplit_aux_alts)
   apply (simp add: drop_bit_bin_cat_eq take_bit_bin_cat_eq)
   done
 
 lemma bin_rsplit_aux_len_le [rule_format] :
   "\<forall>ws m. n \<noteq> 0 \<longrightarrow> ws = bin_rsplit_aux n nw w bs \<longrightarrow>
     length ws \<le> m \<longleftrightarrow> nw + length bs * n \<le> m * n"
 proof -
   have *: R
     if d: "i \<le> j \<or> m < j'"
     and R1: "i * k \<le> j * k \<Longrightarrow> R"
     and R2: "Suc m * k' \<le> j' * k' \<Longrightarrow> R"
     for i j j' k k' m :: nat and R
     using d
     apply safe
     apply (rule R1, erule mult_le_mono1)
     apply (rule R2, erule Suc_le_eq [THEN iffD2 [THEN mult_le_mono1]])
     done
   have **: "0 < sc \<Longrightarrow> sc - n + (n + lb * n) \<le> m * n \<longleftrightarrow> sc + lb * n \<le> m * n"
     for sc m n lb :: nat
     apply safe
      apply arith
     apply (case_tac "sc \<ge> n")
      apply arith
     apply (insert linorder_le_less_linear [of m lb])
     apply (erule_tac k=n and k'=n in *)
      apply arith
     apply simp
     done
   show ?thesis
     apply (induct n nw w bs rule: bin_rsplit_aux.induct)
     apply (subst bin_rsplit_aux.simps)
     apply (simp add: ** Let_def split: prod.split)
     done
 qed
 
 lemma bin_rsplit_len_le: "n \<noteq> 0 \<longrightarrow> ws = bin_rsplit n (nw, w) \<longrightarrow> length ws \<le> m \<longleftrightarrow> nw \<le> m * n"
   by (auto simp: bin_rsplit_def bin_rsplit_aux_len_le)
 
 lemma bin_rsplit_aux_len:
   "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit_aux n nw w cs) = (nw + n - 1) div n + length cs"
   apply (induct n nw w cs rule: bin_rsplit_aux.induct)
   apply (subst bin_rsplit_aux.simps)
   apply (clarsimp simp: Let_def split: prod.split)
   apply (erule thin_rl)
   apply (case_tac m)
    apply simp
   apply (case_tac "m \<le> n")
    apply (auto simp add: div_add_self2)
   done
 
 lemma bin_rsplit_len: "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, w)) = (nw + n - 1) div n"
   by (auto simp: bin_rsplit_def bin_rsplit_aux_len)
 
 lemma bin_rsplit_aux_len_indep:
   "n \<noteq> 0 \<Longrightarrow> length bs = length cs \<Longrightarrow>
     length (bin_rsplit_aux n nw v bs) =
     length (bin_rsplit_aux n nw w cs)"
 proof (induct n nw w cs arbitrary: v bs rule: bin_rsplit_aux.induct)
   case (1 n m w cs v bs)
   show ?case
   proof (cases "m = 0")
     case True
     with \<open>length bs = length cs\<close> show ?thesis by simp
   next
     case False
     from "1.hyps" [of \<open>bin_split n w\<close> \<open>drop_bit n w\<close> \<open>take_bit n w\<close>] \<open>m \<noteq> 0\<close> \<open>n \<noteq> 0\<close>
     have hyp: "\<And>v bs. length bs = Suc (length cs) \<Longrightarrow>
       length (bin_rsplit_aux n (m - n) v bs) =
       length (bin_rsplit_aux n (m - n) (drop_bit n w) (take_bit n w # cs))"
       using bin_rsplit_aux_len by fastforce
     from \<open>length bs = length cs\<close> \<open>n \<noteq> 0\<close> show ?thesis
       by (auto simp add: bin_rsplit_aux_simp_alt Let_def bin_rsplit_len split: prod.split)
   qed
 qed
 
 lemma bin_rsplit_len_indep:
   "n \<noteq> 0 \<Longrightarrow> length (bin_rsplit n (nw, v)) = length (bin_rsplit n (nw, w))"
   apply (unfold bin_rsplit_def)
   apply (simp (no_asm))
   apply (erule bin_rsplit_aux_len_indep)
   apply (rule refl)
   done
 
 
 subsection \<open>Logical operations\<close>
 
 abbreviation (input) bin_sc :: \<open>nat \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> int\<close>
   where \<open>bin_sc n b i \<equiv> set_bit i n b\<close>
 
 lemma bin_sc_0 [simp]:
   "bin_sc 0 b w = of_bool b + 2 * (\<lambda>k::int. k div 2) w"
   by (simp add: set_bit_int_def)
 
 lemma bin_sc_Suc [simp]:
   "bin_sc (Suc n) b w = of_bool (odd w) + 2 * bin_sc n b (w div 2)"
   by (simp add: set_bit_int_def set_bit_Suc unset_bit_Suc bin_last_def)
 
 lemma bin_nth_sc [bit_simps]: "bit (bin_sc n b w) n \<longleftrightarrow> b"
   by (simp add: bit_simps)
 
 lemma bin_sc_sc_same [simp]: "bin_sc n c (bin_sc n b w) = bin_sc n c w"
   by (induction n arbitrary: w) (simp_all add: bit_Suc)
 
 lemma bin_sc_sc_diff: "m \<noteq> n \<Longrightarrow> bin_sc m c (bin_sc n b w) = bin_sc n b (bin_sc m c w)"
   apply (induct n arbitrary: w m)
    apply (case_tac [!] m)
      apply auto
   done
 
 lemma bin_nth_sc_gen: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (bin_sc n b w) m = (if m = n then b else (bit :: int \<Rightarrow> nat \<Rightarrow> bool) w m)"
   by (simp add: bit_simps)
 
 lemma bin_sc_eq:
   \<open>bin_sc n False = unset_bit n\<close>
   \<open>bin_sc n True = Bit_Operations.set_bit n\<close>
    apply (simp_all add: fun_eq_iff bit_eq_iff)
   apply (simp_all add: bit_simps bin_nth_sc_gen)
   done
 
 lemma bin_sc_nth [simp]: "bin_sc n ((bit :: int \<Rightarrow> nat \<Rightarrow> bool) w n) w = w"
   by (rule bit_eqI) (simp add: bin_nth_sc_gen)
 
 lemma bin_sign_sc [simp]: "bin_sign (bin_sc n b w) = bin_sign w"
 proof (induction n arbitrary: w)
   case 0
   then show ?case
     by (auto simp add: bin_sign_def) (use bin_rest_ge_0 in fastforce)
 next
   case (Suc n)
   from Suc [of \<open>w div 2\<close>]
   show ?case by (auto simp add: bin_sign_def split: if_splits)
 qed
 
 lemma bin_sc_bintr [simp]:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m (bin_sc n x ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m w)) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) m (bin_sc n x w)"
   apply (rule bit_eqI)
   apply (cases x)
    apply (auto simp add: bit_simps bin_sc_eq)
   done
 
 lemma bin_clr_le: "bin_sc n False w \<le> w"
   by (simp add: set_bit_int_def unset_bit_less_eq)
 
 lemma bin_set_ge: "bin_sc n True w \<ge> w"
   by (simp add: set_bit_int_def set_bit_greater_eq)
 
 lemma bintr_bin_clr_le: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (bin_sc m False w) \<le> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: set_bit_int_def take_bit_unset_bit_eq unset_bit_less_eq)
 
 lemma bintr_bin_set_ge: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (bin_sc m True w) \<ge> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n w"
   by (simp add: set_bit_int_def take_bit_set_bit_eq set_bit_greater_eq)
 
 lemma bin_sc_FP [simp]: "bin_sc n False 0 = 0"
   by (induct n) auto
 
 lemma bin_sc_TM [simp]: "bin_sc n True (- 1) = - 1"
   by (induct n) auto
 
 lemmas bin_sc_simps = bin_sc_0 bin_sc_Suc bin_sc_TM bin_sc_FP
 
 lemma bin_sc_minus: "0 < n \<Longrightarrow> bin_sc (Suc (n - 1)) b w = bin_sc n b w"
   by auto
 
 lemmas bin_sc_Suc_minus =
   trans [OF bin_sc_minus [symmetric] bin_sc_Suc]
 
 lemma bin_sc_numeral [simp]:
   "bin_sc (numeral k) b w =
     of_bool (odd w) + 2 * bin_sc (pred_numeral k) b (w div 2)"
   by (simp add: numeral_eq_Suc)
 
 lemmas bin_sc_minus_simps =
   bin_sc_simps (2,3,4) [THEN [2] trans, OF bin_sc_minus [THEN sym]]
 
 lemma int_set_bit_0 [simp]: fixes x :: int shows
   "set_bit x 0 b = of_bool b + 2 * (x div 2)"
   by (fact bin_sc_0)
 
 lemma int_set_bit_Suc: fixes x :: int shows
   "set_bit x (Suc n) b = of_bool (odd x) + 2 * set_bit (x div 2) n b"
   by (fact bin_sc_Suc)
 
 lemma bin_last_set_bit:
   "odd (set_bit x n b :: int) = (if n > 0 then odd x else b)"
   by (cases n) (simp_all add: int_set_bit_Suc)
 
 lemma bin_rest_set_bit:
   "(set_bit x n b :: int) div 2 = (if n > 0 then set_bit (x div 2) (n - 1) b else x div 2)"
   by (cases n) (simp_all add: int_set_bit_Suc)
 
 lemma int_set_bit_numeral: fixes x :: int shows
   "set_bit x (numeral w) b = of_bool (odd x) + 2 * set_bit (x div 2) (pred_numeral w) b"
   by (fact bin_sc_numeral)
 
 lemmas int_set_bit_numerals [simp] =
   int_set_bit_numeral[where x="numeral w'"]
   int_set_bit_numeral[where x="- numeral w'"]
   int_set_bit_numeral[where x="Numeral1"]
   int_set_bit_numeral[where x="1"]
   int_set_bit_numeral[where x="0"]
   int_set_bit_Suc[where x="numeral w'"]
   int_set_bit_Suc[where x="- numeral w'"]
   int_set_bit_Suc[where x="Numeral1"]
   int_set_bit_Suc[where x="1"]
   int_set_bit_Suc[where x="0"]
   for w'
 
 lemma msb_set_bit [simp]:
   "msb (set_bit (x :: int) n b) \<longleftrightarrow> msb x"
   by (simp add: msb_int_def set_bit_int_def)
 
 lemma word_set_bit_def:
   \<open>set_bit a n x = word_of_int (bin_sc n x (uint a))\<close>
   apply (rule bit_word_eqI)
   apply (cases x)
    apply (simp_all add: bit_simps bin_sc_eq)
   done
 
 lemma set_bit_word_of_int:
   "set_bit (word_of_int x) n b = word_of_int (bin_sc n b x)"
   unfolding word_set_bit_def
   by (rule word_eqI) (simp add: word_size bin_nth_sc_gen nth_bintr bit_simps)
 
 lemma word_set_numeral [simp]:
   "set_bit (numeral bin::'a::len word) n b =
     word_of_int (bin_sc n b (numeral bin))"
   unfolding word_numeral_alt by (rule set_bit_word_of_int)
 
 lemma word_set_neg_numeral [simp]:
   "set_bit (- numeral bin::'a::len word) n b =
     word_of_int (bin_sc n b (- numeral bin))"
   unfolding word_neg_numeral_alt by (rule set_bit_word_of_int)
 
 lemma word_set_bit_0 [simp]: "set_bit 0 n b = word_of_int (bin_sc n b 0)"
   unfolding word_0_wi by (rule set_bit_word_of_int)
 
 lemma word_set_bit_1 [simp]: "set_bit 1 n b = word_of_int (bin_sc n b 1)"
   unfolding word_1_wi by (rule set_bit_word_of_int)
 
 lemmas shiftl_int_def = shiftl_eq_mult[of x for x::int]
 lemmas shiftr_int_def = shiftr_eq_div[of x for x::int]
 
 
 subsubsection \<open>Basic simplification rules\<close>
 
 context
   includes bit_operations_syntax
 begin
 
 lemmas int_not_def = not_int_def
 
 lemma int_not_simps:
   "NOT (0::int) = -1"
   "NOT (1::int) = -2"
   "NOT (- 1::int) = 0"
   "NOT (numeral w::int) = - numeral (w + Num.One)"
   "NOT (- numeral (Num.Bit0 w)::int) = numeral (Num.BitM w)"
   "NOT (- numeral (Num.Bit1 w)::int) = numeral (Num.Bit0 w)"
   by (simp_all add: not_int_def)
 
 lemma int_not_not: "NOT (NOT x) = x"
   for x :: int
   by (fact bit.double_compl)
 
 lemma int_and_0 [simp]: "0 AND x = 0"
   for x :: int
   by (fact bit.conj_zero_left)
 
 lemma int_and_m1 [simp]: "-1 AND x = x"
   for x :: int
   by (fact and.left_neutral)
 
 lemma int_or_zero [simp]: "0 OR x = x"
   for x :: int
   by (fact or.left_neutral)
 
 lemma int_or_minus1 [simp]: "-1 OR x = -1"
   for x :: int
   by (fact bit.disj_one_left)
 
 lemma int_xor_zero [simp]: "0 XOR x = x"
   for x :: int
   by (fact xor.left_neutral)
 
 
 subsubsection \<open>Binary destructors\<close>
 
 lemma bin_rest_NOT [simp]: "(\<lambda>k::int. k div 2) (NOT x) = NOT ((\<lambda>k::int. k div 2) x)"
   by (fact not_int_div_2)
 
 lemma bin_last_NOT [simp]: "(odd :: int \<Rightarrow> bool) (NOT x) \<longleftrightarrow> \<not> (odd :: int \<Rightarrow> bool) x"
   by simp
 
 lemma bin_rest_AND [simp]: "(\<lambda>k::int. k div 2) (x AND y) = (\<lambda>k::int. k div 2) x AND (\<lambda>k::int. k div 2) y"
   by (subst and_int_rec) auto
 
 lemma bin_last_AND [simp]: "(odd :: int \<Rightarrow> bool) (x AND y) \<longleftrightarrow> (odd :: int \<Rightarrow> bool) x \<and> (odd :: int \<Rightarrow> bool) y"
   by (subst and_int_rec) auto
 
 lemma bin_rest_OR [simp]: "(\<lambda>k::int. k div 2) (x OR y) = (\<lambda>k::int. k div 2) x OR (\<lambda>k::int. k div 2) y"
   by (subst or_int_rec) auto
 
 lemma bin_last_OR [simp]: "(odd :: int \<Rightarrow> bool) (x OR y) \<longleftrightarrow> (odd :: int \<Rightarrow> bool) x \<or> (odd :: int \<Rightarrow> bool) y"
   by (subst or_int_rec) auto
 
 lemma bin_rest_XOR [simp]: "(\<lambda>k::int. k div 2) (x XOR y) = (\<lambda>k::int. k div 2) x XOR (\<lambda>k::int. k div 2) y"
   by (subst xor_int_rec) auto
 
 lemma bin_last_XOR [simp]: "(odd :: int \<Rightarrow> bool) (x XOR y) \<longleftrightarrow> ((odd :: int \<Rightarrow> bool) x \<or> (odd :: int \<Rightarrow> bool) y) \<and> \<not> ((odd :: int \<Rightarrow> bool) x \<and> (odd :: int \<Rightarrow> bool) y)"
   by (subst xor_int_rec) auto
 
 lemma bin_nth_ops:
   "\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x AND y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   "\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x OR y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<or> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   "\<And>x y. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (x XOR y) n \<longleftrightarrow> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<noteq> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) y n"
   "\<And>x. (bit :: int \<Rightarrow> nat \<Rightarrow> bool) (NOT x) n \<longleftrightarrow> \<not> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n"
   by (simp_all add: bit_and_iff bit_or_iff bit_xor_iff bit_not_iff)
 
 
 subsubsection \<open>Derived properties\<close>
 
 lemma int_xor_minus1 [simp]: "-1 XOR x = NOT x"
   for x :: int
   by (fact bit.xor_one_left)
 
 lemma int_xor_extra_simps [simp]:
   "w XOR 0 = w"
   "w XOR -1 = NOT w"
   for w :: int
   by simp_all
 
 lemma int_or_extra_simps [simp]:
   "w OR 0 = w"
   "w OR -1 = -1"
   for w :: int
   by simp_all
 
 lemma int_and_extra_simps [simp]:
   "w AND 0 = 0"
   "w AND -1 = w"
   for w :: int
   by simp_all
 
 text \<open>Commutativity of the above.\<close>
 lemma bin_ops_comm:
   fixes x y :: int
   shows int_and_comm: "x AND y = y AND x"
     and int_or_comm:  "x OR y = y OR x"
     and int_xor_comm: "x XOR y = y XOR x"
   by (simp_all add: ac_simps)
 
 lemma bin_ops_same [simp]:
   "x AND x = x"
   "x OR x = x"
   "x XOR x = 0"
   for x :: int
   by simp_all
 
 lemmas bin_log_esimps =
   int_and_extra_simps  int_or_extra_simps  int_xor_extra_simps
   int_and_0 int_and_m1 int_or_zero int_or_minus1 int_xor_zero int_xor_minus1
 
 
 subsubsection \<open>Basic properties of logical (bit-wise) operations\<close>
 
 lemma bbw_ao_absorb: "x AND (y OR x) = x \<and> x OR (y AND x) = x"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_ao_absorbs_other:
   "x AND (x OR y) = x \<and> (y AND x) OR x = x"
   "(y OR x) AND x = x \<and> x OR (x AND y) = x"
   "(x OR y) AND x = x \<and> (x AND y) OR x = x"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemmas bbw_ao_absorbs [simp] = bbw_ao_absorb bbw_ao_absorbs_other
 
 lemma int_xor_not: "(NOT x) XOR y = NOT (x XOR y) \<and> x XOR (NOT y) = NOT (x XOR y)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_and_assoc: "(x AND y) AND z = x AND (y AND z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_or_assoc: "(x OR y) OR z = x OR (y OR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma int_xor_assoc: "(x XOR y) XOR z = x XOR (y XOR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemmas bbw_assocs = int_and_assoc int_or_assoc int_xor_assoc
 
 (* BH: Why are these declared as simp rules??? *)
 lemma bbw_lcs [simp]:
   "y AND (x AND z) = x AND (y AND z)"
   "y OR (x OR z) = x OR (y OR z)"
   "y XOR (x XOR z) = x XOR (y XOR z)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_not_dist:
   "NOT (x OR y) = (NOT x) AND (NOT y)"
   "NOT (x AND y) = (NOT x) OR (NOT y)"
   for x y :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_oa_dist: "(x AND y) OR z = (x OR z) AND (y OR z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 lemma bbw_ao_dist: "(x OR y) AND z = (x AND z) OR (y AND z)"
   for x y z :: int
   by (auto simp add: bin_eq_iff bin_nth_ops)
 
 
 subsubsection \<open>Simplification with numerals\<close>
 
 text \<open>Cases for \<open>0\<close> and \<open>-1\<close> are already covered by other simp rules.\<close>
 
 lemma bin_rest_neg_numeral_BitM [simp]:
   "(\<lambda>k::int. k div 2) (- numeral (Num.BitM w)) = - numeral w"
   by simp
 
 lemma bin_last_neg_numeral_BitM [simp]:
   "(odd :: int \<Rightarrow> bool) (- numeral (Num.BitM w))"
   by simp
 
 
 subsubsection \<open>Interactions with arithmetic\<close>
 
 lemma le_int_or: "bin_sign y = 0 \<Longrightarrow> x \<le> x OR y"
   for x y :: int
   by (simp add: bin_sign_def or_greater_eq split: if_splits)
 
 lemmas int_and_le =
   xtrans(3) [OF bbw_ao_absorbs (2) [THEN conjunct2, symmetric] le_int_or]
 
 text \<open>Interaction between bit-wise and arithmetic: good example of \<open>bin_induction\<close>.\<close>
 lemma bin_add_not: "x + NOT x = (-1::int)"
   by (simp add: not_int_def)
 
 lemma AND_mod: "x AND (2 ^ n - 1) = x mod 2 ^ n"
   for x :: int
   by (simp flip: take_bit_eq_mod add: take_bit_eq_mask mask_eq_exp_minus_1)
 
 
 subsubsection \<open>Truncating results of bit-wise operations\<close>
 
 lemma bin_trunc_ao:
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x AND (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x AND y)"
   "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x OR (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x OR y)"
   by simp_all
 
 lemma bin_trunc_xor: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x XOR (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (x XOR y)"
   by simp
 
 lemma bin_trunc_not: "(take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (NOT ((take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x)) = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n (NOT x)"
   by (fact take_bit_not_take_bit)
 
 text \<open>Want theorems of the form of \<open>bin_trunc_xor\<close>.\<close>
 lemma bintr_bintr_i: "x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y \<Longrightarrow> (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n y"
   by auto
 
 lemmas bin_trunc_and = bin_trunc_ao(1) [THEN bintr_bintr_i]
 lemmas bin_trunc_or = bin_trunc_ao(2) [THEN bintr_bintr_i]
 
 
 subsubsection \<open>More lemmas\<close>
 
 lemma not_int_cmp_0 [simp]:
   fixes i :: int shows
   "0 < NOT i \<longleftrightarrow> i < -1"
   "0 \<le> NOT i \<longleftrightarrow> i < 0"
   "NOT i < 0 \<longleftrightarrow> i \<ge> 0"
   "NOT i \<le> 0 \<longleftrightarrow> i \<ge> -1"
 by(simp_all add: int_not_def) arith+
 
 lemma bbw_ao_dist2: "(x :: int) AND (y OR z) = x AND y OR x AND z"
   by (fact bit.conj_disj_distrib)
 
 lemmas int_and_ac = bbw_lcs(1) int_and_comm int_and_assoc
 
 lemma int_nand_same [simp]: fixes x :: int shows "x AND NOT x = 0"
   by simp
 
 lemma int_nand_same_middle: fixes x :: int shows "x AND y AND NOT x = 0"
   by (simp add: bit_eq_iff bit_and_iff bit_not_iff)
 
 lemma and_xor_dist: fixes x :: int shows
   "x AND (y XOR z) = (x AND y) XOR (x AND z)"
   by (fact bit.conj_xor_distrib)
 
 lemma int_and_lt0 [simp]:
   \<open>x AND y < 0 \<longleftrightarrow> x < 0 \<and> y < 0\<close> for x y :: int
   by (fact and_negative_int_iff)
 
 lemma int_and_ge0 [simp]:
   \<open>x AND y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<or> y \<ge> 0\<close> for x y :: int
   by (fact and_nonnegative_int_iff)
 
 lemma int_and_1: fixes x :: int shows "x AND 1 = x mod 2"
   by (fact and_one_eq)
 
 lemma int_1_and: fixes x :: int shows "1 AND x = x mod 2"
   by (fact one_and_eq)
 
 lemma int_or_lt0 [simp]:
   \<open>x OR y < 0 \<longleftrightarrow> x < 0 \<or> y < 0\<close> for x y :: int
   by (fact or_negative_int_iff)
 
 lemma int_or_ge0 [simp]:
   \<open>x OR y \<ge> 0 \<longleftrightarrow> x \<ge> 0 \<and> y \<ge> 0\<close> for x y :: int
   by (fact or_nonnegative_int_iff)
 
 lemma int_xor_lt0 [simp]:
   \<open>x XOR y < 0 \<longleftrightarrow> (x < 0) \<noteq> (y < 0)\<close> for x y :: int
   by (fact xor_negative_int_iff)
 
 lemma int_xor_ge0 [simp]:
   \<open>x XOR y \<ge> 0 \<longleftrightarrow> (x \<ge> 0 \<longleftrightarrow> y \<ge> 0)\<close> for x y :: int
   by (fact xor_nonnegative_int_iff)
 
 lemma even_conv_AND:
   \<open>even i \<longleftrightarrow> i AND 1 = 0\<close> for i :: int
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bin_last_conv_AND:
   "(odd :: int \<Rightarrow> bool) i \<longleftrightarrow> i AND 1 \<noteq> 0"
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bitval_bin_last:
   "of_bool ((odd :: int \<Rightarrow> bool) i) = i AND 1"
   by (simp add: and_one_eq mod2_eq_if)
 
 lemma bin_sign_and:
   "bin_sign (i AND j) = - (bin_sign i * bin_sign j)"
 by(simp add: bin_sign_def)
 
 lemma int_not_neg_numeral: "NOT (- numeral n) = (Num.sub n num.One :: int)"
 by(simp add: int_not_def)
 
 lemma int_neg_numeral_pOne_conv_not: "- numeral (n + num.One) = (NOT (numeral n) :: int)"
 by(simp add: int_not_def)
 
 
 subsection \<open>Setting and clearing bits\<close>
 
 lemma int_shiftl_BIT: fixes x :: int
   shows int_shiftl0: "x << 0 = x"
   and int_shiftl_Suc: "x << Suc n = 2 * x << n"
   by (auto simp add: shiftl_int_def)
 
 lemma int_0_shiftl: "push_bit n 0 = (0 :: int)"
   by (fact push_bit_of_0)
 
 lemma bin_last_shiftl: "odd (push_bit n x) \<longleftrightarrow> n = 0 \<and> (odd :: int \<Rightarrow> bool) x"
   by simp
 
 lemma bin_rest_shiftl: "(\<lambda>k::int. k div 2) (push_bit n x) = (if n > 0 then push_bit (n - 1) x else (\<lambda>k::int. k div 2) x)"
   by (cases n) (simp_all add: push_bit_eq_mult)
 
 lemma bin_nth_shiftl: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (push_bit n x) m \<longleftrightarrow> n \<le> m \<and> (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (m - n)"
   by (fact bit_push_bit_iff_int)
 
 lemma bin_last_shiftr: "odd (drop_bit n x) \<longleftrightarrow> bit x n" for x :: int
   by (simp add: bit_iff_odd_drop_bit)
 
 lemma bin_rest_shiftr: "(\<lambda>k::int. k div 2) (drop_bit n x) = drop_bit (Suc n) x"
   by (simp add: drop_bit_Suc drop_bit_half)
 
 lemma bin_nth_shiftr: "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) (drop_bit n x) m = (bit :: int \<Rightarrow> nat \<Rightarrow> bool) x (n + m)"
   by (simp add: bit_simps)
 
 lemma bin_nth_conv_AND:
   fixes x :: int shows
   "(bit :: int \<Rightarrow> nat \<Rightarrow> bool) x n \<longleftrightarrow> x AND (push_bit n 1) \<noteq> 0"
   by (fact bit_iff_and_push_bit_not_eq_0)
 
 lemma int_shiftl_numeral [simp]:
   "push_bit (numeral w') (numeral w :: int) = push_bit (pred_numeral w') (numeral (num.Bit0 w))"
   "push_bit (numeral w') (- numeral w :: int) = push_bit (pred_numeral w') (- numeral (num.Bit0 w))"
 by(simp_all add: numeral_eq_Suc shiftl_int_def)
   (metis add_One mult_inc semiring_norm(11) semiring_norm(13) semiring_norm(2) semiring_norm(6) semiring_norm(87))+
 
 lemma int_shiftl_One_numeral [simp]:
   "push_bit (numeral w) (1::int) = push_bit (pred_numeral w) 2"
   using int_shiftl_numeral [of Num.One w]
   by (simp only: numeral_eq_Suc push_bit_Suc) simp
 
 lemma shiftl_ge_0: fixes i :: int shows "push_bit n i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by (fact push_bit_nonnegative_int_iff)
 
 lemma shiftl_lt_0: fixes i :: int shows "push_bit n i < 0 \<longleftrightarrow> i < 0"
   by (fact push_bit_negative_int_iff)
 
 lemma int_shiftl_test_bit: "bit (push_bit i n :: int) m \<longleftrightarrow> m \<ge> i \<and> bit n (m - i)"
   by (fact bit_push_bit_iff_int)
 
 lemma int_0shiftr: "drop_bit x (0 :: int) = 0"
   by (fact drop_bit_of_0)
 
 lemma int_minus1_shiftr: "drop_bit x (-1 :: int) = -1"
   by (fact drop_bit_minus_one)
 
 lemma int_shiftr_ge_0: fixes i :: int shows "drop_bit n i \<ge> 0 \<longleftrightarrow> i \<ge> 0"
   by (fact drop_bit_nonnegative_int_iff)
 
 lemma int_shiftr_lt_0 [simp]: fixes i :: int shows "drop_bit n i < 0 \<longleftrightarrow> i < 0"
   by (fact drop_bit_negative_int_iff)
 
 lemma int_shiftr_numeral [simp]:
   "drop_bit (numeral w') (1 :: int) = 0"
   "drop_bit (numeral w') (numeral num.One :: int) = 0"
   "drop_bit (numeral w') (numeral (num.Bit0 w) :: int) = drop_bit (pred_numeral w') (numeral w)"
   "drop_bit (numeral w') (numeral (num.Bit1 w) :: int) = drop_bit (pred_numeral w') (numeral w)"
   "drop_bit (numeral w') (- numeral (num.Bit0 w) :: int) = drop_bit (pred_numeral w') (- numeral w)"
   "drop_bit (numeral w') (- numeral (num.Bit1 w) :: int) = drop_bit (pred_numeral w') (- numeral (Num.inc w))"
   by (simp_all add: numeral_eq_Suc add_One drop_bit_Suc)
 
 lemma int_shiftr_numeral_Suc0 [simp]:
   "drop_bit (Suc 0) (1 :: int) = 0"
   "drop_bit (Suc 0) (numeral num.One :: int) = 0"
   "drop_bit (Suc 0) (numeral (num.Bit0 w) :: int) = numeral w"
   "drop_bit (Suc 0) (numeral (num.Bit1 w) :: int) = numeral w"
   "drop_bit (Suc 0) (- numeral (num.Bit0 w) :: int) = - numeral w"
   "drop_bit (Suc 0) (- numeral (num.Bit1 w) :: int) = - numeral (Num.inc w)"
   by (simp_all add: drop_bit_Suc add_One)
 
 lemma bin_nth_minus_p2:
   assumes sign: "bin_sign x = 0"
     and y: "y = push_bit n 1"
     and m: "m < n"
     and x: "x < y"
   shows "bit (x - y) m = bit x m"
 proof -
   from \<open>bin_sign x = 0\<close> have \<open>x \<ge> 0\<close>
     by (simp add: sign_Pls_ge_0) 
   moreover from x y have \<open>x < 2 ^ n\<close>
     by simp
   ultimately have \<open>q < n\<close> if \<open>bit x q\<close> for q
     using that by (metis bit_take_bit_iff take_bit_int_eq_self)
   then have \<open>bit (x + NOT (mask n)) m = bit x m\<close>
     using \<open>m < n\<close> by (simp add: disjunctive_add bit_simps)
   also have \<open>x + NOT (mask n) = x - y\<close>
     using y by (simp flip: minus_exp_eq_not_mask)
   finally show ?thesis .
 qed
 
 lemma bin_clr_conv_NAND:
   "bin_sc n False i = i AND NOT (push_bit n 1)"
   by (rule bit_eqI) (auto simp add: bin_sc_eq bit_simps)
 
 lemma bin_set_conv_OR:
   "bin_sc n True i = i OR (push_bit n 1)"
   by (rule bit_eqI) (auto simp add: bin_sc_eq bit_simps)
 
 end
 
 
 subsection \<open>More lemmas on words\<close>
 
 lemma msb_conv_bin_sign:
   "msb x \<longleftrightarrow> bin_sign x = -1"
   by (simp add: bin_sign_def not_le msb_int_def)
 
 lemma msb_bin_sc:
   "msb (bin_sc n b x) \<longleftrightarrow> msb x"
   by (simp add: msb_conv_bin_sign)
 
 lemma msb_word_def:
   \<open>msb a \<longleftrightarrow> bin_sign (signed_take_bit (LENGTH('a) - 1) (uint a)) = - 1\<close>
   for a :: \<open>'a::len word\<close>
   by (simp add: bin_sign_def bit_simps msb_word_iff_bit)
 
 lemma word_msb_def:
   "msb a \<longleftrightarrow> bin_sign (sint a) = - 1"
   by (simp add: msb_word_def sint_uint)
 
 lemma word_rcat_eq:
   \<open>word_rcat ws = word_of_int (bin_rcat (LENGTH('a::len)) (map uint ws))\<close>
   for ws :: \<open>'a::len word list\<close>
   apply (simp add: word_rcat_def bin_rcat_def rev_map)
   apply transfer
   apply (simp add: horner_sum_foldr foldr_map comp_def)
   done
 
 lemma sign_uint_Pls [simp]: "bin_sign (uint x) = 0"
   by (simp add: sign_Pls_ge_0)
 
 lemmas bin_log_bintrs = bin_trunc_not bin_trunc_xor bin_trunc_and bin_trunc_or
 
 \<comment> \<open>following definitions require both arithmetic and bit-wise word operations\<close>
 
 \<comment> \<open>to get \<open>word_no_log_defs\<close> from \<open>word_log_defs\<close>, using \<open>bin_log_bintrs\<close>\<close>
 lemmas wils1 = bin_log_bintrs [THEN word_of_int_eq_iff [THEN iffD2],
   folded uint_word_of_int_eq, THEN eq_reflection]
 
 \<comment> \<open>the binary operations only\<close>  (* BH: why is this needed? *)
 lemmas word_log_binary_defs =
   word_and_def word_or_def word_xor_def
 
 lemma setBit_no: "Bit_Operations.set_bit n (numeral bin) = word_of_int (bin_sc n True (numeral bin))"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma clearBit_no:
   "unset_bit n (numeral bin) = word_of_int (bin_sc n False (numeral bin))"
   by (rule bit_word_eqI) (simp add: bit_simps)
 
 lemma eq_mod_iff: "0 < n \<Longrightarrow> b = b mod n \<longleftrightarrow> 0 \<le> b \<and> b < n"
   for b n :: int
-  by auto (metis pos_mod_conj)+
+  using pos_mod_sign [of n b] pos_mod_bound [of n b] by (safe, auto)
 
 lemma split_uint_lem: "bin_split n (uint w) = (a, b) \<Longrightarrow>
     a = take_bit (LENGTH('a) - n) a \<and> b = take_bit (LENGTH('a)) b"
   for w :: "'a::len word"
   by transfer (simp add: drop_bit_take_bit ac_simps)
 
 \<comment> \<open>limited hom result\<close>
 lemma word_cat_hom:
   "LENGTH('a::len) \<le> LENGTH('b::len) + LENGTH('c::len) \<Longrightarrow>
     (word_cat (word_of_int w :: 'b word) (b :: 'c word) :: 'a word) =
     word_of_int ((\<lambda>k n l. concat_bit n l k) w (size b) (uint b))"
   by transfer (simp add: take_bit_concat_bit_eq)
 
 lemma bintrunc_shiftl:
   "take_bit n (push_bit i m) = push_bit i (take_bit (n - i) m)"
   for m :: int
   by (fact take_bit_push_bit)
 
 lemma uint_shiftl:
   "uint (push_bit i n) = take_bit (size n) (push_bit i (uint n))"
   by (simp add: unsigned_push_bit_eq word_size)
 
 lemma bin_mask_conv_pow2:
   "mask n = 2 ^ n - (1 :: int)"
   by (fact mask_eq_exp_minus_1)
 
 lemma bin_mask_ge0: "mask n \<ge> (0 :: int)"
   by (fact mask_nonnegative_int)
 
 context
   includes bit_operations_syntax
 begin
 
 lemma and_bin_mask_conv_mod: "x AND mask n = x mod 2 ^ n"
   for x :: int
   by (simp flip: take_bit_eq_mod add: take_bit_eq_mask)
 
 end
 
 lemma bin_mask_numeral:
   "mask (numeral n) = (1 :: int) + 2 * mask (pred_numeral n)"
   by (fact mask_numeral)
 
 lemma bin_nth_mask: "bit (mask n :: int) i \<longleftrightarrow> i < n"
   by (simp add: bit_mask_iff)
 
 lemma bin_sign_mask [simp]: "bin_sign (mask n) = 0"
   by (simp add: bin_sign_def bin_mask_conv_pow2)
 
 lemma bin_mask_p1_conv_shift: "mask n + 1 = push_bit n (1 :: int)"
   by (simp add: bin_mask_conv_pow2 shiftl_int_def)
 
 lemma sbintrunc_eq_in_range:
   "((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = x) = (x \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n))"
   "(x = (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x) = (x \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n))"
   apply (simp_all add: image_def)
   apply (metis sbintrunc_sbintrunc)+
   done
 
 lemma sbintrunc_If:
   "- 3 * (2 ^ n) \<le> x \<and> x < 3 * (2 ^ n)
     \<Longrightarrow> (signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) n x = (if x < - (2 ^ n) then x + 2 * (2 ^ n)
         else if x \<ge> 2 ^ n then x - 2 * (2 ^ n) else x)"
   apply (simp add: no_sbintr_alt2, safe)
    apply (simp add: mod_pos_geq)
   apply (subst mod_add_self1[symmetric], simp)
   done
 
 lemma sint_range':
   \<open>- (2 ^ (LENGTH('a) - Suc 0)) \<le> sint x \<and> sint x < 2 ^ (LENGTH('a) - Suc 0)\<close>
   for x :: \<open>'a::len word\<close>
   apply transfer
   using sbintr_ge sbintr_lt apply auto
   done
 
 lemma signed_arith_eq_checks_to_ord:
   "(sint a + sint b = sint (a + b ))
     = ((a <=s a + b) = (0 <=s b))"
   "(sint a - sint b = sint (a - b ))
     = ((0 <=s a - b) = (b <=s a))"
   "(- sint a = sint (- a)) = (0 <=s (- a) = (a <=s 0))"
   using sint_range'[where x=a] sint_range'[where x=b]
   by (simp_all add: sint_word_ariths word_sle_eq word_sless_alt sbintrunc_If)
 
 lemma signed_mult_eq_checks_double_size:
   assumes mult_le: "(2 ^ (len_of TYPE ('a) - 1) + 1) ^ 2 \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
            and le: "2 ^ (LENGTH('a) - 1) \<le> (2 :: int) ^ (len_of TYPE ('b) - 1)"
   shows "(sint (a :: 'a :: len word) * sint b = sint (a * b))
        = (scast a * scast b = (scast (a * b) :: 'b :: len word))"
 proof -
   have P: "(signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (size a - 1) (sint a * sint b) \<in> range ((signed_take_bit :: nat \<Rightarrow> int \<Rightarrow> int) (size a - 1))"
     by simp
 
   have abs: "!! x :: 'a word. abs (sint x) < 2 ^ (size a - 1) + 1"
     apply (cut_tac x=x in sint_range')
     apply (simp add: abs_le_iff word_size)
     done
   have abs_ab: "abs (sint a * sint b) < 2 ^ (LENGTH('b) - 1)"
     using abs_mult_less[OF abs[where x=a] abs[where x=b]] mult_le
     by (simp add: abs_mult power2_eq_square word_size)
   define r s where \<open>r = LENGTH('a) - 1\<close> \<open>s = LENGTH('b) - 1\<close>
   then have \<open>LENGTH('a) = Suc r\<close> \<open>LENGTH('b) = Suc s\<close>
     \<open>size a = Suc r\<close> \<open>size b = Suc r\<close>
     by (simp_all add: word_size)
   then show ?thesis
     using P[unfolded range_sbintrunc] abs_ab le
     apply clarsimp
     apply (transfer fixing: r s)
     apply (auto simp add: signed_take_bit_int_eq_self simp flip: signed_take_bit_eq_iff_take_bit_eq)
     done
 qed
 
 lemma bintrunc_id:
   "\<lbrakk>m \<le> int n; 0 < m\<rbrakk> \<Longrightarrow> take_bit n m = m"
   by (simp add: take_bit_int_eq_self_iff le_less_trans)
 
 lemma bin_cat_cong: "concat_bit n b a = concat_bit m d c"
   if "n = m" "a = c" "take_bit m b = take_bit m d"
   using that(3) unfolding that(1,2)
   by (simp add: bin_cat_eq_push_bit_add_take_bit)
 
 lemma bin_cat_eqD1: "concat_bit n b a = concat_bit n d c \<Longrightarrow> a = c"
   by (metis drop_bit_bin_cat_eq)
 
 lemma bin_cat_eqD2: "concat_bit n b a = concat_bit n d c \<Longrightarrow> take_bit n b = take_bit n d"
   by (metis take_bit_bin_cat_eq)
 
 lemma bin_cat_inj: "(concat_bit n b a) = concat_bit n d c \<longleftrightarrow> a = c \<and> take_bit n b = take_bit n d"
   by (auto intro: bin_cat_cong bin_cat_eqD1 bin_cat_eqD2)
 
 lemma bin_sc_pos:
   "0 \<le> i \<Longrightarrow> 0 \<le> bin_sc n b i"
   by (metis bin_sign_sc sign_Pls_ge_0)
 
 code_identifier
   code_module Bits_Int \<rightharpoonup>
   (SML) Bit_Operations and (OCaml) Bit_Operations and (Haskell) Bit_Operations and (Scala) Bit_Operations
 
 end
diff --git a/thys/Word_Lib/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,2232 +1,2229 @@
 (*
  * 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
     Singleton_Bit_Shifts
     Legacy_Aliases
 begin
 
 context
   includes bit_operations_syntax
 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 (w div 2) (odd 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 (take_bit 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) = take_bit 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 (take_bit 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 (take_bit 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 (take_bit 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 (signed_take_bit 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 (signed_take_bit n w) = -1)"
   unfolding bin_to_bl_def by (rule bl_sbin_sign_aux)
 
 lemma bin_nth_of_bl_aux:
   "bit (bl_to_bin_aux bl w) n =
     (n < size bl \<and> rev bl ! n \<or> n \<ge> length bl \<and> bit 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: "bit (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> bit w n = nth (rev (bin_to_bl m w)) n"
   by (metis bin_bl_bin bin_nth_of_bl nth_bintr size_bin_to_bl)
 
 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 = bit 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) (w div 2)"
   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) (bl_to_bin bl div 2)"
   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 = bl_to_bin_aux bl w div 2"
   by (induct bl arbitrary: w) auto
 
 lemma butlast_rest_bl2bin: "bl_to_bin (butlast bl) = bl_to_bin bl div 2"
   by (cases bl) (auto simp: bl_to_bin_def butlast_rest_bl2bin_aux)
 
 lemma trunc_bl2bin_aux:
   "take_bit m (bl_to_bin_aux bl w) =
     bl_to_bin_aux (drop (length bl - m) bl) (take_bit (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: "take_bit 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]: "take_bit (length bl) (bl_to_bin bl) = bl_to_bin bl"
   by (simp add: trunc_bl2bin)
 
 lemma bl2bin_drop: "bl_to_bin (drop k bl) = take_bit (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 (((\<lambda>w. w div 2) ^^ (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> odd (bl_to_bin_aux xs w)"
   by (induct xs arbitrary: w) auto
 
 lemma last_bin_last: "size xs > 0 \<Longrightarrow> last xs \<longleftrightarrow> odd (bl_to_bin xs)"
   unfolding bl_to_bin_def by (erule last_bin_last')
 
 lemma bin_last_last: "odd 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 (concat_bit nv v w) =
     concat_bit (nv + length bs) (bl_to_bin_aux bs v) w"
   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) (concat_bit nw w v) 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 = concat_bit (length bs) (bl_to_bin bs) w"
   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) (concat_bit nw w v) =
     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) = concat_bit (length bs) (bl_to_bin bs) (bl_to_bin bsa)"
   by (simp only: bl_to_bin_aux_app_cat bl_to_bin_def)
 
 lemma bin_to_bl_cat_app:
   "bin_to_bl (n + nw) (concat_bit nw wa w) = 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: "concat_bit n w (bl_to_bin cs) = 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 (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_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_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 (simp add: length_concat comp_def sum_list_triv)
 
 lemma bin_cat_foldl_lem:
   "foldl (\<lambda>u k. concat_bit n k u) x xs =
     concat_bit (size xs * n) (foldl (\<lambda>u k. concat_bit n k u) y xs) x"
   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 = "concat_bit n a y" 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: "odd (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: "bl_to_bin bs div 2 = 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 (rule bit_word_eqI)
   apply (auto simp add: bit_simps to_bl_eq_rev nth_append rev_nth nth_butlast not_less simp flip: bit_Suc)
   apply (metis Suc_pred len_gt_0 less_eq_decr_length_iff not_bit_length verit_la_disequality)
   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
 
 global_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_to_bl_iff:
   \<open>hd (to_bl w) \<longleftrightarrow> bit w (LENGTH('a) - 1)\<close>
   for w :: \<open>'a::len word\<close>
   by (simp add: to_bl_eq_rev hd_map hd_rev)
 
 lemma hd_bl_sign_sint: "hd (to_bl w) = (bin_sign (sint w) = -1)"
   by (simp add: hd_to_bl_iff bit_last_iff bin_sign_def)
 
 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:
   "bit (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': "bit (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: "bit 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 = bit 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 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 (rule bit_word_eqI) (auto simp add: bit_simps rev_nth nth_append nth_butlast nth_bin_to_bl simp flip: bit_Suc)
 
 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])"
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   subgoal for n
     apply (cases n)
      apply simp_all
     done
   done
 
 lemma shiftl1_bl: "shiftl1 w = of_bl (to_bl w @ [False])"
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   subgoal for n
     apply (cases n)
      apply (simp_all add: nth_rev_to_bl)
     done
   done
 
 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)
 
 lemma to_bl_double_eq:
   \<open>to_bl (2 * w) = tl (to_bl w) @ [False]\<close>
   using bl_shiftl1 [of w] by (simp add: shiftl1_def ac_simps)
 
 \<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 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 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 (rule nth_equalityI)
    apply (simp_all add: word_size to_bl_nth bit_simps)
   done
 
 lemma drop_sshiftr: "drop n (to_bl (w >>> n)) = take (size w - n) (to_bl w)"
   for w :: "'a::len word"
   apply (rule nth_equalityI)
    apply (simp_all add: word_size nth_to_bl bit_simps)
   done
 
 lemma take_shiftr: "n \<le> size w \<Longrightarrow> take n (to_bl (w >> n)) = replicate n False"
   apply (rule nth_equalityI)
    apply (auto simp add: word_size to_bl_nth bit_simps dest: bit_imp_le_length)
   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 (cases n)
    apply (auto simp add: hd_to_bl_iff bit_simps not_less word_size)
   apply (rule nth_equalityI)
    apply (auto simp add: nth_to_bl bit_simps nth_Cons split: nat.split)
   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)"
   apply (rule bit_word_eqI)
   apply (auto simp add: bit_simps nth_append)
   done
 
 lemma shiftl_bl: "w << n = of_bl (to_bl w @ replicate n False)"
   for w :: "'a::len word"
   by (simp flip: shiftl_of_bl)
 
 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)"
   apply (rule bit_word_eqI)
   apply (simp add: bit_simps)
   apply (cases bl rule: rev_cases)
   apply auto
   done
 
 lemma shiftr_bl_of:
   "length bl \<le> LENGTH('a) \<Longrightarrow>
      (of_bl bl::'a::len word) >> n = of_bl (take (length bl - n) bl)"
   by (rule bit_word_eqI) (auto simp add: bit_simps rev_nth)
 
 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: bit_simps 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 bit_simps)
   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"]
 
 end
 
 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)
+    apply (auto simp add: nat_mult_distrib nat_mod_distrib)
+  using nat_0_le nat_minus_as_int zmod_int apply presburger
   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 (- 1::'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
 
 context
   includes bit_operations_syntax
 begin
 
 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 [bit x 0]"
   by (simp add: word_and_1)
 
 lemma word_1_and_bl:
   fixes x::"'a::len word"
   shows "(1 AND x) = of_bl [bit x 0]"
   using word_and_1_bl [of x] by (simp add: ac_simps)
 
 lemma of_bl_drop:
   "of_bl (drop n xs) = (of_bl xs AND mask (length xs - n))"
   apply (rule bit_word_eqI)
   apply (auto simp: rev_nth bit_simps cong: rev_conj_cong)
   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: last_conv_nth bit_0 lsb_odd)
 
 lemma is_aligned_to_bl:
   "is_aligned (w :: 'a :: len word) n = (True \<notin> set (drop (size w - n) (to_bl w)))"
   by (simp add: is_aligned_mask eq_zero_set_bl bl_and_mask word_size)
 
 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"
   apply (rule nth_equalityI)
   using assms apply (simp_all add: nth_append not_less word_size to_bl_nth is_aligned_imp_not_bit)
   done
 
 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 (rule nth_equalityI)
    apply (auto simp add: nth_append to_bl_nth word_size bit_simps not_less nth_Cons le_diff_conv)
   subgoal for i
   apply (cases \<open>Suc (i + n) - LENGTH('a)\<close>)
   apply simp_all
     done
   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)"
   apply (auto simp add: to_bl_eq_rev take_map drop_map take_rev drop_rev bit_simps)
   apply (rule nth_equalityI)
    apply (auto simp add: bit_simps rev_nth nth_append Suc_diff_Suc)
   done
 
 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)
   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
 
 (* 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 (bit 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
 
 text\<open>Some auxiliaries for sign-shifting by the entire word length or more\<close>
 
 lemma sshiftr_clamp_pos:
   assumes
     "LENGTH('a) \<le> n"
     "0 \<le> sint x"
   shows "(x::'a::len word) >>> n = 0"
   apply (rule bit_word_eqI)
   using assms
   apply (auto simp add: bit_simps bit_last_iff)
   done
 
 lemma sshiftr_clamp_neg:
   assumes
     "LENGTH('a) \<le> n"
     "sint x < 0"
   shows "(x::'a::len word) >>> n = -1"
   apply (rule bit_word_eqI)
   using assms
   apply (auto simp add: bit_simps bit_last_iff)
   done
 
 lemma sshiftr_clamp:
   assumes "LENGTH('a) \<le> n"
   shows "(x::'a::len word) >>> n = x >>> LENGTH('a)"
   apply (rule bit_word_eqI)
   using assms
   apply (auto simp add: bit_simps bit_last_iff)
   done
 
 text\<open>
 Like @{thm shiftr1_bl_of}, but the precondition is stronger because we need to pick the msb out of
 the list.
 \<close>
 lemma sshiftr1_bl_of:
   "length bl = LENGTH('a) \<Longrightarrow>
     sshiftr1 (of_bl bl::'a::len word) = of_bl (hd bl # butlast bl)"
   apply (rule word_bl.Rep_eqD)
   apply (subst bl_sshiftr1[of "of_bl bl :: 'a word"])
   by (simp add: word_bl.Abs_inverse)
 
 text\<open>
 Like @{thm sshiftr1_bl_of}, with a weaker precondition.
 We still get a direct equation for @{term \<open>sshiftr1 (of_bl bl)\<close>}, it's just uglier.
 \<close>
 lemma sshiftr1_bl_of':
   "LENGTH('a) \<le> length bl \<Longrightarrow>
     sshiftr1 (of_bl bl::'a::len word) =
     of_bl (hd (drop (length bl - LENGTH('a)) bl) # butlast (drop (length bl - LENGTH('a)) bl))"
   apply (subst of_bl_drop'[symmetric, of "length bl - LENGTH('a)"])
   using sshiftr1_bl_of[of "drop (length bl - LENGTH('a)) bl"]
   by auto
 
 text\<open>
 Like @{thm shiftr_bl_of}.
 \<close>
 lemma sshiftr_bl_of:
   assumes "length bl = LENGTH('a)"
   shows "(of_bl bl::'a::len word) >>> n = of_bl (replicate n (hd bl) @ take (length bl - n) bl)"
 proof -
   from assms obtain b bs where \<open>bl = b # bs\<close>
     by (cases bl) simp_all
   then have *: \<open>bl ! 0 \<longleftrightarrow> b\<close> \<open>hd bl \<longleftrightarrow> b\<close>
     by simp_all
   show ?thesis
   apply (rule bit_word_eqI)
     using assms * by (auto simp add: bit_simps nth_append rev_nth not_less)
 qed
 
 text\<open>Like @{thm shiftr_bl}\<close>
 lemma sshiftr_bl: "x >>> n \<equiv> of_bl (replicate n (msb x) @ take (LENGTH('a) - n) (to_bl x))"
   for x :: "'a::len word"
   unfolding word_msb_alt
   by (smt (z3) length_to_bl_eq sshiftr_bl_of word_bl.Rep_inverse)
 
 end
 
 lemma of_bl_drop_eq_take_bit:
   \<open>of_bl (drop n xs) = take_bit (length xs - n) (of_bl xs)\<close>
   by (simp add: of_bl_drop take_bit_eq_mask)
 
 lemma of_bl_take_to_bl_eq_drop_bit:
   \<open>of_bl (take n (to_bl w)) = drop_bit (LENGTH('a) - n) w\<close>
     if \<open>n \<le> LENGTH('a)\<close>
     for w :: \<open>'a::len word\<close>
   using that shiftr_bl [of w \<open>LENGTH('a) - n\<close>] by (simp add: shiftr_def)
 
 end