(*  Title:      HOL/Analysis/Bounded_Linear_Function.thy
    Author:     Fabian Immler, TU München
*)

section \<open>Bounded Linear Function\<close>

theory Bounded_Linear_Function
imports
  Topology_Euclidean_Space
  Operator_Norm
begin

subsection \<open>Intro rules for @{term bounded_linear}\<close>

named_theorems bounded_linear_intros

lemma onorm_inner_left:
  assumes "bounded_linear r"
  shows "onorm (\<lambda>x. r x \<bullet> f) \<le> onorm r * norm f"
proof (rule onorm_bound)
  fix x
  have "norm (r x \<bullet> f) \<le> norm (r x) * norm f"
    by (simp add: Cauchy_Schwarz_ineq2)
  also have "\<dots> \<le> onorm r * norm x * norm f"
    by (intro mult_right_mono onorm assms norm_ge_zero)
  finally show "norm (r x \<bullet> f) \<le> onorm r * norm f * norm x"
    by (simp add: ac_simps)
qed (intro mult_nonneg_nonneg norm_ge_zero onorm_pos_le assms)

lemma onorm_inner_right:
  assumes "bounded_linear r"
  shows "onorm (\<lambda>x. f \<bullet> r x) \<le> norm f * onorm r"
  apply (subst inner_commute)
  apply (rule onorm_inner_left[OF assms, THEN order_trans])
  apply simp
  done

lemmas [bounded_linear_intros] =
  bounded_linear_zero
  bounded_linear_add
  bounded_linear_const_mult
  bounded_linear_mult_const
  bounded_linear_scaleR_const
  bounded_linear_const_scaleR
  bounded_linear_ident
  bounded_linear_sum
  bounded_linear_Pair
  bounded_linear_sub
  bounded_linear_fst_comp
  bounded_linear_snd_comp
  bounded_linear_inner_left_comp
  bounded_linear_inner_right_comp

subsection \<open>declaration of derivative/continuous/tendsto introduction rules for bounded linear functions\<close>

attribute_setup bounded_linear =
  \<open>Scan.succeed (Thm.declaration_attribute (fn thm =>
    fold (fn (r, s) => Named_Theorems.add_thm s (thm RS r))
      [
        (@{thm bounded_linear.has_derivative}, @{named_theorems derivative_intros}),
        (@{thm bounded_linear.tendsto}, @{named_theorems tendsto_intros}),
        (@{thm bounded_linear.continuous}, @{named_theorems continuous_intros}),
        (@{thm bounded_linear.continuous_on}, @{named_theorems continuous_intros}),
        (@{thm bounded_linear.uniformly_continuous_on}, @{named_theorems continuous_intros}),
        (@{thm bounded_linear_compose}, @{named_theorems bounded_linear_intros})
      ]))\<close>

attribute_setup bounded_bilinear =
  \<open>Scan.succeed (Thm.declaration_attribute (fn thm =>
    fold (fn (r, s) => Named_Theorems.add_thm s (thm RS r))
      [
        (@{thm bounded_bilinear.FDERIV}, @{named_theorems derivative_intros}),
        (@{thm bounded_bilinear.tendsto}, @{named_theorems tendsto_intros}),
        (@{thm bounded_bilinear.continuous}, @{named_theorems continuous_intros}),
        (@{thm bounded_bilinear.continuous_on}, @{named_theorems continuous_intros}),
        (@{thm bounded_linear_compose[OF bounded_bilinear.bounded_linear_left]},
          @{named_theorems bounded_linear_intros}),
        (@{thm bounded_linear_compose[OF bounded_bilinear.bounded_linear_right]},
          @{named_theorems bounded_linear_intros}),
        (@{thm bounded_linear.uniformly_continuous_on[OF bounded_bilinear.bounded_linear_left]},
          @{named_theorems continuous_intros}),
        (@{thm bounded_linear.uniformly_continuous_on[OF bounded_bilinear.bounded_linear_right]},
          @{named_theorems continuous_intros})
      ]))\<close>

subsection \<open>type of bounded linear functions\<close>

typedef (overloaded) ('a, 'b) blinfun ("(_ \<Rightarrow>\<^sub>L /_)" [22, 21] 21) =
  "{f::'a::real_normed_vector\<Rightarrow>'b::real_normed_vector. bounded_linear f}"
  morphisms blinfun_apply Blinfun
  by (blast intro: bounded_linear_intros)

declare [[coercion
    "blinfun_apply :: ('a::real_normed_vector \<Rightarrow>\<^sub>L'b::real_normed_vector) \<Rightarrow> 'a \<Rightarrow> 'b"]]

lemma bounded_linear_blinfun_apply[bounded_linear_intros]:
  "bounded_linear g \<Longrightarrow> bounded_linear (\<lambda>x. blinfun_apply f (g x))"
  by (metis blinfun_apply mem_Collect_eq bounded_linear_compose)

setup_lifting type_definition_blinfun

lemma blinfun_eqI: "(\<And>i. blinfun_apply x i = blinfun_apply y i) \<Longrightarrow> x = y"
  by transfer auto

lemma bounded_linear_Blinfun_apply: "bounded_linear f \<Longrightarrow> blinfun_apply (Blinfun f) = f"
  by (auto simp: Blinfun_inverse)

subsection \<open>type class instantiations\<close>

instantiation blinfun :: (real_normed_vector, real_normed_vector) real_normed_vector
begin

lift_definition norm_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> real" is onorm .

lift_definition minus_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  is "\<lambda>f g x. f x - g x"
  by (rule bounded_linear_sub)

definition dist_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> real"
  where "dist_blinfun a b = norm (a - b)"

definition [code del]:
  "(uniformity :: (('a \<Rightarrow>\<^sub>L 'b) \<times> ('a \<Rightarrow>\<^sub>L 'b)) filter) = (INF e:{0 <..}. principal {(x, y). dist x y < e})"

definition open_blinfun :: "('a \<Rightarrow>\<^sub>L 'b) set \<Rightarrow> bool"
  where [code del]: "open_blinfun S = (\<forall>x\<in>S. \<forall>\<^sub>F (x', y) in uniformity. x' = x \<longrightarrow> y \<in> S)"

lift_definition uminus_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b" is "\<lambda>f x. - f x"
  by (rule bounded_linear_minus)

lift_definition zero_blinfun :: "'a \<Rightarrow>\<^sub>L 'b" is "\<lambda>x. 0"
  by (rule bounded_linear_zero)

lift_definition plus_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  is "\<lambda>f g x. f x + g x"
  by (metis bounded_linear_add)

lift_definition scaleR_blinfun::"real \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b" is "\<lambda>r f x. r *\<^sub>R f x"
  by (metis bounded_linear_compose bounded_linear_scaleR_right)

definition sgn_blinfun :: "'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  where "sgn_blinfun x = scaleR (inverse (norm x)) x"

instance
  apply standard
  unfolding dist_blinfun_def open_blinfun_def sgn_blinfun_def uniformity_blinfun_def
  apply (rule refl | (transfer, force simp: onorm_triangle onorm_scaleR onorm_eq_0 algebra_simps))+
  done

end

