(*  Title:   TwiceFieldDifferentiable.thy
    Authors: Jacques Fleuriot and Filip Smola, University of Edinburgh, 2020
*)

section \<open>Twice Field Differentiable\<close>

theory TwiceFieldDifferentiable
  imports "HOL-Analysis.Analysis"
begin

subsection\<open>Differentiability on a Set\<close>

text\<open>A function is differentiable on a set iff it is differentiable at any point within that set.\<close>
definition field_differentiable_on :: "('a \<Rightarrow> 'a::real_normed_field) \<Rightarrow> 'a set \<Rightarrow> bool"
  (infix "field'_differentiable'_on" 50)
  where "f field_differentiable_on s \<equiv> \<forall>x\<in>s. f field_differentiable (at x within s)"

text\<open>This is preserved for subsets.\<close>
lemma field_differentiable_on_subset:
  assumes "f field_differentiable_on S"
      and "T \<subseteq> S"
    shows "f field_differentiable_on T"
  by (meson assms field_differentiable_on_def field_differentiable_within_subset in_mono)

subsection\<open>Twice Differentiability\<close>
text\<open>
  Informally, a function is twice differentiable at x iff it is differentiable on some neighbourhood
  of x and its derivative is differentiable at x.
\<close>
definition twice_field_differentiable_at :: "['a \<Rightarrow> 'a::real_normed_field, 'a ] \<Rightarrow> bool"
  (infixr "(twice'_field'_differentiable'_at)" 50)
  where "f twice_field_differentiable_at x \<equiv>
           \<exists>S. f field_differentiable_on S \<and> x \<in> interior S \<and> (deriv f) field_differentiable (at x)"

lemma once_field_differentiable_at:
  "f twice_field_differentiable_at x \<Longrightarrow> f field_differentiable (at x)"
  by (metis at_within_interior field_differentiable_on_def interior_subset subsetD twice_field_differentiable_at_def)

lemma deriv_field_differentiable_at:
  "f twice_field_differentiable_at x \<Longrightarrow> deriv f field_differentiable (at x)"
  using twice_field_differentiable_at_def by blast

text\<open>
  For a composition of two functions twice differentiable at x, the chain rule eventually holds on
  some neighbourhood of x.
\<close>
lemma eventually_deriv_compose:
  assumes "\<exists>S. f field_differentiable_on S \<and> x \<in> interior S"
      and "g twice_field_differentiable_at (f x)"
    shows "\<forall>\<^sub>F x in nhds x. deriv (\<lambda>x. g (f x)) x = deriv g (f x) * deriv f x"
