(*  Title       : HSEQ.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge
    Description : Convergence of sequences and series
    Conversion to Isar and new proofs by Lawrence C Paulson, 2004
    Additional contributions by Jeremy Avigad and Brian Huffman
*)

section {* Sequences and Convergence (Nonstandard) *}

theory HSEQ
imports Limits NatStar
begin

definition
  NSLIMSEQ :: "[nat => 'a::real_normed_vector, 'a] => bool"
    ("((_)/ ----NS> (_))" [60, 60] 60) where
    --{*Nonstandard definition of convergence of sequence*}
  "X ----NS> L = (\<forall>N \<in> HNatInfinite. ( *f* X) N \<approx> star_of L)"

definition
  nslim :: "(nat => 'a::real_normed_vector) => 'a" where
    --{*Nonstandard definition of limit using choice operator*}
  "nslim X = (THE L. X ----NS> L)"

definition
  NSconvergent :: "(nat => 'a::real_normed_vector) => bool" where
    --{*Nonstandard definition of convergence*}
  "NSconvergent X = (\<exists>L. X ----NS> L)"

definition
  NSBseq :: "(nat => 'a::real_normed_vector) => bool" where
    --{*Nonstandard definition for bounded sequence*}
  "NSBseq X = (\<forall>N \<in> HNatInfinite. ( *f* X) N : HFinite)"

definition
  NSCauchy :: "(nat => 'a::real_normed_vector) => bool" where
    --{*Nonstandard definition*}
  "NSCauchy X = (\<forall>M \<in> HNatInfinite. \<forall>N \<in> HNatInfinite. ( *f* X) M \<approx> ( *f* X) N)"

subsection {* Limits of Sequences *}

lemma NSLIMSEQ_iff:
    "(X ----NS> L) = (\<forall>N \<in> HNatInfinite. ( *f* X) N \<approx> star_of L)"
by (simp add: NSLIMSEQ_def)

lemma NSLIMSEQ_I:
  "(\<And>N. N \<in> HNatInfinite \<Longrightarrow> starfun X N \<approx> star_of L) \<Longrightarrow> X ----NS> L"
by (simp add: NSLIMSEQ_def)

lemma NSLIMSEQ_D:
  "\<lbrakk>X ----NS> L; N \<in> HNatInfinite\<rbrakk> \<Longrightarrow> starfun X N \<approx> star_of L"
by (simp add: NSLIMSEQ_def)

lemma NSLIMSEQ_const: "(%n. k) ----NS> k"
by (simp add: NSLIMSEQ_def)

lemma NSLIMSEQ_add:
      "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n + Y n) ----NS> a + b"
by (auto intro: approx_add simp add: NSLIMSEQ_def starfun_add [symmetric])

lemma NSLIMSEQ_add_const: "f ----NS> a ==> (%n.(f n + b)) ----NS> a + b"
by (simp only: NSLIMSEQ_add NSLIMSEQ_const)

lemma NSLIMSEQ_mult:
  fixes a b :: "'a::real_normed_algebra"
  shows "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n * Y n) ----NS> a * b"
by (auto intro!: approx_mult_HFinite simp add: NSLIMSEQ_def)

lemma NSLIMSEQ_minus: "X ----NS> a ==> (%n. -(X n)) ----NS> -a"
by (auto simp add: NSLIMSEQ_def)

lemma NSLIMSEQ_minus_cancel: "(%n. -(X n)) ----NS> -a ==> X ----NS> a"
by (drule NSLIMSEQ_minus, simp)

lemma NSLIMSEQ_diff:
     "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n - Y n) ----NS> a - b"
  using NSLIMSEQ_add [of X a "- Y" "- b"] by (simp add: NSLIMSEQ_minus fun_Compl_def)

(* FIXME: delete *)
lemma NSLIMSEQ_add_minus:
     "[| X ----NS> a; Y ----NS> b |] ==> (%n. X n + -Y n) ----NS> a + -b"
  by (simp add: NSLIMSEQ_diff)

lemma NSLIMSEQ_diff_const: "f ----NS> a ==> (%n.(f n - b)) ----NS> a - b"
by (simp add: NSLIMSEQ_diff NSLIMSEQ_const)

lemma NSLIMSEQ_inverse:
  fixes a :: "'a::real_normed_div_algebra"
  shows "[| X ----NS> a;  a ~= 0 |] ==> (%n. inverse(X n)) ----NS> inverse(a)"
by (simp add: NSLIMSEQ_def star_of_approx_inverse)

lemma NSLIMSEQ_mult_inverse:
  fixes a b :: "'a::real_normed_field"
  shows
     "[| X ----NS> a;  Y ----NS> b;  b ~= 0 |] ==> (%n. X n / Y n) ----NS> a/b"
by (simp add: NSLIMSEQ_mult NSLIMSEQ_inverse divide_inverse)

lemma starfun_hnorm: "\<And>x. hnorm (( *f* f) x) = ( *f* (\<lambda>x. norm (f x))) x"
by transfer simp

lemma NSLIMSEQ_norm: "X ----NS> a \<Longrightarrow> (\<lambda>n. norm (X n)) ----NS> norm a"
by (simp add: NSLIMSEQ_def starfun_hnorm [symmetric] approx_hnorm)

text{*Uniqueness of limit*}
lemma NSLIMSEQ_unique: "[| X ----NS> a; X ----NS> b |] ==> a = b"
apply (simp add: NSLIMSEQ_def)
apply (drule HNatInfinite_whn [THEN [2] bspec])+
apply (auto dest: approx_trans3)
done

lemma NSLIMSEQ_pow [rule_format]:
  fixes a :: "'a::{real_normed_algebra,power}"
  shows "(X ----NS> a) --> ((%n. (X n) ^ m) ----NS> a ^ m)"
apply (induct "m")
apply (auto simp add: power_Suc intro: NSLIMSEQ_mult NSLIMSEQ_const)
done

text{*We can now try and derive a few properties of sequences,
     starting with the limit comparison property for sequences.*}

lemma NSLIMSEQ_le:
       "[| f ----NS> l; g ----NS> m;
           \<exists>N. \<forall>n \<ge> N. f(n) \<le> g(n)
        |] ==> l \<le> (m::real)"
apply (simp add: NSLIMSEQ_def, safe)
apply (drule starfun_le_mono)
apply (drule HNatInfinite_whn [THEN [2] bspec])+
apply (drule_tac x = whn in spec)
apply (drule bex_Infinitesimal_iff2 [THEN iffD2])+
apply clarify
apply (auto intro: hypreal_of_real_le_add_Infininitesimal_cancel2)
done

lemma NSLIMSEQ_le_const: "[| X ----NS> (r::real); \<forall>n. a \<le> X n |] ==> a \<le> r"
by (erule NSLIMSEQ_le [OF NSLIMSEQ_const], auto)

lemma NSLIMSEQ_le_const2: "[| X ----NS> (r::real); \<forall>n. X n \<le> a |] ==> r \<le> a"
by (erule NSLIMSEQ_le [OF _ NSLIMSEQ_const], auto)

text{*Shift a convergent series by 1:
  By the equivalence between Cauchiness and convergence and because
  the successor of an infinite hypernatural is also infinite.*}

lemma NSLIMSEQ_Suc: "f ----NS> l ==> (%n. f(Suc n)) ----NS> l"
apply (unfold NSLIMSEQ_def, safe)
apply (drule_tac x="N + 1" in bspec)
apply (erule HNatInfinite_add)
apply (simp add: starfun_shift_one)
done

lemma NSLIMSEQ_imp_Suc: "(%n. f(Suc n)) ----NS> l ==> f ----NS> l"
apply (unfold NSLIMSEQ_def, safe)
apply (drule_tac x="N - 1" in bspec)
apply (erule Nats_1 [THEN [2] HNatInfinite_diff])
apply (simp add: starfun_shift_one one_le_HNatInfinite)
done

lemma NSLIMSEQ_Suc_iff: "((%n. f(Suc n)) ----NS> l) = (f ----NS> l)"
by (blast intro: NSLIMSEQ_imp_Suc NSLIMSEQ_Suc)

subsubsection {* Equivalence of @{term LIMSEQ} and @{term NSLIMSEQ} *}

lemma LIMSEQ_NSLIMSEQ:
  assumes X: "X ----> L" shows "X ----NS> L"
proof (rule NSLIMSEQ_I)
  fix N assume N: "N \<in> HNatInfinite"
  have "starfun X N - star_of L \<in> Infinitesimal"
  proof (rule InfinitesimalI2)
    fix r::real assume r: "0 < r"
    from LIMSEQ_D [OF X r]
    obtain no where "\<forall>n\<ge>no. norm (X n - L) < r" ..
    hence "\<forall>n\<ge>star_of no. hnorm (starfun X n - star_of L) < star_of r"
      by transfer
    thus "hnorm (starfun X N - star_of L) < star_of r"
      using N by (simp add: star_of_le_HNatInfinite)
  qed
  thus "starfun X N \<approx> star_of L"
    by (unfold approx_def)
qed

lemma NSLIMSEQ_LIMSEQ:
  assumes X: "X ----NS> L" shows "X ----> L"
proof (rule LIMSEQ_I)
  fix r::real assume r: "0 < r"
  have "\<exists>no. \<forall>n\<ge>no. hnorm (starfun X n - star_of L) < star_of r"
  proof (intro exI allI impI)
    fix n assume "whn \<le> n"
    with HNatInfinite_whn have "n \<in> HNatInfinite"
      by (rule HNatInfinite_upward_closed)
    with X have "starfun X n \<approx> star_of L"
      by (rule NSLIMSEQ_D)
    hence "starfun X n - star_of L \<in> Infinitesimal"
      by (unfold approx_def)
    thus "hnorm (starfun X n - star_of L) < star_of r"
      using r by (rule InfinitesimalD2)
  qed
  thus "\<exists>no. \<forall>n\<ge>no. norm (X n - L) < r"
    by transfer
qed

theorem LIMSEQ_NSLIMSEQ_iff: "(f ----> L) = (f ----NS> L)"
by (blast intro: LIMSEQ_NSLIMSEQ NSLIMSEQ_LIMSEQ)

subsubsection {* Derived theorems about @{term NSLIMSEQ} *}

text{*We prove the NS version from the standard one, since the NS proof
   seems more complicated than the standard one above!*}
lemma NSLIMSEQ_norm_zero: "((\<lambda>n. norm (X n)) ----NS> 0) = (X ----NS> 0)"
by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] tendsto_norm_zero_iff)

lemma NSLIMSEQ_rabs_zero: "((%n. \<bar>f n\<bar>) ----NS> 0) = (f ----NS> (0::real))"
by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] tendsto_rabs_zero_iff)

text{*Generalization to other limits*}
lemma NSLIMSEQ_imp_rabs: "f ----NS> (l::real) ==> (%n. \<bar>f n\<bar>) ----NS> \<bar>l\<bar>"
apply (simp add: NSLIMSEQ_def)
apply (auto intro: approx_hrabs
            simp add: starfun_abs)
done

lemma NSLIMSEQ_inverse_zero:
     "\<forall>y::real. \<exists>N. \<forall>n \<ge> N. y < f(n)
      ==> (%n. inverse(f n)) ----NS> 0"
by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] LIMSEQ_inverse_zero)

lemma NSLIMSEQ_inverse_real_of_nat: "(%n. inverse(real(Suc n))) ----NS> 0"
by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] LIMSEQ_inverse_real_of_nat)

lemma NSLIMSEQ_inverse_real_of_nat_add:
     "(%n. r + inverse(real(Suc n))) ----NS> r"
by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric] LIMSEQ_inverse_real_of_nat_add)

lemma NSLIMSEQ_inverse_real_of_nat_add_minus:
     "(%n. r + -inverse(real(Suc n))) ----NS> r"
  using LIMSEQ_inverse_real_of_nat_add_minus by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric])

lemma NSLIMSEQ_inverse_real_of_nat_add_minus_mult:
     "(%n. r*( 1 + -inverse(real(Suc n)))) ----NS> r"
  using LIMSEQ_inverse_real_of_nat_add_minus_mult by (simp add: LIMSEQ_NSLIMSEQ_iff [symmetric])

subsection {* Convergence *}

lemma nslimI: "X ----NS> L ==> nslim X = L"
apply (simp add: nslim_def)
apply (blast intro: NSLIMSEQ_unique)
done

lemma lim_nslim_iff: "lim X = nslim X"
by (simp add: lim_def nslim_def LIMSEQ_NSLIMSEQ_iff)

lemma NSconvergentD: "NSconvergent X ==> \<exists>L. (X ----NS> L)"
by (simp add: NSconvergent_def)

lemma NSconvergentI: "(X ----NS> L) ==> NSconvergent X"
by (auto simp add: NSconvergent_def)

lemma convergent_NSconvergent_iff: "convergent X = NSconvergent X"
by (simp add: convergent_def NSconvergent_def LIMSEQ_NSLIMSEQ_iff)

lemma NSconvergent_NSLIMSEQ_iff: "NSconvergent X = (X ----NS> nslim X)"
by (auto intro: theI NSLIMSEQ_unique simp add: NSconvergent_def nslim_def)