declare uniformity_Abort[where 'a="('a :: real_normed_vector) \<Rightarrow>\<^sub>L ('b :: real_normed_vector)", code]

lemma norm_blinfun_eqI:
  assumes "n \<le> norm (blinfun_apply f x) / norm x"
  assumes "\<And>x. norm (blinfun_apply f x) \<le> n * norm x"
  assumes "0 \<le> n"
  shows "norm f = n"
  by (auto simp: norm_blinfun_def
    intro!: antisym onorm_bound assms order_trans[OF _ le_onorm]
    bounded_linear_intros)

lemma norm_blinfun: "norm (blinfun_apply f x) \<le> norm f * norm x"
  by transfer (rule onorm)

lemma norm_blinfun_bound: "0 \<le> b \<Longrightarrow> (\<And>x. norm (blinfun_apply f x) \<le> b * norm x) \<Longrightarrow> norm f \<le> b"
  by transfer (rule onorm_bound)

lemma bounded_bilinear_blinfun_apply[bounded_bilinear]: "bounded_bilinear blinfun_apply"
proof
  fix f g::"'a \<Rightarrow>\<^sub>L 'b" and a b::'a and r::real
  show "(f + g) a = f a + g a" "(r *\<^sub>R f) a = r *\<^sub>R f a"
    by (transfer, simp)+
  interpret bounded_linear f for f::"'a \<Rightarrow>\<^sub>L 'b"
    by (auto intro!: bounded_linear_intros)
  show "f (a + b) = f a + f b" "f (r *\<^sub>R a) = r *\<^sub>R f a"
    by (simp_all add: add scaleR)
  show "\<exists>K. \<forall>a b. norm (blinfun_apply a b) \<le> norm a * norm b * K"
    by (auto intro!: exI[where x=1] norm_blinfun)
qed

interpretation blinfun: bounded_bilinear blinfun_apply
  by (rule bounded_bilinear_blinfun_apply)

lemmas bounded_linear_apply_blinfun[intro, simp] = blinfun.bounded_linear_left

context bounded_bilinear
begin

named_theorems bilinear_simps

lemmas [bilinear_simps] =
  add_left
  add_right
  diff_left
  diff_right
  minus_left
  minus_right
  scaleR_left
  scaleR_right
  zero_left
  zero_right
  sum_left
  sum_right

end

instance blinfun :: (banach, banach) banach
proof
  fix X::"nat \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  assume "Cauchy X"
  {
    fix x::'a
    {
      fix x::'a
      assume "norm x \<le> 1"
      have "Cauchy (\<lambda>n. X n x)"
      proof (rule CauchyI)
        fix e::real
        assume "0 < e"
        from CauchyD[OF \<open>Cauchy X\<close> \<open>0 < e\<close>] obtain M
          where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (X m - X n) < e"
          by auto
        show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (X m x - X n x) < e"
        proof (safe intro!: exI[where x=M])
          fix m n
          assume le: "M \<le> m" "M \<le> n"
          have "norm (X m x - X n x) = norm ((X m - X n) x)"
            by (simp add: blinfun.bilinear_simps)
          also have "\<dots> \<le> norm (X m - X n) * norm x"
             by (rule norm_blinfun)
          also have "\<dots> \<le> norm (X m - X n) * 1"
            using \<open>norm x \<le> 1\<close> norm_ge_zero by (rule mult_left_mono)
          also have "\<dots> = norm (X m - X n)" by simp
          also have "\<dots> < e" using le by fact
          finally show "norm (X m x - X n x) < e" .
        qed
      qed
      hence "convergent (\<lambda>n. X n x)"
        by (metis Cauchy_convergent_iff)
    } note convergent_norm1 = this
    define y where "y = x /\<^sub>R norm x"
    have y: "norm y \<le> 1" and xy: "x = norm x *\<^sub>R y"
      by (simp_all add: y_def inverse_eq_divide)
    have "convergent (\<lambda>n. norm x *\<^sub>R X n y)"
      by (intro bounded_bilinear.convergent[OF bounded_bilinear_scaleR] convergent_const
        convergent_norm1 y)
    also have "(\<lambda>n. norm x *\<^sub>R X n y) = (\<lambda>n. X n x)"
      by (subst xy) (simp add: blinfun.bilinear_simps)
    finally have "convergent (\<lambda>n. X n x)" .
  }
  then obtain v where v: "\<And>x. (\<lambda>n. X n x) \<longlonglongrightarrow> v x"
    unfolding convergent_def
    by metis

  have "Cauchy (\<lambda>n. norm (X n))"
  proof (rule CauchyI)
    fix e::real
    assume "e > 0"
    from CauchyD[OF \<open>Cauchy X\<close> \<open>0 < e\<close>] obtain M
      where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (X m - X n) < e"
      by auto
    show "\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (norm (X m) - norm (X n)) < e"
    proof (safe intro!: exI[where x=M])
      fix m n assume mn: "m \<ge> M" "n \<ge> M"
      have "norm (norm (X m) - norm (X n)) \<le> norm (X m - X n)"
        by (metis norm_triangle_ineq3 real_norm_def)
      also have "\<dots> < e" using mn by fact
      finally show "norm (norm (X m) - norm (X n)) < e" .
    qed
  qed
  then obtain K where K: "(\<lambda>n. norm (X n)) \<longlonglongrightarrow> K"
    unfolding Cauchy_convergent_iff convergent_def
    by metis

  have "bounded_linear v"
  proof
    fix x y and r::real
    from tendsto_add[OF v[of x] v [of y]] v[of "x + y", unfolded blinfun.bilinear_simps]
      tendsto_scaleR[OF tendsto_const[of r] v[of x]] v[of "r *\<^sub>R x", unfolded blinfun.bilinear_simps]
    show "v (x + y) = v x + v y" "v (r *\<^sub>R x) = r *\<^sub>R v x"
      by (metis (poly_guards_query) LIMSEQ_unique)+
    show "\<exists>K. \<forall>x. norm (v x) \<le> norm x * K"
    proof (safe intro!: exI[where x=K])
      fix x
      have "norm (v x) \<le> K * norm x"
        by (rule tendsto_le[OF _ tendsto_mult[OF K tendsto_const] tendsto_norm[OF v]])
          (auto simp: norm_blinfun)
      thus "norm (v x) \<le> norm x * K"
        by (simp add: ac_simps)
    qed
  qed
  hence Bv: "\<And>x. (\<lambda>n. X n x) \<longlonglongrightarrow> Blinfun v x"
    by (auto simp: bounded_linear_Blinfun_apply v)

  have "X \<longlonglongrightarrow> Blinfun v"
  proof (rule LIMSEQ_I)
    fix r::real assume "r > 0"
    define r' where "r' = r / 2"
    have "0 < r'" "r' < r" using \<open>r > 0\<close> by (simp_all add: r'_def)
    from CauchyD[OF \<open>Cauchy X\<close> \<open>r' > 0\<close>]
    obtain M where M: "\<And>m n. m \<ge> M \<Longrightarrow> n \<ge> M \<Longrightarrow> norm (X m - X n) < r'"
      by metis
    show "\<exists>no. \<forall>n\<ge>no. norm (X n - Blinfun v) < r"
    proof (safe intro!: exI[where x=M])
      fix n assume n: "M \<le> n"
      have "norm (X n - Blinfun v) \<le> r'"
      proof (rule norm_blinfun_bound)
        fix x
        have "eventually (\<lambda>m. m \<ge> M) sequentially"
          by (metis eventually_ge_at_top)
        hence ev_le: "eventually (\<lambda>m. norm (X n x - X m x) \<le> r' * norm x) sequentially"
        proof eventually_elim
          case (elim m)
          have "norm (X n x - X m x) = norm ((X n - X m) x)"
            by (simp add: blinfun.bilinear_simps)
          also have "\<dots> \<le> norm ((X n - X m)) * norm x"
            by (rule norm_blinfun)
          also have "\<dots> \<le> r' * norm x"
            using M[OF n elim] by (simp add: mult_right_mono)
          finally show ?case .
        qed
        have tendsto_v: "(\<lambda>m. norm (X n x - X m x)) \<longlonglongrightarrow> norm (X n x - Blinfun v x)"
          by (auto intro!: tendsto_intros Bv)
        show "norm ((X n - Blinfun v) x) \<le> r' * norm x"
          by (auto intro!: tendsto_upperbound tendsto_v ev_le simp: blinfun.bilinear_simps)
      qed (simp add: \<open>0 < r'\<close> less_imp_le)
      thus "norm (X n - Blinfun v) < r"
        by (metis \<open>r' < r\<close> le_less_trans)
    qed
  qed
  thus "convergent X"
    by (rule convergentI)
qed

subsection \<open>On Euclidean Space\<close>

lemma Zfun_sum:
  assumes "finite s"
  assumes f: "\<And>i. i \<in> s \<Longrightarrow> Zfun (f i) F"
  shows "Zfun (\<lambda>x. sum (\<lambda>i. f i x) s) F"
  using assms by induct (auto intro!: Zfun_zero Zfun_add)

lemma norm_blinfun_euclidean_le:
  fixes a::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::real_normed_vector"
  shows "norm a \<le> sum (\<lambda>x. norm (a x)) Basis"
  apply (rule norm_blinfun_bound)
   apply (simp add: sum_nonneg)
  apply (subst euclidean_representation[symmetric, where 'a='a])
  apply (simp only: blinfun.bilinear_simps sum_distrib_right)
  apply (rule order.trans[OF norm_sum sum_mono])
  apply (simp add: abs_mult mult_right_mono ac_simps Basis_le_norm)
  done

lemma tendsto_componentwise1:
  fixes a::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::real_normed_vector"
    and b::"'c \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  assumes "(\<And>j. j \<in> Basis \<Longrightarrow> ((\<lambda>n. b n j) \<longlongrightarrow> a j) F)"
  shows "(b \<longlongrightarrow> a) F"
proof -
  have "\<And>j. j \<in> Basis \<Longrightarrow> Zfun (\<lambda>x. norm (b x j - a j)) F"
    using assms unfolding tendsto_Zfun_iff Zfun_norm_iff .
  hence "Zfun (\<lambda>x. \<Sum>j\<in>Basis. norm (b x j - a j)) F"
    by (auto intro!: Zfun_sum)
  thus ?thesis
    unfolding tendsto_Zfun_iff
    by (rule Zfun_le)
      (auto intro!: order_trans[OF norm_blinfun_euclidean_le] simp: blinfun.bilinear_simps)
qed

lift_definition
  blinfun_of_matrix::"('b::euclidean_space \<Rightarrow> 'a::euclidean_space \<Rightarrow> real) \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  is "\<lambda>a x. \<Sum>i\<in>Basis. \<Sum>j\<in>Basis. ((x \<bullet> j) * a i j) *\<^sub>R i"
  by (intro bounded_linear_intros)

lemma blinfun_of_matrix_works:
  fixes f::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::euclidean_space"
  shows "blinfun_of_matrix (\<lambda>i j. (f j) \<bullet> i) = f"
proof (transfer, rule,  rule euclidean_eqI)
  fix f::"'a \<Rightarrow> 'b" and x::'a and b::'b assume "bounded_linear f" and b: "b \<in> Basis"
  then interpret bounded_linear f by simp
  have "(\<Sum>j\<in>Basis. \<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> j)) *\<^sub>R j) \<bullet> b
    = (\<Sum>j\<in>Basis. if j = b then (\<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> j))) else 0)"
    using b
    by (auto simp add: algebra_simps inner_sum_left inner_Basis split: if_split intro!: sum.cong)
  also have "\<dots> = (\<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> b)))"
    using b by (simp add: sum.delta)
  also have "\<dots> = f x \<bullet> b"
    by (metis (mono_tags, lifting) Linear_Algebra.linear_componentwise linear_axioms)
  finally show "(\<Sum>j\<in>Basis. \<Sum>i\<in>Basis. (x \<bullet> i * (f i \<bullet> j)) *\<^sub>R j) \<bullet> b = f x \<bullet> b" .
qed

lemma blinfun_of_matrix_apply:
  "blinfun_of_matrix a x = (\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. ((x \<bullet> j) * a i j) *\<^sub>R i)"
  by transfer simp

lemma blinfun_of_matrix_minus: "blinfun_of_matrix x - blinfun_of_matrix y = blinfun_of_matrix (x - y)"
  by transfer (auto simp: algebra_simps sum_subtractf)

lemma norm_blinfun_of_matrix:
  "norm (blinfun_of_matrix a) \<le> (\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. \<bar>a i j\<bar>)"
  apply (rule norm_blinfun_bound)
   apply (simp add: sum_nonneg)
  apply (simp only: blinfun_of_matrix_apply sum_distrib_right)
  apply (rule order_trans[OF norm_sum sum_mono])
  apply (rule order_trans[OF norm_sum sum_mono])
  apply (simp add: abs_mult mult_right_mono ac_simps Basis_le_norm)
  done

lemma tendsto_blinfun_of_matrix:
  assumes "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> ((\<lambda>n. b n i j) \<longlongrightarrow> a i j) F"
  shows "((\<lambda>n. blinfun_of_matrix (b n)) \<longlongrightarrow> blinfun_of_matrix a) F"
proof -
  have "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> Zfun (\<lambda>x. norm (b x i j - a i j)) F"
    using assms unfolding tendsto_Zfun_iff Zfun_norm_iff .
  hence "Zfun (\<lambda>x. (\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. \<bar>b x i j - a i j\<bar>)) F"
    by (auto intro!: Zfun_sum)
  thus ?thesis
    unfolding tendsto_Zfun_iff blinfun_of_matrix_minus
    by (rule Zfun_le) (auto intro!: order_trans[OF norm_blinfun_of_matrix])
qed

lemma tendsto_componentwise:
  fixes a::"'a::euclidean_space \<Rightarrow>\<^sub>L 'b::euclidean_space"
    and b::"'c \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  shows "(\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> ((\<lambda>n. b n j \<bullet> i) \<longlongrightarrow> a j \<bullet> i) F) \<Longrightarrow> (b \<longlongrightarrow> a) F"
  apply (subst blinfun_of_matrix_works[of a, symmetric])
  apply (subst blinfun_of_matrix_works[of "b x" for x, symmetric, abs_def])
  by (rule tendsto_blinfun_of_matrix)

lemma
  continuous_blinfun_componentwiseI:
  fixes f:: "'b::t2_space \<Rightarrow> 'a::euclidean_space \<Rightarrow>\<^sub>L 'c::euclidean_space"
  assumes "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> continuous F (\<lambda>x. (f x) j \<bullet> i)"
  shows "continuous F f"
  using assms by (auto simp: continuous_def intro!: tendsto_componentwise)

lemma
  continuous_blinfun_componentwiseI1:
  fixes f:: "'b::t2_space \<Rightarrow> 'a::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> continuous F (\<lambda>x. f x i)"
  shows "continuous F f"
  using assms by (auto simp: continuous_def intro!: tendsto_componentwise1)

lemma bounded_linear_blinfun_matrix: "bounded_linear (\<lambda>x. (x::_\<Rightarrow>\<^sub>L _) j \<bullet> i)"
  by (auto intro!: bounded_linearI' bounded_linear_intros)

lemma continuous_blinfun_matrix:
  fixes f:: "'b::t2_space \<Rightarrow> 'a::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_inner"
  assumes "continuous F f"
  shows "continuous F (\<lambda>x. (f x) j \<bullet> i)"
  by (rule bounded_linear.continuous[OF bounded_linear_blinfun_matrix assms])

lemma continuous_on_blinfun_matrix:
  fixes f::"'a::t2_space \<Rightarrow> 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_inner"
  assumes "continuous_on S f"
  shows "continuous_on S (\<lambda>x. (f x) j \<bullet> i)"
  using assms
  by (auto simp: continuous_on_eq_continuous_within continuous_blinfun_matrix)

lemma continuous_on_blinfun_of_matrix[continuous_intros]:
  assumes "\<And>i j. i \<in> Basis \<Longrightarrow> j \<in> Basis \<Longrightarrow> continuous_on S (\<lambda>s. g s i j)"
  shows "continuous_on S (\<lambda>s. blinfun_of_matrix (g s))"
  using assms
  by (auto simp: continuous_on intro!: tendsto_blinfun_of_matrix)

lemma mult_if_delta:
  "(if P then (1::'a::comm_semiring_1) else 0) * q = (if P then q else 0)"
  by auto

lemma compact_blinfun_lemma:
  fixes f :: "nat \<Rightarrow> 'a::euclidean_space \<Rightarrow>\<^sub>L 'b::euclidean_space"
  assumes "bounded (range f)"
  shows "\<forall>d\<subseteq>Basis. \<exists>l::'a \<Rightarrow>\<^sub>L 'b. \<exists> r.
    subseq r \<and> (\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>d. dist (f (r n) i) (l i) < e) sequentially)"
  by (rule compact_lemma_general[where unproj = "\<lambda>e. blinfun_of_matrix (\<lambda>i j. e j \<bullet> i)"])
   (auto intro!: euclidean_eqI[where 'a='b] bounded_linear_image assms
    simp: blinfun_of_matrix_works blinfun_of_matrix_apply inner_Basis mult_if_delta sum.delta'
      scaleR_sum_left[symmetric])

lemma blinfun_euclidean_eqI: "(\<And>i. i \<in> Basis \<Longrightarrow> blinfun_apply x i = blinfun_apply y i) \<Longrightarrow> x = y"
  apply (auto intro!: blinfun_eqI)
  apply (subst (2) euclidean_representation[symmetric, where 'a='a])
  apply (subst (1) euclidean_representation[symmetric, where 'a='a])
  apply (simp add: blinfun.bilinear_simps)
  done

lemma Blinfun_eq_matrix: "bounded_linear f \<Longrightarrow> Blinfun f = blinfun_of_matrix (\<lambda>i j. f j \<bullet> i)"
  by (intro blinfun_euclidean_eqI)
     (auto simp: blinfun_of_matrix_apply bounded_linear_Blinfun_apply inner_Basis if_distrib
      cond_application_beta sum.delta' euclidean_representation
      cong: if_cong)

text \<open>TODO: generalize (via @{thm compact_cball})?\<close>
instance blinfun :: (euclidean_space, euclidean_space) heine_borel
proof
  fix f :: "nat \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b"
  assume f: "bounded (range f)"
  then obtain l::"'a \<Rightarrow>\<^sub>L 'b" and r where r: "subseq r"
    and l: "\<forall>e>0. eventually (\<lambda>n. \<forall>i\<in>Basis. dist (f (r n) i) (l i) < e) sequentially"
    using compact_blinfun_lemma [OF f] by blast
  {
    fix e::real
    let ?d = "real_of_nat DIM('a) * real_of_nat DIM('b)"
    assume "e > 0"
    hence "e / ?d > 0" by (simp add: DIM_positive)
    with l have "eventually (\<lambda>n. \<forall>i\<in>Basis. dist (f (r n) i) (l i) < e / ?d) sequentially"
      by simp
    moreover
    {
      fix n
      assume n: "\<forall>i\<in>Basis. dist (f (r n) i) (l i) < e / ?d"
      have "norm (f (r n) - l) = norm (blinfun_of_matrix (\<lambda>i j. (f (r n) - l) j \<bullet> i))"
        unfolding blinfun_of_matrix_works ..
      also note norm_blinfun_of_matrix
      also have "(\<Sum>i\<in>Basis. \<Sum>j\<in>Basis. \<bar>(f (r n) - l) j \<bullet> i\<bar>) <
        (\<Sum>i\<in>(Basis::'b set). e / real_of_nat DIM('b))"
      proof (rule sum_strict_mono)
        fix i::'b assume i: "i \<in> Basis"
        have "(\<Sum>j::'a\<in>Basis. \<bar>(f (r n) - l) j \<bullet> i\<bar>) < (\<Sum>j::'a\<in>Basis. e / ?d)"
        proof (rule sum_strict_mono)
          fix j::'a assume j: "j \<in> Basis"
          have "\<bar>(f (r n) - l) j \<bullet> i\<bar> \<le> norm ((f (r n) - l) j)"
            by (simp add: Basis_le_norm i)
          also have "\<dots> < e / ?d"
            using n i j by (auto simp: dist_norm blinfun.bilinear_simps)
          finally show "\<bar>(f (r n) - l) j \<bullet> i\<bar> < e / ?d" by simp
        qed simp_all
        also have "\<dots> \<le> e / real_of_nat DIM('b)"
          by simp
        finally show "(\<Sum>j\<in>Basis. \<bar>(f (r n) - l) j \<bullet> i\<bar>) < e / real_of_nat DIM('b)"
          by simp
      qed simp_all
      also have "\<dots> \<le> e" by simp
      finally have "dist (f (r n)) l < e"
        by (auto simp: dist_norm)
    }
    ultimately have "eventually (\<lambda>n. dist (f (r n)) l < e) sequentially"
      using eventually_elim2 by force
  }
  then have *: "((f \<circ> r) \<longlongrightarrow> l) sequentially"
    unfolding o_def tendsto_iff by simp
  with r show "\<exists>l r. subseq r \<and> ((f \<circ> r) \<longlongrightarrow> l) sequentially"
    by auto
qed

subsection \<open>concrete bounded linear functions\<close>

lemma transfer_bounded_bilinear_bounded_linearI:
  assumes "g = (\<lambda>i x. (blinfun_apply (f i) x))"
  shows "bounded_bilinear g = bounded_linear f"
proof
  assume "bounded_bilinear g"
  then interpret bounded_bilinear f by (simp add: assms)
  show "bounded_linear f"
  proof (unfold_locales, safe intro!: blinfun_eqI)
    fix i
    show "f (x + y) i = (f x + f y) i" "f (r *\<^sub>R x) i = (r *\<^sub>R f x) i" for r x y
      by (auto intro!: blinfun_eqI simp: blinfun.bilinear_simps)
    from _ nonneg_bounded show "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
      by (rule ex_reg) (auto intro!: onorm_bound simp: norm_blinfun.rep_eq ac_simps)
  qed
qed (auto simp: assms intro!: blinfun.comp)

lemma transfer_bounded_bilinear_bounded_linear[transfer_rule]:
  "(rel_fun (rel_fun op = (pcr_blinfun op = op =)) op =) bounded_bilinear bounded_linear"
  by (auto simp: pcr_blinfun_def cr_blinfun_def rel_fun_def OO_def
    intro!: transfer_bounded_bilinear_bounded_linearI)

context bounded_bilinear
begin

lift_definition prod_left::"'b \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'c" is "(\<lambda>b a. prod a b)"
  by (rule bounded_linear_left)
declare prod_left.rep_eq[simp]

lemma bounded_linear_prod_left[bounded_linear]: "bounded_linear prod_left"
  by transfer (rule flip)

lift_definition prod_right::"'a \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'c" is "(\<lambda>a b. prod a b)"
  by (rule bounded_linear_right)
declare prod_right.rep_eq[simp]

lemma bounded_linear_prod_right[bounded_linear]: "bounded_linear prod_right"
  by transfer (rule bounded_bilinear_axioms)

end

lift_definition id_blinfun::"'a::real_normed_vector \<Rightarrow>\<^sub>L 'a" is "\<lambda>x. x"
  by (rule bounded_linear_ident)

lemmas blinfun_apply_id_blinfun[simp] = id_blinfun.rep_eq

lemma norm_blinfun_id[simp]:
  "norm (id_blinfun::'a::{real_normed_vector, perfect_space} \<Rightarrow>\<^sub>L 'a) = 1"
  by transfer (auto simp: onorm_id)

lemma norm_blinfun_id_le:
  "norm (id_blinfun::'a::real_normed_vector \<Rightarrow>\<^sub>L 'a) \<le> 1"
  by transfer (auto simp: onorm_id_le)

lift_definition fst_blinfun::"('a::real_normed_vector \<times> 'b::real_normed_vector) \<Rightarrow>\<^sub>L 'a" is fst
  by (rule bounded_linear_fst)

lemma blinfun_apply_fst_blinfun[simp]: "blinfun_apply fst_blinfun = fst"
  by transfer (rule refl)

lift_definition snd_blinfun::"('a::real_normed_vector \<times> 'b::real_normed_vector) \<Rightarrow>\<^sub>L 'b" is snd
  by (rule bounded_linear_snd)

lemma blinfun_apply_snd_blinfun[simp]: "blinfun_apply snd_blinfun = snd"
  by transfer (rule refl)

lift_definition blinfun_compose::
  "'a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>
    'c::real_normed_vector \<Rightarrow>\<^sub>L 'a \<Rightarrow>
    'c \<Rightarrow>\<^sub>L 'b" (infixl "o\<^sub>L" 55) is "op o"
  parametric comp_transfer
  unfolding o_def
  by (rule bounded_linear_compose)

lemma blinfun_apply_blinfun_compose[simp]: "(a o\<^sub>L b) c = a (b c)"
  by (simp add: blinfun_compose.rep_eq)

lemma norm_blinfun_compose:
  "norm (f o\<^sub>L g) \<le> norm f * norm g"
  by transfer (rule onorm_compose)

lemma bounded_bilinear_blinfun_compose[bounded_bilinear]: "bounded_bilinear op o\<^sub>L"
  by unfold_locales
    (auto intro!: blinfun_eqI exI[where x=1] simp: blinfun.bilinear_simps norm_blinfun_compose)

lemma blinfun_compose_zero[simp]:
  "blinfun_compose 0 = (\<lambda>_. 0)"
  "blinfun_compose x 0 = 0"
  by (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI)

lift_definition blinfun_inner_right::"'a::real_inner \<Rightarrow> 'a \<Rightarrow>\<^sub>L real" is "op \<bullet>"
  by (rule bounded_linear_inner_right)
declare blinfun_inner_right.rep_eq[simp]

lemma bounded_linear_blinfun_inner_right[bounded_linear]: "bounded_linear blinfun_inner_right"
  by transfer (rule bounded_bilinear_inner)

lift_definition blinfun_inner_left::"'a::real_inner \<Rightarrow> 'a \<Rightarrow>\<^sub>L real" is "\<lambda>x y. y \<bullet> x"
  by (rule bounded_linear_inner_left)
declare blinfun_inner_left.rep_eq[simp]

lemma bounded_linear_blinfun_inner_left[bounded_linear]: "bounded_linear blinfun_inner_left"
  by transfer (rule bounded_bilinear.flip[OF bounded_bilinear_inner])

lift_definition blinfun_scaleR_right::"real \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a::real_normed_vector" is "op *\<^sub>R"
  by (rule bounded_linear_scaleR_right)
declare blinfun_scaleR_right.rep_eq[simp]

lemma bounded_linear_blinfun_scaleR_right[bounded_linear]: "bounded_linear blinfun_scaleR_right"
  by transfer (rule bounded_bilinear_scaleR)

lift_definition blinfun_scaleR_left::"'a::real_normed_vector \<Rightarrow> real \<Rightarrow>\<^sub>L 'a" is "\<lambda>x y. y *\<^sub>R x"
  by (rule bounded_linear_scaleR_left)
lemmas [simp] = blinfun_scaleR_left.rep_eq

lemma bounded_linear_blinfun_scaleR_left[bounded_linear]: "bounded_linear blinfun_scaleR_left"
  by transfer (rule bounded_bilinear.flip[OF bounded_bilinear_scaleR])

lift_definition blinfun_mult_right::"'a \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a::real_normed_algebra" is "op *"
  by (rule bounded_linear_mult_right)
declare blinfun_mult_right.rep_eq[simp]

lemma bounded_linear_blinfun_mult_right[bounded_linear]: "bounded_linear blinfun_mult_right"
  by transfer (rule bounded_bilinear_mult)

lift_definition blinfun_mult_left::"'a::real_normed_algebra \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'a" is "\<lambda>x y. y * x"
  by (rule bounded_linear_mult_left)
lemmas [simp] = blinfun_mult_left.rep_eq

lemma bounded_linear_blinfun_mult_left[bounded_linear]: "bounded_linear blinfun_mult_left"
  by transfer (rule bounded_bilinear.flip[OF bounded_bilinear_mult])

end


(* D. Fuenmayor and A. Steen, August 2021 *)
(* This file provides the correspondences between labellings and extensions
   for argumentation frameworks. *)
(* Auxiliary references:
 [BCG 2011] Baroni, P., M. Caminada and M. Giacomin, An introduction to argumentation semantics,
            Knowledge Engineering Review (2011)
 [Dung 1995] Dung, P.M., On the acceptability of arguments and its fundamental role in nonmonotonic reasoning,
            logic programming and n-person games, Artificial Intelligence. (1995)
*)

theory correspondence
  imports extensions labellings "ext-properties"
begin

(**********************************************************)
(**** Correspondences between labellings and extensions ***)
(********** (proved for all but ideal semantics) **********)
(**********************************************************)

(* Define mappings between extensions and labellings. *)
definition Lab2Ext::\<open>'a Labelling \<Rightarrow> 'a Set\<close>
  where \<open>Lab2Ext Lab \<equiv> in(Lab)\<close>
definition Ext2Lab::\<open>'a Set \<Rightarrow> 'a Rel \<Rightarrow> 'a Set \<Rightarrow> 'a Labelling\<close> ("Ext2Lab\<^sup>_") (* Warning: works only for conflict-free sets! *)
  where \<open>Ext2Lab\<^sup>\<A> att E \<equiv> \<lambda>a. if (E a) then In else (if ([\<A>|att|E]\<^sup>+ a) then Out else Undec)\<close>

(*conflict-free*)

lemma conflictfree_LE:  "conflictfreeLab\<^sup>\<A> att Lab \<longrightarrow> conflictfreeExt\<^sup>\<A> att (Lab2Ext Lab)"
  by (smt (verit, best) Lab2Ext_def conflictfreeExt_def conflictfreeLab_def legallyOut_def)

lemma conflictfree_LE': "conflictfreeExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> conflictfreeLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma conflictfree_EL:  "conflictfreeExt\<^sup>\<A> att E \<longrightarrow> conflictfreeLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)"
  unfolding conflictfreeExt_def conflictfreeLab_def Ext2Lab_def
  by (smt (verit, best) Label.distinct(1) Label.distinct(3) Label.distinct(5) inset_def legallyOut_def outset_def plusset_rel_def)

lemma conflictfree_EL': "conflictfreeLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> conflictfreeExt\<^sup>\<A> att E"
  unfolding conflictfreeExt_def conflictfreeLab_def Ext2Lab_def by (smt (z3) inset_def legallyOut_def)

(*admissible*)

lemma admissible_LE:  "admissibleLab\<^sup>\<A> att Lab \<longrightarrow> admissibleExt\<^sup>\<A> att (Lab2Ext Lab)"
  unfolding admissibleExt_def admissibleLab_def Lab2Ext_def by (smt (verit, ccfv_SIG) Label.distinct(1) conflictfreeExt_def defends_rel_def inset_def legallyIn_def legallyOut_def outset_def)

lemma admissible_LE': "admissibleExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> admissibleLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma admissible_EL:  "admissibleExt\<^sup>\<A> att E \<longrightarrow> admissibleLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)"
  unfolding admissibleExt_def admissibleLab_def Ext2Lab_def by (smt (verit, del_insts) Label.distinct(1) Label.distinct(3) Label.distinct(5) conflictfreeExt_def defends_rel_def inset_def legallyIn_def legallyOut_def outset_def plusset_rel_def)

lemma admissible_EL': "admissibleLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> admissibleExt\<^sup>\<A> att E"
  unfolding admissibleExt_def admissibleLab_def Ext2Lab_def by (smt (verit, del_insts) Label.distinct(1) Label.distinct(5) conflictfreeExt_def defends_rel_def inset_def legallyIn_def outset_def plusset_rel_def)

(*complete*)

lemma complete_LE:  "completeLab\<^sup>\<A> att Lab \<longrightarrow> completeExt\<^sup>\<A> att (Lab2Ext Lab)"
  unfolding completeExt_def by (smt (verit, ccfv_threshold) Lab2Ext_def admissible_LE completeLab2_def completeLab_def complete_defEq defends_rel_def legallyIn_def legallyOut_def)

lemma complete_LE': "completeExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> completeLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma complete_EL:  "completeExt\<^sup>\<A> att E \<longrightarrow> completeLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)"
  unfolding completeExt_def complete_defEq
  by (smt (z3) Ext2Lab_def Label.distinct(1) Label.distinct(3) Label.distinct(5) admissibleExt_def completeLab2_def conflictfreeExt_def defends_rel_def inset_def legallyIn_def legallyOut_def outset_def plusset_rel_def)

lemma complete_EL': "completeLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> completeExt\<^sup>\<A> att E"
  unfolding completeExt_def completeLab_def
  by (smt (z3) Ext2Lab_def Label.distinct(1) Label.distinct(3) admissibleLab_def admissible_EL' completeLab2_def completeLab_def complete_defEq conflictfreeExt_def conflictfreeLab_def conflictfree_EL defends_rel_def inset_def legallyIn_def legallyOut_def outset_def plusset_rel_def)

(*preferred*)

lemma preferred_LE:  "preferredLab\<^sup>\<A> att Lab \<longrightarrow> preferredExt\<^sup>\<A> att (Lab2Ext Lab)"
  unfolding preferredExt_def preferredLab_def maximal_rel_def
  by (smt (verit, ccfv_threshold) Ext2Lab_def Lab2Ext_def complete_EL complete_LE id_apply inset_def)

lemma preferred_LE': "preferredExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> preferredLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma preferred_EL:  "preferredExt\<^sup>\<A> att E \<longrightarrow> preferredLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)"
  unfolding preferredExt_def preferredLab_def maximal_rel_def
  by (metis Ext2Lab_def Lab2Ext_def complete_EL complete_LE eq_id_iff inset_def)

lemma preferred_EL': "preferredLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> preferredExt\<^sup>\<A> att E"
  unfolding preferredExt_def preferredLab_def maximal_rel_def
  by (smt (verit) Ext2Lab_def Label.distinct(1) Label.distinct(3) complete_EL complete_EL' id_apply inset_def)

(*grounded*)

lemma grounded_LE:  "groundedLab\<^sup>\<A> att Lab \<longrightarrow> groundedExt\<^sup>\<A> att (Lab2Ext Lab)"
  unfolding groundedExt_def groundedLab_def minimal_rel_def
  by (smt (verit, del_insts) Ext2Lab_def Lab2Ext_def Label.distinct(1) Label.distinct(3) complete_EL complete_LE id_def inset_def)

lemma grounded_LE': "groundedExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> groundedLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma grounded_EL:  "groundedExt\<^sup>\<A> att E \<longrightarrow> groundedLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)"
  unfolding groundedExt_def groundedLab_def minimal_rel_def
  by (metis Ext2Lab_def Lab2Ext_def Label.distinct(1) Label.distinct(3) complete_EL complete_LE id_def inset_def)

lemma grounded_EL': "groundedLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> groundedExt\<^sup>\<A> att E"
  unfolding groundedExt_def groundedLab_def minimal_rel_def
  by (smt (verit, best) Ext2Lab_def Label.distinct(3) Label.simps(2) complete_EL complete_EL' id_def inset_def)

(*ideal (still missing)*)

lemma ideal_LE:  "idealLab\<^sup>\<A> att Lab \<longrightarrow> idealExt\<^sup>\<A> att (Lab2Ext Lab)"  oops (* TODO: verify *)

lemma ideal_LE': "idealExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> idealLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma ideal_EL:  "idealExt\<^sup>\<A> att E \<longrightarrow> idealLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)" oops (* TODO: verify *)

lemma ideal_EL': "idealLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> idealExt\<^sup>\<A> att E" oops (* TODO: verify *)

(*stable*)

lemma stable_LE:  "stableLab\<^sup>\<A> att Lab \<longrightarrow> stableExt\<^sup>\<A> att (Lab2Ext Lab)"
  unfolding stableExt_def stableLab_def range_def
  by (smt (verit) Lab2Ext_def Label.exhaust admissibleExt_def admissible_LE completeLab2_def completeLab_def complete_defEq inset_def legallyIn_def outset_def plusset_rel_def)

lemma stable_LE': "stableExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> stableLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma stable_EL:  "stableExt\<^sup>\<A> att E \<longrightarrow> stableLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E)"
  by (smt (verit, ccfv_SIG) range_def Ext2Lab_def Label.distinct(3) Label.distinct(5) completeLab2_def complete_defEq conflictfree_EL conflictfreeLab_def inset_def legallyIn_def legallyOut_def outset_def stableExt_def stableLab_def)

lemma stable_EL': "stableLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> stableExt\<^sup>\<A> att E"
  unfolding stableExt_def stableLab_def range_def by (metis Ext2Lab_def admissibleExt_def completeAdmissible complete_EL')

(*semi-stable*)

lemma semistable_LE:  "semistableLab\<^sup>\<A> AF Lab \<longrightarrow> semistableExt\<^sup>\<A> AF (Lab2Ext Lab)"
  unfolding semistableExt_def semistableLab_def minimal_rel_def maximal_rel_def
  by (smt (verit, best) Ext2Lab_def Lab2Ext_def Label.exhaust completeLab2_def complete_EL complete_LE complete_defEq inset_def legallyOut_def outset_def plusset_rel_def range_def undecset_def)

lemma semistable_LE': "semistableExt\<^sup>\<A> AF (Lab2Ext Lab) \<longrightarrow> semistableLab\<^sup>\<A> AF Lab"
  nitpick oops (*as expected*)

lemma semistable_EL:  "semistableExt\<^sup>\<A> AF E \<longrightarrow> semistableLab\<^sup>\<A> AF (Ext2Lab\<^sup>\<A> AF E)"
  unfolding semistableExt_def semistableLab_def minimal_rel_def maximal_rel_def
  by (smt (verit, best) Ext2Lab_def Lab2Ext_def Label.distinct(3) Label.exhaust Label.simps(6) admissibleLab_def completeLab_def complete_EL complete_LE inset_def legallyOut_def outset_def plusset_rel_def range_def undecset_def)

lemma semistable_EL': "semistableLab\<^sup>\<A> AF (Ext2Lab\<^sup>\<A> AF E) \<longrightarrow> semistableExt\<^sup>\<A> AF E"
  unfolding semistableExt_def semistableLab_def  minimal_rel_def maximal_rel_def
  by (smt (verit, ccfv_threshold) Ext2Lab_def Label.distinct(3) Label.simps(6) complete_EL complete_EL' range_def undecset_def)

(*stage*)

lemma stage_LE:  "stageLab\<^sup>\<A> att Lab \<longrightarrow> stageExt\<^sup>\<A> att (Lab2Ext Lab)"
  unfolding stageExt_def stageLab_def minimal_rel_def maximal_rel_def range_def
  by (smt (verit) Ext2Lab_def Lab2Ext_def Label.distinct(5) Label.exhaust conflictfree_EL conflictfree_LE conflictfreeLab_def inset_def legallyOut_def outset_def plusset_rel_def undecset_def)

lemma stage_LE': "stageExt\<^sup>\<A> att (Lab2Ext Lab) \<longrightarrow> stageLab\<^sup>\<A> att Lab"
  nitpick oops (*as expected*)

lemma stage_EL:  "stageExt\<^sup>\<A> AF E \<longrightarrow> stageLab\<^sup>\<A> AF (Ext2Lab\<^sup>\<A> AF E)"
  unfolding stageExt_def stageLab_def minimal_rel_def maximal_rel_def
  by (smt (verit, del_insts) Ext2Lab_def Lab2Ext_def Label.exhaust conflictfree_EL conflictfree_LE conflictfreeLab_def inset_def legallyOut_def outset_def plusset_rel_def range_def undecset_def)

lemma stage_EL': "stageLab\<^sup>\<A> att (Ext2Lab\<^sup>\<A> att E) \<longrightarrow> stageExt\<^sup>\<A> att E"
  unfolding stageExt_def stageLab_def minimal_rel_def maximal_rel_def range_def
  by (smt (verit, ccfv_threshold) Ext2Lab_def Label.distinct(3) Label.distinct(6) conflictfree_EL conflictfree_EL' undecset_def)

end


theory Involutions2Squares
imports Main
begin

section \<open>A few basic properties\<close>

lemma nat_sqr :
  shows "nat(n\<^sup>2) = (nat(abs n))\<^sup>2"
  by(rule int_int_eq[THEN iffD1], simp)

lemma nat_mod_int :
  assumes "n mod m = k"
  shows "int n mod int m = int k"
  by (metis assms of_nat_mod)

lemma sqr_geq_nat :
  shows "(n::nat) \<le> n\<^sup>2"
  using power2_nat_le_imp_le by simp

lemma sqr_geq_abs :
  shows "abs(n::int) \<le> n\<^sup>2"
proof(rule nat_le_eq_zle[THEN iffD1], simp)
  show "nat \<bar>n\<bar> \<le> nat (n\<^sup>2)"
    using nat_sqr sqr_geq_nat by presburger
qed

lemma sqr_fix_nat :
  assumes "(n::nat) = n\<^sup>2"
  shows "n = 0 \<or> n = 1"
  using assms numeral_2_eq_2 by fastforce

lemma card1 :
  shows "(card{a, b} = Suc 0) = (a = b)"
  using singleton_insert_inj_eq' by fastforce

lemma card2 :
  shows "card{a, b} \<ge> Suc 0 \<and> card{a, b} \<le> 2"
  by (simp add: card_insert_if)

section \<open>The relevant properties of involutions\<close>

definition "involution_on A \<phi> = (\<phi> ` A \<subseteq> A \<and> (\<forall>x\<in>A. \<phi>(\<phi> x) = x))"

lemma involution_bij :
  assumes "involution_on A \<phi>"
  shows "bij_betw \<phi> A A"
  using assms bij_betw_byWitness involution_on_def by fast

lemma involution_sub_bij :
  assumes "involution_on A \<phi>"
      and "S \<subseteq> A"
      and "\<forall>x\<in>A. (x \<in> S) = (\<phi> x \<notin> S)"
 shows "bij_betw \<phi> S (A - S)"
proof(simp add: bij_betw_def, rule conjI)
  show "inj_on \<phi> S"
    by (meson assms bij_betw_def inj_on_subset involution_bij)
next
  show "\<phi> ` S = A - S"
  proof(rule set_eqI, clarsimp)
    fix x show "(x \<in> \<phi> ` S) = (x \<in> A \<and> x \<notin> S)" (is "?L = ?R")
    proof
      assume ?L thus ?R
        by(metis assms bij_betw_imp_surj_on f_inv_into_f image_eqI inv_into_into involution_bij subset_iff)
    next
      assume ?R thus ?L
        by (metis assms(1) assms(3) image_iff involution_on_def)
    qed
  qed
qed

lemma involution_sub_card :
  assumes "involution_on A \<phi>"
      and "finite A"
      and "S \<subseteq> A"
      and "\<forall>x\<in>A. (x \<in> S) = (\<phi> x \<notin> S)"
    shows "2 * card S = card A"
proof -
  have "card S = card (A - S)"
    using assms bij_betw_same_card involution_sub_bij by blast

  also have "... = card A - card S"
    by (meson assms card_Diff_subset rev_finite_subset)

  finally show ?thesis by simp
qed

subsection \<open>Unions of preimage/image sets, fixed points\<close>

definition "preimg_img_on A \<phi> = (\<Union>x\<in>A. {{x, \<phi> x}})"
definition "fixpoints_on A \<phi> = {x\<in>A. \<phi> x = x}"

lemma preimg_img_on_Union :
  assumes "\<phi> ` A \<subseteq> A"
  shows "A = \<Union>(preimg_img_on A \<phi>)"
  using assms by(fastforce simp: preimg_img_on_def)

lemma preimg_img_on_finite :
  assumes "finite A"
  shows "finite (preimg_img_on A \<phi>)"
  by(simp add: assms preimg_img_on_def)

lemma fixpoints_on_finite :
  assumes "finite A"
  shows "finite (fixpoints_on A \<phi>)"
  by(simp add: assms fixpoints_on_def)

lemma preimg_img_on_card :
  assumes "x \<in> preimg_img_on A \<phi>"
  shows "1 \<le> card x \<and> card x \<le> 2"
  using assms by(fastforce simp: preimg_img_on_def card2)

corollary preimg_img_on_eq :
  shows "preimg_img_on A \<phi> = {x \<in> preimg_img_on A \<phi>. card x = 1} \<union>
                              {x \<in> preimg_img_on A \<phi>. card x = 2}"
proof(rule equalityI[rotated 1], clarsimp+)
  fix x assume "card x \<noteq> 2" and "x \<in> preimg_img_on A \<phi>"
  thus "card x = Suc 0"
    using preimg_img_on_card by fastforce
qed

lemma fixpoints_on_card_eq :
  shows "card(fixpoints_on A \<phi>) = card {x \<in> preimg_img_on A \<phi>. card x = 1}"
proof -
  have "bij_betw (\<lambda>x. {x}) (fixpoints_on A \<phi>)
                           {x. x \<in> preimg_img_on A \<phi> \<and> card x = 1}"
    by(fastforce simp: bij_betw_def fixpoints_on_def preimg_img_on_def card1)
  thus ?thesis by(rule bij_betw_same_card)
qed

lemma preimg_img_on_disjoint :
  assumes "involution_on A \<phi>"
  shows "pairwise disjnt (preimg_img_on A \<phi>)"
proof(clarsimp simp: pairwise_def disjnt_def preimg_img_on_def)
  fix u v assume b: "u \<in> A" and c: "v \<in> A" and d: "{u, \<phi> u} \<noteq> {v, \<phi> v}"
  hence e: "u \<noteq> v" by clarsimp
  with b and c have f: "\<phi> u \<noteq> \<phi> v" by (metis assms involution_on_def)
  have "(\<phi> v = u) = (v = \<phi> u)" by (metis assms b c involution_on_def)
  with d have "\<phi> v \<noteq> u \<and> v \<noteq> \<phi> u" by fastforce
  with e and f show "v \<noteq> u \<and> v \<noteq> \<phi> u \<and> \<phi> v \<noteq> u \<and> \<phi> v \<noteq> \<phi> u" by simp
qed

theorem involution_dom_card_sum :
  assumes "involution_on A \<phi>"
      and "finite A"
    shows "card A = card (fixpoints_on A \<phi>) +
                    2 * card {x \<in> preimg_img_on A \<phi>. card x = 2}"
proof -
  have eq: "{x \<in> preimg_img_on A \<phi>. card x = Suc 0} \<inter>
           {x \<in> preimg_img_on A \<phi>. card x = 2} = {}"
    by fastforce

  have f1 : "finite {x \<in> preimg_img_on A \<phi>. card x = 1}"
    by (simp add: assms preimg_img_on_finite)
  have f2 : "finite {x \<in> preimg_img_on A \<phi>. card x = 2}"
    by (simp add: assms preimg_img_on_finite)

  have "card A = card (\<Union>(preimg_img_on A \<phi>))"
    by (metis assms(1) involution_on_def preimg_img_on_Union)

  also have "... = sum card (preimg_img_on A \<phi>)"
    by (metis assms(1) card_Union_disjoint card_eq_0_iff not_one_le_zero preimg_img_on_card
        preimg_img_on_disjoint)

  also have "... = sum card ({x \<in> preimg_img_on A \<phi>. card x = 1} \<union>
                             {x \<in> preimg_img_on A \<phi>. card x = 2})"
    by (metis preimg_img_on_eq)

  also have "... = sum card {x \<in> preimg_img_on A \<phi>. card x = 1} +
                   sum card {x \<in> preimg_img_on A \<phi>. card x = 2}"
    by (metis (no_types, lifting) Collect_cong One_nat_def eq f1 f2 sum.union_disjoint)

  also have "... = card (fixpoints_on A \<phi>) +
                   2 * card {x \<in> preimg_img_on A \<phi>. card x = 2}"
    by(simp add: fixpoints_on_card_eq)

  finally show ?thesis .
qed

corollary involution_dom_fixpoints_parity :
  assumes "involution_on A \<phi>"
      and "finite A"
 shows "odd(card A) = odd(card(fixpoints_on A \<phi>))"
  using assms involution_dom_card_sum by fastforce

section \<open>Primes and the two squares theorem\<close>

definition "is_prime (n :: nat) = (n > 1 \<and> (\<forall>d. d dvd n \<longrightarrow> d = 1 \<or> d = n))"

lemma prime_factors :
  assumes "is_prime p"
      and "p = n * m"
    shows "(n = 1 \<and> m = p) \<or> (n = p \<and> m = 1)"
using assms proof(clarsimp simp: is_prime_def)
  assume "\<forall>d. d dvd n * m \<longrightarrow> d = Suc 0 \<or> d = n * m"
  hence a: "n = Suc 0 \<or> n = n * m \<and> m = Suc 0 \<or> m = n * m"
    by (meson dvd_triv_left dvd_triv_right)
  assume "0 < n \<and> Suc 0 \<noteq> m \<or> m \<noteq> Suc 0" and "Suc 0 < n*m"
  with a show "n = Suc 0 \<and> (m = 0 \<or> Suc 0 = n)" by fastforce
qed

lemma prime_not_sqr :
  assumes "is_prime p"
  shows "p \<noteq> n\<^sup>2"
  by (metis assms is_prime_def order_less_irrefl power2_eq_square prime_factors)

lemma int_prime_not_sqr :
  assumes "is_prime p"
  shows "int p \<noteq> n\<^sup>2"
  by (metis assms nat_int nat_sqr prime_not_sqr)

lemma prime_gr4 :
  assumes "is_prime p"
      and "p mod 4 = 1"
    shows "p > 4"
proof(rule ccontr, drule leI)
  assume "p \<le> 4"
  thus False
    by (metis assms dvd_imp_mod_0 dvd_triv_left is_prime_def mod_less mult.right_neutral
        order_less_le zero_neq_one)
qed

theorem two_squares :
  assumes a: "is_prime p"
      and b: "p mod 4 = 1"
    shows "\<exists>n m. p = n\<^sup>2 + m\<^sup>2"
proof -
  let ?S  =  "{(u, v, w). int p = 4 * u * v + w\<^sup>2 \<and> u > 0 \<and> v > 0}"
  let ?T  =  "?S \<inter> {(u, v, w). w > 0}"
  let ?U  =  "?S \<inter> {(u, v, w). u - v + w > 0}"
  let ?f  =  "\<lambda>(u, v, w). (v, u, -w)"
  let ?g  =  "\<lambda>(u, v, w). (u - v + w, v, 2 * v - w)"
  let ?h  =  "\<lambda>(u, v, w). (v, u, w)"

  have w_neq0 : "\<forall>u v w. (u, v, w) \<in> ?S \<longrightarrow> w \<noteq> 0"
  proof clarsimp
    fix u v assume "int p = 4 * u * v"
    hence "4 dvd int p" by simp
    hence "4 dvd p" by presburger
    with b show False by simp
  qed

  have fin_S : "finite ?S"
  proof -
    have uv_comm : "\<forall>u v w. (u, v, w) \<in> ?S \<longrightarrow> (v, u, w) \<in> ?S" by simp

    have bound1 : "\<forall>u v w. (u, v, w) \<in> ?S \<longrightarrow> u \<le> (int p - 1) div 4"
    proof clarsimp
      fix u v w assume 1: "int p = 4 * u * v + w\<^sup>2" and 2: "(0::int) < v" and 3: "(0::int) < u"
      with 2 and 3 have 4: "4 * u \<le> 4 * u * v" by simp
      have "w \<noteq> (0::int)" using 1 2 3 w_neq0 by simp
      hence "1 \<le> w\<^sup>2"
        by (metis add_0 linorder_not_le power2_less_eq_zero_iff zless_imp_add1_zle)
      with 4 have 5: "4 * u \<le> 4 * u * v + w\<^sup>2 - 1" by simp
      note zdiv_mono1[OF 5, where b="4::int", simplified]
      thus "u \<le> (4 * u * v + w\<^sup>2 - 1) div 4" .
    qed

    have bound2 : "\<forall>u v w. (u, v, w) \<in> ?S \<longrightarrow> v \<le> (int p - 1) div 4"
      using bound1 uv_comm by blast

    have bound3 : "\<forall>u v w. (u, v, w) \<in> ?S \<longrightarrow> \<bar>w\<bar> \<le> int p"
    proof clarsimp
      fix u v w::int
      have 1: "\<bar>w\<bar> \<le> w\<^sup>2" by(rule sqr_geq_abs)
      assume "(0::int) < u" and "(0::int) < v"
      hence "0 < u * v" by(rule mult_pos_pos)
      hence "0 \<le> u * v" by simp
      hence "w\<^sup>2 \<le> 4 * u * v + w\<^sup>2" by simp
      with 1 show "\<bar>w\<bar> \<le> 4 * u * v + w\<^sup>2" by simp
    qed

    let ?prod = "{1..(int p - 1) div 4} \<times> {1..(int p - 1) div 4} \<times> {- int p..int p}"

    have prod: "\<forall>u v w. (u, v, w) \<in> ?S \<longrightarrow> (u, v, w) \<in> ?prod"
    proof(intro allI)
      fix u v w show "(u, v, w) \<in> ?S \<longrightarrow> (u, v, w) \<in> ?prod"
      proof(rule impI)
        assume 1: "(u, v, w) \<in> ?S"
        note bound1[rule_format, OF 1] and
             bound2[rule_format, OF 1]
        with 1 show "(u, v, w) \<in> ?prod"
        proof simp
          have "\<bar>w\<bar> \<le> int p" by(rule bound3[rule_format, OF 1])
          hence "w \<le> int p \<and> -w \<le> int p" by(rule abs_le_iff[THEN iffD1])
          with 1 show "- (4 * u * v) - w\<^sup>2 \<le> w \<and> w \<le> 4 * u * v + w\<^sup>2" by simp
        qed
      qed
    qed

    show ?thesis
    proof(rule_tac B="?prod" in finite_subset)
      show "?S \<subseteq> ?prod" using prod by fast
    next
      show "finite ?prod" by simp
    qed
  qed

  have inv1 : "involution_on ?S ?f"
    by(clarsimp simp: involution_on_def)

  have inv2 : "involution_on ?U ?g"
    by(fastforce simp: involution_on_def int_distrib power2_diff power2_eq_square)

  have inv3 : "involution_on ?T ?h"
    by(fastforce simp: involution_on_def)

  have part1 : "\<forall>x\<in>?S. (x \<in> ?T) = (?f x \<notin> ?T)"
  proof clarsimp
    fix u v w assume 1: "int p = 4 * u * v + w\<^sup>2" and 2: "(0::int) < v" and 3: "(0::int) < u"
    have "w \<noteq> 0"
    proof(rule w_neq0[rule_format])
      from 1 2 3 show "(u, v, w) \<in> ?S" by simp
    qed
    thus "(0 < w) = (\<not> w < 0)" by fastforce
  qed

  have part2 : "\<forall>x\<in>?S. (x \<in> ?U) = (?f x \<notin> ?U)"
  proof clarsimp
    fix u v w assume 1: "int p = 4 * u * v + w\<^sup>2" and 2: "u > 0" and 3: "v > 0"
    show "(0 < u - v + w) = (\<not> w < v - u)" (is "?L = ?R")
    proof
      assume ?L with 2 and 3 show ?R by fastforce
    next
      assume ?R hence 4: "v - u \<le> w" by simp
      show ?L
      proof(rule ccontr)
        assume "\<not> ?L" with 4 have "w = v - u" by fastforce
        with 1 have "int p = 4 * u * v + (v - u)\<^sup>2" by fast
        then have sqr : "int p = (v + u)\<^sup>2" by(simp add: power2_diff power2_sum)
        with int_prime_not_sqr[OF a] show False ..
      qed
    qed
  qed

  have card_eq : "card ?T = card ?U"
  proof -
    have 1: "2*card ?T = card ?S"
      by (smt (verit, ccfv_SIG) Int_iff fin_S inv1 involution_sub_card part1 subsetI)
    have "2*card ?U = card ?S"
      by (smt (verit, ccfv_SIG) Int_iff fin_S inv1 involution_sub_card part2 subsetI)
    with 1 show ?thesis by simp
  qed

  have fixp: "fixpoints_on ?U ?g = {((int p - 1) div 4, 1, 1)}" (is "?L = ?R")
  proof
    show "?L \<subseteq> ?R"
    proof(clarsimp simp: fixpoints_on_def)
      fix u v assume 1: "int p = 4 * u * v + v\<^sup>2" and 2: "0 < u" and 3: "0 < v"
      then have 4: "int p = v * (4 * u + v)"
        by(simp add: power2_eq_square int_distrib)
      have 5: "p = nat v * (4 * nat u + nat v)"
      proof(rule int_int_eq[THEN iffD1])
        show "int p = int (nat v * (4 * nat u + nat v))"
          using 2 3 proof(simp add: 4)
        qed
      qed
      note prime_factors[OF a 5]
      then show "u = (4 * u * v + v\<^sup>2 - 1) div 4 \<and> v = 1"
      proof
        assume "nat v = 1 \<and> 4 * nat u + nat v = p"
        with 2 and 3 have "v = 1 \<and> 4 * u + v = int p" by fastforce
        thus ?thesis by simp
      next
        assume "nat v = p \<and> 4 * nat u + nat v = 1"
        with 2 have False by fastforce
        thus ?thesis ..
      qed
    qed
  next
    show "?R \<subseteq> ?L"
    proof(clarsimp simp: fixpoints_on_def, rule conjI)
      show "int p = 4 * ((int p - 1) div 4) + 1"
      proof(subst dvd_mult_div_cancel)
        show "4 dvd int p - 1"
        proof(subst mod_eq_dvd_iff[THEN sym])
          show "int p mod 4 = 1 mod 4" by(simp add: nat_mod_int[OF b, simplified])
        qed
      next
        show "int p = int p - 1 + 1" by simp
      qed
    next
      show "0 < (int p - 1) div 4"
        using a b prime_gr4 by fastforce
    qed
  qed

  have cardS1 : "odd(card ?T)"
  proof(subst card_eq)
    show "odd(card ?U)"
      using add_diff_cancel_right' fin_S fixp inv2 involution_dom_fixpoints_parity by fastforce
  qed

  have fixp_ex : "\<exists>x. x \<in> fixpoints_on ?T ?h"
  proof(rule ccontr)
    assume "\<not> ?thesis" hence 1: "fixpoints_on ?T ?h = {}" by fast
    note involution_dom_card_sum[OF inv3, simplified 1]
    hence "even(card ?T)" by (simp add: fin_S)
    with cardS1 show False ..
  qed

  note fixp_ex then have "\<exists>u w. u > 0 \<and> w > 0 \<and> int p = 4 * u * u + w\<^sup>2"
    by(clarsimp simp: fixpoints_on_def, fast)
  then obtain u w where c: "u > 0 \<and> w > 0 \<and> int p = (2 * u)\<^sup>2 + w\<^sup>2"
    by(fastforce simp: power2_eq_square)
  hence "p = (nat(2 * u))\<^sup>2 + (nat w)\<^sup>2"
    by (smt (verit) int_nat_eq nat_int nat_int_add of_nat_power)
  thus ?thesis by fast

qed

end


section \<open>Specification\<close>

theory Goodstein_Lambda
  imports Main "../../../../SeLFiE"
begin

subsection \<open>Hereditary base representation\<close>

text \<open>We define a data type of trees and an evaluation function that sums siblings and
  exponentiates with respect to the given base on nesting.\<close>

datatype C = C (unC: "C list")

fun evalC where
  "evalC b (C []) = 0"
| "evalC b (C (x # xs)) = b^evalC b x + evalC b (C xs)"

value "evalC 2 (C [])" \<comment> \<open>$0$\<close>
value "evalC 2 (C [C []])" \<comment> \<open>$2^0 = 1$\<close>
value "evalC 2 (C [C [C []]])" \<comment> \<open>$2^1 = 2$\<close>
value "evalC 2 (C [C [], C []])" \<comment> \<open>$2^0 + 2^0 = 2^0 \cdot 2 = 2$; not in hereditary base $2$\<close>

text \<open>The hereditary base representation is characterized as trees (i.e., nested lists) whose
  lists have monotonically increasing evaluations, with fewer than @{term "b"} repetitions for
  each value. We will show later that this representation is unique.\<close>

inductive_set hbase for b where
  "C [] \<in> hbase b"
| "i \<noteq> 0 \<Longrightarrow> i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow>
   C ms \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
   C (replicate i n @ ms) \<in> hbase b"

text \<open>We can convert to and from natural numbers as follows.\<close>

definition H2N where
  "H2N b n = evalC b n"

text \<open>As we will show later, @{term "H2N b"} restricted to @{term "hbase n"} is bijective
  if @{prop "b \<ge> (2 :: nat)"}, so we can convert from natural numbers by taking the inverse.\<close>

definition N2H where
  "N2H b n = inv_into (hbase b) (H2N b) n"

subsection \<open>The Goodstein function\<close>

text \<open>We define a function that computes the length of the Goodstein sequence whose $c$-th element
  is $g_c = n$. Termination will be shown later, thereby establishing Goodstein's theorem.\<close>

function (sequential) goodstein :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "goodstein 0 n = 0"
  \<comment> \<open>we start counting at 1; also note that the initial base is @{term "c+1 :: nat"} and\<close>
  \<comment> \<open>hereditary base 1 makes no sense, so we have to avoid this case\<close>
| "goodstein c 0 = c"
| "goodstein c n = goodstein (c+1) (H2N (c+2) (N2H (c+1) n) - 1)"
  by pat_completeness auto

abbreviation \<G> where
  "\<G> n \<equiv> goodstein (Suc 0) n"

section \<open>Ordinals\<close>

text \<open>The following type contains countable ordinals, by the usual case distinction into 0,
  successor ordinal, or limit ordinal; limit ordinals are given by their fundamental sequence.
  Hereditary base @{term "b"} representations carry over to such ordinals by replacing each
  occurrence of the base by @{term "\<omega>"}.\<close>

datatype Ord = Z | S Ord | L "nat \<Rightarrow> Ord"

text \<open>Note that the following arithmetic operations are not correct for all ordinals. However, they
  will only be used in cases where they actually correspond to the ordinal arithmetic operations.\<close>

primrec addO where
  "addO n Z = n"
| "addO n (S m) = S (addO n m)"
| "addO n (L f) = L (\<lambda>i. addO n (f i))"

primrec mulO where
  "mulO n Z = Z"
| "mulO n (S m) = addO (mulO n m) n"
| "mulO n (L f) = L (\<lambda>i. mulO n (f i))"

definition \<omega> where
  "\<omega> = L (\<lambda>n. (S ^^ n) Z)"

primrec exp\<omega> where
  "exp\<omega> Z = S Z"
| "exp\<omega> (S n) = mulO (exp\<omega> n) \<omega>"
| "exp\<omega> (L f) = L (\<lambda>i. exp\<omega> (f i))"

subsection \<open>Evaluation\<close>

text \<open>Evaluating an ordinal number at base $b$ is accomplished by taking the $b$-th element of
  all fundamental sequences and interpreting zero and successor over the natural numbers.\<close>

primrec evalO where
  "evalO b Z = 0"
| "evalO b (S n) = Suc (evalO b n)"
| "evalO b (L f) = evalO b (f b)"

subsection \<open>Goodstein function and sequence\<close>

text \<open>We can define the Goodstein function very easily, but proving correctness will take a while.\<close>

primrec goodsteinO where
  "goodsteinO c Z = c"
| "goodsteinO c (S n) = goodsteinO (c+1) n"
| "goodsteinO c (L f) = goodsteinO c (f (c+2))"

primrec stepO where
  "stepO c Z = Z"
| "stepO c (S n) = n"
| "stepO c (L f) = stepO c (f (c+2))"

text \<open>We can compute a few values of the Goodstein sequence starting at $4$.\<close>

definition g4O where
  "g4O n = fold stepO [1..<Suc n] ((exp\<omega> ^^ 3) Z)"

value "map (\<lambda>n. evalO (n+2) (g4O n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties of evaluation\<close>

lemma evalO_addO [simp]:
  "evalO b (addO n m) = evalO b n + evalO b m"
  assert_SeLFiE_true is_defined_recursively_on_nth_n_mth_by_two_funs   [on["m"], arb[],rule[]]
  assert_SeLFiE_false is_defined_recursively_on_nth_n_mth_by_two_funs  [on["n"], arb[],rule[]]
  by (induct m) auto

lemma evalO_mulO [simp]:
  "evalO b (mulO n m) = evalO b n * evalO b m"
  by (induct m) auto

lemma evalO_n [simp]:
  "evalO b ((S ^^ n) Z) = n"
  all_induction_heuristic [on["n"], arb[],rule[]]
  by (induct n) auto

lemma evalO_\<omega> [simp]:
  "evalO b \<omega> = b"
  by (auto simp: \<omega>_def)

lemma evalO_exp\<omega> [simp]:
  "evalO b (exp\<omega> n) = b^(evalO b n)"
  by (induct n) auto

text \<open>Note that evaluation is useful for proving that @{type "Ord"} values are distinct:\<close>
notepad begin
  have "addO n (exp\<omega> m) \<noteq> n" for n m by (auto dest: arg_cong[of _ _ "evalO 1"])
end

subsection \<open>Arithmetic properties\<close>

lemma addO_Z [simp]:
  "addO Z n = n"
  by (induct n) auto

lemma addO_assoc [simp]:
  "addO n (addO m p) = addO (addO n m) p"
  by (induct p) auto

lemma mul0_distrib [simp]:
  "mulO n (addO p q) = addO (mulO n p) (mulO n q)"
  by (induct q) auto

lemma mulO_assoc [simp]:
  "mulO n (mulO m p) = mulO (mulO n m) p"
  by (induct p) auto

section \<open>Cantor normal form\<close>

text \<open>The previously introduced tree type @{type C} can be used to represent Cantor normal forms;
  they are trees (evaluated at base @{term \<omega>}) such that siblings are in non-decreasing order.
  One can think of this as hereditary base @{term \<omega>}. The plan is to mirror selected operations on
  ordinals in Cantor normal forms.\<close>

subsection \<open>Conversion to and from the ordinal type @{type Ord}\<close>

fun C2O where
  "C2O (C []) = Z"
| "C2O (C (n # ns)) = addO (C2O (C ns)) (exp\<omega> (C2O n))"

definition O2C where
  "O2C = inv C2O"

text \<open>We show that @{term C2O} is injective, meaning the inverse is unique.\<close>

lemma addO_exp\<omega>_inj:
  assumes "addO n (exp\<omega> m) = addO n' (exp\<omega> m')"
  shows "n = n'" and "m = m'"
proof -
  have "addO n (exp\<omega> m) = addO n' (exp\<omega> m') \<Longrightarrow> n = n'"

  assert_SeLFiE_true  if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs[on["m"], arb["m'"],rule[]]
  assert_SeLFiE_false if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs[on["m'"], arb["m"],rule[]](*very good*)

  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["m"], arb["m'"],rule[]]
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["m'"], arb["m"],rule[]](*unfortunate because assumption failed.*)
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["m"], arb["n"],rule[]] (*unfortunate because assumption failed.*)

  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change [on["m"], arb["m'"],rule[]]
  assert_SeLFiE_false  for_all_arbs_there_should_be_a_change [on["m"], arb["n"],rule[]]
  assert_SeLFiE_true   generalize_arguments_used_in_recursion [on["m"], arb["m'"],rule[]]
  all_induction_heuristic      [on["m"], arb["m'"],rule[]]
  all_generalization_heuristic [on["m"], arb["m'"],rule[]]
(*if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs*)
    by (induct m arbitrary: m'; case_tac m';
      force simp: \<omega>_def dest!: fun_cong[of _ _ 1])
  moreover have "addO n (exp\<omega> m) = addO n (exp\<omega> m') \<Longrightarrow> m = m'"
    apply (induct m arbitrary: n m'; case_tac m')
    apply (auto 0 3 simp: \<omega>_def intro: rangeI
      dest: arg_cong[of _ _ "evalO 1"] fun_cong[of _ _ 0] fun_cong[of _ _ 1])[8] (* 1 left *)
    by simp (meson ext rangeI)
  ultimately show "n = n'" and "m = m'" using assms by simp_all
qed

lemma C2O_inj:
  "C2O n = C2O m \<Longrightarrow> n = m"
  semantic_induct
  assert_SeLFiE_true  if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs[on["n"], arb["m"],rule[]](*good*)
  assert_SeLFiE_false if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs[on["m"], arb["n"],rule[]](*very good*)

  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["n"], arb["m"],rule[]]
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["m"], arb["n"],rule[]] (*unfortunate because assumption failed.*)
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["m"], arb["n"],rule[]] (*unfortunate because assumption failed.*)

  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change [on["n"], arb["m"],rule[]]
  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change [on["m"], arb["n"],rule[]]  (*a little unfortunate*)
  assert_SeLFiE_true   generalize_arguments_used_in_recursion [on["n"], arb["m"],rule[]]
  by (induct n arbitrary: m rule: C2O.induct; case_tac m rule: C2O.cases)
    (auto dest: addO_exp\<omega>_inj arg_cong[of _ _ "evalO 1"])

lemma O2C_C2O [simp]:
  "O2C (C2O n) = n"
  by (auto intro!: inv_f_f simp: O2C_def inj_def C2O_inj)

lemma O2C_Z [simp]:
  "O2C Z = C []"
  using O2C_C2O[of "C []", unfolded C2O.simps] .

lemma C2O_replicate:
  "C2O (C (replicate i n)) = mulO (exp\<omega> (C2O n)) ((S ^^ i) Z)" semantic_induct
  all_induction_heuristic      [on["i"], arb[],rule[]]
  all_generalization_heuristic [on["i"], arb[],rule[]]
  by (induct i) auto

lemma C2O_app:
  "C2O (C (xs @ ys)) = addO (C2O (C ys)) (C2O (C xs))"
  all_induction_heuristic      [on["xs"], arb["ys"],rule[]]
  all_generalization_heuristic [on["xs"], arb["ys"],rule[]]
  by (induct xs arbitrary: ys) auto

subsection \<open>Evaluation\<close>

lemma evalC_def':
  "evalC b n = evalO b (C2O n)" semantic_induct
  by (induct n rule: C2O.induct) auto

lemma evalC_app [simp]:
  "evalC b (C (ns @ ms)) = evalC b (C ns) + evalC b (C ms)"
  by (induct ns) auto

lemma evalC_replicate [simp]:
  "evalC b (C (replicate c n)) = c * evalC b (C [n])"
  semantic_induct
  all_induction_heuristic      [on["c"], arb[],rule[]]
  all_generalization_heuristic [on["c"], arb[],rule[]]
  by (induct c) auto

subsection \<open>Transfer of the @{type Ord} induction principle to @{type C}\<close>

fun funC where \<comment> \<open>@{term funC} computes the fundamental sequence on @{type C}\<close>
  "funC (C []) = (\<lambda>i. [C []])"
| "funC (C (C [] # ns)) = (\<lambda>i. replicate i (C ns))"
| "funC (C (n # ns)) = (\<lambda>i. [C (funC n i @ ns)])"

lemma C2O_cons:
  "C2O (C (n # ns)) =
    (if n = C [] then S (C2O (C ns)) else L (\<lambda>i. C2O (C (funC n i @ ns))))"semantic_induct
  by (induct n arbitrary: ns rule: funC.induct)
    (simp_all add: \<omega>_def C2O_replicate C2O_app flip: exp\<omega>_addO)

lemma C_Ord_induct:
  assumes "P (C [])"
  and "\<And>ns. P (C ns) \<Longrightarrow> P (C (C [] # ns))"
  and "\<And>n ns ms. (\<And>i. P (C (funC (C (n # ns)) i @ ms))) \<Longrightarrow>
    P (C (C (n # ns) # ms))"
  shows "P n"
proof -
  have "\<forall>n. C2O n = m \<longrightarrow> P n" for m semantic_induct
    by (induct m; intro allI; case_tac n rule: funC.cases)
      (auto simp: C2O_cons simp del: C2O.simps(2) intro: assms)
  then show ?thesis by simp
qed

subsection \<open>Goodstein function and sequence on @{type C}\<close>

function (domintros) goodsteinC where
  "goodsteinC c (C []) = c"
| "goodsteinC c (C (C [] # ns)) = goodsteinC (c+1) (C ns)"
| "goodsteinC c (C (C (n # ns) # ms)) =
    goodsteinC c (C (funC (C (n # ns)) (c+2) @ ms))"
  by pat_completeness auto

termination
proof -
  have "goodsteinC_dom (c, n)" for c n semantic_induct
    by (induct n arbitrary: c rule: C_Ord_induct) (auto intro: goodsteinC.domintros)
  then show ?thesis by simp
qed

lemma goodsteinC_def':
  "goodsteinC c n = goodsteinO c (C2O n)"semantic_induct
  by (induct c n rule: goodsteinC.induct) (simp_all add: C2O_cons del: C2O.simps(2))

function (domintros) stepC where
  "stepC c (C []) = C []"
| "stepC c (C (C [] # ns)) = C ns"
| "stepC c (C (C (n # ns) # ms)) =
    stepC c (C (funC (C (n # ns)) (Suc (Suc c)) @ ms))"
  by pat_completeness auto

termination
proof -
  have "stepC_dom (c, n)" for c n
    by (induct n arbitrary: c rule: C_Ord_induct) (auto intro: stepC.domintros)
  then show ?thesis by simp
qed

definition g4C where
  "g4C n = fold stepC [1..<Suc n] (C [C [C [C []]]])"

value "map (\<lambda>n. evalC (n+2) (g4C n)) [0..<10]"
\<comment> \<open>@{value "[4, 26, 41, 60, 83, 109, 139, 173, 211, 253] :: nat list"}\<close>

subsection \<open>Properties\<close>

lemma stepC_def':
  "stepC c n = O2C (stepO c (C2O n))" semantic_induct
  all_induction_heuristic      [on["c", "n"], arb[],rule["stepC.induct"]]
  all_generalization_heuristic [on["c", "n"], arb[],rule["stepC.induct"]]
  by (induct c n rule: stepC.induct) (simp_all add: C2O_cons del: C2O.simps(2))

lemma funC_ne [simp]:
  "funC m (Suc n) \<noteq> []"
  by (cases m rule: funC.cases) simp_all

lemma evalC_funC [simp]:
  "evalC b (C (funC n b)) = evalC b (C [n])" semantic_induct
  by (induct n rule: funC.induct) simp_all

lemma stepC_app [simp]:
  "n \<noteq> C [] \<Longrightarrow> stepC c (C (unC n @ ns)) = C (unC (stepC c n) @ ns)" semantic_induct
  by (induct n arbitrary: ns rule: stepC.induct) simp_all

lemma stepC_cons [simp]:
  "ns \<noteq> [] \<Longrightarrow> stepC c (C (n # ns)) = C (unC (stepC c (C [n])) @ ns)"
  using stepC_app[of "C[n]" c ns] by simp

lemma stepC_dec:
  "n \<noteq> C [] \<Longrightarrow> Suc (evalC (Suc (Suc c)) (stepC c n)) = evalC (Suc (Suc c)) n" semantic_induct
  by (induct c n rule: stepC.induct) simp_all

lemma stepC_dec':
  "n \<noteq> C [] \<Longrightarrow> evalC (c+3) (stepC c n) < evalC (c+3) n" semantic_induct
proof (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  have "evalC (c+3) (C (funC (C (n # ns)) (Suc (Suc c)))) \<le>
      (c+3) ^ ((c+3) ^ evalC (c+3) n + evalC (c+3) (C ns))" semantic_induct(*failed*)
    by (induct n rule: funC.induct) (simp_all add: distrib_right)
  then show ?case using 3 by simp
qed simp_all

section \<open>Hereditary base @{term b} representation\<close>

text \<open>We now turn to properties of the @{term "hbase b"} subset of trees.\<close>

subsection \<open>Uniqueness\<close>

text \<open>We show uniqueness of the hereditary base representation by showing that @{term "evalC b"}
  restricted to @{term "hbase b"} is injective.\<close>

lemma hbaseI2:
  "i < b \<Longrightarrow> n \<in> hbase b \<Longrightarrow> C m \<in> hbase b \<Longrightarrow>
    (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n < evalC b m') \<Longrightarrow>
    C (replicate i n @ m) \<in> hbase b"
  by (cases i) (auto intro: hbase.intros simp del: replicate.simps(2))

lemmas hbase_singletonI =
  hbase.intros(2)[of 1 "Suc (Suc b)" for b, OF _ _ _ hbase.intros(1), simplified]

lemma hbase_hd:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> hd ns \<in> hbase b"
  by (cases rule: hbase.cases) auto

lemmas hbase_hd' [dest] = hbase_hd[of "n # ns" for n ns, simplified]

lemma hbase_tl:
  "C ns \<in> hbase b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase.cases) (auto intro: hbaseI2)

lemmas hbase_tl' [dest] = hbase_tl[of "n # ns" for n ns, simplified]

lemma hbase_elt [dest]:
  "C ns \<in> hbase b \<Longrightarrow> n \<in> set ns \<Longrightarrow> n \<in> hbase b"semantic_induct(*almost failed.*)
  by (induct ns) auto

lemma evalC_sum_list:
  "evalC b (C ns) = sum_list (map (\<lambda>n. b^evalC b n) ns)"(*failed!*)semantic_induct
  by (induct ns) auto

lemma sum_list_replicate:
  "sum_list (replicate n x) = n * x" semantic_induct
  by (induct n) auto

lemma base_red:
  fixes b :: nat
  assumes n: "\<And>n'. n' \<in> set ns \<Longrightarrow> n < n'" "i < b" "i \<noteq> 0"
  and m: "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
  and s: "i * b^n + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
  shows "i = j \<and> n = m"
  using n(1) m(1) s semantic_induct
(*21.321s elapsed time, 193.864s cpu time, 13.175s GC time*)
(*\<rightarrow> 8.978s elapsed time, 99.331s cpu time, 0.804s GC time after working on Is_Nth_Argument_Of*)
(*\<rightarrow> 5.831s elapsed time, 33.797s cpu time, 0.207s GC time after sharing the construction of outer-table and outer-domain w/o resorting to reference.*)
(*\<rightarrow> 4.014s elapsed time, 22.913s cpu time, 0.120s GC time after having only one outer-table for many ind_mods in APply_SeLFiE.ML *)
proof (induct n arbitrary: m ns ms)
  { fix ns ms :: "nat list" and i j m :: nat
    assume n': "\<And>n'. n' \<in> set ns \<Longrightarrow> 0 < n'" "i < b" "i \<noteq> 0"
    assume m': "\<And>m'. m' \<in> set ms \<Longrightarrow> m < m'" "j < b" "j \<noteq> 0"
    assume s': "i * b^0 + sum_list (map (\<lambda>n. b^n) ns) = j * b^m + sum_list (map (\<lambda>n. b^n) ms)"
    obtain x where [simp]: "sum_list (map ((^) b) ns) = x*b"
      using n'(1)
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ns)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    obtain y where [simp]: "sum_list (map ((^) b) ms) = y*b"
      using order.strict_trans1[OF le0 m'(1)]
      by (intro that[of "sum_list (map (\<lambda>n. b^(n-1)) ms)"])
        (simp add: ac_simps flip: sum_list_const_mult power_Suc cong: map_cong)
    have [simp]: "m = 0"
      using s' n'(2,3)
      by (cases m, simp_all)
        (metis Groups.mult_ac(2) Groups.mult_ac(3) Suc_pred div_less mod_div_mult_eq
          mod_mult_self2 mod_mult_self2_is_0 mult_zero_right nat.simps(3))
    have "i = j \<and> 0 = m" using s' n'(2,3) m'(2,3)
      by simp (metis div_less mod_div_mult_eq mod_mult_self1)
  } note BASE = this
  {
    case 0 show ?case by (rule BASE; fact)
  next
    case (Suc n m')
    have "j = i \<and> 0 = Suc n" if "m' = 0" using Suc(2-4)
      by (intro BASE[of ms j ns "Suc n" i]) (simp_all add: ac_simps that n(2,3) m(2,3))
    then obtain m where m' [simp]: "m' = Suc m"
      by (cases m') auto
    obtain ns' where [simp]: "ns = map Suc ns'" "\<And>n'. n' \<in> set ns' \<Longrightarrow> n < n'"
      using Suc(2) less_trans[OF zero_less_Suc Suc(2)]
      by (intro that[of "map (\<lambda>n. n-1) ns"]; force cong: map_cong)
    obtain ms' where [simp]: "ms = map Suc ms'" "\<And>m'. m' \<in> set ms' \<Longrightarrow> m < m'"
      using Suc(3)[unfolded m'] less_trans[OF zero_less_Suc Suc(3)[unfolded m']]
      by (intro that[of "map (\<lambda>n. n-1) ms"]; force cong: map_cong)
    have *: "b * x = b * y \<Longrightarrow> x = y" for x y using n(2) by simp
    have "i = j \<and> n = m"
    proof (rule Suc(1)[of "map (\<lambda>n. n-1) ns" "map (\<lambda>n. n-1) ms" m, OF _ _ *], goal_cases)
      case 3 show ?case using Suc(4) unfolding add_mult_distrib2
        by (simp add: comp_def ac_simps flip: sum_list_const_mult)
    qed simp_all
    then show ?case by simp
  }
qed

lemma evalC_inj_on_hbase:
  "n \<in> hbase b \<Longrightarrow> m \<in> hbase b \<Longrightarrow> evalC b n = evalC b m \<Longrightarrow> n = m"(*!*)
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["n"], arb["m"],rule[]]
  assert_SeLFiE_false  ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["n"], arb[],rule[]]
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq [on["m"], arb["n"],rule[]] (*unfortunate*)
  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change [on["n"], arb["m"],rule[]]
  assert_SeLFiE_false  for_all_arbs_there_should_be_a_change [on["n"], arb["b"],rule[]]
  semantic_induct(*failed*)
  assert_SeLFiE_true   if_defined_with_inductive_set_in_meta_premise_then_set_induction [on["n"], arb["m"],set["Goodstein_Lambda.hbase"]]
proof (induct n arbitrary: m rule: hbase.induct)
  case 1
  then show ?case by (cases m rule: hbase.cases) simp_all
next
  case (2 i n ns m')
  obtain j m ms where [simp]: "m' = C (replicate j m @ ms)" and
    m: "j \<noteq> 0" "j < b" "m \<in> hbase b" "C ms \<in> hbase b" "\<And>m'. m' \<in> set ms \<Longrightarrow> evalC b m < evalC b m'"
    using 2(8,1,2,9) by (cases m' rule: hbase.cases) simp_all
  have "i = j \<and> evalC b n = evalC b m" using 2(1,2,7,9) m(1,2,5)
    by (intro base_red[of "map (evalC b) ns" _ _ b "map (evalC b) ms"])
      (auto simp: comp_def evalC_sum_list sum_list_replicate)
  then show ?case
    using 2(4)[OF m(3)] 2(6)[OF m(4)] 2(9) by simp
qed

subsection \<open>Correctness of @{const stepC}\<close>

text \<open>We show that @{term "stepC c"} preserves hereditary base @{term "c + 2 :: nat"}
  representations. In order to cover intermediate results produced by @{const stepC}, we extend
  the hereditary base representation to allow the least significant digit to be equal to @{term b},
  which essentially means that we may have an extra sibling in front on every level.\<close>

inductive_set hbase_ext for b where
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase_ext b"
| "n \<in> hbase_ext b \<Longrightarrow>
   C m \<in> hbase b \<Longrightarrow> (\<And>m'. m' \<in> set m \<Longrightarrow> evalC b n \<le> evalC b m') \<Longrightarrow>
   C (n # m) \<in> hbase_ext b"

lemma hbase_ext_hd' [dest]:
  "C (n # ns) \<in> hbase_ext b \<Longrightarrow> n \<in> hbase_ext b"
  by (cases rule: hbase_ext.cases) (auto intro: hbase_ext.intros(1))

lemma hbase_ext_tl:
  "C ns \<in> hbase_ext b \<Longrightarrow> ns \<noteq> [] \<Longrightarrow> C (tl ns) \<in> hbase b"
  by (cases "C ns" b rule: hbase_ext.cases; cases ns) (simp_all add: hbase_tl')

lemmas hbase_ext_tl' [dest] = hbase_ext_tl[of "n # ns" for n ns, simplified]

lemma hbase_funC:
  "c \<noteq> 0 \<Longrightarrow> C (n # ns) \<in> hbase_ext (Suc c) \<Longrightarrow>
    C (funC n (Suc c) @ ns) \<in> hbase_ext (Suc c)"semantic_induct(*did not fail.but needs attention*)
proof (induct n arbitrary: ns rule: funC.induct)
  case (2 ms)
  have [simp]: "evalC (Suc c) (C ms) < evalC (Suc c) m'" if "m' \<in> set ns" for m'
    using 2(2)
  proof (cases rule: hbase_ext.cases)
    case 1 then show ?thesis using that
      by (cases rule: hbase.cases, case_tac i) (auto intro: Suc_lessD)
  qed (auto simp: Suc_le_eq that)
  show ?case using 2
    by (auto 0 4 intro: hbase_ext.intros hbase.intros(2) order.strict_implies_order)
next
  case (3 m ms ms')
  show ?case
    unfolding funC.simps append_Cons append_Nil
  proof (rule hbase_ext.intros(2), goal_cases 31 32 33)
    case (33 m')
    show ?case using 3(3)
    proof (cases rule: hbase_ext.cases)
      case 1 show ?thesis using 1 3(1,2) 33
        by (cases rule: hbase.cases, case_tac i) (auto intro: less_or_eq_imp_le)
    qed (insert 33, simp)
  qed (insert 3, blast+)
qed auto

lemma stepC_sound:
  "n \<in> hbase_ext (Suc (Suc c)) \<Longrightarrow> stepC c n \<in> hbase (Suc (Suc c))"semantic_induct(*did not fail, but needs attention*)
proof (induct c n rule: stepC.induct)
  case (3 c n ns ms)
  show ?case using 3(2,1)
    by (cases rule: hbase_ext.cases; unfold stepC.simps) (auto intro: hbase_funC)
qed (auto intro: hbase.intros)

subsection \<open>Surjectivity of @{const evalC}\<close>

text \<open>Note that the base must be at least @{term "2 :: nat"}.\<close>

lemma evalC_surjective:
  "\<exists>n' \<in> hbase (Suc (Suc b)). evalC (Suc (Suc b)) n' = n"semantic_induct(*almost failed*)
proof (induct n)
  case 0 then show ?case by (auto intro: bexI[of _ "C []"] hbase.intros)
next
  have [simp]: "Suc x \<le> Suc (Suc b)^x" for x semantic_induct by (induct x) auto
  case (Suc n)
  then guess n' by (rule bexE)
  then obtain n' j where n': "Suc n \<le> j" "j = evalC (Suc (Suc b)) n'" "n' \<in> hbase (Suc (Suc b))"
    by (intro that[of _ "C [n']"])
      (auto intro!: intro: hbase.intros(1) dest!: hbaseI2[of 1 "b+2" n' "[]", simplified])
  then show ?case
  proof (induct rule: inc_induct)
    case (step m)
    guess n' using step(3)[OF step(4,5)] by (rule bexE)
    then show ?case using stepC_dec[of n' "b"]
      by (cases n' rule: C2O.cases) (auto intro: stepC_sound hbase_ext.intros(1))
  qed blast
qed

subsection \<open>Monotonicity of @{const hbase}\<close>

text \<open>Here we show that every hereditary base @{term "b :: nat"} number is also a valid hereditary
  base @{term "b+1 :: nat"} number. This is not immediate because we have to show that monotonicity
  of siblings is preserved.\<close>

lemma hbase_evalC_mono:
  assumes "n \<in> hbase b" "m \<in> hbase b" "evalC b n < evalC b m"
  shows "evalC (Suc b) n < evalC (Suc b) m"
proof (cases "b < 2")
  case True show ?thesis using assms(2,3) True by (cases rule: hbase.cases) simp_all
next
  case False
  then obtain b' where [simp]: "b = Suc (Suc b')"
    by (auto simp: numeral_2_eq_2 not_less_eq dest: less_imp_Suc_add)
  show ?thesis using assms(3,1,2) semantic_induct
  proof (induct "evalC b n" "evalC b m" arbitrary: n m rule: less_Suc_induct)
    case 1 then show ?case using stepC_sound[of m b', OF hbase_ext.intros(1)]
      stepC_dec[of m b'] stepC_dec'[of m b'] evalC_inj_on_hbase
      by (cases m rule: C2O.cases) (fastforce simp: eval_nat_numeral)+
  next
    case (2 j) then show ?case
      using evalC_surjective[of b' j] less_trans by fastforce
  qed
qed

lemma hbase_mono:
  "n \<in> hbase b \<Longrightarrow> n \<in> hbase (Suc b)"
  semantic_induct
  by (induct n rule: hbase.induct) (auto 0 3 intro: hbase.intros hbase_evalC_mono)

subsection \<open>Conversion to and from @{type nat}\<close>

text \<open>We have previously defined @{term "H2N b = evalC b"} and @{term "N2H b"} as its inverse.
  So we can use the injectivity and surjectivity of @{term "evalC b"} for simplification.\<close>

lemma N2H_inv:
  "n \<in> hbase b \<Longrightarrow> N2H b (H2N b n) = n"
  using evalC_inj_on_hbase
  by (auto simp: N2H_def H2N_def[abs_def] inj_on_def intro!: inv_into_f_f)

lemma N2H_eqI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n = m \<Longrightarrow> N2H (Suc (Suc b)) m = n"
  using N2H_inv by blast

lemma N2H_neI:
  "n \<in> hbase (Suc (Suc b)) \<Longrightarrow>
   H2N (Suc (Suc b)) n \<noteq> m \<Longrightarrow> N2H (Suc (Suc b)) m \<noteq> n"
  using H2N_inv by blast

lemma N2H_0 [simp]:
  "N2H (Suc (Suc c)) 0 = C []"
  using H2N_def N2H_inv hbase.intros(1) by fastforce

lemma N2H_nz [simp]:
  "0 < n \<Longrightarrow> N2H (Suc (Suc c)) n \<noteq> C []"
  by (metis N2H_0 H2N_inv neq0_conv)

section \<open>The Goodstein function revisited\<close>

text \<open>We are now ready to prove termination of the Goodstein function @{const goodstein} as well
  as its relation to @{const goodsteinC} and @{const goodsteinO}.\<close>

lemma goodstein_aux:
  "goodsteinC (Suc c) (N2H (Suc (Suc c)) (Suc n)) =
    goodsteinC (c+2) (N2H (c+3) (H2N (c+3) (N2H (c+2) (n+1)) - 1))"
proof -
  have [simp]: "n \<noteq> C [] \<Longrightarrow> goodsteinC c n = goodsteinC (c+1) (stepC c n)" for c n
    by (induct c n rule: stepC.induct) simp_all
  have [simp]: "stepC (Suc c) (N2H (Suc (Suc c)) (Suc n)) \<in> hbase (Suc (Suc (Suc c)))"
    by (metis H2N_def N2H_inv evalC_surjective hbase_ext.intros(1) hbase_mono stepC_sound)
  show ?thesis
    using arg_cong[OF stepC_dec[of "N2H (c+2) (n+1)" "c+1", folded H2N_def], of "\<lambda>n. N2H (c+3) (n-1)"]
    by (simp add: eval_nat_numeral N2H_inv)
qed

termination goodstein
proof (relation "measure (\<lambda>(c, n). goodsteinC c (N2H (c+1) n) - c)", goal_cases _ 1)
  case (1 c n)
  have *: "goodsteinC c n \<ge> c" for c n semantic_induct
    by (induct c n rule: goodsteinC.induct) simp_all
  show ?case by (simp add: goodstein_aux eval_nat_numeral) (meson Suc_le_eq diff_less_mono2 lessI *)
qed simp

lemma goodstein_def':
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinC c (N2H (c+1) n)"semantic_induct
  by (induct c n rule: goodstein.induct) (simp_all add: goodstein_aux eval_nat_numeral)

lemma goodstein_impl:
  "c \<noteq> 0 \<Longrightarrow> goodstein c n = goodsteinO c (C2O (N2H (c+1) n))"
  \<comment> \<open>but note that @{term N2H} is not executable as currently defined\<close>
  using goodstein_def'[unfolded goodsteinC_def'] .

lemma goodstein_16:
  "\<G> 16 = goodsteinO 1 (exp\<omega> (exp\<omega> (exp\<omega> (exp\<omega> Z))))"
proof -
  have "N2H (Suc (Suc 0)) 16 = C [C [C [C [C []]]]]"
    by (auto simp: H2N_def intro!: N2H_eqI hbase_singletonI hbase.intros(1))
  then show ?thesis by (simp add: goodstein_impl)
qed

section \<open>Translation to $\lambda$-calculus\<close>

text \<open>We define Church encodings for @{type nat} and @{type Ord}. Note that we are basically in a
  Hindley-Milner type system, so we cannot use a proper polymorphic type. We can still express
  Church encodings as folds over values of the original type.\<close>

abbreviation Z\<^sub>N where "Z\<^sub>N \<equiv> (\<lambda>s z. z)"
abbreviation S\<^sub>N where "S\<^sub>N \<equiv> (\<lambda>n s z. s (n s z))"

primrec fold_nat ("\<langle>_\<rangle>\<^sub>N") where
  "\<langle>0\<rangle>\<^sub>N = Z\<^sub>N"
| "\<langle>Suc n\<rangle>\<^sub>N = S\<^sub>N \<langle>n\<rangle>\<^sub>N"

lemma one\<^sub>N:
  "\<langle>1\<rangle>\<^sub>N = (\<lambda>x. x)"
  by simp

abbreviation Z\<^sub>O where "Z\<^sub>O \<equiv> (\<lambda>z s l. z)"
abbreviation S\<^sub>O where "S\<^sub>O \<equiv> (\<lambda>n z s l. s (n z s l))"
abbreviation L\<^sub>O where "L\<^sub>O \<equiv> (\<lambda>f z s l. l (\<lambda>i. f i z s l))"

primrec fold_Ord ("\<langle>_\<rangle>\<^sub>O") where
  "\<langle>Z\<rangle>\<^sub>O = Z\<^sub>O"
| "\<langle>S n\<rangle>\<^sub>O = S\<^sub>O \<langle>n\<rangle>\<^sub>O"
| "\<langle>L f\<rangle>\<^sub>O = L\<^sub>O (\<lambda>i. \<langle>f i\<rangle>\<^sub>O)"

text \<open>The following abbreviations and lemmas show how to implement the arithmetic functions and
  the Goodstein function on a Church-encoded @{type Ord} in lambda calculus.\<close>

abbreviation (input) add\<^sub>O where
  "add\<^sub>O n m \<equiv> (\<lambda>z s l. m (n z s l) s l)"

lemma add\<^sub>O:
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O" semantic_induct
  by (induct m) simp_all

abbreviation (input) mul\<^sub>O where
  "mul\<^sub>O n m \<equiv> (\<lambda>z s l. m z (\<lambda>m. n m s l) l)"

lemma mul\<^sub>O:
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O" semantic_induct
  by (induct m) (simp_all add: add\<^sub>O)

abbreviation (input) \<omega>\<^sub>O where
  "\<omega>\<^sub>O \<equiv> (\<lambda>z s l. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N s z))"

lemma \<omega>\<^sub>O:
  "\<langle>\<omega>\<rangle>\<^sub>O = \<omega>\<^sub>O"
proof -
  have [simp]: "\<langle>(S ^^ i) Z\<rangle>\<^sub>O z s l = \<langle>i\<rangle>\<^sub>N s z" for i z s l by (induct i) simp_all
  show ?thesis by (simp add: \<omega>_def)
qed

abbreviation (input) exp\<omega>\<^sub>O where
  "exp\<omega>\<^sub>O n \<equiv> (\<lambda>z s l. n s (\<lambda>x z. l (\<lambda>n. \<langle>n\<rangle>\<^sub>N x z)) (\<lambda>f z. l (\<lambda>n. f n z)) z)"

lemma exp\<omega>\<^sub>O:
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"semantic_induct
  by (induct n) (simp_all add: mul\<^sub>O \<omega>\<^sub>O)

abbreviation (input) goodstein\<^sub>O where
  "goodstein\<^sub>O \<equiv> (\<lambda>c n. n (\<lambda>x. x) (\<lambda>n m. n (m + 1)) (\<lambda>f m. f (m + 2) m) c)"

lemma goodstein\<^sub>O:
  "goodsteinO c n = goodstein\<^sub>O c \<langle>n\<rangle>\<^sub>O"
  semantic_induct
  all_induction_heuristic [on["n"], arb["c"],rule[]]
  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq                                  [on["n"], arb["c"],rule[]]
  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change                                   [on["n"], arb["c"],rule[]]
  assert_SeLFiE_true   if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs [on["n"], arb["c"],rule[]]
  assert_SeLFiE_true   generalize_arguments_used_in_recursion                                  [on["n"], arb["c"],rule[]]

  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq                                   [on["n"], arb[],rule[]](*a little unfortunate*)
  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change                                    [on["n"], arb[],rule[]](*a little unfortunate*)
  assert_SeLFiE_true   if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs  [on["n"], arb[],rule[]](*a little unfortunate*)
  assert_SeLFiE_false  generalize_arguments_used_in_recursion                                   [on["n"], arb[],rule[]]

  assert_SeLFiE_true   ind_on_lhs_of_eq_then_arb_on_rhs_of_eq                                  [on["c"], arb["n"],rule[]](*a little unfortunate*)
  assert_SeLFiE_true   for_all_arbs_there_should_be_a_change                                   [on["c"], arb["n"],rule[]](*a little unfortunate*)
  assert_SeLFiE_true   if_part_of_lhs_n_part_of_rhs_of_eq_is_induct_then_induct_on_part_of_lhs [on["c"], arb["n"],rule[]](*a little unfortunate*)
  assert_SeLFiE_false  generalize_arguments_used_in_recursion                                  [on["c"], arb["n"],rule[]]
  by (induct n arbitrary: c) simp_all

text \<open>Note that modeling Church encodings with folds is still limited. For example, the meaningful
  expression @{text "\<langle>n\<rangle>\<^sub>N exp\<omega>\<^sub>O Z\<^sub>O"} cannot be typed in Isabelle/HOL, as that would require rank-2
  polymorphism.\<close>

subsection \<open>Alternative: free theorems\<close>

text \<open>The following is essentially the free theorem for Church-encoded @{type Ord} values.\<close>

lemma freeOrd:
  assumes "\<And>n. h (s n) = s' (h n)" and "\<And>f. h (l f) = l' (\<lambda>i. h (f i))"
  shows "h (\<langle>n\<rangle>\<^sub>O z s l) = \<langle>n\<rangle>\<^sub>O (h z) s' l'"semantic_induct
  by (induct n) (simp_all add: assms)

text \<open>Each of the following proofs first states a naive definition of the corresponding function
  (which is proved correct by induction), from which we then derive the optimized version using
  the free theorem, by (conditional) rewriting (without induction).\<close>

lemma add\<^sub>O':
  "\<langle>addO n m\<rangle>\<^sub>O = add\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>addO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O \<langle>n\<rangle>\<^sub>O S\<^sub>O L\<^sub>O"semantic_induct
    by (induct m) simp_all
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma mul\<^sub>O':
  "\<langle>mulO n m\<rangle>\<^sub>O = mul\<^sub>O \<langle>n\<rangle>\<^sub>O \<langle>m\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>mulO n m\<rangle>\<^sub>O = \<langle>m\<rangle>\<^sub>O Z\<^sub>O (\<lambda>m. add\<^sub>O m \<langle>n\<rangle>\<^sub>O) L\<^sub>O"
    by (induct m) (simp_all add: add\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: freeOrd[where h = "\<lambda>n. n _ _ _"])
qed

lemma exp\<omega>\<^sub>O':
  "\<langle>exp\<omega> n\<rangle>\<^sub>O = exp\<omega>\<^sub>O \<langle>n\<rangle>\<^sub>O"
proof -
  have [simp]: "\<langle>exp\<omega> n\<rangle>\<^sub>O = \<langle>n\<rangle>\<^sub>O (S\<^sub>O Z\<^sub>O) (\<lambda>m. mul\<^sub>O m \<omega>\<^sub>O) L\<^sub>O"semantic_induct
    by (induct n) (simp_all add: mul\<^sub>O \<omega>\<^sub>O)
  show ?thesis
    by (intro ext) (simp add: fun_cong[OF freeOrd[where h = "\<lambda>n z. n z _ _"]])
qed

end