(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory Accumulator
imports
  HOLCF
  LList
  WorkerWrapperNew
begin
(*>*)

section\<open>Naive reverse becomes accumulator-reverse.\<close>

text\<open>\label{sec:accum}\<close>

subsection\<open>Hughes lists, naive reverse, worker-wrapper optimisation.\<close>

text\<open>The ``Hughes'' list type.\<close>

type_synonym 'a H = "'a llist \<rightarrow> 'a llist"

definition
  list2H :: "'a llist \<rightarrow> 'a H" where
  "list2H \<equiv> lappend"

lemma acc_c2a_strict[simp]: "list2H\<cdot>\<bottom> = \<bottom>"
  by (rule cfun_eqI, simp add: list2H_def)

definition
  H2list :: "'a H \<rightarrow> 'a llist" where
  "H2list \<equiv> \<Lambda> f . f\<cdot>lnil"

text\<open>The paper only claims the homomorphism holds for finite lists,
but in fact it holds for all lazy lists in HOLCF. They are trying to
dodge an explicit appeal to the equation @{thm "inst_cfun_pcpo"},
which does not hold in Haskell.\<close>

lemma H_llist_hom_append: "list2H\<cdot>(xs :++ ys) = list2H\<cdot>xs oo list2H\<cdot>ys" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix zs
  have "?lhs\<cdot>zs = (xs :++ ys) :++ zs" by (simp add: list2H_def)
  also have "\<dots> = xs :++ (ys :++ zs)" by (rule lappend_assoc)
  also have "\<dots> = list2H\<cdot>xs\<cdot>(ys :++ zs)" by (simp add: list2H_def)
  also have "\<dots> = list2H\<cdot>xs\<cdot>(list2H\<cdot>ys\<cdot>zs)" by (simp add: list2H_def)
  also have "\<dots> = (list2H\<cdot>xs oo list2H\<cdot>ys)\<cdot>zs" by simp
  finally show "?lhs\<cdot>zs = (list2H\<cdot>xs oo list2H\<cdot>ys)\<cdot>zs" .
qed

lemma H_llist_hom_id: "list2H\<cdot>lnil = ID" by (simp add: list2H_def)

lemma H2list_list2H_inv: "H2list oo list2H = ID"
  by (rule cfun_eqI, simp add: H2list_def list2H_def)

text\<open>\<^citet>\<open>\<open>\S4.2\<close> in "GillHutton:2009"\<close> define the naive reverse
function as follows.\<close>

fixrec lrev :: "'a llist \<rightarrow> 'a llist"
where
  "lrev\<cdot>lnil = lnil"
| "lrev\<cdot>(x :@ xs) = lrev\<cdot>xs :++ (x :@ lnil)"

text\<open>Note ``body'' is the generator of @{term "lrev_def"}.\<close>

lemma lrev_strict[simp]: "lrev\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

fixrec lrev_body :: "('a llist \<rightarrow> 'a llist) \<rightarrow> 'a llist \<rightarrow> 'a llist"
where
  "lrev_body\<cdot>r\<cdot>lnil = lnil"
| "lrev_body\<cdot>r\<cdot>(x :@ xs) = r\<cdot>xs :++ (x :@ lnil)"

lemma lrev_body_strict[simp]: "lrev_body\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

text\<open>This is trivial but syntactically a bit touchy. Would be nicer
to define @{term "lrev_body"} as the generator of the fixpoint
definition of @{term "lrev"} directly.\<close>

lemma lrev_lrev_body_eq: "lrev = fix\<cdot>lrev_body"
  by (rule cfun_eqI, subst lrev_def, subst lrev_body.unfold, simp)

text\<open>Wrap / unwrap functions.\<close>

definition
  unwrapH :: "('a llist \<rightarrow> 'a llist) \<rightarrow> 'a llist \<rightarrow> 'a H" where
  "unwrapH \<equiv> \<Lambda> f xs . list2H\<cdot>(f\<cdot>xs)"

lemma unwrapH_strict[simp]: "unwrapH\<cdot>\<bottom> = \<bottom>"
  unfolding unwrapH_def by (rule cfun_eqI, simp)

definition
  wrapH :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a llist" where
  "wrapH \<equiv> \<Lambda> f xs . H2list\<cdot>(f\<cdot>xs)"

lemma wrapH_unwrapH_id: "wrapH oo unwrapH = ID" (is "?lhs = ?rhs")
proof(rule cfun_eqI)+
  fix f xs
  have "?lhs\<cdot>f\<cdot>xs = H2list\<cdot>(list2H\<cdot>(f\<cdot>xs))" by (simp add: wrapH_def unwrapH_def)
  also have "\<dots> = (H2list oo list2H)\<cdot>(f\<cdot>xs)" by simp
  also have "\<dots> = ID\<cdot>(f\<cdot>xs)" by (simp only: H2list_list2H_inv)
  also have "\<dots> = ?rhs\<cdot>f\<cdot>xs" by simp
  finally show "?lhs\<cdot>f\<cdot>xs = ?rhs\<cdot>f\<cdot>xs" .
qed

subsection\<open>Gill/Hutton-style worker/wrapper.\<close>

definition
  lrev_work :: "'a llist \<rightarrow> 'a H" where
  "lrev_work \<equiv> fix\<cdot>(unwrapH oo lrev_body oo wrapH)"

definition
  lrev_wrap :: "'a llist \<rightarrow> 'a llist" where
  "lrev_wrap \<equiv> wrapH\<cdot>lrev_work"

lemma lrev_lrev_ww_eq: "lrev = lrev_wrap"
  using worker_wrapper_id[OF wrapH_unwrapH_id lrev_lrev_body_eq]
  by (simp add: lrev_wrap_def lrev_work_def)

subsection\<open>Optimise worker/wrapper.\<close>

text\<open>Intermediate worker.\<close>

fixrec lrev_body1 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body1\<cdot>r\<cdot>lnil = list2H\<cdot>lnil"
| "lrev_body1\<cdot>r\<cdot>(x :@ xs) = list2H\<cdot>(wrapH\<cdot>r\<cdot>xs :++ (x :@ lnil))"

definition
  lrev_work1 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work1 \<equiv> fix\<cdot>lrev_body1"

lemma lrev_body_lrev_body1_eq: "lrev_body1 = unwrapH oo lrev_body oo wrapH"
  apply (rule cfun_eqI)+
  apply (subst lrev_body.unfold)
  apply (subst lrev_body1.unfold)
  apply (case_tac xa)
  apply (simp_all add: list2H_def wrapH_def unwrapH_def)
  done

lemma lrev_work1_lrev_work_eq: "lrev_work1 = lrev_work"
  by (unfold lrev_work_def lrev_work1_def,
      rule cfun_arg_cong[OF lrev_body_lrev_body1_eq])

text\<open>Now use the homomorphism.\<close>

fixrec lrev_body2 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body2\<cdot>r\<cdot>lnil = ID"
| "lrev_body2\<cdot>r\<cdot>(x :@ xs) = list2H\<cdot>(wrapH\<cdot>r\<cdot>xs) oo list2H\<cdot>(x :@ lnil)"

lemma lrev_body2_strict[simp]: "lrev_body2\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  lrev_work2 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work2 \<equiv> fix\<cdot>lrev_body2"

lemma lrev_work2_strict[simp]: "lrev_work2\<cdot>\<bottom> = \<bottom>"
  unfolding lrev_work2_def
  by (subst fix_eq) simp

lemma lrev_body2_lrev_body1_eq: "lrev_body2 = lrev_body1"
  by ((rule cfun_eqI)+
     , (subst lrev_body1.unfold, subst lrev_body2.unfold)
     , (simp add: H_llist_hom_append[symmetric] H_llist_hom_id))

lemma lrev_work2_lrev_work1_eq: "lrev_work2 = lrev_work1"
  by (unfold lrev_work2_def lrev_work1_def
     , rule cfun_arg_cong[OF lrev_body2_lrev_body1_eq])

text \<open>Simplify.\<close>

fixrec lrev_body3 :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body3\<cdot>r\<cdot>lnil = ID"
| "lrev_body3\<cdot>r\<cdot>(x :@ xs) = r\<cdot>xs oo list2H\<cdot>(x :@ lnil)"

lemma lrev_body3_strict[simp]: "lrev_body3\<cdot>r\<cdot>\<bottom> = \<bottom>"
by fixrec_simp

definition
  lrev_work3 :: "'a llist \<rightarrow> 'a H" where
  "lrev_work3 \<equiv> fix\<cdot>lrev_body3"

lemma lrev_wwfusion: "list2H\<cdot>((wrapH\<cdot>lrev_work2)\<cdot>xs) = lrev_work2\<cdot>xs"
proof -
  {
    have "list2H oo wrapH\<cdot>lrev_work2 = unwrapH\<cdot>(wrapH\<cdot>lrev_work2)"
      by (rule cfun_eqI, simp add: unwrapH_def)
    also have "\<dots> = (unwrapH oo wrapH)\<cdot>lrev_work2" by simp
    also have "\<dots> = lrev_work2"
      apply -
      apply (rule worker_wrapper_fusion[OF wrapH_unwrapH_id, where body="lrev_body"])
      apply (auto iff: lrev_body2_lrev_body1_eq lrev_body_lrev_body1_eq lrev_work2_def lrev_work1_def)
      done
    finally have "list2H oo wrapH\<cdot>lrev_work2 = lrev_work2" .
  }
  thus ?thesis using cfun_eq_iff[where f="list2H oo wrapH\<cdot>lrev_work2" and g="lrev_work2"] by auto
qed

text\<open>If we use this result directly, we only get a partially-correct
program transformation, see \<^citet>\<open>"Tullsen:PhDThesis"\<close> for details.\<close>

lemma "lrev_work3 \<sqsubseteq> lrev_work2"
  unfolding lrev_work3_def
proof(rule fix_least)
  {
    fix xs have "lrev_body3\<cdot>lrev_work2\<cdot>xs = lrev_work2\<cdot>xs"
    proof(cases xs)
      case bottom thus ?thesis by simp
    next
      case lnil thus ?thesis
        unfolding lrev_work2_def
        by (subst fix_eq[where F="lrev_body2"], simp)
    next
      case (lcons y ys)
      hence "lrev_body3\<cdot>lrev_work2\<cdot>xs = lrev_work2\<cdot>ys oo list2H\<cdot>(y :@ lnil)" by simp
      also have "\<dots> = list2H\<cdot>((wrapH\<cdot>lrev_work2)\<cdot>ys) oo list2H\<cdot>(y :@ lnil)"
        using lrev_wwfusion[where xs=ys] by simp
      also from lcons have "\<dots> = lrev_body2\<cdot>lrev_work2\<cdot>xs" by simp
      also have "\<dots> = lrev_work2\<cdot>xs"
        unfolding lrev_work2_def by (simp only: fix_eq[symmetric])
      finally show ?thesis by simp
    qed
  }
  thus "lrev_body3\<cdot>lrev_work2 = lrev_work2" by (rule cfun_eqI)
qed

text\<open>We can't show the reverse inclusion in the same way as the
fusion law doesn't hold for the optimised definition. (Intuitively we
haven't established that it is equal to the original @{term "lrev"}
definition.) We could show termination of the optimised definition
though, as it operates on finite lists. Alternatively we can use
induction (over the list argument) to show total equivalence.

The following lemma shows that the fusion Gill/Hutton want to do is
completely sound in this context, by appealing to the lazy list
induction principle.\<close>

lemma lrev_work3_lrev_work2_eq: "lrev_work3 = lrev_work2" (is "?lhs = ?rhs")
proof(rule cfun_eqI)
  fix x
  show "?lhs\<cdot>x = ?rhs\<cdot>x"
  proof(induct x)
    show "lrev_work3\<cdot>\<bottom> = lrev_work2\<cdot>\<bottom>"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      by (simp add: lrev_body3.unfold lrev_body2.unfold)
  next
    show "lrev_work3\<cdot>lnil = lrev_work2\<cdot>lnil"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      by (simp add: lrev_body3.unfold lrev_body2.unfold)
  next
    fix a l assume "lrev_work3\<cdot>l = lrev_work2\<cdot>l"
    thus "lrev_work3\<cdot>(a :@ l) = lrev_work2\<cdot>(a :@ l)"
      apply (unfold lrev_work3_def lrev_work2_def)
      apply (subst fix_eq[where F="lrev_body2"])
      apply (subst fix_eq[where F="lrev_body3"])
      apply (fold lrev_work3_def lrev_work2_def)
      apply (simp add: lrev_body3.unfold lrev_body2.unfold lrev_wwfusion)
      done
  qed simp_all
qed

text\<open>Use the combined worker/wrapper-fusion rule. Note we get a weaker lemma.\<close>

lemma lrev3_2_syntactic: "lrev_body3 oo (unwrapH oo wrapH) = lrev_body2"
  apply (subst lrev_body2.unfold, subst lrev_body3.unfold)
  apply (rule cfun_eqI)+
  apply (case_tac xa)
    apply (simp_all add: unwrapH_def)
  done

lemma lrev_work3_lrev_work2_eq': "lrev = wrapH\<cdot>lrev_work3"
proof -
  from lrev_lrev_body_eq
  have "lrev = fix\<cdot>lrev_body" .
  also from wrapH_unwrapH_id unwrapH_strict
  have "\<dots> = wrapH\<cdot>(fix\<cdot>lrev_body3)"
    by (rule worker_wrapper_fusion_new
       , simp add: lrev3_2_syntactic lrev_body2_lrev_body1_eq lrev_body_lrev_body1_eq)
  finally show ?thesis unfolding lrev_work3_def by simp
qed

text\<open>Final syntactic tidy-up.\<close>

fixrec lrev_body_final :: "('a llist \<rightarrow> 'a H) \<rightarrow> 'a llist \<rightarrow> 'a H"
where
  "lrev_body_final\<cdot>r\<cdot>lnil\<cdot>ys = ys"
| "lrev_body_final\<cdot>r\<cdot>(x :@ xs)\<cdot>ys = r\<cdot>xs\<cdot>(x :@ ys)"

definition
  lrev_work_final :: "'a llist \<rightarrow> 'a H" where
  "lrev_work_final \<equiv> fix\<cdot>lrev_body_final"

definition
  lrev_final :: "'a llist \<rightarrow> 'a llist" where
  "lrev_final \<equiv> \<Lambda> xs. lrev_work_final\<cdot>xs\<cdot>lnil"

lemma lrev_body_final_lrev_body3_eq': "lrev_body_final\<cdot>r\<cdot>xs = lrev_body3\<cdot>r\<cdot>xs"
  apply (subst lrev_body_final.unfold)
  apply (subst lrev_body3.unfold)
  apply (cases xs)
  apply (simp_all add: list2H_def ID_def cfun_eqI)
  done