subsection {* Bounded Monotonic Sequences *}

lemma NSBseqD: "[| NSBseq X;  N: HNatInfinite |] ==> ( *f* X) N : HFinite"
by (simp add: NSBseq_def)

lemma Standard_subset_HFinite: "Standard \<subseteq> HFinite"
unfolding Standard_def by auto

lemma NSBseqD2: "NSBseq X \<Longrightarrow> ( *f* X) N \<in> HFinite"
apply (cases "N \<in> HNatInfinite")
apply (erule (1) NSBseqD)
apply (rule subsetD [OF Standard_subset_HFinite])
apply (simp add: HNatInfinite_def Nats_eq_Standard)
done

lemma NSBseqI: "\<forall>N \<in> HNatInfinite. ( *f* X) N : HFinite ==> NSBseq X"
by (simp add: NSBseq_def)

text{*The standard definition implies the nonstandard definition*}

lemma Bseq_NSBseq: "Bseq X ==> NSBseq X"
proof (unfold NSBseq_def, safe)
  assume X: "Bseq X"
  fix N assume N: "N \<in> HNatInfinite"
  from BseqD [OF X] obtain K where "\<forall>n. norm (X n) \<le> K" by fast
  hence "\<forall>N. hnorm (starfun X N) \<le> star_of K" by transfer
  hence "hnorm (starfun X N) \<le> star_of K" by simp
  also have "star_of K < star_of (K + 1)" by simp
  finally have "\<exists>x\<in>Reals. hnorm (starfun X N) < x" by (rule bexI, simp)
  thus "starfun X N \<in> HFinite" by (simp add: HFinite_def)
qed

text{*The nonstandard definition implies the standard definition*}

lemma SReal_less_omega: "r \<in> \<real> \<Longrightarrow> r < \<omega>"
apply (insert HInfinite_omega)
apply (simp add: HInfinite_def)
apply (simp add: order_less_imp_le)
done

lemma NSBseq_Bseq: "NSBseq X \<Longrightarrow> Bseq X"
proof (rule ccontr)
  let ?n = "\<lambda>K. LEAST n. K < norm (X n)"
  assume "NSBseq X"
  hence finite: "( *f* X) (( *f* ?n) \<omega>) \<in> HFinite"
    by (rule NSBseqD2)
  assume "\<not> Bseq X"
  hence "\<forall>K>0. \<exists>n. K < norm (X n)"
    by (simp add: Bseq_def linorder_not_le)
  hence "\<forall>K>0. K < norm (X (?n K))"
    by (auto intro: LeastI_ex)
  hence "\<forall>K>0. K < hnorm (( *f* X) (( *f* ?n) K))"
    by transfer
  hence "\<omega> < hnorm (( *f* X) (( *f* ?n) \<omega>))"
    by simp
  hence "\<forall>r\<in>\<real>. r < hnorm (( *f* X) (( *f* ?n) \<omega>))"
    by (simp add: order_less_trans [OF SReal_less_omega])
  hence "( *f* X) (( *f* ?n) \<omega>) \<in> HInfinite"
    by (simp add: HInfinite_def)
  with finite show "False"
    by (simp add: HFinite_HInfinite_iff)
qed

text{* Equivalence of nonstandard and standard definitions
  for a bounded sequence*}
lemma Bseq_NSBseq_iff: "(Bseq X) = (NSBseq X)"
by (blast intro!: NSBseq_Bseq Bseq_NSBseq)

text{*A convergent sequence is bounded:
 Boundedness as a necessary condition for convergence.
 The nonstandard version has no existential, as usual *}

lemma NSconvergent_NSBseq: "NSconvergent X ==> NSBseq X"
apply (simp add: NSconvergent_def NSBseq_def NSLIMSEQ_def)
apply (blast intro: HFinite_star_of approx_sym approx_HFinite)
done

text{*Standard Version: easily now proved using equivalence of NS and
 standard definitions *}

lemma convergent_Bseq: "convergent X ==> Bseq (X::nat \<Rightarrow> _::real_normed_vector)"
by (simp add: NSconvergent_NSBseq convergent_NSconvergent_iff Bseq_NSBseq_iff)

subsubsection{*Upper Bounds and Lubs of Bounded Sequences*}

lemma NSBseq_isUb: "NSBseq X ==> \<exists>U::real. isUb UNIV {x. \<exists>n. X n = x} U"
by (simp add: Bseq_NSBseq_iff [symmetric] Bseq_isUb)

lemma NSBseq_isLub: "NSBseq X ==> \<exists>U::real. isLub UNIV {x. \<exists>n. X n = x} U"
by (simp add: Bseq_NSBseq_iff [symmetric] Bseq_isLub)

subsubsection{*A Bounded and Monotonic Sequence Converges*}

text{* The best of both worlds: Easier to prove this result as a standard
   theorem and then use equivalence to "transfer" it into the
   equivalent nonstandard form if needed!*}

lemma Bmonoseq_NSLIMSEQ: "\<forall>n \<ge> m. X n = X m ==> \<exists>L. (X ----NS> L)"
by (auto dest!: Bmonoseq_LIMSEQ simp add: LIMSEQ_NSLIMSEQ_iff)

lemma NSBseq_mono_NSconvergent:
     "[| NSBseq X; \<forall>m. \<forall>n \<ge> m. X m \<le> X n |] ==> NSconvergent (X::nat=>real)"
by (auto intro: Bseq_mono_convergent
         simp add: convergent_NSconvergent_iff [symmetric]
                   Bseq_NSBseq_iff [symmetric])

subsection {* Cauchy Sequences *}

lemma NSCauchyI:
  "(\<And>M N. \<lbrakk>M \<in> HNatInfinite; N \<in> HNatInfinite\<rbrakk> \<Longrightarrow> starfun X M \<approx> starfun X N)
   \<Longrightarrow> NSCauchy X"
by (simp add: NSCauchy_def)

lemma NSCauchyD:
  "\<lbrakk>NSCauchy X; M \<in> HNatInfinite; N \<in> HNatInfinite\<rbrakk>
   \<Longrightarrow> starfun X M \<approx> starfun X N"
by (simp add: NSCauchy_def)

subsubsection{*Equivalence Between NS and Standard*}

lemma Cauchy_NSCauchy:
  assumes X: "Cauchy X" shows "NSCauchy X"
proof (rule NSCauchyI)
  fix M assume M: "M \<in> HNatInfinite"
  fix N assume N: "N \<in> HNatInfinite"
  have "starfun X M - starfun X N \<in> Infinitesimal"
  proof (rule InfinitesimalI2)
    fix r :: real assume r: "0 < r"
    from CauchyD [OF X r]
    obtain k where "\<forall>m\<ge>k. \<forall>n\<ge>k. norm (X m - X n) < r" ..
    hence "\<forall>m\<ge>star_of k. \<forall>n\<ge>star_of k.
           hnorm (starfun X m - starfun X n) < star_of r"
      by transfer
    thus "hnorm (starfun X M - starfun X N) < star_of r"
      using M N by (simp add: star_of_le_HNatInfinite)
  qed
  thus "starfun X M \<approx> starfun X N"
    by (unfold approx_def)
qed

lemma NSCauchy_Cauchy:
  assumes X: "NSCauchy X" shows "Cauchy X"
proof (rule CauchyI)
  fix r::real assume r: "0 < r"
  have "\<exists>k. \<forall>m\<ge>k. \<forall>n\<ge>k. hnorm (starfun X m - starfun X n) < star_of r"
  proof (intro exI allI impI)
    fix M assume "whn \<le> M"
    with HNatInfinite_whn have M: "M \<in> HNatInfinite"
      by (rule HNatInfinite_upward_closed)
    fix N assume "whn \<le> N"
    with HNatInfinite_whn have N: "N \<in> HNatInfinite"
      by (rule HNatInfinite_upward_closed)
    from X M N have "starfun X M \<approx> starfun X N"
      by (rule NSCauchyD)
    hence "starfun X M - starfun X N \<in> Infinitesimal"
      by (unfold approx_def)
    thus "hnorm (starfun X M - starfun X N) < star_of r"
      using r by (rule InfinitesimalD2)
  qed
  thus "\<exists>k. \<forall>m\<ge>k. \<forall>n\<ge>k. norm (X m - X n) < r"
    by transfer
qed

theorem NSCauchy_Cauchy_iff: "NSCauchy X = Cauchy X"
by (blast intro!: NSCauchy_Cauchy Cauchy_NSCauchy)

subsubsection {* Cauchy Sequences are Bounded *}

text{*A Cauchy sequence is bounded -- nonstandard version*}

lemma NSCauchy_NSBseq: "NSCauchy X ==> NSBseq X"
by (simp add: Cauchy_Bseq Bseq_NSBseq_iff [symmetric] NSCauchy_Cauchy_iff)

subsubsection {* Cauchy Sequences are Convergent *}

text{*Equivalence of Cauchy criterion and convergence:
  We will prove this using our NS formulation which provides a
  much easier proof than using the standard definition. We do not
  need to use properties of subsequences such as boundedness,
  monotonicity etc... Compare with Harrison's corresponding proof
  in HOL which is much longer and more complicated. Of course, we do
  not have problems which he encountered with guessing the right
  instantiations for his 'espsilon-delta' proof(s) in this case
  since the NS formulations do not involve existential quantifiers.*}

lemma NSconvergent_NSCauchy: "NSconvergent X \<Longrightarrow> NSCauchy X"
apply (simp add: NSconvergent_def NSLIMSEQ_def NSCauchy_def, safe)
apply (auto intro: approx_trans2)
done

lemma real_NSCauchy_NSconvergent:
  fixes X :: "nat \<Rightarrow> real"
  shows "NSCauchy X \<Longrightarrow> NSconvergent X"
apply (simp add: NSconvergent_def NSLIMSEQ_def)
apply (frule NSCauchy_NSBseq)
apply (simp add: NSBseq_def NSCauchy_def)
apply (drule HNatInfinite_whn [THEN [2] bspec])
apply (drule HNatInfinite_whn [THEN [2] bspec])
apply (auto dest!: st_part_Ex simp add: SReal_iff)
apply (blast intro: approx_trans3)
done

lemma NSCauchy_NSconvergent:
  fixes X :: "nat \<Rightarrow> 'a::banach"
  shows "NSCauchy X \<Longrightarrow> NSconvergent X"
apply (drule NSCauchy_Cauchy [THEN Cauchy_convergent])
apply (erule convergent_NSconvergent_iff [THEN iffD1])
done

lemma NSCauchy_NSconvergent_iff:
  fixes X :: "nat \<Rightarrow> 'a::banach"
  shows "NSCauchy X = NSconvergent X"
by (fast intro: NSCauchy_NSconvergent NSconvergent_NSCauchy)

subsection {* Power Sequences *}

text{*The sequence @{term "x^n"} tends to 0 if @{term "0\<le>x"} and @{term
"x<1"}.  Proof will use (NS) Cauchy equivalence for convergence and
  also fact that bounded and monotonic sequence converges.*}

text{* We now use NS criterion to bring proof of theorem through *}

lemma NSLIMSEQ_realpow_zero:
  "[| 0 \<le> (x::real); x < 1 |] ==> (%n. x ^ n) ----NS> 0"
apply (simp add: NSLIMSEQ_def)
apply (auto dest!: convergent_realpow simp add: convergent_NSconvergent_iff)
apply (frule NSconvergentD)
apply (auto simp add: NSLIMSEQ_def NSCauchy_NSconvergent_iff [symmetric] NSCauchy_def starfun_pow)
apply (frule HNatInfinite_add_one)
apply (drule bspec, assumption)
apply (drule bspec, assumption)
apply (drule_tac x = "N + (1::hypnat) " in bspec, assumption)
apply (simp add: hyperpow_add)
apply (drule approx_mult_subst_star_of, assumption)
apply (drule approx_trans3, assumption)
apply (auto simp del: star_of_mult simp add: star_of_mult [symmetric])
done

lemma NSLIMSEQ_rabs_realpow_zero: "\<bar>c\<bar> < (1::real) ==> (%n. \<bar>c\<bar> ^ n) ----NS> 0"
by (simp add: LIMSEQ_rabs_realpow_zero LIMSEQ_NSLIMSEQ_iff [symmetric])

lemma NSLIMSEQ_rabs_realpow_zero2: "\<bar>c\<bar> < (1::real) ==> (%n. c ^ n) ----NS> 0"
by (simp add: LIMSEQ_rabs_realpow_zero2 LIMSEQ_NSLIMSEQ_iff [symmetric])

(***---------------------------------------------------------------
    Theorems proved by Harrison in HOL that we do not need
    in order to prove equivalence between Cauchy criterion
    and convergence:
 -- Show that every sequence contains a monotonic subsequence
Goal "\<exists>f. subseq f & monoseq (%n. s (f n))"
 -- Show that a subsequence of a bounded sequence is bounded
Goal "Bseq X ==> Bseq (%n. X (f n))";
 -- Show we can take subsequential terms arbitrarily far
    up a sequence
Goal "subseq f ==> n \<le> f(n)";
Goal "subseq f ==> \<exists>n. N1 \<le> n & N2 \<le> f(n)";
 ---------------------------------------------------------------***)