proof -
  obtain S S'
   where Df_on_S:  "f field_differentiable_on S" and x_int_S: "x \<in> interior S"
     and Dg_on_S': "g field_differentiable_on S'" and fx_int_S': "f x \<in> interior S'"
    using assms twice_field_differentiable_at_def by blast

  let ?T = "{x \<in> interior S. f x \<in> interior S'}"

  have "continuous_on (interior S) f"
    by (meson Df_on_S continuous_on_eq_continuous_within continuous_on_subset field_differentiable_imp_continuous_at
         field_differentiable_on_def interior_subset)
  then have "open (interior S \<inter> {x. f x \<in> interior S'})"
    by (metis continuous_open_preimage open_interior vimage_def)
  then have x_int_T: "x \<in> interior ?T"
    by (metis (no_types) Collect_conj_eq Collect_mem_eq Int_Collect fx_int_S' interior_eq x_int_S)
  moreover have  Dg_on_fT: "g field_differentiable_on f`?T"
   by (metis (no_types, lifting) Dg_on_S' field_differentiable_on_subset image_Collect_subsetI interior_subset)
  moreover have Df_on_T: "f field_differentiable_on ?T"
    using  field_differentiable_on_subset Df_on_S
    by (metis Collect_subset interior_subset)
  moreover have "\<forall>x \<in> interior ?T. deriv (\<lambda>x. g (f x)) x = deriv g (f x) * deriv f x"
  proof
    fix x
    assume x_int_T: "x \<in> interior ?T"
    have "f field_differentiable at x"
      by (metis (no_types, lifting) Df_on_T at_within_interior field_differentiable_on_def
          interior_subset subsetD x_int_T)
    moreover have "g field_differentiable at (f x)"
      by (metis (no_types, lifting) Dg_on_S' at_within_interior field_differentiable_on_def
          interior_subset mem_Collect_eq subsetD x_int_T)
    ultimately have "deriv (g \<circ> f) x = deriv g (f x) * deriv f x"
      using deriv_chain[of f x g] by simp
    then show "deriv (\<lambda>x. g (f x)) x = deriv g (f x) * deriv f x"
      by (simp add: comp_def)
  qed
  ultimately show ?thesis
    using eventually_nhds by blast
qed

lemma eventually_deriv_compose':
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at (f x)"
    shows "\<forall>\<^sub>F x in nhds x. deriv (\<lambda>x. g (f x)) x = deriv g (f x) * deriv f x"
  using assms eventually_deriv_compose twice_field_differentiable_at_def by blast

text\<open>Composition of twice differentiable functions is twice differentiable.\<close>
lemma twice_field_differentiable_at_compose:
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at (f x)"
    shows "(\<lambda>x. g (f x)) twice_field_differentiable_at x"
proof -
  obtain S S'
   where Df_on_S:  "f field_differentiable_on S" and x_int_S: "x \<in> interior S"
     and Dg_on_S': "g field_differentiable_on S'" and fx_int_S': "f x \<in> interior S'"
    using assms twice_field_differentiable_at_def by blast

  let ?T = "{x \<in> interior S. f x \<in> interior S'}"

  have "continuous_on (interior S) f"
    by (meson Df_on_S continuous_on_eq_continuous_within continuous_on_subset field_differentiable_imp_continuous_at
         field_differentiable_on_def interior_subset)
  then have "open (interior S \<inter> {x. f x \<in> interior S'})"
    by (metis continuous_open_preimage open_interior vimage_def)
  then have x_int_T: "x \<in> interior ?T"
    by (metis (no_types) Collect_conj_eq Collect_mem_eq Int_Collect fx_int_S' interior_eq x_int_S)

  have  Dg_on_fT: "g field_differentiable_on f`?T"
    by (metis (no_types, lifting) Dg_on_S' field_differentiable_on_subset image_Collect_subsetI interior_subset)

  have Df_on_T: "f field_differentiable_on ?T"
    using  field_differentiable_on_subset Df_on_S
    by (metis Collect_subset interior_subset)

  have "(\<lambda>x. g (f x)) field_differentiable_on ?T"
    unfolding field_differentiable_on_def
  proof
    fix x assume x_int: "x \<in> {x \<in> interior S. f x \<in> interior S'}"
    have "f field_differentiable at x"
      by (metis Df_on_S at_within_interior field_differentiable_on_def interior_subset mem_Collect_eq subsetD x_int)
    moreover have "g field_differentiable at (f x)"
      by (metis Dg_on_S' at_within_interior field_differentiable_on_def interior_subset mem_Collect_eq subsetD x_int)
    ultimately have "(g \<circ> f) field_differentiable at x"
      by (simp add: field_differentiable_compose)
    then have "(\<lambda>x. g (f x)) field_differentiable at x"
      by (simp add: comp_def)
    then show "(\<lambda>x. g (f x)) field_differentiable at x within {x \<in> interior S. f x \<in> interior S'}"
      using field_differentiable_at_within by blast
  qed
  moreover have "deriv (\<lambda>x. g (f x)) field_differentiable at x"
  proof -
    have "(\<lambda>x. deriv g (f x)) field_differentiable at x"
      by (metis DERIV_chain2 assms deriv_field_differentiable_at field_differentiable_def once_field_differentiable_at)
    then have "(\<lambda>x. deriv g (f x) * deriv f x) field_differentiable at x"
      using assms field_differentiable_mult[of "\<lambda>x. deriv g (f x)"]
      by (simp add: deriv_field_differentiable_at)
    moreover have "deriv (deriv (\<lambda>x. g (f x))) x = deriv (\<lambda>x. deriv g (f x) * deriv f x) x"
      using assms Df_on_S x_int_S deriv_cong_ev eventually_deriv_compose by fastforce
    ultimately show ?thesis
      using assms eventually_deriv_compose DERIV_deriv_iff_field_differentiable Df_on_S x_int_S
            DERIV_cong_ev[of x x "deriv (\<lambda>x. g (f x))" "\<lambda>x. deriv g (f x) * deriv f x"]
      by blast
  qed
  ultimately show ?thesis
    using twice_field_differentiable_at_def x_int_T by blast
qed

subsubsection\<open>Constant\<close>
lemma twice_field_differentiable_at_const [simp, intro]:
  "(\<lambda>x. a) twice_field_differentiable_at x"
  by (auto intro: exI [of _ UNIV] simp add: twice_field_differentiable_at_def field_differentiable_on_def)

subsubsection\<open>Identity\<close>
lemma twice_field_differentiable_at_ident [simp, intro]:
  "(\<lambda>x. x) twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (\<lambda>x. x) field_differentiable at x"
   and "deriv ((\<lambda>x. x)) field_differentiable at x"
    by simp_all
  then show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by fastforce
qed

subsubsection\<open>Constant Multiplication\<close>
lemma twice_field_differentiable_at_cmult [simp, intro]:
"(*) k twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (*) k field_differentiable at x"
    by simp
  moreover have "deriv ((*) k) field_differentiable at x"
    by simp
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by fastforce
qed

lemma twice_field_differentiable_at_uminus [simp, intro]:
  "uminus twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. uminus field_differentiable at x"
    by (simp add: field_differentiable_minus)
  moreover have "deriv uminus field_differentiable at x"
    by simp
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by auto
qed

lemma twice_field_differentiable_at_uminus_fun [intro]:
  assumes "f twice_field_differentiable_at x"
    shows "(\<lambda>x. - f x) twice_field_differentiable_at x"
  by (simp add: assms twice_field_differentiable_at_compose)

subsubsection\<open>Real Scaling\<close>

lemma deriv_scaleR_right_id [simp]:
  "(deriv ((*\<^sub>R) k)) = (\<lambda>z. k *\<^sub>R 1)"
  using DERIV_imp_deriv has_field_derivative_scaleR_right DERIV_ident by blast

lemma deriv_deriv_scaleR_right_id [simp]:
  "deriv (deriv ((*\<^sub>R) k)) = (\<lambda>z. 0)"
  by simp

lemma deriv_scaleR_right:
  "f field_differentiable (at z) \<Longrightarrow> deriv (\<lambda>x. k *\<^sub>R f x) z = k *\<^sub>R deriv f z"
  by (simp add: DERIV_imp_deriv field_differentiable_derivI has_field_derivative_scaleR_right)

lemma field_differentiable_scaleR_right [intro]:
  "f field_differentiable F \<Longrightarrow> (\<lambda>x. c *\<^sub>R f x) field_differentiable F"
  using field_differentiable_def has_field_derivative_scaleR_right by blast

lemma has_field_derivative_scaleR_deriv_right:
  assumes "f twice_field_differentiable_at z"
  shows "((\<lambda>x. k *\<^sub>R deriv f x) has_field_derivative k *\<^sub>R deriv (deriv f) z) (at z)"
  by (simp add: DERIV_deriv_iff_field_differentiable assms deriv_field_differentiable_at has_field_derivative_scaleR_right)

lemma deriv_scaleR_deriv_right:
  assumes "f twice_field_differentiable_at z"
  shows "deriv (\<lambda>x. k *\<^sub>R deriv f x) z = k *\<^sub>R deriv (deriv f) z"
  using assms deriv_scaleR_right twice_field_differentiable_at_def by blast

lemma twice_field_differentiable_at_scaleR [simp, intro]:
  "(*\<^sub>R) k twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (*\<^sub>R) k field_differentiable at x"
    by (simp add: field_differentiable_scaleR_right)
  moreover have "deriv ((*\<^sub>R) k) field_differentiable at x"
    by simp
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by auto
qed

lemma twice_field_differentiable_at_scaleR_fun [simp, intro]:
  assumes "f twice_field_differentiable_at x"
  shows "(\<lambda>x. k *\<^sub>R f x) twice_field_differentiable_at x"
  by (simp add: assms twice_field_differentiable_at_compose)

subsubsection\<open>Addition\<close>

lemma eventually_deriv_add:
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at x"
    shows "\<forall>\<^sub>F x in nhds x. deriv (\<lambda>x. f x + g x) x = deriv f x + deriv g x"
proof -
  obtain S where Df_on_S: "f field_differentiable_on S" and x_int_S: "x \<in> interior S"
    using assms twice_field_differentiable_at_def by blast
  obtain S' where Dg_on_S: "g field_differentiable_on S'" and x_int_S': "x \<in> interior S'"
    using assms twice_field_differentiable_at_def by blast
  have "x \<in> interior (S \<inter> S')"
     by (simp add: x_int_S x_int_S')
  moreover have Df_on_SS': "f field_differentiable_on (S \<inter> S')"
     by (meson Df_on_S IntD1 field_differentiable_on_def field_differentiable_within_subset inf_sup_ord(1))
  moreover have Dg_on_SS': "g field_differentiable_on (S \<inter> S')"
     by (meson Dg_on_S IntD2 field_differentiable_on_def field_differentiable_within_subset inf_le2)
  moreover have "open (interior (S \<inter> S'))"
    by blast
  moreover have "\<forall>x\<in> interior (S \<inter> S'). deriv (\<lambda>x. f x + g x) x = deriv f x + deriv g x"
    by (metis (full_types) Df_on_SS' Dg_on_SS' at_within_interior deriv_add field_differentiable_on_def in_mono interior_subset)
  ultimately show ?thesis
    using eventually_nhds by blast
qed

lemma twice_field_differentiable_at_add [intro]:
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at x"
    shows "(\<lambda>x. f x + g x) twice_field_differentiable_at x"
proof -
  obtain S S'
   where Df_on_S:  "f field_differentiable_on S" and x_int_S: "x \<in> interior S"
     and Dg_on_S': "g field_differentiable_on S'" and x_int_S': " x \<in> interior S'"
    using assms twice_field_differentiable_at_def by blast

  let ?T = "interior (S \<inter> S')"

  have x_int_T: "x \<in> interior ?T"
     by (simp add: x_int_S x_int_S')

  have Df_on_T: "f field_differentiable_on ?T"
    by (meson Df_on_S field_differentiable_on_subset inf_sup_ord(1) interior_subset)
  have  Dg_on_fT: "g field_differentiable_on ?T"
    by (meson Dg_on_S' field_differentiable_on_subset interior_subset le_infE)

   have "(\<lambda>x. f x + g x) field_differentiable_on ?T"
     unfolding field_differentiable_on_def
  proof
    fix x assume x_in_T: "x \<in> ?T"
    have "f field_differentiable at x"
      by (metis x_in_T Df_on_T at_within_open field_differentiable_on_def open_interior)
    moreover have "g field_differentiable at x"
      by (metis x_in_T Dg_on_fT at_within_open field_differentiable_on_def open_interior)
    ultimately have "(\<lambda>x. f x + g x) field_differentiable at x"
      by (simp add: field_differentiable_add)
    then show "(\<lambda>x. f x + g x) field_differentiable at x within ?T"
      using field_differentiable_at_within by blast
  qed
  moreover have "deriv (\<lambda>x. f x + g x) field_differentiable at x"
  proof -
    have "deriv (\<lambda>x. f x + g x) x = deriv f x + deriv g x"
      by (simp add: assms once_field_differentiable_at)
    moreover have "(\<lambda>x. deriv f x + deriv g x) field_differentiable at x"
      by (simp add: field_differentiable_add assms deriv_field_differentiable_at)
    ultimately show ?thesis
      using assms DERIV_deriv_iff_field_differentiable
            DERIV_cong_ev[of x x "deriv (\<lambda>x. f x + g x)" "\<lambda>x. deriv f x + deriv g x"]
      by (simp add: eventually_deriv_add field_differentiable_def)
  qed
  ultimately show ?thesis
    using twice_field_differentiable_at_def x_int_T by blast
qed

lemma deriv_add_id_const [simp]:
  "deriv (\<lambda>x. x + a) = (\<lambda>z. 1)"
  using ext trans[OF deriv_add] by force

lemma deriv_deriv_add_id_const [simp]:
  "deriv (deriv (\<lambda>x. x + a)) z = 0"
  by simp

lemma twice_field_differentiable_at_cadd [simp]:
  "(\<lambda>x. x + a) twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (\<lambda>x. x + a) field_differentiable at x"
    by (simp add: field_differentiable_add)
  moreover have "deriv ((\<lambda>x. x + a)) field_differentiable at x"
    by (simp add: ext)
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by auto
qed

subsubsection\<open>Linear Function\<close>
lemma twice_field_differentiable_at_linear [simp, intro]:
  "(\<lambda>x. k * x + a) twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (\<lambda>x. k * x + a) field_differentiable at x"
    by (simp add: field_differentiable_add)
  moreover have "deriv ((\<lambda>x. k * x + a)) field_differentiable at x"
  proof -
    have "deriv ((\<lambda>x. k * x + a)) = (\<lambda>x. k)"
      by (simp add: ext)
    then show ?thesis
      by simp
  qed
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by auto
qed

lemma twice_field_differentiable_at_linearR [simp, intro]:
  "(\<lambda>x. k *\<^sub>R x + a) twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (\<lambda>x. k *\<^sub>R x + a) field_differentiable at x"
    by (simp add: field_differentiable_scaleR_right field_differentiable_add)
  moreover have "deriv ((\<lambda>x. k *\<^sub>R x + a)) field_differentiable at x"
  proof -
    have "deriv ((\<lambda>x. k *\<^sub>R x + a)) = (\<lambda>x. k *\<^sub>R 1)"
      by (simp add: ext once_field_differentiable_at)
    then show ?thesis
      by simp
  qed
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by auto
qed

subsubsection\<open>Multiplication\<close>

lemma eventually_deriv_mult:
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at x"
    shows "\<forall>\<^sub>F x in nhds x. deriv (\<lambda>x. f x * g x) x = f x * deriv g x + deriv f x * g x"
proof -
  obtain S and S'
    where "f field_differentiable_on S"   and in_S:  "x \<in> interior S"
      and "g field_differentiable_on S'"  and in_S': "x \<in> interior S'"
    using assms twice_field_differentiable_at_def by blast
  then have Df_on_SS': "f field_differentiable_on (S \<inter> S')"
        and Dg_on_SS': "g field_differentiable_on (S \<inter> S')"
    using field_differentiable_on_subset by blast+

  have "\<forall>x\<in> interior (S \<inter> S'). deriv (\<lambda>x. f x * g x) x = f x * deriv g x + deriv f x * g x"
  proof
    fix x assume "x \<in> interior (S \<inter> S')"
    then have "f field_differentiable (at x)"
          and "g field_differentiable (at x)"
      using Df_on_SS' Dg_on_SS' field_differentiable_on_def at_within_interior interior_subset subsetD by metis+
    then show "deriv (\<lambda>x. f x * g x) x = f x * deriv g x + deriv f x * g x"
      by simp
  qed
  moreover have "x \<in> interior (S \<inter> S')"
    by (simp add: in_S in_S')
  moreover have "open (interior (S \<inter> S'))"
    by blast
  ultimately show ?thesis
    using eventually_nhds by blast
qed

lemma twice_field_differentiable_at_mult [intro]:
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at x"
    shows "(\<lambda>x. f x * g x) twice_field_differentiable_at x"
proof -
  obtain S S'
   where Df_on_S:  "f field_differentiable_on S" and x_int_S: "x \<in> interior S"
     and Dg_on_S': "g field_differentiable_on S'" and x_int_S': " x \<in> interior S'"
    using assms twice_field_differentiable_at_def by blast

  let ?T = "interior (S \<inter> S')"

  have x_int_T: "x \<in> interior ?T"
     by (simp add: x_int_S x_int_S')

  have Df_on_T: "f field_differentiable_on ?T"
    by (meson Df_on_S field_differentiable_on_subset inf_sup_ord(1) interior_subset)
  have  Dg_on_fT: "g field_differentiable_on ?T"
    by (meson Dg_on_S' field_differentiable_on_subset interior_subset le_infE)

   have "(\<lambda>x. f x * g x) field_differentiable_on ?T"
     unfolding field_differentiable_on_def
  proof
    fix x assume x_in_T: "x \<in> ?T"
    have "f field_differentiable at x"
      by (metis x_in_T Df_on_T at_within_open field_differentiable_on_def open_interior)
    moreover have "g field_differentiable at x"
      by (metis x_in_T Dg_on_fT at_within_open field_differentiable_on_def open_interior)
    ultimately have "(\<lambda>x. f x * g x) field_differentiable at x"
      by (simp add: field_differentiable_mult)
    then show "(\<lambda>x. f x * g x) field_differentiable at x within ?T"
      using field_differentiable_at_within by blast
  qed
  moreover have "deriv (\<lambda>x. f x * g x) field_differentiable at x"
  proof -
    have "deriv (\<lambda>x. f x * g x) x = f x * deriv g x + deriv f x * g x"
      by (simp add: assms once_field_differentiable_at)
    moreover have "(\<lambda>x. f x * deriv g x + deriv f x * g x) field_differentiable at x"
      by (rule field_differentiable_add, simp_all add: field_differentiable_mult assms once_field_differentiable_at deriv_field_differentiable_at)
    ultimately show ?thesis
      using assms DERIV_deriv_iff_field_differentiable
            DERIV_cong_ev[of x x "deriv (\<lambda>x. f x * g x)" "\<lambda>x. f x * deriv g x + deriv f x * g x"]
      by (simp add: eventually_deriv_mult field_differentiable_def)
  qed
  ultimately show ?thesis
    using twice_field_differentiable_at_def x_int_T by blast
qed

subsubsection\<open>Sine and Cosine\<close>

lemma deriv_sin [simp]: "deriv sin a = cos a"
  by (simp add: DERIV_imp_deriv)

lemma deriv_sinf [simp]: "deriv sin = (\<lambda>x. cos x)"
  by auto

lemma deriv_cos [simp]: "deriv cos a = - sin a"
  by (simp add: DERIV_imp_deriv)

lemma deriv_cosf [simp]: "deriv cos = (\<lambda>x. - sin x)"
  by auto

lemma deriv_sin_minus [simp]:
  "deriv (\<lambda>x. - sin x) a = - deriv (\<lambda>x. sin x) a"
  by (simp add: DERIV_imp_deriv Deriv.field_differentiable_minus)

lemma twice_field_differentiable_at_sin [simp, intro]:
  "sin twice_field_differentiable_at x"
  by (auto intro!: exI [of _ UNIV] simp add: field_differentiable_at_sin
      field_differentiable_on_def twice_field_differentiable_at_def field_differentiable_at_cos)

lemma twice_field_differentiable_at_sin_fun [intro]:
  assumes "f twice_field_differentiable_at x"
  shows   "(\<lambda>x. sin (f x)) twice_field_differentiable_at x"
  by (simp add: assms twice_field_differentiable_at_compose)

lemma twice_field_differentiable_at_cos [simp, intro]:
  "cos twice_field_differentiable_at x"
  by (auto intro!: exI [of _ UNIV] simp add:  field_differentiable_within_sin field_differentiable_minus
      field_differentiable_on_def twice_field_differentiable_at_def field_differentiable_at_cos)

lemma twice_field_differentiable_at_cos_fun [intro]:
  assumes "f twice_field_differentiable_at x"
  shows   "(\<lambda>x. cos (f x)) twice_field_differentiable_at x"
  by (simp add: assms twice_field_differentiable_at_compose)

subsubsection\<open>Exponential\<close>

lemma deriv_exp [simp]: "deriv exp x = exp x"
  using DERIV_exp DERIV_imp_deriv by blast

lemma deriv_expf [simp]: "deriv exp = exp"
  by (simp add: ext)

lemma deriv_deriv_exp [simp]: "deriv (deriv exp) x = exp x"
  by simp

lemma twice_field_differentiable_at_exp [simp, intro]:
  "exp twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. exp field_differentiable at x"
   and "deriv exp field_differentiable at x"
    by (simp_all add: field_differentiable_within_exp)
  then show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by auto
qed

lemma twice_field_differentiable_at_exp_fun [simp, intro]:
  assumes "f twice_field_differentiable_at x"
  shows "(\<lambda>x. exp (f x)) twice_field_differentiable_at x"
  by (simp add: assms twice_field_differentiable_at_compose)

subsubsection\<open>Square Root\<close>

lemma deriv_real_sqrt [simp]: "x > 0 \<Longrightarrow> deriv sqrt x = inverse (sqrt x) / 2"
  using DERIV_imp_deriv DERIV_real_sqrt by blast

lemma has_real_derivative_inverse_sqrt:
  assumes "x > 0"
  shows "((\<lambda>x. inverse (sqrt x) / 2) has_real_derivative - (inverse (sqrt x ^ 3) / 4)) (at x)"
proof -
  have inv_sqrt_mult: "(inverse (sqrt x)/2) * (sqrt x * 2) = 1"
    using assms by simp
  have inv_sqrt_mult2: "(- inverse ((sqrt x)^3)/2)* x * (sqrt x * 2) = -1"
    using assms by (simp add: field_simps power3_eq_cube)
  then show ?thesis
    using assms by (safe intro!: DERIV_imp_deriv derivative_eq_intros)
        (auto intro: derivative_eq_intros inv_sqrt_mult [THEN ssubst] inv_sqrt_mult2 [THEN ssubst]
              simp add: divide_simps power3_eq_cube)
qed

lemma deriv_deriv_real_sqrt':
  assumes "x > 0"
  shows "deriv (\<lambda>x. inverse (sqrt x) / 2) x = - inverse ((sqrt x)^3)/4"
  by (simp add: DERIV_imp_deriv assms has_real_derivative_inverse_sqrt)

lemma has_real_derivative_deriv_sqrt:
  assumes "x > 0"
  shows "(deriv sqrt has_real_derivative - inverse (sqrt x ^ 3) / 4) (at x)"
proof -
  have "((\<lambda>x. inverse (sqrt x) / 2) has_real_derivative - inverse (sqrt x ^ 3) / 4) (at x)"
    using assms has_real_derivative_inverse_sqrt by auto
  moreover
  {fix xa :: real
   assume "xa \<in> {0<..}"
   then have "inverse (sqrt xa) / 2 = deriv sqrt xa"
     by simp
  }
  ultimately show ?thesis
    using has_field_derivative_transform_within_open [where S="{0 <..}" and f="(\<lambda>x. inverse (sqrt x) / 2)"]
    by (meson assms greaterThan_iff open_greaterThan)
qed

lemma deriv_deriv_real_sqrt [simp]:
  assumes "x > 0"
  shows "deriv(deriv sqrt) x = - inverse ((sqrt x)^3)/4"
  using DERIV_imp_deriv assms has_real_derivative_deriv_sqrt by blast

lemma twice_field_differentiable_at_sqrt [simp, intro]:
  assumes "x > 0"
    shows "sqrt twice_field_differentiable_at x"
proof -
  have "sqrt field_differentiable_on {0<..}"
    by (metis DERIV_real_sqrt at_within_open field_differentiable_def field_differentiable_on_def
        greaterThan_iff open_greaterThan)
  moreover have "x \<in> interior {0<..}"
    by (metis assms greaterThan_iff interior_interior interior_real_atLeast)
  moreover have "deriv sqrt field_differentiable at x"
    using assms field_differentiable_def has_real_derivative_deriv_sqrt by blast
  ultimately show ?thesis
    using twice_field_differentiable_at_def by blast
qed

lemma twice_field_differentiable_at_sqrt_fun [intro]:
  assumes "f twice_field_differentiable_at x"
    and "f x > 0"
  shows "(\<lambda>x. sqrt (f x)) twice_field_differentiable_at x"
  by (simp add: assms(1) assms(2) twice_field_differentiable_at_compose)

subsubsection\<open>Natural Power\<close>

lemma field_differentiable_power [simp]:
  "(\<lambda>x. x ^ n) field_differentiable at x"
  using DERIV_power DERIV_ident field_differentiable_def
  by blast

lemma deriv_power_fun [simp]:
  assumes "f field_differentiable at x"
    shows "deriv (\<lambda>x. f x ^ n) x = of_nat n * deriv f x * f x ^ (n - 1)"
  using DERIV_power[of f "deriv f x"]
  by (simp add:  DERIV_imp_deriv assms field_differentiable_derivI mult.assoc [symmetric])

lemma deriv_power [simp]:
  "deriv (\<lambda>x. x ^ n) x = of_nat n * x ^ (n - 1)"
  using DERIV_power[of "\<lambda>x. x" 1] DERIV_imp_deriv by force

lemma deriv_deriv_power [simp]:
  "deriv (deriv (\<lambda>x. x ^ n)) x = of_nat n * of_nat (n - Suc 0) * x ^ (n - 2)"
proof -
  have "(\<lambda>x. x ^ (n - 1)) field_differentiable at x"
    by simp
  then have "deriv (\<lambda>x. of_nat n * x ^ (n - 1)) x = of_nat n * of_nat (n - Suc 0) * x ^ (n - 2)"
    by (simp add: diff_diff_add mult.assoc numeral_2_eq_2)
  then show ?thesis
    by (simp add: ext[OF deriv_power])
qed

lemma twice_field_differentiable_at_power [simp, intro]:
  "(\<lambda>x. x ^ n) twice_field_differentiable_at x"
proof -
  have "\<forall>x\<in>UNIV. (\<lambda>x. x ^ n) field_differentiable at x"
    by simp
  moreover have "deriv ((\<lambda>x. x ^ n)) field_differentiable at x"
  proof -
    have "deriv ((\<lambda>x. x ^ n)) = (\<lambda>x. of_nat n * x ^ (n - 1))"
      by (simp add: ext)
    then show ?thesis
      using field_differentiable_mult[of "\<lambda>x. of_nat n" x UNIV "\<lambda>x. x ^ (n - 1)"]
      by (simp add: field_differentiable_caratheodory_at)
  qed
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by force
qed

lemma twice_field_differentiable_at_power_fun [intro]:
  assumes "f twice_field_differentiable_at x"
    shows "(\<lambda>x. f x ^ n) twice_field_differentiable_at x"
  by (blast intro: assms twice_field_differentiable_at_compose [OF _ twice_field_differentiable_at_power])

subsubsection\<open>Inverse\<close>

lemma eventually_deriv_inverse:
  assumes "x \<noteq> 0"
    shows "\<forall>\<^sub>F x in nhds x. deriv inverse x = - 1 / (x ^ 2)"
proof -
  obtain T where open_T: "open T" and "\<forall>z\<in>T. z \<noteq> 0" and x_in_T: "x \<in> T"
    using assms t1_space by blast

  then have "\<forall>x \<in> T. deriv inverse x = - 1 / (x ^ 2)"
    by simp
  then show ?thesis
    using eventually_nhds open_T x_in_T by blast
qed

lemma deriv_deriv_inverse [simp]:
  assumes "x \<noteq> 0"
  shows "deriv (deriv inverse) x = 2 * inverse (x ^ 3)"
proof -
  have "deriv (\<lambda>x. inverse (x ^ 2)) x = - (of_nat 2 * x) / ((x ^ 2) ^ 2)"
    using assms by simp
  moreover have "(\<lambda>x. inverse (x ^ 2)) field_differentiable at x"
    using assms by (simp add: field_differentiable_inverse)
  ultimately have "deriv (\<lambda>x. - (inverse (x ^ 2))) x = of_nat 2 * x / (x ^ 4)"
    using deriv_chain[of "\<lambda>x. inverse (x ^ 2)" x]
    by (simp add: comp_def field_differentiable_minus field_simps)
  then have "deriv (\<lambda>x. - 1 / (x ^ 2)) x = 2 * inverse (x ^ 3)"
    by (simp add: power4_eq_xxxx power3_eq_cube field_simps)
  then show ?thesis
    using assms eventually_deriv_inverse deriv_cong_ev by fastforce
qed

lemma twice_field_differentiable_at_inverse [simp, intro]:
  assumes "x \<noteq> 0"
  shows "inverse twice_field_differentiable_at x"
proof -
  obtain T where zero_T: "0 \<notin> T" and x_in_T: "x \<in> T" and open_T: "open T"
    using assms t1_space by blast
  then have "T \<subseteq> {z. z \<noteq> 0}"
    by blast
  then have "\<forall>x\<in>T. inverse field_differentiable at x within T"
    using DERIV_inverse field_differentiable_def by blast
  moreover have "deriv inverse field_differentiable at x"
  proof -
    have "(\<lambda>x. - inverse (x ^ 2)) field_differentiable at x"
      using assms by (simp add: field_differentiable_inverse field_differentiable_minus)
    then have "(\<lambda>x. - 1 / (x ^ 2)) field_differentiable at x"
      by (simp add: inverse_eq_divide)
    then show ?thesis
      using eventually_deriv_inverse[OF assms]
      by (simp add: DERIV_cong_ev field_differentiable_def)
  qed
  moreover have "x \<in> interior T"
    by (simp add: x_in_T open_T interior_open)
  ultimately show ?thesis
    unfolding twice_field_differentiable_at_def field_differentiable_on_def
    by blast
qed

lemma twice_field_differentiable_at_inverse_fun [simp, intro]:
  assumes "f twice_field_differentiable_at x"
          "f x \<noteq> 0"
  shows "(\<lambda>x. inverse (f x)) twice_field_differentiable_at x"
  by (simp add: assms twice_field_differentiable_at_compose)

lemma twice_field_differentiable_at_divide [intro]:
  assumes "f twice_field_differentiable_at x"
      and "g twice_field_differentiable_at x"
      and "g x \<noteq> 0"
    shows "(\<lambda>x. f x / g x) twice_field_differentiable_at x"
  by (simp add: assms divide_inverse twice_field_differentiable_at_mult)

subsubsection\<open>Polynomial\<close>

lemma twice_field_differentiable_at_polyn [simp, intro]:
  fixes coef :: "nat \<Rightarrow> 'a :: {real_normed_field}"
    and n :: nat
  shows "(\<lambda>x. \<Sum>i<n. coef i * x ^ i) twice_field_differentiable_at x"
proof (induction n)
  case 0
  then show ?case
    by simp
next
  case hyp: (Suc n)
  show ?case
  proof (simp, rule twice_field_differentiable_at_add)
    show "(\<lambda>x. \<Sum>i<n. coef i * x ^ i) twice_field_differentiable_at x"
      by (rule hyp)
    show "(\<lambda>x. coef n * x ^ n) twice_field_differentiable_at x"
      using twice_field_differentiable_at_compose[of "\<lambda>x. x ^ n" x "(*) (coef n)"]
      by simp
  qed
qed

lemma twice_field_differentiable_at_polyn_fun [simp]:
  fixes coef :: "nat \<Rightarrow> 'a :: {real_normed_field}"
    and n :: nat
  assumes "f twice_field_differentiable_at x"
  shows "(\<lambda>x. \<Sum>i<n. coef i * f x ^ i) twice_field_differentiable_at x"
  by (blast intro: assms twice_field_differentiable_at_compose [OF _ twice_field_differentiable_at_polyn])

end


(*
  File:     Jacobi_Symbol.thy
  Authors:  Daniel Stüwe, Manuel Eberl

  The Jacobi symbol, a generalisation of the Legendre symbol.
  This is used in the Solovay--Strassen test.
*)
section \<open>The Jacobi Symbol\<close>
theory Jacobi_Symbol
imports
  Legendre_Symbol
  Algebraic_Auxiliaries
begin

text \<open>
  The Jacobi symbol is a generalisation of the Legendre symbol to non-primes \<^cite>\<open>"Legendre_Symbol" and "Jacobi_Symbol"\<close>.
  It is defined as
  \[\left(\frac{a}{n}\right) =
      \left(\frac{a}{p_1}\right)^{k_1} \ldots \left(\frac{a}{p_l}\right)^{k_l}\]
  where $(\frac{a}{p})$ denotes the Legendre symbol, \<open>a\<close> is an integer, \<open>n\<close> is an odd natural
  number and $p_1^{k_1}\ldots p_l^{k_l}$ is its prime factorisation.

  There is, however, a fairly natural generalisation to all non-zero integers for \<open>n\<close>.
  It is less clear what a good choice for \<open>n = 0\<close> is; Mathematica and Maxima adopt
  the convention that $(\frac{\pm 1}{0}) = 1$ and $(\frac{a}{0}) = 0$ otherwise. However,
  we chose the slightly different convention $(\frac{a}{0}) = 0$ for \<^emph>\<open>all\<close> \<open>a\<close> because then
  the Jacobi symbol is completely multiplicative in both arguments without any restrictions.
\<close>
definition Jacobi :: "int \<Rightarrow> int \<Rightarrow> int" where
  "Jacobi a n = (if n = 0 then 0 else
                  (\<Prod>p\<in>#prime_factorization n. Legendre a p))"

lemma Jacobi_0_right [simp]: "Jacobi a 0 = 0"
  by (simp add: Jacobi_def)

lemma Jacobi_mult_left [simp]: "Jacobi (a * b) n = Jacobi a n * Jacobi b n"
proof (cases "n = 0")
  case False
  have *: "{# Legendre (a * b) p          . p \<in># prime_factorization n #} =
           {# Legendre a p * Legendre b p . p \<in># prime_factorization n #}"
    by (meson Legendre_mult in_prime_factors_imp_prime image_mset_cong)

  show ?thesis using False unfolding Jacobi_def * prod_mset.distrib by auto
qed auto

lemma Jacobi_mult_right [simp]: "Jacobi a (n * m) = Jacobi a n * Jacobi a m"
  by (cases "m = 0"; cases "n = 0")
     (auto simp: Jacobi_def prime_factorization_mult)

lemma prime_p_Jacobi_eq_Legendre[intro!]: "prime p \<Longrightarrow> Jacobi a p = Legendre a p"
  unfolding Jacobi_def prime_factorization_prime by simp

lemma Jacobi_mod [simp]: "Jacobi (a mod m) n = Jacobi a n" if "n dvd m"
proof -
  have *: "{# Legendre (a mod m) p . p \<in># prime_factorization n #} =
           {# Legendre a p . p \<in># prime_factorization n #}" using that
    by (intro image_mset_cong, subst Legendre_mod)
       (auto intro: dvd_trans[OF in_prime_factors_imp_dvd])
  thus ?thesis by (simp add: Jacobi_def)
qed

lemma Jacobi_mod_cong: "[a = b] (mod n) \<Longrightarrow> Jacobi a n = Jacobi b n"
  by (metis Jacobi_mod cong_def dvd_refl)

lemma Jacobi_1_eq_1 [simp]: "p \<noteq> 0 \<Longrightarrow> Jacobi 1 p = 1"
  by (simp add: Jacobi_def in_prime_factors_imp_prime cong: image_mset_cong)

lemma Jacobi_p_eq_2'[simp]: "n > 0 \<Longrightarrow> Jacobi a (2^n) = a mod 2"
  by (auto simp add: Jacobi_def prime_factorization_prime_power)

lemma Jacobi_prod_mset[simp]: "n \<noteq> 0 \<Longrightarrow> Jacobi (prod_mset M) n = (\<Prod>q\<in>#M. Jacobi q n)"
  by (induction M) simp_all

lemma non_trivial_coprime_neq:
  "1 < a \<Longrightarrow> 1 < b \<Longrightarrow> coprime a b \<Longrightarrow> a \<noteq> b" for a b :: int by auto

lemma odd_odd_even:
  fixes a b :: int
  assumes "odd a" "odd b"
  shows "even ((a*b-1) div 2) = even ((a-1) div 2 + (b-1) div 2)"
  using assms by (auto elim!: oddE simp: algebra_simps)

lemma prime_nonprime_wlog [case_names primes nonprime sym]:
  assumes "\<And>p q. prime p \<Longrightarrow> prime q \<Longrightarrow> P p q"
  assumes "\<And>p q. \<not>prime p \<Longrightarrow> P p q"
  assumes "\<And>p q. P p q \<Longrightarrow> P q p"
  shows   "P p q"
  by (cases "prime p"; cases "prime q") (auto intro: assms)

lemma Quadratic_Reciprocity_Jacobi:
  fixes p q :: int
  assumes "coprime p q"
      and "2 < p" "2 < q"
      and "odd p" "odd q"
    shows "Jacobi p q * Jacobi q p =
           (- 1) ^ (nat ((p - 1) div 2 * ((q - 1) div 2)))"
  using assms
proof (induction "nat p" "nat q" arbitrary: p q
         rule: measure_induct_rule[where f = "\<lambda>(a, b). a + b", split_format(complete), simplified])
  case (1 p q)
  thus ?case
  proof (induction p q rule: prime_nonprime_wlog)
    case (sym p q)
    thus ?case by (simp only: add_ac coprime_commute mult_ac) blast
  next
    case (primes p q)
    from \<open>prime p\<close> \<open>prime q\<close> have "prime (nat p)" "prime (nat q)" "p \<noteq> q"
      using prime_int_nat_transfer primes(4) non_trivial_coprime_neq prime_gt_1_int
      by blast+

    with Quadratic_Reciprocity_int and prime_p_Jacobi_eq_Legendre
    show ?case
      using \<open>prime p\<close> \<open>prime q\<close> primes(5-)
      by presburger
  next
    case (nonprime p q)
    from \<open>\<not>prime p\<close> obtain a b where *: "p = a * b" "1 < b" "1 < a"
      using \<open>2 < p\<close> prime_divisor_exists_strong[of p] by auto

    hence odd_ab: "odd a" "odd b" using \<open>odd p\<close> by simp_all

    moreover have "2 < b" and "2 < a"
      using odd_ab and * by presburger+

    moreover have "coprime a q" and "coprime b q" using \<open>coprime p q\<close>
      unfolding * by simp_all

    ultimately have IH: "Jacobi a q * Jacobi q a = (- 1) ^ nat ((a - 1) div 2 * ((q - 1) div 2))"
                        "Jacobi b q * Jacobi q b = (- 1) ^ nat ((b - 1) div 2 * ((q - 1) div 2))"
      by (auto simp: * nonprime)

    have pos: "0 < q" "0 < p" "0 < a" "0 < b"
      using * \<open>2 < q\<close> by simp_all

    have "Jacobi p q * Jacobi q p = (Jacobi a q * Jacobi q a) * (Jacobi b q * Jacobi q b)"
      using * by simp

    also have "... = (- 1) ^ nat ((a - 1) div 2 * ((q - 1) div 2)) *
                     (- 1) ^ nat ((b - 1) div 2 * ((q - 1) div 2))"
      using IH by presburger

    also from odd_odd_even[OF odd_ab]
    have "... = (- 1) ^ nat ((p - 1) div 2 * ((q - 1) div 2))"
      unfolding * minus_one_power_iff using \<open>2 < q\<close> *
      by (auto simp add: even_nat_iff pos_imp_zdiv_nonneg_iff)

    finally show ?case .
  qed
qed

lemma Jacobi_values: "Jacobi p q \<in> {1, -1, 0}"
proof (cases "q = 0")
  case False
  hence "\<bar>Legendre p x\<bar> = 1" if "x \<in># prime_factorization q" "Jacobi p q \<noteq> 0" for x
    using that prod_mset_zero_iff Legendre_values[of p x]
    unfolding Jacobi_def is_unit_prod_mset_iff set_image_mset
    by fastforce

  then have "is_unit (prod_mset (image_mset (Legendre p) (prime_factorization q)))"
    if "Jacobi p q \<noteq> 0"
    using that False
    unfolding Jacobi_def is_unit_prod_mset_iff
    by auto

  thus ?thesis by (auto simp: Jacobi_def)
qed auto

lemma Quadratic_Reciprocity_Jacobi':
  fixes p q :: int
  assumes "coprime p q"
      and "2 < p" "2 < q"
      and "odd p" "odd q"
    shows "Jacobi q p = (if p mod 4 = 3 \<and> q mod 4 = 3 then -1 else 1) * Jacobi p q"
proof -
  have aux: "a \<in> {1, -1, 0} \<Longrightarrow> c \<noteq> 0 \<Longrightarrow> a*b = c \<Longrightarrow> b = c * a" for b c a :: int by auto

  from Quadratic_Reciprocity_Jacobi[OF assms]
  have "Jacobi q p = (-1) ^ nat ((p - 1) div 2 * ((q - 1) div 2)) * Jacobi p q"
    using Jacobi_values by (fastforce intro!: aux)

  also have "(-1 :: int) ^ nat ((p - 1) div 2 * ((q - 1) div 2)) = (if even ((p - 1) div 2) \<or> even ((q - 1) div 2) then 1 else - 1)"
    unfolding minus_one_power_iff using \<open>2 < p\<close> \<open>2 < q\<close>
    by (auto simp: even_nat_iff)

  also have "... = (if p mod 4 = 3 \<and> q mod 4 = 3 then -1 else 1)"
    using \<open>odd p\<close> \<open>odd q\<close> by presburger

  finally show ?thesis .

qed

lemma odd_odd_even':
  fixes a b :: int
  assumes "odd a" "odd b"
  shows "even (((a * b)\<^sup>2 - 1) div 8) \<longleftrightarrow> even (((a\<^sup>2 - 1) div 8) + ((b\<^sup>2 - 1) div 8))"
proof -
  obtain x where [simp]: "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
  obtain y where [simp]: "b = 2*y + 1" using \<open>odd b\<close> by (auto elim: oddE)
  show ?thesis
    by (cases "even x"; cases "even y"; elim oddE evenE)
       (auto simp: power2_eq_square algebra_simps)
qed

lemma odd_odd_even_nat':
  fixes a b :: nat
  assumes "odd a" "odd b"
  shows "even (((a * b)\<^sup>2 - 1) div 8) \<longleftrightarrow> even (((a\<^sup>2 - 1) div 8) + ((b\<^sup>2 - 1) div 8))"
proof -
  obtain x where [simp]: "a = 2*x + 1" using \<open>odd a\<close> by (auto elim: oddE)
  obtain y where [simp]: "b = 2*y + 1" using \<open>odd b\<close> by (auto elim: oddE)
  show ?thesis
    by (cases "even x"; cases "even y"; elim oddE evenE)
       (auto simp: power2_eq_square algebra_simps)
qed

lemma supplement2_Jacobi: "odd p \<Longrightarrow> p > 1 \<Longrightarrow> Jacobi 2 p = (- 1) ^ (((nat p)\<^sup>2 - 1) div 8)"
proof (induction p rule: prime_divisors_induct)
  case (factor p x)

  then have "odd x" by force

  have "2 < p"
    using \<open>odd (p * x)\<close> prime_gt_1_int[OF \<open>prime p\<close>]
    by (cases "p = 2") auto

  have "odd p" using prime_odd_int[OF \<open>prime p\<close> \<open>2 < p\<close>] .

  have "0 < x"
    using \<open>1 < (p * x)\<close> prime_gt_0_int[OF \<open>prime p\<close>]
    and less_trans less_numeral_extra(1) zero_less_mult_pos by blast

  have base_case : "Jacobi 2 p = (- 1) ^ (((nat p)\<^sup>2 - 1) div 8)"
    using \<open>2 < p\<close> \<open>prime p\<close> supplement2_Legendre and prime_p_Jacobi_eq_Legendre
    by presburger

  show ?case proof (cases "x = 1")
    case True
    thus ?thesis using base_case by force
  next
    case False
    have "Jacobi 2 (p * x) = Jacobi 2 p * Jacobi 2 x"
      using \<open>2 < p\<close> \<open>0 < x\<close> by simp

    also have "Jacobi 2 x = (- 1) ^ (((nat x)\<^sup>2 - 1) div 8)"
      using \<open>odd x\<close> \<open>0 < x\<close> \<open>x \<noteq> 1\<close> by (intro factor.IH) auto

    also note base_case

    also have "(-1) ^ (((nat p)\<^sup>2 - 1) div 8) * (-1) ^ (((nat x)\<^sup>2 - 1) div 8)
             = (-1 :: int) ^ (((nat (p * x))\<^sup>2 - 1) div 8)"
      unfolding minus_one_power_iff
      using \<open>2 < p\<close> \<open>0 < x\<close> \<open>odd x\<close> \<open>odd p\<close> and odd_odd_even_nat'
      using [[linarith_split_limit = 0]]
      by (force simp add: nat_mult_distrib even_nat_iff)

    finally show ?thesis .
  qed
qed simp_all

lemma mod_int_wlog [consumes 1, case_names modulo]:
  fixes P :: "int \<Rightarrow> bool"
  assumes "b > 0"
  assumes "\<And>k. 0 \<le> k \<Longrightarrow> k < b \<Longrightarrow> n mod b = k \<Longrightarrow> P n"
  shows   "P n"
  using \<open>b > 0\<close> assms(2) [of \<open>n mod b\<close>] by simp

lemma supplement2_Jacobi':
  assumes "odd p" and "p > 1"
  shows "Jacobi 2 p = (if p mod 8 = 1 \<or> p mod 8 = 7 then 1 else -1)"
proof -
  have "0 < (4 :: nat)" by simp
  then have *: "even ((p\<^sup>2 - 1) div 8) = (p mod 8 = 1 \<or> p mod 8 = 7)" if "odd p" for p :: nat
  proof(induction p rule: mod_nat_wlog)
    case (modulo k)
    then consider "p mod 4 = 1" | "p mod 4 = 3"
      using \<open>odd p\<close>
      by (metis dvd_0_right even_even_mod_4_iff even_numeral mod_exhaust_less_4)

    then show ?case proof (cases)
      case 1
      then obtain l where l: "p = 4 * l + 1" using mod_natE by blast
      have "even l = ((4 * l + 1) mod 8 = 1 \<or> (4 * l + 1) mod 8 = 7)" by presburger
      thus ?thesis by (simp add: l power2_eq_square algebra_simps)
    next
      case 2
      then obtain l where l: "p = 4 * l + 3" using mod_natE by blast
      have "odd l = ((3 + l * 4) mod 8 = Suc 0 \<or> (3 + l * 4) mod 8 = 7)" by presburger
      thus ?thesis by (simp add: l power2_eq_square algebra_simps)
    qed
  qed

  have [simp]: "nat p mod 8 = nat (p mod 8)"
    using \<open>p > 1\<close> using nat_mod_distrib[of p 8] by simp
  from assms have "odd (nat p)" by (simp add: even_nat_iff)
  show ?thesis
    unfolding supplement2_Jacobi[OF assms]
              minus_one_power_iff *[OF \<open>odd (nat p)\<close>]
    by (simp add: nat_eq_iff)
qed

theorem supplement1_Jacobi:
  "odd p \<Longrightarrow> 1 < p \<Longrightarrow> Jacobi (-1) p = (-1) ^ (nat ((p - 1) div 2))"
proof (induction p rule: prime_divisors_induct)
  case (factor p x)
  then have "odd x" by force

  have "2 < p"
    using \<open>odd (p * x)\<close> prime_gt_1_int[OF \<open>prime p\<close>]
    by (cases "p = 2") auto

  have "prime (nat p)"
    using \<open>prime p\<close> prime_int_nat_transfer
    by blast

  have "Jacobi (-1) p = Legendre (-1) p"
    using prime_p_Jacobi_eq_Legendre[OF \<open>prime p\<close>] .

  also have "... = (-1) ^ ((nat p - 1) div 2)"
    using \<open>prime p\<close> \<open>2 < p\<close> and supplement1_Legendre[of "nat p"]
    by (metis int_nat_eq nat_mono_iff nat_numeral_as_int prime_gt_0_int prime_int_nat_transfer)

  also have "((nat p - 1) div 2) = nat ((p - 1) div 2)" by force

  finally have base_case: "Jacobi (-1) p = (-1) ^ nat ((p - 1) div 2)" .

  show ?case proof (cases "x = 1")
    case True
    then show ?thesis using base_case by simp
  next
    case False
    have "0 < x"
      using \<open>1 < (p * x)\<close> prime_gt_0_int[OF \<open>prime p\<close>]
      by (meson int_one_le_iff_zero_less not_less not_less_iff_gr_or_eq zero_less_mult_iff)

    have "odd p" using \<open>prime p\<close> \<open>2 < p\<close> by (simp add: prime_odd_int)

    have "Jacobi (-1) (p * x) = Jacobi (-1) p * Jacobi (-1) x"
      using \<open>2 < p\<close> \<open>0 < x\<close> by simp

    also note base_case

    also have "Jacobi (-1) x = (-1) ^ nat ((x - 1) div 2)"
      using \<open>0 < x\<close> False \<open>odd x\<close> factor.IH
      by fastforce

    also have "(- 1) ^ nat ((p - 1) div 2) * (- 1) ^ nat ((x - 1) div 2) =
               (- 1 :: int) ^ nat ((p*x - 1) div 2)"
      unfolding minus_one_power_iff
      using \<open>2 < p\<close> \<open>0 < x\<close> and \<open>odd x\<close> \<open>odd p\<close>
      by (fastforce elim!: oddE simp: even_nat_iff algebra_simps)

    finally show ?thesis .
  qed
qed simp_all

theorem supplement1_Jacobi':
  "odd n \<Longrightarrow> 1 < n \<Longrightarrow> Jacobi (-1) n = (if n mod 4 = 1 then 1 else -1)"
  by (simp add: even_nat_iff minus_one_power_iff supplement1_Jacobi)
     presburger?

lemma Jacobi_0_eq_0: "\<not>is_unit n \<Longrightarrow> Jacobi 0 n = 0"
  by (cases "prime_factorization n = {#}")
     (auto simp: Jacobi_def prime_factorization_empty_iff image_iff intro: Nat.gr0I)

lemma is_unit_Jacobi_aux: "is_unit x \<Longrightarrow> Jacobi a x = 1"
  unfolding Jacobi_def using prime_factorization_empty_iff[of x] by auto

lemma is_unit_Jacobi[simp]: "Jacobi a 1 = 1" "Jacobi a (-1) = 1"
  using is_unit_Jacobi_aux by simp_all

lemma Jacobi_neg_right [simp]:
  "Jacobi a (-n) = Jacobi a n"
proof -
  have * : "-n = (-1) * n" by simp
  show ?thesis unfolding *
    by (subst Jacobi_mult_right) auto
qed

lemma Jacobi_neg_left:
  assumes "odd n" "1 < n"
  shows   "Jacobi (-a) n = (if n mod 4 = 1 then 1 else -1) * Jacobi a n"
proof -
  have * : "-a = (-1) * a" by simp
  show ?thesis unfolding * Jacobi_mult_left supplement1_Jacobi'[OF assms] ..
qed

function jacobi_code :: "int \<Rightarrow> int \<Rightarrow> int" where
"jacobi_code a n = (
        if n = 0 then 0
   else if n = 1 then 1
   else if a = 1 then 1
   else if n < 0 then jacobi_code a (-n)
   else if even n then if even a then 0 else jacobi_code a (n div 2)
   else if a < 0 then (if n mod 4 = 1 then 1 else -1) * jacobi_code (-a) n
   else if a = 0 then 0
   else if a \<ge> n then jacobi_code (a mod n) n
   else if even a      then (if n mod 8 \<in> {1, 7} then 1 else -1) * jacobi_code (a div 2) n
   else if coprime a n then (if n mod 4 = 3 \<and> a mod 4 = 3 then -1 else 1) * jacobi_code n a
   else 0)"
  by auto
termination
proof (relation "measure (\<lambda>(a, n). nat(abs(a) + abs(n)*2) +
                   (if n < 0 then 1 else 0) + (if a < 0 then 1 else 0))", goal_cases)
  case (5 a n)
  thus ?case by (fastforce intro!: less_le_trans[OF pos_mod_bound])
qed auto

lemmas [simp del] = jacobi_code.simps

lemma Jacobi_code [code]: "Jacobi a n = jacobi_code a n"
proof (induction a n rule: jacobi_code.induct)
  case (1 a n)
  show ?case
  proof (cases "n = 0")
    case 2: False
    then show ?thesis proof (cases "n = 1")
      case 3: False
      then show ?thesis proof (cases "a = 1")
        case 4: False
          then show ?thesis proof (cases "n < 0")
            case True
            then show ?thesis using 2 3 4 1(1) by (subst jacobi_code.simps) simp
            next
            case 5: False
            then show ?thesis proof (cases "even n")
              case True
              then show ?thesis using 2 3 4 5 1(2)
                by (elim evenE, subst jacobi_code.simps) (auto simp: prime_p_Jacobi_eq_Legendre)
            next
              case 6: False
              then show ?thesis  proof (cases "a < 0")
                case True
                then show ?thesis using 2 3 4 5 6
                  by(subst jacobi_code.simps, subst 1(3)[symmetric]) (simp_all add: Jacobi_neg_left)
              next
                case 7: False
                then show ?thesis proof (cases "a = 0")
                  case True
                  have *: "\<not> is_unit n" using 3 5 by simp
                  then show ?thesis
                    using Jacobi_0_eq_0[OF *] 2 3 4 5 7 True
                    by (subst jacobi_code.simps) simp
                next
                  case 8: False
                  then show ?thesis proof (cases "a \<ge> n")
                    case True
                    then show ?thesis using 2 3 4 5 6 7 8 1(4)
                      by (subst jacobi_code.simps) simp
                  next
                    case 9: False
                    then show ?thesis proof (cases "even a")
                      case True
                      hence "a = 2 * (a div 2)" by simp
                      also have "Jacobi \<dots> n = Jacobi 2 n * Jacobi (a div 2) n"
                        by simp
                      also have "Jacobi (a div 2) n = jacobi_code (a div 2) n"
                        using 2 3 4 5 6 7 8 9 True by (intro 1(5))
                      also have "Jacobi 2 n = (if n mod 8 \<in> {1, 7} then 1 else - 1)"
                        using 2 3 5 supplement2_Jacobi'[OF 6] by simp
                      also have "\<dots> * jacobi_code (a div 2) n = jacobi_code a n"
                        using 2 3 4 5 6 7 8 9 True
                        by (subst (2) jacobi_code.simps) (simp only: if_False if_True HOL.simp_thms)
                      finally show ?thesis .
                    next
                      case 10: False
                      note foo = 1 2 3
                      then show ?thesis proof (cases "coprime a n")
                        case True
                        note this_case = 2 3 4 5 6 7 8 9 10 True
                        have "2 < a" using 10 4 7 by presburger
                        moreover have "2 < n" using 3 5 6 by presburger
                        ultimately have "jacobi_code a n = (if n mod 4 = 3 \<and> a mod 4 = 3 then - 1 else 1)
                                                        * jacobi_code n a"
                          using this_case by (subst jacobi_code.simps) simp
                        also have "jacobi_code n a = Jacobi n a"
                          using this_case by (intro 1(6) [symmetric]) auto
                        also have "(if n mod 4 = 3 \<and> a mod 4 = 3 then -1 else 1) * \<dots> = Jacobi a n"
                          using this_case and \<open>2 < a\<close>
                          by (intro Quadratic_Reciprocity_Jacobi' [symmetric])
                             (auto simp: coprime_commute)
                        finally show ?thesis ..
                      next
                        case False
                        have *: "0 < a" "0 < n" using 5 7 8 9 by linarith+
                        show ?thesis
                          using 1 2 3 4 5 6 7 8 9 10 False *
                          by (subst jacobi_code.simps) (auto simp: Jacobi_eq_0_not_coprime)
                      qed
                    qed
                  qed
                qed
              qed
            qed
        qed
      qed (subst jacobi_code.simps, simp)
    qed (subst jacobi_code.simps, simp)
  qed (subst jacobi_code.simps, simp)
qed

lemma Jacobi_eq_0_imp_not_coprime:
  assumes "p \<noteq> 0" "p \<noteq> 1"
  shows   "Jacobi n p = 0 \<Longrightarrow> \<not>coprime n p"
  using assms Jacobi_mod_cong coprime_iff_invertible_int by force

lemma Jacobi_eq_0_iff_not_coprime:
  assumes "p \<noteq> 0" "p \<noteq> 1"
  shows "Jacobi n p = 0 \<longleftrightarrow> \<not>coprime n p"
proof -
  from assms and Jacobi_eq_0_imp_not_coprime
  show ?thesis using Jacobi_eq_0_not_coprime by auto
qed

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Schur Decomposition\<close>

text \<open>We implement Schur decomposition as an algorithm which, given a square matrix $A$
  and a list eigenvalues, computes $B$, $P$, and $Q$ such that
  $A = PBQ$, $B$ is upper-triangular and $PQ = 1$. The algorithm works is generic in
  the kind of field and can be applied on the rationals, the reals, and the complex numbers.
  The algorithm relies on the method of Gram-Schmidt to create an orthogonal basis,
  and on the Gauss-Jordan algorithm to find eigenvectors to a given eigenvalue.

 The algorithm is a key ingredient to show that every matrix with a linear factorizable
 characteristic polynomial has a Jordan normal form.

  A further consequence of the algorithm is that the characteristic polynomial of
  a block diagonal matrix is the product of the characteristic polynomials of the blocks.\<close>

theory Schur_Decomposition
imports
  Polynomial_Interpolation.Missing_Polynomial
  Gram_Schmidt
  Char_Poly
begin

definition vec_inv :: "'a::conjugatable_field vec \<Rightarrow> 'a vec"
  where "vec_inv v = 1 / (v \<bullet>c v) \<cdot>\<^sub>v conjugate v"

lemma vec_inv_closed[simp]: "v \<in> carrier_vec n \<Longrightarrow> vec_inv v \<in> carrier_vec n"
  unfolding vec_inv_def by auto

lemma vec_inv_dim[simp]: "dim_vec (vec_inv v) = dim_vec v"
  unfolding vec_inv_def by auto

lemma vec_inv[simp]:
  assumes v: "v : carrier_vec n"
      and v0: "(v::'a::conjugatable_ordered_field vec) \<noteq> 0\<^sub>v n"
  shows "vec_inv v \<bullet> v = 1"
proof -
  { assume "v \<bullet>c v = 0"
    hence "v = 0\<^sub>v n" using conjugate_square_eq_0_vec[OF v] by auto
    hence False using v0 by auto
  }
  moreover have "conjugate v \<bullet> v = v \<bullet>c v"
    apply (rule comm_scalar_prod) using v by auto
  ultimately show ?thesis
    unfolding vec_inv_def
    apply (subst smult_scalar_prod_distrib)
    using assms by auto
qed

lemma corthogonal_inv:
  assumes orth: "corthogonal (vs ::'a::conjugatable_field vec list)"
      and V: "set vs \<subseteq> carrier_vec n"
  shows "inverts_mat (mat_of_rows n (map vec_inv vs)) (mat_of_cols n vs)"
    (is "inverts_mat ?W ?V")
proof -
  define l where "l = length vs"
  have rW[simp]: "dim_row ?W = l" using l_def by auto
  have cV[simp]:"dim_col ?V = l" using l_def by auto
  have dim: "\<And>i. i < length vs \<Longrightarrow> vs!i \<in> carrier_vec n" using V by auto
  show ?thesis
    unfolding inverts_mat_def
    apply rule
    unfolding mat_of_rows_carrier length_map l_def[symmetric]
    unfolding index_one_mat
  proof -
    show "dim_row (?W * ?V) = l" "dim_col (?W * ?V) = l"
      unfolding times_mat_def rW cV by auto
    fix i j assume i:"i<l" and j: "j<l"
    hence i2: "i<length vs"
      and i3: "i<length (map vec_inv vs)"
      and j2: "j<length vs" using l_def by auto
    hence id2: "vs ! i \<in> carrier_vec n"
      and id3: "map vec_inv vs ! i \<in> carrier_vec n"
      and id4: "conjugate (vs ! i) \<in> carrier_vec n"
      and jd2: "vs ! j \<in> carrier_vec n" using dim by auto
    show "(?W * ?V) $$ (i,j) = (if i = j then 1 else 0)"
      unfolding times_mat_def rW cV
      unfolding index_mat[OF i j] split
      unfolding mat_of_rows_row[OF i3 id3]
      unfolding col_mat_of_cols[OF j2 jd2]
      unfolding nth_map[OF i2]
      unfolding vec_inv_def
      unfolding smult_scalar_prod_distrib[OF id4 jd2]
      unfolding comm_scalar_prod[OF id4 jd2]
      using corthogonalD[OF orth j2 i2] by auto
  qed
qed

definition corthogonal_inv :: "'a::conjugatable_field mat \<Rightarrow> 'a mat"
  where "corthogonal_inv A = mat_of_rows (dim_row A) (map vec_inv (cols A))"

definition mat_adjoint :: "'a :: conjugatable_field mat \<Rightarrow> 'a mat"
  where "mat_adjoint A \<equiv> mat_of_rows (dim_row A) (map conjugate (cols A))"

definition corthogonal_mat :: "'a::conjugatable_field mat \<Rightarrow> bool"
  where "corthogonal_mat A \<equiv>
    let B = mat_adjoint A * A in
    diagonal_mat B \<and> (\<forall>i<dim_col A. B $$ (i,i) \<noteq> 0)"

lemma corthogonal_matD[elim]:
  assumes orth: "corthogonal_mat A"
      and i: "i < dim_col A"
      and j: "j < dim_col A"
  shows "(col A i \<bullet>c col A j = 0) = (i \<noteq> j)"
proof
  have ci: "col A i : carrier_vec (dim_row A)"
   and cj: "col A j : carrier_vec (dim_row A)" by auto
  note [simp] = conjugate_conjugate_sprod[OF ci cj]

  let ?B = "mat_adjoint A * A"
  have diag: "diagonal_mat ?B" and zero: "\<And>i. i<dim_col A \<Longrightarrow> ?B $$ (i,i) \<noteq> 0"
    using orth unfolding corthogonal_mat_def Let_def by auto
  { assume "i = j"
    hence "conjugate (col A i) \<bullet> col A j \<noteq> 0"
      using zero[OF i] unfolding mat_adjoint_def using i by simp
    hence "conjugate (conjugate (col A i) \<bullet> col A j) \<noteq> 0"
      unfolding conjugate_zero_iff.
    hence "col A i \<bullet>c col A j \<noteq> 0" by simp
  }
  thus "col A i \<bullet>c col A j = 0 \<Longrightarrow> i \<noteq> j" by auto
  { assume "i \<noteq> j"
    hence "conjugate (col A i) \<bullet> col A j = 0"
      using diag
      unfolding diagonal_mat_def
      unfolding mat_adjoint_def using i j by simp
    hence "conjugate (conjugate (col A i) \<bullet> col A j) = 0" by simp
    thus "col A i \<bullet>c col A j = 0" by simp
  }
qed

lemma corthogonal_inv_result:
  assumes o: "corthogonal_mat (A::'a::conjugatable_field mat)"
  shows "inverts_mat (corthogonal_inv A) A"
proof -
  have oc: "corthogonal (cols A)"
    apply (intro corthogonalI) using corthogonal_matD[OF o] by auto
  show ?thesis unfolding corthogonal_inv_def
    using corthogonal_inv[OF oc cols_dim] by auto
qed

text "extends a vector to a basis"

definition basis_completion :: "'a::ring_1 vec \<Rightarrow> 'a vec list" where
  "basis_completion v \<equiv> let
     n = dim_vec v;
     drop_index = hd ([ i . i <- [0..<n], v $ i \<noteq> 0]);
     vs = [unit_vec n i. i <- [0..<n], i \<noteq> drop_index]
   in v # vs"

lemma (in vec_space) basis_completion: fixes v :: "'a :: field vec"
  assumes v: "v \<in> carrier_vec n"
      and v0: "v \<noteq> 0\<^sub>v n"
  shows
    "basis (set (basis_completion v))"
    "set (basis_completion v) \<subseteq> carrier_vec n"
    "span (set (basis_completion v)) = carrier_vec n"
    "distinct (basis_completion v)"
    "\<not> lin_dep (set (basis_completion v))"
    "length (basis_completion v) = n"
    "hd (basis_completion v) = v"
proof -
  let ?b = "basis_completion v"
  note d = basis_completion_def Let_def
  from v have dim: "dim_vec v = n" by auto
  let ?is = "[ i . i <- [0..<n], v $ i \<noteq> 0]"
  {
    assume empty: "set ?is = {}"
    have "v = 0\<^sub>v n"
      by (rule eq_vecI, insert empty v, auto)
  }
  with v0 obtain k ids where id: "?is = k # ids" and mem: "k \<in> set ?is" by (cases ?is, auto)
  from mem have vk: "v $ k \<noteq> 0" and k: "k < n" by auto
  {
    fix i
    assume i: "\<not> i < k"
    have id: "k # [Suc k..<n] = [k ..< n]" using k by (simp add: upt_conv_Cons)
    from i have "i < n \<Longrightarrow> (k # [Suc k..<n]) ! (i - k) = i"
      unfolding id
      by (subst nth_upt, auto)
  }
  hence split: "[0 ..< n] = [0 ..< k] @ k # [Suc k ..< n]"
    by (intro nth_equalityI, insert k, auto simp: nth_append)
  {
    fix as
    assume "k \<notin> set as"
    hence "[unit_vec n i. i <- as, i \<noteq> k] = [unit_vec n i. i <- as]"
      by (induct as, auto)
  } note conv = this
  have b_all: "?b = v # [unit_vec n i. i <- [0..<n], i \<noteq> k]"
    unfolding d dim id by simp
  also have "[unit_vec n i. i <- [0..<n], i \<noteq> k] = [unit_vec n i. i <- [0..<k]] @ [unit_vec n i. i <- [Suc k..<n]]"
    unfolding split by (auto simp: conv)
  finally have b: "?b = v # [unit_vec n i. i <- [0..<k]] @ [unit_vec n i. i <- [Suc k..<n]]" by simp
  show carr: "set ?b \<subseteq> carrier_vec n" (is "?S \<subseteq> _")
    unfolding b using assms by auto
  show "hd ?b = v" unfolding b by auto
  show len: "length (basis_completion v) = n" unfolding b using k
    by auto
  define I where "I = (\<lambda> i. if i < k then i else Suc i)"
  have I: "\<And> i. I i \<noteq> k" "\<And> i. Suc i < n \<Longrightarrow> I i < n" unfolding I_def by auto
  {
    fix i
    assume i: "i < n"
    have "?b ! i = (if i = 0 then v else unit_vec n (I (i - 1)))"
      unfolding b I_def using i
      by (auto split: if_splits simp: nth_append)
  } note bi = this
  show dist: "distinct ?b" unfolding distinct_conv_nth len
  proof (intro allI impI)
    fix i j
    assume i: "i < n" and j: "j < n" and ij: "i \<noteq> j"
    show "?b ! i \<noteq> ?b ! j"
    proof
      assume id1: "?b ! i = ?b ! j"
      hence id2: "\<And> l. ?b ! i $ l = ?b ! j $ l" by auto
      have "i = j"
      proof (cases "i = 0")
        case True
        hence biv: "?b ! i = v" unfolding b by simp
        from True ij have bj: "?b ! j = unit_vec n (I (j - 1))" "Suc (j - 1) = j" unfolding bi[OF j] by auto
        with id2[of k, unfolded biv bj] vk I[of "j - 1"] k j
        have False by simp
        thus ?thesis ..
      next
        case False note i0 = this
        hence bi': "?b ! i = unit_vec n (I (i - 1))" "Suc (i - 1) = i" unfolding bi[OF i] by auto
        show ?thesis
        proof (cases "j = 0")
          case True
          hence bj: "?b ! j = v" unfolding b by simp
          from id2[of k, unfolded bi' bj] vk I[of "i - 1"] k i bi'
          have False by simp
          thus ?thesis by simp
        next
          case False note j0 = this
          hence bj: "?b ! j = unit_vec n (I (j - 1))" "Suc (j - 1) = j" unfolding bi[OF j] by auto
          have "1 = ?b ! i $ I (i - 1)" unfolding bi' using I[of "i - 1"] i i0 by auto
          also have "\<dots> = unit_vec n (I (j - 1)) $ I (i - 1)" unfolding id1 bj by simp
          also have "\<dots> = (if I (i - 1) = I (j - 1) then 1 else 0)"
            using I[of "i - 1"] I[of "j - 1"] i0 j0 i j by auto
          finally have "I (i - 1) = I (j - 1)" by (auto split: if_splits)
          with i0 j0 show "i = j" unfolding I_def by (auto split: if_splits)
        qed
      qed
      thus False using ij by simp
    qed
  qed
  have "span (set ?b) \<subseteq> carrier_vec n" using carr by auto
  moreover
  {
    fix w :: "'a vec"
    assume w: "w \<in> carrier_vec n"
    define lookup where "lookup = (v,k) # [(unit_vec n i, i). i <- [0..<n], i \<noteq> k]"
    define a where "a = (\<lambda> vi. case map_of lookup vi of Some i \<Rightarrow> if i = k then w $ k / v $ k else
       w $ i - w $ k / v $ k * v $ i)"
    have "map fst lookup = ?b" unfolding b_all lookup_def
      by (auto simp: map_concat o_def if_distrib, unfold list.simps fst_def prod.simps, simp)
    with dist have dist: "distinct (map fst lookup)" by simp
    let ?w = "lincomb a (set ?b)"
    have "?w \<in> carrier_vec n" using carr by auto
    with w have dim: "dim_vec w = n" "dim_vec ?w = n" by auto
    have "w = ?w"
    proof (rule eq_vecI; unfold dim)
      fix i
      assume i: "i < n"
      show "w $ i = ?w $ i" unfolding lincomb_def
      proof (subst finsum_index[OF i _ carr])
        show "(\<lambda>v. a v \<cdot>\<^sub>v v) \<in> set ?b \<rightarrow> carrier_vec n" using carr by auto
        {
          fix x :: "'a vec" and j
          assume "x = unit_vec n j" "j \<noteq> k" "j < n"
          hence "(x,j) \<in> set lookup" unfolding lookup_def by auto
          from map_of_is_SomeI[OF dist this]
          have "a x = w $ j - w $ k / v $ k * v $ j" unfolding a_def using \<open>j \<noteq> k\<close> by auto
        } note a = this
        have "(\<Sum>x\<in>set ?b. (a x \<cdot>\<^sub>v x) $ i) = (a v \<cdot>\<^sub>v v) $ i + (\<Sum>x\<in>(set ?b) - {v}. (a x \<cdot>\<^sub>v x) $ i)"
          by (rule sum.remove[OF finite_set], auto simp: b)
        also have "a v = w $ k / v $ k" unfolding a_def lookup_def by auto
        also have "(\<dots> \<cdot>\<^sub>v v) $ i = w $ k / v $ k * v $ i" using i v by auto
        finally have "(\<Sum>x\<in>set ?b. (a x \<cdot>\<^sub>v x) $ i) = w $ k / v $ k * v $ i + (\<Sum>x\<in>(set ?b) - {v}. (a x \<cdot>\<^sub>v x) $ i)" .
        also have "\<dots> = w $ i"
        proof (cases "i = k")
          case True
          hence "w $ k / v $ k * v $ i = w $ k" using vk by auto
          moreover have "(\<Sum>x\<in>(set ?b) - {v}. (a x \<cdot>\<^sub>v x) $ i) = 0" unfolding True
          proof (rule sum.neutral, intro ballI)
            fix x
            assume "x \<in> set ?b - {v}"
            then obtain j where x: "x = unit_vec n j" "j \<noteq> k" "j < n" using k unfolding b by auto
            show "(a x \<cdot>\<^sub>v x) $ k = 0" unfolding a[OF x] unfolding x using x k by auto
          qed
          ultimately show ?thesis unfolding True by simp
        next
          case False
          let ?ui = "unit_vec n i :: 'a vec"
          {
            assume "?ui = v"
            from arg_cong[OF this, of "\<lambda> v. v $ k"] vk i k False have False by auto
          }
          hence diff: "?ui \<noteq> v" by auto
          from a[OF refl False] have ai: "(a ?ui \<cdot>\<^sub>v ?ui) $ i = w $ i - w $ k / v $ k * v $ i"
            using i by auto
          have "?ui \<in> set ?b" unfolding b_all using False k i by auto
          with diff have mem: "unit_vec n i \<in> set ?b - {v}" by auto
          have "w $ k / v $ k * v $ i + (\<Sum>x\<in>(set ?b) - {v}. (a x \<cdot>\<^sub>v x) $ i)
            = w $ i + (\<Sum>x\<in>(set ?b) - {v,?ui}. (a x \<cdot>\<^sub>v x) $ i)"
            by (subst sum.remove[OF _ mem], auto simp: ai intro!: sum.cong)
          also have "(\<Sum>x\<in>(set ?b) - {v,?ui}. (a x \<cdot>\<^sub>v x) $ i) = 0"
            by (rule sum.neutral, unfold b_all, insert i k, auto)
          finally show ?thesis by simp
        qed
        finally show "w $ i = (\<Sum>x\<in>set ?b. (a x \<cdot>\<^sub>v x) $ i)" by simp
      qed
    qed auto
    hence "w \<in> span (set ?b)" unfolding span_def by auto
  }
  ultimately show span: "span (set ?b) = carrier_vec n" by blast
  show "basis (set ?b)"
  proof (rule dim_gen_is_basis[OF finite_set carr span])
    have "card (set ?b) = dim" using dist len distinct_card unfolding dim_is_n by blast
    thus "card (set ?b) \<le> dim" by simp
  qed
  thus "\<not> lin_dep (set ?b)" unfolding basis_def by auto
qed

lemma orthogonal_mat_of_cols:
  assumes W: "set ws \<subseteq> carrier_vec n"
    and orth: "corthogonal ws"
    and len: "length ws = n"
  shows "corthogonal_mat (mat_of_cols n ws)" (is "corthogonal_mat ?W")
proof
    fix i j assume i: "i < dim_col ?W" and j: "j < dim_col ?W"
    hence [simp]: "ws ! i : carrier_vec n" "ws ! j : carrier_vec n"
      using W len by auto
    have "i < length ws" and "j < length ws" using i j using len W by auto
    thus "col ?W i \<bullet>c col ?W j = 0 \<longleftrightarrow> i \<noteq> j"
      using orth
      unfolding corthogonal_def
      by simp
qed

lemma corthogonal_col_ev_0: fixes A :: "'a :: conjugatable_ordered_field mat"
  assumes A: "A \<in> carrier_mat n n"
  and v: "v \<in> carrier_vec n"
  and v0: "v \<noteq> 0\<^sub>v n"
  and eigen[simp]: "A *\<^sub>v v = e \<cdot>\<^sub>v v"
  and n: "n \<noteq> 0"
  and hdws: "hd ws = v"
  and ws: "set ws \<subseteq> carrier_vec n" "corthogonal ws" "length ws = n"
  defines "W == mat_of_cols n ws"
  defines "W' == corthogonal_inv W"
  defines "A' == W' * A * W"
  shows "col A' 0 = vec n (\<lambda> i. if i = 0 then e else 0)"
proof -
  let ?f = "(\<lambda> i. if i = 0 then e else 0)"
  from ws have W: "W \<in> carrier_mat n n" unfolding W_def by auto
  from W have W': "W' \<in> carrier_mat n n" unfolding W'_def
    corthogonal_inv_def mat_of_rows_def by auto
  from A W W' have A': "A' \<in> carrier_mat n n" unfolding A'_def by auto
  show "col A' 0 = vec n ?f"
  proof (rule,unfold dim_vec)
    show dim: "dim_vec (col A' 0) = n" using A' by simp
    have row0: "vec_inv v \<bullet> (A *\<^sub>v v) = e"
      using scalar_prod_smult_distrib[OF vec_inv_closed[OF v] v]
      using vec_inv[OF v v0] by auto
    fix i assume i: "i < n"
    hence i2: "i < length ws" using ws by auto
    let ?wsi = "ws ! i"
    have z: "0 < dim_col A'" using A' n by auto
    hence z2: "0 < length ws" using A' ws by auto
    have wsi[simp]: "ws!i : carrier_vec n" using ws i by auto
    hence ws0[simp]: "ws!0 = v" using hd_conv_nth[symmetric] hdws z2 by auto
    have "col A' 0 $ i = A' $$ (i, 0)" using A' i by auto
    also have "... = (W' * (A * W)) $$ (i, 0)" unfolding A'_def using W' A W by auto
    also have "... = row W' i \<bullet> col (A * W) 0"
      apply (subst index_mult_mat) using W W' A i by auto
    also have "row W' i = vec_inv ?wsi"
      unfolding W'_def W_def unfolding corthogonal_inv_def using i ws by auto
    also have "col (A * W) 0 = A *\<^sub>v col W 0" using A W z A' by auto
    also have "col W 0 = v" unfolding W_def using z2 ws0 n col_mat_of_cols v by blast
    also have "A *\<^sub>v v = e \<cdot>\<^sub>v v" using eigen.
    also have "vec_inv ?wsi \<bullet> (e \<cdot>\<^sub>v v) = e * (vec_inv ?wsi \<bullet> v)"
      using scalar_prod_smult_distrib[OF vec_inv_closed[OF wsi] v].
    also have "... = ?f i"
    proof(cases "i = 0")
      case True thus ?thesis using vec_inv[OF v v0] by simp
    next
      case False
      hence z: "0 < length ws" using i ws by auto
      note cwsi = carrier_vec_conjugate[OF wsi]
      have "vec_inv ?wsi \<bullet> v = 1 / (?wsi \<bullet>c ?wsi) * (conjugate ?wsi \<bullet> v)"
        unfolding vec_inv_def unfolding smult_scalar_prod_distrib[OF cwsi v]..
      also have "conjugate ?wsi \<bullet> v = v \<bullet>c ?wsi"
        using comm_scalar_prod[OF cwsi v].
      also have "... = 0"
        using corthogonalD[OF ws(2) z i2] False unfolding ws0 by auto
      finally show ?thesis using False by auto
    qed
    also have "... = vec n ?f $ i" using i by simp
    finally show "col A' 0 $ i = vec n ?f $ i" .
  qed
qed

text "Schur decomposition"
fun schur_decomposition :: "'a::conjugatable_field mat \<Rightarrow> 'a list \<Rightarrow> 'a mat \<times> 'a mat \<times> 'a mat" where
  "schur_decomposition A [] = (A, 1\<^sub>m (dim_row A), 1\<^sub>m (dim_row A))"
| "schur_decomposition A (e # es) = (let
       n = dim_row A;
       n1 = n - 1;
       v = find_eigenvector A e;
       ws = gram_schmidt n (basis_completion v);
       W = mat_of_cols n ws;
       W' = corthogonal_inv W;
       A' = W' * A * W;
       (A1,A2,A0,A3) = split_block A' 1 1;
       (B,P,Q) = schur_decomposition A3 es;
       z_row = (0\<^sub>m 1 n1);
       z_col = (0\<^sub>m n1 1);
       one_1 = 1\<^sub>m 1
     in (four_block_mat A1 (A2 * P) A0 B,
     W * four_block_mat one_1 z_row z_col P,
     four_block_mat one_1 z_row z_col Q * W'))"

theorem schur_decomposition:
  assumes A: "(A::'a::conjugatable_ordered_field mat) \<in> carrier_mat n n"
      and c: "char_poly A = (\<Prod> (e :: 'a) \<leftarrow> es. [:- e, 1:])"
      and B: "schur_decomposition A es = (B,P,Q)"
  shows "similar_mat_wit A B P Q \<and> upper_triangular B \<and> diag_mat B = es"
  using assms
proof (induct es arbitrary: n A B P Q)
  case Nil
  with degree_monic_char_poly[of A n]
  show ?case by (auto intro: similar_mat_wit_refl simp: diag_mat_def)
next
  case (Cons e es n A C P Q)
  let ?n1 = "n - 1"
  from Cons have A: "A \<in> carrier_mat n n" and dim: "dim_row A = n" by auto
  let ?cp = "char_poly A"
  from Cons(3)
  have cp: "?cp = [: -e, 1 :] * (\<Prod>e \<leftarrow> es. [:- e, 1:])" by auto
  have mon: "monic (\<Prod>e\<leftarrow> es. [:- e, 1:])" by (rule monic_prod_list, auto)
  have deg: "degree ?cp = Suc (degree (\<Prod>e\<leftarrow> es. [:- e, 1:]))" unfolding cp
    by (subst degree_mult_eq, insert mon, auto)
  with degree_monic_char_poly[OF A] have n: "n \<noteq> 0" by auto
  define v where "v = find_eigenvector A e"
  define b where "b = basis_completion v"
  define ws where "ws = gram_schmidt n b"
  define W where "W = mat_of_cols n ws"
  define W' where "W' = corthogonal_inv W"
  define A' where "A' = W' * A * W"
  obtain A1 A2 A0 A3 where splitA': "split_block A' 1 1 = (A1,A2,A0,A3)"
    by (cases "split_block A' 1 1", auto)
  obtain B P' Q' where schur: "schur_decomposition A3 es = (B,P',Q')"
    by (cases "schur_decomposition A3 es", auto)
  let ?P' = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 ?n1) (0\<^sub>m ?n1 1) P'"
  let ?Q' = "four_block_mat (1\<^sub>m 1) (0\<^sub>m 1 ?n1) (0\<^sub>m ?n1 1) Q'"
  have C: "C = four_block_mat A1 (A2 * P') A0 B" and P: "P = W * ?P'" and Q: "Q = ?Q' * W'"
    using Cons(4) unfolding schur_decomposition.simps
    Let_def list.sel dim
    v_def[symmetric] b_def[symmetric] ws_def[symmetric] W'_def[symmetric] W_def[symmetric]
    A'_def[symmetric] split splitA' schur by auto
  have e: "eigenvalue A e"
    unfolding eigenvalue_root_char_poly[OF A] cp by simp
  from find_eigenvector[OF A e] have ev: "eigenvector A v e" unfolding v_def .
  from this[unfolded eigenvector_def]
  have v[simp]: "v \<in> carrier_vec n" and v0: "v \<noteq> 0\<^sub>v n" using A by auto
  interpret cof_vec_space n "TYPE('a)" .
  from basis_completion[OF v v0, folded b_def]
  have span_b: "span (set b) = carrier_vec n" and dist_b: "distinct b"
    and indep: "\<not> lin_dep (set b)" and b: "set b \<subseteq> carrier_vec n" and hdb: "hd b = v"
    and len_b: "length b = n" by auto
  from hdb len_b n obtain vs where bv: "b = v # vs" by (cases b, auto)
  from gram_schmidt_result[OF b dist_b indep refl, folded ws_def]
  have ws: "set ws \<subseteq> carrier_vec n" "corthogonal ws" "length ws = n"
    by (auto simp: len_b)
  from gram_schmidt_hd[OF v, of vs, folded bv] have hdws: "hd ws = v" unfolding ws_def .
  have orth_W: "corthogonal_mat W" using orthogonal_mat_of_cols ws unfolding W_def.
  have W: "W \<in> carrier_mat n n"
    using ws unfolding W_def using mat_of_cols_carrier(1)[of n ws] by auto
  have W': "W' \<in> carrier_mat n n" unfolding W'_def corthogonal_inv_def using W
    by (auto simp: mat_of_rows_def)
  from corthogonal_inv_result[OF orth_W]
  have W'W: "inverts_mat W' W" unfolding W'_def .
  hence WW': "inverts_mat W W'" using mat_mult_left_right_inverse[OF W' W] W' W
    unfolding inverts_mat_def by auto
  have A': "A' \<in> carrier_mat n n" using W W' A unfolding A'_def by auto
  have A'A_wit: "similar_mat_wit A' A W' W"
    by (rule similar_mat_witI[of _ _ n], insert W W' A A' W'W WW', auto simp: A'_def
    inverts_mat_def)
  hence A'A: "similar_mat A' A" unfolding similar_mat_def by blast
  from similar_mat_wit_sym[OF A'A_wit] have simAA': "similar_mat_wit A A' W W'" by auto
  have eigen[simp]: "A *\<^sub>v v = e \<cdot>\<^sub>v v" and v0: "v \<noteq> 0\<^sub>v n"
    using v_def find_eigenvector[OF A e] A
    unfolding eigenvector_def by auto
  let ?f = "(\<lambda> i. if i = 0 then e else 0)"
  have col0: "col A' 0 = vec n ?f"
    unfolding A'_def W'_def W_def
    using corthogonal_col_ev_0[OF A v v0 eigen n hdws ws].
  from A' n have "dim_row A' = 1 + ?n1" "dim_col A' = 1 + ?n1" by auto
  from split_block[OF splitA' this] have A2: "A2 \<in> carrier_mat 1 ?n1"
    and A3: "A3 \<in> carrier_mat ?n1 ?n1"
    and A'block: "A' = four_block_mat A1 A2 A0 A3" by auto
  have A1id: "A1 = mat 1 1 (\<lambda> _. e)"
    using splitA'[unfolded split_block_def Let_def] arg_cong[OF col0, of "\<lambda> v. v $ 0"] A' n
    by (auto simp: col_def)
  have A1: "A1 \<in> carrier_mat 1 1" unfolding A1id by auto
  {
    fix i
    assume "i < ?n1"
    with arg_cong[OF col0, of "\<lambda> v. v $ Suc i"] A'
    have "A' $$ (Suc i, 0) = 0" by auto
  } note A'0 = this
  have A0id: "A0 = 0\<^sub>m ?n1 1"
    using splitA'[unfolded split_block_def Let_def] A'0 A' by auto
  have A0: "A0 \<in> carrier_mat ?n1 1" unfolding A0id by auto
  from cp char_poly_similar[OF A'A]
  have cp: "char_poly A' = [: -e,1 :] * (\<Prod> e \<leftarrow> es. [:- e, 1:])" by simp
  also have "char_poly A' = char_poly A1 * char_poly A3"
    unfolding A'block A0id
    by (rule char_poly_four_block_zeros_col[OF A1 A2 A3])
  also have "char_poly A1 = [: -e,1 :]"
    by (simp add: A1id char_poly_defs det_def signof_def sign_def)
  finally have cp: "char_poly A3 = (\<Prod> e \<leftarrow> es. [:- e, 1:])"
    by (metis mult_cancel_left pCons_eq_0_iff zero_neq_one)
  from Cons(1)[OF A3 cp schur]
  have simIH: "similar_mat_wit A3 B P' Q'" and ut: "upper_triangular B" and diag: "diag_mat B = es" by auto
  from similar_mat_witD2[OF A3 simIH]
  have B: "B \<in> carrier_mat ?n1 ?n1" and P': "P' \<in> carrier_mat ?n1 ?n1" and Q': "Q' \<in> carrier_mat ?n1 ?n1"
    and PQ': "P' * Q' = 1\<^sub>m ?n1" by auto
  have A0_eq: "A0 = P' * A0 * 1\<^sub>m 1" unfolding A0id using P' by auto
  have simA'C: "similar_mat_wit A' C ?P' ?Q'" unfolding A'block C
    by (rule similar_mat_wit_four_block[OF similar_mat_wit_refl[OF A1] simIH _ A0_eq A1 A3 A0],
    insert PQ' A2 P' Q', auto)
  have ut1: "upper_triangular A1" unfolding A1id by auto
  have ut: "upper_triangular C" unfolding C A0id
    by (intro upper_triangular_four_block[OF _ B ut1 ut], auto simp: A1id)
  from A1id have diagA1: "diag_mat A1 = [e]" unfolding diag_mat_def by auto
  from diag_four_block_mat[OF A1 B] have diag: "diag_mat C = e # es" unfolding diag diagA1 C by simp
  from ut similar_mat_wit_trans[OF simAA' simA'C, folded P Q] diag
  show ?case by blast
qed

definition schur_upper_triangular :: "'a::conjugatable_field mat \<Rightarrow> 'a list \<Rightarrow> 'a mat" where
  "schur_upper_triangular A es = (case schur_decomposition A es of (B,_,_) \<Rightarrow> B)"

lemma schur_upper_triangular:
  assumes A: "(A :: 'a :: conjugatable_ordered_field mat) \<in> carrier_mat n n"
  and linear: "char_poly A = (\<Prod> a \<leftarrow> es. [:- a, 1:])"
  defines B: "B \<equiv> schur_upper_triangular A es"
  shows "B \<in> carrier_mat n n" "upper_triangular B" "similar_mat A B"
proof -
  let ?B = "schur_upper_triangular A es"
  obtain C P Q where schur: "schur_decomposition A es = (C,P,Q)"
    by (cases "schur_decomposition A es", auto)
  hence B: "B = C" using A unfolding schur_upper_triangular_def B by auto
  from schur_decomposition[OF A linear schur]
  have sim: "similar_mat_wit A B P Q" and B: "upper_triangular B" unfolding B by auto
  from sim show "similar_mat A B" unfolding similar_mat_def by auto
  from similar_mat_witD2[OF A sim] show "B \<in> carrier_mat n n" by auto
  show "upper_triangular B" by fact
qed

lemma schur_decomposition_exists: assumes A: "A \<in> carrier_mat n n"
  and linear: "char_poly A = (\<Prod> (a :: 'a :: conjugatable_ordered_field) \<leftarrow> es. [:- a, 1:])"
  shows "\<exists> B \<in> carrier_mat n n. upper_triangular B \<and> similar_mat A B"
  using schur_upper_triangular[OF A linear] by blast

lemma char_poly_0_block: fixes A :: "'a :: conjugatable_ordered_field mat"
  assumes A: "A = four_block_mat B C (0\<^sub>m m n) D"
  and linearB: "\<exists> es. char_poly B = (\<Prod> a \<leftarrow> es. [:- a, 1:])"
  and linearD: "\<exists> es. char_poly D = (\<Prod> a \<leftarrow> es. [:- a, 1:])"
  and B: "B \<in> carrier_mat n n"
  and C: "C \<in> carrier_mat n m"
  and D: "D \<in> carrier_mat m m"
  shows "char_poly A = char_poly B * char_poly D"
proof -
  from linearB obtain bs where cB: "char_poly B = (\<Prod>a\<leftarrow>bs. [:- a, 1:])" by auto
  from linearD obtain ds where cD: "char_poly D = (\<Prod>a\<leftarrow>ds. [:- a, 1:])" by auto
  from schur_decomposition_exists[OF B cB]
  obtain B' PB QB where sB: "schur_decomposition B bs = (B',PB,QB)"
    by (cases "schur_decomposition B bs", auto)
  obtain D' PD QD where sD: "schur_decomposition D ds = (D',PD,QD)"
    by (cases "schur_decomposition D ds", auto)
  from schur_decomposition[OF B cB sB] similar_mat_witD2[OF B, of B'] have
    simB: "similar_mat B B'" and utB: "upper_triangular B'" and diagB: "diag_mat B' = bs"
    and B': "B' \<in> carrier_mat n n"
    by (auto simp: similar_mat_def)
  from schur_decomposition[OF D cD sD] similar_mat_witD2[OF D, of D'] have
    simD: "similar_mat D D'" and utD: "upper_triangular D'" and diagD: "diag_mat D' = ds"
    and D': "D' \<in> carrier_mat m m"
    by (auto simp: similar_mat_def)
  let ?z = "0\<^sub>m m n"
  from similar_mat_four_block_0_ex[OF simB simD C B D, folded A]
    obtain B0 where B0: "B0 \<in> carrier_mat n m" and sim: "similar_mat A (four_block_mat B' B0 ?z D')"
    by auto
  let ?block = "four_block_mat B' B0 ?z D'"
  let ?cp = char_poly
  let ?prod = "QB * C * PD"
  let ?diag = "\<lambda> A. (\<Prod>a\<leftarrow>diag_mat A. [:- a, 1:])"
  from char_poly_similar[OF sim] have "?cp A = ?cp ?block" by simp
  also have "\<dots> = ?diag ?block"
    by (rule char_poly_upper_triangular[OF four_block_carrier_mat[OF B' D'] upper_triangular_four_block[OF B' D' utB utD]])
  also have "\<dots> = ?diag B' * ?diag D'" unfolding diag_four_block_mat[OF B' D']
    by auto
  also have "?diag B' = ?cp B'"
    by (subst char_poly_upper_triangular[OF B' utB], simp)
  also have "\<dots> = ?cp B"
    by (rule char_poly_similar[OF similar_mat_sym[OF simB]])
  also have "?diag D' = ?cp D'"
    by (subst char_poly_upper_triangular[OF D' utD], simp)
  also have "\<dots> = ?cp D"
    by (rule char_poly_similar[OF similar_mat_sym[OF simD]])
  finally show ?thesis .
qed

lemma char_poly_0_block': fixes A :: "'a :: conjugatable_ordered_field mat"
  assumes A: "A = four_block_mat B (0\<^sub>m n m) C D"
  and linearB: "\<exists> es. char_poly B = (\<Prod> a \<leftarrow> es. [:- a, 1:])"
  and linearD: "\<exists> es. char_poly D = (\<Prod> a \<leftarrow> es. [:- a, 1:])"
  and B: "B \<in> carrier_mat n n"
  and C: "C \<in> carrier_mat m n"
  and D: "D \<in> carrier_mat m m"
  shows "char_poly A = char_poly B * char_poly D"
proof -
  let ?A = "four_block_mat B (0\<^sub>m n m) C D"
  let ?B = "transpose_mat B"
  let ?D = "transpose_mat D"
  have AC: "?A \<in> carrier_mat (n + m) (n + m)" using B D by auto
  from arg_cong[OF transpose_four_block_mat[OF B zero_carrier_mat C D], of char_poly,
    unfolded char_poly_transpose_mat[OF AC], folded A]
  have "char_poly A =
    char_poly (four_block_mat ?B (transpose_mat C) (0\<^sub>m m n) ?D)" by auto
  also have "\<dots> = char_poly ?B * char_poly ?D"
    by (rule char_poly_0_block[OF refl], insert B C D linearB linearD, auto)
  also have "\<dots> = char_poly B * char_poly D" using B D
    by simp
  finally show ?thesis .
qed

end


theory BoolosATP imports Main
begin

typedecl i
consts
 e :: "i"  (* one *)
 s :: "i\<Rightarrow>i"  (* successor function *)
 F :: "i\<Rightarrow>i\<Rightarrow>i"  (* binary function; axiomatised below as Ackermann function *)
 D :: "i\<Rightarrow>bool"  (* arbitrary uninterpreted unary predicate *)

axiomatization where
    A1: "\<forall>n. F n e = s e"  (* Axiom for Ackermann function F *)
and A2: "\<forall>y. F e (s y) = s (s (F e y))"  (* Axiom for Ackermann function F *)
and A3: "\<forall>x y. F (s x) (s y) = F x (F (s x) y)"  (* Axiom for Ackermann function F *)
and A4: "D e"  (* D holds for one *)
and A5: "\<forall>x. D x \<longrightarrow> D (s x)" (* if D holds for x it also holds for the successor of x *)

lemma "D (F (s (s (s (s e)))) (s (s (s (s e)))))" sledgehammer oops (* no proof; hopeless! *)

definition isIndSet where "isIndSet X \<equiv> (X e) \<and> (\<forall>x. X x \<longrightarrow> X (s x))"  (* X is inductive *)
definition N where "N x \<equiv> (\<forall>X::i\<Rightarrow>bool. isIndSet X \<longrightarrow> X x)"   (* N is smallest inductive set *)
definition P where "P x y \<equiv> N (F x y)"   (* P(x,y) iff F(x,y) is in N *)

lemma "D (F (s (s (s (s e)))) (s (s (s (s e)))))"  (* ATPs can now proof this: using the Defs *)
  sledgehammer  (* proof found *)
  by (metis A1 A2 A3 A4 A5 N_def P_def isIndSet_def)  (* proof reconstruction succeeds *)
end


(*  Title:      Isomorphism Classes of Groups
    Author:     Jakob von Raumer, Karlsruhe Institute of Technology
    Maintainer: Jakob von Raumer <jakob.raumer@student.kit.edu>
*)

theory GroupIsoClasses
imports
  "Groups"
  "List"
  "Coset"
begin

section {* Isomorphism Classes of Groups *}

text {* We construct a quotient type for isomorphism classes of groups. *}

typedef 'a group = "{G :: 'a monoid. group G}"
proof
  show "\<And>a. \<lparr>carrier = {a}, mult = (\<lambda>x y. x), one = a\<rparr> \<in> {G. group G}"
  unfolding group_def group_axioms_def monoid_def Units_def by auto
qed

definition group_iso_rel :: "'a group \<Rightarrow> 'a group \<Rightarrow> bool"
  where "group_iso_rel G H = (\<exists>\<phi>. \<phi> \<in> Rep_group G \<cong> Rep_group H)"

quotient_type 'a group_iso_class = "'a group" / group_iso_rel
  morphisms Rep_group_iso Abs_group_iso
proof (rule equivpI)
  show "reflp group_iso_rel"
  proof (rule reflpI)
    fix G :: "'b group"
    show "group_iso_rel G G"
    unfolding group_iso_rel_def using Rep_group iso_refl by auto
  qed
next
  show "symp group_iso_rel"
  proof (rule sympI)
    fix G H :: "'b group"
    assume "group_iso_rel G H"
    then obtain \<phi> where "\<phi> \<in> Rep_group G \<cong> Rep_group H" unfolding group_iso_rel_def by auto
    then obtain \<phi>' where "\<phi>' \<in> Rep_group H \<cong> Rep_group G" using group.iso_sym Rep_group by fastforce
    thus "group_iso_rel H G" unfolding group_iso_rel_def by auto
  qed
next
  show "transp group_iso_rel"
  proof (rule transpI)
    fix G H I :: "'b group"
    assume "group_iso_rel G H" "group_iso_rel H I"
    then obtain \<phi> \<psi> where "\<phi> \<in> Rep_group G \<cong> Rep_group H" "\<psi> \<in> Rep_group H \<cong> Rep_group I" unfolding group_iso_rel_def by auto
    then obtain \<pi> where "\<pi> \<in> Rep_group G \<cong> Rep_group I" using group.iso_trans Rep_group by fastforce
    thus "group_iso_rel G I" unfolding group_iso_rel_def by auto
  qed
qed

text {* This assigns to a given group the group isomorphism class *}

definition (in group) iso_class :: "'a group_iso_class"
  where "iso_class = Abs_group_iso (Abs_group (monoid.truncate G))"

text {* Two isomorphic groups do indeed have the same isomorphism class: *}

lemma iso_classes_iff:
  assumes "group G"
  assumes "group H"
  shows "(\<exists>\<phi>. \<phi> \<in> G \<cong> H) = (group.iso_class G = group.iso_class H)"
proof -
  from assms(1,2) have groups:"group (monoid.truncate G)" "group (monoid.truncate H)"
    unfolding monoid.truncate_def group_def group_axioms_def Units_def monoid_def by auto
  have "(\<exists>\<phi>. \<phi> \<in> G \<cong> H) = (\<exists>\<phi>. \<phi> \<in> (monoid.truncate G) \<cong> (monoid.truncate H))"
    unfolding iso_def hom_def monoid.truncate_def by auto
  also have "\<dots> = group_iso_rel (Abs_group (monoid.truncate G)) (Abs_group (monoid.truncate H))"
    unfolding group_iso_rel_def using groups group.Abs_group_inverse by (metis mem_Collect_eq)
  also have "\<dots> = (group.iso_class G = group.iso_class H)" using group.iso_class_def assms group_iso_class.abs_eq_iff by metis
  finally show ?thesis.
qed

end