diff --git a/thys/Padic_Field/Cring_Multivariable_Poly.thy b/thys/Padic_Field/Cring_Multivariable_Poly.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Cring_Multivariable_Poly.thy
@@ -0,0 +1,8548 @@
+theory Cring_Multivariable_Poly
+imports  "HOL-Algebra.Indexed_Polynomials" Padic_Ints.Cring_Poly 
+begin 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Multivariable Polynomials Over a Commutative Ring\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  This theory extends the content of \texttt{HOL-Algebra.Indexed\_Polynomials}, mainly in the 
+  context of a commutative base ring. In particular, the ring of polynomials over an arbitrary 
+  variable set is explicitly witnessed as a ring itself, which is commutative if the base is
+  commutative, and a domain if the base ring is a domain. A universal property for polynomial 
+  evaluation is proved, which allows us to embed polynomial rings in a ring of functions over the 
+  base ring, as well as construe multivariable polynomials as univariate polynomials over a small
+  base polynomial ring.
+\<close>
+
+type_synonym 'a monomial = "'a multiset"
+type_synonym ('b,'a) mvar_poly = "'a multiset \<Rightarrow> 'b"
+type_synonym ('a,'b) ring_hom = "'a \<Rightarrow> 'b"
+type_synonym 'a u_poly = "nat \<Rightarrow> 'a"
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Lemmas about multisets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  Since multisets function as monomials in this formalization, we'll need some simple lemmas 
+  about multisets in order to define degree functions and certain lemmas about factorizations.
+  Those are provided in this section.
+\<close>
+
+lemma count_size:                       
+  assumes "size m \<le> K"
+  shows "count m i \<le> K"
+  using assms 
+  by (metis count_le_replicate_mset_subset_eq dual_order.trans order_refl size_mset_mono size_replicate_mset)
+
+text\<open>The following defines the set of monomials with nonzero coefficients for a given polynomial:\<close>
+
+definition monomials_of :: "('a,'c) ring_scheme \<Rightarrow> ('a, 'b) mvar_poly \<Rightarrow> ('b monomial) set" where
+"monomials_of R P = {m. P m \<noteq> \<zero>\<^bsub>R\<^esub>}"
+
+context ring 
+begin 
+
+lemma monomials_of_index_free:
+  assumes "index_free P i"
+  assumes "m \<in> monomials_of R P"
+  shows "count m i = 0"
+  using assms  
+  unfolding monomials_of_def index_free_def 
+  by (meson count_inI mem_Collect_eq)
+
+lemma index_freeI:
+  assumes "\<And>m. m \<in> monomials_of R P \<Longrightarrow> count m i = 0"
+  shows "index_free P i"
+  unfolding index_free_def
+proof safe
+  fix m
+  assume "i \<in># m"
+  then have "count m i \<noteq> 0"
+    by simp
+  then have "m \<notin> monomials_of R P"
+    using assms 
+    by meson
+  then show "P m = \<zero>"
+    unfolding monomials_of_def 
+    by blast
+qed
+
+text\<open>\texttt{monomials\_of} R is subadditive\<close>
+
+lemma monomials_of_add:
+"monomials_of R (P \<Oplus> Q) \<subseteq> (monomials_of R P) \<union> (monomials_of R Q)"
+proof
+  fix x
+  assume "x \<in> monomials_of R (P \<Oplus> Q) "
+  then have "P x \<oplus> Q x \<noteq>\<zero>"
+    by (simp add: indexed_padd_def monomials_of_def)
+  then have "P x \<noteq>\<zero> \<or> Q x \<noteq> \<zero>"
+    by auto
+  then show "x \<in> (monomials_of R P) \<union> (monomials_of R Q)" 
+    by (simp add: monomials_of_def)
+qed
+
+lemma monomials_of_add_finite:
+  assumes "finite (monomials_of R P)"
+  assumes "finite (monomials_of R Q)"
+  shows "finite (monomials_of R (P \<Oplus> Q))"
+  by (meson assms(1) assms(2) finite_Un finite_subset monomials_of_add)
+
+lemma monomials_ofE:
+  assumes "m \<in> monomials_of R p"
+  shows "p m \<noteq> \<zero>"
+  using assms 
+  unfolding monomials_of_def 
+  by simp 
+
+lemma complement_of_monomials_of:
+  assumes "m \<notin> monomials_of R P"
+  shows "P m = \<zero>"
+  using assms  
+  unfolding monomials_of_def
+  by blast 
+
+text\<open>Multiplication by an indexed variable corresponds to adding that index to each monomial:\<close>
+
+lemma monomials_of_p_mult:
+"monomials_of R (P \<Otimes> i) = {m. \<exists> n \<in> (monomials_of R P). m = add_mset i n}"
+proof
+  show "monomials_of R (P \<Otimes> i) \<subseteq> {m. \<exists>n\<in>monomials_of R P. m = add_mset i n}"
+    proof
+      fix m
+      assume A: "m \<in> monomials_of R (P \<Otimes> i)"
+      show "m \<in> {m. \<exists>n\<in>monomials_of R P. m = add_mset i n}"
+      proof-
+        have "(P \<Otimes> i) m \<noteq> \<zero>"
+          by (simp add: A monomials_ofE)
+        then have "P (m - {# i #}) \<noteq>\<zero>"
+          unfolding indexed_pmult_def 
+          by presburger
+        then have 0: "(m - {# i #}) \<in> monomials_of R P"
+          by (meson complement_of_monomials_of)
+        have 1: " m = add_mset i  (m - {# i #})"
+          by (metis \<open>(P \<Otimes> i) m \<noteq> \<zero>\<close> add_mset_remove_trivial_If indexed_pmult_def)
+        then show ?thesis using 0 1
+          by blast
+      qed
+    qed
+  show "{m. \<exists>n\<in>monomials_of R P. m = add_mset i n} \<subseteq> monomials_of R (P \<Otimes> i)"
+    unfolding monomials_of_def indexed_pmult_def 
+    by auto
+qed
+
+lemma monomials_of_p_mult':
+"monomials_of R (p \<Otimes> i) = add_mset i ` (monomials_of R p)"
+  using  monomials_of_p_mult
+  by (simp add: monomials_of_p_mult image_def)
+
+lemma monomials_of_p_mult_finite:
+  assumes "finite (monomials_of R P)"
+  shows "finite (monomials_of R (P \<Otimes> i))"
+  using assms monomials_of_p_mult'[of P i]
+  by simp
+
+text\<open>Monomials of a constant either consist of the empty multiset, or nothing:\<close>
+
+lemma monomials_of_const: 
+"(monomials_of R (indexed_const k)) = (if (k = \<zero>) then {} else {{#}})"
+  unfolding monomials_of_def indexed_const_def 
+  by simp
+
+lemma monomials_of_const_finite: 
+"finite (monomials_of R (indexed_const k))"
+  by (simp add: monomials_of_const)
+  
+text\<open>A polynomial always has finitely many monomials:\<close>
+lemma monomials_finite:
+  assumes "P \<in> indexed_pset K I"
+  shows "finite (monomials_of R P)"
+  using assms 
+  apply(induction P)
+  using monomials_of_const_finite apply blast
+    using monomials_of_add_finite apply blast
+      by (simp add: monomials_of_p_mult_finite)
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+    subsection\<open>Turning monomials into polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+ 
+text\<open>Constructor for turning a monomial into a polynomial\<close>
+
+definition mset_to_IP :: "('a, 'b) ring_scheme \<Rightarrow> 'c monomial \<Rightarrow> ('a,'c) mvar_poly" where
+"mset_to_IP R m n= (if (n = m) then \<one>\<^bsub>R\<^esub> else \<zero>\<^bsub>R\<^esub>)" 
+
+definition var_to_IP :: "('a, 'b) ring_scheme \<Rightarrow> 'c \<Rightarrow> ('a,'c) mvar_poly" ("pvar") where
+"var_to_IP R i = mset_to_IP R {#i#}"
+
+context ring
+begin
+
+lemma mset_to_IP_simp[simp]:
+"mset_to_IP R m m = \<one>"
+  by (simp add: mset_to_IP_def)
+
+lemma mset_to_IP_simp'[simp]:
+  assumes "n \<noteq>m"
+  shows "mset_to_IP R m n = \<zero>"
+  by (simp add: assms mset_to_IP_def)
+
+lemma(in cring) monomials_of_mset_to_IP:
+  assumes "\<one> \<noteq>\<zero>"
+  shows "monomials_of R (mset_to_IP R m) = {m}"
+  unfolding monomials_of_def mset_to_IP_def 
+proof
+  show "{ma. (if ma = m then \<one> else \<zero>) \<noteq> \<zero>} \<subseteq> {m}"
+    by auto
+  show "{m} \<subseteq> {ma. (if ma = m then \<one> else \<zero>) \<noteq> \<zero>}"
+    using assms by auto
+qed
+
+end 
+
+text\<open>The set of monomials of a fixed \<open>P\<close> which include a given variable:\<close>
+
+definition monomials_with :: "('a, 'b) ring_scheme \<Rightarrow> 'c \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> ('c monomial) set" where
+"monomials_with R i P = {m. m \<in> monomials_of R P \<and> i \<in># m}"
+
+context ring
+begin
+
+lemma monomials_withE:
+  assumes "m \<in> monomials_with R i P"
+  shows "i \<in># m"
+        "m \<in> monomials_of R P"
+  using assms unfolding monomials_with_def  
+  apply blast
+     using assms unfolding monomials_with_def  
+     by blast
+
+lemma monomials_withI:
+  assumes "i \<in># m"
+  assumes "m \<in> monomials_of R P"
+  shows "m \<in> monomials_with R i P"
+  using assms 
+  unfolding monomials_with_def 
+  by blast 
+
+end 
+
+text\<open>Restricting a polynomial to be zero outside of a given monomial set:\<close>
+
+definition restrict_poly_to_monom_set :: 
+  "('a, 'b) ring_scheme \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> ('c monomial) set \<Rightarrow>('a,'c) mvar_poly"  where
+"restrict_poly_to_monom_set R P m_set m = (if m \<in> m_set then P m else \<zero>\<^bsub>R\<^esub>)"
+
+context ring
+begin
+
+lemma restrict_poly_to_monom_set_coeff:
+  assumes "carrier_coeff P"
+  shows "carrier_coeff (restrict_poly_to_monom_set R P Ms)"
+  by (metis assms carrier_coeff_def restrict_poly_to_monom_set_def zero_closed)
+
+lemma restrict_poly_to_monom_set_coeff':
+  assumes "P \<in> indexed_pset K I"
+  assumes "I \<noteq> {}"
+  assumes "\<And>m. P m \<in> S"
+  assumes "\<zero> \<in> S"
+  shows "\<And>m.  (restrict_poly_to_monom_set R P m_set m) \<in> S"
+  using assms 
+  unfolding restrict_poly_to_monom_set_def
+  by simp
+
+lemma restrict_poly_to_monom_set_monoms:
+  assumes "P \<in> indexed_pset I K"
+  assumes "m_set \<subseteq> monomials_of R P"
+  shows "monomials_of R (restrict_poly_to_monom_set R P m_set) = m_set"
+  using assms 
+  unfolding monomials_of_def restrict_poly_to_monom_set_def
+  by (simp add: subset_iff)
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Degree Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+  (**************************************************************************************************)
+  (**************************************************************************************************)
+  subsubsection\<open>Total Degree Function\<close>
+  (**************************************************************************************************)
+  (**************************************************************************************************)
+
+
+lemma multi_set_size_count:
+  fixes m :: "'c monomial"
+  shows "size m \<ge> count m i"
+  by (metis count_le_replicate_mset_subset_eq order_refl size_mset_mono size_replicate_mset)
+
+text\<open>Total degree function\<close>
+
+definition total_degree :: "('a, 'b) ring_scheme \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> nat" where
+"total_degree R P = (if (monomials_of R P = {}) then 0 else Max (size ` (monomials_of R P)))"
+
+context ring
+begin
+
+lemma total_degree_ineq:
+  assumes "m \<in> monomials_of R P"
+  assumes "finite (monomials_of R P)"
+  shows "total_degree R P \<ge> size m"
+  unfolding total_degree_def using assms   
+  by force
+
+lemma total_degree_in_monomials_of:
+  assumes "monomials_of R P \<noteq> {}"
+  assumes "finite (monomials_of R P)"
+  obtains m where "m \<in> monomials_of R P \<and> size m = total_degree R P"
+    using assms Max_in[of "(size ` monomials_of R P)"] unfolding total_degree_def  
+    by (metis (mono_tags, lifting) empty_is_image finite_imageI image_iff)
+
+lemma total_degreeI:
+  assumes "finite (monomials_of R P)"
+  assumes "\<exists>m. m \<in> monomials_of R P \<and> size m = n"
+  assumes "\<And>m. m \<in> monomials_of R P \<Longrightarrow> size m \<le> n"
+  shows "n = total_degree R P"
+proof(cases "monomials_of R P = {}")
+  case True
+  then show ?thesis 
+    using assms by blast  
+next
+  case False
+  obtain m where m_def: "m \<in> monomials_of R P \<and> size m = n"
+    using assms by blast 
+  have 0: "n \<in> (size ` (monomials_of R P))"
+    using m_def
+    by blast
+  have "\<And>k. k \<in> (size ` (monomials_of R P)) \<Longrightarrow> k \<le> n"
+    using assms 
+    by blast
+  then have 1: "\<And>m.  m \<in> (monomials_of R P) \<Longrightarrow> size m\<le> n"
+    by blast
+  obtain m' where m'_def: "m' \<in> monomials_of R P \<and> size m' = total_degree R P"
+    using assms total_degree_in_monomials_of
+    by blast
+  then have 2: "size m' \<le> n"
+    using 1 
+    by blast
+  have 3: "n \<le>size m'"
+    using assms m'_def total_degree_ineq by auto
+  show ?thesis using 2 3 
+    using dual_order.antisym m'_def by blast
+qed  
+end 
+
+  (**************************************************************************************************)
+  (**************************************************************************************************)
+  subsubsection\<open>Degree in One Variable\<close>
+  (**************************************************************************************************)
+  (**************************************************************************************************)
+
+definition degree_in_var ::
+  "('a, 'b) ring_scheme \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> 'c \<Rightarrow> nat" where
+"degree_in_var R P i =  (if (monomials_of R P = {}) then 0 else Max ((\<lambda>m. count m i) ` (monomials_of R P)))"
+
+context ring
+begin
+
+lemma degree_in_var_ineq:
+  assumes "m \<in> monomials_of R P"
+  assumes "finite (monomials_of R P)"
+  shows "degree_in_var R P i \<ge> count m i"
+  unfolding degree_in_var_def using assms   
+  by force
+
+lemma degree_in_var_in_monomials_of:
+  assumes "monomials_of R P \<noteq> {}"
+  assumes "finite (monomials_of R P)"
+  obtains m where "m \<in> monomials_of R P \<and> count m i = degree_in_var R P i"
+  using assms Max_in[of "((\<lambda>m. count m i) ` (monomials_of R P))"] unfolding degree_in_var_def
+  by (metis (no_types, lifting) empty_is_image finite_imageI image_iff)
+
+lemma degree_in_varI:
+  assumes "finite (monomials_of R P)"
+  assumes "\<exists>m. m \<in> monomials_of R P \<and> count m i = n"
+  assumes "\<And>c. c \<in> monomials_of R P \<Longrightarrow> count c i \<le> n"
+  shows "n = degree_in_var R P i"
+proof-
+  obtain l where l_def: "l \<in> monomials_of R P \<and> count l i = degree_in_var R P i"
+    by (metis assms(1) assms(2) degree_in_var_in_monomials_of equals0D)
+  have "degree_in_var R P i \<le> n"
+    using assms(3) l_def 
+    by force
+  then show ?thesis 
+    using assms(1) assms(2) dual_order.antisym degree_in_var_ineq 
+    by fastforce  
+qed
+
+text\<open>Total degree bounds degree in a single variable:\<close>
+
+lemma total_degree_degree_in_var:
+  assumes "finite (monomials_of R P)"
+  shows "total_degree R P \<ge> degree_in_var R P i"
+proof(cases " (monomials_of R P) = {}")
+  case True
+  then show ?thesis 
+    unfolding total_degree_def degree_in_var_def 
+    by simp
+next
+  case False
+  then   obtain m1 where m1_def: "m1 \<in> monomials_of R P \<and> count m1 i = degree_in_var R P i"
+    by (meson assms degree_in_var_in_monomials_of)
+  have "size m1 \<ge>count m1 i"
+    by (simp add: multi_set_size_count)
+  then show ?thesis 
+    by (simp add: assms local.ring_axioms m1_def order.trans ring.total_degree_ineq)
+qed
+end 
+
+text\<open>The set of monomials of maximal degree in variable \<open>i\<close>:\<close>
+
+definition max_degree_monoms_in_var :: 
+  "('a, 'b) ring_scheme \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> 'c \<Rightarrow> ('c monomial) set" where
+"max_degree_monoms_in_var R P i = {m. m \<in> monomials_of R P \<and> count m i = degree_in_var R P i}"
+
+context ring
+begin
+
+lemma max_degree_monoms_in_var_memI:
+  assumes "m \<in> monomials_of R P"
+  assumes "count m i = degree_in_var R P i"
+  shows "m \<in> max_degree_monoms_in_var R P i"
+  using assms unfolding max_degree_monoms_in_var_def 
+  by blast
+
+lemma max_degree_monoms_in_var_memE:
+  assumes "m \<in> max_degree_monoms_in_var R P i"
+  shows   "m \<in> monomials_of R P"
+          "count m i = degree_in_var R P i"
+  using assms unfolding max_degree_monoms_in_var_def 
+  apply blast
+    using assms unfolding max_degree_monoms_in_var_def 
+    by blast
+end 
+
+text\<open>The set of monomials of \<open>P\<close> of fixed degree in variable \<open>i\<close>:\<close> 
+
+definition fixed_degree_in_var ::
+  "('a, 'b) ring_scheme \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> 'c \<Rightarrow> nat \<Rightarrow> ('c monomial) set" where
+"fixed_degree_in_var R P i n = {m. m \<in> monomials_of R P \<and> count m i = n}"
+
+context ring 
+begin
+
+lemma fixed_degree_in_var_subset:
+"fixed_degree_in_var R P i n \<subseteq> monomials_of R P"
+  unfolding fixed_degree_in_var_def 
+  by blast
+
+lemma fixed_degree_in_var_max_degree_monoms_in_var:
+"max_degree_monoms_in_var R P i = fixed_degree_in_var R P i (degree_in_var R P i)"
+  unfolding max_degree_monoms_in_var_def fixed_degree_in_var_def 
+  by auto
+
+lemma fixed_degree_in_varI:
+  assumes "m \<in> monomials_of R P"
+  assumes "count m i = n"
+  shows "m \<in> fixed_degree_in_var R P i n"
+  unfolding fixed_degree_in_var_def 
+  using assms 
+  by blast 
+
+lemma fixed_degree_in_varE:
+  assumes "m \<in> fixed_degree_in_var R P i n"
+  shows "m \<in> monomials_of R P"
+          "count m i = n"
+  apply (meson assms fixed_degree_in_var_subset in_mono)
+    using assms fixed_degree_in_var_def by force
+
+definition restrict_to_var_deg ::
+ "('a,'c) mvar_poly \<Rightarrow> 'c \<Rightarrow> nat \<Rightarrow> 'c monomial \<Rightarrow> 'a"  where
+"restrict_to_var_deg P i n = restrict_poly_to_monom_set R P (fixed_degree_in_var R P i n)"
+
+lemma restrict_to_var_deg_var_deg:
+  assumes "finite (monomials_of R P)"
+  assumes "Q = restrict_to_var_deg P i n"
+  assumes "monomials_of R Q \<noteq> {}"
+  shows "n = degree_in_var R Q i"
+  apply(rule degree_in_varI)
+    apply (metis assms(1) assms(2) fixed_degree_in_varE(1) monomials_ofE restrict_poly_to_monom_set_def 
+      restrict_to_var_deg_def rev_finite_subset subsetI)
+      apply (metis (full_types) assms(2) assms(3) equals0I fixed_degree_in_varE(2)
+      monomials_ofE restrict_poly_to_monom_set_def restrict_to_var_deg_def)
+        by (metis assms(2) eq_iff fixed_degree_in_varE(2) monomials_ofE restrict_poly_to_monom_set_def restrict_to_var_deg_def)
+
+lemma index_free_degree_in_var[simp]:
+  assumes "index_free P i"
+  shows "degree_in_var R P i = 0"
+proof(cases "monomials_of R P = {}")
+  case True
+  then show ?thesis 
+    using assms 
+    unfolding degree_in_var_def 
+    by simp
+next
+  case False
+  then have 0: "degree_in_var R P i =  Max ((\<lambda>m. count m i) ` (monomials_of R P))"
+    unfolding degree_in_var_def 
+    by simp 
+  have"((\<lambda>m. count m i) ` (monomials_of R P)) = {0}"
+  proof
+    show "(\<lambda>m. count m i) ` monomials_of R P \<subseteq> {0}"
+      using False assms monomials_of_index_free[of P i] 
+      by auto
+    show "{0} \<subseteq> (\<lambda>m. count m i) ` monomials_of R P" 
+      using False  \<open>(\<lambda>m. count m i) ` monomials_of R P \<subseteq> {0}\<close> 
+      by auto
+  qed
+  then show ?thesis using 0 
+    by simp
+qed
+
+lemma degree_in_var_index_free:
+  assumes "degree_in_var R P i = 0"
+  assumes "finite (monomials_of R P)"
+  shows "index_free P i" 
+  apply(rule index_freeI)
+  by (metis assms(1) assms(2) degree_in_var_ineq le_zero_eq)
+
+end 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Constructing the Multiplication Operation on the Ring of Indexed Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsubsection\<open>The Set of Factors of a Fixed Monomial\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+
+  text\<open>The following function maps a monomial to the set of monomials which divide it:\<close>
+
+definition mset_factors :: "'c monomial \<Rightarrow> ('c monomial) set" where
+"mset_factors m = {n. n \<subseteq># m}"
+
+context ring 
+begin
+
+lemma monom_divides_factors:
+"n \<in> (mset_factors m)\<longleftrightarrow> n \<subseteq># m"
+  unfolding mset_factors_def by auto 
+
+lemma mset_factors_mono:
+  assumes "n \<subseteq># m"
+  shows "mset_factors n \<subseteq> mset_factors m"
+  unfolding mset_factors_def 
+  by (simp add: Collect_mono_iff assms subset_mset.order_trans)
+
+lemma mset_factors_size_bound:
+  assumes "n \<in> mset_factors m"
+  shows "size n \<le> size m"
+  using assms 
+  unfolding mset_factors_def 
+  by (simp add: size_mset_mono)
+
+lemma sets_to_inds_finite:
+  assumes "finite I"
+  shows "finite S \<Longrightarrow> finite (Pi\<^sub>E S (\<lambda>_. I))"
+  using assms 
+  by (simp add: finite_PiE)
+
+end
+
+    (**********************************************************************************************)
+    (**********************************************************************************************)
+    subsubsection\<open>Finiteness of the Factor Set of a Monomial\<close>
+    (**********************************************************************************************)
+    (**********************************************************************************************)
+
+text\<open>
+  This section shows that any monomial m has only finitely many factors. This is done by mapping
+  the set of factors injectively into a finite extensional function set. Explicitly, a monomial is 
+  just mapped to its count function, restricted to the set of indices where the count is nonzero.
+\<close>
+
+definition mset_factors_to_fun ::
+  "('a,'b) ring_scheme \<Rightarrow> 'c monomial \<Rightarrow> 'c monomial \<Rightarrow> ('c \<Rightarrow> nat)" where
+"mset_factors_to_fun R m n = (if (n \<in> mset_factors m) then 
+                                           (restrict  (count n) (set_mset m)) else undefined)"
+context ring 
+begin
+
+lemma mset_factors_to_fun_prop:
+  assumes "size m = n"
+  shows "mset_factors_to_fun R m \<in> (mset_factors m) \<rightarrow> (Pi\<^sub>E (set_mset m) (\<lambda>_. {0.. n}))"
+proof
+  fix x 
+  assume A: "x \<in> (mset_factors m)"
+  show "mset_factors_to_fun R m x \<in> (set_mset m) \<rightarrow>\<^sub>E {0..n} "    
+  proof
+    show "\<And>xa. xa \<in># m \<Longrightarrow> mset_factors_to_fun R m x xa \<in> {0..n}"
+      proof-
+        fix y
+        assume Ay: "y \<in># m"
+        show P0: "mset_factors_to_fun R m x y \<in> {0..n}"
+        proof-
+          have "mset_factors_to_fun R m x = restrict (count x) (set_mset m)"
+            using A  unfolding mset_factors_to_fun_def
+            by simp
+          then have "mset_factors_to_fun R m x y  = count x y"
+            using Ay 
+            by simp        
+          then show ?thesis
+            using A INTEG.R.mset_factors_size_bound assms count_size by fastforce             
+        qed
+      qed
+    fix z
+    assume Ay: "z \<notin>#m"
+    show "mset_factors_to_fun R m x z = undefined"
+      using A Ay unfolding mset_factors_to_fun_def  
+      by simp
+  qed 
+qed
+
+lemma mset_factors_to_fun_inj:
+  shows "inj_on (mset_factors_to_fun R m) (mset_factors m) "
+proof
+  fix x y
+  assume A: "x \<in> mset_factors m" "y \<in> mset_factors m"
+  show "mset_factors_to_fun R m x = mset_factors_to_fun R m y \<Longrightarrow> x = y"
+  proof-
+    assume A0:  "mset_factors_to_fun R m x = mset_factors_to_fun R m y"
+    show " x = y"
+    proof-
+      have "\<And>i. count x i = count y i"
+      proof- fix i
+        show "count x i = count y i"
+        proof(cases "i \<in># m")
+          case True
+          then show ?thesis using A0 A unfolding mset_factors_to_fun_def  
+            by (metis restrict_def)
+        next
+          case False
+          then show ?thesis 
+             using A0 A unfolding mset_factors_to_fun_def
+             by (metis monom_divides_factors count_inI mset_subset_eqD)
+        qed
+      qed
+      then show ?thesis 
+        using multiset_eqI by blast
+    qed
+  qed
+qed
+
+lemma finite_target:
+"finite (Pi\<^sub>E (set_mset m) (\<lambda>_. {0..(n::nat)}))"
+proof-
+  have 0: "finite (set_mset m)"
+    by simp 
+  have 1: "finite ({0..n})"
+    by simp
+  then show ?thesis using 0 
+    by (simp add: finite_PiE)
+qed
+
+text\<open>A multiset has only finitely many factors:\<close>
+
+lemma mset_factors_finite[simp]:
+"finite (mset_factors m)"
+proof-
+  have 0: "inj_on (mset_factors_to_fun R m) (mset_factors m) "
+    by (simp add: mset_factors_to_fun_inj)
+  have 1: "(mset_factors_to_fun R m) \<in> (mset_factors m) \<rightarrow> (Pi\<^sub>E (set_mset m) (\<lambda>_. {0 .. (size m)}))"
+    by (metis mset_factors_to_fun_prop)
+  have 2: "finite (Pi\<^sub>E (set_mset m) (\<lambda>_. {0 .. (size m)}))"
+    by (simp add: finite_target)
+  have 3: "((mset_factors_to_fun R m) ` (mset_factors m)) \<subseteq> (Pi\<^sub>E (set_mset m) (\<lambda>_. {0 .. (size m)}))"
+    using 1 2 
+    by blast
+  then have "finite ((mset_factors_to_fun R m) ` (mset_factors m))"
+    using 2 finite_subset by auto    
+  then show ?thesis using 0 1 2
+    finite_imageD[of "mset_factors_to_fun R m" "mset_factors m" ] 
+    by blast
+qed
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Definition of Indexed Polynomial Multiplication.\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context ring 
+begin
+
+text\<open>Monomial division:\<close>
+
+lemma monom_divide:
+  assumes "n \<in> mset_factors m"
+  shows "(THE k. n + k = m ) = m - n "
+  apply(rule the_equality)
+  using assms unfolding mset_factors_def  
+  apply simp
+    using assms unfolding mset_factors_def  
+    by auto
+
+text\<open>A monomial is a factor of itself:\<close>
+
+lemma m_factor[simp]:
+"m \<in> mset_factors m"
+  using local.ring_axioms ring.monom_divides_factors by blast
+
+end 
+
+text\<open>The definition of polynomial multiplication:\<close>
+
+definition P_ring_mult :: "('a, 'b) ring_scheme \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> 'c monomial \<Rightarrow> 'a"
+  where
+"P_ring_mult R P Q m = (finsum R (\<lambda>x. (P x) \<otimes>\<^bsub>R\<^esub> (Q (m - x))) (mset_factors m))"
+
+abbreviation(in ring) P_ring_mult_in_ring (infixl "\<Otimes>\<^sub>p" 65)where
+"P_ring_mult_in_ring \<equiv>  P_ring_mult R"
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Distributivity Laws for Polynomial Multiplication\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context ring 
+begin 
+
+lemma P_ring_rdistr:
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  shows "a \<Otimes>\<^sub>p (b \<Oplus> c) = (a \<Otimes>\<^sub>p b)\<Oplus> (a \<Otimes>\<^sub>p c)"
+proof
+  fix m
+  show "(a \<Otimes>\<^sub>p (b \<Oplus> c)) m = (a \<Otimes>\<^sub>p b \<Oplus> (a \<Otimes>\<^sub>p c)) m"
+  proof-
+    have RHS: "(a \<Otimes>\<^sub>p b \<Oplus> (a \<Otimes>\<^sub>p c)) m = 
+                  (\<Oplus>x\<in>mset_factors m. a x \<otimes> b (m - x)) \<oplus> (\<Oplus>x\<in>mset_factors m. a x \<otimes> c (m - x))"
+      unfolding indexed_padd_def P_ring_mult_def by auto 
+    have LHS: "(a \<Otimes>\<^sub>p (b \<Oplus> c)) m= 
+                  ( \<Oplus>x\<in>mset_factors m. a x \<otimes> b (m - x) \<oplus> a x \<otimes> c (m - x))"
+      unfolding indexed_padd_def  P_ring_mult_def 
+      by (meson assms(1) assms(2) assms(3) local.ring_axioms r_distr ring.carrier_coeff_def)
+    have RHS': "(a \<Otimes>\<^sub>p b \<Oplus> (a \<Otimes>\<^sub>p c)) m = 
+                  (\<Oplus>x\<in>mset_factors m. a x \<otimes> b (m - x) \<oplus> a x \<otimes> c (m - x))"
+    proof-
+      have 0: "(\<lambda>x. a x \<otimes> b (m - x)) \<in> mset_factors m \<rightarrow> carrier R"
+      proof
+        fix x assume "x \<in> mset_factors m"
+        then show "a x \<otimes> b (m - x) \<in> carrier R"
+          using assms carrier_coeffE 
+          by blast
+      qed
+      have 1: "(\<lambda>x. a x \<otimes> c (m - x)) \<in> mset_factors m \<rightarrow> carrier R"
+      proof
+        fix x assume "x \<in> mset_factors m"
+        then show "a x \<otimes> c (m - x) \<in> carrier R"
+          using assms carrier_coeffE 
+          by blast 
+      qed
+      then show ?thesis 
+        using 0 1 RHS assms finsum_addf[of "\<lambda>x. a x \<otimes> b (m - x)" "mset_factors m"
+                                                    "\<lambda>x. a x \<otimes> c (m - x)"]
+        by metis  
+    qed
+    show ?thesis using LHS RHS' by auto 
+  qed
+qed
+
+lemma P_ring_ldistr:
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  shows "  (b \<Oplus> c) \<Otimes>\<^sub>p  a = (b \<Otimes>\<^sub>p a)\<Oplus> (c \<Otimes>\<^sub>p a)"
+proof
+  fix m
+  show "((b \<Oplus> c) \<Otimes>\<^sub>p  a) m = ((b \<Otimes>\<^sub>p a)\<Oplus> (c \<Otimes>\<^sub>p a)) m"
+  proof-
+    have RHS: "((b \<Otimes>\<^sub>p a)\<Oplus> (c \<Otimes>\<^sub>p a)) m = 
+                  (\<Oplus>x\<in>mset_factors m. b x \<otimes> a (m - x)) \<oplus> (\<Oplus>x\<in>mset_factors m. c x \<otimes> a (m - x))"
+      unfolding indexed_padd_def P_ring_mult_def by auto 
+    have LHS: "((b \<Oplus> c) \<Otimes>\<^sub>p  a)  m= 
+                  ( \<Oplus>x\<in>mset_factors m. b x \<otimes> a (m - x) \<oplus> c x \<otimes> a (m - x))"
+      unfolding indexed_padd_def  P_ring_mult_def 
+      by (meson assms(1) assms(2) assms(3) l_distr local.ring_axioms ring.carrier_coeff_def)
+    have RHS': "((b \<Otimes>\<^sub>p a)\<Oplus> (c \<Otimes>\<^sub>p a)) m = 
+                  (\<Oplus>x\<in>mset_factors m. b x \<otimes> a (m - x) \<oplus> c x \<otimes> a (m - x))"
+    proof-
+      have 0: "(\<lambda>x. b x \<otimes> a (m - x)) \<in> mset_factors m \<rightarrow> carrier R"
+      proof
+        fix x assume "x \<in> mset_factors m"
+        then show "b x \<otimes> a (m - x) \<in> carrier R"
+          using assms carrier_coeffE 
+          by blast
+      qed
+      have 1: "(\<lambda>x. c x \<otimes> a (m - x)) \<in> mset_factors m \<rightarrow> carrier R"
+      proof
+        fix x assume "x \<in> mset_factors m"
+        then show "c x \<otimes> a (m - x) \<in> carrier R"
+          using assms carrier_coeffE 
+          by blast 
+      qed
+      then show ?thesis 
+        using 0 1 RHS assms finsum_addf[of "\<lambda>x. b x \<otimes> a (m - x)" "mset_factors m"
+                                                    "\<lambda>x. c x \<otimes> a (m - x)"]
+        by metis  
+    qed
+    show ?thesis using LHS RHS' by auto 
+  qed
+qed
+end 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Multiplication Commutes with \texttt{indexed\_pmult}\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context ring
+begin
+
+text\<open>This lemma shows how we can write the factors of a monomial $m$ times a variable $i$ in terms
+      of the factors of m:\<close>
+
+lemma mset_factors_add_mset:
+"mset_factors (add_mset i m) = mset_factors m \<union> add_mset i ` (mset_factors m)"
+proof
+  show "mset_factors (add_mset i m) \<subseteq> mset_factors m \<union> add_mset i ` mset_factors m"
+  proof fix x
+    assume A: "x \<in> mset_factors (add_mset i m)"
+    show "x \<in> mset_factors m \<union> add_mset i ` mset_factors m" 
+    proof(cases "i \<in># x")
+      case True
+      then have "x - {#i#} \<subseteq># m"
+        using A INTEG.R.monom_divides_factors subset_eq_diff_conv by force
+      then show ?thesis 
+        by (metis INTEG.R.monom_divides_factors True UnI2 add_mset_remove_trivial image_iff multi_member_split)
+    next
+      case False
+      have 0: "x \<subseteq># add_mset i m"
+        using A INTEG.R.monom_divides_factors by blast
+      hence "x \<subseteq>#  m" 
+        using mset_subset_eqI[of x m] 0 False 
+        by (metis count_add_mset count_greater_zero_iff count_inI less_Suc_eq_le 
+            subseteq_mset_def union_single_eq_member)
+      thus ?thesis 
+        using INTEG.R.monom_divides_factors by blast
+    qed
+  qed
+  show "mset_factors m \<union> add_mset i ` mset_factors m \<subseteq> mset_factors (add_mset i m)"
+  proof fix x assume A: "x \<in> mset_factors m \<union> add_mset i ` mset_factors m"
+    have "x \<subseteq># add_mset i m"
+    proof(cases "x \<in> mset_factors m")
+      case True
+      then have "x \<subseteq># m"
+        by (simp add: INTEG.R.monom_divides_factors)
+      hence "(\<And>a. count x a \<le> count (add_mset i m) a)"
+        using mset_subset_eq_count[of x m] count_add_mset[of i m] 
+              nat_le_linear not_less_eq_eq by fastforce
+      thus ?thesis 
+        using mset_subset_eqI by blast          
+    next
+      case False
+      then obtain n where n_def: "n \<in> mset_factors m \<and> x = add_mset i n"
+        using A by blast
+      then have "x \<subseteq># add_mset i m"
+        by (simp add: INTEG.R.monom_divides_factors)
+      then show ?thesis 
+        by simp
+    qed
+    thus "x \<in> mset_factors (add_mset i m)"
+      by (simp add: INTEG.R.monom_divides_factors)
+  qed
+qed
+
+end 
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Associativity of Polynomial Multiplication.\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+context ring
+begin
+
+lemma finsum_eq:
+  assumes "f \<in> S \<rightarrow> carrier R"
+  assumes "g \<in> S \<rightarrow> carrier R"
+  assumes "(\<lambda> x \<in> S. f x) = (\<lambda> x \<in> S. g x)"
+  shows " finsum R f S = finsum R g S"
+        by (metis assms(1) assms(3) finsum_cong' restrict_apply')
+        
+lemma finsum_eq_induct:
+  assumes "f \<in> S \<rightarrow> carrier R"
+  assumes "g \<in> T \<rightarrow> carrier R"
+  assumes "finite S"
+  assumes "finite T"
+  assumes "bij_betw h S T"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> f s = g (h s)"
+  shows "finite U \<Longrightarrow> U \<subseteq> S \<Longrightarrow> finsum R f U = finsum R g (h ` U)"
+  apply(induct rule: finite_induct) 
+  apply (simp; fail)
+proof-
+  fix x
+  fix F :: "'c set"
+  assume F_fin: "finite F"
+  assume x_not_in: "x \<notin> F"
+  assume IH: "(F \<subseteq> S \<Longrightarrow> finsum R f F = finsum R g (h ` F)) "
+  show "insert x F \<subseteq> S \<Longrightarrow> finsum R f (insert x F) = finsum R g (h ` insert x F)"
+  proof-
+    assume A: "insert x F \<subseteq> S"
+    then have F_sub: "F \<subseteq>S"
+      by simp
+    have x_in: "x \<in> S"
+      using A by blast
+    have fx_in: "f x \<in>  carrier R"
+      using x_in assms(1)
+      by auto 
+    have ghx_fx_eq:
+      "f x = g (h x)"
+      using x_in assms 
+      by blast
+    have I: "finsum R f F = finsum R g (h ` F)"
+      using F_sub IH by blast
+    have f_fact: "f \<in> F \<rightarrow> carrier R "
+      using assms(1) F_sub 
+      by blast
+    have "finsum R f (insert x F) = (f x) \<otimes>\<^bsub>add_monoid R\<^esub> (finsum R f F) "
+      using F_fin  x_not_in comm_monoid.finprod_insert[of "(add_monoid R)" F x f ] 
+      unfolding finsum_def
+      using f_fact fx_in local.add.comm_monoid_axioms 
+      by auto
+    have "finsum R g (h ` insert x F) = finsum R g (insert (h x) (h ` F))"
+      by simp
+    then have "finsum R g (h ` insert x F) = (g (h x)) \<otimes>\<^bsub>add_monoid R\<^esub> finsum R g (h ` F)"
+    proof-
+       have 0: "finite (h ` F)"
+         by (simp add: F_fin)
+       have 1: "h x \<notin> h ` F"
+       proof-
+         have 10: "bij_betw h F (h` F)"
+           using assms(5) F_sub bij_betw_subset 
+           by blast
+         show ?thesis 
+         proof
+           assume "h x \<in> h ` F "
+           then  obtain s where s_def: "s \<in> F \<and> h s = h x"
+             using 10 
+             by auto
+           have "s \<in> S"
+             using F_sub s_def by blast
+           then have "s = x"
+             using x_in assms(5)
+               s_def
+             unfolding bij_betw_def inj_on_def
+             by blast
+           then show False using x_not_in
+             using s_def by blast
+         qed
+       qed
+       have 2: "g \<in> h ` F \<rightarrow> carrier (add_monoid R)"
+       proof
+         fix y
+         assume Ay: "y \<in> h ` F"
+         then obtain s where s_def: "y = h s \<and> s \<in> F"
+           by blast
+         then have s_S: "s \<in> S"
+           using F_sub by blast
+         have "h ` F \<subseteq> T"
+           using F_sub assms(5) 
+           unfolding bij_betw_def  
+           by blast
+         then have "g y \<in> carrier R"
+           using Ay assms(2)
+           by blast
+         then show "g y \<in> carrier (add_monoid R)"
+           by simp
+       qed
+       have "g (h x) \<in> carrier (add_monoid R)"
+         using fx_in ghx_fx_eq 
+         by auto
+       then show ?thesis 
+         using 0 1 2 comm_monoid.finprod_insert[of "(add_monoid R)" "(h ` F)"  "h x" g ] 
+         unfolding finsum_def 
+         by (simp add: local.add.comm_monoid_axioms)
+    qed
+    then have "finsum R g (h ` insert x F) = f x  \<otimes>\<^bsub>add_monoid R\<^esub> (finsum R f F)"    
+      using I ghx_fx_eq by auto
+    then show ?thesis 
+      by (simp add: \<open>finsum R f (insert x F) = f x \<otimes>\<^bsub>add_monoid R\<^esub> finsum R f F\<close>)
+  qed
+qed
+
+lemma finsum_bij_eq:
+  assumes "f \<in> S \<rightarrow> carrier R"
+  assumes "g \<in> T \<rightarrow> carrier R"
+  assumes "finite S"
+  assumes "bij_betw h S T"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> f s = g (h s)"
+  shows "finsum R f S = finsum R g T"
+proof-
+  have 0: "finite T"
+    using assms bij_betw_finite 
+    by blast
+  have 1: "(\<And>s. s \<in> S \<Longrightarrow> f s = g (h s)) "
+    using assms 
+    by blast
+  have "(\<And>s. s \<in> S \<Longrightarrow> f s = g (h s)) \<Longrightarrow> finite S \<Longrightarrow> S \<subseteq> S \<Longrightarrow> finsum R f S = finsum R g (h ` S)"
+    using 0 assms finsum_eq_induct[of f S g T h S ] 
+  by blast
+  then have "finsum R f S = finsum R g (h ` S)"
+    using assms(5) assms(3)
+    by blast
+  then show ?thesis 
+    using assms(5) assms(4) bij_betw_imp_surj_on 
+    by blast
+qed
+
+lemma monom_comp:
+  assumes "x \<subseteq># m"
+  assumes "y \<subseteq># m - x"
+  shows "x \<subseteq># m - y"
+using assms 
+  by (metis add_diff_cancel_left' subset_eq_diff_conv 
+      subset_mset.le_diff_conv2 subset_mset.order_refl subset_mset.order_trans)
+
+lemma monom_comp':
+  assumes "x \<subseteq># m"
+  assumes "y = m - x"
+  shows "x = m - y"
+  using assms 
+  by (metis add_diff_cancel_right' subset_mset.add_diff_inverse)
+
+text \<open>
+  This lemma turns iterated sums into sums over a product set. The first lemma is only a technical
+  phrasing of \texttt{double\_finsum'} to facilitate an inductive proof, and likely can and should 
+  be simplified.
+\<close>
+
+lemma double_finsum_induct:
+  assumes "finite S"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> finite (F s)"
+  assumes "P = (\<lambda>S. {(s, t). s \<in> S \<and>  t \<in> (F s)})"
+  assumes "\<And>s y. s \<in> S \<Longrightarrow> y \<in> (F s) \<Longrightarrow> g s y \<in> carrier R"
+  shows "finite T \<Longrightarrow> T \<subseteq> S \<Longrightarrow> finsum R (\<lambda>s. finsum R (g s) (F s)) T = 
+         finsum R (\<lambda> c. g (fst c) (snd c)) (P  T)" 
+  apply(induct rule: finite_induct) 
+  apply (simp add: assms(3); fail)
+proof-
+  fix x
+  fix T :: "'c set"
+  assume AT: "finite T"
+  assume x_notin: "x \<notin> T"
+  assume IH: "(T \<subseteq> S \<Longrightarrow> (\<Oplus>s\<in>T. finsum R (g s) (F s)) = (\<Oplus>c\<in>P T. g (fst c) (snd c)))"
+  assume A: "insert x T \<subseteq>S"
+  show " (\<Oplus>s\<in>insert x T. finsum R (g s) (F s)) = (\<Oplus>c\<in>P (insert x T). g (fst c) (snd c))"
+  proof-
+    have 0: "(\<lambda>s. finsum R (g s) (F s)) \<in> T \<rightarrow> carrier R"
+    proof
+      fix v
+      assume A0: "v \<in> T"
+      then have A1: "v \<in> S"
+        using A by blast
+      then show "finsum R (g v) (F v) \<in> carrier R"
+      proof-
+        have 00: "finite (F v)"
+          using assms A 
+          using \<open>v \<in> T\<close> by blast   
+        have "g v \<in> F v \<rightarrow> carrier R"
+        proof
+          fix l assume "l \<in> F v"
+          then show "g v l \<in> carrier R"
+            using A1 assms(4)[of v l] 
+            by blast
+        qed
+        then show ?thesis 
+          using finsum_closed by blast
+      qed
+    qed
+    have 1: "finsum R (g x) (F x) \<in> carrier R"
+    proof-
+      have "x \<in> S"
+        using A by blast
+      then show ?thesis using assms(4) finsum_closed[of "(g x)" "F x"] 
+        by blast
+    qed
+    have 2: " (\<Oplus>s\<in>insert x T. finsum R (g s) (F s)) = finsum R (g x) (F x) \<oplus> (\<Oplus>s\<in> T. finsum R (g s) (F s))"
+      using 0 1 finsum_insert[of T x "(\<lambda>s. finsum R (g s) (F s))"] AT x_notin  
+      by blast
+    have 3: "P (insert x T) = P {x} \<union> P T"
+    proof
+      show "P (insert x T) \<subseteq> P {x} \<union> P T"
+      proof
+        fix y
+        assume "y \<in> P (insert x T)"
+        then show "y \<in> P {x} \<union> P T"
+          using assms 
+          by blast
+      qed
+      show "P {x} \<union> P T \<subseteq> P (insert x T)"
+      proof
+        fix y
+        assume Ay: "y \<in> P {x} \<union> P T"
+        show "y  \<in> P (insert x T)"
+        proof(cases "y \<in> P {x}")
+          case True
+          then have "y \<in> ({(s, t). s \<in> {x} \<and> t \<in> F s})"
+            using assms(3) by auto 
+          then have "fst y = x \<and> snd y \<in> F x"
+            using Product_Type.Collect_case_prodD by auto
+          then show ?thesis using assms(3) 
+            using fst_def by auto
+        next
+          case False
+          then have "y \<in> P T"
+            using Ay 
+            by blast
+          then have "y \<in> ({(s, t). s \<in> T \<and> t \<in> F s})"
+            using assms(3) by blast 
+          then obtain s t where st_def: "y = (s, t) \<and>s \<in> T \<and> t \<in> F s"
+            by blast 
+          then have "y = (s, t) \<and>s \<in> (insert x T) \<and> t \<in> F s"
+            by blast 
+          then show ?thesis using assms(3) 
+            by simp
+        qed
+      qed
+    qed
+    have 4: "P {x} \<inter> P T = {}"
+    proof
+      show "P {x} \<inter> P T \<subseteq> {}"
+      proof
+        fix y
+        assume B: "y \<in> P {x} \<inter> P T"
+        then have "fst y = x"
+        proof-
+          have "y \<in> {(s, t). s \<in> {x} \<and> t \<in> F s}"
+            using assms(3) B by auto
+          then obtain s t where "y = (s, t) \<and> s \<in> {x} \<and> t \<in> F s"
+            by blast 
+          then show ?thesis 
+            by auto
+        qed
+        have "fst y \<in> T"
+        proof-
+          have "y \<in> {(s, t). s \<in> T \<and> t \<in> F s}"
+            using assms(3) B by auto
+          then obtain s t where "y = (s, t) \<and> s \<in> T \<and> t \<in> F s"
+            by blast 
+          then show ?thesis 
+            by simp
+        qed
+        then have False 
+          using x_notin 
+          by (simp add: \<open>fst y = x\<close>)
+        then show "y \<in> {}" 
+          by simp
+      qed
+      show "{} \<subseteq> P {x} \<inter> P T" 
+        by simp
+    qed
+    have 5: "(\<lambda>c. g (fst c) (snd c)) \<in> P {x} \<rightarrow> carrier R"
+    proof
+      fix y
+      assume X0: "y \<in> P {x}"
+      obtain s t where st_def: "y = (s, t) \<and> (s, t) \<in> P {x}"
+        by (metis X0 old.prod.exhaust)
+      then have st: "s = x \<and> t \<in> F x"
+        using assms(3) by blast
+      then have "g (fst y) (snd y) = g x t \<and>t \<in> F x"
+        by (simp add: st_def)
+      then show "g (fst y) (snd y) \<in> carrier R"
+        using assms(4)[of x t] A 
+        by simp
+    qed
+    have 6: "(\<lambda>c. g (fst c) (snd c)) \<in> P T \<rightarrow> carrier R"
+    proof
+      fix y
+      assume X0: "y \<in> P T"
+      obtain s t where st_def: "y = (s, t) \<and> (s, t) \<in> P T"
+        by (metis X0 old.prod.exhaust)
+      then have st: "s \<in> T \<and> t \<in> F s"
+        using assms(3) by blast
+      then have "g (fst y) (snd y) = g s t \<and>t \<in> F s"
+        by (simp add: st_def)
+      then show "g (fst y) (snd y) \<in> carrier R"
+        using assms(4)[of s t] A st 
+        by auto
+    qed
+    have 07: "\<And>x. x \<in> S \<Longrightarrow>  finite (P {x})"
+    proof-
+      fix x
+      assume "x \<in> S"
+      have "bij_betw snd (P {x}) (F x)"
+        unfolding bij_betw_def
+      proof
+        show "inj_on snd (P {x})"
+        proof
+          fix a b
+          assume Aa: "a \<in> P {x}"
+          assume Ab: "b \<in> P {x}"
+          have 0: "fst a = x"
+          proof-
+            have" a \<in> {(s, t). s \<in> {x} \<and> t \<in> F s} "
+              using Aa  assms(3)
+              by blast 
+            then obtain s t where st_def: "a = (s, t) \<and> s \<in> {x} \<and> t \<in> F s"
+              by blast 
+            then show ?thesis 
+              by auto
+          qed
+          have 1: "fst b = x"
+          proof-
+            have" b \<in> {(s, t). s \<in> {x} \<and> t \<in> F s} "
+              using Ab  assms(3)
+              by blast 
+            then obtain s t where st_def: "b = (s, t) \<and> s \<in> {x} \<and> t \<in> F s"
+              by blast 
+            then show ?thesis 
+              by auto
+          qed
+          show "snd a = snd b \<Longrightarrow> a = b" 
+            using 0 1 
+            by (simp add: prod_eqI)
+        qed
+        show "snd ` P {x} = F x"
+        proof
+          show "snd ` P {x} \<subseteq> F x"
+          proof
+            fix y
+            assume 0: "y \<in> snd ` P {x}"
+            then obtain q where q_def: " q \<in> P {x} \<and> y = snd q"
+              by blast 
+            then obtain s t where st: "q = (s, t) \<and> s \<in> {x} \<and> t \<in> F s"
+              using assms(3) by blast 
+            then have  1: "s = x" 
+              by blast 
+            have 2: "snd q = t"
+              by (simp add: st)
+            then show "y \<in> F x" 
+              using q_def st by blast
+          qed
+          show "F x \<subseteq> snd ` P {x}"
+          proof
+            fix y
+            assume "y \<in> F x"
+            then have C: "(x, y) \<in> P {x}"
+              using assms(3) 
+              by simp
+            then have "y = snd (x, y)"
+              by auto
+            then show "y \<in> snd ` P {x}"
+              using C  
+              by blast
+          qed
+        qed
+      qed
+      then show "finite (P {x})"
+        using assms(2)[of x] bij_betw_finite 
+        \<open>x \<in> S\<close> 
+        by blast    
+    qed
+    have 7: "finite (P {x})"
+      using 07 A 
+      by blast
+    have 8: "finite (P T)"
+    proof-
+      have "\<And>D. finite D \<Longrightarrow> D \<subseteq> S \<Longrightarrow> finite (P D)"
+      proof-
+        fix D
+        show "finite D \<Longrightarrow> D \<subseteq> S  \<Longrightarrow> finite (P D)"
+          apply(induct rule: finite_induct) 
+        proof-
+          have "P {} = {}" using assms(3) 
+            by blast
+          then show "finite (P {})"
+            by auto 
+          show "\<And>x F. finite F \<Longrightarrow> x \<notin> F \<Longrightarrow> (F \<subseteq> S \<Longrightarrow> finite (P F)) \<Longrightarrow> insert x F \<subseteq> S \<Longrightarrow> finite (P (insert x F))"
+          proof-
+            fix x
+            fix Q :: "'c set "
+            assume fin: "finite Q"
+            assume notin: "x \<notin> Q"
+            assume fin_pf: "(Q \<subseteq> S \<Longrightarrow> finite (P Q))"
+            assume I: "insert x Q \<subseteq> S "
+            show "finite (P (insert x Q))"
+            proof-
+              have x_in: "x \<in> S"
+                using I by blast
+              have 0: "(P (insert x Q)) \<subseteq> (P Q) \<union> P {x}"
+              proof
+                fix y
+                assume "y \<in> P (insert x Q)"
+                obtain s t where st: "y = (s, t) \<and> s \<in> (insert x Q) \<and> t \<in> F s"
+                  using assms(3) x_in  \<open>y \<in> P (insert x Q)\<close> 
+                  by blast
+                show "y \<in> (P Q) \<union> P {x}"
+                proof(cases "s \<in> Q")
+                  case True
+                  then have "y \<in> P Q"
+                    using st assms(3)
+                    by simp
+                  then show ?thesis using st assms(3) 
+                    by blast
+                next
+                  case False
+                  then have "s = x"
+                    using st by blast
+                  then have  "s \<in>{x} \<and> t \<in> F s"
+                    using st by blast 
+                  then have "y \<in> P {x}"
+                    using st assms(3) 
+                    by auto 
+                  then show ?thesis by auto                      
+                qed
+              qed
+              have 1: "finite  (P Q)"
+                using I fin_pf by blast
+              have "finite (P {x})"
+                using "07" x_in by blast
+              then show ?thesis using 0 1 
+                using finite_subset by auto
+            qed
+          qed
+        qed
+      qed   
+      then show ?thesis 
+        using A AT by blast
+    qed
+    have 9: "(\<Oplus>q\<in>P (insert x T). g (fst q) (snd q)) = 
+          (\<Oplus>q\<in>P T. g (fst q) (snd q)) \<oplus> (\<Oplus>q\<in>P {x}. g (fst q) (snd q))"
+      using 8 7 6 5 4 3 finsum_Un_disjoint[of "P {x}" "P T" "\<lambda>q. g (fst q) (snd q)"] 
+      by (simp add: "7" \<open>\<lbrakk>finite (P {x}); finite (P T); P {x} \<inter> P T = {}; (\<lambda>p. g (fst p) (snd p))
+           \<in> P {x} \<rightarrow> carrier R; (\<lambda>p. g (fst p) (snd p)) \<in> P T \<rightarrow> carrier R\<rbrakk> \<Longrightarrow>
+           (\<Oplus>p\<in>P {x} \<union> P T. g (fst p) (snd p)) = (\<Oplus>p\<in>P {x}. g (fst p) (snd p)) \<oplus>
+             (\<Oplus>p\<in>P T. g (fst p) (snd p))\<close> add.m_comm)      
+    have 10: "(\<Oplus>p\<in>P (insert x T). g (fst p) (snd p)) 
+        =  (\<Oplus>s\<in>T. finsum R (g s) (F s))\<oplus> (\<Oplus>p\<in>P {x}. g (fst p) (snd p))"
+      using IH 9 A 
+      by auto
+    have 11: "(\<Oplus>p\<in>P {x}. g (fst p) (snd p)) = finsum R (g x) (F x)"
+    proof-
+      obtain h :: "('c \<times> 'd) \<Rightarrow> 'd" where h_def: "h = snd"
+        by simp 
+      have 110: "bij_betw h (P {x}) (F x)"
+        unfolding bij_betw_def
+      proof
+        show "inj_on h (P {x})"
+          unfolding inj_on_def
+        proof
+          fix q
+          assume Ap: "q \<in>  P {x}"
+          show " \<forall>y\<in>P {x}. h q = h y \<longrightarrow> q = y"
+          proof
+            fix y
+            assume q_def: "y \<in> P {x}"
+            then have C0: "fst y = x"
+               using assms(3) 
+               by (simp add: case_prod_beta)
+            have C1: "fst q = x"
+              using assms(3) Ap
+               by (simp add: case_prod_beta)
+             show  "h q = h y \<longrightarrow> q = y" 
+               using C0 C1 h_def 
+               by (simp add: prod_eq_iff)
+          qed
+        qed
+        show "h ` P {x} = F x"
+        proof
+          show "h ` P {x} \<subseteq> F x"
+          proof
+            fix y
+            assume "y \<in> h ` P {x}"
+            then obtain d where d_def: "y = h d \<and> d \<in> P {x}"
+              by blast 
+            then obtain s t where st_def: "d = (s, t)"
+              by (meson surj_pair)
+            then have "s = x \<and> t \<in> F x"
+              using assms(3) d_def 
+              by blast
+            then  show "y \<in> F x"
+              using assms(3) 
+              by (simp add: d_def h_def st_def)
+          qed
+          show "F x \<subseteq> h ` P {x}"
+          proof
+            fix y
+            assume E0:  "y \<in> F x"
+            have E1: "y = h (x , y)"
+              by (simp add: h_def)
+            have "(x, y) \<in> P {x}"
+              using E0 assms(3) by blast  
+            then show "y \<in> h ` P {x} "
+              using E1 assms(3) by blast 
+          qed
+        qed
+      qed
+      have 111: "g x \<in> F x \<rightarrow> carrier R "
+      proof
+        fix y
+        assume "y \<in> F x"
+        then show "g x y \<in> carrier R" 
+          using assms A 
+          by blast
+      qed
+      have 112: "(\<And>s. s \<in> P {x} \<Longrightarrow> g (fst s) (snd s) = g x (h s))"
+      proof-
+        fix s
+        assume "s \<in> P{x}"
+        then have "s \<in> {(s, t). s = x \<and> t \<in> F s}"
+          using assms(3) by blast 
+        then obtain t where "s = (x, t) \<and> t \<in> F x"
+          using assms(3) 
+          by blast
+        then show "g (fst s) (snd s) = g x (h s)"
+          by (simp add: h_def)
+      qed
+
+        
+ 
+      show ?thesis using 5 7  110 111 112 finsum_bij_eq[of "\<lambda>p. g (fst p) (snd p)" "P {x}" "g x" "F x" h ]
+        by auto 
+    qed
+    have 12: "(\<Oplus>p\<in>P (insert x T). g (fst p) (snd p)) 
+        =  (\<Oplus>s\<in>T. finsum R (g s) (F s))\<oplus> finsum R (g x) (F x)"
+      using 10 11 by auto 
+    then show ?thesis using 2 
+      by (simp add: "2" "0" "1" add.m_comm)
+  qed
+qed
+
+lemma double_finsum:
+  assumes "finite S"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> finite (F s)"
+  assumes "P = {(s, t). s \<in> S \<and>  t \<in> (F s)}"
+  assumes "\<And>s y. s \<in> S \<Longrightarrow> y \<in> (F s) \<Longrightarrow> g s y \<in> carrier R"
+  shows "finsum R (\<lambda>s. finsum R (g s) (F s)) S = 
+         finsum R (\<lambda> p. g (fst p) (snd p)) P" 
+proof-
+  obtain P' where P'_def: "P' =  (\<lambda>S. {(s, t). s \<in> S \<and>  t \<in> (F s)})"
+    by simp
+  have "finsum R (\<lambda>s. finsum R (g s) (F s)) S = 
+         finsum R (\<lambda> p. g (fst p) (snd p)) (P' S)"
+    using double_finsum_induct[of S F P' g S]
+          assms P'_def 
+    by blast
+  then show ?thesis 
+    using P'_def assms 
+    by blast
+qed
+
+end 
+
+text\<open>
+  The product index set for the double sums in the coefficients of the 
+  $((a \otimes_p b) \otimes_p c)$. It is the set of pairs $(x,y)$ of monomials, such that
+  $x$ is a factor of monomial $m$, and $y$ is a factor of monomial $x$.
+\<close>
+
+definition right_cuts :: "'c monomial \<Rightarrow> ('c monomial \<times> 'c monomial) set" where
+"right_cuts m = {(x, y). x \<subseteq># m \<and> y \<subseteq># x}"
+
+context ring
+begin
+
+lemma right_cuts_alt_def:
+"right_cuts m = {(x, y). x \<in> mset_factors m \<and> y \<in> mset_factors x}"
+  unfolding mset_factors_def right_cuts_def
+  by simp
+
+lemma right_cuts_finite:
+"finite (right_cuts m)"
+proof-
+  have "finite (mset_factors m \<times> mset_factors m)"
+    using mset_factors_finite
+    by blast
+  have "right_cuts m \<subseteq> (mset_factors m \<times> mset_factors m)"
+  proof
+    fix p
+    assume p_def: "p \<in> right_cuts m"
+    obtain x y where xy: "p = (x , y) \<and> x \<subseteq># m \<and> y \<subseteq>#x"
+      using p_def unfolding right_cuts_def 
+      by blast
+    then have "x \<in> mset_factors m \<and> y \<in> mset_factors m"
+      using monom_divides_factors 
+      by auto    
+    then show "p \<in> (mset_factors m \<times> mset_factors m)"
+      by (simp add: xy)
+  qed
+  then show ?thesis 
+    using \<open>finite (mset_factors m \<times> mset_factors m)\<close> finite_subset
+    by blast
+qed
+    
+lemma assoc_aux0:  
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  assumes "g = (\<lambda>x y.  a x \<otimes> (b y \<otimes> c (m - x - y)))"
+  shows "\<And>s y. s \<in> mset_factors m \<Longrightarrow> y \<in> mset_factors (m - x) 
+            \<Longrightarrow> g s y \<in> carrier R"
+  using assms carrier_coeffE by blast
+  
+lemma assoc_aux1:  
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  assumes "g = (\<lambda>x y.  (a y  \<otimes> b (x - y)) \<otimes> c (m - x))"
+  shows "\<And>s y. s \<in> mset_factors m \<Longrightarrow> y \<in> mset_factors x \<Longrightarrow> g s y \<in> carrier R"
+  using assms carrier_coeffE by blast
+end
+
+text\<open>
+  The product index set for the double sums in the coefficients of the 
+  $(a \otimes_p (b \otimes_p c))$. It is the set of pairs $(x,y)$ such that $x$ is a factor
+  of $m$ and $y$ is a factor of $m/x$.
+\<close>
+
+definition left_cuts :: "'c monomial \<Rightarrow> ('c monomial \<times> 'c monomial) set" where
+"left_cuts m = {(x, y). x \<subseteq>#m \<and> y \<subseteq># (m - x)}"
+
+context ring
+begin
+
+lemma left_cuts_alt_def:
+"left_cuts m = {(x, y). x \<in> mset_factors m \<and> y \<in> mset_factors (m - x)}"
+  unfolding mset_factors_def left_cuts_def
+  by simp
+
+text\<open>This lemma witnesses the bijection between left and right cuts for the proof of associativity:\<close>
+
+lemma left_right_cuts_bij:
+"bij_betw (\<lambda> (x,y). (x + y, x))  (left_cuts m) (right_cuts m)"
+  unfolding bij_betw_def right_cuts_def left_cuts_def
+proof 
+  show "inj_on (\<lambda>(x, y). (x + y, x)) {(x, y). x \<subseteq># m \<and> y \<subseteq># m - x}"
+    unfolding inj_on_def 
+    by auto 
+  show "(\<lambda>(x, y). (x + y, x)) ` {(x, y). x \<subseteq># m \<and> y \<subseteq># m - x} = {(x, y). x \<subseteq># m \<and> y \<subseteq># x}"
+  proof
+    show "(\<lambda>(x, y). (x + y, x)) ` {(x, y). x \<subseteq># m \<and> y \<subseteq># m - x} \<subseteq> {(x, y). x \<subseteq># m \<and> y \<subseteq># x}"
+    proof
+      fix p
+      assume "p  \<in> (\<lambda>(x, y). (x + y, x)) ` {(x, y). x \<subseteq># m \<and> y \<subseteq># m - x}"
+      then obtain a b where ab: "a \<subseteq># m \<and> b \<subseteq># m - a \<and> p = (\<lambda>(x, y). (x + y, x)) (a, b)"
+        by blast
+      then have "p = (a + b, a)"
+        by simp
+      then show "p \<in> {(x, y). x \<subseteq># m \<and> y \<subseteq># x}"
+        using ab 
+        by (metis (no_types, lifting) case_prodI mem_Collect_eq mset_subset_eq_add_left
+            subset_mset.le_diff_conv2 union_commute)
+    qed
+    show "{(x, y). x \<subseteq># m \<and> y \<subseteq># x} \<subseteq> (\<lambda>(x, y). (x + y, x)) ` {(x, y). x \<subseteq># m \<and> y \<subseteq># m - x}"
+    proof
+      fix p
+      assume p_def: "p \<in> {(x, y). x \<subseteq># m \<and> y \<subseteq># x}"
+      then obtain a b where ab: "p = (a, b) \<and> a \<subseteq># m \<and> b \<subseteq># a"
+        by blast 
+      then have "p = (\<lambda>(x, y). (x + y, x)) (b, a - b)"
+        using ab 
+        by simp
+      then show " p \<in> (\<lambda>(x, y). (x + y, x)) ` {(x, y). x \<subseteq># m \<and> y \<subseteq># m - x}"
+        by (metis (mono_tags, lifting) ab case_prodI image_eqI mem_Collect_eq
+            subset_mset.diff_add subset_mset.dual_order.trans subset_mset.le_diff_conv2)
+    qed
+  qed
+qed
+
+lemma left_cuts_sum:
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  shows "(a \<Otimes>\<^sub>p (b \<Otimes>\<^sub>p c)) m = (\<Oplus>p \<in> left_cuts m. a (fst p) \<otimes> (b (snd p) \<otimes> c (m - (fst p) - (snd p))))"
+proof-
+  have U: "(a \<Otimes>\<^sub>p (b \<Otimes>\<^sub>p c)) m = (\<Oplus>x\<in>mset_factors m. (\<Oplus>xa\<in>mset_factors (m - x). a x \<otimes> (b xa \<otimes> c (m - x - xa))))"
+    unfolding P_ring_mult_def
+  proof-
+    obtain f where f_def:
+          "f = (\<lambda>x . a x \<otimes> (\<Oplus>xa\<in>mset_factors (m - x). b xa \<otimes> c (m - x - xa)))"
+      by simp 
+    obtain g where g_def:
+      "g =  (\<lambda>x . \<Oplus>xa\<in>mset_factors (m - x). a x \<otimes> (b xa \<otimes> c (m - x - xa)))"
+      by simp 
+    have 0: "restrict f (mset_factors m) = restrict g (mset_factors m)"
+    proof
+      fix x
+      show "restrict f (mset_factors m) x = restrict g (mset_factors m) x"
+      proof(cases "x \<in> mset_factors m")
+        case True 
+         have T0: "restrict f (mset_factors m) x = a x \<otimes> (\<Oplus>xa\<in>mset_factors (m - x). b xa \<otimes> c (m - x - xa))"
+           using f_def True by auto 
+         have T1: "restrict g (mset_factors m) x = (\<Oplus>xa\<in>mset_factors (m - x). a x \<otimes> (b xa \<otimes> c (m - x - xa)))"
+           using True g_def by auto 
+         show "restrict f (mset_factors m) x = restrict g (mset_factors m) x"
+           using assms finsum_rdistr[of "mset_factors (m - x)" "a x" "\<lambda> xa. b xa \<otimes> c (m - x - xa)"]
+           by (metis (mono_tags, lifting) mset_factors_finite Pi_I T0 T1 carrier_coeffE m_closed)
+      next
+        case False
+        then have "restrict f (mset_factors m)  x = undefined" using f_def 
+          by (simp add: restrict_def)
+        have  "restrict g (mset_factors m) x = undefined" using g_def False 
+          using restrict_def by auto
+        then show ?thesis using f_def g_def 
+          using \<open>restrict f (mset_factors m) x = undefined\<close>
+          by auto
+           
+      qed
+    qed
+    have 1: "f \<in> mset_factors m \<rightarrow> carrier R"
+      using f_def assms 
+      by (simp add: carrier_coeffE)
+    have 2: "g \<in> mset_factors m \<rightarrow> carrier R"
+      using g_def assms
+      by (simp add: carrier_coeffE)
+    show "(\<Oplus>x\<in>mset_factors m. a x \<otimes> (\<Oplus>xa\<in>mset_factors (m - x). b xa \<otimes> c (m - x - xa))) =
+    (\<Oplus>x\<in>mset_factors m. \<Oplus>xa\<in>mset_factors (m - x). a x \<otimes> (b xa \<otimes> c (m - x - xa)))"
+      using f_def g_def finsum_eq[of "f"
+                "mset_factors m" "g"] 0 1 2
+      by blast 
+  qed
+  have 0: "(\<And>s. s \<in> mset_factors m \<Longrightarrow> finite (mset_factors (m - s)))"
+    by simp
+  have 1: "finite (mset_factors m)"
+    by simp 
+  have 2: "(\<And>s y. s \<in> mset_factors m \<Longrightarrow> y \<in> mset_factors (m - s) \<Longrightarrow> a s \<otimes> (b y \<otimes> c (m - s - y)) \<in> carrier R)"
+    using assms assoc_aux0[of a b c ]
+    by blast
+    have "(\<Oplus>x\<in>mset_factors m. (\<Oplus>xa\<in>mset_factors (m - x). a x \<otimes> (b xa \<otimes> c (m - x - xa)))) =
+          (\<Oplus>p \<in> left_cuts m. a (fst p) \<otimes> (b (snd p) \<otimes> c (m - (fst p) - (snd p)))) " 
+    using assms left_cuts_alt_def[of m] 0 1 2
+          double_finsum[of "mset_factors m" "\<lambda>x. mset_factors (m - x)" "left_cuts m" "(\<lambda>x y.  a x \<otimes> (b y \<otimes> c (m - x - y)))"]
+    by blast
+  then show ?thesis using U 
+    by auto
+qed
+
+lemma right_cuts_sum:
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  shows "(a \<Otimes>\<^sub>p b \<Otimes>\<^sub>p c) m = (\<Oplus>p \<in> right_cuts m. a (snd  p) \<otimes> (b ((fst p) -(snd p)) \<otimes> c (m - (fst p))))"
+proof-
+  have 0: "finite (mset_factors m)"
+    by simp 
+  have 1: "(\<And>s. s \<in> mset_factors m \<Longrightarrow> finite (mset_factors s))"
+    by auto 
+  have 2: "right_cuts m = {(s, t). s \<in> mset_factors m \<and> t \<in> mset_factors s}"
+    unfolding right_cuts_def 
+    by (simp add: monom_divides_factors)
+  have 3: "(\<And>s y. s \<in> mset_factors m \<Longrightarrow> y \<in> mset_factors s \<Longrightarrow> a y \<otimes> b (s - y) \<otimes> c (m - s) \<in> carrier R)"
+    using assoc_aux1 assms(1) assms(2) assms(3) 
+    by blast
+  have 4: "(\<Oplus>s\<in>mset_factors m. (\<Oplus>y\<in>mset_factors s. a y \<otimes> b (s - y) \<otimes> c (m - s))) =
+    (\<Oplus>p\<in>right_cuts m. a (snd p) \<otimes> b (fst p - snd p) \<otimes> c (m - fst p))"
+    using 0 1 2 3 
+      double_finsum[of "mset_factors m" _ "right_cuts m"  
+        "(\<lambda>x y.  (a y  \<otimes> b (x - y)) \<otimes> c (m - x))"]
+    by auto 
+  have 5: "(\<Oplus>x\<in>mset_factors m. (\<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa)) \<otimes> c (m - x)) = 
+           (\<Oplus>x\<in>mset_factors m. \<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa) \<otimes> c (m - x))"
+  proof-
+    obtain f where f_def: "f =( \<lambda>x. (\<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa)) \<otimes> c (m - x))"
+      by simp
+    obtain g where g_def: "g = (\<lambda>x.  \<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa) \<otimes> c (m - x))"
+      by simp
+    have 50: "\<And>s. s \<in> (mset_factors m) \<Longrightarrow> f s = g s"
+    proof-
+      fix x
+      assume As:  "x \<in> mset_factors m"
+      show "f x = g x"
+      proof-
+        have f_eq: "f x = (\<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa)) \<otimes> c (m - x)"
+          using f_def 
+          by auto 
+        have g_eq: "g x =  (\<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa) \<otimes> c (m - x))"
+          using g_def  
+          by auto 
+        have f_eq': "f x =  (\<Oplus>xa\<in>mset_factors x. (a xa \<otimes> b (x - xa)) \<otimes> c (m - x))"
+          using f_eq finsum_ldistr[of "mset_factors x" "c (m - x)" "\<lambda>xa. (a xa \<otimes> b (x - xa))" ] assms 
+          by (simp add: \<open>\<lbrakk>finite (mset_factors x); c (m - x) \<in> carrier R; (\<lambda>xa. a xa \<otimes> b (x - xa)) \<in> mset_factors x \<rightarrow> carrier R\<rbrakk> \<Longrightarrow> (\<Oplus>i\<in>mset_factors x. a i \<otimes> b (x - i)) \<otimes> c (m - x) = (\<Oplus>i\<in>mset_factors x. a i \<otimes> b (x - i) \<otimes> c (m - x))\<close> Pi_I carrier_coeffE)
+        then show "f x = g x"
+          by (simp add: g_eq)
+      qed
+    qed
+    have 51: "f \<in> mset_factors m \<rightarrow> carrier R"
+    proof
+      fix x
+      assume "x \<in> mset_factors m"
+      have "(\<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa)) \<otimes> c (m - x )\<in> carrier R"
+        using assms carrier_coeffE finsum_closed[of "\<lambda>xa.  a xa \<otimes> b (x - xa)" "mset_factors x"]  
+        by blast
+      then show "f x \<in> carrier R" using assms f_def by auto 
+    qed
+    have 52: "g \<in> mset_factors m \<rightarrow> carrier R"
+    proof
+      fix x
+      assume "x \<in> mset_factors m"
+      show "g x \<in> carrier R"
+        using assms finsum_closed[of "\<lambda>xa. a xa \<otimes> b (x - xa) \<otimes> c (m - x)" "mset_factors x"] g_def
+        by (metis (no_types, lifting) "50" "51" Pi_iff \<open>x \<in> mset_factors m\<close>)
+    qed
+      
+    show ?thesis 
+      using 50 51 52 finsum_eq[of f "(mset_factors m) " g] 
+      by (metis (mono_tags, lifting) f_def finsum_cong' g_def)
+  qed
+  then have  6: "(\<Oplus>x\<in>mset_factors m. (\<Oplus>xa\<in>mset_factors x. a xa \<otimes> b (x - xa)) \<otimes> c (m - x)) =
+    (\<Oplus>p\<in>right_cuts m. a (snd p) \<otimes> b (fst p - snd p) \<otimes> c (m - fst p))"
+    by (simp add: "4")
+  have 7: "(\<Oplus>p\<in>right_cuts m. a (snd p) \<otimes> b (fst p - snd p) \<otimes> c (m - fst p)) 
+      = (\<Oplus>p\<in>right_cuts m. a (snd p) \<otimes> (b (fst p - snd p) \<otimes> c (m - fst p)))"
+    using assms 
+    by (meson local.ring_axioms m_assoc ring.carrier_coeff_def)
+  then show ?thesis 
+    using assms 5 6  
+    unfolding P_ring_mult_def 
+    by simp
+qed  
+
+text\<open>The Associativity of Polynomial Multiplication:\<close>
+
+lemma P_ring_mult_assoc:
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  assumes "carrier_coeff c"
+  shows "a \<Otimes>\<^sub>p (b \<Otimes>\<^sub>p c) = (a \<Otimes>\<^sub>p b) \<Otimes>\<^sub>p c"
+proof  
+  fix m
+  show "(a \<Otimes>\<^sub>p (b \<Otimes>\<^sub>p c)) m = (a \<Otimes>\<^sub>p b \<Otimes>\<^sub>p c) m"
+  proof-
+    obtain f where f_def: "f = (\<lambda>p.  a (snd  p) \<otimes> (b ((fst p) -(snd p)) \<otimes> c (m - (fst p))))"
+      by simp
+    obtain g where g_def: "g = (\<lambda>p. a (fst p) \<otimes> (b (snd p) \<otimes> c (m - (fst p) - (snd p))))"
+      by simp
+    have f_dom: "f \<in> right_cuts m \<rightarrow> carrier R"
+      using assms f_def unfolding right_cuts_def 
+      by (simp add: carrier_coeffE)
+    have g_dom: "g \<in> left_cuts m \<rightarrow> carrier R"
+      using assms g_def unfolding left_cuts_def 
+      by (simp add: carrier_coeffE)
+    have 0: "finite (right_cuts m)"
+      by (simp add: right_cuts_finite)
+    have 1: "bij_betw (\<lambda> (x,y). (x + y, x))  (left_cuts m) (right_cuts m)"
+      by (simp add: left_right_cuts_bij)
+    have 2: "(\<And>s. s \<in> left_cuts m \<Longrightarrow> g s = f (case s of (x, y) \<Rightarrow> (x + y, x)))"
+    proof-
+      fix s
+      assume "s \<in> left_cuts m"
+      then obtain x y where xy: "s = (x, y) \<and> x \<subseteq># m \<and> y \<subseteq># m - x"
+        using  left_cuts_def 
+        by blast
+      then have g_eq: "g s = a x \<otimes> (b y \<otimes> c (m - x - y))"
+        using g_def fst_conv 
+        by auto
+      have f_eq: "f (case s of (x, y) \<Rightarrow> (x + y, x)) = f (x + y, x)"
+        by (simp add: xy)
+      then have f_eq': "f (case s of (x, y) \<Rightarrow> (x + y, x)) = a x \<otimes> (b ((x + y) - x) \<otimes> c (m - (x + y)))"
+        using f_def 
+        by simp
+      then show "g s = f (case s of (x, y) \<Rightarrow> (x + y, x))"
+        by (simp add: g_eq)
+    qed
+    have 3: "finsum R g (left_cuts m) = finsum R f (right_cuts m)"
+    using 0 1 2 finsum_bij_eq[of g "left_cuts m" f "right_cuts m" "\<lambda> (x,y). (x + y, x)" ]
+      using bij_betw_finite f_dom g_dom by blast
+    then show ?thesis using assms right_cuts_sum left_cuts_sum
+      by (metis (mono_tags, lifting) f_def f_dom finsum_cong' g_def g_dom)
+  qed
+qed
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Commutativity of Polynomial Multiplication\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context ring 
+begin
+
+lemma mset_factors_bij:
+"bij_betw (\<lambda>x. m - x) (mset_factors m) (mset_factors m)"
+  apply(rule bij_betwI')
+  apply (metis monom_comp' monom_divides_factors)
+   apply (simp add: monom_divides_factors)
+    by (meson monom_comp' monom_divides_factors diff_subset_eq_self)
+
+lemma(in cring) P_ring_mult_comm:
+  assumes "carrier_coeff a"
+  assumes "carrier_coeff b"
+  shows "a \<Otimes>\<^sub>p b  = b \<Otimes>\<^sub>p a"
+proof
+  fix m
+  show "(a \<Otimes>\<^sub>p b) m = (b \<Otimes>\<^sub>p a) m"
+  unfolding P_ring_mult_def
+  apply (rule finsum_bij_eq[of "\<lambda> x. a x \<otimes> b (m - x)" "mset_factors m" 
+                          "\<lambda>x. b x \<otimes> a (m - x)" "mset_factors m" "\<lambda>x. m - x"])
+  proof
+    show "\<And>x. x \<in> mset_factors m \<Longrightarrow> a x \<otimes> b (m - x) \<in> carrier R"
+    proof-
+      fix x
+      assume "x \<in> mset_factors m"
+      show "a x \<otimes> b (m - x) \<in> carrier R"
+        using assms carrier_coeffE 
+        by blast
+    qed
+    show "(\<lambda>x. b x \<otimes> a (m - x)) \<in> mset_factors m \<rightarrow> carrier R"
+    proof
+      fix x
+      assume "x \<in> mset_factors m"
+      show "b x \<otimes> a (m - x) \<in> carrier R"
+        using assms  carrier_coeffE 
+        by blast 
+    qed
+    show "finite (mset_factors m)" 
+      by simp 
+    show "bij_betw ((-) m) (mset_factors m) (mset_factors m)"
+      by (simp add: mset_factors_bij)
+    show "\<And>s. s \<in> mset_factors m \<Longrightarrow> a s \<otimes> b (m - s) = b (m - s) \<otimes> a (m - (m - s))"
+    proof-
+      fix s
+      assume "s \<in> mset_factors m"
+      then show "a s \<otimes> b (m - s) = b (m - s) \<otimes> a (m - (m - s))"
+        using assms carrier_coeffE 
+        by (metis local.ring_axioms m_comm ring.monom_comp' ring.monom_divides_factors)
+    qed
+  qed
+qed 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Closure properties for multiplication\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>Building monomials from polynomials:\<close>
+
+lemma indexed_const_P_mult_eq: 
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier R"
+  shows "(indexed_const a) \<Otimes>\<^sub>p  (indexed_const b) = indexed_const (a \<otimes> b)"
+proof-
+  have 0: "monomials_of R (indexed_const a) = (if (a = \<zero>) then {} else {{#}})"
+    unfolding monomials_of_def indexed_const_def
+    by auto 
+  have 1: "monomials_of R (indexed_const b) = (if (b = \<zero>) then {} else {{#}})"
+    unfolding monomials_of_def indexed_const_def
+    by auto 
+  show ?thesis 
+    unfolding P_ring_mult_def 
+  proof
+    fix m:: "'c monomial"
+    show "(\<Oplus>x\<in>mset_factors m. indexed_const a x \<otimes> indexed_const b (m - x)) = indexed_const (a \<otimes> b) m "
+    proof(cases "m = {#}")
+      case True
+      then have T0: "mset_factors m = {{#}}"
+        unfolding mset_factors_def 
+        by simp        
+      have "(\<Oplus>x\<in>mset_factors m. indexed_const a x \<otimes> indexed_const b (m - x)) =
+                   indexed_const a {#} \<otimes> indexed_const b ({#} - {#}) "
+      proof-
+        have 0: "(\<lambda>x. indexed_const a x \<otimes> indexed_const b (m - x)) \<in> {} \<rightarrow> carrier R"
+          by blast
+        have 1: "indexed_const a {#} \<otimes> indexed_const b (m - {#}) \<in> carrier R"
+          by (simp add: assms(1) assms(2) indexed_const_def)
+        have 2: "(\<Oplus>x\<in>{{#}}. indexed_const a x \<otimes> indexed_const b (m - x)) =
+                 indexed_const a {#} \<otimes> indexed_const b (m - {#}) \<oplus> (\<Oplus>x\<in>{}. indexed_const a x \<otimes> indexed_const b (m - x))"
+        using True T0 0 1  finsum_insert[of "{}" "{#}" "\<lambda>x. indexed_const a x \<otimes> indexed_const b (m - x)"  ] 
+            by (simp add: indexed_const_def)
+        then show ?thesis 
+          using True T0 0 1  finsum_insert[of "{}" "{#}" "\<lambda>x. indexed_const a x \<otimes> indexed_const b (m - x)"  ] 
+              finsum_empty[of "\<lambda>x. indexed_const a x \<otimes> indexed_const b (m - x)"]
+          by (simp add: \<open>\<lbrakk>finite {}; {#} \<notin> {}; (\<lambda>x. indexed_const a x \<otimes> indexed_const b (m - x)) \<in> {} \<rightarrow> carrier R; indexed_const a {#} \<otimes> indexed_const b (m - {#}) \<in> carrier R\<rbrakk> \<Longrightarrow> (\<Oplus>x\<in>{{#}}. indexed_const a x \<otimes> indexed_const b (m - x)) = indexed_const a {#} \<otimes> indexed_const b (m - {#}) \<oplus> (\<Oplus>x\<in>{}. indexed_const a x \<otimes> indexed_const b (m - x))\<close> indexed_const_def)
+      qed
+      then show ?thesis
+        by (simp add: True indexed_const_def)
+    next
+      case False
+      then show ?thesis using 0 1 
+        by (simp add: add.finprod_one_eqI assms(1) assms(2) 
+            indexed_const_def )
+    qed
+  qed
+qed
+
+lemma indexed_const_P_multE: 
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "c \<in> carrier R"
+  shows "(P \<Otimes>\<^sub>p (indexed_const c)) m =  (P m) \<otimes> c"
+  unfolding P_ring_mult_def
+proof-
+  have 3: "m \<notin> mset_factors m - {m}"
+    by simp
+  have 4: "finite ((mset_factors m) - {m})"
+    by simp
+  have 5: "P m \<otimes> indexed_const c (m - m) \<in> carrier R "
+  by (metis assms(1) assms(2) cancel_comm_monoid_add_class.diff_cancel 
+      carrier_coeffE indexed_const_def indexed_pset_in_carrier local.ring_axioms 
+      ring.ring_simprules(5) subsetI)
+  have 0: "(\<lambda>x. P x \<otimes> indexed_const c (m - x)) \<in> mset_factors m - {m} \<rightarrow> carrier R"
+  proof
+    fix x
+    assume "x \<in> mset_factors m - {m}"
+    then show "P x \<otimes> indexed_const c (m - x) \<in> carrier R "
+      using assms 
+      by (meson carrier_coeffE indexed_const_in_carrier indexed_pset_in_carrier m_closed subsetI)
+  qed
+  have 1: "P m \<otimes> indexed_const c ( m - m) =  (P m \<otimes> c)"
+    by (simp add: indexed_const_def)
+  have 2: "\<And>x. x \<in> mset_factors m \<Longrightarrow>  P x \<otimes> indexed_const c (m - x)  = (if x = m then (P m \<otimes> c) else \<zero>)"
+  proof-
+    fix x
+    assume "x \<in> mset_factors m "
+    then have "indexed_const c (m - x) = (if x = m then c else \<zero>)"
+      unfolding indexed_const_def 
+      by (metis cancel_comm_monoid_add_class.diff_cancel 
+          diff_zero monom_comp' monom_divides_factors)
+    then show  "P x \<otimes> indexed_const c (m - x)  = (if x = m then (P m \<otimes> c) else \<zero>)"
+      by (metis assms(1) carrier_coeffE indexed_pset_in_carrier
+            local.semiring_axioms semiring.r_null set_eq_subset)
+  qed
+  then have "(\<Oplus>x\<in>(mset_factors m) - {m}. P x \<otimes> indexed_const c (m - x)) = \<zero>"
+    using assms 
+    by (metis (no_types, lifting) DiffD1 DiffD2 add.finprod_one_eqI singletonI)
+  then show "(\<Oplus>x\<in>(mset_factors m). P x \<otimes> indexed_const c (m - x)) = P m \<otimes> c"
+    using assms 0 1 3 4 5 finsum_insert[of "(mset_factors m) - {m}" 
+                                    m "\<lambda>x. P x \<otimes> indexed_const c (m - x) "] 
+    by (metis (no_types, lifting) m_factor add.l_cancel_one
+              insert_Diff_single insert_absorb zero_closed)
+qed
+
+lemma indexed_const_var_mult:
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "c \<in> carrier R"
+  assumes "i \<in> I"
+  shows "P \<Otimes> i \<Otimes>\<^sub>p indexed_const c = (P \<Otimes>\<^sub>p (indexed_const c)) \<Otimes> i "
+proof
+  fix m
+  show "(P \<Otimes> i \<Otimes>\<^sub>p indexed_const c) m = (P \<Otimes>\<^sub>p indexed_const c \<Otimes> i) m"
+  proof(cases "i \<in># m")
+    case True
+    then have T0: "(P \<Otimes> i \<Otimes>\<^sub>p indexed_const c) m  = (P \<Otimes> i) m \<otimes> c"
+      using assms indexed_const_P_multE[of "P \<Otimes> i" I c m]
+      by (simp add: indexed_pset.indexed_pmult)
+    then show ?thesis using assms indexed_const_P_multE[of P I c m]  
+      unfolding  indexed_pmult_def 
+      using True indexed_const_P_multE by fastforce      
+  next
+    case False
+        then have T0: "(P \<Otimes> i \<Otimes>\<^sub>p indexed_const c) m  = (P \<Otimes> i) m \<otimes> c"
+      using assms indexed_const_P_multE[of "P \<Otimes> i" I c m]
+      by (simp add: indexed_pset.indexed_pmult)
+    then show ?thesis using assms indexed_const_P_multE[of P I c m]  
+      unfolding  indexed_pmult_def 
+      using False by auto
+  qed
+qed    
+    
+lemma indexed_const_P_mult_closed:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  assumes "c \<in> carrier R" 
+  shows "a \<Otimes>\<^sub>p (indexed_const c) \<in> indexed_pset I (carrier R)"
+  apply(rule indexed_pset.induct[of a I "(carrier R)" ])
+     apply (simp add: assms(1); fail)
+proof-
+  show "\<And>k. (k \<in> carrier R) \<Longrightarrow> ((indexed_const k) \<Otimes>\<^sub>p (indexed_const c)) \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>])"
+    using assms 
+    by (metis indexed_const_P_mult_eq indexed_pset.simps m_closed)
+  show "\<And>P Q. P \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow>
+           P \<Otimes>\<^sub>p indexed_const c \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow>
+           Q \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> Q \<Otimes>\<^sub>p indexed_const c \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> P \<Oplus> Q \<Otimes>\<^sub>p indexed_const c \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>])"
+    using P_ring_ldistr 
+    by (metis assms(2) carrier_coeff_def indexed_const_in_carrier indexed_pset.indexed_padd indexed_pset_in_carrier subsetI)
+  show "\<And>P i. P \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> P \<Otimes>\<^sub>p indexed_const c \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> i \<in> I \<Longrightarrow> P \<Otimes> i \<Otimes>\<^sub>p indexed_const c \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>])"
+  proof-
+    fix P i
+    assume A0: "P \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>])"
+    assume A1: " (P \<Otimes>\<^sub>p indexed_const c) \<in> ((carrier R) [\<X>\<^bsub>I\<^esub>])"
+    assume A2: "i \<in> I"
+    show "P \<Otimes> i \<Otimes>\<^sub>p indexed_const c \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using assms  A0 A1 A2 indexed_const_var_mult local.ring_axioms ring.indexed_pset.simps 
+      by (metis (no_types, opaque_lifting))
+  qed
+qed
+
+lemma monom_add_mset: 
+"mset_to_IP R (add_mset i m) = mset_to_IP R m \<Otimes> i"
+  unfolding indexed_pmult_def 
+  by (metis (no_types, opaque_lifting) add_mset_diff_bothsides diff_empty mset_to_IP_def multi_member_split union_single_eq_member)
+
+text\<open>Monomials are closed under multiplication:\<close>
+
+lemma monom_mult:
+"mset_to_IP R m \<Otimes>\<^sub>p mset_to_IP R n = mset_to_IP R (m + n)"
+proof-
+  have "(\<lambda>ma. \<Oplus>x\<in>mset_factors ma. (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>))
+       = (\<lambda>ma. (if ma = n + m then \<one> else \<zero>))"
+  proof
+    fix ma
+    show "(\<Oplus>x\<in>mset_factors ma. (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>)) = (if ma = n + m then \<one> else \<zero>)"
+    
+    proof-
+      have 0: "\<And>x. x \<in> mset_factors ma \<Longrightarrow> 
+            (\<lambda> x. (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>)) x = 
+                  (if (x = m) then (if ma - x = n then \<one> else \<zero>) else \<zero>) "
+        by simp
+      then have 1: "(\<Oplus>x\<in>((mset_factors ma) - {m}). (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>)) =
+            \<zero>"
+        by (metis (no_types, lifting) add.finprod_one_eqI mem_Collect_eq set_diff_eq singletonI)
+      have 2: "finite (mset_factors ma - {m}) "
+        by simp
+      have 3: "m \<notin> mset_factors ma - {m}"
+        by simp
+      have 4: "(\<lambda>x. (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>)) \<in> mset_factors ma - {m} \<rightarrow> carrier R"
+      proof
+        fix x
+        assume " x \<in> mset_factors ma - {m}"
+        show "(if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>) \<in> carrier R "
+          by auto
+      qed
+      show ?thesis
+      proof(cases "m \<in> (mset_factors ma)")
+        case True
+        have T0: " (\<Oplus>x\<in>insert m (mset_factors ma - {m}). (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>)) =
+      (if m = m then \<one> else \<zero>) \<otimes> (if ma - m = n then \<one> else \<zero>) \<oplus>
+      (\<Oplus>x\<in>mset_factors ma - {m}. (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>))"
+          using True 1 2 3 4 finsum_insert[of "((mset_factors ma) - {m})" m 
+                                   "\<lambda>x. (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>)"] 
+          using m_closed one_closed zero_closed by presburger
+        have T1: "(mset_factors ma) = insert m (mset_factors ma - {m})"
+          using True 
+          by blast
+        then have  "(\<Oplus>x\<in>(mset_factors ma). (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>))
+                      = (if m = m then \<one> else \<zero>) \<otimes> (if ma - m = n then \<one> else \<zero>)"
+          using T0 T1 1 add.l_cancel_one insert_Diff_single insert_absorb2 l_one mk_disjoint_insert one_closed zero_closed
+          by presburger
+        then have "(\<Oplus>x\<in>(mset_factors ma). (if x = m then \<one> else \<zero>) \<otimes> (if ma - x = n then \<one> else \<zero>))
+                      = (if ma - m = n then \<one> else \<zero>)"
+          by simp
+        then show ?thesis 
+          by (metis (no_types, lifting) monom_divides_factors True add.commute add_diff_cancel_right' subset_mset.add_diff_inverse)
+      next
+        case False
+        then show ?thesis 
+          by (metis (no_types, lifting) "0" monom_divides_factors add.finprod_one_eqI mset_subset_eq_add_right)
+      qed
+    qed
+  qed
+  then show ?thesis 
+  unfolding mset_to_IP_def P_ring_mult_def   
+  by (simp add: union_commute)
+qed
+
+lemma poly_index_mult:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  assumes "i \<in> I"
+  shows "a \<Otimes> i = a \<Otimes>\<^sub>p mset_to_IP R {#i#}"
+proof
+  fix m
+  show "(a \<Otimes> i) m = (a \<Otimes>\<^sub>p mset_to_IP R {#i#}) m"
+  proof(cases "i \<in># m")
+    case True
+    have T0: "(a \<Otimes> i) m = a (m - {#i#})"
+      by (simp add: True indexed_pmult_def)
+    have T1: "(a \<Otimes>\<^sub>p mset_to_IP R {#i#}) m = a (m - {#i#})"
+    proof-
+      have T10: "(a \<Otimes>\<^sub>p mset_to_IP R {#i#}) m 
+                = (\<Oplus>x\<in>mset_factors m. a x \<otimes> mset_to_IP R {#i#} (m - x)) "
+        unfolding P_ring_mult_def 
+        by auto 
+      have T11: "\<And>x. x \<in> mset_factors m \<Longrightarrow> 
+                  mset_to_IP R {#i#} (m - x) = (if x = (m - {#i#}) then \<one> else \<zero>)"
+        unfolding mset_to_IP_def 
+        by (metis Multiset.diff_cancel Multiset.diff_right_commute True diff_single_eq_union
+            diff_single_trivial diff_zero monom_comp' monom_divides_factors multi_drop_mem_not_eq)
+      have T12: "\<And>x. x \<in> mset_factors m \<Longrightarrow> 
+              a x \<otimes> mset_to_IP R {#i#} (m - x) = (if  x = (m - {#i#}) then a (m - {#i#}) else \<zero>)"
+      proof-
+        fix x
+        assume "x \<in> mset_factors m"
+        then show " a x \<otimes> mset_to_IP R {#i#} (m - x) = (if x = m - {#i#} then a (m - {#i#}) else \<zero>)"
+          apply(cases "x = m - {#i#}")
+           apply (metis T0 T11 \<open>x \<in> mset_factors m\<close> assms(1) carrier_coeffE empty_subsetI
+              ideal_is_subalgebra indexed_pset_in_carrier oneideal r_one subalgebra_in_carrier)
+          by (metis T11 \<open>x \<in> mset_factors m\<close> assms(1) carrier_coeffE carrier_is_subalgebra 
+              empty_subsetI  indexed_pset_in_carrier  r_null  subalgebra_in_carrier)
+      qed
+      have  T13: "(\<Oplus>x\<in>(mset_factors m) - {m - {#i#}}. a x \<otimes> mset_to_IP R {#i#} (m - x)) = \<zero>"
+        using T12 
+        by (metis (no_types, lifting) DiffE add.finprod_one_eqI singletonI)
+      have T14: "finite (mset_factors m - {m - {#i#}})"
+        using mset_factors_finite by blast
+      have T15: "m - {#i#} \<notin> mset_factors m - {m - {#i#}}"
+        by simp
+      have T16: "  (\<lambda>x. a x \<otimes> mset_to_IP R {#i#} (m - x)) \<in> mset_factors m - {m - {#i#}} \<rightarrow> carrier R"
+      proof
+        fix x
+        assume "x \<in> mset_factors m - {m - {#i#}}"
+        then show " a x \<otimes> mset_to_IP R {#i#} (m - x) \<in> carrier R"
+          using assms T12 by auto
+      qed
+      have "m - (m - {#i#}) = {#i#}"
+        by (metis monom_comp' True single_subset_iff)
+      then have T17: " a (m - {#i#}) \<otimes> mset_to_IP R {#i#} (m - (m - {#i#})) \<in> carrier R"
+        unfolding mset_to_IP_def apply auto using assms  
+        by (meson carrier_coeffE carrier_is_subalgebra empty_subsetI indexed_pset_in_carrier m_closed one_closed subalgebra_in_carrier)
+      have T18:"(\<Oplus>x\<in>insert (m - {#i#}) (mset_factors m - {m - {#i#}}). a x \<otimes> mset_to_IP R {#i#} (m - x)) =
+      a (m - {#i#}) \<otimes> mset_to_IP R {#i#} (m - (m - {#i#})) \<oplus> (\<Oplus>x\<in>mset_factors m - {m - {#i#}}. a x \<otimes> mset_to_IP R {#i#} (m - x))" 
+        using T12 T13 T14 T15 T16 T17 unfolding P_ring_mult_def
+        using finsum_insert[of "mset_factors m - {m - {#i#}}" "m - {#i#}" 
+            "\<lambda>x. a x \<otimes> mset_to_IP R {#i#} (m - x)"] 
+        by blast
+      have T19: "a (m - {#i#}) \<otimes> mset_to_IP R {#i#} (m - (m - {#i#})) = a (m - {#i#}) "
+      proof-
+        have " (m - (m - {#i#})) = {#i#}"
+          using True 
+          by (metis monom_comp' single_subset_iff)
+        then have "mset_to_IP R {#i#} (m - (m - {#i#})) = \<one>"
+          by (metis mset_to_IP_def)
+        have "a (m - {#i#}) \<in> carrier R"
+          using assms 
+          by (meson carrier_coeffE carrier_is_subalgebra exp_base_closed 
+              indexed_pset_in_carrier one_closed subalgebra_in_carrier)
+        then show ?thesis using assms 
+          using \<open>mset_to_IP R {#i#} (m - (m - {#i#})) = \<one>\<close> by auto
+      qed
+      have T20: "(\<Oplus>x\<in>insert (m - {#i#}) ((mset_factors m) - {m - {#i#}}). a x \<otimes> mset_to_IP R {#i#} (m - x)) =
+       a (m - {#i#}) \<oplus> (\<Oplus>x\<in>mset_factors m - {m - {#i#}}. a x \<otimes> mset_to_IP R {#i#} (m - x))" 
+        using T18 T19 by auto
+      have T21: "insert (m - {#i#}) ((mset_factors m) - {m - {#i#}}) = mset_factors m"
+      proof-
+        have "(m - {#i#}) \<in> mset_factors m"
+          by (simp add: monom_divides_factors)
+        then show ?thesis 
+          by blast
+      qed
+      then show ?thesis using T13 T20 True unfolding P_ring_mult_def  
+        using T17 T19 by auto
+    qed
+    then show ?thesis 
+      by (simp add: T0)
+  next
+    case False
+    have F0: "(a \<Otimes> i) m = \<zero> "
+      by (simp add: False indexed_pmult_def)
+    have F1: "  (a \<Otimes>\<^sub>p mset_to_IP R {#i#}) m = \<zero>"
+      unfolding P_ring_mult_def 
+    proof-
+      have "\<And>x. x \<in> mset_factors m \<Longrightarrow>  a x \<otimes> mset_to_IP R {#i#} (m - x) = \<zero>"
+      proof-
+        fix x
+        assume A: "x \<in> mset_factors m"
+        have B: "m - x \<noteq> {#i#}" using False A 
+          by (metis diff_subset_eq_self single_subset_iff)
+        then show "a x \<otimes> mset_to_IP R {#i#} (m - x) = \<zero>"
+          using assms False unfolding mset_to_IP_def  
+          using  carrier_coeffE indexed_pset_in_carrier by fastforce
+      qed
+      then show "(\<Oplus>x\<in>mset_factors m. a x \<otimes> mset_to_IP R {#i#} (m - x)) = \<zero>"
+        by (simp add: add.finprod_one_eqI)
+    qed
+    then show ?thesis 
+      by (simp add: F0)  
+  qed
+qed
+
+lemma mset_to_IP_mult_closed:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  shows "set_mset m \<subseteq> I \<Longrightarrow> a \<Otimes>\<^sub>p mset_to_IP R m \<in> indexed_pset I (carrier R)"
+proof(induction m)
+  case empty
+  then have "mset_to_IP R {#} = indexed_const \<one>"
+    unfolding mset_to_IP_def indexed_const_def by auto
+  then show ?case 
+    by (simp add: \<open>mset_to_IP R {#} = indexed_const \<one>\<close> assms indexed_const_P_mult_closed)
+next
+  case (add x m)
+  fix x 
+  fix m :: "'c monomial"
+  assume A: "set_mset (add_mset x m) \<subseteq> I"
+  assume B: "set_mset m \<subseteq> I \<Longrightarrow> a \<Otimes>\<^sub>p mset_to_IP R m \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+  show " a \<Otimes>\<^sub>p mset_to_IP R (add_mset x m) \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+  proof-
+    have 0: "x \<in> I"
+      using A by auto
+    have 1: "set_mset m \<subseteq> I"
+      using A by auto
+    have 2: " a \<Otimes>\<^sub>p mset_to_IP R m \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using "1" B by blast
+    have 3: " a \<Otimes>\<^sub>p mset_to_IP R (add_mset x m) = (a \<Otimes>\<^sub>p mset_to_IP R m) \<Otimes> x" 
+    proof-
+      have 30: " a \<Otimes>\<^sub>p mset_to_IP R (add_mset x m) = a \<Otimes>\<^sub>p (mset_to_IP R m \<Otimes> x)" 
+        using monom_add_mset[of x m]
+        by auto
+      have 31: "(a \<Otimes>\<^sub>p mset_to_IP R m) \<Otimes> x = a \<Otimes>\<^sub>p (mset_to_IP R m \<Otimes> x)"
+      proof
+        fix y
+        show "(a \<Otimes>\<^sub>p mset_to_IP R m \<Otimes> x) y = (a \<Otimes>\<^sub>p (mset_to_IP R m \<Otimes> x)) y "
+        proof-
+          have 310: "(a \<Otimes>\<^sub>p mset_to_IP R m \<Otimes> x) y = (a \<Otimes>\<^sub>p mset_to_IP R m \<Otimes>\<^sub>p mset_to_IP R {#x#}) y"
+            using poly_index_mult "0" "2" 
+            by fastforce
+          have 311: " (mset_to_IP R m \<Otimes> x) = mset_to_IP R m \<Otimes>\<^sub>p mset_to_IP R {#x#}"
+            using  "0" "2" 
+            by (metis add_mset_add_single monom_add_mset monom_mult)
+          have 312: "carrier_coeff a "
+            using assms indexed_pset_in_carrier by blast
+          have 313: "carrier_coeff (mset_to_IP R m)"
+            by (simp add: carrier_coeff_def mset_to_IP_def)
+          have 314: "carrier_coeff (mset_to_IP R {#x#})" 
+            by (metis carrier_coeff_def mset_to_IP_def one_closed zero_closed)
+          show ?thesis 
+            using 310 311 312 313 314 
+                  P_ring_mult_assoc[of a "mset_to_IP R m" "mset_to_IP R {#x#}"]  
+            by simp 
+        qed
+      qed
+      then show ?thesis 
+        by (simp add: monom_add_mset)        
+    qed
+    then show ?thesis 
+      by (simp add: "0" "1" B indexed_pset.indexed_pmult)
+  qed
+qed
+
+text\<open>
+  A predicate which identifies when the variables used in a given polynomial $P$ are only
+   drawn from a fixed variable set $I$.
+\<close>
+abbreviation monoms_in where
+"monoms_in I P \<equiv> (\<forall>m \<in> monomials_of R P. set_mset m \<subseteq> I)"
+
+lemma monoms_of_const:
+"monomials_of R (indexed_const k) = (if k = \<zero> then {} else {{#}})"
+  unfolding indexed_const_def monomials_of_def
+  by auto
+
+lemma const_monoms_in:
+"monoms_in I (indexed_const k)"
+  unfolding indexed_const_def monomials_of_def
+  using  count_empty count_eq_zero_iff monomials_ofE subsetI
+  by simp
+
+lemma mset_to_IP_indices:
+  shows  "P \<in> indexed_pset I (carrier R) \<Longrightarrow> monoms_in I P"
+  apply(erule indexed_pset.induct[of])
+   apply (simp add: const_monoms_in; fail) 
+proof-
+  show "\<And>P Q. P \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow>
+           \<forall>m\<in>monomials_of R P. set_mset m \<subseteq> I \<Longrightarrow>
+           Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> \<forall>m\<in>monomials_of R Q. set_mset m \<subseteq> I \<Longrightarrow> \<forall>m\<in>monomials_of R (P \<Oplus> Q). set_mset m \<subseteq> I"
+  proof
+    fix P Q
+    fix m
+    assume A: "P \<in> (carrier R [\<X>\<^bsub>I\<^esub>])" "\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> I"
+                "Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>])" "\<forall>m\<in>monomials_of R Q. set_mset m \<subseteq> I"
+                  " m \<in> monomials_of R (P \<Oplus> Q)"
+    show "set_mset m \<subseteq> I"
+    proof-
+      have "m \<in> monomials_of R P \<or> m \<in> monomials_of R Q"
+        using A using monomials_of_add[of P Q] 
+        by blast
+      then show ?thesis using A 
+        by blast
+    qed
+  qed
+  show "\<And>P i. P \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> \<forall>m\<in>monomials_of R P. set_mset m \<subseteq> I \<Longrightarrow> i \<in> I \<Longrightarrow> \<forall>m\<in>monomials_of R (P \<Otimes> i). set_mset m \<subseteq> I"
+  proof
+    fix P 
+    fix i 
+    fix m
+    assume A: "P \<in> (carrier R [\<X>\<^bsub>I\<^esub>])" "\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> I" "i \<in> I" "m \<in> monomials_of R (P \<Otimes> i)"
+    obtain n where "n \<in> monomials_of R P \<and> m = add_mset i n"
+      using A 
+      by (metis image_iff monomials_of_p_mult')
+    then show "set_mset m \<subseteq> I" 
+      using A 
+      by auto
+  qed
+qed
+
+lemma mset_to_IP_indices':
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "m \<in> monomials_of R P"
+  shows "set_mset m \<subseteq> I"
+  using assms(1) assms(2) mset_to_IP_indices by blast
+
+lemma one_mset_to_IP: 
+ "mset_to_IP R {#} = indexed_const \<one>"
+  unfolding mset_to_IP_def indexed_const_def
+  by blast
+
+lemma mset_to_IP_closed:
+  shows "set_mset m \<subseteq> I \<Longrightarrow>mset_to_IP R m \<in> indexed_pset I (carrier R) "
+  apply(induction m)
+  apply (simp add: indexed_pset.indexed_const one_mset_to_IP)
+  by (metis (no_types, lifting) add_mset_commute indexed_pset.simps
+      monom_add_mset mset_add subset_iff union_single_eq_member)
+
+lemma mset_to_IP_closed':
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "m \<in> monomials_of R P"
+  shows "mset_to_IP R m \<in> indexed_pset I (carrier R)"
+  by (meson assms(1) assms(2) mset_to_IP_closed mset_to_IP_indices')
+
+text\<open>This lemma expresses closure under multiplcation for indexed polynomials.\<close>
+
+lemma  P_ring_mult_closed:
+  assumes "carrier_coeff P"
+  assumes "carrier_coeff Q"
+  shows  "carrier_coeff (P_ring_mult R P Q)"
+  unfolding carrier_coeff_def
+proof
+  fix m
+  have "(\<lambda>x. P x \<otimes> Q (m - x)) \<in> mset_factors m \<rightarrow> carrier R"
+  proof
+    fix x
+    assume "x \<in> mset_factors m"
+    then show "P x \<otimes> Q (m - x) \<in> carrier R"
+      using assms  carrier_coeffE
+      by blast
+  qed
+  then show "(P \<Otimes>\<^sub>p Q) m \<in> carrier R"
+    using assms finsum_closed[of "(\<lambda>x. (P x) \<otimes> (Q (m - x)))" "mset_factors m"]
+    unfolding carrier_coeff_def  P_ring_mult_def
+    by blast
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Multivariable Polynomial Induction\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma mpoly_induct:
+  assumes "\<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card (monomials_of R Q) = 0 \<Longrightarrow> P Q"
+  assumes "\<And>n. (\<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card (monomials_of R Q) \<le>  n \<Longrightarrow> P Q)
+             \<Longrightarrow> (\<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card (monomials_of R Q) \<le> (Suc n) \<Longrightarrow> P Q)"
+  assumes "Q \<in> indexed_pset I (carrier R)"
+  shows "P Q"
+proof-
+  have "\<And>m. \<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card(monomials_of R Q) \<le> m \<Longrightarrow> P Q"
+  proof-
+    fix m
+    show "\<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card(monomials_of R Q) \<le> m \<Longrightarrow> P Q"
+      apply(induction m)
+      using assms(1)
+       apply blast
+      using assms 
+      by blast
+  qed
+  then show ?thesis 
+    using assms(3) by blast
+qed
+
+lemma monomials_of_card_zero:
+  assumes "Q \<in> indexed_pset I (carrier R) \<and> card (monomials_of R Q) = 0"
+  shows "Q = indexed_const \<zero>"
+proof-
+  have 0: "carrier_coeff  Q"
+    using assms  indexed_pset_in_carrier 
+    by blast
+  have "\<And>m. Q m = \<zero>"
+    unfolding monomials_of_def
+    using assms monomials_finite 
+    by (metis card_0_eq complement_of_monomials_of empty_iff)
+  then show  ?thesis 
+  using 0 assms unfolding indexed_const_def 
+  by auto
+qed
+
+text\<open>Polynomial induction on the number of monomials with nonzero coefficient:\<close>
+
+lemma mpoly_induct':
+  assumes "P (indexed_const \<zero>)"
+  assumes "\<And>n. (\<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card (monomials_of R Q) \<le>  n \<Longrightarrow> P Q)
+             \<Longrightarrow> (\<And>Q. Q \<in> indexed_pset I (carrier R) \<and> card (monomials_of R Q) = (Suc n) \<Longrightarrow> P Q)"
+  assumes "Q \<in> indexed_pset I (carrier R)"
+  shows "P Q"
+  apply(rule mpoly_induct)
+  using assms(1) monomials_of_card_zero apply blast
+proof-
+  show "\<And>n Q. (\<And>Q. Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) \<le> n \<Longrightarrow> P Q) \<Longrightarrow> Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) \<le> Suc n \<Longrightarrow> P Q"
+  proof-
+    fix n
+    fix Q
+    assume A0: "(\<And>Q. Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) \<le> n \<Longrightarrow> P Q)"
+    assume A1: "Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) \<le> Suc n"
+    show "P Q"
+      apply(cases  "card (monomials_of R Q) = Suc n")
+      using assms A0 A1 
+       apply blast
+      using assms A0 A1 
+      using le_SucE by blast
+  qed
+  show "Q \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+    using assms by auto 
+qed
+
+lemma monomial_poly_split:
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "m \<in> monomials_of R P"
+  shows "(restrict_poly_to_monom_set R P ((monomials_of R P) - {m})) \<Oplus> ((mset_to_IP R m) \<Otimes>\<^sub>p (indexed_const (P m))) = P"
+proof fix x
+  show "(restrict_poly_to_monom_set R P (monomials_of R P - {m}) \<Oplus> (mset_to_IP R m \<Otimes>\<^sub>p indexed_const (P m))) x = P x"
+  proof(cases "x = m")
+    case True
+    have T0: "(restrict_poly_to_monom_set R P (monomials_of R P - {m})) x = \<zero>"
+      unfolding restrict_poly_to_monom_set_def 
+      by (simp add: True)
+    have T1: "(mset_to_IP R m \<Otimes>\<^sub>p indexed_const (P m)) x = P x"
+      using assms True indexed_const_P_multE[of "mset_to_IP R m" I "P m" m]
+              mset_to_IP_simp 
+      by (metis Idl_subset_ideal' carrier_coeffE genideal_one indexed_pset_in_carrier 
+          l_one mset_to_IP_closed' one_closed)
+    then show ?thesis 
+      using T0 True 
+      unfolding indexed_padd_def 
+      using assms(1) carrier_coeffE indexed_pset_in_carrier l_zero
+      by fastforce    
+  next
+    case False
+    then have F0: "(restrict_poly_to_monom_set R P (monomials_of R P - {m})) x = P x"
+    proof(cases "x \<in> monomials_of R P")
+      case True
+      then show ?thesis 
+        by (simp add: False restrict_poly_to_monom_set_def)
+    next
+      case False
+      then show ?thesis 
+        by (simp add: complement_of_monomials_of restrict_poly_to_monom_set_def)              
+    qed
+    have F1: "mset_to_IP R m \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using assms(1) assms(2) mset_to_IP_closed' by blast
+    have F2: "P m \<in> carrier R"
+      using assms(1) carrier_coeffE indexed_pset_in_carrier by blast
+    have F3: "(mset_to_IP R m \<Otimes>\<^sub>p indexed_const (P m)) x = \<zero>"
+      using False F1 F2 assms indexed_const_P_multE[of "mset_to_IP R m" I "P m" x] 
+      by (simp add: F1 \<open>m \<in> monomials_of R P\<close>)
+    then show ?thesis using F0 unfolding indexed_padd_def  
+      using assms(1) carrier_coeffE indexed_pset_in_carrier
+      by fastforce
+  qed
+qed
+
+lemma restrict_not_in_monoms:
+  assumes "a \<notin> monomials_of R P"
+  shows "restrict_poly_to_monom_set R P A = restrict_poly_to_monom_set R P (insert a A)"
+proof
+  fix x
+  show " restrict_poly_to_monom_set R P A x = restrict_poly_to_monom_set R P (insert a A) x "
+    unfolding restrict_poly_to_monom_set_def using assms unfolding monomials_of_def 
+  by simp
+qed
+
+lemma restriction_closed':
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "finite ms"
+  shows "(restrict_poly_to_monom_set R P ms) \<in> indexed_pset I (carrier R)"
+  apply(rule finite.induct[of ms])
+  apply (simp add: assms(2); fail)
+proof-
+  show "restrict_poly_to_monom_set R P {} \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+  proof-
+    have "restrict_poly_to_monom_set R P {} = indexed_const \<zero>"
+      unfolding restrict_poly_to_monom_set_def indexed_const_def by auto
+    then show ?thesis 
+      by (simp add: indexed_pset.indexed_const)
+  qed
+  show "\<And>A a. finite A \<Longrightarrow> restrict_poly_to_monom_set R P A \<in> (carrier R [\<X>\<^bsub>I\<^esub>]) \<Longrightarrow> restrict_poly_to_monom_set R P (insert a A) \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+  proof-
+    fix A
+    fix a 
+    assume A: "restrict_poly_to_monom_set R P A \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+    show "restrict_poly_to_monom_set R P (insert a A) \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+    proof(cases "a \<in> monomials_of R P")
+      case True
+      then have T0: "mset_to_IP R a \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+        using assms(1) mset_to_IP_closed' by blast
+      then have T1: "(mset_to_IP R a \<Otimes>\<^sub>p indexed_const (P a)) \<in>  (carrier R [\<X>\<^bsub>I\<^esub>])"
+        by (meson assms(1) carrier_coeffE indexed_pset_in_carrier 
+      local.ring_axioms ring.indexed_const_P_mult_closed subset_refl)
+
+      show ?thesis
+      proof(cases "a \<in> A")
+        case True
+        then show ?thesis 
+          by (simp add: A insert_absorb)        
+      next
+        case False
+        have "restrict_poly_to_monom_set R P (insert a A) = restrict_poly_to_monom_set R P A \<Oplus>  (mset_to_IP R a \<Otimes>\<^sub>p indexed_const (P a))"
+        proof
+          fix x
+          show "restrict_poly_to_monom_set R P (insert a A) x = (restrict_poly_to_monom_set R P A \<Oplus> (mset_to_IP R a \<Otimes>\<^sub>p indexed_const (P a))) x"
+          proof(cases "x = a")
+            case True
+            then have FT0: "(if x \<in> insert a A then P x else \<zero>) = P x"
+              by simp 
+            have FT1: "(if x \<in> A then P x else \<zero>) = \<zero>"
+              by (simp add: False True)
+            have FT2: "P a \<in> carrier R"
+              using assms(1) carrier_coeffE indexed_pset_in_carrier by blast
+            have FT3: "(mset_to_IP R a \<Otimes>\<^sub>p indexed_const (P a)) x = P x"
+              using T0 FT2 True indexed_const_P_multE[of "mset_to_IP R a" I "P a" x] mset_to_IP_simp[of a]
+              by simp
+            then show ?thesis           
+              using False 
+              unfolding restrict_poly_to_monom_set_def indexed_padd_def
+              using FT0 FT1 FT3  assms  
+            by (simp add: FT2 True)
+          next
+            case F: False
+            then have FT0: "(if x \<in> insert a A then P x else \<zero>) = (if x \<in> A then P x else \<zero>)"
+              by simp 
+            have FT2: "P a \<in> carrier R"
+              using assms(1) carrier_coeffE indexed_pset_in_carrier by blast
+            have FT3: "(mset_to_IP R a \<Otimes>\<^sub>p indexed_const (P a)) x = \<zero>"
+              using T0 FT2 True indexed_const_P_multE[of "mset_to_IP R a" I "P a" x] mset_to_IP_simp[of a]
+              by (simp add: F mset_to_IP_def)
+            show ?thesis             
+              unfolding restrict_poly_to_monom_set_def indexed_padd_def
+            proof-
+
+              show "(if x \<in> insert a A then P x else \<zero>) = (if x \<in> A then P x else \<zero>) \<oplus> (mset_to_IP R a \<Otimes>\<^sub>p indexed_const (P a)) x"
+                apply(cases "x \<in> A")
+                using FT0 FT2 FT3 F False assms  carrier_coeffE indexed_pset_in_carrier local.ring_axioms 
+                apply fastforce
+                    using FT0 FT2 FT3 F False assms 
+                    by simp
+                qed
+          qed
+        qed
+        then show ?thesis 
+          using A T1 indexed_pset.simps by blast      
+      qed
+    next
+      case False
+      then show ?thesis 
+        using A restrict_not_in_monoms by fastforce    
+    qed
+  qed
+qed
+
+lemma restriction_restrict:
+"restrict_poly_to_monom_set R P ms = restrict_poly_to_monom_set R P (ms \<inter> monomials_of R P)"
+proof
+  fix x
+  show "restrict_poly_to_monom_set R P ms x = restrict_poly_to_monom_set R P (ms \<inter> monomials_of R P) x"
+    unfolding restrict_poly_to_monom_set_def monomials_of_def 
+  by simp
+qed
+
+lemma restriction_closed:
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "Q = restrict_poly_to_monom_set R P ms"
+  shows "Q \<in> indexed_pset I (carrier R)"
+proof-
+  have "Q = restrict_poly_to_monom_set R P (ms \<inter> monomials_of R P)"
+    using assms restriction_restrict 
+    by blast
+  then show ?thesis 
+    using assms restriction_closed'[of P I "(ms \<inter> monomials_of R P)"]
+    using monomials_finite 
+    by blast
+qed
+
+lemma monomial_split_card:
+  assumes "P \<in> indexed_pset I (carrier R)"
+  assumes "m \<in> monomials_of R P"
+  shows "card (monomials_of R (restrict_poly_to_monom_set R P ((monomials_of R P) - {m})))= 
+        card (monomials_of R P) -1"
+proof-
+  have 0: "(monomials_of R (restrict_poly_to_monom_set R P ((monomials_of R P) - {m}))) = 
+        (monomials_of R P) - {m}"
+    using assms(1) 
+    by (meson Diff_subset restrict_poly_to_monom_set_monoms)    
+  then have 1:  "card (monomials_of R (restrict_poly_to_monom_set R P ((monomials_of R P) - {m}))) = 
+              card ((monomials_of R P) - {m})"
+    by auto 
+  have " card ((monomials_of R P) - {m}) =  card (monomials_of R P) - 1"
+    using assms(2) 
+  using assms(1) monomials_finite by fastforce
+    then show ?thesis 
+    by (simp add: "1")
+qed
+
+lemma P_ring_mult_closed':
+  assumes "a \<in> indexed_pset I (carrier R)"
+  assumes "b \<in> indexed_pset I (carrier R)"
+  shows "a \<Otimes>\<^sub>p b \<in> indexed_pset I (carrier R)"
+  apply(rule mpoly_induct'[of "\<lambda>b. a \<Otimes>\<^sub>p b \<in> indexed_pset I (carrier R)" I b])
+  using assms(1) indexed_const_P_mult_closed apply blast
+proof-
+  show "b \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+    using assms by auto 
+  show "\<And>n Q. (\<And>Q. Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) \<le> n \<Longrightarrow> a \<Otimes>\<^sub>p Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>])) \<Longrightarrow>
+           Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) = Suc n \<Longrightarrow> a \<Otimes>\<^sub>p Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>])"
+  proof-
+    fix n 
+    fix Q
+    assume A0: "(\<And>Q. Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) \<le> n \<Longrightarrow> a \<Otimes>\<^sub>p Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>]))"
+    assume A1: "Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>]) \<and> card (monomials_of R Q) = Suc n"
+    obtain m where m_def: "m \<in> monomials_of R Q"
+      using A1 
+      by fastforce
+    obtain P where P_def: "P = (restrict_poly_to_monom_set R Q ((monomials_of R Q) - {m}))"
+      by simp
+    have "P \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using P_def A1 restriction_closed 
+      by blast
+    have 0: "a \<Otimes>\<^sub>p P \<in>  (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using A0 P_def 
+      by (metis A1 One_nat_def \<open>P \<in> (carrier R [\<X>\<^bsub>I\<^esub>])\<close> diff_Suc_Suc m_def
+          minus_nat.diff_0 monomial_split_card nat_le_linear)
+    have 1: "a \<Otimes>\<^sub>p (mset_to_IP R m) \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using assms mset_to_IP_mult_closed[of a I m] A1 m_def mset_to_IP_indices 
+      by blast
+    have 2: "a \<Otimes>\<^sub>p (mset_to_IP R m \<Otimes>\<^sub>p indexed_const (Q m)) \<in> (carrier R [\<X>\<^bsub>I\<^esub>])"
+      using P_ring_mult_assoc[of a "mset_to_IP R m" " indexed_const (Q m)"]
+        1 
+      by (metis A1 assms(1) carrier_coeffE indexed_pset.indexed_const
+          indexed_pset_in_carrier local.ring_axioms m_def mset_to_IP_closed' 
+          ring.indexed_const_P_mult_closed set_eq_subset)
+    have 3: "(P \<Oplus> (mset_to_IP R m \<Otimes>\<^sub>p indexed_const (Q m))) = Q"
+      using P_def monomial_poly_split[of Q I m]
+      using A1 m_def by blast
+    have 4: "(a \<Otimes>\<^sub>p P ) \<Oplus> (a \<Otimes>\<^sub>p (mset_to_IP R m \<Otimes>\<^sub>p indexed_const (Q m))) = a \<Otimes>\<^sub>p Q"
+      using assms 2 3 P_ring_rdistr[of a P "(mset_to_IP R m \<Otimes>\<^sub>p indexed_const (Q m))"] 
+      by (metis A1 Idl_subset_ideal' P_ring_mult_closed \<open>P \<in> (carrier R [\<X>\<^bsub>I\<^esub>])\<close> 
+          carrier_coeffE indexed_pset.indexed_const indexed_pset_in_carrier m_def 
+          mset_to_IP_closed' onepideal principalideal.generate)
+    then show " a \<Otimes>\<^sub>p Q \<in>  (carrier R [\<X>\<^bsub>I\<^esub>])"
+      by (metis "0" "2" indexed_pset.indexed_padd)
+  qed
+qed
+
+end 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Subtraction of Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition P_ring_uminus :: "('a,'b) ring_scheme \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> ('a,'c) mvar_poly" where
+"P_ring_uminus R P = (\<lambda>m. \<ominus>\<^bsub>R\<^esub> (P m))"
+
+context ring
+
+begin
+
+
+lemma P_ring_uminus_eq:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  shows "P_ring_uminus R a  = a \<Otimes>\<^sub>p (indexed_const (\<ominus> \<one>))"
+proof
+    fix x
+    have "(a \<Otimes>\<^sub>p indexed_const (\<ominus> \<one>)) x = a x \<otimes> \<ominus> \<one>"
+      using indexed_const_P_multE[of a I "\<ominus> \<one>" x] assms
+      by blast
+    then show "P_ring_uminus R a x = (a \<Otimes>\<^sub>p indexed_const (\<ominus> \<one>)) x"
+      unfolding P_ring_uminus_def 
+      using assms 
+      by (metis Idl_subset_ideal' carrier_coeffE indexed_pset_in_carrier
+        one_closed onepideal principalideal.generate r_minus r_one)
+qed
+
+lemma P_ring_uminus_closed:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  shows "P_ring_uminus R a \<in> indexed_pset I (carrier R)"
+  using assms P_ring_uminus_eq
+  by (metis add.l_inv_ex indexed_const_P_mult_closed minus_equality one_closed)
+
+lemma P_ring_uminus_add:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  shows "P_ring_uminus R a \<Oplus> a = indexed_const \<zero>"
+proof
+  fix x
+  show "(P_ring_uminus R a \<Oplus> a) x = indexed_const \<zero> x"
+    using assms 
+    unfolding P_ring_uminus_def indexed_const_def indexed_padd_def
+    by (meson carrier_coeffE indexed_pset_in_carrier 
+        local.ring_axioms ring.ring_simprules(9) set_eq_subset)
+qed
+
+text\<open>multiplication by 1\<close>
+
+lemma one_mult_left:
+  assumes "a \<in> indexed_pset I (carrier R)"
+  shows "(indexed_const \<one>) \<Otimes>\<^sub>p a = a"
+proof
+  fix m
+  show "(indexed_const \<one> \<Otimes>\<^sub>p a) m = a m "
+    unfolding indexed_const_def P_ring_mult_def
+  proof-
+    have 0: "(\<Oplus>x\<in>((mset_factors m) - {{#}}). (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x)) = \<zero>"
+    proof-
+      have "\<And>x. x\<in>((mset_factors m) - {{#}}) \<Longrightarrow>  (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x) = \<zero> \<otimes> a (m - x)"
+        by simp
+      then have "\<And>x. x\<in>((mset_factors m) - {{#}}) \<Longrightarrow>  (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x) = \<zero>"
+        using assms 
+        by (metis carrier_coeffE  indexed_pset_in_carrier local.ring_axioms ring.ring_simprules(24) set_eq_subset)
+      then show ?thesis 
+        by (meson add.finprod_one_eqI)
+    qed
+    have 1: "(\<lambda>x. (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x)) {#} = a m"
+      by (metis (full_types) assms carrier_coeffE diff_zero 
+          indexed_pset_in_carrier local.ring_axioms ring.ring_simprules(12) set_eq_subset)
+    have 2: "(\<Oplus>x\<in>insert {#} (mset_factors m - {{#}}). (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x)) = 
+              (\<lambda>x. (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x)) {#} \<oplus>
+             (\<Oplus>x\<in>((mset_factors m) - {{#}}). (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x))"
+    proof-
+      have 20:"finite (mset_factors m - {{#}})" 
+        by simp
+      have 21: " {#} \<notin> mset_factors m - {{#}}"
+        by blast
+      have 22: " (\<lambda>x. (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x)) \<in> mset_factors m - {{#}} \<rightarrow> carrier R"
+      proof
+        fix x
+        assume A: "x \<in> mset_factors m - {{#}}"
+        show "(if x = {#} then \<one> else \<zero>) \<otimes> a (m - x) \<in> carrier R"
+          apply(cases "x = {#}")
+          using A 
+          apply blast
+              using assms carrier_coeffE indexed_pset_in_carrier  local.ring_axioms 
+              one_closed ring.ring_simprules(5) set_eq_subset zero_closed
+              by (metis (mono_tags, opaque_lifting))
+      qed
+      have 23: "(if {#} = {#} then \<one> else \<zero>) \<otimes> a (m - {#}) \<in> carrier R"
+        by (metis "1" assms carrier_coeffE indexed_pset_in_carrier set_eq_subset)
+      show ?thesis 
+        using 20 21 22 23 finsum_insert[of  "((mset_factors m) - {{#}})" "{#}"
+            " (\<lambda>x. (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x))"]
+        by blast
+    qed
+    have 3: "insert {#} (mset_factors m - {{#}}) = mset_factors m"
+    proof-
+      have "{#} \<in> mset_factors m"
+        using monom_divides_factors subset_mset.zero_le 
+        by blast
+      then show ?thesis 
+        by blast
+    qed
+    show "(\<Oplus>x\<in>mset_factors m. (if x = {#} then \<one> else \<zero>) \<otimes> a (m - x)) = a m"
+      using 0 1 2 3 assms 
+      by (metis (no_types, lifting) Idl_subset_ideal' carrier_coeffE 
+          genideal_one indexed_pset_in_carrier one_closed r_zero) 
+  qed
+qed
+
+end 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+                     subsection\<open>The Carrier of the Ring of Indexed Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+abbreviation(input) Pring_set where
+"Pring_set R I \<equiv> ring.indexed_pset R I (carrier R) "
+
+context ring
+
+begin
+
+lemma Pring_set_zero:
+  assumes "f \<in> Pring_set R I"
+  assumes "\<not> set_mset m \<subseteq>  I" 
+  shows " f m = \<zero>\<^bsub>R\<^esub>"
+proof-
+  have "\<not> set_mset m \<subseteq>  I \<Longrightarrow> f m = \<zero>\<^bsub>R\<^esub>"
+  apply(induction m)
+  apply simp
+  by (meson assms complement_of_monomials_of mset_to_IP_indices')
+  then show ?thesis 
+    using assms(2) by blast
+qed
+
+lemma(in ring) Pring_cfs_closed:
+  assumes "P \<in> Pring_set R I"
+  shows "P m \<in> carrier R"
+  using assms carrier_coeffE indexed_pset_in_carrier 
+  by blast
+
+lemma indexed_pset_mono_aux:
+  assumes "P \<in> indexed_pset I S"
+  shows "S \<subseteq> T \<Longrightarrow> P \<in> indexed_pset I T"
+  using assms 
+  apply(induction P)
+  using indexed_pset.indexed_const apply blast
+  using indexed_pset.indexed_padd apply blast
+  by (simp add: indexed_pset.indexed_pmult)
+
+lemma indexed_pset_mono:
+  assumes "S \<subseteq> T"
+  shows "indexed_pset I S \<subseteq> indexed_pset I T"
+  using assms indexed_pset_mono_aux 
+  by blast
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Scalar Multiplication\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition poly_scalar_mult :: "('a, 'b) ring_scheme \<Rightarrow> 'a \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> ('a,'c) mvar_poly" where
+"poly_scalar_mult R c P = (\<lambda> m. c \<otimes>\<^bsub>R\<^esub> P m)"
+
+lemma(in cring) poly_scalar_mult_eq:
+  assumes "c \<in> carrier R"
+  shows "P \<in> Pring_set R (I :: 'c set) \<Longrightarrow> poly_scalar_mult R c P = indexed_const c \<Otimes>\<^sub>p P"
+proof(erule indexed_pset.induct)
+  show "\<And>k. k \<in> carrier R \<Longrightarrow> poly_scalar_mult R c (indexed_const k) = indexed_const c \<Otimes>\<^sub>p indexed_const k"
+  proof-
+    fix k 
+    assume A0: "k \<in> carrier R"
+    show "poly_scalar_mult R c (indexed_const k)  = (indexed_const c \<Otimes>\<^sub>p indexed_const k) "
+      unfolding poly_scalar_mult_def 
+    proof
+      show "\<And>m. c \<otimes> indexed_const k m = (indexed_const c \<Otimes>\<^sub>p indexed_const k) m"
+          using indexed_const_P_mult_eq
+          by (metis A0  assms indexed_const_P_mult_eq indexed_const_def local.semiring_axioms semiring.r_null)
+    qed
+  qed   
+  show "\<And>P Q. P \<in> Pring_set R I \<Longrightarrow>
+           poly_scalar_mult R c P = indexed_const c \<Otimes>\<^sub>p P \<Longrightarrow>
+           Q \<in> Pring_set R I \<Longrightarrow> poly_scalar_mult R c Q = indexed_const c \<Otimes>\<^sub>p Q \<Longrightarrow> poly_scalar_mult R c (P \<Oplus> Q) = indexed_const c \<Otimes>\<^sub>p (P \<Oplus> Q)"
+  proof
+    fix P Q :: "'c monomial \<Rightarrow> 'a"
+    fix x :: "'c monomial"
+    assume A0: "P \<in> Pring_set R I"
+    assume A1: "poly_scalar_mult R c P = indexed_const c \<Otimes>\<^sub>p P"
+    assume A2: "Q \<in> Pring_set R I"
+    assume A3: "poly_scalar_mult R c Q = indexed_const c \<Otimes>\<^sub>p Q"
+    show "poly_scalar_mult R c (P \<Oplus> Q) x = (indexed_const c \<Otimes>\<^sub>p (P \<Oplus> Q)) x"
+    proof-
+      have P0: "poly_scalar_mult R c (P \<Oplus> Q) = (poly_scalar_mult R c P) \<Oplus> (poly_scalar_mult R c Q)"
+        unfolding poly_scalar_mult_def
+      proof
+        fix m
+        show "c \<otimes> (P \<Oplus> Q) m = ((\<lambda>m. c \<otimes> P m) \<Oplus> (\<lambda>m. c \<otimes> Q m)) m"
+        proof-
+          have LHS: "c \<otimes> (P \<Oplus> Q) m = c \<otimes> ( P m \<oplus> Q m) "
+            by (simp add: indexed_padd_def)
+          then have LHS1: "c \<otimes> (P \<Oplus> Q) m = (c \<otimes>  P m) \<oplus> (c \<otimes>Q m) "
+          proof-
+            have 0: "carrier_coeff P"
+              using A0 indexed_pset_in_carrier 
+              by blast
+            have 1: "P m \<in> carrier R"
+              using 0 carrier_coeffE by blast 
+            have 2: "carrier_coeff Q"
+              using A2 indexed_pset_in_carrier 
+              by blast
+            have 3: "Q m \<in> carrier R" using 2 
+              using carrier_coeff_def 
+              by blast
+            show ?thesis using 1 3 assms 
+              by (simp add: LHS r_distr)
+          qed
+          then show ?thesis 
+            by (simp add: indexed_padd_def)
+        qed
+      qed
+      have P1: "poly_scalar_mult R c (P \<Oplus> Q) = (indexed_const c \<Otimes>\<^sub>p P) \<Oplus> (indexed_const c \<Otimes>\<^sub>p Q)"
+        using P0 A1 A3 
+        by simp
+      have P2: "indexed_const c \<in> Pring_set R I"
+        using assms indexed_pset.indexed_const by blast
+      show ?thesis 
+        using P2 A0 A2 P1 
+        by (metis P_ring_rdistr indexed_pset_in_carrier set_eq_subset)
+    qed
+  qed      
+  show "\<And>P i. P \<in> Pring_set R I \<Longrightarrow>
+           poly_scalar_mult R c P = indexed_const c \<Otimes>\<^sub>p P \<Longrightarrow> i \<in> I \<Longrightarrow> poly_scalar_mult R c (P \<Otimes> i) = indexed_const c \<Otimes>\<^sub>p (P \<Otimes> i)"
+  proof-
+    fix P 
+    fix i
+    assume A0:  "P \<in> Pring_set R I"
+    assume A1: "poly_scalar_mult R c P = indexed_const c \<Otimes>\<^sub>p P"
+    assume A2: "i \<in> I"
+    show "poly_scalar_mult R c (P \<Otimes> i) = indexed_const c \<Otimes>\<^sub>p (P \<Otimes> i)"
+    proof
+      fix x
+      show "poly_scalar_mult R c (P \<Otimes> i) x = (indexed_const c \<Otimes>\<^sub>p (P \<Otimes> i)) x"
+      proof-
+        have RHS: "(indexed_const c \<Otimes>\<^sub>p (P \<Otimes> i)) = (indexed_const c \<Otimes>\<^sub>p P) \<Otimes> i"
+        proof-
+          have B0: "P \<Otimes> i = P \<Otimes>\<^sub>p (mset_to_IP R {#i#})"
+            by (meson A0 A2 poly_index_mult)
+          have B1: " (indexed_const c \<Otimes>\<^sub>p P) \<Otimes> i = (indexed_const c \<Otimes>\<^sub>p P) \<Otimes>\<^sub>p (mset_to_IP R {#i#})"
+            by (meson A0 A2 P_ring_mult_closed' assms indexed_pset.simps poly_index_mult)
+          have B2: "(indexed_const c \<Otimes>\<^sub>p (P \<Otimes> i)) = indexed_const c \<Otimes>\<^sub>p P \<Otimes>\<^sub>p (mset_to_IP R {#i#})"
+            by (metis A0 A2 B1 assms cring.P_ring_mult_comm indexed_const_var_mult
+                indexed_pmult_in_carrier indexed_pset.indexed_const indexed_pset_in_carrier
+                is_cring set_eq_subset)
+          show ?thesis using A0 A1 A2 B2 B1 assms 
+          by (simp add: A0)
+        then have RHS': "(indexed_const c \<Otimes>\<^sub>p (P \<Otimes> i)) = (poly_scalar_mult R c P) \<Otimes> i"
+          using A0 A1 A2 assms 
+          by simp
+        qed
+        show ?thesis apply(cases "i \<in># x")
+          unfolding poly_scalar_mult_def 
+           apply (metis A1 RHS poly_scalar_mult_def indexed_pmult_def )
+          by (metis RHS assms indexed_pmult_def r_null)
+      qed
+    qed
+  qed
+qed
+
+lemma(in cring) poly_scalar_mult_const:
+  assumes "c \<in> carrier R"
+  assumes "k \<in> carrier R"
+  shows "poly_scalar_mult R k (indexed_const c) = indexed_const (k \<otimes> c)"
+  using assms poly_scalar_mult_eq 
+  by (simp add: poly_scalar_mult_eq indexed_const_P_mult_eq indexed_pset.indexed_const)
+ 
+lemma(in cring) poly_scalar_mult_closed:
+  assumes "c \<in> carrier R"
+  assumes "P \<in> Pring_set R I" 
+  shows "poly_scalar_mult R c P \<in> Pring_set R I"
+  using assms poly_scalar_mult_eq 
+  by (metis P_ring_mult_closed' indexed_pset.indexed_const)
+
+lemma(in cring) poly_scalar_mult_zero:
+  assumes "P \<in> Pring_set R I"
+  shows "poly_scalar_mult R \<zero> P = indexed_const \<zero>"
+proof
+  fix x 
+  show "poly_scalar_mult R \<zero> P x = indexed_const \<zero> x"
+    unfolding poly_scalar_mult_def 
+    using assms 
+    by (metis Pring_cfs_closed indexed_zero_def l_null)    
+qed
+
+lemma(in cring) poly_scalar_mult_one:
+  assumes "P \<in> Pring_set R I"
+  shows "poly_scalar_mult R \<one> P = P"
+proof
+  fix x show "poly_scalar_mult R \<one> P x = P x"
+    using assms 
+    by (metis one_closed one_mult_left poly_scalar_mult_eq)
+qed   
+
+lemma(in cring) times_poly_scalar_mult:
+  assumes "P \<in> Pring_set R I"
+  assumes "Q \<in> Pring_set R I"
+  assumes "k \<in> carrier R"
+  shows "P \<Otimes>\<^sub>p (poly_scalar_mult R k Q) = poly_scalar_mult R k (P \<Otimes>\<^sub>p Q)"
+proof-
+  have "P \<Otimes>\<^sub>p (poly_scalar_mult R k Q) = P \<Otimes>\<^sub>p (indexed_const k) \<Otimes>\<^sub>p Q"
+  by (metis assms(1) assms(2) assms(3)  indexed_pset_mono_aux 
+      local.ring_axioms poly_scalar_mult_eq ring.P_ring_mult_assoc ring.indexed_pset.intros(1) 
+      ring.indexed_pset_in_carrier subset_refl)
+  then have  "P \<Otimes>\<^sub>p (poly_scalar_mult R k Q) =  (indexed_const k) \<Otimes>\<^sub>p P \<Otimes>\<^sub>p Q"
+  by (metis P_ring_mult_comm assms(1) assms(3) local.ring_axioms ring.indexed_pset.indexed_const ring.indexed_pset_in_carrier subset_refl)
+  then show ?thesis 
+    by (metis (no_types, opaque_lifting) P_ring_mult_closed' Pring_cfs_closed assms(1) assms(2) assms(3) 
+        carrier_coeff_def  indexed_pset.indexed_const  local.ring_axioms poly_scalar_mult_eq ring.P_ring_mult_assoc)
+qed
+
+lemma(in cring) poly_scalar_mult_times:
+  assumes "P \<in> Pring_set R I"
+  assumes "Q \<in> Pring_set R I"
+  assumes "k \<in> carrier R"
+  shows " poly_scalar_mult R k (Q \<Otimes>\<^sub>p P) = (poly_scalar_mult R k Q) \<Otimes>\<^sub>p P"
+  using assms times_poly_scalar_mult 
+  by (metis (no_types, opaque_lifting) P_ring_mult_comm  cring.P_ring_mult_comm 
+      cring.poly_scalar_mult_closed is_cring local.ring_axioms ring.indexed_pset_in_carrier subset_refl)
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Defining the Ring of Indexed Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+definition Pring :: "('b, 'e) ring_scheme  \<Rightarrow> 'a set  \<Rightarrow> ('b, ('b,'a) mvar_poly) module" where
+
+"Pring R I \<equiv> \<lparr>  carrier = Pring_set R I,
+                Group.monoid.mult = P_ring_mult R ,
+                one = ring.indexed_const R \<one>\<^bsub>R\<^esub>,
+                zero = ring.indexed_const R  \<zero>\<^bsub>R\<^esub>,
+                add = ring.indexed_padd R,
+                smult = poly_scalar_mult R\<rparr>"
+
+context ring
+
+begin
+
+lemma Pring_car:
+"carrier (Pring R I) = Pring_set R I"
+  unfolding Pring_def
+  by auto 
+
+text\<open>Definitions of the operations and constants:\<close>
+
+lemma Pring_mult:
+"a \<otimes>\<^bsub>Pring R I\<^esub> b = a \<Otimes>\<^sub>p b"
+  unfolding Pring_def 
+  by simp 
+
+lemma Pring_add:
+"a \<oplus>\<^bsub>Pring R I\<^esub> b = a \<Oplus> b"
+  unfolding Pring_def 
+  by simp 
+
+lemma Pring_zero:
+"\<zero>\<^bsub>Pring R I\<^esub> = indexed_const \<zero>"
+  unfolding Pring_def by simp 
+
+lemma Pring_one:
+"\<one>\<^bsub>Pring R I\<^esub> = indexed_const \<one>"
+  unfolding Pring_def by simp 
+
+lemma Pring_smult:
+"(\<odot>\<^bsub>Pring R I\<^esub>) = (poly_scalar_mult R)"
+  unfolding Pring_def by simp 
+
+lemma Pring_carrier_coeff:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "carrier_coeff a"
+  using assms indexed_pset_in_carrier[of "(carrier R)" a I] Pring_car
+  by blast
+
+lemma Pring_carrier_coeff'[simp]:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "a m \<in> carrier R"
+  using Pring_car[of I] assms carrier_coeffE indexed_pset_in_carrier 
+  by blast
+
+lemma Pring_add_closed:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  shows "a \<oplus>\<^bsub>Pring R I\<^esub> b \<in> carrier (Pring R I)"
+  using assms  Pring_def[of R I]
+  by (simp add: Pring_def[of R I] indexed_pset.indexed_padd)
+
+lemma Pring_mult_closed:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  shows "a \<otimes>\<^bsub>Pring R I\<^esub> b \<in> carrier (Pring R I)"
+  using assms  P_ring_mult_closed'[of a I b] Pring_car[of I] Pring_mult[of I a b]
+  by (simp add: \<open>a \<otimes>\<^bsub>Pring R I\<^esub> b = a \<Otimes>\<^sub>p b\<close> \<open>carrier (Pring R I) = Pring_set R I\<close>)
+
+lemma Pring_one_closed:
+"\<one>\<^bsub>Pring R I\<^esub> \<in> carrier (Pring R I)"
+proof-
+  have "indexed_const \<one> \<in> carrier (Pring R I)"
+    using Pring_car indexed_pset.simps by blast
+  then show ?thesis 
+    unfolding Pring_def by auto 
+qed
+
+lemma Pring_zero_closed:
+"\<zero>\<^bsub>Pring R I\<^esub> \<in> carrier (Pring R I)"
+proof-
+  have "indexed_const \<zero> \<in> carrier (Pring R I)"
+    using Pring_car indexed_pset.simps by blast
+  then show ?thesis 
+    unfolding Pring_def by auto 
+qed
+
+lemma Pring_var_closed:
+  assumes "i \<in> I"
+  shows "var_to_IP R i \<in> carrier (Pring R I)"
+unfolding var_to_IP_def 
+  by (metis Pring_car Pring_one_closed assms indexed_pset.indexed_pmult 
+      local.ring_axioms monom_add_mset one_mset_to_IP ring.Pring_one)
+
+text\<open>Properties of addition:\<close>
+
+lemma Pring_add_assoc:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  assumes "c \<in> carrier (Pring R I)"
+  shows "a \<oplus>\<^bsub>Pring R I\<^esub> (b \<oplus>\<^bsub>Pring R I\<^esub> c) = (a \<oplus>\<^bsub>Pring R I\<^esub> b) \<oplus>\<^bsub>Pring R I\<^esub> c"
+proof-
+  have "a \<Oplus> (b \<Oplus> c) = (a \<Oplus>  b) \<Oplus>  c"
+  proof
+    fix x 
+    have "carrier_coeff a" "carrier_coeff b" "carrier_coeff c"
+      using assms Pring_car[of I] Pring_carrier_coeff   apply blast
+        using assms Pring_car[of I] Pring_carrier_coeff   apply blast
+          using assms Pring_car[of I] Pring_carrier_coeff   by blast
+    then have "a x \<in> carrier R" "b x \<in> carrier R" "c x \<in> carrier R"
+      using carrier_coeffE apply blast
+        using \<open>carrier_coeff b\<close> carrier_coeffE apply blast
+          using \<open>carrier_coeff c\<close> carrier_coeffE by blast
+    show "(a \<Oplus> (b \<Oplus> c)) x = (a \<Oplus> b \<Oplus> c) x"
+      unfolding indexed_padd_def 
+      using assms 
+      by (simp add: \<open>a x \<in> carrier R\<close> \<open>b x \<in> carrier R\<close> \<open>c x \<in> carrier R\<close> add.m_assoc)
+  qed
+  then show ?thesis
+    using assms  
+  by (simp add: Pring_add)
+qed
+
+lemma Pring_add_comm:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  shows "a \<oplus>\<^bsub>Pring R I\<^esub> b = b \<oplus>\<^bsub>Pring R I\<^esub> a"
+proof-
+  have "a \<Oplus> b = b \<Oplus> a"
+  proof fix x 
+    show "(a \<Oplus> b) x = (b \<Oplus> a) x"
+      using assms 
+      by (metis abelian_monoid.a_comm abelian_monoid_axioms 
+          indexed_padd_def local.ring_axioms ring.Pring_carrier_coeff')
+  qed
+  then show ?thesis 
+    by (simp add: Pring_add)
+qed
+
+lemma Pring_add_zero:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "a \<oplus>\<^bsub>Pring R I\<^esub> \<zero>\<^bsub>Pring R I\<^esub> = a"
+        "\<zero>\<^bsub>Pring R I\<^esub> \<oplus>\<^bsub>Pring R I\<^esub> a  = a"
+  using assms Pring_zero Pring_add 
+   apply (metis Pring_carrier_coeff indexed_padd_zero(1))
+  using assms Pring_zero Pring_add 
+   by (metis Pring_carrier_coeff indexed_padd_zero(2))
+
+text\<open>Properties of multiplication\<close>
+
+lemma Pring_mult_assoc:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  assumes "c \<in> carrier (Pring R I)"
+  shows "a \<otimes>\<^bsub>Pring R I\<^esub> (b \<otimes>\<^bsub>Pring R I\<^esub> c) = (a \<otimes>\<^bsub>Pring R I\<^esub> b) \<otimes>\<^bsub>Pring R I\<^esub> c"
+  using assms P_ring_mult_assoc[of a b c]
+  by (metis Pring_carrier_coeff Pring_mult)
+
+lemma Pring_mult_comm:
+  assumes "cring R"
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  shows "a \<otimes>\<^bsub>Pring R I\<^esub> b = b \<otimes>\<^bsub>Pring R I\<^esub> a"
+  using assms Pring_carrier_coeff[of a I] Pring_carrier_coeff[of b I]
+        Pring_mult[of I b a]  Pring_mult[of I a b] cring.P_ring_mult_comm[of R a b]
+  by metis 
+
+lemma Pring_mult_one:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "a \<otimes>\<^bsub>Pring R I\<^esub> \<one>\<^bsub>Pring R I\<^esub> = a"
+proof
+  fix x
+  show "(a \<otimes>\<^bsub>Pring R I\<^esub> \<one>\<^bsub>Pring R I\<^esub>) x = a x "
+  proof-
+    have 0: "(a \<otimes>\<^bsub>Pring R I\<^esub> \<one>\<^bsub>Pring R I\<^esub>) x = (a \<Otimes>\<^sub>p indexed_const \<one>) x"
+        using assms Pring_mult[of I a "\<one>\<^bsub>Pring R I\<^esub>" ] Pring_one[of I]
+        by metis 
+    have 1: "\<one> \<in> carrier R"
+      by simp
+    have 2: "(a \<otimes>\<^bsub>Pring R I\<^esub> \<one>\<^bsub>Pring R I\<^esub>) x =  a x \<otimes> \<one>"
+      using 0 1 indexed_const_P_multE[of a I \<one> x]
+        assms Pring_car[of I]
+      by metis  
+    then show ?thesis 
+      using assms by auto
+  qed
+qed
+
+lemma Pring_mult_one':
+  assumes "a \<in> carrier (Pring R I)"
+  shows "\<one>\<^bsub>Pring R I\<^esub>  \<otimes>\<^bsub>Pring R I\<^esub> a = a"
+  using one_mult_left[of a I]
+        assms Pring_one Pring_mult
+  by (simp add: Pring_mult Pring_one Pring_car)
+
+text\<open>Distributive laws\<close>
+
+lemma Pring_mult_rdistr:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  assumes "c \<in> carrier (Pring R I)"
+  shows "a \<otimes>\<^bsub>Pring R I\<^esub> (b \<oplus>\<^bsub>Pring R I\<^esub> c) = (a \<otimes>\<^bsub>Pring R I\<^esub> b) \<oplus>\<^bsub>Pring R I\<^esub> (a \<otimes>\<^bsub>Pring R I\<^esub> c)"
+proof-
+  have "a \<Otimes>\<^sub>p (b \<Oplus> c) = a \<Otimes>\<^sub>p b \<Oplus> (a \<Otimes>\<^sub>p c)"
+  using P_ring_rdistr[of a b c] 
+        assms Pring_carrier_coeff 
+  by metis
+  then have "a \<Otimes>\<^sub>p (b \<oplus>\<^bsub>Pring R I\<^esub> c) = a \<Otimes>\<^sub>p b \<oplus>\<^bsub>Pring R I\<^esub> (a \<Otimes>\<^sub>p c)"
+    using       Pring_add[of I b c] Pring_add[of I "a \<Otimes>\<^sub>p b" "a \<Otimes>\<^sub>p c"]
+    by auto 
+  then have "a \<otimes>\<^bsub>Pring R I\<^esub> (b \<oplus>\<^bsub>Pring R I\<^esub> c) = (a \<Otimes>\<^sub>p b) \<oplus>\<^bsub>Pring R I\<^esub> (a \<Otimes>\<^sub>p c)"
+    using  Pring_mult[of I a "(b \<oplus>\<^bsub>Pring R I\<^esub> c)"] 
+    by auto 
+  then have "a \<otimes>\<^bsub>Pring R I\<^esub> (b \<oplus>\<^bsub>Pring R I\<^esub> c) = (a \<otimes>\<^bsub>Pring R I\<^esub> b) \<oplus>\<^bsub>Pring R I\<^esub> (a \<Otimes>\<^sub>p c)"
+    using Pring_mult[of I a b] by metis 
+  then show ?thesis 
+    using Pring_mult[of I a c] by metis 
+qed
+      
+lemma Pring_mult_ldistr:
+  assumes "a \<in> carrier (Pring R I)"
+  assumes "b \<in> carrier (Pring R I)"
+  assumes "c \<in> carrier (Pring R I)"
+  shows "(b \<oplus>\<^bsub>Pring R I\<^esub> c) \<otimes>\<^bsub>Pring R I\<^esub> a  = (b \<otimes>\<^bsub>Pring R I\<^esub> a) \<oplus>\<^bsub>Pring R I\<^esub> (c \<otimes>\<^bsub>Pring R I\<^esub> a)"
+proof-
+  have "(b \<Oplus> c) \<Otimes>\<^sub>p a = b \<Otimes>\<^sub>p a \<Oplus> (c \<Otimes>\<^sub>p a)"
+  using P_ring_ldistr[of a b c] 
+        assms Pring_carrier_coeff 
+  by metis
+  then have " (b \<oplus>\<^bsub>Pring R I\<^esub> c)  \<Otimes>\<^sub>p a = b \<Otimes>\<^sub>p a \<oplus>\<^bsub>Pring R I\<^esub> (c \<Otimes>\<^sub>p a)"
+    using       Pring_add[of I b c] Pring_add[of I "b \<Otimes>\<^sub>p a" "c \<Otimes>\<^sub>p a"]
+    by auto 
+  then have " (b \<oplus>\<^bsub>Pring R I\<^esub> c) \<otimes>\<^bsub>Pring R I\<^esub> a = (b \<Otimes>\<^sub>p a) \<oplus>\<^bsub>Pring R I\<^esub> (c \<Otimes>\<^sub>p a)"
+    using  Pring_mult[of I "(b \<oplus>\<^bsub>Pring R I\<^esub> c)" a] 
+    by auto 
+  then have "(b \<oplus>\<^bsub>Pring R I\<^esub> c) \<otimes>\<^bsub>Pring R I\<^esub> a = (b \<otimes>\<^bsub>Pring R I\<^esub> a) \<oplus>\<^bsub>Pring R I\<^esub> (c \<Otimes>\<^sub>p a)"
+    using Pring_mult[of I b a] by metis 
+  then show ?thesis 
+    using Pring_mult[of I c a] by metis 
+qed
+
+text\<open>Properties of subtraction:\<close>
+
+lemma Pring_uminus:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "P_ring_uminus R a \<in> carrier (Pring R I)"
+  using P_ring_uminus_closed[of a I] Pring_car[of I] assms 
+  by metis 
+
+lemma Pring_subtract:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "P_ring_uminus R a \<oplus>\<^bsub>Pring R I\<^esub> a = \<zero>\<^bsub>Pring R I\<^esub>"
+        "a \<oplus>\<^bsub>Pring R I\<^esub> P_ring_uminus R a = \<zero>\<^bsub>Pring R I\<^esub>"
+  using assms Pring_add[of I "P_ring_uminus R a " a] Pring_zero[of I]
+  apply  (simp add: Pring_car local.ring_axioms ring.P_ring_uminus_add)
+    using assms Pring_add[of I "P_ring_uminus R a " a] Pring_zero[of I]
+    by (metis P_ring_uminus_add P_ring_uminus_closed Pring_add_comm Pring_car)
+
+text\<open>Pring R I is a ring\<close>
+
+lemma Pring_is_abelian_group:
+  shows "abelian_group (Pring R I)"
+  apply(rule abelian_groupI)
+  apply (simp add: Pring_add_closed)
+    apply (simp add: local.ring_axioms ring.Pring_zero_closed)    
+      apply (simp add: Pring_add_assoc)
+        apply (simp add: Pring_add_comm)
+          apply (simp add: local.ring_axioms ring.Pring_add_zero(2))      
+  using Pring_subtract(1) Pring_uminus 
+  by blast
+
+lemma Pring_is_monoid:
+"Group.monoid (Pring R I)"
+  apply(rule monoidI)
+  using Pring_mult_closed apply blast
+    apply (simp add: Pring_one_closed)   
+      apply (metis Pring_mult_assoc)
+        using Pring_mult_one' 
+        apply blast
+  using Pring_mult_one by blast
+
+lemma Pring_is_ring:
+  shows "ring (Pring R I)"
+  apply(rule ringI)
+  apply (simp add: Pring_is_abelian_group)
+    apply (simp add: Pring_is_monoid)
+      apply (simp add: Pring_mult_ldistr)
+  by (simp add: Pring_mult_rdistr)
+
+lemma Pring_is_cring:
+  assumes "cring R"
+  shows "cring (Pring R I)"
+  apply(rule cringI)
+  apply (simp add: Pring_is_abelian_group)
+   apply (simp add: Pring_is_monoid assms local.ring_axioms 
+          monoid.monoid_comm_monoidI ring.Pring_mult_comm)
+     by (simp add: Pring_mult_ldistr)
+
+lemma Pring_a_inv:
+  assumes "P \<in> carrier (Pring R I)"
+  shows "\<ominus>\<^bsub>Pring R I\<^esub> P = P_ring_uminus R P"
+proof-
+  have 0: "P_ring_uminus R P \<in> carrier (Pring R I)"
+    using Pring_uminus assms 
+    by blast
+  have 1: "P_ring_uminus R P \<oplus>\<^bsub>Pring R I\<^esub> P = \<zero>\<^bsub>Pring R I\<^esub>"
+    using Pring_subtract(1) assms 
+    by blast
+  show ?thesis using 0 1 assms Pring_is_ring
+  by (simp add: Pring_car Pring_is_abelian_group abelian_group.minus_equality)
+qed
+
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Defining the R-Algebra of Indexed Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context cring
+begin
+
+lemma Pring_smult_cfs:
+  assumes "a \<in> carrier R"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "(a \<odot>\<^bsub>Pring R I\<^esub> P) m = a \<otimes> (P m)"
+  using assms Pring_smult 
+  by (simp add: Pring_smult poly_scalar_mult_def)  
+
+lemma Pring_smult_closed:
+      "\<And> a x. [| a \<in> carrier R; x \<in> carrier (Pring R I) |] ==> a \<odot>\<^bsub>(Pring R I)\<^esub> x \<in> carrier (Pring R I)"
+  by (simp add: Pring_car Pring_smult poly_scalar_mult_closed)
+  
+lemma Pring_smult_l_distr:
+      "!!a b x. [| a \<in> carrier R; b \<in> carrier R; x \<in> carrier (Pring R I) |] ==>
+      (a \<oplus> b) \<odot>\<^bsub>(Pring R I)\<^esub> x = (a \<odot>\<^bsub>(Pring R I)\<^esub> x) \<oplus>\<^bsub>(Pring R I)\<^esub> (b \<odot>\<^bsub>(Pring R I)\<^esub> x)"
+proof- fix a b x assume A: "a \<in> carrier R" "b \<in> carrier R" "x \<in> carrier (Pring R I)"
+  show "(a \<oplus> b) \<odot>\<^bsub>Pring R I\<^esub> x = a \<odot>\<^bsub>Pring R I\<^esub> x \<oplus>\<^bsub>Pring R I\<^esub> b \<odot>\<^bsub>Pring R I\<^esub> x"
+  proof fix m
+    have "(a \<oplus> b) \<otimes> x m = (a \<otimes> (x m)) \<oplus> (b \<otimes> (x m))"
+      by (meson A(1) A(2) A(3) Pring_carrier_coeff' local.semiring_axioms semiring.l_distr)
+    thus "((a \<oplus> b) \<odot>\<^bsub>Pring R I\<^esub> x) m = (a \<odot>\<^bsub>Pring R I\<^esub> x \<oplus>\<^bsub>Pring R I\<^esub> b \<odot>\<^bsub>Pring R I\<^esub> x) m"
+      using Pring_smult_cfs[of "a \<oplus> b" x I m] 
+            Pring_smult_cfs[of "a" x I m] 
+            Pring_smult_cfs[of "b" x I m]
+            Pring_smult_closed[of a x I]
+            Pring_smult_closed[of b x I]
+            Pring_add  A  
+      by (simp add: \<open>(a \<oplus> b) \<otimes> x m = a \<otimes> x m \<oplus> b \<otimes> x m\<close> Pring_def indexed_padd_def poly_scalar_mult_def)
+  qed   
+qed
+
+lemma Pring_smult_r_distr:
+      "!!a x y. [| a \<in> carrier R; x \<in> carrier (Pring R I); y \<in> carrier (Pring R I) |] ==>
+      a \<odot>\<^bsub>(Pring R I)\<^esub> (x \<oplus>\<^bsub>(Pring R I)\<^esub> y) = (a \<odot>\<^bsub>(Pring R I)\<^esub> x) \<oplus>\<^bsub>(Pring R I)\<^esub> (a \<odot>\<^bsub>(Pring R I)\<^esub> y)"
+proof fix a x y m assume A: "a \<in> carrier R" "x \<in> carrier (Pring R I)" "y \<in> carrier (Pring R I)"
+  show "(a \<odot>\<^bsub>Pring R I\<^esub> (x \<oplus>\<^bsub>Pring R I\<^esub> y)) m =
+       (a \<odot>\<^bsub>Pring R I\<^esub> x \<oplus>\<^bsub>Pring R I\<^esub> a \<odot>\<^bsub>Pring R I\<^esub> y) m"
+    using Pring_smult_cfs[of a "x \<oplus>\<^bsub>Pring R I\<^esub> y" I m] 
+            Pring_smult_cfs[of a x I m] 
+            Pring_smult_cfs[of a y I m]
+            Pring_smult_closed[of a x I]
+            Pring_smult_closed[of a y I]
+            Pring_add  A  
+  by (metis (no_types, lifting) Pring_add_closed Pring_carrier_coeff' indexed_padd_def l_distr m_comm)
+qed
+
+lemma Pring_smult_assoc1:
+      "!!a b x. [| a \<in> carrier R; b \<in> carrier R; x \<in> carrier (Pring R I) |] ==>
+      (a \<otimes> b) \<odot>\<^bsub>Pring R I\<^esub> x = a \<odot>\<^bsub>Pring R I\<^esub> (b \<odot>\<^bsub>Pring R I\<^esub> x)"
+proof fix a b x m  assume A: "a \<in> carrier R" "b \<in> carrier R" "x \<in> carrier (Pring R I)"
+  show " (a \<otimes> b \<odot>\<^bsub>Pring R I\<^esub> x) m = (a \<odot>\<^bsub>Pring R I\<^esub> (b \<odot>\<^bsub>Pring R I\<^esub> x)) m"
+      using Pring_smult_cfs[of "a \<otimes> b" x I m] 
+            Pring_smult_cfs[of a "b \<odot>\<^bsub>Pring R I\<^esub> x" I m] 
+            Pring_smult_cfs[of "b" x I m]
+            Pring_smult_closed[of a "b \<odot>\<^bsub>Pring R I\<^esub> x" I]
+            Pring_smult_closed[of b x I]
+            A(1) A(2) A(3) m_assoc m_closed by auto
+qed
+
+lemma Pring_smult_one:
+      "!!x. x \<in> carrier (Pring R I) ==> (one R) \<odot>\<^bsub>Pring R I\<^esub> x = x"
+  by (simp add: Pring_car Pring_smult poly_scalar_mult_one)
+  
+
+lemma Pring_smult_assoc2:
+      "!!a x y. [| a \<in> carrier R; x \<in> carrier (Pring R I); y \<in> carrier (Pring R I) |] ==>
+      (a \<odot>\<^bsub>Pring R I\<^esub> x) \<otimes>\<^bsub>Pring R I\<^esub> y = a \<odot>\<^bsub>Pring R I\<^esub> (x \<otimes>\<^bsub>Pring R I\<^esub> y)"
+  by (simp add: Pring_def poly_scalar_mult_times)
+
+lemma Pring_algebra:
+"algebra R (Pring R I)"
+  apply(rule algebraI)
+         apply (simp add: is_cring)
+        apply (simp add: Pring_is_cring is_cring)
+       apply (simp add: Pring_smult_closed)
+      apply (simp add: Pring_smult_l_distr)
+     apply (simp add: Pring_smult_r_distr)
+    apply (simp add: Pring_smult_assoc1)
+   apply (simp add: Pring_smult_one)
+  by (simp add: Pring_smult_assoc2)
+
+
+end 
+
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Evaluation of Polynomials and Subring Structure\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  In this section the aim is to define the evaluation of a polynomial over its base ring. We define
+  both total evaluation of a polynomial at all variables, and partial evaluation at only a subset 
+  of variables. The basic input for evaluation is a variable assignment function mapping variables 
+  to ring elements. Once we can evaluate a polynomial $P$ in variables $I$ over a ring $R$ at an 
+  assignment $f: I \to R$, this can be generalized to evaluation of $P$ in some other ring $S$, 
+  given a variable assignment $f: I \to S$ and a ring homomorphism $\phi: R \to S$. We chose to 
+  define this by simply applying $\phi$ to the coefficients of $P$, and then using the first 
+  evaluation function over $S$. This could also have been done the other way around: define 
+  general polynomial evaluation over any ring, given a ring hom $\phi$, and then defining 
+  evaluation over the base ring $R$ as the specialization of this function to the case there 
+  $\phi = \mathit{id}_R$.\<close>
+
+definition remove_monom :: 
+"('a,'b) ring_scheme \<Rightarrow> 'c monomial \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> ('a, 'c) mvar_poly" where
+"remove_monom R m P = ring.indexed_padd R P (poly_scalar_mult R (\<ominus>\<^bsub>R\<^esub> P m) (mset_to_IP R m))"
+ 
+context cring 
+begin
+
+lemma remove_monom_alt_def:
+  assumes "P \<in> Pring_set R I" 
+  shows "remove_monom R m P n = (if n = m then \<zero> else P n)"
+  unfolding remove_monom_def 
+  apply(cases "n = m")
+  using assms 
+   apply (metis Pring_cfs_closed cring.cring_simprules(3) poly_scalar_mult_def
+          indexed_padd_def is_cring mset_to_IP_simp r_neg r_one)
+   using assms 
+   by (metis Pring_cfs_closed add.l_cancel_one cring.cring_simprules(3)
+       poly_scalar_mult_def indexed_padd_def is_cring mset_to_IP_simp' r_null zero_closed)
+
+lemma remove_monom_zero:
+  assumes "m \<notin> monomials_of R P"
+  assumes "P \<in> Pring_set R I"
+  shows "remove_monom R m P = P"
+proof
+  fix x
+  show "remove_monom R m P x = P x "
+    apply(cases "x \<in> monomials_of R P")
+    using assms unfolding monomials_of_def remove_monom_def 
+  apply (metis cring.remove_monom_alt_def is_cring remove_monom_def)
+    using assms unfolding monomials_of_def remove_monom_def 
+    by (metis assms(1) cring.remove_monom_alt_def is_cring local.ring_axioms 
+        remove_monom_def ring.complement_of_monomials_of)
+qed
+  
+lemma remove_monom_closed:
+  assumes "P \<in> Pring_set R I" 
+  shows "remove_monom R m P \<in> Pring_set R I"
+ 
+  apply(cases "m \<in> monomials_of R P")
+  using assms poly_scalar_mult_closed[of "(\<ominus> P m)" "(mset_to_IP R m)" I] mset_to_IP_closed[of m I]
+  unfolding remove_monom_def 
+  apply (meson Pring_cfs_closed add.inv_closed indexed_pset.indexed_padd mset_to_IP_closed')
+  by (metis assms remove_monom_def remove_monom_zero)
+
+lemma remove_monom_monomials:
+  assumes "P \<in> Pring_set R I"
+  shows "monomials_of R (remove_monom R m P) = monomials_of R P - {m}"
+proof
+  show "monomials_of R (remove_monom R m P) \<subseteq> monomials_of R P - {m}"
+    using assms remove_monom_alt_def[of P I m]
+    unfolding monomials_of_def 
+    by auto
+  show "monomials_of R P - {m} \<subseteq> monomials_of R (remove_monom R m P)"
+    using assms remove_monom_alt_def[of P I m]
+    unfolding monomials_of_def 
+    by auto
+qed
+
+text\<open>The additive decomposition of a polynomial by a monomial\<close>
+
+lemma remove_monom_eq:
+  assumes "P \<in> Pring_set R I"
+  shows "P = (remove_monom R a P) \<Oplus> poly_scalar_mult R  (P a) (mset_to_IP R a)"
+  unfolding remove_monom_def poly_scalar_mult_def
+proof
+  fix x
+  show "P x = (P \<Oplus> (\<lambda>m. \<ominus> P a \<otimes> mset_to_IP R a m) \<Oplus> (\<lambda>m. P a \<otimes> mset_to_IP R a m)) x"
+  apply(cases "x = a")
+     apply (metis Pring_cfs_closed assms l_minus l_zero local.ring_axioms mset_to_IP_simp one_closed r_neg r_one ring.indexed_padd_def)
+  proof-
+    assume A: "x \<noteq> a"
+    show "P x = (P \<Oplus> (\<lambda>m. \<ominus> P a \<otimes> mset_to_IP R a m) \<Oplus> (\<lambda>m. P a \<otimes> mset_to_IP R a m)) x"
+      using assms A
+      unfolding mset_to_IP_def indexed_padd_def  
+      using Pring_cfs_closed by fastforce     
+  qed
+qed
+
+lemma remove_monom_restrict_poly_to_monom_set:
+  assumes "P \<in> Pring_set R I"
+  assumes "monomials_of R P = insert a M"
+  assumes "a \<notin> M"
+  shows "(remove_monom R a P) = restrict_poly_to_monom_set R P M"
+proof
+  fix m
+  show "remove_monom R a P m= restrict_poly_to_monom_set R P M m"
+    apply(cases "m = a")
+    using assms apply (metis remove_monom_alt_def restrict_poly_to_monom_set_def)
+    using assms 
+    by (metis complement_of_monomials_of insert_iff remove_monom_alt_def restrict_poly_to_monom_set_def)
+qed
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Nesting of Polynomial Rings According to Nesting of Index Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma(in ring) Pring_carrier_subset:
+  assumes "J \<subseteq> I"
+  shows "(Pring_set R J) \<subseteq> (Pring_set R I)"
+proof
+  fix P
+  show "P \<in> Pring_set R J \<Longrightarrow>P \<in> Pring_set R I"
+    apply(erule indexed_pset.induct)
+    using indexed_pset.indexed_const apply blast
+      using indexed_pset.indexed_padd apply blast
+        by (meson assms indexed_pset.indexed_pmult subsetD)
+qed
+
+lemma(in cring) Pring_set_restrict_induct:
+  shows "finite S \<Longrightarrow> \<forall>P. monomials_of R P = S \<and>  P \<in> Pring_set R I \<and>  (\<forall> m \<in> monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow>  P \<in> Pring_set R J"
+proof(erule finite.induct)
+  show "\<forall>P. monomials_of R P = {} \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow> P \<in> Pring_set R J"
+  proof
+    fix P
+    show "monomials_of R P = {} \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow> P \<in> Pring_set R J"
+    proof
+      assume A0: "monomials_of R P = {} \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J)"
+      show "P \<in> Pring_set R J " 
+        by (metis A0 card_eq_0_iff indexed_pset.indexed_const monomials_of_card_zero zero_closed)
+    qed
+  qed
+  show "\<And>A a. finite A \<Longrightarrow>
+           \<forall>P. monomials_of R P = A \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow> P \<in> Pring_set R J \<Longrightarrow>
+           \<forall>P. monomials_of R P = insert a A \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow> P \<in> Pring_set R J"
+  proof
+    fix A :: "('c monomial) set" fix a fix P
+    assume A1: "finite A"
+    assume A2: "\<forall>P. monomials_of R P = A \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow> P \<in> Pring_set R J"
+    show "monomials_of R P = insert a A \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J) \<longrightarrow> P \<in> Pring_set R J "
+    proof
+      assume A3: "monomials_of R P = insert a A \<and> P \<in> Pring_set R I \<and> (\<forall>m\<in>monomials_of R P. set_mset m \<subseteq> J)"
+      show "P \<in> Pring_set R  J"
+        apply(cases "a \<in>   A")
+         apply (metis A2 A3 insert_absorb)
+      proof-
+        assume N: "a \<notin> A"
+        obtain Q where Q_def: "Q = remove_monom R a P"
+          by simp
+        have Q0: "monomials_of R Q = A"
+        proof-
+          have 0:  "monomials_of R P = insert a A"
+            by (simp add: A3)
+          have 1: "P \<in> Pring_set R I"
+            using A3 by blast
+          have 2: "monomials_of R (remove_monom R a P) = monomials_of R P - {a}"
+            using A3 remove_monom_monomials by blast
+          then show ?thesis
+            using Q_def 0 
+            by (simp add: N)
+        qed
+        have Q1: "Q \<in> Pring_set R I"
+          using A3 Q_def remove_monom_closed by blast
+        have Q2: "(\<forall>m\<in>monomials_of R Q. set_mset m \<subseteq> J)"
+          using Q0 A3 
+          by blast
+        have "Q \<in> Pring_set R J"
+          using A2 Q0 Q1 Q2 by blast
+        then show "P \<in> Pring_set R J"
+        proof-
+          have "P = Q \<Oplus> poly_scalar_mult R  (P a) (mset_to_IP R a)"
+            using Q_def remove_monom_eq
+            using A3 by blast
+          then show ?thesis 
+            by (metis A3 Pring_cfs_closed \<open>Q \<in> Pring_set R J\<close> indexed_pset.indexed_padd insertCI mset_to_IP_closed poly_scalar_mult_closed)
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma(in cring) Pring_set_restrict:
+  assumes "P \<in> Pring_set R I"
+  assumes "(\<And>m.  m \<in> monomials_of R P \<Longrightarrow>  set_mset m \<subseteq> J)"
+  shows " P \<in> Pring_set R J"
+  using assms Pring_set_restrict_induct[of "monomials_of R P"]
+  by (metis monomials_finite)
+             
+lemma(in ring) Pring_mult_eq:
+  fixes I:: "'c set"
+  fixes J:: "'c set"
+  shows "(\<otimes>\<^bsub>Pring R I\<^esub>) = (\<otimes>\<^bsub>Pring R J\<^esub>)"
+  by (simp add: Pring_def)
+  
+lemma(in ring) Pring_add_eq:
+  fixes I:: "'c set"
+  fixes J:: "'c set"
+  shows "(\<oplus>\<^bsub>Pring R I\<^esub>) = (\<oplus>\<^bsub>Pring R J\<^esub>)"
+  using Pring_def 
+  by (simp add: Pring_def)
+
+lemma(in ring) Pring_one_eq:
+  fixes I:: "'c set"
+  fixes J:: "'c set"
+  shows "(\<one>\<^bsub>Pring R I\<^esub>) = (\<one>\<^bsub>Pring R J\<^esub>)"
+  using Pring_def 
+  by (simp add: Pring_def)
+
+lemma(in ring) Pring_zero_eq:
+  fixes I:: "'c set"
+  fixes J:: "'c set"
+  shows "(\<zero>\<^bsub>Pring R I\<^esub>) = (\<zero>\<^bsub>Pring R J\<^esub>)"
+  using Pring_def 
+  by (simp add: Pring_def)
+
+lemma(in ring) index_subset_Pring_subring:
+  assumes "J \<subseteq> I"
+  shows "subring (carrier (Pring R J)) (Pring R I)"
+  apply(rule ring.subringI)
+  apply (simp add: Pring_is_ring; fail)
+    using assms 
+   apply (simp add: Pring_car Pring_carrier_subset; fail)
+   using Pring_def 
+         apply (simp add: Pring_def indexed_pset.indexed_const; fail)
+    proof-
+      show "\<And>h. h \<in> carrier (Pring R J) \<Longrightarrow> \<ominus>\<^bsub>Pring R I\<^esub> h \<in> carrier (Pring R J)"
+      proof-
+        fix h
+        assume A: "h \<in> carrier (Pring R J)"
+        then have A0: "\<ominus>\<^bsub>Pring R J\<^esub> h = P_ring_uminus R h"
+          using Pring_a_inv[of h J] 
+          by auto 
+        have A1: "\<ominus>\<^bsub>Pring R I\<^esub> h = P_ring_uminus R h"
+          using assms A Pring_carrier_subset[of J I] Pring_a_inv[of h I] Pring_car 
+          by blast
+        show "\<ominus>\<^bsub>Pring R I\<^esub> h \<in> carrier (Pring R J)"
+          using A0 A1 A 
+          by (simp add: Pring_uminus)          
+      qed
+      show " \<And>h1 h2. h1 \<in> carrier (Pring R J) \<Longrightarrow> h2 \<in> carrier (Pring R J) \<Longrightarrow> h1 \<otimes>\<^bsub>Pring R I\<^esub> h2 \<in> carrier (Pring R J)"
+        using assms Pring_mult_eq 
+        by (metis Pring_mult_closed)
+      show " \<And>h1 h2. h1 \<in> carrier (Pring R J) \<Longrightarrow> h2 \<in> carrier (Pring R J) \<Longrightarrow> h1 \<oplus>\<^bsub>Pring R I\<^esub> h2 \<in> carrier (Pring R J)"
+        using assms Pring_add_eq 
+        by (metis Pring_add_closed)
+    qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Inclusion Maps\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition Pring_inc :: "('a, 'c) mvar_poly \<Rightarrow> ('a, 'c) mvar_poly" where
+"Pring_inc \<equiv> (\<lambda>P. P)"
+
+lemma(in ring) Princ_inc_is_ring_hom:
+  assumes "J \<subseteq> I"
+  shows "ring_hom_ring (Pring R J) (Pring R I) Pring_inc"
+  unfolding Pring_inc_def
+  apply(rule ring_hom_ringI)
+  apply (simp add: Pring_is_ring)
+    using Pring_is_ring apply blast
+       using index_subset_Pring_subring[of I J] assms index_subset_Pring_subring subringE(1) 
+       apply blast
+          using Pring_mult_eq[of I J]
+          apply (simp add: Pring_mult)
+             using Pring_add_eq[of I J]
+             apply (simp add: Pring_add)
+             using Pring_one_eq 
+  by (simp add: Pring_one_eq)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Restricting a Multiset to a Subset of Variables\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition restrict_to_indices :: "'c monomial \<Rightarrow> 'c set \<Rightarrow> 'c monomial" where
+"restrict_to_indices m S = filter_mset (\<lambda>i. i \<in> S) m"
+
+lemma restrict_to_indicesE:
+  assumes "i \<in># restrict_to_indices m S"
+  shows "i \<in> S"
+  using assms 
+  unfolding restrict_to_indices_def 
+  by simp
+  
+lemma restrict_to_indicesI[simp]:
+  assumes "i \<in># m"
+  assumes "i \<in> S"
+  shows "i \<in># restrict_to_indices m S"
+  using assms 
+  unfolding restrict_to_indices_def 
+  by simp
+
+lemma restrict_to_indices_not_in[simp]:
+  assumes "i \<in># m"
+  assumes "i \<notin> S"
+  shows "i \<notin># restrict_to_indices m S"
+  using assms 
+  unfolding restrict_to_indices_def 
+  by (meson count_eq_zero_iff count_filter_mset)
+
+lemma restrict_to_indices_submultiset[simp]:
+"restrict_to_indices m S \<subseteq># m"
+  unfolding restrict_to_indices_def 
+  using multiset_filter_subset 
+  by blast
+
+lemma restrict_to_indices_add_element:
+"restrict_to_indices (add_mset x m) S = (if x \<in> S then (add_mset x (restrict_to_indices m S) ) 
+                                            else (restrict_to_indices m S) )"
+  unfolding restrict_to_indices_def 
+  by (metis filter_mset_add_mset)
+
+lemma restrict_to_indices_count[simp]: 
+"count (restrict_to_indices m S) i = (if (i \<in> S) then (count m i) else 0)"
+  unfolding restrict_to_indices_def 
+  by (metis count_filter_mset)
+
+lemma restrict_to_indices_subset:
+"restrict_to_indices m S = restrict_to_indices m (set_mset m \<inter> S)"
+proof(induction m)
+  case empty
+  then show ?case unfolding restrict_to_indices_def 
+    by (metis filter_empty_mset)
+next
+  case (add x m)
+  assume IH: "restrict_to_indices m S = restrict_to_indices m (set_mset m \<inter> S)"
+  show "restrict_to_indices (add_mset x m) S = restrict_to_indices (add_mset x m) (set_mset (add_mset x m) \<inter> S)"
+  proof-
+    have "\<And>i. count (restrict_to_indices (add_mset x m) S) i  = 
+              count (restrict_to_indices (add_mset x m) (set_mset (add_mset x m) \<inter> S)) i  "
+    proof-
+      fix i
+      show "count (restrict_to_indices (add_mset x m) S) i  = count (restrict_to_indices (add_mset x m) (set_mset (add_mset x m) \<inter> S)) i"
+        apply(cases "i \<in> S")
+        using restrict_to_indices_count 
+        apply (metis IntI count_inI)
+        by (metis restrict_to_indices_count Int_iff)
+    qed
+    then show ?thesis 
+      using multiset_eq_iff by blast
+  qed
+qed
+
+text\<open>\texttt{Restrict\_to\_indices} only depends on the intersection
+     of the index set with the set of indices in m:\<close>
+
+lemma restrict_to_indices_subset':
+  assumes "(set_mset m) \<inter> S = (set_mset m) \<inter> S'"
+  shows "restrict_to_indices m S = restrict_to_indices m S'"
+  by (metis restrict_to_indices_subset assms)
+
+lemma mset_add_plus:
+  assumes "m = n + k"
+  shows "add_mset x m = (add_mset x n) + k"
+  using assms 
+  by simp
+
+text\<open>Restricting to \<open>S\<close> and the complement of \<open>S\<close> partitions \<open>m\<close>:\<close>
+
+lemma restrict_to_indices_decomp:
+  "m = (restrict_to_indices m S) + (restrict_to_indices m ((set_mset m) - S))"
+  apply(induction m)
+  apply (metis add.right_neutral empty_Diff restrict_to_indices_submultiset set_mset_empty subset_mset.le_zero_eq)
+proof-
+  fix x
+  fix m
+  assume A: "m = restrict_to_indices m S + restrict_to_indices m (set_mset m - S)"
+  show "add_mset x m = restrict_to_indices (add_mset x m) S + restrict_to_indices (add_mset x m) (set_mset (add_mset x m) - S)"
+  proof(cases "x \<in> S")
+    case True
+    then have T0: "restrict_to_indices (add_mset x m) S = (add_mset x (restrict_to_indices m S) ) "
+      by (simp add: True restrict_to_indices_add_element)
+    have T1: "restrict_to_indices (add_mset x m) (set_mset (add_mset x m) - S) = 
+            restrict_to_indices m (set_mset (add_mset x m) - S)"
+      using True by (metis DiffD2 restrict_to_indices_add_element)
+    have T2: "restrict_to_indices (add_mset x m) S +  restrict_to_indices (add_mset x m) (set_mset (add_mset x m) - S)
+            = (add_mset x (restrict_to_indices m S) )  + restrict_to_indices m (set_mset (add_mset x m) - S)"
+      using T0 T1 
+      by presburger
+    have T3: " add_mset x m = add_mset x (restrict_to_indices m S) + restrict_to_indices m (set_mset m - S)"
+      using T2 A using mset_add_plus[of m "restrict_to_indices m S" " restrict_to_indices m (set_mset m - S)" x] 
+      by blast
+    have T4: "set_mset m \<inter> (set_mset (add_mset x m) - S) = set_mset m \<inter> (set_mset m - S)"
+    proof
+      show "set_mset m \<inter> (set_mset (add_mset x m) - S) \<subseteq> set_mset m \<inter> (set_mset m - S)"
+        by blast
+      show "set_mset m \<inter> (set_mset m - S) \<subseteq> set_mset m \<inter> (set_mset (add_mset x m) - S)"
+        by (simp add: True)
+    qed
+    have T5: "restrict_to_indices m (set_mset (add_mset x m) - S) = restrict_to_indices m (set_mset m - S)"
+      using T4 restrict_to_indices_subset'[of m "(set_mset (add_mset x m) - S)" " (set_mset m - S)" ]
+      by blast
+    then show ?thesis using T4 
+      by (metis T0 T1 T3)
+  next
+    case False
+    then have F0: "restrict_to_indices (add_mset x m) S = (restrict_to_indices m S) "
+      by (simp add: False restrict_to_indices_add_element)
+    have F1: "restrict_to_indices (add_mset x m) (set_mset (add_mset x m) - S) = 
+            (add_mset x (restrict_to_indices m (set_mset (add_mset x m) - S)))"
+      using False 
+      by (meson DiffI restrict_to_indices_add_element union_single_eq_member)
+      
+    have F2: "restrict_to_indices (add_mset x m) S +  restrict_to_indices (add_mset x m) (set_mset (add_mset x m) - S)
+            = (restrict_to_indices m S) + (add_mset x (restrict_to_indices m (set_mset (add_mset x m) - S)))"
+      using F0 F1
+      by presburger
+    have F3: " add_mset x m =  (restrict_to_indices m S) +  (add_mset x (restrict_to_indices m (set_mset m - S)))"
+      using F2 A  mset_add_plus[of m "restrict_to_indices m (set_mset m - S)" "restrict_to_indices m S" x] 
+      by (metis union_mset_add_mset_right)
+    have F4: " add_mset x m =  restrict_to_indices (add_mset x m) S+  (add_mset x (restrict_to_indices m (set_mset m - S)))"
+      using F0 F3 by auto
+    have F5: "add_mset x (restrict_to_indices m (set_mset m - S)) = restrict_to_indices (add_mset x m) (set_mset (add_mset x m) - S) "
+    proof(cases "x \<in> set_mset m")
+      case True
+      then show ?thesis 
+        by (metis F1 add_mset_remove_trivial more_than_one_mset_mset_diff)
+    next
+      case F: False
+      have "set_mset m \<inter> (set_mset (add_mset x m) - S) = set_mset m \<inter>(set_mset m - S)"
+      proof
+        show "set_mset m \<inter> (set_mset (add_mset x m) - S) \<subseteq> set_mset m \<inter> (set_mset m - S)"
+          using F False 
+          by blast
+        show "set_mset m \<inter> (set_mset m - S) \<subseteq> set_mset m \<inter> (set_mset (add_mset x m) - S)"
+          using F False 
+          by (metis Diff_mono mset_add_plus Int_mono add_cancel_right_left  
+              set_eq_subset subsetI subset_iff union_commute union_iff)
+      qed
+      then show ?thesis 
+        by (metis F1 restrict_to_indices_subset')
+    qed
+    then show ?thesis 
+      using False F4 
+      by presburger
+  qed
+qed
+
+definition remove_indices :: "'c monomial \<Rightarrow> 'c set \<Rightarrow> 'c monomial" where
+"remove_indices m S = (restrict_to_indices m (set_mset m - S))"
+
+lemma remove_indices_decomp:
+"m = (restrict_to_indices m S) + (remove_indices m S)" 
+  unfolding remove_indices_def 
+  using restrict_to_indices_decomp 
+  by blast
+
+lemma remove_indices_indices[simp]:
+  assumes "set_mset m \<subseteq> I"
+  shows "set_mset (remove_indices m S) \<subseteq> I - S"
+  unfolding remove_indices_def using assms 
+  by (meson Diff_iff restrict_to_indicesE subsetD subsetI)
+ 
+subsubsection\<open>Total evaluation of a monomial\<close>
+
+text\<open>
+  We define total evaluation of a monomial first, and then define the partial evaluation of a
+  monomial in terms of this.
+\<close>
+
+abbreviation(input) closed_fun where
+"closed_fun R g \<equiv> g \<in> UNIV \<rightarrow> carrier R"
+
+definition monom_eval :: "('a, 'b) ring_scheme \<Rightarrow> 'c monomial \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> 'a"  where
+"monom_eval R (m:: 'c monomial) g = fold_mset (\<lambda> x . \<lambda> y. if y \<in> carrier R then (g x) \<otimes>\<^bsub>R\<^esub> y else \<zero>\<^bsub>R\<^esub>) \<one>\<^bsub>R\<^esub> m"
+
+context cring 
+begin
+
+lemma closed_fun_simp:
+  assumes "closed_fun R g"
+  shows "g n \<in> carrier R"
+  using assms 
+  by blast 
+
+lemma closed_funI:
+  assumes "\<And>x. g x \<in> carrier R"
+  shows "closed_fun R g"
+  by (meson Pi_I assms)
+
+
+text\<open>The following are necessary technical lemmas to prove properties of about folds over multisets:\<close>
+
+lemma monom_eval_comp_fun:
+  fixes g:: "'c \<Rightarrow> 'a"
+  assumes "closed_fun R g"
+  shows "comp_fun_commute (\<lambda> x . \<lambda>y. if y \<in> carrier R then  (g x) \<otimes> y else \<zero>)"
+  unfolding comp_fun_commute_def 
+proof-
+  have "\<And> x y. (\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>) \<circ> (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>) =
+          (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>) \<circ> (\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>)"
+  proof
+    fix x y a
+    show "((\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>) \<circ> (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>)) a =
+       ((\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>) \<circ> (\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>)) a"
+    proof(cases "a \<in> carrier R")
+      case True
+      then show ?thesis 
+      proof-
+        have LHS: "((\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>) \<circ> (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>)) a = 
+                    ((\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>)  (g x \<otimes> a))"
+          using True assms(1)  m_closed m_lcomm 
+          unfolding o_def  
+          by presburger
+
+      then have LHS': "((\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>) \<circ> (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>)) a =   g y \<otimes> (g x \<otimes> a) "
+        using True assms m_closed 
+        by (meson PiE UNIV_I)        
+      then show ?thesis
+        unfolding o_def 
+        using True assms m_closed m_lcomm 
+        by (smt PiE UNIV_I)       
+      qed
+    next
+      case False
+      then show ?thesis 
+        unfolding o_def 
+        using assms r_null closed_fun_simp
+        by smt        
+    qed
+  qed
+  then show " \<forall>y x. (\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>) \<circ> (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>) =
+          (\<lambda>y. if y \<in> carrier R then g x \<otimes> y else \<zero>) \<circ> (\<lambda>ya. if ya \<in> carrier R then g y \<otimes> ya else \<zero>)"
+    by blast 
+qed
+
+lemma monom_eval_car:
+  assumes "closed_fun R g"
+  shows "monom_eval R (m:: 'c monomial) g \<in> carrier R" 
+proof(induction m)
+case empty
+  then show ?case 
+    unfolding monom_eval_def
+    by (metis fold_mset_empty one_closed) 
+next
+  case (add x m)
+  fix x m
+  assume A: "monom_eval R m g \<in> carrier R"
+  obtain f where f_def: "f = (\<lambda> x . \<lambda>y. if y \<in> carrier R then (g x) \<otimes> y else \<zero>)"
+    by blast  
+  have 0: "comp_fun_commute f"
+    using assms monom_eval_comp_fun[of g] f_def 
+    by blast        
+  have 1: "\<And>m. monom_eval R m g = fold_mset f \<one> m"
+    using f_def monom_eval_def 
+    by blast 
+  have 2: "monom_eval R (add_mset x m) g = fold_mset f \<one> (add_mset x m)"
+    using 1 by blast 
+  have 3: "g x \<in> carrier R" 
+    using assms  by blast 
+  then show "monom_eval R (add_mset x m) g \<in> carrier R"
+    using assms 0 1 2 3
+    by (metis A comp_fun_commute.fold_mset_add_mset f_def m_closed)
+qed
+
+text\<open>Formula for recursive (total) evaluation of a monomial:\<close>
+lemma monom_eval_add:
+  assumes "closed_fun R g"
+  shows "monom_eval R (add_mset x M) g = (g x) \<otimes> (monom_eval R M g)"
+proof-
+  obtain f where f_def: "f = (\<lambda> x . \<lambda>y. if y \<in> carrier R then (g x) \<otimes> y else \<zero>)"
+    by blast  
+  have 0: "comp_fun_commute f"
+    using assms monom_eval_comp_fun f_def
+    by blast 
+  have 1: "\<And>m. monom_eval R m g = fold_mset f \<one> m"
+    using f_def monom_eval_def 
+    by blast 
+  have 2: "monom_eval R (add_mset x M) g = fold_mset f \<one> (add_mset x M)"
+    using 1 by blast 
+  have 3: "g x \<in> carrier R" 
+    using assms  by blast 
+  have 4: "(g x) \<otimes> (monom_eval R M g) = f x (monom_eval R M g)"
+    using f_def 3  
+    by (meson assms monom_eval_car)    
+  then show ?thesis 
+    by (metis "0" "1" comp_fun_commute.fold_mset_add_mset)
+qed
+
+end
+
+text\<open>
+  This function maps a polynomial $P$ to the set of monomials in $P$ which, after evaluating all
+  variables in the set $S$ to values in the ring $R$, reduce to the monomial $n$.
+\<close>
+
+definition monomials_reducing_to :: 
+"('a,'b) ring_scheme \<Rightarrow> 'c monomial \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow> 'c set \<Rightarrow> ('c monomial) set" where
+"monomials_reducing_to R n P S = {m \<in> monomials_of R P. remove_indices m S = n}"
+
+lemma monomials_reducing_to_subset[simp]:
+ "monomials_reducing_to R n P s \<subseteq> monomials_of R P"
+  unfolding monomials_reducing_to_def 
+  by blast
+
+context cring
+begin
+
+lemma monomials_reducing_to_finite:
+  assumes "P \<in> Pring_set R I"
+  shows "finite (monomials_reducing_to R n P s)"
+  by (meson assms monomials_finite monomials_reducing_to_subset rev_finite_subset)
+
+lemma monomials_reducing_to_disjoint:
+  assumes "n1 \<noteq> n2"
+  shows "monomials_reducing_to R n1 P S \<inter> monomials_reducing_to R n2 P S = {}"
+  unfolding monomials_reducing_to_def 
+  using assms 
+  by blast
+
+lemma monomials_reducing_to_submset:
+assumes "n \<subset># m"
+shows "n \<notin> monomials_reducing_to R m P S"
+proof(rule ccontr)
+  assume C: "\<not> n \<notin> monomials_reducing_to R m P S "
+  then have "n \<in>  monomials_reducing_to R m P S "
+    by blast 
+  then have "remove_indices n S = m"
+    unfolding monomials_reducing_to_def 
+    by blast
+  then show False 
+    by (metis (full_types) remove_indices_def restrict_to_indices_submultiset assms subset_mset.less_asym' subset_mset.less_irrefl subset_mset_def)
+qed
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Partial Evaluation of a Polynomial\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  This function takes as input a set $S$ of variables, an evaluation function $g$, and a polynomial
+  to evaluate $P$. The output is a polynomial which is the result of evaluating the variables from
+  the set $S$ which occur in $P$, according to the evaluation function $g$.
+\<close>
+
+definition poly_eval :: 
+  "('a,'b) ring_scheme \<Rightarrow> 'c set \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> ('a, 'c) mvar_poly"where
+"poly_eval R S g P m = (finsum R (\<lambda>n. monom_eval R (restrict_to_indices n S) g  \<otimes>\<^bsub>R\<^esub> (P n)) (monomials_reducing_to R m P S))"
+
+context cring
+begin
+
+lemma finsum_singleton:
+  assumes "S = {s}"
+  assumes "f s \<in> carrier R"
+  shows "finsum R f S = f s"
+proof-
+  have "finsum R f S = finsum R f (insert s {})"
+    using assms(1) 
+    by blast
+  then show ?thesis using finsum_insert[of "{}" s f] assms 
+    by (metis Pi_I empty_iff finite.emptyI finsum_empty r_zero)
+qed
+
+lemma poly_eval_constant:
+  assumes "k \<in> carrier R"
+  shows "poly_eval R S g (indexed_const k) = (indexed_const k)"
+proof
+  have S: "monomials_of R (indexed_const k) \<subseteq> {{#}}"
+    unfolding indexed_const_def monomials_of_def 
+    by (metis (mono_tags, lifting) mem_Collect_eq singletonI subset_iff)    
+  fix x
+  show "poly_eval R S g (indexed_const k) x = indexed_const k x "
+  proof(cases "x = {#}")
+    case True
+    have "(monomials_reducing_to R x (indexed_const k) S) \<subseteq> {{#}}"
+      using S monomials_reducing_to_subset 
+      by blast
+    then show ?thesis 
+    proof(cases "k = \<zero>")
+      case True
+      then have "(monomials_reducing_to R x (indexed_const k) S) = {}"
+        by (metis S \<open>monomials_reducing_to R x (indexed_const k) S \<subseteq> {{#}}\<close> 
+            monomials_reducing_to_subset monoms_of_const subset_antisym subset_singletonD)
+      then show ?thesis 
+        unfolding poly_eval_def 
+        by (metis True finsum_empty indexed_const_def)      
+    next
+      case False
+      then have "monomials_of R (indexed_const k) = {{#}}"
+        by (meson monoms_of_const)
+      have "remove_indices {#} S = {#}"
+        using remove_indices_decomp by blast
+      then have "{#} \<in> monomials_reducing_to R x (indexed_const k) S"
+        using True False unfolding monomials_reducing_to_def 
+              \<open>monomials_of R (indexed_const k) = {{#}}\<close> 
+        by blast
+      then have 0: "monomials_reducing_to R x (indexed_const k) S = {{#}}"
+        using \<open>monomials_reducing_to R x (indexed_const k) S \<subseteq> {{#}}\<close> 
+        by blast
+      have 1: "restrict_to_indices {#} S = {#}"
+        using restrict_to_indices_submultiset remove_indices_decomp by blast 
+      have 2: "monom_eval R (restrict_to_indices {#} S) g = \<one>"
+        unfolding monom_eval_def 
+        using 1 
+        by (metis fold_mset_empty)   
+      have 3: "poly_eval R S g (indexed_const k)  x =
+                (\<Oplus>n\<in>{{#}}. monom_eval R (restrict_to_indices n S) g \<otimes> indexed_const k n)"
+        unfolding poly_eval_def 
+        using 0 
+        by presburger           
+      have 4: "(\<Oplus>n\<in>{{#}}. monom_eval R (restrict_to_indices n S) g \<otimes> indexed_const k n) = monom_eval R (restrict_to_indices {#} S) g \<otimes> indexed_const k {#}" 
+        using finsum_singleton[of "{{#}}" "{#}" "\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> indexed_const k n" ]
+        by (metis "2" assms indexed_const_def l_one)
+      then show ?thesis unfolding poly_eval_def 
+        using 0 1 2 
+        by (metis True assms indexed_const_def l_one)
+    qed
+  next
+    case False
+    then have F0: "(indexed_const k) x = \<zero>"
+      by (meson indexed_const_def)
+    have "(monomials_reducing_to R x (indexed_const k) S) = {}"
+      unfolding monomials_reducing_to_def 
+    proof(rule ccontr)
+      assume A: "{m \<in> monomials_of R (indexed_const k). remove_indices m S = x} \<noteq> {}"
+      then obtain m where m_def: "m \<in> monomials_of R (indexed_const k) \<and> remove_indices m S = x"
+        by blast
+        then show False using A F0 
+          by (metis False S empty_eq_union empty_iff  
+              remove_indices_decomp singletonD subset_singletonD)
+    qed
+    then show ?thesis 
+      unfolding poly_eval_def 
+      by (metis False finsum_empty indexed_const_def)
+  qed
+qed
+
+lemma finsum_partition:
+  assumes "finite S"
+  assumes "f \<in> S \<rightarrow> carrier R"
+  assumes "T \<subseteq> S"
+  shows "finsum  R f S  = finsum R f T  \<oplus> finsum  R f (S - T) "
+proof-
+  have "\<And>U. finite U \<Longrightarrow> U \<subseteq> S \<longrightarrow> finsum  R f S  = finsum R f U  \<oplus> finsum  R f (S - U) "
+  proof-
+    fix U 
+    show "finite U \<Longrightarrow> U \<subseteq> S \<longrightarrow> finsum R f S = finsum R f U \<oplus> finsum R f (S - U) "
+    apply(erule finite.induct)
+       apply (metis Diff_empty assms(2) finsum_closed finsum_empty l_zero)
+    proof
+      fix A :: "'c set" fix a
+      assume A0: "finite A"
+      show "A \<subseteq> S \<longrightarrow> finsum R f S = finsum R f A \<oplus> finsum R f (S - A) \<Longrightarrow> insert a A \<subseteq> S \<Longrightarrow> finsum R f S = finsum R f (insert a A) \<oplus> finsum R f (S - insert a A)"
+
+      proof-
+        assume A1: "A \<subseteq> S \<longrightarrow> finsum R f S = finsum R f A \<oplus> finsum R f (S - A)"
+        assume A2: "insert a A \<subseteq> S"
+        show "finsum R f S = finsum R f (insert a A) \<oplus> finsum R f (S - insert a A)"
+          apply(cases "a \<in> A")
+           apply (metis A1 A2 insert_absorb)
+        proof-
+          assume A3: "a \<notin> A"
+          have A4: "f a \<in> carrier R"
+            by (metis A2 Pi_iff assms(2) insert_subset)
+          have A5: " finsum R f (insert a A) = f a \<oplus> finsum R f A"
+
+            using A0 A1 A2 finsum_insert[of A a f] assms  A3 
+            by blast
+          have A6: "a \<in> S"
+            using A2 by blast
+          have A7: "finsum R f S \<in> carrier R"
+            using assms(2) finsum_closed by blast
+          have A8: " finsum R f (S - A)\<in> carrier R"
+            using Diff_subset[of S A] Pi_iff assms(2) finsum_closed[of f] subsetD[of _ S ]
+            by (meson Pi_anti_mono in_mono)
+          have A9: "finsum R f A \<in> carrier R"
+            by (meson A2 Pi_anti_mono assms(2) finsum_closed insert_subset subsetD)
+          have A10: "finsum R f A =  finsum R f S \<ominus> finsum R f (S - A)"
+            using A7 A8 A9 
+            by (metis A1 A2 add.inv_solve_right' insert_subset minus_eq)
+          have A11: " finsum R f (insert a A) = f a \<oplus> (finsum R f S \<ominus> finsum R f (S - A))"
+            using A5 A6 A1 A2 assms  A10
+            by presburger
+          then have A12: " finsum R f (insert a A) =finsum R f S \<oplus>( f a  \<ominus> finsum R f (S - A))"
+            using A4 A7 A8 add.inv_closed add.m_lcomm minus_eq by presburger
+          have A13: "finsum R f (insert a A) \<in> carrier R"
+            using A4 A5 A9 add.m_closed 
+            by presburger
+          have A14: " finsum R f (S - insert a A) \<in> carrier R"
+            by (meson Diff_subset Pi_anti_mono assms(2) finsum_closed in_mono)
+          have A15: "finsum R f S = finsum R f (insert a A) \<ominus> ( f a  \<ominus> finsum R f (S - A)) "
+            by (metis A12 A13 A4 A7 A8 add.inv_solve_right' minus_closed minus_eq)
+          have A16: "finsum R f S = finsum R f (insert a A) \<oplus> finsum R f (S - A) \<ominus> f a"
+            using  A1 A2 A4 A5 A8 A9 add.inv_closed add.m_assoc add.m_comm insert_subset minus_closed minus_eq r_neg1
+            unfolding a_minus_def 
+            by (metis add.m_closed)
+          have A16: "finsum R f S = finsum R f (insert a A) \<oplus> (finsum R f (S - A) \<ominus> f a)"
+            unfolding a_minus_def 
+            using A13 A16 A4 A8 add.inv_closed add.m_assoc minus_eq by presburger
+          have A17: "(finsum R f (S - A) \<ominus> f a) = finsum R f (S - insert a A) "
+          proof-
+            have A170: "(S - A) = insert a (S - insert a A)"
+              using A3 A6 by blast
+            have A171: "a \<notin> S - insert a A"
+              by blast
+            then have "finsum R f (S - A)  =(f a) \<oplus> finsum R f (S - insert a A) "
+              using A170 finsum_insert[of "(S - insert a A)" a f] 
+              by (metis A4 Diff_subset Pi_anti_mono assms(1) assms(2)  
+                  rev_finite_subset subsetD )
+            then show ?thesis 
+              by (metis A1 A13 A14 A16 A2 A4 A5 A8 A9 add.l_cancel 
+                  add.m_assoc add.m_comm insert_subset minus_closed)
+          qed
+          then show "finsum R f S = finsum R f (insert a A) \<oplus> finsum R f (S - insert a A) "  
+            using A16
+            by presburger
+        qed
+      qed
+    qed
+  qed
+  then show ?thesis 
+    by (meson assms(1) assms(3) rev_finite_subset)
+qed
+
+lemma finsum_eq_parition:
+  assumes "finite S"
+  assumes "f \<in> S \<rightarrow> carrier R"
+  assumes "T \<subseteq> S"
+  assumes "\<And>x. x \<in> S - T \<Longrightarrow> f x = \<zero>"
+  shows "finsum  R f S  = finsum R f T"
+  using assms 
+  by (metis add.finprod_mono_neutral_cong_right)
+
+lemma poly_eval_scalar_mult:
+  assumes "k \<in> carrier R"
+  assumes "closed_fun R g"
+  assumes "P \<in> Pring_set R I"
+  shows "poly_eval R  S g (poly_scalar_mult R k P)= 
+         (poly_scalar_mult R k (poly_eval R S g P))"
+proof
+  fix m
+  show "poly_eval R S g (poly_scalar_mult R k P) m = poly_scalar_mult R k (poly_eval R S g  P) m"
+    unfolding poly_eval_def poly_scalar_mult_def 
+  proof-
+    have 0: "(\<Oplus>n\<in>monomials_reducing_to R m P S. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n)) = 
+              (\<Oplus>n\<in>monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n)) "
+    proof-
+      have 00: "monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S \<subseteq> monomials_reducing_to R m P S"
+      proof
+        fix x show " x \<in> monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S \<Longrightarrow> x \<in> monomials_reducing_to R m P S"
+        unfolding monomials_reducing_to_def 
+        using assms  assms(1) monomials_ofE complement_of_monomials_of  r_null[of k]
+        by (metis (no_types, lifting) mem_Collect_eq)
+       have 01: "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n)) \<in> monomials_reducing_to R m P S \<rightarrow> carrier R"
+        by (smt Pi_I Pring_cfs_closed assms(1) assms(2) assms(3) closed_fun_simp m_closed monom_eval_car)        
+       have 02: "finite (monomials_reducing_to R m P S)"
+        using assms(3) monomials_reducing_to_finite 
+        by blast
+       have 03: "  (\<And>x. x \<in> monomials_reducing_to R m P S - monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S \<Longrightarrow>
+          monom_eval R (restrict_to_indices x S) g \<otimes> (k \<otimes> P x) = \<zero>)"
+       proof-
+        fix x
+        assume A: "x \<in> monomials_reducing_to R m P S - monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S "
+        have "x \<notin> monomials_of R ((\<lambda>m. k \<otimes> P m))"
+        proof
+          assume "x \<in> monomials_of R (\<lambda>m. k \<otimes> P m)"
+          then have "x \<in>  monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S"
+            using A
+            unfolding monomials_reducing_to_def 
+            by blast
+          then show False 
+            using A by blast
+        qed
+        then show "monom_eval R (restrict_to_indices x S) g \<otimes> (k \<otimes> P x) = \<zero>"
+          by (metis assms(2) complement_of_monomials_of monom_eval_car r_null)          
+       qed
+      qed
+      have 01: " (\<And>x. x \<in> monomials_reducing_to R m P S - monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S \<Longrightarrow> monom_eval R (restrict_to_indices x S) g \<otimes> (k \<otimes> P x) = \<zero>)"
+      proof- fix x assume A: "x \<in> monomials_reducing_to R m P S - monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S"
+        hence "x \<notin> monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S"
+        by blast
+         hence "(k \<otimes> P x) = \<zero>" unfolding monomials_reducing_to_def 
+        by (metis (no_types, lifting) A DiffD1 complement_of_monomials_of mem_Collect_eq monomials_reducing_to_def)      
+        thus "monom_eval R (restrict_to_indices x S) g \<otimes> (k \<otimes> P x) = \<zero>"
+        using monom_eval_car[of g]  assms(2) r_null by presburger
+      qed
+      have 02: "finite (monomials_reducing_to R m P S)"
+        using assms(3) monomials_reducing_to_finite by blast
+      have 04: "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n)) \<in> monomials_reducing_to R m P S \<rightarrow> carrier R"
+        by (smt Pi_I assms(1) assms(2) assms(3) closed_fun_simp cring.axioms(1) is_cring m_closed monom_eval_car ring.Pring_cfs_closed)      
+      show ?thesis
+        using 00 01 02 04
+            finsum_eq_parition[of "monomials_reducing_to R m P S" 
+                                "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n))" 
+                                "monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S"]    
+        by blast
+    qed
+    then have 1: " (\<Oplus>n\<in>monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n))
+       = (\<Oplus>n\<in>monomials_reducing_to R m P S. k \<otimes> (monom_eval R (restrict_to_indices n S) g \<otimes> (P n)))      "
+    proof-
+      have "\<And>n. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n) = k \<otimes> (monom_eval R (restrict_to_indices n S) g \<otimes> (P n))"
+        by (metis Pring_cfs_closed assms(1) assms(2) assms(3) m_lcomm monom_eval_car)
+      then show ?thesis 
+        using 0 
+        by presburger
+    qed
+    show " (\<Oplus>n\<in>monomials_reducing_to R m (\<lambda>m. k \<otimes> P m) S. monom_eval R (restrict_to_indices n S) g \<otimes> (k \<otimes> P n))
+       = k \<otimes>(\<Oplus>n\<in>monomials_reducing_to R m P S.  monom_eval R (restrict_to_indices n S) g \<otimes> (P n))      "   
+    proof-
+      have "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (P n)) \<in> (monomials_reducing_to R m P S) \<rightarrow> carrier R"
+        by (meson Pi_I Pring_cfs_closed assms(2) assms(3) m_closed monom_eval_car)
+      then have "k \<otimes> (\<Oplus>i\<in>monomials_reducing_to R m P S. monom_eval R (restrict_to_indices i S) g \<otimes> P i) =
+      (\<Oplus>i\<in>monomials_reducing_to R m P S. k \<otimes> (monom_eval R (restrict_to_indices i S) g \<otimes> P i))"
+        using finsum_rdistr[of "monomials_reducing_to R m P S" 
+                                  k 
+                                  "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (P n))"] 
+              assms  monomials_reducing_to_finite by blast
+      then show ?thesis
+        using 1 
+        by presburger
+    qed
+  qed
+qed
+
+lemma poly_eval_monomial:
+  assumes "closed_fun R g"
+  assumes "\<one> \<noteq>\<zero>"
+  shows "poly_eval R  S g (mset_to_IP R m)
+           = poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                              (mset_to_IP R (remove_indices m S))"
+proof
+  have 0: "monomials_of R (mset_to_IP R m) = {m}"
+    using assms  monomials_of_mset_to_IP 
+    by blast
+
+  fix x
+  show "poly_eval R  S g (mset_to_IP R m) x =
+         poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                           (mset_to_IP R (remove_indices m S)) x "
+  proof(cases "x = (remove_indices m S)")
+    case True
+    have "monomials_reducing_to R x (mset_to_IP R m) S = {m}"
+      unfolding monomials_reducing_to_def 
+      using True 0
+      by auto
+    then have "poly_eval R  S g (mset_to_IP R m) x = monom_eval R (restrict_to_indices m S) g \<otimes> (mset_to_IP R m m)"
+      unfolding poly_eval_def 
+      by (metis (mono_tags, lifting) assms(1) finsum_singleton monom_eval_car mset_to_IP_simp r_one)      
+    then show ?thesis 
+      by (metis True mset_to_IP_simp poly_scalar_mult_def)    
+  next
+    case False
+    then have "monomials_reducing_to R x (mset_to_IP R m) S = {}"
+      unfolding monomials_reducing_to_def 
+      using 0 
+      by auto
+    then have "poly_eval R S g (mset_to_IP R m) x = \<zero>"
+      unfolding poly_eval_def 
+      by (metis finsum_empty)
+    then show ?thesis 
+      using False 
+      by (metis assms(1) monom_eval_car mset_to_IP_simp' poly_scalar_mult_def r_null)
+  qed
+qed
+
+
+lemma(in cring) poly_eval_monomial_closed:
+  assumes "closed_fun R g"
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "set_mset m \<subseteq> I"
+  shows "poly_eval R S g (mset_to_IP R m) \<in> Pring_set R (I - S)"
+proof-
+  have "(mset_to_IP R (remove_indices m S)) \<in> Pring_set R (I - S)"
+    using assms  mset_to_IP_closed[of "(remove_indices m S)" "I - S"]
+    by (metis remove_indices_indices)
+  then show ?thesis
+    using assms poly_eval_monomial[of g S m  ]
+          poly_scalar_mult_closed[of "(monom_eval R (restrict_to_indices m S) g)"
+                                        "(mset_to_IP R (remove_indices m S))"] 
+    by (metis monom_eval_car)
+qed
+
+lemma poly_scalar_mult_iter:
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "P \<in> Pring_set R I"
+  assumes "k \<in> carrier R"
+  assumes "n \<in> carrier R"
+  shows "poly_scalar_mult R k (poly_scalar_mult R n P) = poly_scalar_mult R (k \<otimes> n) P"
+  using assms 
+  unfolding poly_scalar_mult_def 
+  by (metis Pring_cfs_closed m_assoc)
+
+lemma poly_scalar_mult_comm:
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "P \<in> Pring_set R I"
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier R"
+  shows "poly_scalar_mult R a (poly_scalar_mult R b P) = poly_scalar_mult R b (poly_scalar_mult R a P)"
+  using assms  poly_scalar_mult_iter m_comm[of a b]
+  by metis
+
+lemma poly_eval_monomial_term:
+  assumes "closed_fun R g"
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "set_mset m \<subseteq> I"
+  assumes "k \<in> carrier R"
+  shows "poly_eval R  S g (poly_scalar_mult R k (mset_to_IP R m)) = poly_scalar_mult R (k\<otimes>(monom_eval R (restrict_to_indices m S) g))
+                              (mset_to_IP R (remove_indices m S))"
+proof-
+  have 0: "poly_eval R  S g (poly_scalar_mult R k (mset_to_IP R m)) =
+          poly_scalar_mult R k (poly_eval R S g (mset_to_IP R m))"
+    using assms poly_eval_scalar_mult[of k g "mset_to_IP R m" I S] mset_to_IP_closed 
+    by blast
+  have 1: "poly_eval R  S g (poly_scalar_mult R k (mset_to_IP R m)) =
+           poly_scalar_mult R k (poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                              (mset_to_IP R (remove_indices m S))) "
+    using 0 assms 
+    by (metis poly_eval_monomial)
+  have 2: "mset_to_IP R (remove_indices m S) \<in> Pring_set R I"
+    using assms mset_to_IP_closed 
+    by (metis Diff_subset remove_indices_def restrict_to_indicesE subset_iff)
+  have 3: "monom_eval R (restrict_to_indices m S) g \<in> carrier R"
+    using assms monom_eval_car by blast
+  show ?thesis 
+    using 1 2 3 assms   poly_scalar_mult_iter[of  "mset_to_IP R (remove_indices m S)" I k "(monom_eval R (restrict_to_indices m S) g)"]
+  by presburger
+qed
+
+lemma poly_eval_monomial_term_closed:
+  assumes "closed_fun R g"
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "set_mset m \<subseteq> I"
+  assumes "k \<in> carrier R"
+  shows "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m)) \<in> Pring_set R (I - S)"
+proof-
+  have "(mset_to_IP R (remove_indices m S)) \<in> Pring_set R (I - S)"
+    using assms 
+    by (meson remove_indices_indices mset_to_IP_closed)
+  then show ?thesis 
+    using assms poly_eval_monomial_term remove_indices_indices[of m I S]
+    by (metis cring.cring_simprules(5) cring.monom_eval_car is_cring poly_scalar_mult_closed)
+qed
+
+lemma finsum_split:
+  assumes "finite S"
+  assumes "f \<in> S \<rightarrow> carrier R"
+  assumes "g \<in> S \<rightarrow> carrier R"
+  assumes "k \<in> carrier  R"
+  assumes "c \<in> S"
+  assumes "\<And>s. s \<in> S \<and> s \<noteq> c \<Longrightarrow> f s = g s"
+  assumes "g c = f c \<oplus> k"
+  shows "finsum R g S = k \<oplus> finsum R f S"
+proof-
+  have 0: "finsum R f S = f c \<oplus> finsum R f (S - {c})"
+  proof-
+    have "f \<in> S - {c} \<rightarrow> carrier R"
+      by (metis Pi_split_insert_domain assms(2) assms(5) insert_Diff)
+    then show ?thesis  
+    using assms finsum_insert[of "S - {c}" c f] 
+    by (metis DiffD2 Pi_iff finite_Diff insert_Diff singletonI)
+  qed
+  have 1: "finsum R g S = g c \<oplus> finsum R g (S - {c})"
+  proof-
+    have "g \<in> S - {c} \<rightarrow> carrier R"
+      by (metis Pi_split_insert_domain  assms(3) assms(5) insert_Diff)
+    then show ?thesis  
+    using assms finsum_insert[of "S - {c}" c g] 
+    by (metis DiffD2 Pi_iff finite_Diff insert_Diff singletonI)
+  qed
+  have "finsum R f (S - {c}) = finsum R g (S - {c})"
+    using assms Diff_iff Pi_split_insert_domain finsum_cong'[of "S- {c}" "S - {c}" g f] 
+      insert_Diff singletonI 
+    by blast
+  then have "finsum R g S = f c \<oplus> k \<oplus> finsum R g (S - {c})"
+    using assms  \<open>finsum R g S = g c \<oplus> finsum R g (S - {c})\<close> 
+    by presburger
+  then have 1: "finsum R g S = f c \<oplus> k \<oplus> finsum R f (S - {c})"
+    using \<open>finsum R f (S - {c}) = finsum R g (S - {c})\<close> by presburger
+  have "finsum R g S = k \<oplus> ( f c \<oplus> finsum R f (S - {c}))"
+  proof- 
+    have "f c \<in> carrier R"
+      by (metis PiE assms(2) assms(5))
+    have "finsum R f (S - {c}) \<in> carrier R"
+      by (metis Pi_split_insert_domain assms(2) assms(5) finsum_closed insert_Diff)
+    then show ?thesis using assms(4) 1 
+      using \<open>f c \<in> carrier R\<close> add.m_assoc add.m_lcomm 
+      by presburger
+  qed
+  then show ?thesis 
+    using "0" 
+    by presburger
+qed 
+
+lemma poly_monom_induction:
+assumes "P (indexed_const \<zero>)"
+assumes "\<And>m k. set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> P (poly_scalar_mult R k (mset_to_IP R m))"
+assumes "\<And>Q m k. Q \<in> Pring_set R I \<and> (P Q) \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R\<Longrightarrow> P (Q \<Oplus> (poly_scalar_mult R k (mset_to_IP R m)))"
+shows "\<And>Q. Q \<in> Pring_set R I \<Longrightarrow> P Q"
+proof-
+  have 0: "\<And>Ms. finite Ms \<Longrightarrow> (\<forall> Q \<in> Pring_set R I. monomials_of R Q = Ms \<longrightarrow> P Q)"
+  proof-
+    fix Ms
+    show " finite Ms \<Longrightarrow> (\<forall> Q \<in> Pring_set R I. monomials_of R Q = Ms \<longrightarrow> P Q)"
+    proof(erule finite.induct)
+      show "\<forall>Q\<in>Pring_set R I. monomials_of R Q = {} \<longrightarrow> P Q"
+      proof
+        fix Q
+        assume "Q \<in> Pring_set R I"
+        show "monomials_of R Q = {} \<longrightarrow> P Q "
+          using assms 
+          by (metis \<open>Q \<in> Pring_set R I\<close> card_0_eq monomials_finite monomials_of_card_zero)
+      qed
+      show "\<And>A a. finite A \<Longrightarrow> \<forall>Q\<in>Pring_set R I. monomials_of R Q = A \<longrightarrow> P Q \<Longrightarrow> 
+                    \<forall>Q\<in>Pring_set R I. monomials_of R Q = insert a A \<longrightarrow> P Q"
+      proof
+        fix A :: "'c monomial set" fix  a fix  Q
+        assume A0: "finite A"
+        assume A1: "\<forall>Q\<in>Pring_set R I. monomials_of R Q = A \<longrightarrow> P Q"
+        assume A2: " Q \<in> Pring_set R I "
+        show "monomials_of R Q = insert a A \<longrightarrow> P Q"
+        proof
+          assume A3: "monomials_of R Q = insert a A"
+          show "P Q"
+            apply(cases "a \<in> A")
+             apply (metis A1 A2 A3 insert_absorb)
+          proof-
+            assume A4: "a \<notin> A"
+            show "P Q"
+            proof-
+              have A5: "set_mset a \<subseteq> I"
+                by (metis A2 A3 insert_iff mset_to_IP_indices)
+              have A6: "set_mset a \<subseteq> I \<and> Q a \<in> carrier R"
+                using A2 A5 Pring_cfs_closed by blast
+              obtain Q' where Q'_def: "Q' = remove_monom R a Q"
+                by simp
+              then have "Q = Q' \<Oplus> poly_scalar_mult R (Q a) (mset_to_IP R a)"
+                using A2 cring.remove_monom_eq is_cring by blast
+              then show ?thesis using A6 assms
+                by (metis A1 A2 A3 A4 Diff_empty Diff_insert0 Q'_def insert_Diff1 
+                    remove_monom_closed remove_monom_monomials singletonI)
+            qed
+          qed
+        qed
+      qed
+    qed
+  qed
+  show "\<And>Q. Q \<in> Pring_set R I \<Longrightarrow> P Q"
+  proof-
+    fix Q
+    assume "Q \<in> Pring_set R I"
+    show "P Q"
+      using 0[of "monomials_of R Q"]  \<open>Q \<in> Pring_set R I\<close> monomials_finite 
+      by blast
+  qed
+qed
+
+lemma Pring_car_induct:
+  assumes "q \<in> carrier (Pring R I)"
+  assumes "P \<zero>\<^bsub>Pring R I\<^esub>"
+  assumes "\<And>m k. set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> P (k \<odot>\<^bsub>Pring R I\<^esub>(mset_to_IP R m))"
+  assumes "\<And>Q m k. Q \<in> carrier (Pring R I) \<and> (P Q) \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R\<Longrightarrow>
+             P (Q \<Oplus> (k \<odot>\<^bsub>Pring R I\<^esub> (mset_to_IP R m)))"
+  shows "P q"
+  using poly_monom_induction[of P I q] assms Pring_smult[of I] Pring_car[of I] Pring_zero
+  by metis 
+
+lemma poly_monom_induction2:
+assumes "P (indexed_const \<zero>)"
+assumes "\<And>m k. set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> P (poly_scalar_mult R k (mset_to_IP R m))"
+assumes "\<And>Q m k. Q \<in> Pring_set R I \<and> (P Q) \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> P (Q \<Oplus> (poly_scalar_mult R k (mset_to_IP R m)))"
+assumes "Q \<in>  Pring_set R I"
+shows "P Q"
+  using assms(1) assms(2) assms(3) assms(4) poly_monom_induction by blast
+
+lemma poly_monom_induction3:
+assumes "Q \<in>  Pring_set R I"
+assumes "P (indexed_const \<zero>)"
+assumes "\<And>m k. set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> P (poly_scalar_mult R k (mset_to_IP R m))"
+assumes "\<And>p q. p \<in> Pring_set R I \<Longrightarrow> (P p) \<Longrightarrow> q \<in> Pring_set R I \<Longrightarrow> (P q) \<Longrightarrow>  P (p \<Oplus> q)"
+shows "P Q"
+  apply(rule poly_monom_induction2[of _  I])
+  using assms(2) apply blast
+  using assms(3) apply blast
+  apply (meson assms(3) assms(4) mset_to_IP_closed poly_scalar_mult_closed)
+  using assms(1) by blast
+
+lemma Pring_car_induct':
+assumes "Q \<in> carrier (Pring R I)"
+assumes "P \<zero>\<^bsub>Pring R I\<^esub>"
+assumes "\<And>m k. set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> P (k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m)"
+assumes "\<And>p q. p \<in> carrier (Pring R I) \<Longrightarrow> (P p) \<Longrightarrow> q \<in> carrier (Pring R I) \<Longrightarrow> (P q) \<Longrightarrow>  P (p \<oplus>\<^bsub>Pring R I\<^esub> q)"
+shows "P Q"
+  using poly_monom_induction3[of Q I P] assms Pring_smult Pring_add Pring_zero Pring_car 
+  by metis 
+
+lemma poly_eval_mono:
+  assumes "P \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  assumes "finite F"
+  assumes "monomials_reducing_to R m P S \<subseteq> F"
+  assumes "\<And>n. n \<in> F \<Longrightarrow> remove_indices n S = m"
+  shows "poly_eval R S g P m = (\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes> P n)"
+proof-
+  have 0: "(\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes> P n)= 
+          (\<Oplus>n\<in> F - (monomials_reducing_to R m P S). monom_eval R (restrict_to_indices n S) g \<otimes> P n) \<oplus> poly_eval R S g P m"
+  proof-
+    have 00: "  (\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> P n) \<in> F \<rightarrow> carrier R"
+      by (meson Pi_I Pring_cfs_closed assms(1) assms(2) m_closed monom_eval_car)
+    have 01: "monomials_reducing_to R m P S \<subseteq> F"
+      by (simp add: assms(4))
+    have 02: "(\<Oplus>n\<in>F. monom_eval R (restrict_to_indices n S) g \<otimes> P n) =
+    (\<Oplus>n\<in>monomials_reducing_to R m P S. monom_eval R (restrict_to_indices n S) g \<otimes> P n) \<oplus>
+    (\<Oplus>n\<in>F - monomials_reducing_to R m P S. monom_eval R (restrict_to_indices n S) g \<otimes> P n)"
+      using "00" "01" assms(3) finsum_partition by blast
+    have 03: " (\<Oplus>n\<in>F - monomials_reducing_to R m P S. monom_eval R (restrict_to_indices n S) g \<otimes> P n)\<in> carrier R"
+      by (metis (mono_tags, lifting) "00" DiffD1 PiE Pi_I finsum_closed)
+    have "    (\<Oplus>n\<in>monomials_reducing_to R m P S. monom_eval R (restrict_to_indices n S) g \<otimes> P n) \<in> carrier R"
+    proof -
+      have "(\<lambda>m. monom_eval R (restrict_to_indices m S) g \<otimes> P m) \<in> monomials_reducing_to R m P S \<rightarrow> carrier R"
+        using "00" "01" by blast
+      then show ?thesis
+        using finsum_closed by blast
+    qed
+    then show ?thesis 
+      unfolding poly_eval_def 
+      using  00 01 02 03  add.m_comm
+      by presburger
+  qed
+  have "(\<Oplus>n\<in> F - (monomials_reducing_to R m P S). monom_eval R (restrict_to_indices n S) g \<otimes> P n) = \<zero>"
+  proof-
+    have "\<And>n. n \<in> F - (monomials_reducing_to R m P S) \<Longrightarrow>  monom_eval R (restrict_to_indices n S) g \<otimes> P n = \<zero>"
+    proof-
+      fix n
+      assume A: "n \<in>  F - (monomials_reducing_to R m P S)"
+      have "n \<notin> monomials_of R P"
+      proof
+        assume "n \<in> monomials_of R P"
+        then have "n \<in> (monomials_reducing_to R m P S)" 
+          unfolding monomials_reducing_to_def
+          using assms(5) A
+          by blast
+        then show False using A by blast 
+      qed
+      then show " monom_eval R (restrict_to_indices n S) g \<otimes> P n = \<zero>"
+        by (metis assms(2) monom_eval_car complement_of_monomials_of r_null)
+    qed
+    then show ?thesis 
+      by (meson add.finprod_one_eqI)
+  qed
+  then have 1: "(\<Oplus>n\<in>F. monom_eval R (restrict_to_indices n S) g \<otimes> P n) =
+    \<zero> \<oplus> poly_eval R S g P m"
+    using 0  Pi_I Pring_cfs_closed add.r_cancel_one assms(1) assms(2) 
+    by presburger
+  have " (\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> P n) \<in> monomials_reducing_to R m P S \<rightarrow> carrier R"
+    by (meson Pi_I Pring_cfs_closed assms(1) assms(2) m_closed monom_eval_car)
+  hence "poly_eval R S g P m \<in> carrier R"
+    using assms
+    unfolding poly_eval_def 
+    using finsum_closed[of "\<lambda> n. monom_eval R (restrict_to_indices n S) g \<otimes> P n" 
+                          "monomials_reducing_to R m P S"]
+    by (meson Pi_I Pring_cfs_closed m_closed monom_eval_car)    
+  then have "(\<Oplus>n\<in>F. monom_eval R (restrict_to_indices n S) g \<otimes> P n) = poly_eval R S g P m"
+    using "1" add.r_cancel_one zero_closed 
+    by presburger
+  then show ?thesis 
+    by presburger
+qed
+
+lemma finsum_group:
+  assumes "\<And>n. f n \<in> carrier R"
+  assumes "\<And>n. g n \<in>  carrier R"
+  shows "finite S \<Longrightarrow> finsum R f S \<oplus> finsum R g S = finsum R (\<lambda>n. f n \<oplus> g n) S "
+  apply(erule finite.induct)
+  apply (metis finsum_empty r_zero zero_closed)
+proof-
+  fix A :: "'c set "
+  fix a
+  assume A0: "finite A"
+  assume A1: "finsum R f A \<oplus> finsum R g A = (\<Oplus>n\<in>A. f n \<oplus> g n)"
+  show "finsum R f (insert a A) \<oplus> finsum R g (insert a A) = (\<Oplus>n\<in>insert a A. f n \<oplus> g n)"
+  proof(cases "a \<in> A")
+    case True
+    then show ?thesis 
+      by (metis A1 insert_absorb)   
+  next
+    case False
+    have LHS: "finsum R f (insert a A) \<oplus> finsum R g (insert a A) = 
+                  (f a \<oplus> finsum R f A) \<oplus> (g a \<oplus> finsum R g A)"
+      using assms  finsum_insert[of A a f] finsum_insert[of A a g]
+      by (metis A0 False Pi_I)
+    have F0: "(\<lambda>n. f n \<oplus> g n) \<in> A \<rightarrow> carrier R"
+      using assms 
+      by blast
+    have F1: "(f a \<oplus> g a) \<in> carrier  R"
+      using assms 
+      by blast
+    have RHS: " (\<Oplus>n\<in>insert a A. f n \<oplus> g n) = (f a \<oplus> g a) \<oplus> (\<Oplus>n\<in>A. f n \<oplus> g n)"
+      using F0 F1 assms finsum_insert[of A a " (\<lambda>n. f n \<oplus> g n)"] False A0 
+      by blast
+    have F2: " f a \<oplus> finsum R f A \<oplus> (g a \<oplus> finsum R g A) = (f a \<oplus> g a) \<oplus> (finsum R f A \<oplus>  finsum R g A)"
+    proof-
+      have F20: "f a \<in> carrier R"
+        using assms(1) by blast
+      have F21: "g a \<in> carrier R"
+        using assms(2) by blast
+      have F22: "finsum R f A \<in> carrier R"
+        by (metis Pi_iff assms(1) finsum_closed)
+      have F23: "finsum R g A \<in> carrier R"
+        by (metis Pi_I assms(2) finsum_closed)
+      show ?thesis using F21 F20 F22 F23
+        using add.m_assoc add.m_closed add.m_lcomm
+        by presburger
+    qed
+    show ?thesis
+      using RHS LHS assms A1 F2 
+      by presburger
+  qed
+qed
+
+lemma poly_eval_add:
+  assumes "P \<in> Pring_set R I"
+  assumes "Q \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (P \<Oplus> Q)   = poly_eval R S g P  \<Oplus> poly_eval R S g Q "
+proof
+  fix m
+  show "poly_eval R S g (P \<Oplus> Q)  m = (poly_eval R S g P \<Oplus> poly_eval R S g Q) m"
+  proof-
+    obtain F where F_def: "F = monomials_reducing_to R m (P \<Oplus> Q) S \<union> monomials_reducing_to R m P S \<union> 
+                              monomials_reducing_to R m Q S"
+      by simp 
+    have 0: "finite F"
+    proof-
+      have 00: "finite (monomials_reducing_to R m (P \<Oplus> Q) S)"
+        using assms 
+        by (meson finite_subset monomials_finite monomials_of_add_finite monomials_reducing_to_subset)
+      have 01: "finite (monomials_reducing_to R m P S)"
+        using assms(1) monomials_reducing_to_finite by blast
+      have 02: "finite (monomials_reducing_to R m Q S)"
+        using assms(2) monomials_reducing_to_finite by blast
+      show ?thesis  
+        using F_def 00 01 02 
+        by blast
+    qed
+    have 1: "\<And>n. n \<in> F \<Longrightarrow> remove_indices n S = m"
+    proof-
+      fix n
+      assume A: "n \<in> F"
+      show "remove_indices n S = m"
+        using F_def 
+        unfolding monomials_reducing_to_def 
+        using A 
+        by blast
+    qed
+    have 2: "poly_eval R S g (P \<Oplus> Q)  m  = (\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes> (P \<Oplus> Q) n)"
+      using assms 0 1 poly_eval_mono[of "P \<Oplus> Q" I g F m] F_def indexed_pset.indexed_padd
+      by blast
+    have 3: "poly_eval R S g P m  = (\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes> P n)"
+      using assms 0 1 poly_eval_mono[of "P" I g F m] F_def indexed_pset.indexed_padd
+      by blast  
+    have 4: "poly_eval R S g Q m  = (\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes> Q n)"
+      using assms 0 1 poly_eval_mono[of "Q" I g F m] F_def indexed_pset.indexed_padd
+      by blast  
+    have 5: "poly_eval R S g P m \<oplus> poly_eval R S g Q m = (\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes> P n
+                                                          \<oplus> monom_eval R (restrict_to_indices n S) g \<otimes> Q n)"
+    proof-
+      have 50: "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> P n) \<in> F \<rightarrow> carrier R"
+        by (meson Pi_I Pring_cfs_closed assms(1) assms(3) m_closed monom_eval_car)
+      have 51: "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> Q n) \<in> F \<rightarrow> carrier R"
+        by (meson Pi_I Pring_cfs_closed assms(2) assms(3) m_closed monom_eval_car)
+      then show ?thesis
+        using 0 2 3 50 finsum_group[of "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> P n)"
+                                       "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> Q n)" F] 
+        by (metis (mono_tags, lifting) "4" Pring_cfs_closed assms(1) assms(2) assms(3) m_closed monom_eval_car)
+    qed
+    have 6: "poly_eval R S g P m \<oplus> poly_eval R S g Q m
+           = (\<Oplus>n\<in> F. monom_eval R (restrict_to_indices n S) g \<otimes>( P n \<oplus>  Q n))"
+    proof-
+      have 0 : "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> P n \<oplus> monom_eval R (restrict_to_indices n S) g \<otimes> Q n) \<in> F \<rightarrow> carrier R"
+        apply(rule Pi_I)
+        by (meson Pring_cfs_closed add.m_closed assms(1) assms(2) assms(3) m_closed monom_eval_car)
+      have 1: "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (P n \<oplus> Q n)) \<in> F \<rightarrow> carrier R"
+        apply(rule Pi_I)
+        by (meson Pring_cfs_closed add.m_closed assms(1) assms(2) assms(3) m_closed monom_eval_car)
+      have "\<And>n. n \<in> F \<Longrightarrow>  monom_eval R (restrict_to_indices n S) g \<otimes>( P n \<oplus>  Q n) = monom_eval R (restrict_to_indices n S) g \<otimes> P n
+                                                          \<oplus> monom_eval R (restrict_to_indices n S) g \<otimes> Q n"
+        using assms Pring_cfs_closed cring.monom_eval_car is_cring r_distr
+        by metis 
+      then have "(\<lambda>x\<in>F. monom_eval R (restrict_to_indices x S) g \<otimes> P x \<oplus> monom_eval R (restrict_to_indices x S) g \<otimes> Q x) 
+                = (\<lambda>x\<in>F. monom_eval R (restrict_to_indices x S) g \<otimes> (P x \<oplus> Q x))"
+        by (metis (no_types, lifting) restrict_ext)
+      then show ?thesis
+        using 5 finsum_eq[of "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> P n  \<oplus> monom_eval R (restrict_to_indices n S) g \<otimes> Q n)"
+                            F "(\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes>( P n \<oplus>  Q n))" ] 0 1 
+        by presburger
+    qed                  
+    have 7: "monomials_reducing_to R m (P \<Oplus> Q) S \<subseteq> F"
+      using F_def 
+      by blast
+    have 8: "poly_eval R S g (P \<Oplus> Q)  m  = (\<Oplus>n\<in>F. monom_eval R (restrict_to_indices n S) g \<otimes> (P \<Oplus> Q) n)"
+      using 7 0 1 "2"
+      by blast
+    obtain f where f_def: "f = (\<lambda>n. monom_eval R (restrict_to_indices n S) g \<otimes> (P \<Oplus> Q) n)"
+      by blast 
+    obtain h where h_def: "h = (\<lambda>n.  monom_eval R (restrict_to_indices n S) g \<otimes>( P n \<oplus>  Q n))"
+      by blast 
+    have 9: "f \<in> F \<rightarrow> carrier R"
+      using f_def 
+      by (metis (mono_tags, lifting) Pi_I Pring_cfs_closed add.m_closed
+          assms(1) assms(2) assms(3) indexed_padd_def m_closed monom_eval_car)
+    have 10: "h \<in> F \<rightarrow> carrier R"
+      using h_def 
+      by (metis (mono_tags, lifting) "9" Pi_cong f_def indexed_padd_def)
+    have 11: "restrict f F = restrict h F"
+      using f_def h_def 
+      by (metis indexed_padd_def)      
+    have "finsum R f F = finsum R h F"
+      using 9 10 11 finsum_eq[of f F h]  
+      by blast
+    then show ?thesis 
+      using f_def h_def 
+      by (metis (no_types, lifting) "6" "8"  indexed_padd_def)
+  qed
+qed   
+
+lemma poly_eval_Pring_add:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (P \<oplus>\<^bsub>Pring R I\<^esub> Q)   = poly_eval R S g P \<oplus>\<^bsub>Pring R I\<^esub> poly_eval R S g Q "
+  using assms poly_eval_add[of P I Q g S]  
+  by (metis Pring_add Pring_car)
+
+text\<open>Closure of partial evaluation maps:\<close>
+lemma(in cring) poly_eval_closed:
+  assumes "closed_fun R g"
+  assumes "P \<in> Pring_set R I"
+  shows "poly_eval R S g P \<in> Pring_set R (I - S)"
+proof-
+  obtain Pr where Pr_def[simp]: "Pr = (\<lambda>Q. poly_eval R S g Q \<in> Pring_set R (I - S))"
+    by blast
+  have "Pr P"
+    apply(rule poly_monom_induction2[of _ I _ ])
+     apply (metis Pr_def indexed_pset.indexed_const poly_eval_constant zero_closed)
+       apply (metis Pr_def assms(1) indexed_pset.indexed_const mset_to_IP_closed 
+        poly_eval_constant poly_eval_monomial_term_closed poly_scalar_mult_zero r_null r_one)
+  proof-
+    show "P \<in> Pring_set R I" using assms by blast 
+    show "\<And>Q m k. Q \<in> Pring_set R I \<and> Pr Q \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R\<Longrightarrow> Pr (Q \<Oplus> poly_scalar_mult R k (mset_to_IP R m))"
+    proof-
+      fix Q 
+      fix m 
+      fix k
+      assume A: "Q \<in> Pring_set R I \<and> Pr Q \<and> set_mset m \<subseteq> I\<and> k \<in> carrier R"
+      then have 0: "poly_eval R S g Q \<in> Pring_set R (I - S)"
+        using Pr_def by blast
+      have 1: "poly_scalar_mult R k (mset_to_IP R m) \<in> Pring_set R I"
+        using  A mset_to_IP_closed poly_scalar_mult_closed 
+        by blast
+      have  "poly_eval R  S g (Q \<Oplus> poly_scalar_mult R k (mset_to_IP R m)) = 
+     poly_eval R S g Q \<Oplus> poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m))   "
+        using assms poly_eval_add[of Q I " (poly_scalar_mult R k (mset_to_IP R m))" g]  "1" A 
+        by blast
+      then show "Pr (Q \<Oplus> poly_scalar_mult R k (mset_to_IP R m))"
+        using Pr_def 
+        by (metis "1" A assms(1) indexed_pset.indexed_padd poly_eval_monomial_term_closed poly_scalar_mult_one poly_scalar_mult_zero)
+    qed
+  qed
+  then show ?thesis 
+    using Pr_def 
+    by blast
+qed
+
+lemma poly_scalar_mult_indexed_pmult:
+  assumes "P \<in> Pring_set R I"
+  assumes "k \<in> carrier R"
+  shows " poly_scalar_mult R k (P \<Otimes> i) = (poly_scalar_mult R k P) \<Otimes> i"
+proof-
+  have 0: "mset_to_IP R {#i#} \<in> Pring_set R (I \<union> {i})"
+    by (metis Un_upper2 mset_to_IP_closed set_mset_add_mset_insert set_mset_empty)
+  have 1: "P \<in> Pring_set R (I \<union> {i})"
+    using Pring_carrier_subset Un_upper1 assms(1) by blast
+  show ?thesis 
+    using 0 1  poly_scalar_mult_times[of "mset_to_IP R {#i#}" "I \<union> {i}" P  k]
+        poly_index_mult[of P "I \<union> {i}" i] assms 
+    by (metis Un_upper2 insert_subset poly_index_mult poly_scalar_mult_closed)
+qed
+
+lemma remove_indices_add_mset:
+  assumes "i \<notin> S"
+  shows "remove_indices (add_mset i m) S = add_mset i (remove_indices m S)"
+  apply(induction m)
+  apply (smt assms empty_eq_union remove_indices_decomp restrict_to_indicesE single_is_union union_single_eq_member)
+  by (metis assms multi_union_self_other_eq remove_indices_decomp restrict_to_indices_add_element union_mset_add_mset_right)
+
+lemma poly_eval_monom_insert:
+  assumes "closed_fun R g"
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "i \<in> S"
+  shows "poly_eval R  S g (mset_to_IP R (add_mset i m))
+           = poly_scalar_mult R (g i)
+                    (poly_eval R  S g (mset_to_IP R m))"
+proof-
+  have 0: "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R (monom_eval R (restrict_to_indices (add_mset i m) S) g)
+                              (mset_to_IP R (remove_indices (add_mset i m) S))"
+    using assms(1) assms(2) poly_eval_monomial by blast
+  have 1: "(mset_to_IP R (remove_indices (add_mset i m) S)) =
+                           (mset_to_IP R (remove_indices m S))"
+    using assms 
+    by (metis (full_types) Diff_iff insert_Diff1 remove_indices_def restrict_to_indices_add_element set_mset_add_mset_insert)
+  have 2: "(monom_eval R (restrict_to_indices (add_mset i m) S) g) = 
+            (g i) \<otimes> ((monom_eval R (restrict_to_indices m S) g))"
+    using assms 
+    by (metis monom_eval_add restrict_to_indices_add_element)
+  have 3: "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R ((g i) \<otimes> ((monom_eval R (restrict_to_indices m S) g)))
+                              (mset_to_IP R (remove_indices m S))"
+    using 0 1 2 assms 
+    by presburger
+  hence "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R (g i) 
+                  (poly_scalar_mult R ((monom_eval R (restrict_to_indices m S) g))
+                              (mset_to_IP R (remove_indices m S)))"
+    using assms poly_scalar_mult_iter[of "(mset_to_IP R (remove_indices m S))"
+                                          UNIV "g i" "monom_eval R (restrict_to_indices m S) g"]
+          mset_to_IP_closed[of "remove_indices m S" UNIV]
+    by (metis PiE UNIV_I monom_eval_car subsetI)
+  thus ?thesis using assms 
+    by (metis poly_eval_monomial)
+qed    
+
+lemma poly_eval_monom_insert':
+  assumes "closed_fun R g"
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "i \<notin> S"
+  shows "poly_eval R  S g (mset_to_IP R (add_mset i m))
+           =  (poly_eval R  S g (mset_to_IP R m)) \<Otimes> i"
+proof-
+  have 0: "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R (monom_eval R (restrict_to_indices (add_mset i m) S) g)
+                              (mset_to_IP R (remove_indices (add_mset i m) S))"
+    using assms(1) assms(2) poly_eval_monomial by blast
+  hence "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                              (mset_to_IP R (remove_indices (add_mset i m) S))"
+    by (metis assms(3) restrict_to_indices_add_element)
+  hence "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                              (mset_to_IP R (add_mset i (remove_indices m S)))"
+    by (metis assms(3) remove_indices_add_mset)
+  hence "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                              (mset_to_IP R (remove_indices m S) \<Otimes> i)"
+    by (metis monom_add_mset)
+  hence "poly_eval R  S g (mset_to_IP R (add_mset i m)) = 
+                (poly_scalar_mult R (monom_eval R (restrict_to_indices m S) g)
+                              (mset_to_IP R (remove_indices m S))) \<Otimes> i"
+    by (metis assms(1) cring.monom_eval_car is_cring local.ring_axioms 
+        poly_scalar_mult_indexed_pmult ring.mset_to_IP_closed set_eq_subset)
+  thus ?thesis 
+    by (metis assms(1) assms(2) poly_eval_monomial)  
+qed    
+
+lemma poly_eval_indexed_pmult_monomial:
+  assumes "closed_fun R g"
+  assumes "k \<in> carrier R"
+  assumes "i \<in> S"
+  assumes "\<one> \<noteq> \<zero>"
+  shows "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i) =
+          poly_scalar_mult R (g i) (poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m)))"
+proof-
+  have 0: "poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i = 
+              poly_scalar_mult R k (mset_to_IP R (add_mset i m ))"
+    using monom_add_mset[of i m] poly_scalar_mult_indexed_pmult 
+    by (metis (no_types, opaque_lifting) assms(2) local.ring_axioms  ring.mset_to_IP_closed subsetD subset_refl)
+  hence 1: "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i)  = 
+             poly_scalar_mult R k (poly_eval R S g (mset_to_IP R (add_mset i m )))"
+    by (metis assms(1) assms(2) cring.poly_eval_scalar_mult is_cring local.ring_axioms ring.mset_to_IP_closed subsetI)
+  have 2: "poly_scalar_mult R (g i) (poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m)))
+            = poly_scalar_mult R (g i) 
+              (poly_scalar_mult R k  (poly_eval R S g (mset_to_IP R m))) "
+    by (smt assms(1) assms(2) local.ring_axioms poly_eval_scalar_mult ring.mset_to_IP_closed subsetD subset_refl)    
+  hence 3: "poly_scalar_mult R (g i) (poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m)))
+            = poly_scalar_mult R k 
+              (poly_scalar_mult R (g i) (poly_eval R S g (mset_to_IP R m))) "
+    using assms poly_scalar_mult_comm[of "(poly_eval R S g (mset_to_IP R m))" UNIV] 
+          poly_eval_closed[of g "(mset_to_IP R m)" UNIV]
+    by (metis UNIV_I closed_fun_simp cring.poly_scalar_mult_comm 
+        is_cring local.ring_axioms ring.mset_to_IP_closed subsetI)
+  have 4: "(poly_eval R S g (mset_to_IP R (add_mset i m))) =  (poly_scalar_mult R (g i) (poly_eval R S g (mset_to_IP R m)))"
+    using assms poly_eval_monom_insert[of g i S m]
+    by blast
+  thus ?thesis
+    using 1 3 poly_scalar_mult_comm assms
+    by presburger   
+qed
+
+lemma poly_eval_indexed_pmult_monomial':
+  assumes "closed_fun R g"
+  assumes "k \<in> carrier R"
+  assumes "i \<notin> S"
+  assumes "\<one> \<noteq> \<zero>"
+  shows "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i) =
+         (poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m))) \<Otimes> i"
+proof-
+  have "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i) =
+      poly_scalar_mult R k (poly_eval R S g ( (mset_to_IP R m) \<Otimes> i))"
+    using poly_eval_scalar_mult[of k g] 
+    by (metis UNIV_I assms(1) assms(2) local.ring_axioms poly_scalar_mult_indexed_pmult ring.monom_add_mset ring.mset_to_IP_closed subsetI)   
+  hence "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i) =
+      poly_scalar_mult R k (poly_eval R S g (mset_to_IP R (add_mset i m)))"
+    by (simp add: monom_add_mset)
+  hence "poly_eval R S g (poly_scalar_mult R k (mset_to_IP R m) \<Otimes> i) =
+      (poly_scalar_mult R k (poly_eval R S g (mset_to_IP R m))) \<Otimes> i"
+    using poly_eval_monom_insert'[of g i S m] 
+    by (smt assms(1) assms(2) assms(3) assms(4) poly_eval_monomial_closed poly_scalar_mult_indexed_pmult subsetD subset_refl)
+  thus ?thesis using assms poly_eval_scalar_mult[of k g _ UNIV S] 
+    by (metis UNIV_I mset_to_IP_closed subsetI)    
+qed
+    
+lemma indexed_pmult_add:
+  assumes "p \<in> Pring_set R I"
+  assumes "q \<in> Pring_set R I"
+  shows "p \<Oplus> q \<Otimes> i = (p \<Otimes> i) \<Oplus> (q \<Otimes> i)"
+  using assms poly_index_mult[of _ "I \<union> {i}"] 
+  by (smt Pring_carrier_subset Set.basic_monos(1) Un_upper1 Un_upper2 cring.axioms(1)
+      insert_subset is_cring mk_disjoint_insert mset_to_IP_closed ring.P_ring_ldistr 
+      ring.indexed_pset.intros(2) ring.indexed_pset_in_carrier set_mset_add_mset_insert 
+      set_mset_empty)
+
+lemma poly_eval_indexed_pmult:
+  assumes "P \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (P \<Otimes> i)   = (if i \<in> S then poly_scalar_mult R (g i) (poly_eval R S g P) else (poly_eval R S g P)\<Otimes> i )"
+proof(cases "i \<in> S")
+  case True
+  have "poly_eval R S g (P \<Otimes> i) = poly_scalar_mult R (g i) (poly_eval R S g P)"
+  apply(rule poly_monom_induction3[of P I])
+    using assms apply blast
+      apply (metis PiE UNIV_I assms(2) indexed_pmult_zero poly_eval_constant poly_scalar_mult_const r_null zero_closed)      
+        apply (meson True assms(2) poly_eval_indexed_pmult_monomial)
+          apply (smt PiE True UNIV_I assms(2) genideal_one genideal_zero indexed_pmult_zero mset_to_IP_closed poly_eval_constant poly_eval_indexed_pmult_monomial poly_scalar_mult_one poly_scalar_mult_zero singletonD)
+  proof- fix p q assume A: 
+          "p \<in> Pring_set R I"
+          "poly_eval R S g (p \<Otimes> i) = poly_scalar_mult R (g i) (poly_eval R S g p)"
+          "q \<in> Pring_set R I"
+          "poly_eval R S g (q \<Otimes> i) = poly_scalar_mult R (g i) (poly_eval R S g q)"
+    have "poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_eval R S g (p \<Otimes> i) \<Oplus> poly_eval R S g (q \<Otimes> i)"
+      using assms poly_eval_add[of "p \<Otimes> i" "I \<union> {i}" "q \<Otimes> i" g S] 
+            indexed_pmult_add[of p  I q i]
+      by (smt A(1) A(3) Pring_carrier_subset Un_insert_right Un_upper1 indexed_pset.indexed_pmult insert_iff insert_subset mk_disjoint_insert)
+    hence "poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_scalar_mult R (g i) (poly_eval R S g p) \<Oplus> 
+                                           poly_scalar_mult R (g i) (poly_eval R S g q)"
+      using A 
+      by presburger
+    hence "poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_scalar_mult R (g i) 
+                                            ((poly_eval R S g p) \<Oplus> (poly_eval R S g q))"      
+      using Pring_smult poly_eval_closed[of g] A Pring_add Pring_car  \<open>poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_eval R S g (p \<Otimes> i) \<Oplus> poly_eval R S g (q \<Otimes> i)\<close> assms(1) assms(2) closed_fun_simp 
+            Pring_smult_r_distr[of "g i" "poly_eval R S g p" _ "poly_eval R S g q"] Pring_add Pring_car 
+      by metis
+    thus "poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_scalar_mult R (g i) (poly_eval R S g (p \<Oplus> q))"
+      by (metis A(1) A(3) assms(2) poly_eval_add)
+  qed             
+  then show ?thesis 
+    using True by presburger 
+next
+  case False
+  have "poly_eval R S g (P \<Otimes> i) = (poly_eval R S g P) \<Otimes> i"
+  apply(rule poly_monom_induction3[of P I])
+       apply (simp add: assms(1))
+        apply (metis indexed_pmult_zero poly_eval_constant zero_closed)
+          apply (metis False assms(2) indexed_pmult_zero inv_unique l_null  mset_to_IP_closed 
+           one_closed one_mset_to_IP poly_eval_constant  poly_eval_indexed_pmult_monomial' 
+           poly_scalar_mult_zero  zero_closed)
+  proof-fix p q assume A: 
+          "p \<in> Pring_set R I"
+          "poly_eval R S g (p \<Otimes> i) = poly_eval R S g p \<Otimes> i"
+          "q \<in> Pring_set R I"
+          "poly_eval R S g (q \<Otimes> i) = poly_eval R S g q \<Otimes> i"
+    have "poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_eval R S g (p \<Otimes> i) \<Oplus> poly_eval R S g (q \<Otimes> i)"
+      using assms poly_eval_add[of "p \<Otimes> i" "I \<union> {i}" "q \<Otimes> i" g S] 
+            indexed_pmult_add[of p  I q i]
+      by (smt A(1) A(3) Pring_carrier_subset Un_insert_right Un_upper1 indexed_pset.indexed_pmult insert_iff insert_subset mk_disjoint_insert)
+    thus "poly_eval R S g (p \<Oplus> q \<Otimes> i) = poly_eval R S g (p \<Oplus> q) \<Otimes> i"
+      by (metis A(1) A(2) A(3) A(4) assms(2) indexed_pmult_add poly_eval_add poly_eval_closed)
+  qed             
+  then show ?thesis 
+    by (simp add: False) 
+qed
+
+lemma poly_eval_index:
+  assumes "\<one> \<noteq>\<zero>"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (mset_to_IP R {#i#})= (if i \<in> S then (indexed_const (g i)) else mset_to_IP R {#i#})"
+proof-
+  have 0: "poly_eval R S g (mset_to_IP R {#i#})= poly_scalar_mult R (monom_eval R (restrict_to_indices {#i#} S) g)
+                              (mset_to_IP R (remove_indices {#i#} S))"
+    using poly_eval_monomial[of g S "{#i#}" ] assms(1) assms(2) by blast
+  show ?thesis proof(cases "i \<in> S")
+    case True
+    then have T0: "(restrict_to_indices {#i#} S) =  {#i#}"
+      by (metis restrict_to_indices_add_element restrict_to_indices_submultiset add_mset_subseteq_single_iff)
+    then have T1: "(monom_eval R (restrict_to_indices {#i#} S) g) = (monom_eval R {#i#} g)"
+      by presburger
+    then have "(monom_eval R (restrict_to_indices {#i#} S) g)  = g i \<otimes>  monom_eval R {#} g"
+      using assms monom_eval_add[of g i "{#}"] 
+      by presburger
+    then have T2: "(monom_eval R (restrict_to_indices {#i#} S) g)  = g i"
+      unfolding monom_eval_def  
+      using T0
+      by (metis PiE UNIV_I assms(2) fold_mset_empty r_one)      
+    have T3: "(remove_indices {#i#} S) = {#}"
+      by (metis Diff_iff remove_indices_indices restrict_to_indicesE 
+          T0 multiset_cases subset_iff union_single_eq_member)
+    then have T4: " (mset_to_IP R (remove_indices {#i#} S)) = indexed_const \<one>"
+      by (metis one_mset_to_IP)
+    have T5: "poly_eval R S g (mset_to_IP R {#i#})= poly_scalar_mult R (g i) (indexed_const \<one>)"
+      using "0" T2 T4 
+      by presburger
+    then show ?thesis using True  poly_scalar_mult_const 
+      by (metis T2 assms(2) monom_eval_car one_closed r_one)      
+  next
+    case False
+    have F0: "(restrict_to_indices {#i#} S) = {#}"
+      using False restrict_to_indices_def 
+      by (metis restrict_to_indices_add_element filter_empty_mset)
+    have F1: "(monom_eval R (restrict_to_indices {#i#} S) g) = \<one>"
+      using F0 
+      unfolding monom_eval_def 
+      by (metis fold_mset_empty)
+    have F2: "(remove_indices {#i#} S) = {#i#}"
+      using False 
+      by (metis Diff_iff remove_indices_def restrict_to_indices_add_element
+          restrict_to_indices_def filter_empty_mset set_mset_single singletonI)
+    have F3: "(mset_to_IP R (remove_indices {#i#} S)) = mset_to_IP R {#i#}"
+      by (simp add: F2)
+    have F4: " poly_eval R S g (mset_to_IP R {#i#})= poly_scalar_mult R \<one> (mset_to_IP R {#i#})"
+      using "0" F1 F3 
+      by presburger
+    show ?thesis using False 
+      by (metis F4 mset_to_IP_closed poly_scalar_mult_one subset_iff)
+  qed
+qed  
+    
+lemma poly_eval_indexed_pmult':
+  assumes "P \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  assumes "i \<in> I"
+  shows "poly_eval R  S g (P \<Otimes>\<^sub>p  (mset_to_IP R {#i#}))  =  poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (mset_to_IP R {#i#})"
+proof(cases "i \<in> S")
+  case True
+  have "(P \<Otimes>\<^sub>p mset_to_IP R {#i#})=(P \<Otimes> i) "
+    using assms poly_index_mult 
+    by metis
+  then have 0: " poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R {#i#}) = poly_scalar_mult R (g i) (poly_eval R S g P)"
+    using True assms poly_eval_indexed_pmult[of P I g S i] 
+    by presburger  
+  have 1: "poly_eval R S g (mset_to_IP R {#i#}) = indexed_const (g i)"
+    using assms True 
+    by (smt PiE UNIV_I genideal_one genideal_zero indexed_pmult_zero monom_add_mset one_mset_to_IP poly_eval_constant poly_eval_index singletonD)    
+  then have "poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (mset_to_IP R {#i#})=  poly_eval R S g P\<Otimes>\<^sub>p indexed_const (g i) "
+    by presburger
+  then have "poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (mset_to_IP R {#i#})= indexed_const (g i) \<Otimes>\<^sub>p  poly_eval R S g P"
+    using assms P_ring_mult_comm[of "indexed_const (g i)" "poly_eval R S g P"] 
+    unfolding carrier_coeff_def 
+    by (metis "1" Pring_cfs_closed cring.closed_fun_simp indexed_pset.indexed_const is_cring poly_eval_closed)    
+  then have "poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (mset_to_IP R {#i#})= poly_scalar_mult R (g i)  (poly_eval R S g P)"
+    using assms 
+    by (metis "0" "1" \<open>P \<Otimes>\<^sub>p mset_to_IP R {#i#} = P \<Otimes> i\<close> cring.closed_fun_simp is_cring poly_eval_closed poly_scalar_mult_eq)    
+  then show ?thesis using 0 
+    by presburger
+next
+  case False
+  then have 0: "poly_eval R  S g (P \<Otimes>\<^sub>p  (mset_to_IP R {#i#})) = (poly_eval R S g P)\<Otimes> i "
+    using assms 
+    by (metis poly_eval_indexed_pmult poly_index_mult)
+  have 1: "poly_eval R S g (mset_to_IP R {#i#})= mset_to_IP R {#i#}"
+    using False 
+    by (metis assms(2) indexed_pmult_zero monom_add_mset one_closed one_mset_to_IP poly_eval_constant poly_eval_index)
+  then show ?thesis 
+    using 0 False assms poly_eval_index[of g]
+    by (metis UNIV_I cring.Pring_set_restrict is_cring local.ring_axioms poly_eval_closed ring.poly_index_mult subsetI)
+qed
+
+lemma poly_eval_monom_mult:
+  assumes "P \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  shows "poly_eval R  S g (P  \<Otimes>\<^sub>p  (mset_to_IP R m))  = poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (mset_to_IP R m) "
+proof(induct m)
+  case empty
+  have 0:  "mset_to_IP R {#} = indexed_const \<one>"
+    using one_mset_to_IP by blast
+  then have 1: "(P \<Otimes>\<^sub>p mset_to_IP R {#}) = P"
+    using assms 
+    by (metis P_ring_mult_comm Pring_cfs_closed carrier_coeff_def 
+        mset_to_IP_simp mset_to_IP_simp' one_closed one_mult_left zero_closed)
+  have 2: "poly_eval R S g  (mset_to_IP R {#}) = indexed_const \<one>"
+    by (metis "0" one_closed poly_eval_constant)
+  show ?case using 0 1 2 
+    by (metis assms(1) assms(2) cring.P_ring_mult_comm indexed_pset.indexed_const 
+        is_cring local.ring_axioms one_closed one_mult_left poly_eval_closed  
+        ring.indexed_pset_in_carrier set_eq_subset)
+next
+  case (add x m)
+  fix x 
+  fix m
+  assume A: "poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R m) = poly_eval R S g P \<Otimes>\<^sub>p poly_eval R S g (mset_to_IP R m)"
+  show "poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m))= poly_eval R S g P \<Otimes>\<^sub>p poly_eval R  S g (mset_to_IP R (add_mset x m))"
+  proof-
+    obtain J where J_def: "J = I \<union> set_mset m \<union>{x}"
+      by blast 
+    have I0: "P \<in> Pring_set R J"
+      using J_def assms 
+      by (meson Pring_carrier_subset Un_upper1 subsetD)
+    have I1: "set_mset m \<subseteq> J"
+      using J_def by blast
+    have I2: "x \<in> J"
+      using J_def by blast
+    have "mset_to_IP R (add_mset x m)= (mset_to_IP R m) \<Otimes> x"
+      by (simp add: monom_add_mset)
+    then have "(P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) = P \<Otimes>\<^sub>p((mset_to_IP R m) \<Otimes> x)"
+      by simp
+    then have "(P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) = P \<Otimes>\<^sub>p((mset_to_IP R m) \<Otimes>\<^sub>p (mset_to_IP R {#x#}))"
+      by (metis add_mset_add_single monom_mult)
+    then have I3: "(P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) = (P \<Otimes>\<^sub>p(mset_to_IP R m)) \<Otimes>\<^sub>p (mset_to_IP R {#x#})"
+      by (metis I0 P_ring_mult_assoc indexed_pset_in_carrier mset_to_IP_closed set_eq_subset)
+    have "poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R m \<Otimes>\<^sub>p mset_to_IP R {#x#}) = 
+            poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R m) \<Otimes>\<^sub>p poly_eval R S g  (mset_to_IP R {#x#})"
+      using poly_eval_indexed_pmult'[of "(P \<Otimes>\<^sub>p(mset_to_IP R m))" J g x] 
+            I0 I1 I2 assms(2) assms(1) mset_to_IP_mult_closed 
+      by blast
+    then have "poly_eval R S g (P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) =   
+          poly_eval R  S g (P \<Otimes>\<^sub>p(mset_to_IP R m)) \<Otimes>\<^sub>p  poly_eval R  S g (mset_to_IP R {#x#}) "
+      using I3 
+      by simp
+    then have "poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) = 
+         poly_eval R S g P \<Otimes>\<^sub>p poly_eval R S g (mset_to_IP R m)  \<Otimes>\<^sub>p  poly_eval R S g (mset_to_IP R {#x#}) "
+      by (simp add: A)
+    then have "poly_eval R S g  (P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) = 
+         poly_eval R S g P \<Otimes>\<^sub>p (poly_eval R S g (mset_to_IP R m)  \<Otimes>\<^sub>p  poly_eval R  S g (mset_to_IP R {#x#}))"
+      using P_ring_mult_assoc[of "poly_eval R S g P " "poly_eval R S g (mset_to_IP R m)"  " poly_eval R  S g (mset_to_IP R {#x#})"]
+      by (metis assms(1) assms(2)  indexed_pset_in_carrier mset_to_IP_closed poly_eval_closed set_eq_subset)
+    then have "poly_eval R  S g (P \<Otimes>\<^sub>p mset_to_IP R (add_mset x m)) = 
+         poly_eval R S g P \<Otimes>\<^sub>p (poly_eval R  S g ((mset_to_IP R m) \<Otimes>\<^sub>p (mset_to_IP R {#x#})))"
+      by (metis I1 I2 assms(2)  mset_to_IP_closed poly_eval_indexed_pmult')
+    then show ?thesis 
+      by (metis add_mset_add_single monom_mult)
+  qed
+qed
+
+abbreviation mon_term ("Mt") where
+"Mt k m \<equiv> poly_scalar_mult R k (mset_to_IP R m)"
+
+lemma poly_eval_monom_term_mult:
+  assumes "P \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  assumes "k \<in> carrier R"
+  shows "poly_eval R S g (P \<Otimes>\<^sub>p (Mt k m))   = poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (Mt k m) "
+proof-
+  obtain J where J_def: "J = I \<union> (set_mset m)"
+    by blast 
+  have J0: "P \<in> Pring_set R J"
+    using J_def Pring_carrier_subset Un_upper1 assms(1) by blast
+  have J1: "mset_to_IP R m  \<in> Pring_set R J"
+    by (metis J_def Un_upper2 mset_to_IP_closed)
+  have 0: "(P  \<Otimes>\<^sub>p  (Mt k m)) = poly_scalar_mult R k (P  \<Otimes>\<^sub>p  mset_to_IP R m)"
+    using times_poly_scalar_mult[of P J "mset_to_IP R m" k ] J0 J1 assms(3)
+    by blast
+  have 1: "poly_eval R S g (P \<Otimes>\<^sub>p (Mt k m)) = poly_scalar_mult R k (poly_eval R  S g (P  \<Otimes>\<^sub>p  mset_to_IP R m))"
+    by (metis "0" J0 J1 P_ring_mult_closed' assms(2) assms(3) cring.poly_eval_scalar_mult is_cring)
+  have 2: "poly_eval R S g (P \<Otimes>\<^sub>p (Mt k m)) = poly_scalar_mult R k ((poly_eval R S g P)  \<Otimes>\<^sub>p (poly_eval R S g (mset_to_IP R m)))"
+    by (metis "1" assms(1) assms(2)  poly_eval_monom_mult)
+  have 3: "poly_eval R S g (P \<Otimes>\<^sub>p (Mt k m)) = (poly_eval R S g P)  \<Otimes>\<^sub>p poly_scalar_mult R k  (poly_eval R S g (mset_to_IP R m))"
+    by (metis "0" "2" J0 J1 assms(2) assms(3)  poly_eval_closed times_poly_scalar_mult)
+  then show ?thesis 
+    by (metis J1 assms(3) assms(2) poly_eval_scalar_mult)
+qed
+
+lemma poly_eval_mult:
+  assumes "P \<in> Pring_set R I"
+  assumes "Q \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (P \<Otimes>\<^sub>p Q)  = poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g Q "
+proof-
+  obtain Pr where Pr_def: "Pr = (\<lambda>Q. poly_eval R S g (P \<Otimes>\<^sub>p Q)   = poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g Q )"
+    by blast 
+  have "Pr Q"
+  proof(rule poly_monom_induction2[of _ I])
+    show "Q \<in> Pring_set R I"
+      by (simp add: assms(2))
+    show "Pr (indexed_const \<zero>)"
+    proof-
+      have 0: "(P \<Otimes>\<^sub>p indexed_const \<zero>) = indexed_const \<zero>"
+        by (metis assms(1) cring.P_ring_mult_comm indexed_pset.indexed_const
+            indexed_pset_in_carrier is_cring poly_scalar_mult_eq poly_scalar_mult_zero 
+            set_eq_subset zero_closed)
+      have 1: "poly_eval R  S g (indexed_const \<zero>) = indexed_const \<zero>"
+        using poly_eval_constant by blast
+      have 2: "poly_eval R S g P  \<Otimes>\<^sub>p poly_eval R  S g (indexed_const \<zero>) = indexed_const \<zero>"
+        using 1 
+        by (metis "0" assms(1) assms(3) local.ring_axioms one_closed poly_eval_monom_term_mult
+            poly_scalar_mult_const r_one ring.one_mset_to_IP zero_closed)        
+      have 3: "poly_eval R S g (P \<Otimes>\<^sub>p indexed_const \<zero>) = indexed_const \<zero>"
+        using "0" "1" by presburger
+      show ?thesis
+        using 2 3 Pr_def 
+        by presburger
+    qed
+    show "\<And>m k. set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> Pr (poly_scalar_mult R k (mset_to_IP R m))"
+      using Pr_def assms(1) assms(3)  poly_eval_monom_term_mult by blast
+    show " \<And>Q m k. Q \<in> Pring_set R I \<and> Pr Q \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R \<Longrightarrow> Pr (Q \<Oplus> Mt k m)"
+    proof-
+      fix Q
+      fix m
+      fix k
+      assume A: "Q \<in> Pring_set R I \<and> Pr Q \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R"
+      show "Pr (Q \<Oplus> Mt k m)"
+      proof-
+        have 0: "poly_eval R S g (P \<Otimes>\<^sub>p Q)   = poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g Q "
+          using A Pr_def by blast
+        have 1: "poly_eval R S g (P \<Otimes>\<^sub>p  (Mt k m))   = poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (Mt k m)"
+          using A assms(1) assms(3)  poly_eval_monom_term_mult 
+          by blast
+        have 2: "P \<Otimes>\<^sub>p  (Q \<Oplus> Mt k m) =(P \<Otimes>\<^sub>p  Q)\<Oplus> (P \<Otimes>\<^sub>p  (Mt k m)) "
+          by (meson A assms(1) local.ring_axioms mset_to_IP_closed poly_scalar_mult_closed 
+              ring.P_ring_rdistr ring.indexed_pset_in_carrier set_eq_subset)
+        have 3: "poly_eval R S g (P \<Otimes>\<^sub>p  (Q \<Oplus> Mt k m))= poly_eval R S g (P \<Otimes>\<^sub>p Q)  \<Oplus> poly_eval R S g (P \<Otimes>\<^sub>p  (Mt k m))     "
+          by (metis "2" A P_ring_mult_closed' assms(1) assms(3) 
+              mset_to_IP_closed  poly_eval_add poly_scalar_mult_closed)
+        have 4: "poly_eval R S g (P \<Otimes>\<^sub>p  (Q \<Oplus> Mt k m))= 
+        (poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g Q) \<Oplus> ( poly_eval R S g P  \<Otimes>\<^sub>p  poly_eval R S g (Mt k m) )"
+          by (simp add: "0" "1" "3")
+        have 5: " poly_eval R S g P \<Otimes>\<^sub>p (poly_eval R S g Q \<Oplus> poly_eval R S g (Mt k m)) = poly_eval R S g P \<Otimes>\<^sub>p poly_eval R S g Q \<Oplus> (poly_eval R S g P \<Otimes>\<^sub>p poly_eval R S g (Mt k m))"
+          using ring.P_ring_rdistr[of R "(poly_eval R S g P)" "(poly_eval R S g Q)" "( poly_eval R S g (Mt k m) )"]
+          by (meson A assms(1) assms(3) indexed_pset_in_carrier local.ring_axioms 
+              poly_eval_closed poly_scalar_mult_closed ring.mset_to_IP_closed subset_refl)
+        have 6: "poly_eval R S g (P \<Otimes>\<^sub>p  (Q \<Oplus> Mt k m))= 
+        (poly_eval R S g P)  \<Otimes>\<^sub>p  ((poly_eval R S g Q) \<Oplus> ( poly_eval R S g (Mt k m) ))"
+          using 4 5 
+          by simp
+        have 7: "poly_eval R S g (P \<Otimes>\<^sub>p  (Q \<Oplus> Mt k m))= 
+        (poly_eval R S g P)  \<Otimes>\<^sub>p  (poly_eval R  S g (Q\<Oplus>(Mt k m)))"
+          using 6 poly_eval_add[of "(poly_eval R S g Q)" I "(Mt k m)" g ]  
+          by (metis A assms(3) mset_to_IP_closed poly_eval_add poly_scalar_mult_closed)
+        show ?thesis using 7 
+          using Pr_def by blast
+      qed
+    qed
+  qed
+  then show ?thesis 
+    using Pr_def by blast
+qed
+
+lemma poly_eval_Pring_mult:
+  assumes "P \<in> Pring_set R I"
+  assumes "Q \<in> Pring_set R I"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (P \<otimes>\<^bsub>Pring R I\<^esub> Q)  = poly_eval R S g P \<otimes>\<^bsub>Pring R I\<^esub> poly_eval R S g Q "
+  by (metis Pring_mult assms(1) assms(2) assms(3) poly_eval_mult)
+
+lemma poly_eval_smult:
+  assumes "P \<in> Pring_set R I"
+  assumes "a \<in> carrier R"
+  assumes "closed_fun R g"
+  shows "poly_eval R S g (a \<odot>\<^bsub>Pring R I\<^esub> P)  =a \<odot>\<^bsub>Pring R I\<^esub> poly_eval R S g P"
+  using poly_eval_scalar_mult assms 
+  by (metis Pring_smult)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Partial Evaluation is a Homomorphism\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma poly_eval_ring_hom:
+  assumes "I \<subseteq> J"
+  assumes "closed_fun R g"
+  assumes "J - S \<subseteq> I"
+  shows "ring_hom_ring (Pring R J) (Pring R I) (poly_eval R S g)"
+  apply(rule ring_hom_ringI)
+  apply (simp add: Pring_is_ring)
+  apply (simp add: Pring_is_ring)
+  apply (metis (full_types) Pring_car Pring_carrier_subset assms(2) assms(3) poly_eval_closed subset_iff)  
+  apply (metis Pring_car assms(2) local.ring_axioms poly_eval_mult ring.Pring_mult)
+  apply (metis Pring_add Pring_car assms(2) poly_eval_add)
+  by (metis Pring_one one_closed poly_eval_constant)
+
+text\<open>\texttt{poly\_eval} R at the zero function is an inverse to the inclusion of polynomial rings\<close>
+
+lemma poly_eval_zero_function:
+  assumes "g = (\<lambda>n. \<zero>)"
+  assumes "J - S = I"
+  shows "P \<in> Pring_set R I \<Longrightarrow> poly_eval R S g P = P" 
+  apply(erule indexed_pset.induct)
+  using poly_eval_constant apply blast
+  using  assms poly_eval_add[of _ I _ g S]  zero_closed  
+  apply (metis Pi_I)  
+  using Diff_iff assms(1) assms(2) Pi_I[of UNIV g ]
+      poly_eval_indexed_pmult set_eq_subset subsetD zero_closed 
+  by smt
+
+lemma poly_eval_eval_function_eq:
+  assumes "closed_fun R g"
+  assumes "closed_fun R g'"
+  assumes "restrict g S = restrict g' S"
+  assumes "P \<in> Pring_set R I"
+  shows "poly_eval R S g P = poly_eval R S g' P"
+  apply(rule indexed_pset.induct[of P I "carrier R"])
+     apply (simp add: assms(4))
+    apply (metis poly_eval_constant)
+   apply (metis assms(1) assms(2) poly_eval_add)
+proof- fix P i assume A: "P \<in> Pring_set R I" "poly_eval R S g P = poly_eval R S g' P" "i \<in> I "
+  show "poly_eval R S g (P \<Otimes> i) = poly_eval R S g' (P \<Otimes> i)"
+  proof(cases "i \<in> S")
+    case True
+    then have "g i = g' i"
+      using assms 
+      unfolding  restrict_def  
+      by meson
+    then show ?thesis     
+      using assms A poly_eval_indexed_pmult[of P I g S i] poly_eval_indexed_pmult[of P I g' S i] 
+      by presburger
+  next
+    case False
+    then show ?thesis 
+      using assms A poly_eval_indexed_pmult[of P I g S i] poly_eval_indexed_pmult[of P I g' S i] 
+      by presburger
+  qed
+qed   
+
+lemma poly_eval_eval_set_eq:
+  assumes "closed_fun R g"
+  assumes "S \<inter> I = S' \<inter> I"
+  assumes "P \<in> Pring_set R I"
+  assumes "\<one> \<noteq>\<zero>"
+  shows "poly_eval R S g P = poly_eval R S' g P"
+  apply(rule indexed_pset.induct[of P I "carrier R"])
+     apply (simp add: assms(3))
+  apply (metis poly_eval_constant)
+   apply (metis assms(1) poly_eval_add)
+proof- fix P i
+  assume A: " P \<in> Pring_set R I" "poly_eval R S g P = poly_eval R S' g P" "i \<in> I "
+  show "poly_eval R S g (P \<Otimes> i) = poly_eval R S' g (P \<Otimes> i)"
+  using assms poly_eval_index[of g _ i] A 
+  by (metis Diff_Diff_Int Diff_iff poly_eval_indexed_pmult)
+qed
+
+lemma poly_eval_trivial:
+  assumes "closed_fun R g"
+  assumes "P \<in> Pring_set R (I - S)"
+  shows "poly_eval R S g P = P"
+  apply(rule indexed_pset.induct[of P "I - S" "carrier R"])
+  apply (simp add: assms(2))
+  using poly_eval_constant apply blast
+  apply (metis assms(1) poly_eval_add)
+  by (metis Diff_iff assms(1) poly_eval_indexed_pmult)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Total Evaluation of a Polynomial\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma zero_fun_closed:
+"closed_fun R (\<lambda>n. \<zero>)"
+  by blast
+
+lemma deg_zero_cf_eval:
+  shows "P \<in> Pring_set R I \<Longrightarrow> poly_eval R I (\<lambda>n. \<zero>) P = indexed_const (P {#})"
+  apply(erule indexed_pset.induct)
+  apply (metis indexed_const_def poly_eval_constant)
+proof-
+  show " \<And>P Q. P \<in> Pring_set R I \<Longrightarrow>
+           poly_eval R I (\<lambda>n. \<zero>) P = indexed_const (P {#}) \<Longrightarrow>
+           Q \<in> Pring_set R I \<Longrightarrow> poly_eval R I (\<lambda>n. \<zero>) Q = indexed_const (Q {#}) \<Longrightarrow> poly_eval R I (\<lambda>n. \<zero>) (P \<Oplus> Q) = indexed_const ((P \<Oplus> Q) {#})"
+  proof-
+    fix P 
+    fix Q
+    assume A: "P \<in> Pring_set R I"
+    assume B: " poly_eval R I (\<lambda>n. \<zero>) P = indexed_const (P {#})"
+    assume C: "Q \<in> Pring_set R I "
+    assume D: " poly_eval R I (\<lambda>n. \<zero>) Q = indexed_const (Q {#})"
+    have "indexed_const ((P \<Oplus> Q) {#}) = indexed_const (P {#})  \<Oplus> indexed_const (Q {#})"
+      by (metis indexed_padd_const indexed_padd_def)
+    thus "poly_eval R I (\<lambda>n. \<zero>) (P \<Oplus> Q) = indexed_const ((P \<Oplus> Q) {#})"
+      using A B C D poly_eval_add[of P I Q "\<lambda>n. \<zero>" I] 
+      by (smt zero_fun_closed)
+  qed
+  show "\<And>P i. P \<in> Pring_set R I \<Longrightarrow> poly_eval R I (\<lambda>n. \<zero>) P = indexed_const (P {#}) \<Longrightarrow> i \<in> I \<Longrightarrow> poly_eval R I (\<lambda>n. \<zero>) (P \<Otimes> i) = indexed_const ((P \<Otimes> i) {#})"
+  proof-
+    fix P
+    fix i
+    assume A: "P \<in> Pring_set R I" "poly_eval R I (\<lambda>n. \<zero>) P = indexed_const (P {#})" "i \<in> I"
+    show "poly_eval R I (\<lambda>n. \<zero>) (P \<Otimes> i) = indexed_const ((P \<Otimes> i) {#})"
+    proof-
+      have "poly_eval R I (\<lambda>n. \<zero>) (P \<Otimes> i) = indexed_const \<zero>"
+        using A(1) A(3) cring.poly_eval_constant is_cring poly_eval_indexed_pmult 
+              poly_eval_scalar_mult poly_scalar_mult_zero zero_closed
+        by (metis Pi_I)
+      have "(P \<Otimes> i) {#} = \<zero>"
+        using indexed_pmult_def 
+        by (metis empty_iff set_mset_empty)
+      then show ?thesis 
+        using \<open>poly_eval R I (\<lambda>n. \<zero>) (P \<Otimes> i) = indexed_const \<zero>\<close>
+        by presburger
+    qed
+  qed
+qed
+
+lemma deg_zero_cf_mult:
+  assumes "P \<in> Pring_set R I"
+  assumes "Q \<in> Pring_set R I"
+  shows " (P \<Otimes>\<^sub>p Q) {#} = P {#} \<otimes> Q {#}"
+proof-
+  have "poly_eval R I (\<lambda>n. \<zero>) (P \<Otimes>\<^sub>p Q) = poly_eval R I (\<lambda>n. \<zero>) P \<Otimes>\<^sub>p  poly_eval R I (\<lambda>n. \<zero>) Q"
+    using zero_fun_closed assms  
+    by (metis poly_eval_mult)
+  then have 0: "indexed_const ((P \<Otimes>\<^sub>p Q) {#}) = (indexed_const (P {#})) \<Otimes>\<^sub>p (indexed_const (Q {#}))"
+    by (metis P_ring_mult_closed' Pring_cfs_closed assms(1) assms(2) deg_zero_cf_eval indexed_const_P_mult_eq indexed_const_def)
+  have "indexed_const ((P \<Otimes>\<^sub>p Q) {#}) = (indexed_const ((P {#}) \<otimes>(Q {#})))"
+    apply(rule ccontr)
+    using 0 
+    by (metis Pring_cfs_closed assms(1) assms(2) indexed_const_P_mult_eq)
+  then show ?thesis 
+  proof -
+    show ?thesis
+      by (metis (no_types) \<open>indexed_const ((P \<Otimes>\<^sub>p Q) {#}) = indexed_const (P {#} \<otimes> Q {#})\<close> 
+        local.ring_axioms ring.indexed_const_def)
+  qed
+qed
+
+definition deg_zero_cf :: "('a, 'c) mvar_poly \<Rightarrow> 'a" where
+"deg_zero_cf P = P {#}"
+
+lemma deg_zero_cf_ring_hom:
+  shows "ring_hom_ring (Pring R I) R (deg_zero_cf)"
+  apply(rule ring_hom_ringI)
+  using Pring_is_ring apply blast
+  apply (simp add: local.ring_axioms)
+  apply (metis deg_zero_cf_def Pring_car Pring_cfs_closed)
+  apply (metis deg_zero_cf_def Pring_car Pring_mult deg_zero_cf_mult)
+  apply (metis deg_zero_cf_def Pring_add indexed_padd_def)
+  by (metis deg_zero_cf_def Pring_one indexed_const_def)
+
+end
+
+definition eval_in_ring ::
+ "('a,'b) ring_scheme \<Rightarrow> 'c set \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> 'a" where
+"eval_in_ring R S g P = (poly_eval R S g P) {#}"
+
+definition total_eval ::
+"('a,'b) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> 'a"  where
+"total_eval R g P = eval_in_ring R UNIV g P"
+
+context cring
+begin
+
+lemma eval_in_ring_ring_hom:
+  assumes "closed_fun R g"
+  shows "ring_hom_ring (Pring R I) R (eval_in_ring R S g)"
+  unfolding eval_in_ring_def 
+  apply(rule ring_hom_ringI)
+  apply (simp add: Pring_is_ring)
+  apply (simp add: local.ring_axioms)
+    using Pring_car Pring_carrier_coeff' assms poly_eval_closed 
+     apply (metis )     
+        using Pring_mult[of I] poly_eval_mult[of _ I _ g S] poly_eval_closed[of g _ I S] deg_zero_cf_mult[of _ I] assms 
+          Pring_car[of I]
+        apply (metis deg_zero_cf_mult)
+        
+          using Pring_add[of I ] poly_eval_add[of _ I _ g S] Pring_car[of I] assms indexed_padd_def
+          apply metis
+            unfolding deg_zero_cf_def 
+            by (metis Pring_one indexed_const_def one_closed poly_eval_constant)        
+
+lemma eval_in_ring_smult:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "a \<in> carrier R"
+  assumes "closed_fun R g"
+  shows "eval_in_ring R S g (a \<odot>\<^bsub>Pring R I\<^esub> P) = a \<otimes> eval_in_ring R S g P "
+  using assms unfolding eval_in_ring_def  
+  by (smt Pring_car Pring_smult poly_eval_scalar_mult poly_scalar_mult_def)
+
+
+lemma total_eval_ring_hom:
+  assumes "closed_fun R g"
+  shows "ring_hom_ring (Pring R I) R (total_eval R g)"
+  using assms unfolding total_eval_def 
+  using eval_in_ring_ring_hom by blast
+
+lemma total_eval_smult:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "a \<in> carrier R"
+  assumes "closed_fun R g"
+  shows "total_eval R g (a \<odot>\<^bsub>Pring R I\<^esub> P) = a \<otimes> total_eval R g P"
+  using assms unfolding total_eval_def 
+  using eval_in_ring_smult by blast
+
+lemma total_eval_const:
+  assumes "k \<in> carrier R"
+  shows "total_eval R g (indexed_const k) = k"
+  unfolding total_eval_def eval_in_ring_def 
+  using assms 
+  by (metis indexed_const_def poly_eval_constant)
+
+lemma total_eval_var:
+  assumes "closed_fun R g"
+  shows "(total_eval R g (mset_to_IP R {#i#})) = g i"
+  unfolding total_eval_def eval_in_ring_def 
+  using UNIV_I assms indexed_const_def indexed_pmult_zero monom_add_mset one_closed 
+      one_mset_to_IP one_zeroD poly_eval_constant poly_eval_index  singletonD
+  by (smt PiE iso_tuple_UNIV_I monom_eval_add monom_eval_car mset_to_IP_simp poly_scalar_mult_const r_one)
+
+lemma total_eval_indexed_pmult:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "i \<in> I"
+  assumes "closed_fun R g"
+  shows "total_eval R g (P \<Otimes> i) = total_eval R g P \<otimes>\<^bsub>R\<^esub> g i"
+proof-
+  have "P \<Otimes> i = P \<Otimes>\<^sub>p mset_to_IP R ((add_mset i) {#})"
+    using assms poly_index_mult[of P I i] Pring_car 
+    by blast
+  then have 0: "(P \<Otimes> i) =  P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R {#i#})"
+    by (simp add: Pring_mult)
+  then have "total_eval R g (P \<Otimes> i) = (total_eval R g P) \<otimes>\<^bsub>R\<^esub> (total_eval R g (mset_to_IP R {#i#}))"
+  proof-
+    have "(mset_to_IP R {#i#}) \<in> carrier (Pring R I)"
+      by (metis Pring_car assms(2) mset_to_IP_closed set_mset_single singletonD subset_iff)
+    then show ?thesis 
+      using assms total_eval_ring_hom[of g I] ring_hom_mult 
+      by (metis "0" ring_hom_ring.homh)
+  qed
+  then show ?thesis 
+    by (metis assms(3) cring.total_eval_var is_cring)
+qed
+
+lemma total_eval_mult:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  assumes "closed_fun R g"
+  shows "total_eval R g (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (total_eval R g P) \<otimes>\<^bsub>R\<^esub>(total_eval R g Q) "
+  by (metis assms(1) assms(2) assms(3) ring_hom_mult ring_hom_ring.homh total_eval_ring_hom)
+
+lemma total_eval_add:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  assumes "closed_fun R g"
+  shows "total_eval R g (P \<oplus>\<^bsub>Pring R I\<^esub> Q) = (total_eval R g P) \<oplus>\<^bsub>R\<^esub>(total_eval R g Q) "
+  by (metis assms(1) assms(2) assms(3) ring_hom_add ring_hom_ring.homh total_eval_ring_hom)
+
+lemma total_eval_one:
+  assumes "closed_fun R g"
+  shows "total_eval R g \<one>\<^bsub>Pring R I\<^esub> = \<one>"
+  by (metis Pring_one one_closed total_eval_const)
+
+lemma total_eval_zero:
+  assumes "closed_fun R g"
+  shows "total_eval R g \<zero>\<^bsub>Pring R I\<^esub> = \<zero>"
+  by (metis Pring_zero total_eval_const zero_closed)
+
+lemma total_eval_closed:
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "closed_fun R g"
+  shows "total_eval R g P \<in> carrier R"
+  using assms total_eval_ring_hom[of g]
+  by (metis ring_hom_closed ring_hom_ring.homh)
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Constructing Homomorphisms from Indexed Polynomial Rings and a Universal Property\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>The inclusion of \<open>R\<close> into its polynomial ring\<close>
+
+lemma indexed_const_ring_hom:
+"ring_hom_ring R (Pring R I) (indexed_const)"
+  apply(rule ring_hom_ringI)
+  apply (simp add: local.ring_axioms)
+  apply (simp add: Pring_is_ring)
+  using Pring_car indexed_pset.indexed_const apply blast
+  apply (metis Pring_mult indexed_const_P_mult_eq)
+  apply (metis indexed_padd_const local.ring_axioms ring.Pring_add)
+  by (metis Pring_one)
+
+lemma indexed_const_inj_on:
+"inj_on (indexed_const) (carrier R)"
+  by (metis cring.total_eval_const inj_onI is_cring)
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Mapping $R[x] \to S[x]$ along a homomorphism $R \to S$\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition ring_hom_to_IP_ring_hom ::
+"('a, 'e) ring_hom \<Rightarrow> ('a, 'c) mvar_poly \<Rightarrow> 'c monomial \<Rightarrow> 'e"  where
+"ring_hom_to_IP_ring_hom \<phi> P m = \<phi> (P m)"
+
+context cring
+begin
+
+lemma ring_hom_to_IP_ring_hom_one:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  shows "ring_hom_to_IP_ring_hom \<phi> \<one>\<^bsub>Pring R I\<^esub> = \<one>\<^bsub>Pring S I\<^esub>"
+  unfolding ring_hom_to_IP_ring_hom_def 
+proof
+  fix m
+  show " \<phi> (\<one>\<^bsub>Pring R I\<^esub> m) = \<one>\<^bsub>Pring S I\<^esub> m"
+  proof(cases "m = {#}")
+    case True
+    then have "(\<one>\<^bsub>Pring R I\<^esub> m) = \<one>\<^bsub>R\<^esub>"
+      by (metis Pring_one indexed_const_def)      
+    then have "\<phi> (\<one>\<^bsub>Pring R I\<^esub> m) = \<one>\<^bsub>S\<^esub>"
+      using assms 
+      unfolding ring_hom_ring_def 
+      by (metis assms(2) ring_hom_one ring_hom_ring.homh)
+    then show ?thesis using assms cring True ring.indexed_const_def ring_hom_ring_def
+      by (metis ring.Pring_one)
+  next
+    case False
+      then have "(\<one>\<^bsub>Pring R I\<^esub> m) = \<zero>\<^bsub>R\<^esub>"
+        by (metis indexed_const_def local.ring_axioms ring.Pring_one)
+        
+    then have "\<phi> (\<one>\<^bsub>Pring R I\<^esub> m) = \<zero>\<^bsub>S\<^esub>"
+      using assms 
+      unfolding ring_hom_ring_def cring_def
+      by (metis assms(2) ring_hom_zero ring_hom_ring.homh)     
+    then show ?thesis using assms False ring.indexed_const_def ring_hom_ring_def
+      by (metis ring.Pring_one)
+  qed
+qed
+
+lemma ring_hom_to_IP_ring_hom_constant:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  assumes "a \<in> carrier R"
+  shows "ring_hom_to_IP_ring_hom \<phi> ((indexed_const a):: 'c monomial \<Rightarrow> 'a) = ring.indexed_const S (\<phi> a)"
+  unfolding ring_hom_to_IP_ring_hom_def indexed_const_def 
+proof
+  fix m:: "'c monomial"  
+  show "\<phi> (if m = {#} then a else \<zero>) = ring.indexed_const S (\<phi> a) m"
+    apply(cases "m = {#}")
+  apply (simp add: assms(1) cring.axioms(1) ring.indexed_const_def)
+  proof-
+    assume "m \<noteq> {#} "
+    then have "\<phi> (if m = {#} then a else \<zero>) = \<zero>\<^bsub>S\<^esub>"
+      by (metis (full_types) assms(1) assms(2) cring_def local.ring_axioms 
+          ring_hom_ring.homh ring_hom_zero)
+    then show " \<phi> (if m = {#} then a else \<zero>) = ring.indexed_const S (\<phi> a) m"
+      using assms  
+      by (metis \<open>m \<noteq> {#}\<close> cring.axioms(1) ring.indexed_const_def)      
+  qed
+qed
+
+lemma ring_hom_to_IP_ring_hom_add:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  shows "ring_hom_to_IP_ring_hom \<phi> (P \<oplus>\<^bsub>Pring R I\<^esub> Q) = 
+       (ring_hom_to_IP_ring_hom \<phi> P) \<oplus>\<^bsub>Pring S I\<^esub> (ring_hom_to_IP_ring_hom \<phi> Q)"
+  unfolding ring_hom_to_IP_ring_hom_def 
+proof
+  fix m
+  show " \<phi> ((P \<oplus>\<^bsub>Pring R I\<^esub> Q) m) = ((\<lambda>m. \<phi> (P m)) \<oplus>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (Q m))) m"
+  proof-
+    have RHS: "((\<lambda>m. \<phi> (P m)) \<oplus>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (Q m))) m = \<phi> (P m) \<oplus>\<^bsub>S\<^esub> \<phi> (Q m)"
+      using ring.Pring_add[of  S I _ _ ] assms 
+      by (metis cring.axioms(1) ring.indexed_padd_def)
+    have LHS: "\<phi> ((P \<oplus>\<^bsub>Pring R I\<^esub> Q) m) = \<phi> ((P m)\<oplus>\<^bsub>R\<^esub> (Q m))"
+      by (metis Pring_add indexed_padd_def)
+    then show ?thesis 
+      using assms unfolding ring_hom_ring_def 
+      using  ring_hom_add[of \<phi> R S "P m" "Q m"] 
+      by (metis Pring_carrier_coeff' RHS assms(2) ring_hom_ring.homh)
+  qed
+qed
+
+lemma ring_hom_to_IP_ring_hom_closed:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "ring_hom_to_IP_ring_hom \<phi> P \<in> carrier (Pring S I)"
+  apply(rule indexed_pset.induct[of P I "carrier R"])
+  using Pring_car assms(3) apply blast
+proof-
+  show "\<And>k. k \<in> carrier R \<Longrightarrow> ring_hom_to_IP_ring_hom \<phi> (indexed_const k) \<in> carrier (Pring S I)"
+  proof-
+    fix k
+    show " k \<in> carrier R \<Longrightarrow> ring_hom_to_IP_ring_hom \<phi> (indexed_const k) \<in> carrier (Pring S I)"
+    proof-
+      assume A: "k \<in> carrier R"
+      have "(\<phi> k) \<in> carrier S"
+        by (meson A assms(2) ring_hom_closed ring_hom_ring.homh)
+      then have 0: "ring.indexed_const S (\<phi> k) \<in> carrier (Pring S I)"
+        by (metis assms(1) cring.axioms(1) ring.Pring_car ring.indexed_pset.indexed_const)
+      then show ?thesis  
+        using  assms(2) 
+        by (simp add: "0" A ring_hom_to_IP_ring_hom_constant[of S \<phi> k] assms(1))
+    qed
+  qed
+  show "\<And>P Q. P \<in> Pring_set R I \<Longrightarrow>
+           ring_hom_to_IP_ring_hom \<phi> P \<in> carrier (Pring S I) \<Longrightarrow>
+           Q \<in> Pring_set R I \<Longrightarrow>
+           ring_hom_to_IP_ring_hom \<phi> Q \<in> carrier (Pring S I) \<Longrightarrow> ring_hom_to_IP_ring_hom \<phi> (P \<Oplus> Q) \<in> carrier (Pring S I)"
+    using ring_hom_to_IP_ring_hom_add[of S \<phi> _ I] Pring_car[of I] ring.Pring_car[of S I]
+    by (metis Pring_add assms(1) assms(2) cring.axioms(1) ring.Pring_add_closed )
+  show "\<And>P i. P \<in> Pring_set R I \<Longrightarrow>
+           ring_hom_to_IP_ring_hom \<phi> P \<in> carrier (Pring S I) \<Longrightarrow> i \<in> I \<Longrightarrow> ring_hom_to_IP_ring_hom \<phi> (P \<Otimes> i) \<in> carrier (Pring S I)"
+  proof-
+    fix P 
+    fix i
+    assume A: "P \<in> Pring_set R I " "ring_hom_to_IP_ring_hom \<phi> P \<in> carrier (Pring S I) " "i \<in> I"
+    have 0: "(\<lambda>m. \<phi> ((P \<Otimes> i) m)) = ring.indexed_pmult S (ring_hom_to_IP_ring_hom \<phi> P) i"
+    proof
+      fix m
+      show "\<phi> ((P \<Otimes> i) m) = ring.indexed_pmult S (ring_hom_to_IP_ring_hom \<phi> P) i m"
+      proof(cases "i \<in># m")
+        case True
+        then have LHS: "\<phi> ((P \<Otimes> i) m) = \<phi>  (P (m - {#i#}))"
+          by (metis indexed_pmult_def)
+        then show ?thesis 
+          using True 
+          by (metis assms(1) cring.axioms(1) ring.indexed_pmult_def ring_hom_to_IP_ring_hom_def)
+      next
+        case False
+        then have "\<phi> ((P \<Otimes> i) m) = \<phi> \<zero>\<^bsub>R\<^esub>"
+          by (metis indexed_pmult_def)
+        then have LHS: "\<phi> ((P \<Otimes> i) m) = \<zero>\<^bsub>S\<^esub>"
+          by (metis assms(1) assms(2) cring.axioms(1) local.ring_axioms 
+              ring_hom_ring.homh ring_hom_zero)
+        then show ?thesis 
+          using False assms ring.indexed_pmult_def 
+          by (metis cring.axioms(1))
+      qed
+    qed
+    then show "ring_hom_to_IP_ring_hom \<phi> (P \<Otimes> i) \<in> carrier (Pring S I)"
+      using assms 
+      unfolding ring_hom_to_IP_ring_hom_def 
+      by (metis "0" A(2) A(3) cring.axioms(1) ring.Pring_car ring.indexed_pset.simps)
+  qed  
+qed
+
+lemma ring_hom_to_IP_ring_hom_monom:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  shows "ring_hom_to_IP_ring_hom \<phi> (mset_to_IP R m) = mset_to_IP S m"
+proof
+  fix x 
+  show "ring_hom_to_IP_ring_hom \<phi> (mset_to_IP R m) x = mset_to_IP S m x"
+    unfolding ring_hom_to_IP_ring_hom_def mset_to_IP_def apply( cases "x = m" ) 
+     apply (metis (mono_tags, lifting) assms(2) ring_hom_one ring_hom_ring.homh)
+    by (metis (full_types) assms(1) assms(2) cring.axioms(1) local.ring_axioms 
+        ring_hom_ring.homh ring_hom_zero)
+qed
+
+lemma Pring_morphism:
+  assumes "cring S"
+  assumes "\<phi> \<in> (carrier (Pring R I)) \<rightarrow> (carrier S)"
+  assumes "\<phi> \<one>\<^bsub>Pring R I\<^esub> = \<one>\<^bsub>S\<^esub>"
+  assumes "\<phi> \<zero>\<^bsub>Pring R I\<^esub> = \<zero>\<^bsub>S\<^esub>"
+  assumes "\<And>P Q. P \<in> carrier (Pring R I) \<Longrightarrow> Q \<in> carrier (Pring R I) \<Longrightarrow> 
+          \<phi> (P \<oplus>\<^bsub>Pring R I\<^esub> Q) = (\<phi> P) \<oplus>\<^bsub>S\<^esub> (\<phi> Q)"
+  assumes "\<And> i . \<And> P. i \<in> I \<Longrightarrow> P \<in> carrier (Pring R I) \<Longrightarrow>  \<phi> (P \<Otimes> i) =  (\<phi> P) \<otimes>\<^bsub>S\<^esub> (\<phi> (mset_to_IP R {#i#}))"
+  assumes "\<And>k Q. k \<in> carrier R \<Longrightarrow> Q \<in> carrier (Pring R I) \<Longrightarrow>  \<phi> (poly_scalar_mult R k Q) = 
+                                     (\<phi> (indexed_const k)) \<otimes>\<^bsub>S\<^esub> (\<phi> Q)"
+  shows "ring_hom_ring (Pring R I) S \<phi>"
+  apply(rule ring_hom_ringI)
+  apply (simp add: Pring_is_ring; fail)
+  apply (simp add: assms(1) cring.axioms(1); fail)
+  using assms(2) apply blast  
+proof-
+
+  show "\<And>x y. x \<in> carrier (Pring R I) \<Longrightarrow> y \<in> carrier (Pring R I) \<Longrightarrow> \<phi> (x \<otimes>\<^bsub>Pring R I\<^esub> y) = \<phi> x \<otimes>\<^bsub>S\<^esub> \<phi> y"
+  proof-
+    fix P Q
+    assume A0: "P \<in> carrier (Pring R I)"
+    assume A1: "Q \<in> carrier (Pring R I)"
+    show "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> Q"
+    proof(rule mpoly_induct'[of ])
+      show "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> indexed_const \<zero>) = \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (indexed_const \<zero>)"
+      proof-
+        have 0: "(P \<otimes>\<^bsub>Pring R I\<^esub> indexed_const \<zero>) = \<zero>\<^bsub>Pring R I\<^esub>"
+          using assms 
+          by (metis A0 Pring_is_cring Pring_zero cring.cring_simprules(27) is_cring)
+        have 1: " \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (indexed_const \<zero>) = \<zero>\<^bsub>S\<^esub>"
+        proof-
+          have "\<phi> P \<in> carrier S"
+            using assms(2) A0
+            by blast
+          then show ?thesis 
+            using assms(4) Pring_zero[of I] 
+            by (metis assms(1) cring.cring_simprules(27))
+        qed
+        then show ?thesis using 0 1 
+          using assms(4) by presburger
+      qed 
+      show "\<And>n Q. (\<And>Q. Q \<in> Pring_set R I \<and> card (monomials_of R Q) \<le> n \<Longrightarrow> \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> Q) \<Longrightarrow>
+           Q \<in> Pring_set R I \<and> card (monomials_of R Q) = Suc n \<Longrightarrow> \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> Q"
+      proof- fix n fix Q
+        assume IH: " (\<And>Q. Q \<in> Pring_set R I \<and> card (monomials_of R Q) \<le> n \<Longrightarrow> \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> Q)"
+        assume A: "Q \<in> Pring_set R I \<and> card (monomials_of R Q) = Suc n"
+        show "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> Q"
+        proof-
+          obtain m M where m_M_def: "monomials_of R Q = insert m M \<and> m \<notin> M"
+            using A
+            by (metis card_0_eq ex_in_conv finite.emptyI mk_disjoint_insert nat.distinct(1))
+          have "Q = (restrict_poly_to_monom_set R Q M) \<oplus>\<^bsub>Pring R I\<^esub> (poly_scalar_mult R (Q m) (mset_to_IP R m))"
+            by (metis A Pring_add m_M_def remove_monom_eq remove_monom_restrict_poly_to_monom_set)
+          obtain Q' where Q'_def: "Q' = (restrict_poly_to_monom_set R Q M)"
+            by simp
+          have Q'_fact: " Q' \<in> Pring_set R I \<and> card (monomials_of R Q') \<le> n"
+            proof-
+              have 0: "Q' \<in> Pring_set R I"
+                using Q'_def  A restriction_closed 
+                by blast
+              have "monomials_of R Q' = M" 
+                using A m_M_def Q'_def 
+                by (metis restrict_poly_to_monom_set_monoms subset_insertI)
+              then have "card (monomials_of R Q') = n" using A m_M_def
+                by (metis "0" card_insert_disjoint diff_Suc_1 monomials_finite)
+              then show ?thesis 
+                by (simp add: "0")
+            qed 
+          have 0:"(P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (P \<otimes>\<^bsub>Pring R I\<^esub> (Q' \<oplus>\<^bsub>Pring R I\<^esub> (poly_scalar_mult R (Q m) (mset_to_IP R m))))"
+            using Q'_def \<open>Q = restrict_poly_to_monom_set R Q M \<oplus>\<^bsub>Pring R I\<^esub> Mt (Q m) m\<close> by presburger
+          have 1: "(P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (P \<otimes>\<^bsub>Pring R I\<^esub> Q') \<oplus>\<^bsub>Pring R I\<^esub> (P \<otimes>\<^bsub>Pring R I\<^esub> (poly_scalar_mult R (Q m) (mset_to_IP R m)))"
+          proof-
+            have 10: "P \<in> carrier (Pring R I)"
+              by (simp add: A0)
+            have 11: "Q \<in> carrier (Pring R I)"
+              by (simp add: A Pring_car)
+            have 12: "Q' \<in> carrier (Pring R I)"
+              using A Pring_car Q'_def restriction_closed by blast
+            have 13: "(poly_scalar_mult R (Q m) (mset_to_IP R m)) \<in> carrier (Pring R I)"
+              by (metis A Pring_car Pring_carrier_coeff' insert_iff m_M_def mset_to_IP_closed' poly_scalar_mult_closed)
+            then show ?thesis 
+              using 0 10 11 12 13 
+              by (metis Pring_mult_rdistr)
+          qed
+          then have "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q')) \<oplus>\<^bsub>S\<^esub> \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> (poly_scalar_mult R (Q m) (mset_to_IP R m)))"
+            by (metis A A0 Pring_car Pring_mult_closed Pring_cfs_closed Q'_def assms(5) insert_iff
+                local.ring_axioms m_M_def poly_scalar_mult_closed ring.mset_to_IP_closed' 
+                ring.restriction_closed)
+          then have "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (\<phi> P) \<otimes>\<^bsub>S\<^esub> (\<phi> Q') \<oplus>\<^bsub>S\<^esub> \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> (poly_scalar_mult R (Q m) (mset_to_IP R m)))"
+            using IH[of Q'] Q'_fact
+            by presburger
+          then have 2: "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (\<phi> P) \<otimes>\<^bsub>S\<^esub> (\<phi> Q') \<oplus>\<^bsub>S\<^esub> \<phi> (poly_scalar_mult R (Q m) (P \<otimes>\<^bsub>Pring R I\<^esub>  (mset_to_IP R m)))"
+            by (metis A A0 Pring_car Pring_mult Pring_cfs_closed insert_iff m_M_def mset_to_IP_closed' times_poly_scalar_mult)
+          have 3: "\<And>k. k \<in> carrier R \<Longrightarrow> set_mset m \<subseteq> I \<Longrightarrow> \<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub>  (mset_to_IP R m))) = 
+                    \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> (\<phi> P) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"
+          proof(induction m)
+            case empty
+            assume A: "set_mset {#} \<subseteq> I"
+            then have E0: "(P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#}) = P"
+              by (metis A0 Pring_mult_one Pring_one one_mset_to_IP)
+            have E1: "k \<in> carrier R"
+              using A Pring_cfs_closed empty.prems(1) 
+              by linarith              
+            have E2: "\<phi> (mset_to_IP R {#}) = \<one>\<^bsub>S\<^esub>"
+              by (metis Pring_one assms(3) one_mset_to_IP)
+            have E3: " \<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#})) =
+                       \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#})"
+              using E1 E2 E0 assms(7)[of "k" "P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#}"]  A0 
+              by (simp add: A0 E1)            
+            have E4: " \<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#}) =  (\<phi> P) "
+              using E0 
+              by auto
+            have E5: " \<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#})) =
+                       \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P"
+              using E0 E3 by presburger
+            have E6: " \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P =  \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P \<otimes>\<^bsub>S\<^esub> \<one>\<^bsub>S\<^esub>"
+            proof-
+              have 0: "\<phi> P \<in> carrier S"
+                using assms A0
+                by blast
+              have "indexed_const k \<in> carrier (Pring R I)"
+                using assms(2) E1 Pring_car indexed_pset.indexed_const 
+                by blast
+              then have 1: "\<phi> (indexed_const k) \<in> carrier S"
+                using assms(2)
+                by blast 
+              show ?thesis 
+                using assms(1) 0 1
+                by (metis cring.cring_simprules(12) cring.cring_simprules(14) 
+                    cring.cring_simprules(5) cring.cring_simprules(6))
+            qed
+            then show ?case 
+              using E0 E2 E3 by presburger           
+          next
+            case (add x m)
+            assume AA: "\<And>k. k \<in> carrier R \<Longrightarrow> set_mset m \<subseteq> I \<Longrightarrow> \<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R m)) = \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"
+            assume P0: "set_mset (add_mset x m) \<subseteq> I"
+            then have IA: "set_mset m \<subseteq>I"
+              by (metis insert_subset set_mset_add_mset_insert)
+            have IH: "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R m)) = 
+                        \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"
+              using AA IA add.prems(1)
+              by blast             
+            then have x_mem: "x \<in> I"
+              by (meson P0 subsetD union_single_eq_member)
+            have 0: " mset_to_IP R (add_mset x m) =  mset_to_IP R m \<Otimes> x"
+              by (simp add: monom_add_mset)
+            then have 1: "P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m) = P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m \<Otimes> x)"
+              by simp
+            have 2: "P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m) =( P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m)) \<Otimes> x"
+            proof-
+              have "mset_to_IP R (add_mset x m) = (mset_to_IP R m) \<Otimes> x"
+                using "0" by blast
+              then have "P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m) = P \<otimes>\<^bsub>Pring R I\<^esub> ((mset_to_IP R m) \<Otimes> x)"
+                by simp 
+              then have "P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m) = P \<otimes>\<^bsub>Pring R I\<^esub> ((mset_to_IP R m) \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#x#})"
+                by (metis IA Pring_mult mset_to_IP_closed poly_index_mult x_mem)
+              then have "P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m) = (P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m)) \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#x#}"
+                by (metis A0 IA Pring_car Pring_mult_assoc Pring_one Pring_one_closed 
+                    indexed_pset.indexed_pmult monom_add_mset mset_to_IP_closed one_mset_to_IP x_mem)
+              then show ?thesis 
+                by (metis A0 IA Pring_car Pring_mult Pring_mult_closed mset_to_IP_closed poly_index_mult x_mem)
+            qed
+            have 3: "poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m)) =
+                      poly_scalar_mult R k ( P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m) \<Otimes> x)"
+              using "2" by presburger
+            have 4: "poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m)) =
+                      poly_scalar_mult R k ( P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m)) \<Otimes> x"
+            proof-
+              have "poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m)) =
+                      poly_scalar_mult R k ( P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m) \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#x#})"
+                by (metis "2" A0 IA Pring_car Pring_mult Pring_mult_closed mset_to_IP_closed poly_index_mult x_mem)
+              have "poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m)) =
+                      (poly_scalar_mult R k ( P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R m)) \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#x#}"
+                by (metis A0 IA Pring_car Pring_mult Pring_mult_closed Pring_one Pring_one_closed 
+                    \<open>poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m)) = poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R m \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R {#x#})\<close> 
+                    add.prems(1) indexed_pset.indexed_pmult monom_add_mset mset_to_IP_closed 
+                    one_mset_to_IP poly_scalar_mult_times x_mem)               
+              then show ?thesis 
+                by (metis A0 IA Pring_car Pring_mult Pring_mult_closed add.prems(1) 
+                    cring.poly_scalar_mult_closed is_cring mset_to_IP_closed 
+                    poly_index_mult x_mem)                
+            qed
+            have 5: "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m))) =
+                      \<phi> (poly_scalar_mult R k ( P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m)) \<Otimes> x)"
+              using 4 by metis 
+            have 6: "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m))) =
+                      \<phi> (poly_scalar_mult R k ( P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R m))) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP  R {#x#})"
+              using assms  
+              by (metis "5" A0 IA Pring_car Pring_mult_closed add.prems(1) 
+                  cring.poly_scalar_mult_closed is_cring mset_to_IP_closed x_mem)             
+            have 7: "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m))) =
+                       \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP  R {#x#})"
+              using assms 6 IH 
+              by presburger              
+            have 8: " \<phi> (mset_to_IP R m) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP  R {#x#}) = \<phi> (mset_to_IP R (add_mset x m))"
+            proof-
+              have "\<phi> (mset_to_IP R m) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP  R {#x#}) = 
+                    \<phi> ((mset_to_IP R m) \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP  R {#x#}))"
+                by (metis IA Pring_car Pring_mult assms(6) mset_to_IP_closed poly_index_mult x_mem)
+              then show ?thesis 
+                by (metis "0" IA Pring_car assms(6) mset_to_IP_closed x_mem)
+            qed
+            have 9: "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m))) =
+             \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P \<otimes>\<^bsub>S\<^esub> ( \<phi> (mset_to_IP R m) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP  R {#x#}))"
+            proof-
+              have 0: "\<phi> (indexed_const k) \<in> carrier S"
+              proof-
+                have "(indexed_const k) \<in> carrier (Pring R I)"
+                  using A Pring_car Pring_cfs_closed indexed_pset.indexed_const add.prems(1)
+                  by blast                  
+                then show ?thesis
+                  using assms(2) 
+                  by blast   
+              qed
+              have 1: "\<phi> P \<in> carrier S" 
+                using A0 assms(2) 
+                by blast  
+              have 2: "\<phi> (mset_to_IP R m) \<in> carrier S"
+              proof-
+                have "(mset_to_IP R m) \<in> carrier (Pring R I)"
+                  using IA Pring_car mset_to_IP_closed by blast
+                then show ?thesis using assms(2) 
+                  by blast 
+              qed
+              have 3: " \<phi> (mset_to_IP  R {#x#}) \<in> carrier S"
+              proof-
+                have "(mset_to_IP  R {#x#}) \<in> carrier (Pring R I)"
+                  by (metis Pring_car Pring_one Pring_one_closed indexed_pset.indexed_pmult 
+                      monom_add_mset one_mset_to_IP x_mem)
+                then show ?thesis 
+                  using assms(2) 
+                  by blast 
+              qed
+              have "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m))) =
+                  \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> (\<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP  R {#x#}))"
+                using 1 2 3 7 
+                by (metis "0" \<open>\<phi> (mset_to_IP R m) \<in> carrier S\<close> assms(1) 
+                    cring.cring_simprules(11) cring.cring_simprules(5))
+              then show ?thesis 
+                by (metis "0" "1" "2" "3" "8" Pring_mult assms(1) cring.cring_simprules(11) 
+                    cring.cring_simprules(5))
+            qed
+            have 10: "\<phi> (poly_scalar_mult R k (P \<otimes>\<^bsub>Pring R I\<^esub> mset_to_IP R (add_mset x m))) =
+             \<phi> (indexed_const k) \<otimes>\<^bsub>S\<^esub> \<phi> P \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R (add_mset x m))"              
+              using 8 9 
+              by presburger
+            then show ?case 
+              by blast
+          qed
+          have 4: "\<phi> (poly_scalar_mult R (Q m) (P \<otimes>\<^bsub>Pring R I\<^esub>  (mset_to_IP R m))) = 
+                    \<phi> (indexed_const (Q m)) \<otimes>\<^bsub>S\<^esub> (\<phi> P) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"  
+            using 3 
+            by (metis A Pring_mult insert_iff local.ring_axioms m_M_def mset_to_IP_indices
+                ring.Pring_cfs_closed)
+          have 5: "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (\<phi> P) \<otimes>\<^bsub>S\<^esub> (\<phi> Q') \<oplus>\<^bsub>S\<^esub> \<phi> (indexed_const (Q m)) \<otimes>\<^bsub>S\<^esub> (\<phi> P) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"  
+            using 2 4 
+            by presburger
+          have " \<phi> (indexed_const (Q m)) \<otimes>\<^bsub>S\<^esub> (\<phi> P) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m) = 
+                    (\<phi> P) \<otimes>\<^bsub>S\<^esub> \<phi> (indexed_const (Q m)) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"  
+          proof-
+            have 0: "(\<phi> P)  \<in> carrier S"
+              using A0 assms(2) 
+              by blast 
+            have 1: "\<phi> (indexed_const (Q m)) \<in> carrier S"
+            proof-
+              have "indexed_const (Q m ) \<in> carrier (Pring R I)"
+                using A Pring_car Pring_cfs_closed indexed_pset.indexed_const by blast
+              then show ?thesis 
+                using assms(2) 
+                by blast 
+            qed
+            have 2: "\<phi> (mset_to_IP R m) \<in> carrier S" 
+            proof-
+              have "(mset_to_IP R m) \<in> carrier (Pring R I)"
+                by (metis A Pring_car insert_iff m_M_def mset_to_IP_closed')
+              then show ?thesis using assms(2) 
+                by blast 
+            qed
+            show ?thesis using assms(1) 0 1 2   
+              by (metis cring.cring_simprules(14))
+          qed
+          then  have 6: "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (\<phi> P) \<otimes>\<^bsub>S\<^esub> (\<phi> Q') \<oplus>\<^bsub>S\<^esub>  (\<phi> P) \<otimes>\<^bsub>S\<^esub> \<phi> (indexed_const (Q m)) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m)"  
+            using 5 
+            by presburger
+          then have 7: "\<phi> (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = (\<phi> P) \<otimes>\<^bsub>S\<^esub> ((\<phi> Q') \<oplus>\<^bsub>S\<^esub>  \<phi> (indexed_const (Q m)) \<otimes>\<^bsub>S\<^esub> \<phi> (mset_to_IP R m))"
+          proof-
+            have 0: "(\<phi> P)  \<in> carrier S"
+              using A0 assms(2) 
+              by blast 
+            have 1: "\<phi> (indexed_const (Q m)) \<in> carrier S"
+            proof-
+              have "indexed_const (Q m ) \<in> carrier (Pring R I)"
+                using A Pring_car Pring_cfs_closed indexed_pset.indexed_const by blast
+              then show ?thesis 
+                using assms(2) 
+                by blast 
+            qed
+            have 2: "\<phi> (mset_to_IP R m) \<in> carrier S" 
+            proof-
+              have "(mset_to_IP R m) \<in> carrier (Pring R I)"
+                by (metis A Pring_car insert_iff m_M_def mset_to_IP_closed')
+              then show ?thesis using assms(2) 
+                by blast 
+            qed
+            have 3: "\<phi> Q' \<in> carrier S"
+            proof-
+              have "Q' \<in> carrier (Pring R I)"
+                using Q'_fact Pring_car 
+                by blast
+              then show ?thesis 
+                using assms(2) 
+                by blast 
+            qed  
+            show ?thesis using 0 1 2 3 6 
+              by (metis assms(1) cring.cring_simprules(11) cring.cring_simprules(25) cring.cring_simprules(5))
+          qed
+          then show ?thesis 
+            by (metis A Pring_car Pring_cfs_closed Q'_def Q'_fact 
+                \<open>Q = restrict_poly_to_monom_set R Q M \<oplus>\<^bsub>Pring R I\<^esub> Mt (Q m) m\<close> assms(5) assms(7)
+                cring.poly_scalar_mult_closed insert_iff is_cring m_M_def mset_to_IP_closed')
+        qed
+      qed
+      show "Q \<in> Pring_set R I " 
+        using A1 Pring_car 
+        by blast
+    qed
+  qed
+  show "\<And>x y. x \<in> carrier (Pring R I) \<Longrightarrow> y \<in> carrier (Pring R I) \<Longrightarrow> \<phi> (x \<oplus>\<^bsub>Pring R I\<^esub> y) = \<phi> x \<oplus>\<^bsub>S\<^esub> \<phi> y"
+    using assms(5) 
+    by blast
+  show "\<phi> \<one>\<^bsub>Pring R I\<^esub> = \<one>\<^bsub>S\<^esub>"
+    by (simp add: assms(3))
+qed
+
+lemma(in cring) indexed_const_Pring_mult:
+  assumes "k \<in> carrier R"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "(indexed_const k \<otimes>\<^bsub>Pring R I\<^esub> P) m = k \<otimes>\<^bsub>R\<^esub> (P m)"
+        "(P \<otimes>\<^bsub>Pring R I\<^esub> indexed_const k) m = k \<otimes>\<^bsub>R\<^esub> (P m)"
+  apply (metis Pring_car Pring_mult assms(1) assms(2) poly_scalar_mult_def poly_scalar_mult_eq)
+  by (metis Pring_car Pring_carrier_coeff' Pring_mult assms(1) assms(2) indexed_const_P_multE m_comm)
+
+lemma(in cring) ring_hom_to_IP_ring_hom_is_hom:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  shows "ring_hom_ring (Pring R I) (Pring S I) (ring_hom_to_IP_ring_hom \<phi>)"
+proof(rule Pring_morphism)
+  show 0: "cring (Pring S I)"
+    by (simp add: assms(1) cring.axioms(1) ring.Pring_is_cring)
+  show 1: "ring_hom_to_IP_ring_hom \<phi> \<in> carrier (Pring R I) \<rightarrow> carrier (Pring S I)"
+    by (meson Pi_I assms(1) assms(2) ring_hom_to_IP_ring_hom_closed)
+  show 2: "ring_hom_to_IP_ring_hom \<phi> \<one>\<^bsub>Pring R I\<^esub> = \<one>\<^bsub>Pring S I\<^esub>"
+    by (simp add: assms(1) assms(2) ring_hom_to_IP_ring_hom_one)
+  show 3: "ring_hom_to_IP_ring_hom \<phi> \<zero>\<^bsub>Pring R I\<^esub> = \<zero>\<^bsub>Pring S I\<^esub>"
+  proof-
+    have "\<And>m. \<phi> (\<zero>\<^bsub>Pring R I\<^esub> m) = \<zero>\<^bsub>S\<^esub>"
+      using assms
+      by (metis Pring_carrier_coeff' Pring_zero Pring_zero_closed cring.axioms(1) 
+          cring.cring_simprules(26) indexed_const_Pring_mult(2) is_cring ring.Pring_is_cring 
+          ring_hom_ring.homh ring_hom_zero zero_closed)
+    then have "\<And>m. \<phi> (\<zero>\<^bsub>Pring R I\<^esub> m) = \<zero>\<^bsub>Pring S I\<^esub> m"
+      by (metis assms(1) cring.axioms(1) ring.Pring_zero ring.indexed_const_def)
+    then show ?thesis unfolding ring_hom_to_IP_ring_hom_def
+      by blast 
+  qed    
+  show 4: " \<And>P Q. P \<in> carrier (Pring R I) \<Longrightarrow>
+           Q \<in> carrier (Pring R I) \<Longrightarrow> ring_hom_to_IP_ring_hom \<phi> (P \<oplus>\<^bsub>Pring R I\<^esub> Q) = ring_hom_to_IP_ring_hom \<phi> P \<oplus>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> Q"
+    using assms(1) assms(2) ring_hom_to_IP_ring_hom_add by blast
+  show 5: " \<And>i P. i \<in> I \<Longrightarrow>
+           P \<in> carrier (Pring R I) \<Longrightarrow>
+           ring_hom_to_IP_ring_hom \<phi> (P \<Otimes> i) = ring_hom_to_IP_ring_hom \<phi> P \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> (mset_to_IP R {#i#})"
+  proof-
+    fix i P
+    assume i0: "i \<in> I"
+    assume P0: "P \<in> carrier (Pring R I)"
+    show  "ring_hom_to_IP_ring_hom \<phi> (P \<Otimes> i) = ring_hom_to_IP_ring_hom \<phi> P \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> (mset_to_IP R {#i#})"
+      unfolding ring_hom_to_IP_ring_hom_def 
+    proof
+      fix m
+      show " \<phi> ((P \<Otimes> i) m) = ((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m"
+      proof(cases "i \<in># m")
+        case True
+        have "(\<lambda>m. \<phi> (mset_to_IP R {#i#} m)) = mset_to_IP S {#i#}"
+        proof
+          fix m
+          show "\<phi> (mset_to_IP R {#i#} m) = mset_to_IP S {#i#} m"
+            apply(cases "{#i#} = m")
+             apply (metis (mono_tags, lifting) assms(1) assms(2) cring.axioms(1) local.ring_axioms 
+                mset_to_IP_def one_mset_to_IP ring.Pring_one ring.Pring_one ring.one_mset_to_IP 
+                ring_hom_to_IP_ring_hom_def ring_hom_to_IP_ring_hom_one)
+          proof-
+            assume "{#i#} \<noteq> m"
+            then have LHS: "(mset_to_IP R {#i#} m) = \<zero>\<^bsub>R\<^esub>"
+              by (metis mset_to_IP_simp')
+            have  RHS :"mset_to_IP S {#i#} m = \<zero>\<^bsub>S\<^esub>"
+              by (metis \<open>{#i#} \<noteq> m\<close> mset_to_IP_def)
+            have "\<phi> \<zero>\<^bsub>R\<^esub> = \<zero>\<^bsub>S\<^esub>"
+              using assms(1) assms(2) cring.axioms(1) local.ring_axioms 
+                ring_hom_ring.homh ring_hom_zero by blast
+            then show ?thesis 
+              using  LHS RHS 
+              by presburger
+          qed
+        qed
+        then have RHS: "((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m = 
+              ((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> mset_to_IP S {#i#}) m"
+          by presburger
+        then have RHS': "((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m = 
+              (ring.indexed_pmult S (\<lambda>m. \<phi> (P m)) i) m"
+        proof-
+          have 0: "(\<lambda>m. \<phi> (P m)) \<in> Pring_set S I"
+            using ring_hom_to_IP_ring_hom_closed[of S \<phi> P I] ring.Pring_car[of S I] assms 
+            unfolding ring_hom_to_IP_ring_hom_def 
+            using P0 cring.axioms(1) by blast
+          show ?thesis using ring.poly_index_mult[of S "(\<lambda>m. \<phi> (P m))" I i]
+            by (metis "0" \<open>(\<lambda>m. \<phi> (mset_to_IP R {#i#} m)) = mset_to_IP S {#i#}\<close> 
+                assms(1) cring.axioms(1) i0 ring.Pring_mult)
+        qed
+        then have RHS'': "((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m = 
+            (\<lambda>m. \<phi> (P m)) (m - {#i#})" using ring.indexed_pmult_def[of S "(\<lambda>m. \<phi> (P m))" i] True   
+          by (metis assms(1) cring.axioms(1))
+        then show ?thesis 
+          by (metis True indexed_pmult_def)
+      next
+        case False
+        have LHS: "((P \<Otimes> i) m) = \<zero>\<^bsub>R\<^esub>"
+          using False 
+          by (meson indexed_pmult_def)
+        have "(\<lambda>m. \<phi> (mset_to_IP R {#i#} m)) = mset_to_IP S {#i#}"
+        proof
+          fix m
+          show "\<phi> (mset_to_IP R {#i#} m) = mset_to_IP S {#i#} m"
+            apply(cases "{#i#} = m")
+             apply (metis (mono_tags, lifting) assms(1) assms(2) cring.axioms(1) local.ring_axioms 
+                mset_to_IP_def one_mset_to_IP ring.Pring_one ring.Pring_one ring.one_mset_to_IP 
+                ring_hom_to_IP_ring_hom_def ring_hom_to_IP_ring_hom_one)
+          proof-
+            assume "{#i#} \<noteq> m"
+            then have LHS: "(mset_to_IP R {#i#} m) = \<zero>\<^bsub>R\<^esub>"
+              by (metis mset_to_IP_simp')
+            have  RHS :"mset_to_IP S {#i#} m = \<zero>\<^bsub>S\<^esub>"
+              by (metis \<open>{#i#} \<noteq> m\<close> mset_to_IP_def)
+            have "\<phi> \<zero>\<^bsub>R\<^esub> = \<zero>\<^bsub>S\<^esub>"
+              using assms(1) assms(2) cring.axioms(1) local.ring_axioms 
+                ring_hom_ring.homh ring_hom_zero by blast
+            then show ?thesis 
+              using  LHS RHS 
+              by presburger
+          qed
+        qed
+        then have RHS: "((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m = 
+              ((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> mset_to_IP S {#i#}) m"
+          by presburger
+        then have RHS': "((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m = 
+              (ring.indexed_pmult S (\<lambda>m. \<phi> (P m)) i) m"
+        proof-
+          have 0: "(\<lambda>m. \<phi> (P m)) \<in> Pring_set S I"
+            using ring_hom_to_IP_ring_hom_closed[of S \<phi> P I] ring.Pring_car[of S I] assms 
+            unfolding ring_hom_to_IP_ring_hom_def 
+            using P0 cring.axioms(1) by blast
+          show ?thesis using ring.poly_index_mult[of S "(\<lambda>m. \<phi> (P m))" I i]
+            by (metis "0" \<open>(\<lambda>m. \<phi> (mset_to_IP R {#i#} m)) = mset_to_IP S {#i#}\<close> 
+                assms(1) cring.axioms(1) i0 ring.Pring_mult)
+        qed
+        then have RHS'': "((\<lambda>m. \<phi> (P m)) \<otimes>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (mset_to_IP R {#i#} m))) m = 
+              \<zero>\<^bsub>S\<^esub>"
+          using False 
+          by (metis assms(1) cring.axioms(1) ring.indexed_pmult_def)
+        then show ?thesis 
+          using LHS False assms ring_hom_zero[of \<phi> R S]  
+          by (metis cring.axioms(1) local.ring_axioms ring_hom_ring.homh)
+      qed
+    qed
+  qed
+  show "\<And>k Q. k \<in> carrier R \<Longrightarrow>
+           Q \<in> carrier (Pring R I) \<Longrightarrow>
+           ring_hom_to_IP_ring_hom \<phi> (poly_scalar_mult R k Q) = ring_hom_to_IP_ring_hom \<phi> (indexed_const k) \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> Q"
+  proof-
+    fix k Q 
+    assume A0: "k \<in> carrier R"
+    assume A1: " Q \<in> carrier (Pring R I)"
+    show "ring_hom_to_IP_ring_hom \<phi> (poly_scalar_mult R k Q) = 
+          ring_hom_to_IP_ring_hom \<phi> (indexed_const k) \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> Q"
+    proof
+      fix x
+      show "ring_hom_to_IP_ring_hom \<phi> (poly_scalar_mult R k Q) x = (ring_hom_to_IP_ring_hom \<phi> (indexed_const k) \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> Q) x"
+      proof-
+        have LHS: "ring_hom_to_IP_ring_hom \<phi> (poly_scalar_mult R k Q) x = \<phi> (k \<otimes>\<^bsub>R\<^esub> Q x)"
+          by (metis poly_scalar_mult_def ring_hom_to_IP_ring_hom_def)
+        then have LHS': "ring_hom_to_IP_ring_hom \<phi> (poly_scalar_mult R k Q) x = (\<phi> k) \<otimes>\<^bsub>S\<^esub> \<phi> (Q x)"
+        proof-
+          have "Q x \<in> carrier  R"
+            using A1 Pring_car local.ring_axioms ring.Pring_cfs_closed by blast
+          then show ?thesis 
+            using LHS assms ring_hom_mult[of \<phi> R S k "Q x"]
+            by (metis A0 ring_hom_ring.homh)
+        qed
+        have RHS: "(ring_hom_to_IP_ring_hom \<phi> (indexed_const k) \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> Q) x = 
+               (\<phi> k) \<otimes>\<^bsub>S\<^esub> (\<phi> (Q x))" 
+        proof-
+          have 0: "ring_hom_to_IP_ring_hom \<phi> (indexed_const k)= ring.indexed_const S (\<phi> k)"
+            by (simp add: A0 assms(1) assms(2) ring_hom_to_IP_ring_hom_constant)
+          have 1: "(\<phi> k) \<in> carrier S"
+            by (meson A0 assms(2) ring_hom_closed ring_hom_ring.homh)
+          have 2: "ring_hom_to_IP_ring_hom \<phi> Q \<in> carrier (Pring S I)"
+            using A1 assms ring_hom_to_IP_ring_hom_closed 
+            by blast 
+          have 3: "(ring.indexed_const S (\<phi> k) \<otimes>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> Q) x = (\<phi> k) \<otimes>\<^bsub>S\<^esub> (\<phi> (Q x))"
+            using assms(1) 1 2 
+                 cring.indexed_const_Pring_mult(1)[of S "\<phi> k" "ring_hom_to_IP_ring_hom \<phi> Q" I x] 
+                 ring_hom_to_IP_ring_hom_def[of \<phi> Q x] 
+            by presburger                 
+          then show ?thesis 
+            by (metis "0")
+        qed
+        then show ?thesis 
+          using LHS' 
+          by metis  
+      qed
+    qed
+  qed
+qed
+
+lemma ring_hom_to_IP_ring_hom_smult:
+  assumes "cring S"
+  assumes "ring_hom_ring R S \<phi>"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "a \<in> carrier R"
+  shows "ring_hom_to_IP_ring_hom \<phi> (a \<odot>\<^bsub>Pring R I\<^esub>P) =
+                 \<phi> a \<odot>\<^bsub>Pring S I\<^esub> (ring_hom_to_IP_ring_hom \<phi> P)"
+proof fix m
+  have 0: "\<phi> ((a \<odot>\<^bsub>Pring R I\<^esub> P) m) = \<phi> (a \<otimes> (P m))"
+    using assms 
+    by (metis Pring_smult_cfs)
+  hence 1: "\<phi> ((a \<odot>\<^bsub>Pring R I\<^esub> P) m) = \<phi> a \<otimes>\<^bsub>S\<^esub> \<phi> (P m)"  
+    using assms ring_hom_mult[of \<phi> R S]
+    by (metis Pring_carrier_coeff' ring_hom_ring.homh)
+  have 2: "(\<phi> a \<odot>\<^bsub>Pring S I\<^esub> (\<lambda>m. \<phi> (P m))) m = \<phi> a \<otimes>\<^bsub>S\<^esub> \<phi> (P m)"
+    using assms ring.Pring_smult[of S I] 
+    unfolding poly_scalar_mult_def cring_def 
+    by presburger
+  show "ring_hom_to_IP_ring_hom \<phi> (a \<odot>\<^bsub>Pring R I\<^esub> P) m =
+         (\<phi> a \<odot>\<^bsub>Pring S I\<^esub> ring_hom_to_IP_ring_hom \<phi> P) m" 
+    unfolding ring_hom_to_IP_ring_hom_def using assms 1 2 
+    by presburger
+qed 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>A Universal Property for Indexed Polynomial Rings\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma Pring_universal_prop_0:
+  assumes a_cring: "cring S"
+  assumes index_map: "closed_fun S g"
+  assumes ring_hom: "ring_hom_ring R S \<phi>"
+  assumes "\<psi> = (total_eval S g) \<circ> (ring_hom_to_IP_ring_hom \<phi>)"
+  shows "(ring_hom_ring (Pring R I) S \<psi>)"
+        "(\<forall>i \<in> I. \<psi> (mset_to_IP R {#i#}) = g i)"
+        "(\<forall>a \<in> carrier R. \<psi> (indexed_const a) = \<phi> a)"
+        "\<forall> \<rho>. (ring_hom_ring (Pring R I) S \<rho>) \<and> 
+          (\<forall>i \<in> I. \<rho> (mset_to_IP R {#i#}) = g i) \<and> 
+          (\<forall>a \<in> carrier R. \<rho> (indexed_const a) = \<phi> a) \<longrightarrow> 
+          (\<forall>x \<in> carrier (Pring R I). \<rho> x = \<psi> x)"
+proof-
+  have 0: " (ring_hom_to_IP_ring_hom \<phi>) \<in> ring_hom (Pring R I) (Pring S I)"
+    using a_cring ring_hom ring_hom_ring.homh ring_hom_to_IP_ring_hom_is_hom 
+    by blast
+  have 1: "(total_eval S g) \<in> ring_hom (Pring S I) S " 
+    using a_cring cring.total_eval_ring_hom index_map ring_hom_ring.homh 
+    by blast
+  show P0: "ring_hom_ring (Pring R I) S \<psi> "
+    using ring_hom_trans 0 1 Pring_is_ring a_cring assms(4) cring.axioms(1) ring_hom_ringI2 
+    by blast
+  show P1: "\<forall>i\<in>I. \<psi> (mset_to_IP R {#i#}) = g i"
+  proof
+    fix i assume Pi: "i \<in> I"
+    show "\<psi> (mset_to_IP R {#i#}) = g i"
+    proof-
+      have 0: "\<psi> (mset_to_IP R {#i#}) = (total_eval S g) ( (ring_hom_to_IP_ring_hom \<phi>) (mset_to_IP R {#i#}))"
+        by (simp add: assms(4))
+      have "( (ring_hom_to_IP_ring_hom \<phi>) (mset_to_IP R {#i#})) = (mset_to_IP S {#i#})"
+        by (simp add: a_cring ring_hom ring_hom_to_IP_ring_hom_monom)
+      then have "\<psi> (mset_to_IP R {#i#}) = (total_eval S g) (mset_to_IP S {#i#})"
+        by (simp add: 0)
+      then show ?thesis 
+        by (simp add: a_cring cring.total_eval_var index_map)
+    qed
+  qed
+  show P2: "\<forall>a\<in>carrier R. \<psi> (indexed_const a) = \<phi> a"
+  proof
+    fix a assume A: "a \<in> carrier R"
+    show "\<psi> (indexed_const a) = \<phi> a"
+    proof-
+      have 0: "ring_hom_to_IP_ring_hom \<phi> (indexed_const a) = ring.indexed_const S (\<phi> a)"
+        by (simp add: A a_cring ring_hom ring_hom_to_IP_ring_hom_constant)
+      have 1: "total_eval S g (ring.indexed_const S (\<phi> a)) = \<phi> a"
+        by (meson A a_cring cring.total_eval_const ring_hom ring_hom_closed ring_hom_ring.homh)
+      show ?thesis 
+        using assms 0 1 
+        by (simp add: "0" index_map)
+    qed
+  qed
+  show "\<forall> \<rho>. (ring_hom_ring (Pring R I) S \<rho>) \<and> 
+          (\<forall>i \<in> I. \<rho> (mset_to_IP R {#i#}) = g i) \<and> 
+          (\<forall>a \<in> carrier R. \<rho> (indexed_const a) = \<phi> a) \<longrightarrow> 
+          (\<forall>x \<in> carrier (Pring R I). \<rho> x = \<psi> x)"
+  proof
+    fix \<rho>
+    show "ring_hom_ring (Pring R I) S \<rho> \<and> (\<forall>i\<in>I. \<rho> (mset_to_IP R {#i#}) = g i) \<and> (\<forall>a\<in>carrier R. \<rho> (indexed_const a) = \<phi> a) \<longrightarrow>
+         (\<forall>x\<in>carrier (Pring R I). \<rho> x = \<psi> x)"
+    proof
+        assume A: "(ring_hom_ring (Pring R I) S \<rho>) \<and> 
+          (\<forall>i \<in> I. \<rho> (mset_to_IP R {#i#}) = g i) \<and> 
+          (\<forall>a \<in> carrier R. \<rho> (indexed_const a) = \<phi> a)"
+        show "(\<forall>x \<in> carrier (Pring R I). \<rho> x = \<psi> x)"
+        proof
+          fix x assume B: "x \<in> carrier (Pring R I)"
+          show "\<rho> x = \<psi> x"
+            apply(rule indexed_pset.induct[of x I "carrier R"])
+            using B Pring_car apply blast
+              apply (metis A P2) 
+          proof-
+            show "\<And>P Q. P \<in> Pring_set R I \<Longrightarrow> \<rho> P = \<psi> P \<Longrightarrow> Q \<in> Pring_set R I \<Longrightarrow> \<rho> Q = \<psi> Q \<Longrightarrow> \<rho> (P \<Oplus> Q) = \<psi> (P \<Oplus> Q)"
+            proof-
+              fix P Q
+              assume A0: "P \<in> Pring_set R I " "\<rho> P = \<psi> P" " Q \<in> Pring_set R I" " \<rho> Q = \<psi> Q "
+              show "\<rho> (P \<Oplus> Q) = \<psi> (P \<Oplus> Q)"
+                using A A0 ring_hom_add[of \<psi> "Pring R I" S P Q] ring_hom_add[of \<rho> "Pring R I" S P Q] P0
+                by (metis Pring_add Pring_car ring_hom_ring.homh)
+            qed
+            show "\<And>P i. P \<in> Pring_set R I \<Longrightarrow> \<rho> P = \<psi> P \<Longrightarrow> i \<in> I \<Longrightarrow> \<rho> (P \<Otimes> i) = \<psi> (P \<Otimes> i)"
+            proof-
+              fix P i
+              assume A0: " P \<in> Pring_set R I" " \<rho> P = \<psi> P" "i \<in> I"
+              show "\<rho> (P \<Otimes> i) = \<psi> (P \<Otimes> i)"
+              proof-
+                have "\<rho> (P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R {#i#})) = \<psi> (P \<otimes>\<^bsub>Pring R I\<^esub> (mset_to_IP R {#i#}))"
+                  using A A0 ring_hom_mult[of \<psi> "Pring R I" S P "(mset_to_IP R {#i#})"] 
+                        ring_hom_mult[of \<rho> "Pring R I" S P "(mset_to_IP R {#i#})"] P0
+                  by (metis P1 Pring_car Pring_one Pring_one_closed indexed_pset.indexed_pmult 
+                      monom_add_mset one_mset_to_IP ring_hom_ring.homh)
+                then show ?thesis 
+                  by (metis A0(1) A0(3) Pring_mult poly_index_mult)
+              qed
+            qed
+          qed
+        qed
+    qed
+  qed
+qed    
+
+end 
+
+definition close_fun :: "'c set \<Rightarrow> ('e, 'f) ring_scheme \<Rightarrow> ('c \<Rightarrow> 'e) \<Rightarrow> ('c \<Rightarrow> 'e)" where
+"close_fun I S g = (\<lambda>i. (if i \<in> I then g i else  \<zero>\<^bsub>S\<^esub>))"
+
+context cring
+begin
+
+lemma close_funE:
+  assumes "cring S"
+  assumes "g \<in> I \<rightarrow> carrier S"
+  shows "closed_fun S (close_fun I S g)"
+  apply(rule cring.closed_funI)
+  apply (simp add: assms(1))
+  by (metis close_fun_def PiE assms(1) assms(2) cring.cring_simprules(2))
+
+end
+
+definition indexed_poly_induced_morphism ::
+ "'c set \<Rightarrow> ('e, 'f) ring_scheme \<Rightarrow> ('a, 'e) ring_hom \<Rightarrow> ('c \<Rightarrow> 'e) \<Rightarrow> (('a,'c) mvar_poly, 'e) ring_hom" where
+"indexed_poly_induced_morphism I S \<phi> g = (total_eval S (close_fun I S g)) \<circ> (ring_hom_to_IP_ring_hom \<phi>)"
+
+context cring 
+begin
+
+lemma Pring_universal_prop:
+  assumes a_cring: "cring S"
+  assumes index_map: "g \<in> I \<rightarrow> carrier S"
+  assumes ring_hom: "ring_hom_ring R S \<phi>"
+  assumes "\<psi> = indexed_poly_induced_morphism I S \<phi> g"
+  shows "(ring_hom_ring (Pring R I) S \<psi>)"
+        "(\<forall>i \<in> I. \<psi> (mset_to_IP R {#i#}) = g i)"
+        "(\<forall>a \<in> carrier R. \<psi> (indexed_const a) = \<phi> a)"
+        "\<forall> \<rho>. (ring_hom_ring (Pring R I) S \<rho>) \<and> 
+          (\<forall>i \<in> I. \<rho> (mset_to_IP R {#i#}) = g i) \<and> 
+          (\<forall>a \<in> carrier R. \<rho> (indexed_const a) = \<phi> a) \<longrightarrow> 
+          (\<forall>x \<in> carrier (Pring R I). \<rho> x = \<psi> x)"
+proof-
+  obtain g' where g'_def: "g' =  (close_fun I S g)"
+    by simp 
+  have 0: "closed_fun S g'"
+    using close_funE a_cring g'_def index_map 
+    by blast
+  show "(ring_hom_ring (Pring R I) S \<psi>)" using assms 0 
+    using cring.Pring_universal_prop_0(1) indexed_poly_induced_morphism_def g'_def is_cring 
+    by blast
+  show "(\<forall>i \<in> I. \<psi> (mset_to_IP R {#i#}) = g i)"
+  proof- 
+    have "(\<forall>i \<in> I. \<psi> (mset_to_IP R {#i#}) = g' i)"
+      apply(intro Pring_universal_prop_0[of S _ \<phi>] assms)
+      unfolding assms indexed_poly_induced_morphism_def g'_def 
+      using assms 0 g'_def apply fastforce
+      by auto
+    thus ?thesis unfolding g'_def using assms 
+      by (simp add: close_fun_def)
+  qed
+  show "\<forall>a\<in>carrier R. \<psi> (indexed_const a) = \<phi> a"
+    using 0  indexed_poly_induced_morphism_def Pring_universal_prop_0(3) a_cring assms(4) g'_def ring_hom 
+    by blast
+  show "\<forall>\<rho>. ring_hom_ring (Pring R I) S \<rho> \<and> (\<forall>i\<in>I. \<rho> (mset_to_IP R {#i#}) = g i) \<and> (\<forall>a\<in>carrier R. \<rho> (indexed_const a) = \<phi> a) \<longrightarrow>
+        (\<forall>x\<in>carrier (Pring R I). \<rho> x = \<psi> x)"
+  proof-
+    have "\<forall>\<rho>. ring_hom_ring (Pring R I) S \<rho> \<and> (\<forall>i\<in>I. \<rho> (mset_to_IP R {#i#}) = g' i) \<and> (\<forall>a\<in>carrier R. \<rho> (indexed_const a) = \<phi> a) \<longrightarrow>
+        (\<forall>x\<in>carrier (Pring R I). \<rho> x = \<psi> x)"
+      using assms 0 Pring_universal_prop_0(4)  g'_def
+      unfolding indexed_poly_induced_morphism_def 
+      by blast
+    then show ?thesis 
+      using g'_def 
+      unfolding close_fun_def 
+      by meson
+  qed
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Mapping Mulitvariate Polynomials over a Single Variable to Univariate Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>Constructor for multisets which have one distinct element\<close>
+
+definition nat_to_mset :: "'c \<Rightarrow> nat \<Rightarrow> 'c monomial" where
+"nat_to_mset i n = Abs_multiset (\<lambda>j. if (j = i) then n else 0)"
+
+lemma nat_to_msetE: "count (nat_to_mset i n) i = n"
+  unfolding nat_to_mset_def by simp
+
+lemma nat_to_msetE':
+  assumes "j \<noteq> i"
+  shows "count (nat_to_mset i n) j = 0"
+  unfolding nat_to_mset_def using assms by simp
+
+lemma nat_to_mset_add: "nat_to_mset i (n + m) = (nat_to_mset i n) + (nat_to_mset i m)"
+  apply(rule multiset_eqI)
+  by (metis add.right_neutral nat_to_msetE nat_to_msetE' count_union)
+
+lemma nat_to_mset_inj: 
+  assumes "n \<noteq> m"
+  shows "(nat_to_mset i n) \<noteq> (nat_to_mset i m)"
+  using assms 
+  by (metis nat_to_msetE)
+
+lemma nat_to_mset_zero: "nat_to_mset i 0 = {#}"
+  by (metis add.right_neutral add_cancel_right_right nat_to_mset_add)
+
+lemma nat_to_mset_Suc: "nat_to_mset i (Suc n) = add_mset i (nat_to_mset i n)"
+  using nat_to_mset_add[of i n 1]
+  by (simp add: multiset_eqI nat_to_msetE nat_to_msetE')
+
+lemma nat_to_mset_Pring_singleton:
+  assumes "cring R"
+  assumes "P \<in> carrier (Pring R {i})"
+  assumes "m \<in> monomials_of R P"
+  shows "m = nat_to_mset i (count m i)"
+proof-
+  have "\<And> j. count m j = count (nat_to_mset i (count m i)) j"
+  proof-
+    fix j
+    show "count m j = count (nat_to_mset i (count m i)) j"
+      apply(cases "j = i")
+       apply (simp add: nat_to_msetE; fail)
+    proof-
+      assume A: "j \<noteq>i"
+      have P0: "set_mset m \<subseteq> {i}"
+        using assms 
+        by (metis cring.axioms(1) ring.Pring_car ring.mset_to_IP_indices)
+      then have "count m j = 0"
+        using A assms 
+        by (metis count_inI empty_iff singletonD subset_singletonD)
+      then show " count m j = count (nat_to_mset i (count m i)) j"
+        by (simp add: A nat_to_msetE')
+    qed
+  qed
+  then show ?thesis 
+    using multiset_eqI by blast
+qed
+
+definition IP_to_UP :: "'d \<Rightarrow> ('e, 'd) mvar_poly \<Rightarrow> 'e u_poly" where
+"IP_to_UP i P  = (\<lambda> (n::nat). P (nat_to_mset i n))"
+
+lemma IP_to_UP_closed:
+  assumes "cring R"
+  assumes "P \<in> carrier (Pring R {i::'c})"
+  shows "IP_to_UP i P \<in> carrier (UP R)"
+proof-
+  have "IP_to_UP i P \<in> up R"
+    apply(rule mem_upI)
+    using assms 
+     apply (metis cring_def IP_to_UP_def ring.Pring_carrier_coeff')
+       unfolding bound_def IP_to_UP_def
+       apply(rule ccontr)
+     proof-
+       assume A: "\<nexists>n. \<forall>m>n. P (nat_to_mset i m) = \<zero>\<^bsub>R\<^esub>"
+       then have 0: "\<forall>n. \<exists>m> n. (nat_to_mset i m) \<in> monomials_of R P"
+         by (meson assms(1) cring_def ring.complement_of_monomials_of)
+       have "\<not> finite {m. (nat_to_mset i m) \<in> monomials_of R P }"
+       proof
+         assume "finite {m. nat_to_mset i m \<in> monomials_of R P}"
+         then have "\<exists>n. \<forall>m>n.  m \<notin> {m. nat_to_mset i m \<in> monomials_of R P}"
+           by (meson finite_nat_set_iff_bounded nat_less_le order.strict_trans)
+         then have "\<exists>n. \<forall>m>n.  nat_to_mset i m \<notin> monomials_of R P"
+           by (simp add: monomials_of_def)
+         then show False using 0 
+           by blast
+       qed
+       then obtain S where S_def: "infinite (S::nat set) \<and> (\<forall>m \<in> S. (nat_to_mset i m) \<in> monomials_of R P)"
+         by blast
+       have "inj_on (nat_to_mset i) S"
+         using inj_onI[of S "nat_to_mset i"]
+         by (meson nat_to_mset_inj)
+       then have 1: "infinite (nat_to_mset i ` S)"
+         using S_def finite_imageD 
+         by blast
+       have 2: "(nat_to_mset i ` S) \<subseteq> (monomials_of R P)"
+         using S_def 
+         by blast         
+       then have "infinite (monomials_of R P)"
+         using S_def "1" finite_subset
+         by blast
+       then show False using assms 
+         by (metis Pring_def cring_def partial_object.select_convs(1) ring.monomials_finite)
+     qed
+     then show ?thesis 
+       by (metis (no_types, lifting) UP_def partial_object.select_convs(1))
+qed
+
+lemma IP_to_UP_var:
+  shows "IP_to_UP i (mset_to_IP R {#i#}) = X_poly R"
+proof
+  have UP: "UP_cring R"
+    by (simp add: UP_cring_def cring_axioms)   
+  fix x
+  show "IP_to_UP i (mset_to_IP R {#i#}) x = X_poly R x"
+  proof(cases "x = 1")
+    case True
+    then have RHS: "X_poly R x = \<one>\<^bsub>R\<^esub>"
+      unfolding X_poly_def using UP UP_ring.cfs_monom[of R]
+      unfolding UP_ring_def 
+      using local.ring_axioms one_closed by presburger
+    have LHS: "IP_to_UP i (mset_to_IP R ((add_mset i) {#})) x
+        = mset_to_IP R ((add_mset i) {#}) (nat_to_mset i x)"
+      unfolding IP_to_UP_def 
+      by blast
+    have "(nat_to_mset i x) = {#i#}"
+    proof-
+      have "\<And>n. count (nat_to_mset i x) n = count {#i#} n"
+        by (simp add: True nat_to_msetE nat_to_msetE')
+      then show ?thesis 
+        using multi_count_eq 
+        by blast
+    qed
+    then have LHS: "IP_to_UP i (mset_to_IP R ((add_mset i) {#})) x 
+       =  mset_to_IP R ((add_mset i) {#}) {#i#}"
+      using LHS by presburger  
+    then show ?thesis 
+      unfolding deg_zero_cf_def      
+      by (metis RHS mset_to_IP_simp)            
+  next
+    case False
+    then have RHS: "X_poly R x = \<zero>\<^bsub>R\<^esub>"
+      unfolding X_poly_def 
+      using UP UP_ring.cfs_monom[of R]
+      unfolding UP_ring_def 
+      using local.ring_axioms one_closed by presburger   
+    have LHS: "IP_to_UP i (mset_to_IP R ((add_mset i) {#})) x
+        = mset_to_IP R ((add_mset i) {#}) (nat_to_mset i x)"
+      unfolding IP_to_UP_def 
+      by blast      
+    then show ?thesis 
+      unfolding deg_zero_cf_def  
+      by (metis False RHS count_single mset_to_IP_def nat_to_msetE) 
+  qed
+qed
+
+end
+
+context UP_cring
+begin
+
+lemma IP_to_UP_monom:
+  shows "IP_to_UP i (mset_to_IP R (nat_to_mset i n)) = ((X_poly R)[^]\<^bsub>UP R\<^esub>n) "
+proof
+  fix x 
+  show "IP_to_UP i (mset_to_IP R (nat_to_mset i n)) x = (X_poly R [^]\<^bsub>UP R\<^esub> n) x"
+  proof(cases "x = n")
+    case True
+    have RHS: "(X_poly R [^]\<^bsub>UP R\<^esub> n) x = \<one>\<^bsub>R\<^esub>" 
+      unfolding X_poly_def 
+      by (metis P.nat_pow_closed P.nat_pow_eone P_def R.one_closed True UP_cring.X_closed 
+          UP_cring.monom_coeff UP_one_closed UP_r_one deg_one is_UP_cring monom_one monom_rep_X_pow
+          to_poly_inverse to_poly_mult_simp(2))
+    have LHS:  "IP_to_UP i (mset_to_IP R (nat_to_mset i n)) x = \<one>\<^bsub>R\<^esub>"
+      by (metis R.mset_to_IP_simp True IP_to_UP_def)
+    then show ?thesis
+      using RHS by presburger            
+  next
+    case False
+    have 0: "\<And>x y::nat. nat_to_mset x = nat_to_mset y \<Longrightarrow> x = y"
+    proof-
+      fix a b::nat assume A:  "nat_to_mset a = nat_to_mset b" 
+      then show "a = b" unfolding nat_to_mset_def  
+        by (metis A nat_to_msetE nat_to_msetE' zero_neq_one)
+    qed
+    have 1: "IP_to_UP i (mset_to_IP R (nat_to_mset i n)) x  = (if nat_to_mset i x = nat_to_mset i n then \<one> else \<zero>) "
+      unfolding IP_to_UP_def mset_to_IP_def 
+      by blast 
+    hence 2: "IP_to_UP i (mset_to_IP R (nat_to_mset i n)) x  = (if x = n then \<one> else \<zero>) "
+      using 0 
+      by (meson False nat_to_mset_inj)
+    have 3: "(X_poly R [^]\<^bsub>UP R\<^esub> n) x = \<zero>"
+      unfolding X_poly_def using False 
+      by (smt ctrm_degree P.nat_pow_closed P.nat_pow_eone P.r_null P_def R.one_closed 
+          UP_cring.ltrm_of_X UP_cring.ltrm_rep_X_pow UP_cring.X_closed UP_cring.monom_coeff 
+          UP_r_one UP_zero_closed X_mult_cf cfs_closed cfs_monom deg_nzero_nzero is_UP_cring
+          monom_closed monom_one to_poly_inverse to_poly_mult_simp(2))
+    thus ?thesis using 2 1 
+      using False by presburger
+  qed
+qed
+
+lemma IP_to_UP_one:
+ "IP_to_UP i \<one>\<^bsub>Pring R {i}\<^esub> = \<one>\<^bsub>UP R\<^esub>"
+proof
+  fix x
+  show "IP_to_UP i \<one>\<^bsub>Pring R {i}\<^esub> x = \<one>\<^bsub>UP R\<^esub> x"
+  proof(cases "x = 0")
+    case True
+    have RHS: "\<one>\<^bsub>UP R\<^esub> x = \<one>\<^bsub>R\<^esub>"
+      using P_def True cfs_one by presburger
+    have "\<one>\<^bsub>Pring R {i}\<^esub> = (\<lambda> m. if m = {#} then \<one>\<^bsub>R\<^esub> else \<zero>\<^bsub>R\<^esub>)"
+      by (metis R.Pring_one R.indexed_const_def)
+    then have "IP_to_UP i \<one>\<^bsub>Pring R {i}\<^esub> = IP_to_UP i (\<lambda> m. if m = {#} then \<one>\<^bsub>R\<^esub> else \<zero>\<^bsub>R\<^esub>)"
+      by presburger  
+    then have LHS: "IP_to_UP i \<one>\<^bsub>Pring R {i}\<^esub> x = \<one>\<^bsub>R\<^esub>"
+      by (smt True count_empty IP_to_UP_def multi_count_eq nat_to_msetE nat_to_msetE')
+    then show ?thesis 
+      using RHS by presburger      
+  next
+    case False
+    have RHS: "\<one>\<^bsub>UP R\<^esub> x = \<zero>\<^bsub>R\<^esub>"
+      by (smt False UP_def monoid.simps(2))      
+    show ?thesis 
+      using False count_empty 
+            nat_to_msetE 
+            ring.indexed_const_def
+      unfolding IP_to_UP_def
+      by (metis R.Pring_one R.ring_axioms RHS)
+  qed
+qed
+
+lemma IP_to_UP_zero:
+ "IP_to_UP i \<zero>\<^bsub>Pring R {i}\<^esub> = \<zero>\<^bsub>UP R\<^esub>"
+proof
+  fix x
+  show "IP_to_UP i \<zero>\<^bsub>Pring R {i}\<^esub> x = \<zero>\<^bsub>UP R\<^esub> x"
+    unfolding IP_to_UP_def using R.Pring_zero 
+    by (metis P_def R.indexed_zero_def cfs_zero)
+qed
+
+lemma IP_to_UP_add:
+  assumes " x \<in> carrier (Pring R {i})"
+  assumes " y \<in> carrier (Pring R {i})"
+  shows " IP_to_UP i (x \<oplus>\<^bsub>Pring R {i}\<^esub> y) =
+          IP_to_UP i x \<oplus>\<^bsub>UP R\<^esub> IP_to_UP i y"
+proof
+  fix n
+  have LHS: "IP_to_UP i (x \<oplus>\<^bsub>Pring R {i}\<^esub> y) n = (x \<oplus>\<^bsub>Pring R {i}\<^esub> y) (nat_to_mset i n)"
+    by (meson IP_to_UP_def)   
+  then have LHS: "IP_to_UP i (x \<oplus>\<^bsub>Pring R {i}\<^esub> y) n = x (nat_to_mset i n) \<oplus>\<^bsub>R\<^esub> y (nat_to_mset i n)"
+    using assms  unfolding IP_to_UP_def
+    by (metis R.Pring_add R.indexed_padd_def)  
+  have RHS: "(IP_to_UP i x \<oplus>\<^bsub>UP R\<^esub> IP_to_UP i y) n =
+   (IP_to_UP i x) n \<oplus>\<^bsub>R\<^esub> (IP_to_UP i y) n"
+    using assms UP_ring.cfs_add IP_to_UP_closed
+    by (simp add: UP_ring.cfs_add R_cring cring.IP_to_UP_closed is_UP_ring)    
+  then   show "IP_to_UP i (x \<oplus>\<^bsub>Pring R {i}\<^esub> y) n = (IP_to_UP i x \<oplus>\<^bsub>UP R\<^esub> IP_to_UP i y) n"
+    using assms 
+    by (metis LHS IP_to_UP_def)
+qed
+
+lemma IP_to_UP_indexed_const:
+  assumes "k \<in> carrier R"
+  shows "IP_to_UP i (ring.indexed_const R k) = to_polynomial R k"
+proof
+  fix x
+  show "IP_to_UP i (ring.indexed_const R k) x = to_polynomial R k x"
+  proof(cases "x = 0")
+    case True
+    have LHS: "IP_to_UP i (ring.indexed_const R k) x = k"
+      using True unfolding IP_to_UP_def   
+      by (metis R.indexed_const_def nat_to_mset_zero)  
+    then show ?thesis 
+      using assms 
+      unfolding to_polynomial_def 
+      using True to_polynomial_def 
+      by (metis UP_ring.cfs_monom is_UP_ring)      
+  next
+    case False
+    have LHS: "IP_to_UP i (ring.indexed_const R k) x = \<zero>\<^bsub>R\<^esub>"
+      using False unfolding IP_to_UP_def   
+      by (metis R.indexed_const_def nat_to_mset_inj nat_to_mset_zero)
+    then show ?thesis
+      using assms 
+      unfolding to_polynomial_def 
+      using False UP_cring.intro UP_cring.monom_coeff UP_cring.monom_rep_X_pow
+      using P_def cfs_monom by presburger
+  qed
+qed
+
+lemma IP_to_UP_indexed_pmult:
+  assumes "p \<in> carrier (Pring R {i})"
+  shows "IP_to_UP i (ring.indexed_pmult R p i) = (IP_to_UP i p) \<otimes>\<^bsub>UP R\<^esub> (X_poly R)"
+proof
+  fix n
+  have 0: "IP_to_UP i p \<in> carrier (UP R)"
+    by (simp add: R_cring assms cring.IP_to_UP_closed)     
+  show "IP_to_UP i (ring.indexed_pmult R p i) n = (IP_to_UP i p \<otimes>\<^bsub>UP R\<^esub> X_poly R) n"
+  proof(cases "n = 0")
+    case True
+    then have RHS: "(IP_to_UP i p \<otimes>\<^bsub>UP R\<^esub> X_poly R) n = \<zero>\<^bsub>R\<^esub>"
+      by (metis (no_types, lifting) "0" lcf_closed One_nat_def P.r_null P_def R.r_null
+          UP_cring.ltrm_of_X UP_cring.cfs_monom_mult UP_cring.cfs_monom_mult_l UP_zero_closed 
+          X_closed cfs_times_X deg_leE deg_nzero_nzero is_UP_cring lessI neq0_conv plus_1_eq_Suc to_poly_inverse)      
+    have LHS: "IP_to_UP i (ring.indexed_pmult R p i) n = ring.indexed_pmult R p i (nat_to_mset i n)"
+      unfolding IP_to_UP_def 
+      by blast     
+    then have LHS': "IP_to_UP i (ring.indexed_pmult R p i) n = 
+                  (p \<otimes>\<^bsub>Pring R {i}\<^esub> (mset_to_IP R {#i#})) (nat_to_mset i n)"
+      using  assms(1) ring.Pring_car ring.Pring_mult
+                ring.poly_index_mult singletonI 
+      by (metis R.ring_axioms)
+  then have LHS': "IP_to_UP i (ring.indexed_pmult R p i) n = 
+                  (p \<otimes>\<^bsub>Pring R {i}\<^esub> (mset_to_IP R {#i#})) {#}"
+    using True 
+    by (metis nat_to_mset_zero)          
+  then show ?thesis using RHS  LHS True assms(1) nat_to_mset_zero ring.indexed_pmult_def
+    by (metis R.ring_axioms empty_iff set_mset_empty)
+  next
+    case False
+    then have RHS: "(IP_to_UP i p \<otimes>\<^bsub>UP R\<^esub> X_poly R) n = (IP_to_UP i p ) (n -1)"
+      using "0" Suc_diff_1 Suc_eq_plus1 
+           assms(1) bot_nat_def IP_to_UP_def nat_neq_iff not_less0
+      by (metis (no_types, lifting) P_def UP_cring X_closed cfs_times_X cring.cring_simprules(14))  
+    have LHS: "IP_to_UP i (ring.indexed_pmult R p i) n = ring.indexed_pmult R p i (nat_to_mset i n)"
+      unfolding IP_to_UP_def 
+      by blast      
+    then have LHS': "IP_to_UP i (ring.indexed_pmult R p i) n = 
+                  (p \<otimes>\<^bsub>Pring R {i}\<^esub> (mset_to_IP R {#i#})) (nat_to_mset i n)"
+      using assms(1) ring.Pring_car ring.Pring_mult
+      ring.poly_index_mult singletonI 
+      by (metis R.ring_axioms)
+    then have LHS'': "IP_to_UP i (ring.indexed_pmult R p i) n = 
+                  (p \<otimes>\<^bsub>Pring R {i}\<^esub> (mset_to_IP R {#i#})) (add_mset i (nat_to_mset i (n-1))) "
+      by (metis False Suc_diff_1 nat_to_mset_Suc neq0_conv)
+    then show ?thesis using RHS unfolding IP_to_UP_def  
+      by (metis (no_types, lifting) False R.indexed_pmult_def Suc_diff_1 add_mset_remove_trivial add_mset_remove_trivial_If multi_self_add_other_not_self nat_to_mset_Suc neq0_conv)    
+  qed
+qed
+
+lemma IP_to_UP_ring_hom:
+  shows "ring_hom_ring (Pring R {i}) (UP R) (IP_to_UP i)"
+  apply(rule cring.Pring_morphism)
+      apply (simp add: R_cring; fail) 
+  using P_def UP_cring apply blast
+      apply (simp add: R.IP_to_UP_closed R_cring; fail)
+      apply (meson IP_to_UP_one)
+            apply (meson IP_to_UP_zero)
+    apply (meson IP_to_UP_add)
+  apply (metis R.IP_to_UP_var IP_to_UP_indexed_pmult singletonD)
+proof-
+  fix k Q
+  assume A0: "k \<in> carrier R"
+  assume A1: "Q \<in> carrier (Pring R {i})"
+  show "IP_to_UP i (poly_scalar_mult R k Q) =
+           IP_to_UP i (ring.indexed_const R k) \<otimes>\<^bsub>UP R\<^esub> IP_to_UP i Q"
+    unfolding poly_scalar_mult_def  
+  proof
+    fix x
+    show "IP_to_UP i (\<lambda>m. k \<otimes>\<^bsub>R\<^esub> Q m) x =
+         (IP_to_UP i (ring.indexed_const R k) \<otimes>\<^bsub>UP R\<^esub> IP_to_UP i Q) x"
+    proof-
+      have LHS: "IP_to_UP i (\<lambda>m. k \<otimes>\<^bsub>R\<^esub> Q m) x = k \<otimes>\<^bsub>R\<^esub> Q (nat_to_mset i x)"
+        unfolding IP_to_UP_def 
+        by blast       
+      have RHS: "(IP_to_UP i (ring.indexed_const R k) \<otimes>\<^bsub>UP R\<^esub> IP_to_UP i Q) x = 
+                (to_polynomial R k \<otimes>\<^bsub>UP R\<^esub> IP_to_UP i Q) x"
+        by (metis A0 IP_to_UP_indexed_const)        
+      have RHS': "(IP_to_UP i (ring.indexed_const R k) \<otimes>\<^bsub>UP R\<^esub> IP_to_UP i Q) x = 
+                k \<otimes>\<^bsub>R\<^esub> ((IP_to_UP i Q) x)"
+      proof-
+        have 0: "deg R (to_polynomial R k) = 0"
+          using A0 degree_to_poly by blast
+        have 1: "(IP_to_UP i Q) \<in> carrier (UP R)"
+          using IP_to_UP_closed  unfolding P_def 
+          by (simp add: A1 R.IP_to_UP_closed R_cring) 
+        then show ?thesis 
+        proof -
+          have "UP_cring R \<and> IP_to_UP i Q \<in> carrier (UP R)"
+            using "1" is_UP_cring by blast
+          then show ?thesis
+            by (metis A0 UP_cring.to_poly_mult_simp(1) UP_ring.UP_mult_closed UP_ring.coeff_simp UP_ring.coeff_smult UP_ring.monom_closed IP_to_UP_indexed_const is_UP_ring to_polynomial_def)      
+        qed
+      qed    
+      then show ?thesis 
+        by (metis IP_to_UP_def)       
+    qed
+  qed
+qed
+      
+lemma IP_to_UP_ring_hom_inj:
+  shows "inj_on  (IP_to_UP i) (carrier (Pring R {i}))"
+proof
+  fix x y
+  assume A: "x \<in> carrier (Pring R {i})" "y \<in> carrier (Pring R {i}) "
+  assume B: "IP_to_UP i x = IP_to_UP i y"
+  show "x = y"
+  proof
+    fix a 
+    show "x a = y a"
+    proof(cases "set_mset a \<subseteq> {i}")
+      case True
+      then obtain n where "a = (nat_to_mset i n)"
+        by (metis count_eq_zero_iff insert_subset multiset_eqI nat_to_msetE nat_to_msetE' 
+            set_eq_subset singletonD singleton_insert_inj_eq' subset_insertI subset_refl)
+      then have LHS: "x a = IP_to_UP i x n"
+        by (metis IP_to_UP_def)    
+      then show ?thesis  
+        by (metis B \<open>a = nat_to_mset i n\<close> IP_to_UP_def)
+    next
+      case False
+      then show ?thesis 
+        using ring.Pring_set_zero[of R y "{i}" a] ring.Pring_set_zero[of R x "{i}" a] A 
+        by (metis R.Pring_car R.ring_axioms)  
+    qed
+  qed
+qed
+
+lemma IP_to_UP_scalar_mult:
+  assumes "a \<in> carrier R"
+  assumes "p \<in> carrier (Pring R {i})"
+  shows "(IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> p)) = a\<odot>\<^bsub>UP R\<^esub> (IP_to_UP i p)"
+  apply(rule ring.indexed_pset.induct[of R p "{i}" "carrier R"])
+  apply (simp add: R.ring_axioms; fail)
+  using R.Pring_car assms(2) apply blast
+  apply (metis IP_to_UP_indexed_const P_def R.m_closed R.poly_scalar_mult_const R.ring_axioms assms(1) ring.Pring_smult to_poly_closed to_poly_mult to_poly_mult_simp(1))
+proof-
+  show "\<And>P Q. P \<in> Pring_set R {i} \<Longrightarrow>
+           IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> P) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i P \<Longrightarrow>
+           Q \<in> Pring_set R {i} \<Longrightarrow> IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> Q) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i Q \<Longrightarrow> IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> (P \<Oplus> Q)) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i (P \<Oplus> Q)"
+  proof-
+    fix p Q
+    assume A0: "p \<in> Pring_set R {i}"
+              "IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> p) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i p"
+              " Q \<in> Pring_set R {i}"
+              "IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> Q) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i Q"
+    show "IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> (p \<Oplus> Q)) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i (p \<Oplus> Q)"      
+    proof-
+      have "(a \<odot>\<^bsub>Pring R {i}\<^esub> (p \<Oplus> Q)) = a \<odot>\<^bsub>Pring R {i}\<^esub>  p \<oplus>\<^bsub>Pring R {i}\<^esub> a \<odot>\<^bsub>Pring R {i}\<^esub>  Q"
+        by (metis A0(1) A0(3) R.Pring_add R.Pring_car R.Pring_smult_r_distr assms(1))
+      then show ?thesis using A0 
+        by (metis IP_to_UP_add P_def R.IP_to_UP_closed R.Pring_add R.Pring_car R.Pring_smult_closed R_cring UP_smult_r_distr assms(1)) 
+      qed           
+  qed
+  show " \<And>P ia. P \<in> Pring_set R {i} \<Longrightarrow> IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> P) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i P \<Longrightarrow> ia \<in> {i} \<Longrightarrow> IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> (P \<Otimes> ia)) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i (P \<Otimes> ia)"
+  proof
+    fix P j x
+    assume A0: "P \<in> Pring_set R {i}"
+    assume A1: "IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> P) = a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i P"
+    assume A2: "j \<in> {i}"
+    then have A3: "j = i"
+      by blast
+    have "IP_to_UP i (ring.indexed_pmult R P j) \<in> carrier (UP R)"
+      by (simp add: A0 A3 R.Pring_car R.indexed_pset.indexed_pmult R_cring cring.IP_to_UP_closed)
+    then have "(a \<odot>\<^bsub>UP R\<^esub> (\<lambda>n. ring.indexed_pmult R P j (nat_to_mset i n))) x = a \<otimes>\<^bsub>R\<^esub>((\<lambda>n. ring.indexed_pmult R P j (nat_to_mset i n))) x"
+      using A0 A1 A3 assms unfolding IP_to_UP_def 
+      using P_def cfs_smult by blast
+    then show " IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> (P \<Otimes> j)) x = (a \<odot>\<^bsub>UP R\<^esub> IP_to_UP i (P \<Otimes> j)) x"
+      by (metis A0 A2 IP_to_UP_def P_def R.Pring_car R.Pring_smult_cfs R.indexed_pset.indexed_pmult \<open>IP_to_UP i (P \<Otimes> j) \<in> carrier (UP R)\<close> assms(1) cfs_smult)            
+  qed
+qed
+
+end
+
+text\<open>Evaluation of indexed polynomials commutes with evaluation of univariate polynomials:\<close>
+
+lemma pvar_closed:
+  assumes "cring R"
+  assumes "i \<in> I"
+  shows "(pvar R i) \<in> carrier (Pring R I)"
+  by (meson assms(1) assms(2) cring.axioms(1) ring.Pring_var_closed)
+
+context UP_cring
+begin
+
+lemma pvar_mult:
+  assumes "i \<in> I"
+  assumes "j \<in>  I"
+  shows "(pvar R i) \<otimes>\<^bsub>Pring R I\<^esub> (pvar R j) = mset_to_IP R {#i, j#}"
+proof-
+  have "{#i#} + {#j#}  = {# i, j#}"
+    by auto
+  then show ?thesis 
+    unfolding var_to_IP_def 
+    by (metis R.Pring_mult R.monom_mult)  
+qed
+
+lemma pvar_pow:
+
+  assumes "i \<in> I"
+  shows "(pvar R i)[^]\<^bsub>Pring R I\<^esub>(n::nat) = mset_to_IP R (nat_to_mset i n)"
+  apply(induction n)
+  apply (metis Group.nat_pow_0 R.one_mset_to_IP R.ring_axioms nat_to_mset_zero ring.Pring_one)
+proof-
+  fix n
+  assume IH: "pvar R i [^]\<^bsub>Pring R I\<^esub> n = mset_to_IP R (nat_to_mset i n)"
+  show "pvar R i [^]\<^bsub>Pring R I\<^esub> Suc n = mset_to_IP R (nat_to_mset i (Suc n)) "
+  proof-
+    have "mset_to_IP R (nat_to_mset i (Suc n)) = mset_to_IP R (nat_to_mset i n) \<otimes>\<^bsub>Pring R I\<^esub> pvar R i"
+      using R.monom_mult[of "nat_to_mset i n" "nat_to_mset i 1"] 
+      by (metis One_nat_def R.Pring_mult Suc_eq_plus1 nat_to_mset_Suc nat_to_mset_add nat_to_mset_zero var_to_IP_def)   
+    then show ?thesis 
+      using IH 
+      by simp
+  qed
+qed
+
+lemma IP_to_UP_poly_eval:
+  assumes "p \<in> Pring_set R {i}"
+  assumes "closed_fun R g"
+  shows "total_eval R g p = to_function R (IP_to_UP i p) (g i)"
+  apply(rule R.indexed_pset.induct[of p "{i}" "carrier R" ])
+  apply (simp add: assms(1); fail)
+proof-
+  show "\<And>k. k \<in> carrier R \<Longrightarrow> total_eval R g (R.indexed_const k) = to_function R (IP_to_UP i (R.indexed_const k)) (g i)"
+  proof-
+    fix k
+    assume A: "k \<in> carrier R"
+    have P0: "total_eval R g (ring.indexed_const R k) = k"
+      unfolding total_eval_def eval_in_ring_def 
+      using cring.poly_eval_constant[of R k UNIV g]
+      by (metis A R.indexed_const_def R_cring)      
+    have P1: "(IP_to_UP i (ring.indexed_const R k)) = to_polynomial R k"
+      by (meson A IP_to_UP_indexed_const)     
+    have P2: "to_function R (IP_to_UP i (ring.indexed_const R k)) (g i) = 
+              to_function R (to_polynomial R k) (g i)"
+      using P1 by presburger      
+    have P3: "to_function R (to_polynomial R k) (g i) = k"
+      using A assms(2) to_fun_to_poly[of k "g i"] unfolding to_fun_def by blast           
+    then show "total_eval R g (R.indexed_const k) = to_function R (IP_to_UP i (R.indexed_const k)) (g i)"
+      using P0 P2 by presburger      
+  qed
+  show "\<And>P Q. P \<in> Pring_set R {i} \<Longrightarrow>
+           total_eval R g P = to_function R  (IP_to_UP i P) (g i) \<Longrightarrow>
+           Q \<in> Pring_set R {i} \<Longrightarrow>
+           total_eval R g Q = to_function R  (IP_to_UP i Q) (g i) \<Longrightarrow> total_eval R g (P \<Oplus> Q) = to_function R (IP_to_UP i (P \<Oplus> Q)) (g i)"
+  proof-
+    fix p Q
+    assume A0: "p \<in> Pring_set R {i}"
+    assume A1: " total_eval R g p = to_function R (IP_to_UP i p) (g i)"
+    assume A2: " Q \<in> Pring_set R {i}"
+    assume A3: "total_eval R g Q = to_function R (IP_to_UP i Q) (g i)"
+    have "total_eval R g (R.indexed_padd p Q) = (total_eval R g p) \<oplus>\<^bsub>R\<^esub> (total_eval R g Q)"
+      using R.total_eval_add[of p "{i}" Q g] A0 A1 
+      by (metis A2 R.Pring_add R.Pring_car assms(2))  
+    then
+    have 0: "total_eval R g (p \<Oplus> Q) = total_eval R g p \<oplus> total_eval R g Q "
+      by blast
+    have 1: "IP_to_UP i (p \<Oplus> Q) = IP_to_UP i p \<oplus>\<^bsub>UP R\<^esub> IP_to_UP i Q"
+      using A0 A1 A3 assms A2 R.ring_axioms R_cring IP_to_UP_add 
+      by (metis R.Pring_add R.Pring_car)
+    have "g i \<in> carrier R"
+      using assms by blast 
+    hence 2: "to_function R (IP_to_UP i (p \<Oplus> Q)) (g i) = to_function R (IP_to_UP i p) (g i) \<oplus> to_function R (IP_to_UP i Q) (g i)"
+      using A0 A1 A3 assms A2 R.ring_axioms R_cring to_fun_plus[of "IP_to_UP i p" "IP_to_UP i Q" "g i"] 
+            IP_to_UP_closed is_UP_cring UP_cring.to_fun_def
+            to_fun_def 0 1 
+      unfolding to_fun_def P_def 
+      by (smt (z3) P_def R.IP_to_UP_closed R.Pring_car to_fun_plus)       
+    show "total_eval R g (R.indexed_padd p Q) = to_function R (IP_to_UP i (ring.indexed_padd R p Q)) (g i) "
+      using A0 A1 A3 assms A2 R.ring_axioms R_cring is_UP_cring to_fun_def 0 1 2
+      unfolding to_fun_def   by metis 
+  qed
+  show "\<And>P ia.
+       P \<in> Pring_set R {i} \<Longrightarrow>
+       total_eval R g P = to_function R (IP_to_UP i P) (g i) \<Longrightarrow> ia \<in> {i} \<Longrightarrow> total_eval R g (P \<Otimes> ia) = to_function R (IP_to_UP i (P \<Otimes> ia)) (g i)"
+  proof-
+    fix P
+    fix j
+    assume A0: "P \<in> Pring_set R {i}"
+    assume A1: "total_eval R g P = to_function R (IP_to_UP i P) (g i)"
+    assume A2: "j \<in> {i}"
+    then have A3: "j = i"
+      by blast
+    show "total_eval R g (P \<Otimes> j) = to_function R (IP_to_UP i (P \<Otimes> j)) (g i)"
+    proof-
+      have LHS: "total_eval R g (P \<Otimes> j) = (total_eval R g P) \<otimes>\<^bsub>R\<^esub> (g i)"
+        using assms A0 A3 
+        by (metis R.Pring_car R_cring cring.total_eval_indexed_pmult insertI1)   
+      have RHS: "IP_to_UP i (P \<Otimes> j)=  IP_to_UP i P  \<otimes>\<^bsub> UP R\<^esub> X_poly R"
+        by (metis A0 A3 IP_to_UP_indexed_pmult R.Pring_car)
+      have "g i \<in> carrier R"
+        using assms by blast 
+      then show ?thesis 
+          using A0 A1 A3 X_closed to_fun_X[of "g i"] to_fun_mult[of "IP_to_UP i P" "X_poly R" "g i"] LHS RHS
+              assms  cring.axioms(1) domain.axioms(1) 
+              IP_to_UP_indexed_pmult IP_to_UP_closed
+              Pring_car unfolding to_fun_def P_def
+          by (smt (z3) P.m_comm P_def R.m_comm R_cring cring.IP_to_UP_closed ring.Pring_car to_fun_closed to_fun_def)                                                                                                                 
+      qed
+   qed
+qed
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Mapping Univariate Polynomials to Multivariate Polynomials over a Singleton Variable Set\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition UP_to_IP :: "('a,'b) ring_scheme \<Rightarrow> 'c \<Rightarrow> 'a u_poly \<Rightarrow> ('a, 'c) mvar_poly" where
+"UP_to_IP R i P = (\<lambda> m. if (set_mset m) \<subseteq>  {i} then P (count m i) else \<zero>\<^bsub>R\<^esub>)"
+
+context UP_cring
+begin
+
+lemma UP_to_IP_inv:
+  assumes "p \<in> Pring_set R {i}"
+  shows "UP_to_IP R i (IP_to_UP i p) = p"
+proof
+  fix x
+  show "UP_to_IP R i (IP_to_UP i p) x = p x"
+  proof(cases "(set_mset x) = {i}")
+    case True
+    have "{a. 0 < (\<lambda>j. if j = i then count x i else 0) a} = {i}"
+      by (smt Collect_cong True count_eq_zero_iff neq0_conv singletonI singleton_conv)
+  then have "finite {j. (if j = i then count x i else 0) \<noteq> 0}"
+      by auto     
+    have "(\<lambda>j. if j = i then count x i else 0) = count x"
+    proof
+      fix j
+      show "(if j = i then count x i else 0) = count x j "
+        apply(cases "j = i")
+        using True 
+        apply (simp; fail)     
+        using True 
+        by (metis count_inI singletonD)
+    qed
+    then have "(Abs_multiset (\<lambda>j. if j = i then count x i else 0)) = x"
+      using count_inverse  
+      by simp
+    then show ?thesis 
+      unfolding UP_to_IP_def IP_to_UP_def nat_to_mset_def   
+      by (metis True set_eq_subset)          
+  next
+    case False
+    then show ?thesis 
+      apply(cases "x = {#}")
+       apply (metis count_empty empty_subsetI IP_to_UP_def nat_to_mset_zero set_mset_empty UP_to_IP_def)
+     unfolding UP_to_IP_def IP_to_UP_def nat_to_mset_def   
+     using False  assms 
+     by (metis R.Pring_set_zero set_mset_eq_empty_iff subset_singletonD)     
+  qed
+qed
+
+lemma UP_to_IP_const:
+  assumes "a \<in> carrier R"
+  shows "UP_to_IP R i (to_polynomial R a) = ring.indexed_const R a"
+proof
+  fix x
+  show "UP_to_IP R i (to_polynomial R a) x = ring.indexed_const R a x"
+    apply(cases "x = {#}")
+    unfolding UP_to_IP_def 
+    apply (metis R.indexed_const_def UP_ring.cfs_monom assms count_eq_zero_iff insert_absorb insert_not_empty is_UP_ring set_mset_empty subset_insert subset_refl to_polynomial_def)
+  by (metis R.indexed_const_def UP_ring.cfs_monom assms count_eq_zero_iff is_UP_ring set_mset_eq_empty_iff subset_empty subset_insert to_polynomial_def)
+qed      
+
+lemma UP_to_IP_add:
+  assumes "p \<in> carrier (UP R)"
+  assumes "Q \<in> carrier (UP R)"
+  shows "UP_to_IP R i (p \<oplus>\<^bsub>UP R\<^esub> Q) = 
+         UP_to_IP R i p \<oplus>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q"
+proof
+  fix x
+  show "UP_to_IP R i (p \<oplus>\<^bsub>UP R\<^esub> Q) x = (UP_to_IP R i p \<oplus>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q) x"
+  proof(cases "set_mset x \<subseteq> {i}")
+    case True
+    have "(UP_to_IP R i p \<oplus>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q) x = 
+          (UP_to_IP R i p) x \<oplus>\<^bsub>R\<^esub> (UP_to_IP R i Q) x"
+      using True assms 
+      by (metis R.Pring_add R.indexed_padd_def)        
+    then show ?thesis     using assms True
+      unfolding UP_to_IP_def UP_def 
+      by (smt partial_object.select_convs(1) restrict_def ring_record_simps(12))    
+  next
+    case False
+    have "(UP_to_IP R i p \<oplus>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q) x = 
+          (UP_to_IP R i p) x \<oplus>\<^bsub>R\<^esub> (UP_to_IP R i Q) x"
+            using False assms 
+            by (metis R.Pring_add R.indexed_padd_def) 
+    then show ?thesis using False assms  
+    unfolding UP_to_IP_def UP_def 
+    using R.l_zero R.zero_closed by presburger
+  qed
+qed
+
+lemma UP_to_IP_var:
+  shows "UP_to_IP R i (X_poly R) = pvar R i"
+proof
+  have 0: "(count {#i#} i) = 1"
+    by simp
+  have 1: "set_mset {#i#} \<subseteq> {i}"
+    by simp
+  have 2: "pvar R i {#i#} = \<one>"
+    by (metis R.mset_to_IP_simp var_to_IP_def)
+  fix x
+  show "UP_to_IP R i (X_poly R) x = pvar R i x"
+    apply(cases "x = {#i#}")
+    using X_poly_def[of R] cfs_monom[of \<one> 1 "count x i"] 0 1 2
+    unfolding UP_to_IP_def P_def
+    using R.one_closed apply presburger
+  proof-
+    assume A: "x \<noteq>{#i#}"
+    then show "(if set_mset x \<subseteq> {i} then X_poly R (count x i) else \<zero>\<^bsub>R\<^esub>) = pvar R i x"
+    proof(cases "set_mset x \<subseteq> {i}")
+      case True
+      have "count x i \<noteq> 1" using True A
+        by (metis One_nat_def count_empty count_inI count_single empty_iff multiset_eqI 
+            set_mset_add_mset_insert set_mset_empty set_mset_eq_empty_iff singletonD singletonI subset_singletonD)
+      then have 0: "X_poly R (count x i) = \<zero>\<^bsub>R\<^esub>"
+        using A UP_cring.X_closed UP_cring.degree_X UP_cring.intro True
+        unfolding X_poly_def 
+        using P_def R.one_closed \<open>\<one> \<in> carrier R \<Longrightarrow> up_ring.monom P \<one> 1 (count x i) = (if 1 = count x i then \<one> else \<zero>)\<close> by presburger        
+      have "pvar R i x = \<zero>\<^bsub>R\<^esub>"
+        using A var_to_IP_def
+        by (metis R.mset_to_IP_simp')        
+      then show ?thesis 
+        using A "0" by presburger
+    next
+      case False
+      have "pvar R i x = \<zero>\<^bsub>R\<^esub>" using A var_to_IP_def False 
+        by (metis "1" R.Pring_set_zero R.mset_to_IP_closed)      
+      then show ?thesis     
+        unfolding UP_to_IP_def 
+        using False by presburger       
+    qed
+  qed
+qed
+
+lemma UP_to_IP_var_pow:
+  shows "UP_to_IP R i ((X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat)) = (pvar R i)[^]\<^bsub>Pring R {i}\<^esub>n"
+proof
+  fix x
+  show "UP_to_IP R i (X_poly R [^]\<^bsub>UP R\<^esub> n) x = (pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) x "
+  proof(cases "set_mset x \<subseteq> {i}")
+    case True
+    show ?thesis 
+    proof(cases "count x i = n")
+      case T: True
+      then have 0: "x = nat_to_mset i n"
+        using True 
+        by (metis count_inI emptyE insert_iff multiset_eqI nat_to_msetE 
+            nat_to_msetE' subsetD)
+      have 1: "x = nat_to_mset i (count x i)"
+        using "0" T by auto
+      then have LHS: "(pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) x = \<one>\<^bsub>R\<^esub>"
+        using T True  0 1  
+        by (metis R.mset_to_IP_simp insertI1 pvar_pow)   
+      have 2: "UP_to_IP R i (X_poly R [^]\<^bsub>UP R\<^esub> n) x = (up_ring.monom (UP R) \<one> n) (count x i)"
+        unfolding UP_to_IP_def X_poly_def using True 
+        by (metis ctrm_degree P.nat_pow_closed P.nat_pow_eone P_def R.one_closed UP_cring.monom_coeff 
+            UP_one_closed UP_r_one X_closed is_UP_cring monom_one monom_rep_X_pow to_poly_inverse 
+            to_poly_mult_simp(2))
+      then show ?thesis
+        using True T LHS P_def R.one_closed cfs_monom 
+        by presburger                                      
+    next
+      case False
+      have "(pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) = mset_to_IP R (nat_to_mset i n)"
+        by (simp add: pvar_pow)
+      hence 0: "(pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) x = \<zero>"
+        by (metis False R.mset_to_IP_simp' nat_to_msetE)  
+      have 1: "UP_to_IP R i (X_poly R [^]\<^bsub>UP R\<^esub> n) x = (up_ring.monom (UP R) \<one> n) (count x i)"
+        unfolding UP_to_IP_def X_poly_def  using False  True 
+        by (metis ctrm_degree P.nat_pow_closed P.nat_pow_eone P_def R.one_closed UP_one_closed 
+            UP_r_one X_closed cfs_monom monom_one monom_rep_X_pow to_poly_inverse to_poly_mult_simp(2))
+      thus ?thesis using True False
+        unfolding UP_to_IP_def X_poly_def 0 
+        by (metis P_def R.one_closed cfs_monom)
+    qed
+  next
+    case False
+    then have 0: "UP_to_IP R i (X_poly R [^]\<^bsub>UP R\<^esub> n) x = \<zero>" 
+      unfolding UP_to_IP_def 
+      by meson
+    have "(pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) = mset_to_IP R (nat_to_mset i n)"
+      by (simp add: pvar_pow)
+    hence "(pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) x = \<zero>"
+      by (metis False R.mset_to_IP_simp' count_eq_zero_iff nat_to_msetE' singleton_iff subsetI)
+    then show ?thesis using 0 
+      by presburger
+  qed
+qed
+
+lemma one_var_indexed_poly_monom_simp:
+  assumes "a \<in> carrier R"
+  shows "(a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n)) x = (if x = (nat_to_mset i n) then a else \<zero>)"
+proof-
+  have 0: "(a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n)) x = 
+                a \<otimes> (((pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n) x)"
+    using  Pring_smult_cfs Pring_var_closed assms cring_def is_cring monoid.nat_pow_closed ring.Pring_is_monoid singletonI
+    by (simp add: monoid.nat_pow_closed ring.Pring_is_monoid R.Pring_smult_cfs R.Pring_var_closed R.ring_axioms) 
+  have 1: "(pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n = mset_to_IP R (nat_to_mset i n)"
+   using insertI1 
+   by (simp add: pvar_pow)    
+  then have 1: "(a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n)) x= 
+              a \<otimes> (mset_to_IP R (nat_to_mset i n) x)"
+    using "0" by presburger   
+  show ?thesis 
+    using assms 1 unfolding mset_to_IP_def 
+    using r_null r_one by simp         
+qed    
+
+
+lemma UP_to_IP_monom:
+  assumes "a \<in> carrier R"
+  shows "UP_to_IP R i (up_ring.monom (UP R) a n) = a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i)[^]\<^bsub>Pring R {i}\<^esub>n)"
+proof
+  fix x
+  show "UP_to_IP R i (up_ring.monom (UP R) a n) x = (a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n)) x"
+  proof(cases "set_mset x \<subseteq> {i}")
+    case True
+    then show ?thesis 
+    proof(cases "count x i = n")
+      case T: True
+      then have "x = nat_to_mset i n"
+        using True 
+        by (metis count_inI emptyE insert_iff multiset_eqI nat_to_msetE 
+            nat_to_msetE' subsetD)
+      then have LHS: " (a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i) [^]\<^bsub>Pring R {i}\<^esub> n)) x = a"
+        using assms 
+        by (simp add: one_var_indexed_poly_monom_simp)                                                        
+      then show ?thesis 
+        unfolding UP_to_IP_def
+        using T True  assms(1)
+        by (metis UP_ring.cfs_monom is_UP_ring)        
+    next
+      case False
+      then show ?thesis using True 
+        unfolding UP_to_IP_def
+        by (metis INTEG.R.nat_to_msetE P_def assms cfs_monom one_var_indexed_poly_monom_simp)                                            
+    qed
+  next
+    case False
+    then show ?thesis 
+      unfolding UP_to_IP_def 
+      by (metis (no_types, opaque_lifting) one_var_indexed_poly_monom_simp assms 
+          count_eq_zero_iff  equalityD2 insert_subset nat_to_msetE' subsetI subset_eq)        
+  qed
+qed
+
+lemma UP_to_IP_monom':
+  assumes "a \<in> carrier R"
+  shows "UP_to_IP R i (up_ring.monom (UP R) a n) = a \<odot>\<^bsub>Pring R {i}\<^esub> ((pvar R i)[^]\<^bsub>Pring R {i}\<^esub>n)"
+  by (metis R.Pring_smult UP_to_IP_monom assms)
+
+lemma UP_to_IP_closed:
+  assumes "p \<in> carrier P"
+  shows "(UP_to_IP R i p) \<in> carrier (Pring R {i})"
+  apply(rule poly_induct3[of ])
+  using assms apply blast
+  apply (metis P_def R.Pring_add_closed UP_to_IP_add)
+proof-
+  fix a fix n::nat
+  assume A0: "a \<in> carrier R"
+  have "(pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) \<in> carrier (Pring R {i})"
+    using pvar_closed[of R ] monoid.nat_pow_closed[of "Pring R {i}"]
+  proof -
+    show ?thesis
+      by (meson R.Pring_is_monoid R.Pring_var_closed monoid.nat_pow_closed singleton_iff)
+  qed
+  then show "a \<in> carrier R \<Longrightarrow>
+           UP_to_IP R i (up_ring.monom P a n) \<in> carrier (Pring R {i})"
+    using A0 assms(1) UP_to_IP_monom[of a i n] cring.poly_scalar_mult_closed [of R a _ "{i}"] 
+    by (metis P_def R.Pring_smult_closed)
+qed
+
+lemma IP_to_UP_inv:
+  assumes "p \<in> carrier P"
+  shows "IP_to_UP i (UP_to_IP R i p) = p"
+  apply(rule poly_induct3[of ])
+  using assms apply linarith
+proof-
+  show "\<And>p q. q \<in> carrier P \<Longrightarrow>
+           p \<in> carrier P \<Longrightarrow>
+           IP_to_UP i (UP_to_IP R i p) = p \<Longrightarrow>
+           IP_to_UP i (UP_to_IP R i q) = q \<Longrightarrow>
+           IP_to_UP i (UP_to_IP R i (p \<oplus>\<^bsub>P\<^esub> q)) = p \<oplus>\<^bsub>P\<^esub> q"
+  proof-
+    fix p q assume A: 
+           "q \<in> carrier P"
+           "p \<in> carrier P"
+           "IP_to_UP i (UP_to_IP R i p) = p"
+           "IP_to_UP i (UP_to_IP R i q) = q"
+    show "IP_to_UP i (UP_to_IP R i (p \<oplus>\<^bsub>P\<^esub> q)) = p \<oplus>\<^bsub>P\<^esub> q"
+      using A UP_to_IP_add[of p q i]
+                  UP_to_IP_closed 
+                  IP_to_UP_add 
+      unfolding P_def 
+      by metis
+  qed
+  show "\<And>a n. a \<in> carrier R \<Longrightarrow>
+           IP_to_UP i (UP_to_IP R i (up_ring.monom P a n)) =
+           up_ring.monom P a n"
+  proof-
+    fix a fix n::nat
+    assume A0: "a \<in> carrier R"
+    have A1: "pvar R i [^]\<^bsub>Pring R {i}\<^esub> n \<in> carrier (Pring R {i})"
+      using pvar_closed monoid.nat_pow_closed 
+      by (metis R.Pring_is_monoid R_cring singletonI)
+    have "UP_to_IP R i (up_ring.monom (UP R) a n) = a \<odot>\<^bsub>Pring R {i}\<^esub>  (pvar R i [^]\<^bsub>Pring R {i}\<^esub> n)"
+      by (meson A0 UP_to_IP_monom')               
+    then have A2: "IP_to_UP i (UP_to_IP R i (up_ring.monom (UP R) a n)) =
+            IP_to_UP i (a \<odot>\<^bsub>Pring R {i}\<^esub> (pvar R i [^]\<^bsub>Pring R {i}\<^esub> n))"
+      by presburger 
+    have A3: "IP_to_UP i (pvar R i [^]\<^bsub>Pring R {i}\<^esub> n) =  (up_ring.monom P \<one> n)"
+    proof(induction n)
+      case 0
+      then show ?case 
+        by (metis Group.nat_pow_0 IP_to_UP_one P_def monom_one)     
+    next
+      case (Suc n)
+
+      then show ?case 
+      using IP_to_UP_ring_hom[of i] 
+              ring_hom_mult[of "IP_to_UP i" "Pring R {i}" "UP R" "pvar R i" "pvar R i [^]\<^bsub>Pring R {i}\<^esub> n"]
+                ring_hom_ring.homh[of "Pring R {i}" "UP R"  "IP_to_UP i"] 
+      by (metis IP_to_UP_monom P.l_one P.nat_pow_closed P_def R.one_closed UP_cring.ctrm_degree UP_cring.monom_rep_X_pow  UP_one_closed X_closed cfs_monom is_UP_cring monom_one pvar_pow singletonI to_poly_inverse to_poly_mult_simp(1))
+    qed      
+    then show "IP_to_UP i (UP_to_IP R i (up_ring.monom P a n)) =
+           up_ring.monom P a n"
+      using A2 IP_to_UP_scalar_mult[of a "pvar R i [^]\<^bsub>Pring R {i}\<^esub> n" i] 
+            A0 A1 P_def monic_monom_smult by presburger
+  qed
+qed  
+
+lemma UP_to_IP_mult:
+  assumes "p \<in> carrier (UP R)"
+  assumes "Q \<in> carrier (UP R)"
+  shows "UP_to_IP R i (p \<otimes>\<^bsub>UP R\<^esub> Q) = 
+         UP_to_IP R i p \<otimes>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q"
+proof-
+  have 0: "IP_to_UP i (UP_to_IP R i (p \<otimes>\<^bsub>UP R\<^esub> Q)) = (p \<otimes>\<^bsub>UP R\<^esub> Q)"
+    by (meson UP_cring.IP_to_UP_inv UP_ring.UP_mult_closed assms(1) assms(2) is_UP_cring is_UP_ring)
+  have 1: "IP_to_UP i (UP_to_IP R i p \<otimes>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q) =
+        IP_to_UP i (UP_to_IP R i p) \<otimes>\<^bsub>UP R\<^esub> IP_to_UP i ( UP_to_IP R i Q)"
+    using IP_to_UP_ring_hom[of  i] 
+          ring_hom_mult[of "IP_to_UP i"] 
+          UP_to_IP_closed assms
+    by (smt P_def ring_hom_ring.homh)
+  have 2: "IP_to_UP i (UP_to_IP R i (p \<otimes>\<^bsub>UP R\<^esub> Q)) = 
+        IP_to_UP i (UP_to_IP R i p \<otimes>\<^bsub>Pring R {i}\<^esub> UP_to_IP R i Q)"
+    using 0 1 assms 
+    by (metis UP_cring.IP_to_UP_inv is_UP_cring)     
+  then show ?thesis 
+    by (metis "0" P_def R.Pring_mult_closed R.ring_axioms assms(1) assms(2) ring.Pring_car UP_to_IP_closed UP_to_IP_inv)    
+qed
+
+lemma UP_to_IP_ring_hom:
+shows "ring_hom_ring (UP R) (Pring R {i}) (UP_to_IP R i)"
+  apply(rule ring_hom_ringI)
+  using P_def UP_ring apply force
+  apply (simp add: R.Pring_is_ring; fail)
+  apply (metis P_def UP_to_IP_closed)
+  apply (meson UP_to_IP_mult)
+  apply (meson UP_to_IP_add)
+  by (metis IP_to_UP_one R.Pring_car R.Pring_one_closed UP_to_IP_inv)
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>The isomorphism $R[I\cup J] \sim R[I][J]$, where $I$ and $J$ are disjoint variable sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  Given a ring $R$ and variable sets $I$ and $J$, we'd like to construct the canonical 
+  (iso)morphism $R[I\cup J] \to R[I][J]$. This can be done with the univeral property of the 
+  previous section. Let $\phi: R \to R[J]$ be the inclusion of constants, and $f: J \to R[I]$ be 
+  the map which sends the variable $i$ to the polynomial variable $i$ over the ring $R[I][J]$.
+  Then these are the two basic pieces of input required to give us a canonical homomoprhism 
+  $R[I \cup J] \to R[I][J]$ with the universal property. The first map $\phi$ will be 
+  "\texttt{dist\_varset\_morpshim}" below, and the second map will be 
+  "\texttt{dist\_varset\_var\_ass}". The desired induced isomorphism will be 
+  called "\texttt{var\_factor}".   \<close>
+
+definition(in ring) dist_varset_morphism 
+  :: "'d set \<Rightarrow> 'd set \<Rightarrow> 
+              ('a, (('a, 'd) mvar_poly, 'd) mvar_poly) ring_hom" where
+  "dist_varset_morphism (I:: 'd set) (J:: 'd set) = 
+        (ring.indexed_const (Pring R J) :: ('d multiset \<Rightarrow> 'a) \<Rightarrow> 'd multiset \<Rightarrow> ('d multiset \<Rightarrow> 'a))\<circ> (ring.indexed_const R ::'a \<Rightarrow> 'd multiset \<Rightarrow> 'a)"
+
+definition(in ring) dist_varset_var_ass
+    :: "'d set \<Rightarrow> 'd set \<Rightarrow> 'd \<Rightarrow> (('a, 'd) mvar_poly, 'd) mvar_poly"
+    where
+"dist_varset_var_ass (I:: 'd set) (J:: 'd set)  = (\<lambda>i. if i \<in> J then ring.indexed_const (Pring R J) (pvar R i) else 
+                                                pvar (Pring R J) i )"
+
+context cring
+begin
+
+lemma dist_varset_morphism_is_morphism:
+  assumes "(I:: 'd set) \<subseteq> J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "\<phi> = dist_varset_morphism I J0"
+  shows "ring_hom_ring R (Pring (Pring R J0) J1) \<phi>"
+proof-
+  have 0:"ring_hom_ring R (Pring R J0) indexed_const"
+    by (simp add: indexed_const_ring_hom)
+  have 1:"ring_hom_ring (Pring R J0) (Pring (Pring R J0) J1) (ring.indexed_const (Pring R J0))"
+    by (simp add: cring.indexed_const_ring_hom is_cring local.ring_axioms ring.Pring_is_cring)
+  show ?thesis using 0 1 assms ring_hom_trans[of "indexed_const" R "Pring R J0" "ring.indexed_const (Pring R J0)"
+              "(Pring (Pring R J0) J1) "]
+    unfolding dist_varset_morphism_def 
+  by (meson ring_hom_ring.axioms(1) ring_hom_ring.axioms(2) ring_hom_ring.homh ring_hom_ringI2)
+qed
+
+definition var_factor :: 
+  "'d set \<Rightarrow> 'd set \<Rightarrow> 'd set \<Rightarrow>
+         (('a, 'd) mvar_poly, (('a, 'd) mvar_poly, 'd) mvar_poly) ring_hom "where
+"var_factor (I:: 'd set) (J0:: 'd set) (J1:: 'd set) = indexed_poly_induced_morphism  I (Pring (Pring R J0) J1)                                                       
+                                                        (dist_varset_morphism I J0) (dist_varset_var_ass I J0)"
+
+lemma indexed_const_closed:
+  assumes "x \<in> carrier R"
+  shows "indexed_const x \<in> carrier (Pring R I)"
+  using Pring_car assms indexed_pset.indexed_const by blast
+
+lemma var_factor_morphism:
+  assumes "(I:: 'd set) \<subseteq> J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "g = dist_varset_var_ass I J0"
+  assumes "\<phi> = dist_varset_morphism I J0"
+  assumes "\<psi> = (var_factor I J0 J1)"
+  shows "ring_hom_ring (Pring R I) (Pring (Pring R J0) J1) \<psi> "
+        "\<And>i. i \<in> J0 \<inter> I \<Longrightarrow> \<psi> (pvar R i) = ring.indexed_const (Pring R J0) (pvar R i)"
+        "\<And>i. i \<in> J1 \<Longrightarrow> \<psi> (pvar R i) = pvar (Pring R J0) i"
+        "\<And>a. a \<in> carrier (Pring R (J0 \<inter> I)) \<Longrightarrow> \<psi> a = ring.indexed_const (Pring R J0) a"
+proof-
+  have 0: "g \<in> I \<rightarrow> carrier (Pring (Pring R J0) J1)"
+  proof
+    fix x
+    assume A0: "x \<in> I"
+    then have A1: "x \<in> J0 \<or> x \<in> J1"
+      by (meson UnE assms(1) subsetD)
+    have A2: "x \<notin> J0 \<Longrightarrow> x \<in> J1"
+      using A1 by blast
+    show "g x \<in> carrier (Pring (Pring R J0) J1)"
+      apply(cases "x \<in> J0")
+      using assms A0 A1 A2 pvar_closed[of R x J0] 
+        pvar_closed[of "Pring R J0" x J1]
+        cring.indexed_const_closed[of "Pring R J0" ]
+      unfolding dist_varset_var_ass_def 
+       apply (smt Pring_is_cring is_cring)
+      using assms A0 A1 A2 pvar_closed[of R x J0] 
+        pvar_closed[of "Pring R J0" x J1]
+        cring.indexed_const_closed[of "Pring R J0" ]
+      unfolding dist_varset_var_ass_def 
+      by (smt Pring_is_cring is_cring)
+  qed
+  have 1: " cring (Pring R J0)"
+    by (simp add: Pring_is_cring is_cring)
+  have 2: " cring (Pring (Pring R J0) J1)"
+    by (simp add: "1" Pring_is_ring ring.Pring_is_cring)
+  show C0: "ring_hom_ring (Pring R I) (Pring (Pring R J0) J1) \<psi> " 
+    using 0 assms Pring_universal_prop[of "Pring (Pring R J0) J1" g I \<phi> \<psi>] 
+        dist_varset_morphism_is_morphism[of I J0 J1]
+    unfolding var_factor_def
+    by (meson Pring_is_cring Pring_is_ring is_cring ring.Pring_is_cring)
+  show C1: "\<And>i. i \<in> J0 \<inter> I \<Longrightarrow> \<psi> (pvar R i) = ring.indexed_const (Pring R J0) (pvar R i)"
+    using  0 1 2 assms Pring_universal_prop(2)[of "Pring (Pring R J0) J1" g I \<phi> \<psi>] 
+        dist_varset_morphism_is_morphism[of I J0 J1 \<phi>] dist_varset_var_ass_def 
+        dist_varset_morphism_def unfolding var_factor_def  var_to_IP_def
+    by (smt IntE dist_varset_var_ass_def inf_commute inf_le2 ring.Pring_is_cring subsetD var_to_IP_def)
+  have 3: "\<And>i. i \<in> J1 \<Longrightarrow> g i = mset_to_IP (Pring R J0) {#i#} "
+    using assms unfolding dist_varset_var_ass_def var_to_IP_def
+    by (meson disjoint_iff_not_equal)
+  show C2: "\<And>i. i \<in> J1 \<Longrightarrow> \<psi> (pvar R i) = pvar (Pring R J0) i"
+      using  0 1 2 3 assms Pring_universal_prop(2)[of "Pring (Pring R J0) J1" g I \<phi> \<psi>] 
+        dist_varset_morphism_is_morphism[of I J0 J1 \<phi>] 
+         unfolding   var_factor_def  var_to_IP_def
+         by (metis subsetD)
+  have 4: "\<And>k. k \<in> carrier R \<Longrightarrow> \<psi> (indexed_const k) = ring.indexed_const (Pring R J0) (indexed_const k)"
+      using  0 1 2 3 assms Pring_universal_prop(3)[of "Pring (Pring R J0) J1" g I \<phi> \<psi>] 
+        dist_varset_morphism_is_morphism[of I J0 J1 \<phi>] comp_apply
+      unfolding   var_factor_def  var_to_IP_def dist_varset_morphism_def
+      by metis
+  show C3:  "\<And>a. a \<in> carrier (Pring R (J0 \<inter> I)) \<Longrightarrow> \<psi> a = ring.indexed_const (Pring R J0) a"
+  proof- fix a assume A: "a \<in> carrier (Pring R (J0 \<inter> I))"
+    show " \<psi> a = ring.indexed_const (Pring R J0) a"
+      apply(rule indexed_pset.induct[of a "J0 \<inter> I" "carrier R"])
+      using A Pring_car apply blast
+      using 4  
+      apply blast
+    proof- 
+      show "\<And>P Q. P \<in> Pring_set R (J0 \<inter> I) \<Longrightarrow>
+           \<psi> P = ring.indexed_const (Pring R J0) P \<Longrightarrow>
+           Q \<in> Pring_set R (J0 \<inter> I) \<Longrightarrow> \<psi> Q = ring.indexed_const (Pring R J0) Q \<Longrightarrow> \<psi> (P \<Oplus> Q) = ring.indexed_const (Pring R J0) (P \<Oplus> Q)"
+      proof- fix P Q 
+        assume A0: "P \<in> Pring_set R (J0 \<inter> I)"
+        assume A1: "\<psi> P = ring.indexed_const (Pring R J0) P"
+        assume A2: "Q \<in> Pring_set R (J0 \<inter> I)"
+        assume A3: "\<psi> Q = ring.indexed_const (Pring R J0) Q"
+        have A0': "P \<in> Pring_set R I"
+          using A0  
+          by (meson Int_lower2 Pring_carrier_subset subsetD)
+        have A1': "Q \<in> Pring_set R I"
+          by (meson A2 Int_lower2 Pring_carrier_subset subsetD)
+        have B: "\<psi> (P \<Oplus> Q) = \<psi> P \<oplus>\<^bsub>Pring (Pring R J0) J1\<^esub> \<psi> Q"
+          using A0' A1' A2 A3 C0 assms ring_hom_add 
+          by (metis (no_types, lifting) Pring_add local.ring_axioms ring.Pring_car ring_hom_ring.homh)
+        have " ring.indexed_const (Pring R J0) (P \<Oplus> Q) =  ring.indexed_const (Pring R J0) P
+                                 \<oplus>\<^bsub>Pring (Pring R J0) J1\<^esub>ring.indexed_const (Pring R J0) Q"
+          by (simp add: Pring_add Pring_is_ring ring.Pring_add ring.indexed_padd_const)
+        then show " \<psi> (P \<Oplus> Q) = ring.indexed_const (Pring R J0) (P \<Oplus> Q)"
+          using B 
+          by (simp add: A1 A3)
+      qed 
+      show "\<And>P i. P \<in> Pring_set R (J0 \<inter> I) \<Longrightarrow> \<psi> P = ring.indexed_const (Pring R J0) P \<Longrightarrow> 
+                    i \<in> J0 \<inter> I \<Longrightarrow> \<psi> (P \<Otimes> i) = ring.indexed_const (Pring R J0) (P \<Otimes> i)"
+      proof- fix P i assume A0: "P \<in> Pring_set R (J0 \<inter> I)"
+        assume A1: "\<psi> P = ring.indexed_const (Pring R J0) P"
+        assume A2: "i \<in> J0 \<inter> I"
+        have A0': "P \<in> carrier (Pring R I)"
+          using A0  Pring_carrier_subset 
+          by (metis (no_types, opaque_lifting) Pring_car in_mono inf_commute le_inf_iff subset_refl)
+        have A0'': "P \<in> carrier (Pring R J0)"
+          using A0  Pring_carrier_subset 
+          by (metis (no_types, opaque_lifting) Pring_car in_mono inf_commute le_inf_iff subset_refl)
+        have " \<psi> (P \<Otimes> i) = \<psi> P \<otimes>\<^bsub>Pring (Pring R J0) J1\<^esub>  ring.indexed_const (Pring R J0) (pvar R i)"
+        proof-
+          have "(P \<Otimes> i) = P \<otimes>\<^bsub>Pring R I\<^esub> pvar R i"
+            using A0' A2 unfolding var_to_IP_def 
+            by (metis A0 Pring_mult poly_index_mult)          
+          then show ?thesis 
+            using A0' C0 A2 C1[of i] ring_hom_ring.homh 
+                  ring_hom_mult[of \<psi> "Pring R I" "Pring (Pring R J0) J1" P "pvar R i"] 
+          by (metis IntE Pring_var_closed)
+        qed
+        then have" \<psi> (P \<Otimes> i) = ring.indexed_const (Pring R J0) P \<otimes>\<^bsub>Pring (Pring R J0) J1\<^esub> 
+                           ring.indexed_const (Pring R J0) (pvar R i)"
+          by (simp add: A1)
+        then have " \<psi> (P \<Otimes> i) = ring.indexed_const (Pring R J0) (P \<otimes>\<^bsub>Pring R J0\<^esub> (pvar R i))"
+          using A0'' A2  cring.indexed_const_ring_hom[of "Pring R J0" J1] ring_hom_ring.homh 
+                ring_hom_mult[of "ring.indexed_const (Pring R J0)" "Pring R J0" _  P "pvar R i"] 
+          by (smt "1" IntE Pring_var_closed)
+        then show "\<psi> (P \<Otimes> i) = ring.indexed_const (Pring R J0) (P \<Otimes> i)"
+          using poly_index_mult[of P J0 i] unfolding var_to_IP_def  
+          by (metis A0'' A2 IntE Pring_car Pring_mult)
+      qed
+    qed
+  qed
+qed
+
+lemma var_factor_morphism':
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "\<psi> = (var_factor I J0 J1)"
+  shows "ring_hom_ring (Pring R I) (Pring (Pring R J0) J1) \<psi> "
+        "\<And>i. i \<in> J1 \<Longrightarrow> \<psi> (pvar R i) = pvar (Pring R J0) i"
+        "\<And>a. a \<in> carrier (Pring R (J0 \<inter> I)) \<Longrightarrow> \<psi> a = ring.indexed_const (Pring R J0) a"
+  using assms var_factor_morphism 
+  apply blast
+   using assms var_factor_morphism(3)
+  apply (metis subset_refl)
+     using assms var_factor_morphism(4) 
+  by (metis Un_subset_iff Un_upper1)
+
+text\<open>Constructing the inverse morphism for \texttt{var\_factor\_morphism} \<close>
+
+
+lemma pvar_ass_closed:
+  assumes "J1 \<subseteq> I"
+  shows "pvar R \<in> J1 \<rightarrow> carrier (Pring R I)"
+  by (meson Pi_I Pring_var_closed assms subsetD)
+
+text\<open>The following function gives us the inverse morphism $R[I][J] \to R[I \cup J]$:\<close>
+definition var_factor_inv :: "'d set \<Rightarrow> 'd set \<Rightarrow> 'd set \<Rightarrow> 
+  ((('a, 'd) mvar_poly, 'd) mvar_poly, ('a, 'd) mvar_poly) ring_hom" where
+"var_factor_inv (I:: 'd set) (J0:: 'd set) (J1:: 'd set) = indexed_poly_induced_morphism J1 (Pring R I)                                                      
+                                                        (id:: ('d multiset \<Rightarrow> 'a) \<Rightarrow> 'd multiset \<Rightarrow> 'a)
+                                                       (pvar R)"
+  
+lemma var_factor_inv_morphism:
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "\<psi> = (var_factor_inv I J0 J1)"
+  shows "ring_hom_ring (Pring (Pring R J0) J1) (Pring R I)  \<psi> "
+        "\<And>i. i \<in> J1 \<Longrightarrow> \<psi> (pvar (Pring R J0) i) = pvar R i"
+        "\<And>a. a \<in> carrier (Pring R J0) \<Longrightarrow> \<psi> (ring.indexed_const (Pring R J0) a) = a"
+proof-   
+  have 0:  "ring_hom_ring (Pring R J0) (Pring R I) id"
+    apply(rule ring_hom_ringI)
+      apply (simp add: Pring_is_ring; fail) 
+        apply (simp add: Pring_is_ring;fail )
+       apply (metis Pring_car Pring_carrier_subset Un_upper1 assms(1) id_apply subsetD)
+    apply (metis Pring_mult_eq id_apply)
+     apply (metis Pring_add_eq id_apply)
+  by (simp add: Pring_one_eq)
+  then show "ring_hom_ring (Pring (Pring R J0) J1) (Pring R I)  \<psi> " 
+    using cring.Pring_universal_prop(1)[of "Pring R J0" "Pring R I" "pvar R" J1 id \<psi>]
+        pvar_ass_closed[of J0 I]
+    by (metis Pring_is_cring assms(2) assms(4) is_cring pvar_ass_closed var_factor_inv_def)
+  show "\<And>i. i \<in> J1 \<Longrightarrow> \<psi> (pvar (Pring R J0) i) = pvar R i"
+    using 0 assms pvar_ass_closed[of J0 I] 
+        cring.Pring_universal_prop(2)[of "Pring R J0" "Pring R I" "pvar R" J1 id \<psi>]
+    by (metis Pring_is_cring is_cring pvar_ass_closed var_factor_inv_def var_to_IP_def)
+  show "\<And>a. a \<in> carrier (Pring R J0) \<Longrightarrow> \<psi> (ring.indexed_const (Pring R J0) a) = a"
+    using 0 assms pvar_ass_closed[of J0 I] 
+        cring.Pring_universal_prop(3)[of "Pring R J0" "Pring R I" "pvar R" J1 id \<psi>]
+    by (smt Pi_I Pring_is_cring Pring_var_closed id_def is_cring subsetD var_factor_inv_def)
+qed
+
+lemma var_factor_inv_inverse:
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "\<psi>1 = (var_factor_inv I J0 J1)"
+  assumes "\<psi>0 = (var_factor I J0 J1)"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "\<psi>1 (\<psi>0 P) = P"
+  apply(rule indexed_pset.induct[of P I "carrier R"])
+  using Pring_car assms(6) apply blast
+    using var_factor_inv_morphism(3)[of I J0 J1 "\<psi>1"] var_factor_morphism'(3)[of I J0 J1 \<psi>0] assms
+    apply (metis indexed_const_closed inf_sup_absorb)    
+proof-
+  have 0: "ring_hom_ring (Pring (Pring R J0) J1) (Pring R I) \<psi>1"
+    by (simp add: assms(1) assms(3) assms(4) var_factor_inv_morphism(1))
+  have 1: "ring_hom_ring (Pring R I) (Pring (Pring R J0) J1) \<psi>0"
+    by (simp add: assms(1) assms(3) assms(5) var_factor_morphism'(1))
+  have 2: "\<psi>1 \<circ> \<psi>0 \<in> ring_hom (Pring R I) (Pring R I)"
+    using 0 1 ring_hom_trans[of \<psi>0 "Pring R I" "Pring (Pring R J0) J1" \<psi>1 "Pring R I"]
+          ring_hom_ring.homh[of "Pring R I" "Pring (Pring R J0) J1" \<psi>0] 
+          ring_hom_ring.homh[of "Pring (Pring R J0) J1" "Pring R I" \<psi>1]
+    by blast
+  show "\<And>P Q. P \<in> Pring_set R I \<Longrightarrow>
+           \<psi>1 (\<psi>0 P) = P \<Longrightarrow> Q \<in> Pring_set R I \<Longrightarrow> \<psi>1 (\<psi>0 Q) = Q \<Longrightarrow> \<psi>1 (\<psi>0 (P \<Oplus> Q)) = P \<Oplus> Q"
+  proof- fix P Q assume A0: "P \<in> Pring_set R I" "\<psi>1 (\<psi>0 P) = P"
+    assume A1: "Q \<in> Pring_set R I" "\<psi>1 (\<psi>0 Q) = Q"
+    show "\<psi>1 (\<psi>0 (P \<Oplus> Q)) = P \<Oplus> Q"
+      using  A0 A1 2 ring_hom_add[of "\<psi>1 \<circ> \<psi>0" "Pring R I" "Pring R I" P Q] comp_apply[of \<psi>1 \<psi>0]
+      by (simp add: "2" \<open>P \<in> Pring_set R I\<close> \<open>Q \<in> Pring_set R I\<close> Pring_add Pring_car)
+  qed
+  show "\<And>P i. P \<in> Pring_set R I \<Longrightarrow> \<psi>1 (\<psi>0 P) = P \<Longrightarrow> i \<in> I \<Longrightarrow> \<psi>1 (\<psi>0 (P \<Otimes> i)) = P \<Otimes> i"
+  proof-
+    fix P i assume A: "P \<in> Pring_set R I" "\<psi>1 (\<psi>0 P) = P" "i \<in> I"
+    show "\<psi>1 (\<psi>0 (P \<Otimes> i)) = P \<Otimes> i"
+    proof-
+      have A0: "P \<Otimes> i = P \<otimes>\<^bsub>Pring R I\<^esub> pvar R i"
+        by (metis A(1) A(3) Pring_mult local.ring_axioms ring.poly_index_mult var_to_IP_def)
+      have A1: "\<psi>1 (\<psi>0 (pvar R i)) = pvar R i"
+       by (metis A(3) Int_iff Pring_var_closed UnE Un_subset_iff Un_upper1 assms(1) assms(2) 
+           assms(3) assms(4) assms(5) cring.var_factor_morphism(2) is_cring 
+           var_factor_inv_morphism(2) var_factor_inv_morphism(3) var_factor_morphism'(2))
+     then show ?thesis 
+       using 2 A0 A ring_hom_mult[of "\<psi>1 \<circ> \<psi>0" "Pring R I" _  P "pvar R i" ]
+            Pring_car Pring_var_closed comp_apply[of \<psi>1 \<psi>0]
+       by smt
+   qed
+ qed
+qed
+
+lemma var_factor_total_eval:
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "\<psi> = (var_factor I J0 J1)"
+  assumes "closed_fun R g"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "total_eval R g P = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P))"
+  apply(rule indexed_pset.induct[of P I "carrier R"])
+  using Pring_car assms apply blast
+    apply (metis Pring_is_cring assms(1) assms(2) assms(3) assms(4) cring.total_eval_const 
+      indexed_const_closed is_cring var_factor_morphism'(3))
+proof-
+  show "\<And>P Q. P \<in> Pring_set R I \<Longrightarrow>
+           total_eval R g P = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<Longrightarrow>
+           Q \<in> Pring_set R I \<Longrightarrow>
+           total_eval R g Q = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> Q)) \<Longrightarrow>
+           total_eval R g (P \<Oplus> Q) = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Oplus> Q)))"
+  proof- fix P Q 
+    assume A: " P \<in> Pring_set R I"
+           "total_eval R g P = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P))"
+    assume B: " Q \<in> Pring_set R I"
+           "total_eval R g Q = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> Q))"
+    have 0: "\<psi> (P \<Oplus> Q) = \<psi> P \<oplus>\<^bsub>Pring (Pring R J0) J1\<^esub> \<psi> Q"
+      using A B assms var_factor_morphism'(1)[of I J0 J1 \<psi>] 
+            Pring_add[of I P Q] Pring_car[of I] 
+            ring_hom_ring.homh[of "Pring R I" "Pring (Pring R J0) J1" \<psi>]
+            ring_hom_add[of \<psi> "Pring R I" "Pring (Pring R J0) J1" P Q]
+      by metis     
+    have 1: "closed_fun (Pring R J0) (indexed_const \<circ> g)"
+      using assms comp_apply   
+      by (smt Pi_I closed_fun_simp indexed_const_closed)            
+    have 2: "\<psi> P \<in> carrier (Pring (Pring R J0) J1)"
+      using assms A var_factor_morphism'(1)[of I J0 J1 \<psi>] 
+            ring_hom_ring.homh ring_hom_closed Pring_car  
+      by metis   
+    have 3: "\<psi> Q \<in> carrier (Pring (Pring R J0) J1)"
+      using assms B var_factor_morphism'(1)[of I J0 J1 \<psi>] 
+          ring_hom_ring.homh ring_hom_closed Pring_car 
+      by metis     
+    have 4: "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Oplus> Q))) =
+            (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<oplus>\<^bsub>Pring R J0\<^esub>
+            (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> Q))"
+      using 0 1 2 3 A B assms cring.total_eval_add[of "Pring R J0" "\<psi> P" J1 "\<psi> Q" "indexed_const \<circ> g"]
+      by (metis Pring_car Pring_is_cring is_cring)
+    have 5: "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<in> carrier (Pring R J0)"
+      using 3 assms cring.total_eval_closed "1" "2" Pring_is_cring is_cring 
+      by blast
+    have 6: "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> Q)) \<in> carrier (Pring R J0)"
+      using 4 assms  "1" "3" Pring_is_cring cring.total_eval_closed is_cring 
+      by blast
+    show "total_eval R g (P \<Oplus> Q) = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Oplus> Q)))"
+      using 5 6 4 assms 
+            total_eval_add[of  "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> p))" J0
+                              "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> Q))" ]
+      by (smt A(1) A(2) B(1) B(2) Pring_add Pring_car in_mono indexed_pset_mono order_refl 
+          subsetD subset_iff total_eval_add)
+  qed
+  show "\<And>P i. P \<in> Pring_set R I \<Longrightarrow>
+           total_eval R g P = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<Longrightarrow>
+           i \<in> I \<Longrightarrow> total_eval R g (P \<Otimes> i) = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Otimes> i)))"
+  proof- fix P i 
+    assume A: "P \<in> Pring_set R I"
+           "total_eval R g P = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P))"
+           "i \<in> I" 
+    have 0: "(P \<Otimes> i) = P \<otimes>\<^bsub>Pring R I\<^esub> (pvar R i)"
+      using A poly_index_mult  
+      by (metis Pring_mult var_to_IP_def)
+    have 1: "\<psi> (P \<Otimes> i) = \<psi> P \<otimes>\<^bsub>Pring (Pring R J0) J1\<^esub> \<psi> (pvar R i)"
+      using 0 A assms var_factor_morphism'(1)[of I J0 J1 \<psi>]
+            pvar_closed[of R i] ring_hom_mult ring_hom_ring.homh 
+      by (smt Pring_car Pring_var_closed)
+    have 2: "\<psi> P \<in> carrier (Pring (Pring R J0) J1)"
+      using assms A var_factor_morphism'(1)[of I J0 J1 \<psi>] 
+            ring_hom_ring.homh ring_hom_closed Pring_car  
+      by metis   
+    have 3: "\<psi> (pvar R i) \<in> carrier (Pring (Pring R J0) J1)"
+      using assms A var_factor_morphism'(1)[of I J0 J1 \<psi>]
+            ring_hom_ring.homh ring_hom_closed Pring_car pvar_closed[of R i I]  
+      by (metis is_cring)
+    have 4: "closed_fun (Pring R J0) (indexed_const \<circ> g)"
+      apply(rule cring.closed_funI)
+      using Pring_is_cring is_cring apply blast
+            using assms indexed_const_closed closed_fun_simp[of g] comp_apply[of indexed_const g]
+          proof -
+            fix x :: 'c
+            show "(indexed_const \<circ> g) x \<in> carrier (Pring R J0)"
+              by (metis (no_types) \<open>\<And>n. closed_fun R g \<Longrightarrow> g n \<in> carrier R\<close> \<open>\<And>x. (indexed_const \<circ> g) x = indexed_const (g x)\<close> \<open>closed_fun R g\<close> indexed_const_closed)
+          qed
+    have 5: "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Otimes> i))) = 
+              (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<otimes>\<^bsub>Pring R J0\<^esub> 
+              (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i)))"
+      using 2 3 4 cring.total_eval_ring_hom[of "Pring R J0" "indexed_const \<circ> g" J1]  
+      by (metis "1" Pring_is_cring cring.total_eval_mult is_cring)
+    have 6: "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<in> carrier (Pring R J0)"
+      using total_eval_closed "2" "4" Pring_is_cring cring.total_eval_closed is_cring
+      by blast
+    have 7: " (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i))) \<in> carrier (Pring R J0)"
+      using "3" "4" Pring_is_cring cring.total_eval_closed is_cring 
+      by blast
+    have 8: " total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Otimes> i))) = 
+              total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> P)) \<otimes>\<^bsub>R\<^esub>
+              total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i)))"
+      using 6 7 
+      by (metis "5" assms(5) cring.total_eval_mult is_cring)
+    have 9: " total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Otimes> i))) = 
+              total_eval R g P \<otimes>\<^bsub>R\<^esub>
+              total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i)))"
+      using "8" A(2)
+      by presburger
+    have 10: "total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i))) = 
+              g i"
+    proof(cases "i \<in> J0")
+      case True
+      then have "\<psi> (pvar R i) = ring.indexed_const (Pring R J0) (pvar R i)"
+        using assms  
+        by (metis Pring_var_closed inf_sup_absorb var_factor_morphism'(3))
+      then have "(total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i))) =  (pvar R i)"
+        by (metis Pring_is_cring Pring_var_closed True cring.total_eval_const is_cring)
+      then show ?thesis 
+        using total_eval_var[of g i] assms var_to_IP_def  
+        by metis        
+    next
+      case False
+      then have "\<psi> (pvar R i) = (pvar  (Pring R J0)  i)"
+        by (metis A(3) UnE assms(1) assms(2) assms(3) assms(4) cring.var_factor_morphism'(2) is_cring)
+      then have "total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (pvar R i)) = 
+                  indexed_const (g i)"
+        using cring.total_eval_var[of "Pring R J0" "indexed_const \<circ> g" i] comp_apply
+        by (metis "4" Pring_is_cring is_cring var_to_IP_def)
+      then show ?thesis 
+        using total_eval_const[of "g i" g] assms closed_fun_simp[of g i] 
+        by metis 
+    qed
+    show "total_eval R g (P \<Otimes> i) = total_eval R g (total_eval (Pring R J0) (indexed_const \<circ> g) (\<psi> (P \<Otimes> i)))"
+      using 9 10 
+      by (metis A(1) A(3) Pring_car assms(5) total_eval_indexed_pmult)
+  qed
+qed
+
+lemma var_factor_closed: 
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "var_factor I J0 J1 P \<in> carrier (Pring (Pring R J0 ) J1)"
+  using assms var_factor_morphism'[of I J0 J1] ring_hom_ring.homh
+  by (metis ring_hom_closed)
+
+lemma var_factor_add: 
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  shows "var_factor I J0 J1 (P \<oplus>\<^bsub>Pring R I\<^esub> Q) = var_factor I J0 J1 P \<oplus>\<^bsub>Pring (Pring R J0) J1\<^esub>
+                                                 var_factor I J0 J1 Q"
+  using assms var_factor_morphism'[of I J0 J1] ring_hom_ring.homh
+  by (metis (no_types, lifting) ring_hom_add)
+  
+lemma var_factor_mult: 
+  assumes "I = J0 \<union> J1"
+  assumes "J1 \<subseteq> I"
+  assumes "J1 \<inter> J0 = {}"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  shows "var_factor I J0 J1 (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = var_factor I J0 J1 P \<otimes>\<^bsub>Pring (Pring R J0) J1\<^esub>
+                                                 var_factor I J0 J1 Q"
+  using assms var_factor_morphism'[of I J0 J1] ring_hom_ring.homh
+  by (metis (no_types, lifting) ring_hom_mult)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Viewing a Mulitvariable Polynomial as a Univariate Polynomial over a Multivariate Polynomial Base Ring\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition multivar_poly_to_univ_poly :: 
+ "'c set \<Rightarrow> 'c \<Rightarrow> ('a,'c) mvar_poly \<Rightarrow>
+       (('a,'c) mvar_poly) u_poly  " where
+"multivar_poly_to_univ_poly I i P = ((IP_to_UP i) \<circ> (var_factor I (I - {i}) {i})) P"
+
+definition univ_poly_to_multivar_poly :: 
+  "'c set \<Rightarrow> 'c \<Rightarrow> (('a,'c) mvar_poly) u_poly \<Rightarrow> 
+        ('a,'c) mvar_poly"  where
+"univ_poly_to_multivar_poly I i P =((var_factor_inv I (I - {i}) {i}) \<circ> (UP_to_IP (Pring R (I - {i})) i)) P"
+
+lemma multivar_poly_to_univ_poly_is_hom:
+  assumes "i \<in> I"
+  shows "multivar_poly_to_univ_poly I i \<in> ring_hom (Pring R I) (UP (Pring R (I - {i})))"
+  unfolding multivar_poly_to_univ_poly_def comp_apply
+  apply(rule ring_hom_compose[of _ "Pring (Pring R (I - {i})) {i}" _ "var_factor I (I - {i}) {i}" "IP_to_UP i"])
+       apply (simp add: Pring_is_ring; fail)
+      apply (simp add: local.ring_axioms ring.Pring_is_ring; fail)
+     apply(rule UP_ring.UP_ring) unfolding UP_ring_def 
+     apply (simp add: Pring_is_ring; fail)
+    using assms var_factor_morphism'[of I "I - {i}" "{i}"] unfolding ring_hom_ring_def ring_hom_ring_axioms_def 
+    apply blast
+    using UP_cring.IP_to_UP_ring_hom[of "Pring R (I - {i})" i] 
+    unfolding ring_hom_ring_def ring_hom_ring_axioms_def UP_cring_def 
+    using Pring_is_cring is_cring apply blast
+    by blast 
+
+lemma multivar_poly_to_univ_poly_inverse:
+  assumes "i \<in> I"
+  assumes "\<psi>0 = multivar_poly_to_univ_poly I i"
+  assumes "\<psi>1 = univ_poly_to_multivar_poly I i"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "\<psi>1 (\<psi>0 P) = P"
+proof-
+  have closed: "var_factor I (I - {i}) {i} P \<in> carrier (Pring (Pring R (I - {i})) {i})"
+    using assms var_factor_closed[of I "I - {i}" "{i}" P] 
+    by blast
+  have cancel_1: "UP_to_IP (Pring R (I - {i})) i 
+                  (IP_to_UP i (var_factor I (I - {i}) {i} P)) = 
+                        var_factor I (I - {i}) {i} P"
+    using closed assms  ring.Pring_car
+          UP_cring.UP_to_IP_inv[of "Pring R (I - {i})" "var_factor I (I - {i}) {i} P" i] 
+          Pring_is_ring unfolding UP_cring_def 
+    using is_cring local.ring_axioms ring.Pring_is_cring 
+    by blast  
+  have "univ_poly_to_multivar_poly I i (multivar_poly_to_univ_poly I i P) = 
+        univ_poly_to_multivar_poly I i ((IP_to_UP i) (var_factor I (I - {i}) {i} P))"
+    by (metis comp_apply multivar_poly_to_univ_poly_def)
+  then have "univ_poly_to_multivar_poly I i (multivar_poly_to_univ_poly I i P) = 
+        ((var_factor_inv I (I - {i}) {i})  ((UP_to_IP (Pring R (I - {i})) i)
+                 ((IP_to_UP i) (var_factor I (I - {i}) {i} P))))"
+    using comp_apply univ_poly_to_multivar_poly_def 
+    by metis
+  then have "univ_poly_to_multivar_poly I i (multivar_poly_to_univ_poly I i P) = 
+        ((var_factor_inv I (I - {i}) {i})  (var_factor I (I - {i}) {i} P))"
+    using cancel_1 
+    by presburger
+  then show ?thesis using assms var_factor_inv_inverse[of I "I - {i}" "{i}" _ _ P] 
+    by (metis Diff_cancel Diff_disjoint Diff_eq_empty_iff Diff_partition Un_Diff_cancel 
+        Un_Diff_cancel2 Un_insert_right empty_Diff empty_subsetI insert_Diff_if insert_absorb )
+qed
+
+lemma multivar_poly_to_univ_poly_total_eval:
+  assumes "i \<in> I"
+  assumes "\<psi> = multivar_poly_to_univ_poly I i"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "closed_fun R g"
+  shows "total_eval R g P = total_eval R g (to_function (Pring R (I - {i})) (\<psi> P) (indexed_const (g i)))"
+proof-
+  have 0: "var_factor I (I - {i}) {i} P \<in> Pring_set (Pring R (I - {i})) {i}"
+  proof-
+    have 00: " ring (Pring R (I - {i}))"
+      using Pring_is_ring 
+      by blast
+    then show ?thesis 
+      using assms(1) assms(3) var_factor_closed[of I "I - {i}" "{i}" P] ring.Pring_car[of "Pring R (I - {i})" "{i}"]
+      by blast
+  qed
+  have 1: "closed_fun (Pring R (I - {i})) (indexed_const \<circ> g)"
+    using assms comp_apply  indexed_const_closed cring.closed_funI[of "Pring R (I - {i})"]
+    by (metis Pring_is_cring closed_fun_simp is_cring)
+  have 2: "cring (Pring R (I - {i}))"
+    using Pring_is_cring is_cring by blast
+  have "(to_function (Pring R (I - {i})) (\<psi> P) (indexed_const (g i))) 
+        =  total_eval (Pring R (I - {i})) (indexed_const \<circ> g) ((var_factor I (I - {i}) {i}) P) "
+    using assms 0 1 2 comp_apply UP_cring.IP_to_UP_poly_eval[of "Pring R (I - {i})" 
+                                             "(var_factor I (I - {i}) {i}) P" i "indexed_const \<circ> g"]
+    unfolding UP_cring_def multivar_poly_to_univ_poly_def 
+    by metis 
+  then have 3: "total_eval R g ((to_function (Pring R (I - {i})) (\<psi> P) (indexed_const (g i))) )
+        = total_eval R g ( total_eval (Pring R (I - {i})) (indexed_const \<circ> g) ((var_factor I (I - {i}) {i}) P)) "
+    by presburger
+  then have "total_eval R g P = total_eval R g (total_eval (Pring R (I - {i})) (indexed_const \<circ> g) ((var_factor I (I - {i}) {i}) P)) "
+    using assms var_factor_total_eval[of I "I - {i}" "{i}" "var_factor I (I - {i}) {i}" g P] 
+    by blast
+  then show ?thesis
+    using 3 
+    by presburger
+qed
+
+text\<open>
+  Induction for polynomial rings. Basically just \texttt{indexed\_pset.induct} with some
+  boilerplate translations removed
+\<close>
+
+lemma(in ring) Pring_car_induct'':
+  assumes "Q \<in> carrier (Pring R I)"
+  assumes "\<And>c. c \<in> carrier R \<Longrightarrow> P (indexed_const c)"
+  assumes "\<And>p q. p \<in> carrier (Pring R I) \<Longrightarrow> q \<in> carrier (Pring R I) \<Longrightarrow> P p \<Longrightarrow> P q \<Longrightarrow> P (p \<oplus>\<^bsub>Pring R I\<^esub> q)"
+  assumes "\<And>p i. p \<in> carrier (Pring R I) \<Longrightarrow> i \<in> I \<Longrightarrow> P p \<Longrightarrow> P (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i)"
+  shows "P Q"
+  apply(rule indexed_pset.induct[of Q I "carrier R"])
+  using Pring_car assms(1) apply blast
+  using assms(2) apply blast
+  apply (metis (full_types) Pring_add Pring_car assms(3))
+proof-
+  fix Pa i assume A: "Pa \<in> Pring_set R I" "P Pa" "i \<in> I"
+  then have 0: "Pa \<in> carrier (Pring R I)"
+    using  assms A Pring_car
+    by blast
+  have "Pa \<Otimes> i = Pa \<otimes>\<^bsub>Pring R I\<^esub> pvar R i"
+    using 0 poly_index_mult assms A 
+    by (metis Pring_mult var_to_IP_def)
+  then show "P (Pa \<Otimes> i)"
+    by (simp add: "0" A(2) A(3) assms)
+qed
+
+subsubsection\<open>Application: A Polynomial Ring over a Domain is a Domain\<close>
+
+text \<open>
+  In this section, we use the fact the UP \<open>R\<close> is a domain when \<open>R\<close> is a domain to show the analogous
+  result for indexed polynomial rings. We first prove it inductively for rings with a finite 
+  variable set, and then generalize to infinite variable sets using the fact that any two 
+  multivariable polynomials over an indexed polynomial ring must also lie in a finitely indexed 
+  polynomial subring.
+\<close>
+
+lemma indexed_const_mult:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier R"
+  shows "indexed_const a \<otimes>\<^bsub> Pring R I\<^esub> indexed_const b  = indexed_const (a \<otimes>  b)"
+  by (metis Pring_mult assms(1) assms(2) indexed_const_P_mult_eq)  
+
+lemma(in domain) Pring_fin_vars_is_domain:
+  assumes "finite (I ::'c set)"
+  shows "domain (Pring R I)"
+proof(rule finite_induct, rule assms)
+  show "domain (Pring R ({}::'c set))"
+  proof(rule domainI)
+    show " cring (Pring R {})"
+      by (simp add: Pring_is_cring is_cring)
+    show "\<one>\<^bsub>Pring R {}\<^esub> \<noteq> \<zero>\<^bsub>Pring R {}\<^esub>"
+    proof-
+      have "\<one>\<^bsub>Pring R {}\<^esub> {#} \<noteq> \<zero>\<^bsub>Pring R {}\<^esub> {#}"
+        by (metis Pring_one Pring_zero local.ring_axioms ring.indexed_const_def zero_not_one)
+      thus ?thesis 
+        by metis
+    qed 
+    show "\<And>a b. a \<otimes>\<^bsub>Pring R ({}::'c set)\<^esub> b = \<zero>\<^bsub>Pring R {}\<^esub> \<Longrightarrow>
+           a \<in> carrier (Pring R {}) \<Longrightarrow> b \<in> carrier (Pring R {}) \<Longrightarrow> a = \<zero>\<^bsub>Pring R {}\<^esub> \<or> b = \<zero>\<^bsub>Pring R {}\<^esub>"
+    proof- 
+      fix a b assume A: "a \<otimes>\<^bsub>Pring R ({}::'c set)\<^esub> b = \<zero>\<^bsub>Pring R {}\<^esub>"
+           "a \<in> carrier (Pring R {})" " b \<in> carrier (Pring R {})"
+      have 0: "monomials_of R a \<subseteq> {{#}}"
+        using A Pring_set_zero unfolding monomials_of_def Pring_car
+        by blast
+      have 1: "monomials_of R b \<subseteq> {{#}}"
+        using A Pring_set_zero unfolding monomials_of_def Pring_car
+        by blast
+      obtain A where A_def: "A = a {#}"
+        by blast 
+      obtain B where B_def: "B = b {#}"
+        by blast 
+      have 2: "a = indexed_const A"
+        unfolding A_def
+        apply(rule ext)
+        by (metis 0 complement_of_monomials_of empty_iff in_mono indexed_const_def insert_iff)
+      have 3: "b = indexed_const B"
+        unfolding B_def 
+        apply(rule ext)
+        by (metis 1 complement_of_monomials_of empty_iff in_mono indexed_const_def insert_iff)
+      have 4: "a \<otimes>\<^bsub>Pring R {}\<^esub> b = indexed_const (A \<otimes> B)"
+        using A unfolding 2 3 
+        by (metis "2" "3" A_def B_def Pring_carrier_coeff' indexed_const_mult)
+      have 5: "A \<otimes> B = \<zero>"
+        using A unfolding 4 by (metis Pring_zero indexed_const_def)
+      have 6: "A = \<zero> \<or> B = \<zero>"
+        using 5 A_def B_def A 
+        by (simp add: domain.integral_iff domain_axioms)
+      show "a = \<zero>\<^bsub>Pring R {}\<^esub> \<or> b = \<zero>\<^bsub>Pring R {}\<^esub>"
+        unfolding 2 3 using 6 
+        by (metis Pring_zero)
+    qed
+  qed
+  show "\<And>x F. finite (F:: 'c set) \<Longrightarrow> x \<notin> F \<Longrightarrow> domain (Pring R F) \<Longrightarrow> domain (Pring R (insert x F))"
+  proof- fix S:: "'c set"  fix s assume A: "finite S" "s \<notin> S" "domain (Pring R S)"
+    show "domain (Pring R (insert s S))"
+    proof-
+      have ring_hom: "multivar_poly_to_univ_poly (insert s S) s \<in> ring_hom (Pring R (insert s S)) (UP (Pring R S))"
+        using multivar_poly_to_univ_poly_is_hom 
+        by (metis A(2) Diff_insert_absorb insertI1) 
+      have domain: "domain (UP (Pring R S))"
+        apply(rule UP_domain.UP_domain)
+        unfolding UP_domain_def by(rule A)
+      show "domain (Pring R (insert s S))"
+        apply(rule ring_hom_ring.inj_on_domain[of _ "UP (Pring R S)" "multivar_poly_to_univ_poly (insert s S) s"])
+          apply(rule ring_hom_ring.intro)
+            apply (simp add: Pring_is_ring; fail)
+           apply(rule UP_ring.UP_ring)
+        unfolding UP_ring_def 
+        apply (simp add: Pring_is_ring; fail)
+        unfolding ring_hom_ring_axioms_def apply(rule ring_hom)
+      proof(rule inj_onI)
+        fix x y assume A: "x \<in> carrier (Pring R (insert s S))"
+           "y \<in> carrier (Pring R (insert s S))"
+           "multivar_poly_to_univ_poly (insert s S) s x = multivar_poly_to_univ_poly (insert s S) s y"
+        then have 0: "univ_poly_to_multivar_poly (insert s S) s (multivar_poly_to_univ_poly (insert s S) s x)
+       = univ_poly_to_multivar_poly (insert s S) s (multivar_poly_to_univ_poly (insert s S) s y)"
+          by auto 
+        have 1: "univ_poly_to_multivar_poly (insert s S) s (multivar_poly_to_univ_poly (insert s S) s x) = x"
+          using A by (meson cring.multivar_poly_to_univ_poly_inverse insertI1 is_cring) 
+        have 2: "univ_poly_to_multivar_poly (insert s S) s (multivar_poly_to_univ_poly (insert s S) s y) = y"
+          using A  by (meson insertI1 multivar_poly_to_univ_poly_inverse) 
+        show "x = y"
+          using 0 unfolding 1 2 by auto 
+      next
+        show "domain (UP (Pring R S))"
+          apply(rule UP_domain.UP_domain)
+          unfolding UP_domain_def by(rule A)
+      qed
+    qed
+  qed
+qed
+
+lemma locally_finite:
+  assumes "a \<in> carrier (Pring R I)"
+  shows "\<exists>J. J \<subseteq> I \<and> finite J \<and> a \<in> carrier (Pring R J)"
+proof(rule Pring_car_induct[of _ I], rule assms)
+  have 0: "\<zero>\<^bsub>Pring R I\<^esub> = \<zero>\<^bsub>Pring R {}\<^esub>"
+    by (simp add: Pring_zero_eq) 
+  show "\<exists>J\<subseteq>I. finite J \<and> \<zero>\<^bsub>Pring R I\<^esub> \<in> carrier (Pring R J)"
+    unfolding 0 
+    by (meson Pring_zero_closed empty_subsetI finite.emptyI) 
+next
+  fix m k assume A: "set_mset m \<subseteq> I \<and> k \<in> carrier R"
+  obtain J where J_def: "J = set_mset m"
+    by blast
+  have 0: "k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m = k \<odot>\<^bsub>Pring R J\<^esub> mset_to_IP R m"
+    unfolding J_def by (simp add: Pring_smult) 
+  have 1: "k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m \<in> carrier (Pring R J)"
+    unfolding 0 J_def using A 
+    by (simp add: Pring_car Pring_smult mset_to_IP_closed poly_scalar_mult_closed) 
+  show "\<exists>J\<subseteq>I. finite J \<and> k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m \<in> carrier (Pring R J)"
+    using J_def 1 A by blast 
+next
+  fix Q m k 
+  assume A: "Q \<in> carrier (Pring R I)\<and>(\<exists>J\<subseteq>I. finite J \<and> Q \<in> carrier (Pring R J)) \<and> set_mset m \<subseteq> I \<and> k \<in> carrier R"
+  then obtain J where J_def: "J\<subseteq>I \<and> finite J \<and> Q \<in> carrier (Pring R J)"
+    by blast 
+  obtain J' where J'_def: "J' = J \<union> set_mset m"
+    by blast 
+  have 0: "finite J'"
+    unfolding J'_def using J_def by blast 
+  have 1: "k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m = k \<odot>\<^bsub>Pring R J'\<^esub> mset_to_IP R m"
+    unfolding J'_def using A by (simp add: Pring_smult)
+  have 2: "Q \<in> carrier (Pring R J')"
+    using J_def unfolding J'_def 
+    by (metis Pring_car Pring_carrier_subset Un_upper1 subsetD) 
+  have 3: "Q \<Oplus> k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m \<in> carrier (Pring R J')"
+    using 0 1 2 J'_def A 
+    by (metis Pring_car Pring_smult_closed indexed_pset.indexed_padd mset_to_IP_closed sup.cobounded2) 
+  show "\<exists>J'\<subseteq>I. finite J' \<and> Q \<Oplus> k \<odot>\<^bsub>Pring R I\<^esub> mset_to_IP R m \<in> carrier (Pring R J')"
+    using 3 0 
+    by (metis A J'_def J_def Un_subset_iff) 
+qed
+
+lemma(in domain) Pring_is_domain:
+  "domain (Pring R I)"
+proof(rule domainI, simp add: Pring_is_cring is_cring)
+  have 0: "\<one>\<^bsub>Pring R I\<^esub> {#} = \<one>"
+    by (simp add: Pring_one indexed_const_def)
+  have 1: "\<zero>\<^bsub>Pring R I\<^esub> {#} = \<zero>"
+    by (simp add: Pring_zero indexed_const_def) 
+  have 2: "\<one> \<noteq> \<zero>"
+    by simp
+  show "\<one>\<^bsub>Pring R I\<^esub> \<noteq> \<zero>\<^bsub>Pring R I\<^esub>"
+    using 0 1 2 by auto 
+next
+  fix a b assume A: "a \<otimes>\<^bsub>Pring R I\<^esub> b = \<zero>\<^bsub>Pring R I\<^esub>"
+                    "a \<in> carrier (Pring R I)"
+                    "b \<in> carrier (Pring R I)"
+  obtain J0 where J0_def: "J0 \<subseteq> I \<and> finite J0 \<and> a \<in> carrier (Pring R J0)"
+    using A locally_finite by blast 
+  obtain J1 where J1_def: "J1 \<subseteq> I \<and> finite J1 \<and> b \<in> carrier (Pring R J1)"
+    using A locally_finite by blast 
+  obtain J where J_def: "J = J0 \<union> J1"
+    by blast 
+  have J_finite: "finite J"
+    using J_def J0_def J1_def by blast 
+  have 0: "a \<in> carrier (Pring R J)"
+    using J0_def unfolding J_def 
+    by (metis (no_types, lifting) Pring_car Pring_carrier_subset Un_upper1 subset_eq) 
+  have 1: "b \<in> carrier (Pring R J)"
+    using J1_def unfolding J_def 
+    by (metis Pring_car Pring_carrier_subset in_mono sup.cobounded2) 
+  have 2: "a \<otimes>\<^bsub>Pring R J\<^esub> b = \<zero>\<^bsub>Pring R J\<^esub>"
+    using A J_def 0 1 by (metis Pring_mult_eq Pring_zero_eq)
+  have 3: "domain (Pring R J)"
+    using J_finite Pring_fin_vars_is_domain[of J] by blast 
+  have 4: "a = \<zero>\<^bsub>Pring R J\<^esub> \<or> b = \<zero>\<^bsub>Pring R J\<^esub>"
+    using 3 2 0 1  by (simp add: domain.integral)
+  thus "a = \<zero>\<^bsub>Pring R I\<^esub> \<or> b = \<zero>\<^bsub>Pring R I\<^esub>"
+    using Pring_zero_eq by blast 
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Relabelling of Variables for Indexed Polynomial Rings\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition relabel_vars :: "'d set \<Rightarrow> 'e set \<Rightarrow> ('d \<Rightarrow> 'e) \<Rightarrow>
+         ('a, 'd) mvar_poly \<Rightarrow> ('a, 'e) mvar_poly" where
+"relabel_vars I J g = indexed_poly_induced_morphism I (Pring R J) indexed_const (\<lambda>i. pvar R (g i))"
+
+lemma relabel_vars_is_morphism: 
+  assumes "g \<in> I \<rightarrow> J"
+  shows "ring_hom_ring (Pring R I) (Pring R J) (relabel_vars I J g)"
+        "\<And>i. i \<in> I \<Longrightarrow> relabel_vars I J g (pvar R i) = pvar R (g i)"
+        "\<And>c. c \<in> carrier R \<Longrightarrow> relabel_vars I J g (indexed_const c) = indexed_const c"
+  using Pring_universal_prop(1)[of "Pring R J" "\<lambda>i. pvar R (g i)" I indexed_const]
+    assms unfolding relabel_vars_def 
+    apply (meson Pi_iff Pring_is_cring Pring_var_closed indexed_const_ring_hom is_cring)
+proof-
+  have 0: "cring (Pring R J)" " (\<lambda>i. mset_to_IP R {#g i#}) \<in> I \<rightarrow> carrier (Pring R J)"
+    "ring_hom_ring R (Pring R J) indexed_const"
+    using assms Pring_is_cring is_cring apply blast
+    apply (smt Pi_iff Pring_var_closed assms var_to_IP_def)
+    by (simp add: indexed_const_ring_hom)
+  show "\<And>i. i \<in> I \<Longrightarrow> indexed_poly_induced_morphism I (Pring R J) 
+                        indexed_const (\<lambda>i. pvar R (g i)) (pvar R i) = pvar R (g i)"
+    using 0 assms Pring_universal_prop(2)[of "Pring R J" "\<lambda>i. pvar R (g i)" I indexed_const]
+    unfolding relabel_vars_def var_to_IP_def 
+    by blast
+  show "\<And>c. c \<in> carrier R \<Longrightarrow> indexed_poly_induced_morphism I (Pring R J) 
+                          indexed_const (\<lambda>i. pvar R (g i)) (indexed_const c) = indexed_const c"
+    using 0 assms Pring_universal_prop(3)[of "Pring R J" "\<lambda>i. pvar R (g i)" I indexed_const]
+    unfolding  var_to_IP_def 
+    by blast
+qed
+
+lemma relabel_vars_add: 
+  assumes "g \<in> I \<rightarrow> J"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  shows "relabel_vars I J g (P \<oplus>\<^bsub>Pring R I\<^esub> Q) = relabel_vars I J g P \<oplus>\<^bsub>Pring R J\<^esub> relabel_vars I J g Q"
+  using assms relabel_vars_is_morphism(1)[of g I J] ring_hom_ring.homh ring_hom_add 
+  by (metis (no_types, lifting))
+
+lemma relabel_vars_mult: 
+  assumes "g \<in> I \<rightarrow> J"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "Q \<in> carrier (Pring R I)"
+  shows "relabel_vars I J g (P \<otimes>\<^bsub>Pring R I\<^esub> Q) = relabel_vars I J g P \<otimes>\<^bsub>Pring R J\<^esub> relabel_vars I J g Q"
+  using assms relabel_vars_is_morphism(1)[of g I J] ring_hom_ring.homh ring_hom_mult
+  by (metis (no_types, lifting))
+
+lemma relabel_vars_closed: 
+  assumes "g \<in> I \<rightarrow> J"
+  assumes "P \<in> carrier (Pring R I)"
+  shows "relabel_vars I J g P \<in> carrier (Pring R J)"
+  using assms relabel_vars_is_morphism(1)[of g I J] ring_hom_ring.homh 
+  by (metis ring_hom_closed)
+
+lemma relabel_vars_smult: 
+  assumes "g \<in> I \<rightarrow> J"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "a \<in> carrier R"
+  shows "relabel_vars I J g (a \<odot>\<^bsub>Pring R I\<^esub>P) = a \<odot>\<^bsub>Pring R J\<^esub>relabel_vars I J g P"
+proof-
+  have 0: "a \<odot>\<^bsub>Pring R I\<^esub>P = indexed_const a \<otimes>\<^bsub>Pring R I\<^esub> P"
+    by (metis Pring_car Pring_mult Pring_smult assms(2) assms(3) poly_scalar_mult_eq)
+  have 1: "a \<odot>\<^bsub>Pring R J\<^esub>relabel_vars I J g P = indexed_const a \<otimes>\<^bsub>Pring R J\<^esub> relabel_vars I J g P"
+    by (metis Pring_car Pring_mult Pring_smult assms(1) assms(2) assms(3) poly_scalar_mult_eq relabel_vars_closed)
+  show ?thesis using 0 1 assms relabel_vars_mult relabel_vars_is_morphism(3)[of g I J a]
+    by (metis indexed_const_closed)
+qed
+  
+lemma relabel_vars_inverse: 
+  assumes "g \<in> I \<rightarrow> J"
+  assumes "h \<in> J \<rightarrow> I"
+  assumes "\<And>i. i \<in> I \<Longrightarrow> h (g i) = i"
+  assumes "P \<in> carrier (Pring R I)"
+  shows  "relabel_vars J I h (relabel_vars I J g P) = P"
+  apply(rule Pring_car_induct''[of _ I])
+  using assms(4) apply blast
+  using assms 
+  apply (metis relabel_vars_is_morphism(3))
+proof-
+  show "\<And>p q. p \<in> carrier (Pring R I) \<Longrightarrow>
+           q \<in> carrier (Pring R I) \<Longrightarrow>
+           relabel_vars J I h (relabel_vars I J g p) = p \<Longrightarrow>
+           relabel_vars J I h (relabel_vars I J g q) = q \<Longrightarrow> 
+           relabel_vars J I h (relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q)) = p \<oplus>\<^bsub>Pring R I\<^esub> q"
+  proof- fix p q assume A: " p \<in> carrier (Pring R I)" "q \<in> carrier (Pring R I)"
+                "relabel_vars J I h (relabel_vars I J g p) = p"
+           "relabel_vars J I h (relabel_vars I J g q) = q"
+    show "relabel_vars J I h (relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q)) = p \<oplus>\<^bsub>Pring R I\<^esub> q"
+    proof-
+      have 0: "relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q) = relabel_vars I J g p \<oplus>\<^bsub>Pring R J\<^esub> relabel_vars I J g q"
+        using A(1) A(2) assms(1) relabel_vars_add by blast
+      then show ?thesis
+        using assms A relabel_vars_is_morphism(3)[of g I J] relabel_vars_is_morphism(3)[of h J I]
+              relabel_vars_closed[of g I J p] relabel_vars_closed[of g I J q] 
+              relabel_vars_add[of h J I "relabel_vars I J g p" "relabel_vars I J g q"] 
+        by presburger
+    qed
+  qed 
+  show "\<And>p i. p \<in> carrier (Pring R I) \<Longrightarrow>
+           i \<in> I \<Longrightarrow>
+           relabel_vars J I h (relabel_vars I J g p) = p \<Longrightarrow> 
+        relabel_vars J I h (relabel_vars I J g (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i)) = p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i"
+  proof- fix p i assume A: " p \<in> carrier (Pring R I)"
+                         "relabel_vars J I h (relabel_vars I J g p) = p"
+                         "i \<in> I"
+    show " relabel_vars J I h (relabel_vars I J g (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i)) = p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i"
+    proof- 
+      have "relabel_vars J I h (relabel_vars I J g (pvar R i)) = pvar R i"
+        using assms relabel_vars_is_morphism[of g I J] relabel_vars_is_morphism[of h J I]
+        by (metis A(3) funcset_mem )
+      then show ?thesis 
+        using assms  relabel_vars_is_morphism[of g I J] relabel_vars_is_morphism[of h J I]
+              relabel_vars_closed[of g I J p] relabel_vars_closed[of g I J "pvar R i"] 
+              relabel_vars_mult[of g I J "p" "pvar R i"] 
+              relabel_vars_mult[of h J I "relabel_vars I J g p" "relabel_vars I J g (pvar R i)"] 
+        by (metis A(1) A(2) A(3) Pring_var_closed)
+    qed
+  qed
+qed
+
+lemma relabel_vars_total_eval:
+  assumes "g \<in> I \<rightarrow> J"
+  assumes "P \<in> carrier (Pring R I)"
+  assumes "closed_fun R f"
+  shows "total_eval R (f \<circ> g) P = total_eval R f (relabel_vars I J g P)"
+proof(rule Pring_car_induct''[of P I])
+  show "P \<in> carrier (Pring R I)"
+    using assms(2) by blast
+  show "\<And>c. c \<in> carrier R \<Longrightarrow> total_eval R (f \<circ> g) (indexed_const c) = total_eval R f (relabel_vars I J g (indexed_const c))"
+    by (metis assms(1) relabel_vars_is_morphism(3) total_eval_const)
+  show " \<And>p q. p \<in> carrier (Pring R I) \<Longrightarrow>
+           q \<in> carrier (Pring R I) \<Longrightarrow>
+           total_eval R (f \<circ> g) p = total_eval R f (relabel_vars I J g p) \<Longrightarrow>
+           total_eval R (f \<circ> g) q = total_eval R f (relabel_vars I J g q) \<Longrightarrow>
+           total_eval R (f \<circ> g) (p \<oplus>\<^bsub>Pring R I\<^esub> q) = total_eval R f (relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q))"
+
+  proof- fix p q assume A: "p \<in> carrier (Pring R I)" "q \<in> carrier (Pring R I)"
+                           "total_eval R (f \<circ> g) p = total_eval R f (relabel_vars I J g p)"
+                           "total_eval R (f \<circ> g) q = total_eval R f (relabel_vars I J g q)"
+    have 0: "closed_fun R (f \<circ> g)"
+      apply(rule closed_funI) 
+      using comp_apply[of f g] closed_fun_simp[of f] assms(3) by presburger
+    have 1: " (relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q)) = 
+               (relabel_vars I J g p) \<oplus>\<^bsub>Pring R J\<^esub> (relabel_vars I J g q)"
+      using A(1) A(2) assms(1) relabel_vars_add by blast
+    have 2: "total_eval R f (relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q)) = 
+      (total_eval R f (relabel_vars I J g p)) \<oplus>\<^bsub>R\<^esub> (total_eval R f (relabel_vars I J g q))"
+      using total_eval_add[of _ J _ f] 
+      by (metis "1" A(1) A(2) A(3) A(4) assms(1) assms(3) relabel_vars_closed)      
+    show "total_eval R (f \<circ> g) (p \<oplus>\<^bsub>Pring R I\<^esub> q) = total_eval R f (relabel_vars I J g (p \<oplus>\<^bsub>Pring R I\<^esub> q))"
+      using A 0 1 2 
+      by (metis total_eval_add)
+  qed
+  show "\<And>p i. p \<in> carrier (Pring R I) \<Longrightarrow>
+           i \<in> I \<Longrightarrow>
+           total_eval R (f \<circ> g) p = total_eval R f (relabel_vars I J g p) \<Longrightarrow>
+           total_eval R (f \<circ> g) (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i) = total_eval R f (relabel_vars I J g (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i))"
+  proof- fix p i assume A: "p \<in> carrier (Pring R I)" " i \<in> I "
+           "total_eval R (f \<circ> g) p = total_eval R f (relabel_vars I J g p)"
+    have 0: "closed_fun R (f \<circ> g)"
+            apply(rule closed_funI) 
+      using comp_apply[of f g] closed_fun_simp[of f] assms(3) by presburger
+    have 1: " (relabel_vars I J g (p \<otimes>\<^bsub>Pring R I\<^esub>  (pvar R i))) = 
+               (relabel_vars I J g p) \<otimes>\<^bsub>Pring R J\<^esub> (relabel_vars I J g (pvar R i))"
+      by (meson A(1) A(2) assms(1) local.ring_axioms relabel_vars_mult ring.Pring_var_closed)      
+    have 2: "total_eval R f (relabel_vars I J g (p \<otimes>\<^bsub>Pring R I\<^esub>  (pvar R i))) = 
+      (total_eval R f (relabel_vars I J g p)) \<otimes>\<^bsub>R\<^esub> (total_eval R f (relabel_vars I J g (pvar R i)))"
+      using total_eval_mult[of "relabel_vars I J g p" J "relabel_vars I J g (pvar R i)"]
+      by (metis "1" A(1) A(2) A(3) assms(1) assms(3) is_cring pvar_closed relabel_vars_closed)
+    have 3: " total_eval R (f \<circ> g) (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i) = 
+                total_eval R (f \<circ> g) p \<otimes>\<^bsub>R\<^esub> total_eval R (f \<circ> g)( pvar R i)"
+      by (meson "0" A(1) A(2) Pring_var_closed total_eval_mult)
+    have 4: "total_eval R (f \<circ> g)( pvar R i) = (total_eval R f (relabel_vars I J g (pvar R i)))"
+    proof- 
+      have 40: "total_eval R (f \<circ> g)( pvar R i) = (f \<circ> g) i"
+        using total_eval_var[of "f \<circ>g" i] 
+        by (metis "0" var_to_IP_def)
+      have 41: "relabel_vars I J g (pvar R i) = pvar R (g i)"
+        by (simp add: A(2) assms(1) relabel_vars_is_morphism(2))
+      have 42: "total_eval R f (relabel_vars I J g (pvar R i)) = f (g i)"
+        using total_eval_var
+        by (metis "41" assms(3) var_to_IP_def)
+      show ?thesis 
+        by (metis "40" "42" comp_apply)
+    qed
+    show " total_eval R (f \<circ> g) (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i) = 
+            total_eval R f (relabel_vars I J g (p \<otimes>\<^bsub>Pring R I\<^esub> pvar R i))"
+      using A 0 1 2 3 4
+      by presburger
+  qed
+qed
+
+end
+
+
+end
+
diff --git a/thys/Padic_Field/Fraction_Field.thy b/thys/Padic_Field/Fraction_Field.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Fraction_Field.thy
@@ -0,0 +1,1175 @@
+theory Fraction_Field
+  imports "HOL-Algebra.UnivPoly"
+          Localization_Ring.Localization
+          "HOL-Algebra.Subrings"
+          Padic_Ints.Supplementary_Ring_Facts
+begin
+
+section\<open>The Field of Fractions of a Ring\<close>
+
+text\<open>
+  This theory defines the fraction field of a domain and establishes its basic properties.
+  The fraction field is defined in the standard way as the localization of a domain at its nonzero
+  elements. This is done by importing the AFP session \texttt{Localization\_Ring}. Choice functions
+  for numerator and denominators of fractions are introduced, and the inclusion of a domain into
+  its ring of fractions is defined.
+\<close>
+
+subsection\<open>The Monoid of Nonzero Elements in a Domain\<close>
+locale domain_frac = domain
+
+lemma zero_not_in_nonzero: "\<zero>\<^bsub>R\<^esub> \<notin> nonzero R"
+  unfolding nonzero_def by blast 
+
+lemma(in domain) nonzero_is_submonoid: "submonoid R (nonzero R)"
+proof
+  show " nonzero R \<subseteq> carrier R"
+    using nonzero_def by fastforce
+  show "\<And>x y. x \<in> nonzero R \<Longrightarrow> y \<in> nonzero R \<Longrightarrow> x \<otimes> y \<in> nonzero R" 
+    by (metis (mono_tags, lifting) local.integral m_closed mem_Collect_eq nonzero_def)
+  show "\<one> \<in> nonzero R"
+    by (simp add: nonzero_def)
+qed
+
+lemma(in domain) nonzero_closed:
+  assumes "a \<in> nonzero R"
+  shows "a \<in> carrier R"
+  using assms 
+  by (simp add: nonzero_def)
+
+lemma(in domain) nonzero_mult_closed:
+  assumes "a \<in> nonzero R"
+  assumes "b \<in> nonzero R"
+  shows "a \<otimes> b \<in> carrier R"
+  using assms 
+  by (simp add: nonzero_def)
+
+lemma(in domain) nonzero_one_closed:
+"\<one> \<in> nonzero R"
+  by (simp add: nonzero_def)
+
+lemma(in domain) nonzero_memI:
+  assumes "a \<in> carrier R"
+  assumes "a \<noteq> \<zero>"
+  shows "a \<in> nonzero R"
+  using assms by(simp add: nonzero_def)
+
+lemma(in domain) nonzero_memE:
+  assumes "a \<in> nonzero R"
+  shows "a \<in> carrier R" "a \<noteq>\<zero>"
+  using assms by(auto simp: nonzero_def)
+
+lemma(in domain) not_nonzero_memE:
+  assumes "a \<notin> nonzero R"
+  assumes "a \<in> carrier R"
+  shows "a = \<zero>"
+  using assms 
+  by (simp add: nonzero_def)
+
+lemma(in domain) not_nonzero_memI:
+  assumes "a = \<zero>"
+  shows "a \<notin> nonzero R"
+  using assms nonzero_memE(2) by auto
+
+lemma(in domain) one_nonzero:
+"\<one> \<in> nonzero R"
+  by (simp add: nonzero_one_closed)
+
+lemma(in domain_frac) eq_obj_rng_of_frac_nonzero:
+  "eq_obj_rng_of_frac R (nonzero R)"
+  using nonzero_is_submonoid 
+  by (simp add: eq_obj_rng_of_frac.intro 
+      is_cring local.ring_axioms mult_submonoid_of_crng_def mult_submonoid_of_rng_def)
+
+subsection\<open>Numerator and Denominator Choice Functions\<close>
+
+definition(in eq_obj_rng_of_frac) denom where
+"denom a = (if (a = \<zero>\<^bsub>rec_rng_of_frac\<^esub>) then \<one> else ( snd (SOME x. x \<in> a)))"
+      
+text\<open>The choice function for numerators must be compatible with denom:\<close>
+
+definition(in eq_obj_rng_of_frac) numer where
+"numer a = (if (a = \<zero>\<^bsub>rec_rng_of_frac\<^esub>) then \<zero> else (fst (SOME x. x \<in> a \<and> (snd x = denom a))))"
+
+text\<open>Basic properties of numer and denom:\<close>
+lemma(in eq_obj_rng_of_frac) numer_denom_facts0:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier rec_rng_of_frac"
+  assumes "a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+  shows "a = ((numer a) |\<^bsub>rel\<^esub> (denom a))"
+        "(numer a) \<in> carrier R"
+        "(denom a) \<in> S"
+        "numer a = \<zero> \<Longrightarrow> a = \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+        "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> (rng_to_rng_of_frac(denom a)) = rng_to_rng_of_frac (numer a)"
+        "(rng_to_rng_of_frac(denom a)) \<otimes>\<^bsub>rec_rng_of_frac\<^esub> a = rng_to_rng_of_frac (numer a)"
+proof-  
+  have 0: "carrier rel \<noteq> {}" 
+     by (metis (no_types, lifting) SigmaI empty_iff one_closed partial_object.select_convs(1) rel_def zero_closed) 
+  have 1: "(numer a, denom a) \<in> a" 
+  proof-    
+   have "\<exists> r s. (r \<in> carrier R \<and> s \<in> S \<and> (a = (r |\<^bsub>rel\<^esub> s)))" 
+     using rel_def assms(3) assms(1) set_eq_class_of_rng_of_frac_def rec_rng_of_frac_def  
+     by (smt mem_Collect_eq mem_Sigma_iff partial_object.select_convs(1))     
+   then obtain r s where "r \<in> carrier R \<and> s \<in> S \<and> (a = (r |\<^bsub>rel\<^esub> s))" 
+     by blast
+   hence "a = class_of\<^bsub>rel\<^esub> (r, s)" 
+     by (simp add: class_of_to_rel)
+   hence "(r,s) \<in> a" using  eq_class_of_def rel_def  
+     using \<open>r \<in> carrier R \<and> s \<in> S \<and> a = (r |\<^bsub>rel\<^esub> s)\<close> equiv_obj_rng_of_frac equivalence.refl by fastforce
+   hence "(\<exists> x. x \<in> a)"
+     by blast 
+   hence "(SOME x. x \<in> a) \<in> a" 
+      by (meson some_eq_ex) 
+   hence "(\<exists> x. x \<in> a \<and> (snd x = denom a))" 
+      using denom_def assms  by metis 
+   hence "\<exists>x. x \<in> a \<and> (snd x = denom a) \<and> (fst x = numer a)" 
+     using numer_def assms  by (metis (mono_tags, lifting) exE_some) 
+   thus ?thesis
+    by simp 
+  qed
+  have "a \<in> {r |\<^bsub>rel\<^esub> s |r s. (r, s) \<in> carrier rel}" 
+    using assms(3) rec_rng_of_frac_def set_eq_class_of_rng_of_frac_def by auto 
+  hence "\<exists> x y. a = (x |\<^bsub>rel\<^esub> y) \<and> (x,y) \<in> carrier rel"    
+    using  rec_rng_of_frac_def  eq_class_of_rng_of_frac_def set_eq_class_of_rng_of_frac_def
+    by blast 
+  then obtain x y where "a = (x |\<^bsub>rel\<^esub> y)" and P0:"(x,y) \<in> carrier rel" 
+    by blast 
+  hence P1: "(numer a, denom a) \<in>(x |\<^bsub>rel\<^esub> y)" 
+    using "1" by blast 
+  thus 2:"a = ((numer a) |\<^bsub>rel\<^esub> (denom a))"
+  proof-
+     have P2:"(numer a, denom a) \<in> carrier rel \<and> (x, y).=\<^bsub>rel\<^esub> (numer a, denom a)  "
+      using eq_class_of_rng_of_frac_def P1 by fastforce 
+    hence "(x, y).=\<^bsub>rel\<^esub> (numer a, denom a)" 
+      by blast 
+    hence "(numer a, denom a).=\<^bsub>rel\<^esub>(x, y)"
+      using equiv_obj_rng_of_frac by (simp add: equivalence.sym P0 P2) 
+    thus ?thesis 
+      by (metis P0 P2 \<open>a = (x |\<^bsub>rel\<^esub> y)\<close> class_of_to_rel elem_eq_class equiv_obj_rng_of_frac) 
+    qed
+  have 3:"(numer a, denom a) \<in> carrier rel" 
+    using P1 by (simp add: eq_class_of_rng_of_frac_def) 
+  thus 4: "numer a \<in> carrier R" 
+    by (simp add: rel_def) 
+  show 5: "denom a \<in> S" 
+    using "3" rel_def by auto 
+  show "numer a = \<zero> \<Longrightarrow> a = \<zero>\<^bsub>rec_rng_of_frac\<^esub>" 
+  proof-
+    assume "numer a = \<zero>"
+    hence "a = (\<zero> |\<^bsub>rel\<^esub> (denom a))" 
+      using "2" by auto 
+    thus ?thesis 
+      using "5" class_of_zero_rng_of_frac by auto 
+  qed
+  show "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> rng_to_rng_of_frac (denom a) = rng_to_rng_of_frac (numer a)"
+  proof-
+    have S: "(denom a, \<one>) \<in>carrier rel" 
+      using "5" rel_def subset by auto 
+    hence "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> rng_to_rng_of_frac (denom a) = (((numer a) \<otimes> (denom a)) |\<^bsub>rel\<^esub> ((denom a) \<otimes> \<one>)) "
+      using 2 3 mult_rng_of_frac_fundamental_lemma rng_to_rng_of_frac_def 
+      rec_monoid_rng_of_frac_def rec_rng_of_frac_def by fastforce       
+    hence "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> rng_to_rng_of_frac (denom a) = (((denom a)\<otimes> (numer a)) |\<^bsub>rel\<^esub> ((denom a) \<otimes> \<one>))"
+      using "4" "5" m_comm subset by auto 
+    hence "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> rng_to_rng_of_frac (denom a) = ((denom a) |\<^bsub>rel\<^esub> (denom a)) \<otimes>\<^bsub>rec_rng_of_frac\<^esub>( (numer a) |\<^bsub>rel\<^esub> \<one>)"
+      using mult_rng_of_frac_fundamental_lemma  "4" "5" S 
+        rec_monoid_rng_of_frac_def rec_rng_of_frac_def rel_def by auto
+    thus ?thesis 
+      using "4" "5" \<open>a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> rng_to_rng_of_frac 
+      (denom a) = (denom a \<otimes> numer a |\<^bsub>rel\<^esub> denom a \<otimes> \<one>)\<close> rel_def 
+        rng_to_rng_of_frac_def simp_in_frac by auto
+  qed
+  thus "(rng_to_rng_of_frac(denom a)) \<otimes>\<^bsub>rec_rng_of_frac\<^esub> a = rng_to_rng_of_frac (numer a)"
+    by (smt "5" assms(3) cring.cring_simprules(14) crng_rng_of_frac ring_hom_closed rng_to_rng_of_frac_is_ring_hom subset subsetD)    
+qed
+
+lemma(in eq_obj_rng_of_frac) frac_zero:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier R"
+  assumes "b \<in> S"
+  assumes "(a |\<^bsub>rel\<^esub> b) = \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+  shows "a = \<zero>"
+proof-
+  have 0: "(a |\<^bsub>rel\<^esub> b) = (\<zero> |\<^bsub>rel\<^esub> \<one>)" 
+    by (simp add: assms(5) class_of_zero_rng_of_frac) 
+  have 1: "(a,b) \<in> carrier rel" 
+    by (simp add: assms(3) assms(4) rel_def) 
+  have 2: "(\<zero>, \<one>) \<in> carrier rel" 
+    by (simp add: rel_def) 
+  have 3: "(b, \<one>) \<in> carrier rel" 
+    using assms(4) rel_def subset by auto 
+  have "(a,b) .=\<^bsub>rel\<^esub> (\<zero>, \<one>)" 
+    by (metis (no_types, lifting) "0" "1" "2" eq_class_to_rel partial_object.select_convs(1) rel_def) 
+  have "(a |\<^bsub>rel\<^esub> b) \<otimes>\<^bsub>rec_rng_of_frac\<^esub> (b |\<^bsub>rel\<^esub>\<one>) = (\<zero> |\<^bsub>rel\<^esub> b)" 
+    by (metis (no_types, opaque_lifting) assms(4) assms(5) 
+       basic_trans_rules(31) class_of_zero_rng_of_frac cring.axioms(1) 
+       crng_rng_of_frac ring.ring_simprules(24) ring_hom_closed 
+       rng_to_rng_of_frac_def rng_to_rng_of_frac_is_ring_hom subset) 
+  hence 4: "((a \<otimes> b) |\<^bsub>rel\<^esub> b)  = (\<zero> |\<^bsub>rel\<^esub> b)" 
+    using "1" "3" assms(4) mult_rng_of_frac_fundamental_lemma
+      rec_monoid_rng_of_frac_def rec_rng_of_frac_def subset by auto 
+  have S: "((a \<otimes> b) , b) \<in> carrier rel" 
+      using assms(3) assms(4) rel_def subset by auto 
+  have T: "(\<zero>, b) \<in>carrier rel" 
+      by (simp add: assms(4) rel_def) 
+  hence " ((a \<otimes> b) , b).=\<^bsub>rel\<^esub> (\<zero> , b)"
+    using 4 S eq_class_to_rel rel_def by auto   
+  hence "eq rel ((a \<otimes> b) , b) (\<zero> , b)" 
+    by blast 
+  hence "\<exists>t\<in>S. t \<otimes> (b \<otimes> (a \<otimes> b) \<ominus> b \<otimes> \<zero>) = \<zero>"
+    using  rel_def by auto 
+  then obtain t where "t \<in> S" and "t \<otimes> (b \<otimes> (a \<otimes> b) \<ominus> b \<otimes> \<zero>) = \<zero>" 
+    by blast 
+  have "t \<noteq>\<zero>" 
+    using \<open>t \<in> S\<close> assms(2) by blast 
+  hence "(b \<otimes> (a \<otimes> b) \<ominus> b \<otimes> \<zero>) = \<zero>" 
+    by (meson \<open>t \<in> S\<close> \<open>t \<otimes> (b \<otimes> (a \<otimes> b) \<ominus> b \<otimes> \<zero>) = \<zero>\<close> assms(1) assms(3) 
+        assms(4) domain.integral_iff minus_closed semiring_simprules(3)
+        set_mp subset zero_closed)
+  hence "b \<otimes> (a \<otimes> b) = \<zero>" 
+    using "3" S rel_def abelian_group.minus_to_eq is_abelian_group by fastforce 
+  thus "a = \<zero>" 
+    by (metis (no_types, lifting) assms(1) assms(2) 
+        assms(3) assms(4) domain.integral_iff 
+        semiring_simprules(3) subset subsetCE) 
+qed
+
+text\<open>When S does not contain 0, and R is a domain, the localization is a domain.\<close>
+
+lemma(in eq_obj_rng_of_frac) rec_rng_of_frac_is_domain:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  shows "domain rec_rng_of_frac"
+proof(rule domainI)
+  show "cring rec_rng_of_frac" 
+   by (simp add: crng_rng_of_frac) 
+  show "\<one>\<^bsub>rec_rng_of_frac\<^esub> \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>" 
+ proof-
+    have  " \<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>" 
+      by (simp add: assms domain.one_not_zero) 
+    hence 0: " \<one>\<^bsub>R\<^esub> \<notin> (a_kernel  R  rec_rng_of_frac rng_to_rng_of_frac)"  
+      using assms(1) rng_to_rng_of_frac_without_zero_div_is_inj 
+      by (simp add: assms(2) domain_axioms_def domain_def) 
+    hence "rng_to_rng_of_frac \<one> \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>" 
+      by (simp add: a_kernel_def') 
+    thus ?thesis 
+      using ring_hom_one rng_to_rng_of_frac_is_ring_hom by blast 
+  qed 
+  show "\<And>a b. a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> b = \<zero>\<^bsub>rec_rng_of_frac\<^esub> \<Longrightarrow>
+           a \<in> carrier rec_rng_of_frac \<Longrightarrow>
+           b \<in> carrier rec_rng_of_frac \<Longrightarrow> 
+           a = \<zero>\<^bsub>rec_rng_of_frac\<^esub> \<or> b = \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+  proof-
+    fix a b
+    assume A1: "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> b = \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+    assume A2: " a \<in> carrier rec_rng_of_frac"
+    assume A3: "b \<in> carrier rec_rng_of_frac"
+    show "a = \<zero>\<^bsub>rec_rng_of_frac\<^esub> \<or> b = \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+    proof(rule disjCI)
+      assume "b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>" 
+      have "\<not> a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub> "
+      proof
+        assume "a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>"
+        have B1: "numer a \<noteq> \<zero>" 
+          using A2 \<open>a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) numer_denom_facts0(4) by blast 
+        have B2: "numer b \<noteq> \<zero>" 
+          using A3 \<open>b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) numer_denom_facts0(4) by blast 
+        have B3: "denom a \<noteq>\<zero>" 
+          using A2 \<open>a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2)
+            eq_obj_rng_of_frac.numer_denom_facts0(1) eq_obj_rng_of_frac_axioms 
+            using numer_denom_facts0(3) by force 
+        have B4: "denom b \<noteq>\<zero>" 
+          using A3 \<open>b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) 
+            eq_obj_rng_of_frac_axioms by (metis (no_types, lifting) numer_denom_facts0(3)) 
+        have "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> b = (((numer a) \<otimes> (numer b)) |\<^bsub>rel\<^esub> ((denom a) \<otimes> (denom b)))"
+        proof-
+          have S0: "a = (numer a |\<^bsub>rel\<^esub> denom a)"
+            by (simp add: A2 \<open>a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) numer_denom_facts0(1)) 
+          have S1: "b= (numer b |\<^bsub>rel\<^esub> denom b)" 
+            by (simp add: A3 \<open>b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) numer_denom_facts0(1))    
+          have S2: "(numer a, denom a) \<in> carrier rel" 
+            using A2 \<open>a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) 
+              eq_obj_rng_of_frac.numer_denom_facts0(2) eq_obj_rng_of_frac.numer_denom_facts0(3)
+              eq_obj_rng_of_frac_axioms rel_def by fastforce 
+          have S3: "(numer b, denom b) \<in> carrier rel" 
+            using A3 \<open>b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2)
+              eq_obj_rng_of_frac.numer_denom_facts0(2) eq_obj_rng_of_frac_axioms
+              numer_denom_facts0(3) rel_def by auto 
+          show ?thesis using S0 S1 S2 S3 mult_rng_of_frac_fundamental_lemma 
+            using rec_monoid_rng_of_frac_def rec_rng_of_frac_def by force 
+        qed 
+        hence "(((numer a) \<otimes> (numer b)) |\<^bsub>rel\<^esub> ((denom a) \<otimes> (denom b))) = \<zero>\<^bsub>rec_rng_of_frac\<^esub>" 
+          using A1 by blast 
+        hence "(numer a) \<otimes> (numer b) = \<zero>" 
+          by (meson A2 A3 \<open>a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> \<open>b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close>
+              assms(1) assms(2) eq_obj_rng_of_frac.numer_denom_facts0(2) 
+              eq_obj_rng_of_frac.numer_denom_facts0(3) eq_obj_rng_of_frac_axioms
+              frac_zero m_closed semiring_simprules(3))
+        thus False 
+          by (meson A2 A3 B1 B2 \<open>a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> 
+              \<open>b \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub>\<close> assms(1) assms(2) 
+              domain.integral_iff eq_obj_rng_of_frac.numer_denom_facts0(2) 
+              eq_obj_rng_of_frac_axioms)
+      qed
+      thus "a = \<zero>\<^bsub>rec_rng_of_frac\<^esub>" 
+        by auto 
+    qed
+  qed
+qed
+
+lemma(in eq_obj_rng_of_frac) numer_denom_facts:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier rec_rng_of_frac"
+  shows "a = (numer a |\<^bsub>rel\<^esub> denom a)"
+        "(numer a) \<in> carrier R"
+        "(denom a) \<in> S"
+        "a \<noteq> \<zero>\<^bsub>rec_rng_of_frac\<^esub> \<Longrightarrow> (numer a) \<noteq>\<zero>"
+        "a \<otimes>\<^bsub>rec_rng_of_frac\<^esub> (rng_to_rng_of_frac(denom a)) = rng_to_rng_of_frac (numer a)"
+        "(rng_to_rng_of_frac(denom a)) \<otimes>\<^bsub>rec_rng_of_frac\<^esub> a = rng_to_rng_of_frac (numer a)"
+  using assms(1) assms(2) assms(3) class_of_zero_rng_of_frac denom_def numer_def numer_denom_facts0(1) apply force
+    using assms(1) assms(2) assms(3) numer_def numer_denom_facts0(2) apply force
+      using assms(1) assms(2) assms(3) denom_def numer_denom_facts0(3) apply force
+        using assms(1) assms(2) assms(3) numer_denom_facts0(4) apply blast
+          apply (metis (no_types, lifting) assms(1) assms(2) assms(3) class_of_zero_rng_of_frac 
+                denom_def monoid.r_one monoid.simps(2) numer_def numer_denom_facts0(5) one_closed 
+                rec_rng_of_frac_def ringE(2) rng_rng_of_frac rng_to_rng_of_frac_def)
+            by (metis (no_types, lifting) assms(1) assms(2) assms(3) class_of_zero_rng_of_frac 
+                cring.cring_simprules(12) crng_rng_of_frac denom_def monoid.simps(2) numer_def
+                numer_denom_facts0(6) one_closed rec_rng_of_frac_def rng_to_rng_of_frac_def)
+  
+lemma(in eq_obj_rng_of_frac) numer_denom_closed:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier rec_rng_of_frac"
+  shows "(numer a, denom a) \<in> carrier rel"
+  by (simp add: assms(1) assms(2) assms(3) numer_denom_facts(2) numer_denom_facts(3) rel_def) 
+
+text\<open>Fraction function which suppresses the "rel" argument.\<close>
+
+definition(in eq_obj_rng_of_frac) fraction where
+"fraction x y = (x |\<^bsub>rel\<^esub> y)"
+
+lemma(in eq_obj_rng_of_frac) a_is_fraction:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier rec_rng_of_frac" 
+  shows "a = fraction (numer a) (denom a)"
+  by (simp add: assms(1) assms(2) assms(3) fraction_def numer_denom_facts(1))  
+
+lemma(in eq_obj_rng_of_frac) add_fraction:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier R"
+  assumes "b \<in> S"
+  assumes "c \<in> carrier R"
+  assumes "d \<in> S"
+  shows "(fraction a b) \<oplus>\<^bsub>rec_rng_of_frac\<^esub> (fraction c d) = (fraction ((a \<otimes> d) \<oplus> (b \<otimes> c)) (b \<otimes> d))"  
+proof-
+  have 0:"(a,b) \<in> carrier rel"
+    by (simp add: assms(3) assms(4) rel_def) 
+  have 1:"(c,d) \<in> carrier rel" 
+    by (simp add: assms(5) assms(6) rel_def) 
+  show ?thesis
+    using 0 1 add_rng_of_frac_fundamental_lemma assms numer_denom_facts fraction_def 
+          domain_def m_comm subset 
+    by auto      
+qed
+
+lemma(in eq_obj_rng_of_frac) mult_fraction:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier R"
+  assumes "b \<in> S"
+  assumes "c \<in> carrier R"
+  assumes "d \<in> S"
+  shows "(fraction a b) \<otimes>\<^bsub>rec_rng_of_frac\<^esub> (fraction c d) = (fraction (a \<otimes> c) (b \<otimes> d))"
+proof-
+  have 0:"(a,b) \<in> carrier rel"
+    by (simp add: assms(3) assms(4) rel_def) 
+  have 1:"(c,d) \<in> carrier rel" 
+    by (simp add: assms(5) assms(6) rel_def) 
+  show ?thesis using 0 1 mult_rng_of_frac_fundamental_lemma 
+    by (simp add: fraction_def rec_monoid_rng_of_frac_def rec_rng_of_frac_def)
+qed
+
+lemma(in eq_obj_rng_of_frac) fraction_zero:
+"\<zero>\<^bsub>rec_rng_of_frac\<^esub> = fraction \<zero> \<one> " 
+  by (simp add: class_of_zero_rng_of_frac fraction_def) 
+
+lemma(in eq_obj_rng_of_frac) fraction_zero':
+  assumes "a \<in> S"
+  assumes "\<zero> \<notin> S"
+  shows "\<zero>\<^bsub>rec_rng_of_frac\<^esub> = fraction \<zero> a" 
+  by (simp add: assms(1) class_of_zero_rng_of_frac fraction_def) 
+
+lemma(in eq_obj_rng_of_frac) fraction_one:
+"\<one>\<^bsub>rec_rng_of_frac\<^esub> = fraction \<one> \<one>"
+  by (simp add: fraction_def rec_rng_of_frac_def) 
+
+lemma(in eq_obj_rng_of_frac) fraction_one':
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> S"
+  shows "fraction a a = \<one>\<^bsub>rec_rng_of_frac\<^esub>"  
+  using assms fraction_def fraction_one one_closed simp_in_frac subset 
+  by (smt mem_Sigma_iff partial_object.select_convs(1) r_one rel_def subsetD)
+  
+lemma(in eq_obj_rng_of_frac) fraction_closed:
+  assumes "domain R"
+  assumes "\<zero> \<notin> S"
+  assumes "a \<in> carrier R"
+  assumes "b \<in> S"
+  shows "fraction a b \<in> carrier rec_rng_of_frac" 
+proof-
+  have "(a,b) \<in> carrier rel" 
+    by (simp add: assms(3) assms(4) rel_def) 
+  hence "(a |\<^bsub>rel\<^esub> b) \<in> set_class_of\<^bsub>rel\<^esub>"  
+    using  set_eq_class_of_rng_of_frac_def  
+    by blast
+  thus ?thesis using fraction_def 
+    by (simp add: rec_rng_of_frac_def) 
+qed
+
+subsection\<open>Defining the Field of Fractions\<close>
+
+definition Frac where
+"Frac R  = eq_obj_rng_of_frac.rec_rng_of_frac R (nonzero R)"
+
+lemma(in domain_frac) fraction_field_is_domain:
+"domain (Frac R)"
+  using domain_axioms eq_obj_rng_of_frac.rec_rng_of_frac_is_domain 
+    eq_obj_rng_of_frac_nonzero Frac_def 
+  by (metis nonzero_memE(2))
+
+subsubsection\<open>Numerator and Denominator Choice Functions for \texttt{domain\_frac}\<close>
+definition numerator where
+"numerator R = eq_obj_rng_of_frac.numer R (nonzero R)"
+
+abbreviation(in domain_frac)(input) numer where
+"numer \<equiv> numerator R"
+
+definition denominator where
+"denominator R = eq_obj_rng_of_frac.denom  R (nonzero R)"
+
+abbreviation(in domain_frac)(input) denom where
+"denom \<equiv> denominator R"
+
+definition fraction where
+"fraction R = eq_obj_rng_of_frac.fraction  R (nonzero R)"
+
+abbreviation(in domain_frac)(input) frac where
+"frac \<equiv> fraction R"
+
+subsubsection\<open>The inclusion of R into its fraction field\<close>
+
+definition Frac_inc where
+"Frac_inc R =  eq_obj_rng_of_frac.rng_to_rng_of_frac R (nonzero R)"
+
+abbreviation(in domain_frac)(input) inc ("\<iota>") where
+"inc \<equiv>  Frac_inc R"
+
+lemma(in domain_frac) inc_equation:
+  assumes "a \<in> carrier R"
+  shows "\<iota> a = frac a \<one>"
+  unfolding  Frac_inc_def fraction_def   
+  using assms 
+  by (simp add: eq_obj_rng_of_frac.fraction_def eq_obj_rng_of_frac.rng_to_rng_of_frac_def eq_obj_rng_of_frac_nonzero)
+
+lemma(in domain_frac) inc_is_hom:
+"inc \<in> ring_hom R (Frac R)"
+  by (simp add: eq_obj_rng_of_frac.rng_to_rng_of_frac_is_ring_hom Frac_def 
+      eq_obj_rng_of_frac_nonzero Frac_inc_def) 
+
+lemma(in domain_frac) inc_is_hom1:
+"ring_hom_ring R (Frac R) inc"
+  apply(rule ring_hom_ringI2)
+  using cring_def domain.axioms(1) fraction_field_is_domain
+  by(auto simp:inc_is_hom local.ring_axioms) 
+
+text\<open>Inclusion map is injective:\<close>
+
+lemma(in domain_frac) inc_inj0:
+"a_kernel R (Frac R) inc = {\<zero>}"
+proof-
+  have 0: "\<zero> \<notin> nonzero R" 
+    by (simp add: nonzero_def) 
+  have 1: "eq_obj_rng_of_frac R (nonzero R)" 
+    by (simp add: eq_obj_rng_of_frac_nonzero) 
+  have 2: "\<forall> a\<in> carrier R. \<forall> b\<in>carrier R. a \<otimes> b = \<zero> \<longrightarrow> a = \<zero> \<or> b = \<zero>" 
+    using local.integral by blast 
+  show ?thesis using 0 1 2  
+    by (simp add: eq_obj_rng_of_frac.rng_to_rng_of_frac_without_zero_div_is_inj
+        Frac_def Frac_inc_def) 
+qed
+
+lemma(in domain_frac) inc_inj1:
+  assumes "a \<in> carrier R"
+  assumes "inc a = \<zero>\<^bsub>Frac R\<^esub>"
+  shows "a = \<zero>"
+proof-
+  have "a \<in> a_kernel R (Frac R) inc" using  a_kernel_def' assms(2)  
+    by (simp add: a_kernel_def' assms(1)) 
+  thus ?thesis
+    using inc_inj0  by blast 
+qed
+
+lemma(in domain_frac) inc_inj2:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier R"
+  assumes "inc a = inc b"
+  shows "a = b"
+proof-
+  have "inc (a \<ominus> b) = (inc a) \<oplus>\<^bsub>Frac R\<^esub> (inc (\<ominus> b))" 
+    using inc_is_hom by (simp add: ring_hom_add assms(1) assms(2) minus_eq) 
+  hence "inc (a \<ominus> b) = \<zero>\<^bsub>Frac R\<^esub>" using assms inc_is_hom 
+    by (smt Frac_def add.inv_closed eq_obj_rng_of_frac.rng_rng_of_frac
+        eq_obj_rng_of_frac_nonzero local.ring_axioms r_neg ring_hom_add ring_hom_zero) 
+  thus ?thesis 
+    by (meson abelian_group.minus_to_eq assms(1) assms(2) domain_frac.inc_inj1 domain_frac_axioms is_abelian_group minus_closed)   
+qed
+
+text\<open>Image of inclusion map is a subring:\<close>
+
+lemma(in domain_frac) inc_im_is_subring:
+"subring (\<iota> ` (carrier R)) (Frac R)" 
+  using carrier_is_subring inc_is_hom1 ring_hom_ring.img_is_subring by blast 
+
+subsubsection\<open>Basic Properties of numer, denom, and frac\<close>
+
+lemma(in domain_frac) numer_denom_facts:
+  assumes "a \<in> carrier (Frac R)"
+  shows "a = frac (numer a) (denom a)"
+        "(numer a) \<in> carrier R"
+        "(denom a) \<in> nonzero R"
+        "a \<noteq>  \<zero>\<^bsub>Frac R\<^esub> \<Longrightarrow> numer a \<noteq> \<zero> "
+        "a \<otimes>\<^bsub>Frac R\<^esub> (inc (denom a)) = inc (numer a)"
+  unfolding fraction_def numerator_def denominator_def Frac_inc_def
+  apply (metis Frac_def assms domain_axioms eq_obj_rng_of_frac.a_is_fraction eq_obj_rng_of_frac_nonzero not_nonzero_memI)
+     apply (metis Frac_def assms domain_axioms eq_obj_rng_of_frac.numer_denom_facts(2) eq_obj_rng_of_frac_nonzero nonzero_memE(2))
+      apply (metis Frac_def assms domain_axioms eq_obj_rng_of_frac.numer_denom_facts(3) eq_obj_rng_of_frac_nonzero not_nonzero_memI)
+        apply (metis Frac_def assms domain_axioms eq_obj_rng_of_frac.numer_denom_facts0(4) eq_obj_rng_of_frac_nonzero not_nonzero_memI)
+          by (metis Frac_def assms domain_axioms eq_obj_rng_of_frac.numer_denom_facts(5) eq_obj_rng_of_frac_nonzero nonzero_memE(2))
+ 
+lemma(in domain_frac) frac_add:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> nonzero R"
+  assumes "c \<in> carrier R"
+  assumes "d \<in> nonzero R"
+  shows "(frac a b) \<oplus>\<^bsub>Frac R\<^esub> (frac c d) = (frac ((a \<otimes> d) \<oplus> (b \<otimes> c)) (b \<otimes> d))"
+  using eq_obj_rng_of_frac.add_fraction[of R "nonzero R" a b c d] 
+        eq_obj_rng_of_frac_nonzero assms zero_not_in_nonzero[of R]
+  by (simp add: Frac_def domain_axioms fraction_def)
+  
+lemma(in domain_frac) frac_mult:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> nonzero R"
+  assumes "c \<in> carrier R"
+  assumes "d \<in> nonzero R"
+  shows "(frac a b) \<otimes>\<^bsub>Frac R\<^esub> (frac c d) = (frac (a \<otimes> c) (b \<otimes> d))"
+  by (simp add: Frac_def assms(1) assms(2) assms(3) assms(4) domain_axioms 
+      eq_obj_rng_of_frac.mult_fraction eq_obj_rng_of_frac_nonzero fraction_def not_nonzero_memI)
+
+lemma(in domain_frac) frac_one:
+  assumes "a \<in> nonzero R"
+  shows "frac a a = \<one>\<^bsub>Frac R\<^esub>"
+  by (metis Frac_def assms domain_axioms eq_obj_rng_of_frac.fraction_one' eq_obj_rng_of_frac_nonzero fraction_def nonzero_memE(2))
+
+lemma(in domain_frac) frac_closed:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> nonzero R"
+  shows "frac a b \<in> carrier (Frac R)"
+  by (metis Frac_def assms(1) assms(2) domain_axioms eq_obj_rng_of_frac.fraction_closed eq_obj_rng_of_frac_nonzero fraction_def nonzero_memE(2))
+
+lemma(in domain_frac) nonzero_fraction:
+  assumes "a \<in> nonzero R"
+  assumes "b \<in> nonzero R"
+  shows "frac a b \<noteq> \<zero>\<^bsub>Frac R\<^esub>"
+proof
+  assume "frac a b = \<zero>\<^bsub>Frac R\<^esub>"
+  hence "(frac a b) \<otimes>\<^bsub>Frac R\<^esub> (frac b a) = \<zero>\<^bsub>Frac R\<^esub> \<otimes>\<^bsub>Frac R\<^esub> (frac b a)"
+    by simp 
+  hence "(frac a b) \<otimes>\<^bsub>Frac R\<^esub> (frac b a) = \<zero>\<^bsub>Frac R\<^esub>"
+    by (metis Localization.submonoid.subset assms(1) assms(2) cring.cring_simprules(26) 
+      domain.axioms(1) frac_closed fraction_field_is_domain nonzero_is_submonoid subsetCE) 
+  hence "frac (a \<otimes>b)  (b \<otimes> a)  = \<zero>\<^bsub>Frac R\<^esub>"
+    by (metis (no_types, lifting) Localization.submonoid.subset 
+        assms(1) assms(2) frac_mult nonzero_is_submonoid subsetCE) 
+  hence "frac (a \<otimes>b)  (a \<otimes> b)  = \<zero>\<^bsub>Frac R\<^esub>"
+    by (metis (no_types, lifting) Localization.submonoid.subset assms(1) assms(2) m_comm nonzero_is_submonoid subsetCE) 
+  hence "\<one>\<^bsub>Frac R\<^esub> = \<zero>\<^bsub>Frac R\<^esub>" 
+    using Localization.submonoid.m_closed assms(1) assms(2) frac_one nonzero_is_submonoid by force 
+  thus False 
+    using domain.one_not_zero fraction_field_is_domain by blast 
+qed
+
+lemma(in comm_monoid) UnitsI:
+  assumes "a \<in> carrier G"
+  assumes "b \<in> carrier G"
+  assumes "a \<otimes> b = \<one>"
+  shows "a \<in> Units G" "b \<in> Units G" 
+  unfolding Units_def using comm_monoid_axioms_def assms m_comm[of a b] 
+  by auto 
+
+lemma(in comm_monoid) is_invI:
+  assumes "a \<in> carrier G"
+  assumes "b \<in> carrier G"
+  assumes "a \<otimes> b = \<one>"
+  shows "inv\<^bsub>G\<^esub> b = a" "inv\<^bsub>G\<^esub> a = b"
+  using assms inv_char m_comm 
+  by auto
+
+lemma(in ring) ring_in_Units_imp_not_zero:
+  assumes "\<one> \<noteq> \<zero>"
+  assumes "a \<in> Units R"
+  shows "a \<noteq> \<zero>"
+  using assms monoid.Units_l_cancel
+  by (metis l_null  monoid_axioms one_closed zero_closed)
+
+lemma(in domain_frac) in_Units_imp_not_zero:
+  assumes "a \<in> Units R"
+  shows "a \<noteq> \<zero>"
+  using assms ring_in_Units_imp_not_zero domain_axioms 
+  by simp
+  
+lemma(in domain_frac) units_of_fraction_field0:
+  assumes "a \<in> carrier (Frac R)"
+  assumes "a \<noteq> \<zero>\<^bsub>Frac R\<^esub>"
+  shows "inv\<^bsub>Frac R\<^esub> a = frac (denom a) (numer a)"
+        "a\<otimes>\<^bsub>Frac R\<^esub> (inv\<^bsub>Frac R\<^esub> a)  = \<one>\<^bsub>Frac R\<^esub>"
+        "(inv\<^bsub>Frac R\<^esub> a)\<otimes>\<^bsub>Frac R\<^esub>a   = \<one>\<^bsub>Frac R\<^esub>"
+proof-
+  have 0: "a \<otimes>\<^bsub>Frac R\<^esub> (frac (denom a) (numer a)) =
+    frac ((numer a) \<otimes> (denom a)) ((numer a) \<otimes> (denom a))"     
+  proof -
+    have "denom a \<in> nonzero R"
+      by (simp add: assms(1) numer_denom_facts(3))   
+    hence "frac (numer a) (denom a) \<otimes>\<^bsub>Frac R\<^esub> frac (denom a) (numer a)
+      = frac (numer a \<otimes> denom a) (denom a \<otimes> numer a)"
+      by (simp add: assms(1) assms(2) domain_frac.numer_denom_facts(2) domain_frac_axioms frac_mult nonzero_closed nonzero_memI numer_denom_facts(4))       
+    thus ?thesis
+      using assms(1) numer_denom_facts(5)  domain_frac.numer_denom_facts(2) 
+        domain_axioms m_comm nonzero_closed numer_denom_facts(1) 
+      by (simp add: domain_frac.numer_denom_facts(2) \<open>denominator R a \<in> nonzero R\<close> domain_frac_axioms)                             
+  qed 
+  have 1:"((numer a) \<otimes> (denom a)) \<in> nonzero R"
+    by (metis assms(1) assms(2) domain_frac.numer_denom_facts(2) domain_frac_axioms 
+        local.integral m_closed nonzero_closed nonzero_memI numer_denom_facts(3) numer_denom_facts(4))           
+  have  2: "a \<otimes>\<^bsub>Frac R\<^esub> (frac (denom a) (numer a)) = \<one>\<^bsub>Frac R\<^esub>" 
+    using 0 1 frac_one by blast
+  have 3: "(frac (denom a) (numer a)) \<in> carrier (Frac R)" 
+    by (simp add: assms(1) assms(2) frac_closed nonzero_closed nonzero_memI numer_denom_facts(2) numer_denom_facts(3) numer_denom_facts(4))            
+  hence 4: "(frac (denom a) (numer a)) \<in> carrier (Frac R) \<and>
+             a \<otimes>\<^bsub>Frac R\<^esub> (frac (denom a) (numer a))  = \<one>\<^bsub>Frac R\<^esub> \<and> 
+           (frac (denom a) (numer a))  \<otimes>\<^bsub>Frac R\<^esub> a  = \<one>\<^bsub>Frac R\<^esub>"
+    by (simp add: "2" assms(1) cring.cring_simprules(14) domain.axioms(1) fraction_field_is_domain)
+  thus 5: "inv\<^bsub>Frac R\<^esub> a = frac (denom a) (numer a)"
+    using m_inv_def 2 assms(1) comm_monoid.comm_inv_char cring_def
+      domain_def fraction_field_is_domain by fastforce
+  thus 6: "a\<otimes>\<^bsub>Frac R\<^esub> (inv\<^bsub>Frac R\<^esub> a)   = \<one>\<^bsub>Frac R\<^esub>" 
+    by (simp add: "2") 
+  thus "(inv\<^bsub>Frac R\<^esub> a)\<otimes>\<^bsub>Frac R\<^esub>a   = \<one>\<^bsub>Frac R\<^esub>"
+    using assms 
+    by (simp add: "4" "5")  
+qed
+
+lemma(in domain_frac) units_of_fraction_field:
+"Units (Frac R) = carrier (Frac R) - {\<zero>\<^bsub>Frac R\<^esub>}"
+proof
+  show "Units (Frac R) \<subseteq> carrier (Frac R) - {\<zero>\<^bsub>Frac R\<^esub>}"
+  proof fix x assume A: "x \<in> Units (Frac R)"
+    have "x \<in> carrier (Frac R)" 
+      using Units_def \<open>x \<in> Units (Frac R)\<close> by force 
+    hence "x \<noteq> \<zero>\<^bsub>Frac R\<^esub>" 
+      using fraction_field_is_domain 
+      by (simp add: A domain_frac.in_Units_imp_not_zero domain_frac.intro)      
+    thus "x \<in> carrier (Frac R) - {\<zero>\<^bsub>Frac R\<^esub>}" 
+      by (simp add: \<open>x \<in> carrier (Frac R)\<close>) 
+  qed
+  show "carrier (Frac R) - {\<zero>\<^bsub>Frac R\<^esub>} \<subseteq> Units (Frac R)"
+  proof fix x assume A: "x \<in> carrier (Frac R) - {\<zero>\<^bsub>Frac R\<^esub>}"
+     show "x \<in> Units (Frac R)"
+      using comm_monoid.UnitsI(1)[of "Frac R" x "inv\<^bsub>Frac R\<^esub> x"] 
+      by (metis A Diff_iff cring.axioms(2) domain.axioms(1) domain_frac.numer_denom_facts(2)
+          domain_frac.numer_denom_facts(3) domain_frac.units_of_fraction_field0(1)
+          domain_frac.units_of_fraction_field0(2) domain_frac_axioms frac_closed 
+          fraction_field_is_domain insert_iff nonzero_closed nonzero_memI numer_denom_facts(4))     
+  qed
+qed
+
+subsection\<open>The Fraction Field as a Field\<close>
+
+lemma(in domain_frac) fraction_field_is_field:
+"field (Frac R)"
+proof(rule Ring.field.intro)
+  show "domain (Frac R)" by(auto simp: fraction_field_is_domain)
+  show "field_axioms (Frac R)"
+  proof
+    show "Units (Frac R) = carrier (Frac R) - {\<zero>\<^bsub>Frac R\<^esub>}" 
+      using units_of_fraction_field by blast 
+  qed
+qed
+
+lemma(in domain_frac) frac_inv:
+  assumes "a \<in> nonzero R"
+  assumes "b \<in> nonzero R" 
+  shows "inv\<^bsub>Frac R\<^esub> (frac a b) = (frac b a)"   
+  using cring_def[of "Frac R"] domain_def[of "Frac R"] fraction_field_is_domain 
+        frac_closed[of a b] frac_closed[of b a] nonzero_closed[of a] 
+        nonzero_closed[of b] assms comm_monoid.is_invI(2)[of "Frac R" "frac a b" "frac b a"] 
+  by (metis frac_mult frac_one integral_iff m_comm nonzero_memE(2) nonzero_memI nonzero_mult_closed)
+
+lemma(in domain_frac) frac_inv_id:
+  assumes "a \<in> nonzero R"
+  assumes "b \<in> nonzero R" 
+  assumes "c \<in> nonzero R"
+  assumes "d \<in> nonzero R" 
+  assumes "frac a b = frac c d"
+  shows "frac b a = frac d c"
+  using frac_inv assms  by metis  
+
+lemma(in domain_frac) frac_uminus:
+  assumes "a \<in> carrier  R"
+  assumes "b \<in> nonzero R"
+  shows "\<ominus>\<^bsub>Frac R\<^esub> (frac a b) = frac (\<ominus> a) b" 
+proof-
+  have "frac (\<ominus> a) b \<oplus>\<^bsub>Frac R\<^esub> (frac a b) = frac (((\<ominus> a)\<otimes>b) \<oplus> (a \<otimes>b)) (b\<otimes>b)"
+    using frac_add  by (smt Localization.submonoid.subset add.inv_closed
+        assms(1) assms(2) m_comm nonzero_is_submonoid subsetCE) 
+  hence "frac (\<ominus> a) b \<oplus>\<^bsub>Frac R\<^esub> (frac a b) = frac (b \<otimes>((\<ominus> a) \<oplus> a)) (b\<otimes>b)" 
+    by (metis (no_types, lifting) add.inv_closed  assms(1) assms(2)
+        local.ring_axioms m_comm mem_Collect_eq nonzero_def ringE(4) )
+  hence "frac (\<ominus> a) b \<oplus>\<^bsub>Frac R\<^esub> (frac a b) = (frac \<zero> (b \<otimes>b))"  
+    using Localization.submonoid.subset assms(1) assms(2) l_neg nonzero_is_submonoid by fastforce 
+  hence "frac (\<ominus> a) b \<oplus>\<^bsub>Frac R\<^esub> (frac a b) = (frac \<zero> \<one>) \<otimes>\<^bsub>Frac R\<^esub>  (frac \<zero> (b \<otimes>b))"
+    using frac_mult    by (smt Localization.submonoid.m_closed Localization.submonoid.one_closed
+        Localization.submonoid.subset assms(2) l_one nonzero_is_submonoid r_null subsetCE zero_closed) 
+  hence "frac (\<ominus> a) b \<oplus>\<^bsub>Frac R\<^esub> (frac a b) = \<zero>\<^bsub>Frac R\<^esub> \<otimes>\<^bsub>Frac R\<^esub>  (frac \<zero> (b \<otimes>b))" 
+    using Frac_def eq_obj_rng_of_frac.fraction_zero' eq_obj_rng_of_frac_nonzero 
+    by (simp add: Frac_def eq_obj_rng_of_frac.fraction_zero fraction_def)   
+  hence "frac (\<ominus> a) b \<oplus>\<^bsub>Frac R\<^esub> (frac a b) = \<zero>\<^bsub>Frac R\<^esub>"
+    using fraction_field_is_field 
+    by (simp add: Localization.submonoid.m_closed assms(2) cring.cring_simprules(26)
+        domain.axioms(1) frac_closed fraction_field_is_domain nonzero_is_submonoid)
+  thus 0: "\<ominus>\<^bsub>Frac R\<^esub> (frac a b) = frac (\<ominus> a) b" 
+    by (metis add.inv_closed assms(1) assms(2) cring.sum_zero_eq_neg
+        domain.axioms(1) frac_closed fraction_field_is_domain) 
+qed    
+
+lemma(in domain_frac) frac_eqI:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> nonzero R" 
+  assumes "c \<in> carrier R"
+  assumes "d \<in> nonzero R" 
+  assumes "a \<otimes> d \<ominus> b \<otimes> c = \<zero>"
+  shows "frac a b = frac c d"
+proof-
+ have "frac a b \<ominus>\<^bsub>Frac R\<^esub> frac c d = frac (a \<otimes> d \<ominus> b \<otimes> c) (b\<otimes>d)"
+   by (simp add: a_minus_def assms(1) assms(2) assms(3) assms(4) frac_uminus local.frac_add nonzero_closed r_minus)
+ hence "frac a b \<ominus>\<^bsub>Frac R\<^esub> frac c d = \<zero>\<^bsub>Frac R\<^esub>"
+   by (metis Frac_def assms(2) assms(4) assms(5) eq_obj_rng_of_frac.fraction_zero' 
+       eq_obj_rng_of_frac_nonzero fraction_def local.integral nonzero_memE(1) nonzero_memE(2) 
+       nonzero_memI nonzero_mult_closed)  
+  thus ?thesis 
+    by (meson assms(1) assms(2) assms(3) assms(4) field.is_ring frac_closed fraction_field_is_field ring.r_right_minus_eq) 
+qed
+
+lemma(in domain_frac) frac_eqI':
+  assumes "a \<in> carrier R"
+  assumes "b \<in> nonzero R" 
+  assumes "c \<in> carrier R"
+  assumes "d \<in> nonzero R" 
+  assumes "a \<otimes> d = b \<otimes> c"
+  shows "frac a b = frac c d"
+  using assms frac_eqI[of a b c d]
+  by (simp add: nonzero_closed)
+  
+lemma(in domain_frac) frac_cancel_l:
+  assumes "a \<in>nonzero R"
+  assumes "b \<in>nonzero R"
+  assumes "c \<in>carrier R"
+  shows "frac (a \<otimes> c) (a \<otimes> b) = frac c b" 
+proof-
+  have 0: "frac (a \<otimes>c) (a \<otimes>b) =(frac b b) \<otimes>\<^bsub>Frac R\<^esub> (frac c b)" 
+    by (metis (no_types, lifting) assms(1) assms(2) assms(3)
+        frac_mult frac_one mem_Collect_eq nonzero_def)  
+  have 1: "frac b b = \<one>\<^bsub>Frac R\<^esub>" 
+    by (simp add: assms(2) frac_one) 
+  show ?thesis using 0 1 
+    using Frac_def assms(2) assms(3) eq_obj_rng_of_frac.rng_rng_of_frac 
+      eq_obj_rng_of_frac_nonzero frac_closed ring.ring_simprules(12) 
+    by (simp add: Frac_def eq_obj_rng_of_frac.rng_rng_of_frac ring.ring_simprules(12))
+qed
+
+lemma(in domain_frac) frac_cancel_r:
+  assumes "a \<in>nonzero R"
+  assumes "b \<in>nonzero R"
+  assumes "c \<in>carrier R"
+  shows "frac (c \<otimes> a) (b \<otimes> a) = frac c b"
+  by (metis (no_types, lifting) Localization.submonoid.subset assms(1)
+      assms(2) assms(3) frac_cancel_l m_comm nonzero_is_submonoid subsetCE) 
+
+lemma(in domain_frac) frac_cancel_lr:
+  assumes "a \<in>nonzero R"
+  assumes "b \<in>nonzero R"
+  assumes "c \<in>carrier R"
+  shows "frac (a \<otimes> c) (b \<otimes> a) = frac c b"
+  by (metis (no_types, lifting) Localization.submonoid.subset assms(1)
+      assms(2) assms(3) frac_cancel_l m_comm nonzero_is_submonoid subsetCE) 
+
+lemma(in domain_frac) frac_cancel_rl:
+  assumes "a \<in>nonzero R"
+  assumes "b \<in>nonzero R"
+  assumes "c \<in>carrier R"
+  shows "frac (c \<otimes> a) (a \<otimes> b) = frac c b"
+  by (metis (no_types, lifting) Localization.submonoid.subset assms(1)
+      assms(2) assms(3) frac_cancel_l m_comm nonzero_is_submonoid subsetCE)
+
+lemma(in domain_frac) i_mult:
+  assumes "a \<in> carrier R"
+  assumes "c \<in> carrier R"
+  assumes "d \<in> nonzero R"
+  shows "(\<iota> a) \<otimes>\<^bsub>Frac R\<^esub> (frac c d) = frac (a \<otimes> c) d"
+proof-
+  have "(\<iota> a) \<otimes>\<^bsub>Frac R\<^esub> (frac c d) = (frac a \<one>) \<otimes>\<^bsub>Frac R\<^esub> (frac c d)" 
+    by (simp add: assms(1) inc_equation)
+  thus ?thesis 
+    by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) cring_simprules(12) 
+        cring_simprules(6) frac_mult local.one_not_zero mem_Collect_eq nonzero_def)
+qed
+
+lemma(in domain_frac) frac_eqE:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> nonzero R"
+  assumes "c \<in> carrier R"
+  assumes "d \<in> nonzero R"
+  assumes "frac a b = frac c d"
+  shows "a \<otimes> d = b \<otimes> c"
+proof-
+  have "(\<iota> b) \<otimes>\<^bsub>Frac R\<^esub> (frac a b) = (\<iota> b) \<otimes>\<^bsub>Frac R\<^esub> (frac c d)" 
+    by (simp add: assms(5))
+  hence "(frac (a \<otimes> b)  b) = (frac (c \<otimes> b) d)" 
+    using i_mult 
+    by (metis (no_types, lifting) Localization.submonoid.subset assms(1) 
+        assms(2) assms(3) assms(4) m_comm nonzero_is_submonoid subsetCE)
+  hence "(frac a  \<one>) = (frac (c \<otimes> b) d)"
+    by (smt assms(1) assms(2) frac_cancel_r l_one mem_Collect_eq nonzero_def one_closed zero_not_one)
+  hence "(\<iota> d) \<otimes>\<^bsub>Frac R\<^esub>(frac a  \<one>) =(\<iota> d) \<otimes>\<^bsub>Frac R\<^esub> (frac (c \<otimes> b) d)"
+    by auto
+  hence "(frac (a \<otimes> d) \<one>) =(frac ((c \<otimes> b)\<otimes> d) d)"
+    using i_mult    
+    by (smt Localization.submonoid.m_closed Localization.submonoid.subset assms(1) assms(2) assms(3)
+        assms(4) cring_simprules(27) cring_simprules(6) local.one_not_zero m_comm
+        mem_Collect_eq nonzero_def nonzero_is_submonoid)
+  hence "(frac (a \<otimes> d) \<one>) =(frac (c \<otimes> b) \<one>)" 
+    by (smt Localization.submonoid.subset assms(2) assms(3) assms(4) cring_simprules(5)
+        cring_simprules(6) frac_one i_mult inc_equation inc_is_hom nonzero_is_submonoid
+        r_one ring_hom_mult ring_hom_one subsetCE)
+  thus ?thesis using assms
+    unfolding fraction_def 
+    by (simp add: fraction_def inc_equation inc_inj2 m_comm nonzero_closed)      
+qed
+
+lemma(in domain_frac) frac_add_common_denom:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier R"
+  assumes "c \<in> nonzero R"
+  shows "(frac a c) \<oplus>\<^bsub>Frac R\<^esub> (frac b c) = frac (a \<oplus> b) c"
+proof-
+  have "(frac a c) \<oplus>\<^bsub>Frac R\<^esub> (frac b c) = frac ((a \<otimes> c) \<oplus> (b \<otimes> c)) (c \<otimes> c)"
+    using assms(1) assms(2) assms(3) domain_frac.frac_add domain_axioms frac_eqE local.frac_add 
+    by auto    
+  hence "(frac a c) \<oplus>\<^bsub>Frac R\<^esub> (frac b c) = frac ((a \<oplus> b) \<otimes> c) (c \<otimes> c)"
+    by (metis Localization.submonoid.subset assms(1) assms(2) assms(3) l_distr nonzero_is_submonoid subsetCE)
+  thus ?thesis 
+    by (simp add: assms(1) assms(2) assms(3) frac_cancel_r)
+qed
+
+lemma(in domain_frac) common_denominator:
+  assumes "x \<in> carrier (Frac R)"
+  assumes "y \<in> carrier (Frac R)"
+  obtains a b c where
+    "a \<in> carrier R"
+    "b \<in> carrier R" 
+    "c \<in> nonzero R"
+    "x = frac a c"
+    "y = frac b c"
+proof-
+  obtain x1 x2 where X1: "x1 \<in> carrier R" and X2: "x2 \<in> nonzero R" and Fx: "x = frac x1 x2"
+    by (meson assms(1) numer_denom_facts(1) numer_denom_facts(2) numer_denom_facts(3))   
+  obtain y1 y2 where Y1: "y1 \<in> carrier R" and Y2: "y2 \<in> nonzero R" and Fy: "y = frac y1 y2"
+    by (meson assms(2) numer_denom_facts(1) numer_denom_facts(2) numer_denom_facts(3))  
+  let ?a = "x1 \<otimes> y2"
+  let ?b = "y1 \<otimes> x2"
+  let ?c = "x2 \<otimes> y2"
+  have 0: "?a \<in> carrier R" 
+    using X1 Y2  by (simp add: nonzero_def)
+  have 1: "?b \<in> carrier R" using Y1 X2 
+    by (simp add: nonzero_def)
+  have 2: "?c \<in> nonzero R" using X2 Y2 
+    by (simp add: Localization.submonoid.m_closed nonzero_is_submonoid)
+  have 3: "x = frac ?a ?c" 
+    using Fx X1 X2 Y2 frac_cancel_r by auto
+  have 4: "y = frac ?b ?c" 
+    using Fy X2 Y1 Y2 frac_cancel_rl by auto
+  thus ?thesis using 0 1 2 3 4 
+    using that by blast
+qed
+
+sublocale  domain_frac < F: field "Frac R"
+  by (simp add: fraction_field_is_field)
+
+text\<open>Inclusions of natural numbers into \texttt{(Frac R)}:\<close>
+
+lemma(in domain_frac) nat_0:
+"[(0::nat)]\<cdot>\<one> = \<zero>"
+  by simp
+
+lemma(in domain_frac) nat_suc:
+"[Suc n]\<cdot>\<one> = \<one> \<oplus> [n]\<cdot>\<one>"
+  using add.nat_pow_Suc2 by auto
+
+lemma(in domain_frac) nat_inc_rep:
+  fixes n::nat
+  shows "[n]\<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub> = frac ([n]\<cdot>\<one>) \<one>"
+proof(induction n)
+  case 0
+  have "[(0::nat)] \<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub> = \<zero>\<^bsub>Frac R\<^esub>"
+    using fraction_field_is_domain 
+    by (simp add: domain_frac.intro domain_frac.nat_0)
+  thus ?case 
+    by (simp add: Frac_def eq_obj_rng_of_frac.fraction_zero eq_obj_rng_of_frac_nonzero fraction_def)    
+next
+  case (Suc n)
+  assume A:  "[n] \<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub> = frac ([n] \<cdot> \<one>) \<one>"
+  have "[Suc n] \<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub> = \<one>\<^bsub>Frac R\<^esub> \<oplus>\<^bsub>Frac R\<^esub> [n] \<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub>" 
+    using F.add.nat_pow_Suc2 by auto    
+  hence "[Suc n] \<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub> = (frac \<one> \<one>) \<oplus>\<^bsub>Frac R\<^esub> (frac ([n] \<cdot> \<one>) \<one>)"
+    by (simp add: Suc.IH frac_one nonzero_def)
+  hence "[Suc n] \<cdot>\<^bsub>Frac R\<^esub> \<one>\<^bsub>Frac R\<^esub> = (frac (\<one>\<oplus>[n] \<cdot> \<one>) \<one>)"
+    by (simp add: frac_add_common_denom nonzero_def)
+  thus ?case 
+    using nat_suc by auto
+qed
+
+lemma(in domain_frac) pow_0:
+  assumes "a \<in> nonzero R"
+  shows "a[^](0::nat) = \<one>"
+  by simp
+
+lemma(in domain_frac) pow_suc:
+  assumes "a \<in> carrier R"
+  shows "a[^](Suc n) = a \<otimes>(a[^]n)"
+  using assms nat_pow_Suc2 by auto
+
+lemma(in domain_frac) nat_inc_add:
+"[((n::nat) + (m::nat))]\<cdot>\<one> = [n]\<cdot>\<one> \<oplus> [m]\<cdot>\<one>"
+  using domain_def add_pow_def 
+  by (simp add: add.nat_pow_mult)
+  
+lemma(in domain_frac) int_inc_add:
+"[((n::int) + (m::int))]\<cdot>\<one> = [n]\<cdot>\<one> \<oplus> [m]\<cdot>\<one>"
+  using domain_def add_pow_def 
+  by (simp add: add.int_pow_mult)
+
+lemma(in domain_frac) nat_inc_mult:
+"[((n::nat) * (m::nat))]\<cdot>\<one> = [n]\<cdot>\<one> \<otimes> [m]\<cdot>\<one>"
+  using domain_def add_pow_def 
+  by (simp add: Groups.mult_ac(2) add.nat_pow_pow add_pow_ldistr)
+
+lemma(in domain_frac) int_inc_mult:
+"[((n::int) * (m::int))]\<cdot>\<one> = [n]\<cdot>\<one> \<otimes> [m]\<cdot>\<one>"
+  using domain_def add_pow_def 
+  by (simp add: Groups.mult_ac(2) add.int_pow_pow add_pow_ldistr_int)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Facts About Ring Units\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma(in ring) Units_nonzero:
+  assumes "u \<in> Units R"
+  assumes "\<one>\<^bsub>R\<^esub> \<noteq> \<zero>\<^bsub>R\<^esub>"
+  shows "u \<in> nonzero R"
+proof-
+  have "u \<in>carrier R" 
+    using Units_closed assms by auto
+  have "u \<noteq>\<zero>" 
+    using Units_r_inv_ex assms(1) assms(2) 
+    by force 
+  thus ?thesis 
+    by (simp add: \<open>u \<in> carrier R\<close> nonzero_def)
+qed
+
+lemma(in ring) Units_inverse:
+  assumes "u \<in> Units R"
+  shows "inv u \<in> Units R"
+  by (simp add: assms)
+
+lemma(in cring) invI:  
+  assumes "x \<in> carrier R"
+  assumes "y \<in> carrier R"
+  assumes "x \<otimes>\<^bsub>R\<^esub> y = \<one>\<^bsub>R\<^esub>"
+  shows "y = inv \<^bsub>R\<^esub> x"
+        "x = inv \<^bsub>R\<^esub> y"
+  using assms(1) assms(2) assms(3) is_invI 
+  by auto 
+
+lemma(in cring) inv_cancelR:
+  assumes "x \<in> Units R"
+  assumes "y \<in> carrier R"
+  assumes "z \<in> carrier R"
+  assumes "y = x \<otimes>\<^bsub>R\<^esub> z"
+  shows "inv\<^bsub>R\<^esub> x \<otimes>\<^bsub>R\<^esub> y = z"
+        "y \<otimes>\<^bsub>R\<^esub> (inv\<^bsub>R\<^esub> x)  = z"
+  apply (metis Units_closed assms(1) assms(3) assms(4) cring.cring_simprules(12) 
+    is_cring m_assoc monoid.Units_inv_closed monoid.Units_l_inv monoid_axioms)
+  by (metis Units_closed assms(1) assms(3) assms(4) m_assoc m_comm monoid.Units_inv_closed 
+      monoid.Units_r_inv monoid.r_one monoid_axioms)
+   
+lemma(in cring) inv_cancelL:
+  assumes "x \<in> Units R"
+  assumes "y \<in> carrier R"
+  assumes "z \<in> carrier R"
+  assumes "y = z \<otimes>\<^bsub>R\<^esub> x"
+  shows "inv\<^bsub>R\<^esub> x \<otimes>\<^bsub>R\<^esub> y = z"
+        "y \<otimes>\<^bsub>R\<^esub> (inv\<^bsub>R\<^esub> x)  = z"
+  apply (simp add: Units_closed assms(1) assms(3) assms(4) m_lcomm)
+  by (simp add: Units_closed assms(1) assms(3) assms(4) m_assoc)
+
+lemma(in domain_frac) nat_pow_nonzero:
+  assumes "x \<in>nonzero R"
+  shows "x[^](n::nat) \<in> nonzero R"
+  unfolding nonzero_def 
+  apply(induction n)
+  using assms integral_iff nonzero_closed zero_not_in_nonzero by auto
+
+lemma(in monoid) Units_int_pow_closed:
+  assumes "x \<in> Units G"
+  shows "x[^](n::int) \<in> Units G"
+  by (metis Units_pow_closed assms int_pow_def2 monoid.Units_inv_Units monoid_axioms)
+
+subsection\<open>Facts About Fraction Field Units\<close>
+
+lemma(in domain_frac) frac_nonzero_Units:
+"nonzero (Frac R) = Units (Frac R)"
+  unfolding nonzero_def using F.field_Units 
+  by blast 
+
+lemma(in domain_frac) frac_nonzero_inv_Unit:
+  assumes "b \<in> nonzero (Frac R)"
+  shows "inv\<^bsub>Frac R\<^esub> b \<in> Units (Frac R)"
+  using assms frac_nonzero_Units
+  by simp
+
+lemma(in domain_frac) frac_nonzero_inv_closed:
+  assumes "b \<in> nonzero (Frac R)"
+  shows "inv\<^bsub>Frac R\<^esub> b \<in> carrier (Frac R)"
+  using  frac_nonzero_inv_Unit 
+  by (simp add: Units_def assms)
+
+lemma(in domain_frac) frac_nonzero_inv:
+  assumes "b \<in> nonzero (Frac R)"
+  shows "b \<otimes>\<^bsub>Frac R\<^esub> inv \<^bsub>Frac R\<^esub> b = \<one>\<^bsub>Frac R\<^esub>"
+        "inv \<^bsub>Frac R\<^esub> b \<otimes>\<^bsub>Frac R\<^esub> b = \<one>\<^bsub>Frac R\<^esub>"
+  using frac_nonzero_Units assms by auto  
+
+lemma(in domain_frac) fract_cancel_right[simp]:
+  assumes "a \<in> carrier (Frac R)"
+  assumes "b \<in> nonzero (Frac R)"
+  shows "b \<otimes>\<^bsub>Frac R\<^esub> (a \<otimes>\<^bsub>Frac R\<^esub> inv\<^bsub>Frac R\<^esub> b) = a"
+  by (metis F.Units_inv_inv F.inv_cancelL(1) F.m_closed assms(1) assms(2) frac_nonzero_Units frac_nonzero_inv_Unit frac_nonzero_inv_closed)
+
+lemma(in domain_frac) fract_cancel_left[simp]:
+  assumes "a \<in> carrier (Frac R)"
+  assumes "b \<in> nonzero (Frac R)"
+  shows "(a \<otimes>\<^bsub>Frac R\<^esub> inv\<^bsub>Frac R\<^esub> b) \<otimes>\<^bsub>Frac R\<^esub> b = a"
+  by (metis Diff_iff assms(1) assms(2) cring.cring_simprules(14) cring.cring_simprules(5) 
+      domain.axioms(1) frac_nonzero_Units frac_nonzero_inv_closed fract_cancel_right 
+      fraction_field_is_domain units_of_fraction_field)
+  
+lemma(in domain_frac) fract_mult_inv:
+  assumes "b \<in> nonzero (Frac R)"
+  assumes "d \<in> nonzero (Frac R)"
+  shows "(inv\<^bsub>Frac R\<^esub> b) \<otimes>\<^bsub>Frac R\<^esub> (inv\<^bsub>Frac R\<^esub> d) = (inv\<^bsub>Frac R\<^esub> (b \<otimes>\<^bsub>Frac R\<^esub>d))"
+  by (metis F.Units_inv_closed F.Units_m_closed F.inv_cancelR(2) F.nonzero_closed assms(1) assms(2) frac_nonzero_Units)
+
+lemma(in domain_frac) fract_mult:
+  assumes "a \<in> carrier (Frac R)"
+  assumes "b \<in> nonzero (Frac R)"
+  assumes "c \<in> carrier (Frac R)"
+  assumes "d \<in> nonzero (Frac R)"
+  shows  "(a \<otimes>\<^bsub>Frac R\<^esub> inv\<^bsub>Frac R\<^esub> b) \<otimes>\<^bsub>Frac R\<^esub> (c \<otimes>\<^bsub>Frac R\<^esub> inv\<^bsub>Frac R\<^esub> d) = ((a \<otimes>\<^bsub>Frac R\<^esub> c)\<otimes>\<^bsub>Frac R\<^esub> inv\<^bsub>Frac R\<^esub> (b \<otimes>\<^bsub>Frac R\<^esub>d))"
+  using F.m_assoc F.m_lcomm assms(1) assms(2) assms(3) assms(4) frac_nonzero_Units fract_mult_inv by auto
+
+lemma(in domain_frac) Frac_nat_pow_nonzero:
+  assumes "x \<in> nonzero (Frac R)"
+  shows "x[^]\<^bsub>Frac R\<^esub>(n::nat) \<in> nonzero (Frac R)"
+  by (simp add: assms domain_frac.intro domain_frac.nat_pow_nonzero fraction_field_is_domain)
+  
+lemma(in domain_frac) Frac_nonzero_nat_pow:
+  assumes "x \<in> carrier (Frac R)"
+  assumes "n > 0"
+  assumes "x[^]\<^bsub>Frac R\<^esub>(n::nat) \<in> nonzero (Frac R)"
+  shows "x \<in> nonzero (Frac R)"
+proof(rule ccontr)
+  assume "x \<notin> nonzero (Frac R)"
+  hence 0: "x = \<zero>\<^bsub>Frac R\<^esub>"
+    by (simp add: assms(1) nonzero_def) 
+  have "x[^]\<^bsub>Frac R\<^esub>(n::nat) = \<zero>\<^bsub>Frac R\<^esub>"
+  proof-
+    obtain k where "n = Suc k"
+      using assms(2) lessE by blast
+    hence 00: "x[^]\<^bsub>Frac R\<^esub>(n::nat) = x[^]\<^bsub>Frac R\<^esub>k \<otimes>\<^bsub>Frac R\<^esub> x"
+      by simp
+    have "x[^]\<^bsub>Frac R\<^esub>k \<in> carrier (Frac R)"
+      using assms monoid.nat_pow_closed[of "Frac R" x k] 
+      by (meson field.is_ring fraction_field_is_field ring_def)   
+    thus ?thesis using 0 assms 
+      using "00" cring.cring_simprules(27) domain.axioms(1) fraction_field_is_domain by fastforce      
+  qed
+  thus False 
+    using "0" \<open>x \<notin> nonzero (Frac R)\<close> assms(3) by auto 
+qed
+  
+lemma(in domain_frac) Frac_int_pow_nonzero:
+  assumes "x \<in> nonzero (Frac R)"
+  shows "x[^]\<^bsub>Frac R\<^esub>(n::int) \<in> nonzero (Frac R)"
+  using assms field.is_ring frac_nonzero_Units fraction_field_is_field monoid.Units_pow_closed[of "Frac R" x]
+  by (simp add: field.is_ring monoid.Units_int_pow_closed ring.is_monoid)
+
+lemma(in domain_frac) Frac_nonzero_int_pow:
+  assumes "x \<in> carrier (Frac R)"
+  assumes "n > 0"
+  assumes "x[^]\<^bsub>Frac R\<^esub>(n::int) \<in> nonzero (Frac R)"
+  shows "x \<in> nonzero (Frac R)"
+  by (metis (mono_tags, opaque_lifting) Frac_nonzero_nat_pow assms  int_pow_int pos_int_cases)
+
+lemma(in domain_frac) numer_denom_frac[simp]:
+  assumes "a \<in> nonzero R"
+  assumes "b \<in> nonzero R"
+  shows "frac (numer (frac a b)) (denom (frac a b)) = frac a b"
+  using assms(1) assms(2) domain_frac.numer_denom_facts(1) 
+domain_axioms frac_closed nonzero_closed numer_denom_facts(1) by auto
+  
+lemma(in domain_frac) numer_denom_swap:
+  assumes "a \<in> nonzero R"
+  assumes "b \<in> nonzero R"
+  shows "a \<otimes> (denom (frac a b)) = b \<otimes> (numer (frac a b))"
+  using numer_denom_frac[of a b] assms 
+  by (simp add: frac_closed frac_eqE nonzero_closed numer_denom_facts(2) numer_denom_facts(3))
+    
+lemma(in domain_frac) numer_nonzero:
+  assumes "a \<in> nonzero (Frac R)"
+  shows "numer a \<in> nonzero R"
+  using assms  numer_denom_facts(4)[of a] zero_not_in_nonzero[of R]
+  by (simp add: frac_nonzero_Units nonzero_memI numer_denom_facts(2) units_of_fraction_field)
+
+lemma(in domain_frac) fraction_zero[simp]:
+  assumes "b \<in> nonzero R"
+  shows "frac \<zero> b = \<zero>\<^bsub>Frac R\<^esub>"
+  by (metis Frac_def assms eq_obj_rng_of_frac.fraction_zero' eq_obj_rng_of_frac_nonzero fraction_def nonzero_memE(2))
+
+end
diff --git a/thys/Padic_Field/Generated_Boolean_Algebra.thy b/thys/Padic_Field/Generated_Boolean_Algebra.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Generated_Boolean_Algebra.thy
@@ -0,0 +1,1388 @@
+theory Generated_Boolean_Algebra
+  imports Main 
+begin 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Generated Boolean Algebras of Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Definitions and Basic Lemmas\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+lemma equalityI':
+  assumes "\<And>x. x \<in> A \<Longrightarrow> x \<in> B"
+  assumes "\<And>x. x \<in> B \<Longrightarrow> x \<in> A"
+  shows "A = B"
+  using assms by blast
+
+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 SomeE:
+  assumes "a = (SOME x. P x)"
+  assumes "P c"
+  shows "P a"
+  using assms  by (meson verit_sko_ex)
+
+lemma SomeE':
+  assumes "a = (SOME x. P x)"
+  assumes "\<exists> x. P x"
+  shows "P a"
+  using assms  by (meson verit_sko_ex)
+
+section\<open>Basic notions about boolean algebras over a set \<open>S\<close>, generated by a set of generators \<open>B\<close>\<close>
+
+text\<open>Note that the generators \<open>B\<close> need not be subsets of the set \<open>S\<close>\<close>
+
+inductive_set gen_boolean_algebra 
+  for S and B  where
+    universe: "S \<in> gen_boolean_algebra S B"
+  | generator:  "A \<in> B \<Longrightarrow> A \<inter> S \<in> gen_boolean_algebra S B"
+  | union:      "\<lbrakk> A \<in> gen_boolean_algebra S B; C \<in> gen_boolean_algebra S B\<rbrakk> \<Longrightarrow> A \<union> C \<in> gen_boolean_algebra S B"
+  | complement: "A \<in> gen_boolean_algebra S B \<Longrightarrow> S - A \<in> gen_boolean_algebra S B"
+
+lemma gen_boolean_algebra_subset:
+  shows "A \<in> gen_boolean_algebra S B \<Longrightarrow> A \<subseteq> S"
+  apply(induction A rule: gen_boolean_algebra.induct)
+  apply blast
+  apply blast
+  apply blast
+  by blast
+
+lemma gen_boolean_algebra_intersect:
+  assumes "A \<in> gen_boolean_algebra S B"
+  assumes "C \<in> gen_boolean_algebra S B"
+  shows "A \<inter> C \<in> gen_boolean_algebra S B"
+proof-
+  have 0: "S - A \<in> gen_boolean_algebra S B"
+    using assms(1) gen_boolean_algebra.complement by blast
+  have 1: "S - C \<in> gen_boolean_algebra S B"
+    using assms(2) gen_boolean_algebra.complement by blast
+  have 2: "(S - A) \<union> (S - C) \<in> gen_boolean_algebra S B"
+    using "0" "1" gen_boolean_algebra.union by blast
+  have "S - (A \<inter> C) \<in> gen_boolean_algebra S B"
+    by (simp add: 2 Diff_Int)
+  then have 3: "S - (S - (A \<inter> C)) \<in> gen_boolean_algebra S B"
+    using gen_boolean_algebra.complement 
+    by blast
+  have "A \<inter> C \<subseteq> S"
+    using assms(1) gen_boolean_algebra_subset
+    by blast
+  then show ?thesis 
+    using 3 
+    by (metis "0" Diff_partition Un_subset_iff assms(1) double_diff gen_boolean_algebra_subset)
+qed
+
+lemma gen_boolean_algebra_diff:
+  assumes "A \<in> gen_boolean_algebra S B"
+  assumes "C \<in> gen_boolean_algebra S B"
+  shows "A -  C \<in> gen_boolean_algebra S B"
+proof-
+  have "A - C = A \<inter> (S - C)"
+    by (metis Int_Diff assms(1) gen_boolean_algebra_subset inf_absorb1)
+  then show ?thesis 
+    by (metis assms(1) assms(2) gen_boolean_algebra.complement gen_boolean_algebra_intersect)
+qed
+
+lemma gen_boolean_algebra_diff_eq:
+  assumes "A \<in> gen_boolean_algebra S B"
+  assumes "C \<in> gen_boolean_algebra S B"
+  shows "A -  C = A \<inter> (S - C)"
+  by (metis Int_Diff assms(1) gen_boolean_algebra_subset inf_absorb1)
+
+lemma gen_boolean_algebra_finite_union:
+  assumes "\<And>a. a \<in> A \<Longrightarrow> a \<in> gen_boolean_algebra S B"
+  assumes "finite A"
+  shows "\<Union>A \<in> gen_boolean_algebra S B"
+proof-
+  have "(\<forall>a \<in> A. a \<in> gen_boolean_algebra S B) \<longrightarrow> \<Union>A \<in> gen_boolean_algebra S B"
+  apply(rule finite.induct[of A])
+  apply (simp add: assms(2); fail)
+   apply (metis DiffE Union_empty ex_in_conv  gen_boolean_algebra.simps)
+  by (metis Union_insert gen_boolean_algebra.simps insert_iff)
+  then show ?thesis using assms by blast 
+qed
+  
+lemma gen_boolean_algebra_finite_intersection:
+  assumes "\<And>a. a \<in> A \<Longrightarrow> a \<in> gen_boolean_algebra S B"
+  assumes "finite A"
+  assumes "A \<noteq> {}"
+  shows "\<Inter>A \<in> gen_boolean_algebra S B"
+proof-
+  have "(\<forall>a \<in> A. a \<in> gen_boolean_algebra S B) \<and> A \<noteq> {} \<longrightarrow> \<Inter>A \<in> gen_boolean_algebra S B"
+  apply(rule finite.induct[of A])
+  apply (simp add: assms(2))
+    apply force
+  using gen_boolean_algebra_intersect by auto
+  then show ?thesis using assms by blast 
+qed
+
+lemma gen_boolean_algebra_generators:
+  assumes "\<And>b. b \<in> B \<Longrightarrow> b \<subseteq> S"
+  assumes "b \<in> B"
+  shows "b \<in> gen_boolean_algebra S B"
+  unfolding gen_boolean_algebra.simps[of b] using assms(1)[of b] assms(2)  by blast 
+
+lemma gen_boolean_algebra_generator_subset:
+  assumes "A \<in> gen_boolean_algebra S As"
+  assumes "As \<subseteq> Bs"
+  shows "A \<in> gen_boolean_algebra S Bs"
+  apply(rule gen_boolean_algebra.induct[of A S As])
+  using assms(1) apply blast
+  apply (simp add: gen_boolean_algebra.intros(1); fail)
+  apply (meson Set.basic_monos(7) assms(2) gen_boolean_algebra.intros(2))
+  using gen_boolean_algebra.intros(3) apply blast
+  using gen_boolean_algebra.intros(4) by blast
+
+lemma gen_boolean_algebra_generators_union:
+  assumes "A \<in> gen_boolean_algebra S As"
+  assumes "C \<in> gen_boolean_algebra S Cs"
+  shows "A \<union> C \<in> gen_boolean_algebra S (As \<union> Cs)"
+  apply(rule gen_boolean_algebra.induct[of C S Cs])
+  using assms apply blast
+apply(rule gen_boolean_algebra.union)
+      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
+     apply(rule gen_boolean_algebra.universe)
+    apply(rule gen_boolean_algebra.union)
+      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
+    apply(rule gen_boolean_algebra.generator, blast)
+    apply(rule gen_boolean_algebra.union)
+      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
+    apply(rule gen_boolean_algebra.union)
+            apply(rule gen_boolean_algebra_generator_subset[of _ _  Cs], blast, blast)
+            apply(rule gen_boolean_algebra_generator_subset[of _ _  Cs], blast, blast)
+    apply(rule gen_boolean_algebra.union)
+      apply(rule gen_boolean_algebra_generator_subset[of _ _  As], rule assms, blast)
+      apply(rule gen_boolean_algebra_generator_subset[of _ _  Cs])
+   apply(rule gen_boolean_algebra_diff)
+     apply(rule gen_boolean_algebra.universe)
+  apply blast
+by blast 
+
+lemma gen_boolean_algebra_finite_gen_wits:
+  assumes "A \<in> gen_boolean_algebra S B"
+  shows "\<exists> Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs"
+proof(rule gen_boolean_algebra.induct[of A S B])
+  show " A \<in> gen_boolean_algebra S B"
+    using assms by blast 
+  show "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> S \<in> gen_boolean_algebra S Bs"
+    using gen_boolean_algebra.universe[of S "{}"]
+    by blast 
+  show "\<And>A. A \<in> B \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<inter> S \<in> gen_boolean_algebra S Bs"
+  proof- fix A assume A: "A \<in> B"
+    have 0: "{A} \<subseteq> B"
+      using A by blast 
+    show "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<inter> S \<in> gen_boolean_algebra S Bs"
+      using gen_boolean_algebra.generator[of A "{A}" S] 0 
+      by (meson finite.emptyI finite.insertI singletonI)
+  qed
+  show "\<And>A C. A \<in> gen_boolean_algebra S B \<Longrightarrow>
+           \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs \<Longrightarrow>
+           C \<in> gen_boolean_algebra S B \<Longrightarrow>
+           \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> C \<in> gen_boolean_algebra S Bs \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<union> C \<in> gen_boolean_algebra S Bs"
+  proof- fix A C 
+    assume A: "A \<in> gen_boolean_algebra S B"
+           "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs"
+           "C \<in> gen_boolean_algebra S B"
+           "\<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> C \<in> gen_boolean_algebra S Bs"
+    obtain As where As_def: "finite As \<and> As \<subseteq> B \<and> A \<in> gen_boolean_algebra S As"
+      using A by blast 
+    obtain Cs where Cs_def: "finite Cs \<and> Cs \<subseteq> B \<and> C \<in> gen_boolean_algebra S Cs"
+      using A by blast 
+    obtain Bs where Bs_def: "Bs = As \<union> Cs"
+      by blast 
+    have Bs_sub: "Bs \<subseteq> B"
+      unfolding Bs_def using As_def Cs_def by blast 
+    have 0: " A \<union> C \<in> gen_boolean_algebra S Bs"
+      unfolding Bs_def
+      apply(rule gen_boolean_algebra_generators_union)
+      using As_def apply blast
+      using Cs_def by blast
+    have 1: "finite Bs"
+      unfolding Bs_def using As_def Cs_def by blast 
+    show " \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<union> C \<in> gen_boolean_algebra S Bs"
+      using Bs_sub 0 1 by blast 
+  qed
+  show "\<And>A. A \<in> gen_boolean_algebra S B \<Longrightarrow>
+         \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> A \<in> gen_boolean_algebra S Bs \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs \<subseteq> B \<and> S - A \<in> gen_boolean_algebra S Bs"
+    using gen_boolean_algebra.complement by blast 
+qed
+
+lemma gen_boolean_algebra_univ_mono:
+  assumes "A \<in>  gen_boolean_algebra S B"
+  shows "gen_boolean_algebra A B \<subseteq> gen_boolean_algebra S B "
+proof(rule subsetI) fix x assume A: "x \<in> gen_boolean_algebra A B"
+  obtain a where a_def: "a = A"
+    by blast 
+  have 0: "a \<in> gen_boolean_algebra S B"
+    unfolding a_def using assms by blast 
+  have 1: "a = A \<inter> S"
+    using assms gen_boolean_algebra_subset unfolding a_def by blast 
+  show "x \<in> gen_boolean_algebra S B " 
+    apply(rule gen_boolean_algebra.induct[of x a B])
+    using A a_def apply blast apply(rule 0)
+    apply (metis 1 Int_left_commute assms gen_boolean_algebra.intros(2) gen_boolean_algebra_intersect)
+     apply(rule gen_boolean_algebra.union, blast, blast)
+    apply(rule gen_boolean_algebra_diff)
+     apply(rule 0)
+    by blast 
+qed
+
+text\<open>
+  The boolean algebra generated by a collection of elements in another algebra is contained
+  in the original algebra:
+\<close>
+lemma gen_boolean_algebra_subalgebra:
+  assumes "Xs \<subseteq> gen_boolean_algebra S B"
+  shows "gen_boolean_algebra S Xs \<subseteq> gen_boolean_algebra S B"
+proof fix x assume A: "x \<in> gen_boolean_algebra S Xs"
+  show "x \<in> gen_boolean_algebra S B "
+    apply(rule gen_boolean_algebra.induct[of x S Xs])
+        apply (simp add: A; fail)
+       apply (simp add: gen_boolean_algebra.universe; fail)
+    using assms gen_boolean_algebra.universe gen_boolean_algebra_intersect apply blast
+  apply (simp add: gen_boolean_algebra.union; fail)
+  by (simp add: gen_boolean_algebra.complement)
+qed 
+
+lemma gen_boolean_algebra_idempotent:
+  assumes "S = \<Union> Xs"
+  shows "gen_boolean_algebra S (gen_boolean_algebra S Xs) = (gen_boolean_algebra S Xs)"
+  apply(rule equalityI)
+   apply(rule subsetI)
+  apply (meson equalityD2 gen_boolean_algebra_subalgebra in_mono)
+   apply(rule subsetI)
+  by (metis gen_boolean_algebra.simps gen_boolean_algebra_subset inf.absorb1)
+
+text\<open>We can always replace the set of generators \<open>Xs\<close> with their intersections with the universe 
+  set \<open>S\<close>, and obtain the same algebra.\<close>
+
+lemma gen_boolean_algebra_restrict_generators: 
+"gen_boolean_algebra S Xs =gen_boolean_algebra S ((\<inter>) S ` Xs)"
+proof(rule equalityI')
+  fix x assume A: "x \<in> gen_boolean_algebra S Xs"
+  show "x \<in> gen_boolean_algebra S ((\<inter>) S ` Xs)"
+    apply(rule gen_boolean_algebra.induct[of x S Xs], rule A, rule gen_boolean_algebra.universe) 
+    apply (metis gen_boolean_algebra.generator image_eqI inf.right_idem inf_commute)
+     apply(rule gen_boolean_algebra.union, blast, blast)
+    by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
+next 
+  fix x assume A: "x \<in> gen_boolean_algebra S ((\<inter>) S ` Xs)"
+  show "x \<in> gen_boolean_algebra S Xs"
+    apply(rule gen_boolean_algebra.induct[of x S "(\<inter>) S ` Xs"], rule A, rule gen_boolean_algebra.universe,
+       rule gen_boolean_algebra_intersect )
+    using gen_boolean_algebra.generator[of _ Xs S] 
+       apply (metis (no_types, lifting) Int_commute image_iff)
+      apply(rule gen_boolean_algebra.universe)
+     apply(rule gen_boolean_algebra.union, blast, blast)
+    by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
+qed
+
+text\<open>Adding a generator to a generated boolean algebra is redundant if the generator already
+      lies in the algebra.\<close>
+
+lemma add_generators:
+  assumes "A \<in> gen_boolean_algebra S Xs"
+  shows "gen_boolean_algebra S Xs = gen_boolean_algebra S (insert A Xs)"
+proof(rule equalityI')
+  fix x assume A: "x \<in> gen_boolean_algebra S Xs"
+  show "x \<in> gen_boolean_algebra S (insert A Xs)"
+    apply(rule gen_boolean_algebra.induct[of x S Xs], rule A, rule gen_boolean_algebra.universe)
+      apply(rule gen_boolean_algebra.generator, blast)
+     apply(rule gen_boolean_algebra.union, blast,blast)
+   by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
+next
+  fix x assume A: "x \<in> gen_boolean_algebra S (insert A Xs)"
+  show "x \<in> gen_boolean_algebra S Xs"
+    apply(rule gen_boolean_algebra.induct[of x S "insert A Xs"], rule A, rule gen_boolean_algebra.universe)
+    using assms gen_boolean_algebra.generator[of _ Xs S]
+    using gen_boolean_algebra.universe gen_boolean_algebra_intersect apply blast
+     apply(rule gen_boolean_algebra.union, blast, blast)
+       by(rule gen_boolean_algebra_diff, rule gen_boolean_algebra.universe, blast)
+qed
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Turning a Family of Sets into a Family of Disjoint Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  This section outlines the standard construction where sets $A_0, \dots, A_n$ are replaced by sets
+  $A_0, A_1 - A_0, A_2 - (A_0 \cup A_1), ..., A_n - (\bigcup \limits_{i = 0}^{n-1} A_i)$ to obtain
+  a disjoint family of the same cardinality.
+\<close>
+fun rec_disjointify where
+"rec_disjointify 0 f = {}"|
+"rec_disjointify (Suc m) f = insert (f m - \<Union> (rec_disjointify m f)) (rec_disjointify m f)"
+
+lemma card_of_rec_disjointify:
+"card (rec_disjointify m f) \<le> m"
+  apply(induction m) unfolding rec_disjointify.simps 
+   apply simp
+  by (metis Suc_le_mono card.infinite card_insert_disjoint finite_insert insert_absorb le_SucI)
+
+lemma rec_disjointify_finite:
+"finite (rec_disjointify m f)"
+  apply(induction m)
+  unfolding rec_disjointify.simps by auto 
+
+lemma rec_disjointify_in_gen_boolean_algebra:
+  assumes "f ` {..<m} \<subseteq> gen_boolean_algebra S B"
+  shows  "rec_disjointify m f \<subseteq> gen_boolean_algebra S B"
+proof-
+  have "\<And>k. k \<le> m \<longrightarrow> rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
+  proof- fix k  show "k \<le> m \<longrightarrow> rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
+      apply(induction k) unfolding rec_disjointify.simps(1) using assms apply blast 
+    proof fix k 
+      assume IH: " k \<le> m \<longrightarrow> rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
+                 "Suc k \<le> m"
+      then have 0: "rec_disjointify k f \<subseteq> gen_boolean_algebra S B"
+        by (simp add: IH(2))
+      have 1: "finite (rec_disjointify k f )"
+        using rec_disjointify_finite by blast 
+      have 2: "f k \<in> gen_boolean_algebra S B"
+        using IH(2) assms 
+        by (simp add: image_subset_iff)        
+      show "rec_disjointify (Suc k) f \<subseteq> gen_boolean_algebra S B"
+        using 0 1 2 unfolding rec_disjointify.simps 
+        by (simp add: gen_boolean_algebra_diff gen_boolean_algebra_finite_union subset_iff)
+    qed
+  qed
+  thus ?thesis by blast 
+qed
+
+lemma rec_disjointify_union:
+"\<Union> (rec_disjointify m f) = (\<Union> i \<in> {..<m}. f i)"
+  apply(induction m)
+   apply simp unfolding rec_disjointify.simps insert_def
+  apply(rule equalityI, rule subsetI) 
+  apply (simp add: lessThan_Suc; fail)
+  apply(rule subsetI) 
+  by (simp add: lessThan_Suc)
+
+definition enum_rec_disjointify where
+"enum_rec_disjointify f m = f m - \<Union> (rec_disjointify m f)"
+
+lemma rec_disjointify_as_enum_rec_disjointify_image:
+"rec_disjointify m f = enum_rec_disjointify f  ` {..<m}"
+  apply(induction m)
+  unfolding rec_disjointify.simps 
+   apply (simp; fail)
+  unfolding enum_rec_disjointify_def
+  using lessThan_Suc by auto
+
+lemma enum_rec_disjointify_subset:
+"enum_rec_disjointify f m \<subseteq> f m"
+    unfolding enum_rec_disjointify_def
+    by auto 
+
+lemma enum_rec_disjointify_disjoint:
+  assumes "k < m"
+  shows "enum_rec_disjointify f m \<inter> enum_rec_disjointify f k = {}"
+proof-
+  have "enum_rec_disjointify f k \<subseteq> \<Union> (rec_disjointify m f)"
+    unfolding rec_disjointify_union 
+    using assms enum_rec_disjointify_subset by fastforce
+  thus ?thesis 
+     unfolding enum_rec_disjointify_def
+     by auto 
+qed
+
+lemma enum_rec_disjointify_disjoint':
+  assumes "k \<noteq> m"
+  shows "enum_rec_disjointify f m \<inter> enum_rec_disjointify f k = {}"
+  apply(cases  "k < m") using enum_rec_disjointify_disjoint[of k m f]
+   apply simp  
+  using assms enum_rec_disjointify_disjoint[of m k f] by auto 
+
+lemma rec_disjointify_is_disjoint:
+  assumes "A \<in> rec_disjointify m f"
+  assumes "B \<in>  rec_disjointify m f"
+  assumes "A \<noteq> B"
+  shows "A \<inter> B = {}"
+  using  rec_disjointify_as_enum_rec_disjointify_image enum_rec_disjointify_disjoint' assms
+  by (smt image_iff)
+
+definition enumerates where
+"enumerates A f \<equiv> finite A \<and> A = f ` {..< (card A)} \<and> inj_on f {..< (card A)}"
+
+lemma finite_imp_exists_enumeration:
+  assumes "finite A"
+  shows "\<exists>f. enumerates A f"
+  unfolding enumerates_def 
+  using assms finite_imp_nat_seg_image_inj_on[of A]
+  by (metis card_Collect_less_nat card_image lessThan_def)
+
+lemma enumeratesE:
+  assumes "enumerates A f"
+  shows "finite A" "A = f ` {..< card A}" "inj_on f {..< card A}"
+  using assms unfolding enumerates_def  apply blast 
+  using assms unfolding enumerates_def  apply blast 
+  using assms unfolding enumerates_def  by blast 
+
+lemma rec_disjointify_finite_set:
+  assumes "enumerates A f"
+  shows "\<Union> (rec_disjointify (card A) f) = \<Union> A"
+  unfolding rec_disjointify_union[of "card A" f]
+  using enumeratesE[of A f] assms by auto  
+
+definition enumerate where 
+"enumerate A = (SOME f. enumerates A f)"
+
+lemma enumerate_enumerates:
+  assumes "finite A"
+  shows "enumerates A (enumerate A)"
+  unfolding enumerate_def using finite_imp_exists_enumeration assms 
+  by (simp add: finite_imp_exists_enumeration some_eq_ex)
+
+lemma enumerateE: 
+  assumes "finite A"
+  assumes "a \<in> A"
+  shows "\<exists> i < card A. a = (enumerate A) i"
+  using  enumerate_enumerates[of A] enumeratesE[of A] assms by blast
+
+definition disjointify where 
+"disjointify As = rec_disjointify (card As) (enumerate As)"
+
+lemma disjointify_is_disjoint:
+  assumes "finite As"
+  assumes "A \<in> disjointify As"
+  assumes "B \<in> disjointify As"
+  assumes "A \<noteq>  B"
+  shows "A \<inter> B = {}"
+  using assms rec_disjointify_is_disjoint[of A _ _ B] unfolding disjointify_def 
+  by simp
+
+lemma disjointify_union:
+  assumes "finite As"
+  shows "\<Union> (disjointify As)  = \<Union> As"
+  using assms 
+  by (simp add: disjointify_def enumerate_enumerates rec_disjointify_finite_set)
+
+lemma disjointify_gen_boolean_algebra:
+  assumes "finite As"
+  assumes "As \<subseteq> gen_boolean_algebra S B"
+  shows " disjointify As \<subseteq> gen_boolean_algebra S B"
+  using assms unfolding disjointify_def  
+  by (metis enumerate_enumerates enumeratesE(2) rec_disjointify_in_gen_boolean_algebra)
+
+lemma disjointify_finite:
+  assumes "finite As"
+  shows "finite (disjointify As)"
+  using assms unfolding disjointify_def  
+  by (simp add: rec_disjointify_finite)
+
+lemma disjointify_card: 
+  assumes "finite As"
+  shows"card  (disjointify As) \<le> card As"
+  by (simp add: card_of_rec_disjointify disjointify_def)
+
+lemma disjointify_subset:
+  assumes "finite As"
+  assumes "A \<in> disjointify As"
+  shows "\<exists>B \<in> As. A \<subseteq> B"
+  using assms enum_rec_disjointify_subset enumerate_enumerates enumeratesE
+  unfolding disjointify_def 
+  by (smt image_iff rec_disjointify_as_enum_rec_disjointify_image)
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>The Atoms Generated by Collections of Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  We can also turn a family of sets into a disjoint family by taking the atoms of the boolean
+  algebra generated by these sets. This will still yield a finite family if the initial family is
+  finite, but in general will be much larger in size.
+\<close>
+
+(**********************************************************************)
+(**********************************************************************)
+subsubsection\<open>Defining the Atoms of a Family of Sets\<close>
+(**********************************************************************)
+(**********************************************************************)
+text\<open>
+  Here we intend that \<open>As\<close> is a subset of the collection of sets \<open>Xs\<close>. This function associate to each
+  subset \<open>As \<subseteq> Xs\<close> a set which is contained in each element of \<open>As\<close>, and is disjoint from
+  each element of \<open>Xs - As\<close>. Note that in general this may yield the empty set, but we will
+  ultimately be interested in the cases where the result is nonempty.\<close>
+
+definition subset_to_atom where
+"subset_to_atom Xs As = \<Inter> As - \<Union> (Xs - As)"
+
+lemma subset_to_atom_memI:
+  assumes "\<And>A. A \<in> As \<Longrightarrow> x \<in> A"
+  assumes "\<And>A. A \<in> Xs \<Longrightarrow> A \<notin> As \<Longrightarrow> x \<notin> A"
+  shows "x \<in> subset_to_atom Xs As"
+  using assms unfolding subset_to_atom_def 
+  by blast 
+
+lemma subset_to_atom_memE:
+  assumes "x \<in> subset_to_atom Xs As"
+  shows "\<And>A. A \<in> As \<Longrightarrow> x \<in> A"
+        "\<And>A. A \<in> Xs \<Longrightarrow> A \<notin> As \<Longrightarrow> x \<notin> A"
+  using assms unfolding subset_to_atom_def by auto 
+
+lemma subset_to_atom_closed: 
+  assumes "As \<noteq> {}"
+  assumes "As \<subseteq> Xs"
+  shows "subset_to_atom Xs As \<subseteq> \<Union> Xs"
+proof-
+  have 0: "\<Inter> As \<subseteq> \<Union> As "
+    apply(rule subsetI)
+    using assms(1) by blast
+  show ?thesis 
+  apply(rule subsetI)
+  using assms 0 unfolding subset_to_atom_def 
+  by (meson DiffD1 Union_mono subsetD)
+qed
+
+lemma subset_to_atom_as_intersection:
+  assumes "As \<noteq> {}"
+  assumes "As \<subseteq> Xs"
+  assumes "S = \<Union> Xs"
+  shows "subset_to_atom Xs As = \<Inter> As \<inter> (\<Inter> X \<in> Xs - As. S - X)"
+  unfolding assms subset_to_atom_def 
+  apply(rule equalityI')
+   apply(rule IntI, blast)
+  apply(rule InterI) 
+  using INT_I assms(1) assms(2) apply auto[1]
+  apply(rule DiffI, blast)
+  by blast
+
+definition atoms_of where
+"atoms_of Xs = (subset_to_atom Xs  ` ((Pow Xs) - {{}})) - {{}}"
+
+lemma atoms_nonempty:
+  assumes "A \<in> atoms_of Xs"
+  shows "A \<noteq> {}"
+  using assms unfolding atoms_of_def by blast 
+
+lemma atoms_of_disjoint:
+  assumes "A \<in> atoms_of Xs"
+  assumes "B \<in> atoms_of Xs"
+  assumes "A \<noteq> B"
+  shows "A \<inter> B = {}"
+proof-
+  obtain a where a_def: "a \<subseteq> Xs \<and> A = subset_to_atom Xs a"
+    using assms  unfolding atoms_of_def by blast 
+  obtain b where b_def: "b \<subseteq> Xs \<and> B = subset_to_atom Xs b"
+    using assms  unfolding atoms_of_def by blast 
+  have a_neq_b: "a \<noteq> b"
+    using assms   a_def b_def by blast 
+  have  "A \<inter> B \<subseteq> {}"
+  proof fix x assume A: "x \<in> A \<inter> B"
+    show "x \<in> {}"
+    proof(cases "a \<subseteq> b")
+      case True
+      then obtain c where c_def: "c \<in> b - a"
+        using a_neq_b by blast
+      have c_in_Xs: "c \<in> Xs"
+        using c_def b_def by blast 
+      have x_in_c: "x \<in> c"
+        using A  b_def c_def subset_to_atom_memE[of x Xs b c] by blast 
+      have x_notin_c: "x \<notin> c"
+        using A  a_def c_in_Xs c_def subset_to_atom_memE[of x Xs a c] by blast 
+      then show ?thesis using x_in_c by blast 
+    next
+      case False
+      then obtain c where c_def: "c \<in> a - b"
+        using a_neq_b by blast
+      have c_in_Xs: "c \<in> Xs"
+        using c_def a_def by blast 
+      have x_in_c: "x \<in> c"
+        using A  a_def c_def subset_to_atom_memE[of x Xs a c] by blast 
+      have x_notin_c: "x \<notin> c"
+        using A  b_def c_in_Xs c_def subset_to_atom_memE[of x Xs b c] by blast 
+      then show ?thesis using x_in_c by blast 
+    qed
+  qed
+  thus "A \<inter> B = {}"
+    by blast 
+qed
+
+text \<open>
+  The atoms of a family of sets \<open>Xs\<close> are minimal in the sense that they are either contained in or
+  disjoint from each element of \<open>Xs\<close>.
+\<close>
+lemma atoms_are_minimal:
+  assumes "A \<in> atoms_of Xs"
+  assumes "X \<in> Xs"
+  shows "X \<inter> A = {} \<or> A \<subseteq> X"
+proof(cases "X \<inter> A = {}")
+  case True
+  then show ?thesis by blast 
+next
+  case False
+  obtain As where As_def: "As \<in> Pow Xs - {{}} \<and> A = subset_to_atom Xs As"
+    using assms unfolding atoms_of_def by blast
+  have A_simp: "A = subset_to_atom Xs As"
+    using As_def by blast 
+  then show ?thesis using assms  unfolding atoms_of_def subset_to_atom_def A_simp 
+  using DiffD1 subset_eq by auto
+qed
+
+(**********************************************************************)
+(**********************************************************************)
+subsubsection\<open>Atoms Induced by Types of Points\<close>
+(**********************************************************************)
+(**********************************************************************)
+text\<open>
+  The set of sets in \<open>Xs\<close> which contain some point \<open>x\<close>. In the case where \<open>Xs\<close> is some collection of 
+  first order formulas, this is just the type of \<open>x\<close> over these formulas.\<close>
+definition point_to_type where 
+"point_to_type Xs x = {X \<in> Xs. x \<in> X}"
+
+text \<open>The type of a point \<open>x\<close> induces the unique atom of \<open>Xs\<close> which contains \<open>x\<close>.\<close>
+lemma point_in_atom_of_type:
+  assumes "x \<in> \<Union> Xs"
+  shows "x \<in> subset_to_atom Xs (point_to_type Xs x)"
+  using assms unfolding subset_to_atom_def  point_to_type_def 
+  by blast
+
+lemma point_to_type_nonempty:
+  assumes "x \<in> \<Union> Xs"
+  shows "point_to_type Xs x \<noteq>{}"
+  using assms unfolding point_to_type_def 
+  by blast
+
+lemma point_to_type_closed: 
+ "point_to_type Xs x \<subseteq> Pow (\<Union> Xs)"
+  unfolding point_to_type_def 
+  by blast
+ 
+lemma atoms_of_covers: 
+  assumes "X = \<Union> Xs"
+  shows "\<Union> (atoms_of Xs) = X"
+proof
+  show " \<Union> (atoms_of Xs) \<subseteq> X"
+  proof fix x assume A: "x \<in> \<Union> (atoms_of Xs)"
+    then obtain As where As_def: "As \<in> Pow Xs - {{}} \<and> x \<in> subset_to_atom Xs As"
+      unfolding atoms_of_def  by blast      
+    have "subset_to_atom Xs As \<subseteq>  \<Union> Xs"
+      using subset_to_atom_closed[of As Xs] As_def by blast 
+    then show "x \<in> X" unfolding assms  
+      using As_def by blast
+  qed
+  show "X \<subseteq> \<Union> (atoms_of Xs)" apply(rule subsetI)
+    using point_to_type_nonempty point_in_atom_of_type point_to_type_closed
+    unfolding  assms point_to_type_def atoms_of_def 
+    by fastforce   
+qed    
+
+lemma atoms_of_covers': 
+  shows "\<Union> (atoms_of Xs) = \<Union> Xs"
+  using atoms_of_covers[of "\<Union> Xs"] by blast 
+
+text \<open>Every atom of a collection \<open>Xs\<close> of sets is realized as the atom generated by the type of
+   an element in that atom.\<close>
+lemma nonemtpy_atom_from_point_to_type:
+  assumes "A \<in> atoms_of Xs"
+  assumes "a \<in> A"
+  shows "A = subset_to_atom Xs (point_to_type Xs a)"
+proof-
+  obtain As where As_def: "As \<in> (Pow Xs) - {} \<and> A = subset_to_atom Xs As"
+    using assms unfolding atoms_of_def by blast 
+  have A_simp: "A = subset_to_atom Xs As"
+    using As_def by blast 
+  have 0: "As = point_to_type Xs a"
+    apply(rule  equalityI)
+    apply(rule  subsetI)
+    apply (smt As_def Diff_empty UnionI Union_Pow_eq assms point_in_atom_of_type subset_to_atom_memE(1) subset_to_atom_memE(2))    
+    apply(rule subsetI) 
+    using As_def assms subset_to_atom_memE(2) 
+    by (metis (no_types, lifting) mem_Collect_eq point_to_type_def)
+  show ?thesis 
+    using point_in_atom_of_type 0
+          atoms_of_covers'[of Xs] assms  unfolding A_simp
+    by auto
+qed  
+
+text \<open>
+  In light of the previous theorem, a point a and a collection of sets \<open>Xs\<close> is enough to recover
+  the the unique atom of \<open>Xs\<close> which contains \<open>a\<close>.
+\<close>
+definition point_to_atom where
+"point_to_atom Xs a = subset_to_atom Xs (point_to_type Xs a)"
+
+lemma point_to_atom_closed: 
+  assumes "x \<in> \<Union> Xs"
+  shows "point_to_atom Xs x \<in> atoms_of Xs"
+  using assms unfolding atoms_of_def point_to_atom_def 
+  by (metis (full_types) Union_iff atoms_of_covers atoms_of_def nonemtpy_atom_from_point_to_type)
+
+text \<open>All atoms of \<open>Xs\<close> are the atom induced by some point in the union of \<open>Xs\<close>.\<close>
+lemma atoms_induced_by_points:
+"atoms_of Xs = point_to_atom Xs ` (\<Union> Xs)"
+  apply(rule equalityI)
+   apply(rule subsetI)
+  using nonemtpy_atom_from_point_to_type atoms_nonempty atoms_of_covers'
+  unfolding point_to_atom_def 
+  apply (smt DiffE Pow_empty Pow_iff atoms_of_def image_iff subsetD subsetI subset_to_atom_closed)
+     apply(rule subsetI)
+  by (metis (no_types, lifting) imageE point_to_atom_closed point_to_atom_def)
+
+(**********************************************************************)
+(**********************************************************************)
+subsubsection\<open>Atoms of Generated Boolean Algebras\<close>
+(**********************************************************************)
+(**********************************************************************)
+
+lemma atoms_of_gen_boolean_algebra:
+  assumes "Xs \<subseteq> gen_boolean_algebra S B"
+  assumes "finite Xs"
+  shows "atoms_of Xs \<subseteq> gen_boolean_algebra S B"
+proof
+  fix x assume A: "x \<in> atoms_of Xs"
+  then obtain As where As_def: "As \<in> ((Pow Xs) - {{}}) \<and> x = subset_to_atom Xs As"
+    unfolding atoms_of_def by blast 
+  have x_simp: "x = subset_to_atom Xs As"
+    using As_def by blast 
+  have 0: "finite As"
+    using As_def assms finite_subset by auto
+  have 1: "As \<subseteq> gen_boolean_algebra S B"
+    using As_def assms by blast
+  have 2: "\<Inter> As \<in> gen_boolean_algebra S B"
+    using 0 1 assms 
+    by (metis As_def DiffE gen_boolean_algebra_finite_intersection singletonI subset_eq)
+  show "x \<in> gen_boolean_algebra S B"
+    using A 2 unfolding atoms_of_def subset_to_atom_def x_simp 
+    by (metis (no_types, lifting) As_def DiffD1 Diff_partition Pow_iff Un_subset_iff assms(1) assms(2) finite_subset gen_boolean_algebra_diff gen_boolean_algebra_finite_union order_refl subsetD)
+qed
+
+
+text \<open>If the generators of a boolean algebra are contained in the universe, the atoms induced by 
+  the generators alone are minimal elements of the entire algebra.\<close>
+lemma finite_algebra_atoms_are_minimal:
+  assumes "finite Xs"
+  assumes "\<Union> Xs \<subseteq> S"
+  assumes "A \<in> atoms_of Xs"
+  assumes "X \<in> gen_boolean_algebra S Xs"
+  shows "X \<inter> A = {} \<or> A \<subseteq> X"
+  apply(rule gen_boolean_algebra.induct[of X S Xs])
+  apply (simp add: assms(4); fail)
+  apply (metis Union_upper assms(2) assms(3) atoms_of_covers dual_order.trans)
+  using assms(2) assms(3) atoms_are_minimal apply fastforce
+  apply blast
+  using assms
+  by (metis Diff_Int_distrib2 Diff_empty Diff_eq_empty_iff Sup_upper atoms_of_covers' equalityE inf.absorb_iff2 order_trans) 
+
+lemma finite_set_imp_finite_atoms:
+  assumes "finite Xs"
+  shows "finite (atoms_of Xs)"
+  using assms unfolding atoms_of_def 
+  by blast
+
+text \<open>
+  Every element in the boolean algebra generated by \<open>Xs\<close> over \<open>S\<close> is a (disjoint) union
+  of atoms of generators:
+\<close>
+
+lemma gen_boolean_algebra_elem_uni_of_atoms:
+  assumes "finite Xs"
+  assumes "S = \<Union> Xs"
+  assumes "X \<in> gen_boolean_algebra S Xs"
+  shows "X = \<Union> {a \<in> atoms_of Xs. a \<subseteq> X}"
+proof
+  show "X \<subseteq> \<Union> {a \<in> atoms_of Xs. a \<subseteq> X}"
+  proof fix x assume A: "x \<in> X"
+    then have "point_to_atom Xs x \<in> atoms_of Xs"
+      using assms by (meson gen_boolean_algebra_subset point_to_atom_closed subsetD)
+    then show "x \<in> \<Union> {a \<in> atoms_of Xs. a \<subseteq> X}"
+      by (smt A IntI Union_iff assms(1) assms(2) assms(3) empty_iff finite_algebra_atoms_are_minimal gen_boolean_algebra.universe gen_boolean_algebra_subset mem_Collect_eq point_in_atom_of_type point_to_atom_def subsetD)
+  qed
+  show "\<Union> {a \<in> atoms_of Xs. a \<subseteq> X} \<subseteq> X"
+    by blast 
+qed
+
+text\<open>In fact, every generated boolean algebra is the power set of the atoms of its generators:\<close>
+lemma gen_boolean_algebra_generated_by_atoms:
+  assumes "finite Xs"
+  assumes "S = \<Union> Xs"
+  shows "gen_boolean_algebra S Xs = \<Union> ` (Pow (atoms_of Xs))"
+proof
+  show "gen_boolean_algebra S Xs \<subseteq> \<Union> ` Pow (atoms_of Xs)"
+    apply(rule subsetI)
+    using gen_boolean_algebra_elem_uni_of_atoms[of Xs S] assms 
+    by fastforce
+  show "\<Union> ` Pow (atoms_of Xs) \<subseteq> gen_boolean_algebra S Xs"
+    apply(rule subsetI)
+    using atoms_of_gen_boolean_algebra[of Xs S Xs]
+          finite_subset[of _ "atoms_of Xs"] assms 
+          finite_set_imp_finite_atoms[of Xs] 
+          gen_boolean_algebra_finite_union[of _ S Xs] 
+    by (smt Pow_iff Union_upper gen_boolean_algebra.intros(2) image_iff inf.absorb1 subsetD subsetI)
+qed
+
+text\<open>Finitely generated boolean algebras are finite\<close>
+lemma fin_gens_imp_fin_algebra:
+  assumes "finite Xs"
+  assumes "S = \<Union> Xs"
+  shows "finite (gen_boolean_algebra S Xs)"
+  using finite_set_imp_finite_atoms[of Xs] assms gen_boolean_algebra_generated_by_atoms[of Xs S]
+  by simp
+
+
+lemma point_to_atom_equal:
+  assumes "finite Xs"
+  assumes "S = \<Union> Xs"
+  assumes "x \<in> S"
+  shows "point_to_atom Xs x = point_to_atom (gen_boolean_algebra S Xs) x"
+proof
+  show P0: "point_to_atom Xs x \<subseteq> point_to_atom (gen_boolean_algebra S Xs) x"
+  proof-
+    have 0: "point_to_atom Xs x \<inter> point_to_atom (gen_boolean_algebra S Xs) x \<noteq> {}"
+      using assms 
+      by (metis IntI UnionI empty_iff gen_boolean_algebra.universe point_in_atom_of_type point_to_atom_def)
+    have 1: "point_to_atom (gen_boolean_algebra S Xs) x \<in> gen_boolean_algebra S Xs"
+      using assms fin_gens_imp_fin_algebra[of Xs S] 
+      by (meson UnionI atoms_of_gen_boolean_algebra gen_boolean_algebra.simps point_to_atom_closed subset_eq subset_refl)
+    then show ?thesis
+      using 0 finite_algebra_atoms_are_minimal[of Xs S "point_to_atom Xs x" "point_to_atom (gen_boolean_algebra S Xs) x"]
+            assms(1) assms(2) assms(3) atoms_induced_by_points by auto
+  qed
+  show "point_to_atom (gen_boolean_algebra S Xs) x \<subseteq> point_to_atom Xs x"
+  proof- 
+    have 0: "point_to_atom (gen_boolean_algebra S Xs) x \<inter> point_to_atom Xs x \<noteq>{}"
+      using assms P0 point_in_atom_of_type point_to_atom_def by fastforce
+    have 1: "point_to_atom (gen_boolean_algebra S Xs) x \<in> (gen_boolean_algebra S Xs)"
+      using assms gen_boolean_algebra_idempotent[of S Xs] atoms_of_gen_boolean_algebra 
+      by (metis UnionI fin_gens_imp_fin_algebra gen_boolean_algebra.universe point_to_atom_closed subset_eq)
+    have 2: "\<Union> (gen_boolean_algebra S Xs) \<subseteq> S"
+      using assms 
+      by (simp add: Sup_le_iff gen_boolean_algebra_subset)
+    hence 3: "\<Union> (gen_boolean_algebra S Xs) = S"
+      by (simp add: Union_upper gen_boolean_algebra.universe subset_antisym)
+    have 4: "gen_boolean_algebra S (gen_boolean_algebra S Xs) = gen_boolean_algebra S Xs"
+      using assms gen_boolean_algebra_idempotent[of S Xs] by blast 
+    have 5: "point_to_atom Xs x \<in> gen_boolean_algebra S (gen_boolean_algebra S Xs)"
+      unfolding  4 using assms  
+      by (metis (no_types, opaque_lifting) Int_absorb1 Int_commute Union_upper atoms_of_gen_boolean_algebra gen_boolean_algebra.generator point_to_atom_closed subsetD subsetI)
+    show ?thesis
+      using 2 5 finite_algebra_atoms_are_minimal[of "gen_boolean_algebra S Xs" S "point_to_atom (gen_boolean_algebra S Xs) x" "point_to_atom Xs x"] 0 1 2
+      unfolding 4  
+      by (metis "3" Int_commute assms(1) assms(2) assms(3) fin_gens_imp_fin_algebra point_to_atom_closed)
+  qed
+qed
+
+text \<open>
+  When the set \<open>Xs\<close> of generators covers the universe set \<open>S\<close>, the atoms of \<open>Xs\<close> in the above
+  sense are the same as the atoms of the boolean algebra they generate over \<open>S\<close>.
+\<close>
+
+lemma atoms_of_sets_eq_atoms_of_algebra:
+  assumes "finite Xs"
+  assumes "S = \<Union> Xs"
+  shows "atoms_of Xs = atoms_of (gen_boolean_algebra S Xs)"
+proof
+  show "atoms_of Xs \<subseteq> atoms_of (gen_boolean_algebra S Xs)"
+  proof fix A assume A: "A \<in> atoms_of Xs"
+    then obtain x where x_def: "x \<in> S \<and> A = point_to_atom Xs x"
+      using assms 
+      by (metis atoms_induced_by_points image_iff)
+    have 0: "A = point_to_atom (gen_boolean_algebra S Xs) x"
+      using assms point_to_atom_equal  x_def by fastforce
+    show "A \<in> atoms_of (gen_boolean_algebra S Xs)"
+      unfolding 0 using assms A 
+      by (metis (full_types) "0" UnionI gen_boolean_algebra.universe point_to_atom_closed x_def)
+  qed
+  show "atoms_of (gen_boolean_algebra S Xs) \<subseteq> atoms_of Xs"
+  proof fix A  assume A: "A \<in> atoms_of (gen_boolean_algebra S Xs)"
+    then obtain x where x_def: "x \<in> S \<and> A  = point_to_atom (gen_boolean_algebra S Xs) x"
+      by (metis atoms_induced_by_points cSup_eq_maximum gen_boolean_algebra.universe gen_boolean_algebra_subset image_iff)
+    then show "A \<in> atoms_of Xs" 
+      using assms(1) assms(2) point_to_atom_closed point_to_atom_equal by fastforce
+  qed
+qed
+
+lemma atoms_closed:
+  assumes "finite Xs"
+  assumes "A \<in> atoms_of (gen_boolean_algebra S Xs)"
+  assumes "S = \<Union> Xs"
+  shows "A \<in> (gen_boolean_algebra S Xs)"
+proof-
+  have 1: "A = \<Union> {A}"
+    by blast 
+  have 2: "A \<in> atoms_of Xs"
+    using assms atoms_of_sets_eq_atoms_of_algebra 
+    by blast
+  show ?thesis 
+  using gen_boolean_algebra_generated_by_atoms[of Xs S] 
+        assms 1 2 unfolding Pow_def by blast 
+qed
+
+lemma atoms_finite:
+  assumes "finite Xs"
+  shows "finite ((atoms_of (gen_boolean_algebra S Xs)))"
+proof-
+  have 0: "gen_boolean_algebra S Xs =gen_boolean_algebra S ((\<inter>) S ` Xs)"
+    using gen_boolean_algebra_restrict_generators by blast 
+  have 1: "gen_boolean_algebra S Xs = gen_boolean_algebra S (insert S ((\<inter>) S ` Xs))"
+    unfolding 0 by(rule add_generators, rule gen_boolean_algebra.universe)
+  obtain Ys where Ys_def: "Ys = (insert S ((\<inter>) S ` Xs))"
+    by blast 
+  have Ys_finite: "finite Ys"
+    unfolding Ys_def using assms by blast 
+  have 2: "\<Union> Ys = S"
+    unfolding Ys_def 
+    by blast 
+  have 3: "atoms_of Ys = atoms_of (gen_boolean_algebra S Xs) "
+    unfolding Ys_def 1 
+    apply(rule atoms_of_sets_eq_atoms_of_algebra)
+    using Ys_finite unfolding Ys_def apply blast
+    by blast 
+  have 4: "finite (atoms_of Ys)"
+    by(rule finite_set_imp_finite_atoms, rule Ys_finite)
+  show ?thesis using 4 unfolding 3 by blast
+qed  
+
+
+text \<open>
+  We can distinguish atoms of a set of generators \<open>Cs\<close> by finding some element of \<open>Cs\<close> which
+  includes one and excludes the other.
+\<close>
+
+lemma distinct_atoms:
+  assumes "Cs \<noteq> {}"
+  assumes "a \<in> atoms_of Cs"
+  assumes "b \<in> atoms_of Cs"
+  assumes "a \<noteq> b"
+  shows "(\<exists>B \<in> Cs. b \<subseteq> B \<and> a \<inter> B = {}) \<or> (\<exists>A \<in> Cs. a \<subseteq> A \<and> b \<inter> A = {})"
+proof- 
+  obtain x where x_def: "x \<in> \<Union> Cs \<and> a = point_to_atom Cs x"
+    by (metis assms(2) atoms_induced_by_points imageE)
+  obtain y where y_def: "y \<in> \<Union> Cs \<and> b = point_to_atom Cs y"
+    by (metis assms(3) atoms_induced_by_points imageE)
+  have 0: "point_to_atom Cs x \<noteq> point_to_atom Cs y"
+    using x_def y_def assms by simp 
+  hence 1: "point_to_type Cs x \<noteq> point_to_type Cs y"
+    unfolding point_to_atom_def subset_to_atom_def by blast 
+  then obtain B where B_def: "B \<in> Cs \<and> (B \<in> point_to_type Cs x - point_to_type Cs y \<or> B \<in> point_to_type Cs y - point_to_type Cs x)"
+    unfolding point_to_type_def by blast 
+  have 2: "B \<in> point_to_type Cs x - point_to_type Cs y \<Longrightarrow> a \<subseteq> B"
+    using x_def  point_to_atom_def subset_to_atom_memE(1) by fastforce    
+  have 3: "B \<in> point_to_type Cs y - point_to_type Cs y \<Longrightarrow> b \<subseteq> B"
+    using y_def by blast
+  show ?thesis using B_def 2 3 
+    by (smt Diff_iff disjoint_iff_not_equal point_to_atom_def subset_eq subset_to_atom_memE(1) subset_to_atom_memE(2) x_def y_def)
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Partitions of a Set\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition disjoint :: "'a set set \<Rightarrow> bool" where
+"disjoint Ss = (\<forall> A \<in> Ss. \<forall>B \<in> Ss.  A \<noteq>B \<longrightarrow> A \<inter> B = {})"
+
+lemma disjointE: 
+  assumes "disjoint Ss"
+  assumes "A \<in> Ss"
+  assumes "B \<in> Ss"
+  assumes "A \<noteq>B"
+  shows "A \<inter> B = {}"
+  by (meson assms(1) assms(2) assms(3) assms(4) disjoint_def)
+
+lemma disjointI: 
+  assumes "\<And>A B. A \<in> Ss \<Longrightarrow> B \<in> Ss \<Longrightarrow> A \<noteq> B \<Longrightarrow> A \<inter> B = {}"
+  shows "disjoint Ss"
+  by (meson assms disjoint_def)
+
+definition is_partition  :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "partitions" 75) where
+"S partitions A = (disjoint S \<and> \<Union> S = A)"
+
+lemma is_partitionE: 
+  assumes "S partitions A"
+  shows "disjoint S"
+        "\<Union> S = A"
+  using assms is_partition_def apply blast 
+  using assms 
+  by (simp add: is_partition_def)
+
+lemma is_partitionI: 
+  assumes "disjoint S"
+  assumes "\<Union> S = A"
+  shows "S partitions A"
+  using assms is_partition_def by blast 
+
+text \<open>
+  If we start with a finite partition of a set \<open>A\<close>, and each element in that partition has a
+  finite partition with some property \<open>P\<close>, then \<open>A\<close> itself has a finite partition where each
+  element has property \<open>P\<close>.\<close>
+
+lemma iter_partition:
+  assumes "As partitions A"
+  assumes "finite As"
+  assumes "\<And>a. a \<in> As \<Longrightarrow> \<exists>Bs. finite Bs \<and> Bs partitions a \<and> (\<forall>b \<in> Bs. P b)"
+  shows "\<exists>Bs. finite Bs \<and> Bs partitions A \<and> (\<forall>b \<in> Bs. P b)"
+proof- 
+  obtain F where F_def: "F = (\<lambda>a. (SOME Bs.  finite Bs \<and> Bs partitions a \<and> (\<forall>b \<in> Bs. P b)))"
+    by blast 
+  have FE: "\<And>a. a \<in> As \<Longrightarrow> finite (F a) \<and> (F a) partitions a \<and> (\<forall>b \<in> (F a). P b)" 
+  proof- fix a assume A: "a \<in> As"
+    show "finite (F a) \<and> (F a) partitions a \<and> (\<forall>b \<in> (F a). P b)"
+      apply(rule SomeE'[of _ "\<lambda>Bs.  finite Bs \<and> Bs partitions a \<and> (\<forall>b \<in> Bs. P b)"])
+      unfolding F_def apply blast
+      using assms by (simp add: A)
+  qed
+  obtain Bs where Bs_def: "Bs = (\<Union> a \<in> As. F a)"
+    by blast 
+  have 0: "finite Bs"
+    unfolding Bs_def using FE assms by blast 
+  have 1: "disjoint Bs"
+  proof(rule disjointI)
+    fix a b assume A: "a \<in> Bs" "b \<in> Bs" "a \<noteq> b"
+    obtain c where c_def: "c \<in> As \<and> a \<in>  F c"
+      using Bs_def A by blast 
+    obtain d where d_def: "d \<in> As \<and> b \<in>  F d"
+      using Bs_def A by blast 
+    have 0: "a \<subseteq> c"
+      using c_def FE[of c] is_partitionE(2)[of "F c" c] by blast 
+    have 1: "b \<subseteq> d"
+      using d_def FE[of d] is_partitionE(2)[of "F d" d] by blast 
+    show "a \<inter> b = {}"
+    proof(cases "c = d")
+      case True
+      show ?thesis apply(rule disjointE[of "F c"])
+        unfolding True using FE is_partitionE d_def apply blast
+        using c_def unfolding True apply blast
+        using d_def apply blast
+        by(rule A)
+    next
+      case False
+      have "c \<inter> d = {}"
+        apply(rule disjointE[of As])
+        using assms is_partitionE apply blast
+        using c_def apply blast
+        using d_def apply blast
+        using False by blast 
+      then show ?thesis using 0 1 by blast  
+    qed
+  qed
+  have 2: "(\<forall>b \<in> Bs. P b)"
+    apply(rule )
+    unfolding Bs_def using FE 
+    by blast
+  have FE': "\<And>a. a \<in> As \<Longrightarrow> (\<Union> (F a)) = a "
+    apply(rule is_partitionE)
+    using FE by blast 
+  have 3: "Bs partitions A"
+    apply(rule is_partitionI, rule 1)
+apply(rule equalityI')
+    unfolding Bs_def using assms is_partitionE(2)[of As A]
+      FE' is_partitionE(2) apply blast
+  proof- 
+    fix x assume A: "x \<in> A"
+    then obtain a where a_def: "a \<in> As \<and> x \<in> a"
+      using assms is_partitionE by blast 
+    then have "x \<in> (\<Union> (F a))"
+      using a_def FE' by blast 
+    thus " x \<in> \<Union> (\<Union> (F ` As))"
+      using a_def A by blast 
+  qed
+  show "\<exists>Bs. finite Bs \<and> Bs partitions A \<and> (\<forall>b\<in>Bs. P b)"
+    using 0 2 3 by blast 
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Intersections of Families of Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition pairwise_intersect where 
+"pairwise_intersect As Bs = {c. \<exists>a \<in> As. \<exists>b \<in> Bs. c = a \<inter> b}"
+
+lemma partition_intersection:
+  assumes "As partitions A"
+  assumes "Bs partitions B"
+  shows "(pairwise_intersect As Bs) partitions (A \<inter> B)"
+proof(rule is_partitionI, rule disjointI)
+  fix a b assume a0: "a \<in> pairwise_intersect As Bs" "b \<in> pairwise_intersect As Bs" "a \<noteq> b"
+  obtain a1 b1 where def1: "a1 \<in> As \<and> b1 \<in> Bs \<and> a = a1 \<inter> b1"
+    using a0 unfolding pairwise_intersect_def by blast 
+  obtain a2 b2 where def2: "a2 \<in> As \<and> b2 \<in> Bs \<and> b = a2 \<inter> b2"
+    using a0 unfolding pairwise_intersect_def by blast 
+  have 0: "a \<inter> b = (a1 \<inter> a2) \<inter> (b1 \<inter> b2)"
+    using def1 def2 by blast 
+  show " a \<inter> b= {}"
+  proof(cases "a1 \<noteq> a2")
+    case True
+    have T0: "a1 \<inter> a2 = {}"
+      apply(rule disjointE[of As a1 a2] )
+      using def1 def2 assms(1) True is_partitionE(1)[of As A] apply blast
+      using def1 apply blast using def2 apply blast by(rule True)
+    thus ?thesis unfolding 0 by blast      
+  next
+    case False
+    then have F0: "b1 \<noteq> b2"
+      using a0 def1 def2 by blast 
+    have F1: "b1 \<inter> b2 = {}"
+      apply(rule disjointE[of Bs b1 b2])
+      using def1 def2 assms(2) F0  is_partitionE(1)[of Bs B] apply blast
+      using def1 apply blast using def2 apply blast by(rule F0)
+    thus ?thesis unfolding 0 by blast      
+  qed
+next 
+  show "\<Union> (pairwise_intersect As Bs) = A \<inter> B"
+  proof(rule equalityI')
+    fix x assume A: "x \<in> \<Union> (pairwise_intersect As Bs)"
+    then obtain a b where def1: "a \<in> As \<and> b \<in> Bs \<and> x \<in> a \<inter> b"
+      unfolding pairwise_intersect_def by blast 
+    have 0: "a \<subseteq> A"
+      using def1 assms is_partitionE by blast 
+    have 1: "b \<subseteq> B"
+      using def1 assms is_partitionE by blast 
+    show " x \<in> A \<inter> B"
+      using 0 1 def1 by blast 
+  next 
+    fix x assume A: "x \<in> A \<inter> B"
+    obtain a where a_def: "a \<in> As \<and> x \<in> a"
+      using A assms is_partitionE by blast 
+    obtain b where b_def: "b \<in> Bs \<and> x \<in> b"
+      using A assms is_partitionE by blast 
+    have 0: "x \<in> a \<inter> b"
+      using a_def b_def by blast 
+    show "x \<in> \<Union> (pairwise_intersect As Bs)"
+      using a_def b_def 0 unfolding pairwise_intersect_def 
+      by blast 
+  qed
+qed
+
+lemma pairwise_intersect_finite: 
+  assumes "finite As"
+  assumes "finite Bs"
+  shows "finite (pairwise_intersect As Bs)"
+proof- 
+  have 0: "(pairwise_intersect As Bs) = (\<Union> a \<in> As. (\<inter>) a ` Bs)"
+    unfolding pairwise_intersect_def
+    apply(rule equalityI')
+    unfolding mem_Collect_eq apply blast
+    by blast
+  have 1: "\<And>a. a \<in> As \<Longrightarrow> finite ((\<inter>) a ` Bs)"
+    using assms by blast 
+  show ?thesis unfolding 0 using assms(1) 1 by blast 
+qed
+
+definition family_intersect where
+"family_intersect parts = atoms_of (\<Union> parts)"
+
+lemma family_intersect_partitions:
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> Ps partitions A"
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
+  assumes "finite parts"
+  assumes "parts \<noteq> {}"
+  shows "family_intersect parts partitions A"
+proof(rule is_partitionI)
+  show "disjoint (family_intersect parts)"
+    apply(rule disjointI)
+    unfolding family_intersect_def apply(rule atoms_of_disjoint)
+    apply blast
+    apply blast
+    by blast 
+  show " \<Union> (family_intersect parts) = A"
+  proof- 
+    have 0: "\<Union> (family_intersect parts) = \<Union> (\<Union> parts)"
+      unfolding family_intersect_def 
+      apply(rule atoms_of_covers)
+      by blast 
+    have 1: "\<And>Ps. Ps \<in> parts \<Longrightarrow> \<Union>Ps = A"
+      by(rule is_partitionE, rule assms, blast)
+    show ?thesis unfolding 0 
+      using 1 assms by blast 
+  qed
+qed
+
+lemma family_intersect_memE: 
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> Ps partitions A"
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
+  assumes "finite parts"
+  assumes "parts \<noteq> {}"
+  shows "\<And>Ps a. a \<in> family_intersect parts \<Longrightarrow> Ps \<in> parts \<Longrightarrow> \<exists>P \<in> Ps. a \<subseteq> P"
+proof- 
+  fix Ps a assume A: "a \<in> family_intersect parts" "Ps \<in> parts"
+  have 0: "\<Union> Ps = A"
+    apply(rule is_partitionE)
+    using A assms by blast 
+  have 1: "\<Union> (family_intersect parts) = A"
+    apply(rule is_partitionE)
+    using family_intersect_partitions assms by blast 
+  have 2: "a \<noteq> {}"
+    using A unfolding family_intersect_def  atoms_of_def by blast 
+  obtain P where P_def: "P \<in> Ps \<and> a \<inter> P \<noteq> {}"
+    using 0 1 A 2 by blast 
+  have P_in: "P \<in> (\<Union> parts)"
+    using P_def A by blast 
+  have a_sub: "a \<subseteq> P"
+    using atoms_are_minimal P_def A P_in unfolding family_intersect_def by blast 
+  show "\<exists>P \<in> Ps. a \<subseteq> P"
+    using a_sub P_def by blast 
+qed
+
+lemma family_intersect_mem_inter: 
+  assumes "\<And>Ps. Ps \<in> (parts:: 'a set set set) \<Longrightarrow> Ps partitions A"
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
+  assumes "finite parts"
+  assumes "parts \<noteq> {}"
+  assumes "a \<in> family_intersect parts"
+  shows "\<exists>f. \<forall> Ps \<in> parts. f Ps \<in> Ps \<and> a = (\<Inter> Ps \<in> parts. f Ps)"
+proof-  
+  obtain f where f_def: "f = (\<lambda>Ps:: 'a set set. (SOME P. P \<in> Ps \<and> a \<subseteq> P))"
+    by blast 
+  have f_eval: "\<And>Ps. Ps \<in> parts \<Longrightarrow> f Ps \<in> Ps \<and> a \<subseteq> (f Ps)"
+  proof- 
+    fix Ps assume A: "Ps \<in> parts"
+    obtain P where P_def: "P \<in> Ps \<and> a \<subseteq> P"
+      using assms family_intersect_memE A by blast 
+    show " f Ps \<in> Ps \<and> a \<subseteq> f Ps" 
+      apply(rule SomeE[of "f Ps" _ P])
+      unfolding f_def using A apply simp 
+      by(rule P_def)
+  qed
+  have 0: "a \<noteq> {}"
+    using assms unfolding family_intersect_def 
+    using atoms_nonempty by blast
+  have 1: "a = (\<Inter> Ps \<in> parts. f Ps)"
+  proof(rule equalityI)
+    show 10: "a \<subseteq> \<Inter> (f ` parts)"
+      using f_eval by blast 
+    show "\<Inter> (f ` parts) \<subseteq> a"
+    proof
+      fix x assume A: "x \<in> \<Inter> (f ` parts)"
+      obtain b where b_def: "b = point_to_atom (\<Union> parts) x"
+        by blast 
+      have b_atom: "b \<in> atoms_of (\<Union> parts)"
+        unfolding b_def apply(rule point_to_atom_closed)
+        using A f_eval assms by blast
+      show x_in_a: "x \<in> a"
+      proof(rule ccontr)
+        assume "x \<notin> a"
+        then have "\<not> b \<subseteq> a"
+          using b_def unfolding point_to_atom_def  point_to_type_def  subset_to_atom_def by blast
+        hence p0: "a \<noteq> b"
+          by blast 
+        have p1: "b \<inter> a = {}"
+          apply(rule atoms_of_disjoint[of _ "(\<Union> parts)"] ) 
+            apply(rule b_atom)
+          using assms unfolding family_intersect_def apply blast
+          using p0 by blast 
+        have p2: " (\<exists>B\<in>\<Union> parts. b \<subseteq> B \<and> a \<inter> B = {}) \<or> (\<exists>A\<in>\<Union> parts. a \<subseteq> A \<and> b \<inter> A = {})"
+          using distinct_atoms[of "\<Union> parts" a b] assms 
+          by (metis Sup_bot_conv(1) b_atom equalityI' f_eval family_intersect_def mem_simps(2) p0)
+        show False 
+        proof(cases "(\<exists>B\<in>\<Union> parts. b \<subseteq> B \<and> a \<inter> B = {})")
+          case True
+          then obtain B where B_def: "B\<in>\<Union> parts \<and> b \<subseteq> B \<and> a \<inter> B = {}"
+            by blast 
+          obtain Ps where Ps_def: "B \<in> Ps \<and> Ps \<in> parts"
+            using B_def by blast 
+          have B_neq: "B \<noteq> f Ps"
+            using Ps_def B_def 10 0 by blast 
+          have B_cap: "B \<inter> f Ps = {}"
+            apply(rule disjointE[of Ps])
+               apply(rule is_partitionE[of Ps A])
+            using Ps_def assms apply blast
+            using Ps_def apply blast
+            using f_eval Ps_def apply blast
+            by(rule B_neq)
+          have b_cap: "b \<inter> f Ps = {}"
+            using B_cap B_def by blast 
+          have x_in_b: "x \<in> b"
+            using b_def unfolding point_to_atom_def point_to_type_def subset_to_atom_def 
+            by blast  
+          show False using x_in_b b_cap Ps_def A by blast 
+        next
+          case False
+          then obtain B where B_def: "B\<in>\<Union> parts \<and> a \<subseteq> B \<and> b \<inter> B = {}"
+            using p2 by blast 
+          obtain Ps where Ps_def: "B \<in> Ps \<and> Ps \<in> parts" 
+            using B_def by blast 
+          have F0: "B = f Ps"
+          proof(rule ccontr)
+            assume not: "B \<noteq> f Ps"
+            have F0: "B \<inter> f Ps = {}"
+             apply(rule disjointE[of Ps])
+               apply(rule is_partitionE[of Ps A])
+            using Ps_def assms apply blast
+            using Ps_def apply blast
+            using f_eval Ps_def apply blast
+            by(rule not)
+            have a_sub: "a \<subseteq> f Ps"
+              using 10 Ps_def by blast 
+            show False using F0 B_def a_sub 0  by blast 
+          qed
+          have x_in_B: "x \<in> B"
+            unfolding F0 using A Ps_def by blast 
+          have x_in_b: "x \<in> b"
+            using b_def unfolding point_to_atom_def point_to_type_def subset_to_atom_def 
+            by blast  
+          show False using x_in_b x_in_B B_def by blast 
+        qed
+      qed
+    qed
+  qed
+  show ?thesis using f_eval 1 by blast 
+qed
+
+text \<open>
+  If we take a finite family of partitions in a particular generated boolean algebra, where each
+  partition itself is finite, then their induced partition is also in the algebra.\<close>
+lemma family_intersect_in_gen_boolean_algebra:
+  assumes "A \<in> gen_boolean_algebra S B"
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> Ps partitions A"
+  assumes "\<And>Ps. Ps \<in> parts \<Longrightarrow> finite Ps"
+  assumes "\<And>Ps P. Ps \<in> parts \<Longrightarrow> P \<in> Ps \<Longrightarrow>  P \<in> gen_boolean_algebra S B"
+  assumes "finite parts"
+  assumes "parts \<noteq> {}"
+  shows "\<And>P. P \<in> family_intersect parts \<Longrightarrow> P \<in> gen_boolean_algebra S B"
+proof- 
+  fix P assume A: "P \<in> family_intersect parts"
+  have 0: "P \<in> atoms_of (\<Union> parts)"
+    using A unfolding family_intersect_def by blast 
+  have 1: "finite (\<Union> parts)"
+    using assms by blast 
+  have 2: "\<Union> parts \<subseteq> gen_boolean_algebra S B"
+    using assms  by blast 
+  obtain Ps where Ps_def: "Ps \<in> parts"
+    using assms by blast 
+  have 3: "\<Union> (\<Union> parts) = A"
+    apply(rule equalityI')
+    using assms is_partitionE(2)[of _ A] apply blast 
+    using assms is_partitionE(2)[of Ps A] Ps_def by blast 
+  have 4: "atoms_of (\<Union> parts) = atoms_of (gen_boolean_algebra A (\<Union> parts))"
+    apply(rule atoms_of_sets_eq_atoms_of_algebra[of "\<Union> parts" A])
+     apply(rule 1)
+    unfolding 3 by blast 
+  have 5: "atoms_of (\<Union> parts) \<subseteq>  (gen_boolean_algebra A (\<Union> parts))"
+    apply(rule atoms_of_gen_boolean_algebra)
+    using 3 gen_boolean_algebra.generator[of _ "\<Union> parts" A] 
+     apply (meson Sup_upper gen_boolean_algebra_generators subsetI)
+    by(rule 1)
+  have 6: "A \<subseteq> S"
+    using assms gen_boolean_algebra_subset by blast  
+  have 7: "(gen_boolean_algebra A (\<Union> parts)) \<subseteq> gen_boolean_algebra (S) (\<Union> parts)"
+    apply(rule gen_boolean_algebra_univ_mono) 
+    using 3 gen_boolean_algebra_finite_union[of "\<Union> parts" "S" "\<Union> parts"]
+          gen_boolean_algebra.generator[of _ "\<Union> parts" "S" ] 6 1 
+    by (meson Sup_le_iff gen_boolean_algebra_generators)
+  have 8: "gen_boolean_algebra (S) (\<Union> parts) \<subseteq> gen_boolean_algebra S B"
+    apply(rule gen_boolean_algebra_subalgebra)
+    using 2  by blast 
+  show "P \<in> gen_boolean_algebra S B"
+    using 0 5 6 7 8 by blast 
+qed
+
+
+
+end
diff --git a/thys/Padic_Field/Indices.thy b/thys/Padic_Field/Indices.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Indices.thy
@@ -0,0 +1,571 @@
+theory Indices
+imports Main
+begin
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Basic Lemmas for Manipulating Indices and Lists\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+fun index_list where
+"index_list 0 = []"|
+"index_list (Suc n) = index_list n @ [n]"
+
+lemma index_list_length:
+"length (index_list n) = n"
+  by(induction n, simp, auto ) 
+
+lemma index_list_indices:
+"k < n \<Longrightarrow> (index_list n)!k = k"
+  apply(induction n)
+  apply (simp; fail)
+  by (simp add: index_list_length nth_append)
+
+lemma index_list_set:
+"set (index_list n) = {..<n}"
+  apply(induction n)
+  apply force
+  by (metis Zero_not_Suc atLeastLessThan_empty atLeastLessThan_singleton atLeastLessThan_upt 
+      diff_Suc_1 index_list.elims ivl_disj_un_singleton(2) lessI lessThan_Suc_atMost less_Suc_eq_le 
+      set_append sorted_list_of_set_empty sorted_list_of_set_range upt_rec)
+
+fun flat_map :: "('a => 'b list) => 'a list => 'b list" where
+  "flat_map f [] = []"
+ |"flat_map f (h#t) = (f h)@(flat_map f t)"
+
+abbreviation(input) project_at_indices ("\<pi>\<^bsub>_\<^esub>") where
+"project_at_indices S as \<equiv> nths as S"
+
+fun insert_at_index :: " 'a list \<Rightarrow>'a \<Rightarrow> nat \<Rightarrow> 'a list" where
+"insert_at_index as a n= (take n as) @ (a#(drop n as))"
+
+lemma insert_at_index_length:
+  shows "length (insert_at_index as a n) = length as + 1"
+  by(induction n, auto) 
+
+lemma insert_at_index_eq[simp]:
+  assumes "n \<le> length as"
+  shows "(insert_at_index as a n)!n = a"
+  by (metis assms insert_at_index.elims length_take min.absorb2 nth_append_length)
+
+lemma insert_at_index_eq'[simp]:
+  assumes "n \<le> length as"
+  assumes "k < n"
+  shows "(insert_at_index as a n)!k = as ! k"
+  using assms 
+  by (simp add: nth_append)
+
+lemma insert_at_index_eq''[simp]:
+  assumes "n < length as"
+  assumes "k \<le> n"
+  shows "(insert_at_index as a k)!(Suc n) = as ! n"  
+  using assms insert_at_index.simps[of as a k] 
+  by (smt Suc_diff_Suc append_take_drop_id diff_Suc_Suc dual_order.order_iff_strict 
+      le_imp_less_Suc length_take less_trans min.absorb2 not_le nth_Cons_Suc nth_append)
+
+text\<open>Correctness of project\_at\_indices\<close>
+
+definition indices_of :: "'a list \<Rightarrow> nat set" where
+"indices_of as = {..<(length as)}"
+
+lemma proj_at_index_list_length[simp]:
+  assumes "S \<subseteq> indices_of as"
+  shows "length (project_at_indices S as) = card S"
+proof-
+  have "S = {i. i < length as \<and> i \<in> S}"
+    using assms unfolding indices_of_def 
+    by blast
+  thus ?thesis 
+  using length_nths[of as S] by auto   
+qed
+
+text\<open>A function which enumerates finite sets\<close>
+
+abbreviation(input) set_to_list :: "nat set \<Rightarrow>  nat list" where
+"set_to_list S \<equiv> sorted_list_of_set S"
+
+lemma set_to_list_set:
+  assumes "finite S"
+  shows "set (set_to_list S) = S"
+  by (simp add: assms)
+
+lemma set_to_list_length:
+  assumes "finite S"
+  shows "length (set_to_list S) = card S"
+  by (metis assms length_remdups_card_conv length_sort set_sorted_list_of_set sorted_list_of_set_sort_remdups)
+
+lemma set_to_list_empty:
+  assumes "card S = 0"
+  shows "set_to_list S = []"
+  by (metis assms length_0_conv length_sorted_list_of_set)
+
+lemma set_to_list_first:
+  assumes "card S > 0"
+  shows "Min S = set_to_list S ! 0 "
+proof-
+  have 0: "set (set_to_list S) = S"
+    using assms card_ge_0_finite set_sorted_list_of_set by blast
+  have 1: "sorted (set_to_list S)"
+    by simp
+  show ?thesis apply(rule Min_eqI)
+    using assms card_ge_0_finite apply blast
+     apply (metis "0" "1" in_set_conv_nth less_Suc0 less_or_eq_imp_le not_less_eq sorted_iff_nth_mono_less)
+      by (metis "0" Max_in assms card_0_eq card_ge_0_finite gr_zeroI in_set_conv_nth not_less0)
+qed
+  
+lemma set_to_list_last:
+  assumes "card S > 0"
+  shows "Max S = last (set_to_list S)"
+proof-
+  have 0: "set (set_to_list S) = S"
+    using assms card_ge_0_finite set_sorted_list_of_set by blast
+  have 1: "sorted (set_to_list S)"
+    by simp
+  show ?thesis apply(rule Max_eqI)
+    using assms card_ge_0_finite apply blast
+     apply (smt "0" "1" Suc_diff_1 in_set_conv_nth last_conv_nth le_simps(2) length_greater_0_conv 
+        less_or_eq_imp_le nat_neq_iff neq0_conv not_less_eq sorted_iff_nth_mono_less)
+      by (metis "0" assms card.empty empty_set last_in_set less_numeral_extra(3))
+qed
+
+lemma set_to_list_insert_Max:
+  assumes "finite S"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> a > s"
+  shows "set_to_list (insert a S) = set_to_list S @[a]"
+  by (metis assms(1) assms(2) card_0_eq card_insert_if finite.insertI infinite_growing 
+      insert_not_empty less_imp_le_nat sorted_insort_is_snoc sorted_list_of_set(1) sorted_list_of_set(2) 
+      sorted_list_of_set_insert)
+
+lemma set_to_list_insert_Min:
+  assumes "finite S"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> a < s"
+  shows "set_to_list (insert a S) = a#set_to_list S"
+  by (metis assms(1) assms(2) insort_is_Cons nat_less_le sorted_list_of_set(1) sorted_list_of_set_insert)
+
+fun nth_elem where
+"nth_elem S n = set_to_list S ! n"
+
+lemma nth_elem_closed:
+  assumes "i < card S"
+  shows "nth_elem S i \<in> S"
+  by (metis assms card.infinite not_less0 nth_elem.elims nth_mem set_to_list_length sorted_list_of_set(1))
+
+lemma nth_elem_Min:
+  assumes "card S > 0"
+  shows "nth_elem S 0 = Min S"
+  by (simp add: assms  set_to_list_first)
+
+lemma nth_elem_Max:
+  assumes "card S > 0"
+  shows "nth_elem S (card S - 1) = Max S"
+proof-
+  have "last (set_to_list S) = set_to_list S ! (card S - 1)"
+    by (metis assms card_0_eq card_ge_0_finite last_conv_nth neq0_conv set_to_list_length sorted_list_of_set_eq_Nil_iff)
+  thus ?thesis 
+    using assms set_to_list_last set_to_list_length 
+    by simp
+qed
+
+lemma nth_elem_Suc:
+  assumes "card S > Suc n"
+  shows "nth_elem S (Suc n) > nth_elem S n"
+  using assms sorted_sorted_list_of_set[of S] set_to_list_length[of S]
+  by (metis Suc_lessD card.infinite distinct_sorted_list_of_set lessI nat_less_le not_less0 nth_elem.elims nth_eq_iff_index_eq sorted_iff_nth_mono_less)
+
+lemma nth_elem_insert_Min:
+  assumes "card S > 0"
+  assumes "a < Min S"
+  shows "nth_elem (insert a S) (Suc i) = nth_elem S i"
+  using assms  
+  by (metis Min_gr_iff card_0_eq card_ge_0_finite neq0_conv nth_Cons_Suc nth_elem.elims set_to_list_insert_Min)
+  
+lemma set_to_list_Suc_map:
+  assumes "finite S"
+  shows "set_to_list (Suc ` S) = map Suc (set_to_list S)"
+proof-
+  obtain n where n_def: "n = card S"
+    by blast 
+  have "\<And>S. card S = n \<Longrightarrow> set_to_list (Suc ` S) = map Suc (set_to_list S)"
+  proof(induction n)
+    case 0
+    then show ?case 
+      by (metis card_eq_0_iff finite_imageD image_is_empty inj_Suc list.simps(8) set_to_list_empty)
+  next
+    case (Suc n)
+    have 0: "S = insert (Min S) (S - {Min S})"
+      by (metis Min_in Suc.prems card_gt_0_iff insert_Diff zero_less_Suc)
+    have 1: "sorted_list_of_set (Suc ` (S - {Min S})) = map Suc (sorted_list_of_set (S - {Min S}))"
+      by (metis "0" Suc.IH Suc.prems card_Diff_singleton card.infinite diff_Suc_1 insertI1 nat.simps(3))
+    have 2: "set_to_list S = (Min S)#(set_to_list (S - {Min S}))"
+      by (metis "0" DiffD1 Min_le Suc.prems card_Diff_singleton card.infinite card_insert_if  
+          diff_Suc_1 finite_Diff n_not_Suc_n nat.simps(3) nat_less_le set_to_list_insert_Min)
+    have 3: "sorted_list_of_set (Suc ` S) = (Min (Suc ` S))#(set_to_list ((Suc ` S) - {Min (Suc ` S)}))"
+      by (metis DiffD1 Diff_idemp Min_in Min_le Suc.prems card_Diff1_less card_eq_0_iff finite_Diff 
+          finite_imageI image_is_empty insert_Diff nat.simps(3) nat_less_le set_to_list_insert_Min)
+    have 4: "(Min (Suc ` S)) = Suc (Min S)"
+      by (metis Min.hom_commute Suc.prems Suc_le_mono card_eq_0_iff min_def nat.simps(3))
+    have 5: "sorted_list_of_set (Suc ` S) = Suc (Min S)#(set_to_list ((Suc ` S) - {Suc (Min S)}))"
+      using 3 4 by auto 
+    have 6: "sorted_list_of_set (Suc ` S) = Suc (Min S)#(set_to_list (Suc ` (S - {Min S})))"
+      by (metis (no_types, lifting) "0" "5" Diff_insert_absorb image_insert inj_Suc inj_on_insert)
+    show ?case 
+      using 6 
+      by (simp add: "1" "2")
+  qed  
+  thus ?thesis 
+    using n_def by blast
+qed
+
+lemma nth_elem_Suc_im:
+  assumes "i < card S"
+  shows "nth_elem (Suc ` S) i = Suc (nth_elem S i) "
+  using set_to_list_Suc_map 
+  by (metis assms card_ge_0_finite dual_order.strict_trans not_gr0 nth_elem.elims nth_map set_to_list_length)
+
+lemma set_to_list_upto:
+"set_to_list {..<n} = [0..<n]"
+  by (simp add: lessThan_atLeast0)
+
+lemma nth_elem_upto:
+  assumes "i < n"
+  shows "nth_elem {..<n} i = i"
+  using set_to_list_upto 
+  by (simp add: assms)
+
+text\<open>Characterizing the entries of project\_at\_indices \<close>
+
+lemma project_at_indices_append:
+"project_at_indices S (as@bs) = project_at_indices S as @ project_at_indices {j. j + length as \<in> S} bs"
+  using nths_append[of as bs S] by auto 
+
+lemma project_at_indices_nth:
+  assumes "S \<subseteq> indices_of as"
+  assumes "card S > i"
+  shows "project_at_indices S as ! i = as ! (nth_elem S i)"
+proof-
+  have "\<And> S i. S \<subseteq> indices_of as \<and> card S > i \<Longrightarrow> project_at_indices S as ! i = as ! (nth_elem S i)"
+  proof(induction as)
+    case Nil
+    then show ?case 
+      by (metis list.size(3) not_less0 nths_nil proj_at_index_list_length)   
+  next
+    case (Cons a as)
+    assume A: "S \<subseteq> indices_of (a # as) \<and> i < card S"
+    have 0: "nths (a # as) S = (if 0 \<in> S then [a] else []) @ nths as {j. Suc j \<in> S}"
+      using nths_Cons[of a as S] by simp 
+    show "nths (a # as) S ! i = (a # as) ! nth_elem S i"
+    proof(cases "0 \<in> S")
+      case True
+      show ?thesis 
+      proof(cases "S = {0}")
+        case True
+        then show ?thesis 
+          using "0" Cons.prems  by auto        
+      next
+        case False
+        have T0: "nths (a # as) S = a#nths as {j. Suc j \<in> S}"
+          using 0 
+          by (simp add: True)
+        have T1: "{j. Suc j \<in> S} \<subseteq> indices_of as"
+        proof fix x assume A: "x \<in> {j. Suc j \<in> S}"
+          then have "Suc x < length (a#as)" 
+          using Cons.prems indices_of_def by blast
+         then show "x \<in> indices_of as"
+          by (simp add: indices_of_def)
+        qed
+        have T2: "\<And>i.  i < card {j. Suc j \<in> S} \<Longrightarrow> nths as {j. Suc j \<in> S} ! i = as ! nth_elem {j. Suc j \<in> S} i"
+          using Cons.IH T1 by blast
+        have T3: "\<And>i.  i < card {j. Suc j \<in> S} \<Longrightarrow> nth_elem {j. j > 0 \<and> j\<in> S} i = nth_elem S (Suc i)"
+        proof-
+          have 0: " 0 < card {j. Suc j \<in> S}" 
+            by (smt Cons.prems Diff_iff Diff_subset False T0 T1 True add_diff_cancel_left' 
+                card.insert card_0_eq card.infinite finite_subset gr_zeroI insert_Diff 
+                length_Cons n_not_Suc_n plus_1_eq_Suc proj_at_index_list_length singletonI)
+          have 1: "(insert 0 {j. 0 < j \<and> j \<in> S}) = S"
+            apply(rule set_eqI) using True  gr0I by blast
+          have 2: "0 < Min {j. 0 < j \<and> j \<in> S}" using False 
+            by (metis (mono_tags, lifting) "1" Cons.prems Min_in finite_insert finite_lessThan
+                finite_subset indices_of_def less_Suc_eq less_Suc_eq_0_disj mem_Collect_eq singleton_conv)    
+          show "\<And>i. i < card {j. Suc j \<in> S} \<Longrightarrow> nth_elem {j. 0 < j \<and> j \<in> S} i = nth_elem S (Suc i)"
+            using 0 1 2 nth_elem_insert_Min[of "{j. 0 < j \<and> j \<in> S}" 0] True False 
+            by (metis (no_types, lifting) Cons.prems T0 T1 card_gt_0_iff finite_insert length_Cons less_SucI proj_at_index_list_length)
+        qed      
+        show "nths (a # as) S ! i = (a # as) ! nth_elem S i"
+          apply(cases "i = 0")
+           apply (metis Cons.prems Min_le T0 True card_ge_0_finite le_zero_eq nth_Cons' nth_elem_Min)           
+        proof-
+          assume "i \<noteq> 0"
+          then have "i = Suc (i - 1)"
+            using Suc_pred' by blast
+          hence "nths (a # as) S ! i = nths as {j. Suc j \<in> S} ! (i-1)"
+            using A by (simp add: T0)
+          thus "nths (a # as) S ! i = (a # as) ! nth_elem S i"
+          proof-
+            have "i - 1 < card {j. Suc j \<in> S}"
+              by (metis Cons.prems Suc_less_SucD T0 T1 \<open>i = Suc (i - 1)\<close> length_Cons proj_at_index_list_length)
+            hence 0: "nth_elem {j. 0 < j \<and> j \<in> S} (i - 1) = nth_elem S i" 
+              using T3[of "i-1"] \<open>i = Suc (i - 1)\<close> by auto   
+
+            have 1: "nths as {j. Suc j \<in> S} ! (i-1) = as ! nth_elem {j. Suc j \<in> S} (i-1)"
+              using T2 \<open>i - 1 < card {j. Suc j \<in> S}\<close> by blast
+            have 2: "(a # as) ! nth_elem S i = as! ((nth_elem S i) - 1)"
+              by (metis Cons.prems \<open>i = Suc (i - 1)\<close> not_less0 nth_Cons' nth_elem_Suc)
+            have 3: "(nth_elem S i) - 1 = nth_elem {j. Suc j \<in> S} (i-1)"
+            proof-
+              have "Suc ` {j. Suc j \<in> S} = {j. 0 < j \<and> j \<in> S}"
+              proof
+                show "Suc ` {j. Suc j \<in> S} \<subseteq> {j. 0 < j \<and> j \<in> S}"
+                  by blast
+                show "{j. 0 < j \<and> j \<in> S} \<subseteq> Suc ` {j. Suc j \<in> S}"
+                  using Suc_pred gr0_conv_Suc by auto
+              qed
+              thus ?thesis 
+                using "0" \<open>i - 1 < card {j. Suc j \<in> S}\<close> nth_elem_Suc_im by fastforce
+            qed
+            show "nths (a # as) S ! i = (a # as) ! nth_elem S i"
+              using "1" "2" "3" \<open>nths (a # as) S ! i = nths as {j. Suc j \<in> S} ! (i - 1)\<close> by auto
+          qed
+        qed
+      qed
+    next
+      case False
+      have F0: "nths (a # as) S = nths as {j. Suc j \<in> S}"
+        by (simp add: "0" False)
+      have F1: "Suc `{j. Suc j \<in> S} = S"
+      proof show "Suc ` {j. Suc j \<in> S} \<subseteq> S" by auto 
+            show "S \<subseteq> Suc ` {j. Suc j \<in> S}"  using False Suc_pred  
+                by (smt image_iff mem_Collect_eq neq0_conv subsetI)
+      qed
+      have F2: "{j. Suc j \<in> S} \<subseteq> indices_of as \<and> i < card {j. Suc j \<in> S}"
+        using F1 
+        by (metis (mono_tags, lifting) A F0 Suc_less_SucD indices_of_def length_Cons lessThan_iff
+            mem_Collect_eq proj_at_index_list_length subset_iff)        
+      have F3: "project_at_indices {j. Suc j \<in> S} as ! i = as ! (nth_elem {j. Suc j \<in> S} i)"
+        using F2 Cons(1)[of "{j. Suc j \<in> S}"] Cons(2)
+        by blast
+      then show ?thesis 
+        using F0 F1 F2 nth_elem_Suc_im by fastforce
+    qed
+  qed
+  then show ?thesis 
+    using assms(1) assms(2) by blast
+qed
+
+text\<open>An inverse for nth\_elem\<close>
+
+definition set_rank where
+"set_rank S x = (THE i. i < card S \<and> x = nth_elem S i)"
+
+lemma set_rank_exist:
+  assumes "finite S"
+  assumes "x \<in> S"
+  shows "\<exists>i. i < card S \<and> x = nth_elem S i"
+  using assms nth_elem.simps[of S]
+  by (metis in_set_conv_nth set_to_list_length sorted_list_of_set(1))  
+
+lemma set_rank_unique:
+  assumes "finite S"
+  assumes "x \<in> S"
+  assumes "i < card S \<and> x = nth_elem S i"
+  assumes "j < card S \<and> x = nth_elem S j"
+  shows "i = j"
+  using assms nth_elem.simps[of S]
+  by (simp add: \<open>i < card S \<and> x = nth_elem S i\<close> \<open>j < card S \<and> x = nth_elem S j\<close>
+      nth_eq_iff_index_eq set_to_list_length)
+
+lemma nth_elem_set_rank_inv:
+  assumes "finite S"
+  assumes "x \<in> S"
+  shows "nth_elem S (set_rank S x) = x"
+  using the_equality  set_rank_unique set_rank_exist assms 
+  unfolding set_rank_def 
+  by smt
+
+lemma set_rank_nth_elem_inv:
+  assumes "finite S"
+  assumes "i < card S"
+  shows "set_rank S (nth_elem S i) = i"
+  using the_equality  set_rank_unique set_rank_exist assms 
+  unfolding set_rank_def 
+proof -
+  show "(THE n. n < card S \<and> nth_elem S i = nth_elem S n) = i"
+    using assms(1) assms(2) nth_elem_closed set_rank_unique by blast
+qed
+ 
+lemma set_rank_range:
+  assumes "finite S"
+  assumes "x \<in> S"
+  shows "set_rank S x < card S"
+  using assms(1) assms(2) set_rank_exist set_rank_nth_elem_inv by fastforce
+
+lemma project_at_indices_nth':
+  assumes "S \<subseteq> indices_of as"
+  assumes "i \<in> S"
+  shows "as ! i = project_at_indices S as ! (set_rank S i) "
+  by (metis assms(1) assms(2) finite_lessThan finite_subset indices_of_def nth_elem_set_rank_inv 
+      project_at_indices_nth set_rank_range)
+
+fun proj_away_from_index :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list" ("\<pi>\<^bsub>\<noteq>_\<^esub>")where
+"proj_away_from_index n as = (take n as)@(drop (Suc n) as)"
+
+text\<open>proj\_away\_from\_index is an inverse to insert\_at\_index\<close>
+
+lemma insert_at_index_project_away[simp]:
+  assumes "k < length as"
+  assumes "bs = (insert_at_index as a k)"
+  shows "\<pi>\<^bsub>\<noteq> k\<^esub> bs = as"
+  using assms insert_at_index.simps[of as a k] proj_away_from_index.simps[of k bs]
+  by (simp add: \<open>k < length as\<close> less_imp_le_nat min.absorb2)
+
+definition fibred_cell :: "'a list set \<Rightarrow> ('a list \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list set" where 
+"fibred_cell C P = {as . \<exists>x t. as = (t#x) \<and> x \<in> C \<and> (P x t)}"
+
+definition fibred_cell_at_ind :: "nat \<Rightarrow> 'a list set \<Rightarrow> ('a list \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list set" where
+"fibred_cell_at_ind n C P = {as . \<exists>x t. as = (insert_at_index x t n) \<and> x \<in> C \<and> (P x t)}"
+
+lemma fibred_cell_lengths:
+  assumes "\<And>k. k \<in> C \<Longrightarrow> length k = n"
+  shows "k \<in> (fibred_cell C P) \<Longrightarrow> length k = Suc n"
+proof-
+  assume "k \<in> (fibred_cell C P)"
+  obtain x t where "k = (t#x) \<and> x \<in> C \<and> P x t"
+  proof -
+    assume a1: "\<And>t x. k = t # x \<and> x \<in> C \<and> P x t \<Longrightarrow> thesis"
+    have "\<exists>as a. k = a # as \<and> as \<in> C \<and> P as a"
+      using \<open>k \<in> fibred_cell C P\<close> fibred_cell_def by blast
+    then show ?thesis
+      using a1 by blast
+  qed
+  then show ?thesis 
+    by (simp add: assms)
+qed
+
+lemma fibred_cell_at_ind_lengths:
+  assumes "\<And>k. k \<in> C \<Longrightarrow> length k = n"
+  assumes "k \<le> n"
+  shows "c \<in> (fibred_cell_at_ind k C P) \<Longrightarrow> length c = Suc n"
+proof-
+  assume "c \<in> (fibred_cell_at_ind k C P)"
+  then obtain x t where "c = (insert_at_index x t k) \<and> x \<in> C \<and> (P x t)"
+    using assms
+    unfolding fibred_cell_at_ind_def 
+    by blast
+  then show ?thesis 
+    by (simp add: assms(1))   
+qed
+
+lemma project_fibred_cell:
+  assumes "\<And>k. k \<in> C \<Longrightarrow> length k = n"
+  assumes "k < n"
+  assumes "\<forall>x \<in> C. \<exists>t. P x t"
+  shows "\<pi>\<^bsub>\<noteq> k\<^esub> ` (fibred_cell_at_ind k C P) = C"
+proof
+  show "\<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P \<subseteq> C"
+  proof
+    fix x
+    assume x_def: "x \<in> \<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P"
+    then obtain c where c_def: "x = \<pi>\<^bsub>\<noteq>k\<^esub> c \<and> c \<in>  fibred_cell_at_ind k C P"
+      by blast
+    then obtain y t where yt_def: "c = (insert_at_index y t k) \<and> y \<in> C \<and> (P y t)"
+      using assms
+      unfolding fibred_cell_at_ind_def 
+      by blast
+    have 0: "x =\<pi>\<^bsub>\<noteq>k\<^esub> c"
+      by (simp add: c_def)
+    have 1: "y =\<pi>\<^bsub>\<noteq>k\<^esub> c"
+      using yt_def  assms(1) assms(2)
+      by (metis insert_at_index_project_away)      
+    have 2: "x = y" using 0 1 by auto 
+    then show "x \<in> C"
+      by (simp add: yt_def)
+  qed
+  show "C \<subseteq> \<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P"
+  proof fix x
+    assume A: "x \<in> C"
+    obtain t where t_def: "P x t"
+      using assms A by auto 
+    then show "x \<in> \<pi>\<^bsub>\<noteq>k\<^esub> ` fibred_cell_at_ind k C P"
+    proof -
+      have f1: "\<forall>a n A as. take n as @ (a::'a) # drop n as \<notin> A \<or> as \<in> \<pi>\<^bsub>\<noteq>n\<^esub> ` A \<or> \<not> n < length as"
+        by (metis insert_at_index.simps insert_at_index_project_away rev_image_eqI)        
+      have "\<forall>n. \<exists>as a. take n x @ t # drop n x = insert_at_index as a n \<and> as \<in> C \<and> P as a"
+        using A t_def by auto 
+      then have "\<forall>n. take n x @ t # drop n x \<in> {insert_at_index as a n |as a. as \<in> C \<and> P as a}"
+        by blast
+      then have "x \<in> \<pi>\<^bsub>\<noteq>k\<^esub> ` {insert_at_index as a k |as a. as \<in> C \<and> P as a}"
+        using f1 by (metis (lifting) A assms(1) assms(2))
+      then show ?thesis
+        by (simp add: fibred_cell_at_ind_def)
+    qed
+  qed
+qed
+
+definition list_segment where
+"list_segment i j as = map (nth as)  [i..<j]"
+
+lemma list_segment_length:
+  assumes "i \<le> j"
+  assumes "j \<le>  length as"
+  shows "length (list_segment i j as) = j - i"
+  using  assms 
+  unfolding list_segment_def   
+  by (metis length_map length_upt)
+
+lemma list_segment_drop:
+  assumes "i < length as"
+  shows "(list_segment i (length as) as) = drop i  as"
+  by (metis One_nat_def Suc_diff_Suc add_diff_inverse_nat drop0  drop_map drop_upt
+      less_Suc_eq list_segment_def map_nth neq0_conv not_less0 plus_1_eq_Suc)
+  
+lemma list_segment_concat:
+  assumes "j \<le> k"
+  assumes "i \<le> j"
+  shows "(list_segment i j as) @ (list_segment j k as) = (list_segment i k as)"
+  using assms   unfolding list_segment_def 
+  using le_Suc_ex upt_add_eq_append 
+  by fastforce
+
+lemma list_segment_subset:
+  assumes "j \<le> k"
+  shows "set (list_segment i j as) \<subseteq> set (list_segment i k as)"
+  apply(cases "i > j")
+  unfolding list_segment_def 
+  apply (metis in_set_conv_nth length_map list.size(3) order.asym subsetI upt_rec zero_order(3))
+proof-
+  assume "\<not> j < i"
+  then have "i \<le>j"
+    using not_le 
+    by blast
+  then have "list_segment i j as @ list_segment j k as = list_segment i k as"
+    using assms list_segment_concat[of j k i as] by auto 
+  then show "set (map ((!) as) [i..<j]) \<subseteq> set (map ((!) as) [i..<k])" 
+    using set_append  unfolding list_segment_def 
+    by (metis Un_upper1)
+qed
+
+lemma list_segment_subset_list_set:
+  assumes "j \<le> length as"
+  shows "set (list_segment i j as) \<subseteq> set as"
+  apply(cases "i \<ge> j")
+  apply (simp add: list_segment_def)
+proof-
+  assume A: "\<not> j \<le> i"
+  then have B: "i < j"
+    by auto 
+  have 0: "list_segment i (length as) as = drop i as"
+    using B assms list_segment_drop[of i as] less_le_trans 
+    by blast
+  have 1: "set (list_segment i j as) \<subseteq> set (list_segment i (length as) as)"
+    using B assms list_segment_subset[of j "length as" i as] 
+    by blast
+  then show ?thesis 
+  using assms 0 dual_order.trans  set_drop_subset[of i as]
+    by metis
+qed
+
+definition fun_inv where 
+"fun_inv = inv"
+
+
+
+end
diff --git a/thys/Padic_Field/Padic_Field_Polynomials.thy b/thys/Padic_Field/Padic_Field_Polynomials.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Padic_Field_Polynomials.thy
@@ -0,0 +1,1811 @@
+theory Padic_Field_Polynomials
+  imports Padic_Fields
+
+begin 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>$p$-adic Univariate Polynomials and Hensel's Lemma\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+type_synonym padic_field_poly = "nat \<Rightarrow> padic_number"
+
+type_synonym padic_field_fun = "padic_number \<Rightarrow> padic_number"
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Gauss Norms of Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text \<open>
+  The Gauss norm of a polynomial is defined to be the minimum valuation of a coefficient of that 
+  polynomial. This induces a valuation on the ring of polynomials, and in particular it satisfies 
+  the ultrametric inequality. In addition, the Gauss norm of a polynomial $f(x)$ gives a lower 
+  bound for the value $\text{val } (f(a))$ in terms of $\text{val }(a)$, for a point 
+  $a \in \mathbb{Q}_p$. We introduce Gauss norms here as a useful tool for stating and proving 
+  Hensel's Lemma for the field $\mathbb{Q}_p$. We are abusing terminology slightly in calling 
+  this the Gauss norm, rather than the Gauss valuation, but this is just to conform with our 
+  decision to work exclusively with the $p$-adic valuation and not discuss the equivalent 
+  real-valued $p$-adic norm. For a detailed treatment of Gauss norms one can see, for example
+  \cite{engler2005valued}.
+\<close>
+context padic_fields
+begin
+
+no_notation Zp.to_fun (infixl\<open>\<bullet>\<close> 70)
+
+abbreviation(input) Q\<^sub>p_x where
+"Q\<^sub>p_x \<equiv> UP Q\<^sub>p"
+
+definition gauss_norm where
+"gauss_norm g = Min (val ` g ` {..degree g}) "
+
+lemma gauss_normE:  
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  shows "gauss_norm g \<le> val (g k)" 
+  apply(cases "k \<le> degree g")
+  unfolding gauss_norm_def 
+  using assms apply auto[1]  
+proof-
+  assume "\<not> k \<le> degree g"
+  then have "g k = \<zero>\<^bsub>Q\<^sub>p\<^esub> "
+    by (simp add: UPQ.deg_leE assms)    
+  then show "Min (val ` g ` {..deg Q\<^sub>p g}) \<le> val (g k)"
+    by (simp add: local.val_zero)    
+qed
+
+lemma gauss_norm_geqI:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>n. val (g n) \<ge> \<alpha>"
+  shows "gauss_norm g \<ge> \<alpha>"
+  unfolding gauss_norm_def using assms 
+  by simp
+
+lemma gauss_norm_eqI:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>n. val (g n) \<ge> \<alpha>"
+  assumes "val (g i) = \<alpha>"
+  shows "gauss_norm g = \<alpha>"
+proof- 
+  have 0: "gauss_norm g \<le> \<alpha>"
+    using assms gauss_normE gauss_norm_def by fastforce
+  have 1: "gauss_norm g \<ge> \<alpha>"
+    using assms gauss_norm_geqI by auto 
+  show ?thesis using 0 1 by auto 
+qed
+
+lemma nonzero_poly_nonzero_coeff:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "g \<noteq> \<zero>\<^bsub>Q\<^sub>p_x\<^esub>"
+  shows "\<exists>k. k \<le>degree g \<and> g k \<noteq>\<zero>\<^bsub>Q\<^sub>p\<^esub>"
+proof(rule ccontr)
+  assume "\<not> (\<exists>k\<le>degree g. g k \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>)"
+  then have 0: "\<And>k. g k = \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+    by (meson UPQ.deg_leE assms(1) not_le_imp_less)
+  then show False 
+    using assms  UPQ.cfs_zero by blast
+qed 
+
+lemma gauss_norm_prop:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "g \<noteq> \<zero>\<^bsub>Q\<^sub>p_x\<^esub>"
+  shows "gauss_norm g \<noteq> \<infinity>"
+proof- 
+  obtain k where k_def: "k \<le>degree g \<and> g k \<noteq>\<zero>\<^bsub>Q\<^sub>p\<^esub>"
+    using assms nonzero_poly_nonzero_coeff 
+    by blast
+  then have 0: "gauss_norm g \<le> val (g k)"
+    using assms(1) gauss_normE by blast
+  have "g k \<in> carrier Q\<^sub>p"
+    using UPQ.cfs_closed assms(1) by blast    
+  hence "val (g k) < \<infinity>"
+    using k_def assms  
+    by (metis eint_ord_code(3) eint_ord_simps(4) val_ineq)
+  then show ?thesis 
+    using 0 not_le by fastforce   
+qed
+
+lemma gauss_norm_coeff_norm:
+  "\<exists>n \<le> degree g. (gauss_norm g) = val (g n)"
+proof-
+  have "finite (val ` g ` {..deg Q\<^sub>p g})"
+    by blast
+  hence "\<exists>x \<in> (val ` g ` {..deg Q\<^sub>p g}). gauss_norm g = x"
+  unfolding gauss_norm_def
+  by auto 
+  thus ?thesis unfolding gauss_norm_def 
+    by blast 
+qed
+
+lemma gauss_norm_smult_cfs:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "gauss_norm g = val (g k)"
+  shows "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) = val a + val (g k)"
+proof-
+  obtain l where l_def: "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) =  val ((a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) l)"
+    using gauss_norm_coeff_norm 
+    by blast
+  then have "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) =  val (a \<otimes>\<^bsub>Q\<^sub>p\<^esub> (g l))"
+    using assms 
+    by simp   
+  then have "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) =  val a + val (g l)"
+    by (simp add: UPQ.cfs_closed assms(1) assms(2) val_mult)            
+  then have 0: "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) \<le> val a +val (g k)"
+    using assms  gauss_normE[of g l]
+    by (metis UPQ.UP_smult_closed UPQ.cfs_closed UPQ.cfs_smult gauss_normE val_mult)          
+  have "val a + val (g k) = val ((a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) k)"
+    by (simp add: UPQ.cfs_closed assms(1) assms(2) val_mult)       
+  then have "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) \<ge> val a + val (g k)"
+    by (metis \<open>gauss_norm (a \<odot>\<^bsub>UP Q\<^sub>p\<^esub> g) = val a + val (g l)\<close> add_left_mono assms(1) assms(3) gauss_normE)   
+  then show ?thesis 
+    using 0  by auto     
+qed
+
+lemma gauss_norm_smult:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "gauss_norm (a \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g) = val a + gauss_norm g"
+  using gauss_norm_smult_cfs[of g a] gauss_norm_coeff_norm[of g] assms 
+  by metis
+
+lemma gauss_norm_ultrametric:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "h \<in> carrier Q\<^sub>p_x"
+  shows "gauss_norm (g \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> h) \<ge> min (gauss_norm g) (gauss_norm h)"
+proof-
+  obtain k where "gauss_norm (g \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> h) = val ((g \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> h) k)"
+    using gauss_norm_coeff_norm 
+    by blast
+  then have 0: "gauss_norm (g \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> h) = val (g k \<oplus>\<^bsub>Q\<^sub>p\<^esub> h k)"
+    by (simp add: assms(1) assms(2))      
+  have "min (val (g k)) (val (h k))\<ge> min (gauss_norm g) (gauss_norm h)"
+    using gauss_normE[of g k] gauss_normE[of h k]  assms(1) assms(2) min.mono 
+    by blast    
+  then show ?thesis 
+    using 0 val_ultrametric[of "g k" "h k"] assms(1) assms(2) dual_order.trans 
+    by (metis (no_types, lifting) UPQ.cfs_closed)         
+qed
+
+lemma gauss_norm_a_inv: 
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  shows "gauss_norm (\<ominus>\<^bsub>UP Q\<^sub>p\<^esub>f) = gauss_norm f"
+proof- 
+  have 0: "\<And>n. ((\<ominus>\<^bsub>UP Q\<^sub>p\<^esub>f) n) = \<ominus> (f n)"
+    using assms by simp
+  have 1: "\<And>n. val ((\<ominus>\<^bsub>UP Q\<^sub>p\<^esub>f) n) = val (f n)"
+    using 0 assms UPQ.UP_car_memE(1) val_minus by presburger
+  obtain i where i_def: "gauss_norm f = val (f i)"
+    using assms gauss_norm_coeff_norm by blast
+  have 2: "\<And>k. val ((\<ominus>\<^bsub>UP Q\<^sub>p\<^esub>f) k) \<ge> val (f i)"
+    unfolding 1 
+    using i_def assms gauss_normE by fastforce
+  show ?thesis 
+    apply(rule gauss_norm_eqI[of _ _ i])
+      apply (simp add: assms; fail)
+    unfolding 1 using assms gauss_normE apply blast
+    unfolding i_def by blast 
+qed
+
+lemma gauss_norm_ultrametric':
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "gauss_norm (f \<ominus>\<^bsub>UP Q\<^sub>p\<^esub> g) \<ge> min (gauss_norm f) (gauss_norm g)"
+  unfolding a_minus_def 
+  using assms gauss_norm_a_inv[of g] gauss_norm_ultrametric 
+  by (metis UPQ.UP_a_inv_closed)
+
+lemma gauss_norm_finsum:
+  assumes "f \<in> A \<rightarrow> carrier Q\<^sub>p_x"
+  assumes "finite A"
+  assumes "A \<noteq> {}"
+  shows " gauss_norm (\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) \<ge> Min (gauss_norm ` (f`A))"  
+proof-
+  obtain k where k_def: "val ((\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) k) = gauss_norm (\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i)"
+    by (metis gauss_norm_coeff_norm)
+  then have 0: "val (\<Oplus>\<^bsub>Q\<^sub>p\<^esub>i\<in>A. f i k) \<ge> Min (val ` (\<lambda> i. f i k) ` A)"
+    using finsum_val_ultrametric[of "\<lambda> i. f i k" A] assms 
+    by (simp add: \<open>\<lbrakk>(\<lambda>i. f i k) \<in> A \<rightarrow> carrier Q\<^sub>p; finite A; A \<noteq> {}\<rbrakk> \<Longrightarrow> Min (val ` (\<lambda>i. f i k) ` A) \<le> val (\<Oplus>i\<in>A. f i k)\<close> Pi_iff UPQ.cfs_closed)      
+  have "(\<And>a. a \<in> A \<Longrightarrow> (val \<circ> (\<lambda>i. f i k)) a \<ge> gauss_norm (f a))"
+    using gauss_normE assms
+    by (metis (no_types, lifting) Pi_split_insert_domain Set.set_insert comp_apply)  
+  then have "Min (val ` (\<lambda> i. f i k) ` A) \<ge> Min ((\<lambda> i. gauss_norm (f  i)) ` A)" 
+    using Min_mono'[of A] 
+    by (simp add: assms(2) image_comp)
+  then have 1: "Min (val ` (\<lambda> i. f i k) ` A) \<ge> Min (gauss_norm ` f ` A)"
+    by (metis image_image)
+  have "f \<in> A \<rightarrow> carrier (UP Q\<^sub>p) \<longrightarrow> ((\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) \<in> carrier Q\<^sub>p_x \<and> ((\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) k) = (\<Oplus>\<^bsub>Q\<^sub>p\<^esub>i\<in>A. f i k)) "
+    apply(rule finite.induct[of A])
+      apply (simp add: assms(2); fail)
+     apply (metis (no_types, lifting) Pi_I Qp.add.finprod_one_eqI UPQ.P.finsum_closed UPQ.P.finsum_empty UPQ.cfs_zero empty_iff)        
+  proof-
+    fix a A assume A: "finite A" "f \<in> A \<rightarrow> carrier (UP Q\<^sub>p) \<longrightarrow> ( finsum (UP Q\<^sub>p) f A \<in> carrier (UP Q\<^sub>p) \<and> finsum (UP Q\<^sub>p) f A k = (\<Oplus>i\<in>A. f i k)) "
+    show " f \<in> insert a A \<rightarrow> carrier (UP Q\<^sub>p) \<longrightarrow>  finsum (UP Q\<^sub>p) f (insert a A) \<in> carrier (UP Q\<^sub>p) \<and> finsum (UP Q\<^sub>p) f (insert a A) k = (\<Oplus>i\<in>insert a A. f i k)"
+      apply(cases "a \<in> A")
+      using A 
+      apply (simp add: insert_absorb; fail)
+    proof assume B: "a \<notin> A" " f \<in> insert a A \<rightarrow> carrier (UP Q\<^sub>p)"
+      then have f_a: "f a \<in> carrier (UP Q\<^sub>p)"
+        by blast 
+      have f_A: "f \<in> A \<rightarrow> carrier (UP Q\<^sub>p)"
+        using B by blast 
+      have "finsum (UP Q\<^sub>p) f (insert a A) = f a \<oplus>\<^bsub>UP Q\<^sub>p\<^esub>finsum (UP Q\<^sub>p) f A"
+        using assms A B f_a f_A  finsum_insert by simp       
+      then have 0: "finsum (UP Q\<^sub>p) f (insert a A) k = f a k \<oplus>\<^bsub>Q\<^sub>p\<^esub> (finsum (UP Q\<^sub>p) f A) k"
+        using f_a f_A A B 
+        by simp
+      have " ( \<lambda> a. f a k) \<in> A \<rightarrow> carrier Q\<^sub>p"
+      proof fix a assume "a \<in> A"
+        then have "f a \<in> carrier (UP Q\<^sub>p)"
+          using f_A by blast 
+        then show "f a k \<in> carrier Q\<^sub>p"
+          using A cfs_closed by blast 
+      qed 
+      then have 0: "finsum (UP Q\<^sub>p) f (insert a A) k = (\<Oplus>i\<in>insert a A. f i k)"
+        using A B Qp.finsum_insert[of A a "\<lambda> a. f a k"] 
+        by (simp add: UPQ.cfs_closed)        
+      thus " finsum (UP Q\<^sub>p) f (insert a A) \<in> carrier (UP Q\<^sub>p) \<and> finsum (UP Q\<^sub>p) f (insert a A) k = (\<Oplus>i\<in>insert a A. f i k)"
+        using B(2) UPQ.P.finsum_closed by blast
+    qed        
+  qed   
+  then have "(\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) \<in> carrier Q\<^sub>p_x \<and> ((\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) k) = (\<Oplus>\<^bsub>Q\<^sub>p\<^esub>i\<in>A. f i k)"
+    using assms by blast 
+  hence 3: "gauss_norm (\<Oplus>\<^bsub>Q\<^sub>p_x\<^esub>i\<in>A. f i) \<ge> Min (val ` (\<lambda> i. f i k) ` A)"
+    using 0  k_def by auto 
+  thus ?thesis 
+    using 1 le_trans by auto 
+qed
+
+lemma gauss_norm_monom:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "gauss_norm (monom Q\<^sub>p_x a n) = val a"
+proof-
+  have "val ((monom Q\<^sub>p_x a n) n) \<ge> gauss_norm (monom Q\<^sub>p_x a n)"
+    using assms gauss_normE[of "monom Q\<^sub>p_x a n" n] UPQ.monom_closed 
+    by blast   
+  then show ?thesis 
+    using gauss_norm_coeff_norm[of "monom Q\<^sub>p_x a n"] assms val_ineq UPQ.cfs_monom by fastforce     
+qed
+
+lemma val_val_ring_prod:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  shows "val (a \<otimes>\<^bsub>Q\<^sub>p\<^esub> b) \<ge> val b"
+proof-
+  have 0: "val (a \<otimes>\<^bsub>Q\<^sub>p\<^esub> b) = val a + val b"
+    using assms val_ring_memE[of a] val_mult 
+    by blast
+  have 1: " val a \<ge> 0"
+    using assms 
+    by (simp add: val_ring_memE)
+  then show ?thesis 
+    using assms 0 
+    by simp   
+qed
+
+lemma val_val_ring_prod':
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  shows "val (b \<otimes>\<^bsub>Q\<^sub>p\<^esub> a) \<ge> val b"
+  using val_val_ring_prod[of a b]
+  by (simp add: Qp.m_comm val_ring_memE assms(1) assms(2)) 
+
+lemma val_ring_nat_pow_closed:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "(a[^](n::nat)) \<in> \<O>\<^sub>p"
+  apply(induction n)
+  apply auto[1]
+  using Qp.inv_one Z\<^sub>p_mem apply blast
+  by (metis Qp.nat_pow_Suc Qp.nat_pow_closed val_ring_memE assms image_eqI inc_of_prod to_Zp_closed to_Zp_inc to_Zp_mult)
+  
+lemma val_ringI:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<ge>0"
+  shows " a \<in> \<O>\<^sub>p"
+  apply(rule val_ring_val_criterion)
+  using assms by auto 
+
+notation UPQ.to_fun (infixl\<open>\<bullet>\<close> 70)
+
+lemma val_gauss_norm_eval:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "val (g \<bullet> a) \<ge> gauss_norm g"
+proof-
+  have 0: "g\<bullet>a = (\<Oplus>\<^bsub>Q\<^sub>p\<^esub>i\<in>{..degree g}. (g i)\<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i))"
+    using val_ring_memE assms to_fun_formula[of g a] by auto 
+    
+  have 1: "(\<lambda>i. g i \<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i)) \<in> {..degree g} \<rightarrow> carrier Q\<^sub>p"
+     using assms 
+    by (meson Pi_I val_ring_memE cfs_closed monom_term_car)    
+  then have 2: "val (g\<bullet>a) \<ge> Min (val ` (\<lambda> i. ((g i)\<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i))) ` {..degree g})"
+    using 0 finsum_val_ultrametric[of "\<lambda> i. ((g i)\<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i))" "{..degree g}" ]  
+    by (metis finite_atMost not_empty_eq_Iic_eq_empty)
+  have 3: "\<And> i. val ((g i)\<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i)) = val (g i) + val (a[^]i)"
+    using assms val_mult 
+    by (simp add: val_ring_memE UPQ.cfs_closed)    
+  have 4: "\<And> i. val ((g i)\<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i)) \<ge> val (g i)"    
+  proof-
+    fix i 
+    show "val ((g i)\<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i)) \<ge> val (g i)"
+      using val_val_ring_prod'[of "a[^]i" "g i" ] 
+        assms(1) assms(2) val_ring_nat_pow_closed cfs_closed 
+      by simp      
+  qed
+  have "Min (val ` (\<lambda>i. g i \<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i)) ` {..degree g}) \<ge> Min ((\<lambda>i. val (g i)) ` {..degree g})"
+    using Min_mono'[of "{..degree g}" "\<lambda>i. val (g i)" "\<lambda>i. val (g i \<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i))" ] 4 2 
+    by (metis finite_atMost image_image)
+  then have "Min (val ` (\<lambda>i. g i \<otimes>\<^bsub>Q\<^sub>p\<^esub> (a[^]i)) ` {..degree g}) \<ge> Min (val ` g ` {..degree g})"
+    by (metis  image_image)
+  then have  "val (g\<bullet>a) \<ge> Min (val ` g ` {..degree g})"
+    using 2 
+    by (meson atMost_iff atMost_subset_iff in_mono)    
+  then show ?thesis 
+    by (simp add: \<open>val (g\<bullet>a) \<ge> Min (val ` g ` {..degree g})\<close> gauss_norm_def)
+qed
+
+lemma positive_gauss_norm_eval:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "gauss_norm g \<ge> 0"
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "(g\<bullet>a) \<in> \<O>\<^sub>p"
+  apply(rule val_ring_val_criterion[of "g\<bullet>a"])
+  using assms val_ring_memE 
+  using UPQ.to_fun_closed apply blast
+  using assms val_gauss_norm_eval[of g a] by auto 
+  
+lemma positive_gauss_norm_valuation_ring_coeffs:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "gauss_norm g \<ge> 0"
+  shows "g n \<in> \<O>\<^sub>p"
+  apply(rule val_ringI)
+  using cfs_closed assms(1) apply blast
+  using gauss_normE[of g n] assms by auto  
+
+lemma val_ring_cfs_imp_nonneg_gauss_norm:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>n. g n \<in> \<O>\<^sub>p"
+  shows "gauss_norm g \<ge> 0"
+  by(rule gauss_norm_geqI, rule assms, rule val_ring_memE, rule assms)
+
+lemma val_of_add_pow:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "val ([(n::nat)]\<cdot>a) \<ge> val a"
+proof-
+  have 0: "[(n::nat)]\<cdot>a = ([n]\<cdot>\<one>)\<otimes>a"
+    using assms Qp.add_pow_ldistr Qp.cring_simprules(12) Qp.one_closed by presburger
+  have 1: "val ([(n::nat)]\<cdot>a) = val ([n]\<cdot>\<one>) + val a"
+    unfolding 0 by(rule val_mult, simp, rule assms)
+  show ?thesis unfolding 1 using assms 
+    by (simp add: val_of_nat_inc)
+qed
+
+lemma gauss_norm_pderiv:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "gauss_norm g \<le> gauss_norm (pderiv g)"
+  apply(rule gauss_norm_geqI)
+  using UPQ.pderiv_closed assms apply blast
+  using gauss_normE pderiv_cfs val_of_add_pow 
+  by (smt UPQ.cfs_closed assms dual_order.trans)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Mapping Polynomials with Value Ring Coefficients to Polynomials over $\mathbb{Z}_p$\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition to_Zp_poly where
+"to_Zp_poly g = (\<lambda>n. to_Zp (g n))"
+
+lemma to_Zp_poly_closed:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "gauss_norm g \<ge> 0"
+  shows "to_Zp_poly g \<in> carrier (UP Z\<^sub>p)"
+proof-
+  have  "to_Zp_poly g \<in> up Z\<^sub>p"
+    apply(rule mem_upI)
+   unfolding to_Zp_poly_def 
+   using cfs_closed[of g ] assms(1) to_Zp_closed[of ]  apply blast  
+  proof-
+    have "\<exists>n. bound \<zero>\<^bsub>Q\<^sub>p\<^esub> n g"
+     using UPQ.deg_leE assms(1) by auto
+    then obtain n where n_def: " bound \<zero>\<^bsub>Q\<^sub>p\<^esub> n g"
+      by blast 
+    then have " bound \<zero>\<^bsub>Z\<^sub>p\<^esub> n (\<lambda>n. to_Zp (g n))"
+      unfolding bound_def 
+      by (simp add: to_Zp_zero)
+    then show "\<exists>n. bound \<zero>\<^bsub>Z\<^sub>p\<^esub> n (\<lambda>n. to_Zp (g n))"
+      by blast
+  qed
+  then show ?thesis using UP_def[of Z\<^sub>p]
+    by simp
+qed
+
+definition poly_inc where
+"poly_inc g = (\<lambda>n::nat. \<iota> (g n))"
+
+lemma poly_inc_closed:
+  assumes "g \<in> carrier (UP Z\<^sub>p)"
+  shows "poly_inc g \<in> carrier Q\<^sub>p_x"
+proof-
+  have "poly_inc g \<in> up Q\<^sub>p"
+  proof(rule mem_upI)
+    show "\<And>n. poly_inc g n \<in> carrier Q\<^sub>p"
+    proof- fix n
+      have "g n \<in> carrier Z\<^sub>p"
+        using assms UP_def 
+        by (simp add: UP_def mem_upD)
+      then show "poly_inc g n \<in> carrier Q\<^sub>p"
+        using assms poly_inc_def[of g] inc_def[of "g n" ] inc_closed 
+        by force                   
+    qed
+    show "\<exists>n. bound \<zero>\<^bsub>Q\<^sub>p\<^esub> n (poly_inc g)"
+    proof-
+      obtain n where n_def: " bound \<zero>\<^bsub>Z\<^sub>p\<^esub> n g"
+        using assms  bound_def[of "\<zero>\<^bsub>Z\<^sub>p\<^esub>" _ g]Zp.cring_axioms UP_cring.deg_leE[of Z\<^sub>p g]
+        unfolding UP_cring_def 
+        by metis 
+      then have " bound \<zero>\<^bsub>Q\<^sub>p\<^esub> n (poly_inc g)"
+        unfolding poly_inc_def bound_def 
+        by (metis Qp.nat_inc_zero Zp.nat_inc_zero inc_of_nat)
+      then show ?thesis by blast
+    qed
+  qed
+  then show ?thesis 
+    by (simp add: \<open>poly_inc g \<in> up Q\<^sub>p\<close> UP_def)
+qed
+
+lemma poly_inc_inverse_right:
+  assumes "g \<in> carrier (UP Z\<^sub>p)"
+  shows "to_Zp_poly (poly_inc g) = g"
+proof-
+  have 0: "\<And>n. g n \<in> carrier Z\<^sub>p"
+    by (simp add: Zp.cfs_closed assms)    
+  show ?thesis 
+    unfolding to_Zp_poly_def poly_inc_def
+  proof
+    fix n
+    show "to_Zp (\<iota> (g n)) = g n"
+      using 0 inc_to_Zp 
+      by auto
+  qed
+qed
+
+lemma poly_inc_inverse_left:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "gauss_norm g \<ge>0"
+  shows "poly_inc (to_Zp_poly g) = g"
+proof
+  fix x
+  show "poly_inc (to_Zp_poly g) x = g x"
+    using assms unfolding poly_inc_def to_Zp_poly_def 
+    by (simp add: positive_gauss_norm_valuation_ring_coeffs to_Zp_inc)    
+qed
+
+lemma poly_inc_plus: 
+  assumes "f \<in> carrier (UP Z\<^sub>p)"
+  assumes "g \<in> carrier (UP Z\<^sub>p)"
+  shows "poly_inc (f \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> g) = poly_inc f \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc g"
+proof
+  fix n 
+  have 0: "poly_inc (f \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> g) n = \<iota> (f n \<oplus>\<^bsub>Z\<^sub>p\<^esub> g n)"
+    unfolding poly_inc_def using assms by auto
+  have 1: "(poly_inc f \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc g) n = poly_inc f n \<oplus> poly_inc g n"
+    by(rule cfs_add, rule poly_inc_closed, rule assms, rule poly_inc_closed, rule assms)
+  show "poly_inc (f \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> g) n = (poly_inc f \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc g) n"
+    unfolding 0 1 unfolding poly_inc_def 
+    apply(rule inc_of_sum)
+    using assms apply (simp add: Zp.cfs_closed; fail)
+        using assms by (simp add: Zp.cfs_closed)
+qed
+
+lemma poly_inc_monom:
+  assumes "a \<in> carrier Z\<^sub>p"
+  shows "poly_inc (monom (UP Z\<^sub>p) a m) = monom (UP Q\<^sub>p) (\<iota> a) m"
+proof fix n 
+  show "poly_inc (monom (UP Z\<^sub>p) a m) n = monom (UP Q\<^sub>p) (\<iota> a) m n"
+    apply(cases "m = n")
+    using assms cfs_monom[of "\<iota> a"] Zp.cfs_monom[of a] unfolding poly_inc_def 
+     apply (simp add: inc_closed; fail)
+    using assms cfs_monom[of "\<iota> a"] Zp.cfs_monom[of a] unfolding poly_inc_def 
+    by (metis Qp.nat_mult_zero Zp_nat_inc_zero inc_closed inc_of_nat)
+qed
+
+lemma poly_inc_times: 
+  assumes "f \<in> carrier (UP Z\<^sub>p)"
+  assumes "g \<in> carrier (UP Z\<^sub>p)"
+  shows "poly_inc (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> g) = poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc g"
+  apply(rule UP_ring.poly_induct3[of Z\<^sub>p])
+  apply (simp add: Zp.is_UP_ring; fail)
+  using assms apply blast
+proof- 
+  fix p q 
+  assume A: "q \<in> carrier (UP Z\<^sub>p)"  "p \<in> carrier (UP Z\<^sub>p)"
+            "poly_inc (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> p) = poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc p"
+            "poly_inc (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> q) = poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc q"
+  have 0: "(f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> (p \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> q)) = (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> p) \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> q)"
+    using assms(1) A 
+    by (simp add: Zp.P.r_distr)
+  have 1: "poly_inc (p \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> q) = poly_inc p \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc q"
+    by(rule poly_inc_plus, rule A, rule A)
+  show "poly_inc (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> (p \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> q)) = poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc (p \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> q)"
+    unfolding 0 1 using A poly_inc_closed poly_inc_plus 
+    by (simp add: UPQ.P.r_distr assms(1))
+next
+  fix a fix n::nat
+  assume A: "a \<in> carrier Z\<^sub>p"
+  show "poly_inc (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> monom (UP Z\<^sub>p) a n) =
+           poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc (monom (UP Z\<^sub>p) a n)"
+  proof
+    fix m 
+    show "poly_inc (f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> monom (UP Z\<^sub>p) a n) m =
+         (poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc (monom (UP Z\<^sub>p) a n)) m"
+    proof(cases "m < n")
+      case True
+      have T0: "(f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> monom (UP Z\<^sub>p) a n) m = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+        using True Zp.cfs_monom_mult[of f a m n] A assms 
+        by blast
+      have T1: "poly_inc (monom (UP Z\<^sub>p) a n) =  (monom (UP Q\<^sub>p) (\<iota> a) n)"
+        by(rule poly_inc_monom , rule A)
+      show ?thesis
+        unfolding T0 T1 using True 
+        by (metis A Q\<^sub>p_def T0 UPQ.cfs_monom_mult Zp_def assms(1) inc_closed padic_fields.to_Zp_zero padic_fields_axioms poly_inc_closed poly_inc_def to_Zp_inc zero_in_val_ring)
+    next
+      case False
+      then have F0: "m \<ge> n"
+        using False by simp 
+      have F1: "(f \<otimes>\<^bsub>UP Z\<^sub>p\<^esub> monom (UP Z\<^sub>p) a n) m = a \<otimes>\<^bsub>Z\<^sub>p\<^esub> f (m - n)"
+        using Zp.cfs_monom_mult_l' F0 A assms by simp 
+      have F2: "poly_inc (monom (UP Z\<^sub>p) a n)  = monom (UP Q\<^sub>p) (\<iota> a) n "
+        by(rule poly_inc_monom, rule A)
+      have F3: "(poly_inc f \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc (monom (UP Z\<^sub>p) a n)) m 
+                = (\<iota> a) \<otimes> (poly_inc f (m -n))"
+        using UPQ.cfs_monom_mult_l' F0 A assms poly_inc_closed 
+        by (simp add: F2 inc_closed)
+      show ?thesis 
+        unfolding F3 unfolding poly_inc_def F1 
+        apply(rule inc_of_prod, rule A)
+        using assms Zp.cfs_closed by blast
+    qed
+  qed
+qed
+      
+lemma poly_inc_one:
+"poly_inc (\<one>\<^bsub>UP Z\<^sub>p\<^esub>) = \<one>\<^bsub>UP Q\<^sub>p\<^esub>"
+apply(rule ext)
+  unfolding poly_inc_def 
+  using inc_of_one inc_of_zero  
+  by simp
+
+lemma poly_inc_zero:
+"poly_inc (\<zero>\<^bsub>UP Z\<^sub>p\<^esub>) = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+apply(rule ext)
+  unfolding poly_inc_def 
+  using inc_of_one inc_of_zero  
+  by simp
+
+lemma poly_inc_hom: 
+"poly_inc \<in> ring_hom (UP Z\<^sub>p) (UP Q\<^sub>p)"
+  apply(rule ring_hom_memI)
+     apply(rule poly_inc_closed, blast)
+    apply(rule poly_inc_times, blast, blast)
+   apply(rule poly_inc_plus, blast, blast)
+  by(rule poly_inc_one)
+
+lemma poly_inc_as_poly_lift_hom:
+  assumes "f \<in> carrier (UP Z\<^sub>p)"
+  shows "poly_inc f = poly_lift_hom Z\<^sub>p Q\<^sub>p \<iota> f"
+  apply(rule ext)
+  unfolding poly_inc_def 
+  using Zp.poly_lift_hom_cf[of Q\<^sub>p \<iota> f] assms UPQ.R_cring local.inc_is_hom
+  by blast
+
+lemma poly_inc_eval:
+  assumes "g \<in> carrier (UP Z\<^sub>p)"
+  assumes "a \<in> carrier Z\<^sub>p"
+  shows "to_function Q\<^sub>p (poly_inc g) (\<iota> a) = \<iota> (to_function Z\<^sub>p g a)"
+proof- 
+  have 0: "poly_inc g = poly_lift_hom Z\<^sub>p Q\<^sub>p \<iota> g"
+    using assms poly_inc_as_poly_lift_hom[of g] by blast 
+  have 1: "to_function Q\<^sub>p (poly_lift_hom Z\<^sub>p Q\<^sub>p \<iota> g) (\<iota> a) = \<iota> (to_function Z\<^sub>p g a)"
+    using Zp.poly_lift_hom_eval[of Q\<^sub>p \<iota> g a] assms inc_is_hom
+    unfolding to_fun_def Zp.to_fun_def 
+    using UPQ.R_cring by blast
+  show ?thesis unfolding 0 1 
+    by blast 
+qed
+
+lemma val_ring_poly_eval:
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And> i. f i \<in> \<O>\<^sub>p"
+  shows "\<And>x. x \<in> \<O>\<^sub>p \<Longrightarrow> f \<bullet> x \<in> \<O>\<^sub>p"
+  apply(rule positive_gauss_norm_eval, rule assms)
+  apply(rule val_ring_cfs_imp_nonneg_gauss_norm)
+  using assms by auto 
+
+lemma Zp_res_of_pow:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> carrier Z\<^sub>p"
+  assumes "a n = b n"
+  shows "(a[^]\<^bsub>Z\<^sub>p\<^esub>(k::nat)) n = (b[^]\<^bsub>Z\<^sub>p\<^esub>(k::nat)) n"
+  apply(induction k)
+  using assms Group.nat_pow_0 to_Zp_one apply metis 
+  using Zp.geometric_series_id[of a b] Zp_residue_mult_zero(1) assms(1) assms(2) assms(3)
+    pow_closed res_diff_zero_fact'' res_diff_zero_fact(1) by metis 
+
+lemma to_Zp_nat_pow:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "to_Zp (a[^](n::nat)) = (to_Zp a)[^]\<^bsub>Z\<^sub>p\<^esub>(n::nat)"
+  apply(induction n)
+  using assms Group.nat_pow_0 to_Zp_one apply metis
+  using assms to_Zp_mult[of a] Qp.m_comm Qp.nat_pow_Suc val_ring_memE pow_suc to_Zp_closed val_ring_nat_pow_closed 
+  by metis 
+
+lemma  to_Zp_res_of_pow:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "to_Zp a n = to_Zp b n"
+  shows "to_Zp (a[^](k::nat)) n = to_Zp (b[^](k::nat)) n"
+  using assms val_ring_memE Zp_res_of_pow to_Zp_closed to_Zp_nat_pow by presburger
+
+lemma poly_eval_cong:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>i. g i \<in> \<O>\<^sub>p"
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "to_Zp a k = to_Zp b k"
+  shows "to_Zp (g \<bullet> a) k = to_Zp (g \<bullet> b) k"
+proof-
+  have "(\<forall>i. g i \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (g \<bullet> a) k = to_Zp (g \<bullet> b) k"
+  proof(rule UPQ.poly_induct[of g])
+    show " g \<in> carrier (UP Q\<^sub>p)"
+      using assms by blast
+    show "\<And>p. p \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> deg Q\<^sub>p p = 0 \<Longrightarrow> (\<forall>i. p i \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (p \<bullet> a) k = to_Zp (p \<bullet> b) k"
+    proof 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"
+      obtain c where c_def: "c \<in> carrier Q\<^sub>p \<and> p = up_ring.monom (UP Q\<^sub>p) c 0"
+        using A 
+        by (metis UPQ.zcf_degree_zero UPQ.cfs_closed UPQ.trms_of_deg_leq_0 UPQ.trms_of_deg_leq_degree_f)
+      have p_eq: "p = up_ring.monom (UP Q\<^sub>p) c 0"
+        using c_def by blast 
+      have p_cfs: "p 0 = c"
+        unfolding p_eq using c_def UP_ring.cfs_monom[of Q\<^sub>p c 0 0] UPQ.P_is_UP_ring by presburger
+      have c_closed: "c \<in> \<O>\<^sub>p"
+        using p_cfs A(3) by blast
+      have 0: "(p \<bullet> a) = c"
+        unfolding p_eq using c_def assms by (meson UPQ.to_fun_const val_ring_memE(2))
+      have 1: "(p \<bullet> b) = c"
+        unfolding p_eq using c_def assms UPQ.to_fun_const val_ring_memE(2) by presburger
+      show " to_Zp (p \<bullet> a) k = to_Zp (p \<bullet> b) k"
+        unfolding 0 1 by blast 
+    qed
+    show "\<And>p. (\<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) \<longrightarrow> to_Zp (q \<bullet> a) k = to_Zp (q \<bullet> b) k) \<Longrightarrow>
+         p \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> 0 < deg Q\<^sub>p p \<Longrightarrow> (\<forall>i. p i \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (p \<bullet> a) k = to_Zp (p \<bullet> b) k"
+    proof 
+      fix p assume A: "(\<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) \<longrightarrow> to_Zp (q \<bullet> a) k = to_Zp (q \<bullet> b) k)"
+                      "p \<in> carrier (UP Q\<^sub>p)" "0 < deg Q\<^sub>p p " " \<forall>i. p i \<in> \<O>\<^sub>p"
+      obtain q where q_def: "q \<in> carrier (UP Q\<^sub>p) \<and> deg Q\<^sub>p q < deg Q\<^sub>p p \<and> p = UPQ.ltrm p \<oplus>\<^bsub>UP Q\<^sub>p\<^esub>q"
+        by (metis A(2) A(3) UPQ.ltrm_closed UPQ.ltrm_decomp UPQ.UP_a_comm)
+      have 0: "\<And>i.  p i = q i \<oplus> UPQ.ltrm p i"
+        using q_def A 
+        by (metis Qp.a_ac(2) UPQ.ltrm_closed UPQ.UP_car_memE(1) UPQ.cfs_add)
+      have 1: "\<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 p")
+          using 0[of i] A(4) A(2) q_def 
+          using UPQ.ltrm_closed UPQ.P.a_ac(2) UPQ.trunc_cfs UPQ.trunc_closed UPQ.trunc_simps(1) 
+           apply (metis Qp.r_zero UPQ.ltrm_cfs UPQ.cfs_closed UPQ.deg_leE)
+          using q_def 
+          by (metis (no_types, opaque_lifting) A(2) A(4) UPQ.P.add.m_closed UPQ.coeff_of_sum_diff_degree0 UPQ.deg_leE UPQ.equal_deg_sum UPQ.equal_deg_sum' \<open>\<And>thesis. (\<And>q. q \<in> carrier (UP Q\<^sub>p) \<and> deg Q\<^sub>p q < deg Q\<^sub>p p \<and> p = up_ring.monom (UP Q\<^sub>p) (p (deg Q\<^sub>p p)) (deg Q\<^sub>p p) \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> q \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> lessI linorder_neqE_nat)
+      qed
+      have 2: "UPQ.lcf p \<in> \<O>\<^sub>p"
+        using A(4) by blast 
+      have 3: "UPQ.ltrm p \<bullet> a = UPQ.lcf p \<otimes> a[^] deg Q\<^sub>p p"
+        apply(rule UP_cring.to_fun_monom) unfolding UP_cring_def 
+        using Qp.cring apply blast
+        using A UPQ.lcf_closed apply blast
+        using assms val_ring_memE(2) by blast
+      have 4: "UPQ.ltrm p \<bullet> b = UPQ.lcf p \<otimes> b[^] deg Q\<^sub>p p"
+        apply(rule UP_cring.to_fun_monom) unfolding UP_cring_def 
+        using Qp.cring apply blast
+        using A UPQ.lcf_closed apply blast
+        using assms val_ring_memE(2) by blast
+      have p_eq: "p = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> UPQ.ltrm p"
+        using q_def by (metis A(2) UPQ.ltrm_closed UPQ.UP_a_comm)
+      have 5: "p \<bullet> a = q \<bullet> a \<oplus>  UPQ.lcf p \<otimes> a[^] deg Q\<^sub>p p"
+        using assms val_ring_memE(2) p_eq q_def UPQ.to_fun_plus[of q "UPQ.ltrm p" a] 
+        by (metis "3" A(2) UPQ.ltrm_closed UPQ.to_fun_plus)
+      have 6: "p \<bullet> b = q \<bullet> b \<oplus>  UPQ.lcf p \<otimes> b[^] deg Q\<^sub>p p"
+        using assms val_ring_memE(2) p_eq q_def UPQ.to_fun_plus[of q "UPQ.ltrm p" a] 
+        by (metis "4" A(2) UPQ.ltrm_closed UPQ.to_fun_plus)
+      have 7: "UPQ.lcf p \<otimes> b[^] deg Q\<^sub>p p \<in> \<O>\<^sub>p"
+        apply(rule val_ring_times_closed)
+        using "2" apply linarith
+        by(rule val_ring_nat_pow_closed, rule assms)
+      have 8: "UPQ.lcf p \<otimes> a[^] deg Q\<^sub>p p \<in> \<O>\<^sub>p"
+        apply(rule val_ring_times_closed)
+        using "2" apply linarith
+        by(rule val_ring_nat_pow_closed, rule assms)
+      have 9: "q \<bullet> a \<in> \<O>\<^sub>p"
+        using q_def 1 assms(3) val_ring_poly_eval by blast
+      have 10: "q \<bullet> b \<in> \<O>\<^sub>p"
+        using q_def 1 assms(4) val_ring_poly_eval by blast 
+      have 11: "to_Zp (p \<bullet> a) = to_Zp (q \<bullet> a) \<oplus>\<^bsub>Z\<^sub>p\<^esub> to_Zp (UPQ.ltrm p \<bullet> a)"
+        using 5 8 9 to_Zp_add 3 by presburger
+      have 12: "to_Zp (p \<bullet> b) = to_Zp (q \<bullet> b) \<oplus>\<^bsub>Z\<^sub>p\<^esub> to_Zp (UPQ.ltrm p \<bullet> b)"
+        using 6 10 7 to_Zp_add 4  by presburger
+      have 13: "to_Zp (p \<bullet> a) k = to_Zp (q \<bullet> a) k \<oplus>\<^bsub>Zp_res_ring k\<^esub> to_Zp (UPQ.ltrm p \<bullet> a) k"
+        unfolding 11 using residue_of_sum by blast
+      have 14: "to_Zp (p \<bullet> b) k = to_Zp (q \<bullet> b) k \<oplus>\<^bsub>Zp_res_ring k\<^esub> to_Zp (UPQ.ltrm p \<bullet> b) k"
+        unfolding 12 using residue_of_sum by blast
+      have 15: "to_Zp (UPQ.ltrm p \<bullet> a) k = to_Zp (UPQ.ltrm p \<bullet> b) k"
+      proof(cases "k = 0")
+        case True
+        have T0: "to_Zp (UPQ.ltrm p \<bullet> a) \<in> carrier Z\<^sub>p"
+          unfolding 3 using 8  to_Zp_closed val_ring_memE(2) by blast
+        have T1: "to_Zp (UPQ.ltrm p \<bullet> b) \<in> carrier Z\<^sub>p"
+          unfolding 4 using 7 to_Zp_closed val_ring_memE(2) by blast
+        show ?thesis unfolding True using T0 T1 padic_integers.p_res_ring_0 
+          by (metis p_res_ring_0' residues_closed)       
+      next
+        case False
+        have k_pos: "k > 0"
+          using False by presburger 
+        have 150: "to_Zp (p (deg Q\<^sub>p p) \<otimes> a [^] deg Q\<^sub>p p) = to_Zp (p (deg Q\<^sub>p p)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> to_Zp( a [^] deg Q\<^sub>p p)"
+         apply(rule to_Zp_mult) 
+          using "2" apply blast
+         by(rule val_ring_nat_pow_closed, rule assms)
+        have 151: "to_Zp (p (deg Q\<^sub>p p) \<otimes> b [^] deg Q\<^sub>p p) = to_Zp (p (deg Q\<^sub>p p)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> to_Zp( b [^] deg Q\<^sub>p p)"
+         apply(rule to_Zp_mult) 
+          using "2" apply blast
+         by(rule val_ring_nat_pow_closed, rule assms)
+       have 152: "to_Zp (p (deg Q\<^sub>p p) \<otimes> a [^] deg Q\<^sub>p p) k = to_Zp (p (deg Q\<^sub>p p)) k \<otimes>\<^bsub>Zp_res_ring k\<^esub> to_Zp( a [^] deg Q\<^sub>p p) k"
+         unfolding 150 using residue_of_prod by blast
+       have 153: "to_Zp (p (deg Q\<^sub>p p) \<otimes> b [^] deg Q\<^sub>p p) k = to_Zp (p (deg Q\<^sub>p p)) k \<otimes>\<^bsub>Zp_res_ring k\<^esub> to_Zp( b [^] deg Q\<^sub>p p) k"
+         unfolding 151 using residue_of_prod by blast
+       have 154: "to_Zp( a [^] deg Q\<^sub>p p) k = to_Zp a k [^]\<^bsub>Zp_res_ring k\<^esub> deg Q\<^sub>p p"
+       proof- 
+       have 01: "\<And>m::nat. to_Zp (a[^]m) k = to_Zp a k [^]\<^bsub>Zp_res_ring k\<^esub> m"
+       proof-
+         fix m::nat show "to_Zp (a [^] m) k = to_Zp a k [^]\<^bsub>Zp_res_ring k\<^esub> m"
+       proof-
+         have 00: "to_Zp (a[^]m) = to_Zp a [^]\<^bsub>Z\<^sub>p\<^esub> m"
+         using assms to_Zp_nat_pow[of a "m"] by blast
+       have 01: "to_Zp a \<in> carrier Z\<^sub>p"
+         using assms to_Zp_closed val_ring_memE(2) by blast 
+       have 02: "to_Zp a k \<in> carrier (Zp_res_ring k)"
+         using 01 residues_closed by blast
+       have 03: "cring (Zp_res_ring k)"
+         using k_pos padic_integers.R_cring padic_integers_axioms by blast
+       have 01: "(to_Zp a [^]\<^bsub>Z\<^sub>p\<^esub> m) k = (to_Zp a) k [^]\<^bsub>Zp_res_ring k\<^esub> m"
+         apply(induction m)
+         using 01 02 apply (metis Group.nat_pow_0 k_pos residue_of_one(1))
+         using residue_of_prod[of "to_Zp a [^]\<^bsub>Z\<^sub>p\<^esub> m" "to_Zp a" k] 01 02 03 
+       proof -
+         fix ma :: nat
+         assume "(to_Zp a [^]\<^bsub>Z\<^sub>p\<^esub> ma) k = to_Zp a k [^]\<^bsub>Zp_res_ring k\<^esub> ma"
+         then show "(to_Zp a [^]\<^bsub>Z\<^sub>p\<^esub> Suc ma) k = to_Zp a k [^]\<^bsub>Zp_res_ring k\<^esub> Suc ma"
+           by (metis (no_types) Group.nat_pow_Suc residue_of_prod)
+       qed
+       show ?thesis unfolding 00 01 by blast 
+       qed
+       qed
+       thus ?thesis by blast       
+       qed
+       have 155: "to_Zp( b [^] deg Q\<^sub>p p) k = to_Zp b k [^]\<^bsub>Zp_res_ring k\<^esub> deg Q\<^sub>p p"
+         using assms by (metis "154" to_Zp_res_of_pow)
+       show ?thesis
+         unfolding 3 4 152 153 154 155 assms by blast 
+     qed
+     show "to_Zp (p \<bullet> a) k = to_Zp (p \<bullet> b) k"
+       unfolding 13 14 15 using A 1 q_def by presburger
+   qed
+  qed
+  thus ?thesis using assms by blast 
+qed
+
+lemma to_Zp_poly_eval:
+  assumes "g \<in> carrier Q\<^sub>p_x"
+  assumes "gauss_norm g \<ge> 0"
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "to_Zp (to_function Q\<^sub>p g a) = to_function Z\<^sub>p (to_Zp_poly g) (to_Zp a)"
+proof- 
+  obtain h where h_def: "h = to_Zp_poly g"
+    by blast 
+  obtain b where b_def: "b = to_Zp a"
+    by blast 
+  have h_poly_inc: "poly_inc h = g"
+    unfolding h_def using assms 
+    by (simp add: poly_inc_inverse_left)
+  have b_inc: "\<iota> b = a"
+    unfolding b_def using assms 
+    by (simp add: to_Zp_inc)
+  have h_closed: "h \<in> carrier (UP Z\<^sub>p)"
+    unfolding h_def using assms 
+    by (simp add: to_Zp_poly_closed)
+  have b_closed: "b \<in> carrier Z\<^sub>p"
+    unfolding b_def using assms 
+    by (simp add: to_Zp_closed val_ring_memE)
+  have 0: "to_function Q\<^sub>p (poly_inc h) (\<iota> b) = \<iota> (to_function Z\<^sub>p h b)"
+    apply(rule poly_inc_eval)
+    using h_def assms apply (simp add: to_Zp_poly_closed; fail)
+    unfolding b_def using assms 
+    by (simp add: to_Zp_closed val_ring_memE)
+  have 1: "to_Zp (to_function Q\<^sub>p (poly_inc h) (\<iota> b)) = to_function Z\<^sub>p h b"
+    unfolding 0 
+    using h_closed b_closed Zp.to_fun_closed Zp.to_fun_def inc_to_Zp by auto
+  show ?thesis 
+    using 1 unfolding h_poly_inc b_inc 
+    unfolding h_def b_def by blast 
+qed
+
+lemma poly_eval_equal_val:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>x. g x \<in> \<O>\<^sub>p"
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "val (g \<bullet> a) < eint n"
+  assumes "to_Zp a n = to_Zp b n"
+  shows "val (g \<bullet> b) = val (g \<bullet> a)"
+proof-
+  have "(\<forall>x. g x \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (g \<bullet> b) n = to_Zp (g \<bullet> a) n"
+  proof(rule poly_induct[of g])
+    show "g \<in> carrier (UP Q\<^sub>p)"
+      by (simp add: assms(1))
+    show "\<And>p. p \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> deg Q\<^sub>p p = 0 \<Longrightarrow> (\<forall>x. p x \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (p \<bullet> b) n = to_Zp (p \<bullet> a) n"
+    proof fix p assume A: "p \<in> carrier (UP Q\<^sub>p)" " deg Q\<^sub>p p = 0 " "\<forall>x. p x \<in> \<O>\<^sub>p "
+      show "to_Zp (p \<bullet> b) n = to_Zp (p \<bullet> a) n"
+        using A  by (metis val_ring_memE UPQ.to_fun_ctrm UPQ.trms_of_deg_leq_0 UPQ.trms_of_deg_leq_degree_f assms(3) assms(4))
+    qed
+    show "\<And>p. (\<And>q. q \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> deg Q\<^sub>p q < deg Q\<^sub>p p \<Longrightarrow> (\<forall>x. q x \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (q \<bullet> b) n = to_Zp (q \<bullet> a) n) \<Longrightarrow>
+         p \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> 0 < deg Q\<^sub>p p \<Longrightarrow> (\<forall>x. p x \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (p \<bullet> b) n = to_Zp (p \<bullet> a) n"
+    proof fix p assume IH: "(\<And>q. q \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> deg Q\<^sub>p q < deg Q\<^sub>p p \<Longrightarrow> (\<forall>x. q x \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (q \<bullet> b) n = to_Zp (q \<bullet> a) n)"
+      assume A: "p \<in> carrier (UP Q\<^sub>p)" "0 < deg Q\<^sub>p p" "\<forall>x. p x \<in> \<O>\<^sub>p"
+      show "to_Zp (p \<bullet> b) n = to_Zp (p \<bullet> a) n"
+      proof-
+        obtain q where q_def: "q \<in> carrier (UP Q\<^sub>p) \<and> deg Q\<^sub>p q < deg Q\<^sub>p p \<and>
+                      p = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> ltrm p"
+          using A  by (meson UPQ.ltrm_decomp)
+        have p_eq: "p = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> ltrm p"
+          using q_def by blast 
+        have "\<forall>x. q x \<in> \<O>\<^sub>p" proof fix x
+          have px: "p x = (q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> ltrm p) x"
+            using p_eq by simp 
+          show "q x \<in> \<O>\<^sub>p"
+          proof(cases "x \<le> deg Q\<^sub>p q")
+            case True
+            then have "p x = q x"           
+              unfolding px using q_def A 
+              by (smt UPQ.ltrm_closed UPQ.P.add.right_cancel UPQ.coeff_of_sum_diff_degree0 UPQ.deg_ltrm UPQ.trunc_cfs UPQ.trunc_closed UPQ.trunc_simps(1) less_eq_Suc_le nat_neq_iff not_less_eq_eq)
+            then show ?thesis using A 
+              by blast
+          next
+            case False
+            then show ?thesis 
+              using q_def UPQ.deg_eqI eq_imp_le nat_le_linear zero_in_val_ring
+              by (metis (no_types, lifting) UPQ.coeff_simp UPQ.deg_belowI)
+          qed
+        qed
+        then have 0: " to_Zp (q \<bullet> b) n = to_Zp (q \<bullet> a) n"
+          using IH q_def by blast
+        have 1: "to_Zp (ltrm p \<bullet> b) n = to_Zp (ltrm p \<bullet> a) n"
+        proof-
+          have 10: "(ltrm p \<bullet> b) = (p (deg Q\<^sub>p p)) \<otimes> b[^] (deg Q\<^sub>p p)"
+            using assms A  by (meson val_ring_memE UPQ.to_fun_monom)
+          have 11: "(ltrm p \<bullet> a) = (p (deg Q\<^sub>p p)) \<otimes> a[^] (deg Q\<^sub>p p)"
+            using assms A by (meson val_ring_memE UPQ.to_fun_monom)
+          have 12: "to_Zp (b[^] (deg Q\<^sub>p p)) n = to_Zp (a[^] (deg Q\<^sub>p p)) n"
+            using to_Zp_res_of_pow assms by metis
+          have 13: "p (deg Q\<^sub>p p) \<in> \<O>\<^sub>p"
+            using A(3) by blast
+          have 14: "b[^] (deg Q\<^sub>p p) \<in> \<O>\<^sub>p"
+            using assms(4) val_ring_nat_pow_closed by blast
+          have 15: "a[^] (deg Q\<^sub>p p) \<in> \<O>\<^sub>p"
+            using assms(3) val_ring_nat_pow_closed by blast
+          have 16: "(ltrm p \<bullet> b) \<in> \<O>\<^sub>p"
+            by (simp add: "10" "13" "14" val_ring_times_closed)
+          have 17: "to_Zp (ltrm p \<bullet> b) n = to_Zp (p (deg Q\<^sub>p p)) n \<otimes>\<^bsub>Zp_res_ring n\<^esub> to_Zp (b[^] (deg Q\<^sub>p p)) n"
+            using 10 13 14 15 16 assms residue_of_prod to_Zp_mult by presburger 
+          have 18: "(ltrm p \<bullet> a) \<in> \<O>\<^sub>p"
+            by (simp add: "11" "15" A(3) val_ring_times_closed)
+          have 19: "to_Zp (ltrm p \<bullet> a) n = to_Zp (p (deg Q\<^sub>p p)) n \<otimes>\<^bsub>Zp_res_ring n\<^esub> to_Zp (a[^] (deg Q\<^sub>p p)) n"
+            using 10 13 14 15 16 17 18 assms residue_of_prod to_Zp_mult 11  by presburger
+          show ?thesis using 12 17 19 by presburger
+        qed
+        have 2: "p (deg Q\<^sub>p p) \<in> \<O>\<^sub>p"
+          using A(3) by blast
+        have 3: "(ltrm p \<bullet> b) \<in> \<O>\<^sub>p"
+          using 2 assms  
+          by (metis A(1) Q\<^sub>p_def val_ring_memE val_ring_memE UPQ.ltrm_closed Zp_def \<iota>_def 
+              gauss_norm_monom padic_fields.positive_gauss_norm_eval padic_fields_axioms)
+        have 4: "(ltrm p \<bullet> a) \<in> \<O>\<^sub>p"
+          using 2 assms 
+          by (metis A(1) Q\<^sub>p_def val_ring_memE val_ring_memE UPQ.ltrm_closed Zp_def \<iota>_def
+              gauss_norm_monom padic_fields.positive_gauss_norm_eval padic_fields_axioms)
+        have 5: "(q \<bullet> b) \<in> \<O>\<^sub>p"
+          using  \<open>\<forall>x. q x \<in> \<O>\<^sub>p\<close> assms(4) q_def     
+          by (metis gauss_norm_coeff_norm positive_gauss_norm_eval val_ring_memE(1))
+        have 6: "(q \<bullet> a) \<in> \<O>\<^sub>p"
+          using  \<open>\<forall>x. q x \<in> \<O>\<^sub>p\<close> assms(3) q_def     
+          by (metis gauss_norm_coeff_norm positive_gauss_norm_eval val_ring_memE(1))
+        have 7: "to_Zp (p \<bullet> b) = to_Zp (ltrm p \<bullet> b)  \<oplus>\<^bsub>Z\<^sub>p\<^esub> to_Zp (q \<bullet> b)"
+          using 5 3 q_def by (metis (no_types, lifting) A(1) val_ring_memE UPQ.ltrm_closed UPQ.to_fun_plus add_comm assms(4) to_Zp_add)
+        have 8: "to_Zp (p \<bullet> a) = to_Zp (ltrm p \<bullet> a)  \<oplus>\<^bsub>Z\<^sub>p\<^esub> to_Zp (q \<bullet> a)"
+          using 4 6 q_def by (metis (no_types, lifting) A(1) val_ring_memE UPQ.ltrm_closed UPQ.to_fun_plus add_comm assms(3) to_Zp_add)
+        have 9: "to_Zp (p \<bullet> b) \<in> carrier Z\<^sub>p"
+          using A assms by (meson val_ring_memE UPQ.to_fun_closed to_Zp_closed)
+        have 10: "to_Zp (p \<bullet> a) \<in> carrier Z\<^sub>p"
+          using A assms val_ring_memE UPQ.to_fun_closed to_Zp_closed by presburger
+        have 11: "to_Zp (p \<bullet> b) n = to_Zp (ltrm p \<bullet> b) n  \<oplus>\<^bsub>Zp_res_ring n\<^esub> to_Zp (q \<bullet> b) n"
+          using 7 9 5 3 residue_of_sum by presburger
+        have 12: "to_Zp (p \<bullet> a) n = to_Zp (ltrm p \<bullet> a) n \<oplus>\<^bsub>Zp_res_ring n\<^esub> to_Zp (q \<bullet> a) n"
+          using 8 6 4 residue_of_sum by presburger
+        show ?thesis using 0 11 12 q_def assms 
+          using "1" by presburger
+      qed
+    qed
+  qed
+  have "(\<forall>x. g x \<in> \<O>\<^sub>p) "
+    using assms by blast
+  hence 0: "to_Zp (g \<bullet> b) n = to_Zp (g \<bullet> a) n"
+    using \<open>(\<forall>x. g x \<in> \<O>\<^sub>p) \<longrightarrow> to_Zp (g \<bullet> b) n = to_Zp (g \<bullet> a) n\<close> by blast
+  have 1: "g \<bullet> a \<in> \<O>\<^sub>p"
+    using  assms(1) assms(2) assms(3) 
+    by (metis gauss_norm_coeff_norm positive_gauss_norm_eval val_ring_memE(1))
+  have 2: "g \<bullet> b \<in> \<O>\<^sub>p"
+    using  assms(1) assms(2) assms(4) 
+    by (metis gauss_norm_coeff_norm positive_gauss_norm_eval val_ring_memE(1))
+  have 3: "val (g \<bullet> b) < eint n"
+  proof-
+    have P0: "to_Zp (g \<bullet> a) \<in> carrier Z\<^sub>p"
+      using 1 val_ring_memE to_Zp_closed by blast
+    have P1: "to_Zp (g \<bullet> b) \<in> carrier Z\<^sub>p"
+      using 2 val_ring_memE to_Zp_closed by blast
+    have P2: "val_Zp (to_Zp (g \<bullet> a)) < n"
+      using 1 assms to_Zp_val by presburger
+    have P3: "to_Zp (g \<bullet> a) \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+      using P2 P0 unfolding val_Zp_def     by (metis P2 infinity_ilessE val_Zp_def)
+    have P4: "(to_Zp (g \<bullet> a)) n \<noteq> 0"
+      using 1 P2 P3 above_ord_nonzero[of "to_Zp (g \<bullet> a)" n]  
+      by (metis P0 eint.inject less_eintE val_ord_Zp)
+    then have "to_Zp (g \<bullet> b) n \<noteq> 0"
+      using 0 by linarith
+    then have "val_Zp (to_Zp (g \<bullet> b)) < n"
+      using P1 P0 
+      by (smt below_val_Zp_zero eint_ile eint_ord_simps(1) eint_ord_simps(2) nonzero_imp_ex_nonzero_res residue_of_zero(2) zero_below_val_Zp)  
+    then show ?thesis using 2 
+      by (metis to_Zp_val)
+  qed
+  thus ?thesis using 0 1 2 assms val_ring_equal_res_imp_equal_val[of "g \<bullet> b" "g \<bullet> a" n] by blast
+qed
+
+lemma to_Zp_poly_monom:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "to_Zp_poly (monom (UP Q\<^sub>p) a n) = monom (UP Z\<^sub>p) (to_Zp a) n"
+  unfolding to_Zp_poly_def 
+  apply(rule ext)
+  using assms cfs_monom[of a n] Zp.cfs_monom[of "to_Zp a" n] 
+  by (simp add: to_Zp_closed to_Zp_zero val_ring_memE(2))
+
+lemma to_Zp_poly_add:
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  assumes "gauss_norm f \<ge> 0"
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "gauss_norm g \<ge> 0"
+  shows "to_Zp_poly (f \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> g) = to_Zp_poly f \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly g"
+proof- 
+  obtain F where F_def: "F = to_Zp_poly f"
+    by blast 
+  obtain G where G_def: "G = to_Zp_poly g"
+    by blast 
+  have F_closed: "F \<in> carrier (UP Z\<^sub>p)"
+    unfolding F_def using assms 
+    by (simp add: to_Zp_poly_closed)
+  have G_closed: "G \<in> carrier (UP Z\<^sub>p)"
+    unfolding G_def using assms 
+    by (simp add: to_Zp_poly_closed)
+  have F_inc: "poly_inc F = f"
+    using assms unfolding F_def 
+    using poly_inc_inverse_left by blast
+  have G_inc: "poly_inc G = g"
+    using assms unfolding G_def 
+    by (simp add: poly_inc_inverse_left)
+  have 0: "poly_inc (F \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> G) = poly_inc F \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> poly_inc G"
+    using F_closed G_closed 
+    by (simp add: poly_inc_plus)
+  have 1: "to_Zp_poly (poly_inc (F \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> G)) = F \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> G"
+    using G_closed F_closed 
+    by (simp add: poly_inc_inverse_right)
+  show ?thesis 
+    using  1 unfolding F_inc G_inc 0 unfolding F_def G_def 
+    by blast 
+qed
+
+lemma to_Zp_poly_zero:
+"to_Zp_poly (\<zero>\<^bsub>UP Q\<^sub>p\<^esub>) = \<zero>\<^bsub>UP Z\<^sub>p\<^esub>"
+  unfolding to_Zp_poly_def 
+  apply(rule ext)
+  by (simp add: to_Zp_zero)
+
+lemma to_Zp_poly_one:
+"to_Zp_poly (\<one>\<^bsub>UP Q\<^sub>p\<^esub>) = \<one>\<^bsub>UP Z\<^sub>p\<^esub>"
+  unfolding to_Zp_poly_def 
+  apply(rule ext)
+  by (metis Zp.UP_one_closed poly_inc_inverse_right poly_inc_one to_Zp_poly_def) 
+
+lemma val_ring_add_pow:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<ge> 0"
+  shows "val ([(n::nat)]\<cdot>a) \<ge> 0"
+proof-
+  have 0: "[(n::nat)]\<cdot>a = ([n]\<cdot>\<one>)\<otimes>a"
+    using assms Qp.add_pow_ldistr Qp.cring_simprules(12) Qp.one_closed by presburger
+  show ?thesis unfolding 0 using assms 
+    by (meson Qp.nat_inc_closed val_ring_memE val_of_nat_inc val_ringI val_ring_times_closed)
+qed
+
+lemma to_Zp_poly_pderiv:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "gauss_norm g \<ge> 0"
+  shows "to_Zp_poly (pderiv g) = Zp.pderiv (to_Zp_poly g)"
+proof- 
+  have 0: "gauss_norm g \<ge> 0 \<longrightarrow> to_Zp_poly (pderiv g) = Zp.pderiv (to_Zp_poly g)"
+  proof(rule poly_induct, rule assms, rule)
+    fix p 
+    assume A: " p \<in> carrier (UP Q\<^sub>p)"
+         "deg Q\<^sub>p p = 0"
+         "0 \<le> gauss_norm p"
+    obtain a where a_def: "a \<in> \<O>\<^sub>p \<and> p = monom (UP Q\<^sub>p) a 0"
+      using A 
+      by (metis UPQ.ltrm_deg_0 positive_gauss_norm_valuation_ring_coeffs)
+    have p_eq: "p = monom (UP Q\<^sub>p) a 0"
+      using a_def by blast 
+    have 0: "to_Zp_poly p = monom (UP Z\<^sub>p) (to_Zp a) 0"
+      unfolding p_eq
+      apply(rule to_Zp_poly_monom)
+      using a_def by blast 
+    have 1: "UPQ.pderiv (monom (UP Q\<^sub>p) a 0) = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+      using A(1) A(2) UPQ.pderiv_deg_0 p_eq by blast
+    have 2: "Zp.pderiv (monom (UP Z\<^sub>p) (to_Zp a) 0) = \<zero>\<^bsub>UP Z\<^sub>p\<^esub>"
+      apply(rule Zp.pderiv_deg_0) 
+       apply(rule Zp.monom_closed, rule to_Zp_closed)
+      using a_def 
+       apply (simp add: val_ring_memE(2); fail)
+      apply(cases "to_Zp a = \<zero>\<^bsub>Z\<^sub>p\<^esub>")
+      apply (simp; fail)
+      apply(rule Zp.deg_monom, blast) 
+      using a_def 
+      by (simp add: to_Zp_closed val_ring_memE(2))
+    show "to_Zp_poly (UPQ.pderiv p) = Zp.pderiv (to_Zp_poly p)"
+      unfolding 0 unfolding p_eq 
+      unfolding 1 2 to_Zp_poly_zero by blast 
+  next 
+    fix p 
+    assume A: "\<And>q. q \<in> carrier (UP Q\<^sub>p) \<Longrightarrow>
+              deg Q\<^sub>p q < deg Q\<^sub>p p \<Longrightarrow>
+              0 \<le> gauss_norm q \<longrightarrow>
+              to_Zp_poly (UPQ.pderiv q) = Zp.pderiv (to_Zp_poly q)"
+              "p \<in> carrier (UP Q\<^sub>p)"
+              " 0 < deg Q\<^sub>p p"
+    show "0 \<le> gauss_norm p \<longrightarrow> to_Zp_poly (UPQ.pderiv p) = Zp.pderiv (to_Zp_poly p)"
+    proof 
+      assume B: "0 \<le> gauss_norm p"
+      obtain q where q_def: "q = trunc p"
+        by blast 
+      have p_eq: "p = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> ltrm p"
+        by (simp add: A(2) UPQ.trunc_simps(1) q_def)
+      have q_gauss_norm:    "gauss_norm q \<ge> 0"
+        unfolding q_def 
+        apply(rule gauss_norm_geqI)
+        using A apply (simp add: UPQ.trunc_closed; fail)
+        using trunc_cfs[of p] A gauss_normE 
+      proof -
+        fix n :: nat
+        have f1: "\<zero> = q (deg Q\<^sub>p p)"
+          by (simp add: UPQ.deg_leE UPQ.trunc_closed UPQ.trunc_degree \<open>0 < deg Q\<^sub>p p\<close> \<open>p \<in> carrier (UP Q\<^sub>p)\<close> q_def)
+        have "\<forall>n. 0 \<le> val (p n)"
+          by (meson B \<open>p \<in> carrier (UP Q\<^sub>p)\<close> eint_ord_trans gauss_normE)
+        then show "0 \<le> val (Cring_Poly.truncate Q\<^sub>p p n)"
+          using f1 by (metis (no_types) Qp.nat_mult_zero UPQ.ltrm_closed UPQ.coeff_of_sum_diff_degree0 UPQ.deg_ltrm UPQ.trunc_closed \<open>\<And>n. \<lbrakk>p \<in> carrier (UP Q\<^sub>p); n < deg Q\<^sub>p p\<rbrakk> \<Longrightarrow> Cring_Poly.truncate Q\<^sub>p p n = p n\<close> \<open>p \<in> carrier (UP Q\<^sub>p)\<close> nat_neq_iff p_eq q_def val_of_nat_inc)
+      qed
+      have 0: "to_Zp_poly (UPQ.pderiv q) = Zp.pderiv (to_Zp_poly q)"
+        using A q_def q_gauss_norm 
+        by (simp add: UPQ.trunc_closed UPQ.trunc_degree)
+      have 1: "UPQ.pderiv (monom (UP Q\<^sub>p) (p (deg Q\<^sub>p p)) (deg Q\<^sub>p p)) =
+               monom (UP Q\<^sub>p) ([deg Q\<^sub>p p] \<cdot> p (deg Q\<^sub>p p)) (deg Q\<^sub>p p - 1)"
+        apply(rule pderiv_monom)
+        using A by (simp add: UPQ.UP_car_memE(1))
+      have 2: "Zp.pderiv (monom (UP Z\<^sub>p) (to_Zp (p (deg Q\<^sub>p p))) (deg Q\<^sub>p p)) =
+    monom (UP Z\<^sub>p) ([deg Q\<^sub>p p] \<cdot>\<^bsub>Z\<^sub>p\<^esub> to_Zp ( p (deg Q\<^sub>p p))) (deg Q\<^sub>p p - 1)"
+        using A  Zp.pderiv_monom[of "to_Zp ( p (deg Q\<^sub>p p))" "deg Q\<^sub>p p"]  
+        by (simp add: UPQ.lcf_closed to_Zp_closed)
+      have 3: "to_Zp_poly (UPQ.pderiv (monom (UP Q\<^sub>p) (p (deg Q\<^sub>p p)) (deg Q\<^sub>p p))) = monom (UP Z\<^sub>p) (to_Zp ([deg Q\<^sub>p p] \<cdot> p (deg Q\<^sub>p p))) (deg Q\<^sub>p p - 1)"
+        unfolding 1 apply(rule to_Zp_poly_monom)
+        apply(rule val_ring_memI)
+         apply (simp add: A(2) UPQ.UP_car_memE(1); fail)
+        apply(rule val_ring_add_pow)
+        using A 
+        apply (simp add: UPQ.lcf_closed; fail)
+        using B A 
+        by (simp add: positive_gauss_norm_valuation_ring_coeffs val_ring_memE(1))
+      have 4: "to_Zp_poly (ltrm p) = monom (UP Z\<^sub>p) (to_Zp (p (deg Q\<^sub>p p))) (deg Q\<^sub>p p)"
+        apply(rule to_Zp_poly_monom) using A 
+        by (simp add: B positive_gauss_norm_valuation_ring_coeffs)
+      have 5: "to_Zp_poly (UPQ.pderiv (ltrm p)) = Zp.pderiv (to_Zp_poly (ltrm p))"
+        unfolding 3 4 2 
+        by (simp add: A(2) B positive_gauss_norm_valuation_ring_coeffs to_Zp_nat_add_pow)
+      have 6: "pderiv p = pderiv q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> pderiv (ltrm p)"
+        using p_eq 
+        by (metis A(2) UPQ.ltrm_closed UPQ.pderiv_add UPQ.trunc_closed p_eq q_def)
+      have 7: "to_Zp_poly p = to_Zp_poly q \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly (ltrm p)"
+        using p_eq 
+        by (metis (no_types, lifting) A(2) B UPQ.ltrm_closed UPQ.cfs_closed UPQ.trunc_closed gauss_norm_monom positive_gauss_norm_valuation_ring_coeffs q_def q_gauss_norm to_Zp_poly_add val_ring_memE(1))
+      have 8: "to_Zp_poly  (pderiv p) =
+                to_Zp_poly (UPQ.pderiv q) \<oplus>\<^bsub>UP Z\<^sub>p\<^esub>
+                 to_Zp_poly (UPQ.pderiv (monom (UP Q\<^sub>p) (p (deg Q\<^sub>p p)) (deg Q\<^sub>p p)))"
+        unfolding 6 apply(rule to_Zp_poly_add)
+           apply (simp add: A(2) UPQ.pderiv_closed UPQ.trunc_closed q_def; fail)
+          apply (metis A(2) UPQ.cfs_closed UPQ.pderiv_cfs UPQ.trunc_closed gauss_norm_coeff_norm positive_gauss_norm_valuation_ring_coeffs q_def q_gauss_norm val_ring_add_pow val_ring_memE(1))
+         apply (simp add: A(2) UPQ.UP_car_memE(1) UPQ.pderiv_closed; fail)
+        apply(rule eint_ord_trans[of _ "gauss_norm (monom (UP Q\<^sub>p) (p (deg Q\<^sub>p p)) (deg Q\<^sub>p p))"])
+        apply (simp add: A(2) B UPQ.cfs_closed gauss_norm_monom positive_gauss_norm_valuation_ring_coeffs val_ring_memE(1); fail)
+        apply(rule gauss_norm_pderiv)
+        using A(2) UPQ.ltrm_closed by blast
+      have 9: "Zp.pderiv  (to_Zp_poly p) =  Zp.pderiv (to_Zp_poly q) \<oplus>\<^bsub>UP Z\<^sub>p\<^esub>
+         Zp.pderiv (to_Zp_poly (monom (UP Q\<^sub>p) (p (deg Q\<^sub>p p)) (deg Q\<^sub>p p)))"
+          unfolding 7 apply(rule Zp.pderiv_add)
+           apply(rule to_Zp_poly_closed)
+            apply (simp add: A(2) UPQ.trunc_closed q_def; fail)
+           apply (simp add: q_gauss_norm; fail)
+           apply(rule to_Zp_poly_closed)
+           apply (simp add: A(2) UPQ.UP_car_memE(1); fail)
+          by (simp add: A(2) B UPQ.cfs_closed gauss_norm_monom positive_gauss_norm_valuation_ring_coeffs val_ring_memE(1))
+      show "to_Zp_poly (UPQ.pderiv p) = Zp.pderiv (to_Zp_poly p)"
+          unfolding 9 8 5 0 by blast 
+    qed
+  qed
+  thus ?thesis using assms by blast 
+qed
+
+lemma val_p_int_pow:
+"val (\<pp>[^]k) = eint (k)"
+  by (simp add: ord_p_pow_int p_intpow_closed(2))
+
+definition int_gauss_norm where
+"int_gauss_norm g = (SOME n::int. eint n = gauss_norm g)"
+
+lemma int_gauss_norm_eq: 
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  shows "eint (int_gauss_norm g) = gauss_norm g"
+proof- 
+  have 0: "gauss_norm g < \<infinity>"
+    using assms by (simp add: gauss_norm_prop)
+  then show ?thesis unfolding int_gauss_norm_def 
+    using assms 
+    by fastforce
+qed
+
+lemma int_gauss_norm_smult:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "int_gauss_norm (a \<odot>\<^bsub>UP Q\<^sub>p\<^esub> g) = ord a + int_gauss_norm g"
+  using gauss_norm_smult[of g a] int_gauss_norm_eq val_ord assms 
+  by (metis (no_types, opaque_lifting) Qp.nonzero_closed UPQ.UP_smult_closed UPQ.cfs_zero
+      eint.distinct(2) eint.inject gauss_norm_coeff_norm local.val_zero plus_eint_simps(1))
+
+definition normalize_poly where
+"normalize_poly g = (if g = \<zero>\<^bsub>UP Q\<^sub>p\<^esub> then g else (\<pp>[^](- int_gauss_norm g)) \<odot>\<^bsub>Q\<^sub>p_x\<^esub> g)"
+
+lemma normalize_poly_zero: 
+"normalize_poly \<zero>\<^bsub>UP Q\<^sub>p\<^esub> = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  unfolding normalize_poly_def by simp 
+
+lemma normalize_poly_nonzero_eq:
+  assumes "g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "normalize_poly g = (\<pp>[^](- int_gauss_norm g)) \<odot>\<^bsub>UP Q\<^sub>p\<^esub> g"
+  using assms unfolding normalize_poly_def by simp 
+
+lemma int_gauss_norm_normalize_poly:
+  assumes "g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "int_gauss_norm (normalize_poly g) = 0"
+  using normalize_poly_nonzero_eq int_gauss_norm_smult assms 
+  by (simp add: ord_p_pow_int p_intpow_closed(2))
+
+lemma normalize_poly_closed: 
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "normalize_poly g \<in> carrier (UP Q\<^sub>p)"
+  using assms unfolding normalize_poly_def 
+  by (simp add: p_intpow_closed(1))
+
+lemma normalize_poly_nonzero:
+  assumes "g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "normalize_poly g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  using assms normalize_poly_nonzero_eq 
+  by (metis (no_types, lifting) UPQ.UP_smult_one UPQ.module_axioms UPQ.smult_r_null module.smult_assoc1 p_intpow_closed(1) p_intpow_inv')
+
+lemma gauss_norm_normalize_poly:
+  assumes "g \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  shows "gauss_norm (normalize_poly g) = 0"
+proof- 
+  have 0: "eint (int_gauss_norm (normalize_poly g)) = gauss_norm (normalize_poly g)"
+    by(rule int_gauss_norm_eq, rule normalize_poly_closed, rule assms, 
+          rule normalize_poly_nonzero, rule assms, rule assms)
+  show ?thesis 
+    using 0 int_gauss_norm_normalize_poly assms 
+    by (simp add: zero_eint_def)
+qed
+
+lemma taylor_term_eval_eq:
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "t \<in> carrier Q\<^sub>p"
+  assumes "\<And>j. i \<noteq> j \<Longrightarrow> val (UPQ.taylor_term x f i \<bullet> t) < val (UPQ.taylor_term x f j \<bullet> t) "
+  shows "val (f \<bullet> t) = val (UPQ.taylor_term x f i \<bullet> t)"
+proof-
+  have 0: "f = finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) {..deg Q\<^sub>p f}"
+    by(rule UPQ.taylor_term_sum[of f "deg Q\<^sub>p f" x], rule assms, blast, rule assms)
+  show ?thesis 
+  proof(cases "i \<in> {..deg Q\<^sub>p f}")
+    case True
+    have T0: "finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) {..deg Q\<^sub>p f} = UPQ.taylor_term x f i \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i})"
+      apply(rule UPQ.P.finsum_remove[of "{..deg Q\<^sub>p f}" "UPQ.taylor_term x f" i])
+      by(rule UPQ.taylor_term_closed, rule assms, rule assms, blast, rule True)
+    have T1: "f = UPQ.taylor_term x f i \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i})"
+      using 0 T0 by metis
+    have T2: "finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i}) \<in> carrier (UP Q\<^sub>p)"
+      apply(rule UPQ.P.finsum_closed)
+      using UPQ.taylor_term_closed assms(1) assms(2) by blast
+    have T3: "UPQ.taylor_term x f i \<in> carrier (UP Q\<^sub>p)"
+      by(rule UPQ.taylor_term_closed, rule assms, rule assms )
+    obtain g where g_def: "g = f" 
+      by blast 
+    have T4: "g = UPQ.taylor_term x f i \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i})"
+      unfolding g_def by(rule T1)
+    have g_closed: "g \<in> carrier (UP Q\<^sub>p)"
+      unfolding g_def by(rule assms)
+    have T5: "g \<bullet> t = UPQ.taylor_term x f i \<bullet> t \<oplus> ( finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i})) \<bullet> t"
+      unfolding T4 by(rule UPQ.to_fun_plus, rule T2, rule T3, rule assms)
+    have T6: "( finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i})) \<bullet> t = 
+                ( finsum Q\<^sub>p (\<lambda>i. UPQ.taylor_term x f i \<bullet> t) ({..deg Q\<^sub>p f} - {i}))"
+      apply(rule UPQ.to_fun_finsum, blast)
+      using assms UPQ.taylor_term_closed apply blast
+      using assms by blast 
+    have T7: "\<And>j. j \<in> {..deg Q\<^sub>p f} - {i} \<Longrightarrow> val (UPQ.taylor_term x f j \<bullet> t) > val (UPQ.taylor_term x f i \<bullet> t)"
+      using assms  by (metis Diff_iff singletonI)
+    have T8: "val (( finsum (UP Q\<^sub>p) (UPQ.taylor_term x f) ({..deg Q\<^sub>p f} - {i})) \<bullet> t) > val (UPQ.taylor_term x f i \<bullet> t)"
+      unfolding T6
+      apply(rule finsum_val_ultrametric'')
+      using UPQ.taylor_term_closed assms 
+      apply (metis (no_types, lifting) Pi_I UPQ.to_fun_closed)
+        apply blast
+      using assms T7 apply blast
+      using assms(4)[of "Suc i"] using eint_ord_simps(4)
+        assms(4) eint_ord_code(6)  g_def gr_implies_not_zero less_one by smt 
+    have T9: "val (g \<bullet> t) =  val (UPQ.taylor_term x f i \<bullet> t)"
+      unfolding T5 using T8 T2 T3 
+      by (metis (no_types, lifting) Qp.add.m_comm UPQ.to_fun_closed assms(3) val_ultrametric_noteq)
+    show ?thesis using T9 unfolding g_def by blast 
+  next
+    case False
+    have "i > deg Q\<^sub>p f"
+      using False by simp
+    hence "i > deg Q\<^sub>p (UPQ.taylor x f)"
+      using assms UPQ.taylor_deg by presburger
+    hence F0: "UPQ.taylor x f i = \<zero>"
+      using assms UPQ.taylor_closed UPQ.deg_leE by blast
+    have F1: "(UPQ.taylor_term x f i \<bullet> t) = \<zero>"
+      using UPQ.to_fun_taylor_term[of f t x i]
+      unfolding F0
+      using assms Qp.cring_simprules(2) Qp.cring_simprules(4) Qp.integral_iff Qp.nat_pow_closed by presburger
+    show ?thesis 
+      using assms(4)[of "Suc i"] unfolding F1 
+      by (metis eint_ord_code(6) local.val_zero n_not_Suc_n)
+  qed
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Hensel's Lemma for \<open>p\<close>-adic fields\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+theorem hensels_lemma:
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "gauss_norm f \<ge> 0"
+  assumes "val (f\<bullet>a) > 2*val ((pderiv f)\<bullet>a)"
+  shows "\<exists>!\<alpha> \<in> \<O>\<^sub>p. f\<bullet>\<alpha> = \<zero> \<and> val (a \<ominus> \<alpha>) > val ((pderiv f)\<bullet>a)"
+proof- 
+  have a_closed: "a \<in> carrier Q\<^sub>p"
+    using assms val_ring_memE by auto 
+  have f_nonzero: "f \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+  proof(rule ccontr)
+    assume N: "\<not> f \<noteq> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+    then have 0: "pderiv f = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+      using UPQ.deg_zero UPQ.pderiv_deg_0 by blast
+    have 1: "f = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+      using N by auto 
+    have 2: "eint 2 * val (UPQ.pderiv \<zero>\<^bsub>UP Q\<^sub>p\<^esub> \<bullet> a) = \<infinity>"
+      by (simp add: UPQ.to_fun_zero local.a_closed local.val_zero)
+    show False using assms a_closed
+      unfolding 2 1 
+      using eint_ord_simps(6) by blast
+  qed
+  obtain h where h_def: "h = to_Zp_poly f"
+    by blast 
+  have h_closed: "h \<in> carrier (UP Z\<^sub>p)"
+    unfolding h_def using assms
+    by (simp add: to_Zp_poly_closed)
+  have h_deriv: "Zp.pderiv h = to_Zp_poly (pderiv f)"
+    unfolding h_def 
+    using to_Zp_poly_pderiv[of f] assms by auto 
+  have 0: "to_Zp (f\<bullet>a) = to_function Z\<^sub>p h (to_Zp a)"
+    unfolding h_def 
+    using assms a_closed 
+    by (simp add: UPQ.to_fun_def to_Zp_poly_eval)
+  have 1: "to_Zp ((pderiv f)\<bullet>a) = to_function Z\<^sub>p (Zp.pderiv h) (to_Zp a)"
+    unfolding h_deriv 
+    using assms a_closed  UPQ.pderiv_closed UPQ.to_fun_def eint_ord_trans gauss_norm_pderiv to_Zp_poly_eval 
+    by presburger
+  have 2: "val (f\<bullet>a) = val_Zp (to_function Z\<^sub>p h (to_Zp a))"
+  proof- 
+    have 20: "f\<bullet>a \<in> \<O>\<^sub>p"
+      using assms positive_gauss_norm_eval by blast
+    have 21: "val (f\<bullet>a) = val_Zp (to_Zp (f\<bullet>a))"
+      using 20 by (simp add: to_Zp_val)
+    show ?thesis unfolding 21 0 by blast 
+  qed
+  have 3: "val ((pderiv f)\<bullet>a) = val_Zp ( to_function Z\<^sub>p (Zp.pderiv h) (to_Zp a))"
+  proof- 
+    have 30: "(pderiv f)\<bullet>a \<in> \<O>\<^sub>p"
+      using positive_gauss_norm_eval assms gauss_norm_pderiv 
+      by (meson UPQ.pderiv_closed eint_ord_trans)
+    have 31: "val ((pderiv f)\<bullet>a) = val_Zp (to_Zp ((pderiv f)\<bullet>a))"
+      using 30 by (simp add: to_Zp_val)
+    show ?thesis unfolding 31 1 by blast 
+  qed
+  have 4: "\<exists>!\<alpha>. \<alpha> \<in> carrier Z\<^sub>p \<and>
+        Zp.to_fun (to_Zp_poly f) \<alpha> = \<zero>\<^bsub>Z\<^sub>p\<^esub> \<and>
+        val_Zp (Zp.to_fun (Zp.pderiv (to_Zp_poly f)) (to_Zp a))
+        < val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>)"
+    apply(rule hensels_lemma')
+    using h_closed h_def apply blast
+    using assms local.a_closed to_Zp_closed apply blast
+    using assms unfolding 2 3 h_def Zp.to_fun_def by blast  
+  obtain \<alpha> where \<alpha>_def: "\<alpha> \<in> carrier Z\<^sub>p \<and>
+        Zp.to_fun (to_Zp_poly f) \<alpha> = \<zero>\<^bsub>Z\<^sub>p\<^esub> \<and>
+        val_Zp (Zp.to_fun (Zp.pderiv (to_Zp_poly f)) (to_Zp a))
+        < val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>) 
+        \<and> (\<forall>x.  x \<in> carrier Z\<^sub>p \<and>
+        Zp.to_fun (to_Zp_poly f) x = \<zero>\<^bsub>Z\<^sub>p\<^esub> \<and>
+        val_Zp (Zp.to_fun (Zp.pderiv (to_Zp_poly f)) (to_Zp a))
+        < val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> x) \<longrightarrow> x = \<alpha>)"
+    using 4 by blast 
+  obtain \<beta> where \<beta>_def: "\<beta> = \<iota> \<alpha>"
+    by blast 
+  have \<beta>_closed: "\<beta> \<in> \<O>\<^sub>p"
+    using \<alpha>_def unfolding \<beta>_def by simp
+  have 5: "(Zp.to_fun (to_Zp_poly f) \<alpha>) = to_Zp (f\<bullet>\<beta>)"
+    using \<beta>_closed to_Zp_poly_eval[of f \<beta>] assms 
+    unfolding \<beta>_def UPQ.to_fun_def 
+    by (simp add: Zp.to_fun_def \<alpha>_def inc_to_Zp)
+  have 6: "to_Zp (f\<bullet>\<beta>) = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+    using 5 \<alpha>_def by auto 
+  have \<beta>_closed: "\<beta> \<in> \<O>\<^sub>p"
+    unfolding \<beta>_def using \<alpha>_def  by simp
+  have 7: "(f\<bullet>\<beta>) = \<zero>"
+    using 6 assms unfolding \<beta>_def 
+    by (metis \<beta>_closed \<beta>_def inc_of_zero positive_gauss_norm_eval to_Zp_inc)
+  have 8: "\<alpha> = to_Zp \<beta>"
+    unfolding \<beta>_def using \<alpha>_def 
+    by (simp add: inc_to_Zp)
+  have 9: "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha> = to_Zp (a \<ominus> \<beta>)"
+    unfolding 8 using assms(2) \<beta>_closed 
+    by (simp add: to_Zp_minus)
+  have 10: "val (a \<ominus> \<beta>) = val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>)"
+    unfolding 9 using \<beta>_closed assms(2) 
+    to_Zp_val val_ring_minus_closed by presburger
+  have 11: "val (a \<ominus> \<beta>) > val ((pderiv f)\<bullet>a)"
+    using \<alpha>_def unfolding 9 10 3 h_def 
+    by (simp add: Zp.to_fun_def)
+  have 12: "\<beta> \<in> \<O>\<^sub>p \<and> f \<bullet> \<beta> = \<zero> \<and> val (UPQ.pderiv f \<bullet> a) < val (a \<ominus> \<beta>)"
+    using "11" "7" \<beta>_closed by linarith
+  have 13: "\<forall>x. x\<in> \<O>\<^sub>p \<and> f \<bullet> x = \<zero> \<and> val (UPQ.pderiv f \<bullet> a) < val (a \<ominus> x) 
+            \<longrightarrow> x = \<beta>"
+  proof(rule, rule)
+    fix x assume A: "x \<in> \<O>\<^sub>p \<and>  f \<bullet> x = \<zero> \<and> val (UPQ.pderiv f \<bullet> a) < val (a \<ominus> x)"
+    obtain y where y_def: "y = to_Zp x"
+      by blast 
+    have y_closed: "y \<in> carrier Z\<^sub>p"
+      unfolding y_def using A 
+      by (simp add: to_Zp_closed val_ring_memE(2))
+    have eval: "Zp.to_fun (to_Zp_poly f) y = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+      unfolding y_def using A assms 
+      by (metis UPQ.to_fun_def Zp.to_fun_def to_Zp_poly_eval to_Zp_zero)
+    have 0: "to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> y = to_Zp (a \<ominus> x)"
+      unfolding y_def using A assms 
+      by (simp add: to_Zp_minus)
+    have q: " val_Zp (Zp.to_fun (Zp.pderiv (to_Zp_poly f)) (to_Zp a)) = val (UPQ.pderiv f \<bullet> a)"
+      by (simp add: "3" Zp.to_fun_def h_def)
+    have 1: "y \<in> carrier Z\<^sub>p \<and>
+        Zp.to_fun (to_Zp_poly f) y = \<zero>\<^bsub>Z\<^sub>p\<^esub> \<and>
+        val_Zp (Zp.to_fun (Zp.pderiv (to_Zp_poly f)) (to_Zp a))
+        < val_Zp (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> y)"
+      unfolding 0 eval Zp.to_fun_def h_def 
+      apply(intro conjI y_closed)
+      using eval Zp.to_fun_def apply (simp; fail)
+      using A unfolding 0 eval Zp.to_fun_def h_def 3 
+      using assms(2) to_Zp_val val_ring_minus_closed by presburger
+    have 2: "y = \<alpha>"
+      using 1 \<alpha>_def by blast
+    show "x = \<beta>"
+      using y_def unfolding 2 8 using A \<beta>_closed 
+      by (metis to_Zp_inc)
+  qed
+  show "\<exists>!\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<and> f \<bullet> \<alpha> = \<zero> \<and> val (UPQ.pderiv f \<bullet> a) < val (a \<ominus> \<alpha>)"
+    using 12 13 by metis
+qed
+
+lemma nth_root_poly_root_fixed:
+  assumes "(n::nat) > 1"
+  assumes "a \<in> \<O>\<^sub>p"
+  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 \<and>  val (b \<ominus> \<one>) > val ([n]\<cdot>\<one>))"
+proof- 
+  obtain f where f_def: "f = up_ring.monom (UP Q\<^sub>p) \<one> n \<ominus>\<^bsub>UP Q\<^sub>p\<^esub> up_ring.monom (UP Q\<^sub>p) a 0"
+    by blast 
+  have f_closed: "f \<in> carrier (UP Q\<^sub>p)"
+    unfolding f_def apply(rule UPQ.P.ring_simprules)
+     apply (simp; fail)   using assms 
+    by (simp add: val_ring_memE(2))
+  have 0: "UPQ.pderiv (up_ring.monom (UP Q\<^sub>p) a 0) = \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+    using assms 
+    by (simp add: val_ring_memE(2))
+  have 1: "UPQ.pderiv (up_ring.monom (UP Q\<^sub>p) (\<one>) n) = (up_ring.monom (UP Q\<^sub>p) ([n]\<cdot>\<one>) (n-1)) "
+    using UPQ.pderiv_monom by blast
+  have 2: "up_ring.monom (UP Q\<^sub>p) \<one> n \<in> carrier (UP Q\<^sub>p)"
+    by simp
+  have 3: "up_ring.monom (UP Q\<^sub>p) a 0 \<in> carrier (UP Q\<^sub>p)"
+    using assms val_ring_memE by simp 
+  have 4: "UPQ.pderiv f  = up_ring.monom (UP Q\<^sub>p) ([n] \<cdot> \<one>) (n - 1)  \<ominus>\<^bsub>UP Q\<^sub>p\<^esub> \<zero>\<^bsub>UP Q\<^sub>p\<^esub>"
+    using 2 3 assms val_ring_memE UPQ.pderiv_minus[of "up_ring.monom (UP Q\<^sub>p) \<one> n" "up_ring.monom (UP Q\<^sub>p) a 0"]
+    unfolding f_def 0 1 by blast
+  have 5: "UPQ.pderiv f = (up_ring.monom (UP Q\<^sub>p) ([n]\<cdot>\<one>) (n-1))"
+    unfolding 4 a_minus_def by simp
+  have a_closed: "a \<in> carrier Q\<^sub>p"
+    using assms val_ring_memE by blast 
+  have 6: "UPQ.pderiv f \<bullet> \<one> = [n]\<cdot>\<one> \<otimes> \<one>[^](n-1)"
+    unfolding 5 using a_closed 
+    by (simp add: UPQ.to_fun_monom)
+  have 7: "val (\<one> \<ominus>\<^bsub>Q\<^sub>p\<^esub> a) > val \<one>"
+  proof- 
+    have "eint 2 * val ([n] \<cdot> \<one>) \<ge> 0"
+      by (meson eint_ord_trans eint_pos_int_times_ge val_of_nat_inc zero_less_numeral) 
+    thus ?thesis
+      using assms unfolding val_one  
+      by (simp add: Q\<^sub>p_def)
+  qed
+  hence 8: "val a = val \<one>"
+    using a_closed 
+    by (metis Qp.cring_simprules(6) ultrametric_equal_eq')
+  have 9:"val (a [^] (n - 1)) = 0"
+    by (simp add: "8" local.a_closed val_zero_imp_val_pow_zero) 
+  have 10: "val ([n]\<cdot>\<one> \<otimes> \<one>[^](n-1)) = val ([n]\<cdot>\<one>)"
+    unfolding val_one 9 by simp
+  have 11: "0 \<le> gauss_norm f"
+  proof- 
+    have p0: "gauss_norm (up_ring.monom (UP Q\<^sub>p) \<one> n) \<ge> 0"
+      using gauss_norm_monom by simp
+    have p1: "gauss_norm (up_ring.monom (UP Q\<^sub>p) a 0) \<ge> 0"
+      using gauss_norm_monom assms val_ring_memE by simp
+    have p2: "min (gauss_norm (up_ring.monom (UP Q\<^sub>p) \<one> n)) (gauss_norm (up_ring.monom (UP Q\<^sub>p) a 0)) \<ge> 0"
+      using p0 p1 by simp 
+    have p3: "0 \<le> gauss_norm
+      (up_ring.monom (UP Q\<^sub>p) \<one> n \<ominus>\<^bsub>UP Q\<^sub>p\<^esub> up_ring.monom (UP Q\<^sub>p) a 0)"
+      using gauss_norm_ultrametric'[of "up_ring.monom (UP Q\<^sub>p) \<one> n" "up_ring.monom (UP Q\<^sub>p) a 0"]
+            p2  "2" "3" eint_ord_trans  by blast
+    show ?thesis using p3 unfolding f_def by simp 
+  qed
+  have 12: "\<And>\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<Longrightarrow> f \<bullet> \<alpha> = \<alpha>[^]n \<ominus> a"
+    unfolding f_def using a_closed 
+    by (simp add: UPQ.to_fun_const UPQ.to_fun_diff UPQ.to_fun_monic_monom val_ring_memE(2))
+  have 13: "\<exists>!\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<and> f \<bullet> \<alpha> = \<zero> \<and> val (UPQ.pderiv f \<bullet> \<one>) < val (\<one> \<ominus> \<alpha>)"
+    apply(rule hensels_lemma, rule f_closed, rule one_in_val_ring, rule 11) 
+    unfolding 6 10  
+    using a_closed assms 12[of \<one>] assms(3) 
+    by (simp add: one_in_val_ring)
+  have 14: "\<And>\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<Longrightarrow> \<alpha>[^]n = a \<longleftrightarrow> f \<bullet> \<alpha> = \<zero>"
+    unfolding f_def using a_closed 12 f_def val_ring_memE(2) by auto
+  have 15: "val (UPQ.pderiv f \<bullet> \<one>) = val ([n]\<cdot>\<one>)"
+    unfolding 6 10 by auto 
+  have 16: "\<And>\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<Longrightarrow> val (\<one> \<ominus> \<alpha>) = val (\<alpha> \<ominus> \<one>)"
+  proof- 
+    have 17: "\<And>\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<Longrightarrow> (\<one> \<ominus> \<alpha>) = \<ominus> (\<alpha> \<ominus> \<one>)"
+      using val_ring_memE 
+      by (meson Qp.minus_a_inv Qp.one_closed)
+    show "\<And>\<alpha>. \<alpha> \<in> \<O>\<^sub>p \<Longrightarrow> val (\<one> \<ominus> \<alpha>) = val (\<alpha> \<ominus> \<one>)"
+      unfolding 17 
+      using Qp.minus_closed Qp.one_closed val_minus val_ring_memE(2) by presburger
+  qed
+  show ?thesis using 13 unfolding 15 using 14 16 Qp.one_closed val_ring_memE(2) by metis   
+qed
+
+lemma mod_zeroE: 
+  assumes "(a::int) mod k  = 0"
+  shows "\<exists>l. a = l*k"
+  using assms 
+  using Groups.mult_ac(2) by blast
+
+lemma to_Zp_poly_closed':
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>i. g i \<in> \<O>\<^sub>p"
+  shows "to_Zp_poly g \<in> carrier (UP Z\<^sub>p)"
+proof(rule to_Zp_poly_closed)
+  show "g \<in> carrier (UP Q\<^sub>p)"
+    using assms(1) by blast 
+  show "0 \<le> gauss_norm g"
+  proof-
+    have "\<And>i. val (g i) \<ge> 0"
+      using assms val_ring_memE by blast 
+    thus ?thesis unfolding gauss_norm_def 
+      by (metis  gauss_norm_coeff_norm gauss_norm_def)
+  qed
+qed
+
+lemma to_Zp_poly_eval_to_Zp:
+  assumes "g \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And>i. g i \<in> \<O>\<^sub>p"
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "to_function Z\<^sub>p (to_Zp_poly g) (to_Zp a) = to_Zp (g \<bullet> a)"
+proof- 
+  have "(\<forall>i. g i \<in> \<O>\<^sub>p) \<longrightarrow> to_function Z\<^sub>p (to_Zp_poly g) (to_Zp a) = to_Zp (g \<bullet> a)"
+    apply(rule UPQ.poly_induct[of g]) using assms apply blast
+  proof 
+    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"
+    obtain c where c_def: "c \<in> carrier Q\<^sub>p \<and> p = up_ring.monom (UP Q\<^sub>p) c  0"
+      using A  by (metis UPQ.ltrm_deg_0 val_ring_memE(2))
+    have 0: "to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c  0) = up_ring.monom (UP Z\<^sub>p) (to_Zp c) 0"
+      unfolding to_Zp_poly_def proof fix n show " to_Zp (up_ring.monom (UP Q\<^sub>p) c 0 n) = up_ring.monom (UP Z\<^sub>p) (to_Zp c) 0 n"
+        using UP_ring.cfs_monom[of Z\<^sub>p "to_Zp c" 0 n] UP_ring.cfs_monom[of Q\<^sub>p c 0 n] to_Zp_closed[of c ]
+        unfolding UP_ring_def 
+        apply(cases "0 = n")
+        using UPQ.cfs_monom Zp.cfs_monom c_def apply presburger
+         using UPQ.cfs_monom Zp.cfs_monom c_def 
+         using to_Zp_zero by presburger
+    qed    
+    have p_eq: "p = up_ring.monom (UP Q\<^sub>p) c  0"
+      using c_def by blast 
+    have 1: "(up_ring.monom (UP Q\<^sub>p) c 0 \<bullet> a) = c"
+      using UPQ.to_fun_to_poly[of c a]  c_def assms val_ring_memE 
+      unfolding to_polynomial_def  by blast 
+    show "to_function Z\<^sub>p (to_Zp_poly p) (to_Zp a) = to_Zp (p \<bullet> a)"
+      using c_def assms(3) val_ring_memE(2)[of a]
+      UP_cring.to_fun_to_poly[of Z\<^sub>p "to_Zp c" "to_Zp a"]
+      unfolding p_eq 0 1 Zp.to_fun_def to_polynomial_def  
+      using Zp.UP_cring_axioms to_Zp_closed by blast
+  next  
+    show "\<And>p. (\<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) \<longrightarrow> to_function Z\<^sub>p (to_Zp_poly q) (to_Zp a) = to_Zp (q \<bullet> a)) \<Longrightarrow>
+         p \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> 0 < deg Q\<^sub>p p \<Longrightarrow> (\<forall>i. p i \<in> \<O>\<^sub>p) \<longrightarrow> to_function Z\<^sub>p (to_Zp_poly p) (to_Zp a) = to_Zp (p \<bullet> a)"
+    proof  fix p 
+      assume A: "(\<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) \<longrightarrow> to_function Z\<^sub>p (to_Zp_poly q) (to_Zp a) = to_Zp (q \<bullet> a))"
+            "p \<in> carrier (UP Q\<^sub>p)" "0 < deg Q\<^sub>p p" "\<forall>i. p i \<in> \<O>\<^sub>p"
+      show "to_function Z\<^sub>p (to_Zp_poly p) (to_Zp a) = to_Zp (p \<bullet> a)"
+      proof- 
+        obtain q where q_def: "q = truncate Q\<^sub>p  p"
+          by blast 
+        have  q_closed: "q \<in> carrier (UP Q\<^sub>p)"
+          unfolding q_def by(rule UPQ.trunc_closed, rule A)
+        obtain c where c_def: "c = UPQ.lcf p"
+          by blast 
+        obtain n where n_def: "n = deg Q\<^sub>p p"
+          by blast 
+        have 0: "p = q \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> up_ring.monom (UP Q\<^sub>p) c n"
+          unfolding c_def n_def q_def 
+          using A(2) UPQ.trunc_simps(1) by blast
+        have 1: "up_ring.monom (UP Q\<^sub>p) c n \<in> carrier  (UP Q\<^sub>p)"
+          using A(2) UPQ.ltrm_closed c_def n_def by blast
+        have 2: "p \<bullet> a  = q  \<bullet> a \<oplus> (c \<otimes> a[^]n)"
+          unfolding 0 using assms val_ring_memE  
+          by (metis "1" A(4) UPQ.to_fun_monom UPQ.to_fun_plus c_def q_closed)
+        have 3: "\<And>i. i < n \<Longrightarrow> q i = p i"
+          unfolding n_def q_def 
+          using A(2) UPQ.trunc_cfs by blast
+        have 4: "deg Q\<^sub>p q < n"
+          unfolding n_def q_def using A
+          using UPQ.trunc_degree by presburger
+        have 5: "\<And>i. i \<ge> n \<Longrightarrow> i >  deg Q\<^sub>p q"
+          using A[of ] less_le_trans[of "deg Q\<^sub>p q" "deg Q\<^sub>p p"] unfolding q_def n_def  
+          using "4" n_def q_def by blast
+        have 6: "\<And>i. i \<ge> n \<Longrightarrow> q i = \<zero>"
+          using q_closed 5 UPQ.deg_leE by blast
+        have 7: "(\<forall>i. q i \<in> \<O>\<^sub>p) \<longrightarrow> to_function Z\<^sub>p (to_Zp_poly q) (to_Zp a) = to_Zp (q \<bullet> a)"
+          apply(rule   A) unfolding q_def 
+          using q_closed q_def apply blast
+          using "4" n_def q_def by blast
+        have 8: "(\<forall>i. q i \<in> \<O>\<^sub>p)"
+        proof fix i show "q i \<in> \<O>\<^sub>p" apply(cases "i < n") 
+            using 3 A(4) apply blast using 6[of i] 
+            by (metis less_or_eq_imp_le linorder_neqE_nat zero_in_val_ring)
+        qed
+        have 9: "to_function Z\<^sub>p (to_Zp_poly q) (to_Zp a) = to_Zp (q \<bullet> a)"
+          using 7 8 by blast 
+        have 10: "to_Zp_poly p = to_Zp_poly q \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n)"
+        proof fix x  
+          have 100: "to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n) = (up_ring.monom (UP Z\<^sub>p) (to_Zp c) n)"
+            using to_Zp_poly_monom[of c] A(4) c_def by blast
+          have 101: "deg Z\<^sub>p (to_Zp_poly q) \<le> n-1"
+              apply(rule  UP_cring.deg_leqI)
+              unfolding UP_cring_def using Zp.R_cring apply auto[1]
+              using to_Zp_poly_closed' 8 q_closed apply blast
+              unfolding to_Zp_poly_def using 4 6 
+              by (simp add: to_Zp_zero) 
+          have 102: "(to_Zp_poly q) \<in> carrier (UP Z\<^sub>p)"
+            apply(rule to_Zp_poly_closed', rule q_closed) using 8 by blast 
+          have 103: "deg Z\<^sub>p (to_Zp_poly q) < n"
+            using 101 4 by linarith
+            have T0: "(to_Zp_poly q \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n)) x = 
+                    (to_Zp_poly q x) \<oplus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n) x)"
+              apply(rule  UP_ring.cfs_add)
+              unfolding UP_ring_def apply (simp add: Zp.is_ring)
+               apply(rule 102) unfolding 100 apply(rule UP_ring.monom_closed)
+              unfolding UP_ring_def apply (simp add: Zp.is_ring)
+              apply(rule  to_Zp_closed ) unfolding c_def 
+              using A(2) UPQ.UP_car_memE(1) by blast
+            have c_closed: "c \<in> \<O>\<^sub>p"
+              unfolding c_def  using A(4) by blast
+            have to_Zp_c_closed: "to_Zp c \<in> carrier Z\<^sub>p"
+              using c_closed to_Zp_closed val_ring_memE(2) by blast
+          show "to_Zp_poly p x = (to_Zp_poly q \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n)) x"
+          proof(cases "x < n")
+            case True
+            have T1: "(to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n) x) = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+              using True UP_ring.cfs_monom[of Z\<^sub>p] unfolding UP_ring_def 
+              by (metis "100" A(2) UPQ.cfs_closed UPQ.deg_leE Zp.is_ring c_def n_def to_Zp_closed to_Zp_zero)
+            have T2: "to_Zp (p x) = to_Zp (q x)" using 3[of x] True by smt 
+            have T3: "to_Zp (p x) \<in> carrier Z\<^sub>p"
+              apply(rule to_Zp_closed) using A(2) UPQ.UP_car_memE(1) by blast
+            show ?thesis using T3 
+              unfolding T0  unfolding T1 unfolding  to_Zp_poly_def  T2  
+              using Zp.cring_simprules(8) add_comm by presburger
+          next
+            case False
+            have F: "q x = \<zero> "
+              using False  
+              by (metis "6" less_or_eq_imp_le linorder_neqE_nat)
+            have F': "(to_Zp_poly q) x = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+             unfolding to_Zp_poly_def F using to_Zp_zero by blast
+            show "to_Zp_poly p x = (to_Zp_poly q \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n)) x"
+            proof(cases "x = n")
+              case True
+              have T1: "to_Zp (p x) \<in> carrier Z\<^sub>p"
+                apply(rule to_Zp_closed)
+                using A(2) UPQ.UP_car_memE(1) by blast
+              have T2: "(to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n) x) = to_Zp c"
+                unfolding 100 using UP_ring.cfs_monom[of Z\<^sub>p "to_Zp c" n n] unfolding UP_ring_def True
+                using Zp.is_ring to_Zp_c_closed by presburger
+              show ?thesis using to_Zp_c_closed unfolding T0 F' T2 unfolding to_Zp_poly_def True c_def n_def
+                using Zp.cring_simprules(8) by presburger
+            next
+              case FF: False
+              have F0: "p x = \<zero>"
+                using FF False unfolding n_def 
+                using A(2) UPQ.UP_car_memE(2) linorder_neqE_nat by blast
+              have F1: "q x = \<zero>"
+                using FF False F by linarith
+              have F2: "(up_ring.monom (UP Q\<^sub>p) c n) x = \<zero>"
+                using FF False A(2) UPQ.cfs_closed UPQ.cfs_monom c_def by presburger
+              show ?thesis unfolding T0 unfolding to_Zp_poly_def F0 F1 F2
+                using Zp.r_zero Zp.zero_closed to_Zp_zero by presburger
+            qed
+          qed
+        qed
+        have 11: "deg Z\<^sub>p (to_Zp_poly q) \<le> n-1"
+          apply(rule  UP_cring.deg_leqI)
+          unfolding UP_cring_def using Zp.R_cring apply auto[1]
+          using to_Zp_poly_closed' 8 q_closed apply blast
+          unfolding to_Zp_poly_def using 4 6 
+          by (smt diff_commute diff_diff_cancel less_one less_or_eq_imp_le linorder_neqE_nat to_Zp_zero zero_less_diff)
+        have 12: "(to_Zp_poly q) \<in> carrier (UP Z\<^sub>p)"
+          apply(rule to_Zp_poly_closed', rule q_closed) using 8 by blast 
+        have 13: "deg Z\<^sub>p (to_Zp_poly q) < n"
+          using 11 4 by linarith
+        have 14: "to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n) = (up_ring.monom (UP Z\<^sub>p) (to_Zp c) n)"
+          using to_Zp_poly_monom[of c] A(4) c_def by blast
+        have 15: "Zp.to_fun (to_Zp_poly q \<oplus>\<^bsub>UP Z\<^sub>p\<^esub> to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n)) (to_Zp a)= 
+            Zp.to_fun (to_Zp_poly q) (to_Zp a) \<oplus>\<^bsub>Z\<^sub>p\<^esub> Zp.to_fun (to_Zp_poly (up_ring.monom (UP Q\<^sub>p) c n)) (to_Zp a)"
+          apply(rule Zp.to_fun_plus)
+          unfolding 14  apply(rule UP_ring.monom_closed) 
+          unfolding UP_ring_def using Zp.is_ring apply auto[1]
+          apply(rule to_Zp_closed) unfolding c_def 
+          using A(2) UPQ.cfs_closed apply blast
+          using 12 apply blast 
+          apply(rule to_Zp_closed) using assms val_ring_memE by blast 
+        have 16: "to_Zp (q \<bullet> a \<oplus> c \<otimes> a [^] n) = to_Zp (q \<bullet> a)  \<oplus>\<^bsub>Z\<^sub>p\<^esub> to_Zp (c \<otimes> a [^] n)"
+          apply(rule to_Zp_add)
+           apply(rule val_ring_poly_eval, rule q_closed) 
+            using "8" apply blast
+             apply(rule assms)
+            apply(rule val_ring_times_closed)
+            unfolding c_def using A(4) apply blast
+          by(rule val_ring_nat_pow_closed, rule assms)
+        have  17: " to_function Z\<^sub>p (up_ring.monom (UP Z\<^sub>p) (to_Zp c) n) (to_Zp a) =  to_Zp (c \<otimes> a [^] n)"
+          proof-
+            have 170: "to_Zp (c \<otimes> a [^] n) = to_Zp c \<otimes>\<^bsub>Z\<^sub>p\<^esub> to_Zp (a [^] n)"
+              apply(rule  to_Zp_mult[of c "a[^]n"])
+              unfolding c_def using A(4) apply blast
+              by(rule val_ring_nat_pow_closed, rule assms)
+            have 171: "to_Zp (a [^] n) = (to_Zp a [^]\<^bsub>Z\<^sub>p\<^esub>n)"
+              by(rule to_Zp_nat_pow, rule assms)
+            have 172: "to_Zp c \<in> carrier Z\<^sub>p "
+              apply(rule to_Zp_closed) unfolding c_def 
+              using A(2) UPQ.UP_car_memE(1) by blast
+            have 173: "to_Zp a \<in> carrier Z\<^sub>p "
+              apply(rule to_Zp_closed) using assms val_ring_memE by blast  
+            show ?thesis
+              using 172 173 Zp.to_fun_monom[of "to_Zp c" "to_Zp a" n] unfolding Zp.to_fun_def 170 171
+              by blast 
+        qed
+        show ?thesis
+          using 15 unfolding Zp.to_fun_def 10 2 16 9 unfolding 14 17
+          by blast 
+      qed
+    qed
+  qed
+  thus ?thesis using assms by blast 
+qed
+
+lemma inc_nat_pow:
+  assumes "a \<in> carrier Z\<^sub>p"
+  shows "\<iota> ([(n::nat)] \<cdot>\<^bsub>Z\<^sub>p\<^esub>a) = [n]\<cdot>(\<iota> a)"
+  apply(induction n)
+  apply (metis Q\<^sub>p_def Qp.int_inc_zero Qp.nat_mult_zero Zp.add.nat_pow_0 Zp_int_inc_zero' \<iota>_def frac_inc_of_int)
+  unfolding Qp.add.nat_pow_Suc Zp.add.nat_pow_Suc 
+  using Zp_nat_mult_closed assms inc_of_sum by presburger
+  
+lemma poly_inc_pderiv:
+  assumes "g \<in> carrier (UP Z\<^sub>p)"
+  shows "poly_inc (Zp.pderiv g) = UPQ.pderiv (poly_inc g)"
+proof fix x
+  have 0: "UPQ.pderiv (poly_inc g) x = [Suc x] \<cdot> poly_inc g (Suc x)"
+    apply(rule UPQ.pderiv_cfs[of "poly_inc g" x])
+    by(rule poly_inc_closed, rule assms)
+  have 1: "Zp.pderiv g x = [Suc x] \<cdot>\<^bsub>Z\<^sub>p\<^esub> g (Suc x)"
+    by(rule Zp.pderiv_cfs[of g x], rule assms)
+  show "poly_inc (Zp.pderiv g) x = UPQ.pderiv (poly_inc g) x"
+    unfolding 0  unfolding poly_inc_def 1 apply(rule  inc_nat_pow)
+    using Zp.UP_car_memE(1) assms by blast
+qed
+
+lemma Zp_hensels_lemma:
+  assumes "f \<in> carrier Zp_x"
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "Zp.to_fun (Zp.pderiv f) a \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+  assumes "Zp.to_fun f a \<noteq> \<zero>\<^bsub>Z\<^sub>p \<^esub>"
+  assumes "val_Zp (Zp.to_fun f a) > eint 2 * val_Zp (Zp.to_fun (Zp.pderiv f) a)"
+  obtains \<alpha> where
+       "Zp.to_fun f \<alpha> = \<zero>\<^bsub>Z\<^sub>p\<^esub>" and "\<alpha> \<in> carrier Z\<^sub>p" 
+       "val_Zp (a \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>) > val_Zp (Zp.to_fun (Zp.pderiv f) a)"
+       "val_Zp (a \<ominus>\<^bsub>Z\<^sub>p\<^esub> \<alpha>) = val_Zp (divide (Zp.to_fun f a) (Zp.to_fun (Zp.pderiv f) a))"
+       "val_Zp (Zp.to_fun (Zp.pderiv f) \<alpha>) = val_Zp (Zp.to_fun (Zp.pderiv f) a)"
+proof-
+  have "hensel p f a"
+    using assms 
+    by (simp add: Zp_def hensel.intro hensel_axioms.intro padic_integers_axioms)
+  then show ?thesis 
+    using hensel.full_hensels_lemma[of p f a] that 
+    unfolding Zp_def    
+    by blast       
+qed
+
+end
+end
diff --git a/thys/Padic_Field/Padic_Field_Powers.thy b/thys/Padic_Field/Padic_Field_Powers.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Padic_Field_Powers.thy
@@ -0,0 +1,11440 @@
+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)
+  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 (metis in_set_conv_nth le_numeral_extra(4) less_one numeral_le_iff numeral_less_iff padic_fields.singleton_length padic_fields_axioms semiring_norm(173) semiring_norm(79) Qp.to_R_to_R1)
+        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 (metis Suc_1 eval_nat_numeral(3) plus_1_eq_Suc semiring_norm(164))
+        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 
+          using eval_nat_numeral(3) semiring_norm(175) by presburger
+
+        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 (metis le_numeral_extra(4) take_closed numeral_le_iff semiring_norm(173) semiring_norm(72))
+           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 (metis in_set_conv_nth le_numeral_extra(4) less_one numeral_le_iff numeral_less_iff padic_fields.singleton_length padic_fields_axioms semiring_norm(173) semiring_norm(79) Qp.to_R_to_R1)
+        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 (metis Suc_1 eval_nat_numeral(3) plus_1_eq_Suc semiring_norm(164))
+        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 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 
+          using eval_nat_numeral(3) semiring_norm(175) by presburger
+
+        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 
+          using eval_nat_numeral(3) semiring_norm(175) by presburger
+
+        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 
+          using eval_nat_numeral(3) semiring_norm(175) by presburger
+
+        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/Padic_Field/Padic_Field_Topology.thy b/thys/Padic_Field/Padic_Field_Topology.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Padic_Field_Topology.thy
@@ -0,0 +1,1326 @@
+theory Padic_Field_Topology
+  imports Padic_Fields
+begin
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Topology of $p$-adic Fields\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  In this section we develop some basic properties of the topology on the $p$-adics. Open and 
+  closed sets are defined, convex subsets of the value group are characterized.
+\<close>
+type_synonym padic_univ_poly = "nat \<Rightarrow> padic_number"  
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>$p$-adic Balls\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context padic_fields
+begin
+
+definition c_ball :: "int \<Rightarrow> padic_number \<Rightarrow> padic_number set" ("B\<^bsub>_\<^esub>[_]") where
+"c_ball n c = {x \<in> carrier Q\<^sub>p. val (x \<ominus> c) \<ge> n}"
+
+lemma c_ballI: 
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes " val (x \<ominus> c) \<ge> n"
+  shows "x \<in> c_ball n c"
+  using assms c_ball_def 
+  by blast
+
+lemma c_ballE: 
+  assumes "x \<in> c_ball n c"
+  shows "x \<in> carrier Q\<^sub>p"
+        " val (x \<ominus> c) \<ge> n"
+  using assms c_ball_def apply blast
+    using assms c_ball_def by blast
+
+lemma c_ball_in_Qp: 
+  "B\<^bsub>n\<^esub>[c] \<subseteq> carrier Q\<^sub>p"
+  unfolding c_ball_def 
+  by blast
+
+definition  
+q_ball :: "nat \<Rightarrow> int \<Rightarrow> int \<Rightarrow> padic_number \<Rightarrow> padic_number set" where
+"q_ball n k m c = {x \<in> carrier Q\<^sub>p. (ac n (x \<ominus> c) = k \<and> (ord (x \<ominus> c)) = m) }"
+
+lemma q_ballI: 
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "ac n (x \<ominus> c) = k" 
+  assumes "(ord (x \<ominus> c)) = m"
+  shows "x \<in> q_ball n k m c"
+  using assms q_ball_def 
+  by blast
+
+lemma q_ballE: 
+  assumes "x \<in> q_ball n k m c "
+  shows "x \<in> carrier Q\<^sub>p"
+
+  using assms q_ball_def by blast 
+
+lemma q_ballE': 
+  assumes "x \<in> q_ball n k m c "
+  shows  "ac n (x \<ominus> c) = k" 
+        "(ord (x \<ominus> c)) = m"
+  using assms q_ball_def apply blast 
+  using assms q_ball_def by blast 
+
+lemma q_ball_in_Qp: 
+  "q_ball n k m c  \<subseteq> carrier Q\<^sub>p"
+  unfolding q_ball_def by blast 
+
+lemma ac_ord_prop:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  assumes "ord a = ord b"
+  assumes "ord a = n"
+  assumes "ac m a = ac m b"
+  assumes "m > 0"
+  shows "val (a \<ominus> b) \<ge> m + n "
+proof-
+  have 0: "a = (\<pp>[^]n) \<otimes> \<iota> (angular_component a)"
+    using angular_component_factors_x assms(1) assms(4) by blast
+  have 1: "b = (\<pp>[^]n) \<otimes> \<iota> (angular_component b)"
+    using angular_component_factors_x assms(4) assms(2) assms(3) 
+    by presburger
+  have 2: "a \<ominus>b = (\<pp>[^]n) \<otimes> \<iota> (angular_component a) \<ominus>
+                     (\<pp>[^]n) \<otimes> \<iota> (angular_component b) "
+    using 0 1 by auto 
+  have 3: "a \<ominus>b = (\<pp>[^]n) \<otimes>( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b))"
+  proof-
+    have 30: "(\<pp>[^]n) \<in> carrier Q\<^sub>p"
+      by (simp add: p_intpow_closed(1))        
+    have 31: " \<iota> (angular_component a)  \<in> carrier Q\<^sub>p"
+      using Zp.nonzero_one_closed angular_component_closed assms(1) frac_closed local.inc_def 
+      by presburger
+    have 32: " \<iota> (angular_component b)  \<in> carrier Q\<^sub>p"
+      using Zp.nonzero_one_closed angular_component_closed assms(2) frac_closed local.inc_def 
+      by presburger
+    show ?thesis 
+      using 2 30 31 32 ring.ring_simprules(23)[of Q\<^sub>p "(\<pp>[^]n)"]
+      unfolding a_minus_def 
+      by (metis Qp.domain_axioms cring.cring_simprules(25) cring.cring_simprules(29) 
+          cring.cring_simprules(3) domain.axioms(1))
+  qed
+  have 4: "a \<ominus>b = (\<pp>[^]n) \<otimes>( \<iota> ((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>  (angular_component b)))"
+    using 3 
+    by (simp add: angular_component_closed assms(1) assms(2) inc_of_diff)    
+  have 5: "val_Zp ((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>  (angular_component b)) \<ge>  m "    
+  proof-
+    have "((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub> (angular_component b)) m = 0"      
+      using assms(5)
+      unfolding ac_def 
+      using Q\<^sub>p_def Qp.nonzero_memE(2) angular_component_closed assms(1) assms(2) residue_of_diff' 
+      by auto     
+    then show ?thesis 
+      using  Zp.minus_closed angular_component_closed assms(1) assms(2) ord_Zp_geq val_Zp_def val_ord_Zp
+      by auto      
+  qed
+  have 6: "val (a \<ominus> b) \<ge> n + val ( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b))"
+    using 3 Qp.minus_closed angular_component_closed assms(1) assms(2) inc_closed 
+        ord_p_pow_int p_intpow_closed(1) p_intpow_closed(2) val_mult val_ord
+    by simp
+  have 7: "n + val ( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b)) 
+          = n + val_Zp ((angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>  (angular_component b))"
+    using Zp.minus_closed angular_component_closed assms(1) assms(2) inc_of_diff val_of_inc 
+    by simp
+  have 8: "n + val_Zp ( (angular_component a) \<ominus>\<^bsub>Z\<^sub>p\<^esub>(angular_component b))
+                \<ge> n + m"
+    using 5 
+    by (metis add_mono_thms_linordered_semiring(2) plus_eint_simps(1))
+  then have 9: "n + val ( \<iota> (angular_component a) \<ominus>  \<iota> (angular_component b)) 
+                \<ge> n + m"
+    using "7" by presburger
+  then show ?thesis 
+    by (metis (no_types, opaque_lifting) "6" add.commute order_trans plus_eint_simps(1))   
+qed
+
+lemma c_ball_q_ball: 
+  assumes "b \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  assumes "k = ac n b"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "d \<in> q_ball n k m c"
+  shows "q_ball n k m c = c_ball (m + n) d"
+proof
+  show "q_ball n k m c \<subseteq> B\<^bsub>m + int n\<^esub>[d]"
+  proof
+    fix x
+    assume A0: "x \<in> q_ball n k m c"
+    show "x \<in> B\<^bsub>m + int n\<^esub>[d]"
+    proof-
+      have A1: "(ac n (x \<ominus> c) = k \<and> (ord (x \<ominus> c)) = m)"
+        using A0 q_ball_def 
+        by blast
+      have "val (x \<ominus> d) \<ge> m + n"
+      proof-
+        have A2: "(ac n (d \<ominus> c) = k \<and> (ord (d \<ominus> c)) = m)"
+          using assms(5) q_ball_def 
+          by blast
+        have A3: "(x \<ominus> c) \<in> nonzero Q\<^sub>p"
+        proof-
+          have "k \<noteq>0"
+            using A2 assms(1) assms(3) assms(5) ac_units[of b n]
+            by (metis One_nat_def Suc_le_eq assms(2) zero_not_in_residue_units)                            
+          then show ?thesis 
+            by (smt A0 Qp.domain_axioms ac_def assms(4) cring.cring_simprules(4) domain.axioms(1)
+              mem_Collect_eq not_nonzero_Qp q_ball_def)
+        qed
+        have A4: "(d \<ominus> c) \<in> nonzero Q\<^sub>p"
+        proof-
+          have "k \<noteq>0"
+            using A2 assms(1) assms(3) assms(5) ac_units[of b n] 
+            by (metis One_nat_def Suc_le_eq assms(2) zero_not_in_residue_units)         
+          then show ?thesis 
+            by (metis (no_types, lifting) A2 Qp.domain_axioms ac_def assms(4) assms(5) 
+                cring.cring_simprules(4) domain.axioms(1) mem_Collect_eq not_nonzero_Qp q_ball_def)
+        qed
+        then have " val ((x \<ominus> c) \<ominus>(d \<ominus> c)) \<ge>  n + m"
+          using ac_ord_prop[of "(x \<ominus> c)" "(d \<ominus> c)" m n ] A1 A2 assms A3 
+          by simp          
+        then show ?thesis 
+          by (smt A0 Qp_diff_diff assms(4) assms(5) q_ballE)
+      qed
+      then show ?thesis 
+        by (metis (no_types, lifting) A0 c_ball_def mem_Collect_eq q_ball_def)
+    qed
+  qed
+  show "B\<^bsub>m + int n\<^esub>[d] \<subseteq> q_ball n k m c"
+  proof
+    fix x
+    assume A: "x \<in> B\<^bsub>m + int n\<^esub>[d]"
+    show "x \<in> q_ball n k m c"
+    proof-
+      have A0: "val (x \<ominus> d) \<ge> m + n"
+        using A c_ball_def 
+        by blast
+      have A1: "ord (d \<ominus> c) = m"
+        using assms(5) q_ball_def 
+        by blast
+      have A2: "ac n (d \<ominus> c) = k"
+        using assms(5) q_ball_def 
+        by blast 
+      have A3: "(d \<ominus> c) \<noteq> \<zero>" 
+        using A2 assms 
+        by (metis ac_def ac_units le_eq_less_or_eq le_neq_implies_less less_one nat_le_linear 
+            padic_integers.zero_not_in_residue_units padic_integers_def prime zero_less_iff_neq_zero)                    
+      have A4: "val (d \<ominus> c) =m"
+        by (simp add: A1 A3 val_def)
+      have A5: "val (x \<ominus> d) > val (d \<ominus> c)"
+        by (smt A0 A4 assms(2) eint_ord_code(4) eint_ord_simps(1) eint_ord_simps(2) of_nat_0_less_iff val_def)        
+      have A6: "val ((x \<ominus> d) \<oplus> (d \<ominus> c)) = m"
+        using A4 A0 A5  
+        by (metis (mono_tags, opaque_lifting) A Qp.minus_closed assms(4) assms(5) 
+            c_ballE(1) q_ballE val_ultrametric_noteq)       
+      have A7: "val (x \<ominus> c) = m"
+      proof-
+        have "(x \<ominus> d) \<oplus> (d \<ominus> c) = ((x \<ominus> d) \<oplus> d) \<ominus> c"
+          by (metis (no_types, lifting) A Qp.domain_axioms a_minus_def assms(4) assms(5)
+              c_ball_def cring.cring_simprules(3) cring.cring_simprules(4) 
+              cring.cring_simprules(7) domain.axioms(1) mem_Collect_eq q_ball_def)
+        have "(x \<ominus> d) \<oplus> (d \<ominus> c) = (x \<oplus> (\<ominus> d \<oplus> d)) \<ominus> c"
+          by (metis (no_types, opaque_lifting) A Qp.add.l_cancel_one Qp.add.m_comm Qp.l_neg 
+              Qp.minus_closed Qp.plus_diff_simp Qp.zero_closed assms(4) assms(5)
+              c_ballE(1) q_ballE)          
+        then show ?thesis 
+          by (metis (no_types, lifting) A A6 Qp.domain_axioms assms(5) c_ball_def 
+              cring.cring_simprules(16) cring.cring_simprules(9) domain.axioms(1) 
+              mem_Collect_eq q_ball_def)
+      qed
+      have A8: "ac n (x \<ominus> c) = ac n (d \<ominus> c)"
+      proof-
+        have A80: "(x \<ominus> c) \<in> nonzero Q\<^sub>p"
+          by (metis (no_types, lifting) A A4 A5 A7 Qp.domain_axioms 
+              assms(4) cring.cring_simprules(4) domain.axioms(1) 
+              mem_Collect_eq c_ball_def val_nonzero)
+        have A81: "(d \<ominus> c) \<in> nonzero Q\<^sub>p"
+          by (metis (no_types, lifting) A3 Qp.domain_axioms assms(4) assms(5) 
+              cring.cring_simprules(4) domain.axioms(1) mem_Collect_eq not_nonzero_Qp q_ball_def)
+        have A82: "n + m= val (x \<ominus> c) + n"
+          by (simp add: A7)
+        show ?thesis 
+          using A0 A4 A7 ac_val[of "(x \<ominus> c)" "(d \<ominus> c)" n] A A80 A81 Qp_diff_diff assms(4) assms(5) c_ballE(1) q_ballE 
+          by auto         
+      qed
+      show ?thesis using A8 A3 A7 A2 q_ball_def[of n k m c] q_ballI[of x n c k m]   
+        by (metis (no_types, lifting) A A4 A5 Qp.minus_closed assms(4) c_ballE(1) eint.inject val_nonzero val_ord)        
+    qed
+  qed
+qed
+
+definition is_ball :: "padic_number set \<Rightarrow> bool" where
+"is_ball B = (\<exists>(m::int). \<exists> c \<in> carrier Q\<^sub>p. (B = B\<^bsub>m\<^esub>[c]))" 
+
+lemma is_ball_imp_in_Qp:
+  assumes "is_ball B"
+  shows "B \<subseteq> carrier Q\<^sub>p"
+  unfolding is_ball_def 
+  using assms c_ball_in_Qp is_ball_def 
+  by auto
+
+lemma c_ball_centers:
+  assumes "is_ball B"
+  assumes "B = B\<^bsub>n\<^esub>[c]"
+  assumes "d \<in> B"
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "B = B\<^bsub>n\<^esub>[d]"
+proof
+  show "B \<subseteq> B\<^bsub>n\<^esub>[d]"
+  proof
+    fix x
+    assume A0: "x \<in> B"
+    have "val (x \<ominus> d) \<ge> n"
+    proof-
+      have A00: "val (x \<ominus> c) \<ge> n"
+        using A0 assms(2) c_ballE(2) by blast
+      have A01: "val (d \<ominus> c) \<ge> n"
+        using assms(2) assms(3) c_ballE(2) by blast
+      then show ?thesis 
+        using Qp_isosceles[of x c d "n"] assms A0 A00 c_ballE(1) 
+        by blast
+    qed
+    then show "x \<in> B\<^bsub>n\<^esub>[d]" 
+      using A0 assms(1) c_ballI is_ball_imp_in_Qp 
+      by blast
+  qed
+  show "B\<^bsub>n\<^esub>[d] \<subseteq> B"
+  proof
+    fix x
+    assume "x \<in> B\<^bsub>n\<^esub>[d]"
+    show "x \<in> B"
+      using Qp_isosceles[of x d c "n"]
+            assms 
+      unfolding c_ball_def
+      by (metis (no_types, lifting) Qp.domain_axioms Qp_isosceles \<open>x \<in> B\<^bsub>n\<^esub>[d]\<close> 
+          a_minus_def assms(2) c_ballE(2) c_ballI cring.cring_simprules(17) domain.axioms(1) 
+          c_ballE(1))
+  qed
+qed
+
+lemma c_ball_center_in:
+  assumes "is_ball B"
+  assumes "B = B\<^bsub>n\<^esub>[c]"
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "c \<in> B"
+  using assms  unfolding c_ball_def
+  by (metis (no_types, lifting) Qp.r_right_minus_eq assms(2) c_ballI eint_ord_code(3) local.val_zero)
+  
+text \<open>Every point a has a point b of distance exactly n away from it.\<close>
+lemma dist_nonempty:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "\<exists>b \<in> carrier Q\<^sub>p. val (b \<ominus> a) = eint n"
+proof-
+  obtain b where b_def: "b = (\<pp> [^] n) \<oplus> a"
+    by simp 
+  have "val (b \<ominus>a) = n"
+    using b_def assms 
+    by (metis (no_types, lifting) Qp.domain_axioms a_minus_def cring.cring_simprules(16)
+        cring.cring_simprules(17) cring.cring_simprules(3) cring.cring_simprules(7)
+        domain.axioms(1) ord_p_pow_int p_intpow_closed(1) p_intpow_closed(2) val_ord)
+  then show ?thesis 
+    by (metis Qp.domain_axioms assms b_def cring.cring_simprules(1) domain.axioms(1) p_intpow_closed(1))
+qed
+
+lemma dist_nonempty':
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "\<exists>b \<in> carrier Q\<^sub>p. val (b \<ominus> a) = \<alpha>"
+proof(cases "\<alpha> = \<infinity>")
+  case True
+  then have "val (a \<ominus> a) = \<alpha>"
+    using assms 
+    by (metis Qp.r_right_minus_eq local.val_zero)    
+  then show ?thesis 
+    using assms 
+    by blast
+next
+  case False
+  then obtain n where n_def: "eint n = \<alpha>"
+    by blast
+  then show ?thesis 
+    using assms dist_nonempty[of a n] 
+    by blast    
+qed
+
+lemma ball_rad_0:
+  assumes "is_ball B"
+  assumes "B\<^bsub>m\<^esub>[c] \<subseteq> B\<^bsub>n\<^esub>[c]"
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "n \<le> m"
+proof-
+  obtain b where b_def: "b \<in> carrier Q\<^sub>p \<and> val (b \<ominus>c) = m"
+    by (meson assms(3) dist_nonempty)
+  then have "b \<in> B\<^bsub>n\<^esub>[c]"
+    using assms c_ballI 
+    by auto
+   
+  then have "m \<ge> n"
+    using Q\<^sub>p_def Zp_def b_def c_ballE(2) padic_integers_axioms 
+    by force
+  then show ?thesis 
+    by (simp )
+qed
+
+lemma ball_rad:
+  assumes "is_ball B"
+  assumes "B = B\<^bsub>n\<^esub>[c]"
+  assumes "B = B\<^bsub>m\<^esub>[c]"
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "n = m"
+proof-
+  have 0: "n \<ge>m"
+    using assms ball_rad_0 
+    by (metis order_refl)
+  have 1: "m \<ge>n"
+    using assms ball_rad_0 
+    by (metis order_refl)
+  show ?thesis 
+    using 0 1 
+    by auto
+qed
+
+definition radius :: "padic_number set \<Rightarrow> int" ("rad") where
+"radius B = (SOME n. (\<exists>c \<in> carrier Q\<^sub>p . B = B\<^bsub>n\<^esub>[c]))"
+
+lemma radius_of_ball:
+  assumes "is_ball B"
+  assumes "c \<in> B"
+  shows "B = B\<^bsub>rad B\<^esub>[c]"
+proof-
+  obtain d m where d_m_def: "d \<in> carrier Q\<^sub>p \<and>  B = B\<^bsub>m\<^esub>[d]"
+    using assms(1) is_ball_def 
+    by blast
+  then have "B = B\<^bsub>m\<^esub>[c]"
+    using assms(1) assms(2) c_ball_centers by blast
+  then have "rad B = m" 
+  proof-
+    have "\<exists>n. (\<exists>c \<in> carrier Q\<^sub>p . B = B\<^bsub>n\<^esub>[c])"
+      using d_m_def by blast 
+    then have "(\<exists>c \<in> carrier Q\<^sub>p . B = B\<^bsub>rad B\<^esub>[c])"
+      using radius_def[of B] 
+      by (smt someI_ex)
+    then show ?thesis 
+      using radius_def ball_rad[of B m ]
+      by (metis (mono_tags, lifting) \<open>B = B\<^bsub>m\<^esub>[c]\<close> assms(1) assms(2) c_ballE(1) c_ball_centers)
+  qed
+  then show ?thesis 
+    using \<open>B = B\<^bsub>m\<^esub>[c]\<close> by blast
+qed
+
+lemma ball_rad':
+  assumes "is_ball B"
+  assumes "B = B\<^bsub>n\<^esub>[c]"
+  assumes "B = B\<^bsub>m\<^esub>[d]"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "d \<in> carrier Q\<^sub>p"
+  shows "n = m"
+  by (metis assms(1) assms(2) assms(3) assms(4) assms(5) ball_rad c_ball_center_in c_ball_centers)
+
+lemma nested_balls:
+  assumes "is_ball B"
+  assumes "B = B\<^bsub>n\<^esub>[c]"
+  assumes "B' = B\<^bsub>m\<^esub>[c]"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "d \<in> carrier Q\<^sub>p"
+  shows "n \<ge>m \<longleftrightarrow> B \<subseteq> B'"
+proof
+  show "m \<le> n \<Longrightarrow> B \<subseteq> B'" 
+  proof
+    assume A0: "m \<le>n" 
+    then have A0': "m \<le> n"
+      by (simp add: )
+    fix x
+    assume A1: "x \<in> B"
+    show "x \<in> B'"
+      using assms c_ballI[of x m c] A0' A1 c_ballE(2)[of x n c]  c_ball_in_Qp 
+      by (meson c_ballE(1) dual_order.trans eint_ord_simps(1))      
+  qed
+  show "B \<subseteq> B' \<Longrightarrow> m \<le> n"
+    using assms(1) assms(2) assms(3) assms(4) ball_rad_0 
+    by blast
+qed
+
+lemma nested_balls':
+  assumes "is_ball B"
+  assumes "is_ball B'"
+  assumes "B \<inter> B' \<noteq> {}"
+  shows "B \<subseteq> B' \<or> B' \<subseteq> B"
+proof-
+  obtain b where b_def: "b \<in> B \<inter> B'"
+    using assms(3) by blast
+  show "B \<subseteq> B' \<or> B' \<subseteq> B"
+  proof-
+    have "\<not> B \<subseteq> B' \<Longrightarrow> B' \<subseteq> B"
+    proof-
+      assume A: "\<not> B \<subseteq> B' "
+      have 0: "B = B\<^bsub>rad B\<^esub>[b]"
+        using assms(1) b_def radius_of_ball by auto
+      have 1: "B' = B\<^bsub>rad B'\<^esub>[b]"
+        using assms(2) b_def radius_of_ball by auto
+      show "B' \<subseteq> B" using 0 1 A nested_balls 
+        by (smt IntD2 Q\<^sub>p_def Zp_def assms(1) assms(2) b_def
+            c_ballE(1) padic_integers_axioms)
+    qed
+    then show ?thesis by blast 
+  qed
+qed
+
+definition is_bounded:: "padic_number set \<Rightarrow> bool" where
+"is_bounded S = (\<exists>n. \<exists>c \<in> carrier Q\<^sub>p. S \<subseteq> B\<^bsub>n\<^esub>[c] )"
+
+lemma empty_is_bounded:
+"is_bounded {}"
+  unfolding is_bounded_def 
+  by blast  
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>$p$-adic Open Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition is_open:: "padic_number set \<Rightarrow> bool" where
+"is_open U \<equiv> (U \<subseteq> carrier Q\<^sub>p) \<and> (\<forall>c \<in> U. \<exists>n. B\<^bsub>n\<^esub>[c]\<subseteq> U )"
+
+lemma is_openI:
+  assumes "U \<subseteq>carrier Q\<^sub>p"
+  assumes "\<And>c. c \<in> U \<Longrightarrow> \<exists>n. B\<^bsub>n\<^esub>[c]\<subseteq> U"
+  shows "is_open U"
+  by (simp add: assms(1) assms(2) is_open_def)
+
+lemma ball_is_open:
+  assumes "is_ball B"
+  shows "is_open B"
+  by (metis (mono_tags, lifting) assms is_ball_imp_in_Qp is_open_def radius_of_ball subset_iff)
+
+lemma is_open_imp_in_Qp:
+  assumes "is_open U"
+  shows "U \<subseteq> carrier Q\<^sub>p"
+  using assms unfolding is_open_def 
+  by linarith
+
+lemma is_open_imp_in_Qp':
+  assumes "is_open U"
+  assumes " x \<in> U"
+  shows "x \<in> carrier Q\<^sub>p"
+  using assms(1) assms(2) is_open_imp_in_Qp 
+  by blast
+
+text\<open>
+  Owing to the total disconnectedness of the $p$-adic field, every open set can be decomposed
+  into a disjoint union of balls which are maximal with respect to containment in that set.
+  This unique decomposition is occasionally useful.
+\<close>
+
+definition is_max_ball_of ::"padic_number set \<Rightarrow> padic_number set  \<Rightarrow> bool" where
+"is_max_ball_of U B \<equiv> (is_ball B) \<and> (B \<subseteq> U) \<and> (\<forall>B'. ((is_ball B') \<and> (B' \<subseteq> U) \<and> B \<subseteq> B') \<longrightarrow> B' \<subseteq> B)"
+
+lemma is_max_ball_ofI:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  assumes "(B\<^bsub>m\<^esub>[c]) \<subseteq> U"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "\<forall>m'. m' < m \<longrightarrow> \<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
+  shows "is_max_ball_of U (B\<^bsub>m\<^esub>[c])"
+proof(rule ccontr)
+  assume " \<not> is_max_ball_of U B\<^bsub>m\<^esub>[c]"
+  then have "\<not> (\<forall>B'. is_ball B' \<and> B' \<subseteq> U \<and> B\<^bsub>m\<^esub>[c] \<subseteq> B'\<longrightarrow> B' \<subseteq> B\<^bsub>m\<^esub>[c])"
+    using assms is_max_ball_of_def[of U "B\<^bsub>m\<^esub>[c]" ] 
+    unfolding is_ball_def
+    by blast
+  then obtain B' where B'_def: "is_ball B' \<and> B' \<subseteq> U \<and> B\<^bsub>m\<^esub>[c] \<subseteq> B' \<and> \<not> B' \<subseteq> B\<^bsub>m\<^esub>[c]"
+  by auto
+  obtain n where n_def: "B' = B\<^bsub>n\<^esub>[c]" 
+    by (meson B'_def assms(3) c_ball_center_in is_ball_def radius_of_ball subset_iff)
+  then show False 
+    using assms 
+    by (smt B'_def Q\<^sub>p_def Zp_def ball_rad_0 padic_integers_axioms)
+qed
+
+lemma int_prop:
+  fixes P:: "int \<Rightarrow> bool"
+  assumes "P n"
+  assumes "\<forall>m. m \<le>N \<longrightarrow> \<not> P m"
+  shows  "\<exists>n. P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge>n)"
+proof-
+  have "n > N"
+    by (meson assms(1) assms(2) not_less)
+  obtain k::nat  where k_def: "k = nat (n - N)"
+    by blast
+  obtain l::nat where l_def: "l = (LEAST M.  P (N + int M))"
+    by simp 
+  have 0: " P (N + int l)"
+    by (metis (full_types) LeastI \<open>N < n\<close> assms(1) l_def zless_iff_Suc_zadd)
+  have 1: "l > 0"
+    using "0" assms(2) of_nat_0_less_iff by fastforce
+  have 2: "\<And>M. M < l \<longrightarrow> \<not> P (N + M)"
+    by (metis Least_le l_def less_le_trans nat_less_le)
+  obtain n where n_def: "n = (N + int l)"
+    by simp 
+  have "P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge> n)"
+  proof-
+    have "P n"
+      by (simp add: "0" n_def)
+    have "(\<forall>n'. P n'\<longrightarrow> n' \<ge> n)"
+    proof
+      fix n'
+      show "P n' \<longrightarrow> n \<le> n'"
+      proof
+        assume "P n'"
+        show  "n \<le>n'"
+        proof(rule ccontr)
+          assume " \<not> n \<le> n'"
+          then have C: "n' < n"
+            by auto
+          show "False"
+          proof(cases "n' \<ge> N")
+            case True
+            obtain M where M_def: "nat (n' - N) = M"
+              by simp 
+            then have M0: "n' = N + int M "
+              using True by linarith
+            have M1: "M < l"
+              using n_def C M0 
+              by linarith
+            then show ?thesis using 2 M_def M0 M1 
+              using \<open>P n'\<close> by auto
+          next
+            case False
+            then show ?thesis using assms  
+              using \<open>P n'\<close> by auto
+          qed
+        qed
+      qed
+    qed
+    then show ?thesis 
+      using \<open>P n\<close> by blast
+  qed
+  then show ?thesis by blast 
+qed
+
+lemma open_max_ball:
+  assumes  "is_open U"
+  assumes  "U \<noteq> carrier Q\<^sub>p"
+  assumes "c \<in> U"
+  shows "\<exists>B. is_max_ball_of U B \<and> c \<in> B"
+proof-
+  obtain B where B_def: "is_ball B \<and> B \<subseteq> U \<and> c \<in> B"
+    by (meson assms(1) assms(3) c_ball_center_in is_ball_def is_open_imp_in_Qp' is_open_def padic_integers_axioms)
+  show P: "\<exists>B. is_max_ball_of U B \<and> c \<in> B"
+  proof(rule ccontr)
+    assume C: "\<nexists>B. is_max_ball_of U B \<and> c \<in> B"
+    show False
+    proof-
+      have C': "\<forall>B. c \<in> B \<longrightarrow> \<not>  is_max_ball_of U B "
+        using C 
+        by auto
+      have C'': "\<forall>N. \<exists>m <N. B\<^bsub>m\<^esub>[c] \<subseteq> U "
+      proof
+        fix N
+        show "\<exists>m<N. B\<^bsub>m\<^esub>[c] \<subseteq> U"
+        proof(rule  ccontr)
+          assume A: "\<not> (\<exists>m<N. B\<^bsub>m\<^esub>[c] \<subseteq> U)"
+          obtain P where P_def: "P = (\<lambda> n. \<exists>m<n. B\<^bsub>m\<^esub>[c] \<subseteq> U)"
+            by simp
+          have A0: "\<exists>n. P n"
+            by (metis B_def P_def gt_ex radius_of_ball)
+          have A1: "\<forall>m. m \<le>N \<longrightarrow> \<not> P m"
+            using A P_def by auto 
+          have A2: "\<exists>n. P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge>n)"
+            using A0 A1 int_prop 
+            by auto
+          obtain n where n_def: " P n \<and> (\<forall>n'. P n'\<longrightarrow> n' \<ge>n)"
+            using A2 by blast 
+          have " B\<^bsub>n\<^esub>[c] \<subseteq> U"
+            by (smt B_def P_def c_ball_def is_ball_def mem_Collect_eq n_def nested_balls order_trans)
+          obtain m where m_def: "m < n \<and>B\<^bsub>m\<^esub>[c] \<subseteq> U"
+            using P_def n_def by blast
+          have "m = n-1"
+          proof-
+            have "P (m +1)"
+              using P_def m_def  
+              by auto
+            then have "m + 1 \<ge> n"
+              using n_def by blast  
+            then show ?thesis using m_def by auto  
+          qed
+          have "\<forall>m'. m' < m \<longrightarrow> \<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
+          proof
+            fix m'
+            show " m' < m \<longrightarrow> \<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
+            proof
+              assume "m' < m"
+              show "\<not> B\<^bsub>m'\<^esub>[c] \<subseteq> U"
+              proof
+                assume "B\<^bsub>m'\<^esub>[c] \<subseteq> U"
+                then have "P (m' + 1)"
+                  using P_def by auto
+                have "m'+ 1 < n"
+                  using \<open>m = n - 1\<close> \<open>m' < m\<close> by linarith
+                then show False 
+                  using n_def \<open>P (m' + 1)\<close> by auto
+              qed
+            qed
+          qed
+          then have "is_max_ball_of U B\<^bsub>m\<^esub>[c]"
+            using is_max_ball_ofI  assms(1) assms(3) is_open_imp_in_Qp is_open_imp_in_Qp' m_def 
+            by presburger
+          then show False 
+            using C assms(1) assms(3) c_ball_center_in is_open_imp_in_Qp'
+              is_max_ball_of_def padic_integers_axioms 
+            by blast
+        qed
+      qed
+      have "U = carrier Q\<^sub>p"
+      proof
+        show "carrier Q\<^sub>p \<subseteq> U"
+        proof
+          fix x
+          assume "x \<in> carrier Q\<^sub>p"
+          show "x \<in> U"
+          proof(cases "x = c")
+            case True
+            then show ?thesis using assms by auto 
+          next
+            case False
+            obtain m where m_def: "eint m = val(x \<ominus> c)"
+              using False 
+              by (metis (no_types, opaque_lifting) Qp_diff_diff Qp.domain_axioms \<open>x \<in> carrier Q\<^sub>p\<close> a_minus_def
+                  assms(1) assms(3) cring.cring_simprules(16) cring.cring_simprules(17)
+                  cring.cring_simprules(4) domain.axioms(1) is_open_imp_in_Qp' val_def val_minus)
+            obtain m' where m'_def: "m' < m \<and>  B\<^bsub>m'\<^esub>[c] \<subseteq> U "
+              using C'' 
+              by blast
+            have "val (x \<ominus> c) \<ge> m'"
+              by (metis eint_ord_simps(1) less_imp_le m'_def m_def)              
+            then have "x \<in> B\<^bsub>m'\<^esub>[c]"
+              using \<open>x \<in> carrier Q\<^sub>p\<close> c_ballI by blast
+            then show "x \<in> U"
+              using m'_def by blast
+          qed
+        qed
+        show "U \<subseteq> carrier Q\<^sub>p " 
+          using assms 
+          by (simp add: is_open_imp_in_Qp)          
+      qed
+      then show False using assms by auto 
+    qed
+  qed
+qed
+
+definition interior where
+  "interior U = {a. \<exists>B. is_open B \<and> B \<subseteq> U \<and> a \<in> B}"
+
+lemma interior_subset:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  shows "interior U \<subseteq> U"
+proof
+  fix x
+  assume "x \<in> interior U"
+  show "x \<in> U"
+  proof-
+    obtain B where B_def: "is_open B \<and> B \<subseteq> U \<and> x \<in> B"
+      using \<open>x \<in> interior U\<close> interior_def 
+      by auto
+    then show "x \<in> U"
+      by blast
+  qed
+qed
+
+lemma interior_open:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  shows "is_open (interior U)"
+proof(rule is_openI)
+  show "interior U \<subseteq> carrier Q\<^sub>p"
+    using assms interior_subset by blast
+  show "\<And>c. c \<in> interior U \<Longrightarrow> \<exists>n. B\<^bsub>n\<^esub>[c] \<subseteq> interior U"
+  proof-
+    fix c
+    assume "c \<in> interior U"
+    show "\<exists>n. B\<^bsub>n\<^esub>[c] \<subseteq> interior U"
+    proof-
+    obtain B where B_def: "is_open B \<and> B \<subseteq> U \<and> c \<in> B"
+      using \<open>c \<in> interior U\<close> interior_def padic_integers_axioms
+      by auto
+    then show ?thesis 
+    proof -
+      obtain ii :: "((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set \<Rightarrow> ((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set set \<Rightarrow> int" 
+        where
+        "B\<^bsub>ii c B\<^esub>[c] \<subseteq> B"
+        by (meson B_def is_open_def)
+      then show ?thesis
+        using B_def interior_def padic_integers_axioms by auto
+qed
+  qed
+  qed
+qed
+
+lemma interiorI:
+  assumes "W \<subseteq> U"
+  assumes "is_open W"
+  shows "W \<subseteq> interior U"
+  using assms(1) assms(2) interior_def by blast
+
+lemma max_ball_interior:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  assumes "is_max_ball_of (interior U) B"
+  shows "is_max_ball_of U B"
+proof(rule ccontr)
+  assume C: " \<not> is_max_ball_of U B"
+  then obtain B' where B'_def: "is_ball B' \<and> B' \<subseteq> U \<and> B \<subseteq> B' \<and> B \<noteq> B'"
+    by (metis (no_types, lifting) assms(1) assms(2) dual_order.trans 
+        interior_subset is_max_ball_of_def )
+  then have "B' \<subseteq> interior U"
+    using interior_def padic_integers_axioms ball_is_open 
+    by auto   
+  then show False using assms B'_def is_max_ball_of_def[of "interior U" "B"]  
+    by blast
+qed
+
+lemma ball_in_max_ball:
+  assumes  "U \<subseteq> carrier Q\<^sub>p"
+  assumes  "U \<noteq> carrier Q\<^sub>p"
+  assumes "c \<in> U"
+  assumes "\<exists>B. B \<subseteq> U \<and> is_ball B \<and> c \<in> B"
+  shows "\<exists>B'. is_max_ball_of U B' \<and> c \<in> B'"
+proof-
+  obtain B where " B \<subseteq> U \<and> is_ball B \<and> c \<in> B"
+    using assms(4)
+    by blast
+  then have 0: "B \<subseteq> interior U"
+    using ball_is_open interior_def by blast
+  have 1: "c \<in> interior U"
+    using "0" \<open>B \<subseteq> U \<and> is_ball B \<and> c \<in> B\<close> by blast
+  then have "\<exists>B'. is_max_ball_of (interior U) B' \<and> c \<in> B'"
+    using open_max_ball[of "interior U" c] assms(1) assms(2) interior_open interior_subset
+    by blast
+  then show ?thesis 
+    using assms(1) max_ball_interior 
+    by blast
+qed
+
+lemma ball_in_max_ball':
+  assumes  "U \<subseteq> carrier Q\<^sub>p"
+  assumes  "U \<noteq> carrier Q\<^sub>p"
+  assumes "B \<subseteq> U \<and> is_ball B"
+  shows "\<exists>B'. is_max_ball_of U B' \<and> B \<subseteq> B'"
+proof-
+  obtain c where c_def: "c \<in> B"
+    by (metis assms(3) c_ball_center_in is_ball_def)
+  obtain B' where B'_def: " is_max_ball_of U B' \<and> c \<in> B'"
+    using assms ball_in_max_ball[of U c] c_def 
+    by blast
+  then show ?thesis 
+    by (meson assms(3) c_def disjoint_iff_not_equal nested_balls' 
+        is_max_ball_of_def padic_integers_axioms)
+qed
+
+lemma max_balls_disjoint:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  assumes "is_max_ball_of U B"
+  assumes "is_max_ball_of U B'"
+  assumes "B \<noteq>B'"
+  shows "B \<inter> B' = {}"
+  by (meson assms(2) assms(3) assms(4) nested_balls' is_max_ball_of_def 
+      padic_integers_axioms subset_antisym)
+
+definition max_balls :: "padic_number set \<Rightarrow> padic_number set set" where
+"max_balls U = {B. is_max_ball_of U B }"
+
+lemma max_balls_interior:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  assumes "U \<noteq> carrier Q\<^sub>p"
+  shows "interior U = {x \<in> carrier Q\<^sub>p. (\<exists>B \<in> (max_balls U). x \<in> B)}"
+proof
+  show "interior U \<subseteq> {x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B}"
+  proof
+    fix x
+    assume A: " x \<in> interior U"
+    show "x \<in> {x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B}"
+      by (metis (mono_tags, lifting) A assms(1) assms(2) interior_open 
+          interior_subset is_open_imp_in_Qp' max_ball_interior max_balls_def
+          mem_Collect_eq open_max_ball subset_antisym)
+  qed
+  show "{x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B} \<subseteq> interior U"
+  proof
+    fix x
+    assume A: " x \<in> {x \<in> carrier Q\<^sub>p. \<exists>B\<in>max_balls U. x \<in> B} "
+    show "x \<in> interior U"
+    proof-
+      obtain B where B_def: "B\<in>max_balls U \<and> x \<in> B"
+        using A by blast
+      then have "B \<subseteq> interior U"
+        by (metis (no_types, lifting) interior_def is_max_ball_of_def mem_Collect_eq
+            ball_is_open max_balls_def subsetI)
+      then show ?thesis 
+        using B_def by blast
+    qed
+  qed
+qed
+
+lemma max_balls_interior':
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  assumes "U \<noteq> carrier Q\<^sub>p"
+  assumes "B \<in> max_balls U"
+  shows "B \<subseteq> interior U"
+  using assms(1) assms(2) assms(3) is_max_ball_of_def max_balls_interior
+        max_balls_def padic_integers_axioms 
+  by auto
+
+lemma max_balls_interior'':
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  assumes "U \<noteq> carrier Q\<^sub>p"
+  assumes "a \<in> interior U"
+  shows "\<exists>B \<in> max_balls U. a \<in> B"
+  using assms(1) assms(2) assms(3) max_balls_interior
+  by blast
+
+lemma open_interior:
+  assumes "is_open U"
+  shows "interior U = U"
+  unfolding interior_def using assms  
+  by blast
+
+lemma interior_idempotent:
+  assumes "U \<subseteq> carrier Q\<^sub>p"
+  shows "interior (interior U) = interior U"
+  using assms interior_open[of U] open_interior[of "interior U"]
+  by auto 
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Convex Subsets of the Value Group\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  The content of this section will be useful for defining and reasoning about $p$-adic cells in the
+  proof of Macintyre's theorem. It is proved that every convex set in the extended integers is 
+  either an open ray, a closed ray, a closed interval, or a left-closed interval.\<close>
+
+definition is_convex :: "eint set \<Rightarrow> bool" where
+"is_convex A = (\<forall> x \<in> A. \<forall>y \<in> A. \<forall>c. x \<le> c \<and> c \<le> y \<longrightarrow> c \<in> A)"
+
+lemma is_convexI: 
+  assumes "\<And>x y c. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x \<le> c \<and> c \<le>y \<Longrightarrow> c \<in> A"
+  shows "is_convex  A"
+  unfolding is_convex_def 
+  using assms 
+  by blast
+
+lemma is_convexE: 
+  assumes "is_convex A"
+  assumes "x \<in> A" 
+  assumes "y \<in> A"
+  assumes "x \<le> a"
+  assumes "a \<le> y"
+  shows "a \<in> A"
+  using assms is_convex_def 
+  by blast
+
+lemma empty_convex:
+"is_convex {}"
+  apply(rule is_convexI)
+  by blast
+
+lemma UNIV_convex:
+"is_convex UNIV"
+  apply(rule is_convexI)
+  by blast
+
+definition closed_interval ("I[_ _]") where
+  "closed_interval \<alpha> \<beta> = {a . \<alpha> \<le> a \<and>  a \<le> \<beta>}"
+
+lemma closed_interval_is_convex:
+  assumes "A = closed_interval \<alpha> \<beta>"
+  shows "is_convex A"
+  apply(rule is_convexI)
+  using assms unfolding closed_interval_def 
+  by auto  
+
+lemma empty_closed_interval:
+"{} = closed_interval \<infinity> (eint 1)"
+  unfolding closed_interval_def 
+  by auto
+
+definition left_closed_interval  where
+"left_closed_interval \<alpha> \<beta> = {a . \<alpha> \<le>  a \<and>  a < \<beta>}"
+
+lemma left_closed_interval_is_convex:
+  assumes "A = left_closed_interval \<alpha> \<beta>"
+  shows "is_convex A"
+  apply(rule is_convexI)
+  using assms unfolding left_closed_interval_def 
+  using leD order.trans by auto
+  
+definition closed_ray where
+"closed_ray \<alpha> \<beta>  = {a .   a \<le> \<beta> }"
+
+lemma closed_ray_is_convex:
+  assumes "A = closed_ray \<alpha> \<beta>"
+  shows "is_convex A"
+  apply(rule is_convexI)
+  using assms unfolding closed_ray_def 
+  by auto  
+
+lemma UNIV_closed_ray:
+"(UNIV::eint set)= closed_ray \<alpha> \<infinity>"
+  unfolding closed_ray_def 
+  by simp
+
+definition open_ray :: "eint \<Rightarrow> eint \<Rightarrow> eint set" where
+"open_ray \<alpha> \<beta>  = {a .   a < \<beta> }"
+
+lemma open_ray_is_convex:
+  assumes "A = open_ray \<alpha> \<beta>"
+  shows "is_convex A"
+  apply(rule is_convexI)
+  using assms unfolding open_ray_def 
+  using leD by auto
+ 
+lemma open_rayE:
+  assumes "a < \<beta>"
+  shows "a \<in> open_ray \<alpha> \<beta>"
+  unfolding open_ray_def using assms 
+  by blast
+  
+lemma value_group_is_open_ray:
+"UNIV - {\<infinity>} = open_ray \<alpha> \<infinity>"
+proof
+  show "UNIV - {\<infinity>} \<subseteq> open_ray \<alpha> \<infinity>"  
+    using open_rayE[of _ \<alpha> "\<infinity>"]
+    by (simp add: open_rayE subset_eq)
+  show "open_ray \<alpha> \<infinity> \<subseteq> UNIV - {\<infinity>}"
+    unfolding open_ray_def 
+    by blast
+qed
+
+text\<open>
+  This is a predicate which identifies a certain kind of set-valued function on the extended
+  integers. Convex conditions will be important in the definition of $p$-adic cells later, and 
+  it will be proved that every convex set is induced by a convex condition.\<close>
+definition is_convex_condition :: "(eint \<Rightarrow> eint \<Rightarrow> eint set) \<Rightarrow> bool"
+  where "is_convex_condition I \<equiv> 
+              I = closed_interval \<or> I = left_closed_interval \<or> I = closed_ray \<or> I = open_ray"
+
+lemma convex_condition_imp_convex: 
+  assumes "is_convex_condition I"
+  shows "is_convex (I \<alpha> \<beta>)"
+  using assms 
+  unfolding is_convex_condition_def 
+  by (meson closed_interval_is_convex closed_ray_is_convex left_closed_interval_is_convex open_ray_is_convex)
+
+lemma bounded_order:
+  assumes "(a::eint) < \<infinity>"
+  assumes  "b \<le>  a"
+  obtains k::nat where  "a = b + k"
+proof-
+  obtain m::int where m_def: "a = m"
+    using assms(1) less_infinityE by blast
+  obtain n::int where n_def: "b = n"
+    using assms(2) eint_ile m_def by blast
+  have 0: "a - b =  eint (m - n)"
+    by (simp add: m_def n_def)
+  then have "a = b + nat (m - n)"
+    using assms m_def n_def 
+    by simp
+  thus ?thesis 
+    using that by blast
+qed
+  
+text\<open>Every convex set is given by a convex condition\<close>
+lemma convex_imp_convex_condition:
+  assumes "is_convex A"
+  shows "\<exists> I \<alpha> \<beta>. is_convex_condition I \<and> A = (I \<alpha> \<beta>)"
+proof(cases "\<exists> a \<in> A. \<forall> b \<in> A. a \<le> b")
+  case True
+  then obtain \<alpha> where alpha_def: "\<alpha> \<in> A \<and> (\<forall> b \<in> A. \<alpha> \<le> b)"
+    by blast 
+  then show ?thesis
+  proof(cases "\<exists> a \<in> A. \<forall> b \<in> A. b \<le> a")
+    case True
+    then obtain \<beta> where beta_def: "\<beta> \<in> A \<and> (\<forall> b \<in> A. b \<le> \<beta>)"
+      by blast 
+    have "A = closed_interval \<alpha> \<beta>"
+      unfolding closed_interval_def 
+      using alpha_def beta_def assms is_convexE[of A \<alpha> \<beta>]
+      by blast
+    then show ?thesis 
+      using is_convex_condition_def 
+      by blast
+  next
+    case False
+    have F0: "\<forall>a. \<alpha> \<le> a \<and> a < \<infinity> \<longrightarrow> a \<in> A"
+    proof(rule ccontr)
+      assume A: "\<not> (\<forall>a. a \<ge> \<alpha> \<and> a < \<infinity> \<longrightarrow> a \<in> A)"
+      then obtain a where a_def: " \<alpha> \<le> a \<and> a < \<infinity> \<and> a \<notin> A"
+        by blast 
+      obtain n where n_def: "\<alpha> = eint n"
+        using False alpha_def by force        
+      obtain m where m_def: "a = eint m"
+        using a_def less_infinityE by blast        
+      have "\<forall>k::nat. \<exists>c. (\<alpha> + eint (int k)) < c \<and> c \<in> A"
+      proof fix k
+        show "\<exists>c>\<alpha> + eint (int k). c \<in> A"
+          apply(induction k)
+           using False alpha_def le_less_linear zero_eint_def apply fastforce           
+        proof- fix k
+          assume IH: "\<exists>c>\<alpha> + eint (int k). c \<in> A"
+          then obtain c where c_def: "c>\<alpha> + eint (int k) \<and> c \<in> A"
+            by blast 
+          then obtain c' where c'_def: "c' \<in> A \<and> c < c'" 
+            using False 
+            by (meson le_less_linear)            
+          then have "(\<alpha> + eint (int (Suc k))) \<le> c'"
+          proof-
+            have 0: "eint (int (Suc k)) = eint (int k) + eint 1"
+              by simp
+            have "\<alpha> + eint (int k) \<le>c'"
+              by (meson c'_def c_def le_less le_less_trans)              
+            then have 1: "(\<alpha> + eint (int k)) < c'"
+              using c'_def c_def le_less_trans 
+              by auto                      
+            have 2: "\<alpha> + eint (int k) + eint 1 = \<alpha> + eint (int (Suc k))"
+              using 0 
+              by (simp add: n_def)
+            then show "(\<alpha> + eint (int (Suc k))) \<le> c'"
+              by (metis "1" ileI1 one_eint_def)              
+          qed
+          then show "\<exists>c>\<alpha> + eint (int (Suc k)). c \<in> A"
+            using False c'_def not_less by fastforce            
+        qed
+      qed
+      obtain k where k_def: "k = a - \<alpha>"
+        using a_def n_def 
+        by blast 
+      hence "k \<ge> 0"
+        using a_def n_def 
+        by (metis alpha_def eint_minus_le le_less)        
+      hence 0: "\<exists>n::nat. k = n"
+        using a_def n_def  k_def   
+        by (metis eint.distinct(2) eint_0_iff(2) eint_add_cancel_fact eint_ord_simps(1) fromeint.cases m_def nonneg_int_cases plus_eint_simps(3))        
+      have 1: "a = \<alpha> + k"
+        using k_def a_def n_def 
+        by simp
+      then obtain c where "c \<in> A \<and> a < c"
+        by (metis "0" \<open>\<forall>k. \<exists>c>\<alpha> + eint (int k). c \<in> A\<close> the_eint.simps)        
+      then have "a \<in> A"
+        using is_convexE[of A \<alpha> a c] a_def alpha_def assms is_convexE 
+        by (meson linear not_less)        
+      then show False 
+        using a_def by blast
+    qed
+    have "A = closed_interval \<alpha>  \<infinity> \<or> A = left_closed_interval \<alpha> \<infinity>"
+      apply(cases "\<infinity> \<in> A")
+      using False eint_ord_code(3) apply blast      
+    proof-
+      assume A0: "\<infinity> \<notin> A "
+      have "A = left_closed_interval \<alpha> \<infinity>"
+      proof
+        show "A \<subseteq> left_closed_interval \<alpha> \<infinity>"
+          unfolding left_closed_interval_def 
+          using alpha_def A0 
+          by (metis (mono_tags, lifting) False eint_ord_code(3) le_less_linear less_le_trans mem_Collect_eq subsetI)
+        show "left_closed_interval \<alpha> \<infinity> \<subseteq> A"
+          unfolding left_closed_interval_def 
+          using alpha_def A0 F0 
+          by blast
+      qed
+      then show ?thesis 
+        by blast 
+    qed
+    then show ?thesis 
+      unfolding is_convex_condition_def  
+      by blast
+  qed
+next
+  case False
+  show ?thesis apply(cases "A = {}")
+    using empty_closed_interval is_convex_condition_def apply blast
+  proof-
+    assume A0: "A \<noteq> {}"
+    have "A \<noteq> {\<infinity>}"
+      using False  
+      by blast
+    then obtain \<alpha> where alpha_def: "\<alpha> \<in> A \<and> \<alpha> \<noteq>\<infinity>"
+      using A0 
+      by fastforce
+    have A1: "\<And>k::nat. \<exists> b \<in> A. b + eint (int k) \<le> \<alpha>"
+    proof- fix k
+      show " \<exists> b \<in> A. b + eint (int k) \<le> \<alpha>"
+      proof(induction k)
+        case 0
+        then have "\<alpha> + eint (int 0) = \<alpha>"
+          by (simp add: zero_eint_def)          
+        then show ?case 
+          using alpha_def by auto                      
+      next
+        case (Suc k) fix k
+        assume IH: "\<exists>b\<in>A. \<alpha> \<ge> b + eint (int k)"
+        show "\<exists>b\<in>A. \<alpha> \<ge> b + eint (int (Suc k))"
+        proof-
+          obtain b where b_def: "b \<in> A \<and> \<alpha> \<ge> b + eint (int k)"
+            using IH by blast 
+          then obtain c where c_def: "c \<in> A \<and> c < b"
+            using False le_less_linear by blast           
+          have 0: "(c + eint (int (Suc k))) < (b + eint (int (Suc k)))"
+            using c_def 
+            by simp            
+          have 1: "b + eint (int (Suc k)) =  (b + eint (int k)) + eint 1"
+            by simp            
+          then show ?thesis 
+            by (metis "0" b_def c_def eSuc_ile_mono ileI1 le_less one_eint_def)            
+        qed
+      qed
+    qed
+    show ?thesis 
+    proof(cases "\<exists> a \<in> A. \<forall> b \<in> A. b \<le> a")
+      case True
+      then obtain \<beta> where beta_def: "\<beta> \<in> A \<and> (\<forall> b \<in> A. b \<le> \<beta>)"
+        by blast 
+      have "A = closed_ray \<alpha> \<beta>"
+        unfolding closed_ray_def 
+      proof
+        show "A \<subseteq> {a. \<beta> \<ge> a}"
+          using assms beta_def 
+          by blast
+        show "{a. \<beta> \<ge> a} \<subseteq> A"
+        proof fix x assume "x \<in> {a. \<beta> \<ge> a}"
+          then have 0: "\<beta> \<ge> x" by blast 
+          show "x \<in> A"
+          proof(cases "x \<le> \<alpha>")
+            case True
+            obtain n where n_def: "\<alpha>= eint n"
+              using alpha_def 
+              by blast              
+            obtain m where m_def: "x = eint m"
+              using True eint_ile n_def by blast             
+            have 1: "m \<le> n"
+              using  True m_def n_def 
+              by simp             
+            have 2: "eint (int (nat (n - m))) = eint (n - m)"
+              by (simp add: "1")
+            then obtain b where b_def: "b \<in> A \<and> b + eint (n - m) \<le> \<alpha>"
+              using  A1[of "nat (n - m)"] 
+              by (metis)
+            then have "b + eint (n - m) \<le> x + eint (n - m)"
+              using b_def  
+              by (simp add: m_def n_def)              
+            then have "b \<le> x"
+              by auto              
+            then show ?thesis 
+              using "0" assms b_def beta_def is_convex_def 
+              by blast           
+          next
+            case False
+            then show ?thesis 
+              using "0" alpha_def assms beta_def is_convexE 
+              by (meson linear)              
+          qed
+        qed
+      qed
+      then show ?thesis 
+        using is_convex_condition_def 
+        by blast
+    next
+      case f: False
+      have F0: "\<forall>a. \<alpha> \<le> a \<and> a < \<infinity> \<longrightarrow> a \<in> A"
+      proof(rule ccontr)
+      assume A: "\<not> (\<forall>a. a \<ge> \<alpha> \<and> a < \<infinity> \<longrightarrow> a \<in> A)"
+      then obtain a where a_def: " \<alpha> \<le> a \<and> a < \<infinity> \<and> a \<notin> A"
+        by blast 
+      obtain n where n_def: "\<alpha> = eint n"
+        using alpha_def by blast        
+      obtain m where m_def: "a = eint m"
+        using a_def less_infinityE by blast       
+      have 0: "\<forall>k::nat. \<exists>c. (\<alpha> + eint (int k)) < c \<and> c \<in> A"
+      proof fix k
+        show "\<exists>c>\<alpha> + eint (int k). c \<in> A"
+          apply(induction k)
+           using alpha_def f le_less_linear apply fastforce                               
+        proof- fix k
+          assume IH: "\<exists>c>\<alpha> + eint (int k). c \<in> A"
+          then obtain c where c_def: "c>\<alpha> + eint (int k) \<and> c \<in> A"
+            by blast 
+          then obtain c' where c'_def: "c' \<in> A \<and> c < c'" 
+            using False f le_less_linear by blast                        
+          then have "(\<alpha> + eint (int (Suc k))) \<le> c'"
+          proof-
+            have 0: "eint (int (Suc k)) = eint (int k) + eint 1"
+              by simp
+            have "\<alpha> + eint (int k) \<le>c'"
+              using c_def c'_def dual_order.strict_trans le_less by blast                 
+            then have 1: "(\<alpha> + eint (int k)) < c'"
+              using c'_def c_def le_less_trans by auto                          
+            have 2: "\<alpha> + eint (int k) + eint 1 = \<alpha> + eint (int (Suc k))"
+              using 0 by (simp add: n_def)
+            then show "(\<alpha> + eint (int (Suc k))) \<le> c'"
+              by (metis "1" ileI1 one_eint_def)              
+          qed
+          then show "\<exists>c>\<alpha> + eint (int (Suc k)). c \<in> A"
+            using False c'_def 
+            by (smt c_def eSuc_eint iadd_Suc_right ileI1 le_less of_nat_Suc)            
+        qed
+      qed
+      obtain k::nat where "a = \<alpha> + eint (int k)"
+        using bounded_order a_def
+        by blast
+      then obtain c where "c \<in> A \<and> a <c"
+        using 0 by blast        
+      then have "a \<in> A"
+        using is_convexE[of A \<alpha> a c] a_def alpha_def assms is_convexE 
+        by (meson linear not_less)       
+      then show False 
+        using a_def by blast
+      qed
+      have "A = UNIV - {\<infinity>}"
+      proof
+        show "A \<subseteq> UNIV - {\<infinity>}"
+          using f by auto        
+        show "UNIV - {\<infinity>} \<subseteq> A"       
+        proof fix x ::eint 
+          assume A: "x \<in> UNIV - {\<infinity>}"
+          show "x \<in> A"
+          proof(cases "x \<le> \<alpha>")
+            case True
+            obtain k::nat where k_def: "x + k = \<alpha>"
+              by (metis True alpha_def bounded_order eint_ord_simps(4))
+            obtain c where c_def: "c \<in> A \<and> c + k = \<alpha>"
+              by (metis A1 True add.commute alpha_def assms eint_add_left_cancel_le is_convexE k_def not_eint_eq)
+            have "x = c"
+              using k_def c_def 
+              by auto
+            thus ?thesis 
+              by (simp add: c_def)
+          next
+            case False
+            thus ?thesis 
+              using A F0 by auto            
+          qed
+        qed
+      qed
+    then show ?thesis 
+      by (meson is_convex_condition_def value_group_is_open_ray)
+   qed
+ qed
+qed
+
+lemma ex_val_less:
+  shows "\<exists> (\<alpha>::eint). \<alpha> < \<beta>"
+  apply(induction \<beta>)
+  using eint_ord_simps(2) lt_ex apply blast
+  using eint_ord_simps(4) by blast
+
+lemma ex_dist_less:
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "\<exists> a \<in> carrier Q\<^sub>p. val (a \<ominus> c) < \<beta>"
+  using ex_val_less[of \<beta>] assms 
+  by (metis dist_nonempty' ex_val_less)
+end
+end
\ No newline at end of file
diff --git a/thys/Padic_Field/Padic_Fields.thy b/thys/Padic_Field/Padic_Fields.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Padic_Fields.thy
@@ -0,0 +1,3063 @@
+theory Padic_Fields
+  imports Fraction_Field Padic_Ints.Hensels_Lemma
+
+begin
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Constructing the $p$-adic Valued Field\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  As a field, we can define the field $\mathbb{Q}_p$ immediately as the fraction field of 
+  $\mathbb{Z}_p$. The valuation can then be extended from to $\mathbb{Z}_p$ to $\mathbb{Q}_p$ by 
+  defining $\text{val}(a/b) = \text{val}\ a - \text{val}\ b$ where $a, b \in \mathbb{Z}_p$. \<close>
+
+(**********************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>A Locale for $p$-adic Fields\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  This section builds a locale for reasoning about general $p$-adic fields for a fixed $p$. 
+  The locale fixes constants for the ring of $p$-adic integers ($\mathbb{Z}_p$) and the inclusion
+   map $\iota: \mathbb{Z}_p \to \mathbb{Q}_p$. \<close>
+type_synonym padic_number = "((nat \<Rightarrow> int) \<times> (nat \<Rightarrow> int)) set"
+locale padic_fields= 
+fixes Q\<^sub>p:: "_ ring" (structure)
+fixes Z\<^sub>p:: "_ ring" (structure)
+fixes p
+fixes \<iota>
+defines "Z\<^sub>p \<equiv> padic_int p"
+defines "Q\<^sub>p \<equiv> Frac Z\<^sub>p"
+defines "\<iota> \<equiv> domain_frac.inc Z\<^sub>p"
+assumes prime: "prime p"
+
+sublocale padic_fields < Zp?: domain_frac Z\<^sub>p
+  by (simp add: Z\<^sub>p_def domain_frac.intro padic_int_is_domain prime)
+
+sublocale padic_fields < Qp?: ring Q\<^sub>p
+  unfolding Q\<^sub>p_def 
+  by (simp add: Fraction_Field.domain_frac_def domain_axioms domain_frac.fraction_field_is_field field.is_ring)
+ 
+sublocale padic_fields < Qp?: cring Q\<^sub>p
+  unfolding Q\<^sub>p_def 
+  by (simp add: Fraction_Field.domain_frac_def domain.axioms(1) domain_axioms domain_frac.fraction_field_is_domain)
+ 
+sublocale padic_fields < Qp?: field Q\<^sub>p
+  unfolding Q\<^sub>p_def 
+  by (simp add: Fraction_Field.domain_frac_def domain_axioms domain_frac.fraction_field_is_field)
+
+sublocale padic_fields < Qp?: domain Q\<^sub>p
+  by (simp add: Qp.domain_axioms)
+
+sublocale padic_fields <  padic_integers Z\<^sub>p  
+apply (simp add: padic_integers_def prime) 
+using Z\<^sub>p_def by auto
+
+sublocale padic_fields < UPQ?: UP_cring Q\<^sub>p "UP Q\<^sub>p"
+  using Qp.is_cring UP_cring_def apply blast
+  by auto 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>The Valuation Ring in $\mathbb{Q}_p$\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  The valuation ring $\mathcal{O}_p$ is the subring of elements in $\mathbb{Q}_p$ with positive 
+  valuation. It is an isomorphic copy of $\mathbb{Z}_p$.\<close>
+context padic_fields
+begin
+
+abbreviation \<O>\<^sub>p where
+"\<O>\<^sub>p \<equiv> \<iota> ` carrier Z\<^sub>p"
+
+lemma inc_closed: 
+  assumes "a \<in> carrier Z\<^sub>p"
+  shows "\<iota> a \<in> carrier Q\<^sub>p"
+  using Q\<^sub>p_def \<iota>_def assms Zp.inc_is_hom ring_hom_closed
+  by fastforce
+
+lemma inc_is_hom:
+"\<iota> \<in> ring_hom Z\<^sub>p Q\<^sub>p"
+  unfolding Q\<^sub>p_def \<iota>_def  
+by(rule Zp.inc_is_hom)
+
+text\<open>An alternate formula of the map $\iota$\<close>
+
+lemma inc_def: 
+  assumes "a \<in> carrier Z\<^sub>p"
+  shows "\<iota> a = frac a \<one>\<^bsub>Z\<^sub>p\<^esub>" 
+  using assms inc_equation[of a] \<iota>_def by auto
+
+lemma inc_of_nonzero:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  shows "\<iota> a \<in> nonzero Q\<^sub>p"
+  using  \<iota>_def assms Q\<^sub>p_def Qp.nonzero_memI 
+    Zp.nonzero_closed Zp.nonzero_one_closed frac_closed local.inc_def nonzero_fraction 
+  by (metis Zp.nonzero_memE(2) inc_closed inc_inj1)
+ 
+lemma inc_of_one:
+"\<iota> \<one>\<^bsub>Z\<^sub>p\<^esub> = \<one>"
+  by (simp add: inc_is_hom ring_hom_one)
+
+lemma inc_of_zero:
+"\<iota> \<zero>\<^bsub>Z\<^sub>p\<^esub> = \<zero>"
+  apply(rule ring_hom_zero[of \<iota>], rule inc_is_hom)
+  apply (simp add: Zp.ring_axioms)
+  by (simp add: Qp.ring_axioms)
+
+lemma inc_of_sum:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> carrier Z\<^sub>p"
+  shows "\<iota> (a \<oplus>\<^bsub>Z\<^sub>p\<^esub> b) = (\<iota> a) \<oplus> (\<iota> b)"
+by(rule ring_hom_add[of _ Z\<^sub>p], rule inc_is_hom, rule assms, rule assms)
+
+lemma inc_of_prod:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> carrier Z\<^sub>p"
+  shows "\<iota> (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> b) = (\<iota> a) \<otimes> (\<iota> b)"
+  by (simp add: assms(1) assms(2) inc_is_hom ring_hom_mult)
+
+lemma inc_pow:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  shows "\<iota> (a[^]\<^bsub>Z\<^sub>p\<^esub>(n::nat)) = (\<iota> a)[^] n"
+  apply(induction n)
+  apply (simp add: inc_of_one)
+  by (simp add: assms inc_of_prod Zp.nonzero_closed)
+
+lemma inc_of_diff:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> carrier Z\<^sub>p"
+  shows "\<iota> (a \<ominus>\<^bsub>Z\<^sub>p\<^esub>  b) = (\<iota> a) \<ominus> (\<iota> b)"
+  using assms unfolding a_minus_def 
+  using inc_is_hom Qp.ring_axioms Q\<^sub>p_def Zp.ring_hom_a_inv inc_of_sum by fastforce  
+
+lemma Units_nonzero_Qp:
+assumes "u \<in> Units Q\<^sub>p"
+shows "u \<in> nonzero Q\<^sub>p"
+  by (simp add: Qp.Units_nonzero assms) 
+
+lemma Units_eq_nonzero:
+ "Units Q\<^sub>p = nonzero Q\<^sub>p"
+  using frac_nonzero_Units unfolding Q\<^sub>p_def Z\<^sub>p_def 
+by blast 
+
+lemma Units_inverse_Qp:
+  assumes "u \<in> Units Q\<^sub>p"
+  shows "inv\<^bsub>Q\<^sub>p\<^esub> u \<in> Units Q\<^sub>p"
+  using Q\<^sub>p_def Units_eq_nonzero assms frac_nonzero_inv_Unit by auto
+  
+lemma nonzero_inverse_Qp:
+  assumes "u \<in> nonzero Q\<^sub>p"
+  shows "inv\<^bsub>Q\<^sub>p\<^esub> u \<in> nonzero Q\<^sub>p"
+  using Units_eq_nonzero Units_inverse_Qp assms by auto  
+
+lemma frac_add:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  assumes "c \<in> carrier Z\<^sub>p"
+  assumes "d \<in> nonzero Z\<^sub>p"
+  shows "(frac a b) \<oplus> (frac c d) = (frac ((a \<otimes>\<^bsub>Z\<^sub>p\<^esub> d) \<oplus>\<^bsub>Z\<^sub>p\<^esub> (b \<otimes>\<^bsub>Z\<^sub>p\<^esub> c)) (b \<otimes>\<^bsub>Z\<^sub>p\<^esub> d))"
+  by (simp add: Q\<^sub>p_def assms(1) assms(2) assms(3) assms(4) local.frac_add)
+
+lemma frac_add_common_denom:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> carrier Z\<^sub>p"
+  assumes "c \<in> nonzero Z\<^sub>p"
+  shows "(frac a c) \<oplus> (frac b c) = frac (a \<oplus>\<^bsub>Z\<^sub>p\<^esub> b) c"
+  by (simp add: Q\<^sub>p_def assms(1) assms(2) assms(3) frac_add_common_denom)
+
+lemma frac_mult:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  assumes "c \<in> carrier Z\<^sub>p"
+  assumes "d \<in> nonzero Z\<^sub>p"
+  shows "(frac a b) \<otimes> (frac c d) = (frac (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> c) (b \<otimes>\<^bsub>Z\<^sub>p\<^esub> d))"
+  by (simp add: Q\<^sub>p_def assms(1) assms(2) assms(3) assms(4) frac_mult)
+
+lemma frac_one:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  shows "frac a a = \<one>"
+  by (simp add: Q\<^sub>p_def assms frac_one)
+
+lemma frac_closed:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  shows "frac a b \<in> carrier Q\<^sub>p"
+  by (simp add: Q\<^sub>p_def assms(1) assms(2) frac_closed)  
+
+lemma inv_in_frac:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "a \<noteq>\<zero>"
+  shows "inv\<^bsub>Q\<^sub>p\<^esub> a \<in> carrier Q\<^sub>p"
+        "inv\<^bsub>Q\<^sub>p\<^esub> a \<noteq>\<zero>"
+        "inv\<^bsub>Q\<^sub>p\<^esub> a \<in> nonzero Q\<^sub>p"
+  apply (simp add: assms(1) assms(2) field_inv(3))
+    using assms(1) assms(2) field_inv(1) apply fastforce
+      using Qp.not_nonzero_memE assms(1) assms(2) nonzero_inverse_Qp by blast
+
+lemma nonzero_numer_imp_nonzero_fraction:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  shows "frac a b \<noteq> \<zero>"
+  by (simp add: Q\<^sub>p_def assms(1) assms(2) nonzero_fraction)
+
+lemma nonzero_fraction_imp_numer_not_zero:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  assumes "frac a b \<noteq> \<zero>"
+  shows "a \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+  using assms fraction_zero Q\<^sub>p_def by blast
+
+lemma nonzero_fraction_imp_nonzero_numer:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  assumes "frac a b \<noteq> \<zero>"
+  shows "a \<in> nonzero Z\<^sub>p"
+  using assms(1) assms(2) assms(3) nonzero_fraction_imp_numer_not_zero not_nonzero_Zp by blast
+
+lemma(in padic_fields) frac_inv_id:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p" 
+  assumes "c \<in> nonzero Z\<^sub>p"
+  assumes "d \<in> nonzero Z\<^sub>p" 
+  assumes "frac a b = frac c d"
+  shows "frac b a = frac d c"
+  using frac_inv assms  
+  by metis  
+
+lemma(in padic_fields) frac_uminus:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  shows "\<ominus> (frac a b) = frac (\<ominus>\<^bsub>Z\<^sub>p\<^esub> a) b" 
+  by (simp add: Q\<^sub>p_def assms(1) assms(2) frac_uminus)
+
+lemma(in padic_fields) i_mult:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "c \<in> carrier Z\<^sub>p"
+  assumes "d \<in> nonzero Z\<^sub>p"
+  shows "(\<iota> a) \<otimes> (frac c d) = frac (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> c) d"
+  by (simp add: Q\<^sub>p_def \<iota>_def assms(1) assms(2) assms(3) i_mult)
+
+lemma numer_denom_facts:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "(numer a) \<in> carrier Z\<^sub>p"
+        "(denom a) \<in> nonzero Z\<^sub>p"
+        "a \<noteq> \<zero> \<Longrightarrow> numer a \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+        "a \<otimes> (\<iota> (denom a)) = \<iota> (numer a)"
+        "a = frac (numer a) (denom a)" 
+  unfolding Q\<^sub>p_def
+  using Q\<^sub>p_def assms numer_denom_facts(2) apply auto[1]
+    using Q\<^sub>p_def assms numer_denom_facts(3) apply blast
+      using Q\<^sub>p_def assms numer_denom_facts(4) apply blast
+        using Q\<^sub>p_def \<iota>_def assms numer_denom_facts(5) apply auto[1]
+          using Q\<^sub>p_def assms numer_denom_facts(1) by auto
+
+lemma get_common_denominator:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  obtains a b c where
+    "a \<in> carrier Z\<^sub>p"
+    "b \<in> carrier Z\<^sub>p" 
+    "c \<in> nonzero Z\<^sub>p"
+    "x = frac a c"
+    "y = frac b c"
+  using Q\<^sub>p_def assms(1) assms(2) common_denominator[of x y]
+  by blast  
+
+abbreviation fract :: "_ \<Rightarrow> _ \<Rightarrow> _" (infixl "\<div>" 50) where
+"(fract a b) \<equiv> (a \<otimes> (inv\<^bsub>Q\<^sub>p\<^esub> b))"
+
+text\<open>fract generalizes frac\<close>
+
+lemma fract_frac:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  shows "(frac a b) = (\<iota> a \<div> \<iota> b)" 
+proof-
+  have B: "b \<in> carrier Z\<^sub>p" 
+    using Zp.nonzero_closed assms(2) by auto    
+  have P0:"(inv\<^bsub>Q\<^sub>p\<^esub> (\<iota> b)) = frac \<one>\<^bsub>Z\<^sub>p\<^esub> b" 
+    by (simp add: B Q\<^sub>p_def Zp.nonzero_one_closed assms(2) frac_inv local.inc_def)
+  have P1: "(frac a b) = (\<iota> a) \<otimes> (frac \<one>\<^bsub>Z\<^sub>p\<^esub> b)"
+    by (simp add: assms(1) assms(2) i_mult)    
+  show ?thesis 
+    by (simp add: P0 P1)
+qed
+
+lemma frac_eq:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  assumes "frac a b = \<one>"
+  shows "a = b"
+proof-
+  have "frac a b = frac b b"
+    by (simp add: assms(2) assms(3) frac_one)
+  then have "frac a \<one>\<^bsub>Z\<^sub>p\<^esub> = frac b \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using assms 
+    by (metis (no_types, lifting) Zp.nonzero_closed 
+        Zp.nonzero_one_closed frac_eqE frac_eqI')
+  then show ?thesis
+    using \<iota>_def assms(1) assms(2) inc_inj2 local.inc_def 
+    by (simp add: Zp.nonzero_closed)
+qed
+
+lemma fract_cancel_right:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "b \<otimes> (a \<div> b) = a"
+  by (simp add: Qp.Units_closed Qp.m_lcomm Units_eq_nonzero assms(1)
+      assms(2))
+  
+lemma fract_cancel_left:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "(a \<div> b) \<otimes> b = a"
+  by (simp add: Qp.m_comm Qp.nonzero_closed assms(1) assms(2) 
+      local.fract_cancel_right nonzero_inverse_Qp)
+  
+lemma fract_mult:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "d \<in> nonzero Q\<^sub>p"
+  shows  "(a \<div> b) \<otimes> (c \<div> d) = ((a \<otimes> c)\<div> (b \<otimes> d))"
+  using Q\<^sub>p_def assms(1) assms(2) assms(3) assms(4) 
+  by (simp add: fract_mult)
+  
+lemma Qp_nat_pow_nonzero:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  shows "x[^](n::nat) \<in> nonzero Q\<^sub>p"
+  using Qp.Units_pow_closed Units_eq_nonzero assms by auto
+
+lemma Qp_nonzero_nat_pow:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "n > 0"
+  assumes "x[^](n::nat) \<in> nonzero Q\<^sub>p"
+  shows "x \<in> nonzero Q\<^sub>p"
+  using Frac_nonzero_nat_pow Q\<^sub>p_def assms(1) assms(2) assms(3) by blast
+  
+lemma Qp_int_pow_nonzero:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  shows "x[^](n::int) \<in> nonzero Q\<^sub>p"
+  using Frac_int_pow_nonzero Q\<^sub>p_def assms by blast
+
+lemma Qp_nonzero_int_pow:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "n > 0"
+  assumes "x[^](n::int) \<in> nonzero Q\<^sub>p"
+  shows "x \<in> nonzero Q\<^sub>p"
+  using Frac_nonzero_int_pow Q\<^sub>p_def assms 
+  by auto 
+
+lemma pow_p_frac_0:
+  assumes "(m::int) \<ge> n"
+  assumes "n \<ge>0"
+  shows "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) = \<iota> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n))"
+proof-
+  have 0: "\<p>\<in>carrier Z\<^sub>p" 
+    by (simp add: Zp.nat_inc_closed) 
+  have 1: "m - n \<ge>0" 
+    using assms(1) by auto 
+  have 2: "nat (m - n) + (nat n) = nat m" 
+    using "1" assms(2) by linarith 
+  have 3: "m \<ge>0" 
+    using assms by auto
+  then have "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(nat (m-n))) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(nat n)) = (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(nat m))" 
+    by (simp add: "2" p_natpow_prod)
+  then have "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) = (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m)" 
+    using int_pow_int 1 3 assms(2) int_nat_eq by metis  
+  then have P0: "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) = frac ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n))\<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)"
+    by simp 
+  have "\<p> \<in>carrier Z\<^sub>p" 
+    by (simp add: "0") 
+  have "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(nat n)) = [(p^(nat n))] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by (simp add: p_pow_rep0) 
+  then have "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(nat n)) \<in> carrier Z\<^sub>p" 
+    by (simp add: Zp_nat_inc_closed) 
+  then have "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) \<in> carrier Z\<^sub>p" 
+    using assms(2) by (metis int_nat_eq int_pow_int) 
+  then have P1: "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) = frac ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n))\<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) ((\<one>\<^bsub>Z\<^sub>p\<^esub> \<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)))"
+    by (simp add: \<open>[p] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> [^]\<^bsub>Z\<^sub>p\<^esub> (m - n) \<otimes>\<^bsub>Z\<^sub>p\<^esub> [p] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> [^]\<^bsub>Z\<^sub>p\<^esub> n = [p] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> [^]\<^bsub>Z\<^sub>p\<^esub> m\<close>)  
+  have P2: "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<in> carrier Z\<^sub>p" 
+    using "1" p_pow_car by blast 
+  have P3: "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) \<in> carrier Z\<^sub>p" 
+    using \<open>\<p> [^]\<^bsub>Z\<^sub>p\<^esub> n \<in> carrier Z\<^sub>p\<close>
+    by blast 
+  have P4: "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) \<in> nonzero Z\<^sub>p" 
+    using assms(2) p_int_pow_nonzero 
+    by blast 
+  have P5: "\<one>\<^bsub>Z\<^sub>p\<^esub> \<in> nonzero Z\<^sub>p" 
+    using nonzero_def 
+    by (simp add: Zp.nonzero_one_closed)   
+  have "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>) \<otimes> (frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) 
+        = frac ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n))\<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) ((\<one>\<^bsub>Z\<^sub>p\<^esub> \<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)))"
+    by (simp add: P2 P3 P4 Zp.nonzero_one_closed local.frac_mult)    
+  then have "frac ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n))\<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) ((\<one>\<^bsub>Z\<^sub>p\<^esub> \<otimes>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n))) = (frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>) "
+    by (simp add: P2 P4 Zp.nonzero_one_closed frac_cancel_lr mult_comm)  
+  then have P6: "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) = (frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>) " 
+    using P1 by blast 
+  have "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>) = \<iota> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n))" 
+    using inc_def  by (simp add: P2) 
+  then show ?thesis 
+    using P6 by blast
+qed
+
+lemma pow_p_frac:
+  assumes "(m::int) \<le> n"
+  assumes "m \<ge>0"
+  shows "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) = frac \<one>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(n-m))"
+proof-
+  have "(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m)) = \<iota> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(n-m))" 
+    by (simp add: assms(1) assms(2) pow_p_frac_0) 
+  then have P0:"(frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m)) = frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(n-m)) \<one>\<^bsub>Z\<^sub>p\<^esub>"
+   by (simp add: assms(1) local.inc_def p_pow_car)   
+  have P1: "\<one>\<^bsub>Z\<^sub>p\<^esub> \<in>nonzero Z\<^sub>p" 
+    by (simp add: Zp.nonzero_one_closed)
+  have P2: "\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n \<in> nonzero Z\<^sub>p"
+    using assms(1) assms(2) p_int_pow_nonzero by auto
+  have P3: "\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m \<in> nonzero Z\<^sub>p" 
+    by (simp add: assms(2) p_int_pow_nonzero)    
+  have P4: "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(n-m)) \<in> nonzero Z\<^sub>p" 
+    by (simp add: assms(1) p_int_pow_nonzero)
+  show " frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) = frac \<one>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(n-m))"
+    using P0 P1 P2 P3 P4 p_pow_nonzero 
+    by (meson local.frac_inv_id)   
+qed
+
+text\<open>The copy of the prime \<open>p\<close> living in $\mathbb{Q}_p$:\<close>
+
+abbreviation \<pp> where
+"\<pp> \<equiv> [p] \<cdot>\<^bsub>Q\<^sub>p\<^esub> \<one>"
+
+lemma(in domain_frac) frac_inc_of_nat:
+"Frac_inc R ([(n::nat)]\<cdot> \<one>) = [n]\<cdot>\<^bsub>Frac R\<^esub>\<one>\<^bsub>Frac R\<^esub>"
+  by (simp add: inc_equation nat_inc_rep)
+
+lemma inc_of_nat:
+"(\<iota> ([(n::nat)]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>)) = [n]\<cdot>\<^bsub>Q\<^sub>p\<^esub>\<one>"
+  unfolding Q\<^sub>p_def \<iota>_def
+  using  frac_inc_of_nat[of n]
+  by auto 
+  
+lemma(in domain_frac) frac_inc_of_int:
+"Frac_inc R ([(n::int)]\<cdot> \<one>) = [n]\<cdot>\<^bsub>Frac R\<^esub>\<one>\<^bsub>Frac R\<^esub>"
+  apply(induction n)
+  apply (simp add: add_pow_int_ge inc_equation nat_inc_rep)
+    by (simp add: add_pow_int_lt frac_uminus inc_equation nat_inc_rep nonzero_one_closed)
+
+lemma inc_of_int:
+"(\<iota> ([(n::int)]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>)) = [n]\<cdot>\<^bsub>Q\<^sub>p\<^esub>\<one>"
+  unfolding Q\<^sub>p_def \<iota>_def
+  using  frac_inc_of_int[of n]
+  by auto 
+  
+lemma p_inc:
+"\<pp> = \<iota> \<p>"
+  by (simp add: inc_of_int)
+
+lemma p_nonzero:
+"\<pp> \<in> nonzero Q\<^sub>p"
+  using Z\<^sub>p_def Zp_nat_inc_closed inc_of_nonzero ord_Zp_p p_inc 
+    p_nonzero by auto
+ 
+lemma p_natpow_inc:
+  fixes n::nat
+  shows "\<pp>[^]n = \<iota> (\<p> [^]\<^bsub>Z\<^sub>p\<^esub> n)"
+  by (simp add: Qp.int_nat_pow_rep inc_of_int p_pow_rep0)
+
+lemma p_intpow_inc:
+  fixes n::int
+  assumes "n \<ge>0"
+  shows "\<pp>[^]n = \<iota> (\<p> [^]\<^bsub>Z\<^sub>p\<^esub> n)"
+  using p_natpow_inc  
+  by (metis assms int_nat_eq int_pow_int)
+
+lemma p_intpow:
+  fixes n::int
+  assumes "n < 0"
+  shows "\<pp>[^]n = (frac \<one>\<^bsub>Z\<^sub>p\<^esub> (\<p> [^]\<^bsub>Z\<^sub>p\<^esub> (-n)))"
+proof-
+  have U0: "(\<pp> [^] (nat (-n))) \<in> Units Q\<^sub>p" 
+    using Qp.Units_pow_closed Units_eq_nonzero p_nonzero by blast   
+  have E0: "(\<pp> [^] (nat (-n))) = (\<pp> [^] (-n))" 
+    using assms  by (simp add: int_pow_def nat_pow_def)
+  then have U1: "(\<pp> [^]  (-n)) \<in> Units Q\<^sub>p" using U0 
+    by simp
+  have "(\<pp>[^]n) = inv \<^bsub>Q\<^sub>p\<^esub> (\<pp> [^] (nat (-n)))"
+    using assms by (simp add: int_pow_def nat_pow_def)
+  then have "(\<pp>[^]n) = inv \<^bsub>Q\<^sub>p\<^esub> (\<pp> [^] (-n))" 
+    using E0 by simp
+  then have "(\<pp>[^]n) = inv \<^bsub>Q\<^sub>p\<^esub> \<iota> (\<p> [^]\<^bsub>Z\<^sub>p\<^esub>(-n))" 
+    using assms p_intpow_inc by auto
+  then have E1: "(\<pp>[^]n) = inv \<^bsub>Q\<^sub>p\<^esub>  frac (\<p> [^]\<^bsub>Z\<^sub>p\<^esub>(-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using assms local.inc_def p_pow_car by auto
+  have A: "(\<p> [^]\<^bsub>Z\<^sub>p\<^esub>(-n)) \<in> nonzero Z\<^sub>p"
+    using assms p_pow_nonzero  p_int_pow_nonzero 
+    by auto 
+  then show ?thesis 
+    using A frac_inv inc_def E1 
+    by (simp add: Q\<^sub>p_def Zp.nonzero_one_closed)
+qed
+
+lemma p_natpow_closed[simp]:
+  fixes n::nat
+  shows "(\<pp>[^]n) \<in> (carrier Q\<^sub>p)"
+        "(\<pp>[^]n) \<in> (nonzero Q\<^sub>p)"
+  apply blast 
+    using Qp_nat_pow_nonzero p_nonzero by blast
+  
+lemma nonzero_int_pow_distrib:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "(a \<otimes> b) [^](k::int) = a[^]k \<otimes> b[^]k"
+proof(induction k)
+  case (nonneg n)
+  then show ?case using pow_nat[of n _ Q\<^sub>p] 
+    by (smt Qp.nat_pow_distrib Qp.nonzero_closed assms(1) assms(2) int_pow_int)
+next
+  case N: (neg n)
+  have "a \<otimes> b \<in> Units Q\<^sub>p"
+    using assms Units_eq_nonzero by blast  
+  hence "(a \<otimes> b) [^] - int (Suc n) = inv ((a \<otimes> b) [^] (Suc n))"
+     by (metis Qp.int_pow_inv' int_pow_int)
+   then show ?case using 
+       Qp.int_pow_inv' Qp.int_pow_unit_closed Qp.inv_of_prod[of "a[^]Suc n" "b[^]Suc n"] 
+       Qp.nat_pow_distrib Qp.nonzero_closed Units_eq_nonzero assms(1) assms(2) int_pow_int  by metis
+qed
+
+lemma val_ring_subring:
+"subring \<O>\<^sub>p Q\<^sub>p"
+  using Q\<^sub>p_def \<iota>_def inc_im_is_subring by blast
+
+lemma val_ring_closed: 
+"\<O>\<^sub>p \<subseteq> carrier Q\<^sub>p"      
+  by (simp add: subringE(1) val_ring_subring)
+
+lemma p_pow_diff: 
+  fixes n::int 
+  fixes m::int 
+  assumes "n \<ge>0"
+  assumes "m \<ge>0"
+  shows "\<pp> [^] (n - m) = frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m)"
+proof-
+  have 0: "comm_monoid Q\<^sub>p"
+    by (simp add: Qp.comm_monoid_axioms)
+  have 1: "\<pp> \<in> Units Q\<^sub>p"
+    using Units_eq_nonzero p_nonzero 
+    by blast
+  have 2: "\<pp> [^] (n - m) = (\<pp>[^]n) \<otimes> (\<pp> [^] -m)"
+    by (metis "1" Qp.int_pow_add diff_conv_add_uminus)    
+  have 3: "\<pp> [^] (n - m) = (\<pp>[^]n) \<otimes> inv\<^bsub>Q\<^sub>p\<^esub>(\<pp> [^] m)"
+    by (simp add: "1" "2" Qp.int_pow_inv')  
+  then show ?thesis using assms 
+    using fract_frac p_int_pow_nonzero p_intpow_inc p_pow_car by presburger
+qed
+
+lemma Qp_int_pow_add: 
+  fixes n::int 
+  fixes m::int
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "a [^] (n + m) = (a [^] n) \<otimes> (a [^] m)"
+  using monoid.int_pow_add[of Q\<^sub>p a n m] Units_eq_nonzero assms 
+  by (simp add: Qp.monoid_axioms)
+  
+lemma Qp_nat_pow_pow: 
+  fixes n::nat 
+  fixes m::nat
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "(a[^](n*m)) = ((a[^]n)[^]m)"
+  by (simp add: Qp.nat_pow_pow assms)
+  
+lemma Qp_p_nat_pow_pow: 
+  fixes n::nat 
+  fixes m::nat
+  shows "(\<pp> [^] (n*m)) = ((\<pp>[^]n)[^]m)"
+  using Qp_nat_pow_pow 
+  by simp
+  
+lemma Qp_units_int_pow:
+  fixes n::int
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "a[^]n = a[^]\<^bsub>units_of Q\<^sub>p\<^esub>n"
+  apply(cases "n \<ge> 0")
+  using monoid.units_of_pow[of Q\<^sub>p]
+   apply (metis int_pow_def2 mult_of_is_Units nat_pow_mult_of not_le)
+    by (metis Qp.Units_pow_closed Qp.units_of_inv Units_eq_nonzero assms int_pow_def2 mult_of_is_Units nat_pow_mult_of)
+ 
+lemma Qp_int_pow_pow: 
+  fixes n::int
+  fixes m::int
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "(a[^](n*m)) = ((a[^]n)[^]m)"
+proof-
+  have 0: "a \<in> carrier (units_of Q\<^sub>p)"
+    by (simp add: Units_eq_nonzero assms units_of_carrier)
+  have "group (units_of Q\<^sub>p)"
+    using  monoid.units_group Qp.units_group 
+    by blast 
+  then show ?thesis 
+    using 0 group.int_pow_pow[of "units_of Q\<^sub>p"] Qp_int_pow_nonzero Qp_units_int_pow assms 
+    by auto
+qed
+
+lemma Qp_p_int_pow_pow: 
+  fixes n::int
+  fixes m::int
+  shows "(\<pp> [^] (n*m)) = ((\<pp>[^]n)[^]m)"
+  using Qp_int_pow_pow p_nonzero by blast
+  
+lemma Qp_int_nat_pow_pow: 
+  fixes n::int
+  fixes m::nat
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "(a[^](n*m)) = ((a[^]n)[^]m)"
+  by (simp add: Qp_int_pow_pow assms int_pow_int)
+
+lemma Qp_p_int_nat_pow_pow: 
+  fixes n::int
+  fixes m::nat
+  shows "(\<pp> [^] (n*m)) = ((\<pp>[^]n)[^]m)"
+  by (simp add: Qp_int_nat_pow_pow p_nonzero)
+
+lemma Qp_nat_int_pow_pow: 
+  fixes n::nat
+  fixes m::int
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "(a[^](n*m)) = ((a[^]n)[^]m)"
+  by (simp add: Qp_int_pow_pow assms int_pow_int)
+
+lemma Qp_p_nat_int_pow_pow: 
+  fixes n::nat
+  fixes m::int
+  shows "(\<pp> [^] (n*m)) = ((\<pp>[^]n)[^]m)"
+  by (simp add: Qp_nat_int_pow_pow p_nonzero)
+
+lemma p_intpow_closed:
+  fixes n::int
+  shows "(\<pp>[^]n) \<in> (carrier Q\<^sub>p)"
+        "(\<pp>[^]n) \<in> (nonzero Q\<^sub>p)"
+  apply (simp add: Qp.nonzero_closed Qp_int_pow_nonzero p_nonzero)
+    by (simp add: Qp_int_pow_nonzero p_nonzero)
+  
+lemma p_intpow_add:
+  fixes n::int 
+  fixes m::int
+  shows "\<pp> [^] (n + m) = (\<pp> [^] n) \<otimes> (\<pp> [^] m)"
+  using Qp_int_pow_add p_nonzero by blast
+
+lemma p_intpow_inv:
+  fixes n::int
+  shows  "(\<pp> [^] n) \<otimes> (\<pp> [^] -n) = \<one>"
+  using Units_eq_nonzero monoid.int_pow_inv'[of Q\<^sub>p \<pp> n] 
+  by (metis add.right_inverse int_pow_0 p_intpow_add)
+    
+lemma p_intpow_inv':
+  fixes n::int
+  shows  "(\<pp> [^] -n) \<otimes> (\<pp> [^] n) = \<one>"
+  using p_intpow_inv 
+  by (metis add.commute p_intpow_add)
+
+lemma p_intpow_inv'':
+  fixes n::int
+  shows "(\<pp> [^] -n) = inv\<^bsub>Q\<^sub>p\<^esub> (\<pp> [^] n)"
+  by (simp add: Qp.int_pow_inv' Units_eq_nonzero p_nonzero)
+
+lemma p_int_pow_factor_int_pow:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "(\<pp>[^](n::int) \<otimes> a)[^](k::int) = \<pp>[^](n*k) \<otimes> a[^]k"
+  using assms nonzero_int_pow_distrib p_intpow_closed(2) Qp_p_int_pow_pow by presburger
+
+lemma p_nat_pow_factor_int_pow:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "(\<pp>[^](n::nat) \<otimes> a)[^](k::int) = \<pp>[^](n*k) \<otimes> a[^]k"
+  using assms  Qp_p_int_nat_pow_pow p_natpow_closed(1) 
+  by (metis int_pow_int p_int_pow_factor_int_pow)
+
+lemma p_pow_factor:
+"\<pp>[^]((int N)*l  + k) = (\<pp>[^]l)[^](N::nat) \<otimes> \<pp>[^] k"
+  by (metis Qp_p_int_nat_pow_pow mult_of_nat_commute p_intpow_add)
+
+lemma p_nat_pow_factor_nat_pow:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "(\<pp>[^](n::nat) \<otimes> a)[^](k::nat) = \<pp>[^](n*k) \<otimes> a[^]k"
+  using Qp.nat_pow_distrib Qp_p_nat_pow_pow assms p_natpow_closed(1) by presburger
+
+lemma p_int_pow_factor_nat_pow:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "(\<pp>[^](n::int) \<otimes> a)[^](k::nat) = \<pp>[^](n*k) \<otimes> a[^]k"
+  using assms Qp.nat_pow_distrib Qp_p_int_nat_pow_pow p_intpow_closed(1) by presburger
+
+lemma(in ring) r_minus_distr:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier R"
+  assumes "c \<in> carrier R"
+  shows "a \<otimes> b \<ominus> a \<otimes> c = a \<otimes> (b \<ominus> c)"
+  using assms 
+  unfolding a_minus_def  
+  by (simp add: r_distr r_minus)
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>The Valuation on $\mathbb{Q}_p$\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+      (********************************************************************************************)
+      (********************************************************************************************)
+      subsubsection\<open>Extending the Valuation from $\mathbb{Z}_p$ to $\mathbb{Q}_p$\<close>
+      (********************************************************************************************)
+      (********************************************************************************************)
+
+text\<open>
+  The valuation of a $p$-adic number can be defined as the difference of the valuations of an
+  arbitrary choice of numerator and denominator.\<close>
+definition ord where
+"ord x = (ord_Zp (numer x)) - (ord_Zp (denom x))"
+
+definition val where
+"val x = (if x = \<zero> then (\<infinity>::eint) else eint (ord x))"
+
+lemma val_ord[simp]:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "val a = ord a"
+  using assms nonzero_def val_def by force
+
+      (********************************************************************************************)
+      (********************************************************************************************)
+      subsubsection\<open>Properties of the Valuation\<close>
+      (********************************************************************************************)
+      (********************************************************************************************)
+
+lemma ord_of_frac:
+  assumes "a \<in> nonzero Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  shows "ord (frac a b) = (ord_Zp a) - (ord_Zp b)"
+proof-
+  have "frac a b = frac (numer (frac a b)) (denom (frac a b))"
+    by (simp add: assms(1) assms(2))
+  then have "a \<otimes>\<^bsub>Z\<^sub>p\<^esub> (denom (frac a b)) = b \<otimes>\<^bsub>Z\<^sub>p\<^esub> (numer (frac a b))"
+    by (simp add: assms(1) assms(2) numer_denom_swap)   
+  then have "(ord_Zp a) - (ord_Zp b) =  (ord_Zp (numer (frac a b))) - (ord_Zp (denom (frac a b)))"
+    using ord_Zp_eq_frac Q\<^sub>p_def Z\<^sub>p_def 
+    by (metis Zp.frac_closed Zp.nonzero_closed Zp.numer_denom_facts(4) assms(1) assms(2) local.numer_denom_facts(1) local.numer_denom_facts(2) nonzero_fraction ord_of_nonzero(2) ord_pos) 
+  then show ?thesis 
+    using ord_def 
+    by presburger
+qed
+
+lemma val_zero:
+"val \<zero> = \<infinity>" by (simp add: val_def)
+
+lemma ord_one[simp]:
+"ord \<one> = 0"
+  using Zp.nonzero_one_closed local.frac_one ord_of_frac by fastforce
+  
+lemma val_one[simp]:
+"val (\<one>) = 0"
+  using ord_one 
+  by (simp add: Qp.one_nonzero zero_eint_def)      
+  
+lemma val_of_frac:
+  assumes "a \<in> carrier Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  shows "val (frac a b) = (val_Zp a) - (val_Zp b)"
+proof(cases "a = \<zero>\<^bsub>Z\<^sub>p\<^esub>")
+  case True
+  then show ?thesis 
+    using assms(1) assms(2)  local.val_zero
+    by (simp add: Q\<^sub>p_def val_Zp_def)
+next
+  case False
+  then have "a \<in> nonzero Z\<^sub>p" 
+    by (simp add: assms(1) nonzero_def)
+  then show ?thesis
+    using ord_of_frac[of a b] assms(2)  val_def val_ord_Zp 
+          nonzero_numer_imp_nonzero_fraction
+  by (simp add: Zp.nonzero_memE(2))
+qed
+
+lemma Z\<^sub>p_division_Qp_0[simp]:
+  assumes "u \<in> Units Z\<^sub>p"
+  assumes "v \<in> Units Z\<^sub>p"
+  shows "frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<one>\<^bsub>Z\<^sub>p\<^esub>= frac u v"
+proof-  
+  have 0: "frac v v = \<one>" 
+    using frac_one
+    by (simp add: Q\<^sub>p_def Zp.Units_nonzero assms(2))
+  have 1:"(inv\<^bsub>Z\<^sub>p\<^esub> v) \<in> carrier Z\<^sub>p"
+    using assms  by blast
+  have 2:"frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v))  \<one>\<^bsub>Z\<^sub>p\<^esub>  \<in> carrier Q\<^sub>p"
+    by (simp add: "1" Zp.Units_closed Zp.nonzero_one_closed assms(1) local.frac_closed)
+  have 3: "frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<one>\<^bsub>Z\<^sub>p\<^esub> =  (frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<one>\<^bsub>Z\<^sub>p\<^esub>) \<otimes> frac v v"
+    by (simp add: "0" "2")
+  then have 4:  "frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<one>\<^bsub>Z\<^sub>p\<^esub> =  (frac ((u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> v)  v)"
+    by (simp add: Zp.Units_nonzero Zp.nonzero_closed assms(1) assms(2) frac_eqI') 
+  then have 4:  "frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<one>\<^bsub>Z\<^sub>p\<^esub> =  (frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> ((inv\<^bsub>Z\<^sub>p\<^esub> v) \<otimes>\<^bsub>Z\<^sub>p\<^esub> v))  v)"
+    by (simp add: mult_assoc) 
+  have 5:"(inv\<^bsub>Z\<^sub>p\<^esub> v) \<otimes>\<^bsub>Z\<^sub>p\<^esub> v = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by (simp add: assms(2))
+  then show  "frac (u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<one>\<^bsub>Z\<^sub>p\<^esub> =  (frac u  v)"
+    by (simp add: "4" Zp.Units_closed assms(1))
+qed
+
+lemma Z\<^sub>p_division_Qp_1:
+  assumes "u \<in> Units Z\<^sub>p"
+  assumes "v \<in> Units Z\<^sub>p"
+  obtains w where "w \<in> Units Z\<^sub>p"
+                  "\<iota> w = frac u v"
+proof-
+  have " (inv\<^bsub>Z\<^sub>p\<^esub> v) \<in> Units Z\<^sub>p" 
+    by (simp add: assms(2))
+  then have "(u \<otimes>\<^bsub>Z\<^sub>p\<^esub> (inv\<^bsub>Z\<^sub>p\<^esub> v)) \<in> Units Z\<^sub>p" 
+    using assms 
+    by blast     
+  then show ?thesis 
+    using  Z\<^sub>p_division_Qp_0  Zp.Units_closed assms(1) assms(2) 
+      local.inc_def that by presburger
+qed
+
+lemma val_ring_ord_criterion:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "a \<noteq> \<zero>"
+  assumes "ord a \<ge> 0"
+  shows "a \<in> \<O>\<^sub>p"
+proof-
+  obtain c d where P0: "a = frac c d" and P1: "c \<in> nonzero Z\<^sub>p" and P2: "d \<in> nonzero Z\<^sub>p"
+   by (metis assms(1) assms(2) get_common_denominator nonzero_fraction_imp_nonzero_numer)  
+  obtain m n where P3: "m = ord_Zp c" and P4:"n = ord_Zp d"
+    by metis 
+  obtain u where "u = ac_Zp c" 
+    by simp
+  then have P5:"c = (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) \<otimes>\<^bsub>Z\<^sub>p\<^esub> u" and P6:"u \<in> Units Z\<^sub>p"
+     apply (simp add: P1 P3 \<open>u = ac_Zp c\<close> ac_Zp_factors')
+     using P1 Zp.nonzero_memE 
+     by (simp add: \<open>u = ac_Zp c\<close> ac_Zp_is_Unit)
+  obtain v where "v = ac_Zp d" by simp
+  have  P7:"d = (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) \<otimes>\<^bsub>Z\<^sub>p\<^esub> v" and P8:"v \<in> Units Z\<^sub>p"
+     using P2 P4 \<open>v = ac_Zp d\<close> ac_Zp_factors' apply blast
+     using P2 Zp.nonzero_memE 
+     by (simp add: \<open>v = ac_Zp d\<close> ac_Zp_is_Unit)
+  have P9: "a = frac ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) \<otimes>\<^bsub>Z\<^sub>p\<^esub> u) ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) \<otimes>\<^bsub>Z\<^sub>p\<^esub> v)"
+    by (simp add: P0 P5 P7)
+  have P10: "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) \<in> carrier Z\<^sub>p"
+    using P1 P3 Z\<^sub>p_def ord_pos Zp.nonzero_closed Zp.nonzero_memE(2) p_pow_car
+    by auto
+  have P11: "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n) \<in> nonzero Z\<^sub>p" 
+    by (simp add: P2 P4 Zp.nonzero_closed Zp.nonzero_memE(2) ord_pos p_int_pow_nonzero)
+  have P12: "u \<in> carrier Z\<^sub>p"
+    using P6 Units_def 
+    by blast
+  have P13: "v \<in> nonzero Z\<^sub>p"
+    using P8 Units_def ord_of_nonzero(2) 
+    by (simp add: Zp.Units_nonzero)    
+  have P14: "a = (frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>m) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>n)) \<otimes> (frac u v)"
+    using P12 P13 P10 P9 P11 Q\<^sub>p_def  frac_mult by metis 
+  have P15: "m \<ge> n" 
+  proof-
+    have "ord_Zp c \<ge> ord_Zp d" 
+      using P0 P1 P2 assms(3) ord_of_frac[of c d] 
+      by (metis P3 P4 antisym eq_iff eq_iff_diff_eq_0 le_cases le_iff_diff_le_0 ord_Zp_def) 
+    then show ?thesis 
+      using P3 P4 by blast
+  qed
+  have P16: "n \<ge> 0" 
+    by (simp add: P2 P4 Zp.nonzero_closed Zp.nonzero_memE(2) ord_pos)
+  have P17: "a = (frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>) \<otimes> (frac u v)" 
+    using P14 P15 P16 local.inc_def[of "(\<p> [^]\<^bsub>Z\<^sub>p\<^esub> (n - m))"] pow_p_frac_0[of n m] 
+    by (simp add: local.inc_def p_pow_car)    
+  obtain w where P18: "w \<in> Units Z\<^sub>p" and P19: "\<iota> w = frac u v "
+    using  Z\<^sub>p_division_Qp_1 P6 P8 by blast
+  have P20: "w \<in> carrier Z\<^sub>p" 
+    using P18 Units_def by blast
+  have P21:  "a = \<iota> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<otimes> \<iota> w" 
+    using P15 P17 P19 \<iota>_def inc_equation p_pow_car by auto    
+  have P22:  "a = (frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<one>\<^bsub>Z\<^sub>p\<^esub>) \<otimes> (frac w \<one>\<^bsub>Z\<^sub>p\<^esub>)" 
+    using P17 P19 P20 local.inc_def by auto
+  have P23: "\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n) \<in> carrier Z\<^sub>p" 
+    by (simp add: P15 p_pow_car)   
+  have P24: "a = (frac ((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> w) \<one>\<^bsub>Z\<^sub>p\<^esub>)" 
+    using P20 P22 P23 frac_mult 
+    by (simp add: Zp.nonzero_one_closed)
+  have P24:  "a = \<iota>((\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(m-n)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> w)" 
+    by (simp add: P20 P23 P24  cring.cring_simprules(5) domain.axioms(1) local.inc_def)
+  then show ?thesis 
+    using P20 P23 by blast
+qed
+
+lemma val_ring_val_criterion:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<ge> 0"
+  shows "a \<in> \<O>\<^sub>p"
+  apply(cases "a = \<zero>")
+  using Qp.int_inc_zero Q\<^sub>p_def inc_of_int apply blast
+    using assms unfolding val_def 
+    by (simp add: val_ring_ord_criterion zero_eint_def)  
+
+lemma ord_of_inv:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "a \<noteq> \<zero>"
+  shows "ord (inv\<^bsub>Q\<^sub>p\<^esub> a) = - (ord a)"
+proof-
+  obtain b c where 
+   Frac: "a = frac b c" and 
+   Car: "b \<in> carrier Z\<^sub>p" and 
+   Nz_c: "c \<in> nonzero Z\<^sub>p"
+    using assms(1) local.numer_denom_facts(1) local.numer_denom_facts(2)
+          local.numer_denom_facts(5) by blast   
+    have Nz_b: "b \<in> nonzero Z\<^sub>p" 
+      using Frac Car Nz_c  assms(2) nonzero_fraction_imp_nonzero_numer by metis 
+    then have "(inv\<^bsub>Q\<^sub>p\<^esub> a) = frac c b" 
+      using Frac Nz_c frac_inv Q\<^sub>p_def 
+      by auto
+    then show ?thesis using Frac Nz_b Nz_c ord_of_frac[of b c] ord_of_frac[of c b]  
+      by (simp add: nonzero_def ord_Zp_def)
+qed
+
+lemma val_of_inv:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "a \<noteq> \<zero>"
+  shows "val (inv\<^bsub>Q\<^sub>p\<^esub> a) = - (val a)"
+  using ord_of_inv unfolding uminus_eint_def 
+  by (simp add: assms(1) assms(2) inv_in_frac(2) val_def)
+
+text\<open>Zp is a valuation ring in Qp\<close>
+
+lemma Z\<^sub>p_mem:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "a \<in> \<O>\<^sub>p \<or> (inv\<^bsub>Q\<^sub>p\<^esub> a \<in> \<O>\<^sub>p)"
+proof(cases "inv\<^bsub>Q\<^sub>p\<^esub>a \<in> \<O>\<^sub>p \<or> a = \<zero>")
+  case True
+  then show ?thesis 
+    using val_ring_subring subringE(2) by auto
+next
+  case False
+  then have Nz: "a \<noteq> \<zero>" by auto 
+  have "\<not> (ord a < 0)"
+  proof
+    assume "ord a < 0"
+    then have "ord (inv\<^bsub>Q\<^sub>p\<^esub> a) >0" 
+      by (simp add: assms(1) Nz ord_of_inv)
+    then have 0: "ord (inv\<^bsub>Q\<^sub>p\<^esub> a) \<ge>0"
+      by auto
+    have 1: "(inv\<^bsub>Q\<^sub>p\<^esub> a) \<in> carrier Q\<^sub>p"
+      by (simp add: assms(1) Nz inv_in_frac)
+    have 2: "(inv\<^bsub>Q\<^sub>p\<^esub> a) \<noteq>\<zero>" 
+      by (simp add: assms(1) Nz inv_in_frac(2))
+    then have "(inv\<^bsub>Q\<^sub>p\<^esub> a) \<in> \<O>\<^sub>p" 
+      using  val_ring_ord_criterion  by (simp add: "0" "1")
+    then show False 
+      using False by blast
+  qed
+  then show ?thesis 
+    using val_ring_ord_criterion assms(1) Nz by auto
+qed 
+
+lemma Qp_val_ringI:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<ge> 0"
+  shows "a \<in> \<O>\<^sub>p" 
+using assms val_ring_val_criterion by blast
+
+
+text\<open>Criterion for determining when an element in Qp is zero\<close>
+lemma val_nonzero:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "s > val a"
+  shows "a \<in> nonzero Q\<^sub>p"
+proof-
+  have "val a \<noteq> \<infinity>"
+    by (metis assms(2) eint_ord_simps(6))    
+  then show ?thesis 
+    using assms 
+    by (metis (mono_tags, opaque_lifting) local.val_zero  not_nonzero_Qp)
+qed
+
+lemma val_ineq:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val \<zero> \<le> val a"
+  shows "a = \<zero>"
+  using assms unfolding val_def 
+  by (metis (mono_tags, lifting) eint_ord_code(5))
+  
+lemma ord_minus:
+  assumes "a \<in>  nonzero Q\<^sub>p"
+  shows "ord a = ord (\<ominus>a)"
+proof-
+  have "\<ominus> a = \<ominus> (frac (numer a) (denom a))"
+    using assms Qp.nonzero_closed local.numer_denom_facts(5) by auto    
+  then have "\<ominus> a = (frac (\<ominus>\<^bsub>Z\<^sub>p\<^esub> (numer a)) (denom a))"
+    by (simp add: Qp.nonzero_closed assms local.frac_uminus local.numer_denom_facts(1) local.numer_denom_facts(2))
+  then show ?thesis 
+    by (metis Q\<^sub>p_def Qp.add.inv_eq_1_iff Qp.nonzero_closed Zp.add.inv_closed assms 
+        local.numer_denom_facts(1) local.numer_denom_facts(2) nonzero_fraction_imp_nonzero_numer 
+        numer_nonzero ord_Zp_of_a_inv ord_def ord_of_frac)
+qed
+
+lemma val_minus:
+  assumes "a \<in>  carrier Q\<^sub>p"
+  shows "val a = val (\<ominus>a)"
+proof(cases "a = \<zero>")
+  case True
+  then show ?thesis 
+    using Qp.minus_zero by presburger  
+next
+  case False
+  then show ?thesis using Qp.domain_axioms assms cring.cring_simprules(21)
+        cring.cring_simprules(22) domain.axioms(1) not_nonzero_Qp 
+        ord_minus val_def 
+    by metis 
+qed
+
+text\<open>The valuation is multiplicative:\<close>
+
+lemma ord_mult:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  shows "(ord (x \<otimes> y)) = (ord x) + (ord y)"
+proof-
+  have 0:"x \<in> carrier Q\<^sub>p" using assms by(simp add:nonzero_def)
+  have 1:"y \<in>carrier Q\<^sub>p" using assms by(simp add:nonzero_def)
+  obtain a b c where
+   A: "a \<in> carrier Z\<^sub>p" and
+   B: "b \<in> carrier Z\<^sub>p" and
+   C: "c \<in> nonzero Z\<^sub>p" and
+   Fx: "x = frac a c" and
+   Fy: "y = frac b c" 
+    using get_common_denominator 0 1 by blast
+  have An: "a \<in> nonzero Z\<^sub>p"
+    using A C Fx assms(1) nonzero_def nonzero_fraction_imp_nonzero_numer 
+          Qp.nonzero_memE(2) by auto
+  have Bn: " b \<in> nonzero Z\<^sub>p" 
+    using B C Fy assms(2) nonzero_def nonzero_fraction_imp_nonzero_numer 
+          Qp.nonzero_memE(2) by auto
+  have Fxy: "x \<otimes> y = frac (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> b) (c \<otimes>\<^bsub>Z\<^sub>p\<^esub> c)" 
+    by (simp add: A B C Fx Fy frac_mult)
+  have Cn: "c \<otimes>\<^bsub>Z\<^sub>p\<^esub> c \<in> nonzero Z\<^sub>p" 
+    using C Localization.submonoid.m_closed Zp.domain_axioms domain.nonzero_is_submonoid 
+    by metis
+  have Ordxy0: "ord (x \<otimes> y) = ord_Zp (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> b) - ord_Zp (c \<otimes>\<^bsub>Z\<^sub>p\<^esub> c)"
+    by (metis "0" "1" An Bn C Cn Fx Fxy Fy Qp.integral
+        Zp.nonzero_mult_closed Zp.zero_closed fraction_zero 
+        nonzero_fraction nonzero_fraction_imp_nonzero_numer ord_of_frac)
+  have Ordxy1: "ord (x \<otimes> y) = (ord_Zp a) + (ord_Zp b) - ((ord_Zp c) + (ord_Zp c))" 
+    using  An Bn C 
+    by (simp add: Ordxy0 ord_Zp_mult)
+  show ?thesis 
+  proof-
+    have "ord x + ord y = (ord_Zp a) - (ord_Zp c) + ((ord_Zp b) - (ord_Zp c))"
+      using An Bn C Fx Fy ord_of_frac[of a c] ord_of_frac[of b c] by presburger 
+    then show ?thesis 
+      using Ordxy1 
+      by presburger 
+  qed
+qed
+
+lemma val_mult0:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  shows "(val (x \<otimes> y)) = (val x) + (val y)"
+proof-
+  have 0: "val x = ord x" 
+    using assms(1) val_ord by metis  
+  have 1: "val y = ord y" 
+    using assms(2) val_ord by metis   
+  have "x \<otimes> y \<noteq> \<zero>"
+    using field_axioms assms(1) assms(2) integral  Qp.integral_iff 
+      Qp.nonzero_closed Qp.nonzero_memE(2) by presburger
+  then have 2: "val (x \<otimes> y) = ord (x \<otimes> y)" 
+    by (simp add:  val_def) 
+  have 3: "val x + val y = ord x + ord y "
+    by (simp add: "0" "1")   
+  have 4: "val (x \<otimes> y) = ord  (x \<otimes> y)" 
+    using "2" by auto 
+  then show ?thesis using 3 4 ord_mult assms nonzero_def 
+    by (simp add: nonzero_def)   
+qed  
+
+text\<open>val is multiplicative everywhere\<close>
+
+lemma val_mult:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  shows "(val (x \<otimes> y)) = (val x) + (val y)"
+  apply(cases "x = \<zero> \<or> y = \<zero>")
+  using assms local.val_zero apply auto[1]
+    by (meson assms(1) assms(2) not_nonzero_Qp val_mult0)
+
+text\<open>val and ord are compatible with inclusion\<close>
+
+lemma ord_of_inc:
+assumes "x \<in> nonzero Z\<^sub>p"
+shows "ord_Zp x = ord(\<iota> x)" 
+proof-
+  have "\<iota> x = frac x \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using assms(1) 
+    by (simp add: Zp.nonzero_closed local.inc_def)
+  then have "ord ( \<iota> x) = ord_Zp x - ord_Zp \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using assms(1) ord_of_frac 
+    by (simp add: Zp.nonzero_one_closed)
+  then show ?thesis
+    using ord_Zp_one 
+    by (simp add: ord_Zp_def)
+qed
+
+lemma val_of_inc:
+assumes "x \<in> carrier Z\<^sub>p"
+shows "val_Zp x = val (\<iota> x)" 
+proof(cases "x \<in> nonzero Z\<^sub>p")
+  case True
+  then show ?thesis 
+    using inc_of_nonzero nonzero_def ord_Zp_def ord_of_inc val_Zp_def val_ord 
+    by (simp add: nonzero_def)
+next
+  case False
+  then show ?thesis 
+    by (metis Zp.nonzero_memI Zp.nonzero_one_closed assms local.inc_def nonzero_fraction_imp_numer_not_zero val_Zp_def val_def)
+qed
+
+lemma Qp_inc_id:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "ord a \<ge>0"
+  obtains b where "b \<in> nonzero Z\<^sub>p" and "a = \<iota> b"
+  using assms 
+  by (metis (no_types, opaque_lifting) Qp.nonzero_closed Qp.nonzero_memE(2) 
+      Zp.nonzero_one_closed Zp.zero_closed Zp_defs(2) val_ring_ord_criterion image_iff local.inc_def 
+      nonzero_fraction_imp_numer_not_zero not_nonzero_Zp  that)
+
+lemma val_ring_memI:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<ge> 0"
+  shows "a \<in> \<O>\<^sub>p"
+  using assms Qp_val_ringI by blast
+
+lemma val_ring_memE:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "val a \<ge> 0" "a \<in> carrier  Q\<^sub>p"
+  using assms  val_of_inc val_pos apply auto[1]
+  using assms inc_closed by auto
+  
+lemma val_ring_add_closed: 
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "a \<oplus> b \<in> \<O>\<^sub>p"
+  using val_ring_subring subringE(7) by (metis assms(1) assms(2))
+
+lemma val_ring_times_closed: 
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "a \<otimes> b \<in> \<O>\<^sub>p"
+  using val_ring_subring subringE(6)  by (metis assms(1) assms(2))
+
+lemma val_ring_ainv_closed: 
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "\<ominus> a \<in> \<O>\<^sub>p"
+  using val_ring_subring subringE(5)  by (metis assms)
+
+lemma val_ring_minus_closed:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "a \<ominus> b \<in> \<O>\<^sub>p"
+  using assms val_ring_subring val_ring_ainv_closed val_ring_add_closed
+  unfolding a_minus_def   by blast 
+
+lemma one_in_val_ring:
+"\<one> \<in> \<O>\<^sub>p"
+  apply(rule val_ring_memI)
+  apply blast
+  unfolding val_one by blast 
+
+lemma zero_in_val_ring:
+"\<zero> \<in> \<O>\<^sub>p"
+  apply(rule val_ring_memI)
+  apply blast
+  unfolding val_zero 
+  by simp  
+
+lemma ord_p:
+"ord \<pp> = 1"
+  using p_nonzero ord_Zp_p ord_of_inc p_inc 
+  by (smt Zp_int_inc_closed ord_of_nonzero(2))
+
+lemma ord_p_pow_nat:
+"ord (\<pp> [^] (n::nat)) = n"
+  using p_pow_nonzero ord_Zp_p ord_of_inc p_inc ord_Zp_p_pow p_natpow_inc  p_pow_nonzero' 
+  by auto
+
+lemma ord_p_pow_int:
+"ord (\<pp> [^] (n::int)) = n"
+proof(cases "n \<ge>0")
+  case True
+  then show ?thesis 
+    by (metis int_nat_eq int_pow_int ord_p_pow_nat)
+next
+  case False
+  then have Neg: "n <0" by auto 
+  then have 0: "\<pp>[^]n = frac \<one>\<^bsub>Z\<^sub>p\<^esub> (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(-n))" 
+    using p_intpow by auto
+  have "(\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(-n)) \<in> nonzero Z\<^sub>p"
+    using False p_int_pow_nonzero 
+    by (simp add: nonzero_def)
+  then have "ord (\<pp> [^] (n::int)) = ord_Zp \<one>\<^bsub>Z\<^sub>p\<^esub> - ord_Zp (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(-n))" 
+    using "0" ord_of_frac 
+    by (simp add: Zp.nonzero_one_closed)
+  then have "ord (\<pp> [^] (n::int)) = - ord_Zp (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(-n))" 
+    using ord_Zp_one by linarith
+  then have "ord (\<pp> [^] (n::int)) = -(-n)" 
+    using Neg ord_Zp_p_int_pow 
+    by (metis int.lless_eq neg_0_le_iff_le)
+  then show ?thesis 
+    by auto 
+qed
+
+lemma ord_nonneg:
+  assumes "x \<in>  \<O>\<^sub>p"
+  assumes "x \<noteq> \<zero>"
+  shows "ord x \<ge>0"
+proof-
+  obtain a where A: "x = \<iota> a \<and> a \<in> carrier Z\<^sub>p" 
+    using assms(1) by blast
+  then have "a \<in> nonzero Z\<^sub>p" using assms(2) 
+      local.inc_def nonzero_fraction_imp_numer_not_zero not_nonzero_Zp
+    using Zp.nonzero_one_closed by blast
+  then have "ord_Zp a \<ge>0" 
+    using A 
+    by (simp add: Zp.nonzero_memE(2) ord_pos)
+  then show ?thesis 
+    using A \<open>a \<in> nonzero Z\<^sub>p\<close> ord_of_inc by metis 
+qed
+
+lemma val_p:
+"val \<pp> = 1"
+  using p_inc val_Zp_p val_of_inc val_def ord_p p_nonzero val_ord 
+  by simp  
+
+lemma val_p_int_pow:
+"val (\<pp>[^](k::int)) = k"
+  using ord_p_pow_int p_intpow_closed(2) val_ord by presburger
+
+lemma val_p_int_pow_neg:
+"val (\<pp>[^](-k::int)) = - eint k"
+  by (metis eint.distinct(2) local.val_zero p_intpow_closed(1) p_intpow_inv'' val_of_inv val_p_int_pow)
+
+lemma nonzero_nat_pow_ord:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "ord (a [^] (n::nat)) = n * ord a"
+  apply(induction n)
+  apply simp
+    using Qp_nat_pow_nonzero assms semiring_normalization_rules(2) 
+    by (simp add: semiring_normalization_rules(2) ord_mult)
+
+
+lemma add_cancel_eint_geq:
+  assumes "(eint a) + x \<ge> (eint a ) + y"
+  shows "x \<ge>y"
+  using assms eint_add_left_cancel_le by blast
+
+lemma(in padic_fields) prod_equal_val_imp_equal_val:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "val (a \<otimes> b) = val (a \<otimes> c)"
+  shows "val b = val c"
+proof(cases "b = \<zero>")
+  case True
+  then have "val (a \<otimes> b) = \<infinity>"
+    using Qp.nonzero_closed Qp.r_null assms(1) local.val_zero by presburger
+  then have "c = \<zero>"
+    using assms True 
+    by (metis Qp.integral Qp.nonzero_closed Qp.nonzero_mult_in_car Qp.not_nonzero_memI eint_ord_simps(3) not_nonzero_Qp val_ineq)   
+  then show ?thesis 
+    using True by blast
+next
+  case False
+  obtain n where n_def: "val a = eint n"
+    using assms val_ord by blast
+  then show ?thesis using val_mult[of a b] val_mult[of a c] unfolding n_def 
+  by (simp add: Qp.nonzero_closed assms(1) assms(2) assms(3) assms(4))
+qed
+
+
+lemma two_times_eint:
+  shows "2*(x::eint) = x + x"
+  by (metis eint_2_minus_1_mult eint_add_cancel_fact plus_eq_infty_iff_eint times_eint_simps(4))
+
+lemma times_cfs_val_mono:
+  assumes "u \<in> Units Q\<^sub>p"
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "val (u \<otimes> a) \<le> val (u \<otimes> b)"
+  shows "val a \<le> val b"
+proof-
+  have "eint (ord u) + val a \<le> eint (ord u) + val b"
+    using assms val_ord  val_mult Qp.Units_nonzero Qp.nonzero_closed Units_eq_nonzero by metis 
+  thus ?thesis  
+    apply(induction "val a")
+    using add_cancel_eint_geq apply blast
+    using add_cancel_eint_geq by blast
+qed
+
+lemma times_cfs_val_mono':
+  assumes "u \<in> Units Q\<^sub>p"
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "val (u \<otimes> a) \<le> val (u \<otimes> b) + \<alpha>"
+  shows "val a \<le> val b + \<alpha>"
+proof-
+  obtain c where c_def: "c \<in> carrier Q\<^sub>p \<and> val c = \<alpha>"
+    by (metis Qp.zero_closed eint.exhaust local.val_zero p_intpow_closed(1) val_p_int_pow)     
+  have 0: "val (u \<otimes> a) \<le> val (u \<otimes> (b \<otimes> c))"
+    using assms val_mult[of "u \<otimes> b" c] Qp.m_assoc[of u b c] c_def Qp.Units_closed Qp.cring_simprules(5) 
+    by metis
+  have 1: "val a \<le> val (b \<otimes> c)" 
+    apply(rule times_cfs_val_mono[of u])
+    using assms apply blast using assms apply blast
+     apply(rule Qp.ring_simprules) using assms apply blast using c_def apply blast
+    by(rule 0)
+  show ?thesis 
+    using 1 val_mult[of b c] assms c_def by smt 
+qed
+
+lemma times_cfs_val_mono'':
+  assumes "u \<in> Units Q\<^sub>p"
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "val a \<le> val b + \<alpha>"
+  shows "val (u \<otimes> a) \<le> val (u \<otimes> b) + \<alpha>"
+  apply(rule times_cfs_val_mono'[of "inv u" "u \<otimes> a" "u \<otimes> b" \<alpha>])
+  using assms apply blast
+  apply(rule Qp.ring_simprules)
+  using assms apply blast using assms apply blast
+  apply(rule Qp.ring_simprules)
+  using assms apply blast using assms apply blast
+  using m_assoc assms 
+  by (metis Qp.Units_closed Qp.cring_simprules(5) Qp.inv_cancelR(1))
+
+lemma val_ineq_cancel_leq: 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "val (a \<otimes> b) \<le> val (a \<otimes> c)"
+  shows "val b \<le> val c"
+  using Units_eq_nonzero assms(1) assms(2) assms(3) assms(4) times_cfs_val_mono by blast 
+
+lemma val_ineq_cancel_leq': 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "val b \<le> val c"
+  shows "val (a \<otimes> b) \<le> val (a \<otimes> c)"
+  apply(rule val_ineq_cancel_leq[of "inv a" "a \<otimes> b" "a \<otimes> c"])
+  using assms(1) nonzero_inverse_Qp apply blast
+  using Qp.nonzero_closed assms(1) assms(2) apply blast
+  using Qp.nonzero_closed assms assms(2) apply blast
+  by (metis Qp.inv_cancelR(1) Qp.m_closed Qp.nonzero_closed Units_eq_nonzero assms(1) assms(2) assms(3) assms(4))
+
+lemma val_ineq_cancel_le: 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "val (a \<otimes> b) < val (a \<otimes> c)"
+  shows "val b < val c"
+  using Qp.nonzero_closed assms(1) assms(2) assms(3) assms(4) val_mult by auto 
+
+lemma val_ineq_cancel_le': 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "val b < val c"
+  shows "val (a \<otimes> b) < val (a \<otimes> c)"
+  apply(rule val_ineq_cancel_le[of "inv a" "a \<otimes> b" "a \<otimes> c"])
+  using assms(1) nonzero_inverse_Qp apply blast
+  using Qp.nonzero_closed assms(1) assms(2) apply blast
+  using Qp.nonzero_closed assms assms(2) apply blast
+  by (metis Qp.inv_cancelR(1) Qp.m_closed Qp.nonzero_closed Units_eq_nonzero assms(1) assms(2) assms(3) assms(4))
+
+lemma finite_val_imp_nonzero:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<noteq> \<infinity>"
+  shows "a \<in> nonzero Q\<^sub>p"
+  using assms unfolding val_def nonzero_def 
+  by (metis (mono_tags, lifting) mem_Collect_eq)
+
+lemma val_ineq_cancel_leq'': 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "val b \<le> val c + eint N"
+  shows "val (a \<otimes> b) \<le> val (a \<otimes> c) + eint N"
+proof- 
+  obtain d where d_def: "d = \<pp>[^]N \<otimes> c"
+    by blast 
+  show ?thesis 
+  proof(cases "c = \<zero>")
+    case True
+    then show ?thesis unfolding True 
+      using True Units_eq_nonzero assms(1) assms(2) assms(4) times_cfs_val_mono'' by blast
+  next
+    case False
+    have F0: "c \<in> nonzero Q\<^sub>p"
+      using False assms  Qp.not_nonzero_memE by blast
+    have F1: "val (a \<otimes> c) < \<infinity>"
+      using F0 assms 
+      by (metis (no_types, lifting) Qp.integral Qp.nonzero_closed Qp.nonzero_memE(2) eint.distinct(1) eint_ord_simps(4) val_def) 
+    have F2: "b \<in> nonzero Q\<^sub>p"
+      using F0 assms 
+      by (metis False Groups.add_ac(2) add_cancel_eint_geq finite_val_imp_nonzero local.val_zero plus_eint_simps(2) val_ineq)
+    have F3: "ord b \<le> ord c + N"
+      using assms F0
+      by (metis F2 eint_ord_simps(1) plus_eint_simps(1) val_ord)
+    have F4: "ord a + ord b \<le> ord a + ord c+ N"
+      using assms F0 F1 F2 ord_mult F3 by presburger
+    have F5: "ord (a \<otimes> b) \<le> ord (a \<otimes> c) + N"
+      using F4 F2 F0 assms ord_mult by presburger
+    have F6: "a \<otimes> b \<in> nonzero Q\<^sub>p"
+      by (metis F2 Qp.integral Qp.nonzero_memE(1) Qp.nonzero_mult_closed Qp.not_nonzero_memE assms(1))
+    have F7: "a \<otimes> c \<in> nonzero Q\<^sub>p"
+      by (metis False Qp.integral Qp.nonzero_closed Qp.nonzero_memI Qp.nonzero_mult_closed assms(1) assms(3))
+    show "val (a \<otimes> b) \<le> val (a \<otimes> c) + eint N"
+      using val_ord[of "a \<otimes> b" ] val_ord[of "a \<otimes>c"] F7 F7 F4 
+        Units_eq_nonzero assms(1) assms(2) assms(3) assms(4) times_cfs_val_mono'' by blast
+  qed
+qed
+
+
+      (********************************************************************************************)
+      (********************************************************************************************)
+      subsubsection\<open>The Ultrametric Inequality on $\mathbb{Q}_p$\<close>
+      (********************************************************************************************)
+      (********************************************************************************************)
+
+
+lemma ord_ultrametric:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  assumes "x \<oplus> y \<in> nonzero Q\<^sub>p"
+  shows "ord (x \<oplus> y) \<ge> min (ord x) (ord y)"
+proof-
+  have 0:"x \<in> carrier Q\<^sub>p" using assms by(simp add:nonzero_def)
+  have 1:"y \<in>carrier Q\<^sub>p" using assms by(simp add:nonzero_def)
+  obtain a b c where
+   A: "a \<in> carrier Z\<^sub>p" and
+   B: "b \<in> carrier Z\<^sub>p" and
+   C: "c \<in> nonzero Z\<^sub>p" and
+   Fx: "x = frac a c" and
+   Fy: "y = frac b c" 
+    using  0 1  get_common_denominator by blast
+  have An: "a \<in> nonzero Z\<^sub>p" 
+    using A C Fx assms(1) nonzero_fraction_imp_nonzero_numer 
+          Qp.nonzero_memE(2) by auto
+  have Bn: " b \<in> nonzero Z\<^sub>p" 
+    using B C Fy assms(2)   nonzero_fraction_imp_nonzero_numer  Qp.nonzero_memE(2) by auto
+  have Fxy: "x \<oplus> y = frac (a \<oplus>\<^bsub>Z\<^sub>p\<^esub> b) c" using 0 1  
+    by (simp add: A B C Fx Fy frac_add_common_denom)
+  have ABn: " a \<oplus>\<^bsub>Z\<^sub>p\<^esub> b \<in> nonzero Z\<^sub>p" 
+  proof-
+    have "a \<oplus>\<^bsub>Z\<^sub>p\<^esub> b \<in> carrier Z\<^sub>p" 
+      using A B Z\<^sub>p_def padic_add_closed prime by blast
+    then show ?thesis 
+      using Fxy C assms(3) Qp.nonzero_memE(2) 
+        nonzero_fraction_imp_nonzero_numer by blast     
+  qed
+  have Ordx: "ord x = ord_Zp a - ord_Zp c"
+      using Fx An C ord_of_frac by metis 
+  have Ordy: "ord y = ord_Zp b - ord_Zp c" 
+    using Fy Bn C ord_of_frac by metis   
+  have Ordxy: "ord (x \<oplus> y) = ord_Zp (a \<oplus>\<^bsub>Z\<^sub>p\<^esub> b) - ord_Zp c"
+    using Fxy ABn C ord_of_frac by metis   
+  then show ?thesis
+    using Ordx Ordy Ordxy ord_Zp_ultrametric[of a b] ABn An Bn 
+    by linarith
+qed
+
+lemma ord_ultrametric':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  assumes "x \<ominus>\<^bsub>Q\<^sub>p\<^esub> y \<in> nonzero Q\<^sub>p"
+  shows "ord (x \<ominus>\<^bsub>Q\<^sub>p\<^esub> y) \<ge> min (ord x) (ord y)"
+proof-
+  have "ord y = ord (\<ominus>y)"
+    using assms(2) ord_minus by blast
+  then show ?thesis 
+    using assms ord_ultrametric[of x "\<ominus>y"]
+    unfolding a_minus_def 
+    using Qp.add.inv_closed Qp.add.inv_eq_1_iff Qp.nonzero_closed Qp.nonzero_memE(2) Qp.nonzero_memI 
+    by metis
+qed
+
+lemma val_ultrametric0:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  assumes "x \<oplus> y \<in> nonzero Q\<^sub>p"
+  shows " min (val x) (val y) \<le> val (x \<oplus> y)  "
+proof-
+  have 0: "val (x \<oplus> y) = ord (x \<oplus> y)" 
+    using assms(3) nonzero_def val_def[of "(x \<oplus> y)"] by fastforce
+  have 1: "val x = ord x" 
+    using assms(1) nonzero_def val_def 
+    by (simp add: nonzero_def)
+  have 2: "val y = ord y" 
+    using assms(2) nonzero_def val_def val_ord by auto
+  have 3: "ord (x \<oplus> y) \<ge> min (ord x) (ord y)" 
+    by (simp add: assms(1) assms(2) assms(3) ord_ultrametric)   
+  then show ?thesis 
+    by (simp add: "0" "1" "2")   
+qed
+
+lemma val_ultrametric:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  shows " min (val x) (val y) \<le> val (x \<oplus> y)"
+  apply(cases "x = \<zero> \<or> y = \<zero>")
+  using assms(1) assms(2) apply auto[1]
+    by (metis Qp.add.m_closed assms(1) assms(2) eint_ord_code(3) local.val_zero not_nonzero_Qp val_ultrametric0)
+
+lemma val_ultrametric':
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  shows " min (val x) (val y) \<le> val (x \<ominus> y)"
+  using val_ultrametric[of x "\<ominus>y"]
+        val_minus[of y]
+        assms 
+  by (metis Qp.domain_axioms a_minus_def cring.cring_simprules(3) domain.axioms(1))
+
+lemma diff_ord_nonzero:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"  
+  assumes "ord x \<noteq> ord y"
+  shows "x \<oplus> y \<in> nonzero Q\<^sub>p"
+proof(rule ccontr)
+  assume " x \<oplus> y \<notin> nonzero Q\<^sub>p"
+  then have "x \<oplus> y = \<zero>"
+    using Qp.add.m_closed Qp.nonzero_closed Qp.nonzero_memI assms(1) assms(2) by blast
+  then have "x = \<ominus> y"
+    using Qp.minus_equality Qp.nonzero_closed assms(1) assms(2) by blast
+  then have "ord x = ord y"
+    using assms(2) ord_minus by presburger
+  then show False 
+    using assms(3) by blast
+qed
+
+lemma ord_ultrametric_noteq:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  assumes "ord x > ord y"
+  shows "ord (x \<oplus> y) = (ord y)"
+proof(rule ccontr)
+  assume "ord (x \<oplus> y) \<noteq> ord y"
+  have 00:"x \<oplus> y \<in> nonzero Q\<^sub>p"
+  proof(rule ccontr)
+    assume "x \<oplus> y \<notin> nonzero Q\<^sub>p"
+    then have "x \<oplus> y = \<zero>"
+      using Qp.add.m_closed Qp.nonzero_closed Qp.nonzero_memI assms(1) assms(2) by blast
+    then have "x = \<ominus> y"
+      by (smt \<open>x \<oplus> y \<notin> nonzero Q\<^sub>p\<close> assms(1) assms(2) assms(3) diff_ord_nonzero)      
+    then have "ord x = ord y"
+      using assms(2) ord_minus by presburger
+    then show False 
+      using assms(3) by linarith
+  qed
+  then have 0: "ord (x \<oplus> y) > ord y"
+    using ord_ultrametric[of x y] \<open>ord (x \<oplus> y) \<noteq> ord y\<close> assms(1) assms(2) assms(3) 
+    by linarith    
+  have 1: "((y \<oplus> x) \<ominus> x) = y"
+    using "00" Qp.add.inv_solve_right' Qp.add.m_comm Qp.minus_eq Qp.nonzero_closed assms(1) assms(2) by presburger 
+  have 2: "ord ((y \<oplus> x) \<ominus> x) \<ge> min (ord (y \<oplus> x)) (ord x) "
+    using 1 assms ord_ultrametric'[of "(y \<oplus> x)" x] diff_ord_nonzero by auto
+  have 3:  "ord y \<ge> min (ord x) (ord (x \<oplus> y))"
+    using 2 1 Q\<^sub>p_def Qp.domain_axioms Z\<^sub>p_def assms(1) assms(2) cring.cring_simprules(10) 
+          domain.axioms(1) Qp.nonzero_closed by fastforce  
+  show False 
+    using 3 0 assms 
+    by linarith
+qed
+
+lemma ord_ultrametric_noteq':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  assumes "ord x > ord y"
+  shows "ord (x \<ominus> y) = (ord y)"
+  using assms ord_ultrametric_noteq[of x "\<ominus>y"]
+  by (metis Qp.add.inv_closed Qp.minus_eq Qp.nonzero_closed Qp.nonzero_memI Qp.r_neg Qp.r_zero ord_minus)
+  
+lemma ord_ultrametric_noteq'':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  assumes "ord y > ord x"
+  shows "ord (x \<ominus> y) = (ord x)"
+  using assms ord_ultrametric_noteq'[of y x]
+  by (metis Qp.minus_a_inv Qp.nonzero_closed Qp.not_eq_diff_nonzero ord_minus)
+  
+lemma val_ultrametric_noteq:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  assumes "val x > val y"
+  shows "val (x \<oplus> y) = val y"
+  apply(cases "x = \<zero>")
+  apply (simp add: assms(2))
+    using assms unfolding val_def 
+    by (smt Qp.not_nonzero_memI diff_ord_nonzero eint_ord_simps(2) not_nonzero_Qp ord_ultrametric_noteq val_def val_nonzero)
+
+lemma val_ultrametric_noteq':
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  assumes "val x > val y"
+  shows "val (x \<ominus> y) = val y"
+  using assms  val_ultrametric_noteq[of x "\<ominus>y"]
+  by (metis Qp.domain_axioms a_minus_def cring.cring_simprules(3) domain.axioms(1) val_minus)
+
+lemma ultrametric_equal_eq:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  assumes "val (y \<ominus> x) > val x"
+  shows "val x = val y"
+  using assms 
+  by (metis (no_types, lifting) Qp.add.inv_closed Qp.add.m_assoc Qp.l_neg Qp.minus_closed Qp.minus_eq Qp.r_zero val_ultrametric_noteq)
+
+lemma ultrametric_equal_eq':
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  assumes "val (x \<ominus> y) > val x"
+  shows "val x = val y"
+  using assms ultrametric_equal_eq[of x y] 
+  by (metis Qp.minus_a_inv Qp.minus_closed val_minus)
+
+lemma val_ultrametric_noteq'':
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  assumes "val x > val y"
+  shows "val (y \<ominus> x) = val y"
+  by (metis Qp.minus_a_inv Qp.minus_closed assms(1) assms(2) assms(3) val_minus val_ultrametric_noteq')
+  
+text\<open>Ultrametric over finite sums:\<close>
+
+lemma Min_mono:
+  assumes "finite A"
+  assumes "A \<noteq> {}"
+  assumes "\<And> a. a \<in> A \<Longrightarrow>  f a \<le> a"
+  shows "Min (f`A) \<le> Min A"
+  by (meson Min_in Min_le_iff assms(1) assms(2) assms(3) finite_imageI image_eqI image_is_empty)
+
+lemma Min_mono':
+  assumes "finite A"
+  assumes "\<And> (a::'a). a \<in> A \<Longrightarrow> (f::'a \<Rightarrow> eint)  a \<le>  g a"
+  shows "Min (f`A) \<le> Min (g `A)"
+proof-
+  have "(\<forall>a \<in>  A. f a \<le> g a) \<longrightarrow> Min (f`A) \<le> Min (g` A)"
+  apply(rule finite.induct[of A])
+      apply (simp add: assms(1))
+  apply simp
+  proof fix A a assume F: "finite A" "(\<forall>a\<in>A. f a \<le> g a) \<longrightarrow> Min (f ` A) \<le> Min (g ` A)"
+"\<forall>a\<in>insert a A. f a \<le> g a"
+    show "Min (f ` insert a A) \<le> Min (g ` insert a A)"
+    proof-
+      obtain k where k_def: "k \<in> insert a A \<and> g k = Min (g ` insert a A)"
+        using assms 
+        by (metis (mono_tags, opaque_lifting) F(1) Min_eq_iff finite.insertI finite_imageI image_iff image_is_empty insert_not_empty)
+      then have 0: "f k \<le> g k"
+        using F(3) by blast
+      thus ?thesis using k_def 
+        by (metis F(1) Min_le dual_order.trans finite.insertI finite_imageI image_eqI)
+    qed
+  qed
+  thus ?thesis using assms by blast 
+qed
+
+lemma eint_ord_trans:
+  assumes "(a::eint) \<le> b"
+  assumes "b \<le> c"
+  shows "a \<le> c"
+  using assms by auto 
+
+lemma eint_Min_geq:
+  assumes "finite (A::eint set)"
+  assumes "\<And>x. x \<in> A \<Longrightarrow> x \<ge> c"
+  assumes "A \<noteq> {}"
+  shows "Min A \<ge> c"
+  using Min_in[of A] assms(2)[of "Min A"] assms by blast 
+
+lemma eint_Min_gr:
+  assumes "finite (A::eint set)"
+  assumes "\<And>x. x \<in> A \<Longrightarrow> x > c"
+  assumes "A \<noteq> {}"
+  shows "Min A > c"
+  using Min_in[of A] assms(2)[of "Min A"] assms by blast 
+
+lemma finsum_val_ultrametric:
+  assumes "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+  assumes "finite A"
+  assumes "A \<noteq> {}"
+  shows " val (finsum Q\<^sub>p g A) \<ge> Min (val ` (g`A))"  
+proof-
+  have "A \<noteq> {} \<and> g \<in> A \<rightarrow> carrier Q\<^sub>p \<longrightarrow> val (finsum Q\<^sub>p g A) \<ge> Min (val ` (g`A))"  
+    apply(rule finite.induct[of A])
+      apply (simp add: assms(2))
+      apply blast
+  proof fix A a assume A: "finite A" "A \<noteq> {}\<and> g \<in> A \<rightarrow> carrier Q\<^sub>p \<longrightarrow> val (finsum Q\<^sub>p g A) \<ge> Min (val ` g ` A)"
+                          " insert a A \<noteq> {} \<and> g \<in> insert a A \<rightarrow> carrier Q\<^sub>p "
+    show "val (finsum Q\<^sub>p g (insert a A)) \<ge> Min (val ` g ` insert a A)"
+      apply(cases "a \<in> A")
+       apply (metis A(2) A(3) insert_absorb)
+    proof(cases "A = {}")
+      have g_closed: "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+        using A(3) by blast
+      have g_closed': "g \<in> insert a A \<rightarrow> carrier Q\<^sub>p"
+        using A(3) by linarith
+      then have ga: "g a \<in> carrier Q\<^sub>p"
+        by blast 
+      assume a_notin: "a \<notin> A"
+      case True
+      have "g a \<in> carrier Q\<^sub>p" using A(3) 
+        by blast
+      then have 0: "(finsum Q\<^sub>p g (insert a A)) = g a"
+        using A True abelian_monoid.finsum_insert[of Q\<^sub>p A a g]  abelian_monoid.finsum_empty[of Q\<^sub>p g]
+              Qp.abelian_monoid_axioms Qp.add.l_cancel_one Qp.zero_closed a_notin g_closed 
+        by metis  
+      have 1: "Min (val ` g ` insert a A) = val (g a)"
+        by (metis A(1) True Min_in finite.insertI finite_imageI image_empty 
+            image_insert insert_not_empty singletonD)
+      show ?thesis 
+        using 0 1 
+        by simp       
+    next
+      case False
+      assume a_notin: "a \<notin> A"
+      have g_closed: "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+        using A(3) by blast
+      have g_closed': "g \<in> insert a A \<rightarrow> carrier Q\<^sub>p"
+        using A(3) by linarith
+      then have ga: "g a \<in> carrier Q\<^sub>p"
+        by blast 
+      have 0: "finsum Q\<^sub>p g (insert a A) = g a \<oplus> finsum Q\<^sub>p g A" 
+        by (simp add: A(1) a_notin g_closed ga)     
+      have 1: "min (val (g a)) (Min (val ` g ` A)) = Min (insert (val (g a)) (val ` g ` A))"
+      proof-
+        have 10: "finite (val ` g ` A) " using A
+          by blast
+        then have 11: "val ` g ` A \<noteq> {}"
+          using False 
+          by blast
+        show ?thesis 
+          using  10 11 Min_insert 
+          by simp          
+      qed
+      have 2: " val (g a \<oplus> finsum Q\<^sub>p g A) \<ge> min (val (g a)) (val (finsum Q\<^sub>p g A))"
+        using val_ultrametric[of "g a" "finsum Q\<^sub>p g A" ] abelian_monoid.finsum_closed[of Q\<^sub>p g A]
+              g_closed ga  Qp.abelian_monoid_axioms by blast   
+      have 3: " val (finsum Q\<^sub>p g A) \<ge> Min (val ` g ` A)"
+        using A False 
+        by blast
+      have 4: " val (finsum Q\<^sub>p g (insert a A)) \<ge>  min (val (g a)) (val (finsum Q\<^sub>p g A))"
+        using 2 "0" 
+        by presburger
+      have 5: " val (finsum Q\<^sub>p g A) \<ge> Min (val ` g ` A)"
+        using False "3" by blast
+      show " val (finsum Q\<^sub>p g (insert a A)) \<ge> Min (val ` g ` insert a A)"
+        using 5 4 1 
+        by (smt image_insert min.cobounded1 min_def order_trans)        
+    qed
+  qed
+  then show ?thesis 
+    using assms 
+    by blast
+qed
+
+lemma (in padic_fields) finsum_val_ultrametric':
+  assumes "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+  assumes "finite A"
+  assumes "\<And>i. i \<in> A \<Longrightarrow> val (g i) \<ge> c"
+  shows " val (finsum Q\<^sub>p g A) \<ge> c"
+proof(cases "A = {}")
+  case True
+  then show ?thesis using assms
+    unfolding True Qp.finsum_empty  
+    using eint_ord_code(3) local.val_zero by presburger
+next
+  case False
+  show ?thesis
+  proof(rule eint_ord_trans[of _ "Min (val ` g ` A)"])
+    have 0: "\<And>s. s \<in> val ` g ` A \<Longrightarrow> s \<ge> c" 
+    proof- fix s assume A: "s \<in> val ` g ` A"
+      then obtain a where a_def: "a \<in> A \<and> s = val (g a)"
+        by blast
+      have s_eq: "s = val (g a)"
+        using a_def by blast 
+      show "c \<le> s"
+        using assms(3)[of a] A a_def unfolding s_eq  by blast 
+    qed
+    show "c \<le> Min (val ` g ` A)"
+      apply(rule eint_Min_geq)
+      using assms apply blast using assms apply blast
+      using False by blast
+    show "Min (val ` g ` A) \<le> val (finsum Q\<^sub>p g A)"
+      by(rule finsum_val_ultrametric[of g A], rule assms, rule assms, rule False)
+  qed
+qed
+
+lemma (in padic_fields) finsum_val_ultrametric'':
+  assumes "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+  assumes "finite A"
+  assumes "\<And>i. i \<in> A \<Longrightarrow> val (g i) > c"
+  assumes "c < \<infinity>"
+  shows " val (finsum Q\<^sub>p g A) > c"
+proof(cases "A = {}")
+  case True
+  then show ?thesis using assms
+    unfolding True Qp.finsum_empty  val_zero
+    using eint_ord_code(3) local.val_zero  by blast   
+next
+  case False
+  show ?thesis
+  proof(rule less_le_trans[of _ "Min (val ` g ` A)"])
+    have 0: "\<And>s. s \<in> val ` g ` A \<Longrightarrow> s > c" 
+    proof- fix s assume A: "s \<in> val ` g ` A"
+      then obtain a where a_def: "a \<in> A \<and> s = val (g a)"
+        by blast
+      have s_eq: "s = val (g a)"
+        using a_def by blast 
+      show "c < s"
+        using assms(3)[of a] A a_def unfolding s_eq  by blast 
+    qed
+    show "c < Min (val ` g ` A)"
+      apply(rule eint_Min_gr)
+      using assms apply blast using assms 
+      using "0" apply blast
+      using False by blast
+    show "Min (val ` g ` A) \<le> val (finsum Q\<^sub>p g A)"
+      by(rule finsum_val_ultrametric[of g A], rule assms, rule assms, rule False)
+  qed
+qed
+
+lemma Qp_diff_diff:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "d \<in> carrier Q\<^sub>p"
+  shows "(x \<ominus> c) \<ominus> (d \<ominus> c) = x \<ominus> d "
+  by (smt Qp.domain_axioms a_minus_def assms(1) assms(2) assms(3) cring.cring_simprules(10) 
+      cring.cring_simprules(19) cring.cring_simprules(3) cring.cring_simprules(4) 
+      cring.cring_simprules(7) domain.axioms(1))
+
+text\<open>This variant of the ultrametric identity formalizes the common saying that "all triangles in $\mathbb{Q}_p$ are isosceles":\<close>
+lemma Qp_isosceles:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "d \<in> carrier Q\<^sub>p"
+  assumes "val (x \<ominus> c) \<ge> v"
+  assumes "val (d \<ominus> c) \<ge> v"
+  shows "val (x \<ominus> d) \<ge> v"
+proof-
+  have "val (x \<ominus> d) \<ge> min (val (x \<ominus> c)) (val (d \<ominus> c))"
+    using assms Qp_diff_diff[of x c d]
+    by (metis Qp.domain_axioms cring.cring_simprules(4) domain.axioms(1) val_ultrametric')
+  then show ?thesis using assms 
+    by (meson dual_order.trans min_le_iff_disj)    
+qed
+
+text\<open>More variants on the ultrametric inequality\<close>
+
+lemma MinE:
+  assumes "finite (A::eint set)"
+  assumes "a = Min A"
+  assumes "b \<in> A"
+  shows "a \<le> b"
+  using assms by (simp add: assms(3))
+
+lemma MinE':
+  assumes "finite (A::eint set)"
+  assumes "a = Min A"
+  assumes "b \<in> A - {a}"
+  shows "a < b"
+proof-
+  have 0: "a \<le> b" 
+    using assms MinE by blast 
+  have 1: "a \<noteq> b" using assms by blast 
+  show ?thesis using 0 1 
+    by simp
+qed
+
+lemma MinE'':
+  assumes "finite A"
+  assumes "f \<in> A \<rightarrow> (UNIV :: eint set)"
+  assumes "a = Min (f ` A)"
+  assumes "b \<in> A"
+  shows "a \<le> f b"
+  apply(rule MinE[of "f` A"]) using assms apply blast using assms apply blast  using assms by blast
+
+lemma finsum_val_ultrametric_diff:
+  assumes "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+  assumes "finite A"
+  assumes "A \<noteq> {}"
+  assumes "\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> val (g a) \<noteq> val (g b)"
+  shows " val (finsum Q\<^sub>p g A) = Min (val ` g`A)"
+proof-
+  have "Min (val ` g ` A) \<in> val ` g ` A"
+    using Min_in[of "val ` g ` A"] assms by blast
+  then obtain a where a_def: "a \<in> A \<and> Min (val ` g`A) = val (g a)"
+    by blast 
+  have 0: "\<And>b. b \<in> A \<Longrightarrow> b \<noteq> a \<Longrightarrow> val (g b) >  val (g a)"
+    apply(rule MinE'[of "val ` g ` A"]) using assms apply blast 
+    using a_def assms apply presburger
+    using assms(4)[of a] a_def 
+    by (metis image_eqI insert_Diff insert_iff)
+  have 1: "g a \<oplus> finsum Q\<^sub>p g (A - {a}) = finsum Q\<^sub>p g (insert a (A - {a}))"
+    using assms Qp.finsum_insert[of "A - {a}" a g] a_def finite_subset[of "A - {a}" A]  by blast 
+  have 2: "finsum Q\<^sub>p g A = g a \<oplus> finsum Q\<^sub>p g (A - {a})"  
+    unfolding 1 using a_def  
+    by (metis insert_Diff_single insert_absorb)
+  have 3: "g a \<in> carrier Q\<^sub>p"
+    using a_def assms by blast 
+  show "val (finsum Q\<^sub>p g A) = Min (val ` g`A)"
+  proof(cases "A = {a}")
+    case True
+    show ?thesis using 3 Qp.finsum_empty[of g] a_def unfolding 2 unfolding True  
+      by auto       
+  next
+    case False
+    then have F0: "A - {a} \<noteq> {}"
+      using assms by blast 
+    have F1: "finsum Q\<^sub>p g (A - {a}) \<in> carrier Q\<^sub>p"
+      apply(rule Qp.finsum_closed)
+      using assms by blast 
+    have F2: "val (finsum Q\<^sub>p g (A - {a})) \<ge> Min (val ` g` (A- {a}))"
+      apply(rule finsum_val_ultrametric)
+      using assms apply blast using assms apply blast using False a_def by blast 
+    have F3: "Min (val ` g` (A- {a})) \<in> (val ` g` (A- {a}))"
+      apply(rule Min_in)
+      using assms apply blast using False a_def by blast 
+    obtain b where b_def: "b \<in> A - {a} \<and> Min (val ` g` (A- {a})) = val (g b)"
+      using F3 by blast 
+    have F4: "Min (val ` g` (A- {a})) > val (g a)"
+      using a_def assms b_def  by (metis "0" Diff_iff singletonI)
+    have F5: "val (finsum Q\<^sub>p g (A - {a})) > val (g a)"
+      using F4 F2 less_le_trans by blast  
+    then show ?thesis using 2 F1 3 
+      by (metis Qp.a_ac(2) a_def val_ultrametric_noteq)
+  qed
+qed
+
+lemma finsum_val_ultrametric_diff':
+  assumes "g \<in> A \<rightarrow> carrier Q\<^sub>p"
+  assumes "finite A"
+  assumes "A \<noteq> {}"
+  assumes "\<And>a b. a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> a \<noteq> b \<Longrightarrow> val (g a) \<noteq> val (g b)"
+  shows " val (finsum Q\<^sub>p g A) = (MIN a \<in> A. (val (g a)))"
+proof-
+  have 0: "(\<lambda> a. val (g a)) ` A = (val ` g`A)"
+    by blast 
+  show ?thesis using assms finsum_val_ultrametric_diff[of g A] unfolding 0 by blast 
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Constructing the Angular Component Maps on $\mathbb{Q}_p$\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+      (********************************************************************************************)
+      (********************************************************************************************)
+      subsubsection\<open>Unreduced Angular Component Map\<close>
+      (********************************************************************************************)
+      (********************************************************************************************)
+
+text\<open>While one can compute the residue of a $p$-adic integer mod $p^n$, this operation does not generalize to the $p$-adic field unless we restrict our attention to the valuation ring. However, we can still define the angular component maps on the field $\mathbb{Q}_p$, which allows us to take a sort of residue for any element $x \in \mathbb{Q}_p$. Given a nonzero element $x \in \mathbb{Q}_p^{\times}$, we can normalize it to obtain $p^{-ord( x)}x$ which has of valuation zero, and then computes its residue (viewed as an element of $\mathbb{Z}_p$). The resulting map agrees with the standard residue map on elements of $\mathbb{Q}_p$ of valuation zero, but not on terms of positive or negative valuation. For example, the element $p^2$ has an order $1$ residue of $0$, but its order $1$ angular component is $1$. In the formalism below, we will use the term "\texttt{angular\_component}" to refer to the unreduced normalization map $x \mapsto p^{-ord( x)}x$, and use the notation "\texttt{ac n}" to refer to the angular component which has been reduced mod $p^n$. This is line with the terminology used in \cite{denef1986}.  \<close>
+definition angular_component where 
+"angular_component a = (ac_Zp (numer a)) \<otimes>\<^bsub>Z\<^sub>p\<^esub>  (inv\<^bsub>Z\<^sub>p\<^esub> ac_Zp (denom a))"
+
+lemma ac_fract:
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "a \<in> nonzero Z\<^sub>p"
+  assumes "b \<in> nonzero Z\<^sub>p"
+  assumes "c = frac a b"
+  shows "angular_component c = (ac_Zp a)\<otimes>\<^bsub>Z\<^sub>p\<^esub> inv \<^bsub>Z\<^sub>p\<^esub>(ac_Zp b)"
+proof-
+  have "(numer c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> b = (denom c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> a"
+    by (simp add: assms(2) assms(3) assms(4) mult_comm numer_denom_swap)
+  then have "ac_Zp ((numer c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> b) = ac_Zp ((denom c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> a)"
+    by simp
+  then have "(ac_Zp (numer c)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp b) = (ac_Zp (denom c)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp a)"
+    by (metis Q\<^sub>p_def Zp.nonzero_closed Zp.numer_denom_facts(3) ac_Zp_mult assms(2) assms(3) assms(4) local.frac_closed local.numer_denom_facts(1) nonzero_fraction_imp_nonzero_numer nonzero_numer_imp_nonzero_fraction numer_denom_frac)    
+  then have "(inv \<^bsub>Z\<^sub>p\<^esub> (ac_Zp (denom c))) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp (numer c)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp b) =  (ac_Zp a)"
+    using ac_Zp_is_Unit[of "ac_Zp (denom c)"] Zp.domain_axioms inv_cancelR(1) 
+          Q\<^sub>p_def Zp.Units_closed Zp.inv_cancelR(1) Zp.m_closed Zp.nonzero_closed Zp.nonzero_memE(2) Z\<^sub>p_def ac_Zp_is_Unit assms(1) assms(2) mult_assoc padic_fields.numer_denom_facts(2) padic_fields_axioms by auto   
+  then have "(inv \<^bsub>Z\<^sub>p\<^esub> (ac_Zp (denom c))) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp (numer c))  =  (ac_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv \<^bsub>Z\<^sub>p\<^esub> (ac_Zp b)"
+    using ac_Zp_is_Unit[of "ac_Zp b"] Zp.domain_axioms inv_cancelL(2) 
+    by (smt Q\<^sub>p_def Zp.Units_inv_closed Zp.Units_r_inv Zp.nonzero_closed Zp.nonzero_memE(2) Zp.r_one Z\<^sub>p_def ac_Zp_is_Unit assms(1) assms(3) mult_assoc mult_comm padic_fields.numer_denom_facts(2) padic_fields_axioms)
+  then show ?thesis 
+    by (simp add: angular_component_def mult_comm)
+qed
+
+lemma angular_component_closed: 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "angular_component a \<in> carrier Z\<^sub>p"
+  using ac_fract assms Q\<^sub>p_def Qp.nonzero_closed Qp.nonzero_memE(2) Zp.Units_inv_closed Zp.m_closed
+      Zp.nonzero_closed Zp.nonzero_memE(2) Z\<^sub>p_def ac_Zp_is_Unit angular_component_def local.numer_denom_facts(3)
+      padic_fields.numer_denom_facts(1) padic_fields.numer_denom_facts(2) padic_fields_axioms padic_integers.ac_Zp_in_Zp padic_integers_def prime by auto
+ 
+lemma angular_component_unit: 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "angular_component a \<in> Units Z\<^sub>p"
+  using ac_fract[of a "numer a" "denom a"]  Q\<^sub>p_def Qp.nonzero_closed 
+    Qp.nonzero_memE(2) Zp.Units_inv_Units Zp.Units_m_closed 
+    Zp.nonzero_closed Zp.nonzero_memE(2) Z\<^sub>p_def ac_Zp_is_Unit 
+    angular_component_def assms local.numer_denom_facts(1) 
+    local.numer_denom_facts(2) padic_fields.numer_denom_facts(3) 
+    padic_fields_axioms by auto
+
+lemma angular_component_factors_x:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  shows "x = (\<pp>[^](ord x)) \<otimes> \<iota> (angular_component x)"
+proof-
+  have 0: "angular_component x = (ac_Zp (numer x)) \<otimes>\<^bsub>Z\<^sub>p\<^esub>  (inv\<^bsub>Z\<^sub>p\<^esub> ac_Zp (denom x))"
+    by (simp add: angular_component_def)
+  have 1:  "(numer x) = (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(ord_Zp (numer x))) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp (numer x))"
+  proof-
+    have "numer x \<in> nonzero Z\<^sub>p"
+     using assms unfolding Q\<^sub>p_def 
+     by (simp add: numer_nonzero)
+    then show ?thesis using ac_Zp_factors_x[of "numer x"]
+      by (simp add: ac_Zp_factors')
+  qed
+  have 2: "(denom x) = (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(ord_Zp (denom x))) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp (denom x))"
+  proof-
+    have "denom x \<in> nonzero Z\<^sub>p"
+      using nonzero_memE assms numer_denom_facts(2) 
+      by (simp add: Qp.nonzero_closed)
+    then show ?thesis 
+      using ac_Zp_factors_x[of "denom x"] Zp.nonzero_closed Zp.nonzero_memE(2) by auto
+  qed
+  have 3: "\<iota> (angular_component x) = frac (ac_Zp (numer x)) (ac_Zp (denom x))"
+    by (metis "0" Q\<^sub>p_def Qp.nonzero_closed Qp.nonzero_memE(2) Zp.nonzero_closed Zp.nonzero_memE(2) Zp.numer_denom_facts(2) Z\<^sub>p_def Z\<^sub>p_division_Qp_0 ac_Zp_is_Unit angular_component_closed assms local.inc_def padic_fields.numer_denom_facts(2) padic_fields.numer_denom_facts(3) padic_fields_axioms)
+  have 4: "(\<pp>[^]((ord x))) \<otimes> \<iota> (angular_component x) = 
+           (\<pp>[^]((ord_Zp (numer x)) - (ord_Zp (denom x)))) \<otimes> frac (ac_Zp (numer x)) (ac_Zp (denom x))"
+    using "3" ord_def by presburger
+  have 5: "(\<pp>[^]((ord x))) \<otimes> \<iota> (angular_component x) = 
+           frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>((ord_Zp (numer x)))) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(ord_Zp (denom x))) \<otimes> frac (ac_Zp (numer x)) (ac_Zp (denom x))"
+  proof-
+    have "(\<pp>[^]((ord_Zp (numer x)) - (ord_Zp (denom x)))) 
+        =  frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>((ord_Zp (numer x)))) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(ord_Zp (denom x)))"
+      by (metis Q\<^sub>p_def Qp.nonzero_closed Z\<^sub>p_def assms domain.nonzero_memE(1) domain.nonzero_memE(2) numer_nonzero ord_pos p_pow_diff padic_fields.numer_denom_facts(2) padic_fields_axioms padic_int_is_domain prime)             
+    then show ?thesis using 4 by metis 
+  qed
+  have 6: "(\<pp>[^]((ord x))) \<otimes> \<iota> (angular_component x) = 
+           frac (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>((ord_Zp (numer x))) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp (numer x))) (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(ord_Zp (denom x)) \<otimes>\<^bsub>Z\<^sub>p\<^esub>  (ac_Zp (denom x)))"
+    using 5 frac_mult[of "\<p>[^]\<^bsub>Z\<^sub>p\<^esub>((ord_Zp (numer x)))" " (\<p>[^]\<^bsub>Z\<^sub>p\<^esub>(ord_Zp (denom x)))" "(ac_Zp (numer x)) " " (ac_Zp (denom x))"] mult_comm 
+    by (metis "2" Q\<^sub>p_def Qp.nonzero_closed Zp.integral_iff Zp.nonzero_closed Zp.nonzero_memE(2) ac_Zp_in_Zp assms local.numer_denom_facts(2) not_nonzero_Zp numer_nonzero ord_pos p_int_pow_nonzero)
+  then show ?thesis 
+    using "1" "2" nonzero_memE assms numer_denom_facts(5) Qp.nonzero_closed by auto   
+qed
+
+lemma angular_component_mult:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  shows "angular_component (x \<otimes> y) = (angular_component  x) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (angular_component  y)"
+proof-
+  obtain a b where "a = numer x" and
+                   "b = denom x" and 
+                   a_nz: "a \<in> nonzero Z\<^sub>p" and
+                   b_nz: "b \<in> nonzero Z\<^sub>p" and
+                   x_frac: "x = frac a b"
+    using assms Qp.nonzero_memE[of x] 
+    by (meson local.numer_denom_facts(1) local.numer_denom_facts(2) 
+        local.numer_denom_facts(3) local.numer_denom_facts(5) not_nonzero_Zp)
+  obtain c d where "c = numer y" and
+                   "d = denom y" and 
+                   c_nz: "c \<in> nonzero Z\<^sub>p" and
+                   d_nz: "d \<in> nonzero Z\<^sub>p" and 
+                   y_frac: "y = frac c d"
+        using assms Qp.nonzero_memE[of y] 
+    by (meson local.numer_denom_facts(1) local.numer_denom_facts(2) local.numer_denom_facts(3) local.numer_denom_facts(5) not_nonzero_Zp)      
+  have 0: "(x \<otimes> y) = frac (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> c) (b \<otimes>\<^bsub>Z\<^sub>p\<^esub> d)"
+    using  a_nz b_nz c_nz d_nz frac_mult x_frac y_frac
+    by (simp add: Zp.nonzero_closed)
+  have 1: "angular_component (x \<otimes> y) = (ac_Zp (a \<otimes>\<^bsub>Z\<^sub>p\<^esub> c)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp (b \<otimes>\<^bsub>Z\<^sub>p\<^esub> d))"
+    by (metis (mono_tags, lifting) "0" Qp.nonzero_mult_closed Zp.integral_iff Zp.nonzero_closed Zp.nonzero_mult_closed a_nz ac_fract assms(1) assms(2) b_nz c_nz d_nz not_nonzero_Zp)   
+  have 2: "angular_component (x \<otimes> y) = (ac_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> ((ac_Zp b) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp d))"
+    by (simp add: "1" a_nz ac_Zp_mult b_nz c_nz d_nz)
+  have 3: "angular_component (x \<otimes> y) = (ac_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (ac_Zp c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp b) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp d)"
+    using 2 
+    by (simp add: Zp.inv_of_prod Zp.nonzero_closed Zp.nonzero_memE(2) ac_Zp_is_Unit b_nz d_nz mult_assoc)
+
+  have 4: "angular_component (x \<otimes> y) = (ac_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub>  inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp b) \<otimes>\<^bsub>Z\<^sub>p\<^esub>  (ac_Zp c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp d)"
+    using "3"  a_nz ac_Zp_in_Zp ac_Zp_is_Unit b_nz c_nz m_assoc mult_comm 
+          mult_assoc by auto  
+  have 5: "angular_component (x \<otimes> y) = ((ac_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub>  inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp b)) \<otimes>\<^bsub>Z\<^sub>p\<^esub> ( (ac_Zp c) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp d))"
+    using 4 by (simp add: mult_assoc) 
+  then show ?thesis 
+    by (simp add: Z\<^sub>p_def \<open>a = numer x\<close> \<open>b = denom x\<close> \<open>c = numer y\<close> \<open>d = denom y\<close>
+        padic_fields.angular_component_def padic_fields_axioms)
+qed
+
+lemma angular_component_inv:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  shows "angular_component (inv\<^bsub>Q\<^sub>p\<^esub> x) = inv\<^bsub>Z\<^sub>p\<^esub> (angular_component x)"
+  by (metis Q\<^sub>p_def Qp.one_closed Zp.Units_r_inv Zp.inv_unique' Zp.nonzero_closed Zp.nonzero_one_closed Zp.zero_not_one Z\<^sub>p_def \<iota>_def ac_Zp_is_Unit angular_component_closed angular_component_mult assms frac_nonzero_inv(1) frac_nonzero_inv(2) inc_equation inc_of_one nonzero_inverse_Qp padic_fields.ac_fract padic_fields_axioms)
+
+lemma angular_component_one: 
+"angular_component \<one> = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+  using \<iota>_def ac_Zp_one ac_fract inc_equation inc_of_one 
+    Zp.nonzero_one_closed by fastforce
+
+lemma angular_component_ord_zero:
+  assumes "ord x = 0"
+  assumes "x \<in> nonzero Q\<^sub>p"
+  shows "\<iota> (angular_component x) = x"
+proof-
+  have 0: "ord x \<ge>0"
+    using assms by auto 
+  have 1: "x \<in> nonzero Q\<^sub>p"
+  proof-
+    have "x \<noteq> \<zero>"
+      using nonzero_def assms(2)  Qp.nonzero_memE(2) by auto      
+    then show ?thesis 
+      by (simp add: assms(2))
+  qed
+  obtain a where a_def: "a \<in> nonzero Z\<^sub>p \<and> \<iota> a = x"
+    using 0 1 assms Qp_inc_id[of x] 
+    by metis
+  then have "x = frac a \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using local.inc_def Zp.nonzero_closed by blast
+  then have "angular_component x = ac_Zp a \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp \<one>\<^bsub>Z\<^sub>p\<^esub>)"
+    using ac_fract[of x a ]  "1" nonzero_memE Q\<^sub>p_def Zp.nonzero_closed Zp.nonzero_one_closed Z\<^sub>p_def a_def 
+      local.frac_closed padic_fields.ac_fract padic_fields_axioms by auto
+  then have "angular_component x = ac_Zp a \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by (simp add: ac_Zp_one)
+  then have 0: "angular_component x = ac_Zp a \<otimes>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by simp
+  have "ac_Zp a \<in> nonzero Z\<^sub>p"
+    using Zp.Units_nonzero Zp.nonzero_closed Zp.not_nonzero_memI a_def ac_Zp_is_Unit by auto
+  thus ?thesis using 0 
+    by (metis Zp.l_one Zp.nonzero_closed Zp_defs(1) Zp_defs(4) a_def ac_Zp_factors' 
+        assms(1) int_pow_0 mult_comm ord_of_inc)
+qed
+
+lemma angular_component_of_inclusion:
+  assumes "x \<in> nonzero Z\<^sub>p"
+  assumes "y = \<iota> x"
+  shows "angular_component y = ac_Zp x"
+proof-
+  have "y = local.frac x \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using assms 
+    by (simp add: Zp.nonzero_closed local.inc_def)
+  then have 0: "angular_component y = (ac_Zp x) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> ac_Zp (\<one>\<^bsub>Z\<^sub>p\<^esub>)"
+    using assms  ac_fract[of y x ] 
+    by (simp add: \<open>y = \<iota> x\<close> Zp.nonzero_closed Zp.nonzero_one_closed local.frac_closed)
+  have 1: "ac_Zp \<one>\<^bsub>Z\<^sub>p\<^esub> = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using ac_Zp_one by blast
+  have 2: "(ac_Zp x)  \<in> carrier Z\<^sub>p"
+    using Zp.Units_closed Zp.nonzero_closed ac_Zp_is_Unit assms(1) nonzero_fraction_imp_numer_not_zero nonzero_numer_imp_nonzero_fraction by auto  
+  have 3: "inv \<^bsub>Z\<^sub>p\<^esub> (ac_Zp \<one>\<^bsub>Z\<^sub>p\<^esub>) = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using 1 
+    by simp  
+  have 4: "(ac_Zp x) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> ac_Zp (\<one>\<^bsub>Z\<^sub>p\<^esub>) = (ac_Zp x) \<otimes>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using "3" by auto
+  have 5: "(ac_Zp x) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> ac_Zp (\<one>\<^bsub>Z\<^sub>p\<^esub>) = (ac_Zp x)"
+    using 4 2 Zp.domain_axioms  by simp
+  then show ?thesis 
+    by (simp add: "0")
+qed
+
+lemma res_uminus:
+  assumes "k > 0"
+  assumes "f \<in> carrier Z\<^sub>p"
+  assumes "c \<in> carrier (Zp_res_ring k)"
+  assumes "c = \<ominus>\<^bsub>Zp_res_ring k\<^esub> (f k)"
+  shows "c = ((\<ominus>\<^bsub>Z\<^sub>p\<^esub> f) k)"
+  using Z\<^sub>p_def assms(2) assms(4)  prime  Zp_residue_a_inv(1) by auto
+
+lemma ord_fract:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "ord (a \<div> b) = ord a - ord b"
+  using assms nonzero_memE nonzero_def nonzero_inverse_Qp ord_mult ord_of_inv 
+        Qp.nonzero_closed Qp.nonzero_memE(2) by presburger
+
+lemma val_fract:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "val (a \<div> b) = val a - val b"
+  apply(cases "a = \<zero>")
+   apply (simp add: Units_eq_nonzero assms(2) val_def)
+proof-
+  assume "a \<noteq> \<zero>"
+  then have 0: "a \<in> nonzero Q\<^sub>p"
+    by (simp add: Qp.nonzero_memI assms(1))
+  have 1: "(a \<div> b) \<in> nonzero Q\<^sub>p"
+    by (simp add: "0" Localization.submonoid.m_closed Qp.nonzero_is_submonoid assms(2) nonzero_inverse_Qp)
+  show ?thesis using 0 1 assms  
+    by (simp add: ord_fract)
+qed
+  
+lemma zero_fract:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "\<zero> \<div> a = \<zero>"
+  by (simp add: Units_eq_nonzero assms)
+
+lemma fract_closed:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "(a \<div> b) \<in> carrier Q\<^sub>p"
+  by (simp add: Units_eq_nonzero assms(1) assms(2))
+
+lemma val_of_power:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "val (a[^](n::nat)) = n*(val a)"
+  unfolding val_def using assms 
+  by (simp add: Qp.nonzero_memE(2) Qp_nat_pow_nonzero nonzero_nat_pow_ord)
+
+lemma val_zero_imp_val_pow_zero:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a = 0"
+  shows "val (a[^](n::nat)) = 0"
+  apply(induction n) 
+  using assms apply simp
+proof- 
+  fix n ::nat
+  assume A: "val (a [^] n) = 0"
+  have 0: "a [^] Suc n = a [^] n \<otimes> a"
+    by simp 
+  show "val (a [^] Suc n) = 0 "
+    unfolding 0 using A assms 
+    by (simp add: val_mult)
+qed
+
+text\<open>val and ord of powers of p\<close>
+
+lemma val_p_nat_pow:
+"val (\<pp>[^](k::nat)) = eint k"
+  by (simp add: ord_p_pow_nat)
+
+lemma ord_p_int_pow:
+"ord (\<pp>[^](k::int)) = k"
+  by (simp add: ord_p_pow_int)
+
+lemma ord_p_nat_pow:
+"ord (\<pp>[^](k::nat)) = k"
+  by (simp add: ord_p_pow_nat)
+
+lemma val_nonzero_frac:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  assumes "val (a \<div> b) = c"
+  shows "val a = val b + c"
+proof-
+  obtain n where n_def: "c = eint n"
+    using assms val_ord by (metis (no_types, lifting) Qp.integral Qp.nonzero_closed inv_in_frac(1) inv_in_frac(2) val_def)
+  have 0: "ord (a \<div> b) = n"
+    by (metis assms(3) eint.distinct(2) eint.inject n_def val_def)
+  have 1: "ord a - ord b = n"
+    using 0 assms by (metis ord_fract)
+  have 2: "ord a = ord b + n"
+    using 1 by presburger 
+  show "val a = val b + c"
+    unfolding n_def using 2 assms 
+    by (metis Qp.nonzero_memE(1) fract_closed local.fract_cancel_right n_def val_mult)
+qed
+
+lemma val_nonzero_frac':
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  assumes "val (a \<div> b) = 0"
+  shows "val a = val b"
+  using val_nonzero_frac[of a b 0]
+  by (metis arith_simps(50) assms(1) assms(2) assms(3))
+
+lemma equal_val_imp_equal_ord: 
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "val a = val b"
+  shows "ord a = ord b" "b \<in> nonzero Q\<^sub>p"
+  using assms 
+   apply (metis eint.inject eint.simps(3) eint_ord_simps(4) val_nonzero val_ord)
+  using assms unfolding nonzero_def 
+  using val_def by auto
+
+lemma int_pow_ord:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "ord (a[^](i::int)) = i* (ord a)"
+proof(induction i)
+  show "\<And>n. ord (a [^] int n) = int n * ord a"
+    using assms 
+    by (metis int_pow_int mult_of_nat_commute nonzero_nat_pow_ord)
+  show "\<And>n. ord (a [^] - int (Suc n)) = - int (Suc n) * ord a"
+  proof- fix n 
+    have "(a [^] - int (Suc n)) \<otimes> (a [^]  int (Suc n)) = a [^] (- int (Suc n) + int  (Suc n))"
+      using assms Qp_int_pow_add by blast
+    hence "(a [^] - int (Suc n)) \<otimes> (a [^]  int (Suc n)) = \<one>"
+      using assms 
+      by (metis ab_group_add_class.ab_left_minus int_pow_0)
+    hence "ord (a [^] - int (Suc n)) + ord (a [^]  int (Suc n)) = 0"
+      by (metis Qp_int_pow_nonzero assms ord_mult ord_one)
+    thus "ord (a [^] - int (Suc n)) = - int (Suc n) * ord a"
+      using nonzero_nat_pow_ord assms 
+      by (metis \<open>\<And>n. ord (a [^] int n) = int n * ord a\<close> add.inverse_inverse add_left_cancel more_arith_simps(4) more_arith_simps(7))
+  qed
+qed
+
+lemma int_pow_val:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "val (a[^](i::int)) = i* (val a)"
+  using int_pow_ord Qp_int_pow_nonzero assms times_eint_simps(1) val_ord by presburger
+
+lemma neg_int_pow_val:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "val (a[^]-(i::int)) = - (val (a[^]i))"
+  using int_pow_val[of a i]
+  by (metis Qp_int_pow_nonzero assms int_pow_ord mult_minus_left val_ord val_p_int_pow val_p_int_pow_neg)
+
+lemma int_pow_sum_val:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "val (a[^]((i::int) + j)) =  (val (a[^]i)) + val (a[^]j)"
+  using assms Qp.int_pow_add Qp_int_pow_nonzero Units_eq_nonzero val_mult0 by presburger
+
+lemma int_pow_diff_val:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "val (a[^]((i::int) - j)) =  (val (a[^]i)) - val (a[^]j)"
+proof-
+  obtain k where k_def: "val a = eint k"
+    using assms val_ord by blast
+  have 0: "val (a[^]((i::int) - j)) = eint ((i-j)*k)"
+    using assms k_def int_pow_val times_eint_simps(1) by presburger
+  show ?thesis unfolding 0 using k_def 
+    by (metis "0" Qp_int_pow_nonzero Rings.ring_distribs(3) assms eint.simps(1) idiff_eint_eint int_pow_ord val_ord)
+qed
+
+lemma nat_add_pow_mult_assoc:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "[(n::nat)]\<cdot>a = [n]\<cdot>\<one> \<otimes> a"
+  using assms Qp.add_pow_ldistr Qp.l_one Qp.one_closed by presburger
+
+lemma(in padic_integers) equal_res_imp_equal_ord_Zp:
+  assumes "N > 0"
+  assumes "a \<in> carrier Zp"
+  assumes "b \<in> carrier Zp"
+  assumes "a N = b N"
+  assumes "a N \<noteq> 0"
+  shows "ord_Zp a = ord_Zp b" 
+proof-
+  have "(a \<ominus> b) N = 0"
+    using assms(2) assms(3) assms(4) res_diff_zero_fact'' by blast 
+  have "ord_Zp a < N"
+    using assms zero_below_ord by force    
+  then show ?thesis 
+    by (smt R.minus_closed Zp_def \<open>(a \<ominus> b) N = 0\<close> above_ord_nonzero assms(2) assms(3) assms(4) assms(5) ord_Zp_ultrametric_eq' ord_Zp_ultrametric_eq'' padic_integers.ord_Zp_not_equal_imp_notequal(2) padic_integers.ord_of_nonzero(2) padic_integers.ord_pos padic_integers_axioms residue_of_zero(2))
+qed
+
+lemma(in padic_integers) equal_res_mod:
+  assumes "N > k"
+  assumes "a \<in> carrier Zp"
+  assumes "b \<in> carrier Zp"
+  assumes "a N = b N"
+  shows "a k = b k"
+proof-
+  have 0: "a k = a N mod p^k"
+    using assms 
+    by (metis Zp_int_inc_rep Zp_int_inc_res less_or_eq_imp_le p_residue_padic_int)
+  have 1: "b k = b N mod p^k"
+    using assms 
+    by (metis Zp_int_inc_rep Zp_int_inc_res less_or_eq_imp_le p_residue_padic_int) 
+  show ?thesis unfolding 0 1 assms  using assms by blast 
+qed
+
+lemma Qp_char_0:
+  assumes "(n::nat) \<noteq> 0"
+  shows "[n]\<cdot>\<one> \<noteq> \<zero>"
+proof-
+  have "[n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+    using Zp_char_0' assms by blast
+  thus ?thesis using inc_of_nat 
+    by (metis Qp.nat_inc_zero Zp.nat_inc_zero Zp_nat_inc_closed \<iota>_def inc_inj2)
+qed
+
+lemma Qp_char_0_int:
+  assumes "(n::int) \<noteq> 0"
+  shows "[n]\<cdot>\<one> \<noteq> \<zero>"
+proof-
+  have "[n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> \<noteq> \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+    using Zp_char_0 assms 
+    by (metis int_inc_mult linorder_neqE_linordered_idom mult_zero_l zero_less_mult_iff)    
+  thus ?thesis using inc_of_int 
+    by (metis Q\<^sub>p_def Zp_int_inc_closed \<iota>_def inc_inj1)    
+qed
+
+lemma add_int_pow_inject:
+  assumes "[(k::int)]\<cdot>\<one> = [(j::int)]\<cdot>\<one>"
+  shows "k = j"
+proof(rule ccontr)
+  assume A: "k \<noteq> j"
+  then have 0: "k - j \<noteq>0 "
+    by presburger 
+  hence 1: "[(k-j)]\<cdot>\<one> \<noteq> \<zero> "
+    using Qp_char_0_int by blast
+  hence 2: "[k]\<cdot>\<one> \<oplus> [(-j)]\<cdot> \<one>  \<noteq> \<zero> "
+    by (metis (no_types, opaque_lifting) Qp.add.int_pow_mult Qp.one_closed diff_minus_eq_add diff_zero minus_diff_eq)
+  hence 2: "[k]\<cdot>\<one> \<ominus> [j]\<cdot> \<one>  \<noteq> \<zero> "
+    by (metis Qp.add.int_pow_mult Qp.int_inc_zero Qp.one_closed assms more_arith_simps(4))
+  thus False using assms 
+    using Qp.int_inc_closed Qp.r_right_minus_eq by blast
+qed
+
+lemma val_ord_nat_inc:
+  assumes "(n::nat) > 0"
+  shows "ord ([n]\<cdot>\<one>) = val([n]\<cdot>\<one>)"
+  using val_ord assms Qp_char_0 
+  by (metis less_irrefl_nat val_def)
+
+lemma val_ord_int_inc:
+  assumes "(n::int) \<noteq> 0"
+  shows "ord ([n]\<cdot>\<one>) = val([n]\<cdot>\<one>)"
+  using val_ord assms Qp_char_0_int val_def by presburger
+
+
+      (********************************************************************************************)
+      (********************************************************************************************)
+      subsubsection\<open>Reduced Angular Component Maps\<close>
+      (********************************************************************************************)
+      (********************************************************************************************)
+  
+definition ac :: "nat \<Rightarrow> padic_number \<Rightarrow> int" where
+"ac n x = (if x = \<zero> then 0 else (angular_component x) n)"
+
+lemma ac_in_res_ring:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  shows "ac n x \<in> carrier (Zp_res_ring n)"
+  unfolding ac_def 
+  using assms angular_component_closed[of x] 
+  by (simp add: Qp.nonzero_memE(2) residues_closed)
+
+lemma ac_in_res_ring'[simp]:
+  assumes "x \<in> carrier Q\<^sub>p"
+  shows "ac n x \<in> carrier (Zp_res_ring n)"
+  apply(cases "x \<in> nonzero Q\<^sub>p")
+  using ac_in_res_ring apply blast
+  by (metis Qp.nonzero_memI ac_def assms mod_0 mod_in_carrier p_res_ring_car p_residue_alt_def)
+  
+lemma ac_mult':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "y \<in> nonzero Q\<^sub>p"
+  shows "ac n (x \<otimes> y) = (ac n x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n y)"
+  unfolding ac_def 
+proof-
+  have 0: "angular_component (x \<otimes> y) = angular_component x \<otimes>\<^bsub>Z\<^sub>p\<^esub> angular_component y"
+    using assms angular_component_mult[of x y]
+    by auto 
+  show "(if x \<otimes> y = \<zero> then 0 else angular_component (x \<otimes> y) n) =
+    (if x = \<zero> then 0 else angular_component x n) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (if y = \<zero> then 0 else angular_component y n)"
+    using assms angular_component_closed[of x] angular_component_closed[of y]
+    by (simp add: "0" Qp.integral_iff Qp.nonzero_closed Qp.nonzero_memE(2) residue_of_prod) 
+qed
+
+lemma ac_mult:
+  assumes "x \<in> carrier Q\<^sub>p"
+  assumes "y \<in> carrier Q\<^sub>p"
+  shows "ac n (x \<otimes> y) = (ac n x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n y)"
+  apply(cases "x \<in> nonzero Q\<^sub>p \<and> y \<in> nonzero Q\<^sub>p")
+  apply (simp add: ac_mult')
+  using assms unfolding ac_def 
+  by (smt Qp.integral_iff Qp.nonzero_memI residue_times_zero_l residue_times_zero_r)
+ 
+lemma ac_one[simp]:
+  assumes "n \<ge> 1"
+  shows "ac n \<one> = 1"  
+proof-
+  have "ac n \<one> = \<one>\<^bsub>Z\<^sub>p\<^esub> n"
+    unfolding ac_def
+    using angular_component_one 
+    by simp    
+  then show ?thesis 
+    using assms residue_of_one(2) by auto   
+qed
+
+lemma ac_one':
+  assumes "n > 0"
+  shows "ac n \<one> = \<one>\<^bsub>Zp_res_ring n\<^esub>"
+  using assms residue_ring_def 
+  by auto
+
+lemma ac_units:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  shows "ac n x \<in> Units (Zp_res_ring n)"
+proof-
+  obtain y where y_def: "y = inv x"
+    by simp 
+  have y_nz: "y \<in> nonzero Q\<^sub>p"
+    using assms(1) nonzero_inverse_Qp y_def 
+    by blast    
+  have 0: "ac n (x \<otimes> y) = (ac n x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n y)"
+    using ac_mult' assms(1) y_nz by blast
+  have 1: "x \<otimes> y = \<one>" 
+    by (metis Qp.field_axioms Qp.nonzero_memE Qp.nonzero_memE assms(1) field.field_inv(2) y_def)
+  have 2: "(ac n x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n y) = \<one>\<^bsub>Zp_res_ring n\<^esub>"
+    using "0" "1" ac_one' assms(2) 
+    by auto
+  show ?thesis 
+    by (metis "2" R_comm_monoid ac_in_res_ring assms(1) assms(2) comm_monoid.UnitsI(1) nonzero_inverse_Qp y_def)
+        
+qed
+
+lemma ac_inv:
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  shows "ac n (inv x) = inv\<^bsub>Zp_res_ring n\<^esub> (ac n x)"
+proof-
+  have "x \<otimes> inv x = \<one>"  
+    by (simp add: Qp.monoid_axioms Units_eq_nonzero assms(1) monoid.Units_r_inv)    
+  then have "ac n (x \<otimes> inv x) = \<one>\<^bsub>Zp_res_ring n\<^esub>"
+    by (simp add: \<open>(x \<div> x) = \<one>\<close> ac_one' assms(2))
+  then have "ac n x \<otimes>\<^bsub>Zp_res_ring n\<^esub> ac n (inv x) = \<one>\<^bsub>Zp_res_ring n\<^esub>"
+    using Units_eq_nonzero Units_inverse_Qp ac_mult' assms(1) 
+    by metis    
+  then show ?thesis 
+    by (metis R_comm_monoid ac_in_res_ring assms(1) assms(2) comm_monoid.comm_inv_char nonzero_inverse_Qp)
+qed
+
+lemma ac_inv':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  shows "ac n (inv x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n x) = \<one>\<^bsub>Zp_res_ring n\<^esub>"
+  using ac_inv[of x n] ac_units[of x n] assms 
+  by (metis (no_types, opaque_lifting) Qp.field_axioms Qp.nonzero_memE 
+      Qp.nonzero_memE Units_eq_nonzero Units_inverse_Qp ac_mult ac_one' field.field_inv(1))  
+
+lemma ac_inv'':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  shows " (ac n x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> ac n (inv x)= \<one>\<^bsub>Zp_res_ring n\<^esub>"
+  using ac_inv' assms(1) assms(2) residue_mult_comm by auto
+
+lemma ac_inv''':
+  assumes "x \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  shows "(ac n x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> ac n (inv x)= 1"
+        "ac n (inv x) \<otimes>\<^bsub>Zp_res_ring n\<^esub> (ac n x) = 1"
+  by (auto simp add: ac_inv'' ac_inv' assms(1) assms(2) p_res_ring_one)
+
+lemma ac_val:
+  assumes  "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  assumes "val a = val b"
+  assumes "val (a \<ominus> b) \<ge> val a + n" 
+  shows "ac n a = ac n b"
+proof-
+  obtain m where m_def: "m = ord a"
+    by simp 
+  have 0: "a = (\<pp>[^]m) \<otimes> \<iota> (angular_component a)"
+    by (simp add: angular_component_factors_x assms(1) m_def)
+  have 1: "b = (\<pp>[^]m) \<otimes> \<iota> (angular_component b)"
+  proof-
+    have "ord b = ord a"
+      using assms(1) assms(2) assms(3) by auto     
+    then show ?thesis 
+      by (metis angular_component_factors_x assms(2) m_def)
+  qed    
+  have 2: "(a \<ominus>b) = (\<pp>[^]m) \<otimes> \<iota> (angular_component a)
+                      \<ominus>(\<pp>[^]m) \<otimes> \<iota> (angular_component b)"
+    using "0" "1" by auto
+  have 3: "(a \<ominus>b) = (\<pp>[^]m) \<otimes>( \<iota> (angular_component a)
+                                     \<ominus> \<iota> (angular_component b))"
+    using 2 assms angular_component_closed inc_closed Qp.cring_simprules Qp.r_minus_distr
+    by (metis (no_types, lifting) p_intpow_closed(1))
+  have 4: "(a \<ominus>b) = (\<pp>[^]m) \<otimes>( \<iota> ((angular_component a)
+                                          \<ominus>\<^bsub>Z\<^sub>p\<^esub>(angular_component b)))"
+    by (simp add: "3" angular_component_closed assms(1) assms(2) inc_of_diff)    
+  have 5: "val (a \<ominus>b) = m + val (( \<iota> ((angular_component a)
+                                          \<ominus>\<^bsub>Z\<^sub>p\<^esub>(angular_component b))))"
+    by (metis "4" Zp.nonzero_one_closed angular_component_closed assms(1) assms(2)
+        cring.cring_simprules(4) frac_closed local.inc_def ord_p_pow_int p_intpow_closed(1)
+        p_intpow_closed(2) Zp.domain_axioms domain_def val_mult val_ord)
+  have 6: "m = val a"
+    using Q\<^sub>p_def assms(1) m_def by auto
+  have 7: "m + val (\<iota> (angular_component a \<ominus>\<^bsub>Z\<^sub>p\<^esub> angular_component b)) \<ge> val a + n"
+    using "5" assms(4) by presburger
+  have 8: "m + val (\<iota> (angular_component a \<ominus>\<^bsub>Z\<^sub>p\<^esub> angular_component b)) \<ge> m + n"
+    using "6" "7" 
+    by (metis plus_eint_simps(1))
+  have 9: "val (\<iota> (angular_component a \<ominus>\<^bsub>Z\<^sub>p\<^esub> angular_component b)) \<ge> n"
+    using 8 add_le_cancel_left eint_ile eint_ord_simps(1) linear plus_eint_simps(1)
+    by metis
+  have 10: "val_Zp (angular_component a \<ominus>\<^bsub>Z\<^sub>p\<^esub> angular_component b) \<ge> n"
+    using 9 
+    by (metis angular_component_closed assms(1) assms(2) cring.cring_simprules(4)
+        Zp.domain_axioms domain_def val_of_inc)
+  have 11: "(angular_component a \<ominus>\<^bsub>Z\<^sub>p\<^esub> angular_component b) n = \<zero>\<^bsub>Zp_res_ring n\<^esub>"
+    using 9 
+    by (simp add: "10" angular_component_closed assms(1) assms(2) p_res_ring_zero zero_below_val_Zp)          
+  have 12: "(angular_component a n) \<ominus>\<^bsub>Zp_res_ring n\<^esub> (angular_component b n) = \<zero>\<^bsub>Zp_res_ring n\<^esub>"
+    using "11" angular_component_closed assms(2) residue_of_diff by auto
+  have 13: "(angular_component a n) = (angular_component b n)"
+    apply(cases "n = 0")
+    apply (metis angular_component_closed assms(1) assms(2) p_res_ring_0' residues_closed)   
+    using 12 angular_component_closed residue_closed ring.ring_simprules[of "Zp_res_ring n"] 
+    by (meson assms(1) assms(2) cring_def prime residues.cring residues_n ring.r_right_minus_eq) 
+  then show ?thesis 
+    by (simp add: Qp.nonzero_memE ac_def assms(1) assms(2))
+qed
+
+lemma angular_component_nat_pow:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "angular_component (a [^] (k::nat)) = (angular_component a) [^]\<^bsub>Z\<^sub>p\<^esub> k"
+  apply(induction k)
+  apply (simp add: angular_component_one)
+  by (simp add: Qp_nat_pow_nonzero angular_component_mult assms) 
+
+lemma angular_component_int_pow:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "angular_component (a [^] (k::int)) = (angular_component a) [^]\<^bsub>Z\<^sub>p\<^esub> k"
+  apply(cases "k \<ge> 0")
+  using angular_component_nat_pow assms 
+   apply (metis int_pow_int nonneg_int_cases)
+proof-
+  assume "\<not> 0 \<le>k"
+  show "angular_component (a [^] k) = angular_component a [^] \<^bsub>Z\<^sub>p\<^esub> k"
+    using angular_component_nat_pow[of a "nat (-k)"] assms 
+        Qp_nat_pow_nonzero[of a] \<open>\<not> 0 \<le> k\<close> angular_component_inv[of "(a [^] k)"] int_pow_def2
+    by (metis angular_component_nat_pow angular_component_inv)
+qed
+
+lemma ac_nat_pow:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "ac n (a [^] (k::nat)) = (ac n a)^ k mod (p^n)"
+proof(cases "k = 0")
+  case True
+  show ?thesis apply(cases "n = 0")
+  apply (metis Group.nat_pow_0 Qp.one_closed True ac_in_res_ring' mod_self p_res_ring_0' power_0)
+  using True prime residues.one_cong residues.res_one_eq residues_n by auto
+next
+  case False
+  show ?thesis 
+    apply(cases "n = 0")
+     apply (metis Qp_nat_pow_nonzero ac_in_res_ring assms mod_by_1 p_res_ring_0' power_0)
+      using assms angular_component_nat_pow 
+      by (metis Qp.nonzero_closed Qp.nonzero_pow_nonzero Qp.not_nonzero_memI ac_def angular_component_closed neq0_conv power_residue)
+qed
+
+lemma ac_nat_pow':
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "n \<noteq>0"
+  shows "ac n (a [^] (k::nat)) = (ac n a)[^]\<^bsub>Zp_res_ring n\<^esub> k"
+proof-
+  have "(ac n a)^ k mod (p^n) = (ac n a)[^]\<^bsub>Zp_res_ring n\<^esub> k"
+    apply(induction k)
+    apply (metis Group.nat_pow_0 assms(2) prime residues.pow_cong residues_n)
+    by (metis Group.nat_pow_Suc Qp_nat_pow_nonzero ac_mult' ac_nat_pow assms(1))
+  then show ?thesis 
+    by (simp add: ac_nat_pow assms(1))
+qed
+
+lemma ac_int_pow:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "n > 0"
+  shows "ac n (a [^] (k::int)) = (ac n a)[^]\<^bsub>Zp_res_ring n\<^esub> k"
+  apply(cases "k \<ge>0") 
+  using assms ac_nat_pow' 
+  apply (metis int.lless_eq int.nat_pow_0 p_residues pow_nat residues_def)
+  using assms ac_nat_pow' ac_inv[of "a [^] k"] ac_units[of "a [^] k"]
+  by (metis Qp_nat_pow_nonzero ac_inv int_pow_def2 neq0_conv)  
+
+lemma angular_component_p:
+"angular_component \<pp> = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+proof-
+  have "\<pp> = frac \<p> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by (simp add: Zp_nat_inc_closed local.inc_def p_inc)
+  then have 0: "angular_component \<pp> = (ac_Zp \<p>) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> (ac_Zp \<one>\<^bsub>Z\<^sub>p\<^esub>)"
+    using ac_Zp_one unfolding angular_component_def 
+    by (metis Q\<^sub>p_def Qp.int_inc_closed Zp.one_nonzero Zp_int_inc_closed ac_fract 
+        local.numer_denom_facts(2) local.numer_denom_facts(5) nonzero_fraction_imp_nonzero_numer
+        nonzero_numer_imp_nonzero_fraction numer_nonzero p_nonzero)
+  then have "angular_component \<pp> = (ac_Zp \<p>) \<otimes>\<^bsub>Z\<^sub>p\<^esub> inv\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by (simp add: ac_Zp_one)
+  then have "angular_component \<pp> = (ac_Zp \<p>)"
+    by (simp add: ac_Zp_p)  
+  then show ?thesis 
+    using ac_Zp_p
+    by simp
+qed
+
+lemma angular_component_p_nat_pow:
+"angular_component (\<pp> [^] (n::nat)) = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+  apply(induction n)
+  apply (simp add: angular_component_one)
+  using angular_component_nat_pow angular_component_p nat_pow_one p_nonzero  Zp.nat_pow_one 
+  by presburger
+
+lemma angular_component_p_int_pow:
+"angular_component (\<pp> [^] (n::int)) = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+  apply(cases "n \<ge> 0")
+  apply (metis angular_component_p_nat_pow int_pow_int nonneg_int_cases)
+  using angular_component_p_nat_pow[of "nat (-n)"] angular_component_inv[of "(\<pp> [^] n)"] angular_component_inv[of "\<pp> [^] (nat (-n))"] 
+  by (metis (mono_tags, opaque_lifting) Group.nat_pow_0 Zp.inv_one add.inverse_neutral angular_component_one int_nat_eq
+      int_pow_def2 nat_0_iff nat_int nat_zminus_int p_natpow_closed(2) )
+  
+lemma ac_p_nat_pow:
+  assumes "k > 0"
+  shows "ac k (\<pp> [^] (n::nat)) = 1"
+proof-
+  have "\<not> (\<pp> [^] n) = \<zero>"
+    by (simp add: Qp.nonzero_memE)
+  have " angular_component (\<pp> [^] n) k = 1"
+    using assms angular_component_p_nat_pow[of n]  ac_def ac_one angular_component_one 
+    by auto
+  then show ?thesis 
+    unfolding ac_def using angular_component_p_nat_pow[of n] 
+    by (simp add: \<open>(\<pp> [^] n) \<noteq> \<zero>\<close>)
+qed
+
+lemma ac_p:
+  assumes "k > 0"
+  shows "ac k \<pp> = 1"
+  by (metis Qp.int_inc_closed Qp.nat_pow_eone ac_p_nat_pow assms)
+
+lemma ac_p_int_pow:
+  assumes "k > 0"
+  shows "ac k (\<pp> [^] (n::int)) = 1"
+  using Qp.nonzero_memE(2) ac_def ac_one' angular_component_one angular_component_p_int_pow
+        assms p_intpow_closed(2) p_res_ring_one by auto
+  
+lemma angular_component_p_nat_pow_factor:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "angular_component ((\<pp> [^] (n::nat)) \<otimes> a) = angular_component a"
+proof-
+  have 0: "angular_component ((\<pp> [^] n) \<otimes> a) = angular_component (\<pp> [^] n) \<otimes>\<^bsub>Z\<^sub>p\<^esub> angular_component a"
+    using assms angular_component_mult[of "(\<pp> [^] (n::nat))" a] p_natpow_closed(2) 
+    by blast
+  have 1: "angular_component (\<pp> [^] n) = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    by (simp add: angular_component_p_nat_pow)
+  have 2: "angular_component ((\<pp> [^] n) \<otimes> a) = \<one>\<^bsub>Z\<^sub>p\<^esub> \<otimes>\<^bsub>Z\<^sub>p\<^esub> angular_component a"
+    by (simp add: "0" "1")
+  then show ?thesis using angular_component_closed[of a] assms Zp.domain_axioms
+    by (simp add: assms cring.cring_simprules(12) domain.axioms(1))
+qed
+
+lemma ac_p_nat_pow_factor:
+  assumes "m > 0"
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "ac m ((\<pp> [^] (n::nat)) \<otimes> a) = ac m a"
+  using angular_component_p_nat_pow_factor assms  ac_def 
+  by (metis (no_types, lifting) Qp.field_axioms Qp_nat_pow_nonzero Qp.nonzero_memE 
+      Qp.nonzero_memE Ring.integral p_nonzero)
+  
+lemma angular_component_p_nat_pow_factor_right:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "angular_component (a \<otimes> (\<pp> [^] (n::nat))) = angular_component a"
+proof-
+  have "((\<pp> [^] (n::nat)) \<otimes> a) = (a \<otimes> (\<pp> [^] (n::nat)))"
+    using assms Qp.domain_axioms domain_def 
+    by (simp add: assms domain_def Qp.nonzero_memE cring.cring_simprules(14))
+  then show ?thesis 
+    using angular_component_p_nat_pow_factor[of a n] 
+    by (simp add: assms)
+qed
+
+lemma ac_p_nat_pow_factor_right:
+  assumes "m > 0"
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "ac m (a \<otimes> (\<pp> [^] (n::nat))) = ac m a"
+  using assms angular_component_p_nat_pow_factor_right[of a n] 
+  unfolding ac_def 
+  by (metis Qp.integral Qp.l_null Qp.not_nonzero_memE Qp.not_nonzero_memI
+      angular_component_p_nat_pow_factor_right p_natpow_closed(1) p_natpow_closed(2))
+
+lemma angular_component_p_int_pow_factor:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "angular_component ((\<pp> [^] (n::int)) \<otimes> a) = angular_component a"
+  by (metis Qp.integral_iff Qp.l_one Qp.nonzero_memI Qp.one_nonzero angular_component_mult
+      angular_component_one angular_component_p_int_pow assms p_intpow_closed(1) p_intpow_closed(2))
+  
+lemma ac_p_int_pow_factor:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  shows "ac m ((\<pp> [^] (n::int)) \<otimes> a) = ac m a"
+  apply(cases "m = 0")
+   apply (metis (no_types, lifting) Qp.integral Qp.nonzero_closed Qp.nonzero_memE(2) 
+          ac_def angular_component_p_int_pow_factor assms p_intpow_closed(2))
+  using assms angular_component_p_int_pow_factor[of a n]
+  by (metis (no_types, lifting) Qp.integral Qp.nonzero_closed Qp.not_nonzero_memI ac_def 
+      p_intpow_closed(2))
+
+lemma angular_component_p_int_pow_factor_right:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "angular_component (a \<otimes> (\<pp> [^] (n::int))) = angular_component a"
+  using Qp.m_comm angular_component_p_int_pow_factor assms p_intpow_closed(1) by auto
+
+lemma ac_p_int_pow_factor_right:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "ac m (a \<otimes> (\<pp> [^] (n::int))) = ac m a"
+  using assms angular_component_p_int_pow_factor_right unfolding ac_def 
+  using Qp.integral_iff Qp.nonzero_memE(2) p_intpow_closed(1) p_intpow_closed(2) by presburger
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>An Inverse for the inclusion map $\iota$\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition to_Zp where 
+"to_Zp a = (if (a \<in> \<O>\<^sub>p) then (SOME x. x \<in> carrier Z\<^sub>p \<and> \<iota> x = a) else \<zero>\<^bsub>Z\<^sub>p\<^esub>)"
+
+lemma to_Zp_closed:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "to_Zp a \<in> carrier Z\<^sub>p"
+  apply(cases "a \<in> \<O>\<^sub>p")
+  using assms unfolding to_Zp_def \<iota>_def 
+  apply (smt image_iff tfl_some)
+    by simp
+
+lemma to_Zp_inc: 
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "\<iota> (to_Zp a) = a"
+proof-
+  obtain c where c_def: "c = (SOME x. x \<in> carrier Z\<^sub>p \<and> \<iota> x = a)"
+    by simp
+  have "(\<exists> x. x \<in> carrier Z\<^sub>p \<and> \<iota> x = a)"
+    using assms(1) 
+    by blast
+  then  have "c \<in> carrier Z\<^sub>p \<and> \<iota> c = a"
+    using c_def 
+    by (metis (mono_tags, lifting)  tfl_some)
+  then show "\<iota> (to_Zp a) = a" 
+    using to_Zp_def c_def assms(1) 
+    by auto 
+qed
+
+lemma inc_to_Zp: 
+ assumes "b \<in> carrier Z\<^sub>p"
+ shows "to_Zp (\<iota> b) = b"
+proof-
+  have "\<iota> (to_Zp (\<iota> b)) = (\<iota> b)"
+    using assms to_Zp_inc[of "\<iota> b"]
+    by blast
+  then show ?thesis 
+    using inc_inj2[of b "to_Zp (\<iota> b)"] assms to_Zp_closed inc_closed 
+    unfolding \<iota>_def Q\<^sub>p_def 
+    by auto      
+qed
+
+lemma to_Zp_add: 
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "to_Zp (a \<oplus> b) = to_Zp a \<oplus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp b)"
+  by (metis (no_types, lifting) Zp.domain_axioms assms(1) assms(2)
+      cring.cring_simprules(1) domain.axioms(1) imageE inc_of_sum inc_to_Zp)
+
+lemma to_Zp_mult: 
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "to_Zp (a \<otimes> b) = to_Zp a \<otimes>\<^bsub>Z\<^sub>p\<^esub> (to_Zp b)"
+proof-
+  have "(a \<otimes> b) \<in> \<O>\<^sub>p"
+    by (simp add: val_ring_subring assms(1) assms(2) subringE(6))
+  then have 
+    "\<iota> ((to_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (to_Zp) b) =  ((\<iota> (to_Zp a)) \<otimes> (\<iota> (to_Zp b)))"
+    using assms(1) assms(2) inc_of_prod inc_to_Zp 
+    by auto
+  then have "\<iota> ((to_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (to_Zp) b) =  a \<otimes>b"
+    by (simp add: assms(1) assms(2) to_Zp_inc)
+  then have "to_Zp ( \<iota> ((to_Zp a) \<otimes>\<^bsub>Z\<^sub>p\<^esub> (to_Zp) b)) = to_Zp (a \<otimes>b)"
+    by simp
+  then show ?thesis 
+    by (metis (no_types, opaque_lifting) Zp.domain_axioms val_ring_subring assms(1) assms(2) 
+        cring.cring_simprules(5) domain.axioms(1) inc_to_Zp subringE(1) subset_iff to_Zp_closed)
+qed
+
+lemma to_Zp_minus:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "to_Zp (a \<ominus> b) = to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp b)"
+  by (metis (no_types, lifting) Zp.domain_axioms assms(1) assms(2) cring_def domain.axioms(1)
+      image_iff inc_of_diff inc_to_Zp ring.ring_simprules(4))
+
+lemma to_Zp_one: 
+  shows "to_Zp \<one> = \<one>\<^bsub>Z\<^sub>p\<^esub>"
+  using Zp_def Zp.one_closed \<iota>_def inc_of_one inc_to_Zp padic_integers_axioms 
+  by fastforce
+
+lemma to_Zp_zero: 
+  shows "to_Zp \<zero> = \<zero>\<^bsub>Z\<^sub>p\<^esub>"
+  using Q\<^sub>p_def Zp_def Zp.domain_axioms \<iota>_def domain_frac.inc_inj1 inc_to_Zp 
+        padic_integers_axioms to_Zp_def domain_frac_axioms by fastforce
+
+lemma to_Zp_ominus:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "to_Zp (\<ominus> a) = \<ominus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp a)"
+proof-
+  have "\<ominus>a \<in> \<O>\<^sub>p"
+    by (simp add: val_ring_subring assms subringE(5))
+  then show ?thesis 
+    by (metis (no_types, lifting) Zp.domain_axioms Zp.nonzero_one_closed assms
+        cring.cring_simprules(3) domain.axioms(1) frac_uminus image_iff inc_to_Zp local.inc_def)
+qed
+
+lemma to_Zp_val:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "val_Zp (to_Zp a) = val a"
+  by (metis assms imageE inc_to_Zp val_of_inc)
+
+lemma val_of_nat_inc:
+"val ([(k::nat)]\<cdot>\<one>) \<ge> 0"
+proof-
+  have "[(k::nat)]\<cdot>\<one> \<in> \<O>\<^sub>p"
+    by (metis Zp.one_closed Zp_nat_mult_closed image_eqI inc_of_nat)
+  thus ?thesis 
+    using val_ring_memE(1) by blast
+qed
+
+lemma val_of_int_inc:
+"val ([(k::int)]\<cdot>\<one>) \<ge> 0"
+proof-
+  have "\<iota> ([k] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) = [k]\<cdot>\<one>"
+    using inc_of_int by blast
+  hence "[k]\<cdot>\<one> \<in> \<O>\<^sub>p"
+    using Zp.one_closed Zp_nat_mult_closed image_eqI inc_of_int 
+    by blast    
+  thus ?thesis 
+    using val_ring_memE(1) by blast
+qed
+
+lemma to_Zp_nat_inc:
+"to_Zp ([(a::nat)]\<cdot>\<one>) = [a]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one> \<^bsub>Z\<^sub>p\<^esub>"
+  apply(induction a)
+  using Qp.nat_inc_zero Zp.nat_inc_zero to_Zp_zero apply presburger
+proof-
+  fix a::nat assume A: "to_Zp ([a] \<cdot> \<one>) = [a] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+  have 0: "[(Suc a)]\<cdot>\<one> = [a]\<cdot>\<one> \<oplus> \<one>"
+    using Qp.add.nat_pow_Suc by blast
+  have 1: "[a]\<cdot>\<one> \<in> \<O>\<^sub>p"
+    using Qp.nat_inc_closed val_of_nat_inc val_ring_memI by blast
+  have 2: "to_Zp ([Suc a] \<cdot> \<one>) = (to_Zp ([a]\<cdot>\<one>)) \<oplus>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using A 1 unfolding 0 
+    by (metis Zp.cring_simprules(6) Zp.nat_inc_closed inc_of_nat inc_of_one inc_of_sum inc_to_Zp sum_closed)
+  show "to_Zp ([Suc a] \<cdot> \<one>) = [Suc a] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>"
+    unfolding  2 A 
+    using add_comm nat_suc by presburger
+qed
+
+lemma to_Zp_int_neg:
+"to_Zp ([(-int (a::nat))]\<cdot>\<one>) = \<ominus>\<^bsub>Z\<^sub>p\<^esub>([int a]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one> \<^bsub>Z\<^sub>p\<^esub>)"
+proof-
+  have 0: "[(-int (a::nat))]\<cdot>\<one> = \<ominus> ([int a]\<cdot>\<one>)"
+    using Qp.add.int_pow_neg by blast
+  have 1: "[int a]\<cdot>\<one> \<in> \<O>\<^sub>p"
+    using Qp.int_inc_closed val_of_int_inc val_ring_memI by blast
+  show ?thesis using 1 unfolding 0 
+    by (metis Zp.int_inc_closed inc_of_int inc_to_Zp to_Zp_ominus)
+qed
+
+lemma(in ring) int_add_pow:
+"[int n] \<cdot> \<one> = [n]\<cdot>\<one>"
+  unfolding add_pow_def 
+  by (simp add: int_pow_int)
+
+lemma int_add_pow:
+"[int n] \<cdot> \<one> = [n]\<cdot>\<one>"
+  unfolding add_pow_def 
+  by (simp add: int_pow_int)
+
+lemma Zp_int_add_pow:
+"[int n] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> = [n]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>"
+  unfolding add_pow_def 
+  by (simp add: int_pow_int)
+
+lemma to_Zp_int_inc:
+"to_Zp ([(a::int)]\<cdot>\<one>) = ([a]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one> \<^bsub>Z\<^sub>p\<^esub>)"
+  apply(induction a)
+  unfolding int_add_pow Zp_int_add_pow
+    using to_Zp_nat_inc apply blast
+    unfolding to_Zp_int_neg using  Zp.add.int_pow_neg Zp.one_closed 
+    by presburger
+
+lemma to_Zp_nat_add_pow:
+  assumes "a \<in> \<O>\<^sub>p"
+  shows "to_Zp ([(n::nat)]\<cdot>a) = [n]\<cdot>\<^bsub>Z\<^sub>p\<^esub> to_Zp a"
+  apply( induction n)
+  using Qp.nat_mult_zero Zp_nat_inc_zero to_Zp_zero apply presburger
+proof- fix n::nat assume A: "to_Zp ([n] \<cdot> a) = [n] \<cdot>\<^bsub>Z\<^sub>p\<^esub> to_Zp a"
+  have 0: "[Suc n] \<cdot> a = [n]\<cdot>a \<oplus> a"
+    using Qp.add.nat_pow_Suc by blast
+  have 1: "to_Zp ([n] \<cdot> a \<oplus> a) = to_Zp ([n] \<cdot> a) \<oplus>\<^bsub>Z\<^sub>p\<^esub> to_Zp a"
+    apply(rule to_Zp_add[of "[n]\<cdot>a" a] )
+    apply( induction n) 
+    using Qp.nat_mult_zero zero_in_val_ring apply blast
+    unfolding Qp.add.nat_pow_Suc by(rule val_ring_add_closed, blast, rule assms, rule assms)
+  show "to_Zp ([Suc n] \<cdot> a) = [Suc n] \<cdot>\<^bsub>Z\<^sub>p\<^esub> to_Zp a "
+    unfolding Qp.add.nat_pow_Suc Zp.add.nat_pow_Suc 1 A by blast 
+qed
+
+lemma val_ring_res:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  shows "to_Zp (a \<ominus> b) N = to_Zp a N \<ominus>\<^bsub>Zp_res_ring N\<^esub> to_Zp b N"
+proof-
+  have "to_Zp (a \<ominus> b) N = (to_Zp a \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp b) N"
+    using assms to_Zp_minus by presburger
+  then show ?thesis using assms residue_of_diff to_Zp_closed val_ring_memE(2)
+    by (simp add: val_ring_memE(1))
+qed
+
+lemma res_diff_in_val_ring_imp_in_val_ring:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "a \<ominus> b \<in> \<O>\<^sub>p"
+  shows "b \<in> \<O>\<^sub>p"
+proof-
+  have "b = a \<ominus> (a \<ominus> b)"
+    unfolding a_minus_def 
+    using assms val_ring_memE(2)[of a] Qp.r_neg2 Q\<^sub>p_def Qp.minus_sum by auto
+  thus ?thesis  using assms val_ring_minus_closed[of a "a \<ominus> b"]
+    by presburger
+qed
+
+lemma(in padic_fields) equal_res_imp_res_diff_zero:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "to_Zp a N = to_Zp b N"
+  shows "to_Zp (a \<ominus> b) N = 0"
+  using val_ring_res[of a b] assms 
+  by (metis res_diff_zero_fact' to_Zp_closed val_ring_memE(2))
+
+lemma(in padic_fields) equal_res_imp_val_diff_bound:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "to_Zp a N = to_Zp b N"
+  shows "val (a \<ominus> b) \<ge> N"
+  using assms equal_res_imp_res_diff_zero[of a b N]
+  by (metis to_Zp_closed to_Zp_minus to_Zp_val val_Zp_dist_def val_Zp_dist_res_eq2 val_ring_memE(2) val_ring_minus_closed) 
+  
+lemma(in padic_fields) equal_res_equal_val:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "val a < N"
+  assumes "to_Zp a N = to_Zp b N"
+  shows "val a = val b"
+proof-
+  have "val (a \<ominus> b) \<ge> N"
+    using assms equal_res_imp_val_diff_bound by blast 
+  then have "val (a \<ominus> b) > val a"
+    using assms less_le_trans by blast
+  then show "val a = val b"
+    using assms by (meson ultrametric_equal_eq' val_ring_memE)
+qed
+
+lemma(in padic_fields) val_ring_equal_res_imp_equal_val:
+  assumes "a \<in> \<O>\<^sub>p"
+  assumes "b \<in> \<O>\<^sub>p"
+  assumes "val a < eint N"
+  assumes "val b < eint N"
+  assumes "to_Zp a N = to_Zp b N"
+  shows "val a = val b"
+proof-
+  have "val_Zp (to_Zp (a \<ominus> b)) \<ge> N"
+    using assms val_ring_memE to_Zp_closed to_Zp_minus val_Zp_dist_def val_Zp_dist_res_eq2 by presburger
+  thus ?thesis 
+    by (meson assms(1) assms(2) assms(3) assms(5) equal_res_equal_val) 
+qed
+
+end
+end
diff --git a/thys/Padic_Field/Padic_Semialgebraic_Function_Ring.thy b/thys/Padic_Field/Padic_Semialgebraic_Function_Ring.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Padic_Semialgebraic_Function_Ring.thy
@@ -0,0 +1,6503 @@
+theory Padic_Semialgebraic_Function_Ring
+  imports Padic_Field_Powers
+begin
+
+section\<open>Rings of Semialgebraic Functions\<close>
+
+text\<open>
+  In order to efficiently formalize Denef's proof of Macintyre's theorem, it is necessary to be 
+  able to reason about semialgebraic functions algebraically. For example, we need to consider 
+  polynomials in one variable whose coefficients are semialgebraic functions, and take their 
+  Taylor expansions centered at a semialgebraic function. To facilitate this kind of reasoning, it
+  is necessary to construct, for each arity $m$, a ring \texttt{SA(m)} of semialgebraic functions in
+  $m$ variables. These functions must be extensional functions which are undefined outside of the 
+  carrier set of $\mathbb{Q}_p^m$. 
+
+  The developments in this theory are mainly lemmas and defintitions which build the necessary 
+  theory to prove the cell decomposition theorems of \cite{denef1986}, and finally Macintyre's 
+  Theorem, which says that semi-algebraic sets are closed under projections. 
+\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Some eint Arithmetic\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context padic_fields
+begin
+
+lemma eint_minus_ineq':
+  assumes "a \<le> eint N"
+  assumes "b - a \<le> c"
+  shows "b - eint N \<le> c"
+  using assms by(induction c, induction b, induction a, auto )
+
+lemma eint_minus_plus:
+"a - (eint b + eint c) = a - eint b - eint c"
+  apply(induction a)
+  apply (metis diff_add_eq_diff_diff_swap idiff_eint_eint plus_eint_simps(1) semiring_normalization_rules(24))
+  using idiff_infinity by presburger
+
+lemma eint_minus_plus':
+"a - (eint b + eint c) = a - eint c - eint b"
+  by (metis add.commute eint_minus_plus)  
+
+lemma eint_minus_plus'':
+  assumes "a - eint c - eint b = eint f"
+  shows "a - eint c - eint f =  eint b"
+  using assms  apply(induction a ) 
+  apply (metis add.commute add_diff_cancel_eint eint.distinct(2) eint_add_cancel_fact)
+  by simp
+
+lemma uminus_involutive[simp]:
+"-(-x::eint) = x"
+  apply(induction x)
+  unfolding uminus_eint_def by auto
+
+lemma eint_minus:
+"(a::eint) - (b::eint) = a + (-b)"
+  apply(induction a)
+   apply(induction b)
+proof -
+  fix int :: int and inta :: int
+  have "\<forall>e ea. (ea::eint) + (e + - ea) = ea - ea + e"
+    by (simp add: eint_uminus_eq)
+  then have "\<forall>i ia. eint (ia + i) + - eint ia = eint i"
+    by (metis ab_group_add_class.ab_diff_conv_add_uminus add.assoc add_minus_cancel idiff_eint_eint plus_eint_simps(1))
+  then show "eint inta - eint int = eint inta + - eint int"
+    by (metis ab_group_add_class.ab_diff_conv_add_uminus add.commute add_minus_cancel idiff_eint_eint)
+next
+  show "\<And>int. eint int - \<infinity> = eint int + - \<infinity>"
+  by (metis eint_uminus_eq i0_ne_infinity idiff_infinity_right idiff_self plus_eq_infty_iff_eint uminus_involutive)
+  show " \<infinity> - b = \<infinity> + - b"
+    apply(induction b)
+  apply simp
+    by auto  
+qed
+
+lemma eint_mult_Suc:
+   "eint (Suc k) * a = eint k * a + a"
+  apply(induction a)
+  apply (metis add.commute eSuc_eint mult_eSuc' of_nat_Suc)
+  using plus_eint_simps(3) times_eint_simps(4) 
+  by presburger
+
+lemma eint_mult_Suc_mono:
+assumes "a \<le> eint b \<longrightarrow> eint (int k) * a \<le> eint (int k) * eint b"
+shows "a \<le> eint b \<longrightarrow> eint (int (Suc k)) * a \<le> eint (int (Suc k)) * eint b"
+  using assms eint_mult_Suc 
+  by (metis add_mono_thms_linordered_semiring(1))
+
+lemma eint_nat_mult_mono:
+  assumes "(a::eint) \<le> b"
+  shows "eint (k::nat)*a \<le> eint k*b"
+proof-
+  have "(a::eint) \<le> b \<longrightarrow> eint (k::nat)*a \<le> eint k*b"
+    apply(induction k) apply(induction b)
+  apply (metis eint_ile eq_iff mult_not_zero of_nat_0 times_eint_simps(1))
+  apply simp
+ apply(induction b) 
+    using eint_mult_Suc_mono apply blast
+  using eint_ord_simps(3) times_eint_simps(4) by presburger
+  thus ?thesis using assms by blast 
+qed
+
+lemma eint_Suc_zero:
+"eint (int (Suc 0)) * a = a"
+  apply(induction a)
+  apply simp
+  by simp
+
+lemma eint_add_mono:
+  assumes "(a::eint) \<le> b"
+  assumes "(c::eint) \<le> d"
+  shows "a + c \<le> b + d"
+  using assms 
+  by (simp add: add_mono)
+
+lemma eint_nat_mult_mono_rev:
+  assumes "k > 0"
+  assumes "eint (k::nat)*a \<le> eint k*b" 
+  shows "(a::eint) \<le> b"
+proof(rule ccontr)
+  assume "\<not> a \<le> b"
+  then have A: "b < a"
+    using leI by blast
+  have "b < a \<longrightarrow> eint (k::nat)*b < eint k*a"
+    apply(induction b) apply(induction a)
+      using A assms eint_ord_simps(2) times_eint_simps(1) zmult_zless_mono2_lemma apply presburger
+    using eint_ord_simps(4) nat_mult_not_infty times_eint_simps(4) apply presburger
+    using eint_ord_simps(6) by blast
+  then have "eint (k::nat)*b < eint k*a" 
+    using A by blast 
+  hence "\<not> eint (k::nat)*a \<le> eint k*b"
+    by (metis \<open>\<not> a \<le> b\<close> antisym eint_nat_mult_mono linear neq_iff)   
+  then show False using assms by blast 
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Lemmas on Function Ring Operations\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma Qp_funs_is_cring:
+"cring (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  using F.cring by blast 
+
+lemma Qp_funs_is_monoid:
+"monoid (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  using F.is_monoid by blast
+  
+lemma Qp_funs_car_memE:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  shows "f \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<rightarrow> (carrier Q\<^sub>p)"
+  by (simp add: assms ring_pow_function_ring_car_memE(2))
+  
+lemma Qp_funs_car_memI:
+  assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  assumes "\<And>x. x \<notin> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<Longrightarrow> g x = undefined"
+  shows "g \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+apply(rule Qp.function_ring_car_memI)
+  using assms  apply blast
+  using assms by blast  
+
+lemma Qp_funs_car_memI':
+  assumes "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  assumes "restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = g"
+  shows "g \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  apply(intro Qp_funs_car_memI assms)
+  using assms  unfolding restrict_def 
+  by (metis (mono_tags, lifting)) 
+
+lemma Qp_funs_car_memI'':
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  assumes "g = (\<lambda> x \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)). f x)"
+  shows "g \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  apply(rule Qp_funs_car_memI)
+  using assms 
+  apply (meson restrict_Pi_cancel)
+  by (metis assms(2) restrict_def)
+
+lemma Qp_funs_one:
+"\<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). \<one>)"
+  unfolding function_ring_def function_one_def 
+  by (meson monoid.select_convs(2))
+
+lemma Qp_funs_zero:
+"\<zero>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). \<zero>\<^bsub>Q\<^sub>p\<^esub>)"
+  unfolding function_ring_def function_zero_def 
+  by (meson ring_record_simps(11))
+
+lemma Qp_funs_add:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<rightarrow> carrier Q\<^sub>p"
+  assumes "g \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<rightarrow> carrier Q\<^sub>p"
+  shows "(f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = f x \<oplus>\<^bsub>Q\<^sub>p\<^esub> g x"
+  using assms function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" "Q\<^sub>p"] 
+  unfolding function_add_def  
+  by (metis (mono_tags, lifting) restrict_apply' ring_record_simps(12))
+
+lemma Qp_funs_add':
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "g \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = f x \<oplus>\<^bsub>Q\<^sub>p\<^esub> g x"
+  using assms Qp_funs_add Qp_funs_car_memE
+  by blast 
+
+lemma Qp_funs_add'':
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "g \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x \<oplus>\<^bsub>Q\<^sub>p\<^esub> g x)"
+  unfolding function_ring_def function_add_def using ring_record_simps(12)
+  by metis 
+
+lemma Qp_funs_add''':
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = f x \<oplus>\<^bsub>Q\<^sub>p\<^esub> g x"
+  using assms function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" "Q\<^sub>p"] 
+  unfolding function_add_def  
+  by (metis (mono_tags, lifting) restrict_apply' ring_record_simps(12))
+
+lemma Qp_funs_mult:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<rightarrow> carrier Q\<^sub>p"
+  assumes "g \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<rightarrow> carrier Q\<^sub>p"
+  shows "(f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = f x \<otimes> g x"
+  using assms function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" "Q\<^sub>p"] 
+  unfolding function_mult_def  
+  by (metis (no_types, lifting) monoid.select_convs(1) restrict_apply')
+
+lemma Qp_funs_mult':
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "g \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = f x \<otimes> g x"
+  using assms Qp_funs_mult Qp_funs_car_memE
+  by blast
+
+lemma Qp_funs_mult'':
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "g \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x \<otimes> g x)"
+  unfolding function_ring_def function_mult_def using ring_record_simps(5) 
+  by metis 
+
+lemma Qp_funs_mult''':
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = f x \<otimes> g x"
+  using assms function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" "Q\<^sub>p"] 
+  unfolding function_mult_def  
+  by (metis (mono_tags, lifting) monoid.select_convs(1) restrict_apply')
+
+lemma Qp_funs_a_inv:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = \<ominus> (f x)"
+  using assms local.function_uminus_eval 
+  by (simp add: local.function_uminus_eval'')
+    
+lemma Qp_funs_a_inv':
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). \<ominus> (f x))"
+proof fix x 
+  show "(\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). \<ominus> f x) x"
+    apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+     apply (metis (no_types, lifting) Qp_funs_a_inv assms restrict_apply')
+  by (simp add: assms local.function_ring_not_car)
+qed
+
+abbreviation(input) Qp_const ("\<cc>\<^bsub>_\<^esub>_") where
+"Qp_const n c \<equiv> constant_function (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) c"
+
+lemma Qp_constE: 
+  assumes "c \<in> carrier Q\<^sub>p"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "Qp_const n c x = c"
+  using assms unfolding constant_function_def 
+  by (meson restrict_apply')
+
+lemma Qp_funs_Units_memI:
+  assumes "f \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow>  f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+  shows "f \<in> (Units (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+        "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). inv\<^bsub>Q\<^sub>p\<^esub> (f x))"
+proof-
+  obtain g where g_def: "g = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). inv\<^bsub>Q\<^sub>p\<^esub> (f x))"
+    by blast 
+  have g_closed: "g \<in> (carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+    by(rule Qp_funs_car_memI, unfold  g_def, auto,  
+            intro field_inv(3) assms Qp.function_ring_car_memE[of _ n], auto ) 
+  have "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> f x \<otimes> g x = \<one>"
+    using assms g_def 
+    by (metis (no_types, lifting) Qp.function_ring_car_memE field_inv(2) restrict_apply)   
+  then have 0: "f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g = \<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>"
+    using assms g_def Qp_funs_mult''[of f n g] Qp_funs_one[of n] g_closed 
+    by (metis (no_types, lifting) restrict_ext)
+  then show "f \<in> (Units (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+    using comm_monoid.UnitsI[of "Fun\<^bsub>n\<^esub> Q\<^sub>p"] assms(1) g_closed local.F.comm_monoid_axioms by presburger  
+  have "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = g"
+    using g_def g_closed 0 cring.invI[of "Fun\<^bsub>n\<^esub> Q\<^sub>p"] Qp_funs_is_cring assms(1) 
+    by presburger
+  show "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). inv\<^bsub>Q\<^sub>p\<^esub> (f x))"
+    using assms g_def 0  \<open>inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = g\<close> 
+    by blast
+qed
+
+lemma Qp_funs_Units_memE:
+  assumes "f \<in> (Units (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = \<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>"
+        "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = \<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>"
+        "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow>  f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+  using monoid.Units_r_inv[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" f ] assms  Qp_funs_is_monoid 
+    apply blast
+  using monoid.Units_l_inv[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" f ] assms  Qp_funs_is_monoid 
+    apply blast
+proof-
+  obtain g where g_def: "g = inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f"
+    by blast 
+  show "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow>  f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+  proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    have "f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g = \<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>"
+      using assms g_def Qp_funs_is_monoid 
+        \<open>\<lbrakk>Group.monoid (Fun\<^bsub>n\<^esub> Q\<^sub>p); f \<in> Units (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<rbrakk> \<Longrightarrow> f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = \<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>\<close> 
+      by blast
+    then have 0: "f x \<otimes> g x = \<one>"
+      using A assms g_def Qp_funs_mult'[of x n f g] Qp_funs_one[of n] 
+      by (metis Qp_funs_is_monoid monoid.Units_closed monoid.Units_inv_closed restrict_apply)
+    have 1: "g x \<in> carrier Q\<^sub>p"
+      using g_def A assms local.function_ring_car_closed by auto      
+    then show "f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+      using 0 
+      by (metis Qp.l_null local.one_neq_zero)      
+  qed
+qed
+  
+lemma Qp_funs_m_inv:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> (Units (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "(inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = inv\<^bsub>Q\<^sub>p\<^esub> (f x)"
+  using Qp_funs_Units_memI(2)  Qp_funs_Units_memE(3) assms 
+  by (metis (no_types, lifting) Qp_funs_is_monoid monoid.Units_closed restrict_apply)
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Defining the Rings of Semialgebraic Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition semialg_functions  where
+"semialg_functions n  = {f \<in> (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<rightarrow> carrier Q\<^sub>p. is_semialg_function n f \<and> f = restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))}"
+
+lemma semialg_functions_memE: 
+  assumes "f \<in> semialg_functions n"
+  shows "is_semialg_function n f"
+        "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+        "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  using semialg_functions_def assms apply blast 
+  apply(rule Qp_funs_car_memI')
+  using assms 
+  apply (metis (no_types, lifting) mem_Collect_eq semialg_functions_def)
+  using assms unfolding semialg_functions_def 
+   apply (metis (mono_tags, lifting) mem_Collect_eq)
+  by (metis (no_types, lifting) assms mem_Collect_eq semialg_functions_def)
+
+lemma semialg_functions_in_Qp_funs:
+"semialg_functions n \<subseteq> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  using semialg_functions_memE 
+  by blast
+
+lemma semialg_functions_memI:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  assumes "is_semialg_function n f"
+  shows "f \<in> semialg_functions n"
+  using assms unfolding semialg_functions_def 
+  by (metis (mono_tags, lifting) Qp_funs_car_memI function_ring_car_eqI 
+      is_semialg_function_closed mem_Collect_eq restrict_Pi_cancel restrict_apply)
+
+lemma restrict_is_semialg:
+  assumes "is_semialg_function n f"
+  shows "is_semialg_function n (restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)))"
+proof(rule is_semialg_functionI)
+  show 0: "restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+    using assms is_semialg_function_closed by blast
+  show "\<And>k S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (n + k) (partial_pullback n (restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) k S)"
+  proof- fix k S assume A: "S \<in> semialg_sets (1 + k)"
+    have "(partial_pullback n (restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) k S) = partial_pullback n f k S"
+      apply(intro equalityI'  partial_pullback_memI, meson partial_pullback_memE)
+      unfolding partial_pullback_def partial_image_def evimage_eq restrict_def
+        apply (metis (mono_tags, lifting) le_add1 local.take_closed)
+       apply blast 
+      by (metis (mono_tags, lifting) le_add1 local.take_closed)
+    then show " is_semialgebraic (n + k) (partial_pullback n (restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) k S)"
+      using assms A is_semialg_functionE is_semialgebraicI
+      by presburger
+  qed
+qed
+
+lemma restrict_in_semialg_functions:
+  assumes "is_semialg_function n f"
+  shows "(restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) \<in> semialg_functions n"
+  using assms restrict_is_semialg 
+  unfolding semialg_functions_def  
+  by (metis (mono_tags, lifting) is_semialg_function_closed mem_Collect_eq restrict_apply' restrict_ext)
+
+lemma constant_function_is_semialg:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "is_semialg_function n (constant_function (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) a)"
+proof-
+  have "(constant_function (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) a) = restrict (Qp_ev (Qp.indexed_const a)) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+    apply(rule ext)
+    unfolding constant_function_def 
+    using eval_at_point_const assms by simp   
+  then show ?thesis using restrict_in_semialg_functions poly_is_semialg[of  "Qp.indexed_const a"]
+    using assms(1)  Qp_to_IP_car restrict_is_semialg by presburger    
+qed
+
+lemma constant_function_in_semialg_functions:
+  assumes "a \<in> carrier Q\<^sub>p"
+  shows "Qp_const n a \<in> semialg_functions n"
+  apply(unfold semialg_functions_def constant_function_def mem_Collect_eq, intro conjI, auto simp: assms)
+  using assms constant_function_is_semialg[of a n] unfolding constant_function_def by auto 
+
+lemma function_one_as_constant:
+"\<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> = Qp_const n \<one>"
+  unfolding constant_function_def  function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" Q\<^sub>p] function_one_def 
+  by simp 
+
+lemma function_zero_as_constant:
+"\<zero>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> = Qp_const n \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+  unfolding constant_function_def function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" Q\<^sub>p] function_zero_def 
+  by simp 
+
+lemma sum_in_semialg_functions:
+  assumes "f \<in> semialg_functions n"
+  assumes "g \<in> semialg_functions n"
+  shows "f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g \<in> semialg_functions n"
+proof-
+  have 0:"f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g = restrict (function_tuple_comp Q\<^sub>p [f,g] Qp_add_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  proof fix x
+    show "(f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = restrict (function_tuple_comp Q\<^sub>p [f, g] Qp_add_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+      case True
+      have " restrict (function_tuple_comp Q\<^sub>p [f, g] Qp_add_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = Qp_add_fun [f x, g x]"
+        unfolding function_tuple_comp_def function_tuple_eval_def restrict_def
+        using comp_apply[of "Qp_add_fun" "(\<lambda>x. map (\<lambda>f. f x) [f, g])" x]   
+        by (metis (no_types, lifting) True list.simps(8) list.simps(9))       
+      then have "restrict (function_tuple_comp Q\<^sub>p [f, g] Qp_add_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = f x \<oplus>\<^bsub>Q\<^sub>p\<^esub> g x"
+        unfolding Qp_add_fun_def 
+        by (metis One_nat_def nth_Cons_0 nth_Cons_Suc)
+      then show ?thesis  using True function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" Q\<^sub>p] 
+        unfolding function_add_def 
+        by (metis (no_types, lifting) Qp_funs_add assms(1) assms(2) mem_Collect_eq semialg_functions_def)
+    next
+      case False
+      have "(f \<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = undefined"
+        using function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" Q\<^sub>p] unfolding function_add_def 
+        by (metis (mono_tags, lifting) False restrict_apply ring_record_simps(12))
+      then show ?thesis 
+        by (metis False restrict_def)
+    qed
+  qed
+  have 1: "is_semialg_function_tuple n [f, g]"
+    using assms is_semialg_function_tupleI[of "[f, g]" n] semialg_functions_memE 
+    by (metis list.distinct(1) list.set_cases set_ConsD)
+  have 2: "is_semialg_function n (function_tuple_comp Q\<^sub>p [f,g] Qp_add_fun)"
+    apply(rule semialg_function_tuple_comp[of _ _  2])
+        apply (simp add: "1")
+       apply simp
+    by (simp add: addition_is_semialg)
+  show ?thesis
+    apply(rule semialg_functions_memI)
+  apply (meson Qp_funs_is_cring assms(1) assms(2) cring.cring_simprules(1) semialg_functions_memE(2))
+    using 0 2 restrict_is_semialg by presburger
+qed
+
+lemma prod_in_semialg_functions:
+  assumes "f \<in> semialg_functions n"
+  assumes "g \<in> semialg_functions n"
+  shows "f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g \<in> semialg_functions n"
+proof-
+  have 0:"f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g = restrict (function_tuple_comp Q\<^sub>p [f,g] Qp_mult_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  proof fix x
+    show "(f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = restrict (function_tuple_comp Q\<^sub>p [f, g] Qp_mult_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+      case True
+      have " restrict (function_tuple_comp Q\<^sub>p [f, g] Qp_mult_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = Qp_mult_fun [f x, g x]"
+        unfolding function_tuple_comp_def function_tuple_eval_def restrict_def
+        using comp_apply[of "Qp_mult_fun" "(\<lambda>x. map (\<lambda>f. f x) [f, g])" x] 
+        by (metis (no_types, lifting) True list.simps(8) list.simps(9))        
+      then have "restrict (function_tuple_comp Q\<^sub>p [f, g] Qp_mult_fun) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = f x \<otimes> g x"
+        unfolding Qp_mult_fun_def 
+        by (metis One_nat_def nth_Cons_0 nth_Cons_Suc)
+      then show ?thesis  using True function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" Q\<^sub>p] 
+        unfolding function_mult_def 
+        by (metis (no_types, lifting) Qp_funs_mult  assms(1) assms(2) mem_Collect_eq semialg_functions_def)
+    next
+      case False
+      have "(f \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> g) x = undefined"
+        using function_ring_def[of "carrier (Q\<^sub>p\<^bsup>n\<^esup>)" Q\<^sub>p] unfolding function_mult_def 
+        by (metis (mono_tags, lifting) False restrict_apply ring_record_simps(5))
+      then show ?thesis 
+        by (metis False restrict_def)
+    qed
+  qed
+  have 1: "is_semialg_function_tuple n [f, g]"
+    using assms is_semialg_function_tupleI[of "[f, g]" n] semialg_functions_memE 
+    by (metis list.distinct(1) list.set_cases set_ConsD)
+  have 2: "is_semialg_function n (function_tuple_comp Q\<^sub>p [f,g] Qp_mult_fun)"
+    apply(rule semialg_function_tuple_comp[of _ _  2])
+        apply (simp add: "1")
+       apply simp
+    by (simp add: multiplication_is_semialg)
+  show ?thesis
+    apply(rule semialg_functions_memI)
+    apply (meson Qp_funs_is_cring assms(1) assms(2) cring.cring_simprules(5) semialg_functions_memE(2))
+    using 0 2 restrict_is_semialg by presburger
+qed
+    
+lemma inv_in_semialg_functions:
+  assumes "f \<in> semialg_functions n"
+  assumes "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+  shows "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f \<in> semialg_functions n "
+proof-
+  have 0: "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = restrict (function_tuple_comp Q\<^sub>p [f] Qp_invert) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  proof fix x 
+    show "(inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = restrict (function_tuple_comp Q\<^sub>p [f] Qp_invert) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+      case True
+      have "(function_tuple_comp Q\<^sub>p [f] Qp_invert) x = Qp_invert [f x]"
+        unfolding function_tuple_comp_def function_tuple_eval_def 
+        using comp_apply  by (metis (no_types, lifting) list.simps(8) list.simps(9))
+      then have "(function_tuple_comp Q\<^sub>p [f] Qp_invert) x = inv\<^bsub>Q\<^sub>p\<^esub> (f x)"
+        unfolding Qp_invert_def 
+        using True assms(2) Qp.to_R_to_R1 by presburger        
+      then show ?thesis 
+        using True restrict_apply 
+        by (metis (mono_tags, opaque_lifting) Qp_funs_Units_memI(1) 
+            Qp_funs_m_inv assms(1) assms(2) semialg_functions_memE(2))      
+    next
+      case False
+      have "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+        using assms 
+        by (meson Qp_funs_Units_memI(1) Qp_funs_is_monoid monoid.Units_inv_closed semialg_functions_memE(2))
+      then show ?thesis using False restrict_apply function_ring_not_car
+        by auto 
+    qed
+  qed
+  have "is_semialg_function n (function_tuple_comp Q\<^sub>p [f] Qp_invert)"
+    apply(rule semialg_function_tuple_comp[of _ _  1])
+        apply (simp add: assms(1) is_semialg_function_tuple_def semialg_functions_memE(1))
+        apply simp 
+        using Qp_invert_is_semialg by blast
+  then show ?thesis 
+    using "0" restrict_in_semialg_functions 
+    by presburger
+qed
+
+lemma a_inv_in_semialg_functions:
+  assumes "f \<in> semialg_functions n"
+  shows "\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f \<in> semialg_functions n"
+proof-
+  have "\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f = (Qp_const n (\<ominus> \<one>)) \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f"
+  proof fix x 
+    show "(\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = (Qp_const n (\<ominus> \<one>) \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+      case True
+      have 0: "(\<ominus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = \<ominus> (f x)"
+        using Qp_funs_a_inv semialg_functions_memE True assms(1) by blast 
+      have 1: "(Qp_const n (\<ominus> \<one>) \<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f) x = (\<ominus> \<one>)\<otimes>(f x)"
+        using Qp_funs_mult[of x n "Qp_const n (\<ominus> \<one>)" f] assms Qp_constE[of "\<ominus> \<one>" x n] 
+          Qp_funs_mult'  Qp.add.inv_closed Qp.one_closed Qp_funs_mult''' True by presburger
+      have 2: "f x \<in> carrier Q\<^sub>p"
+        using True semialg_functions_memE[of f n]  assms by blast
+      show ?thesis 
+        using True assms 0 1 2 Qp.l_minus Qp.l_one Qp.one_closed by presburger        
+    next
+      case False
+      have "(\<ominus>\<^bsub>function_ring (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) Q\<^sub>p\<^esub> f) x = undefined"
+        using  Qp_funs_a_inv'[of f n] False assms semialg_functions_memE  
+        by (metis (no_types, lifting) restrict_apply)
+      then show ?thesis 
+        using False function_ring_defs(2)[of n] Qp_funs_a_inv'[of f n]
+        unfolding function_mult_def restrict_def
+        by presburger
+    qed
+  qed
+  then show ?thesis 
+    using prod_in_semialg_functions[of "Qp_const n (\<ominus> \<one>)" n f] assms
+      constant_function_in_semialg_functions[of "\<ominus> \<one>" n]  Qp.add.inv_closed Qp.one_closed 
+    by presburger     
+qed
+    
+lemma semialg_functions_subring:
+  shows "subring (semialg_functions n) (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  apply(rule ring.subringI)
+  using Qp_funs_is_cring cring.axioms(1) apply blast
+  apply (simp add: semialg_functions_in_Qp_funs)
+  using Qp.one_closed  constant_function_in_semialg_functions function_one_as_constant apply presburger
+  using a_inv_in_semialg_functions  apply blast
+  using  prod_in_semialg_functions apply blast
+  using  sum_in_semialg_functions by blast
+
+lemma semialg_functions_subcring:
+  shows "subcring (semialg_functions n) (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  using semialg_functions_subring cring.subcringI'
+  using Qp_funs_is_cring by blast
+
+definition SA where
+"SA n = (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<lparr> carrier := semialg_functions n\<rparr>"
+
+lemma SA_is_ring:
+  shows "ring (SA n)"
+proof-
+  have "ring (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+    by (simp add: Qp_funs_is_cring cring.axioms(1))
+  then show ?thesis 
+    unfolding SA_def
+  using  ring.subring_is_ring[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" "semialg_functions n"] semialg_functions_subring[of n]
+  by blast 
+qed
+
+lemma SA_is_cring:
+  shows "cring (SA n)"
+  using ring.subcring_iff[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" "semialg_functions n"] semialg_functions_subcring[of n]
+         Qp_funs_is_cring cring.axioms(1) semialg_functions_in_Qp_funs 
+    unfolding SA_def
+  by blast
+
+lemma SA_is_monoid:
+  shows "monoid (SA n)"
+  using SA_is_ring[of n]  unfolding ring_def 
+  by linarith
+
+lemma SA_is_abelian_monoid:
+  shows "abelian_monoid (SA n)"
+  using SA_is_ring[of n]  unfolding ring_def abelian_group_def by blast 
+
+lemma SA_car: 
+"carrier (SA n) = semialg_functions n"
+    unfolding SA_def
+  by simp 
+
+lemma SA_car_in_Qp_funs_car: 
+"carrier (SA n) \<subseteq> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  by (simp add: SA_car semialg_functions_in_Qp_funs)
+
+lemma SA_car_memI:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  assumes "is_semialg_function n f"
+  shows "f \<in> carrier (SA n)"
+  using assms semialg_functions_memI[of f n] SA_car 
+  by blast
+
+lemma SA_car_memE:
+  assumes "f \<in> carrier (SA n)"
+  shows "is_semialg_function n f"
+        "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+        "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  using SA_car assms semialg_functions_memE(1) apply blast
+  using SA_car assms semialg_functions_memE(2) apply blast
+  using SA_car assms semialg_functions_memE(3) by blast
+
+lemma SA_plus: 
+"(\<oplus>\<^bsub>SA n\<^esub>) = (\<oplus>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>)"
+  unfolding SA_def
+  by simp 
+
+lemma SA_times: 
+"(\<otimes>\<^bsub>SA n\<^esub>) = (\<otimes>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>)"
+  unfolding SA_def
+  by simp 
+
+lemma SA_one: 
+"(\<one>\<^bsub>SA n\<^esub>) = (\<one>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>)"
+  unfolding SA_def
+  by simp 
+
+lemma SA_zero: 
+"(\<zero>\<^bsub>SA n\<^esub>) = (\<zero>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>)"
+  unfolding SA_def
+  by simp 
+
+lemma SA_zero_is_function_ring:
+"(Fun\<^bsub>0\<^esub> Q\<^sub>p) = SA 0"
+proof-
+  have 0: "carrier (Fun\<^bsub>0\<^esub> Q\<^sub>p) = carrier (SA 0)"
+  proof
+    show "carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p) \<subseteq> carrier (SA 0)"
+    proof fix f assume A0: "f \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p)"
+      show "f \<in> carrier (SA 0)"
+      proof(rule SA_car_memI)
+        show "f \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p)"
+          using A0 by blast 
+        show "is_semialg_function 0 f"
+        proof(rule is_semialg_functionI)
+          show "f \<in> carrier (Q\<^sub>p\<^bsup>0\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+            using A0 Qp.function_ring_car_memE by blast 
+          show "\<And>k S. S \<in> semialg_sets (1 + k) \<Longrightarrow> is_semialgebraic (0 + k) (partial_pullback 0 f k S)"
+          proof- fix k S assume A: "S \<in> semialg_sets (1+k)"
+            obtain a where a_def: "a = f []"
+              by blast 
+            have 0: "carrier (Q\<^sub>p\<^bsup>0\<^esup>) = {[]}"
+              using Qp_zero_carrier by blast
+            have 1: "(partial_pullback 0 f k S) = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). a#x \<in> S}"
+            proof
+              show "partial_pullback 0 f k S \<subseteq> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). a # x \<in> S}"
+                apply(rule subsetI)
+              unfolding partial_pullback_def partial_image_def using a_def 
+              by (metis (no_types, lifting) add.left_neutral drop0 evimage_eq mem_Collect_eq take_eq_Nil)
+              show "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). a # x \<in> S} \<subseteq> partial_pullback 0 f k S"
+                apply(rule subsetI)
+                unfolding partial_pullback_def partial_image_def  a_def 
+                by (metis (no_types, lifting) add.left_neutral drop0 evimageI2 mem_Collect_eq take0)
+            qed
+            have 2: "cartesian_product {[a]} (partial_pullback 0 f k S) = (cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>))) \<inter> S"
+            proof
+              show "cartesian_product {[a]} (partial_pullback 0 f k S) \<subseteq> cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) \<inter> S"
+              proof(rule subsetI) fix x assume A: "x \<in> cartesian_product {[a]} (partial_pullback 0 f k S)"
+                then obtain y where y_def: "y \<in> (partial_pullback 0 f k S) \<and>x = a#y"
+                  using cartesian_product_memE' 
+                  by (metis (no_types, lifting) Cons_eq_appendI self_append_conv2 singletonD)
+                hence 20: "x \<in> S"
+                  unfolding 1 by blast  
+                have 21: "x = [a]@y"
+                  using y_def by (simp add: y_def)
+                have "x \<in> cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>))"
+                  unfolding 21 apply(rule cartesian_product_memI'[of _ Q\<^sub>p 1 _ k])
+                  using a_def  apply (metis function_ring_car_closed Qp_zero_carrier \<open>f \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p)\<close> empty_subsetI insert_subset singletonI Qp.to_R1_closed)
+                    apply blast 
+                   apply blast 
+                  using y_def unfolding partial_pullback_def  evimage_def 
+                  by (metis IntD2 add_cancel_right_left)
+                thus "x \<in> cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) \<inter> S"
+                  using 20 by blast 
+              qed
+              show " cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) \<inter> S \<subseteq> cartesian_product {[a]} (partial_pullback 0 f k S)"
+              proof fix x assume A: "x \<in> cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) \<inter> S"
+                then obtain y where y_def: "x = a#y \<and> y \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+                  using cartesian_product_memE'   
+                  by (metis (no_types, lifting) Cons_eq_appendI IntD1 append_Nil singletonD)
+                have 00: "y \<in> partial_pullback 0 f k S"
+                  using y_def unfolding 1  using A by blast
+                have 01: "x = [a]@y"
+                  using y_def by (simp add: y_def)
+                have 02: "partial_pullback 0 f k S \<subseteq> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+                  unfolding partial_pullback_def 
+                  by (simp add: extensional_vimage_closed)                 
+                show "x \<in> cartesian_product {[a]} (partial_pullback 0 f k S)"
+                  unfolding 01 apply(rule cartesian_product_memI'[of "{[a]}" Q\<^sub>p 1 "partial_pullback 0 f k S" k "[a]" y ])    
+                  apply (metis function_ring_car_closed Qp_zero_carrier \<open>f \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p)\<close> a_def empty_subsetI insert_subset singletonI Qp.to_R1_closed)
+                  using "02" apply blast
+                   apply blast 
+                  using 00 by blast 
+              qed
+            qed 
+            have 3:"is_semialgebraic 1 {[a]}"
+            proof-
+              have "a \<in> carrier Q\<^sub>p"
+                using a_def Qp.function_ring_car_memE 0  \<open>f \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p)\<close> by blast
+              hence "[a] \<in> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
+                using Qp.to_R1_closed by blast
+              thus ?thesis  
+                using is_algebraic_imp_is_semialg singleton_is_algebraic by blast
+            qed
+            have  4: "is_semialgebraic (1+k)  (cartesian_product {[a]} (carrier (Q\<^sub>p\<^bsup>k\<^esup>)))"
+              using 3 carrier_is_semialgebraic cartesian_product_is_semialgebraic less_one by blast
+            have  5: "is_semialgebraic (1+k) (cartesian_product {[a]} (partial_pullback 0 f k S))"
+              unfolding 2 using 3 4 A intersection_is_semialg padic_fields.is_semialgebraicI padic_fields_axioms by blast
+            have 6: "{[a]} \<subseteq> carrier (Q\<^sub>p\<^bsup>1\<^esup>)"
+              using a_def A0 0 by (metis Qp.function_ring_car_memE empty_subsetI insert_subset singletonI Qp.to_R1_closed)
+            have  7: "is_semialgebraic (k+1) (cartesian_product (partial_pullback 0 f k S) {[a]})"
+              apply(rule cartesian_product_swap)
+                using "6" apply blast
+               apply (metis add_cancel_right_left partial_pullback_closed)
+              using "5" by auto
+            have 8: "is_semialgebraic k (partial_pullback 0 f k S)"
+              apply(rule cartesian_product_singleton_factor_projection_is_semialg'[of _ _ "[a]" 1])
+                  apply (metis add_cancel_right_left partial_pullback_closed)
+                 apply (metis A0 Qp.function_ring_car_memE Qp_zero_carrier a_def singletonI Qp.to_R1_closed)
+                using "7" by blast
+            thus "is_semialgebraic (0 + k) (partial_pullback 0 f k S)"
+                by simp 
+          qed
+        qed
+      qed
+    qed
+    show "carrier (SA 0) \<subseteq> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) Q\<^sub>p)"
+      using SA_car_in_Qp_funs_car by blast
+  qed
+  then have 1: "semialg_functions 0 = carrier (Fun\<^bsub>0\<^esub> Q\<^sub>p)"
+    unfolding 0 SA_def by auto 
+  show ?thesis unfolding SA_def 1 by auto 
+qed
+
+lemma constant_fun_closed: 
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "constant_function (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) c \<in> carrier (SA m)"
+  using constant_function_in_semialg_functions SA_car assms by blast
+
+lemma SA_0_car_memI:
+  assumes "\<xi> \<in> carrier (Q\<^sub>p\<^bsup>0\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  assumes "\<And>x. x \<notin> carrier (Q\<^sub>p\<^bsup>0\<^esup>) \<Longrightarrow> \<xi> x = undefined"
+  shows "\<xi> \<in> carrier (SA 0)"
+proof- 
+  have 0: "carrier (Q\<^sub>p\<^bsup>0\<^esup>) = {[]}"
+    by (simp add: Qp_zero_carrier)
+  obtain c where c_def: "\<xi> [] = c"
+    by blast 
+  have 1: "\<xi> = constant_function (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) c"
+    unfolding constant_function_def restrict_def 
+    using assms c_def  unfolding 0
+    by (metis empty_iff insert_iff)
+  have 2: "c \<in> carrier Q\<^sub>p"
+    using assms(1) c_def unfolding 0 by blast 
+  show ?thesis unfolding 1
+    using 2 constant_fun_closed by blast
+qed
+
+lemma car_SA_0_mem_imp_const:
+  assumes "a \<in> carrier (SA 0)"
+  shows "\<exists> c \<in> carrier Q\<^sub>p. a = Qp_const 0 c"
+proof-
+  obtain c where c_def: "c =  a []"
+    by blast 
+  have car_zero: "carrier (Q\<^sub>p\<^bsup>0\<^esup>) = {[]}"
+    using Qp_zero_carrier by blast
+  have 0: "a = constant_function (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) c"
+  proof fix x 
+    show " a x = constant_function (carrier (Q\<^sub>p\<^bsup>0\<^esup>)) c x"
+      apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>0\<^esup>)")
+      using assms SA_car_memE[of a 0] c_def
+      unfolding constant_function_def restrict_def  car_zero 
+       apply (metis empty_iff insert_iff)
+      using assms SA_car_memE(2)[of a 0] c_def 
+      unfolding constant_function_def restrict_def car_zero
+      by (metis car_zero function_ring_not_car)
+  qed
+  have c_closed: "c \<in> carrier Q\<^sub>p"
+    using assms  SA_car_memE(3)[of  a 0] unfolding c_def car_zero
+    by blast  
+  thus ?thesis using 0 by blast   
+qed
+
+lemma SA_zeroE:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "\<zero> \<^bsub>SA n\<^esub> a = \<zero>"
+  using function_zero_eval SA_zero assms by presburger
+
+lemma SA_oneE:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "\<one> \<^bsub>SA n\<^esub> a = \<one>"
+  using function_one_eval  SA_one assms by presburger  
+end 
+
+sublocale padic_fields < UPSA?: UP_cring "SA m" "UP (SA m)"
+  unfolding UP_cring_def using SA_is_cring[of m] by auto 
+
+context padic_fields
+begin
+
+lemma SA_add: 
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f \<oplus>\<^bsub>SA n\<^esub> g) x = f x \<oplus>\<^bsub>Q\<^sub>p\<^esub> g x"
+  using Qp_funs_add''' SA_plus assms by presburger
+  
+lemma SA_add': 
+  assumes "x \<notin> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f \<oplus>\<^bsub>SA n\<^esub> g) x = undefined"
+proof-
+  have "(f \<oplus>\<^bsub>SA n\<^esub> g) x = function_add (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) Q\<^sub>p f g x"
+    using SA_plus[of n] unfolding function_ring_def
+    by (metis ring_record_simps(12))
+  then show ?thesis 
+    unfolding function_add_def using restrict_apply assms  
+    by (metis (no_types, lifting))
+qed
+
+lemma SA_mult:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f \<otimes>\<^bsub>SA n\<^esub> g) x = f x \<otimes> g x"
+  using Qp_funs_mult''' SA_times assms by presburger
+  
+lemma SA_mult': 
+  assumes "x \<notin> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f \<otimes>\<^bsub>SA n\<^esub> g) x = undefined"
+proof-
+  have "(f \<otimes>\<^bsub>SA n\<^esub> g) x = function_mult (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) Q\<^sub>p f g x"
+    using SA_times[of n] unfolding function_ring_def
+    by (metis ring_record_simps(5))
+  then show ?thesis 
+    unfolding function_mult_def using restrict_apply assms  
+    by (metis (no_types, lifting))
+qed
+
+lemma SA_u_minus_eval:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(\<ominus>\<^bsub>SA n\<^esub> f) x = \<ominus> (f x)" 
+proof-
+  have  "f \<oplus>\<^bsub>SA n\<^esub> (\<ominus>\<^bsub>SA n\<^esub> f) = \<zero> \<^bsub>SA n\<^esub>"
+    using assms SA_is_cring cring.cring_simprules(17) by metis 
+  have  "(f \<oplus>\<^bsub>SA n\<^esub> (\<ominus>\<^bsub>SA n\<^esub> f)) x = \<zero> \<^bsub>SA n\<^esub> x"
+    using assms \<open>f \<oplus>\<^bsub>SA n\<^esub> \<ominus>\<^bsub>SA n\<^esub> f = \<zero>\<^bsub>SA n\<^esub>\<close> by presburger
+  then have "(f x) \<oplus> (\<ominus>\<^bsub>SA n\<^esub> f) x = \<zero>"
+    using assms function_zero_eval SA_add unfolding   SA_zero by blast  
+  then show ?thesis 
+    using assms SA_is_ring 
+    by (meson Qp.add.inv_closed Qp.add.inv_comm Qp.function_ring_car_memE Qp.minus_unique Qp.r_neg SA_car_memE(2) ring.ring_simprules(3))
+qed
+
+lemma SA_a_inv_eval:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(\<ominus>\<^bsub>SA n\<^esub> f) x = \<ominus> (f x)" 
+proof-
+  have  "f \<oplus>\<^bsub>SA n\<^esub> (\<ominus>\<^bsub>SA n\<^esub> f) = \<zero> \<^bsub>SA n\<^esub>"
+    using assms SA_is_cring cring.cring_simprules(17) by metis   
+  have  "(f \<oplus>\<^bsub>SA n\<^esub> (\<ominus>\<^bsub>SA n\<^esub> f)) x = \<zero> \<^bsub>SA n\<^esub> x"
+    using assms \<open>f \<oplus>\<^bsub>SA n\<^esub> \<ominus>\<^bsub>SA n\<^esub> f = \<zero>\<^bsub>SA n\<^esub>\<close> by presburger
+  then have "(f x) \<oplus> (\<ominus>\<^bsub>SA n\<^esub> f) x = \<zero>"
+    by (metis function_zero_eval SA_add SA_zero assms)
+  then show ?thesis 
+    by (metis (no_types, lifting) PiE Q\<^sub>p_def Qp.add.m_comm Qp.minus_equality SA_is_cring Zp_def assms(1) assms(2) cring.cring_simprules(3) padic_fields.SA_car_memE(3) padic_fields_axioms)
+qed
+
+lemma SA_nat_pow:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f [^]\<^bsub>SA n\<^esub> (k::nat)) x = (f x) [^]\<^bsub>Q\<^sub>p\<^esub> k"
+  apply(induction k)
+  using assms  nat_pow_def   
+  apply (metis function_one_eval SA_one old.nat.simps(6))
+  using assms SA_mult 
+  by (metis Group.nat_pow_Suc)
+
+lemma SA_nat_pow':
+  assumes "x \<notin> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f [^]\<^bsub>SA n\<^esub> (k::nat)) x = undefined"
+  apply(induction k)
+  using assms nat_pow_def[of "SA n" f] 
+  apply (metis (no_types, lifting) Group.nat_pow_0 Qp_funs_one SA_one restrict_apply)
+  by (metis Group.nat_pow_Suc SA_mult' assms)
+  
+lemma SA_add_closed_id: 
+  assumes "is_semialg_function n f"
+  assumes "is_semialg_function n g"
+  shows "restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<oplus>\<^bsub>SA n\<^esub> restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = f \<oplus>\<^bsub>SA n\<^esub> g "
+proof fix x 
+  show "(restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<oplus>\<^bsub>SA n\<^esub> restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) x = (f \<oplus>\<^bsub>SA n\<^esub> g) x"
+    apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+    using assms restrict_apply  
+    apply (metis SA_add)
+    using assms  
+    by (metis SA_add')
+qed
+
+lemma SA_mult_closed_id: 
+  assumes "is_semialg_function n f"
+  assumes "is_semialg_function n g"
+  shows "restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<otimes>\<^bsub>SA n\<^esub> restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = f \<otimes>\<^bsub>SA n\<^esub> g "
+proof fix x 
+  show "(restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<otimes>\<^bsub>SA n\<^esub> restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) x = (f \<otimes>\<^bsub>SA n\<^esub> g) x"
+    apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+    using assms restrict_apply  
+    apply (metis SA_mult)
+    using assms  
+    by (metis SA_mult')
+qed
+
+lemma SA_add_closed: 
+  assumes "is_semialg_function n f"
+  assumes "is_semialg_function n g"
+  shows "f \<oplus>\<^bsub>SA n\<^esub> g \<in> carrier (SA n)"
+    using assms SA_add_closed_id 
+    by (metis SA_car SA_plus restrict_in_semialg_functions sum_in_semialg_functions)
+
+lemma SA_mult_closed: 
+  assumes "is_semialg_function n f"
+  assumes "is_semialg_function n g"
+  shows "f \<otimes>\<^bsub>SA n\<^esub> g \<in> carrier (SA n)"
+    using assms SA_mult_closed_id 
+  by (metis SA_car SA_is_cring cring.cring_simprules(5) restrict_in_semialg_functions)
+
+lemma SA_add_closed_right: 
+  assumes "is_semialg_function n f"
+  assumes "g \<in> carrier (SA n)"
+  shows "f \<oplus>\<^bsub>SA n\<^esub> g \<in> carrier (SA n)"
+  using SA_add_closed SA_car_memE(1) assms(1) assms(2)   by blast
+  
+lemma SA_mult_closed_right: 
+  assumes "is_semialg_function n f"
+  assumes "g \<in> carrier (SA n)"
+  shows "f \<otimes>\<^bsub>SA n\<^esub> g \<in> carrier (SA n)"
+  using SA_car_memE(1) SA_mult_closed assms(1) assms(2)   by blast
+  
+lemma SA_add_closed_left: 
+  assumes "f \<in> carrier (SA n)"
+  assumes "is_semialg_function n g"
+  shows "f \<oplus>\<^bsub>SA n\<^esub> g \<in> carrier (SA n)"
+  using SA_add_closed SA_car_memE(1) assms(1) assms(2)   by blast
+  
+lemma SA_mult_closed_left: 
+  assumes "f \<in> carrier (SA n)"
+  assumes "is_semialg_function n g"
+  shows "f \<otimes>\<^bsub>SA n\<^esub> g \<in> carrier (SA n)"
+  using SA_car_memE(1) SA_mult_closed assms(1) assms(2)  by blast
+
+lemma SA_nat_pow_closed:
+  assumes "is_semialg_function n f"
+  shows "f [^]\<^bsub>SA n\<^esub> (k::nat) \<in> carrier (SA n)"
+  apply(induction k)
+  using nat_pow_def[of "SA n" f ] 
+  apply (metis Group.nat_pow_0  monoid.one_closed SA_is_monoid)
+  by (metis Group.nat_pow_Suc SA_car assms(1) assms SA_mult_closed semialg_functions_memE(1))
+
+lemma SA_imp_semialg:
+  assumes "f \<in> carrier (SA n)"
+  shows "is_semialg_function n f"
+  using SA_car assms semialg_functions_memE(1) by blast
+
+lemma SA_minus_closed:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  shows "(f  \<ominus>\<^bsub>SA n\<^esub> g) \<in> carrier (SA n)"
+  using assms unfolding a_minus_def 
+  by (meson SA_add_closed_left SA_imp_semialg SA_is_ring ring.ring_simprules(3))
+
+lemma(in ring) add_pow_closed : 
+  assumes "b \<in> carrier R"
+  shows "([(m::nat)]\<cdot>\<^bsub>R\<^esub>b) \<in> carrier R" 
+  by(rule add.nat_pow_closed, rule assms)
+   
+lemma(in ring) add_pow_Suc: 
+  assumes "b \<in> carrier R"
+  shows "[(Suc m)]\<cdot>b = [m]\<cdot>b \<oplus> b"
+  using assms add.nat_pow_Suc by blast
+
+lemma(in ring) add_pow_zero: 
+  assumes "b \<in> carrier R"
+  shows "[(0::nat)]\<cdot>b = \<zero>"
+  using assms nat_mult_zero 
+  by blast
+  
+lemma Fun_add_pow_apply:
+  assumes "b \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "([(m::nat)]\<cdot>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> b) a = [m]\<cdot>( b a)"
+proof-
+  have 0: "b a \<in> carrier Q\<^sub>p"
+    using Qp.function_ring_car_mem_closed assms by fastforce    
+  have 1: "ring (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+    using function_ring_is_ring by blast
+  show ?thesis 
+  proof(induction m) 
+    case 0
+    have "([(0::nat)] \<cdot>\<^bsub>function_ring (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) Q\<^sub>p\<^esub> b) = \<zero>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>"
+      using 1 ring.add_pow_zero[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" b ] assms  by blast  
+    then show ?case 
+      using  function_zero_eval Qp.nat_mult_zero assms  by presburger   
+  next
+    case (Suc m)
+    then show ?case using Suc ring.add_pow_Suc[of "SA n" b m] assms 
+      by (metis (no_types, lifting) "0" "1" Qp.ring_axioms SA_add SA_plus ring.add_pow_Suc)   
+  qed
+qed
+
+lemma SA_add_pow_apply:
+  assumes "b \<in> carrier (SA n)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "([(m::nat)]\<cdot>\<^bsub>SA n\<^esub> b) a = [m]\<cdot>( b a)"
+  apply(induction m)
+  using assms SA_is_ring[of n] Fun_add_pow_apply 
+  apply (metis function_zero_eval Qp.nat_mult_zero SA_zero ring.add_pow_zero) 
+  using assms SA_is_ring[of n] ring.add_pow_Suc[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" b]  ring.add_pow_Suc[of "SA n" b] SA_plus[of n]
+  using Fun_add_pow_apply 
+  by (metis Qp.add.nat_pow_Suc SA_add)
+
+lemma Qp_funs_Units_SA_Units:
+  assumes "f \<in> Units (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  assumes "is_semialg_function n f"
+  shows "f \<in> Units (SA n)"
+proof-
+  have 0: "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+    by (meson Qp_funs_is_monoid assms(1) monoid.Units_closed)
+  have 1: "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f \<in> semialg_functions n"
+    using monoid.Units_closed[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" f]
+      assms inv_in_semialg_functions[of f n] Qp_funs_Units_memE(3)[of f n] 
+      semialg_functions_memI[of f n] Qp_funs_is_monoid by blast
+  then have 2: "f \<otimes>\<^bsub>SA n\<^esub> (inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f ) = \<one>\<^bsub>SA n\<^esub>"
+    using Qp_funs_Units_memE(1)[of f n] SA_one SA_times assms(1) 
+    by presburger
+  then have 3: "(inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f ) \<otimes>\<^bsub>SA n\<^esub> f  = \<one>\<^bsub>SA n\<^esub>"
+    using Qp_funs_Units_memE(2)[of f n] SA_one SA_times assms(1) 
+    by presburger
+  have 4: "f \<in> carrier (SA n)"
+    using "0" SA_car assms(2) semialg_functions_memI by blast
+  have 5: "inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f \<in> carrier (SA n)"
+    using SA_car_memI "1" SA_car by blast
+  show ?thesis 
+    using 5 4 3 2 unfolding Units_def 
+    by blast
+qed
+
+lemma SA_Units_memE:
+  assumes "f \<in> (Units (SA n))"
+  shows "f \<otimes>\<^bsub>SA n\<^esub> inv\<^bsub>SA n\<^esub> f = \<one>\<^bsub>SA n\<^esub>"
+        "inv\<^bsub>SA n\<^esub> f \<otimes>\<^bsub>SA n\<^esub> f = \<one>\<^bsub>SA n\<^esub>"
+  using assms SA_is_monoid[of n] monoid.Units_r_inv[of "SA n" f] 
+  apply blast
+  using assms SA_is_monoid[of n] monoid.Units_l_inv[of "SA n" f] 
+  by blast 
+
+lemma SA_Units_closed:
+  assumes "f \<in> (Units (SA n))"
+  shows "f \<in> carrier (SA n)"
+  using assms unfolding Units_def by blast 
+
+lemma SA_Units_inv_closed:
+  assumes "f \<in> (Units (SA n))"
+  shows "inv\<^bsub>SA n\<^esub> f \<in> carrier (SA n)"
+  using assms SA_is_monoid[of n] monoid.Units_inv_closed[of "SA n" f]
+  by blast
+
+lemma SA_Units_Qp_funs_Units:
+  assumes "f \<in> (Units (SA n))"
+  shows "f \<in> (Units (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+proof-
+  have 0:  "f \<otimes>\<^bsub>SA n\<^esub> inv\<^bsub>SA n\<^esub> f = \<one>\<^bsub>SA n\<^esub>"
+        "inv\<^bsub>SA n\<^esub> f \<otimes>\<^bsub>SA n\<^esub> f = \<one>\<^bsub>SA n\<^esub>"
+     using R.Units_r_inv assms apply blast    
+     using R.Units_l_inv assms by blast     
+  have 1: "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+    using assms 
+    by (metis SA_car SA_is_monoid monoid.Units_closed semialg_functions_memE(2))
+  have 2: "inv\<^bsub>SA n\<^esub> f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+    using SA_Units_inv_closed SA_car assms semialg_functions_memE(2) by blast
+  then show ?thesis 
+   using 0 1 2  SA_one SA_times local.F.UnitsI(1) by auto
+qed
+
+lemma SA_Units_Qp_funs_inv:
+  assumes "f \<in> (Units (SA n))"
+  shows "inv\<^bsub>SA n\<^esub> f = inv\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub> f"
+  using assms SA_Units_Qp_funs_Units
+  by (metis (no_types, opaque_lifting) Qp_funs_is_cring Qp_funs_is_monoid SA_Units_memE(1) 
+      SA_is_monoid SA_one SA_times cring.invI(1) monoid.Units_closed monoid.Units_inv_Units)
+
+lemma SA_Units_memI:
+  assumes "f \<in> (carrier (SA n))"
+  assumes "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow>  f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>"
+  shows "f \<in> (Units (SA n))"
+  using assms Qp_funs_Units_memI[of f n] Qp_funs_Units_SA_Units SA_car SA_imp_semialg 
+      semialg_functions_memE(2) by blast
+  
+lemma SA_Units_memE':
+  assumes "f \<in> (Units (SA n))"
+  shows  "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow>  f x \<noteq> \<zero>\<^bsub>Q\<^sub>p\<^esub>" 
+  using assms Qp_funs_Units_memE[of f n] SA_Units_Qp_funs_Units 
+  by blast
+
+lemma Qp_n_nonempty:
+  shows "carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<noteq> {}"
+  apply(induction n)
+  apply (simp add: Qp_zero_carrier)
+  using cartesian_power_cons[of _ Q\<^sub>p _ \<one>] Qp.one_closed  
+  by (metis Suc_eq_plus1 all_not_in_conv cartesian_power_cons empty_iff)
+
+lemma SA_one_not_zero:
+  shows "\<one>\<^bsub>SA n\<^esub> \<noteq> \<zero>\<^bsub> SA n\<^esub>"
+proof-
+  obtain a where a_def: "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    using Qp_n_nonempty by blast 
+  have "\<one>\<^bsub>SA n\<^esub> a  \<noteq> \<zero>\<^bsub> SA n\<^esub> a"
+    using function_one_eval function_zero_eval SA_one SA_zero a_def local.one_neq_zero by presburger
+  then show ?thesis 
+    by metis 
+qed
+  
+lemma SA_units_not_zero:
+  assumes "f \<in> Units (SA n)"
+  shows "f \<noteq> \<zero>\<^bsub> SA n\<^esub>"  
+  using SA_one_not_zero 
+  by (metis assms padic_fields.SA_is_ring padic_fields_axioms ring.ring_in_Units_imp_not_zero)
+
+lemma SA_Units_nonzero:
+  assumes "f \<in> Units (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "f x \<in> nonzero Q\<^sub>p"
+  unfolding nonzero_def  mem_Collect_eq 
+  apply(rule conjI)
+  using assms  SA_Units_closed SA_car_memE(3)[of f m]  apply blast 
+  using assms SA_Units_memE' by blast 
+
+lemma SA_car_closed:
+  assumes "f \<in> carrier (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "f x \<in> carrier Q\<^sub>p"
+  using assms SA_car_memE(3) by blast 
+
+lemma SA_Units_closed_fun:
+  assumes "f \<in> Units (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "f x \<in> carrier Q\<^sub>p"
+  using SA_Units_closed SA_car_closed assms by blast 
+
+lemma SA_inv_eval:
+  assumes "f \<in> Units (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(inv\<^bsub>SA n\<^esub> f) x = inv (f x)" 
+proof-
+  have  "f \<otimes>\<^bsub>SA n\<^esub> (inv\<^bsub>SA n\<^esub> f) = \<one> \<^bsub>SA n\<^esub>"
+    using assms SA_is_cring  SA_Units_memE(1) by blast
+  hence  "(f \<otimes>\<^bsub>SA n\<^esub> (inv\<^bsub>SA n\<^esub> f)) x = \<one>  \<^bsub>SA n\<^esub> x"
+    using assms by presburger
+  then have "(f x) \<otimes> (inv\<^bsub>SA n\<^esub> f) x = \<one>"
+    by (metis function_one_eval SA_mult SA_one assms)
+  then show ?thesis 
+    by (metis Q\<^sub>p_def Qp_funs_m_inv Zp_def assms(1) assms(2) padic_fields.SA_Units_Qp_funs_Units padic_fields.SA_Units_Qp_funs_inv padic_fields_axioms)
+qed
+
+lemma SA_div_eval:
+  assumes "f \<in> Units (SA n)"
+  assumes "h \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(h \<otimes>\<^bsub>SA n\<^esub> (inv\<^bsub>SA n\<^esub> f)) x = h x \<otimes> inv (f x)" 
+  using assms SA_inv_eval  SA_mult by presburger
+
+lemma SA_unit_int_pow:
+  assumes "f \<in> Units (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "(f[^]\<^bsub>SA m\<^esub>(i::int)) x = (f x)[^]i"
+proof(induction i)
+  case (nonneg n)
+  have  0: "(f [^]\<^bsub>SA m\<^esub> int n) = (f [^]\<^bsub>SA m\<^esub> n)"
+    using assms by (meson int_pow_int)
+  then show ?case using SA_Units_closed[of f m] assms 
+    by (metis SA_nat_pow int_pow_int)
+next
+  case (neg n)
+  have 0: "(f [^]\<^bsub>SA m\<^esub> - int (Suc n)) = inv \<^bsub>SA m\<^esub>(f [^]\<^bsub>SA m\<^esub> (Suc n))"
+    using assms by (metis R.int_pow_inv' int_pow_int)
+  then show ?case unfolding 0 using assms 
+    by (metis Qp.int_pow_inv' R.Units_pow_closed SA_Units_nonzero SA_inv_eval SA_nat_pow Units_eq_nonzero int_pow_int)
+qed
+
+lemma restrict_in_SA_car:
+  assumes "is_semialg_function n f"
+  shows "restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<in> carrier (SA n)"
+  using assms  SA_car restrict_in_semialg_functions 
+  by blast
+
+lemma SA_smult:
+"(\<odot>\<^bsub>SA n\<^esub>) = (\<odot>\<^bsub>Fun\<^bsub>n\<^esub> Q\<^sub>p\<^esub>)"
+  unfolding SA_def by auto 
+
+lemma SA_smult_formula: 
+  assumes "h \<in> carrier (SA n)"
+  assumes "q \<in> carrier Q\<^sub>p"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(q \<odot>\<^bsub>SA n\<^esub> h) a = q \<otimes>(h a)"
+  using SA_smult assms function_smult_eval SA_car_memE(2) by presburger
+
+lemma SA_smult_closed: 
+  assumes "h \<in> carrier (SA n)"
+  assumes "q \<in> carrier Q\<^sub>p"
+  shows "q \<odot>\<^bsub>SA n\<^esub> h \<in> carrier (SA n)"
+proof-
+  obtain g where g_def: "g = \<cc>\<^bsub>n\<^esub> q"
+    by blast 
+  have g_closed: "g \<in> carrier (SA n)"
+    using g_def assms constant_function_is_semialg[of q n] constant_function_closed SA_car_memI 
+    by blast
+  have "q \<odot>\<^bsub>SA n\<^esub> h = g \<otimes>\<^bsub>SA n\<^esub> h"
+    apply(rule function_ring_car_eqI[of _ n])
+    using function_smult_closed SA_car_memE(2) SA_smult assms apply presburger    
+    using SA_car_memE(2) assms(1) assms(2) g_closed padic_fields.SA_imp_semialg padic_fields.SA_mult_closed_right padic_fields_axioms apply blast
+    using Qp_constE SA_mult SA_smult_formula assms   g_def by presburger
+  thus ?thesis 
+    using SA_imp_semialg SA_mult_closed_right assms(1) assms(2) g_closed by presburger
+qed
+
+lemma p_mult_function_val:
+  assumes "f \<in> carrier (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "val ((\<pp> \<odot>\<^bsub>SA m\<^esub>f) x) = val (f x) + 1"
+proof-
+  have 0: "(\<pp>\<odot>\<^bsub>SA m\<^esub>f) x = \<pp>\<otimes>(f x)"
+    using Qp.int_inc_closed SA_smult_formula assms(1) assms(2) by blast
+  show ?thesis  unfolding 0 using assms 
+    by (metis Qp.function_ring_car_memE Qp.int_inc_closed Qp.m_comm SA_car semialg_functions_memE(2) val_mult val_p)
+qed
+
+lemma Qp_char_0'':
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "a \<noteq> \<zero>"
+  assumes "(k::nat) > 0"
+  shows "[k]\<cdot>a \<noteq> \<zero>"
+proof-
+  have 0: "[k]\<cdot>\<one> \<noteq>\<zero>"
+    using Qp_char_0 assms(3) by blast
+  have "[k]\<cdot>a = [k]\<cdot>\<one> \<otimes> a"
+    using Qp.add_pow_ldistr Qp.l_one Qp.one_closed assms(1) by presburger
+  thus ?thesis using 0 assms 
+    using Qp.integral by blast
+qed
+
+lemma SA_char_zero:
+  assumes "f \<in> carrier (SA m)"
+  assumes "f \<noteq> \<zero>\<^bsub>SA m\<^esub>"
+  assumes "n > 0"
+  shows "[(n::nat)]\<cdot>\<^bsub>SA m\<^esub>f \<noteq> \<zero>\<^bsub>SA m\<^esub>"
+proof assume A: "[n] \<cdot>\<^bsub>SA m\<^esub> f = \<zero>\<^bsub>SA m\<^esub>"
+  obtain x where x_def: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> f x \<noteq> \<zero>"
+    using assms 
+    by (metis function_ring_car_eqI R.cring_simprules(2) SA_car_memE(2) SA_zeroE)
+  have 0: "([(n::nat)]\<cdot>\<^bsub>SA m\<^esub>f) x = [n]\<cdot>(f x)"
+    using SA_add_pow_apply assms(1) x_def by blast
+  have 1: "[n]\<cdot>(f x) = \<zero>"
+    using 0 unfolding A  using SA_zeroE x_def by blast
+  have 2: "f x \<in> nonzero Q\<^sub>p"
+    using x_def assms 
+    by (metis Qp.function_ring_car_memE SA_car not_nonzero_Qp semialg_functions_memE(2))
+  then show False using x_def 
+    using "1" Qp.nonzero_memE(1) Qp_char_0'' assms(3) by blast
+qed
+
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Defining Semialgebraic Maps\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  We can define a semialgebraic map in essentially the same way that Denef defines 
+  semialgebraic functions. As for functions, we can define the partial pullback of a set 
+  $S \subseteq \mathbb{Q}_p^{n+l}$ by a map $g: \mathbb{Q}_p^m \to \mathbb{Q}_p^n$ to be the set
+  \[
+  \{(x,y) \in \mathbb{Q}_p^m \times \mathbb{Q}_p^l \mid (f(x), y) \in S \}
+  \]
+  and say that $g$ is a semialgebraic map if for every $l$, and every semialgebraic 
+  $S \subseteq \mathbb{Q}_p^{n+l}$, the partial pullback of $S$ by $g$ is also semialgebraic. 
+  On this definition, it is immediate that the composition $f \circ g$ of a semialgebraic 
+  function $f: \mathbb{Q}_p^n \to \mathbb{Q}$ and a semialgebraic map 
+  $g: \mathbb{Q}_p^m \to \mathbb{Q}_p^n$ is semialgebraic. It is also not hard to show that a map 
+  is semialgebraic if and only if all of its coordinate functions are semialgebraic functions. 
+  This allows us to build new semialgebraic functions out of old ones via composition.
+\<close>
+
+
+text\<open>Generalizing the notion of partial image partial pullbacks from functions to maps:\<close>
+
+definition map_partial_image where
+"map_partial_image m f xs = (f (take m xs))@(drop m xs)"
+
+definition map_partial_pullback where
+"map_partial_pullback m f l S = (map_partial_image m f)  \<inverse>\<^bsub>m+l\<^esub> S"
+
+lemma map_partial_pullback_memE: 
+  assumes "as \<in> map_partial_pullback m f l S"
+  shows "as \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)" "map_partial_image m f as \<in> S"
+  using assms unfolding map_partial_pullback_def  evimage_def
+  apply (metis (no_types, opaque_lifting) Int_iff add.commute)
+  using assms unfolding map_partial_pullback_def   
+  by blast
+
+lemma map_partial_pullback_closed: 
+"map_partial_pullback m f l S \<subseteq> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)" 
+  using map_partial_pullback_memE(1) by blast
+
+lemma map_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> map_partial_pullback m f k S"
+  using assms unfolding map_partial_pullback_def map_partial_image_def 
+  by blast 
+
+lemma map_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 "map_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 map_partial_image_def 
+    by blast 
+qed
+  
+lemma map_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> map_partial_pullback n f k S"
+  shows "(f as)@bs \<in> S" 
+  using map_partial_pullback_memE[of x n f k S] map_partial_image_def[of n f x] 
+  by (metis assms(1) assms(2) assms(3) assms(4) map_partial_image_eq)
+
+text\<open>Partial pullbacks have the same algebraic properties as pullbacks.\<close>
+
+lemma map_partial_pullback_intersect:
+"map_partial_pullback m f l (S1 \<inter> S2) = (map_partial_pullback m f l S1) \<inter> (map_partial_pullback m f l S2)"
+  unfolding map_partial_pullback_def 
+  by simp
+  
+lemma map_partial_pullback_union:
+"map_partial_pullback m f l (S1 \<union> S2) = (map_partial_pullback m f l S1) \<union> (map_partial_pullback m f l S2)"
+  unfolding map_partial_pullback_def 
+  by simp
+
+lemma map_partial_pullback_complement:
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "map_partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) - S) = carrier (Q\<^sub>p\<^bsup>m+l\<^esup>) - (map_partial_pullback m f l S) "
+  apply(rule equalityI)
+  using map_partial_pullback_def[of m f l "(carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) - S)"] 
+        map_partial_pullback_def[of m f l S] 
+   apply (metis (no_types, lifting) DiffD2 DiffI evimage_Diff map_partial_pullback_memE(1) subsetI)   
+proof fix x assume A: " x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>) - map_partial_pullback m f l S"
+  show " x \<in> map_partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) - S) "
+    apply(rule map_partial_pullback_memI)
+    using A 
+     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 take_closed le_add1)     
+    show "f (take m x) @ drop m x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>) "
+      using 0 1 assms 
+      by (meson Pi_iff cartesian_power_concat(1))      
+    show "f (take m x) @ drop m x \<notin> S"
+      using A unfolding map_partial_pullback_def map_partial_image_def 
+      by blast
+  qed
+qed     
+
+lemma map_partial_pullback_carrier:
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "map_partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)) = carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)"
+  apply(rule equalityI)
+  using map_partial_pullback_memE(1) apply blast
+proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)"
+  show "x \<in> map_partial_pullback m f l (carrier (Q\<^sub>p\<^bsup>n+l\<^esup>))"
+    apply(rule map_partial_pullback_memI)
+  using A cartesian_power_drop[of x m l] take_closed assms
+   apply blast  
+proof-
+  have "f (take m x) \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    using A take_closed assms
+    by (meson Pi_mem le_add1)
+  then show "f (take m x) @ drop m x \<in> carrier (Q\<^sub>p\<^bsup>n+l\<^esup>)" 
+    using cartesian_power_drop[of x m l] A cartesian_power_concat(1)[of _ Q\<^sub>p n _ l] 
+    by blast    
+qed
+qed
+
+definition is_semialg_map where
+"is_semialg_map m n f = (f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)  \<and> 
+                          (\<forall>l \<ge> 0. \<forall>S \<in> semialg_sets (n + l). is_semialgebraic (m + l) (map_partial_pullback m f l S)))"
+
+lemma is_semialg_map_closed:
+  assumes "is_semialg_map m n f"
+  shows "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  using is_semialg_map_def assms by blast 
+
+lemma is_semialg_map_closed':
+  assumes "is_semialg_map m n f" "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "f x \<in>  carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  using is_semialg_map_def assms by blast 
+
+lemma is_semialg_mapE:
+  assumes "is_semialg_map m n f"
+  assumes "is_semialgebraic (n + k) S"
+  shows " is_semialgebraic (m + k) (map_partial_pullback m f k S)"
+  using is_semialg_map_def assms 
+  by (meson is_semialgebraicE le0)
+
+lemma is_semialg_mapE':
+  assumes "is_semialg_map m n f"
+  assumes "is_semialgebraic (n + k) S"
+  shows " is_semialgebraic (m + k) (map_partial_image m f \<inverse>\<^bsub>m+k\<^esub> S)"
+  using assms is_semialg_mapE unfolding map_partial_pullback_def
+  by blast 
+
+lemma is_semialg_mapI:
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "\<And>k  S. S \<in> semialg_sets (n + k) \<Longrightarrow> is_semialgebraic (m + k) (map_partial_pullback m f k S)"
+  shows "is_semialg_map m n f"
+  using assms unfolding is_semialg_map_def 
+  by blast
+
+lemma is_semialg_mapI':
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "\<And>k  S. S \<in> semialg_sets (n + k) \<Longrightarrow> is_semialgebraic (m + k) (map_partial_image m f \<inverse>\<^bsub>m+k\<^esub> S)"
+  shows "is_semialg_map m n f"
+  using assms is_semialg_mapI unfolding map_partial_pullback_def 
+  by blast
+
+text\<open>Semialgebraicity for functions can be verified on basic semialgebraic sets.\<close>
+
+lemma is_semialg_mapI'':
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "\<And>k  S. S \<in> basic_semialgs (n + k) \<Longrightarrow> is_semialgebraic (m + k) (map_partial_pullback m f k S)"
+  shows "is_semialg_map m n f"
+  apply(rule is_semialg_mapI)
+  using assms(1) apply blast
+proof-
+  show "\<And>k S. S \<in> semialg_sets (n + k) \<Longrightarrow> is_semialgebraic (m + k) (map_partial_pullback m f k S)"
+  proof- fix k S assume A: "S \<in> semialg_sets (n + k)"
+    show "is_semialgebraic (m + k) (map_partial_pullback m f k S)"
+      apply(rule gen_boolean_algebra.induct[of S "carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)" "basic_semialgs (n + k)"])
+        using A unfolding semialg_sets_def 
+            apply blast
+        using map_partial_pullback_carrier assms carrier_is_semialgebraic plus_1_eq_Suc apply presburger
+        apply (simp add: assms(1) assms(2) carrier_is_semialgebraic intersection_is_semialg map_partial_pullback_carrier map_partial_pullback_intersect)
+        using map_partial_pullback_union union_is_semialgebraic apply presburger
+        using assms(1) complement_is_semialg map_partial_pullback_complement plus_1_eq_Suc by presburger
+  qed
+qed      
+
+lemma is_semialg_mapI''':
+  assumes "f \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "\<And>k  S. S \<in> basic_semialgs (n + k) \<Longrightarrow> is_semialgebraic (m + k) (map_partial_image m f \<inverse>\<^bsub>m+k\<^esub> S)"
+  shows "is_semialg_map m n f"
+  using is_semialg_mapI'' assms unfolding map_partial_pullback_def 
+  by blast
+
+lemma id_is_semialg_map: 
+"is_semialg_map n n (\<lambda> x. x)"
+proof-
+  have 0: "\<And>k S. S \<in> semialg_sets (n + k) \<Longrightarrow> (\<lambda>xs. take n xs @ drop n xs) -` S \<inter> carrier (Q\<^sub>p\<^bsup>n + k\<^esup>) = 
+            S"
+    apply(rule equalityI') 
+     apply (metis (no_types, lifting) Int_iff append_take_drop_id vimage_eq)
+    by (metis (no_types, lifting) IntI append_take_drop_id in_mono is_semialgebraicI is_semialgebraic_closed vimageI)
+  show ?thesis 
+    by(intro is_semialg_mapI,
+          unfold  map_partial_pullback_def map_partial_image_def evimage_def is_semialgebraic_def  0, 
+          auto)
+qed
+
+lemma map_partial_pullback_comp:
+  assumes "is_semialg_map m n f"
+  assumes "is_semialg_map k m g"
+  shows  "(map_partial_pullback k (f \<circ> g) l S) = (map_partial_pullback k g l (map_partial_pullback m f l S))"
+proof
+  show "map_partial_pullback k (f \<circ> g) l S \<subseteq> map_partial_pullback k g l (map_partial_pullback m f l S)"
+  proof fix x assume A: " x \<in> map_partial_pullback k (f \<circ> g) l S"
+    show " x \<in> map_partial_pullback k g l (map_partial_pullback m f l S)"
+    proof(rule map_partial_pullback_memI) 
+      show 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k+l\<^esup>)"
+        using A map_partial_pullback_memE(1) by blast
+      show "g (take k x) @ drop k x \<in> map_partial_pullback m f l S"  
+      proof(rule map_partial_pullback_memI) 
+        show "g (take k x) @ drop k x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)" 
+        proof-
+          have 1: "g (take k x) \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+            using 0 assms(2) is_semialg_map_closed[of k m g] 
+            by (meson Pi_iff le_add1 take_closed)
+          then show ?thesis 
+            by (metis "0" add.commute cartesian_power_concat(2) cartesian_power_drop)
+        qed
+        show "f (take m (g (take k x) @ drop k x)) @ drop m (g (take k x) @ drop k x) \<in> S"
+        using map_partial_pullback_memE[of x k "f \<circ> g" l S] 
+          comp_apply[of f g] map_partial_image_eq[of "take k x" k "drop k x" l x "f \<circ> g"]
+        by (metis (no_types, lifting) A \<open>g (take k x) @ drop k x \<in> carrier (Q\<^sub>p\<^bsup>m + l\<^esup>)\<close> 
+            append_eq_append_conv append_take_drop_id cartesian_power_car_memE 
+            cartesian_power_drop map_partial_image_def)
+      qed
+    qed
+  qed
+  show "map_partial_pullback k g l (map_partial_pullback m f l S) \<subseteq> map_partial_pullback k (f \<circ> g) l S"
+  proof fix x assume A: "x \<in> map_partial_pullback k g l (map_partial_pullback m f l S)"
+    have 0: "(take m (map_partial_image k g x)) = g (take k x)"
+    proof-
+      have "take k x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+        using map_partial_pullback_memE[of x k g l] A le_add1 take_closed 
+        by blast
+      then have "length (g (take k x)) = m"
+        using assms is_semialg_map_closed[of k m g] cartesian_power_car_memE 
+        by blast
+      then show ?thesis
+        using assms unfolding map_partial_image_def 
+        by (metis append_eq_conv_conj)
+    qed
+    show " x \<in> map_partial_pullback k (f \<circ> g) l S"
+      apply(rule map_partial_pullback_memI)
+      using A map_partial_pullback_memE 
+       apply blast
+      using 0 assms A comp_apply map_partial_pullback_memE[of x k g l "map_partial_pullback m f l S"]
+            map_partial_pullback_memE[of "map_partial_image k g x" m f l S]
+  map_partial_image_eq[of "take k x" k "drop k x" l x g]
+   map_partial_image_eq[of "take m (map_partial_image k g x)" m "drop m (map_partial_image k g x)" l "(map_partial_image k g x)" f ]
+  by (metis (no_types, lifting) cartesian_power_drop le_add1 map_partial_image_def map_partial_pullback_memE' take_closed)
+qed
+qed
+
+lemma semialg_map_comp_closed:
+  assumes "is_semialg_map m n f"
+  assumes "is_semialg_map k m g"
+  shows "is_semialg_map k n (f \<circ> g)"
+  apply(intro is_semialg_mapI , unfold Pi_iff comp_def, intro ballI,
+        intro is_semialg_map_closed'[of m n f] is_semialg_map_closed'[of k m g]  assms, blast) 
+proof- fix l S assume A: "S \<in> semialg_sets (n + l)"  
+  have " is_semialgebraic (k + l) (map_partial_pullback k (f \<circ> g) l S)"
+    using map_partial_pullback_comp is_semialg_mapE A assms(1) assms(2) is_semialgebraicI 
+    by presburger
+  thus "is_semialgebraic (k + l) (map_partial_pullback k (\<lambda>x. f (g x)) l S)"
+    unfolding comp_def by auto 
+qed
+
+lemma partial_pullback_comp:
+  assumes "is_semialg_function m f"
+  assumes "is_semialg_map k m g"
+  shows  "(partial_pullback k (f \<circ> g) l S) = (map_partial_pullback k g l (partial_pullback m f l S))"
+proof
+  show "partial_pullback k (f \<circ> g) l S \<subseteq> map_partial_pullback k g l (partial_pullback m f l S)"
+  proof fix x assume A: "x \<in> partial_pullback k (f \<circ> g) l S"
+    show "x \<in> map_partial_pullback k g l (partial_pullback m f l S)"
+    proof(rule map_partial_pullback_memI) 
+      show 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k+l\<^esup>)"
+        using A partial_pullback_memE(1) by blast
+      show "g (take k x) @ drop k x \<in> partial_pullback m f l S"  
+      proof(rule partial_pullback_memI) 
+        show "g (take k x) @ drop k x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)" 
+        proof-
+          have 1: "g (take k x) \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+            using 0 assms(2) is_semialg_map_closed[of k m g] 
+            by (meson Pi_iff le_add1 take_closed)
+          then show ?thesis 
+            by (metis "0" add.commute cartesian_power_concat(2) cartesian_power_drop)
+        qed
+        show "f (take m (g (take k x) @ drop k x)) # drop m (g (take k x) @ drop k x) \<in> S"
+        using partial_pullback_memE[of x k "f \<circ> g" l S] 
+          comp_apply[of f g] partial_image_eq[of "take k x" k "drop k x" l x "f \<circ> g"]
+        by (metis (no_types, lifting) A \<open>g (take k x) @ drop k x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>)\<close> 
+            add_diff_cancel_left' append_eq_append_conv append_take_drop_id 
+            cartesian_power_car_memE length_drop local.partial_image_def)        
+      qed
+    qed
+  qed
+  show "map_partial_pullback k g l (partial_pullback m f l S) \<subseteq> partial_pullback k (f \<circ> g) l S"
+  proof fix x assume A: "x \<in> map_partial_pullback k g l (partial_pullback m f l S)"
+    have 0: "(take m (map_partial_image k g x)) = g (take k x)"
+    proof-
+      have "take k x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+        using map_partial_pullback_memE[of x k g l] A le_add1 take_closed 
+        by blast
+      then have "length (g (take k x)) = m"
+        using assms is_semialg_map_closed[of k m g] cartesian_power_car_memE 
+        by blast
+      then show ?thesis
+        using assms unfolding map_partial_image_def 
+        by (metis append_eq_conv_conj)
+    qed
+    show "x \<in> partial_pullback k (f \<circ> g) l S"
+      apply(rule partial_pullback_memI)
+      using A map_partial_pullback_memE 
+       apply blast
+      using 0 assms A comp_apply map_partial_pullback_memE[of x k g l "partial_pullback m f l S"]
+            partial_pullback_memE[of "map_partial_image k g x" m f l S]
+            map_partial_image_eq[of "take k x" k "drop k x" l x g]
+   partial_image_eq[of "take m (map_partial_image k g x)" m "drop m (map_partial_image k g x)" l "(map_partial_image k g x)" f ]
+  by (metis (no_types, lifting) cartesian_power_drop le_add1 map_partial_image_def partial_pullback_memE' take_closed)
+
+qed
+qed
+
+lemma semialg_function_comp_closed:
+  assumes "is_semialg_function m f"
+  assumes "is_semialg_map k m g"
+  shows "is_semialg_function k (f \<circ> g)"
+proof(rule is_semialg_functionI)
+  show "f \<circ> g \<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>)"
+    show " (f \<circ> g) x \<in> carrier Q\<^sub>p"
+      using A assms is_semialg_map_closed[of k m g ] is_semialg_function_closed[of m f] comp_apply[of f g x]
+      by (metis (no_types, lifting) Pi_mem)
+  qed
+  show " \<And>ka S. S \<in> semialg_sets (1 + ka) \<Longrightarrow> is_semialgebraic (k + ka) (partial_pullback k (f \<circ> g) ka S)"
+  proof- fix n S assume A: "S \<in> semialg_sets (1 + n)"
+    show "is_semialgebraic (k + n) (partial_pullback k (f \<circ> g) n S)"
+      using A assms partial_pullback_comp is_semialg_functionE is_semialg_mapE
+        is_semialgebraicI  by presburger
+  qed
+qed
+
+lemma semialg_map_evimage_is_semialg:
+  assumes "is_semialg_map k m g"
+  assumes "is_semialgebraic m S"
+  shows "is_semialgebraic k (g  \<inverse>\<^bsub>k\<^esub> S)"
+proof-
+  have "g  \<inverse>\<^bsub>k\<^esub> S = map_partial_pullback k g 0 S"
+  proof
+    show "g \<inverse>\<^bsub>k\<^esub> S \<subseteq> map_partial_pullback k g 0 S"
+    proof fix x assume A: "x \<in> g  \<inverse>\<^bsub>k\<^esub> S"
+      then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> g x \<in> S"
+        by (meson evimage_eq)
+      have "x = take k x @ drop k x"
+        using 0  by (simp add: "0")
+      then show "x \<in> map_partial_pullback k g 0 S"
+        unfolding map_partial_pullback_def map_partial_image_def
+        by (metis (no_types, lifting) "0" Nat.add_0_right add.commute append_Nil2 append_same_eq 
+        append_take_drop_id evimageI2 map_partial_image_def map_partial_image_eq take0 take_drop)
+    qed
+    show "map_partial_pullback k g 0 S \<subseteq> g \<inverse>\<^bsub>k\<^esub> S"
+    proof fix x assume A: "x \<in> map_partial_pullback k g 0 S " 
+      then have 0: " g (take k x) @ (drop k x) \<in> S"
+        unfolding map_partial_pullback_def map_partial_image_def
+        by blast
+      have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+        using A unfolding map_partial_pullback_def map_partial_image_def 
+        by (metis (no_types, lifting) Nat.add_0_right evimage_eq)
+      hence "take k x = x"
+        by (metis cartesian_power_car_memE le_eq_less_or_eq take_all)
+      then show " x \<in> g \<inverse>\<^bsub>k\<^esub> S"
+        using 0 1 unfolding evimage_def  
+        by (metis (no_types, lifting) IntI append.assoc append_same_eq append_take_drop_id same_append_eq vimageI)
+    qed
+  qed
+  then show ?thesis using assms 
+    by (metis add.right_neutral is_semialg_mapE' map_partial_pullback_def)
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection \<open>Examples of Semialgebraic Maps\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+lemma semialg_map_on_carrier:
+  assumes "is_semialg_map n m f"
+  assumes "restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict g (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  shows "is_semialg_map n m g"
+proof(rule is_semialg_mapI)
+  have 0: "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using assms(1) is_semialg_map_closed 
+    by blast
+  show "g \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)" then show " g x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+      using assms(2) 0 
+      by (metis (no_types, lifting) PiE restrict_Pi_cancel)
+  qed    
+  show "\<And>k S. S \<in> semialg_sets (m + k) \<Longrightarrow> is_semialgebraic (n + k) (map_partial_pullback n g k S)"
+  proof- fix k S 
+    assume A: "S \<in> semialg_sets (m + k)"
+    have 1: "is_semialgebraic (n + k) (map_partial_pullback n f k S)"
+      using A assms(1) is_semialg_mapE is_semialgebraicI 
+      by blast
+    have 2: "(map_partial_pullback n f k S) = (map_partial_pullback n g k S)"
+      unfolding map_partial_pullback_def map_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 A: "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 A
+          by (meson Int_iff le_add1 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 
+          by (metis (no_types, lifting) A Int_iff vimageE vimageI)         
+      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) (map_partial_pullback n g k S)" 
+      using 1 by auto 
+  qed
+qed
+
+lemma semialg_function_tuple_is_semialg_map:
+  assumes "is_semialg_function_tuple m fs"
+  assumes "length fs = n"
+  shows "is_semialg_map m n (function_tuple_eval Q\<^sub>p m fs)"
+  apply(rule is_semialg_mapI)
+  using function_tuple_eval_closed[of m fs] 
+  apply (metis Pi_I assms(1) assms(2) semialg_function_tuple_is_function_tuple)
+proof- fix k S assume A: "S \<in> semialg_sets (n + k)"
+  show "is_semialgebraic (m + k) (map_partial_pullback m (function_tuple_eval Q\<^sub>p m fs) k S)"
+  using is_semialg_map_tupleE[of m fs k S] assms A tuple_partial_pullback_is_semialg_map_tuple[of m fs]
+  unfolding tuple_partial_pullback_def map_partial_pullback_def
+        map_partial_image_def tuple_partial_image_def is_semialgebraic_def  
+  by (metis evimage_def)  
+qed
+
+lemma index_is_semialg_function:
+  assumes "n > k"
+  shows "is_semialg_function n (\<lambda>as. as!k)"
+proof-
+  have 0: "restrict (\<lambda>as. as!k) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict (Qp_ev (pvar Q\<^sub>p k)) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+    using assms by (metis (no_types, lifting) eval_pvar restrict_ext)    
+  have 1: "is_semialg_function n (Qp_ev (pvar Q\<^sub>p k))"
+    using pvar_closed   assms poly_is_semialg[of  "pvar Q\<^sub>p k"] by blast
+  show ?thesis 
+    using 0 1 semialg_function_on_carrier[of n "Qp_ev (pvar Q\<^sub>p k)" "(\<lambda>as. as!k)"] 
+    by presburger
+qed
+
+definition Qp_ith where 
+"Qp_ith m i = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). x!i)"
+
+lemma Qp_ith_closed: 
+  assumes "i < m"
+  shows "Qp_ith m i \<in> carrier (SA m)"
+proof(rule SA_car_memI)
+  show "Qp_ith m i \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>m\<^esup>)) Q\<^sub>p)"
+    apply(rule Qp.function_ring_car_memI[of "carrier(Q\<^sub>p\<^bsup>m\<^esup>)"])
+    using assms cartesian_power_car_memE'[of _ Q\<^sub>p m i] unfolding Qp_ith_def 
+    apply (metis restrict_apply)
+    unfolding restrict_def by meson
+  have 0: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> Qp_ith m i x = eval_at_point Q\<^sub>p  x (pvar Q\<^sub>p i)"
+    using assms eval_pvar[of i m] unfolding Qp_ith_def restrict_def by presburger
+  have 1: "is_semialg_function m (eval_at_poly Q\<^sub>p  (pvar Q\<^sub>p i))"
+    using assms pvar_closed[of i m] poly_is_semialg by blast
+  show "is_semialg_function m (local.Qp_ith m i)" 
+    apply(rule semialg_function_on_carrier'[of m "eval_at_poly Q\<^sub>p  (pvar Q\<^sub>p i)"])
+    using 1 apply blast 
+    using 0 by blast  
+qed
+
+lemma take_is_semialg_map:
+  assumes "n \<ge> k"
+  shows "is_semialg_map n k (take k)"
+proof-
+  obtain fs where fs_def: "fs = map (\<lambda>i::nat. (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). as!i)) [0::nat..< k]"
+    by blast 
+  have 0: "is_semialg_function_tuple n fs"
+  proof(rule is_semialg_function_tupleI)
+    fix f assume A: "f \<in> set fs"
+    then obtain i where i_def: "i \<in> set [0::nat..< k] \<and> f = (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). as!i)"
+      using A fs_def 
+      by (metis (no_types, lifting) in_set_conv_nth length_map nth_map)
+    have i_less: "i < k"
+    proof-
+      have "set [0::nat..< k] = {0..<k}"
+        using atLeastLessThan_upt by blast
+      then show ?thesis using i_def 
+        using atLeastLessThan_iff by blast
+    qed
+    show "is_semialg_function n f"
+      apply(rule semialg_function_on_carrier[of n "(\<lambda>as. as ! i)"], 
+            rule index_is_semialg_function[of i n ]  )
+      using A i_def assms by auto               
+  qed
+  have 1: "restrict (function_tuple_eval Q\<^sub>p n fs) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict (take k) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  unfolding function_tuple_eval_def 
+  proof fix x 
+    show " (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). map (\<lambda>f. f x) fs) x = restrict (take k) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+  proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+    case True
+    have "(map (\<lambda>f. f x) fs) = take k x"
+    proof-
+      have "\<And>i. i < k \<Longrightarrow> (map (\<lambda>f. f x) fs) ! i = x ! i"
+      proof- fix i assume A: "i < k"
+        have "length [0::nat..< k] = k"
+          using assms by simp
+        then have "length fs = k"
+          using fs_def  
+          by (metis length_map)
+        then have 0: "(map (\<lambda>f. f x) fs) ! i = (fs!i) x"
+          using A by (meson nth_map) 
+        have 1: "(fs!i) x = x!i"
+          using A nth_map[of i "[0..<k]" "(\<lambda>i. \<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). as ! i)"] True 
+          unfolding fs_def  restrict_def  by auto                  
+        then show "map (\<lambda>f. f x) fs ! i = x ! i" 
+          using 0 assms A True fs_def nth_map[of i fs] cartesian_power_car_memE[of x Q\<^sub>p n]
+          by blast
+      qed
+      then have 0: "\<And>i. i < k \<Longrightarrow> (map (\<lambda>f. f x) fs) ! i = (take k x) ! i"
+        using assms True  nth_take by blast
+      have 1: "length (map (\<lambda>f. f x) fs) = length (take k x)"
+        using fs_def True assms 
+        by (metis cartesian_power_car_memE length_map map_nth take_closed)
+      have 2: "length (take k x) = k"
+        using assms True cartesian_power_car_memE take_closed 
+        by blast
+      show ?thesis using 0 1 2 
+        by (metis nth_equalityI)
+    qed
+    then show ?thesis using True unfolding restrict_def  
+      by presburger   
+  next
+    case False
+    then show ?thesis unfolding restrict_def  
+      by (simp add: False)
+  qed
+  qed
+  have 2: " is_semialg_map n k (function_tuple_eval Q\<^sub>p n fs)"
+    using 0 semialg_function_tuple_is_semialg_map[of n fs k] assms fs_def  length_map
+    by (metis (no_types, lifting) diff_zero length_upt)
+  show ?thesis using 1 2 
+    using semialg_map_on_carrier by blast
+qed
+
+lemma drop_is_semialg_map:
+  shows "is_semialg_map (k + n) n (drop k)"
+proof-
+  obtain fs where fs_def: "fs = map (\<lambda>i::nat. (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). as!i)) [k..<n+k]"
+    by blast 
+  have 0: "is_semialg_function_tuple (k+n) fs"
+  proof(rule is_semialg_function_tupleI)
+    fix f assume A: "f \<in> set fs"
+    then obtain i where i_def: "i \<in> set [k..<n+k] \<and> f = (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). as!i)"
+      using A fs_def 
+      by (metis (no_types, lifting) in_set_conv_nth length_map nth_map)
+    have i_less: "i \<ge> k \<and> i < n + k"
+    proof-
+      have "set [k..<n+k] = {k..<n+k}"
+        using atLeastLessThan_upt by blast
+      then show ?thesis using i_def 
+        using atLeastLessThan_iff by blast
+    qed
+    have "is_semialg_function (n + k) f"
+      using A index_is_semialg_function[of i "n+k" ] 
+            i_less semialg_function_on_carrier[of "n+k" "(\<lambda>as. as ! i)" f] i_def
+            restrict_is_semialg 
+      by blast           
+    then show "is_semialg_function (k + n) f"
+      by (simp add: add.commute)
+  qed
+  have 1: "restrict (function_tuple_eval Q\<^sub>p (n+k) fs) (carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)) = restrict (drop k) (carrier (Q\<^sub>p\<^bsup>n+k\<^esup>))"
+  unfolding function_tuple_eval_def 
+  proof fix x 
+    show " (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). map (\<lambda>f. f x) fs) x = restrict (drop k) (carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)) x"
+  proof(cases "x\<in>carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)")
+    case True
+    have "(map (\<lambda>f. f x) fs) = drop k x"
+    proof-
+      have "\<And>i. i < n \<Longrightarrow> (map (\<lambda>f. f x) fs) ! i = x ! (i+k)"
+      proof- fix i assume A: "i < n"
+        have 00: "length [k..<n+k] = n"
+           by simp
+        then have "length fs = n"
+          using fs_def  
+          by (metis length_map)
+        then have 0:"(map (\<lambda>f. f x) fs) ! i = (fs!i) x"
+          using A  by (meson nth_map)          
+        have "[k..<n+k]!i = i + k"
+          by (simp add: A)
+        have "( map (\<lambda>i. \<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). as ! i) [k..<n + k]) ! i = ((\<lambda>i. \<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). as ! i) ([k..<n + k] ! i))"
+          using A 00 nth_map[of i "[k..< n + k]" "(\<lambda>i. \<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). as ! i)"] 
+          by linarith
+        then have 1: "fs!i =  (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>). as!(i+k))"
+          using fs_def A  \<open>[k..<n + k] ! i = i + k\<close> by presburger
+        then show "map (\<lambda>f. f x) fs ! i = x ! (i + k)" 
+          using True 0
+          by (metis (no_types, lifting) restrict_apply)         
+      qed
+      then have 0: "\<And>i. i < n \<Longrightarrow> (map (\<lambda>f. f x) fs) ! i = (drop k x) ! i"
+        using True  nth_drop 
+        by (metis add.commute cartesian_power_car_memE le_add2)
+      have 1: "length (map (\<lambda>f. f x) fs) = length (drop k x)"
+        using fs_def True length_drop[of k x]
+        by (metis cartesian_power_car_memE length_map length_upt)
+      have 2: "length (drop k x) = n"
+        using True cartesian_power_car_memE  
+        by (metis add_diff_cancel_right' length_drop)    
+      show ?thesis using 0 1 2 
+        by (metis nth_equalityI)
+    qed
+    then show ?thesis using True unfolding restrict_def  
+      by presburger   
+  next
+    case False
+    then show ?thesis unfolding restrict_def  
+      by (simp add: False)
+  qed
+  qed
+  have 00: "length [k..<n+k] = n"
+    by simp
+  then have "length fs = n"
+    using fs_def  
+    by (metis length_map)
+  then have 2: " is_semialg_map (k + n) n (function_tuple_eval Q\<^sub>p (k + n) fs)"
+    using 0 semialg_function_tuple_is_semialg_map[of "k + n" fs n]   
+    by blast
+  show ?thesis using 1 2
+    using semialg_map_on_carrier[of "k + n" n "function_tuple_eval Q\<^sub>p (k + n) fs" "drop k"] 
+    by (metis add.commute)    
+qed
+
+lemma project_at_indices_is_semialg_map:
+  assumes "S \<subseteq> {..<n}"
+  shows "is_semialg_map n (card S) \<pi>\<^bsub>S\<^esub>"
+proof-
+  obtain k where k_def: "k = card S"
+    by blast
+  have 0: "card {..<n} = n"
+    by simp
+  have 1: "finite S"
+    using assms finite_subset 
+    by blast
+  have 2: "card S \<le> n"
+    using assms 0 1 
+    by (metis card_mono finite_lessThan)
+  then have k_size: " k \<le> n"
+    using k_def assms 0 1 2 
+    by blast
+  obtain fs where fs_def: "fs = map (\<lambda>i::nat. (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). as!(nth_elem S i))) [0..<k]"
+    by blast 
+  have 4: "length fs = k"
+    using fs_def assms "1" k_def  
+    by (metis Ex_list_of_length length_map map_nth)   
+  have 5: "is_semialg_function_tuple n fs"
+  proof(rule is_semialg_function_tupleI)
+    fix f assume A: "f \<in> set fs"
+    then obtain i where i_def: "i \<in> set [0..<k] \<and> f = (\<lambda>as \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). as!(nth_elem S i))"
+      using A fs_def atLeast_upt "4"  in_set_conv_nth  map_eq_conv map_nth 
+      by auto
+    have i_le_k:"i < k"
+    proof-
+      have "set [0..<k] = {..<k}"
+        using atLeast_upt by blast
+      then show ?thesis
+        using i_def 
+        by blast
+    qed
+    then have i_in_S: "nth_elem S i \<in> S"
+      using "1" k_def nth_elem_closed by blast      
+    then have "nth_elem S i < n"
+      using assms 
+      by blast
+    show "is_semialg_function n f"
+      using A index_is_semialg_function[of "nth_elem S i" n]  
+            semialg_function_on_carrier[of n "(\<lambda>as. as ! nth_elem S i)"] i_def restrict_is_semialg 
+            \<open>nth_elem S i < n\<close> by blast 
+  qed
+  have 6: "restrict (function_tuple_eval Q\<^sub>p n fs) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict (\<pi>\<^bsub>S\<^esub>) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  unfolding function_tuple_eval_def 
+  proof fix x 
+    show " (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). map (\<lambda>f. f x) fs) x = restrict (\<pi>\<^bsub>S\<^esub>) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+    case True
+    have "(map (\<lambda>f. f x) fs) = \<pi>\<^bsub>S\<^esub> x"
+    proof-
+      have "\<And>i. i < k \<Longrightarrow> (map (\<lambda>f. f x) fs) ! i = (\<pi>\<^bsub>S\<^esub> x) ! i"
+      proof- fix i assume A: "i < k"
+        have T0:"(map (\<lambda>f. f x) fs) ! i = (fs!i) x"
+          using A nth_map by (metis "4")          
+        have T1: "indices_of x = {..< n}"
+          using True cartesian_power_car_memE indices_of_def 
+          by blast
+        have T2: "set (set_to_list S) \<subseteq> indices_of x"
+          using assms True  by (simp add: True "1" T1)          
+        have T3: "length x = n"
+          using True cartesian_power_car_memE by blast
+        have T4: "([0..<k] ! i) =   i"
+          using A by simp 
+        have T5: "nth_elem S i < n"
+          using assms 0 1 2 A k_def 
+          by (meson lessThan_iff nth_elem_closed subsetD)          
+        have T6: "nth_elem S ([0..<k] ! i) = nth_elem S i"
+          by (simp add: T4)
+        have T6: "(\<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). as ! nth_elem S ([0..<k] ! i)) x = x! (nth_elem S i)"
+        proof-
+          have "(\<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). as ! nth_elem S ([0..<k] ! i)) x = x! nth_elem S ([0..<k] ! i)"
+            using True restrict_def by metis 
+          then show ?thesis 
+            using A T3 T4 0 1 2 T5 T6  True 
+            by metis 
+        qed
+        have T7: " map (\<lambda>f. f x) fs ! i = x! (nth_elem S i)"
+          using fs_def T0 A nth_map[of i "[0..<k]" "(\<lambda>i. \<lambda>as\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). as ! nth_elem S i)"] 
+          by (metis "4" T6 length_map)
+        show "map (\<lambda>f. f x) fs ! i = \<pi>\<^bsub>S\<^esub> x ! i"
+          using True T0 T1 T2 fs_def 5 unfolding T7 
+          by (metis A assms(1) k_def project_at_indices_nth)                                    
+      qed
+      have 1: "length (map (\<lambda>f. f x) fs) = length (\<pi>\<^bsub>S\<^esub> x)"
+        using fs_def True assms proj_at_index_list_length[of S x] k_def  
+        by (metis "4" cartesian_power_car_memE indices_of_def length_map)         
+      have 2: "length (\<pi>\<^bsub>S\<^esub> x) = k"
+        using assms True 0 1 2
+        by (metis "4" length_map)        
+      show ?thesis using  1 2 
+        by (metis \<open>\<And>i. i < k \<Longrightarrow> map (\<lambda>f. f x) fs ! i = \<pi>\<^bsub>S\<^esub> x ! i\<close> nth_equalityI)        
+    qed
+    then show ?thesis using True unfolding restrict_def  
+      by presburger   
+    next
+    case False
+    then show ?thesis unfolding restrict_def  
+      by (simp add: False)
+    qed
+  qed
+  have 7: " is_semialg_map n k (function_tuple_eval Q\<^sub>p n fs)"
+    using 0 semialg_function_tuple_is_semialg_map[of n fs k] assms fs_def  length_map "4" "5" k_size 
+    by blast
+  show ?thesis using 6 7 
+    using semialg_map_on_carrier k_def 
+    by blast    
+qed
+
+lemma tl_is_semialg_map:
+  shows "is_semialg_map (Suc n) n tl"
+proof-
+  have 0: "(card {1..<Suc n}) = n"
+  proof-
+    have "Suc n - 1 = n"
+      using diff_Suc_1 by blast
+    then show ?thesis 
+      by simp
+  qed   
+  have 3: "{1..<Suc n} \<subseteq> {..<Suc n}"
+    using atLeastLessThan_iff by blast
+  have 4: " is_semialg_map (Suc n) n (project_at_indices {1..<Suc n})"
+    using 0 project_at_indices_is_semialg_map 
+    by (metis "3")   
+  show ?thesis
+    using 0 3 4 
+        semialg_map_on_carrier[of "Suc n" n "(project_at_indices {1..<Suc n})" tl] 
+    unfolding restrict_def
+    by (metis (no_types, lifting) tl_as_projection)
+qed
+
+text\<open>Coordinate functions are semialgebraic maps.\<close>
+
+lemma coord_fun_is_SA:
+  assumes "is_semialg_map n m g"
+  assumes "i < m"
+  shows "coord_fun Q\<^sub>p n g i \<in> carrier (SA n)"
+proof(rule SA_car_memI)
+  show "coord_fun Q\<^sub>p n g i \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) Q\<^sub>p)"
+    apply(rule Qp.function_ring_car_memI)
+    unfolding coord_fun_def using assms 
+     apply (metis (no_types, lifting) Pi_iff cartesian_power_car_memE' is_semialg_map_closed restrict_apply')
+      by (meson restrict_apply)
+  show "is_semialg_function n (coord_fun Q\<^sub>p n g i)"
+  proof-
+    have 0: "is_semialg_function m (\<lambda> x. x ! i)"
+      using assms gr_implies_not0 index_is_semialg_function by blast
+    have 1: "(coord_fun Q\<^sub>p n g i) = restrict ((\<lambda>x.  x ! i) \<circ> g) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) "
+      unfolding coord_fun_def using comp_apply 
+      by metis 
+    show ?thesis 
+      using semialg_function_on_carrier[of n "((\<lambda>x. x ! i) \<circ> g)" "coord_fun Q\<^sub>p n g i"]
+             assms semialg_function_comp_closed[of m "\<lambda>x. x ! i" n g] assms 0 1
+      unfolding coord_fun_def 
+      using restrict_is_semialg by presburger
+  qed
+qed
+
+lemma coord_fun_map_is_semialg_tuple:
+  assumes "is_semialg_map n m g"
+  shows "is_semialg_function_tuple n (map (coord_fun Q\<^sub>p n g) [0..<m])"
+proof(rule is_semialg_function_tupleI)
+  have 0: "set [0..<m] = {..<m}"
+    using atLeast_upt by blast
+  fix f assume A: "f \<in> set (map (coord_fun Q\<^sub>p n g) [0..<m])"
+  then obtain i where i_def: "i < m \<and> f = coord_fun Q\<^sub>p n g i"
+    using set_map[of "coord_fun Q\<^sub>p n g" "[0..<m]"] 0 
+    by (metis image_iff lessThan_iff)
+  show " is_semialg_function n f"
+  using i_def A assms coord_fun_is_SA[of n m g i] SA_imp_semialg by blast
+qed
+
+lemma semialg_map_cons:
+  assumes "is_semialg_map n m g"
+  assumes "f \<in> carrier (SA n)"
+  shows "is_semialg_map n (Suc m) (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x # g x)"
+proof-
+  obtain Fs where Fs_def: "Fs = f # (map (coord_fun Q\<^sub>p n g) [0..<m])"
+    by blast 
+  have 0: "is_semialg_function_tuple n Fs"
+    apply(rule  is_semialg_function_tupleI)
+    using is_semialg_function_tupleE'[of n "map (coord_fun Q\<^sub>p n g) [0..<m]"] 
+          coord_fun_map_is_semialg_tuple[of n m g] assms SA_car_memE(1)[of f n]
+          set_ConsD[of _ f "map (coord_fun Q\<^sub>p n g) [0..<m]"] assms
+    unfolding Fs_def by blast
+  have 1: "(\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x # g x) = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). function_tuple_eval Q\<^sub>p n Fs x)"
+  proof(rule ext) fix x show "(\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x # g x) x = restrict (function_tuple_eval Q\<^sub>p n Fs) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+      case True then have T0: "(\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x # g x) x = f x # g x"
+        by (meson restrict_apply')
+      have T1: "restrict (function_tuple_eval Q\<^sub>p n Fs) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = function_tuple_eval Q\<^sub>p n Fs x"
+        using True by (meson restrict_apply')
+      hence T2: "restrict (function_tuple_eval Q\<^sub>p n Fs) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = f x # (function_tuple_eval Q\<^sub>p n (map (coord_fun Q\<^sub>p n g) [0..<m]) x)"
+        unfolding function_tuple_eval_def Fs_def by (metis (no_types, lifting) list.simps(9))
+      have T3: "g x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+        using assms True is_semialg_map_closed by blast 
+      have "length [0..<m] = m"
+        by auto 
+      hence T4: "length (map (coord_fun Q\<^sub>p n g) [0..<m]) = m"
+        using length_map[of "(coord_fun Q\<^sub>p n g)" "[0..<m]"] by metis  
+      hence T5: "length (function_tuple_eval Q\<^sub>p n (map (coord_fun Q\<^sub>p n g) [0..<m]) x) = m"
+        unfolding function_tuple_eval_def using length_map by metis
+      have T6: "(function_tuple_eval Q\<^sub>p n (map (coord_fun Q\<^sub>p n g) [0..<m]) x) = g x"
+        apply(rule nth_equalityI) using T3 T5 
+          using cartesian_power_car_memE apply blast
+          using cartesian_power_car_memE[of "g x" Q\<^sub>p m]  T5 T4  T3 True  
+                nth_map[of _ "(map (\<lambda>i. \<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). g x ! i) [0..<m])" "(\<lambda>f. f x)"]
+                nth_map[of _ "[0..<m]" "(\<lambda>i. \<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). g x ! i)"]
+          unfolding function_tuple_eval_def  coord_fun_def restrict_def 
+          by (metis (no_types, lifting) \<open>length [0..<m] = m\<close> map_nth nth_map)
+      hence T7: "restrict (function_tuple_eval Q\<^sub>p n Fs) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = f x # g x"
+        using T4 T2 by presburger
+      thus ?thesis using T0
+        by presburger
+    next
+      case False
+      then show ?thesis unfolding restrict_def 
+        by metis  
+    qed
+  qed
+  have 2: "length Fs = Suc m"
+    unfolding Fs_def using length_map[of "(coord_fun Q\<^sub>p n g)" "[0..<m]"] length_Cons[of f "map (coord_fun Q\<^sub>p n g) [0..<m]"]
+    using length_upt by presburger    
+  have 3: "is_semialg_map n (Suc m) (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). function_tuple_eval Q\<^sub>p n Fs x)"
+    apply(rule semialg_map_on_carrier[of _ _  "function_tuple_eval Q\<^sub>p n Fs"], 
+          intro semialg_function_tuple_is_semialg_map[of n Fs "Suc m"] 0 2)
+    by auto 
+  show ?thesis using 1 3
+    by presburger  
+qed
+
+text\<open>Extensional Semialgebraic Maps:\<close>
+
+definition semialg_maps where
+"semialg_maps n m \<equiv> {f. is_semialg_map n m f \<and> f \<in> struct_maps (Q\<^sub>p\<^bsup>n\<^esup>) (Q\<^sub>p\<^bsup>m\<^esup>)}"
+
+lemma semialg_mapsE:
+  assumes "f \<in> (semialg_maps n m)"
+  shows "is_semialg_map n m f"
+        "f \<in> struct_maps (Q\<^sub>p\<^bsup>n\<^esup>) (Q\<^sub>p\<^bsup>m\<^esup>)"
+        "f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  using assms unfolding semialg_maps_def apply blast 
+  using assms unfolding semialg_maps_def apply blast 
+  apply(rule is_semialg_map_closed)
+  using assms unfolding semialg_maps_def by blast 
+
+definition to_semialg_map where 
+"to_semialg_map n m f = restrict f (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+
+lemma to_semialg_map_is_semialg_map:
+  assumes "is_semialg_map n m f"
+  shows "to_semialg_map n m f \<in> semialg_maps n m"
+  using assms unfolding to_semialg_map_def semialg_maps_def struct_maps_def mem_Collect_eq
+  using is_semialg_map_closed' semialg_map_on_carrier by force
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Application of Functions to Segments of Tuples\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition take_apply where
+"take_apply m n f = restrict (f \<circ> take n) (carrier (Q\<^sub>p\<^bsup>m\<^esup>))"
+
+definition drop_apply where
+"drop_apply m n f = restrict (f \<circ> drop n) (carrier (Q\<^sub>p\<^bsup>m\<^esup>))"
+
+lemma take_apply_closed:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  assumes "k \<ge> n"
+  shows "take_apply k n f \<in> carrier (Fun\<^bsub>k\<^esub> Q\<^sub>p)"
+proof(rule Qp.function_ring_car_memI)
+  show  "\<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<Longrightarrow> take_apply k n f a \<in> carrier Q\<^sub>p"
+  proof-  fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)" show "take_apply k n f a \<in> carrier Q\<^sub>p"
+      using A assms comp_apply[of f "take n" a] Qp.function_ring_car_memE[of f n] take_closed[of n k a]
+      unfolding take_apply_def restrict_def 
+      by metis
+  qed
+  show " \<And>a. a \<notin> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<Longrightarrow> take_apply k n f a = undefined"
+    unfolding take_apply_def restrict_def 
+    by meson
+qed 
+
+lemma take_apply_SA_closed:
+  assumes "f \<in> carrier (SA n)"
+  assumes "k \<ge> n"
+  shows "take_apply k n f \<in> carrier (SA k)"
+  apply(rule SA_car_memI)
+  using SA_car_memE(2) assms(1) assms(2) take_apply_closed apply blast
+  using assms take_is_semialg_map[of n k] unfolding take_apply_def 
+  by (metis padic_fields.SA_imp_semialg 
+      padic_fields_axioms restrict_is_semialg semialg_function_comp_closed)
+  
+lemma drop_apply_closed:
+  assumes "f \<in> carrier (Fun\<^bsub>k - n\<^esub> Q\<^sub>p)"
+  assumes "k \<ge> n"
+  shows "drop_apply k n f \<in> carrier (Fun\<^bsub>k\<^esub> Q\<^sub>p)"
+proof(rule Qp.function_ring_car_memI)
+  show  " \<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<Longrightarrow> drop_apply k n f a \<in> carrier Q\<^sub>p"
+  proof-  fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)" show "drop_apply k n f a \<in> carrier Q\<^sub>p"
+      using A assms comp_apply[of f "drop n" a] Qp.function_ring_car_memE[of f ] drop_closed[of n k a Q\<^sub>p]
+      unfolding drop_apply_def restrict_def 
+      by (metis (no_types, opaque_lifting) Qp.function_ring_car_memE add_diff_cancel_right' 
+          cartesian_power_drop dec_induct diff_diff_cancel diff_less_Suc diff_less_mono2 
+          infinite_descent le_neq_implies_less less_antisym linorder_neqE_nat not_less0 not_less_eq_eq)      
+  qed
+  show " \<And>a. a \<notin> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<Longrightarrow> drop_apply k n f a = undefined"
+    unfolding drop_apply_def restrict_def 
+    by meson
+qed 
+  
+lemma drop_apply_SA_closed:
+  assumes "f \<in> carrier (SA (k-n))"
+  assumes "k \<ge> n"
+  shows "drop_apply k n f \<in> carrier (SA k)"
+  apply(rule SA_car_memI)
+  using SA_car_memE(2) assms(1) assms(2) drop_apply_closed less_imp_le_nat apply blast 
+  using assms drop_is_semialg_map[of n "k - n" ] semialg_function_comp_closed[of "k - n" f k "drop n"] unfolding drop_apply_def 
+  by (metis (no_types, lifting) SA_imp_semialg le_add_diff_inverse  restrict_is_semialg)
+
+lemma take_apply_apply:
+  assumes "f \<in> carrier (SA n)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+  shows "take_apply (n+k) n f (a@b) = f a"
+proof-
+  have "a@b \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+    using assms cartesian_power_concat(1) by blast
+  thus ?thesis 
+    unfolding take_apply_def restrict_def 
+    using assms cartesian_power_car_memE comp_apply[of f "take n"]  
+    by (metis append_eq_conv_conj)
+qed
+
+lemma drop_apply_apply:
+  assumes "f \<in> carrier (SA k)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+  shows "drop_apply (n+k) n f (a@b) = f b"
+proof-
+  have "a@b \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+    using assms cartesian_power_concat(1) by blast
+  thus ?thesis 
+    unfolding drop_apply_def  restrict_def 
+    using assms cartesian_power_car_memE comp_apply[of f "drop n"]  
+    by (metis append_eq_conv_conj)
+qed
+
+lemma drop_apply_add:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  shows "drop_apply (n+k) k (f \<oplus>\<^bsub>SA n\<^esub> g) = drop_apply (n+k) k f \<oplus>\<^bsub>SA (n + k)\<^esub> drop_apply (n+k) k g"
+  apply(rule function_ring_car_eqI[of _ "n + k"])
+  using drop_apply_SA_closed  assms fun_add_closed SA_car_memE(2) SA_plus diff_add_inverse2 drop_apply_closed le_add2 apply presburger
+  using drop_apply_SA_closed assms fun_add_closed SA_car_memE(2) SA_plus diff_add_inverse2 drop_apply_closed le_add2 apply presburger
+proof-
+  fix a  assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+  then obtain  b c where bc_def: "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> c \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> a  =  b@c"
+    by (metis (no_types, lifting) add.commute cartesian_power_decomp)
+  have 0: "drop_apply (n + k) k (f \<oplus>\<^bsub>SA n\<^esub> g) a = f c \<oplus> g c"
+    using assms  bc_def drop_apply_apply[of "f \<oplus>\<^bsub>SA n\<^esub> g" n b k c ] 
+    by (metis SA_add SA_imp_semialg add.commute padic_fields.SA_add_closed_left padic_fields_axioms)
+  then show " drop_apply (n + k) k (f \<oplus>\<^bsub>SA n\<^esub> g) a = (drop_apply (n + k) k f \<oplus>\<^bsub>SA (n + k)\<^esub> drop_apply (n + k) k g) a"
+    using bc_def drop_apply_apply assms 
+    by (metis A SA_add add.commute)
+qed
+    
+lemma drop_apply_mult:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  shows "drop_apply (n+k) k (f \<otimes> \<^bsub>SA n\<^esub> g) = drop_apply (n+k) k f \<otimes>\<^bsub>SA (n + k)\<^esub> drop_apply (n+k) k g"
+  apply(rule function_ring_car_eqI[of _ "n + k"])
+  using drop_apply_SA_closed  assms fun_mult_closed SA_car_memE(2) SA_times diff_add_inverse2 drop_apply_closed le_add2 apply presburger
+  using drop_apply_SA_closed assms fun_mult_closed SA_car_memE(2)  SA_times diff_add_inverse2 drop_apply_closed le_add2 apply presburger
+proof-
+  fix a  assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+  then obtain  b c where bc_def: "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> c \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> a  =  b@c"
+    by (metis (no_types, lifting) add.commute cartesian_power_decomp)
+  have 0: "drop_apply (n + k) k (f \<otimes>\<^bsub>SA n\<^esub> g) a = f c \<otimes> g c"
+    using assms  bc_def drop_apply_apply[of "f \<otimes>\<^bsub>SA n\<^esub> g" n b k c ] 
+    by (metis SA_imp_semialg SA_mult SA_mult_closed_right add.commute)    
+  then show " drop_apply (n + k) k (f \<otimes>\<^bsub>SA n\<^esub> g) a = (drop_apply (n + k) k f \<otimes>\<^bsub>SA (n + k)\<^esub> drop_apply (n + k) k g) a"
+    using bc_def drop_apply_apply assms by (metis A SA_mult add.commute)
+qed
+
+lemma drop_apply_one:
+  shows "drop_apply (n+k) k \<one>\<^bsub>SA n\<^esub> = \<one>\<^bsub>SA (n+k)\<^esub>"
+  apply(rule function_ring_car_eqI[of _  "n + k"])
+  apply (metis function_one_closed SA_one add_diff_cancel_right' drop_apply_closed le_add2)
+  using function_one_closed SA_one apply presburger  
+proof-
+  fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+  show "drop_apply (n + k) k \<one>\<^bsub>SA n\<^esub> a = \<one>\<^bsub>SA (n + k)\<^esub> a"
+  unfolding drop_apply_def restrict_def 
+  using  SA_one[of "n+k"] SA_one[of n] comp_apply[of "\<one>\<^bsub>SA n\<^esub>" "drop k" a] drop_closed[of k "n+k" a Q\<^sub>p]  
+        function_ring_defs(4)
+  unfolding function_one_def 
+  by (metis A function_one_eval add.commute cartesian_power_drop)
+qed
+
+lemma drop_apply_is_hom:
+  shows "drop_apply (n + k) k \<in> ring_hom (SA n) (SA (n + k))"
+  apply(rule ring_hom_memI)
+  using drop_apply_SA_closed[of _ "k+n" k]  
+  apply (metis add.commute add_diff_cancel_left' le_add1)    
+  using drop_apply_mult apply blast
+   using drop_apply_add apply blast
+     using drop_apply_one by blast
+
+lemma take_apply_add:
+  assumes "f \<in> carrier (SA k)"
+  assumes "g \<in> carrier (SA k)"
+  shows "take_apply (n+k) k (f \<oplus>\<^bsub>SA k\<^esub> g) = take_apply (n+k) k f \<oplus>\<^bsub>SA (n + k)\<^esub> take_apply (n+k) k g"
+  apply(rule function_ring_car_eqI[of _ "n + k"])
+  using take_apply_SA_closed  assms fun_add_closed SA_car_memE(2) SA_plus diff_add_inverse2 take_apply_closed le_add2 apply presburger
+  using take_apply_SA_closed assms fun_add_closed SA_car_memE(2) SA_plus diff_add_inverse2 take_apply_closed le_add2 apply presburger
+proof-
+  fix a  assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+  then obtain  b c where bc_def: "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> c \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> a  =  b@c"
+    by (metis (no_types, lifting) add.commute cartesian_power_decomp)
+  hence 0: "take_apply (n + k) k (f \<oplus>\<^bsub>SA k\<^esub> g) a =  f b \<oplus> g b"
+    using assms bc_def take_apply_apply[of "f \<oplus>\<^bsub>SA k\<^esub> g" k b c ] 
+    by (metis SA_add SA_imp_semialg add.commute padic_fields.SA_add_closed_left padic_fields_axioms)
+  then show "take_apply (n + k) k (f \<oplus>\<^bsub>SA k\<^esub> g) a = (take_apply (n + k) k f \<oplus>\<^bsub>SA (n + k)\<^esub> take_apply (n + k) k g) a"
+    using bc_def take_apply_apply assms 
+    by (metis A SA_add add.commute)
+qed
+    
+lemma take_apply_mult:
+  assumes "f \<in> carrier (SA k)"
+  assumes "g \<in> carrier (SA k)"
+  shows "take_apply (n+k) k (f \<otimes>\<^bsub>SA k\<^esub> g) = take_apply (n+k) k f \<otimes>\<^bsub>SA (n + k)\<^esub> take_apply (n+k) k g"
+  apply(rule function_ring_car_eqI[of _ "n + k"])
+  using take_apply_SA_closed  assms fun_mult_closed SA_car_memE(2) SA_times diff_add_inverse2 take_apply_closed le_add2 apply presburger
+  using take_apply_SA_closed assms fun_mult_closed SA_car_memE(2) SA_times diff_add_inverse2 take_apply_closed le_add2 apply presburger
+proof-
+  fix a  assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+  then obtain  b c where bc_def: "b \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> c \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<and> a  =  b@c"
+    by (metis (no_types, lifting) add.commute cartesian_power_decomp)
+  hence 0: "take_apply (n + k) k (f \<otimes>\<^bsub>SA k\<^esub> g) a =  f b \<otimes> g b"
+    using assms bc_def take_apply_apply[of "f \<otimes>\<^bsub>SA k\<^esub> g" k b c ] 
+    by (metis SA_mult SA_imp_semialg add.commute padic_fields.SA_mult_closed_left padic_fields_axioms)
+  then show "take_apply (n + k) k (f \<otimes>\<^bsub>SA k\<^esub> g) a = (take_apply (n + k) k f \<otimes>\<^bsub>SA (n + k)\<^esub> take_apply (n + k) k g) a"
+    using bc_def take_apply_apply assms 
+    by (metis A SA_mult add.commute)
+qed
+
+lemma take_apply_one:
+  shows "take_apply (n+k) k \<one>\<^bsub>SA k\<^esub> = \<one>\<^bsub>SA (n+k)\<^esub>"
+  apply(rule function_ring_car_eqI[of _  "n + k"])
+  using function_one_closed SA_one le_add2 take_apply_closed apply presburger
+  using function_one_closed SA_one apply presburger
+proof-
+  fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+  show "take_apply (n + k) k \<one>\<^bsub>SA k\<^esub> a = \<one>\<^bsub>SA (n + k)\<^esub> a"
+  unfolding take_apply_def restrict_def 
+  using  SA_one[of "n+k"] SA_one[of k] comp_apply[of "\<one>\<^bsub>SA k\<^esub>" "take k" a] take_closed[of k "n + k" a] 
+        function_ring_defs(4)
+  unfolding function_one_def 
+  using A function_one_eval le_add2 by metis 
+qed
+
+lemma take_apply_is_hom:
+  shows "take_apply (n + k) k \<in> ring_hom (SA k) (SA (n + k))"
+  apply(rule ring_hom_memI)
+  using take_apply_SA_closed[of _ k "n+k"]  le_add2 apply blast  
+  using   take_apply_mult apply blast
+   using   take_apply_add apply blast
+     using   take_apply_one by blast
+
+lemma drop_apply_units:
+  assumes "f \<in> Units (SA n)"
+  shows "drop_apply (n+k) k f \<in> Units (SA (n+k))"
+  apply(rule SA_Units_memI)
+  using drop_apply_SA_closed[of f "n+k" k ] assms SA_Units_closed 
+  apply (metis add_diff_cancel_right' le_add2)
+proof-
+  show "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>n + k\<^esup>) \<Longrightarrow> drop_apply (n + k) k f x \<noteq> \<zero>"
+  proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+    then have "drop_apply (n + k) k f x = f (drop k x)"
+      unfolding drop_apply_def restrict_def by (meson comp_def)
+    then show "drop_apply (n + k) k f x \<noteq> \<zero>"
+      using SA_Units_memE'[of f n "drop k x"] 
+      by (metis A add.commute assms  cartesian_power_drop)
+  qed
+qed
+
+lemma take_apply_units:
+  assumes "f \<in> Units (SA k)"
+  shows "take_apply (n+k) k f \<in> Units (SA (n+k))"
+  apply(rule SA_Units_memI)
+  using take_apply_SA_closed[of f k "n+k" ] assms SA_Units_closed le_add2 apply blast
+proof-
+  show "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>n + k\<^esup>) \<Longrightarrow> take_apply (n + k) k f x \<noteq> \<zero>"
+  proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+    then have "take_apply (n + k) k f x = f (take k x)"
+      unfolding take_apply_def restrict_def by (meson comp_def)
+    then show "take_apply (n + k) k f x \<noteq> \<zero>"
+      using SA_Units_memE'[of f k "take k x"]  A assms le_add2 local.take_closed by blast      
+  qed
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Level Sets of Semialgebraic Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+lemma evimage_is_semialg:
+  assumes "h \<in> carrier (SA n)" 
+  assumes "is_univ_semialgebraic S"
+  shows "is_semialgebraic n (h  \<inverse>\<^bsub>n\<^esub> S)"
+proof-
+  have 0: "is_semialgebraic 1 (to_R1 ` S)"
+    using assms is_univ_semialgebraicE by blast
+  have 1: "h  \<inverse>\<^bsub>n\<^esub> S = partial_pullback n h (0::nat) (to_R1 ` S)"
+  proof show "h \<inverse>\<^bsub>n\<^esub> S \<subseteq> partial_pullback n h 0 ((\<lambda>a. [a]) ` S)"
+    proof fix x assume A: "x \<in> h \<inverse>\<^bsub>n\<^esub> S"
+      then have 0: "h x \<in> S" by blast
+      have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+        by (meson A evimage_eq)
+      have 1: "drop n x = []"
+        using cartesian_power_car_memE[of x Q\<^sub>p n] drop_all x_closed 
+        by blast
+      have 2: "take n x = x"
+        using cartesian_power_car_memE[of x Q\<^sub>p n] x_closed take_all 
+        by blast
+      then show "x \<in> partial_pullback n h 0 ((\<lambda>a. [a]) ` S)"
+        unfolding partial_pullback_def partial_image_def evimage_def 
+        using 0 1 2 x_closed 
+        by (metis (no_types, lifting) IntI Nat.add_0_right image_iff vimageI)
+    qed
+    show "partial_pullback n h 0 ((\<lambda>a. [a]) ` S) \<subseteq> h \<inverse>\<^bsub>n\<^esub> S"
+    proof fix x assume A: "x \<in> partial_pullback n h 0 ((\<lambda>a. [a]) ` S)"
+      have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+        using A unfolding partial_pullback_def evimage_def 
+        by (metis A Nat.add_0_right partial_pullback_memE(1))
+      then have "(partial_image n h) x = [h x]" 
+        unfolding partial_image_def 
+        by (metis (no_types, opaque_lifting) One_nat_def Qp.zero_closed append.right_neutral append_Nil 
+            local.partial_image_def partial_image_eq segment_in_car' Qp.to_R1_closed)
+      then have "h x \<in> S"
+        using A unfolding partial_pullback_def 
+        by (metis (no_types, lifting) A image_iff partial_pullback_memE(2) Qp.to_R_to_R1)
+      thus "x \<in> h \<inverse>\<^bsub>n\<^esub> S"
+        using x_closed by blast
+    qed
+  qed
+  then show ?thesis 
+    using 0 is_semialg_functionE[of n h 0 "((\<lambda>a. [a]) ` S)"] assms SA_car_memE(1)[of h n]
+    by (metis Nat.add_0_right SA_car)
+qed
+
+lemma semialg_val_ineq_set_is_semialg:
+  assumes "g \<in> carrier (SA k)"
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)}"
+proof-
+  obtain F where F_def: "F = function_tuple_eval Q\<^sub>p  k [f, g]"
+    by blast 
+  have P0: "is_semialg_function_tuple k [f, g] "
+    using is_semialg_function_tupleI[of "[f, g]" k]
+    by (metis assms  list.distinct(1) list.set_cases padic_fields.SA_imp_semialg padic_fields_axioms set_ConsD)
+  hence P1: "is_semialg_map k 2 F"
+    using  assms semialg_function_tuple_is_semialg_map[of k "[f, g]" 2]
+    unfolding F_def by (simp add: \<open>f \<in> carrier (SA k)\<close> \<open>g \<in> carrier (SA k)\<close>)
+  have "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)} = F  \<inverse>\<^bsub>k\<^esub> val_relation_set"
+  proof
+    show "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)} \<subseteq> F \<inverse>\<^bsub>k\<^esub> val_relation_set"
+    proof fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)}"
+      then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> val (g x) \<le> val (f x)" by blast
+      have 1: "F x = [f x, g x]"
+        unfolding F_def using A unfolding function_tuple_eval_def  
+        by (metis (no_types, lifting) list.simps(8) map_eq_Cons_conv)
+      have 2: "val (g x) \<le> val (f x)"
+        using A 
+        by blast
+      have 3: "F x \<in> carrier (Q\<^sub>p\<^bsup>2\<^esup>)"
+        using assms A 1 
+        by (metis (no_types, lifting) "0" Qp.function_ring_car_mem_closed Qp_2I SA_car_memE(2))
+      then have 4: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> F x \<in> val_relation_set"
+        unfolding val_relation_set_def F_def using 0 1 2 3 
+        by (metis (no_types, lifting) cartesian_power_car_memE cartesian_power_car_memE' 
+            list.inject local.F_def one_less_numeral_iff pair_id semiring_norm(76) val_relation_setI 
+            val_relation_set_def zero_less_numeral)
+      then show "x \<in> F \<inverse>\<^bsub>k\<^esub> val_relation_set"
+        by blast
+    qed
+    show "F \<inverse>\<^bsub>k\<^esub> val_relation_set \<subseteq> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)}"
+    proof fix x assume A: "x \<in> F \<inverse>\<^bsub>k\<^esub> val_relation_set"
+      then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> F x \<in> val_relation_set"
+        by (meson evimage_eq)
+      then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> [f x, g x] \<in> val_relation_set"
+        unfolding F_def function_tuple_eval_def 
+        by (metis (no_types, lifting) list.simps(8) list.simps(9))
+      then have "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> val (g x) \<le> val (f x)"
+        unfolding F_def val_relation_set_def 
+        by (metis (no_types, lifting) "0" list.inject val_relation_setE)
+      then show "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)}"
+        by blast
+    qed
+  qed
+  then show ?thesis 
+    using assms P0 P1 val_relation_is_semialgebraic semialg_map_evimage_is_semialg[of k 2 F val_relation_set] pos2 
+    by presburger
+qed
+
+lemma semialg_val_ineq_set_is_semialg':
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> C}"
+proof-
+  obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> val a = C"
+    by (meson Qp.carrier_not_empty Qp.minus_closed dist_nonempty' equals0I)
+  then obtain g where g_def: "g = constant_function (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) a"
+    by blast 
+  have 0: "g \<in> carrier (SA k)"
+    using g_def a_def SA_car assms(1) constant_function_in_semialg_functions by blast  
+  have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> val (g x)}"
+    using g_def by (metis (no_types, lifting) Qp_constE a_def)
+  then show ?thesis using assms 0 semialg_val_ineq_set_is_semialg[of f k g] 
+    by presburger
+qed
+
+lemma semialg_val_ineq_set_is_semialg'':
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<ge> C}"
+proof-
+  obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> val a = C"
+    by (meson Qp.carrier_not_empty Qp.minus_closed dist_nonempty' equals0I)
+  then obtain g where g_def: "g = constant_function (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) a"
+    by blast 
+  have 0: "g \<in> carrier (SA k)"
+    using g_def a_def SA_car assms(1) constant_function_in_semialg_functions by blast  
+  have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<ge> C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<ge> val (g x)}"
+    using g_def by (metis (no_types, lifting) Qp_constE a_def)
+  then show ?thesis using assms 0 semialg_val_ineq_set_is_semialg[of g k f] 
+    by presburger
+qed
+
+lemma semialg_level_set_is_semialg:
+  assumes "f \<in> carrier (SA k)"
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). f x = c}"
+proof-
+  have 0: "is_univ_semialgebraic {c}"
+    apply(rule finite_is_univ_semialgebraic) using assms apply blast by auto 
+  have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). f x = c} = f  \<inverse>\<^bsub>k\<^esub> {c}"
+    unfolding evimage_def by auto 
+  then show ?thesis using 0 assms evimage_is_semialg by presburger
+qed
+
+lemma semialg_val_eq_set_is_semialg':
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C}"
+proof(cases "C = \<infinity>")
+  case True
+  then have "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). f x = \<zero>}"
+    using assms unfolding val_def by (meson eint.distinct(1))
+  then have "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C} = f  \<inverse>\<^bsub>k\<^esub> {\<zero>}"
+    unfolding evimage_def by blast 
+  then show ?thesis 
+    using assms semialg_level_set_is_semialg[of f k \<zero>]  Qp.zero_closed \<open>{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). f x = \<zero>}\<close> by presburger
+next
+  case False
+  then obtain N::int where N_def: "C = eint N"
+    by blast
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> N} - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> (eint (N-1))}"
+  proof 
+    show "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C} \<subseteq> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> N} - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> (eint (N-1))}"
+    proof
+      fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C}"
+      then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> val (f x) = C"
+        by blast 
+      have 1: "\<not> val (f x) \<le> (eint (N-1))"
+        using A N_def assms 0 eint_ord_simps(1) by presburger
+      have 2: "val (f x) \<le> (eint N)"
+        using 0 N_def eint_ord_simps(1) by presburger
+      show "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> N} - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> (eint (N-1))}"
+        using 0 1 2
+        by blast 
+    qed
+    show  "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> N} - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> (eint (N-1))} \<subseteq>  {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C}"
+    proof fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> N} - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> (eint (N-1))}"
+      have 0:  "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<and> val (f x) \<le> C" 
+        using A N_def by blast      
+      have 1: "\<not> val (f x) \<le> (eint (N-1))"
+        using A 0  by blast
+      have 2: "val (f x) = C"
+      proof(rule ccontr)
+        assume "val (f x) \<noteq> C"
+        then have "val (f x) < C"
+          using 0 by auto 
+        then obtain M where M_def: "val (f x) = eint M"
+          using N_def eint_iless by blast
+        then have "M < N"
+          by (metis N_def \<open>val (f x) < C\<close> eint_ord_simps(2))
+        then have "val (f x) \<le> eint (N - 1)"
+          using M_def eint_ord_simps(1) by presburger
+        then show False using 1 by blast 
+      qed
+      show "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) = C} "
+        using 0 2  by blast        
+    qed
+  qed
+  have 1: "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> N}"
+    using assms semialg_val_ineq_set_is_semialg'[of f k N] by blast 
+  have 2: "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> (eint (N-1))}"
+    using assms semialg_val_ineq_set_is_semialg' by blast  
+  show ?thesis using 0 1 2 
+    using diff_is_semialgebraic by presburger
+qed
+
+lemma semialg_val_eq_set_is_semialg:
+  assumes "g \<in> carrier (SA k)"
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) = val (f x)}"
+proof-
+  have 0: "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)}"
+    using assms semialg_val_ineq_set_is_semialg[of g k f] by blast 
+  have 1: "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<ge> val (f x)}"
+    using assms semialg_val_ineq_set_is_semialg[of f k g] by blast 
+  have 2: " {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) = val (f x)} =  {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)} \<inter> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<ge> val (f x)}"
+    using eq_iff by blast 
+  show ?thesis using 0 1 2 intersection_is_semialg by presburger
+qed
+
+lemma semialg_val_strict_ineq_set_formula:
+"{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) < val (f x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)} - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) = val (f x)}"
+  using neq_iff le_less by blast 
+
+lemma semialg_val_ineq_set_complement:
+"carrier (Q\<^sub>p\<^bsup>k\<^esup>) - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) \<le> val (f x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) < val (g x)}"
+  using not_le by blast 
+
+lemma semialg_val_strict_ineq_set_complement:
+"carrier (Q\<^sub>p\<^bsup>k\<^esup>) - {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) < val (f x)} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) \<le> val (g x)}"
+  using not_le by blast
+
+lemma semialg_val_strict_ineq_set_is_semialg:
+  assumes "g \<in> carrier (SA k)"
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (g x) < val (f x)}"
+  using semialg_val_ineq_set_complement[of k f g] assms diff_is_semialgebraic 
+        semialg_val_ineq_set_is_semialg[of f ]  
+  by (metis (no_types, lifting) complement_is_semialg)
+
+lemma semialg_val_strict_ineq_set_is_semialg':
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) < C}"
+proof-
+  obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> val a = C"
+    by (meson Qp.carrier_not_empty Qp.minus_closed dist_nonempty' equals0I)
+  then obtain g where g_def: "g = constant_function (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) a"
+    by blast 
+  have 0: "g \<in> carrier (SA k)"
+    using g_def a_def SA_car assms(1) constant_function_in_semialg_functions by blast  
+  have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) < C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) < val (g x)}"
+    using g_def by (metis (no_types, lifting) Qp_constE a_def)
+  then show ?thesis using assms 0 semialg_val_strict_ineq_set_is_semialg[of f k g] 
+    by presburger
+qed
+
+lemma semialg_val_strict_ineq_set_is_semialg'':
+  assumes "f \<in> carrier (SA k)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) > C}"
+proof-
+  obtain a where a_def: "a \<in> carrier Q\<^sub>p \<and> val a = C"
+    by (meson Qp.carrier_not_empty Qp.minus_closed dist_nonempty' equals0I)
+  then obtain g where g_def: "g = constant_function (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) a"
+    by blast 
+  have 0: "g \<in> carrier (SA k)"
+    using g_def a_def SA_car assms(1) constant_function_in_semialg_functions by blast  
+  have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) > C} = {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). val (f x) > val (g x)}"
+    using g_def by (metis (no_types, lifting) Qp_constE a_def)
+  then show ?thesis using assms 0 semialg_val_strict_ineq_set_is_semialg[of g k f] 
+    by presburger
+qed
+
+lemma semialg_val_ineq_set_plus:
+  assumes "N > 0"
+  assumes "c \<in> carrier (SA N)"
+  assumes "a \<in> carrier (SA N)"
+  shows "is_semialgebraic N  {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). val (c x) \<le> val (a x) + eint n}"
+proof-
+  obtain b where b_def: "b = \<pp>[^]n \<odot>\<^bsub>SA N\<^esub> a"
+    by blast 
+  have b_closed: "b \<in> carrier (SA N)"
+    unfolding b_def using assms SA_smult_closed p_intpow_closed(1) by blast
+  have "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>) \<Longrightarrow> val (b x) = val (a x) + eint n"
+    unfolding b_def by (metis Qp.function_ring_car_memE SA_car_memE(2) SA_smult_formula assms(3) p_intpow_closed(1) times_p_pow_val)
+  hence 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). val (c x) \<le> val (a x) + eint n} = {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). val (c x) \<le> val (b x)}"
+    by (metis (no_types, opaque_lifting) add.commute)
+  show ?thesis unfolding 0 using assms b_def b_closed semialg_val_ineq_set_is_semialg[of c N b]  by blast 
+qed
+
+lemma semialg_val_eq_set_plus:
+  assumes "N > 0"
+  assumes "c \<in> carrier (SA N)"
+  assumes "a \<in> carrier (SA N)"
+  shows "is_semialgebraic N  {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). val (c x) = val (a x) + eint n}"
+proof-
+  obtain b where b_def: "b = \<pp>[^]n \<odot>\<^bsub>SA N\<^esub> a"
+    by blast 
+  have b_closed: "b \<in> carrier (SA N)"
+    unfolding b_def using assms SA_smult_closed p_intpow_closed(1) by blast
+  have "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>) \<Longrightarrow> val (b x) = val (a x) + eint n"
+    unfolding b_def by (metis Qp.function_ring_car_memE SA_car_memE(2) SA_smult_formula assms(3) p_intpow_closed(1) times_p_pow_val)
+  hence 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). val (c x) = val (a x) + eint n} = {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). val (c x) = val (b x)}"
+    by (metis (no_types, opaque_lifting) add.commute)
+  show ?thesis unfolding 0 using assms b_def b_closed semialg_val_eq_set_is_semialg[of c N b]  by blast 
+qed
+
+definition SA_zero_set where 
+"SA_zero_set n f = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x = \<zero>}"
+
+lemma SA_zero_set_is_semialgebraic:
+  assumes "f \<in> carrier (SA n)"
+  shows "is_semialgebraic n (SA_zero_set n f)"
+  using assms semialg_level_set_is_semialg[of f n \<zero>] unfolding SA_zero_set_def 
+  by blast
+
+lemma SA_zero_set_memE:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> SA_zero_set n f"
+  shows "f x = \<zero>"
+  using assms unfolding SA_zero_set_def by blast 
+
+lemma SA_zero_set_memI:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x = \<zero>"
+  shows  "x \<in> SA_zero_set n f"
+  using assms unfolding SA_zero_set_def by blast 
+
+lemma SA_zero_set_of_zero:
+"SA_zero_set m (\<zero>\<^bsub>SA m\<^esub>) = carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  apply(rule equalityI')
+  unfolding SA_zero_set_def mem_Collect_eq 
+  apply blast 
+  using SA_zeroE by blast
+  
+definition SA_nonzero_set where 
+"SA_nonzero_set n f = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x \<noteq> \<zero>}"
+
+lemma nonzero_evimage_closed:
+  assumes "f \<in> carrier (SA n)"
+  shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x \<noteq> \<zero>}"
+proof-
+  have "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x \<noteq> \<zero>} = f  \<inverse>\<^bsub>n\<^esub> nonzero Q\<^sub>p"
+    unfolding nonzero_def evimage_def using SA_car_memE[of f n] assms by blast
+  thus ?thesis   using assms evimage_is_semialg[of f n "nonzero Q\<^sub>p"] nonzero_is_univ_semialgebraic 
+    by presburger
+qed
+
+lemma SA_nonzero_set_is_semialgebraic:
+  assumes "f \<in> carrier (SA n)"
+  shows "is_semialgebraic n (SA_nonzero_set n f)"
+  using assms semialg_level_set_is_semialg[of f n \<zero>] unfolding SA_nonzero_set_def 
+  using nonzero_evimage_closed by blast
+  
+lemma SA_nonzero_set_memE:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> SA_nonzero_set n f"
+  shows "f x \<noteq> \<zero>"
+  using assms unfolding SA_nonzero_set_def by blast 
+
+lemma SA_nonzero_set_memI:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq>  \<zero>"
+  shows  "x \<in> SA_nonzero_set n f"
+  using assms unfolding SA_nonzero_set_def
+  by blast 
+
+lemma SA_nonzero_set_of_zero:
+"SA_nonzero_set m (\<zero>\<^bsub>SA m\<^esub>) = {}"
+  apply(rule equalityI')
+  unfolding SA_nonzero_set_def mem_Collect_eq 
+  using SA_zeroE apply blast
+  by blast 
+
+lemma SA_car_memI':
+  assumes "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> f x \<in> carrier Q\<^sub>p"
+  assumes "\<And>x. x \<notin> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> f x = undefined"
+  assumes "\<And>k n P. n > 0 \<Longrightarrow> P \<in> carrier (Q\<^sub>p [\<X>\<^bsub>1 + k\<^esub>]) \<Longrightarrow> is_semialgebraic (m + k) (partial_pullback m f k (basic_semialg_set (1 + k) n P))"
+  shows "f \<in> carrier (SA m)"
+  apply(rule SA_car_memI)
+   apply(rule Qp.function_ring_car_memI)
+  using assms(1) apply blast using assms(2) apply blast 
+  apply(rule is_semialg_functionI')
+  using assms(1) apply blast
+  using assms(3) unfolding is_basic_semialg_def 
+  by blast 
+
+lemma(in padic_fields) SA_zero_set_is_semialg:
+  assumes "a \<in> carrier (SA m)"
+  shows "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). a x = \<zero>}"
+  using assms semialg_level_set_is_semialg[of a m \<zero>] Qp.zero_closed by blast 
+
+lemma(in padic_fields) SA_nonzero_set_is_semialg:
+  assumes "a \<in> carrier (SA m)"
+  shows "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). a x \<noteq> \<zero>}"
+proof-
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). a x \<noteq> \<zero>} = carrier (Q\<^sub>p\<^bsup>m\<^esup>) - {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). a x = \<zero>}"
+    by blast
+  show ?thesis using assms  SA_zero_set_is_semialg[of a m] complement_is_semialg[of m "{x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). a x = \<zero>}"]
+    unfolding 0  by blast 
+qed
+
+lemma zero_set_nonzero_set_covers:
+"carrier (Q\<^sub>p\<^bsup>n\<^esup>) = SA_zero_set n f \<union> SA_nonzero_set n f"
+  unfolding SA_zero_set_def SA_nonzero_set_def  
+  apply(rule equalityI')
+  unfolding mem_Collect_eq 
+  apply blast
+  by blast
+
+lemma zero_set_nonzero_set_covers':
+  assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "S = (S \<inter> SA_zero_set n f) \<union> (S \<inter> SA_nonzero_set n f)"
+  using assms zero_set_nonzero_set_covers by blast 
+
+lemma zero_set_nonzero_set_covers_semialg_set:
+  assumes "is_semialgebraic n S"
+  shows "S = (S \<inter> SA_zero_set n f) \<union> (S \<inter> SA_nonzero_set n f)"
+  using assms is_semialgebraic_closed zero_set_nonzero_set_covers' by blast 
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Partitioning Semialgebraic Sets According to Valuations of Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+text\<open>
+  Given a semialgebraic set $A$ and a finite set of semialgebraic functions $Fs$, a common 
+  construction is to simplify one's understanding of the behaviour of the functions $\mathit{Fs}$ on
+  $A$ by finitely paritioning $A$ into subsets where the element $f \in F$ for which $val (f x)$ is 
+  minimal is constant as $x$ ranges over each piece of the parititon. The function 
+  \texttt{Min\_set} helps construct this by picking out the subset of a set $A$ where the valuation
+  of a particular element of $\mathit{Fs}$ is minimal. Such a set will always be semialgebraic.
+\<close>
+
+lemma disjointify_semialg:
+  assumes "finite As"
+  assumes "As \<subseteq> semialg_sets n"
+  shows "disjointify As \<subseteq> semialg_sets n"
+  using assms unfolding semialg_sets_def 
+  by (simp add: disjointify_gen_boolean_algebra)
+
+lemma semialgebraic_subalgebra:
+  assumes "finite Xs"
+  assumes "Xs \<subseteq> semialg_sets n"
+  shows "atoms_of Xs \<subseteq> semialg_sets n"
+  using assms unfolding semialg_sets_def  
+  by (simp add: atoms_of_gen_boolean_algebra)
+
+lemma(in padic_fields) finite_intersection_is_semialg:
+  assumes "finite  Xs"
+  assumes "Xs \<noteq> {}"
+  assumes "F ` Xs \<subseteq> semialg_sets m"
+  shows "is_semialgebraic m (\<Inter> i \<in> Xs. F i)"
+proof-
+  have 0: "F ` Xs \<subseteq> semialg_sets m \<and> F ` Xs \<noteq> {} "
+    using assms by blast
+  thus ?thesis
+    using assms finite_intersection_is_semialgebraic[of "F ` Xs" m]
+    by blast 
+qed
+
+
+definition Min_set where
+"Min_set m As a = carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<inter> (\<Inter> f \<in> As. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (a x) \<le> val (f x) })"
+
+lemma Min_set_memE: 
+  assumes "x \<in> Min_set m As a"
+  assumes "f \<in> As"
+  shows "val (a x) \<le> val (f x)"
+  using assms unfolding Min_set_def by blast 
+
+lemma Min_set_closed:
+"Min_set m As a \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  unfolding Min_set_def by blast 
+
+lemma Min_set_semialg0: 
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "finite As"
+  assumes "a \<in> As"
+  assumes "As \<noteq> {}"
+  shows "is_semialgebraic m (Min_set m As a)"
+  unfolding Min_set_def apply(rule intersection_is_semialg)
+  using carrier_is_semialgebraic apply blast
+  apply(rule finite_intersection_is_semialg) 
+  using assms apply blast
+  using assms apply blast
+proof(rule subsetI) fix x assume A: " x \<in> (\<lambda>i. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (a x) \<le> val (i x)}) ` As"
+  then obtain f where f_def: "f \<in> As \<and> x = {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (a x) \<le> val (f x)}"
+    by blast 
+  have f_closed: "f \<in> carrier (SA m)"
+    using f_def assms by blast 
+  have a_closed: "a \<in> carrier (SA m)"
+    using assms by blast 
+  have "is_semialgebraic m  {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (a x) \<le> val (f x)}"
+    using a_closed f_closed semialg_val_ineq_set_is_semialg by blast
+  thus " x \<in> semialg_sets m"
+    using f_def unfolding is_semialgebraic_def by blast 
+qed
+
+lemma Min_set_semialg: 
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "finite As"
+  assumes "a \<in> As"
+  shows "is_semialgebraic m (Min_set m As a)"
+  apply(cases "As = {}")
+  using Min_set_def  assms(3) apply blast
+  using assms Min_set_semialg0 by blast 
+
+lemma Min_sets_cover:
+  assumes "As \<noteq> {}"
+  assumes "finite As"
+  shows "carrier (Q\<^sub>p\<^bsup>m\<^esup>) = (\<Union> a \<in> As. Min_set m As a)"
+proof
+  show "carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<subseteq> \<Union> (Min_set m As ` As)"
+  proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) "
+    obtain v where v_def: "v = Min ((\<lambda>f. val (f x)) ` As)"
+      by blast 
+    obtain f where f_def: "f \<in> As \<and> v = val (f x)"
+      unfolding v_def using assms Min_in[of "((\<lambda>f. val (f x)) ` As)"] 
+      by blast
+    have v_def': "v = val (f x)"
+      using f_def by blast 
+    have 0: "x \<in> Min_set m As f"
+      unfolding Min_set_def 
+      apply(rule IntI)
+      using A apply blast 
+    proof(rule InterI) fix s assume s: "s \<in> (\<lambda>fa. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (f x) \<le> val (fa x)}) ` As"
+      then obtain g where g_def: "g \<in> As \<and> s=  {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (f x) \<le> val (g x)}"
+        by blast 
+      have s_def: "s=  {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). val (f x) \<le> val (g x)}"
+        using g_def by blast 
+      have 00: " val (g x) \<in> ((\<lambda>f. val (f x)) ` As)"
+        using g_def by blast 
+      show "x \<in> s"
+        unfolding s_def mem_Collect_eq using 00 A assms  MinE[of "((\<lambda>f. val (f x)) ` As)" v "val (g x)"] 
+        unfolding v_def  by (metis f_def finite_imageI v_def)
+    qed
+    thus "x \<in> \<Union> (Min_set m As ` As)"
+      using f_def by blast
+  qed
+  show "\<Union> (Min_set m As ` As) \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    unfolding Min_set_def by blast 
+qed
+
+text\<open>
+  The sets defined by the function \texttt{Min\_set} for a fixed set of functions may not all be
+   disjoint, but we can easily refine then to obtain a finite partition via the function 
+  "disjointify".
+\<close>
+
+definition Min_set_partition where 
+"Min_set_partition m As B = disjointify ((\<inter>)B  ` (Min_set m As ` As))"
+
+lemma Min_set_partition_finite:
+  assumes "finite As"
+  shows "finite (Min_set_partition m As B)"
+  unfolding Min_set_partition_def 
+  by (meson assms disjointify_finite finite_imageI)
+
+lemma Min_set_partition_semialg0:
+  assumes "finite As"
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "is_semialgebraic m B"
+  assumes "S \<in> ((\<inter>)B  ` (Min_set m As ` As))"
+  shows "is_semialgebraic m S"
+  using Min_set_semialg[of As m] assms intersection_is_semialg[of m B] 
+  by blast
+  
+lemma Min_set_partition_semialg:
+  assumes "finite As"
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "is_semialgebraic m B"
+  assumes "S \<in> (Min_set_partition m As B)"
+  shows "is_semialgebraic m S"
+proof-
+  have 0: "(\<inter>) B ` Min_set m As ` As \<subseteq> semialg_sets m "
+    apply(rule subsetI)
+    using Min_set_partition_semialg0[of As m B ] assms unfolding is_semialgebraic_def 
+    by blast
+  thus ?thesis
+  unfolding is_semialgebraic_def
+  using assms  Min_set_partition_semialg0[of As m B] disjointify_semialg[of "((\<inter>) B ` Min_set m As ` As)" m] 
+  unfolding Min_set_partition_def  is_semialgebraic_def by blast 
+qed
+
+lemma Min_set_partition_covers0: 
+  assumes "finite As"
+  assumes "As \<noteq> {}"
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "is_semialgebraic m B"
+  shows "\<Union> ((\<inter>)B  ` (Min_set m As ` As)) = B"
+proof- 
+  have 0: "\<Union> ((\<inter>)B  ` (Min_set m As ` As)) = B \<inter> \<Union> (Min_set m As ` As)"
+    by blast 
+  have 1: "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using assms is_semialgebraic_closed by blast
+  show ?thesis unfolding 0 using 1 assms Min_sets_cover[of As m]  by blast 
+qed
+
+lemma Min_set_partition_covers: 
+  assumes "finite As"
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "As \<noteq> {}"
+  assumes "is_semialgebraic m B"
+  shows "\<Union> (Min_set_partition m As B)  = B"
+  unfolding Min_set_partition_def 
+  using Min_set_partition_covers0[of As m B] assms disjointify_union[of "((\<inter>) B ` Min_set m As ` As)"]
+  by (metis finite_imageI)
+
+lemma Min_set_partition_disjoint: 
+  assumes "finite As"
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "As \<noteq> {}"
+  assumes "is_semialgebraic m B"
+  assumes "s \<in> Min_set_partition m As B"
+  assumes "s' \<in> Min_set_partition m As B"
+  assumes "s \<noteq>  s'"
+  shows  "s \<inter> s' = {}"
+  apply(rule  disjointify_is_disjoint[of "((\<inter>) B ` Min_set m As ` As)" s s'])
+  using assms finite_imageI apply blast 
+  using assms unfolding Min_set_partition_def apply blast 
+  using assms unfolding Min_set_partition_def apply blast
+  using assms by blast 
+
+lemma Min_set_partition_memE:
+  assumes "finite As"
+  assumes "As \<subseteq> carrier (SA m)"
+  assumes "As \<noteq> {}"
+  assumes "is_semialgebraic m B"
+  assumes "s \<in> Min_set_partition m As B"
+  shows "\<exists>f \<in> As. (\<forall>x \<in> s. (\<forall>g \<in> As. val (f x) \<le> val (g x)))"
+proof-
+  obtain s' where s'_def: "s' \<in> ((\<inter>) B ` Min_set m As ` As) \<and> s \<subseteq>  s'"
+    using finite_imageI assms disjointify_subset[of "((\<inter>) B ` Min_set m As ` As)" s] unfolding Min_set_partition_def  by blast 
+  obtain f where f_def: "f \<in> As \<and> s' = B \<inter> Min_set m As f"
+    using s'_def by blast 
+  have 0: "(\<forall>x \<in> s'. (\<forall>g \<in> As. val (f x) \<le> val (g x)))"
+    using f_def Min_set_memE[of _ m As f] by blast 
+  thus ?thesis 
+    using s'_def  by (meson f_def subset_iff)
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Valuative Congruence Sets for Semialgebraic Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  The set of points $x$ where the values $\mathit{ord}\ f(x)$ satisfy a congruence are important
+  basic examples of semialgebraic sets, and will be vital in the proof of Macintyre's Theorem. The
+  lemma below is essentially the content of Denef's Lemma 2.1.3 from his cell decomposition paper.
+\<close>
+
+lemma pre_SA_unit_cong_set_is_semialg:
+  assumes "k \<ge> 0"
+  assumes "f \<in> Units (SA n)"
+  shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k  = a }"
+proof-
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k  = a } = f  \<inverse>\<^bsub>n\<^esub> ord_congruence_set k a"
+    unfolding ord_congruence_set_def 
+    apply(rule equalityI')  
+    using assms unfolding evimage_def vimage_def mem_Collect_eq 
+    apply (metis (mono_tags, lifting) IntI Qp.function_ring_car_memE SA_Units_closed SA_Units_memE' SA_car_memE(2) mem_Collect_eq not_nonzero_Qp)
+    using assms by blast
+  show ?thesis unfolding 0 
+    apply(rule evimage_is_semialg) 
+    using assms  apply blast
+    using  assms ord_congruence_set_univ_semialg[of k a]   
+    by blast
+qed
+
+lemma SA_unit_cong_set_is_semialg:
+  assumes "f \<in> Units (SA n)"
+  shows "is_semialgebraic n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = a}"
+proof(cases "k \<ge> 0")
+  case True
+  then show ?thesis 
+    using assms pre_SA_unit_cong_set_is_semialg by presburger
+next
+  case False
+  show ?thesis 
+  proof(cases "a = 0")
+    case True
+    have T0: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k  = a } = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod (-k)  = a }" 
+      apply(rule equalityI')
+      unfolding mem_Collect_eq using True zmod_zminus2_not_zero  apply meson
+      using True zmod_zminus2_not_zero  
+      by (metis equation_minus_iff)     
+    show ?thesis unfolding T0 apply(rule pre_SA_unit_cong_set_is_semialg[of "-k" f n a])
+      using False apply presburger using assms by blast 
+  next
+    case F: False
+    show ?thesis 
+    proof(cases "a = k")
+      case True
+      have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = a} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = k}"
+        using True by blast
+      have 1: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = a} = {} \<or> k = 0"
+      proof(cases "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = a} \<noteq> {}")
+        case T: True
+        then obtain x where "ord (f x) mod k = k"
+          unfolding True by blast
+        then have "k = 0"  
+          by (metis mod_mod_trivial mod_self)
+        thus ?thesis by blast 
+      next
+        case False
+        then show ?thesis by blast 
+      qed
+      show ?thesis apply(cases "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = a} = {}")
+        using empty_is_semialgebraic apply presburger
+        using 1 pre_SA_unit_cong_set_is_semialg assms by blast 
+    next
+      case F': False
+      have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod k = a} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). ord (f x) mod (-k) = a - k}"
+        apply(rule equalityI')
+        unfolding mem_Collect_eq using zmod_zminus2_eq_if assms apply (metis F)
+        unfolding mem_Collect_eq zmod_zminus2_eq_if using False F F' assms
+        by (metis (no_types, opaque_lifting) cancel_ab_semigroup_add_class.diff_right_commute group_add_class.right_minus_eq) 
+      show ?thesis unfolding 0 apply(rule pre_SA_unit_cong_set_is_semialg)
+        using False apply presburger using assms by blast 
+    qed
+  qed
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Gluing Functions Along Semialgebraic Sets\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+text\<open>
+  Semialgebraic functions have the useful property that they are closed under piecewise definitions.
+  That is, if $f, g$ are semialgebraic and $C \subseteq \mathbb{Q}_p^m$ is a semialgebraic set, 
+  then the function:
+  \[
+   h(x) =
+    \begin{cases}
+                                     f(x) & \text{if $x \in C$} \\
+                                     g(x) & \text{if $x \in \mathbb{Q}_p^m - C$} \\
+    undefined & \text{otherwise}
+    \end{cases}
+  \]
+  is again semialgebraic. The function $h$ can be obtained by the definition 
+  \[\texttt{h = fun\_glue m C f g}\] which is defined below. This closure property means that we
+  can avoid having to define partial semialgebraic functions which are undefined outside of some 
+  proper subset of $\mathbb{Q}_p^m$, since it usually suffices to just define the function as some 
+  arbitrary constant outside of the desired domain. This is useful for defining partial 
+  multiplicative inverses of arbitrary functions. If $f$ is semialgebraic, then its nonzero set 
+  $\{x \in \mathbb{Q}_p^m \mid f x \neq 0\}$ is semialgebraic. By gluing $f$ to the constant 
+  function $1$ outside of its nonzero set, we obtain an invertible element in the ring 
+  \texttt{SA(m)} which evaluates to a multiplicative inverse of $f(x)$ on the largest domain 
+  possible.
+\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Defining Piecewise Semialgebraic Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+text\<open>
+  An important property that will be repeatedly used is that we can define piecewise semialgebraic
+  functions, which will themselves be semialgebraic as long as the pieces are semialgebraic sets.
+  An important application of this principle will be that a function $f$ which is always nonzero 
+  on some semialgebraic set $A$ can be replaced with a global unit in the ring of semialgebraic 
+  functions. This global unit admits a global multiplicative inverse that inverts $f$ pointwise on 
+  $A$, and allows us to avoid having to consider localizations of function rings to locally invert 
+  such functions.
+\<close>
+
+definition fun_glue where
+"fun_glue n S f g = (\<lambda>x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). if x \<in> S then f x else g x)"
+
+lemma fun_glueE:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "x \<in> S"
+  shows "fun_glue n S f g x = f x"
+proof-
+  have "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    using assms by blast 
+  thus ?thesis 
+    unfolding fun_glue_def using assms 
+    by (metis (mono_tags, lifting) restrict_apply')
+qed
+
+lemma fun_glueE':
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) - S"
+  shows "fun_glue n S f g x = g x"
+proof-
+  have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    using assms by blast
+  have 1: "x \<notin> S"
+    using assms by blast 
+  show ?thesis 
+    unfolding fun_glue_def using assms 0 1
+    by (metis (mono_tags, lifting) restrict_apply')
+qed
+
+lemma fun_glue_evimage:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "fun_glue n S f g \<inverse>\<^bsub>n\<^esub> T = ((f  \<inverse>\<^bsub>n\<^esub> T) \<inter> S) \<union> ((g  \<inverse>\<^bsub>n\<^esub> T) - S)"
+proof
+  show "fun_glue n S f g \<inverse>\<^bsub>n\<^esub> T \<subseteq> ((f  \<inverse>\<^bsub>n\<^esub> T) \<inter> S) \<union> ((g  \<inverse>\<^bsub>n\<^esub> T) - S)"
+  proof fix x assume A: "x \<in> fun_glue n S f g \<inverse>\<^bsub>n\<^esub> T "
+    then have 0: "fun_glue n S f g x \<in> T"
+      by blast
+    have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+      using A  by (meson evimage_eq)
+    show "x \<in> ((f  \<inverse>\<^bsub>n\<^esub> T) \<inter> S) \<union> ((g  \<inverse>\<^bsub>n\<^esub> T) - S)"
+      apply(cases "x \<in> S")
+      apply auto[1] 
+      using "1" apply force
+      using "0" assms(1) assms(2) assms(3) fun_glueE apply force
+      apply auto[1] using 1 apply blast 
+      using A 1  unfolding fun_glue_def evimage_def Int_iff  by auto 
+  qed
+  show " f \<inverse>\<^bsub>n\<^esub> T \<inter> S \<union> (g \<inverse>\<^bsub>n\<^esub> T - S) \<subseteq> fun_glue n S f g \<inverse>\<^bsub>n\<^esub> T"
+  proof fix x assume A: "x \<in> f \<inverse>\<^bsub>n\<^esub> T \<inter> S \<union> (g \<inverse>\<^bsub>n\<^esub> T - S)"
+    then have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+      by (metis (no_types, opaque_lifting) Diff_iff Int_iff UnE extensional_vimage_closed subsetD)
+    show "x \<in> fun_glue n S f g \<inverse>\<^bsub>n\<^esub> T"
+      apply(cases "x \<in> S")
+      using x_closed fun_glueE assms 
+       apply (metis A DiffD2 IntD1 UnE evimage_eq)
+      using x_closed fun_glueE' assms 
+      by (metis A Diff_iff Int_iff Un_iff evimageD evimageI2)
+  qed
+qed
+
+lemma fun_glue_partial_pullback:
+  assumes "f \<in> carrier (SA k)"
+  assumes "g \<in> carrier (SA k)"
+  assumes "S \<subseteq> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+  shows "partial_pullback k (fun_glue k S f g) n T = 
+          ((cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) \<inter> partial_pullback k f n T) \<union> ((partial_pullback k g n T)- (cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>))))"
+proof
+  show "partial_pullback k (fun_glue k S f g) n T \<subseteq> (cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>))) \<inter> partial_pullback k f n T \<union> (partial_pullback k g n T - (cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>))))"
+  proof fix x assume A: "x \<in> partial_pullback k (fun_glue k S f g) n T "
+    then have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>k+n\<^esup>)" unfolding partial_pullback_def partial_image_def
+      by (meson evimage_eq) 
+    show " x \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<inter> partial_pullback k f n T \<union> (partial_pullback k g n T - (cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>))))"
+    proof(cases "x \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>))")
+      case True
+      then have T0: "take k x \<in> S"
+        using assms cartesian_product_memE(1) by blast
+      then have "(fun_glue k S f g) (take k x) = f (take k x)"
+        using assms fun_glueE[of f k g S "take k x"] 
+        by blast
+      then have "partial_image k (fun_glue k S f g) x = partial_image k f x"
+        using A x_closed unfolding partial_pullback_def partial_image_def 
+        by blast        
+      then show ?thesis using T0 A unfolding partial_pullback_def evimage_def  
+        by (metis IntI Int_iff True Un_iff vimageI vimage_eq x_closed)
+    next
+      case False
+      then have F0: "take k x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) - S"
+        using A x_closed assms cartesian_product_memI 
+        by (metis (no_types, lifting) DiffI carrier_is_semialgebraic cartesian_power_drop is_semialgebraic_closed le_add1 local.take_closed)
+      then have "(fun_glue k S f g) (take k x) = g (take k x)"
+        using assms fun_glueE'[of f k g S "take k x"] 
+        by blast
+      then have "partial_image k (fun_glue k S f g) x = partial_image k g x"
+        using A x_closed unfolding partial_pullback_def partial_image_def 
+        by blast        
+      then have "x \<in> partial_pullback k g n T "
+        using F0 x_closed A unfolding partial_pullback_def partial_image_def evimage_def 
+        by (metis (no_types, lifting) A IntI local.partial_image_def partial_pullback_memE(2) vimageI)
+      then have "x \<in> (partial_pullback k g n T - cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)))"
+        using False by blast 
+      then show ?thesis by blast 
+    qed
+  qed 
+  show "cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<inter> partial_pullback k f n T \<union> (partial_pullback k g n T - cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)))
+    \<subseteq> partial_pullback k (fun_glue k S f g) n T"
+  proof fix x assume A: "x \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<inter> partial_pullback k f n T \<union> (partial_pullback k g n T - cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)))"
+    then have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n+k\<^esup>)"
+      by (metis DiffD1 Int_iff Un_iff add.commute partial_pullback_memE(1))
+    show "x \<in> partial_pullback k (fun_glue k S f g) n T"
+    proof(cases "x \<in> cartesian_product S (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) \<inter> partial_pullback k f n T")
+      case True
+      show ?thesis apply(rule partial_pullback_memI)
+        using x_closed apply (metis add.commute)      
+        using x_closed True assms fun_glueE[of f k g S "take k x"] partial_pullback_memE[of x k f n T]
+        unfolding partial_image_def by (metis Int_iff cartesian_product_memE(1))
+    next
+      case False
+      show ?thesis apply(rule partial_pullback_memI)
+        using x_closed apply (metis add.commute)   
+        using A x_closed False assms fun_glueE'[of f k g S "take k x"] partial_pullback_memE[of x k g n T]
+        unfolding partial_image_def 
+        by (metis (no_types, lifting) Diff_iff Un_iff carrier_is_semialgebraic cartesian_power_drop cartesian_product_memI is_semialgebraic_closed le_add2 local.take_closed)
+    qed
+  qed
+qed
+
+lemma fun_glue_eval_closed:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "fun_glue n S f g x \<in> carrier Q\<^sub>p"
+  apply(cases "x \<in> S")
+  using assms fun_glueE SA_car_memE 
+   apply (metis Qp.function_ring_car_mem_closed is_semialgebraic_closed)
+proof- assume A: "x \<notin> S"
+  then have 0: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) - S"
+    using assms by auto 
+  hence 1: "fun_glue n S f g x = g x"
+    using assms fun_glueE' is_semialgebraic_closed by auto  
+  show "fun_glue n S f g x \<in> carrier Q\<^sub>p"
+    unfolding 1 using assms SA_car_memE by blast 
+qed
+
+lemma fun_glue_closed:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  shows "fun_glue n S f g \<in> carrier (SA n)"
+  apply(rule SA_car_memI)
+   apply(rule Qp.function_ring_car_memI)
+  using fun_glue_eval_closed assms apply blast   
+  using fun_glue_def unfolding restrict_apply apply metis 
+  apply(rule is_semialg_functionI, intro Pi_I fun_glue_eval_closed assms, blast) 
+proof-
+  fix k T assume A: "T \<in> semialg_sets (1 + k)"
+  have 0: "is_semialgebraic (n+k) (partial_pullback n f k T)"
+    using assms A SA_car_memE[of f n]  is_semialg_functionE[of n f k T]  padic_fields.is_semialgebraicI padic_fields_axioms by blast
+  have 1: "is_semialgebraic (n+k) (partial_pullback n g k T)"
+    using assms A SA_car_memE[of g n]  is_semialg_functionE[of n g k T] padic_fields.is_semialgebraicI padic_fields_axioms by blast
+  have 2: "partial_pullback n (fun_glue n S f g) k T =
+    cartesian_product S (carrier (Q\<^sub>p\<^bsup>k\<^esup>)) \<inter> partial_pullback n f k T \<union> (partial_pullback n g k T - cartesian_product S (carrier (Q\<^sub>p\<^bsup>k\<^esup>)))"
+    using assms fun_glue_partial_pullback[of f n g S k T] \<open>f \<in> carrier (SA n)\<close> \<open>g \<in> carrier (SA n)\<close> is_semialgebraic_closed 
+    by blast
+  show "is_semialgebraic (n + k) (partial_pullback n (fun_glue n S f g) k T)"
+    using assms 0 1 2 cartesian_product_is_semialgebraic carrier_is_semialgebraic 
+      diff_is_semialgebraic intersection_is_semialg union_is_semialgebraic by presburger 
+qed  
+
+lemma fun_glue_unit:
+  assumes "f \<in> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  assumes "\<And>x. x \<in> S \<Longrightarrow> f x \<noteq> \<zero>"
+  shows "fun_glue n S f \<one>\<^bsub>SA n\<^esub> \<in> Units (SA n)"
+proof(rule SA_Units_memI)
+  show "fun_glue n S f \<one>\<^bsub>SA n\<^esub> \<in> carrier (SA n)"
+    using fun_glue_closed assms SA_is_cring cring.cring_simprules(6) by blast
+  show "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> fun_glue n S f \<one>\<^bsub>SA n\<^esub> x \<noteq> \<zero>"
+  proof- fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    show "fun_glue n S f \<one>\<^bsub>SA n\<^esub> x \<noteq> \<zero>"
+      apply(cases "x \<in> S")
+      using assms SA_is_cring cring.cring_simprules(6) assms(3)[of x] fun_glueE[of f n "\<one>\<^bsub>SA n\<^esub>" S x] 
+      apply (metis is_semialgebraic_closed)
+      using assms SA_is_cring[of n] cring.cring_simprules(6)[of "SA n"] 
+            A  fun_glueE'[of f n "\<one>\<^bsub>SA n\<^esub>" S x] is_semialgebraic_closed[of n S] 
+      unfolding SA_one[of n] function_ring_defs(4)[of n] function_one_def
+      by (metis Diff_iff function_one_eval Qp_funs_one local.one_neq_zero)
+  qed
+qed
+
+definition parametric_fun_glue where
+"parametric_fun_glue n Xs fs = (\<lambda>x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). let S = (THE S. S \<in> Xs \<and> x \<in> S) in (fs S x))"
+
+lemma parametric_fun_glue_formula:
+  assumes "Xs partitions (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  assumes "x \<in> S"
+  assumes "S \<in> Xs"
+  shows "parametric_fun_glue n Xs fs x = fs S x"
+proof-
+  have 0: "(THE S. S \<in> Xs \<and> x \<in> S) = S"
+    apply(rule the_equality)
+    using assms apply blast 
+    using assms unfolding is_partition_def by (metis Int_iff empty_iff disjointE)
+  have 1: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    using assms unfolding is_partition_def by blast 
+  then show ?thesis using 0 unfolding parametric_fun_glue_def  restrict_def by metis 
+qed
+
+definition char_fun where
+"char_fun n S = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). if x \<in> S then \<one> else \<zero>)"
+
+lemma char_fun_is_semialg:
+  assumes "is_semialgebraic n S"
+  shows "char_fun n S \<in> carrier (SA n)"
+proof-
+  have "char_fun n S = fun_glue n S \<one>\<^bsub>SA n\<^esub> \<zero>\<^bsub>SA n\<^esub>"
+    unfolding char_fun_def fun_glue_def 
+    by (metis (no_types, lifting) function_one_eval function_zero_eval SA_one SA_zero restrict_ext)
+  then show ?thesis 
+    using assms fun_glue_closed
+    by (metis SA_is_cring cring.cring_simprules(2) cring.cring_simprules(6))    
+qed
+
+lemma SA_finsum_apply:
+  assumes "finite S"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "F \<in> S \<rightarrow> carrier (SA n) \<longrightarrow> finsum (SA n) F S x = (\<Oplus>s\<in>S. F s x)"
+proof(rule finite.induct[of S])
+  show "finite S"
+    using assms by blast 
+  show " F \<in> {} \<rightarrow> carrier (SA n) \<longrightarrow> finsum (SA n) F {} x = (\<Oplus>s\<in>{}. F s x)"
+    using assms abelian_monoid.finsum_empty[of "SA n"]   Qp.abelian_monoid_axioms SA_is_abelian_monoid
+    by (simp add: SA_zeroE)
+  show "\<And>A a. finite A \<Longrightarrow>
+           F \<in> A \<rightarrow> carrier (SA n) \<longrightarrow> finsum (SA n) F A x = (\<Oplus>s\<in>A. F s x) \<Longrightarrow>
+           F \<in> insert a A \<rightarrow> carrier (SA n) \<longrightarrow> finsum (SA n) F (insert a A) x = (\<Oplus>s\<in>insert a A. F s x)"
+  proof- fix A a assume A: "finite A" "F \<in> A \<rightarrow> carrier (SA n) \<longrightarrow> finsum (SA n) F A x = (\<Oplus>s\<in>A. F s x)"
+    show " F \<in> insert a A \<rightarrow> carrier (SA n) \<longrightarrow> finsum (SA n) F (insert a A) x = (\<Oplus>s\<in>insert a A. F s x)"
+    proof assume A': "F \<in> insert a A \<rightarrow> carrier (SA n)"
+      then have 0: "F \<in> A \<rightarrow> carrier (SA n)"
+        by blast 
+      hence 1: "finsum (SA n) F A x = (\<Oplus>s\<in>A. F s x)"
+        using A by blast 
+      show "finsum (SA n) F (insert a A) x = (\<Oplus>s\<in>insert a A. F s x)"
+      proof(cases "a \<in> A")
+        case True
+        then show ?thesis        
+          using 1 by (metis insert_absorb)
+      next
+        case False
+        have F00: "(\<lambda>s. F s x) \<in> A \<rightarrow> carrier Q\<^sub>p"
+          apply(rule Pi_I, rule SA_car_closed[of _ n] )  
+          using "0" assms by auto 
+        have F01: "F a x \<in> carrier Q\<^sub>p"
+          using A' assms 
+          by (metis (no_types, lifting) Qp.function_ring_car_mem_closed Pi_split_insert_domain SA_car_in_Qp_funs_car subsetD)
+        have F0: "(\<Oplus>s\<in>insert a A. F s x) = F a x \<oplus> (\<Oplus>s\<in>A. F s x)"
+          using F00 F01  A' False A(1) Qp.finsum_insert[of A a "\<lambda>s. F s x"] by blast 
+        have F1: "finsum (SA n) F (insert a A) = F a \<oplus>\<^bsub>SA n\<^esub> finsum (SA n) F A"
+          using abelian_monoid.finsum_insert[of "SA n" A a F]
+          by (metis (no_types, lifting) A' A(1) False Pi_split_insert_domain SA_is_abelian_monoid assms(1))
+        show ?thesis 
+          using Qp.finsum_closed[of "\<lambda>s. F s x" A] abelian_monoid.finsum_closed[of "SA n" F A]
+                SA_is_abelian_monoid[of n] assms F0 F1 "0" A(2) SA_add by presburger
+      qed
+    qed
+  qed
+qed
+
+lemma SA_finsum_apply_zero:
+  assumes "finite S"
+  assumes "F \<in> S \<rightarrow> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "\<And>s. s \<in> S \<Longrightarrow> F s x = \<zero>"
+  shows "finsum (SA n) F S x = \<zero>"
+proof-
+  have "finsum (SA n) F S x = (\<Oplus>s\<in>S. F s x)"
+    using SA_finsum_apply assms by blast   
+  then show ?thesis using assms 
+    by (metis Qp.add.finprod_one_eqI)
+qed
+
+lemma parametric_fun_glue_is_SA:
+  assumes "finite Xs"
+  assumes "Xs partitions (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  assumes "fs \<in> Xs \<rightarrow> carrier (SA n)"
+  assumes "\<forall> S \<in> Xs. is_semialgebraic n S"
+  shows "parametric_fun_glue n Xs fs \<in> carrier (SA n)"
+proof-
+  obtain F where F_def: "F = (\<lambda>S. fs S \<otimes>\<^bsub>SA n\<^esub> char_fun n S)"
+    by blast 
+  have 0: "F \<in> Xs \<rightarrow> carrier (SA n)" proof fix S assume "S \<in> Xs" then show "F S \<in> carrier (SA n)"
+      using  SA_mult_closed[of n "fs S" "char_fun n S"] char_fun_is_semialg[of n S] assms SA_car_memE
+      unfolding F_def by blast qed
+  have 1: "\<And>S x. S \<in> Xs \<Longrightarrow> x \<in> S \<Longrightarrow> F S x = fs S x"
+  proof- fix S x assume A: "S \<in> Xs" "x \<in> S"
+    then have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+      using assms unfolding is_partition_def by blast 
+    then have 0: "F S x = fs S x \<otimes> char_fun n S x"
+      unfolding F_def using SA_mult by blast
+    have 1: "char_fun n S x = \<one>"
+      using char_fun_def A x_closed by auto 
+    have 2: "fs S x \<in> carrier Q\<^sub>p"
+      apply(intro SA_car_closed[of _ n] x_closed )
+      using assms A by auto 
+    show "F S x = fs S x"
+      unfolding 0  1 using 2 Qp.cring_simprules(12) by auto             
+  qed
+  have 2: "\<And>S x. S \<in> Xs \<Longrightarrow> x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<Longrightarrow> x \<notin> S \<Longrightarrow> F S x = \<zero>"
+  proof- fix S x assume A: "S \<in> Xs" "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)" "x \<notin> S"
+    then have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+      using assms unfolding is_partition_def by blast 
+    hence 20: "F S x = fs S x \<otimes> char_fun n S x"
+      unfolding F_def using SA_mult by blast
+    have 21: "char_fun n S x = \<zero>"
+      unfolding char_fun_def using A x_closed by auto 
+    have 22: "fs S x \<in> carrier Q\<^sub>p"
+      apply(intro SA_car_closed[of _ n] x_closed )
+      using assms A by auto 
+    show "F S x = \<zero>"
+      using 22 unfolding 20 21 by auto       
+  qed
+  obtain g where g_def: "g = finsum (SA n) F Xs"
+    by blast 
+  have g_closed: "g \<in> carrier (SA n)"
+    using abelian_monoid.finsum_closed[of "SA n" F Xs] assms SA_is_ring 0
+    unfolding g_def ring_def abelian_group_def by blast 
+  have "g = parametric_fun_glue n Xs fs"
+  proof fix x show "g x = parametric_fun_glue n Xs fs x"
+    proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+      case True
+      then obtain S where S_def: "S \<in> Xs \<and> x \<in> S"
+        using assms is_partitionE by blast 
+      then have T0: "parametric_fun_glue n Xs fs x = F S x"
+        using 1 assms parametric_fun_glue_formula by blast
+      have T1: "g x = F S x"
+      proof-
+        have 00: " F S \<oplus>\<^bsub>SA n\<^esub> finsum (SA n) F (Xs - {S}) =  finsum (SA n) F (insert S (Xs - {S}))"
+          using abelian_monoid.finsum_insert[of "SA n" "Xs - {S}" S F ] 
+          by (metis (no_types, lifting) "0" Diff_iff Pi_anti_mono Pi_split_insert_domain SA_is_abelian_monoid S_def Set.basic_monos(7) assms(1) finite_Diff insert_iff subsetI)
+        have T10: "g  = F S \<oplus>\<^bsub>SA n\<^esub> finsum (SA n) F (Xs - {S})"
+          using S_def unfolding 00 g_def 
+          by (simp add: insert_absorb)         
+        have T11: "finsum (SA n) F (Xs - {S}) \<in> carrier (SA n)"
+          using abelian_monoid.finsum_closed[of "SA n" F "Xs - {S}"] assms SA_is_ring 0
+          unfolding g_def ring_def abelian_group_def by blast 
+        hence T12: "g x = F S x \<oplus> finsum (SA n) F (Xs - {S}) x"
+          using SA_add S_def T10 assms is_semialgebraic_closed by blast
+        have T13: "finsum (SA n) F (Xs - {S}) x = \<zero>"
+          apply(rule SA_finsum_apply_zero[of "Xs - {S}" F n x]) 
+              using assms apply blast
+                using "0" apply blast
+                using True apply blast 
+        proof-
+           fix s assume AA: "s \<in> Xs - {S}"
+           then have "x \<notin> s"
+             using True assms S_def is_partitionE[of Xs "carrier (Q\<^sub>p\<^bsup>n\<^esup>)"]  disjointE[of Xs S s]
+             by blast              
+           then show "F s x = \<zero>"
+             using AA 2[of s x] True by blast
+        qed
+        have T14: "F S x \<in> carrier Q\<^sub>p"
+          using assms True S_def  by (metis (no_types, lifting) "0" Qp.function_ring_car_mem_closed PiE SA_car_memE(2))
+        then show ?thesis using T12 T13 assms True Qp.add.l_cancel_one Qp.zero_closed by presburger
+      qed
+      show ?thesis using T0 T1 by blast 
+    next
+      case False
+      then show ?thesis 
+        using g_closed unfolding parametric_fun_glue_def 
+        by (metis (mono_tags, lifting) function_ring_not_car SA_car_memE(2) restrict_def)
+    qed
+  qed
+  then show ?thesis using g_closed by blast 
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Turning Functions into Units Via Gluing\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  By gluing a function to the multiplicative unit on its zero set, we can get a canonical choice of
+  local multiplicative inverse of a function $f$. Denef's proof frequently reasons about functions
+  of the form $\frac{f(x)}{g(x)}$ with the tacit understanding that they are meant to be defined 
+  on the largest domain of definition possible. This technical tool allows us to replicate this 
+  kind of reasoning in our formal proofs.
+\<close>
+
+definition to_fun_unit where
+"to_fun_unit n f = fun_glue n {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). f x \<noteq> \<zero>} f \<one>\<^bsub>SA n\<^esub>"
+
+lemma to_fun_unit_is_unit:
+  assumes "f \<in> carrier (SA n)"
+  shows "to_fun_unit n f \<in> Units (SA n)"
+  unfolding to_fun_unit_def 
+  apply(rule fun_glue_unit) 
+  apply (simp add: assms)
+  using assms nonzero_evimage_closed[of f] apply blast 
+  by blast 
+
+lemma to_fun_unit_closed:
+  assumes "f \<in> carrier (SA n)"
+  shows "to_fun_unit n f \<in> carrier (SA n)"
+  using assms to_fun_unit_is_unit SA_is_ring SA_Units_closed by blast
+
+lemma to_fun_unit_eq:
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq> \<zero>"
+  shows "to_fun_unit n f x = f x"
+  unfolding to_fun_unit_def fun_glue_def using assms 
+  by simp
+  
+lemma to_fun_unit_eq':
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x = \<zero>"
+  shows "to_fun_unit n f x = \<one>"
+  unfolding to_fun_unit_def fun_glue_def using assms 
+  by (simp add: SA_oneE)
+
+definition one_over_fun where
+"one_over_fun n f = inv\<^bsub>SA n\<^esub> (to_fun_unit n f)"
+
+lemma one_over_fun_closed: 
+  assumes "f \<in> carrier (SA n)"
+  shows "one_over_fun n f \<in> carrier (SA n)"
+  using assms SA_is_ring[of n] to_fun_unit_is_unit[of f n] 
+  by (metis SA_Units_closed one_over_fun_def ring.Units_inverse)
+
+lemma one_over_fun_eq: 
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq> \<zero>" 
+  shows "one_over_fun n f x = inv (f x)"
+  using assms to_fun_unit_eq unfolding one_over_fun_def 
+  using Qp_funs_m_inv SA_Units_Qp_funs_Units SA_Units_Qp_funs_inv to_fun_unit_is_unit by presburger
+
+lemma one_over_fun_smult_eval: 
+  assumes "f \<in> carrier (SA n)"
+  assumes "a \<noteq> \<zero>"
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq> \<zero>"
+  shows "one_over_fun n (a \<odot>\<^bsub>SA n\<^esub>f) x = inv (a \<otimes> (f x))"
+  using one_over_fun_eq[of "a \<odot>\<^bsub>SA n\<^esub> f" n x] assms 
+  by (metis Qp.function_ring_car_memE Qp.integral SA_car_memE(2) SA_smult_closed SA_smult_formula)
+
+lemma one_over_fun_smult_eval':
+  assumes "f \<in> carrier (SA n)"
+  assumes "a \<noteq> \<zero>"
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq> \<zero>"
+  shows "one_over_fun n (a \<odot>\<^bsub>SA n\<^esub>f) x = inv a \<otimes> inv (f x)"
+proof- 
+  have 0: "one_over_fun n (a \<odot>\<^bsub>SA n\<^esub> f) x = inv (a \<otimes> f x)"
+    using assms one_over_fun_smult_eval[of f n a x]
+    by fastforce
+  have 1: "f x \<in> nonzero Q\<^sub>p"
+    by(intro nonzero_memI SA_car_closed[ of _ n] assms)
+  show ?thesis
+    unfolding 0 using 1 assms  
+    using Qp.comm_inv_char Qp.cring_simprules(11) Qp.cring_simprules(5) SA_car_closed field_inv(2) field_inv(3) local.fract_cancel_right by presburger
+qed
+
+
+
+lemma SA_add_pow_closed:
+  assumes "f \<in> carrier (SA n)"
+  shows "([(k::nat)]\<cdot>\<^bsub>SA n\<^esub>f) \<in> carrier (SA n)"
+  using assms SA_is_ring[of n]
+  by (meson ring.nat_mult_closed)
+
+lemma one_over_fun_add_pow_eval: 
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq> \<zero>"
+  assumes "(k::nat) > 0"
+  shows "one_over_fun n ([k]\<cdot>\<^bsub>SA n\<^esub>f) x = inv ([k] \<cdot>f x)"
+proof-
+  have 0: "([k] \<cdot>\<^bsub>SA n\<^esub> f) x = [k] \<cdot> f x"
+    using assms SA_add_pow_apply[of f n x k] by linarith
+  hence 1: "([k] \<cdot>\<^bsub>SA n\<^esub> f) x \<noteq> \<zero>"
+    using assms Qp_char_0'' Qp.function_ring_car_mem_closed SA_car_memE(2) 
+    by metis
+  have 2: "one_over_fun n ([k] \<cdot>\<^bsub>SA n\<^esub> f) x = inv ([k] \<cdot>\<^bsub>SA n\<^esub> f) x"
+    using assms one_over_fun_eq[of "[k]\<cdot>\<^bsub>SA n\<^esub>f" n x] 1 SA_add_pow_closed by blast
+  thus ?thesis using 1 0 by presburger
+qed
+
+lemma one_over_fun_pow_closed: 
+  assumes "f \<in> carrier (SA n)"
+  shows "one_over_fun n (f[^]\<^bsub>SA n\<^esub>(k::nat)) \<in> carrier (SA n)"
+  using assms 
+  by (meson SA_nat_pow_closed one_over_fun_closed padic_fields.SA_imp_semialg padic_fields_axioms)
+
+lemma one_over_fun_pow_eval: 
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f x \<noteq> \<zero>"
+  shows "one_over_fun n (f[^]\<^bsub>SA n\<^esub>(k::nat)) x = inv ((f x) [^] k)"
+  using one_over_fun_eq[of  "f[^]\<^bsub>SA n\<^esub>k" n x] assms 
+  by (metis Qp.function_ring_car_memE Qp.nonzero_pow_nonzero SA_car_memE(2) SA_nat_pow SA_nat_pow_closed padic_fields.SA_car_memE(1) padic_fields_axioms)
+ 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Inclusions of Lower Dimensional Function Rings\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition fun_inc where
+"fun_inc m n f = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (take n x))"
+
+lemma fun_inc_closed:
+  assumes "f \<in> carrier (SA n)"
+  assumes "m \<ge> n"
+  shows  "fun_inc m n f \<in> carrier (SA m)"
+proof-
+  have 0: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> fun_inc m n f x = (f \<circ> take n) x"
+    unfolding fun_inc_def by (metis comp_apply restrict_apply')
+  have 1: "is_semialg_function m (f \<circ> take n)"
+    using assms comp_take_is_semialg
+    by (metis SA_imp_semialg le_neq_implies_less padic_fields.semialg_function_comp_closed padic_fields_axioms take_is_semialg_map)
+  have 2: "is_semialg_function m (fun_inc m n f)"
+    using 0 1 semialg_function_on_carrier' by blast
+  show ?thesis apply(rule SA_car_memI) apply(rule  Qp.function_ring_car_memI)
+    using "2" is_semialg_function_closed apply blast
+    using fun_inc_def[of m n f] unfolding restrict_def apply presburger
+    using 2 by blast 
+qed
+
+lemma fun_inc_eval:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "fun_inc m n f x = f (take n x)"
+  unfolding fun_inc_def using assms 
+  by (meson restrict_apply')
+
+lemma ord_congruence_set_univ_semialg_fixed: 
+  assumes "n \<ge> 0"
+  shows "is_univ_semialgebraic (ord_congruence_set n a)" 
+  using ord_congruence_set_univ_semialg assms 
+  by auto
+  
+lemma ord_congruence_set_SA_function: 
+  assumes "n \<ge> 0"
+  assumes "c \<in> carrier (SA (m+l))"
+  shows "is_semialgebraic (m+l) {x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>). c x \<in> nonzero Q\<^sub>p \<and> ord (c x) mod n = a}"
+proof-
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>). c x \<in> nonzero Q\<^sub>p \<and> ord (c x) mod n = a} = c  \<inverse>\<^bsub>m+l\<^esub> (ord_congruence_set n a)"
+    unfolding ord_congruence_set_def evimage_def using assms by blast
+  show ?thesis unfolding 0 apply(rule evimage_is_semialg)
+    using assms apply blast using assms  ord_congruence_set_univ_semialg_fixed[of n a]  
+    by blast  
+qed
+
+lemma ac_cong_set_SA:
+  assumes "n > 0"
+  assumes "k \<in> Units (Zp_res_ring n)"
+  assumes "c \<in> carrier (SA (m+l))"
+  shows "is_semialgebraic (m+l) {x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>). c x \<in> nonzero Q\<^sub>p \<and> ac n (c x) = k}"
+proof-
+  have  "{x \<in> carrier (Q\<^sub>p\<^bsup>m+l\<^esup>). c x \<in> nonzero Q\<^sub>p \<and> ac n (c x) = k}= (c \<inverse>\<^bsub>m + l\<^esub> ac_cong_set n k)"
+    unfolding ac_cong_set_def evimage_def nonzero_def mem_Collect_eq using assms by blast
+  thus ?thesis   
+    using assms ac_cong_set_is_univ_semialg[of n k] evimage_is_semialg[of c "m+l" "ac_cong_set n k"] 
+    by presburger
+qed
+
+lemma ac_cong_set_SA':
+  assumes "n >0 "
+  assumes "k \<in> Units (Zp_res_ring n)"
+  assumes "c \<in> carrier (SA m)"
+  shows "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). c x \<in> nonzero Q\<^sub>p \<and> ac n (c x) = k}"
+  using assms ac_cong_set_SA[of n k c m 0] unfolding Nat.add_0_right by blast 
+
+lemma ac_cong_set_SA'':
+  assumes "n >0 "
+  assumes "m > 0"
+  assumes "k \<in> Units (Zp_res_ring n)"
+  assumes "c \<in> carrier (SA m)"
+  assumes "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> c x \<noteq> \<zero>"
+  shows "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). ac n (c x) = k}"
+proof-
+  have "{x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). c x \<in> nonzero Q\<^sub>p \<and> ac n (c x) = k} = {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). ac n (c x) = k}"
+    apply(rule subset_antisym) apply blast 
+    apply(rule subsetI) using assms unfolding nonzero_def mem_Collect_eq 
+    using Qp.function_ring_car_memE SA_car_memE(2) by blast 
+  thus ?thesis using assms ac_cong_set_SA'[of n k c m] by metis 
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Miscellaneous\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+lemma nth_pow_wits_SA_fun_prep:
+  assumes "n > 0"
+  assumes "h \<in> carrier (SA m)"
+  assumes "\<rho> \<in> nth_pow_wits n"
+  shows "is_semialgebraic m (h \<inverse>\<^bsub>m\<^esub>pow_res n \<rho>)"
+  by(intro evimage_is_semialg assms  pow_res_is_univ_semialgebraic nth_pow_wits_closed(1)[of n])
+
+definition kth_rt where
+"kth_rt m (k::nat) f x = (if x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) then (THE b. b \<in> carrier Q\<^sub>p \<and> b[^]k = (f x) \<and> ac (nat (ord ([k]\<cdot>\<one>)) + 1) b = 1)
+                                                           else undefined )"
+
+text\<open>Normalizing a semialgebraic function to have a constant angular component\<close>
+
+lemma ac_res_Unit_inc:
+  assumes "n > 0"
+  assumes "t \<in> Units (Zp_res_ring n)"
+  shows "ac n ([t]\<cdot>\<one>) = t"
+proof-
+  have 0: "[t]\<cdot>\<one> \<noteq>\<zero>"
+    using assms by (metis Qp_char_0_int less_one less_or_eq_imp_le nat_neq_iff zero_not_in_residue_units)
+  have 1: "[t]\<cdot>\<one> \<in> \<O>\<^sub>p" 
+    by (metis Zp.one_closed Zp_int_mult_closed image_eqI inc_of_int)
+  hence 2: "angular_component ([t]\<cdot>\<one>) = ac_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
+    using angular_component_of_inclusion[of "[t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>"] 
+    by (metis "0" Qp.int_inc_zero Zp.int_inc_zero Zp_int_inc_closed inc_of_int not_nonzero_Qp)
+  hence 3: "ac n ([t]\<cdot>\<one>) = ac_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) n"
+    unfolding ac_def using 0 by presburger
+  hence "val_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) = 0"
+  proof-
+    have "coprime p t"
+      using assms 
+      by (metis coprime_commute less_one less_or_eq_imp_le nat_neq_iff padic_integers.residue_UnitsE padic_integers_axioms)
+    then show ?thesis 
+      by (metis Zp_int_inc_closed Zp_int_inc_res coprime_mod_right_iff coprime_power_right_iff mod_by_0 order_refl p_residues residues.m_gt_one residues.mod_in_res_units val_Zp_0_criterion val_Zp_p val_Zp_p_int_unit zero_less_one zero_neq_one_class.one_neq_zero zero_not_in_residue_units)
+  qed
+  hence 4: "[t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub> \<in> Units Z\<^sub>p"
+    using val_Zp_0_imp_unit by blast
+  hence 5: "ac_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)  = [t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>"  using
+      ac_Zp_of_Unit  \<open>val_Zp ([t] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) = 0\<close> by blast
+  have 6: "ac_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) n  = t"
+  proof-
+    have "t \<in> carrier (Zp_res_ring n)"
+      using assms monoid.Units_closed[of "Zp_res_ring n" t] cring_def padic_integers.R_cring padic_integers_axioms ring_def by blast
+    hence "t < p^n \<and> t \<ge> 0 "
+      using p_residue_ring_car_memE by auto 
+    thus ?thesis
+      unfolding 5 unfolding Zp_int_inc_rep p_residue_def residue_def by auto 
+  qed
+  show ?thesis 
+    unfolding 3 using 6 by blast 
+qed
+
+lemma val_of_res_Unit:
+  assumes "n > 0"
+  assumes "t \<in> Units (Zp_res_ring n)"
+  shows "val ([t]\<cdot>\<one>) = 0"
+proof-
+  have 0: "[t]\<cdot>\<one> \<noteq>\<zero>"
+    using assms by (metis Qp_char_0_int less_one less_or_eq_imp_le nat_neq_iff zero_not_in_residue_units)
+  have 1: "[t]\<cdot>\<one> \<in> \<O>\<^sub>p" 
+    by (metis Zp.one_closed Zp_int_mult_closed image_eqI inc_of_int)
+  hence 2: "angular_component ([t]\<cdot>\<one>) = ac_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>)"
+    using angular_component_of_inclusion[of "[t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>"] 
+    by (metis "0" Qp.int_inc_zero Zp.int_inc_zero Zp_int_inc_closed inc_of_int not_nonzero_Qp)
+  hence 3: "ac n ([t]\<cdot>\<one>) = ac_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) n"
+    unfolding ac_def using 0 by presburger
+  hence "val_Zp ([t]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) = 0"
+  proof-
+    have "coprime p t"
+      using assms 
+      by (metis coprime_commute less_one less_or_eq_imp_le nat_neq_iff padic_integers.residue_UnitsE padic_integers_axioms)
+    then show ?thesis 
+      by (metis Zp_int_inc_closed Zp_int_inc_res coprime_mod_right_iff coprime_power_right_iff mod_by_0 order_refl p_residues residues.m_gt_one residues.mod_in_res_units val_Zp_0_criterion val_Zp_p val_Zp_p_int_unit zero_less_one zero_neq_one_class.one_neq_zero zero_not_in_residue_units)
+  qed
+  then show ?thesis using assms 
+    by (metis Zp_int_inc_closed inc_of_int val_of_inc)
+qed
+
+
+lemma(in padic_integers) res_map_is_hom:
+  assumes "N > 0"
+  shows "ring_hom_ring Zp (Zp_res_ring N) (\<lambda> x. x N)"
+  apply(rule ring_hom_ringI)
+  apply (simp add: R.ring_axioms)
+  using assms cring.axioms(1) local.R_cring apply blast
+  using residue_closed apply blast
+  using residue_of_prod apply blast
+  using residue_of_sum apply blast
+  using assms residue_of_one(1) by blast
+
+lemma ac_of_fraction:
+  assumes "N > 0"
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> nonzero Q\<^sub>p"
+  shows "ac N (a \<div> b) = ac N a \<otimes>\<^bsub>Zp_res_ring N\<^esub> inv \<^bsub>Zp_res_ring N\<^esub> ac N b"
+  using ac_mult[of a "inv b" N] ac_inv assms Qp.nonzero_closed nonzero_inverse_Qp by presburger 
+
+lemma pow_res_eq_rel:
+  assumes "n > 0"
+  assumes "b \<in> carrier Q\<^sub>p"
+  shows "{x \<in> carrier Q\<^sub>p. pow_res n x = pow_res n b} = pow_res n b"
+  apply(rule equalityI',  unfold mem_Collect_eq, metis pow_res_refl, 
+        intro conjI)
+    using pow_res_def apply auto[1] 
+    apply(rule equal_pow_resI)
+    using pow_res_def apply auto[1] 
+    using  pow_res_refl assms  by (metis equal_pow_resI)
+
+lemma pow_res_is_univ_semialgebraic':
+  assumes "n > 0"
+  assumes "b \<in> carrier Q\<^sub>p"
+  shows "is_univ_semialgebraic {x \<in> carrier Q\<^sub>p. pow_res n x = pow_res n b}"
+  using assms pow_res_eq_rel pow_res_is_univ_semialgebraic by presburger
+
+lemma evimage_eqI:
+  assumes "c \<in> carrier (SA n)"
+  shows "c  \<inverse>\<^bsub>n\<^esub> {x \<in> carrier Q\<^sub>p. P x} = {x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). P (c x)}"  
+  by(rule equalityI', unfold evimage_def mem_Collect_eq Int_iff,  intro conjI, auto
+        , rule SA_car_closed[of _ n], auto simp: assms)
+
+lemma SA_pow_res_is_semialgebraic:
+  assumes "n > 0"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "c \<in> carrier (SA N)"
+  shows "is_semialgebraic N  {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). pow_res n (c x) = pow_res n b}"
+proof-
+  have " c  \<inverse>\<^bsub>N\<^esub> {x \<in> carrier Q\<^sub>p. pow_res n x = pow_res n b} = {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). pow_res n (c x) = pow_res n b}"
+    apply(rule evimage_eqI) using assms by blast 
+  thus ?thesis 
+    using pow_res_is_univ_semialgebraic' evimage_is_semialg assms
+    by (metis (no_types, lifting))      
+qed
+
+lemma eint_diff_imp_eint:
+  assumes "a \<in> nonzero Q\<^sub>p"
+  assumes "b \<in> carrier Q\<^sub>p"
+  assumes "val a = val b + eint i"
+  shows "b \<in> nonzero Q\<^sub>p"
+  using assms val_zero 
+  by (metis Qp.nonzero_closed Qp.not_nonzero_memE not_eint_eq plus_eint_simps(2) val_ord')
+
+lemma SA_minus_eval:
+  assumes "f \<in> carrier (SA n)"
+  assumes "g \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(f  \<ominus>\<^bsub>SA n\<^esub> g) x = f x \<ominus> g x"
+  using assms unfolding a_minus_def 
+  using SA_a_inv_eval SA_add  by metis  
+
+lemma Qp_cong_set_evimage:
+  assumes "f \<in> carrier (SA n)"
+  assumes "a \<in> carrier Z\<^sub>p"
+  shows  "is_semialgebraic n (f \<inverse>\<^bsub>n\<^esub> (Qp_cong_set \<alpha> a))"
+  using assms Qp_cong_set_is_univ_semialgebraic evimage_is_semialg by blast
+
+lemma SA_constant_res_set_semialg: 
+  assumes "l \<in> carrier (Zp_res_ring n)"
+  assumes "f \<in> carrier (SA m)"
+  shows "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f x \<in> \<O>\<^sub>p \<and> Qp_res (f x) n = l}"
+proof- 
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f x \<in> \<O>\<^sub>p \<and> Qp_res (f x) n = l} = f  \<inverse>\<^bsub>m\<^esub> {x \<in> \<O>\<^sub>p. Qp_res x n = l}"
+    unfolding evimage_def  by blast 
+  show ?thesis unfolding 0 
+    by(rule evimage_is_semialg, rule assms, rule constant_res_set_semialg, rule assms)
+qed
+
+lemma val_ring_cong_set:
+  assumes "f \<in> carrier (SA k)"
+  assumes "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>) \<Longrightarrow> f x \<in> \<O>\<^sub>p"
+  assumes "t \<in> carrier (Zp_res_ring n)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). to_Zp (f x) n = t}"
+proof-
+  have 0: "[t] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub> \<in> carrier Z\<^sub>p "
+    by blast 
+  have 1: "([t] \<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>) n = t"
+    using assms 
+    unfolding Zp_int_inc_rep p_residue_def residue_def residue_ring_def by simp 
+  have "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). to_Zp (f x) n = t} = f  \<inverse>\<^bsub>k\<^esub> {x \<in> \<O>\<^sub>p. (to_Zp x) n = t}"
+    unfolding evimage_def using assms by auto
+  then show ?thesis using 0 1 assms  Qp_cong_set_evimage[of f k "[t]\<cdot>\<^bsub>Z\<^sub>p\<^esub> \<one>\<^bsub>Z\<^sub>p\<^esub>" n] unfolding Qp_cong_set_def 
+    by presburger
+qed
+
+lemma val_ring_pullback_SA:
+  assumes "N > 0"
+  assumes "c \<in> carrier (SA N)"
+  shows "is_semialgebraic N {x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). c x \<in> \<O>\<^sub>p}"
+proof-
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>N\<^esup>). c x \<in> \<O>\<^sub>p} = c  \<inverse>\<^bsub>N\<^esub> \<O>\<^sub>p"
+    unfolding evimage_def by blast
+  have 1: "is_univ_semialgebraic \<O>\<^sub>p"
+    using Qp_val_ring_is_univ_semialgebraic by blast
+  show ?thesis using assms 0 1 evimage_is_semialg by presburger
+qed
+
+lemma(in padic_fields) res_eq_set_is_semialg:
+  assumes "k > 0"
+  assumes "c \<in> carrier (SA k)"
+  assumes "s \<in> carrier (Zp_res_ring n)"
+  shows "is_semialgebraic k {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). c x \<in> \<O>\<^sub>p \<and> to_Zp (c x) n = s}"
+proof-
+  obtain a where a_def: "a = [s]\<cdot>\<one>"
+    by blast 
+  have 0: "a \<in> \<O>\<^sub>p"
+    using a_def 
+    by (metis Zp.one_closed Zp_int_mult_closed image_iff inc_of_int)
+  have 1: "to_Zp a = [s]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>"
+    using 0 unfolding a_def 
+    by (metis Q\<^sub>p_def Zp_def Zp_int_inc_closed \<iota>_def inc_to_Zp padic_fields.inc_of_int padic_fields_axioms)
+  have 2: "([s]\<cdot>\<^bsub>Z\<^sub>p\<^esub>\<one>\<^bsub>Z\<^sub>p\<^esub>) n = s"
+    using assms 
+    by (metis Zp_int_inc_res mod_pos_pos_trivial p_residue_ring_car_memE(1) p_residue_ring_car_memE(2))
+  have 3: "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). c x \<in> \<O>\<^sub>p \<and> to_Zp (c x) n = s} = c  \<inverse>\<^bsub>k\<^esub> B\<^bsub>n\<^esub>[a]"
+  proof
+    show "{x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). c x \<in> \<O>\<^sub>p \<and> to_Zp (c x) n = s} \<subseteq> c \<inverse>\<^bsub>k\<^esub> B\<^bsub>int n\<^esub>[a]"
+    proof fix x assume A: "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). c x \<in> \<O>\<^sub>p \<and> to_Zp (c x) n = s}"
+      then have  30: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)" by blast 
+      have 31: "c x \<in> \<O>\<^sub>p" using A by blast 
+      have 32: "to_Zp (c x) n = s" using A by blast 
+      have 33: "to_Zp (c x) \<in> carrier Z\<^sub>p"
+        using 31 val_ring_memE to_Zp_closed by blast
+      have 34: "to_Zp (c x) n = (to_Zp a) n"
+        using "1" "2" "32" by presburger
+      hence "((to_Zp (c x)) \<ominus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp a)) n = 0"
+        using "1" "33" Zp_int_inc_closed res_diff_zero_fact'' by presburger
+      hence 35: "val_Zp ((to_Zp (c x)) \<ominus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp a)) \<ge> n"
+        using "1" "33" "34" Zp.one_closed Zp_int_mult_closed val_Zp_dist_def val_Zp_dist_res_eq2 by presburger
+      have 36: "val (c x \<ominus> a) = val_Zp ((to_Zp (c x)) \<ominus>\<^bsub>Z\<^sub>p\<^esub> (to_Zp a))"
+        using 31 0 
+        by (metis to_Zp_minus to_Zp_val val_ring_minus_closed)
+      hence "val (c x \<ominus> a) \<ge> n"
+        using 35 by presburger
+      hence "c x \<in>  B\<^bsub>int n\<^esub>[a]"
+        using 31 c_ballI  val_ring_memE by blast
+      thus "x \<in> c \<inverse>\<^bsub>k\<^esub> B\<^bsub>int n\<^esub>[a]"
+        using 30  by blast 
+    qed
+    show "c \<inverse>\<^bsub>k\<^esub> B\<^bsub>int n\<^esub>[a] \<subseteq> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). c x \<in> \<O>\<^sub>p \<and> to_Zp (c x) n = s}"
+    proof fix x assume A: "x \<in> c \<inverse>\<^bsub>k\<^esub> B\<^bsub>int n\<^esub>[a]"
+      have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>)"
+        using A  by (meson evimage_eq)
+      have 00: "val (c x \<ominus> a) \<ge> n"
+        using A c_ballE(2) by blast
+      have cx_closed: "c x \<in> carrier Q\<^sub>p"
+        using x_closed assms function_ring_car_closed SA_car_memE(2) by blast
+      hence 11: "c x \<ominus> a \<in> \<O>\<^sub>p"
+      proof-
+        have "(0::eint) \<le> n"
+          by (metis eint_ord_simps(1) of_nat_0_le_iff zero_eint_def)
+        thus ?thesis using 00 order_trans[of "0::eint" n] Qp_val_ringI 
+          by (meson "0" Qp.minus_closed val_ring_memE cx_closed)
+      qed
+      hence 22: "c x \<in> \<O>\<^sub>p"
+      proof-
+        have 00: "c x = (c x \<ominus> a) \<oplus> a"
+          using cx_closed 0 
+          by (metis "11" Qp.add.inv_solve_right' Qp.minus_eq val_ring_memE(2))
+        have 01: "(c x \<ominus> a) \<oplus> a \<in> \<O>\<^sub>p"
+          by(intro val_ring_add_closed 0 11)
+        then show ?thesis 
+          using 0 11 image_iff  "00" by auto 
+      qed
+      have 33: "val (c x \<ominus> a) = val_Zp (to_Zp (c x) \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp a)"
+        using 11 22 0 
+        by (metis to_Zp_minus to_Zp_val)       
+      have 44: "val_Zp (to_Zp (c x) \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp a) \<ge> n"
+        using 33 00 by presburger
+      have tzpcx: "to_Zp (c x) \<in> carrier Z\<^sub>p"
+        using 22 by (metis image_iff inc_to_Zp)
+      have tzpa: "to_Zp a \<in> carrier Z\<^sub>p"
+        using 0 val_ring_memE to_Zp_closed by blast
+      have 55: "(to_Zp (c x) \<ominus>\<^bsub>Z\<^sub>p\<^esub> to_Zp a) n = 0"
+        using 44 tzpcx tzpa Zp.minus_closed zero_below_val_Zp by blast
+      hence 66: "to_Zp (c x) n = s"
+        using 0 1 2 tzpa tzpcx 
+        by (metis res_diff_zero_fact(1))
+      then show "x \<in> {x \<in> carrier (Q\<^sub>p\<^bsup>k\<^esup>). c x \<in> \<O>\<^sub>p \<and> to_Zp (c x) n = s}"
+        using "22" x_closed by blast
+    qed
+  qed
+  thus ?thesis 
+    using evimage_is_semialg[of c k] 0  val_ring_memE assms(2) ball_is_univ_semialgebraic by presburger
+qed
+
+lemma SA_constant_res_set_semialg': 
+  assumes "f \<in> carrier (SA m)"
+  assumes "C \<in> Qp_res_classes n"
+  shows "is_semialgebraic m (f  \<inverse>\<^bsub>m\<^esub> C)"
+proof- 
+  obtain l where l_def: "l \<in> carrier (Zp_res_ring n) \<and> C = Qp_res_class n ([l]\<cdot>\<one>)"
+    using Qp_res_classes_wits assms by blast 
+  have C_eq: "C = Qp_res_class n ([l]\<cdot>\<one>)"
+    using l_def by blast 
+  have 0: "Qp_res ([l] \<cdot> \<one>) n = l"
+    using l_def 
+    by (metis Qp_res_int_inc mod_pos_pos_trivial p_residue_ring_car_memE(1) p_residue_ring_car_memE(2))
+  have 1: "f  \<inverse>\<^bsub>m\<^esub> C = {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f x \<in> \<O>\<^sub>p \<and> Qp_res (f x) n = l}"
+    apply(rule equalityI') 
+    unfolding evimage_def C_eq Qp_res_class_def mem_Collect_eq unfolding 0 apply blast
+    by blast 
+  show ?thesis 
+    unfolding 1 apply(rule SA_constant_res_set_semialg )
+    using  l_def apply blast by(rule assms)
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Semialgebraic Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+lemma UP_SA_n_is_ring:
+  shows "ring (UP (SA n))"
+  using SA_is_ring  
+  by (simp add: UP_ring.UP_ring UP_ring.intro)
+  
+lemma UP_SA_n_is_cring:
+  shows "cring (UP (SA n))"
+  using SA_is_cring  
+  by (simp add: UP_cring.UP_cring UP_cring.intro)
+
+text\<open>The evaluation homomorphism from \texttt{Qp\_funs} to \texttt{Qp}\<close>
+
+definition eval_hom where 
+"eval_hom a = (\<lambda>f. f a)"
+
+lemma eval_hom_is_hom:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "ring_hom_ring (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a)"
+  apply(rule ring_hom_ringI)
+  using Qp_funs_is_cring cring.axioms(1) apply blast
+  apply (simp add: Qp.ring_axioms)  
+  apply (simp add: Qp.function_ring_car_mem_closed assms eval_hom_def) 
+  apply (metis Qp_funs_mult' assms eval_hom_def)
+  apply (metis Qp_funs_add' assms eval_hom_def)
+  by (metis function_one_eval assms eval_hom_def)
+
+text\<open>the homomorphism from \texttt{Fun n Qp [x]} to \texttt{Qp [x]} induced by evaluation of coefficients\<close>
+
+definition Qp_fpoly_to_Qp_poly where
+"Qp_fpoly_to_Qp_poly n a = poly_lift_hom (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a)"
+
+lemma Qp_fpoly_to_Qp_poly_is_hom:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(Qp_fpoly_to_Qp_poly n a) \<in> ring_hom (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)) (Q\<^sub>p_x) "
+  unfolding Qp_fpoly_to_Qp_poly_def 
+  apply(rule UP_cring.poly_lift_hom_is_hom)
+  unfolding UP_cring_def 
+  apply (simp add: Qp_funs_is_cring)
+  apply (simp add: UPQ.R_cring)
+  using assms eval_hom_is_hom[of a] ring_hom_ring.homh by blast
+
+lemma Qp_fpoly_to_Qp_poly_extends_apply:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  shows "Qp_fpoly_to_Qp_poly n a (to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) f) = to_polynomial Q\<^sub>p (f a)"
+  unfolding Qp_fpoly_to_Qp_poly_def 
+  using assms eval_hom_is_hom[of a] UP_cring.poly_lift_hom_extends_hom[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" Q\<^sub>p "eval_hom a" ]
+        Qp.function_ring_car_memE[of f n] ring_hom_ring.homh
+  unfolding eval_hom_def UP_cring_def 
+  using Qp_funs_is_cring UPQ.R_cring by blast
+
+lemma Qp_fpoly_to_Qp_poly_X_var:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "Qp_fpoly_to_Qp_poly n a (X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p)) = X_poly Q\<^sub>p"
+  unfolding X_poly_def Qp_fpoly_to_Qp_poly_def
+  apply(rule UP_cring.poly_lift_hom_X_var) unfolding UP_cring_def 
+    apply (simp add: Qp_funs_is_cring)    
+      apply (simp add: UPQ.R_cring)      
+        using assms(1) eval_hom_is_hom ring_hom_ring.homh 
+  by blast
+  
+lemma Qp_fpoly_to_Qp_poly_monom:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  shows "Qp_fpoly_to_Qp_poly n a (up_ring.monom (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)) f m) = up_ring.monom Q\<^sub>p_x (f a) m"
+  unfolding Qp_fpoly_to_Qp_poly_def 
+  using UP_cring.poly_lift_hom_monom[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" Q\<^sub>p "eval_hom a" f m] assms ring_hom_ring.homh
+        eval_hom_is_hom[of a] unfolding eval_hom_def UP_cring_def 
+  using Qp_funs_is_cring UPQ.R_cring by blast
+  
+lemma Qp_fpoly_to_Qp_poly_coeff:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  shows "Qp_fpoly_to_Qp_poly n a f k = (f k) a"
+  using assms UP_cring.poly_lift_hom_cf[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" Q\<^sub>p "eval_hom a" f k] eval_hom_is_hom[of a] 
+  unfolding  Qp_fpoly_to_Qp_poly_def eval_hom_def 
+  using Qp_funs_is_cring ring_hom_ring.homh  ring_hom_ring.homh
+  unfolding eval_hom_def UP_cring_def 
+  using UPQ.R_cring by blast  
+
+lemma Qp_fpoly_to_Qp_poly_eval:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "P \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  shows "(UP_cring.to_fun (Fun\<^bsub>n\<^esub> Q\<^sub>p) P f) a  = UP_cring.to_fun Q\<^sub>p (Qp_fpoly_to_Qp_poly n a P) (f a)"
+  unfolding Qp_fpoly_to_Qp_poly_def 
+  using UP_cring.poly_lift_hom_eval[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" Q\<^sub>p "eval_hom a" P f] 
+        eval_hom_is_hom[of a] eval_hom_def assms ring_hom_ring.homh Qp_funs_is_cring
+  unfolding eval_hom_def UP_cring_def 
+  using UPQ.R_cring by blast
+ 
+lemma Qp_fpoly_to_Qp_poly_sub:
+  assumes "f \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "g \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "Qp_fpoly_to_Qp_poly n a (compose (Fun\<^bsub>n\<^esub> Q\<^sub>p) f g) = compose Q\<^sub>p (Qp_fpoly_to_Qp_poly n a f) (Qp_fpoly_to_Qp_poly n a g)"
+  unfolding Qp_fpoly_to_Qp_poly_def 
+  using assms UP_cring.poly_lift_hom_sub[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" Q\<^sub>p "eval_hom a" f g]
+        eval_hom_is_hom[of a] ring_hom_ring.homh[of "Fun\<^bsub>n\<^esub> Q\<^sub>p" Q\<^sub>p "eval_hom a"]
+        Qp_funs_is_cring  
+  unfolding eval_hom_def UP_cring_def 
+  using UPQ.R_cring by blast
+
+lemma Qp_fpoly_to_Qp_poly_taylor_poly:
+  assumes "F \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+  assumes "c \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "Qp_fpoly_to_Qp_poly n a (taylor_expansion (Fun\<^bsub>n\<^esub> Q\<^sub>p) c F) = 
+        taylor_expansion Q\<^sub>p (c a) (Qp_fpoly_to_Qp_poly n a F)"
+proof-
+  have 0: "X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p) \<oplus>\<^bsub>UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<^esub> to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+    by (metis Qp_funs_is_cring UP_cring.X_plus_closed UP_cring_def X_poly_plus_def assms(2))
+  have 1: "poly_lift_hom (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a) (X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p) \<oplus>\<^bsub>UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<^esub> to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c) = X_poly Q\<^sub>p \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> UPQ.to_poly (c a)"
+  proof-
+    have 10: "poly_lift_hom (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a) \<in> ring_hom (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)) Q\<^sub>p_x"
+      using Qp_fpoly_to_Qp_poly_def Qp_fpoly_to_Qp_poly_is_hom assms
+      by presburger
+    have 11: " to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p))"
+      by (meson Qp_funs_is_cring UP_cring.intro UP_cring.to_poly_closed assms)
+    have 12: "X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p) \<in> carrier (UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)) "
+      using UP_cring.X_closed[of "Fun\<^bsub>n\<^esub> Q\<^sub>p"] unfolding UP_cring_def 
+      using Qp_funs_is_cring 
+      by blast
+    have "Qp_fpoly_to_Qp_poly n a (X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p) \<oplus>\<^bsub>UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<^esub> to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c) =
+    Qp_fpoly_to_Qp_poly n a (X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p)) \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> Qp_fpoly_to_Qp_poly n a (to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c)"    
+      using assms 0 10 11 12 Qp_fpoly_to_Qp_poly_extends_apply[of a n c] Qp_fpoly_to_Qp_poly_is_hom[of a] Qp_fpoly_to_Qp_poly_X_var[of a]
+      using ring_hom_add[of "Qp_fpoly_to_Qp_poly n a"  "UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)" Q\<^sub>p_x "X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p)" "to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c" ]
+      unfolding Qp_fpoly_to_Qp_poly_def 
+      by blast
+     then show ?thesis 
+       using Qp_fpoly_to_Qp_poly_X_var Qp_fpoly_to_Qp_poly_def Qp_fpoly_to_Qp_poly_extends_apply assms 
+       by metis 
+  qed
+  have 2: "poly_lift_hom (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a) (compose (Fun\<^bsub>n\<^esub> Q\<^sub>p) F (X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p) \<oplus>\<^bsub>UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<^esub> to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c)) =
+   UPQ.sub (poly_lift_hom (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a) F) 
+    (poly_lift_hom (Fun\<^bsub>n\<^esub> Q\<^sub>p) Q\<^sub>p (eval_hom a) (X_poly (Fun\<^bsub>n\<^esub> Q\<^sub>p) \<oplus>\<^bsub>UP (Fun\<^bsub>n\<^esub> Q\<^sub>p)\<^esub> to_polynomial (Fun\<^bsub>n\<^esub> Q\<^sub>p) c))"
+    using 0 1 Qp_fpoly_to_Qp_poly_sub[of F n "X_poly_plus (Fun\<^bsub>n\<^esub> Q\<^sub>p) c" a] assms
+    unfolding Qp_fpoly_to_Qp_poly_def X_poly_plus_def 
+    by blast
+  show ?thesis  
+    using assms 0 1
+    unfolding Qp_fpoly_to_Qp_poly_def  taylor_expansion_def X_poly_plus_def
+    using "2" by presburger    
+qed 
+
+lemma SA_is_UP_cring:
+  shows "UP_cring (SA n)"
+  unfolding UP_cring_def 
+  by (simp add: SA_is_cring)
+
+lemma eval_hom_is_SA_hom:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "ring_hom_ring (SA n) Q\<^sub>p (eval_hom a)"
+  apply(rule ring_hom_ringI)
+  using SA_is_cring cring.axioms(1) assms(1) apply blast 
+  using Qp.ring_axioms apply blast 
+  apply (metis (no_types, lifting) SA_car assms eval_hom_def Qp.function_ring_car_mem_closed semialg_functions_memE(2))
+  apply (metis (mono_tags, lifting) Qp_funs_mult' SA_car SA_times assms eval_hom_def semialg_functions_memE(2))
+  apply (metis (mono_tags, lifting) Qp_funs_add' SA_car SA_plus assms eval_hom_def semialg_functions_memE(2))
+  using Qp_constE Qp.one_closed SA_one assms eval_hom_def function_one_as_constant
+  by (metis function_one_eval)
+
+text\<open>the homomorphism from \texttt{(SA n)[x]} to \texttt{Qp [x]} induced by evaluation of coefficients\<close>
+
+definition SA_poly_to_Qp_poly where
+"SA_poly_to_Qp_poly n a = poly_lift_hom (SA n) Q\<^sub>p (eval_hom a)"
+
+lemma SA_poly_to_Qp_poly_is_hom:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "(SA_poly_to_Qp_poly n a) \<in> ring_hom (UP (SA n)) (Q\<^sub>p_x) "
+  unfolding SA_poly_to_Qp_poly_def 
+  apply(rule UP_cring.poly_lift_hom_is_hom)
+  using SA_is_cring assms(1) UP_cring.intro apply blast  
+  apply (simp add: UPQ.R_cring)
+  using assms eval_hom_is_SA_hom ring_hom_ring.homh by blast
+
+lemma SA_poly_to_Qp_poly_closed:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "P \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_Qp_poly n a P \<in> carrier Q\<^sub>p_x"
+  using assms SA_poly_to_Qp_poly_is_hom[of a] ring_hom_closed[of "SA_poly_to_Qp_poly n a" "UP (SA n)" Q\<^sub>p_x P] 
+  by blast
+
+lemma SA_poly_to_Qp_poly_add:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_Qp_poly n a (f \<oplus>\<^bsub>UP (SA n)\<^esub> g) = SA_poly_to_Qp_poly n a f \<oplus>\<^bsub>Q\<^sub>p_x\<^esub> SA_poly_to_Qp_poly n a g"
+  using SA_poly_to_Qp_poly_is_hom ring_hom_add assms 
+  by (metis (no_types, opaque_lifting))
+
+lemma SA_poly_to_Qp_poly_minus:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+   shows "SA_poly_to_Qp_poly n a (f \<ominus>\<^bsub>UP (SA n)\<^esub> g) = SA_poly_to_Qp_poly n a f \<ominus>\<^bsub>Q\<^sub>p_x\<^esub> SA_poly_to_Qp_poly n a g"
+  using SA_poly_to_Qp_poly_is_hom[of a] assms SA_is_ring[of n] 
+        ring.ring_hom_minus[of "UP (SA n)" Q\<^sub>p_x "SA_poly_to_Qp_poly n a" f g] UP_SA_n_is_ring 
+        UPQ.UP_ring 
+  by blast
+
+lemma SA_poly_to_Qp_poly_mult:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_Qp_poly n a (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) = SA_poly_to_Qp_poly n a f \<otimes>\<^bsub>Q\<^sub>p_x\<^esub> SA_poly_to_Qp_poly n a g"
+  using SA_poly_to_Qp_poly_is_hom ring_hom_mult assms 
+  by (metis (no_types, opaque_lifting))
+
+lemma SA_poly_to_Qp_poly_extends_apply:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (SA n)"
+  shows "SA_poly_to_Qp_poly n a (to_polynomial (SA n) f) = to_polynomial Q\<^sub>p (f a)"
+  unfolding SA_poly_to_Qp_poly_def 
+  using assms eval_hom_is_SA_hom[of a] UP_cring.poly_lift_hom_extends_hom[of "SA n" Q\<^sub>p "eval_hom a" f]
+         eval_hom_def   SA_is_cring Qp.cring_axioms ring_hom_ring.homh
+  unfolding eval_hom_def UP_cring_def 
+  by blast
+
+lemma SA_poly_to_Qp_poly_X_var:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "SA_poly_to_Qp_poly n a (X_poly (SA n)) = X_poly Q\<^sub>p"
+  unfolding X_poly_def SA_poly_to_Qp_poly_def
+  apply(rule UP_cring.poly_lift_hom_X_var)
+    using SA_is_cring assms(1) 
+    using UP_cring.intro apply blast
+    apply (simp add: Qp.cring_axioms)
+    using assms eval_hom_is_SA_hom ring_hom_ring.homh by blast    
+
+lemma SA_poly_to_Qp_poly_X_plus:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "c \<in> carrier (SA n)"
+  shows "SA_poly_to_Qp_poly n a (X_poly_plus (SA n) c) = UPQ.X_plus (c a)"
+  unfolding X_poly_plus_def 
+  using assms SA_poly_to_Qp_poly_add[of a n "X_poly (SA n)" "to_polynomial (SA n) c"]
+        SA_poly_to_Qp_poly_extends_apply[of a n c] UP_cring.X_closed[of "SA n"] SA_is_cring[of n]
+        SA_poly_to_Qp_poly_X_var[of a] UP_cring.to_poly_closed[of "SA n" c] 
+  unfolding UP_cring_def 
+  by metis 
+
+lemma SA_poly_to_Qp_poly_X_minus:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "c \<in> carrier (SA n)"
+  shows "SA_poly_to_Qp_poly n a (X_poly_minus (SA n) c) = UPQ.X_minus (c a)"
+  unfolding X_poly_minus_def 
+  using assms SA_poly_to_Qp_poly_minus[of a n "X_poly (SA n)" "to_polynomial (SA n) c"]
+        SA_poly_to_Qp_poly_extends_apply[of a n c] UP_cring.X_closed[of "SA n"] SA_is_cring[of n]
+        SA_poly_to_Qp_poly_X_var[of a n] UP_cring.to_poly_closed[of "SA n" c] 
+  unfolding UP_cring_def 
+  by metis 
+
+lemma SA_poly_to_Qp_poly_monom:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (SA n)"
+  shows "SA_poly_to_Qp_poly n a (up_ring.monom (UP (SA n)) f m) = up_ring.monom Q\<^sub>p_x (f a) m"
+  unfolding SA_poly_to_Qp_poly_def 
+  using UP_cring.poly_lift_hom_monom[of "SA n" Q\<^sub>p "eval_hom a" f n] assms eval_hom_is_SA_hom eval_hom_def 
+   SA_is_cring Qp.cring_axioms UP_cring.poly_lift_hom_monom ring_hom_ring.homh
+  by (metis UP_cring.intro)
+
+lemma SA_poly_to_Qp_poly_coeff:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_Qp_poly n a f k = (f k) a"
+  using assms UP_cring.poly_lift_hom_cf[of "SA n" Q\<^sub>p "eval_hom a" f k] eval_hom_is_SA_hom[of a] 
+  using SA_is_cring Qp.cring_axioms ring_hom_ring.homh
+  unfolding  SA_poly_to_Qp_poly_def eval_hom_def UP_cring_def
+  by blast
+
+lemma SA_poly_to_Qp_poly_eval:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "P \<in> carrier (UP (SA n))"
+  assumes "f \<in> carrier (SA n)"
+  shows "(UP_cring.to_fun (SA n) P f) a  = UP_cring.to_fun Q\<^sub>p (SA_poly_to_Qp_poly n a P) (f a)"
+  unfolding SA_poly_to_Qp_poly_def 
+  using UP_cring.poly_lift_hom_eval[of "SA n" Q\<^sub>p "eval_hom a" P f] 
+        eval_hom_is_SA_hom[of a] eval_hom_def assms SA_is_cring Qp.cring_axioms ring_hom_ring.homh
+  unfolding  SA_poly_to_Qp_poly_def eval_hom_def UP_cring_def
+  by blast
+
+lemma SA_poly_to_Qp_poly_sub:
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "SA_poly_to_Qp_poly n a (compose (SA n) f g) = compose Q\<^sub>p (SA_poly_to_Qp_poly n a f) (SA_poly_to_Qp_poly n a g)"
+  unfolding SA_poly_to_Qp_poly_def 
+  using assms UP_cring.poly_lift_hom_sub[of "SA n" Q\<^sub>p "eval_hom a" f g]
+        eval_hom_is_SA_hom[of a] ring_hom_ring.homh[of "SA n" Q\<^sub>p "eval_hom a"]
+        SA_is_cring Qp.cring_axioms 
+  unfolding  SA_poly_to_Qp_poly_def eval_hom_def UP_cring_def
+  by blast
+
+lemma SA_poly_to_Qp_poly_deg_bound: 
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "deg Q\<^sub>p (SA_poly_to_Qp_poly m x g) \<le> deg (SA m) g"
+  apply(rule  UPQ.deg_leqI) 
+    using assms SA_poly_to_Qp_poly_closed[of x m g] apply blast 
+  proof- fix n assume A: "deg (SA m) g < n"
+    then have "g n = \<zero>\<^bsub>SA m\<^esub>"
+      using assms SA_is_UP_cring[of m] UP_cring.UP_car_memE(2) by blast
+    thus "SA_poly_to_Qp_poly m x g n = \<zero>"
+      using assms SA_poly_to_Qp_poly_coeff[of x m g n] function_zero_eval SA_zero by presburger
+  qed
+
+lemma SA_poly_to_Qp_poly_taylor_poly:
+  assumes "F \<in> carrier (UP (SA n))"
+  assumes "c \<in> carrier (SA n)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "SA_poly_to_Qp_poly n a (taylor_expansion (SA n) c F) = 
+        taylor_expansion Q\<^sub>p (c a) (SA_poly_to_Qp_poly n a F)"
+  unfolding SA_poly_to_Qp_poly_def using assms Qp.cring_axioms SA_is_cring eval_hom_def 
+      eval_hom_is_SA_hom UP_cring.poly_lift_hom_comm_taylor_expansion[of "SA n" Q\<^sub>p "eval_hom a" F c] ring_hom_ring.homh
+  unfolding  SA_poly_to_Qp_poly_def eval_hom_def UP_cring_def 
+  by metis
+
+lemma SA_poly_to_Qp_poly_comm_taylor_term:
+  assumes "F \<in> carrier (UP (SA n))"
+  assumes "c \<in> carrier (SA n)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "SA_poly_to_Qp_poly n a (UP_cring.taylor_term (SA n) c F i) = 
+        UP_cring.taylor_term Q\<^sub>p (c a) (SA_poly_to_Qp_poly n a F) i"
+  unfolding SA_poly_to_Qp_poly_def using assms  Qp.cring_axioms SA_is_cring eval_hom_def
+      eval_hom_is_SA_hom UP_cring.poly_lift_hom_comm_taylor_term[of "SA n" Q\<^sub>p "eval_hom a" F c i] ring_hom_ring.homh
+  unfolding  SA_poly_to_Qp_poly_def eval_hom_def UP_cring_def 
+  by metis
+
+lemma SA_poly_to_Qp_poly_comm_pderiv:
+  assumes "F \<in> carrier (UP (SA n))"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) F) = 
+        UP_cring.pderiv Q\<^sub>p (SA_poly_to_Qp_poly n a F)"
+  apply(rule UP_ring.poly_induct3[of "SA n" F]) unfolding UP_ring_def 
+  apply (simp add: SA_is_ring assms(1))
+  using assms apply blast
+proof-
+  show "\<And>p q. q \<in> carrier (UP (SA n)) \<Longrightarrow>
+           p \<in> carrier (UP (SA n)) \<Longrightarrow>
+           SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) p) = UPQ.pderiv (SA_poly_to_Qp_poly n a p) \<Longrightarrow>
+           SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) q) = UPQ.pderiv (SA_poly_to_Qp_poly n a q) \<Longrightarrow>
+           SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) (p \<oplus>\<^bsub>UP (SA n)\<^esub> q)) = UPQ.pderiv (SA_poly_to_Qp_poly n a (p \<oplus>\<^bsub>UP (SA n)\<^esub> q))"
+  proof- fix p q assume A: "q \<in> carrier (UP (SA n))"
+           "p \<in> carrier (UP (SA n))"
+           "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) p) = UPQ.pderiv (SA_poly_to_Qp_poly n a p)"
+           "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) q) = UPQ.pderiv (SA_poly_to_Qp_poly n a q)"
+    show "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) (p \<oplus>\<^bsub>UP (SA n)\<^esub> q)) = UPQ.pderiv (SA_poly_to_Qp_poly n a (p \<oplus>\<^bsub>UP (SA n)\<^esub> q))"
+    proof-
+      have 0: "SA_poly_to_Qp_poly n a p \<in> carrier (UP Q\<^sub>p)" 
+        using A assms SA_poly_to_Qp_poly_closed[of a n p] 
+        by blast
+      have 1: "SA_poly_to_Qp_poly n a q \<in> carrier (UP Q\<^sub>p)"
+        using A SA_poly_to_Qp_poly_closed[of a n q] assms by blast 
+      have 2: "UPQ.pderiv (SA_poly_to_Qp_poly n a p) \<in> carrier (UP Q\<^sub>p)" 
+        using  UPQ.pderiv_closed[of "SA_poly_to_Qp_poly n a p"] 0  by blast
+      have 3: "UPQ.pderiv (SA_poly_to_Qp_poly n a q) \<in> carrier (UP Q\<^sub>p)"
+        using A assms  UPQ.pderiv_closed[of "SA_poly_to_Qp_poly n a q"] 1 by blast 
+      have 4: "UP_cring.pderiv (SA n) p \<in> carrier (UP (SA n))"
+        using A UP_cring.pderiv_closed[of "SA n" p] unfolding UP_cring_def 
+        using SA_is_cring assms(1) by blast
+      have 5: "UP_cring.pderiv (SA n) q \<in> carrier (UP (SA n))"
+        using A UP_cring.pderiv_closed[of "SA n" q] unfolding UP_cring_def  
+        using SA_is_cring assms(1) by blast
+      have 6: "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) p \<oplus>\<^bsub>UP (SA n)\<^esub> UP_cring.pderiv (SA n) q) =
+    SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) p) \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) q)"
+        using A 4 5 SA_poly_to_Qp_poly_add assms  by blast
+      have 7: "UPQ.pderiv (SA_poly_to_Qp_poly n a p \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly n a q) =
+    UPQ.pderiv (SA_poly_to_Qp_poly n a p) \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> UPQ.pderiv (SA_poly_to_Qp_poly n a q)"
+        using "0" "1" UPQ.pderiv_add by blast
+      have 8: "UP_cring.pderiv (SA n) (p \<oplus>\<^bsub>UP (SA n)\<^esub> q) = UP_cring.pderiv (SA n) p \<oplus>\<^bsub>UP (SA n)\<^esub> UP_cring.pderiv (SA n) q"  
+        using A assms UP_cring.pderiv_add[of "SA n" p q]
+        unfolding UP_cring_def  using SA_is_cring by blast
+      have 9: "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) (p \<oplus>\<^bsub>UP (SA n)\<^esub> q)) =
+    UPQ.pderiv (SA_poly_to_Qp_poly n a p) \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> UPQ.pderiv (SA_poly_to_Qp_poly n a q)"
+        using A 6 8 by presburger
+      have 10: "UPQ.pderiv (SA_poly_to_Qp_poly n a (p \<oplus>\<^bsub>UP (SA n)\<^esub> q)) = 
+    UPQ.pderiv (SA_poly_to_Qp_poly n a p) \<oplus> \<^bsub>UP Q\<^sub>p\<^esub> UPQ.pderiv (SA_poly_to_Qp_poly n a q)"
+        using "7" A(1) A(2) SA_poly_to_Qp_poly_add assms  by presburger
+      show ?thesis using 9 10 
+        by presburger
+    qed
+  qed
+  show "\<And>aa na.
+       aa \<in> carrier (SA n) \<Longrightarrow>
+       SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) (up_ring.monom (UP (SA n)) aa na)) =
+       UPQ.pderiv (SA_poly_to_Qp_poly n a (up_ring.monom (UP (SA n)) aa na))"
+  proof- fix b m assume A: "b \<in> carrier (SA n)"
+    show "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) (up_ring.monom (UP (SA n)) b m)) =
+       UPQ.pderiv (SA_poly_to_Qp_poly n a (up_ring.monom (UP (SA n)) b m))"
+    proof-
+      have 0: "(UP_cring.pderiv (SA n) (up_ring.monom (UP (SA n)) b m)) = 
+              (up_ring.monom (UP (SA n)) ([m]\<cdot>\<^bsub>SA n\<^esub>b) (m-1))"
+        using UP_cring.pderiv_monom[of "SA n" b m] unfolding UP_cring_def 
+        using SA_is_cring \<open>b \<in> carrier (SA n)\<close> assms(1) by blast
+      have 1: "(SA_poly_to_Qp_poly n a (up_ring.monom (UP (SA n)) b m)) =up_ring.monom (UP Q\<^sub>p) (b a) m" 
+        using SA_poly_to_Qp_poly_monom \<open>b \<in> carrier (SA n)\<close> assms  by blast
+      have 2: "b a \<in> carrier Q\<^sub>p"
+        using A assms Qp.function_ring_car_mem_closed SA_car_memE(2) by metis        
+      hence 3: "UPQ.pderiv (SA_poly_to_Qp_poly n a (up_ring.monom (UP (SA n)) b m)) = up_ring.monom (UP Q\<^sub>p) ([m]\<cdot>(b a)) (m-1)"
+        using 1 2 A UPQ.pderiv_monom[of "b a" m] 
+        by presburger
+      have 4: "[m] \<cdot>\<^bsub>SA n\<^esub> b \<in> carrier (SA n)"
+        using A assms  SA_is_cring[of n] ring.add_pow_closed[of "SA n" b m] SA_is_ring 
+        by blast
+      have 5: "SA_poly_to_Qp_poly n a (up_ring.monom (UP (SA n)) ([m] \<cdot>\<^bsub>SA n\<^esub> b) (m-1)) = up_ring.monom (UP Q\<^sub>p) (([m] \<cdot>\<^bsub>SA n\<^esub> b) a) (m-1)"
+        using SA_poly_to_Qp_poly_monom[of a n "[m]\<cdot>\<^bsub>SA n\<^esub>b" "m-1"] assms 4 by blast
+      have 6: "SA_poly_to_Qp_poly n a (UP_cring.pderiv (SA n) (up_ring.monom (UP (SA n)) b m)) = up_ring.monom (UP Q\<^sub>p) (([m] \<cdot>\<^bsub>SA n\<^esub> b) a) (m - 1)"
+         using 5 0  by presburger
+      thus ?thesis using assms A 3 6 SA_add_pow_apply[of b n a] 
+        by auto 
+    qed
+  qed
+qed
+
+lemma SA_poly_to_Qp_poly_pderiv:
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "UPQ.pderiv (SA_poly_to_Qp_poly m x g) = (SA_poly_to_Qp_poly m x (pderiv m g))"
+proof
+  fix n 
+  have 0: "UPQ.pderiv (SA_poly_to_Qp_poly m x g) n = [Suc n] \<cdot> SA_poly_to_Qp_poly m x g (Suc n)"
+    by(rule UPQ.pderiv_cfs[of "SA_poly_to_Qp_poly m x g"n], rule SA_poly_to_Qp_poly_closed, rule assms , rule assms)
+  have 1: "SA_poly_to_Qp_poly m x (UPSA.pderiv m g) n = UPSA.pderiv m g n x"
+    by(rule SA_poly_to_Qp_poly_coeff[of x m "UPSA.pderiv m g" n], rule assms, rule UPSA.pderiv_closed, rule assms)
+  have 2: "SA_poly_to_Qp_poly m x (UPSA.pderiv m g) n = ([Suc n] \<cdot>\<^bsub>SA m\<^esub> g (Suc n)) x"
+    using UPSA.pderiv_cfs[of g m n] assms unfolding 1 by auto  
+  show "UPQ.pderiv (SA_poly_to_Qp_poly m x g) n = SA_poly_to_Qp_poly m x (UPSA.pderiv m g) n"
+    unfolding 0 2 using SA_poly_to_Qp_poly_coeff assms 
+    by (metis "0" "2" SA_poly_to_Qp_poly_comm_pderiv)
+qed
+    
+lemma(in UP_cring) pderiv_deg_lt:
+  assumes "f \<in> carrier (UP R)"
+  assumes "deg R f > 0"
+  shows "deg R (pderiv f) < deg R f"
+proof- 
+  obtain n where n_def: "n = deg R f"
+    by blast 
+  have 0: "\<And>k. k \<ge> n \<Longrightarrow> pderiv f k = \<zero>"
+    using pderiv_cfs assms unfolding n_def 
+    by (simp add: UP_car_memE(2)) 
+  obtain k where k_def: "n = Suc k"
+    using n_def assms gr0_implies_Suc by presburger 
+  have "deg R (pderiv f) \<le> k"
+    apply(rule deg_leqI)
+    using P_def assms(1) pderiv_closed apply presburger 
+    apply(rule 0)
+    unfolding k_def by presburger 
+  thus ?thesis using k_def unfolding n_def by linarith 
+qed
+
+lemma deg_pderiv:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "deg (SA m) f > 0"
+  shows "deg (SA m) (pderiv m f) = deg (SA m) f - 1"
+proof- 
+  obtain n where n_def: "n = deg (SA m) f"
+    by blast
+  have 0: "f n \<noteq> \<zero>\<^bsub>SA m\<^esub>"
+    unfolding n_def using assms UPSA.deg_ltrm by fastforce
+  have 1: "(pderiv m f) (n-1) = [n]\<cdot>\<^bsub>SA m\<^esub> (f n)"
+    using assms unfolding n_def using  Suc_diff_1 UPSA.pderiv_cfs by presburger
+  have 2: "deg (SA m) (pderiv m f) \<ge> (n-1)"
+    using 0 assms SA_char_zero 
+    by (metis "1" UPSA.deg_eqI UPSA.lcf_closed UPSA.pderiv_closed n_def nat_le_linear) 
+  have 3: "deg (SA m) (pderiv m f) < deg (SA m) f"
+    using assms  pderiv_deg_lt by auto 
+  thus ?thesis using 2  unfolding  n_def by presburger
+qed
+
+lemma SA_poly_to_Qp_poly_smult:
+  assumes "a \<in> carrier (SA m)"
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "SA_poly_to_Qp_poly m x (a \<odot>\<^bsub>UP (SA m)\<^esub> f) = a x \<odot>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly m x f"
+proof-
+  have 0: "a \<odot>\<^bsub>UP (SA m)\<^esub> f = to_polynomial (SA m) a \<otimes>\<^bsub>UP (SA m)\<^esub> f"
+    using assms  UPSA.to_poly_mult_simp(1) by presburger
+  have 1: "SA_poly_to_Qp_poly m x (a \<odot>\<^bsub>UP (SA m)\<^esub> f) = SA_poly_to_Qp_poly m x (to_polynomial (SA m) a) \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly m x f"
+    unfolding 0 apply(rule SA_poly_to_Qp_poly_mult)
+    using assms apply blast
+    using assms to_poly_closed  apply blast
+    using assms by blast 
+  have 2: "SA_poly_to_Qp_poly m x (a \<odot>\<^bsub>UP (SA m)\<^esub> f) = (to_polynomial Q\<^sub>p (a x)) \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly m x f"
+    unfolding 1 using assms SA_poly_to_Qp_poly_monom unfolding to_polynomial_def
+    by presburger
+  show ?thesis 
+    unfolding 2 apply(rule UP_cring.to_poly_mult_simp(1)[of Q\<^sub>p "a x" "SA_poly_to_Qp_poly m x f"])
+    unfolding UP_cring_def 
+    apply (simp add: Qp.cring)
+    using assms SA_car_memE apply blast
+    using   assms SA_poly_to_Qp_poly_closed[of x m f] by blast 
+qed
+
+lemma SA_poly_constant_res_class_semialg:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> f i x \<in> \<O>\<^sub>p"
+  assumes "deg (SA m) f \<le> d"
+  assumes "C \<in> poly_res_classes n d"
+  shows "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). SA_poly_to_Qp_poly m x f \<in> C}"
+proof-
+  obtain Fs where Fs_def: "Fs = f ` {..d}"
+    by blast 
+  obtain g where g_def: "g \<in> val_ring_polys_grad d \<and> C = poly_res_class n d g"
+    using assms unfolding poly_res_classes_def by blast 
+  have C_eq: " C = poly_res_class n d g"
+    using g_def by blast 
+  have 0: "{x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). SA_poly_to_Qp_poly m x f \<in> C} = 
+            (\<Inter> i \<in> {..d}. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n})"
+    apply(rule equalityI')
+    unfolding mem_Collect_eq 
+  proof(rule InterI)
+    fix x S
+    assume A: " x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> SA_poly_to_Qp_poly m x f \<in> C"
+           "S \<in> (\<lambda>i. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n}) ` {..d}"
+    have 0: "C = poly_res_class n d (SA_poly_to_Qp_poly m x f)"
+      unfolding C_eq 
+      apply(rule equalityI', rule poly_res_class_memI, rule poly_res_class_memE[of _ n d g], blast
+          , rule poly_res_class_memE[of _ n d g], blast,  rule poly_res_class_memE[of _ n d g], blast)
+      using poly_res_class_memE[of _ n d ]A 
+       apply (metis (no_types, lifting) C_eq)
+      apply(rule poly_res_class_memI, rule poly_res_class_memE[of _ n d "SA_poly_to_Qp_poly m x f"], blast, 
+            rule poly_res_class_memE[of _ n d "SA_poly_to_Qp_poly m x f"], blast, 
+            rule poly_res_class_memE[of _ n d "SA_poly_to_Qp_poly m x f"], blast)
+      using poly_res_class_memE[of _ n d ]A 
+       by (metis (no_types, lifting) C_eq)
+    obtain i where i_def: "i \<in> {..d} \<and>  
+                            S = {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n}"
+      using A by blast
+    have S_eq: "S = {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n}"
+      using i_def by blast 
+    have 1: "\<And>i. SA_poly_to_Qp_poly m x f i = f i x"
+      apply(rule SA_poly_to_Qp_poly_coeff)
+      using A apply blast by(rule assms)
+    have 2: "deg Q\<^sub>p (SA_poly_to_Qp_poly m x f) \<le> d"
+      using assms SA_poly_to_Qp_poly_deg_bound[of f m x]
+      using A(1) by linarith
+    have 3: "Qp_res (SA_poly_to_Qp_poly m x f i) n = Qp_res (g i) n"
+      apply(rule poly_res_class_memE[of _ _ d], rule poly_res_class_memI)
+      using g_def val_ring_polys_grad_memE apply blast
+      using g_def val_ring_polys_grad_memE apply blast
+      using g_def val_ring_polys_grad_memE apply blast
+      apply(rule poly_res_class_memE[of _ _ d],rule poly_res_class_memI)
+         apply(rule SA_poly_to_Qp_poly_closed)
+      using A apply blast
+         apply(rule assms)
+      apply(rule 2)
+      unfolding 1 using assms A apply blast
+      using A unfolding C_eq 
+      using poly_res_class_memE(4)[of "SA_poly_to_Qp_poly m x f" n d g]
+      unfolding 1 by metis 
+    show "x \<in> S"
+      using A 3 assms
+      unfolding S_eq mem_Collect_eq unfolding 1 
+      by blast 
+  next
+    
+    show "\<And>x. x \<in> (\<Inter>i\<le>d. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n}) \<Longrightarrow> x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> SA_poly_to_Qp_poly m x f \<in> C"
+    proof- 
+      fix x assume A: "x \<in> (\<Inter>i\<le>d. {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n})"
+      have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+        using A by blast 
+      have 0: "\<And>i. SA_poly_to_Qp_poly m x f i = f i x"
+        apply(rule SA_poly_to_Qp_poly_coeff)
+        using A apply blast by(rule assms)
+      have 1: "deg Q\<^sub>p (SA_poly_to_Qp_poly m x f) \<le> d"
+        using assms SA_poly_to_Qp_poly_deg_bound[of f m x]
+        using x_closed by linarith
+      have 2: "\<And>i. Qp_res (f i x) n = Qp_res (g i) n"
+      proof- fix i 
+        have 20: "i > d \<Longrightarrow> i > deg Q\<^sub>p g"
+          using g_def val_ring_polys_grad_memE(2) by fastforce          
+        have 21: "i > d \<Longrightarrow> g i= \<zero>"
+          using 20 g_def val_ring_polys_grad_memE UPQ.deg_leE by blast
+        have 22: "i > d \<Longrightarrow> Qp_res (g i) n = 0"
+          unfolding 21 Qp_res_zero by blast 
+        have 23: "i > d \<Longrightarrow> SA_poly_to_Qp_poly m x f i = \<zero>"
+          apply(rule UPQ.deg_leE, rule SA_poly_to_Qp_poly_closed, rule x_closed, rule assms)
+          by(rule le_less_trans[of _ d], rule 1, blast) 
+        show " Qp_res (f i x) n = Qp_res (g i) n"
+          apply(cases "i \<le> d")
+          using A apply blast
+          using 22 21 1 23 unfolding 0 
+          by (metis less_or_eq_imp_le linorder_neqE_nat)
+      qed
+      have 3: "SA_poly_to_Qp_poly m x f \<in> C"
+        unfolding C_eq 
+        apply(rule poly_res_class_memI, rule SA_poly_to_Qp_poly_closed, rule x_closed, rule assms, rule 1)
+        unfolding 0 
+        by(rule assms, rule x_closed, rule 2)
+      show " x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<and> SA_poly_to_Qp_poly m x f \<in> C"
+        using x_closed 3 by blast 
+    qed
+  qed
+  have 1: "\<And>i. is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f i x \<in> \<O>\<^sub>p \<and> Qp_res (f i x) n = Qp_res (g i) n}"
+    apply(rule SA_constant_res_set_semialg, rule Qp_res_closed, rule val_ring_polys_grad_memE[of _ d])
+    using g_def apply blast
+    using assms UPSA.UP_car_memE(1) by blast
+  show "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). SA_poly_to_Qp_poly m x f \<in> C}"
+    unfolding 0 
+    apply(rule finite_intersection_is_semialg, blast, blast, rule subsetI)
+    using 1 unfolding is_semialgebraic_def by blast
+qed
+
+text\<open>Maps a polynomial $F(t) \in UP (SA n)$ to a function sending $(t, a) \in (Q_p (n + 1) \mapsto F(a)(t) \in Q_p$ \<close>
+
+definition SA_poly_to_SA_fun where
+  "SA_poly_to_SA_fun n P = (\<lambda> a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>). UP_cring.to_fun Q\<^sub>p (SA_poly_to_Qp_poly n (tl a) P) (hd a))"
+
+lemma SA_poly_to_SA_fun_is_fun:
+  assumes "P \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_SA_fun n P \<in> (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<rightarrow> carrier Q\<^sub>p)"
+proof fix x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+  obtain t where t_def: "t = hd x" by blast 
+  obtain a where a_def: "a = tl x" by blast 
+  have t_closed: "t \<in> carrier Q\<^sub>p"
+    using A t_def cartesian_power_head 
+    by blast
+  have a_closed: "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+    using A a_def cartesian_power_tail 
+    by blast
+  have 0: "SA_poly_to_SA_fun n P x = UP_cring.to_fun Q\<^sub>p (SA_poly_to_Qp_poly n a P) t"
+    unfolding SA_poly_to_SA_fun_def using t_def a_def 
+    by (meson A restrict_apply')
+  show "SA_poly_to_SA_fun n P x \<in> carrier Q\<^sub>p"
+    using assms t_closed a_def 0 UP_cring.to_fun_closed[of Q\<^sub>p "SA_poly_to_Qp_poly n a P" ] 
+    unfolding SA_poly_to_SA_fun_def 
+    using SA_poly_to_Qp_poly_closed a_closed UPQ.to_fun_closed by presburger
+qed
+
+lemma SA_poly_to_SA_fun_formula:
+  assumes "P \<in> carrier (UP (SA n))"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "t \<in> carrier Q\<^sub>p"
+  shows "SA_poly_to_SA_fun n P (t#x) = (SA_poly_to_Qp_poly n x P)\<bullet>t"
+proof-
+  have 0: "hd (t#x) = t"
+    by simp
+  have 1: "tl (t#x) = x"
+    by auto
+  have 2: "(t#x) \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    by (metis add.commute assms cartesian_power_cons plus_1_eq_Suc)
+  show ?thesis 
+    unfolding SA_poly_to_SA_fun_def 
+    using 0 1 2 assms 
+    by (metis (no_types, lifting) restrict_apply')
+qed
+
+lemma semialg_map_comp_in_SA:
+  assumes "f \<in> carrier (SA n)"
+  assumes "is_semialg_map m n g"
+  shows "(\<lambda> a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a)) \<in> carrier (SA m)"  
+proof(rule SA_car_memI)
+  show "(\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a)) \<in> carrier (Qp_funs m)"
+  proof(rule Qp_funs_car_memI)
+    show " (\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a)) \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<rightarrow> carrier Q\<^sub>p"      
+    proof fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+      then have "g a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+        using is_semialg_map_def[of m n g] assms
+        by blast 
+      then show  "f (g a) \<in> carrier Q\<^sub>p" 
+        using A assms  SA_car_memE(3)[of f n] 
+        by blast 
+    qed
+    show " \<And>x. x \<notin> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> (\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a)) x = undefined"
+      unfolding restrict_def by metis  
+  qed
+  have 0: "is_semialg_function m (f \<circ> g)"
+    using assms semialg_function_comp_closed[of n f m g] SA_car_memE(1)[of f n]
+    by blast 
+  have 1: " (\<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> (f \<circ> g) a = (\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a)) a)"
+    using assms  comp_apply[of f g] unfolding restrict_def
+    by metis 
+  then show "is_semialg_function m (\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a))"
+    using 0 1 semialg_function_on_carrier'[of m "f \<circ> g" "\<lambda> a \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). f (g a)" ] 
+    by blast 
+qed
+
+lemma tl_comp_in_SA:
+  assumes "f \<in> carrier (SA n)"
+  shows "(\<lambda> a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>). f (tl a)) \<in> carrier (SA (Suc n))"  
+  using assms semialg_map_comp_in_SA[of f _ _  tl] tl_is_semialg_map[of "n"]
+  by blast 
+
+lemma SA_poly_to_SA_fun_add_eval:
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+  shows "SA_poly_to_SA_fun n (f \<oplus>\<^bsub>UP (SA n)\<^esub> g) a = SA_poly_to_SA_fun n f a \<oplus>\<^bsub>Q\<^sub>p\<^esub> SA_poly_to_SA_fun n g a"
+  unfolding SA_poly_to_SA_fun_def 
+  using assms SA_poly_to_Qp_poly_add[of "tl a" n f g]
+  by (metis (no_types, lifting) SA_poly_to_Qp_poly_closed UPQ.to_fun_plus cartesian_power_head cartesian_power_tail restrict_apply')
+  
+lemma SA_poly_to_SA_fun_add:
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_SA_fun n (f \<oplus>\<^bsub>UP (SA n)\<^esub> g) = SA_poly_to_SA_fun n f \<oplus>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g"
+proof fix x
+  show " SA_poly_to_SA_fun n (f \<oplus>\<^bsub>UP (SA n)\<^esub> g) x = (SA_poly_to_SA_fun n f \<oplus>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g) x"
+  proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)")
+    case True
+    then show ?thesis using SA_poly_to_SA_fun_add_eval[of f n g x] SA_add[of x n]
+      using SA_mult assms(1) assms(2) SA_add 
+      by blast     
+  next
+    case False
+    have F0: "SA_poly_to_SA_fun n (f \<oplus>\<^bsub>UP (SA n)\<^esub> g) x = undefined"
+      unfolding SA_poly_to_SA_fun_def 
+      by (meson False restrict_apply)
+    have F1: "(SA_poly_to_SA_fun n f \<oplus>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g) x = undefined"
+      using  False SA_add' by blast
+    then show ?thesis 
+      using F0 by blast
+  qed
+qed
+
+lemma SA_poly_to_SA_fun_monom:
+  assumes "f \<in> carrier (SA n)"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+  shows "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) a = (f (tl a))\<otimes>(hd a)[^]\<^bsub>Q\<^sub>p\<^esub>k "
+proof-
+  have "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) a = SA_poly_to_Qp_poly n (tl a) (up_ring.monom (UP (SA n)) f k) \<bullet> lead_coeff a"
+    unfolding SA_poly_to_SA_fun_def using assms 
+    by (meson restrict_apply)
+  then have "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) a = up_ring.monom Q\<^sub>p_x (f (tl a)) k\<bullet> lead_coeff a"
+    using SA_poly_to_Qp_poly_monom[of "tl a" n f k] assms 
+    by (metis cartesian_power_tail)
+  then show ?thesis using assms 
+    by (metis (no_types, lifting) SA_car cartesian_power_head cartesian_power_tail UPQ.to_fun_monom Qp.function_ring_car_mem_closed semialg_functions_memE(2))
+qed
+
+lemma SA_poly_to_SA_fun_monom':
+  assumes "f \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "t \<in> carrier Q\<^sub>p"
+  shows "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) (t#x) = (f x)\<otimes>t[^]\<^bsub>Q\<^sub>p\<^esub>k "
+proof-
+  have 0: "hd (t#x) = t"
+    by simp
+  have 1: "tl (t#x) = x"
+    by auto
+  have 2: "(t#x) \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    by (metis add.commute assms  cartesian_power_cons plus_1_eq_Suc)
+  show ?thesis  
+    using 0 1 2 SA_poly_to_SA_fun_monom[of f n "t#x" k] assms SA_poly_to_SA_fun_monom 
+    by presburger
+qed
+
+lemma hd_is_semialg_function: 
+  assumes "n > 0"
+  shows "is_semialg_function n hd"
+proof-
+  have 0: "is_semialg_function n (\<lambda> a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). a!0)"
+    using assms index_is_semialg_function restrict_is_semialg by blast
+  have 1: "restrict (\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). a ! 0) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) = restrict lead_coeff (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+  proof fix x 
+    show "restrict (\<lambda>a\<in>carrier (Q\<^sub>p\<^bsup>n\<^esup>). a ! 0) (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x = restrict lead_coeff (carrier (Q\<^sub>p\<^bsup>n\<^esup>)) x"
+      unfolding restrict_def
+      apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)")
+       apply (metis assms cartesian_power_car_memE drop_0 hd_drop_conv_nth)
+      by presburger
+  qed
+  show ?thesis 
+    using 0 1 assms semialg_function_on_carrier[of n "(\<lambda> a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>). a!0)" hd]
+    by blast
+qed
+
+lemma SA_poly_to_SA_fun_monom_closed:
+  assumes "f \<in> carrier (SA n)"
+  shows "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) \<in> carrier (SA (Suc n))"
+proof-
+  have 0: "is_semialg_function (Suc n) (f \<circ> tl)"
+    using SA_imp_semialg assms(1)  semialg_function_comp_closed tl_is_semialg_map by blast
+  obtain h where h_def: "h = restrict hd (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>))"
+    by blast 
+  have h_closed: "h \<in> carrier (SA (Suc n))"
+    using hd_is_semialg_function SA_car h_def restrict_in_semialg_functions 
+    by blast
+  have h_pow_closed: "h[^]\<^bsub>SA (Suc n)\<^esub> k \<in> carrier (SA (Suc n))"
+    using assms(1) h_closed monoid.nat_pow_closed[of "SA (Suc n)" h k] SA_is_monoid[of "Suc n"] 
+    by blast 
+  have monom_term_closed: "(f \<circ> tl) \<otimes>\<^bsub>SA (Suc n)\<^esub> h[^]\<^bsub>SA (Suc n)\<^esub> k \<in> carrier (SA (Suc n))"
+    apply(rule SA_mult_closed_right)
+    using "0" apply linarith
+    using h_pow_closed by blast
+    
+  have 0: "\<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<Longrightarrow> SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) a = ((f \<circ> tl) \<otimes>\<^bsub>SA (Suc n)\<^esub> h[^]\<^bsub>SA (Suc n)\<^esub> k) a"
+  proof- fix a assume "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    then show "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) a = ((f \<circ> tl) \<otimes>\<^bsub>SA (Suc n)\<^esub> h[^]\<^bsub>SA (Suc n)\<^esub> k) a"
+      using assms SA_poly_to_SA_fun_monom[of f n a k] comp_apply[of f tl a] h_def restrict_apply 
+            SA_mult[of a "Suc n" "f \<circ> tl" "h [^]\<^bsub>SA (Suc n)\<^esub> k"] SA_nat_pow[of a "Suc n" h k]  
+      by metis
+  qed
+  have 1: "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) = ((f \<circ> tl) \<otimes>\<^bsub>SA (Suc n)\<^esub> h[^]\<^bsub>SA (Suc n)\<^esub> k)"
+  proof fix x 
+    show "SA_poly_to_SA_fun n (up_ring.monom (UP (SA n)) f k) x = ((f \<circ> tl) \<otimes>\<^bsub>SA (Suc n)\<^esub> h [^]\<^bsub>SA (Suc n)\<^esub> k) x"
+      apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)")
+      using "0" apply blast
+      using monom_term_closed unfolding SA_poly_to_SA_fun_def 
+      using restrict_apply 
+      by (metis (no_types, lifting) SA_mult')
+  qed
+  show ?thesis 
+    using 1 monom_term_closed 
+    by presburger
+qed
+
+lemma SA_poly_to_SA_fun_is_SA:
+  assumes "P \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_SA_fun n P \<in> carrier (SA (Suc n))"
+  apply(rule UP_ring.poly_induct3[of "SA n" P])
+  unfolding UP_ring_def using assms SA_is_ring apply blast 
+  using assms apply blast 
+  using assms SA_poly_to_SA_fun_add[of ]
+  using SA_add_closed_right SA_imp_semialg  zero_less_Suc apply presburger
+  using SA_poly_to_SA_fun_monom_closed assms(1) 
+  by blast
+
+lemma SA_poly_to_SA_fun_mult:
+  assumes "f \<in> carrier (UP (SA n))"
+  assumes "g \<in> carrier (UP (SA n))"
+  shows "SA_poly_to_SA_fun n (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) = SA_poly_to_SA_fun n f \<otimes>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g"
+proof(rule function_ring_car_eqI[of _ "Suc n"])
+  show "SA_poly_to_SA_fun n (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)) Q\<^sub>p)"
+  proof-
+    have "f \<otimes>\<^bsub>UP (SA n)\<^esub> g \<in> carrier (UP (SA n))"
+      using assms  SA_is_UP_cring 
+      by (meson cring.cring_simprules(5) padic_fields.UP_SA_n_is_cring padic_fields_axioms)
+    thus ?thesis 
+      using SA_is_UP_cring assms SA_poly_to_SA_fun_is_SA[of "f \<otimes>\<^bsub>UP (SA n)\<^esub> g"] SA_car_in_Qp_funs_car[of "Suc n"]  
+      by blast
+  qed
+  show "SA_poly_to_SA_fun n f \<otimes>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)) Q\<^sub>p)"
+    using SA_is_UP_cring SA_poly_to_SA_fun_is_SA assms 
+    by (meson SA_car_memE(2) SA_mult_closed_left less_Suc_eq_0_disj padic_fields.SA_car_memE(1) padic_fields_axioms)
+  show "\<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<Longrightarrow> SA_poly_to_SA_fun n (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) a = (SA_poly_to_SA_fun n f \<otimes>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g) a"
+  proof- fix a assume  A: "a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    then obtain t b where tb_def: "a = t#b"
+      using cartesian_power_car_memE[of a Q\<^sub>p "Suc n"] by (meson length_Suc_conv)
+    have t_closed: "t \<in> carrier Q\<^sub>p"
+      using tb_def A cartesian_power_head[of a Q\<^sub>p n] by (metis list.sel(1))
+    have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+      using tb_def A cartesian_power_tail[of a Q\<^sub>p n] by (metis list.sel(3))
+    have 0: "f \<otimes>\<^bsub>UP (SA n)\<^esub> g \<in> carrier (UP (SA n))"
+      using assms by (meson UP_SA_n_is_cring cring.cring_simprules(5))
+    have 1: "SA_poly_to_SA_fun n (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) a  = (SA_poly_to_Qp_poly n b (f \<otimes>\<^bsub>UP (SA n)\<^esub> g))\<bullet>t"
+      using SA_poly_to_SA_fun_formula[of "f \<otimes>\<^bsub>UP (SA n)\<^esub> g" n b t] t_closed b_closed tb_def  0  assms(1) 
+      by blast
+    have 2: "(SA_poly_to_SA_fun n f \<otimes>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g) a = 
+            SA_poly_to_SA_fun n f a \<otimes> SA_poly_to_SA_fun n g a"
+      using SA_poly_to_SA_fun_is_fun assms A SA_mult by blast
+    hence 3: "(SA_poly_to_SA_fun n f \<otimes>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g) a = 
+            ((SA_poly_to_Qp_poly n b f) \<bullet> t) \<otimes> ((SA_poly_to_Qp_poly n b g) \<bullet> t)"
+      using SA_poly_to_SA_fun_formula assms 
+      by (metis b_closed t_closed tb_def)
+    have 4: "SA_poly_to_SA_fun n (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) a  = ((SA_poly_to_Qp_poly n b f) \<bullet> t) \<otimes> ((SA_poly_to_Qp_poly n b g) \<bullet> t)"
+      using 1 assms SA_poly_to_Qp_poly_closed[of b] SA_poly_to_Qp_poly_mult UPQ.to_fun_mult b_closed t_closed 
+      by presburger
+    show " SA_poly_to_SA_fun n (f \<otimes>\<^bsub>UP (SA n)\<^esub> g) a = (SA_poly_to_SA_fun n f \<otimes>\<^bsub>SA (Suc n)\<^esub> SA_poly_to_SA_fun n g) a"
+      using "3" "4" by blast
+  qed
+qed
+
+lemma SA_poly_to_SA_fun_one:
+  shows "SA_poly_to_SA_fun n (\<one>\<^bsub>UP (SA n)\<^esub>) = \<one>\<^bsub>SA (Suc n)\<^esub>"
+proof(rule function_ring_car_eqI[of _ "Suc n"])
+  have "\<one>\<^bsub>UP (SA n)\<^esub> \<in> carrier (UP (SA n))"
+    using UP_SA_n_is_cring cring.cring_simprules(6) by blast
+  thus " SA_poly_to_SA_fun n \<one>\<^bsub>UP (SA n)\<^esub> \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)) Q\<^sub>p)"
+    using SA_poly_to_SA_fun_is_SA[of "\<one>\<^bsub>UP (SA n)\<^esub>"] SA_car_in_Qp_funs_car[of "Suc n"]  SA_is_UP_cring[of n]            
+    by blast
+  show "\<one>\<^bsub>SA (Suc n)\<^esub> \<in> carrier (function_ring (carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)) Q\<^sub>p)"
+    unfolding SA_one 
+    using function_one_closed by blast
+  show "\<And>a. a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>) \<Longrightarrow> SA_poly_to_SA_fun n \<one>\<^bsub>UP (SA n)\<^esub> a = \<one>\<^bsub>SA (Suc n)\<^esub> a"
+  proof- fix a assume A: "  a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    then obtain t b where tb_def: "a = t#b"
+      using cartesian_power_car_memE[of a Q\<^sub>p "Suc n"] by (meson length_Suc_conv)
+    have t_closed: "t \<in> carrier Q\<^sub>p"
+      using tb_def A cartesian_power_head[of a Q\<^sub>p n] by (metis list.sel(1))
+    have b_closed: "b \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+      using tb_def A cartesian_power_tail[of a Q\<^sub>p n] by (metis list.sel(3))
+    have 0: "SA_poly_to_SA_fun n \<one>\<^bsub>UP (SA n)\<^esub> a  = (SA_poly_to_Qp_poly n b \<one>\<^bsub>UP (SA n)\<^esub>)\<bullet>t"
+      using SA_poly_to_SA_fun_formula \<open>\<one>\<^bsub>UP (SA n)\<^esub> \<in> carrier (UP (SA n))\<close>  b_closed t_closed tb_def 
+      by blast
+    have 1: "SA_poly_to_Qp_poly n b \<one>\<^bsub>UP (SA n)\<^esub> = \<one>\<^bsub>UP Q\<^sub>p\<^esub>"
+      using  SA_poly_to_Qp_poly_is_hom[of b] ring_hom_one[of _ "UP (SA n)" "UP Q\<^sub>p"] b_closed 
+      by blast
+    thus "SA_poly_to_SA_fun n \<one>\<^bsub>UP (SA n)\<^esub> a = \<one>\<^bsub>SA (Suc n)\<^esub> a"
+      using "0" A function_one_eval SA_one UPQ.to_fun_one t_closed by presburger
+  qed
+qed
+
+lemma SA_poly_to_SA_fun_ring_hom:
+  shows "SA_poly_to_SA_fun n \<in> ring_hom (UP (SA n)) (SA (Suc n))"
+  apply(rule ring_hom_memI)
+  using SA_poly_to_SA_fun_is_SA  apply blast 
+  apply (meson SA_poly_to_SA_fun_mult)
+  apply (meson SA_poly_to_SA_fun_add)
+  by (meson SA_poly_to_SA_fun_one)
+
+lemma SA_poly_to_SA_fun_taylor_term:
+  assumes "F \<in> carrier (UP (SA n))"
+  assumes "c \<in> carrier (SA n)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "t \<in> carrier Q\<^sub>p"
+  assumes "f = SA_poly_to_Qp_poly n x F"
+  shows "SA_poly_to_SA_fun n (UP_cring.taylor_term (SA n) c F k) (t#x) = (taylor_expansion Q\<^sub>p (c x) f k) \<otimes>(t \<ominus> c x)[^]\<^bsub>Q\<^sub>p\<^esub> k"
+proof-
+  have 0: "hd (t#x) = t"
+    by simp
+  have 1: "tl (t#x) = x"
+    by auto
+  have 2: "(t#x) \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    by (metis Suc_eq_plus1 assms cartesian_power_cons)
+  show ?thesis 
+    using assms 0 1 2 Pi_iff  SA_car_memE(3)
+          SA_poly_to_Qp_poly_closed SA_poly_to_Qp_poly_comm_taylor_term[of F n c x k] restrict_apply'
+    unfolding SA_poly_to_SA_fun_def 
+    by (metis (no_types, lifting) UPQ.taylor_def UPQ.to_fun_taylor_term)    
+qed
+    
+lemma SA_finsum_eval: 
+  assumes "finite I"
+  assumes "F \<in> I \<rightarrow> carrier (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "(\<Oplus>\<^bsub>SA m\<^esub>i\<in>I. F i) x = (\<Oplus>i\<in>I. F i x)"
+proof-
+  have "F \<in> I \<rightarrow> carrier (SA m) \<longrightarrow> (\<Oplus>\<^bsub>SA m\<^esub>i\<in>I. F i) x = (\<Oplus>i\<in>I. F i x)"
+    apply(rule finite.induct[of I])
+    apply (simp add: assms(1))
+    using  abelian_monoid.finsum_empty[of "SA m" F] assms unfolding Qp.finsum_empty 
+    using SA_is_abelian_monoid SA_zeroE apply presburger
+  proof fix A a assume IH: "finite A" " F \<in> A \<rightarrow> carrier (SA m) \<longrightarrow> finsum (SA m) F A x = (\<Oplus>i\<in>A. F i x)"
+                            "F \<in> insert a A \<rightarrow> carrier (SA m)"
+    then have 0: "F \<in> A \<rightarrow> carrier (SA m)"
+      by blast
+    then have 1: "finsum (SA m) F A x = (\<Oplus>i\<in>A. F i x)"
+      using IH by blast
+    show "finsum (SA m) F (insert a A) x = (\<Oplus>i\<in>insert a A. F i x)"
+    proof(cases "a \<in> A")
+      case True     
+      then show ?thesis using insert_absorb[of a A] IH 
+        by presburger
+    next
+      case False
+      have F0: "(\<lambda>i. F i x) \<in> A \<rightarrow> carrier Q\<^sub>p" proof fix i assume "i \<in> A" thus "F i x \<in> carrier Q\<^sub>p"
+        using 0 assms(3) SA_car_memE(3)[of "F i" m] by blast qed
+      have F1: "F a x \<in> carrier Q\<^sub>p"
+        using IH assms(3) SA_car_memE(3)[of "F a" m] by blast  
+      have F2: "finsum (SA m) F (insert a A) x = F a x \<oplus> finsum (SA m) F A x"
+      proof-
+        have " finsum (SA m) F (insert a A) = F a \<oplus>\<^bsub>SA m\<^esub> finsum (SA m) F A"
+          using False IH abelian_monoid.finsum_insert[of "SA m" A a F ] 0 
+          by (meson Pi_split_insert_domain SA_is_abelian_monoid)
+        thus ?thesis using    abelian_monoid.finsum_closed[of "SA m" F A] 1 F0  F1
+            SA_add[of x m "F a" "finsum (SA m) F A"] 
+          using assms(3) by presburger
+      qed
+      show ?thesis using False 0 IH  Qp.finsum_insert[of A a "\<lambda>i. F i x"] unfolding F2 1 
+        using F0 F1 by blast     
+    qed
+  qed
+  thus ?thesis using assms by blast 
+qed
+
+lemma(in ring) finsum_ring_hom:
+  assumes "ring S"
+  assumes "h \<in> ring_hom R S"
+  assumes "F \<in> I \<rightarrow> carrier R"
+  assumes "finite I"
+  shows "h (\<Oplus>i\<in>I. F i) = (\<Oplus>\<^bsub>S\<^esub>i\<in>I. h (F i))"
+proof-
+  have "F \<in> I \<rightarrow> carrier R \<longrightarrow> h (\<Oplus>i\<in>I. F i) = (\<Oplus>\<^bsub>S\<^esub>i\<in>I. h (F i))"
+    apply(rule finite.induct[of I])
+      apply (simp add: assms(4))
+    unfolding finsum_empty using assms abelian_monoid.finsum_empty[of S]
+    unfolding ring_def abelian_group_def 
+    apply (simp add: \<open>\<And>f. abelian_monoid S \<Longrightarrow> finsum S f {} = \<zero>\<^bsub>S\<^esub>\<close> assms(1) local.ring_axioms ring_hom_zero)    
+  proof fix A a assume A: "finite A" "  F \<in> A \<rightarrow> carrier R \<longrightarrow> h (finsum R F A) = (\<Oplus>\<^bsub>S\<^esub>i\<in>A. h (F i))"
+       "   F \<in> insert a A \<rightarrow> carrier R"
+    then have 0: "F \<in> A \<rightarrow> carrier R "
+      by blast
+    have 1: "h (finsum R F A) = (\<Oplus>\<^bsub>S\<^esub>i\<in>A. h (F i))"
+      using "0" A(2) by linarith
+    have 2: "(finsum R F A) \<in> carrier R"
+      using finsum_closed[of F A] 0 by blast  
+    have 3: "(\<Oplus>\<^bsub>S\<^esub>i\<in>A. h (F i)) \<in> carrier S"
+    using assms 1 2 ring_hom_closed 
+    by metis
+    have 4: "F a \<in> carrier R" using A by blast 
+    have 5: "h (F a) \<in> carrier S"
+      using assms 4 
+      by (meson ring_hom_closed)
+    show "h (finsum R F (insert a A)) = (\<Oplus>\<^bsub>S\<^esub>i\<in>insert a A. h (F i))"
+      apply(cases "a \<in> A")
+      using insert_absorb 1 
+       apply metis
+    proof- assume C: "a \<notin>A"
+      have 6: "finsum R F (insert a A) = F a \<oplus> finsum R F A"
+      using A finsum_insert[of A a F]  C by blast
+    have 7: "(\<Oplus>\<^bsub>S\<^esub>i\<in>insert a A. h (F i)) = h (F a) \<oplus>\<^bsub>S\<^esub> (\<Oplus>\<^bsub>S\<^esub>i\<in>A. h (F i))"
+    apply(rule abelian_monoid.finsum_insert[of S A a "\<lambda>i. h (F i)"])
+          apply (simp add: abelian_group.axioms(1) assms(1) ring.is_abelian_group)
+         apply (simp add: A(1))
+        apply (simp add: C)
+       apply(intro Pi_I ring_hom_closed[of h R S] assms)
+      using 0 A 5 assms by auto       
+    thus ?thesis 
+    using    0 1 2 3 4 5 6  7 assms ring_hom_add[of h R S "F a" "finsum R F A" ] 
+
+      unfolding 1 ring_def abelian_group_def 
+      by presburger
+  qed
+  qed
+  thus ?thesis using assms by auto  
+qed
+
+lemma SA_poly_to_SA_fun_finsum:
+  assumes "finite I"
+  assumes "F \<in> I \<rightarrow> carrier (UP (SA m))"
+  assumes "f = (\<Oplus>\<^bsub>UP (SA m)\<^esub>i\<in>I. F i)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
+  shows "SA_poly_to_SA_fun m f x = (\<Oplus>i\<in>I. SA_poly_to_SA_fun m (F i) x)"
+proof- 
+  have "SA_poly_to_SA_fun m \<in> ring_hom (UP (SA m)) (SA (Suc m))"
+    using SA_poly_to_SA_fun_ring_hom by blast
+  have f_closed: "f \<in> carrier (UP (SA m))"
+    unfolding assms apply(rule finsum_closed)  using assms by blast 
+  have 0: "SA_poly_to_SA_fun m f = (\<Oplus>\<^bsub>SA (Suc m)\<^esub>i\<in>I. SA_poly_to_SA_fun m (F i))"
+    unfolding assms 
+    apply(rule finsum_ring_hom)
+       apply (simp add: R.is_ring)
+    using \<open>SA_poly_to_SA_fun m \<in> ring_hom (UP (SA m)) (SA (Suc m))\<close> apply blast
+    using assms(2) apply blast
+    by (simp add: assms(1))
+  show ?thesis unfolding 0 apply(rule SA_finsum_eval) 
+    using assms apply blast using assms 
+    apply (meson Pi_I Pi_mem padic_fields.SA_poly_to_SA_fun_is_SA padic_fields_axioms)
+    using assms by blast     
+qed
+
+lemma SA_poly_to_SA_fun_taylor_expansion:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "c \<in> carrier (SA m)"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
+  shows "SA_poly_to_SA_fun m f x = (\<Oplus>i\<in>{..deg (SA m) f}. taylor_expansion (SA m) c f i (tl x) \<otimes> (hd x \<ominus> c (tl x)) [^] i)"
+proof-
+  have 0: "f = (\<Oplus>\<^bsub>UP (SA m)\<^esub>i\<in>{..deg (SA m) f}. UP_cring.taylor_term (SA m) c f i)"
+    using taylor_sum[of f m "deg (SA m) f" c] assms unfolding UPSA.taylor_term_def UPSA.taylor_def  
+    by blast  
+  have 1: "SA_poly_to_SA_fun m f x = (\<Oplus>i\<in>{..deg (SA m) f}. SA_poly_to_SA_fun m (UP_cring.taylor_term (SA m) c f i) x)"
+    apply(rule SA_poly_to_SA_fun_finsum)
+       apply simp
+      apply (meson Pi_I UPSA.taylor_term_closed assms(1) assms(2))
+    using 0 apply blast 
+    using assms by blast
+  have hd_closed: "hd x \<in> carrier Q\<^sub>p"
+    using assms cartesian_power_head by blast
+  have tl_closed: "tl x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using assms cartesian_power_tail by blast
+  obtain t a where ta_def: " x = t#a"
+    using assms cartesian_power_car_memE[of x Q\<^sub>p "Suc m" ] 
+    by (metis Suc_length_conv)
+  have 2: "t = hd x"
+    by (simp add: ta_def)
+  have 3: "a = tl x "
+    by (simp add: ta_def)
+  have 4: "\<And>i. SA_poly_to_SA_fun m (UPSA.taylor_term m c f i) x =
+    taylor_expansion Q\<^sub>p (c (tl x)) (SA_poly_to_Qp_poly m (tl x) f) i \<otimes> (lead_coeff x \<ominus> c (tl x)) [^] i"
+    using tl_closed hd_closed assms SA_poly_to_SA_fun_taylor_term[of f m c a t  "SA_poly_to_Qp_poly m a f"  ] 
+    unfolding 2 3  by (metis "2" "3" ta_def) 
+  have 5: "SA_poly_to_SA_fun m f x = (\<Oplus>i\<in>{..deg (SA m) f}. (taylor_expansion Q\<^sub>p (c (tl x)) (SA_poly_to_Qp_poly m (tl x) f) i) \<otimes>((hd x) \<ominus> c (tl x))[^]\<^bsub>Q\<^sub>p\<^esub> i)"
+    using 1 2 unfolding 4 by blast
+  have 6: "taylor_expansion Q\<^sub>p (c (tl x)) (SA_poly_to_Qp_poly m (tl x) f) = SA_poly_to_Qp_poly m (tl x) (taylor_expansion (SA m) c f)"
+
+    using SA_poly_to_Qp_poly_taylor_poly[of f m c "tl x"] assms(1) assms(2) tl_closed by presburger
+  have 7: "\<And>i. taylor_expansion Q\<^sub>p (c (tl x)) (SA_poly_to_Qp_poly m (tl x) f) i =
+                taylor_expansion (SA m) c f i (tl x)"
+    unfolding 6 using SA_poly_to_Qp_poly_coeff[of "tl x" m "taylor_expansion (SA m) c f"] 
+    by (metis UPSA.taylor_closed UPSA.taylor_def assms(1) assms(2) tl_closed)
+  show ?thesis using 5 unfolding 7 by blast 
+qed
+
+lemma SA_deg_one_eval:
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "deg (SA m) g = 1"
+  assumes "\<xi> \<in> carrier (Fun\<^bsub>m\<^esub> Q\<^sub>p)"
+  assumes "UP_ring.lcf (SA m) g \<in> Units (SA m)"
+  assumes "\<forall>x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). (SA_poly_to_SA_fun m g) (\<xi> x#x) = \<zero>"
+  shows "\<xi> = \<ominus>\<^bsub>SA m\<^esub>(g 0)\<otimes>\<^bsub>SA m\<^esub> (inv\<^bsub>SA m\<^esub> (g 1))"
+proof(rule ext)
+  fix x show " \<xi> x = (\<ominus>\<^bsub>SA m\<^esub> g 0 \<otimes>\<^bsub>SA m\<^esub> inv\<^bsub>SA m\<^esub> g 1) x"
+  proof(cases "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)")
+    case True
+    then have "(SA_poly_to_SA_fun m g) (\<xi> x#x) = \<zero>"
+      using assms by blast 
+    then have T0: "SA_poly_to_Qp_poly m x g \<bullet> \<xi> x = \<zero>"
+      using SA_poly_to_SA_fun_formula[of g m x "\<xi> x"] assms 
+            Qp.function_ring_car_mem_closed True by metis
+    have "deg Q\<^sub>p (SA_poly_to_Qp_poly m x g) = 1"
+    proof(rule UPQ.deg_eqI)
+      show "SA_poly_to_Qp_poly m x g \<in> carrier (UP Q\<^sub>p)"
+        using assms True SA_poly_to_Qp_poly_closed by blast
+      show "deg Q\<^sub>p (SA_poly_to_Qp_poly m x g) \<le> 1"
+        using SA_poly_to_Qp_poly_deg_bound by (metis True assms(1) assms(2) )
+      show " SA_poly_to_Qp_poly m x g 1 \<noteq> \<zero>"
+        using SA_poly_to_Qp_poly_coeff[of x m g 1] assms SA_Units_memE' True by presburger
+    qed
+    hence T1: "SA_poly_to_Qp_poly m x g \<bullet> \<xi> x = SA_poly_to_Qp_poly m x g 0 \<oplus> SA_poly_to_Qp_poly m x g 1 \<otimes> (\<xi> x)"
+      using UP_cring.deg_one_eval[of Q\<^sub>p _ "\<xi> x"]
+      by (meson Qp.function_ring_car_mem_closed SA_poly_to_Qp_poly_closed True UPQ.deg_one_eval assms)
+    hence T2: "g 0 x \<oplus> g 1 x \<otimes> (\<xi> x) = \<zero>"
+      using True T0 assms SA_poly_to_Qp_poly_coeff[of x m g] 
+      by metis       
+    have T3: "g 0 x \<in> carrier Q\<^sub>p"
+      using True assms UP_ring.cfs_closed 
+      by (metis SA_poly_to_Qp_poly_closed SA_poly_to_Qp_poly_coeff UPQ.is_UP_ring)
+    have T4: "\<xi> x \<in> carrier Q\<^sub>p"
+      using True assms Qp.function_ring_car_memE by blast
+    have T5: "g 1 x \<in> nonzero Q\<^sub>p"
+      using True assms 
+      by (metis Qp.function_ring_car_memE SA_Units_closed SA_Units_memE' SA_car_memE(2) not_nonzero_Qp)
+    have T6: "\<ominus> (g 0 x) = g 1 x \<otimes> (\<xi> x)"
+      using T2 T3 T4 T5 by (metis Qp.m_closed Qp.minus_equality Qp.minus_minus Qp.nonzero_closed)
+    hence T7: "\<ominus> (g 0 x) \<otimes> inv (g 1 x)= \<xi> x"
+      using T5 by (metis Qp.inv_cancelR(2) Qp.m_closed Qp.nonzero_closed T4 Units_eq_nonzero)
+    have T8: "(inv\<^bsub>SA m\<^esub> g 1) x = inv (g 1 x)"
+      using assms True Qp_funs_m_inv SA_Units_Qp_funs_Units SA_Units_Qp_funs_inv by presburger
+    have T9: "(\<ominus>\<^bsub>SA m\<^esub> g 0) x = \<ominus> (g 0 x)" 
+      using SA_a_inv_eval[of "g 0" m x] UP_ring.cfs_closed[of "SA m" g 0] assms True SA_is_ring
+      unfolding UP_ring_def by blast 
+    have T11: "((\<ominus>\<^bsub>SA m\<^esub> g 0) \<otimes>\<^bsub>SA m\<^esub> inv\<^bsub>SA m\<^esub> g 1) x = \<ominus> (g 0 x) \<otimes> inv (g 1 x)"
+      using assms UP_ring.cfs_closed T8 T9 T7 True SA_mult by presburger
+    thus "\<xi> x = (\<ominus>\<^bsub>SA m\<^esub> g 0 \<otimes>\<^bsub>SA m\<^esub> inv\<^bsub>SA m\<^esub> g 1) x"
+      using T7 by blast
+  next
+    case False
+    then show ?thesis 
+      using SA_mult' SA_times assms function_ring_not_car by auto
+  qed
+qed
+
+lemma SA_deg_one_eval':
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "deg (SA m) g = 1"
+  assumes "\<xi> \<in> carrier (Fun\<^bsub>m\<^esub> Q\<^sub>p)"
+  assumes "UP_ring.lcf (SA m) g \<in> Units (SA m)"
+  assumes "\<forall>x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). (SA_poly_to_SA_fun m g) (\<xi> x#x) = \<zero>"
+  shows "\<xi> \<in> carrier (SA m)"
+proof-
+  have 0: "\<xi> = \<ominus>\<^bsub>SA m\<^esub>(g 0)\<otimes>\<^bsub>SA m\<^esub> (inv\<^bsub>SA m\<^esub> (g 1))"
+    using assms SA_deg_one_eval by blast
+  have 1: "(inv\<^bsub>SA m\<^esub> (g 1)) \<in> carrier (SA m)"
+    using assms SA_Units_inv_closed by presburger
+  have "(g 0) \<in> carrier (SA m)"
+    using assms(1) assms(2) UP_ring.cfs_closed[of "SA m" g 0] SA_is_ring[of m ] unfolding UP_ring_def 
+    by blast 
+  hence 2: "\<ominus>\<^bsub>SA m\<^esub>(g 0) \<in> carrier (SA m)"
+    by (meson SA_is_cring assms(1) cring.cring_simprules(3))
+  show ?thesis 
+    using 0 1 2  SA_imp_semialg SA_mult_closed_left assms(1) by blast
+qed
+
+lemma Qp_pow_ConsI:
+  assumes "t \<in> carrier Q\<^sub>p"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "t#x \<in> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
+  using assms cartesian_power_cons[of x Q\<^sub>p m t] Suc_eq_plus1 by presburger
+
+lemma Qp_pow_ConsE:
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
+  shows "tl x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+        "hd x \<in> carrier Q\<^sub>p"
+  using assms cartesian_power_tail apply blast
+  using assms cartesian_power_head by blast 
+
+lemma(in ring) add_monoid_one:
+"\<one>\<^bsub>add_monoid R\<^esub> = \<zero>"
+  by (metis add.generate_empty add.group_l_invI add.l_inv_ex empty_iff group.generate_empty insert_iff)
+
+lemma(in ring) add_monoid_carrier:
+"carrier (add_monoid R) = carrier R"
+  unfolding Congruence.partial_object.simps(1) 
+  by simp
+  
+lemma(in ring) finsum_mono_neutral_cong:
+  assumes "F \<in> I \<rightarrow> carrier R"
+  assumes "finite I"
+  assumes "\<And>i. i \<notin> J \<Longrightarrow> F i = \<zero>"
+  assumes "J \<subseteq> I"
+  shows "finsum R F I = finsum R F J"
+  unfolding finsum_def apply(rule comm_monoid.finprod_mono_neutral_cong)
+  using local.add.comm_monoid_axioms apply blast
+  using assms(2) assms(4) rev_finite_subset apply blast
+  apply (simp add: assms(2))
+  using assms(4) apply blast
+  unfolding add_monoid_one using assms apply blast
+  apply blast 
+  using add_monoid_carrier assms(1) apply blast
+  using add_monoid_carrier assms  by blast
+
+text\<open>
+  This lemma helps to formalize statements like "by passing to a partition, we can assume the
+  Taylor coefficients are either always zero or never zero"\<close>
+
+lemma SA_poly_to_SA_fun_taylor_on_refined_set:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "c \<in> carrier (SA m)"
+  assumes "is_semialgebraic m A"
+  assumes "\<And>i. A \<subseteq> SA_zero_set m (taylor_expansion (SA m) c f i) \<or> A \<subseteq> SA_nonzero_set m (taylor_expansion (SA m) c f i)"
+  assumes "a = to_fun_unit m \<circ> taylor_expansion (SA m) c f"
+  assumes "inds = {i. i \<le> deg (SA m) f \<and> A \<subseteq> SA_nonzero_set m (taylor_expansion (SA m) c f i)}"
+  assumes "x \<in> A"
+  assumes "t \<in> carrier Q\<^sub>p"
+  shows "SA_poly_to_SA_fun m f (t#x) = (\<Oplus>i\<in>inds. (a i x)\<otimes>(t \<ominus> c x)[^]i)"
+proof-
+  have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using assms(3) assms(7)  
+  by (metis (no_types, lifting) Diff_eq_empty_iff Diff_iff empty_iff is_semialgebraic_closed)
+  have tx_closed: "t#x \<in> carrier (Q\<^sub>p\<^bsup>Suc m\<^esup>)"
+    using x_closed assms(8) cartesian_power_cons[of x Q\<^sub>p m t] Qp_pow_ConsI by blast
+  have "SA_poly_to_SA_fun m f (t # x) =
+    (\<Oplus>i\<in>{..deg (SA m) f}. taylor_expansion (SA m) c f i (tl (t # x)) \<otimes> (hd (t # x) \<ominus> c (tl (t # x))) [^] i)"
+    using tx_closed assms SA_poly_to_SA_fun_taylor_expansion[of f m c "t#x"] 
+    by linarith
+  then have 0: "SA_poly_to_SA_fun m f (t#x) = (\<Oplus>i\<in>{..deg (SA m) f}. taylor_expansion (SA m) c f i x \<otimes> (t \<ominus> c x) [^] i)"
+    unfolding list_tl list_hd by blast 
+  have 1: "\<And>i. i \<notin> inds \<Longrightarrow> taylor_expansion (SA m) c f i x = \<zero>"
+  proof- fix i assume A: "i \<notin> inds" 
+    show "taylor_expansion (SA m) c f i x = \<zero>"
+    proof(cases "i \<le> deg (SA m) f")
+    case True
+    then have "A \<subseteq> {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). taylor_expansion (SA m) c f i x = \<zero>}"
+      using A assms(8) assms(4)[of i] unfolding assms mem_Collect_eq SA_zero_set_def 
+      by linarith
+    thus ?thesis using x_closed assms by blast 
+   next
+    case False
+    then have "taylor_expansion (SA m) c f i = \<zero>\<^bsub>SA m\<^esub>"
+      using assms taylor_deg[of c m f] unfolding UPSA.taylor_def  
+      by (metis (no_types, lifting) UPSA.taylor_closed UPSA.taylor_def UPSA.deg_eqI nat_le_linear)
+    then show ?thesis 
+      using x_closed SA_car_memE SA_zeroE by presburger
+    qed
+  qed
+  hence 2: "\<And>i. i \<notin> inds \<Longrightarrow> taylor_expansion (SA m) c f i x \<otimes> (t \<ominus> c x) [^] i = \<zero>"
+    using assms x_closed  SA_car_memE 
+    by (metis (no_types, lifting) Qp.cring_simprules(26) Qp.function_ring_car_memE Qp.minus_closed Qp.nat_pow_closed)
+  have 3: "(\<lambda>i. taylor_expansion (SA m) c f i x \<otimes> (t \<ominus> c x) [^] i) \<in> {..deg (SA m) f} \<rightarrow> carrier Q\<^sub>p"
+  proof fix i assume A: "i \<in> {..deg (SA m) f}"
+    have 30: "taylor_expansion (SA m) c f i \<in> carrier (SA m)"
+      using  assms UPSA.taylor_closed[of f m c] unfolding UPSA.taylor_def  
+      using UPSA.UP_car_memE(1) by blast
+    hence 31: "taylor_expansion (SA m) c f i x \<in> carrier Q\<^sub>p"
+      using x_closed function_ring_car_closed SA_car_memE(2) by blast
+    have 32: "c x \<in> carrier Q\<^sub>p"
+      using assms x_closed SA_car_memE(3) by blast 
+    hence 33: "(t \<ominus> c x)[^] i \<in> carrier Q\<^sub>p"
+      using assms by blast
+    show "taylor_expansion (SA m) c f i x \<otimes> (t \<ominus> c x) [^] i \<in> carrier Q\<^sub>p"
+      using 30 31 32 33 by blast
+  qed
+  have 4: "SA_poly_to_SA_fun m f (t#x) = (\<Oplus>i\<in>inds. taylor_expansion (SA m) c f i x \<otimes> (t \<ominus> c x) [^] i)"
+    unfolding 0 apply(rule Qp.finsum_mono_neutral_cong)
+    using assms UPSA.taylor_closed[of f m c] unfolding UPSA.taylor_def  
+    using "3" apply blast
+      apply blast 
+    using 2 apply blast 
+    unfolding assms by blast 
+  have A: "\<And>i. i \<in> inds \<Longrightarrow> a i x = taylor_expansion (SA m) c f i x"
+    unfolding assms mem_Collect_eq SA_nonzero_set_def comp_apply
+    apply(rule to_fun_unit_eq[of _ m x])
+    using UPSA.taylor_closed[of f m c] assms unfolding UPSA.taylor_def 
+    using UPSA.UP_car_memE(1) apply blast
+    using x_closed apply blast 
+    using assms(7) by blast 
+  have a_closed: "a \<in> UNIV \<rightarrow> carrier (SA m)"
+    apply(rule Pi_I) unfolding assms comp_apply apply(rule to_fun_unit_closed[of _ m])
+    apply(rule cfs_closed) using assms UPSA.taylor_closed[of f m c] unfolding UPSA.taylor_def by blast 
+  have 5: "(\<lambda>i. a i x \<otimes> (t \<ominus> c x) [^] i) \<in> inds \<rightarrow> carrier Q\<^sub>p"
+  proof fix i assume A: "i \<in> inds"
+    show "a i x \<otimes> (t \<ominus> c x) [^] i \<in> carrier Q\<^sub>p"
+    using assms(8) x_closed a_closed SA_car_memE(3)[of c m] SA_car_memE(3)[of "a i" m] 
+         assms(2) by blast
+  qed
+  have 6: "\<And>i. i \<in> inds \<Longrightarrow> taylor_expansion (SA m) c f i x \<otimes> (t \<ominus> c x) [^] i = a i x \<otimes> (t \<ominus> c x) [^] i"
+    unfolding A by blast 
+  show ?thesis 
+    unfolding 4 apply(rule Qp.finsum_cong') apply blast 
+    using 5 apply blast 
+    using 6 by blast 
+qed
+
+lemma SA_poly_to_Qp_poly_taylor_cfs: 
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  assumes "c \<in> carrier (SA m)"
+  shows "taylor_expansion (SA m) c f i x =
+    taylor_expansion Q\<^sub>p (c x) (SA_poly_to_Qp_poly m x f) i"
+proof-
+  have 0: "SA_poly_to_Qp_poly m x (taylor_expansion (SA m) c f) =
+         taylor_expansion Q\<^sub>p (c x) (SA_poly_to_Qp_poly m x f)"
+    using SA_poly_to_Qp_poly_taylor_poly[of f m c x] assms by blast 
+  hence 1: "SA_poly_to_Qp_poly m x (taylor_expansion (SA m) c f) i =
+  taylor_expansion Q\<^sub>p (c x) (SA_poly_to_Qp_poly m x f) i"
+    by presburger
+  thus ?thesis 
+    using assms SA_poly_to_Qp_poly_coeff[of x m "taylor_expansion (SA m) c f" i]  
+      UPSA.taylor_closed[of f m c] unfolding UPSA.taylor_def assms by blast 
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Common Morphisms on Polynomial Rings\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+text\<open>Evaluation homomorphism from multivariable polynomials to semialgebraic functions\<close>
+
+definition Qp_ev_hom where
+"Qp_ev_hom n P = restrict (Qp_ev P) (carrier (Q\<^sub>p\<^bsup>n\<^esup>))"
+
+lemma Qp_ev_hom_ev:
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  shows "Qp_ev_hom n P a = Qp_ev P a"
+  using assms unfolding Qp_ev_hom_def 
+  by (meson restrict_apply')
+
+lemma Qp_ev_hom_closed:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  shows "Qp_ev_hom n f \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>) \<rightarrow> carrier Q\<^sub>p"
+  using Qp_ev_hom_ev assms by (metis Pi_I eval_at_point_closed)
+
+lemma Qp_ev_hom_is_semialg_function:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  shows "is_semialg_function n (Qp_ev_hom n f)"
+  unfolding Qp_ev_hom_def  
+  using assms poly_is_semialg[of  f] restrict_is_semialg by blast
+
+lemma Qp_ev_hom_closed':
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  shows "Qp_ev_hom n f \<in> carrier (Fun\<^bsub>n\<^esub> Q\<^sub>p)"
+  apply(rule Qp.function_ring_car_memI)
+  using  Qp_ev_hom_closed[of f n] assms apply blast
+  unfolding Qp_ev_hom_def using assms by (meson restrict_apply)
+
+lemma Qp_ev_hom_in_SA:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  shows "Qp_ev_hom n f \<in> carrier (SA n)"
+  apply(rule SA_car_memI)
+  using Qp_ev_hom_closed' assms(1)  apply blast
+  using Qp_ev_hom_is_semialg_function assms(1) by blast 
+
+lemma Qp_ev_hom_add:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  shows "Qp_ev_hom n (f \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> g) = (Qp_ev_hom n f) \<oplus>\<^bsub>SA n\<^esub> (Qp_ev_hom n g)"
+  apply(rule function_ring_car_eqI[of _ n])
+  using assms MP.add.m_closed Qp_ev_hom_closed' apply blast
+  using assms Qp_ev_hom_closed' fun_add_closed SA_plus apply presburger
+proof- fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  have " Qp_ev_hom n (f \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>n\<^esub>]\<^esub> g) a =  Qp_ev_hom n f a \<oplus> Qp_ev_hom n g a"
+    using A Qp_ev_hom_ev assms eval_at_point_add by presburger
+  then show "Qp_ev_hom n (f \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>n\<^esub>]\<^esub> g) a = (Qp_ev_hom n f \<oplus>\<^bsub>SA n\<^esub> Qp_ev_hom n g) a"
+    using A SA_add by blast
+qed
+        
+lemma Qp_ev_hom_mult:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])"
+  shows "Qp_ev_hom n (f \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> g) = (Qp_ev_hom n f) \<otimes>\<^bsub>SA n\<^esub> (Qp_ev_hom n g)"
+  apply(rule function_ring_car_eqI[of _ n])
+  using assms MP.m_closed Qp_ev_hom_closed' apply blast 
+  using assms Qp_ev_hom_closed' fun_mult_closed SA_mult 
+  apply (meson Qp_ev_hom_in_SA SA_car_memE(2) SA_imp_semialg SA_mult_closed)  
+proof- fix a assume A: "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  have " Qp_ev_hom n (f \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>n\<^esub>]\<^esub> g) a =  Qp_ev_hom n f a \<otimes> Qp_ev_hom n g a"
+    using A Qp_ev_hom_ev assms eval_at_point_mult by presburger
+  then show "Qp_ev_hom n (f \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>n\<^esub>]\<^esub> g) a = (Qp_ev_hom n f \<otimes>\<^bsub>SA n\<^esub> Qp_ev_hom n g) a"
+    using A SA_mult by blast
+qed
+
+lemma Qp_ev_hom_one:
+  shows "Qp_ev_hom n \<one>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> = \<one>\<^bsub>SA n\<^esub>"
+  apply(rule function_ring_car_eqI[of _ n])
+  using Qp_ev_hom_closed' apply blast
+  using  function_one_closed SA_one apply presburger 
+  unfolding Qp_ev_hom_def 
+  using function_one_eval Qp_ev_hom_def Qp_ev_hom_ev Qp_ev_one SA_one by presburger
+
+lemma Qp_ev_hom_is_hom:
+  shows "Qp_ev_hom n \<in> ring_hom (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (SA n)"
+  apply(rule ring_hom_memI)
+  using   Qp_ev_hom_in_SA apply blast
+    using  Qp_ev_hom_mult apply blast
+      using  Qp_ev_hom_add apply blast  
+        using  Qp_ev_hom_one by blast 
+
+lemma Qp_ev_hom_constant:
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "Qp_ev_hom n (Qp.indexed_const c) = \<cc>\<^bsub>n\<^esub> c"
+  apply(rule function_ring_car_eqI[of _ n])
+  using Qp_ev_hom_closed' Qp_to_IP_car assms(1)  apply blast
+  using constant_function_closed assms  apply blast
+  by (metis Qp_constE Qp_ev_hom_ev assms eval_at_point_const)
+
+notation  Qp.variable ("\<vv>\<^bsub>_, _\<^esub>")
+
+lemma Qp_ev_hom_pvar:
+  assumes "i < n"
+  shows "Qp_ev_hom n (pvar Q\<^sub>p i) = \<vv>\<^bsub>n, i\<^esub>"
+  apply(rule function_ring_car_eqI[of _ n]) 
+  using assms Qp_ev_hom_closed' local.pvar_closed apply blast
+  using Qp.var_in_car assms apply blast
+  unfolding Qp_ev_hom_def var_def using assms eval_pvar 
+  by (metis (no_types, lifting) restrict_apply)
+
+definition ext_hd where 
+"ext_hd m = (\<lambda> x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). hd x)"
+
+lemma hd_zeroth:
+"length x > 0 \<Longrightarrow> x!0 = hd x"
+  apply(induction x)
+  apply simp
+  by simp
+
+lemma ext_hd_pvar:
+  assumes "m > 0"
+  shows "ext_hd m = (\<lambda>x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). eval_at_point Q\<^sub>p x (pvar Q\<^sub>p 0) )"
+  unfolding ext_hd_def restrict_def using assms eval_pvar[of 0 m]
+  using hd_zeroth 
+  by (metis (no_types, opaque_lifting) cartesian_power_car_memE)
+
+lemma ext_hd_closed: 
+  assumes "m > 0"
+  shows "ext_hd m \<in> carrier (SA m)"
+  using ext_hd_pvar[of m] assms pvar_closed[of 0 m] Qp_ev_hom_def Qp_ev_hom_in_SA by presburger 
+  
+lemma UP_Qp_poly_to_UP_SA_is_hom:
+  shows "poly_lift_hom (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (SA n) (Qp_ev_hom n) \<in> ring_hom (UP (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])) (UP (SA n))"
+  using UP_cring.poly_lift_hom_is_hom[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "SA n" "Qp_ev_hom n"]
+  unfolding UP_cring_def 
+  using Qp_ev_hom_is_hom SA_is_cring  coord_cring_cring by blast
+
+definition coord_ring_to_UP_SA where
+"coord_ring_to_UP_SA n = poly_lift_hom (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (SA n) (Qp_ev_hom n) \<circ> to_univ_poly (Suc n) 0"
+
+lemma coord_ring_to_UP_SA_is_hom:
+  shows "coord_ring_to_UP_SA n \<in> ring_hom (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>]) (UP (SA n))"
+  unfolding coord_ring_to_UP_SA_def 
+  using UP_Qp_poly_to_UP_SA_is_hom[of n] to_univ_poly_is_hom[of 0 "n"] ring_hom_trans 
+  by blast
+
+lemma coord_ring_to_UP_SA_add:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "coord_ring_to_UP_SA n (f \<oplus>\<^bsub>Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>]\<^esub>g) = coord_ring_to_UP_SA n f  \<oplus>\<^bsub>UP (SA n)\<^esub> coord_ring_to_UP_SA n g"
+  using assms coord_ring_to_UP_SA_is_hom ring_hom_add 
+  by (metis (mono_tags, opaque_lifting))
+
+lemma coord_ring_to_UP_SA_mult:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "g \<in> carrier (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "coord_ring_to_UP_SA n (f \<otimes>\<^bsub>Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>]\<^esub>g) = coord_ring_to_UP_SA n f  \<otimes>\<^bsub>UP (SA n)\<^esub> coord_ring_to_UP_SA n g"
+  using assms coord_ring_to_UP_SA_is_hom ring_hom_mult 
+  by (metis (no_types, opaque_lifting))
+
+lemma coord_ring_to_UP_SA_one:
+  shows "coord_ring_to_UP_SA n \<one>\<^bsub>Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>]\<^esub> = \<one>\<^bsub>UP (SA n)\<^esub>"
+  using coord_ring_to_UP_SA_is_hom ring_hom_one 
+  by blast
+
+lemma coord_ring_to_UP_SA_closed:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "coord_ring_to_UP_SA n f \<in> carrier (UP (SA n))"
+  using assms coord_ring_to_UP_SA_is_hom ring_hom_closed 
+  by (metis (no_types, opaque_lifting))
+
+lemma coord_ring_to_UP_SA_constant:
+  assumes "c \<in> carrier Q\<^sub>p"
+  shows "coord_ring_to_UP_SA n (Qp.indexed_const c) = to_polynomial (SA n) (\<cc>\<^bsub>n\<^esub> c)"
+proof-
+  have 0: "pre_to_univ_poly (Suc n) 0 (Qp.indexed_const c) = ring.indexed_const (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (Qp.indexed_const c)"
+    unfolding to_univ_poly_def 
+    using pre_to_univ_poly_is_hom(5)[of 0 "Suc n" "pre_to_univ_poly (Suc n) 0" c] assms unfolding coord_ring_def 
+    using diff_Suc_1 zero_less_Suc by presburger
+  hence 1: "to_univ_poly (Suc n) 0 (Qp.indexed_const c) = to_polynomial (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (Qp.indexed_const c) "
+    unfolding to_univ_poly_def 
+    using UP_cring.IP_to_UP_indexed_const[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "Qp.indexed_const c" "0::nat"] assms 
+          comp_apply[of "IP_to_UP (0::nat)" "pre_to_univ_poly (Suc n) (0::nat)" "Qp.indexed_const c"]
+    unfolding UP_cring_def using Qp_to_IP_car coord_cring_cring by presburger
+  have 2: "Qp_ev_hom n (Qp.indexed_const c) = \<cc>\<^bsub>n\<^esub> c"
+    using Qp_ev_hom_constant[of c n] assms by blast 
+  have 3: "poly_lift_hom (Q\<^sub>p [\<X>\<^bsub>n\<^esub>]) (SA n) (Qp_ev_hom n) (to_polynomial (Q\<^sub>p [\<X>\<^bsub>n\<^esub>]) (Qp.indexed_const c)) = to_polynomial (SA n) (Qp_ev_hom n (Qp.indexed_const c))"
+    using UP_cring.poly_lift_hom_extends_hom[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "SA n" "Qp_ev_hom n" "Qp.indexed_const c"]
+    unfolding UP_cring_def coord_ring_def coord_ring_to_UP_SA_def
+    by (metis Qp_ev_hom_is_hom Qp_to_IP_car SA_is_cring assms(1) coord_cring_cring coord_ring_def)
+  hence 4: "poly_lift_hom (Q\<^sub>p [\<X>\<^bsub>n\<^esub>]) (SA n) (Qp_ev_hom n) (to_univ_poly (Suc n) 0 (Qp.indexed_const c) ) = to_polynomial (SA n) (\<cc>\<^bsub>n\<^esub> c)"
+    using "1" "2" by presburger
+  show ?thesis 
+    using assms 4 Qp.indexed_const_closed[of c "{..<n}"] 
+          comp_apply[of "poly_lift_hom (Pring Q\<^sub>p {..<n}) (SA n) (Qp_ev_hom n)" "to_univ_poly (Suc n) 0" "Qp.indexed_const c"] 
+    unfolding coord_ring_to_UP_SA_def
+    by (metis coord_ring_def)
+qed
+
+lemma coord_ring_to_UP_SA_pvar_0:
+  shows "coord_ring_to_UP_SA n (pvar Q\<^sub>p 0) = up_ring.monom (UP (SA n)) \<one>\<^bsub>SA n\<^esub> 1"
+proof-
+  have 0: "pre_to_univ_poly (Suc n) 0 (pvar Q\<^sub>p 0) = pvar (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) 0"
+    using pre_to_univ_poly_is_hom(3)[of 0 "Suc n" "pre_to_univ_poly (Suc n) 0"] diff_Suc_1 zero_less_Suc 
+    by presburger
+  have 1: "IP_to_UP (0::nat) (pvar (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) 0) = up_ring.monom (UP (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> 1"
+    using cring.IP_to_UP_var[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "0::nat"] unfolding X_poly_def var_to_IP_def
+    using coord_cring_cring by blast
+  have 2: "to_univ_poly (Suc n) 0 (pvar Q\<^sub>p 0) = up_ring.monom (UP (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> 1"
+    unfolding to_univ_poly_def using 0 1 comp_apply 
+    by metis
+  have 3: "poly_lift_hom (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (SA n) (Qp_ev_hom n) (up_ring.monom (UP (Q\<^sub>p[\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>Q\<^sub>p[\<X>\<^bsub>n\<^esub>]\<^esub> 1) 
+             = up_ring.monom (UP (SA n)) \<one>\<^bsub>SA n\<^esub> 1"
+    using UP_cring.poly_lift_hom_monom[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "SA n" "Qp_ev_hom n"]
+    unfolding UP_cring_def
+    using MP.one_closed Qp_ev_hom_is_hom Qp_ev_hom_one SA_is_cring coord_cring_cring by presburger
+  thus ?thesis unfolding coord_ring_to_UP_SA_def  
+    using 2 3  comp_apply 
+    by metis
+qed
+
+lemma coord_ring_to_UP_SA_pvar_Suc:
+  assumes "i > 0"
+  assumes "i < Suc n"
+  shows "coord_ring_to_UP_SA n (pvar Q\<^sub>p i) = to_polynomial (SA n) (\<vv>\<^bsub>n, i-1\<^esub>)"
+proof-
+  have 0: "pre_to_univ_poly (Suc n) 0 (pvar Q\<^sub>p i) = ring.indexed_const (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (pvar Q\<^sub>p (i-1))"
+    using pre_to_univ_poly_is_hom(4)[of 0 "Suc n" "pre_to_univ_poly (Suc n) 0" i] diff_Suc_1 zero_less_Suc 
+          assms
+    unfolding coord_ring_def by presburger 
+  have 1: "IP_to_UP (0::nat) (ring.indexed_const (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (pvar Q\<^sub>p (i-1))) = to_polynomial (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (pvar Q\<^sub>p (i-1))"
+    using UP_cring.IP_to_UP_indexed_const[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "pvar Q\<^sub>p (i-1)" "0::nat"] coord_cring_cring
+    unfolding UP_cring_def  
+    by (metis assms diff_less less_Suc_eq less_imp_diff_less less_numeral_extra(1) local.pvar_closed)    
+  have 2: "to_univ_poly (Suc n) 0 (pvar Q\<^sub>p i) = to_polynomial (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (pvar Q\<^sub>p (i-1))"
+    unfolding to_univ_poly_def using 0 1 comp_apply 
+    by metis
+  have 3: "poly_lift_hom (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (SA n) (Qp_ev_hom n) (to_polynomial (Q\<^sub>p[\<X>\<^bsub>n\<^esub>]) (pvar Q\<^sub>p (i-1))) 
+             = to_polynomial (SA n) (\<vv>\<^bsub>n, (i-1)\<^esub>)"
+    using UP_cring.poly_lift_hom_extends_hom[of "Q\<^sub>p[\<X>\<^bsub>n\<^esub>]" "SA n" "Qp_ev_hom n" "pvar Q\<^sub>p (i-1)"]
+    unfolding UP_cring_def 
+    by (metis (no_types, lifting) Qp_ev_hom_is_hom Qp_ev_hom_pvar SA_is_cring Suc_diff_1 
+        Suc_less_eq assms  coord_cring_cring local.pvar_closed) 
+  thus ?thesis unfolding coord_ring_to_UP_SA_def  
+    using 2 3 assms comp_apply 
+    by metis
+qed
+ 
+lemma coord_ring_to_UP_SA_eval:
+  assumes "f \<in> carrier (Q\<^sub>p[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "a \<in> carrier (Q\<^sub>p\<^bsup>n\<^esup>)"
+  assumes "t \<in> carrier Q\<^sub>p"
+  shows "Qp_ev f (t#a) = ((SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n f))) \<bullet> t"
+proof(rule coord_ring_car_induct[of f "Suc n"])
+  have ta_closed: "t # a \<in> carrier (Q\<^sub>p\<^bsup>Suc n\<^esup>)"
+    using assms cartesian_power_cons  by (metis Suc_eq_plus1)
+  show "f \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>])"
+    by (simp add: assms)
+  show "\<And>c. c \<in> carrier Q\<^sub>p \<Longrightarrow> eval_at_point Q\<^sub>p (t # a) (Qp.indexed_const c) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (Qp.indexed_const c)) \<bullet> t"
+  proof- fix c assume A: "c \<in> carrier Q\<^sub>p"
+    have 0: "eval_at_point Q\<^sub>p (t # a) (Qp.indexed_const c) = c"
+      using A eval_at_point_const ta_closed by blast
+    have 1: "SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (Qp.indexed_const c)) = to_polynomial Q\<^sub>p c"
+      using coord_ring_to_UP_SA_constant[of c n]  A Qp_constE SA_car 
+            SA_poly_to_Qp_poly_extends_apply assms  constant_function_in_semialg_functions 
+      by presburger
+    show "eval_at_point Q\<^sub>p (t # a) (Qp.indexed_const c) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (Qp.indexed_const c)) \<bullet> t"
+      using 0 1 A UPQ.to_fun_to_poly assms by presburger
+  qed 
+  show " \<And>p q. p \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]) \<Longrightarrow>
+           q \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]) \<Longrightarrow>
+           eval_at_point Q\<^sub>p (t # a) p = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<bullet> t \<Longrightarrow>
+           eval_at_point Q\<^sub>p (t # a) q = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n q) \<bullet> t \<Longrightarrow>
+           eval_at_point Q\<^sub>p (t # a) (p \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> q) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> q)) \<bullet> t"
+  proof- fix p q assume A: "p \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>])" "q \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>])"
+           "eval_at_point Q\<^sub>p (t # a) p = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<bullet> t"
+           "eval_at_point Q\<^sub>p (t # a) q = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n q) \<bullet> t"
+    have 0: "eval_at_point Q\<^sub>p (t # a) (p \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> q) = eval_at_point Q\<^sub>p (t # a) p \<oplus> eval_at_point Q\<^sub>p (t # a) q"
+      using A(1) A(2) eval_at_point_add ta_closed by blast
+    have 1: "SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> q))= 
+    SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p)  \<oplus>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n q)"
+      using coord_ring_to_UP_SA_add[of ] assms coord_ring_to_UP_SA_closed A
+            SA_poly_to_Qp_poly_add[of  a n "coord_ring_to_UP_SA n p" "coord_ring_to_UP_SA n q"] 
+      by presburger
+    show "eval_at_point Q\<^sub>p (t # a) (p \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> q) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<oplus>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> q)) \<bullet> t"
+      using 0 1  assms SA_poly_to_Qp_poly_closed[of a n] SA_poly_to_Qp_poly_closed A(1) A(2) A(3) A(4) UPQ.to_fun_plus coord_ring_to_UP_SA_closed 
+      by presburger
+  qed
+  show "\<And>p i. p \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]) \<Longrightarrow>
+           i < Suc n \<Longrightarrow>
+           eval_at_point Q\<^sub>p (t # a) p = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<bullet> t \<Longrightarrow>
+           eval_at_point Q\<^sub>p (t # a) (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i)) \<bullet> t"
+  proof- fix p i assume A: "p \<in> carrier (Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>])" "i < Suc n"
+           "eval_at_point Q\<^sub>p (t # a) p = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<bullet> t"
+    show " eval_at_point Q\<^sub>p (t # a) (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i)) \<bullet> t"
+    proof-
+      have 0: "eval_at_point Q\<^sub>p (t # a) (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = eval_at_point Q\<^sub>p (t # a) p \<otimes>  eval_at_point Q\<^sub>p (t # a) (pvar Q\<^sub>p i)"
+        using A(1) A(2) eval_at_point_mult local.pvar_closed ta_closed by blast
+      have 1: "coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = coord_ring_to_UP_SA n p \<otimes>\<^bsub>UP (SA n)\<^esub> coord_ring_to_UP_SA n (pvar Q\<^sub>p i)"
+        using A(1) A(2) assms(1) coord_ring_to_UP_SA_mult local.pvar_closed by blast
+      hence 2: "SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i)) =
+              SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<otimes>\<^bsub>UP Q\<^sub>p\<^esub>SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (pvar Q\<^sub>p i))"
+        using SA_poly_to_Qp_poly_mult coord_ring_to_UP_SA_closed A(1) A(2) assms local.pvar_closed 
+        by presburger
+      show "eval_at_point Q\<^sub>p (t # a) (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i)) \<bullet> t"
+      proof(cases  "i = 0")
+        case True
+        have T0: "SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i)) =
+              SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> up_ring.monom (UP Q\<^sub>p) \<one> 1"
+          using True coord_ring_to_UP_SA_pvar_0 SA_poly_to_Qp_poly_monom  
+          by (metis "2" function_one_eval Qp.one_closed SA_car SA_one assms constant_function_in_semialg_functions function_one_as_constant)
+        have T1: "eval_at_point Q\<^sub>p (t # a) (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = eval_at_point Q\<^sub>p (t # a) p \<otimes>  t"
+          using 0 True ta_closed eval_pvar[of 0 "Suc n" "t#a"] 
+          by (metis A(2) nth_Cons_0)
+        then show ?thesis 
+          using T0 A SA_poly_to_Qp_poly_closed[of a n  "coord_ring_to_UP_SA n p"] UPQ.to_fun_X[of t] to_fun_mult
+                coord_ring_to_UP_SA_closed[of  ] UPQ.X_closed[of ] unfolding X_poly_def 
+          using assms UPQ.to_fun_mult by presburger                 
+      next
+        case False
+        have "\<vv>\<^bsub>n, i - 1\<^esub> a = a!(i-1)"
+          by (metis A(2) False Qp.varE Suc_diff_1 Suc_less_eq assms  less_Suc_eq_0_disj)
+        hence F0: "SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i)) =
+              SA_poly_to_Qp_poly n a (coord_ring_to_UP_SA n p) \<otimes>\<^bsub>UP Q\<^sub>p\<^esub> to_polynomial Q\<^sub>p (a!(i-1))"
+          using False coord_ring_to_UP_SA_pvar_Suc[of i n] SA_poly_to_Qp_poly_extends_apply[of a n "\<vv>\<^bsub>n, i - 1\<^esub>"] 
+          by (metis (no_types, lifting) "2" A(2) Qp_ev_hom_in_SA Qp_ev_hom_pvar Suc_diff_1 Suc_less_eq assms  local.pvar_closed neq0_conv)
+        have F1: "eval_at_point Q\<^sub>p (t # a) (p \<otimes>\<^bsub>Q\<^sub>p [\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar Q\<^sub>p i) = eval_at_point Q\<^sub>p (t # a) p \<otimes> (a!(i-1))"
+          using 0 False ta_closed eval_pvar[of i "Suc n" "t#a"] 
+          by (metis A(2) nth_Cons')
+        then show ?thesis 
+          using F0 A SA_poly_to_Qp_poly_closed[of a n "coord_ring_to_UP_SA n p"] to_fun_mult
+                coord_ring_to_UP_SA_closed[of p n]   False UPQ.to_fun_to_poly UPQ.to_poly_closed assms 
+              eval_at_point_closed eval_pvar local.pvar_closed neq0_conv nth_Cons_pos ta_closed
+          by (metis (no_types, lifting) UPQ.to_fun_mult)
+      qed
+    qed
+  qed
+qed
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Gluing Semialgebraic Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition SA_poly_glue where 
+"SA_poly_glue m S f g = (\<lambda> n. fun_glue m S (f n) (g n))"
+
+lemma SA_poly_glue_closed: 
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "is_semialgebraic m S"
+  shows "SA_poly_glue m S f g \<in> carrier (UP (SA m))"
+proof(rule UP_car_memI[of "max (deg (SA m) f) (deg (SA m) g)"])
+  fix n assume A: "max (deg (SA m) f) (deg (SA m) g) < n" show "SA_poly_glue m S f g n = \<zero>\<^bsub>SA m\<^esub>"
+    unfolding SA_poly_glue_def
+  proof- 
+    have 0: "n > (deg (SA m) f)"
+      using A by simp
+    have 1: "n > (deg (SA m) g)"
+      using A by simp
+    have 2: "f n = \<zero>\<^bsub>SA m\<^esub>"
+      using 0 assms UPSA.deg_leE by blast
+    have 3: "g n = \<zero>\<^bsub>SA m\<^esub>"
+      using 1 assms UPSA.deg_leE by blast
+    show "fun_glue m S (f n) (g n) = \<zero>\<^bsub>SA m\<^esub>"
+      unfolding SA_zero function_ring_def ring_record_simps function_zero_def 2 3
+    proof fix x 
+      show " fun_glue m S (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<zero>) (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<zero>) x = (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<zero>) x"
+        apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)")
+        unfolding fun_glue_def restrict_def apply presburger
+        by auto  
+    qed
+  qed
+  next
+  show " \<And>n. SA_poly_glue m S f g n \<in> carrier (SA m)"
+    unfolding SA_poly_glue_def apply(rule fun_glue_closed)
+    by(rule cfs_closed, rule assms, rule cfs_closed, rule assms, rule assms)
+qed
+
+lemma SA_poly_glue_deg: 
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "is_semialgebraic m S"
+  assumes "deg (SA m) f \<le> d"
+  assumes "deg (SA m) g \<le> d"
+  shows "deg (SA m) (SA_poly_glue m S f g) \<le> d"
+  apply(rule deg_leqI,  rule SA_poly_glue_closed, rule assms, rule assms, rule assms)
+proof- fix n assume A: "d < n"
+  show "SA_poly_glue m S f g n = \<zero>\<^bsub>SA m\<^esub>"
+    unfolding SA_poly_glue_def
+  proof- 
+    have 0: "n > (deg (SA m) f)"
+      using A assms by linarith
+    have 1: "n > (deg (SA m) g)"
+      using A assms by linarith
+    have 2: "f n = \<zero>\<^bsub>SA m\<^esub>"
+      using 0 assms UPSA.deg_leE by blast
+    have 3: "g n = \<zero>\<^bsub>SA m\<^esub>"
+      using 1 assms UPSA.deg_leE by blast
+    show "fun_glue m S (f n) (g n) = \<zero>\<^bsub>SA m\<^esub>"
+      unfolding SA_zero function_ring_def ring_record_simps function_zero_def 2 3
+    proof fix x 
+      show " fun_glue m S (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<zero>) (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<zero>) x = (\<lambda>x\<in>carrier (Q\<^sub>p\<^bsup>m\<^esup>). \<zero>) x"
+        apply(cases "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)")
+        unfolding fun_glue_def restrict_def apply presburger
+        by auto  
+    qed
+  qed
+qed
+
+lemma UP_SA_cfs_closed: 
+  assumes "g \<in> carrier (UP (SA m))"
+  shows "g k \<in> carrier (SA m)"
+  using assms UP_ring.cfs_closed[of "SA m" g k] SA_is_ring[of m] unfolding UP_ring_def 
+  by blast 
+
+
+lemma SA_poly_glue_cfs1: 
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "is_semialgebraic m S"
+  assumes "x \<in> S"
+  shows "(SA_poly_glue m S f g) n x = f n x"
+  unfolding SA_poly_glue_def fun_glue_def restrict_def 
+  using assms 
+  by (metis SA_car local.function_ring_not_car padic_fields.UP_SA_cfs_closed padic_fields_axioms semialg_functions_memE(2))
+
+lemma SA_poly_glue_cfs2:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "is_semialgebraic m S"
+  assumes "x \<notin> S"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "(SA_poly_glue m S f g) n x = g n x" 
+  unfolding SA_poly_glue_def fun_glue_def restrict_def 
+  using assms by meson
+
+lemma SA_poly_glue_to_Qp_poly1:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "is_semialgebraic m S"
+  assumes "x \<in> S"
+  shows "SA_poly_to_Qp_poly m x (SA_poly_glue m S f g) = SA_poly_to_Qp_poly m x f"
+proof fix n 
+  have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using assms is_semialgebraic_closed by blast
+  have 0: "SA_poly_to_Qp_poly m x (SA_poly_glue m S f g) n = (SA_poly_glue m S f g) n x"
+    by(rule SA_poly_to_Qp_poly_coeff[of x m "SA_poly_glue m S f g"], rule x_closed, rule SA_poly_glue_closed
+          , rule assms, rule assms, rule assms)
+  have 1: "(SA_poly_glue m S f g) n x = f n x"
+    by(rule SA_poly_glue_cfs1 , rule assms, rule assms, rule assms, rule assms)
+  show "SA_poly_to_Qp_poly m x (SA_poly_glue m S f g) n = SA_poly_to_Qp_poly m x f n"
+    unfolding 0 1 using SA_poly_to_Qp_poly_coeff[of x m f n] assms (1) x_closed by blast 
+qed
+
+lemma SA_poly_glue_to_Qp_poly2:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "g \<in> carrier (UP (SA m))"
+  assumes "is_semialgebraic m S"
+  assumes "x \<notin> S"
+  assumes "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "SA_poly_to_Qp_poly m x (SA_poly_glue m S f g) = SA_poly_to_Qp_poly m x g"
+proof fix n 
+  have x_closed: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using assms is_semialgebraic_closed by blast
+  have 0: "SA_poly_to_Qp_poly m x (SA_poly_glue m S f g) n = (SA_poly_glue m S f g) n x"
+    by(rule SA_poly_to_Qp_poly_coeff[of x m "SA_poly_glue m S f g"], rule x_closed, rule SA_poly_glue_closed
+          , rule assms, rule assms, rule assms)
+  have 1: "(SA_poly_glue m S f g) n x = g n x"
+    by(rule SA_poly_glue_cfs2 , rule assms, rule assms, rule assms, rule assms, rule x_closed)
+  show "SA_poly_to_Qp_poly m x (SA_poly_glue m S f g) n = SA_poly_to_Qp_poly m x g n"
+    unfolding 0 1 using SA_poly_to_Qp_poly_coeff[of x m g n] assms x_closed by blast 
+qed
+ 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsubsection\<open>Polynomials over the Valuation Ring\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition integral_on where
+"integral_on m B = {f \<in> carrier (UP (SA m)). (\<forall>x \<in> B. \<forall>i. SA_poly_to_Qp_poly m x f i \<in> \<O>\<^sub>p)}"
+
+lemma integral_on_memI: 
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "\<And>x i. x \<in> B \<Longrightarrow> SA_poly_to_Qp_poly m x f i \<in> \<O>\<^sub>p"
+  shows "f \<in> integral_on m B"
+  unfolding integral_on_def mem_Collect_eq using assms by blast
+
+lemma integral_on_memE: 
+  assumes "f \<in> integral_on m B"
+  shows  "f \<in> carrier (UP (SA m))"
+          "\<And>x. x \<in> B \<Longrightarrow> SA_poly_to_Qp_poly m x f i \<in> \<O>\<^sub>p"
+ using assms unfolding integral_on_def mem_Collect_eq apply blast 
+ using assms unfolding integral_on_def mem_Collect_eq by blast 
+
+lemma one_integral_on:
+  assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "\<one> \<^bsub>UP (SA m)\<^esub> \<in> integral_on m B"
+  apply(rule integral_on_memI)
+  apply blast
+proof- fix x i assume A: "x \<in> B"
+  have 0: "SA_poly_to_Qp_poly m x \<one>\<^bsub>UP (SA m)\<^esub> = \<one>\<^bsub>UP Q\<^sub>p\<^esub>"
+    apply(rule ring_hom_one[of _ "UP (SA m)"])
+    using SA_poly_to_Qp_poly_is_hom[of x m] A assms by blast 
+  show "SA_poly_to_Qp_poly m x \<one>\<^bsub>UP (SA m)\<^esub> i \<in> \<O>\<^sub>p"
+    unfolding 0 
+    apply(rule val_ring_memI)
+     apply(rule UPQ.cfs_closed)
+     apply blast
+    apply(cases "i = 0")
+     apply (metis Qp.add.nat_pow_eone Qp.one_closed UPQ.cfs_one val_of_nat_inc val_one)
+    by (metis Qp.int_inc_zero UPQ.cfs_one val_of_int_inc)
+qed
+
+lemma integral_on_plus:
+  assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  assumes "f \<in> integral_on m B"
+  assumes "g \<in> integral_on m B"
+  shows "f \<oplus>\<^bsub>UP (SA m)\<^esub> g \<in> integral_on m B"
+proof(rule integral_on_memI)
+  show "f \<oplus>\<^bsub>UP (SA m)\<^esub> g \<in> carrier (UP (SA m))"
+    using assms integral_on_memE by blast
+  show "\<And>x i. x \<in> B \<Longrightarrow> SA_poly_to_Qp_poly m x (f \<oplus>\<^bsub>UP (SA m)\<^esub> g) i \<in> \<O>\<^sub>p"
+  proof- fix x i assume A: "x \<in> B"
+    have 0: "SA_poly_to_Qp_poly m x (f \<oplus>\<^bsub>UP (SA m)\<^esub> g) = SA_poly_to_Qp_poly m x f
+                                                          \<oplus>\<^bsub>UP Q\<^sub>p\<^esub>  SA_poly_to_Qp_poly m x g"
+      apply(rule SA_poly_to_Qp_poly_add)
+      using A assms apply blast using assms integral_on_memE apply blast
+      using assms integral_on_memE by blast
+    have 1: "SA_poly_to_Qp_poly m x (f \<oplus>\<^bsub>UP (SA m)\<^esub> g) i = SA_poly_to_Qp_poly m x f i
+                                                          \<oplus>  SA_poly_to_Qp_poly m x g i"
+      unfolding 0 apply(rule UPQ.cfs_add)
+       apply(rule SA_poly_to_Qp_poly_closed)
+      using  A assms apply blast
+      using assms integral_on_memE  apply blast
+       apply(rule SA_poly_to_Qp_poly_closed)
+      using  A assms apply blast
+      using assms integral_on_memE  by blast
+    show "SA_poly_to_Qp_poly m x (f \<oplus>\<^bsub>UP (SA m)\<^esub> g) i \<in> \<O>\<^sub>p"
+      unfolding 1 using assms integral_on_memE 
+      using A val_ring_add_closed by presburger
+  qed
+qed
+
+lemma integral_on_times:
+  assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  assumes "f \<in> integral_on m B"
+  assumes "g \<in> integral_on m B"
+  shows "f \<otimes>\<^bsub>UP (SA m)\<^esub> g \<in> integral_on m B"
+proof(rule integral_on_memI)
+  show "f \<otimes>\<^bsub>UP (SA m)\<^esub> g \<in> carrier (UP (SA m))"
+    using assms integral_on_memE by blast
+  show "\<And>x i. x \<in> B \<Longrightarrow> SA_poly_to_Qp_poly m x (f \<otimes>\<^bsub>UP (SA m)\<^esub> g) i \<in> \<O>\<^sub>p"
+  proof- fix x i assume A: "x \<in> B"
+    have 0: "SA_poly_to_Qp_poly m x (f \<otimes>\<^bsub>UP (SA m)\<^esub> g) = SA_poly_to_Qp_poly m x f
+                                                          \<otimes>\<^bsub>UP Q\<^sub>p\<^esub>  SA_poly_to_Qp_poly m x g"
+      apply(rule SA_poly_to_Qp_poly_mult)
+      using A assms apply blast using assms integral_on_memE apply blast
+      using assms integral_on_memE by blast
+    obtain S where S_def: "S = UP (Q\<^sub>p \<lparr> carrier := \<O>\<^sub>p \<rparr>)"
+      by blast 
+    have 1: "cring S"
+      unfolding S_def apply(rule UPQ.UP_ring_subring_is_ring) 
+      using val_ring_subring by blast
+    have 2: " carrier S = {h \<in> carrier (UP Q\<^sub>p). \<forall>n. h n \<in> \<O>\<^sub>p}"
+      unfolding S_def  using UPQ.UP_ring_subring_car[of \<O>\<^sub>p] val_ring_subring by blast
+    have 3: "SA_poly_to_Qp_poly m x f \<in> carrier S"
+      unfolding 2 mem_Collect_eq using assms integral_on_memE SA_poly_to_Qp_poly_closed A 
+      by blast 
+    have 4: "SA_poly_to_Qp_poly m x g \<in> carrier S"
+      unfolding 2 mem_Collect_eq using assms integral_on_memE SA_poly_to_Qp_poly_closed A 
+      by blast 
+    have 5: "SA_poly_to_Qp_poly m x (f \<otimes>\<^bsub>UP (SA m)\<^esub> g) \<in> carrier S"
+      unfolding 0 
+      using  cring.cring_simprules(5)[of S]3 4 1 UPQ.UP_ring_subring_mult[of \<O>\<^sub>p "SA_poly_to_Qp_poly m x f" "SA_poly_to_Qp_poly m x g"] 
+      using S_def val_ring_subring by metis 
+    show "SA_poly_to_Qp_poly m x (f \<otimes>\<^bsub>UP (SA m)\<^esub> g) i \<in> \<O>\<^sub>p"
+      using 5 unfolding 2 mem_Collect_eq by blast 
+  qed
+qed
+
+lemma integral_on_a_minus:
+  assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  assumes "f \<in> integral_on m B"
+  shows "\<ominus>\<^bsub>UP (SA m)\<^esub> f \<in> integral_on m B"
+  apply(rule integral_on_memI)
+  using assms integral_on_memE(1)[of f m B] 
+  apply blast
+proof- fix x i assume A: "x \<in> B"
+  have 0: "SA_poly_to_Qp_poly m x (\<ominus>\<^bsub>UP (SA m)\<^esub> f) = \<ominus>\<^bsub>UP Q\<^sub>p\<^esub> SA_poly_to_Qp_poly m x f"
+    apply(rule  UP_cring.ring_hom_uminus[of "UP Q\<^sub>p" "UP (SA m)" "SA_poly_to_Qp_poly m x" f ] )
+    unfolding UP_cring_def
+       apply (simp add: UPQ.M_cring)
+    using UPSA.P.is_ring apply blast
+    apply(rule SA_poly_to_Qp_poly_is_hom)
+    using A assms apply blast
+    using assms integral_on_memE by blast 
+  have 2: "\<And>f. f \<in> carrier (UP Q\<^sub>p) \<Longrightarrow> (\<ominus>\<^bsub>UP Q\<^sub>p\<^esub> f) i = \<ominus> (f i)"
+    using UPQ.cfs_a_inv by blast
+  have 1: "SA_poly_to_Qp_poly m x (\<ominus>\<^bsub>UP (SA m)\<^esub> f) i = \<ominus> (SA_poly_to_Qp_poly m x f) i "
+    unfolding 0 apply(rule 2)
+    using integral_on_memE  assms A SA_poly_to_Qp_poly_closed[of x m f] by blast 
+  show "SA_poly_to_Qp_poly m x (\<ominus>\<^bsub>UP (SA m)\<^esub> f) i \<in> \<O>\<^sub>p"
+    unfolding 1 using A assms integral_on_memE(2)[of f m B x i]
+    using val_ring_ainv_closed by blast
+qed
+
+lemma integral_on_subring:
+  assumes "B \<subseteq> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+  shows "subring (integral_on m B) (UP (SA m))"
+proof(rule subringI)
+  show "integral_on m B \<subseteq> carrier (UP (SA m))"
+    unfolding integral_on_def by blast 
+  show "\<one>\<^bsub>UP (SA m)\<^esub> \<in> integral_on m B"
+    using one_integral_on assms by blast 
+  show " \<And>h. h \<in> integral_on m B \<Longrightarrow> \<ominus>\<^bsub>UP (SA m)\<^esub> h \<in> integral_on m B"
+    using integral_on_a_minus assms by blast 
+  show "\<And>h1 h2. h1 \<in> integral_on m B \<Longrightarrow> h2 \<in> integral_on m B \<Longrightarrow> h1 \<otimes>\<^bsub>UP (SA m)\<^esub> h2 \<in> integral_on m B"
+    using integral_on_times assms by blast 
+  show "\<And>h1 h2. h1 \<in> integral_on m B \<Longrightarrow> h2 \<in> integral_on m B \<Longrightarrow> h1 \<oplus>\<^bsub>UP (SA m)\<^esub> h2 \<in> integral_on m B"
+    using integral_on_plus assms by blast 
+qed
+
+lemma val_ring_add_pow:
+  assumes "a \<in> carrier Q\<^sub>p"
+  assumes "val a \<ge> 0"
+  shows "val ([(n::nat)]\<cdot>a) \<ge> 0"
+proof-
+  have 0: "[(n::nat)]\<cdot>a = ([n]\<cdot>\<one>)\<otimes>a"
+    using assms Qp.add_pow_ldistr Qp.cring_simprules(12) Qp.one_closed by presburger
+  show ?thesis unfolding 0 using assms 
+    by (meson Qp.nat_inc_closed val_ring_memE val_of_nat_inc val_ringI val_ring_times_closed)
+qed
+
+lemma val_ring_poly_eval:
+  assumes "f \<in> carrier (UP Q\<^sub>p)"
+  assumes "\<And> i. f i \<in> \<O>\<^sub>p"
+  shows "\<And>x. x \<in> \<O>\<^sub>p \<Longrightarrow> f \<bullet> x \<in> \<O>\<^sub>p"
+proof- fix x assume A: "x \<in> \<O>\<^sub>p"
+  obtain S where S_def: "S = (Q\<^sub>p \<lparr> carrier := \<O>\<^sub>p \<rparr>)"
+    by blast 
+  have 0: "UP_cring S"
+    unfolding S_def apply(rule UPQ.UP_ring_subring(1))
+    using val_ring_subring by blast
+  have 1: "to_function Q\<^sub>p f x = to_function S f x"
+    unfolding S_def  apply(rule UPQ.UP_subring_eval)
+    using val_ring_subring apply blast
+    apply(rule UPQ.poly_cfs_subring)    using val_ring_subring apply blast
+    using assms apply blast
+    using assms apply blast using A by blast 
+  have 2: "f \<in> carrier (UP S)"
+    unfolding S_def 
+    using UPQ.UP_ring_subring_car[of \<O>\<^sub>p] assms val_ring_subring by blast
+  have 3: "to_function S f x \<in> \<O>\<^sub>p"
+      using UPQ.UP_subring_eval_closed[of \<O>\<^sub>p f x]
+    using 1 0 UP_cring.to_fun_closed[of S f x]
+    unfolding S_def 
+    by (metis "2" A S_def UPQ.to_fun_def val_ring_subring)
+  thus "f \<bullet> x \<in> \<O>\<^sub>p"
+    using 1 UPQ.to_fun_def by presburger
+qed
+
+lemma SA_poly_constant_res_class_semialg':
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "\<And>i x. x \<in> B \<Longrightarrow> f i x \<in> \<O>\<^sub>p"
+  assumes "deg (SA m) f \<le> d"
+  assumes "C \<in> poly_res_classes n d"
+  assumes "is_semialgebraic m B"
+  shows "is_semialgebraic m {x \<in> B. SA_poly_to_Qp_poly m x f \<in> C}"
+proof-
+  obtain g where g_def: "g = SA_poly_glue m B f (\<one>\<^bsub>UP (SA m)\<^esub>)"
+    by blast 
+  have g_closed: "g \<in> carrier (UP (SA m))"
+    unfolding g_def by(rule SA_poly_glue_closed, rule assms, blast, rule assms)
+  have g_deg: "deg (SA m) g \<le> d"
+    unfolding g_def apply(rule SA_poly_glue_deg, rule assms, blast, rule assms, rule assms)
+    unfolding deg_one by blast 
+  have 0: "{x \<in> B. SA_poly_to_Qp_poly m x f \<in> C} = B \<inter> {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). SA_poly_to_Qp_poly m x g \<in> C}"
+    apply(rule equalityI', rule IntI, blast)
+    unfolding mem_Collect_eq apply(rule conjI)
+    using assms is_semialgebraic_closed apply blast
+    unfolding g_def using SA_poly_glue_cfs1[of f m "\<one>\<^bsub>UP (SA m)\<^esub>" B] assms
+    using SA_poly_glue_to_Qp_poly1 UPSA.P.cring_simprules(6) apply presburger
+    unfolding g_def using SA_poly_glue_cfs1[of f m "\<one>\<^bsub>UP (SA m)\<^esub>" B] assms
+    using SA_poly_glue_to_Qp_poly1 UPSA.P.cring_simprules(6) 
+    by (metis (no_types, lifting) Int_iff mem_Collect_eq)
+  have 1: "\<And>i x. x \<in> B \<Longrightarrow> g i x = f i x"
+    unfolding g_def by(rule SA_poly_glue_cfs1, rule assms, blast, rule assms, blast)
+  have 2: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> g i x \<in> \<O>\<^sub>p"
+  proof- fix i x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    show "g i x \<in> \<O>\<^sub>p"
+      unfolding g_def apply(cases "x \<in> B")
+      using SA_poly_glue_cfs1[of f m "\<one>\<^bsub>UP (SA m)\<^esub>" B x i]
+            assms(1) assms(2)[of x i] 1 
+      using UPSA.P.cring_simprules(6) assms(5) apply presburger
+      using SA_poly_glue_cfs2[of g m "\<one>\<^bsub>UP (SA m)\<^esub>" B x i] g_closed assms A 
+      by (metis (mono_tags, opaque_lifting) SA_poly_glue_cfs2 SA_poly_to_Qp_poly_coeff 
+          UPSA.P.cring_simprules(6) carrier_is_semialgebraic g_def integral_on_memE(2) is_semialgebraic_closed one_integral_on )
+  qed
+  have 3: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> x \<notin> B \<Longrightarrow> g i x = \<one>\<^bsub>UP (SA m)\<^esub> i x"
+    unfolding g_def apply(rule SA_poly_glue_cfs2[of f m "\<one>\<^bsub>UP (SA m)\<^esub>" B ])
+    by(rule assms, blast, rule assms, blast, blast)  
+  have 4: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> x \<notin> B \<Longrightarrow> g i x \<in> \<O>\<^sub>p "
+    using 3 cfs_one[of m] 2 by blast
+  have 5: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> g i x \<in> \<O>\<^sub>p"
+    using 1 4 assms 2  by blast
+  have 6: "is_semialgebraic m {x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>). SA_poly_to_Qp_poly m x g \<in> C}"
+    by(rule SA_poly_constant_res_class_semialg[of _ _ d _ n], rule g_closed, rule 5, blast, rule g_deg, rule assms)
+  show ?thesis unfolding 0 
+    by(rule intersection_is_semialg, rule assms, rule 6)
+qed
+
+lemma SA_poly_constant_res_class_decomp:
+  assumes "f \<in> carrier (UP (SA m))"
+  assumes "\<And>i x. x \<in> B \<Longrightarrow> f i x \<in> \<O>\<^sub>p"
+  assumes "deg (SA m) f \<le> d"
+  assumes "is_semialgebraic m B"
+  shows "B = (\<Union> C \<in> poly_res_classes n d. {x \<in> B. SA_poly_to_Qp_poly m x f \<in> C})"
+proof(rule equalityI')fix x assume A: "x \<in> B"
+  obtain g where g_def: "g = SA_poly_glue m B f (\<one>\<^bsub>UP (SA m)\<^esub>)"
+    by blast 
+  have g_closed: "g \<in> carrier (UP (SA m))"
+    unfolding g_def by(rule SA_poly_glue_closed, rule assms, blast, rule assms)
+  have g_deg: "deg (SA m) g \<le> d"
+    unfolding g_def apply(rule SA_poly_glue_deg, rule assms, blast, rule assms, rule assms)
+    unfolding deg_one by blast 
+  have 1: "\<And>i x. x \<in> B \<Longrightarrow> g i x = f i x"
+    unfolding g_def by(rule SA_poly_glue_cfs1, rule assms, blast, rule assms, blast)
+  have 2: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> g i x \<in> \<O>\<^sub>p"
+  proof- fix i x assume A: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    show "g i x \<in> \<O>\<^sub>p"
+      unfolding g_def apply(cases "x \<in> B")
+      using SA_poly_glue_cfs1[of f m "\<one>\<^bsub>UP (SA m)\<^esub>" B x i]
+            assms(1) assms(2)[of x i] 1 
+      using UPSA.P.cring_simprules(6) assms(4) apply presburger
+      using SA_poly_glue_cfs2[of g m "\<one>\<^bsub>UP (SA m)\<^esub>" B x i] g_closed assms A 
+      by (metis (mono_tags, opaque_lifting) SA_poly_glue_cfs2 SA_poly_to_Qp_poly_coeff 
+          UPSA.P.cring_simprules(6) carrier_is_semialgebraic g_def integral_on_memE(2) is_semialgebraic_closed one_integral_on )
+  qed
+  have 3: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> x \<notin> B \<Longrightarrow> g i x = \<one>\<^bsub>UP (SA m)\<^esub> i x"
+    unfolding g_def apply(rule SA_poly_glue_cfs2[of f m "\<one>\<^bsub>UP (SA m)\<^esub>" B ])
+    by(rule assms, blast, rule assms, blast, blast)  
+  have 4: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> x \<notin> B \<Longrightarrow> g i x \<in> \<O>\<^sub>p "
+    using 3 cfs_one[of m] 2 by blast
+  have 5: "\<And>i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> g i x \<in> \<O>\<^sub>p"
+    using 1 4 assms 2  by blast
+  have 6: "\<And> i x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> SA_poly_to_Qp_poly m x g i = g i x"
+    by(rule SA_poly_to_Qp_poly_coeff, blast, rule g_closed)
+  have 7: "\<And> x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> SA_poly_to_Qp_poly m x g \<in> val_ring_polys_grad d"
+    apply(rule val_ring_polys_grad_memI, rule SA_poly_to_Qp_poly_closed, blast, rule g_closed)
+    unfolding  6 apply(rule 5, blast)
+    using g_closed  SA_poly_to_Qp_poly_deg_bound[of g m] g_deg le_trans by blast
+  have 8: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> SA_poly_to_Qp_poly m x g \<in> poly_res_class n d (SA_poly_to_Qp_poly m x g)"
+    by(rule poly_res_class_refl, rule 7)
+  have 9: "\<And>x. x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>) \<Longrightarrow> poly_res_class n d (SA_poly_to_Qp_poly m x g) \<in> poly_res_classes n d"
+    unfolding poly_res_classes_def using 7 by blast 
+  have 10: "\<And>x. x \<in> B \<Longrightarrow> SA_poly_to_Qp_poly m x g = SA_poly_to_Qp_poly m x f"
+    unfolding g_def by(rule SA_poly_glue_to_Qp_poly1, rule assms, blast, rule assms, blast)
+  have 11: "x \<in> carrier (Q\<^sub>p\<^bsup>m\<^esup>)"
+    using A is_semialgebraic_closed assms by blast 
+  have 12: "SA_poly_to_Qp_poly m x g = SA_poly_to_Qp_poly m x f"
+    by(rule 10, rule A)
+  have 13: "x \<in> {x \<in> B. SA_poly_to_Qp_poly m x f \<in> poly_res_class n d (SA_poly_to_Qp_poly m x g)}"
+    using 11 10[of x] A 9[of x] 8[of x] unfolding 12 mem_Collect_eq  by blast 
+  show  "x \<in> (\<Union>C\<in>poly_res_classes n d. {x \<in> B. SA_poly_to_Qp_poly m x f \<in> C})"
+    using 13 9[of x] 11  unfolding 12 mem_simps(8) mem_Collect_eq by auto 
+next 
+  show "\<And>x. x \<in> (\<Union>C\<in>poly_res_classes n d. {x \<in> B. SA_poly_to_Qp_poly m x f \<in> C}) \<Longrightarrow> x \<in> B"
+    by blast 
+qed
+
+end
+
+context UP_cring
+begin
+
+lemma pderiv_deg_bound:
+  assumes "p \<in> carrier P"
+  assumes "deg R p \<le> (Suc d)"
+  shows "deg R (pderiv p) \<le> d"
+proof- 
+  have "deg R p \<le> (Suc d) \<longrightarrow> deg R (pderiv p) \<le> d"
+    apply(rule poly_induct[of p])
+      apply (simp add: assms(1))
+    using deg_zero pderiv_deg_0 apply presburger
+  proof fix p assume A: "(\<And>q. q \<in> carrier P \<Longrightarrow> deg R q < deg R p \<Longrightarrow> deg R q \<le> Suc d \<longrightarrow> deg R (pderiv q) \<le> d)"  
+                        "p \<in> carrier P" "0 < deg R p" "deg R p \<le> Suc d"
+    obtain q where q_def: "q \<in> carrier P \<and> deg R q < deg R p \<and> p = q \<oplus>\<^bsub>P\<^esub> ltrm p"
+      using A  ltrm_decomp by metis 
+    have 0: "deg R (pderiv (ltrm p)) \<le> d"
+    proof- 
+      have 1: "pderiv (ltrm p) = up_ring.monom P ([deg R p] \<cdot> p (deg R p)) (deg R p - 1)"
+        using pderiv_monom[of "lcf p" "deg R p"] A  P_def UP_car_memE(1) by auto 
+      show ?thesis unfolding 1 
+        by (metis (no_types, lifting) A(2) A(3) A(4) R.add_pow_closed Suc_diff_1 cfs_closed deg_monom_le le_trans not_less_eq_eq)
+    qed
+    have "deg R q \<le> Suc d" using A q_def  by linarith
+    then have 1: "deg R (pderiv q) \<le> d"
+      using A q_def by blast
+    hence "max (deg R (pderiv q)) (deg R (pderiv (up_ring.monom P (p (deg R p)) (deg R p)))) \<le>  d"
+      using 0 max.bounded_iff by blast
+    thus "deg R (pderiv p) \<le> d "
+      using q_def pderiv_add pderiv_monom[of "lcf p" "deg R p"] A deg_add[of "pderiv q" "pderiv (ltrm p)"]
+      by (metis "0" "1" ltrm_closed bound_deg_sum pderiv_closed)
+  qed
+  thus ?thesis 
+    using assms(2) by blast
+qed
+
+lemma(in cring) minus_zero: 
+"a \<in> carrier R \<Longrightarrow> a \<ominus> \<zero> = a"
+  unfolding a_minus_def 
+  by (metis add.l_cancel_one' cring_simprules(2) cring_simprules(22))
+
+lemma (in UP_cring) taylor_expansion_at_zero: 
+  assumes "g \<in> carrier (UP R)"
+  shows "taylor_expansion R \<zero> g = g"
+proof- 
+  have 0: "X_plus \<zero> = X_poly R"
+    unfolding X_poly_plus_def 
+    by (metis ctrm_degree lcf_eq P.r_zero P_def R.zero_closed UP_cring.ctrm_is_poly UP_cring.to_poly_inverse UP_zero_closed X_closed deg_nzero_nzero is_UP_cring to_fun_ctrm to_fun_zero)
+  show ?thesis 
+    unfolding taylor_expansion_def 0 
+    using assms UP_cring.X_sub is_UP_cring by blast
+qed
+end
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Partitioning Semialgebraic Sets By Zero Sets of Function\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context padic_fields
+begin
+
+definition SA_funs_to_SA_decomp where
+"SA_funs_to_SA_decomp n Fs S = atoms_of ((\<inter>) S ` ((SA_zero_set n ` Fs) \<union> (SA_nonzero_set n ` Fs))) "
+
+lemma SA_funs_to_SA_decomp_closed_0: 
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  shows "(\<inter>) S ` ((SA_zero_set n ` Fs) \<union> (SA_nonzero_set n ` Fs)) \<subseteq> semialg_sets n"
+proof(rule subsetI)
+  fix x assume A: "x \<in> (\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+  show " x \<in> semialg_sets n"
+  proof(cases "x \<in> (\<inter>) S ` SA_zero_set n ` Fs")
+    case True
+    then obtain f where f_def: "f \<in> Fs \<and> x = S \<inter> SA_zero_set n f"
+      by blast 
+    then show "x \<in> semialg_sets n" using assms SA_zero_set_is_semialgebraic  
+      by (meson is_semialgebraicE semialg_intersect subset_iff)
+  next
+    case False
+    then have "x \<in> (\<inter>) S ` SA_nonzero_set n ` Fs"
+      using A by blast
+    then obtain f where f_def: "f \<in> Fs \<and> x = S \<inter> SA_nonzero_set n f"
+      using A by blast 
+    then show "x \<in> semialg_sets n" using assms SA_nonzero_set_is_semialgebraic 
+      by (meson padic_fields.is_semialgebraicE padic_fields.semialg_intersect padic_fields_axioms subset_iff)   
+  qed
+qed
+
+lemma SA_funs_to_SA_decomp_closed: 
+  assumes "finite Fs"
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  shows "SA_funs_to_SA_decomp n Fs S \<subseteq> semialg_sets n"
+  unfolding SA_funs_to_SA_decomp_def semialg_sets_def
+  apply(rule atoms_of_gen_boolean_algebra)
+  using SA_funs_to_SA_decomp_closed_0[of Fs n S]  assms  unfolding semialg_sets_def 
+   apply blast 
+  using assms 
+  by blast
+
+lemma SA_funs_to_SA_decomp_finite: 
+  assumes "finite Fs"
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  shows "finite (SA_funs_to_SA_decomp n Fs S)"
+  unfolding SA_funs_to_SA_decomp_def 
+  apply(rule finite_set_imp_finite_atoms)
+  using assms by blast 
+
+lemma SA_funs_to_SA_decomp_disjoint: 
+  assumes "finite Fs"
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  shows "disjoint (SA_funs_to_SA_decomp n Fs S)"
+  apply(rule disjointI) unfolding SA_funs_to_SA_decomp_def
+  apply(rule atoms_of_disjoint[of _ " ((\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs))"])
+    apply blast apply blast by blast 
+
+lemma pre_SA_funs_to_SA_decomp_in_algebra:
+  shows " ((\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)) \<subseteq> gen_boolean_algebra S (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+proof(rule subsetI) fix x assume A: " x \<in>  (\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+  then obtain A where A_def: "A \<in> (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs) \<and> x = S \<inter> A"
+    by blast 
+  then show "x \<in> gen_boolean_algebra S (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+    using gen_boolean_algebra.generator[of A "SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs" S]
+    by (metis inf.commute)  
+qed
+
+lemma SA_funs_to_SA_decomp_in_algebra:
+  assumes "finite Fs"
+  shows "SA_funs_to_SA_decomp n Fs S \<subseteq> gen_boolean_algebra S (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+  unfolding SA_funs_to_SA_decomp_def  apply(rule atoms_of_gen_boolean_algebra)
+  using pre_SA_funs_to_SA_decomp_in_algebra[of S n Fs] apply blast 
+  using assms by blast
+
+lemma SA_funs_to_SA_decomp_subset: 
+  assumes "finite Fs"
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  assumes "A \<in> SA_funs_to_SA_decomp n Fs S"
+  shows "A \<subseteq> S"
+proof-
+  have "A \<in> gen_boolean_algebra S (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+  using assms SA_funs_to_SA_decomp_in_algebra[of Fs n S] 
+        atoms_of_gen_boolean_algebra[of _  S "(SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"] 
+  unfolding SA_funs_to_SA_decomp_def by blast 
+  then show ?thesis using gen_boolean_algebra_subset by blast  
+qed
+
+lemma SA_funs_to_SA_decomp_memE: 
+  assumes "finite Fs"
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  assumes "A \<in> (SA_funs_to_SA_decomp n Fs S)"
+  assumes "f \<in> Fs"
+  shows "A \<subseteq> SA_zero_set n f \<or> A \<subseteq> SA_nonzero_set n f"
+proof(cases "A \<subseteq> S \<inter> SA_zero_set n f")
+case True
+  then show ?thesis 
+    by blast
+next
+  case False
+  have 0: "S \<inter> SA_zero_set n f \<in> (\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)"
+    using assms 
+    by blast
+  then have 1: "A \<inter> (S \<inter> SA_zero_set n f) = {}"
+    using False assms atoms_are_minimal[of A "((\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs))" "S \<inter> SA_zero_set n f"]
+    unfolding SA_funs_to_SA_decomp_def
+    by blast
+  have 2: "A \<subseteq> S"
+    using assms SA_funs_to_SA_decomp_subset by blast
+  then show ?thesis 
+    using 0 1 False zero_set_nonzero_set_covers_semialg_set[of n S] assms(3) by auto
+qed
+
+lemma SA_funs_to_SA_decomp_covers: 
+  assumes "finite Fs"
+  assumes "Fs \<noteq> {}"
+  assumes "Fs \<subseteq> carrier (SA n)"
+  assumes "is_semialgebraic n S"
+  shows "S = \<Union> (SA_funs_to_SA_decomp n Fs S)"
+proof-
+  have 0: "S = \<Union> ((\<inter>) S ` ((SA_zero_set n ` Fs) \<union> (SA_nonzero_set n ` Fs)))"
+  proof 
+    obtain f where f_def: "f \<in> Fs"
+      using assms by blast 
+    have 0: "S \<inter> SA_nonzero_set n f \<in> ((\<inter>) S ` ((SA_zero_set n ` Fs) \<union> (SA_nonzero_set n ` Fs)))"
+      using f_def by blast 
+    have 1: "S \<inter> SA_zero_set n f \<in> ((\<inter>) S ` ((SA_zero_set n ` Fs) \<union> (SA_nonzero_set n ` Fs)))"
+      using f_def by blast 
+    have 2: "S = S \<inter> SA_zero_set n f \<union> S \<inter> SA_nonzero_set n f"
+      by (simp add: assms(4) zero_set_nonzero_set_covers_semialg_set)
+    then show "S \<subseteq> \<Union> ((\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs))"
+      using 0 1 Sup_upper2 Un_subset_iff subset_refl by blast          
+    show "\<Union> ((\<inter>) S ` (SA_zero_set n ` Fs \<union> SA_nonzero_set n ` Fs)) \<subseteq> S"
+      by blast
+  qed
+  show ?thesis 
+    unfolding SA_funs_to_SA_decomp_def atoms_of_covers' using 0 by blast 
+qed
+
+end
+end
+
diff --git a/thys/Padic_Field/ROOT b/thys/Padic_Field/ROOT
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/ROOT
@@ -0,0 +1,20 @@
+chapter AFP
+
+session Padic_Field (AFP) = "Padic_Ints" +
+  options [timeout = 3600]
+sessions
+    "Localization_Ring"
+theories
+    Fraction_Field
+    Cring_Multivariable_Poly
+    Indices
+    Ring_Powers
+    Padic_Fields
+    Padic_Field_Polynomials
+    Padic_Field_Topology
+    Generated_Boolean_Algebra
+    Padic_Field_Powers
+    Padic_Semialgebraic_Function_Ring   
+  document_files
+    "root.tex"
+    "root.bib"
diff --git a/thys/Padic_Field/Ring_Powers.thy b/thys/Padic_Field/Ring_Powers.thy
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/Ring_Powers.thy
@@ -0,0 +1,7011 @@
+theory Ring_Powers
+  imports "HOL-Algebra.Chinese_Remainder" "HOL-Combinatorics.List_Permutation"
+          Padic_Ints.Function_Ring "HOL-Algebra.Generated_Rings" Cring_Multivariable_Poly Indices
+begin
+
+type_synonym arity = nat
+type_synonym 'a tuple = "'a list"
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Cartesian Powers of a Ring\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsection\<open>Constructing the Cartesian Power of a Ring\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+text\<open>Powers of a ring\<close>
+
+text\<open>\texttt{R\_list n R} produces the list $[R, ... , R]$ of length n\<close>
+
+fun R_list :: "nat \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> (('a, 'b) ring_scheme ) list" where
+"R_list n R = map (\<lambda>_. R) (index_list n)"
+
+text\<open>Cartesian powers of a ring\<close>
+
+definition cartesian_power :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a list) ring" ("_\<^bsup>_\<^esup>" 80) where
+"R\<^bsup>n\<^esup> \<equiv> RDirProd_list (R_list n R)"
+
+lemma R_list_length: 
+"length (R_list n R) = n"
+  apply(induction n) by auto 
+
+lemma R_list_nth:
+"i < n \<Longrightarrow> R_list n R ! i = R"
+  by (simp add: index_list_length)
+
+lemma cartesian_power_car_memI:
+  assumes "length as = n" 
+  assumes "set as \<subseteq> carrier R" 
+  shows "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  unfolding cartesian_power_def 
+  apply(rule RDirProd_list_carrier_memI)
+    using R_list_length assms(1) apply auto[1]
+      by (metis R_list_length R_list_nth assms(1) assms(2) nth_mem subsetD)
+
+lemma cartesian_power_car_memI':
+  assumes "length as = n"
+  assumes "\<And>i. i < n \<Longrightarrow>  as ! i \<in> carrier R"
+  shows "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  unfolding cartesian_power_def 
+  apply(rule RDirProd_list_carrier_memI)
+    using R_list_length assms(1) apply auto[1]
+      by (metis R_list_length R_list_nth assms(2))  
+
+lemma cartesian_power_car_memE:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "length as = n"
+  using RDirProd_list_carrier_mem(1) 
+  by (metis R_list_length assms cartesian_power_def)
+ 
+lemma cartesian_power_car_memE':
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "i < n"
+  shows " as ! i \<in> carrier R"
+  using assms  RDirProd_list_carrier_mem(2) 
+  by (metis (no_types, lifting) R_list_length R_list_nth cartesian_power_def)
+  
+lemma cartesian_power_car_memE'':
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "set as \<subseteq> carrier R"
+  using cartesian_power_car_memE' 
+  by (metis assms cartesian_power_car_memE in_set_conv_nth subsetI)
+  
+lemma cartesian_power_car_memI'':
+  assumes "length as = n + k"
+  assumes "take n as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "drop n as \<in> carrier (R\<^bsup>k\<^esup>)"
+  shows "as \<in> carrier (R\<^bsup>n+k\<^esup>)"
+  apply(rule cartesian_power_car_memI')
+  apply (simp add: assms(1))
+proof- fix i assume A: "i < n + k"
+  show " as ! i \<in> carrier R"
+    apply(cases "i < n")
+     apply (metis assms(2) cartesian_power_car_memE' nth_take)
+    by (metis A add_diff_inverse_nat add_less_imp_less_left 
+        append_take_drop_id assms(2) assms(3) cartesian_power_car_memE 
+        cartesian_power_car_memE' nth_append_length_plus)
+qed
+
+lemma cartesian_power_cons:
+  assumes " as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "a \<in> carrier R"
+  shows "a#as \<in> carrier (R\<^bsup>n+1\<^esup>)"
+  apply(rule cartesian_power_car_memI)
+  apply (metis One_nat_def assms(1) cartesian_power_car_memE list.size(4))
+  by (metis assms(1) assms(2) cartesian_power_car_memE cartesian_power_car_memE' in_set_conv_nth set_ConsD subsetI)
+
+lemma cartesian_power_append:
+  assumes " as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "a \<in> carrier R"
+  shows "as@[a] \<in> carrier (R\<^bsup>n+1\<^esup>)"
+  apply(rule cartesian_power_car_memI'')
+   apply (metis add.commute assms(1) cartesian_power_car_memE length_append_singleton plus_1_eq_Suc)
+  apply (metis append_eq_append_conv_if assms(1) butlast_snoc cartesian_power_car_memE length_append_singleton lessI take_butlast)
+  by (metis add.commute add.right_neutral append_eq_conv_conj assms(1) assms(2) bot_least
+      cartesian_power_car_memE cartesian_power_car_memI cartesian_power_cons 
+      list.set(1) list.size(3))
+
+lemma cartesian_power_head:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "hd as \<in> carrier R"
+  by (metis assms cartesian_power_car_memE cartesian_power_car_memE''  list.set_sel(1) list.size(3) old.nat.distinct(1) subsetD)
+
+lemma cartesian_power_tail:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "tl as \<in> carrier (R\<^bsup>n\<^esup>)"
+  apply(rule cartesian_power_car_memI)
+  apply (metis add_diff_cancel_left' assms cartesian_power_car_memE length_tl plus_1_eq_Suc)
+  by (metis assms cartesian_power_car_memE cartesian_power_car_memE'' list.set_sel(2) list.size(3) nat.simps(3) subsetD subsetI)
+
+lemma insert_at_index_closed:
+  assumes "length as = n"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "a \<in> carrier R"
+  assumes "k \<le> n"
+  shows "(insert_at_index as a k) \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  apply(rule cartesian_power_car_memI')
+   apply (metis Groups.add_ac(2) assms(1) insert_at_index_length plus_1_eq_Suc)
+  by (smt R_list_length Suc_le_eq assms(1) assms(2) assms(3) assms(4) 
+      cartesian_power_car_memE' insert_at_index_eq insert_at_index_eq' 
+      insert_at_index_eq'' less_Suc_eq less_Suc_eq_0_disj not_less_eq_eq)
+
+lemma insert_at_index_pow_not_car:
+  assumes "k \<le>n"
+  assumes "length x = n"
+  assumes "(insert_at_index x a k) \<in> carrier (R\<^bsup>Suc n\<^esup>)" 
+  shows "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  apply(rule cartesian_power_car_memI')
+  apply (simp add: assms(2))
+  by (metis Suc_mono assms(1) assms(2) assms(3) 
+      cartesian_power_car_memE' insert_at_index_eq' 
+      insert_at_index_eq'' leI less_SucI)
+
+lemma insert_at_index_pow_not_car':
+  assumes "k \<le>n"
+  assumes "length x = n"
+  assumes "x \<notin> carrier (R\<^bsup>n\<^esup>)"
+  shows "(insert_at_index x a n) \<notin> carrier (R\<^bsup>Suc n\<^esup>)"
+  by (metis assms(2) assms(3) insert_at_index_pow_not_car lessI less_Suc_eq_le)
+
+lemma take_closed:
+  assumes "k \<le>n"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "take k x \<in> carrier (R\<^bsup>k\<^esup>)"
+  apply(rule cartesian_power_car_memI)
+  apply (metis assms(1) assms(2) cartesian_power_car_memE length_take min.absorb_iff2)
+  by (meson assms(2) cartesian_power_car_memE'' set_take_subset subset_trans)
+
+lemma drop_closed:
+  assumes "k < n"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "drop k x \<in> carrier (R\<^bsup>n - k\<^esup>)"
+  apply(rule   cartesian_power_car_memI[of "drop k x" "n - k"] )
+  using assms(2) cartesian_power_car_memE length_drop apply blast
+   by (metis add_diff_inverse_nat assms(1) assms(2) cartesian_power_car_memE 
+      cartesian_power_car_memE' in_set_conv_nth length_drop less_imp_le_nat
+      nat_add_left_cancel_less nth_drop order.asym subsetI)
+
+lemma last_closed: 
+  assumes "n > 0"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "last x \<in> carrier R"
+  using assms 
+  by (metis Suc_diff_1 cartesian_power_car_memE cartesian_power_car_memE'
+      last_conv_nth lessI list.size(3) neq0_conv)
+
+lemma cartesian_power_concat:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "b \<in> carrier (R\<^bsup>k\<^esup>)"
+  shows "a@b \<in> carrier (R\<^bsup>n+k\<^esup>)"
+        "b@a \<in> carrier (R\<^bsup>n+k\<^esup>)"
+  apply (metis (no_types, lifting) append_eq_conv_conj assms(1) assms(2) 
+    cartesian_power_car_memE cartesian_power_car_memI'' length_append)
+  by (metis (no_types, lifting) add.commute append_eq_conv_conj assms(1) assms(2) 
+      cartesian_power_car_memE cartesian_power_car_memI'' length_append)
+
+lemma cartesian_power_decomp:
+  assumes "a \<in> carrier (R\<^bsup>n+k\<^esup>)"
+  obtains a0 a1 where "a0 \<in> carrier (R\<^bsup>n\<^esup>) \<and> a1 \<in> carrier (R\<^bsup>k\<^esup>) \<and> a0@a1 = a"
+  using assms 
+  by (metis (no_types, lifting) add_diff_cancel_left' append.assoc append_eq_append_conv 
+      append_take_drop_id cartesian_power_car_memE drop_closed le_add1 
+      le_neq_implies_less length_append take_closed)
+
+lemma list_segment_pow:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "j \<le> n"
+  assumes "i \<le>  j"
+  shows "list_segment i j as \<in> carrier (R\<^bsup>j - i\<^esup>)"
+  apply(rule cartesian_power_car_memI)
+  using list_segment_length assms cartesian_power_car_memE 
+   apply blast
+  using assms 
+  by (metis cartesian_power_car_memE cartesian_power_car_memE''
+      dual_order.trans list_segment_subset_list_set)
+
+lemma nth_list_segment:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "j \<le>n"
+  assumes "i \<le>  j"
+  assumes "k < j - i"
+  shows "(list_segment i j as) ! k = as ! (i + k)" 
+  unfolding list_segment_def
+  using assms nth_map_upt[of k j i "((!) as)"   ] 
+  by blast
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Mapping the Carrier of a Ring to its 1-Dimensional Cartesian Power.\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+context cring
+begin
+
+lemma R1_carI:
+  assumes "length as = 1"
+  assumes "as!0 \<in> carrier R"
+  shows "as \<in> carrier (R\<^bsup>1\<^esup>)"
+  apply(rule cartesian_power_car_memI)
+  using assms 
+   apply blast
+     using assms 
+    by (metis in_set_conv_nth less_one subsetI)
+  
+abbreviation(input) to_R1 where
+"to_R1 a \<equiv> [a]"
+
+abbreviation(input) to_R :: "'a list \<Rightarrow> 'a"  where
+"to_R as \<equiv> as!0"
+
+lemma to_R1_to_R:
+  assumes "a \<in> carrier (R\<^bsup>1\<^esup>)"
+  shows "to_R1 (to_R a) = a"
+proof-
+  have "length a = 1"
+    using assms cartesian_power_car_memE by blast
+  then obtain b where "a = [b]"
+    by (metis One_nat_def length_0_conv length_Suc_conv)
+  then show ?thesis 
+    using assms
+    by (metis nth_Cons_0)
+qed
+
+lemma to_R_to_R1:
+  shows "to_R (to_R1 a) = a"
+  by (meson nth_Cons_0)
+
+lemma to_R1_closed:
+  assumes "a \<in> carrier R"
+  shows "to_R1 a \<in> carrier (R\<^bsup>1\<^esup>)"
+proof(rule R1_carI)
+  show "length [a] = 1"
+    by simp 
+  show "[a] ! 0 \<in> carrier R"
+    using assms to_R_to_R1 by presburger    
+qed
+    
+lemma to_R_pow_closed:
+  assumes "a \<in> carrier (R\<^bsup>1\<^esup>)"
+  shows "to_R a \<in> carrier R"
+  using assms cartesian_power_car_memE' by blast
+
+lemma to_R1_intersection:
+  assumes "A \<subseteq> carrier R"
+  assumes "B \<subseteq> carrier R"
+  shows "to_R1 ` (A \<inter> B) = to_R1` A \<inter> to_R1 ` B"
+proof
+  show "(\<lambda>a. [a]) ` (A \<inter> B) \<subseteq> (\<lambda>a. [a]) ` A \<inter> (\<lambda>a. [a]) ` B"
+    by blast
+  show "(\<lambda>a. [a]) ` A \<inter> (\<lambda>a. [a]) ` B \<subseteq> (\<lambda>a. [a]) ` (A \<inter> B)"
+    using assms 
+  by blast
+qed
+
+lemma to_R1_finite:
+  assumes "finite A"
+  shows "finite (to_R1` A)"
+        "card A = card (to_R1` A)"
+  using assms 
+  apply blast
+  apply(rule finite.induct[of A])
+  apply (simp add: assms(1))
+   apply simp
+  by (smt card_insert_if finite_imageI image_iff image_insert list.inject)
+
+lemma to_R1_carrier:
+"to_R1` (carrier R)= carrier (R\<^bsup>1\<^esup>)"
+proof
+  show "(\<lambda>a. [a]) ` carrier R \<subseteq> carrier (R\<^bsup>1\<^esup>)"
+  proof fix x
+    assume "x \<in> (\<lambda>a. [a]) ` carrier R"
+    then show "x \<in> carrier (R\<^bsup>1\<^esup>)"
+      using cartesian_power_car_memI[of x 1 R] 
+      by (metis (no_types, lifting) image_iff to_R1_closed)
+  qed
+  show "carrier (R\<^bsup>1\<^esup>) \<subseteq> (\<lambda>a. [a]) ` carrier R"
+  proof fix x
+    assume "x \<in> carrier (R\<^bsup>1\<^esup>)"
+    then obtain a where a_def: "a \<in> carrier R \<and> x = [a]"
+      using cartesian_power_car_memE'[of x R 1] cartesian_power_car_memE[of x R 1]
+      by (metis less_numeral_extra(1) to_R1_to_R)
+    then show "x \<in> (\<lambda>a. [a]) ` carrier R"
+      by blast
+  qed
+qed
+
+lemma to_R1_diff:
+"to_R1` (A - B) = to_R1` A - to_R1` B"
+proof
+  show "(\<lambda>a. [a]) ` (A - B) \<subseteq> (\<lambda>a. [a]) ` A - (\<lambda>a. [a]) ` B"
+    by blast
+  show "(\<lambda>a. [a]) ` A - (\<lambda>a. [a]) ` B \<subseteq> (\<lambda>a. [a]) ` (A - B)"
+    by blast
+qed
+
+lemma to_R1_complement:
+  shows "to_R1` (carrier R - A) = carrier (R\<^bsup>1\<^esup>) - to_R1` A"
+  by (metis to_R1_carrier to_R1_diff)
+
+lemma to_R1_subset:
+  assumes "A \<subseteq> B"
+  shows "to_R1` A \<subseteq> to_R1` B"
+  using assms 
+  by blast
+
+lemma to_R1_car_subset:
+  assumes "A \<subseteq> carrier R"
+  shows "to_R1` A \<subseteq> carrier (R\<^bsup>1\<^esup>)"
+  using assms to_R1_carrier 
+  by blast
+end 
+
+      (**********************************************************************)
+      (**********************************************************************)
+      subsection\<open>Simple Cartesian Products\<close>
+      (**********************************************************************)
+      (**********************************************************************)
+definition cartesian_product :: "('a list) set \<Rightarrow> ('a list) set \<Rightarrow> ('a list) set" where
+"cartesian_product A B \<equiv> {xs. \<exists>as \<in> A. \<exists>bs \<in> B. xs = as@bs}"
+
+lemma cartesian_product_closed:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  shows "cartesian_product A B \<subseteq> carrier (R\<^bsup>n + m\<^esup>)"
+proof
+  fix x 
+  assume A: "x \<in> cartesian_product A B "
+  then obtain as bs where as_bs_def: "x = as@bs \<and> as \<in> A \<and> bs \<in> B"
+    unfolding cartesian_product_def by blast
+  show "x \<in> carrier (R\<^bsup>n + m\<^esup>) "
+    apply(rule cartesian_power_car_memI')
+     apply (metis as_bs_def assms cartesian_power_car_memE length_append subsetD)
+    using A unfolding cartesian_product_def 
+    by (metis (no_types, lifting) add_diff_inverse_nat as_bs_def assms(1)
+        assms(2) cartesian_power_car_memE cartesian_power_car_memE' 
+        nat_add_left_cancel_less nth_append subsetD)   
+qed
+
+lemma cartesian_product_closed':
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "b \<in>  carrier (R\<^bsup>m\<^esup>)"
+  shows "(a@b) \<in>  carrier (R\<^bsup>n + m\<^esup>)"
+proof-
+  have "a@b \<in> cartesian_product {a} {b}"
+    using cartesian_product_def by blast
+  then show ?thesis 
+  using cartesian_product_closed[of "{a}" R n "{b}" m]
+        assms 
+  by blast
+qed      
+
+lemma cartesian_product_carrier: 
+"cartesian_product (carrier (R\<^bsup>n\<^esup>)) (carrier (R\<^bsup>m\<^esup>)) =  carrier (R\<^bsup>n + m\<^esup>)"
+proof
+  show "cartesian_product (carrier (R\<^bsup>n\<^esup>)) (carrier (R\<^bsup>m\<^esup>)) \<subseteq> carrier (R\<^bsup>n + m\<^esup>)"
+    using cartesian_product_closed[of "(carrier (R\<^bsup>n\<^esup>))" R n "(carrier (R\<^bsup>m\<^esup>)) " m] 
+    by blast
+  show "carrier (R\<^bsup>n + m\<^esup>) \<subseteq> cartesian_product (carrier (R\<^bsup>n\<^esup>)) (carrier (R\<^bsup>m\<^esup>))"
+  proof
+    fix x
+    assume A: "x \<in> carrier (R\<^bsup>n + m\<^esup>)"
+    have 0: "take n x \<in> carrier (R\<^bsup>n\<^esup>)"
+      apply(rule cartesian_power_car_memI')  
+       apply (metis A cartesian_power_car_memE le_add1 length_take min.absorb2)
+         by (metis A add.commute cartesian_power_car_memE' 
+            nth_take trans_less_add2) 
+    have 1: "drop n x \<in> carrier (R\<^bsup>m\<^esup>)"
+      apply(rule cartesian_power_car_memI')  
+        apply (metis A add_diff_cancel_left' cartesian_power_car_memE length_drop)
+          by (metis A cartesian_power_car_memE cartesian_power_car_memE' le_add1 nat_add_left_cancel_less nth_drop)
+    show "x \<in> cartesian_product (carrier (R\<^bsup>n\<^esup>)) (carrier (R\<^bsup>m\<^esup>))"
+      using 0 1 
+      by (smt A cartesian_power_decomp cartesian_product_def mem_Collect_eq)
+qed
+
+
+text\<open>Higher function rings\<close>
+qed
+
+lemma cartesian_product_memI:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "take n a \<in> A"
+  assumes "drop n a \<in> B"
+  shows "a \<in> cartesian_product A B"
+proof-
+  have "a = (take n a) @ (drop n a)"
+    by (metis append_take_drop_id)
+  then show ?thesis 
+    using assms(3) assms(4) cartesian_product_def by blast    
+qed
+
+lemma cartesian_product_memI':
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "a \<in> A"
+  assumes "b \<in> B"
+  shows "a@b \<in> cartesian_product A B"
+  using assms unfolding cartesian_product_def
+  by blast   
+
+lemma cartesian_product_memE: 
+assumes "a \<in> cartesian_product A B"
+assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+shows "take n a \<in> A"
+      "drop n a \<in> B"
+  using assms unfolding cartesian_product_def  
+  apply (smt append_eq_conv_conj cartesian_power_car_memE in_mono mem_Collect_eq)
+  using assms unfolding cartesian_product_def  
+  by (smt append_eq_conv_conj cartesian_power_car_memE in_mono mem_Collect_eq)
+
+lemma cartesian_product_intersection:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "C \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "D \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  shows "cartesian_product A B \<inter> cartesian_product C D = cartesian_product (A \<inter> C) (B \<inter> D)"
+proof
+  show "cartesian_product A B \<inter> cartesian_product C D \<subseteq> cartesian_product (A \<inter> C) (B \<inter> D)"
+  proof fix x
+    assume "x \<in> cartesian_product A B \<inter> cartesian_product C D"
+    then show "x \<in> cartesian_product (A \<inter> C) (B \<inter> D)"
+      using assms cartesian_product_memE[of x C D] cartesian_product_memE[of x A B] 
+            cartesian_product_memI[of "A \<inter> C" R n "B \<inter> D" m x] 
+      by (smt Int_iff inf.coboundedI1)
+  qed
+  show "cartesian_product (A \<inter> C) (B \<inter> D) \<subseteq> cartesian_product A B \<inter> cartesian_product C D"
+  proof fix x
+    assume "x \<in> cartesian_product (A \<inter> C) (B \<inter> D)"
+    then show "x \<in> cartesian_product A B \<inter> cartesian_product C D"
+          using assms cartesian_product_memI[of C R n D m] cartesian_product_memI[of A R n B m]
+            cartesian_product_memE[of x "A \<inter> B" "C \<inter> D" R n ] 
+          by (metis (no_types, lifting) Int_iff cartesian_product_memE(1) cartesian_product_memE(2) inf_le1 subset_trans)          
+  qed
+qed         
+
+lemma cartesian_product_subsetI:
+  assumes "C \<subseteq> A"
+  assumes "D \<subseteq> B"
+  shows "cartesian_product C D \<subseteq> cartesian_product A B"
+  using assms unfolding cartesian_product_def
+  by blast
+
+lemma cartesian_product_binary_union_right:
+  assumes "C \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "D \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "cartesian_product A (C \<union> D) = (cartesian_product A C) \<union> (cartesian_product A D)"
+proof
+  show "cartesian_product A (C \<union> D) \<subseteq> cartesian_product A C \<union> cartesian_product A D"
+    unfolding cartesian_product_def  by blast
+  show "cartesian_product A C \<union> cartesian_product A D \<subseteq> cartesian_product A (C \<union> D)"
+    unfolding cartesian_product_def by blast
+qed
+
+lemma cartesian_product_binary_union_left:
+  assumes "C \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "D \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "cartesian_product (C \<union> D) A = (cartesian_product C A) \<union> (cartesian_product D A)"
+proof
+  show "cartesian_product (C \<union> D) A \<subseteq> cartesian_product C A \<union> cartesian_product D A"
+    unfolding cartesian_product_def by blast
+  show "cartesian_product C A \<union> cartesian_product D A \<subseteq> cartesian_product (C \<union> D) A"
+    unfolding cartesian_product_def by blast 
+qed
+
+lemma cartesian_product_binary_intersection_right:
+  assumes "C \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "D \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  shows "cartesian_product A (C \<inter> D) = (cartesian_product A C) \<inter> (cartesian_product A D)"
+proof
+  show "cartesian_product A (C \<inter> D) \<subseteq> cartesian_product A C \<inter> cartesian_product A D"
+    unfolding cartesian_product_def by blast
+  show "cartesian_product A C \<inter> cartesian_product A D \<subseteq> cartesian_product A (C \<inter> D)"
+  proof fix x assume A: "x \<in> cartesian_product A C \<inter> cartesian_product A D"
+    show "x \<in> cartesian_product A (C \<inter> D)" apply(rule cartesian_product_memI[of A R m _ n  ])
+    apply (simp add: assms(3)) 
+      apply (simp add: assms(1) inf.coboundedI1)
+       apply (meson A IntD1 assms(3) cartesian_product_memE(1))
+        by (meson A Int_iff assms(3) cartesian_product_memE(2))
+  qed
+qed
+
+lemma cartesian_product_binary_intersection_left:
+  assumes "C \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "D \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  shows "cartesian_product (C \<inter> D) A = (cartesian_product C A) \<inter> (cartesian_product D A)"
+proof
+  show "cartesian_product (C \<inter> D) A \<subseteq> cartesian_product C A \<inter> cartesian_product D A"
+    unfolding cartesian_product_def by blast
+  show "cartesian_product C A \<inter> cartesian_product D A \<subseteq> cartesian_product (C \<inter> D) A"
+    proof fix x assume A: "x \<in> cartesian_product C A \<inter> cartesian_product D A"
+    show "x \<in> cartesian_product (C \<inter> D) A" apply(rule cartesian_product_memI[of _ R n _ m ])
+       apply (simp add: assms(2) inf.coboundedI2)
+        apply (simp add: assms(3))
+          apply (meson A Int_iff assms(1) assms(2) cartesian_product_memE(1))
+            by (meson A IntD1 assms(1) cartesian_product_memE(2))
+  qed
+qed
+
+lemma cartesian_product_car_complement_right:
+  assumes "A \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  shows "carrier (R\<^bsup>n + m\<^esup>) - cartesian_product (carrier (R\<^bsup>n\<^esup>)) A = 
+          cartesian_product (carrier (R\<^bsup>n\<^esup>)) ((carrier (R\<^bsup>m\<^esup>)) - A)"
+proof
+  show "carrier (R\<^bsup>n + m\<^esup>) - cartesian_product (carrier (R\<^bsup>n\<^esup>)) A \<subseteq> cartesian_product (carrier (R\<^bsup>n\<^esup>)) ((carrier (R\<^bsup>m\<^esup>)) - A)"
+  proof fix x assume A: "x \<in> (carrier (R\<^bsup>n + m\<^esup>) - cartesian_product (carrier (R\<^bsup>n\<^esup>)) A)"
+  show "x \<in> cartesian_product (carrier (R\<^bsup>n\<^esup>)) ((carrier (R\<^bsup>m\<^esup>)) - A)"
+  apply(rule cartesian_product_memI[of  _  R n _ m]) 
+    apply simp 
+      apply simp
+        apply (meson A DiffE le_add1 take_closed)
+    apply(rule ccontr) 
+    proof-
+      assume A': "drop n x \<notin> (carrier (R\<^bsup>m\<^esup>) - A)"
+      have "drop n x \<in> A"
+      proof-
+      have "x \<in> cartesian_product (carrier (R\<^bsup>n\<^esup>)) (carrier (R\<^bsup>m\<^esup>))"
+        using A 
+        by (metis (mono_tags, lifting) DiffD1 cartesian_product_carrier)
+      then show ?thesis 
+        using A' cartesian_product_memE[of x "(carrier (R\<^bsup>n\<^esup>))" "(carrier (R\<^bsup>m\<^esup>))" R n] 
+        by blast
+      qed
+      then show False 
+        using A cartesian_product_memI[of "(carrier (R\<^bsup>n\<^esup>))" R n A m x] 
+        by (meson DiffD1 DiffD2 assms le_add1 order_refl take_closed)
+    qed
+  qed
+  show "cartesian_product (carrier (R\<^bsup>n\<^esup>)) ((carrier (R\<^bsup>m\<^esup>)) - A) \<subseteq> carrier (R\<^bsup>n + m\<^esup>) - cartesian_product (carrier (R\<^bsup>n\<^esup>)) A"
+  proof fix x assume A: "x \<in> cartesian_product (carrier (R\<^bsup>n\<^esup>)) ((carrier (R\<^bsup>m\<^esup>)) - A)"
+    show "x \<in> carrier (R\<^bsup>n + m\<^esup>) - cartesian_product (carrier (R\<^bsup>n\<^esup>)) A"
+      apply(rule ccontr)
+      using A cartesian_product_memE[of x "carrier (R\<^bsup>n\<^esup>)" A R n]
+      using A cartesian_product_memE[of x "(carrier (R\<^bsup>n\<^esup>))" "(carrier (R\<^bsup>m\<^esup>)) - A" R n] 
+      by (metis (no_types, lifting) DiffD1 DiffD2 DiffI 
+          append_take_drop_id cartesian_product_closed' order_refl)
+  qed
+qed
+
+lemma cartesian_product_car_complement_left:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "carrier (R\<^bsup>n + m\<^esup>) - cartesian_product  A (carrier (R\<^bsup>m\<^esup>)) = 
+          cartesian_product ((carrier (R\<^bsup>n\<^esup>)) - A) (carrier (R\<^bsup>m\<^esup>)) "
+proof
+  show "carrier (R\<^bsup>n + m\<^esup>) - cartesian_product  A (carrier (R\<^bsup>m\<^esup>)) \<subseteq>
+          cartesian_product ((carrier (R\<^bsup>n\<^esup>)) - A) (carrier (R\<^bsup>m\<^esup>)) "
+  proof fix x assume A: " x \<in> carrier (R\<^bsup>n + m\<^esup>) - cartesian_product  A (carrier (R\<^bsup>m\<^esup>))"
+    show "x \<in> cartesian_product ((carrier (R\<^bsup>n\<^esup>)) - A) (carrier (R\<^bsup>m\<^esup>)) "
+    proof(rule cartesian_product_memI[of _ R n _ m]) 
+      show "carrier (R\<^bsup>n\<^esup>) - A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+        by simp
+      show "carrier (R\<^bsup>m\<^esup>) \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+        by simp
+      show "take n x \<in> carrier (R\<^bsup>n\<^esup>) - A"
+        by (metis (no_types, lifting) A DiffD1 DiffD2 DiffI assms 
+            cartesian_product_carrier cartesian_product_memE(2) cartesian_product_memI 
+            le_add1 order_refl take_closed)
+      show "drop n x \<in> carrier (R\<^bsup>m\<^esup>)"
+        by (metis A DiffD1 cartesian_product_carrier cartesian_product_memE(2) order_refl)
+    qed
+  qed
+  show "cartesian_product ((carrier (R\<^bsup>n\<^esup>)) - A) (carrier (R\<^bsup>m\<^esup>)) \<subseteq>
+        carrier (R\<^bsup>n + m\<^esup>) - cartesian_product  A (carrier (R\<^bsup>m\<^esup>)) "
+  proof fix x assume A: " x \<in> cartesian_product ((carrier (R\<^bsup>n\<^esup>)) - A) (carrier (R\<^bsup>m\<^esup>))"
+    show "x \<in> carrier (R\<^bsup>n + m\<^esup>) - cartesian_product  A (carrier (R\<^bsup>m\<^esup>))"
+    apply(rule ccontr)
+      using A cartesian_product_memE[of x "((carrier (R\<^bsup>n\<^esup>)) - A)" "(carrier (R\<^bsup>m\<^esup>))"]
+              cartesian_product_memE[of x A "(carrier (R\<^bsup>m\<^esup>))"]
+      by (smt DiffD1 DiffD2 DiffI Diff_subset append_take_drop_id assms cartesian_product_closed')
+  qed
+qed
+
+lemma cartesian_product_complement_right:
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "cartesian_product A (carrier (R\<^bsup>m\<^esup>)) - (cartesian_product A B) = 
+          cartesian_product A ((carrier (R\<^bsup>m\<^esup>)) - B)"
+proof
+  show "cartesian_product A (carrier (R\<^bsup>m\<^esup>)) - cartesian_product A B \<subseteq> cartesian_product A ((carrier (R\<^bsup>m\<^esup>)) - B)"
+    unfolding cartesian_product_def by blast
+  show "cartesian_product A ((carrier (R\<^bsup>m\<^esup>)) - B) \<subseteq> cartesian_product A ((carrier (R\<^bsup>m\<^esup>))) - cartesian_product A B"
+  proof fix x assume A: "x \<in> cartesian_product A ((carrier (R\<^bsup>m\<^esup>)) - B)"
+    have 0: "x \<in> cartesian_product A (carrier (R\<^bsup>m\<^esup>))" 
+      using A unfolding cartesian_product_def by blast
+    show "x \<in> cartesian_product A (carrier (R\<^bsup>m\<^esup>)) - cartesian_product A B "
+      apply(rule ccontr) 
+      using assms 0 A cartesian_product_memE[of x A "((carrier (R\<^bsup>m\<^esup>)) - B)" R n] 
+                      cartesian_product_memE[of x A B R n] 
+      by blast
+  qed
+qed
+
+lemma cartesian_product_complement_left:
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "cartesian_product (carrier (R\<^bsup>m\<^esup>)) A  - (cartesian_product B A) = 
+          cartesian_product ((carrier (R\<^bsup>m\<^esup>)) - B) A "
+proof
+  show "cartesian_product (carrier (R\<^bsup>m\<^esup>)) A - cartesian_product B A \<subseteq> cartesian_product ((carrier (R\<^bsup>m\<^esup>)) - B) A"
+    unfolding cartesian_product_def by blast
+  show "cartesian_product ((carrier (R\<^bsup>m\<^esup>)) - B) A \<subseteq> cartesian_product (carrier (R\<^bsup>m\<^esup>)) A - cartesian_product B A"
+  proof fix x assume A: "x \<in> cartesian_product ((carrier (R\<^bsup>m\<^esup>)) - B) A"
+    have 0: "x \<in> cartesian_product (carrier (R\<^bsup>m\<^esup>)) A"
+      using A  unfolding cartesian_product_def by blast
+    have 1: "take m x \<in> (carrier (R\<^bsup>m\<^esup>)) - B"
+      using A cartesian_product_memE[of x "((carrier (R\<^bsup>m\<^esup>)) - B)" A R m]
+      by blast
+    have 2: "drop m x \<in> A"
+      using cartesian_product_memE[of x "((carrier (R\<^bsup>m\<^esup>)) - B)" A R m]
+      by (metis  A  Diff_subset)
+    show "x \<in> cartesian_product (carrier (R\<^bsup>m\<^esup>)) A - cartesian_product B A"
+      apply(rule ccontr) 
+      using A 0 1 2 cartesian_product_memE[of x B A R m] assms  
+      by blast
+  qed
+qed
+
+lemma cartesian_product_empty_right:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B = {[]}"
+  shows "cartesian_product A B = A"
+proof
+  show "cartesian_product A B \<subseteq> A"
+    using assms unfolding cartesian_product_def
+    by (smt append_Nil2 mem_Collect_eq singletonD subsetI)
+  show "A \<subseteq> cartesian_product A B"
+    using assms unfolding cartesian_product_def 
+    by blast
+qed
+
+lemma cartesian_product_empty_left:
+  assumes "B \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A = {[]}"
+  shows "cartesian_product A B = B"
+proof
+  show "cartesian_product A B \<subseteq> B"
+    using assms unfolding cartesian_product_def
+    by (smt append.simps(1) mem_Collect_eq singletonD subsetI)
+  show "B \<subseteq> cartesian_product A B"
+    using assms unfolding cartesian_product_def
+    by blast
+qed
+
+      (**********************************************************************)
+      (**********************************************************************)
+      subsection\<open>Cartesian Products at Arbitrary Indices\<close>
+      (**********************************************************************)
+      (**********************************************************************)
+
+definition(in ring) ring_pow_proj ::  "nat  \<Rightarrow> (nat set) \<Rightarrow>  ('a list)  \<Rightarrow> ('a list) " ("\<pi>\<^bsub>_, _\<^esub>")  where
+"ring_pow_proj n S \<equiv> restrict (project_at_indices S) (carrier (R\<^bsup>n\<^esup>))"
+
+text\<open>The projection at an arbitrary index set\<close>
+
+lemma project_at_indices_closed:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "S \<subseteq> indices_of a"
+  shows "\<pi>\<^bsub>S\<^esub> a \<in> carrier (R\<^bsup>card S\<^esup>)"
+  apply(rule cartesian_power_car_memI')
+  using assms proj_at_index_list_length apply blast
+    using assms project_at_indices_nth[of S] 
+    by (smt cartesian_power_car_memE cartesian_power_car_memE' indices_of_def lessThan_iff nth_elem_closed subsetD)
+
+lemma(in ring) ring_pow_proj_is_map:
+  assumes "S \<subseteq> {..<n}"
+  shows "\<pi>\<^bsub>n,S\<^esub> \<in> struct_maps (R\<^bsup>n\<^esup>) (R\<^bsup>card S\<^esup>)"
+proof(rule struct_maps_memI)
+  show "\<And>x. x \<in> carrier (R\<^bsup>n\<^esup>) \<Longrightarrow> \<pi>\<^bsub>n,S\<^esub> x \<in> carrier (R\<^bsup>card S\<^esup>)"
+    using project_at_indices_closed unfolding ring_pow_proj_def 
+    by (metis assms cartesian_power_car_memE indices_of_def restrict_apply')
+  show " \<And>x. x \<notin> carrier (R\<^bsup>n\<^esup>) \<Longrightarrow> \<pi>\<^bsub>n, S\<^esub> x = undefined"
+    by (metis restrict_apply ring_pow_proj_def)
+qed
+
+lemma(in ring) project_at_indices_ring_pow_proj:
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "\<pi>\<^bsub>S\<^esub> x = \<pi>\<^bsub>n,S\<^esub> x"
+  unfolding ring_pow_proj_def 
+  by (metis assms restrict_apply')
+
+text\<open>
+  Cartesian products where the first factor \<open>A\<close> occurs at the entries of some arbitrary index set.
+  Note that this product isn't completely arbitrary because the entries of the factor of \<open>A\<close> 
+  still occurs in ascending order.\<close>
+
+definition twisted_cartesian_product ("Prod\<^bsub>_, _\<^esub>") where
+"twisted_cartesian_product S S' A B = {a . length a = card S + card S' \<and> \<pi>\<^bsub>S\<^esub> a \<in> A \<and> \<pi>\<^bsub>S'\<^esub> a \<in> B}"
+
+lemma twisted_cartesian_product_mem_length:
+  assumes "card S = n"
+  assumes "card S' = m"
+  assumes "a \<in> Prod\<^bsub>S,S'\<^esub> A B"
+  shows "length a = n + m"
+  using assms unfolding twisted_cartesian_product_def 
+  by blast
+
+lemma twisted_cartesian_product_closed:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "card S = n"
+  assumes "card S' = m"
+  assumes "S \<union> S' = {..<n + m}"
+  shows "twisted_cartesian_product S S' A B \<subseteq> carrier (R\<^bsup>n + m\<^esup>)"
+proof(rule subsetI)
+  fix x assume A: "x \<in> twisted_cartesian_product S S' A B"
+  show "x \<in> carrier (R\<^bsup>n + m\<^esup>)"
+  proof(rule cartesian_power_car_memI')
+    show "length x = n + m"
+      using twisted_cartesian_product_mem_length \<open>x \<in> twisted_cartesian_product S S' A B\<close> assms(1) assms(2) assms(3) assms(4) assms(5) by blast
+    fix i assume A': "i < n + m"
+    have 0: "indices_of x = {..<n+m}"
+      by (simp add: \<open>length x = n + m\<close> indices_of_def)
+    show "x ! i \<in> carrier R"
+    proof(cases "i \<in> S")
+      case True
+      have "x!i = \<pi>\<^bsub>S\<^esub>x ! (set_rank S i)"
+        using A' 0 assms 
+        by (metis True Un_upper1 project_at_indices_nth')
+      then show ?thesis 
+        using project_at_indices_closed[of x R "n + m" S] A A'
+              cartesian_power_car_memE'[of "\<pi>\<^bsub>S\<^esub> x" R "card S"]
+        by (metis (no_types, lifting) True UnI2 Un_upper1 assms(1) assms(3) assms(5) 
+            finite_lessThan finite_subset mem_Collect_eq set_rank_range sup.absorb_iff1 
+            twisted_cartesian_product_def)
+    next
+      case False
+      have "x!i = \<pi>\<^bsub>S'\<^esub>x ! (set_rank S' i)"
+        using A' 0 assms 
+        by (metis False UnE lessThan_iff project_at_indices_nth' sup.absorb_iff1 sup.right_idem)        
+      then show ?thesis 
+        using project_at_indices_closed[of x R "n + m" S'] A A'
+              cartesian_power_car_memE'[of "\<pi>\<^bsub>S'\<^esub> x" R "card S'"]
+        by (metis (no_types, lifting) False UnE UnI2 Un_upper2 assms(2) assms(4) assms(5) 
+            finite_lessThan finite_subset lessThan_iff mem_Collect_eq set_rank_range sup.absorb_iff1 
+            twisted_cartesian_product_def)
+    qed
+  qed
+qed
+
+lemma twisted_cartesian_product_memE:
+  assumes "a \<in> twisted_cartesian_product S S' A B"
+  shows "\<pi>\<^bsub>S\<^esub> a \<in> A" "\<pi>\<^bsub>S'\<^esub> a \<in> B"
+  using assms(1) unfolding twisted_cartesian_product_def apply blast 
+    using assms(1) unfolding twisted_cartesian_product_def by blast
+
+lemma twisted_cartesian_product_memI:
+  assumes "\<pi>\<^bsub>S\<^esub> a \<in> A" 
+  assumes "\<pi>\<^bsub>S'\<^esub> a \<in> B"
+  assumes "length a = card S + card S'"
+  shows "a \<in> twisted_cartesian_product S S' A B"
+  by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) mem_Collect_eq twisted_cartesian_product_def)
+
+lemma twisted_cartesian_product_empty_left_factor:
+  assumes "A = {}"
+  shows "twisted_cartesian_product S S' A B = {}"
+  by (metis assms emptyE equals0I twisted_cartesian_product_memE(1))
+
+lemma twisted_cartesian_product_empty_right_factor:
+  assumes "B = {}"
+  shows "twisted_cartesian_product S S' A B = {}"
+  by (metis assms emptyE equals0I twisted_cartesian_product_memE(2))
+
+lemma twisted_cartesian_project_left:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "A \<noteq> {}"
+  assumes "B \<noteq> {}"
+  assumes "card S = n"
+  assumes "card S' = m"
+  assumes "S \<union> S' = {..<n + m}"
+  shows "\<pi>\<^bsub>S\<^esub> ` (Prod\<^bsub>S,S'\<^esub> A B) = A"
+proof
+  have f0: "S \<inter> S' = {}"
+  proof-
+    have "card (S \<union> S') = card S + card S'"
+      by (simp add: assms(5) assms(6) assms(7))
+    thus ?thesis 
+    by (metis Nat.add_diff_assoc2 add.right_neutral add_diff_cancel_left' assms(6) 
+        assms(7) card_0_eq card_Un_Int finite_Int finite_Un finite_lessThan le_add1)
+qed    
+  show "\<pi>\<^bsub>S\<^esub> ` (Prod\<^bsub>S,S'\<^esub> A B) \<subseteq> A"
+   unfolding twisted_cartesian_product_def 
+   by blast
+  show "A \<subseteq> \<pi>\<^bsub>S\<^esub> ` (Prod\<^bsub>S,S'\<^esub> A B)"
+  proof fix x assume A: "x \<in> A"
+    obtain y where y_def: "y \<in> B"
+    using assms(4) by blast  
+    obtain a where a_def: 
+      "a = map (\<lambda>i. if i \<in> S then (x ! set_rank S i) else (y ! set_rank S' i)) [0..<n+m]"
+      by blast 
+    have 0: "S \<subseteq> indices_of a"
+      by (metis (no_types, lifting) Un_upper1 a_def assms(7) diff_zero indices_of_def length_map length_upt)
+    have 1: "S' \<subseteq> indices_of a"
+      by (metis (no_types, lifting) Un_upper2 a_def assms(7) diff_zero indices_of_def length_map length_upt)
+    have 2: "\<pi>\<^bsub>S\<^esub> a = x"
+    proof-
+      have 20: "length (\<pi>\<^bsub>S\<^esub> a) = n"
+        by (metis (no_types, lifting) Un_upper1 a_def assms(5) assms(7) diff_zero indices_of_def length_map length_upt proj_at_index_list_length)
+      have "\<And>i. i < n \<Longrightarrow> \<pi>\<^bsub>S\<^esub> a ! i = x ! i"
+      proof- fix i assume A: "i < n" show "\<pi>\<^bsub>S\<^esub> a ! i = x ! i"
+          using 0 assms a_def project_at_indices_nth'[of S a "nth_elem S i"] set_rank_nth_elem_inv[of S i]
+                nth_map[of i "[0..<n+m]"] 
+          by (smt (z3) A add.left_neutral card.infinite diff_zero indices_of_def length_map length_upt lessThan_iff not_less_zero nth_elem_closed nth_map nth_upt subsetD)
+      qed
+      thus ?thesis using 20 
+        by (metis A assms(1) cartesian_power_car_memE nth_equalityI subsetD)
+    qed
+    have 3: "\<pi>\<^bsub>S'\<^esub> a = y"
+    proof-
+      have 20: "length (\<pi>\<^bsub>S'\<^esub> a) = m"
+        using "1" assms(6) proj_at_index_list_length by blast        
+      have "\<And>i. i < m \<Longrightarrow> \<pi>\<^bsub>S'\<^esub> a ! i = y ! i"
+      proof- fix i assume A: "i < m" 
+        have "nth_elem S' i \<notin> S"
+          using nth_elem_closed[of i S']  f0  A assms(6) by blast
+        thus "\<pi>\<^bsub>S'\<^esub> a ! i = y ! i"
+          using 0 assms a_def project_at_indices_nth'[of S' a "nth_elem S' i"] set_rank_nth_elem_inv[of S' i]
+                nth_map[of i "[0..<n+m]"] 
+          by (smt "1" A add.left_neutral card.infinite diff_zero indices_of_def length_map length_upt lessThan_iff not_less0 nth_elem_closed nth_map nth_upt subsetD)
+      qed
+      thus ?thesis 
+        by (metis "20" assms(2) cartesian_power_car_memE nth_equalityI subsetD y_def)      
+    qed
+    have"a \<in> (Prod\<^bsub>S,S'\<^esub> A B)"
+      apply(rule twisted_cartesian_product_memI)
+        apply (simp add: "2" A)
+          apply (simp add: "3" y_def)
+            by (metis (no_types, lifting) a_def assms(5) assms(6) diff_zero length_map length_upt)
+    thus "x \<in> \<pi>\<^bsub>S\<^esub> ` (Prod\<^bsub>S,S'\<^esub> A B)"
+      using "2" by blast
+  qed
+qed
+
+lemma twisted_cartesian_product_swap:
+  shows "(Prod\<^bsub>S,S'\<^esub> A B) = (Prod\<^bsub>S',S\<^esub> B A)"
+  unfolding twisted_cartesian_product_def 
+  by (metis add.commute)
+
+lemma twisted_cartesian_project_right:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "A \<noteq> {}"
+  assumes "B \<noteq> {}"
+  assumes "card S = n"
+  assumes "card S' = m"
+  assumes "S \<union> S' = {..<n + m}"
+  shows "\<pi>\<^bsub>S'\<^esub> ` (Prod\<^bsub>S,S'\<^esub> A B) = B"
+  using assms twisted_cartesian_project_left[of B R m A n S' S] twisted_cartesian_product_swap
+  by (metis add.commute sup_commute)
+
+text \<open>
+  Cartesian products which send points $a = (a_1, \dots, a_{m})$ and $b = (b_1, \dots, b_{n})$ to
+  the point $(a_1, \dots, a_i, b_1, \dots, b_{n},a_{i+1}, \dots, a_m)$
+\<close>
+definition splitting_permutation :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 
+                                          nat \<Rightarrow> nat" where
+"splitting_permutation l1 l2 i j = (if j < i then j else 
+                                      (if i \<le> j \<and> j < l1 then (l2 + j) else 
+                                          (if j < l1 + l2 then j - l1 + i else j)))"
+
+lemma splitting_permutation_case_1_unique: 
+  assumes "i \<le> l1"
+  assumes "y < i"
+  assumes "splitting_permutation l1 l2 i j = y"
+  shows "j = y"
+  unfolding splitting_permutation_def 
+  using assms(2) assms(3) splitting_permutation_def by auto
+  
+lemma splitting_permutation_case_1_exists: 
+  assumes "i \<le> l1"
+  assumes "y < i"
+  shows "splitting_permutation l1 l2 i y = y"
+  unfolding splitting_permutation_def 
+  by (simp add: assms(2))
+
+lemma splitting_permutation_case_2_unique:
+  assumes "i \<le> l1"
+  assumes "i \<le> y \<and> y < l2 + i"
+  assumes "splitting_permutation l1 l2 i j = y"
+  shows "j = y + l1 - i"
+  unfolding splitting_permutation_def 
+  using assms(1) assms(2) assms(3) le_add_diff_inverse2 not_less_iff_gr_or_eq 
+        splitting_permutation_def trans_less_add2 by auto
+
+lemma splitting_permutation_case_2_exists:
+  assumes "i \<le> l1"
+  assumes "i \<le> y \<and> y < l2 + i"
+  shows "splitting_permutation l1 l2 i (y + l1 - i) = y"
+  unfolding splitting_permutation_def 
+  using assms(1) assms(2) less_diff_conv2 by auto
+
+lemma splitting_permutation_case_3_unique: 
+  assumes "i \<le> l1"
+  assumes "l2 + i \<le> y \<and> y < l1 + l2"
+  assumes "splitting_permutation l1 l2 i j = y"
+  shows "j = y - l2"
+  unfolding splitting_permutation_def 
+  by (smt Nat.le_diff_conv2 add_diff_cancel_left' add_diff_cancel_right' add_leD2 
+      assms(2) assms(3) le_add1 le_diff_iff not_le splitting_permutation_def)
+
+lemma splitting_permutation_case_3_exists: 
+  assumes "i \<le> l1"
+  assumes "l2 + i \<le> y \<and> y < l1 + l2"
+  shows "splitting_permutation l1 l2 i (y - l2) = y"
+  unfolding splitting_permutation_def 
+  by (metis Nat.le_diff_conv2 add.commute add_leD1 assms(2) leD le_add_diff_inverse less_diff_conv2)
+
+lemma splitting_permutation_case_4_unique: 
+  assumes "i \<le> l1"
+  assumes "l1 + l2 \<le> y"
+  assumes "splitting_permutation l1 l2 i j = y"
+  shows "j = y"
+  using assms(1) assms(2) assms(3) le_add_diff_inverse2 less_le_trans 
+      splitting_permutation_def by auto
+
+lemma splitting_permutation_case_4_exists: 
+  assumes "i \<le> l1"
+  assumes "l1 + l2 \<le>y"
+  shows "splitting_permutation l1 l2 i y = y"
+  unfolding splitting_permutation_def 
+  using assms(2) by auto
+
+lemma splitting_permutation_permutes:
+  assumes "i \<le> l1"
+  shows "(splitting_permutation l1 l2 i) permutes {..< l1 + l2}"
+proof-
+  have 0: "(\<forall>x. x \<notin> {..<l1 + l2} \<longrightarrow> splitting_permutation l1 l2 i x = x)"
+  proof fix x show "x \<notin> {..<l1 + l2} \<longrightarrow> splitting_permutation l1 l2 i x = x"
+    proof assume A: "x \<notin> {..<l1 + l2}"
+        then show "splitting_permutation l1 l2 i x = x"
+          using assms unfolding splitting_permutation_def 
+    by simp
+    qed
+  qed
+  have 1: "(\<forall>y. \<exists>!x. splitting_permutation l1 l2 i x = y)"
+  proof fix y
+    show "\<exists>!x. splitting_permutation l1 l2 i x = y"
+    proof(cases "y < i")
+      case True
+      then show ?thesis 
+        using splitting_permutation_case_1_exists splitting_permutation_case_1_unique assms 
+        by (metis splitting_permutation_def)        
+    next
+      case F0: False
+      show ?thesis 
+      proof(cases "i \<le> y \<and> y < l2 + i")
+        case True
+        then show ?thesis
+        using F0 splitting_permutation_case_2_exists splitting_permutation_case_2_unique assms 
+        by metis
+      next
+        case F1: False
+        show ?thesis
+          proof(cases "l2 + i \<le> y \<and> y < l1 + l2")
+            case True
+            then show ?thesis 
+              using F0 F1 splitting_permutation_case_3_exists splitting_permutation_case_3_unique assms 
+              by metis 
+          next
+            case F2: False
+            show ?thesis
+              using F0 F1 F2 splitting_permutation_case_4_exists splitting_permutation_case_4_unique assms 
+              by (metis leI not_less)
+          qed
+        qed
+      qed
+  qed
+  show ?thesis 
+    using 0 1  permutes_def  
+    by  blast 
+qed
+
+lemma splitting_permutation_action:
+  assumes "i \<le>l1"
+  assumes "length a1 = l1"
+  assumes "length a2 = l2"
+  shows "permute_list (splitting_permutation l1 l2 i) ((take i a1) @ a2 @ (drop i a1)) = 
+                      a1@a2"
+proof-
+  obtain x where x_def:  "x = permute_list (splitting_permutation l1 l2 i) ((take i a1) @ a2 @ (drop i a1))"
+    by blast 
+  obtain y where y_def: "y = a1 @ a2"
+    by blast 
+  have 0: "length x = length y"
+    using x_def y_def  assms splitting_permutation_permutes[of i l1 l2]
+    by (smt add.commute add.left_commute le_add_diff_inverse length_append 
+        length_drop length_permute_list length_take min.absorb2)
+  have 1: "\<And>i. i < l1 + l2 \<Longrightarrow> x ! i = y ! i"
+  proof- fix j assume A: "j < l1 + l2"
+    show "x ! j = y ! j"
+      apply(cases "j < i")
+       apply (smt "0" A append_take_drop_id assms(1) assms(2) assms(3) length_append length_permute_list length_take less_le_trans min.absorb2 nth_append permute_list_nth splitting_permutation_case_1_exists splitting_permutation_permutes x_def y_def)
+      apply(cases "i \<le> j \<and> j < l1")
+       apply (smt "0" A add.left_commute append_take_drop_id assms(1) assms(2) assms(3) le_add_diff_inverse length_append length_permute_list length_take min.absorb2 nth_append nth_append_length_plus permute_list_nth splitting_permutation_def splitting_permutation_permutes x_def y_def)
+      using x_def y_def assms
+    by (smt "0" A add.commute add_diff_cancel_left' add_diff_inverse_nat length_append length_permute_list length_take less_diff_conv min.absorb2 not_le nth_append permute_list_nth splitting_permutation_case_1_unique splitting_permutation_def splitting_permutation_permutes) 
+  qed
+  have 2: "length x = l1 + l2"
+     by (simp add: x_def assms(2) assms(3))
+   have 3: "x = y"
+     using 0 1 2  
+  by (metis nth_equalityI)
+  then show ?thesis 
+    using x_def y_def 
+    by blast
+qed
+
+definition scp_permutation where
+"scp_permutation l1 l2 i = fun_inv (splitting_permutation l1 l2 i)"
+
+lemma scp_permutation_action:
+  assumes "i \<le>l1"
+  assumes "length a1 = l1"
+  assumes "length a2 = l2"
+  shows "permute_list (scp_permutation l1 l2 i) (a1@a2) = ((take i a1) @ a2 @ (drop i a1))"
+proof-
+  have "(scp_permutation l1 l2 i) \<circ> (splitting_permutation l1 l2 i) = id"
+    by (metis assms(1) fun_inv_def permutes_inv_o(2) scp_permutation_def splitting_permutation_permutes)
+  then have "permute_list ((scp_permutation l1 l2 i) \<circ> (splitting_permutation l1 l2 i) ) ((take i a1) @ a2 @ (drop i a1)) = 
+          ((take i a1) @ a2 @ (drop i a1))"
+    by (metis permute_list_id)
+  then show ?thesis using splitting_permutation_action permute_list_compose
+    by (smt \<open>scp_permutation l1 l2 i \<circ> splitting_permutation l1 l2 i = id\<close> assms(1) 
+        assms(2) assms(3) fun_inv_def length_append length_permute_list permutes_inv permutes_inv_o(1) scp_permutation_def splitting_permutation_permutes)
+qed
+
+lemma scp_permutes:
+  assumes "i \<le>l1"
+  shows "(scp_permutation l1 l2 i) permutes {..<l1 + l2}"
+  by (simp add: assms(1) fun_inv_def permutes_inv scp_permutation_def splitting_permutation_permutes)
+
+definition split_cartesian_product where
+"split_cartesian_product l1 l2 i A B = permute_list (scp_permutation l1 l2 i) ` (cartesian_product A B)"
+
+lemma split_cartesian_product_memI:
+  assumes "a1@a2 \<in> A"
+  assumes "b \<in> B"
+  assumes "A \<subseteq> carrier (R\<^bsup>l1\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>l2\<^esup>)"
+  assumes "length a1 = i"
+  shows "a1@b@a2 \<in> split_cartesian_product l1 l2 i A B"
+proof-
+  have P: "a1@a2@b \<in> cartesian_product A B"
+    by (metis append.assoc assms(1) assms(2) assms(3) assms(4) cartesian_product_memI')  
+  have 0: "i \<le> l1" 
+    using assms 
+    by (metis cartesian_power_car_memE le_add1 length_append subset_iff)
+  have 1: "length (a1@a2) = l1"
+    using assms(1) assms(3) cartesian_power_car_memE 
+    by blast
+  have 2: "length b = l2"
+    using assms(2) assms(4) cartesian_power_car_memE 
+    by blast
+  have 3: "take i (a1 @ a2) = a1"
+    by (simp add: assms(5))
+  have 4: "drop i (a1 @ a2) = a2"
+    by (simp add: assms(5))
+  have "permute_list (scp_permutation l1 l2 i) ((a1 @ a2) @ b) = take i (a1 @ a2) @ b @ drop i (a1 @ a2)"
+    using 0 1 2 scp_permutation_action[of i l1 "a1@a2" b l2]
+    by blast
+  then have "permute_list (scp_permutation l1 l2 i) ((a1@a2)@b) = a1@b@a2 "
+    by(simp only: 3 4)
+  then have "permute_list (scp_permutation l1 l2 i) (a1@a2@b) = a1@b@a2 "
+    by simp
+  then show ?thesis
+    using P unfolding split_cartesian_product_def  
+    by (metis (mono_tags, lifting) image_eqI)
+qed
+    
+lemma split_cartesian_product_memI':
+  assumes "a \<in> A"
+  assumes "b \<in> B"
+  assumes "A \<subseteq> carrier (R\<^bsup>l1\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>l2\<^esup>)"
+  assumes "i \<le> l1"
+  shows "(take i a)@b@(drop i a) \<in> split_cartesian_product l1 l2 i A B"
+  using assms split_cartesian_product_memI[of "take i a" "drop i a" A b B R l1 l2 i]
+  by (metis append_take_drop_id cartesian_power_car_memE length_take min.absorb2 subset_iff)
+
+lemma split_cartesian_product_memE:
+  assumes "a \<in> split_cartesian_product l1 l2 i A B"
+  assumes "A \<subseteq> carrier (R\<^bsup>l1\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>l2\<^esup>)"
+  assumes "i \<le> l1"
+  shows "(take i a)@(drop (i + l2) a) \<in> A"
+        "(drop i (take (i + l2) a)) \<in> B"
+proof-
+  obtain b where b_def: "b \<in> cartesian_product A B \<and> a = permute_list (scp_permutation l1 l2 i) b"
+    using assms split_cartesian_product_def
+    by (metis (mono_tags, lifting) image_iff)
+  then have 0: "(take l1 b) \<in> A \<and> (drop l1 b) \<in> B"
+    using assms(2) cartesian_product_memE(1)[of b A B R l1] cartesian_product_memE(2)[of b A B R l1]  
+    by metis 
+  have 1: "a = (take i (take l1 b))@(drop l1 b)@(drop i (take l1 b))"
+    using  "0" append_take_drop_id assms(2) assms(3) assms(4) b_def 
+      cartesian_power_car_memE scp_permutation_action subsetD
+    by smt
+  have 2: "(take i a) = (take i (take l1 b))"
+    using 0 1 
+    by (metis (no_types, lifting) append_eq_append_conv append_take_drop_id   
+        assms(4) b_def length_permute_list length_take min.absorb1 take_take)
+  have "drop (i + l2) a = drop i (take l1 b)"
+  proof-
+    have "drop (i + l2) ( (take i (take l1 b))@(drop l1 b)@(drop i (take l1 b))) = drop i (take l1 b)"
+      using assms 
+      by (metis "0" "1" "2" add.commute append_eq_conv_conj append_take_drop_id 
+          cartesian_power_car_memE drop_drop subsetD)
+    then show ?thesis 
+      using 1 
+      by blast
+  qed
+  then show "take i a @ drop (i + l2) a \<in> A"
+    by (metis "0" "2" append_take_drop_id)
+  have 3: "length b = l1 + l2 "
+    by (metis "0" append_take_drop_id assms(2) assms(3) cartesian_power_car_memE length_append subsetD)
+  then have "(drop i (take (i + l2) ((take i (take l1 b))@(drop l1 b)@(drop i (take l1 b))))) = (drop l1 b)"
+  proof-
+    have 0: "take (i + l2) ((take i (take l1 b))@(drop l1 b)@(drop i (take l1 b))) = 
+            take (i + l2) ((take i b)@(drop l1 b)@(drop i (take l1 b)))"
+      using assms(4) 
+      by (metis min.absorb1 take_take)
+    have 1: "length ((take i b)@(drop l1 b)) = i  + l2"
+      using 3  assms 
+      by (metis (no_types, opaque_lifting) add_diff_cancel_left' b_def length_append length_drop 
+          length_permute_list length_take  min.absorb2 trans_le_add1)
+    have 2: "take (i + l2) (((take i b)@(drop l1 b))@(drop i (take l1 b))) = (take i b)@(drop l1 b)"
+      using 1 
+      by (metis append_eq_conv_conj)
+    have 3: "take (i + l2) ((take i b)@(drop l1 b)@(drop i (take l1 b))) = (take i b)@(drop l1 b)"
+      using 2 
+      by (metis append.assoc)
+    have 4: "take (i + l2) ((take i (take l1 b))@(drop l1 b)@(drop i (take l1 b))) =  (take i b)@(drop l1 b)"
+      using "0" "3" 
+      by presburger
+    then have 5: "(drop i (take (i + l2) ((take i (take l1 b))@(drop l1 b)@(drop i (take l1 b))))) = 
+                drop i ((take i b)@(drop l1 b))"
+      by presburger
+    have "length (take i b) = i"
+      by (metis "1" append_take_drop_id assms(4) le_add1 length_take min.absorb2 min.bounded_iff nat_le_linear take_all)
+    then show ?thesis using 5 
+      by (metis append_eq_conv_conj)
+  qed
+  then have "drop i (take (i + l2) a) = drop l1 b"
+    using 1 by blast 
+  then show "(drop i (take (i + l2) a)) \<in> B"
+    using 0 
+    by presburger
+qed
+
+lemma split_cartesian_product_mem_length:
+  assumes "a \<in> split_cartesian_product l1 l2 i A B"
+  assumes "A \<subseteq> carrier (R\<^bsup>l1\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>l2\<^esup>)"
+  assumes "i \<le> l1"
+  shows "length a = l1 + l2"
+  using assms unfolding split_cartesian_product_def 
+  using cartesian_product_closed[of A R l1 B l2] scp_permutes[of i l1 l2]
+  by (smt cartesian_power_car_memE imageE in_mono length_permute_list scp_permutation_def)
+
+lemma split_cartesian_product_memE':
+  assumes "a1@b@a2 \<in> split_cartesian_product l1 l2 i A B"
+  assumes "A \<subseteq> carrier (R\<^bsup>l1\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>l2\<^esup>)"
+  assumes "i \<le> l1"
+  assumes "length a1 = i"
+  assumes "length b = l2"
+  assumes "length as = (l1 - i)"
+  shows "a1@a2 \<in> A"
+        "b \<in> B"
+  using assms split_cartesian_product_memE(1)[of "a1@b@a2" l1 l2  i A B R]
+  apply (metis  append.assoc append_eq_conv_conj length_append)
+  using assms split_cartesian_product_memE(2)[of "a1@b@a2" l1 l2  i A B R]
+  by (metis add_diff_cancel_left' append_eq_conv_conj drop_take)
+
+lemma split_cartesian_product_closed:
+  assumes "A \<subseteq> carrier (R\<^bsup>l1\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>l2\<^esup>)"
+  assumes "i \<le> l1"
+  shows "split_cartesian_product l1 l2 i A B \<subseteq> carrier (R\<^bsup>l1 + l2\<^esup>)"
+proof fix x 
+  assume A: "x \<in> split_cartesian_product l1 l2 i A B"
+  show "x \<in> carrier (R\<^bsup>l1 + l2\<^esup>)"
+    apply(rule cartesian_power_car_memI)
+     apply (meson \<open>x \<in> split_cartesian_product l1 l2 i A B\<close> assms(1) 
+        assms(2) assms(3) split_cartesian_product_mem_length)
+    using assms A unfolding split_cartesian_product_def 
+    using cartesian_product_closed[of A R l1 B l2]
+    by (smt A cartesian_power_car_memE'' image_iff length_permute_list 
+        scp_permutes set_permute_list split_cartesian_product_mem_length subsetD)
+qed
+    
+text\<open>General function for permuting the elements of a simple cartesian product:\<close>
+
+definition intersperse :: "(nat \<Rightarrow> nat) \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple \<Rightarrow> 'a tuple" where
+"intersperse \<sigma> as bs = permute_list \<sigma> (as@bs) "
+
+lemma intersperseE:
+  assumes "\<sigma> permutes ({..<n})"
+  assumes "length as + length bs = n"
+  shows "length (intersperse \<sigma> as bs) = n"
+  by (metis assms(2) intersperse_def length_append length_permute_list)
+
+lemma intersperseE':
+  assumes "\<sigma> permutes ({..<n})"
+  assumes "length as + length bs = n"
+  assumes "length as = k"
+  assumes "\<sigma> i < k"
+  shows "(intersperse \<sigma> as bs)! i  = as ! \<sigma> i"
+proof-
+  have "permute_list \<sigma> (as @ bs) ! i = (as @ bs) ! \<sigma> i"
+    using assms permute_list_nth[of \<sigma> "(as@bs)" i]
+    unfolding intersperse_def 
+    by (metis length_append lessThan_iff permutes_not_in trans_less_add1)    
+  then show ?thesis using assms 
+    by (metis intersperse_def nth_append)
+qed
+
+lemma intersperseE'':
+  assumes "\<sigma> permutes ({..<n})"
+  assumes "length as + length bs = n"
+  assumes "length as = k"
+  assumes "i < n"
+  assumes "\<sigma> i \<ge> k"
+  shows "(intersperse \<sigma> as bs)! i  = bs ! ((\<sigma> i) - k)"  
+proof-
+  have 0: "permute_list \<sigma> (as @ bs) ! i = (as @ bs) ! \<sigma> i"
+    using assms permute_list_nth[of \<sigma> "(as@bs)" i]
+    unfolding intersperse_def 
+  proof -
+    have "(as @ bs) ! \<sigma> i = (as @ bs) ! \<sigma> ([0..<n] ! i)"
+      by (simp add: \<open>i < n\<close>)
+    then show ?thesis
+      by (metis (no_types) \<open>i < n\<close> \<open>length as + length bs = n\<close> diff_zero length_append 
+          length_upt nth_map permute_list_def)
+  qed
+  have 1: "\<sigma> i < n"
+    using assms 
+    by (meson lessThan_iff permutes_in_image)  
+  have 2: "(\<sigma> i) - k < length bs"
+    using "1" assms(2) assms(3) assms(5) by linarith
+  have "(as @ bs) ! (\<sigma> i)  =  bs ! (\<sigma> i - length as)"
+    using assms 1 2 nth_append[of as bs "(\<sigma> i)"] 
+    by (meson not_le)
+  then   have 3: "(as @ bs) ! (\<sigma> i)  =  bs ! (\<sigma> i - k)"
+    using assms 
+    by blast
+  have 4: "permute_list \<sigma> (as @ bs) ! i = (as @ bs) ! (\<sigma> i)"
+    using "0" by blast
+  show ?thesis using 4 3  unfolding intersperse_def
+    by auto     
+qed
+
+text\<open>Some more lemmas about the project\_at\_indices function.\<close>
+
+lemma project_at_indices_consecutive_ind_length:
+  assumes "(i::nat) < j"
+  assumes "j \<le> n"
+  assumes "length a = n"
+  shows "length (project_at_indices {i..<j} a) = j - i"
+  using assms proj_at_index_list_length[of "{i..<j}" a] 
+  unfolding indices_of_def 
+  by (metis card_atLeastLessThan ivl_subset le_less_linear lessThan_atLeast0 not_less0)   
+
+lemma project_at_indices_consecutive_ind_length':
+  assumes "(i::nat) < j"
+  assumes "j \<le> n"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "length (project_at_indices {i..<j} a) = j - i"
+  using assms(1) assms(2) assms(3) cartesian_power_car_memE project_at_indices_consecutive_ind_length by blast
+
+lemma  sorted_list_of_set_from_up_to:
+  assumes  "(i::nat)  < j"
+  assumes "k < j - i"
+  shows "sorted_list_of_set {i..<j} ! k = i + k"
+  using assms apply(induction k)
+  apply simp by simp
+    
+lemma nth_elem_consecutive_indices:
+  assumes "(i::nat) < j"
+  assumes "k < j - i"
+  shows "nth_elem {i..<j} k = i + k"
+  using nth_elem.simps[of "{i..<j}" k] sorted_list_of_set_from_up_to assms(2) 
+  by auto
+  
+lemma project_at_indices_consecutive_indices:
+  assumes "(i::nat) < j"
+  assumes "j \<le> n"
+  assumes "length a = n"
+  assumes "k < j - i"
+  shows "(project_at_indices {i..<j} a) ! k = a! (i + k)"
+  using assms nth_elem_consecutive_indices[of i j k]
+  by (metis atLeast0LessThan card_atLeastLessThan indices_of_def ivl_subset linorder_le_less_linear not_less0 project_at_indices_nth)
+  
+lemma project_at_indices_consecutive_indices':
+  assumes "(i::nat) < j"
+  assumes "j \<le> n" 
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "k < j - i"
+  shows "(project_at_indices {i..<j} a) ! k = a! (i + k)"
+  using assms(1) assms(2) assms(3) assms(4) cartesian_power_car_memE project_at_indices_consecutive_indices by blast
+
+lemma tl_as_projection:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "tl a = project_at_indices {1::nat..<n} a"
+proof-
+  have 0: "indices_of a = {..<n}"
+    using assms cartesian_power_car_memE indices_of_def 
+    by blast    
+  have 1: "length (tl a) = n - 1"
+    using assms cartesian_power_car_memE length_tl 
+    by blast
+  have 2: "length (tl a) = length (project_at_indices {1::nat..<n} a)"
+    using 0 assms cartesian_power_car_memE[of a R n] proj_at_index_list_length[of "{1::nat..<n}" a] 
+    by (metis "1" atLeastLessThan_iff card_atLeastLessThan  lessThan_iff subsetI)
+  have "\<And>i. i < n - 1 \<Longrightarrow> (tl a) ! i = (project_at_indices {1::nat..<n} a) ! i"
+    using project_at_indices_consecutive_indices'[of 1 n n a R] assms 
+    by (metis "1" One_nat_def Suc_leI le_add_diff_inverse2 le_numeral_extra(4) 
+        linorder_neqE_nat nat_add_left_cancel_le nat_diff_split_asm not_less0 nth_tl plus_1_eq_Suc)
+  then show ?thesis 
+    by (metis "1" "2" nth_equalityI)
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Function Rings on Cartesian Powers\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>Complement operator\<close>
+
+definition ring_pow_comp :: "('a, 'b) ring_scheme \<Rightarrow> arity \<Rightarrow> 'a tuple set \<Rightarrow> 'a tuple set" where
+"ring_pow_comp R n S \<equiv> carrier (R\<^bsup>n\<^esup>) - S"
+ 
+lemma ring_pow_comp_closed:
+"ring_pow_comp R n S \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  by (simp add: ring_pow_comp_def)
+
+lemma ring_pow_comp_disjoint:
+"ring_pow_comp R n S \<inter> S = {}"
+  by (simp add: ring_pow_comp_def inf_sup_aci(1))
+  
+lemma ring_pow_comp_union:
+  assumes "S \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "(ring_pow_comp R n S) \<union> S = carrier (R\<^bsup>n\<^esup>)"
+  by (metis ring_pow_comp_def Un_Diff_cancel2 assms sup.absorb_iff1)
+
+lemma ring_pow_comp_carrier:
+"ring_pow_comp R n (carrier (R\<^bsup>n\<^esup>)) = {}"
+  by (simp add: ring_pow_comp_def)
+
+lemma ring_pow_comp_empty:
+"ring_pow_comp R n {} = (carrier (R\<^bsup>n\<^esup>)) "
+  by (simp add: ring_pow_comp_def)
+
+lemma ring_pow_comp_demorgans:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "ring_pow_comp R n (A \<union> B) = (ring_pow_comp R n A) \<inter> (ring_pow_comp R n B)"
+  by (simp add: ring_pow_comp_def Diff_Un )
+
+lemma ring_pow_comp_demorgans':
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "ring_pow_comp R n (A \<inter> B) = (ring_pow_comp R n A) \<union> (ring_pow_comp R n B)"
+  by (simp add: ring_pow_comp_def Diff_Int)
+
+lemma ring_pow_comp_inv:
+  assumes "A \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "ring_pow_comp R n (ring_pow_comp R n A) = A"
+  by (simp add: ring_pow_comp_def assms double_diff)
+
+text\<open>The function ring defined on the powers of a ring:\<close>
+abbreviation(input) ring_pow_function_ring ("Fun\<^bsub>_\<^esub> _") where
+"ring_pow_function_ring n R \<equiv> function_ring (carrier (R\<^bsup>n\<^esup>)) R"
+
+text \<open>
+  Partial function application. Given a function $f(x_1, \dots, x_{n+1})$, an index $i$ and a 
+  point $a \in \text{carrier R}$ returns the function
+  $(x_1,..,x_n) \mapsto f(x_1, \dots, x_{i-1}, a, x_i, \dots, x_n)$ \<close>
+
+lemma ring_pow_function_ring_car_memE:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  shows "f \<in> extensional (carrier (R\<^bsup>n\<^esup>))"
+        "f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R"
+  using ring_functions.function_ring_car_memE[of R f "carrier (R\<^bsup>n\<^esup>)"] assms 
+  unfolding ring_functions_def 
+  using  function_ring_def partial_object.select_convs(1)  apply (metis PiE_iff)
+  using Int_iff assms PiE_iff function_ring_def partial_object.select_convs(1)
+  by (simp add: PiE_iff function_ring_def)
+  
+definition partial_eval :: "('a, 'b) ring_scheme \<Rightarrow> arity \<Rightarrow> nat \<Rightarrow>  ('a list \<Rightarrow> 'a) \<Rightarrow> 'a  \<Rightarrow> ('a list \<Rightarrow> 'a)" where
+"partial_eval R m n f c = restrict (\<lambda> as. f (insert_at_index as c n)) (carrier (R\<^bsup>m\<^esup>))"
+
+context ring 
+begin
+
+lemma function_ring_car_mem_closed: 
+  assumes "f \<in> carrier (function_ring S R)"
+  assumes "s \<in> S"
+  shows "f s \<in> carrier R"
+  using assms unfolding function_ring_def ring_record_simps by blast 
+
+lemma function_ring_car_mem_closed': 
+  assumes "f \<in> carrier (Fun\<^bsub>Suc k\<^esub> R)"
+  assumes "s \<in> carrier (R\<^bsup>Suc k\<^esup>)"
+  shows "f s \<in> carrier R"
+  using assms unfolding function_ring_def ring_record_simps by blast 
+
+lemma(in ring) partial_eval_domain:
+  assumes "f \<in> carrier (Fun\<^bsub>Suc k\<^esub> R)"
+  assumes "a \<in> carrier R"
+  assumes "n \<le>k"
+  shows "(partial_eval R k n f a)  \<in> carrier (Fun\<^bsub>k\<^esub> R)"
+  apply(rule ring_functions.function_ring_car_memI)
+proof-
+  show "\<And>x. x \<in> carrier (R\<^bsup>k\<^esup>) \<Longrightarrow> (partial_eval  R k n f a)  x \<in> (carrier R)"  
+  proof-
+    fix x
+    assume A: "x \<in> carrier (R\<^bsup>k\<^esup>)"
+    show "(partial_eval  R k n f a)  x \<in> (carrier R)"
+    proof(cases "n = k")
+      case True
+      then have "(partial_eval  R k n f a)  x = f (insert_at_index x a n)"
+        by (metis (no_types, lifting) A restrict_apply' partial_eval_def)     
+      then show "(partial_eval  R k n f a) x \<in> carrier R"
+        using insert_at_index_closed[of x k R a n] assms ring_functions.function_ring_car_memE[of R]
+        unfolding ring_functions_def 
+        by (smt A cartesian_power_car_memE funcset_carrier ring_pow_function_ring_car_memE(2))
+        
+    next
+      case False
+      then have F0: "(partial_eval  R k n f a)  x = f (insert_at_index x a n)"
+        unfolding partial_eval_def 
+        using assms   
+        by (meson A restrict_apply')  
+      have F1: "(insert_at_index x a n) \<in> carrier (R\<^bsup>Suc k\<^esup>)"
+        using A assms insert_at_index_closed[of x k R a n] cartesian_power_car_memE 
+        by blast
+      show "(partial_eval  R k n f a) x \<in> carrier R"
+        unfolding F0 apply(rule function_ring_car_mem_closed[of f "carrier (R\<^bsup>Suc k\<^esup>)"]) 
+         apply (simp add: assms(1))
+        by(rule F1)         
+    qed
+  qed
+  show "\<And>x. x \<notin> carrier (R\<^bsup>k\<^esup>) \<Longrightarrow> (partial_eval  R k n f a)  x = undefined"
+  proof-
+    fix x
+    assume "x \<notin> carrier (R\<^bsup>k\<^esup>)"
+    show "(partial_eval  R k n f a) x = undefined"
+      unfolding partial_eval_def 
+      by (meson \<open>x \<notin> carrier (R\<^bsup>k\<^esup>)\<close> restrict_apply)
+  qed
+  show "ring_functions R"
+    unfolding ring_functions_def 
+    by (simp add: ring_axioms)
+qed
+
+text\<open>Pullbacks preserve ring power functions\<close>
+
+lemma fun_struct_maps:
+"struct_maps (R\<^bsup>n\<^esup>) R = carrier (Fun\<^bsub>n\<^esub> R)"
+proof
+  show "struct_maps (R\<^bsup>n\<^esup>) R \<subseteq> carrier Fun\<^bsub>n\<^esub> R"
+    by (smt function_ring_car_memI struct_maps_memE(1) struct_maps_memE(2) subsetI)    
+  show "carrier (Fun\<^bsub>n\<^esub> R) \<subseteq> struct_maps (R\<^bsup>n\<^esup>) R"
+    using struct_maps_memI ring_functions.function_ring_car_memE
+  by (smt function_ring_car_mem_closed  ring_axioms ring_functions.function_ring_not_car ring_functions.intro subsetI)
+qed
+
+lemma pullback_fun_closed:
+  assumes "f \<in> struct_maps (R\<^bsup>n\<^esup>) (R\<^bsup>m\<^esup>)"
+  assumes "g \<in> carrier (Fun\<^bsub>m\<^esub> R)"
+  shows "pullback (R\<^bsup>n\<^esup>) f g \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  using assms(1) assms(2) fun_struct_maps pullback_closed by blast
+
+end
+
+
+text\<open>Includes $R^{|S|}$ into $R^n$ by pulling back along the projection $R^n \mapsto R^{|S|}$ at indices $S$ \<close>
+
+context ring
+begin
+
+definition(in ring) ring_pow_inc :: " (nat set) \<Rightarrow> arity  \<Rightarrow> ('a tuple  \<Rightarrow> 'a) => ('a tuple \<Rightarrow> 'a)  " where
+"ring_pow_inc S n f = pullback (R\<^bsup>n\<^esup>) (\<pi>\<^bsub>n,S\<^esub>) f"
+
+lemma ring_pow_inc_is_fun:
+  assumes "S \<subseteq> {..<n}"
+  assumes "f \<in> carrier (Fun\<^bsub>card S\<^esub> R)"
+  shows "ring_pow_inc S n f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  by (metis assms(1) assms(2) ring_pow_proj_is_map pullback_fun_closed ring_pow_inc_def)
+
+text\<open>The "standard" inclusion of powers of function rings into one another\<close>
+
+abbreviation(input) std_proj:: "nat \<Rightarrow> nat \<Rightarrow> ('a list) \<Rightarrow> ('a list)" where 
+"std_proj n m \<equiv> ring_pow_proj n ({..<m}) "
+
+lemma std_proj_id: 
+  assumes "m \<le> n"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "i < m"
+  shows "std_proj n m as ! i = as ! i"
+proof-
+  have "{..<m} \<subseteq> indices_of as"
+    using assms cartesian_power_car_memE unfolding indices_of_def 
+    by blast
+  thus ?thesis 
+  unfolding ring_pow_proj_def
+    using assms nth_elem_upto[of i m] 
+           project_at_indices_nth[of "{..<m}" as i] 
+  by (metis card_lessThan restrict_apply)
+qed
+
+abbreviation(input) std_inc:: "nat \<Rightarrow> nat \<Rightarrow> ('a list  \<Rightarrow> 'a)  => ('a list  \<Rightarrow> 'a)" where
+"std_inc n m f \<equiv> ring_pow_inc ({..<m}) n f"
+
+lemma std_proj_is_map[simp]:
+  assumes "m \<le> n"
+  shows "std_proj n m \<in> struct_maps (R\<^bsup>n\<^esup>) (R\<^bsup>m\<^esup>)"
+  by (metis assms card_lessThan lessThan_subset_iff ring_pow_proj_is_map)
+
+end
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Coordinate Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition var :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a)" where
+"var R n i = restrict (\<lambda>x. x!i) (carrier (R\<^bsup>n\<^esup>))"
+
+context ring
+begin
+
+lemma var_in_car:
+  assumes "i < n"
+  shows "var R n i \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  apply(rule function_ring_car_memI)
+  unfolding var_def 
+  apply (metis assms cartesian_power_car_memE' restrict_apply')
+  by (meson restrict_apply)
+  
+
+lemma varE[simp]: 
+  assumes "i < n"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "var R n i x = x ! i"
+  unfolding var_def 
+  using  assms(2) 
+  by (meson restrict_apply')
+
+lemma std_inc_of_var:
+  assumes "i < n"
+  assumes "n \<le>m"
+  shows "std_inc m n (var R n i) =  (var R m i)"
+  apply(rule ext)
+proof-
+  fix x
+  show "std_inc m n (var R n i) x = var R m i x"
+    apply(cases "x \<in> carrier (R\<^bsup>m\<^esup> )")
+  proof-
+    show "x \<in> carrier (R\<^bsup>m\<^esup>) \<Longrightarrow> std_inc m n (var R n i) x = var R m i x"
+    proof-
+      assume A: "x \<in> carrier (R\<^bsup>m\<^esup>)"
+      have "(restrict (project_at_indices ({..<n})) (carrier (R\<^bsup>m\<^esup>))) x =  ((project_at_indices ({..<n})) x)"
+        by (meson A restrict_apply')
+      then have B: "std_inc m n (var R n i) x = (var R n i) ((project_at_indices ({..<n})) x)"
+        unfolding ring_pow_inc_def ring_pow_proj_def pullback_def 
+        by (metis A compose_eq)
+      have C: "var R m i x = x ! i"
+        by (metis A assms(1) assms(2) le_iff_add trans_less_add1 varE)
+      show "std_inc m n (var R n i) x = var R m i x"
+        by (metis A B C assms(1) assms(2) project_at_indices_ring_pow_proj std_proj_id std_proj_is_map struct_maps_memE(1) varE)
+    qed
+    show "x \<notin> carrier (R\<^bsup>m\<^esup>) \<Longrightarrow> std_inc m n (var R n i) x = var R m i x"
+      by (metis (mono_tags, lifting) assms(1) assms(2) card_lessThan lessThan_subset_iff less_SucI ring_axioms nat_induct_at_least ring.fun_struct_maps ring_pow_inc_is_fun struct_maps_memE(2) var_in_car)      
+  qed
+qed
+
+abbreviation variable ("\<vv>\<^bsub>_\<^esub>") where
+"variable n i \<equiv> var R n i"
+
+end
+
+definition var_set :: "('a, 'b) ring_scheme \<Rightarrow>  nat \<Rightarrow> ('a list \<Rightarrow> 'a) set" where
+"var_set R n = var R n ` {..<n}"
+
+lemma var_setE:
+  assumes "f \<in> var_set R n"
+  obtains i where "f = var R n i \<and> i \<in> {..<n}"
+  by (metis assms imageE that var_set_def)
+
+lemma var_setI:
+  assumes "i \<in> {..<n}"
+  assumes  "f = var R n i"
+  shows "f \<in> var_set R n"
+  using assms(1) assms(2) var_set_def 
+  by blast
+
+context ring 
+begin
+
+lemma var_set_in_fun_ring_car:
+  shows "var_set R n \<subseteq> carrier Fun\<^bsub>n\<^esub> R"
+proof
+  fix x
+  assume "x \<in> var_set R n"
+  then obtain i where i_def: "i \<in> {..<n} \<and> x = var R n i"
+    unfolding var_set_def 
+    by blast
+  have "i < n"using i_def 
+    using atLeastLessThan_iff by blast  
+  then show "x \<in> carrier Fun\<^bsub>n\<^esub> R" 
+    using i_def var_in_car by blast     
+qed
+
+
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Graphs of functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition fun_graph:: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a) \<Rightarrow> 'a list set" where
+"fun_graph R n f = {as. (\<exists>x \<in> carrier (R\<^bsup>n\<^esup>). as = x @ [f x])}"
+
+context ring 
+begin
+
+lemma function_ring_car_memE:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "f a \<in> carrier R"
+  using ring_functions.function_ring_car_memE(1)[of R f] 
+  unfolding ring_functions_def 
+  by (meson assms(1) assms(2) ring_axioms function_ring_car_mem_closed ring_functions_def)
+
+lemma graph_range:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  shows "fun_graph R n f \<subseteq> carrier (R\<^bsup>Suc n\<^esup> )"
+proof
+  fix x
+  assume x_def: "x \<in> fun_graph R n f"
+  obtain a where a_def: "a \<in> carrier (R\<^bsup>n\<^esup>) \<and> x = a@[f a]"
+    using x_def fun_graph_def 
+    by (smt mem_Collect_eq)
+  have f_closed: "f a \<in> carrier R"
+    using assms function_ring_car_memE a_def 
+    by blast 
+  show "x \<in> carrier (R\<^bsup>Suc n\<^esup> )"
+  proof(rule cartesian_power_car_memI)
+    show "length x = Suc n"
+      using x_def a_def cartesian_power_car_memE[of a R n]
+      by (metis length_append_singleton)
+    have "set x = insert (f a) (set a)"
+      using a_def   
+      by (metis Un_insert_right append_Nil2 list.simps(15) set_append)
+    thus "set x \<subseteq> carrier R"
+      using a_def 
+      by (metis cartesian_power_car_memE'' f_closed insert_subset)
+  qed
+qed
+
+lemma fun_graph_memE:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  assumes "p \<in> fun_graph R n f"
+  shows "(take n p) \<in> carrier (R\<^bsup>n\<^esup>)"
+    using assms unfolding fun_graph_def  
+  by (metis (no_types, lifting) assms(2) graph_range le_add2 plus_1_eq_Suc subsetD take_closed)
+
+lemma fun_graph_memE':
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  assumes "p \<in> fun_graph R n f"
+  shows "f (take n p) = p!n"
+  using assms 
+  unfolding fun_graph_def 
+  by (smt Cons_nth_drop_Suc append_take_drop_id assms(2) butlast_snoc cartesian_power_car_memE 
+      drop_all graph_range last_snoc le_Suc_eq lessI mem_Collect_eq subsetD)
+  
+text\<open>
+  apply a function f to the tuple consisting of the first n indices, leaving the remaining indices
+  unchanged
+\<close>
+
+definition partial_image :: "arity \<Rightarrow> ('c list \<Rightarrow> 'c) \<Rightarrow> 'c list \<Rightarrow> 'c list" where
+"partial_image n f as = (f (take n as)) # (drop n as) "
+
+lemma partial_image_range:
+  assumes "f \<in> carrier (Fun\<^bsub>n\<^esub> R)"
+  assumes "m \<ge> n"
+  assumes "as \<in> carrier (R\<^bsup>m\<^esup>)"
+  shows "partial_image n f as \<in> carrier (R\<^bsup>m - n + 1\<^esup>)"
+proof(cases "m = n")
+  case True
+  then have "f (take n as) = f as"
+    by (metis assms(2) assms(3) cartesian_power_car_memE take_all)
+  then have 0: "f (take n as) \<in> carrier R"
+    using True assms(1) assms(3) function_ring_car_memE by presburger    
+  have 1: "(drop n as) = []"
+    using True assms(3) cartesian_power_car_memE drop_all by blast
+  then show ?thesis 
+    unfolding partial_image_def 
+    using 0 1   
+    by (metis (no_types, lifting) One_nat_def assms(3) cartesian_power_car_memE 
+        cartesian_power_car_memI empty_iff insert_iff length_drop list.set(1) 
+        list.set(2) list.size(4) subsetI)
+next
+  case False
+  then have 0: "(drop n as) \<in> carrier (R\<^bsup>m - n\<^esup>)"
+    using assms drop_closed[of n m as R] le_neq_implies_less 
+    by blast
+  have 1: "f (take n as) \<in> carrier R"
+    using assms(1) assms(2) assms(3) function_ring_car_memE take_closed by blast    
+  show ?thesis 
+    apply(rule cartesian_power_car_memI)
+     apply (metis "0" One_nat_def cartesian_power_car_memE list.size(4) partial_image_def)
+      by (smt "1" assms(3) cartesian_power_car_memE cartesian_power_car_memE' in_set_conv_nth 
+      partial_image_def set_ConsD set_drop_subset subsetD subsetI) 
+qed
+
+end 
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Coordinate Rings on Cartesian Powers\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Basic Facts and Definitions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+locale cring_coord_rings = UP_cring + 
+  assumes one_neq_zero: "\<one> \<noteq> \<zero>"
+
+text\<open>coordinate polynomial ring in n variables over a commutative ring\<close>
+
+definition coord_ring :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a, ('a, nat) mvar_poly) module"
+ ("_ [\<X>\<^bsub>_\<^esub>]" 80) where "R[\<X>\<^bsub>n\<^esub>] \<equiv> Pring R {..< n::nat}"
+
+sublocale cring_coord_rings < cring_functions R "carrier (R\<^bsup>n\<^esup>)" "Fun\<^bsub>n\<^esub> R"
+  unfolding cring_functions_def ring_functions_def  
+  apply (simp add: R.ring_axioms R_cring)
+  by simp
+
+sublocale cring_coord_rings <  MP?: cring "R[\<X>\<^bsub>n\<^esub>]"
+  by (simp add: R.Pring_is_cring R_cring coord_ring_def)
+
+sublocale cring_coord_rings < F?: cring "Fun\<^bsub>n\<^esub> R"
+  by (simp add: function_ring_is_cring)
+
+context cring_coord_rings
+begin
+
+lemma coord_cring_cring:
+"cring (R[\<X>\<^bsub>n\<^esub>])" unfolding coord_ring_def
+  by (simp add: R.Pring_is_cring R_cring)
+  
+text\<open>coordinate constant functions\<close>
+
+abbreviation(input) coord_const :: "'a \<Rightarrow> ('a, nat) mvar_poly" where
+"coord_const k \<equiv> ring.indexed_const R k"
+
+lemma coord_const_ring_hom:
+"ring_hom_ring R (R[\<X>\<^bsub>n\<^esub>]) coord_const"
+  unfolding coord_ring_def
+  apply(rule ring_hom_ringI)
+       apply (simp add: R.ring_axioms)
+      apply (simp add: R.Pring_is_ring)
+     apply (simp add: R.indexed_const_closed)
+    apply (simp add: R.indexed_const_mult)
+  apply (simp add: R.Pring_add R.indexed_padd_const)
+ by (simp add: R.Pring_one)
+  
+text\<open>coordinate functions\<close>
+
+lemma pvar_closed:
+  assumes "i < n"
+  shows "pvar R i \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  unfolding var_to_IP_def
+proof-
+  have "set_mset {#i#} \<subseteq> {..<n}"
+    using assms 
+    by simp    
+  then show "mset_to_IP R {#i#} \<in> carrier (R[\<X>\<^bsub>n\<^esub>])" 
+    by (simp add: R.ring_axioms coord_ring_def R.Pring_car ring.mset_to_IP_closed)
+qed
+
+text\<open>relationship between multiplciation by a variable and index multiplcation\<close>
+
+lemma pvar_indexed_pmult:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "(p \<Otimes> i) = p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i"
+proof-
+  have "p \<in> Pring_set R {..<(n::nat)} " 
+    using R.Pring_car assms 
+    by (metis coord_ring_def)   
+  then have "p \<in> Pring_set R (UNIV::nat set)" 
+    using R.Pring_set_restrict 
+    by blast
+  then show ?thesis  
+    using assms R.poly_index_mult[of p UNIV i]  unfolding var_to_IP_def
+    by (metis R.Pring_mult UNIV_I coord_ring_def)    
+qed
+
+lemma coord_ring_cfs_closed:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "p m \<in> carrier R"
+  using assms unfolding coord_ring_def 
+  using R.Pring_carrier_coeff' by blast  
+
+lemma coord_ring_plus:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "(p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q) m = p m \<oplus> Q m"
+  using assms unfolding coord_ring_def 
+  by (metis R.Pring_add R.indexed_padd_def)
+
+lemma coord_ring_uminus:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "(\<ominus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> p) m = \<ominus> (p m)"
+  using assms unfolding coord_ring_def 
+  using MP.add.inv_closed MP.minus_minus coord_ring_cfs_closed coord_ring_def 
+        coord_ring_plus is_abelian_group R.is_cring
+        R.ring_axioms 
+  by (metis P_ring_uminus_def R.Pring_a_inv assms)
+
+lemma coord_ring_minus:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "(p \<ominus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q) m = p m \<ominus> Q m"
+  using assms R.Pring_add[of _ p Q] coord_ring_cfs_closed
+  unfolding indexed_padd_def coord_ring_def a_minus_def 
+  by (metis (no_types, lifting) MP.add.inv_closed coord_ring_def coord_ring_plus 
+      cring_coord_rings.coord_ring_uminus cring_coord_rings_axioms)
+
+lemma coord_ring_one:
+"\<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m = (if m = {#} then \<one> else \<zero>)"
+  by (metis R.Pring_one coord_ring_def R.indexed_const_def)
+
+lemma coord_ring_zero:
+"\<zero>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m = \<zero>"
+  by (metis MP.minus_zero MP.r_zero MP.zero_closed R_cring coord_ring_cfs_closed coord_ring_plus coord_ring_uminus cring.cring_simprules(17))
+  
+text\<open>Evaluation of a polynomial at a point\<close>
+
+end
+
+abbreviation(input) point_to_eval_map where
+"point_to_eval_map R as \<equiv> (\<lambda>i. (if i< length as then as ! i else \<zero>\<^bsub>R\<^esub>))"
+
+definition eval_at_point :: "('a, 'b) ring_scheme \<Rightarrow> 'a list \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> 'a" where
+"eval_at_point R as p \<equiv> total_eval R  (\<lambda>i. (if i< length as then as ! i else \<zero>\<^bsub>R\<^esub>)) p"
+
+
+lemma(in cring_coord_rings) eval_at_point_factored:
+"eval_at_point R as p = total_eval R (point_to_eval_map R as) p"
+  using eval_at_point_def by blast  
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Total Evaluation of a Polynomial\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+abbreviation(input) eval_at_poly where
+"eval_at_poly R p as \<equiv> eval_at_point R as p"
+
+
+text\<open>evaluation of coordinate polynomials\<close>
+
+context cring_coord_rings
+begin
+
+lemma eval_at_point_closed:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "eval_at_point R a p \<in> carrier R"
+proof- 
+  have 0: "R.indexed_pset ({..<n}- UNIV) (carrier R) \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    unfolding coord_ring_def 
+    by (simp add: R.Pring_car R.Pring_carrier_subset)
+  have 1 : "poly_eval R UNIV (\<lambda>i. if i < length a then a ! i else \<zero>) p \<in> R.indexed_pset ({..<n}- UNIV) (carrier R)"
+    by (smt R.Pring_car R.closed_funI R.poly_eval_closed R.zero_closed assms(1) assms(2) cartesian_power_car_memE cartesian_power_car_memE' coord_ring_def)
+  hence 2: "poly_eval R UNIV (\<lambda>i. if i < length a then a ! i else \<zero>) p \<in>carrier (R[\<X>\<^bsub>n\<^esub>])"
+    using 0 by blast 
+  show ?thesis
+    unfolding eval_at_point_def total_eval_def eval_in_ring_def  
+    using 1 R.Pring_car R.Pring_cfs_closed cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI coord_ring_def R.zero_closed 
+    by blast
+qed
+
+lemma eval_pvar:
+  assumes "i < (n::nat)"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "eval_at_point R a (pvar R i) = a!i"
+  unfolding eval_at_point_def
+proof-
+  have "pvar R i = \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> \<Otimes> i"
+    unfolding var_to_IP_def  
+    by (metis R.Pring_one coord_ring_def R.monom_add_mset R.one_mset_to_IP)    
+  then show "total_eval R (\<lambda>i. if i < length a then a ! i else \<zero>) (pvar R i) = a ! i" 
+    using assms R.total_eval_var[of "(\<lambda>i. (if i< length a then a ! i else \<zero>\<^bsub>R\<^esub>))" i ] 
+    by (smt cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI var_to_IP_def R.zero_closed)
+qed
+
+lemma eval_at_point_const:
+  assumes "k \<in> carrier R"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "eval_at_point R a (R.indexed_const k) = k"
+  unfolding eval_at_point_def
+  using assms(1) R.total_eval_const by blast
+
+lemma eval_at_point_add:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier (coord_ring R  n)"
+  shows "eval_at_point R a (A \<oplus>\<^bsub>coord_ring R  n\<^esub> B) = 
+          eval_at_point R a A \<oplus>\<^bsub>R\<^esub> eval_at_point R a B"
+  unfolding eval_at_point_def
+  using R.total_eval_add[of A "{..<n}" B] 
+  by (smt assms(1) assms(2) assms(3) cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI coord_ring_def R.zero_closed)  
+  
+lemma eval_at_point_mult:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier ((R[\<X>\<^bsub>n\<^esub>]))"
+  shows "eval_at_point R a (A \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B) = 
+          eval_at_point R a A \<otimes>\<^bsub>R\<^esub> eval_at_point R a B"
+    unfolding eval_at_point_def
+    using R.total_eval_mult[of A "{..<n}" B] 
+    by (smt assms(1) assms(2) assms(3) cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI coord_ring_def R.zero_closed)
+    
+lemma eval_at_point_indexed_pmult:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "i < n"
+  shows "eval_at_point R a (A \<Otimes> i) = 
+          eval_at_point R a A \<otimes>\<^bsub>R\<^esub> (a!i)"
+proof-
+  have "(A \<Otimes> i) = A \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar R i)"
+    using assms(2) pvar_indexed_pmult by blast
+  then show ?thesis 
+    using assms eval_at_point_mult eval_pvar pvar_closed
+    by presburger
+qed
+
+lemma eval_at_point_ring_hom:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "ring_hom_ring (coord_ring R I) R (eval_at_point R a)"
+  unfolding eval_at_point_def
+  using R.total_eval_ring_hom 
+  by (smt assms cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI coord_ring_def R.zero_closed)
+  
+lemma eval_at_point_scalar_mult:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "k \<in> carrier R"
+  shows "eval_at_point R a (poly_scalar_mult R k A) = k \<otimes>\<^bsub>R\<^esub> (eval_at_point R a A)"
+  using assms unfolding eval_at_point_def total_eval_def eval_in_ring_def
+  using  R.poly_eval_scalar_mult[of k "(\<lambda>i. if i < length a then a ! i else \<zero>)" A "{..<n}" UNIV]  
+        poly_scalar_mult_def
+  by (smt R.Pring_car cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI coord_ring_def R.zero_closed)
+
+lemma eval_at_point_smult:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "k \<in> carrier R"
+  shows "eval_at_point R a (k \<odot>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> A) = k \<otimes>\<^bsub>R\<^esub> (eval_at_point R a A)"
+  by (metis R.Pring_smult assms(1) assms(2) assms(3) coord_ring_def eval_at_point_scalar_mult)
+
+lemma eval_at_point_subtract:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier (coord_ring R  n)"
+  shows "eval_at_point R a (A \<ominus>\<^bsub>coord_ring R  n\<^esub> B) = 
+          eval_at_point R a A \<ominus>\<^bsub>R\<^esub> eval_at_point R a B"
+  using assms eval_at_point_add[of a n A "\<ominus>\<^bsub>coord_ring R  n\<^esub> B"] 
+        abelian_group.a_inv_closed[of "R[\<X>\<^bsub>n\<^esub>]" B]
+  unfolding a_minus_def 
+    abelian_group.a_inv_closed abelian_group.minus_minus abelian_group.r_neg1 abelian_groupE(1) abelian_groupE(4) coord_cring_cring cring_def eval_at_point_add eval_at_point_closed is_abelian_group ring_def 
+  by (smt MP.add.inv_closed MP.l_neg MP.r_zero MP.zero_closed R.add.inv_closed R.add.m_assoc R.l_neg R.r_zero R.zero_closed eval_at_point_add eval_at_point_closed)
+
+lemma eval_at_point_a_inv:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "B \<in> carrier (coord_ring R  n)"
+  shows "eval_at_point R a (\<ominus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B) = \<ominus>\<^bsub>R\<^esub> eval_at_point R a B"
+  using assms eval_at_point_subtract[of a n "\<zero>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>" B]
+  by (smt MP.add.inv_eq_1_iff MP.l_zero MP.minus_add MP.zero_closed R.is_abelian_group R.r_neg R.r_neg2 a_minus_def abelian_group.a_inv_closed abelian_groupE(4) eval_at_point_add eval_at_point_closed)
+
+lemma eval_at_point_nat_pow:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "eval_at_point R a (A[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>(k::nat)) = (eval_at_point R a A)[^]k"
+  apply(induction k)
+   apply (metis Group.nat_pow_0 R.Pring_one assms(1) coord_ring_def eval_at_point_const R.one_closed)   
+proof- fix k::nat assume IH: "eval_at_poly R (A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> k) a = eval_at_poly R A a [^] k"
+  have "A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Suc k = A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> k \<otimes>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> A"
+    using MP.nat_pow_Suc by blast    
+  then have "eval_at_poly R (A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Suc k) a =
+      eval_at_poly R (A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> k) a \<otimes> eval_at_poly R A a"
+    using monoid.nat_pow_closed[of "(R[\<X>\<^bsub>n\<^esub>])" A k] eval_at_point_mult[of a n "A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> k" A] assms 
+    by (metis R.Pring_is_monoid coord_ring_def)    
+  then show " eval_at_poly R (A [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Suc k) a = eval_at_poly R A a [^] Suc k"
+    using IH R.nat_pow_Suc 
+    by auto 
+qed
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Partial Evaluation of a Polynomial\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+
+definition coord_partial_eval :: 
+  "('a, 'b) ring_scheme \<Rightarrow> nat set \<Rightarrow> 'a list \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> ('a, nat) mvar_poly" where
+"coord_partial_eval R S as = poly_eval R S (point_to_eval_map R as)"
+
+context cring_coord_rings
+begin
+
+lemma point_to_eval_map_closed:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "closed_fun R (point_to_eval_map R as)"
+  using assms 
+  by (smt cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI R.zero_closed)  
+
+lemma coord_partial_eval_hom:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "coord_partial_eval R S as \<in> ring_hom (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>n\<^esub>])"
+  unfolding coord_partial_eval_def 
+  using point_to_eval_map_closed[of as n] assms 
+        R.poly_eval_ring_hom[of "{..<n}" "{..<n}" "point_to_eval_map R as" S]
+  by (metis (mono_tags, lifting) Diff_subset coord_ring_def order_refl ring_hom_ring.homh)  
+
+lemma coord_partial_eval_hom':
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "coord_partial_eval R S as \<in> ring_hom (R[\<X>\<^bsub>n\<^esub>]) (Pring R ({..<n} - S))"
+  unfolding coord_partial_eval_def 
+  using point_to_eval_map_closed[of as n] assms 
+        R.poly_eval_ring_hom[of "{..<n} - S" "{..<n}" "point_to_eval_map R as" S]
+  by (metis (no_types, lifting) Diff_subset coord_ring_def order_refl ring_hom_ring.homh)  
+
+lemma coord_partial_eval_closed:
+  assumes "S \<subseteq> {..<n}"
+  assumes "{..<n} - S \<subseteq> I"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "coord_partial_eval R S as p \<in> carrier (Pring R I)"
+  unfolding coord_partial_eval_def
+  using R.poly_eval_closed[of "point_to_eval_map R as" p "{..<n}" S ] R.Pring_car[of I] R.Pring_carrier_subset  
+  by (smt R.Pring_car assms(2) assms(3) assms(4) cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI coord_ring_def subsetD R.zero_closed)  
+
+lemma coord_partial_eval_add:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "coord_partial_eval R S as  (p \<oplus>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> Q) =  
+          (coord_partial_eval R S as  p) \<oplus>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> (coord_partial_eval R S as  Q)"
+  using assms R.poly_eval_add[of p "{..<n}" Q "(point_to_eval_map R as)" S] Pring_def[of R "{..<n}"]      
+  point_to_eval_map_closed[of as n] 
+  unfolding coord_partial_eval_def 
+  by (metis R.Pring_add R.Pring_car coord_ring_def)  
+
+lemma coord_partial_eval_mult:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "coord_partial_eval R S as  (p \<otimes>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> Q) =  
+          (coord_partial_eval R S as  p) \<otimes>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> (coord_partial_eval R S as  Q)"
+  using assms R.poly_eval_mult[of p "{..<n}" Q "(point_to_eval_map R as)" S] Pring_def[of R "{..<n}"]      
+  point_to_eval_map_closed[of as n] 
+  unfolding coord_partial_eval_def 
+  by (metis R.Pring_car R.Pring_mult coord_ring_def)  
+
+lemma coord_partial_eval_pvar:
+  assumes "\<one> \<noteq> \<zero>"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "i \<in> S \<inter> {..<n}"
+  shows "coord_partial_eval R S as (pvar R i) = coord_const (as!i)"
+proof-
+  have 0: "i \<in> S" using assms 
+    by blast
+  have "i < length as" 
+    by (metis IntD2 assms(2) assms(3) cartesian_power_car_memE lessThan_iff)
+  then have "(point_to_eval_map R as i) = as!i"
+    by presburger  
+  then show ?thesis 
+    unfolding coord_partial_eval_def var_to_IP_def  
+    using 0 assms point_to_eval_map_closed[of as n] 
+        R.poly_eval_index[of "point_to_eval_map R as" S i ]
+    by presburger
+qed
+
+lemma coord_partial_eval_pvar':
+  assumes "\<one> \<noteq> \<zero>"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "i \<notin> S"
+  shows "coord_partial_eval R S as (pvar R i) = (pvar R i)"
+  unfolding coord_partial_eval_def
+  using R.poly_eval_index[of "point_to_eval_map R as" S i ]
+  by (smt assms(1) assms(2) assms(3) cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI var_to_IP_def R.zero_closed)  
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>An induction rule for coordinate rings\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma coord_ring_induct:
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "\<And>a. a \<in> carrier R \<Longrightarrow> p (coord_const a)"
+  assumes "\<And>i Q. Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> p Q \<Longrightarrow>  i < n \<Longrightarrow> p (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>pvar R i)"
+  assumes "\<And>Q0 Q1. Q0 \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> Q1 \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> p Q0 \<Longrightarrow> p Q1 \<Longrightarrow> p (Q0 \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q1)"
+  shows "p A"
+  apply(rule R.indexed_pset.induct[of A "{..<n}" "carrier R"])
+  using R.Pring_car assms(1) 
+  apply (metis coord_ring_def) 
+  using assms(2) apply blast
+  apply (metis (full_types) R.Pring_add R.Pring_car assms(4) coord_ring_def) 
+proof-
+  fix a i
+  assume "a \<in> Pring_set R {..<n}"
+  then have 0: "a \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    using R.Pring_car 
+    by (simp add: \<open>\<And>I. carrier (Pring R I) = Pring_set R I\<close> \<open>a \<in> Pring_set R {..<n}\<close> coord_ring_def)
+  assume 1: "p a"
+  assume "i \<in> {..< n}"
+  then have 2: "i < n"
+    using assms 
+    by blast 
+  have "p (a \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>pvar R i)"
+    using "0" "1" "2" assms(3) by blast
+  then show "p (a \<Otimes> i)"
+    using "0" pvar_indexed_pmult 
+    by presburger
+qed
+  
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Algebraic Sets in Cartesian Powers\<close>  
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsubsection\<open>The Zero Set of a Single Polynomial\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+definition zero_set  :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> 'a list set"
+ ("V\<index>") where
+"zero_set R n p =  {a \<in> carrier (R\<^bsup>n\<^esup>). eval_at_point R a p =\<zero>\<^bsub>R\<^esub>}"
+
+context cring_coord_rings
+begin 
+
+lemma zero_setI:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "eval_at_point R a p =\<zero>\<^bsub>R\<^esub>"
+  shows  "a \<in> zero_set R n p"
+  using assms 
+  by (metis (mono_tags, lifting) mem_Collect_eq zero_set_def)
+
+lemma zero_setE:
+  assumes  "a \<in> zero_set R n p"
+  shows  "a \<in> carrier (R\<^bsup>n\<^esup>)"
+         "eval_at_point R a p =\<zero>\<^bsub>R\<^esub>"
+  using assms zero_set_def 
+  apply blast
+  by (metis (mono_tags, lifting) assms mem_Collect_eq zero_set_def)
+
+lemma zero_set_closed:
+ "zero_set R n p \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+unfolding zero_set_def 
+  by blast
+
+end
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsubsection\<open>The Zero Set of a Collection of Polynomials\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+definition affine_alg_set :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a, nat) mvar_poly set \<Rightarrow> 'a list set"
+  where "affine_alg_set R n as = {a \<in> carrier (R\<^bsup>n\<^esup>). \<forall> b \<in> as. a \<in> (zero_set R n b)}"
+
+context cring_coord_rings
+begin 
+
+lemma affine_alg_set_empty:
+"affine_alg_set R n {} = carrier (R\<^bsup>n\<^esup>)"
+  unfolding affine_alg_set_def by blast 
+
+lemma affine_alg_set_subset_zero_set:
+  assumes "b \<in> as"
+  shows " affine_alg_set R n as \<subseteq> (zero_set R n b)"
+  using assms affine_alg_set_def 
+  by blast
+
+lemma(in cring_coord_rings) affine_alg_set_memE:
+  assumes "b \<in> as"
+  assumes "a \<in>  affine_alg_set R n as"
+  shows "eval_at_poly R b a = \<zero>"
+  using affine_alg_set_subset_zero_set zero_set_def assms(1) assms(2) 
+  by blast
+
+lemma affine_alg_set_subset:
+  assumes "as \<subseteq> bs"
+  shows " affine_alg_set R n bs \<subseteq> affine_alg_set R n as "
+  using assms affine_alg_set_def 
+  by blast
+
+lemma affine_alg_set_empty_set:
+  assumes "as = {}"
+  shows " affine_alg_set R n as = carrier (R\<^bsup>n\<^esup>)"
+  unfolding affine_alg_set_def 
+  using assms by blast
+
+lemma affine_alg_set_closed: 
+  shows "affine_alg_set R n as \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  unfolding affine_alg_set_def 
+  by blast 
+
+lemma affine_alg_set_singleton:
+"affine_alg_set R n {a} = zero_set R n a"
+  unfolding affine_alg_set_def using zero_set_closed  
+  by blast
+
+lemma affine_alg_set_insert:
+"affine_alg_set R n (insert a A) = zero_set R n a \<inter> (affine_alg_set R n A)"
+proof
+  show "affine_alg_set R n (insert a A) \<subseteq> V\<^bsub>R\<^esub> n a \<inter> affine_alg_set R n A"
+    using affine_alg_set_subset 
+    by (metis Int_greatest affine_alg_set_subset_zero_set insertI1 subset_insertI)
+  show "V\<^bsub>R\<^esub> n a \<inter> affine_alg_set R n A \<subseteq> affine_alg_set R n (insert a A)"
+    unfolding affine_alg_set_def 
+    by blast
+qed
+
+lemma affine_alg_set_intersect:
+"affine_alg_set R n (A \<union> B) = (affine_alg_set R n A) \<inter> (affine_alg_set R n B)"
+  unfolding affine_alg_set_def by blast 
+
+lemma affine_alg_set_memI:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "\<And>p. p \<in> B \<Longrightarrow> eval_at_point R a p = \<zero>"
+  shows "a \<in> (affine_alg_set R n B)"
+  unfolding affine_alg_set_def zero_set_def 
+  using assms 
+  by blast
+
+lemma affine_alg_set_not_memE:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "a \<notin> (affine_alg_set R n B)"
+  shows "\<exists>b \<in> B. eval_at_poly R b a \<noteq> \<zero>"
+  using assms affine_alg_set_memI by blast
+
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsubsection\<open>Finite Unions and Intersections of Algebraic Sets are Algebraic\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+text\<open>The product set of two sets in an arbitrary ring. That is, the set $\{ xy \mid x \in A \land y \in B \}$ for two sets $A$, $B$.\<close>
+definition(in ring) prod_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
+"prod_set as bs = (\<lambda>x. fst x \<otimes> snd x) ` (as \<times> bs)"
+
+lemma(in ring) prod_setI:
+  assumes "c \<in> prod_set as bs"
+  shows "\<exists>a \<in> as. \<exists>b \<in> bs. c = a \<otimes> b"
+proof-
+  obtain p where p_def: "p \<in> (as \<times> bs) \<and> c = fst p \<otimes> snd p" 
+    using assms prod_set_def[of as bs] 
+    by (metis (no_types, lifting) image_iff)
+  then show ?thesis 
+    using mem_Times_iff by blast
+qed
+
+lemma(in ring) prod_set_closed:
+  assumes "as \<subseteq> carrier R"
+  assumes "bs \<subseteq> carrier R"
+  shows "prod_set as bs \<subseteq> carrier R"
+proof
+  fix x
+  assume " x \<in> prod_set as bs"
+  then obtain a b where "a \<in> as \<and> b \<in> bs \<and> x = a \<otimes> b"
+    by (meson ring_axioms ring.prod_setI)
+  then have "a \<in> carrier R \<and> b \<in> carrier R \<and> x = a \<otimes> b"
+    using assms 
+    by blast 
+  then show "x \<in> carrier R"
+    by blast
+qed
+
+text\<open>The set of products of elements from two finite sets is again finite.\<close>
+lemma(in ring) prod_set_finite:
+  assumes "finite as"
+  assumes "finite bs"
+  shows "finite (prod_set as bs)" "card (prod_set as bs) \<le> card as * card bs"
+proof-
+  have "finite (as \<times> bs)"
+    using assms 
+    by blast
+  then show "finite (prod_set as bs)" 
+    using  prod_set_def 
+    by (metis (no_types, lifting) finite_imageI)
+  have "card (prod_set as bs) \<le> card (as \<times> bs)"
+    using assms 
+    unfolding prod_set_def 
+    using \<open>finite (as \<times> bs)\<close> card_image_le by blast
+  then show "card (prod_set as bs) \<le> card as * card bs"
+    by (simp add: card_cartesian_product)
+qed
+
+definition poly_prod_set where
+"poly_prod_set n as bs = ring.prod_set (R[\<X>\<^bsub>n\<^esub>]) as bs"
+
+lemma poly_prod_setE:
+  assumes "c \<in> poly_prod_set n as bs"
+  shows "\<exists>a \<in> as. \<exists>b \<in> bs. c = a \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> b"
+  using ring.prod_setI[of "R[\<X>\<^bsub>n\<^esub>]"] R.Pring_is_ring assms poly_prod_set_def coord_cring_cring cring.axioms(1) 
+  by blast
+  
+lemma poly_prod_setI:
+  assumes "a \<in> as"
+  assumes "b \<in> bs"
+  shows "a \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> b \<in> poly_prod_set n as bs"
+proof-
+  have 0: "(a,b) \<in> (as \<times> bs)"
+    using assms by blast 
+  have 1: "(\<lambda>x. fst x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> snd x) (a, b) = a \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> b"
+    by (metis fst_conv snd_conv)    
+  have 2: "(\<lambda>x. fst x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> snd x) (a, b) \<in> ((\<lambda>x. fst x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> snd x) ` (as \<times> bs))"
+    using 0  by blast 
+  have 3: "ring (R[\<X>\<^bsub>n\<^esub>])"
+    by (simp add: R.Pring_is_ring coord_ring_def)    
+  then show ?thesis
+    unfolding poly_prod_set_def using 0 1 2 3 ring.prod_set_def[of "R[\<X>\<^bsub>n\<^esub>]" as bs]  
+    by presburger
+qed
+
+lemma poly_prod_set_closed:
+  assumes "as \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "bs \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "poly_prod_set n as bs \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  using ring.prod_set_closed[of "R[\<X>\<^bsub>n\<^esub>]"]  R.Pring_is_ring assms(1) assms(2) poly_prod_set_def 
+  by (simp add: coord_cring_cring cring.axioms(1))  
+
+lemma poly_prod_set_finite:
+  assumes "finite as"
+  assumes "finite bs"
+  shows "finite (poly_prod_set n as bs)" "card (poly_prod_set n as bs) \<le> card as * card bs"
+ 
+  using ring.prod_set_finite[of "R[\<X>\<^bsub>n\<^esub>]"]
+  apply (simp add: R.Pring_is_ring assms(1) assms(2) poly_prod_set_def)
+  using ring.prod_set_finite[of "R[\<X>\<^bsub>n\<^esub>]"]
+  apply (simp add: assms(1) assms(2) coord_cring_cring cring.axioms(1))
+  by (simp add: assms(1) assms(2) coord_cring_cring cring.axioms(1) poly_prod_set_def ring.prod_set_finite(2))
+
+end 
+
+locale domain_coord_rings = cring_coord_rings + domain
+
+lemma(in domain_coord_rings) poly_prod_set_algebraic_set:
+  assumes "as \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "bs \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "affine_alg_set R n as \<union> affine_alg_set R n bs = affine_alg_set R n (poly_prod_set n as bs)"
+proof
+  show "affine_alg_set R n as \<union> affine_alg_set R n bs \<subseteq> affine_alg_set R n (poly_prod_set n as bs)"
+  proof fix x
+    assume A: "x \<in> affine_alg_set R n as \<union> affine_alg_set R n bs"
+    show "x \<in> affine_alg_set R n (poly_prod_set n as bs)"
+    proof(rule affine_alg_set_memI)
+      show "x \<in> carrier (R\<^bsup>n\<^esup>)"
+        using A affine_alg_set_closed 
+        by blast
+      show "\<And>p. p \<in> poly_prod_set n as bs \<Longrightarrow> eval_at_poly R p x = \<zero>"
+      proof- fix p
+        assume B: "p \<in> poly_prod_set n as bs"
+        show "eval_at_poly R p x = \<zero>"
+        proof-
+          obtain p0 p1 where C: "p0 \<in> as \<and> p1 \<in> bs \<and> p = p0 \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> p1"
+            using B poly_prod_setE by blast
+          then have D: "eval_at_poly R p x = (eval_at_poly R p0 x) \<otimes> (eval_at_poly R p1 x)"
+            using \<open>x \<in> carrier (R\<^bsup>n\<^esup>)\<close> assms(1) assms(2) eval_at_point_mult 
+            by blast 
+          show ?thesis proof(cases "x \<in> affine_alg_set R n as")
+            case True
+            then have "(eval_at_poly R p0 x) = \<zero>"
+              using C  affine_alg_set_memE by blast              
+            then show ?thesis 
+              by (smt C D \<open>x \<in> carrier (R\<^bsup>n\<^esup>)\<close> assms(2) eval_at_point_closed R.semiring_axioms semiring.l_null subsetD)            
+          next
+            case False
+            then have "x \<in> affine_alg_set R n bs"
+              using A 
+              by blast
+            then have "(eval_at_poly R p1 x) = \<zero>"
+              using C affine_alg_set_memE by blast
+            then show ?thesis 
+              using C A False 
+              by (smt D \<open>x \<in> carrier (R\<^bsup>n\<^esup>)\<close> assms(1) eval_at_point_closed R.r_null subsetD)
+          qed 
+        qed
+      qed
+    qed
+  qed  
+  show "affine_alg_set R n (poly_prod_set n as bs) \<subseteq> affine_alg_set R n as \<union> affine_alg_set R n bs"
+  proof fix x 
+    assume A: "x \<in> affine_alg_set R n (poly_prod_set n as bs)"
+    have x_car: "x \<in> carrier (R\<^bsup>n\<^esup>)"
+      using A affine_alg_set_closed 
+      by blast
+    show "x \<in> affine_alg_set R n as \<union> affine_alg_set R n bs"
+    proof(cases "x \<in> affine_alg_set R n as")
+      case True
+      then show ?thesis by blast 
+    next
+      case False
+      have "x \<in> affine_alg_set R n bs"
+      proof(rule affine_alg_set_memI)
+        show "x \<in> carrier (R\<^bsup>n\<^esup>)"
+          using A affine_alg_set_closed by blast
+        show "\<And>p. p \<in> bs \<Longrightarrow> eval_at_poly R p x = \<zero>"
+        proof-
+          fix p assume p_def: "p \<in> bs"
+          obtain a where a_def: "a \<in> as \<and> eval_at_poly R a x \<noteq> \<zero>"
+            using False affine_alg_set_not_memE  \<open>x \<in> carrier (R\<^bsup>n\<^esup>)\<close> 
+            by blast
+          then have "a \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> p \<in> (poly_prod_set n as bs)"
+            using poly_prod_setI[of a as p bs] p_def 
+            by blast
+          then have "eval_at_poly R (a \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> p) x = \<zero>"
+            using A affine_alg_set_memE 
+            by blast
+         
+          then have "eval_at_poly R a x \<otimes> eval_at_poly R p  x = \<zero>"
+            using eval_at_point_mult[of x n a p]
+            by (metis (no_types, lifting) \<open>x \<in> carrier (R\<^bsup>n\<^esup>)\<close> a_def assms(1) assms(2) p_def subsetD)
+          then show "eval_at_poly R p  x  = \<zero>"
+            using a_def p_def 
+            by (meson assms(1) assms(2) eval_at_point_closed integral_iff subsetD x_car)            
+        qed
+      qed
+      then show ?thesis 
+        by blast
+    qed
+  qed
+qed
+      
+definition is_algebraic :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> 'a list set \<Rightarrow> bool" where
+"is_algebraic R n S = (\<exists>ps. finite ps \<and> ps \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>]) \<and> S = affine_alg_set R n ps)"
+
+context cring_coord_rings
+begin 
+
+lemma is_algebraicE:
+  assumes "is_algebraic R n S"
+  obtains ps where  "finite ps" "ps \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])" "S = affine_alg_set R n ps"
+  using assms 
+  by (meson is_algebraic_def)
+
+lemma is_algebraicI:
+  assumes "finite ps"
+  assumes "ps \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "S = affine_alg_set R n ps"
+  shows "is_algebraic R n S"
+  using is_algebraic_def assms 
+  by blast
+
+lemma is_algebraicI':
+  assumes "p \<in>  carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "S = zero_set R n p"
+  shows "is_algebraic R n S"
+  by (metis affine_alg_set_singleton assms(1) assms(2) empty_subsetI finite.emptyI finite.intros(2) insert_subset is_algebraic_def)
+
+end
+
+definition alg_sets :: "arity \<Rightarrow> ('a, 'b) ring_scheme \<Rightarrow> ('a list set) set" where
+"alg_sets n R = {S. is_algebraic R n S}"
+
+context cring_coord_rings
+begin 
+
+lemma intersection_is_alg:
+  assumes "is_algebraic R n A"
+  assumes "is_algebraic R n B"
+  shows "is_algebraic R n (A \<inter> B)"
+proof-
+  obtain as where as_def: "finite as \<and> as \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>]) \<and> A = affine_alg_set R n as"
+    by (meson assms(1) is_algebraicE)
+  obtain bs where bs_def: "finite bs \<and> bs \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>]) \<and> B = affine_alg_set R n bs"
+    by (meson assms(2) is_algebraicE)
+  show ?thesis apply(rule is_algebraicI[of "as \<union> bs"])
+    using as_def bs_def apply blast
+    using as_def bs_def apply blast
+    by (simp add: affine_alg_set_intersect as_def bs_def)
+qed
+
+lemma(in domain_coord_rings) union_is_alg:
+  assumes "is_algebraic R n A"
+  assumes "is_algebraic R n B"
+  shows "is_algebraic R n (A \<union> B)"
+proof-
+  obtain as where as_def: "finite as \<and> as \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>]) \<and> A = affine_alg_set R n as"
+    by (meson assms(1) is_algebraicE)
+  obtain bs where bs_def: "finite bs \<and> bs \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>]) \<and> B = affine_alg_set R n bs"
+    by (meson assms(2) is_algebraicE)
+  show ?thesis apply(rule is_algebraicI[of "poly_prod_set n as bs"])
+    using as_def bs_def 
+    apply (simp add: poly_prod_set_finite(1))
+    using as_def bs_def poly_prod_set_closed apply blast
+        using as_def bs_def poly_prod_set_algebraic_set 
+        by simp
+qed
+
+lemma zero_set_zero:
+"zero_set R n \<zero>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> = carrier (R\<^bsup>n\<^esup>)"
+  by (metis R.add.r_cancel_one cring.cring_simprules(2) cring.cring_simprules(8) 
+      coord_cring_cring cring_coord_rings.eval_at_point_add cring_coord_rings.eval_at_point_closed 
+      cring_coord_rings_axioms subsetI subset_antisym zero_setI zero_set_closed)
+  
+lemma affine_alg_set_set:
+"affine_alg_set  R n {\<zero>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>} = carrier (R\<^bsup>n\<^esup>)"
+using affine_alg_set_singleton zero_set_zero 
+by blast
+
+lemma car_is_alg:
+"is_algebraic R n (carrier (R\<^bsup>n\<^esup>))"
+  apply(rule is_algebraicI[of "{\<zero>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>}"])
+  apply blast
+  using R.Pring_zero_closed  
+   apply blast
+    using affine_alg_set_set by blast
+
+lemma zero_set_nonzero_constant:
+  assumes "a \<noteq> \<zero>"
+  assumes "a \<in> carrier R"
+  shows "zero_set R n (coord_const a) = {}"
+proof(rule ccontr)
+  assume "V n (coord_const a) \<noteq> {}"
+  then obtain x where "x \<in> V n (coord_const a)"
+    by blast 
+  then show False
+    by (metis assms(1) assms(2) cring_coord_rings.eval_at_point_const cring_coord_rings.zero_setE(1) cring_coord_rings.zero_setE(2) cring_coord_rings_axioms)    
+qed  
+
+lemma zero_set_one:
+  assumes "a \<noteq> \<zero>"
+  assumes "a \<in> carrier R"
+  shows "zero_set R n \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> = {}"
+  using zero_set_nonzero_constant
+  by (metis R.Pring_one coord_ring_def one_neq_zero R.one_closed)  
+
+lemma empty_set_as_affine_alg_set:
+"affine_alg_set  R n {\<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>} = {}"
+  using affine_alg_set_singleton local.one_neq_zero zero_set_one by blast
+
+lemma empty_is_alg:
+"is_algebraic R n {}"
+  apply(rule is_algebraicI'[of "\<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>"])
+  apply blast  
+  using local.one_neq_zero zero_set_one by blast
+  
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsubsection\<open>Finite Sets Are Algebraic\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+text\<open>the function mapping a point in $R^n$ to the unique linear polynomial vanishing exclusively at that point\<close>
+
+definition pvar_trans ::  "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> ('a, nat) mvar_poly" where
+"pvar_trans n i a = (pvar R i) \<ominus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> coord_const a"
+
+lemma pvar_trans_closed:
+  assumes "a \<in> carrier R"
+  assumes "i < n"
+  shows "pvar_trans n i a \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  unfolding pvar_trans_def using assms 
+  by (metis MP.minus_closed coord_ring_def R.indexed_const_closed local.pvar_closed)
+  
+lemma pvar_trans_eval:
+  assumes "a \<in> carrier R"
+  assumes "b \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "i < n"
+  shows "eval_at_point R b (pvar_trans n i a) = (b!i) \<ominus> a"
+proof-
+  have "eval_at_point R b (pvar_trans n i a) = 
+        (eval_at_point R b (pvar R i)) \<oplus> (eval_at_point R b (\<ominus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (coord_const a)))"
+  unfolding pvar_trans_def a_minus_def using assms 
+  by (metis MP.add.inv_closed coord_ring_def eval_at_point_add R.indexed_const_closed local.pvar_closed)
+ 
+  then show ?thesis
+    by (metis a_minus_def assms(1) assms(2) assms(3) coord_ring_def eval_at_point_a_inv eval_at_point_const eval_pvar R.indexed_const_closed)
+qed
+  
+definition point_to_polys :: "'a list \<Rightarrow> ('a, nat) mvar_poly list" where
+"point_to_polys as = map (\<lambda> x. pvar_trans (length as) (snd x) (fst x)) (zip as (index_list (length as)))"
+
+lemma point_to_polys_length: 
+"length (point_to_polys as) = length as"
+  unfolding point_to_polys_def 
+  by (smt index_list_length length_map list.map_ident map_eq_imp_length_eq zip_eq_conv)
+  
+lemma point_to_polysE: 
+  assumes "i < length as"
+  shows "(point_to_polys as) ! i = (pvar_trans (length as) i (as ! i))"
+proof- 
+  have " (zip as (index_list (length as)))!i =  ((as!i), i)"
+    by (metis assms index_list_indices index_list_length nth_zip)    
+  then  have 0: "(point_to_polys as) ! i = (\<lambda> x. pvar_trans (length as) (snd x) (fst x)) ((as!i), i)"
+    unfolding point_to_polys_def
+    using  assms nth_map[of i "(zip as (index_list (length as)))" "(\<lambda>x. pvar_trans (length as) (snd x) (fst x))" ]
+    by (metis index_list_length length_map map_fst_zip)
+  then show ?thesis 
+    by (metis fst_conv snd_conv)
+qed
+
+lemma point_to_polysE': 
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "i < n"
+  shows "eval_at_point R as ((point_to_polys as) ! i) = \<zero>"
+  by (metis assms(1) assms(2) cartesian_power_car_memE cartesian_power_car_memE' point_to_polysE pvar_trans_eval R.r_right_minus_eq)
+
+lemma point_to_polysE'': 
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "b \<in> set (point_to_polys as)"
+  shows "eval_at_point R as b = \<zero>"
+  using point_to_polysE' 
+  by (metis assms(1) assms(2) cartesian_power_car_memE in_set_conv_nth point_to_polys_length)
+
+lemma point_to_polys_zero_set: 
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "b \<in> set (point_to_polys as)"
+  shows "as \<in> zero_set R n b"
+  using assms(1) assms(2) point_to_polysE'' zero_setI by blast
+
+lemma point_to_polys_closed:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "set (point_to_polys as) \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  using assms point_to_polysE pvar_trans_closed 
+  by (smt cartesian_power_car_memE cartesian_power_car_memE' in_set_conv_nth point_to_polys_length subsetI)  
+
+lemma point_to_polys_affine_alg_set:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "affine_alg_set R n (set (point_to_polys as)) = {as}"
+proof
+  show "affine_alg_set R n (set (point_to_polys as)) \<subseteq> {as}"
+  proof
+    fix x
+    assume A0: "x \<in> affine_alg_set R n (set (point_to_polys as))"
+    then have 0: "length x = n" using affine_alg_set_closed[of  n " (set (point_to_polys as))"]
+      using cartesian_power_car_memE by blast
+    have "\<And>i. i < n \<Longrightarrow> x!i = as!i"
+    proof-
+      fix i
+      assume A1: "i < n"
+      show " x!i = as!i"
+        using A0 
+        by (smt A1 affine_alg_set_closed affine_alg_set_memE assms cartesian_power_car_memE 
+            cartesian_power_car_memE' nth_mem point_to_polysE point_to_polys_length
+            pvar_trans_eval R.r_right_minus_eq subsetD)
+    qed
+    then have "x = as"
+      by (metis "0" assms cartesian_power_car_memE nth_equalityI)
+    then show "x \<in> {as}"
+      by blast
+  qed
+  show "{as} \<subseteq> affine_alg_set R n (set (point_to_polys as))"
+  proof-
+    have "as \<in>  affine_alg_set R n (set (point_to_polys as))"
+      using affine_alg_set_not_memE assms point_to_polysE'' 
+      by blast
+    then show ?thesis 
+      by blast
+  qed
+qed
+
+lemma singleton_is_algebraic:
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "is_algebraic R n {as}"
+  apply(rule is_algebraicI[of "(set (point_to_polys as))"])
+  apply blast
+  using point_to_polys_affine_alg_set
+  using assms point_to_polys_closed apply blast
+  by (simp add: assms point_to_polys_affine_alg_set)
+
+lemma(in domain_coord_rings) finite_sets_are_algebraic:
+  assumes "finite F"
+  shows "F \<subseteq> carrier (R\<^bsup>n\<^esup>) \<longrightarrow> is_algebraic R n F"
+  apply(rule finite.induct) 
+  apply (simp add: assms) 
+  using empty_is_alg apply blast
+  using singleton_is_algebraic 
+  by (metis union_is_alg insert_is_Un insert_subset)
+
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Polynomial Maps\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsection\<open>The Action of Index Permutations on Polynomials\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+
+definition permute_poly_args :: 
+  "nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> ('a, nat) mvar_poly" where
+"permute_poly_args (n::nat) \<sigma> p = indexed_poly_induced_morphism {..<n} (R[\<X>\<^bsub>n\<^esub>]) coord_const (\<lambda>i. pvar R (\<sigma> i)) p" 
+
+lemma permute_poly_args_characterization:
+  assumes "\<sigma> permutes {..< n}"
+  shows "(ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>n\<^esub>]) (permute_poly_args (n::nat) \<sigma>))"
+        "(\<forall>i \<in> {..<n}. (permute_poly_args (n::nat) \<sigma>) (pvar R i) =  pvar R (\<sigma> i))"
+        "(\<forall>a \<in> carrier R. permute_poly_args (n::nat) \<sigma> (coord_const a) = (coord_const a))"
+proof-
+  have 0: "cring (R[\<X>\<^bsub>n\<^esub>])"
+    by (simp add: MP.is_cring)
+  have 1: "(\<lambda>i. pvar R (\<sigma> i)) \<in> {..<n} \<rightarrow> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  proof
+    fix x
+    assume A: "x \<in> {..<n}"
+    then have 0: "\<sigma> x \<in> {..<n}"
+      using assms 
+      by (meson permutes_in_image)
+    then have "\<sigma> x < n"
+      using assms 
+      by auto
+    then  show "pvar R (\<sigma> x) \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) "
+      using  pvar_closed[of "\<sigma> x" n]
+      by blast
+  qed
+  have 2: " ring_hom_ring R (R[\<X>\<^bsub>n\<^esub>]) coord_const"
+    using R.indexed_const_ring_hom unfolding coord_ring_def 
+    by blast    
+  have 3: "  indexed_poly_induced_morphism {..<n} (R[\<X>\<^bsub>n\<^esub>]) coord_const (\<lambda>i. pvar R (\<sigma> i)) =
+    indexed_poly_induced_morphism {..<n} (R[\<X>\<^bsub>n\<^esub>]) coord_const (\<lambda>i. pvar R (\<sigma> i))"
+    by blast   
+  show "ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>n\<^esub>]) (permute_poly_args n \<sigma>)"
+    using 0 1 2 3
+        R.Pring_universal_prop[of "(R[\<X>\<^bsub>n\<^esub>])" " (\<lambda>i. pvar R (\<sigma> i))" "{..<n}" coord_const "permute_poly_args (n::nat) \<sigma>" ]
+    unfolding permute_poly_args_def 
+    by (metis coord_ring_def)  
+  show "\<forall>i\<in>{..<n}. permute_poly_args n \<sigma> (pvar R i) = pvar R (\<sigma> i)"
+    using 0 1 2 3
+        R.Pring_universal_prop(2)[of "(R[\<X>\<^bsub>n\<^esub>])" " (\<lambda>i. pvar R (\<sigma> i))" "{..<n}" coord_const "permute_poly_args (n::nat) \<sigma>" ]
+    unfolding permute_poly_args_def var_to_IP_def
+    by blast
+  show "\<forall>a\<in>carrier R. permute_poly_args n \<sigma> (coord_const a) = coord_const a"
+    using 0 1 2 3 
+        R.Pring_universal_prop[of "(R[\<X>\<^bsub>n\<^esub>])" " (\<lambda>i. pvar R (\<sigma> i))" "{..<n}" coord_const "permute_poly_args (n::nat) \<sigma>" ]
+    unfolding permute_poly_args_def var_to_IP_def
+    by blast 
+qed
+
+lemma permute_poly_args_closed:
+  assumes "\<sigma> permutes {..<n}"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "permute_poly_args n \<sigma> p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+proof-
+  have "(ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>n\<^esub>]) (permute_poly_args (n::nat) \<sigma>))"
+    using assms permute_poly_args_characterization(1) 
+    by blast
+  then have "(permute_poly_args (n::nat) \<sigma>) \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<rightarrow> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    unfolding ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def
+    by blast
+  then show ?thesis
+    using assms  
+    by blast
+qed
+
+
+lemma permute_poly_args_constant:
+  assumes "a \<in> carrier R"
+  assumes "\<sigma> permutes {..<n}"
+  shows "permute_poly_args n \<sigma> (coord_const a) = (coord_const a)"
+  using assms permute_poly_args_characterization(3) 
+  by blast
+
+lemma permute_poly_args_add:
+  assumes "\<sigma> permutes {..<n}"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "permute_poly_args n \<sigma> (p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> q) = (permute_poly_args n \<sigma> p) \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (permute_poly_args n \<sigma> q)"
+  using permute_poly_args_characterization(1)[of  \<sigma>] assms
+  unfolding ring_hom_ring_def ring_hom_ring_axioms_def
+  by (metis (no_types, lifting) ring_hom_add)
+  
+lemma permute_poly_args_mult:
+  assumes "\<sigma> permutes {..<n}"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "permute_poly_args n \<sigma> (p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> q) = (permute_poly_args n \<sigma> p) \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (permute_poly_args n \<sigma> q)"
+  using permute_poly_args_characterization(1)[of  \<sigma>] assms
+  unfolding ring_hom_ring_def ring_hom_ring_axioms_def
+  using ring_hom_mult 
+  by (metis (mono_tags, lifting))
+  
+lemma permute_poly_args_indexed_pmult:
+  assumes "\<sigma> permutes {..<n}"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "i \<in> {..<n}"
+  shows "(permute_poly_args n \<sigma> (p \<Otimes> i)) = (permute_poly_args n \<sigma> p) \<Otimes> (\<sigma> i)"
+proof
+  fix x
+  show "permute_poly_args n \<sigma> (p \<Otimes> i) x = (permute_poly_args n \<sigma> p \<Otimes> \<sigma> i) x"
+  proof-
+    have 0: "(p \<Otimes> i) = (p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i)"
+      using assms  pvar_indexed_pmult 
+      by blast
+    have 1: "(permute_poly_args n \<sigma> p) \<Otimes> (\<sigma> i) = (permute_poly_args n \<sigma> p) \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R (\<sigma> i)"
+      using assms permute_poly_args_closed pvar_indexed_pmult by blast
+    have 2: "permute_poly_args n \<sigma> (p \<Otimes> i) x = permute_poly_args n \<sigma> (p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) x"
+      using \<open>p \<Otimes> i = p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i\<close> by presburger
+    then show ?thesis using 1 R.Pring_var_closed assms(1) assms(2) assms(3) assms 
+          permute_poly_args_mult R.is_cring permute_poly_args_characterization(2) R.zero_closed
+      by (metis coord_ring_def)
+  qed
+qed
+
+lemma permute_list_closed:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "\<sigma> permutes {..<n}"
+  shows "(permute_list \<sigma> a)  \<in> carrier (R\<^bsup>n\<^esup>)"
+  apply(rule cartesian_power_car_memI)
+  using assms cartesian_power_car_memE length_permute_list apply blast
+proof-
+  have 0: "set a \<subseteq> carrier R"
+    using assms(1) cartesian_power_car_memE'' by blast
+  have "\<sigma> permutes {..<length a}"
+  proof-
+    have 0: "length a = n"
+      using assms cartesian_power_car_memE by blast
+    have "{..<n} = {..<length a}"
+      using 0 by blast  
+    then show ?thesis 
+      using assms by presburger
+  qed
+  have  1: "set (permute_list \<sigma> a) = set a"
+    using assms set_permute_list[of \<sigma> a] \<open>\<sigma> permutes {..<length a}\<close>
+    by blast
+  then show "set (permute_list \<sigma> a) \<subseteq> carrier R" 
+    by (simp add: "1" "0")
+qed
+
+lemma permute_list_set:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "\<sigma> permutes {..<n}"
+  shows "set (permute_list \<sigma> a) = set a"
+proof-
+  have "\<sigma> permutes {..<length a}"
+  proof-
+    have 0: "length a = n"
+      using assms cartesian_power_car_memE by blast
+    have "{..<n} = {..<length a}"
+      using 0 by blast 
+    then show ?thesis 
+      using assms by presburger
+  qed
+  then show  1: "set (permute_list \<sigma> a) = set a"
+    using assms set_permute_list[of \<sigma> a] 
+    by blast
+qed  
+
+end 
+
+definition perm_map :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+"perm_map R n \<sigma> = restrict (permute_list \<sigma>) (carrier (R\<^bsup>n\<^esup>))"
+
+context cring_coord_rings
+begin
+
+lemma perm_map_is_struct_map:
+  assumes "\<sigma> permutes {..<n}"
+  shows "perm_map R n \<sigma> \<in> struct_maps (R\<^bsup>n\<^esup>) (R\<^bsup>n\<^esup>)"
+  apply(rule struct_maps_memI)
+  unfolding perm_map_def restrict_def using assms permute_list_closed[of _ n \<sigma>] 
+   apply metis 
+  by metis 
+
+lemma permute_poly_args_eval:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "\<sigma> permutes {..<n}"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "eval_at_point R a (permute_poly_args n \<sigma> p) = eval_at_point R (permute_list \<sigma> a) p"
+  apply(rule R.indexed_pset.induct[of p "{..<n}" "carrier R"])
+  using R.Pring_car assms  apply (metis coord_ring_def)
+   apply (metis assms(1) assms(2) eval_at_point_const permute_list_closed permute_poly_args_constant)
+proof-
+  show "\<And>p Q. p \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_point R a (permute_poly_args n \<sigma> p) = eval_at_point R (permute_list \<sigma> a) p \<Longrightarrow>
+           Q \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_point R a (permute_poly_args n \<sigma> Q) = eval_at_point R (permute_list \<sigma> a) Q \<Longrightarrow>
+           eval_at_point R a (permute_poly_args n \<sigma> (p \<Oplus> Q)) = eval_at_point R (permute_list \<sigma> a) (p \<Oplus> Q)"
+  proof-
+    fix p Q assume  A0: "p \<in> Pring_set R {..<n} "
+    assume A1: "eval_at_point R a (permute_poly_args n \<sigma> p) = eval_at_point R (permute_list \<sigma> a) p "
+    assume A2: "Q \<in> Pring_set R {..<n}"
+    assume A3: "eval_at_point R a (permute_poly_args n \<sigma> Q) = eval_at_point R (permute_list \<sigma> a) Q"
+    have A0': "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) "
+      using A0 R.Pring_car unfolding coord_ring_def  by blast
+    have A2': "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) "
+      using A2 R.Pring_car unfolding coord_ring_def by blast
+    have A4: "(permute_poly_args n \<sigma> (p \<Oplus> Q)) = (permute_poly_args n \<sigma> p) \<Oplus> (permute_poly_args n \<sigma> Q)"
+    proof-
+      have  "(permute_poly_args n \<sigma> (p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q)) = (permute_poly_args n \<sigma> p) \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (permute_poly_args n \<sigma> Q)"
+        using A0' A2' assms permute_poly_args_add by blast
+      then show ?thesis 
+        unfolding coord_ring_def 
+        by (metis R.Pring_add)        
+    qed    
+    show A5: "eval_at_point R a (permute_poly_args n \<sigma> (p \<Oplus> Q)) = eval_at_point R (permute_list \<sigma> a) (p \<Oplus> Q)"
+      using eval_at_point_add[of a n "permute_poly_args n \<sigma> p" "permute_poly_args n \<sigma> Q" ]
+            permute_poly_args_add[of \<sigma> n p Q] A0' A1 A2' A3 A4 permute_poly_args_closed assms 
+      by (metis R.Pring_add cartesian_power_car_memE cartesian_power_car_memE'' 
+          cartesian_power_car_memI coord_ring_def eval_at_point_add length_permute_list permute_list_set)  
+  qed
+  show "\<And>p i. p \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_point R a (permute_poly_args n \<sigma> p) = eval_at_point R (permute_list \<sigma> a) p \<Longrightarrow>
+           i \<in> {..<n} \<Longrightarrow> eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) = eval_at_point R (permute_list \<sigma> a) (p \<Otimes> i)"
+  proof-
+    fix p i
+    assume A0: "p \<in> Pring_set R {..<n}"
+    assume A1: "eval_at_point R a (permute_poly_args n \<sigma> p) = eval_at_point R (permute_list \<sigma> a) p "
+    assume A2: "i \<in> {..<n}"
+    have LHS:  "eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) = eval_at_point R a (permute_poly_args n \<sigma> p \<Otimes> \<sigma> i)"
+      using permute_poly_args_indexed_pmult[of \<sigma> n p i ] A0 A1 A2 assms 
+      by (metis R.Pring_car coord_ring_def)      
+    then have LHS' : "eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) =
+                 eval_at_point R a (permute_poly_args n \<sigma> p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R (\<sigma> i))"
+      using A0 R.Pring_car assms(1) assms  permute_poly_args_closed pvar_indexed_pmult
+      by (metis coord_ring_def)
+    have "eval_at_point R a (permute_poly_args n \<sigma> p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R (\<sigma> i)) =
+          eval_at_point R a (permute_poly_args n \<sigma>  p) \<otimes> eval_at_point R a (pvar R (\<sigma> i))"
+    proof-
+      have 1: "permute_poly_args n \<sigma> p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+        using A0 R.Pring_car assms(1) assms  permute_poly_args_closed 
+        by (metis coord_ring_def)        
+      have "pvar R (\<sigma> i) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+      proof-
+        have "\<sigma> i \<in> {..<n}"
+          using A2 assms 
+          by (meson permutes_in_image)
+        then have "(\<sigma> i) < n"
+           by blast 
+         then show ?thesis 
+           using pvar_closed[of "\<sigma> i" n]   
+          by blast
+      qed
+      then have LHS'' : "eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) =
+                 (eval_at_point R a (permute_poly_args n \<sigma>  p)) \<otimes>\<^bsub>R\<^esub> eval_at_point R a (pvar R (\<sigma> i))"
+        using LHS' "1" eval_at_point_mult assms 
+        by presburger       
+      then show ?thesis  
+        using LHS' by presburger
+    qed
+    then have LHS'': "eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) =
+        eval_at_point R a (permute_poly_args n \<sigma>  p) \<otimes> eval_at_point R a (pvar R (\<sigma> i))"
+      using LHS' by presburger
+    have 0: "eval_at_point R a (pvar R (\<sigma> i)) = a! (\<sigma> i)"
+    proof-
+      have "\<sigma> i \<in> {..<n}" 
+      using A2 assms 
+      by (meson permutes_in_image)
+      then have 0: "\<sigma> i < n" 
+        by blast 
+     have 1: "permute_list \<sigma> a \<in> carrier (R\<^bsup>n\<^esup>)"
+      using assms(1) assms(2) assms(3) permute_list_closed by blast
+     show ?thesis 
+      using 0 1 eval_pvar[of "\<sigma> i" n a] assms  
+      by blast
+    qed
+    have 1: "(permute_list \<sigma> a)! i  = a! \<sigma>  i"
+    proof-
+      have "length a = n"
+        using assms  cartesian_power_car_memE
+        by blast
+      then have "{..<length a} = {..<n}"
+        by blast
+      then have 0: " \<sigma> permutes {..<length a}" 
+        using assms 
+        by presburger
+      have 1: "i < length a"
+        using A2 \<open>{..<length a} = {..<n}\<close> 
+        by blast
+      show ?thesis using 0 1  permute_list_nth[of \<sigma> a i]
+        by blast
+    qed
+    have LHS''': "eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) =
+        eval_at_point R (permute_list \<sigma> a) p \<otimes> a! (\<sigma> i)"
+      using 0 LHS''  A1 
+      by presburger
+    have RHS: "eval_at_point R (permute_list \<sigma> a) (p \<Otimes> i) = 
+        (eval_at_point R (permute_list \<sigma> a) p) \<otimes>\<^bsub>R\<^esub> (eval_at_point R (permute_list \<sigma> a) (pvar R i))"
+    proof-
+      have "(p \<Otimes> i) = p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar R i)"
+        using A0 R.Pring_car pvar_indexed_pmult unfolding coord_ring_def 
+        by blast        
+      then show ?thesis 
+        using eval_at_point_mult[of "(permute_list \<sigma> a)" n p "(pvar R i)" ] 
+             A0 A2 R.Pring_car R.Pring_var_closed assms(1) assms(2) assms(3) permute_list_closed
+        by (metis coord_ring_def)
+    qed
+    then have RHS': "eval_at_point R (permute_list \<sigma> a) (p \<Otimes> i) = 
+        (eval_at_point R (permute_list \<sigma> a) p) \<otimes>\<^bsub>R\<^esub> (permute_list \<sigma> a)! i"
+    proof-
+      have 0: "i < n" 
+        using A2 assms 
+        by blast 
+      have 1: "permute_list \<sigma> a \<in> carrier (R\<^bsup>n\<^esup>)"
+        using assms permute_list_closed 
+        by blast
+      show ?thesis 
+        using 0 1 eval_pvar[of i n "(permute_list \<sigma> a)" ] RHS 
+        by presburger
+    qed
+    then show "eval_at_point R a (permute_poly_args n \<sigma> (p \<Otimes> i)) = eval_at_point R (permute_list \<sigma> a) (p \<Otimes> i)"
+      using LHS''' A1 1 
+      by presburger
+  qed
+qed
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsection\<open>Inverse Images of Sets by Tuples of Polynomials\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+
+definition is_poly_tuple :: "nat \<Rightarrow> ('a, nat) mvar_poly list \<Rightarrow> bool" where
+"is_poly_tuple (n::nat) fs = (set (fs) \<subseteq> carrier (R[\<X>\<^bsub>n\<^esub>]))"
+
+lemma is_poly_tupleE:
+  assumes "is_poly_tuple n fs"
+  assumes "j < length fs"
+  shows "fs ! j \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  using assms is_poly_tuple_def nth_mem 
+  by blast
+
+lemma is_poly_tuple_Cons:
+  assumes "is_poly_tuple n fs"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "is_poly_tuple n (f#fs)"
+  using assms unfolding is_poly_tuple_def 
+  by (metis (no_types, lifting) set_ConsD subset_iff)
+
+lemma is_poly_tuple_append:
+  assumes "is_poly_tuple n fs"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "is_poly_tuple n (fs@[f])"
+  using assms set_append unfolding is_poly_tuple_def 
+  by (metis (no_types, lifting) Un_subset_iff append_Nil2 set_ConsD subset_code(1))
+
+definition poly_tuple_eval :: "('a, nat) mvar_poly list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+"poly_tuple_eval fs as = map (\<lambda> f. eval_at_poly R f as) fs "
+
+lemma poly_tuple_evalE:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "j < m"
+  shows "(poly_tuple_eval fs as)!j \<in> carrier R"
+proof-
+  have 0: "(poly_tuple_eval fs as)!j = (eval_at_poly R (fs!j) as)"
+    using poly_tuple_eval_def 
+    by (metis assms(2) assms(4) nth_map)   
+  have 1: "(fs!j) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    using assms is_poly_tupleE
+    by blast
+  show ?thesis 
+    using assms 0 1 eval_at_point_closed 
+    by presburger   
+qed
+
+lemma poly_tuple_evalE':
+  shows "length (poly_tuple_eval fs as) = length fs"
+  unfolding poly_tuple_eval_def 
+  using length_map by blast
+
+lemma poly_tuple_evalE'':
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "j < m"
+  shows "(poly_tuple_eval fs as)!j = (eval_at_poly R (fs!j) as)"
+  using assms 
+  unfolding poly_tuple_eval_def 
+  using nth_map
+  by blast
+
+lemma poly_tuple_eval_closed:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "(poly_tuple_eval fs as) \<in> carrier (R\<^bsup>m\<^esup>)"
+proof(rule cartesian_power_car_memI)
+  show "length (poly_tuple_eval fs as) = m"
+    using assms 
+    by (simp add: assms poly_tuple_evalE')
+  show "set (poly_tuple_eval fs as) \<subseteq> carrier R"
+  proof fix x
+    assume "x \<in> set (poly_tuple_eval fs as)"
+    then obtain j where j_def: "j< m \<and> x = (poly_tuple_eval fs as)!j"
+      using assms 
+      by (metis \<open>length (poly_tuple_eval fs as) = m\<close> in_set_conv_nth)
+    then show "x \<in> carrier R"
+      using assms(1) assms(2) assms(3)  poly_tuple_evalE assms by blast       
+  qed
+qed
+
+lemma poly_tuple_eval_Cons:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "(poly_tuple_eval (f#fs) as) = (eval_at_point R as f)#(poly_tuple_eval fs as)"
+  using assms poly_tuple_eval_def 
+  by (metis list.simps(9))
+
+definition poly_tuple_pullback :: 
+   "nat \<Rightarrow> 'a list set \<Rightarrow> ('a, nat) mvar_poly list \<Rightarrow> 'a list set" where
+"poly_tuple_pullback n S fs = ((poly_tuple_eval fs) -` S) \<inter> (carrier (R\<^bsup>n\<^esup>)) "
+
+lemma poly_pullbackE: 
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "S \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  shows "poly_tuple_pullback n S fs \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  using poly_tuple_pullback_def assms  
+  by blast
+  
+lemma poly_pullbackE': 
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "S \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "as \<in> poly_tuple_pullback n S fs"
+  shows "as \<in> carrier (R\<^bsup>n\<^esup>)"
+        "poly_tuple_eval fs as \<in> S"
+  using assms 
+  apply (meson poly_pullbackE subsetD)
+proof-
+  have "as \<in> poly_tuple_eval fs -` S" 
+    using assms unfolding poly_tuple_pullback_def
+    by blast
+  then show "poly_tuple_eval fs as \<in> S" 
+    by blast
+qed
+
+lemma poly_pullbackI: 
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "S \<subseteq> carrier (R\<^bsup>m\<^esup>)"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "poly_tuple_eval fs as \<in> S"
+  shows "as \<in> poly_tuple_pullback n S fs"
+  using assms 
+  unfolding poly_tuple_pullback_def 
+  by blast
+
+
+
+end 
+
+text\<open>coordinate permutations as pullbacks. The point here is to realize that permutations of 
+indices are just pullbacks (or pushforwards) by particular polynomial maps\<close>
+
+abbreviation pvar_list where 
+"pvar_list R n \<equiv> map (pvar R) (index_list n)"
+
+lemma pvar_list_elements:
+  assumes "i < n"
+  shows "pvar_list R n ! i = pvar R i"
+  by (simp add: assms index_list_indices index_list_length)
+  
+lemma pvar_list_length:
+"length (pvar_list R n) = n"
+  by (simp add: index_list_length)
+
+context cring_coord_rings
+begin
+
+lemma pvar_list_is_poly_tuple:
+  shows "is_poly_tuple n (pvar_list R n)"
+  unfolding is_poly_tuple_def 
+proof fix x
+  assume A: "x \<in> set (pvar_list R n)"
+  have "set (index_list n) = {..<n}"
+    by (simp add: index_list_set)
+  obtain i where "i < n \<and> x = pvar R i"
+    using A  pvar_list_elements[of _ n R] pvar_list_length[of R n] 
+    by (metis in_set_conv_nth)
+  then show "x \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    using pvar_closed 
+    by blast
+qed
+
+lemma permutation_of_poly_list_is_poly_list:
+  assumes "is_poly_tuple k fs"
+  assumes "\<sigma> permutes {..< length fs}"
+  shows "is_poly_tuple k (permute_list \<sigma> fs)"
+  unfolding is_poly_tuple_def 
+proof-
+  show "set (permute_list \<sigma> fs) \<subseteq> carrier (coord_ring R k)"
+    using assms is_poly_tuple_def set_permute_list 
+    by blast
+qed
+
+lemma permutation_of_poly_listE:
+  assumes "is_poly_tuple k fs"
+  assumes "\<sigma> permutes {..< length fs}"
+  assumes "i < length fs"
+  shows "(permute_list \<sigma> fs) ! i = fs ! (\<sigma> i)"
+  using assms permute_list_nth 
+  by blast
+
+lemma pushforward_by_permutation_of_poly_list:
+  assumes "is_poly_tuple k fs"
+  assumes "\<sigma> permutes {..< length fs}"
+  assumes "as \<in> carrier (R\<^bsup>k\<^esup>)"
+  shows "poly_tuple_eval (permute_list \<sigma> fs) as = permute_list \<sigma> (poly_tuple_eval fs as)"
+  using assms unfolding poly_tuple_eval_def 
+  by (metis permute_list_map)
+
+lemma pushforward_by_pvar_list:
+  assumes "as \<in>  carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_tuple_eval (pvar_list R n) as = as"
+  using assms pvar_list_elements[of _ n R] unfolding poly_tuple_eval_def using eval_pvar[of _ n as]
+  by (metis (mono_tags, lifting) cartesian_power_car_memE length_map nth_equalityI nth_map pvar_list_length)
+
+lemma pushforward_by_permuted_pvar_list:
+  assumes "\<sigma> permutes {..< n}"
+  assumes "as \<in>  carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_tuple_eval (permute_list \<sigma> (pvar_list R n)) as = permute_list \<sigma> as"
+  by (metis assms pushforward_by_permutation_of_poly_list 
+      pushforward_by_pvar_list pvar_list_is_poly_tuple pvar_list_length)
+
+lemma pullback_by_permutation_of_poly_list:
+  assumes "\<sigma> permutes {..< n}"
+  assumes "S \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_tuple_pullback n S (permute_list \<sigma> (pvar_list R n)) = 
+          permute_list (fun_inv \<sigma>) ` S"
+proof
+   show "poly_tuple_pullback n S (permute_list \<sigma> (pvar_list R n)) \<subseteq> permute_list (fun_inv \<sigma>) ` S"
+   proof fix x
+     assume A: " x \<in> poly_tuple_pullback n S (permute_list \<sigma> (pvar_list R n))"
+     then obtain y where y_def: "y \<in> S \<and> poly_tuple_eval (permute_list \<sigma> (pvar_list R n)) x = y"
+       by (metis assms length_permute_list 
+           permutation_of_poly_list_is_poly_list poly_pullbackE'(2) pvar_list_is_poly_tuple 
+           pvar_list_length)
+     then have 0: "y = permute_list \<sigma> x"
+       by (metis A assms length_permute_list 
+           permutation_of_poly_list_is_poly_list poly_pullbackE'(1) pushforward_by_permuted_pvar_list pvar_list_is_poly_tuple pvar_list_length)
+     have 1: "length x = n"
+       using A 
+       by (metis "0" length_permute_list poly_tuple_evalE' pvar_list_length y_def)
+     then have "{..<length x} = {..<n}"
+       by blast 
+     then have "permute_list (fun_inv \<sigma>) y = x"
+       using 0 permutes_inv_o(1)[of \<sigma> "{..< n}"] permute_list_id[of x] permutes_inv[of \<sigma> "{..<n}"]
+            assms permute_list_compose[of "(fun_inv \<sigma>)" x \<sigma> ]
+       unfolding fun_inv_def 
+       by metis 
+     then show " x \<in> permute_list (fun_inv \<sigma>) ` S"
+       using y_def by blast
+   qed
+   show "permute_list (fun_inv \<sigma>) ` S \<subseteq> poly_tuple_pullback n S (permute_list \<sigma> (pvar_list R n))"
+   proof fix x assume A: "x \<in> permute_list (fun_inv \<sigma>) ` S"
+     then obtain y where y_def: "y \<in> S \<and> x = permute_list (fun_inv \<sigma>) y"
+       by blast
+     have 0: "(fun_inv \<sigma>) permutes {..<n}"
+       using assms unfolding fun_inv_def 
+       by (simp add: permutes_inv)
+     have 1: "permute_list \<sigma> x = permute_list \<sigma> (permute_list (fun_inv \<sigma>) y)"
+       by (simp add: y_def)
+     have 2: "length y = n"
+       using y_def A assms cartesian_power_car_memE 
+       by blast
+     have 3: "\<sigma> permutes {..<length y}"
+       by (simp add: "2" assms)
+     have 4: "permute_list \<sigma> x = y"
+       using assms(2) permute_list_id[of y]  permute_list_compose[of \<sigma> y "(fun_inv \<sigma>)" ] 
+              3 2 1 0 permutes_inv_o(2)[of \<sigma> "{..< n}"] 
+       unfolding fun_inv_def 
+       by metis 
+     have 5: "x \<in> carrier (R\<^bsup>n\<^esup>)"
+       apply(rule cartesian_power_car_memI)
+       using A 0 assms  
+        apply (metis "2" "4" length_permute_list)
+       using A 0 assms  
+       by (smt "2" in_set_conv_nth neq0_conv poly_tuple_evalE pushforward_by_pvar_list 
+           pvar_list_is_poly_tuple pvar_list_length set_permute_list subset_iff y_def)
+     then have 6: "poly_tuple_eval (permute_list \<sigma> (pvar_list R n)) x = y"
+       using 4  assms pushforward_by_permuted_pvar_list[of \<sigma> n x] 
+       by blast
+     then show "x \<in> poly_tuple_pullback n S (permute_list \<sigma> (pvar_list R n))"
+       using 5 y_def unfolding poly_tuple_pullback_def 
+       by blast
+   qed
+qed
+
+lemma pullback_by_permutation_of_poly_list':
+  assumes "\<sigma> permutes {..< n}"
+  assumes "S \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_tuple_pullback n S (permute_list (fun_inv \<sigma>) (pvar_list R n)) = 
+          permute_list \<sigma> ` S"
+proof-
+  have 0: "(fun_inv (fun_inv \<sigma>)) = \<sigma>"
+    using assms unfolding fun_inv_def 
+    using permutes_inv_inv 
+    by blast
+  have 1: "fun_inv \<sigma> permutes {..<n}"
+    unfolding fun_inv_def 
+    using assms permutes_inv by blast
+  then show ?thesis using 0 assms pullback_by_permutation_of_poly_list[of "fun_inv \<sigma>" n S]
+    by presburger
+qed
+
+
+  (**********************************************************************)
+  (**********************************************************************)
+  subsection\<open>Composing Polynomial Tuples With Polynomials\<close>
+  (**********************************************************************)
+  (**********************************************************************)
+
+text\<open>composition of a multivaribale polynomial by a list of polynomials\<close>
+
+definition poly_compose :: 
+  "nat \<Rightarrow> nat \<Rightarrow> ('a, nat) mvar_poly list \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> ('a, nat) mvar_poly" where
+"poly_compose n m fs = indexed_poly_induced_morphism {..<n} (coord_ring R m) (\<lambda> s. R.indexed_const s) (\<lambda>i. fs!i) "
+
+lemma poly_compose_var:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "j < n"
+  shows "poly_compose n m fs (pvar R j) = (fs!j)"
+proof-
+  have 0: "cring (coord_ring R m)"
+    using R.Pring_is_cring R.is_cring 
+    unfolding coord_ring_def  by blast    
+  have 1: "(!) fs \<in> {..<n} \<rightarrow> carrier (coord_ring R m)"
+    using assms is_poly_tuple_def 
+    by auto            
+  have 2: "ring_hom_ring R (coord_ring R m) coord_const"
+    using indexed_const_ring_hom coord_const_ring_hom by blast    
+  have "\<forall>i\<in>{..<n}. indexed_poly_induced_morphism {..<n} (coord_ring R m) coord_const ((!) fs) (mset_to_IP R {#i#}) = fs ! i"  
+    using assms 0 1 2 R.Pring_universal_prop(2)[of "(coord_ring R m)" "(\<lambda>i. fs!i)" "{..<n}" "(\<lambda> s. R.indexed_const s)" "poly_compose n m fs"] 
+           poly_compose_def 
+    by (metis var_to_IP_def)    
+  then show ?thesis
+    using assms 
+    unfolding poly_compose_def var_to_IP_def
+  by blast
+qed
+
+lemma Pring_universal_prop_assms:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  shows  "(\<lambda>i. fs!i) \<in> {..<n} \<rightarrow> carrier (coord_ring R m)"
+           "ring_hom_ring R (coord_ring R m) coord_const"
+proof
+  show "\<And>x. x \<in> {..<n} \<Longrightarrow> fs ! x \<in> carrier (coord_ring R m)"
+    using assms  is_poly_tupleE by blast    
+  show "ring_hom_ring R (coord_ring R m) coord_const"
+    using R.indexed_const_ring_hom coord_const_ring_hom by blast   
+qed
+
+lemma poly_compose_ring_hom:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  shows  "(ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (coord_ring R m) (poly_compose n m fs))"
+  using Pring_universal_prop_assms[of n fs] assms
+        R.Pring_universal_prop(1)[of "(coord_ring R m)" "(\<lambda>i. fs!i)" "{..<n}" coord_const "(poly_compose n m fs)"]
+  unfolding poly_compose_def 
+  using R.Pring_is_cring R.is_cring
+  by (metis Pi_I Pring_universal_prop_assms(2) coord_ring_def is_poly_tupleE lessThan_iff)
+  
+lemma poly_compose_closed:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "(poly_compose n m fs f) \<in> carrier (coord_ring R m)"
+proof-
+  have "poly_compose n m fs \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<rightarrow> carrier (R [\<X>\<^bsub>m\<^esub>])"
+  using poly_compose_ring_hom[of m fs n] assms 
+  unfolding  ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def 
+  by blast
+  then show ?thesis  using assms by blast 
+qed
+  
+lemma poly_compose_add:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "g \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "poly_compose n m fs (f \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> g) = (poly_compose n m fs f) \<oplus>\<^bsub>coord_ring R m\<^esub>  (poly_compose n m fs g)"
+  using assms poly_compose_ring_hom ring_hom_add 
+  by (metis (mono_tags, lifting) ring_hom_ring.homh)
+
+lemma poly_compose_mult:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "g \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "poly_compose n m fs (f \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> g) = (poly_compose n m fs f) \<otimes>\<^bsub>coord_ring R m\<^esub>  (poly_compose n m fs g)"
+  using assms poly_compose_ring_hom ring_hom_mult
+  by (metis (mono_tags, lifting) ring_hom_ring.homh)
+
+lemma poly_compose_indexed_pmult:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "i < n"
+  shows "poly_compose n m fs (f \<Otimes> i) = (poly_compose n m fs f) \<otimes>\<^bsub>coord_ring R m\<^esub> (fs!i)"
+proof-
+  have "(f \<Otimes> i) = f \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i"
+    using assms pvar_indexed_pmult 
+    by blast
+  then show ?thesis using poly_compose_mult poly_compose_var  assms 
+    by (metis pvar_closed)
+qed
+
+lemma poly_compose_const:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "a \<in> carrier R"
+  shows "poly_compose n m fs (coord_const a) = coord_const a"
+  using R.Pring_universal_prop(3)[of "(coord_ring R m)" "(\<lambda>i. fs!i)" "{..<n}" coord_const "(poly_compose n m fs)"]
+        Pring_universal_prop_assms assms
+  unfolding poly_compose_def 
+  using R.Pring_is_cring coord_cring_cring by blast
+  
+text\<open>evaluating polynomial compositions\<close>
+
+lemma poly_compose_eval:
+  assumes "is_poly_tuple m fs"
+  assumes "length fs = n"
+  assumes "f \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "as \<in> carrier (R\<^bsup>m\<^esup>)"
+  shows "eval_at_point R (poly_tuple_eval fs as) f = eval_at_point R as (poly_compose n m fs f)"
+  apply(rule R.indexed_pset.induct[of f "{..<n}" "carrier R"])
+  using R.Pring_car assms
+  apply (metis coord_ring_def)  
+proof-
+    show "\<And>k. k \<in> carrier R \<Longrightarrow> eval_at_poly R (coord_const k) (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs (coord_const k)) as"
+      using assms 
+      by (metis (no_types, lifting) eval_at_point_factored poly_compose_const R.total_eval_const)     
+    show " \<And>p Q. p \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_poly R p (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs p) as \<Longrightarrow>
+           Q \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_poly R Q (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs Q) as \<Longrightarrow>
+           eval_at_poly R (p \<Oplus> Q) (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs (p \<Oplus> Q)) as"
+    proof-
+      fix p Q
+      assume A0: "p \<in> Pring_set R {..<n}"
+      assume A1: "eval_at_poly R p (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs p) as"
+      assume A2: "Q \<in> Pring_set R {..<n}"
+      assume A3: " eval_at_poly R Q (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs Q) as"
+      have A4: "eval_at_poly R (p \<Oplus> Q) (poly_tuple_eval fs as) = eval_at_poly R p (poly_tuple_eval fs as) \<oplus> eval_at_poly R Q (poly_tuple_eval fs as)"
+        using A0  A1 A2 A3  
+            eval_at_point_add[of "(poly_tuple_eval fs as)" n p Q]  
+        by (metis R.Pring_add R.Pring_car assms(2) assms(3) assms(4) assms coord_ring_def neq0_conv poly_tuple_eval_closed)
+      have A5: "poly_compose n m fs (p \<Oplus> Q) = poly_compose n m fs p \<oplus>\<^bsub>coord_ring R m\<^esub> poly_compose n m fs Q"
+        using assms poly_compose_add
+        by (metis A0 A2 R.Pring_add R.Pring_car coord_ring_def)        
+      have A6: " eval_at_poly R (poly_compose n m fs (p \<Oplus> Q)) as =  eval_at_poly R (poly_compose n m fs p) as \<oplus> eval_at_poly R (poly_compose n m fs Q) as"
+      proof-
+        have 0: " as \<in> carrier (R\<^bsup>m\<^esup>)"
+          by (simp add: assms)
+        have 1: "poly_compose n m fs p \<in> carrier (coord_ring R m)"
+          using A0 R.Pring_car assms(1) assms(2) assms(3) assms(4) poly_compose_closed 
+          by (metis coord_ring_def)           
+        have 2: "poly_compose n m fs Q \<in> carrier (coord_ring R m)"
+          using A2 R.Pring_car assms(1) assms(2) assms(3) assms(4) poly_compose_closed 
+          by (metis coord_ring_def)
+        show ?thesis 
+          using  0 1 2 eval_at_point_add[of as m "(poly_compose n m fs p)" "(poly_compose n m fs Q)"]
+                A5
+          by presburger
+      qed
+      show  "eval_at_poly R (p \<Oplus> Q) (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs (p \<Oplus> Q)) as"
+        using A5 A6 A3 A1  A4 
+        by presburger
+    qed
+    show "\<And>p i. p \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_poly R p (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs p) as \<Longrightarrow>
+           i \<in> {..<n} \<Longrightarrow> eval_at_poly R (p \<Otimes> i) (poly_tuple_eval fs as) = eval_at_poly R (poly_compose n m fs (p \<Otimes> i)) as"
+      using assms poly_compose_indexed_pmult eval_at_point_indexed_pmult
+      by (smt R.Pring_car coord_ring_def eval_at_point_mult is_poly_tupleE lessThan_iff neq0_conv poly_compose_closed poly_tuple_evalE'' poly_tuple_eval_closed)
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Extensional Polynomial Maps\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>Polynomial Maps between powers of a ring\<close>
+
+definition poly_map :: "nat \<Rightarrow> ('a, nat) mvar_poly list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
+"poly_map n fs = (\<lambda>a \<in> carrier (R\<^bsup>n\<^esup>). poly_tuple_eval fs a)"
+
+lemma poly_map_is_struct_map:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  shows "poly_map n fs \<in> struct_maps (R\<^bsup>n\<^esup>) (R\<^bsup>m\<^esup>)"
+  apply(rule struct_maps_memI)
+  unfolding poly_map_def using assms 
+  apply (metis poly_tuple_eval_closed restrict_apply')
+  by (meson restrict_apply)
+
+lemma poly_map_closed:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "as \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_map n fs as \<in> carrier (R\<^bsup>m\<^esup>)"
+  using assms 
+  by (meson poly_map_is_struct_map struct_maps_memE(1))
+
+definition poly_maps :: "nat \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a list) set"  where 
+"poly_maps n m = {F. (\<exists> fs. length fs = m \<and> is_poly_tuple n fs \<and> F = poly_map n fs)}"
+
+lemma poly_maps_memE:
+  assumes "F \<in> poly_maps n m"
+  obtains fs where "length fs = m \<and> is_poly_tuple n fs \<and> F = poly_map n fs"
+  using assms unfolding poly_maps_def by blast 
+
+lemma poly_maps_memI:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "F = poly_map n fs"
+  shows "F \<in> poly_maps n m"
+  using assms unfolding poly_maps_def by blast 
+
+lemma poly_map_compose_closed:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "is_poly_tuple k gs"
+  assumes "length gs = n"
+  shows "is_poly_tuple k (map (poly_compose n k gs) fs)"
+  unfolding is_poly_tuple_def 
+proof fix y assume A: "y \<in> set (map (poly_compose n k gs) fs)"
+  then obtain f where f_def: "f \<in> set fs \<and> y = poly_compose n k gs f"
+    by (smt in_set_conv_nth length_map nth_map)
+  then show "y \<in> carrier (coord_ring R k)"
+    using assms poly_compose_closed 
+    by (metis in_set_conv_nth is_poly_tupleE )
+qed
+
+lemma poly_map_compose_closed':
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "is_poly_tuple k gs"
+  assumes "length gs = n"
+  shows "poly_map k (map (poly_compose n k gs) fs) \<in> poly_maps k m"
+  apply(rule poly_maps_memI[of _ "map (poly_compose n k gs) fs"])
+  using poly_map_compose_closed[of n fs m k gs] assms apply blast
+   apply (simp add: assms)
+     by auto
+
+lemma poly_map_pullback_char:
+  assumes "is_poly_tuple n fs"
+  assumes "length fs = m"
+  assumes "is_poly_tuple k gs"
+  assumes "length gs = n"
+  shows "(pullback (R\<^bsup>k\<^esup>) (poly_map k gs) (poly_map n fs)) = 
+          poly_map k (map (poly_compose n k gs) fs)"
+proof(rule ext)
+  fix x 
+  show "pullback (R\<^bsup>k\<^esup>) (poly_map k gs) (poly_map n fs) x =
+         poly_map k (map (poly_compose n k gs) fs) x"
+  proof(cases "x \<in> carrier (R\<^bsup>k\<^esup>)")
+    case True
+      have 0: "length (pullback (R\<^bsup>k\<^esup>) (poly_map k gs) (poly_map n fs) x) =  m"
+        using True assms poly_map_closed cartesian_power_car_memE
+        unfolding pullback_def  
+        by (metis (mono_tags, lifting) compose_eq)
+      have 1: "is_poly_tuple k (map (poly_compose n k gs) fs)"
+       by (simp add: assms poly_map_compose_closed)               
+      have 2: "length (map (poly_compose n k gs) fs) = m"
+        using assms length_map by auto 
+      have 3: "\<And>i. i < m \<Longrightarrow> 
+            (pullback (R\<^bsup>k\<^esup>) (poly_map k gs) (poly_map n fs) x)! i = 
+                  eval_at_point R (poly_map k gs x) (fs ! i)"
+        unfolding pullback_def poly_map_def poly_tuple_eval_def 
+        using assms True 
+        by (smt compose_eq nth_map poly_tuple_eval_closed poly_tuple_eval_def restrict_apply')
+      have 4: "\<And>i. i < m \<Longrightarrow> 
+            poly_map k (map (poly_compose n k gs) fs) x ! i = 
+                  eval_at_point R (poly_map k gs x) (fs ! i)"       
+        unfolding poly_map_def poly_tuple_eval_def using True assms 
+        by (smt "2" cring_coord_rings.is_poly_tuple_def cring_coord_rings_axioms neq0_conv 
+            nth_map nth_mem poly_compose_eval poly_tuple_eval_def restrict_apply' subset_code(1))
+      show ?thesis using 0 1 2 3 4 assms True 
+        by (metis cartesian_power_car_memE nth_equalityI poly_map_closed)
+  next
+    case False
+    then show ?thesis 
+      unfolding poly_map_def pullback_def
+      by (metis affine_alg_set_empty compose_extensional extensional_restrict poly_map_def restrict_def)
+  qed
+qed
+
+lemma poly_map_pullback_closed:
+  assumes "F \<in> poly_maps n m"
+  assumes "G \<in> poly_maps k n"
+  shows "(pullback (R\<^bsup>k\<^esup>) G F) \<in> poly_maps k m"
+  by (metis assms poly_map_compose_closed' 
+      poly_map_pullback_char poly_maps_memE)
+
+lemma poly_map_cons: 
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_map n (f#fs) a = (eval_at_point R a f)#poly_map n fs a"
+  unfolding poly_map_def poly_tuple_eval_def  
+  by (metis (mono_tags, lifting) assms list.simps(9) restrict_apply')
+   
+lemma poly_map_append: 
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows  "poly_map n (fs@gs) a = (poly_map n fs a) @ (poly_map n gs a)"
+proof(induction fs)
+  case Nil
+  then show ?case 
+    using assms unfolding poly_map_def poly_tuple_eval_def 
+  by (metis (no_types, lifting) map_append restrict_apply')
+next
+  case (Cons f fs)
+  have "poly_map n ((f # fs) @ gs) a = (eval_at_point R a f)#(poly_map n (fs@gs) a)"
+    using poly_map_cons 
+    by (metis append_Cons assms)
+  hence "poly_map n ((f # fs) @ gs) a = (eval_at_point R a f)#(poly_map n fs a)@(poly_map n gs a)"
+    using Cons.IH by metis 
+  thus ?case 
+    by (metis Cons_eq_appendI assms poly_map_cons)
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Nesting of Polynomial Rings\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+lemma poly_ring_car_mono:
+  assumes "n \<le> m"
+  shows "carrier (R[\<X>\<^bsub>n\<^esub>]) \<subseteq> carrier (coord_ring R m)"
+  using R.Pring_carrier_subset 
+  unfolding coord_ring_def 
+  by (simp add: R.Pring_car R.Pring_carrier_subset assms)
+    
+lemma poly_ring_car_mono'[simp]:
+  shows "carrier (R[\<X>\<^bsub>n\<^esub>]) \<subseteq> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+        "carrier (R[\<X>\<^bsub>n\<^esub>]) \<subseteq> carrier (R[\<X>\<^bsub>n+m\<^esub>])"
+  using poly_ring_car_mono 
+  apply simp
+  using poly_ring_car_mono 
+  by simp
+
+lemma poly_ring_add_mono:
+  assumes "n \<le> m"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "A \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B = A \<oplus>\<^bsub>coord_ring R m\<^esub> B"
+  using assms unfolding coord_ring_def 
+  by (metis R.Pring_add_eq)
+  
+lemma poly_ring_add_mono':
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "A \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B = A \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> B"
+        "A \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B = A \<oplus>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> B"
+  using assms unfolding coord_ring_def 
+  apply (metis R.Pring_add_eq)
+  by (metis R.Pring_add_eq)  
+
+lemma poly_ring_times_mono:
+  assumes "n \<le> m"
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "A \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B = A \<otimes>\<^bsub>coord_ring R m\<^esub> B"
+  using assms unfolding coord_ring_def 
+  by (metis R.Pring_mult_eq)
+  
+lemma poly_ring_times_mono':
+  assumes "A \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "B \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "A \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B = A \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> B"
+        "A \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> B = A \<otimes>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> B"
+  using assms unfolding coord_ring_def 
+  apply (metis R.Pring_mult_eq)
+  by (metis R.Pring_mult_eq)  
+ 
+lemma poly_ring_one_mono:
+  assumes "n \<le> m"
+  shows "\<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> = \<one>\<^bsub>coord_ring R m\<^esub>"
+  by (metis R.Pring_one coord_ring_def) 
+
+lemma poly_ring_zero_mono:
+  assumes "n \<le> m"
+  shows "\<zero>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> = \<zero>\<^bsub>coord_ring R m\<^esub>"
+  using R.Pring_zero_eq
+  by (metis coord_ring_def)
+
+text\<open>replacing the variables in a polynomial with new variables\<close>
+
+definition shift_vars :: "nat \<Rightarrow> nat \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> ('a, nat) mvar_poly" where
+"shift_vars n m p = indexed_poly_induced_morphism {..<n} (R[\<X>\<^bsub>n+m\<^esub>]) coord_const (\<lambda>i. pvar R (i + m)) p" 
+
+lemma shift_vars_char:
+  shows "(ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>n+m\<^esub>]) (shift_vars n m))"
+        "(\<forall>i \<in> {..<n}. (shift_vars n m) (pvar R i) = pvar R (i + m))"
+        "(\<forall>a \<in> carrier R. (shift_vars n m) (R.indexed_const a) = (coord_const a))"
+proof-
+  have 1:  "(\<lambda>i. pvar R (i + m)) \<in> {..<n} \<rightarrow> carrier (R[\<X>\<^bsub>n+m\<^esub>])"
+  proof fix x
+    assume "x \<in> {..<n}"
+    then have "x + m < n + m"
+      using  add_less_mono1 by blast      
+    then show "pvar R (x + m) \<in> carrier (R[\<X>\<^bsub>n+m\<^esub>])"
+      using pvar_closed by blast
+  qed
+  have 2:  "ring_hom_ring R (R[\<X>\<^bsub>n+m\<^esub>]) coord_const"
+    using R.indexed_const_ring_hom unfolding coord_ring_def 
+    by blast
+  have 3:  "shift_vars n m = indexed_poly_induced_morphism {..<n} (R[\<X>\<^bsub>n+m\<^esub>]) coord_const (\<lambda>i. pvar R (i + m))"
+    unfolding shift_vars_def 
+    by blast 
+  show "(ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>n+m\<^esub>]) (shift_vars n m))"
+    using 1 2 3 R.Pring_universal_prop[of "(R[\<X>\<^bsub>n+m\<^esub>])"  "(\<lambda>i. pvar R (i + m))" "{..<n}" "coord_const" "(shift_vars n m)"]
+    using MP.is_cring by (metis coord_ring_def)    
+  show "(\<forall>i \<in> {..<n}. (shift_vars n m) (pvar R i) = pvar R (i + m))"
+    using 1 2 3 R.Pring_universal_prop[of "(R[\<X>\<^bsub>n+m\<^esub>])"  "(\<lambda>i. pvar R (i + m))" "{..<n}" "coord_const" "(shift_vars n m)"]
+    by (metis R.Pring_is_cring MP.is_cring var_to_IP_def)
+  show "(\<forall>a \<in> carrier R. (shift_vars n m) (R.indexed_const a) = (coord_const a))"
+    using 1 2 3 R.Pring_universal_prop[of "(R[\<X>\<^bsub>n+m\<^esub>])"  "(\<lambda>i. pvar R (i + m))" "{..<n}" "coord_const" "(shift_vars n m)"]
+    by (meson MP.is_cring)
+qed
+
+lemma shift_vars_constant:
+  assumes "a \<in> carrier R"
+  shows "shift_vars n m (coord_const a) = coord_const a"
+  using assms(1) shift_vars_char(3) by blast
+
+lemma shift_vars_pvar:
+  assumes "i \<in> {..<n}"
+  shows "shift_vars n m (pvar R i) = pvar R (i + m)"
+  using assms shift_vars_char(2) by blast 
+
+lemma shift_vars_add:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "shift_vars n m (p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q) = shift_vars n m p \<oplus>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> shift_vars n m Q"
+  using assms shift_vars_char(1)[of n m] 
+  unfolding ring_hom_ring_def ring_hom_ring_axioms_def 
+  using ring_hom_add  
+  by (metis (no_types, lifting))  
+
+lemma shift_vars_mult:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "shift_vars n m (p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q) = shift_vars n m p \<otimes>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> shift_vars n m Q"
+  using assms shift_vars_char(1)[of n m] 
+  unfolding ring_hom_ring_def ring_hom_ring_axioms_def unfolding coord_ring_def 
+  using ring_hom_mult 
+  by metis
+
+lemma shift_vars_indexed_pmult:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "i \<in> {..<n}"
+  shows "shift_vars n m (p \<Otimes> i) = (shift_vars n m p) \<otimes>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> (pvar R (i + m))"
+proof-
+  have "(p \<Otimes> i) = p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (pvar R i)"
+    using assms pvar_indexed_pmult by blast
+  then show ?thesis 
+    using shift_vars_mult shift_vars_pvar assms unfolding coord_ring_def 
+    by (metis R.Pring_var_closed)
+qed
+
+lemma shift_vars_closed:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "shift_vars n m p \<in> carrier (R[\<X>\<^bsub>n+m\<^esub>])"
+  using assms shift_vars_char(1)[of n m] ring_hom_closed[of "shift_vars n m"]
+  unfolding ring_hom_ring_def ring_hom_ring_axioms_def  
+  by blast
+
+lemma shift_vars_eval:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "a \<in> carrier (R\<^bsup>m\<^esup>)"
+  assumes "b \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "eval_at_point R (a@b) (shift_vars n m p)  = eval_at_point R b p"
+  apply(rule R.indexed_pset.induct[of p "{..<n}" "carrier R"])
+  using R.Pring_car assms apply (metis coord_ring_def)  
+proof-
+  show "\<And>k. k \<in> carrier R \<Longrightarrow> eval_at_poly R (shift_vars n m (coord_const k)) (a @ b) = eval_at_poly R (coord_const k) b"
+  proof-
+    fix k
+    have 0: "(a @ b) \<in> carrier (R\<^bsup>n + m\<^esup>)"
+      using assms 
+      by (metis add.commute cartesian_product_closed')
+    assume A: "k \<in> carrier R"
+    then show "eval_at_poly R (shift_vars n m (coord_const k)) (a @ b) = eval_at_poly R (coord_const k) b"
+      using assms shift_vars_constant
+          eval_at_point_const[of k "(a @ b)" "m + n"] 
+          eval_at_point_const[of k "b" n]  0
+      by (metis eval_at_point_const)
+  qed
+  show "\<And>p Q. p \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_poly R (shift_vars n m p) (a @ b) = eval_at_poly R p b \<Longrightarrow>
+           Q \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_poly R (shift_vars n m Q) (a @ b) = eval_at_poly R Q b \<Longrightarrow>
+           eval_at_poly R (shift_vars n m (p \<Oplus> Q)) (a @ b) = eval_at_poly R (p \<Oplus> Q) b"
+  proof- fix p Q
+    assume A0: " p \<in> Pring_set R {..<n}"
+    assume A1: "eval_at_poly R (shift_vars n m p) (a @ b) = eval_at_poly R p b"
+    assume A2: "Q \<in> Pring_set R {..<n}"
+    assume A3: "eval_at_poly R (shift_vars n m Q) (a @ b) = eval_at_poly R Q b"
+    have A4: "eval_at_poly R (p \<Oplus> Q) b = eval_at_poly R p b \<oplus> eval_at_poly R Q b"
+      using A0 A2 assms eval_at_point_add[of b n p Q]  
+      by (metis R.Pring_add R.Pring_car coord_ring_def)      
+    have A5: "(shift_vars n m (p \<Oplus> Q)) = (shift_vars n m p) \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (shift_vars n m Q)"
+      using A0 A2 R.Pring_add R.Pring_car assms(1) shift_vars_add unfolding coord_ring_def 
+      by metis
+    have A6: " eval_at_poly R (shift_vars n m (p \<Oplus> Q)) (a @ b) = 
+             eval_at_poly R (shift_vars n m p) (a @ b) \<oplus> eval_at_poly R (shift_vars n m Q) (a @ b) "
+      using A5 eval_at_point_add shift_vars_closed A0 A2  R.Pring_car add.commute 
+        assms unfolding coord_ring_def  
+      by (metis R.Pring_add cartesian_power_concat(1))       
+    have A7: " eval_at_poly R (shift_vars n m (p \<Oplus> Q)) (a @ b) = 
+             eval_at_poly R p b \<oplus> eval_at_poly R Q b "
+      using A6  A1 A3 by presburger
+    then show " eval_at_poly R (shift_vars n m (p \<Oplus> Q)) (a @ b) = eval_at_poly R (p \<Oplus> Q) b "
+      using A4 
+      by presburger
+  qed
+  show "\<And>p i. p \<in> Pring_set R {..<n} \<Longrightarrow>
+           eval_at_poly R (shift_vars n m p) (a @ b) = eval_at_poly R p b \<Longrightarrow>
+           i \<in> {..<n} \<Longrightarrow> eval_at_poly R (shift_vars n m (p \<Otimes> i)) (a @ b) = eval_at_poly R (p \<Otimes> i) b"
+  proof- fix p i
+    assume A0: "p \<in> Pring_set R {..<n}" 
+    then have A0': "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+      using R.Pring_car unfolding coord_ring_def
+      by blast
+    assume A1: " eval_at_poly R (shift_vars n m p) (a @ b) = eval_at_poly R p b"
+    assume A2: "i \<in> {..<n}"
+    have A3: "(shift_vars n m (p \<Otimes> i)) = (shift_vars n m p) \<otimes>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> (pvar R (i + m))"
+      using A0'  shift_vars_indexed_pmult A2 assms(1) 
+      by blast
+    have A4: "eval_at_poly R (shift_vars n m (p \<Otimes> i)) (a @ b) = 
+              eval_at_poly R ( (shift_vars n m p) \<otimes>\<^bsub>R[\<X>\<^bsub>n+m\<^esub>]\<^esub> (pvar R (i + m))) (a@b)"
+      using A3 
+      by presburger
+    have A5: "a@b \<in> carrier (R\<^bsup>n+m\<^esup>)"
+      using assms(2) assms(3) cartesian_power_concat(2) by blast    
+    have A6: "eval_at_poly R (shift_vars n m (p \<Otimes> i)) (a @ b) = 
+              eval_at_poly R p b \<otimes> eval_at_poly R (pvar R (i + m)) (a @ b)"
+      using A5  A0' eval_at_point_mult[of "a@b" "n+m" "shift_vars n m p" "pvar R (i + m)"]
+      unfolding A4 by (metis A1 A2 Groups.add_ac(2) lessThan_iff local.pvar_closed nat_add_left_cancel_less shift_vars_closed)      
+    have A7: " eval_at_poly R (pvar R (i + m)) (a @ b) = (a@b)!(i+m)"
+    proof-
+      have "i < n"
+        using assms A2 by blast        
+      then have "i + m < n + m "
+        using add_less_cancel_right 
+        by blast
+      then show ?thesis 
+        using A5 eval_pvar[of "i+m" "n+m" "a@b"] 
+        by blast
+    qed
+    then  have A8: "eval_at_poly R (shift_vars n m (p \<Otimes> i)) (a @ b) = eval_at_poly R p b \<otimes> ((a @ b)!(i+m))"
+      using A6 by presburger
+    have A9: "eval_at_poly R (shift_vars n m (p \<Otimes> i)) (a @ b) = eval_at_poly R p b \<otimes> (b!i)"
+    proof-
+      have "length a = m"
+        using assms cartesian_power_car_memE by blast
+      then have "(a @ b)!(i+m) = b!i"
+        by (metis add.commute nth_append_length_plus)
+      then show ?thesis 
+        using A8 
+        by presburger
+    qed
+    show " eval_at_poly R (shift_vars n m (p \<Otimes> i)) (a @ b) = eval_at_poly R (p \<Otimes> i) b"
+    proof-
+      have "i < n"
+        using A2 assms 
+        by blast        
+      then have "eval_at_poly R (p \<Otimes> i) b = eval_at_poly R p b \<otimes> (b!i)"
+        using assms A0' eval_at_point_indexed_pmult
+        by blast
+      then show ?thesis using A9 
+        by presburger
+    qed
+  qed
+qed
+
+      
+text\<open>Evaluating a polynomial from a lower poly ring in a higher power:\<close>
+
+lemma poly_eval_cartesian_prod:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "b \<in> carrier (R\<^bsup>m\<^esup>)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "eval_at_point R a p = eval_at_point R (a@b) p"
+  apply(rule coord_ring_induct[of p n])
+  using assms apply blast
+proof-
+  have 0: "a@b \<in> carrier (R\<^bsup>n + m\<^esup>)"
+    using assms cartesian_product_closed' by blast
+  show "\<And>aa. aa \<in> carrier R \<Longrightarrow> eval_at_poly R (coord_const aa) a = eval_at_poly R (coord_const aa) (a @ b)"
+  proof- fix c assume "c \<in> carrier R"
+    show "eval_at_poly R (coord_const c) a = eval_at_poly R (coord_const c) (a @ b)"
+      using eval_at_point_const[of c a n] eval_at_point_const[of c "a@b" "n+m"] 0 
+        \<open>c \<in> carrier R\<close> assms(2) assms(1) by presburger     
+  qed
+  show "\<And>i Q. Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow>
+           eval_at_poly R Q a = eval_at_poly R Q (a @ b) \<Longrightarrow>
+           i < n \<Longrightarrow> eval_at_poly R (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) a = eval_at_poly R (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) (a @ b)"    
+  proof-
+  fix i Q
+  assume A0: "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])" 
+  assume A1: "eval_at_poly R Q a = eval_at_poly R Q (a @ b)"
+  assume A2: "i < n"
+  have LHS: "eval_at_poly R (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) a = eval_at_poly R Q a \<otimes> (a!i)"
+    by (metis A0 A2 assms eval_at_point_indexed_pmult pvar_indexed_pmult)
+  have RHS: "eval_at_poly R (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) (a @ b) = eval_at_poly R Q (a@b) \<otimes> ((a@b)!i)"
+    by (smt "0" A0 A2 add.commute eval_at_point_indexed_pmult le_add1 poly_ring_car_mono 
+      pvar_indexed_pmult subsetD trans_less_add2)
+  show "eval_at_poly R (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) a = eval_at_poly R (Q \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i) (a @ b)"   
+  proof-
+    have "length a > i" using A2 assms
+      using cartesian_power_car_memE by blast
+    then have "a!i = (a@b)!i"
+      by (metis nth_append)
+    then show ?thesis 
+      using LHS RHS A1 
+      by presburger
+  qed
+  qed
+  show "\<And>Q0 Q1.
+       Q0 \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow>
+       Q1 \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow>
+       eval_at_poly R Q0 a = eval_at_poly R Q0 (a @ b) \<Longrightarrow>
+       eval_at_poly R Q1 a = eval_at_poly R Q1 (a @ b) \<Longrightarrow>
+       eval_at_poly R (Q0 \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q1) a = eval_at_poly R (Q0 \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q1) (a @ b)"
+  proof-
+    fix Q0 Q1 
+    assume A0: "eval_at_poly R Q0 a = eval_at_poly R Q0 (a @ b)"
+    assume A1: "eval_at_poly R Q1 a = eval_at_poly R Q1 (a @ b)"
+    assume A2: "Q0 \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    assume A3: "Q1 \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    show "eval_at_poly R (Q0 \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q1) a = eval_at_poly R (Q0 \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q1) (a @ b)"
+      using A0 A1 A2 A3  assms eval_at_point_add[of _ n Q0 Q1] 0 unfolding coord_ring_def
+      by (metis (no_types, lifting) R.Pring_add_eq basic_trans_rules(31) coord_ring_def eval_at_point_add le_add1 poly_ring_car_mono)      
+  qed
+qed
+
+text\<open>Evaluating polynomials at points in higher powers:\<close>
+
+lemma eval_at_points_higher_pow:
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "k \<ge> n"
+  assumes "a \<in> carrier (R\<^bsup>k\<^esup>)"
+  shows "eval_at_point R a p = eval_at_point R (take n a) p"
+  using poly_eval_cartesian_prod[of "take n a" n "drop n a" "k - n" p] assms 
+  by (metis (no_types, lifting) append_take_drop_id cartesian_power_car_memE cartesian_power_car_memE''
+      cartesian_power_car_memI length_drop set_drop_subset subset_trans take_closed)
+
+
+subsection\<open> Diagonal sets in even powers of \<open>R\<close>\<close>
+
+text\<open>
+  In this section, by a diagonal set in $R^(2m)$ we will mean the set of points $(x,x)$,
+  where $x \in R^m$. This is slightly different from the standard definition. Introducing these 
+  sets will be useful for reasoning about multiplicative inverses of functions later on.
+\<close>
+
+definition diagonal :: "nat \<Rightarrow> 'a list set" where 
+"diagonal m = {x \<in> carrier (R\<^bsup>m+m\<^esup>). take m x = drop m x}"
+
+lemma diagonalE: 
+  assumes "x \<in> diagonal  m"
+  shows "x = (take m x)@(take m x)"
+        "x \<in> carrier (R\<^bsup>m+m\<^esup>)"
+        "take m x \<in> carrier (R\<^bsup>m\<^esup>)"
+        "\<And>i. i < m \<Longrightarrow> x!i = x!(i + m)"
+   apply (metis (mono_tags, lifting) append_take_drop_id assms(1) diagonal_def mem_Collect_eq )
+  using assms diagonal_def 
+  apply blast
+  apply(rule cartesian_power_car_memI)
+  using assms unfolding diagonal_def 
+  apply (metis (no_types, lifting) cartesian_power_car_memE le_add2 mem_Collect_eq take_closed)
+proof-
+  show "set (take m x) \<subseteq> carrier R"
+  proof fix a
+    assume "a \<in> set (take m x)"
+    then have "a \<in> set x"
+      by (meson in_set_takeD)
+    then show "a \<in> carrier R"
+      using assms unfolding diagonal_def using cartesian_power_car_memE'[of x] 
+      by (smt cartesian_power_car_memE in_set_conv_nth mem_Collect_eq)
+  qed
+  show "\<And>i. i < m \<Longrightarrow> x!i = x!(i + m)"
+  proof- fix i
+    assume A: "i < m"
+    have 0: "x = (take m x)@(take m x)"
+      using assms diagonal_def[of m] 
+      by (metis (mono_tags, lifting) append_take_drop_id mem_Collect_eq)
+    then have 1: "x!i = take m x ! i"
+      by (metis A nth_take)
+    have 2: "length x = m + m"
+      using assms(1) cartesian_power_car_memE diagonal_def by blast
+    have 3: "take m x = drop m x"
+      by (metis "0" append_take_drop_id same_append_eq)
+    have 4: "drop m x ! i = x ! (i + m)"
+      by (metis "2" add.commute le_add1 nth_drop)
+    then show "x!i = x!(i + m)"
+      using "1" "3" by presburger
+  qed
+qed
+
+lemma diagonalI: 
+  assumes "x = (take m x)@(take m x)"
+  assumes "take m x \<in> carrier (R\<^bsup>m\<^esup>)"
+  shows "x \<in> diagonal m"
+  unfolding diagonal_def using assms 
+  by (metis (mono_tags, lifting) append_eq_conv_conj cartesian_power_car_memE 
+      cartesian_power_car_memI'' length_append mem_Collect_eq)
+
+definition diag_def_poly :: "nat \<Rightarrow> nat \<Rightarrow>('a, nat) mvar_poly" where
+"diag_def_poly n i = pvar R i \<ominus>\<^bsub>coord_ring R (n + n)\<^esub> pvar R (i + n)"
+
+lemma diag_def_poly_closed:
+  assumes "i < n"
+  shows "diag_def_poly n i \<in> carrier (coord_ring R (n + n))"
+  using assms unfolding diag_def_poly_def  coord_ring_def
+  by (metis (no_types, lifting) MP.minus_closed add.assoc add_leD1 coord_ring_def less_add_eq_less local.pvar_closed nat_less_le not_add_less1)  
+
+lemma diag_def_poly_eval:
+  assumes "i < n"
+  assumes "x \<in> carrier (R\<^bsup>n+n\<^esup>)"
+  shows "eval_at_point R x (diag_def_poly n i)  = (x!i) \<ominus> (x!(i + n))"
+
+  using assms diag_def_poly_def[of n i]  
+        eval_at_point_subtract[of x "n + n" "pvar R i" "pvar R (i + n)"] eval_pvar[of i "n + n"]
+        eval_pvar[of "i+n" "n + n"] pvar_closed[of i "n + n"] pvar_closed[of "i + n" "n + n"] 
+  by (metis add_less_cancel_right trans_less_add2)
+
+definition diag_def_poly_set :: "nat \<Rightarrow> ('a, nat) mvar_poly set" where 
+"diag_def_poly_set n = diag_def_poly n ` {..<n}"
+
+lemma diag_def_poly_set_in_coord_ring:
+  shows "diag_def_poly_set n \<subseteq> carrier (coord_ring R (n + n))"
+proof fix x 
+  assume "x \<in> diag_def_poly_set n"
+  then obtain i where i_def: "i < n \<and> x = diag_def_poly n i"
+    unfolding diag_def_poly_set_def  
+    by blast   
+  then show "x \<in> carrier (coord_ring R (n + n))"
+    using diag_def_poly_closed
+    by blast
+qed
+
+lemma diag_def_poly_set_finite: 
+"finite (diag_def_poly_set n)"
+  unfolding diag_def_poly_set_def 
+  by blast
+
+lemma diag_def_poly_eval_at_diagonal:
+  assumes "x \<in> diagonal n"
+  assumes "i < n"
+  shows "eval_at_point R x (diag_def_poly n i) = \<zero>"
+proof-
+  have "x!i = x!(i + n)"
+    using assms diagonalE(4) by blast
+  then show ?thesis 
+    by (metis assms(1) assms(2) cartesian_power_car_memE cartesian_power_car_memE' cring_coord_rings.diag_def_poly_eval cring_coord_rings_axioms diagonalE(2) point_to_polysE point_to_polysE' pvar_trans_eval trans_less_add2)    
+qed
+
+lemma diagonal_as_affine_alg_set:
+  shows "diagonal n = affine_alg_set R (n + n) (diag_def_poly_set n)"
+proof
+  show "diagonal n \<subseteq> affine_alg_set R (n + n) (diag_def_poly_set n)"
+  proof fix x assume A: "x \<in> diagonal n"
+    show " x \<in> affine_alg_set R (n + n) (diag_def_poly_set n)"
+        apply(rule affine_alg_set_memI)
+        using A  diagonalE(2) apply blast
+        using diag_def_poly_eval_at_diagonal[of x] diag_def_poly_set_def[of n]
+              atLeastAtMost_iff[of _ 0 "n-1"] 
+        by (metis (no_types, lifting) A image_iff lessThan_iff)                     
+  qed
+  show "affine_alg_set R (n + n) (diag_def_poly_set n) \<subseteq> diagonal n"
+  proof fix x 
+    assume A: "x \<in> affine_alg_set R (n + n) (diag_def_poly_set n)"
+    show "x \<in> diagonal n"
+    proof(rule diagonalI)
+      show "x = take n x @ take n x"
+      proof-
+        have 0: "x = take n x @ drop n x"
+          by (metis append_take_drop_id)
+        have "take n x = drop n x"
+        proof-
+          have 0: "length x = n + n"
+            using A unfolding affine_alg_set_def  
+            using cartesian_power_car_memE by blast
+          then have 1: "length (take n x) = length (drop n x)"
+            using A 
+            by (metis (no_types, lifting) \<open>x = take n x @ drop n x\<close> 
+                add.commute add_right_cancel affine_alg_set_closed cartesian_power_car_memE 
+                le_add1 length_append subsetD take_closed)
+          have "\<And>i::nat. i < n \<Longrightarrow> (take n x)!i = (drop n x) ! i"
+          proof- fix i::nat assume A0: "i < n"
+            then have "i \<in> {..<n}" using atLeastAtMost_iff[of i 0 "n-1"]
+              by auto
+            then have "diag_def_poly n i \<in>  (diag_def_poly_set n)"
+              using diag_def_poly_set_def by blast
+            then have "eval_at_point R x (diag_def_poly n i) = \<zero>"
+              using A affine_alg_set_memE by blast
+            then have "x!i = x!(n + i)"
+              using A0 diag_def_poly_eval[of i n x] 
+              by (metis (no_types, lifting) A add.commute affine_alg_set_closed
+                  cartesian_power_car_memE' nat_add_left_cancel_less R.r_right_minus_eq subsetD trans_less_add2)
+            then show "take n x ! i =drop n x ! i"
+              by (metis "0" A0 le_add1 nth_drop nth_take)
+          qed
+          then show ?thesis using 0 
+            by (metis "1" \<open>x = take n x @ drop n x\<close> add_less_mono 
+                length_append less_not_refl linorder_neqE_nat nth_equalityI)
+        qed
+        then show ?thesis 
+          using 0 by metis   
+      qed
+      show "take n x \<in> carrier (R\<^bsup>n\<^esup>)"
+        using A unfolding affine_alg_set_def 
+        by (meson A affine_alg_set_closed le_add2 subset_eq take_closed)
+    qed
+  qed
+qed
+
+lemma diagonal_is_algebraic:
+  shows "is_algebraic R (n + n) (diagonal n)"
+  apply(rule is_algebraicI[of "diag_def_poly_set n"])
+  apply (simp add: diag_def_poly_set_finite)
+  using  diag_def_poly_set_in_coord_ring apply blast
+  by (simp add:  diagonal_as_affine_alg_set)
+
+end 
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Tuples of Functions\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition is_function_tuple :: "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a) list \<Rightarrow> bool" where 
+"is_function_tuple R n fs = (set fs \<subseteq> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R)"
+
+lemma is_function_tupleI:
+  assumes "(set fs \<subseteq> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R)"
+  shows "is_function_tuple R n fs "
+  by (simp add: assms is_function_tuple_def)
+
+lemma is_function_tuple_append:
+  assumes "is_function_tuple R n fs" 
+  assumes "is_function_tuple R n gs" 
+  shows "is_function_tuple R n (fs@gs)"
+  using assms is_function_tupleI set_append
+  by (simp add: is_function_tuple_def)
+
+lemma is_function_tuple_Cons:
+  assumes "is_function_tuple R n fs" 
+  assumes "f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R"
+  shows "is_function_tuple R n (f#fs)"
+  using assms is_function_tupleI  
+  by (simp add: assms(2) is_function_tuple_def)
+
+lemma is_function_tuple_snoc:
+  assumes "is_function_tuple R n fs" 
+  assumes "f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R"
+  shows "is_function_tuple R n (fs@[f])"
+  apply(rule is_function_tupleI)
+  by (metis (no_types) Un_subset_iff append_Nil assms(1) assms(2) is_function_tuple_Cons is_function_tuple_def set_append)
+
+lemma is_function_tuple_list_update:
+  assumes "is_function_tuple R n fs" 
+  assumes "f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R"
+  assumes "i < n"
+  shows "is_function_tuple R n (fs[i := f])"
+  apply(rule is_function_tupleI)
+  by (metis assms(1) assms(2) is_function_tuple_def set_update_subsetI)
+
+definition function_tuple_eval :: "'b \<Rightarrow> 'c \<Rightarrow> ('d \<Rightarrow> 'a) list \<Rightarrow> 'd \<Rightarrow> 'a list" where
+"function_tuple_eval R n fs x = map (\<lambda>f. f x) fs"
+
+lemma function_tuple_eval_closed:
+  assumes "is_function_tuple R n fs" 
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "function_tuple_eval R n fs x \<in> carrier (R\<^bsup>length fs\<^esup>)"
+  apply(rule cartesian_power_car_memI')
+  apply (metis function_tuple_eval_def length_map)
+proof- fix i assume "i < length fs"
+  then show "function_tuple_eval R n fs x ! i \<in> carrier R"
+    unfolding function_tuple_eval_def using assms unfolding is_function_tuple_def 
+  by (metis funcset_carrier nth_map nth_mem subsetD)
+qed
+
+definition coord_fun :: 
+  "('a, 'c) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'b list) \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> 'b" where 
+"coord_fun R n g i = (\<lambda>x \<in>  carrier (R\<^bsup>n\<^esup>). (g x) ! i)"
+
+lemma(in cring) map_is_coord_fun_tuple:
+  assumes "g \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow>\<^sub>E carrier (R\<^bsup>m\<^esup>)"
+  shows "g = (\<lambda> x \<in> carrier (R\<^bsup>n\<^esup>). function_tuple_eval R n (map (coord_fun R n g) [0..<m]) x)"
+proof
+  fix x 
+  show "g x = restrict (function_tuple_eval R n (map (coord_fun R n g) [0..<m])) (carrier (R\<^bsup>n\<^esup>)) x"
+  proof(cases "x \<in> carrier (R\<^bsup>n\<^esup>)")
+    case True
+    then have T0: "restrict (function_tuple_eval R n (map (coord_fun R n g) [0..<m])) (carrier (R\<^bsup>n\<^esup>)) x = 
+              function_tuple_eval R n (map (coord_fun R n g) [0..<m]) x"
+      by (meson restrict_apply')
+    have T1: "length (g x) = m"
+      by (metis PiE_mem True assms cartesian_power_car_memE)
+    have T2: "\<And>i. i < m \<Longrightarrow> (g x) ! i = (function_tuple_eval R n (map (coord_fun R n g) [0..<m]) x) ! i"
+      unfolding function_tuple_eval_def coord_fun_def 
+      using restrict_apply True T1 length_map map_nth nth_map by smt 
+    have T3: "length (function_tuple_eval R n (map (coord_fun R n g) [0..<m]) x) = m"
+      unfolding function_tuple_eval_def using length_map 
+      by (metis T1 map_nth)
+    show ?thesis using T1 T2 T3 
+      by (metis T0 nth_equalityI)
+  next
+    case False
+    then show ?thesis using assms unfolding restrict_def  
+      by (meson PiE_E)
+  qed
+qed
+
+definition function_tuple_comp :: 
+  "'c \<Rightarrow> ('a \<Rightarrow> 'd) list \<Rightarrow> ('d list \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" where
+"function_tuple_comp R fs f = f \<circ> (function_tuple_eval R (0::nat) fs)"
+
+lemma function_tuple_comp_closed:
+  assumes "f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R"
+  assumes "length fs = n"
+  assumes "is_function_tuple R m fs"
+  shows "function_tuple_comp R fs f \<in> carrier (R\<^bsup>m\<^esup>) \<rightarrow> carrier R"
+  unfolding function_tuple_comp_def
+  using assms 
+  by (smt Pi_iff comp_apply function_tuple_eval_closed function_tuple_eval_def)
+
+fun id_function_tuple where
+"id_function_tuple (R::('a,'b) partial_object_scheme) 0 = []"|
+"id_function_tuple R (Suc n) = id_function_tuple R n @ [(\<lambda>(x::'a list). x! n)] "
+
+lemma id_function_tuple_is_function_tuple:
+"\<And>k. k \<ge> n \<Longrightarrow> is_function_tuple R k (id_function_tuple R n)"
+  apply(induction n)
+  apply (simp add: is_function_tupleI)
+proof- fix n k
+  assume IH: "(\<And>k. n \<le> k \<Longrightarrow> is_function_tuple R k (id_function_tuple R n))"
+
+  assume A: "Suc n \<le> k"
+  have 0: "(\<lambda>a. a!n) \<in> carrier (R\<^bsup>k\<^esup>)  \<rightarrow> carrier R"
+    using A cartesian_power_car_memE' 
+    by (metis Pi_I Suc_le_lessD)
+  have 1: " is_function_tuple R k (id_function_tuple R n)"
+    using A IH  Suc_leD by blast
+  then show "is_function_tuple R k (id_function_tuple R (Suc n))"
+    using A  0 id_function_tuple.simps(2)[of R n] 
+          is_function_tuple_snoc[of R k "id_function_tuple R n" "\<lambda>a. a!n" ] 
+     by (simp add: "0")
+qed
+
+lemma id_function_tuple_is_function_tuple':
+"is_function_tuple R n (id_function_tuple R n)"
+by (simp add: id_function_tuple_is_function_tuple)
+    
+lemma id_function_tuple_eval_is_take:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "k \<le> n \<Longrightarrow> function_tuple_eval R n (id_function_tuple R k) a = take k a"
+  apply(induction k)
+  using assms  
+  apply (simp add: assms function_tuple_eval_def)
+proof- fix k
+  assume IH: "(k \<le>  n \<Longrightarrow> function_tuple_eval R n (id_function_tuple R k) a = take k a) "
+  assume A: "Suc k \<le> n"
+  then have 0: "function_tuple_eval R n (id_function_tuple R k) a = take k a "
+    using IH  Suc_leD 
+    by blast   
+  have  "function_tuple_eval R n (id_function_tuple R (Suc  k)) a
+          = function_tuple_eval R n (id_function_tuple R k) a @ [a!k]"
+    using id_function_tuple.simps(2)[of R k]  
+    by (simp add: function_tuple_eval_def)
+  then  show "function_tuple_eval R n (id_function_tuple R (Suc k)) a = take (Suc k) a"
+    by (metis "0" A Suc_le_lessD assms cartesian_power_car_memE take_Suc_conv_app_nth)
+qed
+  
+lemma id_function_tuple_eval_is_id:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "function_tuple_eval R n (id_function_tuple R n) a = a"
+  using assms  id_function_tuple_eval_is_take[of a R n n]
+  by (metis cartesian_power_car_memE order_refl take_all)
+
+text\<open>Composing a function tuple with a polynomial\<close>
+
+definition poly_function_tuple_comp :: 
+   "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a list \<Rightarrow> 'a) list \<Rightarrow> ('a, nat) mvar_poly \<Rightarrow> 'a list \<Rightarrow> 'a" where
+"poly_function_tuple_comp R n fs f = eval_at_poly R f \<circ> function_tuple_eval R n fs"
+
+context cring_coord_rings
+begin
+
+lemma poly_function_tuple_comp_closed:
+  assumes "is_function_tuple R n fs" 
+  assumes "f \<in> carrier (coord_ring R (length fs))"
+  shows "poly_function_tuple_comp R n fs f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier R"
+proof fix x assume A: "x \<in> carrier (R\<^bsup>n\<^esup>)" 
+  then show "poly_function_tuple_comp R n fs f x \<in> carrier R"
+    using assms function_tuple_eval_closed eval_at_point_closed
+    unfolding poly_function_tuple_comp_def 
+    by (metis comp_apply)
+qed
+
+lemma poly_function_tuple_comp_eq:
+  assumes "is_function_tuple R n fs" 
+  assumes "f \<in> carrier (coord_ring R (length fs))"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_function_tuple_comp R n fs f a = eval_at_poly R f ( function_tuple_eval R n fs a)"
+  unfolding poly_function_tuple_comp_def 
+  using comp_apply 
+  by metis
+  
+lemma poly_function_tuple_comp_constant:
+  assumes "is_function_tuple R n fs" 
+  assumes "a \<in> carrier R"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_function_tuple_comp R n fs (coord_const a) x = a"
+  unfolding poly_function_tuple_comp_def 
+  using assms comp_apply function_tuple_eval_closed
+  by (metis eval_at_point_const)
+
+lemma poly_function_tuple_comp_add:
+  assumes "is_function_tuple R n fs"
+  assumes "k \<le>length fs"
+  assumes "p \<in> carrier (coord_ring R k)"
+  assumes "Q \<in> carrier (coord_ring R k)"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_function_tuple_comp R n fs (p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q) x = 
+          (poly_function_tuple_comp R n fs p x) \<oplus> (poly_function_tuple_comp R n fs Q x)"
+proof-
+  have 0: "p \<in> carrier (coord_ring R (length fs))"
+    using assms poly_ring_car_mono[of k "length fs"]
+    by blast 
+  have 1: "Q \<in> carrier (coord_ring R (length fs))"
+    using assms poly_ring_car_mono[of k "length fs"]
+    by blast 
+  show ?thesis  
+    using assms(1) assms(5) 0 1 R.Pring_add_eq[of ]
+        poly_function_tuple_comp_eq
+        function_tuple_eval_closed[of R n fs x]  
+        eval_at_point_add[of "function_tuple_eval R n fs x" "length fs" p Q]
+   unfolding coord_ring_def by (metis R.Pring_add_closed)    
+qed    
+
+lemma poly_function_tuple_comp_mult:
+  assumes "is_function_tuple R n fs"
+  assumes "k \<le>length fs"
+  assumes "p \<in> carrier (coord_ring R k)"
+  assumes "Q \<in> carrier (coord_ring R k)"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_function_tuple_comp R n fs (p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q) x = 
+          (poly_function_tuple_comp R n fs p x) \<otimes> (poly_function_tuple_comp R n fs Q x)"
+proof-
+  have 0: "p \<in> carrier (coord_ring R (length fs))"
+    using assms poly_ring_car_mono[of k "length fs"]
+    by blast 
+  have 1: "Q \<in> carrier (coord_ring R (length fs))"
+    using assms poly_ring_car_mono[of k "length fs"]
+    by blast 
+  show ?thesis
+    using assms  0 1
+        poly_function_tuple_comp_eq
+        function_tuple_eval_closed[of R n fs x]  
+        eval_at_point_mult[of "function_tuple_eval R n fs x" "length fs" p Q]
+    unfolding coord_ring_def 
+    by (metis MP.m_closed R.Pring_mult_eq coord_ring_def)    
+qed
+
+lemma poly_function_tuple_comp_pvar:
+  assumes "is_function_tuple R n fs"
+  assumes "k < length fs"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  shows "poly_function_tuple_comp R n fs (pvar R k) x = (fs ! k) x"
+proof-
+  have "(map (\<lambda>f. f x) fs) \<in> carrier (R\<^bsup>length fs\<^esup>)"
+    using function_tuple_eval_closed[of R n fs x] 
+    unfolding function_tuple_eval_def
+    using assms(1) assms(3) by blast
+  then have "eval_at_poly R (pvar R k) (map (\<lambda>f. f x) fs)  = (fs! k) x"
+    using eval_pvar[of k "length fs" "(map (\<lambda>f. f x) fs)"] 
+    by (metis assms(2) nth_map)
+  then show ?thesis 
+    by (metis (mono_tags, lifting) assms(1) assms(2) assms(3) function_tuple_eval_def 
+        nth_map poly_function_tuple_comp_eq pvar_closed)
+qed
+
+end
+text\<open>The coordinate ring of polynomials indexed by natural numbers\<close>
+
+definition Coord_ring :: "('a, 'b) ring_scheme \<Rightarrow> ('a, ('a, nat) mvar_poly) module" where
+"Coord_ring R = Pring R (UNIV :: nat set)"
+
+
+text\<open>Some general closure lemmas for coordinate rings\<close>
+context cring_coord_rings
+begin
+lemma coord_ring_monom_term_closed:
+  assumes "a \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "b \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "a \<otimes>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> b[^]\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub>(n::nat) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  using assms  monoid.nat_pow_closed[of "(R[\<X>\<^bsub>n\<^esub>])"] 
+  unfolding coord_ring_def
+  by (meson R.Pring_is_monoid monoid.m_closed)
+
+lemma coord_ring_monom_term_plus_closed:
+  assumes "a \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "b \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "c \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "c \<oplus>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> a \<otimes>\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub> b[^]\<^bsub>(R[\<X>\<^bsub>n\<^esub>])\<^esub>(n::nat) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  using assms coord_ring_monom_term_closed R.Pring_add_closed
+  by blast
+
+end
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Generic Univariate Polynomials\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  By a generic univariate polynomial, we mean a polynomial in one variable whose coefficients are
+  coordinate functions over a ring. That is, a polynomial of the form:
+  \[f(t) = x_0 + x_1t + \dots + x_nt^n\]
+  Such a polynomial can be construed as an element of $R[x_0,..,x_n](t)$, or as an element of
+  $R[x_0,..,x_n, x_n{n+1}]$. We will intially define the latter version, and show that it can
+  easily be cast to the former using the function ``\texttt{IP\_to\_UP"}. Such a polynomial can be
+  cast to a univariate polynomial over the ring $R$ by substituting a tuple of ring elements for
+  the coefficients.  
+\<close>
+definition generic_poly_lt ::  "('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> ('a, nat) mvar_poly" where
+"generic_poly_lt R n = (pvar R (Suc n)) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> (pvar R 0)[^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n"
+
+fun generic_poly where
+"generic_poly R (0::nat) = pvar R 1"|
+"generic_poly R (Suc n) = (generic_poly R n) \<oplus>\<^bsub>(coord_ring R (n+3))\<^esub> generic_poly_lt R (Suc n)"
+
+
+context cring_coord_rings
+begin
+
+lemma generic_poly_lt_closed:
+"generic_poly_lt R n \<in> carrier (coord_ring R (Suc (Suc n)))"
+proof-
+  have 0: "(pvar R (Suc n)) \<in> carrier (coord_ring R (Suc (Suc n)))"
+    using pvar_closed 
+    by blast
+  have 1: " (pvar R 0) \<in> carrier (coord_ring R (Suc (Suc n)))"
+    using pvar_closed 
+    by blast
+  then have "(pvar R 0)[^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n \<in> carrier (coord_ring R (Suc (Suc n)))"
+    using monoid.nat_pow_closed 
+    unfolding coord_ring_def by (metis R.Pring_is_monoid)
+  then show ?thesis using 0 
+    unfolding coord_ring_def 
+    by (metis R.Pring_mult_closed coord_ring_def generic_poly_lt_def)    
+qed
+
+lemma generic_poly_lt_eval:
+  assumes "a \<in> carrier (R\<^bsup>n+2\<^esup>)"
+  shows "eval_at_point R a (generic_poly_lt R n) = a!(Suc n) \<otimes> (a!0)[^]n "
+proof-
+  have "(pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) \<in> carrier (coord_ring R (n + 2))"
+    using monoid.nat_pow_closed pvar_closed unfolding coord_ring_def
+    by (metis R.Pring_is_monoid add_2_eq_Suc' zero_less_Suc)
+  then have "eval_at_point R a (generic_poly_lt R n) =
+    eval_at_poly R (pvar R (Suc n)) a \<otimes> eval_at_poly R (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) a"
+    unfolding generic_poly_lt_def 
+    using assms pvar_closed[of "(Suc n)" "n + 2"] eval_at_point_mult[of a "n + 2" "pvar R (Suc n)" "(pvar R 0)[^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n"]
+    by (metis add_2_eq_Suc' lessI)  
+  then show ?thesis using assms 
+    by (metis add_2_eq_Suc' add_gr_0 eval_at_point_nat_pow eval_pvar lessI pvar_closed zero_less_numeral)
+qed  
+
+lemma generic_poly_closed:
+"generic_poly R n \<in> carrier (coord_ring R (Suc (Suc n)))"
+  apply(induction n)
+  using pvar_closed[of 1 "Suc (Suc n)"]
+  apply (metis One_nat_def generic_poly.simps(1) lessI pvar_closed)
+proof-
+  fix n assume IH: "generic_poly R n \<in> carrier (coord_ring R (Suc (Suc n)))"
+    have "generic_poly R n \<in> carrier (coord_ring R (Suc (Suc (Suc n))))"
+      using IH poly_ring_car_mono'[of "Suc (Suc n)"]
+      by blast
+    then show " generic_poly R (Suc n) \<in> carrier (coord_ring R (Suc (Suc (Suc n))))"
+      unfolding coord_ring_def 
+      using generic_poly.simps[of R] generic_poly_lt_closed[of n]
+      by (metis MP.add.m_closed R.Pring_add_eq coord_ring_def generic_poly_lt_closed)
+qed
+
+lemma generic_poly_closed':
+  assumes "k \<le>n"
+  shows "generic_poly R k \<in> carrier (coord_ring R (Suc (Suc n)))"
+by (meson Suc_le_mono assms generic_poly_closed poly_ring_car_mono subsetD)
+
+lemma generic_poly_eval_at_point:
+  assumes "a \<in> carrier (R\<^bsup>n+3\<^esup>)"
+  shows "eval_at_point R a (generic_poly R (Suc n)) = (eval_at_point R a (generic_poly R n)) \<oplus>
+                                                    (a!(n + 2)) \<otimes> (a!0)[^](Suc n)"
+proof-
+  have 0: "(generic_poly R n) \<in> carrier (coord_ring R (n + 3))"
+    using generic_poly_closed' 
+    by (metis Suc3_eq_add_3 add.commute eq_imp_le le_SucI)
+  then show ?thesis 
+    using generic_poly.simps(2) 
+          generic_poly_closed'[of n "n + 3"] 
+          generic_poly_lt_eval eval_at_point_add[of a "(n + 3)" "generic_poly R n"]  
+    by (metis (no_types, lifting) add.left_commute add_2_eq_Suc' assms 
+        generic_poly_lt_closed numeral_2_eq_2 numeral_3_eq_3 plus_1_eq_Suc)
+qed
+
+end
+
+text \<open>
+  We can turn points in $R^{n+1}$ into univariate polynomials with the associated coefficients 
+  via partial evaluation of the generic polynomials of degree $n$. \<close>
+
+definition ring_cfs_to_poly :: 
+"('a, 'b) ring_scheme \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> ('a, nat) mvar_poly" where
+"ring_cfs_to_poly R n as = coord_partial_eval R {1..<n+2} (\<zero>\<^bsub>R\<^esub>#as) (generic_poly R n)" 
+
+context cring_coord_rings
+begin
+
+lemma ring_cfs_to_poly_closed:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "ring_cfs_to_poly R n as \<in> carrier (coord_ring R 1)"
+proof-
+  have 0: "\<zero> # as \<in> carrier (R\<^bsup>n+2\<^esup>)"
+    apply(rule cartesian_power_car_memI)
+    using assms 
+    apply (metis add_2_eq_Suc' cartesian_power_car_memE length_Cons)
+    using assms 
+    by (metis cartesian_power_car_memE'' insert_subset list.simps(15) R.zero_closed)
+  then have 1: "coord_partial_eval R {1..<n + 2} (\<zero> # as) \<in> ring_hom (coord_ring R (n + 2)) (Pring R ({..<n + 2} - {1..<n + 2}))"
+    using coord_partial_eval_hom' by blast
+  have "({..<n + 2} - {1..<n + 2}) = {..<1}"
+    by auto 
+  then have 2: "coord_partial_eval R {1..<n + 2} (\<zero> # as) \<in> ring_hom (coord_ring R (n + 2)) (coord_ring R 1)"
+    using 1 unfolding coord_ring_def
+    by presburger    
+  then show ?thesis
+    unfolding ring_cfs_to_poly_def  coord_ring_def
+    by (metis "0" Diff_subset \<open>{..<n + 2} - {1..<n + 2} = {..<1}\<close> 
+      add_2_eq_Suc' coord_partial_eval_closed generic_poly_closed 
+      le_numeral_extra(4) lessThan_minus_lessThan lessThan_subset_iff)
+qed
+
+text\<open>Variant which maps to the univariate polynomial ring\<close>
+
+definition ring_cfs_to_univ_poly :: "nat \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> 'a" where
+"ring_cfs_to_univ_poly n as = IP_to_UP (0::nat) (ring_cfs_to_poly R n as)" 
+
+lemma ring_cfs_to_univ_poly_closed:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows  "ring_cfs_to_univ_poly n as \<in> carrier (UP R)"
+  unfolding ring_cfs_to_univ_poly_def apply(rule R.IP_to_UP_closed, rule R.is_cring)
+  using ring_cfs_to_poly_closed unfolding coord_ring_def 
+  using assms  by (metis One_nat_def lessThan_0 lessThan_Suc)
+
+lemma ring_cfs_to_poly_eq:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  assumes "k \<le>n"
+  shows  "ring_cfs_to_poly R k as = ring_cfs_to_poly R k (take (Suc k) as) "
+  unfolding ring_cfs_to_poly_def coord_partial_eval_def 
+  apply(rule R.poly_eval_eval_function_eq[of "(point_to_eval_map R (\<zero> # as))" "(point_to_eval_map R (\<zero> # take (Suc k) as))" "{1..<k + 2}" _ "{..<k + 2}"])   
+proof-
+  show "closed_fun R (point_to_eval_map R (\<zero> # as))"
+    apply(rule R.closed_funI)
+    using assms cartesian_power_car_memE[of as R "Suc n"] 
+    by (metis cartesian_power_car_memE'' nth_mem set_ConsD subset_code(1) R.zero_closed)
+  show "closed_fun R (\<lambda>i. if i < length (\<zero> # take (Suc k) as) then (\<zero> # take (Suc k) as) ! i else \<zero>)"
+    apply(rule R.closed_funI)
+    using assms 
+    by (metis cartesian_power_car_memE'' in_set_takeD nth_mem set_ConsD subset_code(1) R.zero_closed)
+  have 0: "length (\<zero> # as) \<ge> k + 2"
+    using assms 
+    by (metis Suc_le_mono add_2_eq_Suc' cartesian_power_car_memE length_Cons)
+  have 1: "length (\<zero> # take (Suc k) as) \<ge>k + 2"
+    using 0 
+    by (metis add_2_eq_Suc' assms(1) cartesian_power_car_memE 
+        impossible_Cons length_Cons not_less_eq_eq take_closed)
+  show "restrict (point_to_eval_map R (\<zero> # as)) {1..<k + 2} = restrict (point_to_eval_map R (\<zero> # take (Suc k) as)) {1..<k + 2}"
+  proof fix x 
+    show "restrict (point_to_eval_map R (\<zero> # as)) {1..<k + 2} x = restrict (point_to_eval_map R (\<zero> # take (Suc k) as)) {1..<k + 2} x"
+    proof(cases "x \<in> {1..<k + 2}")
+      case True
+      have 00: "restrict (point_to_eval_map R (\<zero> # as)) {1..<k + 2} x = (\<zero>#as)!x"
+        unfolding restrict_def 
+        by (metis "0" True atLeastLessThan_iff le_Suc_ex trans_less_add1)
+      have 11: "restrict (point_to_eval_map R (\<zero> # take (Suc k) as)) {1..<k + 2} x = (\<zero> # take (Suc k) as)!x"
+        unfolding restrict_def 
+        by (metis "1" True atLeastLessThan_iff le_Suc_ex trans_less_add1)
+      have 2: "(\<zero> # as) ! x = (\<zero> # take (Suc k) as) ! x"
+      proof-
+        obtain l where l_def: "Suc l = x"
+          using True
+          by (metis One_nat_def Suc_le_D atLeastLessThan_iff) 
+        have P1: "(\<zero> # as) ! x = as ! l"
+          using 0 True l_def 
+          by (meson nth_Cons_Suc)
+        have P0: "(\<zero> # take (Suc k) as) ! x = (take (Suc k) as) ! l"
+          using 1 True l_def 
+          by (meson nth_Cons_Suc)
+        have "l < Suc k"
+          using True l_def 
+          by (metis Suc_1 Suc_eq_plus1 Suc_less_SucD add_Suc_right atLeastLessThan_iff)
+        then have "(\<zero> # take (Suc k) as) ! x = as ! l"
+          using P0 
+          by (metis nth_take)
+        then show ?thesis
+          using P1 by metis  
+      qed
+      then show ?thesis using 00 11 True 
+        by presburger        
+    next
+      case False
+      then show ?thesis 
+        unfolding restrict_def 
+        by presburger       
+    qed
+  qed
+  show " generic_poly R k \<in> Pring_set R {..<k + 2}"
+   by (metis R.Pring_car add_2_eq_Suc' coord_ring_def generic_poly_closed)    
+qed
+
+lemma coord_partial_eval_generic_poly_lt:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "coord_partial_eval R {1..<n+2} (\<zero>\<^bsub>R\<^esub>#as) (generic_poly_lt R n) = 
+        poly_scalar_mult R (as!n) ((pvar R 0)[^]\<^bsub>coord_ring R (n+2)\<^esub> n)"
+proof-
+  have 0: "\<zero> # as \<in>  carrier (R\<^bsup>Suc (Suc n)\<^esup>)"
+    using assms cartesian_power_cons 
+    by (metis Suc_eq_plus1 R.zero_closed)
+  have 1: "pvar R (Suc n) \<in> Pring_set R {..<n + 2}"
+    using pvar_closed 
+    by (metis R.Pring_car add_2_eq_Suc' coord_ring_def lessI)         
+  have 2: " pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n \<in> Pring_set R {..<n + 2}"
+    using monoid.nat_pow_closed pvar_closed unfolding coord_ring_def 
+    using R.Pring_car R.Pring_is_monoid add_2_eq_Suc' zero_less_Suc
+    by (metis)
+  have 3: "poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R (Suc n) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) = 
+ (poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as)) (pvar R (Suc n))) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> 
+ (poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n))"
+    using 0 1 2 R.poly_eval_mult[of "pvar R (Suc n)" "{..<n+2}" " pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n"
+          "(point_to_eval_map R (\<zero> # as))" "{1..<n + 2}"] unfolding coord_ring_def  
+    by (smt R.Pring_mult cartesian_power_car_memE cartesian_power_car_memE' R.closed_funI R.zero_closed)
+  have 4: "poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R (Suc n) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) = 
+  (coord_const ((\<zero> # as)! (Suc n))) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> 
+  (poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n))"
+    using 0 3 point_to_eval_map_closed[of "(\<zero> # as)" "Suc (Suc n)"]   
+          R.poly_eval_index[of "(point_to_eval_map R (\<zero> # as))" "{1..<n + 2}" "Suc n"]
+     add_2_eq_Suc' atLeastLessThan_iff cartesian_power_car_memE le_neq_implies_less 
+        less_Suc_eq not_less_eq_eq not_less_zero numeral_1_eq_Suc_0 numeral_One var_to_IP_def 
+    by (smt local.one_neq_zero)
+  have 5: "pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n \<in> Pring_set R ({..<n + 2} - {1..<n + 2}) "
+  proof-
+    have "0 \<in> {..<n + 2} - {1..<n + 2}" by auto 
+    then have "pvar R 0 [^]\<^bsub>Pring R ({..<n + 2} - {1..<n + 2})\<^esub> n \<in> carrier (Pring R ({..<n + 2} - {1..<n + 2}))"
+      using R.Pring_var_closed[of 0 "{..<n + 2} - {1..<n + 2}"] R.Pring_is_monoid[of "{..<n + 2} - {1..<n + 2}"] 
+          monoid.nat_pow_closed[of "Pring R ({..<n + 2} - {1..<n + 2})" "pvar R 0" n ] 
+      by blast          
+    have "\<And>k::nat. (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> k) = (pvar R 0 [^]\<^bsub>Pring R ({..<n + 2} - {1..<n + 2})\<^esub>k)"
+    proof- fix k::nat show "(pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> k) = (pvar R 0 [^]\<^bsub>Pring R ({..<n + 2} - {1..<n + 2})\<^esub>k)"
+        apply(induction k)
+        using R.Pring_var_closed[of 0 "{..<(Suc (Suc n))}"] R.Pring_var_closed[of 0 "{..<n + 2} - {1..<n + 2}"]
+        unfolding coord_ring_def 
+        apply (metis Group.nat_pow_0 R.ring_axioms R.Pring_one)
+        using R.Pring_var_closed[of 0 "{..<(Suc (Suc n))}"] R.Pring_var_closed[of 0 "{..<n + 2} - {1..<n + 2}"]
+        nat_pow_def
+        by (metis R.Pring_mult_eq R.Pring_one_eq add_2_eq_Suc')
+    qed
+    then show ?thesis 
+      by (metis R.Pring_car \<open>pvar R 0 [^]\<^bsub>Pring R ({..<n + 2} - {1..<n + 2})\<^esub> n \<in> carrier (Pring R ({..<n + 2} - {1..<n + 2}))\<close>)
+  qed
+  have 6: "(poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))  
+               (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n)) = (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n)"
+    using 5 0 point_to_eval_map_closed[of "(\<zero> # as)" "Suc (Suc n)"]
+          R.poly_eval_trivial[of "(point_to_eval_map R (\<zero> # as))" "pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n" "{..<n + 2}" "{1..<n + 2}" ]
+    by blast
+  have 7: "poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R (Suc n) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) = 
+  (coord_const ((\<zero> # as)! (Suc n))) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> 
+     (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n)"
+    using 4 6 
+    by presburger
+  have 8: "(\<zero> # as) ! Suc n = as! n"
+    by (meson nth_Cons_Suc)
+  have 88: "(\<zero> # as) ! Suc n \<in> carrier R"
+    by (metis "8" assms cartesian_power_car_memE' less_Suc_eq)
+  have 9: "poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R (Suc n) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) = 
+    coord_const ((\<zero> # as) ! Suc n) \<Otimes>\<^sub>p pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n "
+    using R.poly_scalar_mult_eq[of "(\<zero> # as) ! Suc n" "pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n"] 
+    unfolding coord_ring_def  
+    by (metis (no_types, lifting) "7" R.Pring_mult coord_ring_def)     
+  have 10: "poly_scalar_mult R ((\<zero> # as) ! Suc n) (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) =
+    coord_const ((\<zero> # as) ! Suc n) \<Otimes>\<^sub>p pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n"
+    using 9 8 88 0 5 R.poly_scalar_mult_eq[of "(\<zero> # as) ! Suc n" "pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n" "({..<n + 2} - {1..<n + 2})"]  
+    by blast
+  have 11: "poly_scalar_mult R (as! n) (pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) =
+    coord_const ((\<zero> # as) ! Suc n) \<Otimes>\<^sub>p pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n"
+    using 10 8 
+    by metis 
+  have 12: "poly_eval R {1..<n + 2} (point_to_eval_map R (\<zero> # as))
+     (pvar R (Suc n) \<otimes>\<^bsub>coord_ring R (Suc (Suc n))\<^esub> pvar R 0 [^]\<^bsub>coord_ring R (Suc (Suc n))\<^esub> n) = 
+    poly_scalar_mult R (as ! n) ((pvar R 0) [^]\<^bsub>coord_ring R (n + 2)\<^esub> n)"
+    using 11 9 
+    by (metis add_2_eq_Suc')
+  then show ?thesis 
+    unfolding coord_partial_eval_def generic_poly_lt_def 
+    by blast
+qed
+
+lemma coord_partial_eval_generic_poly_lt':
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "coord_partial_eval R {1..<n+2} (\<zero>\<^bsub>R\<^esub>#as) (generic_poly_lt R n) = 
+        poly_scalar_mult R (as!n) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> n)"
+proof-
+  have 0: "coord_partial_eval R {1..<n+2} (\<zero>\<^bsub>R\<^esub>#as) (generic_poly_lt R n) = 
+        poly_scalar_mult R (as!n) ((pvar R 0)[^]\<^bsub>coord_ring R (n+2)\<^esub> n)"
+    using assms coord_partial_eval_generic_poly_lt by blast    
+  have 1: "\<And>k::nat. (pvar R 0)[^]\<^bsub>coord_ring R (n+2)\<^esub> k = (pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> k"
+  proof- fix k::nat show "(pvar R 0)[^]\<^bsub>coord_ring R (n+2)\<^esub> k = (pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> k"
+      apply(induction k)
+      unfolding coord_ring_def 
+       apply (metis Group.nat_pow_0 R.Pring_one_eq)
+      using nat_pow_def 
+      by (metis R.Pring_mult_eq R.Pring_one add_2_eq_Suc')
+  qed
+  then show ?thesis 
+    using "0" by presburger
+qed
+
+lemma ring_cfs_to_poly_decomp:
+  assumes "as \<in> carrier (R\<^bsup>Suc (Suc n)\<^esup>)"
+  shows "ring_cfs_to_poly R (Suc n) as = ring_cfs_to_poly R n as \<oplus>\<^bsub>coord_ring R 1\<^esub>
+        poly_scalar_mult R (as!(Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n))"
+proof-
+  have LHS: "ring_cfs_to_poly R (Suc n) as = 
+              coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly R n \<oplus>\<^bsub>coord_ring R (Suc (Suc (Suc n)))\<^esub> generic_poly_lt R (Suc n))" 
+    by (smt add_2_eq_Suc' add_Suc_right generic_poly.simps(2) numeral_2_eq_2 numeral_3_eq_3 ring_cfs_to_poly_def)   
+  have LHS': "ring_cfs_to_poly R (Suc n) as = 
+              coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly R n) \<oplus>\<^bsub>coord_ring R (Suc (Suc (Suc n)))\<^esub> 
+              coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly_lt R (Suc n))" 
+    using coord_partial_eval_add[of as "Suc n"]    
+    by (metis LHS add_2_eq_Suc' add_Suc_shift assms cartesian_power_cons 
+        coord_partial_eval_add generic_poly_closed' generic_poly_lt_closed le_add2 plus_1_eq_Suc R.zero_closed) 
+  have LHS'': "ring_cfs_to_poly R (Suc n) as = 
+              coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly R n) \<oplus>\<^bsub>coord_ring R (Suc (Suc (Suc n)))\<^esub> 
+              coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly_lt R (Suc n))" 
+    using coord_partial_eval_add[of as "Suc n"]    
+    by (metis LHS add_2_eq_Suc' add_Suc_shift assms cartesian_power_cons 
+        coord_partial_eval_add generic_poly_closed' generic_poly_lt_closed le_add2 plus_1_eq_Suc R.zero_closed)
+  have LHS''': "ring_cfs_to_poly R (Suc n) as =
+              coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly R n) \<oplus>\<^bsub>coord_ring R (Suc (Suc (Suc n)))\<^esub>  
+              poly_scalar_mult R (as! (Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n))" 
+    using LHS'' coord_partial_eval_generic_poly_lt'[of as "Suc n"] assms 
+    by presburger
+  have 0: "coord_partial_eval R {1..<Suc n + 2} (\<zero> # as) (generic_poly R n) = ring_cfs_to_poly R n as"
+  proof-
+    have 00: "(generic_poly R n) \<in> carrier (coord_ring R (n + 2))"
+      using add_2_eq_Suc' generic_poly_closed by presburger      
+    have 01: "\<one> \<noteq> \<zero>"
+      using one_neq_zero
+      by presburger
+    have 02: "(\<zero> # as) \<in> carrier (R\<^bsup>Suc (Suc n) + 1\<^esup>)"
+      using cartesian_power_cons[of as R "Suc (Suc n)" \<zero>] assms 
+      by blast
+    have 03: "closed_fun R (point_to_eval_map R (\<zero> # as))"
+      using point_to_eval_map_closed[of "\<zero>#as" "Suc (Suc (Suc n))"] 
+      by (metis "02" Suc_eq_plus1)     
+    have 04: "{1..<Suc n + 2} \<inter> {..<n + 2} = {1..<n + 2} \<inter> {..<n + 2}"
+      by auto 
+    show ?thesis
+      unfolding ring_cfs_to_poly_def coord_partial_eval_def 
+      using 04 03 02 01 00 R.Pring_car[of "{..<n + 2}"] assms 
+            R.poly_eval_eval_set_eq[of "point_to_eval_map R (\<zero> # as)" "{1..<Suc n + 2}"
+                                  "{..<n + 2}" "{1..<n + 2}" "(generic_poly R n)" ] 
+      by (metis coord_ring_def)      
+  qed
+  show ?thesis 
+    using generic_poly.simps(2)[of R n] coord_partial_eval_add LHS''' 0 
+    unfolding ring_cfs_to_poly_def 
+    by (metis R.Pring_add_eq coord_ring_def)   
+qed
+
+lemma ring_cfs_to_poly_decomp':
+  assumes "as \<in> carrier (R\<^bsup>Suc (Suc n)\<^esup>)"
+  shows "ring_cfs_to_poly R (Suc n) as = 
+                ring_cfs_to_poly R n (take (Suc n) as) \<oplus>\<^bsub>coord_ring R 1\<^esub>
+                poly_scalar_mult R (as!(Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n))"
+  using assms ring_cfs_to_poly_decomp[of as n] 
+        ring_cfs_to_poly_eq[of as "Suc n" n] le_eq_less_or_eq less_Suc_eq 
+  by presburger
+
+lemma ring_cfs_to_univ_poly_decomp':
+  assumes "as \<in> carrier (R\<^bsup>Suc (Suc n)\<^esup>)"
+  shows "ring_cfs_to_univ_poly (Suc n) as = 
+                ring_cfs_to_univ_poly n (take (Suc n) as) \<oplus>\<^bsub>UP R\<^esub>
+                 (as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))"
+proof-
+  have 00: "(pvar R 0 [^]\<^bsub>coord_ring R 1\<^esub> Suc n) \<in> carrier (Pring R {0})"
+    using pvar_closed[of 0 1] monoid.nat_pow_closed[of "coord_ring R 1"  _ n ]
+    unfolding coord_ring_def 
+    by (metis One_nat_def R.Pring_is_monoid lessThan_0 lessThan_Suc less_one monoid.nat_pow_closed)
+  have LHS: "ring_cfs_to_univ_poly (Suc n) as = 
+      IP_to_UP 0 (ring_cfs_to_poly R n (take (Suc n) as) \<oplus>\<^bsub>coord_ring R 1\<^esub>
+                poly_scalar_mult R (as!(Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n)))"
+    using assms ring_cfs_to_poly_decomp' 
+    unfolding ring_cfs_to_univ_poly_def 
+    by presburger
+  have LHS': "ring_cfs_to_univ_poly (Suc n) as = 
+      IP_to_UP 0 (ring_cfs_to_poly R n (take (Suc n) as)) \<oplus>\<^bsub>UP R\<^esub>
+      IP_to_UP 0 (poly_scalar_mult R (as!(Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n)))"
+  proof-
+    have 0: " ring_cfs_to_poly R n (take (Suc n) as) \<in> carrier (Pring R {0})"
+      by (metis One_nat_def assms coord_ring_def le_add2 lessThan_0 lessThan_Suc plus_1_eq_Suc ring_cfs_to_poly_closed take_closed)      
+    have 1: "as ! Suc n \<in> carrier R"
+      using assms cartesian_power_car_memE'[of as R "Suc (Suc n)"] 
+      by blast
+    have 2: "poly_scalar_mult R (as ! Suc n) (pvar R 0 [^]\<^bsub>coord_ring R 1\<^esub> Suc n) \<in> carrier (Pring R {0})"
+      using 1 00 R.Pring_car R.poly_scalar_mult_closed[of "(as ! Suc n)" "(pvar R 0 [^]\<^bsub>coord_ring R 1\<^esub> Suc n)" "{0}"] 
+      by blast
+    then show ?thesis      
+      using 0 1 2 UP_cring.IP_to_UP_add[of R "(ring_cfs_to_poly R n (take (Suc n) as))" "0"
+              "poly_scalar_mult R (as!(Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n))"] 
+      by (metis LHS One_nat_def UP_cring_def coord_ring_def R.is_cring lessThan_0 lessThan_Suc)
+  qed
+  have 0: "IP_to_UP 0 (ring_cfs_to_poly R n (take (Suc n) as)) = 
+           ring_cfs_to_univ_poly n  (take (Suc n) as)"
+    using ring_cfs_to_univ_poly_def
+    by presburger
+  have 1: "(mset_to_IP R (nat_to_mset 0 (Suc n))) = (pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n)"
+    unfolding coord_ring_def using  lessThan_iff less_one 
+    by (metis UP_cring.intro UP_cring.pvar_pow R.is_cring)    
+  have 2: "as ! Suc n \<in> carrier R"
+    using cartesian_power_car_memE' assms 
+    by blast
+  have 3: "IP_to_UP 0 (poly_scalar_mult R (as ! Suc n) (pvar R 0 [^]\<^bsub>coord_ring R 1\<^esub> Suc n)) =
+    as ! Suc n \<odot>\<^bsub>UP R\<^esub> IP_to_UP 0 (pvar R 0 [^]\<^bsub>coord_ring R 1\<^esub> Suc n)"   
+    using UP_cring.IP_to_UP_scalar_mult[of R "as!(Suc n)" "((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n))" 0]
+          "00" "2" unfolding coord_ring_def 
+    by (metis R.Pring_smult UP_cring.intro R.is_cring)                  
+  have 4: "IP_to_UP 0 (poly_scalar_mult R (as!(Suc n)) ((pvar R 0)[^]\<^bsub>coord_ring R 1\<^esub> (Suc n)))
+            = (as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))"
+  proof -
+    have "as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> Suc n = IP_to_UP (0::nat) (Mt (as ! Suc n) (nat_to_mset 0 (Suc n)))"
+      using 3 1 UP_cring.IP_to_UP_monom
+      by (metis UP_cring.intro R.is_cring)      
+    then show ?thesis
+      using \<open>mset_to_IP R (nat_to_mset 0 (Suc n)) = pvar R 0 [^]\<^bsub>coord_ring R 1\<^esub> Suc n\<close> 
+      by presburger
+  qed
+  then show ?thesis 
+    using "0" LHS' 
+    by presburger
+qed
+
+lemma ring_cfs_to_univ_poly_decomp:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  assumes "k < n"
+  shows "ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k)) as) = ring_cfs_to_univ_poly k (take (Suc k) as) 
+                              \<oplus>\<^bsub>UP R\<^esub> (as!(Suc k)) \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (Suc k)"
+proof- 
+  have 0: "(take (Suc (Suc k)) as) \<in> carrier (R\<^bsup>Suc (Suc k)\<^esup>)"
+    using assms  
+    by (meson Suc_leI Suc_mono take_closed)
+  then show ?thesis using ring_cfs_to_univ_poly_decomp'[of "take (Suc (Suc k)) as" k]
+    by (metis (no_types, lifting) Suc_leI assms(1) assms(2) cartesian_power_car_memE 
+        lessI less_SucI nth_take nth_take_lemma)
+qed
+
+lemma ring_cfs_to_univ_poly_degree:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows  "deg R (ring_cfs_to_univ_poly n as) \<le> n"
+         "as!n \<noteq> \<zero> \<Longrightarrow> deg R (ring_cfs_to_univ_poly n as) = n"
+proof-
+  have 0:"\<And>as. as \<in> carrier (R\<^bsup>Suc n\<^esup>)  \<Longrightarrow> 
+              deg R (ring_cfs_to_univ_poly n as) \<le> n \<and> (as!n \<noteq> \<zero> \<longrightarrow> deg R (ring_cfs_to_univ_poly n as) = n)"
+  proof(induction n)
+    case 0
+    show "\<And>as. as \<in> carrier (R\<^bsup>Suc 0\<^esup>) \<Longrightarrow>
+          deg R (ring_cfs_to_univ_poly 0 as) \<le> 0 \<and>
+          (as ! 0 \<noteq> \<zero> \<longrightarrow> deg R (ring_cfs_to_univ_poly 0 as) = 0)"
+    proof-
+      fix as assume A: "as \<in> carrier (R\<^bsup>Suc 0\<^esup>)"
+      have 0:"cring R"
+        by (simp add: R.is_cring)
+      have 1:"\<zero> # as \<in> carrier (R\<^bsup>2\<^esup>)"
+        using A cartesian_power_cons[of as R "Suc 0" \<zero>] 
+        by (metis numeral_1_eq_Suc_0 numeral_One one_add_one R.zero_closed)
+      have 2: "(\<zero> # as) ! 1 = as!0"
+        using A 
+        by (metis One_nat_def nth_Cons_Suc)
+      have 3: "1 \<in> {(1::nat)..<0 + 2} \<inter> {..<2}"
+        by auto 
+      have 4: "coord_partial_eval R {1::nat..<0 + 2} (\<zero> # as) (pvar R (1::nat)) =
+                 R.indexed_const (as!0)"
+      unfolding ring_cfs_to_univ_poly_def ring_cfs_to_poly_def
+        using 0 1 2 one_neq_zero UP_cring.IP_to_UP_indexed_const[of R "as!0" 0]  generic_poly.simps(1)[of R] coord_partial_eval_pvar[of "\<zero>#as" 2 "1::nat" "{1..<0+2}" ]
+        unfolding UP_cring_def  
+        using "3" by presburger
+      have 5: "ring_cfs_to_univ_poly 0 as = IP_to_UP (0::nat) (R.indexed_const (as ! 0))"
+        unfolding ring_cfs_to_univ_poly_def ring_cfs_to_poly_def 
+        using 4 generic_poly.simps(1)[of R]  
+        by presburger
+      hence "ring_cfs_to_univ_poly 0 as = to_polynomial R (as!0)"
+        by (metis A UP_cring.IP_to_UP_indexed_const UP_cring.intro  
+            cartesian_power_car_memE' R.is_cring lessI)
+    assume B: "as \<in> carrier (R\<^bsup>Suc 0\<^esup>) "
+    have 0: "(point_to_eval_map R (\<zero> # as) 1) = as!0"
+      by (metis B One_nat_def cartesian_power_car_memE impossible_Cons le_numeral_extra(4) 
+          linorder_neqE_nat nat_less_le nth_Cons_Suc)
+    have 1: "closed_fun R ((point_to_eval_map R (\<zero> # as)))"
+      apply(rule R.closed_funI) 
+      by (metis "0" B One_nat_def cartesian_power_car_memE cartesian_power_car_memE' 
+          length_Suc_conv less_Suc0 less_SucE nth_Cons_0 R.zero_closed)
+    have 2: "(1::nat) \<in> ({1..<0 + 2}::nat set)"     
+      by simp 
+    have 3: "poly_eval R {1..<0 + 2} (point_to_eval_map R (\<zero> # as)) (mset_to_IP R {#1#}) =
+              coord_const (point_to_eval_map R (\<zero> # as) 1)"
+      using generic_poly.simps(1)[of R] one_neq_zero
+      unfolding ring_cfs_to_poly_def  coord_partial_eval_def var_to_IP_def 
+      using 0 1 2 R.poly_eval_index[of "(point_to_eval_map R (\<zero> # as))" "{1..<0 + 2}" 1]
+      by (metis (no_types, lifting))
+    have 4: "(ring_cfs_to_poly R 0 as) = coord_const (as! 0)"
+      using 3 0 generic_poly.simps(1)[of R]
+      unfolding ring_cfs_to_poly_def  coord_partial_eval_def var_to_IP_def 
+      by presburger
+    have 5: "as! 0 \<in> carrier R"
+      using assms B cartesian_power_car_memE' by blast     
+    have 6: "(ring_cfs_to_univ_poly 0 as) = to_polynomial R (as! 0)"
+      unfolding ring_cfs_to_univ_poly_def ring_cfs_to_poly_def 
+      using 3 4 5 UP_cring.IP_to_UP_indexed_const[of R "as!0" "0::nat"]
+      unfolding coord_partial_eval_def 
+      by (smt "0" \<open>ring_cfs_to_univ_poly 0 as = to_polynomial R (as ! 0)\<close> generic_poly.simps(1) ring_cfs_to_univ_poly_def var_to_IP_def)     
+    then show " deg R (ring_cfs_to_univ_poly 0 as) \<le> 0 \<and> (as ! 0 \<noteq> \<zero> \<longrightarrow> deg R (ring_cfs_to_univ_poly 0 as) = 0)"
+      using  UP_cring.degree_to_poly[of R "as! 0"] 5  UP_cring_def[of R]
+      using R.is_cring by presburger      
+  qed
+  next
+  case (Suc n)
+    have 0: "(ring_cfs_to_univ_poly (Suc n) as) = ring_cfs_to_univ_poly n (take (Suc n) as) \<oplus>\<^bsub>UP R\<^esub>
+                 (as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))"
+    using ring_cfs_to_univ_poly_decomp' Suc.prems by blast
+   have 1: "(take (Suc n) as) \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+    using Suc.prems
+    by (meson le_Suc_eq take_closed)
+   have 2: "deg R (ring_cfs_to_univ_poly n (take (Suc n) as)) \<le> n"
+    using "1" Suc.IH 
+    by blast
+   have 3: "deg R ((as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))) \<le> Suc n"
+    using UP_cring.degree_monom[of R "as!(Suc n)" "Suc n"] UP_cring_def[of R] 
+    Suc.prems cartesian_power_car_memE' le_Suc_eq lessI less_imp_le_nat zero_less_Suc
+    by (metis R.is_cring)
+  have 4: "(X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) \<in> carrier (UP R)"
+  proof-
+    have 40: "Group.monoid (UP R)" 
+      using UP_cring_def[of R] UP_domain_def cring.axioms(1) ring.is_monoid
+      using UP_cring.UP_cring R.is_cring by blast
+    have 41: "X_poly R \<in> carrier (UP R)"
+      using UP_cring.X_closed[of R] UP_cring_def[of R] R.is_cring 
+      by blast 
+    show ?thesis
+      using monoid.nat_pow_closed[of "UP R" "X_poly R" "Suc n"] 40 41 
+      by blast 
+  qed
+  have 5: "deg R (ring_cfs_to_univ_poly (Suc n) as) \<le>Suc n"
+  proof(cases "as!(Suc n) = \<zero>")
+    case True
+    then have T0: "(as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) = \<zero>\<^bsub>UP R\<^esub>"
+      using 4 UP_ring.UP_smult_zero[of R "X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)"] UP_ring_def[of R] R.ring_axioms 
+      by presburger
+    then show ?thesis 
+      using UP_ring.deg_zero[of R] UP_ring_def[of R]  
+      by (metis "0" "1" "2" "3" UP_ring.UP_zero_closed UP_ring.bound_deg_sum le_SucI R.ring_axioms ring_cfs_to_univ_poly_closed)        
+  next
+    case False
+    have F0 : "as!(Suc n) \<in> carrier R"
+       by (metis Suc.prems cartesian_power_car_memE le_simps(1) lessI not_less_eq_eq poly_tuple_evalE poly_tuple_evalE' pushforward_by_pvar_list pvar_list_is_poly_tuple zero_less_Suc)     
+    have F1: "(as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) \<in> carrier (UP R)"
+      using F0 4 UP_ring.UP_smult_closed[of R "as!(Suc n)" "X_poly R [^]\<^bsub>UP R\<^esub> Suc n "] 
+            UP_ring_def[of R] assms R.ring_axioms 
+      by blast
+    have "deg R ((as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))) = Suc n"
+      using False UP_cring.degree_monom[of R "as!(Suc n)" "Suc n"] UP_cring_def[of R]
+         cartesian_power_car_memE' lessI 
+      using F0 R.is_cring 
+      by presburger            
+    then show ?thesis 
+      using UP_ring.degree_of_sum_diff_degree[of R "(as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))"
+               "ring_cfs_to_univ_poly n (take (Suc n) as)"] 1 2 4 UP_domain_def[of R] F1
+              ring_cfs_to_univ_poly_closed[of "take (Suc n) as" "Suc n"]  "0" "3"
+              UP_ring_def[of R] UP_cring_def[of R] 
+              UP_ring.equal_deg_sum less_Suc_eq_le ring_cfs_to_univ_poly_closed
+      by (metis R.ring_axioms)
+  qed
+  have 6: "(as ! (Suc n) \<noteq> \<zero> \<longrightarrow> deg R (ring_cfs_to_univ_poly (Suc n) as) = Suc n)"
+    proof 
+    assume F: "as ! (Suc n) \<noteq> \<zero> "
+    have F0 : "as!(Suc n) \<in> carrier R"
+      by (metis Suc.prems cartesian_power_car_memE le_simps(1) lessI not_less_eq_eq poly_tuple_evalE poly_tuple_evalE' pushforward_by_pvar_list pvar_list_is_poly_tuple zero_less_Suc)     
+    have F1: "(as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) \<in> carrier (UP R)"
+      using F0 4 UP_ring.UP_smult_closed[of R "as!(Suc n)" "X_poly R [^]\<^bsub>UP R\<^esub> Suc n "] 
+            UP_ring_def[of R] assms R.ring_axioms 
+      by blast
+    then have F2: "deg R ((as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc n))) = Suc n"
+      using F0 F UP_cring.degree_monom[of R "as!(Suc n)" "Suc n"] UP_cring_def[of R] R.is_cring 
+      by presburger
+    have F3: "ring_cfs_to_univ_poly n (take (Suc n) as) \<in> carrier (UP R)"
+      using "1" ring_cfs_to_univ_poly_closed 
+      by blast
+    show "deg R (ring_cfs_to_univ_poly (Suc n) as) = Suc n"
+      using UP_domain_def[of R] 0 F1 F2 F3 1 2 
+            UP_ring.degree_of_sum_diff_degree[of R "ring_cfs_to_univ_poly n (take (Suc n) as)" 
+                                                "as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> Suc n"] 
+      UP_ring.equal_deg_sum le_imp_less_Suc UP_ring_def[of R] UP_cring_def[of R]
+  by (metis R.ring_axioms)
+  qed
+  show ?case 
+    using "5" "6" by blast
+  qed
+  show "deg R (ring_cfs_to_univ_poly n as) \<le> n"
+    using 0 assms 
+    by blast
+  show "as ! n \<noteq> \<zero> \<Longrightarrow> deg R (ring_cfs_to_univ_poly n as) = n"
+    using 0 assms 
+    by blast
+qed
+
+lemma ring_cfs_to_univ_poly_constant:
+  assumes "as \<in> carrier (R\<^bsup>1\<^esup>)"
+  shows "ring_cfs_to_univ_poly 0 as = to_polynomial R (as!0)"
+proof-
+  have 0: "(1::nat) \<in> {1..<0 + 2}" 
+    by simp 
+  have 1: "closed_fun R (point_to_eval_map R (\<zero> # as))"
+    using assms 
+    by (smt cartesian_power_car_memE'' R.closed_funI nth_mem set_ConsD subset_code(1) R.zero_closed)    
+  have 2: "(point_to_eval_map R (\<zero> # as) (1::nat)) = as!0"
+    by (metis One_nat_def assms cartesian_power_car_memE impossible_Cons
+      le_numeral_extra(4) linorder_neqE_nat nat_less_le nth_Cons_Suc)
+  have 3: "as!0 \<in> carrier R"
+    using assms cartesian_power_car_memE' 
+    by blast
+  have "(poly_eval R {1::nat..<0 + 2} (point_to_eval_map R (\<zero> # as)) (generic_poly R 0)) = coord_const (point_to_eval_map R (\<zero> # as) 1)"
+    using generic_poly.simps(1)[of R] 0 1 one_not_zero 
+          cring.poly_eval_index[of R "point_to_eval_map R (\<zero> # as)" "{1..<0 + 2}" 1]
+    unfolding var_to_IP_def 
+    using R.is_cring local.one_neq_zero by presburger   
+  then have "(poly_eval R {1..<0 + 2} (point_to_eval_map R (\<zero> # as)) (generic_poly R 0)) = coord_const (as!0)"
+    using 2 
+    by presburger
+  then show ?thesis 
+    using 3
+    unfolding ring_cfs_to_univ_poly_def ring_cfs_to_poly_def coord_partial_eval_def 
+    by (metis UP_cring.IP_to_UP_indexed_const UP_cring.intro R.is_cring)
+qed
+
+lemma ring_cfs_to_univ_poly_top_coeff:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "(ring_cfs_to_univ_poly n as) n = as ! n"
+  proof(cases "n = 0")
+    case True
+    have 0: "as ! 0 \<in> carrier R"
+      using assms cartesian_power_car_memE' 
+      by blast
+    have 1: "to_polynomial R (as ! 0)  0 = as ! 0"
+      using assms cartesian_power_car_memE'[of as R "Suc n"] UP_ring.cfs_monom[of R]
+      unfolding to_polynomial_def UP_ring_def
+      using "0" R.ring_axioms by presburger
+    have "ring_cfs_to_univ_poly 0 as = to_polynomial R (as ! 0)"
+      using One_nat_def True assms ring_cfs_to_univ_poly_constant by presburger      
+    then show ?thesis 
+      using True 1 
+      by presburger
+  next
+    case False
+    obtain k where k_def: "Suc k = n"
+      using False 
+      by (metis lessI less_Suc_eq_0_disj)
+    have "ring_cfs_to_univ_poly (Suc k) as (Suc k) = as ! (Suc k)"
+    proof-
+      have 0: "ring_cfs_to_univ_poly (Suc k) as n = ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k))as) n"
+        by (metis assms(1) k_def le_Suc_eq ring_cfs_to_poly_eq ring_cfs_to_univ_poly_def)
+      have 1: "take (Suc (Suc k)) as \<in> carrier (R\<^bsup>Suc (Suc k)\<^esup>)"
+        using assms k_def take_closed 
+        by blast
+      have 2: "ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k))as) = 
+                ring_cfs_to_univ_poly k (take (Suc k) (take (Suc (Suc k)) as)) \<oplus>\<^bsub>UP R\<^esub>  (as!(Suc k))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc k))"
+        using 1 ring_cfs_to_univ_poly_decomp'[of "take (Suc (Suc k))as" k] assms  
+        by (metis cartesian_power_car_memE k_def nat_le_linear take_all)
+      have 3: "ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k))as) = 
+                ring_cfs_to_univ_poly k (take (Suc k) as) \<oplus>\<^bsub>UP R\<^esub>  (as!(Suc k))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc k))"
+        using 2  
+        by (metis assms(1) k_def le_Suc_eq ring_cfs_to_poly_eq ring_cfs_to_univ_poly_decomp' ring_cfs_to_univ_poly_def)
+      have 4: "deg R (ring_cfs_to_univ_poly k (take (Suc k) as)) \<le> k"
+        by (metis assms(1) dual_order.refl k_def le_SucI ring_cfs_to_univ_poly_degree(1) take_closed)
+      have 5: "(ring_cfs_to_univ_poly k (take (Suc k) as)) \<in> carrier (UP R)"
+        by (metis assms(1) k_def le_Suc_eq le_refl ring_cfs_to_univ_poly_closed take_closed)
+      have  6: "X_poly R [^]\<^bsub>UP R\<^esub> Suc k \<in> carrier (UP R)"
+        using monoid.nat_pow_closed[of "UP R" "X_poly R" "Suc k"]  domain_def ring.is_monoid[of "UP R"] 
+              UP_cring.X_closed[of R] UP_domain_def[of R]  UP_cring_def[of R] 
+              cring.axioms(1)   UP_cring.UP_cring 
+        using R.is_cring by blast
+      have 7: " (as!(Suc k))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc k)) \<in> carrier (UP R)"
+        using UP_ring.UP_smult_closed[of R "as!(Suc k)" " (X_poly R [^]\<^bsub>UP R\<^esub> (Suc k))"]
+              UP_ring_def[of R] domain_def 6 cartesian_power_car_memE'[of as R _ "Suc k"] 
+               assms(1) k_def R.ring_axioms by blast         
+      have 8:  "ring_cfs_to_univ_poly (Suc k) as (Suc k) = ( (as!(Suc k))\<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> (Suc k))) (Suc k)"
+        using 3 4 k_def 
+            "5"  7  UP_cring_def[of R] UP_ring_def[of R] add.r_cancel_one' assms(1)
+            cartesian_power_car_memE  le_eq_less_or_eq 
+            le_imp_less_Suc take_all R.zero_closed  UP_ring.UP_a_comm UP_ring.coeff_of_sum_diff_degree0 R.ring_axioms
+        by (metis (no_types, lifting))          
+      then show ?thesis using UP_cring_def[of R]  UP_cring.monom_coeff assms(1) cartesian_power_car_memE
+            k_def lessI point_to_eval_map_closed 
+        by (metis (no_types, lifting) cartesian_power_car_memE' R.is_cring)        
+    qed 
+    then show ?thesis 
+      using k_def False 
+      by blast
+  qed
+
+lemma(in UP_cring) monom_plus_lower_degree_top_coeff:
+  assumes "degree  p < n"
+  assumes "p \<in> carrier (UP R)"
+  assumes "a \<in> carrier R"
+  shows "(p \<oplus>\<^bsub>UP R\<^esub> (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> n)) n = a"
+proof-
+  have 0: "(a \<odot>\<^bsub>UP R\<^esub> (X_poly R [^]\<^bsub>UP R\<^esub> n)) \<in> carrier (UP R)"
+    using P.nat_pow_closed P_def X_closed assms(3) smult_closed 
+    by blast
+  have 1: "( (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> n) \<oplus>\<^bsub>UP R\<^esub> p) n = (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> n) n"
+    using "0" UP_ring.coeff_of_sum_diff_degree0[of R] UP_cring_def[of R] assms(1) assms(2)   
+    using is_UP_ring by blast
+  then show ?thesis 
+    using 0 assms  P_def UP_a_comm  UP_cring.monom_coeff  UP_cring_def[of R]
+    by (metis R_cring)
+qed
+
+lemma(in UP_cring) monom_closed:
+  assumes "a \<in> carrier R"
+  shows "a \<odot>\<^bsub>UP R\<^esub> ((X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat)) \<in> carrier (UP R)"
+  using P.nat_pow_closed P_def assms X_closed carrier_is_submodule submoduleE(4)
+  by blast
+
+lemma(in UP_cring) monom_bottom_coeff:
+  assumes "a \<in> carrier R"
+  assumes "n > 0"
+  shows "(a \<odot>\<^bsub>UP R\<^esub> ((X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat))) 0 = \<zero>"
+  using assms monom_coeff[of a n]  P_def local.monom_coeff 
+  by presburger
+
+lemma(in UP_cring) monom_plus_lower_degree_bottom_coeff:
+  assumes "0 < n"
+  assumes "p \<in> carrier (UP R)"
+  assumes "a \<in> carrier R"
+  shows "(p \<oplus>\<^bsub>UP R\<^esub> (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat))) 0 = p 0"
+proof-
+  have 0: "p 0 \<in> carrier R"
+    using assms(2) UP_ring_def is_UP_ring P_def cfs_closed by blast    
+  have 1: "(p \<oplus>\<^bsub>UP R\<^esub> (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat))) 0 = p 0 \<oplus> (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> n) 0"
+    using assms monom_closed[of a n] cfs_add[of p "(a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat))" 0]
+    unfolding P_def   
+    by blast
+  then have "(a \<odot>\<^bsub>UP R\<^esub> ((X_poly R) [^]\<^bsub>UP R\<^esub> n)) 0 = \<zero>"
+    using monom_bottom_coeff[of a n] P_def assms(1) assms(3) local.monom_coeff 
+    by blast   
+  then have 2: "(p \<oplus>\<^bsub>UP R\<^esub> (a \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (n::nat))) 0 = p 0 \<oplus> \<zero>"
+    using 1 by metis 
+  then show ?thesis 
+    using 0  R.add.l_cancel_one[of "p 0"] R.zero_closed 
+    by presburger
+qed
+
+lemma ring_cfs_to_univ_poly_bottom_coeff:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "(ring_cfs_to_univ_poly n as) 0 = as ! 0"
+proof-
+  have "\<And>as. as \<in> carrier (R\<^bsup>Suc n\<^esup>) \<Longrightarrow> (ring_cfs_to_univ_poly n as) 0 = as ! 0"
+    apply(induction n)
+    using ring_cfs_to_univ_poly_top_coeff apply blast
+  proof-
+    fix n as 
+    assume IH: "\<And>as. as \<in> carrier (R\<^bsup>Suc n\<^esup>) \<Longrightarrow> (ring_cfs_to_univ_poly n as) 0 = as ! 0"
+    assume A: "as \<in> carrier (R\<^bsup>Suc (Suc n)\<^esup>)"
+    show "ring_cfs_to_univ_poly (Suc n) as 0 = as ! 0"
+    proof-
+      have 0: "ring_cfs_to_univ_poly (Suc n) as = ring_cfs_to_univ_poly n (take (Suc n) as) \<oplus>\<^bsub>UP R\<^esub> (as!(Suc n))\<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (Suc n)"
+        using A ring_cfs_to_univ_poly_decomp'[of as n] 
+        by blast
+      have 1: "ring_cfs_to_univ_poly n (take (Suc n) as) \<in> carrier (UP R)"
+       by (meson A ring_cfs_to_univ_poly_closed R.is_cring le_Suc_eq take_closed)
+     have 2:"as ! Suc n \<in> carrier R"
+       using assms cartesian_power_car_memE'  A 
+       by blast
+     have 3: "(ring_cfs_to_univ_poly n (take (Suc n) as) \<oplus>\<^bsub>UP R\<^esub> as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) 0 =
+              ring_cfs_to_univ_poly n (take (Suc n) as) 0"
+     proof-
+       have "as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> Suc n \<in> carrier (UP R)"
+         by (meson "2" UP_cring.monom_closed UP_cring_def R.is_cring)
+       hence 30: "(ring_cfs_to_univ_poly n (take (Suc n) as) \<oplus>\<^bsub>UP R\<^esub> as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) 0 = 
+        (ring_cfs_to_univ_poly n (take (Suc n) as)) 0 \<oplus> (as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)) 0"
+         using A ring_cfs_to_univ_poly_closed[of "take (Suc n) as" "n"] take_closed[of "Suc n" "Suc (Suc n)" as R]
+              UP_ring.cfs_add[of R "ring_cfs_to_univ_poly n (take (Suc n) as)" "as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> (Suc n)"  0]
+         unfolding UP_ring_def 
+         using "1" R.ring_axioms by blast
+       have 31: "(as ! Suc n \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> Suc n) 0 = \<zero>"
+         by (metis (no_types, lifting) "2" Suc_neq_Zero UP_cring.monom_coeff UP_cring_def R.is_cring)
+       thus ?thesis using  30 2 
+         by (simp add: "1" UP_car_memE(1))         
+     qed
+     have 4: "(take (Suc n) as) \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+       by (meson A le_Suc_eq take_closed)
+     have 5: "ring_cfs_to_univ_poly n (take (Suc n) as) 0 = as!0"
+       using IH[of "(take (Suc n) as)"] 4 nth_take[of 0 "Suc n" as] less_Suc_eq_0_disj 
+       by presburger
+     then show ?thesis 
+        using 0 3 
+        by presburger
+    qed   
+  qed
+  then show ?thesis 
+    using assms 
+    by blast
+qed
+
+lemma ring_cfs_to_univ_poly_chain:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  assumes "l \<le> n"
+  shows "l \<le> k \<and> k \<le> n  \<Longrightarrow> (ring_cfs_to_univ_poly k (take (Suc k) as)) l = (ring_cfs_to_univ_poly l (take (Suc l) as)) l"
+  apply( induction k)
+   apply blast
+proof-
+  fix k 
+  assume IH: "(l \<le> k \<and> k \<le> n \<Longrightarrow> ring_cfs_to_univ_poly k (take (Suc k) as) l = ring_cfs_to_univ_poly l (take (Suc l) as) l)"
+  assume A: "l \<le> Suc k \<and> Suc k \<le> n"
+  show "ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k)) as) l = ring_cfs_to_univ_poly l (take (Suc l) as) l"
+  proof(cases "l = Suc k")
+    case True
+    then show ?thesis 
+      by blast
+  next
+    case False
+    then have "l \<le> k \<and> k \<le> n " 
+      using A le_Suc_eq 
+      by blast
+    then have 0: " ring_cfs_to_univ_poly k (take (Suc k) as) l = ring_cfs_to_univ_poly l (take (Suc l) as) l"
+      using IH 
+      by blast
+    have 1: "ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k)) as) = ring_cfs_to_univ_poly k (take (Suc k) as) 
+                              \<oplus>\<^bsub>UP R\<^esub> (as!(Suc k)) \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (Suc k)"
+      using assms A ring_cfs_to_univ_poly_decomp[of as n k] Suc_le_lessD 
+      by blast
+    have 2: "ring_cfs_to_univ_poly (Suc k) (take (Suc (Suc k)) as) l = ring_cfs_to_univ_poly k (take (Suc k) as) l 
+                              \<oplus>( (as!(Suc k)) \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (Suc k)) l"
+    proof-
+      have 21: "ring_cfs_to_univ_poly k (take (Suc k) as) \<in> carrier (UP R)"
+        by (meson A assms(1) le_SucI ring_cfs_to_univ_poly_closed take_closed)
+      have 22: "as ! Suc k \<odot>\<^bsub>UP R\<^esub> X_poly R [^]\<^bsub>UP R\<^esub> Suc k \<in> carrier (UP R)"
+        using UP_ring_def[of R] A UP_ring.monom_closed assms(1) cartesian_power_car_memE' less_Suc_eq_le
+              monoid.nat_pow_closed[of "UP R" "X_poly R" "Suc k"] 
+        unfolding X_poly_def 
+        by (metis UP_ring.UP_ring UP_ring.UP_smult_closed R.ring_axioms R.one_closed ring.is_monoid)
+      show ?thesis 
+        using 1 21 22 UP_ring.cfs_add[of R "ring_cfs_to_univ_poly k (take (Suc k) as)" "( (as!(Suc k)) \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (Suc k))" l]
+        UP_ring_def[of R] R.ring_axioms by presburger 
+    qed
+    have 3: "( (as!(Suc k)) \<odot>\<^bsub>UP R\<^esub> (X_poly R)[^]\<^bsub>UP R\<^esub> (Suc k)) l = \<zero>"
+      using UP_cring.monom_coeff[of R "as!(Suc k)"]  A False UP_cring_def assms(1) cartesian_power_car_memE' 
+      by (metis R.is_cring le_imp_less_Suc)
+    then show ?thesis 
+      using 2 
+      by (metis "0" Suc_le_mono assms(1) assms(2) cartesian_power_car_memE' lessI R.r_zero 
+          ring_cfs_to_univ_poly_top_coeff take_closed)
+  qed
+qed
+
+lemma ring_cfs_to_univ_poly_coeffs:
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  assumes "l \<le> n"
+  shows "(ring_cfs_to_univ_poly n as) l = (ring_cfs_to_univ_poly l (take (Suc l) as)) l"
+proof-
+  have "(take (Suc n) as) = as"
+    using assms 
+    by (metis cartesian_power_car_memE le_refl take_all)
+  then show ?thesis 
+    using ring_cfs_to_univ_poly_chain[of as n l n]
+    by (metis assms(1) assms(2) order_refl)
+qed
+
+lemma ring_cfs_to_univ_poly_coeffs':
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  assumes "l \<le> n"
+  shows "(ring_cfs_to_univ_poly n as) l = as! l"
+proof-
+  have 0: "(ring_cfs_to_univ_poly l (take (Suc l) as)) l = (take (Suc l) as) ! l"
+    by (meson Suc_le_mono assms(1) assms(2) ring_cfs_to_univ_poly_top_coeff take_closed)
+  have 1: "(take (Suc l) as) ! l = as! l"
+    using nth_take[of l "Suc l" as] 
+    by blast
+  then show ?thesis
+    using 0 assms ring_cfs_to_univ_poly_coeffs[of as n l] 
+    by presburger
+qed
+
+lemma ring_cfs_to_univ_poly_coeffs'':
+  assumes "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  shows "(ring_cfs_to_univ_poly n as) l = (if l \<le> n then as! l else \<zero>)"
+  apply(cases "l \<le>n")
+  apply (meson assms ring_cfs_to_univ_poly_coeffs')
+proof- assume "\<not> l \<le> n " then 
+  have A: "n < l" 
+    by auto 
+  have "deg R (ring_cfs_to_univ_poly n as) \<le> n"
+    using assms ring_cfs_to_univ_poly_degree(1) by blast    
+  then show ?thesis 
+    using A domain_def[of R]  deg_leE  assms le_less_trans ring_cfs_to_univ_poly_closed UP_car_memE(2) 
+    by auto
+qed
+end
+
+definition fun_tuple_to_univ_poly where
+"fun_tuple_to_univ_poly R n m fs x = cring_coord_rings.ring_cfs_to_univ_poly R m (function_tuple_eval R n fs x)"
+
+context cring_coord_rings
+begin
+
+lemma  fun_tuple_to_univ_poly_closed:
+  assumes "is_function_tuple R n fs"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "length fs = Suc m"
+  shows "fun_tuple_to_univ_poly R n m fs x \<in> carrier (UP R)"
+  unfolding fun_tuple_to_univ_poly_def 
+  using assms 
+        ring_cfs_to_univ_poly_closed[of "function_tuple_eval R n fs x" m] 
+        function_tuple_eval_closed[of R n fs x] 
+  by metis 
+
+lemma  fun_tuple_to_univ_poly_degree_bound:
+  assumes "is_function_tuple R n fs"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "length fs = Suc m"
+  shows "deg R (fun_tuple_to_univ_poly R n m fs x) \<le> m"
+  unfolding fun_tuple_to_univ_poly_def 
+  using ring_cfs_to_univ_poly_degree assms 
+  by (metis function_tuple_eval_closed)
+
+lemma  fun_tuple_to_univ_poly_degree:
+  assumes "is_function_tuple R n fs"
+  assumes "x \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "length fs = Suc m"
+  assumes "(fs!m) x \<noteq>\<zero>"
+  shows "deg R (fun_tuple_to_univ_poly R n m fs x) = m"
+  unfolding fun_tuple_to_univ_poly_def 
+  using ring_cfs_to_univ_poly_degree[of "function_tuple_eval R n fs x" m] 
+        assms 
+        function_tuple_eval_def
+        function_tuple_eval_closed[of R n fs x]
+  by (metis lessI nth_map)
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+subsection\<open>Factoring a Polynomial as a Univariate Polynomial over a Multivariable Polynomial Ring\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+definition pre_to_univ_poly_hom :: "nat \<Rightarrow> nat \<Rightarrow> ('a, (('a, nat) mvar_poly, nat) mvar_poly) ring_hom" where
+"pre_to_univ_poly_hom n i= MP.indexed_const (n-1) \<circ>
+                                    R.indexed_const"
+
+lemma pre_to_univ_poly_hom_is_hom:
+  assumes "i < n"
+  shows "ring_hom_ring R (Pring (coord_ring R (n-1)) {i}) (pre_to_univ_poly_hom n i)"
+  using ring_hom_trans[of R.indexed_const R "coord_ring R (n-1)" 
+                          "ring.indexed_const(Pring R ({..<n-1}))"
+                          "Pring (coord_ring R (n-1)) {i}"]
+                        R.indexed_const_ring_hom[of "{..<n-1}"]                      
+                        MP.indexed_const_ring_hom[of n "{..<n-1}"]
+                        ring_hom_ring.homh[of R "coord_ring R (n - 1)" "coord_const"]
+  unfolding ring_hom_ring_def[of R] 
+  by (smt MP.Pring_is_ring MP.indexed_const_ring_hom coord_ring_def pre_to_univ_poly_hom_def ring_hom_ring.homh ring_hom_ring_axioms_def)
+  
+definition pre_to_univ_poly_var_ass :: 
+  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (('a, nat) mvar_poly, nat) mvar_poly" where
+"pre_to_univ_poly_var_ass n i j =(if j < i then MP.indexed_const (n-1) (pvar R j) else 
+                                   (if j = i then pvar (coord_ring R (n-1)) i else 
+                                   (if j < n then MP.indexed_const (n-1) (pvar R (j - 1)) else 
+                                    \<zero>\<^bsub>Pring (coord_ring R (n-1)) {i}\<^esub>)))"
+
+lemma pre_to_univ_poly_var_ass_closed: 
+  assumes "i < n"
+  shows "closed_fun (Pring (coord_ring R (n-1)) {i}) (pre_to_univ_poly_var_ass n i)"
+proof fix j
+  show "pre_to_univ_poly_var_ass n i j \<in> carrier (Pring (coord_ring R (n - 1)) {i})"
+    unfolding pre_to_univ_poly_var_ass_def 
+    apply(cases "j < i")
+    using pvar_closed[of j n] assms cring.indexed_const_closed 
+    apply (metis (no_types, lifting) R.Pring_is_cring Suc_diff_1 Suc_le_eq coord_ring_def diff_diff_cancel R.is_cring less_imp_diff_less local.pvar_closed not_less0 not_less_eq_eq)    
+    apply(cases "j = i")
+    using assms apply (meson pvar_closed R.Pring_is_cring R.is_cring singletonI)    
+    apply(cases "j < n")
+    using pvar_closed[of "j-1" n] assms MP.indexed_const_closed R.Pring_is_cring Suc_diff_1 Suc_le_eq coord_ring_def R.is_cring pvar_closed neq0_conv not_le
+      apply (metis MP.Pring_var_closed singletonI)
+    using MP.Pring_is_ring[of "n-1" "{i}"] apply blast
+  by (smt MP.Pring_zero_closed MP.indexed_const_closed Suc_diff_1 Suc_le_eq le_eq_less_or_eq less_Suc_eq local.pvar_closed nat_induct) 
+qed
+
+lemma pre_to_univ_poly_var_ass_closed': 
+  assumes "i < n"
+  shows "(pre_to_univ_poly_var_ass n i) \<in> {..<n} \<rightarrow> carrier (Pring (coord_ring R (n-1)) {i})"
+  by (metis (no_types, lifting) Pi_iff UNIV_I assms pre_to_univ_poly_var_ass_closed)
+
+definition pre_to_univ_poly :: 
+  "nat \<Rightarrow> nat \<Rightarrow> (('a, nat) mvar_poly, (('a, nat) mvar_poly, nat) mvar_poly) ring_hom" where
+"pre_to_univ_poly (n::nat) (i::nat) = indexed_poly_induced_morphism {..<n} (Pring (coord_ring R (n-1)) {i})
+                                                         (pre_to_univ_poly_hom n i)
+                                                         (pre_to_univ_poly_var_ass n i)"
+
+lemma pre_to_univ_poly_is_hom:
+  assumes "i < n"
+  assumes "\<psi> = pre_to_univ_poly n i"
+  shows "ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (Pring (coord_ring R (n-1)) {i}) \<psi> "
+        "\<And>j. j < i \<Longrightarrow> \<psi> (pvar R j) = MP.indexed_const (n-1) (pvar R j)"
+        "\<psi> (pvar R i) = pvar (coord_ring R (n-1)) i"
+        "\<And>j. i < j \<and> j < n \<Longrightarrow> \<psi> (pvar R j) = MP.indexed_const (n-1) (pvar R (j - 1))"
+        "\<And>a. a \<in> carrier R \<Longrightarrow> \<psi> (coord_const a) = MP.indexed_const (n-1) (coord_const a)"
+        "\<And>p. p \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> pre_to_univ_poly n i p \<in> carrier (Pring (coord_ring R (n-1)) {i})"
+proof-
+  have 0: "cring (Pring (coord_ring R (n - 1)) {i})"
+    using MP.Pring_is_cring coord_cring_cring by blast    
+  have 1: "pre_to_univ_poly_var_ass n i \<in> {..<n} \<rightarrow> carrier (Pring (coord_ring R (n - 1)) {i})"
+    using Pi_iff assms(1) pre_to_univ_poly_var_ass_closed[of i n]
+    by blast
+  have 2: "ring_hom_ring R (Pring (coord_ring R (n - 1)) {i}) (pre_to_univ_poly_hom n i)"
+    using assms(1) pre_to_univ_poly_hom_is_hom by auto
+
+  show 3:"ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (Pring (coord_ring R (n-1)) {i}) \<psi> "
+  using R.Pring_universal_prop(1)[of "(Pring (coord_ring R (n-1)) {i})" "pre_to_univ_poly_var_ass n i"
+                                "{..<n}" "pre_to_univ_poly_hom n i" \<psi>] assms 0 1 2
+  unfolding pre_to_univ_poly_def 
+  by (metis coord_ring_def)
+  
+  show " \<And>j. j < i \<Longrightarrow>
+         \<psi> (pvar R j) = MP.indexed_const (n-1) (pvar R j)"
+  proof- 
+    fix j assume A: "j < i"
+    then have 00: "MP.indexed_const (n - 1) (pvar R j) = pre_to_univ_poly_var_ass n i j "
+      unfolding pre_to_univ_poly_var_ass_def by auto
+    have 01: "j \<in> {..<n}"
+      using assms A by auto
+    show "\<psi> (pvar R j) = MP.indexed_const (n-1) (pvar R j)" 
+    using R.Pring_universal_prop(2)[of "(Pring (coord_ring R (n-1)) {i})" "pre_to_univ_poly_var_ass n i"
+                                "{..<n}" "pre_to_univ_poly_hom n i" \<psi>] assms 0 1 2 01
+        MP.is_cring 
+    unfolding pre_to_univ_poly_def  00 unfolding coord_ring_def var_to_IP_def  
+    by blast
+  qed
+  show "\<psi> (pvar R i) = pvar (coord_ring R (n - 1)) i"
+    using R.Pring_universal_prop[of "(Pring (coord_ring R (n-1)) {i})" "pre_to_univ_poly_var_ass n i"
+                                "{..<n}" "pre_to_univ_poly_hom n i" \<psi>] assms 0 1 2
+    unfolding pre_to_univ_poly_def  coord_ring_def
+    using lessThan_iff less_not_refl pre_to_univ_poly_var_ass_def var_to_IP_def 
+    by (metis coord_ring_def)    
+  show "\<And>j. i < j \<and> j < n \<Longrightarrow> \<psi> (pvar R j) = MP.indexed_const (n - 1) (pvar R (j - 1))"
+    using R.Pring_universal_prop[of "(Pring (coord_ring R (n-1)) {i})" "pre_to_univ_poly_var_ass n i"
+                                "{..<n}" "pre_to_univ_poly_hom n i" \<psi>] assms 0 1 2
+    unfolding pre_to_univ_poly_def
+    using add_diff_inverse_nat lessThan_iff less_diff_conv less_imp_add_positive 
+        not_add_less1 pre_to_univ_poly_var_ass_def trans_less_add2 var_to_IP_def 
+    by (metis (no_types, lifting) coord_ring_def)    
+  show "\<And>a. a \<in> carrier R \<Longrightarrow> \<psi> (R.indexed_const a) = MP.indexed_const (n - 1) (R.indexed_const a)"
+    using R.Pring_universal_prop(3)[of "(Pring (coord_ring R (n-1)) {i})" "pre_to_univ_poly_var_ass n i"
+                                "{..<n}" "pre_to_univ_poly_hom n i" \<psi>] assms 0 1 2 comp_apply 
+    unfolding pre_to_univ_poly_def pre_to_univ_poly_hom_def
+    by metis
+  show "\<And>p. p \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> pre_to_univ_poly n i p \<in> carrier (Pring (coord_ring R (n - 1)) {i})"
+  proof-
+    fix p assume A: "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    have "\<psi> \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<rightarrow> carrier (Pring (coord_ring R (n - 1)) {i})"
+      using 3 unfolding ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def by blast  
+    then show " pre_to_univ_poly n i p \<in> carrier (Pring (coord_ring R (n - 1)) {i})"
+      using A assms 
+      by blast
+  qed
+qed   
+     
+lemma insert_at_index_closed:
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "x \<in> carrier R"
+  assumes "i \<le> n"
+  shows "insert_at_index a x i \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  apply(rule cartesian_power_car_memI')
+proof-
+  have 0: "length (take i a) = i"
+    using assms(1) assms(3) cartesian_power_car_memE take_closed by blast
+  have 1: "length (drop i a) = (n - i)"
+    using assms cartesian_power_car_memE length_drop 
+    by blast
+  then have "length (x # drop i a) = Suc (n - i)"    
+    by (metis length_Cons)
+  then show "length (insert_at_index a x i) = Suc n"
+    using 0 1 assms 
+    by (metis Suc_eq_plus1 cartesian_power_car_memE insert_at_index_length)   
+  show "\<And>ia. ia < Suc n \<Longrightarrow> insert_at_index a x i ! ia \<in> carrier R"
+  proof- fix j assume A: "j < Suc n"
+    show "insert_at_index a x i ! j \<in> carrier R"
+      apply(cases "j < i")
+       apply (metis A assms(1) assms(3) cartesian_power_car_memE cartesian_power_car_memE' insert_at_index_eq' le_imp_less_Suc less_Suc_eq not_less_eq)
+      apply(cases "j = i")
+       apply (metis assms(1) assms(2) assms(3) cartesian_power_car_memE insert_at_index_eq)
+    proof- assume A1: "\<not> j < i " "j \<noteq>i"
+      then have "i < j" by auto 
+      then have "(take i a @ x # drop i a) ! j = drop i a ! (j - (Suc i))"
+        by (metis "0" A1(1) Suc_diff_Suc nth_Cons_Suc nth_append)
+      then show "insert_at_index a x i ! j \<in> carrier R"
+        by (metis A \<open>i < j\<close> assms(1) cartesian_power_car_memE cartesian_power_car_memE' insert_at_index_eq'' less_Suc_eq_0_disj less_Suc_eq_le not_less0)
+    qed
+  qed
+qed
+        
+lemma  pre_to_univ_poly_eval: 
+  assumes "i < Suc n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "x \<in> carrier R"
+  assumes "as = insert_at_index a x i"
+  shows "eval_at_point R as p = eval_at_point R a (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda> i. coord_const x) (pre_to_univ_poly (Suc n) i p))"
+  apply(rule R.Pring_car_induct''[of p "{..<Suc n}"])
+  unfolding coord_ring_def 
+  apply (metis assms(2) coord_ring_def)
+proof-
+  have 0: "as \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+    using assms insert_at_index_closed 
+    by (meson less_Suc_eq_le)
+  show  " \<And>c. c \<in> carrier R \<Longrightarrow>
+         eval_at_point R as (R.indexed_const c) =
+         eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i (R.indexed_const c)))"
+  proof- fix c assume "c \<in> carrier R"
+    have 00: "eval_at_poly R (coord_const c) as = c"
+      using assms eval_at_point_const[of c as "Suc n"] "0" \<open>c \<in> carrier R\<close>
+      by blast
+    have 01: "closed_fun (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>n. coord_const x)"
+      using assms(4) R.indexed_const_closed 
+      by (metis Pi_I coord_ring_def)     
+    have 02: "(pre_to_univ_poly (Suc n) i (coord_const c)) = ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) (coord_const c)"
+      using pre_to_univ_poly_is_hom(5)[of i "Suc n" _ c] \<open>c \<in> carrier R\<close> assms(1) diff_Suc_1 
+      by (metis coord_ring_def)     
+    have 03: "(total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda> i. coord_const x) (pre_to_univ_poly (Suc n) i (coord_const c))) = 
+             coord_const c"    
+      using 01 cring.total_eval_const[of "R[\<X>\<^bsub>n\<^esub>]" "coord_const c" ]
+      by (smt "02" MP.total_eval_const \<open>c \<in> carrier R\<close> coord_ring_def cring.indexed_const_closed R.is_cring)
+    show " eval_at_point R as (R.indexed_const c) =
+         eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i (R.indexed_const c))) "
+      using assms 00 02 03 
+      by (metis \<open>c \<in> carrier R\<close> coord_ring_def eval_at_point_const)
+  qed
+  have 01: "closed_fun (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>n. coord_const x)"
+    using assms(4) R.indexed_const_closed 
+    by (metis Pi_I coord_ring_def)    
+  have 02: "ring_hom_ring (R[\<X>\<^bsub>Suc n\<^esub>]) (Pring (R[\<X>\<^bsub>n\<^esub>]) {i}) (pre_to_univ_poly (Suc n) i)"
+    using pre_to_univ_poly_is_hom(1)[of i "Suc n" ]  
+    by (simp add: assms)
+  show "\<And>p q. p \<in> carrier (Pring R {..<Suc n}) \<Longrightarrow>
+           q \<in> carrier (Pring R {..<Suc n}) \<Longrightarrow>
+           eval_at_point R as p = eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i p)) \<Longrightarrow>
+           eval_at_point R as q = eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i q)) \<Longrightarrow>
+           eval_at_point R as (p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q) =
+           eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q)))"
+    proof- fix p q assume A: "p \<in> carrier (Pring R {..<Suc n})"
+                           " q \<in> carrier (Pring R {..<Suc n})"
+                             "eval_at_point R as p = eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i p))"
+                             " eval_at_point R as q = eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i q))"
+      have 0: "eval_at_poly R (p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> q) as = 
+                eval_at_poly R p as \<oplus>\<^bsub>R\<^esub> eval_at_poly R q as"
+        using "0" A(1) A(2) eval_at_point_add unfolding coord_ring_def  
+        by blast  
+      have 1: "(total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> q))) = 
+                (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i p)) \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>
+                 (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i q))"
+      proof-
+        have 10: "pre_to_univ_poly (Suc n) i p \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+          using   pre_to_univ_poly_is_hom(6)[of i "Suc n"  _ p] 
+          unfolding coord_ring_def
+          by (metis A(1) assms(1) diff_Suc_1)
+        have 11: "pre_to_univ_poly (Suc n) i q \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+          using pre_to_univ_poly_is_hom(6)[of i "Suc n" _ q] 
+          unfolding coord_ring_def
+
+          by (metis A(2) assms(1) diff_Suc_1)
+        have 12: "(pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> q)) = 
+                  (pre_to_univ_poly (Suc n) i p \<oplus>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub> pre_to_univ_poly (Suc n) i q)"
+          using ring_hom_ring.homh A 02 ring_hom_add[of "pre_to_univ_poly (Suc n) i" "R[\<X>\<^bsub>Suc n\<^esub>] " "Pring (R[\<X>\<^bsub>n\<^esub>]) {i}"
+                    p q ] 
+          unfolding coord_ring_def
+
+          by blast
+          
+        show ?thesis
+
+          using 01 10 11 12  A cring.total_eval_add[of "R[\<X>\<^bsub>n\<^esub>]" "pre_to_univ_poly (Suc n) i p" "{i}"
+                                                       "pre_to_univ_poly (Suc n) i q" "\<lambda>i. coord_const x"]             
+               coord_cring_cring 
+          unfolding coord_ring_def
+
+          by smt          
+      qed
+     have 2: "eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> q))) a = 
+              eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i p)) a \<oplus>
+              eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i q)) a"
+     proof-
+       have 20: "pre_to_univ_poly (Suc n) i p \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i}) "
+         using A(1) 02 unfolding ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def          unfolding coord_ring_def
+         by blast 
+       have 21: "pre_to_univ_poly (Suc n) i q \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i}) " 
+         using A(2) 02 unfolding ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def           unfolding coord_ring_def
+         by blast 
+       have 22: "(total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i p)) \<in> 
+                  carrier (R[\<X>\<^bsub>n\<^esub>])"
+         using 21 01 A cring.total_eval_closed[of "R[\<X>\<^bsub>n\<^esub>]" "pre_to_univ_poly (Suc n) i p" 
+                                                "{i}" "\<lambda>i. coord_const x"] "20" coord_cring_cring 
+         by metis        
+       have 23: "(total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i q)) \<in> 
+                  carrier (R[\<X>\<^bsub>n\<^esub>])"
+         using cring.total_eval_closed[of "R[\<X>\<^bsub>n\<^esub>]" "pre_to_univ_poly (Suc n) i q" "{i}"
+                                        "\<lambda>i. coord_const x"]
+         by (metis "01" "21" coord_cring_cring)
+
+       show ?thesis
+         using "1" "22" "23" assms(3) eval_at_point_add by presburger
+     qed
+      show "eval_at_point R as (p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q) =
+           eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q)))"
+        using eval_at_point_add A 0 1 2 
+          unfolding coord_ring_def
+
+        by presburger
+    qed
+    fix p j
+    assume A: "p \<in> carrier (Pring R {..<Suc n})"  "j \<in> {..<Suc n}"
+      "eval_at_point R as p = eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i p))"
+    show "eval_at_point R as (p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R j) =
+       eval_at_point R a
+        (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R j)))"
+    proof-
+    have A0: "eval_at_poly R (p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar R j) as = 
+              eval_at_poly R p as \<otimes> as!j"
+    proof-
+      have "eval_at_poly R (pvar R j) as = as!j"
+        using A(2) 0 eval_pvar
+        by blast
+      then show ?thesis using A eval_at_point_mult[of as "Suc n" p "pvar R j" ] 0  
+        by (metis R.Pring_var_closed coord_ring_def)        
+    qed
+    have A1: "(pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar R j)) = 
+              (pre_to_univ_poly (Suc n) i p) \<otimes>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub> pre_to_univ_poly (Suc n) i (pvar R j)"
+      using A 02 ring_hom_ring.homh ring_hom_mult[of _ "R[\<X>\<^bsub>Suc n\<^esub>]"  _ p "pvar R j"] R.Pring_var_closed[of j "{..< Suc n}"] 
+      unfolding coord_ring_def 
+      by blast
+    have A2: "(total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar R j))) = 
+              (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i p ))\<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>
+              (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) ( pre_to_univ_poly (Suc n) i (pvar R j)))"
+    proof-
+      have A20: "pre_to_univ_poly (Suc n) i p \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+        using 02 A unfolding ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def 
+              unfolding coord_ring_def 
+
+        by blast
+      have A21: "pre_to_univ_poly (Suc n) i (pvar R j) \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+        using 02 A unfolding ring_hom_ring_def ring_hom_ring_axioms_def ring_hom_def 
+        using  R.Pring_var_closed[of j "{..< Suc n}"] 
+              unfolding coord_ring_def 
+
+        by blast
+      show ?thesis using A1 cring.total_eval_mult[of _ "pre_to_univ_poly (Suc n) i p"] 
+     
+          by (smt A20 A21 MP.closed_funI MP.total_eval_mult assms(4) coord_ring_def cring.indexed_const_closed R.is_cring)          
+    qed
+    have A3: "pre_to_univ_poly (Suc n) i p \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+      using 02 A ring_hom_ring.homh unfolding ring_hom_def
+            unfolding coord_ring_def 
+            by blast 
+    have A4: "pre_to_univ_poly (Suc n) i (pvar R j) \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+      using 02 A ring_hom_ring.homh R.Pring_var_closed[of j "{..< Suc n}"] unfolding ring_hom_def
+           unfolding coord_ring_def 
+
+      by blast
+    have A5: "total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i p ) \<in>
+              carrier (R[\<X>\<^bsub>n\<^esub>])"
+      using 01 cring.total_eval_closed[of "R[\<X>\<^bsub>n\<^esub>]" "pre_to_univ_poly (Suc n) i p " "{i}"]
+            A3 coord_cring_cring
+            unfolding coord_ring_def 
+            by smt
+    have A6: "total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j) ) \<in> 
+              carrier (R[\<X>\<^bsub>n\<^esub>])"
+      using 01 cring.total_eval_closed[of "R[\<X>\<^bsub>n\<^esub>]" "pre_to_univ_poly (Suc n) i (pvar R j) " "{i}"]
+            A4 coord_cring_cring 
+      unfolding coord_ring_def 
+      by smt
+    have A7: " eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar R j))) a
+            =  eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i p)) a \<otimes>
+               eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j))) a"
+      using eval_at_point_mult A5 A6 A2 assms(3) by presburger
+    have A8: "eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j))) a = 
+              as!j"
+    proof(cases "j = i")
+      case True
+      then have "pre_to_univ_poly (Suc n) i (pvar R j) = pvar (R[\<X>\<^bsub>n\<^esub>]) i"
+        using pre_to_univ_poly_is_hom(3)[of i "Suc n"] assms(1) diff_Suc_1 by presburger
+      then have "total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j)) = 
+                  coord_const x"
+        using cring.total_eval_var[of "R[\<X>\<^bsub>n\<^esub>]" "\<lambda>i. coord_const x"]
+              unfolding coord_ring_def 
+        by (smt "01" \<open>\<And>i. \<lbrakk>cring (R [\<X>\<^bsub>n\<^esub>]); (\<lambda>i. R.indexed_const x) \<in> UNIV \<rightarrow> carrier (R [\<X>\<^bsub>n\<^esub>])\<rbrakk> \<Longrightarrow> total_eval (R [\<X>\<^bsub>n\<^esub>]) (\<lambda>i. R.indexed_const x) (mset_to_IP (R [\<X>\<^bsub>n\<^esub>]) {#i#}) = R.indexed_const x\<close> coord_ring_def cring_coord_rings.coord_cring_cring cring_coord_rings_axioms var_to_IP_def)            
+      then have T0: "eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j))) a
+                 = x"
+        using eval_at_point_const 
+        by (metis assms(3) assms(4))
+      have T1: "as!j = x"
+        using assms 
+        by (metis True  assms(5)  cartesian_power_car_memE insert_at_index_eq le_eq_less_or_eq nat_le_linear
+        not_less_eq)
+      then show ?thesis  
+        using T0 by blast
+    next
+      case False
+      then show ?thesis
+      proof(cases "j < i")
+        case True
+      then have "pre_to_univ_poly (Suc n) i (pvar R j) = ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) (pvar R j)"
+        using pre_to_univ_poly_is_hom(2)[of i "Suc n"] assms(1) diff_Suc_1
+        unfolding coord_ring_def 
+        by presburger
+      then have "total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j)) = 
+                  pvar R j"
+        using cring.total_eval_const[of "R[\<X>\<^bsub>n\<^esub>]"] 
+        by (smt Suc_less_eq True assms(1) coord_cring_cring less_trans_Suc local.pvar_closed)        
+      then have T0: "eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j))) a
+                 = a!j"
+        using eval_pvar
+        by (metis Suc_less_eq True assms(1) assms(3) less_trans_Suc)       
+      have T1: "as!j = a!j"
+        using assms  
+        by (metis True assms(5) cartesian_power_car_memE insert_at_index_eq' less_Suc_eq_le)        
+        then show ?thesis 
+          using T0 by presburger
+      next
+        case F: False
+      then have "pre_to_univ_poly (Suc n) i (pvar R j) = ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) (pvar R (j-1))"
+        using pre_to_univ_poly_is_hom(4)[of i "Suc n"] assms(1) diff_Suc_1 
+           unfolding coord_ring_def 
+        by (metis A(2) False lessThan_iff linorder_neqE_nat)
+      then have "total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j)) = 
+                  pvar R (j-1)"
+        using cring.total_eval_const[of "R[\<X>\<^bsub>n\<^esub>]"] 
+        by (smt A(2) F False Suc_less_SucD add_diff_inverse_nat coord_cring_cring 
+            lessThan_iff less_one linorder_neqE_nat local.pvar_closed not_less0 plus_1_eq_Suc)                      
+      then have T0: "eval_at_poly R (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>i. coord_const x) (pre_to_univ_poly (Suc n) i (pvar R j))) a
+                 = a!(j-1)"
+        using eval_pvar[of "j-1" n a]
+        by (metis A(2) F False One_nat_def Suc_diff_Suc Suc_less_eq assms(3)
+            lessThan_iff linorder_neqE_nat minus_nat.diff_0 not_less0)
+      have T1: "as!j = a!(j-1)"
+      proof-
+        obtain k where k_def: "j = i + 1 + k"
+          using False F 
+          by (metis Nat.add_0_right less_imp_add_positive less_one
+              nat_neq_iff semiring_normalization_rules(25))
+        show "as!j = a!(j-1)"
+        proof-
+          have "length (take i a) = i"
+            using assms 
+            by (meson cartesian_power_car_memE less_Suc_eq_le take_closed)
+          then have "as!j = ( x # drop i a)!(k+1)"
+            using k_def assms 
+            unfolding coord_ring_def 
+            by (metis Suc_eq_plus1 add.assoc insert_at_index.simps nth_append_length_plus plus_1_eq_Suc)
+          have "length (drop i a) \<ge> k"
+          proof-
+            have "length (drop i a) = n - i"
+              using assms cartesian_power_car_memE length_drop 
+              by blast
+            then show ?thesis 
+              using assms k_def A(2) 
+              by (metis Suc_eq_plus1 add.commute diff_Suc_Suc lessThan_iff less_diff_conv less_imp_le_nat)
+          qed
+          then have "as!j = (drop i a)! k"
+            using assms k_def 
+            by (metis Nat.add_0_right One_nat_def \<open>as ! j = (x # drop i a) ! (k + 1)\<close> add_Suc_right nth_Cons_Suc)
+          then show ?thesis using k_def assms 
+            by (metis Nat.add_diff_assoc2 add_diff_cancel_right' cartesian_power_car_memE le_add2 less_Suc_eq_le nth_drop)
+        qed
+      qed
+      then show ?thesis 
+        using T0 by presburger
+      qed
+    qed
+    then show "eval_at_point R as (p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R j) =
+    eval_at_point R a (total_eval (Pring R {..<n}) (\<lambda>i. R.indexed_const x) (pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R j)))"      
+      using A(3) A0 A7
+      unfolding coord_ring_def 
+      by presburger
+  qed
+qed
+
+definition pre_to_univ_poly_inv_hom :: 
+    "nat \<Rightarrow> nat \<Rightarrow> (('a, nat) mvar_poly,('a, nat) mvar_poly) ring_hom" where
+"pre_to_univ_poly_inv_hom n i = R.relabel_vars {..<(n-1)} {..<n} (\<lambda>j. if j < i then j else j + 1)"
+
+lemma pre_to_univ_poly_inv_hom_is_hom:
+  assumes "i < Suc n"
+  shows "ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>Suc n\<^esub>]) (pre_to_univ_poly_inv_hom (Suc n) i)"
+proof-
+  have 0: "ring_hom_ring (R[\<X>\<^bsub>n\<^esub>]) (R[\<X>\<^bsub>Suc n\<^esub>]) (R.relabel_vars {..<n} {..<Suc n} (\<lambda>j. if j < i then j else j + 1))"
+    unfolding coord_ring_def 
+    apply(rule R.relabel_vars_is_morphism)
+    using assms 
+    by (smt Pi_I Suc_eq_plus1 add_less_cancel_right lessThan_iff less_Suc_eq)
+  then show ?thesis 
+    unfolding pre_to_univ_poly_inv_hom_def
+    by simp
+qed
+
+lemma pre_to_univ_poly_inv_hom_const:
+  assumes "i < Suc n" 
+  assumes "k \<in> carrier R"
+  shows "(pre_to_univ_poly_inv_hom (Suc n) i) (R.indexed_const k) = R.indexed_const k"
+proof-
+  have 0: "(R.relabel_vars {..<n} {..<Suc n} (\<lambda>j. if j < i then j else j + 1)) (R.indexed_const k) = R.indexed_const k"
+    unfolding coord_ring_def 
+    apply(rule R.relabel_vars_is_morphism)
+    using assms 
+    apply (smt Pi_I Suc_eq_plus1 add_less_cancel_right lessThan_iff less_Suc_eq)
+    using assms(2) by blast 
+  then show ?thesis 
+    unfolding pre_to_univ_poly_inv_hom_def
+    using diff_Suc_1 by presburger    
+qed
+
+lemma pre_to_univ_poly_inv_hom_pvar_0:
+  assumes "i < Suc n"
+  assumes "j < i"
+  shows "pre_to_univ_poly_inv_hom (Suc n) i (pvar R j) = 
+            pvar R j"
+  unfolding pre_to_univ_poly_inv_hom_def coord_ring_def
+  using R.relabel_vars_is_morphism(2)[of "\<lambda>j. if j < i then j else j + 1" "{..<n}" "{..< Suc n}" j]
+  by (smt Pi_I add.commute add_diff_cancel_left' assms(1) assms(2) 
+      lessThan_iff less_Suc_eq less_trans_Suc not_less_eq plus_1_eq_Suc)
+
+lemma pre_to_univ_poly_inv_hom_pvar_1:
+  assumes "i < Suc n"
+  assumes "i \<le> j"
+  assumes "j < n"
+  shows "pre_to_univ_poly_inv_hom (Suc n) i (pvar R j) = 
+            pvar R (j + 1)"
+  unfolding pre_to_univ_poly_inv_hom_def 
+  using assms R.relabel_vars_is_morphism(2)[of "\<lambda>j. if j < i then j else j + 1" "{..<n}" "{..< Suc n}" j]
+  by (smt Pi_I add.commute add_less_cancel_right diff_Suc_1 lessThan_iff less_Suc_eq not_le plus_1_eq_Suc) 
+ 
+definition pre_to_univ_poly_inv_var_ass ::
+  "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ('a, nat) mvar_poly" where
+"pre_to_univ_poly_inv_var_ass n i j =  pvar R i"
+
+lemma pre_to_univ_poly_inv_var_ass_closed: 
+  assumes "i < Suc n"
+  shows "pre_to_univ_poly_inv_var_ass (Suc n) i \<in> {i} \<rightarrow> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  by (metis Pi_I assms local.pvar_closed pre_to_univ_poly_inv_var_ass_def)
+
+definition pre_to_univ_poly_inv :: 
+  "nat \<Rightarrow> nat \<Rightarrow> ((('a, nat) mvar_poly, nat) mvar_poly,('a, nat) mvar_poly) ring_hom" where
+"pre_to_univ_poly_inv n i  = indexed_poly_induced_morphism {i} (R[\<X>\<^bsub>n\<^esub>])
+                                 (pre_to_univ_poly_inv_hom n i) (pre_to_univ_poly_inv_var_ass n i)"
+
+lemma pre_to_univ_poly_inv_is_hom: 
+  assumes "i < Suc n"
+  shows "ring_hom_ring (Pring (R[\<X>\<^bsub>n\<^esub>]) {i}) (R[\<X>\<^bsub>Suc n\<^esub>]) (pre_to_univ_poly_inv (Suc n) i)"
+  apply(rule cring.Pring_universal_prop[of _ _  "pre_to_univ_poly_inv_var_ass (Suc n) i" "{i}" "pre_to_univ_poly_inv_hom (Suc n) i"])
+  unfolding coord_ring_def
+  apply (simp add: R.Pring_is_cring R.is_cring)
+  apply (simp add: R.Pring_is_cring R.is_cring)
+  apply (metis Pi_I R.Pring_var_closed assms lessThan_iff pre_to_univ_poly_inv_var_ass_def)
+  apply (metis assms coord_ring_def pre_to_univ_poly_inv_hom_is_hom)
+  by (simp add: coord_ring_def pre_to_univ_poly_inv_def)
+
+lemma pre_to_univ_poly_inv_pvar: 
+  assumes "i < Suc n"
+  shows  "(pre_to_univ_poly_inv (Suc n) i) (pvar (R[\<X>\<^bsub>n\<^esub>]) i) = pvar R i"
+  using assms  cring.Pring_universal_prop[of "R[\<X>\<^bsub>n\<^esub>]" "R[\<X>\<^bsub>Suc n\<^esub>]" 
+                    "pre_to_univ_poly_inv_var_ass (Suc n) i" "{i}" "pre_to_univ_poly_inv_hom (Suc n) i"]
+  by (metis Pi_I coord_cring_cring cring_coord_rings.pre_to_univ_poly_inv_var_ass_def
+      cring_coord_rings_axioms local.pvar_closed pre_to_univ_poly_inv_def 
+      pre_to_univ_poly_inv_hom_is_hom singletonI var_to_IP_def)
+
+lemma pre_to_univ_poly_inv_const: 
+  assumes "i < Suc n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows  "(pre_to_univ_poly_inv (Suc n) i) (ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) p) = pre_to_univ_poly_inv_hom (Suc n) i p "
+  using assms  cring.Pring_universal_prop[of "R[\<X>\<^bsub>n\<^esub>]" "R[\<X>\<^bsub>Suc n\<^esub>]" 
+                    "pre_to_univ_poly_inv_var_ass (Suc n) i" "{i}" "pre_to_univ_poly_inv_hom (Suc n) i"]
+  by (metis Pi_I coord_cring_cring cring_coord_rings.pre_to_univ_poly_inv_var_ass_def
+      cring_coord_rings_axioms local.pvar_closed pre_to_univ_poly_inv_def pre_to_univ_poly_inv_hom_is_hom)
+  
+lemma pre_to_univ_poly_inverse:
+  assumes  "i < Suc n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i p) = p"
+  apply(rule R.Pring_car_induct''[of p "{..<Suc n}"])
+  using assms coord_ring_def  apply metis    
+proof-
+  show 0: " \<And>c. c \<in> carrier R \<Longrightarrow> pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i (coord_const c)) = coord_const c"
+  proof-
+    fix c assume A: "c \<in> carrier R"
+    have 0: "pre_to_univ_poly (Suc n) i (coord_const c) = 
+                MP.indexed_const n (coord_const c)"
+      using A assms(1) diff_Suc_1 pre_to_univ_poly_is_hom(5) by presburger
+    have 1: "(\<lambda>j. if j < i then j else j + 1) \<in> {..<n} \<rightarrow> {..<Suc n}"
+      by (smt Pi_I Suc_eq_plus1 add_less_cancel_right lessThan_iff less_Suc_eq)
+    have 2: "pre_to_univ_poly_inv_hom (Suc n) i (coord_const c) = coord_const c"
+      unfolding pre_to_univ_poly_inv_hom_def
+      using 1 R.relabel_vars_is_morphism(3)[of "(\<lambda>j. if j < i then j else j + 1)" "{..<n}" "{..<Suc n}" c] 
+     unfolding coord_ring_def 
+     using A diff_Suc_1 by presburger
+    show "pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i (coord_const c)) = coord_const c "
+      using 0 1 2 
+      by (metis (no_types, lifting) A R.indexed_const_closed assms(1) coord_ring_def pre_to_univ_poly_inv_const)      
+  qed
+  show 1: "\<And>p q. p \<in> carrier (Pring R {..<Suc n}) \<Longrightarrow>
+           q \<in> carrier (Pring R {..<Suc n}) \<Longrightarrow>
+           pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i p) =
+           p \<Longrightarrow>
+           pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i q) =
+           q \<Longrightarrow>
+           pre_to_univ_poly_inv (Suc n) i
+            (pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q)) =
+           p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q"
+  proof- fix p q assume A: "p \<in> carrier (Pring R {..<Suc n})"
+          "q \<in> carrier (Pring R {..<Suc n})"
+          "pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i p) = p"
+          "pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i q) = q"
+    have 0: "(pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> q)) = 
+            (pre_to_univ_poly (Suc n) i p) \<oplus>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub> pre_to_univ_poly (Suc n) i q"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] ring_hom_ring.homh ring_hom_add A
+      unfolding coord_ring_def 
+      by (metis (mono_tags, lifting) assms(1) diff_Suc_1)
+    have 1: "pre_to_univ_poly (Suc n) i p \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] A      
+      unfolding coord_ring_def 
+      by (metis assms(1) coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(6))
+    have 2: "pre_to_univ_poly (Suc n) i q \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] A
+      unfolding coord_ring_def 
+      by (metis assms(1) coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(6))      
+    show "pre_to_univ_poly_inv (Suc n) i
+            (pre_to_univ_poly (Suc n) i (p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q)) =
+           p \<oplus>\<^bsub>Pring R {..<Suc n}\<^esub> q"
+      using 0 1 2 A pre_to_univ_poly_inv_is_hom[of i n] ring_hom_ring.homh ring_hom_add
+      unfolding coord_ring_def      
+      by (smt assms(1))
+  qed
+  show "\<And>p ia.
+       p \<in> carrier (Pring R {..<Suc n}) \<Longrightarrow>
+       ia \<in> {..<Suc n} \<Longrightarrow>
+       pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i p) = p \<Longrightarrow>
+       pre_to_univ_poly_inv (Suc n) i
+        (pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R ia)) =
+       p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R ia"
+  proof- fix p j 
+    assume A: " p \<in> carrier (Pring R {..<Suc n})"  "j \<in> {..<Suc n}"
+           "pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i p) = p "
+    have 0: "(pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> pvar R j)) 
+            = (pre_to_univ_poly (Suc n) i p) \<otimes>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub> pre_to_univ_poly (Suc n) i (pvar  R j)"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] ring_hom_ring.homh ring_hom_mult A
+      unfolding coord_ring_def
+      by (metis R.Pring_var_closed assms(1) diff_Suc_1)
+    have 1: "pre_to_univ_poly (Suc n) i p \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] A    
+      unfolding coord_ring_def
+      by (metis assms(1) coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(6))
+    have 1: "pre_to_univ_poly (Suc n) i (pvar R j) \<in> carrier (Pring (R[\<X>\<^bsub>n\<^esub>]) {i})"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] A      
+      unfolding coord_ring_def
+      by (metis R.Pring_var_closed assms(1) coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(6))
+    have 2: "pre_to_univ_poly_inv (Suc n) i (pre_to_univ_poly (Suc n) i (pvar R j)) = pvar R j"   
+    proof(cases "j = i")
+      case True
+      then have "(pre_to_univ_poly (Suc n) i (pvar R j)) = pvar (R[\<X>\<^bsub>n\<^esub>]) j"
+        using pre_to_univ_poly_is_hom(3)[of i "Suc n"] assms(1) diff_Suc_1 by presburger
+      then show ?thesis 
+      unfolding coord_ring_def
+      using True \<open>pre_to_univ_poly (Suc n) i (pvar R j) = pvar (R[\<X>\<^bsub>n\<^esub>]) j\<close> assms(1) pre_to_univ_poly_inv_pvar by presburger
+    next
+      case False
+      show ?thesis 
+      proof(cases "j < i")
+        case True
+        then have "(pre_to_univ_poly (Suc n) i (pvar R j)) = ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) (pvar R j)"
+          using pre_to_univ_poly_is_hom(2) [of i "Suc n"] assms(1) diff_Suc_1 
+           unfolding coord_ring_def
+
+          by presburger
+        then show ?thesis 
+          using pre_to_univ_poly_inv_const[of i n "(pvar R j)"]
+                pre_to_univ_poly_inv_hom_pvar_0[of i n j]
+          by (metis Suc_less_eq True assms(1) less_trans_Suc local.pvar_closed)
+      next
+        case F: False
+        then have "(pre_to_univ_poly (Suc n) i (pvar R j)) = ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) (pvar R (j-1))"
+          using pre_to_univ_poly_is_hom(4)[of i "Suc n"] assms(1) diff_Suc_1 
+               unfolding coord_ring_def
+ by (metis A(2) False lessThan_iff linorder_neqE_nat)
+        then show ?thesis 
+          using pre_to_univ_poly_inv_const[of i n "(pvar R (j-1))"]
+                pre_to_univ_poly_inv_hom_pvar_0[of i n "j-1"]
+          by (metis (no_types, lifting) A(2) F False One_nat_def Suc_eq_plus1 add_diff_inverse_nat 
+              assms(1) le_neq_implies_less lessThan_iff less_one local.pvar_closed nat_le_linear 
+              not_less_eq plus_1_eq_Suc pre_to_univ_poly_inv_hom_pvar_1)        
+      qed
+    qed
+    show "pre_to_univ_poly_inv (Suc n) i
+        (pre_to_univ_poly (Suc n) i (p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R j)) =
+       p \<otimes>\<^bsub>Pring R {..<Suc n}\<^esub> pvar R j"
+      using 0 1 2 A pre_to_univ_poly_inv_is_hom[of i n] 
+            ring_hom_ring.homh[of _ _ "pre_to_univ_poly_inv (Suc n) i "] 
+            ring_hom_mult[of "pre_to_univ_poly_inv (Suc n) i "]
+      unfolding coord_ring_def 
+      by (smt assms(1) coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(6))
+  qed
+qed
+
+lemma coord_ring_car_induct:
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  assumes "\<And>c. c \<in> carrier R \<Longrightarrow> A (R.indexed_const c)"
+  assumes "\<And>p q. p \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> q \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> A p \<Longrightarrow> A q \<Longrightarrow> A (p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> q)"
+  assumes "\<And>p i. p \<in> carrier (R[\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> i < n \<Longrightarrow> A p \<Longrightarrow> A (p \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> pvar R i)"
+  shows "A Q"
+  unfolding coord_ring_def apply(rule R.Pring_car_induct''[of _ "{..<n}"])
+  apply (metis assms(1) coord_ring_def)
+  using assms(2) apply auto[1]
+  apply (metis assms(3) coord_ring_def)
+  by (metis assms(4) coord_ring_def lessThan_iff)
+
+lemma pre_to_univ_poly_inverse':
+  assumes  "i < Suc n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) = MP.indexed_const n p"
+  apply(rule coord_ring_car_induct[of _ n])
+  using assms(2) apply blast
+proof-
+  show "\<And>c. c \<in> carrier R \<Longrightarrow>
+         pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (R.indexed_const c))) =
+         MP.indexed_const n (R.indexed_const c)"
+  proof- fix k assume A: "k \<in> carrier R"
+    have 0: "R.indexed_const k \<in> carrier (R [\<X>\<^bsub>n\<^esub>])"
+      using A 
+      by (metis coord_ring_def R.indexed_const_closed)
+    have 1: "pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (R.indexed_const k)) = pre_to_univ_poly_inv_hom (Suc n) i (R.indexed_const k)"
+      using 0 assms pre_to_univ_poly_inv_const[of i n "R.indexed_const k"]
+      by linarith
+    have "pre_to_univ_poly_inv_hom (Suc n) i (R.indexed_const k) = R.indexed_const k"
+      using A pre_to_univ_poly_inv_hom_const[of i n k] assms
+      by blast
+    thus "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (R.indexed_const k))) = MP.indexed_const n (R.indexed_const k) "
+      using 1 
+      by (metis A assms(1) coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(5))
+  qed
+  show "\<And>p q. p \<in> carrier (R [\<X>\<^bsub>n\<^esub>]) \<Longrightarrow>
+           q \<in> carrier (R [\<X>\<^bsub>n\<^esub>]) \<Longrightarrow>
+           pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) = MP.indexed_const n p \<Longrightarrow>
+           pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n q)) = MP.indexed_const n q \<Longrightarrow>
+           pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<oplus>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> q))) = MP.indexed_const n (p \<oplus>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> q)"
+  proof- fix p Q
+    assume A: "p \<in> carrier (R [\<X>\<^bsub>n\<^esub>]) "
+           "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) = MP.indexed_const n p"
+           "Q \<in> carrier (R [\<X>\<^bsub>n\<^esub>])"
+           "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n Q)) = MP.indexed_const n Q "
+    have 0: "p \<Oplus> Q = p \<oplus>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> Q"
+      by (metis R.Pring_add coord_ring_def)
+    have 1: "MP.indexed_const n (p \<Oplus> Q) = (MP.indexed_const n p) \<oplus>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub>(MP.indexed_const n Q)"
+      by (metis "0" MP.Pring_add MP.indexed_padd_const)
+    have 2: "MP.indexed_const n p \<in> carrier (Pring (R [\<X>\<^bsub>n\<^esub>]) {i})"
+      using A unfolding coord_ring_def 
+      by (metis MP.indexed_const_closed R.Pring_car coord_ring_def)
+    have 3: "MP.indexed_const n Q \<in> carrier (Pring (R [\<X>\<^bsub>n\<^esub>]) {i})"
+      using A(3) MP.indexed_const_closed by blast
+    have 4: "(pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<oplus>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> Q))) = 
+      pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p) \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n Q)"
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"]
+            pre_to_univ_poly_inv_is_hom(1)[of i n] 
+            ring_hom_add[of "pre_to_univ_poly_inv (Suc n) i" "(Pring (R [\<X>\<^bsub>n\<^esub>]) {i})" 
+                          "(R [\<X>\<^bsub>Suc n\<^esub>])" "MP.indexed_const n p" "MP.indexed_const n Q"] 
+            ring_hom_ring.homh 
+            MP.indexed_const_closed[of p n "{i}"] 
+            MP.indexed_const_closed[of Q n "{i}"] A R.Pring_car[of "{..<n}"] unfolding coord_ring_def 
+      by (metis "0" "1" assms(1) coord_ring_def)
+    have 5: "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<oplus>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> Q))) = 
+          pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) \<oplus>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub>
+          pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n Q))"
+    proof-
+      have 50: "pre_to_univ_poly (Suc n) i \<in> ring_hom (R [\<X>\<^bsub>Suc n\<^esub>]) (Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i})"
+        using pre_to_univ_poly_is_hom(1)[of i "Suc n"] ring_hom_ring.homh
+        by (metis assms(1))
+      have 51: "pre_to_univ_poly_inv (Suc n) i \<in> ring_hom (Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}) (R [\<X>\<^bsub>Suc n\<^esub>]) "
+        using pre_to_univ_poly_inv_is_hom ring_hom_ring.homh
+        by (metis assms(1) diff_Suc_1)
+      have 52: " pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p) \<in> carrier (R [\<X>\<^bsub>Suc n\<^esub>])"
+        using 51 ring_hom_closed[of "pre_to_univ_poly_inv (Suc n) i" ] 
+        by (smt "2" diff_Suc_1)
+      have 53: "  pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n Q) \<in> carrier (R [\<X>\<^bsub>Suc n\<^esub>]) "
+        using 51 ring_hom_closed[of "pre_to_univ_poly_inv (Suc n) i" ] 
+        by (smt 3 diff_Suc_1)
+      show ?thesis using 50 51 52 53
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"]
+            ring_hom_add[of "pre_to_univ_poly (Suc n) i" "R [\<X>\<^bsub>Suc n\<^esub>]" "Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}"
+                "pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)" 
+                "pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n Q)"] 4
+      by (metis diff_Suc_1)
+    qed
+    show "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<oplus>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> Q))) = MP.indexed_const n (p \<oplus>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> Q)"
+      using 5 A "0" "1" by metis 
+  qed
+  show "\<And>p ia.
+       p \<in> carrier (R [\<X>\<^bsub>n\<^esub>]) \<Longrightarrow>
+       ia < n \<Longrightarrow>
+       pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) = MP.indexed_const n p \<Longrightarrow>
+       pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R ia))) = MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R ia)"
+  proof- fix p j
+    assume A: "p \<in> carrier (R [\<X>\<^bsub>n\<^esub>])" "j < n"
+               "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) = MP.indexed_const n p"
+    show "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R j))) = MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R j)"
+    proof-
+      have 0: "pre_to_univ_poly_inv (Suc n) i \<in> ring_hom (Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}) (R [\<X>\<^bsub>Suc n\<^esub>]) "
+        using pre_to_univ_poly_inv_is_hom(1)[of i n] ring_hom_ring.homh
+        by (metis assms(1) diff_Suc_1)    
+      have 1: "MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> (pvar R j)) = MP.indexed_const n p \<otimes>\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub> MP.indexed_const n (pvar R j)"
+        by (metis A(1) A(2) MP.indexed_const_mult local.pvar_closed)
+      have 2: "(pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R j))) = 
+          pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p) \<otimes>\<^bsub>(R [\<X>\<^bsub>Suc n\<^esub>])\<^esub> pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j))"
+        using 0 1 ring_hom_mult A
+        by (metis (no_types, lifting) MP.indexed_const_closed diff_Suc_1 local.pvar_closed)
+      have 3: "pre_to_univ_poly(Suc n) i \<in> ring_hom  (R [\<X>\<^bsub>Suc n\<^esub>]) (Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}) "
+        using assms(1) pre_to_univ_poly_is_hom(1) ring_hom_ring.homh by blast        
+      have 4: "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R j))) =
+                pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n p)) \<otimes>\<^bsub>Pring (R [\<X>\<^bsub>n\<^esub>]) {i}\<^esub> 
+                  pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j)))"
+        using 2 3 ring_hom_mult
+        by (smt "0" A(1) A(2) MP.indexed_const_closed diff_Suc_1 local.pvar_closed ring_hom_closed)
+      have 5: "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (p \<otimes>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> pvar R j))) =
+                MP.indexed_const n p \<otimes>\<^bsub>Pring (R [\<X>\<^bsub>n\<^esub>]) {i}\<^esub> 
+                  pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j)))"
+       using A "4" by presburger
+     have 6: "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j))) = (MP.indexed_const n (pvar R j))"
+     proof- 
+       have "(pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j))) = pre_to_univ_poly_inv_hom (Suc n) i  (pvar R j)"
+         using A(2) assms(1) local.pvar_closed pre_to_univ_poly_inv_const by blast
+       hence "pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j))) = 
+              pre_to_univ_poly (Suc n) i (pre_to_univ_poly_inv_hom (Suc n) i  (pvar R j))"
+         by presburger
+       show ?thesis 
+       proof(cases "j < i")
+         case True
+         then have "(pre_to_univ_poly_inv_hom (Suc n) i  (pvar R j)) = (pvar R j)"
+           using pre_to_univ_poly_inv_hom_pvar_0[of i n j] assms(1) by blast
+         thus ?thesis using   pre_to_univ_poly_is_hom 
+           by (metis True \<open>pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j)) = pre_to_univ_poly_inv_hom (Suc n) i (pvar R j)\<close> assms(1) coord_ring_def diff_Suc_1)
+       next
+         case False
+         have "pre_to_univ_poly_inv_hom (Suc n) i  (pvar R j) = pvar R (j + 1)"
+           using pre_to_univ_poly_inv_hom_pvar_1[of i n j]  A(2) False assms(1) not_le 
+           by blast
+         thus ?thesis using   pre_to_univ_poly_is_hom 
+           by (metis A(2) False Suc_eq_plus1 \<open>pre_to_univ_poly_inv (Suc n) i (MP.indexed_const n (pvar R j)) = pre_to_univ_poly_inv_hom (Suc n) i (pvar R j)\<close> 
+               assms(1) coord_ring_def diff_Suc_1 not_less_eq)
+       qed
+     qed
+     show ?thesis using 6 A 
+       using "1" "5" by presburger
+   qed
+ qed
+qed
+
+definition to_univ_poly :: "nat \<Rightarrow> nat \<Rightarrow> 
+  (('a, nat) mvar_poly , ('a, nat) mvar_poly u_poly) ring_hom" where
+"to_univ_poly n i  = IP_to_UP i \<circ> (pre_to_univ_poly n i) "
+
+definition from_univ_poly :: "nat \<Rightarrow> nat \<Rightarrow> 
+      (('a, nat) mvar_poly u_poly , ('a, nat) mvar_poly) ring_hom" where
+"from_univ_poly n i  = pre_to_univ_poly_inv n i \<circ> (UP_to_IP (coord_ring R (n-1)) i)"
+
+lemma to_univ_poly_is_hom:
+  assumes "i \<le> n"
+  shows "(to_univ_poly (Suc n) i) \<in> ring_hom (R[\<X>\<^bsub>Suc n\<^esub>]) (UP (R[\<X>\<^bsub>n\<^esub>])) "
+  unfolding to_univ_poly_def 
+  apply(rule ring_hom_trans[of _ _ "Pring (R[\<X>\<^bsub>n\<^esub>]) {i}"])
+  using assms pre_to_univ_poly_is_hom ring_hom_ring.homh
+   apply (metis diff_Suc_1 le_imp_less_Suc)
+  using UP_cring.IP_to_UP_ring_hom[of "(Pring R {..<n})" i] assms  ring_hom_ring.homh
+  unfolding coord_ring_def UP_cring_def
+  using R.Pring_is_cring R.is_cring by blast
+
+lemma from_univ_poly_is_hom:
+  assumes "i \<le> n"
+  shows "(from_univ_poly (Suc n) i) \<in> ring_hom  (UP (R[\<X>\<^bsub>n\<^esub>])) (R[\<X>\<^bsub>Suc n\<^esub>]) "
+  unfolding from_univ_poly_def 
+  apply(rule ring_hom_trans[of _ _ "Pring (R[\<X>\<^bsub>n\<^esub>]) {i}"])
+  using assms UP_cring.UP_to_IP_ring_hom[of "coord_ring R (Suc n - 1)" i] 
+              ring_hom_ring.homh[of "UP (coord_ring R (Suc n - 1))" "Pring (coord_ring R (Suc n - 1)) {i}" "UP_to_IP (coord_ring R (Suc n - 1)) i"]
+  unfolding coord_ring_def UP_cring_def 
+  apply (metis R.Pring_is_cring diff_Suc_1 R.is_cring)  
+  using assms ring_hom_ring.homh le_imp_less_Suc pre_to_univ_poly_inv_is_hom 
+   unfolding coord_ring_def UP_cring_def
+  by blast
+
+lemma to_univ_poly_inverse:
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "from_univ_poly (Suc n) i (to_univ_poly (Suc n) i p) = p"
+proof-
+  have 0: "pre_to_univ_poly (Suc n) i p \<in> Pring_set (R[\<X>\<^bsub>n\<^esub>]) {i}"
+    using pre_to_univ_poly_is_hom(6)[of i "Suc n" _ p] assms ring.Pring_car
+     unfolding coord_ring_def UP_domain_def
+    by (metis R.Pring_is_ring diff_Suc_1 le_imp_less_Suc)
+  have 1: "UP_to_IP (R[\<X>\<^bsub>n\<^esub>]) i 
+           (IP_to_UP i (pre_to_univ_poly (Suc n) i p)) = 
+           pre_to_univ_poly (Suc n) i p"
+    using 0 UP_cring.UP_to_IP_inv[of "R[\<X>\<^bsub>n\<^esub>]" "pre_to_univ_poly (Suc n) i p" i ] 
+          R.Pring_is_cring
+    unfolding coord_ring_def UP_cring_def
+    using R.is_cring by blast     
+  have 2: "from_univ_poly (Suc n) i (to_univ_poly (Suc n) i p) =
+          (pre_to_univ_poly_inv (Suc n) i (
+          (UP_to_IP (coord_ring R (Suc n - 1)) i) (
+          (IP_to_UP i (
+          (pre_to_univ_poly (Suc n) i) p)))))"
+    unfolding from_univ_poly_def to_univ_poly_def 
+  unfolding coord_ring_def
+    by (metis comp_eq_dest_lhs)    
+  have 3: "from_univ_poly (Suc n) i (to_univ_poly (Suc n) i p) =
+          (pre_to_univ_poly_inv (Suc n) i (
+          pre_to_univ_poly (Suc n) i p))"
+    using 0 1 2 
+  unfolding coord_ring_def 
+    using diff_Suc_1 by presburger    
+  then show ?thesis 
+    using pre_to_univ_poly_inverse assms(1) assms(2) less_Suc_eq_le 
+    by presburger
+qed
+ 
+lemma to_univ_poly_closed: 
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "to_univ_poly (Suc n) i p \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>]))"
+  using to_univ_poly_is_hom[of i n] assms unfolding  ring_hom_def
+  by blast 
+
+lemma to_univ_poly_add: 
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "to_univ_poly (Suc n) i (p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>Q) = 
+        to_univ_poly (Suc n) i p \<oplus>\<^bsub>UP (R[\<X>\<^bsub>n\<^esub>])\<^esub> to_univ_poly (Suc n) i Q"
+  using to_univ_poly_is_hom ring_hom_add 
+  by (metis assms(1) assms(2) assms(3))
+  
+lemma to_univ_poly_mult: 
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "Q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  shows "to_univ_poly (Suc n) i (p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>Q) = 
+        to_univ_poly (Suc n) i p \<otimes>\<^bsub>UP (R[\<X>\<^bsub>n\<^esub>])\<^esub> to_univ_poly (Suc n) i Q"
+  using to_univ_poly_is_hom ring_hom_mult
+  by (metis assms(1) assms(2) assms(3))
+
+lemma from_univ_poly_closed: 
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>])) "
+  shows "from_univ_poly (Suc n) i p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  using from_univ_poly_is_hom[of i n] assms unfolding  ring_hom_def
+  by blast 
+
+lemma from_univ_poly_add: 
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>])) "
+  assumes "Q \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>])) "
+  shows "from_univ_poly (Suc n) i (p \<oplus>\<^bsub>UP (R[\<X>\<^bsub>n\<^esub>])\<^esub>Q) = 
+        from_univ_poly (Suc n) i p \<oplus>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> from_univ_poly (Suc n) i Q"
+  using from_univ_poly_is_hom ring_hom_add 
+  by (metis assms(1) assms(2) assms(3))
+  
+lemma from_univ_poly_mult: 
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>])) "
+  assumes "Q \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>])) "
+  shows "from_univ_poly (Suc n) i (p \<otimes>\<^bsub>UP (R[\<X>\<^bsub>n\<^esub>])\<^esub>Q) = 
+        from_univ_poly (Suc n) i p \<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> from_univ_poly (Suc n) i Q"
+  using from_univ_poly_is_hom ring_hom_mult 
+  by (metis assms(1) assms(2) assms(3))
+
+lemma(in UP_cring) monom_as_mult:
+  assumes "a \<in> carrier R"
+  shows "up_ring.monom (UP R) a n = to_poly a  \<otimes>\<^bsub> UP R\<^esub> up_ring.monom (UP R) \<one> n"
+  by (metis One_nat_def P_def R.one_closed R.r_one UP_cring.poly_shift_monom add_Suc assms is_UP_cring local.monom_mult plus_1_eq_Suc to_polynomial_def)
+
+lemma cring_coord_rings_coord_ring:
+"cring_coord_rings (R[\<X>\<^bsub>n\<^esub>])"
+  unfolding cring_coord_rings_def 
+            cring_coord_rings_axioms_def coord_ring_def 
+  apply(rule conjI)
+  unfolding UP_cring_def 
+  apply (metis coord_cring_cring coord_ring_def)
+  using cring_coord_rings_axioms
+  unfolding cring_coord_rings_def cring_coord_rings_axioms_def
+  by (metis coord_ring_def coord_ring_one coord_ring_zero)
+
+lemma from_univ_poly_monom_inverse:
+  assumes "i < Suc n"
+  assumes "a \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  shows "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a m)) = up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a m"
+proof-
+  have 0: "up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a m = (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a) \<otimes>\<^bsub>UP (R[\<X>\<^bsub>n\<^esub>])\<^esub> (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m)"
+    using UP_cring.monom_as_mult[of "R[\<X>\<^bsub>n\<^esub>]" a m] unfolding UP_ring_def 
+    using UP_cring_def assms coord_cring_cring by blast
+  have 1 : "(UP_to_IP (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i) (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a) = ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) a"
+    using UP_cring.UP_to_IP_const[of "R [\<X>\<^bsub>Suc n - 1\<^esub>]" a i] unfolding UP_cring_def  
+    by (simp add: assms coord_cring_cring)
+  have 2: "(from_univ_poly (Suc n) i (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a)) 
+                = pre_to_univ_poly_inv (Suc n) i (ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) a)"
+    unfolding from_univ_poly_def using 1  
+    by (metis comp_apply)
+  have 3: "from_univ_poly (Suc n) i (to_polynomial (R [\<X>\<^bsub>n\<^esub>]) a) = pre_to_univ_poly_inv_hom (Suc n) i a"
+    using pre_to_univ_poly_inv_const[of i n a] assms 2
+    by presburger
+  have 4: "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (to_polynomial (R [\<X>\<^bsub>n\<^esub>]) a)) = 
+            IP_to_UP i ((pre_to_univ_poly (Suc n) i) (pre_to_univ_poly_inv_hom (Suc n) i a))"
+    using 3 unfolding to_univ_poly_def from_univ_poly_def 
+    by (metis comp_apply)
+  have 5: "(pre_to_univ_poly (Suc n) i) (pre_to_univ_poly_inv (Suc n) i (ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) a)) =  (ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) a)"
+    using assms(1) assms(2) pre_to_univ_poly_inverse' by blast
+  have "(to_univ_poly (Suc n) i) (from_univ_poly (Suc n) i (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a)) = IP_to_UP i  (ring.indexed_const (R[\<X>\<^bsub>n\<^esub>]) a)"
+    unfolding to_univ_poly_def 
+    by (metis "2" "5" comp_apply)
+  hence 6: "(to_univ_poly (Suc n) i) (from_univ_poly (Suc n) i (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a)) = to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a"
+    using UP_cring.IP_to_UP_indexed_const[of "R[\<X>\<^bsub>n\<^esub>]"] 
+    by (smt UP_cring_def assms(2) coord_cring_cring)
+  have 7: "(to_univ_poly (Suc n) i) (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m)) = up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m"
+  proof-
+    have 70: "pvar (R [\<X>\<^bsub>n\<^esub>]) i [^]\<^bsub>Pring (R [\<X>\<^bsub>n\<^esub>]) {i}\<^esub> m \<in> carrier (Pring (R [\<X>\<^bsub>n\<^esub>]) {i})"
+      using Cring_Multivariable_Poly.pvar_closed[of  "R[\<X>\<^bsub>n\<^esub>]" i "{i}"] monoid.nat_pow_closed[of "R[\<X>\<^bsub>n\<^esub>]"]
+      by (meson MP.Pring_is_monoid coord_cring_cring equalityD2 insert_subset monoid.nat_pow_closed)
+    have 71: "(UP_to_IP (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i) (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> m) = 
+                          (pvar (R[\<X>\<^bsub>n\<^esub>]) i)[^]\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub>m"
+      using 70 UP_cring.UP_to_IP_monom[of "R[\<X>\<^bsub>n\<^esub>]" "\<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>" i m ] cring.Pring_smult_one[of "R[\<X>\<^bsub>n\<^esub>]" "pvar (R [\<X>\<^bsub>n\<^esub>]) i [^]\<^bsub>Pring (R [\<X>\<^bsub>n\<^esub>]) {i}\<^esub> m" "{i}"]
+      unfolding UP_cring_def 
+      using MP.one_closed coord_cring_cring diff_Suc_1 by presburger
+    hence 72: "from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m) = 
+                   pre_to_univ_poly_inv (Suc n) i ((pvar (R[\<X>\<^bsub>n\<^esub>]) i)[^]\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub>m)"
+      unfolding from_univ_poly_def
+      using comp_apply[of "pre_to_univ_poly_inv (Suc n) i" "UP_to_IP (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i" "up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> m"]  
+      by presburger 
+    have 73: " pre_to_univ_poly_inv (Suc n) i \<in> ring_hom (Pring (R [\<X>\<^bsub>n\<^esub>]) {i}) (R [\<X>\<^bsub>Suc n\<^esub>]) "
+      using pre_to_univ_poly_inv_is_hom[of i n] assms(1) ring_hom_ring.homh by blast
+    hence 74: "from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m) = (pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>m"
+      unfolding from_univ_poly_def 
+      using 70 71 72 pre_to_univ_poly_inv_pvar[of i n] 
+              ring_hom_nat_pow[of "(Pring (R [\<X>\<^bsub>n\<^esub>]) {i})" "R [\<X>\<^bsub>Suc n\<^esub>]" "pre_to_univ_poly_inv (Suc n) i" "(pvar (R[\<X>\<^bsub>n\<^esub>]) i)" m]
+      by (metis MP.Pring_is_ring MP.Pring_var_closed MP.ring_axioms assms(1) from_univ_poly_def singletonI)
+    hence 75: "(to_univ_poly (Suc n) i) (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m)) 
+                  = (to_univ_poly (Suc n) i) ((pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>m)"
+      by metis 
+    have 76: "pre_to_univ_poly (Suc n) i (pvar R i) = pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i"
+      using pre_to_univ_poly_is_hom(3)[of i "Suc n" ] assms(1) by blast
+    have "pre_to_univ_poly (Suc n) i \<in> ring_hom (R [\<X>\<^bsub>Suc n\<^esub>]) (Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}) "
+      apply(rule ring_hom_ring.homh)
+      using pre_to_univ_poly_is_hom(1)[of i "Suc n"] 
+      using assms(1) by blast
+    hence "pre_to_univ_poly (Suc n) i (pvar R i [^]\<^bsub>R [\<X>\<^bsub>Suc n\<^esub>]\<^esub> m) = pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i [^]\<^bsub>Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}\<^esub> m"
+      using 76 ring_hom_nat_pow[of "R[\<X>\<^bsub>Suc n\<^esub>]" "Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}" "pre_to_univ_poly (Suc n) i" "pvar R i" m]
+      by (metis MP.Pring_is_ring MP.ring_axioms assms(1) local.pvar_closed)
+    hence 77: "(to_univ_poly (Suc n) i) (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m)) 
+                  =IP_to_UP i  (pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i [^]\<^bsub>Pring (R [\<X>\<^bsub>Suc n - 1\<^esub>]) {i}\<^esub> m)"
+      unfolding to_univ_poly_def using comp_apply[of "IP_to_UP i" " pre_to_univ_poly (Suc n) i"]
+      using "74" by presburger
+    have 78: "IP_to_UP i  (pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i) = X_poly (R[\<X>\<^bsub>n\<^esub>])"
+      using cring.IP_to_UP_var[of "R[\<X>\<^bsub>n\<^esub>]"] 
+      by (simp add: MP.IP_to_UP_var var_to_IP_def)
+    have 79: "IP_to_UP i \<in> ring_hom (Pring (R [\<X>\<^bsub>n\<^esub>]) {i}) (UP (R [\<X>\<^bsub>n\<^esub>]))"
+      using UP_cring.IP_to_UP_ring_hom[of "R[\<X>\<^bsub>n\<^esub>]" i] ring_hom_ring.homh[of "Pring (R [\<X>\<^bsub>n\<^esub>]) {i}"] 
+      unfolding UP_cring_def
+      using coord_cring_cring by blast
+    have 80: "pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i \<in> carrier (Pring (R [\<X>\<^bsub>n\<^esub>]) {i})"
+      by (metis "76" assms(1) diff_Suc_1 local.pvar_closed pre_to_univ_poly_is_hom(6))
+    have 81: "ring (UP (R[\<X>\<^bsub>n\<^esub>]))"
+      using UP_ring.UP_ring[of "R[\<X>\<^bsub>n\<^esub>]"] unfolding UP_ring_def  
+      using MP.ring_axioms by blast
+    hence 82: "IP_to_UP i  (pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i [^]\<^bsub>Pring (R[\<X>\<^bsub>n\<^esub>]) {i}\<^esub> m) = X_poly (R[\<X>\<^bsub>n\<^esub>]) [^]\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> m"
+
+      using 78 79 80 ring_hom_nat_pow[of "Pring (R [\<X>\<^bsub>n\<^esub>]) {i}" "UP (R [\<X>\<^bsub>n\<^esub>])" "IP_to_UP i" "pvar (R [\<X>\<^bsub>Suc n - 1\<^esub>]) i" m] 
+      by (metis MP.Pring_is_ring)
+    have 83: "\<one>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> \<odot>\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> X_poly (R [\<X>\<^bsub>n\<^esub>]) [^]\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> m = X_poly (R [\<X>\<^bsub>n\<^esub>]) [^]\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> m"
+      using UP_ring.UP_smult_one[of "R[\<X>\<^bsub>n\<^esub>]" "X_poly (R [\<X>\<^bsub>n\<^esub>]) [^]\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> m"]
+            UP_cring.X_closed[of "R[\<X>\<^bsub>n\<^esub>]"] monoid.nat_pow_closed[of "UP (R[\<X>\<^bsub>n\<^esub>])" "X_poly (R[\<X>\<^bsub>n\<^esub>])" m]
+      unfolding UP_ring_def UP_cring_def  
+      using 81 MP.ring_axioms coord_cring_cring ring.is_monoid by blast
+    have 84: "X_poly (R[\<X>\<^bsub>n\<^esub>]) [^]\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> m = up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> m"
+      using 83 UP_cring.monom_rep_X_pow[of "R[\<X>\<^bsub>n\<^esub>]" "\<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>" m] 
+            monoid.nat_pow_closed[of "UP (R[\<X>\<^bsub>n\<^esub>])" "X_poly (R[\<X>\<^bsub>n\<^esub>])" m] 81
+      unfolding UP_cring_def 
+       using MP.one_closed coord_cring_cring by presburger       
+    thus ?thesis using 77 
+      by (metis "82" diff_Suc_1)
+  qed
+  have 8: "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a m)) = 
+        to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a)) \<otimes>\<^bsub>UP (R[\<X>\<^bsub>n\<^esub>])\<^esub>
+        to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m))"
+  proof-
+    have 80: "to_polynomial (R [\<X>\<^bsub>n\<^esub>]) a \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>]))"
+      using UP_cring.to_poly_closed[of "R[\<X>\<^bsub>n\<^esub>]" a]  UP_cring_def assms(2) coord_cring_cring 
+      by blast
+    have 81: "up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R [\<X>\<^bsub>n\<^esub>]\<^esub> m \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>])) "
+    apply(rule UP_ring.monom_closed[of  "R[\<X>\<^bsub>n\<^esub>]"]) unfolding UP_ring_def using MP.one_closed
+    apply (simp add: MP.ring_axioms)
+      using MP.one_closed by blast     
+    have 82: "(from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a m)) = 
+                (from_univ_poly (Suc n) i (to_polynomial (R[\<X>\<^bsub>n\<^esub>]) a)) \<otimes>\<^bsub>(R[\<X>\<^bsub>Suc n\<^esub>])\<^esub> 
+                  (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m))"
+      using 80 81  from_univ_poly_mult[of i n "to_polynomial (R [\<X>\<^bsub>n\<^esub>]) a" "(up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> m)"] 0  
+      by (metis assms(1) less_Suc_eq_le)
+    thus ?thesis using to_univ_poly_mult 80 81 
+      by (metis assms(1) from_univ_poly_closed less_Suc_eq_le)
+  qed
+  thus ?thesis 
+    using "0" "6" "7" by metis 
+qed
+
+lemma from_univ_poly_inverse:
+  assumes "i \<le> n"
+  assumes "p \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>]))"
+  shows "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i p) = p"
+proof(rule UP_ring.poly_induct3[of "R[\<X>\<^bsub>n\<^esub>]"])
+  show "UP_ring (R [\<X>\<^bsub>n\<^esub>])"
+    unfolding UP_ring_def 
+    by (simp add: MP.ring_axioms)
+  show "p \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>]))"
+    using assms by blast 
+  show "\<And>p q. q \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>])) \<Longrightarrow>
+           p \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>])) \<Longrightarrow>
+           to_univ_poly (Suc n) i (from_univ_poly (Suc n) i p) = p \<Longrightarrow>
+           to_univ_poly (Suc n) i (from_univ_poly (Suc n) i q) = q \<Longrightarrow>
+           to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (p \<oplus>\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> q)) = p \<oplus>\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> q"
+  proof- fix p q 
+    assume A: "q \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>]))" "p \<in> carrier (UP (R [\<X>\<^bsub>n\<^esub>]))"
+              "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i p) = p"
+              "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i q) = q"
+    show "to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (p \<oplus>\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> q)) = p \<oplus>\<^bsub>UP (R [\<X>\<^bsub>n\<^esub>])\<^esub> q"
+      using A assms
+          from_univ_poly_add[of i n p q] 
+          to_univ_poly_add[of i n "from_univ_poly (Suc n) i p" "from_univ_poly (Suc n) i q"] 
+          from_univ_poly_closed[of i n p] from_univ_poly_closed[of i n q] 
+      by presburger
+  qed
+  show "\<And>a na. a \<in> carrier (R [\<X>\<^bsub>n\<^esub>]) \<Longrightarrow> 
+            to_univ_poly (Suc n) i (from_univ_poly (Suc n) i (up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a na)) = up_ring.monom (UP (R [\<X>\<^bsub>n\<^esub>])) a na"
+    using from_univ_poly_monom_inverse[of i ] assms(1) le_imp_less_Suc by presburger
+qed
+
+lemma to_univ_poly_eval:
+  assumes "i < Suc n"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "x \<in> carrier R"
+  assumes  "as = insert_at_index a x i"
+  shows "eval_at_point R as p = eval_at_point R a (to_function (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p) (coord_const x))"
+proof-
+  have 0: "pre_to_univ_poly (Suc n) i p \<in> Pring_set (R[\<X>\<^bsub>n\<^esub>]) {i}"
+    using assms pre_to_univ_poly_is_hom(1)[of i "Suc n"] unfolding ring_hom_ring_def 
+      unfolding coord_ring_def UP_domain_def   coord_ring_def UP_domain_def
+  by (metis MP.Pring_car coord_ring_def diff_Suc_1 pre_to_univ_poly_is_hom(6))
+  have 1: " closed_fun (R[\<X>\<^bsub>n\<^esub>]) (\<lambda>n. coord_const x)"
+    using assms(4) R.indexed_const_closed 
+      unfolding coord_ring_def UP_domain_def
+    by blast
+  have "(to_function (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p) (coord_const x)) = 
+           to_function (R[\<X>\<^bsub>n\<^esub>]) (IP_to_UP i ((pre_to_univ_poly (Suc n) i) p)) (coord_const x)"
+    unfolding to_univ_poly_def 
+  unfolding coord_ring_def UP_domain_def
+    by (metis comp_apply)    
+  then have 2: "(to_function (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p) (coord_const x)) = 
+              (total_eval (R[\<X>\<^bsub>n\<^esub>]) (\<lambda> i. coord_const x) (pre_to_univ_poly (Suc n) i p))"
+      using 0 1 UP_cring.IP_to_UP_poly_eval[of "R[\<X>\<^bsub>n\<^esub>]" 
+                                  "(pre_to_univ_poly (Suc n) i) p" i "\<lambda> i. coord_const x"]
+      unfolding coord_ring_def UP_cring_def 
+      using assms(4) cring.indexed_const_closed R.Pring_is_cring R.cring_axioms 
+      by smt
+    then show ?thesis using pre_to_univ_poly_eval[of i n p a x as] 
+      using assms(1) assms(2) assms(3) assms(4) assms(5) by presburger
+qed
+
+text\<open>
+  The function \texttt{one\_over\_poly}, introduced in the theory \texttt{Cring\_Poly}, maps a 
+  polynomial $p(x)$ to the unique polynomial $q(x)$ which satisfies the relation 
+  $q(x) = x^n p(1/x)$. This will be used later to show that the function $f(x) = 1/x$ is 
+  semialgebraic over the field $\mathbb{Q}_p$.\<close>
+lemma to_univ_poly_one_over_poly:
+  assumes "field R"
+  assumes "i < (Suc n)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "Q = from_univ_poly (Suc n) i (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "x \<in> carrier R"
+  assumes "x \<noteq> \<zero>"
+  assumes "b = insert_at_index a x i"
+  assumes "c = insert_at_index a (inv x) i"
+  assumes "N = UP_ring.degree (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p)"
+  shows "Q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+        "eval_at_point R b Q = (x[^]N) \<otimes> (eval_at_point R c p)"
+proof-
+  have 0: "(to_univ_poly (Suc n) i p) \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>]))"
+    using assms(2) assms(3) less_Suc_eq_le to_univ_poly_closed by blast
+  have 1: "(UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p)) \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>]))"
+      using 0 assms  UP_domain_def UP_cring.one_over_poly_closed UP_cring_def coord_cring_cring by blast
+  show "Q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+    using 1 assms from_univ_poly_closed[of i n] less_Suc_eq_le 
+    by blast
+  have 2: "coord_const x \<in> Units (R[\<X>\<^bsub>n\<^esub>])"
+  proof-
+
+    have 20: "inv x \<in> carrier R"
+      using assms(1) assms(6) assms(7) field.field_Units by blast
+    have 21: "x \<otimes> (inv x) = \<one> "
+    using assms field.field_Units R.Units_r_inv 
+    by blast
+   have 22: "coord_const x \<in> carrier (R[\<X>\<^bsub>n\<^esub>])" 
+     using assms(6) R.indexed_const_closed 
+     unfolding coord_ring_def
+     by blast
+    have 23: "coord_const (inv x) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+      using "20" R.indexed_const_closed
+           unfolding coord_ring_def
+by blast
+    have 24:  "coord_const x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> coord_const (inv x)  = coord_const  (x \<otimes> (inv x))"
+    using assms(6) 20 R.indexed_const_mult      unfolding coord_ring_def
+    by blast
+   have 25:  "coord_const x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> coord_const (inv x)  = \<one>\<^bsub>coord_ring  R n\<^esub>"
+       unfolding coord_ring_def
+  by (metis "20" "21" R.Pring_one assms(6) R.indexed_const_mult)
+   have 26:  "coord_const (inv x) \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> coord_const x  = \<one>\<^bsub>coord_ring  R n\<^esub>"
+         unfolding coord_ring_def
+  by (metis "21" "22" "23" "24" MP.m_comm R.Pring_one coord_ring_def)
+   then show ?thesis
+     using 23 Units_def[of "R[\<X>\<^bsub>n\<^esub>]"] "22" "25"
+     by blast
+  qed
+  have 3: "inv\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (coord_const x) = coord_const (inv x)"
+  proof-
+    have 20: "inv x \<in> carrier R"
+      using assms(1) assms(6) assms(7) field.field_Units by blast
+    have 21: "x \<otimes> (inv x) = \<one> "
+    using assms field.field_Units R.Units_r_inv 
+    by blast
+   have 22: "coord_const x \<in> carrier (R[\<X>\<^bsub>n\<^esub>])" 
+     using assms(6) R.indexed_const_closed 
+          unfolding coord_ring_def
+by blast
+    have 23: "coord_const (inv x) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+      using "20" R.indexed_const_closed     unfolding coord_ring_def
+ by blast
+    have 24:  "coord_const x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> coord_const (inv x)  = coord_const  (x \<otimes> (inv x))"
+    using assms(6) 20 R.indexed_const_mult     unfolding coord_ring_def
+    by blast
+   have 25:  "coord_const x \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> coord_const (inv x)  = \<one>\<^bsub>coord_ring  R n\<^esub>"
+          unfolding coord_ring_def
+  by (metis "20" "21" R.Pring_one assms(6) R.indexed_const_mult)
+   show ?thesis
+    using 22 23 25  R.Pring_is_cring[of "{..<n}"] 
+    monoid.inv_char[of "R[\<X>\<^bsub>n\<^esub>]"]
+     unfolding coord_ring_def
+
+    by (metis R.Pring_is_monoid R.Pring_mult_comm R.is_cring)
+  qed
+  have 4: "to_function (R[\<X>\<^bsub>n\<^esub>]) (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))
+              (coord_const x) = (coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> 
+                            (to_function (R[\<X>\<^bsub>n\<^esub>]) ( (to_univ_poly (Suc n) i p)) (coord_const (inv\<^bsub>R\<^esub> x)))" 
+    using 3 assms UP_cring_def UP_cring.one_over_poly_eval[of "R[\<X>\<^bsub>n\<^esub>]" " (to_univ_poly (Suc n) i p)" "coord_const x"]
+       unfolding coord_ring_def
+       by (metis "0" "2" MP.Units_closed R.Pring_is_cring UP_cring.to_fun_def coord_ring_def R.is_cring)  
+  have 5: "eval_at_point R a (to_function (R[\<X>\<^bsub>n\<^esub>]) (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))
+              (coord_const x))
+           = eval_at_point R a ((coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N \<otimes>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> 
+                            (to_function (R[\<X>\<^bsub>n\<^esub>]) ( (to_univ_poly (Suc n) i p)) (coord_const (inv\<^bsub>R\<^esub> x))) ) "
+    using 4 
+    by presburger
+  have 6: "to_univ_poly (Suc n) i Q =  (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))"
+    using assms from_univ_poly_inverse 
+    by (meson "1" less_Suc_eq_le)
+  have 7: "eval_at_point R a (to_function (R[\<X>\<^bsub>n\<^esub>]) (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))
+              (coord_const x)) = eval_at_point R b Q"
+    using 6 to_univ_poly_eval[of i n Q a x b] assms  \<open>Q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])\<close>
+    by smt
+  have 8: "(coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    using monoid.nat_pow_closed[of "R[\<X>\<^bsub>n\<^esub>]"]
+     unfolding coord_ring_def
+  using R.Pring_is_monoid assms(6) R.indexed_const_closed by blast
+  have 9: "to_function (R[\<X>\<^bsub>n\<^esub>]) ( (to_univ_poly (Suc n) i p)) (coord_const (inv\<^bsub>R\<^esub> x))
+ \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+  proof-
+    have 91: "to_univ_poly (Suc n) i p \<in> carrier (UP (R[\<X>\<^bsub>n\<^esub>]))"
+      by (simp add: "0")
+    have "  coord_const (inv x) \<in> carrier (R[\<X>\<^bsub>n\<^esub>])"
+    proof-
+      have "inv x \<in> carrier R"
+        using assms(1) assms(6) assms(7) field.field_Units by blast      
+      then show ?thesis
+        using R.indexed_const_closed[of "inv x"] assms
+     unfolding coord_ring_def
+
+        by blast
+    qed
+    then show ?thesis 
+    using 91 UP_cring_def[of "R[\<X>\<^bsub>n\<^esub>]" ] UP_cring.to_fun_closed[of "R[\<X>\<^bsub>n\<^esub>]" "to_univ_poly (Suc n) i p" "coord_const (inv\<^bsub>R\<^esub> x)"]
+        to_univ_poly_closed[of i n p] UP_domain_def[of "R[\<X>\<^bsub>n\<^esub>]"]   
+         unfolding coord_ring_def
+         using R.Pring_is_cring R.is_cring 
+         by (metis UP_cring.to_fun_def)                 
+  qed
+  have 10: " eval_at_point R b Q = (eval_at_point R a ((coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N)) \<otimes>
+        (eval_at_point R a  (to_function (R[\<X>\<^bsub>n\<^esub>]) ( (to_univ_poly (Suc n) i p)) (coord_const (inv\<^bsub>R\<^esub> x))))"
+    using 7 5 eval_at_point_mult[of a n "(coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N" 
+        "(to_function (R[\<X>\<^bsub>n\<^esub>]) ( (to_univ_poly (Suc n) i p)) (coord_const (inv\<^bsub>R\<^esub> x)))"]  
+       "8" "9" assms(5) 
+    by presburger
+  have 11: "inv x \<in> carrier R"
+    using assms(1) assms(6) assms(7) field.field_Units by blast
+  have 12: " eval_at_point R b Q = (eval_at_point R a ((coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N)) \<otimes>
+        (eval_at_point R c p)"
+     using 10 11 to_univ_poly_eval[of i n p a "inv x" c] assms(2) assms(3) assms(5) assms(9) 
+     by presburger
+   show 12: " eval_at_point R b Q = (x[^]N) \<otimes>
+        (eval_at_point R c p)"
+  proof-
+    have 0: "(coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N = coord_const (x[^]N)"
+    proof(induction N)
+      case 0
+      have 00: "coord_const x [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> (0::nat) = \<one>\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>"
+        using nat_pow_def[of "R[\<X>\<^bsub>n\<^esub>]" _ "(0::nat)"] 
+          unfolding coord_ring_def
+          by (meson Group.nat_pow_0)
+        then show ?case 
+     unfolding coord_ring_def
+        by (metis Group.nat_pow_0 R.Pring_one)
+    next
+      case (Suc N) fix N::nat assume IH: "coord_const x [^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub> N = coord_const (x [^] N)"
+      then show ?case 
+        using R.indexed_const_mult Group.nat_pow_Suc Suc.IH assms(6) R.nat_pow_closed
+           unfolding coord_ring_def 
+           by (metis )           
+       qed
+    have 1: "(eval_at_point R a ((coord_const x)[^]\<^bsub>R[\<X>\<^bsub>n\<^esub>]\<^esub>N)) = x[^]N"
+      using 0 
+      by (metis assms(5) assms(6) eval_at_point_const R.nat_pow_closed)
+    show ?thesis using 0 1 "12" 
+      by presburger
+  qed
+qed
+
+lemma to_univ_poly_one_over_poly':
+  assumes "field R"
+  assumes "i < (Suc n)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "Q = from_univ_poly (Suc n) i (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))"
+  assumes "a \<in> carrier (R\<^bsup>n\<^esup>)"
+  assumes "x \<in> carrier R"
+  assumes "x \<noteq> \<zero>"
+  assumes "b = insert_at_index a x i"
+  assumes "c = insert_at_index a (inv x) i"
+  assumes "N = UP_ring.degree (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p)"
+  assumes "q = (pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>(k::nat)\<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> Q"
+  shows "q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+        "eval_at_point R b q = (x[^](N + k)) \<otimes> (eval_at_point R c p)"
+proof-
+  have 0: "(pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>k \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+    using pvar_closed[of i "Suc n"] monoid.nat_pow_closed[] 
+        unfolding coord_ring_def
+ by (metis R.Pring_is_monoid assms(2))
+  have 1: "b \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+    using assms(2) assms(5) assms(6) assms(8) insert_at_index_closed less_Suc_eq_le
+    by blast
+  have 11 : "c \<in> carrier (R\<^bsup>Suc n\<^esup>)"
+  proof-
+    have "inv x \<in> carrier R"
+      using assms field.field_Units 
+      by blast
+    then show ?thesis 
+    using assms insert_at_index_closed less_Suc_eq_le 
+    by blast  
+  qed
+  have 2: "eval_at_point R b q = eval_at_point R b ((pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>(k::nat)) 
+                                 \<otimes> eval_at_point R b Q"
+    using assms 0 1      unfolding coord_ring_def
+  by (metis R.Pring_mult coord_ring_def eval_at_point_mult to_univ_poly_one_over_poly(1))
+  have 3: "eval_at_point R b ((pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>(k::nat)) = 
+           x[^](k::nat)"   
+  proof(induction k)
+    case 0
+    have T0: "eval_at_point R b ((pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>(0::nat)) = 
+              eval_at_point R b (\<one>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>)"
+      using nat_pow_def[of "R[\<X>\<^bsub>Suc n\<^esub>]" "pvar R i" "0::nat"] 
+      by (metis Group.nat_pow_0)  
+    then show ?case 
+      by (metis "1" assms(2) eval_at_point_nat_pow R.nat_pow_0 local.pvar_closed)   
+  next
+    case (Suc k) fix k::nat
+    assume IH: "eval_at_poly R (pvar R i [^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> k) b = x [^] k "
+    have 0: "eval_at_poly R (pvar R i) b = b!i"
+      using eval_pvar[of i "Suc n"] assms "1" 
+      by blast
+    have "length a = n"
+      using assms(5) cartesian_power_car_memE by blast
+    then have "eval_at_poly R (pvar R i) b = x"
+      using 0 assms(8) insert_at_index_eq[of i a x] 
+      by (metis assms(2) less_Suc_eq_le)
+    then show ?case 
+      using "1" assms(2) eval_at_point_nat_pow local.pvar_closed 
+      by blast
+  qed
+  have 4: "eval_at_point R b Q = (x[^]N) \<otimes> (eval_at_point R c p)"
+    using to_univ_poly_one_over_poly(2)[of i n p Q a x b c N] assms(1) assms(10) assms(2)
+          assms(3) assms(4) assms(5) assms(6) assms(7) assms(8) assms(9) 
+    by blast
+  have 5: "eval_at_point R b q = x[^](k::nat) \<otimes> ((x[^]N) \<otimes> (eval_at_point R c p))"
+     using 4 3 2 
+     by presburger
+  show 6: "eval_at_point R b q = x[^](N + k) \<otimes> (eval_at_point R c p)"
+  proof-
+
+    have 60: "x[^](k::nat) \<in> carrier R" 
+      using assms(6) by blast
+    have 61: "x[^]N \<in> carrier R" 
+      using assms(6) by blast
+    have 62: "eval_at_point R c p \<in> carrier R"
+      using eval_at_point_closed[of c "Suc n" p]  \<open>c \<in> carrier (R\<^bsup>Suc n\<^esup>)\<close> assms(3) 
+      by blast
+    show ?thesis using 5 60 61 62
+      by (metis assms(6) R.m_assoc R.m_comm R.nat_pow_mult)      
+  qed
+  show "q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+    using assms 
+     unfolding coord_ring_def
+     using 0 R.Pring_mult_closed to_univ_poly_one_over_poly(1) 
+     by (metis coord_ring_def)
+  
+qed
+
+lemma to_univ_poly_one_over_poly'':
+  assumes "field R"
+  assumes "i < (Suc n)"
+  assumes "p \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  assumes "N \<ge>  UP_ring.degree (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p)"
+  shows "\<exists> q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>]). ( \<forall> x \<in> carrier R - {\<zero>}. ( \<forall> a \<in>  carrier (R\<^bsup>n\<^esup>).
+        eval_at_point R (insert_at_index a x i) q =  (x[^]N) \<otimes> (eval_at_point R (insert_at_index a (inv x) i) p)))"
+proof-
+  obtain Q where Q_def: 
+    "Q = from_univ_poly (Suc n) i (UP_cring.one_over_poly (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))"
+    by blast 
+  obtain k where k_def: "k = (N - UP_ring.degree (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p))"
+    by blast 
+  obtain q where q_def: "q = (pvar R i)[^]\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub>(k::nat)\<otimes>\<^bsub>R[\<X>\<^bsub>Suc n\<^esub>]\<^esub> Q"
+    by blast 
+  have 0: " ( \<forall> x \<in> carrier R - {\<zero>}.( \<forall> a \<in>  carrier (R\<^bsup>n\<^esup>).
+        eval_at_point R (insert_at_index a x i) q =  (x[^]N) \<otimes> (eval_at_point R (insert_at_index a (inv x) i) p)))"
+  proof fix x
+    assume A0: " x \<in> carrier R - {\<zero>}"
+    show " \<forall>a\<in>carrier (R\<^bsup>n\<^esup>). eval_at_poly R q (insert_at_index a x i) = x [^] N \<otimes> eval_at_poly R p (insert_at_index a (inv x) i)"
+    proof fix a assume A1: "a \<in> carrier (R\<^bsup>n\<^esup>)"
+      obtain l where l_def: "l = UP_ring.degree (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p)"
+        by blast 
+      have "eval_at_poly R q (insert_at_index a x i) = x [^] (l + k) \<otimes> eval_at_poly R p (insert_at_index a (inv x) i)"
+        using assms A1 A0 to_univ_poly_one_over_poly'(2)[of i n p Q a x "insert_at_index a x i" "insert_at_index a (inv x) i" l q k]
+              Q_def l_def q_def 
+        by blast
+      then show " eval_at_poly R q (insert_at_index a x i) = x [^] N \<otimes> eval_at_poly R p (insert_at_index a (inv x) i)"
+        using k_def  assms l_def add_diff_inverse_nat less_Suc_eq not_less_eq
+        by (metis diff_diff_cancel diff_less_Suc)       
+    qed
+  qed
+  have 1: "q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+  proof-
+    obtain a where a_def: "a = map (\<lambda>i. \<one>) [(0::nat)..<n] "
+      by blast 
+    have a_car: "a \<in> carrier (R\<^bsup>n\<^esup>)"
+      apply(rule cartesian_power_car_memI')
+      using a_def 
+       apply (metis Ex_list_of_length coeff_list length_map length_rev)
+    proof- fix i assume A: "i < n"
+      then have "a!i = \<one>"
+        using a_def 
+        by (metis R_list_length length_map map_nth nth_map)
+      then show "a ! i \<in> carrier R"
+        using a_def  R.one_closed 
+        by metis 
+    qed
+    then show "q \<in> carrier (R[\<X>\<^bsub>Suc n\<^esub>])"
+      using assms q_def k_def Q_def to_univ_poly_one_over_poly'(1)[of i n p Q a \<one> _ _ "deg (R[\<X>\<^bsub>n\<^esub>]) 
+          (to_univ_poly (Suc n) i p)" q "N -deg (R[\<X>\<^bsub>n\<^esub>]) (to_univ_poly (Suc n) i p)" ]
+      using one_closed local.one_neq_zero by blast      
+  qed
+  show ?thesis 
+    using 0 1 by blast 
+qed
+
+(**************************************************************************************************)
+(**************************************************************************************************)
+section\<open>Restricted Inverse Images and Complements\<close>
+(**************************************************************************************************)
+(**************************************************************************************************)
+
+text\<open>
+  This section introduces some versions of basic set operations for extensional functions and sets.
+  We would like a version of the inverse image which intersects the inverse image of a function 
+  with the set \texttt{carrier }$(R^n)$, and a version of the complement of a set which takes the
+  comeplement relative to \texttt{carrier }$(R^n)$. These will have to be defined in parametrized 
+  families, with one such object for each natural number $n$.\<close>
+definition evimage (infixr "\<inverse>\<index>" 90) where
+"evimage n f S = ((f -` S) \<inter> carrier (R\<^bsup>n\<^esup>))"
+
+definition euminus_set :: "nat \<Rightarrow> 'a list set \<Rightarrow> 'a list set" ("_ \<^sup>c\<index>" 70) where
+"S\<^sup>c\<^bsub>n\<^esub> = carrier (R\<^bsup>n\<^esup>) - S"
+
+lemma extensional_vimage_closed:
+"f \<inverse>\<^bsub>n\<^esub> S \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+  unfolding evimage_def by blast 
+
+subsection \<open>Inverse image of a function\<close>
+
+lemma evimage_eq [simp]: "a \<in> f \<inverse>\<^bsub>n\<^esub> B \<longleftrightarrow> a \<in> carrier (R\<^bsup>n\<^esup>) \<and> f a \<in> B"
+  unfolding evimage_def 
+  by blast
+  
+lemma evimage_singleton_eq: "a \<in> f \<inverse>\<^bsub>n\<^esub> {b} \<longleftrightarrow> a \<in> carrier (R\<^bsup>n\<^esup>) \<and>  f a = b"
+  unfolding evimage_def 
+  by blast
+
+lemma evimageI [intro]: "a \<in> carrier (R\<^bsup>n\<^esup>) \<Longrightarrow> f a = b \<Longrightarrow> b \<in> B \<Longrightarrow> a \<in> f \<inverse>\<^bsub>n\<^esub> B"
+  unfolding vimage_def 
+  using evimage_eq by blast  
+
+lemma evimageI2: "a \<in> carrier (R\<^bsup>n\<^esup>) \<Longrightarrow> f a \<in> A \<Longrightarrow> a \<in> f \<inverse>\<^bsub>n\<^esub> A"
+  unfolding vimage_def by fast
+
+lemma evimageE [elim!]: "a \<in> f \<inverse>\<^bsub>n\<^esub> B \<Longrightarrow> (\<And>x. f a = x \<Longrightarrow> x \<in> B \<Longrightarrow> p) \<Longrightarrow> p"
+  unfolding evimage_def 
+  by blast
+  
+lemma evimageD: "a \<in> f\<inverse>\<^bsub>n\<^esub> A \<Longrightarrow> f a \<in> A"
+  unfolding vimage_def by fast
+
+lemma evimage_empty [simp]: "f \<inverse>\<^bsub>n\<^esub> {} = {}"
+  by blast
+
+lemma evimage_Compl:
+  assumes "f \<in> carrier (R\<^bsup>n\<^esup>) \<rightarrow> carrier (R\<^bsup>m\<^esup>)"
+  shows  "(f \<inverse>\<^bsub>n\<^esub>(A\<^sup>c\<^bsub>m\<^esub>)) = ((f -` A)\<^sup>c\<^bsub>n\<^esub>) "
+proof-
+  have "(f \<inverse>\<^bsub>n\<^esub>(A\<^sup>c\<^bsub>m\<^esub>)) =  ((f -` (carrier (R\<^bsup>m\<^esup>))  - (f -`  A))) \<inter> carrier (R\<^bsup>n\<^esup>)"
+    unfolding evimage_def euminus_set_def by blast 
+  hence 0: "(f \<inverse>\<^bsub>n\<^esub>(A\<^sup>c\<^bsub>m\<^esub>)) =  (f -` (carrier (R\<^bsup>m\<^esup>))  \<inter> carrier (R\<^bsup>n\<^esup>))  - (f -`  A)"
+    by (simp add: Int_Diff Int_commute)
+  have  "(f -` (carrier (R\<^bsup>m\<^esup>))  \<inter> carrier (R\<^bsup>n\<^esup>)) = carrier (R\<^bsup>n\<^esup>)"
+  proof
+    show "f -` carrier (R\<^bsup>m\<^esup>) \<inter> carrier (R\<^bsup>n\<^esup>) \<subseteq> carrier (R\<^bsup>n\<^esup>)"
+      by auto 
+    show "carrier (R\<^bsup>n\<^esup>) \<subseteq> f -` carrier (R\<^bsup>m\<^esup>) \<inter> carrier (R\<^bsup>n\<^esup>)"
+      using assms by blast 
+  qed
+  thus ?thesis using 0 
+    by (simp add: euminus_set_def)
+qed
+
+lemma evimage_Un [simp]: "f \<inverse>\<^bsub>n\<^esub> (A \<union> B) = (f \<inverse>\<^bsub>n\<^esub> A) \<union> (f \<inverse>\<^bsub>n\<^esub> B)"
+  unfolding evimage_def by blast 
+
+lemma evimage_Int [simp]: "f \<inverse>\<^bsub>n\<^esub> (A \<inter> B) = (f \<inverse>\<^bsub>n\<^esub> A) \<inter> (f \<inverse>\<^bsub>n\<^esub> B)"
+  unfolding evimage_def by blast 
+
+lemma evimage_Collect_eq [simp]: "f \<inverse>\<^bsub>n\<^esub> Collect p = {y \<in> carrier (R\<^bsup>n\<^esup>). p (f y)}"
+  unfolding evimage_def by blast 
+
+lemma evimage_Collect: "(\<And>x. x \<in> carrier (R\<^bsup>n\<^esup>) \<Longrightarrow> p (f x) = Q x) \<Longrightarrow> f \<inverse>\<^bsub>n\<^esub> (Collect p) = Collect Q \<inter> carrier (R\<^bsup>n\<^esup>)"
+  unfolding evimage_def by blast 
+
+lemma evimage_insert: "f \<inverse>\<^bsub>n\<^esub> (insert a B) = (f \<inverse>\<^bsub>n\<^esub> {a}) \<union> (f \<inverse>\<^bsub>n\<^esub> B)"
+  \<comment> \<open>NOT suitable for rewriting because of the recurrence of \<open>{a}\<close>.\<close>
+  unfolding evimage_def by blast 
+
+lemma evimage_Diff: "f \<inverse>\<^bsub>n\<^esub> (A - B) = (f \<inverse>\<^bsub>n\<^esub> A) - (f \<inverse>\<^bsub>n\<^esub> B)"
+  unfolding evimage_def by blast 
+
+lemma evimage_UNIV [simp]: "f \<inverse>\<^bsub>n\<^esub> UNIV = carrier (R\<^bsup>n\<^esup>)"
+  unfolding evimage_def by blast 
+
+lemma evimage_mono: "A \<subseteq> B \<Longrightarrow> f \<inverse>\<^bsub>n\<^esub> A \<subseteq> f \<inverse>\<^bsub>n\<^esub> B"
+  \<comment> \<open>monotonicity\<close>
+  unfolding evimage_def by blast 
+
+lemma evimage_image_eq: "(f \<inverse>\<^bsub>n\<^esub> (f ` A)) = {y \<in> carrier (R\<^bsup>n\<^esup>). \<exists>x\<in>A. f x = f y}"
+  unfolding evimage_def  by (blast intro: sym)
+
+lemma image_evimage_subset: "f ` (f \<inverse>\<^bsub>n\<^esub> A) \<subseteq> A"
+  by blast
+
+lemma image_evimage_eq [simp]: "f ` (f \<inverse>\<^bsub>n\<^esub> A) = A \<inter> (f ` carrier (R\<^bsup>n\<^esup>))"
+  unfolding evimage_def   by blast
+
+lemma image_subset_iff_subset_evimage: "A \<subseteq> carrier (R\<^bsup>n\<^esup>) \<Longrightarrow> f ` A \<subseteq> B \<longleftrightarrow> A \<subseteq> f \<inverse>\<^bsub>n\<^esub> B"
+  by blast
+
+lemma evimage_const [simp]: "((\<lambda>x. c) \<inverse>\<^bsub>n\<^esub> A) = (if c \<in> A then carrier (R\<^bsup>n\<^esup>) else {})"
+  unfolding evimage_def using vimage_const[of c A] 
+  by (smt Int_commute inf_bot_right inf_top.right_neutral)
+
+lemma evimage_if [simp]: "((\<lambda>x. if x \<in> B then c else d) \<inverse>\<^bsub>n\<^esub> A) =
+   (if c \<in> A then (if d \<in> A then carrier (R\<^bsup>n\<^esup>) else B \<inter> carrier (R\<^bsup>n\<^esup>) )
+    else if d \<in> A then B\<^sup>c\<^bsub>n\<^esub>  else {})"
+unfolding evimage_def euminus_set_def using vimage_if[of B c d A]  
+  by (metis Diff_Compl Diff_UNIV Diff_empty Int_commute double_compl)
+
+lemma evimage_inter_cong: "(\<And> w. w \<in> S \<Longrightarrow> f w = g w) \<Longrightarrow> f \<inverse>\<^bsub>n\<^esub> y \<inter> S = g \<inverse>\<^bsub>n\<^esub> y \<inter> S"
+unfolding evimage_def 
+  by (smt Int_assoc Int_commute vimage_inter_cong)
+
+lemma evimage_ident [simp]: "(\<lambda>x. x) \<inverse>\<^bsub>n\<^esub> Y = Y \<inter> carrier (R\<^bsup>n\<^esup>)"
+unfolding evimage_def 
+  by blast
+
+
+end  
+
+
+
+
+end
diff --git a/thys/Padic_Field/document/root.bib b/thys/Padic_Field/document/root.bib
new file mode 100644
--- /dev/null
+++ b/thys/Padic_Field/document/root.bib
@@ -0,0 +1,62 @@
+
+@Book{dummit2004abstract,
+ author = {Dummit, David},
+ title = {Abstract algebra},
+ publisher = {John Wiley \& Sons, Inc},
+ year = {2004},
+ address = {Hoboken, NJ},
+ isbn = {0471433349}
+ }
+
+@Book{engler2005valued,
+ author = {Engler, Antonio},
+ title = {Valued fields},
+ publisher = {Springer},
+ year = {2005},
+ address = {Berlin New York},
+ isbn = {354024221X}
+ }
+
+@misc{keithconrad, title={Hensel's Lemma}, url={https://kconrad.math.uconn.edu/blurbs/gradnumthy/hensel.pdf}, author={Conrad, Keith}} 
+
+@inproceedings{Thi,
+author = {Lewis, Robert Y.},
+title = {A Formal Proof of Hensel's Lemma over the p-Adic Integers},
+year = {2019},
+isbn = {9781450362221},
+publisher = {Association for Computing Machinery},
+address = {New York, NY, USA},
+url = {https://doi.org/10.1145/3293880.3294089},
+doi = {10.1145/3293880.3294089},
+abstract = {The field of p-adic numbers ℚp and the ring of p-adic integers ℤp are essential constructions of modern number theory. Hensel’s lemma, described by Gouv\^{e}a as the “most important algebraic property of the p-adic numbers,” shows the existence of roots of polynomials over ℤp provided an initial seed point. The theorem can be proved for the p-adics with significantly weaker hypotheses than for general rings. We construct ℚp and ℤp in the Lean proof assistant, with various associated algebraic properties, and formally prove a strong form of Hensel’s lemma. The proof lies at the intersection of algebraic and analytic reasoning and demonstrates how the Lean mathematical library handles such a heterogeneous topic.},
+booktitle = {Proceedings of the 8th ACM SIGPLAN International Conference on Certified Programs and Proofs},
+pages = {15–26},
+numpages = {12},
+keywords = {Hensel's lemma, formal proof, Lean, p-adic},
+location = {Cascais, Portugal},
+series = {CPP 2019}
+}
+
+@article{10.2307/2274477,
+ ISSN = {00224812},
+ URL = {http://www.jstor.org/stable/2274477},
+ author = {Johan Pas},
+ journal = {The Journal of Symbolic Logic},
+ number = {3},
+ pages = {1125--1129},
+ publisher = {Association for Symbolic Logic},
+ title = {On the Angular Component Map Modulo P},
+ volume = {55},
+ year = {1990}
+}
+
+@article{denef1986,
+author = {Denef, Jan},
+journal = {Journal für die reine und angewandte Mathematik},
+keywords = {rationality of Poincaré series; Macintyre's theorem; elimination of quantifiers; p-adic fields; cell decomposition theorem},
+pages = {154-166},
+title = {p-adic Semi-Algebraic Sets and Cell Decomposition.},
+url = {http://eudml.org/doc/152854},
+volume = {369},
+year = {1986},
+}
diff --git a/thys/Padic_Field/document/root.tex b/thys/Padic_Field/document/root.tex
new file mode 100755
--- /dev/null
+++ b/thys/Padic_Field/document/root.tex
@@ -0,0 +1,64 @@
+\documentclass[11pt,a4paper]{article}
+\usepackage{isabelle,isabellesym, amsmath, amssymb, amsfonts}
+
+% further packages required for unusual symbols (see also
+% isabellesym.sty), use only when needed
+
+%\usepackage{amssymb}
+  %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
+  %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
+  %\<triangleq>, \<yen>, \<lozenge>
+
+%\usepackage{eurosym}
+  %for \<euro>
+
+%\usepackage[only,bigsqcap]{stmaryrd}
+  %for \<Sqinter>
+
+%\usepackage{eufrak}
+  %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
+
+%\usepackage{textcomp}
+  %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
+  %\<currency>
+
+% this should be the last package used
+\usepackage{pdfsetup}
+
+% urls in roman style, theory text in math-similar italics
+\urlstyle{rm}
+\isabellestyle{it}
+
+% for uniform font size
+%\renewcommand{\isastyle}{\isastyleminor}
+
+
+\begin{document}
+
+\title{$p$-adic Fields}
+\author{Aaron Crighton}
+\maketitle
+
+\tableofcontents
+
+% sane default for proof documents
+\parindent 0pt\parskip 0.5ex
+
+
+\begin{abstract}
+We formalize the fields $\mathbb{Q}_p$ of $p$-adic numbers within the framework of the HOL-Algebra library. The $p$-adic field is defined simply as the fraction field of the ring of $p$-adic integers. The valuation, and basic topological properties of $\mathbb{Q}_p$ are developed, including deducing Hensel's Lemma for $\mathbb{Q}_p$ from the same theorem for $\mathbb{Z}_p$. The theory of semialgebraic subsets of $\mathbb{Q}_p^n$ and semialgebraic functions is also developed, as outlined in \cite{denef1986}. In order to formulate these results, general theory about multivariable polynomial rings and cartesian powers of a ring must also be developed. This work is done with a view to formalizing the proof in \cite{denef1986} of Macintyre's quantifier elimination theorem for semialgebraic subsets of $\mathbb{Q}_p^n$. 
+\end{abstract}
+% generated text of all theories
+
+\input{session}
+
+% optional bibliography
+\bibliographystyle{abbrv}
+\bibliography{root}
+
+\end{document}
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: t
+%%% End:
diff --git a/thys/ROOTS b/thys/ROOTS
--- a/thys/ROOTS
+++ b/thys/ROOTS
@@ -1,704 +1,705 @@
 ADS_Functor
 AI_Planning_Languages_Semantics
 AODV
 AVL-Trees
 AWN
 Abortable_Linearizable_Modules
 Abs_Int_ITP2012
 Abstract-Hoare-Logics
 Abstract-Rewriting
 Abstract_Completeness
 Abstract_Soundness
 Ackermanns_not_PR
 Actuarial_Mathematics
 Adaptive_State_Counting
 Affine_Arithmetic
 Aggregation_Algebras
 Akra_Bazzi
 Algebraic_Numbers
 Algebraic_VCs
 Allen_Calculus
 Amicable_Numbers
 Amortized_Complexity
 AnselmGod
 Applicative_Lifting
 Approximation_Algorithms
 Architectural_Design_Patterns
 Aristotles_Assertoric_Syllogistic
 Arith_Prog_Rel_Primes
 ArrowImpossibilityGS
 Attack_Trees
 Auto2_HOL
 Auto2_Imperative_HOL
 AutoFocus-Stream
 Automated_Stateful_Protocol_Verification
 Automatic_Refinement
 AxiomaticCategoryTheory
 BDD
 BD_Security_Compositional
 BNF_CC
 BNF_Operations
 BTree
 Banach_Steinhaus
 Belief_Revision
 Bell_Numbers_Spivey
 BenOr_Kozen_Reif
 Berlekamp_Zassenhaus
 Bernoulli
 Bertrands_Postulate
 Bicategory
 BinarySearchTree
 Binding_Syntax_Theory
 Binomial-Heaps
 Binomial-Queues
 BirdKMP
 Blue_Eyes
 Bondy
 Boolean_Expression_Checkers
 Boolos_Curious_Inference
 Bounded_Deducibility_Security
 Buchi_Complementation
 Budan_Fourier
 Buffons_Needle
 Buildings
 BytecodeLogicJmlTypes
 C2KA_DistributedSystems
 CAVA_Automata
 CAVA_LTL_Modelchecker
 CCS
 CISC-Kernel
 CRYSTALS-Kyber
 CRDT
 CSP_RefTK
 CYK
 CZH_Elementary_Categories
 CZH_Foundations
 CZH_Universal_Constructions
 CakeML
 CakeML_Codegen
 Call_Arity
 Card_Equiv_Relations
 Card_Multisets
 Card_Number_Partitions
 Card_Partitions
 Cartan_FP
 Case_Labeling
 Catalan_Numbers
 Category
 Category2
 Category3
 Cauchy
 Cayley_Hamilton
 Certification_Monads
 Chandy_Lamport
 Chord_Segments
 Circus
 Clean
 Clique_and_Monotone_Circuits
 ClockSynchInst
 Closest_Pair_Points
 CoCon
 CoSMeDis
 CoSMed
 CofGroups
 Coinductive
 Coinductive_Languages
 Collections
 Combinable_Wands
 Combinatorics_Words
 Combinatorics_Words_Graph_Lemma
 Combinatorics_Words_Lyndon
 Commuting_Hermitian
 Comparison_Sort_Lower_Bound
 Compiling-Exceptions-Correctly
 Complete_Non_Orders
 Completeness
 Complex_Bounded_Operators
 Complex_Geometry
 Complx
 ComponentDependencies
 ConcurrentGC
 ConcurrentIMP
 Concurrent_Ref_Alg
 Concurrent_Revisions
 Conditional_Simplification
 Conditional_Transfer_Rule
 Consensus_Refined
 Constructive_Cryptography
 Constructive_Cryptography_CM
 Constructor_Funs
 Containers
 CoreC++
 Core_DOM
 Core_SC_DOM
 Correctness_Algebras
 Cotangent_PFD_Formula
 Count_Complex_Roots
 CryptHOL
 CryptoBasedCompositionalProperties
 Cubic_Quartic_Equations
 DFS_Framework
 DOM_Components
 DPT-SAT-Solver
 DataRefinementIBP
 Datatype_Order_Generator
 Decl_Sem_Fun_PL
 Decreasing-Diagrams
 Decreasing-Diagrams-II
 Dedekind_Real
 Deep_Learning
 Delta_System_Lemma
 Density_Compiler
 Dependent_SIFUM_Refinement
 Dependent_SIFUM_Type_Systems
 Depth-First-Search
 Derangements
 Deriving
 Descartes_Sign_Rule
 Design_Theory
 Dict_Construction
 Differential_Dynamic_Logic
 Differential_Game_Logic
 Digit_Expansions
 Dijkstra_Shortest_Path
 Diophantine_Eqns_Lin_Hom
 Dirichlet_L
 Dirichlet_Series
 DiscretePricing
 Discrete_Summation
 DiskPaxos
 Dominance_CHK
 DPRM_Theorem
 DynamicArchitectures
 Dynamic_Tables
 E_Transcendental
 Echelon_Form
 EdmondsKarp_Maxflow
 Efficient-Mergesort
 Elliptic_Curves_Group_Law
 Encodability_Process_Calculi
 Epistemic_Logic
 Equivalence_Relation_Enumeration
 Ergodic_Theory
 Error_Function
 Euler_MacLaurin
 Euler_Partition
 Eval_FO
 Example-Submission
 Extended_Finite_State_Machine_Inference
 Extended_Finite_State_Machines
 FFT
 FLP
 FOL-Fitting
 FOL_Axiomatic
 FOL_Harrison
 FOL_Seq_Calc1
 FOL_Seq_Calc2
 FOL_Seq_Calc3
 FSM_Tests
 Factor_Algebraic_Polynomial
 Factored_Transition_System_Bounding
 Falling_Factorial_Sum
 Farkas
 FeatherweightJava
 Featherweight_OCL
 Fermat3_4
 FileRefinement
 FinFun
 Finger-Trees
 Finite-Map-Extras
 Finite_Automata_HF
 Finite_Fields
 Finitely_Generated_Abelian_Groups
 First_Order_Terms
 First_Welfare_Theorem
 Fishburn_Impossibility
 Fisher_Yates
 Fishers_Inequality
 Flow_Networks
 Floyd_Warshall
 Flyspeck-Tame
 FocusStreamsCaseStudies
 Forcing
 Formal_Puiseux_Series
 Formal_SSA
 Formula_Derivatives
 Foundation_of_geometry
 Fourier
 FO_Theory_Rewriting
 Free-Boolean-Algebra
 Free-Groups
 Frequency_Moments
 Fresh_Identifiers
 FunWithFunctions
 FunWithTilings
 Functional-Automata
 Functional_Ordered_Resolution_Prover
 Furstenberg_Topology
 GPU_Kernel_PL
 Gabow_SCC
 GaleStewart_Games
 Gale_Shapley
 Game_Based_Crypto
 Gauss-Jordan-Elim-Fun
 Gauss_Jordan
 Gauss_Sums
 Gaussian_Integers
 GenClock
 General-Triangle
 Generalized_Counting_Sort
 Generic_Deriving
 Generic_Join
 GewirthPGCProof
 Girth_Chromatic
 GoedelGod
 Goedel_HFSet_Semantic
 Goedel_HFSet_Semanticless
 Goedel_Incompleteness
 Goodstein_Lambda
 GraphMarkingIBP
 Graph_Saturation
 Graph_Theory
 Green
 Groebner_Bases
 Groebner_Macaulay
 Gromov_Hyperbolicity
 Grothendieck_Schemes
 Group-Ring-Module
 HOL-CSP
 HOLCF-Prelude
 HRB-Slicing
 Hahn_Jordan_Decomposition
 Hales_Jewett
 Heard_Of
 Hello_World
 HereditarilyFinite
 Hermite
 Hermite_Lindemann
 Hidden_Markov_Models
 Higher_Order_Terms
 Hoare_Time
 Hood_Melville_Queue
 HotelKeyCards
 Huffman
 Hybrid_Logic
 Hybrid_Multi_Lane_Spatial_Logic
 Hybrid_Systems_VCs
 HyperCTL
 Hyperdual
 IEEE_Floating_Point
 IFC_Tracking
 IMAP-CRDT
 IMO2019
 IMP2
 IMP2_Binary_Heap
 IMP_Compiler
 IMP_Compiler_Reuse
 IP_Addresses
 Imperative_Insertion_Sort
 Implicational_Logic
 Impossible_Geometry
 Incompleteness
 Incredible_Proof_Machine
 Independence_CH
 Inductive_Confidentiality
 Inductive_Inference
 InfPathElimination
 InformationFlowSlicing
 InformationFlowSlicing_Inter
 Integration
 Interpolation_Polynomials_HOL_Algebra
 Interpreter_Optimizations
 Interval_Arithmetic_Word32
 Intro_Dest_Elim
 Involutions2Squares
 Iptables_Semantics
 Irrational_Series_Erdos_Straus
 Irrationality_J_Hancl
 Irrationals_From_THEBOOK
 IsaGeoCoq
 Isabelle_C
 Isabelle_Marries_Dirac
 Isabelle_Meta_Model
 IsaNet
 Jacobson_Basic_Algebra
 Jinja
 JinjaDCI
 JinjaThreads
 JiveDataStoreModel
 Jordan_Hoelder
 Jordan_Normal_Form
 KAD
 KAT_and_DRA
 KBPs
 KD_Tree
 Key_Agreement_Strong_Adversaries
 Khovanskii_Theorem
 Kleene_Algebra
 Knights_Tour
 Knot_Theory
 Knuth_Bendix_Order
 Knuth_Morris_Pratt
 Koenigsberg_Friendship
 Kruskal
 Kuratowski_Closure_Complement
 LLL_Basis_Reduction
 LLL_Factorization
 LOFT
 LTL
 LTL_Master_Theorem
 LTL_Normal_Form
 LTL_to_DRA
 LTL_to_GBA
 Lam-ml-Normalization
 LambdaAuth
 LambdaMu
 Lambda_Free_EPO
 Lambda_Free_KBOs
 Lambda_Free_RPOs
 Lambert_W
 Landau_Symbols
 Laplace_Transform
 Latin_Square
 LatticeProperties
 Launchbury
 Laws_of_Large_Numbers
 Lazy-Lists-II
 Lazy_Case
 Lehmer
 Lifting_Definition_Option
 Lifting_the_Exponent
 LightweightJava
 LinearQuantifierElim
 Linear_Inequalities
 Linear_Programming
 Linear_Recurrences
 Liouville_Numbers
 List-Index
 List-Infinite
 List_Interleaving
 List_Inversions
 List_Update
 LocalLexing
 Localization_Ring
 Locally-Nameless-Sigma
 Logging_Independent_Anonymity
 Lowe_Ontological_Argument
 Lower_Semicontinuous
 Lp
 LP_Duality
 Lucas_Theorem
 MDP-Algorithms
 MDP-Rewards
 MFMC_Countable
 MFODL_Monitor_Optimized
 MFOTL_Monitor
 MSO_Regex_Equivalence
 Markov_Models
 Marriage
 Mason_Stothers
 Matrices_for_ODEs
 Matrix
 Matrix_Tensor
 Matroids
 Max-Card-Matching
 Median_Method
 Median_Of_Medians_Selection
 Menger
 Mereology
 Mersenne_Primes
 Metalogic_ProofChecker
 MiniML
 MiniSail
 Minimal_SSA
 Minkowskis_Theorem
 Minsky_Machines
 Modal_Logics_for_NTS
 Modular_Assembly_Kit_Security
 Modular_arithmetic_LLL_and_HNF_algorithms
 Monad_Memo_DP
 Monad_Normalisation
 MonoBoolTranAlgebra
 MonoidalCategory
 Monomorphic_Monad
 MuchAdoAboutTwo
 Multiset_Ordering_NPC
 Multi_Party_Computation
 Multirelations
 Myhill-Nerode
 Name_Carrying_Type_Inference
 Nano_JSON
 Nash_Williams
 Nat-Interval-Logic
 Native_Word
 Nested_Multisets_Ordinals
 Network_Security_Policy_Verification
 Neumann_Morgenstern_Utility
 No_FTL_observers
 Nominal2
 Noninterference_CSP
 Noninterference_Concurrent_Composition
 Noninterference_Generic_Unwinding
 Noninterference_Inductive_Unwinding
 Noninterference_Ipurge_Unwinding
 Noninterference_Sequential_Composition
 NormByEval
 Nullstellensatz
 Number_Theoretic_Transform
 Octonions
 OpSets
 Open_Induction
 Optics
 Optimal_BST
 Orbit_Stabiliser
 Order_Lattice_Props
 Ordered_Resolution_Prover
 Ordinal
 Ordinal_Partitions
 Ordinals_and_Cardinals
 Ordinary_Differential_Equations
 PAC_Checker
 Package_logic
 PAL
 PCF
 PLM
 POPLmark-deBruijn
 PSemigroupsConvolution
 Padic_Ints
+Padic_Field
 Pairing_Heap
 Paraconsistency
 Parity_Game
 Partial_Function_MR
 Partial_Order_Reduction
 Password_Authentication_Protocol
 Pell
 Perfect-Number-Thm
 Perron_Frobenius
 Physical_Quantities
 Pi_Calculus
 Pi_Transcendental
 Planarity_Certificates
 Pluennecke_Ruzsa_Inequality
 Poincare_Bendixson
 Poincare_Disc
 Polynomial_Factorization
 Polynomial_Interpolation
 Polynomials
 Pop_Refinement
 Posix-Lexing
 Possibilistic_Noninterference
 Power_Sum_Polynomials
 Pratt_Certificate
 Prefix_Free_Code_Combinators
 Presburger-Automata
 Prim_Dijkstra_Simple
 Prime_Distribution_Elementary
 Prime_Harmonic_Series
 Prime_Number_Theorem
 Priority_Queue_Braun
 Priority_Search_Trees
 Probabilistic_Noninterference
 Probabilistic_Prime_Tests
 Probabilistic_System_Zoo
 Probabilistic_Timed_Automata
 Probabilistic_While
 Program-Conflict-Analysis
 Progress_Tracking
 Projective_Geometry
 Projective_Measurements
 Promela
 Proof_Strategy_Language
 PropResPI
 Propositional_Proof_Systems
 Prpu_Maxflow
 PseudoHoops
 Psi_Calculi
 Ptolemys_Theorem
 Public_Announcement_Logic
 QHLProver
 QR_Decomposition
 Quantales
 Quasi_Borel_Spaces
 Quaternions
 Quick_Sort_Cost
 RIPEMD-160-SPARK
 ROBDD
 RSAPSS
 Ramsey-Infinite
 Random_BSTs
 Random_Graph_Subgraph_Threshold
 Randomised_BSTs
 Randomised_Social_Choice
 Rank_Nullity_Theorem
 Real_Impl
 Real_Power
 Real_Time_Deque
 Recursion-Addition
 Recursion-Theory-I
 Refine_Imperative_HOL
 Refine_Monadic
 RefinementReactive
 Regex_Equivalence
 Registers
 Regression_Test_Selection
 Regular-Sets
 Regular_Algebras
 Regular_Tree_Relations
 Relation_Algebra
 Relational-Incorrectness-Logic
 Relational_Disjoint_Set_Forests
 Relational_Forests
 Relational_Method
 Relational_Minimum_Spanning_Trees
 Relational_Paths
 Rep_Fin_Groups
 ResiduatedTransitionSystem
 Residuated_Lattices
 Resolution_FOL
 Rewrite_Properties_Reduction
 Rewriting_Z
 Ribbon_Proofs
 Risk_Free_Lending
 Robbins-Conjecture
 Robinson_Arithmetic
 Root_Balanced_Tree
 Roth_Arithmetic_Progressions
 Routing
 Roy_Floyd_Warshall
 SATSolverVerification
 SC_DOM_Components
 SDS_Impossibility
 SIFPL
 SIFUM_Type_Systems
 SPARCv8
 Safe_Distance
 Safe_OCL
 Saturation_Framework
 Saturation_Framework_Extensions
 SCC_Bloemen_Sequential
 Schutz_Spacetime
 Secondary_Sylow
 Security_Protocol_Refinement
 Selection_Heap_Sort
 SenSocialChoice
 Separata
 Separation_Algebra
 Separation_Logic_Imperative_HOL
 Separation_Logic_Unbounded
 SequentInvertibility
 Shadow_DOM
 Shadow_SC_DOM
 Shivers-CFA
 ShortestPath
 Show
 Sigma_Commit_Crypto
 Signature_Groebner
 Simpl
 Simple_Firewall
 Simplex
 Simplicial_complexes_and_boolean_functions
 SimplifiedOntologicalArgument
 Skew_Heap
 Skip_Lists
 Slicing
 Sliding_Window_Algorithm
 Smith_Normal_Form
 Smooth_Manifolds
 Sophomores_Dream
 Solidity
 Sort_Encodings
 Source_Coding_Theorem
 SpecCheck
 Special_Function_Bounds
 Splay_Tree
 Sqrt_Babylonian
 Stable_Matching
 Statecharts
 Stateful_Protocol_Composition_and_Typing
 Stellar_Quorums
 Stern_Brocot
 Stewart_Apollonius
 Stirling_Formula
 Stochastic_Matrices
 Stone_Algebras
 Stone_Kleene_Relation_Algebras
 Stone_Relation_Algebras
 Store_Buffer_Reduction
 Stream-Fusion
 Stream_Fusion_Code
 Strong_Security
 Sturm_Sequences
 Sturm_Tarski
 Stuttering_Equivalence
 Subresultants
 Subset_Boolean_Algebras
 SumSquares
 Sunflowers
 SuperCalc
 Surprise_Paradox
 Symmetric_Polynomials
 Syntax_Independent_Logic
 Szemeredi_Regularity
 Szpilrajn
 TESL_Language
 TLA
 Tail_Recursive_Functions
 Tarskis_Geometry
 Taylor_Models
 Three_Circles
 Timed_Automata
 Topological_Semantics
 Topology
 TortoiseHare
 Transcendence_Series_Hancl_Rucki
 Transformer_Semantics
 Transition_Systems_and_Automata
 Transitive-Closure
 Transitive-Closure-II
 Transitive_Models
 Treaps
 Tree-Automata
 Tree_Decomposition
 Triangle
 Trie
 Twelvefold_Way
 Tycon
 Types_Tableaus_and_Goedels_God
 Types_To_Sets_Extension
 UPF
 UPF_Firewall
 UTP
 Universal_Hash_Families
 Universal_Turing_Machine
 UpDown_Scheme
 Valuation
 Van_Emde_Boas_Trees
 Van_der_Waerden
 VectorSpace
 VeriComp
 Verified-Prover
 Verified_SAT_Based_AI_Planning
 VerifyThis2018
 VerifyThis2019
 Vickrey_Clarke_Groves
 Virtual_Substitution
 VolpanoSmith
 VYDRA_MDL
 WHATandWHERE_Security
 WOOT_Strong_Eventual_Consistency
 WebAssembly
 Weight_Balanced_Trees
 Weighted_Arithmetic_Geometric_Mean
 Weighted_Path_Order
 Well_Quasi_Orders
 Wetzels_Problem
 Winding_Number_Eval
 Word_Lib
 WorkerWrapper
 X86_Semantics
 XML
 Youngs_Inequality
 ZFC_in_HOL
 Zeta_3_Irrational
 Zeta_Function
 pGCL