end


(*  Title:      Well-Quasi-Orders
    Author:     Christian Sternagel <c.sternagel@gmail.com>
    Maintainer: Christian Sternagel
    License:    LGPL
*)

section \<open>A Proof of Higman's Lemma via Open Induction\<close>

theory Higman_OI
imports
  Open_Induction.Open_Induction
  Minimal_Elements
  Almost_Full
begin

subsection \<open>Some facts about the suffix relation\<close>

lemma wfp_on_strict_suffix:
  "wfp_on strict_suffix A"
by (rule wfp_on_mono [OF subset_refl, of _ _ "measure_on length A"])
   (auto simp: strict_suffix_def suffix_def)

lemma po_on_strict_suffix:
  "po_on strict_suffix A"
by (force simp: strict_suffix_def po_on_def transp_on_def irreflp_on_def)

subsection \<open>Lexicographic Order on Infinite Sequences\<close>

lemma antisymp_on_LEX:
  assumes "irreflp_on A P" and "antisymp_on A P"
  shows "antisymp_on (SEQ A) (LEX P)"
proof (rule antisymp_onI)
  fix f g assume SEQ: "f \<in> SEQ A" "g \<in> SEQ A" and "LEX P f g" and "LEX P g f"
  then obtain i j where "P (f i) (g i)" and "P (g j) (f j)"
    and "\<forall>k<i. f k = g k" and "\<forall>k<j. g k = f k" by (auto simp: LEX_def)
  then have "P (f (min i j)) (f (min i j))"
    using assms(2) and SEQ by (cases "i = j") (auto simp: antisymp_on_def min_def, force)
  with assms(1) and SEQ show  "f = g" by (auto simp: irreflp_on_def)
qed

lemma LEX_trans:
  assumes "transp_on A P" and "f \<in> SEQ A" and "g \<in> SEQ A" and "h \<in> SEQ A"
    and "LEX P f g" and "LEX P g h"
  shows "LEX P f h"
using assms by (auto simp: LEX_def transp_on_def) (metis less_trans linorder_neqE_nat)

lemma qo_on_LEXEQ:
  "transp_on A P \<Longrightarrow> qo_on (LEXEQ P) (SEQ A)"
by (auto simp: qo_on_def reflp_on_def transp_on_def [of _ "LEXEQ P"] dest: LEX_trans)

context minimal_element
begin

lemma glb_LEX_lexmin:
  assumes "chain_on (LEX P) C (SEQ A)" and "C \<noteq> {}"
  shows "glb (LEX P) C (lexmin C)"
proof
  have "C \<subseteq> SEQ A" using assms by (auto simp: chain_on_def)
  then have "lexmin C \<in> SEQ A" using \<open>C \<noteq> {}\<close> by (intro lexmin_SEQ_mem)
  note * = \<open>C \<subseteq> SEQ A\<close> \<open>C \<noteq> {}\<close>
  note lex = LEX_imp_less [folded irreflp_on_def, OF po [THEN po_on_imp_irreflp_on]]
  \<comment> \<open>\<open>lexmin C\<close> is a lower bound\<close>
  show "lb (LEX P) C (lexmin C)"
  proof
    fix f assume "f \<in> C"
    then show "LEXEQ P (lexmin C) f"
    proof (cases "f = lexmin C")
      define i where "i = (LEAST i. f i \<noteq> lexmin C i)"
      case False
      then have neq: "\<exists>i. f i \<noteq> lexmin C i" by blast
      from LeastI_ex [OF this, folded i_def]
        and not_less_Least [where P = "\<lambda>i. f i \<noteq> lexmin C i", folded i_def]
      have neq: "f i \<noteq> lexmin C i" and eq: "\<forall>j<i. f j = lexmin C j" by auto
      then have **: "f \<in> eq_upto C (lexmin C) i" "f i \<in> ith (eq_upto C (lexmin C) i) i"
        using \<open>f \<in> C\<close> by force+
      moreover from ** have "\<not> P (f i) (lexmin C i)"
        using lexmin_minimal [OF *, of "f i" i] and \<open>f \<in> C\<close> and \<open>C \<subseteq> SEQ A\<close> by blast
      moreover obtain g where "g \<in> eq_upto C (lexmin C) (Suc i)"
        using eq_upto_lexmin_non_empty [OF *] by blast
      ultimately have "P (lexmin C i) (f i)"
        using neq and \<open>C \<subseteq> SEQ A\<close> and assms(1) and lex [of g f i] and lex [of f g i]
        by (auto simp: eq_upto_def chain_on_def)
      with eq show ?thesis by (auto simp: LEX_def)
    qed simp
  qed

  \<comment> \<open>\<open>lexmin C\<close> is greater than or equal to any other lower bound\<close>
  fix f assume lb: "lb (LEX P) C f"
  then show "LEXEQ P f (lexmin C)"
  proof (cases "f = lexmin C")
    define i where "i = (LEAST i. f i \<noteq> lexmin C i)"
    case False
    then have neq: "\<exists>i. f i \<noteq> lexmin C i" by blast
    from LeastI_ex [OF this, folded i_def]
      and not_less_Least [where P = "\<lambda>i. f i \<noteq> lexmin C i", folded i_def]
    have neq: "f i \<noteq> lexmin C i" and eq: "\<forall>j<i. f j = lexmin C j" by auto
    obtain h where "h \<in> eq_upto C (lexmin C) (Suc i)" and "h \<in> C"
      using eq_upto_lexmin_non_empty [OF *] by (auto simp: eq_upto_def)
    then have [simp]: "\<And>j. j < Suc i \<Longrightarrow> h j = lexmin C j" by auto
    with lb and \<open>h \<in> C\<close> have "LEX P f h" using neq by (auto simp: lb_def)
    then have "P (f i) (h i)"
      using neq and eq and \<open>C \<subseteq> SEQ A\<close> and \<open>h \<in> C\<close> by (intro lex) auto
    with eq show ?thesis by (auto simp: LEX_def)
  qed simp
qed

lemma dc_on_LEXEQ:
  "dc_on (LEXEQ P) (SEQ A)"
proof
  fix C assume "chain_on (LEXEQ P) C (SEQ A)" and "C \<noteq> {}"
  then have chain: "chain_on (LEX P) C (SEQ A)" by (auto simp: chain_on_def)
  then have "C \<subseteq> SEQ A" by (auto simp: chain_on_def)
  then have "lexmin C \<in> SEQ A" using \<open>C \<noteq> {}\<close> by (intro lexmin_SEQ_mem)
  have "glb (LEX P) C (lexmin C)" by (rule glb_LEX_lexmin [OF chain \<open>C \<noteq> {}\<close>])
  then have "glb (LEXEQ P) C (lexmin C)" by (auto simp: glb_def lb_def)
  with \<open>lexmin C \<in> SEQ A\<close> show "\<exists>f \<in> SEQ A. glb (LEXEQ P) C f" by blast
qed

end

text \<open>
  Properties that only depend on finite initial segments of a sequence
  (i.e., which are open with respect to the product topology).
\<close>
definition "pt_open_on Q A \<longleftrightarrow> (\<forall>f\<in>A. Q f \<longleftrightarrow> (\<exists>n. (\<forall>g\<in>A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g)))"

lemma pt_open_onD:
  "pt_open_on Q A \<Longrightarrow> Q f \<Longrightarrow> f \<in> A \<Longrightarrow> (\<exists>n. (\<forall>g\<in>A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g))"
  unfolding pt_open_on_def by blast

lemma pt_open_on_good:
  "pt_open_on (good Q) (SEQ A)"
proof (unfold pt_open_on_def, intro ballI)
  fix f assume f: "f \<in> SEQ A"
  show "good Q f = (\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g)"
  proof
    assume "good Q f"
    then obtain i and j where *: "i < j" "Q (f i) (f j)" by auto
    have "\<forall>g\<in>SEQ A. (\<forall>i<Suc j. g i = f i) \<longrightarrow> good Q g"
    proof (intro ballI impI)
      fix g assume "g \<in> SEQ A" and "\<forall>i<Suc j. g i = f i"
      then show "good Q g" using * by (force simp: good_def)
    qed
    then show "\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g" ..
  next
    assume "\<exists>n. \<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> good Q g"
    with f show "good Q f" by blast
  qed
qed

context minimal_element
begin

lemma pt_open_on_imp_open_on_LEXEQ:
  assumes "pt_open_on Q (SEQ A)"
  shows "open_on (LEXEQ P) Q (SEQ A)"
proof
  fix C assume chain: "chain_on (LEXEQ P) C (SEQ A)" and ne: "C \<noteq> {}"
    and "\<exists>g\<in>SEQ A. glb (LEXEQ P) C g \<and> Q g"
  then obtain g where g: "g \<in> SEQ A" and "glb (LEXEQ P) C g"
    and Q: "Q g" by blast
  then have glb: "glb (LEX P) C g" by (auto simp: glb_def lb_def)
  from chain have "chain_on (LEX P) C (SEQ A)" and C: "C \<subseteq> SEQ A" by (auto simp: chain_on_def)
  note * = glb_LEX_lexmin [OF this(1) ne]
  have "lexmin C \<in> SEQ A" using ne and C by (intro lexmin_SEQ_mem)
  from glb_unique [OF _ g this glb *]
    and antisymp_on_LEX [OF po_on_imp_irreflp_on [OF po] po_on_imp_antisymp_on [OF po]]
  have [simp]: "lexmin C = g" by auto
  from assms [THEN pt_open_onD, OF Q g]
  obtain n :: nat where **: "\<And>h. h \<in> SEQ A \<Longrightarrow> (\<forall>i<n. h i = g i) \<longrightarrow> Q h" by blast
  from eq_upto_lexmin_non_empty [OF C ne, of n]
  obtain f where "f \<in> eq_upto C g n" by auto
  then have "f \<in> C" and "Q f" using ** [of f] and C by force+
  then show "\<exists>f\<in>C. Q f" by blast
qed

lemma open_on_good:
  "open_on (LEXEQ P) (good Q) (SEQ A)"
  by (intro pt_open_on_imp_open_on_LEXEQ pt_open_on_good)

end

lemma open_on_LEXEQ_imp_pt_open_on_counterexample:
  fixes a b :: "'a"
  defines "A \<equiv> {a, b}" and "P \<equiv> (\<lambda>x y. False)" and "Q \<equiv> (\<lambda>f. \<forall>i. f i = b)"
  assumes [simp]: "a \<noteq> b"
  shows "minimal_element P A" and "open_on (LEXEQ P) Q (SEQ A)"
    and "\<not> pt_open_on Q (SEQ A)"
proof -
  show "minimal_element P A"
    by standard (auto simp: P_def po_on_def irreflp_on_def transp_on_def wfp_on_def)
  show "open_on (LEXEQ P) Q (SEQ A)"
    by (auto simp: P_def open_on_def chain_on_def SEQ_def glb_def lb_def LEX_def)
  show "\<not> pt_open_on Q (SEQ A)"
  proof
    define f :: "nat \<Rightarrow> 'a" where "f \<equiv> (\<lambda>x. b)"
    have "f \<in> SEQ A" by (auto simp: A_def f_def)
    moreover assume "pt_open_on Q (SEQ A)"
    ultimately have "Q f \<longleftrightarrow> (\<exists>n. (\<forall>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<longrightarrow> Q g))"
      unfolding pt_open_on_def by blast
    moreover have "Q f" by (auto simp: Q_def f_def)
    moreover have "\<exists>g\<in>SEQ A. (\<forall>i<n. g i = f i) \<and> \<not> Q g" for n
      by (intro bexI [of _ "f(n := a)"]) (auto simp: f_def Q_def A_def)
    ultimately show False by blast
  qed
qed

lemma higman:
  assumes "almost_full_on P A"
  shows "almost_full_on (list_emb P) (lists A)"