lemma lrev_body_final_lrev_body3_eq: "lrev_body_final = lrev_body3"
  by (simp only: lrev_body_final_lrev_body3_eq' cfun_eqI)

lemma lrev_final_lrev_eq: "lrev = lrev_final" (is "?lhs = ?rhs")
proof -
  have "?lhs = lrev_wrap" by (rule lrev_lrev_ww_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work" by (simp only: lrev_wrap_def)
  also have "\<dots> = wrapH\<cdot>lrev_work1" by (simp only: lrev_work1_lrev_work_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work2" by (simp only: lrev_work2_lrev_work1_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work3" by (simp only: lrev_work3_lrev_work2_eq)
  also have "\<dots> = wrapH\<cdot>lrev_work_final" by (simp only: lrev_work3_def lrev_work_final_def lrev_body_final_lrev_body3_eq)
  also have "\<dots> = lrev_final" by (simp add: lrev_final_def cfun_eqI H2list_def wrapH_def)
  finally show ?thesis .
qed

(*<*)
end
(*>*)


(*
  File: Irrationality_J_Hancl.thy
  Authors:  Angeliki Koutsoukou-Argyraki and Wenda Li,
            Computer Laboratory, University of Cambridge, UK.
  Email: ak2110@cam.ac.uk, wl302@cam.ac.uk
*)

section \<open>Irrational Rapidly Convergent Series\<close>
theory Irrationality_J_Hancl
  imports "HOL-Analysis.Analysis" "HOL-Decision_Procs.Approximation"
begin

text \<open>This is the formalisation of a proof by J. Hančl, in particular of the proof of his Theorem 3 in
the paper: Irrational Rapidly Convergent Series, Rend. Sem. Mat. Univ. Padova, Vol 107 (2002).

The statement asserts the irrationality of the sum of a series consisting of rational numbers
defined using sequences that fulfill certain properties. Even though the statement
is number-theoretic, the proof uses only arguments from introductory Analysis.\<close>

text \<open>We prove the central result (theorem Hancl3) by contradiction, by making use of some of
 the auxiliary lemmas. To this end, assuming that the sum is a rational number, for a quantity
 $\textrm{ALPHA}(n)$ we show that $\textrm{ALPHA}(n) \geq 1$ for all $n \in \mathbb{N}$. After that we show that we can find an
  $n \in \mathbb{N}$ for which $\textrm{ALPHA}(n) < 1$ which yields a contradiction and we thus conclude that the
  sum of the series is rational. We finally give an immediate application of theorem Hancl3
 for a specific series (corollary Hancl3corollary, requiring lemma
 summable\_ln\_plus) which corresponds to Corollary 2 in the original
paper by J. Hančl.
\<close>

hide_const floatarith.Max

subsection \<open>Misc\<close>

lemma filterlim_sequentially_iff:
  "filterlim f F1 sequentially \<longleftrightarrow> filterlim (\<lambda>x. f (x+k)) F1 sequentially"
  unfolding filterlim_iff
  by (metis eventually_at_top_linorder eventually_sequentially_seg)

lemma filterlim_realpow_sequentially_at_top:
  "(x::real) > 1 \<Longrightarrow> filterlim (power x) at_top sequentially"
  apply (rule LIMSEQ_divide_realpow_zero[THEN filterlim_inverse_at_top,of _ 1,simplified])
  by auto

lemma filterlim_at_top_powr_real:
  fixes g::"'b \<Rightarrow> real"
  assumes "filterlim f at_top F" "(g \<longlongrightarrow> g') F" "g'>1"
  shows "LIM x F. g x powr f x :> at_top"
proof -
  have "LIM x F. ((g' + 1) / 2) powr f x :> at_top"
  proof (subst filterlim_at_top_gt[of _ _ 1],rule+)
    fix Z::real assume "Z > 1"
    have "\<forall>\<^sub>F x in F. ln Z / ln ((g' + 1) / 2) \<le> f x"
      using assms(1) filterlim_at_top by blast
    then have "\<forall>\<^sub>F x in F. ln Z \<le> ln (((g' + 1) / 2) powr f x)"
    proof (eventually_elim)
      case (elim x)
      then show ?case
      using \<open>g'>1\<close> by (auto simp:ln_powr divide_simps)
    qed
    then show "\<forall>\<^sub>F x in F. Z \<le> ((g' + 1) / 2) powr f x"
    proof (eventually_elim)
      case (elim x)
      then show ?case
        using \<open>1 < Z\<close> \<open>g'>1\<close> by auto
    qed
  qed
  moreover have "\<forall>\<^sub>F x in F. ((g'+1)/2) powr f x \<le> g x powr f x"
  proof -
    have "\<forall>\<^sub>F x in F. g x > (g'+1)/2"
      apply (rule order_tendstoD[OF assms(2)])
      using \<open>g'>1\<close> by auto
    moreover have "\<forall>\<^sub>F x in F. f x>0"
      using assms(1) filterlim_at_top_dense by blast
    ultimately show ?thesis
    proof eventually_elim
      case (elim x)
      then show ?case
        using \<open>g'>1\<close> by (auto intro!: powr_mono2)
    qed
  qed
  ultimately show ?thesis using filterlim_at_top_mono by fast
qed

lemma powrfinitesum:
  fixes a::real and s::nat assumes  "s \<le> n"
  shows " (\<Prod>j=s..(n::nat).(a powr (2^j)))  = a powr (\<Sum>j=s..(n::nat).(2^j)) "
  using \<open>s \<le> n\<close>
proof(induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  have ?case when "s\<le>n" using Suc.hyps
    by (metis Suc.prems add.commute linorder_not_le powr_add prod.nat_ivl_Suc' sum.cl_ivl_Suc that)
  moreover have ?case when "s=Suc n"
  proof-
    have "(\<Prod>j = s..Suc n. a powr 2 ^ j) =(a powr 2 ^(Suc n))  "
      using \<open>s=Suc n\<close> by simp
    also have "a powr 2 ^ Suc n = a powr sum (power 2) {s..Suc n}" using that by auto
    ultimately show "(\<Prod>j = s..Suc n. a powr 2 ^ j) = a powr sum (power 2) {s..Suc n}"
      using \<open>s\<le>Suc n\<close> by linarith
  qed
  ultimately show ?case using \<open>s\<le>Suc n\<close> by linarith
qed

lemma summable_ratio_test_tendsto:
  fixes f :: "nat \<Rightarrow> 'a::banach"
  assumes "c < 1" and "\<forall>n. f n\<noteq>0" and "(\<lambda>n. norm (f (Suc n)) / norm (f n)) \<longlonglongrightarrow> c"
  shows "summable f"
proof -
  obtain N where N_dist:"\<forall>n\<ge>N. dist (norm (f (Suc n)) / norm (f n)) c < (1-c)/2"
    using assms unfolding tendsto_iff eventually_sequentially
    by (meson diff_gt_0_iff_gt zero_less_divide_iff zero_less_numeral)
  have "norm (f (Suc n)) / norm (f n) \<le> (1+c)/2" when "n\<ge>N" for n
    using N_dist[rule_format,OF that] \<open>c<1\<close>
    apply (auto simp add:field_simps dist_norm)
    by argo
  then have "norm (f (Suc n))  \<le> (1+c)/2 * norm (f n)" when "n\<ge>N" for n
    using that assms(2)[rule_format, of n] by (auto simp add:divide_simps)
  moreover have "(1+c)/2 < 1" using \<open>c<1\<close> by auto
  ultimately show ?thesis
    using summable_ratio_test[of _ N f] by blast
qed

lemma summable_ln_plus:
  fixes f::"nat \<Rightarrow> real"
  assumes "summable f" "\<forall>n. f n>0"
  shows "summable (\<lambda>n. ln (1+f n))"
proof (rule summable_comparison_test_ev[OF _ assms(1)])
  have "ln (1 + f n) > 0" for n by (simp add: assms(2) ln_gt_zero)
  moreover have "ln (1 + f n) \<le> f n" for n
    apply (rule ln_add_one_self_le_self2)
    using assms(2)[rule_format,of n] by auto
  ultimately show "\<forall>\<^sub>F n in sequentially. norm (ln (1 + f n)) \<le> f n"
    by (auto intro!: eventuallyI simp add:less_imp_le)
qed

lemma suminf_real_offset_le:
  fixes f :: "nat \<Rightarrow> real"
  assumes f: "\<And>i. 0 \<le> f i" and "summable f"
  shows "(\<Sum>i. f (i + k)) \<le> suminf f"
proof -
  have "(\<lambda>n. \<Sum>i<n. f (i + k)) \<longlonglongrightarrow> (\<Sum>i. f (i + k))"
    using summable_sums[OF \<open>summable f\<close>]
    by (simp add: assms(2) summable_LIMSEQ summable_ignore_initial_segment)
  moreover have "(\<lambda>n. \<Sum>i<n. f i) \<longlonglongrightarrow> (\<Sum>i. f i)"
    using summable_sums[OF \<open>summable f\<close>] by (simp add: sums_def atLeast0LessThan f)
  then have "(\<lambda>n. \<Sum>i<n + k. f i) \<longlonglongrightarrow> (\<Sum>i. f i)"
    by (rule LIMSEQ_ignore_initial_segment)
  ultimately show ?thesis
  proof (rule LIMSEQ_le, safe intro!: exI[of _ k])
    fix n assume "k \<le> n"
    have "(\<Sum>i<n. f (i + k)) = (\<Sum>i<n. (f \<circ> (\<lambda>i. i + k)) i)"
      by simp
    also have "\<dots> = (\<Sum>i\<in>(\<lambda>i. i + k) ` {..<n}. f i)"
      by (subst sum.reindex) auto
    also have "\<dots> \<le> sum f {..<n + k}"
      by (intro sum_mono2) (auto simp: f)
    finally show "(\<Sum>i<n. f (i + k)) \<le> sum f {..<n + k}" .
  qed
qed

lemma factt:
  fixes s n ::nat assumes "s \<le> n"
  shows " (\<Sum>i=s..n. 2^i) < (2^(n+1) :: real) " using assms
proof (induct n)
  case 0
  show ?case by  auto
next
  case (Suc n)
  have ?case when  "s=n+1" using that by auto
  moreover have ?case when  "s \<noteq> n+1"
  proof -
    have"(\<Sum>i=s..(n+1). 2^i ) = (\<Sum>i=s..n. 2^i ) + (2::real)^(n+1) "
      using sum.cl_ivl_Suc \<open>s \<le> Suc n \<close>
      by (auto simp add:add.commute)
    also have "... < (2) ^ (n +1) + (2)^(n+1)"
    proof -
      have "s \<le>n" using that  \<open>s \<le> Suc n \<close> by auto
      then show ?thesis
        using Suc.hyps \<open>s \<le> n\<close> by linarith
    qed
    also have "... = 2^(n+2)" by simp
    finally show "(\<Sum>i=s..(Suc n). 2^i )< (2::real)^(Suc n+1)" by auto
  qed
  ultimately show ?case by blast
qed

subsection \<open>Auxiliary lemmas and the main proof\<close>

lemma showpre7:
  fixes a b ::"nat\<Rightarrow>int " and q p::int
  assumes "q>0" and "p>0"and a: "\<forall>n. a n>0" and "\<forall>n. b n>0" and
    assumerational:"(\<lambda> n. b (n+1) / a (n+1) )  sums (p/q)"
  shows "q*((\<Prod>j=1..n. of_int( a j)))*(suminf (\<lambda>(j::nat). (b (j+n+1)/ a (j+n+1 ))))
        = ((\<Prod>j=1..n. of_int( a j)))*(p -q* (\<Sum>j=1..n. b j / a j))       "
proof -
  define aa where "aa=(\<Prod>j = 1..n. real_of_int (a j))"
  define ff where "ff=(\<lambda>i. real_of_int (b (i+1)) / real_of_int (a (i+1)))"

  have "(\<Sum>j. ff (j+n)) =  (\<Sum>n. ff n) - sum ff {..<n}"
    apply (rule suminf_minus_initial_segment)
    using assumerational unfolding ff_def by (simp add: sums_summable)
  also have "... = p/q - sum ff {..<n}"
    using assumerational unfolding ff_def by (simp add: sums_iff)
  also have "... = p/q - (\<Sum>j=1..n. ff (j-1))"
  proof -
    have "sum ff {..<n} = (\<Sum>j=1..n. ff (j-1))"
      apply (subst sum_bounds_lt_plus1[symmetric])
      by simp
    then show ?thesis unfolding ff_def by auto
  qed
  finally have "(\<Sum>j. ff (j + n)) = p / q - (\<Sum>j = 1..n. ff (j - 1))" .
  then have "q*(\<Sum>j. ff (j + n)) = p - q*(\<Sum>j = 1..n. ff (j - 1))"
    using \<open>q>0\<close> by (auto simp add:field_simps)
  then have "aa*q*(\<Sum>j. ff (j + n)) = aa*(p - q*(\<Sum>j = 1..n. ff (j - 1)))"
    by auto
  then show ?thesis unfolding aa_def ff_def by auto
qed

lemma show7:
  fixes d::"nat\<Rightarrow>real" and a b::"nat\<Rightarrow>int " and q p::int
  assumes "q \<ge>1" and "p \<ge> 1" and a: "\<forall>n. a n \<ge> 1" and "\<forall>n. b n \<ge> 1"
    and assumerational:"(\<lambda> n. b (n+1) / a (n+1) ) sums (p/q)"
  shows "q*((\<Prod>j=1..n. of_int( a j)))*( suminf (\<lambda> (j::nat). (b (j+n+1)/ a (j+n+1 )))) \<ge> 1 "
    (is "?L \<ge> _")
proof-
  define LL where "LL=?L"
  define aa where "aa=(\<Prod>j = 1..n. real_of_int (a j))"
  define ff where "ff=(\<lambda>i. real_of_int (b (i+1)) / real_of_int (a (i+1)))"

  have "?L > 0"
  proof -
    have "aa > 0"
      unfolding aa_def using a
    by (induction n) (simp_all add: int_one_le_iff_zero_less prod_pos)
    moreover have "(\<Sum>j. ff (j + n)) > 0"
    proof (rule suminf_pos)
      have "summable ff" unfolding ff_def using assumerational
        using summable_def by blast
      then show " summable (\<lambda>j. ff (j + n))" using summable_iff_shift[of ff n] by auto
      show "\<And>i. 0 < ff (i + n)" unfolding ff_def using a assms(4) int_one_le_iff_zero_less by auto
    qed
    ultimately show ?thesis unfolding aa_def ff_def using \<open>q\<ge>1\<close> by auto
  qed
  moreover have "?L \<in> \<int>"
  proof -
    have "?L = aa *(p -q* ( \<Sum>j=1..n. b j / a j))"
      unfolding aa_def
      using a assms assumerational int_one_le_iff_zero_less showpre7 by force
    also have "... = aa * p - q * (\<Sum>j=1..n. aa * b j / a j)"
      by (auto simp add:algebra_simps sum_distrib_left)
    also have "... = prod a {1..n} * p - q * (\<Sum>j = 1..n. b j * prod a ({1..n} - {j}))"
    proof -
      have "(\<Sum>j=1..n. aa * b j / a j) = (\<Sum>j=1..n. b j * prod a ({1..n} - {j}))"
        unfolding of_int_sum
      proof (rule sum.cong)
        fix j assume "j \<in> {1..n}"
        then have "(\<Prod>i = 1..n. real_of_int (a i)) = a j * (\<Prod>i\<in>{1..n} - {j}. real_of_int (a i))"
          by (meson finite_atLeastAtMost prod.remove)
        then have "aa / real_of_int (a j) = prod a ({1..n} - {j})"
          unfolding aa_def using a[rule_format,of j] by (auto simp add:field_simps)
        then show "aa * b j / a j = b j * prod a ({1..n} - {j})"
          by (metis mult.commute of_int_mult times_divide_eq_right)
      qed simp
      moreover have "aa * p = (\<Prod>j = 1..n.  (a j)) *  p"
        unfolding aa_def by auto
      ultimately show ?thesis by force
    qed
    also have "... \<in> \<int>" using Ints_of_int by blast
    finally show ?thesis .
  qed
  ultimately show ?thesis
    apply (fold LL_def)
    by (metis Ints_cases int_one_le_iff_zero_less not_less of_int_0_less_iff of_int_less_1_iff)
qed

lemma show8:
  fixes d ::"nat\<Rightarrow>real " and a :: "nat\<Rightarrow>int" and s k::nat
  assumes "A > 1" and d: "\<forall>n. d n> 1"  and a:"\<forall>n. a n>0" and "s>0"
    and "convergent_prod d"
    and assu2: "\<forall>n \<ge> s. A / of_int (a n) powr (1 / of_int (2^n)) > (\<Prod>j. d (n + j))"
  shows "\<forall>n\<ge>s. (\<Prod>j. d (j+n)) < A / (MAX j\<in>{s..n}. of_int (a j) powr (1 / of_int (2 ^ j)))"
proof (intro strip)
  fix n assume "s \<le> n"
  define sp where "sp \<equiv> (\<lambda>n. \<Prod>j. d (j+n))"
  define ff where "ff \<equiv> (\<lambda>(j::nat). (real_of_int (a j)) powr(1 /of_int (2^j)))"
  have "sp i \<ge> sp n" when "i\<le>n" for i
  proof -
    have "(\<Prod>j. d (j + i)) = (\<Prod>ia. d (ia + (n - i) + i)) * (\<Prod>ia<n - i. d (ia + i))"
    proof (rule prodinf_split_initial_segment)
      show "convergent_prod (\<lambda>j. d (j + i))"
        using \<open>convergent_prod d\<close> convergent_prod_iff_shift[of d i] by simp
      show "\<And>j. j < n - i \<Longrightarrow> d (j + i) \<noteq> 0"
        by (metis d not_one_less_zero)
    qed
    then have "sp i = sp n * (\<Prod>j<n - i. d (i + j))"
      unfolding sp_def using \<open>n\<ge>i\<close> by (auto simp:algebra_simps)
    moreover have "sp i>1" "sp n>1"
      unfolding sp_def using convergent_prod_iff_shift \<open>convergent_prod d\<close> d
      by (auto intro!:less_1_prodinf)
    moreover have "(\<Prod>j<n - i. d (i + j)) \<ge> 1"
      using d less_imp_le by (auto intro: prod_ge_1)
    ultimately show ?thesis by auto
  qed
  moreover have "\<forall>j\<ge>s. A / ff j > sp j"
    unfolding ff_def sp_def using assu2 by (auto simp:algebra_simps)
  ultimately have "\<forall>j. s\<le>j \<and> j\<le>n \<longrightarrow> A / ff j > sp n" by force
  then show "sp n< A / Max (ff ` {s..n})"
    by (metis (mono_tags, opaque_lifting) Max_in \<open>n\<ge>s\<close> atLeastAtMost_iff empty_iff
        finite_atLeastAtMost finite_imageI imageE image_is_empty order_refl)
qed

lemma auxiliary1_9:
  fixes d ::"nat\<Rightarrow>real" and a::"nat\<Rightarrow>int " and s m::nat
  assumes d: "\<forall>n. d n> 1"  and a: "\<forall>n. a n>0" and "s>0" and "n \<ge> m" and " m \<ge> s"
    and auxifalse_assu: "\<forall>n\<ge>m. (of_int (a (n+1))) powr(1 /of_int (2^(n+1))) <
              (d (n+1))* (Max ((\<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} ))"
  shows "(of_int (a (n+1))) powr(1 /of_int (2^(n+1))) <
    (\<Prod>j=(m+1)..(n+1). d j) * (Max ((\<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..m}))"
proof-
  define ff where "ff \<equiv> \<lambda>j. real_of_int (a j) powr (1 / of_int (2^j))"
  have [simp]:"ff j > 0" for j
    unfolding ff_def by (metis a less_numeral_extra(3) of_int_0_less_iff powr_gt_zero)

  have ff_asm:"ff (n+1) < d (n+1) * Max (ff ` {s..n})" when "n\<ge>m" for n
    using auxifalse_assu that unfolding ff_def by simp
  from \<open>n\<ge>m\<close>
  have Q: "(Max( ff ` {s..n} )) \<le> (\<Prod>j=(m+1)..n. d j)* (Max (ff ` {s..m}))"
  proof(induct n)
    case 0
    then show ?case using \<open>m\<ge>s\<close> by simp
  next
    case (Suc n)
    have ?case when "m=Suc n"
      using that by auto
    moreover have ?case when "m\<noteq>Suc n"
    proof -
      have "m \<le> n" using that Suc(2) by simp
      then have IH: "Max (ff ` {s..n}) \<le> prod d {m + 1..n} * Max (ff ` {s..m})"
        using Suc(1) by linarith
      have "Max (ff ` {s..Suc n}) = Max (ff ` {s..n} \<union> {ff (Suc n)})"
        using Suc.prems assms(5) atLeastAtMostSuc_conv by auto
      also have "... = max (Max (ff ` {s..n})) (ff (Suc n))"
        using Suc.prems assms(5) max_def sup_assoc that by auto
      also have "... \<le> max (Max (ff ` {s..n})) (d (n+1) * Max (ff ` {s..n}))"
        using \<open>m \<le> n\<close> ff_asm by fastforce
      also have "... \<le> Max (ff ` {s..n}) * max 1 (d (n+1))"
      proof -
        have "Max (ff ` {s..n}) \<ge> 0"
          by (metis (mono_tags, opaque_lifting) Max_in \<open>\<And>j. 0 < ff j\<close> \<open>m \<le> n\<close> assms(5)
              atLeastAtMost_iff empty_iff finite_atLeastAtMost finite_imageI imageE
              image_is_empty less_eq_real_def)
        then show ?thesis using max_mult_distrib_right
          by (simp add: max_mult_distrib_right mult.commute)
      qed
      also have "... = Max (ff ` {s..n}) * d (n+1)"
        by (metis d max.commute max.strict_order_iff)
      also have "... \<le>  prod d {m + 1..n} * Max (ff ` {s..m}) * d (n+1)"
        using IH d[rule_format, of "n+1"] by auto
      also have "... = prod d {m + 1..n+1} * Max (ff ` {s..m})"
        using \<open>n\<ge>m\<close> by (simp add:prod.nat_ivl_Suc' algebra_simps)
      finally show ?case by simp
    qed
    ultimately show ?case by blast
  qed
  then have "d (n+1) * Max (ff ` {s..n} ) \<le> (\<Prod>j=(m+1)..(n+1). d j)* (Max (ff ` {s..m}))"
    using \<open>m\<le>n\<close> d[rule_format,of "Suc n"] by (simp add:prod.nat_ivl_Suc')
  then show ?thesis using ff_asm[of n] \<open>s\<le>m\<close> \<open>m\<le>n\<close> unfolding ff_def by auto
qed

lemma show9:
  fixes d ::"nat\<Rightarrow>real " and a :: "nat\<Rightarrow>int " and s ::nat and A::real
  assumes   "A > 1" and  d: "\<forall>n. d n> 1"  and a: "\<forall>n. a n>0" and "s>0"
    and assu1: "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (2^n)))\<longlongrightarrow> A) sequentially "
    and "convergent_prod d"
    and 8: "\<forall>n\<ge>s. prodinf (\<lambda>j. d( n+j))
                  < A/(Max ((\<lambda>(j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n})) "
  shows "\<forall>m \<ge>s. \<exists>n\<ge>m.  ( (of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
          (d (n+1))* (Max ( ( \<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
proof (rule ccontr)
  define ff where "ff \<equiv> (\<lambda>j. real_of_int (a j) powr (1 / of_int (2^j)))"
  assume assumptioncontra: " \<not> (\<forall>m \<ge>s. \<exists>n\<ge>m. ff(n+1) \<ge> d(n+1) * Max (ff  ` {s..n}))"

  then obtain t where "t\<ge>s" and
    ttt: "\<forall>n\<ge>t. ff (n+1) < d (n+1) * Max (ff ` {s..n})"
    by fastforce
  define B where "B \<equiv> \<Prod>j. d (t + 1 + j)"
  have "B>0" unfolding B_def
  proof (rule less_0_prodinf)
    show "convergent_prod (\<lambda>j. d (t + 1 + j))"
      using convergent_prod_iff_shift[of d "t+1"] \<open>convergent_prod d\<close>
      by (auto simp: algebra_simps)
    show "\<And>i. 0 < d (t + 1 + i)"
      using d le_less_trans zero_le_one by blast
  qed
  have "A \<le> B * Max ( ff ` {s..t})"
  proof (rule tendsto_le[of sequentially "\<lambda>n. (\<Prod>j=(t+1)..(n+1). d j) * Max ( ff ` {s..t})" _
        "\<lambda>n. ff (n+1)"])
    show "(\<lambda>n. ff (n + 1)) \<longlonglongrightarrow> A"
      using assu1[folded ff_def] LIMSEQ_ignore_initial_segment by blast
    have "(\<lambda>n. prod d {t + 1..n + 1}) \<longlonglongrightarrow> B"
    proof -
      have "convergent_prod (\<lambda>j. d (t + 1 + j))"
        using \<open>convergent_prod d\<close> convergent_prod_iff_shift[of d "t+1"] by (simp add:algebra_simps)
      then have "(\<lambda>n. \<Prod>i\<le>n. d (t + 1 + i)) \<longlonglongrightarrow> B"
        using B_def convergent_prod_LIMSEQ by blast
      then have "(\<lambda>n. \<Prod>i\<in>{0..n}. d (i+(t + 1))) \<longlonglongrightarrow> B"
        using atLeast0AtMost by (auto simp:algebra_simps)
      then have "(\<lambda>n. prod d {(t + 1)..n + (t + 1)}) \<longlonglongrightarrow> B"
        apply (subst (asm) prod.shift_bounds_cl_nat_ivl[symmetric])
        by simp
      from seq_offset_neg[OF this,of "t"]
      show "(\<lambda>n. prod d {t + 1..n+1}) \<longlonglongrightarrow> B"
        apply (elim Lim_transform)
        apply (rule LIMSEQ_I)
        apply (rule exI[where x="t+1"])
        by auto
    qed
    then show "(\<lambda>n. prod d {t + 1..n + 1} * Max (ff ` {s..t})) \<longlonglongrightarrow> B * Max (ff ` {s..t})"
      by (auto intro:tendsto_eq_intros)
    have "\<forall>\<^sub>F n in sequentially. (ff (n+1)) < (\<Prod>j=(t+1)..(n+1). d j) * (Max ( ff ` {s..t}))"
      unfolding eventually_sequentially ff_def
      using auxiliary1_9[OF d a \<open>s>0\<close> _ \<open>t\<ge>s\<close> ttt[unfolded ff_def]]
      by blast
    then show "\<forall>\<^sub>F n in sequentially. (ff (n+1)) \<le> (\<Prod>j=(t+1)..(n+1). d j) * (Max ( ff ` {s..t}))"
      by (eventually_elim,simp)
  qed simp
  also have "... \<le> B * Max ( ff ` {s..t+1})"
  proof -
    have "Max (ff ` {s..t}) \<le> Max (ff ` {s..t + 1})"
      using \<open>t\<ge>s\<close> by (auto intro: Max_mono)
    then show ?thesis using \<open>B>0\<close> by auto
  qed
  finally have "A \<le> B * Max (ff ` {s..t + 1})"
    unfolding B_def .
  moreover have "B < A / Max (ff ` {s..t + 1})"
    using 8[rule_format, of "t+1",folded ff_def B_def] \<open>s\<le>t\<close> by auto
  moreover have "Max (ff ` {s..t+1})>0"
    using \<open>A \<le> B * Max (ff ` {s..t + 1})\<close> \<open>B>0\<close> \<open>A>1\<close> zero_less_mult_pos [of B "Max (ff ` {s..Suc t})"]
    by fastforce
  ultimately show False by (auto simp add:field_simps)
qed

lemma show10:
  fixes d ::"nat\<Rightarrow>real " and  a ::"nat\<Rightarrow>int " and s::nat
  assumes d [rule_format]: "\<forall>n. d n> 1"
    and a [rule_format]: "\<forall>n. a n>0"  and " s>0"
    and 9: "\<forall>m \<ge>s. \<exists>n\<ge>m. a (n+1) powr(1 / of_int (2^(n+1))) \<ge>
          d (n+1) * (Max ((\<lambda>j. (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} ))"
  shows "\<forall>m\<ge>s. \<exists>n\<ge>m. d (n+1) powr(2^(n+1)) * (\<Prod>j=1..n. of_int( a j)) *
            (1 / (\<Prod>j=1..s-1. of_int( a j))) \<le> a (n+1)"
proof (intro strip)
  fix m assume "s \<le> m"
  from 9[rule_format,OF this]
  obtain n where "n\<ge>m" and asm_9:"( (of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
          (d (n+1))* (Max ( ( \<lambda> (j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
    by auto
  with \<open>s\<le>m\<close> have "s\<le>n" by auto

  define M where "M \<equiv> \<lambda>s. MAX j\<in>{s..n}. a j powr (1 / real_of_int (2 ^ j))"
  have prod: "(\<Prod>j=1..n. real_of_int (a j)) * (1 / (\<Prod>j=1..s-1. of_int(a j)))
            = (\<Prod>j=s..n. of_int( a j))"
  proof -
    define f where "f= (\<lambda>j. real_of_int( a j))"
    have "{Suc 0..n}= {Suc 0..s - Suc 0} \<union> {s..n}" using \<open>n\<ge>s\<close>  \<open>s >0\<close>
      by auto
    then have "(\<Prod>j=1..n. f j) = (\<Prod>j=1..s-1. f j) * (\<Prod>j=s..n. f j)"
      apply (subst prod.union_disjoint[symmetric])
      by auto
    moreover have "(\<Prod>j=1..s-1. f j) > 0 "
      by (metis a f_def of_int_0_less_iff prod_pos)
    then have "(\<Prod>j=1..s-1. f j) \<noteq> 0" by argo
    ultimately show ?thesis unfolding f_def by auto
  qed
  then have "d (n+1) powr 2 ^ (n+1) * (\<Prod>j = 1..n. of_int (a j)) * (1 / (\<Prod>j = 1..s - 1. of_int (a j))) =
             d (n+1) powr 2 ^ (n+1) * (\<Prod>j = s..n. of_int (a j))"
     by (metis mult.assoc prod)
  also have
    "... \<le> ((d (n+1))powr(2^(n+1) ) * (\<Prod>i=s..n. M s powr(2^i)) )"
  proof (rule mult_left_mono)
    show "0 \<le> (d (n + 1)) powr 2 ^ (n + 1)"
      by auto
    show "(\<Prod>j = s..n. real_of_int (a j)) \<le> (\<Prod>i = s..n. M s powr 2 ^ i)"
    proof (intro prod_mono conjI)
      fix i assume i: "i \<in> {s..n}"
      have "a i = (a i powr (1 / real_of_int (2 ^ i))) powr 2 ^ i"
        unfolding powr_powr by (simp add: a less_eq_real_def)
      also have  "\<dots> \<le> M s powr(2^i)"
        unfolding M_def using i by (force intro: powr_mono2)
      finally show "a i \<le> M s powr 2 ^ i" .
      show "\<And>i. i \<in> {s..n} \<Longrightarrow> 0 \<le> real_of_int (a i)"
        by (meson a less_imp_le of_int_0_le_iff)
    qed
  qed
  also have "... = d(n+1) powr (2^(n+1)) * M s powr (\<Sum>i=s..n. 2^i)"
  proof-
    have  "d (n+1) powr (2^(n+1)) \<ge> 1  "
      by (metis Transcendental.log_one d le_powr_iff zero_le_numeral zero_le_power zero_less_one)
    moreover have "(\<Prod>i=s..n. M s powr(2^i)) = M s powr (\<Sum>i=s..n. 2^i ) "
      using \<open>s\<le>n\<close> powrfinitesum by auto
    ultimately show ?thesis by auto
  qed
  also have "... \<le> d (n + 1) powr 2 ^ (n + 1) * M s powr(2^(n+1))"
  proof -
    have "sum (power 2) {s..n} < (2::real) ^ (n + 1)" using factt \<open>s\<le>n\<close> by auto
    moreover have "1 \<le> M s"
    proof -
      define S where "S=(\<lambda>(j::nat). ( of_int( a j) powr(1 /real_of_int (2^j)) )) ` {s..n  }"
      have "finite S" unfolding S_def by auto
      moreover have "S\<noteq>{}" unfolding S_def using \<open>s\<le>n\<close>  by auto
      moreover have "\<exists>x\<in>S. x\<ge>1"
      proof-
        have "a s powr (1 / (2^s)) \<ge> 1"
        proof (rule ge_one_powr_ge_zero)
          show "1 \<le> real_of_int (a s)"
            by (simp add: a int_one_le_iff_zero_less)
        qed auto
        moreover have "of_int( a s) powr(1 /real_of_int (2^s)) \<in> S"
          unfolding S_def
          using \<open>s\<le>n\<close> by auto
        ultimately show ?thesis by auto
      qed
      ultimately show ?thesis
        using Max_ge_iff[of S 1] unfolding S_def M_def by blast
    qed
    moreover have "0 \<le> (d (n + 1)) powr 2 ^ (n + 1)" by auto
    ultimately show ?thesis
      by (simp add: mult_left_mono powr_mono M_def)
  qed

  also have "... =  (d (n+1) * M s) powr(2^(n+1))"
  proof -
    have "d (n + 1) \<ge> 0" using d[of "n+1"] by argo
    moreover have "M s \<ge> 0"
      using \<open>s\<le>n\<close> by (auto simp: M_def Max_ge_iff)
    ultimately show ?thesis
      unfolding M_def using powr_mult by auto
  qed
  also have "... \<le> (real_of_int (a (n + 1)) powr (1 / real_of_int (2 ^ (n + 1)))) powr 2 ^ (n + 1)"
  proof (rule powr_mono2)
    have "M s \<ge> 0"
      using \<open>s\<le>n\<close> by (auto simp: M_def Max_ge_iff)
    moreover have "d (n + 1) \<ge>0"
      using d[of "n+1"] by argo
    ultimately show "0 \<le> (d (n + 1)) * M s" by auto
    show "(d (n + 1)) * M s \<le> real_of_int (a (n + 1)) powr (1 / real_of_int (2 ^ (n + 1)))"
      using M_def asm_9 by presburger
  qed simp
  also have "... =  (of_int (a (n+1)))"
    by (simp add: a less_eq_real_def pos_add_strict powr_powr)
  finally show "\<exists>n\<ge>m. d (n + 1) powr 2 ^ (n + 1) * (\<Prod>j = 1..n. real_of_int (a j)) *
                (1 / (\<Prod>j = 1..s - 1. real_of_int (a j)))
                \<le> real_of_int (a (n + 1))" using \<open>n\<ge>m\<close> \<open>m\<ge>s\<close>
    by force
qed

lemma lasttoshow:
  fixes d ::"nat\<Rightarrow>real " and a b ::"nat\<Rightarrow>int " and q::int and s::nat
  assumes d: "\<forall>n. d n> 1"
     and a:"\<forall>n. a n>0" and "s>0" and "q>0"
    and "A > 1" and b:"\<forall>n. b n>0" and 9:
    "\<forall>m\<ge>s. \<exists>n\<ge>m. ((of_int (a (n+1))) powr(1 /of_int (2^(n+1))) \<ge>
          (d (n+1))* (Max ((\<lambda>(j::nat). (of_int (a j)) powr(1 /of_int (2^j))) ` {s..n} )))"
    and assu3: "filterlim( \<lambda> n. (d n)^(2^n)/ b n) at_top sequentially "
    and 5: "\<forall>\<^sub>F n in sequentially. (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
  shows "\<exists>n. q*((\<Prod>j=1..n. real_of_int(a j))) * suminf (\<lambda>(j::nat). (b (j+n+1)/ a (j+n+1)))<1"
proof-
  define as where "as=(\<Prod>j = 1..s - 1. real_of_int (a j))"
  obtain n where "n\<ge>s" and n_def1:"real_of_int q * as * 2
      * real_of_int (b (n + 1)) / d (n + 1) powr 2 ^ (n + 1) < 1"
    and n_def2:"d (n + 1) powr 2 ^ (n + 1) * (\<Prod>j = 1..n. real_of_int (a j)) * (1 / as)
          \<le> real_of_int (a (n + 1))"
    and n_def3:"(\<Sum>j. (b (n+1 + j)) /  (a (n+1 + j))) \<le> 2 * b (n+1) / a (n+1)"
  proof -
    have *:"(\<lambda>n. real_of_int (b n) / d n ^ 2 ^ n) \<longlonglongrightarrow> 0"
      using tendsto_inverse_0_at_top[OF assu3] by auto
    then have "(\<lambda>n. real_of_int (b n) / d n powr 2 ^ n) \<longlonglongrightarrow> 0"
    proof -
      have "d n ^ 2 ^ n = d n powr (of_nat (2 ^ n))" for n
        by (metis d le_less_trans powr_realpow zero_le_one)
      then show ?thesis using * by auto
    qed
    from tendsto_mult_right_zero[OF this,of "q * as * 2"]
    have "(\<lambda>n. q * as * 2 * b n / d n powr 2 ^ n) \<longlonglongrightarrow> 0"
      by auto
    then have "\<forall>\<^sub>F n in sequentially. q * as * 2 * b n / d n powr 2 ^ n < 1"
      by (elim order_tendstoD) simp
    then have "\<forall>\<^sub>F n in sequentially. q * as * 2 * b n / d n powr 2 ^ n < 1
                  \<and> (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
      using 5 by eventually_elim auto
    then obtain N where N_def:"\<forall>n\<ge>N. q * as * 2 * b n / d n powr 2 ^ n < 1
            \<and> (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
      unfolding eventually_sequentially by auto
    obtain n where "n\<ge>s" and "n\<ge>N" and n_def:"d (n + 1) powr 2 ^ (n + 1)
                * (\<Prod>j = 1..n. of_int (a j)) * (1 / as) \<le> real_of_int (a (n + 1))"
      using show10[OF d a \<open>s>0\<close> 9,folded as_def,rule_format,of "max s N"] by auto
    with N_def[rule_format, of "n+1"] that[of n]  show ?thesis by auto
  qed

  define pa where "pa \<equiv> (\<Prod>j = 1..n. real_of_int (a j))"
  define dn where "dn \<equiv> d (n + 1) powr 2 ^ (n + 1)"
  have [simp]:"dn >0" "as > 0"
    subgoal unfolding dn_def by (metis d not_le numeral_One powr_gt_zero zero_le_numeral)
    subgoal unfolding as_def by (simp add: a prod_pos)
    done
  have [simp]:"pa>0"
    unfolding pa_def using a by (simp add: prod_pos)

  have K: "q* (\<Prod>j=1..n. real_of_int (a j)) * suminf (\<lambda> (j::nat). (b (j+n+1)/ a (j+n+1)))
              \<le>q* (\<Prod>j=1..n. real_of_int (a j)) *2* (b (n+1))/(a( n+1))"
    apply (fold pa_def)
    using mult_left_mono[OF n_def3,of "real_of_int q * pa"]
      \<open>n\<ge>s\<close> \<open>pa>0\<close> \<open>q>0\<close> by (auto simp add:algebra_simps)
  also have KK:"... \<le> 2*q* (\<Prod>j=1..n. real_of_int (a j)) * (b(n+1))*
      ((\<Prod>j=1..s-1. real_of_int( a j))/((d (n+1))powr(2^(n+1)) * (\<Prod>j=1..n. real_of_int ( a j))))"
  proof -
    have " dn * pa * (1 / as) \<le> real_of_int (a (n + 1))"
      using n_def2 unfolding dn_def pa_def .
    then show ?thesis
      apply (fold pa_def dn_def as_def)
      using \<open>pa>0\<close> \<open>q>0\<close> a[rule_format, of "Suc n"] b[rule_format, of "Suc n"]
      by (auto simp add: field_simps)
  qed
  also have KKK: "... = q * (\<Prod>j=1..(s-1). real_of_int(a j)) * 2 * b (n+1) / d (n+1) powr 2^(n+1)"
    apply (fold as_def pa_def dn_def)
    apply simp
    using \<open>0 < pa\<close> by blast
  also have KKKK: "... < 1" using n_def1 unfolding as_def by simp
  finally show ?thesis by auto
qed

lemma
  fixes d ::"nat\<Rightarrow>real " and  a b ::"nat\<Rightarrow>int " and A::real
  assumes "A > 1" and d: "\<forall>n. d n> 1" and a: "\<forall>n. a n>0" and b:"\<forall>n. b n>0"
    and assu1: "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (2^n)))\<longlongrightarrow> A) sequentially "
    and assu3: "filterlim ( \<lambda> n. (d n)^(2^n)/ b n) at_top sequentially"
    and "convergent_prod d"
  shows issummable: "summable (\<lambda>j. b j / a j)"
    and show5: "\<forall>\<^sub>F n in sequentially. (\<Sum>j. (b (n + j)) / (a (n + j))) \<le> 2 * b n / a n"
proof-
  define c where "c = (\<lambda>j. b j / a j)"
  have c_pos:"c j>0" for j
    using a b unfolding c_def by simp
  have c_ratio_tendsto:"(\<lambda>n. c (n+1) / c n ) \<longlonglongrightarrow> 0"
  proof -
    define nn where "nn \<equiv> (\<lambda>n. (2::int) ^ (Suc n))"
    define ff where "ff \<equiv> (\<lambda>n. (a n / a (Suc n)) powr(1 /nn n)*(d(Suc n)))"
    have nn_pos:"nn n>0" and ff_pos:"ff n>0" for n
      subgoal unfolding nn_def by simp
      subgoal unfolding ff_def
        using d[rule_format, of "Suc n"] a[rule_format, of n] a[rule_format, of "Suc n"]
        by auto
      done
    have ff_tendsto:"ff \<longlonglongrightarrow> 1 / sqrt A"
    proof -
      have "(of_int (a n)) powr(1 / (nn n)) = sqrt(of_int (a n) powr(1 /of_int (2^n)))" for n
        unfolding nn_def using a
        by (simp add: powr_half_sqrt [symmetric] powr_powr ac_simps)
      moreover have "(( \<lambda> n. sqrt(of_int (a n) powr(1 /of_int (2^n))))\<longlongrightarrow> sqrt A) sequentially "
        using assu1 tendsto_real_sqrt by blast
      ultimately have "(( \<lambda> n. (of_int (a n)) powr(1 /of_int (nn n)))\<longlongrightarrow> sqrt A) sequentially "
        by auto
      from tendsto_divide[OF this assu1[THEN LIMSEQ_ignore_initial_segment[where k=1]]]
      have "(\<lambda>n. (a n / a (Suc n)) powr(1 /nn n)) \<longlonglongrightarrow> 1/sqrt A"
        using \<open>A>1\<close> a unfolding nn_def
        by (auto simp add:powr_divide less_imp_le inverse_eq_divide sqrt_divide_self_eq)
      moreover have "(\<lambda>n. d (Suc n))\<longlonglongrightarrow> 1"
        apply (rule convergent_prod_imp_LIMSEQ)
        using convergent_prod_iff_shift[of d 1] \<open>convergent_prod d\<close> by auto
      ultimately show ?thesis
        unfolding ff_def by (auto intro:tendsto_eq_intros)
    qed
    have "(\<lambda>n. (ff n) powr nn n) \<longlonglongrightarrow> 0"
    proof -
      define aa where "aa=(1+1/sqrt A) / 2"
      have "eventually (\<lambda>n. ff n<aa) sequentially"
        apply (rule order_tendstoD[OF ff_tendsto])
        unfolding aa_def using \<open>A>1\<close> by (auto simp add:field_simps)
      moreover have "(\<lambda>n. aa powr nn n) \<longlonglongrightarrow> 0"
      proof -
        have "(\<lambda>y. aa ^ (nat \<circ> nn) y) \<longlonglongrightarrow> 0"
          apply (rule tendsto_power_zero)
          subgoal unfolding nn_def comp_def
            apply (rule filterlim_subseq)
            by (auto intro:strict_monoI)
          subgoal unfolding aa_def using \<open>A>1\<close> by auto
          done
        then show ?thesis
        proof (elim filterlim_mono_eventually)
          have "aa>0" unfolding aa_def using \<open>A>1\<close>
            by  (auto simp add:field_simps pos_add_strict)
          then show " \<forall>\<^sub>F x in sequentially. aa ^ (nat \<circ> nn) x = aa powr real_of_int (nn x)"
            by (auto simp: powr_int order.strict_implies_order[OF nn_pos])
        qed auto
      qed
      ultimately show ?thesis
        apply (elim metric_tendsto_imp_tendsto)
        apply (auto intro!:powr_mono2 elim!:eventually_mono)
        using nn_pos ff_pos by (meson le_cases not_le)+
    qed
    then have "(\<lambda>n. (d (Suc n))^(nat (nn n)) * (a n / a (Suc n))) \<longlonglongrightarrow> 0"
    proof (elim filterlim_mono_eventually)
      show "\<forall>\<^sub>F x in sequentially. ff x powr  (nn x) = d (Suc x) ^ nat (nn x) * (a x / a (Suc x))"
        apply (rule eventuallyI)
        subgoal for x
          unfolding ff_def
          using a[rule_format,of x] a[rule_format,of "Suc x"] d[rule_format,of "Suc x"] nn_pos[of x]
          apply (auto simp add:field_simps powr_divide powr_powr powr_mult )
          by (simp add: powr_int)
        done
    qed auto
    moreover have "(\<lambda>n. b (Suc n) / (d (Suc n))^(nat (nn n))) \<longlonglongrightarrow> 0"
      using tendsto_inverse_0_at_top[OF assu3,THEN LIMSEQ_ignore_initial_segment[where k=1]]
      unfolding nn_def by (auto simp add:field_simps nat_mult_distrib nat_power_eq)
    ultimately have "(\<lambda>n. b (Suc n) * (a n / a (Suc n))) \<longlonglongrightarrow> 0"
      apply -
      subgoal premises asm
        using tendsto_mult[OF asm,simplified]
        apply (elim filterlim_mono_eventually)
        using d by (auto simp add:algebra_simps,metis (mono_tags, lifting) always_eventually
            not_one_less_zero)
      done
    then have "(\<lambda>n. (b (Suc n) / b n) * (a n / a (Suc n))) \<longlonglongrightarrow> 0"
      apply (elim Lim_transform_bound[rotated])
      apply (rule eventuallyI)
      subgoal for x using a[rule_format, of x] a[rule_format, of "Suc x"]
          b[rule_format, of x] b[rule_format, of "Suc x"]
        by (auto simp add:field_simps)
      done
    then show ?thesis unfolding c_def by (auto simp add:algebra_simps)
  qed
  from c_ratio_tendsto
  have "(\<lambda>n. norm (b (Suc n) / a (Suc n)) / norm (b n / a n)) \<longlonglongrightarrow> 0"
    unfolding c_def
    using a b by (force simp add:divide_simps abs_of_pos intro: Lim_transform_eventually)
  from summable_ratio_test_tendsto[OF _ _ this] a b
  show "summable c" unfolding c_def
    by (metis c_def c_pos less_irrefl zero_less_one)
  have "\<forall>\<^sub>F n in sequentially. (\<Sum>j. c (n + j)) \<le> 2 * c n"
  proof -
    obtain N where N_ratio:"\<forall>n\<ge>N. c (n + 1) / c n < 1 / 2"
    proof -
      have "eventually (\<lambda>n. c (n+1) / c n < 1/2) sequentially"
        using c_ratio_tendsto[unfolded tendsto_iff,rule_format, of "1/2",simplified]
        apply eventually_elim
        subgoal for n using c_pos[of n] c_pos[of "Suc n"] by auto
        done
      then show ?thesis using that unfolding eventually_sequentially by auto
    qed
    have "(\<Sum>j. c (j + n)) \<le> 2 * c n" when "n\<ge>N" for n
    proof -
      have "(\<Sum>j<m. c (j + n)) \<le> 2*c n * (1 - 1 / 2^(m+1))" for m
      proof (induct m)
        case 0
        then show ?case using c_pos[of n] by simp
      next
        case (Suc m)
        have "(\<Sum>j<Suc m. c (j + n)) = c n + (\<Sum>i<m. c (Suc i + n)) "
          unfolding sum.lessThan_Suc_shift by simp
        also have "... \<le> c n + (\<Sum>i<m. c (i + n) / 2)"
        proof -
          have "c (Suc i + n) \<le> c (i + n) / 2" for i
            using N_ratio[rule_format,of "i+n"] \<open>n\<ge>N\<close> c_pos[of "i+n"]  by simp
          then show ?thesis by (auto intro:sum_mono)
        qed
        also have "... = c n + (\<Sum>i<m. c (i + n)) / 2"
          unfolding sum_divide_distrib by simp
        also have "... \<le> c n + c n * (1 - 1 / 2 ^ (m + 1))"
          using Suc by auto
        also have "... = 2 * c n * (1 - 1 / 2 ^ (Suc m + 1))"
          by (auto simp add:field_simps)
        finally show ?case .
      qed
      then have "(\<Sum>j<m. c (j + n)) \<le> 2*c n" for m
        using c_pos[of n]
        by (smt divide_le_eq_1_pos divide_pos_pos nonzero_mult_div_cancel_left zero_less_power)
      moreover have "summable (\<lambda>j. c (j + n))"
        using \<open>summable c\<close> by (simp add: summable_iff_shift)
      ultimately show ?thesis using suminf_le_const[of "\<lambda>j. c (j+n)" "2*c n"] by auto
    qed
    then show ?thesis unfolding eventually_sequentially by (auto simp add:algebra_simps)
  qed
  then show "\<forall>\<^sub>F n in sequentially. (\<Sum>j. (b (n + j)) /  (a (n + j))) \<le> 2 * b n / a n"
    unfolding c_def by simp
qed

  define ALPHA where
    "ALPHA = (\<lambda>n. of_int q * (\<Prod>j=1..n. of_int(a j)) * (\<Sum>j. (b (j+n+1)/a (j+n+1))))"
  have "ALPHA n \<ge> 1" for n
  proof -
    have "(\<Sum>n. b (n+1) / a (n+1)) > 0"
    proof (rule suminf_pos)
      show "summable (\<lambda>n. b (n + 1) / real_of_int (a (n + 1)))"
        using summable_ignore_initial_segment[OF ab_sum,of 1] by auto
      show "\<And>n. 0 < b (n + 1) / a (n + 1)"
        using a b by simp
    qed
    then have "p/q > 0"
      using pq_def sums_unique by force
    then have "q\<ge>1" "p\<ge>1" using \<open>q>0\<close> by (auto simp add:divide_simps)
    moreover have "\<forall>n. 1 \<le> a n" "\<forall>n. 1 \<le> b n" using a b
      by (auto simp add: int_one_le_iff_zero_less)
    ultimately show ?thesis unfolding ALPHA_def
      using show7[OF _ _ _ _ pq_def] by auto
  qed
  moreover have "\<exists>n. ALPHA n < 1" unfolding ALPHA_def
  proof (rule lasttoshow[OF d a \<open>s>0\<close> \<open>q>0\<close> \<open>A>1\<close> b _ assu3])
    show "\<forall>\<^sub>F n in sequentially. (\<Sum>j. b (n+j) / a (n+j)) \<le> (2 * b n) / a n"
      using show5[OF \<open>A>1\<close> d a b assu1 assu3 \<open>convergent_prod d\<close>] by simp
    show "\<forall>m\<ge>s. \<exists>n\<ge>m. d (n+1) * (MAX j\<in>{s..n}. a j powr (1 / of_int (2 ^ j)))
                    \<le> a (n+1) powr (1 / of_int (2 ^ (n+1)))"
      apply (rule show9[OF \<open>A>1\<close> d a \<open>s>0\<close> assu1 \<open>convergent_prod d\<close>])
      using show8[OF \<open>A>1\<close> d a \<open>s>0\<close> \<open>convergent_prod d\<close> assu2] by (simp add:algebra_simps)
  qed
  ultimately show False using not_le by blast
qed

corollary Hancl3corollary:
  fixes A::real and  a b :: "nat\<Rightarrow>int"
  assumes "A > 1" and a: "\<forall>n. a n>0" and b: "\<forall>n. b n>0"
    and assu1: "(\<lambda>n. (a n) powr(1 / of_int(2^n))) \<longlonglongrightarrow> A"
    and asscor2: "\<forall>n \<ge> 6. a n powr(1 / of_int (2^n)) * (1 + 4*(2/3)^n) \<le> A
                        \<and> b n \<le> 2 powr (4/3)^(n-1)"
  shows "(\<Sum>n. b n / a n) \<notin> \<rat>"
proof-
  define d::"nat\<Rightarrow>real" where "d= (\<lambda> n. 1+(2/3)^(n+1))"
  have dgt1:"\<forall>n. 1 < d n " unfolding d_def by auto
  moreover have "convergent_prod d"
    unfolding d_def
    by (simp add: abs_convergent_prod_imp_convergent_prod summable_imp_abs_convergent_prod)
  moreover have "\<forall>n\<ge>6. (\<Prod>j. d (n+j)) < A / a n powr (1 / of_int (2 ^ n))"
  proof (intro strip)
    fix n::nat assume "6 \<le> n"
    have d_sum:"summable (\<lambda>j. ln (d j))" unfolding d_def
      by (auto intro: summable_ln_plus)

    have "(\<Sum>j. ln (d (n + j))) < ln (1+4 * (2/3) ^ n)"
    proof -
      define c::real where "c = (2/3) ^ n"
      have "0<c" "c<1/8"
      proof -
        have "c = (2/3)^6 * (2/3) ^ (n-6)"
          unfolding c_def using \<open>n\<ge>6\<close>
          by (metis le_add_diff_inverse power_add)
        also have "... \<le> (2/3)^6" by (auto intro:power_le_one)
        also have "... < 1/8" by (auto simp add:field_simps)
        finally show "c < 1/8" .
      qed (simp add:c_def)

      have "(\<Sum>j. ln (d (n + j))) \<le> (\<Sum>j. (2/3) ^ (n + j + 1))"
      proof (rule suminf_le)
        show "\<And>j. ln (d (n + j)) \<le> (2/3) ^ (n + j + 1)"
          unfolding d_def
          by (metis divide_pos_pos less_eq_real_def ln_add_one_self_le_self zero_less_numeral zero_less_power)
        show "summable (\<lambda>j. ln (d (n + j)))"
          using summable_ignore_initial_segment[OF d_sum]
          by (force simp add: algebra_simps)
        show "summable (\<lambda>j. (2 / 3::real) ^ (n + j + 1))"
          using summable_geometric[THEN summable_ignore_initial_segment,of "2/3" "n+1"]
          by (auto simp add:algebra_simps)
      qed
      also have "... = (\<Sum>j. (2/3)^(n+1)*(2/3) ^ j)"
        by (auto simp add:algebra_simps power_add)
      also have "... = (2/3)^(n+1) * (\<Sum>j. (2/3) ^ j)"
        by (force intro!: summable_geometric suminf_mult)
      also have "... = 2 * c"
        unfolding c_def
        by (simp add: suminf_geometric)
      also have "... <  4 * c - (4 * c)\<^sup>2"
        using \<open>0<c\<close> \<open>c<1/8\<close>
        by (sos "((((A<0 * A<1) * R<1) + ((A<=0 * R<1) * (R<1/16 * [1]^2))))")
      also have "... \<le> ln (1 + 4 * c)"
        apply (rule ln_one_plus_pos_lower_bound)
        using \<open>0<c\<close> \<open>c<1/8\<close> by auto
      finally show ?thesis unfolding c_def by simp
    qed
    then have "exp (\<Sum>j. ln (d (n + j))) < 1 + 4 * (2/3) ^ n"
      by (smt (z3) divide_pos_pos ln_exp ln_ge_iff zero_less_power)
    moreover have "exp (\<Sum>j. ln (d (n + j))) = (\<Prod>j. d (n + j))"
    proof (subst exp_suminf_prodinf_real [symmetric])
      show "\<And>k. 0 \<le> ln (d (n + k))"
        using dgt1 by (simp add: less_imp_le)
      show "abs_convergent_prod (\<lambda>na. exp (ln (d (n + na))))"
      proof (subst exp_ln)
        show "\<And>j. 0 < d (n + j)"
          using dgt1 le_less_trans zero_le_one by blast
        show "abs_convergent_prod (\<lambda>j. d (n + j))"
          unfolding abs_convergent_prod_def
          using \<open>convergent_prod d\<close>
          by (simp add: dgt1 convergent_prod_iff_shift less_imp_le algebra_simps)
      qed
      show "(\<Prod>j. exp (ln (d (n + j)))) = (\<Prod>j. d (n + j))"
        by (meson dgt1 exp_ln not_less not_one_less_zero order_trans)
    qed
    ultimately have "(\<Prod>j. d (n + j))  < 1 + 4 * (2/3) ^ n"
      by simp
    also have "... \<le> A / (a n) powr (1 / of_int (2 ^ n))"
    proof -
      have "a n powr (1 / real_of_int (2 ^ n)) > 0"
        using a[rule_format,of n] by auto
      then show ?thesis using asscor2[rule_format,OF \<open>6\<le>n\<close>]
        by (auto simp add:field_simps)
    qed
    finally show "(\<Prod>j. d (n + j)) < A / real_of_int (a n) powr (1 / of_int (2 ^ n))" .
  qed
  moreover have "LIM n sequentially. d n ^ 2 ^ n / real_of_int (b n) :> at_top"
  proof -
    have "LIM n sequentially. d n ^ 2 ^ n / 2 powr((4/3)^(n-1)) :> at_top"
    proof -
      define n1 where "n1 \<equiv> (\<lambda>n. (2::real) * (3/2)^(n-1))"
      define n2 where "n2 \<equiv> (\<lambda>n. ((4::real)/3)^(n-1))"
      have "LIM n sequentially. (((1+(8/9)/(n1 n)) powr (n1 n))/2) powr (n2 n) :> at_top"
      proof (rule filterlim_at_top_powr_real[where g'="exp (8/9) / 2"])
        define e1 where "e1 = exp (8/9) / (2::real)"
        show "e1>1" unfolding e1_def by (approximation 4)
        show "(\<lambda>n. ((1+(8/9)/(n1 n)) powr (n1 n))/2) \<longlonglongrightarrow> e1"
        proof -
          have "(\<lambda>n. (1+(8/9)/(n1 n)) powr (n1 n)) \<longlonglongrightarrow> exp (8/9)"
            apply (rule filterlim_compose[OF tendsto_exp_limit_at_top])
            unfolding n1_def
            by (auto intro!: filterlim_tendsto_pos_mult_at_top
                filterlim_realpow_sequentially_at_top
                simp:filterlim_sequentially_iff[of "\<lambda>x. (3 / 2) ^ (x - Suc 0)" _ 1])
          then show ?thesis unfolding e1_def
            by (intro tendsto_intros,auto)
        qed
        show "filterlim n2 at_top sequentially"
          unfolding n2_def
          apply (subst filterlim_sequentially_iff[of "\<lambda>n. (4 / 3) ^ (n - 1)" _ 1])
          by (auto intro:filterlim_realpow_sequentially_at_top)
      qed
      moreover have "\<forall>\<^sub>F n in sequentially. (((1+(8/9)/(n1 n)) powr (n1 n))/2) powr (n2 n)
        = d n ^ 2 ^ n / 2 powr((4/3)^(n-1))"
      proof (rule eventually_sequentiallyI)
        fix k::nat assume "k \<ge> 1"
        have "((1 + 8 / 9 / n1 k) powr n1 k / 2) powr n2 k
            = (((1 + 8 / 9 / n1 k) powr n1 k) powr n2 k) / 2 powr (4 / 3) ^ (k - 1)"
          by (simp add: n1_def n2_def powr_divide)
        also have "... = (1 + 8 / 9 / n1 k) powr (n1 k * n2 k) / 2 powr (4 / 3) ^ (k - 1)"
          by (simp add: powr_powr)
        also have "... = (1 + 8 / 9 / n1 k) powr (2 ^ k) / 2 powr (4 / 3) ^ (k - 1)"
        proof -
          have "n1 k * n2 k = 2 ^ k"
            unfolding n1_def n2_def
            using \<open>k\<ge>1\<close> by (simp add: mult_ac flip:power_mult_distrib power_Suc)
          then show ?thesis by simp
        qed
        also have "... = (1 + 8 / 9 / n1 k) ^ (2 ^ k) / 2 powr (4 / 3) ^ (k - 1)"
          unfolding n1_def
          by (smt (verit, best) powr_realpow divide_pos_pos numeral_plus_numeral numeral_plus_one of_nat_numeral of_nat_power semiring_norm(2) zero_less_power)
        also have "... = d k ^ 2 ^ k / 2 powr (4 / 3) ^ (k - 1)"
        proof -
          have **: "8 / 9 / n1 k = (2/3) ^ (k+1)"
            unfolding n1_def using \<open>k\<ge>1\<close>
            by (simp add: divide_simps split: nat_diff_split)
          then show ?thesis
            unfolding d_def by presburger
        qed
        finally show "((1 + 8 / 9 / n1 k) powr n1 k / 2) powr n2 k
                    = d k ^ 2 ^ k / 2 powr (4 / 3) ^ (k - 1)" .
      qed
      ultimately show ?thesis using filterlim_cong by fast
    qed
    moreover have "\<forall>\<^sub>F n in sequentially. d n ^ 2 ^ n / 2 powr((4/3)^(n-1))
        \<le> d n ^ 2 ^ n / real_of_int (b n)"
      using eventually_sequentiallyI[of 6]
      by (smt (verit, best) asscor2 b dgt1 frac_le of_int_0_less_iff zero_le_power)
    ultimately show ?thesis by (auto elim: filterlim_at_top_mono)
  qed
  ultimately show ?thesis using Hancl3[OF \<open>A>1\<close> _ a b _ assu1,of d 6] by force
qed

end


(*  Title:      HOL/Decision_Procs/Commutative_Ring.thy
    Author:     Bernhard Haeupler, Stefan Berghofer, and Amine Chaieb

Proving equalities in commutative rings done "right" in Isabelle/HOL.
*)

section \<open>Proving equalities in commutative rings\<close>

theory Commutative_Ring
  imports
    Conversions
    Algebra_Aux
    "HOL-Library.Code_Target_Numeral"
begin

text \<open>Syntax of multivariate polynomials (pol) and polynomial expressions.\<close>

datatype pol =
    Pc int
  | Pinj nat pol
  | PX pol nat pol

datatype polex =
    Var nat
  | Const int
  | Add polex polex
  | Sub polex polex
  | Mul polex polex
  | Pow polex nat
  | Neg polex

text \<open>Interpretation functions for the shadow syntax.\<close>

context cring
begin

definition in_carrier :: "'a list \<Rightarrow> bool"
  where "in_carrier xs \<longleftrightarrow> (\<forall>x\<in>set xs. x \<in> carrier R)"

lemma in_carrier_Nil: "in_carrier []"
  by (simp add: in_carrier_def)

lemma in_carrier_Cons: "x \<in> carrier R \<Longrightarrow> in_carrier xs \<Longrightarrow> in_carrier (x # xs)"
  by (simp add: in_carrier_def)

lemma drop_in_carrier [simp]: "in_carrier xs \<Longrightarrow> in_carrier (drop n xs)"
  using set_drop_subset [of n xs] by (auto simp add: in_carrier_def)

primrec head :: "'a list \<Rightarrow> 'a"
  where
    "head [] = \<zero>"
  | "head (x # xs) = x"

lemma head_closed [simp]: "in_carrier xs \<Longrightarrow> head xs \<in> carrier R"
  by (cases xs) (simp_all add: in_carrier_def)

primrec Ipol :: "'a list \<Rightarrow> pol \<Rightarrow> 'a"
  where
    "Ipol l (Pc c) = \<guillemotleft>c\<guillemotright>"
  | "Ipol l (Pinj i P) = Ipol (drop i l) P"
  | "Ipol l (PX P x Q) = Ipol l P \<otimes> head l [^] x \<oplus> Ipol (drop 1 l) Q"

lemma Ipol_Pc:
  "Ipol l (Pc 0) = \<zero>"
  "Ipol l (Pc 1) = \<one>"
  "Ipol l (Pc (numeral n)) = \<guillemotleft>numeral n\<guillemotright>"
  "Ipol l (Pc (- numeral n)) = \<ominus> \<guillemotleft>numeral n\<guillemotright>"
  by simp_all

lemma Ipol_closed [simp]: "in_carrier l \<Longrightarrow> Ipol l p \<in> carrier R"
  by (induct p arbitrary: l) simp_all

primrec Ipolex :: "'a list \<Rightarrow> polex \<Rightarrow> 'a"
  where
    "Ipolex l (Var n) = head (drop n l)"
  | "Ipolex l (Const i) = \<guillemotleft>i\<guillemotright>"
  | "Ipolex l (Add P Q) = Ipolex l P \<oplus> Ipolex l Q"
  | "Ipolex l (Sub P Q) = Ipolex l P \<ominus> Ipolex l Q"
  | "Ipolex l (Mul P Q) = Ipolex l P \<otimes> Ipolex l Q"
  | "Ipolex l (Pow p n) = Ipolex l p [^] n"
  | "Ipolex l (Neg P) = \<ominus> Ipolex l P"

lemma Ipolex_Const:
  "Ipolex l (Const 0) = \<zero>"
  "Ipolex l (Const 1) = \<one>"
  "Ipolex l (Const (numeral n)) = \<guillemotleft>numeral n\<guillemotright>"
  by simp_all

end

text \<open>Create polynomial normalized polynomials given normalized inputs.\<close>

definition mkPinj :: "nat \<Rightarrow> pol \<Rightarrow> pol"
  where "mkPinj x P =
    (case P of
      Pc c \<Rightarrow> Pc c
    | Pinj y P \<Rightarrow> Pinj (x + y) P
    | PX p1 y p2 \<Rightarrow> Pinj x P)"

definition mkPX :: "pol \<Rightarrow> nat \<Rightarrow> pol \<Rightarrow> pol"
  where "mkPX P i Q =
    (case P of
      Pc c \<Rightarrow> if c = 0 then mkPinj 1 Q else PX P i Q
    | Pinj j R \<Rightarrow> PX P i Q
    | PX P2 i2 Q2 \<Rightarrow> if Q2 = Pc 0 then PX P2 (i + i2) Q else PX P i Q)"

text \<open>Defining the basic ring operations on normalized polynomials\<close>

function add :: "pol \<Rightarrow> pol \<Rightarrow> pol"  (infixl "\<langle>+\<rangle>" 65)
  where
    "Pc a \<langle>+\<rangle> Pc b = Pc (a + b)"
  | "Pc c \<langle>+\<rangle> Pinj i P = Pinj i (P \<langle>+\<rangle> Pc c)"
  | "Pinj i P \<langle>+\<rangle> Pc c = Pinj i (P \<langle>+\<rangle> Pc c)"
  | "Pc c \<langle>+\<rangle> PX P i Q = PX P i (Q \<langle>+\<rangle> Pc c)"
  | "PX P i Q \<langle>+\<rangle> Pc c = PX P i (Q \<langle>+\<rangle> Pc c)"
  | "Pinj x P \<langle>+\<rangle> Pinj y Q =
      (if x = y then mkPinj x (P \<langle>+\<rangle> Q)
       else (if x > y then mkPinj y (Pinj (x - y) P \<langle>+\<rangle> Q)
         else mkPinj x (Pinj (y - x) Q \<langle>+\<rangle> P)))"
  | "Pinj x P \<langle>+\<rangle> PX Q y R =
      (if x = 0 then P \<langle>+\<rangle> PX Q y R
       else (if x = 1 then PX Q y (R \<langle>+\<rangle> P)
         else PX Q y (R \<langle>+\<rangle> Pinj (x - 1) P)))"
  | "PX P x R \<langle>+\<rangle> Pinj y Q =
      (if y = 0 then PX P x R \<langle>+\<rangle> Q
       else (if y = 1 then PX P x (R \<langle>+\<rangle> Q)
         else PX P x (R \<langle>+\<rangle> Pinj (y - 1) Q)))"
  | "PX P1 x P2 \<langle>+\<rangle> PX Q1 y Q2 =
      (if x = y then mkPX (P1 \<langle>+\<rangle> Q1) x (P2 \<langle>+\<rangle> Q2)
       else (if x > y then mkPX (PX P1 (x - y) (Pc 0) \<langle>+\<rangle> Q1) y (P2 \<langle>+\<rangle> Q2)
         else mkPX (PX Q1 (y - x) (Pc 0) \<langle>+\<rangle> P1) x (P2 \<langle>+\<rangle> Q2)))"
  by pat_completeness auto
termination by (relation "measure (\<lambda>(x, y). size x + size y)") auto

function mul :: "pol \<Rightarrow> pol \<Rightarrow> pol"  (infixl "\<langle>*\<rangle>" 70)
  where
    "Pc a \<langle>*\<rangle> Pc b = Pc (a * b)"
  | "Pc c \<langle>*\<rangle> Pinj i P =
      (if c = 0 then Pc 0 else mkPinj i (P \<langle>*\<rangle> Pc c))"
  | "Pinj i P \<langle>*\<rangle> Pc c =
      (if c = 0 then Pc 0 else mkPinj i (P \<langle>*\<rangle> Pc c))"
  | "Pc c \<langle>*\<rangle> PX P i Q =
      (if c = 0 then Pc 0 else mkPX (P \<langle>*\<rangle> Pc c) i (Q \<langle>*\<rangle> Pc c))"
  | "PX P i Q \<langle>*\<rangle> Pc c =
      (if c = 0 then Pc 0 else mkPX (P \<langle>*\<rangle> Pc c) i (Q \<langle>*\<rangle> Pc c))"
  | "Pinj x P \<langle>*\<rangle> Pinj y Q =
      (if x = y then mkPinj x (P \<langle>*\<rangle> Q)
       else
         (if x > y then mkPinj y (Pinj (x - y) P \<langle>*\<rangle> Q)
          else mkPinj x (Pinj (y - x) Q \<langle>*\<rangle> P)))"
  | "Pinj x P \<langle>*\<rangle> PX Q y R =
      (if x = 0 then P \<langle>*\<rangle> PX Q y R
       else
         (if x = 1 then mkPX (Pinj x P \<langle>*\<rangle> Q) y (R \<langle>*\<rangle> P)
          else mkPX (Pinj x P \<langle>*\<rangle> Q) y (R \<langle>*\<rangle> Pinj (x - 1) P)))"
  | "PX P x R \<langle>*\<rangle> Pinj y Q =
      (if y = 0 then PX P x R \<langle>*\<rangle> Q
       else
         (if y = 1 then mkPX (Pinj y Q \<langle>*\<rangle> P) x (R \<langle>*\<rangle> Q)
          else mkPX (Pinj y Q \<langle>*\<rangle> P) x (R \<langle>*\<rangle> Pinj (y - 1) Q)))"
  | "PX P1 x P2 \<langle>*\<rangle> PX Q1 y Q2 =
      mkPX (P1 \<langle>*\<rangle> Q1) (x + y) (P2 \<langle>*\<rangle> Q2) \<langle>+\<rangle>
        (mkPX (P1 \<langle>*\<rangle> mkPinj 1 Q2) x (Pc 0) \<langle>+\<rangle>
          (mkPX (Q1 \<langle>*\<rangle> mkPinj 1 P2) y (Pc 0)))"
  by pat_completeness auto
termination by (relation "measure (\<lambda>(x, y). size x + size y)")
  (auto simp add: mkPinj_def split: pol.split)

text \<open>Negation\<close>
primrec neg :: "pol \<Rightarrow> pol"
  where
    "neg (Pc c) = Pc (- c)"
  | "neg (Pinj i P) = Pinj i (neg P)"
  | "neg (PX P x Q) = PX (neg P) x (neg Q)"

text \<open>Subtraction\<close>
definition sub :: "pol \<Rightarrow> pol \<Rightarrow> pol"  (infixl "\<langle>-\<rangle>" 65)
  where "sub P Q = P \<langle>+\<rangle> neg Q"

text \<open>Square for Fast Exponentiation\<close>
primrec sqr :: "pol \<Rightarrow> pol"
  where
    "sqr (Pc c) = Pc (c * c)"
  | "sqr (Pinj i P) = mkPinj i (sqr P)"
  | "sqr (PX A x B) = mkPX (sqr A) (x + x) (sqr B) \<langle>+\<rangle> mkPX (Pc 2 \<langle>*\<rangle> A \<langle>*\<rangle> mkPinj 1 B) x (Pc 0)"

text \<open>Fast Exponentiation\<close>

fun pow :: "nat \<Rightarrow> pol \<Rightarrow> pol"
  where pow_if [simp del]: "pow n P =
   (if n = 0 then Pc 1
    else if even n then pow (n div 2) (sqr P)
    else P \<langle>*\<rangle> pow (n div 2) (sqr P))"

lemma pow_simps [simp]:
  "pow 0 P = Pc 1"
  "pow (2 * n) P = pow n (sqr P)"
  "pow (Suc (2 * n)) P = P \<langle>*\<rangle> pow n (sqr P)"
  by (simp_all add: pow_if)

lemma even_pow: "even n \<Longrightarrow> pow n P = pow (n div 2) (sqr P)"
  by (erule evenE) simp

lemma odd_pow: "odd n \<Longrightarrow> pow n P = P \<langle>*\<rangle> pow (n div 2) (sqr P)"
  by (erule oddE) simp

text \<open>Normalization of polynomial expressions\<close>

primrec norm :: "polex \<Rightarrow> pol"
  where
    "norm (Var n) =
       (if n = 0 then PX (Pc 1) 1 (Pc 0)
        else Pinj n (PX (Pc 1) 1 (Pc 0)))"
  | "norm (Const i) = Pc i"
  | "norm (Add P Q) = norm P \<langle>+\<rangle> norm Q"
  | "norm (Sub P Q) = norm P \<langle>-\<rangle> norm Q"
  | "norm (Mul P Q) = norm P \<langle>*\<rangle> norm Q"
  | "norm (Pow P n) = pow n (norm P)"
  | "norm (Neg P) = neg (norm P)"

context cring
begin

text \<open>mkPinj preserve semantics\<close>
lemma mkPinj_ci: "Ipol l (mkPinj a B) = Ipol l (Pinj a B)"
  by (induct B) (auto simp add: mkPinj_def algebra_simps)

text \<open>mkPX preserves semantics\<close>
lemma mkPX_ci: "in_carrier l \<Longrightarrow> Ipol l (mkPX A b C) = Ipol l (PX A b C)"
  by (cases A) (auto simp add: mkPX_def mkPinj_ci nat_pow_mult [symmetric] m_ac)

text \<open>Correctness theorems for the implemented operations\<close>

text \<open>Negation\<close>
lemma neg_ci: "in_carrier l \<Longrightarrow> Ipol l (neg P) = \<ominus> (Ipol l P)"
  by (induct P arbitrary: l) (auto simp add: minus_add l_minus)

text \<open>Addition\<close>
lemma add_ci: "in_carrier l \<Longrightarrow> Ipol l (P \<langle>+\<rangle> Q) = Ipol l P \<oplus> Ipol l Q"
proof (induct P Q arbitrary: l rule: add.induct)
  case (6 x P y Q)
  consider "x < y" | "x = y" | "x > y" by arith
  then show ?case
  proof cases
    case 1
    with 6 show ?thesis by (simp add: mkPinj_ci a_ac)
  next
    case 2
    with 6 show ?thesis by (simp add: mkPinj_ci)
  next
    case 3
    with 6 show ?thesis by (simp add: mkPinj_ci)
  qed
next
  case (7 x P Q y R)
  consider "x = 0" | "x = 1" | "x > 1" by arith
  then show ?case
  proof cases
    case 1
    with 7 show ?thesis by simp
  next
    case 2
    with 7 show ?thesis by (simp add: a_ac)
  next
    case 3
    with 7 show ?thesis by (cases x) (simp_all add: a_ac)
  qed
next
  case (8 P x R y Q)
  then show ?case by (simp add: a_ac)
next
  case (9 P1 x P2 Q1 y Q2)
  consider "x = y" | d where "d + x = y" | d where "d + y = x"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 9 show ?thesis by (simp add: mkPX_ci r_distr a_ac m_ac)
  next
    case 2
    with 9 show ?thesis by (auto simp add: mkPX_ci nat_pow_mult [symmetric] r_distr a_ac m_ac)
  next
    case 3
    with 9 show ?thesis by (auto simp add: nat_pow_mult [symmetric] mkPX_ci r_distr a_ac m_ac)
  qed
qed (auto simp add: a_ac m_ac)

text \<open>Multiplication\<close>
lemma mul_ci: "in_carrier l \<Longrightarrow> Ipol l (P \<langle>*\<rangle> Q) = Ipol l P \<otimes> Ipol l Q"
  by (induct P Q arbitrary: l rule: mul.induct)
    (simp_all add: mkPX_ci mkPinj_ci a_ac m_ac r_distr add_ci nat_pow_mult [symmetric])

text \<open>Subtraction\<close>
lemma sub_ci: "in_carrier l \<Longrightarrow> Ipol l (P \<langle>-\<rangle> Q) = Ipol l P \<ominus> Ipol l Q"
  by (simp add: add_ci neg_ci sub_def minus_eq)

text \<open>Square\<close>
lemma sqr_ci: "in_carrier ls \<Longrightarrow> Ipol ls (sqr P) = Ipol ls P \<otimes> Ipol ls P"
  by (induct P arbitrary: ls)
    (simp_all add: add_ci mkPinj_ci mkPX_ci mul_ci l_distr r_distr
       a_ac m_ac nat_pow_mult [symmetric] of_int_2)

text \<open>Power\<close>
lemma pow_ci: "in_carrier ls \<Longrightarrow> Ipol ls (pow n P) = Ipol ls P [^] n"
proof (induct n arbitrary: P rule: less_induct)
  case (less k)
  consider "k = 0" | "k > 0" by arith
  then show ?case
  proof cases
    case 1
    then show ?thesis by simp
  next
    case 2
    then have "k div 2 < k" by arith
    with less have *: "Ipol ls (pow (k div 2) (sqr P)) = Ipol ls (sqr P) [^] (k div 2)"
      by simp
    show ?thesis
    proof (cases "even k")
      case True
      with * \<open>in_carrier ls\<close> show ?thesis
        by (simp add: even_pow sqr_ci nat_pow_distrib nat_pow_mult
          mult_2 [symmetric] even_two_times_div_two)
    next
      case False
      with * \<open>in_carrier ls\<close> show ?thesis
        by (simp add: odd_pow mul_ci sqr_ci nat_pow_distrib nat_pow_mult
          mult_2 [symmetric] trans [OF nat_pow_Suc m_comm, symmetric])
    qed
  qed
qed

text \<open>Normalization preserves semantics\<close>
lemma norm_ci: "in_carrier l \<Longrightarrow> Ipolex l Pe = Ipol l (norm Pe)"
  by (induct Pe) (simp_all add: add_ci sub_ci mul_ci neg_ci pow_ci)

text \<open>Reflection lemma: Key to the (incomplete) decision procedure\<close>
lemma norm_eq:
  assumes "in_carrier l"
  and "norm P1 = norm P2"
  shows "Ipolex l P1 = Ipolex l P2"
proof -
  from assms have "Ipol l (norm P1) = Ipol l (norm P2)" by simp
  with assms show ?thesis by (simp only: norm_ci)
qed

end

text \<open>Monomials\<close>

datatype mon =
    Mc int
  | Minj nat mon
  | MX nat mon

primrec (in cring) Imon :: "'a list \<Rightarrow> mon \<Rightarrow> 'a"
  where
    "Imon l (Mc c) = \<guillemotleft>c\<guillemotright>"
  | "Imon l (Minj i M) = Imon (drop i l) M"
  | "Imon l (MX x M) = Imon (drop 1 l) M \<otimes> head l [^] x"

lemma (in cring) Imon_closed [simp]: "in_carrier l \<Longrightarrow> Imon l m \<in> carrier R"
  by (induct m arbitrary: l) simp_all

definition mkMinj :: "nat \<Rightarrow> mon \<Rightarrow> mon"
  where "mkMinj i M =
    (case M of
      Mc c \<Rightarrow> Mc c
    | Minj j M \<Rightarrow> Minj (i + j) M
    | _ \<Rightarrow> Minj i M)"

definition Minj_pred :: "nat \<Rightarrow> mon \<Rightarrow> mon"
  where "Minj_pred i M = (if i = 1 then M else mkMinj (i - 1) M)"

primrec mkMX :: "nat \<Rightarrow> mon \<Rightarrow> mon"
  where
    "mkMX i (Mc c) = MX i (Mc c)"
  | "mkMX i (Minj j M) = (if j = 0 then mkMX i M else MX i (Minj_pred j M))"
  | "mkMX i (MX j M) = MX (i + j) M"

lemma (in cring) mkMinj_correct: "Imon l (mkMinj i M) = Imon l (Minj i M)"
  by (simp add: mkMinj_def add.commute split: mon.split)

lemma (in cring) Minj_pred_correct: "0 < i \<Longrightarrow> Imon (drop 1 l) (Minj_pred i M) = Imon l (Minj i M)"
  by (simp add: Minj_pred_def mkMinj_correct)

lemma (in cring) mkMX_correct: "in_carrier l \<Longrightarrow> Imon l (mkMX i M) = Imon l M \<otimes> head l [^] i"
  by (induct M)
    (simp_all add: Minj_pred_correct [simplified] nat_pow_mult [symmetric] m_ac split: mon.split)

fun cfactor :: "pol \<Rightarrow> int \<Rightarrow> pol \<times> pol"
  where
    "cfactor (Pc c') c = (Pc (c' mod c), Pc (c' div c))"
  | "cfactor (Pinj i P) c =
       (let (R, S) = cfactor P c
        in (mkPinj i R, mkPinj i S))"
  | "cfactor (PX P i Q) c =
       (let
          (R1, S1) = cfactor P c;
          (R2, S2) = cfactor Q c
        in (mkPX R1 i R2, mkPX S1 i S2))"

lemma (in cring) cfactor_correct:
  "in_carrier l \<Longrightarrow> Ipol l P = Ipol l (fst (cfactor P c)) \<oplus> \<guillemotleft>c\<guillemotright> \<otimes> Ipol l (snd (cfactor P c))"
proof (induct P c arbitrary: l rule: cfactor.induct)
  case (1 c' c)
  show ?case
    by (simp add: of_int_mult [symmetric] of_int_add [symmetric] del: of_int_mult)
next
  case (2 i P c)
  then show ?case
    by (simp add: mkPinj_ci split_beta)
next
  case (3 P i Q c)
  from 3(1) 3(2) [OF refl prod.collapse] 3(3)
  show ?case
    by (simp add: mkPX_ci r_distr a_ac m_ac split_beta)
qed

fun mfactor :: "pol \<Rightarrow> mon \<Rightarrow> pol \<times> pol"
  where
    "mfactor P (Mc c) = (if c = 1 then (Pc 0, P) else cfactor P c)"
  | "mfactor (Pc d) M = (Pc d, Pc 0)"
  | "mfactor (Pinj i P) (Minj j M) =
       (if i = j then
          let (R, S) = mfactor P M
          in (mkPinj i R, mkPinj i S)
        else if i < j then
          let (R, S) = mfactor P (Minj (j - i) M)
          in (mkPinj i R, mkPinj i S)
        else (Pinj i P, Pc 0))"
  | "mfactor (Pinj i P) (MX j M) = (Pinj i P, Pc 0)"
  | "mfactor (PX P i Q) (Minj j M) =
       (if j = 0 then mfactor (PX P i Q) M
        else
          let
            (R1, S1) = mfactor P (Minj j M);
            (R2, S2) = mfactor Q (Minj_pred j M)
          in (mkPX R1 i R2, mkPX S1 i S2))"
  | "mfactor (PX P i Q) (MX j M) =
       (if i = j then
          let (R, S) = mfactor P (mkMinj 1 M)
          in (mkPX R i Q, S)
        else if i < j then
          let (R, S) = mfactor P (MX (j - i) M)
          in (mkPX R i Q, S)
        else
          let (R, S) = mfactor P (mkMinj 1 M)
          in (mkPX R i Q, mkPX S (i - j) (Pc 0)))"

lemmas mfactor_induct = mfactor.induct
  [case_names Mc Pc_Minj Pc_MX Pinj_Minj Pinj_MX PX_Minj PX_MX]

lemma (in cring) mfactor_correct:
  "in_carrier l \<Longrightarrow>
   Ipol l P =
   Ipol l (fst (mfactor P M)) \<oplus>
   Imon l M \<otimes> Ipol l (snd (mfactor P M))"
proof (induct P M arbitrary: l rule: mfactor_induct)
  case (Mc P c)
  then show ?case
    by (simp add: cfactor_correct)
next
  case (Pc_Minj d i M)
  then show ?case
    by simp
next
  case (Pc_MX d i M)
  then show ?case
    by simp
next
  case (Pinj_Minj i P j M)
  then show ?case
    by (simp add: mkPinj_ci split_beta)
next
  case (Pinj_MX i P j M)
  then show ?case
    by simp
next
  case (PX_Minj P i Q j M)
  from PX_Minj(1,2) PX_Minj(3) [OF _ refl prod.collapse] PX_Minj(4)
  show ?case
    by (simp add: mkPX_ci Minj_pred_correct [simplified] r_distr a_ac m_ac split_beta)
next
  case (PX_MX P i Q j M)
  from \<open>in_carrier l\<close>
  have eq1: "(Imon (drop (Suc 0) l) M \<otimes> head l [^] (j - i)) \<otimes>
    Ipol l (snd (mfactor P (MX (j - i) M))) \<otimes> head l [^] i =
    Imon (drop (Suc 0) l) M \<otimes>
    Ipol l (snd (mfactor P (MX (j - i) M))) \<otimes>
    (head l [^] (j - i) \<otimes> head l [^] i)"
    by (simp add: m_ac)
  from \<open>in_carrier l\<close>
  have eq2: "(Imon (drop (Suc 0) l) M \<otimes> head l [^] j) \<otimes>
    (Ipol l (snd (mfactor P (mkMinj (Suc 0) M))) \<otimes> head l [^] (i - j)) =
    Imon (drop (Suc 0) l) M \<otimes>
    Ipol l (snd (mfactor P (mkMinj (Suc 0) M))) \<otimes>
    (head l [^] (i - j) \<otimes> head l [^] j)"
    by (simp add: m_ac)
  from PX_MX \<open>in_carrier l\<close> show ?case
    by (simp add: mkPX_ci mkMinj_correct l_distr eq1 eq2 split_beta nat_pow_mult)
      (simp add: a_ac m_ac)
qed

primrec mon_of_pol :: "pol \<Rightarrow> mon option"
  where
    "mon_of_pol (Pc c) = Some (Mc c)"
  | "mon_of_pol (Pinj i P) = (case mon_of_pol P of
         None \<Rightarrow> None
       | Some M \<Rightarrow> Some (mkMinj i M))"
  | "mon_of_pol (PX P i Q) =
       (if Q = Pc 0 then (case mon_of_pol P of
            None \<Rightarrow> None
          | Some M \<Rightarrow> Some (mkMX i M))
        else None)"

lemma (in cring) mon_of_pol_correct:
  assumes "in_carrier l"
    and "mon_of_pol P = Some M"
  shows "Ipol l P = Imon l M"
  using assms
proof (induct P arbitrary: M l)
  case (PX P1 i P2)
  from PX(1,3,4)
  show ?case
    by (auto simp add: mkMinj_correct mkMX_correct split: if_split_asm option.split_asm)
qed (auto simp add: mkMinj_correct split: option.split_asm)

fun (in cring) Ipolex_polex_list :: "'a list \<Rightarrow> (polex \<times> polex) list \<Rightarrow> bool"
  where
    "Ipolex_polex_list l [] = True"
  | "Ipolex_polex_list l ((P, Q) # pps) = ((Ipolex l P = Ipolex l Q) \<and> Ipolex_polex_list l pps)"

fun (in cring) Imon_pol_list :: "'a list \<Rightarrow> (mon \<times> pol) list \<Rightarrow> bool"
  where
    "Imon_pol_list l [] = True"
  | "Imon_pol_list l ((M, P) # mps) = ((Imon l M = Ipol l P) \<and> Imon_pol_list l mps)"

fun mk_monpol_list :: "(polex \<times> polex) list \<Rightarrow> (mon \<times> pol) list"
  where
    "mk_monpol_list [] = []"
  | "mk_monpol_list ((P, Q) # pps) =
       (case mon_of_pol (norm P) of
          None \<Rightarrow> mk_monpol_list pps
        | Some M \<Rightarrow> (M, norm Q) # mk_monpol_list pps)"

lemma (in cring) mk_monpol_list_correct:
  "in_carrier l \<Longrightarrow> Ipolex_polex_list l pps \<Longrightarrow> Imon_pol_list l (mk_monpol_list pps)"
  by (induct pps rule: mk_monpol_list.induct)
    (auto split: option.split simp add: norm_ci [symmetric] mon_of_pol_correct [symmetric])

definition ponesubst :: "pol \<Rightarrow> mon \<Rightarrow> pol \<Rightarrow> pol option"
  where "ponesubst P1 M P2 =
   (let (Q, R) = mfactor P1 M in
    (case R of
      Pc c \<Rightarrow> if c = 0 then None else Some (add Q (mul P2 R))
    | _ \<Rightarrow> Some (add Q (mul P2 R))))"

fun pnsubst1 :: "pol \<Rightarrow> mon \<Rightarrow> pol \<Rightarrow> nat \<Rightarrow> pol"
  where "pnsubst1 P1 M P2 n =
    (case ponesubst P1 M P2 of
      None \<Rightarrow> P1
    | Some P3 \<Rightarrow> if n = 0 then P3 else pnsubst1 P3 M P2 (n - 1))"

lemma pnsubst1_0 [simp]: "pnsubst1 P1 M P2 0 = (case ponesubst P1 M P2 of
  None \<Rightarrow> P1 | Some P3 \<Rightarrow> P3)"
  by (simp split: option.split)

lemma pnsubst1_Suc [simp]:
  "pnsubst1 P1 M P2 (Suc n) =
    (case ponesubst P1 M P2 of
      None \<Rightarrow> P1
    | Some P3 \<Rightarrow> pnsubst1 P3 M P2 n)"
  by (simp split: option.split)

declare pnsubst1.simps [simp del]

definition pnsubst :: "pol \<Rightarrow> mon \<Rightarrow> pol \<Rightarrow> nat \<Rightarrow> pol option"
  where "pnsubst P1 M P2 n =
    (case ponesubst P1 M P2 of
      None \<Rightarrow> None
    | Some P3 \<Rightarrow> Some (pnsubst1 P3 M P2 n))"

fun psubstl1 :: "pol \<Rightarrow> (mon \<times> pol) list \<Rightarrow> nat \<Rightarrow> pol"
  where
    "psubstl1 P1 [] n = P1"
  | "psubstl1 P1 ((M, P2) # mps) n = psubstl1 (pnsubst1 P1 M P2 n) mps n"

fun psubstl :: "pol \<Rightarrow> (mon \<times> pol) list \<Rightarrow> nat \<Rightarrow> pol option"
  where
    "psubstl P1 [] n = None"
  | "psubstl P1 ((M, P2) # mps) n =
      (case pnsubst P1 M P2 n of
        None \<Rightarrow> psubstl P1 mps n
      | Some P3 \<Rightarrow> Some (psubstl1 P3 mps n))"

fun pnsubstl :: "pol \<Rightarrow> (mon \<times> pol) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> pol"
  where "pnsubstl P1 mps m n =
    (case psubstl P1 mps n of
      None \<Rightarrow> P1
    | Some P3 \<Rightarrow> if m = 0 then P3 else pnsubstl P3 mps (m - 1) n)"

lemma pnsubstl_0 [simp]:
  "pnsubstl P1 mps 0 n = (case psubstl P1 mps n of None \<Rightarrow> P1 | Some P3 \<Rightarrow> P3)"
  by (simp split: option.split)

lemma pnsubstl_Suc [simp]:
  "pnsubstl P1 mps (Suc m) n = (case psubstl P1 mps n of None \<Rightarrow> P1 | Some P3 \<Rightarrow> pnsubstl P3 mps m n)"
  by (simp split: option.split)

declare pnsubstl.simps [simp del]

lemma (in cring) ponesubst_correct:
  "in_carrier l \<Longrightarrow> ponesubst P1 M P2 = Some P3 \<Longrightarrow> Imon l M = Ipol l P2 \<Longrightarrow> Ipol l P1 = Ipol l P3"
  by (auto simp add: ponesubst_def split_beta mfactor_correct [of l P1 M]
    add_ci mul_ci split: pol.split_asm if_split_asm)

lemma (in cring) pnsubst1_correct:
  "in_carrier l \<Longrightarrow> Imon l M = Ipol l P2 \<Longrightarrow> Ipol l (pnsubst1 P1 M P2 n) = Ipol l P1"
  by (induct n arbitrary: P1)
    (simp_all add: ponesubst_correct split: option.split)

lemma (in cring) pnsubst_correct:
  "in_carrier l \<Longrightarrow> pnsubst P1 M P2 n = Some P3 \<Longrightarrow> Imon l M = Ipol l P2 \<Longrightarrow> Ipol l P1 = Ipol l P3"
  by (auto simp add: pnsubst_def
    pnsubst1_correct ponesubst_correct split: option.split_asm)

lemma (in cring) psubstl1_correct:
  "in_carrier l \<Longrightarrow> Imon_pol_list l mps \<Longrightarrow> Ipol l (psubstl1 P1 mps n) = Ipol l P1"
  by (induct P1 mps n rule: psubstl1.induct) (simp_all add: pnsubst1_correct)

lemma (in cring) psubstl_correct:
  "in_carrier l \<Longrightarrow> psubstl P1 mps n = Some P2 \<Longrightarrow> Imon_pol_list l mps \<Longrightarrow> Ipol l P1 = Ipol l P2"
  by (induct P1 mps n rule: psubstl.induct)
    (auto simp add: psubstl1_correct pnsubst_correct split: option.split_asm)

lemma (in cring) pnsubstl_correct:
  "in_carrier l \<Longrightarrow> Imon_pol_list l mps \<Longrightarrow> Ipol l (pnsubstl P1 mps m n) = Ipol l P1"
  by (induct m arbitrary: P1)
    (simp_all add: psubstl_correct split: option.split)

lemma (in cring) norm_subst_correct:
  "in_carrier l \<Longrightarrow> Ipolex_polex_list l pps \<Longrightarrow>
   Ipolex l P = Ipol l (pnsubstl (norm P) (mk_monpol_list pps) m n)"
  by (simp add: pnsubstl_correct mk_monpol_list_correct norm_ci)

lemma in_carrier_trivial: "cring_class.in_carrier l"
  by (induct l) (simp_all add: cring_class.in_carrier_def carrier_class)

ML \<open>
val term_of_nat = HOLogic.mk_number \<^Type>\<open>nat\<close> o @{code integer_of_nat};

val term_of_int = HOLogic.mk_number \<^Type>\<open>int\<close> o @{code integer_of_int};

fun term_of_pol (@{code Pc} k) = \<^Const>\<open>Pc\<close> $ term_of_int k
  | term_of_pol (@{code Pinj} (n, p)) = \<^Const>\<open>Pinj\<close> $ term_of_nat n $ term_of_pol p
  | term_of_pol (@{code PX} (p, n, q)) = \<^Const>\<open>PX\<close> $ term_of_pol p $ term_of_nat n $ term_of_pol q;

local

fun pol (ctxt, ct, t) =
  \<^instantiate>\<open>x = ct and y = \<open>Thm.cterm_of ctxt t\<close>
    in cterm \<open>x \<equiv> y\<close> for x y :: pol\<close>;

val (_, raw_pol_oracle) = Context.>>> (Context.map_theory_result
  (Thm.add_oracle (\<^binding>\<open>pnsubstl\<close>, pol)));

fun pol_oracle ctxt ct t = raw_pol_oracle (ctxt, ct, t);

in

val cv = @{computation_conv pol
  terms: pnsubstl mk_monpol_list norm
    nat_of_integer Code_Target_Nat.natural
      "0::nat" "1::nat" "2::nat" "3::nat"
      "0::int" "1::int" "2::int" "3::int" "-1::int"
  datatypes: polex "(polex * polex) list" int integer num}
  (fn ctxt => fn p => fn ct => pol_oracle ctxt ct (term_of_pol p))

end
\<close>

ML \<open>
signature RING_TAC =
sig
  structure Ring_Simps:
  sig
    type T
    val get: Context.generic -> T
    val put: T -> Context.generic -> Context.generic
    val map: (T -> T) -> Context.generic -> Context.generic
  end
  val insert_rules: ((term * 'a) * (term * 'a) -> bool) -> (term * 'a) ->
    (term * 'a) Net.net -> (term * 'a) Net.net
  val eq_ring_simps:
    (term * (thm list * thm list * thm list * thm list * thm * thm)) *
    (term * (thm list * thm list * thm list * thm list * thm * thm)) -> bool
  val ring_tac: bool -> thm list -> Proof.context -> int -> tactic
  val get_matching_rules: Proof.context -> (term * 'a) Net.net -> term -> 'a option
  val norm: thm -> thm
  val mk_in_carrier: Proof.context -> term -> thm list -> (string * typ) list -> thm
  val mk_ring: typ -> term
end

structure Ring_Tac : RING_TAC =
struct

fun eq_ring_simps
  ((t, (ths1, ths2, ths3, ths4, th5, th)),
   (t', (ths1', ths2', ths3', ths4', th5', th'))) =
    t aconv t' andalso
    eq_list Thm.eq_thm (ths1, ths1') andalso
    eq_list Thm.eq_thm (ths2, ths2') andalso
    eq_list Thm.eq_thm (ths3, ths3') andalso
    eq_list Thm.eq_thm (ths4, ths4') andalso
    Thm.eq_thm (th5, th5') andalso
    Thm.eq_thm (th, th');

structure Ring_Simps = Generic_Data
(struct
  type T = (term * (thm list * thm list * thm list * thm list * thm * thm)) Net.net
  val empty = Net.empty
  val merge = Net.merge eq_ring_simps
end);

fun get_matching_rules ctxt net t = get_first
  (fn (p, x) =>
     if Pattern.matches (Proof_Context.theory_of ctxt) (p, t) then SOME x else NONE)
  (Net.match_term net t);

fun insert_rules eq (t, x) = Net.insert_term eq (t, (t, x));

fun norm thm = thm COMP_INCR asm_rl;

fun get_ring_simps ctxt optcT t =
  (case get_matching_rules ctxt (Ring_Simps.get (Context.Proof ctxt)) t of
     SOME (ths1, ths2, ths3, ths4, th5, th) =>
       let val tr =
         Thm.transfer' ctxt #>
         (case optcT of NONE => I | SOME cT => inst [cT] [] #> norm)
       in (map tr ths1, map tr ths2, map tr ths3, map tr ths4, tr th5, tr th) end
   | NONE => error "get_ring_simps: lookup failed");

fun ring_struct \<^Const_>\<open>Ring.ring.add _ _ for R _ _\<close> = SOME R
  | ring_struct \<^Const_>\<open>Ring.a_minus _ _ for R _ _\<close> = SOME R
  | ring_struct \<^Const_>\<open>Group.monoid.mult _ _ for R _ _\<close> = SOME R
  | ring_struct \<^Const_>\<open>Ring.a_inv _ _ for R _\<close> = SOME R
  | ring_struct \<^Const_>\<open>Group.pow _ _ _ for R _ _\<close> = SOME R
  | ring_struct \<^Const_>\<open>Ring.ring.zero _ _ for R\<close> = SOME R
  | ring_struct \<^Const_>\<open>Group.monoid.one _ _ for R\<close> = SOME R
  | ring_struct \<^Const_>\<open>Algebra_Aux.of_integer _ _ for R _\<close> = SOME R
  | ring_struct _ = NONE;

fun reif_polex vs \<^Const_>\<open>Ring.ring.add _ _ for _ a b\<close> =
      \<^Const>\<open>Add for \<open>reif_polex vs a\<close> \<open>reif_polex vs b\<close>\<close>
  | reif_polex vs \<^Const_>\<open>Ring.a_minus _ _ for _ a b\<close> =
      \<^Const>\<open>Sub for \<open>reif_polex vs a\<close> \<open>reif_polex vs b\<close>\<close>
  | reif_polex vs \<^Const_>\<open>Group.monoid.mult _ _ for _ a b\<close> =
      \<^Const>\<open>Mul for \<open>reif_polex vs a\<close> \<open>reif_polex vs b\<close>\<close>
  | reif_polex vs \<^Const_>\<open>Ring.a_inv _ _ for _ a\<close> =
      \<^Const>\<open>Neg for \<open>reif_polex vs a\<close>\<close>
  | reif_polex vs \<^Const_>\<open>Group.pow _ _ _ for _ a n\<close> =
      \<^Const>\<open>Pow for \<open>reif_polex vs a\<close> n\<close>
  | reif_polex vs (Free x) =
      \<^Const>\<open>Var for \<open>HOLogic.mk_number HOLogic.natT (find_index (equal x) vs)\<close>\<close>
  | reif_polex _ \<^Const_>\<open>Ring.ring.zero _ _ for _\<close> = \<^term>\<open>Const 0\<close>
  | reif_polex _ \<^Const_>\<open>Group.monoid.one _ _ for _\<close> = \<^term>\<open>Const 1\<close>
  | reif_polex _ \<^Const_>\<open>Algebra_Aux.of_integer _ _ for _ n\<close> = \<^Const>\<open>Const for n\<close>
  | reif_polex _ _ = error "reif_polex: bad expression";

fun reif_polex' vs \<^Const_>\<open>plus _ for a b\<close> = \<^Const>\<open>Add for \<open>reif_polex' vs a\<close> \<open>reif_polex' vs b\<close>\<close>
  | reif_polex' vs \<^Const_>\<open>minus _ for a b\<close> = \<^Const>\<open>Sub for \<open>reif_polex' vs a\<close> \<open>reif_polex' vs b\<close>\<close>
  | reif_polex' vs \<^Const_>\<open>times _ for a b\<close> = \<^Const>\<open>Mul for \<open>reif_polex' vs a\<close> \<open>reif_polex' vs b\<close>\<close>
  | reif_polex' vs \<^Const_>\<open>uminus _ for a\<close> = \<^Const>\<open>Neg for \<open>reif_polex' vs a\<close>\<close>
  | reif_polex' vs \<^Const_>\<open>power _ for a n\<close> = \<^Const>\<open>Pow for \<open>reif_polex' vs a\<close> n\<close>
  | reif_polex' vs (Free x) = \<^Const>\<open>Var for \<open>HOLogic.mk_number \<^Type>\<open>nat\<close> (find_index (equal x) vs)\<close>\<close>
  | reif_polex' _ \<^Const_>\<open>numeral _ for b\<close> = \<^Const>\<open>Const for \<^Const>\<open>numeral \<^Type>\<open>int\<close> for b\<close>\<close>
  | reif_polex' _ \<^Const_>\<open>zero_class.zero _\<close> = \<^term>\<open>Const 0\<close>
  | reif_polex' _ \<^Const_>\<open>one_class.one _\<close> = \<^term>\<open>Const 1\<close>
  | reif_polex' _ t = error "reif_polex: bad expression";

fun head_conv (_, _, _, _, head_simp, _) ys =
  (case strip_app ys of
     (\<^const_name>\<open>Cons\<close>, [y, xs]) => inst [] [y, xs] head_simp);

fun Ipol_conv (rls as
      ([Ipol_simps_1, Ipol_simps_2, Ipol_simps_3,
        Ipol_simps_4, Ipol_simps_5, Ipol_simps_6,
        Ipol_simps_7], _, _, _, _, _)) =
  let
    val a = type_of_eqn Ipol_simps_1;
    val drop_conv_a = drop_conv a;

    fun conv l p = (case strip_app p of
        (\<^const_name>\<open>Pc\<close>, [c]) => (case strip_numeral c of
            (\<^const_name>\<open>zero_class.zero\<close>, _) => inst [] [l] Ipol_simps_4
          | (\<^const_name>\<open>one_class.one\<close>, _) => inst [] [l] Ipol_simps_5
          | (\<^const_name>\<open>numeral\<close>, [m]) => inst [] [l, m] Ipol_simps_6
          | (\<^const_name>\<open>uminus\<close>, [m]) => inst [] [l, m] Ipol_simps_7
          | _ => inst [] [l, c] Ipol_simps_1)
      | (\<^const_name>\<open>Pinj\<close>, [i, P]) =>
          transitive'
            (inst [] [l, i, P] Ipol_simps_2)
            (cong2' conv (args2 drop_conv_a) Thm.reflexive)
      | (\<^const_name>\<open>PX\<close>, [P, x, Q]) =>
          transitive'
            (inst [] [l, P, x, Q] Ipol_simps_3)
            (cong2
               (cong2
                  (args2 conv) (cong2 (args1 (head_conv rls)) Thm.reflexive))
               (cong2' conv (args2 drop_conv_a) Thm.reflexive)))
  in conv end;

fun Ipolex_conv (rls as
      (_,
       [Ipolex_Var, Ipolex_Const, Ipolex_Add,
        Ipolex_Sub, Ipolex_Mul, Ipolex_Pow,
        Ipolex_Neg, Ipolex_Const_0, Ipolex_Const_1,
        Ipolex_Const_numeral], _, _, _, _)) =
  let
    val a = type_of_eqn Ipolex_Var;
    val drop_conv_a = drop_conv a;

    fun conv l r = (case strip_app r of
        (\<^const_name>\<open>Var\<close>, [n]) =>
          transitive'
            (inst [] [l, n] Ipolex_Var)
            (cong1' (head_conv rls) (args2 drop_conv_a))
      | (\<^const_name>\<open>Const\<close>, [i]) => (case strip_app i of
            (\<^const_name>\<open>zero_class.zero\<close>, _) => inst [] [l] Ipolex_Const_0
          | (\<^const_name>\<open>one_class.one\<close>, _) => inst [] [l] Ipolex_Const_1
          | (\<^const_name>\<open>numeral\<close>, [m]) => inst [] [l, m] Ipolex_Const_numeral
          | _ => inst [] [l, i] Ipolex_Const)
      | (\<^const_name>\<open>Add\<close>, [P, Q]) =>
          transitive'
            (inst [] [l, P, Q] Ipolex_Add)
            (cong2 (args2 conv) (args2 conv))
      | (\<^const_name>\<open>Sub\<close>, [P, Q]) =>
          transitive'
            (inst [] [l, P, Q] Ipolex_Sub)
            (cong2 (args2 conv) (args2 conv))
      | (\<^const_name>\<open>Mul\<close>, [P, Q]) =>
          transitive'
            (inst [] [l, P, Q] Ipolex_Mul)
            (cong2 (args2 conv) (args2 conv))
      | (\<^const_name>\<open>Pow\<close>, [P, n]) =>
          transitive'
            (inst [] [l, P, n] Ipolex_Pow)
            (cong2 (args2 conv) Thm.reflexive)
      | (\<^const_name>\<open>Neg\<close>, [P]) =>
          transitive'
            (inst [] [l, P] Ipolex_Neg)
            (cong1 (args2 conv)))
  in conv end;

fun Ipolex_polex_list_conv (rls as
      (_, _,
       [Ipolex_polex_list_Nil, Ipolex_polex_list_Cons], _, _, _)) l pps =
  (case strip_app pps of
     (\<^const_name>\<open>Nil\<close>, []) => inst [] [l] Ipolex_polex_list_Nil
   | (\<^const_name>\<open>Cons\<close>, [p, pps']) => (case strip_app p of
       (\<^const_name>\<open>Pair\<close>, [P, Q]) =>
         transitive'
           (inst [] [l, P, Q, pps'] Ipolex_polex_list_Cons)
           (cong2
              (cong2 (args2 (Ipolex_conv rls)) (args2 (Ipolex_conv rls)))
              (args2 (Ipolex_polex_list_conv rls)))));

fun dest_conj th =
  let
    val th1 = th RS @{thm conjunct1};
    val th2 = th RS @{thm conjunct2}
  in
    dest_conj th1 @ dest_conj th2
  end handle THM _ => [th];

fun mk_in_carrier ctxt R prems xs =
  let
    val (_, _, _, [in_carrier_Nil, in_carrier_Cons], _, _) =
      get_ring_simps ctxt NONE R;
    val props = map fst (Facts.props (Proof_Context.facts_of ctxt)) @ maps dest_conj prems;
    val ths = map (fn p as (x, _) =>
      (case find_first
         ((fn \<^Const_>\<open>Trueprop
              for \<^Const_>\<open>Set.member _ for \<open>Free (y, _)\<close> \<^Const_>\<open>carrier _ _ for S\<close>\<close>\<close> =>
                x = y andalso R aconv S
            | _ => false) o Thm.prop_of) props of
         SOME th => th
       | NONE => error ("Variable " ^ Syntax.string_of_term ctxt (Free p) ^
           " not in carrier"))) xs
  in
    fold_rev (fn th1 => fn th2 => [th1, th2] MRS in_carrier_Cons)
       ths in_carrier_Nil
  end;

fun mk_ring T = \<^Const>\<open>cring_class_ops T\<close>;

val iterations = \<^cterm>\<open>1000::nat\<close>;
val Trueprop_cong = Thm.combination (Thm.reflexive \<^cterm>\<open>Trueprop\<close>);

fun commutative_ring_conv ctxt prems eqs ct =
  let
    val cT = Thm.ctyp_of_cterm ct;
    val T = Thm.typ_of cT;
    val eqs' = map (HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of) eqs;
    val xs = filter (equal T o snd) (rev (fold Term.add_frees
      (map fst eqs' @ map snd eqs' @ [Thm.term_of ct]) []));
    val (R, optcT, prem', reif) = (case ring_struct (Thm.term_of ct) of
        SOME R => (R, NONE, mk_in_carrier ctxt R prems xs, reif_polex xs)
      | NONE => (mk_ring T, SOME cT, @{thm in_carrier_trivial}, reif_polex' xs));
    val rls as (_, _, _, _, _, norm_subst_correct) = get_ring_simps ctxt optcT R;
    val cxs = Thm.cterm_of ctxt (HOLogic.mk_list T (map Free xs));
    val ceqs = Thm.cterm_of ctxt (HOLogic.mk_list \<^typ>\<open>polex \<times> polex\<close>
      (map (HOLogic.mk_prod o apply2 reif) eqs'));
    val cp = Thm.cterm_of ctxt (reif (Thm.term_of ct));
    val prem = Thm.equal_elim
      (Trueprop_cong (Thm.symmetric (Ipolex_polex_list_conv rls cxs ceqs)))
      (fold_rev (fn th1 => fn th2 => [th1, th2] MRS @{thm conjI})
         eqs @{thm TrueI});
  in
    Thm.transitive
      (Thm.symmetric (Ipolex_conv rls cxs cp))
      (transitive'
         ([prem', prem] MRS inst [] [cxs, ceqs, cp, iterations, iterations]
            norm_subst_correct)
         (cong2' (Ipol_conv rls)
            Thm.reflexive
            (cv ctxt)))
  end;

fun ring_tac in_prems thms ctxt =
  tactic_of_conv (fn ct =>
    (if in_prems then Conv.prems_conv else Conv.concl_conv)
      (Logic.count_prems (Thm.term_of ct))
      (Conv.arg_conv (Conv.binop_conv (commutative_ring_conv ctxt [] thms))) ct) THEN'
  TRY o (assume_tac ctxt ORELSE' resolve_tac ctxt [@{thm refl}]);

end
\<close>

context cring
begin

local_setup \<open>
Local_Theory.declaration {syntax = false, pervasive = false}
  (fn phi => Ring_Tac.Ring_Simps.map (Ring_Tac.insert_rules Ring_Tac.eq_ring_simps
    (Morphism.term phi \<^term>\<open>R\<close>,
     (Morphism.fact phi @{thms Ipol.simps [meta] Ipol_Pc [meta]},
      Morphism.fact phi @{thms Ipolex.simps [meta] Ipolex_Const [meta]},
      Morphism.fact phi @{thms Ipolex_polex_list.simps [meta]},
      Morphism.fact phi @{thms in_carrier_Nil in_carrier_Cons},
      singleton (Morphism.fact phi) @{thm head.simps(2) [meta]},
      singleton (Morphism.fact phi) @{thm norm_subst_correct [meta]}))))
\<close>

end

method_setup ring = \<open>
  Scan.lift (Args.mode "prems") -- Attrib.thms >> (SIMPLE_METHOD' oo uncurry Ring_Tac.ring_tac)
\<close> "simplify equations involving rings"

end