proof
  interpret minimal_element strict_suffix "lists A"
    by (unfold_locales) (intro po_on_strict_suffix wfp_on_strict_suffix)+
  fix f presume "f \<in> SEQ (lists A)"
  with qo_on_LEXEQ [OF po_on_imp_transp_on [OF po_on_strict_suffix]] and dc_on_LEXEQ and open_on_good
    show "good (list_emb P) f"
  proof (induct rule: open_induct_on)
    case (less f)
    define h where "h i = hd (f i)" for i
    show ?case
    proof (cases "\<exists>i. f i = []")
      case False
      then have ne: "\<forall>i. f i \<noteq> []" by auto
      with \<open>f \<in> SEQ (lists A)\<close> have "\<forall>i. h i \<in> A" by (auto simp: h_def ne_lists)
      from almost_full_on_imp_homogeneous_subseq [OF assms this]
      obtain \<phi> :: "nat \<Rightarrow> nat" where mono: "\<And>i j. i < j \<Longrightarrow> \<phi> i < \<phi> j"
        and P: "\<And>i j. i < j \<Longrightarrow> P (h (\<phi> i)) (h (\<phi> j))" by blast
      define f' where "f' i = (if i < \<phi> 0 then f i else tl (f (\<phi> (i - \<phi> 0))))" for i
      have f': "f' \<in> SEQ (lists A)" using ne and \<open>f \<in> SEQ (lists A)\<close>
        by (auto simp: f'_def dest: list.set_sel)
      have [simp]: "\<And>i. \<phi> 0 \<le> i \<Longrightarrow> h (\<phi> (i - \<phi> 0)) # f' i = f (\<phi> (i - \<phi> 0))"
        "\<And>i. i < \<phi> 0 \<Longrightarrow> f' i = f i" using ne by (auto simp: f'_def h_def)
      moreover have "strict_suffix (f' (\<phi> 0)) (f (\<phi> 0))" using ne by (auto simp: f'_def)
      ultimately have "LEX strict_suffix f' f" by (auto simp: LEX_def)
      with LEX_imp_not_LEX [OF this] have "strict (LEXEQ strict_suffix) f' f"
        using po_on_strict_suffix [of UNIV] unfolding po_on_def irreflp_on_def transp_on_def by blast
      from less(2) [OF f' this] have "good (list_emb P) f'" .
      then obtain i j where "i < j" and emb: "list_emb P (f' i) (f' j)" by (auto simp: good_def)
      consider "j < \<phi> 0" | "\<phi> 0 \<le> i" | "i < \<phi> 0" and "\<phi> 0 \<le> j" by arith
      then show ?thesis
      proof (cases)
        case 1 with \<open>i < j\<close> and emb show ?thesis by (auto simp: good_def)
      next
        case 2
        with \<open>i < j\<close> and P have "P (h (\<phi> (i - \<phi> 0))) (h (\<phi> (j - \<phi> 0)))" by auto
        with emb have "list_emb P (h (\<phi> (i - \<phi> 0)) # f' i) (h (\<phi> (j - \<phi> 0)) # f' j)" by auto
        then have "list_emb P (f (\<phi> (i - \<phi> 0))) (f (\<phi> (j - \<phi> 0)))" using 2 and \<open>i < j\<close> by auto
        moreover with 2 and \<open>i <j\<close> have "\<phi> (i - \<phi> 0) < \<phi> (j - \<phi> 0)" using mono by auto
        ultimately show ?thesis by (auto simp: good_def)
      next
        case 3
        with emb have "list_emb P (f i) (f' j)" by auto
        moreover have "f (\<phi> (j - \<phi> 0)) = h (\<phi> (j - \<phi> 0)) # f' j" using 3 by auto
        ultimately have "list_emb P (f i) (f (\<phi> (j - \<phi> 0)))" by auto
        moreover have "i < \<phi> (j - \<phi> 0)" using mono [of 0 "j - \<phi> 0"] and 3 by force
        ultimately show ?thesis by (auto simp: good_def)
      qed
    qed auto
  qed
qed blast

end


theory Ackermann imports Main "HOL-ex.Primrec"  "HOL-Library.Discrete" InverseNatNat begin

\<comment> \<open>This theory, including the structure of many proofs and the comments
   follow closely the Coq library accompanying the paper by Charguéraud and Pottier:
   \<^url>\<open>http://gallium.inria.fr/~fpottier/dev/uf/\<close>\<close>

(*Tarjan's definition, formulated in terms of compower*)
definition Ackermann where
  "Ackermann k \<equiv> ((\<lambda>f x. (f ^^ Suc x) x) ^^ k) Suc"

definition abase where "abase x \<equiv> Suc x"

definition astep where "astep (f::nat \<Rightarrow> nat) x \<equiv> compow (Suc x) f x"
term "compow k astep abase"
definition Ackermann' where "Ackermann' k \<equiv> compow k astep abase"

lemma Ackermann_alt_eq: "Ackermann = Ackermann'"
  unfolding Ackermann_def Ackermann'_def abase_def astep_def by simp

(*WTF is dis*)
lemma "compow 1 (0::nat) = 0"
  apply simp
  oops

lemma Ackermann01: "Ackermann 0 1 = 2"
  unfolding Ackermann_def
  by auto

(********************************************)
subsection{*Tarjan's characteristic equations*}
(********************************************)

lemma Ackermann_base_eq: "Ackermann 0 x = Suc x"
  unfolding Ackermann_def by simp

lemma Ackermann_step_eq: "Ackermann (Suc k) x = compow (Suc x) (Ackermann k) x"
  unfolding Ackermann_def by simp

(********************************************)
subsection{*Closed forms for @{term "Ackermann 1"} and @{term "Ackermann 2"}, from Cormen et al.*}
(********************************************)

lemma Ackermann_1_eq: "Ackermann (Suc 0) x = Suc (2 * x)"
proof -
  {
    fix x y
    have "compow x (Ackermann 0) y = x + y"
      unfolding Ackermann_def
      by (induction x) auto
  } note fact = this
  show ?thesis unfolding Ackermann_def by (simp add: Ackermann_step_eq fact)
qed

lemma Ackermann_1_eq': "Ackermann 1 x = Suc (2 * x)"
  by (simp add: Ackermann_1_eq)

lemma compow_Ackermann_1_eq_lemma: assumes "i>0" "x>0"
  shows "Suc (2 * (2 ^ i * Suc x - 1)) = 2 ^ Suc i * Suc x - 1"
proof -
  {
    have sg1: "2 ^ Suc i * Suc x > 1"
      using assms
      by (metis One_nat_def Suc_mono less_1_mult one_less_numeral_iff power_gt1 less_num_simps(2))
  } note sg1 = this
  show ?thesis
  apply (subst Suc_eq_plus1)
  apply (subst diff_mult_distrib2)
  apply (subst mult_1_right)
  apply (subst semigroup_mult_class.mult.assoc[symmetric])
  apply (subst power_class.power.power_Suc[symmetric])
  apply (subst Suc_eq_plus1[symmetric])
  using sg1
  by auto
qed

lemma compow_Ackermann_1_eq: "compow i (Ackermann 1) x = 2^i * (Suc x) -1"
proof (induction i arbitrary: x)
  case 0
  then show ?case by simp
next
  case (Suc i)
  have sg1: "compow (Suc i) (Ackermann 1) x = Ackermann 1 ((compow i (Ackermann 1) ) x)"
    by simp
   show ?case
     apply (subst sg1)
     apply (subst Suc)
     apply (subst Ackermann_1_eq')
     apply (cases "i>0")
     subgoal
       apply (cases "x>0")
       subgoal  using compow_Ackermann_1_eq_lemma[of i x] .
       subgoal
         by (metis One_nat_def Suc_1 Suc_diff_Suc lessI mult.right_neutral
             not_gr_zero power_Suc power_gt1 right_diff_distrib')
       done
     apply (cases "x>0")
     by auto
qed

lemma Ackermann_2_eq: "Ackermann 2 x = 2^(Suc x) * (Suc x) - 1"
  apply (subst numeral_2_eq_2; subst One_nat_def[symmetric])
  apply (subst Ackermann_step_eq)
  apply (subst compow_Ackermann_1_eq) ..

(********************************************)
subsection {*Every @{term "Ackermann k"} is inflationary.
             That is, @{term "x \<le> Ackermann k x"} holds.*}
(********************************************)

abbreviation inflationary where "inflationary f \<equiv> \<forall>x. x \<le> f x"

lemma inflationary_concrete: "inflationary f \<Longrightarrow> x \<le> f x"
  by simp

lemma inflationary_abase: "inflationary abase"
  unfolding abase_def by fastforce

lemma mono_id: "mono id" unfolding mono_def by auto

(*This is of course true for any sufficiently nice ordering (not necessarily nat), no idea how it's called*)
lemma inflationary_compow': assumes "inflationary f" shows "(x::nat) \<le> (f^^i) x"
proof (induction i)
  case 0
  then show ?case by auto
next
  case (Suc i)
  hence "x \<le>  (f ^^ i) x" .
  also have "\<dots>\<le> f ((f ^^ i) x) " using assms by auto
  finally show ?case apply (subst Nat.funpow.simps(2)) by simp
qed

lemma inflationary_compow: assumes "inflationary (f::nat\<Rightarrow>nat)" shows "inflationary (f^^i)"
  using inflationary_compow'[OF assms] by force

lemma preserves_inflationary_astep: assumes "inflationary f" shows "inflationary (astep f)"
  unfolding astep_def using inflationary_compow[OF assms] by blast

lemma compow_infaltionary_astep: "inflationary ((astep ^^ k) abase)"
proof (induction k)
  case 0
  then show ?case using inflationary_abase by auto
next
  case (Suc k)
  show ?case using preserves_inflationary_astep[OF Suc] by simp
qed

(*In the Coq proof this induction is abstracted through iter_invariant*)
lemma Ackermann'_k_inflationary: "inflationary (Ackermann' k)"
proof (induction k)
  case 0
  then show ?case
    unfolding Ackermann'_def
    by (auto simp add: inflationary_abase)
next
  case (Suc k)
   show ?case
    unfolding Ackermann'_def
    apply (subst Nat.funpow.simps(2))
    using preserves_inflationary_astep[OF Suc] unfolding Ackermann'_def by simp
qed

lemma Ackermann_k_inflationary: "inflationary (Ackermann k)"
  using Ackermann'_k_inflationary Ackermann_alt_eq by simp

lemma compow_Ackermann_k_inflationary: "inflationary ((Ackermann k)^^n)"
  using inflationary_compow[OF Ackermann_k_inflationary, of n k] .

lemma compow_Ackermann_k_inflationary': "x\<le> ((Ackermann k)^^n) x"
  using compow_Ackermann_k_inflationary by simp

(********************************************)
subsection {*@{term astep} is @{term inflationary}.*}
(********************************************)

lemma inflationary_astep: assumes "inflationary f" shows "f x \<le> astep f x"
proof -
  have 1:"(f::nat\<Rightarrow>nat) ^^ 1 = f" by simp
  show ?thesis
  unfolding astep_def
  apply (subst Suc_eq_plus1)
  apply (subst funpow_add[of x 1 f])
  apply (subst 1)
  using assms inflationary_compow[OF assms]
  by simp
qed

(********************************************)
subsection {*@{term Ackermann} is monotonic in its first argument.
            The results, which are functions, are compared pointwise*}
(********************************************)

lemma mono_pow_nat: "mono (f::nat\<Rightarrow>nat) \<Longrightarrow> mono (f ^^ n)"
  by (induct n) (auto simp: mono_def)

lemma strict_mono_pow_nat: "strict_mono (f::nat\<Rightarrow>nat) \<Longrightarrow> strict_mono (f ^^ n)"
  by (induct n) (simp add: strict_mono_def)+

lemma mono_abase: "mono abase"
  unfolding abase_def mono_def by auto

lemma astep_preserves_mono: assumes "mono f" "inflationary f" shows "mono (astep f)"
proof -
  {
    fix x y
    assume xy: "(x::nat)\<le>y"
    have "astep f x \<le>  (f ^^ Suc y) y" unfolding astep_def
      using funpow_mono2[OF assms(1), of "Suc x" "Suc y" x y, OF _ xy] assms(2) xy by blast
    hence "astep f x \<le> astep f y" unfolding astep_def by simp
  }
  thus ?thesis unfolding mono_def by fast
qed

lemma mono_Ackermann': "mono (Ackermann' k)"
proof (induction k)
 case 0
  show ?case unfolding Ackermann'_def apply (subst funpow_simps_right(1))+
    using mono_abase  unfolding id_def mono_def by blast
next
  case (Suc k)
   show ?case
     unfolding Ackermann'_def
     apply (subst Nat.funpow.simps(2))+
     using astep_preserves_mono[OF Suc Ackermann'_k_inflationary] unfolding Ackermann'_def by simp
qed

lemma mono_Ackermann: "mono (Ackermann k)"
  apply (subst Ackermann_alt_eq) using mono_Ackermann' .

lemma mono_Ackermann'_in_k: "mono (\<lambda>k. Ackermann' k x)"
proof -
  {
    fix k
    have "Ackermann' k x \<le> Ackermann' (Suc k) x"
      unfolding Ackermann'_def
      using inflationary_astep[OF compow_infaltionary_astep[of k], of x]
      by fastforce
  }
  thus ?thesis using mono_iff_le_Suc by blast
qed

lemma mono_Ackermann_in_k: "mono (\<lambda>k. Ackermann k x)"
  apply (subst Ackermann_alt_eq) using mono_Ackermann'_in_k .

(********************************************)
subsection {*Power can be expressed with @{term compow}*}
(********************************************)

lemma funpow_Suc_right_apply: "(f ^^ Suc n) x = (f ^^ n) (f x)"
  by (metis comp_apply funpow_Suc_right)

lemma pow_compow: " x ^ y = compow y (\<lambda>a. x * a ) 1" \<comment>\<open>(( * ) x ^^ y) 1\<close>
  by (induction y) auto

\<comment>\<open> Lower bound for @{term "Ackermann 2"}: @{term "2^x \<le> Ackermann 2 x"} \<close>

lemma Ackermann_2_lower_bound': assumes "x>0" shows "2 ^ x < Ackermann 2 x"
proof -
  {
    fix x::nat
    assume "x>0"
    hence "(2::nat) ^ x < 2 * 2 ^ x" by fastforce
  } note last1 = this
  {
    fix a::nat fix b::nat fix c::nat
    assume "a<b" "c>0"
    hence "a<b+c-1" by simp
  } note last2 = this
  {
    fix x::nat
    assume 1: "x>0"
    have " 2 ^ x * (2 * x) > 0" using 1 by auto
  } note last3 = this
  show ?thesis
  apply (subst pow_compow)
  apply (subst (2) Suc_1[symmetric])
  apply (subst Ackermann_step_eq)
  apply (subst  funpow_Suc_right_apply)
  apply (subst (3) One_nat_def)
  apply (subst Ackermann_1_eq)
  apply (subst compow_Ackermann_1_eq)
  apply (simp add: pow_compow)
  apply (subst  One_nat_def[symmetric])+
  apply (subst pow_compow[symmetric])+
    using last2[OF  last1[OF \<open>0<x\<close>] ,of  "2 ^ x * (2 * x)", OF  last3[OF \<open>0<x\<close>]] .
qed

lemma Ackermann_2_lower_bound: "2 ^ x \<le> Ackermann 2 x"
  apply (cases "0<x")
  subgoal using Ackermann_2_lower_bound'[of x] by auto
  subgoal by (auto simp: Ackermann_2_eq)
  done

(********************************************)
subsection {*A slightly more powerful version of the previous lemma. It is not a
   direct consequence of the previous lemma, because @{term "2 ^ (Discrete.log n)"} is
   in general less than or equal to n*}
(********************************************)

lemma Ackermann_2_log_lower_bound: "n \<le> Ackermann 2 (Discrete.log n)"
proof -
  {
    fix m::nat
    assume mins:"m\<ge>2"
    have "Discrete.log 2 = 1" by (simp add: Discrete.log.simps)
    with mins have "(Discrete.log m + 1) \<ge> 2" using log_mono unfolding mono_def by fastforce
    hence sg1: "2 * 2 ^ Discrete.log m * (Discrete.log m + 1) - 1  \<ge> 2 * 2 ^ Discrete.log m * 2 - 1 "
      by (simp add: diff_le_mono)
    also have "\<dots> \<ge>  2 * 2 ^ Discrete.log m" using calculation by linarith
    also have "\<dots> \<ge> m" using log_exp2_ge[of m]
      using sg1 le_trans by linarith
  } note case1 = this
  {
    fix m::nat
    assume maxs:"m<2"
    have "m \<le> 2 * 2 ^ Discrete.log m * (Discrete.log m + 1) - 1"
      apply (cases m)
      using maxs by (simp add: Discrete.log.simps)+
  } note case2 = this
  show ?thesis
    apply (subst Ackermann_2_eq)
    apply (subst power_Suc)
    apply (subst mult.commute)
    apply (subst Suc_eq_plus1)
    apply (subst mult.commute)
    apply (cases "n\<ge>2")
    subgoal using case1[of n] .
    subgoal using case2[of n] by simp
    done
qed

(********************************************)
subsection {*2 ^ (2 ^ ( ... 2)) { x + 1 times } \<le> Ackermann 3 x*}
(********************************************)

lemma compow_mono_in_f_2': assumes "mono (f::nat\<Rightarrow>nat)" "mono (g::nat\<Rightarrow>nat)" "\<forall> x y. x\<le> y \<longrightarrow> f x \<le> g y" "x\<le>y"
  shows "(f ^^ i) x \<le> (g ^^ i) y"
  using assms
proof (induction i arbitrary: x y)
  case 0
  then show ?case by simp
next
  case (Suc i)
  show ?case apply (subst funpow_Suc_right_apply)+
    using Suc(1)[OF Suc(2) Suc(3) Suc(4), of "f x" "g y"] Suc(5) Suc(4) by blast
qed

lemma compow_mono_in_f_2: assumes "mono (f::nat\<Rightarrow>nat)" "mono (g::nat\<Rightarrow>nat)" "\<forall> x. f x \<le> g x" "x\<le>y"
  shows "(f ^^ i) x \<le> (g ^^ i) y"
proof -
  have "\<forall> x y. x\<le> y \<longrightarrow> f x \<le> g y" using assms(3)
    using assms(2) le_trans mono_def by blast
  thus ?thesis using compow_mono_in_f_2'[OF assms(1-2) _ assms(4)]
    by presburger
qed

\<comment>\<open>This is a version of @{thm funpow_mono2} for comparing two functions on the same i\<close>
lemma compow_mono_in_f: assumes "mono (f::nat\<Rightarrow>nat)" "mono (g::nat\<Rightarrow>nat)" "\<forall>x. f x \<le> g x"
  shows "(f ^^ i) x \<le> (g ^^ i) x"
  using compow_mono_in_f_2 assms by blast

\<comment>\<open>This is a version of @{thm funpow_mono2} for comparing two functions instead of only
  the number of iterations\<close>
lemma compow_mono_in_f_and_i': assumes "mono (f::nat\<Rightarrow>nat)" "mono (g::nat\<Rightarrow>nat)" "inflationary g"
  "\<forall> x y. x\<le> y \<longrightarrow> f x \<le> g y" "x\<le>y" "i\<le>j"
  shows "(f ^^ i) x \<le> (g ^^ j) y"
  using assms
proof goal_cases
  case 1
  have "(f ^^ i) x \<le> (g ^^ i) y" using assms compow_mono_in_f_2' by auto
  also have "(g ^^ i) y \<le> (g ^^ j) y"  using assms funpow_mono2 by blast
  finally show ?case .
qed
thm funpow_mono2 compow_mono_in_f compow_mono_in_f_and_i'

lemma Ackermann_3_lower_bound:  "compow (Suc x) ((^) 2) 0 \<le> Ackermann 3 x"
proof -
  have def_3:"3 = Suc 2" by simp
  have monopow: "mono ((^) (2::nat))" unfolding mono_def by simp
  have sg1: "\<forall>x. 2 ^ x \<le> Ackermann 2 x" using Ackermann_2_lower_bound by blast
  have sg2: "\<forall> x y. x\<le> y \<longrightarrow> Ackermann 2 x \<le> Ackermann 2 y"
    using mono_Ackermann[of 2] unfolding mono_def .
  have sg3: "\<forall> x y. x\<le> y \<longrightarrow>  2 ^ x \<le> Ackermann 2 y" using sg1 sg2 order_trans by blast
  show ?thesis
    apply (subst def_3)
    apply (subst Ackermann_step_eq)
    using Ackermann_2_lower_bound
      compow_mono_in_f_and_i'[OF monopow mono_Ackermann[of 2] Ackermann_k_inflationary[of 2],
                              of 0 x "Suc x" "Suc x", OF sg3] by blast
qed

(********************************************)
subsection {*Every @{term "Ackermann k"} tends to infinity*}
(********************************************)

lemma Ackermann_k_tends_to_infinity:
  "filterlim (Ackermann k) at_top at_top"
  apply (subst filterlim_iff)
  apply (subst eventually_sequentially)
  apply (subst eventually_at_top_linorder)
  using Ackermann_k_inflationary[of k]
  using order.trans by blast

(********************************************)
subsection {*Every @{term "Ackermann k"} is strictly inflationary.
             That is, @{term "x < Ackermann k x"} holds.*}
(********************************************)

lemma Ackermann_k_strictly_inflationary:
  "x < Ackermann k x"
proof -
  have "x < Ackermann 0 x" apply (subst Ackermann_base_eq) by simp
  also have "\<dots> \<le> Ackermann k x" using mono_Ackermann_in_k unfolding mono_def by blast
  finally show ?thesis .
qed

(********************************************)
subsection {*For every n other than zero,
             @{term "compow n (Ackermann k)"} is strictly inflationary.*}
(********************************************)

lemma compow_Ackermann_k_strictly_inflationary':
  shows "x < compow (Suc n) (Ackermann k) x"
proof -
  have sg1: "x < Ackermann k x" using Ackermann_k_strictly_inflationary .
  also have sg2: "\<dots> \<le> (Ackermann k ^^ n) (Ackermann k x)"
    using compow_Ackermann_k_inflationary' mono_Ackermann unfolding mono_def by blast
  finally show ?thesis apply (subst funpow_Suc_right_apply) by simp
qed

lemma compow_Ackermann_k_strictly_inflationary:
  assumes "n>0"
  shows "x < compow n (Ackermann k) x"
proof -
  obtain m where sg1: "n = Suc m" using gr0_implies_Suc[OF assms] by blast
  show ?thesis apply (subst sg1) using compow_Ackermann_k_strictly_inflationary' by simp
qed

(********************************************)
subsection {*The function  @{term "\<lambda>k. Ackermann k x"} is @{term strict_mono}.*}
(********************************************)

lemma Ackermann_strict_mono_in_k_step:
  assumes "x > 0"
  shows "Ackermann k x < Ackermann (Suc k) x"
  apply (subst Ackermann_step_eq)
  apply simp
  apply (subst funpow_swap1[of "Ackermann k" x x])
  using compow_Ackermann_k_strictly_inflationary[of x "Ackermann k x" k , OF assms] .

lemma Ackermann_strict_mono_in_k:
  assumes "x > 0"
  shows "strict_mono (\<lambda>k. Ackermann k x)"
  unfolding strict_mono_def
  apply auto
proof goal_cases
  case (1 k1 k2)
  have "Ackermann k1 x < Ackermann (Suc k1) x"
    using Ackermann_strict_mono_in_k_step[OF assms] by simp
  also have "Ackermann (Suc k1) x \<le> Ackermann k2 x" using 1 mono_Ackermann_in_k unfolding mono_def by auto
  finally show ?case .
qed

(********************************************)
subsection {*Orbits of inflationary functions*}
(********************************************)

lemma Ackermann_k_x_tends_to_infinity_along_k:
  assumes "x > 0" shows "filterlim (\<lambda>k. Ackermann k x) at_top at_top"
  using  filterlim_subseq[OF Ackermann_strict_mono_in_k[OF assms]] .

(* The orbit of a strictly inflationary function goes to infinity. *)
 (* This lemma has nothing to do with Ackermann's function and could
     be placed in a separate file. *)

lemma compow_strictly_inflationary_tends_to_infinity:
  assumes "\<forall>x. x < f x" shows "filterlim (\<lambda>i. compow i f x) sequentially sequentially"
proof -
  {
    fix i
    have "x + i \<le> compow i f x" using assms proof (induction i)
      case (Suc i)
      have "Suc (x + i) \<le> f ((f ^^ i) x)"
        using assms Suc(1)[OF \<open> \<forall>x. x < f x\<close>] Suc_leI le_less_trans by blast
      then show ?case by (simp add: funpow_swap1 funpow_Suc_right_apply)
    qed simp
  } note bound = this
  thus ?thesis
    apply (subst filterlim_iff)
    apply (subst eventually_sequentially)
    apply (subst eventually_at_top_linorder)
    apply auto
    by (meson order_trans trans_le_add2)
qed

lemma compow_i_Ackermann_tends_to_infinity_along_i:
  "filterlim (\<lambda>i. compow i (Ackermann k) x) at_top at_top"
  using compow_strictly_inflationary_tends_to_infinity[of "Ackermann k"]
        Ackermann_k_strictly_inflationary[of _ k]
  by blast

(********************************************)
subsection {*Iterating i times an inflationary function f yields a monotonic function of i.*}
(********************************************)

lemma compow_inflationary_monotonic:
  assumes "inflationary (f::nat\<Rightarrow>nat)"
  shows "mono (\<lambda>i. (f ^^ i) x)"
  using assms unfolding mono_def
  apply auto
proof goal_cases
  case (1 i j)
  {
    fix y
    have "y \<le> (f ^^ (j - i)) y" using inflationary_compow'[OF assms, of y "j-i"] .
  } note gener = this
  have jlong: "j = (j - i) + i" using 1(2) by simp
  have sane: "(f ^^ (j - i) \<circ> f ^^ i) x = (f ^^ (j - i)) ((f ^^ i) x)" by simp
  show ?case
    apply (subst jlong)
    apply (subst funpow_add)
    apply (subst sane)
    using gener[of "(f ^^ i) x"] .
qed

(********************************************)
subsection {* @{term "(\<lambda> i. compow i (Ackermann k) x)"} is monotonic.*}
(********************************************)

lemma compow_Ackermann_mono_in_i:
  "mono (\<lambda> i. (Ackermann k ^^ i) x)"
  unfolding mono_def
  apply safe
proof goal_cases
  case (1 i j)
  show ?case using
      funpow_mono2[OF mono_Ackermann[of k] \<open>i\<le>j\<close>, of x x] Ackermann_k_inflationary[of k] by blast
qed

lemma observable_universe'':
  "Ackermann 3 1= 2047"
proof -
  have "Ackermann 3 1 = (Ackermann 2 ^^ Suc 1) 1" using Ackermann_step_eq[of 2 1] by fastforce
  also have "\<dots> = Ackermann 2 (Ackermann 2 1)" by simp
  also have "\<dots> = Ackermann 2 7" using Ackermann_2_eq[of 1] by simp
  also have "\<dots> = 2^8 * 8 -1" using Ackermann_2_eq[of 7] by simp
  also have "\<dots> = 2^11 - 1" by simp
  finally show ?thesis by auto
qed

lemma observable_universe':
"Ackermann 4 1 \<ge> 2 ^ 2048"
proof -
  have trivial: "Suc 2047 = 2048" by simp
  have "Ackermann 4 1 = (Ackermann 3 ^^ Suc 1) 1" using Ackermann_step_eq[of 3 1] by fastforce
  also have "\<dots> = Ackermann 3 (Ackermann 3 1)" by simp
  also have "\<dots> = Ackermann 3 2047" using observable_universe'' by argo
  also have sg: "\<dots> = (Ackermann 2 ^^ 2048) 2047" using Ackermann_step_eq[of 2 2047] by simp
  also have "\<dots> > Ackermann 2 2047" \<comment>\<open>This is a really big >> \<close>
    by (metis Ackermann_strict_mono_in_k_step Suc_1 sg
        numeral_1_eq_Suc_0 numeral_3_eq_3 numeral_One zero_less_numeral)
  also have "Ackermann 2 2047 = 2^(Suc 2047) * (Suc 2047) -1" using Ackermann_2_eq[of 2047] by argo
  also have "\<dots> = 2^2048 * 2048 - 1" apply (subst trivial)+ by argo
  finally show ?thesis by fastforce
qed

lemma observable_universe:
"Ackermann 4 1 > 10^80"
proof -
  have factor: "(2048::nat) = 4 * 512"  by simp
  have "(2::nat)^2048 = (2^4)^512" apply (subst factor)
    using power_mult[of 2 4 512] .
  also have "\<dots> = 16^512" by algebra
  finally have "(2::nat)^2048 > 10^80" by simp  \<comment>\<open>Again, very big >>\<close>
  thus ?thesis using observable_universe' by linarith
qed

(********************************************)
section {*Inverse Ackermann function, aka \<alpha>.*}
(********************************************)

definition \<alpha> where
  "\<alpha> n \<equiv> Least (\<lambda>k. Ackermann k 1 \<ge> n)"

interpretation A1nn: f_nat_nat "\<lambda>k. Ackermann k 1"
  apply standard subgoal using Ackermann_strict_mono_in_k[of 1] by simp
  subgoal using Ackermann_k_x_tends_to_infinity_along_k[of 1] by simp
  done

abbreviation \<alpha>' where
  "\<alpha>' \<equiv> A1nn.\<alpha>\<^sub>f "

lemma \<alpha>_alt_eq: "\<alpha> = \<alpha>'" unfolding \<alpha>_def A1nn.\<alpha>\<^sub>f_def by blast

lemma mono_\<alpha>: "mono \<alpha>"
  apply (subst \<alpha>_alt_eq)
  using A1nn.\<alpha>\<^sub>f_mono .

lemma observable_universe_\<alpha>:
  assumes "n \<le> 10^80"
  shows "\<alpha> n \<le> 4"
proof -
  have sg: "\<alpha>' (10^80) \<le> 4"
    apply (rule A1nn.\<alpha>\<^sub>f_spec_reciprocal[of "10^80" 4]) using observable_universe by linarith
  show ?thesis apply (subst \<alpha>_alt_eq) using sg assms mono_\<alpha> unfolding mono_def
    by (metis \<alpha>_alt_eq order_trans)
qed

context
  fixes x::nat
  assumes pos: "x>0"
begin
interpretation Apnn: f_nat_nat "\<lambda>k. Ackermann k x"
  apply standard subgoal using Ackermann_strict_mono_in_k[OF pos] .
  subgoal using Ackermann_k_x_tends_to_infinity_along_k[OF pos] .
  done

lemma \<beta>_x_Suc_x:
  shows "Apnn.\<beta>\<^sub>f (x + 1) = 0"
proof -
  have "Apnn.\<beta>\<^sub>f (x + 1) < 1"
    apply (rule Apnn.\<beta>\<^sub>f_spec_direct_contrapositive)
     apply (subst Ackermann_base_eq) apply simp
    apply (subst Ackermann_1_eq') using pos by simp
  thus ?thesis by blast
qed

(********************************************)
subsection{* @{term \<alpha>} grows very slowly. In particular, of course, it never grows by more
             than one at a time.*}
(********************************************)

\<comment>\<open>We state this lemma directly in a generalized form that will be useful when
   we later consider the function @{term alphar} introduced by Alstrup et al. \<close>

lemma \<alpha>_grows_one_by_one: "Apnn.\<alpha>\<^sub>f (Suc n) \<le> Suc (Apnn.\<alpha>\<^sub>f n)"
  apply (subst Apnn.\<alpha>\<^sub>f_spec)
  apply (subst Ackermann_step_eq)
  apply simp
proof -
  let ?alpha = "Apnn.\<alpha>\<^sub>f"
  let ?thesis = "Suc n \<le> Ackermann (?alpha n) ((Ackermann (?alpha n) ^^ x) x)"
  let ?f = "Ackermann (?alpha n)"
  have pos': "1\<le>x" using pos by fastforce
  have fact: "?f x \<le> compow x ?f x"
    using funpow_mono2[OF mono_Ackermann[of "(?alpha n)"],
                       of 1 x x x, OF pos' order.refl]
    Ackermann_k_inflationary[of "(?alpha n)"] by auto
  have fact2: "n \<le> Ackermann (?alpha  n) x"
    by (simp add: Apnn.f_\<alpha>\<^sub>f)
  have "Suc n \<le> Ackermann (?alpha n) n"
    by (simp add: Ackermann_k_strictly_inflationary Suc_leI)
  also have "\<dots> \<le> Ackermann (?alpha n) (Ackermann (?alpha n) x)" using fact2
    by (simp add: monoD mono_Ackermann)
  finally show ?thesis using fact mono_Ackermann le_trans unfolding mono_def by blast
qed
end

lemma "\<alpha> (Suc n) \<le> Suc (\<alpha> n)"
  apply (subst \<alpha>_alt_eq)+
  using \<alpha>_grows_one_by_one[OF zero_less_one] .

(********************************************)
subsection{* As soon as @{term n} is at least 4, @{term "\<alpha> n"} is greater than one. *}
(********************************************)

lemma two_le_\<alpha>: assumes "4 \<le> n" shows "2 \<le> \<alpha> n"
  apply (subst \<alpha>_alt_eq)
proof -
  have fact: "Ackermann 1 1 < n" apply (subst Ackermann_1_eq') using assms by fastforce
  show "2 \<le> A1nn.\<alpha>\<^sub>f n"  using A1nn.\<alpha>\<^sub>f_spec_direct_contrapositive[OF fact] by simp
qed

(********************************************)
\<comment>\<open> @{term "\<alpha> n"} is at most @{term "Suc (\<alpha> (Discrete.log n))"}. This gives a weak sense of how
   slowly the function @{term \<alpha>} grows. In fact, the function log* would
   satisfy the same property; yet @{term \<alpha>} grows even more slowly than
   log*.

   This property also shows that @{term "\<alpha> n"} and @{term "\<alpha> (Discrete.log n)"} are
   asymptotically equivalent. This explains why Tarjan and Cormen et al. are
   content with a bound of @{term "\<alpha> n"} for the amortized complexity of union and
   find, even though they could easily obtain @{term "\<alpha> (Discrete.log n)"}. See Exercise
   21.4-6 in Cormen et al. \<close>
(********************************************)

lemma "n \<le> Ackermann (A1nn.\<alpha>\<^sub>f (Discrete.log n)) (Discrete.log n)"
  oops
lemma prove_le_log: assumes "2 ^ k \<le> n" shows "k \<le> Discrete.log n" using assms
  using Discrete.log_le_iff by fastforce

lemma \<alpha>_n_0_\<alpha>_logn:
  assumes "16 \<le> n" shows "\<alpha> n \<le> Suc (\<alpha> (Discrete.log n))"
  apply (subst \<alpha>_alt_eq)
  apply (rule A1nn.\<alpha>\<^sub>f_spec_reciprocal)
  apply (subst Ackermann_step_eq)
  apply simp
  apply (subst One_nat_def[symmetric])
  apply (subst \<alpha>_alt_eq)+
  apply (cases "(A1nn.\<alpha>\<^sub>f (Discrete.log n)) \<ge> 2" )
  proof goal_cases
    let ?log = "Discrete.log"
    case 1
    have "n \<le> Ackermann 2 (?log n)" using Ackermann_2_log_lower_bound[of n] .
    also have "\<dots> \<le> Ackermann 2 (Ackermann (A1nn.\<alpha>\<^sub>f (?log n)) 1)"
      using A1nn.f_\<alpha>\<^sub>f[of "?log n"] mono_Ackermann unfolding mono_def by blast
    also have "\<dots> \<le> Ackermann (A1nn.\<alpha>\<^sub>f (?log n)) (Ackermann (A1nn.\<alpha>\<^sub>f (?log n)) 1)"
      using 1(1) mono_Ackermann_in_k[of "(Ackermann (A1nn.\<alpha>\<^sub>f (?log n)) 1)"] two_le_\<alpha>
      unfolding mono_def
      by (simp add: \<alpha>_alt_eq)
    finally show ?case .
  next
    case 2
    have 3: "4 \<le> Discrete.log n " using assms by (simp add: prove_le_log)
    have "2 \<le> A1nn.\<alpha>\<^sub>f (Discrete.log n)" using two_le_\<alpha>[OF 3]
      by (subst (asm) \<alpha>_alt_eq)
    then show ?case using 2 by blast
  qed

(********************************************)
subsection {*alphar*}

\<comment>\<open> Alstrup et al. define the function @{term alphar} as follows (page 17).
   Note that their definition of @{term Ackermann} is not the same as ours -- they
   index k from 1 and up, whereas, following Tarjan, we index k
   from 0 and up -- so our definition of alphar looks different. \<close>
(********************************************)

context
  fixes r::nat
  assumes pos: "r>0"
begin
definition alphar where
  "alphar n \<equiv> Suc (Least (\<lambda>k. Ackermann k r \<ge> Suc n))"

\<comment>\<open>abbreviation defalphar where "defalphar  \<equiv> \<lambda>k. Ackermann k r"\<close>

interpretation pnn: f_nat_nat "\<lambda>k. Ackermann k r"
  apply standard subgoal using Ackermann_strict_mono_in_k[OF pos] .
  subgoal using Ackermann_k_x_tends_to_infinity_along_k[OF pos] .
  done

definition prealphar where "prealphar n \<equiv> pnn.\<alpha>\<^sub>f (Suc n)"

definition alphar' where "alphar' n \<equiv> Suc (prealphar n)"

lemma alphar_alt_eq: "alphar = alphar'"
  unfolding alphar_def alphar'_def prealphar_def pnn.\<alpha>\<^sub>f_def by blast

subsubsection{* @{term "alphar n"} is positive.*}

lemma alphar_pos: "0 < alphar n"
  unfolding alphar_def by simp

(********************************************)
subsubsection{* @{term "alphar n"} is monotonic.*}
(********************************************)

lemma mono_alphar: "mono alphar"
  apply (subst alphar_alt_eq)
  unfolding alphar'_def prealphar_def
  using pnn.\<alpha>\<^sub>f_mono unfolding mono_def by simp

(********************************************)
subsubsection{* Like @{term \<alpha>}, @{term alphar} grows at most by one at a time. *}
(********************************************)

lemma alphar_grows_one_by_one:
  "alphar (Suc n) \<le> Suc (alphar n)"
  apply (subst alphar_alt_eq)+
  unfolding alphar'_def prealphar_def
  using \<alpha>_grows_one_by_one[OF pos] by auto

(********************************************)
\<comment>\<open> If @{term r} is 1, then @{term "alphar n"} is as follows. \<close>
(********************************************)

lemma alphar_one: assumes "r = 1" shows "alphar n  = Suc (\<alpha> (Suc n))"
  apply (subst alphar_alt_eq)
  apply (subst \<alpha>_alt_eq)
  unfolding alphar'_def prealphar_def pnn.\<alpha>\<^sub>f_def A1nn.\<alpha>\<^sub>f_def using assms by blast

(********************************************)
\<comment>\<open> @{term "alphar r"} is 1. (Exploited on page 18.) \<close>
(********************************************)

lemma alphar_r:
  "alphar r = 1"
  apply (subst alphar_alt_eq)
  unfolding alphar'_def
proof -
  have "prealphar r \<le> 0" unfolding prealphar_def
    apply (rule  pnn.\<alpha>\<^sub>f_spec_reciprocal)
    apply (subst Ackermann_base_eq) by simp
  thus "Suc (local.prealphar r) = 1" by force
qed

(********************************************)
\<comment>\<open> If @{term r} is less than @{term n}, then @{term "alphar n"} is at least two (page 17). \<close>
(********************************************)

lemma alphar_geq_two: assumes "r < n" shows "1 < alphar n"
  apply (subst alphar_alt_eq)
  unfolding alphar'_def
  apply simp
  unfolding prealphar_def
  apply (rule pnn.\<alpha>\<^sub>f_spec_direct_contrapositive)
  apply (subst Ackermann_base_eq) using assms by simp

(********************************************)
\<comment>\<open> @{term "Ackermann (prealphar n) r"} is greater than @{term n} (page 17). \<close>
(********************************************)

lemma Ackermann_prealphar_gt: "n < Ackermann (prealphar n) r"
proof -
  have "Suc n \<le> Ackermann (prealphar n) r" using pnn.f_\<alpha>\<^sub>f unfolding prealphar_def by simp
  thus ?thesis by simp
qed

end

end


(*<*)
theory "termination" imports examples begin
(*>*)

text\<open>
When a function~$f$ is defined via \isacommand{recdef}, Isabelle tries to prove
its termination with the help of the user-supplied measure.  Each of the examples
above is simple enough that Isabelle can automatically prove that the
argument's measure decreases in each recursive call. As a result,
$f$\<open>.simps\<close> will contain the defining equations (or variants derived
from them) as theorems. For example, look (via \isacommand{thm}) at
@{thm[source]sep.simps} and @{thm[source]sep1.simps} to see that they define
the same function. What is more, those equations are automatically declared as
simplification rules.

Isabelle may fail to prove the termination condition for some
recursive call.  Let us try to define Quicksort:\<close>

consts qs :: "nat list \<Rightarrow> nat list"
recdef(*<*)(permissive)(*>*) qs "measure length"
 "qs [] = []"
 "qs(x#xs) = qs(filter (\<lambda>y. y\<le>x) xs) @ [x] @ qs(filter (\<lambda>y. x<y) xs)"

text\<open>\noindent where @{term filter} is predefined and @{term"filter P xs"}
is the list of elements of @{term xs} satisfying @{term P}.
This definition of @{term qs} fails, and Isabelle prints an error message
showing you what it was unable to prove:
@{text[display]"length (filter ... xs) < Suc (length xs)"}
We can either prove this as a separate lemma, or try to figure out which
existing lemmas may help. We opt for the second alternative. The theory of
lists contains the simplification rule @{thm length_filter_le[no_vars]},
which is what we need, provided we turn \mbox{\<open>< Suc\<close>}
into
\<open>\<le>\<close> so that the rule applies. Lemma
@{thm[source]less_Suc_eq_le} does just that: @{thm less_Suc_eq_le[no_vars]}.

Now we retry the above definition but supply the lemma(s) just found (or
proved). Because \isacommand{recdef}'s termination prover involves
simplification, we include in our second attempt a hint: the
\attrdx{recdef_simp} attribute says to use @{thm[source]less_Suc_eq_le} as a
simplification rule.\cmmdx{hints}\<close>

(*<*)global consts qs :: "nat list \<Rightarrow> nat list" (*>*)
recdef qs "measure length"
 "qs [] = []"
 "qs(x#xs) = qs(filter (\<lambda>y. y\<le>x) xs) @ [x] @ qs(filter (\<lambda>y. x<y) xs)"
(hints recdef_simp: less_Suc_eq_le)
(*<*)local(*>*)
text\<open>\noindent
This time everything works fine. Now @{thm[source]qs.simps} contains precisely
the stated recursion equations for \<open>qs\<close> and they have become
simplification rules.
Thus we can automatically prove results such as this one:
\<close>

theorem "qs[2,3,0] = qs[3,0,2]"
apply(simp)
done

text\<open>\noindent
More exciting theorems require induction, which is discussed below.

If the termination proof requires a lemma that is of general use, you can
turn it permanently into a simplification rule, in which case the above
\isacommand{hint} is not necessary. But in the case of
@{thm[source]less_Suc_eq_le} this would be of dubious value.
\<close>
(*<*)
end
(*>*)


(* Title: Examples/SML_Relativization/Algebra/SML_Semigroups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about semigroups\<close>
theory SML_Semigroups
  imports
    "../SML_Introduction"
    "../Foundations/Lifting_Set_Ext"
begin

subsection\<open>Simple semigroups\<close>

subsubsection\<open>Definitions and common properties\<close>

locale semigroup_ow =
  fixes U :: "'ag set" and f :: "['ag, 'ag] \<Rightarrow> 'ag" (infixl \<open>\<^bold>*\<^sub>o\<^sub>w\<close> 70)
  assumes f_closed: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<^bold>*\<^sub>o\<^sub>w b \<in> U"
  assumes assoc: "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a \<^bold>*\<^sub>o\<^sub>w b \<^bold>*\<^sub>o\<^sub>w c = a \<^bold>*\<^sub>o\<^sub>w (b \<^bold>*\<^sub>o\<^sub>w c)"
begin

notation f (infixl \<open>\<^bold>*\<^sub>o\<^sub>w\<close> 70)

lemma f_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x \<^bold>*\<^sub>o\<^sub>w y \<in> U" by (simp add: f_closed)

tts_register_sbts \<open>(\<^bold>*\<^sub>o\<^sub>w)\<close> | U by (rule tts_AA_A_transfer[OF f_closed])

end

lemma semigroup_ow: "semigroup = semigroup_ow UNIV"
  unfolding semigroup_def semigroup_ow_def by simp

locale plus_ow =
  fixes U :: "'ag set" and plus :: "['ag, 'ag] \<Rightarrow> 'ag" (infixl \<open>+\<^sub>o\<^sub>w\<close> 65)
  assumes plus_closed[simp, intro]: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b \<in> U"
begin

notation plus (infixl \<open>+\<^sub>o\<^sub>w\<close> 65)

lemma plus_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x +\<^sub>o\<^sub>w y \<in> U" by simp

tts_register_sbts \<open>(+\<^sub>o\<^sub>w)\<close> | U  by (rule tts_AA_A_transfer[OF plus_closed])

end

locale times_ow =
  fixes U :: "'ag set" and times :: "['ag, 'ag] \<Rightarrow> 'ag" (infixl \<open>*\<^sub>o\<^sub>w\<close> 70)
  assumes times_closed[simp, intro]: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b \<in> U"
begin

notation times (infixl \<open>*\<^sub>o\<^sub>w\<close> 70)

lemma times_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x *\<^sub>o\<^sub>w y \<in> U" by simp

tts_register_sbts \<open>(*\<^sub>o\<^sub>w)\<close> | U  by (rule tts_AA_A_transfer[OF times_closed])

end

locale semigroup_add_ow = plus_ow U plus
  for U :: "'ag set" and plus +
  assumes plus_assoc:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w c = a +\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c)"
begin

sublocale add: semigroup_ow U \<open>(+\<^sub>o\<^sub>w)\<close>
  by unfold_locales (auto simp: plus_assoc)

end

lemma semigroup_add_ow: "class.semigroup_add = semigroup_add_ow UNIV"
  unfolding
    class.semigroup_add_def semigroup_add_ow_def
    semigroup_add_ow_axioms_def plus_ow_def
  by simp

locale semigroup_mult_ow = times_ow U times
  for U :: "'ag set" and times +
  assumes mult_assoc:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w (b *\<^sub>o\<^sub>w c)"
begin

sublocale mult: semigroup_ow U \<open>(*\<^sub>o\<^sub>w)\<close>
  by unfold_locales (auto simp: times_closed' mult_assoc)

end

lemma semigroup_mult_ow: "class.semigroup_mult = semigroup_mult_ow UNIV"
  unfolding
    class.semigroup_mult_def semigroup_mult_ow_def
    semigroup_mult_ow_axioms_def times_ow_def
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma semigroup_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (semigroup_ow (Collect (Domainp A))) semigroup"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_ow = "semigroup_ow (Collect (Domainp A))"
  let ?rf_UNIV =
    "(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))"
  have "?P ?semigroup_ow (\<lambda>f. ?rf_UNIV f \<and> semigroup f)"
    unfolding semigroup_ow_def semigroup_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (semigroup_add_ow (Collect (Domainp A))) class.semigroup_add"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_add_ow = "(\<lambda>f. semigroup_add_ow (Collect (Domainp A)) f)"
  let ?rf_UNIV =
    "(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))"
  have "?P ?semigroup_add_ow (\<lambda>f. ?rf_UNIV f \<and> class.semigroup_add f)"
    unfolding
      semigroup_add_ow_def class.semigroup_add_def
      semigroup_add_ow_axioms_def plus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

lemma semigroup_mult_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (semigroup_mult_ow (Collect (Domainp A))) class.semigroup_mult"
proof -
  let ?P = "((A ===> A ===> A) ===> (=))"
  let ?semigroup_mult_ow = "(\<lambda>f. semigroup_mult_ow (Collect (Domainp A)) f)"
  let ?rf_UNIV =
    "(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))"
  have "?P ?semigroup_mult_ow (\<lambda>f. ?rf_UNIV f \<and> class.semigroup_mult f)"
    unfolding
      semigroup_mult_ow_def class.semigroup_mult_def
      semigroup_mult_ow_axioms_def times_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

end

subsection\<open>Cancellative semigroups\<close>

subsubsection\<open>Definitions and common properties\<close>

locale cancel_semigroup_add_ow = semigroup_add_ow U plus
  for U :: "'ag set" and plus +
  assumes add_left_imp_eq:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U; a +\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w c \<rbrakk> \<Longrightarrow> b = c"
  assumes add_right_imp_eq:
    "\<lbrakk> b \<in> U; a \<in> U; c \<in> U; b +\<^sub>o\<^sub>w a = c +\<^sub>o\<^sub>w a \<rbrakk> \<Longrightarrow> b = c"

lemma cancel_semigroup_add_ow:
  "class.cancel_semigroup_add = cancel_semigroup_add_ow UNIV"
  unfolding
    class.cancel_semigroup_add_def cancel_semigroup_add_ow_def
    cancel_semigroup_add_ow_axioms_def class.cancel_semigroup_add_axioms_def
    semigroup_add_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma cancel_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (cancel_semigroup_add_ow (Collect (Domainp A)))
      class.cancel_semigroup_add"
  unfolding cancel_semigroup_add_ow_def class.cancel_semigroup_add_def
  unfolding
    cancel_semigroup_add_ow_axioms_def class.cancel_semigroup_add_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

subsubsection\<open>Relativization\<close>

context cancel_semigroup_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_semigroup_add_ow_axioms
  eliminating through simp
begin

tts_lemma add_right_cancel:
  assumes "b \<in> U" and "a \<in> U" and "c \<in> U"
  shows "(b +\<^sub>o\<^sub>w a = c +\<^sub>o\<^sub>w a) = (b = c)"
  is cancel_semigroup_add_class.add_right_cancel.

tts_lemma add_left_cancel:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "(a +\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w c) = (b = c)"
  is cancel_semigroup_add_class.add_left_cancel.

tts_lemma bij_betw_add:
  assumes "a \<in> U" and "A \<subseteq> U" and "B \<subseteq> U"
  shows "bij_betw ((+\<^sub>o\<^sub>w) a) A B = ((+\<^sub>o\<^sub>w) a ` A = B)"
    is cancel_semigroup_add_class.bij_betw_add.

tts_lemma inj_on_add:
  assumes "a \<in> U" and "A \<subseteq> U"
  shows "inj_on ((+\<^sub>o\<^sub>w) a) A"
    is cancel_semigroup_add_class.inj_on_add.

tts_lemma inj_on_add':
  assumes "a \<in> U" and "A \<subseteq> U"
  shows "inj_on (\<lambda>b. b +\<^sub>o\<^sub>w a) A"
    is cancel_semigroup_add_class.inj_on_add'.

end

end

subsection\<open>Commutative semigroups\<close>

subsubsection\<open>Definitions and common properties\<close>

locale abel_semigroup_ow =
  semigroup_ow U f for U :: "'ag set" and f +
  assumes commute: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a \<^bold>*\<^sub>o\<^sub>w b = b \<^bold>*\<^sub>o\<^sub>w a"
begin

lemma fun_left_comm:
  assumes "x \<in> U" and "y \<in> U" and "z \<in> U"
  shows "y \<^bold>*\<^sub>o\<^sub>w (x \<^bold>*\<^sub>o\<^sub>w z) = x \<^bold>*\<^sub>o\<^sub>w (y \<^bold>*\<^sub>o\<^sub>w z)"
  using assms by (metis assoc commute)

end

lemma abel_semigroup_ow: "abel_semigroup = abel_semigroup_ow UNIV"
  unfolding
    abel_semigroup_def abel_semigroup_ow_def
    abel_semigroup_axioms_def abel_semigroup_ow_axioms_def
    semigroup_ow
  by simp

locale ab_semigroup_add_ow =
  semigroup_add_ow U plus for U :: "'ag set" and plus +
  assumes add_commute: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b = b +\<^sub>o\<^sub>w a"
begin

sublocale add: abel_semigroup_ow U \<open>(+\<^sub>o\<^sub>w)\<close>
  by unfold_locales (rule add_commute)

end

lemma ab_semigroup_add_ow: "class.ab_semigroup_add = ab_semigroup_add_ow UNIV"
  unfolding
    class.ab_semigroup_add_def ab_semigroup_add_ow_def
    class.ab_semigroup_add_axioms_def ab_semigroup_add_ow_axioms_def
    semigroup_add_ow
  by simp

locale ab_semigroup_mult_ow =
  semigroup_mult_ow U times for U :: "'ag set" and times+
  assumes mult_commute: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b = b *\<^sub>o\<^sub>w a"
begin

sublocale mult: abel_semigroup_ow U \<open>(*\<^sub>o\<^sub>w)\<close>
  by unfold_locales (rule mult_commute)

end

lemma ab_semigroup_mult_ow:
  "class.ab_semigroup_mult = ab_semigroup_mult_ow UNIV"
  unfolding
    class.ab_semigroup_mult_def ab_semigroup_mult_ow_def
    class.ab_semigroup_mult_axioms_def ab_semigroup_mult_ow_axioms_def
    semigroup_mult_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma abel_semigroup_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (abel_semigroup_ow (Collect (Domainp A))) abel_semigroup"
  unfolding
    abel_semigroup_ow_def abel_semigroup_def
    abel_semigroup_ow_axioms_def abel_semigroup_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  unfolding Ball_def by simp

lemma ab_semigroup_add_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (ab_semigroup_add_ow (Collect (Domainp A))) class.ab_semigroup_add"
  unfolding
    ab_semigroup_add_ow_def class.ab_semigroup_add_def
    ab_semigroup_add_ow_axioms_def class.ab_semigroup_add_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

lemma ab_semigroup_mult_transfer[transfer_rule]:
  assumes[transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (=))
      (ab_semigroup_mult_ow (Collect (Domainp A))) class.ab_semigroup_mult"
  unfolding ab_semigroup_mult_ow_def class.ab_semigroup_mult_def
  unfolding ab_semigroup_mult_ow_axioms_def class.ab_semigroup_mult_axioms_def
  apply transfer_prover_start
  apply transfer_step+
  by simp

end

subsubsection\<open>Relativization\<close>

context abel_semigroup_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting abel_semigroup_ow_axioms
  eliminating through simp
begin

tts_lemma left_commute:
  assumes "b \<in> U" and "a \<in> U" and "c \<in> U"
  shows "b \<^bold>*\<^sub>o\<^sub>w (a \<^bold>*\<^sub>o\<^sub>w c) = a \<^bold>*\<^sub>o\<^sub>w (b \<^bold>*\<^sub>o\<^sub>w c)"
    is abel_semigroup.left_commute.

end

end

context ab_semigroup_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ab_semigroup_add_ow_axioms
  eliminating through simp
begin

tts_lemma add_ac:
  shows "\<lbrakk>a \<in> U; b \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w c = a +\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c)"
    is ab_semigroup_add_class.add_ac(1)
    and "\<lbrakk>a \<in> U; b \<in> U\<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w b = b +\<^sub>o\<^sub>w a"
    is ab_semigroup_add_class.add_ac(2)
    and "\<lbrakk>b \<in> U; a \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> b +\<^sub>o\<^sub>w (a +\<^sub>o\<^sub>w c) = a +\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c)"
    is ab_semigroup_add_class.add_ac(3).

end

end

context ab_semigroup_mult_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ab_semigroup_mult_ow_axioms
  eliminating through simp
begin

tts_lemma mult_ac:
  shows "\<lbrakk>a \<in> U; b \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b *\<^sub>o\<^sub>w c = a *\<^sub>o\<^sub>w (b *\<^sub>o\<^sub>w c)"
    is ab_semigroup_mult_class.mult_ac(1)
    and "\<lbrakk>a \<in> U; b \<in> U\<rbrakk> \<Longrightarrow> a *\<^sub>o\<^sub>w b = b *\<^sub>o\<^sub>w a"
    is ab_semigroup_mult_class.mult_ac(2)
    and "\<lbrakk>b \<in> U; a \<in> U; c \<in> U\<rbrakk> \<Longrightarrow> b *\<^sub>o\<^sub>w (a *\<^sub>o\<^sub>w c) = a *\<^sub>o\<^sub>w (b *\<^sub>o\<^sub>w c)"
    is ab_semigroup_mult_class.mult_ac(3).

end

end

subsection\<open>Cancellative commutative semigroups\<close>

subsubsection\<open>Definitions and common properties\<close>

locale minus_ow =
  fixes U :: "'ag set" and minus :: "['ag, 'ag] \<Rightarrow> 'ag" (infixl \<open>-\<^sub>o\<^sub>w\<close> 65)
  assumes minus_closed[simp,intro]: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a -\<^sub>o\<^sub>w b \<in> U"
begin

notation minus (infixl \<open>-\<^sub>o\<^sub>w\<close> 65)

lemma minus_closed'[simp]: "\<forall>x\<in>U. \<forall>y\<in>U. x -\<^sub>o\<^sub>w y \<in> U" by simp

tts_register_sbts \<open>(-\<^sub>o\<^sub>w)\<close> | U by (rule tts_AA_A_transfer[OF minus_closed])

end

locale cancel_ab_semigroup_add_ow =
  ab_semigroup_add_ow U plus + minus_ow U minus
  for U :: "'ag set" and plus minus +
  assumes add_diff_cancel_left'[simp]:
    "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> (a +\<^sub>o\<^sub>w b) -\<^sub>o\<^sub>w a = b"
  assumes diff_diff_add:
    "\<lbrakk> a \<in> U; b \<in> U; c \<in> U \<rbrakk> \<Longrightarrow> a -\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w c = a -\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c)"
begin

sublocale cancel_semigroup_add_ow U \<open>(+\<^sub>o\<^sub>w)\<close>
  apply unfold_locales
  subgoal by (metis add_diff_cancel_left')
  subgoal by (metis add.commute add_diff_cancel_left')
  done

end

lemma cancel_ab_semigroup_add_ow:
  "class.cancel_ab_semigroup_add = cancel_ab_semigroup_add_ow UNIV"
  unfolding
    class.cancel_ab_semigroup_add_def
    cancel_ab_semigroup_add_ow_def
    class.cancel_ab_semigroup_add_axioms_def
    cancel_ab_semigroup_add_ow_axioms_def
    minus_ow_def
    ab_semigroup_add_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma cancel_ab_semigroup_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=))
      (cancel_ab_semigroup_add_ow (Collect (Domainp A)))
      class.cancel_ab_semigroup_add"
proof -
  let ?P = "((A ===> A ===> A) ===> (A ===> A ===> A) ===> (=))"
  let ?cancel_ab_semigroup_add_ow =
    "cancel_ab_semigroup_add_ow (Collect (Domainp A))"
  let ?rf_UNIV =
    "(\<lambda>f::['b, 'b] \<Rightarrow> 'b. (\<forall>x y. x \<in> UNIV \<longrightarrow> y \<in> UNIV \<longrightarrow> f x y \<in> UNIV))"
  have
    "?P
      ?cancel_ab_semigroup_add_ow
      (\<lambda>f fi. ?rf_UNIV fi \<and> class.cancel_ab_semigroup_add f fi)"
    unfolding
      class.cancel_ab_semigroup_add_def
      cancel_ab_semigroup_add_ow_def
      class.cancel_ab_semigroup_add_axioms_def
      cancel_ab_semigroup_add_ow_axioms_def
      minus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    unfolding Ball_def by auto
  thus ?thesis by simp
qed

end

subsubsection\<open>Relativization\<close>

context cancel_ab_semigroup_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting cancel_ab_semigroup_add_ow_axioms
  eliminating through simp
begin

tts_lemma add_diff_cancel_right':
  assumes "a \<in> U" and "b \<in> U"
  shows "a +\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w b = a"
    is cancel_ab_semigroup_add_class.add_diff_cancel_right'.

tts_lemma add_diff_cancel_right:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U"
  shows "a +\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = a -\<^sub>o\<^sub>w b"
    is cancel_ab_semigroup_add_class.add_diff_cancel_right.

tts_lemma add_diff_cancel_left:
  assumes "c \<in> U" and "a \<in> U" and "b \<in> U"
  shows "c +\<^sub>o\<^sub>w a -\<^sub>o\<^sub>w (c +\<^sub>o\<^sub>w b) = a -\<^sub>o\<^sub>w b"
    is cancel_ab_semigroup_add_class.add_diff_cancel_left.

tts_lemma diff_right_commute:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U"
  shows "a -\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w b = a -\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w c"
    is cancel_ab_semigroup_add_class.diff_right_commute.

tts_lemma diff_diff_eq:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a -\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w c = a -\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c)"
    is diff_diff_eq.

end

end

text\<open>\newpage\<close>

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_list_PairUnpair
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun unpair :: "(('t, 't) pair) list => 't list" where
  "unpair (nil2) = nil2"
| "unpair (cons2 (pair2 z y2) xys) =
     cons2 z (cons2 y2 (unpair xys))"

fun pairs :: "'t list => (('t, 't) pair) list" where
  "pairs (nil2) = nil2"
| "pairs (cons2 y (nil2)) = nil2"
| "pairs (cons2 y (cons2 y2 xs)) = cons2 (pair2 y y2) (pairs xs)"

fun length :: "'a list => int" where
  "length (nil2) = 0"
| "length (cons2 y l) = 1 + (length l)"

theorem property0 :
  "((let eta :: int = length xs
     in ((let md :: int = eta mod 2
          in (if
                (((if (eta = 0) then 0 else (if eta <= 0 then 0 - 1 else 1)) =
                    (if 2 <= 0 then 0 - (0 - 1) else 0 - 1)) &
                   (md ~= 0))
                then
                md - 2
                else
                md)) =
           0)) ==>
      ((unpair (pairs xs)) = xs))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_BSortCount
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun le :: "Nat => Nat => bool" where
"le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
"sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "Nat list => Nat list => Nat list" where
"pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "Nat list => Nat list => Nat list" where
"stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
         and odds :: "'a list => 'a list" where
"evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
"count y (nil2) = Z"
| "count y (cons2 z2 ys) =
     (if (y = z2) then plus (S Z) (count y ys) else count y ys)"

(*fun did not finish the proof*)
function bmerge :: "Nat list => Nat list => Nat list" where
"bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: Nat list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "Nat list => Nat list" where
"bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "((count y (bsort xs)) = (count y xs))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_nat_NStoogeSortIsSort
  imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun reverse :: "'a list => 'a list" where
  "reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) z = z"
| "plus (S z2) z = S (plus z2 z)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

(*fun did not finish the proof*)
function third :: "Nat => Nat" where
  "third y =
   (if (y = (S (S Z))) then Z else
      (if (y = (S Z)) then Z else
         (case y of
            Z => Z
            | S z => plus (S Z) (third (minus y (S (S (S Z))))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun sort2 :: "Nat => Nat => Nat list" where
  "sort2 y z =
   (if le y z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun take :: "Nat => 'a list => 'a list" where
  "take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun insert :: "Nat => Nat list => Nat list" where
  "insert y (nil2) = cons2 y (nil2)"
| "insert y (cons2 z2 xs) =
     (if le y z2 then cons2 y (cons2 z2 xs) else
        cons2 z2 (insert y xs))"

fun isort :: "Nat list => Nat list" where
  "isort (nil2) = nil2"
| "isort (cons2 z xs) = insert z (isort xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) pair" where
  "splitAt y z = pair2 (take y z) (drop y z)"

function nstooge1sort2 :: "Nat list => Nat list"
  and nstoogesort :: "Nat list => Nat list"
  and nstooge1sort1 :: "Nat list => Nat list" where
  "nstooge1sort2 y =
   (case splitAt (third (length y)) (reverse y) of
      pair2 ys2 zs2 => x (nstoogesort zs2) (reverse ys2))"
| "nstoogesort (nil2) = nil2"
| "nstoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "nstoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "nstoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     nstooge1sort2
       (nstooge1sort1 (nstooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "nstooge1sort1 y =
     (case splitAt (third (length y)) y of
        pair2 ys2 zs1 => x ys2 (nstoogesort zs1))"
  by pat_completeness auto

theorem property0 :
  "((nstoogesort xs) = (isort xs))"
  oops

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_int_left_distrib
  imports "../../Test_Base"
begin

datatype Sign = Pos | Neg

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Integer" where
  "toInteger (Pos) y = P y"
| "toInteger (Neg) (Z) = P Z"
| "toInteger (Neg) (S z) = N z"

fun sign :: "Integer => Sign" where
  "sign (P y) = Pos"
| "sign (N z) = Neg"

fun pred :: "Nat => Nat" where
  "pred (S y) = y"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun times2 :: "Nat => Nat => Nat" where
  "times2 (Z) y = Z"
| "times2 (S z) y = plus y (times2 z y)"

fun opposite :: "Sign => Sign" where
  "opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
  "timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun absVal :: "Integer => Nat" where
  "absVal (P n) = n"
| "absVal (N m) = plus (S Z) m"

fun times :: "Integer => Integer => Integer" where
  "times x y =
   toInteger
     (timesSign (sign x) (sign y)) (times2 (absVal x) (absVal y))"

fun t2 :: "Nat => Nat => Integer" where
  "t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus2 :: "Integer => Integer => Integer" where
  "plus2 (P m) (P n) = P (plus m n)"
| "plus2 (P m) (N o2) = t2 m (plus (S Z) o2)"
| "plus2 (N m2) (P n2) = t2 n2 (plus (S Z) m2)"
| "plus2 (N m2) (N n3) = N (plus (plus (S Z) m2) n3)"

theorem property0 :
  "((times x (plus2 y z)) = (plus2 (times x y) (times x z)))"
  oops

end