diff --git a/thys/Complex_Bounded_Operators/Complex_Bounded_Linear_Function.thy b/thys/Complex_Bounded_Operators/Complex_Bounded_Linear_Function.thy
--- a/thys/Complex_Bounded_Operators/Complex_Bounded_Linear_Function.thy
+++ b/thys/Complex_Bounded_Operators/Complex_Bounded_Linear_Function.thy
@@ -1,4403 +1,4530 @@
 section \<open>\<open>Complex_Bounded_Linear_Function\<close> -- Complex bounded linear functions (bounded operators)\<close>
 
 (*
 Authors:
 
   Dominique Unruh, University of Tartu, unruh@ut.ee
   Jose Manuel Rodriguez Caballero, University of Tartu, jose.manuel.rodriguez.caballero@ut.ee
 
 *)
 
 theory Complex_Bounded_Linear_Function
   imports
     "HOL-Types_To_Sets.Types_To_Sets"
     Banach_Steinhaus.Banach_Steinhaus
     Complex_Inner_Product
     One_Dimensional_Spaces
     Complex_Bounded_Linear_Function0
     "HOL-Library.Function_Algebras"
 begin
 
 unbundle lattice_syntax
 
 subsection \<open>Misc basic facts and declarations\<close>
 
 notation cblinfun_apply (infixr "*\<^sub>V" 70)
 
 lemma id_cblinfun_apply[simp]: "id_cblinfun *\<^sub>V \<psi> = \<psi>"
   apply transfer by simp
 
 lemma apply_id_cblinfun[simp]: \<open>(*\<^sub>V) id_cblinfun = id\<close>
   by auto
 
 lemma isCont_cblinfun_apply[simp]: "isCont ((*\<^sub>V) A) \<psi>"
   apply transfer
   by (simp add: clinear_continuous_at)
 
 declare cblinfun.scaleC_left[simp]
 
 lemma cblinfun_apply_clinear[simp]: \<open>clinear (cblinfun_apply A)\<close>
   using bounded_clinear.axioms(1) cblinfun_apply by blast
 
 lemma cblinfun_cinner_eqI:
   fixes A B :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'a\<close>
   assumes \<open>\<And>\<psi>. cinner \<psi> (A *\<^sub>V \<psi>) = cinner \<psi> (B *\<^sub>V \<psi>)\<close>
   shows \<open>A = B\<close>
 proof -
   define C where \<open>C = A - B\<close>
   have C0[simp]: \<open>cinner \<psi> (C \<psi>) = 0\<close> for \<psi>
     by (simp add: C_def assms cblinfun.diff_left cinner_diff_right)
   { fix f g \<alpha>
     have \<open>0 = cinner (f + \<alpha> *\<^sub>C g) (C *\<^sub>V (f + \<alpha> *\<^sub>C g))\<close>
       by (simp add: cinner_diff_right minus_cblinfun.rep_eq)
     also have \<open>\<dots> = \<alpha> *\<^sub>C cinner f (C g) + cnj \<alpha> *\<^sub>C cinner g (C f)\<close>
       by (smt (z3) C0 add.commute add.right_neutral cblinfun.add_right cblinfun.scaleC_right cblinfun_cinner_right.rep_eq cinner_add_left cinner_scaleC_left complex_scaleC_def)
     finally have \<open>\<alpha> *\<^sub>C cinner f (C g) = - cnj \<alpha> *\<^sub>C cinner g (C f)\<close>
       by (simp add: eq_neg_iff_add_eq_0)
   }
   then have \<open>cinner f (C g) = 0\<close> for f g
     by (metis complex_cnj_i complex_cnj_one complex_vector.scale_cancel_right complex_vector.scale_left_imp_eq equation_minus_iff i_squared mult_eq_0_iff one_neq_neg_one)
   then have \<open>C g = 0\<close> for g
     using cinner_eq_zero_iff by blast
   then have \<open>C = 0\<close>
     by (simp add: cblinfun_eqI)
   then show \<open>A = B\<close>
     using C_def by auto
 qed
 
 lemma id_cblinfun_not_0[simp]: \<open>(id_cblinfun :: 'a::{complex_normed_vector, not_singleton} \<Rightarrow>\<^sub>C\<^sub>L _) \<noteq> 0\<close>
   by (metis (full_types) Extra_General.UNIV_not_singleton cblinfun.zero_left cblinfun_id_cblinfun_apply ex_norm1 norm_zero one_neq_zero)
 
 lemma cblinfun_norm_geqI:
   assumes \<open>norm (f *\<^sub>V x) / norm x \<ge> K\<close>
   shows \<open>norm f \<ge> K\<close>
   using assms apply transfer
   by (smt (z3) bounded_clinear.bounded_linear le_onorm)
 
 (* This lemma is proven in Complex_Bounded_Linear_Function0 but we add the [simp]
    only here because we try to keep Complex_Bounded_Linear_Function0 as close to
    Bounded_Linear_Function as possible. *)
 declare scaleC_conv_of_complex[simp]
 
 lemma cblinfun_eq_0_on_span:
   fixes S::\<open>'a::complex_normed_vector set\<close>
   assumes "x \<in> cspan S"
     and "\<And>s. s\<in>S \<Longrightarrow> F *\<^sub>V s = 0"
   shows \<open>F *\<^sub>V x = 0\<close>
   apply (rule complex_vector.linear_eq_0_on_span[where f=F])
   using bounded_clinear.axioms(1) cblinfun_apply assms by auto
 
 lemma cblinfun_eq_on_span:
   fixes S::\<open>'a::complex_normed_vector set\<close>
   assumes "x \<in> cspan S"
     and "\<And>s. s\<in>S \<Longrightarrow> F *\<^sub>V s = G *\<^sub>V s"
   shows \<open>F *\<^sub>V x = G *\<^sub>V x\<close>
   apply (rule complex_vector.linear_eq_on_span[where f=F])
   using bounded_clinear.axioms(1) cblinfun_apply assms by auto
 
 lemma cblinfun_eq_0_on_UNIV_span:
   fixes basis::\<open>'a::complex_normed_vector set\<close>
   assumes "cspan basis = UNIV"
     and "\<And>s. s\<in>basis \<Longrightarrow> F *\<^sub>V s = 0"
   shows \<open>F = 0\<close>
   by (metis cblinfun_eq_0_on_span UNIV_I assms cblinfun.zero_left cblinfun_eqI)
 
 lemma cblinfun_eq_on_UNIV_span:
   fixes basis::"'a::complex_normed_vector set" and \<phi>::"'a \<Rightarrow> 'b::complex_normed_vector"
   assumes "cspan basis = UNIV"
     and "\<And>s. s\<in>basis \<Longrightarrow> F *\<^sub>V s = G *\<^sub>V s"
   shows \<open>F = G\<close>
 proof-
   have "F - G = 0"
     apply (rule cblinfun_eq_0_on_UNIV_span[where basis=basis])
     using assms by (auto simp add: cblinfun.diff_left)
   thus ?thesis by simp
 qed
 
 lemma cblinfun_eq_on_canonical_basis:
   fixes f g::"'a::{basis_enum,complex_normed_vector} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector"
   defines "basis == set (canonical_basis::'a list)"
   assumes "\<And>u. u \<in> basis \<Longrightarrow> f *\<^sub>V u = g *\<^sub>V u"
   shows  "f = g"
   apply (rule cblinfun_eq_on_UNIV_span[where basis=basis])
   using assms is_generator_set is_cindependent_set by auto
 
 lemma cblinfun_eq_0_on_canonical_basis:
   fixes f ::"'a::{basis_enum,complex_normed_vector} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector"
   defines "basis == set (canonical_basis::'a list)"
   assumes "\<And>u. u \<in> basis \<Longrightarrow> f *\<^sub>V u = 0"
   shows  "f = 0"
   by (simp add: assms cblinfun_eq_on_canonical_basis)
 
 lemma cinner_canonical_basis_eq_0:
   defines "basisA == set (canonical_basis::'a::onb_enum list)"
     and   "basisB == set (canonical_basis::'b::onb_enum list)"
   assumes "\<And>u v. u\<in>basisA \<Longrightarrow> v\<in>basisB \<Longrightarrow> \<langle>v, F *\<^sub>V u\<rangle> = 0"
   shows "F = 0"
 proof-
   have "F *\<^sub>V u = 0"
     if "u\<in>basisA" for u
   proof-
     have "\<And>v. v\<in>basisB \<Longrightarrow> \<langle>v, F *\<^sub>V u\<rangle> = 0"
       by (simp add: assms(3) that)
     moreover have "(\<And>v. v\<in>basisB \<Longrightarrow> \<langle>v, x\<rangle> = 0) \<Longrightarrow> x = 0"
       for x
     proof-
       assume r1: "\<And>v. v\<in>basisB \<Longrightarrow> \<langle>v, x\<rangle> = 0"
       have "\<langle>v, x\<rangle> = 0" for v
       proof-
         have "cspan basisB = UNIV"
           using basisB_def is_generator_set  by auto
         hence "v \<in> cspan basisB"
           by (smt iso_tuple_UNIV_I)
         hence "\<exists>t s. v = (\<Sum>a\<in>t. s a *\<^sub>C a) \<and> finite t \<and> t \<subseteq> basisB"
           using complex_vector.span_explicit
           by (smt mem_Collect_eq)
         then obtain t s where b1: "v = (\<Sum>a\<in>t. s a *\<^sub>C a)" and b2: "finite t" and b3: "t \<subseteq> basisB"
           by blast
         have "\<langle>v, x\<rangle> = \<langle>(\<Sum>a\<in>t. s a *\<^sub>C a), x\<rangle>"
           by (simp add: b1)
         also have "\<dots> = (\<Sum>a\<in>t. \<langle>s a *\<^sub>C a, x\<rangle>)"
           using cinner_sum_left by blast
         also have "\<dots> = (\<Sum>a\<in>t. cnj (s a) * \<langle>a, x\<rangle>)"
           by auto
         also have "\<dots> = 0"
           using b3 r1 subsetD by force
         finally show ?thesis by simp
       qed
       thus ?thesis
         by (simp add: \<open>\<And>v. \<langle>v, x\<rangle> = 0\<close> cinner_extensionality)
     qed
     ultimately show ?thesis by simp
   qed
   thus ?thesis
     using basisA_def cblinfun_eq_0_on_canonical_basis by auto
 qed
 
 lemma cinner_canonical_basis_eq:
   defines "basisA == set (canonical_basis::'a::onb_enum list)"
     and   "basisB == set (canonical_basis::'b::onb_enum list)"
   assumes "\<And>u v. u\<in>basisA \<Longrightarrow> v\<in>basisB \<Longrightarrow> \<langle>v, F *\<^sub>V u\<rangle> = \<langle>v, G *\<^sub>V u\<rangle>"
   shows "F = G"
 proof-
   define H where "H = F - G"
   have "\<And>u v. u\<in>basisA \<Longrightarrow> v\<in>basisB \<Longrightarrow> \<langle>v, H *\<^sub>V u\<rangle> = 0"
     unfolding H_def
     by (simp add: assms(3) cinner_diff_right minus_cblinfun.rep_eq)
   hence "H = 0"
     by (simp add: basisA_def basisB_def cinner_canonical_basis_eq_0)
   thus ?thesis unfolding H_def by simp
 qed
 
 lemma cinner_canonical_basis_eq':
   defines "basisA == set (canonical_basis::'a::onb_enum list)"
     and   "basisB == set (canonical_basis::'b::onb_enum list)"
   assumes "\<And>u v. u\<in>basisA \<Longrightarrow> v\<in>basisB \<Longrightarrow> \<langle>F *\<^sub>V u, v\<rangle> = \<langle>G *\<^sub>V u, v\<rangle>"
   shows "F = G"
   using cinner_canonical_basis_eq assms
   by (metis cinner_commute')
 
 lemma cblinfun_norm_approx_witness:
   fixes A :: \<open>'a::{not_singleton,complex_normed_vector} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector\<close>
   assumes \<open>\<epsilon> > 0\<close>
   shows \<open>\<exists>\<psi>. norm (A *\<^sub>V \<psi>) \<ge> norm A - \<epsilon> \<and> norm \<psi> = 1\<close>
 proof (transfer fixing: \<epsilon>)
   fix A :: \<open>'a \<Rightarrow> 'b\<close> assume [simp]: \<open>bounded_clinear A\<close>
   have \<open>\<exists>y\<in>{norm (A x) |x. norm x = 1}. y > \<Squnion> {norm (A x) |x. norm x = 1} - \<epsilon>\<close>
     apply (rule Sup_real_close)
     using assms by (auto simp: ex_norm1 bounded_clinear.bounded_linear bdd_above_norm_f)
   also have \<open>\<Squnion> {norm (A x) |x. norm x = 1} = onorm A\<close>
     by (simp add: bounded_clinear.bounded_linear onorm_sphere)
   finally
   show \<open>\<exists>\<psi>. onorm A - \<epsilon> \<le> norm (A \<psi>) \<and> norm \<psi> = 1\<close>
     by force
 qed
 
 lemma cblinfun_norm_approx_witness_mult:
   fixes A :: \<open>'a::{not_singleton,complex_normed_vector} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector\<close>
   assumes \<open>\<epsilon> < 1\<close>
   shows \<open>\<exists>\<psi>. norm (A *\<^sub>V \<psi>) \<ge> norm A * \<epsilon> \<and> norm \<psi> = 1\<close>
 proof (cases \<open>norm A = 0\<close>)
   case True
   then show ?thesis
     apply auto
     by (simp add: ex_norm1)
 next
   case False
   then have \<open>(1 - \<epsilon>) * norm A > 0\<close>
     using assms by fastforce
   then obtain \<psi> where geq: \<open>norm (A *\<^sub>V \<psi>) \<ge> norm A - ((1 - \<epsilon>) * norm A)\<close> and \<open>norm \<psi> = 1\<close>
     using cblinfun_norm_approx_witness by blast
   have \<open>norm A * \<epsilon> = norm A - (1 - \<epsilon>) * norm A\<close>
     by (simp add: mult.commute right_diff_distrib')
   also have \<open>\<dots> \<le> norm (A *\<^sub>V \<psi>)\<close>
     by (rule geq)
   finally show ?thesis
     using \<open>norm \<psi> = 1\<close> by auto
 qed
 
 
 lemma cblinfun_to_CARD_1_0[simp]: \<open>(A :: _ \<Rightarrow>\<^sub>C\<^sub>L _::CARD_1) = 0\<close>
   apply (rule cblinfun_eqI)
   by auto
 
 lemma cblinfun_from_CARD_1_0[simp]: \<open>(A :: _::CARD_1 \<Rightarrow>\<^sub>C\<^sub>L _) = 0\<close>
   apply (rule cblinfun_eqI)
   apply (subst CARD_1_vec_0)
   by auto
 
 
 lemma cblinfun_cspan_UNIV:
   fixes basis :: \<open>('a::{complex_normed_vector,cfinite_dim} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector) set\<close>
     and basisA :: \<open>'a set\<close> and basisB :: \<open>'b set\<close>
   assumes \<open>cspan basisA = UNIV\<close> and \<open>cspan basisB = UNIV\<close>
   assumes basis: \<open>\<And>a b. a\<in>basisA \<Longrightarrow> b\<in>basisB \<Longrightarrow> \<exists>F\<in>basis. \<forall>a'\<in>basisA. F *\<^sub>V a' = (if a'=a then b else 0)\<close>
   shows \<open>cspan basis = UNIV\<close>
 proof -
   obtain basisA' where \<open>basisA' \<subseteq> basisA\<close> and \<open>cindependent basisA'\<close> and \<open>cspan basisA' = UNIV\<close>
     by (metis assms(1) complex_vector.maximal_independent_subset complex_vector.span_eq top_greatest)
   then have [simp]: \<open>finite basisA'\<close>
     by (simp add: cindependent_cfinite_dim_finite)
   have basis': \<open>\<And>a b. a\<in>basisA' \<Longrightarrow> b\<in>basisB \<Longrightarrow> \<exists>F\<in>basis. \<forall>a'\<in>basisA'. F *\<^sub>V a' = (if a'=a then b else 0)\<close>
     using basis \<open>basisA' \<subseteq> basisA\<close> by fastforce
 
   obtain F where F: \<open>F a b \<in> basis \<and> F a b *\<^sub>V a' = (if a'=a then b else 0)\<close>
     if \<open>a\<in>basisA'\<close> \<open>b\<in>basisB\<close> \<open>a'\<in>basisA'\<close> for a b a'
     apply atomize_elim apply (intro choice allI)
     using basis' by metis
   then have F_apply: \<open>F a b *\<^sub>V a' = (if a'=a then b else 0)\<close>
     if \<open>a\<in>basisA'\<close> \<open>b\<in>basisB\<close> \<open>a'\<in>basisA'\<close> for a b a'
     using that by auto
   have F_basis: \<open>F a b \<in> basis\<close>
     if \<open>a\<in>basisA'\<close> \<open>b\<in>basisB\<close> for a b
     using that F by auto
   have b_span: \<open>\<exists>G\<in>cspan {F a b|b. b\<in>basisB}. \<forall>a'\<in>basisA'. G *\<^sub>V a' = (if a'=a then b else 0)\<close> if \<open>a\<in>basisA'\<close> for a b
   proof -
     from \<open>cspan basisB = UNIV\<close>
     obtain r t where \<open>finite t\<close> and \<open>t \<subseteq> basisB\<close> and b_lincom: \<open>b = (\<Sum>a\<in>t. r a *\<^sub>C a)\<close>
       unfolding complex_vector.span_alt apply atomize_elim by blast
     define G where \<open>G = (\<Sum>i\<in>t. r i *\<^sub>C F a i)\<close>
     have \<open>G \<in> cspan {F a b|b. b\<in>basisB}\<close>
       using \<open>finite t\<close> \<open>t \<subseteq> basisB\<close> unfolding G_def
       by (smt (verit, ccfv_threshold) complex_vector.span_base complex_vector.span_scale complex_vector.span_sum mem_Collect_eq subset_eq)
     moreover have \<open>G *\<^sub>V a' = (if a'=a then b else 0)\<close> if \<open>a'\<in>basisA'\<close> for a'
       apply (cases \<open>a'=a\<close>)
       using \<open>t \<subseteq> basisB\<close> \<open>a\<in>basisA'\<close> \<open>a'\<in>basisA'\<close>
       by (auto simp: b_lincom G_def cblinfun.sum_left F_apply intro!: sum.neutral sum.cong)
     ultimately show ?thesis
       by blast
   qed
 
   have a_span: \<open>cspan (\<Union>a\<in>basisA'. cspan {F a b|b. b\<in>basisB}) = UNIV\<close>
   proof (intro equalityI subset_UNIV subsetI, rename_tac H)
     fix H
     obtain G where G: \<open>G a b \<in> cspan {F a b|b. b\<in>basisB} \<and> G a b *\<^sub>V a' = (if a'=a then b else 0)\<close> if \<open>a\<in>basisA'\<close> and \<open>a'\<in>basisA'\<close> for a b a'
       apply atomize_elim apply (intro choice allI)
       using b_span by blast
     then have G_cspan: \<open>G a b \<in> cspan {F a b|b. b\<in>basisB}\<close> if \<open>a\<in>basisA'\<close> for a b
       using that by auto
     from G have G: \<open>G a b *\<^sub>V a' = (if a'=a then b else 0)\<close> if \<open>a\<in>basisA'\<close> and \<open>a'\<in>basisA'\<close> for a b a'
       using that by auto
     define H' where \<open>H' = (\<Sum>a\<in>basisA'. G a (H *\<^sub>V a))\<close>
     have \<open>H' \<in> cspan (\<Union>a\<in>basisA'. cspan {F a b|b. b\<in>basisB})\<close>
       unfolding H'_def using G_cspan
       by (smt (verit, del_insts) UN_iff complex_vector.span_clauses(1) complex_vector.span_sum)
     moreover have \<open>H' = H\<close>
       using \<open>cspan basisA' = UNIV\<close> apply (rule cblinfun_eq_on_UNIV_span)
       apply (auto simp: H'_def cblinfun.sum_left)
       apply (subst sum_single)
       by (auto simp: G)
     ultimately show \<open>H \<in> cspan (\<Union>a\<in>basisA'. cspan {F a b |b. b \<in> basisB})\<close>
       by simp
   qed
 
   moreover have \<open>cspan basis \<supseteq> cspan (\<Union>a\<in>basisA'. cspan {F a b|b. b\<in>basisB})\<close>
     using F_basis
     by (smt (z3) UN_subset_iff complex_vector.span_alt complex_vector.span_minimal complex_vector.subspace_span mem_Collect_eq subset_iff)
 
   ultimately show \<open>cspan basis = UNIV\<close>
     by auto
 qed
 
 
 instance cblinfun :: (\<open>{cfinite_dim,complex_normed_vector}\<close>, \<open>{cfinite_dim,complex_normed_vector}\<close>) cfinite_dim
 proof intro_classes
   obtain basisA :: \<open>'a set\<close> where [simp]: \<open>cspan basisA = UNIV\<close> \<open>cindependent basisA\<close> \<open>finite basisA\<close>
     using finite_basis by blast
   obtain basisB :: \<open>'b set\<close> where [simp]: \<open>cspan basisB = UNIV\<close> \<open>cindependent basisB\<close> \<open>finite basisB\<close>
     using finite_basis by blast
   define f where \<open>f a b = cconstruct basisA (\<lambda>x. if x=a then b else 0)\<close> for a :: 'a and b :: 'b
   have f_a: \<open>f a b a = b\<close> if \<open>a : basisA\<close> for a b
     by (simp add: complex_vector.construct_basis f_def that)
   have f_not_a: \<open>f a b c = 0\<close> if \<open>a : basisA\<close> and \<open>c : basisA\<close> and \<open>a \<noteq> c\<close>for a b c
     using that by (simp add: complex_vector.construct_basis f_def)
   define F where \<open>F a b = CBlinfun (f a b)\<close> for a b
   have \<open>clinear (f a b)\<close> for a b
     by (auto intro: complex_vector.linear_construct simp: f_def)
   then have \<open>bounded_clinear (f a b)\<close> for a b
     by auto
   then have F_apply: \<open>cblinfun_apply (F a b) = f a b\<close> for a b
     by (simp add: F_def bounded_clinear_CBlinfun_apply)
   define basis where \<open>basis = {F a b| a b. a\<in>basisA \<and> b\<in>basisB}\<close>
   have \<open>cspan basis = UNIV\<close>
     apply (rule cblinfun_cspan_UNIV[where basisA=basisA and basisB=basisB])
       apply (auto simp: basis_def)
     by (metis F_apply f_a f_not_a)
 
   moreover have \<open>finite basis\<close>
     unfolding basis_def apply (rule finite_image_set2) by auto
 
   ultimately show \<open>\<exists>S :: ('a \<Rightarrow>\<^sub>C\<^sub>L 'b) set. finite S \<and> cspan S = UNIV\<close>
     by auto
 qed
 
 lemma norm_cblinfun_bound_dense:
   assumes \<open>0 \<le> b\<close>
   assumes S: \<open>closure S = UNIV\<close>
   assumes bound: \<open>\<And>x. x\<in>S \<Longrightarrow> norm (cblinfun_apply f x) \<le> b * norm x\<close>
   shows \<open>norm f \<le> b\<close>
 proof -
   have 1: \<open>continuous_on UNIV (\<lambda>a. norm (f *\<^sub>V a))\<close>
     apply (intro continuous_on_norm linear_continuous_on)
     by (simp add: Complex_Vector_Spaces.bounded_clinear.bounded_linear cblinfun.bounded_clinear_right)
   have 2: \<open>continuous_on UNIV (\<lambda>a. b * norm a)\<close>
     using continuous_on_mult_left continuous_on_norm_id by blast
   have \<open>norm (cblinfun_apply f x) \<le> b * norm x\<close> for x
     apply (rule on_closure_leI[where x=x and S=S])
     using S bound 1 2 by auto
   then show \<open>norm f \<le> b\<close>
     apply (rule_tac norm_cblinfun_bound)
     using \<open>0 \<le> b\<close> by auto
 qed
 
 lemma dense_span_separating: \<open>closure (cspan S) = UNIV \<Longrightarrow> bounded_clinear F \<Longrightarrow> bounded_clinear G \<Longrightarrow> (\<forall>x\<in>S. F x = G x) \<Longrightarrow> F = G\<close>
 proof -
   fix F G :: \<open>'a \<Rightarrow> 'b\<close>
   assume dense: \<open>closure (cspan S) = UNIV\<close>
   assume [simp]: \<open>bounded_clinear F\<close> \<open>bounded_clinear G\<close>
   assume \<open>\<forall>x\<in>S. F x = G x\<close>
   then have \<open>F x = G x\<close> if \<open>x \<in> cspan S\<close> for x
     apply (rule_tac complex_vector.linear_eq_on[of F G _ S])
     using that by (auto simp: bounded_clinear.clinear)
   then show \<open>F = G\<close>
     apply (rule_tac ext)
     apply (rule on_closure_eqI[of \<open>cspan S\<close> F G])
     using dense by (auto intro!: continuous_at_imp_continuous_on clinear_continuous_at)
 qed
 
 
 lemma infsum_cblinfun_apply:
   assumes \<open>g summable_on S\<close>
   shows \<open>infsum (\<lambda>x. A *\<^sub>V g x) S = A *\<^sub>V (infsum g S)\<close>
   apply (rule infsum_bounded_linear[unfolded o_def, of \<open>cblinfun_apply A\<close>])
   using assms 
   by (auto simp add: bounded_clinear.bounded_linear bounded_cbilinear.bounded_clinear_right
       bounded_cbilinear_cblinfun_apply)
 
 lemma has_sum_cblinfun_apply:
   assumes \<open>has_sum g S x\<close>
   shows \<open>has_sum (\<lambda>x. A *\<^sub>V g x) S (A *\<^sub>V x)\<close>
   apply (rule has_sum_bounded_linear[unfolded o_def, of \<open>cblinfun_apply A\<close>])
   using assms by (auto simp add: bounded_clinear.bounded_linear cblinfun.bounded_clinear_right)
 
 lemma abs_summable_on_cblinfun_apply:
   assumes \<open>g abs_summable_on S\<close>
   shows \<open>(\<lambda>x. A *\<^sub>V g x) abs_summable_on S\<close>
   using bounded_clinear.bounded_linear[OF cblinfun.bounded_clinear_right] assms
   by (rule abs_summable_on_bounded_linear[unfolded o_def])
 
 text \<open>The next eight lemmas logically belong in \<^theory>\<open>Complex_Bounded_Operators.Complex_Inner_Product\<close> 
   but the proofs use facts from this theory.\<close>
 lemma has_sum_cinner_left:
   assumes \<open>has_sum f I x\<close>
   shows \<open>has_sum (\<lambda>i. cinner a (f i)) I (cinner a x)\<close>
   by (metis assms cblinfun_cinner_right.rep_eq has_sum_cblinfun_apply)
 
 lemma summable_on_cinner_left:
   assumes \<open>f summable_on I\<close>
   shows \<open>(\<lambda>i. cinner a (f i)) summable_on I\<close>
   by (metis assms has_sum_cinner_left summable_on_def)
 
 lemma infsum_cinner_left:
   assumes \<open>\<phi> summable_on I\<close>
   shows \<open>cinner \<psi> (\<Sum>\<^sub>\<infinity>i\<in>I. \<phi> i) = (\<Sum>\<^sub>\<infinity>i\<in>I. cinner \<psi> (\<phi> i))\<close>
   by (metis assms has_sum_cinner_left has_sum_infsum infsumI)
 
 lemma has_sum_cinner_right:
   assumes \<open>has_sum f I x\<close>
   shows \<open>has_sum (\<lambda>i. f i \<bullet>\<^sub>C a) I (x \<bullet>\<^sub>C a)\<close>
   apply (rule has_sum_bounded_linear[where f=\<open>\<lambda>x. x \<bullet>\<^sub>C a\<close>, unfolded o_def])
   using assms by (simp_all add: bounded_antilinear.bounded_linear bounded_antilinear_cinner_left)
 
 lemma summable_on_cinner_right:
   assumes \<open>f summable_on I\<close>
   shows \<open>(\<lambda>i. f i \<bullet>\<^sub>C a) summable_on I\<close>
   by (metis assms has_sum_cinner_right summable_on_def)
 
 lemma infsum_cinner_right:
   assumes \<open>\<phi> summable_on I\<close>
   shows \<open>(\<Sum>\<^sub>\<infinity>i\<in>I. \<phi> i) \<bullet>\<^sub>C \<psi> = (\<Sum>\<^sub>\<infinity>i\<in>I. \<phi> i \<bullet>\<^sub>C \<psi>)\<close>
   by (metis assms has_sum_cinner_right has_sum_infsum infsumI)
 
 lemma Cauchy_cinner_product_summable:
   assumes asum: \<open>a summable_on UNIV\<close>
   assumes bsum: \<open>b summable_on UNIV\<close>
   assumes \<open>finite X\<close> \<open>finite Y\<close>
   assumes pos: \<open>\<And>x y. x \<notin> X \<Longrightarrow> y \<notin> Y \<Longrightarrow> cinner (a x) (b y) \<ge> 0\<close>
   shows absum: \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on UNIV\<close>
 proof -
   have \<open>(\<Sum>(x,y)\<in>F. norm (cinner (a x) (b y))) \<le> norm (cinner (infsum a (-X)) (infsum b (-Y))) + norm (infsum a (-X)) + norm (infsum b (-Y)) + 1\<close> 
     if \<open>finite F\<close> and \<open>F \<subseteq> (-X)\<times>(-Y)\<close> for F
   proof -
     from asum \<open>finite X\<close>
     have \<open>a summable_on (-X)\<close>
       by (simp add: Compl_eq_Diff_UNIV summable_on_cofin_subset)
     then obtain MA where \<open>finite MA\<close> and \<open>MA \<subseteq> -X\<close>
       and MA: \<open>G \<supseteq> MA \<Longrightarrow> G \<subseteq> -X \<Longrightarrow> finite G \<Longrightarrow> norm (sum a G - infsum a (-X)) \<le> 1\<close> for G
       apply (simp add: summable_iff_has_sum_infsum has_sum_metric dist_norm)
       by (meson less_eq_real_def zero_less_one)
     
     from bsum \<open>finite Y\<close>
     have \<open>b summable_on (-Y)\<close>
       by (simp add: Compl_eq_Diff_UNIV summable_on_cofin_subset)
     then obtain MB where \<open>finite MB\<close> and \<open>MB \<subseteq> -Y\<close>
       and MB: \<open>G \<supseteq> MB \<Longrightarrow> G \<subseteq> -Y \<Longrightarrow> finite G \<Longrightarrow> norm (sum b G - infsum b (-Y)) \<le> 1\<close> for G
       apply (simp add: summable_iff_has_sum_infsum has_sum_metric dist_norm)
       by (meson less_eq_real_def zero_less_one)
 
     define F1 F2 where \<open>F1 = fst ` F \<union> MA\<close> and \<open>F2 = snd ` F \<union> MB\<close>
     define t1 t2 where \<open>t1 = sum a F1 - infsum a (-X)\<close> and \<open>t2 = sum b F2 - infsum b (-Y)\<close>
   
     have [simp]: \<open>finite F1\<close> \<open>finite F2\<close>
       using F1_def F2_def \<open>finite MA\<close> \<open>finite MB\<close> that by auto
     have [simp]: \<open>F1 \<subseteq> -X\<close> \<open>F2 \<subseteq> -Y\<close>
       using \<open>F \<subseteq> (-X)\<times>(-Y)\<close> \<open>MA \<subseteq> -X\<close> \<open>MB \<subseteq> -Y\<close>
       by (auto simp: F1_def F2_def)
     from MA[OF _ \<open>F1 \<subseteq> -X\<close> \<open>finite F1\<close>] have \<open>norm t1 \<le> 1\<close> 
       by (auto simp: t1_def F1_def)
     from MB[OF _ \<open>F2 \<subseteq> -Y\<close> \<open>finite F2\<close>] have \<open>norm t2 \<le> 1\<close> 
       by (auto simp: t2_def F2_def)
     have [simp]: \<open>F \<subseteq> F1 \<times> F2\<close>
       apply (auto simp: F1_def F2_def image_def)
       by force+
     have \<open>(\<Sum>(x,y)\<in>F. norm (cinner (a x) (b y))) \<le> (\<Sum>(x,y)\<in>F1\<times>F2. norm (cinner (a x) (b y)))\<close>
       apply (rule sum_mono2)
       by auto
     also from pos have \<open>\<dots> = norm (\<Sum>(x,y)\<in>F1\<times>F2. cinner (a x) (b y))\<close>
       apply (auto intro!: of_real_eq_iff[THEN iffD1] simp: case_prod_beta)
       apply (subst abs_complex_def[unfolded o_def, symmetric, THEN fun_cong])+
       apply (subst (2) abs_pos)
        apply (rule sum_nonneg)
        apply (metis Compl_eq_Diff_UNIV Diff_iff SigmaE \<open>F1 \<subseteq> - X\<close> \<open>F2 \<subseteq> - Y\<close> fst_conv prod.sel(2) subsetD)
       apply (rule sum.cong)
       apply simp
       by (metis Compl_iff SigmaE \<open>F1 \<subseteq> - X\<close> \<open>F2 \<subseteq> - Y\<close> abs_pos fst_conv prod.sel(2) subset_eq)
     also have \<open>\<dots> = norm (cinner (sum a F1) (sum b F2))\<close>
       by (simp add: sum.cartesian_product sum_cinner)
     also have \<open>\<dots> = norm (cinner (infsum a (-X) + t1) (infsum b (-Y) + t2))\<close>
       by (simp add: t1_def t2_def)
     also have \<open>\<dots> \<le> norm (cinner (infsum a (-X)) (infsum b (-Y))) + norm (infsum a (-X)) * norm t2 + norm t1 * norm (infsum b (-Y)) + norm t1 * norm t2\<close>
       apply (simp add: cinner_add_right cinner_add_left)
       by (smt (verit, del_insts) complex_inner_class.Cauchy_Schwarz_ineq2 norm_triangle_ineq)
     also from \<open>norm t1 \<le> 1\<close> \<open>norm t2 \<le> 1\<close>
     have \<open>\<dots> \<le> norm (cinner (infsum a (-X)) (infsum b (-Y))) + norm (infsum a (-X)) + norm (infsum b (-Y)) + 1\<close>
       by (auto intro!: add_mono mult_left_le mult_left_le_one_le mult_le_one)
     finally show ?thesis
       by -
   qed
 
   then have \<open>(\<lambda>(x, y). cinner (a x) (b y)) abs_summable_on (-X)\<times>(-Y)\<close>
     apply (rule_tac nonneg_bdd_above_summable_on)
     by (auto intro!: bdd_aboveI2 simp: case_prod_unfold)
   then have 1: \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on (-X)\<times>(-Y)\<close>
     using abs_summable_summable by blast
 
   from bsum
   have \<open>(\<lambda>y. b y) summable_on (-Y)\<close>
     by (simp add: Compl_eq_Diff_UNIV assms(4) summable_on_cofin_subset)
   then have \<open>(\<lambda>y. cinner (a x) (b y)) summable_on (-Y)\<close> for x
     using summable_on_cinner_left by blast
   with \<open>finite X\<close> have 2: \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on X\<times>(-Y)\<close>
     apply (rule_tac summable_on_product_finite_left)
     by auto
 
   from asum
   have \<open>(\<lambda>x. a x) summable_on (-X)\<close>
     by (simp add: Compl_eq_Diff_UNIV assms(3) summable_on_cofin_subset)
   then have \<open>(\<lambda>x. cinner (a x) (b y)) summable_on (-X)\<close> for y
     using summable_on_cinner_right by blast
   with \<open>finite Y\<close> have 3: \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on (-X)\<times>Y\<close>
     apply (rule_tac summable_on_product_finite_right)
     by auto
 
   have 4: \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on X\<times>Y\<close>
     by (simp add: \<open>finite X\<close> \<open>finite Y\<close>)
 
   show ?thesis
     apply (subst asm_rl[of \<open>UNIV = (-X)\<times>(-Y) \<union> X\<times>(-Y) \<union> (-X)\<times>Y \<union> X\<times>Y\<close>])
     using 1 2 3 4 by (auto intro!: summable_on_Un_disjoint)
 qed
 
 
 text \<open>A variant of @{thm [source] Series.Cauchy_product_sums} with \<^term>\<open>(*)\<close> replaced by \<^term>\<open>cinner\<close>.
    Differently from @{thm [source] Series.Cauchy_product_sums}, we do not require absolute summability
    of \<^term>\<open>a\<close> and \<^term>\<open>b\<close> individually but only unconditional summability of \<^term>\<open>a\<close>, \<^term>\<open>b\<close>, and their product.
    While on, e.g., reals, unconditional summability is equivalent to absolute summability, in
    general unconditional summability is a weaker requirement.\<close>
 lemma 
   fixes a b :: "nat \<Rightarrow> 'a::complex_inner"
   assumes asum: \<open>a summable_on UNIV\<close>
   assumes bsum: \<open>b summable_on UNIV\<close>
   assumes absum: \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on UNIV\<close>
     (* \<comment> \<open>See @{thm [source] Cauchy_cinner_product_summable} or @{thm [source] Cauchy_cinner_product_summable'} for a way to rewrite this premise.\<close> *)
   shows Cauchy_cinner_product_infsum: \<open>(\<Sum>\<^sub>\<infinity>k. \<Sum>i\<le>k. cinner (a i) (b (k - i))) = cinner (\<Sum>\<^sub>\<infinity>k. a k) (\<Sum>\<^sub>\<infinity>k. b k)\<close>
     and Cauchy_cinner_product_infsum_exists: \<open>(\<lambda>k. \<Sum>i\<le>k. cinner (a i) (b (k - i))) summable_on UNIV\<close>
 proof -
   have img: \<open>(\<lambda>(k::nat, i). (i, k - i)) ` {(k, i). i \<le> k} = UNIV\<close>
     apply (auto simp: image_def)
     by (metis add.commute add_diff_cancel_right' diff_le_self)
   have inj: \<open>inj_on (\<lambda>(k::nat, i). (i, k - i)) {(k, i). i \<le> k}\<close>
     by (smt (verit, del_insts) Pair_inject case_prodE case_prod_conv eq_diff_iff inj_onI mem_Collect_eq)
   have sigma: \<open>(SIGMA k:UNIV. {i. i \<le> k}) = {(k, i). i \<le> k}\<close>
     by auto
 
   from absum
   have \<open>(\<lambda>(x, y). cinner (a y) (b (x - y))) summable_on {(k, i). i \<le> k}\<close>
     by (rule Cauchy_cinner_product_summable'[THEN iffD1])
   then have \<open>(\<lambda>k. \<Sum>\<^sub>\<infinity>i|i\<le>k. cinner (a i) (b (k-i))) summable_on UNIV\<close>
     by (metis (mono_tags, lifting) sigma summable_on_Sigma_banach summable_on_cong)
   then show \<open>(\<lambda>k. \<Sum>i\<le>k. cinner (a i) (b (k - i))) summable_on UNIV\<close>
     by (metis (mono_tags, lifting) atMost_def finite_Collect_le_nat infsum_finite summable_on_cong)
 
   have \<open>cinner (\<Sum>\<^sub>\<infinity>k. a k) (\<Sum>\<^sub>\<infinity>k. b k) = (\<Sum>\<^sub>\<infinity>k. \<Sum>\<^sub>\<infinity>l. cinner (a k) (b l))\<close>
     apply (subst infsum_cinner_right)
      apply (rule asum)
     apply (subst infsum_cinner_left)
      apply (rule bsum)
     by simp
   also have \<open>\<dots> = (\<Sum>\<^sub>\<infinity>(k,l). cinner (a k) (b l))\<close>
     apply (subst infsum_Sigma'_banach)
     using absum by auto
   also have \<open>\<dots> = (\<Sum>\<^sub>\<infinity>(k, l)\<in>(\<lambda>(k, i). (i, k - i)) ` {(k, i). i \<le> k}. cinner (a k) (b l))\<close>
     by (simp only: img)
   also have \<open>\<dots> = infsum ((\<lambda>(k, l). a k \<bullet>\<^sub>C b l) \<circ> (\<lambda>(k, i). (i, k - i))) {(k, i). i \<le> k}\<close>
     using inj by (rule infsum_reindex)
   also have \<open>\<dots> = (\<Sum>\<^sub>\<infinity>(k,i)|i\<le>k. a i \<bullet>\<^sub>C b (k-i))\<close>
     by (simp add: o_def case_prod_unfold)
   also have \<open>\<dots> = (\<Sum>\<^sub>\<infinity>k. \<Sum>\<^sub>\<infinity>i|i\<le>k. a i \<bullet>\<^sub>C b (k-i))\<close>
     apply (subst infsum_Sigma'_banach)
     using absum by (auto simp: sigma Cauchy_cinner_product_summable')
   also have \<open>\<dots> = (\<Sum>\<^sub>\<infinity>k. \<Sum>i\<le>k. a i \<bullet>\<^sub>C b (k-i))\<close>
     apply (subst infsum_finite[symmetric])
     by (auto simp add: atMost_def)
   finally show \<open>(\<Sum>\<^sub>\<infinity>k. \<Sum>i\<le>k. a i \<bullet>\<^sub>C b (k - i)) = (\<Sum>\<^sub>\<infinity>k. a k) \<bullet>\<^sub>C (\<Sum>\<^sub>\<infinity>k. b k)\<close>
     by simp
 qed
 
 
 lemma CBlinfun_plus: 
   assumes [simp]: \<open>bounded_clinear f\<close> \<open>bounded_clinear g\<close>
   shows \<open>CBlinfun (f + g) = CBlinfun f + CBlinfun g\<close>
   by (auto intro!: cblinfun_eqI simp: plus_fun_def bounded_clinear_add CBlinfun_inverse cblinfun.add_left)
 
 lemma CBlinfun_scaleC:
   assumes \<open>bounded_clinear f\<close>
   shows \<open>CBlinfun (\<lambda>y. c *\<^sub>C f y) = c *\<^sub>C CBlinfun f\<close>
   by (simp add: assms eq_onp_same_args scaleC_cblinfun.abs_eq)
 
 
 lemma bounded_clinear_inv:
   assumes [simp]: \<open>bounded_clinear f\<close>
   assumes b: \<open>b > 0\<close>
   assumes bound: \<open>\<And>x. norm (f x) \<ge> b * norm x\<close>
   assumes \<open>surj f\<close>
   shows \<open>bounded_clinear (inv f)\<close>
 proof (rule bounded_clinear_intro)
   fix x y :: 'b and r :: complex
   define x' y' where \<open>x' = inv f x\<close> and \<open>y' = inv f y\<close>
   have [simp]: \<open>clinear f\<close>
     by (simp add: bounded_clinear.clinear)
   have [simp]: \<open>inj f\<close>
   proof (rule injI)
     fix x y assume \<open>f x = f y\<close>
     then have \<open>norm (f (x - y)) = 0\<close>
       by (simp add: complex_vector.linear_diff)
     with bound b have \<open>norm (x - y) = 0\<close>
       by (metis linorder_not_le mult_le_0_iff nle_le norm_ge_zero)
     then show \<open>x = y\<close>
       by simp
   qed
 
   from \<open>surj f\<close>
   have [simp]: \<open>x = f x'\<close> \<open>y = f y'\<close>
     by (simp_all add: surj_f_inv_f x'_def y'_def)
   show "inv f (x + y) = inv f x + inv f y"
     by (simp flip: complex_vector.linear_add)
   show "inv f (r *\<^sub>C x) = r *\<^sub>C inv f x"
     by (simp flip: clinear.scaleC)
   from bound have "b * norm (inv f x) \<le> norm x" 
     by (simp flip: clinear.scaleC)
   with b show "norm (inv f x) \<le> norm x * inverse b" 
     by (smt (verit, ccfv_threshold) left_inverse mult.commute mult_cancel_right1 mult_le_cancel_left_pos vector_space_over_itself.scale_scale)
 qed
 
+lemma cinner_sup_norm_cblinfun:
+  fixes A :: \<open>'a::{complex_normed_vector,not_singleton} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner\<close>
+  shows \<open>norm A = (SUP (\<psi>,\<phi>). cmod (cinner \<psi> (A *\<^sub>V \<phi>)) / (norm \<psi> * norm \<phi>))\<close>
+  apply transfer
+  apply (rule cinner_sup_onorm)
+  by (simp add: bounded_clinear.bounded_linear)
+
+
+lemma norm_cblinfun_Sup: \<open>norm A = (SUP \<psi>. norm (A *\<^sub>V \<psi>) / norm \<psi>)\<close>
+  by (simp add: norm_cblinfun.rep_eq onorm_def)
 
 subsection \<open>Relationship to real bounded operators (\<^typ>\<open>_ \<Rightarrow>\<^sub>L _\<close>)\<close>
 
 instantiation blinfun :: (real_normed_vector, complex_normed_vector) "complex_normed_vector"
 begin
 lift_definition scaleC_blinfun :: \<open>complex \<Rightarrow>
  ('a::real_normed_vector, 'b::complex_normed_vector) blinfun \<Rightarrow>
  ('a, 'b) blinfun\<close>
   is \<open>\<lambda> c::complex. \<lambda> f::'a\<Rightarrow>'b. (\<lambda> x. c *\<^sub>C (f x) )\<close>
 proof
   fix c::complex and f :: \<open>'a\<Rightarrow>'b\<close> and b1::'a and b2::'a
   assume \<open>bounded_linear f\<close>
   show \<open>c *\<^sub>C f (b1 + b2) = c *\<^sub>C f b1 + c *\<^sub>C f b2\<close>
     by (simp add: \<open>bounded_linear f\<close> linear_simps scaleC_add_right)
 
   fix c::complex and f :: \<open>'a\<Rightarrow>'b\<close> and b::'a and r::real
   assume \<open>bounded_linear f\<close>
   show \<open>c *\<^sub>C f (r *\<^sub>R b) = r *\<^sub>R (c *\<^sub>C f b)\<close>
     by (simp add: \<open>bounded_linear f\<close> linear_simps(5) scaleR_scaleC)
 
   fix c::complex and f :: \<open>'a\<Rightarrow>'b\<close>
   assume \<open>bounded_linear f\<close>
 
   have \<open>\<exists> K. \<forall> x. norm (f x) \<le> norm x * K\<close>
     using \<open>bounded_linear f\<close>
     by (simp add: bounded_linear.bounded)
   then obtain K where \<open>\<forall> x. norm (f x) \<le> norm x * K\<close>
     by blast
   have \<open>cmod c \<ge> 0\<close>
     by simp
   hence \<open>\<forall> x. (cmod c) * norm (f x) \<le> (cmod c) * norm x * K\<close>
     using  \<open>\<forall> x. norm (f x) \<le> norm x * K\<close>
     by (metis ordered_comm_semiring_class.comm_mult_left_mono vector_space_over_itself.scale_scale)
   moreover have \<open>norm (c *\<^sub>C f x) = (cmod c) * norm (f x)\<close>
     for x
     by simp
   ultimately show \<open>\<exists>K. \<forall>x. norm (c *\<^sub>C f x) \<le> norm x * K\<close>
     by (metis ab_semigroup_mult_class.mult_ac(1) mult.commute)
 qed
 
 instance
 proof
   have "r *\<^sub>R x = complex_of_real r *\<^sub>C x"
     for x :: "('a, 'b) blinfun" and r
     apply transfer
     by (simp add: scaleR_scaleC)
   thus "((*\<^sub>R) r::'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> _) = (*\<^sub>C) (complex_of_real r)" for r
     by auto
   show "a *\<^sub>C (x + y) = a *\<^sub>C x + a *\<^sub>C y"
     for a :: complex and x y :: "'a \<Rightarrow>\<^sub>L 'b"
     apply transfer
     by (simp add: scaleC_add_right)
 
   show "(a + b) *\<^sub>C x = a *\<^sub>C x + b *\<^sub>C x"
     for a b :: complex and x :: "'a \<Rightarrow>\<^sub>L 'b"
     apply transfer
     by (simp add: scaleC_add_left)
 
   show "a *\<^sub>C b *\<^sub>C x = (a * b) *\<^sub>C x"
     for a b :: complex and x :: "'a \<Rightarrow>\<^sub>L 'b"
     apply transfer
     by simp
 
   have \<open>1 *\<^sub>C f x = f x\<close>
     for f :: \<open>'a\<Rightarrow>'b\<close> and x
     by auto
   thus "1 *\<^sub>C x = x"
     for x :: "'a \<Rightarrow>\<^sub>L 'b"
     by (simp add: scaleC_blinfun.rep_eq blinfun_eqI)
 
   have \<open>onorm (\<lambda>x. a *\<^sub>C f x) = cmod a * onorm f\<close>
     if \<open>bounded_linear f\<close>
     for f :: \<open>'a \<Rightarrow> 'b\<close> and a :: complex
   proof-
     have \<open>cmod a \<ge> 0\<close>
       by simp
     have \<open>\<exists> K::real. \<forall> x. (\<bar> ereal ((norm (f x)) / (norm x)) \<bar>) \<le> K\<close>
       using \<open>bounded_linear f\<close> le_onorm by fastforce
     then obtain K::real where \<open>\<forall> x. (\<bar> ereal ((norm (f x)) / (norm x)) \<bar>) \<le> K\<close>
       by blast
     hence  \<open>\<forall> x. (cmod a) *(\<bar> ereal ((norm (f x)) / (norm x)) \<bar>) \<le> (cmod a) * K\<close>
       using \<open>cmod a \<ge> 0\<close>
       by (metis abs_ereal.simps(1) abs_ereal_pos   abs_pos ereal_mult_left_mono  times_ereal.simps(1))
     hence  \<open>\<forall> x.  (\<bar> ereal ((cmod a) * (norm (f x)) / (norm x)) \<bar>) \<le> (cmod a) * K\<close>
       by simp
     hence \<open>bdd_above {ereal (cmod a * (norm (f x)) / (norm x)) | x. True}\<close>
       by simp
     moreover have \<open>{ereal (cmod a * (norm (f x)) / (norm x)) | x. True} \<noteq> {}\<close>
       by auto
     ultimately have p1: \<open>(SUP x. \<bar>ereal (cmod a * (norm (f x)) / (norm x))\<bar>) \<le> cmod a * K\<close>
       using \<open>\<forall> x. \<bar> ereal (cmod a * (norm (f x)) / (norm x)) \<bar> \<le> cmod a * K\<close>
         Sup_least mem_Collect_eq
       by (simp add: SUP_le_iff)
     have  p2: \<open>\<And>i. i \<in> UNIV \<Longrightarrow> 0 \<le> ereal (cmod a * norm (f i) / norm i)\<close>
       by simp
     hence \<open>\<bar>SUP x. ereal (cmod a * (norm (f x)) / (norm x))\<bar>
               \<le> (SUP x. \<bar>ereal (cmod a * (norm (f x)) / (norm x))\<bar>)\<close>
       using  \<open>bdd_above {ereal (cmod a * (norm (f x)) / (norm x)) | x. True}\<close>
         \<open>{ereal (cmod a * (norm (f x)) / (norm x)) | x. True} \<noteq> {}\<close>
       by (metis (mono_tags, lifting) SUP_upper2 Sup.SUP_cong UNIV_I
           p2 abs_ereal_ge0 ereal_le_real)
     hence \<open>\<bar>SUP x. ereal (cmod a * (norm (f x)) / (norm x))\<bar> \<le> cmod a * K\<close>
       using  \<open>(SUP x. \<bar>ereal (cmod a * (norm (f x)) / (norm x))\<bar>) \<le> cmod a * K\<close>
       by simp
     hence \<open>\<bar> ( SUP i\<in>UNIV::'a set. ereal ((\<lambda> x. (cmod a) * (norm (f x)) / norm x) i)) \<bar> \<noteq> \<infinity>\<close>
       by auto
     hence w2: \<open>( SUP i\<in>UNIV::'a set. ereal ((\<lambda> x. cmod a * (norm (f x)) / norm x) i))
              = ereal ( Sup ((\<lambda> x. cmod a * (norm (f x)) / norm x) ` (UNIV::'a set) ))\<close>
       by (simp add: ereal_SUP)
     have \<open>(UNIV::('a set)) \<noteq> {}\<close>
       by simp
     moreover have \<open>\<And> i. i \<in> (UNIV::('a set)) \<Longrightarrow> (\<lambda> x. (norm (f x)) / norm x :: ereal) i \<ge> 0\<close>
       by simp
     moreover have \<open>cmod a \<ge> 0\<close>
       by simp
     ultimately have \<open>(SUP i\<in>(UNIV::('a set)). ((cmod a)::ereal) * (\<lambda> x. (norm (f x)) / norm x :: ereal) i )
         = ((cmod a)::ereal) * ( SUP i\<in>(UNIV::('a set)). (\<lambda> x. (norm (f x)) / norm x :: ereal) i )\<close>
       by (simp add: Sup_ereal_mult_left')
     hence \<open>(SUP x. ((cmod a)::ereal) * ( (norm (f x)) / norm x :: ereal) )
         = ((cmod a)::ereal) * ( SUP x. ( (norm (f x)) / norm x :: ereal) )\<close>
       by simp
     hence z1: \<open>real_of_ereal ( (SUP x. ((cmod a)::ereal) * ( (norm (f x)) / norm x :: ereal) ) )
         = real_of_ereal ( ((cmod a)::ereal) * ( SUP x. ( (norm (f x)) / norm x :: ereal) ) )\<close>
       by simp
     have z2: \<open>real_of_ereal (SUP x. ((cmod a)::ereal) * ( (norm (f x)) / norm x :: ereal) )
                   = (SUP x. cmod a * (norm (f x) / norm x))\<close>
       using w2
       by auto
     have \<open>real_of_ereal ( ((cmod a)::ereal) * ( SUP x. ( (norm (f x)) / norm x :: ereal) ) )
                 =  (cmod a) * real_of_ereal ( SUP x. ( (norm (f x)) / norm x :: ereal) )\<close>
       by simp
     moreover have \<open>real_of_ereal ( SUP x. ( (norm (f x)) / norm x :: ereal) )
                   = ( SUP x. ((norm (f x)) / norm x) )\<close>
     proof-
       have \<open>\<bar> ( SUP i\<in>UNIV::'a set. ereal ((\<lambda> x. (norm (f x)) / norm x) i)) \<bar> \<noteq> \<infinity>\<close>
       proof-
         have \<open>\<exists> K::real. \<forall> x. (\<bar> ereal ((norm (f x)) / (norm x)) \<bar>) \<le> K\<close>
           using \<open>bounded_linear f\<close> le_onorm by fastforce
         then obtain K::real where \<open>\<forall> x. (\<bar> ereal ((norm (f x)) / (norm x)) \<bar>) \<le> K\<close>
           by blast
         hence \<open>bdd_above {ereal ((norm (f x)) / (norm x)) | x. True}\<close>
           by simp
         moreover have \<open>{ereal ((norm (f x)) / (norm x)) | x. True} \<noteq> {}\<close>
           by auto
         ultimately have \<open>(SUP x. \<bar>ereal ((norm (f x)) / (norm x))\<bar>) \<le> K\<close>
           using \<open>\<forall> x. \<bar> ereal ((norm (f x)) / (norm x)) \<bar> \<le> K\<close>
             Sup_least mem_Collect_eq
           by (simp add: SUP_le_iff)
         hence \<open>\<bar>SUP x. ereal ((norm (f x)) / (norm x))\<bar>
               \<le> (SUP x. \<bar>ereal ((norm (f x)) / (norm x))\<bar>)\<close>
           using  \<open>bdd_above {ereal ((norm (f x)) / (norm x)) | x. True}\<close>
             \<open>{ereal ((norm (f x)) / (norm x)) | x. True} \<noteq> {}\<close>
           by (metis (mono_tags, lifting) SUP_upper2 Sup.SUP_cong UNIV_I \<open>\<And>i. i \<in> UNIV \<Longrightarrow> 0 \<le> ereal (norm (f i) / norm i)\<close> abs_ereal_ge0 ereal_le_real)
         hence \<open>\<bar>SUP x. ereal ((norm (f x)) / (norm x))\<bar> \<le> K\<close>
           using  \<open>(SUP x. \<bar>ereal ((norm (f x)) / (norm x))\<bar>) \<le> K\<close>
           by simp
         thus ?thesis
           by auto
       qed
       hence \<open> ( SUP i\<in>UNIV::'a set. ereal ((\<lambda> x. (norm (f x)) / norm x) i))
              = ereal ( Sup ((\<lambda> x. (norm (f x)) / norm x) ` (UNIV::'a set) ))\<close>
         by (simp add: ereal_SUP)
       thus ?thesis
         by simp
     qed
     have z3: \<open>real_of_ereal ( ((cmod a)::ereal) * ( SUP x. ( (norm (f x)) / norm x :: ereal) ) )
                 = cmod a * (SUP x. norm (f x) / norm x)\<close>
       by (simp add: \<open>real_of_ereal (SUP x. ereal (norm (f x) / norm x)) = (SUP x. norm (f x) / norm x)\<close>)
     hence w1: \<open>(SUP x. cmod a * (norm (f x) / norm x)) =
           cmod a * (SUP x. norm (f x) / norm x)\<close>
       using z1 z2 by linarith
     have v1: \<open>onorm (\<lambda>x. a *\<^sub>C f x) = (SUP x. norm (a *\<^sub>C f x) / norm x)\<close>
       by (simp add: onorm_def)
     have v2: \<open>(SUP x. norm (a *\<^sub>C f x) / norm x) = (SUP x. ((cmod a) * norm (f x)) / norm x)\<close>
       by simp
     have v3: \<open>(SUP x. ((cmod a) * norm (f x)) / norm x) =  (SUP x. (cmod a) * ((norm (f x)) / norm x))\<close>
       by simp
     have v4: \<open>(SUP x. (cmod a) * ((norm (f x)) / norm x)) = (cmod a) *  (SUP x. ((norm (f x)) / norm x))\<close>
       using w1
       by blast
     show \<open>onorm (\<lambda>x. a *\<^sub>C f x) = cmod a * onorm f\<close>
       using v1 v2 v3 v4
       by (metis (mono_tags, lifting) onorm_def)
   qed
   thus \<open>norm (a *\<^sub>C x) = cmod a * norm x\<close>
     for a::complex and x::\<open>('a, 'b) blinfun\<close>
     apply transfer
     by blast
 qed
 end
 
 (* We do not have clinear_blinfun_compose_right *)
 lemma clinear_blinfun_compose_left: \<open>clinear (\<lambda>x. blinfun_compose x y)\<close>
   by (auto intro!: clinearI simp: blinfun_eqI scaleC_blinfun.rep_eq bounded_bilinear.add_left
                                   bounded_bilinear_blinfun_compose)
 
 instantiation blinfun :: (real_normed_vector, cbanach) "cbanach"
 begin
 instance..
 end
 
 lemma blinfun_compose_assoc: "(A o\<^sub>L B) o\<^sub>L C = A o\<^sub>L (B  o\<^sub>L C)"
   by (simp add: blinfun_eqI)
 
 lift_definition blinfun_of_cblinfun::\<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector
   \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b\<close> is "id"
   apply transfer by (simp add: bounded_clinear.bounded_linear)
 
 lift_definition blinfun_cblinfun_eq ::
   \<open>'a \<Rightarrow>\<^sub>L 'b \<Rightarrow> 'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector \<Rightarrow> bool\<close> is "(=)" .
 
 lemma blinfun_cblinfun_eq_bi_unique[transfer_rule]: \<open>bi_unique blinfun_cblinfun_eq\<close>
   unfolding bi_unique_def apply transfer by auto
 
 lemma blinfun_cblinfun_eq_right_total[transfer_rule]: \<open>right_total blinfun_cblinfun_eq\<close>
   unfolding right_total_def apply transfer
   by (simp add: bounded_clinear.bounded_linear)
 
 named_theorems cblinfun_blinfun_transfer
 
 lemma cblinfun_blinfun_transfer_0[cblinfun_blinfun_transfer]:
   "blinfun_cblinfun_eq (0::(_,_) blinfun) (0::(_,_) cblinfun)"
   apply transfer by simp
 
 lemma cblinfun_blinfun_transfer_plus[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> blinfun_cblinfun_eq ===> blinfun_cblinfun_eq) (+) (+)"
   unfolding rel_fun_def apply transfer by auto
 
 lemma cblinfun_blinfun_transfer_minus[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> blinfun_cblinfun_eq ===> blinfun_cblinfun_eq) (-) (-)"
   unfolding rel_fun_def apply transfer by auto
 
 lemma cblinfun_blinfun_transfer_uminus[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> blinfun_cblinfun_eq) (uminus) (uminus)"
   unfolding rel_fun_def apply transfer by auto
 
 definition "real_complex_eq r c \<longleftrightarrow> complex_of_real r = c"
 
 lemma bi_unique_real_complex_eq[transfer_rule]: \<open>bi_unique real_complex_eq\<close>
   unfolding real_complex_eq_def bi_unique_def by auto
 
 lemma left_total_real_complex_eq[transfer_rule]: \<open>left_total real_complex_eq\<close>
   unfolding real_complex_eq_def left_total_def by auto
 
 lemma cblinfun_blinfun_transfer_scaleC[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(real_complex_eq ===> blinfun_cblinfun_eq ===> blinfun_cblinfun_eq) (scaleR) (scaleC)"
   unfolding rel_fun_def apply transfer
   by (simp add: real_complex_eq_def scaleR_scaleC)
 
 lemma cblinfun_blinfun_transfer_CBlinfun[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(eq_onp bounded_clinear ===> blinfun_cblinfun_eq) Blinfun CBlinfun"
   unfolding rel_fun_def blinfun_cblinfun_eq.rep_eq eq_onp_def
   by (auto simp: CBlinfun_inverse Blinfun_inverse bounded_clinear.bounded_linear)
 
 lemma cblinfun_blinfun_transfer_norm[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> (=)) norm norm"
   unfolding rel_fun_def apply transfer by auto
 
 lemma cblinfun_blinfun_transfer_dist[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> blinfun_cblinfun_eq ===> (=)) dist dist"
   unfolding rel_fun_def dist_norm apply transfer by auto
 
 lemma cblinfun_blinfun_transfer_sgn[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> blinfun_cblinfun_eq) sgn sgn"
   unfolding rel_fun_def sgn_blinfun_def sgn_cblinfun_def apply transfer
   by (auto simp: scaleR_scaleC)
 
 lemma cblinfun_blinfun_transfer_Cauchy[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(((=) ===> blinfun_cblinfun_eq) ===> (=)) Cauchy Cauchy"
 proof -
   note cblinfun_blinfun_transfer[transfer_rule]
   show ?thesis
     unfolding Cauchy_def
     by transfer_prover
 qed
 
 lemma cblinfun_blinfun_transfer_tendsto[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(((=) ===> blinfun_cblinfun_eq) ===> blinfun_cblinfun_eq ===> (=) ===> (=)) tendsto tendsto"
 proof -
   note cblinfun_blinfun_transfer[transfer_rule]
   show ?thesis
     unfolding tendsto_iff
     by transfer_prover
 qed
 
 lemma cblinfun_blinfun_transfer_compose[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> blinfun_cblinfun_eq ===> blinfun_cblinfun_eq) (o\<^sub>L) (o\<^sub>C\<^sub>L)"
   unfolding rel_fun_def apply transfer by auto
 
 lemma cblinfun_blinfun_transfer_apply[cblinfun_blinfun_transfer]:
   includes lifting_syntax
   shows "(blinfun_cblinfun_eq ===> (=) ===> (=)) blinfun_apply cblinfun_apply"
   unfolding rel_fun_def apply transfer by auto
 
 lemma blinfun_of_cblinfun_inj:
   \<open>blinfun_of_cblinfun f = blinfun_of_cblinfun g \<Longrightarrow> f = g\<close>
   by (metis cblinfun_apply_inject blinfun_of_cblinfun.rep_eq)
 
 lemma blinfun_of_cblinfun_inv:
   assumes "\<And>c. \<And>x. f *\<^sub>v (c *\<^sub>C x) = c *\<^sub>C (f *\<^sub>v x)"
   shows "\<exists>g. blinfun_of_cblinfun g = f"
   using assms
 proof transfer
   show "\<exists>g\<in>Collect bounded_clinear. id g = f"
     if "bounded_linear f"
       and "\<And>c x. f (c *\<^sub>C x) = c *\<^sub>C f x"
     for f :: "'a \<Rightarrow> 'b"
     using that bounded_linear_bounded_clinear by auto
 qed
 
 lemma blinfun_of_cblinfun_zero:
   \<open>blinfun_of_cblinfun 0 = 0\<close>
   apply transfer by simp
 
 lemma blinfun_of_cblinfun_uminus:
   \<open>blinfun_of_cblinfun (- f) = - (blinfun_of_cblinfun f)\<close>
   apply transfer
   by auto
 
 lemma blinfun_of_cblinfun_minus:
   \<open>blinfun_of_cblinfun (f - g) = blinfun_of_cblinfun f - blinfun_of_cblinfun g\<close>
   apply transfer
   by auto
 
 lemma blinfun_of_cblinfun_scaleC:
   \<open>blinfun_of_cblinfun (c *\<^sub>C f) = c *\<^sub>C (blinfun_of_cblinfun f)\<close>
   apply transfer
   by auto
 
 lemma blinfun_of_cblinfun_scaleR:
   \<open>blinfun_of_cblinfun (c *\<^sub>R f) = c *\<^sub>R (blinfun_of_cblinfun f)\<close>
   apply transfer by auto
 
 lemma blinfun_of_cblinfun_norm:
   fixes f::\<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector\<close>
   shows \<open>norm f = norm (blinfun_of_cblinfun f)\<close>
   apply transfer by auto
 
 subsection \<open>Composition\<close>
 
 lemma blinfun_of_cblinfun_cblinfun_compose:
   fixes f::\<open>'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_normed_vector\<close>
     and g::\<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b\<close>
   shows \<open>blinfun_of_cblinfun (f  o\<^sub>C\<^sub>L g) = (blinfun_of_cblinfun f) o\<^sub>L (blinfun_of_cblinfun g)\<close>
   apply transfer by auto
 
 lemma cblinfun_compose_assoc:
   shows "(A o\<^sub>C\<^sub>L B) o\<^sub>C\<^sub>L C = A o\<^sub>C\<^sub>L (B o\<^sub>C\<^sub>L C)"
   by (metis (no_types, lifting) cblinfun_apply_inject fun.map_comp cblinfun_compose.rep_eq)
 
 lemma cblinfun_compose_zero_right[simp]: "U o\<^sub>C\<^sub>L 0 = 0"
   using bounded_cbilinear.zero_right bounded_cbilinear_cblinfun_compose by blast
 
 lemma cblinfun_compose_zero_left[simp]: "0 o\<^sub>C\<^sub>L U = 0"
   using bounded_cbilinear.zero_left bounded_cbilinear_cblinfun_compose by blast
 
 lemma cblinfun_compose_scaleC_left[simp]:
   fixes A::"'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_normed_vector"
     and B::"'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b"
   shows \<open>(a *\<^sub>C A) o\<^sub>C\<^sub>L B = a *\<^sub>C (A o\<^sub>C\<^sub>L B)\<close>
   by (simp add: bounded_cbilinear.scaleC_left bounded_cbilinear_cblinfun_compose)
 
 lemma cblinfun_compose_scaleR_left[simp]:
   fixes A::"'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_normed_vector"
     and B::"'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b"
   shows \<open>(a *\<^sub>R A) o\<^sub>C\<^sub>L B = a *\<^sub>R (A o\<^sub>C\<^sub>L B)\<close>
   by (simp add: scaleR_scaleC)
 
 lemma cblinfun_compose_scaleC_right[simp]:
   fixes A::"'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_normed_vector"
     and B::"'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b"
   shows \<open>A o\<^sub>C\<^sub>L (a *\<^sub>C B) = a *\<^sub>C (A o\<^sub>C\<^sub>L B)\<close>
   apply transfer by (auto intro!: ext bounded_clinear.clinear complex_vector.linear_scale)
 
 lemma cblinfun_compose_scaleR_right[simp]:
   fixes A::"'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_normed_vector"
     and B::"'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b"
   shows \<open>A o\<^sub>C\<^sub>L (a *\<^sub>R B) = a *\<^sub>R (A o\<^sub>C\<^sub>L B)\<close>
   by (simp add: scaleR_scaleC)
 
 lemma cblinfun_compose_id_right[simp]:
   shows "U o\<^sub>C\<^sub>L id_cblinfun = U"
   apply transfer by auto
 
 lemma cblinfun_compose_id_left[simp]:
   shows "id_cblinfun o\<^sub>C\<^sub>L U  = U"
   apply transfer by auto
 
 lemma cblinfun_eq_on:
   fixes A B :: "'a::cbanach \<Rightarrow>\<^sub>C\<^sub>L'b::complex_normed_vector"
   assumes "\<And>x. x \<in> G \<Longrightarrow> A *\<^sub>V x = B *\<^sub>V x" and \<open>t \<in> closure (cspan G)\<close>
   shows "A *\<^sub>V t = B *\<^sub>V t"
   using assms
   apply transfer
   using bounded_clinear_eq_on by blast
 
 lemma cblinfun_eq_gen_eqI:
   fixes A B :: "'a::cbanach \<Rightarrow>\<^sub>C\<^sub>L'b::complex_normed_vector"
   assumes "\<And>x. x \<in> G \<Longrightarrow> A *\<^sub>V x = B *\<^sub>V x" and \<open>ccspan G = \<top>\<close>
   shows "A = B"
   apply (rule cblinfun_eqI)
   apply (rule cblinfun_eq_on[where G=G])
   using assms apply auto
   by (metis ccspan.rep_eq iso_tuple_UNIV_I top_ccsubspace.rep_eq)
 
 lemma cblinfun_compose_add_left: \<open>(a + b) o\<^sub>C\<^sub>L c = (a o\<^sub>C\<^sub>L c) + (b o\<^sub>C\<^sub>L c)\<close>
   by (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose)
 
 lemma cblinfun_compose_add_right: \<open>a o\<^sub>C\<^sub>L (b + c) = (a o\<^sub>C\<^sub>L b) + (a o\<^sub>C\<^sub>L c)\<close>
   by (simp add: bounded_cbilinear.add_right bounded_cbilinear_cblinfun_compose)
 
 lemma cbilinear_cblinfun_compose[simp]: "cbilinear cblinfun_compose"
   by (auto intro!: clinearI simp add: cbilinear_def bounded_cbilinear.add_left bounded_cbilinear.add_right bounded_cbilinear_cblinfun_compose)
 
 lemma cblinfun_compose_sum_left: \<open>(\<Sum>i\<in>S. g i) o\<^sub>C\<^sub>L x = (\<Sum>i\<in>S. g i o\<^sub>C\<^sub>L x)\<close>
   apply (induction S rule:infinite_finite_induct)
   by (auto simp: cblinfun_compose_add_left)
 
 lemma cblinfun_compose_sum_right: \<open>x o\<^sub>C\<^sub>L (\<Sum>i\<in>S. g i) = (\<Sum>i\<in>S. x o\<^sub>C\<^sub>L g i)\<close>
   apply (induction S rule:infinite_finite_induct)
   by (auto simp: cblinfun_compose_add_right)
 
 lemma cblinfun_compose_minus_right: \<open>a o\<^sub>C\<^sub>L (b - c) = (a o\<^sub>C\<^sub>L b) - (a o\<^sub>C\<^sub>L c)\<close>
   by (simp add: bounded_cbilinear.diff_right bounded_cbilinear_cblinfun_compose)
 lemma cblinfun_compose_minus_left: \<open>(a - b) o\<^sub>C\<^sub>L c = (a o\<^sub>C\<^sub>L c) - (b o\<^sub>C\<^sub>L c)\<close>
   by (simp add: bounded_cbilinear.diff_left bounded_cbilinear_cblinfun_compose)
 
 
 lemma simp_a_oCL_b: \<open>a o\<^sub>C\<^sub>L b = c \<Longrightarrow> a o\<^sub>C\<^sub>L (b o\<^sub>C\<^sub>L d) = c o\<^sub>C\<^sub>L d\<close>
   \<comment> \<open>A convenience lemma to transform simplification rules of the form \<^term>\<open>a o\<^sub>C\<^sub>L b = c\<close>.
      E.g., \<open>simp_a_oCL_b[OF isometryD, simp]\<close> declares a simp-rule for simplifying \<^term>\<open>adj x o\<^sub>C\<^sub>L (x o\<^sub>C\<^sub>L y) = id_cblinfun o\<^sub>C\<^sub>L y\<close>.\<close>
   by (auto simp: cblinfun_compose_assoc)
 
 lemma simp_a_oCL_b': \<open>a o\<^sub>C\<^sub>L b = c \<Longrightarrow> a *\<^sub>V (b *\<^sub>V d) = c *\<^sub>V d\<close>
   \<comment> \<open>A convenience lemma to transform simplification rules of the form \<^term>\<open>a o\<^sub>C\<^sub>L b = c\<close>.
      E.g., \<open>simp_a_oCL_b'[OF isometryD, simp]\<close> declares a simp-rule for simplifying \<^term>\<open>adj x *\<^sub>V x *\<^sub>V y = id_cblinfun *\<^sub>V y\<close>.\<close>
   by auto
 
 lemma cblinfun_compose_uminus_left: \<open>(- a) o\<^sub>C\<^sub>L b = - (a o\<^sub>C\<^sub>L b)\<close>
   by (simp add: bounded_cbilinear.minus_left bounded_cbilinear_cblinfun_compose)
 
 lemma cblinfun_compose_uminus_right: \<open>a o\<^sub>C\<^sub>L (- b) = - (a o\<^sub>C\<^sub>L b)\<close>
   by (simp add: bounded_cbilinear.minus_right bounded_cbilinear_cblinfun_compose)
 
 subsection \<open>Adjoint\<close>
 
 lift_definition
   adj :: "'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner \<Rightarrow> 'b \<Rightarrow>\<^sub>C\<^sub>L 'a" ("_*" [99] 100)
   is cadjoint by (fact cadjoint_bounded_clinear)
 
 lemma id_cblinfun_adjoint[simp]: "id_cblinfun* = id_cblinfun"
   apply transfer using cadjoint_id
   by (metis eq_id_iff)
 
 lemma double_adj[simp]: "(A*)* = A"
   apply transfer using double_cadjoint by blast
 
 lemma adj_cblinfun_compose[simp]:
   fixes B::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space\<close>
     and A::\<open>'b \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_inner\<close>
   shows "(A o\<^sub>C\<^sub>L B)* =  (B*) o\<^sub>C\<^sub>L (A*)"
 proof transfer
   fix  A :: \<open>'b \<Rightarrow> 'c\<close> and B :: \<open>'a \<Rightarrow> 'b\<close>
   assume \<open>bounded_clinear A\<close> and \<open>bounded_clinear B\<close>
   hence \<open>bounded_clinear (A \<circ> B)\<close>
     by (simp add: comp_bounded_clinear)
   have \<open>\<langle> (A \<circ> B) u, v \<rangle> = \<langle> u, (B\<^sup>\<dagger> \<circ> A\<^sup>\<dagger>) v \<rangle>\<close>
     for u v
     by (metis (no_types, lifting) cadjoint_univ_prop \<open>bounded_clinear A\<close> \<open>bounded_clinear B\<close> cinner_commute' comp_def)
   thus \<open>(A \<circ> B)\<^sup>\<dagger> = B\<^sup>\<dagger> \<circ> A\<^sup>\<dagger>\<close>
     using \<open>bounded_clinear (A \<circ> B)\<close>
     by (metis cadjoint_eqI cinner_commute')
 qed
 
 lemma scaleC_adj[simp]: "(a *\<^sub>C A)* = (cnj a) *\<^sub>C (A*)"
   apply transfer
   by (simp add: bounded_clinear.bounded_linear bounded_clinear_def complex_vector.linear_scale scaleC_cadjoint)
 
 lemma scaleR_adj[simp]: "(a *\<^sub>R A)* = a *\<^sub>R (A*)"
   by (simp add: scaleR_scaleC)
 
 lemma adj_plus: \<open>(A + B)* = (A*) + (B*)\<close>
 proof transfer
   fix A B::\<open>'b \<Rightarrow> 'a\<close>
   assume a1: \<open>bounded_clinear A\<close> and a2: \<open>bounded_clinear B\<close>
   define F where \<open>F = (\<lambda>x. (A\<^sup>\<dagger>) x + (B\<^sup>\<dagger>) x)\<close>
   define G where \<open>G = (\<lambda>x. A x + B x)\<close>
   have \<open>bounded_clinear G\<close>
     unfolding G_def
     by (simp add: a1 a2 bounded_clinear_add)
   moreover have \<open>\<langle>F u,  v\<rangle> = \<langle>u, G v\<rangle>\<close> for u v
     unfolding F_def G_def
     using cadjoint_univ_prop a1 a2 cinner_add_left
     by (simp add: cadjoint_univ_prop cinner_add_left cinner_add_right)
   ultimately have \<open>F = G\<^sup>\<dagger> \<close>
     using cadjoint_eqI by blast
   thus \<open>(\<lambda>x. A x + B x)\<^sup>\<dagger> = (\<lambda>x. (A\<^sup>\<dagger>) x + (B\<^sup>\<dagger>) x)\<close>
     unfolding F_def G_def
     by auto
 qed
 
-lemma cinner_sup_norm_cblinfun:
-  fixes A :: \<open>'a::{complex_normed_vector,not_singleton} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner\<close>
-  shows \<open>norm A = (SUP (\<psi>,\<phi>). cmod (cinner \<psi> (A *\<^sub>V \<phi>)) / (norm \<psi> * norm \<phi>))\<close>
-  apply transfer
-  apply (rule cinner_sup_onorm)
-  by (simp add: bounded_clinear.bounded_linear)
-
 lemma cinner_adj_left:
   fixes G :: "'b::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'a::complex_inner"
   shows \<open>\<langle>G* *\<^sub>V x, y\<rangle> = \<langle>x, G *\<^sub>V y\<rangle>\<close>
   apply transfer using cadjoint_univ_prop by blast
 
 lemma cinner_adj_right:
   fixes G :: "'b::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'a::complex_inner"
   shows \<open>\<langle>x, G* *\<^sub>V y\<rangle> = \<langle>G *\<^sub>V x, y\<rangle>\<close>
   apply transfer using cadjoint_univ_prop' by blast
 
 lemma adj_0[simp]: \<open>0* = 0\<close>
   by (metis add_cancel_right_left adj_plus)
 
 lemma norm_adj[simp]: \<open>norm (A*) = norm A\<close>
   for A :: \<open>'b::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'c::complex_inner\<close>
 proof (cases \<open>(\<exists>x y :: 'b. x \<noteq> y) \<and> (\<exists>x y :: 'c. x \<noteq> y)\<close>)
   case True
   then have c1: \<open>class.not_singleton TYPE('b)\<close>
     apply intro_classes by simp
   from True have c2: \<open>class.not_singleton TYPE('c)\<close>
     apply intro_classes by simp
   have normA: \<open>norm A = (SUP (\<psi>, \<phi>). cmod (\<psi> \<bullet>\<^sub>C (A *\<^sub>V \<phi>)) / (norm \<psi> * norm \<phi>))\<close>
     apply (rule cinner_sup_norm_cblinfun[internalize_sort \<open>'a::{complex_normed_vector,not_singleton}\<close>])
      apply (rule complex_normed_vector_axioms)
     by (rule c1)
   have normAadj: \<open>norm (A*) = (SUP (\<psi>, \<phi>). cmod (\<psi> \<bullet>\<^sub>C (A* *\<^sub>V \<phi>)) / (norm \<psi> * norm \<phi>))\<close>
     apply (rule cinner_sup_norm_cblinfun[internalize_sort \<open>'a::{complex_normed_vector,not_singleton}\<close>])
      apply (rule complex_normed_vector_axioms)
     by (rule c2)
 
   have \<open>norm (A*) = (SUP (\<psi>, \<phi>). cmod (\<phi> \<bullet>\<^sub>C (A *\<^sub>V \<psi>)) / (norm \<psi> * norm \<phi>))\<close>
     unfolding normAadj
     apply (subst cinner_adj_right)
     apply (subst cinner_commute)
     apply (subst complex_mod_cnj)
     by rule
   also have \<open>\<dots> = Sup ((\<lambda>(\<psi>, \<phi>). cmod (\<phi> \<bullet>\<^sub>C (A *\<^sub>V \<psi>)) / (norm \<psi> * norm \<phi>)) ` prod.swap ` UNIV)\<close>
     by auto
   also have \<open>\<dots> = (SUP (\<phi>, \<psi>). cmod (\<phi> \<bullet>\<^sub>C (A *\<^sub>V \<psi>)) / (norm \<psi> * norm \<phi>))\<close>
     apply (subst image_image)
     by auto
   also have \<open>\<dots> = norm A\<close>
     unfolding normA
     by (simp add: mult.commute)
   finally show ?thesis
     by -
 next
   case False
   then consider (b) \<open>\<And>x::'b. x = 0\<close> | (c) \<open>\<And>x::'c. x = 0\<close>
     by auto
   then have \<open>A = 0\<close>
     apply (cases; transfer)
      apply (metis (full_types) bounded_clinear_def complex_vector.linear_0)
     by auto
   then show \<open>norm (A*) = norm A\<close>
     by simp
 qed
 
 
 lemma antilinear_adj[simp]: \<open>antilinear adj\<close>
   apply (rule antilinearI) by (auto simp add: adj_plus)
 
 lemma bounded_antilinear_adj[bounded_antilinear, simp]: \<open>bounded_antilinear adj\<close>
   by (auto intro!: antilinearI exI[of _ 1] simp: bounded_antilinear_def bounded_antilinear_axioms_def adj_plus)
 
 lemma adjoint_eqI:
   fixes G:: \<open>'b::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'a::complex_inner\<close>
     and F:: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L 'b\<close>
   assumes \<open>\<And>x y. \<langle>(cblinfun_apply F) x, y\<rangle> = \<langle>x, (cblinfun_apply G) y\<rangle>\<close>
   shows \<open>F = G*\<close>
   using assms apply transfer using cadjoint_eqI by auto
 
 lemma adj_uminus: \<open>(-A)* = - (A*)\<close>
   apply (rule adjoint_eqI[symmetric])
   by (simp add: cblinfun.minus_left cinner_adj_left)
 
 lemma cinner_real_hermiteanI:
   \<comment> \<open>Prop. II.2.12 in @{cite conway2013course}\<close>
   assumes \<open>\<And>\<psi>. cinner \<psi> (A *\<^sub>V \<psi>) \<in> \<real>\<close>
   shows \<open>A = A*\<close>
 proof -
   { fix g h :: 'a
     {
       fix \<alpha> :: complex
       have \<open>cinner h (A h) + cnj \<alpha> *\<^sub>C cinner g (A h) + \<alpha> *\<^sub>C cinner h (A g) + (abs \<alpha>)\<^sup>2 * cinner g (A g)
         = cinner (h + \<alpha> *\<^sub>C g) (A *\<^sub>V (h + \<alpha> *\<^sub>C g))\<close> (is \<open>?sum4 = _\<close>)
         apply (auto simp: cinner_add_right cinner_add_left cblinfun.add_right cblinfun.scaleC_right ring_class.ring_distribs)
         by (metis cnj_x_x mult.commute)
       also have \<open>\<dots> \<in> \<real>\<close>
         using assms by auto
       finally have \<open>?sum4 = cnj ?sum4\<close>
         using Reals_cnj_iff by fastforce
       then have \<open>cnj \<alpha> *\<^sub>C cinner g (A h) + \<alpha> *\<^sub>C cinner h (A g)
             = \<alpha> *\<^sub>C cinner (A h) g + cnj \<alpha> *\<^sub>C cinner (A g) h\<close>
         using Reals_cnj_iff abs_complex_real assms by force
       also have \<open>\<dots> = \<alpha> *\<^sub>C cinner h (A* *\<^sub>V g) + cnj \<alpha> *\<^sub>C cinner g (A* *\<^sub>V h)\<close>
         by (simp add: cinner_adj_right)
       finally have \<open>cnj \<alpha> *\<^sub>C cinner g (A h) + \<alpha> *\<^sub>C cinner h (A g) = \<alpha> *\<^sub>C cinner h (A* *\<^sub>V g) + cnj \<alpha> *\<^sub>C cinner g (A* *\<^sub>V h)\<close>
         by -
     }
     from this[where \<alpha>2=1] this[where \<alpha>2=\<i>]
     have 1: \<open>cinner g (A h) + cinner h (A g) = cinner h (A* *\<^sub>V g) + cinner g (A* *\<^sub>V h)\<close>
       and i: \<open>- \<i> * cinner g (A h) + \<i> *\<^sub>C cinner h (A g) =  \<i> *\<^sub>C cinner h (A* *\<^sub>V g) - \<i> *\<^sub>C cinner g (A* *\<^sub>V h)\<close>
       by auto
     from arg_cong2[OF 1 arg_cong[OF i, where f=\<open>(*) (-\<i>)\<close>], where f=plus]
     have \<open>cinner h (A g) = cinner h (A* *\<^sub>V g)\<close>
       by (auto simp: ring_class.ring_distribs)
   }
   then show "A = A*"
     by (simp add: adjoint_eqI cinner_adj_right)
 qed
 
 
 lemma norm_AAadj[simp]: \<open>norm (A o\<^sub>C\<^sub>L A*) = (norm A)\<^sup>2\<close> for A :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::{complex_inner}\<close>
 proof (cases \<open>class.not_singleton TYPE('b)\<close>)
   case True
   then have [simp]: \<open>class.not_singleton TYPE('b)\<close>
     by -
   have 1: \<open>(norm A)\<^sup>2 * \<epsilon> \<le> norm (A o\<^sub>C\<^sub>L A*)\<close> if \<open>\<epsilon> < 1\<close> and \<open>\<epsilon> \<ge> 0\<close> for \<epsilon>
   proof -
     obtain \<psi> where \<psi>: \<open>norm ((A*) *\<^sub>V \<psi>) \<ge> norm (A*) * sqrt \<epsilon>\<close> and [simp]: \<open>norm \<psi> = 1\<close>
       apply atomize_elim
       apply (rule cblinfun_norm_approx_witness_mult[internalize_sort' 'a])
       using \<open>\<epsilon> < 1\<close> by (auto intro: complex_normed_vector_class.complex_normed_vector_axioms)
     have \<open>complex_of_real ((norm A)\<^sup>2 * \<epsilon>) = (norm (A*) * sqrt \<epsilon>)\<^sup>2\<close>
       by (simp add: ordered_field_class.sign_simps(23) that(2))
     also have \<open>\<dots> \<le> (norm ((A* *\<^sub>V \<psi>)))\<^sup>2\<close>
       apply (rule complex_of_real_mono)
       using \<psi> apply (rule power_mono)
       using \<open>\<epsilon> \<ge> 0\<close> by auto
     also have \<open>\<dots> \<le> cinner (A* *\<^sub>V \<psi>) (A* *\<^sub>V \<psi>)\<close>
       by (auto simp flip: power2_norm_eq_cinner)
     also have \<open>\<dots> = cinner \<psi> (A *\<^sub>V A* *\<^sub>V \<psi>)\<close>
       by (simp add: cinner_adj_left)
     also have \<open>\<dots> = cinner \<psi> ((A o\<^sub>C\<^sub>L A*) *\<^sub>V \<psi>)\<close>
       by auto
     also have \<open>\<dots> \<le> norm (A o\<^sub>C\<^sub>L A*)\<close>
       using \<open>norm \<psi> = 1\<close>
       by (smt (verit, best) Im_complex_of_real Re_complex_of_real \<open>(A* *\<^sub>V \<psi>) \<bullet>\<^sub>C (A* *\<^sub>V \<psi>) = \<psi> \<bullet>\<^sub>C (A *\<^sub>V A* *\<^sub>V \<psi>)\<close> \<open>\<psi> \<bullet>\<^sub>C (A *\<^sub>V A* *\<^sub>V \<psi>) = \<psi> \<bullet>\<^sub>C ((A o\<^sub>C\<^sub>L A*) *\<^sub>V \<psi>)\<close> cdot_square_norm cinner_ge_zero cmod_Re complex_inner_class.Cauchy_Schwarz_ineq2 less_eq_complex_def mult_cancel_left1 mult_cancel_right1 norm_cblinfun)
     finally show ?thesis
       by (auto simp: less_eq_complex_def)
   qed
   then have 1: \<open>(norm A)\<^sup>2 \<le> norm (A o\<^sub>C\<^sub>L A*)\<close>
     by (metis field_le_mult_one_interval less_eq_real_def ordered_field_class.sign_simps(5))
 
   have 2: \<open>norm (A o\<^sub>C\<^sub>L A*) \<le> (norm A)\<^sup>2\<close>
   proof (rule norm_cblinfun_bound)
     show \<open>0 \<le> (norm A)\<^sup>2\<close> by simp
     fix \<psi>
     have \<open>norm ((A o\<^sub>C\<^sub>L A*) *\<^sub>V \<psi>) = norm (A *\<^sub>V A* *\<^sub>V \<psi>)\<close>
       by auto
     also have \<open>\<dots> \<le> norm A * norm (A* *\<^sub>V \<psi>)\<close>
       by (simp add: norm_cblinfun)
     also have \<open>\<dots> \<le> norm A * norm (A*) * norm \<psi>\<close>
       by (metis mult.assoc norm_cblinfun norm_imp_pos_and_ge ordered_comm_semiring_class.comm_mult_left_mono)
     also have \<open>\<dots> = (norm A)\<^sup>2 * norm \<psi>\<close>
       by (simp add: power2_eq_square)
     finally show \<open>norm ((A o\<^sub>C\<^sub>L A*) *\<^sub>V \<psi>) \<le> (norm A)\<^sup>2 * norm \<psi>\<close>
       by -
   qed
 
   from 1 2 show ?thesis by simp
 next
   case False
   then have [simp]: \<open>class.CARD_1 TYPE('b)\<close>
     by (rule not_singleton_vs_CARD_1)
   have \<open>A = 0\<close>
     apply (rule cblinfun_to_CARD_1_0[internalize_sort' 'b])
     by (auto intro: complex_normed_vector_class.complex_normed_vector_axioms)
   then show ?thesis
     by auto
 qed
 
 lemma sum_adj: \<open>(sum a F)* = sum (\<lambda>i. (a i)*) F\<close>
   apply (induction rule:infinite_finite_induct)
   by (auto simp add: adj_plus)
 
 lemma has_sum_adj:
   assumes \<open>has_sum f I x\<close>
   shows \<open>has_sum (\<lambda>x. adj (f x)) I (adj x)\<close>
   apply (rule has_sum_comm_additive[where f=adj, unfolded o_def])
   apply (simp add: antilinear.axioms(1))
   apply (metis (no_types, lifting) LIM_eq adj_plus adj_uminus norm_adj uminus_add_conv_diff)
   by (simp add: assms)
 
 lemma adj_minus: \<open>(A - B)* = (A*) - (B*)\<close>
   by (metis add_implies_diff adj_plus diff_add_cancel)
 
 lemma cinner_hermitian_real: \<open>x \<bullet>\<^sub>C (A *\<^sub>V x) \<in> \<real>\<close> if \<open>A* = A\<close>
   by (metis Reals_cnj_iff cinner_adj_right cinner_commute' that)
 
 lemma adj_inject: \<open>adj a = adj b \<longleftrightarrow> a = b\<close>
   by (metis (no_types, opaque_lifting) adj_minus eq_iff_diff_eq_0 norm_adj norm_eq_zero)
 
 lemma norm_AadjA[simp]: \<open>norm (A* o\<^sub>C\<^sub>L A) = (norm A)\<^sup>2\<close> for A :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space\<close>
   by (metis double_adj norm_AAadj norm_adj)
 
 subsection \<open>Powers of operators\<close>
 
 lift_definition cblinfun_power :: \<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'a \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'a\<close> is
   \<open>\<lambda>(a::'a\<Rightarrow>'a) n. a ^^ n\<close>
   apply (rename_tac f n, induct_tac n, auto simp: Nat.funpow_code_def)
   by (simp add: bounded_clinear_compose)
 
 lemma cblinfun_power_0[simp]: \<open>cblinfun_power A 0 = id_cblinfun\<close> 
   apply transfer by auto
 
 lemma cblinfun_power_Suc': \<open>cblinfun_power A (Suc n) = A o\<^sub>C\<^sub>L cblinfun_power A n\<close> 
   apply transfer by auto
 
 lemma cblinfun_power_Suc: \<open>cblinfun_power A (Suc n) = cblinfun_power A n o\<^sub>C\<^sub>L A\<close>
   apply (induction n)
   by (auto simp: cblinfun_power_Suc' simp flip:  cblinfun_compose_assoc)
 
 lemma cblinfun_power_compose[simp]: \<open>cblinfun_power A n o\<^sub>C\<^sub>L cblinfun_power A m = cblinfun_power A (n+m)\<close>
   apply (induction n)
   by (auto simp: cblinfun_power_Suc' cblinfun_compose_assoc)
 
 lemma cblinfun_power_scaleC: \<open>cblinfun_power (c *\<^sub>C a) n = c^n *\<^sub>C cblinfun_power a n\<close>
   apply (induction n)
   by (auto simp: cblinfun_power_Suc)
 
 lemma cblinfun_power_scaleR: \<open>cblinfun_power (c *\<^sub>R a) n = c^n *\<^sub>R cblinfun_power a n\<close>
   apply (induction n)
   by (auto simp: cblinfun_power_Suc)
 
 lemma cblinfun_power_uminus: \<open>cblinfun_power (-a) n = (-1)^n *\<^sub>R cblinfun_power a n\<close>
   apply (subst asm_rl[of \<open>-a = (-1) *\<^sub>R a\<close>])
    apply simp
   by (rule cblinfun_power_scaleR)
 
 lemma cblinfun_power_adj: \<open>(cblinfun_power S n)* = cblinfun_power (S*) n\<close>
   apply (induction n)
    apply simp
   apply (subst cblinfun_power_Suc)
   apply (subst cblinfun_power_Suc')
   by auto
 
 subsection \<open>Unitaries / isometries\<close>
 
 
 definition isometry::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner \<Rightarrow> bool\<close> where
   \<open>isometry U \<longleftrightarrow> U* o\<^sub>C\<^sub>L U = id_cblinfun\<close>
 
 definition unitary::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner \<Rightarrow> bool\<close> where
   \<open>unitary U \<longleftrightarrow> (U* o\<^sub>C\<^sub>L U  = id_cblinfun) \<and> (U o\<^sub>C\<^sub>L U* = id_cblinfun)\<close>
 
 lemma unitary_twosided_isometry: "unitary U \<longleftrightarrow> isometry U \<and> isometry (U*)"
   unfolding unitary_def isometry_def by simp
 
 lemma isometryD[simp]: "isometry U \<Longrightarrow> U* o\<^sub>C\<^sub>L U = id_cblinfun"
   unfolding isometry_def by simp
 
 (* Not [simp] because isometryD[simp] + unitary_isometry[simp] already have the same effect *)
 lemma unitaryD1: "unitary U \<Longrightarrow> U* o\<^sub>C\<^sub>L U = id_cblinfun"
   unfolding unitary_def by simp
 
 lemma unitaryD2[simp]: "unitary U \<Longrightarrow> U o\<^sub>C\<^sub>L U* = id_cblinfun"
   unfolding unitary_def by simp
 
 lemma unitary_isometry[simp]: "unitary U \<Longrightarrow> isometry U"
   unfolding unitary_def isometry_def by simp
 
 lemma unitary_adj[simp]: "unitary (U*) = unitary U"
   unfolding unitary_def by auto
 
 lemma isometry_cblinfun_compose[simp]:
   assumes "isometry A" and "isometry B"
   shows "isometry (A o\<^sub>C\<^sub>L B)"
 proof-
   have "B* o\<^sub>C\<^sub>L A* o\<^sub>C\<^sub>L (A o\<^sub>C\<^sub>L B) = id_cblinfun" if "A* o\<^sub>C\<^sub>L A = id_cblinfun" and "B* o\<^sub>C\<^sub>L B = id_cblinfun"
     using that
     by (smt (verit, del_insts) adjoint_eqI cblinfun_apply_cblinfun_compose cblinfun_id_cblinfun_apply)
   thus ?thesis
     using assms unfolding isometry_def by simp
 qed
 
 lemma unitary_cblinfun_compose[simp]: "unitary (A o\<^sub>C\<^sub>L B)"
   if "unitary A" and "unitary B"
   using that
   by (smt (z3) adj_cblinfun_compose cblinfun_compose_assoc cblinfun_compose_id_right double_adj isometryD isometry_cblinfun_compose unitary_def unitary_isometry)
 
 lemma unitary_surj:
   assumes "unitary U"
   shows "surj (cblinfun_apply U)"
   apply (rule surjI[where f=\<open>cblinfun_apply (U*)\<close>])
   using assms unfolding unitary_def apply transfer
   using comp_eq_dest_lhs by force
 
 lemma unitary_id[simp]: "unitary id_cblinfun"
   by (simp add: unitary_def)
 
 lemma orthogonal_on_basis_is_isometry:
   assumes spanB: \<open>ccspan B = \<top>\<close>
   assumes orthoU: \<open>\<And>b c. b\<in>B \<Longrightarrow> c\<in>B \<Longrightarrow> cinner (U *\<^sub>V b) (U *\<^sub>V c) = cinner b c\<close>
   shows \<open>isometry U\<close>
 proof -
   have [simp]: \<open>b \<in> closure (cspan B)\<close> for b
     using spanB apply transfer by simp
   have *: \<open>cinner (U* *\<^sub>V U *\<^sub>V \<psi>) \<phi> = cinner \<psi> \<phi>\<close> if \<open>\<psi>\<in>B\<close> and \<open>\<phi>\<in>B\<close> for \<psi> \<phi>
     by (simp add: cinner_adj_left orthoU that(1) that(2))
   have *: \<open>cinner (U* *\<^sub>V U *\<^sub>V \<psi>) \<phi> = cinner \<psi> \<phi>\<close> if \<open>\<psi>\<in>B\<close> for \<psi> \<phi>
     apply (rule bounded_clinear_eq_on[where t=\<phi> and G=B])
     using bounded_clinear_cinner_right *[OF that]
     by auto
   have \<open>U* *\<^sub>V U *\<^sub>V \<phi> = \<phi>\<close> if \<open>\<phi>\<in>B\<close> for \<phi>
     apply (rule cinner_extensionality)
     apply (subst cinner_eq_flip)
     by (simp add: * that)
   then have \<open>U* o\<^sub>C\<^sub>L U = id_cblinfun\<close>
     by (metis cblinfun_apply_cblinfun_compose cblinfun_eq_gen_eqI cblinfun_id_cblinfun_apply spanB)
   then show \<open>isometry U\<close>
     using isometry_def by blast
 qed
 
 lemma isometry_preserves_norm: \<open>isometry U \<Longrightarrow> norm (U *\<^sub>V \<psi>) = norm \<psi>\<close>
   by (metis (no_types, lifting) cblinfun_apply_cblinfun_compose cblinfun_id_cblinfun_apply cinner_adj_right cnorm_eq isometryD)
 
+lemma norm_isometry_compose: 
+  assumes \<open>isometry U\<close>
+  shows \<open>norm (U o\<^sub>C\<^sub>L A) = norm A\<close>
+proof -
+  have *: \<open>norm (U *\<^sub>V A *\<^sub>V \<psi>) = norm (A *\<^sub>V \<psi>)\<close> for \<psi>
+    by (smt (verit, ccfv_threshold) assms cblinfun_apply_cblinfun_compose cinner_adj_right cnorm_eq id_cblinfun_apply isometryD)
+
+  have \<open>norm (U o\<^sub>C\<^sub>L A) = (SUP \<psi>. norm (U *\<^sub>V A *\<^sub>V \<psi>) / norm \<psi>)\<close>
+    unfolding norm_cblinfun_Sup by auto
+  also have \<open>\<dots> = (SUP \<psi>. norm (A *\<^sub>V \<psi>) / norm \<psi>)\<close>
+    using * by auto
+  also have \<open>\<dots> = norm A\<close>
+    unfolding norm_cblinfun_Sup by auto
+  finally show ?thesis
+    by simp
+qed
+
+lemma norm_isometry:
+  fixes U :: \<open>'a::{chilbert_space,not_singleton} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner\<close>
+  assumes \<open>isometry U\<close>
+  shows \<open>norm U = 1\<close>
+  apply (subst asm_rl[of \<open>U = U o\<^sub>C\<^sub>L id_cblinfun\<close>], simp)
+  apply (subst norm_isometry_compose, simp add: assms)
+  by simp
+
+lemma norm_preserving_isometry: \<open>isometry U\<close> if \<open>\<And>\<psi>. norm (U *\<^sub>V \<psi>) = norm \<psi>\<close>
+  by (smt (verit, ccfv_SIG) cblinfun_cinner_eqI cblinfun_id_cblinfun_apply cinner_adj_right cnorm_eq isometry_def simp_a_oCL_b' that)
+
 subsection \<open>Product spaces\<close>
 
 lift_definition cblinfun_left :: \<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L ('a\<times>'b::complex_normed_vector)\<close> is \<open>(\<lambda>x. (x,0))\<close>
   by (auto intro!: bounded_clinearI[where K=1])
 lift_definition cblinfun_right :: \<open>'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L ('a::complex_normed_vector\<times>'b)\<close> is \<open>(\<lambda>x. (0,x))\<close>
   by (auto intro!: bounded_clinearI[where K=1])
 
 lemma isometry_cblinfun_left[simp]: \<open>isometry cblinfun_left\<close>
   apply (rule orthogonal_on_basis_is_isometry[of some_chilbert_basis])
    apply simp
   apply transfer
   by simp
 
 lemma isometry_cblinfun_right[simp]: \<open>isometry cblinfun_right\<close>
   apply (rule orthogonal_on_basis_is_isometry[of some_chilbert_basis])
    apply simp
   apply transfer
   by simp
 
 lemma cblinfun_left_right_ortho[simp]: \<open>cblinfun_left* o\<^sub>C\<^sub>L cblinfun_right = 0\<close>
 proof -
   have \<open>x \<bullet>\<^sub>C ((cblinfun_left* o\<^sub>C\<^sub>L cblinfun_right) *\<^sub>V y) = 0\<close> for x :: 'b and y :: 'a
     apply (simp add: cinner_adj_right)
     apply transfer
     by auto
   then show ?thesis
     by (metis cblinfun.zero_left cblinfun_eqI cinner_eq_zero_iff)
 qed
 
 lemma cblinfun_right_left_ortho[simp]: \<open>cblinfun_right* o\<^sub>C\<^sub>L cblinfun_left = 0\<close>
 proof -
   have \<open>x \<bullet>\<^sub>C ((cblinfun_right* o\<^sub>C\<^sub>L cblinfun_left) *\<^sub>V y) = 0\<close> for x :: 'b and y :: 'a
     apply (simp add: cinner_adj_right)
     apply transfer
     by auto
   then show ?thesis
     by (metis cblinfun.zero_left cblinfun_eqI cinner_eq_zero_iff)
 qed
 
 lemma cblinfun_left_apply[simp]: \<open>cblinfun_left *\<^sub>V \<psi> = (\<psi>,0)\<close>
   apply transfer by simp
 
 lemma cblinfun_left_adj_apply[simp]: \<open>cblinfun_left* *\<^sub>V \<psi> = fst \<psi>\<close>
   apply (cases \<psi>)
   by (auto intro!: cinner_extensionality[of \<open>_ *\<^sub>V _\<close>] simp: cinner_adj_right)
 
 lemma cblinfun_right_apply[simp]: \<open>cblinfun_right *\<^sub>V \<psi> = (0,\<psi>)\<close>
   apply transfer by simp
 
 lemma cblinfun_right_adj_apply[simp]: \<open>cblinfun_right* *\<^sub>V \<psi> = snd \<psi>\<close>
   apply (cases \<psi>)
   by (auto intro!: cinner_extensionality[of \<open>_ *\<^sub>V _\<close>] simp: cinner_adj_right)
 
 lift_definition ccsubspace_Times :: \<open>'a::complex_normed_vector ccsubspace \<Rightarrow> 'b::complex_normed_vector ccsubspace \<Rightarrow> ('a\<times>'b) ccsubspace\<close> is
   Product_Type.Times
 proof -
   fix S :: \<open>'a set\<close> and T :: \<open>'b set\<close>
   assume [simp]: \<open>closed_csubspace S\<close> \<open>closed_csubspace T\<close>
   have \<open>csubspace (S \<times> T)\<close>
     by (simp add: complex_vector.subspace_Times)
   moreover have \<open>closed (S \<times> T)\<close>
     by (simp add: closed_Times closed_csubspace.closed)
   ultimately show \<open>closed_csubspace (S \<times> T)\<close>
     by (rule closed_csubspace.intro)
 qed
 
 
 lemma ccspan_Times: \<open>ccspan (S \<times> T) = ccsubspace_Times (ccspan S) (ccspan T)\<close> if \<open>0 \<in> S\<close> and \<open>0 \<in> T\<close>
 proof (transfer fixing: S T)
   from that have \<open>closure (cspan (S \<times> T)) = closure (cspan S \<times> cspan T)\<close>
     by (simp add: cspan_Times)
   also have \<open>\<dots> = closure (cspan S) \<times> closure (cspan T)\<close>
     using closure_Times by blast
   finally   show \<open>closure (cspan (S \<times> T)) = closure (cspan S) \<times> closure (cspan T)\<close>
     by -
 qed
 
 lemma ccspan_Times_sing1: \<open>ccspan ({0::'a::complex_normed_vector} \<times> B) = ccsubspace_Times 0 (ccspan B)\<close>
 proof (transfer fixing: B)
   have \<open>closure (cspan ({0::'a} \<times> B)) = closure ({0} \<times> cspan B)\<close>
     by (simp add: complex_vector.span_Times_sing1)
   also have \<open>\<dots> = closure {0} \<times> closure (cspan B)\<close>
     using closure_Times by blast
   also have \<open>\<dots> = {0} \<times> closure (cspan B)\<close>
     by simp
   finally show \<open>closure (cspan ({0::'a} \<times> B)) = {0} \<times> closure (cspan B)\<close>
     by -
 qed
 
 lemma ccspan_Times_sing2: \<open>ccspan (B \<times> {0::'a::complex_normed_vector}) = ccsubspace_Times (ccspan B) 0\<close>
 proof (transfer fixing: B)
   have \<open>closure (cspan (B \<times> {0::'a})) = closure (cspan B \<times> {0})\<close>
     by (simp add: complex_vector.span_Times_sing2)
   also have \<open>\<dots> = closure (cspan B) \<times> closure {0}\<close>
     using closure_Times by blast
   also have \<open>\<dots> = closure (cspan B) \<times> {0}\<close>
     by simp
   finally show \<open>closure (cspan (B \<times> {0::'a})) = closure (cspan B) \<times> {0}\<close>
     by -
 qed
 
 lemma ccsubspace_Times_sup: \<open>sup (ccsubspace_Times A B) (ccsubspace_Times C D) = ccsubspace_Times (sup A C) (sup B D)\<close>
 proof transfer
   fix A C :: \<open>'a set\<close> and B D :: \<open>'b set\<close>
   have \<open>A \<times> B +\<^sub>M C \<times> D = closure ((A \<times> B) + (C \<times> D))\<close>
     using closed_sum_def by blast
   also have \<open>\<dots> = closure ((A + C) \<times> (B + D))\<close>
     by (simp add: set_Times_plus_distrib)
   also have \<open>\<dots> = closure (A + C) \<times> closure (B + D)\<close>
     by (simp add: closure_Times)
   also have \<open>\<dots> = (A +\<^sub>M C) \<times> (B +\<^sub>M D)\<close>
     by (simp add: closed_sum_def)
   finally show \<open>A \<times> B +\<^sub>M C \<times> D = (A +\<^sub>M C) \<times> (B +\<^sub>M D)\<close>
     by -
 qed
 
 lemma ccsubspace_Times_top_top[simp]: \<open>ccsubspace_Times top top = top\<close>
   apply transfer
   by simp
 
 lemma is_onb_prod:
   assumes \<open>is_onb B\<close> \<open>is_onb B'\<close>
   shows \<open>is_onb ((B \<times> {0}) \<union> ({0} \<times> B'))\<close>
 proof -
   from assms
   have 1: \<open>is_ortho_set ((B \<times> {0}) \<union> ({0} \<times> B'))\<close>
     unfolding is_ortho_set_def
     apply (auto simp: is_onb_def is_ortho_set_def zero_prod_def)
     by (meson is_onb_def is_ortho_set_def)+
 
   have 2: \<open>(l, r) \<in> B \<times> {0} \<Longrightarrow> norm (l, r) = 1\<close> for l :: 'a and r :: 'b
     using \<open>is_onb B\<close> is_onb_def by auto
 
   have 3: \<open>(l, r) \<in> {0} \<times> B' \<Longrightarrow> norm (l, r) = 1\<close> for l :: 'a and r :: 'b
     using \<open>is_onb B'\<close> is_onb_def by auto
 
   have [simp]: \<open>ccspan B = top\<close> \<open>ccspan B' = top\<close>
     using assms is_onb_def by auto
 
   have 4: \<open>ccspan ((B \<times> {0}) \<union> ({0} \<times> B')) = top\<close>
     by (auto simp: ccspan_Times_sing1 ccspan_Times_sing2 ccsubspace_Times_sup simp flip: ccspan_union)
 
   from 1 2 3 4
   show \<open>is_onb ((B \<times> {0}) \<union> ({0} \<times> B'))\<close>
     by (auto simp add: is_onb_def)
 qed
 
 subsection \<open>Images\<close>
 
 
 (* Closure is necessary. See email 47a3bb3d-3cc3-0934-36eb-3ef0f7b70a85@ut.ee *)
 lift_definition cblinfun_image :: \<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector
 \<Rightarrow> 'a ccsubspace \<Rightarrow> 'b ccsubspace\<close>  (infixr "*\<^sub>S" 70)
   is "\<lambda>A S. closure (A ` S)"
   using  bounded_clinear_def closed_closure  closed_csubspace.intro
   by (simp add: bounded_clinear_def complex_vector.linear_subspace_image closure_is_closed_csubspace)
 
 lemma cblinfun_image_mono:
   assumes a1: "S \<le> T"
   shows "A *\<^sub>S S \<le> A *\<^sub>S T"
   using a1
   by (simp add: cblinfun_image.rep_eq closure_mono image_mono less_eq_ccsubspace.rep_eq)
 
 lemma cblinfun_image_0[simp]:
   shows "U *\<^sub>S 0 = 0"
   thm zero_ccsubspace_def
   apply transfer
   by (simp add: bounded_clinear_def complex_vector.linear_0)
 
 lemma cblinfun_image_bot[simp]: "U *\<^sub>S bot = bot"
   using cblinfun_image_0 by auto
 
 lemma cblinfun_image_sup[simp]:
   fixes A B :: \<open>'a::chilbert_space ccsubspace\<close> and U :: "'a \<Rightarrow>\<^sub>C\<^sub>L'b::chilbert_space"
   shows \<open>U *\<^sub>S (sup A B) = sup (U *\<^sub>S A) (U *\<^sub>S B)\<close>
   apply transfer using bounded_clinear.bounded_linear closure_image_closed_sum by blast
 
 lemma scaleC_cblinfun_image[simp]:
   fixes A :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b :: chilbert_space\<close>
     and S :: \<open>'a ccsubspace\<close> and \<alpha> :: complex
   shows \<open>(\<alpha> *\<^sub>C A) *\<^sub>S S  = \<alpha> *\<^sub>C (A *\<^sub>S S)\<close>
 proof-
   have \<open>closure ( ( ((*\<^sub>C) \<alpha>) \<circ> (cblinfun_apply A) ) ` space_as_set S) =
    ((*\<^sub>C) \<alpha>) ` (closure (cblinfun_apply A ` space_as_set S))\<close>
     by (metis closure_scaleC image_comp)
   hence \<open>(closure (cblinfun_apply (\<alpha> *\<^sub>C A) ` space_as_set S)) =
    ((*\<^sub>C) \<alpha>) ` (closure (cblinfun_apply A ` space_as_set S))\<close>
     by (metis (mono_tags, lifting) comp_apply image_cong scaleC_cblinfun.rep_eq)
   hence \<open>Abs_clinear_space (closure (cblinfun_apply (\<alpha> *\<^sub>C A) ` space_as_set S)) =
             \<alpha> *\<^sub>C Abs_clinear_space (closure (cblinfun_apply A ` space_as_set S))\<close>
     by (metis space_as_set_inverse cblinfun_image.rep_eq scaleC_ccsubspace.rep_eq)
   have x1: "Abs_clinear_space (closure ((*\<^sub>V) (\<alpha> *\<^sub>C A) ` space_as_set S)) =
             \<alpha> *\<^sub>C Abs_clinear_space (closure ((*\<^sub>V) A ` space_as_set S))"
     using \<open>Abs_clinear_space (closure (cblinfun_apply (\<alpha> *\<^sub>C A) ` space_as_set S)) =
             \<alpha> *\<^sub>C Abs_clinear_space (closure (cblinfun_apply A ` space_as_set S))\<close>
     by blast
   show ?thesis
     unfolding cblinfun_image_def using x1 by force
 qed
 
 lemma cblinfun_image_id[simp]:
   "id_cblinfun *\<^sub>S \<psi> = \<psi>"
   apply transfer
   by (simp add: closed_csubspace.closed)
 
 lemma cblinfun_compose_image:
   \<open>(A o\<^sub>C\<^sub>L B) *\<^sub>S S =  A *\<^sub>S (B *\<^sub>S S)\<close>
   apply transfer unfolding image_comp[symmetric]
   apply (rule closure_bounded_linear_image_subset_eq[symmetric])
   by (simp add: bounded_clinear.bounded_linear)
 
 lemmas cblinfun_assoc_left = cblinfun_compose_assoc[symmetric] cblinfun_compose_image[symmetric]
   add.assoc[where ?'a="'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space", symmetric]
 lemmas cblinfun_assoc_right = cblinfun_compose_assoc cblinfun_compose_image
   add.assoc[where ?'a="'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space"]
 
 lemma cblinfun_image_INF_leq[simp]:
   fixes U :: "'b::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'c::cbanach"
     and V :: "'a \<Rightarrow> 'b ccsubspace"
   shows \<open>U *\<^sub>S (INF i. V i) \<le> (INF i. U *\<^sub>S (V i))\<close>
   apply transfer
   by (simp add: INT_greatest Inter_lower closure_mono image_mono)
 
 lemma isometry_cblinfun_image_inf_distrib':
   fixes U::\<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b::cbanach\<close> and B C::"'a ccsubspace"
   shows "U *\<^sub>S (inf B C) \<le> inf (U *\<^sub>S B) (U *\<^sub>S C)"
 proof -
   define V where \<open>V b = (if b then B else C)\<close> for b
   have \<open>U *\<^sub>S (INF i. V i) \<le> (INF i. U *\<^sub>S (V i))\<close>
     by auto
   then show ?thesis
     unfolding V_def
     by (metis (mono_tags, lifting) INF_UNIV_bool_expand)
 qed
 
 lemma cblinfun_image_eq:
   fixes S :: "'a::cbanach ccsubspace"
     and A B :: "'a::cbanach \<Rightarrow>\<^sub>C\<^sub>L'b::cbanach"
   assumes "\<And>x. x \<in> G \<Longrightarrow> A *\<^sub>V x = B *\<^sub>V x" and "ccspan G \<ge> S"
   shows "A *\<^sub>S S = B *\<^sub>S S"
 proof (use assms in transfer)
   fix G :: "'a set" and A :: "'a \<Rightarrow> 'b" and B :: "'a \<Rightarrow> 'b" and S :: "'a set"
   assume a1: "bounded_clinear A"
   assume a2: "bounded_clinear B"
   assume a3: "\<And>x. x \<in> G \<Longrightarrow> A x = B x"
   assume a4: "S \<subseteq> closure (cspan G)"
 
   have "A ` closure S = B ` closure S"
     by (smt (verit, best) UnCI a1 a2 a3 a4 bounded_clinear_eq_on closure_Un closure_closure image_cong sup.absorb_iff1)
   then show "closure (A ` S) = closure (B ` S)"
     by (metis bounded_clinear.bounded_linear a1 a2 closure_bounded_linear_image_subset_eq)
 qed
 
 lemma cblinfun_fixes_range:
   assumes "A o\<^sub>C\<^sub>L B = B" and "\<psi> \<in> space_as_set (B *\<^sub>S top)"
   shows "A *\<^sub>V \<psi> = \<psi>"
 proof-
   define rangeB rangeB' where "rangeB = space_as_set (B *\<^sub>S top)"
     and "rangeB' = range (cblinfun_apply B)"
   from assms have "\<psi> \<in> closure rangeB'"
     by (simp add: cblinfun_image.rep_eq rangeB'_def top_ccsubspace.rep_eq)
 
   then obtain \<psi>i where \<psi>i_lim: "\<psi>i \<longlonglongrightarrow> \<psi>" and \<psi>i_B: "\<psi>i i \<in> rangeB'" for i
     using closure_sequential by blast
   have A_invariant: "A *\<^sub>V \<psi>i i = \<psi>i i"
     for i
   proof-
     from \<psi>i_B obtain \<phi> where \<phi>: "\<psi>i i = B *\<^sub>V \<phi>"
       using rangeB'_def by blast
     hence "A *\<^sub>V \<psi>i i = (A o\<^sub>C\<^sub>L B) *\<^sub>V \<phi>"
       by (simp add: cblinfun_compose.rep_eq)
     also have "\<dots> = B *\<^sub>V \<phi>"
       by (simp add: assms)
     also have "\<dots> = \<psi>i i"
       by (simp add: \<phi>)
     finally show ?thesis.
   qed
   from \<psi>i_lim have "(\<lambda>i. A *\<^sub>V (\<psi>i i)) \<longlonglongrightarrow> A *\<^sub>V \<psi>"
     by (rule isCont_tendsto_compose[rotated], simp)
   with A_invariant have "(\<lambda>i. \<psi>i i) \<longlonglongrightarrow> A *\<^sub>V \<psi>"
     by auto
   with \<psi>i_lim show "A *\<^sub>V \<psi> = \<psi>"
     using LIMSEQ_unique by blast
 qed
 
 lemma zero_cblinfun_image[simp]: "0 *\<^sub>S S = (0::_ ccsubspace)"
   apply transfer by (simp add: complex_vector.subspace_0 image_constant[where x=0])
 
 lemma cblinfun_image_INF_eq_general:
   fixes V :: "'a \<Rightarrow> 'b::chilbert_space ccsubspace"
     and U :: "'b \<Rightarrow>\<^sub>C\<^sub>L'c::chilbert_space"
     and Uinv :: "'c \<Rightarrow>\<^sub>C\<^sub>L'b"
   assumes UinvUUinv: "Uinv o\<^sub>C\<^sub>L U o\<^sub>C\<^sub>L Uinv = Uinv" and UUinvU: "U o\<^sub>C\<^sub>L Uinv o\<^sub>C\<^sub>L U = U"
     \<comment> \<open>Meaning: \<^term>\<open>Uinv\<close> is a Pseudoinverse of \<^term>\<open>U\<close>\<close>
     and V: "\<And>i. V i \<le> Uinv *\<^sub>S top"
   shows "U *\<^sub>S (INF i. V i) = (INF i. U *\<^sub>S V i)"
 proof (rule antisym)
   show "U *\<^sub>S (INF i. V i) \<le> (INF i. U *\<^sub>S V i)"
     by (rule cblinfun_image_INF_leq)
 next
   define rangeU rangeUinv where "rangeU = U *\<^sub>S top" and "rangeUinv = Uinv *\<^sub>S top"
   define INFUV INFV where INFUV_def: "INFUV = (INF i. U *\<^sub>S V i)" and INFV_def: "INFV = (INF i. V i)"
   from assms have "V i \<le> rangeUinv"
     for i
     unfolding rangeUinv_def by simp
   moreover have "(Uinv o\<^sub>C\<^sub>L U) *\<^sub>V \<psi> = \<psi>" if "\<psi> \<in> space_as_set rangeUinv"
     for \<psi>
     using UinvUUinv cblinfun_fixes_range rangeUinv_def that by fastforce
   ultimately have "(Uinv o\<^sub>C\<^sub>L U) *\<^sub>V \<psi> = \<psi>" if "\<psi> \<in> space_as_set (V i)"
     for \<psi> i
     using less_eq_ccsubspace.rep_eq that by blast
   hence d1: "(Uinv o\<^sub>C\<^sub>L U) *\<^sub>S (V i) = (V i)" for i
   proof transfer
     show "closure ((Uinv \<circ> U) ` V i) = V i"
       if "pred_fun \<top> closed_csubspace V"
         and "bounded_clinear Uinv"
         and "bounded_clinear U"
         and "\<And>\<psi> i. \<psi> \<in> V i \<Longrightarrow> (Uinv \<circ> U) \<psi> = \<psi>"
       for V :: "'a \<Rightarrow> 'b set"
         and Uinv :: "'c \<Rightarrow> 'b"
         and U :: "'b \<Rightarrow> 'c"
         and i :: 'a
       using that proof auto
       show "x \<in> V i"
         if "\<forall>x. closed_csubspace (V x)"
           and "bounded_clinear Uinv"
           and "bounded_clinear U"
           and "\<And>\<psi> i. \<psi> \<in> V i \<Longrightarrow> Uinv (U \<psi>) = \<psi>"
           and "x \<in> closure (V i)"
         for x :: 'b
         using that
         by (metis orthogonal_complement_of_closure closed_csubspace.subspace double_orthogonal_complement_id closure_is_closed_csubspace)
       show "x \<in> closure (V i)"
         if "\<forall>x. closed_csubspace (V x)"
           and "bounded_clinear Uinv"
           and "bounded_clinear U"
           and "\<And>\<psi> i. \<psi> \<in> V i \<Longrightarrow> Uinv (U \<psi>) = \<psi>"
           and "x \<in> V i"
         for x :: 'b
         using that
         using setdist_eq_0_sing_1 setdist_sing_in_set
         by blast
     qed
   qed
   have "U *\<^sub>S V i \<le> rangeU" for i
     by (simp add: cblinfun_image_mono rangeU_def)
   hence "INFUV \<le> rangeU"
     unfolding INFUV_def by (meson INF_lower UNIV_I order_trans)
   moreover have "(U o\<^sub>C\<^sub>L Uinv) *\<^sub>V \<psi> = \<psi>" if "\<psi> \<in> space_as_set rangeU" for \<psi>
     using UUinvU cblinfun_fixes_range rangeU_def that by fastforce
   ultimately have x: "(U o\<^sub>C\<^sub>L Uinv) *\<^sub>V \<psi> = \<psi>" if "\<psi> \<in> space_as_set INFUV" for \<psi>
     by (simp add: in_mono less_eq_ccsubspace.rep_eq that)
 
   have "closure ((U \<circ> Uinv) ` INFUV) = INFUV"
     if "closed_csubspace INFUV"
       and "bounded_clinear U"
       and "bounded_clinear Uinv"
       and "\<And>\<psi>. \<psi> \<in> INFUV \<Longrightarrow> (U \<circ> Uinv) \<psi> = \<psi>"
     for INFUV :: "'c set"
       and U :: "'b \<Rightarrow> 'c"
       and Uinv :: "'c \<Rightarrow> 'b"
     using that proof auto
     show "x \<in> INFUV"
       if "closed_csubspace INFUV"
         and "bounded_clinear U"
         and "bounded_clinear Uinv"
         and "\<And>\<psi>. \<psi> \<in> INFUV \<Longrightarrow> U (Uinv \<psi>) = \<psi>"
         and "x \<in> closure INFUV"
       for x :: 'c
       using that
       by (metis orthogonal_complement_of_closure closed_csubspace.subspace double_orthogonal_complement_id closure_is_closed_csubspace)
     show "x \<in> closure INFUV"
       if "closed_csubspace INFUV"
         and "bounded_clinear U"
         and "bounded_clinear Uinv"
         and "\<And>\<psi>. \<psi> \<in> INFUV \<Longrightarrow> U (Uinv \<psi>) = \<psi>"
         and "x \<in> INFUV"
       for x :: 'c
       using that
       using setdist_eq_0_sing_1 setdist_sing_in_set
       by (simp add: closed_csubspace.closed)
   qed
   hence "(U o\<^sub>C\<^sub>L Uinv) *\<^sub>S INFUV = INFUV"
     by (metis (mono_tags, opaque_lifting) x cblinfun_image.rep_eq cblinfun_image_id id_cblinfun_apply image_cong
         space_as_set_inject)
   hence "INFUV = U *\<^sub>S Uinv *\<^sub>S INFUV"
     by (simp add: cblinfun_compose_image)
   also have "\<dots> \<le> U *\<^sub>S (INF i. Uinv *\<^sub>S U *\<^sub>S V i)"
     unfolding INFUV_def
     by (metis cblinfun_image_mono cblinfun_image_INF_leq)
   also have "\<dots> = U *\<^sub>S INFV"
     using d1
     by (metis (no_types, lifting) INFV_def cblinfun_assoc_left(2) image_cong)
   finally show "INFUV \<le> U *\<^sub>S INFV".
 qed
 
 lemma unitary_range[simp]:
   assumes "unitary U"
   shows "U *\<^sub>S top = top"
   using assms unfolding unitary_def apply transfer
   by (metis closure_UNIV comp_apply surj_def)
 
 lemma range_adjoint_isometry:
   assumes "isometry U"
   shows "U* *\<^sub>S top = top"
 proof-
   from assms have "top = U* *\<^sub>S U *\<^sub>S top"
     by (simp add: cblinfun_assoc_left(2))
   also have "\<dots> \<le> U* *\<^sub>S top"
     by (simp add: cblinfun_image_mono)
   finally show ?thesis
     using top.extremum_unique by blast
 qed
 
 lemma cblinfun_image_INF_eq[simp]:
   fixes V :: "'a \<Rightarrow> 'b::chilbert_space ccsubspace"
     and U :: "'b \<Rightarrow>\<^sub>C\<^sub>L 'c::chilbert_space"
   assumes \<open>isometry U\<close>
   shows "U *\<^sub>S (INF i. V i) = (INF i. U *\<^sub>S V i)"
 proof -
   from \<open>isometry U\<close> have "U* o\<^sub>C\<^sub>L U o\<^sub>C\<^sub>L U* = U*"
     unfolding isometry_def by simp
   moreover from \<open>isometry U\<close> have "U o\<^sub>C\<^sub>L U* o\<^sub>C\<^sub>L U = U"
     unfolding isometry_def
     by (simp add: cblinfun_compose_assoc)
   moreover have "V i \<le> U* *\<^sub>S top" for i
     by (simp add: range_adjoint_isometry assms)
   ultimately show ?thesis
     by (rule cblinfun_image_INF_eq_general)
 qed
 
 lemma isometry_cblinfun_image_inf_distrib[simp]:
   fixes U::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space\<close>
     and X Y::"'a ccsubspace"
   assumes "isometry U"
   shows "U *\<^sub>S (inf X Y) = inf (U *\<^sub>S X) (U *\<^sub>S Y)"
   using cblinfun_image_INF_eq[where V="\<lambda>b. if b then X else Y" and U=U]
   unfolding INF_UNIV_bool_expand
   using assms by auto
 
 lemma cblinfun_image_ccspan:
   shows "A *\<^sub>S ccspan G = ccspan ((*\<^sub>V) A ` G)"
   apply transfer
   by (simp add: bounded_clinear.bounded_linear bounded_clinear_def closure_bounded_linear_image_subset_eq complex_vector.linear_span_image)
 
 
 lemma cblinfun_apply_in_image[simp]: "A *\<^sub>V \<psi> \<in> space_as_set (A *\<^sub>S \<top>)"
   by (metis cblinfun_image.rep_eq closure_subset in_mono range_eqI top_ccsubspace.rep_eq)
 
 
 lemma cblinfun_plus_image_distr:
   \<open>(A + B) *\<^sub>S S \<le> A *\<^sub>S S \<squnion> B *\<^sub>S S\<close>
   apply transfer
   by (smt (verit, ccfv_threshold) closed_closure closed_sum_def closure_minimal closure_subset image_subset_iff set_plus_intro subset_eq)
 
 lemma cblinfun_sum_image_distr:
   \<open>(\<Sum>i\<in>I. A i) *\<^sub>S S \<le> (SUP i\<in>I. A i *\<^sub>S S)\<close>
 proof (cases \<open>finite I\<close>)
   case True
   then show ?thesis
   proof induction
     case empty
     then show ?case
       by auto
   next
     case (insert x F)
     then show ?case
       apply auto by (smt (z3) cblinfun_plus_image_distr inf_sup_aci(6) le_iff_sup)
   qed
 next
   case False
   then show ?thesis
     by auto
 qed
 
 lemma space_as_set_image_commute:
   assumes UV: \<open>U o\<^sub>C\<^sub>L V = id_cblinfun\<close> and VU: \<open>V o\<^sub>C\<^sub>L U = id_cblinfun\<close>
     (* I think only one of them is needed, can the lemma be strengthened? *)
   shows \<open>(*\<^sub>V) U ` space_as_set T = space_as_set (U *\<^sub>S T)\<close>
 proof -
   have \<open>space_as_set (U *\<^sub>S T) = U ` V ` space_as_set (U *\<^sub>S T)\<close>
     by (simp add: image_image UV flip: cblinfun_apply_cblinfun_compose)
   also have \<open>\<dots> \<subseteq> U ` space_as_set (V *\<^sub>S U *\<^sub>S T)\<close>
     by (metis cblinfun_image.rep_eq closure_subset image_mono)
   also have \<open>\<dots> = U ` space_as_set T\<close>
     by (simp add: VU cblinfun_assoc_left(2))
   finally have 1: \<open>space_as_set (U *\<^sub>S T) \<subseteq> U ` space_as_set T\<close>
     by -
   have 2: \<open>U ` space_as_set T \<subseteq> space_as_set (U *\<^sub>S T)\<close>
     by (simp add: cblinfun_image.rep_eq closure_subset)
   from 1 2 show ?thesis
     by simp
 qed
 
 lemma right_total_rel_ccsubspace:
   fixes R :: \<open>'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector \<Rightarrow> bool\<close>
   assumes UV: \<open>U o\<^sub>C\<^sub>L V = id_cblinfun\<close>
   assumes VU: \<open>V o\<^sub>C\<^sub>L U = id_cblinfun\<close>
   assumes R_def: \<open>\<And>x y. R x y \<longleftrightarrow> x = U *\<^sub>V y\<close>
   shows \<open>right_total (rel_ccsubspace R)\<close>
 proof (rule right_totalI)
   fix T :: \<open>'b ccsubspace\<close>
   show \<open>\<exists>S. rel_ccsubspace R S T\<close>
     apply (rule exI[of _ \<open>U *\<^sub>S T\<close>])
     using UV VU by (auto simp add: rel_ccsubspace_def R_def rel_set_def simp flip: space_as_set_image_commute)
 qed
 
 lemma left_total_rel_ccsubspace:
   fixes R :: \<open>'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector \<Rightarrow> bool\<close>
   assumes UV: \<open>U o\<^sub>C\<^sub>L V = id_cblinfun\<close>
   assumes VU: \<open>V o\<^sub>C\<^sub>L U = id_cblinfun\<close>
   assumes R_def: \<open>\<And>x y. R x y \<longleftrightarrow> y = U *\<^sub>V x\<close>
   shows \<open>left_total (rel_ccsubspace R)\<close>
 proof -
   have \<open>right_total (rel_ccsubspace (conversep R))\<close>
     apply (rule right_total_rel_ccsubspace)
     using assms by auto
   then show ?thesis
     by (auto intro!: right_total_conversep[THEN iffD1] simp: converse_rel_ccsubspace)
 qed
 
 lemma cblinfun_image_bot_zero[simp]: \<open>A *\<^sub>S top = bot \<longleftrightarrow> A = 0\<close>
   by (metis Complex_Bounded_Linear_Function.zero_cblinfun_image bot_ccsubspace.rep_eq cblinfun_apply_in_image cblinfun_eqI empty_iff insert_iff zero_ccsubspace_def)
 
 subsection \<open>Sandwiches\<close>
 
 
 lift_definition sandwich :: \<open>('a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner) \<Rightarrow> (('a \<Rightarrow>\<^sub>C\<^sub>L 'a) \<Rightarrow>\<^sub>C\<^sub>L ('b \<Rightarrow>\<^sub>C\<^sub>L 'b))\<close> is
   \<open>\<lambda>(A::'a\<Rightarrow>\<^sub>C\<^sub>L'b) B. A o\<^sub>C\<^sub>L B o\<^sub>C\<^sub>L A*\<close>
 proof
   fix A :: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L 'b\<close> and B B1 B2 :: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L 'a\<close> and c :: complex
   show \<open>A o\<^sub>C\<^sub>L (B1 + B2) o\<^sub>C\<^sub>L A* = (A o\<^sub>C\<^sub>L B1 o\<^sub>C\<^sub>L A*) + (A o\<^sub>C\<^sub>L B2 o\<^sub>C\<^sub>L A*)\<close>
     by (simp add: cblinfun_compose_add_left cblinfun_compose_add_right)
   show \<open>A o\<^sub>C\<^sub>L (c *\<^sub>C B) o\<^sub>C\<^sub>L A* = c *\<^sub>C (A o\<^sub>C\<^sub>L B o\<^sub>C\<^sub>L A*)\<close>
     by auto
   show \<open>\<exists>K. \<forall>B. norm (A o\<^sub>C\<^sub>L B o\<^sub>C\<^sub>L A*) \<le> norm B * K\<close>
   proof (rule exI[of _ \<open>norm A * norm (A*)\<close>], rule allI)
     fix B
     have \<open>norm (A o\<^sub>C\<^sub>L B o\<^sub>C\<^sub>L A*) \<le> norm (A o\<^sub>C\<^sub>L B) * norm (A*)\<close>
       using norm_cblinfun_compose by blast
     also have \<open>\<dots> \<le> (norm A * norm B) * norm (A*)\<close>
       by (simp add: mult_right_mono norm_cblinfun_compose)
     finally show \<open>norm (A o\<^sub>C\<^sub>L B o\<^sub>C\<^sub>L A*) \<le> norm B * (norm A * norm (A*))\<close>
       by (simp add: mult.assoc vector_space_over_itself.scale_left_commute)
   qed
 qed
 
 lemma sandwich_0[simp]: \<open>sandwich 0 = 0\<close>
   by (simp add: cblinfun_eqI sandwich.rep_eq)
 
 lemma sandwich_apply: \<open>sandwich A *\<^sub>V B = A o\<^sub>C\<^sub>L B o\<^sub>C\<^sub>L A*\<close>
   apply (transfer fixing: A B) by auto
 
-
 lemma norm_sandwich: \<open>norm (sandwich A) = (norm A)\<^sup>2\<close> for A :: \<open>'a::{chilbert_space} \<Rightarrow>\<^sub>C\<^sub>L 'b::{complex_inner}\<close>
 proof -
   have main: \<open>norm (sandwich A) = (norm A)\<^sup>2\<close> for A :: \<open>'c::{chilbert_space,not_singleton} \<Rightarrow>\<^sub>C\<^sub>L 'd::{complex_inner}\<close>
   proof (rule norm_cblinfun_eqI)
     show \<open>(norm A)\<^sup>2 \<le> norm (sandwich A *\<^sub>V id_cblinfun) / norm (id_cblinfun :: 'c \<Rightarrow>\<^sub>C\<^sub>L _)\<close>
       apply (auto simp: sandwich_apply)
       by -
     fix B
     have \<open>norm (sandwich A *\<^sub>V B) \<le> norm (A o\<^sub>C\<^sub>L B) * norm (A*)\<close>
       using norm_cblinfun_compose by (auto simp: sandwich_apply simp del: norm_adj)
     also have \<open>\<dots> \<le> (norm A * norm B) * norm (A*)\<close>
       by (simp add: mult_right_mono norm_cblinfun_compose)
     also have \<open>\<dots> \<le> (norm A)\<^sup>2 * norm B\<close>
       by (simp add: power2_eq_square mult.assoc vector_space_over_itself.scale_left_commute)
     finally show \<open>norm (sandwich A *\<^sub>V B) \<le> (norm A)\<^sup>2 * norm B\<close>
       by -
     show \<open>0 \<le> (norm A)\<^sup>2\<close>
       by auto
   qed
 
   show ?thesis
   proof (cases \<open>class.not_singleton TYPE('a)\<close>)
     case True
     show ?thesis
       apply (rule main[internalize_sort' 'c2])
        apply standard[1]
       using True by simp
   next
     case False
     have \<open>A = 0\<close>
       apply (rule cblinfun_from_CARD_1_0[internalize_sort' 'a])
        apply (rule not_singleton_vs_CARD_1)
        apply (rule False)
       by standard
     then show ?thesis
       by simp
   qed
 qed
 
 lemma sandwich_apply_adj: \<open>sandwich A (B*) = (sandwich A B)*\<close>
   by (simp add: cblinfun_assoc_left(1) sandwich_apply)
 
 lemma sandwich_id[simp]: "sandwich id_cblinfun = id_cblinfun"
   apply (rule cblinfun_eqI)
   by (auto simp: sandwich_apply)
 
 
 subsection \<open>Projectors\<close>
 
 lift_definition Proj :: "('a::chilbert_space) ccsubspace \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L'a"
   is \<open>projection\<close>
   by (rule projection_bounded_clinear)
 
 lemma Proj_range[simp]: "Proj S *\<^sub>S top = S"
 proof transfer
   fix S :: \<open>'a set\<close> assume \<open>closed_csubspace S\<close>
   then have "closure (range (projection S)) \<subseteq> S"
     by (metis closed_csubspace.closed closed_csubspace.subspace closure_closed complex_vector.subspace_0 csubspace_is_convex dual_order.eq_iff insert_absorb insert_not_empty projection_image)
   moreover have "S \<subseteq> closure (range (projection S))"
     using \<open>closed_csubspace S\<close>
     by (metis closed_csubspace_def closure_subset csubspace_is_convex equals0D projection_image subset_iff)
   ultimately show \<open>closure (range (projection S)) = S\<close>
     by auto
 qed
 
 lemma adj_Proj: \<open>(Proj M)* = Proj M\<close>
   apply transfer by (simp add: projection_cadjoint)
 
 lemma Proj_idempotent[simp]: \<open>Proj M o\<^sub>C\<^sub>L Proj M = Proj M\<close>
 proof -
   have u1: \<open>(cblinfun_apply (Proj M)) = projection (space_as_set M)\<close>
     apply transfer
     by blast
   have \<open>closed_csubspace (space_as_set M)\<close>
     using space_as_set by auto
   hence u2: \<open>(projection (space_as_set M))\<circ>(projection (space_as_set M))
                 = (projection (space_as_set M))\<close>
     using projection_idem by fastforce
   have \<open>(cblinfun_apply (Proj M)) \<circ> (cblinfun_apply (Proj M)) = cblinfun_apply (Proj M)\<close>
     using u1 u2
     by simp
   hence \<open>cblinfun_apply ((Proj M) o\<^sub>C\<^sub>L (Proj M)) = cblinfun_apply (Proj M)\<close>
     by (simp add: cblinfun_compose.rep_eq)
   thus ?thesis using cblinfun_apply_inject
     by auto
 qed
 
 (* Widen the type class *)
 lift_definition is_Proj :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'a \<Rightarrow> bool\<close> is
   \<open>\<lambda>P. \<exists>M. closed_csubspace M \<and> is_projection_on P M\<close> .
 
+lemma Proj_top[simp]: \<open>Proj \<top> = id_cblinfun\<close>
+  by (metis Proj_idempotent Proj_range cblinfun_eqI cblinfun_fixes_range id_cblinfun_apply iso_tuple_UNIV_I space_as_set_top)
+
 lemma Proj_on_own_range':
   fixes P :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L'a\<close>
   assumes \<open>P o\<^sub>C\<^sub>L P = P\<close> and \<open>P = P*\<close>
   shows \<open>Proj (P *\<^sub>S top) = P\<close>
 proof-
   define M where "M = P *\<^sub>S top"
   have v3: "x \<in> (\<lambda>x. x - P *\<^sub>V x) -` {0}"
     if "x \<in> range (cblinfun_apply P)"
     for x :: 'a
   proof-
     have v3_1: \<open>cblinfun_apply P \<circ> cblinfun_apply P = cblinfun_apply P\<close>
       by (metis \<open>P o\<^sub>C\<^sub>L P = P\<close> cblinfun_compose.rep_eq)
     have \<open>\<exists>t. P *\<^sub>V t = x\<close>
       using that by blast
     then obtain t where t_def: \<open>P *\<^sub>V t = x\<close>
       by blast
     hence \<open>x - P *\<^sub>V x = x - P *\<^sub>V (P *\<^sub>V t)\<close>
       by simp
     also have \<open>\<dots> = x - (P *\<^sub>V t)\<close>
       using v3_1
       by (metis comp_apply)
     also have \<open>\<dots> = 0\<close>
       by (simp add: t_def)
     finally have \<open>x - P *\<^sub>V x = 0\<close>
       by blast
     thus ?thesis
       by simp
   qed
 
   have v1: "range (cblinfun_apply P) \<subseteq> (\<lambda>x. x - cblinfun_apply P x) -` {0}"
     using v3
     by blast
 
   have "x \<in> range (cblinfun_apply P)"
     if "x \<in> (\<lambda>x. x - P *\<^sub>V x) -` {0}"
     for x :: 'a
   proof-
     have x1:\<open>x - P *\<^sub>V x = 0\<close>
       using that by blast
     have \<open>x = P *\<^sub>V x\<close>
       by (simp add: x1 eq_iff_diff_eq_0)
     thus ?thesis
       by blast
   qed
   hence v2: "(\<lambda>x. x - cblinfun_apply P x) -` {0} \<subseteq> range (cblinfun_apply P)"
     by blast
   have i1: \<open>range (cblinfun_apply P) = (\<lambda> x. x - cblinfun_apply P x) -` {0}\<close>
     using v1 v2
     by (simp add: v1 dual_order.antisym)
   have p1: \<open>closed {(0::'a)}\<close>
     by simp
   have p2: \<open>continuous (at x) (\<lambda> x. x - P *\<^sub>V x)\<close>
     for x
   proof-
     have \<open>cblinfun_apply (id_cblinfun - P) = (\<lambda> x. x - P *\<^sub>V x)\<close>
       by (simp add: id_cblinfun.rep_eq minus_cblinfun.rep_eq)
     hence \<open>bounded_clinear (cblinfun_apply (id_cblinfun - P))\<close>
       using cblinfun_apply
       by blast
     hence \<open>continuous (at x) (cblinfun_apply (id_cblinfun - P))\<close>
       by (simp add: clinear_continuous_at)
     thus ?thesis
       using \<open>cblinfun_apply (id_cblinfun - P) = (\<lambda> x. x - P *\<^sub>V x)\<close>
       by simp
   qed
 
   have i2: \<open>closed ( (\<lambda> x. x - P *\<^sub>V x) -` {0} )\<close>
     using p1 p2
     by (rule Abstract_Topology.continuous_closed_vimage)
 
   have \<open>closed (range (cblinfun_apply P))\<close>
     using i1 i2
     by simp
   have u2: \<open>cblinfun_apply P x \<in> space_as_set M\<close>
     for x
     by (simp add: M_def \<open>closed (range ((*\<^sub>V) P))\<close> cblinfun_image.rep_eq top_ccsubspace.rep_eq)
 
   have xy: \<open>\<langle> x - P *\<^sub>V x, y \<rangle> = 0\<close>
     if y1: \<open>y \<in> space_as_set M\<close>
     for x y
   proof-
     have \<open>\<exists>t. y = P *\<^sub>V t\<close>
       using y1
       by (simp add:  M_def \<open>closed (range ((*\<^sub>V) P))\<close> cblinfun_image.rep_eq image_iff
           top_ccsubspace.rep_eq)
     then obtain t where t_def: \<open>y = P *\<^sub>V t\<close>
       by blast
     have \<open>\<langle> x - P *\<^sub>V x, y \<rangle> = \<langle> x - P *\<^sub>V x, P *\<^sub>V t \<rangle>\<close>
       by (simp add: t_def)
     also have \<open>\<dots> = \<langle> P *\<^sub>V (x - P *\<^sub>V x), t \<rangle>\<close>
       by (metis \<open>P = P*\<close> cinner_adj_left)
     also have \<open>\<dots> = \<langle> P *\<^sub>V x - P *\<^sub>V (P *\<^sub>V x), t \<rangle>\<close>
       by (simp add: cblinfun.diff_right)
     also have \<open>\<dots> = \<langle> P *\<^sub>V x - P *\<^sub>V x, t \<rangle>\<close>
       by (metis assms(1) comp_apply cblinfun_compose.rep_eq)
     also have \<open>\<dots> = \<langle> 0, t \<rangle>\<close>
       by simp
     also have \<open>\<dots> = 0\<close>
       by simp
     finally show ?thesis by blast
   qed
   hence u1: \<open>x - P *\<^sub>V x \<in> orthogonal_complement (space_as_set M)\<close>
     for x
     by (simp add: orthogonal_complementI)
   have "closed_csubspace (space_as_set M)"
     using space_as_set by auto
   hence f1: "(Proj M) *\<^sub>V a = P *\<^sub>V a" for a
     by (simp add: Proj.rep_eq projection_eqI u1 u2)
   have "(+) ((P - Proj M) *\<^sub>V a) = id" for a
     using f1
     by (auto intro!: ext simp add: minus_cblinfun.rep_eq)
   hence "b - b = cblinfun_apply (P - Proj M) a"
     for a b
     by (metis (no_types) add_diff_cancel_right' id_apply)
   hence "cblinfun_apply (id_cblinfun - (P - Proj M)) a = a"
     for a
     by (simp add: minus_cblinfun.rep_eq)
   thus ?thesis
     using u1 u2 cblinfun_apply_inject diff_diff_eq2 diff_eq_diff_eq eq_id_iff id_cblinfun.rep_eq
     by (metis (no_types, opaque_lifting) M_def)
 qed
 
 lemma Proj_range_closed:
   assumes "is_Proj P"
   shows "closed (range (cblinfun_apply P))"
   using assms apply transfer
   using closed_csubspace.closed is_projection_on_image by blast
 
 lemma Proj_is_Proj[simp]:
   fixes M::\<open>'a::chilbert_space ccsubspace\<close>
   shows \<open>is_Proj (Proj M)\<close>
 proof-
   have u1: "closed_csubspace (space_as_set M)"
     using space_as_set by blast
   have v1: "h - Proj M *\<^sub>V h
          \<in> orthogonal_complement (space_as_set M)" for h
     by (simp add: Proj.rep_eq orthogonal_complementI projection_orthogonal u1)
   have v2: "Proj M *\<^sub>V h \<in> space_as_set M" for h
     by (metis Proj.rep_eq mem_Collect_eq orthog_proj_exists projection_eqI space_as_set)
   have u2: "is_projection_on ((*\<^sub>V) (Proj M)) (space_as_set M)"
     unfolding is_projection_on_def
     by (simp add: smallest_dist_is_ortho u1 v1 v2)
   show ?thesis
     using u1 u2 is_Proj.rep_eq by blast
 qed
 
 lemma is_Proj_algebraic:
   fixes P::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'a\<close>
   shows \<open>is_Proj P \<longleftrightarrow> P o\<^sub>C\<^sub>L P = P \<and> P = P*\<close>
 proof
   have "P o\<^sub>C\<^sub>L P = P"
     if "is_Proj P"
     using that apply transfer
     using is_projection_on_idem
     by fastforce
   moreover have "P = P*"
     if "is_Proj P"
     using that apply transfer
     by (metis is_projection_on_cadjoint)
   ultimately show "P o\<^sub>C\<^sub>L P = P \<and> P = P*"
     if "is_Proj P"
     using that
     by blast
   show "is_Proj P"
     if "P o\<^sub>C\<^sub>L P = P \<and> P = P*"
     using that Proj_on_own_range' Proj_is_Proj by metis
 qed
 
 lemma Proj_on_own_range:
   fixes P :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L'a\<close>
   assumes \<open>is_Proj P\<close>
   shows \<open>Proj (P *\<^sub>S top) = P\<close>
   using Proj_on_own_range' assms is_Proj_algebraic by blast
 
 lemma Proj_image_leq: "(Proj S) *\<^sub>S A \<le> S"
   by (metis Proj_range inf_top_left le_inf_iff isometry_cblinfun_image_inf_distrib')
 
 lemma Proj_sandwich:
   fixes A::"'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space"
   assumes "isometry A"
   shows "sandwich A *\<^sub>V Proj S = Proj (A *\<^sub>S S)"
 proof-
   define P where \<open>P = A o\<^sub>C\<^sub>L Proj S o\<^sub>C\<^sub>L (A*)\<close>
   have \<open>P o\<^sub>C\<^sub>L P = P\<close>
     using assms
     unfolding P_def isometry_def
     by (metis (no_types, lifting) Proj_idempotent cblinfun_assoc_left(1) cblinfun_compose_id_left)
   moreover have \<open>P = P*\<close>
     unfolding P_def
     by (metis adj_Proj adj_cblinfun_compose cblinfun_assoc_left(1) double_adj)
   ultimately have
     \<open>\<exists>M. P = Proj M \<and> space_as_set M = range (cblinfun_apply (A o\<^sub>C\<^sub>L (Proj S) o\<^sub>C\<^sub>L (A*)))\<close>
     using P_def Proj_on_own_range'
     by (metis Proj_is_Proj Proj_range_closed cblinfun_image.rep_eq closure_closed top_ccsubspace.rep_eq)
   then obtain M where \<open>P = Proj M\<close>
     and \<open>space_as_set M = range (cblinfun_apply (A o\<^sub>C\<^sub>L (Proj S) o\<^sub>C\<^sub>L (A*)))\<close>
     by blast
 
   have f1: "A o\<^sub>C\<^sub>L Proj S = P o\<^sub>C\<^sub>L A"
     by (simp add: P_def assms cblinfun_compose_assoc)
   hence "P o\<^sub>C\<^sub>L A o\<^sub>C\<^sub>L A* = P"
     using P_def by presburger
   hence "(P o\<^sub>C\<^sub>L A) *\<^sub>S (c \<squnion> A* *\<^sub>S d) = P *\<^sub>S (A *\<^sub>S c \<squnion> d)"
     for c d
 
     by (simp add: cblinfun_assoc_left(2))
   hence "P *\<^sub>S (A *\<^sub>S \<top> \<squnion> c) = (P o\<^sub>C\<^sub>L A) *\<^sub>S \<top>"
     for c
     by (metis sup_top_left)
   hence \<open>M = A *\<^sub>S S\<close>
     using f1
     by (metis \<open>P = Proj M\<close> cblinfun_assoc_left(2) Proj_range sup_top_right)
   thus ?thesis
     using \<open>P = Proj M\<close>
     unfolding P_def sandwich_apply by blast
 qed
 
 lemma Proj_orthog_ccspan_union:
   assumes "\<And>x y. x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> is_orthogonal x y"
   shows \<open>Proj (ccspan (X \<union> Y)) = Proj (ccspan X) + Proj (ccspan Y)\<close>
 proof -
   have \<open>x \<in> cspan X \<Longrightarrow> y \<in> cspan Y \<Longrightarrow> is_orthogonal x y\<close> for x y
     apply (rule is_orthogonal_closure_cspan[where X=X and Y=Y])
     using closure_subset assms by auto
   then have \<open>x \<in> closure (cspan X) \<Longrightarrow> y \<in> closure (cspan Y) \<Longrightarrow> is_orthogonal x y\<close> for x y
     by (metis orthogonal_complementI orthogonal_complement_of_closure orthogonal_complement_orthoI')
   then show ?thesis
     apply (transfer fixing: X Y)
     apply (subst projection_plus[symmetric])
     by auto
 qed
 
 abbreviation proj :: "'a::chilbert_space \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'a" where "proj \<psi> \<equiv> Proj (ccspan {\<psi>})"
 
 lemma proj_0[simp]: \<open>proj 0 = 0\<close>
   apply transfer by auto
 
 lemma surj_isometry_is_unitary:
   fixes U :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space\<close>
   assumes \<open>isometry U\<close>
   assumes \<open>U *\<^sub>S \<top> = \<top>\<close>
   shows \<open>unitary U\<close>
   by (metis Proj_sandwich sandwich_apply Proj_on_own_range' assms(1) assms(2) cblinfun_compose_id_right isometry_def unitary_def unitary_id unitary_range)
 
 lemma ccsubspace_supI_via_Proj:
   fixes A B C::"'a::chilbert_space ccsubspace"
   assumes a1: \<open>Proj (- C) *\<^sub>S A \<le> B\<close>
   shows  "A \<le> sup B C"
 proof-
   have x2: \<open>x \<in> space_as_set B\<close>
     if "x \<in>  closure ( (projection (orthogonal_complement (space_as_set C))) ` space_as_set A)" for x
     using that
     by (metis Proj.rep_eq cblinfun_image.rep_eq assms less_eq_ccsubspace.rep_eq subsetD
         uminus_ccsubspace.rep_eq)
   have q1: \<open>x \<in> closure {\<psi> + \<phi> |\<psi> \<phi>. \<psi> \<in> space_as_set B \<and> \<phi> \<in> space_as_set C}\<close>
     if \<open>x \<in> space_as_set A\<close>
     for x
   proof-
     have p1: \<open>closed_csubspace (space_as_set C)\<close>
       using space_as_set by auto
     hence \<open>x = (projection (space_as_set C)) x
        + (projection (orthogonal_complement (space_as_set C))) x\<close>
       by simp
     hence \<open>x = (projection (orthogonal_complement (space_as_set C))) x
               + (projection (space_as_set C)) x\<close>
       by (metis ordered_field_class.sign_simps(2))
     moreover have \<open>(projection (orthogonal_complement (space_as_set C))) x \<in> space_as_set B\<close>
       using x2
       by (meson closure_subset image_subset_iff that)
     moreover have \<open>(projection (space_as_set C)) x \<in> space_as_set C\<close>
       by (metis mem_Collect_eq orthog_proj_exists projection_eqI space_as_set)
     ultimately show ?thesis
       using closure_subset by fastforce
   qed
   have x1: \<open>x \<in> (space_as_set B +\<^sub>M space_as_set C)\<close>
     if "x \<in> space_as_set A" for x
   proof -
     have f1: "x \<in> closure {a + b |a b. a \<in> space_as_set B \<and> b \<in> space_as_set C}"
       by (simp add: q1 that)
     have "{a + b |a b. a \<in> space_as_set B \<and> b \<in> space_as_set C} = {a. \<exists>p. p \<in> space_as_set B
       \<and> (\<exists>q. q \<in> space_as_set C \<and> a = p + q)}"
       by blast
     hence "x \<in> closure {a. \<exists>b\<in>space_as_set B. \<exists>c\<in>space_as_set C. a = b + c}"
       using f1 by (simp add: Bex_def_raw)
     thus ?thesis
       using that
       unfolding closed_sum_def set_plus_def
       by blast
   qed
 
   hence \<open>x \<in> space_as_set (Abs_clinear_space (space_as_set B +\<^sub>M space_as_set C))\<close>
     if "x \<in> space_as_set A" for x
     using that
     by (metis space_as_set_inverse sup_ccsubspace.rep_eq)
   thus ?thesis
     by (simp add: x1 less_eq_ccsubspace.rep_eq subset_eq sup_ccsubspace.rep_eq)
 qed
 
 lemma is_Proj_idempotent:
   assumes "is_Proj P"
   shows "P o\<^sub>C\<^sub>L P = P"
   using assms
   unfolding is_Proj_def
   using assms is_Proj_algebraic by auto
 
 lemma is_proj_selfadj:
   assumes "is_Proj P"
   shows "P* = P"
   using assms
   unfolding is_Proj_def
   by (metis is_Proj_algebraic is_Proj_def)
 
 lemma is_Proj_I:
   assumes "P o\<^sub>C\<^sub>L P = P" and "P* = P"
   shows "is_Proj P"
   using assms is_Proj_algebraic by metis
 
 lemma is_Proj_0[simp]: "is_Proj 0"
   by (metis add_left_cancel adj_plus bounded_cbilinear.zero_left bounded_cbilinear_cblinfun_compose group_cancel.rule0 is_Proj_I)
 
 lemma is_Proj_complement[simp]:
   assumes a1: "is_Proj P"
   shows "is_Proj (id_cblinfun-P)"
   by (smt (z3) add_diff_cancel_left add_diff_cancel_left' adj_cblinfun_compose adj_plus assms bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose diff_add_cancel id_cblinfun_adjoint is_Proj_algebraic cblinfun_compose_id_left)
 
 lemma Proj_bot[simp]: "Proj bot = 0"
   by (metis zero_cblinfun_image Proj_on_own_range' is_Proj_0 is_Proj_algebraic
       zero_ccsubspace_def)
 
 lemma Proj_ortho_compl:
   "Proj (- X) = id_cblinfun - Proj X"
   by (transfer , auto)
 
 lemma Proj_inj:
   assumes "Proj X = Proj Y"
   shows "X = Y"
   by (metis assms Proj_range)
 
 lemma norm_Proj_leq1: \<open>norm (Proj M) \<le> 1\<close>
   apply transfer
   by (metis (no_types, opaque_lifting) mult.left_neutral onorm_bound projection_reduces_norm zero_less_one_class.zero_le_one)
 
 lemma Proj_orthog_ccspan_insert:
   assumes "\<And>y. y \<in> Y \<Longrightarrow> is_orthogonal x y"
   shows \<open>Proj (ccspan (insert x Y)) = proj x + Proj (ccspan Y)\<close>
   apply (subst asm_rl[of \<open>insert x Y = {x} \<union> Y\<close>], simp)
   apply (rule Proj_orthog_ccspan_union)
   using assms by auto
 
 lemma cancel_apply_Proj:
   assumes \<open>\<psi> \<in> space_as_set S\<close>
   shows \<open>Proj S *\<^sub>V \<psi> = \<psi>\<close>
   by (metis Proj_idempotent Proj_range assms cblinfun_fixes_range)
 
 lemma Proj_fixes_image: \<open>Proj S *\<^sub>V \<psi> = \<psi>\<close> if \<open>\<psi> \<in> space_as_set S\<close>
   by (simp add: Proj.rep_eq closed_csubspace_def projection_fixes_image that)
 
 lemma norm_is_Proj: \<open>norm P \<le> 1\<close> if \<open>is_Proj P\<close>
   by (metis Proj_on_own_range norm_Proj_leq1 that)
 
+lemma Proj_sup: \<open>orthogonal_spaces S T \<Longrightarrow> Proj (sup S T) = Proj S + Proj T\<close>
+  unfolding orthogonal_spaces_def
+  apply transfer
+  by (simp add: projection_plus)
+
+lemma Proj_sum_spaces:
+  assumes \<open>finite X\<close>
+  assumes \<open>\<And>x y. x\<in>X \<Longrightarrow> y\<in>X \<Longrightarrow> x\<noteq>y \<Longrightarrow> orthogonal_spaces (J x) (J y)\<close>
+  shows \<open>Proj (\<Sum>x\<in>X. J x) = (\<Sum>x\<in>X. Proj (J x))\<close>
+  using assms
+proof induction
+  case empty
+  show ?case 
+    by auto
+next
+  case (insert x F)
+  have \<open>Proj (sum J (insert x F)) = Proj (J x \<squnion> sum J F)\<close>
+    by (simp add: insert)
+  also have \<open>\<dots> = Proj (J x) + Proj (sum J F)\<close>
+    apply (rule Proj_sup)
+    apply (rule orthogonal_sum)
+    using insert by auto
+  also have \<open>\<dots> = (\<Sum>x\<in>insert x F. Proj (J x))\<close>
+    by (simp add: insert.IH insert.hyps(1) insert.hyps(2) insert.prems)
+  finally show ?case
+    by -
+qed
+
+lemma is_Proj_reduces_norm:
+  assumes \<open>is_Proj P\<close>
+  shows \<open>norm (P *\<^sub>V \<psi>) \<le> norm \<psi>\<close>
+  using assms apply transfer
+  using is_projection_on_reduces_norm by blast
+
+lemma norm_Proj_apply: \<open>norm (Proj T *\<^sub>V \<psi>) = norm \<psi> \<longleftrightarrow> \<psi> \<in> space_as_set T\<close>
+proof (rule iffI)
+  show \<open>norm (Proj T *\<^sub>V \<psi>) = norm \<psi>\<close> if \<open>\<psi> \<in> space_as_set T\<close>
+    by (simp add: cancel_apply_Proj that)
+  assume assm: \<open>norm (Proj T *\<^sub>V \<psi>) = norm \<psi>\<close>
+  have \<psi>_decomp: \<open>\<psi> = Proj T \<psi> + Proj (-T) \<psi>\<close>
+    by (simp add: Proj_ortho_compl cblinfun.real.diff_left)
+  have \<open>(norm (Proj (-T) \<psi>))\<^sup>2 = (norm (Proj T \<psi>))\<^sup>2 + (norm (Proj (-T) \<psi>))\<^sup>2 - (norm (Proj T \<psi>))\<^sup>2\<close>
+    by auto
+  also have \<open>\<dots> = (norm (Proj T \<psi> + Proj (-T) \<psi>))\<^sup>2 - (norm (Proj T \<psi>))\<^sup>2\<close>
+    apply (subst pythagorean_theorem)
+     apply (metis (no_types, lifting) Proj_idempotent \<psi>_decomp add_cancel_right_left adj_Proj cblinfun.real.add_right cblinfun_apply_cblinfun_compose cinner_adj_left cinner_zero_left)
+    by simp
+  also with \<psi>_decomp have \<open>\<dots> = (norm \<psi>)\<^sup>2 - (norm (Proj T \<psi>))\<^sup>2\<close>
+    by metis
+  also with assm have \<open>\<dots> = 0\<close>
+    by simp
+  finally have \<open>norm (Proj (-T) \<psi>) = 0\<close>
+    by auto
+  with \<psi>_decomp have \<open>\<psi> = Proj T \<psi>\<close>
+    by auto
+  then show \<open>\<psi> \<in> space_as_set T\<close>
+    by (metis Proj_range cblinfun_apply_in_image)
+qed
+
+lemma norm_Proj_apply_1: \<open>norm \<psi> = 1 \<Longrightarrow> norm (Proj T *\<^sub>V \<psi>) = 1 \<longleftrightarrow> \<psi> \<in> space_as_set T\<close>
+  using norm_Proj_apply by metis
+
 subsection \<open>Kernel\<close>
 
 lift_definition kernel :: "'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L'b::complex_normed_vector
    \<Rightarrow> 'a ccsubspace"
   is "\<lambda> f. f -` {0}"
   by (metis kernel_is_closed_csubspace)
 
 definition eigenspace :: "complex \<Rightarrow> 'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L'a \<Rightarrow> 'a ccsubspace" where
   "eigenspace a A = kernel (A - a *\<^sub>C id_cblinfun)"
 
 lemma kernel_scaleC[simp]: "a\<noteq>0 \<Longrightarrow> kernel (a *\<^sub>C A) = kernel A"
   for a :: complex and A :: "(_,_) cblinfun"
   apply transfer
   using complex_vector.scale_eq_0_iff by blast
 
 lemma kernel_0[simp]: "kernel 0 = top"
   apply transfer by auto
 
 lemma kernel_id[simp]: "kernel id_cblinfun = 0"
   apply transfer by simp
 
 lemma eigenspace_scaleC[simp]:
   assumes a1: "a \<noteq> 0"
   shows "eigenspace b (a *\<^sub>C A) = eigenspace (b/a) A"
 proof -
   have "b *\<^sub>C (id_cblinfun::('a, _) cblinfun) = a *\<^sub>C (b / a) *\<^sub>C id_cblinfun"
     using a1
     by (metis ceq_vector_fraction_iff)
   hence "kernel (a *\<^sub>C A - b *\<^sub>C id_cblinfun) = kernel (A - (b / a) *\<^sub>C id_cblinfun)"
     using a1 by (metis (no_types) complex_vector.scale_right_diff_distrib kernel_scaleC)
   thus ?thesis
     unfolding eigenspace_def
     by blast
 qed
 
 lemma eigenspace_memberD:
   assumes "x \<in> space_as_set (eigenspace e A)"
   shows "A *\<^sub>V x = e *\<^sub>C x"
   using assms unfolding eigenspace_def apply transfer by auto
 
 lemma kernel_memberD:
   assumes "x \<in> space_as_set (kernel A)"
   shows "A *\<^sub>V x = 0"
   using assms apply transfer by auto
 
 lemma eigenspace_memberI:
   assumes "A *\<^sub>V x = e *\<^sub>C x"
   shows "x \<in> space_as_set (eigenspace e A)"
   using assms unfolding eigenspace_def apply transfer by auto
 
 lemma kernel_memberI:
   assumes "A *\<^sub>V x = 0"
   shows "x \<in> space_as_set (kernel A)"
   using assms apply transfer by auto
 
 lemma kernel_Proj[simp]: \<open>kernel (Proj S) = - S\<close>
   apply transfer
   apply auto
   apply (metis diff_0_right is_projection_on_iff_orthog projection_is_projection_on')
   by (simp add: complex_vector.subspace_0 projection_eqI)
 
 lemma orthogonal_projectors_orthogonal_spaces:
   \<comment> \<open>Logically belongs in section "Projectors".\<close>
   fixes S T :: \<open>'a::chilbert_space set\<close>
   shows \<open>(\<forall>x\<in>S. \<forall>y\<in>T. is_orthogonal x y) \<longleftrightarrow> Proj (ccspan S) o\<^sub>C\<^sub>L Proj (ccspan T) = 0\<close>
 proof (intro ballI iffI)
   fix x y assume \<open>Proj (ccspan S) o\<^sub>C\<^sub>L Proj (ccspan T) = 0\<close> \<open>x \<in> S\<close> \<open>y \<in> T\<close>
   then show \<open>is_orthogonal x y\<close>
     by (smt (verit, del_insts) Proj_idempotent Proj_range adj_Proj cblinfun.zero_left cblinfun_apply_cblinfun_compose cblinfun_fixes_range ccspan_superset cinner_adj_right cinner_zero_right in_mono)
 next 
   assume \<open>\<forall>x\<in>S. \<forall>y\<in>T. is_orthogonal x y\<close>
   then have \<open>ccspan S \<le> - ccspan T\<close>
     by (simp add: ccspan_leq_ortho_ccspan)
   then show \<open>Proj (ccspan S) o\<^sub>C\<^sub>L Proj (ccspan T) = 0\<close>
     by (metis (no_types, opaque_lifting) Proj_range adj_Proj adj_cblinfun_compose basic_trans_rules(31) cblinfun.zero_left cblinfun_apply_cblinfun_compose cblinfun_apply_in_image cblinfun_eqI kernel_Proj kernel_memberD less_eq_ccsubspace.rep_eq)
 qed
 
 lemma cblinfun_compose_Proj_kernel[simp]: \<open>a o\<^sub>C\<^sub>L Proj (kernel a) = 0\<close>
   apply (rule cblinfun_eqI)
   apply simp
   by (metis Proj_range cblinfun_apply_in_image kernel_memberD)
 
 lemma kernel_compl_adj_range:
   shows \<open>kernel a = - (a* *\<^sub>S top)\<close>
 proof (rule ccsubspace_eqI)
   fix x
   have \<open>x \<in> space_as_set (kernel a) \<longleftrightarrow> a x = 0\<close>
     apply transfer by simp
   also have \<open>a x = 0 \<longleftrightarrow> (\<forall>y. is_orthogonal y (a x))\<close>
     by (metis cinner_gt_zero_iff cinner_zero_right)
   also have \<open>\<dots> \<longleftrightarrow> (\<forall>y. is_orthogonal (a* *\<^sub>V y) x)\<close>
     by (simp add: cinner_adj_left)
   also have \<open>\<dots> \<longleftrightarrow> x \<in> space_as_set (- (a* *\<^sub>S top))\<close>
     apply transfer
     by (metis (mono_tags, opaque_lifting) UNIV_I image_iff is_orthogonal_sym orthogonal_complementI orthogonal_complement_of_closure orthogonal_complement_orthoI')
   finally show \<open>x \<in> space_as_set (kernel a) \<longleftrightarrow> x \<in> space_as_set (- (a* *\<^sub>S top))\<close>
     by -
 qed
 
 
 subsection \<open>Partial isometries\<close>
 
 definition partial_isometry where
   \<open>partial_isometry A \<longleftrightarrow> (\<forall>h \<in> space_as_set (- kernel A). norm (A h) = norm h)\<close>
 
 lemma partial_isometryI: 
   assumes \<open>\<And>h. h \<in> space_as_set (- kernel A) \<Longrightarrow> norm (A h) = norm h\<close>
   shows \<open>partial_isometry A\<close>
   using assms partial_isometry_def by blast
 
 
 lemma
   fixes A :: \<open>'a :: chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b :: complex_normed_vector\<close>
   assumes iso: \<open>\<And>\<psi>. \<psi> \<in> space_as_set V \<Longrightarrow> norm (A *\<^sub>V \<psi>) = norm \<psi>\<close>
   assumes zero: \<open>\<And>\<psi>. \<psi> \<in> space_as_set (- V) \<Longrightarrow> A *\<^sub>V \<psi> = 0\<close>
   shows partial_isometryI': \<open>partial_isometry A\<close>
     and partial_isometry_initial: \<open>kernel A = - V\<close>
 proof -
   from zero
   have \<open>- V \<le> kernel A\<close>
     by (simp add: kernel_memberI less_eq_ccsubspace.rep_eq subsetI)
   moreover have \<open>kernel A \<le> -V\<close>
     by (smt (verit, ccfv_threshold) Proj_ortho_compl Proj_range assms(1) cblinfun.diff_left cblinfun.diff_right cblinfun_apply_in_image cblinfun_id_cblinfun_apply ccsubspace_leI kernel_Proj kernel_memberD kernel_memberI norm_eq_zero ortho_involution subsetI zero)
   ultimately show kerA: \<open>kernel A = -V\<close>
     by simp
 
   show \<open>partial_isometry A\<close>
     apply (rule partial_isometryI)
     by (simp add: kerA iso)
 qed
 
 lemma Proj_partial_isometry: \<open>partial_isometry (Proj S)\<close>
   apply (rule partial_isometryI)
   by (simp add: cancel_apply_Proj)
 
 lemma is_Proj_partial_isometry: \<open>is_Proj P \<Longrightarrow> partial_isometry P\<close>
   by (metis Proj_on_own_range Proj_partial_isometry)
 
 lemma isometry_partial_isometry: \<open>isometry P \<Longrightarrow> partial_isometry P\<close>
   by (simp add: isometry_preserves_norm partial_isometry_def)
 
 lemma unitary_partial_isometry: \<open>unitary P \<Longrightarrow> partial_isometry P\<close>
   using isometry_partial_isometry unitary_isometry by blast
 
 lemma norm_partial_isometry:
   fixes A :: \<open>'a :: chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector\<close>
   assumes \<open>partial_isometry A\<close> and \<open>A \<noteq> 0\<close>
   shows \<open>norm A = 1\<close> 
 proof -
   from \<open>A \<noteq> 0\<close>
   have \<open>- (kernel A) \<noteq> 0\<close>
     by (metis cblinfun_eqI diff_zero id_cblinfun_apply kernel_id kernel_memberD ortho_involution orthog_proj_exists orthogonal_complement_closed_subspace uminus_ccsubspace.rep_eq zero_cblinfun.rep_eq)
   then obtain h where \<open>h \<in> space_as_set (- kernel A)\<close> and \<open>h \<noteq> 0\<close>
     by (metis cblinfun_id_cblinfun_apply ccsubspace_eqI closed_csubspace.subspace complex_vector.subspace_0 kernel_id kernel_memberD kernel_memberI orthogonal_complement_closed_subspace uminus_ccsubspace.rep_eq)
   with \<open>partial_isometry A\<close>
   have \<open>norm (A h) = norm h\<close>
     using partial_isometry_def by blast
   then have \<open>norm A \<ge> 1\<close>
     by (smt (verit) \<open>h \<noteq> 0\<close> mult_cancel_right1 mult_left_le_one_le norm_cblinfun norm_eq_zero norm_ge_zero)
 
   have \<open>norm A \<le> 1\<close>
   proof (rule norm_cblinfun_bound)
     show \<open>0 \<le> (1::real)\<close>
       by simp
     fix \<psi> :: 'a
     define g h where \<open>g = Proj (kernel A) \<psi>\<close> and \<open>h = Proj (- kernel A) \<psi>\<close>
     have \<open>A g = 0\<close>
       by (metis Proj_range cblinfun_apply_in_image g_def kernel_memberD)
     moreover from \<open>partial_isometry A\<close>
     have \<open>norm (A h) = norm h\<close>
       by (metis Proj_range cblinfun_apply_in_image h_def partial_isometry_def)
     ultimately have \<open>norm (A \<psi>) = norm h\<close>
       by (simp add: Proj_ortho_compl cblinfun.diff_left cblinfun.diff_right g_def h_def)
     also have \<open>norm h \<le> norm \<psi>\<close>
       by (smt (verit, del_insts) h_def mult_left_le_one_le norm_Proj_leq1 norm_cblinfun norm_ge_zero)
     finally show \<open>norm (A *\<^sub>V \<psi>) \<le> 1 * norm \<psi>\<close>
       by simp
   qed
 
   from \<open>norm A \<le> 1\<close> and \<open>norm A \<ge> 1\<close>
   show \<open>norm A = 1\<close>
     by auto
 qed
 
 lemma partial_isometry_adj_a_o_a:
   assumes \<open>partial_isometry a\<close>
   shows \<open>a* o\<^sub>C\<^sub>L a = Proj (- kernel a)\<close>
 proof (rule cblinfun_cinner_eqI)
   define P where \<open>P = Proj (- kernel a)\<close>
   have aP: \<open>a o\<^sub>C\<^sub>L P = a\<close>
     by (auto intro!: simp: cblinfun_compose_minus_right P_def Proj_ortho_compl)
   have is_Proj_P[simp]: \<open>is_Proj P\<close>
     by (simp add: P_def)
 
   fix \<psi> :: 'a
   have \<open>\<psi> \<bullet>\<^sub>C ((a* o\<^sub>C\<^sub>L a) *\<^sub>V \<psi>) = a \<psi> \<bullet>\<^sub>C a \<psi>\<close>
     by (simp add: cinner_adj_right)
   also have \<open>\<dots> = a (P \<psi>) \<bullet>\<^sub>C a (P \<psi>)\<close>
     by (metis aP cblinfun_apply_cblinfun_compose)
   also have \<open>\<dots> = P \<psi> \<bullet>\<^sub>C P \<psi>\<close>
     by (metis P_def Proj_range assms cblinfun_apply_in_image cdot_square_norm partial_isometry_def)
   also have \<open>\<dots> = \<psi> \<bullet>\<^sub>C P \<psi>\<close>
     by (simp flip: cinner_adj_right add: is_proj_selfadj is_Proj_idempotent[THEN simp_a_oCL_b'])
   finally show \<open>\<psi> \<bullet>\<^sub>C ((a* o\<^sub>C\<^sub>L a) *\<^sub>V \<psi>) = \<psi> \<bullet>\<^sub>C P \<psi>\<close>
     by -
 qed
 
 lemma partial_isometry_square_proj: \<open>is_Proj (a* o\<^sub>C\<^sub>L a)\<close> if \<open>partial_isometry a\<close>
   by (simp add: partial_isometry_adj_a_o_a that)
 
 lemma partial_isometry_adj[simp]: \<open>partial_isometry (a*)\<close> if \<open>partial_isometry a\<close>
   for a :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::chilbert_space\<close>
 proof -
   have ran_ker: \<open>a *\<^sub>S top = - kernel (a*)\<close>
     by (simp add: kernel_compl_adj_range)
 
   have \<open>norm (a* *\<^sub>V h) = norm h\<close> if \<open>h \<in> range a\<close> for h
   proof -
     from that obtain x where h: \<open>h = a x\<close>
       by auto
     have \<open>norm (a* *\<^sub>V h) = norm (a* *\<^sub>V a *\<^sub>V x)\<close>
       by (simp add: h)
     also have \<open>\<dots> = norm (Proj (- kernel a) *\<^sub>V x)\<close>
       by (simp add: \<open>partial_isometry a\<close> partial_isometry_adj_a_o_a simp_a_oCL_b')
     also have \<open>\<dots> = norm (a *\<^sub>V Proj (- kernel a) *\<^sub>V x)\<close>
       by (metis Proj_range \<open>partial_isometry a\<close> cblinfun_apply_in_image partial_isometry_def)
     also have \<open>\<dots> = norm (a *\<^sub>V x)\<close>
       by (smt (verit, best) Proj_idempotent \<open>partial_isometry a\<close> adj_Proj cblinfun_apply_cblinfun_compose cinner_adj_right cnorm_eq partial_isometry_adj_a_o_a)
     also have \<open>\<dots> = norm h\<close>
       using h by auto
     finally show ?thesis
       by -
   qed
 
   then have norm_pres: \<open>norm (a* *\<^sub>V h) = norm h\<close> if \<open>h \<in> closure (range a)\<close> for h
     using that apply (rule on_closure_eqI)
       apply assumption
     by (intro continuous_intros)+
 
   show ?thesis
     apply (rule partial_isometryI)
     by (auto simp: cblinfun_image.rep_eq norm_pres simp flip: ran_ker)
 qed
 
 subsection \<open>Isomorphisms and inverses\<close>
 
 definition iso_cblinfun :: \<open>('a::complex_normed_vector, 'b::complex_normed_vector) cblinfun \<Rightarrow> bool\<close> where
   \<open>iso_cblinfun A = (\<exists> B. A o\<^sub>C\<^sub>L B = id_cblinfun \<and> B o\<^sub>C\<^sub>L A = id_cblinfun)\<close>
 
 definition cblinfun_inv :: \<open>('a::complex_normed_vector, 'b::complex_normed_vector) cblinfun \<Rightarrow> ('b,'a) cblinfun\<close> where
   \<open>cblinfun_inv A = (SOME B. B o\<^sub>C\<^sub>L A = id_cblinfun)\<close>
 
 lemma
   assumes \<open>iso_cblinfun A\<close>
   shows cblinfun_inv_left: \<open>cblinfun_inv A o\<^sub>C\<^sub>L A = id_cblinfun\<close>
     and cblinfun_inv_right: \<open>A o\<^sub>C\<^sub>L cblinfun_inv A = id_cblinfun\<close>
 proof -
   from assms
   obtain B where AB: \<open>A o\<^sub>C\<^sub>L B = id_cblinfun\<close> and BA: \<open>B o\<^sub>C\<^sub>L A = id_cblinfun\<close>
     using iso_cblinfun_def by blast
   from BA have \<open>cblinfun_inv A o\<^sub>C\<^sub>L A = id_cblinfun\<close>
     by (metis (mono_tags, lifting) cblinfun_inv_def someI_ex)
   with AB BA have \<open>cblinfun_inv A = B\<close>
     by (metis cblinfun_assoc_left(1) cblinfun_compose_id_right)
   with AB BA show \<open>cblinfun_inv A o\<^sub>C\<^sub>L A = id_cblinfun\<close>
     and \<open>A o\<^sub>C\<^sub>L cblinfun_inv A = id_cblinfun\<close>
     by auto
 qed
 
 
 lemma cblinfun_inv_uniq:
   assumes "A o\<^sub>C\<^sub>L B = id_cblinfun" and "B o\<^sub>C\<^sub>L A = id_cblinfun"
   shows "cblinfun_inv A = B"
   using assms by (metis cblinfun_compose_assoc cblinfun_compose_id_right cblinfun_inv_left iso_cblinfun_def)
 
 subsection \<open>One-dimensional spaces\<close>
 
 
 instantiation cblinfun :: (one_dim, one_dim) complex_inner begin
 text \<open>Once we have a theory for the trace, we could instead define the Hilbert-Schmidt inner product
   and relax the \<^class>\<open>one_dim\<close>-sort constraint to (\<^class>\<open>cfinite_dim\<close>,\<^class>\<open>complex_normed_vector\<close>) or similar\<close>
 definition "cinner_cblinfun (A::'a \<Rightarrow>\<^sub>C\<^sub>L 'b) (B::'a \<Rightarrow>\<^sub>C\<^sub>L 'b)
              = cnj (one_dim_iso (A *\<^sub>V 1)) * one_dim_iso (B *\<^sub>V 1)"
 instance
 proof intro_classes
   fix A B C :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
     and c c' :: complex
   show "\<langle>A, B\<rangle> = cnj \<langle>B, A\<rangle>"
     unfolding cinner_cblinfun_def by auto
   show "\<langle>A + B, C\<rangle> = \<langle>A, C\<rangle> + \<langle>B, C\<rangle>"
     by (simp add: cinner_cblinfun_def algebra_simps plus_cblinfun.rep_eq)
   show "\<langle>c *\<^sub>C A, B\<rangle> = cnj c * \<langle>A, B\<rangle>"
     by (simp add: cblinfun.scaleC_left cinner_cblinfun_def)
   show "0 \<le> \<langle>A, A\<rangle>"
     unfolding cinner_cblinfun_def by auto
   have "bounded_clinear A \<Longrightarrow> A 1 = 0 \<Longrightarrow> A = (\<lambda>_. 0)"
     for A::"'a \<Rightarrow> 'b"
   proof (rule one_dim_clinear_eqI [where x = 1] , auto)
     show "clinear A"
       if "bounded_clinear A"
         and "A 1 = 0"
       for A :: "'a \<Rightarrow> 'b"
       using that
       by (simp add: bounded_clinear.clinear)
     show "clinear ((\<lambda>_. 0)::'a \<Rightarrow> 'b)"
       if "bounded_clinear A"
         and "A 1 = 0"
       for A :: "'a \<Rightarrow> 'b"
       using that
       by (simp add: complex_vector.module_hom_zero)
   qed
   hence "A *\<^sub>V 1 = 0 \<Longrightarrow> A = 0"
     by transfer
   hence "one_dim_iso (A *\<^sub>V 1) = 0 \<Longrightarrow> A = 0"
     by (metis one_dim_iso_of_zero one_dim_iso_inj)
   thus "(\<langle>A, A\<rangle> = 0) = (A = 0)"
     by (auto simp: cinner_cblinfun_def)
 
   show "norm A = sqrt (cmod \<langle>A, A\<rangle>)"
     unfolding cinner_cblinfun_def
     apply transfer
     by (simp add: norm_mult abs_complex_def one_dim_onorm' cnj_x_x power2_eq_square bounded_clinear.clinear)
 qed
 end
 
 instantiation cblinfun :: (one_dim, one_dim) one_dim begin
 lift_definition one_cblinfun :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b" is "one_dim_iso"
   by (rule bounded_clinear_one_dim_iso)
 lift_definition times_cblinfun :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
   is "\<lambda>f g. f o one_dim_iso o g"
   by (simp add: comp_bounded_clinear)
 lift_definition inverse_cblinfun :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'b" is
   "\<lambda>f. ((*) (one_dim_iso (inverse (f 1)))) o one_dim_iso"
   by (auto intro!: comp_bounded_clinear bounded_clinear_mult_right)
 definition divide_cblinfun :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'b \<Rightarrow> 'a \<Rightarrow>\<^sub>C\<^sub>L 'b" where
   "divide_cblinfun A B = A * inverse B"
 definition "canonical_basis_cblinfun = [1 :: 'a \<Rightarrow>\<^sub>C\<^sub>L 'b]"
 instance
 proof intro_classes
   let ?basis = "canonical_basis :: ('a \<Rightarrow>\<^sub>C\<^sub>L 'b) list"
   fix A B C :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
     and c c' :: complex
   show "distinct ?basis"
     unfolding canonical_basis_cblinfun_def by simp
   have "(1::'a \<Rightarrow>\<^sub>C\<^sub>L 'b) \<noteq> (0::'a \<Rightarrow>\<^sub>C\<^sub>L 'b)"
     by (metis cblinfun.zero_left one_cblinfun.rep_eq one_dim_iso_of_one zero_neq_one)
   thus "cindependent (set ?basis)"
     unfolding canonical_basis_cblinfun_def by simp
 
   have "A \<in> cspan (set ?basis)" for A
   proof -
     define c :: complex where "c = one_dim_iso (A *\<^sub>V 1)"
     have "A x = one_dim_iso (A 1) *\<^sub>C one_dim_iso x" for x
       by (smt (z3) cblinfun.scaleC_right complex_vector.scale_left_commute one_dim_iso_idem one_dim_scaleC_1)
     hence "A = one_dim_iso (A *\<^sub>V 1) *\<^sub>C 1"
       apply transfer by metis
     thus "A \<in> cspan (set ?basis)"
       unfolding canonical_basis_cblinfun_def
       by (smt complex_vector.span_base complex_vector.span_scale list.set_intros(1))
   qed
   thus "cspan (set ?basis) = UNIV" by auto
 
   have "A = (1::'a \<Rightarrow>\<^sub>C\<^sub>L 'b) \<Longrightarrow>
     norm (1::'a \<Rightarrow>\<^sub>C\<^sub>L 'b) = (1::real)"
     apply transfer by simp
   thus "A \<in> set ?basis \<Longrightarrow> norm A = 1"
     unfolding canonical_basis_cblinfun_def
     by simp
 
   show "?basis = [1]"
     unfolding canonical_basis_cblinfun_def by simp
   show "c *\<^sub>C 1 * c' *\<^sub>C 1 = (c * c') *\<^sub>C (1::'a\<Rightarrow>\<^sub>C\<^sub>L'b)"
     apply transfer by auto
   have "(1::'a \<Rightarrow>\<^sub>C\<^sub>L 'b) = (0::'a \<Rightarrow>\<^sub>C\<^sub>L 'b) \<Longrightarrow> False"
     by (metis cblinfun.zero_left one_cblinfun.rep_eq one_dim_iso_of_zero' zero_neq_neg_one)
   thus "is_ortho_set (set ?basis)"
     unfolding is_ortho_set_def canonical_basis_cblinfun_def by auto
   show "A div B = A * inverse B"
     by (simp add: divide_cblinfun_def)
   show "inverse (c *\<^sub>C 1) = (1::'a\<Rightarrow>\<^sub>C\<^sub>L'b) /\<^sub>C c"
     apply transfer by (simp add: o_def one_dim_inverse)
 qed
 end
 
 lemma id_cblinfun_eq_1[simp]: \<open>id_cblinfun = 1\<close>
   apply transfer by auto
 
 lemma one_dim_apply_is_times[simp]:
   fixes A :: "'a::one_dim \<Rightarrow>\<^sub>C\<^sub>L 'a" and B :: "'a \<Rightarrow>\<^sub>C\<^sub>L 'a"
   shows "A o\<^sub>C\<^sub>L B = A * B"
   apply transfer by simp
 
 lemma one_comp_one_cblinfun[simp]: "1 o\<^sub>C\<^sub>L 1 = 1"
   apply transfer unfolding o_def by simp
 
 lemma one_cblinfun_adj[simp]: "1* = 1"
   apply transfer by simp
 
 
 lemma scaleC_1_right[simp]: \<open>scaleC x (1::'a::one_dim) = of_complex x\<close>
   unfolding of_complex_def by simp
 
 lemma scaleC_of_complex[simp]: \<open>scaleC x (of_complex y) = of_complex (x * y)\<close>
   unfolding of_complex_def using scaleC_scaleC by blast
 
 lemma scaleC_1_apply[simp]: \<open>(x *\<^sub>C 1) *\<^sub>V y = x *\<^sub>C y\<close>
   by (metis cblinfun.scaleC_left cblinfun_id_cblinfun_apply id_cblinfun_eq_1)
 
 lemma cblinfun_apply_1_left[simp]: \<open>1 *\<^sub>V y = y\<close>
   by (metis cblinfun_id_cblinfun_apply id_cblinfun_eq_1)
 
 lemma of_complex_cblinfun_apply[simp]: \<open>of_complex x *\<^sub>V y = x *\<^sub>C y\<close>
   unfolding of_complex_def
   by (metis cblinfun.scaleC_left cblinfun_id_cblinfun_apply id_cblinfun_eq_1)
 
 lemma cblinfun_compose_1_left[simp]: \<open>1 o\<^sub>C\<^sub>L x = x\<close>
   apply transfer by auto
 
 lemma cblinfun_compose_1_right[simp]: \<open>x o\<^sub>C\<^sub>L 1 = x\<close>
   apply transfer by auto
 
 lemma one_dim_iso_id_cblinfun: \<open>one_dim_iso id_cblinfun = id_cblinfun\<close>
   by simp
 
 lemma one_dim_iso_id_cblinfun_eq_1: \<open>one_dim_iso id_cblinfun = 1\<close>
   by simp
 
 lemma one_dim_iso_comp_distr[simp]: \<open>one_dim_iso (a o\<^sub>C\<^sub>L b) = one_dim_iso a o\<^sub>C\<^sub>L one_dim_iso b\<close>
   by (smt (z3) cblinfun_compose_scaleC_left cblinfun_compose_scaleC_right one_cinner_a_scaleC_one one_comp_one_cblinfun one_dim_iso_of_one one_dim_iso_scaleC)
 
 lemma one_dim_iso_comp_distr_times[simp]: \<open>one_dim_iso (a o\<^sub>C\<^sub>L b) = one_dim_iso a * one_dim_iso b\<close>
   by (smt (verit, del_insts) mult.left_neutral mult_scaleC_left one_cinner_a_scaleC_one one_comp_one_cblinfun one_dim_iso_of_one one_dim_iso_scaleC cblinfun_compose_scaleC_right cblinfun_compose_scaleC_left)
 
 lemma one_dim_iso_adjoint[simp]: \<open>one_dim_iso (A*) = (one_dim_iso A)*\<close>
   by (smt (z3) one_cblinfun_adj one_cinner_a_scaleC_one one_dim_iso_of_one one_dim_iso_scaleC scaleC_adj)
 
 lemma one_dim_iso_adjoint_complex[simp]: \<open>one_dim_iso (A*) = cnj (one_dim_iso A)\<close>
   by (metis (mono_tags, lifting) one_cblinfun_adj one_dim_iso_idem one_dim_scaleC_1 scaleC_adj)
 
 lemma one_dim_cblinfun_compose_commute: \<open>a o\<^sub>C\<^sub>L b = b o\<^sub>C\<^sub>L a\<close> for a b :: \<open>('a::one_dim,'a) cblinfun\<close>
   by (simp add: one_dim_iso_inj)
 
 lemma one_cblinfun_apply_one[simp]: \<open>1 *\<^sub>V 1 = 1\<close>
   by (simp add: one_cblinfun.rep_eq)
 
 lemma ccspan_one_dim[simp]: \<open>ccspan {x} = top\<close> if \<open>x \<noteq> 0\<close> for x :: \<open>_ :: one_dim\<close>
 proof -
   have \<open>y \<in> cspan {x}\<close> for y
     using that by (metis complex_vector.span_base complex_vector.span_zero cspan_singleton_scaleC insertI1 one_dim_scaleC_1 scaleC_zero_left)
   then show ?thesis
     by (auto intro!: order.antisym ccsubspace_leI
       simp: top_ccsubspace.rep_eq ccspan.rep_eq)
 qed
 
 lemma is_onb_one_dim[simp]: \<open>norm x = 1 \<Longrightarrow> is_onb {x}\<close> for x :: \<open>_ :: one_dim\<close>
   by (auto simp: is_onb_def intro!: ccspan_one_dim)
 
 lemma one_dim_iso_cblinfun_comp: \<open>one_dim_iso (a o\<^sub>C\<^sub>L b) = of_complex (cinner (a* *\<^sub>V 1) (b *\<^sub>V 1))\<close>
   for a :: \<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L 'b::one_dim\<close> and b :: \<open>'c::one_dim \<Rightarrow>\<^sub>C\<^sub>L 'a\<close>
   by (simp add: cinner_adj_left cinner_cblinfun_def one_dim_iso_def)
 
 subsection \<open>Loewner order\<close>
 
 lift_definition heterogenous_cblinfun_id :: \<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector\<close>
   is \<open>if bounded_clinear (heterogenous_identity :: 'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector) then heterogenous_identity else (\<lambda>_. 0)\<close>
   by auto
 
 lemma heterogenous_cblinfun_id_def'[simp]: "heterogenous_cblinfun_id = id_cblinfun"
   apply transfer by auto
 
 definition "heterogenous_same_type_cblinfun (x::'a::chilbert_space itself) (y::'b::chilbert_space itself) \<longleftrightarrow>
   unitary (heterogenous_cblinfun_id :: 'a \<Rightarrow>\<^sub>C\<^sub>L 'b) \<and> unitary (heterogenous_cblinfun_id :: 'b \<Rightarrow>\<^sub>C\<^sub>L 'a)"
 
 lemma heterogenous_same_type_cblinfun[simp]: \<open>heterogenous_same_type_cblinfun (x::'a::chilbert_space itself) (y::'a::chilbert_space itself)\<close>
   unfolding heterogenous_same_type_cblinfun_def by auto
 
 instantiation cblinfun :: (chilbert_space, chilbert_space) ord begin
 definition less_eq_cblinfun :: \<open>('a \<Rightarrow>\<^sub>C\<^sub>L 'b) \<Rightarrow> ('a \<Rightarrow>\<^sub>C\<^sub>L 'b) \<Rightarrow> bool\<close>
   where less_eq_cblinfun_def_heterogenous: \<open>less_eq_cblinfun A B =
   (if heterogenous_same_type_cblinfun TYPE('a) TYPE('b) then
     \<forall>\<psi>::'b. cinner \<psi> ((B-A) *\<^sub>V heterogenous_cblinfun_id *\<^sub>V \<psi>) \<ge> 0 else (A=B))\<close>
 definition \<open>less_cblinfun (A :: 'a \<Rightarrow>\<^sub>C\<^sub>L 'b) B \<longleftrightarrow> A \<le> B \<and> \<not> B \<le> A\<close>
 instance..
 end
 
 lemma less_eq_cblinfun_def: \<open>A \<le> B \<longleftrightarrow>
     (\<forall>\<psi>. cinner \<psi> (A *\<^sub>V \<psi>) \<le> cinner \<psi> (B *\<^sub>V \<psi>))\<close>
   unfolding less_eq_cblinfun_def_heterogenous
   by (auto simp del: less_eq_complex_def simp: cblinfun.diff_left cinner_diff_right)
 
 instantiation cblinfun :: (chilbert_space, chilbert_space) ordered_complex_vector begin
 instance
 proof intro_classes
   note less_eq_complex_def[simp del]
 
   fix x y z :: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L 'b\<close>
   fix a b :: complex
 
   define pos where \<open>pos X \<longleftrightarrow> (\<forall>\<psi>. cinner \<psi> (X *\<^sub>V \<psi>) \<ge> 0)\<close> for X :: \<open>'b \<Rightarrow>\<^sub>C\<^sub>L 'b\<close>
   consider (unitary) \<open>heterogenous_same_type_cblinfun TYPE('a) TYPE('b)\<close>
       \<open>\<And>A B :: 'a \<Rightarrow>\<^sub>C\<^sub>L 'b. A \<le> B = pos ((B-A) o\<^sub>C\<^sub>L (heterogenous_cblinfun_id :: 'b\<Rightarrow>\<^sub>C\<^sub>L'a))\<close>
     | (trivial) \<open>\<And>A B :: 'a \<Rightarrow>\<^sub>C\<^sub>L 'b. A \<le> B \<longleftrightarrow> A = B\<close>
     apply atomize_elim by (auto simp: pos_def less_eq_cblinfun_def_heterogenous)
   note cases = this
 
   have [simp]: \<open>pos 0\<close>
     unfolding pos_def by auto
 
   have pos_nondeg: \<open>X = 0\<close> if \<open>pos X\<close> and \<open>pos (-X)\<close> for X
     apply (rule cblinfun_cinner_eqI, simp)
     using that by (metis (no_types, lifting) cblinfun.minus_left cinner_minus_right dual_order.antisym equation_minus_iff neg_le_0_iff_le pos_def)
 
   have pos_add: \<open>pos (X+Y)\<close> if \<open>pos X\<close> and \<open>pos Y\<close> for X Y
     by (smt (z3) pos_def cblinfun.diff_left cinner_minus_right cinner_simps(3) diff_ge_0_iff_ge diff_minus_eq_add neg_le_0_iff_le order_trans that(1) that(2) uminus_cblinfun.rep_eq)
 
   have pos_scaleC: \<open>pos (a *\<^sub>C X)\<close> if \<open>a\<ge>0\<close> and \<open>pos X\<close> for X a
     using that unfolding pos_def by (auto simp: cblinfun.scaleC_left)
 
   let ?id = \<open>heterogenous_cblinfun_id :: 'b \<Rightarrow>\<^sub>C\<^sub>L 'a\<close>
 
   show \<open>x \<le> x\<close>
     apply (cases rule:cases) by auto
   show \<open>(x < y) \<longleftrightarrow> (x \<le> y \<and> \<not> y \<le> x)\<close>
     unfolding less_cblinfun_def by simp
   show \<open>x \<le> z\<close> if \<open>x \<le> y\<close> and \<open>y \<le> z\<close>
   proof (cases rule:cases)
     case unitary
     define a b :: \<open>'b \<Rightarrow>\<^sub>C\<^sub>L 'b\<close> where \<open>a = (y-x) o\<^sub>C\<^sub>L heterogenous_cblinfun_id\<close>
       and \<open>b = (z-y) o\<^sub>C\<^sub>L heterogenous_cblinfun_id\<close>
     with unitary that have \<open>pos a\<close> and \<open>pos b\<close>
       by auto
     then have \<open>pos (a + b)\<close>
       by (rule pos_add)
     moreover have \<open>a + b = (z - x) o\<^sub>C\<^sub>L heterogenous_cblinfun_id\<close>
       unfolding a_def b_def
       by (metis (no_types, lifting) bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose diff_add_cancel ordered_field_class.sign_simps(2) ordered_field_class.sign_simps(8))
     ultimately show ?thesis
       using unitary by auto
   next
     case trivial
     with that show ?thesis by auto
   qed
   show \<open>x = y\<close> if \<open>x \<le> y\<close> and \<open>y \<le> x\<close>
   proof (cases rule:cases)
     case unitary
     then have \<open>unitary ?id\<close>
       by (auto simp: heterogenous_same_type_cblinfun_def)
     define a b :: \<open>'b \<Rightarrow>\<^sub>C\<^sub>L 'b\<close> where \<open>a = (y-x) o\<^sub>C\<^sub>L ?id\<close>
       and \<open>b = (x-y) o\<^sub>C\<^sub>L ?id\<close>
     with unitary that have \<open>pos a\<close> and \<open>pos b\<close>
       by auto
     then have \<open>a = 0\<close>
       apply (rule_tac pos_nondeg)
        apply (auto simp: a_def b_def)
       by (smt (verit, best) add.commute bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose cblinfun_compose_zero_left diff_0 diff_add_cancel group_cancel.rule0 group_cancel.sub1)
     then show ?thesis
       unfolding a_def using \<open>unitary ?id\<close>
       by (metis cblinfun_compose_assoc cblinfun_compose_id_right cblinfun_compose_zero_left eq_iff_diff_eq_0 unitaryD2)
   next
     case trivial
     with that show ?thesis by simp
   qed
   show \<open>x + y \<le> x + z\<close> if \<open>y \<le> z\<close>
   proof (cases rule:cases)
     case unitary
     with that show ?thesis
       by auto
   next
     case trivial
     with that show ?thesis
       by auto
   qed
 
   show \<open>a *\<^sub>C x \<le> a *\<^sub>C y\<close> if \<open>x \<le> y\<close> and \<open>0 \<le> a\<close>
   proof (cases rule:cases)
     case unitary
     with that pos_scaleC show ?thesis
       by (metis cblinfun_compose_scaleC_left complex_vector.scale_right_diff_distrib)
   next
     case trivial
     with that show ?thesis
       by auto
   qed
 
   show \<open>a *\<^sub>C x \<le> b *\<^sub>C x\<close> if \<open>a \<le> b\<close> and \<open>0 \<le> x\<close>
   proof (cases rule:cases)
     case unitary
     with that show ?thesis
       by (auto intro!: pos_scaleC simp flip: scaleC_diff_left)
   next
     case trivial
     with that show ?thesis
       by auto
   qed
 qed
 end
 
 lemma positive_id_cblinfun[simp]: "id_cblinfun \<ge> 0"
   unfolding less_eq_cblinfun_def using cinner_ge_zero by auto
 
 lemma positive_hermitianI: \<open>A = A*\<close> if \<open>A \<ge> 0\<close>
   apply (rule cinner_real_hermiteanI)
   using that by (auto simp: complex_is_real_iff_compare0 less_eq_cblinfun_def)
 
 lemma cblinfun_leI:
   assumes \<open>\<And>x. norm x = 1 \<Longrightarrow> x \<bullet>\<^sub>C (A *\<^sub>V x) \<le> x \<bullet>\<^sub>C (B *\<^sub>V x)\<close>
   shows \<open>A \<le> B\<close>
 proof (unfold less_eq_cblinfun_def, intro allI, case_tac \<open>\<psi> = 0\<close>)
   fix \<psi> :: 'a assume \<open>\<psi> = 0\<close>
   then show \<open>\<psi> \<bullet>\<^sub>C (A *\<^sub>V \<psi>) \<le> \<psi> \<bullet>\<^sub>C (B *\<^sub>V \<psi>)\<close>
     by simp
 next
   fix \<psi> :: 'a assume \<open>\<psi> \<noteq> 0\<close>
   define \<phi> where \<open>\<phi> = \<psi> /\<^sub>R norm \<psi>\<close>
   have \<open>\<phi> \<bullet>\<^sub>C (A *\<^sub>V \<phi>) \<le> \<phi> \<bullet>\<^sub>C (B *\<^sub>V \<phi>)\<close>
     apply (rule assms)
     unfolding \<phi>_def
     by (simp add: \<open>\<psi> \<noteq> 0\<close>)
   with \<open>\<psi> \<noteq> 0\<close> show \<open>\<psi> \<bullet>\<^sub>C (A *\<^sub>V \<psi>) \<le> \<psi> \<bullet>\<^sub>C (B *\<^sub>V \<psi>)\<close>
     unfolding \<phi>_def
     by (smt (verit) cinner_adj_left cinner_scaleR_left cinner_simps(6) complex_of_real_nn_iff mult_cancel_right1 mult_left_mono norm_eq_zero norm_ge_zero of_real_1 right_inverse scaleR_scaleC scaleR_scaleR)
 qed
 
 lemma positive_cblinfunI: \<open>A \<ge> 0\<close> if \<open>\<And>x. norm x = 1 \<Longrightarrow> cinner x (A *\<^sub>V x) \<ge> 0\<close>
   apply (rule cblinfun_leI)
   using that by simp
 
 (* Note: this does not require B to be a square operator *)
 lemma positive_cblinfun_squareI: \<open>A = B* o\<^sub>C\<^sub>L B \<Longrightarrow> A \<ge> 0\<close>
   apply (rule positive_cblinfunI)
   by (metis cblinfun_apply_cblinfun_compose cinner_adj_right cinner_ge_zero)
 
 lemma one_dim_loewner_order: \<open>A \<ge> B \<longleftrightarrow> one_dim_iso A \<ge> (one_dim_iso B :: complex)\<close> for A B :: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L 'a::{chilbert_space, one_dim}\<close>
 proof -
   note less_eq_complex_def[simp del]
   have A: \<open>A = one_dim_iso A *\<^sub>C id_cblinfun\<close>
     by simp
   have B: \<open>B = one_dim_iso B *\<^sub>C id_cblinfun\<close>
     by simp
   have \<open>A \<ge> B \<longleftrightarrow> (\<forall>\<psi>. cinner \<psi> (A \<psi>) \<ge> cinner \<psi> (B \<psi>))\<close>
     by (simp add: less_eq_cblinfun_def)
   also have \<open>\<dots> \<longleftrightarrow> (\<forall>\<psi>::'a. one_dim_iso B * (\<psi> \<bullet>\<^sub>C \<psi>) \<le> one_dim_iso A * (\<psi> \<bullet>\<^sub>C \<psi>))\<close>
     apply (subst A, subst B)
     by (metis (no_types, opaque_lifting) cinner_scaleC_right id_cblinfun_apply scaleC_cblinfun.rep_eq)
   also have \<open>\<dots> \<longleftrightarrow> one_dim_iso A \<ge> (one_dim_iso B :: complex)\<close>
     by (auto intro!: mult_right_mono elim!: allE[where x=1])
   finally show ?thesis
     by -
 qed
 
 lemma one_dim_positive: \<open>A \<ge> 0 \<longleftrightarrow> one_dim_iso A \<ge> (0::complex)\<close> for A :: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L 'a::{chilbert_space, one_dim}\<close>
   using one_dim_loewner_order[where B=0] by auto
 
 lemma op_square_nondegenerate: \<open>a = 0\<close> if \<open>a* o\<^sub>C\<^sub>L a = 0\<close>
 proof (rule cblinfun_eq_0_on_UNIV_span[where basis=UNIV]; simp)
   fix s
   from that have \<open>s \<bullet>\<^sub>C ((a* o\<^sub>C\<^sub>L a) *\<^sub>V s) = 0\<close>
     by simp
   then have \<open>(a *\<^sub>V s) \<bullet>\<^sub>C (a *\<^sub>V s) = 0\<close>
     by (simp add: cinner_adj_right)
   then show \<open>a *\<^sub>V s = 0\<close>
     by simp
 qed
 
 lemma comparable_hermitean:
   assumes \<open>a \<le> b\<close>
   assumes \<open>a* = a\<close>
   shows \<open>b* = b\<close>
   by (smt (verit, best) assms(1) assms(2) cinner_hermitian_real cinner_real_hermiteanI comparable complex_is_real_iff_compare0 less_eq_cblinfun_def)
 
 lemma comparable_hermitean':
   assumes \<open>a \<le> b\<close>
   assumes \<open>b* = b\<close>
   shows \<open>a* = a\<close>
   by (smt (verit, best) assms(1) assms(2) cinner_hermitian_real cinner_real_hermiteanI comparable complex_is_real_iff_compare0 less_eq_cblinfun_def)
 
+lemma Proj_mono: \<open>Proj S \<le> Proj T \<longleftrightarrow> S \<le> T\<close>
+proof (rule iffI)
+  assume \<open>S \<le> T\<close>
+  define D where \<open>D = Proj T - Proj S\<close>
+  from \<open>S \<le> T\<close> have TS_S[simp]: \<open>Proj T o\<^sub>C\<^sub>L Proj S = Proj S\<close>
+    by (smt (verit, ccfv_threshold) Proj_idempotent Proj_range cblinfun_apply_cblinfun_compose cblinfun_apply_in_image cblinfun_eqI cblinfun_fixes_range less_eq_ccsubspace.rep_eq subset_iff)
+  then have ST_S[simp]: \<open>Proj S o\<^sub>C\<^sub>L Proj T = Proj S\<close>
+    by (metis adj_Proj adj_cblinfun_compose)
+  have \<open>D* o\<^sub>C\<^sub>L D = D\<close>
+    by (simp add: D_def cblinfun_compose_minus_left cblinfun_compose_minus_right adj_minus adj_Proj)
+  then have \<open>D \<ge> 0\<close>
+    by (metis positive_cblinfun_squareI)
+  then show \<open>Proj S \<le> Proj T\<close>
+    by (simp add: D_def)
+next
+  assume PS_PT: \<open>Proj S \<le> Proj T\<close>
+  show \<open>S \<le> T\<close>
+  proof (rule ccsubspace_leI_unit)
+    fix \<psi> assume \<open>\<psi> \<in> space_as_set S\<close> and [simp]: \<open>norm \<psi> = 1\<close>
+    then have \<open>1 = norm (Proj S *\<^sub>V \<psi>)\<close>
+      by (simp add: cancel_apply_Proj)
+    also from PS_PT have \<open>\<dots> \<le> norm (Proj T *\<^sub>V \<psi>)\<close>
+      by (metis (no_types, lifting) Proj_idempotent adj_Proj cblinfun_apply_cblinfun_compose cinner_adj_left cnorm_le less_eq_cblinfun_def)
+    also have \<open>\<dots> \<le> 1\<close>
+      by (metis Proj_is_Proj \<open>norm \<psi> = 1\<close> is_Proj_reduces_norm)
+    ultimately have \<open>norm (Proj T *\<^sub>V \<psi>) = 1\<close>
+      by auto
+    then show \<open>\<psi> \<in> space_as_set T\<close>
+      by (simp add: norm_Proj_apply_1)
+  qed
+qed
+
 subsection \<open>Embedding vectors to operators\<close>
 
 lift_definition vector_to_cblinfun :: \<open>'a::complex_normed_vector \<Rightarrow> 'b::one_dim \<Rightarrow>\<^sub>C\<^sub>L 'a\<close> is
   \<open>\<lambda>\<psi> \<phi>. one_dim_iso \<phi> *\<^sub>C \<psi>\<close>
   by (simp add: bounded_clinear_scaleC_const)
 
 lemma vector_to_cblinfun_cblinfun_apply:
   "vector_to_cblinfun (A *\<^sub>V \<psi>) = A  o\<^sub>C\<^sub>L (vector_to_cblinfun \<psi>)"
   apply transfer
   unfolding comp_def bounded_clinear_def clinear_def Vector_Spaces.linear_def
     module_hom_def module_hom_axioms_def
   by simp
 
 lemma vector_to_cblinfun_add: \<open>vector_to_cblinfun (x + y) = vector_to_cblinfun x + vector_to_cblinfun y\<close>
   apply transfer
   by (simp add: scaleC_add_right)
 
 lemma norm_vector_to_cblinfun[simp]: "norm (vector_to_cblinfun x) = norm x"
 proof transfer
   have "bounded_clinear (one_dim_iso::'a \<Rightarrow> complex)"
     by simp
   moreover have "onorm (one_dim_iso::'a \<Rightarrow> complex) * norm x = norm x"
     for x :: 'b
     by simp
   ultimately show "onorm (\<lambda>\<phi>. one_dim_iso (\<phi>::'a) *\<^sub>C x) = norm x"
     for x :: 'b
     by (subst onorm_scaleC_left)
 qed
 
 lemma bounded_clinear_vector_to_cblinfun[bounded_clinear]: "bounded_clinear vector_to_cblinfun"
   apply (rule bounded_clinearI[where K=1])
     apply (transfer, simp add: scaleC_add_right)
    apply (transfer, simp add: mult.commute)
   by simp
 
 lemma vector_to_cblinfun_scaleC[simp]:
   "vector_to_cblinfun (a *\<^sub>C \<psi>) = a *\<^sub>C vector_to_cblinfun \<psi>" for a::complex
 proof (subst asm_rl [of "a *\<^sub>C \<psi> = (a *\<^sub>C id_cblinfun) *\<^sub>V \<psi>"])
   show "a *\<^sub>C \<psi> = a *\<^sub>C id_cblinfun *\<^sub>V \<psi>"
     by (simp add: scaleC_cblinfun.rep_eq)
   show "vector_to_cblinfun (a *\<^sub>C id_cblinfun *\<^sub>V \<psi>) = a *\<^sub>C (vector_to_cblinfun \<psi>::'a \<Rightarrow>\<^sub>C\<^sub>L 'b)"
     by (metis cblinfun_id_cblinfun_apply cblinfun_compose_scaleC_left vector_to_cblinfun_cblinfun_apply)
 qed
 
 lemma vector_to_cblinfun_apply_one_dim[simp]:
   shows "vector_to_cblinfun \<phi> *\<^sub>V \<gamma> = one_dim_iso \<gamma> *\<^sub>C \<phi>"
   apply transfer by (rule refl)
 
 lemma vector_to_cblinfun_adj_apply[simp]:
   shows "vector_to_cblinfun \<psi>* *\<^sub>V \<phi> = of_complex (cinner \<psi> \<phi>)"
   by (simp add: cinner_adj_right one_dim_iso_def one_dim_iso_inj)
 
 lemma vector_to_cblinfun_comp_one[simp]:
   "(vector_to_cblinfun s :: 'a::one_dim \<Rightarrow>\<^sub>C\<^sub>L _) o\<^sub>C\<^sub>L 1
      = (vector_to_cblinfun s :: 'b::one_dim \<Rightarrow>\<^sub>C\<^sub>L _)"
   apply (transfer fixing: s)
   by fastforce
 
 lemma vector_to_cblinfun_0[simp]: "vector_to_cblinfun 0 = 0"
   by (metis cblinfun.zero_left cblinfun_compose_zero_left vector_to_cblinfun_cblinfun_apply)
 
 lemma image_vector_to_cblinfun[simp]: "vector_to_cblinfun x *\<^sub>S top = ccspan {x}"
 proof transfer
   show "closure (range (\<lambda>\<phi>::'b. one_dim_iso \<phi> *\<^sub>C x)) = closure (cspan {x})"
     for x :: 'a
   proof (rule arg_cong [where f = closure])
     have "k *\<^sub>C x \<in> range (\<lambda>\<phi>. one_dim_iso \<phi> *\<^sub>C x)" for k
       by (smt (z3) id_apply one_dim_iso_id one_dim_iso_idem range_eqI)
     thus "range (\<lambda>\<phi>. one_dim_iso (\<phi>::'b) *\<^sub>C x) = cspan {x}"
       unfolding complex_vector.span_singleton
       by auto
   qed
 qed
 
 lemma vector_to_cblinfun_adj_comp_vector_to_cblinfun[simp]:
   shows "vector_to_cblinfun \<psi>* o\<^sub>C\<^sub>L vector_to_cblinfun \<phi> = cinner \<psi> \<phi> *\<^sub>C id_cblinfun"
 proof -
   have "one_dim_iso \<gamma> *\<^sub>C one_dim_iso (of_complex \<langle>\<psi>, \<phi>\<rangle>) =
     \<langle>\<psi>, \<phi>\<rangle> *\<^sub>C one_dim_iso \<gamma>"
     for \<gamma> :: "'c::one_dim"
     by (metis complex_vector.scale_left_commute of_complex_def one_dim_iso_of_one one_dim_iso_scaleC one_dim_scaleC_1)
   hence "one_dim_iso ((vector_to_cblinfun \<psi>* o\<^sub>C\<^sub>L vector_to_cblinfun \<phi>) *\<^sub>V \<gamma>)
       = one_dim_iso ((cinner \<psi> \<phi> *\<^sub>C id_cblinfun) *\<^sub>V \<gamma>)"
     for \<gamma> :: "'c::one_dim"
     by simp
   hence "((vector_to_cblinfun \<psi>* o\<^sub>C\<^sub>L vector_to_cblinfun \<phi>) *\<^sub>V \<gamma>) = ((cinner \<psi> \<phi> *\<^sub>C id_cblinfun) *\<^sub>V \<gamma>)"
     for \<gamma> :: "'c::one_dim"
     by (rule one_dim_iso_inj)
   thus ?thesis
     using cblinfun_eqI[where x = "vector_to_cblinfun \<psi>* o\<^sub>C\<^sub>L vector_to_cblinfun \<phi>"
         and y = "\<langle>\<psi>, \<phi>\<rangle> *\<^sub>C id_cblinfun"]
     by auto
 qed
 
 lemma isometry_vector_to_cblinfun[simp]:
   assumes "norm x = 1"
   shows "isometry (vector_to_cblinfun x)"
   using assms cnorm_eq_1 isometry_def by force
 
 subsection \<open>Butterflies (rank-1 projectors)\<close>
 
 definition butterfly_def: "butterfly (s::'a::complex_normed_vector) (t::'b::chilbert_space)
    = vector_to_cblinfun s o\<^sub>C\<^sub>L (vector_to_cblinfun t :: complex \<Rightarrow>\<^sub>C\<^sub>L _)*"
 
 abbreviation "selfbutter s \<equiv> butterfly s s"
 
 lemma butterfly_add_left: \<open>butterfly (a + a') b = butterfly a b + butterfly a' b\<close>
   by (simp add: butterfly_def vector_to_cblinfun_add cbilinear_add_left bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose)
 
 lemma butterfly_add_right: \<open>butterfly a (b + b') = butterfly a b + butterfly a b'\<close>
   by (simp add: butterfly_def adj_plus vector_to_cblinfun_add cblinfun_compose_add_right)
 
 lemma butterfly_def_one_dim: "butterfly s t = (vector_to_cblinfun s :: 'c::one_dim \<Rightarrow>\<^sub>C\<^sub>L _)
                                           o\<^sub>C\<^sub>L (vector_to_cblinfun t :: 'c \<Rightarrow>\<^sub>C\<^sub>L _)*"
   (is "_ = ?rhs") for s :: "'a::complex_normed_vector" and t :: "'b::chilbert_space"
 proof -
   let ?isoAC = "1 :: 'c \<Rightarrow>\<^sub>C\<^sub>L complex"
   let ?isoCA = "1 :: complex \<Rightarrow>\<^sub>C\<^sub>L 'c"
   let ?vector = "vector_to_cblinfun :: _ \<Rightarrow> ('c \<Rightarrow>\<^sub>C\<^sub>L _)"
 
   have "butterfly s t =
     (?vector s o\<^sub>C\<^sub>L ?isoCA) o\<^sub>C\<^sub>L (?vector t o\<^sub>C\<^sub>L ?isoCA)*"
     unfolding butterfly_def vector_to_cblinfun_comp_one by simp
   also have "\<dots> = ?vector s o\<^sub>C\<^sub>L (?isoCA o\<^sub>C\<^sub>L ?isoCA*) o\<^sub>C\<^sub>L (?vector t)*"
     by (metis (no_types, lifting) cblinfun_compose_assoc adj_cblinfun_compose)
   also have "\<dots> = ?rhs"
     by simp
   finally show ?thesis
     by simp
 qed
 
 lemma butterfly_comp_cblinfun: "butterfly \<psi> \<phi> o\<^sub>C\<^sub>L a = butterfly \<psi> (a* *\<^sub>V \<phi>)"
   unfolding butterfly_def
   by (simp add: cblinfun_compose_assoc vector_to_cblinfun_cblinfun_apply)
 
 lemma cblinfun_comp_butterfly: "a o\<^sub>C\<^sub>L butterfly \<psi> \<phi> = butterfly (a *\<^sub>V \<psi>) \<phi>"
   unfolding butterfly_def
   by (simp add: cblinfun_compose_assoc vector_to_cblinfun_cblinfun_apply)
 
 lemma butterfly_apply[simp]: "butterfly \<psi> \<psi>' *\<^sub>V \<phi> = \<langle>\<psi>', \<phi>\<rangle> *\<^sub>C \<psi>"
   by (simp add: butterfly_def scaleC_cblinfun.rep_eq)
 
 lemma butterfly_scaleC_left[simp]: "butterfly (c *\<^sub>C \<psi>) \<phi> = c *\<^sub>C butterfly \<psi> \<phi>"
   unfolding butterfly_def vector_to_cblinfun_scaleC scaleC_adj
   by (simp add: cnj_x_x)
 
 lemma butterfly_scaleC_right[simp]: "butterfly \<psi> (c *\<^sub>C \<phi>) = cnj c *\<^sub>C butterfly \<psi> \<phi>"
   unfolding butterfly_def vector_to_cblinfun_scaleC scaleC_adj
   by (simp add: cnj_x_x)
 
 lemma butterfly_scaleR_left[simp]: "butterfly (r *\<^sub>R \<psi>) \<phi> = r *\<^sub>C butterfly \<psi> \<phi>"
   by (simp add: scaleR_scaleC)
 
 lemma butterfly_scaleR_right[simp]: "butterfly \<psi> (r *\<^sub>R \<phi>) = r *\<^sub>C butterfly \<psi> \<phi>"
   by (simp add: butterfly_scaleC_right scaleR_scaleC)
 
 lemma butterfly_adjoint[simp]: "(butterfly \<psi> \<phi>)* = butterfly \<phi> \<psi>"
   unfolding butterfly_def by auto
 
 lemma butterfly_comp_butterfly[simp]: "butterfly \<psi>1 \<psi>2 o\<^sub>C\<^sub>L butterfly \<psi>3 \<psi>4 = \<langle>\<psi>2, \<psi>3\<rangle> *\<^sub>C butterfly \<psi>1 \<psi>4"
   by (simp add: butterfly_comp_cblinfun)
 
 lemma butterfly_0_left[simp]: "butterfly 0 a = 0"
   by (simp add: butterfly_def)
 
 lemma butterfly_0_right[simp]: "butterfly a 0 = 0"
   by (simp add: butterfly_def)
 
 lemma norm_butterfly: "norm (butterfly \<psi> \<phi>) = norm \<psi> * norm \<phi>"
 proof (cases "\<phi>=0")
   case True
   then show ?thesis by simp
 next
   case False
   show ?thesis
     unfolding norm_cblinfun.rep_eq
     thm onormI[OF _ False]
   proof (rule onormI[OF _ False])
     fix x
 
     have "cmod \<langle>\<phi>, x\<rangle> * norm \<psi> \<le> norm \<psi> * norm \<phi> * norm x"
       by (metis ab_semigroup_mult_class.mult_ac(1) complex_inner_class.Cauchy_Schwarz_ineq2 mult.commute mult_left_mono norm_ge_zero)
     thus "norm (butterfly \<psi> \<phi> *\<^sub>V x) \<le> norm \<psi> * norm \<phi> * norm x"
       by (simp add: power2_eq_square)
 
     show "norm (butterfly \<psi> \<phi> *\<^sub>V \<phi>) = norm \<psi> * norm \<phi> * norm \<phi>"
       by (smt (z3) ab_semigroup_mult_class.mult_ac(1) butterfly_apply mult.commute norm_eq_sqrt_cinner norm_ge_zero norm_scaleC power2_eq_square real_sqrt_abs real_sqrt_eq_iff)
   qed
 qed
 
 lemma bounded_sesquilinear_butterfly[bounded_sesquilinear]: \<open>bounded_sesquilinear (\<lambda>(b::'b::chilbert_space) (a::'a::chilbert_space). butterfly a b)\<close>
 proof standard
   fix a a' :: 'a and b b' :: 'b and r :: complex
   show \<open>butterfly (a + a') b = butterfly a b + butterfly a' b\<close>
     by (rule butterfly_add_left)
   show \<open>butterfly a (b + b') = butterfly a b + butterfly a b'\<close>
     by (rule butterfly_add_right)
   show \<open>butterfly (r *\<^sub>C a) b = r *\<^sub>C butterfly a b\<close>
     by simp
   show \<open>butterfly a (r *\<^sub>C b) = cnj r *\<^sub>C butterfly a b\<close>
     by simp
   show \<open>\<exists>K. \<forall>b a. norm (butterfly a b) \<le> norm b * norm a * K \<close>
     apply (rule exI[of _ 1])
     by (simp add: norm_butterfly)
 qed
 
 lemma inj_selfbutter_upto_phase:
   assumes "selfbutter x = selfbutter y"
   shows "\<exists>c. cmod c = 1 \<and> x = c *\<^sub>C y"
 proof (cases "x = 0")
   case True
   from assms have "y = 0"
     using norm_butterfly
     by (metis True butterfly_0_left divisors_zero norm_eq_zero)
   with True show ?thesis
     using norm_one by fastforce
 next
   case False
   define c where "c = \<langle>y, x\<rangle> / \<langle>x, x\<rangle>"
   have "\<langle>x, x\<rangle> *\<^sub>C x = selfbutter x *\<^sub>V x"
     by (simp add: butterfly_apply)
   also have "\<dots> = selfbutter y *\<^sub>V x"
     using assms by simp
   also have "\<dots> = \<langle>y, x\<rangle> *\<^sub>C y"
     by (simp add: butterfly_apply)
   finally have xcy: "x = c *\<^sub>C y"
     by (simp add: c_def ceq_vector_fraction_iff)
   have "cmod c * norm x = cmod c * norm y"
     using assms norm_butterfly
     by (smt (verit, ccfv_SIG) \<open>\<langle>x, x\<rangle> *\<^sub>C x = selfbutter x *\<^sub>V x\<close> \<open>selfbutter y *\<^sub>V x = \<langle>y, x\<rangle> *\<^sub>C y\<close> cinner_scaleC_right complex_vector.scale_left_commute complex_vector.scale_right_imp_eq mult_cancel_left norm_eq_sqrt_cinner norm_eq_zero scaleC_scaleC xcy)
   also have "cmod c * norm y = norm (c *\<^sub>C y)"
     by simp
   also have "\<dots> = norm x"
     unfolding xcy[symmetric] by simp
   finally have c: "cmod c = 1"
     by (simp add: False)
   from c xcy show ?thesis
     by auto
 qed
 
 lemma butterfly_eq_proj:
   assumes "norm x = 1"
   shows "selfbutter x = proj x"
 proof -
   define B and \<phi> :: "complex \<Rightarrow>\<^sub>C\<^sub>L 'a"
     where "B = selfbutter x" and "\<phi> = vector_to_cblinfun x"
   then have B: "B = \<phi> o\<^sub>C\<^sub>L \<phi>*"
     unfolding butterfly_def by simp
   have \<phi>adj\<phi>: "\<phi>* o\<^sub>C\<^sub>L \<phi> = id_cblinfun"
     using \<phi>_def assms isometry_def isometry_vector_to_cblinfun by blast
   have "B o\<^sub>C\<^sub>L B = \<phi> o\<^sub>C\<^sub>L (\<phi>* o\<^sub>C\<^sub>L \<phi>) o\<^sub>C\<^sub>L \<phi>*"
     by (simp add: B cblinfun_assoc_left(1))
   also have "\<dots> = B"
     unfolding \<phi>adj\<phi> by (simp add: B)
   finally have idem: "B o\<^sub>C\<^sub>L B = B".
   have herm: "B = B*"
     unfolding B by simp
   from idem herm have BProj: "B = Proj (B *\<^sub>S top)"
     by (rule Proj_on_own_range'[symmetric])
   have "B *\<^sub>S top = ccspan {x}"
     by (simp add: B \<phi>_def assms cblinfun_compose_image range_adjoint_isometry)
   with BProj show "B = proj x"
     by simp
 qed
 
 lemma butterfly_sgn_eq_proj:
   shows "selfbutter (sgn x) = proj x"
 proof (cases \<open>x = 0\<close>)
   case True
   then show ?thesis
     by simp
 next
   case False
   then have \<open>selfbutter (sgn x) = proj (sgn x)\<close>
     by (simp add: butterfly_eq_proj norm_sgn)
   also have \<open>ccspan {sgn x} = ccspan {x}\<close>
     by (metis ccspan_singleton_scaleC scaleC_eq_0_iff scaleR_scaleC sgn_div_norm sgn_zero_iff)
   finally show ?thesis
     by -
 qed
 
 lemma butterfly_is_Proj:
   \<open>norm x = 1 \<Longrightarrow> is_Proj (selfbutter x)\<close>
   by (subst butterfly_eq_proj, simp_all)
 
 lemma cspan_butterfly_UNIV:
   assumes \<open>cspan basisA = UNIV\<close>
   assumes \<open>cspan basisB = UNIV\<close>
   assumes \<open>is_ortho_set basisB\<close>
   assumes \<open>\<And>b. b \<in> basisB \<Longrightarrow> norm b = 1\<close>
   shows \<open>cspan {butterfly a b| (a::'a::{complex_normed_vector}) (b::'b::{chilbert_space,cfinite_dim}). a \<in> basisA \<and> b \<in> basisB} = UNIV\<close>
 proof -
   have F: \<open>\<exists>F\<in>{butterfly a b |a b. a \<in> basisA \<and> b \<in> basisB}. \<forall>b'\<in>basisB. F *\<^sub>V b' = (if b' = b then a else 0)\<close>
     if \<open>a \<in> basisA\<close> and \<open>b \<in> basisB\<close> for a b
     apply (rule bexI[where x=\<open>butterfly a b\<close>])
     using assms that by (auto simp: is_ortho_set_def cnorm_eq_1)
   show ?thesis
     apply (rule cblinfun_cspan_UNIV[where basisA=basisB and basisB=basisA])
     using assms apply auto[2]
     using F by (smt (verit, ccfv_SIG) image_iff)
 qed
 
 lemma cindependent_butterfly:
   fixes basisA :: \<open>'a::chilbert_space set\<close> and basisB :: \<open>'b::chilbert_space set\<close>
   assumes \<open>is_ortho_set basisA\<close> \<open>is_ortho_set basisB\<close>
   assumes normA: \<open>\<And>a. a\<in>basisA \<Longrightarrow> norm a = 1\<close> and normB: \<open>\<And>b. b\<in>basisB \<Longrightarrow> norm b = 1\<close>
   shows \<open>cindependent {butterfly a b| a b. a\<in>basisA \<and> b\<in>basisB}\<close>
 proof (unfold complex_vector.independent_explicit_module, intro allI impI, rename_tac T f g)
   fix T :: \<open>('b \<Rightarrow>\<^sub>C\<^sub>L 'a) set\<close> and f :: \<open>'b \<Rightarrow>\<^sub>C\<^sub>L 'a \<Rightarrow> complex\<close> and g :: \<open>'b \<Rightarrow>\<^sub>C\<^sub>L 'a\<close>
   assume \<open>finite T\<close>
   assume T_subset: \<open>T \<subseteq> {butterfly a b |a b. a \<in> basisA \<and> b \<in> basisB}\<close>
   define lin where \<open>lin = (\<Sum>g\<in>T. f g *\<^sub>C g)\<close>
   assume \<open>lin = 0\<close>
   assume \<open>g \<in> T\<close>
   (* To show: f g = 0 *)
   then obtain a b where g: \<open>g = butterfly a b\<close> and [simp]: \<open>a \<in> basisA\<close> \<open>b \<in> basisB\<close>
     using T_subset by auto
 
   have *: "(vector_to_cblinfun a)* *\<^sub>V f g *\<^sub>C g *\<^sub>V b = 0"
     if \<open>g \<in> T - {butterfly a b}\<close> for g
   proof -
     from that
     obtain a' b' where g: \<open>g = butterfly a' b'\<close> and [simp]: \<open>a' \<in> basisA\<close> \<open>b' \<in> basisB\<close>
       using T_subset by auto
     from that have \<open>g \<noteq> butterfly a b\<close> by auto
     with g consider (a) \<open>a\<noteq>a'\<close> | (b) \<open>b\<noteq>b'\<close>
       by auto
     then show \<open>(vector_to_cblinfun a)* *\<^sub>V f g *\<^sub>C g *\<^sub>V b = 0\<close>
     proof cases
       case a
       then show ?thesis
         using  \<open>is_ortho_set basisA\<close> unfolding g
         by (auto simp: is_ortho_set_def butterfly_def scaleC_cblinfun.rep_eq)
     next
       case b
       then show ?thesis
         using  \<open>is_ortho_set basisB\<close> unfolding g
         by (auto simp: is_ortho_set_def butterfly_def scaleC_cblinfun.rep_eq)
     qed
   qed
 
   have \<open>0 = (vector_to_cblinfun a)* *\<^sub>V lin *\<^sub>V b\<close>
     using \<open>lin = 0\<close> by auto
   also have \<open>\<dots> = (\<Sum>g\<in>T. (vector_to_cblinfun a)* *\<^sub>V (f g *\<^sub>C g) *\<^sub>V b)\<close>
     unfolding lin_def
     apply (rule complex_vector.linear_sum)
     by (smt (z3) cblinfun.scaleC_left cblinfun.scaleC_right cblinfun.add_right clinearI plus_cblinfun.rep_eq)
   also have \<open>\<dots> = (\<Sum>g\<in>{butterfly a b}. (vector_to_cblinfun a)* *\<^sub>V (f g *\<^sub>C g) *\<^sub>V b)\<close>
     apply (rule sum.mono_neutral_right)
     using \<open>finite T\<close> * \<open>g \<in> T\<close> g by auto
   also have \<open>\<dots> = (vector_to_cblinfun a)* *\<^sub>V (f g *\<^sub>C g) *\<^sub>V b\<close>
     by (simp add: g)
   also have \<open>\<dots> = f g\<close>
     unfolding g
     using normA normB by (auto simp: butterfly_def scaleC_cblinfun.rep_eq cnorm_eq_1)
   finally show \<open>f g = 0\<close>
     by simp
 qed
 
 lemma clinear_eq_butterflyI:
   fixes F G :: \<open>('a::{chilbert_space,cfinite_dim} \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_inner) \<Rightarrow> 'c::complex_vector\<close>
   assumes "clinear F" and "clinear G"
   assumes \<open>cspan basisA = UNIV\<close> \<open>cspan basisB = UNIV\<close>
   assumes \<open>is_ortho_set basisA\<close> \<open>is_ortho_set basisB\<close>
   assumes "\<And>a b. a\<in>basisA \<Longrightarrow> b\<in>basisB \<Longrightarrow> F (butterfly a b) = G (butterfly a b)"
   assumes \<open>\<And>b. b\<in>basisB \<Longrightarrow> norm b = 1\<close>
   shows "F = G"
   apply (rule complex_vector.linear_eq_on_span[where f=F, THEN ext, rotated 3])
      apply (subst cspan_butterfly_UNIV)
   using assms by auto
 
 lemma sum_butterfly_is_Proj:
   assumes \<open>is_ortho_set E\<close>
   assumes \<open>\<And>e. e\<in>E \<Longrightarrow> norm e = 1\<close>
   shows \<open>is_Proj (\<Sum>e\<in>E. butterfly e e)\<close>
 proof (cases \<open>finite E\<close>)
   case True
   show ?thesis
   proof (rule is_Proj_I)
     show \<open>(\<Sum>e\<in>E. butterfly e e)* = (\<Sum>e\<in>E. butterfly e e)\<close>
       by (simp add: sum_adj)
     have ortho: \<open>f \<noteq> e \<Longrightarrow> e \<in> E \<Longrightarrow> f \<in> E \<Longrightarrow> is_orthogonal f e\<close> for f e
       by (meson assms(1) is_ortho_set_def)
     have unit: \<open>e \<bullet>\<^sub>C e = 1\<close> if \<open>e \<in> E\<close> for e
       using assms(2) cnorm_eq_1 that by blast
     have *: \<open>(\<Sum>f\<in>E. (f \<bullet>\<^sub>C e) *\<^sub>C butterfly f e) = butterfly e e\<close> if \<open>e \<in> E\<close> for e
       apply (subst sum_single[where i=e])
       by (auto intro!: simp: that ortho unit True)
     show \<open>(\<Sum>e\<in>E. butterfly e e) o\<^sub>C\<^sub>L (\<Sum>e\<in>E. butterfly e e) = (\<Sum>e\<in>E. butterfly e e)\<close>
       by (auto simp: * cblinfun_compose_sum_right cblinfun_compose_sum_left)
   qed
 next
   case False
   then show ?thesis
     by simp
 qed
 
 subsection \<open>Bifunctionals\<close>
 
 lift_definition bifunctional :: \<open>'a::complex_normed_vector \<Rightarrow>\<^sub>C\<^sub>L (('a \<Rightarrow>\<^sub>C\<^sub>L complex) \<Rightarrow>\<^sub>C\<^sub>L complex)\<close>
   is \<open>\<lambda>x f. f *\<^sub>V x\<close>
   by (simp add: cblinfun.flip)
 
 lemma bifunctional_apply[simp]: \<open>(bifunctional *\<^sub>V x) *\<^sub>V f = f *\<^sub>V x\<close>
   by (transfer fixing: x f, simp)
 
 lemma bifunctional_isometric[simp]: \<open>norm (bifunctional *\<^sub>V x) = norm x\<close> for x :: \<open>'a::complex_inner\<close>
 proof -
   define f :: \<open>'a \<Rightarrow>\<^sub>C\<^sub>L complex\<close> where \<open>f = CBlinfun (\<lambda>y. cinner x y)\<close>
   then have [simp]: \<open>f *\<^sub>V y = cinner x y\<close> for y
     by (simp add: bounded_clinear_CBlinfun_apply bounded_clinear_cinner_right)
   then have [simp]: \<open>norm f = norm x\<close>
     apply (auto intro!: norm_cblinfun_eqI[where x=x] simp: power2_norm_eq_cinner[symmetric])
      apply (smt (verit, best) norm_eq_sqrt_cinner norm_ge_zero power2_norm_eq_cinner real_div_sqrt)
     using Cauchy_Schwarz_ineq2 by blast
   show ?thesis
     apply (auto intro!: norm_cblinfun_eqI[where x=f])
      apply (metis norm_eq_sqrt_cinner norm_imp_pos_and_ge real_div_sqrt)
     by (metis norm_cblinfun ordered_field_class.sign_simps(33))
 qed
 
 lemma norm_bifunctional[simp]: \<open>norm (bifunctional :: 'a::{complex_inner, not_singleton} \<Rightarrow>\<^sub>C\<^sub>L _) = 1\<close>
 proof -
   obtain x :: 'a where [simp]: \<open>norm x = 1\<close>
     by (meson UNIV_not_singleton ex_norm1)
   show ?thesis
     by (auto intro!: norm_cblinfun_eqI[where x=x])
 qed
 
 subsection \<open>Banach-Steinhaus\<close>
 
 theorem cbanach_steinhaus:
   fixes F :: \<open>'c \<Rightarrow> 'a::cbanach \<Rightarrow>\<^sub>C\<^sub>L 'b::complex_normed_vector\<close>
   assumes \<open>\<And>x. \<exists>M. \<forall>n.  norm ((F n) *\<^sub>V x) \<le> M\<close>
   shows  \<open>\<exists>M. \<forall> n. norm (F n) \<le> M\<close>
   using cblinfun_blinfun_transfer[transfer_rule] apply (rule TrueI)? (* Deletes current facts *)
 proof (use assms in transfer)
   fix F :: \<open>'c \<Rightarrow> 'a \<Rightarrow>\<^sub>L 'b\<close> assume \<open>(\<And>x. \<exists>M. \<forall>n. norm (F n *\<^sub>v x) \<le> M)\<close>
   hence \<open>\<And>x. bounded (range (\<lambda>n. blinfun_apply (F n) x))\<close>
     by (metis (no_types, lifting) boundedI rangeE)
   hence \<open>bounded (range F)\<close>
     by (simp add: banach_steinhaus)
   thus  \<open>\<exists>M. \<forall>n. norm (F n) \<le> M\<close>
     by (simp add: bounded_iff)
 qed
 
 subsection \<open>Riesz-representation theorem\<close>
 
 theorem riesz_frechet_representation_cblinfun_existence:
   \<comment> \<open>Theorem 3.4 in @{cite conway2013course}\<close>
   fixes f::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L complex\<close>
   shows \<open>\<exists>t. \<forall>x.  f *\<^sub>V x = \<langle>t, x\<rangle>\<close>
   apply transfer by (rule riesz_frechet_representation_existence)
 
 lemma riesz_frechet_representation_cblinfun_unique:
   \<comment> \<open>Theorem 3.4 in @{cite conway2013course}\<close>
   fixes f::\<open>'a::complex_inner \<Rightarrow>\<^sub>C\<^sub>L complex\<close>
   assumes \<open>\<And>x. f *\<^sub>V x = \<langle>t, x\<rangle>\<close>
   assumes \<open>\<And>x. f *\<^sub>V x = \<langle>u, x\<rangle>\<close>
   shows \<open>t = u\<close>
   using assms by (rule riesz_frechet_representation_unique)
 
 theorem riesz_frechet_representation_cblinfun_norm:
   includes notation_norm
   fixes f::\<open>'a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L complex\<close>
   assumes \<open>\<And>x.  f *\<^sub>V x = \<langle>t, x\<rangle>\<close>
   shows \<open>\<parallel>f\<parallel> = \<parallel>t\<parallel>\<close>
   using assms
 proof transfer
   fix f::\<open>'a \<Rightarrow> complex\<close> and t
   assume \<open>bounded_clinear f\<close> and \<open>\<And>x. f x = \<langle>t, x\<rangle>\<close>
   from  \<open>\<And>x. f x = \<langle>t, x\<rangle>\<close>
   have \<open>(norm (f x)) / (norm x) \<le> norm t\<close>
     for x
   proof(cases \<open>norm x = 0\<close>)
     case True
     thus ?thesis by simp
   next
     case False
     have \<open>norm (f x) = norm (\<langle>t, x\<rangle>)\<close>
       using \<open>\<And>x. f x = \<langle>t, x\<rangle>\<close> by simp
     also have \<open>norm \<langle>t, x\<rangle> \<le> norm t * norm x\<close>
       by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2)
     finally have \<open>norm (f x) \<le> norm t * norm x\<close>
       by blast
     thus ?thesis
       by (metis False linordered_field_class.divide_right_mono nonzero_mult_div_cancel_right norm_ge_zero)
   qed
   moreover have \<open>(norm (f t)) / (norm t) = norm t\<close>
   proof(cases \<open>norm t = 0\<close>)
     case True
     thus ?thesis
       by simp
   next
     case False
     have \<open>f t = \<langle>t, t\<rangle>\<close>
       using \<open>\<And>x. f x = \<langle>t, x\<rangle>\<close> by blast
     also have \<open>\<dots> = (norm t)^2\<close>
       by (meson cnorm_eq_square)
     also have \<open>\<dots> = (norm t)*(norm t)\<close>
       by (simp add: power2_eq_square)
     finally have \<open>f t = (norm t)*(norm t)\<close>
       by blast
     thus ?thesis
       by (metis False Re_complex_of_real \<open>\<And>x. f x = cinner t x\<close> cinner_ge_zero complex_of_real_cmod nonzero_divide_eq_eq)
   qed
   ultimately have \<open>Sup {(norm (f x)) / (norm x)| x. True} = norm t\<close>
     by (smt cSup_eq_maximum mem_Collect_eq)
   moreover have \<open>Sup {(norm (f x)) / (norm x)| x. True} = (SUP x. (norm (f x)) / (norm x))\<close>
     by (simp add: full_SetCompr_eq)
   ultimately show \<open>onorm f = norm t\<close>
     by (simp add: onorm_def)
 qed
 
 definition the_riesz_rep :: \<open>('a::chilbert_space \<Rightarrow>\<^sub>C\<^sub>L complex) \<Rightarrow> 'a\<close> where
   \<open>the_riesz_rep f = (SOME t. \<forall>x. f x = \<langle>t, x\<rangle>)\<close>
 
 lemma the_riesz_rep[simp]: \<open>the_riesz_rep f \<bullet>\<^sub>C x = f *\<^sub>V x\<close>
   unfolding the_riesz_rep_def
   apply (rule someI2_ex)
   by (simp_all add: riesz_frechet_representation_cblinfun_existence)
 
 lemma the_riesz_rep_unique:
   assumes \<open>\<And>x. f *\<^sub>V x = t \<bullet>\<^sub>C x\<close>
   shows \<open>t = the_riesz_rep f\<close>
   using assms riesz_frechet_representation_cblinfun_unique the_riesz_rep by metis
 
 lemma the_riesz_rep_scaleC: \<open>the_riesz_rep (c *\<^sub>C f) = cnj c *\<^sub>C the_riesz_rep f\<close>
   apply (rule the_riesz_rep_unique[symmetric])
   by auto
 
 lemma the_riesz_rep_add: \<open>the_riesz_rep (f + g) = the_riesz_rep f + the_riesz_rep g\<close>
   apply (rule the_riesz_rep_unique[symmetric])
   by (auto simp: cinner_add_left cblinfun.add_left)
 
 lemma the_riesz_rep_norm[simp]: \<open>norm (the_riesz_rep f) = norm f\<close>
   apply (rule riesz_frechet_representation_cblinfun_norm[symmetric])
   by simp
 
 lemma bounded_antilinear_the_riesz_rep[bounded_antilinear]: \<open>bounded_antilinear the_riesz_rep\<close>
   by (metis (no_types, opaque_lifting) bounded_antilinear_intro dual_order.refl mult.commute mult_1 the_riesz_rep_add the_riesz_rep_norm the_riesz_rep_scaleC)
 
 definition the_riesz_rep_bilinear' :: \<open>('a::complex_normed_vector \<Rightarrow> 'b::chilbert_space \<Rightarrow> complex) \<Rightarrow> ('a \<Rightarrow> 'b)\<close> where
   \<open>the_riesz_rep_bilinear' p x = the_riesz_rep (CBlinfun (p x))\<close>
 
 lemma the_riesz_rep_bilinear'_correct:
   assumes \<open>bounded_clinear (p x)\<close>
   shows \<open>(the_riesz_rep_bilinear' p x) \<bullet>\<^sub>C y = p x y\<close>
   by (auto simp add: the_riesz_rep_bilinear'_def assms bounded_clinear_CBlinfun_apply)
 
 
 lemma the_riesz_rep_bilinear'_plus1:
   assumes \<open>\<And>x. bounded_clinear (p x)\<close> and \<open>\<And>x. bounded_clinear (q x)\<close>
   shows \<open>the_riesz_rep_bilinear' (p + q) = the_riesz_rep_bilinear' p + the_riesz_rep_bilinear' q\<close>
   by (auto intro!: ext simp add: the_riesz_rep_add CBlinfun_plus the_riesz_rep_bilinear'_def 
       assms bounded_clinear_CBlinfun_apply)
 
 lemma the_riesz_rep_bilinear'_plus2:
   assumes \<open>bounded_sesquilinear p\<close>
   shows \<open>the_riesz_rep_bilinear' p (x + y) = the_riesz_rep_bilinear' p x + the_riesz_rep_bilinear' p y\<close>
 proof -
   have [simp]: \<open>p (x + y) = p x + p y\<close>
     using assms bounded_sesquilinear.add_left by fastforce
   have [simp]: \<open>bounded_clinear (p x)\<close> for x
     by (simp add: assms bounded_sesquilinear.bounded_clinear_right)
   show ?thesis
     by (auto intro!: ext simp add: the_riesz_rep_add CBlinfun_plus the_riesz_rep_bilinear'_def
       assms bounded_clinear_CBlinfun_apply)
 qed
 
 lemma the_riesz_rep_bilinear'_scaleC1:
   assumes \<open>\<And>x. bounded_clinear (p x)\<close>
   shows \<open>the_riesz_rep_bilinear' (\<lambda>x y. c *\<^sub>C p x y) = (\<lambda>x. cnj c *\<^sub>C the_riesz_rep_bilinear' p x)\<close>
   by (auto intro!: ext simp add: the_riesz_rep_scaleC CBlinfun_scaleC the_riesz_rep_bilinear'_def 
       assms bounded_clinear_CBlinfun_apply
       simp del: complex_scaleC_def scaleC_conv_of_complex)
 
 lemma the_riesz_rep_bilinear'_scaleC2:
   assumes \<open>bounded_sesquilinear p\<close>
   shows \<open>the_riesz_rep_bilinear' p (c *\<^sub>C x) = c *\<^sub>C the_riesz_rep_bilinear' p x\<close>
 proof -
   have [simp]: \<open>p (c *\<^sub>C x) = (\<lambda>y. cnj c *\<^sub>C p x y)\<close>
     using assms bounded_sesquilinear.scaleC_left by blast
   have [simp]: \<open>bounded_clinear (p x)\<close> for x
     by (simp add: assms bounded_sesquilinear.bounded_clinear_right)
   show ?thesis
     by (auto intro!: ext simp add: the_riesz_rep_scaleC CBlinfun_scaleC the_riesz_rep_bilinear'_def
       assms bounded_clinear_CBlinfun_apply
       simp del: complex_scaleC_def scaleC_conv_of_complex)
 qed
 
 lemma bounded_clinear_the_riesz_rep_bilinear'2:
   assumes \<open>bounded_sesquilinear p\<close>
   shows \<open>bounded_clinear (the_riesz_rep_bilinear' p)\<close>
 proof -
   obtain K0 where K0: \<open>cmod (p x y) \<le> norm x * norm y * K0\<close> for x y
     using assms bounded_sesquilinear.bounded  by blast
   define K where \<open>K = max K0 0\<close>
   with K0 have K: \<open>cmod (p x y) \<le> norm x * norm y * K\<close> for x y
     by (smt (verit, del_insts) mult_nonneg_nonneg mult_nonneg_nonpos norm_ge_zero)
   have [simp]: \<open>K \<ge> 0\<close>
     by (simp add: K_def)
   have [simp]: \<open>bounded_clinear (p x)\<close> for x
     by (simp add: assms bounded_sesquilinear.bounded_clinear_right)
   have "norm (the_riesz_rep_bilinear' p x) \<le> norm x * K" for x
     unfolding the_riesz_rep_bilinear'_def
     using K by (auto intro!: norm_cblinfun_bound simp: bounded_clinear_CBlinfun_apply mult.commute mult.left_commute)
   then show ?thesis
     apply (rule_tac bounded_clinearI)
     by (auto simp: assms the_riesz_rep_bilinear'_plus2 the_riesz_rep_bilinear'_scaleC2)
 qed
 
 lift_definition the_riesz_rep_bilinear:: \<open>('a::complex_normed_vector \<Rightarrow> 'b::chilbert_space \<Rightarrow> complex) \<Rightarrow> ('a \<Rightarrow>\<^sub>C\<^sub>L 'b)\<close> is
   \<open>\<lambda>p. if bounded_sesquilinear p then the_riesz_rep_bilinear' p else 0\<close>
   by (auto simp: bounded_clinear_the_riesz_rep_bilinear'2 zero_fun_def)
 
 lemma the_riesz_rep_bilinear_correct:
   assumes \<open>bounded_sesquilinear p\<close>
   shows \<open>(the_riesz_rep_bilinear p x) \<bullet>\<^sub>C y = p x y\<close>
   apply (transfer fixing: p)
   by (simp add: assms bounded_sesquilinear.bounded_clinear_right the_riesz_rep_bilinear'_correct)
 
 
 subsection \<open>Extension of complex bounded operators\<close>
 
 definition cblinfun_extension where
   "cblinfun_extension S \<phi> = (SOME B. \<forall>x\<in>S. B *\<^sub>V x = \<phi> x)"
 
 definition cblinfun_extension_exists where
   "cblinfun_extension_exists S \<phi> = (\<exists>B. \<forall>x\<in>S. B *\<^sub>V x = \<phi> x)"
 
 lemma cblinfun_extension_existsI:
   assumes "\<And>x. x\<in>S \<Longrightarrow> B *\<^sub>V x = \<phi> x"
   shows "cblinfun_extension_exists S \<phi>"
   using assms cblinfun_extension_exists_def by blast
 
 lemma cblinfun_extension_exists_finite_dim:
   fixes \<phi>::"'a::{complex_normed_vector,cfinite_dim} \<Rightarrow> 'b::complex_normed_vector"
   assumes "cindependent S"
     and "cspan S = UNIV"
   shows "cblinfun_extension_exists S \<phi>"
 proof-
   define f::"'a \<Rightarrow> 'b"
     where "f = complex_vector.construct S \<phi>"
   have "clinear f"
     by (simp add: complex_vector.linear_construct assms linear_construct f_def)
   have "bounded_clinear f"
     using \<open>clinear f\<close> assms by auto
   then obtain B::"'a \<Rightarrow>\<^sub>C\<^sub>L 'b"
     where "B *\<^sub>V x = f x" for x
     using cblinfun_apply_cases by blast
   have "B *\<^sub>V x = \<phi> x"
     if c1: "x\<in>S"
     for x
   proof-
     have "B *\<^sub>V x = f x"
       by (simp add: \<open>\<And>x. B *\<^sub>V x = f x\<close>)
     also have "\<dots> = \<phi> x"
       using assms complex_vector.construct_basis f_def that
       by (simp add: complex_vector.construct_basis)
     finally show?thesis by blast
   qed
   thus ?thesis
     unfolding cblinfun_extension_exists_def
     by blast
 qed
 
 lemma cblinfun_extension_apply:
   assumes "cblinfun_extension_exists S f"
     and "v \<in> S"
   shows "(cblinfun_extension S f) *\<^sub>V v = f v"
   by (smt assms cblinfun_extension_def cblinfun_extension_exists_def tfl_some)
 
 lemma
   fixes f :: \<open>'a::complex_normed_vector \<Rightarrow> 'b::cbanach\<close>
   assumes \<open>csubspace S\<close>
   assumes \<open>closure S = UNIV\<close>
   assumes f_add: \<open>\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f (x + y) = f x + f y\<close>
   assumes f_scale: \<open>\<And>c x y. x \<in> S \<Longrightarrow> f (c *\<^sub>C x) = c *\<^sub>C f x\<close>
   assumes bounded: \<open>\<And>x. x \<in> S \<Longrightarrow> norm (f x) \<le> B * norm x\<close>
   shows cblinfun_extension_exists_bounded_dense: \<open>cblinfun_extension_exists S f\<close>
     and cblinfun_extension_exists_norm: \<open>B \<ge> 0 \<Longrightarrow> norm (cblinfun_extension S f) \<le> B\<close>
 proof -
   define B' where \<open>B' = (if B\<le>0 then 1 else B)\<close>
   then have bounded': \<open>\<And>x. x \<in> S \<Longrightarrow> norm (f x) \<le> B' * norm x\<close>
     using bounded by (metis mult_1 mult_le_0_iff norm_ge_zero order_trans)
   have \<open>B' > 0\<close>
     by (simp add: B'_def)
 
   have \<open>\<exists>xi. (xi \<longlonglongrightarrow> x) \<and> (\<forall>i. xi i \<in> S)\<close> for x
     using assms(2) closure_sequential by blast
   then obtain seq :: \<open>'a \<Rightarrow> nat \<Rightarrow> 'a\<close> where seq_lim: \<open>seq x \<longlonglongrightarrow> x\<close> and seq_S: \<open>seq x i \<in> S\<close> for x i
     apply (atomize_elim, subst all_conj_distrib[symmetric])
     apply (rule choice)
     by auto
   define g where \<open>g x = lim (\<lambda>i. f (seq x i))\<close> for x
   have \<open>Cauchy (\<lambda>i. f (seq x i))\<close> for x
   proof (rule CauchyI)
     fix e :: real assume \<open>e > 0\<close>
     have \<open>Cauchy (seq x)\<close>
       using LIMSEQ_imp_Cauchy seq_lim by blast
     then obtain M where less_eB: \<open>norm (seq x m - seq x n) < e/B'\<close> if \<open>n \<ge> M\<close> and \<open>m \<ge> M\<close> for n m
       apply atomize_elim by (meson CauchyD \<open>0 < B'\<close> \<open>0 < e\<close> linordered_field_class.divide_pos_pos)
     have \<open>norm (f (seq x m) - f (seq x n)) < e\<close> if \<open>n \<ge> M\<close> and \<open>m \<ge> M\<close> for n m
     proof -
       have \<open>norm (f (seq x m) - f (seq x n)) = norm (f (seq x m - seq x n))\<close>
         using f_add f_scale seq_S
         by (metis add_diff_cancel assms(1) complex_vector.subspace_diff diff_add_cancel)
       also have \<open>\<dots> \<le> B' * norm (seq x m - seq x n)\<close>
         apply (rule bounded')
         by (simp add: assms(1) complex_vector.subspace_diff seq_S)
       also from less_eB have \<open>\<dots> < B' * (e/B')\<close>
         by (meson \<open>0 < B'\<close> linordered_semiring_strict_class.mult_strict_left_mono that)
       also have \<open>\<dots> \<le> e\<close>
         using \<open>0 < B'\<close> by auto
       finally show ?thesis
         by -
     qed
     then show \<open>\<exists>M. \<forall>m\<ge>M. \<forall>n\<ge>M. norm (f (seq x m) - f (seq x n)) < e\<close>
       by auto
   qed
   then have f_seq_lim: \<open>(\<lambda>i. f (seq x i)) \<longlonglongrightarrow> g x\<close> for x
     by (simp add: Cauchy_convergent_iff convergent_LIMSEQ_iff g_def)
   have f_xi_lim: \<open>(\<lambda>i. f (xi i)) \<longlonglongrightarrow> g x\<close> if \<open>xi \<longlonglongrightarrow> x\<close> and \<open>\<And>i. xi i \<in> S\<close> for xi x
   proof -
     from seq_lim that
     have \<open>(\<lambda>i. B' * norm (xi i - seq x i)) \<longlonglongrightarrow> 0\<close>
       by (metis (no_types) \<open>0 < B'\<close> cancel_comm_monoid_add_class.diff_cancel norm_not_less_zero norm_zero tendsto_diff tendsto_norm_zero_iff tendsto_zero_mult_left_iff)
     then have \<open>(\<lambda>i. f (xi i + (-1) *\<^sub>C seq x i)) \<longlonglongrightarrow> 0\<close>
       apply (rule Lim_null_comparison[rotated])
       using bounded' by (simp add: assms(1) complex_vector.subspace_diff seq_S that(2))
     then have \<open>(\<lambda>i. f (xi i) - f (seq x i)) \<longlonglongrightarrow> 0\<close>
       apply (subst (asm) f_add)
         apply (auto simp: that \<open>csubspace S\<close> complex_vector.subspace_neg seq_S)[2]
       apply (subst (asm) f_scale)
       by (auto simp: that \<open>csubspace S\<close> complex_vector.subspace_neg seq_S)
     then show \<open>(\<lambda>i. f (xi i)) \<longlonglongrightarrow> g x\<close>
       using Lim_transform f_seq_lim by fastforce
   qed
   have g_add: \<open>g (x + y) = g x + g y\<close> for x y
   proof -
     obtain xi :: \<open>nat \<Rightarrow> 'a\<close> where \<open>xi \<longlonglongrightarrow> x\<close> and \<open>xi i \<in> S\<close> for i
       using seq_S seq_lim by auto
     obtain yi :: \<open>nat \<Rightarrow> 'a\<close> where \<open>yi \<longlonglongrightarrow> y\<close> and \<open>yi i \<in> S\<close> for i
       using seq_S seq_lim by auto
     have \<open>(\<lambda>i. xi i + yi i) \<longlonglongrightarrow> x + y\<close>
       using \<open>xi \<longlonglongrightarrow> x\<close> \<open>yi \<longlonglongrightarrow> y\<close> tendsto_add by blast
     then have lim1: \<open>(\<lambda>i. f (xi i + yi i)) \<longlonglongrightarrow> g (x + y)\<close>
       by (simp add: \<open>\<And>i. xi i \<in> S\<close> \<open>\<And>i. yi i \<in> S\<close> assms(1) complex_vector.subspace_add f_xi_lim)
     have \<open>(\<lambda>i. f (xi i + yi i)) = (\<lambda>i. f (xi i) + f (yi i))\<close>
       by (simp add: \<open>\<And>i. xi i \<in> S\<close> \<open>\<And>i. yi i \<in> S\<close> f_add)
     also have \<open>\<dots> \<longlonglongrightarrow> g x + g y\<close>
       by (simp add: \<open>\<And>i. xi i \<in> S\<close> \<open>\<And>i. yi i \<in> S\<close> \<open>xi \<longlonglongrightarrow> x\<close> \<open>yi \<longlonglongrightarrow> y\<close> f_xi_lim tendsto_add)
     finally show ?thesis
       using lim1 LIMSEQ_unique by blast
   qed
   have g_scale: \<open>g (c *\<^sub>C x) = c *\<^sub>C g x\<close> for c x
   proof -
     obtain xi :: \<open>nat \<Rightarrow> 'a\<close> where \<open>xi \<longlonglongrightarrow> x\<close> and \<open>xi i \<in> S\<close> for i
       using seq_S seq_lim by auto
     have \<open>(\<lambda>i. c *\<^sub>C xi i) \<longlonglongrightarrow> c *\<^sub>C x\<close>
       using \<open>xi \<longlonglongrightarrow> x\<close> bounded_clinear_scaleC_right clinear_continuous_at isCont_tendsto_compose by blast
     then have lim1: \<open>(\<lambda>i. f (c *\<^sub>C xi i)) \<longlonglongrightarrow> g (c *\<^sub>C x)\<close>
       by (simp add: \<open>\<And>i. xi i \<in> S\<close> assms(1) complex_vector.subspace_scale f_xi_lim)
     have \<open>(\<lambda>i. f (c *\<^sub>C xi i)) = (\<lambda>i. c *\<^sub>C f (xi i))\<close>
       by (simp add: \<open>\<And>i. xi i \<in> S\<close> f_scale)
     also have \<open>\<dots> \<longlonglongrightarrow> c *\<^sub>C g x\<close>
       using \<open>\<And>i. xi i \<in> S\<close> \<open>xi \<longlonglongrightarrow> x\<close> bounded_clinear_scaleC_right clinear_continuous_at f_xi_lim isCont_tendsto_compose by blast
     finally show ?thesis
       using lim1 LIMSEQ_unique by blast
   qed
 
   have [simp]: \<open>f x = g x\<close> if \<open>x \<in> S\<close> for x
   proof -
     have \<open>(\<lambda>_. x) \<longlonglongrightarrow> x\<close>
       by auto
     then have \<open>(\<lambda>_. f x) \<longlonglongrightarrow> g x\<close>
       using that by (rule f_xi_lim)
     then show \<open>f x = g x\<close>
       by (simp add: LIMSEQ_const_iff)
   qed
 
   have g_bounded: \<open>norm (g x) \<le> B' * norm x\<close> for x
   proof -
     obtain xi :: \<open>nat \<Rightarrow> 'a\<close> where \<open>xi \<longlonglongrightarrow> x\<close> and \<open>xi i \<in> S\<close> for i
       using seq_S seq_lim by auto
     then have \<open>(\<lambda>i. f (xi i)) \<longlonglongrightarrow> g x\<close>
       using f_xi_lim by presburger
     then have \<open>(\<lambda>i. norm (f (xi i))) \<longlonglongrightarrow> norm (g x)\<close>
       by (metis tendsto_norm)
     moreover have \<open>(\<lambda>i. B' * norm (xi i)) \<longlonglongrightarrow> B' * norm x\<close>
       by (simp add: \<open>xi \<longlonglongrightarrow> x\<close> tendsto_mult_left tendsto_norm)
     ultimately show \<open>norm (g x) \<le> B' * norm x\<close>
       apply (rule lim_mono[rotated])
       using bounded' using \<open>xi _ \<in> S\<close> by blast
   qed
 
   have \<open>bounded_clinear g\<close>
     using g_add g_scale apply (rule bounded_clinearI[where K=B'])
     using g_bounded by (simp add: ordered_field_class.sign_simps(5))
   then have [simp]: \<open>CBlinfun g *\<^sub>V x = g x\<close> for x
     by (subst CBlinfun_inverse, auto)
 
   show \<open>cblinfun_extension_exists S f\<close>
     apply (rule cblinfun_extension_existsI[where B=\<open>CBlinfun g\<close>])
     by auto
 
   then have \<open>cblinfun_extension S f *\<^sub>V \<psi> = CBlinfun g *\<^sub>V \<psi>\<close> if \<open>\<psi> \<in> S\<close> for \<psi>
     by (simp add: cblinfun_extension_apply that)
 
   then have ext_is_g: \<open>(*\<^sub>V) (cblinfun_extension S f) = g\<close>
     apply (rule_tac ext)
     apply (rule on_closure_eqI[where S=S])
     using  \<open>closure S = UNIV\<close> \<open>bounded_clinear g\<close>
     by (auto simp add: continuous_at_imp_continuous_on clinear_continuous_within)
 
   show \<open>norm (cblinfun_extension S f) \<le> B\<close> if \<open>B \<ge> 0\<close>
   proof (cases \<open>B > 0\<close>)
     case True
     then have \<open>B = B'\<close>
       unfolding B'_def
       by auto
     moreover have *: \<open>norm (cblinfun_extension S f) \<le> B'\<close>
       by (metis ext_is_g \<open>0 < B'\<close> g_bounded norm_cblinfun_bound order_le_less)
     ultimately show ?thesis
       by simp
   next
     case False
     with bounded have \<open>f x = 0\<close> if \<open>x \<in> S\<close> for x
       by (smt (verit) mult_nonpos_nonneg norm_ge_zero norm_le_zero_iff that)
     then have \<open>g x = (\<lambda>_. 0) x\<close> if \<open>x \<in> S\<close> for x
       using that by simp
     then have \<open>g x = 0\<close> for x
       apply (rule on_closure_eqI[where S=S])
       using \<open>closure S = UNIV\<close> \<open>bounded_clinear g\<close>
       by (auto simp add: continuous_at_imp_continuous_on clinear_continuous_within)
     with ext_is_g have \<open>cblinfun_extension S f = 0\<close>
       by (simp add: cblinfun_eqI)
     then show ?thesis
       using that by simp
   qed
 qed
 
 lemma cblinfun_extension_cong:
   assumes \<open>cspan A = cspan B\<close>
   assumes \<open>B \<subseteq> A\<close>
   assumes fg: \<open>\<And>x. x\<in>B \<Longrightarrow> f x = g x\<close>
   assumes \<open>cblinfun_extension_exists A f\<close>
   shows \<open>cblinfun_extension A f = cblinfun_extension B g\<close>
 proof -
   from \<open>cblinfun_extension_exists A f\<close> fg \<open>B \<subseteq> A\<close>
   have \<open>cblinfun_extension_exists B g\<close>
     by (metis assms(2) cblinfun_extension_exists_def subset_eq)
 
   have \<open>(\<forall>x\<in>A. C *\<^sub>V x = f x) \<longleftrightarrow> (\<forall>x\<in>B. C *\<^sub>V x = f x)\<close> for C
     by (smt (verit, ccfv_SIG) assms(1) assms(2) assms(4) cblinfun_eq_on_span cblinfun_extension_exists_def complex_vector.span_eq subset_iff)
   also from fg have \<open>\<dots> C \<longleftrightarrow> (\<forall>x\<in>B. C *\<^sub>V x = g x)\<close> for C
     by auto
   finally show \<open>cblinfun_extension A f = cblinfun_extension B g\<close>
     unfolding cblinfun_extension_def
     by auto
 qed
 
 lemma
   fixes f :: \<open>'a::complex_inner \<Rightarrow> 'b::chilbert_space\<close> and S 
   assumes \<open>is_ortho_set S\<close> and \<open>closure (cspan S) = UNIV\<close>
   assumes ortho_f: \<open>\<And>x y. x\<in>S \<Longrightarrow> y\<in>S \<Longrightarrow> x\<noteq>y \<Longrightarrow> is_orthogonal (f x) (f y)\<close>
   assumes bounded: \<open>\<And>x. x \<in> S \<Longrightarrow> norm (f x) \<le> B * norm x\<close>
   shows cblinfun_extension_exists_ortho: \<open>cblinfun_extension_exists S f\<close>
     and cblinfun_extension_exists_ortho_norm: \<open>B \<ge> 0 \<Longrightarrow> norm (cblinfun_extension S f) \<le> B\<close>
 proof -
   define g where \<open>g = cconstruct S f\<close>
   have \<open>cindependent S\<close>
     using assms(1) is_ortho_set_cindependent by blast
   have g_f: \<open>g x = f x\<close> if \<open>x\<in>S\<close> for x
     unfolding g_def using \<open>cindependent S\<close> that by (rule complex_vector.construct_basis)
   have [simp]: \<open>clinear g\<close>
     unfolding g_def using \<open>cindependent S\<close> by (rule complex_vector.linear_construct)
   then have g_add: \<open>g (x + y) = g x + g y\<close> if \<open>x \<in> cspan S\<close> and \<open>y \<in> cspan S\<close> for x y
     using clinear_iff by blast
   from \<open>clinear g\<close> have g_scale: \<open>g (c *\<^sub>C x) = c *\<^sub>C g x\<close> if \<open>x \<in> cspan S\<close> for x c
     by (simp add: complex_vector.linear_scale)
   moreover have g_bounded: \<open>norm (g x) \<le> abs B * norm x\<close> if \<open>x \<in> cspan S\<close> for x
   proof -
     from that obtain t r where x_sum: \<open>x = (\<Sum>a\<in>t. r a *\<^sub>C a)\<close> and \<open>finite t\<close> and \<open>t \<subseteq> S\<close>
       unfolding complex_vector.span_explicit by auto
     have \<open>(norm (g x))\<^sup>2 = (norm (\<Sum>a\<in>t. r a *\<^sub>C g a))\<^sup>2\<close>
       by (simp add: x_sum complex_vector.linear_sum clinear.scaleC)
     also have \<open>\<dots> = (norm (\<Sum>a\<in>t. r a *\<^sub>C f a))\<^sup>2\<close>
       by (smt (verit) \<open>t \<subseteq> S\<close> g_f in_mono sum.cong)
     also have \<open>\<dots> = (\<Sum>a\<in>t. (norm (r a *\<^sub>C f a))\<^sup>2)\<close>
       using _ \<open>finite t\<close> apply (rule pythagorean_theorem_sum)
       using \<open>t \<subseteq> S\<close> ortho_f in_mono by fastforce
     also have \<open>\<dots> = (\<Sum>a\<in>t. (cmod (r a) * norm (f a))\<^sup>2)\<close>
       by simp
     also have \<open>\<dots> \<le> (\<Sum>a\<in>t. (cmod (r a) * B * norm a)\<^sup>2)\<close>
       apply (rule sum_mono)
       by (metis \<open>t \<subseteq> S\<close> assms(4) in_mono mult_left_mono mult_nonneg_nonneg norm_ge_zero power_mono vector_space_over_itself.scale_scale)
     also have \<open>\<dots> = B\<^sup>2 * (\<Sum>a\<in>t. (norm (r a *\<^sub>C a))\<^sup>2)\<close>
       by (simp add: sum_distrib_left mult.commute vector_space_over_itself.scale_left_commute flip: power_mult_distrib)
     also have \<open>\<dots> = B\<^sup>2 * (norm (\<Sum>a\<in>t. (r a *\<^sub>C a)))\<^sup>2\<close>
       apply (subst pythagorean_theorem_sum)
       using \<open>finite t\<close> apply auto
       by (meson \<open>t \<subseteq> S\<close> assms(1) is_ortho_set_def subsetD)
     also have \<open>\<dots> = (abs B * norm x)\<^sup>2\<close>
       by (simp add: power_mult_distrib x_sum)
     finally show \<open>norm (g x) \<le> abs B * norm x\<close>
       by auto
   qed
   
   from g_add g_scale g_bounded
   have extg_exists: \<open>cblinfun_extension_exists (cspan S) g\<close>
     apply (rule_tac cblinfun_extension_exists_bounded_dense[where B=\<open>abs B\<close>])
     using \<open>closure (cspan S) = UNIV\<close> by auto
 
   then show \<open>cblinfun_extension_exists S f\<close>
     by (metis (mono_tags, opaque_lifting) g_f cblinfun_extension_apply cblinfun_extension_existsI complex_vector.span_base)
 
   have norm_extg: \<open>norm (cblinfun_extension (cspan S) g) \<le> B\<close> if \<open>B \<ge> 0\<close>
     apply (rule cblinfun_extension_exists_norm)
     using g_add g_scale g_bounded \<open>closure (cspan S) = UNIV\<close> that by auto
 
   have extg_extf: \<open>cblinfun_extension (cspan S) g = cblinfun_extension S f\<close>
     apply (rule cblinfun_extension_cong)
     by (auto simp add: complex_vector.span_base g_f extg_exists)
 
   from norm_extg extg_extf
   show \<open>norm (cblinfun_extension S f) \<le> B\<close> if \<open>B \<ge> 0\<close>
     using that by simp
 qed
 
 
 lemma cblinfun_extension_exists_proj:
   fixes f :: \<open>'a::complex_normed_vector \<Rightarrow> 'b::cbanach\<close>
   assumes \<open>csubspace S\<close>
   assumes \<open>\<exists>P. is_projection_on P (closure S) \<and> bounded_clinear P\<close> (* Maybe can be replaced by is_Proj if the latter's type class is widened *)
   assumes f_add: \<open>\<And>x y. x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> f (x + y) = f x + f y\<close>
   assumes f_scale: \<open>\<And>c x y. x \<in> S \<Longrightarrow> f (c *\<^sub>C x) = c *\<^sub>C f x\<close>
   assumes bounded: \<open>\<And>x. x \<in> S \<Longrightarrow> norm (f x) \<le> B * norm x\<close>
   shows \<open>cblinfun_extension_exists S f\<close>
 proof (cases \<open>B \<ge> 0\<close>)
   case True
   note True[simp]
   obtain P where P_proj: \<open>is_projection_on P (closure S)\<close> and P_blin[simp]: \<open>bounded_clinear P\<close>
     using assms(2) by blast 
   have P_lin[simp]: \<open>clinear P\<close>
     by (simp add: bounded_clinear.clinear)
   define f' S' where \<open>f' \<psi> = f (P \<psi>)\<close> and \<open>S' = S + (P -` {0})\<close> for \<psi>
   have \<open>csubspace S'\<close>
     by (simp add: S'_def assms(1) csubspace_set_plus)
   moreover have \<open>closure S' = UNIV\<close>
   proof auto
     fix \<psi>
     have \<open>\<psi> = P \<psi> + (id - P) \<psi>\<close>
       by simp
     also have \<open>\<dots> \<in> closure S + (P -` {0})\<close>
       apply (rule set_plus_intro) 
       using P_proj is_projection_on_in_image 
       by (auto simp: complex_vector.linear_diff is_projection_on_fixes_image is_projection_on_in_image)
     also have \<open>\<dots> \<subseteq> closure (closure S + (P -` {0}))\<close>
       using closure_subset by blast
     also have \<open>\<dots> = closure (S + (P -` {0}))\<close>
       using closed_sum_closure_left closed_sum_def by blast
     also have \<open>\<dots> = closure S'\<close>
       using S'_def by fastforce
     finally show \<open>\<psi> \<in> closure S'\<close>
       by -
   qed
 
   moreover have \<open>f' (x + y) = f' x + f' y\<close> if \<open>x \<in> S'\<close> and \<open>y \<in> S'\<close> for x y
     by (smt (z3) P_blin P_proj S'_def f'_def add.right_neutral bounded_clinear_CBlinfun_apply cblinfun.add_right closure_subset f_add is_projection_on_fixes_image set_plus_elim singletonD subset_eq that(1) that(2) vimageE)
   moreover have \<open>f' (c *\<^sub>C x) = c *\<^sub>C f' x\<close> if \<open>x \<in> S'\<close> for c x
     by (smt (verit, ccfv_SIG) P_blin P_proj S'_def f'_def add.right_neutral bounded_clinear_CBlinfun_apply cblinfun.add_right cblinfun.scaleC_right closure_subset f_scale is_projection_on_fixes_image set_plus_elim singletonD subset_eq that vimageE)
 
   moreover 
   from P_blin obtain B' where B': \<open>norm (P x) \<le> B' * norm x\<close> for x
     by (metis bounded_clinear.bounded mult.commute)
   have \<open>norm (f' x) \<le> (B * B') * norm x\<close> if \<open>x \<in> S'\<close> for x
   proof -
     have \<open>norm (f' x) \<le> B* norm (P x)\<close>
       apply (auto simp: f'_def)
       by (smt (verit) P_blin P_proj S'_def add.right_neutral bounded bounded_clinear_CBlinfun_apply cblinfun.add_right closure_subset is_projection_on_fixes_image set_plus_elim singletonD subset_eq that vimageE)
     also have \<open>\<dots> \<le> B * B' * norm x\<close>
       by (simp add: B' mult.assoc mult_mono)
     finally show ?thesis
       by auto
   qed
 
   ultimately have F_ex: \<open>cblinfun_extension_exists S' f'\<close>
     by (rule cblinfun_extension_exists_bounded_dense)
   define F where \<open>F = cblinfun_extension S' f'\<close>
   from F_ex have *: \<open>F \<psi> = f' \<psi>\<close> if \<open>\<psi> \<in> S'\<close> for \<psi>
     by (simp add: F_def cblinfun_extension_apply that)
   then have \<open>F \<psi> = f \<psi>\<close> if \<open>\<psi> \<in> S\<close> for \<psi>
     apply (auto simp: S'_def f'_def)
     by (metis (no_types, lifting) P_lin P_proj add.right_neutral closure_subset complex_vector.linear_subspace_vimage complex_vector.subspace_0 complex_vector.subspace_single_0 is_projection_on_fixes_image set_plus_intro subset_eq that)
   then show \<open>cblinfun_extension_exists S f\<close>
     using cblinfun_extension_exists_def by blast
 next
   case False
   then have \<open>S \<subseteq> {0}\<close>
     using bounded apply auto
     by (meson norm_ge_zero norm_le_zero_iff order_trans zero_le_mult_iff)
   then show \<open>cblinfun_extension_exists S f\<close>
     apply (rule_tac cblinfun_extension_existsI[where B=0])
     apply auto
     using bounded by fastforce
 qed
 
 subsection \<open>Bijections between different ONBs\<close>
 
 text \<open>Some of the theorems here logically belong into \<^theory>\<open>Complex_Bounded_Operators.Complex_Inner_Product\<close>
   but the proof uses some concepts from the present theory.\<close>
 
 (* TODO mention: follows conway functional, Prop 4.14 *)
 lemma all_ortho_bases_same_card:
   fixes E F :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_ortho_set E\<close> \<open>is_ortho_set F\<close> \<open>ccspan E = top\<close> \<open>ccspan F = top\<close>
   shows \<open>\<exists>f. bij_betw f E F\<close>
 proof -
   have \<open>|F| \<le>o |E|\<close> if \<open>infinite E\<close> and
     \<open>is_ortho_set E\<close> \<open>is_ortho_set F\<close> \<open>ccspan E = top\<close> \<open>ccspan F = top\<close> for E F :: \<open>'a set\<close>
   proof -
     define F' where \<open>F' e = {f\<in>F. \<not> is_orthogonal f e}\<close> for e
     have \<open>\<exists>e\<in>E. cinner f e \<noteq> 0\<close> if \<open>f \<in> F\<close> for f
     proof (rule ccontr, simp)
       assume \<open>\<forall>e\<in>E. is_orthogonal f e\<close>
       then have \<open>f \<in> orthogonal_complement E\<close>
         by (simp add: orthogonal_complementI)
       also have \<open>\<dots> = orthogonal_complement (closure (cspan E))\<close>
         using orthogonal_complement_of_closure orthogonal_complement_of_cspan by blast
       also have \<open>\<dots> = space_as_set (- ccspan E)\<close>
         apply transfer by simp
       also have \<open>\<dots> = space_as_set (- top)\<close>
         by (simp add: \<open>ccspan E = top\<close>)
       also have \<open>\<dots> = {0}\<close>
         by (auto simp add: top_ccsubspace.rep_eq uminus_ccsubspace.rep_eq)
       finally have \<open>f = 0\<close>
         by simp
       with \<open>f \<in> F\<close> \<open>is_ortho_set F\<close> show False
         by (simp add: is_onb_def is_ortho_set_def)
     qed
     then have F'_union: \<open>F = (\<Union>e\<in>E. F' e)\<close>
       unfolding F'_def by auto
     have \<open>countable (F' e)\<close> for e
     proof -
       have \<open>(\<Sum>f\<in>M. (cmod (cinner (sgn f) e))\<^sup>2) \<le> (norm e)\<^sup>2\<close> if \<open>finite M\<close> and \<open>M \<subseteq> F\<close> for M
       proof -
         have [simp]: \<open>is_ortho_set M\<close>
           using \<open>is_ortho_set F\<close> is_ortho_set_antimono that(2) by blast
         have [simp]: \<open>norm (sgn f) = 1\<close> if \<open>f \<in> M\<close> for f
           by (metis \<open>is_ortho_set M\<close> is_ortho_set_def norm_sgn that)
         have \<open>(\<Sum>f\<in>M. (cmod (cinner (sgn f) e))\<^sup>2) = (\<Sum>f\<in>M. (norm ((cinner (sgn f) e) *\<^sub>C sgn f))\<^sup>2)\<close>
           apply (rule sum.cong[OF refl])
           by simp
         also have \<open>\<dots> = (norm (\<Sum>f\<in>M. ((cinner (sgn f) e) *\<^sub>C sgn f)))\<^sup>2\<close>
           apply (rule pythagorean_theorem_sum[symmetric])
           using that apply auto
           by (meson \<open>is_ortho_set M\<close> is_ortho_set_def)
         also have \<open>\<dots> = (norm (\<Sum>f\<in>M. proj f e))\<^sup>2\<close>
           by (metis butterfly_apply butterfly_sgn_eq_proj)
         also have \<open>\<dots> = (norm (Proj (ccspan M) e))\<^sup>2\<close>
           apply (rule arg_cong[where f=\<open>\<lambda>x. (norm x)\<^sup>2\<close>])
           using \<open>finite M\<close> \<open>is_ortho_set M\<close> apply induction
            apply simp
           by (smt (verit, ccfv_threshold) Proj_orthog_ccspan_insert insertCI is_ortho_set_def plus_cblinfun.rep_eq sum.insert)
         also have \<open>\<dots> \<le> (norm (Proj (ccspan M)) * norm e)\<^sup>2\<close>
           by (auto simp: norm_cblinfun intro!: power_mono)
         also have \<open>\<dots> \<le> (norm e)\<^sup>2\<close>
           apply (rule power_mono)
            apply (metis norm_Proj_leq1 mult_left_le_one_le norm_ge_zero)
           by simp
         finally show ?thesis
           by -
       qed
       then have \<open>(\<lambda>f. (cmod (cinner (sgn f) e))\<^sup>2) abs_summable_on F\<close>
         apply (intro nonneg_bdd_above_summable_on bdd_aboveI)
         by auto
       then have \<open>countable {f \<in> F. (cmod (sgn f \<bullet>\<^sub>C e))\<^sup>2 \<noteq> 0}\<close>
         by (rule abs_summable_countable)
       then have \<open>countable {f \<in> F. \<not> is_orthogonal (sgn f) e}\<close>
         by force
       then have \<open>countable {f \<in> F. \<not> is_orthogonal f e}\<close>
         by force
       then show ?thesis
         unfolding F'_def by simp
     qed
     then have F'_leq: \<open>|F' e| \<le>o natLeq\<close> for e
       using countable_leq_natLeq by auto
 
     from F'_union have \<open>|F| \<le>o |Sigma E F'|\<close> (is \<open>_ \<le>o \<dots>\<close>)
       using card_of_UNION_Sigma by blast
     also have \<open>\<dots> \<le>o |E \<times> (UNIV::nat set)|\<close> (is \<open>_ \<le>o \<dots>\<close>)
       apply (rule card_of_Sigma_mono1)
       using F'_leq
       using card_of_nat ordIso_symmetric ordLeq_ordIso_trans by blast
     also have \<open>\<dots> =o |E| *c natLeq\<close> (is \<open>ordIso2 _ \<dots>\<close>)
       by (metis Field_card_of Field_natLeq card_of_ordIso_subst cprod_def)
     also have \<open>\<dots> =o |E|\<close>
       apply (rule card_prod_omega)
       using that by (simp add: cinfinite_def)
     finally show \<open>|F| \<le>o |E|\<close>
       by -
   qed
   then have infinite: \<open>|E| =o |F|\<close> if \<open>infinite E\<close> and \<open>infinite F\<close>
     by (simp add: assms ordIso_iff_ordLeq that(1) that(2))
 
   have \<open>|E| =o |F|\<close> if \<open>finite E\<close> and \<open>is_ortho_set E\<close> \<open>is_ortho_set F\<close> \<open>ccspan E = top\<close> \<open>ccspan F = top\<close>
     for E F :: \<open>'a set\<close>
   proof -
     have \<open>card E = card F\<close>
       using that 
       by (metis bij_betw_same_card ccspan.rep_eq closure_finite_cspan complex_vector.bij_if_span_eq_span_bases 
           complex_vector.independent_span_bound is_ortho_set_cindependent top_ccsubspace.rep_eq top_greatest)
     with \<open>finite E\<close> have \<open>finite F\<close>
       by (metis ccspan.rep_eq closure_finite_cspan complex_vector.independent_span_bound is_ortho_set_cindependent that(3) that(4) top_ccsubspace.rep_eq top_greatest)
     with \<open>card E = card F\<close> that show ?thesis
       apply (rule_tac finite_card_of_iff_card[THEN iffD2])
       by auto
   qed
 
   with infinite assms have \<open>|E| =o |F|\<close>
     by (meson ordIso_symmetric)
 
   then show ?thesis
     by (simp add: card_of_ordIso)
 qed
 
 lemma all_onbs_same_card:
   fixes E F :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_onb E\<close> \<open>is_onb F\<close>
   shows \<open>\<exists>f. bij_betw f E F\<close>
   apply (rule all_ortho_bases_same_card)
   using assms by (auto simp: is_onb_def)
 
 definition bij_between_bases where \<open>bij_between_bases E F = (SOME f. bij_betw f E F)\<close> for E F :: \<open>'a::chilbert_space set\<close>
 
 lemma
   fixes E F :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_onb E\<close> \<open>is_onb F\<close>
   shows bij_between_bases_bij: \<open>bij_betw (bij_between_bases E F) E F\<close>
   using all_onbs_same_card
   by (metis assms(1) assms(2) bij_between_bases_def someI)
 
 definition unitary_between where \<open>unitary_between E F = cblinfun_extension E (bij_between_bases E F)\<close>
 
 lemma unitary_between_apply:
   fixes E F :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_onb E\<close> \<open>is_onb F\<close> \<open>e \<in> E\<close>
   shows \<open>unitary_between E F *\<^sub>V e = bij_between_bases E F e\<close>
 proof -
   from \<open>is_onb E\<close> \<open>is_onb F\<close>
   have EF: \<open>bij_between_bases E F e \<in> F\<close> if \<open>e \<in> E\<close> for e
     by (meson bij_betwE bij_between_bases_bij that)
   have ortho: \<open>is_orthogonal (bij_between_bases E F x) (bij_between_bases E F y)\<close> if \<open>x \<noteq> y\<close> and \<open>x \<in> E\<close> and \<open>y \<in> E\<close> for x y
     by (smt (verit, del_insts) assms(1) assms(2) bij_betw_iff_bijections bij_between_bases_bij is_onb_def is_ortho_set_def that(1) that(2) that(3))
   have spanE: \<open>closure (cspan E) = UNIV\<close>
     by (metis assms(1) ccspan.rep_eq is_onb_def top_ccsubspace.rep_eq)
   show ?thesis
     unfolding unitary_between_def
     apply (rule cblinfun_extension_apply)
      apply (rule cblinfun_extension_exists_ortho[where B=1])
     using assms EF ortho spanE
     by (auto simp: is_onb_def)
 qed
 
 lemma unitary_between_unitary:
   fixes E F :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_onb E\<close> \<open>is_onb F\<close>
   shows \<open>unitary (unitary_between E F)\<close>
 proof -
   have \<open>(unitary_between E F *\<^sub>V b) \<bullet>\<^sub>C (unitary_between E F *\<^sub>V c) = b \<bullet>\<^sub>C c\<close> if \<open>b \<in> E\<close> and \<open>c \<in> E\<close> for b c
   proof (cases \<open>b = c\<close>)
     case True
     from \<open>is_onb E\<close> that have 1: \<open>b \<bullet>\<^sub>C b = 1\<close>
       using cnorm_eq_1 is_onb_def by blast
     from that have \<open>unitary_between E F *\<^sub>V b \<in> F\<close>
       by (metis assms(1) assms(2) bij_betw_apply bij_between_bases_bij unitary_between_apply)
     with \<open>is_onb F\<close> have 2: \<open>(unitary_between E F *\<^sub>V b) \<bullet>\<^sub>C (unitary_between E F *\<^sub>V b) = 1\<close>
       by (simp add: cnorm_eq_1 is_onb_def)
     from 1 2 True show ?thesis
       by simp
   next
     case False
     from \<open>is_onb E\<close> that have 1: \<open>b \<bullet>\<^sub>C c = 0\<close>
       by (simp add: False is_onb_def is_ortho_set_def)
     from that have inF: \<open>unitary_between E F *\<^sub>V b \<in> F\<close> \<open>unitary_between E F *\<^sub>V c \<in> F\<close>
       by (metis assms(1) assms(2) bij_betw_apply bij_between_bases_bij unitary_between_apply)+
     have neq: \<open>unitary_between E F *\<^sub>V b \<noteq> unitary_between E F *\<^sub>V c\<close>
       by (metis (no_types, lifting) False assms(1) assms(2) bij_betw_iff_bijections bij_between_bases_bij that(1) that(2) unitary_between_apply)
     from inF neq \<open>is_onb F\<close> have 2: \<open>(unitary_between E F *\<^sub>V b) \<bullet>\<^sub>C (unitary_between E F *\<^sub>V c) = 0\<close>
       by (simp add: is_onb_def is_ortho_set_def)
     from 1 2 show ?thesis
       by simp
   qed
   then have iso: \<open>isometry (unitary_between E F)\<close>
     apply (rule_tac orthogonal_on_basis_is_isometry[where B=E])
     using assms(1) is_onb_def by auto
   have \<open>unitary_between E F *\<^sub>S top = unitary_between E F *\<^sub>S ccspan E\<close>
     by (metis assms(1) is_onb_def)
   also have \<open>\<dots> \<ge> ccspan (unitary_between E F ` E)\<close> (is \<open>_ \<ge> \<dots>\<close>)
     by (simp add: cblinfun_image_ccspan)
   also have \<open>\<dots> = ccspan (bij_between_bases E F ` E)\<close>
     by (metis assms(1) assms(2) image_cong unitary_between_apply)
   also have \<open>\<dots> = ccspan F\<close>
     by (metis assms(1) assms(2) bij_betw_imp_surj_on bij_between_bases_bij)
   also have \<open>\<dots> = top\<close>
     using assms(2) is_onb_def by blast
   finally have surj: \<open>unitary_between E F *\<^sub>S top = top\<close>
     by (simp add: top.extremum_unique)
   from iso surj show ?thesis
     by (rule surj_isometry_is_unitary)
 qed
 
 subsection \<open>Notation\<close>
 
 bundle cblinfun_notation begin
 notation cblinfun_compose (infixl "o\<^sub>C\<^sub>L" 67)
 notation cblinfun_apply (infixr "*\<^sub>V" 70)
 notation cblinfun_image (infixr "*\<^sub>S" 70)
 notation adj ("_*" [99] 100)
 end
 
 bundle no_cblinfun_notation begin
 no_notation cblinfun_compose (infixl "o\<^sub>C\<^sub>L" 67)
 no_notation cblinfun_apply (infixr "*\<^sub>V" 70)
 no_notation cblinfun_image (infixr "*\<^sub>S" 70)
 no_notation adj ("_*" [99] 100)
 end
 
 bundle blinfun_notation begin
 notation blinfun_apply (infixr "*\<^sub>V" 70)
 end
 
 bundle no_blinfun_notation begin
 no_notation blinfun_apply (infixr "*\<^sub>V" 70)
 end
 
 unbundle no_cblinfun_notation
 unbundle no_lattice_syntax
 
 end
diff --git a/thys/Complex_Bounded_Operators/Complex_Inner_Product.thy b/thys/Complex_Bounded_Operators/Complex_Inner_Product.thy
--- a/thys/Complex_Bounded_Operators/Complex_Inner_Product.thy
+++ b/thys/Complex_Bounded_Operators/Complex_Inner_Product.thy
@@ -1,2494 +1,2523 @@
 (*
 Authors:
 
   Dominique Unruh, University of Tartu, unruh@ut.ee
   Jose Manuel Rodriguez Caballero, University of Tartu, jose.manuel.rodriguez.caballero@ut.ee
 
 *)
 
 section \<open>\<open>Complex_Inner_Product\<close> -- Complex Inner Product Spaces\<close>
 
 theory Complex_Inner_Product
   imports
     Complex_Inner_Product0
 begin
 
 subsection \<open>Complex inner product spaces\<close>
 
 bundle cinner_bracket_notation begin
 notation cinner ("\<langle>_, _\<rangle>")
 end
 unbundle cinner_bracket_notation
 
 bundle no_cinner_bracket_notation begin
 no_notation cinner ("\<langle>_, _\<rangle>")
 end
 
 lemma cinner_real: "cinner x x \<in> \<real>"
   by (simp add: cdot_square_norm)
 
 lemmas cinner_commute' [simp] = cinner_commute[symmetric]
 
 lemma (in complex_inner) cinner_eq_flip: \<open>(cinner x y = cinner z w) \<longleftrightarrow> (cinner y x = cinner w z)\<close>
   by (metis cinner_commute)
 
 lemma Im_cinner_x_x[simp]: "Im \<langle>x , x\<rangle> = 0"
   using comp_Im_same[OF cinner_ge_zero] by simp
 
 
 lemma of_complex_inner_1' [simp]:
   "cinner (1 :: 'a :: {complex_inner, complex_normed_algebra_1}) (of_complex x) = x"
   by (metis cinner_commute complex_cnj_cnj of_complex_inner_1)
 
 
 class chilbert_space =  complex_inner + complete_space
 begin
 subclass cbanach by standard
 end
 
 instantiation complex :: "chilbert_space" begin
 instance ..
 end
 
 subsection \<open>Misc facts\<close>
 
 lemma cinner_scaleR_left [simp]: "cinner (scaleR r x) y = of_real r * (cinner x y)"
   by (simp add: scaleR_scaleC)
 
 lemma cinner_scaleR_right [simp]: "cinner x (scaleR r y) = of_real r * (cinner x y)"
   by (simp add: scaleR_scaleC)
 
 
 text \<open>This is a useful rule for establishing the equality of vectors\<close>
 lemma cinner_extensionality:
   assumes \<open>\<And>\<gamma>. \<langle>\<gamma>, \<psi>\<rangle> = \<langle>\<gamma>, \<phi>\<rangle>\<close>
   shows \<open>\<psi> = \<phi>\<close>
   by (metis assms cinner_eq_zero_iff cinner_simps(3) right_minus_eq)
 
 lemma polar_identity:
   includes notation_norm
   shows \<open>\<parallel>x + y\<parallel>^2 = \<parallel>x\<parallel>^2 + \<parallel>y\<parallel>^2 + 2*Re \<langle>x, y\<rangle>\<close>
     \<comment> \<open>Shown in the proof of Corollary 1.5 in @{cite conway2013course}\<close>
 proof -
   have \<open>\<langle>x , y\<rangle> + \<langle>y , x\<rangle> = \<langle>x , y\<rangle> + cnj \<langle>x , y\<rangle>\<close>
     by simp
   hence \<open>\<langle>x , y\<rangle> + \<langle>y , x\<rangle> = 2 * Re \<langle>x , y\<rangle> \<close>
     using complex_add_cnj by presburger
   have \<open>\<parallel>x + y\<parallel>^2 = \<langle>x+y, x+y\<rangle>\<close>
     by (simp add: cdot_square_norm)
   hence \<open>\<parallel>x + y\<parallel>^2 = \<langle>x , x\<rangle> + \<langle>x , y\<rangle> + \<langle>y , x\<rangle> + \<langle>y , y\<rangle>\<close>
     by (simp add: cinner_add_left cinner_add_right)
   thus ?thesis using  \<open>\<langle>x , y\<rangle> + \<langle>y , x\<rangle> = 2 * Re \<langle>x , y\<rangle>\<close>
     by (smt (verit, ccfv_SIG) Re_complex_of_real plus_complex.simps(1) power2_norm_eq_cinner')
 qed
 
 lemma polar_identity_minus:
   includes notation_norm
   shows \<open>\<parallel>x - y\<parallel>^2 = \<parallel>x\<parallel>^2 + \<parallel>y\<parallel>^2 - 2 * Re \<langle>x, y\<rangle>\<close>
 proof-
   have \<open>\<parallel>x + (-y)\<parallel>^2 = \<parallel>x\<parallel>^2 + \<parallel>-y\<parallel>^2 + 2 * Re \<langle>x , (-y)\<rangle>\<close>
     using polar_identity by blast
   hence \<open>\<parallel>x - y\<parallel>^2 = \<parallel>x\<parallel>^2 + \<parallel>y\<parallel>^2 - 2*Re \<langle>x , y\<rangle>\<close>
     by simp
   thus ?thesis
     by blast
 qed
 
 proposition parallelogram_law:
   includes notation_norm
   fixes x y :: "'a::complex_inner"
   shows \<open>\<parallel>x+y\<parallel>^2 + \<parallel>x-y\<parallel>^2 = 2*( \<parallel>x\<parallel>^2 + \<parallel>y\<parallel>^2 )\<close>
     \<comment> \<open>Shown in the proof of Theorem 2.3 in @{cite conway2013course}\<close>
   by (simp add: polar_identity_minus polar_identity)
 
 
 theorem pythagorean_theorem:
   includes notation_norm
   shows \<open>\<langle>x , y\<rangle> = 0 \<Longrightarrow> \<parallel> x + y \<parallel>^2 = \<parallel> x \<parallel>^2 + \<parallel> y \<parallel>^2\<close>
     \<comment> \<open>Shown in the proof of Theorem 2.2 in @{cite conway2013course}\<close>
   by (simp add: polar_identity)
 
 lemma pythagorean_theorem_sum:
   assumes q1: "\<And>a a'. a \<in> t \<Longrightarrow> a' \<in> t \<Longrightarrow> a \<noteq> a' \<Longrightarrow> \<langle>f a, f a'\<rangle> = 0"
     and q2: "finite t"
   shows "(norm  (\<Sum>a\<in>t. f a))^2 = (\<Sum>a\<in>t.(norm (f a))^2)"
 proof (insert q1, use q2 in induction)
   case empty
   show ?case
     by auto
 next
   case (insert x F)
   have r1: "\<langle>f x, f a\<rangle> = 0"
     if "a \<in> F"
     for a
     using that insert.hyps(2) insert.prems by auto
   have "sum f F = (\<Sum>a\<in>F. f a)"
     by simp
   hence s4: "\<langle>f x, sum f F\<rangle> = \<langle>f x, (\<Sum>a\<in>F. f a)\<rangle>"
     by simp
   also have s3: "\<dots> = (\<Sum>a\<in>F. \<langle>f x, f a\<rangle>)"
     using cinner_sum_right by auto
   also have s2: "\<dots> = (\<Sum>a\<in>F. 0)"
     using r1
     by simp
   also have s1: "\<dots> = 0"
     by simp
   finally have xF_ortho: "\<langle>f x, sum f F\<rangle> = 0"
     using s2 s3 by auto
   have "(norm (sum f (insert x F)))\<^sup>2 = (norm (f x + sum f F))\<^sup>2"
     by (simp add: insert.hyps(1) insert.hyps(2))
   also have "\<dots> = (norm (f x))\<^sup>2 + (norm (sum f F))\<^sup>2"
     using xF_ortho by (rule pythagorean_theorem)
   also have "\<dots> = (norm (f x))\<^sup>2 + (\<Sum>a\<in>F.(norm (f a))^2)"
     apply (subst insert.IH) using insert.prems by auto
   also have "\<dots> = (\<Sum>a\<in>insert x F.(norm (f a))^2)"
     by (simp add: insert.hyps(1) insert.hyps(2))
   finally show ?case
     by simp
 qed
 
 
 lemma Cauchy_cinner_Cauchy:
   fixes x y :: \<open>nat \<Rightarrow> 'a::complex_inner\<close>
   assumes a1: \<open>Cauchy x\<close> and a2: \<open>Cauchy y\<close>
   shows \<open>Cauchy (\<lambda> n. \<langle> x n, y n \<rangle>)\<close>
 proof-
   have \<open>bounded (range x)\<close>
     using a1
     by (simp add: Elementary_Metric_Spaces.cauchy_imp_bounded)
   hence b1: \<open>\<exists>M. \<forall>n. norm (x n) < M\<close>
     by (meson bounded_pos_less rangeI)
   have \<open>bounded (range y)\<close>
     using a2
     by (simp add: Elementary_Metric_Spaces.cauchy_imp_bounded)
   hence b2: \<open>\<exists> M. \<forall> n. norm (y n) < M\<close>
     by (meson bounded_pos_less rangeI)
   have \<open>\<exists>M. \<forall>n. norm (x n) < M \<and> norm (y n) < M\<close>
     using b1 b2
     by (metis dual_order.strict_trans linorder_neqE_linordered_idom)
   then obtain M where M1: \<open>\<And>n. norm (x n) < M\<close> and M2: \<open>\<And>n. norm (y n) < M\<close>
     by blast
   have M3: \<open>M > 0\<close>
     by (smt M2 norm_not_less_zero)
   have \<open>\<exists>N. \<forall>n \<ge> N. \<forall>m \<ge> N. norm ( (\<lambda> i. \<langle> x i, y i \<rangle>) n -  (\<lambda> i. \<langle> x i, y i \<rangle>) m ) < e\<close>
     if "e > 0" for e
   proof-
     have \<open>e / (2*M) > 0\<close>
       using M3
       by (simp add: that)
     hence \<open>\<exists>N. \<forall>n\<ge>N. \<forall>m\<ge>N. norm (x n - x m) < e / (2*M)\<close>
       using a1
       by (simp add: Cauchy_iff)
     then obtain N1 where N1_def: \<open>\<And>n m. n\<ge>N1 \<Longrightarrow> m\<ge>N1 \<Longrightarrow> norm (x n - x m) < e / (2*M)\<close>
       by blast
     have x1: \<open>\<exists>N. \<forall> n\<ge>N. \<forall> m\<ge>N. norm (y n - y m) < e / (2*M)\<close>
       using a2 \<open>e / (2*M) > 0\<close>
       by (simp add: Cauchy_iff)
     obtain N2 where N2_def: \<open>\<And>n m.  n\<ge>N2 \<Longrightarrow> m\<ge>N2 \<Longrightarrow> norm (y n - y m) < e / (2*M)\<close>
       using x1
       by blast
     define N where N_def: \<open>N = N1 + N2\<close>
     hence \<open>N \<ge> N1\<close>
       by auto
     have \<open>N \<ge> N2\<close>
       using N_def
       by auto
     have \<open>norm ( \<langle> x n, y n \<rangle> - \<langle> x m, y m \<rangle> ) < e\<close>
       if \<open>n \<ge> N\<close> and \<open>m \<ge> N\<close>
       for n m
     proof -
       have \<open>\<langle> x n, y n \<rangle> - \<langle> x m, y m \<rangle> = (\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle>) + (\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle>)\<close>
         by simp
       hence y1: \<open>norm (\<langle> x n, y n \<rangle> - \<langle> x m, y m \<rangle>) \<le> norm (\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle>)
            + norm (\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle>)\<close>
         by (metis norm_triangle_ineq)
 
       have \<open>\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle> = \<langle> x n - x m, y n \<rangle>\<close>
         by (simp add: cinner_diff_left)
       hence \<open>norm (\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle>) = norm \<langle> x n - x m, y n \<rangle>\<close>
         by simp
       moreover have \<open>norm \<langle> x n - x m, y n \<rangle> \<le> norm (x n - x m) * norm (y n)\<close>
         using complex_inner_class.Cauchy_Schwarz_ineq2 by blast
       moreover have \<open>norm (y n) < M\<close>
         by (simp add: M2)
       moreover have \<open>norm (x n - x m) < e/(2*M)\<close>
         using \<open>N \<le> m\<close> \<open>N \<le> n\<close> \<open>N1 \<le> N\<close> N1_def by auto
       ultimately have \<open>norm (\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle>) < (e/(2*M)) * M\<close>
         by (smt linordered_semiring_strict_class.mult_strict_mono norm_ge_zero)
       moreover have \<open> (e/(2*M)) * M = e/2\<close>
         using \<open>M > 0\<close> by simp
       ultimately have  \<open>norm (\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle>) < e/2\<close>
         by simp
       hence y2: \<open>norm (\<langle> x n, y n \<rangle> - \<langle> x m, y n \<rangle>) < e/2\<close>
         by blast
       have \<open>\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle> = \<langle> x m, y n - y m \<rangle>\<close>
         by (simp add: cinner_diff_right)
       hence \<open>norm (\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle>) = norm \<langle> x m, y n - y m \<rangle>\<close>
         by simp
       moreover have \<open>norm \<langle> x m, y n - y m \<rangle> \<le> norm (x m) * norm (y n - y m)\<close>
         by (meson complex_inner_class.Cauchy_Schwarz_ineq2)
       moreover have \<open>norm (x m) < M\<close>
         by (simp add: M1)
       moreover have \<open>norm (y n - y m) < e/(2*M)\<close>
         using \<open>N \<le> m\<close> \<open>N \<le> n\<close> \<open>N2 \<le> N\<close> N2_def by auto
       ultimately have \<open>norm (\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle>) < M * (e/(2*M))\<close>
         by (smt linordered_semiring_strict_class.mult_strict_mono norm_ge_zero)
       moreover have \<open>M * (e/(2*M)) = e/2\<close>
         using \<open>M > 0\<close> by simp
       ultimately have  \<open>norm (\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle>) < e/2\<close>
         by simp
       hence y3: \<open>norm (\<langle> x m, y n \<rangle> - \<langle> x m, y m \<rangle>) < e/2\<close>
         by blast
       show \<open>norm ( \<langle> x n, y n \<rangle> - \<langle> x m, y m \<rangle> ) < e\<close>
         using y1 y2 y3 by simp
     qed
     thus ?thesis by blast
   qed
   thus ?thesis
     by (simp add: CauchyI)
 qed
 
 
 lemma cinner_sup_norm: \<open>norm \<psi> = (SUP \<phi>. cmod (cinner \<phi> \<psi>) / norm \<phi>)\<close>
 proof (rule sym, rule cSup_eq_maximum)
   have \<open>norm \<psi> = cmod (cinner \<psi> \<psi>) / norm \<psi>\<close>
     by (metis norm_eq_sqrt_cinner norm_ge_zero real_div_sqrt)
   then show \<open>norm \<psi> \<in> range (\<lambda>\<phi>. cmod (cinner \<phi> \<psi>) / norm \<phi>)\<close>
     by blast
 next
   fix n assume \<open>n \<in> range (\<lambda>\<phi>. cmod (cinner \<phi> \<psi>) / norm \<phi>)\<close>
   then obtain \<phi> where n\<phi>: \<open>n = cmod (cinner \<phi> \<psi>) / norm \<phi>\<close>
     by auto
   show \<open>n \<le> norm \<psi>\<close>
     unfolding n\<phi>
     by (simp add: complex_inner_class.Cauchy_Schwarz_ineq2 divide_le_eq ordered_field_class.sign_simps(33))
 qed
 
 lemma cinner_sup_onorm:
   fixes A :: \<open>'a::{real_normed_vector,not_singleton} \<Rightarrow> 'b::complex_inner\<close>
   assumes \<open>bounded_linear A\<close>
   shows \<open>onorm A = (SUP (\<psi>,\<phi>). cmod (cinner \<psi> (A \<phi>)) / (norm \<psi> * norm \<phi>))\<close>
 proof (unfold onorm_def, rule cSup_eq_cSup)
   show \<open>bdd_above (range (\<lambda>x. norm (A x) / norm x))\<close>
     by (meson assms bdd_aboveI2 le_onorm)
 next
   fix a
   assume \<open>a \<in> range (\<lambda>\<phi>. norm (A \<phi>) / norm \<phi>)\<close>
   then obtain \<phi> where \<open>a = norm (A \<phi>) / norm \<phi>\<close>
     by auto
   then have \<open>a \<le> cmod (cinner (A \<phi>) (A \<phi>)) / (norm (A \<phi>) * norm \<phi>)\<close>
     apply auto
     by (smt (verit) divide_divide_eq_left norm_eq_sqrt_cinner norm_imp_pos_and_ge real_div_sqrt)
   then show \<open>\<exists>b\<in>range (\<lambda>(\<psi>, \<phi>). cmod (cinner \<psi> (A \<phi>)) / (norm \<psi> * norm \<phi>)). a \<le> b\<close>
     by force
 next
   fix b
   assume \<open>b \<in> range (\<lambda>(\<psi>, \<phi>). cmod (cinner \<psi> (A \<phi>)) / (norm \<psi> * norm \<phi>))\<close>
   then obtain \<psi> \<phi> where b: \<open>b = cmod (cinner \<psi> (A \<phi>)) / (norm \<psi> * norm \<phi>)\<close>
     by auto
   then have \<open>b \<le> norm (A \<phi>) / norm \<phi>\<close>
     apply auto
     by (smt (verit, ccfv_threshold) complex_inner_class.Cauchy_Schwarz_ineq2 division_ring_divide_zero linordered_field_class.divide_right_mono mult_cancel_left1 nonzero_mult_divide_mult_cancel_left2 norm_imp_pos_and_ge ordered_field_class.sign_simps(33) zero_le_divide_iff)
   then show \<open>\<exists>a\<in>range (\<lambda>x. norm (A x) / norm x). b \<le> a\<close>
     by auto
 qed
 
 
 lemma sum_cinner:
   fixes f :: "'a \<Rightarrow> 'b::complex_inner"
   shows "cinner (sum f A) (sum g B) = (\<Sum>i\<in>A. \<Sum>j\<in>B. cinner (f i) (g j))"
   by (simp add: cinner_sum_right cinner_sum_left) (rule sum.swap)
 
 lemma Cauchy_cinner_product_summable':
   fixes a b :: "nat \<Rightarrow> 'a::complex_inner"
   shows \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on UNIV \<longleftrightarrow> (\<lambda>(x, y). cinner (a y) (b (x - y))) summable_on {(k, i). i \<le> k}\<close>
 proof -
   have img: \<open>(\<lambda>(k::nat, i). (i, k - i)) ` {(k, i). i \<le> k} = UNIV\<close>
     apply (auto simp: image_def)
     by (metis add.commute add_diff_cancel_right' diff_le_self)
   have inj: \<open>inj_on (\<lambda>(k::nat, i). (i, k - i)) {(k, i). i \<le> k}\<close>
     by (smt (verit, del_insts) Pair_inject case_prodE case_prod_conv eq_diff_iff inj_onI mem_Collect_eq)
 
   have \<open>(\<lambda>(x, y). cinner (a x) (b y)) summable_on UNIV \<longleftrightarrow> (\<lambda>(k, l). cinner (a k) (b l)) summable_on (\<lambda>(k, i). (i, k - i)) ` {(k, i). i \<le> k}\<close>
     by (simp only: img)
   also have \<open>\<dots> \<longleftrightarrow> ((\<lambda>(k, l). cinner (a k) (b l)) \<circ> (\<lambda>(k, i). (i, k - i))) summable_on {(k, i). i \<le> k}\<close>
     using inj by (rule summable_on_reindex)
   also have \<open>\<dots> \<longleftrightarrow> (\<lambda>(x, y). cinner (a y) (b (x - y))) summable_on {(k, i). i \<le> k}\<close>
     by (simp add: o_def case_prod_unfold)
   finally show ?thesis
     by -
 qed
 
 instantiation prod :: (complex_inner, complex_inner) complex_inner
 begin
 
 definition cinner_prod_def:
   "cinner x y = cinner (fst x) (fst y) + cinner (snd x) (snd y)"
 
 instance
 proof
   fix r :: complex
   fix x y z :: "'a::complex_inner \<times> 'b::complex_inner"
   show "cinner x y = cnj (cinner y x)"
     unfolding cinner_prod_def
     by simp
   show "cinner (x + y) z = cinner x z + cinner y z"
     unfolding cinner_prod_def
     by (simp add: cinner_add_left)
   show "cinner (scaleC r x) y = cnj r * cinner x y"
     unfolding cinner_prod_def
     by (simp add: distrib_left)
   show "0 \<le> cinner x x"
     unfolding cinner_prod_def
     by (intro add_nonneg_nonneg cinner_ge_zero)
   show "cinner x x = 0 \<longleftrightarrow> x = 0"
     unfolding cinner_prod_def prod_eq_iff
     by (metis antisym cinner_eq_zero_iff cinner_ge_zero fst_zero le_add_same_cancel2 snd_zero verit_sum_simplify)
   show "norm x = sqrt (cmod (cinner x x))"
     unfolding norm_prod_def cinner_prod_def
     by (metis (no_types, lifting) Re_complex_of_real add_nonneg_nonneg cinner_ge_zero complex_of_real_cmod plus_complex.simps(1) power2_norm_eq_cinner')
 qed
 
 end
 
 instance prod :: (chilbert_space, chilbert_space) chilbert_space..
 
 subsection \<open>Orthogonality\<close>
 
 definition "orthogonal_complement S = {x| x. \<forall>y\<in>S. cinner x y = 0}"
 
 lemma orthogonal_complement_orthoI:
   \<open>x \<in> orthogonal_complement M \<Longrightarrow> y \<in> M \<Longrightarrow> \<langle> x, y \<rangle> = 0\<close>
   unfolding orthogonal_complement_def by auto
 
 lemma orthogonal_complement_orthoI':
   \<open>x \<in> M \<Longrightarrow> y \<in> orthogonal_complement M \<Longrightarrow> \<langle> x, y \<rangle> = 0\<close>
   by (metis cinner_commute' complex_cnj_zero orthogonal_complement_orthoI)
 
 lemma orthogonal_complementI:
   \<open>(\<And>x. x \<in> M \<Longrightarrow> \<langle> y, x \<rangle> = 0) \<Longrightarrow> y \<in> orthogonal_complement M\<close>
   unfolding orthogonal_complement_def
   by simp
 
 abbreviation is_orthogonal::\<open>'a::complex_inner \<Rightarrow> 'a \<Rightarrow> bool\<close>  where
   \<open>is_orthogonal x y \<equiv> \<langle> x, y \<rangle> = 0\<close>
 
 bundle orthogonal_notation begin
 notation is_orthogonal (infixl "\<bottom>" 69)
 end
 
 bundle no_orthogonal_notation begin
 no_notation is_orthogonal (infixl "\<bottom>" 69)
 end
 
 
 lemma is_orthogonal_sym: "is_orthogonal \<psi> \<phi> = is_orthogonal \<phi> \<psi>"
   by (metis cinner_commute' complex_cnj_zero)
 
 lemma is_orthogonal_sgn_right[simp]: \<open>is_orthogonal e (sgn f) \<longleftrightarrow> is_orthogonal e f\<close>
 proof (cases \<open>f = 0\<close>)
   case True
   then show ?thesis
     by simp
 next
   case False
   have \<open>cinner e (sgn f) = cinner e f / norm f\<close>
     by (simp add: sgn_div_norm divide_inverse scaleR_scaleC)
   moreover have \<open>norm f \<noteq> 0\<close>
     by (simp add: False)
   ultimately show ?thesis
     by force
 qed
 
 lemma is_orthogonal_sgn_left[simp]: \<open>is_orthogonal (sgn e) f \<longleftrightarrow> is_orthogonal e f\<close>
   by (simp add: is_orthogonal_sym)
 
 lemma orthogonal_complement_closed_subspace[simp]:
   "closed_csubspace (orthogonal_complement A)"
   for A :: \<open>('a::complex_inner) set\<close>
 proof (intro closed_csubspace.intro complex_vector.subspaceI)
   fix x y and c
   show \<open>0 \<in> orthogonal_complement A\<close>
     by (rule orthogonal_complementI, simp)
   show \<open>x + y \<in> orthogonal_complement A\<close>
     if \<open>x \<in> orthogonal_complement A\<close> and \<open>y \<in> orthogonal_complement A\<close>
     using that by (auto intro!: orthogonal_complementI dest!: orthogonal_complement_orthoI
         simp add: cinner_add_left)
   show \<open>c *\<^sub>C x \<in> orthogonal_complement A\<close> if \<open>x \<in> orthogonal_complement A\<close>
     using that by (auto intro!: orthogonal_complementI dest!: orthogonal_complement_orthoI)
 
   show "closed (orthogonal_complement A)"
   proof (auto simp add: closed_sequential_limits, rename_tac an a)
     fix an a
     assume ortho: \<open>\<forall>n::nat. an n \<in> orthogonal_complement A\<close>
     assume lim: \<open>an \<longlonglongrightarrow> a\<close>
 
     have \<open>\<forall> y \<in> A. \<forall> n. \<langle> y , an n \<rangle> = 0\<close>
       using orthogonal_complement_orthoI'
       by (simp add: orthogonal_complement_orthoI' ortho)
     moreover have \<open>isCont (\<lambda> x. \<langle> y , x \<rangle>) a\<close> for y
       using bounded_clinear_cinner_right clinear_continuous_at
       by (simp add: clinear_continuous_at bounded_clinear_cinner_right)
     ultimately have \<open>(\<lambda> n. (\<lambda> v. \<langle> y , v \<rangle>) (an n)) \<longlonglongrightarrow> (\<lambda> v. \<langle> y , v \<rangle>) a\<close> for y
       using isCont_tendsto_compose
       by (simp add: isCont_tendsto_compose lim)
     hence  \<open>\<forall> y\<in>A. (\<lambda> n. \<langle> y , an n \<rangle>  ) \<longlonglongrightarrow>  \<langle> y , a \<rangle>\<close>
       by simp
     hence  \<open>\<forall> y\<in>A. (\<lambda> n. 0  ) \<longlonglongrightarrow>  \<langle> y , a \<rangle>\<close>
       using \<open>\<forall> y \<in> A. \<forall> n. \<langle> y , an n \<rangle> = 0\<close>
       by fastforce
     hence  \<open>\<forall> y \<in> A. \<langle> y , a \<rangle> = 0\<close>
       using limI by fastforce
     then show \<open>a \<in> orthogonal_complement A\<close>
       by (simp add: orthogonal_complementI is_orthogonal_sym)
   qed
 qed
 
 lemma orthogonal_complement_zero_intersection:
   assumes "0\<in>M"
   shows \<open>M \<inter> (orthogonal_complement M) = {0}\<close>
 proof -
   have "x=0" if "x\<in>M" and "x\<in>orthogonal_complement M" for x
   proof -
     from that have "\<langle> x, x \<rangle> = 0"
       unfolding orthogonal_complement_def by auto
     thus "x=0"
       by auto
   qed
   with assms show ?thesis
     unfolding orthogonal_complement_def by auto
 qed
 
 lemma is_orthogonal_closure_cspan:
   assumes "\<And>x y. x \<in> X \<Longrightarrow> y \<in> Y \<Longrightarrow> is_orthogonal x y"
   assumes \<open>x \<in> closure (cspan X)\<close> \<open>y \<in> closure (cspan Y)\<close>
   shows "is_orthogonal x y"
 proof -
   have *: \<open>cinner x y = 0\<close> if \<open>y \<in> Y\<close> for y
     using bounded_antilinear_cinner_left apply (rule bounded_antilinear_eq_on[where G=X])
     using assms that by auto
   show \<open>cinner x y = 0\<close>
     using bounded_clinear_cinner_right apply (rule bounded_clinear_eq_on[where G=Y])
     using * assms by auto
 qed
 
 
 instantiation ccsubspace :: (complex_inner) "uminus"
 begin
 lift_definition uminus_ccsubspace::\<open>'a ccsubspace  \<Rightarrow> 'a ccsubspace\<close>
   is \<open>orthogonal_complement\<close>
   by simp
 
 instance ..
 end
 
 
 instantiation ccsubspace :: (complex_inner) minus begin
 lift_definition minus_ccsubspace :: "'a ccsubspace \<Rightarrow> 'a ccsubspace \<Rightarrow> 'a ccsubspace"
   is "\<lambda>A B. A \<inter> (orthogonal_complement B)"
   by simp
 instance..
 end
 
 definition is_ortho_set :: "'a::complex_inner set \<Rightarrow> bool" where
   \<comment> \<open>Orthogonal set\<close>
   \<open>is_ortho_set S = ((\<forall>x\<in>S. \<forall>y\<in>S. x \<noteq> y \<longrightarrow> \<langle>x, y\<rangle> = 0) \<and> 0 \<notin> S)\<close>
 
 definition is_onb where \<open>is_onb E \<longleftrightarrow> is_ortho_set E \<and> (\<forall>b\<in>E. norm b = 1) \<and> ccspan E = top\<close>
 
 lemma is_ortho_set_empty[simp]: "is_ortho_set {}"
   unfolding is_ortho_set_def by auto
 
 lemma is_ortho_set_antimono: \<open>A \<subseteq> B \<Longrightarrow> is_ortho_set B \<Longrightarrow> is_ortho_set A\<close>
   unfolding is_ortho_set_def by auto
 
 lemma orthogonal_complement_of_closure:
   fixes A ::"('a::complex_inner) set"
   shows "orthogonal_complement A = orthogonal_complement (closure A)"
 proof-
   have s1: \<open>\<langle> y, x \<rangle> = 0\<close>
     if a1: "x \<in> (orthogonal_complement A)"
       and a2: \<open>y \<in> closure A\<close>
     for x y
   proof-
     have \<open>\<forall> y \<in> A. \<langle> y , x \<rangle> = 0\<close>
       by (simp add: a1 orthogonal_complement_orthoI')
     then obtain yy where \<open>\<forall> n. yy n \<in> A\<close> and \<open>yy \<longlonglongrightarrow> y\<close>
       using a2 closure_sequential by blast
     have \<open>isCont (\<lambda> t. \<langle> t , x \<rangle>) y\<close>
       by simp
     hence \<open>(\<lambda> n. \<langle> yy n , x \<rangle>) \<longlonglongrightarrow>  \<langle> y , x \<rangle>\<close>
       using \<open>yy \<longlonglongrightarrow> y\<close> isCont_tendsto_compose
       by fastforce
     hence \<open>(\<lambda> n. 0) \<longlonglongrightarrow>  \<langle> y , x \<rangle>\<close>
       using \<open>\<forall> y \<in> A. \<langle> y , x \<rangle> = 0\<close>  \<open>\<forall> n. yy n \<in> A\<close> by simp
     thus ?thesis
       using limI by force
   qed
   hence "x \<in> orthogonal_complement (closure A)"
     if a1: "x \<in> (orthogonal_complement A)"
     for x
     using that
     by (meson orthogonal_complementI is_orthogonal_sym)
   moreover have \<open>x \<in> (orthogonal_complement A)\<close>
     if "x \<in> (orthogonal_complement (closure A))"
     for x
     using that
     by (meson closure_subset orthogonal_complement_orthoI orthogonal_complementI subset_eq)
   ultimately show ?thesis by blast
 qed
 
 
 lemma is_orthogonal_closure:
   assumes \<open>\<And>s. s \<in> S \<Longrightarrow> is_orthogonal a  s\<close>
   assumes \<open>x \<in> closure S\<close>
   shows \<open>is_orthogonal a x\<close>
   by (metis assms(1) assms(2) orthogonal_complementI orthogonal_complement_of_closure orthogonal_complement_orthoI)
 
 
 lemma is_orthogonal_cspan:
   assumes a1: "\<And>s. s \<in> S \<Longrightarrow> is_orthogonal a s" and a3: "x \<in> cspan S"
   shows "\<langle>a, x\<rangle> = 0"
 proof-
   have "\<exists>t r. finite t \<and> t \<subseteq> S \<and> (\<Sum>a\<in>t. r a *\<^sub>C a) = x"
     using complex_vector.span_explicit
     by (smt a3 mem_Collect_eq)
   then obtain t r where b1: "finite t" and b2: "t \<subseteq> S" and b3: "(\<Sum>a\<in>t. r a *\<^sub>C a) = x"
     by blast
   have x1: "\<langle>a, i\<rangle> = 0"
     if "i\<in>t" for i
     using b2 a1 that by blast
   have  "\<langle>a, x\<rangle> = \<langle>a, (\<Sum>i\<in>t. r i *\<^sub>C i)\<rangle>"
     by (simp add: b3)
   also have  "\<dots> = (\<Sum>i\<in>t. r i *\<^sub>C \<langle>a, i\<rangle>)"
     by (simp add: cinner_sum_right)
   also have  "\<dots> = 0"
     using x1 by simp
   finally show ?thesis.
 qed
 
 lemma ccspan_leq_ortho_ccspan:
   assumes "\<And>s t. s\<in>S \<Longrightarrow> t\<in>T \<Longrightarrow> is_orthogonal s t"
   shows "ccspan S \<le> - (ccspan T)"
   using assms apply transfer
   by (smt (verit, ccfv_threshold) is_orthogonal_closure is_orthogonal_cspan is_orthogonal_sym orthogonal_complementI subsetI)
 
 lemma double_orthogonal_complement_increasing[simp]:
   shows "M \<subseteq> orthogonal_complement (orthogonal_complement M)"
 proof (rule subsetI)
   fix x assume s1: "x \<in> M"
   have \<open>\<forall> y \<in> (orthogonal_complement M). \<langle> x, y \<rangle> = 0\<close>
     using s1 orthogonal_complement_orthoI' by auto
   hence \<open>x \<in> orthogonal_complement (orthogonal_complement M)\<close>
     by (simp add: orthogonal_complement_def)
   then show "x \<in> orthogonal_complement (orthogonal_complement M)"
     by blast
 qed
 
 
 lemma orthonormal_basis_of_cspan:
   fixes S::"'a::complex_inner set"
   assumes "finite S"
   shows "\<exists>A. is_ortho_set A \<and> (\<forall>x\<in>A. norm x = 1) \<and> cspan A = cspan S \<and> finite A"
 proof (use assms in induction)
   case empty
   show ?case
     apply (rule exI[of _ "{}"])
     by auto
 next
   case (insert s S)
   from insert.IH
   obtain A where orthoA: "is_ortho_set A" and normA: "\<And>x. x\<in>A \<Longrightarrow> norm x = 1" and spanA: "cspan A = cspan S" and finiteA: "finite A"
     by auto
   show ?case
   proof (cases \<open>s \<in> cspan S\<close>)
     case True
     then have \<open>cspan (insert s S) = cspan S\<close>
       by (simp add: complex_vector.span_redundant)
     with orthoA normA spanA finiteA
     show ?thesis
       by auto
   next
     case False
     obtain a where a_ortho: \<open>\<And>x. x\<in>A \<Longrightarrow> is_orthogonal x a\<close> and sa_span: \<open>s - a \<in> cspan A\<close>
     proof (atomize_elim, use \<open>finite A\<close> \<open>is_ortho_set A\<close> in induction)
       case empty
       then show ?case
         by auto
     next
       case (insert x A)
       then obtain a where orthoA: \<open>\<And>x. x \<in> A \<Longrightarrow> is_orthogonal x a\<close> and sa: \<open>s - a \<in> cspan A\<close>
         by (meson is_ortho_set_antimono subset_insertI)
       define a' where \<open>a' = a - cinner x a *\<^sub>C inverse (cinner x x) *\<^sub>C x\<close>
       have \<open>is_orthogonal x a'\<close>
         unfolding a'_def cinner_diff_right cinner_scaleC_right
         apply (cases \<open>cinner x x = 0\<close>)
         by auto
       have orthoA: \<open>is_orthogonal y a'\<close> if \<open>y \<in> A\<close> for y
         unfolding a'_def cinner_diff_right cinner_scaleC_right
         apply auto by (metis insert.prems insertCI is_ortho_set_def mult_not_zero orthoA that)
       have \<open>s - a' \<in> cspan (insert x A)\<close>
         unfolding a'_def apply auto
         by (metis (no_types, lifting) complex_vector.span_breakdown_eq diff_add_cancel diff_diff_add sa)
       with \<open>is_orthogonal x a'\<close> orthoA
       show ?case
         apply (rule_tac exI[of _ a'])
         by auto
     qed
 
     from False sa_span
     have \<open>a \<noteq> 0\<close>
       unfolding spanA by auto
     define a' where \<open>a' = inverse (norm a) *\<^sub>C a\<close>
     with \<open>a \<noteq> 0\<close> have \<open>norm a' = 1\<close>
       by (simp add: norm_inverse)
     have a: \<open>a = norm a *\<^sub>C a'\<close>
       by (simp add: \<open>a \<noteq> 0\<close> a'_def)
 
     from sa_span spanA
     have a'_span: \<open>a' \<in> cspan (insert s S)\<close>
       unfolding a'_def
       by (metis complex_vector.eq_span_insert_eq complex_vector.span_scale complex_vector.span_superset in_mono insertI1)
     from sa_span
     have s_span: \<open>s \<in> cspan (insert a' A)\<close>
       apply (subst (asm) a)
       using complex_vector.span_breakdown_eq by blast
 
     from \<open>a \<noteq> 0\<close> a_ortho orthoA
     have ortho: "is_ortho_set (insert a' A)"
       unfolding is_ortho_set_def a'_def
       apply auto
       by (meson is_orthogonal_sym)
 
     have span: \<open>cspan (insert a' A) = cspan (insert s S)\<close>
       using a'_span s_span spanA apply auto
        apply (metis (full_types) complex_vector.span_breakdown_eq complex_vector.span_redundant insert_commute s_span)
       by (metis (full_types) complex_vector.span_breakdown_eq complex_vector.span_redundant insert_commute s_span)
 
     show ?thesis
       apply (rule exI[of _ \<open>insert a' A\<close>])
       by (simp add: ortho \<open>norm a' = 1\<close> normA finiteA span)
   qed
 qed
 
 lemma is_ortho_set_cindependent:
   assumes "is_ortho_set A"
   shows "cindependent A"
 proof -
   have "u v = 0"
     if b1: "finite t" and b2: "t \<subseteq> A" and b3: "(\<Sum>v\<in>t. u v *\<^sub>C v) = 0" and b4: "v \<in> t"
     for t u v
   proof -
     have "\<langle>v, v'\<rangle> = 0" if c1: "v'\<in>t-{v}" for v'
       by (metis DiffE assms b2 b4 insertI1 is_ortho_set_antimono is_ortho_set_def that)
     hence sum0: "(\<Sum>v'\<in>t-{v}. u v' * \<langle>v, v'\<rangle>) = 0"
       by simp
     have "\<langle>v, (\<Sum>v'\<in>t. u v' *\<^sub>C v')\<rangle> = (\<Sum>v'\<in>t. u v' * \<langle>v, v'\<rangle>)"
       using b1
       by (metis (mono_tags, lifting) cinner_scaleC_right cinner_sum_right sum.cong)
     also have "\<dots> = u v * \<langle>v, v\<rangle> + (\<Sum>v'\<in>t-{v}. u v' * \<langle>v, v'\<rangle>)"
       by (meson b1 b4 sum.remove)
     also have "\<dots> = u v * \<langle>v, v\<rangle>"
       using sum0 by simp
     finally have "\<langle>v, (\<Sum>v'\<in>t. u v' *\<^sub>C v')\<rangle> =  u v * \<langle>v, v\<rangle>"
       by blast
     hence "u v * \<langle>v, v\<rangle> = 0" using b3 by simp
     moreover have "\<langle>v, v\<rangle> \<noteq> 0"
       using assms is_ortho_set_def b2 b4 by auto
     ultimately show "u v = 0" by simp
   qed
   thus ?thesis using complex_vector.independent_explicit_module
     by (smt cdependent_raw_def)
 qed
 
 
 lemma onb_expansion_finite:
   includes notation_norm
   fixes T::\<open>'a::{complex_inner,cfinite_dim} set\<close>
   assumes a1: \<open>cspan T = UNIV\<close> and a3: \<open>is_ortho_set T\<close>
     and a4: \<open>\<And>t. t\<in>T \<Longrightarrow> \<parallel>t\<parallel> = 1\<close>
   shows \<open>x = (\<Sum>t\<in>T. \<langle> t, x \<rangle> *\<^sub>C t)\<close>
 proof -
   have \<open>finite T\<close>
     apply (rule cindependent_cfinite_dim_finite)
     by (simp add: a3 is_ortho_set_cindependent)
   have \<open>closure (complex_vector.span T)  = complex_vector.span T\<close>
     by (simp add: a1)
   have \<open>{\<Sum>a\<in>t. r a *\<^sub>C a |t r. finite t \<and> t \<subseteq> T} = {\<Sum>a\<in>T. r a *\<^sub>C a |r. True}\<close>
     apply auto
      apply (rule_tac x=\<open>\<lambda>a. if a \<in> t then r a else 0\<close> in exI)
      apply (simp add: \<open>finite T\<close> sum.mono_neutral_cong_right)
     using \<open>finite T\<close> by blast
 
   have f1: "\<forall>A. {a. \<exists>Aa f. (a::'a) = (\<Sum>a\<in>Aa. f a *\<^sub>C a) \<and> finite Aa \<and> Aa \<subseteq> A} = cspan A"
     by (simp add: complex_vector.span_explicit)
   have f2: "\<forall>a. (\<exists>f. a = (\<Sum>a\<in>T. f a *\<^sub>C a)) \<or> (\<forall>A. (\<forall>f. a \<noteq> (\<Sum>a\<in>A. f a *\<^sub>C a)) \<or> infinite A \<or> \<not> A \<subseteq> T)"
     using \<open>{\<Sum>a\<in>t. r a *\<^sub>C a |t r. finite t \<and> t \<subseteq> T} = {\<Sum>a\<in>T. r a *\<^sub>C a |r. True}\<close> by auto
   have f3: "\<forall>A a. (\<exists>Aa f. (a::'a) = (\<Sum>a\<in>Aa. f a *\<^sub>C a) \<and> finite Aa \<and> Aa \<subseteq> A) \<or> a \<notin> cspan A"
     using f1 by blast
   have "cspan T = UNIV"
     by (metis (full_types, lifting)  \<open>complex_vector.span T = UNIV\<close>)
   hence \<open>\<exists> r. x = (\<Sum> a\<in>T. r a *\<^sub>C a)\<close>
     using f3 f2 by blast
   then obtain r where \<open>x = (\<Sum> a\<in>T. r a *\<^sub>C a)\<close>
     by blast
 
   have \<open>r a = \<langle>a, x\<rangle>\<close> if \<open>a \<in> T\<close> for a
   proof-
     have \<open>norm a = 1\<close>
       using a4
       by (simp add: \<open>a \<in> T\<close>)
     moreover have \<open>norm a = sqrt (norm \<langle>a, a\<rangle>)\<close>
       using norm_eq_sqrt_cinner by auto
     ultimately have \<open>sqrt (norm \<langle>a, a\<rangle>) = 1\<close>
       by simp
     hence \<open>norm \<langle>a, a\<rangle> = 1\<close>
       using real_sqrt_eq_1_iff by blast
     moreover have \<open>\<langle>a, a\<rangle> \<in> \<real>\<close>
       by (simp add: cinner_real)
     moreover have \<open>\<langle>a, a\<rangle> \<ge> 0\<close>
       using cinner_ge_zero by blast
     ultimately have w1: \<open>\<langle>a, a\<rangle> = 1\<close>
       by (metis \<open>0 \<le> \<langle>a, a\<rangle>\<close> \<open>cmod \<langle>a, a\<rangle> = 1\<close> complex_of_real_cmod of_real_1)
 
     have \<open>r t * \<langle>a, t\<rangle> = 0\<close> if \<open>t \<in> T-{a}\<close> for t
       by (metis DiffD1 DiffD2 \<open>a \<in> T\<close> a3 is_ortho_set_def mult_eq_0_iff singletonI that)
     hence s1: \<open>(\<Sum> t\<in>T-{a}. r t * \<langle>a, t\<rangle>) = 0\<close>
       by (simp add: \<open>\<And>t. t \<in> T - {a} \<Longrightarrow> r t * \<langle>a, t\<rangle> = 0\<close>)
     have \<open>\<langle>a, x\<rangle> = \<langle>a, (\<Sum> t\<in>T. r t *\<^sub>C t)\<rangle>\<close>
       using \<open>x = (\<Sum> a\<in>T. r a *\<^sub>C a)\<close>
       by simp
     also have \<open>\<dots> = (\<Sum> t\<in>T. \<langle>a, r t *\<^sub>C t\<rangle>)\<close>
       using cinner_sum_right by blast
     also have \<open>\<dots> = (\<Sum> t\<in>T. r t * \<langle>a, t\<rangle>)\<close>
       by simp
     also have \<open>\<dots> = r a * \<langle>a, a\<rangle> + (\<Sum> t\<in>T-{a}. r t * \<langle>a, t\<rangle>)\<close>
       using \<open>a \<in> T\<close>
       by (meson \<open>finite T\<close> sum.remove)
     also have \<open>\<dots> = r a * \<langle>a, a\<rangle>\<close>
       using s1
       by simp
     also have \<open>\<dots> = r a\<close>
       by (simp add: w1)
     finally show ?thesis by auto
   qed
   thus ?thesis
     using \<open>x = (\<Sum> a\<in>T. r a *\<^sub>C a)\<close>
     by fastforce
 qed
 
 lemma is_ortho_set_singleton[simp]: \<open>is_ortho_set {x} \<longleftrightarrow> x \<noteq> 0\<close>
   by (simp add: is_ortho_set_def)
 
 subsection \<open>Projections\<close>
 
 lemma smallest_norm_exists:
   \<comment> \<open>Theorem 2.5 in @{cite conway2013course} (inside the proof)\<close>
   includes notation_norm
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes q1: \<open>convex M\<close> and q2: \<open>closed M\<close> and q3: \<open>M \<noteq> {}\<close>
   shows  \<open>\<exists>k. is_arg_min (\<lambda> x. \<parallel>x\<parallel>) (\<lambda> t. t \<in> M) k\<close>
 proof-
   define d where \<open>d = Inf { \<parallel>x\<parallel>^2 | x. x \<in> M }\<close>
   have w4: \<open>{ \<parallel>x\<parallel>^2 | x. x \<in> M } \<noteq> {}\<close>
     by (simp add: assms(3))
   have \<open>\<forall> x. \<parallel>x\<parallel>^2 \<ge> 0\<close>
     by simp
   hence bdd_below1: \<open>bdd_below { \<parallel>x\<parallel>^2 | x. x \<in> M }\<close>
     by fastforce
   have \<open>d \<le> \<parallel>x\<parallel>^2\<close>
     if a1: "x \<in> M"
     for x
   proof-
     have "\<forall>v. (\<exists>w. Re (\<langle>v , v\<rangle> ) = \<parallel>w\<parallel>\<^sup>2 \<and> w \<in> M) \<or> v \<notin> M"
       by (metis (no_types) power2_norm_eq_cinner')
     hence "Re (\<langle>x , x\<rangle> ) \<in> {\<parallel>v\<parallel>\<^sup>2 |v. v \<in> M}"
       using a1 by blast
     thus ?thesis
       unfolding d_def
       by (metis (lifting) bdd_below1 cInf_lower power2_norm_eq_cinner')
   qed
 
   have \<open>\<forall> \<epsilon> > 0. \<exists> t \<in> { \<parallel>x\<parallel>^2 | x. x \<in> M }.  t < d + \<epsilon>\<close>
     unfolding d_def
     using w4  bdd_below1
     by (meson cInf_lessD less_add_same_cancel1)
   hence \<open>\<forall> \<epsilon> > 0. \<exists> x \<in> M.  \<parallel>x\<parallel>^2 < d + \<epsilon>\<close>
     by auto
   hence \<open>\<forall> \<epsilon> > 0. \<exists> x \<in> M.  \<parallel>x\<parallel>^2 < d + \<epsilon>\<close>
     by (simp add: \<open>\<And>x. x \<in> M \<Longrightarrow> d \<le> \<parallel>x\<parallel>\<^sup>2\<close>)
   hence w1: \<open>\<forall> n::nat. \<exists> x \<in> M.  \<parallel>x\<parallel>^2 < d + 1/(n+1)\<close> by auto
 
   then obtain r::\<open>nat \<Rightarrow> 'a\<close> where w2: \<open>\<forall> n. r n \<in> M \<and>  \<parallel> r n \<parallel>^2 < d + 1/(n+1)\<close>
     by metis
   have w3: \<open>\<forall> n. r n \<in> M\<close>
     by (simp add: w2)
   have \<open>\<forall> n. \<parallel> r n \<parallel>^2 < d + 1/(n+1)\<close>
     by (simp add: w2)
   have w5: \<open>\<parallel> (r n) - (r m) \<parallel>^2 < 2*(1/(n+1) + 1/(m+1))\<close>
     for m n
   proof-
     have w6: \<open>\<parallel> r n \<parallel>^2 < d + 1/(n+1)\<close>
       by (metis w2  of_nat_1 of_nat_add)
     have \<open> \<parallel> r m \<parallel>^2 < d + 1/(m+1)\<close>
       by (metis w2 of_nat_1 of_nat_add)
     have \<open>(r n) \<in> M\<close>
       by (simp add: \<open>\<forall>n. r n \<in> M\<close>)
     moreover have \<open>(r m) \<in> M\<close>
       by (simp add: \<open>\<forall>n. r n \<in> M\<close>)
     ultimately have \<open>(1/2) *\<^sub>R (r n) + (1/2) *\<^sub>R (r m) \<in> M\<close>
       using \<open>convex M\<close>
       by (simp add: convexD)
     hence \<open>\<parallel> (1/2) *\<^sub>R (r n) + (1/2) *\<^sub>R (r m) \<parallel>^2 \<ge> d\<close>
       by (simp add: \<open>\<And>x. x \<in> M \<Longrightarrow> d \<le> \<parallel>x\<parallel>\<^sup>2\<close>)
     have \<open>\<parallel> (1/2) *\<^sub>R (r n) - (1/2) *\<^sub>R (r m) \<parallel>^2
               = (1/2)*( \<parallel> r n \<parallel>^2 + \<parallel> r m \<parallel>^2 ) - \<parallel> (1/2) *\<^sub>R (r n) + (1/2) *\<^sub>R (r m) \<parallel>^2\<close>
       by (smt (z3) div_by_1 field_sum_of_halves nonzero_mult_div_cancel_left parallelogram_law polar_identity power2_norm_eq_cinner' scaleR_collapse times_divide_eq_left)
     also have  \<open>...
               < (1/2)*( d + 1/(n+1) + \<parallel> r m \<parallel>^2 ) - \<parallel> (1/2) *\<^sub>R (r n) + (1/2) *\<^sub>R (r m) \<parallel>^2\<close>
       using \<open>\<parallel>r n\<parallel>\<^sup>2 < d + 1 / real (n + 1)\<close> by auto
     also have  \<open>...
               < (1/2)*( d + 1/(n+1) + d + 1/(m+1) ) - \<parallel> (1/2) *\<^sub>R (r n) + (1/2) *\<^sub>R (r m) \<parallel>^2\<close>
       using \<open>\<parallel>r m\<parallel>\<^sup>2 < d + 1 / real (m + 1)\<close> by auto
     also have  \<open>...
               \<le> (1/2)*( d + 1/(n+1) + d + 1/(m+1) ) - d\<close>
       by (simp add: \<open>d \<le> \<parallel>(1 / 2) *\<^sub>R r n + (1 / 2) *\<^sub>R r m\<parallel>\<^sup>2\<close>)
     also have  \<open>...
               \<le> (1/2)*( 1/(n+1) + 1/(m+1) + 2*d ) - d\<close>
       by simp
     also have  \<open>...
               \<le> (1/2)*( 1/(n+1) + 1/(m+1) ) + (1/2)*(2*d) - d\<close>
       by (simp add: distrib_left)
     also have  \<open>...
               \<le> (1/2)*( 1/(n+1) + 1/(m+1) ) + d - d\<close>
       by simp
     also have  \<open>...
               \<le> (1/2)*( 1/(n+1) + 1/(m+1) )\<close>
       by simp
     finally have \<open> \<parallel>(1 / 2) *\<^sub>R r n - (1 / 2) *\<^sub>R r m\<parallel>\<^sup>2 < 1 / 2 * (1 / real (n + 1) + 1 / real (m + 1)) \<close>
       by blast
     hence \<open> \<parallel>(1 / 2) *\<^sub>R (r n - r m) \<parallel>\<^sup>2 < (1 / 2) * (1 / real (n + 1) + 1 / real (m + 1)) \<close>
       by (simp add: real_vector.scale_right_diff_distrib)
     hence \<open> ((1 / 2)*\<parallel> (r n - r m) \<parallel>)\<^sup>2 < (1 / 2) * (1 / real (n + 1) + 1 / real (m + 1)) \<close>
       by simp
     hence \<open> (1 / 2)^2*(\<parallel> (r n - r m) \<parallel>)\<^sup>2 < (1 / 2) * (1 / real (n + 1) + 1 / real (m + 1)) \<close>
       by (metis power_mult_distrib)
     hence \<open> (1 / 4) *(\<parallel> (r n - r m) \<parallel>)\<^sup>2 < (1 / 2) * (1 / real (n + 1) + 1 / real (m + 1)) \<close>
       by (simp add: power_divide)
     hence \<open> \<parallel> (r n - r m) \<parallel>\<^sup>2 < 2 * (1 / real (n + 1) + 1 / real (m + 1)) \<close>
       by simp
     thus ?thesis
       by (metis of_nat_1 of_nat_add)
   qed
   hence "\<exists> N. \<forall> n m. n \<ge> N \<and> m \<ge> N \<longrightarrow> \<parallel> (r n) - (r m) \<parallel>^2 < \<epsilon>^2"
     if "\<epsilon> > 0"
     for \<epsilon>
   proof-
     obtain N::nat where \<open>1/(N + 1) < \<epsilon>^2/4\<close>
       using LIMSEQ_ignore_initial_segment[OF lim_inverse_n', where k=1]
       by (metis Suc_eq_plus1 \<open>0 < \<epsilon>\<close> nat_approx_posE zero_less_divide_iff zero_less_numeral
           zero_less_power )
     hence \<open>4/(N + 1) < \<epsilon>^2\<close>
       by simp
     have "2*(1/(n+1) + 1/(m+1)) < \<epsilon>^2"
       if f1: "n \<ge> N" and f2: "m \<ge> N"
       for m n::nat
     proof-
       have \<open>1/(n+1) \<le> 1/(N+1)\<close>
         by (simp add: f1 linordered_field_class.frac_le)
       moreover have \<open>1/(m+1) \<le> 1/(N+1)\<close>
         by (simp add: f2 linordered_field_class.frac_le)
       ultimately have  \<open>2*(1/(n+1) + 1/(m+1)) \<le> 4/(N+1)\<close>
         by simp
       thus ?thesis using \<open>4/(N + 1) < \<epsilon>^2\<close>
         by linarith
     qed
     hence "\<parallel> (r n) - (r m) \<parallel>^2 < \<epsilon>^2"
       if y1: "n \<ge> N" and y2: "m \<ge> N"
       for m n::nat
       using that
       by (smt \<open>\<And>n m. \<parallel>r n - r m\<parallel>\<^sup>2 < 2 * (1 / (real n + 1) + 1 / (real m + 1))\<close> of_nat_1 of_nat_add)
     thus ?thesis
       by blast
   qed
   hence  \<open>\<forall> \<epsilon> > 0. \<exists> N::nat. \<forall> n m::nat. n \<ge> N \<and> m \<ge> N \<longrightarrow> \<parallel> (r n) - (r m) \<parallel>^2 < \<epsilon>^2\<close>
     by blast
   hence  \<open>\<forall> \<epsilon> > 0. \<exists> N::nat. \<forall> n m::nat. n \<ge> N \<and> m \<ge> N \<longrightarrow> \<parallel> (r n) - (r m) \<parallel> < \<epsilon>\<close>
     by (meson less_eq_real_def power_less_imp_less_base)
   hence \<open>Cauchy r\<close>
     using CauchyI by fastforce
   then obtain k where \<open>r \<longlonglongrightarrow> k\<close>
     using  convergent_eq_Cauchy by auto
   have \<open>k \<in> M\<close> using \<open>closed M\<close>
     using \<open>\<forall>n. r n \<in> M\<close> \<open>r \<longlonglongrightarrow> k\<close> closed_sequentially by auto
   have  \<open>(\<lambda> n.  \<parallel> r n \<parallel>^2) \<longlonglongrightarrow>  \<parallel> k \<parallel>^2\<close>
     by (simp add: \<open>r \<longlonglongrightarrow> k\<close> tendsto_norm tendsto_power)
   moreover  have  \<open>(\<lambda> n.  \<parallel> r n \<parallel>^2) \<longlonglongrightarrow>  d\<close>
   proof-
     have \<open>\<bar>\<parallel> r n \<parallel>^2 - d\<bar> < 1/(n+1)\<close> for n :: nat
       using \<open>\<And>x. x \<in> M \<Longrightarrow> d \<le> \<parallel>x\<parallel>\<^sup>2\<close> \<open>\<forall>n. r n \<in> M \<and> \<parallel>r n\<parallel>\<^sup>2 < d + 1 / (real n + 1)\<close> of_nat_1 of_nat_add
       by smt
     moreover have \<open>(\<lambda>n. 1 / real (n + 1)) \<longlonglongrightarrow> 0\<close>
       using  LIMSEQ_ignore_initial_segment[OF lim_inverse_n', where k=1] by blast
     ultimately have \<open>(\<lambda> n. \<bar>\<parallel> r n \<parallel>^2 - d\<bar> ) \<longlonglongrightarrow> 0\<close>
       by (simp add: LIMSEQ_norm_0)
     hence \<open>(\<lambda> n. \<parallel> r n \<parallel>^2 - d ) \<longlonglongrightarrow> 0\<close>
       by (simp add: tendsto_rabs_zero_iff)
     moreover have \<open>(\<lambda> n. d ) \<longlonglongrightarrow> d\<close>
       by simp
     ultimately have \<open>(\<lambda> n. (\<parallel> r n \<parallel>^2 - d)+d ) \<longlonglongrightarrow> 0+d\<close>
       using tendsto_add by fastforce
     thus ?thesis by simp
   qed
   ultimately have \<open>d = \<parallel> k \<parallel>^2\<close>
     using LIMSEQ_unique by auto
   hence \<open>t \<in> M \<Longrightarrow> \<parallel> k \<parallel>^2 \<le> \<parallel> t \<parallel>^2\<close> for t
     using \<open>\<And>x. x \<in> M \<Longrightarrow> d \<le> \<parallel>x\<parallel>\<^sup>2\<close> by auto
   hence q1: \<open>\<exists> k. is_arg_min (\<lambda> x. \<parallel>x\<parallel>^2) (\<lambda> t. t \<in> M) k\<close>
     using \<open>k \<in> M\<close>
       is_arg_min_def \<open>d = \<parallel>k\<parallel>\<^sup>2\<close>
     by smt
   thus \<open>\<exists> k. is_arg_min (\<lambda> x. \<parallel>x\<parallel>) (\<lambda> t. t \<in> M) k\<close>
     by (smt is_arg_min_def norm_ge_zero power2_eq_square power2_le_imp_le)
 qed
 
 
 lemma smallest_norm_unique:
   \<comment> \<open>Theorem 2.5 in @{cite conway2013course} (inside the proof)\<close>
   includes notation_norm
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes q1: \<open>convex M\<close>
   assumes r: \<open>is_arg_min (\<lambda> x. \<parallel>x\<parallel>) (\<lambda> t. t \<in> M) r\<close>
   assumes s: \<open>is_arg_min (\<lambda> x. \<parallel>x\<parallel>) (\<lambda> t. t \<in> M) s\<close>
   shows \<open>r = s\<close>
 proof -
   have \<open>r \<in> M\<close>
     using \<open>is_arg_min (\<lambda>x. \<parallel>x\<parallel>) (\<lambda> t. t \<in> M) r\<close>
     by (simp add: is_arg_min_def)
   moreover have \<open>s \<in> M\<close>
     using \<open>is_arg_min (\<lambda>x. \<parallel>x\<parallel>) (\<lambda> t. t \<in> M) s\<close>
     by (simp add: is_arg_min_def)
   ultimately have \<open>((1/2) *\<^sub>R r + (1/2) *\<^sub>R s) \<in> M\<close> using \<open>convex M\<close>
     by (simp add: convexD)
   hence \<open>\<parallel>r\<parallel> \<le> \<parallel> (1/2) *\<^sub>R r + (1/2) *\<^sub>R s \<parallel>\<close>
     by (metis is_arg_min_linorder r)
   hence u2: \<open>\<parallel>r\<parallel>^2 \<le> \<parallel> (1/2) *\<^sub>R r + (1/2) *\<^sub>R s \<parallel>^2\<close>
     using norm_ge_zero power_mono by blast
 
   have \<open>\<parallel>r\<parallel> \<le> \<parallel>s\<parallel>\<close>
     using r s is_arg_min_def
     by (metis is_arg_min_linorder)
   moreover have \<open>\<parallel>s\<parallel> \<le> \<parallel>r\<parallel>\<close>
     using r s is_arg_min_def
     by (metis is_arg_min_linorder)
   ultimately have u3: \<open>\<parallel>r\<parallel> = \<parallel>s\<parallel>\<close> by simp
 
   have \<open>\<parallel> (1/2) *\<^sub>R r - (1/2) *\<^sub>R s \<parallel>^2 \<le> 0\<close>
     using u2 u3 parallelogram_law
     by (smt (verit, ccfv_SIG) polar_identity_minus power2_norm_eq_cinner' scaleR_add_right scaleR_half_double)
   hence \<open>\<parallel> (1/2) *\<^sub>R r - (1/2) *\<^sub>R s \<parallel>^2 = 0\<close>
     by simp
   hence \<open>\<parallel> (1/2) *\<^sub>R r - (1/2) *\<^sub>R s \<parallel> = 0\<close>
     by auto
   hence \<open>(1/2) *\<^sub>R r - (1/2) *\<^sub>R s = 0\<close>
     using norm_eq_zero by blast
   thus ?thesis by simp
 qed
 
 theorem smallest_dist_exists:
   \<comment> \<open>Theorem 2.5 in @{cite conway2013course}\<close>
   fixes M::\<open>'a::chilbert_space set\<close> and h
   assumes a1: \<open>convex M\<close> and a2: \<open>closed M\<close> and a3: \<open>M \<noteq> {}\<close>
   shows  \<open>\<exists>k. is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k\<close>
 proof-
   have *: "is_arg_min (\<lambda>x. dist x h) (\<lambda>x. x\<in>M) (k+h) \<longleftrightarrow> is_arg_min (\<lambda>x. norm x) (\<lambda>x. x\<in>(\<lambda>x. x-h) ` M) k" for k
     unfolding dist_norm is_arg_min_def apply auto using add_implies_diff by blast
   have \<open>\<exists>k. is_arg_min (\<lambda>x. dist x h) (\<lambda>x. x\<in>M) (k+h)\<close>
     apply (subst *)
     apply (rule smallest_norm_exists)
     using assms by (auto simp: closed_translation_subtract)
   then show \<open>\<exists>k. is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k\<close>
     by metis
 qed
 
 theorem smallest_dist_unique:
   \<comment> \<open>Theorem 2.5 in @{cite conway2013course}\<close>
   fixes M::\<open>'a::complex_inner set\<close> and h
   assumes a1: \<open>convex M\<close>
   assumes \<open>is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) r\<close>
   assumes \<open>is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) s\<close>
   shows  \<open>r = s\<close>
 proof-
   have *: "is_arg_min (\<lambda>x. dist x h) (\<lambda>x. x\<in>M) k \<longleftrightarrow> is_arg_min (\<lambda>x. norm x) (\<lambda>x. x\<in>(\<lambda>x. x-h) ` M) (k-h)" for k
     unfolding dist_norm is_arg_min_def by auto
   have \<open>r - h = s - h\<close>
     using _ assms(2,3)[unfolded *] apply (rule smallest_norm_unique)
     by (simp add: a1)
   thus \<open>r = s\<close>
     by auto
 qed
 
 
 \<comment> \<open>Theorem 2.6 in @{cite conway2013course}\<close>
 theorem smallest_dist_is_ortho:
   fixes M::\<open>'a::complex_inner set\<close> and h k::'a
   assumes b1: \<open>closed_csubspace M\<close>
   shows  \<open>(is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k) \<longleftrightarrow>
           h - k \<in> (orthogonal_complement M) \<and> k \<in> M\<close>
 proof-
   include notation_norm
   have  \<open>csubspace M\<close>
     using \<open>closed_csubspace M\<close> unfolding closed_csubspace_def by blast
   have r1: \<open>2 * Re (\<langle> h - k , f \<rangle>) \<le> \<parallel> f \<parallel>^2\<close>
     if "f \<in> M" and \<open>k \<in> M\<close> and \<open>is_arg_min (\<lambda>x. dist x h) (\<lambda> x. x \<in> M) k\<close>
     for f
   proof-
     have \<open>k + f \<in>  M\<close>
       using \<open>csubspace M\<close>
       by (simp add:complex_vector.subspace_add that)
     have "\<forall>f A a b. \<not> is_arg_min f (\<lambda> x. x \<in> A) (a::'a) \<or> (f a::real) \<le> f b \<or> b \<notin> A"
       by (metis (no_types) is_arg_min_linorder)
     hence "dist k h \<le> dist (f + k) h"
       by (metis \<open>is_arg_min (\<lambda>x. dist x h) (\<lambda> x. x \<in> M) k\<close> \<open>k + f \<in> M\<close> add.commute)
     hence \<open>dist h k \<le> dist  h (k + f)\<close>
       by (simp add: add.commute dist_commute)
     hence \<open>\<parallel> h - k \<parallel> \<le> \<parallel> h - (k + f) \<parallel>\<close>
       by (simp add: dist_norm)
     hence \<open>\<parallel> h - k \<parallel>^2 \<le> \<parallel> h - (k + f) \<parallel>^2\<close>
       by (simp add: power_mono)
     also have \<open>... \<le> \<parallel> (h - k) - f \<parallel>^2\<close>
       by (simp add: diff_diff_add)
     also have \<open>... \<le> \<parallel> (h - k) \<parallel>^2 + \<parallel> f \<parallel>^2 -  2 * Re (\<langle> h - k , f \<rangle>)\<close>
       by (simp add: polar_identity_minus)
     finally have \<open>\<parallel> (h - k) \<parallel>^2 \<le> \<parallel> (h - k) \<parallel>^2 + \<parallel> f \<parallel>^2 -  2 * Re (\<langle> h - k , f \<rangle>)\<close>
       by simp
     thus ?thesis by simp
   qed
 
   have q4: \<open>\<forall> c > 0.  2 * Re (\<langle> h - k , f \<rangle>) \<le> c\<close>
     if  \<open>\<forall>c>0. 2 * Re (\<langle>h - k , f\<rangle> ) \<le> c * \<parallel>f\<parallel>\<^sup>2\<close>
     for f
   proof (cases \<open>\<parallel> f \<parallel>^2 > 0\<close>)
     case True
     hence \<open>\<forall> c > 0.  2 * Re (\<langle> h - k , f \<rangle>) \<le> (c/\<parallel> f \<parallel>^2)*\<parallel> f \<parallel>^2\<close>
       using that linordered_field_class.divide_pos_pos by blast
     thus ?thesis
       using True by auto
   next
     case False
     hence \<open>\<parallel> f \<parallel>^2 = 0\<close>
       by simp
     thus ?thesis
       by auto
   qed
   have q3: \<open>\<forall> c::real. c > 0 \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) \<le> 0\<close>
     if a3: \<open>\<forall>f. f \<in> M \<longrightarrow> (\<forall>c>0. 2 * Re \<langle>h - k , f\<rangle> \<le> c * \<parallel>f\<parallel>\<^sup>2)\<close>
       and a2: "f \<in>  M"
       and a1: "is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k"
     for f
   proof-
     have \<open>\<forall> c > 0.  2 * Re (\<langle> h - k , f \<rangle>) \<le> c*\<parallel> f \<parallel>^2\<close>
       by (simp add: that )
     thus ?thesis
       using q4 by smt
   qed
   have w2: "h - k \<in> orthogonal_complement M \<and> k \<in> M"
     if a1: "is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k"
   proof-
     have  \<open>k \<in> M\<close>
       using is_arg_min_def that by fastforce
     hence \<open>\<forall> f. f \<in>  M \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) \<le> \<parallel> f \<parallel>^2\<close>
       using r1
       by (simp add: that)
     have \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real.  2 * Re (\<langle> h - k , c *\<^sub>R f \<rangle>) \<le> \<parallel> c *\<^sub>R f \<parallel>^2)\<close>
       using  assms scaleR_scaleC complex_vector.subspace_def \<open>csubspace M\<close>
       by (metis \<open>\<forall>f. f \<in> M \<longrightarrow> 2 * Re \<langle>h - k, f\<rangle> \<le> \<parallel>f\<parallel>\<^sup>2\<close>)
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c * (2 * Re (\<langle> h - k , f \<rangle>)) \<le> \<parallel> c *\<^sub>R f \<parallel>^2)\<close>
       by (metis Re_complex_of_real cinner_scaleC_right complex_add_cnj complex_cnj_complex_of_real
           complex_cnj_mult of_real_mult scaleR_scaleC semiring_normalization_rules(34))
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c * (2 * Re (\<langle> h - k , f \<rangle>)) \<le> \<bar>c\<bar>^2*\<parallel> f \<parallel>^2)\<close>
       by (simp add: power_mult_distrib)
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c * (2 * Re (\<langle> h - k , f \<rangle>)) \<le> c^2*\<parallel> f \<parallel>^2)\<close>
       by auto
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> c * (2 * Re (\<langle> h - k , f \<rangle>)) \<le> c^2*\<parallel> f \<parallel>^2)\<close>
       by simp
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> c*(2 * Re (\<langle> h - k , f \<rangle>)) \<le> c*(c*\<parallel> f \<parallel>^2))\<close>
       by (simp add: power2_eq_square)
     hence  q4: \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) \<le> c*\<parallel> f \<parallel>^2)\<close>
       by simp
     have  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) \<le> 0)\<close>
       using q3
       by (simp add: q4 that)
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> (2 * Re (\<langle> h - k , (-1) *\<^sub>R f \<rangle>)) \<le> 0)\<close>
       using assms scaleR_scaleC complex_vector.subspace_def
       by (metis \<open>csubspace M\<close>)
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> -(2 * Re (\<langle> h - k , f \<rangle>)) \<le> 0)\<close>
       by simp
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) \<ge> 0)\<close>
       by simp
     hence \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) = 0)\<close>
       using  \<open>\<forall> f. f \<in>  M \<longrightarrow>
                 (\<forall> c::real. c > 0 \<longrightarrow> (2 * Re (\<langle> h - k , f \<rangle>)) \<le> 0)\<close>
       by fastforce
 
     have \<open>\<forall> f. f \<in>  M \<longrightarrow>
                  ((1::real) > 0 \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) = 0)\<close>
       using \<open>\<forall>f. f \<in>  M \<longrightarrow> (\<forall>c>0. 2 * Re (\<langle>h - k , f\<rangle> ) = 0)\<close> by blast
     hence \<open>\<forall> f. f \<in>  M \<longrightarrow> 2 * Re (\<langle> h - k , f \<rangle>) = 0\<close>
       by simp
     hence \<open>\<forall> f. f \<in>  M \<longrightarrow> Re (\<langle> h - k , f \<rangle>) = 0\<close>
       by simp
     have  \<open>\<forall> f. f \<in>  M \<longrightarrow> Re (\<langle> h - k , (Complex 0 (-1)) *\<^sub>C f \<rangle>) = 0\<close>
       using assms  complex_vector.subspace_def \<open>csubspace M\<close>
       by (metis \<open>\<forall>f. f \<in> M \<longrightarrow> Re \<langle>h - k, f\<rangle> = 0\<close>)
     hence  \<open>\<forall> f. f \<in>  M \<longrightarrow> Re ( (Complex 0 (-1))*(\<langle> h - k , f \<rangle>) ) = 0\<close>
       by simp
     hence \<open>\<forall> f. f \<in>  M \<longrightarrow> Im (\<langle> h - k , f \<rangle>) = 0\<close>
       using Complex_eq_neg_1 Re_i_times cinner_scaleC_right complex_of_real_def by auto
 
     have \<open>\<forall> f. f \<in>  M \<longrightarrow> (\<langle> h - k , f \<rangle>) = 0\<close>
       using complex_eq_iff
       by (simp add: \<open>\<forall>f. f \<in> M \<longrightarrow> Im \<langle>h - k, f\<rangle> = 0\<close> \<open>\<forall>f. f \<in> M \<longrightarrow> Re \<langle>h - k, f\<rangle> = 0\<close>)
     hence \<open>h - k \<in> orthogonal_complement M \<and> k \<in> M\<close>
       by (simp add: \<open>k \<in> M\<close> orthogonal_complementI)
     have  \<open>\<forall> c. c *\<^sub>R f \<in> M\<close>
       if "f \<in> M"
       for f
       using that scaleR_scaleC  \<open>csubspace M\<close> complex_vector.subspace_def
       by (simp add: complex_vector.subspace_def scaleR_scaleC)
     have \<open>\<langle> h - k , f \<rangle> = 0\<close>
       if "f \<in> M"
       for f
       using \<open>h - k \<in> orthogonal_complement M \<and> k \<in> M\<close> orthogonal_complement_orthoI that by auto
     hence \<open>h - k \<in> orthogonal_complement M\<close>
       by (simp add: orthogonal_complement_def)
     thus ?thesis
       using \<open>k \<in> M\<close> by auto
   qed
 
   have q1: \<open>dist h k \<le> dist h f \<close>
     if "f \<in> M" and  \<open>h - k \<in> orthogonal_complement M \<and> k \<in> M\<close>
     for f
   proof-
     have \<open>\<langle> h - k,  k - f \<rangle> = 0\<close>
       by (metis (no_types, lifting) that
           cinner_diff_right diff_0_right orthogonal_complement_orthoI that)
     have \<open>\<parallel> h - f \<parallel>^2 = \<parallel> (h - k) + (k - f) \<parallel>^2\<close>
       by simp
     also have \<open>... = \<parallel> h - k \<parallel>^2 + \<parallel> k - f \<parallel>^2\<close>
       using  \<open>\<langle> h - k, k - f \<rangle> = 0\<close> pythagorean_theorem by blast
     also have \<open>... \<ge> \<parallel> h - k \<parallel>^2\<close>
       by simp
     finally have \<open>\<parallel>h - k\<parallel>\<^sup>2 \<le> \<parallel>h - f\<parallel>\<^sup>2 \<close>
       by blast
     hence \<open>\<parallel>h - k\<parallel> \<le> \<parallel>h - f\<parallel>\<close>
       using norm_ge_zero power2_le_imp_le by blast
     thus ?thesis
       by (simp add: dist_norm)
   qed
 
   have  w1: "is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k"
     if "h - k \<in> orthogonal_complement M \<and> k \<in>  M"
   proof-
     have \<open>h - k \<in> orthogonal_complement M\<close>
       using that by blast
     have \<open>k \<in> M\<close> using \<open>h - k \<in> orthogonal_complement M \<and> k \<in>  M\<close>
       by blast
     thus ?thesis
       by (metis (no_types, lifting) dist_commute is_arg_min_linorder q1 that)
   qed
   show ?thesis
     using w1 w2 by blast
 qed
 
 corollary orthog_proj_exists:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>closed_csubspace M\<close>
   shows  \<open>\<exists>k. h - k \<in> orthogonal_complement M \<and> k \<in> M\<close>
 proof-
   from  \<open>closed_csubspace M\<close>
   have \<open>M \<noteq> {}\<close>
     using closed_csubspace.subspace complex_vector.subspace_0 by blast
   have \<open>closed  M\<close>
     using  \<open>closed_csubspace M\<close>
     by (simp add: closed_csubspace.closed)
   have \<open>convex  M\<close>
     using  \<open>closed_csubspace M\<close>
     by (simp)
   have \<open>\<exists>k.  is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) k\<close>
     by (simp add: smallest_dist_exists \<open>closed M\<close> \<open>convex M\<close> \<open>M \<noteq> {}\<close>)
   thus ?thesis
     by (simp add: assms smallest_dist_is_ortho)
 qed
 
 corollary orthog_proj_unique:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes \<open>closed_csubspace M\<close>
   assumes \<open>h - r \<in> orthogonal_complement M \<and> r \<in> M\<close>
   assumes \<open>h - s \<in> orthogonal_complement M \<and> s \<in> M\<close>
   shows  \<open>r = s\<close>
   using _ assms(2,3) unfolding smallest_dist_is_ortho[OF assms(1), symmetric]
   apply (rule smallest_dist_unique)
   using assms(1) by (simp)
 
 definition is_projection_on::\<open>('a \<Rightarrow> 'a) \<Rightarrow> ('a::metric_space) set \<Rightarrow> bool\<close> where
   \<open>is_projection_on \<pi> M \<longleftrightarrow> (\<forall>h. is_arg_min (\<lambda> x. dist x h) (\<lambda> x. x \<in> M) (\<pi> h))\<close>
 
 lemma is_projection_on_iff_orthog:
   \<open>closed_csubspace M \<Longrightarrow> is_projection_on \<pi> M \<longleftrightarrow> (\<forall>h. h - \<pi> h \<in> orthogonal_complement M \<and> \<pi> h \<in> M)\<close>
   by (simp add: is_projection_on_def smallest_dist_is_ortho)
 
 lemma is_projection_on_exists:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>convex M\<close> and \<open>closed M\<close> and \<open>M \<noteq> {}\<close>
   shows "\<exists>\<pi>. is_projection_on \<pi> M"
   unfolding is_projection_on_def apply (rule choice)
   using smallest_dist_exists[OF assms] by auto
 
 lemma is_projection_on_unique:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes \<open>convex M\<close>
   assumes "is_projection_on \<pi>\<^sub>1 M"
   assumes "is_projection_on \<pi>\<^sub>2 M"
   shows "\<pi>\<^sub>1 = \<pi>\<^sub>2"
   using smallest_dist_unique[OF assms(1)] using assms(2,3)
   unfolding is_projection_on_def by blast
 
 definition projection :: \<open>'a::metric_space set \<Rightarrow> ('a \<Rightarrow> 'a)\<close> where
   \<open>projection M \<equiv> SOME \<pi>. is_projection_on \<pi> M\<close>
 
 lemma projection_is_projection_on:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>convex M\<close> and \<open>closed M\<close> and \<open>M \<noteq> {}\<close>
   shows "is_projection_on (projection M) M"
   by (metis assms(1) assms(2) assms(3) is_projection_on_exists projection_def someI)
 
 lemma projection_is_projection_on'[simp]:
   \<comment> \<open>Common special case of @{thm projection_is_projection_on}\<close>
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>closed_csubspace M\<close>
   shows "is_projection_on (projection M) M"
   apply (rule projection_is_projection_on)
     apply (auto simp add: assms closed_csubspace.closed)
   using assms closed_csubspace.subspace complex_vector.subspace_0 by blast
 
 lemma projection_orthogonal:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes "closed_csubspace M" and \<open>m \<in> M\<close>
   shows \<open>is_orthogonal (h - projection M h) m\<close>
   by (metis assms(1) assms(2) closed_csubspace.closed closed_csubspace.subspace csubspace_is_convex empty_iff is_projection_on_iff_orthog orthogonal_complement_orthoI projection_is_projection_on)
 
 lemma is_projection_on_in_image:
   assumes "is_projection_on \<pi> M"
   shows "\<pi> h \<in> M"
   using assms
   by (simp add: is_arg_min_def is_projection_on_def)
 
 lemma is_projection_on_image:
   assumes "is_projection_on \<pi> M"
   shows "range \<pi> = M"
   using assms
   apply (auto simp: is_projection_on_in_image)
   by (smt (verit, ccfv_threshold) dist_pos_lt dist_self is_arg_min_def is_projection_on_def rangeI)
 
 lemma projection_in_image[simp]:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>convex M\<close> and \<open>closed M\<close> and \<open>M \<noteq> {}\<close>
   shows \<open>projection M h \<in> M\<close>
   by (simp add: assms(1) assms(2) assms(3) is_projection_on_in_image projection_is_projection_on)
 
 lemma projection_image[simp]:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>convex M\<close> and \<open>closed M\<close> and \<open>M \<noteq> {}\<close>
   shows \<open>range (projection M) = M\<close>
   by (simp add: assms(1) assms(2) assms(3) is_projection_on_image projection_is_projection_on)
 
 lemma projection_eqI':
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes \<open>convex M\<close>
   assumes \<open>is_projection_on f M\<close>
   shows \<open>projection M = f\<close>
   by (metis assms(1) assms(2) is_projection_on_unique projection_def someI_ex)
 
 lemma is_projection_on_eqI:
   fixes  M :: \<open>'a::complex_inner set\<close>
   assumes a1: \<open>closed_csubspace M\<close> and a2: \<open>h - x \<in> orthogonal_complement M\<close> and a3: \<open>x \<in> M\<close>
     and a4: \<open>is_projection_on \<pi> M\<close>
   shows \<open>\<pi> h = x\<close>
   by (meson a1 a2 a3 a4 closed_csubspace.subspace csubspace_is_convex is_projection_on_def smallest_dist_is_ortho smallest_dist_unique)
 
 lemma projection_eqI:
   fixes  M :: \<open>('a::chilbert_space) set\<close>
   assumes  \<open>closed_csubspace M\<close> and \<open>h - x \<in> orthogonal_complement M\<close> and \<open>x \<in> M\<close>
   shows \<open>projection M h = x\<close>
   by (metis assms(1) assms(2) assms(3) is_projection_on_iff_orthog orthog_proj_exists projection_def is_projection_on_eqI tfl_some)
 
 lemma is_projection_on_fixes_image:
   fixes M :: \<open>'a::metric_space set\<close>
   assumes a1: "is_projection_on \<pi> M" and a3: "x \<in> M"
   shows "\<pi> x = x"
   by (metis a1 a3 dist_pos_lt dist_self is_arg_min_def is_projection_on_def)
 
 lemma projection_fixes_image:
   fixes M :: \<open>('a::chilbert_space) set\<close>
   assumes a1: "closed_csubspace M" and a2: "x \<in> M"
   shows "(projection M) x = x"
   using is_projection_on_fixes_image
     \<comment> \<open>Theorem 2.7 in @{cite conway2013course}\<close>
   by (simp add: a1 a2 complex_vector.subspace_0 projection_eqI)
 
 proposition is_projection_on_reduces_norm:
   includes notation_norm
   fixes M :: \<open>('a::complex_inner) set\<close>
   assumes \<open>is_projection_on \<pi> M\<close> and \<open>closed_csubspace M\<close>
   shows \<open>\<parallel> \<pi>  h \<parallel> \<le> \<parallel> h \<parallel>\<close>
 proof-
   have \<open>h - \<pi> h \<in> orthogonal_complement M\<close>
     using assms is_projection_on_iff_orthog by blast
   hence \<open>\<forall> k \<in> M. \<langle>  h - \<pi> h , k \<rangle> = 0\<close>
     using orthogonal_complement_orthoI by blast
   also have \<open>\<pi> h \<in>  M\<close>
     using \<open>is_projection_on \<pi> M\<close>
     by (simp add: is_projection_on_in_image)
   ultimately have \<open>\<langle>  h - \<pi> h , \<pi> h \<rangle> = 0\<close>
     by auto
   hence \<open>\<parallel> \<pi> h \<parallel>^2 + \<parallel> h - \<pi> h \<parallel>^2 = \<parallel> h \<parallel>^2\<close>
     using pythagorean_theorem by fastforce
   hence \<open>\<parallel>\<pi> h \<parallel>^2 \<le> \<parallel> h \<parallel>^2\<close>
     by (smt zero_le_power2)
   thus ?thesis
     using norm_ge_zero power2_le_imp_le by blast
 qed
 
 proposition projection_reduces_norm:
   includes notation_norm
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes a1: "closed_csubspace M"
   shows \<open>\<parallel> projection M h \<parallel> \<le> \<parallel> h \<parallel>\<close>
   using assms is_projection_on_iff_orthog orthog_proj_exists is_projection_on_reduces_norm projection_eqI by blast
 
 \<comment> \<open>Theorem 2.7 (version) in @{cite conway2013course}\<close>
 theorem is_projection_on_bounded_clinear:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes a1: "is_projection_on \<pi> M" and a2: "closed_csubspace M"
   shows "bounded_clinear \<pi>"
 proof
   have b1:  \<open>csubspace (orthogonal_complement M)\<close>
     by (simp add: a2)
   have f1: "\<forall>a. a - \<pi> a \<in> orthogonal_complement M \<and> \<pi> a \<in> M"
     using a1 a2 is_projection_on_iff_orthog by blast
   hence "c *\<^sub>C x - c *\<^sub>C \<pi> x \<in> orthogonal_complement M"
     for c x
     by (metis (no_types) b1
         add_diff_cancel_right' complex_vector.subspace_def diff_add_cancel scaleC_add_right)
   thus r1: \<open>\<pi> (c *\<^sub>C x) = c *\<^sub>C (\<pi> x)\<close> for x c
     using f1 by (meson a2 a1 closed_csubspace.subspace
         complex_vector.subspace_def is_projection_on_eqI)
   show r2: \<open>\<pi> (x + y) =  (\<pi> x) + (\<pi> y)\<close>
     for x y
   proof-
     have "\<forall>A. \<not> closed_csubspace (A::'a set) \<or> csubspace A"
       by (metis closed_csubspace.subspace)
     hence "csubspace M"
       using a2 by auto
     hence \<open>\<pi> (x + y) - ( (\<pi> x) + (\<pi> y) ) \<in> M\<close>
       by (simp add: complex_vector.subspace_add complex_vector.subspace_diff f1)
     have \<open>closed_csubspace (orthogonal_complement M)\<close>
       using a2
       by simp
     have f1: "\<forall>a b. (b::'a) + (a - b) = a"
       by (metis add.commute diff_add_cancel)
     have f2: "\<forall>a b. (b::'a) - b = a - a"
       by auto
     hence f3: "\<forall>a. a - a \<in> orthogonal_complement M"
       by (simp add: complex_vector.subspace_0)
     have "\<forall>a b. (a \<in> orthogonal_complement M \<or> a + b \<notin> orthogonal_complement M)
              \<or> b \<notin> orthogonal_complement M"
       using add_diff_cancel_right' b1 complex_vector.subspace_diff
       by metis
     hence "\<forall>a b c. (a \<in> orthogonal_complement M \<or> c - (b + a) \<notin> orthogonal_complement M)
               \<or> c - b \<notin> orthogonal_complement M"
       using f1 by (metis diff_diff_add)
     hence f4: "\<forall>a b f. (f a - b \<in> orthogonal_complement M \<or> a - b \<notin> orthogonal_complement M)
               \<or> \<not> is_projection_on f M"
       using f1
       by (metis a2 is_projection_on_iff_orthog)
     have f5: "\<forall>a b c d. (d::'a) - (c + (b - a)) = d + (a - (b + c))"
       by auto
     have "x - \<pi> x \<in> orthogonal_complement M"
       using a1 a2 is_projection_on_iff_orthog by blast
     hence q1: \<open>\<pi> (x + y) - ( (\<pi> x) + (\<pi> y) ) \<in> orthogonal_complement M\<close>
       using f5 f4 f3 by (metis \<open>csubspace (orthogonal_complement M)\<close>
           \<open>is_projection_on \<pi> M\<close> add_diff_eq complex_vector.subspace_diff diff_diff_add
           diff_diff_eq2)
     hence \<open>\<pi> (x + y) - ( (\<pi> x) + (\<pi> y) ) \<in> M \<inter> (orthogonal_complement M)\<close>
       by (simp add: \<open>\<pi> (x + y) - (\<pi> x + \<pi> y) \<in> M\<close>)
     moreover have \<open>M \<inter> (orthogonal_complement M) = {0}\<close>
       by (simp add: \<open>closed_csubspace M\<close> complex_vector.subspace_0 orthogonal_complement_zero_intersection)
     ultimately have \<open>\<pi> (x + y) - ( (\<pi> x) + (\<pi> y) ) = 0\<close>
       by auto
     thus ?thesis by simp
   qed
   from is_projection_on_reduces_norm
   show t1: \<open>\<exists> K. \<forall> x. norm (\<pi> x) \<le> norm x * K\<close>
     by (metis a1 a2 mult.left_neutral ordered_field_class.sign_simps(5))
 qed
 
 theorem projection_bounded_clinear:
   fixes M :: \<open>('a::chilbert_space) set\<close>
   assumes a1: "closed_csubspace M"
   shows \<open>bounded_clinear (projection M)\<close>
     \<comment> \<open>Theorem 2.7 in @{cite conway2013course}\<close>
   using assms is_projection_on_iff_orthog orthog_proj_exists is_projection_on_bounded_clinear projection_eqI by blast
 
 proposition is_projection_on_idem:
   fixes M :: \<open>('a::complex_inner) set\<close>
   assumes "is_projection_on \<pi> M"
   shows "\<pi> (\<pi> x) = \<pi> x"
   using is_projection_on_fixes_image is_projection_on_in_image assms by blast
 
 proposition projection_idem:
   fixes M :: "'a::chilbert_space set"
   assumes a1: "closed_csubspace M"
   shows "projection M (projection M x) = projection M x"
   by (metis assms closed_csubspace.closed closed_csubspace.subspace complex_vector.subspace_0 csubspace_is_convex equals0D projection_fixes_image projection_in_image)
 
 
 proposition is_projection_on_kernel_is_orthogonal_complement:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes a1: "is_projection_on \<pi> M" and a2: "closed_csubspace M"
   shows "\<pi> -` {0} = orthogonal_complement M"
 proof-
   have "x \<in> (\<pi> -` {0})"
     if "x \<in> orthogonal_complement M"
     for x
     by (smt (verit, ccfv_SIG) a1 a2 closed_csubspace_def complex_vector.subspace_def complex_vector.subspace_diff is_projection_on_eqI orthogonal_complement_closed_subspace that vimage_singleton_eq)
   moreover have "x \<in> orthogonal_complement M"
     if s1: "x \<in> \<pi> -` {0}" for x
     by (metis a1 a2 diff_zero is_projection_on_iff_orthog that vimage_singleton_eq)
   ultimately show ?thesis
     by blast
 qed
 
 \<comment> \<open>Theorem 2.7 in @{cite conway2013course}\<close>
 proposition projection_kernel_is_orthogonal_complement:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes "closed_csubspace M"
   shows "(projection M) -` {0} = (orthogonal_complement M)"
   by (metis assms closed_csubspace_def complex_vector.subspace_def csubspace_is_convex insert_absorb insert_not_empty is_projection_on_kernel_is_orthogonal_complement projection_is_projection_on)
 
 lemma is_projection_on_id_minus:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes is_proj: "is_projection_on \<pi> M"
     and cc: "closed_csubspace M"
   shows "is_projection_on (id - \<pi>) (orthogonal_complement M)"
   using is_proj apply (simp add: cc is_projection_on_iff_orthog)
   using double_orthogonal_complement_increasing by blast
 
 
 text \<open>Exercise 2 (section 2, chapter I) in  @{cite conway2013course}\<close>
 lemma projection_on_orthogonal_complement[simp]:
   fixes M :: "'a::chilbert_space set"
   assumes a1: "closed_csubspace M"
   shows "projection (orthogonal_complement M) = id - projection M"
   apply (auto intro!: ext)
   by (smt (verit, ccfv_SIG) add_diff_cancel_left' assms closed_csubspace.closed closed_csubspace.subspace complex_vector.subspace_0 csubspace_is_convex diff_add_cancel double_orthogonal_complement_increasing insert_absorb insert_not_empty is_projection_on_iff_orthog orthogonal_complement_closed_subspace projection_eqI projection_is_projection_on subset_eq)
 
 lemma is_projection_on_zero:
   "is_projection_on (\<lambda>_. 0) {0}"
   by (simp add: is_projection_on_def is_arg_min_def)
 
 lemma projection_zero[simp]:
   "projection {0} = (\<lambda>_. 0)"
   using is_projection_on_zero
   by (metis (full_types) is_projection_on_in_image projection_def singletonD someI_ex)
 
 lemma is_projection_on_rank1:
   fixes t :: \<open>'a::complex_inner\<close>
   shows \<open>is_projection_on (\<lambda>x. (\<langle>t , x\<rangle> / \<langle>t , t\<rangle>) *\<^sub>C t) (cspan {t})\<close>
 proof (cases \<open>t = 0\<close>)
   case True
   then show ?thesis
     by (simp add: is_projection_on_zero)
 next
   case False
   define P where \<open>P x = (\<langle>t , x\<rangle> / \<langle>t , t\<rangle>) *\<^sub>C t\<close> for x
   define t' where \<open>t' = t /\<^sub>C norm t\<close>
   with False have \<open>norm t' = 1\<close>
     by (simp add: norm_inverse)
   have P_def': \<open>P x = cinner t' x *\<^sub>C t'\<close> for x
     unfolding P_def t'_def apply auto
     by (metis divide_divide_eq_left divide_inverse mult.commute power2_eq_square power2_norm_eq_cinner)
   have spant': \<open>cspan {t} = cspan {t'}\<close>
     by (simp add: False t'_def)
   have cc: \<open>closed_csubspace (cspan {t})\<close>
     by (auto intro!: finite_cspan_closed closed_csubspace.intro)
   have ortho: \<open>h - P h \<in> orthogonal_complement (cspan {t})\<close> for h
     unfolding orthogonal_complement_def P_def' spant' apply auto
     by (smt (verit, ccfv_threshold) \<open>norm t' = 1\<close> add_cancel_right_left cinner_add_right cinner_commute' cinner_scaleC_right cnorm_eq_1 complex_vector.span_breakdown_eq complex_vector.span_empty diff_add_cancel mult_cancel_left1 singletonD)
   have inspan: \<open>P h \<in> cspan {t}\<close> for h
     unfolding P_def' spant'
     by (simp add: complex_vector.span_base complex_vector.span_scale)
   show \<open>is_projection_on P (cspan {t})\<close>
     apply (subst is_projection_on_iff_orthog)
     using cc ortho inspan by auto
 qed
 
 lemma projection_rank1:
   fixes t x :: \<open>'a::complex_inner\<close>
   shows \<open>projection (cspan {t}) x = (\<langle>t , x\<rangle> / \<langle>t , t\<rangle>) *\<^sub>C t\<close>
   apply (rule fun_cong, rule projection_eqI', simp)
   by (rule is_projection_on_rank1)
 
 subsection \<open>More orthogonal complement\<close>
 
 text \<open>The following lemmas logically fit into the "orthogonality" section but depend on projections for their proofs.\<close>
 
 text \<open>Corollary 2.8 in  @{cite conway2013course}\<close>
 theorem double_orthogonal_complement_id[simp]:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes a1: "closed_csubspace M"
   shows "orthogonal_complement (orthogonal_complement M) = M"
 proof-
   have b2: "x \<in> (id - projection M) -` {0}"
     if c1: "x \<in> M" for x
     by (simp add: assms projection_fixes_image that)
 
   have b3: \<open>x \<in> M\<close>
     if c1: \<open>x \<in> (id - projection M) -` {0}\<close> for x
     by (metis assms closed_csubspace.closed closed_csubspace.subspace complex_vector.subspace_0 csubspace_is_convex eq_id_iff equals0D fun_diff_def projection_in_image right_minus_eq that vimage_singleton_eq)
   have \<open>x \<in>  M \<longleftrightarrow> x \<in> (id - projection M) -` {0}\<close> for x
     using b2 b3 by blast
   hence b4: \<open>( id - (projection M) ) -` {0} =  M\<close>
     by blast
   have b1: "orthogonal_complement (orthogonal_complement M)
           = (projection (orthogonal_complement M)) -` {0}"
     by (simp add: a1 projection_kernel_is_orthogonal_complement del: projection_on_orthogonal_complement)
   also have \<open>... = ( id - (projection M) ) -` {0}\<close>
     by (simp add: a1)
   also have \<open>... = M\<close>
     by (simp add: b4)
   finally show ?thesis by blast
 qed
 
 lemma orthogonal_complement_antimono[simp]:
   fixes  A B :: \<open>('a::complex_inner) set\<close>
   assumes "A \<supseteq> B"
   shows \<open>orthogonal_complement A \<subseteq> orthogonal_complement B\<close>
   by (meson assms orthogonal_complementI orthogonal_complement_orthoI' subsetD subsetI)
 
 lemma orthogonal_complement_antimono_iff[simp]:
   fixes  A B :: \<open>('a::chilbert_space) set\<close>
   assumes \<open>closed_csubspace A\<close> and  \<open>closed_csubspace B\<close>
   shows \<open>orthogonal_complement A \<subseteq> orthogonal_complement B \<longleftrightarrow> A \<supseteq> B\<close>
 proof
   show \<open>orthogonal_complement A \<subseteq> orthogonal_complement B\<close> if \<open>A \<supseteq> B\<close>
     using that by auto
 
   assume \<open>orthogonal_complement A \<subseteq> orthogonal_complement B\<close>
   then have \<open>orthogonal_complement (orthogonal_complement A) \<supseteq> orthogonal_complement (orthogonal_complement B)\<close>
     by simp
   then show \<open>A \<supseteq> B\<close>
     using assms by auto
 qed
 
 lemma orthogonal_complement_UNIV[simp]:
   "orthogonal_complement UNIV = {0}"
   by (metis Int_UNIV_left complex_vector.subspace_UNIV complex_vector.subspace_def orthogonal_complement_zero_intersection)
 
 lemma orthogonal_complement_zero[simp]:
   "orthogonal_complement {0} = UNIV"
   unfolding orthogonal_complement_def by auto
 
 
 lemma de_morgan_orthogonal_complement_plus:
   fixes A B::"('a::complex_inner) set"
   assumes \<open>0 \<in> A\<close> and \<open>0 \<in> B\<close>
   shows \<open>orthogonal_complement (A +\<^sub>M B) = (orthogonal_complement A) \<inter> (orthogonal_complement B)\<close>
 proof-
   have "x \<in> (orthogonal_complement A) \<inter> (orthogonal_complement B)"
     if "x \<in> orthogonal_complement (A +\<^sub>M B)"
     for x
   proof-
     have \<open>orthogonal_complement (A +\<^sub>M B) = orthogonal_complement (A + B)\<close>
       unfolding closed_sum_def by (subst orthogonal_complement_of_closure[symmetric], simp)
     hence \<open>x \<in> orthogonal_complement (A + B)\<close>
       using that by blast
     hence t1: \<open>\<forall>z \<in> (A + B). \<langle> z , x \<rangle> = 0\<close>
       by (simp add: orthogonal_complement_orthoI')
     have \<open>A \<subseteq> A + B\<close>
       using subset_iff add.commute set_zero_plus2 \<open>0 \<in> B\<close>
       by fastforce
     hence \<open>\<forall>z \<in> A. \<langle> z , x \<rangle> = 0\<close>
       using t1 by auto
     hence w1: \<open>x \<in> (orthogonal_complement A)\<close>
       by (smt mem_Collect_eq is_orthogonal_sym orthogonal_complement_def)
     have \<open>B \<subseteq> A + B\<close>
       using \<open>0 \<in> A\<close> subset_iff set_zero_plus2 by blast
     hence \<open>\<forall> z \<in> B. \<langle> z , x \<rangle> = 0\<close>
       using t1 by auto
     hence \<open>x \<in> (orthogonal_complement B)\<close>
       by (smt mem_Collect_eq is_orthogonal_sym orthogonal_complement_def)
     thus ?thesis
       using w1 by auto
   qed
   moreover have "x \<in> (orthogonal_complement (A +\<^sub>M B))"
     if v1: "x \<in> (orthogonal_complement A) \<inter> (orthogonal_complement B)"
     for x
   proof-
     have \<open>x \<in> (orthogonal_complement A)\<close>
       using v1
       by blast
     hence \<open>\<forall>y\<in> A. \<langle> y , x \<rangle> = 0\<close>
       by (simp add: orthogonal_complement_orthoI')
     have \<open>x \<in> (orthogonal_complement B)\<close>
       using v1
       by blast
     hence \<open>\<forall> y\<in> B. \<langle> y , x \<rangle> = 0\<close>
       by (simp add: orthogonal_complement_orthoI')
     have \<open>\<forall> a\<in>A. \<forall> b\<in>B. \<langle> a+b , x \<rangle> = 0\<close>
       by (simp add: \<open>\<forall>y\<in>A. \<langle>y , x\<rangle> = 0\<close> \<open>\<forall>y\<in>B. \<langle>y , x\<rangle> = 0\<close> cinner_add_left)
     hence \<open>\<forall> y \<in> (A + B). \<langle> y , x \<rangle> = 0\<close>
       using set_plus_elim by force
     hence \<open>x \<in> (orthogonal_complement (A + B))\<close>
       by (smt mem_Collect_eq is_orthogonal_sym orthogonal_complement_def)
     moreover have \<open>(orthogonal_complement (A + B)) = (orthogonal_complement (A +\<^sub>M B))\<close>
       unfolding closed_sum_def by (subst orthogonal_complement_of_closure[symmetric], simp)
     ultimately have \<open>x \<in> (orthogonal_complement (A +\<^sub>M B))\<close>
       by blast
     thus ?thesis
       by blast
   qed
   ultimately show ?thesis by blast
 qed
 
 lemma de_morgan_orthogonal_complement_inter:
   fixes A B::"'a::chilbert_space set"
   assumes a1: \<open>closed_csubspace A\<close> and a2: \<open>closed_csubspace B\<close>
   shows  \<open>orthogonal_complement (A \<inter> B) = orthogonal_complement A +\<^sub>M orthogonal_complement B\<close>
 proof-
   have \<open>orthogonal_complement A +\<^sub>M orthogonal_complement B
     = orthogonal_complement (orthogonal_complement (orthogonal_complement A +\<^sub>M orthogonal_complement B))\<close>
     by (simp add: closed_subspace_closed_sum)
   also have \<open>\<dots> = orthogonal_complement (orthogonal_complement (orthogonal_complement A) \<inter> orthogonal_complement (orthogonal_complement B))\<close>
     by (simp add: de_morgan_orthogonal_complement_plus orthogonal_complementI)
   also have \<open>\<dots> = orthogonal_complement (A \<inter> B)\<close>
     by (simp add: a1 a2)
   finally show ?thesis
     by simp
 qed
 
 lemma orthogonal_complement_of_cspan: \<open>orthogonal_complement A = orthogonal_complement (cspan A)\<close>
   by (metis (no_types, opaque_lifting) closed_csubspace.subspace complex_vector.span_minimal complex_vector.span_superset double_orthogonal_complement_increasing orthogonal_complement_antimono orthogonal_complement_closed_subspace subset_antisym)
 
 lemma orthogonal_complement_orthogonal_complement_closure_cspan:
   \<open>orthogonal_complement (orthogonal_complement S) = closure (cspan S)\<close> for S :: \<open>'a::chilbert_space set\<close>
 proof -
   have \<open>orthogonal_complement (orthogonal_complement S) = orthogonal_complement (orthogonal_complement (closure (cspan S)))\<close>
     by (simp flip: orthogonal_complement_of_closure orthogonal_complement_of_cspan)
   also have \<open>\<dots> = closure (cspan S)\<close>
     by simp
   finally show \<open>orthogonal_complement (orthogonal_complement S) = closure (cspan S)\<close>
     by -
 qed
 
+subsection \<open>Orthogonal spaces\<close>
+(* TODO: Add to report overview *)
+
+definition \<open>orthogonal_spaces S T \<longleftrightarrow> (\<forall>x\<in>space_as_set S. \<forall>y\<in>space_as_set T. is_orthogonal x y)\<close>
+
+lemma orthogonal_spaces_leq_compl: \<open>orthogonal_spaces S T \<longleftrightarrow> S \<le> -T\<close>
+  unfolding orthogonal_spaces_def apply transfer
+  by (auto simp: orthogonal_complement_def)
+
+lemma orthogonal_bot[simp]: \<open>orthogonal_spaces S bot\<close>
+  by (simp add: orthogonal_spaces_def)
+
+lemma orthogonal_spaces_sym: \<open>orthogonal_spaces S T \<Longrightarrow> orthogonal_spaces T S\<close>
+  unfolding orthogonal_spaces_def
+  using is_orthogonal_sym by blast
+
+lemma orthogonal_sup: \<open>orthogonal_spaces S T1 \<Longrightarrow> orthogonal_spaces S T2 \<Longrightarrow> orthogonal_spaces S (sup T1 T2)\<close>
+  apply (rule orthogonal_spaces_sym)
+  apply (simp add: orthogonal_spaces_leq_compl)
+  using orthogonal_spaces_leq_compl orthogonal_spaces_sym by blast
+
+lemma orthogonal_sum:
+  assumes \<open>finite F\<close> and \<open>\<And>x. x\<in>F \<Longrightarrow> orthogonal_spaces S (T x)\<close> 
+  shows \<open>orthogonal_spaces S (sum T F)\<close>
+  using assms
+  apply induction
+  by (auto intro!: orthogonal_sup)
+
+
 subsection \<open>Orthonormal bases\<close>
 
 lemma ortho_basis_exists: 
   fixes S :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_ortho_set S\<close>
   shows \<open>\<exists>B. B \<supseteq> S \<and> is_ortho_set B \<and> closure (cspan B) = UNIV\<close>
 proof -
   define on where \<open>on B \<longleftrightarrow> B \<supseteq> S \<and> is_ortho_set B\<close> for B :: \<open>'a set\<close>
   have \<open>\<exists>B\<in>Collect on. \<forall>B'\<in>Collect on. B \<subseteq> B' \<longrightarrow> B' = B\<close>
   proof (rule subset_Zorn_nonempty; simp)
     show \<open>\<exists>S. on S\<close>
       apply (rule exI[of _ S])
       using assms on_def by fastforce
   next
     fix C :: \<open>'a set set\<close>
     assume \<open>C \<noteq> {}\<close>
     assume \<open>subset.chain (Collect on) C\<close>
     then have C_on: \<open>B \<in> C \<Longrightarrow> on B\<close> and C_order: \<open>B \<in> C \<Longrightarrow> B' \<in> C \<Longrightarrow> B \<subseteq> B' \<or> B' \<subseteq> B\<close> for B B'
       by (auto simp: subset.chain_def)
     have \<open>is_orthogonal x y\<close> if \<open>x\<in>\<Union>C\<close> \<open>y\<in>\<Union>C\<close> \<open>x \<noteq> y\<close> for x y
       by (smt (verit) UnionE C_order C_on on_def is_ortho_set_def subsetD that(1) that(2) that(3))
     moreover have \<open>0 \<notin> \<Union> C\<close>
       by (meson UnionE C_on is_ortho_set_def on_def)
     moreover have \<open>\<Union>C \<supseteq> S\<close>
       using C_on \<open>C \<noteq> {}\<close> on_def by blast
     ultimately show \<open>on (\<Union> C)\<close>
       unfolding on_def is_ortho_set_def by simp
   qed
   then obtain B where \<open>on B\<close> and B_max: \<open>B' \<supseteq> B \<Longrightarrow> on B' \<Longrightarrow> B=B'\<close> for B'
     by auto
   have \<open>\<psi> = 0\<close> if \<psi>ortho: \<open>\<forall>b\<in>B. is_orthogonal \<psi> b\<close> for \<psi> :: 'a
   proof (rule ccontr)
     assume \<open>\<psi> \<noteq> 0\<close>
     define \<phi> B' where \<open>\<phi> = \<psi> /\<^sub>R norm \<psi>\<close> and \<open>B' = B \<union> {\<phi>}\<close>
     have [simp]: \<open>norm \<phi> = 1\<close>
       using \<open>\<psi> \<noteq> 0\<close> by (auto simp: \<phi>_def)
     have \<phi>ortho: \<open>is_orthogonal \<phi> b\<close> if \<open>b \<in> B\<close> for b
       using \<psi>ortho that \<phi>_def  by auto
     have orthoB': \<open>is_orthogonal x y\<close> if \<open>x\<in>B'\<close> \<open>y\<in>B'\<close> \<open>x \<noteq> y\<close> for x y
       using that \<open>on B\<close> \<phi>ortho \<phi>ortho[THEN is_orthogonal_sym[THEN iffD1]]
       by (auto simp: B'_def on_def is_ortho_set_def)
     have B'0: \<open>0 \<notin> B'\<close>
       using B'_def \<open>norm \<phi> = 1\<close> \<open>on B\<close> is_ortho_set_def on_def by fastforce
     have \<open>S \<subseteq> B'\<close>
       using B'_def \<open>on B\<close> on_def by auto
     from orthoB' B'0 \<open>S \<subseteq> B'\<close> have \<open>on B'\<close>
       by (simp add: on_def is_ortho_set_def)
     with B_max have \<open>B = B'\<close>
       by (metis B'_def Un_upper1)
     then have \<open>\<phi> \<in> B\<close>
       using B'_def by blast
     then have \<open>is_orthogonal \<phi> \<phi>\<close>
       using \<phi>ortho by blast
     then show False
       using B'0 \<open>B = B'\<close> \<open>\<phi> \<in> B\<close> by fastforce
   qed 
   then have \<open>orthogonal_complement B = {0}\<close>
     by (auto simp: orthogonal_complement_def)
   then have \<open>UNIV = orthogonal_complement (orthogonal_complement B)\<close>
     by simp
   also have \<open>\<dots> = orthogonal_complement (orthogonal_complement (closure (cspan B)))\<close>
     by (metis (mono_tags, opaque_lifting) \<open>orthogonal_complement B = {0}\<close> cinner_zero_left complex_vector.span_superset empty_iff insert_iff orthogonal_complementI orthogonal_complement_antimono orthogonal_complement_of_closure subsetI subset_antisym)
   also have \<open>\<dots> = closure (cspan B)\<close>
     apply (rule double_orthogonal_complement_id)
     by simp
   finally have \<open>closure (cspan B) = UNIV\<close>
     by simp
   with \<open>on B\<close> show ?thesis
     by (auto simp: on_def)
 qed
 
 lemma orthonormal_basis_exists: 
   fixes S :: \<open>'a::chilbert_space set\<close>
   assumes \<open>is_ortho_set S\<close> and \<open>\<And>x. x\<in>S \<Longrightarrow> norm x = 1\<close>
   shows \<open>\<exists>B. B \<supseteq> S \<and> is_onb B\<close>
 proof -
   from \<open>is_ortho_set S\<close>
   obtain B where \<open>is_ortho_set B\<close> and \<open>B \<supseteq> S\<close> and \<open>closure (cspan B) = UNIV\<close>
     using ortho_basis_exists by blast
   define B' where \<open>B' = (\<lambda>x. x /\<^sub>R norm x) ` B\<close>
   have \<open>S = (\<lambda>x. x /\<^sub>R norm x) ` S\<close>
     by (simp add: assms(2))
   then have \<open>B' \<supseteq> S\<close>
     using B'_def \<open>S \<subseteq> B\<close> by blast
   moreover 
   have \<open>ccspan B' = top\<close>
     apply (transfer fixing: B')
     apply (simp add: B'_def scaleR_scaleC)
     apply (subst complex_vector.span_image_scale')
     using \<open>is_ortho_set B\<close> \<open>closure (cspan B) = UNIV\<close> is_ortho_set_def 
     by auto
   moreover have \<open>is_ortho_set B'\<close>
     using \<open>is_ortho_set B\<close> by (auto simp: B'_def is_ortho_set_def)
   moreover have \<open>\<forall>b\<in>B'. norm b = 1\<close>
     using \<open>is_ortho_set B\<close> apply (auto simp: B'_def is_ortho_set_def)
     by (metis field_class.field_inverse norm_eq_zero)
   ultimately show ?thesis
     by (auto simp: is_onb_def)
 qed
 
 
 definition some_chilbert_basis :: \<open>'a::chilbert_space set\<close> where
   \<open>some_chilbert_basis = (SOME B::'a set. is_onb B)\<close>
 
 lemma is_onb_some_chilbert_basis[simp]: \<open>is_onb (some_chilbert_basis :: 'a::chilbert_space set)\<close>
   using orthonormal_basis_exists[OF is_ortho_set_empty]
   by (auto simp add: some_chilbert_basis_def intro: someI2)
 
 lemma is_ortho_set_some_chilbert_basis[simp]: \<open>is_ortho_set some_chilbert_basis\<close>
   using is_onb_def is_onb_some_chilbert_basis by blast
 lemma is_normal_some_chilbert_basis: \<open>\<And>x. x \<in> some_chilbert_basis \<Longrightarrow> norm x = 1\<close>
   using is_onb_def is_onb_some_chilbert_basis by blast
 lemma ccspan_some_chilbert_basis[simp]: \<open>ccspan some_chilbert_basis = top\<close>
   using is_onb_def is_onb_some_chilbert_basis by blast
 lemma span_some_chilbert_basis[simp]: \<open>closure (cspan some_chilbert_basis) = UNIV\<close>
   by (metis ccspan.rep_eq ccspan_some_chilbert_basis top_ccsubspace.rep_eq)
 
 lemma cindependent_some_chilbert_basis[simp]: \<open>cindependent some_chilbert_basis\<close>
   using is_ortho_set_cindependent is_ortho_set_some_chilbert_basis by blast
 
 lemma finite_some_chilbert_basis[simp]: \<open>finite (some_chilbert_basis :: 'a :: {chilbert_space, cfinite_dim} set)\<close>
   apply (rule cindependent_cfinite_dim_finite)
   by simp
 
 lemma some_chilbert_basis_nonempty: \<open>(some_chilbert_basis :: 'a::{chilbert_space, not_singleton} set) \<noteq> {}\<close>
 proof (rule ccontr, simp)
   define B :: \<open>'a set\<close> where \<open>B = some_chilbert_basis\<close>
   assume [simp]: \<open>B = {}\<close>
   have \<open>UNIV = closure (cspan B)\<close>
     using B_def span_some_chilbert_basis by blast
   also have \<open>\<dots> = {0}\<close>
     by simp
   also have \<open>\<dots> \<noteq> UNIV\<close>
     using Extra_General.UNIV_not_singleton by blast
   finally show False
     by simp
 qed
 
 subsection \<open>Riesz-representation theorem\<close>
 
 lemma orthogonal_complement_kernel_functional:
   fixes f :: \<open>'a::complex_inner \<Rightarrow> complex\<close>
   assumes \<open>bounded_clinear f\<close>
   shows \<open>\<exists>x. orthogonal_complement (f -` {0}) = cspan {x}\<close>
 proof (cases \<open>orthogonal_complement (f -` {0}) = {0}\<close>)
   case True
   then show ?thesis
     apply (rule_tac x=0 in exI) by auto
 next
   case False
   then obtain x where xortho: \<open>x \<in> orthogonal_complement (f -` {0})\<close> and xnon0: \<open>x \<noteq> 0\<close>
     using complex_vector.subspace_def by fastforce
 
   from xnon0 xortho
   have r1: \<open>f x \<noteq> 0\<close>
     by (metis cinner_eq_zero_iff orthogonal_complement_orthoI vimage_singleton_eq)
 
   have \<open>\<exists> k. y = k *\<^sub>C x\<close> if \<open>y \<in> orthogonal_complement (f -` {0})\<close> for y
   proof (cases \<open>y = 0\<close>)
     case True
     then show ?thesis by auto
   next
     case False
     with that
     have \<open>f y \<noteq> 0\<close>
       by (metis cinner_eq_zero_iff orthogonal_complement_orthoI vimage_singleton_eq)
     then obtain k where k_def: \<open>f x = k * f y\<close>
       by (metis add.inverse_inverse minus_divide_eq_eq)
     with assms have \<open>f x = f (k *\<^sub>C y)\<close>
       by (simp add: bounded_clinear.axioms(1) clinear.scaleC)
     hence \<open>f x - f (k *\<^sub>C y) = 0\<close>
       by simp
     with assms have s1: \<open>f (x - k *\<^sub>C y) = 0\<close>
       by (simp add: bounded_clinear.axioms(1) complex_vector.linear_diff)
     from that have \<open>k *\<^sub>C y \<in> orthogonal_complement (f -` {0})\<close>
       by (simp add: complex_vector.subspace_scale)
     with xortho have s2: \<open>x - (k *\<^sub>C y) \<in> orthogonal_complement (f -` {0})\<close>
       by (simp add: complex_vector.subspace_diff)
     have s3: \<open>(x - (k *\<^sub>C y)) \<in> f -` {0}\<close>
       using s1 by simp
     moreover have \<open>(f -` {0}) \<inter> (orthogonal_complement (f -` {0})) = {0}\<close>
       by (meson assms closed_csubspace_def complex_vector.subspace_def kernel_is_closed_csubspace
           orthogonal_complement_zero_intersection)
     ultimately have \<open>x - (k *\<^sub>C y) = 0\<close>
       using s2 by blast
     thus ?thesis
       by (metis ceq_vector_fraction_iff eq_iff_diff_eq_0 k_def r1 scaleC_scaleC)
   qed
   then have \<open>orthogonal_complement (f -` {0}) \<subseteq> cspan {x}\<close>
     using complex_vector.span_superset complex_vector.subspace_scale by blast
 
   moreover from xortho have \<open>orthogonal_complement (f -` {0}) \<supseteq> cspan {x}\<close>
     by (simp add: complex_vector.span_minimal)
 
   ultimately show ?thesis
     by auto
 qed
 
 lemma riesz_frechet_representation_existence:
   \<comment> \<open>Theorem 3.4 in @{cite conway2013course}\<close>
   fixes f::\<open>'a::chilbert_space \<Rightarrow> complex\<close>
   assumes a1: \<open>bounded_clinear f\<close>
   shows \<open>\<exists>t. \<forall>x.  f x = \<langle>t, x\<rangle>\<close>
 proof(cases \<open>\<forall> x. f x = 0\<close>)
   case True
   thus ?thesis
     by (metis cinner_zero_left)
 next
   case False
   obtain t where spant: \<open>orthogonal_complement (f -` {0}) = cspan {t}\<close>
     using orthogonal_complement_kernel_functional
     using assms by blast
   have \<open>projection (orthogonal_complement (f -` {0})) x = (\<langle>t , x\<rangle>/\<langle>t , t\<rangle>) *\<^sub>C t\<close> for x
     apply (subst spant) by (rule projection_rank1)
   hence \<open>f (projection (orthogonal_complement (f -` {0})) x) = ((\<langle>t , x\<rangle>)/(\<langle>t , t\<rangle>)) * (f t)\<close> for x
     using a1 unfolding bounded_clinear_def
     by (simp add: complex_vector.linear_scale)
   hence l2: \<open>f (projection (orthogonal_complement (f -` {0})) x) = \<langle>((cnj (f t)/\<langle>t , t\<rangle>) *\<^sub>C t) , x\<rangle>\<close> for x
     using complex_cnj_divide by force
   have \<open>f (projection (f -` {0}) x) = 0\<close> for x
     by (metis (no_types, lifting) assms bounded_clinear_def closed_csubspace.closed
         complex_vector.linear_subspace_vimage complex_vector.subspace_0 complex_vector.subspace_single_0
         csubspace_is_convex insert_absorb insert_not_empty kernel_is_closed_csubspace projection_in_image vimage_singleton_eq)
   hence "\<And>a b. f (projection (f -` {0}) a + b) = 0 + f b"
     using additive.add assms
     by (simp add: bounded_clinear_def complex_vector.linear_add)
   hence "\<And>a. 0 + f (projection (orthogonal_complement (f -` {0})) a) = f a"
     apply (simp add: assms)
     by (metis add.commute diff_add_cancel)
   hence \<open>f x = \<langle>(cnj (f t)/\<langle>t , t\<rangle>) *\<^sub>C t, x\<rangle>\<close> for x
     by (simp add: l2)
   thus ?thesis
     by blast
 qed
 
 lemma riesz_frechet_representation_unique:
   \<comment> \<open>Theorem 3.4 in @{cite conway2013course}\<close>
   fixes f::\<open>'a::complex_inner \<Rightarrow> complex\<close>
   assumes \<open>\<And>x. f x = \<langle>t, x\<rangle>\<close>
   assumes \<open>\<And>x. f x = \<langle>u, x\<rangle>\<close>
   shows \<open>t = u\<close>
   by (metis add_diff_cancel_left' assms(1) assms(2) cinner_diff_left cinner_gt_zero_iff diff_add_cancel diff_zero)
 
 
 subsection \<open>Adjoints\<close>
 
 definition "is_cadjoint F G \<longleftrightarrow> (\<forall>x. \<forall>y. \<langle>F x, y\<rangle> = \<langle>x, G y\<rangle>)"
 
 lemma is_adjoint_sym:
   \<open>is_cadjoint F G \<Longrightarrow> is_cadjoint G F\<close>
   unfolding is_cadjoint_def apply auto
   by (metis cinner_commute')
 
 definition \<open>cadjoint G = (SOME F. is_cadjoint F G)\<close>
   for G :: "'b::complex_inner \<Rightarrow> 'a::complex_inner"
 
 lemma cadjoint_exists:
   fixes G :: "'b::chilbert_space \<Rightarrow> 'a::complex_inner"
   assumes [simp]: \<open>bounded_clinear G\<close>
   shows \<open>\<exists>F. is_cadjoint F G\<close>
 proof -
   include notation_norm
   have [simp]: \<open>clinear G\<close>
     using assms unfolding bounded_clinear_def by blast
   define g :: \<open>'a \<Rightarrow> 'b \<Rightarrow> complex\<close>
     where \<open>g x y = \<langle>x , G y\<rangle>\<close> for x y
   have \<open>bounded_clinear (g x)\<close> for x
   proof -
     have \<open>g x (a + b) = g x a + g x b\<close> for a b
       unfolding g_def
       using additive.add cinner_add_right clinear_def
       by (simp add: cinner_add_right complex_vector.linear_add)
     moreover have  \<open>g x (k *\<^sub>C a) = k *\<^sub>C (g x a)\<close>
       for a k
       unfolding g_def
       by (simp add: complex_vector.linear_scale)
     ultimately have \<open>clinear (g x)\<close>
       by (simp add: clinearI)
     moreover
     have \<open>\<exists> M. \<forall> y. \<parallel> G y \<parallel> \<le> \<parallel> y \<parallel> * M\<close>
       using \<open>bounded_clinear G\<close>
       unfolding bounded_clinear_def bounded_clinear_axioms_def by blast
     then have \<open>\<exists>M. \<forall>y. \<parallel> g x y \<parallel> \<le> \<parallel> y \<parallel> * M\<close>
       using g_def
       by (simp add: bounded_clinear.bounded bounded_clinear_cinner_right_comp)
     ultimately show ?thesis unfolding bounded_linear_def
       using bounded_clinear.intro
       using bounded_clinear_axioms_def by blast
   qed
   hence \<open>\<forall>x. \<exists>t. \<forall>y.  g x y = \<langle>t, y\<rangle>\<close>
     using riesz_frechet_representation_existence by blast
   then obtain F where \<open>\<forall>x. \<forall>y. g x y = \<langle>F x, y\<rangle>\<close>
     by metis
   then have \<open>is_cadjoint F G\<close>
     unfolding is_cadjoint_def g_def by simp
   thus ?thesis
     by auto
 qed
 
 lemma cadjoint_is_cadjoint[simp]:
   fixes G :: "'b::chilbert_space \<Rightarrow> 'a::complex_inner"
   assumes [simp]: \<open>bounded_clinear G\<close>
   shows \<open>is_cadjoint (cadjoint G) G\<close>
   by (metis assms cadjoint_def cadjoint_exists someI_ex)
 
 lemma is_cadjoint_unique:
   assumes \<open>is_cadjoint F1 G\<close>
   assumes \<open>is_cadjoint F2 G\<close>
   shows \<open>F1 = F2\<close>
 proof (rule ext)
   fix x
   {
     fix y
     have \<open>cinner (F1 x - F2 x) y = cinner (F1 x) y - cinner (F2 x) y\<close>
       by (simp add: cinner_diff_left)
     also have \<open>\<dots> = cinner x (G y) - cinner x (G y)\<close>
       by (metis assms(1) assms(2) is_cadjoint_def)
     also have \<open>\<dots> = 0\<close>
       by simp
     finally have \<open>cinner (F1 x - F2 x) y = 0\<close>
       by -
   }
   then show \<open>F1 x = F2 x\<close>
     by fastforce
 qed
 
 lemma cadjoint_univ_prop:
   fixes G :: "'b::chilbert_space \<Rightarrow> 'a::complex_inner"
   assumes a1: \<open>bounded_clinear G\<close>
   shows \<open>\<forall>x. \<forall>y. \<langle>cadjoint G x, y\<rangle> = \<langle>x, G y\<rangle>\<close>
   using assms cadjoint_is_cadjoint is_cadjoint_def by blast
 
 lemma cadjoint_univ_prop':
   fixes G :: "'b::chilbert_space \<Rightarrow> 'a::complex_inner"
   assumes a1: \<open>bounded_clinear G\<close>
   shows \<open>\<forall>x. \<forall>y. \<langle>x, cadjoint G y\<rangle> = \<langle>G x, y\<rangle>\<close>
   by (metis cadjoint_univ_prop assms cinner_commute')
 
 notation cadjoint ("_\<^sup>\<dagger>" [99] 100)
 
 lemma cadjoint_eqI:
   fixes G:: \<open>'b::complex_inner \<Rightarrow> 'a::complex_inner\<close>
     and F:: \<open>'a \<Rightarrow> 'b\<close>
   assumes \<open>\<And>x y. \<langle>F x, y\<rangle> = \<langle>x, G y\<rangle>\<close>
   shows \<open>G\<^sup>\<dagger> = F\<close>
   by (metis assms cadjoint_def is_cadjoint_def is_cadjoint_unique someI_ex)
 
 lemma cadjoint_bounded_clinear:
   fixes A :: "'a::chilbert_space \<Rightarrow> 'b::complex_inner"
   assumes a1: "bounded_clinear A"
   shows \<open>bounded_clinear (A\<^sup>\<dagger>)\<close>
 proof
   include notation_norm
   have b1: \<open>\<langle>(A\<^sup>\<dagger>) x, y\<rangle> = \<langle>x , A y\<rangle>\<close> for x y
     using cadjoint_univ_prop a1 by auto
   have \<open>\<langle>(A\<^sup>\<dagger>) (x1 + x2) - ((A\<^sup>\<dagger>) x1 + (A\<^sup>\<dagger>) x2) , y\<rangle> = 0\<close> for x1 x2 y
     by (simp add: b1 cinner_diff_left cinner_add_left)
   hence b2: \<open>(A\<^sup>\<dagger>) (x1 + x2) - ((A\<^sup>\<dagger>) x1 + (A\<^sup>\<dagger>) x2) = 0\<close> for x1 x2
     using cinner_eq_zero_iff by blast
   thus z1: \<open>(A\<^sup>\<dagger>) (x1 + x2) = (A\<^sup>\<dagger>) x1 + (A\<^sup>\<dagger>) x2\<close> for x1 x2
     by (simp add: b2 eq_iff_diff_eq_0)
 
   have f1: \<open>\<langle>(A\<^sup>\<dagger>) (r *\<^sub>C x) - (r *\<^sub>C (A\<^sup>\<dagger>) x ), y\<rangle> = 0\<close> for r x y
     by (simp add: b1 cinner_diff_left)
   thus z2: \<open>(A\<^sup>\<dagger>) (r *\<^sub>C x) = r *\<^sub>C (A\<^sup>\<dagger>) x\<close> for r x
     using cinner_eq_zero_iff eq_iff_diff_eq_0 by blast
   have \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel>^2 = \<langle>(A\<^sup>\<dagger>) x, (A\<^sup>\<dagger>) x\<rangle>\<close> for x
     by (metis cnorm_eq_square)
   moreover have \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel>^2 \<ge> 0\<close> for x
     by simp
   ultimately have \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel>^2 = \<bar> \<langle>(A\<^sup>\<dagger>) x, (A\<^sup>\<dagger>) x\<rangle> \<bar>\<close> for x
     by (metis abs_pos cinner_ge_zero)
   hence \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel>^2 = \<bar> \<langle>x, A ((A\<^sup>\<dagger>) x)\<rangle> \<bar>\<close> for x
     by (simp add: b1)
   moreover have  \<open>\<bar>\<langle>x , A ((A\<^sup>\<dagger>) x)\<rangle>\<bar> \<le> \<parallel>x\<parallel> *  \<parallel>A ((A\<^sup>\<dagger>) x)\<parallel>\<close> for x
     by (simp add: abs_complex_def complex_inner_class.Cauchy_Schwarz_ineq2 less_eq_complex_def)
   ultimately have b5: \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel>^2  \<le> \<parallel>x\<parallel> * \<parallel>A ((A\<^sup>\<dagger>) x)\<parallel>\<close> for x
     by (metis complex_of_real_mono_iff)
   have \<open>\<exists>M. M \<ge> 0 \<and> (\<forall> x. \<parallel>A ((A\<^sup>\<dagger>) x)\<parallel> \<le> M *  \<parallel>(A\<^sup>\<dagger>) x\<parallel>)\<close>
     using a1
     by (metis (mono_tags, opaque_lifting) bounded_clinear.bounded linear mult_nonneg_nonpos
         mult_zero_right norm_ge_zero order.trans semiring_normalization_rules(7))
   then obtain M where q1: \<open>M \<ge> 0\<close> and q2: \<open>\<forall> x. \<parallel>A ((A\<^sup>\<dagger>) x)\<parallel> \<le> M * \<parallel>(A\<^sup>\<dagger>) x\<parallel>\<close>
     by blast
   have \<open>\<forall> x::'b. \<parallel>x\<parallel> \<ge> 0\<close>
     by simp
   hence b6: \<open>\<parallel>x\<parallel> * \<parallel>A ((A\<^sup>\<dagger>) x)\<parallel> \<le>  \<parallel>x\<parallel> * M * \<parallel>(A\<^sup>\<dagger>) x\<parallel>\<close> for x
     using q2
     by (smt ordered_comm_semiring_class.comm_mult_left_mono vector_space_over_itself.scale_scale)
   have z3: \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel> \<le> \<parallel>x\<parallel> * M\<close> for x
   proof(cases \<open>\<parallel>(A\<^sup>\<dagger>) x\<parallel> = 0\<close>)
     case True
     thus ?thesis
       by (simp add: \<open>0 \<le> M\<close>)
   next
     case False
     have \<open>\<parallel> (A\<^sup>\<dagger>) x \<parallel>^2 \<le> \<parallel>x\<parallel> *  M *  \<parallel>(A\<^sup>\<dagger>) x\<parallel>\<close>
       by (smt b5 b6)
     thus ?thesis
       by (smt False mult_right_cancel mult_right_mono norm_ge_zero semiring_normalization_rules(29))
   qed
   thus \<open>\<exists>K. \<forall>x. \<parallel>(A\<^sup>\<dagger>) x\<parallel> \<le> \<parallel>x\<parallel> * K\<close>
     by auto
 qed
 
 proposition double_cadjoint:
   fixes U :: \<open>'a::chilbert_space \<Rightarrow> 'b::complex_inner\<close>
   assumes a1: "bounded_clinear U"
   shows "U\<^sup>\<dagger>\<^sup>\<dagger> = U"
   by (metis assms cadjoint_def cadjoint_is_cadjoint is_adjoint_sym is_cadjoint_unique someI_ex)
 
 lemma cadjoint_id: \<open>(id::'a::complex_inner\<Rightarrow>'a)\<^sup>\<dagger> = id\<close>
   by (simp add: cadjoint_eqI id_def)
 
 lemma scaleC_cadjoint:
   fixes A::"'a::chilbert_space \<Rightarrow> 'b::complex_inner"
   assumes "bounded_clinear A"
   shows \<open>(\<lambda>t. a *\<^sub>C (A t))\<^sup>\<dagger> = (\<lambda>s. (cnj a) *\<^sub>C ((A\<^sup>\<dagger>) s))\<close>
 proof-
   have b3: \<open>\<langle>(\<lambda> s. (cnj a) *\<^sub>C ((A\<^sup>\<dagger>) s)) x, y \<rangle> = \<langle>x, (\<lambda> t. a *\<^sub>C (A t)) y \<rangle>\<close>
     for x y
     by (simp add: assms cadjoint_univ_prop)
 
   have "((\<lambda>t. a *\<^sub>C A t)\<^sup>\<dagger>) b = cnj a *\<^sub>C (A\<^sup>\<dagger>) b"
     for b::'b
   proof-
     have "bounded_clinear (\<lambda>t. a *\<^sub>C A t)"
       by (simp add: assms bounded_clinear_const_scaleC)
     thus ?thesis
       by (metis (no_types) cadjoint_eqI b3)
   qed
   thus ?thesis
     by blast
 qed
 
 
 lemma is_projection_on_is_cadjoint:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes a1: \<open>is_projection_on \<pi> M\<close> and a2: \<open>closed_csubspace M\<close>
   shows \<open>is_cadjoint \<pi> \<pi>\<close>
 proof -
   have \<open>cinner (x - \<pi> x) y = 0\<close> if \<open>y\<in>M\<close> for x y
     using a1 a2 is_projection_on_iff_orthog orthogonal_complement_orthoI that by blast
   then have \<open>cinner x y = cinner (\<pi> x) y\<close> if \<open>y\<in>M\<close> for x y
     by (metis cinner_diff_left eq_iff_diff_eq_0 that)
   moreover have \<open>cinner x y = cinner x (\<pi> y)\<close> if \<open>y\<in>M\<close> for x y
     using a1 is_projection_on_fixes_image that by fastforce
   ultimately have 1: \<open>cinner (\<pi> x) y = cinner x (\<pi> y)\<close> if \<open>y\<in>M\<close> for x y
     using that by metis
 
   have \<open>cinner (\<pi> x) y = 0\<close> if \<open>y \<in> orthogonal_complement M\<close> for x y
     by (meson a1 is_projection_on_in_image orthogonal_complement_orthoI' that)
   also have \<open>0 = cinner x (\<pi> y)\<close> if \<open>y \<in> orthogonal_complement M\<close> for x y
     by (metis a1 a2 cinner_zero_right closed_csubspace.subspace complex_vector.subspace_0 diff_zero is_projection_on_eqI that)
   finally have 2: \<open>cinner (\<pi> x) y = cinner x (\<pi> y)\<close> if \<open>y \<in> orthogonal_complement M\<close> for x y
     using that by simp
 
   from 1 2
   have \<open>cinner (\<pi> x) y = cinner x (\<pi> y)\<close> for x y
     by (smt (verit, ccfv_threshold) a1 a2 cinner_commute cinner_diff_left eq_iff_diff_eq_0 is_projection_on_iff_orthog orthogonal_complement_orthoI)
   then show ?thesis
     by (simp add: is_cadjoint_def)
 qed
 
 lemma is_projection_on_cadjoint:
   fixes M :: \<open>'a::complex_inner set\<close>
   assumes \<open>is_projection_on \<pi> M\<close> and \<open>closed_csubspace M\<close>
   shows \<open>\<pi>\<^sup>\<dagger> = \<pi>\<close>
   using assms is_projection_on_is_cadjoint cadjoint_eqI is_cadjoint_def by blast
 
 lemma projection_cadjoint:
   fixes M :: \<open>'a::chilbert_space set\<close>
   assumes \<open>closed_csubspace M\<close>
   shows \<open>(projection M)\<^sup>\<dagger> = projection M\<close>
   using is_projection_on_cadjoint assms
   by (metis closed_csubspace.closed closed_csubspace.subspace csubspace_is_convex empty_iff orthog_proj_exists projection_is_projection_on)
 
 instance ccsubspace :: (chilbert_space) complete_orthomodular_lattice
 proof
   show "inf x (- x) = bot"
     for x :: "'a ccsubspace"
     apply transfer
     by (simp add: closed_csubspace_def complex_vector.subspace_0 orthogonal_complement_zero_intersection)
 
   have \<open>t \<in> x +\<^sub>M orthogonal_complement x\<close>
     if a1: \<open>closed_csubspace x\<close>
     for t::'a and x
   proof-
     have e1: \<open>t = (projection x) t + (projection (orthogonal_complement x)) t\<close>
       by (simp add: that)
     have e2: \<open>(projection x) t \<in> x\<close>
       by (metis closed_csubspace.closed closed_csubspace.subspace csubspace_is_convex empty_iff orthog_proj_exists projection_in_image that)
     have e3: \<open>(projection (orthogonal_complement x)) t \<in> orthogonal_complement x\<close>
       by (metis add_diff_cancel_left' e1 orthogonal_complementI projection_orthogonal that)
     have "orthogonal_complement x \<subseteq> x +\<^sub>M orthogonal_complement x"
       by (simp add: closed_sum_right_subset complex_vector.subspace_0 that)
     thus ?thesis
       using \<open>closed_csubspace x\<close>
         \<open>projection (orthogonal_complement x) t \<in> orthogonal_complement x\<close> \<open>projection x t \<in> x\<close>
         \<open>t = projection x t + projection (orthogonal_complement x) t\<close> in_mono
         closed_sum_left_subset complex_vector.subspace_def
       by (metis closed_csubspace.subspace closed_subspace_closed_sum orthogonal_complement_closed_subspace)
   qed
   hence b1: \<open>x +\<^sub>M orthogonal_complement x = UNIV\<close>
     if a1: \<open>closed_csubspace x\<close>
     for x::\<open>'a set\<close>
     using that by blast
   show "sup x (- x) = top"
     for x :: "'a ccsubspace"
     apply transfer
     using b1 by auto
   show "- (- x) = x"
     for x :: "'a ccsubspace"
     apply transfer
     by (simp)
 
   show "- y \<le> - x"
     if "x \<le> y"
     for x :: "'a ccsubspace"
       and y :: "'a ccsubspace"
     using that apply transfer
     by simp
 
   have c1: "x +\<^sub>M orthogonal_complement x \<inter> y \<subseteq> y"
     if "closed_csubspace x"
       and "closed_csubspace y"
       and "x \<subseteq> y"
     for x :: "'a set"
       and y :: "'a set"
     using that
     by (simp add: closed_sum_is_sup)
 
   have c2: \<open>u \<in> x +\<^sub>M ((orthogonal_complement x) \<inter> y)\<close>
     if a1: "closed_csubspace x" and a2: "closed_csubspace y" and a3: "x \<subseteq> y" and x1: \<open>u \<in> y\<close>
     for x :: "'a set" and y :: "'a set"  and u
   proof-
     have d4: \<open>(projection x) u \<in> x\<close>
       by (metis a1 closed_csubspace_def csubspace_is_convex equals0D orthog_proj_exists projection_in_image)
     hence d2: \<open>(projection x) u \<in> y\<close>
       using a3 by auto
     have d1: \<open>csubspace y\<close>
       by (simp add: a2)
     have \<open>u - (projection x) u \<in> orthogonal_complement x\<close>
       by (simp add: a1 orthogonal_complementI projection_orthogonal)
     moreover have  \<open>u - (projection x) u \<in> y\<close>
       by (simp add: d1 d2 complex_vector.subspace_diff x1)
     ultimately have d3: \<open>u - (projection x) u \<in> ((orthogonal_complement x) \<inter> y)\<close>
       by simp
     hence \<open>\<exists> v \<in> ((orthogonal_complement x) \<inter> y). u = (projection x) u + v\<close>
       by (metis d3 diff_add_cancel ordered_field_class.sign_simps(2))
     then obtain v where \<open>v \<in> ((orthogonal_complement x) \<inter> y)\<close> and \<open>u = (projection x) u + v\<close>
       by blast
     hence \<open>u \<in> x + ((orthogonal_complement x) \<inter> y)\<close>
       by (metis d4 set_plus_intro)
     thus ?thesis
       unfolding closed_sum_def
       using closure_subset by blast
   qed
 
   have c3: "y \<subseteq> x +\<^sub>M ((orthogonal_complement x) \<inter> y)"
     if a1: "closed_csubspace x" and a2: "closed_csubspace y" and a3: "x \<subseteq> y"
     for x y :: "'a set"
     using c2 a1 a2 a3 by auto
 
   show "sup x (inf (- x) y) = y"
     if "x \<le> y"
     for x y :: "'a ccsubspace"
     using that apply transfer
     using c1 c3
     by (simp add: subset_antisym)
 
   show "x - y = inf x (- y)"
     for x y :: "'a ccsubspace"
     apply transfer
     by simp
 qed
 
 subsection \<open>More projections\<close>
 
 text \<open>These lemmas logically belong in the "projections" section above but depend on lemmas developed later.\<close>
 
 lemma is_projection_on_plus:
   assumes "\<And>x y. x:A \<Longrightarrow> y:B \<Longrightarrow> is_orthogonal x y"
   assumes \<open>closed_csubspace A\<close>
   assumes \<open>closed_csubspace B\<close>
   assumes \<open>is_projection_on \<pi>A A\<close>
   assumes \<open>is_projection_on \<pi>B B\<close>
   shows \<open>is_projection_on (\<lambda>x. \<pi>A x + \<pi>B x) (A +\<^sub>M B)\<close>
 proof (rule is_projection_on_iff_orthog[THEN iffD2, rule_format])
   show clAB: \<open>closed_csubspace (A +\<^sub>M B)\<close>
     by (simp add: assms(2) assms(3) closed_subspace_closed_sum)
   fix h
   have 1: \<open>\<pi>A h + \<pi>B h \<in> A +\<^sub>M B\<close>
     by (meson clAB assms(2) assms(3) assms(4) assms(5) closed_csubspace_def closed_sum_left_subset closed_sum_right_subset complex_vector.subspace_def in_mono is_projection_on_in_image)
 
   have \<open>\<pi>A (\<pi>B h) = 0\<close>
     by (smt (verit, del_insts) assms(1) assms(2) assms(4) assms(5) cinner_eq_zero_iff is_cadjoint_def is_projection_on_in_image is_projection_on_is_cadjoint)
   then have \<open>h - (\<pi>A h + \<pi>B h) = (h - \<pi>B h) - \<pi>A (h - \<pi>B h)\<close>
     by (smt (verit) add.right_neutral add_diff_cancel_left' assms(2) assms(4) closed_csubspace.subspace complex_vector.subspace_diff diff_add_eq_diff_diff_swap diff_diff_add is_projection_on_iff_orthog orthog_proj_unique orthogonal_complement_closed_subspace)
   also have \<open>\<dots> \<in> orthogonal_complement A\<close>
     using assms(2) assms(4) is_projection_on_iff_orthog by blast
   finally have orthoA: \<open>h - (\<pi>A h + \<pi>B h) \<in> orthogonal_complement A\<close>
     by -
 
   have \<open>\<pi>B (\<pi>A h) = 0\<close>
     by (smt (verit, del_insts) assms(1) assms(3) assms(4) assms(5) cinner_eq_zero_iff is_cadjoint_def is_projection_on_in_image is_projection_on_is_cadjoint)
   then have \<open>h - (\<pi>A h + \<pi>B h) = (h - \<pi>A h) - \<pi>B (h - \<pi>A h)\<close>
     by (smt (verit) add.right_neutral add_diff_cancel assms(3) assms(5) closed_csubspace.subspace complex_vector.subspace_diff diff_add_eq_diff_diff_swap diff_diff_add is_projection_on_iff_orthog orthog_proj_unique orthogonal_complement_closed_subspace)
   also have \<open>\<dots> \<in> orthogonal_complement B\<close>
     using assms(3) assms(5) is_projection_on_iff_orthog by blast
   finally have orthoB: \<open>h - (\<pi>A h + \<pi>B h) \<in> orthogonal_complement B\<close>
     by -
 
   from orthoA orthoB
   have 2: \<open>h - (\<pi>A h + \<pi>B h) \<in> orthogonal_complement (A +\<^sub>M B)\<close>
     by (metis IntI assms(2) assms(3) closed_csubspace_def complex_vector.subspace_def de_morgan_orthogonal_complement_plus)
 
   from 1 2 show \<open>h - (\<pi>A h + \<pi>B h) \<in> orthogonal_complement (A +\<^sub>M B) \<and> \<pi>A h + \<pi>B h \<in> A +\<^sub>M B\<close>
     by simp
 qed
 
 lemma projection_plus:
   fixes A B :: "'a::chilbert_space set"
   assumes "\<And>x y. x:A \<Longrightarrow> y:B \<Longrightarrow> is_orthogonal x y"
   assumes \<open>closed_csubspace A\<close>
   assumes \<open>closed_csubspace B\<close>
   shows \<open>projection (A +\<^sub>M B) = (\<lambda>x. projection A x + projection B x)\<close>
 proof -
   have \<open>is_projection_on (\<lambda>x. projection A x + projection B x) (A +\<^sub>M B)\<close>
     apply (rule is_projection_on_plus)
     using assms by auto
   then show ?thesis
     by (meson assms(2) assms(3) closed_csubspace.subspace closed_subspace_closed_sum csubspace_is_convex projection_eqI')
 qed
 
 lemma is_projection_on_insert:
   assumes ortho: "\<And>s. s \<in> S \<Longrightarrow> \<langle>a, s\<rangle> = 0"
   assumes \<open>is_projection_on \<pi> (closure (cspan S))\<close>
   assumes \<open>is_projection_on \<pi>a (cspan {a})\<close>
   shows "is_projection_on (\<lambda>x. \<pi>a x + \<pi> x) (closure (cspan (insert a S)))"
 proof -
   from ortho
   have \<open>x \<in> cspan {a} \<Longrightarrow> y \<in> closure (cspan S) \<Longrightarrow> is_orthogonal x y\<close> for x y
     using is_orthogonal_cspan is_orthogonal_closure is_orthogonal_sym
     by (smt (verit, ccfv_threshold) empty_iff insert_iff)
   then have \<open>is_projection_on (\<lambda>x. \<pi>a x + \<pi> x) (cspan {a} +\<^sub>M closure (cspan S))\<close>
     apply (rule is_projection_on_plus)
     using assms by (auto simp add: closed_csubspace.intro)
   also have \<open>\<dots> = closure (cspan (insert a S))\<close>
     using closed_sum_cspan[where X=\<open>{a}\<close>] by simp
   finally show ?thesis
     by -
 qed
 
 lemma projection_insert:
   fixes a :: \<open>'a::chilbert_space\<close>
   assumes a1: "\<And>s. s \<in> S \<Longrightarrow> \<langle>a, s\<rangle> = 0"
   shows "projection (closure (cspan (insert a S))) u
         = projection (cspan {a}) u + projection (closure (cspan S)) u"
   using is_projection_on_insert[where S=S, OF a1]
   by (metis (no_types, lifting) closed_closure closed_csubspace.intro closure_is_csubspace complex_vector.subspace_span csubspace_is_convex finite.intros(1) finite.intros(2) finite_cspan_closed_csubspace projection_eqI' projection_is_projection_on')
 
 lemma projection_insert_finite:
   assumes a1: "\<And>s. s \<in> S \<Longrightarrow> \<langle>a, s\<rangle> = 0" and a2: "finite (S::'a::chilbert_space set)"
   shows "projection (cspan (insert a S)) u
         = projection (cspan {a}) u + projection (cspan S) u"
   using projection_insert
   by (metis a1 a2 closure_finite_cspan finite.insertI)
 
 subsection \<open>Canonical basis (\<open>onb_enum\<close>)\<close>
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>is_ortho_set\<close>, SOME \<^typ>\<open>'a set \<Rightarrow> bool\<close>)\<close>
 
 class onb_enum = basis_enum + complex_inner +
   assumes is_orthonormal: "is_ortho_set (set canonical_basis)"
     and is_normal: "\<And>x. x \<in> (set canonical_basis) \<Longrightarrow> norm x = 1"
 
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>is_ortho_set\<close>, SOME \<^typ>\<open>'a::complex_inner set \<Rightarrow> bool\<close>)\<close>
 
 lemma cinner_canonical_basis:
   assumes \<open>i < length (canonical_basis :: 'a::onb_enum list)\<close>
   assumes \<open>j < length (canonical_basis :: 'a::onb_enum list)\<close>
   shows \<open>cinner (canonical_basis!i :: 'a) (canonical_basis!j) = (if i=j then 1 else 0)\<close>
   by (metis assms(1) assms(2) distinct_canonical_basis is_normal is_ortho_set_def is_orthonormal nth_eq_iff_index_eq nth_mem of_real_1 power2_norm_eq_cinner power_one)
 
 instance onb_enum \<subseteq> chilbert_space
 proof
   show "convergent X"
     if "Cauchy X"
     for X :: "nat \<Rightarrow> 'a"
   proof-
     have \<open>finite (set canonical_basis)\<close>
       by simp
     have \<open>Cauchy (\<lambda> n. \<langle> t, X n \<rangle>)\<close> for t
       by (simp add: bounded_clinear.Cauchy bounded_clinear_cinner_right that)
     hence \<open>convergent (\<lambda> n. \<langle> t, X n \<rangle>)\<close>
       for t
       by (simp add: Cauchy_convergent_iff)
     hence \<open>\<forall> t\<in>set canonical_basis. \<exists> L. (\<lambda> n. \<langle> t, X n \<rangle>) \<longlonglongrightarrow> L\<close>
       by (simp add: convergentD)
     hence \<open>\<exists> L. \<forall> t\<in>set canonical_basis. (\<lambda> n. \<langle> t, X n \<rangle>) \<longlonglongrightarrow> L t\<close>
       by metis
     then obtain L where \<open>\<And> t. t\<in>set canonical_basis \<Longrightarrow> (\<lambda> n. \<langle> t, X n \<rangle>) \<longlonglongrightarrow> L t\<close>
       by blast
     define l where \<open>l = (\<Sum>t\<in>set canonical_basis. L t *\<^sub>C t)\<close>
     have x1: \<open>X n = (\<Sum>t\<in>set canonical_basis. \<langle> t, X n \<rangle> *\<^sub>C t)\<close>
       for n
       using onb_expansion_finite[where T = "set canonical_basis" and x = "X n"]
         \<open>finite (set canonical_basis)\<close>
       by (smt is_generator_set is_normal is_orthonormal)
 
     have \<open>(\<lambda> n. \<langle> t, X n \<rangle> *\<^sub>C t) \<longlonglongrightarrow> L t *\<^sub>C t\<close>
       if r1: \<open>t\<in>set canonical_basis\<close>
       for t
     proof-
       have \<open>(\<lambda> n. \<langle> t, X n \<rangle>) \<longlonglongrightarrow> L t\<close>
         using r1  \<open>\<And> t. t\<in>set canonical_basis \<Longrightarrow> (\<lambda> n. \<langle> t, X n \<rangle>) \<longlonglongrightarrow> L t\<close>
         by blast
       define f where \<open>f x = x *\<^sub>C t\<close> for x
       have \<open>isCont f r\<close>
         for r
         unfolding f_def
         by (simp add: bounded_clinear_scaleC_left clinear_continuous_at)
       hence \<open>(\<lambda> n. f \<langle> t, X n \<rangle>) \<longlonglongrightarrow> f (L t)\<close>
         using \<open>(\<lambda>n. \<langle>t, X n\<rangle>) \<longlonglongrightarrow> L t\<close> isCont_tendsto_compose by blast
       hence \<open>(\<lambda> n. \<langle> t, X n \<rangle> *\<^sub>C t) \<longlonglongrightarrow> L t *\<^sub>C t\<close>
         unfolding f_def
         by simp
       thus ?thesis by blast
     qed
     hence \<open>(\<lambda> n. (\<Sum>t\<in>set canonical_basis. \<langle> t, X n \<rangle> *\<^sub>C t))
     \<longlonglongrightarrow>  (\<Sum>t\<in>set canonical_basis. L t *\<^sub>C t)\<close>
       using \<open>finite (set canonical_basis)\<close>
         tendsto_sum[where I = "set canonical_basis" and f = "\<lambda> t. \<lambda> n. \<langle>t, X n\<rangle> *\<^sub>C t"
           and a = "\<lambda> t. L t *\<^sub>C t"]
       by auto
     hence x2: \<open>(\<lambda> n. (\<Sum>t\<in>set canonical_basis. \<langle> t, X n \<rangle> *\<^sub>C t)) \<longlonglongrightarrow> l\<close>
       using l_def by blast
     have \<open>X \<longlonglongrightarrow> l\<close>
       using x1 x2 by simp
     thus ?thesis
       unfolding convergent_def by blast
   qed
 qed
 
 subsection \<open>Conjugate space\<close>
 
 instantiation conjugate_space :: (complex_inner) complex_inner begin
 lift_definition cinner_conjugate_space :: "'a conjugate_space \<Rightarrow> 'a conjugate_space \<Rightarrow> complex" is
   \<open>\<lambda>x y. cinner y x\<close>.
 instance
   apply (intro_classes; transfer)
        apply (simp_all add: )
     apply (simp add: cinner_add_right)
   using cinner_ge_zero norm_eq_sqrt_cinner by auto
 end
 
 subsection \<open>Misc (ctd.)\<close>
 
 
 lemma separating_dense_span: 
   assumes \<open>\<And>F G :: 'a::chilbert_space \<Rightarrow> 'b::{complex_normed_vector,not_singleton}. 
            bounded_clinear F \<Longrightarrow> bounded_clinear G \<Longrightarrow> (\<forall>x\<in>S. F x = G x) \<Longrightarrow> F = G\<close>
   shows \<open>closure (cspan S) = UNIV\<close>
 proof -
   have \<open>\<psi> = 0\<close> if \<open>\<psi> \<in> orthogonal_complement S\<close> for \<psi>
   proof -
     obtain \<phi> :: 'b where \<open>\<phi> \<noteq> 0\<close>
       by fastforce
     have \<open>(\<lambda>x. cinner \<psi> x *\<^sub>C \<phi>) = (\<lambda>_. 0)\<close> 
       apply (rule assms[rule_format])
       using orthogonal_complement_orthoI that
       by (auto simp add: bounded_clinear_cinner_right bounded_clinear_scaleC_const)
     then have \<open>cinner \<psi> \<psi> = 0\<close>
       by (meson \<open>\<phi> \<noteq> 0\<close> scaleC_eq_0_iff)
     then show \<open>\<psi> = 0\<close>
       by auto
   qed
   then have \<open>orthogonal_complement (orthogonal_complement S) = UNIV\<close>
     by (metis UNIV_eq_I cinner_zero_right orthogonal_complementI)
   then show \<open>closure (cspan S) = UNIV\<close>
     by (simp add: orthogonal_complement_orthogonal_complement_closure_cspan)
 qed
 
 
 instance conjugate_space :: (chilbert_space) chilbert_space..
 
 end
diff --git a/thys/Complex_Bounded_Operators/Complex_L2.thy b/thys/Complex_Bounded_Operators/Complex_L2.thy
--- a/thys/Complex_Bounded_Operators/Complex_L2.thy
+++ b/thys/Complex_Bounded_Operators/Complex_L2.thy
@@ -1,1518 +1,1563 @@
 section \<open>\<open>Complex_L2\<close> -- Hilbert space of square-summable functions\<close>
 
 (*
 Authors:
 
   Dominique Unruh, University of Tartu, unruh@ut.ee
   Jose Manuel Rodriguez Caballero, University of Tartu, jose.manuel.rodriguez.caballero@ut.ee
 
 *)
 
 theory Complex_L2
   imports 
     Complex_Bounded_Linear_Function
 
     "HOL-Analysis.L2_Norm"
     "HOL-Library.Rewrite"
     "HOL-Analysis.Infinite_Sum"
 begin
 
 unbundle lattice_syntax
 unbundle cblinfun_notation
 unbundle no_notation_blinfun_apply
 
 subsection \<open>l2 norm of functions\<close>
 
 definition "has_ell2_norm (x::_\<Rightarrow>complex) \<longleftrightarrow> (\<lambda>i. (x i)\<^sup>2) abs_summable_on UNIV"
 
 lemma has_ell2_norm_bdd_above: \<open>has_ell2_norm x \<longleftrightarrow> bdd_above (sum (\<lambda>xa. norm ((x xa)\<^sup>2)) ` Collect finite)\<close>
   by (simp add: has_ell2_norm_def abs_summable_iff_bdd_above)
 
 lemma has_ell2_norm_L2_set: "has_ell2_norm x = bdd_above (L2_set (norm o x) ` Collect finite)"
 proof (rule iffI)
   have \<open>mono sqrt\<close>
     using monoI real_sqrt_le_mono by blast
   assume \<open>has_ell2_norm x\<close>
   then have *: \<open>bdd_above (sum (\<lambda>xa. norm ((x xa)\<^sup>2)) ` Collect finite)\<close>
     by (subst (asm) has_ell2_norm_bdd_above)
   have \<open>bdd_above ((\<lambda>F. sqrt (sum (\<lambda>xa. norm ((x xa)\<^sup>2)) F)) ` Collect finite)\<close>
     using bdd_above_image_mono[OF \<open>mono sqrt\<close> *]
     by (auto simp: image_image)
   then show \<open>bdd_above (L2_set (norm o x) ` Collect finite)\<close>
     by (auto simp: L2_set_def norm_power)
 next
   define p2 where \<open>p2 x = (if x < 0 then 0 else x^2)\<close> for x :: real
   have \<open>mono p2\<close>
     by (simp add: monoI p2_def)
   have [simp]: \<open>p2 (L2_set f F) = (\<Sum>i\<in>F. (f i)\<^sup>2)\<close> for f and F :: \<open>'a set\<close>
     by (smt (verit) L2_set_def L2_set_nonneg p2_def power2_less_0 real_sqrt_pow2 sum.cong sum_nonneg)
   assume *: \<open>bdd_above (L2_set (norm o x) ` Collect finite)\<close>
   have \<open>bdd_above (p2 ` L2_set (norm o x) ` Collect finite)\<close>
     using bdd_above_image_mono[OF \<open>mono p2\<close> *]
     by auto
   then show \<open>has_ell2_norm x\<close>
     apply (simp add: image_image has_ell2_norm_def abs_summable_iff_bdd_above)
     by (simp add: norm_power)
 qed
 
 definition ell2_norm :: \<open>('a \<Rightarrow> complex) \<Rightarrow> real\<close> where \<open>ell2_norm x = sqrt (\<Sum>\<^sub>\<infinity>i. norm (x i)^2)\<close>
 
 lemma ell2_norm_SUP:
   assumes \<open>has_ell2_norm x\<close>
   shows "ell2_norm x = sqrt (SUP F\<in>{F. finite F}. sum (\<lambda>i. norm (x i)^2) F)"
   using assms apply (auto simp add: ell2_norm_def has_ell2_norm_def)
   apply (subst infsum_nonneg_is_SUPREMUM_real)
   by (auto simp: norm_power)
 
 lemma ell2_norm_L2_set: 
   assumes "has_ell2_norm x"
   shows "ell2_norm x = (SUP F\<in>{F. finite F}. L2_set (norm o x) F)"
 proof-
   have "sqrt (\<Squnion> (sum (\<lambda>i. (cmod (x i))\<^sup>2) ` Collect finite)) =
       (SUP F\<in>{F. finite F}. sqrt (\<Sum>i\<in>F. (cmod (x i))\<^sup>2))"
   proof (subst continuous_at_Sup_mono)
     show "mono sqrt"
       by (simp add: mono_def)      
     show "continuous (at_left (\<Squnion> (sum (\<lambda>i. (cmod (x i))\<^sup>2) ` Collect finite))) sqrt"
       using continuous_at_split isCont_real_sqrt by blast    
     show "sum (\<lambda>i. (cmod (x i))\<^sup>2) ` Collect finite \<noteq> {}"
       by auto      
     show "bdd_above (sum (\<lambda>i. (cmod (x i))\<^sup>2) ` Collect finite)"
       using has_ell2_norm_bdd_above[THEN iffD1, OF assms] by (auto simp: norm_power)
     show "\<Squnion> (sqrt ` sum (\<lambda>i. (cmod (x i))\<^sup>2) ` Collect finite) = (SUP F\<in>Collect finite. sqrt (\<Sum>i\<in>F. (cmod (x i))\<^sup>2))"
       by (metis image_image)      
   qed  
   thus ?thesis 
     using assms by (auto simp: ell2_norm_SUP L2_set_def)
 qed
 
 lemma has_ell2_norm_finite[simp]: "has_ell2_norm (x::'a::finite\<Rightarrow>_)"
   unfolding has_ell2_norm_def by simp
 
 lemma ell2_norm_finite: 
   "ell2_norm (x::'a::finite\<Rightarrow>complex) = sqrt (sum (\<lambda>i. (norm(x i))^2) UNIV)"
   by (simp add: ell2_norm_def)
 
 lemma ell2_norm_finite_L2_set: "ell2_norm (x::'a::finite\<Rightarrow>complex) = L2_set (norm o x) UNIV"
   by (simp add: ell2_norm_finite L2_set_def)
 
 lemma ell2_norm_square: \<open>(ell2_norm x)\<^sup>2 = (\<Sum>\<^sub>\<infinity>i. (cmod (x i))\<^sup>2)\<close>
   unfolding ell2_norm_def
   apply (subst real_sqrt_pow2)
   by (simp_all add: infsum_nonneg)
 
 lemma ell2_ket:
   fixes a
   defines \<open>f \<equiv> (\<lambda>i. if a = i then 1 else 0)\<close>
   shows has_ell2_norm_ket: \<open>has_ell2_norm f\<close>
     and ell2_norm_ket: \<open>ell2_norm f = 1\<close>
 proof -
   have \<open>(\<lambda>x. (f x)\<^sup>2) abs_summable_on {a}\<close>
     apply (rule summable_on_finite) by simp
   then show \<open>has_ell2_norm f\<close>
     unfolding has_ell2_norm_def
     apply (rule summable_on_cong_neutral[THEN iffD1, rotated -1])
     unfolding f_def by auto
 
   have \<open>(\<Sum>\<^sub>\<infinity>x\<in>{a}. (f x)\<^sup>2) = 1\<close>
     apply (subst infsum_finite)
     by (auto simp: f_def)
   then show \<open>ell2_norm f = 1\<close>
     unfolding ell2_norm_def
     apply (subst infsum_cong_neutral[where T=\<open>{a}\<close> and g=\<open>\<lambda>x. (cmod (f x))\<^sup>2\<close>])
     by (auto simp: f_def)
 qed
 
 lemma ell2_norm_geq0: \<open>ell2_norm x \<ge> 0\<close>
   by (auto simp: ell2_norm_def intro!: infsum_nonneg)
 
 lemma ell2_norm_point_bound:
   assumes \<open>has_ell2_norm x\<close>
   shows \<open>ell2_norm x \<ge> cmod (x i)\<close>
 proof -
   have \<open>(cmod (x i))\<^sup>2 = norm ((x i)\<^sup>2)\<close>
     by (simp add: norm_power)
   also have \<open>norm ((x i)\<^sup>2) = sum (\<lambda>i. (norm ((x i)\<^sup>2))) {i}\<close>
     by auto
   also have \<open>\<dots> = infsum (\<lambda>i. (norm ((x i)\<^sup>2))) {i}\<close>
     by (rule infsum_finite[symmetric], simp)
   also have \<open>\<dots> \<le> infsum (\<lambda>i. (norm ((x i)\<^sup>2))) UNIV\<close>
     apply (rule infsum_mono_neutral)
     using assms by (auto simp: has_ell2_norm_def)
   also have \<open>\<dots> = (ell2_norm x)\<^sup>2\<close>
     by (metis (no_types, lifting) ell2_norm_def ell2_norm_geq0 infsum_cong norm_power real_sqrt_eq_iff real_sqrt_unique)
   finally show ?thesis
     using ell2_norm_geq0 power2_le_imp_le by blast
 qed
 
 lemma ell2_norm_0:
   assumes "has_ell2_norm x"
   shows "(ell2_norm x = 0) = (x = (\<lambda>_. 0))"
 proof
   assume u1: "x = (\<lambda>_. 0)"
   have u2: "(SUP x::'a set\<in>Collect finite. (0::real)) = 0"
     if "x = (\<lambda>_. 0)"
     by (metis cSUP_const empty_Collect_eq finite.emptyI)
   show "ell2_norm x = 0"
     unfolding ell2_norm_def
     using u1 u2 by auto 
 next
   assume norm0: "ell2_norm x = 0"
   show "x = (\<lambda>_. 0)"
   proof
     fix i
     have \<open>cmod (x i) \<le> ell2_norm x\<close>
       using assms by (rule ell2_norm_point_bound)
     also have \<open>\<dots> = 0\<close>
       by (fact norm0)
     finally show "x i = 0" by auto
   qed
 qed
 
 
 lemma ell2_norm_smult:
   assumes "has_ell2_norm x"
   shows "has_ell2_norm (\<lambda>i. c * x i)" and "ell2_norm (\<lambda>i. c * x i) = cmod c * ell2_norm x"
 proof -
   have L2_set_mul: "L2_set (cmod \<circ> (\<lambda>i. c * x i)) F = cmod c * L2_set (cmod \<circ> x) F" for F
   proof-
     have "L2_set (cmod \<circ> (\<lambda>i. c * x i)) F = L2_set (\<lambda>i. (cmod c * (cmod o x) i)) F"
       by (metis comp_def norm_mult)
     also have "\<dots> = cmod c * L2_set (cmod o x) F"
       by (metis norm_ge_zero L2_set_right_distrib)
     finally show ?thesis .
   qed
 
   from assms obtain M where M: "M \<ge> L2_set (cmod o x) F" if "finite F" for F
     unfolding has_ell2_norm_L2_set bdd_above_def by auto
   hence "cmod c * M \<ge> L2_set (cmod o (\<lambda>i. c * x i)) F" if "finite F" for F
     unfolding L2_set_mul
     by (simp add: ordered_comm_semiring_class.comm_mult_left_mono that) 
   thus has: "has_ell2_norm (\<lambda>i. c * x i)"
     unfolding has_ell2_norm_L2_set bdd_above_def using L2_set_mul[symmetric] by auto
   have "ell2_norm (\<lambda>i. c * x i) = (SUP F \<in> Collect finite. (L2_set (cmod \<circ> (\<lambda>i. c * x i)) F))"
     by (simp add: ell2_norm_L2_set has)
   also have "\<dots> = (SUP F \<in> Collect finite. (cmod c * L2_set (cmod \<circ> x) F))"
     using L2_set_mul by auto   
   also have "\<dots> = cmod c * ell2_norm x" 
   proof (subst ell2_norm_L2_set)
     show "has_ell2_norm x"
       by (simp add: assms)      
     show "(SUP F\<in>Collect finite. cmod c * L2_set (cmod \<circ> x) F) = cmod c * \<Squnion> (L2_set (cmod \<circ> x) ` Collect finite)"
     proof (subst continuous_at_Sup_mono [where f = "\<lambda>x. cmod c * x"])
       show "mono ((*) (cmod c))"
         by (simp add: mono_def ordered_comm_semiring_class.comm_mult_left_mono)
       show "continuous (at_left (\<Squnion> (L2_set (cmod \<circ> x) ` Collect finite))) ((*) (cmod c))"
       proof (rule continuous_mult)
         show "continuous (at_left (\<Squnion> (L2_set (cmod \<circ> x) ` Collect finite))) (\<lambda>x. cmod c)"
           by simp
         show "continuous (at_left (\<Squnion> (L2_set (cmod \<circ> x) ` Collect finite))) (\<lambda>x. x)"
           by simp
       qed    
       show "L2_set (cmod \<circ> x) ` Collect finite \<noteq> {}"
         by auto        
       show "bdd_above (L2_set (cmod \<circ> x) ` Collect finite)"
         by (meson assms has_ell2_norm_L2_set)        
       show "(SUP F\<in>Collect finite. cmod c * L2_set (cmod \<circ> x) F) = \<Squnion> ((*) (cmod c) ` L2_set (cmod \<circ> x) ` Collect finite)"
         by (metis image_image)        
     qed   
   qed     
   finally show "ell2_norm (\<lambda>i. c * x i) = cmod c * ell2_norm x".
 qed
 
 
 lemma ell2_norm_triangle:
   assumes "has_ell2_norm x" and "has_ell2_norm y"
   shows "has_ell2_norm (\<lambda>i. x i + y i)" and "ell2_norm (\<lambda>i. x i + y i) \<le> ell2_norm x + ell2_norm y"
 proof -
   have triangle: "L2_set (cmod \<circ> (\<lambda>i. x i + y i)) F \<le> L2_set (cmod \<circ> x) F + L2_set (cmod \<circ> y) F" 
     (is "?lhs\<le>?rhs") 
     if "finite F" for F
   proof -
     have "?lhs \<le> L2_set (\<lambda>i. (cmod o x) i + (cmod o y) i) F"
     proof (rule L2_set_mono)
       show "(cmod \<circ> (\<lambda>i. x i + y i)) i \<le> (cmod \<circ> x) i + (cmod \<circ> y) i"
         if "i \<in> F"
         for i :: 'a
         using that norm_triangle_ineq by auto 
       show "0 \<le> (cmod \<circ> (\<lambda>i. x i + y i)) i"
         if "i \<in> F"
         for i :: 'a
         using that
         by simp 
     qed
     also have "\<dots> \<le> ?rhs"
       by (rule L2_set_triangle_ineq)
     finally show ?thesis .
   qed
   obtain Mx My where Mx: "Mx \<ge> L2_set (cmod o x) F" and My: "My \<ge> L2_set (cmod o y) F" 
     if "finite F" for F
     using assms unfolding has_ell2_norm_L2_set bdd_above_def by auto
   hence MxMy: "Mx + My \<ge> L2_set (cmod \<circ> x) F + L2_set (cmod \<circ> y) F" if "finite F" for F
     using that by fastforce
   hence bdd_plus: "bdd_above ((\<lambda>xa. L2_set (cmod \<circ> x) xa + L2_set (cmod \<circ> y) xa) ` Collect finite)"
     unfolding bdd_above_def by auto
   from MxMy have MxMy': "Mx + My \<ge> L2_set (cmod \<circ> (\<lambda>i. x i + y i)) F" if "finite F" for F 
     using triangle that by fastforce
   thus has: "has_ell2_norm (\<lambda>i. x i + y i)"
     unfolding has_ell2_norm_L2_set bdd_above_def by auto
   have SUP_plus: "(SUP x\<in>A. f x + g x) \<le> (SUP x\<in>A. f x) + (SUP x\<in>A. g x)" 
     if notempty: "A\<noteq>{}" and bddf: "bdd_above (f`A)"and bddg: "bdd_above (g`A)"
     for f g :: "'a set \<Rightarrow> real" and A
   proof-
     have xleq: "x \<le> (SUP x\<in>A. f x) + (SUP x\<in>A. g x)" if x: "x \<in> (\<lambda>x. f x + g x) ` A" for x
     proof -
       obtain a where aA: "a:A" and ax: "x = f a + g a"
         using x by blast
       have fa: "f a \<le> (SUP x\<in>A. f x)"
         by (simp add: bddf aA cSUP_upper)
       moreover have "g a \<le> (SUP x\<in>A. g x)"
         by (simp add: bddg aA cSUP_upper)
       ultimately have "f a + g a \<le> (SUP x\<in>A. f x) + (SUP x\<in>A. g x)" by simp
       with ax show ?thesis by simp
     qed
     have "(\<lambda>x. f x + g x) ` A \<noteq> {}"
       using notempty by auto        
     moreover have "x \<le> \<Squnion> (f ` A) + \<Squnion> (g ` A)"
       if "x \<in> (\<lambda>x. f x + g x) ` A"
       for x :: real
       using that
       by (simp add: xleq) 
     ultimately show ?thesis
       by (meson bdd_above_def cSup_le_iff)      
   qed
   have a2: "bdd_above (L2_set (cmod \<circ> x) ` Collect finite)"
     by (meson assms(1) has_ell2_norm_L2_set)    
   have a3: "bdd_above (L2_set (cmod \<circ> y) ` Collect finite)"
     by (meson assms(2) has_ell2_norm_L2_set)    
   have a1: "Collect finite \<noteq> {}"
     by auto    
   have a4: "\<Squnion> (L2_set (cmod \<circ> (\<lambda>i. x i + y i)) ` Collect finite)
     \<le> (SUP xa\<in>Collect finite.
            L2_set (cmod \<circ> x) xa + L2_set (cmod \<circ> y) xa)"
     by (metis (mono_tags, lifting) a1 bdd_plus cSUP_mono mem_Collect_eq triangle)    
   have "\<forall>r. \<Squnion> (L2_set (cmod \<circ> (\<lambda>a. x a + y a)) ` Collect finite) \<le> r \<or> \<not> (SUP A\<in>Collect finite. L2_set (cmod \<circ> x) A + L2_set (cmod \<circ> y) A) \<le> r"
     using a4 by linarith
   hence "\<Squnion> (L2_set (cmod \<circ> (\<lambda>i. x i + y i)) ` Collect finite)
     \<le> \<Squnion> (L2_set (cmod \<circ> x) ` Collect finite) +
        \<Squnion> (L2_set (cmod \<circ> y) ` Collect finite)"
     by (metis (no_types) SUP_plus a1 a2 a3)
   hence "\<Squnion> (L2_set (cmod \<circ> (\<lambda>i. x i + y i)) ` Collect finite) \<le> ell2_norm x + ell2_norm y"
     by (simp add: assms(1) assms(2) ell2_norm_L2_set)
   thus "ell2_norm (\<lambda>i. x i + y i) \<le> ell2_norm x + ell2_norm y"
     by (simp add: ell2_norm_L2_set has)  
 qed
 
 lemma ell2_norm_uminus:
   assumes "has_ell2_norm x"
   shows \<open>has_ell2_norm (\<lambda>i. - x i)\<close> and \<open>ell2_norm (\<lambda>i. - x i) = ell2_norm x\<close>
   using assms by (auto simp: has_ell2_norm_def ell2_norm_def)
 
 subsection \<open>The type \<open>ell2\<close> of square-summable functions\<close>
 
 typedef 'a ell2 = "{x::'a\<Rightarrow>complex. has_ell2_norm x}"
   unfolding has_ell2_norm_def by (rule exI[of _ "\<lambda>_.0"], auto)
 setup_lifting type_definition_ell2
 
 instantiation ell2 :: (type)complex_vector begin
 lift_definition zero_ell2 :: "'a ell2" is "\<lambda>_. 0" by (auto simp: has_ell2_norm_def)
 lift_definition uminus_ell2 :: "'a ell2 \<Rightarrow> 'a ell2" is uminus by (simp add: has_ell2_norm_def)
 lift_definition plus_ell2 :: "'a ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>f g x. f x + g x"
   by (rule ell2_norm_triangle) 
 lift_definition minus_ell2 :: "'a ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>f g x. f x - g x"
   apply (subst add_uminus_conv_diff[symmetric])
   apply (rule ell2_norm_triangle)
   by (auto simp add: ell2_norm_uminus)
 lift_definition scaleR_ell2 :: "real \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>r f x. complex_of_real r * f x"
   by (rule ell2_norm_smult)
 lift_definition scaleC_ell2 :: "complex \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>c f x. c * f x"
   by (rule ell2_norm_smult)
 
 instance
 proof
   fix a b c :: "'a ell2"
 
   show "((*\<^sub>R) r::'a ell2 \<Rightarrow> _) = (*\<^sub>C) (complex_of_real r)" for r
     apply (rule ext) apply transfer by auto
   show "a + b + c = a + (b + c)"
     by (transfer; rule ext; simp)
   show "a + b = b + a"
     by (transfer; rule ext; simp)
   show "0 + a = a"
     by (transfer; rule ext; simp)
   show "- a + a = 0"
     by (transfer; rule ext; simp)
   show "a - b = a + - b"
     by (transfer; rule ext; simp)
   show "r *\<^sub>C (a + b) = r *\<^sub>C a + r *\<^sub>C b" for r
     apply (transfer; rule ext)
     by (simp add: vector_space_over_itself.scale_right_distrib)
   show "(r + r') *\<^sub>C a = r *\<^sub>C a + r' *\<^sub>C a" for r r'
     apply (transfer; rule ext)
     by (simp add: ring_class.ring_distribs(2)) 
   show "r *\<^sub>C r' *\<^sub>C a = (r * r') *\<^sub>C a" for r r'
     by (transfer; rule ext; simp)
   show "1 *\<^sub>C a = a"
     by (transfer; rule ext; simp)
 qed
 end
 
 instantiation ell2 :: (type)complex_normed_vector begin
 lift_definition norm_ell2 :: "'a ell2 \<Rightarrow> real" is ell2_norm .
 declare norm_ell2_def[code del]
 definition "dist x y = norm (x - y)" for x y::"'a ell2"
 definition "sgn x = x /\<^sub>R norm x" for x::"'a ell2"
 definition [code del]: "uniformity = (INF e\<in>{0<..}. principal {(x::'a ell2, y). norm (x - y) < e})"
 definition [code del]: "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in INF e\<in>{0<..}. principal {(x, y). norm (x - y) < e}. x' = x \<longrightarrow> y \<in> U)" for U :: "'a ell2 set"
 instance
 proof
   fix a b :: "'a ell2"
   show "dist a b = norm (a - b)"
     by (simp add: dist_ell2_def)    
   show "sgn a = a /\<^sub>R norm a"
     by (simp add: sgn_ell2_def)    
   show "uniformity = (INF e\<in>{0<..}. principal {(x, y). dist (x::'a ell2) y < e})"
     unfolding dist_ell2_def  uniformity_ell2_def by simp
   show "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. (x'::'a ell2) = x \<longrightarrow> y \<in> U)" for U :: "'a ell2 set"
     unfolding uniformity_ell2_def open_ell2_def by simp_all        
   show "(norm a = 0) = (a = 0)"
     apply transfer by (fact ell2_norm_0)    
   show "norm (a + b) \<le> norm a + norm b"
     apply transfer by (fact ell2_norm_triangle)
   show "norm (r *\<^sub>R (a::'a ell2)) = \<bar>r\<bar> * norm a" for r
     and a :: "'a ell2"
     apply transfer
     by (simp add: ell2_norm_smult(2)) 
   show "norm (r *\<^sub>C a) = cmod r * norm a" for r
     apply transfer
     by (simp add: ell2_norm_smult(2)) 
 qed  
 end
 
 lemma norm_point_bound_ell2: "norm (Rep_ell2 x i) \<le> norm x"
   apply transfer
   by (simp add: ell2_norm_point_bound)
 
 lemma ell2_norm_finite_support:
   assumes \<open>finite S\<close> \<open>\<And> i. i \<notin> S \<Longrightarrow> Rep_ell2 x i = 0\<close>
   shows \<open>norm x = sqrt ((sum (\<lambda>i. (cmod (Rep_ell2 x i))\<^sup>2)) S)\<close>
 proof (insert assms(2), transfer fixing: S)
   fix x :: \<open>'a \<Rightarrow> complex\<close>
   assume zero: \<open>\<And>i. i \<notin> S \<Longrightarrow> x i = 0\<close>
   have \<open>ell2_norm x = sqrt (\<Sum>\<^sub>\<infinity>i. (cmod (x i))\<^sup>2)\<close>
     by (auto simp: ell2_norm_def)
   also have \<open>\<dots> = sqrt (\<Sum>\<^sub>\<infinity>i\<in>S. (cmod (x i))\<^sup>2)\<close>
     apply (subst infsum_cong_neutral[where g=\<open>\<lambda>i. (cmod (x i))\<^sup>2\<close> and S=UNIV and T=S])
     using zero by auto
   also have \<open>\<dots> = sqrt (\<Sum>i\<in>S. (cmod (x i))\<^sup>2)\<close>
     using \<open>finite S\<close> by simp
   finally show \<open>ell2_norm x = sqrt (\<Sum>i\<in>S. (cmod (x i))\<^sup>2)\<close>
     by -
 qed
 
 instantiation ell2 :: (type) complex_inner begin
 lift_definition cinner_ell2 :: "'a ell2 \<Rightarrow> 'a ell2 \<Rightarrow> complex" is 
   "\<lambda>x y. infsum (\<lambda>i. (cnj (x i) * y i)) UNIV" .
 declare cinner_ell2_def[code del]
 
 instance
 proof standard
   fix x y z :: "'a ell2" fix c :: complex
   show "cinner x y = cnj (cinner y x)"
   proof transfer
     fix x y :: "'a\<Rightarrow>complex" assume "has_ell2_norm x" and "has_ell2_norm y"
     have "(\<Sum>\<^sub>\<infinity>i. cnj (x i) * y i) = (\<Sum>\<^sub>\<infinity>i. cnj (cnj (y i) * x i))"
       by (metis complex_cnj_cnj complex_cnj_mult mult.commute)
     also have "\<dots> = cnj (\<Sum>\<^sub>\<infinity>i. cnj (y i) * x i)"
       by (metis infsum_cnj) 
     finally show "(\<Sum>\<^sub>\<infinity>i. cnj (x i) * y i) = cnj (\<Sum>\<^sub>\<infinity>i. cnj (y i) * x i)" .
   qed
 
   show "cinner (x + y) z = cinner x z + cinner y z"
   proof transfer
     fix x y z :: "'a \<Rightarrow> complex"
     assume "has_ell2_norm x"
     hence cnj_x: "(\<lambda>i. cnj (x i) * cnj (x i)) abs_summable_on UNIV"
       by (simp del: complex_cnj_mult add: norm_mult[symmetric] complex_cnj_mult[symmetric] has_ell2_norm_def power2_eq_square)
     assume "has_ell2_norm y"
     hence cnj_y: "(\<lambda>i. cnj (y i) * cnj (y i)) abs_summable_on UNIV"
       by (simp del: complex_cnj_mult add: norm_mult[symmetric] complex_cnj_mult[symmetric] has_ell2_norm_def power2_eq_square)
     assume "has_ell2_norm z"
     hence z: "(\<lambda>i. z i * z i) abs_summable_on UNIV" 
       by (simp add: norm_mult[symmetric] has_ell2_norm_def power2_eq_square)
     have cnj_x_z:"(\<lambda>i. cnj (x i) * z i) abs_summable_on UNIV"
       using cnj_x z by (rule abs_summable_product) 
     have cnj_y_z:"(\<lambda>i. cnj (y i) * z i) abs_summable_on UNIV"
       using cnj_y z by (rule abs_summable_product) 
     show "(\<Sum>\<^sub>\<infinity>i. cnj (x i + y i) * z i) = (\<Sum>\<^sub>\<infinity>i. cnj (x i) * z i) + (\<Sum>\<^sub>\<infinity>i. cnj (y i) * z i)"
       apply (subst infsum_add [symmetric])
       using cnj_x_z cnj_y_z 
       by (auto simp add: summable_on_iff_abs_summable_on_complex distrib_left mult.commute)
   qed
 
   show "cinner (c *\<^sub>C x) y = cnj c * cinner x y"
   proof transfer
     fix x y :: "'a \<Rightarrow> complex" and c :: complex
     assume "has_ell2_norm x"
     hence cnj_x: "(\<lambda>i. cnj (x i) * cnj (x i)) abs_summable_on UNIV"
       by (simp del: complex_cnj_mult add: norm_mult[symmetric] complex_cnj_mult[symmetric] has_ell2_norm_def power2_eq_square)
     assume "has_ell2_norm y"
     hence y: "(\<lambda>i. y i * y i) abs_summable_on UNIV" 
       by (simp add: norm_mult[symmetric] has_ell2_norm_def power2_eq_square)
     have cnj_x_y:"(\<lambda>i. cnj (x i) * y i) abs_summable_on UNIV"
       using cnj_x y by (rule abs_summable_product) 
     thus "(\<Sum>\<^sub>\<infinity>i. cnj (c * x i) * y i) = cnj c * (\<Sum>\<^sub>\<infinity>i. cnj (x i) * y i)"
       by (auto simp flip: infsum_cmult_right simp add: abs_summable_summable mult.commute vector_space_over_itself.scale_left_commute)
   qed
 
   show "0 \<le> cinner x x"
   proof transfer
     fix x :: "'a \<Rightarrow> complex"
     assume "has_ell2_norm x"
     hence "(\<lambda>i. cmod (cnj (x i) * x i)) abs_summable_on UNIV"
       by (simp add: norm_mult has_ell2_norm_def power2_eq_square)
     hence "(\<lambda>i. cnj (x i) * x i) abs_summable_on UNIV"
       by auto
     hence sum: "(\<lambda>i. cnj (x i) * x i) abs_summable_on UNIV"
       unfolding has_ell2_norm_def power2_eq_square.
     have "0 = (\<Sum>\<^sub>\<infinity>i::'a. 0)" by auto
     also have "\<dots> \<le> (\<Sum>\<^sub>\<infinity>i. cnj (x i) * x i)"
       apply (rule infsum_mono_complex)
       by (auto simp add: abs_summable_summable sum)
     finally show "0 \<le> (\<Sum>\<^sub>\<infinity>i. cnj (x i) * x i)" by assumption
   qed
 
   show "(cinner x x = 0) = (x = 0)"
   proof (transfer, auto)
     fix x :: "'a \<Rightarrow> complex"
     assume "has_ell2_norm x"
     hence "(\<lambda>i::'a. cmod (cnj (x i) * x i)) abs_summable_on UNIV"
       by (smt (verit, del_insts) complex_mod_mult_cnj has_ell2_norm_def mult.commute norm_ge_zero norm_power real_norm_def summable_on_cong)
     hence cmod_x2: "(\<lambda>i. cnj (x i) * x i) abs_summable_on UNIV"
       unfolding has_ell2_norm_def power2_eq_square
       by simp
     assume eq0: "(\<Sum>\<^sub>\<infinity>i. cnj (x i) * x i) = 0"
     show "x = (\<lambda>_. 0)"
     proof (rule ccontr)
       assume "x \<noteq> (\<lambda>_. 0)"
       then obtain i where "x i \<noteq> 0" by auto
       hence "0 < cnj (x i) * x i"
         by (metis le_less cnj_x_x_geq0 complex_cnj_zero_iff vector_space_over_itself.scale_eq_0_iff)
       also have "\<dots> = (\<Sum>\<^sub>\<infinity>i\<in>{i}. cnj (x i) * x i)" by auto
       also have "\<dots> \<le> (\<Sum>\<^sub>\<infinity>i. cnj (x i) * x i)"
         apply (rule infsum_mono_neutral_complex)
         by (auto simp add: abs_summable_summable cmod_x2)
       also from eq0 have "\<dots> = 0" by assumption
       finally show False by simp
     qed
   qed
 
   show "norm x = sqrt (cmod (cinner x x))"
   proof transfer 
     fix x :: "'a \<Rightarrow> complex" 
     assume x: "has_ell2_norm x"
     have "(\<lambda>i::'a. cmod (x i) * cmod (x i)) abs_summable_on UNIV \<Longrightarrow>
     (\<lambda>i::'a. cmod (cnj (x i) * x i)) abs_summable_on UNIV"
       by (simp add: norm_mult has_ell2_norm_def power2_eq_square)
     hence sum: "(\<lambda>i. cnj (x i) * x i) abs_summable_on UNIV"
       by (metis (no_types, lifting) complex_mod_mult_cnj has_ell2_norm_def mult.commute norm_power summable_on_cong x)
     from x have "ell2_norm x = sqrt (\<Sum>\<^sub>\<infinity>i. (cmod (x i))\<^sup>2)"
       unfolding ell2_norm_def by simp
     also have "\<dots> = sqrt (\<Sum>\<^sub>\<infinity>i. cmod (cnj (x i) * x i))"
       unfolding norm_complex_def power2_eq_square by auto
     also have "\<dots> = sqrt (cmod (\<Sum>\<^sub>\<infinity>i. cnj (x i) * x i))"
       by (auto simp: infsum_cmod abs_summable_summable sum)
     finally show "ell2_norm x = sqrt (cmod (\<Sum>\<^sub>\<infinity>i. cnj (x i) * x i))" by assumption
   qed
 qed
 end
 
 instance ell2 :: (type) chilbert_space
 proof
   fix X :: \<open>nat \<Rightarrow> 'a ell2\<close>
   define x where \<open>x n a = Rep_ell2 (X n) a\<close> for n a
   have [simp]: \<open>has_ell2_norm (x n)\<close> for n
     using Rep_ell2 x_def[abs_def] by simp
 
   assume \<open>Cauchy X\<close>
   moreover have "dist (x n a) (x m a) \<le> dist (X n) (X m)" for n m a
     by (metis Rep_ell2 x_def dist_norm ell2_norm_point_bound mem_Collect_eq minus_ell2.rep_eq norm_ell2.rep_eq)
   ultimately have \<open>Cauchy (\<lambda>n. x n a)\<close> for a
     by (meson Cauchy_def le_less_trans)
   then obtain l where x_lim: \<open>(\<lambda>n. x n a) \<longlonglongrightarrow> l a\<close> for a
     apply atomize_elim apply (rule choice)
     by (simp add: convergent_eq_Cauchy)
   define L where \<open>L = Abs_ell2 l\<close>
   define normF where \<open>normF F x = L2_set (cmod \<circ> x) F\<close> for F :: \<open>'a set\<close> and x
   have normF_triangle: \<open>normF F (\<lambda>a. x a + y a) \<le> normF F x + normF F y\<close> if \<open>finite F\<close> for F x y
   proof -
     have \<open>normF F (\<lambda>a. x a + y a) = L2_set (\<lambda>a. cmod (x a + y a)) F\<close>
       by (metis (mono_tags, lifting) L2_set_cong comp_apply normF_def)
     also have \<open>\<dots> \<le> L2_set (\<lambda>a. cmod (x a) + cmod (y a)) F\<close>
       by (meson L2_set_mono norm_ge_zero norm_triangle_ineq)
     also have \<open>\<dots> \<le> L2_set (\<lambda>a. cmod (x a)) F + L2_set (\<lambda>a. cmod (y a)) F\<close>
       by (simp add: L2_set_triangle_ineq)
     also have \<open>\<dots> \<le> normF F x + normF F y\<close>
       by (smt (verit, best) L2_set_cong normF_def comp_apply)
     finally show ?thesis
       by -
   qed
   have normF_negate: \<open>normF F (\<lambda>a. - x a) = normF F x\<close> if \<open>finite F\<close> for F x
     unfolding normF_def o_def by simp
   have normF_ell2norm: \<open>normF F x \<le> ell2_norm x\<close> if \<open>finite F\<close> and \<open>has_ell2_norm x\<close> for F x
     apply (auto intro!: cSUP_upper2[where x=F] simp: that normF_def ell2_norm_L2_set)
     by (meson has_ell2_norm_L2_set that(2))
 
   note Lim_bounded2[rotated, rule_format, trans]
 
   from \<open>Cauchy X\<close>
   obtain I where cauchyX: \<open>norm (X n - X m) \<le> \<epsilon>\<close> if \<open>\<epsilon>>0\<close> \<open>n\<ge>I \<epsilon>\<close> \<open>m\<ge>I \<epsilon>\<close> for \<epsilon> n m
     by (metis Cauchy_def dist_norm less_eq_real_def)
   have normF_xx: \<open>normF F (\<lambda>a. x n a - x m a) \<le> \<epsilon>\<close> if \<open>finite F\<close> \<open>\<epsilon>>0\<close> \<open>n\<ge>I \<epsilon>\<close> \<open>m\<ge>I \<epsilon>\<close> for \<epsilon> n m F
     apply (subst asm_rl[of \<open>(\<lambda>a. x n a - x m a) = Rep_ell2 (X n - X m)\<close>])
      apply (simp add: x_def minus_ell2.rep_eq)
     using that cauchyX by (metis Rep_ell2 mem_Collect_eq normF_ell2norm norm_ell2.rep_eq order_trans)
   have normF_xl_lim: \<open>(\<lambda>m. normF F (\<lambda>a. x m a - l a)) \<longlonglongrightarrow> 0\<close> if \<open>finite F\<close> for F
   proof -
     have \<open>(\<lambda>xa. cmod (x xa m - l m)) \<longlonglongrightarrow> 0\<close> for m
       using x_lim by (simp add: LIM_zero_iff tendsto_norm_zero)
     then have \<open>(\<lambda>m. \<Sum>i\<in>F. ((cmod \<circ> (\<lambda>a. x m a - l a)) i)\<^sup>2) \<longlonglongrightarrow> 0\<close>
       by (auto intro: tendsto_null_sum)
     then show ?thesis
       unfolding normF_def L2_set_def
       using tendsto_real_sqrt by force
   qed
   have normF_xl: \<open>normF F (\<lambda>a. x n a - l a) \<le> \<epsilon>\<close>
     if \<open>n \<ge> I \<epsilon>\<close> and \<open>\<epsilon> > 0\<close> and \<open>finite F\<close> for n \<epsilon> F
   proof -
     have \<open>normF F (\<lambda>a. x n a - l a) - \<epsilon> \<le> normF F (\<lambda>a. x n a - x m a) + normF F (\<lambda>a. x m a - l a) - \<epsilon>\<close> for m
       using normF_triangle[OF \<open>finite F\<close>, where x=\<open>(\<lambda>a. x n a - x m a)\<close> and y=\<open>(\<lambda>a. x m a - l a)\<close>]
       by auto
     also have \<open>\<dots> m \<le> normF F (\<lambda>a. x m a - l a)\<close> if \<open>m \<ge> I \<epsilon>\<close> for m
       using normF_xx[OF \<open>finite F\<close> \<open>\<epsilon>>0\<close> \<open>n \<ge> I \<epsilon>\<close> \<open>m \<ge> I \<epsilon>\<close>]
       by auto
     also have \<open>(\<lambda>m. \<dots> m) \<longlonglongrightarrow> 0\<close>
       using \<open>finite F\<close> by (rule normF_xl_lim)
     finally show ?thesis
       by auto
   qed
   have \<open>normF F l \<le> 1 + normF F (x (I 1))\<close> if [simp]: \<open>finite F\<close> for F
     using normF_xl[where F=F and \<epsilon>=1 and n=\<open>I 1\<close>]
     using normF_triangle[where F=F and x=\<open>x (I 1)\<close> and y=\<open>\<lambda>a. l a - x (I 1) a\<close>]
     using normF_negate[where F=F and x=\<open>(\<lambda>a. x (I 1) a - l a)\<close>]
     by auto
   also have \<open>\<dots> F \<le> 1 + ell2_norm (x (I 1))\<close> if \<open>finite F\<close> for F
     using normF_ell2norm that by simp
   finally have [simp]: \<open>has_ell2_norm l\<close>
     unfolding has_ell2_norm_L2_set
     by (auto intro!: bdd_aboveI simp flip: normF_def)
   then have \<open>l = Rep_ell2 L\<close>
     by (simp add: Abs_ell2_inverse L_def)
   have [simp]: \<open>has_ell2_norm (\<lambda>a. x n a - l a)\<close> for n
     apply (subst diff_conv_add_uminus)
     apply (rule ell2_norm_triangle)
     by (auto intro!: ell2_norm_uminus)
   from normF_xl have ell2norm_xl: \<open>ell2_norm (\<lambda>a. x n a - l a) \<le> \<epsilon>\<close>
     if \<open>n \<ge> I \<epsilon>\<close> and \<open>\<epsilon> > 0\<close> for n \<epsilon>
     apply (subst ell2_norm_L2_set)
     using that by (auto intro!: cSUP_least simp: normF_def)
   have \<open>norm (X n - L) \<le> \<epsilon>\<close> if \<open>n \<ge> I \<epsilon>\<close> and \<open>\<epsilon> > 0\<close> for n \<epsilon>
     using ell2norm_xl[OF that]
     by (simp add: x_def norm_ell2.rep_eq \<open>l = Rep_ell2 L\<close> minus_ell2.rep_eq)
   then have \<open>X \<longlonglongrightarrow> L\<close>
     unfolding tendsto_iff
     apply (auto simp: dist_norm eventually_sequentially)
     by (meson field_lbound_gt_zero le_less_trans)
   then show \<open>convergent X\<close>
     by (rule convergentI)
 qed
 
 instantiation ell2 :: (CARD_1) complex_algebra_1 
 begin
 lift_definition one_ell2 :: "'a ell2" is "\<lambda>_. 1" by simp
 lift_definition times_ell2 :: "'a ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>a b x. a x * b x"
   by simp   
 instance 
 proof
   fix a b c :: "'a ell2" and r :: complex
   show "a * b * c = a * (b * c)"
     by (transfer, auto)
   show "(a + b) * c = a * c + b * c"
     apply (transfer, rule ext)
     by (simp add: distrib_left mult.commute)
   show "a * (b + c) = a * b + a * c"
     apply transfer
     by (simp add: ring_class.ring_distribs(1))
   show "r *\<^sub>C a * b = r *\<^sub>C (a * b)"
     by (transfer, auto)
   show "(a::'a ell2) * r *\<^sub>C b = r *\<^sub>C (a * b)"
     by (transfer, auto)
   show "1 * a = a"
     by (transfer, rule ext, auto)
   show "a * 1 = a"
     by (transfer, rule ext, auto)
   show "(0::'a ell2) \<noteq> 1"
     apply transfer
     by (meson zero_neq_one)
 qed
 end
 
 instantiation ell2 :: (CARD_1) field begin
 lift_definition divide_ell2 :: "'a ell2 \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>a b x. a x / b x"
   by simp   
 lift_definition inverse_ell2 :: "'a ell2 \<Rightarrow> 'a ell2" is "\<lambda>a x. inverse (a x)"
   by simp
 instance
 proof (intro_classes; transfer)
   fix a :: "'a \<Rightarrow> complex"
   assume "a \<noteq> (\<lambda>_. 0)"
   then obtain y where ay: "a y \<noteq> 0"
     by auto
   show "(\<lambda>x. inverse (a x) * a x) = (\<lambda>_. 1)"
   proof (rule ext)
     fix x
     have "x = y"
       by auto
     with ay have "a x \<noteq> 0"
       by metis
     then show "inverse (a x) * a x = 1"
       by auto
   qed
 qed (auto simp add: divide_complex_def mult.commute ring_class.ring_distribs)
 end
 
+lemma sum_ell2_transfer[transfer_rule]:
+  includes lifting_syntax
+  shows \<open>(((=) ===> pcr_ell2 (=)) ===> rel_set (=) ===> pcr_ell2 (=)) 
+          (\<lambda>f X x. sum (\<lambda>y. f y x) X) sum\<close>
+proof (intro rel_funI, rename_tac f f' X X')
+  fix f and f' :: \<open>'a \<Rightarrow> 'b ell2\<close> 
+  assume [transfer_rule]: \<open>((=) ===> pcr_ell2 (=)) f f'\<close>
+  fix X X' :: \<open>'a set\<close>
+  assume \<open>rel_set (=) X X'\<close>
+  then have [simp]: \<open>X' = X\<close>
+    by (simp add: rel_set_eq)
+  show \<open>pcr_ell2 (=) (\<lambda>x. \<Sum>y\<in>X. f y x) (sum f' X')\<close>
+    unfolding \<open>X' = X\<close>
+  proof (induction X rule: infinite_finite_induct)
+    case (infinite X)
+    show ?case
+      apply (simp add: infinite)
+      by transfer_prover
+  next
+    case empty
+    show ?case
+      apply (simp add: empty)
+      by transfer_prover
+  next
+    case (insert x F)
+    note [transfer_rule] = insert.IH
+    show ?case
+      apply (simp add: insert)
+      by transfer_prover
+  qed
+qed
+
 subsection \<open>Orthogonality\<close>
 
 lemma ell2_pointwise_ortho:
   assumes \<open>\<And> i. Rep_ell2 x i = 0 \<or> Rep_ell2 y i = 0\<close>
   shows \<open>is_orthogonal x y\<close>
   using assms apply transfer
   by (simp add: infsum_0)
 
 subsection \<open>Truncated vectors\<close>
 
 lift_definition trunc_ell2:: \<open>'a set \<Rightarrow> 'a ell2 \<Rightarrow> 'a ell2\<close>
   is \<open>\<lambda> S x. (\<lambda> i. (if i \<in> S then x i else 0))\<close>
 proof (rename_tac S x)
   fix x :: \<open>'a \<Rightarrow> complex\<close> and S :: \<open>'a set\<close>
   assume \<open>has_ell2_norm x\<close>
   then have \<open>(\<lambda>i. (x i)\<^sup>2) abs_summable_on UNIV\<close>
     unfolding has_ell2_norm_def by -
   then have \<open>(\<lambda>i. (x i)\<^sup>2) abs_summable_on S\<close>
     using summable_on_subset_banach by blast
   then have \<open>(\<lambda>xa. (if xa \<in> S then x xa else 0)\<^sup>2) abs_summable_on UNIV\<close>
     apply (rule summable_on_cong_neutral[THEN iffD1, rotated -1])
     by auto
   then show \<open>has_ell2_norm (\<lambda>i. if i \<in> S then x i else 0)\<close>
     unfolding has_ell2_norm_def by -
 qed
 
 lemma trunc_ell2_empty[simp]: \<open>trunc_ell2 {} x = 0\<close>
   apply transfer by simp
 
 lemma trunc_ell2_UNIV[simp]: \<open>trunc_ell2 UNIV \<psi> = \<psi>\<close>
   apply transfer by simp
 
 lemma norm_id_minus_trunc_ell2:
   \<open>(norm (x - trunc_ell2 S x))^2 = (norm x)^2 - (norm (trunc_ell2 S x))^2\<close>
 proof-
   have \<open>Rep_ell2 (trunc_ell2 S x) i = 0 \<or> Rep_ell2 (x - trunc_ell2 S x) i = 0\<close> for i
     apply transfer
     by auto
   hence \<open>\<langle> (trunc_ell2 S x), (x - trunc_ell2 S x) \<rangle> = 0\<close>
     using ell2_pointwise_ortho by blast
   hence \<open>(norm x)^2 = (norm (trunc_ell2 S x))^2 + (norm (x - trunc_ell2 S x))^2\<close>
     using pythagorean_theorem by fastforce    
   thus ?thesis by simp
 qed
 
 lemma norm_trunc_ell2_finite:
   \<open>finite S \<Longrightarrow> (norm (trunc_ell2 S x)) = sqrt ((sum (\<lambda>i. (cmod (Rep_ell2 x i))\<^sup>2)) S)\<close>
 proof-
   assume \<open>finite S\<close>
   moreover have \<open>\<And> i. i \<notin> S \<Longrightarrow> Rep_ell2 ((trunc_ell2 S x)) i = 0\<close>
     by (simp add: trunc_ell2.rep_eq)    
   ultimately have \<open>(norm (trunc_ell2 S x)) = sqrt ((sum (\<lambda>i. (cmod (Rep_ell2 ((trunc_ell2 S x)) i))\<^sup>2)) S)\<close>
     using ell2_norm_finite_support
     by blast 
   moreover have \<open>\<And> i. i \<in> S \<Longrightarrow> Rep_ell2 ((trunc_ell2 S x)) i = Rep_ell2 x i\<close>
     by (simp add: trunc_ell2.rep_eq)
   ultimately show ?thesis by simp
 qed
 
 lemma trunc_ell2_lim_at_UNIV:
   \<open>((\<lambda>S. trunc_ell2 S \<psi>) \<longlongrightarrow> \<psi>) (finite_subsets_at_top UNIV)\<close>
 proof -
   define f where \<open>f i = (cmod (Rep_ell2 \<psi> i))\<^sup>2\<close> for i
 
   have has: \<open>has_ell2_norm (Rep_ell2 \<psi>)\<close>
     using Rep_ell2 by blast
   then have summable: "f abs_summable_on UNIV"
     by (smt (verit, del_insts) f_def has_ell2_norm_def norm_ge_zero norm_power real_norm_def summable_on_cong)
 
   have \<open>norm \<psi> = (ell2_norm (Rep_ell2 \<psi>))\<close>
     apply transfer by simp
   also have \<open>\<dots> = sqrt (infsum f UNIV)\<close>
     by (simp add: ell2_norm_def f_def[symmetric])
   finally have norm\<psi>: \<open>norm \<psi> = sqrt (infsum f UNIV)\<close>
     by -
 
   have norm_trunc: \<open>norm (trunc_ell2 S \<psi>) = sqrt (sum f S)\<close> if \<open>finite S\<close> for S
     using f_def that norm_trunc_ell2_finite by fastforce
 
   have \<open>(sum f \<longlongrightarrow> infsum f UNIV) (finite_subsets_at_top UNIV)\<close>
     using f_def[abs_def] infsum_tendsto local.summable by fastforce
   then have \<open>((\<lambda>S. sqrt (sum f S)) \<longlongrightarrow> sqrt (infsum f UNIV)) (finite_subsets_at_top UNIV)\<close>
     using tendsto_real_sqrt by blast
   then have \<open>((\<lambda>S. norm (trunc_ell2 S \<psi>)) \<longlongrightarrow> norm \<psi>) (finite_subsets_at_top UNIV)\<close>
     apply (subst tendsto_cong[where g=\<open>\<lambda>S. sqrt (sum f S)\<close>])
     by (auto simp add: eventually_finite_subsets_at_top_weakI norm_trunc norm\<psi>)
   then have \<open>((\<lambda>S. (norm (trunc_ell2 S \<psi>))\<^sup>2) \<longlongrightarrow> (norm \<psi>)\<^sup>2) (finite_subsets_at_top UNIV)\<close>
     by (simp add: tendsto_power)
   then have \<open>((\<lambda>S. (norm \<psi>)\<^sup>2 - (norm (trunc_ell2 S \<psi>))\<^sup>2) \<longlongrightarrow> 0) (finite_subsets_at_top UNIV)\<close>
     apply (rule tendsto_diff[where a=\<open>(norm \<psi>)^2\<close> and b=\<open>(norm \<psi>)^2\<close>, simplified, rotated])
     by auto
   then have \<open>((\<lambda>S. (norm (\<psi> - trunc_ell2 S \<psi>))\<^sup>2) \<longlongrightarrow> 0) (finite_subsets_at_top UNIV)\<close>
     unfolding norm_id_minus_trunc_ell2 by simp
   then have \<open>((\<lambda>S. norm (\<psi> - trunc_ell2 S \<psi>)) \<longlongrightarrow> 0) (finite_subsets_at_top UNIV)\<close>
     by auto
   then have \<open>((\<lambda>S. \<psi> - trunc_ell2 S \<psi>) \<longlongrightarrow> 0) (finite_subsets_at_top UNIV)\<close>
     by (rule tendsto_norm_zero_cancel)
   then show ?thesis
     apply (rule Lim_transform2[where f=\<open>\<lambda>_. \<psi>\<close>, rotated])
     by simp
 qed
 
 lemma trunc_ell2_norm_mono: \<open>M \<subseteq> N \<Longrightarrow> norm (trunc_ell2 M \<psi>) \<le> norm (trunc_ell2 N \<psi>)\<close>
 proof (rule power2_le_imp_le[rotated], force, transfer)
   fix M N :: \<open>'a set\<close> and \<psi> :: \<open>'a \<Rightarrow> complex\<close>
   assume \<open>M \<subseteq> N\<close> and \<open>has_ell2_norm \<psi>\<close>
   have \<open>(ell2_norm (\<lambda>i. if i \<in> M then \<psi> i else 0))\<^sup>2 = (\<Sum>\<^sub>\<infinity>i\<in>M. (cmod (\<psi> i))\<^sup>2)\<close>
     unfolding ell2_norm_square
     apply (rule infsum_cong_neutral)
     by auto
   also have \<open>\<dots> \<le> (\<Sum>\<^sub>\<infinity>i\<in>N. (cmod (\<psi> i))\<^sup>2)\<close>
     apply (rule infsum_mono2)
     using \<open>has_ell2_norm \<psi>\<close> \<open>M \<subseteq> N\<close>
     by (auto simp add: ell2_norm_square has_ell2_norm_def simp flip: norm_power intro: summable_on_subset_banach)
   also have \<open>\<dots> = (ell2_norm (\<lambda>i. if i \<in> N then \<psi> i else 0))\<^sup>2\<close>
     unfolding ell2_norm_square
     apply (rule infsum_cong_neutral)
     by auto
   finally show \<open>(ell2_norm (\<lambda>i. if i \<in> M then \<psi> i else 0))\<^sup>2 \<le> (ell2_norm (\<lambda>i. if i \<in> N then \<psi> i else 0))\<^sup>2\<close>
     by -
 qed
 
 lemma trunc_ell2_twice[simp]: \<open>trunc_ell2 M (trunc_ell2 N \<psi>) = trunc_ell2 (M\<inter>N) \<psi>\<close>
   apply transfer by auto
 
 lemma trunc_ell2_union: \<open>trunc_ell2 (M \<union> N) \<psi> = trunc_ell2 M \<psi> + trunc_ell2 N \<psi> - trunc_ell2 (M\<inter>N) \<psi>\<close>
   apply transfer by auto
 
 lemma trunc_ell2_union_disjoint: \<open>M\<inter>N = {} \<Longrightarrow> trunc_ell2 (M \<union> N) \<psi> = trunc_ell2 M \<psi> + trunc_ell2 N \<psi>\<close>
   by (simp add: trunc_ell2_union)
 
 lemma trunc_ell2_union_Diff: \<open>M \<subseteq> N \<Longrightarrow> trunc_ell2 (N-M) \<psi> = trunc_ell2 N \<psi> - trunc_ell2 M \<psi>\<close>
   using trunc_ell2_union_disjoint[where M=\<open>N-M\<close> and N=M and \<psi>=\<psi>]
   by (simp add: Un_commute inf.commute le_iff_sup)
 
 lemma trunc_ell2_lim: \<open>((\<lambda>S. trunc_ell2 S \<psi>) \<longlongrightarrow> trunc_ell2 M \<psi>) (finite_subsets_at_top M)\<close>
 proof -
   have \<open>((\<lambda>S. trunc_ell2 S (trunc_ell2 M \<psi>)) \<longlongrightarrow> trunc_ell2 M \<psi>) (finite_subsets_at_top UNIV)\<close>
     using trunc_ell2_lim_at_UNIV by blast
   then have \<open>((\<lambda>S. trunc_ell2 (S\<inter>M) \<psi>) \<longlongrightarrow> trunc_ell2 M \<psi>) (finite_subsets_at_top UNIV)\<close>
     by simp
   then show \<open>((\<lambda>S. trunc_ell2 S \<psi>) \<longlongrightarrow> trunc_ell2 M \<psi>) (finite_subsets_at_top M)\<close>
     unfolding filterlim_def
     apply (subst (asm) filtermap_filtermap[where g=\<open>\<lambda>S. S\<inter>M\<close>, symmetric])
     apply (subst (asm) finite_subsets_at_top_inter[where A=M and B=UNIV])
     by auto
 qed
 
 lemma trunc_ell2_lim_general:
   assumes big: \<open>\<And>G. finite G \<Longrightarrow> G \<subseteq> M \<Longrightarrow> (\<forall>\<^sub>F H in F. H \<supseteq> G)\<close>
   assumes small: \<open>\<forall>\<^sub>F H in F. H \<subseteq> M\<close>
   shows \<open>((\<lambda>S. trunc_ell2 S \<psi>) \<longlongrightarrow> trunc_ell2 M \<psi>) F\<close>
 proof (rule tendstoI)
   fix e :: real assume \<open>e > 0\<close>
   from trunc_ell2_lim[THEN tendsto_iff[THEN iffD1], rule_format, OF \<open>e > 0\<close>, where M=M and \<psi>=\<psi>]
   obtain G where \<open>finite G\<close> and \<open>G \<subseteq> M\<close> and 
     close: \<open>dist (trunc_ell2 G \<psi>) (trunc_ell2 M \<psi>) < e\<close>
     apply atomize_elim
     unfolding eventually_finite_subsets_at_top
     by blast
   from \<open>finite G\<close> \<open>G \<subseteq> M\<close> and big
   have \<open>\<forall>\<^sub>F H in F. H \<supseteq> G\<close>
     by -
   with small have \<open>\<forall>\<^sub>F H in F. H \<subseteq> M \<and> H \<supseteq> G\<close>
     by (simp add: eventually_conj_iff)
   then show \<open>\<forall>\<^sub>F H in F. dist (trunc_ell2 H \<psi>) (trunc_ell2 M \<psi>) < e\<close>
   proof (rule eventually_mono)
     fix H assume GHM: \<open>H \<subseteq> M \<and> H \<supseteq> G\<close>
     have \<open>dist (trunc_ell2 H \<psi>) (trunc_ell2 M \<psi>) = norm (trunc_ell2 (M-H) \<psi>)\<close>
       by (simp add: GHM dist_ell2_def norm_minus_commute trunc_ell2_union_Diff)
     also have \<open>\<dots> \<le> norm (trunc_ell2 (M-G) \<psi>)\<close>
       by (simp add: Diff_mono GHM trunc_ell2_norm_mono)
     also have \<open>\<dots>  = dist (trunc_ell2 G \<psi>) (trunc_ell2 M \<psi>)\<close>
       by (simp add: \<open>G \<subseteq> M\<close> dist_ell2_def norm_minus_commute trunc_ell2_union_Diff)
     also have \<open>\<dots> < e\<close>
       using close by simp
     finally show \<open>dist (trunc_ell2 H \<psi>) (trunc_ell2 M \<psi>) < e\<close>
       by -
   qed
 qed
 
 subsection \<open>Kets and bras\<close>
 
 lift_definition ket :: "'a \<Rightarrow> 'a ell2" is "\<lambda>x y. if x=y then 1 else 0"
   by (rule has_ell2_norm_ket)
 
 abbreviation bra :: "'a \<Rightarrow> (_,complex) cblinfun" where "bra i \<equiv> vector_to_cblinfun (ket i)*" for i
 
 instance ell2 :: (type) not_singleton
 proof standard
   have "ket undefined \<noteq> (0::'a ell2)"
   proof transfer
     show "(\<lambda>y. if (undefined::'a) = y then 1::complex else 0) \<noteq> (\<lambda>_. 0)"
       by (meson one_neq_zero)
   qed   
   thus \<open>\<exists>x y::'a ell2. x \<noteq> y\<close>
     by blast    
 qed
 
 lemma cinner_ket_left: \<open>\<langle>ket i, \<psi>\<rangle> = Rep_ell2 \<psi> i\<close>
   apply (transfer fixing: i)
   apply (subst infsum_cong_neutral[where T=\<open>{i}\<close>])
   by auto
 
 lemma cinner_ket_right: \<open>\<langle>\<psi>, ket i\<rangle> = cnj (Rep_ell2 \<psi> i)\<close>
   apply (transfer fixing: i)
   apply (subst infsum_cong_neutral[where T=\<open>{i}\<close>])
   by auto
 
 lemma cinner_ket_eqI:
   assumes \<open>\<And>i. cinner (ket i) \<psi> = cinner (ket i) \<phi>\<close>
   shows \<open>\<psi> = \<phi>\<close>
   by (metis Rep_ell2_inject assms cinner_ket_left ext)
 
 lemma norm_ket[simp]: "norm (ket i) = 1"
   apply transfer by (rule ell2_norm_ket)
 
 lemma cinner_ket_same[simp]:
   \<open>\<langle>ket i, ket i\<rangle> = 1\<close>
 proof-
   have \<open>norm (ket i) = 1\<close>
     by simp
   hence \<open>sqrt (cmod \<langle>ket i, ket i\<rangle>) = 1\<close>
     by (metis norm_eq_sqrt_cinner)
   hence \<open>cmod \<langle>ket i, ket i\<rangle> = 1\<close>
     using real_sqrt_eq_1_iff by blast
   moreover have \<open>\<langle>ket i, ket i\<rangle> = cmod \<langle>ket i, ket i\<rangle>\<close>
   proof-
     have \<open>\<langle>ket i, ket i\<rangle> \<in> \<real>\<close>
       by (simp add: cinner_real)      
     thus ?thesis 
       by (metis cinner_ge_zero complex_of_real_cmod) 
   qed
   ultimately show ?thesis by simp
 qed
 
 lemma orthogonal_ket[simp]:
   \<open>is_orthogonal (ket i) (ket j) \<longleftrightarrow> i \<noteq> j\<close>
   by (simp add: cinner_ket_left ket.rep_eq)
 
 lemma cinner_ket: \<open>\<langle>ket i, ket j\<rangle> = (if i=j then 1 else 0)\<close>
   by (simp add: cinner_ket_left ket.rep_eq)
 
 lemma ket_injective[simp]: \<open>ket i = ket j \<longleftrightarrow> i = j\<close>
   by (metis cinner_ket one_neq_zero)
 
 lemma inj_ket[simp]: \<open>inj ket\<close>
   by (simp add: inj_on_def)
 
 
 lemma trunc_ell2_ket_cspan:
   \<open>trunc_ell2 S x \<in> (cspan (range ket))\<close> if \<open>finite S\<close>
 proof (use that in induction)
   case empty
   then show ?case 
     by (auto intro: complex_vector.span_zero)
 next
   case (insert a F)
   from insert.hyps have \<open>trunc_ell2 (insert a F) x = trunc_ell2 F x + Rep_ell2 x a *\<^sub>C ket a\<close>
     apply (transfer fixing: F a)
     by auto
   with insert.IH
   show ?case
     by (simp add: complex_vector.span_add_eq complex_vector.span_base complex_vector.span_scale)
 qed
 
 lemma closed_cspan_range_ket[simp]:
   \<open>closure (cspan (range ket)) = UNIV\<close>
 proof (intro set_eqI iffI UNIV_I closure_approachable[THEN iffD2] allI impI)
   fix \<psi> :: \<open>'a ell2\<close>
   fix e :: real assume \<open>e > 0\<close>
   have \<open>((\<lambda>S. trunc_ell2 S \<psi>) \<longlongrightarrow> \<psi>) (finite_subsets_at_top UNIV)\<close>
     by (rule trunc_ell2_lim_at_UNIV)
   then obtain F where \<open>finite F\<close> and \<open>dist (trunc_ell2 F \<psi>) \<psi> < e\<close>
     apply (drule_tac tendstoD[OF _ \<open>e > 0\<close>])
     by (auto dest: simp: eventually_finite_subsets_at_top)
   moreover have \<open>trunc_ell2 F \<psi> \<in> cspan (range ket)\<close>
     using \<open>finite F\<close> trunc_ell2_ket_cspan by blast
   ultimately show \<open>\<exists>\<phi>\<in>cspan (range ket). dist \<phi> \<psi> < e\<close>
     by auto
 qed
 
 lemma ccspan_range_ket[simp]: "ccspan (range ket) = (top::('a ell2 ccsubspace))"
 proof-
   have \<open>closure (complex_vector.span (range ket)) = (UNIV::'a ell2 set)\<close>
     using Complex_L2.closed_cspan_range_ket by blast
   thus ?thesis
     by (simp add: ccspan.abs_eq top_ccsubspace.abs_eq)
 qed
 
 lemma cspan_range_ket_finite[simp]: "cspan (range ket :: 'a::finite ell2 set) = UNIV"
   by (metis closed_cspan_range_ket closure_finite_cspan finite_class.finite_UNIV finite_imageI)
 
 instance ell2 :: (finite) cfinite_dim
 proof
   define basis :: \<open>'a ell2 set\<close> where \<open>basis = range ket\<close>
   have \<open>finite basis\<close>
     unfolding basis_def by simp
   moreover have \<open>cspan basis = UNIV\<close>
     by (simp add: basis_def)
   ultimately show \<open>\<exists>basis::'a ell2 set. finite basis \<and> cspan basis = UNIV\<close>
     by auto
 qed
 
 instantiation ell2 :: (enum) onb_enum begin
 definition "canonical_basis_ell2 = map ket Enum.enum"
 instance
 proof
   show "distinct (canonical_basis::'a ell2 list)"
   proof-
     have \<open>finite (UNIV::'a set)\<close>
       by simp
     have \<open>distinct (enum_class.enum::'a list)\<close>
       using enum_distinct by blast
     moreover have \<open>inj_on ket (set enum_class.enum)\<close>
       by (meson inj_onI ket_injective)         
     ultimately show ?thesis
       unfolding canonical_basis_ell2_def
       using distinct_map
       by blast
   qed    
 
   show "is_ortho_set (set (canonical_basis::'a ell2 list))"
     apply (auto simp: canonical_basis_ell2_def enum_UNIV)
     by (smt (z3) norm_ket f_inv_into_f is_ortho_set_def orthogonal_ket norm_zero)
 
   show "cindependent (set (canonical_basis::'a ell2 list))"
     apply (auto simp: canonical_basis_ell2_def enum_UNIV)
     by (smt (verit, best) norm_ket f_inv_into_f is_ortho_set_def is_ortho_set_cindependent orthogonal_ket norm_zero)
 
   show "cspan (set (canonical_basis::'a ell2 list)) = UNIV"
     by (auto simp: canonical_basis_ell2_def enum_UNIV)
 
   show "norm (x::'a ell2) = 1"
     if "(x::'a ell2) \<in> set canonical_basis"
     for x :: "'a ell2"
     using that unfolding canonical_basis_ell2_def 
     by auto
 qed
 
 end
 
 lemma canonical_basis_length_ell2[code_unfold, simp]:
   "length (canonical_basis ::'a::enum ell2 list) = CARD('a)"
   unfolding canonical_basis_ell2_def apply simp
   using card_UNIV_length_enum by metis
 
 lemma ket_canonical_basis: "ket x = canonical_basis ! enum_idx x"
 proof-
   have "x = (enum_class.enum::'a list) ! enum_idx x"
     using enum_idx_correct[where i = x] by simp
   hence p1: "ket x = ket ((enum_class.enum::'a list) ! enum_idx x)"
     by simp
   have "enum_idx x < length (enum_class.enum::'a list)"
     using enum_idx_bound[where x = x].
   hence "(map ket (enum_class.enum::'a list)) ! enum_idx x 
         = ket ((enum_class.enum::'a list) ! enum_idx x)"
     by auto      
   thus ?thesis
     unfolding canonical_basis_ell2_def using p1 by auto    
 qed
 
 lemma clinear_equal_ket:
   fixes f g :: \<open>'a::finite ell2 \<Rightarrow> _\<close>
   assumes \<open>clinear f\<close>
   assumes \<open>clinear g\<close>
   assumes \<open>\<And>i. f (ket i) = g (ket i)\<close>
   shows \<open>f = g\<close>
   apply (rule ext)
   apply (rule complex_vector.linear_eq_on_span[where f=f and g=g and B=\<open>range ket\<close>])
   using assms by auto
 
 lemma equal_ket:
   fixes A B :: \<open>('a ell2, 'b::complex_normed_vector) cblinfun\<close>
   assumes \<open>\<And> x. cblinfun_apply A (ket x) = cblinfun_apply B (ket x)\<close>
   shows \<open>A = B\<close>
   apply (rule cblinfun_eq_gen_eqI[where G=\<open>range ket\<close>])
   using assms by auto
 
 lemma antilinear_equal_ket:
   fixes f g :: \<open>'a::finite ell2 \<Rightarrow> _\<close>
   assumes \<open>antilinear f\<close>
   assumes \<open>antilinear g\<close>
   assumes \<open>\<And>i. f (ket i) = g (ket i)\<close>
   shows \<open>f = g\<close>
 proof -
   have [simp]: \<open>clinear (f \<circ> from_conjugate_space)\<close>
     apply (rule antilinear_o_antilinear)
     using assms by (simp_all add: antilinear_from_conjugate_space)
   have [simp]: \<open>clinear (g \<circ> from_conjugate_space)\<close>
     apply (rule antilinear_o_antilinear)
     using assms by (simp_all add: antilinear_from_conjugate_space)
   have [simp]: \<open>cspan (to_conjugate_space ` (range ket :: 'a ell2 set)) = UNIV\<close>
     by simp
   have "f o from_conjugate_space = g o from_conjugate_space"
     apply (rule ext)
     apply (rule complex_vector.linear_eq_on_span[where f="f o from_conjugate_space" and g="g o from_conjugate_space" and B=\<open>to_conjugate_space ` range ket\<close>])
        apply (simp, simp)
     using assms(3) by (auto simp: to_conjugate_space_inverse)
   then show "f = g"
     by (smt (verit) UNIV_I from_conjugate_space_inverse surj_def surj_fun_eq to_conjugate_space_inject) 
 qed
 
 lemma cinner_ket_adjointI:
   fixes F::"'a ell2 \<Rightarrow>\<^sub>C\<^sub>L _" and G::"'b ell2 \<Rightarrow>\<^sub>C\<^sub>L_"
   assumes "\<And> i j. \<langle>F *\<^sub>V ket i, ket j\<rangle> = \<langle>ket i, G *\<^sub>V ket j\<rangle>"
   shows "F = G*"
 proof -
   from assms
   have \<open>(F *\<^sub>V x) \<bullet>\<^sub>C y = x \<bullet>\<^sub>C (G *\<^sub>V y)\<close> if \<open>x \<in> range ket\<close> and \<open>y \<in> range ket\<close> for x y
     using that by auto
   then have \<open>(F *\<^sub>V x) \<bullet>\<^sub>C y = x \<bullet>\<^sub>C (G *\<^sub>V y)\<close> if \<open>x \<in> range ket\<close> for x y
     apply (rule bounded_clinear_eq_on[where G=\<open>range ket\<close> and t=y, rotated 2])
     using that by (auto intro!: bounded_linear_intros)
   then have \<open>(F *\<^sub>V x) \<bullet>\<^sub>C y = x \<bullet>\<^sub>C (G *\<^sub>V y)\<close> for x y
     apply (rule bounded_antilinear_eq_on[where G=\<open>range ket\<close> and t=x, rotated 2])
     by (auto intro!: bounded_linear_intros)
   then show ?thesis
     by (rule adjoint_eqI)
 qed
 
 lemma ket_nonzero[simp]: "ket i \<noteq> 0"
   using norm_ket[of i] by force
 
 
 lemma cindependent_ket:
   "cindependent (range (ket::'a\<Rightarrow>_))"
 proof-
   define S where "S = range (ket::'a\<Rightarrow>_)"
   have "is_ortho_set S"
     unfolding S_def is_ortho_set_def by auto
   moreover have "0 \<notin> S"
     unfolding S_def
     using ket_nonzero
     by (simp add: image_iff)
   ultimately show ?thesis
     using is_ortho_set_cindependent[where A = S] unfolding S_def 
     by blast
 qed
 
 lemma cdim_UNIV_ell2[simp]: \<open>cdim (UNIV::'a::finite ell2 set) = CARD('a)\<close>
   apply (subst cspan_range_ket_finite[symmetric])
   by (metis card_image cindependent_ket complex_vector.dim_span_eq_card_independent inj_ket)
 
 lemma is_ortho_set_ket[simp]: \<open>is_ortho_set (range ket)\<close>
   using is_ortho_set_def by fastforce
 
 lemma bounded_clinear_equal_ket:
   fixes f g :: \<open>'a ell2 \<Rightarrow> _\<close>
   assumes \<open>bounded_clinear f\<close>
   assumes \<open>bounded_clinear g\<close>
   assumes \<open>\<And>i. f (ket i) = g (ket i)\<close>
   shows \<open>f = g\<close>
   apply (rule ext)
   apply (rule bounded_clinear_eq_on[of f g \<open>range ket\<close>])
   using assms by auto
 
 lemma bounded_antilinear_equal_ket:
   fixes f g :: \<open>'a ell2 \<Rightarrow> _\<close>
   assumes \<open>bounded_antilinear f\<close>
   assumes \<open>bounded_antilinear g\<close>
   assumes \<open>\<And>i. f (ket i) = g (ket i)\<close>
   shows \<open>f = g\<close>
   apply (rule ext)
   apply (rule bounded_antilinear_eq_on[of f g \<open>range ket\<close>])
   using assms by auto
 
 lemma ket_CARD_1_is_1: \<open>ket x = 1\<close> for x :: \<open>'a::CARD_1\<close>
   apply transfer by simp
 
 lemma is_onb_ket[simp]: \<open>is_onb (range ket)\<close>
   by (auto simp: is_onb_def)
 
+lemma ell2_sum_ket: \<open>\<psi> = (\<Sum>i\<in>UNIV. Rep_ell2 \<psi> i *\<^sub>C ket i)\<close> for \<psi> :: \<open>_::finite ell2\<close>
+  apply transfer apply (rule ext)
+  apply (subst sum_single)
+  by auto
+
 subsection \<open>Butterflies\<close>
 
 lemma cspan_butterfly_ket: \<open>cspan {butterfly (ket i) (ket j)| (i::'b::finite) (j::'a::finite). True} = UNIV\<close>
 proof -
   have *: \<open>{butterfly (ket i) (ket j)| (i::'b::finite) (j::'a::finite). True} = {butterfly a b |a b. a \<in> range ket \<and> b \<in> range ket}\<close>
     by auto
   show ?thesis
     apply (subst *)
     apply (rule cspan_butterfly_UNIV)
     by auto
 qed
 
 lemma cindependent_butterfly_ket: \<open>cindependent {butterfly (ket i) (ket j)| (i::'b) (j::'a). True}\<close>
 proof -
   have *: \<open>{butterfly (ket i) (ket j)| (i::'b) (j::'a). True} = {butterfly a b |a b. a \<in> range ket \<and> b \<in> range ket}\<close>
     by auto
   show ?thesis
     apply (subst *)
     apply (rule cindependent_butterfly)
     by auto
 qed
 
 lemma clinear_eq_butterfly_ketI:
   fixes F G :: \<open>('a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::finite ell2) \<Rightarrow> 'c::complex_vector\<close>
   assumes "clinear F" and "clinear G"
   assumes "\<And>i j. F (butterfly (ket i) (ket j)) = G (butterfly (ket i) (ket j))"
   shows "F = G"
   apply (rule complex_vector.linear_eq_on_span[where f=F, THEN ext, rotated 3])
      apply (subst cspan_butterfly_ket)
   using assms by auto
 
 lemma sum_butterfly_ket[simp]: \<open>(\<Sum>(i::'a::finite)\<in>UNIV. butterfly (ket i) (ket i)) = id_cblinfun\<close>
   apply (rule equal_ket)
   apply (subst complex_vector.linear_sum[where f=\<open>\<lambda>y. y *\<^sub>V ket _\<close>])
    apply (auto simp add: scaleC_cblinfun.rep_eq cblinfun.add_left clinearI butterfly_def cblinfun_compose_image cinner_ket)
   apply (subst sum.mono_neutral_cong_right[where S=\<open>{_}\<close>])
   by auto
 
 subsection \<open>One-dimensional spaces\<close>
 
 instantiation ell2 :: ("{enum,CARD_1}") one_dim begin
 text \<open>Note: enum is not needed logically, but without it this instantiation
             clashes with \<open>instantiation ell2 :: (enum) onb_enum\<close>\<close>
 instance
 proof
   show "canonical_basis = [1::'a ell2]"
     unfolding canonical_basis_ell2_def
     apply transfer
     by (simp add: enum_CARD_1[of undefined])
   show "a *\<^sub>C 1 * b *\<^sub>C 1 = (a * b) *\<^sub>C (1::'a ell2)" for a b
     apply (transfer fixing: a b) by simp
   show "x / y = x * inverse y" for x y :: "'a ell2"
     by (simp add: divide_inverse)
   show "inverse (c *\<^sub>C 1) = inverse c *\<^sub>C (1::'a ell2)" for c :: complex
     apply transfer by auto
 qed
 end
 
 
 subsection \<open>Classical operators\<close>
 
 text \<open>We call an operator mapping \<^term>\<open>ket x\<close> to \<^term>\<open>ket (\<pi> x)\<close> or \<^term>\<open>0\<close> "classical".
 (The meaning is inspired by the fact that in quantum mechanics, such operators usually correspond
 to operations with classical interpretation (such as Pauli-X, CNOT, measurement in the computational
 basis, etc.))\<close>
 
 definition classical_operator :: "('a\<Rightarrow>'b option) \<Rightarrow> 'a ell2 \<Rightarrow>\<^sub>C\<^sub>L'b ell2" where
   "classical_operator \<pi> = 
     (let f = (\<lambda>t. (case \<pi> (inv (ket::'a\<Rightarrow>_) t) 
                            of None \<Rightarrow> (0::'b ell2) 
                           | Some i \<Rightarrow> ket i))
      in
       cblinfun_extension (range (ket::'a\<Rightarrow>_)) f)"
 
 
 definition "classical_operator_exists \<pi> \<longleftrightarrow>
   cblinfun_extension_exists (range ket)
     (\<lambda>t. case \<pi> (inv ket t) of None \<Rightarrow> 0 | Some i \<Rightarrow> ket i)"
 
 lemma classical_operator_existsI:
   assumes "\<And>x. B *\<^sub>V (ket x) = (case \<pi> x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)"
   shows "classical_operator_exists \<pi>"
   unfolding classical_operator_exists_def
   apply (rule cblinfun_extension_existsI[of _ B])
   using assms 
   by (auto simp: inv_f_f[OF inj_ket])
 
-lemma classical_operator_exists_inj:
+lemma 
   assumes "inj_map \<pi>"
-  shows "classical_operator_exists \<pi>"
-proof (unfold classical_operator_exists_def, rule cblinfun_extension_exists_ortho)
-  show \<open>is_ortho_set (range ket)\<close>
-    by simp
-  show \<open>closure (cspan (range ket)) = UNIV\<close>
-    by simp
+  shows classical_operator_exists_inj: "classical_operator_exists \<pi>"
+    and classical_operator_norm_inj: \<open>norm (classical_operator \<pi>) \<le> 1\<close>
+proof -
   have \<open>is_orthogonal (case \<pi> x of None \<Rightarrow> 0 | Some x' \<Rightarrow> ket x')
                       (case \<pi> y of None \<Rightarrow> 0 | Some y' \<Rightarrow> ket y')\<close>
     if \<open>x \<noteq> y\<close> for x y
     apply (cases \<open>\<pi> x\<close>; cases \<open>\<pi> y\<close>)
     using that assms
     by (auto simp add: inj_map_def)
-  then show \<open>is_orthogonal (case \<pi> (inv ket x) of None \<Rightarrow> 0 | Some x' \<Rightarrow> ket x')
+  then have 1: \<open>is_orthogonal (case \<pi> (inv ket x) of None \<Rightarrow> 0 | Some x' \<Rightarrow> ket x')
                       (case \<pi> (inv ket y) of None \<Rightarrow> 0 | Some y' \<Rightarrow> ket y')\<close>
     if \<open>x \<in> range ket\<close> and \<open>y \<in> range ket\<close> and \<open>x \<noteq> y\<close> for x y
     using that by auto
+
   have \<open>norm (case \<pi> x of None \<Rightarrow> 0 | Some x \<Rightarrow> ket x) \<le> 1 * norm (ket x)\<close> for x
     apply (cases \<open>\<pi> x\<close>) by auto
-  then show \<open>norm (case \<pi> (inv ket x) of None \<Rightarrow> 0 | Some x \<Rightarrow> ket x) \<le> 1 * norm x\<close>
+  then have 2: \<open>norm (case \<pi> (inv ket x) of None \<Rightarrow> 0 | Some x \<Rightarrow> ket x) \<le> 1 * norm x\<close>
     if \<open>x \<in> range ket\<close> for x
     using that by auto
+
+  show \<open>classical_operator_exists \<pi>\<close>
+    unfolding classical_operator_exists_def
+    using _ _ 1 2 apply (rule cblinfun_extension_exists_ortho)
+    by simp_all
+
+  show \<open>norm (classical_operator \<pi>) \<le> 1\<close>
+    unfolding classical_operator_def Let_def
+    using _ _ 1 2 apply (rule cblinfun_extension_exists_ortho_norm)
+    by simp_all
 qed
 
 lemma classical_operator_exists_finite[simp]: "classical_operator_exists (\<pi> :: _::finite \<Rightarrow> _)"
   unfolding classical_operator_exists_def
   apply (rule cblinfun_extension_exists_finite_dim)
   using cindependent_ket apply blast
   using finite_class.finite_UNIV finite_imageI closed_cspan_range_ket closure_finite_cspan by blast
 
 lemma classical_operator_ket:
   assumes "classical_operator_exists \<pi>"
   shows "(classical_operator \<pi>) *\<^sub>V (ket x) = (case \<pi> x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)"
   unfolding classical_operator_def 
   using f_inv_into_f ket_injective rangeI
   by (metis assms cblinfun_extension_apply classical_operator_exists_def)
 
 lemma classical_operator_ket_finite:
   "(classical_operator \<pi>) *\<^sub>V (ket (x::'a::finite)) = (case \<pi> x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)"
   by (rule classical_operator_ket, simp)
 
 lemma classical_operator_adjoint[simp]:
   fixes \<pi> :: "'a \<Rightarrow> 'b option"
   assumes a1: "inj_map \<pi>"
   shows  "(classical_operator \<pi>)* = classical_operator (inv_map \<pi>)"
 proof-
   define F where "F = classical_operator (inv_map \<pi>)"
   define G where "G = classical_operator \<pi>"
   have "\<langle>F *\<^sub>V ket i, ket j\<rangle> = \<langle>ket i, G *\<^sub>V ket j\<rangle>" for i j
   proof-
     have w1: "(classical_operator (inv_map \<pi>)) *\<^sub>V (ket i)
      = (case inv_map \<pi> i of Some k \<Rightarrow> ket k | None \<Rightarrow> 0)"
       by (simp add: classical_operator_ket classical_operator_exists_inj)
     have w2: "(classical_operator \<pi>) *\<^sub>V (ket j)
      = (case \<pi> j of Some k \<Rightarrow> ket k | None \<Rightarrow> 0)"
       by (simp add: assms classical_operator_ket classical_operator_exists_inj)
     have "\<langle>F *\<^sub>V ket i, ket j\<rangle> = \<langle>classical_operator (inv_map \<pi>) *\<^sub>V ket i, ket j\<rangle>"
       unfolding F_def by blast
     also have "\<dots> = \<langle>(case inv_map \<pi> i of Some k \<Rightarrow> ket k | None \<Rightarrow> 0), ket j\<rangle>"
       using w1 by simp
     also have "\<dots> = \<langle>ket i, (case \<pi> j of Some k \<Rightarrow> ket k | None \<Rightarrow> 0)\<rangle>"
     proof(induction "inv_map \<pi> i")
       case None
       hence pi1: "None = inv_map \<pi> i".
       show ?case 
       proof (induction "\<pi> j")
         case None
         thus ?case
           using pi1 by auto
       next
         case (Some c)
         have "c \<noteq> i"
         proof(rule classical)
           assume "\<not>(c \<noteq> i)"
           hence "c = i"
             by blast
           hence "inv_map \<pi> c = inv_map \<pi> i"
             by simp
           hence "inv_map \<pi> c = None"
             by (simp add: pi1)
           moreover have "inv_map \<pi> c = Some j"
             using Some.hyps unfolding inv_map_def
             apply auto
             by (metis a1 f_inv_into_f inj_map_def option.distinct(1) rangeI)
           ultimately show ?thesis by simp
         qed
         thus ?thesis
           by (metis None.hyps Some.hyps cinner_zero_left orthogonal_ket option.simps(4) 
               option.simps(5)) 
       qed       
     next
       case (Some d)
       hence s1: "Some d = inv_map \<pi> i".
       show "\<langle>case inv_map \<pi> i of 
             None \<Rightarrow> 0
         | Some a \<Rightarrow> ket a, ket j\<rangle> =
        \<langle>ket i, case \<pi> j of 
             None \<Rightarrow> 0 
         | Some a \<Rightarrow> ket a\<rangle>" 
       proof(induction "\<pi> j")
         case None
         have "d \<noteq> j"
         proof(rule classical)
           assume "\<not>(d \<noteq> j)"
           hence "d = j"
             by blast
           hence "\<pi> d = \<pi> j"
             by simp
           hence "\<pi> d = None"
             by (simp add: None.hyps)
           moreover have "\<pi> d = Some i"
             using Some.hyps unfolding inv_map_def
             apply auto
             by (metis f_inv_into_f option.distinct(1) option.inject)
           ultimately show ?thesis 
             by simp
         qed
         thus ?case
           by (metis None.hyps Some.hyps cinner_zero_right orthogonal_ket option.case_eq_if 
               option.simps(5)) 
       next
         case (Some c)
         hence s2: "\<pi> j = Some c" by simp
         have "\<langle>ket d, ket j\<rangle> = \<langle>ket i, ket c\<rangle>"
         proof(cases "\<pi> j = Some i")
           case True
           hence ij: "Some j = inv_map \<pi> i"
             unfolding inv_map_def apply auto
              apply (metis a1 f_inv_into_f inj_map_def option.discI range_eqI)
             by (metis range_eqI)
           have "i = c"
             using True s2 by auto
           moreover have "j = d"
             by (metis option.inject s1 ij)
           ultimately show ?thesis
             by (simp add: cinner_ket_same) 
         next
           case False
           moreover have "\<pi> d = Some i"
             using s1 unfolding inv_map_def
             by (metis f_inv_into_f option.distinct(1) option.inject)            
           ultimately have "j \<noteq> d"
             by auto            
           moreover have "i \<noteq> c"
             using False s2 by auto            
           ultimately show ?thesis
             by (metis orthogonal_ket) 
         qed
         hence "\<langle>case Some d of None \<Rightarrow> 0
         | Some a \<Rightarrow> ket a, ket j\<rangle> =
        \<langle>ket i, case Some c of None \<Rightarrow> 0 | Some a \<Rightarrow> ket a\<rangle>"
           by simp          
         thus "\<langle>case inv_map \<pi> i of None \<Rightarrow> 0
         | Some a \<Rightarrow> ket a, ket j\<rangle> =
        \<langle>ket i, case \<pi> j of None \<Rightarrow> 0 | Some a \<Rightarrow> ket a\<rangle>"
           by (simp add: Some.hyps s1)          
       qed
     qed
     also have "\<dots> = \<langle>ket i, classical_operator \<pi> *\<^sub>V ket j\<rangle>"
       by (simp add: w2)
     also have "\<dots> = \<langle>ket i, G *\<^sub>V ket j\<rangle>"
       unfolding G_def by blast
     finally show ?thesis .
   qed
   hence "G* = F"
     using cinner_ket_adjointI
     by auto
   thus ?thesis unfolding G_def F_def .
 qed
 
 lemma
   fixes \<pi>::"'b \<Rightarrow> 'c option" and \<rho>::"'a \<Rightarrow> 'b option"
   assumes "classical_operator_exists \<pi>"
   assumes "classical_operator_exists \<rho>"
   shows classical_operator_exists_comp[simp]: "classical_operator_exists (\<pi> \<circ>\<^sub>m \<rho>)"
     and classical_operator_mult[simp]: "classical_operator \<pi> o\<^sub>C\<^sub>L classical_operator \<rho> = classical_operator (\<pi> \<circ>\<^sub>m \<rho>)"
 proof -
   define C\<pi> C\<rho> C\<pi>\<rho> where "C\<pi> = classical_operator \<pi>" and "C\<rho> = classical_operator \<rho>" 
     and "C\<pi>\<rho> = classical_operator (\<pi> \<circ>\<^sub>m \<rho>)"
   have C\<pi>x: "C\<pi> *\<^sub>V (ket x) = (case \<pi> x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)" for x
     unfolding C\<pi>_def using \<open>classical_operator_exists \<pi>\<close> by (rule classical_operator_ket)
   have C\<rho>x: "C\<rho> *\<^sub>V (ket x) = (case \<rho> x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)" for x
     unfolding C\<rho>_def using \<open>classical_operator_exists \<rho>\<close> by (rule classical_operator_ket)
   have C\<pi>\<rho>x': "(C\<pi> o\<^sub>C\<^sub>L C\<rho>) *\<^sub>V (ket x) = (case (\<pi> \<circ>\<^sub>m \<rho>) x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)" for x
     apply (simp add: scaleC_cblinfun.rep_eq C\<rho>x)
     apply (cases "\<rho> x")
     by (auto simp: C\<pi>x)
   thus \<open>classical_operator_exists (\<pi> \<circ>\<^sub>m \<rho>)\<close>
     by (rule classical_operator_existsI)
   hence "C\<pi>\<rho> *\<^sub>V (ket x) = (case (\<pi> \<circ>\<^sub>m \<rho>) x of Some i \<Rightarrow> ket i | None \<Rightarrow> 0)" for x
     unfolding C\<pi>\<rho>_def
     by (rule classical_operator_ket)
   with C\<pi>\<rho>x' have "(C\<pi> o\<^sub>C\<^sub>L C\<rho>) *\<^sub>V (ket x) = C\<pi>\<rho> *\<^sub>V (ket x)" for x
     by simp
   thus "C\<pi> o\<^sub>C\<^sub>L C\<rho> = C\<pi>\<rho>"
     by (simp add: equal_ket)
 qed
 
 lemma classical_operator_Some[simp]: "classical_operator (Some::'a\<Rightarrow>_) = id_cblinfun"
 proof-
   have "(classical_operator Some) *\<^sub>V (ket i)  = id_cblinfun *\<^sub>V (ket i)"
     for i::'a
     apply (subst classical_operator_ket)
      apply (rule classical_operator_exists_inj)
     by auto
   thus ?thesis
     using equal_ket[where A = "classical_operator (Some::'a \<Rightarrow> _ option)"
         and B = "id_cblinfun::'a ell2 \<Rightarrow>\<^sub>C\<^sub>L _"]
     by blast
 qed
 
 lemma isometry_classical_operator[simp]:
   fixes \<pi>::"'a \<Rightarrow> 'b"
   assumes a1: "inj \<pi>"
   shows "isometry (classical_operator (Some o \<pi>))"
 proof -
   have b0: "inj_map (Some \<circ> \<pi>)"
     by (simp add: a1)
   have b0': "inj_map (inv_map (Some \<circ> \<pi>))"
     by simp
   have b1: "inv_map (Some \<circ> \<pi>) \<circ>\<^sub>m (Some \<circ> \<pi>) = Some" 
     apply (rule ext) unfolding inv_map_def o_def 
     using assms unfolding inj_def inv_def by auto
   have b3: "classical_operator (inv_map (Some \<circ> \<pi>)) o\<^sub>C\<^sub>L
             classical_operator (Some \<circ> \<pi>) = classical_operator (inv_map (Some \<circ> \<pi>) \<circ>\<^sub>m (Some \<circ> \<pi>))"
     by (metis b0 b0' b1 classical_operator_Some classical_operator_exists_inj 
         classical_operator_mult)
   show ?thesis
     unfolding isometry_def
     apply (subst classical_operator_adjoint)
     using b0 by (auto simp add: b1 b3)
 qed
 
 lemma unitary_classical_operator[simp]:
   fixes \<pi>::"'a \<Rightarrow> 'b"
   assumes a1: "bij \<pi>"
   shows "unitary (classical_operator (Some o \<pi>))"
 proof (unfold unitary_def, rule conjI)
   have "inj \<pi>"
     using a1 bij_betw_imp_inj_on by auto
   hence "isometry (classical_operator (Some o \<pi>))"
     by simp
   hence "classical_operator (Some \<circ> \<pi>)* o\<^sub>C\<^sub>L classical_operator (Some \<circ> \<pi>) = id_cblinfun"
     unfolding isometry_def by simp
   thus \<open>classical_operator (Some \<circ> \<pi>)* o\<^sub>C\<^sub>L classical_operator (Some \<circ> \<pi>) = id_cblinfun\<close>
     by simp 
 next
   have "inj \<pi>"
     by (simp add: assms bij_is_inj)
   have comp: "Some \<circ> \<pi> \<circ>\<^sub>m inv_map (Some \<circ> \<pi>) = Some"
     apply (rule ext)
     unfolding inv_map_def o_def map_comp_def
     unfolding inv_def apply auto
      apply (metis \<open>inj \<pi>\<close> inv_def inv_f_f)
     using bij_def image_iff range_eqI
     by (metis a1)
   have "classical_operator (Some \<circ> \<pi>) o\<^sub>C\<^sub>L classical_operator (Some \<circ> \<pi>)*
       = classical_operator (Some \<circ> \<pi>) o\<^sub>C\<^sub>L classical_operator (inv_map (Some \<circ> \<pi>))"
     by (simp add: \<open>inj \<pi>\<close>)
   also have "\<dots> = classical_operator ((Some \<circ> \<pi>) \<circ>\<^sub>m (inv_map (Some \<circ> \<pi>)))"
     by (simp add: \<open>inj \<pi>\<close> classical_operator_exists_inj)
   also have "\<dots> = classical_operator (Some::'b\<Rightarrow>_)"
     using comp
     by simp 
   also have "\<dots> = (id_cblinfun:: 'b ell2 \<Rightarrow>\<^sub>C\<^sub>L _)"
     by simp
   finally show "classical_operator (Some \<circ> \<pi>) o\<^sub>C\<^sub>L classical_operator (Some \<circ> \<pi>)* = id_cblinfun".
 qed
 
 
 unbundle no_lattice_syntax
 unbundle no_cblinfun_notation
 
 end
diff --git a/thys/Complex_Bounded_Operators/Complex_Vector_Spaces.thy b/thys/Complex_Bounded_Operators/Complex_Vector_Spaces.thy
--- a/thys/Complex_Bounded_Operators/Complex_Vector_Spaces.thy
+++ b/thys/Complex_Bounded_Operators/Complex_Vector_Spaces.thy
@@ -1,3125 +1,3158 @@
 section \<open>\<open>Complex_Vector_Spaces\<close> -- Complex Vector Spaces\<close>
 
 (*
 Authors:
 
   Dominique Unruh, University of Tartu, unruh@ut.ee
   Jose Manuel Rodriguez Caballero, University of Tartu, jose.manuel.rodriguez.caballero@ut.ee
 *)
 
 theory Complex_Vector_Spaces
   imports
     "HOL-Analysis.Elementary_Topology"
     "HOL-Analysis.Operator_Norm"
     "HOL-Analysis.Elementary_Normed_Spaces"
     "HOL-Library.Set_Algebras"
     "HOL-Analysis.Starlike"
     "HOL-Types_To_Sets.Types_To_Sets"
     "HOL-Library.Complemented_Lattices"
 
     Extra_Vector_Spaces
     Extra_Ordered_Fields
     Extra_Operator_Norm
     Extra_General
 
     Complex_Vector_Spaces0
 begin
 
 bundle notation_norm begin
 notation norm ("\<parallel>_\<parallel>")
 end
 
 unbundle lattice_syntax
 
 subsection \<open>Misc\<close>
 
 
 (* Should rather be in Extra_Vector_Spaces but then complex_vector.span_image_scale' does not exist for some reason.
    Ideally this would replace Vector_Spaces.vector_space.span_image_scale. *)
 lemma (in vector_space) span_image_scale':
   \<comment> \<open>Strengthening of @{thm [source] vector_space.span_image_scale} without the condition \<open>finite S\<close>\<close>
   assumes nz: "\<And>x. x \<in> S \<Longrightarrow> c x \<noteq> 0"
   shows "span ((\<lambda>x. c x *s x) ` S) = span S"
 proof
   have \<open>((\<lambda>x. c x *s x) ` S) \<subseteq> span S\<close>
     by (metis (mono_tags, lifting) image_subsetI in_mono local.span_superset local.subspace_scale local.subspace_span)
   then show \<open>span ((\<lambda>x. c x *s x) ` S) \<subseteq> span S\<close>
     by (simp add: local.span_minimal)
 next
   have \<open>x \<in> span ((\<lambda>x. c x *s x) ` S)\<close> if \<open>x \<in> S\<close> for x
   proof -
     have \<open>x = inverse (c x) *s c x *s x\<close>
       by (simp add: nz that)
     moreover have \<open>c x *s x \<in> (\<lambda>x. c x *s x) ` S\<close>
       using that by blast
     ultimately show ?thesis
       by (metis local.span_base local.span_scale)
   qed
   then show \<open>span S \<subseteq> span ((\<lambda>x. c x *s x) ` S)\<close>
     by (simp add: local.span_minimal subsetI)
 qed
 
 lemma (in scaleC) scaleC_real: assumes "r\<in>\<real>" shows "r *\<^sub>C x = Re r *\<^sub>R x"
   unfolding scaleR_scaleC using assms by simp
 
 lemma of_complex_of_real_eq [simp]: "of_complex (of_real n) = of_real n"
   unfolding of_complex_def of_real_def unfolding scaleR_scaleC by simp
 
 lemma Complexs_of_real [simp]: "of_real r \<in> \<complex>"
   unfolding Complexs_def of_real_def of_complex_def
   apply (subst scaleR_scaleC) by simp
 
 lemma Reals_in_Complexs: "\<real> \<subseteq> \<complex>"
   unfolding Reals_def by auto
 
 lemma (in bounded_clinear) bounded_linear: "bounded_linear f"
   by standard
 
 lemma clinear_times: "clinear (\<lambda>x. c * x)"
   for c :: "'a::complex_algebra"
   by (auto simp: clinearI distrib_left)
 
 lemma (in clinear) linear: \<open>linear f\<close>
   by standard
 
 lemma bounded_clinearI:
   assumes \<open>\<And>b1 b2. f (b1 + b2) = f b1 + f b2\<close>
   assumes \<open>\<And>r b. f (r *\<^sub>C b) = r *\<^sub>C f b\<close>
   assumes \<open>\<And>x. norm (f x) \<le> norm x * K\<close>
   shows "bounded_clinear f"
   using assms by (auto intro!: exI bounded_clinear.intro clinearI simp: bounded_clinear_axioms_def)
 
 lemma bounded_clinear_id[simp]: \<open>bounded_clinear id\<close>
   by (simp add: id_def)
 
 definition cbilinear :: \<open>('a::complex_vector \<Rightarrow> 'b::complex_vector \<Rightarrow> 'c::complex_vector) \<Rightarrow> bool\<close>
   where \<open>cbilinear = (\<lambda> f. (\<forall> y. clinear (\<lambda> x. f x y)) \<and> (\<forall> x. clinear (\<lambda> y. f x y)) )\<close>
 
 lemma cbilinear_add_left:
   assumes \<open>cbilinear f\<close>
   shows \<open>f (a + b) c = f a c + f b c\<close>
   by (smt (verit, del_insts) assms cbilinear_def complex_vector.linear_add)
 
 lemma cbilinear_add_right:
   assumes \<open>cbilinear f\<close>
   shows \<open>f a (b + c) = f a b + f a c\<close>
   by (smt (verit, del_insts) assms cbilinear_def complex_vector.linear_add)
 
 lemma cbilinear_times:
   fixes g' :: \<open>'a::complex_vector \<Rightarrow> complex\<close> and g :: \<open>'b::complex_vector \<Rightarrow> complex\<close>
   assumes \<open>\<And> x y. h x y = (g' x)*(g y)\<close> and \<open>clinear g\<close> and \<open>clinear g'\<close>
   shows \<open>cbilinear h\<close>
 proof -
   have w1: "h (b1 + b2) y = h b1 y + h b2 y"
     for b1 :: 'a
       and b2 :: 'a
       and y
   proof-
     have \<open>h (b1 + b2) y = g' (b1 + b2) * g y\<close>
       using \<open>\<And> x y. h x y = (g' x)*(g y)\<close>
       by auto
     also have \<open>\<dots> = (g' b1 + g' b2) * g y\<close>
       using \<open>clinear g'\<close>
       unfolding clinear_def
       by (simp add: assms(3) complex_vector.linear_add)
     also have \<open>\<dots> = g' b1 * g y + g' b2 * g y\<close>
       by (simp add: ring_class.ring_distribs(2))
     also have \<open>\<dots> = h b1 y + h b2 y\<close>
       using assms(1) by auto
     finally show ?thesis by blast
   qed
   have w2: "h (r *\<^sub>C b) y = r *\<^sub>C h b y"
     for r :: complex
       and b :: 'a
       and y
   proof-
     have \<open>h (r *\<^sub>C b) y = g' (r *\<^sub>C b) * g y\<close>
       by (simp add: assms(1))
     also have \<open>\<dots> = r *\<^sub>C (g' b * g y)\<close>
       by (simp add: assms(3) complex_vector.linear_scale)
     also have \<open>\<dots> = r *\<^sub>C (h b y)\<close>
       by (simp add: assms(1))
     finally show ?thesis by blast
   qed
   have "clinear (\<lambda>x. h x y)"
     for y :: 'b
     unfolding clinear_def
     by (meson clinearI clinear_def w1 w2)
   hence t2: "\<forall>y. clinear (\<lambda>x. h x y)"
     by simp
   have v1: "h x (b1 + b2) = h x b1 + h x b2"
     for b1 :: 'b
       and b2 :: 'b
       and x
   proof-
     have \<open>h x (b1 + b2)  = g' x * g (b1 + b2)\<close>
       using \<open>\<And> x y. h x y = (g' x)*(g y)\<close>
       by auto
     also have \<open>\<dots> = g' x * (g b1 + g b2)\<close>
       using \<open>clinear g'\<close>
       unfolding clinear_def
       by (simp add: assms(2) complex_vector.linear_add)
     also have \<open>\<dots> = g' x * g b1 + g' x * g b2\<close>
       by (simp add: ring_class.ring_distribs(1))
     also have \<open>\<dots> = h x b1 + h x b2\<close>
       using assms(1) by auto
     finally show ?thesis by blast
   qed
 
   have v2:  "h x (r *\<^sub>C b) = r *\<^sub>C h x b"
     for r :: complex
       and b :: 'b
       and x
   proof-
     have \<open>h x (r *\<^sub>C b) =  g' x * g (r *\<^sub>C b)\<close>
       by (simp add: assms(1))
     also have \<open>\<dots> = r *\<^sub>C (g' x * g b)\<close>
       by (simp add: assms(2) complex_vector.linear_scale)
     also have \<open>\<dots> = r *\<^sub>C (h x b)\<close>
       by (simp add: assms(1))
     finally show ?thesis by blast
   qed
   have "Vector_Spaces.linear (*\<^sub>C) (*\<^sub>C) (h x)"
     for x :: 'a
     using v1 v2
     by (meson clinearI clinear_def)
   hence t1: "\<forall>x. clinear (h x)"
     unfolding clinear_def
     by simp
   show ?thesis
     unfolding cbilinear_def
     by (simp add: t1 t2)
 qed
 
 lemma csubspace_is_subspace: "csubspace A \<Longrightarrow> subspace A"
   apply (rule subspaceI)
   by (auto simp: complex_vector.subspace_def scaleR_scaleC)
 
 lemma span_subset_cspan: "span A \<subseteq> cspan A"
   unfolding span_def complex_vector.span_def
   by (simp add: csubspace_is_subspace hull_antimono)
 
 
 lemma cindependent_implies_independent:
   assumes "cindependent (S::'a::complex_vector set)"
   shows "independent S"
   using assms unfolding dependent_def complex_vector.dependent_def
   using span_subset_cspan by blast
 
 lemma cspan_singleton: "cspan {x} = {\<alpha> *\<^sub>C x| \<alpha>. True}"
 proof -
   have \<open>cspan {x} = {y. y\<in>cspan {x}}\<close>
     by auto
   also have \<open>\<dots> = {\<alpha> *\<^sub>C x| \<alpha>. True}\<close>
     apply (subst complex_vector.span_breakdown_eq)
     by auto
   finally show ?thesis
     by -
 qed
 
 
 lemma cspan_as_span:
   "cspan (B::'a::complex_vector set) = span (B \<union> scaleC \<i> ` B)"
 proof auto
   let ?cspan = complex_vector.span
   let ?rspan = real_vector.span
   fix \<psi>
   assume cspan: "\<psi> \<in> ?cspan B"
   have "\<exists>B' r. finite B' \<and> B' \<subseteq> B \<and> \<psi> = (\<Sum>b\<in>B'. r b *\<^sub>C b)"
     using complex_vector.span_explicit[of B] cspan
     by auto
   then obtain B' r where "finite B'" and "B' \<subseteq> B" and \<psi>_explicit: "\<psi> = (\<Sum>b\<in>B'. r b *\<^sub>C b)"
     by atomize_elim
   define R where "R = B \<union> scaleC \<i> ` B"
 
   have x2: "(case x of (b, i) \<Rightarrow> if i
             then Im (r b) *\<^sub>R \<i> *\<^sub>C b
             else Re (r b) *\<^sub>R b) \<in> span (B \<union> (*\<^sub>C) \<i> ` B)"
     if "x \<in> B' \<times> (UNIV::bool set)"
     for x :: "'a \<times> bool"
     using that \<open>B' \<subseteq> B\<close> by (auto simp add: real_vector.span_base real_vector.span_scale subset_iff)
   have x1: "\<psi> = (\<Sum>x\<in>B'. \<Sum>i\<in>UNIV. if i then Im (r x) *\<^sub>R \<i> *\<^sub>C x else Re (r x) *\<^sub>R x)"
     if "\<And>b. r b *\<^sub>C b = Re (r b) *\<^sub>R b + Im (r b) *\<^sub>R \<i> *\<^sub>C b"
     using that by (simp add: UNIV_bool \<psi>_explicit)
   moreover have "r b *\<^sub>C b = Re (r b) *\<^sub>R b + Im (r b) *\<^sub>R \<i> *\<^sub>C b" for b
     using complex_eq scaleC_add_left scaleC_scaleC scaleR_scaleC
     by (metis (no_types, lifting) complex_of_real_i i_complex_of_real)
   ultimately have "\<psi> = (\<Sum>(b,i)\<in>(B'\<times>UNIV). if i then Im (r b) *\<^sub>R (\<i> *\<^sub>C b) else Re (r b) *\<^sub>R b)"
     by (simp add: sum.cartesian_product)
   also have "\<dots> \<in> ?rspan R"
     unfolding R_def
     using x2
     by (rule real_vector.span_sum)
   finally show "\<psi> \<in> ?rspan R" by -
 next
   let ?cspan = complex_vector.span
   let ?rspan = real_vector.span
   define R where "R = B \<union> scaleC \<i> ` B"
   fix \<psi>
   assume rspan: "\<psi> \<in> ?rspan R"
   have "subspace {a. a \<in> cspan B}"
     by (rule real_vector.subspaceI, auto simp add: complex_vector.span_zero
         complex_vector.span_add_eq2 complex_vector.span_scale scaleR_scaleC)
   moreover have "x \<in> cspan B"
     if "x \<in> R"
     for x :: 'a
     using that R_def complex_vector.span_base complex_vector.span_scale by fastforce
   ultimately show "\<psi> \<in> ?cspan B"
     using real_vector.span_induct rspan by blast
 qed
 
 
 lemma isomorphic_equal_cdim:
   assumes lin_f: \<open>clinear f\<close>
   assumes inj_f: \<open>inj_on f (cspan S)\<close>
   assumes im_S: \<open>f ` S = T\<close>
   shows \<open>cdim S = cdim T\<close>
 proof -
   obtain SB where SB_span: "cspan SB = cspan S" and indep_SB: \<open>cindependent SB\<close>
     by (metis complex_vector.basis_exists complex_vector.span_mono complex_vector.span_span subset_antisym)
   with lin_f inj_f have indep_fSB: \<open>cindependent (f ` SB)\<close>
     apply (rule_tac complex_vector.linear_independent_injective_image)
     by auto
   from lin_f have \<open>cspan (f ` SB) = f ` cspan SB\<close>
     by (meson complex_vector.linear_span_image)
   also from SB_span lin_f have \<open>\<dots> = cspan T\<close>
     by (metis complex_vector.linear_span_image im_S)
   finally have \<open>cdim T = card (f ` SB)\<close>
     using indep_fSB complex_vector.dim_eq_card by blast
   also have \<open>\<dots> = card SB\<close>
     apply (rule card_image) using inj_f
     by (metis SB_span complex_vector.linear_inj_on_span_iff_independent_image indep_fSB lin_f)
   also have \<open>\<dots> = cdim S\<close>
     using indep_SB SB_span
     by (metis complex_vector.dim_eq_card)
   finally show ?thesis by simp
 qed
 
 
 lemma cindependent_inter_scaleC_cindependent:
   assumes a1: "cindependent (B::'a::complex_vector set)" and a3: "c \<noteq> 1"
   shows "B \<inter> (*\<^sub>C) c ` B = {}"
 proof (rule classical, cases \<open>c = 0\<close>)
   case True
   then show ?thesis
     using a1 by (auto simp add: complex_vector.dependent_zero)
 next
   case False
   assume "\<not>(B \<inter> (*\<^sub>C) c ` B = {})"
   hence "B \<inter> (*\<^sub>C) c ` B \<noteq> {}"
     by blast
   then obtain x where u1: "x \<in> B \<inter> (*\<^sub>C) c ` B"
     by blast
   then obtain b where u2: "x = b" and u3: "b\<in>B"
     by blast
   then  obtain b' where u2': "x = c *\<^sub>C b'" and u3': "b'\<in>B"
     using u1
     by blast
   have g1: "b = c *\<^sub>C b'"
     using u2 and u2' by simp
   hence "b \<in> complex_vector.span {b'}"
     using False
     by (simp add: complex_vector.span_base complex_vector.span_scale)
   hence "b = b'"
     by (metis  u3' a1 complex_vector.dependent_def complex_vector.span_base
         complex_vector.span_scale insertE insert_Diff u2 u2' u3)
   hence "b' = c *\<^sub>C b'"
     using g1 by blast
   thus ?thesis
     by (metis a1 a3 complex_vector.dependent_zero complex_vector.scale_right_imp_eq
         mult_cancel_right2 scaleC_scaleC u3')
 qed
 
 lemma real_independent_from_complex_independent:
   assumes "cindependent (B::'a::complex_vector set)"
   defines "B' == ((*\<^sub>C) \<i> ` B)"
   shows "independent (B \<union> B')"
 proof (rule notI)
   assume \<open>dependent (B \<union> B')\<close>
   then obtain T f0 x where [simp]: \<open>finite T\<close> and \<open>T \<subseteq> B \<union> B'\<close> and f0_sum: \<open>(\<Sum>v\<in>T. f0 v *\<^sub>R v) = 0\<close>
     and x: \<open>x \<in> T\<close> and f0_x: \<open>f0 x \<noteq> 0\<close>
     by (auto simp: real_vector.dependent_explicit)
   define f T1 T2 T' f' x' where \<open>f v = (if v \<in> T then f0 v else 0)\<close>
     and \<open>T1 = T \<inter> B\<close> and \<open>T2 = scaleC (-\<i>) ` (T \<inter> B')\<close>
     and \<open>T' = T1 \<union> T2\<close> and \<open>f' v = f v + \<i> * f (\<i> *\<^sub>C v)\<close>
     and \<open>x' = (if x \<in> T1 then x else -\<i> *\<^sub>C x)\<close> for v
   have \<open>B \<inter> B' = {}\<close>
     by (simp add: assms cindependent_inter_scaleC_cindependent)
   have \<open>T' \<subseteq> B\<close>
     by (auto simp: T'_def T1_def T2_def B'_def)
   have [simp]: \<open>finite T'\<close> \<open>finite T1\<close> \<open>finite T2\<close>
     by (auto simp add: T'_def T1_def T2_def)
   have f_sum: \<open>(\<Sum>v\<in>T. f v *\<^sub>R v) = 0\<close>
     unfolding f_def using f0_sum by auto
   have f_x: \<open>f x \<noteq> 0\<close>
     using f0_x x by (auto simp: f_def)
   have f'_sum: \<open>(\<Sum>v\<in>T'. f' v *\<^sub>C v) = 0\<close>
   proof -
     have \<open>(\<Sum>v\<in>T'. f' v *\<^sub>C v) = (\<Sum>v\<in>T'. complex_of_real (f v) *\<^sub>C v) + (\<Sum>v\<in>T'. (\<i> * complex_of_real (f (\<i> *\<^sub>C v))) *\<^sub>C v)\<close>
       by (auto simp: f'_def sum.distrib scaleC_add_left)
     also have \<open>(\<Sum>v\<in>T'. complex_of_real (f v) *\<^sub>C v) = (\<Sum>v\<in>T1. f v *\<^sub>R v)\<close> (is \<open>_ = ?left\<close>)
       apply (auto simp: T'_def scaleR_scaleC intro!: sum.mono_neutral_cong_right)
       using T'_def T1_def \<open>T' \<subseteq> B\<close> f_def by auto
     also have \<open>(\<Sum>v\<in>T'. (\<i> * complex_of_real (f (\<i> *\<^sub>C v))) *\<^sub>C v) = (\<Sum>v\<in>T2. (\<i> * complex_of_real (f (\<i> *\<^sub>C v))) *\<^sub>C v)\<close> (is \<open>_ = ?right\<close>)
       apply (auto simp: T'_def intro!: sum.mono_neutral_cong_right)
       by (smt (z3) B'_def IntE IntI T1_def T2_def \<open>f \<equiv> \<lambda>v. if v \<in> T then f0 v else 0\<close> add.inverse_inverse complex_vector.vector_space_axioms i_squared imageI mult_minus_left vector_space.vector_space_assms(3) vector_space.vector_space_assms(4))
     also have \<open>?right = (\<Sum>v\<in>T\<inter>B'. f v *\<^sub>R v)\<close> (is \<open>_ = ?right\<close>)
       apply (rule sum.reindex_cong[symmetric, where l=\<open>scaleC \<i>\<close>])
         apply (auto simp: T2_def image_image scaleR_scaleC)
       using inj_on_def by fastforce
     also have \<open>?left + ?right = (\<Sum>v\<in>T. f v *\<^sub>R v)\<close>
       apply (subst sum.union_disjoint[symmetric])
       using \<open>B \<inter> B' = {}\<close> \<open>T \<subseteq> B \<union> B'\<close> apply (auto simp: T1_def)
       by (metis Int_Un_distrib Un_Int_eq(4) sup.absorb_iff1)
     also have \<open>\<dots> = 0\<close>
       by (rule f_sum)
     finally show ?thesis
       by -
   qed
 
   have x': \<open>x' \<in> T'\<close>
     using \<open>T \<subseteq> B \<union> B'\<close> x by (auto simp: x'_def T'_def T1_def T2_def)
 
   have f'_x': \<open>f' x' \<noteq> 0\<close>
     using Complex_eq Complex_eq_0 f'_def f_x x'_def by auto
 
   from \<open>finite T'\<close> \<open>T' \<subseteq> B\<close> f'_sum x' f'_x'
   have \<open>cdependent B\<close>
     using complex_vector.independent_explicit_module by blast
   with assms show False
     by auto
 qed
 
 lemma crepresentation_from_representation:
   assumes a1: "cindependent B" and a2: "b \<in> B" and a3: "finite B"
   shows "crepresentation B \<psi> b = (representation (B \<union> (*\<^sub>C) \<i> ` B) \<psi> b)
                            + \<i> *\<^sub>C (representation (B \<union> (*\<^sub>C) \<i> ` B) \<psi> (\<i> *\<^sub>C b))"
 proof (cases "\<psi> \<in> cspan B")
   define B' where "B' = B \<union> (*\<^sub>C) \<i> ` B"
   case True
   define r  where "r v = real_vector.representation B' \<psi> v" for v
   define r' where "r' v = real_vector.representation B' \<psi> (\<i> *\<^sub>C v)" for v
   define f  where "f v = r v + \<i> *\<^sub>C r' v" for v
   define g  where "g v = crepresentation B \<psi> v" for v
   have "(\<Sum>v | g v \<noteq> 0. g v *\<^sub>C v) = \<psi>"
     unfolding g_def
     using Collect_cong Collect_mono_iff DiffD1 DiffD2 True a1
       complex_vector.finite_representation
       complex_vector.sum_nonzero_representation_eq sum.mono_neutral_cong_left
     by fastforce
   moreover have "finite {v. g v \<noteq> 0}"
     unfolding g_def
     by (simp add: complex_vector.finite_representation)
   moreover have "v \<in> B"
     if "g v \<noteq> 0" for v
     using that unfolding g_def
     by (simp add: complex_vector.representation_ne_zero)
   ultimately have rep1: "(\<Sum>v\<in>B. g v *\<^sub>C v) = \<psi>"
     unfolding g_def
     using a3 True a1 complex_vector.sum_representation_eq by blast
   have l0': "inj ((*\<^sub>C) \<i>::'a \<Rightarrow>'a)"
     unfolding inj_def
     by simp
   have l0: "inj ((*\<^sub>C) (- \<i>)::'a \<Rightarrow>'a)"
     unfolding inj_def
     by simp
   have l1: "(*\<^sub>C) (- \<i>) ` B \<inter> B = {}"
     using cindependent_inter_scaleC_cindependent[where B=B and c = "- \<i>"]
     by (metis Int_commute a1 add.inverse_inverse complex_i_not_one i_squared mult_cancel_left1
         neg_equal_0_iff_equal)
   have l2: "B \<inter> (*\<^sub>C) \<i> ` B = {}"
     by (simp add: a1 cindependent_inter_scaleC_cindependent)
   have rr1: "r (\<i> *\<^sub>C v) = r' v" for v
     unfolding r_def r'_def
     by simp
   have k1: "independent B'"
     unfolding B'_def using a1 real_independent_from_complex_independent by simp
   have "\<psi> \<in> span B'"
     using B'_def True cspan_as_span by blast
   have "v \<in> B'"
     if "r v \<noteq> 0"
     for v
     unfolding r_def
     using r_def real_vector.representation_ne_zero that by auto
   have "finite B'"
     unfolding B'_def using a3
     by simp
   have "(\<Sum>v\<in>B'. r v *\<^sub>R v) = \<psi>"
     unfolding r_def
     using True  Real_Vector_Spaces.real_vector.sum_representation_eq[where B = B' and basis = B'
         and v = \<psi>]
     by (smt Real_Vector_Spaces.dependent_raw_def \<open>\<psi> \<in> Real_Vector_Spaces.span B'\<close> \<open>finite B'\<close>
         equalityD2 k1)
   have d1: "(\<Sum>v\<in>B. r (\<i> *\<^sub>C v) *\<^sub>R (\<i> *\<^sub>C v)) = (\<Sum>v\<in>(*\<^sub>C) \<i> ` B. r v *\<^sub>R v)"
     using l0'
     by (metis (mono_tags, lifting) inj_eq inj_on_def sum.reindex_cong)
   have "(\<Sum>v\<in>B. (r v + \<i> * (r' v)) *\<^sub>C v) = (\<Sum>v\<in>B. r v *\<^sub>C v + (\<i> * r' v) *\<^sub>C v)"
     by (meson scaleC_left.add)
   also have "\<dots> = (\<Sum>v\<in>B. r v *\<^sub>C v) + (\<Sum>v\<in>B. (\<i> * r' v) *\<^sub>C v)"
     using sum.distrib by fastforce
   also have "\<dots> = (\<Sum>v\<in>B. r v *\<^sub>C v) + (\<Sum>v\<in>B. \<i> *\<^sub>C (r' v *\<^sub>C v))"
     by auto
   also have "\<dots> = (\<Sum>v\<in>B. r v *\<^sub>R v) + (\<Sum>v\<in>B. \<i> *\<^sub>C (r (\<i> *\<^sub>C v) *\<^sub>R v))"
     unfolding r'_def r_def
     by (metis (mono_tags, lifting) scaleR_scaleC sum.cong)
   also have "\<dots> = (\<Sum>v\<in>B. r v *\<^sub>R v) + (\<Sum>v\<in>B. r (\<i> *\<^sub>C v) *\<^sub>R (\<i> *\<^sub>C v))"
     by (metis (no_types, lifting) complex_vector.scale_left_commute scaleR_scaleC)
   also have "\<dots> = (\<Sum>v\<in>B. r v *\<^sub>R v) + (\<Sum>v\<in>(*\<^sub>C) \<i> ` B. r v *\<^sub>R v)"
     using d1
     by simp
   also have "\<dots> = \<psi>"
     using l2 \<open>(\<Sum>v\<in>B'. r v *\<^sub>R v) = \<psi>\<close>
     unfolding B'_def
     by (simp add: a3 sum.union_disjoint)
   finally have "(\<Sum>v\<in>B. f v *\<^sub>C v) = \<psi>" unfolding r'_def r_def f_def by simp
   hence "0 = (\<Sum>v\<in>B. f v *\<^sub>C v) - (\<Sum>v\<in>B. crepresentation B \<psi> v *\<^sub>C v)"
     using rep1
     unfolding g_def
     by simp
   also have "\<dots> = (\<Sum>v\<in>B. f v *\<^sub>C v - crepresentation B \<psi> v *\<^sub>C v)"
     by (simp add: sum_subtractf)
   also have "\<dots> = (\<Sum>v\<in>B. (f v - crepresentation B \<psi> v) *\<^sub>C v)"
     by (metis scaleC_left.diff)
   finally have "0 = (\<Sum>v\<in>B. (f v - crepresentation B \<psi> v) *\<^sub>C v)".
   hence "(\<Sum>v\<in>B. (f v - crepresentation B \<psi> v) *\<^sub>C v) = 0"
     by simp
   hence "f b - crepresentation B \<psi> b = 0"
     using a1 a2 a3 complex_vector.independentD[where s = B and t = B
         and u = "\<lambda>v. f v - crepresentation B \<psi> v" and v = b]
       order_refl  by smt
   hence "crepresentation B \<psi> b = f b"
     by simp
   thus ?thesis unfolding f_def r_def r'_def B'_def by auto
 next
   define B' where "B' = B \<union> (*\<^sub>C) \<i> ` B"
   case False
   have b2: "\<psi> \<notin> real_vector.span B'"
     unfolding B'_def
     using False cspan_as_span by auto
   have "\<psi> \<notin> complex_vector.span B"
     using False by blast
   have "crepresentation B \<psi> b = 0"
     unfolding complex_vector.representation_def
     by (simp add: False)
   moreover have "real_vector.representation B' \<psi> b = 0"
     unfolding real_vector.representation_def
     by (simp add: b2)
   moreover have "real_vector.representation B' \<psi> ((*\<^sub>C) \<i> b) = 0"
     unfolding real_vector.representation_def
     by (simp add: b2)
   ultimately show ?thesis unfolding B'_def by simp
 qed
 
 
 lemma CARD_1_vec_0[simp]: \<open>(\<psi> :: _ ::{complex_vector,CARD_1}) = 0\<close>
   by auto
 
 
 lemma scaleC_cindependent:
   assumes a1: "cindependent (B::'a::complex_vector set)" and a3: "c \<noteq> 0"
   shows "cindependent ((*\<^sub>C) c ` B)"
 proof-
   have "u y = 0"
     if g1: "y\<in>S" and g2: "(\<Sum>x\<in>S. u x *\<^sub>C x) = 0" and g3: "finite S" and g4: "S\<subseteq>(*\<^sub>C) c ` B"
     for u y S
   proof-
     define v where "v x = u (c *\<^sub>C x)" for x
     obtain S' where "S'\<subseteq>B" and S_S': "S = (*\<^sub>C) c ` S'"
       by (meson g4 subset_imageE)
     have "inj ((*\<^sub>C) c::'a\<Rightarrow>_)"
       unfolding inj_def
       using a3 by auto
     hence "finite S'"
       using S_S' finite_imageD g3 subset_inj_on by blast
     have "t \<in> (*\<^sub>C) (inverse c) ` S"
       if "t \<in> S'" for t
     proof-
       have "c *\<^sub>C t \<in> S"
         using \<open>S = (*\<^sub>C) c ` S'\<close> that by blast
       hence "(inverse c) *\<^sub>C (c *\<^sub>C t) \<in> (*\<^sub>C) (inverse c) ` S"
         by blast
       moreover have "(inverse c) *\<^sub>C (c *\<^sub>C t) = t"
         by (simp add: a3)
       ultimately show ?thesis by simp
     qed
     moreover have "t \<in> S'"
       if "t \<in> (*\<^sub>C) (inverse c) ` S" for t
     proof-
       obtain t' where "t = (inverse c) *\<^sub>C t'" and "t' \<in> S"
         using \<open>t \<in> (*\<^sub>C) (inverse c) ` S\<close> by auto
       have "c *\<^sub>C t = c *\<^sub>C ((inverse c) *\<^sub>C t')"
         using \<open>t = (inverse c) *\<^sub>C t'\<close> by simp
       also have "\<dots> = (c * (inverse c)) *\<^sub>C t'"
         by simp
       also have "\<dots> = t'"
         by (simp add: a3)
       finally have "c *\<^sub>C t = t'".
       thus ?thesis using \<open>t' \<in> S\<close>
         using \<open>S = (*\<^sub>C) c ` S'\<close> a3 complex_vector.scale_left_imp_eq by blast
     qed
     ultimately have "S' = (*\<^sub>C) (inverse c) ` S"
       by blast
     hence "inverse c *\<^sub>C y \<in> S'"
       using that(1) by blast
     have t: "inj (((*\<^sub>C) c)::'a \<Rightarrow> _)"
       using a3 complex_vector.injective_scale[where c = c]
       by blast
     have "0 = (\<Sum>x\<in>(*\<^sub>C) c ` S'. u x *\<^sub>C x)"
       using \<open>S = (*\<^sub>C) c ` S'\<close> that(2) by auto
     also have "\<dots> = (\<Sum>x\<in>S'. v x *\<^sub>C (c *\<^sub>C x))"
       unfolding v_def
       using t Groups_Big.comm_monoid_add_class.sum.reindex[where h = "((*\<^sub>C) c)" and A = S'
           and g = "\<lambda>x. u x *\<^sub>C x"] subset_inj_on by auto
     also have "\<dots> = c *\<^sub>C (\<Sum>x\<in>S'. v x *\<^sub>C x)"
       by (metis (mono_tags, lifting) complex_vector.scale_left_commute scaleC_right.sum sum.cong)
     finally have "0 = c *\<^sub>C (\<Sum>x\<in>S'. v x *\<^sub>C x)".
     hence "(\<Sum>x\<in>S'. v x *\<^sub>C x) = 0"
       using a3 by auto
     hence "v (inverse c *\<^sub>C y) = 0"
       using \<open>inverse c *\<^sub>C y \<in> S'\<close> \<open>finite S'\<close> \<open>S' \<subseteq> B\<close> a1
         complex_vector.independentD
       by blast
     thus "u y = 0"
       unfolding v_def
       by (simp add: a3)
   qed
   thus ?thesis
     using complex_vector.dependent_explicit
     by (simp add: complex_vector.dependent_explicit )
 qed
 
 lemma cspan_eqI:
   assumes \<open>\<And>a. a\<in>A \<Longrightarrow> a\<in>cspan B\<close>
   assumes \<open>\<And>b. b\<in>B \<Longrightarrow> b\<in>cspan A\<close>
   shows \<open>cspan A = cspan B\<close>
   apply (rule complex_vector.span_subspace[rotated])
     apply (rule complex_vector.span_minimal)
   using assms by auto
 
 lemma (in bounded_cbilinear) bounded_bilinear[simp]: "bounded_bilinear prod"
   by standard
 
 subsection \<open>Antilinear maps and friends\<close>
 
 locale antilinear = additive f for f :: "'a::complex_vector \<Rightarrow> 'b::complex_vector" +
   assumes scaleC: "f (scaleC r x) = cnj r *\<^sub>C f x"
 
 sublocale antilinear \<subseteq> linear
 proof (rule linearI)
   show "f (b1 + b2) = f b1 + f b2"
     for b1 :: 'a
       and b2 :: 'a
     by (simp add: add)
   show "f (r *\<^sub>R b) = r *\<^sub>R f b"
     for r :: real
       and b :: 'a
     unfolding scaleR_scaleC by (subst scaleC, simp)
 qed
 
 lemma antilinear_imp_scaleC:
   fixes D :: "complex \<Rightarrow> 'a::complex_vector"
   assumes "antilinear D"
   obtains d where "D = (\<lambda>x. cnj x *\<^sub>C d)"
 proof -
   interpret clinear "D o cnj"
     apply standard apply auto
      apply (simp add: additive.add assms antilinear.axioms(1))
     using assms antilinear.scaleC by fastforce
   obtain d where "D o cnj = (\<lambda>x. x *\<^sub>C d)"
     using clinear_axioms complex_vector.linear_imp_scale by blast
   then have \<open>D = (\<lambda>x. cnj x *\<^sub>C d)\<close>
     by (metis comp_apply complex_cnj_cnj)
   then show ?thesis
     by (rule that)
 qed
 
 corollary complex_antilinearD:
   fixes f :: "complex \<Rightarrow> complex"
   assumes "antilinear f" obtains c where "f = (\<lambda>x. c * cnj x)"
   by (rule antilinear_imp_scaleC [OF assms]) (force simp: scaleC_conv_of_complex)
 
 lemma antilinearI:
   assumes "\<And>x y. f (x + y) = f x + f y"
     and "\<And>c x. f (c *\<^sub>C x) = cnj c *\<^sub>C f x"
   shows "antilinear f"
   by standard (rule assms)+
 
 lemma antilinear_o_antilinear: "antilinear f \<Longrightarrow> antilinear g \<Longrightarrow> clinear (g o f)"
   apply (rule clinearI)
    apply (simp add: additive.add antilinear_def)
   by (simp add: antilinear.scaleC)
 
 lemma clinear_o_antilinear: "antilinear f \<Longrightarrow> clinear g \<Longrightarrow> antilinear (g o f)"
   apply (rule antilinearI)
    apply (simp add: additive.add complex_vector.linear_add antilinear_def)
   by (simp add: complex_vector.linear_scale antilinear.scaleC)
 
 lemma antilinear_o_clinear: "clinear f \<Longrightarrow> antilinear g \<Longrightarrow> antilinear (g o f)"
   apply (rule antilinearI)
    apply (simp add: additive.add complex_vector.linear_add antilinear_def)
   by (simp add: complex_vector.linear_scale antilinear.scaleC)
 
 locale bounded_antilinear = antilinear f for f :: "'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector" +
   assumes bounded: "\<exists>K. \<forall>x. norm (f x) \<le> norm x * K"
 
 lemma bounded_antilinearI:
   assumes \<open>\<And>b1 b2. f (b1 + b2) = f b1 + f b2\<close>
   assumes \<open>\<And>r b. f (r *\<^sub>C b) = cnj r *\<^sub>C f b\<close>
   assumes \<open>\<forall>x. norm (f x) \<le> norm x * K\<close>
   shows "bounded_antilinear f"
   using assms by (auto intro!: exI bounded_antilinear.intro antilinearI simp: bounded_antilinear_axioms_def)
 
 sublocale bounded_antilinear \<subseteq> real: bounded_linear
   \<comment> \<open>Gives access to all lemmas from \<^locale>\<open>linear\<close> using prefix \<open>real.\<close>\<close>
   apply standard by (fact bounded)
 
 lemma (in bounded_antilinear) bounded_linear: "bounded_linear f"
   by (fact real.bounded_linear)
 
 lemma (in bounded_antilinear) antilinear: "antilinear f"
   by (fact antilinear_axioms)
 
 lemma bounded_antilinear_intro:
   assumes "\<And>x y. f (x + y) = f x + f y"
     and "\<And>r x. f (scaleC r x) = scaleC (cnj r) (f x)"
     and "\<And>x. norm (f x) \<le> norm x * K"
   shows "bounded_antilinear f"
   by standard (blast intro: assms)+
 
 lemma bounded_antilinear_0[simp]: \<open>bounded_antilinear (\<lambda>_. 0)\<close>
   by (rule bounded_antilinear_intro[where K=0], auto)
 
 lemma cnj_bounded_antilinear[simp]: "bounded_antilinear cnj"
   apply (rule bounded_antilinear_intro [where K = 1])
   by auto
 
 lemma bounded_antilinear_o_bounded_antilinear:
   assumes "bounded_antilinear f"
     and "bounded_antilinear g"
   shows "bounded_clinear (\<lambda>x. f (g x))"
 proof
   interpret f: bounded_antilinear f by fact
   interpret g: bounded_antilinear g by fact
   fix b1 b2 b r
   show "f (g (b1 + b2)) = f (g b1) + f (g b2)"
     by (simp add: f.add g.add)
   show "f (g (r *\<^sub>C b)) = r *\<^sub>C f (g b)"
     by (simp add: f.scaleC g.scaleC)
   have "bounded_linear (\<lambda>x. f (g x))"
     using f.bounded_linear g.bounded_linear by (rule bounded_linear_compose)
   then show "\<exists>K. \<forall>x. norm (f (g x)) \<le> norm x * K"
     by (rule bounded_linear.bounded)
 qed
 
 lemma bounded_antilinear_o_bounded_clinear:
   assumes "bounded_antilinear f"
     and "bounded_clinear g"
   shows "bounded_antilinear (\<lambda>x. f (g x))"
 proof
   interpret f: bounded_antilinear f by fact
   interpret g: bounded_clinear g by fact
   show "f (g (x + y)) = f (g x) + f (g y)" for x y
     by (simp only: f.add g.add)
   show "f (g (scaleC r x)) = scaleC (cnj r) (f (g x))" for r x
     by (simp add: f.scaleC g.scaleC)
   have "bounded_linear (\<lambda>x. f (g x))"
     using f.bounded_linear g.bounded_linear by (rule bounded_linear_compose)
   then show "\<exists>K. \<forall>x. norm (f (g x)) \<le> norm x * K"
     by (rule bounded_linear.bounded)
 qed
 
 lemma bounded_clinear_o_bounded_antilinear:
   assumes "bounded_clinear f"
     and "bounded_antilinear g"
   shows "bounded_antilinear (\<lambda>x. f (g x))"
 proof
   interpret f: bounded_clinear f by fact
   interpret g: bounded_antilinear g by fact
   show "f (g (x + y)) = f (g x) + f (g y)" for x y
     by (simp only: f.add g.add)
   show "f (g (scaleC r x)) = scaleC (cnj r) (f (g x))" for r x
     using f.scaleC g.scaleC by fastforce
   have "bounded_linear (\<lambda>x. f (g x))"
     using f.bounded_linear g.bounded_linear by (rule bounded_linear_compose)
   then show "\<exists>K. \<forall>x. norm (f (g x)) \<le> norm x * K"
     by (rule bounded_linear.bounded)
 qed
 
 lemma bij_clinear_imp_inv_clinear: "clinear (inv f)"
   if a1: "clinear f" and a2: "bij f"
 proof
   fix b1 b2 r b
   show "inv f (b1 + b2) = inv f b1 + inv f b2"
     by (simp add: a1 a2 bij_is_inj bij_is_surj complex_vector.linear_add inv_f_eq surj_f_inv_f)
   show "inv f (r *\<^sub>C b) = r *\<^sub>C inv f b"
     using that
     by (smt bij_inv_eq_iff clinear_def complex_vector.linear_scale)
 qed
 
 
 locale bounded_sesquilinear =
   fixes
     prod :: "'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector \<Rightarrow> 'c::complex_normed_vector"
       (infixl "**" 70)
   assumes add_left: "prod (a + a') b = prod a b + prod a' b"
     and add_right: "prod a (b + b') = prod a b + prod a b'"
     and scaleC_left: "prod (r *\<^sub>C a) b = (cnj r) *\<^sub>C (prod a b)"
     and scaleC_right: "prod a (r *\<^sub>C b) = r *\<^sub>C (prod a b)"
     and bounded: "\<exists>K. \<forall>a b. norm (prod a b) \<le> norm a * norm b * K"
 
 sublocale bounded_sesquilinear \<subseteq> real: bounded_bilinear
   \<comment> \<open>Gives access to all lemmas from \<^locale>\<open>linear\<close> using prefix \<open>real.\<close>\<close>
   apply standard
   by (auto simp: add_left add_right scaleC_left scaleC_right bounded scaleR_scaleC)
 
 lemma (in bounded_sesquilinear) bounded_bilinear[simp]: "bounded_bilinear prod"
   by intro_locales
 
 lemma (in bounded_sesquilinear) bounded_antilinear_left: "bounded_antilinear (\<lambda>a. prod a b)"
   apply standard
     apply (auto simp add: scaleC_left add_left)
   by (metis ab_semigroup_mult_class.mult_ac(1) bounded)
 
 lemma (in bounded_sesquilinear) bounded_clinear_right: "bounded_clinear (\<lambda>b. prod a b)"
   apply standard
     apply (auto simp add: scaleC_right add_right)
   by (metis ab_semigroup_mult_class.mult_ac(1) ordered_field_class.sign_simps(34) real.pos_bounded)
 
 lemma (in bounded_sesquilinear) comp1:
   assumes \<open>bounded_clinear g\<close>
   shows \<open>bounded_sesquilinear (\<lambda>x. prod (g x))\<close>
 proof
   interpret bounded_clinear g by fact
   fix a a' b b' r
   show "prod (g (a + a')) b = prod (g a) b + prod (g a') b"
     by (simp add: add add_left)
   show "prod (g a) (b + b') = prod (g a) b + prod (g a) b'"
     by (simp add: add add_right)
   show "prod (g (r *\<^sub>C a)) b = cnj r *\<^sub>C prod (g a) b"
     by (simp add: scaleC scaleC_left)
   show "prod (g a) (r *\<^sub>C b) = r *\<^sub>C prod (g a) b"
     by (simp add: scaleC_right)
   interpret bi: bounded_bilinear \<open>(\<lambda>x. prod (g x))\<close>
     by (simp add: bounded_linear real.comp1)
   show "\<exists>K. \<forall>a b. norm (prod (g a) b) \<le> norm a * norm b * K"
     using bi.bounded by blast
 qed
 
 lemma (in bounded_sesquilinear) comp2:
   assumes \<open>bounded_clinear g\<close>
   shows \<open>bounded_sesquilinear (\<lambda>x y. prod x (g y))\<close>
 proof
   interpret bounded_clinear g by fact
   fix a a' b b' r
   show "prod (a + a') (g b) = prod a (g b) + prod a' (g b)"
     by (simp add: add add_left)
   show "prod a (g (b + b')) = prod a (g b) + prod a (g b')"
     by (simp add: add add_right)
   show "prod (r *\<^sub>C a) (g b) = cnj r *\<^sub>C prod a (g b)"
     by (simp add: scaleC scaleC_left)
   show "prod a (g (r *\<^sub>C b)) = r *\<^sub>C prod a (g b)"
     by (simp add: scaleC scaleC_right)
   interpret bi: bounded_bilinear \<open>(\<lambda>x y. prod x (g y))\<close>
     apply (rule bounded_bilinear.flip)
     using _ bounded_linear apply (rule bounded_bilinear.comp1)
     using bounded_bilinear by (rule bounded_bilinear.flip)
   show "\<exists>K. \<forall>a b. norm (prod a (g b)) \<le> norm a * norm b * K"
     using bi.bounded by blast
 qed
 
 lemma (in bounded_sesquilinear) comp: "bounded_clinear f \<Longrightarrow> bounded_clinear g \<Longrightarrow> bounded_sesquilinear (\<lambda>x y. prod (f x) (g y))"
   using comp1 bounded_sesquilinear.comp2 by auto
 
 lemma bounded_clinear_const_scaleR:
   fixes c :: real
   assumes \<open>bounded_clinear f\<close>
   shows \<open>bounded_clinear (\<lambda> x. c *\<^sub>R f x )\<close>
 proof-
   have  \<open>bounded_clinear (\<lambda> x. (complex_of_real c) *\<^sub>C f x )\<close>
     by (simp add: assms bounded_clinear_const_scaleC)
   thus ?thesis
     by (simp add: scaleR_scaleC)
 qed
 
 lemma bounded_linear_bounded_clinear:
   \<open>bounded_linear A \<Longrightarrow> \<forall>c x. A (c *\<^sub>C x) = c *\<^sub>C A x \<Longrightarrow> bounded_clinear A\<close>
   apply standard
   by (simp_all add: linear_simps bounded_linear.bounded)
 
 lemma comp_bounded_clinear:
   fixes  A :: \<open>'b::complex_normed_vector \<Rightarrow> 'c::complex_normed_vector\<close>
     and B :: \<open>'a::complex_normed_vector \<Rightarrow> 'b\<close>
   assumes \<open>bounded_clinear A\<close> and \<open>bounded_clinear B\<close>
   shows \<open>bounded_clinear (A \<circ> B)\<close>
   by (metis clinear_compose assms(1) assms(2) bounded_clinear_axioms_def bounded_clinear_compose bounded_clinear_def o_def)
 
 
 lemmas isCont_scaleC [simp] =
   bounded_bilinear.isCont [OF bounded_cbilinear_scaleC[THEN bounded_cbilinear.bounded_bilinear]]
 
 subsection \<open>Misc 2\<close>
 
 lemma summable_on_scaleC_left [intro]:
   fixes c :: \<open>'a :: complex_normed_vector\<close>
   assumes "c \<noteq> 0 \<Longrightarrow> f summable_on A"
   shows   "(\<lambda>x. f x *\<^sub>C c) summable_on A"
   apply (cases \<open>c \<noteq> 0\<close>)
    apply (subst asm_rl[of \<open>(\<lambda>x. f x *\<^sub>C c) = (\<lambda>y. y *\<^sub>C c) o f\<close>], simp add: o_def)
    apply (rule summable_on_comm_additive)
   using assms by (auto simp add: scaleC_left.additive_axioms)
 
 lemma summable_on_scaleC_right [intro]:
   fixes f :: \<open>'a \<Rightarrow> 'b :: complex_normed_vector\<close>
   assumes "c \<noteq> 0 \<Longrightarrow> f summable_on A"
   shows   "(\<lambda>x. c *\<^sub>C f x) summable_on A"
   apply (cases \<open>c \<noteq> 0\<close>)
    apply (subst asm_rl[of \<open>(\<lambda>x. c *\<^sub>C f x) = (\<lambda>y. c *\<^sub>C y) o f\<close>], simp add: o_def)
    apply (rule summable_on_comm_additive)
   using assms by (auto simp add: scaleC_right.additive_axioms)
 
 lemma infsum_scaleC_left:
   fixes c :: \<open>'a :: complex_normed_vector\<close>
   assumes "c \<noteq> 0 \<Longrightarrow> f summable_on A"
   shows   "infsum (\<lambda>x. f x *\<^sub>C c) A = infsum f A *\<^sub>C c"
   apply (cases \<open>c \<noteq> 0\<close>)
    apply (subst asm_rl[of \<open>(\<lambda>x. f x *\<^sub>C c) = (\<lambda>y. y *\<^sub>C c) o f\<close>], simp add: o_def)
    apply (rule infsum_comm_additive)
   using assms by (auto simp add: scaleC_left.additive_axioms)
 
 lemma infsum_scaleC_right:
   fixes f :: \<open>'a \<Rightarrow> 'b :: complex_normed_vector\<close>
   shows   "infsum (\<lambda>x. c *\<^sub>C f x) A = c *\<^sub>C infsum f A"
 proof -
   consider (summable) \<open>f summable_on A\<close> | (c0) \<open>c = 0\<close> | (not_summable) \<open>\<not> f summable_on A\<close> \<open>c \<noteq> 0\<close>
     by auto
   then show ?thesis
   proof cases
     case summable
     then show ?thesis
       apply (subst asm_rl[of \<open>(\<lambda>x. c *\<^sub>C f x) = (\<lambda>y. c *\<^sub>C y) o f\<close>], simp add: o_def)
       apply (rule infsum_comm_additive)
       using summable by (auto simp add: scaleC_right.additive_axioms)
   next
     case c0
     then show ?thesis by auto
   next
     case not_summable
     have \<open>\<not> (\<lambda>x. c *\<^sub>C f x) summable_on A\<close>
     proof (rule notI)
       assume \<open>(\<lambda>x. c *\<^sub>C f x) summable_on A\<close>
       then have \<open>(\<lambda>x. inverse c *\<^sub>C c *\<^sub>C f x) summable_on A\<close>
         using summable_on_scaleC_right by blast
       then have \<open>f summable_on A\<close>
         using not_summable by auto
       with not_summable show False
         by simp
     qed
     then show ?thesis
       by (simp add: infsum_not_exists not_summable(1)) 
   qed
 qed
 
 
 
 lemmas sums_of_complex = bounded_linear.sums [OF bounded_clinear_of_complex[THEN bounded_clinear.bounded_linear]]
 lemmas summable_of_complex = bounded_linear.summable [OF bounded_clinear_of_complex[THEN bounded_clinear.bounded_linear]]
 lemmas suminf_of_complex = bounded_linear.suminf [OF bounded_clinear_of_complex[THEN bounded_clinear.bounded_linear]]
 
 lemmas sums_scaleC_left = bounded_linear.sums[OF bounded_clinear_scaleC_left[THEN bounded_clinear.bounded_linear]]
 lemmas summable_scaleC_left = bounded_linear.summable[OF bounded_clinear_scaleC_left[THEN bounded_clinear.bounded_linear]]
 lemmas suminf_scaleC_left = bounded_linear.suminf[OF bounded_clinear_scaleC_left[THEN bounded_clinear.bounded_linear]]
 
 lemmas sums_scaleC_right = bounded_linear.sums[OF bounded_clinear_scaleC_right[THEN bounded_clinear.bounded_linear]]
 lemmas summable_scaleC_right = bounded_linear.summable[OF bounded_clinear_scaleC_right[THEN bounded_clinear.bounded_linear]]
 lemmas suminf_scaleC_right = bounded_linear.suminf[OF bounded_clinear_scaleC_right[THEN bounded_clinear.bounded_linear]]
 
 lemma closed_scaleC:
   fixes S::\<open>'a::complex_normed_vector set\<close> and a :: complex
   assumes \<open>closed S\<close>
   shows \<open>closed ((*\<^sub>C) a ` S)\<close>
 proof (cases \<open>a = 0\<close>)
   case True
   then show ?thesis
     apply (cases \<open>S = {}\<close>)
     by (auto simp: image_constant)
 next
   case False
   then have \<open>(*\<^sub>C) a ` S = (*\<^sub>C) (inverse a) -` S\<close>
     by (auto simp add: rev_image_eqI)
   moreover have \<open>closed ((*\<^sub>C) (inverse a) -` S)\<close>
     by (simp add: assms continuous_closed_vimage)
   ultimately show ?thesis
     by simp
 qed
 
 lemma closure_scaleC:
   fixes S::\<open>'a::complex_normed_vector set\<close>
   shows \<open>closure ((*\<^sub>C) a ` S) = (*\<^sub>C) a ` closure S\<close>
 proof
   have \<open>closed (closure S)\<close>
     by simp
   show "closure ((*\<^sub>C) a ` S) \<subseteq> (*\<^sub>C) a ` closure S"
     by (simp add: closed_scaleC closure_minimal closure_subset image_mono)
 
   have "x \<in> closure ((*\<^sub>C) a ` S)"
     if "x \<in> (*\<^sub>C) a ` closure S"
     for x :: 'a
   proof-
     obtain t where \<open>x = ((*\<^sub>C) a) t\<close> and \<open>t \<in> closure S\<close>
       using \<open>x \<in> (*\<^sub>C) a ` closure S\<close> by auto
     have \<open>\<exists>s. (\<forall>n. s n \<in> S) \<and> s \<longlonglongrightarrow> t\<close>
       using \<open>t \<in> closure S\<close> Elementary_Topology.closure_sequential
       by blast
     then obtain s where \<open>\<forall>n. s n \<in> S\<close> and \<open>s \<longlonglongrightarrow> t\<close>
       by blast
     have \<open>(\<forall> n. scaleC a (s n) \<in> ((*\<^sub>C) a ` S))\<close>
       using \<open>\<forall>n. s n \<in> S\<close> by blast
     moreover have \<open>(\<lambda> n. scaleC a (s n)) \<longlonglongrightarrow> x\<close>
     proof-
       have \<open>isCont (scaleC a) t\<close>
         by simp
       thus ?thesis
         using  \<open>s \<longlonglongrightarrow> t\<close>  \<open>x = ((*\<^sub>C) a) t\<close>
         by (simp add: isCont_tendsto_compose)
     qed
     ultimately show ?thesis using Elementary_Topology.closure_sequential
       by metis
   qed
   thus "(*\<^sub>C) a ` closure S \<subseteq> closure ((*\<^sub>C) a ` S)" by blast
 qed
 
 lemma onorm_scalarC:
   fixes f :: \<open>'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector\<close>
   assumes a1: \<open>bounded_clinear f\<close>
   shows  \<open>onorm (\<lambda> x. r *\<^sub>C (f x)) = (cmod r) * onorm f\<close>
 proof-
   have \<open>(norm (f x)) / norm x \<le> onorm f\<close>
     for x
     using a1
     by (simp add: bounded_clinear.bounded_linear le_onorm)
   hence t2: \<open>bdd_above {(norm (f x)) / norm x | x. True}\<close>
     by fastforce
   have \<open>continuous_on UNIV ( (*) w ) \<close>
     for w::real
     by simp
   hence \<open>isCont ( ((*) (cmod r)) ) x\<close>
     for x
     by simp
   hence t3: \<open>continuous (at_left (Sup {(norm (f x)) / norm x | x. True})) ((*) (cmod r))\<close>
     using Elementary_Topology.continuous_at_imp_continuous_within
     by blast
   have \<open>{(norm (f x)) / norm x | x. True} \<noteq> {}\<close>
     by blast
   moreover have \<open>mono ((*) (cmod r))\<close>
     by (simp add: monoI ordered_comm_semiring_class.comm_mult_left_mono)
   ultimately have \<open>Sup {((*) (cmod r)) ((norm (f x)) / norm x) | x. True}
          = ((*) (cmod r)) (Sup {(norm (f x)) / norm x | x. True})\<close>
     using t2 t3
     by (simp add:  continuous_at_Sup_mono full_SetCompr_eq image_image)
   hence  \<open>Sup {(cmod r) * ((norm (f x)) / norm x) | x. True}
          = (cmod r) * (Sup {(norm (f x)) / norm x | x. True})\<close>
     by blast
   moreover have \<open>Sup {(cmod r) * ((norm (f x)) / norm x) | x. True}
                 = (SUP x. cmod r * norm (f x) / norm x)\<close>
     by (simp add: full_SetCompr_eq)
   moreover have \<open>(Sup {(norm (f x)) / norm x | x. True})
                 = (SUP x. norm (f x) / norm x)\<close>
     by (simp add: full_SetCompr_eq)
   ultimately have t1: "(SUP x. cmod r * norm (f x) / norm x)
       = cmod r * (SUP x. norm (f x) / norm x)"
     by simp
   have \<open>onorm (\<lambda> x. r *\<^sub>C (f x)) = (SUP x. norm ( (\<lambda> t. r *\<^sub>C (f t)) x) / norm x)\<close>
     by (simp add: onorm_def)
   hence \<open>onorm (\<lambda> x. r *\<^sub>C (f x)) = (SUP x. (cmod r) * (norm (f x)) / norm x)\<close>
     by simp
   also have \<open>... = (cmod r) * (SUP x. (norm (f x)) / norm x)\<close>
     using t1.
   finally show ?thesis
     by (simp add: onorm_def)
 qed
 
 lemma onorm_scaleC_left_lemma:
   fixes f :: "'a::complex_normed_vector"
   assumes r: "bounded_clinear r"
   shows "onorm (\<lambda>x. r x *\<^sub>C f) \<le> onorm r * norm f"
 proof (rule onorm_bound)
   fix x
   have "norm (r x *\<^sub>C f) = norm (r x) * norm f"
     by simp
   also have "\<dots> \<le> onorm r * norm x * norm f"
     by (simp add: bounded_clinear.bounded_linear mult.commute mult_left_mono onorm r)
   finally show "norm (r x *\<^sub>C f) \<le> onorm r * norm f * norm x"
     by (simp add: ac_simps)
   show "0 \<le> onorm r * norm f"
     by (simp add: bounded_clinear.bounded_linear onorm_pos_le r)
 qed
 
 lemma onorm_scaleC_left:
   fixes f :: "'a::complex_normed_vector"
   assumes f: "bounded_clinear r"
   shows "onorm (\<lambda>x. r x *\<^sub>C f) = onorm r * norm f"
 proof (cases "f = 0")
   assume "f \<noteq> 0"
   show ?thesis
   proof (rule order_antisym)
     show "onorm (\<lambda>x. r x *\<^sub>C f) \<le> onorm r * norm f"
       using f by (rule onorm_scaleC_left_lemma)
   next
     have bl1: "bounded_clinear (\<lambda>x. r x *\<^sub>C f)"
       by (metis bounded_clinear_scaleC_const f)
     have x1:"bounded_clinear (\<lambda>x. r x * norm f)"
       by (metis bounded_clinear_mult_const f)
 
     have "onorm r \<le> onorm (\<lambda>x. r x * complex_of_real (norm f)) / norm f"
       if "onorm r \<le> onorm (\<lambda>x. r x * complex_of_real (norm f)) * cmod (1 / complex_of_real (norm f))"
         and "f \<noteq> 0"
       using that
       by (metis complex_of_real_cmod complex_of_real_nn_iff field_class.field_divide_inverse
           inverse_eq_divide nice_ordered_field_class.zero_le_divide_1_iff norm_ge_zero of_real_1
           of_real_divide of_real_eq_iff)
     hence "onorm r \<le> onorm (\<lambda>x. r x * norm f) * inverse (norm f)"
       using \<open>f \<noteq> 0\<close> onorm_scaleC_left_lemma[OF x1, of "inverse (norm f)"]
       by (simp add: inverse_eq_divide)
     also have "onorm (\<lambda>x. r x * norm f) \<le> onorm (\<lambda>x. r x *\<^sub>C f)"
     proof (rule onorm_bound)
       have "bounded_linear (\<lambda>x. r x *\<^sub>C f)"
         using bl1 bounded_clinear.bounded_linear by auto
       thus "0 \<le> onorm (\<lambda>x. r x *\<^sub>C f)"
         by (rule Operator_Norm.onorm_pos_le)
       show "cmod (r x * complex_of_real (norm f)) \<le> onorm (\<lambda>x. r x *\<^sub>C f) * norm x"
         for x :: 'b
         by (smt \<open>bounded_linear (\<lambda>x. r x *\<^sub>C f)\<close> complex_of_real_cmod complex_of_real_nn_iff
             complex_scaleC_def norm_ge_zero norm_scaleC of_real_eq_iff onorm)
     qed
     finally show "onorm r * norm f \<le> onorm (\<lambda>x. r x *\<^sub>C f)"
       using \<open>f \<noteq> 0\<close>
       by (simp add: inverse_eq_divide pos_le_divide_eq mult.commute)
   qed
 qed (simp add: onorm_zero)
 
 subsection \<open>Finite dimension and canonical basis\<close>
 
 lemma vector_finitely_spanned:
   assumes \<open>z \<in> cspan T\<close>
   shows \<open>\<exists> S. finite S \<and> S \<subseteq> T \<and> z \<in> cspan S\<close>
 proof-
   have \<open>\<exists> S r. finite S \<and> S \<subseteq> T \<and> z = (\<Sum>a\<in>S. r a *\<^sub>C a)\<close>
     using complex_vector.span_explicit[where b = "T"]
       assms by auto
   then obtain S r where \<open>finite S\<close> and \<open>S \<subseteq> T\<close> and \<open>z = (\<Sum>a\<in>S. r a *\<^sub>C a)\<close>
     by blast
   thus ?thesis
     by (meson complex_vector.span_scale complex_vector.span_sum complex_vector.span_superset subset_iff)
 qed
 
 setup \<open>Sign.add_const_constraint ("Complex_Vector_Spaces0.cindependent", SOME \<^typ>\<open>'a set \<Rightarrow> bool\<close>)\<close>
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>cdependent\<close>, SOME \<^typ>\<open>'a set \<Rightarrow> bool\<close>)\<close>
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>cspan\<close>, SOME \<^typ>\<open>'a set \<Rightarrow> 'a set\<close>)\<close>
 
 class cfinite_dim = complex_vector +
   assumes cfinitely_spanned: "\<exists>S::'a set. finite S \<and> cspan S = UNIV"
 
 class basis_enum = complex_vector +
   fixes canonical_basis :: "'a list"
   assumes distinct_canonical_basis[simp]:
     "distinct canonical_basis"
     and is_cindependent_set[simp]:
     "cindependent (set canonical_basis)"
     and is_generator_set[simp]:
     "cspan (set canonical_basis) = UNIV"
 
 setup \<open>Sign.add_const_constraint ("Complex_Vector_Spaces0.cindependent", SOME \<^typ>\<open>'a::complex_vector set \<Rightarrow> bool\<close>)\<close>
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>cdependent\<close>, SOME \<^typ>\<open>'a::complex_vector set \<Rightarrow> bool\<close>)\<close>
 setup \<open>Sign.add_const_constraint (\<^const_name>\<open>cspan\<close>, SOME \<^typ>\<open>'a::complex_vector set \<Rightarrow> 'a set\<close>)\<close>
 
 lemma cdim_UNIV_basis_enum[simp]: \<open>cdim (UNIV::'a::basis_enum set) = length (canonical_basis::'a list)\<close>
   apply (subst is_generator_set[symmetric])
   apply (subst complex_vector.dim_span_eq_card_independent)
    apply (rule is_cindependent_set)
   using distinct_canonical_basis distinct_card by blast
 
 lemma finite_basis: "\<exists>basis::'a::cfinite_dim set. finite basis \<and> cindependent basis \<and> cspan basis = UNIV"
 proof -
   from cfinitely_spanned
   obtain S :: \<open>'a set\<close> where \<open>finite S\<close> and \<open>cspan S = UNIV\<close>
     by auto
   from complex_vector.maximal_independent_subset
   obtain B :: \<open>'a set\<close> where \<open>B \<subseteq> S\<close> and \<open>cindependent B\<close> and \<open>S \<subseteq> cspan B\<close>
     by metis
   moreover have \<open>finite B\<close>
     using \<open>B \<subseteq> S\<close> \<open>finite S\<close>
     by (meson finite_subset)
   moreover have \<open>cspan B = UNIV\<close>
     using \<open>cspan S = UNIV\<close> \<open>S \<subseteq> cspan B\<close>
     by (metis complex_vector.span_eq top_greatest)
   ultimately show ?thesis
     by auto
 qed
 
 instance basis_enum \<subseteq> cfinite_dim
   apply intro_classes
   apply (rule exI[of _ \<open>set canonical_basis\<close>])
   using is_cindependent_set is_generator_set by auto
 
 lemma cindependent_cfinite_dim_finite:
   assumes \<open>cindependent (S::'a::cfinite_dim set)\<close>
   shows \<open>finite S\<close>
   by (metis assms cfinitely_spanned complex_vector.independent_span_bound top_greatest)
 
 lemma cfinite_dim_finite_subspace_basis:
   assumes \<open>csubspace X\<close>
   shows "\<exists>basis::'a::cfinite_dim set. finite basis \<and> cindependent basis \<and> cspan basis = X"
   by (meson assms cindependent_cfinite_dim_finite complex_vector.basis_exists complex_vector.span_subspace)
 
 
 text \<open>The following auxiliary lemma (\<open>finite_span_complete_aux\<close>) shows more or less the same as \<open>finite_span_representation_bounded\<close>,
    \<open>finite_span_complete\<close> below (see there for an intuition about the mathematical
    content of the lemmas). However, there is one difference: Here we additionally assume here
    that there is a bijection rep/abs between a finite type \<^typ>\<open>'basis\<close> and the set $B$.
    This is needed to be able to use results about euclidean spaces that are formulated w.r.t.
    the type class \<^class>\<open>finite\<close>
 
    Since we anyway assume that $B$ is finite, this added assumption does not make the lemma
    weaker. However, we cannot derive the existence of \<^typ>\<open>'basis\<close> inside the proof
    (HOL does not support such reasoning). Therefore we have the type \<^typ>\<open>'basis\<close> as
    an explicit assumption and remove it using @{attribute internalize_sort} after the proof.\<close>
 
 lemma finite_span_complete_aux:
   fixes b :: "'b::real_normed_vector" and B :: "'b set"
     and  rep :: "'basis::finite \<Rightarrow> 'b" and abs :: "'b \<Rightarrow> 'basis"
   assumes t: "type_definition rep abs B"
     and t1: "finite B" and t2: "b\<in>B" and t3: "independent B"
   shows "\<exists>D>0. \<forall>\<psi>. norm (representation B \<psi> b) \<le> norm \<psi> * D"
     and "complete (span B)"
 proof -
   define repr  where "repr = real_vector.representation B"
   define repr' where "repr' \<psi> = Abs_euclidean_space (repr \<psi> o rep)" for \<psi>
   define comb  where "comb l = (\<Sum>b\<in>B. l b *\<^sub>R b)" for l
   define comb' where "comb' l = comb (Rep_euclidean_space l o abs)" for l
 
   have comb_cong: "comb x = comb y" if "\<And>z. z\<in>B \<Longrightarrow> x z = y z" for x y
     unfolding comb_def using that by auto
   have comb_repr[simp]: "comb (repr \<psi>) = \<psi>" if "\<psi> \<in> real_vector.span B" for \<psi>
     using \<open>comb \<equiv> \<lambda>l. \<Sum>b\<in>B. l b *\<^sub>R b\<close> local.repr_def real_vector.sum_representation_eq t1 t3 that
     by fastforce
 
   have w5:"(\<Sum>b | (b \<in> B \<longrightarrow> x b \<noteq> 0) \<and> b \<in> B. x b *\<^sub>R b) =
     (\<Sum>b\<in>B. x b *\<^sub>R b)" for x
     using \<open>finite B\<close>
     by (smt DiffD1 DiffD2 mem_Collect_eq real_vector.scale_eq_0_iff subset_eq sum.mono_neutral_left)
   have "representation B (\<Sum>b\<in>B. x b *\<^sub>R b) =  (\<lambda>b. if b \<in> B then x b else 0)"
     for x
   proof (rule real_vector.representation_eqI)
     show "independent B"
       by (simp add: t3)
     show "(\<Sum>b\<in>B. x b *\<^sub>R b) \<in> span B"
       by (meson real_vector.span_scale real_vector.span_sum real_vector.span_superset subset_iff)
     show "b \<in> B"
       if "(if b \<in> B then x b else 0) \<noteq> 0"
       for b :: 'b
       using that
       by meson
     show "finite {b. (if b \<in> B then x b else 0) \<noteq> 0}"
       using t1 by auto
     show "(\<Sum>b | (if b \<in> B then x b else 0) \<noteq> 0. (if b \<in> B then x b else 0) *\<^sub>R b) = (\<Sum>b\<in>B. x b *\<^sub>R b)"
       using w5
       by simp
   qed
   hence repr_comb[simp]: "repr (comb x) = (\<lambda>b. if b\<in>B then x b else 0)" for x
     unfolding repr_def comb_def.
   have repr_bad[simp]: "repr \<psi> = (\<lambda>_. 0)" if "\<psi> \<notin> real_vector.span B" for \<psi>
     unfolding repr_def using that
     by (simp add: real_vector.representation_def)
   have [simp]: "repr' \<psi> = 0" if "\<psi> \<notin> real_vector.span B" for \<psi>
     unfolding repr'_def repr_bad[OF that]
     apply transfer
     by auto
   have comb'_repr'[simp]: "comb' (repr' \<psi>) = \<psi>"
     if "\<psi> \<in> real_vector.span B" for \<psi>
   proof -
     have x1: "(repr \<psi> \<circ> rep \<circ> abs) z = repr \<psi> z"
       if "z \<in> B"
       for z
       unfolding o_def
       using t that type_definition.Abs_inverse by fastforce
     have "comb' (repr' \<psi>) = comb ((repr \<psi> \<circ> rep) \<circ> abs)"
       unfolding comb'_def repr'_def
       by (subst Abs_euclidean_space_inverse; simp)
     also have "\<dots> = comb (repr \<psi>)"
       using x1 comb_cong by blast
     also have "\<dots> = \<psi>"
       using that by simp
     finally show ?thesis by -
   qed
 
   have t1: "Abs_euclidean_space (Rep_euclidean_space t) = t"
     if "\<And>x. rep x \<in> B"
     for t::"'a euclidean_space"
     apply (subst Rep_euclidean_space_inverse)
     by simp
   have "Abs_euclidean_space
      (\<lambda>y. if rep y \<in> B
            then Rep_euclidean_space x y
            else 0) = x"
     for x
     using type_definition.Rep[OF t] apply simp
     using t1 by blast
   hence "Abs_euclidean_space
      (\<lambda>y. if rep y \<in> B
            then Rep_euclidean_space x (abs (rep y))
            else 0) = x"
     for x
     apply (subst type_definition.Rep_inverse[OF t])
     by simp
   hence repr'_comb'[simp]: "repr' (comb' x) = x" for x
     unfolding comb'_def repr'_def o_def
     by simp
   have sphere: "compact (sphere 0 d :: 'basis euclidean_space set)" for d
     using compact_sphere by blast
   have "complete (UNIV :: 'basis euclidean_space set)"
     by (simp add: complete_UNIV)
 
 
   have "(\<Sum>b\<in>B. (Rep_euclidean_space (x + y) \<circ> abs) b *\<^sub>R b) = (\<Sum>b\<in>B. (Rep_euclidean_space x \<circ> abs) b *\<^sub>R b) + (\<Sum>b\<in>B. (Rep_euclidean_space y \<circ> abs) b *\<^sub>R b)"
     for x :: "'basis euclidean_space"
       and y :: "'basis euclidean_space"
     apply (transfer fixing: abs)
     by (simp add: scaleR_add_left sum.distrib)
   moreover have "(\<Sum>b\<in>B. (Rep_euclidean_space (c *\<^sub>R x) \<circ> abs) b *\<^sub>R b) = c *\<^sub>R (\<Sum>b\<in>B. (Rep_euclidean_space x \<circ> abs) b *\<^sub>R b)"
     for c :: real
       and x :: "'basis euclidean_space"
     apply (transfer fixing: abs)
     by (simp add: real_vector.scale_sum_right)
   ultimately have blin_comb': "bounded_linear comb'"
     unfolding comb_def comb'_def
     by (rule bounded_linearI')
   hence "continuous_on X comb'" for X
     by (simp add: linear_continuous_on)
   hence "compact (comb' ` sphere 0 d)" for d
     using sphere
     by (rule compact_continuous_image)
   hence compact_norm_comb': "compact (norm ` comb' ` sphere 0 1)"
     using compact_continuous_image continuous_on_norm_id by blast
   have not0: "0 \<notin> norm ` comb' ` sphere 0 1"
   proof (rule ccontr, simp)
     assume "0 \<in> norm ` comb' ` sphere 0 1"
     then obtain x where nc0: "norm (comb' x) = 0" and x: "x \<in> sphere 0 1"
       by auto
     hence "comb' x = 0"
       by simp
     hence "repr' (comb' x) = 0"
       unfolding repr'_def o_def repr_def apply simp
       by (smt repr'_comb' blin_comb' dist_0_norm linear_simps(3) mem_sphere norm_zero x)
     hence "x = 0"
       by auto
     with x show False
       by simp
   qed
 
   have "closed (norm ` comb' ` sphere 0 1)"
     using compact_imp_closed compact_norm_comb' by blast
   moreover have "0 \<notin> norm ` comb' ` sphere 0 1"
     by (simp add: not0)
   ultimately have "\<exists>d>0. \<forall>x\<in>norm ` comb' ` sphere 0 1. d \<le> dist 0 x"
     by (meson separate_point_closed)
 
   then obtain d where d: "x\<in>norm ` comb' ` sphere 0 1 \<Longrightarrow> d \<le> dist 0 x"
     and "d > 0" for x
     by metis
   define D where "D = 1/d"
   hence "D > 0"
     using \<open>d>0\<close> unfolding D_def by auto
   have "x \<ge> d"
     if "x\<in>norm ` comb' ` sphere 0 1"
     for x
     using d that
     apply auto
     by fastforce
   hence *: "norm (comb' x) \<ge> d" if "norm x = 1" for x
     using that by auto
   have norm_comb': "norm (comb' x) \<ge> d * norm x" for x
   proof (cases "x=0")
     show "d * norm x \<le> norm (comb' x)"
       if "x = 0"
       using that
       by simp
     show "d * norm x \<le> norm (comb' x)"
       if "x \<noteq> 0"
       using that
       using *[of "(1/norm x) *\<^sub>R x"]
       unfolding linear_simps(5)[OF blin_comb']
       apply auto
       by (simp add: le_divide_eq)
   qed
 
   have *:  "norm (repr' \<psi>) \<le> norm \<psi> * D" for \<psi>
   proof (cases "\<psi> \<in> real_vector.span B")
     show "norm (repr' \<psi>) \<le> norm \<psi> * D"
       if "\<psi> \<in> span B"
       using that     unfolding D_def
       using norm_comb'[of "repr' \<psi>"] \<open>d>0\<close>
       by (simp_all add: linordered_field_class.mult_imp_le_div_pos mult.commute)
 
     show "norm (repr' \<psi>) \<le> norm \<psi> * D"
       if "\<psi> \<notin> span B"
       using that \<open>0 < D\<close> by auto
   qed
 
   hence "norm (Rep_euclidean_space (repr' \<psi>) (abs b)) \<le> norm \<psi> * D" for \<psi>
   proof -
     have "(Rep_euclidean_space (repr' \<psi>) (abs b)) = repr' \<psi> \<bullet> euclidean_space_basis_vector (abs b)"
       apply (transfer fixing: abs b)
       by auto
     also have "\<bar>\<dots>\<bar> \<le> norm (repr' \<psi>)"
       apply (rule Basis_le_norm)
       unfolding Basis_euclidean_space_def by simp
     also have "\<dots> \<le> norm \<psi> * D"
       using * by auto
     finally show ?thesis by simp
   qed
   hence "norm (repr \<psi> b) \<le> norm \<psi> * D" for \<psi>
     unfolding repr'_def
     by (smt \<open>comb' \<equiv> \<lambda>l. comb (Rep_euclidean_space l \<circ> abs)\<close>
         \<open>repr' \<equiv> \<lambda>\<psi>. Abs_euclidean_space (repr \<psi> \<circ> rep)\<close> comb'_repr' comp_apply norm_le_zero_iff
         repr_bad repr_comb)
   thus "\<exists>D>0. \<forall>\<psi>. norm (repr \<psi> b) \<le> norm \<psi> * D"
     using \<open>D>0\<close> by auto
   from \<open>d>0\<close>
   have complete_comb': "complete (comb' ` UNIV)"
   proof (rule complete_isometric_image)
     show "subspace (UNIV::'basis euclidean_space set)"
       by simp
     show "bounded_linear comb'"
       by (simp add: blin_comb')
     show "\<forall>x\<in>UNIV. d * norm x \<le> norm (comb' x)"
       by (simp add: norm_comb')
     show "complete (UNIV::'basis euclidean_space set)"
       by (simp add: \<open>complete UNIV\<close>)
   qed
 
   have range_comb': "comb' ` UNIV = real_vector.span B"
   proof (auto simp: image_def)
     show "comb' x \<in> real_vector.span B" for x
       by (metis comb'_def comb_cong comb_repr local.repr_def repr_bad repr_comb real_vector.representation_zero real_vector.span_zero)
   next
     fix \<psi> assume "\<psi> \<in> real_vector.span B"
     then obtain f where f: "comb f = \<psi>"
       apply atomize_elim
       unfolding span_finite[OF \<open>finite B\<close>] comb_def
       by auto
     define f' where "f' b = (if b\<in>B then f b else 0)" for b :: 'b
     have f': "comb f' = \<psi>"
       unfolding f[symmetric]
       apply (rule comb_cong)
       unfolding f'_def by simp
     define x :: "'basis euclidean_space" where "x = Abs_euclidean_space (f' o rep)"
     have "\<psi> = comb' x"
       by (metis (no_types, lifting) \<open>\<psi> \<in> span B\<close> \<open>repr' \<equiv> \<lambda>\<psi>. Abs_euclidean_space (repr \<psi> \<circ> rep)\<close>
           comb'_repr' f' fun.map_cong repr_comb t type_definition.Rep_range x_def)
     thus "\<exists>x. \<psi> = comb' x"
       by auto
   qed
 
   from range_comb' complete_comb'
   show "complete (real_vector.span B)"
     by simp
 qed
 
 lemma finite_span_complete[simp]:
   fixes A :: "'a::real_normed_vector set"
   assumes "finite A"
   shows "complete (span A)"
   text \<open>The span of a finite set is complete.\<close>
 proof (cases "A \<noteq> {} \<and> A \<noteq> {0}")
   case True
   obtain B where
     BT: "real_vector.span B = real_vector.span A"
     and "independent B"
     and "finite B"
     by (meson True assms finite_subset real_vector.maximal_independent_subset real_vector.span_eq
         real_vector.span_superset subset_trans)
 
   have "B\<noteq>{}"
     apply (rule ccontr, simp)
     using BT True
     by (metis real_vector.span_superset real_vector.span_empty subset_singletonD)
 
 (* The following generalizes finite_span_complete_aux to hold without the assumption
      that 'basis has type class finite *)
   {
     (* The type variable 'basisT must not be the same as the one used in finite_span_complete_aux,
        otherwise "internalize_sort" below fails *)
     assume "\<exists>(Rep :: 'basisT\<Rightarrow>'a) Abs. type_definition Rep Abs B"
     then obtain rep :: "'basisT \<Rightarrow> 'a" and abs :: "'a \<Rightarrow> 'basisT" where t: "type_definition rep abs B"
       by auto
     have basisT_finite: "class.finite TYPE('basisT)"
       apply intro_classes
       using \<open>finite B\<close> t
       by (metis (mono_tags, opaque_lifting) ex_new_if_finite finite_imageI image_eqI type_definition_def)
     note finite_span_complete_aux(2)[internalize_sort "'basis::finite"]
     note this[OF basisT_finite t]
   }
   note this[cancel_type_definition, OF \<open>B\<noteq>{}\<close> \<open>finite B\<close> _ \<open>independent B\<close>]
   hence "complete (real_vector.span B)"
     using \<open>B\<noteq>{}\<close> by auto
   thus "complete (real_vector.span A)"
     unfolding BT by simp
 next
   case False
   thus ?thesis
     using complete_singleton by auto
 qed
 
 
 lemma finite_span_representation_bounded:
   fixes B :: "'a::real_normed_vector set"
   assumes "finite B" and "independent B"
   shows "\<exists>D>0. \<forall>\<psi> b. abs (representation B \<psi> b) \<le> norm \<psi> * D"
 
   text \<open>
   Assume $B$ is a finite linear independent set of vectors (in a real normed vector space).
   Let $\alpha^\psi_b$ be the coefficients of $\psi$ expressed as a linear combination over $B$.
   Then $\alpha$ is is uniformly cblinfun (i.e., $\lvert\alpha^\psi_b \leq D \lVert\psi\rVert\psi$
   for some $D$ independent of $\psi,b$).
 
   (This also holds when $b$ is not in the span of $B$ because of the way \<open>real_vector.representation\<close>
   is defined in this corner case.)\<close>
 
 proof (cases "B\<noteq>{}")
   case True
 
 (* The following generalizes finite_span_complete_aux to hold without the assumption
      that 'basis has type class finite *)
   define repr  where "repr = real_vector.representation B"
   {
     (* Step 1: Create a fake type definition by introducing a new type variable 'basis
                and then assuming the existence of the morphisms Rep/Abs to B
                This is then roughly equivalent to "typedef 'basis = B" *)
     (* The type variable 'basisT must not be the same as the one used in finite_span_complete_aux
        (I.e., we cannot call it 'basis) *)
     assume "\<exists>(Rep :: 'basisT\<Rightarrow>'a) Abs. type_definition Rep Abs B"
     then obtain rep :: "'basisT \<Rightarrow> 'a" and abs :: "'a \<Rightarrow> 'basisT" where t: "type_definition rep abs B"
       by auto
         (* Step 2: We show that our fake typedef 'basisT could be instantiated as type class finite *)
     have basisT_finite: "class.finite TYPE('basisT)"
       apply intro_classes
       using \<open>finite B\<close> t
       by (metis (mono_tags, opaque_lifting) ex_new_if_finite finite_imageI image_eqI type_definition_def)
         (* Step 3: We take the finite_span_complete_aux and remove the requirement that 'basis::finite
                (instead, a precondition "class.finite TYPE('basisT)" is introduced) *)
     note finite_span_complete_aux(1)[internalize_sort "'basis::finite"]
       (* Step 4: We instantiate the premises *)
     note this[OF basisT_finite t]
   }
     (* Now we have the desired fact, except that it still assumes that B is isomorphic to some type 'basis
      together with the assumption that there are morphisms between 'basis and B. 'basis and that premise
      are removed using cancel_type_definition
   *)
   note this[cancel_type_definition, OF True \<open>finite B\<close> _ \<open>independent B\<close>]
 
   hence d2:"\<exists>D. \<forall>\<psi>. D>0 \<and> norm (repr \<psi> b) \<le> norm \<psi> * D" if \<open>b\<in>B\<close> for b
     by (simp add: repr_def that True)
   have d1: " (\<And>b. b \<in> B \<Longrightarrow>
           \<exists>D. \<forall>\<psi>. 0 < D \<and> norm (repr \<psi> b) \<le> norm \<psi> * D) \<Longrightarrow>
     \<exists>D. \<forall>b \<psi>. b \<in> B \<longrightarrow>
                0 < D b \<and> norm (repr \<psi> b) \<le> norm \<psi> * D b"
     apply (rule choice) by auto
   then obtain D where D: "D b > 0 \<and> norm (repr \<psi> b) \<le> norm \<psi> * D b" if "b\<in>B" for b \<psi>
     apply atomize_elim
     using d2 by blast
 
   hence Dpos: "D b > 0" and Dbound: "norm (repr \<psi> b) \<le> norm \<psi> * D b"
     if "b\<in>B" for b \<psi>
     using that by auto
   define Dall where "Dall = Max (D`B)"
   have "Dall > 0"
     unfolding Dall_def using \<open>finite B\<close> \<open>B\<noteq>{}\<close> Dpos
     by (metis (mono_tags, lifting) Max_in finite_imageI image_iff image_is_empty)
   have "Dall \<ge> D b" if "b\<in>B" for b
     unfolding Dall_def using \<open>finite B\<close> that by auto
   with Dbound
   have "norm (repr \<psi> b) \<le> norm \<psi> * Dall" if "b\<in>B" for b \<psi>
     using that
     by (smt mult_left_mono norm_not_less_zero)
   moreover have "norm (repr \<psi> b) \<le> norm \<psi> * Dall" if "b\<notin>B" for b \<psi>
     unfolding repr_def using real_vector.representation_ne_zero True
     by (metis calculation empty_subsetI less_le_trans local.repr_def norm_ge_zero norm_zero not_less
         subsetI subset_antisym)
   ultimately show "\<exists>D>0. \<forall>\<psi> b. abs (repr \<psi> b) \<le> norm \<psi> * D"
     using \<open>Dall > 0\<close> real_norm_def by metis
 next
   case False
   thus ?thesis
     unfolding repr_def using real_vector.representation_ne_zero[of B]
     using nice_ordered_field_class.linordered_field_no_ub by fastforce
 qed
 
 hide_fact finite_span_complete_aux
 
 
 lemma finite_cspan_complete[simp]:
   fixes B :: "'a::complex_normed_vector set"
   assumes "finite B"
   shows "complete (cspan B)"
   by (simp add: assms cspan_as_span)
 
 
 lemma finite_span_closed[simp]:
   fixes B :: "'a::real_normed_vector set"
   assumes "finite B"
   shows "closed (real_vector.span B)"
   by (simp add: assms complete_imp_closed)
 
 
 lemma finite_cspan_closed[simp]:
   fixes S::\<open>'a::complex_normed_vector set\<close>
   assumes a1: \<open>finite S\<close>
   shows \<open>closed (cspan S)\<close>
   by (simp add: assms complete_imp_closed)
 
 lemma closure_finite_cspan:
   fixes T::\<open>'a::complex_normed_vector set\<close>
   assumes \<open>finite T\<close>
   shows \<open>closure (cspan T)  = cspan T\<close>
   by (simp add: assms)
 
 
 lemma finite_cspan_crepresentation_bounded:
   fixes B :: "'a::complex_normed_vector set"
   assumes a1: "finite B" and a2: "cindependent B"
   shows "\<exists>D>0. \<forall>\<psi> b. norm (crepresentation B \<psi> b) \<le> norm \<psi> * D"
 proof -
   define B' where "B' = (B \<union> scaleC \<i> ` B)"
   have independent_B': "independent B'"
     using B'_def \<open>cindependent B\<close>
     by (simp add: real_independent_from_complex_independent a1)
   have "finite B'"
     unfolding B'_def using \<open>finite B\<close> by simp
   obtain D' where "D' > 0" and D': "norm (real_vector.representation B' \<psi> b) \<le> norm \<psi> * D'"
     for \<psi> b
     apply atomize_elim
     using independent_B' \<open>finite B'\<close>
     by (simp add: finite_span_representation_bounded)
 
   define D where "D = 2*D'"
   from \<open>D' > 0\<close> have \<open>D > 0\<close>
     unfolding D_def by simp
   have "norm (crepresentation B \<psi> b) \<le> norm \<psi> * D" for \<psi> b
   proof (cases "b\<in>B")
     case True
     have d3: "norm \<i> = 1"
       by simp
 
     have "norm (\<i> *\<^sub>C complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))
           = norm \<i> * norm (complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))"
       using norm_scaleC by blast
     also have "\<dots> = norm (complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))"
       using d3 by simp
     finally have d2:"norm (\<i> *\<^sub>C complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))
           = norm (complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))".
     have "norm (crepresentation B \<psi> b)
         = norm (complex_of_real (real_vector.representation B' \<psi> b)
             + \<i> *\<^sub>C complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))"
       by (simp add: B'_def True a1 a2 crepresentation_from_representation)
     also have "\<dots> \<le> norm (complex_of_real (real_vector.representation B' \<psi> b))
              + norm (\<i> *\<^sub>C complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))"
       using norm_triangle_ineq by blast
     also have "\<dots> = norm (complex_of_real (real_vector.representation B' \<psi> b))
                   + norm (complex_of_real (real_vector.representation B' \<psi> (\<i> *\<^sub>C b)))"
       using d2 by simp
     also have "\<dots> = norm (real_vector.representation B' \<psi> b)
                   + norm (real_vector.representation B' \<psi> (\<i> *\<^sub>C b))"
       by simp
     also have "\<dots> \<le> norm \<psi> * D' + norm \<psi> * D'"
       by (rule add_mono; rule D')
     also have "\<dots> \<le> norm \<psi> * D"
       unfolding D_def by linarith
     finally show ?thesis
       by auto
   next
     case False
     hence "crepresentation B \<psi> b = 0"
       using complex_vector.representation_ne_zero by blast
     thus ?thesis
       by (smt \<open>0 < D\<close> norm_ge_zero norm_zero split_mult_pos_le)
   qed
   with \<open>D > 0\<close>
   show ?thesis
     by auto
 qed
 
 lemma bounded_clinear_finite_dim[simp]:
   fixes f :: \<open>'a::{cfinite_dim,complex_normed_vector} \<Rightarrow> 'b::complex_normed_vector\<close>
   assumes \<open>clinear f\<close>
   shows \<open>bounded_clinear f\<close>
 proof -
   include notation_norm
   obtain basis :: \<open>'a set\<close> where b1: "complex_vector.span basis = UNIV"
     and b2: "cindependent basis"
     and b3:"finite basis"
     using finite_basis by auto
   have "\<exists>C>0. \<forall>\<psi> b. cmod (crepresentation basis \<psi> b) \<le> \<parallel>\<psi>\<parallel> * C"
     using finite_cspan_crepresentation_bounded[where B = basis] b2 b3 by blast
   then obtain C where s1: "cmod (crepresentation basis \<psi> b) \<le> \<parallel>\<psi>\<parallel> * C"
     and s2: "C > 0"
   for \<psi> b by blast
   define M where "M = C * (\<Sum>a\<in>basis. \<parallel>f a\<parallel>)"
   have "\<parallel>f x\<parallel> \<le> \<parallel>x\<parallel> * M"
     for x
   proof-
     define r where "r b = crepresentation basis x b" for b
     have x_span: "x \<in> complex_vector.span basis"
       by (simp add: b1)
     have f0: "v \<in> basis"
       if "r v \<noteq> 0" for v
       using complex_vector.representation_ne_zero r_def that by auto
     have w:"{a|a. r a \<noteq> 0} \<subseteq> basis"
       using f0 by blast
     hence f1: "finite {a|a. r a \<noteq> 0}"
       using b3 rev_finite_subset by auto
     have f2: "(\<Sum>a| r a \<noteq> 0. r a *\<^sub>C a) = x"
       unfolding r_def
       using b2 complex_vector.sum_nonzero_representation_eq x_span
         Collect_cong  by fastforce
     have g1: "(\<Sum>a\<in>basis. crepresentation basis x a *\<^sub>C a) = x"
       by (simp add: b2 b3 complex_vector.sum_representation_eq x_span)
     have f3: "(\<Sum>a\<in>basis. r a *\<^sub>C a) = x"
       unfolding r_def
       by (simp add: g1)
     hence "f x = f (\<Sum>a\<in>basis. r a *\<^sub>C a)"
       by simp
     also have "\<dots> = (\<Sum>a\<in>basis. r a *\<^sub>C f a)"
       by (smt (verit, ccfv_SIG) assms complex_vector.linear_scale complex_vector.linear_sum sum.cong)
     finally have "f x = (\<Sum>a\<in>basis. r a *\<^sub>C f a)".
     hence "\<parallel>f x\<parallel> = \<parallel>(\<Sum>a\<in>basis. r a *\<^sub>C f a)\<parallel>"
       by simp
     also have "\<dots> \<le> (\<Sum>a\<in>basis. \<parallel>r a *\<^sub>C f a\<parallel>)"
       by (simp add: sum_norm_le)
     also have "\<dots> \<le> (\<Sum>a\<in>basis. \<parallel>r a\<parallel> * \<parallel>f a\<parallel>)"
       by simp
     also have "\<dots> \<le> (\<Sum>a\<in>basis. \<parallel>x\<parallel> * C * \<parallel>f a\<parallel>)"
       using sum_mono s1 unfolding r_def
       by (simp add: sum_mono mult_right_mono)
     also have "\<dots> \<le> \<parallel>x\<parallel> * C * (\<Sum>a\<in>basis. \<parallel>f a\<parallel>)"
       using sum_distrib_left
       by (smt sum.cong)
     also have "\<dots> = \<parallel>x\<parallel> * M"
       unfolding M_def
       by linarith
     finally show ?thesis .
   qed
   thus ?thesis
     using assms bounded_clinear_def bounded_clinear_axioms_def by blast
 qed
 
 
 lemma summable_on_scaleR_left_converse:
   \<comment> \<open>This result has nothing to do with the bounded operator library but it
       uses @{thm [source] finite_span_closed} so it is proven here.\<close>
   fixes f :: \<open>'b \<Rightarrow> real\<close>
     and c :: \<open>'a :: real_normed_vector\<close>
   assumes \<open>c \<noteq> 0\<close>
   assumes \<open>(\<lambda>x. f x *\<^sub>R c) summable_on A\<close>
   shows \<open>f summable_on A\<close>
 proof -
   define fromR toR T where \<open>fromR x = x *\<^sub>R c\<close> and \<open>toR = inv fromR\<close> and \<open>T = range fromR\<close> for x :: real
   have \<open>additive fromR\<close>
     by (simp add: fromR_def additive.intro scaleR_left_distrib)
   have \<open>inj fromR\<close>
     by (simp add: fromR_def \<open>c \<noteq> 0\<close> inj_def)
   have toR_fromR: \<open>toR (fromR x) = x\<close> for x
     by (simp add: \<open>inj fromR\<close> toR_def)
   have fromR_toR: \<open>fromR (toR x) = x\<close> if \<open>x \<in> T\<close> for x
     by (metis T_def f_inv_into_f that toR_def)
 
   have 1: \<open>sum (toR \<circ> (fromR \<circ> f)) F = toR (sum (fromR \<circ> f) F)\<close> if \<open>finite F\<close> for F
     by (simp add: o_def additive.sum[OF \<open>additive fromR\<close>, symmetric] toR_fromR)
   have 2: \<open>sum (fromR \<circ> f) F \<in> T\<close> if \<open>finite F\<close> for F
     by (simp add: o_def additive.sum[OF \<open>additive fromR\<close>, symmetric] T_def)
   have 3: \<open>(toR \<longlongrightarrow> toR x) (at x within T)\<close> for x
   proof (cases \<open>x \<in> T\<close>)
     case True
     have \<open>dist (toR y) (toR x) < e\<close> if \<open>y\<in>T\<close> \<open>e>0\<close> \<open>dist y x < e * norm c\<close> for e y
     proof -
       obtain x' y' where x: \<open>x = fromR x'\<close> and y: \<open>y = fromR y'\<close>
         using T_def True \<open>y \<in> T\<close> by blast
       have \<open>dist (toR y) (toR x) = dist (fromR (toR y)) (fromR (toR x)) / norm c\<close>
         by (auto simp: dist_real_def fromR_def \<open>c \<noteq> 0\<close>)
       also have \<open>\<dots> = dist y x / norm c\<close>
         using \<open>x\<in>T\<close> \<open>y\<in>T\<close> by (simp add: fromR_toR)
       also have \<open>\<dots> < e\<close>
         using \<open>dist y x < e * norm c\<close>
         by (simp add: divide_less_eq that(2))
       finally show ?thesis
         by (simp add: x y toR_fromR)
     qed
     then show ?thesis
       apply (auto simp: tendsto_iff at_within_def eventually_inf_principal eventually_nhds_metric)
       by (metis assms(1) div_0 divide_less_eq zero_less_norm_iff)
   next
     case False
     have \<open>T = span {c}\<close>
       by (simp add: T_def fromR_def span_singleton)
     then have \<open>closed T\<close>
       by simp
     with False have \<open>x \<notin> closure T\<close>
       by simp
     then have \<open>(at x within T) = bot\<close>
       by (rule not_in_closure_trivial_limitI)
     then show ?thesis
       by simp
   qed
   have 4: \<open>(fromR \<circ> f) summable_on A\<close>
     by (simp add: assms(2) fromR_def summable_on_cong)
 
   have \<open>(toR o (fromR o f)) summable_on A\<close>
     using 1 2 3 4 
     by (rule summable_on_comm_additive_general[where T=T])
   with toR_fromR
   show ?thesis
     by (auto simp: o_def)
 qed
 
 lemma infsum_scaleR_left:
   \<comment> \<open>This result has nothing to do with the bounded operator library but it
       uses @{thm [source] finite_span_closed} so it is proven here.
 
       It is a strengthening of @{thm [source] infsum_scaleR_left}.\<close>
   fixes c :: \<open>'a :: real_normed_vector\<close>
   shows "infsum (\<lambda>x. f x *\<^sub>R c) A = infsum f A *\<^sub>R c"
 proof (cases \<open>f summable_on A\<close>)
   case True
   then show ?thesis 
    apply (subst asm_rl[of \<open>(\<lambda>x. f x *\<^sub>R c) = (\<lambda>y. y *\<^sub>R c) o f\<close>], simp add: o_def)
    apply (rule infsum_comm_additive)
   using True by (auto simp add: scaleR_left.additive_axioms)
 next
   case False
   then have \<open>\<not> (\<lambda>x. f x *\<^sub>R c) summable_on A\<close> if \<open>c \<noteq> 0\<close>
     using summable_on_scaleR_left_converse[where A=A and f=f and c=c]
     using that by auto
   with False show ?thesis
     apply (cases \<open>c = 0\<close>)
     by (auto simp add: infsum_not_exists)
 qed
 
 lemma infsum_of_real: 
   shows \<open>(\<Sum>\<^sub>\<infinity>x\<in>A. of_real (f x) :: 'b::{real_normed_vector, real_algebra_1}) = of_real (\<Sum>\<^sub>\<infinity>x\<in>A. f x)\<close>
   \<comment> \<open>This result has nothing to do with the bounded operator library but it
       uses @{thm [source] finite_span_closed} so it is proven here.\<close>
   unfolding of_real_def
   by (rule infsum_scaleR_left)
 
 
 
 subsection \<open>Closed subspaces\<close>
 
 lemma csubspace_INF[simp]: "(\<And>x. x \<in> A \<Longrightarrow> csubspace x) \<Longrightarrow> csubspace (\<Inter>A)"
   by (simp add: complex_vector.subspace_Inter)
 
 locale closed_csubspace =
   fixes A::"('a::{complex_vector,topological_space}) set"
   assumes subspace: "csubspace A"
   assumes closed: "closed A"
 
 declare closed_csubspace.subspace[simp]
 
 lemma closure_is_csubspace[simp]:
   fixes A::"('a::complex_normed_vector) set"
   assumes \<open>csubspace A\<close>
   shows \<open>csubspace (closure A)\<close>
 proof-
   have "x \<in> closure A \<Longrightarrow> y \<in> closure A \<Longrightarrow> x+y \<in> closure A" for x y
   proof-
     assume \<open>x\<in>(closure A)\<close>
     then obtain xx where \<open>\<forall> n::nat. xx n \<in> A\<close> and \<open>xx \<longlonglongrightarrow> x\<close>
       using closure_sequential by blast
     assume \<open>y\<in>(closure A)\<close>
     then obtain yy where \<open>\<forall> n::nat. yy n \<in> A\<close> and \<open>yy \<longlonglongrightarrow> y\<close>
       using closure_sequential by blast
     have \<open>\<forall> n::nat. (xx n) + (yy n) \<in> A\<close>
       using \<open>\<forall>n. xx n \<in> A\<close> \<open>\<forall>n. yy n \<in> A\<close> assms complex_vector.subspace_def
       by (simp add: complex_vector.subspace_def)
     hence  \<open>(\<lambda> n. (xx n) + (yy n)) \<longlonglongrightarrow> x + y\<close> using  \<open>xx \<longlonglongrightarrow> x\<close> \<open>yy \<longlonglongrightarrow> y\<close>
       by (simp add: tendsto_add)
     thus ?thesis using  \<open>\<forall> n::nat. (xx n) + (yy n) \<in> A\<close>
       by (meson closure_sequential)
   qed
   moreover have "x\<in>(closure A) \<Longrightarrow> c *\<^sub>C x \<in> (closure A)" for x c
   proof-
     assume \<open>x\<in>(closure A)\<close>
     then obtain xx where \<open>\<forall> n::nat. xx n \<in> A\<close> and \<open>xx \<longlonglongrightarrow> x\<close>
       using closure_sequential by blast
     have \<open>\<forall> n::nat. c *\<^sub>C (xx n) \<in> A\<close>
       using \<open>\<forall>n. xx n \<in> A\<close> assms complex_vector.subspace_def
       by (simp add: complex_vector.subspace_def)
     have \<open>isCont (\<lambda> t. c *\<^sub>C t) x\<close>
       using bounded_clinear.bounded_linear bounded_clinear_scaleC_right linear_continuous_at by auto
     hence  \<open>(\<lambda> n. c *\<^sub>C (xx n)) \<longlonglongrightarrow> c *\<^sub>C x\<close> using  \<open>xx \<longlonglongrightarrow> x\<close>
       by (simp add: isCont_tendsto_compose)
     thus ?thesis using  \<open>\<forall> n::nat. c *\<^sub>C (xx n) \<in> A\<close>
       by (meson closure_sequential)
   qed
   moreover have "0 \<in> (closure A)"
     using assms closure_subset complex_vector.subspace_def
     by (metis in_mono)
   ultimately show ?thesis
     by (simp add: complex_vector.subspaceI)
 qed
 
 lemma csubspace_set_plus:
   assumes \<open>csubspace A\<close> and \<open>csubspace B\<close>
   shows \<open>csubspace (A + B)\<close>
 proof -
   define C where \<open>C = {\<psi>+\<phi>| \<psi> \<phi>. \<psi>\<in>A \<and> \<phi>\<in>B}\<close>
   have  "x\<in>C \<Longrightarrow> y\<in>C \<Longrightarrow> x+y\<in>C" for x y
     using C_def assms(1) assms(2) complex_vector.subspace_add complex_vector.subspace_sums by blast
   moreover have "c *\<^sub>C x \<in> C" if \<open>x\<in>C\<close> for x c
   proof -
     have "csubspace C"
       by (simp add: C_def assms(1) assms(2) complex_vector.subspace_sums)
     then show ?thesis
       using that by (simp add: complex_vector.subspace_def)
   qed
   moreover have  "0 \<in> C"
     using  \<open>C = {\<psi> + \<phi> |\<psi> \<phi>. \<psi> \<in> A \<and> \<phi> \<in> B}\<close> add.inverse_neutral add_uminus_conv_diff assms(1) assms(2) diff_0  mem_Collect_eq
       add.right_inverse
     by (metis (mono_tags, lifting) complex_vector.subspace_0)
   ultimately show ?thesis
     unfolding C_def complex_vector.subspace_def
     by (smt mem_Collect_eq set_plus_elim set_plus_intro)
 qed
 
 lemma closed_csubspace_0[simp]:
   "closed_csubspace ({0} :: ('a::{complex_vector,t1_space}) set)"
 proof-
   have \<open>csubspace {0}\<close>
     using add.right_neutral complex_vector.subspace_def scaleC_right.zero
     by blast
   moreover have "closed ({0} :: 'a set)"
     by simp
   ultimately show ?thesis
     by (simp add: closed_csubspace_def)
 qed
 
 lemma closed_csubspace_UNIV[simp]: "closed_csubspace (UNIV::('a::{complex_vector,topological_space}) set)"
 proof-
   have \<open>csubspace UNIV\<close>
     by simp
   moreover have \<open>closed UNIV\<close>
     by simp
   ultimately show ?thesis
     unfolding closed_csubspace_def by auto
 qed
 
 lemma closed_csubspace_inter[simp]:
   assumes "closed_csubspace A" and "closed_csubspace B"
   shows "closed_csubspace (A\<inter>B)"
 proof-
   obtain C where \<open>C = A \<inter> B\<close> by blast
   have \<open>csubspace C\<close>
   proof-
     have "x\<in>C \<Longrightarrow> y\<in>C \<Longrightarrow> x+y\<in>C" for x y
       by (metis IntD1 IntD2 IntI \<open>C = A \<inter> B\<close> assms(1) assms(2) complex_vector.subspace_def closed_csubspace_def)
     moreover have "x\<in>C \<Longrightarrow> c *\<^sub>C x \<in> C" for x c
       by (metis IntD1 IntD2 IntI \<open>C = A \<inter> B\<close> assms(1) assms(2) complex_vector.subspace_def closed_csubspace_def)
     moreover have "0 \<in> C"
       using  \<open>C = A \<inter> B\<close> assms(1) assms(2) complex_vector.subspace_def closed_csubspace_def by fastforce
     ultimately show ?thesis
       by (simp add: complex_vector.subspace_def)
   qed
   moreover have \<open>closed C\<close>
     using  \<open>C = A \<inter> B\<close>
     by (simp add: assms(1) assms(2) closed_Int closed_csubspace.closed)
   ultimately show ?thesis
     using  \<open>C = A \<inter> B\<close>
     by (simp add: closed_csubspace_def)
 qed
 
 
 lemma closed_csubspace_INF[simp]:
   assumes a1: "\<forall>A\<in>\<A>. closed_csubspace A"
   shows "closed_csubspace (\<Inter>\<A>)"
 proof-
   have \<open>csubspace (\<Inter>\<A>)\<close>
     by (simp add: assms closed_csubspace.subspace complex_vector.subspace_Inter)
   moreover have \<open>closed (\<Inter>\<A>)\<close>
     by (simp add: assms closed_Inter closed_csubspace.closed)
   ultimately show ?thesis
     by (simp add: closed_csubspace.intro)
 qed
 
 
 typedef (overloaded) ('a::"{complex_vector,topological_space}")
   ccsubspace = \<open>{S::'a set. closed_csubspace S}\<close>
   morphisms space_as_set Abs_clinear_space
   using Complex_Vector_Spaces.closed_csubspace_UNIV by blast
 
 setup_lifting type_definition_ccsubspace
 
 lemma csubspace_space_as_set[simp]: \<open>csubspace (space_as_set S)\<close>
   by (metis closed_csubspace_def mem_Collect_eq space_as_set)
 
 lemma closed_space_as_set[simp]: \<open>closed (space_as_set S)\<close>
   apply transfer by (simp add: closed_csubspace.closed)
 
+lemma zero_space_as_set[simp]: \<open>0 \<in> space_as_set A\<close>
+  by (simp add: complex_vector.subspace_0)
+
 instantiation ccsubspace :: (complex_normed_vector) scaleC begin
 lift_definition scaleC_ccsubspace :: "complex \<Rightarrow> 'a ccsubspace \<Rightarrow> 'a ccsubspace" is
   "\<lambda>c S. (*\<^sub>C) c ` S"
 proof
   show "csubspace ((*\<^sub>C) c ` S)"
     if "closed_csubspace S"
     for c :: complex
       and S :: "'a set"
     using that
     by (simp add: closed_csubspace.subspace complex_vector.linear_subspace_image)
   show "closed ((*\<^sub>C) c ` S)"
     if "closed_csubspace S"
     for c :: complex
       and S :: "'a set"
     using that
     by (simp add: closed_scaleC closed_csubspace.closed)
 qed
 
 lift_definition scaleR_ccsubspace :: "real \<Rightarrow> 'a ccsubspace \<Rightarrow> 'a ccsubspace" is
   "\<lambda>c S. (*\<^sub>R) c ` S"
 proof
   show "csubspace ((*\<^sub>R) r ` S)"
     if "closed_csubspace S"
     for r :: real
       and S :: "'a set"
     using that   using bounded_clinear_def bounded_clinear_scaleC_right scaleR_scaleC
     by (simp add: scaleR_scaleC closed_csubspace.subspace complex_vector.linear_subspace_image)
   show "closed ((*\<^sub>R) r ` S)"
     if "closed_csubspace S"
     for r :: real
       and S :: "'a set"
     using that
     by (simp add: closed_scaling closed_csubspace.closed)
 qed
 
 instance
 proof
   show "((*\<^sub>R) r::'a ccsubspace \<Rightarrow> _) = (*\<^sub>C) (complex_of_real r)" for r :: real
     by (simp add: scaleR_scaleC scaleC_ccsubspace_def scaleR_ccsubspace_def)
 qed
 end
 
 instantiation ccsubspace :: ("{complex_vector,t1_space}") bot begin
 lift_definition bot_ccsubspace :: \<open>'a ccsubspace\<close> is \<open>{0}\<close>
   by simp
 instance..
 end
 
 lemma zero_cblinfun_image[simp]: "0 *\<^sub>C S = bot" for S :: "_ ccsubspace"
 proof transfer
   have "(0::'b) \<in> (\<lambda>x. 0) ` S"
     if "closed_csubspace S"
     for S::"'b set"
     using that unfolding closed_csubspace_def
     by (simp add: complex_vector.linear_subspace_image complex_vector.module_hom_zero
         complex_vector.subspace_0)
   thus "(*\<^sub>C) 0 ` S = {0::'b}"
     if "closed_csubspace (S::'b set)"
     for S :: "'b set"
     using that
     by (auto intro !: exI [of _ 0])
 qed
 
 lemma csubspace_scaleC_invariant:
   fixes a S
   assumes \<open>a \<noteq> 0\<close> and \<open>csubspace S\<close>
   shows \<open>(*\<^sub>C) a ` S = S\<close>
 proof-
   have  \<open>x \<in> (*\<^sub>C) a ` S \<Longrightarrow> x \<in> S\<close>
     for x
     using assms(2) complex_vector.subspace_scale by blast
   moreover have  \<open>x \<in> S \<Longrightarrow> x \<in> (*\<^sub>C) a ` S\<close>
     for x
   proof -
     assume "x \<in> S"
     hence "\<exists>c aa. (c / a) *\<^sub>C aa \<in> S \<and> c *\<^sub>C aa = x"
       using assms(2) complex_vector.subspace_def scaleC_one by metis
     hence "\<exists>aa. aa \<in> S \<and> a *\<^sub>C aa = x"
       using assms(1) by auto
     thus ?thesis
       by (meson image_iff)
   qed
   ultimately show ?thesis by blast
 qed
 
 
 lemma ccsubspace_scaleC_invariant[simp]: "a \<noteq> 0 \<Longrightarrow> a *\<^sub>C S = S" for S :: "_ ccsubspace"
   apply transfer
   by (simp add: closed_csubspace.subspace csubspace_scaleC_invariant)
 
 
 instantiation ccsubspace :: ("{complex_vector,topological_space}") "top"
 begin
 lift_definition top_ccsubspace :: \<open>'a ccsubspace\<close> is \<open>UNIV\<close>
   by simp
 
 instance ..
 end
 
 lemma space_as_set_bot[simp]: \<open>space_as_set bot = {0}\<close>
   by (rule bot_ccsubspace.rep_eq)
 
 lemma ccsubspace_top_not_bot[simp]:
   "(top::'a::{complex_vector,t1_space,not_singleton} ccsubspace) \<noteq> bot"
   (* The type class t1_space is needed because the definition of bot in ccsubspace needs it *)
   by (metis UNIV_not_singleton bot_ccsubspace.rep_eq top_ccsubspace.rep_eq)
 
 lemma ccsubspace_bot_not_top[simp]:
   "(bot::'a::{complex_vector,t1_space,not_singleton} ccsubspace) \<noteq> top"
   using ccsubspace_top_not_bot by metis
 
 instantiation ccsubspace :: ("{complex_vector,topological_space}") "Inf"
 begin
 lift_definition Inf_ccsubspace::\<open>'a ccsubspace set \<Rightarrow> 'a ccsubspace\<close>
   is \<open>\<lambda> S. \<Inter> S\<close>
 proof
   fix S :: "'a set set"
   assume closed: "closed_csubspace x" if \<open>x \<in> S\<close> for x
   show "csubspace (\<Inter> S::'a set)"
     by (simp add: closed closed_csubspace.subspace)
   show "closed (\<Inter> S::'a set)"
     by (simp add: closed closed_csubspace.closed)
 qed
 
 instance ..
 end
 
 lift_definition ccspan :: "'a::complex_normed_vector set \<Rightarrow> 'a ccsubspace"
   is "\<lambda>G. closure (cspan G)"
 proof (rule closed_csubspace.intro)
   fix S :: "'a set"
   show "csubspace (closure (cspan S))"
     by (simp add: closure_is_csubspace)
   show "closed (closure (cspan S))"
     by simp
 qed
 
 lemma ccspan_canonical_basis[simp]: "ccspan (set canonical_basis) = top"
   using ccspan.rep_eq space_as_set_inject top_ccsubspace.rep_eq
     closure_UNIV is_generator_set
   by metis
 
 lemma ccspan_Inf_def: \<open>ccspan A = Inf {S. A \<subseteq> space_as_set S}\<close>
   for A::\<open>('a::cbanach) set\<close>
 proof-
   have \<open>x \<in> space_as_set (ccspan A)
     \<Longrightarrow> x \<in> space_as_set (Inf {S. A \<subseteq> space_as_set S})\<close>
     for x::'a
   proof-
     assume \<open>x \<in> space_as_set (ccspan A)\<close>
     hence "x \<in> closure (cspan A)"
       by (simp add: ccspan.rep_eq)
     hence \<open>x \<in> closure (complex_vector.span A)\<close>
       unfolding ccspan_def
       by simp
     hence \<open>\<exists> y::nat \<Rightarrow> 'a. (\<forall> n. y n \<in> (complex_vector.span A)) \<and> y \<longlonglongrightarrow> x\<close>
       by (simp add: closure_sequential)
     then obtain y where \<open>\<forall> n. y n \<in> (complex_vector.span A)\<close> and \<open>y \<longlonglongrightarrow> x\<close>
       by blast
     have \<open>y n \<in> \<Inter> {S. (complex_vector.span A) \<subseteq> S \<and> closed_csubspace S}\<close>
       for n
       using  \<open>\<forall> n. y n \<in> (complex_vector.span A)\<close>
       by auto
 
     have \<open>closed_csubspace S \<Longrightarrow> closed S\<close>
       for S::\<open>'a set\<close>
       by (simp add: closed_csubspace.closed)
     hence \<open>closed ( \<Inter> {S. (complex_vector.span A) \<subseteq> S \<and> closed_csubspace S})\<close>
       by simp
     hence \<open>x \<in> \<Inter> {S. (complex_vector.span A) \<subseteq> S \<and> closed_csubspace S}\<close> using \<open>y \<longlonglongrightarrow> x\<close>
       using \<open>\<And>n. y n \<in> \<Inter> {S. complex_vector.span A \<subseteq> S \<and> closed_csubspace S}\<close> closed_sequentially
       by blast
     moreover have \<open>{S. A \<subseteq> S \<and> closed_csubspace S} \<subseteq> {S. (complex_vector.span A) \<subseteq> S \<and> closed_csubspace S}\<close>
       using Collect_mono_iff
       by (simp add: Collect_mono_iff closed_csubspace.subspace complex_vector.span_minimal)
     ultimately have \<open>x \<in> \<Inter> {S. A \<subseteq> S \<and> closed_csubspace S}\<close>
       by blast
     moreover have "(x::'a) \<in> \<Inter> {x. A \<subseteq> x \<and> closed_csubspace x}"
       if "(x::'a) \<in> \<Inter> {S. A \<subseteq> S \<and> closed_csubspace S}"
       for x :: 'a
         and A :: "'a set"
       using that
       by simp
     ultimately show \<open>x \<in> space_as_set (Inf {S. A \<subseteq> space_as_set S})\<close>
       apply transfer.
   qed
   moreover have \<open>x \<in> space_as_set (Inf {S. A \<subseteq> space_as_set S})
              \<Longrightarrow> x \<in> space_as_set (ccspan A)\<close>
     for x::'a
   proof-
     assume \<open>x \<in> space_as_set (Inf {S. A \<subseteq> space_as_set S})\<close>
     hence \<open>x \<in> \<Inter> {S. A \<subseteq> S \<and> closed_csubspace S}\<close>
       apply transfer
       by blast
     moreover have \<open>{S. (complex_vector.span A) \<subseteq> S \<and> closed_csubspace S} \<subseteq> {S. A \<subseteq> S \<and> closed_csubspace S}\<close>
       using Collect_mono_iff complex_vector.span_superset by fastforce
     ultimately have \<open>x \<in> \<Inter> {S. (complex_vector.span A) \<subseteq> S \<and> closed_csubspace S}\<close>
       by blast
     thus \<open>x \<in> space_as_set (ccspan A)\<close>
       by (metis (no_types, lifting) Inter_iff space_as_set closure_subset mem_Collect_eq ccspan.rep_eq)
   qed
   ultimately have \<open>space_as_set (ccspan A) = space_as_set (Inf {S. A \<subseteq> space_as_set S})\<close>
     by blast
   thus ?thesis
     using space_as_set_inject by auto
 qed
 
 lemma cspan_singleton_scaleC[simp]: "(a::complex)\<noteq>0 \<Longrightarrow> cspan { a *\<^sub>C \<psi> } = cspan {\<psi>}"
   for \<psi>::"'a::complex_vector"
   by (smt complex_vector.dependent_single complex_vector.independent_insert
       complex_vector.scale_eq_0_iff complex_vector.span_base complex_vector.span_redundant
       complex_vector.span_scale doubleton_eq_iff insert_absorb insert_absorb2 insert_commute
       singletonI)
 
 lemma closure_is_closed_csubspace[simp]:
   fixes S::\<open>'a::complex_normed_vector set\<close>
   assumes \<open>csubspace S\<close>
   shows \<open>closed_csubspace (closure S)\<close>
 proof-
   fix x y :: 'a and c :: complex
   have "x + y \<in> closure S"
     if "x \<in> closure S"
       and "y \<in> closure S"
   proof-
     have \<open>\<exists> r. (\<forall> n::nat. r n \<in> S) \<and> r \<longlonglongrightarrow> x\<close>
       using closure_sequential that(1) by auto
     then obtain r where \<open>\<forall> n::nat. r n \<in> S\<close> and \<open>r \<longlonglongrightarrow> x\<close>
       by blast
     have \<open>\<exists> s. (\<forall> n::nat. s n \<in> S) \<and> s \<longlonglongrightarrow> y\<close>
       using closure_sequential that(2) by auto
     then obtain s where \<open>\<forall> n::nat. s n \<in> S\<close> and \<open>s \<longlonglongrightarrow> y\<close>
       by blast
     have \<open>\<forall> n::nat. r n + s n \<in> S\<close>
       using \<open>\<forall>n. r n \<in> S\<close> \<open>\<forall>n. s n \<in> S\<close> assms complex_vector.subspace_add by blast
     moreover have \<open>(\<lambda> n. r n + s n) \<longlonglongrightarrow> x + y\<close>
       by (simp add: \<open>r \<longlonglongrightarrow> x\<close> \<open>s \<longlonglongrightarrow> y\<close> tendsto_add)
     ultimately show ?thesis
       using assms that(1) that(2)
       by (simp add: complex_vector.subspace_add)
   qed
   moreover have "c *\<^sub>C x \<in> closure S"
     if "x \<in> closure S"
   proof-
     have \<open>\<exists> y. (\<forall> n::nat. y n \<in> S) \<and> y \<longlonglongrightarrow> x\<close>
       using Elementary_Topology.closure_sequential that by auto
     then obtain y where \<open>\<forall> n::nat. y n \<in> S\<close> and \<open>y \<longlonglongrightarrow> x\<close>
       by blast
     have \<open>isCont (scaleC c) x\<close>
       by simp
     hence \<open>(\<lambda> n. scaleC c (y n)) \<longlonglongrightarrow> scaleC c x\<close>
       using  \<open>y \<longlonglongrightarrow> x\<close>
       by (simp add: isCont_tendsto_compose)
     from  \<open>\<forall> n::nat. y n \<in> S\<close>
     have  \<open>\<forall> n::nat. scaleC c (y n) \<in> S\<close>
       using assms complex_vector.subspace_scale by auto
     thus ?thesis
       using assms that
       by (simp add: complex_vector.subspace_scale)
   qed
   moreover have "0 \<in> closure S"
     by (simp add: assms complex_vector.subspace_0)
   moreover have "closed (closure S)"
     by auto
   ultimately show ?thesis
     by (simp add: assms closed_csubspace_def)
 qed
 
 lemma ccspan_singleton_scaleC[simp]: "(a::complex)\<noteq>0 \<Longrightarrow> ccspan {a *\<^sub>C \<psi>} = ccspan {\<psi>}"
   apply transfer by simp
 
 lemma clinear_continuous_at:
   assumes \<open>bounded_clinear f\<close>
   shows \<open>isCont f x\<close>
   by (simp add: assms bounded_clinear.bounded_linear linear_continuous_at)
 
 lemma clinear_continuous_within:
   assumes \<open>bounded_clinear f\<close>
   shows \<open>continuous (at x within s) f\<close>
   by (simp add: assms bounded_clinear.bounded_linear linear_continuous_within)
 
 lemma antilinear_continuous_at:
   assumes \<open>bounded_antilinear f\<close>
   shows \<open>isCont f x\<close>
   by (simp add: assms bounded_antilinear.bounded_linear linear_continuous_at)
 
 lemma antilinear_continuous_within:
   assumes \<open>bounded_antilinear f\<close>
   shows \<open>continuous (at x within s) f\<close>
   by (simp add: assms bounded_antilinear.bounded_linear linear_continuous_within)
 
 lemma bounded_clinear_eq_on:
   fixes A B :: "'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector"
   assumes \<open>bounded_clinear A\<close> and \<open>bounded_clinear B\<close> and
     eq: \<open>\<And>x. x \<in> G \<Longrightarrow> A x = B x\<close> and t: \<open>t \<in> closure (cspan G)\<close>
   shows \<open>A t = B t\<close>
 proof -
   have eq': \<open>A t = B t\<close> if \<open>t \<in> cspan G\<close> for t
     using _ _ that eq apply (rule complex_vector.linear_eq_on)
     by (auto simp: assms bounded_clinear.clinear)
   have \<open>A t - B t = 0\<close>
     using _ _ t apply (rule continuous_constant_on_closure)
     by (auto simp add: eq' assms(1) assms(2) clinear_continuous_at continuous_at_imp_continuous_on)
   then show ?thesis
     by auto
 qed
 
 instantiation ccsubspace :: ("{complex_vector,topological_space}") "order"
 begin
 lift_definition less_eq_ccsubspace :: \<open>'a ccsubspace \<Rightarrow> 'a ccsubspace \<Rightarrow> bool\<close>
   is  \<open>(\<subseteq>)\<close>.
 declare less_eq_ccsubspace_def[code del]
 lift_definition less_ccsubspace :: \<open>'a ccsubspace \<Rightarrow> 'a ccsubspace \<Rightarrow> bool\<close>
   is \<open>(\<subset>)\<close>.
 declare less_ccsubspace_def[code del]
 instance
 proof
   fix x y z :: "'a ccsubspace"
   show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
     by (simp add: less_eq_ccsubspace.rep_eq less_le_not_le less_ccsubspace.rep_eq)
   show "x \<le> x"
     by (simp add: less_eq_ccsubspace.rep_eq)
   show "x \<le> z" if "x \<le> y" and "y \<le> z"
     using that less_eq_ccsubspace.rep_eq by auto
   show "x = y" if "x \<le> y" and "y \<le> x"
     using that by (simp add: space_as_set_inject less_eq_ccsubspace.rep_eq)
 qed
 end
 
 lemma ccspan_leqI:
   assumes \<open>M \<subseteq> space_as_set S\<close>
   shows \<open>ccspan M \<le> S\<close>
   using assms apply transfer
   by (simp add: closed_csubspace.closed closure_minimal complex_vector.span_minimal)
 
 lemma ccspan_mono:
   assumes \<open>A \<subseteq> B\<close>
   shows \<open>ccspan A \<le> ccspan B\<close>
   apply (transfer fixing: A B)
   by (simp add: assms closure_mono complex_vector.span_mono)
 
 lemma bounded_sesquilinear_add:
   \<open>bounded_sesquilinear (\<lambda> x y. A x y + B x y)\<close> if \<open>bounded_sesquilinear A\<close> and \<open>bounded_sesquilinear B\<close>
 proof
   fix a a' :: 'a and b b' :: 'b and r :: complex
   show "A (a + a') b + B (a + a') b = (A a b + B a b) + (A a' b + B a' b)"
     by (simp add: bounded_sesquilinear.add_left that(1) that(2))
   show \<open>A a (b + b') + B a (b + b') = (A a b + B a b) + (A a b' + B a b')\<close>
     by (simp add: bounded_sesquilinear.add_right that(1) that(2))
   show \<open>A (r *\<^sub>C a) b + B (r *\<^sub>C a) b = cnj r *\<^sub>C (A a b + B a b)\<close>
     by (simp add: bounded_sesquilinear.scaleC_left scaleC_add_right that(1) that(2))
   show \<open>A a (r *\<^sub>C b) + B a (r *\<^sub>C b) = r *\<^sub>C (A a b + B a b)\<close>
     by (simp add: bounded_sesquilinear.scaleC_right scaleC_add_right that(1) that(2))
   show \<open>\<exists>K. \<forall>a b. norm (A a b + B a b) \<le> norm a * norm b * K\<close>
   proof-
     have \<open>\<exists> KA. \<forall> a b. norm (A a b) \<le> norm a * norm b * KA\<close>
       by (simp add: bounded_sesquilinear.bounded that(1))
     then obtain KA where \<open>\<forall> a b. norm (A a b) \<le> norm a * norm b * KA\<close>
       by blast
     have \<open>\<exists> KB. \<forall> a b. norm (B a b) \<le> norm a * norm b * KB\<close>
       by (simp add: bounded_sesquilinear.bounded that(2))
     then obtain KB where \<open>\<forall> a b. norm (B a b) \<le> norm a * norm b * KB\<close>
       by blast
     have \<open>norm (A a b + B a b) \<le> norm a * norm b * (KA + KB)\<close>
       for a b
     proof-
       have \<open>norm (A a b + B a b) \<le> norm (A a b) +  norm (B a b)\<close>
         using norm_triangle_ineq by blast
       also have \<open>\<dots> \<le> norm a * norm b * KA + norm a * norm b * KB\<close>
         using  \<open>\<forall> a b. norm (A a b) \<le> norm a * norm b * KA\<close>
           \<open>\<forall> a b. norm (B a b) \<le> norm a * norm b * KB\<close>
         using add_mono by blast
       also have \<open>\<dots>=  norm a * norm b * (KA + KB)\<close>
         by (simp add: mult.commute ring_class.ring_distribs(2))
       finally show ?thesis
         by blast
     qed
     thus ?thesis by blast
   qed
 qed
 
 lemma bounded_sesquilinear_uminus:
   \<open>bounded_sesquilinear (\<lambda> x y. - A x y)\<close> if \<open>bounded_sesquilinear A\<close>
 proof
   fix a a' :: 'a and b b' :: 'b and r :: complex
   show "- A (a + a') b = (- A a b) + (- A a' b)"
     by (simp add: bounded_sesquilinear.add_left that)
   show \<open>- A a (b + b') = (- A a b) + (- A a b')\<close>
     by (simp add: bounded_sesquilinear.add_right that)
   show \<open>- A (r *\<^sub>C a) b = cnj r *\<^sub>C (- A a b)\<close>
     by (simp add: bounded_sesquilinear.scaleC_left that)
   show \<open>- A a (r *\<^sub>C b) = r *\<^sub>C (- A a b)\<close>
     by (simp add: bounded_sesquilinear.scaleC_right that)
   show \<open>\<exists>K. \<forall>a b. norm (- A a b) \<le> norm a * norm b * K\<close>
   proof-
     have \<open>\<exists> KA. \<forall> a b. norm (A a b) \<le> norm a * norm b * KA\<close>
       by (simp add: bounded_sesquilinear.bounded that(1))
     then obtain KA where \<open>\<forall> a b. norm (A a b) \<le> norm a * norm b * KA\<close>
       by blast
     have \<open>norm (- A a b) \<le> norm a * norm b * KA\<close>
       for a b
       by (simp add: \<open>\<forall>a b. norm (A a b) \<le> norm a * norm b * KA\<close>)
     thus ?thesis by blast
   qed
 qed
 
 lemma bounded_sesquilinear_diff:
   \<open>bounded_sesquilinear (\<lambda> x y. A x y - B x y)\<close> if \<open>bounded_sesquilinear A\<close> and \<open>bounded_sesquilinear B\<close>
 proof -
   have \<open>bounded_sesquilinear (\<lambda> x y. - B x y)\<close>
     using that(2) by (rule bounded_sesquilinear_uminus)
   then have \<open>bounded_sesquilinear (\<lambda> x y. A x y + (- B x y))\<close>
     using that(1) by (rule bounded_sesquilinear_add[rotated])
   then show ?thesis
     by auto
 qed
 
 lemma ccsubspace_leI:
   assumes t1: "space_as_set A \<subseteq> space_as_set B"
   shows "A \<le> B"
   using t1 apply transfer by -
 
 lemma ccspan_of_empty[simp]: "ccspan {} = bot"
 proof transfer
   show "closure (cspan {}) = {0::'a}"
     by simp
 qed
 
 
 instantiation ccsubspace :: ("{complex_vector,topological_space}") inf begin
 lift_definition inf_ccsubspace :: "'a ccsubspace \<Rightarrow> 'a ccsubspace \<Rightarrow> 'a ccsubspace"
   is "(\<inter>)" by simp
 instance .. end
 
 lemma space_as_set_inf[simp]: "space_as_set (A \<sqinter> B) = space_as_set A \<inter> space_as_set B"
   by (rule inf_ccsubspace.rep_eq)
 
 instantiation ccsubspace :: ("{complex_vector,topological_space}") order_top begin
 instance
 proof
   show "a \<le> \<top>"
     for a :: "'a ccsubspace"
     apply transfer
     by simp
 qed
 end
 
 
 instantiation ccsubspace :: ("{complex_vector,t1_space}") order_bot begin
 instance
 proof
   show "(\<bottom>::'a ccsubspace) \<le> a"
     for a :: "'a ccsubspace"
     apply transfer
     apply auto
     using closed_csubspace.subspace complex_vector.subspace_0 by blast
 qed
 end
 
 
 instantiation ccsubspace :: ("{complex_vector,topological_space}") semilattice_inf begin
 instance
 proof
   fix x y z :: \<open>'a ccsubspace\<close>
   show "x \<sqinter> y \<le> x"
     apply transfer by simp
   show "x \<sqinter> y \<le> y"
     apply transfer by simp
   show "x \<le> y \<sqinter> z" if "x \<le> y" and "x \<le> z"
     using that apply transfer by simp
 qed
 end
 
 
 instantiation ccsubspace :: ("{complex_vector,t1_space}") zero begin
 definition zero_ccsubspace :: "'a ccsubspace" where [simp]: "zero_ccsubspace = bot"
 lemma zero_ccsubspace_transfer[transfer_rule]: \<open>pcr_ccsubspace (=) {0} 0\<close>
   unfolding zero_ccsubspace_def by transfer_prover
 instance ..
 end
 
 lemma ccspan_0[simp]: \<open>ccspan {0} = 0\<close>
   apply transfer
   by simp
 
 definition \<open>rel_ccsubspace R x y = rel_set R (space_as_set x) (space_as_set y)\<close>
 
 
 lemma left_unique_rel_ccsubspace[transfer_rule]: \<open>left_unique (rel_ccsubspace R)\<close> if \<open>left_unique R\<close>
 proof (rule left_uniqueI)
   fix S T :: \<open>'a ccsubspace\<close> and U
   assume assms: \<open>rel_ccsubspace R S U\<close> \<open>rel_ccsubspace R T U\<close>
   have \<open>space_as_set S = space_as_set T\<close>
     apply (rule left_uniqueD)
       using that apply (rule left_unique_rel_set)
     using assms unfolding rel_ccsubspace_def by auto
   then show \<open>S = T\<close>
     by (simp add: space_as_set_inject)
 qed
 
 lemma right_unique_rel_ccsubspace[transfer_rule]: \<open>right_unique (rel_ccsubspace R)\<close> if \<open>right_unique R\<close>
   by (metis rel_ccsubspace_def right_unique_def right_unique_rel_set space_as_set_inject that)
 
 lemma bi_unique_rel_ccsubspace[transfer_rule]: \<open>bi_unique (rel_ccsubspace R)\<close> if \<open>bi_unique R\<close>
   by (metis (no_types, lifting) bi_unique_def bi_unique_rel_set rel_ccsubspace_def space_as_set_inject that)
 
 lemma converse_rel_ccsubspace: \<open>conversep (rel_ccsubspace R) = rel_ccsubspace (conversep R)\<close>
   by (auto simp: rel_ccsubspace_def[abs_def])
 
 lemma space_as_set_top[simp]: \<open>space_as_set top = UNIV\<close>
   by (rule top_ccsubspace.rep_eq)
 
 lemma ccsubspace_eqI:
   assumes \<open>\<And>x. x \<in> space_as_set S \<longleftrightarrow> x \<in> space_as_set T\<close>
   shows \<open>S = T\<close>
   by (metis Abs_clinear_space_cases Abs_clinear_space_inverse antisym assms subsetI)
 
+lemma ccspan_remove_0: \<open>ccspan (A - {0}) = ccspan A\<close>
+  apply transfer
+  by auto
+
+lemma sgn_in_spaceD: \<open>\<psi> \<in> space_as_set A\<close> if \<open>sgn \<psi> \<in> space_as_set A\<close> and \<open>\<psi> \<noteq> 0\<close>
+  for \<psi> :: \<open>_ :: complex_normed_vector\<close>
+  using that
+  apply (transfer fixing: \<psi>)
+  by (metis closed_csubspace.subspace complex_vector.subspace_scale divideC_field_simps(1) scaleR_eq_0_iff scaleR_scaleC sgn_div_norm sgn_zero_iff)
+
+lemma sgn_in_spaceI: \<open>sgn \<psi> \<in> space_as_set A\<close> if \<open>\<psi> \<in> space_as_set A\<close> 
+  for \<psi> :: \<open>_ :: complex_normed_vector\<close>
+  using that by (auto simp: sgn_div_norm scaleR_scaleC complex_vector.subspace_scale)
+
+lemma ccsubspace_leI_unit:
+  fixes A B :: \<open>_ :: complex_normed_vector ccsubspace\<close>
+  assumes "\<And>\<psi>. norm \<psi> = 1 \<Longrightarrow> \<psi> \<in> space_as_set A \<Longrightarrow> \<psi> \<in> space_as_set B"
+  shows "A \<le> B"
+proof (rule ccsubspace_leI, rule subsetI)
+  fix \<psi> assume \<psi>A: \<open>\<psi> \<in> space_as_set A\<close>
+  show \<open>\<psi> \<in> space_as_set B\<close>
+    apply (cases \<open>\<psi> = 0\<close>)
+    apply simp
+    using assms[of \<open>sgn \<psi>\<close>] \<psi>A sgn_in_spaceD sgn_in_spaceI 
+    by (auto simp: norm_sgn)
+qed
+
 subsection \<open>Closed sums\<close>
 
 definition closed_sum:: \<open>'a::{semigroup_add,topological_space} set \<Rightarrow> 'a set \<Rightarrow> 'a set\<close> where
   \<open>closed_sum A B = closure (A + B)\<close>
 
 notation closed_sum (infixl "+\<^sub>M" 65)
 
 lemma closed_sum_comm: \<open>A +\<^sub>M B = B +\<^sub>M A\<close> for A B :: "_::ab_semigroup_add"
   by (simp add: add.commute closed_sum_def)
 
 lemma closed_sum_left_subset: \<open>0 \<in> B \<Longrightarrow> A \<subseteq> A +\<^sub>M B\<close> for A B :: "_::monoid_add"
   by (metis add.right_neutral closed_sum_def closure_subset in_mono set_plus_intro subsetI)
 
 lemma closed_sum_right_subset: \<open>0 \<in> A \<Longrightarrow> B \<subseteq> A +\<^sub>M B\<close> for A B :: "_::monoid_add"
   by (metis add.left_neutral closed_sum_def closure_subset set_plus_intro subset_iff)
 
 lemma finite_cspan_closed_csubspace:
   assumes "finite (S::'a::complex_normed_vector set)"
   shows "closed_csubspace (cspan S)"
   by (simp add: assms closed_csubspace.intro)
 
 lemma closed_sum_is_sup:
   fixes A B C:: \<open>('a::{complex_vector,topological_space}) set\<close>
   assumes \<open>closed_csubspace C\<close>
   assumes \<open>A \<subseteq> C\<close> and \<open>B \<subseteq> C\<close>
   shows \<open>(A +\<^sub>M B) \<subseteq> C\<close>
 proof -
   have \<open>A + B \<subseteq> C\<close>
     using assms unfolding set_plus_def
     using closed_csubspace.subspace complex_vector.subspace_add by blast
   then show \<open>(A +\<^sub>M B) \<subseteq> C\<close>
     unfolding closed_sum_def
     using \<open>closed_csubspace C\<close>
     by (simp add: closed_csubspace.closed closure_minimal)
 qed
 
 lemma closed_subspace_closed_sum:
   fixes A B::"('a::complex_normed_vector) set"
   assumes a1: \<open>csubspace A\<close> and a2: \<open>csubspace B\<close>
   shows \<open>closed_csubspace (A +\<^sub>M B)\<close>
   using a1 a2 closed_sum_def
   by (metis closure_is_closed_csubspace csubspace_set_plus)
 
 
 lemma closed_sum_assoc:
   fixes A B C::"'a::real_normed_vector set"
   shows \<open>A +\<^sub>M (B +\<^sub>M C) = (A +\<^sub>M B) +\<^sub>M C\<close>
 proof -
   have \<open>A + closure B \<subseteq> closure (A + B)\<close> for A B :: "'a set"
     by (meson closure_subset closure_sum dual_order.trans order_refl set_plus_mono2)
   then have \<open>A +\<^sub>M (B +\<^sub>M C) = closure (A + (B + C))\<close>
     unfolding closed_sum_def
     by (meson antisym_conv closed_closure closure_minimal closure_mono closure_subset equalityD1 set_plus_mono2)
   moreover
   have \<open>closure A + B \<subseteq> closure (A + B)\<close> for A B :: "'a set"
     by (meson closure_subset closure_sum dual_order.trans order_refl set_plus_mono2)
   then have \<open>(A +\<^sub>M B) +\<^sub>M C = closure ((A + B) + C)\<close>
     unfolding closed_sum_def
     by (meson closed_closure closure_minimal closure_mono closure_subset eq_iff set_plus_mono2)
   ultimately show ?thesis
     by (simp add: ab_semigroup_add_class.add_ac(1))
 qed
 
 
 lemma closed_sum_zero_left[simp]:
   fixes A :: \<open>('a::{monoid_add, topological_space}) set\<close>
   shows \<open>{0} +\<^sub>M A = closure A\<close>
   unfolding closed_sum_def
   by (metis add.left_neutral set_zero)
 
 lemma closed_sum_zero_right[simp]:
   fixes A :: \<open>('a::{monoid_add, topological_space}) set\<close>
   shows \<open>A +\<^sub>M {0} = closure A\<close>
   unfolding closed_sum_def
   by (metis add.right_neutral set_zero)
 
 lemma closed_sum_closure_right[simp]:
   fixes A B :: \<open>'a::real_normed_vector set\<close>
   shows \<open>A +\<^sub>M closure B = A +\<^sub>M B\<close>
   by (metis closed_sum_assoc closed_sum_def closed_sum_zero_right closure_closure)
 
 lemma closed_sum_closure_left[simp]:
   fixes A B :: \<open>'a::real_normed_vector set\<close>
   shows \<open>closure A +\<^sub>M B = A +\<^sub>M B\<close>
   by (simp add: closed_sum_comm)
 
 lemma closed_sum_mono_left:
   assumes \<open>A \<subseteq> B\<close>
   shows \<open>A +\<^sub>M C \<subseteq> B +\<^sub>M C\<close>
   by (simp add: assms closed_sum_def closure_mono set_plus_mono2)
 
 lemma closed_sum_mono_right:
   assumes \<open>A \<subseteq> B\<close>
   shows \<open>C +\<^sub>M A \<subseteq> C +\<^sub>M B\<close>
   by (simp add: assms closed_sum_def closure_mono set_plus_mono2)
 
 instantiation ccsubspace :: (complex_normed_vector) sup begin
 lift_definition sup_ccsubspace :: "'a ccsubspace \<Rightarrow> 'a ccsubspace \<Rightarrow> 'a ccsubspace"
   \<comment> \<open>Note that \<^term>\<open>A+B\<close> would not be a closed subspace, we need the closure. See, e.g., \<^url>\<open>https://math.stackexchange.com/a/1786792/403528\<close>.\<close>
   is "\<lambda>A B::'a set. A +\<^sub>M B"
   by (simp add: closed_subspace_closed_sum)
 instance ..
 end
 
 lemma closed_sum_cspan[simp]:
   shows \<open>cspan X +\<^sub>M cspan Y = closure (cspan (X \<union> Y))\<close>
   by (smt (verit, best) Collect_cong closed_sum_def complex_vector.span_Un set_plus_def)
 
 lemma closure_image_closed_sum:
   assumes \<open>bounded_linear U\<close>
   shows \<open>closure (U ` (A +\<^sub>M B)) = closure (U ` A) +\<^sub>M closure (U ` B)\<close>
 proof -
   have \<open>closure (U ` (A +\<^sub>M B)) = closure (U ` closure (closure A + closure B))\<close>
     unfolding closed_sum_def
     by (smt (verit, best) closed_closure closure_minimal closure_mono closure_subset closure_sum set_plus_mono2 subset_antisym)
   also have \<open>\<dots> = closure (U ` (closure A + closure B))\<close>
     using assms closure_bounded_linear_image_subset_eq by blast
   also have \<open>\<dots> = closure (U ` closure A + U ` closure B)\<close>
     apply (subst image_set_plus)
     by (simp_all add: assms bounded_linear.linear)
   also have \<open>\<dots> = closure (closure (U ` A) + closure (U ` B))\<close>
     by (smt (verit, ccfv_SIG) assms closed_closure closure_bounded_linear_image_subset closure_bounded_linear_image_subset_eq closure_minimal closure_mono closure_sum dual_order.eq_iff set_plus_mono2)
   also have \<open>\<dots> = closure (U ` A) +\<^sub>M closure (U ` B)\<close>
     using closed_sum_def by blast
   finally show ?thesis
     by -
 qed
 
 
 
 lemma ccspan_union: "ccspan A \<squnion> ccspan B = ccspan (A \<union> B)"
   apply transfer by simp
 
 instantiation ccsubspace :: (complex_normed_vector) "Sup"
 begin
 lift_definition Sup_ccsubspace::\<open>'a ccsubspace set \<Rightarrow> 'a ccsubspace\<close>
   is \<open>\<lambda>S. closure (complex_vector.span (Union S))\<close>
 proof
   show "csubspace (closure (complex_vector.span (\<Union> S::'a set)))"
     if "\<And>x::'a set. x \<in> S \<Longrightarrow> closed_csubspace x"
     for S :: "'a set set"
     using that
     by (simp add: closure_is_closed_csubspace)
   show "closed (closure (complex_vector.span (\<Union> S::'a set)))"
     if "\<And>x. (x::'a set) \<in> S \<Longrightarrow> closed_csubspace x"
     for S :: "'a set set"
     using that
     by simp
 qed
 
 instance..
 end
 
 
 instance ccsubspace :: ("{complex_normed_vector}") semilattice_sup
 proof
   fix x y z :: \<open>'a ccsubspace\<close>
   show \<open>x \<le> sup x y\<close>
     apply transfer
     by (simp add: closed_csubspace_def closed_sum_left_subset complex_vector.subspace_0)
 
   show "y \<le> sup x y"
     apply transfer
     by (simp add: closed_csubspace_def closed_sum_right_subset complex_vector.subspace_0)
 
   show "sup x y \<le> z" if "x \<le> z" and "y \<le> z"
     using that apply transfer
     apply (rule closed_sum_is_sup) by auto
 qed
 
 instance ccsubspace :: ("{complex_normed_vector}") complete_lattice
 proof
   show "Inf A \<le> x"
     if "x \<in> A"
     for x :: "'a ccsubspace"
       and A :: "'a ccsubspace set"
     using that
     apply transfer
     by auto
 
   have b1: "z \<subseteq> \<Inter> A"
     if "Ball A closed_csubspace" and
       "closed_csubspace z" and
       "(\<And>x. closed_csubspace x \<Longrightarrow> x \<in> A \<Longrightarrow> z \<subseteq> x)"
     for z::"'a set" and A
     using that
     by auto
   show "z \<le> Inf A"
     if "\<And>x::'a ccsubspace. x \<in> A \<Longrightarrow> z \<le> x"
     for A :: "'a ccsubspace set"
       and z :: "'a ccsubspace"
     using that
     apply transfer
     using b1 by blast
 
   show "x \<le> Sup A"
     if "x \<in> A"
     for x :: "'a ccsubspace"
       and A :: "'a ccsubspace set"
     using that
     apply transfer
     by (meson Union_upper closure_subset complex_vector.span_superset dual_order.trans)
 
   show "Sup A \<le> z"
     if "\<And>x::'a ccsubspace. x \<in> A \<Longrightarrow> x \<le> z"
     for A :: "'a ccsubspace set"
       and z :: "'a ccsubspace"
     using that apply transfer
   proof -
     fix A :: "'a set set" and z :: "'a set"
     assume A_closed: "Ball A closed_csubspace"
     assume "closed_csubspace z"
     assume in_z: "\<And>x. closed_csubspace x \<Longrightarrow> x \<in> A \<Longrightarrow> x \<subseteq> z"
     from A_closed in_z
     have \<open>V \<subseteq> z\<close> if \<open>V \<in> A\<close> for V
       by (simp add: that)
     then have \<open>\<Union> A \<subseteq> z\<close>
       by (simp add: Sup_le_iff)
     with \<open>closed_csubspace z\<close>
     show "closure (cspan (\<Union> A)) \<subseteq> z"
       by (simp add: closed_csubspace_def closure_minimal complex_vector.span_def subset_hull)
   qed
 
   show "Inf {} = (top::'a ccsubspace)"
     using \<open>\<And>z A. (\<And>x. x \<in> A \<Longrightarrow> z \<le> x) \<Longrightarrow> z \<le> Inf A\<close> top.extremum_uniqueI by auto
 
   show "Sup {} = (bot::'a ccsubspace)"
     using \<open>\<And>z A. (\<And>x. x \<in> A \<Longrightarrow> x \<le> z) \<Longrightarrow> Sup A \<le> z\<close> bot.extremum_uniqueI by auto
 qed
 
 instantiation ccsubspace :: (complex_normed_vector) comm_monoid_add begin
 definition plus_ccsubspace :: "'a ccsubspace \<Rightarrow> _ \<Rightarrow> _"
   where [simp]: "plus_ccsubspace = sup"
 instance
 proof
   fix a b c :: \<open>'a ccsubspace\<close>
   show "a + b + c = a + (b + c)"
     using sup.assoc by auto
   show "a + b = b + a"
     by (simp add: sup.commute)
   show "0 + a = a"
     by (simp add: zero_ccsubspace_def)
 qed
 end
 
 lemma ccsubspace_plus_sup: "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y + z \<le> x"
   for x y z :: "'a::complex_normed_vector ccsubspace"
   unfolding plus_ccsubspace_def by auto
 
 lemma ccsubspace_Sup_empty: "Sup {} = (0::_ ccsubspace)"
   unfolding zero_ccsubspace_def by auto
 
 lemma ccsubspace_add_right_incr[simp]: "a \<le> a + c" for a::"_ ccsubspace"
   by (simp add: add_increasing2)
 
 lemma ccsubspace_add_left_incr[simp]: "a \<le> c + a" for a::"_ ccsubspace"
   by (simp add: add_increasing)
 
+lemma sum_bot_ccsubspace[simp]: \<open>(\<Sum>x\<in>X. \<bottom>) = (\<bottom> :: _ ccsubspace)\<close>
+  by (simp flip: zero_ccsubspace_def)
+
 subsection \<open>Conjugate space\<close>
 
 typedef 'a conjugate_space = "UNIV :: 'a set"
   morphisms from_conjugate_space to_conjugate_space ..
 setup_lifting type_definition_conjugate_space
 
 instantiation conjugate_space :: (complex_vector) complex_vector begin
 lift_definition scaleC_conjugate_space :: \<open>complex \<Rightarrow> 'a conjugate_space \<Rightarrow> 'a conjugate_space\<close> is \<open>\<lambda>c x. cnj c *\<^sub>C x\<close>.
 lift_definition scaleR_conjugate_space :: \<open>real \<Rightarrow> 'a conjugate_space \<Rightarrow> 'a conjugate_space\<close> is \<open>\<lambda>r x. r *\<^sub>R x\<close>.
 lift_definition plus_conjugate_space :: "'a conjugate_space \<Rightarrow> 'a conjugate_space \<Rightarrow> 'a conjugate_space" is "(+)".
 lift_definition uminus_conjugate_space :: "'a conjugate_space \<Rightarrow> 'a conjugate_space" is \<open>\<lambda>x. -x\<close>.
 lift_definition zero_conjugate_space :: "'a conjugate_space" is 0.
 lift_definition minus_conjugate_space :: "'a conjugate_space \<Rightarrow> 'a conjugate_space \<Rightarrow> 'a conjugate_space" is "(-)".
 instance
   apply (intro_classes; transfer)
   by (simp_all add: scaleR_scaleC scaleC_add_right scaleC_left.add)
 end
 
 instantiation conjugate_space :: (complex_normed_vector) complex_normed_vector begin
 lift_definition sgn_conjugate_space :: "'a conjugate_space \<Rightarrow> 'a conjugate_space" is "sgn".
 lift_definition norm_conjugate_space :: "'a conjugate_space \<Rightarrow> real" is norm.
 lift_definition dist_conjugate_space :: "'a conjugate_space \<Rightarrow> 'a conjugate_space \<Rightarrow> real" is dist.
 lift_definition uniformity_conjugate_space :: "('a conjugate_space \<times> 'a conjugate_space) filter" is uniformity.
 lift_definition  open_conjugate_space :: "'a conjugate_space set \<Rightarrow> bool" is "open".
 instance
   apply (intro_classes; transfer)
   by (simp_all add: dist_norm sgn_div_norm open_uniformity uniformity_dist norm_triangle_ineq)
 end
 
 instantiation conjugate_space :: (cbanach) cbanach begin
 instance
   apply intro_classes
   unfolding Cauchy_def convergent_def LIMSEQ_def apply transfer
   using Cauchy_convergent unfolding Cauchy_def convergent_def LIMSEQ_def by metis
 end
 
 lemma bounded_antilinear_to_conjugate_space[simp]: \<open>bounded_antilinear to_conjugate_space\<close>
   by (rule bounded_antilinear_intro[where K=1]; transfer; auto)
 
 lemma bounded_antilinear_from_conjugate_space[simp]: \<open>bounded_antilinear from_conjugate_space\<close>
   by (rule bounded_antilinear_intro[where K=1]; transfer; auto)
 
 lemma antilinear_to_conjugate_space[simp]: \<open>antilinear to_conjugate_space\<close>
   by (rule antilinearI; transfer, auto)
 
 lemma antilinear_from_conjugate_space[simp]: \<open>antilinear from_conjugate_space\<close>
   by (rule antilinearI; transfer, auto)
 
 lemma cspan_to_conjugate_space[simp]: "cspan (to_conjugate_space ` X) = to_conjugate_space ` cspan X"
   unfolding complex_vector.span_def complex_vector.subspace_def hull_def
   apply transfer
   apply simp
   by (metis (no_types, opaque_lifting) complex_cnj_cnj)
 
 lemma surj_to_conjugate_space[simp]: "surj to_conjugate_space"
   by (meson surj_def to_conjugate_space_cases)
 
 lemmas has_derivative_scaleC[simp, derivative_intros] =
   bounded_bilinear.FDERIV[OF bounded_cbilinear_scaleC[THEN bounded_cbilinear.bounded_bilinear]]
 
 lemma norm_to_conjugate_space[simp]: \<open>norm (to_conjugate_space x) = norm x\<close>
   by (fact norm_conjugate_space.abs_eq)
 
 lemma norm_from_conjugate_space[simp]: \<open>norm (from_conjugate_space x) = norm x\<close>
   by (simp add: norm_conjugate_space.rep_eq)
 
 lemma closure_to_conjugate_space: \<open>closure (to_conjugate_space ` X) = to_conjugate_space ` closure X\<close>
 proof -
   have 1: \<open>to_conjugate_space ` closure X \<subseteq> closure (to_conjugate_space ` X)\<close>
     apply (rule closure_bounded_linear_image_subset)
     by (simp add: bounded_antilinear.bounded_linear)
   have \<open>\<dots> = to_conjugate_space ` from_conjugate_space ` closure (to_conjugate_space ` X)\<close>
     by (simp add: from_conjugate_space_inverse image_image)
   also have \<open>\<dots> \<subseteq> to_conjugate_space ` closure (from_conjugate_space ` to_conjugate_space ` X)\<close>
     apply (rule image_mono)
     apply (rule closure_bounded_linear_image_subset)
     by (simp add: bounded_antilinear.bounded_linear)
   also have \<open>\<dots> = to_conjugate_space ` closure X\<close>
     by (simp add: to_conjugate_space_inverse image_image)
   finally show ?thesis
     using 1 by simp
 qed
 
 lemma closure_from_conjugate_space: \<open>closure (from_conjugate_space ` X) = from_conjugate_space ` closure X\<close>
 proof -
   have 1: \<open>from_conjugate_space ` closure X \<subseteq> closure (from_conjugate_space ` X)\<close>
     apply (rule closure_bounded_linear_image_subset)
     by (simp add: bounded_antilinear.bounded_linear)
   have \<open>\<dots> = from_conjugate_space ` to_conjugate_space ` closure (from_conjugate_space ` X)\<close>
     by (simp add: to_conjugate_space_inverse image_image)
   also have \<open>\<dots> \<subseteq> from_conjugate_space ` closure (to_conjugate_space ` from_conjugate_space ` X)\<close>
     apply (rule image_mono)
     apply (rule closure_bounded_linear_image_subset)
     by (simp add: bounded_antilinear.bounded_linear)
   also have \<open>\<dots> = from_conjugate_space ` closure X\<close>
     by (simp add: from_conjugate_space_inverse image_image)
   finally show ?thesis
     using 1 by simp
 qed
 
 lemma bounded_antilinear_eq_on:
   fixes A B :: "'a::complex_normed_vector \<Rightarrow> 'b::complex_normed_vector"
   assumes \<open>bounded_antilinear A\<close> and \<open>bounded_antilinear B\<close> and
     eq: \<open>\<And>x. x \<in> G \<Longrightarrow> A x = B x\<close> and t: \<open>t \<in> closure (cspan G)\<close>
   shows \<open>A t = B t\<close>
 proof -
   let ?A = \<open>\<lambda>x. A (from_conjugate_space x)\<close> and ?B = \<open>\<lambda>x. B (from_conjugate_space x)\<close>
     and ?G = \<open>to_conjugate_space ` G\<close> and ?t = \<open>to_conjugate_space t\<close>
   have \<open>bounded_clinear ?A\<close> and \<open>bounded_clinear ?B\<close>
     by (auto intro!: bounded_antilinear_o_bounded_antilinear[OF \<open>bounded_antilinear A\<close>]
         bounded_antilinear_o_bounded_antilinear[OF \<open>bounded_antilinear B\<close>])
   moreover from eq have \<open>\<And>x. x \<in> ?G \<Longrightarrow> ?A x = ?B x\<close>
     by (metis image_iff iso_tuple_UNIV_I to_conjugate_space_inverse)
   moreover from t have \<open>?t \<in> closure (cspan ?G)\<close>
     by (metis bounded_antilinear.bounded_linear bounded_antilinear_to_conjugate_space closure_bounded_linear_image_subset cspan_to_conjugate_space imageI subsetD)
   ultimately have \<open>?A ?t = ?B ?t\<close>
     by (rule bounded_clinear_eq_on)
   then show \<open>A t = B t\<close>
     by (simp add: to_conjugate_space_inverse)
 qed
 
 instantiation complex :: basis_enum begin
 definition "canonical_basis = [1::complex]"
 instance
 proof
   show "distinct (canonical_basis::complex list)"
     by (simp add: canonical_basis_complex_def)
   show "cindependent (set (canonical_basis::complex list))"
     unfolding canonical_basis_complex_def
     by auto
   show "cspan (set (canonical_basis::complex list)) = UNIV"
     unfolding canonical_basis_complex_def
     apply (auto simp add: cspan_raw_def vector_space_over_itself.span_Basis)
     by (metis complex_scaleC_def complex_vector.span_base complex_vector.span_scale cspan_raw_def insertI1 mult.right_neutral)
 qed
 end
 
 lemma csubspace_is_convex[simp]:
   assumes a1: "csubspace M"
   shows "convex M"
 proof-
   have \<open>\<forall>x\<in>M. \<forall>y\<in> M. \<forall>u. \<forall>v. u *\<^sub>C x + v *\<^sub>C y \<in>  M\<close>
     using a1
     by (simp add:  complex_vector.subspace_def)
   hence \<open>\<forall>x\<in>M. \<forall>y\<in>M. \<forall>u::real. \<forall>v::real. u *\<^sub>R x + v *\<^sub>R y \<in> M\<close>
     by (simp add: scaleR_scaleC)
   hence \<open>\<forall>x\<in>M. \<forall>y\<in>M. \<forall>u\<ge>0. \<forall>v\<ge>0. u + v = 1 \<longrightarrow> u *\<^sub>R x + v *\<^sub>R y \<in>M\<close>
     by blast
   thus ?thesis using convex_def by blast
 qed
 
 lemma kernel_is_csubspace[simp]:
   assumes a1: "clinear f"
   shows "csubspace  (f -` {0})"
 proof-
   have w3: \<open>t *\<^sub>C x \<in> {x. f x = 0}\<close>
     if b1: "x \<in> {x. f x = 0}"
     for x t
     by (metis assms complex_vector.linear_subspace_kernel complex_vector.subspace_def that)
   have \<open>f 0 = 0\<close>
     by (simp add: assms complex_vector.linear_0)
   hence s2: \<open>0 \<in> {x. f x = 0}\<close>
     by blast
 
   have w4: "x + y \<in> {x. f x = 0}"
     if c1: "x \<in> {x. f x = 0}" and c2: "y \<in> {x. f x = 0}"
     for x y
     using assms c1 c2 complex_vector.linear_add by fastforce
   have s4: \<open>c *\<^sub>C t \<in> {x. f x = 0}\<close>
     if "t \<in> {x. f x = 0}"
     for t c
     using that w3 by auto
   have s5: "u + v \<in> {x. f x = 0}"
     if "u \<in> {x. f x = 0}" and "v \<in> {x. f x = 0}"
     for u v
     using w4 that(1) that(2) by auto
   have f3: "f -` {b. b = 0 \<or> b \<in> {}} = {a. f a = 0}"
     by blast
   have "csubspace {a. f a = 0}"
     by (metis complex_vector.subspace_def s2 s4 s5)
   thus ?thesis
     using f3 by auto
 qed
 
 
 lemma kernel_is_closed_csubspace[simp]:
   assumes a1: "bounded_clinear f"
   shows "closed_csubspace (f -` {0})"
 proof-
   have \<open>csubspace (f -` {0})\<close>
     using assms bounded_clinear.clinear complex_vector.linear_subspace_vimage complex_vector.subspace_single_0 by blast
   have "L \<in> {x. f x = 0}"
     if "r \<longlonglongrightarrow> L" and "\<forall> n. r n \<in> {x. f x = 0}"
     for r and  L
   proof-
     have d1: \<open>\<forall> n. f (r n) = 0\<close>
       using that(2) by auto
     have \<open>(\<lambda> n. f (r n)) \<longlonglongrightarrow> f L\<close>
       using assms clinear_continuous_at continuous_within_tendsto_compose' that(1)
       by fastforce
     hence \<open>(\<lambda> n. 0) \<longlonglongrightarrow> f L\<close>
       using d1 by simp
     hence \<open>f L = 0\<close>
       using limI by fastforce
     thus ?thesis by blast
   qed
   then have s3: \<open>closed (f -` {0})\<close>
     using closed_sequential_limits by force
   with \<open>csubspace (f -` {0})\<close>
   show ?thesis
     using closed_csubspace.intro by blast
 qed
 
 lemma range_is_clinear[simp]:
   assumes a1: "clinear f"
   shows "csubspace (range f)"
   using assms complex_vector.linear_subspace_image complex_vector.subspace_UNIV by blast
 
 lemma ccspan_superset:
   \<open>A \<subseteq> space_as_set (ccspan A)\<close>
   for A :: \<open>'a::complex_normed_vector set\<close>
   apply transfer
   by (meson closure_subset complex_vector.span_superset subset_trans)
 
 
 subsection \<open>Product is a Complex Vector Space\<close>
 
 (* Follows closely Product_Vector.thy *)
 
 instantiation prod :: (complex_vector, complex_vector) complex_vector
 begin
 
 definition scaleC_prod_def:
   "scaleC r A = (scaleC r (fst A), scaleC r (snd A))"
 
 lemma fst_scaleC [simp]: "fst (scaleC r A) = scaleC r (fst A)"
   unfolding scaleC_prod_def by simp
 
 lemma snd_scaleC [simp]: "snd (scaleC r A) = scaleC r (snd A)"
   unfolding scaleC_prod_def by simp
 
 proposition scaleC_Pair [simp]: "scaleC r (a, b) = (scaleC r a, scaleC r b)"
   unfolding scaleC_prod_def by simp
 
 instance
 proof
   fix a b :: complex and x y :: "'a \<times> 'b"
   show "scaleC a (x + y) = scaleC a x + scaleC a y"
     by (simp add: scaleC_add_right scaleC_prod_def)
   show "scaleC (a + b) x = scaleC a x + scaleC b x"
     by (simp add: Complex_Vector_Spaces.scaleC_prod_def scaleC_left.add)
   show "scaleC a (scaleC b x) = scaleC (a * b) x"
     by (simp add: prod_eq_iff)
   show "scaleC 1 x = x"
     by (simp add: prod_eq_iff)
   show \<open>(scaleR :: _ \<Rightarrow> _ \<Rightarrow> 'a*'b) r = (*\<^sub>C) (complex_of_real r)\<close> for r
     by (auto intro!: ext simp: scaleR_scaleC scaleC_prod_def scaleR_prod_def)
 qed
 
 end
 
 lemma module_prod_scale_eq_scaleC: "module_prod.scale (*\<^sub>C) (*\<^sub>C) = scaleC"
   apply (rule ext) apply (rule ext)
   apply (subst module_prod.scale_def)
   subgoal by unfold_locales
   by (simp add: scaleC_prod_def)
 
 interpretation complex_vector?: vector_space_prod "scaleC::_\<Rightarrow>_\<Rightarrow>'a::complex_vector" "scaleC::_\<Rightarrow>_\<Rightarrow>'b::complex_vector"
   rewrites "scale = ((*\<^sub>C)::_\<Rightarrow>_\<Rightarrow>('a \<times> 'b))"
     and "module.dependent (*\<^sub>C) = cdependent"
     and "module.representation (*\<^sub>C) = crepresentation"
     and "module.subspace (*\<^sub>C) = csubspace"
     and "module.span (*\<^sub>C) = cspan"
     and "vector_space.extend_basis (*\<^sub>C) = cextend_basis"
     and "vector_space.dim (*\<^sub>C) = cdim"
     and "Vector_Spaces.linear (*\<^sub>C) (*\<^sub>C) = clinear"
   subgoal by unfold_locales
   subgoal by (fact module_prod_scale_eq_scaleC)
   unfolding cdependent_raw_def crepresentation_raw_def csubspace_raw_def cspan_raw_def
     cextend_basis_raw_def cdim_raw_def clinear_def
   by (rule refl)+
 
 instance prod :: (complex_normed_vector, complex_normed_vector) complex_normed_vector 
 proof
   fix c :: complex and x y :: "'a \<times> 'b"
   show "norm (c *\<^sub>C x) = cmod c * norm x"
     unfolding norm_prod_def
     apply (simp add: power_mult_distrib)
     apply (simp add: distrib_left [symmetric])
     by (simp add: real_sqrt_mult)
 qed
 
 
 lemma cspan_Times: \<open>cspan (S \<times> T) = cspan S \<times> cspan T\<close> if \<open>0 \<in> S\<close> and \<open>0 \<in> T\<close>
 proof 
   have \<open>fst ` cspan (S \<times> T) \<subseteq> cspan S\<close>
     apply (subst complex_vector.linear_span_image[symmetric])
     using that complex_vector.module_hom_fst by auto
   moreover have \<open>snd ` cspan (S \<times> T) \<subseteq> cspan T\<close>
     apply (subst complex_vector.linear_span_image[symmetric])
     using that complex_vector.module_hom_snd by auto
   ultimately show \<open>cspan (S \<times> T) \<subseteq> cspan S \<times> cspan T\<close>
     by auto
 
   show \<open>cspan S \<times> cspan T \<subseteq> cspan (S \<times> T)\<close>
   proof
     fix x assume assm: \<open>x \<in> cspan S \<times> cspan T\<close>
     then have \<open>fst x \<in> cspan S\<close>
       by auto
     then obtain t1 r1 where fst_x: \<open>fst x = (\<Sum>a\<in>t1. r1 a *\<^sub>C a)\<close> and [simp]: \<open>finite t1\<close> and \<open>t1 \<subseteq> S\<close>
       by (auto simp add: complex_vector.span_explicit)
     from assm
     have \<open>snd x \<in> cspan T\<close>
       by auto
     then obtain t2 r2 where snd_x: \<open>snd x = (\<Sum>a\<in>t2. r2 a *\<^sub>C a)\<close> and [simp]: \<open>finite t2\<close> and \<open>t2 \<subseteq> T\<close>
       by (auto simp add: complex_vector.span_explicit)
     define t :: \<open>('a+'b) set\<close> and r :: \<open>('a+'b) \<Rightarrow> complex\<close> and f :: \<open>('a+'b) \<Rightarrow> ('a\<times>'b)\<close>
       where \<open>t = t1 <+> t2\<close>
       and \<open>r a = (case a of Inl a1 \<Rightarrow> r1 a1 | Inr a2 \<Rightarrow> r2 a2)\<close>
       and \<open>f a = (case a of Inl a1 \<Rightarrow> (a1,0) | Inr a2 \<Rightarrow> (0,a2))\<close>
     for a
     have \<open>finite t\<close>
       by (simp add: t_def)
     moreover have \<open>f ` t \<subseteq> S \<times> T\<close>
       using  \<open>t1 \<subseteq> S\<close> \<open>t2 \<subseteq> T\<close> that
       by (auto simp: f_def t_def)
     moreover have \<open>(fst x, snd x) = (\<Sum>a\<in>t. r a *\<^sub>C f a)\<close>
       apply (simp only: fst_x snd_x)
       by (auto simp: t_def sum.Plus r_def f_def sum_prod)
     ultimately show \<open>x \<in> cspan (S \<times> T)\<close>
       apply auto
       by (smt (verit, best) complex_vector.span_scale complex_vector.span_sum complex_vector.span_superset image_subset_iff subset_iff)
   qed
 qed
 
 lemma onorm_case_prod_plus: \<open>onorm (case_prod plus :: _ \<Rightarrow> 'a::{real_normed_vector, not_singleton}) = sqrt 2\<close>
 proof -
   obtain x :: 'a where \<open>x \<noteq> 0\<close>
     apply atomize_elim by auto
   show ?thesis
     apply (rule onormI[where x=\<open>(x,x)\<close>])
     using norm_plus_leq_norm_prod apply force
     using  \<open>x \<noteq> 0\<close>
     by (auto simp add: zero_prod_def norm_prod_def real_sqrt_mult
         simp flip: scaleR_2)
 qed
 
 
 subsection \<open>Copying existing theorems into sublocales\<close>
 
 context bounded_clinear begin
 interpretation bounded_linear f by (rule bounded_linear)
 lemmas continuous = real.continuous
 lemmas uniform_limit = real.uniform_limit
 lemmas Cauchy = real.Cauchy
 end
 
 context bounded_antilinear begin
 interpretation bounded_linear f by (rule bounded_linear)
 lemmas continuous = real.continuous
 lemmas uniform_limit = real.uniform_limit
 end
 
 
 context bounded_cbilinear begin
 interpretation bounded_bilinear prod by simp
 lemmas tendsto = real.tendsto
 lemmas isCont = real.isCont
 lemmas scaleR_right = real.scaleR_right
 lemmas scaleR_left = real.scaleR_left
 end
 
 context bounded_sesquilinear begin
 interpretation bounded_bilinear prod by simp
 lemmas tendsto = real.tendsto
 lemmas isCont = real.isCont
 lemmas scaleR_right = real.scaleR_right
 lemmas scaleR_left = real.scaleR_left
 end
 
 lemmas tendsto_scaleC [tendsto_intros] =
   bounded_cbilinear.tendsto [OF bounded_cbilinear_scaleC]
 
 unbundle no_lattice_syntax
 
 end
diff --git a/thys/Complex_Bounded_Operators/extra/Extra_General.thy b/thys/Complex_Bounded_Operators/extra/Extra_General.thy
--- a/thys/Complex_Bounded_Operators/extra/Extra_General.thy
+++ b/thys/Complex_Bounded_Operators/extra/Extra_General.thy
@@ -1,687 +1,720 @@
 section \<open>\<open>Extra_General\<close> -- General missing things\<close>
 
 theory Extra_General
   imports
     "HOL-Library.Cardinality"
     "HOL-Analysis.Elementary_Topology"
     "HOL-Analysis.Uniform_Limit"
     "HOL-Library.Set_Algebras"
     "HOL-Types_To_Sets.Types_To_Sets"
     "HOL-Library.Complex_Order"
     "HOL-Analysis.Infinite_Sum"
     "HOL-Cardinals.Cardinals"
+    "HOL-Library.Complemented_Lattices"
 begin
 
 subsection \<open>Misc\<close>
 
 lemma reals_zero_comparable:
   fixes x::complex
   assumes "x\<in>\<real>"
   shows "x \<le> 0 \<or> x \<ge> 0"
   using assms unfolding complex_is_real_iff_compare0 by assumption
 
 lemma unique_choice: "\<forall>x. \<exists>!y. Q x y \<Longrightarrow> \<exists>!f. \<forall>x. Q x (f x)"
   apply (auto intro!: choice ext) by metis
 
 lemma image_set_plus: 
   assumes \<open>linear U\<close>
   shows \<open>U ` (A + B) = U ` A + U ` B\<close>
   unfolding image_def set_plus_def
   using assms by (force simp: linear_add)
 
 consts heterogenous_identity :: \<open>'a \<Rightarrow> 'b\<close>
 overloading heterogenous_identity_id \<equiv> "heterogenous_identity :: 'a \<Rightarrow> 'a" begin
 definition heterogenous_identity_def[simp]: \<open>heterogenous_identity_id = id\<close>
 end
 
 lemma L2_set_mono2:
   assumes a1: "finite L" and a2: "K \<le> L"
   shows "L2_set f K \<le> L2_set f L"
 proof-
   have "(\<Sum>i\<in>K. (f i)\<^sup>2) \<le> (\<Sum>i\<in>L. (f i)\<^sup>2)"
   proof (rule sum_mono2)
     show "finite L"
       using a1.
     show "K \<subseteq> L"
       using a2.
     show "0 \<le> (f b)\<^sup>2"
       if "b \<in> L - K"
       for b :: 'a
       using that
       by simp 
   qed
   hence "sqrt (\<Sum>i\<in>K. (f i)\<^sup>2) \<le> sqrt (\<Sum>i\<in>L. (f i)\<^sup>2)"
     by (rule real_sqrt_le_mono)
   thus ?thesis
     unfolding L2_set_def.
 qed
 
 lemma Sup_real_close:
   fixes e :: real
   assumes "0 < e"
     and S: "bdd_above S" "S \<noteq> {}"
   shows "\<exists>x\<in>S. Sup S - e < x"
 proof -
   have \<open>Sup (ereal ` S) \<noteq> \<infinity>\<close>
     by (metis assms(2) bdd_above_def ereal_less_eq(3) less_SUP_iff less_ereal.simps(4) not_le)
   moreover have \<open>Sup (ereal ` S) \<noteq> -\<infinity>\<close>
     by (simp add: SUP_eq_iff assms(3))
   ultimately have Sup_bdd: \<open>\<bar>Sup (ereal ` S)\<bar> \<noteq> \<infinity>\<close>
     by auto
   then have \<open>\<exists>x'\<in>ereal ` S. Sup (ereal ` S) - ereal e < x'\<close>
     apply (rule_tac Sup_ereal_close)
     using assms by auto
   then obtain x where \<open>x \<in> S\<close> and Sup_x: \<open>Sup (ereal ` S) - ereal e < ereal x\<close>
     by auto
   have \<open>Sup (ereal ` S) = ereal (Sup S)\<close>
     using Sup_bdd by (rule ereal_Sup[symmetric])
   with Sup_x have \<open>ereal (Sup S - e) < ereal x\<close>
     by auto
   then have \<open>Sup S - e < x\<close>
     by auto
   with \<open>x \<in> S\<close> show ?thesis
     by auto
 qed
 
 text \<open>Improved version of @{attribute internalize_sort}: It is not necessary to specify the sort of the type variable.\<close>
 attribute_setup internalize_sort' = \<open>let
 fun find_tvar thm v = let
   val tvars = Term.add_tvars (Thm.prop_of thm) []
   val tv = case find_first (fn (n,sort) => n=v) tvars of
               SOME tv => tv | NONE => raise THM ("Type variable " ^ string_of_indexname v ^ " not found", 0, [thm])
 in 
 TVar tv
 end
 
 fun internalize_sort_attr (tvar:indexname) =
   Thm.rule_attribute [] (fn context => fn thm =>
     (snd (Internalize_Sort.internalize_sort (Thm.ctyp_of (Context.proof_of context) (find_tvar thm tvar)) thm)));
 in
   Scan.lift Args.var >> internalize_sort_attr
 end\<close>
   "internalize a sort"
 
 lemma card_prod_omega: \<open>X *c natLeq =o X\<close> if \<open>Cinfinite X\<close>
   by (simp add: Cinfinite_Cnotzero cprod_infinite1' natLeq_Card_order natLeq_cinfinite natLeq_ordLeq_cinfinite that)
 
 lemma countable_leq_natLeq: \<open>|X| \<le>o natLeq\<close> if \<open>countable X\<close>
   using subset_range_from_nat_into[OF that]
   by (meson card_of_nat ordIso_iff_ordLeq ordLeq_transitive surj_imp_ordLeq)
 
 lemma set_Times_plus_distrib: \<open>(A \<times> B) + (C \<times> D) = (A + C) \<times> (B + D)\<close>
   by (auto simp: Sigma_def set_plus_def)
 
 subsection \<open>Not singleton\<close>
 
 class not_singleton =
   assumes not_singleton_card: "\<exists>x y. x \<noteq> y"
 
 lemma not_singleton_existence[simp]:
   \<open>\<exists> x::('a::not_singleton). x \<noteq> t\<close>
   using not_singleton_card[where ?'a = 'a] by (metis (full_types))
 
 lemma UNIV_not_singleton[simp]: "(UNIV::_::not_singleton set) \<noteq> {x}"
   using not_singleton_existence[of x] by blast
 
 lemma UNIV_not_singleton_converse: 
   assumes"\<And>x::'a. UNIV \<noteq> {x}"
   shows "\<exists>x::'a. \<exists>y. x \<noteq> y"
   using assms
   by fastforce 
 
 subclass (in card2) not_singleton
   apply standard using two_le_card
   by (meson card_2_iff' obtain_subset_with_card_n)
 
 subclass (in perfect_space) not_singleton
   apply intro_classes
   by (metis (mono_tags) Collect_cong Collect_mem_eq UNIV_I local.UNIV_not_singleton local.not_open_singleton local.open_subopen)
 
 lemma class_not_singletonI_monoid_add:
   assumes "(UNIV::'a set) \<noteq> {0}"
   shows "class.not_singleton TYPE('a::monoid_add)"
 proof intro_classes
   let ?univ = "UNIV :: 'a set"
   from assms obtain x::'a where "x \<noteq> 0"
     by auto
   thus "\<exists>x y :: 'a. x \<noteq> y"
     by auto
 qed
 
 lemma not_singleton_vs_CARD_1:
   assumes \<open>\<not> class.not_singleton TYPE('a)\<close>
   shows \<open>class.CARD_1 TYPE('a)\<close>
   using assms unfolding class.not_singleton_def class.CARD_1_def
   by (metis (full_types) One_nat_def UNIV_I card.empty card.insert empty_iff equalityI finite.intros(1) insert_iff subsetI)
 
 subsection \<open>\<^class>\<open>CARD_1\<close>\<close>
 
 context CARD_1 begin
 
 lemma everything_the_same[simp]: "(x::'a)=y"
   by (metis (full_types) UNIV_I card_1_singletonE empty_iff insert_iff local.CARD_1)
 
 lemma CARD_1_UNIV: "UNIV = {x::'a}"
   by (metis (full_types) UNIV_I card_1_singletonE local.CARD_1 singletonD)
 
 lemma CARD_1_ext: "x (a::'a) = y b \<Longrightarrow> x = y"
 proof (rule ext)
   show "x t = y t"
     if "x a = y b"
     for t :: 'a
     using that  apply (subst (asm) everything_the_same[where x=a])
     apply (subst (asm) everything_the_same[where x=b])
     by simp
 qed 
 
 end
 
 instance unit :: CARD_1
   apply standard by auto
 
 instance prod :: (CARD_1, CARD_1) CARD_1
   apply intro_classes
   by (simp add: CARD_1)
 
 instance "fun" :: (CARD_1, CARD_1) CARD_1
   apply intro_classes
   by (auto simp add: card_fun CARD_1)
 
 
 lemma enum_CARD_1: "(Enum.enum :: 'a::{CARD_1,enum} list) = [a]"
 proof -
   let ?enum = "Enum.enum :: 'a::{CARD_1,enum} list"
   have "length ?enum = 1"
     apply (subst card_UNIV_length_enum[symmetric])
     by (rule CARD_1)
   then obtain b where "?enum = [b]"
     apply atomize_elim
     apply (cases ?enum, auto)
     by (metis length_0_conv length_Cons nat.inject)
   thus "?enum = [a]"
     by (subst everything_the_same[of _ b], simp)
 qed
 
+lemma card_not_singleton: \<open>CARD('a::not_singleton) \<noteq> 1\<close>
+  by (simp add: card_1_singleton_iff)
 
 
 subsection \<open>Topology\<close>
 
 lemma cauchy_filter_metricI:
   fixes F :: "'a::metric_space filter"
   assumes "\<And>e. e>0 \<Longrightarrow> \<exists>P. eventually P F \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> dist x y < e)"
   shows "cauchy_filter F"
 proof (unfold cauchy_filter_def le_filter_def, auto)
   fix P :: "'a \<times> 'a \<Rightarrow> bool"
   assume "eventually P uniformity"
   then obtain e where e: "e > 0" and P: "dist x y < e \<Longrightarrow> P (x, y)" for x y
     unfolding eventually_uniformity_metric by auto
 
   obtain P' where evP': "eventually P' F" and P'_dist: "P' x \<and> P' y \<Longrightarrow> dist x y < e" for x y
     apply atomize_elim using assms e by auto
 
   from evP' P'_dist P
   show "eventually P (F \<times>\<^sub>F F)"
     unfolding eventually_uniformity_metric eventually_prod_filter eventually_filtermap by metis
 qed
 
 lemma cauchy_filter_metric_filtermapI:
   fixes F :: "'a filter" and f :: "'a\<Rightarrow>'b::metric_space"
   assumes "\<And>e. e>0 \<Longrightarrow> \<exists>P. eventually P F \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> dist (f x) (f y) < e)"
   shows "cauchy_filter (filtermap f F)"
 proof (rule cauchy_filter_metricI)
   fix e :: real assume e: "e > 0"
   with assms obtain P where evP: "eventually P F" and dist: "P x \<and> P y \<Longrightarrow> dist (f x) (f y) < e" for x y
     by atomize_elim auto
   define P' where "P' y = (\<exists>x. P x \<and> y = f x)" for y
   have "eventually P' (filtermap f F)"
     unfolding eventually_filtermap P'_def 
     using evP
     by (smt eventually_mono) 
   moreover have "P' x \<and> P' y \<longrightarrow> dist x y < e" for x y
     unfolding P'_def using dist by metis
   ultimately show "\<exists>P. eventually P (filtermap f F) \<and> (\<forall>x y. P x \<and> P y \<longrightarrow> dist x y < e)"
     by auto
 qed
 
 
 lemma tendsto_add_const_iff:
   \<comment> \<open>This is a generalization of \<open>Limits.tendsto_add_const_iff\<close>, 
       the only difference is that the sort here is more general.\<close>
   "((\<lambda>x. c + f x :: 'a::topological_group_add) \<longlongrightarrow> c + d) F \<longleftrightarrow> (f \<longlongrightarrow> d) F"
   using tendsto_add[OF tendsto_const[of c], of f d]
     and tendsto_add[OF tendsto_const[of "-c"], of "\<lambda>x. c + f x" "c + d"] by auto
 
 lemma finite_subsets_at_top_minus: 
   assumes "A\<subseteq>B"
   shows "finite_subsets_at_top (B - A) \<le> filtermap (\<lambda>F. F - A) (finite_subsets_at_top B)"
 proof (rule filter_leI)
   fix P assume "eventually P (filtermap (\<lambda>F. F - A) (finite_subsets_at_top B))"
   then obtain X where "finite X" and "X \<subseteq> B" 
     and P: "finite Y \<and> X \<subseteq> Y \<and> Y \<subseteq> B \<longrightarrow> P (Y - A)" for Y
     unfolding eventually_filtermap eventually_finite_subsets_at_top by auto
 
   hence "finite (X-A)" and "X-A \<subseteq> B - A"
     by auto
   moreover have "finite Y \<and> X-A \<subseteq> Y \<and> Y \<subseteq> B - A \<longrightarrow> P Y" for Y
     using P[where Y="Y\<union>X"] \<open>finite X\<close> \<open>X \<subseteq> B\<close>
     by (metis Diff_subset Int_Diff Un_Diff finite_Un inf.orderE le_sup_iff sup.orderE sup_ge2)
   ultimately show "eventually P (finite_subsets_at_top (B - A))"
     unfolding eventually_finite_subsets_at_top by meson
 qed
 
 lemma finite_subsets_at_top_inter: 
   assumes "A\<subseteq>B"
   shows "filtermap (\<lambda>F. F \<inter> A) (finite_subsets_at_top B) = finite_subsets_at_top A"
 proof (subst filter_eq_iff, intro allI iffI)
   fix P :: "'a set \<Rightarrow> bool"
   assume "eventually P (finite_subsets_at_top A)"
   then show "eventually P (filtermap (\<lambda>F. F \<inter> A) (finite_subsets_at_top B))"
     unfolding eventually_filtermap
     unfolding eventually_finite_subsets_at_top
     by (metis Int_subset_iff assms finite_Int inf_le2 subset_trans)
 next
   fix P :: "'a set \<Rightarrow> bool"
   assume "eventually P (filtermap (\<lambda>F. F \<inter> A) (finite_subsets_at_top B))"
   then obtain X where \<open>finite X\<close> \<open>X \<subseteq> B\<close> and P: \<open>finite Y \<Longrightarrow> X \<subseteq> Y \<Longrightarrow> Y \<subseteq> B \<Longrightarrow> P (Y \<inter> A)\<close> for Y
     unfolding eventually_filtermap eventually_finite_subsets_at_top by metis
   have *: \<open>finite Y \<Longrightarrow> X \<inter> A \<subseteq> Y \<Longrightarrow> Y \<subseteq> A \<Longrightarrow> P Y\<close> for Y
     using P[where Y=\<open>Y \<union> (B-A)\<close>]
     apply (subgoal_tac \<open>(Y \<union> (B - A)) \<inter> A = Y\<close>)
     apply (smt (verit, best) Int_Un_distrib2 Int_Un_eq(4) P Un_subset_iff \<open>X \<subseteq> B\<close> \<open>finite X\<close> assms finite_UnI inf.orderE sup_ge2)
     by auto
   show "eventually P (finite_subsets_at_top A)"
     unfolding eventually_finite_subsets_at_top
     apply (rule exI[of _ \<open>X\<inter>A\<close>])
     by (auto simp: \<open>finite X\<close> intro!: *)
 qed
 
 lemma tendsto_principal_singleton:
   shows "(f \<longlongrightarrow> f x) (principal {x})"
   unfolding tendsto_def eventually_principal by simp
 
 lemma complete_singleton: 
   "complete {s::'a::uniform_space}"
 proof-
   have "F \<le> principal {s} \<Longrightarrow>
          F \<noteq> bot \<Longrightarrow> cauchy_filter F \<Longrightarrow> F \<le> nhds s" for F
     by (metis eventually_nhds eventually_principal le_filter_def singletonD)
   thus ?thesis
     unfolding complete_uniform
     by simp
 qed
 
 lemma on_closure_eqI:
   fixes f g :: \<open>'a::topological_space \<Rightarrow> 'b::t2_space\<close>
   assumes eq: \<open>\<And>x. x \<in> S \<Longrightarrow> f x = g x\<close>
   assumes xS: \<open>x \<in> closure S\<close>
   assumes cont: \<open>continuous_on UNIV f\<close> \<open>continuous_on UNIV g\<close>
   shows \<open>f x = g x\<close>
 proof -
   define X where \<open>X = {x. f x = g x}\<close>
   have \<open>closed X\<close>
     using cont by (simp add: X_def closed_Collect_eq)
   moreover have \<open>S \<subseteq> X\<close>
     by (simp add: X_def eq subsetI)
   ultimately have \<open>closure S \<subseteq> X\<close>
     using closure_minimal by blast
   with xS have \<open>x \<in> X\<close>
     by auto
   then show ?thesis
     using X_def by blast
 qed
 
 lemma on_closure_leI:
   fixes f g :: \<open>'a::topological_space \<Rightarrow> 'b::linorder_topology\<close>
   assumes eq: \<open>\<And>x. x \<in> S \<Longrightarrow> f x \<le> g x\<close>
   assumes xS: \<open>x \<in> closure S\<close>
   assumes cont: \<open>continuous_on UNIV f\<close> \<open>continuous_on UNIV g\<close> (* Is "isCont f x" "isCont g x" sufficient? *)
   shows \<open>f x \<le> g x\<close>
 proof -
   define X where \<open>X = {x. f x \<le> g x}\<close>
   have \<open>closed X\<close>
     using cont by (simp add: X_def closed_Collect_le)
   moreover have \<open>S \<subseteq> X\<close>
     by (simp add: X_def eq subsetI)
   ultimately have \<open>closure S \<subseteq> X\<close>
     using closure_minimal by blast
   with xS have \<open>x \<in> X\<close>
     by auto
   then show ?thesis
     using X_def by blast
 qed
 
 
 lemma tendsto_compose_at_within:
   assumes f: "(f \<longlongrightarrow> y) F" and g: "(g \<longlongrightarrow> z) (at y within S)" 
     and fg: "eventually (\<lambda>w. f w = y \<longrightarrow> g y = z) F"
     and fS: \<open>\<forall>\<^sub>F w in F. f w \<in> S\<close>
   shows "((g \<circ> f) \<longlongrightarrow> z) F"
 proof (cases \<open>g y = z\<close>)
   case False
   then have 1: "(\<forall>\<^sub>F a in F. f a \<noteq> y)"
     using fg by force
   have 2: "(g \<longlongrightarrow> z) (filtermap f F) \<or> \<not> (\<forall>\<^sub>F a in F. f a \<noteq> y)"
     by (smt (verit, best) eventually_elim2 f fS filterlim_at filterlim_def g tendsto_mono)
   show ?thesis
     using "1" "2" tendsto_compose_filtermap by blast
 next
   case True
   have *: ?thesis if \<open>(g \<longlongrightarrow> z) (filtermap f F)\<close>
     using that by (simp add: tendsto_compose_filtermap)
   from g
   have \<open>(g \<longlongrightarrow> g y) (inf (nhds y) (principal (S-{y})))\<close>
     by (simp add: True at_within_def)
   then have g': \<open>(g \<longlongrightarrow> g y) (inf (nhds y) (principal S))\<close>
     using True g tendsto_at_iff_tendsto_nhds_within by blast
   from f have \<open>filterlim f (nhds y) F\<close>
     by -
   then have f': \<open>filterlim f (inf (nhds y) (principal S)) F\<close>
     using fS
     by (simp add: filterlim_inf filterlim_principal)
   from f' g' show ?thesis
     by (simp add: * True filterlim_compose filterlim_filtermap)
 qed
 
 subsection \<open>Sums\<close>
 
 lemma sum_single: 
   assumes "finite A"
   assumes "\<And>j. j \<noteq> i \<Longrightarrow> j\<in>A \<Longrightarrow> f j = 0"
   shows "sum f A = (if i\<in>A then f i else 0)"
   apply (subst sum.mono_neutral_cong_right[where S=\<open>A \<inter> {i}\<close> and h=f])
   using assms by auto
 
 lemma has_sum_comm_additive_general: 
   \<comment> \<open>This is a strengthening of @{thm [source] has_sum_comm_additive_general}.\<close>
   fixes f :: \<open>'b :: {comm_monoid_add,topological_space} \<Rightarrow> 'c :: {comm_monoid_add,topological_space}\<close>
   assumes f_sum: \<open>\<And>F. finite F \<Longrightarrow> F \<subseteq> S \<Longrightarrow> sum (f o g) F = f (sum g F)\<close>
       \<comment> \<open>Not using \<^const>\<open>additive\<close> because it would add sort constraint \<^class>\<open>ab_group_add\<close>\<close>
   assumes inS: \<open>\<And>F. finite F \<Longrightarrow> sum g F \<in> T\<close>
   assumes cont: \<open>(f \<longlongrightarrow> f x) (at x within T)\<close>
     \<comment> \<open>For \<^class>\<open>t2_space\<close> and \<^term>\<open>T=UNIV\<close>, this is equivalent to \<open>isCont f x\<close> by @{thm [source] isCont_def}.\<close>
   assumes infsum: \<open>has_sum g S x\<close>
   shows \<open>has_sum (f o g) S (f x)\<close> 
 proof -
   have \<open>(sum g \<longlongrightarrow> x) (finite_subsets_at_top S)\<close>
     using infsum has_sum_def by blast
   then have \<open>((f o sum g) \<longlongrightarrow> f x) (finite_subsets_at_top S)\<close>
     apply (rule tendsto_compose_at_within[where S=T])
     using assms by auto
   then have \<open>(sum (f o g) \<longlongrightarrow> f x) (finite_subsets_at_top S)\<close>
     apply (rule tendsto_cong[THEN iffD1, rotated])
     using f_sum by fastforce
   then show \<open>has_sum (f o g) S (f x)\<close>
     using has_sum_def by blast 
 qed
 
 lemma summable_on_comm_additive_general:
   \<comment> \<open>This is a strengthening of @{thm [source] summable_on_comm_additive_general}.\<close>
   fixes g :: \<open>'a \<Rightarrow> 'b :: {comm_monoid_add,topological_space}\<close> and f :: \<open>'b \<Rightarrow> 'c :: {comm_monoid_add,topological_space}\<close>
   assumes \<open>\<And>F. finite F \<Longrightarrow> F \<subseteq> S \<Longrightarrow> sum (f o g) F = f (sum g F)\<close>
     \<comment> \<open>Not using \<^const>\<open>additive\<close> because it would add sort constraint \<^class>\<open>ab_group_add\<close>\<close>
   assumes inS: \<open>\<And>F. finite F \<Longrightarrow> sum g F \<in> T\<close>
   assumes cont: \<open>\<And>x. has_sum g S x \<Longrightarrow> (f \<longlongrightarrow> f x) (at x within T)\<close>
     \<comment> \<open>For \<^class>\<open>t2_space\<close> and \<^term>\<open>T=UNIV\<close>, this is equivalent to \<open>isCont f x\<close> by @{thm [source] isCont_def}.\<close>
   assumes \<open>g summable_on S\<close>
   shows \<open>(f o g) summable_on S\<close>
   by (meson assms summable_on_def has_sum_comm_additive_general has_sum_def infsum_tendsto)
 
 lemma has_sum_metric:
   fixes l :: \<open>'a :: {metric_space, comm_monoid_add}\<close>
   shows \<open>has_sum f A l \<longleftrightarrow> (\<forall>e. e > 0 \<longrightarrow> (\<exists>X. finite X \<and> X \<subseteq> A \<and> (\<forall>Y. finite Y \<and> X \<subseteq> Y \<and> Y \<subseteq> A \<longrightarrow> dist (sum f Y) l < e)))\<close>
   unfolding has_sum_def
   apply (subst tendsto_iff)
   unfolding eventually_finite_subsets_at_top
   by simp
 
 lemma summable_on_product_finite_left:
   fixes f :: \<open>'a\<times>'b \<Rightarrow> 'c::{topological_comm_monoid_add}\<close>
   assumes sum: \<open>\<And>x. x\<in>X \<Longrightarrow> (\<lambda>y. f(x,y)) summable_on Y\<close>
   assumes \<open>finite X\<close>
   shows \<open>f summable_on (X\<times>Y)\<close>
   using \<open>finite X\<close> subset_refl[of X]
 proof (induction rule: finite_subset_induct')
   case empty
   then show ?case
     by simp
 next
   case (insert x F)
   have *: \<open>bij_betw (Pair x) Y ({x} \<times> Y)\<close>
     apply (rule bij_betwI')
     by auto
   from sum[of x]
   have \<open>f summable_on {x} \<times> Y\<close>
     apply (rule summable_on_reindex_bij_betw[THEN iffD1, rotated])
     by (simp_all add: * insert.hyps(2))
   then have \<open>f summable_on {x} \<times> Y \<union> F \<times> Y\<close>
     apply (rule summable_on_Un_disjoint)
     using insert by auto
   then show ?case
     by (metis Sigma_Un_distrib1 insert_is_Un)
 qed
 
 lemma summable_on_product_finite_right:
   fixes f :: \<open>'a\<times>'b \<Rightarrow> 'c::{topological_comm_monoid_add}\<close>
   assumes sum: \<open>\<And>y. y\<in>Y \<Longrightarrow> (\<lambda>x. f(x,y)) summable_on X\<close>
   assumes \<open>finite Y\<close>
   shows \<open>f summable_on (X\<times>Y)\<close>
 proof -
   have \<open>(\<lambda>(y,x). f(x,y)) summable_on (Y\<times>X)\<close>
     apply (rule summable_on_product_finite_left)
     using assms by auto
   then show ?thesis
     apply (subst summable_on_reindex_bij_betw[where g=prod.swap and A=\<open>Y\<times>X\<close>, symmetric])
     apply (simp add: bij_betw_def product_swap)
     by (metis (mono_tags, lifting) case_prod_unfold prod.swap_def summable_on_cong)
 qed
 
 subsection \<open>Complex numbers\<close>
 
 lemma cmod_Re:
   assumes "x \<ge> 0"
   shows "cmod x = Re x"
   using assms unfolding less_eq_complex_def cmod_def
   by auto
 
 lemma abs_complex_real[simp]: "abs x \<in> \<real>" for x :: complex
   by (simp add: abs_complex_def)
 
 lemma Im_abs[simp]: "Im (abs x) = 0"
   using abs_complex_real complex_is_Real_iff by blast
 
 
 lemma cnj_x_x: "cnj x * x = (abs x)\<^sup>2"
 proof (cases x)
   show "cnj x * x = \<bar>x\<bar>\<^sup>2"
     if "x = Complex x1 x2"
     for x1 :: real
       and x2 :: real
     using that
     by (auto simp: complex_cnj complex_mult abs_complex_def
         complex_norm power2_eq_square complex_of_real_def)
 qed
 
 lemma cnj_x_x_geq0[simp]: \<open>cnj x * x \<ge> 0\<close>
   by (simp add: less_eq_complex_def)
 
 lemma complex_of_real_leq_1_iff[iff]: \<open>complex_of_real x \<le> 1 \<longleftrightarrow> x \<le> 1\<close>
   by (simp add: less_eq_complex_def)
 
 lemma x_cnj_x: \<open>x * cnj x = (abs x)\<^sup>2\<close>
   by (metis cnj_x_x mult.commute)
 
 subsection \<open>List indices and enum\<close>
 
 fun index_of where
   "index_of x [] = (0::nat)"
 | "index_of x (y#ys) = (if x=y then 0 else (index_of x ys + 1))"
 
 definition "enum_idx (x::'a::enum) = index_of x (enum_class.enum :: 'a list)"
 
 lemma index_of_length: "index_of x y \<le> length y"
   apply (induction y) by auto
 
 lemma index_of_correct:
   assumes "x \<in> set y"
   shows "y ! index_of x y = x"
   using assms apply (induction y arbitrary: x)
   by auto
 
 lemma enum_idx_correct: 
   "Enum.enum ! enum_idx i = i"
 proof-
   have "i \<in> set enum_class.enum"
     using UNIV_enum by blast 
   thus ?thesis
     unfolding enum_idx_def
     using index_of_correct by metis
 qed
 
 lemma index_of_bound: 
   assumes "y \<noteq> []" and "x \<in> set y"
   shows "index_of x y < length y"
   using assms proof(induction y arbitrary: x)
   case Nil
   thus ?case by auto
 next
   case (Cons a y)
   show ?case 
   proof(cases "a = x")
     case True
     thus ?thesis by auto
   next
     case False
     moreover have "a \<noteq> x \<Longrightarrow> index_of x y < length y"
       using Cons.IH Cons.prems(2) by fastforce      
     ultimately show ?thesis by auto
   qed
 qed
 
 lemma enum_idx_bound: "enum_idx x < length (Enum.enum :: 'a list)" for x :: "'a::enum"
 proof-
   have p1: "False"
     if "(Enum.enum :: 'a list) = []"
   proof-
     have "(UNIV::'a set) = set ([]::'a list)"
       using that UNIV_enum by metis
     also have "\<dots> = {}"
       by blast
     finally have "(UNIV::'a set) = {}".
     thus ?thesis by simp
   qed    
   have p2: "x \<in> set (Enum.enum :: 'a list)"
     using UNIV_enum by auto
   moreover have "(enum_class.enum::'a list) \<noteq> []"
     using p2 by auto
   ultimately show ?thesis
     unfolding enum_idx_def     
     using index_of_bound [where x = x and y = "(Enum.enum :: 'a list)"]
     by auto   
 qed
 
 lemma index_of_nth:
   assumes "distinct xs"
   assumes "i < length xs"
   shows "index_of (xs ! i) xs = i"
   using assms
   by (metis gr_implies_not_zero index_of_bound index_of_correct length_0_conv nth_eq_iff_index_eq nth_mem)
 
 lemma enum_idx_enum: 
   assumes \<open>i < CARD('a::enum)\<close>
   shows \<open>enum_idx (enum_class.enum ! i :: 'a) = i\<close>
   unfolding enum_idx_def apply (rule index_of_nth)
   using assms by (simp_all add: card_UNIV_length_enum enum_distinct)
 
 subsection \<open>Filtering lists/sets\<close>
 
 lemma map_filter_map: "List.map_filter f (map g l) = List.map_filter (f o g) l"
 proof (induction l)
   show "List.map_filter f (map g []) = List.map_filter (f \<circ> g) []"
     by (simp add: map_filter_simps)
   show "List.map_filter f (map g (a # l)) = List.map_filter (f \<circ> g) (a # l)"
     if "List.map_filter f (map g l) = List.map_filter (f \<circ> g) l"
     for a :: 'c
       and l :: "'c list"
     using that  map_filter_simps(1)
     by (metis comp_eq_dest_lhs list.simps(9))
 qed
 
 lemma map_filter_Some[simp]: "List.map_filter (\<lambda>x. Some (f x)) l = map f l"
 proof (induction l)
   show "List.map_filter (\<lambda>x. Some (f x)) [] = map f []"
     by (simp add: map_filter_simps)
   show "List.map_filter (\<lambda>x. Some (f x)) (a # l) = map f (a # l)"
     if "List.map_filter (\<lambda>x. Some (f x)) l = map f l"
     for a :: 'b
       and l :: "'b list"
     using that by (simp add: map_filter_simps(1))
 qed
 
 lemma filter_Un: "Set.filter f (x \<union> y) = Set.filter f x \<union> Set.filter f y"
   unfolding Set.filter_def by auto  
 
 lemma Set_filter_unchanged: "Set.filter P X = X" if "\<And>x. x\<in>X \<Longrightarrow> P x" for P and X :: "'z set"
   using that unfolding Set.filter_def by auto
 
 subsection \<open>Maps\<close>
 
 definition "inj_map \<pi> = (\<forall>x y. \<pi> x = \<pi> y \<and> \<pi> x \<noteq> None \<longrightarrow> x = y)"
 
 definition "inv_map \<pi> = (\<lambda>y. if Some y \<in> range \<pi> then Some (inv \<pi> (Some y)) else None)"
 
 lemma inj_map_total[simp]: "inj_map (Some o \<pi>) = inj \<pi>"
   unfolding inj_map_def inj_def by simp
 
 lemma inj_map_Some[simp]: "inj_map Some"
   by (simp add: inj_map_def)
 
 lemma inv_map_total: 
   assumes "surj \<pi>"
   shows "inv_map (Some o \<pi>) = Some o inv \<pi>"
 proof-
   have "(if Some y \<in> range (\<lambda>x. Some (\<pi> x))
           then Some (SOME x. Some (\<pi> x) = Some y)
           else None) =
          Some (SOME b. \<pi> b = y)"
     if "surj \<pi>"
     for y
     using that by auto
   hence  "surj \<pi> \<Longrightarrow>
     (\<lambda>y. if Some y \<in> range (\<lambda>x. Some (\<pi> x))
          then Some (SOME x. Some (\<pi> x) = Some y) else None) =
     (\<lambda>x. Some (SOME xa. \<pi> xa = x))"
     by (rule ext) 
   thus ?thesis 
     unfolding inv_map_def o_def inv_def
     using assms by linarith
 qed
 
 lemma inj_map_map_comp[simp]: 
   assumes a1: "inj_map f" and a2: "inj_map g" 
   shows "inj_map (f \<circ>\<^sub>m g)"
   using a1 a2
   unfolding inj_map_def
   by (metis (mono_tags, lifting) map_comp_def option.case_eq_if option.expand)
 
 lemma inj_map_inv_map[simp]: "inj_map (inv_map \<pi>)"
 proof (unfold inj_map_def, rule allI, rule allI, rule impI, erule conjE)
   fix x y
   assume same: "inv_map \<pi> x = inv_map \<pi> y"
     and pix_not_None: "inv_map \<pi> x \<noteq> None"
   have x_pi: "Some x \<in> range \<pi>" 
     using pix_not_None unfolding inv_map_def apply auto
     by (meson option.distinct(1))
   have y_pi: "Some y \<in> range \<pi>" 
     using pix_not_None unfolding same unfolding inv_map_def apply auto
     by (meson option.distinct(1))
   have "inv_map \<pi> x = Some (Hilbert_Choice.inv \<pi> (Some x))"
     unfolding inv_map_def using x_pi by simp
   moreover have "inv_map \<pi> y = Some (Hilbert_Choice.inv \<pi> (Some y))"
     unfolding inv_map_def using y_pi by simp
   ultimately have "Hilbert_Choice.inv \<pi> (Some x) = Hilbert_Choice.inv \<pi> (Some y)"
     using same by simp
   thus "x = y"
     by (meson inv_into_injective option.inject x_pi y_pi)
 qed
 
+subsection \<open>Lattices\<close>
+
+unbundle lattice_syntax
+
+text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_Inf} 
+  except for the more general sort.\<close>
+lemma uminus_Inf: "- (\<Sqinter>A) = \<Squnion>(uminus ` A)" for A :: \<open>'a::complete_orthocomplemented_lattice set\<close>
+proof (rule order.antisym)
+  show "- \<Sqinter>A \<le> \<Squnion>(uminus ` A)"
+    by (rule compl_le_swap2, rule Inf_greatest, rule compl_le_swap2, rule Sup_upper) simp
+  show "\<Squnion>(uminus ` A) \<le> - \<Sqinter>A"
+    by (rule Sup_least, rule compl_le_swap1, rule Inf_lower) auto
+qed
+
+text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_INF}
+  except for the more general sort.\<close>
+lemma uminus_INF: "- (INF x\<in>A. B x) = (SUP x\<in>A. - B x)" for B :: \<open>'a \<Rightarrow> 'b::complete_orthocomplemented_lattice\<close>
+  by (simp add: uminus_Inf image_image)
+
+text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_Sup}
+  except for the more general sort.\<close>
+lemma uminus_Sup: "- (\<Squnion>A) = \<Sqinter>(uminus ` A)" for A :: \<open>'a::complete_orthocomplemented_lattice set\<close>
+  by (metis (no_types, lifting) uminus_INF image_cong image_ident ortho_involution)
+
+text \<open>The following lemma is identical to @{thm [source] Complete_Lattices.uminus_SUP}
+  except for the more general sort.\<close>
+lemma uminus_SUP: "- (SUP x\<in>A. B x) = (INF x\<in>A. - B x)" for B :: \<open>'a \<Rightarrow> 'b::complete_orthocomplemented_lattice\<close>
+  by (simp add: uminus_Sup image_image)
+
+
 end
diff --git a/thys/Linear_Recurrences/Linear_Recurrences_Misc.thy b/thys/Linear_Recurrences/Linear_Recurrences_Misc.thy
--- a/thys/Linear_Recurrences/Linear_Recurrences_Misc.thy
+++ b/thys/Linear_Recurrences/Linear_Recurrences_Misc.thy
@@ -1,227 +1,225 @@
 (*
   File:    Linear_Recurrences_Misc.thy
   Author:  Manuel Eberl, TU München
 *)
 section \<open>Miscellaneous material required for linear recurrences\<close>
 theory Linear_Recurrences_Misc
 imports 
   Complex_Main
   "HOL-Computational_Algebra.Computational_Algebra"
   "HOL-Computational_Algebra.Polynomial_Factorial"
 begin
 
 fun zip_with where
   "zip_with f (x#xs) (y#ys) = f x y # zip_with f xs ys"
 | "zip_with f _ _ = []"
 
 lemma length_zip_with [simp]: "length (zip_with f xs ys) = min (length xs) (length ys)"
   by (induction f xs ys rule: zip_with.induct) simp_all
 
 lemma zip_with_altdef: "zip_with f xs ys = map (\<lambda>(x,y). f x y) (zip xs ys)"
   by (induction f xs ys rule: zip_with.induct) simp_all
   
 lemma zip_with_nth [simp]:
   "n < length xs \<Longrightarrow> n < length ys \<Longrightarrow> zip_with f xs ys ! n = f (xs!n) (ys!n)"
   by (simp add: zip_with_altdef)
 
 lemma take_zip_with: "take n (zip_with f xs ys) = zip_with f (take n xs) (take n ys)"
 proof (induction f xs ys arbitrary: n rule: zip_with.induct)
   case (1 f x xs y ys n)
   thus ?case by (cases n) simp_all
 qed simp_all
 
 lemma drop_zip_with: "drop n (zip_with f xs ys) = zip_with f (drop n xs) (drop n ys)"
 proof (induction f xs ys arbitrary: n rule: zip_with.induct)
   case (1 f x xs y ys n)
   thus ?case by (cases n) simp_all
 qed simp_all
 
 lemma map_zip_with: "map f (zip_with g xs ys) = zip_with (\<lambda>x y. f (g x y)) xs ys"
   by (induction g xs ys rule: zip_with.induct) simp_all
 
 lemma zip_with_map: "zip_with f (map g xs) (map h ys) = zip_with (\<lambda>x y. f (g x) (h y)) xs ys"
   by (induction "\<lambda>x y. f (g x) (h y)" xs ys rule: zip_with.induct) simp_all
 
 lemma zip_with_map_left: "zip_with f (map g xs) ys = zip_with (\<lambda>x y. f (g x) y) xs ys"
   using zip_with_map[of f g xs "\<lambda>x. x" ys] by simp
 
 lemma zip_with_map_right: "zip_with f xs (map g ys) = zip_with (\<lambda>x y. f x (g y)) xs ys"
   using zip_with_map[of f "\<lambda>x. x" xs g ys] by simp
 
 lemma zip_with_swap: "zip_with (\<lambda>x y. f y x) xs ys = zip_with f ys xs"
   by (induction f ys xs rule: zip_with.induct) simp_all
 
 lemma set_zip_with: "set (zip_with f xs ys) = (\<lambda>(x,y). f x y) ` set (zip xs ys)"
   by (induction f xs ys rule: zip_with.induct) simp_all
 
 lemma zip_with_Pair: "zip_with Pair (xs :: 'a list) (ys :: 'b list) = zip xs ys"
   by (induction "Pair :: 'a \<Rightarrow> 'b \<Rightarrow> _" xs ys rule: zip_with.induct) simp_all
 
 lemma zip_with_altdef': 
     "zip_with f xs ys = [f (xs!i) (ys!i). i \<leftarrow> [0..<min (length xs) (length ys)]]"
   by (induction f xs ys rule: zip_with.induct) (simp_all add: map_upt_Suc del: upt_Suc)
 
 lemma zip_altdef: "zip xs ys = [(xs!i, ys!i). i \<leftarrow> [0..<min (length xs) (length ys)]]"
   by (simp add: zip_with_Pair [symmetric] zip_with_altdef')
 
 
 
 lemma card_poly_roots_bound:
   fixes p :: "'a::{comm_ring_1,ring_no_zero_divisors} poly"
   assumes "p \<noteq> 0"
   shows   "card {x. poly p x = 0} \<le> degree p"
 using assms
 proof (induction "degree p" arbitrary: p rule: less_induct)
   case (less p)
   show ?case
   proof (cases "\<exists>x. poly p x = 0")
     case False
     hence "{x. poly p x = 0} = {}" by blast
     thus ?thesis by simp
   next
     case True
     then obtain x where x: "poly p x = 0" by blast
     hence "[:-x, 1:] dvd p" by (subst (asm) poly_eq_0_iff_dvd)
     then obtain q where q: "p = [:-x, 1:] * q" by (auto simp: dvd_def)
     with \<open>p \<noteq> 0\<close> have [simp]: "q \<noteq> 0" by auto
     have deg: "degree p = Suc (degree q)"
       by (subst q, subst degree_mult_eq) auto
     have "card {x. poly p x = 0} \<le> card (insert x {x. poly q x = 0})"
       by (intro card_mono) (auto intro: poly_roots_finite simp: q)
     also have "\<dots> \<le> Suc (card {x. poly q x = 0})"
       by (rule card_insert_le_m1) auto
     also from deg have  "card {x. poly q x = 0} \<le> degree q"
       using \<open>p \<noteq> 0\<close> and q by (intro less) auto
     also have "Suc \<dots> = degree p" by (simp add: deg)
     finally show ?thesis by - simp_all
   qed
 qed
 
 lemma poly_eqI_degree:
   fixes p q :: "'a :: {comm_ring_1, ring_no_zero_divisors} poly"
   assumes "\<And>x. x \<in> A \<Longrightarrow> poly p x = poly q x"
   assumes "card A > degree p" "card A > degree q"
   shows   "p = q"
 proof (rule ccontr)
   assume neq: "p \<noteq> q"
   have "degree (p - q) \<le> max (degree p) (degree q)"
     by (rule degree_diff_le_max)
   also from assms have "\<dots> < card A" by linarith
   also have "\<dots> \<le> card {x. poly (p - q) x = 0}"
     using neq and assms by (intro card_mono poly_roots_finite) auto
   finally have "degree (p - q) < card {x. poly (p - q) x = 0}" .
   moreover have "degree (p - q) \<ge> card {x. poly (p - q) x = 0}"
     using neq by (intro card_poly_roots_bound) auto
   ultimately show False by linarith
 qed  
 
 lemma poly_root_order_induct [case_names 0 no_roots root]:
   fixes p :: "'a :: idom poly"
   assumes "P 0" "\<And>p. (\<And>x. poly p x \<noteq> 0) \<Longrightarrow> P p" 
           "\<And>p x n. n > 0 \<Longrightarrow> poly p x \<noteq> 0 \<Longrightarrow> P p \<Longrightarrow> P ([:-x, 1:] ^ n * p)"
   shows   "P p"
 proof (induction "degree p" arbitrary: p rule: less_induct)
   case (less p)
   consider "p = 0" | "p \<noteq> 0" "\<exists>x. poly p x = 0" | "\<And>x. poly p x \<noteq> 0" by blast
   thus ?case
   proof cases
     case 3
     with assms(2)[of p] show ?thesis by simp
   next
     case 2
     then obtain x where x: "poly p x = 0" by auto
     have "[:-x, 1:] ^ order x p dvd p" by (intro order_1)
     then obtain q where q: "p = [:-x, 1:] ^ order x p * q" by (auto simp: dvd_def)
     with 2 have [simp]: "q \<noteq> 0" by auto
     have order_pos: "order x p > 0"
       using \<open>p \<noteq> 0\<close> and x by (auto simp: order_root)
     have "order x p = order x p + order x q"
       by (subst q, subst order_mult) (auto simp: order_power_n_n)
     hence [simp]: "order x q = 0" by simp
     have deg: "degree p = order x p + degree q"
       by (subst q, subst degree_mult_eq) (auto simp: degree_power_eq)
     with order_pos have "degree q < degree p" by simp
     hence "P q" by (rule less)
     with order_pos have "P ([:-x, 1:] ^ order x p * q)"
       by (intro assms(3)) (auto simp: order_root)
     with q show ?thesis by simp
   qed (simp_all add: assms(1))
 qed
 
 lemma complex_poly_decompose:
   "smult (lead_coeff p) (\<Prod>z|poly p z = 0. [:-z, 1:] ^ order z p) = (p :: complex poly)"
 proof (induction p rule: poly_root_order_induct)
   case (no_roots p)
   show ?case
   proof (cases "degree p = 0")
     case False
     hence "\<not>constant (poly p)" by (subst constant_degree)
     with fundamental_theorem_of_algebra and no_roots show ?thesis by blast
   qed (auto elim!: degree_eq_zeroE)
 next
   case (root p x n)
   from root have *: "{z. poly ([:- x, 1:] ^ n * p) z = 0} = insert x {z. poly p z = 0}"
     by auto
   have "smult (lead_coeff ([:-x, 1:] ^ n * p)) 
            (\<Prod>z|poly ([:-x,1:] ^ n * p) z = 0. [:-z, 1:] ^ order z ([:- x, 1:] ^ n * p)) = 
         [:- x, 1:] ^ order x ([:- x, 1:] ^ n * p) * 
           smult (lead_coeff p) (\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z ([:- x, 1:] ^ n * p))"
     by (subst *, subst prod.insert) 
        (insert root, auto intro: poly_roots_finite simp: mult_ac lead_coeff_mult lead_coeff_power)
   also have "order x ([:- x, 1:] ^ n * p) = n"
     using root by (subst order_mult) (auto simp: order_power_n_n order_0I)
   also have "(\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z ([:- x, 1:] ^ n * p)) =
                (\<Prod>z\<in>{z. poly p z = 0}. [:- z, 1:] ^ order z p)"
   proof (intro prod.cong refl, goal_cases)
     case (1 y)
     with root have "order y ([:-x,1:] ^ n) = 0" by (intro order_0I) auto 
     thus ?case using root by (subst order_mult) auto
   qed
   also note root.IH
   finally show ?case .
 qed simp_all
 
 
 lemma normalize_field: 
   "normalize (x :: 'a :: {normalization_semidom,field}) = (if x = 0 then 0 else 1)"
   by (auto simp: normalize_1_iff dvd_field_iff)
 
 lemma unit_factor_field [simp]:
   "unit_factor (x :: 'a :: {normalization_semidom,field}) = x"
   using unit_factor_mult_normalize[of x] normalize_field[of x]
   by (simp split: if_splits)
 
 lemma coprime_linear_poly: 
   fixes c :: "'a :: field_gcd"
   assumes "c \<noteq> c'"
   shows   "coprime [:c,1:] [:c',1:]"
 proof -
   have "gcd [:c,1:] [:c',1:] = gcd ([:c,1:] - [:c',1:]) [:c',1:]"
     by (rule gcd_diff1 [symmetric])
   also have "[:c,1:] - [:c',1:] = [:c-c':]" by simp
   also from assms have "gcd \<dots> [:c',1:] = normalize [:c-c':]"
     by (intro gcd_proj1_if_dvd) (auto simp: const_poly_dvd_iff dvd_field_iff)
   also from assms have "\<dots> = 1" by (simp add: normalize_poly_def)
   finally show "coprime [:c,1:] [:c',1:]"
     by (simp add: gcd_eq_1_imp_coprime)
 qed
 
 lemma coprime_linear_poly': 
   fixes c :: "'a :: field_gcd"
   assumes "c \<noteq> c'" "c \<noteq> 0" "c' \<noteq> 0"
   shows   "coprime [:1,c:] [:1,c':]"
 proof -
   have "gcd [:1,c:] [:1,c':] = gcd ([:1,c:] mod [:1,c':]) [:1,c':]"
     by simp
-  also have "eucl_rel_poly [:1, c:] [:1, c':] ([:c/c':], [:1-c/c':])"
-    using assms by (auto simp add: eucl_rel_poly_iff one_pCons)
-  hence "[:1,c:] mod [:1,c':] = [:1 - c / c':]"
-    by (rule mod_poly_eq)
+  also have \<open>[:1,c:] mod [:1,c':] = [:1 - c / c':]\<close>
+    using \<open>c' \<noteq> 0\<close> by (simp add: mod_pCons)
   also from assms have "gcd \<dots> [:1,c':] = normalize ([:1 - c / c':])"
     by (intro gcd_proj1_if_dvd) (auto simp: const_poly_dvd_iff dvd_field_iff)
   also from assms have "\<dots> = 1" by (auto simp: normalize_poly_def)
   finally show ?thesis
     by (rule gcd_eq_1_imp_coprime)
 qed
 
 end
diff --git a/thys/Polynomial_Interpolation/Ring_Hom_Poly.thy b/thys/Polynomial_Interpolation/Ring_Hom_Poly.thy
--- a/thys/Polynomial_Interpolation/Ring_Hom_Poly.thy
+++ b/thys/Polynomial_Interpolation/Ring_Hom_Poly.thy
@@ -1,450 +1,455 @@
 (*  
     Author:      René Thiemann 
                  Akihisa Yamada
     License:     BSD
 *)
 section \<open>Connecting Polynomials with Homomorphism Locales\<close>
 
 theory Ring_Hom_Poly
 imports 
   "HOL-Computational_Algebra.Euclidean_Algorithm"
   Ring_Hom
   Missing_Polynomial
 begin
 
 text\<open>@{term poly} as a homomorphism. Note that types differ.\<close>
 
 interpretation poly_hom: comm_semiring_hom "\<lambda>p. poly p a" by (unfold_locales, auto)
 
 interpretation poly_hom: comm_ring_hom "\<lambda>p. poly p a"..
 
 interpretation poly_hom: idom_hom "\<lambda>p. poly p a"..
 
 text \<open>@{term "(\<circ>\<^sub>p)"} as a homomorphism.\<close>
 
 interpretation pcompose_hom: comm_semiring_hom "\<lambda>q. q \<circ>\<^sub>p p"
   using pcompose_add pcompose_mult pcompose_1 by (unfold_locales, auto)
 
 interpretation pcompose_hom: comm_ring_hom "\<lambda>q. q \<circ>\<^sub>p p" ..
 
 interpretation pcompose_hom: idom_hom "\<lambda>q. q \<circ>\<^sub>p p" ..
 
 
 
 definition eval_poly :: "('a \<Rightarrow> 'b :: comm_semiring_1) \<Rightarrow> 'a :: zero poly \<Rightarrow> 'b \<Rightarrow> 'b" where
   [code del]: "eval_poly h p = poly (map_poly h p)"
 
 lemma eval_poly_code[code]: "eval_poly h p x = fold_coeffs (\<lambda> a b. h a + x * b) p 0" 
   by (induct p, auto simp: eval_poly_def)
 
 lemma eval_poly_as_sum:
   fixes h :: "'a :: zero \<Rightarrow> 'b :: comm_semiring_1"
   assumes "h 0 = 0"
   shows "eval_poly h p x = (\<Sum>i\<le>degree p. x^i * h (coeff p i))"
   unfolding eval_poly_def
 proof (induct p)
   case 0 show ?case using assms by simp
   next case (pCons a p) thus ?case
     proof (cases "p = 0")
       case True show ?thesis by (simp add: True map_poly_simps assms)
       next case False show ?thesis
         unfolding degree_pCons_eq[OF False]
         unfolding sum.atMost_Suc_shift
         unfolding map_poly_pCons[OF pCons(1)]
         by (simp add: pCons(2) sum_distrib_left mult.assoc)
   qed
 qed
 
 lemma coeff_const: "coeff [: a :] i = (if i = 0 then a else 0)"
   by (metis coeff_monom monom_0)
 
 lemma x_as_monom: "[:0,1:] = monom 1 1"
   by (simp add: monom_0 monom_Suc)
 
 lemma x_pow_n: "monom 1 1 ^ n = monom 1 n"
   by (induct n) (simp_all add: monom_0 monom_Suc)
 
 lemma map_poly_eval_poly: assumes h0: "h 0 = 0"
   shows "map_poly h p = eval_poly (\<lambda> a. [: h a :]) p [:0,1:]" (is "?mp = ?ep")
 proof (rule poly_eqI)
   fix i :: nat
   have 2: "(\<Sum>x\<le>i. \<Sum>xa\<le>degree p. (if xa = x then 1 else 0) * coeff [:h (coeff p xa):] (i - x)) 
     = h (coeff p i)" (is "sum ?f ?s = ?r")
   proof -
     have "sum ?f ?s = ?f i + sum ?f ({..i} - {i})"
       by (rule sum.remove[of _ i], auto)
     also have "sum ?f ({..i} - {i}) = 0"
       by (rule sum.neutral, intro ballI, rule sum.neutral, auto simp: coeff_const)
     also have "?f i = (\<Sum>xa\<le>degree p. (if xa = i then 1 else 0) * h (coeff p xa))" (is "_ = ?m")
       unfolding coeff_const by simp
     also have "\<dots> = ?r"
     proof (cases "i \<le> degree p")
       case True
       show ?thesis
         by (subst sum.remove[of _ i], insert True, auto)
     next
       case False
       hence [simp]: "coeff p i = 0" using le_degree by blast
       show ?thesis
         by (subst sum.neutral, auto simp: h0)
     qed
     finally show ?thesis by simp
   qed
   have h'0: "[: h 0 :] = 0" using h0 by auto
   show "coeff ?mp i = coeff ?ep i"
     unfolding coeff_map_poly[of h, OF h0]
     unfolding eval_poly_as_sum[of "\<lambda>a. [: h a :]", OF h'0]
     unfolding coeff_sum
     unfolding x_as_monom x_pow_n coeff_mult
     unfolding sum.swap[of _ _ "{..degree p}"]
     unfolding coeff_monom using 2 by auto
 qed
 
 lemma smult_as_map_poly: "smult a = map_poly ((*) a)"
   by (rule ext, rule poly_eqI, subst coeff_map_poly, auto)
 
 
 subsection \<open>@{const map_poly} of Homomorphisms\<close>
 
 context zero_hom begin
   text \<open>We will consider @{term hom} is always simpler than @{term "map_poly hom"}.\<close>
   lemma map_poly_hom_monom[simp]: "map_poly hom (monom a i) = monom (hom a) i"
     by(rule map_poly_monom, auto)
   lemma coeff_map_poly_hom[simp]: "coeff (map_poly hom p) i = hom (coeff p i)"
     by (rule coeff_map_poly, rule hom_zero)
 end
 
 locale map_poly_zero_hom = base: zero_hom
 begin
   sublocale zero_hom "map_poly hom" by (unfold_locales, auto)
 end
 
 text \<open>@{const map_poly} preserves homomorphisms over addition.\<close>
 
 context comm_monoid_add_hom
 begin
   lemma map_poly_hom_add[hom_distribs]:
     "map_poly hom (p + q) = map_poly hom p + map_poly hom q"
     by (rule map_poly_add; simp add: hom_distribs)
 end
 
 locale map_poly_comm_monoid_add_hom = base: comm_monoid_add_hom
 begin
   sublocale comm_monoid_add_hom "map_poly hom" by (unfold_locales, auto simp:hom_distribs)
 end
 
 text \<open>To preserve homomorphisms over multiplication, it demands commutative ring homomorphisms.\<close>
 context comm_semiring_hom begin
   lemma map_poly_pCons_hom[hom_distribs]: "map_poly hom (pCons a p) = pCons (hom a) (map_poly hom p)"
     unfolding map_poly_simps by auto
   lemma map_poly_hom_smult[hom_distribs]:
     "map_poly hom (smult c p) = smult (hom c) (map_poly hom p)"
     by (induct p, auto simp: hom_distribs)
   lemma poly_map_poly[simp]: "poly (map_poly hom p) (hom x) = hom (poly p x)"
     by (induct p; simp add: hom_distribs)
 end
 
 locale map_poly_comm_semiring_hom = base: comm_semiring_hom
 begin
   sublocale map_poly_comm_monoid_add_hom..
   sublocale comm_semiring_hom "map_poly hom"
   proof
     show "map_poly hom 1 = 1" by simp
     fix p q show "map_poly hom (p * q) = map_poly hom p * map_poly hom q"
       by (induct p, auto simp: hom_distribs)
   qed
 end
 
 locale map_poly_comm_ring_hom = base: comm_ring_hom
 begin
   sublocale map_poly_comm_semiring_hom..
   sublocale comm_ring_hom "map_poly hom"..
 end
 
 locale map_poly_idom_hom = base: idom_hom
 begin
   sublocale map_poly_comm_ring_hom..
   sublocale idom_hom "map_poly hom"..
 end
 
 subsubsection \<open>Injectivity\<close>
 
 locale map_poly_inj_zero_hom = base: inj_zero_hom
 begin
   sublocale inj_zero_hom "map_poly hom"
   proof (unfold_locales)
     fix p q :: "'a poly" assume "map_poly hom p = map_poly hom q"
     from cong[of "\<lambda>p. coeff p _", OF refl this] show "p = q" by (auto intro: poly_eqI)
   qed simp
 end
 
 locale map_poly_inj_comm_monoid_add_hom = base: inj_comm_monoid_add_hom
 begin
   sublocale map_poly_comm_monoid_add_hom..
   sublocale map_poly_inj_zero_hom..
   sublocale inj_comm_monoid_add_hom "map_poly hom"..
 end
 
 locale map_poly_inj_comm_semiring_hom = base: inj_comm_semiring_hom
 begin
   sublocale map_poly_comm_semiring_hom..
   sublocale map_poly_inj_zero_hom..
   sublocale inj_comm_semiring_hom "map_poly hom"..
 end
 
 locale map_poly_inj_comm_ring_hom = base: inj_comm_ring_hom
 begin
   sublocale map_poly_inj_comm_semiring_hom..
   sublocale inj_comm_ring_hom "map_poly hom"..
 end
 
 locale map_poly_inj_idom_hom = base: inj_idom_hom
 begin
   sublocale map_poly_inj_comm_ring_hom..
   sublocale inj_idom_hom "map_poly hom"..
 end
 
 
 
 
 lemma degree_map_poly_le: "degree (map_poly f p) \<le> degree p"
   by(induct p;auto)
 
 lemma coeffs_map_poly: (* An exact variant *)
   assumes "f (lead_coeff p) = 0 \<longleftrightarrow> p = 0"
   shows "coeffs (map_poly f p) = map f (coeffs p)"
   unfolding coeffs_map_poly using assms by (simp add:coeffs_def)
 
 lemma degree_map_poly: (* An exact variant *)
   assumes "f (lead_coeff p) = 0 \<longleftrightarrow> p = 0"
   shows   "degree (map_poly f p) = degree p"
   unfolding degree_eq_length_coeffs unfolding coeffs_map_poly[of f, OF assms] by simp
 
 context zero_hom_0 begin
   lemma degree_map_poly_hom[simp]: "degree (map_poly hom p) = degree p"
     by (rule degree_map_poly, auto)
   lemma coeffs_map_poly_hom[simp]: "coeffs (map_poly hom p) = map hom (coeffs p)"
     by (rule coeffs_map_poly, auto)
   lemma hom_lead_coeff[simp]: "lead_coeff (map_poly hom p) = hom (lead_coeff p)"
     by simp
 end
 
 context comm_semiring_hom begin
 
   interpretation map_poly_hom: map_poly_comm_semiring_hom..
 
   lemma poly_map_poly_0[simp]:
     "poly (map_poly hom p) 0 = hom (poly p 0)" (is "?l = ?r")
   proof-
     have "?l = poly (map_poly hom p) (hom 0)" by auto
     then show ?thesis unfolding poly_map_poly.
   qed
 
   lemma poly_map_poly_1[simp]:
     "poly (map_poly hom p) 1 = hom (poly p 1)" (is "?l = ?r")
   proof-
     have "?l = poly (map_poly hom p) (hom 1)" by auto
     then show ?thesis unfolding poly_map_poly.
   qed
 
   lemma map_poly_hom_as_monom_sum:
     "(\<Sum>j\<le>degree p. monom (hom (coeff p j)) j) = map_poly hom p"
   proof -
     show ?thesis
       by (subst(6) poly_as_sum_of_monoms'[OF le_refl, symmetric], simp add: hom_distribs)
   qed
 
   lemma map_poly_pcompose[hom_distribs]:
     "map_poly hom (f \<circ>\<^sub>p g) = map_poly hom f \<circ>\<^sub>p map_poly hom g"
     by (induct f arbitrary: g; auto simp: hom_distribs)
 
 end
 
 context comm_semiring_hom begin
 
 lemma eval_poly_0[simp]: "eval_poly hom 0 x = 0" unfolding eval_poly_def by simp
 lemma eval_poly_monom: "eval_poly hom (monom a n) x = hom a * x ^ n"
   unfolding eval_poly_def
   unfolding map_poly_monom[of hom, OF hom_zero] using poly_monom.
 
 lemma poly_map_poly_eval_poly: "poly (map_poly hom p) = eval_poly hom p"
   unfolding eval_poly_def..
 
 lemma map_poly_eval_poly: 
   "map_poly hom p = eval_poly (\<lambda> a. [: hom a :]) p [:0,1:]" 
   by (rule map_poly_eval_poly, simp)
 
 lemma degree_extension: assumes "degree p \<le> n"
   shows "(\<Sum>i\<le>degree p. x ^ i * hom (coeff p i))
       = (\<Sum>i\<le>n. x ^ i * hom (coeff p i))" (is "?l = ?r")
 proof -
   let ?f = "\<lambda> i. x ^ i * hom (coeff p i)"
   define m where "m = n - degree p"
   have n: "n = degree p + m" unfolding m_def using assms by auto
   have "?r = (\<Sum> i \<le> degree p + m. ?f i)" unfolding n ..
   also have "\<dots> = ?l + sum ?f {Suc (degree p) .. degree p + m}"
     by (subst sum.union_disjoint[symmetric], auto intro: sum.cong)
   also have "sum ?f {Suc (degree p) .. degree p + m} = 0"
     by (rule sum.neutral, auto simp: coeff_eq_0)
   finally show ?thesis by simp
 qed
 
 lemma eval_poly_add[simp]: "eval_poly hom (p + q) x = eval_poly hom p x + eval_poly hom q x"
   unfolding eval_poly_def hom_distribs..
 
 lemma eval_poly_sum: "eval_poly hom (\<Sum>k\<in>A. p k) x = (\<Sum>k\<in>A. eval_poly hom (p k) x)"
 proof (induct A rule: infinite_finite_induct)
   case (insert a A)
   show ?case
     unfolding sum.insert[OF insert(1-2)] insert(3)[symmetric] by simp
 qed (auto simp: eval_poly_def)
 
 lemma eval_poly_poly: "eval_poly hom p (hom x) = hom (poly p x)"
   unfolding eval_poly_def by auto
 
 end
 
 context comm_ring_hom begin
   interpretation map_poly_hom: map_poly_comm_ring_hom..
 
   lemma pseudo_divmod_main_hom:
     "pseudo_divmod_main (hom lc) (map_poly hom q) (map_poly hom r) (map_poly hom d) dr i =
      map_prod (map_poly hom) (map_poly hom) (pseudo_divmod_main lc q r d dr i)"
   proof-
     show ?thesis by (induct lc q r d dr i rule:pseudo_divmod_main.induct, auto simp: Let_def hom_distribs)
   qed
 end
 
 lemma(in inj_comm_ring_hom) pseudo_divmod_hom:
   "pseudo_divmod (map_poly hom p) (map_poly hom q) =
    map_prod (map_poly hom) (map_poly hom) (pseudo_divmod p q)"
   unfolding pseudo_divmod_def using pseudo_divmod_main_hom[of _ 0] by (cases "q = 0",auto)
 
 lemma(in inj_idom_hom) pseudo_mod_hom:
   "pseudo_mod (map_poly hom p) (map_poly hom q) = map_poly hom (pseudo_mod p q)"
   using pseudo_divmod_hom unfolding pseudo_mod_def by auto
 
 lemma(in idom_hom) map_poly_pderiv[hom_distribs]:
   "map_poly hom (pderiv p) = pderiv (map_poly hom p)"
 proof (induct p rule: pderiv.induct)
   case (1 a p)
   then show ?case unfolding pderiv.simps map_poly_pCons_hom by (cases "p = 0", auto simp: hom_distribs)
 qed
 
 context field_hom
 begin
 
-lemma map_poly_pdivmod[hom_distribs]:
-  "map_prod (map_poly hom) (map_poly hom) (p div q, p mod q) =
-    (map_poly hom p div map_poly hom q, map_poly hom p mod map_poly hom q)"
-  (is "?l = ?r")
+lemma dvd_map_poly_hom_imp_dvd: \<open>map_poly hom x dvd map_poly hom y \<Longrightarrow> x dvd y\<close>
+  by (smt (verit, del_insts) degree_map_poly_hom hom_0 hom_div hom_lead_coeff hom_one hom_power map_poly_hom_smult map_poly_zero mod_eq_0_iff_dvd mod_poly_def pseudo_mod_hom)
+
+lemma map_poly_pdivmod [hom_distribs]:
+  \<open>map_prod (map_poly hom) (map_poly hom) (p div q, p mod q) =
+    (map_poly hom p div map_poly hom q, map_poly hom p mod map_poly hom q)\<close>
 proof -
-  let ?mp = "map_poly hom"
-  interpret map_poly_hom: map_poly_idom_hom..
-  obtain r s where dm: "(p div q, p mod q) = (r, s)"
-    by force  
-  hence r: "r = p div q" and s: "s = p mod q"
-    by simp_all
-  from dm [folded pdivmod_pdivmodrel] have "eucl_rel_poly p q (r, s)"
-    by auto
-  from this[unfolded eucl_rel_poly_iff]
-  have eq: "p = r * q + s" and cond: "(if q = 0 then r = 0 else s = 0 \<or> degree s < degree q)" by auto
-  from arg_cong[OF eq, of ?mp, unfolded map_poly_add]
-  have eq: "?mp p = ?mp q * ?mp r + ?mp s" by (auto simp: hom_distribs)
-  from cond have cond: "(if ?mp q = 0 then ?mp r = 0 else ?mp s = 0 \<or> degree (?mp s) < degree (?mp q))"
+  let ?mp = \<open>map_poly hom\<close>
+  interpret map_poly_hom: map_poly_idom_hom ..
+  have \<open>(?mp p div ?mp q, ?mp p mod ?mp q) = (?mp (p div q), ?mp (p mod q))\<close>
+  proof (cases \<open>?mp q\<close> \<open>?mp (p div q)\<close> \<open>?mp (p mod q)\<close> \<open>?mp p\<close> rule: euclidean_relation_polyI)
+    case by0
+    then show ?case
+      by simp
+  next
+    case divides
+    then have \<open>q \<noteq> 0\<close> \<open>q dvd p\<close>
+      by (auto dest: dvd_map_poly_hom_imp_dvd)
+    from \<open>q dvd p\<close> obtain r where \<open>p = q * r\<close> ..
+    with \<open>q \<noteq> 0\<close> show ?case
+      by (simp add: map_poly_hom.hom_mult)
+  next
+    case euclidean_relation
+    with degree_mod_less_degree [of q p] show ?case
+      by (auto simp flip: map_poly_hom.hom_mult map_poly_hom_add)
+  qed
+  then show ?thesis
     by simp
-  from eq cond have "eucl_rel_poly (?mp p) (?mp q) (?mp r, ?mp s)"
-    unfolding eucl_rel_poly_iff by auto
-  from this[unfolded pdivmod_pdivmodrel]
-  show ?thesis unfolding dm prod.simps by simp
 qed
 
 lemma map_poly_div[hom_distribs]: "map_poly hom (p div q) = map_poly hom p div map_poly hom q"
   using map_poly_pdivmod[of p q] by simp
 
 lemma map_poly_mod[hom_distribs]: "map_poly hom (p mod q) = map_poly hom p mod map_poly hom q"
   using map_poly_pdivmod[of p q] by simp
 
 end
 
 locale field_hom' = field_hom hom
   for hom :: "'a :: {field_gcd} \<Rightarrow> 'b :: {field_gcd}"
 begin
 
 lemma map_poly_normalize[hom_distribs]: "map_poly hom (normalize p) = normalize (map_poly hom p)"
   by (simp add: normalize_poly_def hom_distribs)
 
 lemma map_poly_gcd[hom_distribs]: "map_poly hom (gcd p q) = gcd (map_poly hom p) (map_poly hom q)"
   by (induct p q rule: eucl_induct)
     (simp_all add: map_poly_normalize ac_simps hom_distribs)
 
 end
 
 definition div_poly :: "'a :: euclidean_semiring \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
   "div_poly a p = map_poly (\<lambda> c. c div a) p"
 
 lemma smult_div_poly: assumes "\<And> c. c \<in> set (coeffs p) \<Longrightarrow> a dvd c"
   shows "smult a (div_poly a p) = p" 
   unfolding smult_as_map_poly div_poly_def 
   by (subst map_poly_map_poly, force, subst map_poly_idI, insert assms, auto)
 
 lemma coeff_div_poly: "coeff (div_poly a f) n = coeff f n div a" 
   unfolding div_poly_def
   by (rule coeff_map_poly, auto)
 
 locale map_poly_inj_idom_divide_hom = base: inj_idom_divide_hom
 begin
 sublocale map_poly_idom_hom ..
 sublocale map_poly_inj_zero_hom .. 
 sublocale inj_idom_hom "map_poly hom" ..
 lemma divide_poly_main_hom: defines "hh \<equiv> map_poly hom" 
   shows "hh (divide_poly_main lc f g h i j) = divide_poly_main (hom lc) (hh f) (hh g) (hh h) i j"  
   unfolding hh_def
 proof (induct j arbitrary: lc f g h i)
   case (Suc j lc f g h i)
   let ?h = "map_poly hom" 
   show ?case unfolding divide_poly_main.simps Let_def
     unfolding base.coeff_map_poly_hom base.hom_div[symmetric] base.hom_mult[symmetric] base.eq_iff
       if_distrib[of ?h] hom_zero
     by (rule if_cong[OF refl _ refl], subst Suc, simp add: hom_minus hom_add hom_mult)
 qed simp
 
 sublocale inj_idom_divide_hom "map_poly hom" 
 proof
   fix f g :: "'a poly" 
   let ?h = "map_poly hom" 
   show "?h (f div g) = (?h f) div (?h g)" unfolding divide_poly_def if_distrib[of ?h]
     divide_poly_main_hom by simp
 qed
 
 lemma order_hom: "order (hom x) (map_poly hom f) = order x f"
   unfolding Polynomial.order_def unfolding hom_dvd_iff[symmetric]
   unfolding hom_power by (simp add: base.hom_uminus)
 end
 
 
 subsection \<open>Example Interpretations\<close>
 
 abbreviation "of_int_poly \<equiv> map_poly of_int"
 
 interpretation of_int_poly_hom: map_poly_comm_semiring_hom of_int..
 interpretation of_int_poly_hom: map_poly_comm_ring_hom of_int..
 interpretation of_int_poly_hom: map_poly_idom_hom of_int..
 interpretation of_int_poly_hom:
   map_poly_inj_comm_ring_hom "of_int :: int  \<Rightarrow> 'a :: {comm_ring_1,ring_char_0}" ..
 interpretation of_int_poly_hom:
   map_poly_inj_idom_hom "of_int :: int  \<Rightarrow> 'a :: {idom,ring_char_0}" ..
 
 
 text \<open>The following operations are homomorphic w.r.t. only @{class monoid_add}.\<close>
 
 interpretation pCons_0_hom: injective "pCons 0" by (unfold_locales, auto)
 interpretation pCons_0_hom: zero_hom_0 "pCons 0" by (unfold_locales, auto)
 interpretation pCons_0_hom: inj_comm_monoid_add_hom "pCons 0" by (unfold_locales, auto)
 interpretation pCons_0_hom: inj_ab_group_add_hom "pCons 0" by (unfold_locales, auto)
 
 interpretation monom_hom: injective "\<lambda>x. monom x d" by (unfold_locales, auto)
 interpretation monom_hom: inj_monoid_add_hom "\<lambda>x. monom x d" by (unfold_locales, auto simp: add_monom)
 interpretation monom_hom: inj_comm_monoid_add_hom "\<lambda>x. monom x d"..
 
 end
diff --git a/thys/Subresultants/Subresultant.thy b/thys/Subresultants/Subresultant.thy
--- a/thys/Subresultants/Subresultant.thy
+++ b/thys/Subresultants/Subresultant.thy
@@ -1,2778 +1,2778 @@
 section \<open>Subresultants and the subresultant PRS\<close>
 
 text \<open>This theory contains most of the soundness proofs of the subresultant PRS algorithm,
   where we closely follow the papers of Brown \cite{Brown} and Brown and Traub \cite{BrownTraub}.
   This is in contrast to a similar Coq formalization of Mahboubi \cite{Mahboubi06} which
   is based on polynomial determinants.
 
   Whereas the current file only contains an algorithm to compute the resultant of two polynomials
   efficiently, there is another theory ``Subresultant-Gcd'' which also contains the algorithm
   to compute the GCD of two polynomials via the subresultant algorithm. In both algorithms we
   integrate Lazard's optimization in the dichotomous version,
   but not the second optmization described by Ducos \cite{Ducos}.\<close>
 theory Subresultant
 imports
   Resultant_Prelim
   Dichotomous_Lazard
   Binary_Exponentiation
   More_Homomorphisms
   Coeff_Int
 begin
 
 subsection \<open>Algorithm\<close>
 
 locale div_exp_param =
   fixes div_exp :: "'a :: idom_divide \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
 begin
 partial_function(tailrec) subresultant_prs_main where
   "subresultant_prs_main f g c = (let
    m = degree f;
    n = degree g;
    lf = lead_coeff f;
    lg = lead_coeff g;
    \<delta> = m - n;
    d = div_exp lg c \<delta>;
    h = pseudo_mod f g
   in if h = 0 then (g,d)
      else subresultant_prs_main g (sdiv_poly h ((-1) ^ (\<delta> + 1) * lf * (c ^ \<delta>))) d)"
 
 definition subresultant_prs where
   "subresultant_prs f g = (let
     h = pseudo_mod f g;
     \<delta> = (degree f - degree g);
     d = lead_coeff g ^ \<delta>
     in if h = 0 then (g,d)
        else subresultant_prs_main g ((- 1) ^ (\<delta> + 1) * h) d)"
 
 definition resultant_impl_main where
   "resultant_impl_main G1 G2 = (if G2 = 0 then (if degree G1 = 0 then 1 else 0) else
      case subresultant_prs G1 G2 of
      (Gk,hk) \<Rightarrow> (if degree Gk = 0 then hk else 0))"
 
 definition resultant_impl where
   "resultant_impl f g =
      (if length (coeffs f) \<ge> length (coeffs g) then resultant_impl_main f g
      else let res = resultant_impl_main g f in
       if even (degree f) \<or> even (degree g) then res else - res)"
 end
 
 locale div_exp_sound = div_exp_param + 
   assumes div_exp: "\<And> x y n.
      (to_fract x)^n / (to_fract y)^(n-1) \<in> range to_fract
      \<Longrightarrow> to_fract (div_exp x y n) = (to_fract x)^n / (to_fract y)^(n-1)"
 
 definition basic_div_exp :: "'a :: idom_divide \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
   "basic_div_exp x y n = x^n div y^(n-1)"
 
 text \<open>We have an instance for arbitrary integral domains.\<close>
 lemma basic_div_exp: "div_exp_sound basic_div_exp" 
   by (unfold_locales, unfold basic_div_exp_def, rule sym, rule div_divide_to_fract, auto simp: hom_distribs)
 
 text \<open>Lazard's optimization is only proven for factorial rings.\<close>
 lemma dichotomous_Lazard: "div_exp_sound (dichotomous_Lazard :: 'a :: factorial_ring_gcd \<Rightarrow> _)" 
   by (unfold_locales, rule dichotomous_Lazard)
 
 subsection \<open>Soundness Proof for @{term "div_exp_param.resultant_impl div_exp = resultant"}\<close>
 
 abbreviation pdivmod :: "'a::field poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly \<times> 'a poly"
 where
   "pdivmod p q \<equiv> (p div q, p mod q)"
 
 lemma even_sum_list: assumes "\<And> x. x \<in> set xs \<Longrightarrow> even (f x) = even (g x)"
   shows "even (sum_list (map f xs)) = even (sum_list (map g xs))"
   using assms by (induct xs, auto)
 
 lemma for_all_Suc: "P i \<Longrightarrow> (\<forall> j \<ge> Suc i. P j) = (\<forall> j \<ge> i. P j)" for P
   by (metis (full_types) Suc_le_eq less_le)
 
 (* part on pseudo_divmod *)
 lemma pseudo_mod_left_0[simp]: "pseudo_mod 0 x = 0"
   unfolding pseudo_mod_def pseudo_divmod_def
   by (cases "x = 0"; cases "length (coeffs x)", auto)
 
 lemma pseudo_mod_right_0[simp]: "pseudo_mod x 0 = x"
   unfolding pseudo_mod_def pseudo_divmod_def by simp
 
 lemma snd_pseudo_divmod_main_cong:
   assumes "a1 = b1" "a3 = b3" "a4 = b4" "a5 = b5" "a6 = b6" (* note that a2 = b2 is not required! *)
   shows "snd (pseudo_divmod_main a1 a2 a3 a4 a5 a6) = snd (pseudo_divmod_main b1 b2 b3 b4 b5 b6)"
 using assms snd_pseudo_divmod_main by metis
 
 lemma snd_pseudo_mod_smult_invar_right:
   shows "(snd (pseudo_divmod_main (x * lc) q r (smult x d) dr n))
          = snd (pseudo_divmod_main lc q' (smult (x^n) r) d dr n)"
 proof(induct n arbitrary: q q' r dr)
   case (Suc n)
   let ?q = "smult (x * lc) q + monom (coeff r dr) n"
   let ?r = "smult (x * lc) r - (smult x (monom (coeff r dr) n * d))"
   let ?dr = "dr - 1"
   let ?rec_lhs = "pseudo_divmod_main (x * lc) ?q ?r (smult x d) ?dr n"
   let ?rec_rhs = "pseudo_divmod_main lc q' (smult (x^n) ?r) d ?dr n"
   have [simp]: "\<And> n. x ^ n * (x * lc) = lc * (x * x ^ n)"
                "\<And> n c. x ^ n * (x * c) = x * x ^ n * c"
                "\<And> n. x * x ^ n * lc = lc * (x * x ^ n)"
     by (auto simp: ac_simps)
   have "snd (pseudo_divmod_main (x * lc) q r (smult x d) dr (Suc n)) = snd ?rec_lhs"
     by (auto simp:Let_def)
   also have "\<dots> = snd ?rec_rhs" using Suc by auto
   also have "\<dots> = snd (pseudo_divmod_main lc q' (smult (x^Suc n) r) d dr (Suc n))"
     unfolding pseudo_divmod_main.simps Let_def
     proof(rule snd_pseudo_divmod_main_cong,goal_cases)
       case 2
       show ?case by (auto simp:smult_add_right smult_diff_right smult_monom smult_monom_mult)
     qed auto
   finally show ?case by auto
 qed auto
 
 lemma snd_pseudo_mod_smult_invar_left:
   shows "snd (pseudo_divmod_main lc q (smult x r) d dr n)
        = smult x (snd (pseudo_divmod_main lc q' r d dr n))"
 proof(induct n arbitrary:x lc q q' r d dr)
   case (Suc n)
   have sm:"smult lc (smult x r) - monom (coeff (smult x r) dr) n * d
           =smult x (smult lc r - monom (coeff r dr) n * d) "
     by (auto simp:smult_diff_right smult_monom smult_monom_mult mult.commute[of lc x])
   let ?q' = "smult lc q' + monom (coeff r dr) n"
   show ?case unfolding pseudo_divmod_main.simps Let_def Suc(1)[of lc _ _ _ _ _ ?q'] sm by auto
 qed auto
 
 lemma snd_pseudo_mod_smult_left[simp]:
   shows "snd (pseudo_divmod (smult (x::'a::idom) p) q) = (smult x (snd (pseudo_divmod p q)))"
   unfolding pseudo_divmod_def
     by (auto simp:snd_pseudo_mod_smult_invar_left[of _ _ _ _ _ _ _ 0] Polynomial.coeffs_smult)
 
 lemma pseudo_mod_smult_right:
   assumes "(x::'a::idom)\<noteq>0" "q\<noteq>0"
   shows "(pseudo_mod p (smult (x::'a::idom) q)) = (smult (x^(Suc (length (coeffs p)) - length (coeffs q))) (pseudo_mod p q))"
   unfolding pseudo_divmod_def pseudo_mod_def
     by (auto simp:snd_pseudo_mod_smult_invar_right[of _ _ _ _ _ _ _ 0]
                   snd_pseudo_mod_smult_invar_left[of _ _ _ _ _ _ _ 0] Polynomial.coeffs_smult assms)
 
 lemma pseudo_mod_zero[simp]:
 "pseudo_mod 0 f = (0::'a :: {idom} poly)"
 "pseudo_mod f 0 = f"
 unfolding pseudo_mod_def snd_pseudo_mod_smult_left[of 0 _ f,simplified]
 unfolding pseudo_divmod_def by auto
 
 (* part on prod_list *)
 
 lemma prod_combine:
   assumes "j \<le> i"
   shows "f i * (\<Prod>l\<leftarrow>[j..<i]. (f l :: 'a::comm_monoid_mult)) = prod_list (map f [j..<Suc i])"
 proof(subst prod_list_map_remove1[of i "[j..<Suc i]" f],goal_cases)
   case 2
   have "remove1 i ([j..<i] @ [i]) = [j..<i]" by (simp add: remove1_append)
   thus ?case by auto
 qed (insert assms, auto)
 
 lemma prod_list_minus_1_exp: "prod_list (map (\<lambda> i. (-1)^(f i)) xs)
   = (-1)^(sum_list (map f xs))"
   by (induct xs, auto simp: power_add)
 
 lemma minus_1_power_even: "(- (1 :: 'b :: comm_ring_1))^ k = (if even k then 1 else (-1))"
   by auto
 
 lemma minus_1_even_eqI: assumes "even k = even l" shows
     "(- (1 :: 'b :: comm_ring_1))^k = (- 1)^l"
     unfolding minus_1_power_even assms by auto
 
 lemma (in comm_monoid_mult) prod_list_multf:
   "(\<Prod>x\<leftarrow>xs. f x * g x) = prod_list (map f xs) * prod_list (map g xs)"
   by (induct xs) (simp_all add: algebra_simps)
 
 lemma inverse_prod_list: "inverse (prod_list xs) = prod_list (map inverse (xs :: 'a :: field list))"
   by (induct xs, auto)
 
 (* part on pow_int, i.e., exponentiation with integer exponent *)
 definition pow_int :: "'a :: field \<Rightarrow> int \<Rightarrow> 'a" where
   "pow_int x e = (if e < 0 then 1 / (x ^ (nat (-e))) else x ^ (nat e))"
 
 lemma pow_int_0[simp]: "pow_int x 0 = 1" unfolding pow_int_def by auto
 
 lemma pow_int_1[simp]: "pow_int x 1 = x" unfolding pow_int_def by auto
 
 lemma exp_pow_int: "x ^ n = pow_int x n"
   unfolding pow_int_def by auto
 
 lemma pow_int_add: assumes x: "x \<noteq> 0" shows "pow_int x (a + b) = pow_int x a * pow_int x b"
 proof -
   have *:
     "\<not> a + b < 0 \<Longrightarrow> a < 0 \<Longrightarrow> nat b = nat (a + b) + nat (-a)"
     "\<not> a + b < 0 \<Longrightarrow> b < 0 \<Longrightarrow> nat a = nat (a + b) + nat (-b)"
     "a + b < 0 \<Longrightarrow> \<not> a < 0 \<Longrightarrow> nat (-b) = nat a + nat (-a -b) "
     "a + b < 0 \<Longrightarrow> \<not> b < 0 \<Longrightarrow> nat (-a) = nat b + nat (-a -b) "
   by auto
   have pow_eq: "l = m \<Longrightarrow> (x ^ l = x ^ m)" for l m by auto
   from x show ?thesis unfolding pow_int_def
     by (auto split: if_splits simp: power_add[symmetric] simp: * intro!: pow_eq, auto simp: power_add)
 qed
 
 lemma pow_int_mult: "pow_int (x * y) a = pow_int x a * pow_int y a"
   unfolding pow_int_def by (cases "a < 0", auto simp: power_mult_distrib)
 
 lemma pow_int_base_1[simp]: "pow_int 1 a = 1"
   unfolding pow_int_def by (cases "a < 0", auto)
 
 lemma pow_int_divide: "a / pow_int x b = a * pow_int x (-b)"
   unfolding pow_int_def by (cases b rule: linorder_cases[of _ 0], auto)
 
 lemma divide_prod_assoc: "x / (y * z :: 'a :: field) = x / y / z" by (simp add: field_simps)
 
 lemma minus_1_inverse_pow[simp]: "x / (-1)^n = (x :: 'a :: field) * (-1)^n"
   by (simp add: minus_1_power_even)
 
 (* part on subresultants *)
 definition subresultant_mat :: "nat \<Rightarrow> 'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly mat" where
   "subresultant_mat J F G = (let
      dg = degree G; df = degree F; f = coeff_int F; g = coeff_int G; n = (df - J) + (dg - J)
      in mat n n (\<lambda> (i,j). if j < dg - J then
        if i = n - 1 then monom 1 (dg - J - 1 - j) * F else [: f (df - int i + int j) :]
       else let jj = j - (dg - J) in
        if i = n - 1 then monom 1 (df - J - 1 - jj) * G else [: g (dg - int i + int jj) :]))"
 
 lemma subresultant_mat_dim[simp]:
   fixes j p q
   defines "S \<equiv> subresultant_mat j p q"
   shows "dim_row S = (degree p - j) + (degree q - j)" and "dim_col S = (degree p - j) + (degree q - j)"
   unfolding S_def subresultant_mat_def Let_def by auto
 
 definition subresultant'_mat :: "nat \<Rightarrow> nat \<Rightarrow> 'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a mat" where
   "subresultant'_mat J l F G = (let
      \<gamma> = degree G; \<phi> = degree F; f = coeff_int F; g = coeff_int G; n = (\<phi> - J) + (\<gamma> - J)
      in mat n n (\<lambda> (i,j). if j < \<gamma> - J then
        if i = n - 1 then (f (l - int (\<gamma> - J - 1) + int j)) else (f (\<phi> - int i + int j))
       else let jj = j - (\<gamma> - J) in
        if i = n - 1 then (g (l - int (\<phi> - J - 1) + int jj)) else (g (\<gamma> - int i + int jj))))"
 
 lemma subresultant_index_mat:
   fixes F G
   assumes i: "i < (degree F - J) + (degree G - J)" and j: "j < (degree F - J) + (degree G - J)"
   shows "subresultant_mat J F G $$ (i,j) =
     (if j < degree G - J then
        if i = (degree F - J) + (degree G - J) - 1 then monom 1 (degree G - J - 1 - j) * F else ([: coeff_int F ( degree F - int i + int j) :])
       else let jj = j - (degree G - J) in
        if i = (degree F - J) + (degree G - J) - 1 then monom 1 ( degree F - J - 1 - jj) * G else ([: coeff_int G (degree G - int i + int jj) :]))"
   unfolding subresultant_mat_def Let_def
   unfolding index_mat(1)[OF i j] split by auto
 
 definition subresultant :: "nat \<Rightarrow> 'a :: comm_ring_1 poly \<Rightarrow> 'a poly \<Rightarrow> 'a poly" where
   "subresultant J F G = det (subresultant_mat J F G)"
 
 
 lemma subresultant_smult_left: assumes "(c :: 'a :: {comm_ring_1, semiring_no_zero_divisors}) \<noteq> 0"
   shows "subresultant J (smult c f) g = smult (c ^ (degree g - J)) (subresultant J f g)"
 proof -
   let ?df = "degree f"
   let ?dg = "degree g"
   let ?n = "(?df - J) + (?dg - J)"
   let ?m = "?dg - J"
   let ?M = "mat ?n ?n (\<lambda> (i,j). if i = j then if i < ?m then [:c:] else 1 else 0)"
   from \<open>c \<noteq> 0\<close> have deg: "degree (smult c f) = ?df" by simp
   let ?S = "subresultant_mat J f g"
   let ?cS = "subresultant_mat J (smult c f) g"
   have dim: "dim_row ?S = ?n" "dim_col ?S = ?n"  "dim_row ?cS = ?n" "dim_col ?cS = ?n" using deg by auto
   hence C: "?S \<in> carrier_mat ?n ?n" "?cS \<in> carrier_mat ?n ?n" "?M \<in> carrier_mat ?n ?n" by auto
   have dim': "dim_row (?S * ?M) = ?n" "dim_col (?S * ?M) = ?n" using dim (1,2) by simp_all
   define S where "S = ?S"
   have "?cS = ?S * ?M"
   proof (rule eq_matI, unfold dim' dim)
     fix i j
     assume ij: "i < ?n" "j < ?n"
     have "(?S * ?M) $$ (i,j) = row ?S i \<bullet> col ?M j"
       by (rule index_mult_mat, insert ij dim, auto)
     also have "\<dots> = (\<Sum>k = 0..<?n. row S i $ k * col ?M j $ k)" unfolding scalar_prod_def S_def[symmetric]
       by simp
     also have "\<dots> = (\<Sum>k = 0..<?n. S $$ (i,k) * ?M $$ (k,j))"
       by (rule sum.cong, insert ij, auto simp: S_def)
     also have "\<dots> = S $$ (i,j) * ?M $$ (j,j) + sum (\<lambda> k. S $$ (i,k) * ?M $$ (k,j)) ({0..<?n} - {j})"
       by (rule sum.remove, insert ij, auto)
     also have "\<dots> = S $$ (i,j) * ?M $$ (j,j)"
       by (subst sum.neutral, insert ij, auto)
     also have "\<dots> = ?cS $$ (i,j)" unfolding subresultant_index_mat[OF ij] S_def
       by (subst subresultant_index_mat, unfold deg, insert ij, auto)
     finally show "?cS $$ (i,j) = (?S * ?M) $$ (i,j)" by simp
   qed auto
   from arg_cong[OF this, of det] det_mult[OF C(1) C(3)]
   have "subresultant J (smult c f) g = subresultant J f g * det ?M"
     unfolding subresultant_def by auto
   also have "det ?M = [:c ^ ?m :]"
   proof (subst det_upper_triangular[OF _ C(3)])
     show "upper_triangular ?M"
       by (rule upper_triangularI, auto)
     have "prod_list (diag_mat ?M) = (\<Prod>k = 0..<?n. (?M $$ (k,k)))"
       unfolding prod_list_diag_prod by simp
     also have "\<dots> = (\<Prod>k = 0..<?m. ?M $$ (k,k)) * (\<Prod>k = ?m..<?n. ?M $$ (k,k))"
       by (subst prod.union_disjoint[symmetric], (auto)[3], rule prod.cong, auto)
     also have "(\<Prod>k = 0..<?m. ?M $$ (k,k)) = (\<Prod>k = 0..<?m. [: c :])"
       by (rule prod.cong, auto)
     also have "(\<Prod>k = 0..<?m. [: c :]) = [: c :] ^ ?m" by simp
     also have "(\<Prod>k = ?m..<?n. ?M $$ (k,k)) = (\<Prod>k = ?m..<?n. 1)"
       by (rule prod.cong, auto)
     finally show "prod_list (diag_mat ?M) = [: c^?m :]" unfolding poly_const_pow by simp
   qed
   finally show ?thesis by simp
 qed
 
 lemma subresultant_swap:
   shows "subresultant J f g = smult ((- 1) ^ ((degree f - J) * (degree g - J))) (subresultant J g f)"
 proof -
   let ?A = "subresultant_mat J f g"
   let ?k = "degree f - J"
   let ?n = "degree g - J"
   have nk: "?n + ?k = ?k + ?n" by simp
   have change: "j < ?k + ?n \<Longrightarrow> ((if j < ?k then j + ?n else j - ?k) < ?n)
     = (\<not> (j < ?k))" for j by auto
   have "subresultant J f g = det ?A" unfolding subresultant_def by simp
   also have "\<dots> = (-1)^(?k * ?n) * det (mat (?k + ?n) (?k + ?n) (\<lambda> (i,j).
     ?A $$ (i,(if j < ?k then j + ?n else j - ?k))))" (is "_ = _ * det ?B")
     by (rule det_swap_cols, auto simp: subresultant_mat_def Let_def)
   also have "?B = subresultant_mat J g f"
     unfolding subresultant_mat_def Let_def
     by (rule eq_matI, unfold dim_row_mat dim_col_mat nk index_mat split,
       subst index_mat, (auto)[2], unfold split, subst change, force,
       unfold if_conn, rule if_cong[OF refl if_cong if_cong], auto)
   also have "det \<dots> = subresultant J g f" unfolding subresultant_def ..
   also have "(-1)^(?k * ?n) * \<dots> = [: (-1)^(?k * ?n) :] * \<dots> " by (unfold hom_distribs, simp)
   also have "\<dots> = smult ((-1)^(?k * ?n)) (subresultant J g f)" by simp
   finally show ?thesis .
 qed
 
 lemma subresultant_smult_right:assumes "(c :: 'a :: {comm_ring_1, semiring_no_zero_divisors}) \<noteq> 0"
   shows "subresultant J f (smult c g) = smult (c ^ (degree f - J)) (subresultant J f g)"
   unfolding subresultant_swap[of _ f] subresultant_smult_left[OF assms]
     degree_smult_eq using assms by (simp add: ac_simps)
 
 lemma coeff_subresultant: "coeff (subresultant J F G) l =
   (if degree F - J + (degree G - J) = 0 \<and> l \<noteq> 0 then 0 else det (subresultant'_mat J l F G))"
 proof (cases "degree F - J + (degree G - J) = 0")
   case True
   show ?thesis unfolding subresultant_def subresultant_mat_def subresultant'_mat_def Let_def True
     by simp
 next
   case False
   let ?n = "degree F - J + (degree G - J)"
   define n where "n = ?n"
   from False have n: "n \<noteq> 0" unfolding n_def by auto
   hence id: "{0..<n} = insert (n - 1) {0..< (n - 1)}" by (cases n, auto)
   have idn: "(x = x) = True" for x :: nat by simp
   let ?M = "subresultant_mat J F G"
   define M where "M = ?M"
   let ?L = "subresultant'_mat J l F G"
   define L where "L = ?L"
   {
     fix p
     assume p: "p permutes {0..<n}"
     from n p have n1: "n - 1 < n" "p (n - 1) < n" by auto
     have "coeff_int (\<Prod>i = 0..<n. M $$ (i, p i)) l =
       (\<Prod>i = 0 ..< (n - 1). coeff_int (M $$ (i, p i)) 0) * coeff_int (M $$ (n - 1, p (n - 1))) l"
       unfolding id
     proof (rule coeff_int_prod_const, (auto)[2])
       fix i
       assume "i \<in> {0 ..< n - 1}"
       with p have i: "i \<noteq> n - 1" and "i < n" "p i < n" by (auto simp: n_def)
       note id = subresultant_index_mat[OF this(2-3)[unfolded n_def], folded M_def n_def]
       show "degree (M $$ (i, p i)) = 0" unfolding id Let_def using i
         by (simp split: if_splits)
     qed
     also have "(\<Prod>i = 0 ..< (n - 1). coeff_int (M $$ (i, p i)) 0)
        = (\<Prod>i = 0 ..< (n - 1). L $$ (i, p i))"
     proof (rule prod.cong[OF refl])
       fix i
       assume "i \<in> {0 ..< n - 1}"
       with p have i: "i \<noteq> n - 1" and ii: "i < n" "p i < n" by (auto simp: n_def)
       note id = subresultant_index_mat[OF this(2-3)[unfolded n_def], folded M_def n_def]
       note id' = L_def[unfolded subresultant'_mat_def Let_def, folded n_def] index_mat[OF ii]
       show "coeff_int (M $$ (i, p i)) 0 = L $$ (i, p i)"
         unfolding id id' split using i proof (simp add: if_splits Let_def)
       qed
     qed
     also have "coeff_int (M $$ (n - 1, p (n - 1))) l =
       (if p (n - 1) < degree G - J then
          coeff_int (monom 1 (degree G - J - 1 - p (n - 1)) * F) l
          else coeff_int (monom 1 (degree F - J - 1 - (p (n - 1) - (degree G - J))) * G) l)"
       using subresultant_index_mat[OF n1[unfolded n_def], folded M_def n_def, unfolded idn if_True Let_def]
       by simp
     also have "\<dots> = (if p (n - 1) < degree G - J
       then coeff_int F (int l - int (degree G - J - 1 - p (n - 1)))
       else coeff_int G (int l - int (degree F - J - 1 - (p (n - 1) - (degree G - J)))))"
         unfolding coeff_int_monom_mult by simp
     also have "\<dots> = (if p (n - 1) < degree G - J
       then coeff_int F (int l - int (degree G - J - 1) + p (n - 1))
       else coeff_int G (int l - int (degree F - J - 1) + (p (n - 1) - (degree G - J))))"
     proof (cases "p (n - 1) < degree G - J")
       case True
       hence "int (degree G - J - 1 - p (n - 1)) = int (degree G - J - 1) - p (n - 1)" by simp
       hence id: "int l - int (degree G - J - 1 - p (n - 1)) = int l - int (degree G - J - 1) + p (n - 1)" by simp
       show ?thesis using True unfolding id by simp
     next
       case False
       from n1 False have "degree F - J - 1 \<ge> p (n - 1) - (degree G - J)"
         unfolding n_def by linarith
       hence "int (degree F - J - 1 - (p (n - 1) - (degree G - J))) = int (degree F - J - 1) - (p (n - 1) - (degree G - J))"
         by linarith
       hence id: "int l - int (degree F - J - 1 - (p (n - 1) - (degree G - J))) =
        int l - int (degree F - J - 1) + (p (n - 1) - (degree G - J))" by simp
       show ?thesis unfolding id using False by simp
     qed
     also have "\<dots> = L $$ (n - 1, p (n - 1))"
       unfolding L_def subresultant'_mat_def Let_def n_def[symmetric] using n1 by simp
     also have "(\<Prod>i = 0..<n - 1. L $$ (i, p i)) * \<dots> = (\<Prod>i = 0..<n. L $$ (i, p i))"
       unfolding id by simp
     finally have "coeff_int (\<Prod>i = 0..<n. M $$ (i, p i)) (int l) = (\<Prod>i = 0..<n. L $$ (i, p i))" .
   } note * = this
   have "coeff_int (subresultant J F G) l =
     (\<Sum>p\<in>{p. p permutes {0..<n}}. signof p * coeff_int (\<Prod>i = 0..<n. M $$ (i, p i)) l)"
     unfolding subresultant_def det_def subresultant_mat_dim idn if_True n_def[symmetric] M_def
       coeff_int_sum coeff_int_signof_mult by simp
   also have "\<dots> = (\<Sum>p\<in>{p. p permutes {0..<n}}. signof p * (\<Prod>i = 0..<n. L $$ (i, p i)))"
     by (rule sum.cong[OF refl], insert *, simp)
   also have "\<dots> = det L"
   proof -
     have id: "dim_row (subresultant'_mat J l F G) = n"
       "dim_col (subresultant'_mat J l F G) = n" unfolding subresultant'_mat_def Let_def n_def
       by auto
     show ?thesis unfolding det_def L_def id by simp
   qed
   finally show ?thesis unfolding L_def coeff_int_def using False by auto
 qed
 
 lemma subresultant'_zero_ge: assumes "(degree f - J) + (degree g - J) \<noteq> 0" and "k \<ge> degree f + (degree g - J)"
   shows "det (subresultant'_mat J k f g) = 0" (* last row is zero *)
 proof -
   obtain dg where dg: "degree g - J = dg" by simp
   obtain df where df: "degree f - J = df" by simp
   obtain ddf where ddf: "degree f = ddf" by simp
   note * = assms(2)[unfolded ddf dg] assms(1)
   define M where "M = (\<lambda> i j. if j < dg
             then coeff_int f (degree f - int i + int j)
             else coeff_int g (degree g - int i + int (j - dg)))"
   let ?M = "subresultant'_mat J k f g"
   have M: "det ?M = det (mat (df + dg) (df + dg)
     (\<lambda>(i, j).
         if i = df + dg - 1 then
           if j < dg
             then coeff_int f (int k - int (dg - 1) + int j)
             else coeff_int g (int k - int (df - 1) + int (j - dg))
         else M i j))" (is "_ = det ?N")
     unfolding subresultant'_mat_def Let_def M_def
     by (rule arg_cong[of _ _ det], rule eq_matI, auto simp: df dg)
   also have "?N = mat (df + dg) (df + dg)
     (\<lambda>(i, j).
         if i = df + dg - 1 then 0
         else M i j)"
     by (rule cong_mat[OF refl refl], unfold split, rule if_cong[OF refl _ refl],
       auto simp add: coeff_int_def df dg ddf intro!: coeff_eq_0, insert *(1),
       unfold ddf[symmetric] dg[symmetric] df[symmetric], linarith+)
   also have "\<dots> = mat\<^sub>r (df + dg) (df + dg) (\<lambda>i. if i = df + dg - 1 then 0\<^sub>v (df + dg) else
     vec (df + dg) (\<lambda> j. M i j))"
     by (rule eq_matI, auto)
   also have "det \<dots> = 0"
     by (rule det_row_0, insert *, auto simp: df[symmetric] dg[symmetric] ddf[symmetric])
   finally show ?thesis .
 qed
 
 lemma subresultant'_zero_lt: assumes
   J: "J \<le> degree f" "J \<le> degree g" "J < k"
   and k: "k < degree f + (degree g - J)"
   shows "det (subresultant'_mat J k f g) = 0" (* last row is identical to last row - k *)
 proof -
   obtain dg where dg: "dg = degree g - J" by simp
   obtain df where df: "df = degree f - J" by simp
   note * = assms[folded df dg]
   define M where "M = (\<lambda> i j. if j < dg
             then coeff_int f (degree f - int i + int j)
             else coeff_int g (degree g - int i + int (j - dg)))"
   define N where "N = (\<lambda> j. if j < dg
             then coeff_int f (int k - int (dg - 1) + int j)
             else coeff_int g (int k - int (df - 1) + int (j - dg)))"
   let ?M = "subresultant'_mat J k f g"
   have M: "?M = mat (df + dg) (df + dg)
     (\<lambda>(i, j).
         if i = df + dg - 1 then N j
         else M i j)"
     unfolding subresultant'_mat_def Let_def
     by (rule eq_matI, auto simp: df dg M_def N_def)
   also have "\<dots> = mat (df + dg) (df + dg)
     (\<lambda>(i, j).
         if i = df + dg - 1 then N j
         else if i = degree f + dg - 1 - k then N j else M i j)" (is "_ = ?N")
     unfolding N_def
     by (rule cong_mat[OF refl refl], unfold split, rule if_cong[OF refl refl], unfold M_def N_def,
       insert J k, auto simp: df dg intro!: arg_cong[of _ _ "coeff_int _"])
   finally have id: "?M = ?N" .
   have deg: "degree f + dg - 1 - k < df + dg" "df + dg - 1 < df + dg"
     using k J unfolding df dg by auto
   have id: "row ?M (degree f + dg - 1 - k) = row ?M (df + dg - 1)"
     unfolding arg_cong[OF id, of row]
     by (rule eq_vecI, insert deg, auto)
   show ?thesis
     by (rule det_identical_rows[OF _ _ _ _ id, of "df + dg"], insert deg assms,
       auto simp: subresultant'_mat_def Let_def df dg)
 qed
 
 lemma subresultant'_mat_sylvester_mat: "transpose_mat (subresultant'_mat 0 0 f g) = sylvester_mat f g"
 proof -
   obtain dg where dg: "degree g = dg" by simp
   obtain df where df: "degree f = df" by simp
   let ?M = "transpose_mat (subresultant'_mat 0 0 f g)"
   let ?n = "degree f + degree g"
   have dim: "dim_row ?M = ?n" "dim_col ?M = ?n" by (auto simp: subresultant'_mat_def Let_def)
   show ?thesis
   proof (rule eq_matI, unfold sylvester_mat_dim dim df dg, goal_cases)
     case ij: (1 i j)
     have "?M $$ (i,j) = (if i < dg
          then if j = df + dg - 1
               then coeff_int f (- int (dg - 1) + int i)
               else coeff_int f (int df - int j + int i)
          else if j = df + dg - 1
               then coeff_int g (- int (df - 1) + int (i - dg))
               else coeff_int g (int dg - int j + int (i - dg)))"
       using ij unfolding subresultant'_mat_def Let_def by (simp add: if_splits df dg)
     also have "\<dots> = (if i < dg
          then coeff_int f (int df - int j + int i)
          else coeff_int g (int dg - int j + int (i - dg)))"
     proof -
       have cong: "(b \<Longrightarrow> x = z) \<Longrightarrow> (\<not> b \<Longrightarrow> y = z) \<Longrightarrow> (if b then coeff_int f x else coeff_int f y) = coeff_int f z"
         for b x y z and f :: "'a poly" by auto
       show ?thesis
         by (rule if_cong[OF refl cong cong], insert ij, auto)
     qed
     also have "\<dots> = sylvester_mat f g $$ (i,j)"
     proof -
       have *: "i \<le> j \<Longrightarrow> j - i \<le> df \<Longrightarrow> nat (int df - int j + int i) = df - (j - i)" for j i df
         by simp
       show ?thesis unfolding sylvester_index_mat[OF ij[folded df dg]] df dg
       proof (rule if_cong[OF refl])
         assume i: "i < dg"
         have "int df - int j + int i < 0 \<longrightarrow> \<not> j - i \<le> df" by auto
         thus "coeff_int f (int df - int j + int i) = (if i \<le> j \<and> j - i \<le> df then coeff f (df + i - j) else 0)"
           using i ij by (simp add: coeff_int_def *, intro impI  coeff_eq_0[of f, unfolded df], linarith)
       next
         assume i: "\<not> i < dg"
         hence **: "i - dg \<le> j \<Longrightarrow> dg - (j + dg - i) = i - j" using ij by linarith
         have "int dg - int j + int (i - dg) < 0 \<longrightarrow> \<not> j \<le> i" by auto
         thus "coeff_int g (int dg - int j + int (i - dg)) = (if i - dg \<le> j \<and> j \<le> i then coeff g (i - j) else 0)"
           using ij i by (simp add: coeff_int_def * **, intro impI  coeff_eq_0[of g, unfolded dg], linarith)
       qed
     qed
     finally show ?case .
   qed auto
 qed
 
 lemma coeff_subresultant_0_0_resultant: "coeff (subresultant 0 f g) 0 = resultant f g"
 proof -
   let ?M = "transpose_mat (subresultant'_mat 0 0 f g)"
   have "det (subresultant'_mat 0 0 f g) = det ?M"
     by (subst det_transpose, auto simp: subresultant'_mat_def Let_def)
   also have "?M = sylvester_mat f g"
     by (rule subresultant'_mat_sylvester_mat)
   finally show ?thesis by (simp add: coeff_subresultant resultant_def)
 qed
 
 lemma subresultant_zero_ge: assumes "k \<ge> degree f + (degree g - J)"
   and "(degree f - J) + (degree g - J) \<noteq> 0"
   shows "coeff (subresultant J f g) k = 0"
   unfolding coeff_subresultant
   by (subst subresultant'_zero_ge[OF assms(2,1)], simp)
 
 lemma subresultant_zero_lt: assumes "k < degree f + (degree g - J)"
   and "J \<le> degree f" "J \<le> degree g" "J < k"
   shows "coeff (subresultant J f g) k = 0"
   unfolding coeff_subresultant
   by (subst subresultant'_zero_lt[OF assms(2,3,4,1)], simp)
 
 lemma subresultant_resultant: "subresultant 0 f g = [: resultant f g :]"
 proof (cases "degree f + degree g = 0")
   case True
   thus ?thesis unfolding subresultant_def subresultant_mat_def resultant_def Let_def
       sylvester_mat_def sylvester_mat_sub_def
     by simp
 next
   case 0: False
   show ?thesis
   proof (rule poly_eqI)
     fix k
     show "coeff (subresultant 0 f g) k = coeff [:resultant f g:] k"
     proof (cases "k = 0")
       case True
       thus ?thesis using coeff_subresultant_0_0_resultant[of f g] by auto
     next
       case False
       hence "0 < k \<and> k < degree f + degree g \<or> k \<ge> degree f + degree g" by auto
       thus ?thesis using subresultant_zero_ge[of f g 0 k] 0
         subresultant_zero_lt[of k f g 0] 0 False by (cases k, auto)
     qed
   qed
 qed
 
 lemma (in inj_comm_ring_hom) subresultant_hom:
   "map_poly hom (subresultant J f g) = subresultant J (map_poly hom f) (map_poly hom g)"
 proof -
   note d = subresultant_mat_def Let_def
   interpret p: map_poly_inj_comm_ring_hom hom..
   show ?thesis unfolding subresultant_def unfolding p.hom_det[symmetric]
   proof (rule arg_cong[of _ _ det])
     show "p.mat_hom (subresultant_mat J f g) =
       subresultant_mat J (map_poly hom f) (map_poly hom g)"
     proof (rule eq_matI, goal_cases)
       case (1 i j)
       hence ij: "i < degree f - J + (degree g - J)" "j < degree f - J + (degree g - J)"
         unfolding d degree_map_poly by auto
       show ?case
         by (auto simp add: coeff_int_def d map_mat_def index_mat(1)[OF ij] hom_distribs)
     qed (auto simp: d)
   qed
 qed
 
 text \<open>We now derive properties of the resultant via the connection to subresultants.\<close>
 
 lemma resultant_smult_left: assumes "(c :: 'a :: idom) \<noteq> 0"
   shows "resultant (smult c f) g = c ^ degree g * resultant f g"
   unfolding coeff_subresultant_0_0_resultant[symmetric] subresultant_smult_left[OF assms] coeff_smult
     by simp
 
 lemma resultant_smult_right: assumes "(c :: 'a :: idom) \<noteq> 0"
   shows "resultant f (smult c g) = c ^ degree f * resultant f g"
   unfolding coeff_subresultant_0_0_resultant[symmetric] subresultant_smult_right[OF assms] coeff_smult
   by simp
 
 lemma resultant_swap: "resultant f g = (-1)^(degree f * degree g) * (resultant g f)"
   unfolding coeff_subresultant_0_0_resultant[symmetric]
   unfolding arg_cong[OF subresultant_swap[of 0 f g], of "\<lambda> x. coeff x 0"] coeff_smult by simp
 
 text \<open>The following equations are taken from Brown-Traub ``On Euclid's Algorithm and
 the Theory of Subresultant'' (BT)\<close>
 
 lemma  fixes F B G H :: "'a :: idom poly" and J :: nat
        defines df: "df \<equiv> degree F"
   and dg: "dg \<equiv> degree G"
   and dh: "dh \<equiv> degree H"
   and db: "db \<equiv> degree B"
   defines
     n: "n \<equiv> (df - J) + (dg - J)"
   and f: "f \<equiv> coeff_int F"
   and b: "b \<equiv> coeff_int B"
   and g: "g \<equiv> coeff_int G"
   and h: "h \<equiv> coeff_int H"
   assumes FGH: "F + B * G = H"
   and dfg: "df \<ge> dg"
   and choice: "dg > dh \<or> H = 0 \<and> F \<noteq> 0 \<and> G \<noteq> 0"
 shows BT_eq_18: "subresultant J F G = smult ((-1)^((df - J) * (dg - J))) (det (mat n n
   (\<lambda> (i,j).
               if j < df - J
               then if i = n - 1 then monom 1 ((df - J) - 1 - j) * G
                    else [:g (int dg - int i + int j):]
               else if i = n - 1 then monom 1 ((dg - J) - 1 - (j - (df - J))) * H
                    else [:h (int df - int i + int (j - (df - J))):])))"
    (is "_ = smult ?m1 ?right")
   and BT_eq_19: "dh \<le> J \<Longrightarrow> J < dg \<Longrightarrow> subresultant J F G = smult (
     (-1)^((df - J) * (dg - J)) * lead_coeff G ^ (df - J) * coeff H J ^ (dg - J - 1)) H"
     (is "_ \<Longrightarrow> _ \<Longrightarrow> _ = smult (_ * ?G * ?H) H")
   and BT_lemma_1_12: "J < dh \<Longrightarrow> subresultant J F G = smult (
     (-1)^((df - J) * (dg - J)) * lead_coeff G ^ (df - dh)) (subresultant J G H)"
   and BT_lemma_1_13': "J = dh \<Longrightarrow> dg > dh \<or> H \<noteq> 0 \<Longrightarrow> subresultant dh F G = smult (
     (-1)^((df - dh) * (dg - dh)) * lead_coeff G ^ (df - dh) * lead_coeff H ^ (dg - dh - 1)) H"
   and BT_lemma_1_14: "dh < J \<Longrightarrow> J < dg - 1 \<Longrightarrow> subresultant J F G = 0"
   and BT_lemma_1_15': "J = dg - 1 \<Longrightarrow> dg > dh \<or> H \<noteq> 0 \<Longrightarrow> subresultant (dg - 1) F G = smult (
     (-1)^(df - dg + 1) * lead_coeff G ^ (df - dg + 1)) H"
 proof -
   define dfj where "dfj = df - J"
   define dgj where "dgj = dg - J"
   note d = df dg dh db
   have F0: "F \<noteq> 0" using dfg choice df by auto
   have G0: "G \<noteq> 0" using choice dg by auto
   have dgh: "dg \<ge> dh" using choice unfolding dh by auto
   have B0: "B \<noteq> 0" using FGH dfg dgh choice F0 G0 unfolding d by auto
   have dfh: "df \<ge> dh" using dfg dgh by auto
   have "df = degree (B * G)"
   proof (cases "H = 0")
     case False
     with choice dfg have dfh: "df > dh" by auto
     show ?thesis using dfh[folded arg_cong[OF FGH, of degree, folded dh]] choice
       unfolding df by (metis \<open>degree (F + B * G) < df\<close> degree_add_eq_left degree_add_eq_right df nat_neq_iff)
   next
     case True
     have "F = - B * G" using arg_cong[OF FGH[unfolded True], of "\<lambda> x. x - B * G"] by auto
     thus ?thesis using F0 G0 B0 unfolding df by simp
   qed
   hence dfbg: "df = db + dg" using degree_mult_eq[OF B0 G0] by (simp add: d)
   hence dbfg: "db = df - dg" by simp
   let ?dfj = "df - J"
   let ?dgj = "dg - J"
   have norm: "?dgj + ?dfj = ?dfj + ?dgj" by simp
   let ?bij = "\<lambda> i j. b (db - int i + int (j - dfj))"
   let ?M = "mat n n (\<lambda> (i,j). if i = j then 1 else if j < dfj then 0 else if i < j
     then [:  ?bij i j :] else 0)" (* this is the matrix which contains all the column-operations
      that are required to transform the subresultant-matrix of F and G into the one of G and H (
      the matrix depicted in equation (18) in BT *)
   let ?GF = "\<lambda> i j.
               if j < dfj
               then if i = n - 1 then monom 1 (dfj - 1 - j) * G
                    else [:g (int dg - int i + int j):]
               else if i = n - 1 then monom 1 (dgj - 1 - (j - dfj)) * F
                    else [:f (int df - int i + int (j - dfj)):]"
   let ?G_F = "mat n n (\<lambda> (i,j). ?GF i j)"
   let ?GH = "\<lambda> i j.
               if j < dfj
               then if i = n - 1 then monom 1 (dfj - 1 - j) * G
                    else [:g (int dg - int i + int j):]
               else if i = n - 1 then monom 1 (dgj - 1 - (j - dfj)) * H
                    else [:h (int df - int i + int (j - dfj)):]"
   let ?G_H = "mat n n (\<lambda> (i,j). ?GH i j)"
   have hfg: "h i = f i + coeff_int (B * G) i" for i
     unfolding FGH[symmetric] f g h unfolding coeff_int_def by simp
   have dM1: "det ?M = 1"
     by (subst det_upper_triangular, (auto)[2], subst prod_list_diag_prod, auto)
   have "subresultant J F G = smult ?m1 (subresultant J G F)"
     unfolding subresultant_swap[of _ F] d by simp
   also have "subresultant J G F = det ?G_F"
     unfolding subresultant_def n norm subresultant_mat_def g f Let_def d[symmetric] dfj_def dgj_def by simp
   also have "\<dots> = det (?G_F * ?M)"
     by (subst det_mult[of _ n], unfold dM1, auto)
   also have "?G_F * ?M = ?G_H"
   proof (rule eq_matI, unfold dim_col_mat dim_row_mat)
     fix i j
     assume i: "i < n" and j: "j < n"
     have "(?G_F * ?M) $$ (i,j) = row (?G_F) i \<bullet> col ?M j"
       using i j by simp
     also have "\<dots> = ?GH i j"
     proof (cases "j < dfj")
       case True
       have id: "col ?M j = unit_vec n j"
         by (rule eq_vecI, insert True i j, auto)
       show ?thesis unfolding id using True i j by simp
     next
       case False
       define d where "d = j - dfj"
       from False have jd: "j = d + dfj" unfolding d_def by auto
       hence idj: "{0 ..< j} = {0 ..< dfj} \<union> {dfj ..< dfj + d}" by auto
       let ?H = "(if i = n - 1 then monom 1 (dgj - Suc d) * H else [:h (int df - int i + int d):])"
       have idr: "?GH i j = ?H" unfolding d_def using jd by auto
       let ?bi = "\<lambda> i. b (db - int i + int d)"
       let ?m = "\<lambda> i. if i = j then 1 else if i < j then [:?bij i j:] else 0"
       let ?P = "\<lambda> k. (?GF i k * ?m k)"
       let ?Q = "\<lambda> k. ?GF i k * [: ?bi k :]"
       let ?G = "\<lambda> k. if i = n - 1 then monom 1 (dfj - 1 - k) * G else [:g (int dg - int i + int k):]"
       let ?Gb = "\<lambda> k. ?G k * [:?bi k:]"
       let ?off = "- (int db - int dfj + 1 + int d)"
       have off0: "?off \<ge> 0" using False dfg j unfolding dfj_def d_def dbfg n by simp
       from nat_0_le[OF this]
       obtain off where off: "int off = ?off" by blast
       have "int off \<le> int dfj" unfolding off by auto
       hence "off \<le> dfj" by simp
       hence split1: "{0 ..< dfj} = {0 ..< off} \<union> {off ..< dfj}" by auto
       have "int off + Suc db \<le> dfj" unfolding off by auto
       hence split2: "{off ..< dfj} = {off .. off + db} \<union> {off + Suc db ..< dfj} " by auto
       let ?g_b = "\<lambda>k. (if i = n - 1 then monom 1 k * G else [:g (int dg - int i + int (dfj - Suc k)):]) *
             [:b (k - int off):]"
       let ?gb = "\<lambda>k. (if i = n - 1 then monom 1 (k + off) * G else [:g (int dg - int i + int (dfj - Suc k - off)):]) *
             [:coeff B k:]"
       let ?F = "\<lambda> k. if i = n - 1 then monom 1 (dgj - 1 - (k - dfj)) * F
                    else [:f (int df - int i + int (k - dfj)):]"
       let ?Fb = "\<lambda> k. ?F k * [:?bi k:]"
       let ?Pj = "if i = n - 1 then  monom 1 (dgj - Suc d) * F else [:f (int df - int i + int d):]"
       from False have id: "col ?M j = vec n ?m"
         using j i by (intro eq_vecI, auto)
       have "row ?G_F i \<bullet> col ?M j = sum ?P {0 ..< n}"
         using i j unfolding id by (simp add: scalar_prod_def)
       also have "{0 ..< n} = {0 ..< j} \<union> {j} \<union> {Suc j ..< n}" using j by auto
       also have "sum ?P \<dots> = sum ?P {0 ..< j} + ?P j + sum ?P {Suc j ..< n}"
         by (simp add: sum.union_disjoint)
       also have "sum ?P {Suc j ..< n} = 0" by (rule sum.neutral, auto)
       also have "?P j = ?Pj"
         unfolding d_def using jd by simp
       also have "sum ?P {0 ..< j} = sum ?Q {0 ..< j}"
         by (rule sum.cong[OF refl], unfold d_def, insert jd, auto)
       also have "sum ?Q {0 ..< j} = sum ?Q {0 ..< dfj} + sum ?Q {dfj ..< dfj+d}" unfolding idj
         by (simp add: sum.union_disjoint)
       also have "sum ?Q {0 ..< dfj} = sum ?Gb {0 ..< dfj}"
         by (rule sum.cong, auto)
       also have "sum ?Q {dfj ..< dfj+d} = sum ?Fb {dfj ..< dfj+d}"
         by (rule sum.cong, auto)
       also have "\<dots> = 0"
       proof (rule sum.neutral, intro ballI)
         fix k
         assume k: "k \<in> {dfj ..< dfj+d}"
         hence k: "db + d < k" using k j False unfolding n db[symmetric] dfbg dfj_def d_def by auto
         let ?k = "(int db - int k + int d)"
         have "?k < 0" using k by auto
         hence "b ?k = 0" unfolding b by (intro coeff_int_eq_0, auto)
         thus "?Fb k = 0" by simp
       qed
       also have "sum ?Gb {0 ..< dfj} = sum ?g_b {0 ..< dfj}"
       proof (rule sum.reindex_cong[of "\<lambda> k. dfj - Suc k"], (auto simp: inj_on_def off)[2], goal_cases)
         case (1 k)
         hence "k = dfj - (Suc (dfj - Suc k))" and "(dfj - Suc k) \<in> {0..<dfj}"  by auto
         thus ?case by blast
       next
         case (2 k)
         hence [simp]: "dfj - Suc (dfj - Suc k) = k"
           "int db - int (dfj - Suc k) + int d = int k - off" by (auto simp: off)
         show ?case by auto
       qed
       also have "\<dots>  = sum ?g_b {0 ..< off} + sum ?g_b {off ..< dfj}" unfolding split1
         by (simp add: sum.union_disjoint)
       also have "sum ?g_b {0 ..< off} = 0"
         by (rule sum.neutral, intro ballI, auto simp: b coeff_int_def)
       also have "sum ?g_b {off ..< dfj} = sum ?g_b {off .. off + db} + sum ?g_b {off + Suc db ..< dfj}"
         unfolding split2 by (rule sum.union_disjoint, auto)
       also have "sum ?g_b {off + Suc db ..< dfj} = 0"
       proof (rule sum.neutral, intro ballI, goal_cases)
         case (1 k)
         hence "b (int k - int off) = 0" unfolding b db
           by (intro coeff_int_eq_0, auto)
         thus ?case by simp
       qed
       also have "sum ?g_b {off .. off + db} = sum ?gb {0 .. db}"
         using sum.atLeastAtMost_shift_bounds [of ?g_b 0 off db]
         by (auto intro: sum.cong simp add: b ac_simps)
       finally have id: "row ?G_F i \<bullet> col ?M j - ?H = ?Pj + sum ?gb {0 .. db} - ?H"
         (is "_ = ?E")
         by (simp add: ac_simps)
       define E where "E = ?E"
       let ?b = "coeff B"
       have Bsum: "(\<Sum>k = 0..db. monom (?b k) k) = B" unfolding db
         using atMost_atLeast0 poly_as_sum_of_monoms by auto
       have "E = 0"
       proof (cases "i = n - 1")
         case i_n: False
         hence id: "(i = n - 1) = False" by simp
         with i have i: "i < n - 1" by auto
         let ?ii = "int df - int i + int d"
         have "?thesis = ([:f ?ii:] +
          (\<Sum>k = 0..db.
           [:g (int dg - int i + int (dfj - Suc k - off)):] * [:?b k:]) -
           [:h ?ii:] = 0)" (is "_ = (?e = 0)") unfolding E_def id if_False by simp
         also have "?e = [: f ?ii +
          (\<Sum>k = 0..db.
           g (int dg - int i + int (dfj - Suc k - off)) * ?b k) -
           h ?ii:]" (is "_ = [: ?e :]")
         proof (rule poly_eqI, goal_cases)
           case (1 n)
           show ?case unfolding coeff_diff coeff_add coeff_sum coeff_const
             by (cases n, auto simp: ac_simps)
         qed
         also have "[: ?e :] = 0 \<longleftrightarrow> ?e = 0" by simp
         also have "?e = (\<Sum>k = 0..db. g (int dg - int i + int (dfj - Suc k - off)) * ?b k)
           - coeff_int (B * G) ?ii"
           unfolding hfg by simp
         also have "(B * G) = (\<Sum>k = 0..db. monom (?b k) k) * G" unfolding Bsum by simp
         also have "\<dots> = (\<Sum>k = 0..db. monom (?b k) k * G)" by (rule sum_distrib_right)
         also have "coeff_int \<dots> ?ii = (\<Sum>k = 0..db. g (?ii - k) * ?b k)"
           unfolding coeff_int_sum coeff_int_monom_mult g by (simp add: ac_simps)
         also have "\<dots> = (\<Sum>k = 0..db. g (int dg - int i + int (dfj - Suc k - off)) * ?b k)"
         proof (rule sum.cong[OF refl], goal_cases)
           case (1 k)
           hence "k \<le> db" by simp
           hence id: "int dg - int i + int (dfj - Suc k - off) = ?ii - k"
             using False i j off dfg
             unfolding dbfg d_def dfj_def n by linarith
           show ?case unfolding id ..
         qed
         finally show ?thesis by simp
       next
         case True
         let ?jj = "dgj - Suc d"
         have zero: "int off - (dgj - Suc d) = 0" using dfg False j unfolding off dbfg dfj_def d_def dgj_def n
           by linarith
         from True have "E = monom 1 ?jj * F + (\<Sum>k = 0.. db.
           monom 1 (k + off) * G * [: ?b k :]) - monom 1 ?jj * H"
           (is "_ = ?A + ?sum - ?mon") unfolding id E_def by simp
         also have "?mon = monom 1 ?jj * F + monom 1 ?jj * (B * G)"
           unfolding FGH[symmetric] by (simp add: ring_distribs)
         also have "?A + ?sum - \<dots> = ?sum - (monom 1 ?jj * G) * B" (is "_ = _ - ?GB * B") by simp
         also have "?sum = (\<Sum>k = 0..db.
           (monom 1 ?jj * G) * (monom 1 (k + off - ?jj) * [: ?b k :]))"
         proof (rule sum.cong[OF refl], goal_cases)
           case (1 k)
           let ?one = "1 :: 'a"
           have "int off \<ge> int ?jj" using j False i True
             unfolding off d_def dfj_def dgj_def dfbg n by linarith
           hence "k + off = ?jj + (k + off - ?jj)" by linarith
           hence id: "monom ?one (k + off) = monom (1 * 1) (?jj + (k + off - ?jj))" by simp
           show ?case unfolding id[folded mult_monom] by (simp add: ac_simps)
         qed
         also have "\<dots> = (monom 1 ?jj * G) * (\<Sum>k = 0..db.  monom 1 (k + off - ?jj) * [:?b k:])"
           (is "_ = _ * ?sum")
           unfolding sum_distrib_left ..
         also have "\<dots> - (monom 1 ?jj * G) * B = (monom 1 ?jj * G) * (?sum - B)" by (simp add: ring_distribs)
         also have "?sum = (\<Sum>k = 0..db.  monom 1 k * [:?b k:])"
           by (rule sum.cong[OF refl], insert zero, auto)
         also have "\<dots> = (\<Sum>k = 0..db.  monom (?b k) k)"
           by (rule sum.cong[OF refl], rule poly_eqI, auto)
         also have "\<dots> = B" unfolding Bsum ..
         finally show ?thesis by simp
       qed
       from id[folded E_def, unfolded this]
       show ?thesis using False unfolding d_def by simp
     qed
     also have "\<dots> = ?G_H $$ (i,j)" using i j by simp
     finally show "(?G_F * ?M) $$ (i,j) = ?G_H $$ (i,j)" .
   qed auto
   finally show eq_18: "subresultant J F G = smult ?m1 (det ?G_H)" unfolding dfj_def dgj_def .
   {
     fix i j
     assume ij: "i < j" and j: "j < n"
     with dgh have "int dg - int i + int j > int dg" by auto
     hence "g (int dg - int i + int j) = 0" unfolding g dg by (intro coeff_int_eq_0, auto)
   } note g0 = this
   {
     assume *: "dh \<le> J" "J < dg"
     have n_dfj: "n > dfj" using * unfolding n dfj_def by auto
     note eq_18
     also have "det ?G_H = prod_list (diag_mat ?G_H)"
     proof (rule det_lower_triangular[of n])
       fix i j
       assume ij: "i < j" and j: "j < n"
       from ij j have if_e: "i = n - 1 \<longleftrightarrow> False" by auto
       have "?G_H $$ (i,j) = ?GH i j" using ij j by auto
       also have "\<dots> = 0"
       proof (cases "j < dfj")
         case True
         with True g0[OF ij j] show ?thesis unfolding if_e by simp
       next
         case False
         have "h (int df - int i + int (j - dfj)) = 0" unfolding h
           by (rule coeff_int_eq_0, insert False * ij j dfg, unfold dfj_def dh[symmetric], auto)
         with False show ?thesis unfolding if_e by auto
       qed
       finally show "?G_H $$ (i,j) = 0" .
     qed auto
     also have "\<dots> = (\<Prod>i = 0..<n. ?GH i i)"
       by (subst prod_list_diag_prod, simp)
     also have "{0 ..< n} = {0 ..< dfj} \<union> {dfj ..< n}" unfolding n dfj_def by auto
     also have "prod (\<lambda> i. ?GH i i) \<dots> = prod (\<lambda> i. ?GH i i) {0 ..< dfj} * prod (\<lambda> i. ?GH i i) {dfj ..< n}"
       by (simp add: prod.union_disjoint)
     also have "prod (\<lambda> i. ?GH i i) {0 ..< dfj} = prod (\<lambda> i. [: lead_coeff G :]) {0 ..< dfj}"
     proof -
       show ?thesis
         by (rule prod.cong[OF refl], insert n_dfj, auto simp: g coeff_int_def dg)
     qed
     also have "\<dots> = [: (lead_coeff G)^dfj :]" by (simp add: poly_const_pow)
     also have "{dfj ..< n} = {dfj ..< n-1} \<union> {n - 1}" using n_dfj by auto
     also have "prod (\<lambda> i. ?GH i i) \<dots> = prod (\<lambda> i. ?GH i i) {dfj ..< n-1} * ?GH (n - 1) (n - 1)"
       by (simp add: prod.union_disjoint)
     also have "?GH (n - 1) (n - 1) = H"
     proof -
       have "dgj - 1 - (n - 1 - dfj) = 0" using n_dfj unfolding dgj_def dfj_def n by auto
       with n_dfj show ?thesis by auto
     qed
     also have "prod (\<lambda> i. ?GH i i) {dfj ..< n-1} = prod (\<lambda> i. [:h (int df - dfj):]) {dfj ..< n-1}"
       by (rule prod.cong[OF refl], auto intro!: arg_cong[of _ _ h])
     also have "\<dots> = [: h (int df - dfj) ^ (n - 1 - dfj) :]"
       unfolding prod_constant by (simp add: poly_const_pow)
     also have "n - 1 - dfj = dg - J - 1" unfolding n dfj_def by simp
     also have "int df - dfj = J" using * dfg unfolding dfj_def by auto
     also have "h J = coeff H J" unfolding h coeff_int_def by simp
     finally show "subresultant J F G = smult (?m1 * ?G * ?H) H" by (simp add: dfj_def ac_simps)
   } note eq_19 = this
   {
     assume J: "J < dh"
     define dhj where "dhj = dh - J"
     have n_add: "n = (df - dh) + (dhj + dgj)" unfolding dhj_def dgj_def n using J dfg dgh by auto
     let ?split = "split_block ?G_H (df - dh) (df - dh)"
     have dim: "dim_row ?G_H = (df - dh) + (dhj + dgj)"
       "dim_col ?G_H = (df - dh) + (dhj + dgj)"
       unfolding n_add by auto
     obtain UL UR LL LR where spl: "?split = (UL,UR,LL,LR)" by (cases ?split, auto)
     note spl' = spl[unfolded split_block_def Let_def, simplified]
     let ?LR = "subresultant_mat J G H"
     have "LR = mat (dgj + dhj) (dgj + dhj)
        (\<lambda> (i,j). ?GH (i + (df - dh)) (j + (df - dh)))"
       using spl' by (auto simp: n_add)
     also have "\<dots> = ?LR"
       unfolding subresultant_mat_def Let_def dhj_def dgj_def d[symmetric]
     proof (rule eq_matI, unfold dim_row_mat dim_col_mat index_mat split dfj_def, goal_cases)
       case (1 i j)
       hence id1: "(j + (df - dh) < df - J) = (j < dh - J)" using dgh dfg J by auto
       have id2: "(i + (df - dh) = n - 1) = (i = dg - J + (dh - J) - 1)"
         unfolding n_add dhj_def dgj_def using dgh dfg J by auto
       have id3: "(df - J - 1 - (j + (df - dh))) = (dh - J - 1 - j)"
         and id4: "(int dg - int (i + (df - dh)) + int (j + (df - dh))) = (int dg - int i + int j)"
         and id5: "(dg - J - 1 - (j + (df - dh) - (df - J))) = (dg - J - 1 - (j - (dh - J)))"
         and id6: "(int df - int (i + (df - dh)) + int (j + (df - dh) - (df - J))) = (int dh - int i + int (j - (dh - J)))"
         using dgh dfg J by auto
       show ?case unfolding g[symmetric] h[symmetric] id3 id4 id5 id6
         by (rule if_cong[OF id1 if_cong[OF id2 refl refl] if_cong[OF id2 refl refl]])
     qed auto
     finally have "LR = ?LR" .
     note spl = spl[unfolded this]
     let ?UR = "0\<^sub>m (df - dh) (dgj + dhj)"
     have "UR = mat (df - dh) (dgj + dhj)
        (\<lambda> (i,j). ?GH i (j + (df - dh)))"
       using spl' by (auto simp: n_add)
     also have "\<dots> = ?UR"
     proof (rule eq_matI, unfold dim_row_mat dim_col_mat index_mat split dfj_def index_zero_mat, goal_cases)
       case (1 i j)
       hence in1: "i \<noteq> n - 1" using J unfolding dgj_def dhj_def n_add by auto
       {
         assume "j + (df - dh) < df - J"
         hence "dg < int dg - int i + int (j + (df - dh))" using 1 J unfolding dgj_def dhj_def by auto
         hence "g \<dots> = 0" unfolding dg g by (intro coeff_int_eq_0, auto)
       } note g = this
       {
         assume "\<not> (j + (df - dh) < df - J)"
         hence "dh < int df - int i + int (j + (df - dh) - (df - J))" using 1 J unfolding dgj_def dhj_def by auto
         hence "h \<dots> = 0" unfolding dh h by (intro coeff_int_eq_0, auto)
       } note h = this
       show ?case using in1 g h by auto
     qed auto
     finally have "UR = ?UR" .
     note spl = spl[unfolded this]
     let ?G = "\<lambda> (i,j). if i = j then [:lead_coeff G:] else if i < j then 0 else ?GH i j"
     let ?UL = "mat (df - dh) (df - dh) ?G"
     have "UL = mat (df - dh) (df - dh) (\<lambda> (i,j). ?GH i j)"
       using spl' by (auto simp: n_add)
     also have "\<dots> = ?UL"
     proof (rule eq_matI, unfold dim_row_mat dim_col_mat index_mat split, goal_cases)
       case (1 i j)
       {
         assume "i = j"
         hence "int dg - int i + int j = dg" using 1 by auto
         hence "g (int dg - int i + int j) = lead_coeff G"
           unfolding g dg coeff_int_def by simp
       } note eq = this
       {
         assume "i < j"
         hence "dg < int dg - int i + int j" using 1 by auto
         hence "g (int dg - int i + int j) = 0"
           unfolding g dg by (intro coeff_int_eq_0, auto)
       } note lt = this
       from 1 have *: "j < dfj" "i \<noteq> n - 1" using J unfolding n_add dhj_def dgj_def dfj_def  by auto
       hence "?GH i j = [:g (int dg - int i + int j):]" by simp
       also have "\<dots> = (if i = j then [: lead_coeff G :] else if i < j then 0 else ?GH i j)"
         using eq lt * by auto
       finally show ?case by simp
     qed auto
     finally have "UL = ?UL" .
     note spl = spl[unfolded this]
     from split_block[OF spl dim]
     have GH: "?G_H = four_block_mat ?UL ?UR LL ?LR"
       and C: "?UL \<in> carrier_mat (df - dh) (df - dh)"
       "?UR \<in> carrier_mat (df - dh) (dhj + dgj)"
       "LL \<in> carrier_mat (dhj + dgj) (df - dh)"
       "?LR \<in> carrier_mat (dhj + dgj) (dhj + dgj)" by auto
     from arg_cong[OF GH, of det]
     have "det ?G_H = det (four_block_mat ?UL ?UR LL ?LR)" unfolding GH[symmetric] ..
     also have "\<dots> = det ?UL * det ?LR"
       by (rule det_four_block_mat_upper_right_zero[OF _ refl], insert C, auto simp: ac_simps)
     also have "det ?LR = subresultant J G H" unfolding subresultant_def by simp
     also have "det ?UL = prod_list (diag_mat ?UL)"
       by (rule det_lower_triangular[of "df - dh"], auto)
     also have "\<dots> = (\<Prod>i = 0..< (df - dh). [: lead_coeff G :])" unfolding prod_list_diag_prod by simp
     also have "\<dots> = [: lead_coeff G ^ (df - dh) :]" by (simp add: poly_const_pow)
     finally have det: "det ?G_H = [:lead_coeff G ^ (df - dh):] * subresultant J G H" by auto
     show "subresultant J F G = smult (?m1 * lead_coeff G ^ (df - dh)) (subresultant J G H)"
       unfolding eq_18 det by simp
   }
   {
     assume J: "dh < J" "J < dg - 1"
     hence "dh \<le> J" "J < dg" by auto
     from eq_19[OF this]
     have "subresultant J F G = smult ((- 1) ^ ((df - J) * (dg - J)) * lead_coeff G ^ (df - J) * coeff H J ^ (dg - J - 1)) H"
       by simp
     also have "coeff H J = 0" by (rule coeff_eq_0, insert J, auto simp: dh)
     also have "\<dots> ^ (dg - J - 1) = 0" using J by auto
     finally show "subresultant J F G = 0" by simp
   }
   {
     assume J: "J = dh" and "dg > dh \<or> H \<noteq> 0"
     with choice have dgh: "dg > dh" by auto
     show "subresultant dh F G = smult (
       (-1)^((df - dh) * (dg - dh)) * lead_coeff G ^ (df - dh) * lead_coeff H ^ (dg - dh - 1)) H"
       unfolding eq_19[unfolded J, OF le_refl dgh] unfolding dh by simp
   }
   {
     assume J: "J = dg - 1" and "dg > dh \<or> H \<noteq> 0"
     with choice have dgh: "dg > dh" by auto
     have *: "dh \<le> dg - 1" "dg - 1 < dg" using dgh by auto
     have **: "df - (dg - 1) = df - dg + 1" "dg - (dg - 1) - 1 = 0" "dg - (dg - 1) = 1"
       using dfg dgh by linarith+
     show "subresultant (dg - 1) F G = smult (
       (-1)^(df - dg + 1) * lead_coeff G ^ (df - dg + 1)) H"
       unfolding eq_19[unfolded J, OF *] unfolding ** by simp
   }
 qed
 
 lemmas BT_lemma_1_13 = BT_lemma_1_13'[OF _ _ _ refl]
 lemmas BT_lemma_1_15 = BT_lemma_1_15'[OF _ _ _ refl]
 
 lemma subresultant_product: fixes F :: "'a :: idom poly"
   assumes "F = B * G"
   and FG: "degree F \<ge> degree G"
 shows "subresultant J F G = (if J < degree G then 0 else
    if J < degree F then smult (lead_coeff G ^ (degree F - J - 1)) G else 1)"
 proof (cases "J < degree G")
   case J: True
   from assms have eq: "F + (-B) * G = 0" by auto
   from J have lt: "degree 0 < degree G \<or> b" for b by auto
   from BT_lemma_1_13[OF eq FG lt lt]
   have "subresultant 0 F G = 0" using J by auto
   with BT_lemma_1_14[OF eq FG lt, of J] have 00: "J = 0 \<or> J < degree G - 1 \<Longrightarrow> subresultant J F G = 0" by auto
   from BT_lemma_1_15[OF eq FG lt lt] J have 01: "subresultant (degree G - 1) F G = 0" by simp
   from J have "(J = 0 \<or> J < degree G - 1) \<or> J = degree G - 1" by linarith
   with 00 01 have "subresultant J F G = 0" by auto
   thus ?thesis using J by simp
 next
   case J: False
   hence dg: "degree G - J = 0" by simp
   let ?n = "degree F - J"
   have *: "(j :: nat) < 0 \<longleftrightarrow> False" "j - 0 = j" for j by auto
   let ?M = "mat ?n ?n
           (\<lambda>(i, j).
               if i = ?n - 1 then monom 1 (?n - 1 - j) * G
               else [:coeff_int G (int (degree G) - int i + int j):])"
   have "subresultant J F G = det ?M"
     unfolding subresultant_def subresultant_mat_def Let_def dg * by auto
   also have "det ?M = prod_list (diag_mat ?M)"
     by (rule det_lower_triangular[of ?n], auto intro: coeff_int_eq_0)
   also have "\<dots> = (\<Prod>i = 0..< ?n. ?M $$ (i,i))" unfolding prod_list_diag_prod by simp
   also have "\<dots> = (\<Prod>i = 0..< ?n. if i = ?n - 1 then G else [: lead_coeff G :])"
     by (rule prod.cong[OF refl], auto simp: coeff_int_def)
   also have "\<dots> = (if J < degree F then smult (lead_coeff G ^ (?n - 1)) G else 1)"
   proof (cases "J < degree F")
     case True
     hence id: "{ 0 ..< ?n} = { 0 ..< ?n - 1} \<union> {?n - 1}" by auto
     have "(\<Prod>i = 0..< ?n. if i = ?n - 1 then G else [: lead_coeff G :])
       = (\<Prod>i = 0 ..< ?n - 1. if i = ?n - 1 then G else [: lead_coeff G :]) * G" (is "_ = ?P * G")
       unfolding id
       by (subst prod.union_disjoint, auto)
     also have "?P = (\<Prod>i = 0 ..< ?n - 1. [: lead_coeff G :])"
       by (rule prod.cong, auto)
     also have "\<dots> = [: lead_coeff G ^ (?n - 1) :]"
       by (simp add: poly_const_pow)
     finally show ?thesis by auto
   qed auto
   finally have "subresultant J F G =
       (if J < degree F then smult (lead_coeff G ^ (degree F - J - 1)) G else 1)" .
   thus ?thesis using J by simp
 qed
 
 lemma resultant_pseudo_mod_0: assumes "pseudo_mod f g = (0 :: 'a :: idom_divide poly)"
   and dfg: "degree f \<ge> degree g"
   and f: "f \<noteq> 0" and g: "g \<noteq> 0"
   shows "resultant f g = (if degree g = 0 then lead_coeff g^degree f else 0)"
 proof -
   let ?df = "degree f" let ?dg = "degree g"
   obtain d r where pd: "pseudo_divmod f g = (d,r)" by force
   from pd have r: "r = pseudo_mod f g" unfolding pseudo_mod_def by simp
   with assms pd have pd: "pseudo_divmod f g = (d,0)" by auto
   from pseudo_divmod[OF g pd] g
   obtain a q where prod: "smult a f = g * q" and a: "a \<noteq> 0" "a = lead_coeff g ^ (Suc ?df - ?dg)"
     by auto
   from a dfg have dfg: "degree g \<le> degree (smult a f)" by auto
   have g0: "degree g = 0 \<Longrightarrow> coeff g 0 = 0 \<Longrightarrow> g = 0"
     using leading_coeff_0_iff by fastforce
   from prod have "smult a f = q * g" by simp
   from arg_cong[OF subresultant_product[OF this dfg, of 0, unfolded subresultant_resultant
     resultant_smult_left[OF a(1)]], of "\<lambda> x. coeff x 0"]
   show ?thesis using a g0 by (cases "degree f", auto)
 qed
 
 locale primitive_remainder_sequence =
   fixes F :: "nat \<Rightarrow> 'a :: idom_divide poly"
     and n :: "nat \<Rightarrow> nat"
     and \<delta> :: "nat \<Rightarrow> nat"
     and f :: "nat \<Rightarrow> 'a"
     and k :: nat
     and \<beta> :: "nat \<Rightarrow> 'a"
   assumes f: "\<And> i. f i = lead_coeff (F i)"
       and n: "\<And> i. n i = degree (F i)"
       and \<delta>: "\<And> i. \<delta> i = n i - n (Suc i)"
       and n12: "n 1 \<ge> n 2"
       and F12: "F 1 \<noteq> 0" "F 2 \<noteq> 0"
       and F0: "\<And> i. i \<noteq> 0 \<Longrightarrow> F i = 0 \<longleftrightarrow> i > k"
       and \<beta>0: "\<And> i. \<beta> i \<noteq> 0"
       and pmod: "\<And> i. i \<ge> 3 \<Longrightarrow> i \<le> Suc k \<Longrightarrow> smult (\<beta> i) (F i) = pseudo_mod (F (i - 2)) (F (i - 1))"
 begin
 
 lemma f10: "f 1 \<noteq> 0" and f20: "f 2 \<noteq> 0" unfolding f using F12 by auto
 
 lemma f0: "i \<noteq> 0 \<Longrightarrow> f i = 0 \<longleftrightarrow> i > k"
   using F0[of i] unfolding f by auto
 
 lemma n_gt: assumes "2 \<le> i" "i < k"
   shows "n i > n (Suc i)"
 proof -
   from assms have "3 \<le> Suc i" "Suc i \<le> Suc k" by auto
   note pmod = pmod[OF this]
   from assms F0 have "F (Suc i - 1) \<noteq> 0" "F (Suc i) \<noteq> 0" by auto
   from pseudo_mod(2)[OF this(1), of "F (Suc i - 2)", folded pmod] this(2)
   show ?thesis unfolding n using \<beta>0 by auto
 qed
 
 
 lemma n_ge: assumes "1 \<le> i" "i < k"
   shows "n i \<ge> n (Suc i)"
   using n12 n_gt[OF _ assms(2)] assms(1) by (cases "i = 1", auto simp: numeral_2_eq_2)
 
 lemma n_ge_trans: assumes "1 \<le> i" "i \<le> j" "j \<le> k"
   shows "n i \<ge> n j"
 proof -
   from assms(2) have "j = i + (j - i)" by simp
   then obtain jj where j: "j = i + jj" by blast
   from assms(3)[unfolded j] show ?thesis unfolding j
   proof (induct jj)
     case (Suc j)
     from Suc(2) have "i + j \<le> k" by simp
     from Suc(1)[OF this] have IH: "n (i + j) \<le> n i" .
     have "n (Suc (i + j)) \<le> n (i + j)"
       by (rule n_ge, insert assms(1) Suc(2), auto)
     with IH show ?case by auto
   qed auto
 qed
 
 lemma delta_gt: assumes "2 \<le> i" "i < k"
   shows "\<delta> i > 0" using n_gt[OF assms] unfolding \<delta> by auto
 
 lemma k2:"2 \<le> k"
   by (metis le_cases linorder_not_le F0 F12(2) zero_order(2))
 
 lemma k0: "k \<noteq> 0" using k2 by auto
 
 
 lemma ni2:"3 \<le> i \<Longrightarrow> i \<le> k \<Longrightarrow> n i \<noteq> n 2"
   by (metis Suc_numeral \<delta> delta_gt k2 le_imp_less_Suc le_less n_ge_trans not_le one_le_numeral
       semiring_norm(5) zero_less_diff)
 end
 
 
 locale subresultant_prs_locale = primitive_remainder_sequence F n \<delta> f k \<beta> for
        F :: "nat \<Rightarrow> 'a :: idom_divide fract poly"
     and n :: "nat \<Rightarrow> nat"
     and \<delta> :: "nat \<Rightarrow> nat"
     and f :: "nat \<Rightarrow> 'a fract"
     and k :: nat
     and \<beta> :: "nat \<Rightarrow> 'a fract" +
   fixes G1 G2 :: "'a poly"
   assumes F1: "F 1 = map_poly to_fract G1"
     and F2: "F 2 = map_poly to_fract G2"
 begin
 
 definition "\<alpha> i = (f (i - 1))^(Suc (\<delta> (i - 2)))"
 
 lemma \<alpha>0: "i > 1 \<Longrightarrow> \<alpha> i = 0 \<longleftrightarrow> (i - 1) > k"
   unfolding \<alpha>_def using f0[of "i - 1"] by auto
 
 lemma \<alpha>_char:
 assumes "3 \<le> i" "i < k + 2"
   shows "\<alpha> i = (f (i - 1)) ^ (Suc (length (coeffs (F (i - 2)))) - length (coeffs (F (i - 1))))"
 proof (cases "i = 3")
   case True
   have triv:"Suc (Suc 0) = 2" by auto
   have l:"length (coeffs (F 2)) \<noteq> 0" "length (coeffs (F 1)) \<noteq> 0" using F12 by auto
   hence "length (coeffs (F 2)) \<le> length (coeffs (F (Suc 0)))" using n12
     unfolding n degree_eq_length_coeffs One_nat_def by linarith
   hence "Suc (length (coeffs (F 1)) - 1 - (length (coeffs (F 2)) - 1)) =
          (Suc (length (coeffs (F 1))) - length (coeffs (F (3 - 1))))" using l by simp
   thus ?thesis unfolding True \<alpha>_def n \<delta> degree_eq_length_coeffs by (simp add:triv)
 next
   case False
   hence assms:"2 \<le> i - 2" "i - 2 < k" using assms by auto
   have i:"i - 2 \<noteq> 0" "i - 1 \<noteq> 0" using assms by auto
   hence [simp]: "Suc (i - 2) = i - 1" by auto
   from assms(2) F0[OF i(2)] have "F (i - 1) \<noteq> 0" by auto
   then have "length (coeffs (F (i - 1))) > 0" by (cases "F (i - 1)") auto
   with delta_gt[unfolded \<delta> n degree_eq_length_coeffs,OF assms]
   have * : "Suc (\<delta> (i - 2)) = Suc (length (coeffs (F (i - 2)))) - (length (coeffs (F (Suc (i - 2)))))"
     by (auto simp:\<delta> n degree_eq_length_coeffs)
   show ?thesis unfolding \<alpha>_def * by simp
 qed
 
 definition Q :: "nat \<Rightarrow> 'a fract poly" where
   "Q i \<equiv> smult (\<alpha> i) (fst (pdivmod (F (i - 2)) (F (i - 1))))"
 
 lemma beta_F_as_sum:
   assumes "3 \<le> i" "i \<le> Suc k"
   shows "smult (\<beta> i) (F i) = smult (\<alpha> i) (F (i - 2)) + - Q i * F (i - 1)" (is ?t1)
 proof -
   have ik:"i < k + 2" using assms by auto
   have f0:"F (i - 1) = 0 \<longleftrightarrow> False" "F (i - Suc 0) = 0 \<longleftrightarrow> False"
     using F0[of "i - 1"] assms by auto
   hence f0_b:"(inverse (coeff (F (i - 1)) (degree (F (i - 1))))) \<noteq> 0" "F (i - 1) \<noteq> 0" by auto
   have i:"i - 2 \<noteq> 0" "Suc (i - 2) = i - 1" "(k < i - 2) \<longleftrightarrow> False" using assms by auto
   have "F (i - 2) \<noteq> 0" using F0[of "i - 2"] assms by auto
   let ?c = "(inverse (f (i - 1)) ^ (Suc (length (coeffs (F (i - 2)))) - length (coeffs (F (i - 1)))))"
   have inv:"inverse (\<alpha> i) = ?c" unfolding \<alpha>_char[OF assms(1) ik] power_inverse by auto
   have alpha0:"\<alpha> i \<noteq> 0" unfolding \<alpha>_def f using f0 by auto
   have \<alpha>_inv[simp]:"\<alpha> i * inverse (\<alpha> i) = 1"
     using field_class.field_inverse[OF alpha0] mult.commute by metis
   with field_class.field_inverse[OF alpha0,unfolded inv]
   have c_times_Q:"smult ?c (Q i) = fst (pdivmod (F (i - 2)) (F (i - 1)))"
     unfolding Q_def by auto
   have "pdivmod (F (i - 2)) (F (i - 1)) = (smult ?c (Q i), smult ?c (smult (\<beta> i) (F i)))"
     unfolding c_times_Q
     unfolding pdivmod_via_pseudo_divmod pmod[OF assms] f n c_times_Q
               pseudo_mod_smult_right[OF f0_b, of "F (i - 2)",symmetric] f0 if_False Let_def
     unfolding pseudo_mod_def by (auto split:prod.split)
-  from this[folded pdivmod_pdivmodrel]
-  have pr:"F (i - 2) = smult ?c (Q i) * F (i - 1) + smult ?c ( smult (\<beta> i) (F i))"
-    by (auto simp: eucl_rel_poly_iff)
-  hence "F (i - 2) = smult (inverse (\<alpha> i)) (Q i) * F (i - 1)
+  from this [symmetric]
+  have pr: \<open>F (i - 2) = smult ?c (Q i) * F (i - 1) + smult ?c ( smult (\<beta> i) (F i))\<close>
+    by (simp only: prod_eq_iff fst_conv snd_conv div_mult_mod_eq)
+  then have "F (i - 2) = smult (inverse (\<alpha> i)) (Q i) * F (i - 1)
                    + smult (inverse (\<alpha> i)) ( smult (\<beta> i) (F i))" (is "?l = ?r" is "_ = ?t + _")
                    unfolding inv.
   hence eq:"smult (\<alpha> i) (?l - ?t) = smult (\<alpha> i) (?r - ?t)" by auto
   have " smult (\<alpha> i) (F (i - 2)) - Q i * (F (i - 1)) = smult (\<alpha> i) (?l - ?t)"
    unfolding smult_diff_right by auto
   also have "\<dots> = smult (\<alpha> i) (?r - ?t)" unfolding eq..
   also have "\<dots> = smult (\<beta> i) (F i)" by (auto simp:mult.assoc[symmetric])
   finally show ?t1 by auto
 qed
 
 lemma assumes "3 \<le> i" "i \<le> k" shows
   BT_lemma_2_21: "j < n i \<Longrightarrow> smult (\<alpha> i ^ (n (i - 1) - j)) (subresultant j (F (i - 2)) (F (i - 1)))
   = smult ((- 1) ^ ((n (i - 2) - j) * (n (i - 1) - j)) * (f (i - 1)) ^ (\<delta> (i - 2) + \<delta> (i - 1)) * (\<beta> i) ^ (n (i - 1) - j)) (subresultant j (F (i - 1)) (F i))"
     (is "_ \<Longrightarrow> ?eq_21") and
   BT_lemma_2_22: "smult (\<alpha> i ^ (\<delta> (i - 1))) (subresultant (n i) (F (i - 2)) (F (i - 1)))
   = smult ((- 1) ^ ((\<delta> (i - 2) + \<delta> (i - 1)) * \<delta> (i - 1)) * f (i - 1) ^ (\<delta> (i - 2) + \<delta> (i - 1)) * f i ^ (\<delta> (i - 1) - 1) * (\<beta> i) ^ \<delta> (i - 1)) (F i)"
     (is "?eq_22") and
   BT_lemma_2_23: "n i < j \<Longrightarrow> j < n (i - 1) - 1 \<Longrightarrow> subresultant j (F (i - 2)) (F (i - 1)) = 0"
     (is "_ \<Longrightarrow> _ \<Longrightarrow> ?eq_23") and
   BT_lemma_2_24: "smult (\<alpha> i) (subresultant (n (i - 1) - 1) (F (i - 2)) (F (i - 1)))
   = smult ((- 1) ^ (\<delta> (i - 2) + 1) * f (i - 1) ^ (\<delta> (i - 2) + 1) * \<beta> i) (F i)" (is "?eq_24")
 proof -
   from assms have ik:"i \<le> Suc k" by auto
   note beta_F_as_sum = beta_F_as_sum[OF assms(1) ik, symmetric]
   have s[simp]:"Suc (i - 2) = i - 1" "Suc (i - 1) = i" using assms by auto
   have \<alpha>0:"\<alpha> i \<noteq> 0" using assms f0[of "i - 1"] unfolding \<alpha>_def f by auto
   hence \<alpha>0pow:"\<And> x. \<alpha> i ^ x \<noteq> 0" by auto
   have df:"degree (F (i - 1)) \<le> degree (smult (\<alpha> i) (F (i - 2)))"
           "degree (smult (\<beta> i) (F i)) < degree (F (i - 1)) \<or> b" for b
     using n_ge[of "i-2"] n_gt[of "i-1"] assms \<alpha>0 \<beta>0 unfolding n by auto
   have degree_smult_eq:"\<And> c f. (c::_::{idom_divide}) \<noteq> 0 \<Longrightarrow> degree (smult c f) = degree f" by auto
   have n_lt:"n i < n (i - 1)" using n_gt[of "i-1"] assms unfolding n by auto
   from semiring_normalization_rules(30) mult.commute
     have *:"\<And> x y q. (x * (y::'a fract)) ^ q = y ^ q * x ^ q" by metis
   have "n (i - 1) - n i > 0" using n_lt by auto
   hence **:"\<beta> i ^ (n (i - 1) - n i - 1) * \<beta> i = \<beta> i ^ (n (i - 1) - n i)"
     by (subst power_minus_mult) auto
   have "max (n (i - 2)) (n (i - 1)) = n (i - 2)" using n_ge[of "i-2"] assms
     unfolding max_def by auto
   with diff_add_assoc[OF n_ge[of "i-1"],symmetric] assms
   have ns : "n (i - 2) - n (i - 1) + (n (i - 1) - n i) = n (i - 2) - n i"
      by (auto simp:nat_minus_add_max)
   { assume "j < n i"
     hence j:"j < degree (smult (\<beta> i) (F i))" using \<beta>0 unfolding n by auto
     from BT_lemma_1_12[OF beta_F_as_sum df j]
     show ?eq_21
       unfolding subresultant_smult_right[OF \<beta>0] subresultant_smult_left[OF \<alpha>0]
                 degree_smult_eq[OF \<alpha>0] degree_smult_eq[OF \<beta>0] n[symmetric] f[symmetric] \<delta> s ns
       using f n
       by auto}
   { from BT_lemma_1_13[OF beta_F_as_sum df df(2)]
     show ?eq_22
       unfolding subresultant_smult_left[OF \<alpha>0] lead_coeff_smult smult_smult
                 degree_smult_eq[OF \<alpha>0] degree_smult_eq[OF \<beta>0] n[symmetric] f[symmetric] \<delta> s ns
       by (metis (no_types, lifting) * ** coeff_smult f mult.assoc n)}
   { assume "n i < j" "j < n (i - 1) - 1"
     hence j:"degree (smult (\<beta> i) (F i)) < j" "j < degree (F (i - 1)) - 1"
       using \<beta>0 unfolding n by auto
     from BT_lemma_1_14[OF beta_F_as_sum df j]
     show ?eq_23 unfolding subresultant_smult_left[OF \<alpha>0] smult_eq_0_iff using \<alpha>0pow by auto}
   { have ***: "n (i - 1) - (n (i - 1) - 1) = 1" using n_lt by auto
     from BT_lemma_1_15[OF beta_F_as_sum df df(2)]
     show ?eq_24
       unfolding subresultant_smult_left[OF \<alpha>0] *** degree_smult_eq[OF \<alpha>0] n[symmetric] f \<delta>
       by (auto simp:mult.commute)}
 qed
 
 lemma BT_eq_30: "3 \<le> i \<Longrightarrow> i \<le> k + 1 \<Longrightarrow> j < n (i - 1) \<Longrightarrow>
     smult (\<Prod>l\<leftarrow>[3..<i]. \<alpha> l ^ (n (l - 1) - j)) (subresultant j (F 1) (F 2))
   = smult (\<Prod>l\<leftarrow>[3..<i]. \<beta> l ^ (n (l - 1) - j) * f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1))
         * (- 1) ^ ((n (l - 2) - j) * (n (l - 1) - j))) (subresultant j (F (i - 2)) (F (i - 1)))"
 proof (induct "i - 3" arbitrary:i)
   case (Suc x)
   from Suc.hyps(2) Suc.prems(1-2)
     have prems:"x = (i - 1) - 3" "3 \<le> i - 1" "i - 1 \<le> k + 1" "2 \<le> i - 1 - 1" "i - 1 - 1 < k"
                "i - 1 \<le> k" by auto
   from prems(2) have inset:"i - 1 \<in> set [3..<i]" by auto
   have r1:"remove1 (i - 1) [3..<i] = [3..<i-1]" by (induct i,auto simp:remove1_append)
   from Suc.prems(1) have "Suc (i - 1 - 1) = i - 1" by auto
   from n_gt[OF prems(4,5),unfolded this] Suc.prems(3) have j:"j < n (i - 1 - 1)" by auto
   have *:"\<And> c d e x. smult c d = e \<Longrightarrow> smult (x * c) d = smult x e" by auto
   have **:"\<And> c d e x. smult c d = e \<Longrightarrow> smult c (smult x d) = smult x e" by (auto simp:mult.commute)
   show ?case unfolding prod_list_map_remove1[OF inset(1),unfolded r1]
       *[OF Suc.hyps(1)[OF prems(1-3) j]]
       **[OF BT_lemma_2_21[OF prems(2,6) Suc.prems(3)]]
       by (auto simp: numeral_2_eq_2 ac_simps)
 qed auto
 
 lemma nonzero_alphaprod: assumes "i \<le> k + 1" shows "(\<Prod>l\<leftarrow>[3..<i]. \<alpha> l ^ (p l)) \<noteq> 0"
   unfolding prod_list_zero_iff using assms by (auto simp: \<alpha>0)
 
 lemma BT_eq_30': assumes i: "3 \<le> i" "i \<le> k + 1" "j < n (i - 1)"
 shows "subresultant j (F 1) (F 2)
   = smult ((- 1) ^ (\<Sum>l\<leftarrow>[3..<i]. (n (l - 2) - j) * (n (l - 1) - j))
      * (\<Prod>l\<leftarrow>[3..<i]. (\<beta> l / \<alpha> l) ^ (n (l - 1) - j)) * (\<Prod>l\<leftarrow>[3..<i]. f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1)))) (subresultant j (F (i - 2)) (F (i - 1)))"
   (is "_ = smult (?mm * ?b * ?f) _")
 proof -
   let ?a = "\<Prod>l\<leftarrow>[3..<i]. \<alpha> l ^ (n (l - 1) - j)"
   let ?d = "\<Prod>l\<leftarrow>[3..<i]. \<beta> l ^ (n (l - 1) - j) * f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1)) *
                      (- 1) ^ ((n (l - 2) - j) * (n (l - 1) - j))"
   let ?m = "\<Prod>l\<leftarrow>[3..<i]. (- 1) ^ ((n (l - 2) - j) * (n (l - 1) - j))"
   have a0: "?a \<noteq> 0" by (rule nonzero_alphaprod, rule i)
   with arg_cong[OF BT_eq_30[OF i], of "smult (inverse ?a)", unfolded smult_smult]
   have "subresultant j (F 1) (F 2) = smult (inverse ?a * ?d)
     (subresultant j (F (i - 2)) (F (i - 1)))"
     by simp
   also have "inverse ?a * ?d = ?b * ?f * ?m" unfolding prod_list_multf inverse_prod_list map_map o_def
       power_inverse[symmetric] power_mult_distrib divide_inverse_commute
     by simp
   also have "?m = ?mm"
     unfolding prod_list_minus_1_exp by simp
   finally show ?thesis by (simp add: ac_simps)
 qed
 
 text \<open>For defining the subresultant PRS, we mainly follow Brown's ``The Subresultant PRS Algorithm'' (B).\<close>
 
 definition "R j = (if j = n 2 then sdiv_poly (smult ((lead_coeff G2)^(\<delta> 1)) G2) (lead_coeff G2) else subresultant j G1 G2)"
 
 abbreviation "ff i \<equiv> to_fract (i :: 'a)"
 abbreviation "ffp \<equiv> map_poly ff"
 
 sublocale map_poly_hom: map_poly_inj_idom_hom to_fract..
 
 (* for \<sigma> and \<tau> we only take additions, so that no negative number-problems occur *)
 definition "\<sigma> i = (\<Sum>l\<leftarrow>[3..<Suc i]. (n (l - 2) + n (i - 1) + 1) * (n (l - 1) + n (i - 1) + 1))"
 definition "\<tau> i = (\<Sum>l\<leftarrow>[3..<Suc i]. (n (l - 2) + n i) * (n (l - 1) + n i))"
 
 definition "\<gamma> i = (-1)^(\<sigma> i) * pow_int ( f (i - 1)) (1 - int (\<delta> (i - 1))) * (\<Prod>l\<leftarrow>[3..<Suc i].
   (\<beta> l / \<alpha> l)^(n (l - 1) - n (i - 1) + 1) * (f (l - 1))^(\<delta> (l - 2) + \<delta> (l - 1)))"
 definition "\<Theta> i = (-1)^(\<tau> i) * pow_int (f i) (int (\<delta> (i - 1)) - 1) * (\<Prod>l\<leftarrow>[3..<Suc i].
   (\<beta> l / \<alpha> l)^(n (l - 1) - n i) * (f (l - 1))^(\<delta> (l - 2) + \<delta> (l - 1)))"
 
 (* is eq 29 in BT *)
 lemma fundamental_theorem_eq_4: assumes i: "3 \<le> i" "i \<le> k"
   shows "ffp (R (n (i - 1) - 1)) = smult (\<gamma> i) (F i)"
 proof -
   have "n (i - 1) \<le> n 2" by (rule n_ge_trans, insert i, auto)
   with n_gt[of "i - 1"] i have "n (i - 1) - 1 < n 2"
     and lt: "n (i - 1) - 1 < n (i - 1)" by linarith+
   hence "R (n (i - 1) - 1) = subresultant (n (i - 1) - 1) G1 G2"
     unfolding R_def by auto
   from arg_cong[OF this, of ffp, unfolded to_fract_hom.subresultant_hom, folded F1 F2]
   have id1: "ffp (R (n (i - 1) - 1)) = subresultant (n (i - 1) - 1) (F 1) (F 2)" .
   note eq_24 = BT_lemma_2_24[OF i]
   let ?o = "(- 1) :: 'a fract"
   let ?m1 = "(\<delta> (i - 2) + 1)"
   let ?d1 = "f (i - 1) ^ (\<delta> (i - 2) + 1) * \<beta> i"
   let ?c1 = "?o ^ ?m1  * ?d1"
   let ?c0 = "\<alpha> i"
   have "?c0 \<noteq> 0" using \<alpha>0[of i] i by auto
   with arg_cong[OF eq_24, of "smult (inverse ?c0)"]
   have id2: "subresultant (n (i - 1) - 1) (F (i - 2)) (F (i - 1)) =
      smult (inverse ?c0 * ?c1) (F i)"
     by (auto intro: poly_eqI)
   from i have "3 \<le> i" "i \<le> k + 1" by auto
   note id3 = BT_eq_30'[OF this lt]
   let ?f = "\<lambda> l. f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1))"
   let ?b = "\<lambda> l. (\<beta> l / \<alpha> l) ^ (n (l - 1) - (n (i - 1) - 1))"
   let ?b' = "\<lambda> l. (\<beta> l / \<alpha> l) ^ (n (l - 1) - n (i - 1) + 1)"
   let ?m = "\<lambda> l.  (n (l - 2) - (n (i - 1) - 1)) * (n (l - 1) - (n (i - 1) - 1))"
   let ?m' = "\<lambda> l. (n (l - 2) + n (i - 1) + 1) * (n (l - 1) + n (i - 1) + 1)"
   let ?m2 = "(\<Sum>l\<leftarrow>[3..<i]. ?m l)"
   let ?b2 = "(\<Prod>l\<leftarrow>[3..<i]. ?b l)"
   let ?f2 = "(\<Prod>l\<leftarrow>[3..<i]. ?f l)"
   let ?f1 = "pow_int ( f (i - 1)) (1 - int (\<delta> (i - 1)))"
   have id4: "\<gamma> i = ?o ^ (?m1 + ?m2) * (inverse ?c0 * ?d1 * ?b2 * ?f2)"
   proof -
     have id: "\<gamma> i = (-1)^(\<sigma> i) * (?f1 * (\<Prod>l\<leftarrow>[3..<Suc i]. ?b' l) * (\<Prod>l\<leftarrow>[3..<Suc i]. ?f l))"
       unfolding \<gamma>_def prod_list_multf by simp
     have cong: "even m1 = even m2 \<Longrightarrow> c1 = c2 \<Longrightarrow> ?o^m1 * c1 = ?o^m2 * c2" for m1 m2 c1 c2
       unfolding minus_1_power_even by auto
     show ?thesis unfolding id
     proof (rule cong)
       from n_gt[of "i - 1"] i have n1: "n (i - 1) \<noteq> 0" by linarith
       {
         fix l
         assume "2 \<le> l" "l \<le> i"
         hence l: "l \<ge> 2" "l - 1 \<le> i - 1" "l \<le> k" using i by auto
         from n_ge_trans[OF _ l(2)] l i have n2: "n (i - 1) \<le> n (l - 1)" by auto
         from n1 n2 have id: "n (l - 1) - (n (i - 1) - 1) = n (l - 1) - n (i - 1) + 1" by auto
         have "even (n (l - 1) - (n (i - 1) - 1)) = even (n (l - 1) + n (i - 1) + 1)"
           unfolding id using n2 by auto
         note id n2 this
       } note diff = this
       have f0: "f (i - 1) \<noteq> 0" using f0[of "i - 1"] i by auto
       have "(\<Prod>l\<leftarrow>[3..<Suc i]. ?b' l) = (\<Prod>l\<leftarrow>[3..<Suc i]. ?b l)"
         by (rule arg_cong, rule map_cong, use diff(1) in auto)
       also have "\<dots> = ?b2 * ?b i" using i by auto
       finally have "?f1 * (\<Prod>l\<leftarrow>[3..<Suc i]. ?b' l) * (\<Prod>l\<leftarrow>[3..<Suc i]. ?f l) =
          (?b2 * ?f2) * (?f1 * ?b i * ?f i)" using i by simp
       also have "?f1 * ?b i * ?f i = (?f1 * ?f i) * \<beta> i * inverse ?c0" using n1 by (simp add: divide_inverse)
       also have "?f1 * ?f i = f (i - 1) ^ (\<delta> (i - 2) + 1)"
         unfolding exp_pow_int pow_int_add[OF f0, symmetric] by simp
       finally
       show "?f1 * (\<Prod>l\<leftarrow>[3..<Suc i]. ?b' l) * (\<Prod>l\<leftarrow>[3..<Suc i]. ?f l)
          = inverse ?c0 * ?d1 * ?b2 * ?f2" by simp
       have "even (\<sigma> i) = even ((\<Sum>l\<leftarrow>[3..<i]. ?m' l) + ?m' i)" unfolding \<sigma>_def using i by simp
       also have "\<dots> = (even (\<Sum>l\<leftarrow>[3..<i]. ?m' l) = even (?m' i))" by simp
       also have "even (\<Sum>l\<leftarrow>[3..<i]. ?m' l) = even ?m2"
       proof (rule even_sum_list, goal_cases)
         case (1 l)
         hence l: "l \<ge> 2" "l \<le> i" and l1: "l - 1 \<ge> 2" "l - 1 \<le> i" by auto
         have l2: "l - 2 = l - 1 - 1" by simp
         show ?case using diff(3) [OF l] diff(3) [OF l1] l2
           by auto
       qed
       also have "even (?m' i) = even ?m1"
       proof -
         from i have id: "Suc (i - 1 - 1) = i - 1" "i - 2 = i - 1 - 1" by auto
         have "even ?m1 = even (n (i - 2) + n (i - 1) + 1)" unfolding \<delta> id
           using diff[of "i - 1"] i by auto
         also have "\<dots> = even (?m' i)" by auto
         finally show ?thesis by simp
       qed
       also have "(even ?m2 = even ?m1) = even (?m2 + ?m1)" unfolding even_add by simp
       also have "?m2 + ?m1 = ?m1 + ?m2" by simp
       finally show "even (\<sigma> i) = even (?m1 + ?m2)" .
     qed
   qed
   show ?thesis unfolding id1 id3 id2 smult_smult id4 by (simp add: ac_simps power_add)
 qed
 
 (* equation 28 in BT *)
 lemma fundamental_theorem_eq_5: assumes i: "3 \<le> i" "i \<le> k" "n i < j" "j < n (i - 1) - 1"
   shows "R j = 0"
 proof -
   from BT_lemma_2_23[OF i] have id1: "subresultant j (F (i - 2)) (F (i - 1)) = 0" .
   have "n (i - 1) \<le> n 2" by (rule n_ge_trans, insert i, auto)
   with n_gt[of "i - 1"] i have "n (i - 1) - 1 < n 2"
     and lt: "j < n (i - 1)" by linarith+
   with i have "R j = subresultant j G1 G2" unfolding R_def by auto
   from arg_cong[OF this, of ffp, unfolded to_fract_hom.subresultant_hom, folded F1 F2]
   have id2: "ffp (R j) = subresultant j (F 1) (F 2)" .
   from i have "3 \<le> i" "i \<le> k + 1" by auto
   note eq_30 = BT_eq_30[OF this lt]
   let ?c3 = "\<Prod>l\<leftarrow>[3..<i]. \<alpha> l ^ (n (l - 1) - j)"
   let ?c2 = "\<Prod>l\<leftarrow>[3..<i]. \<beta> l ^ (n (l - 1) - j) * f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1)) *
                   (- 1) ^ ((n (l - 2) - j) * (n (l - 1) - j))"
   have "?c3 \<noteq> 0" by (rule nonzero_alphaprod, insert i, auto)
   with arg_cong[OF eq_30, of "smult (inverse ?c3)"]
   have id3: "subresultant j (F 1) (F 2) = smult (inverse ?c3 * ?c2)
      (subresultant j (F (i - 2)) (F (i - 1)))"
     by (auto intro: poly_eqI)
   have "ffp (R j) = 0" unfolding id1 id2 id3 by simp
   thus ?thesis by simp
 qed
 
 (* equation 27 in BT *)
 lemma fundamental_theorem_eq_6: assumes "3 \<le> i" "i \<le> k" shows "ffp (R (n i)) = smult (\<Theta> i) (F i)"
   (is "?lhs=?rhs")
 proof -
   from assms have i1:"1 \<le> i" by auto
   from assms have nlt:"i \<le> k + 1" "n i < n (i - 1)" using n_gt[of "i - 1"] by auto
   from assms have \<alpha>nz:"\<alpha> i ^ \<delta> (i - 1) \<noteq> 0" using \<alpha>0 by auto
   have *:"\<And> a f b. a \<noteq> 0 \<Longrightarrow> smult a f = b \<Longrightarrow> f = smult (inverse (a::'a fract)) b" by auto
   have **:"\<And> f g xs c. c * prod_list (map f xs) * prod_list (map g xs)
          = c * (\<Prod>x\<leftarrow>xs. f x * (g:: _ \<Rightarrow> (_ :: comm_monoid_mult)) x)"
          by (auto simp:ac_simps prod_list_multf)
   have ***:"\<And> c. \<beta> i ^ \<delta> (i - Suc 0) * (inverse (\<alpha> i ^ \<delta> (i - Suc 0)) * c) = (\<beta> i / \<alpha> i) ^ \<delta> (i - 1) * c"
     by (auto simp:inverse_eq_divide power_divide)
   have ****:"int (n (i - Suc 0) - n i) - 1 = int (n (i - 1) - Suc (n i))"
     using assms nlt by auto
   from assms n_ge[of "i-2"] nlt n_ge[of i]
     have nge:"n (i - Suc 0) \<le> n (i - 2)" "n i < n (i - Suc 0)" "n i < n (i - 1)" "Suc (i - 2) = i - 1"
     by (cases i,auto simp:numeral_2_eq_2 numeral_3_eq_3)
   have *****:"(- 1 ::  'a fract) ^ ((n (i - Suc 0) - n i) * (n (i - Suc 0) - n i + (n (i - 2) - n (Suc (i - 2)))))
        = (- 1) ^ ((n i + n (i - Suc 0)) * (n i + n (i - 2)))"
        "(- 1 ::  'a fract) ^ (\<Sum>l\<leftarrow>[3..<i]. (n (l - Suc 0) - n i) * (n (l - 2) - n i))
        = (- 1) ^ (\<Sum>l\<leftarrow>[3..<i]. (n i + n (l - Suc 0)) * (n i + n (l - 2))) "
     using nge apply (intro minus_1_even_eqI,auto)
     apply (intro minus_1_even_eqI)
     apply (intro even_sum_list)
     proof(goal_cases) case (1 x)
       with n_ge_trans assms
         have "n i \<le> n (x - Suc 0)" "n (x - 2) \<ge> n i" by auto
       with 1 show ?case by auto
     qed
   have "ffp (R (n i)) = subresultant (n i) (F 1) (F 2)" unfolding R_def F1 F2
     by (auto simp: to_fract_hom.subresultant_hom ni2[OF assms])
   also have "\<dots> = smult
      ((- 1) ^ (\<Sum>l\<leftarrow>[3..<i]. (n (l - 2) - n i) * (n (l - 1) - n i)) *
       (\<Prod>x\<leftarrow>[3..<i]. (\<beta> x / \<alpha> x) ^ (n (x - 1) - n i) * f (x - 1) ^ (\<delta> (x - 1) + \<delta> (x - 2))) *
       (((\<beta> i / \<alpha> i) ^ \<delta> (i - 1)) * f (i - 1) ^ (\<delta> (i - 1) + \<delta> (i - 2))) *
        ((- 1) ^ ((\<delta> (i - 2) + \<delta> (i - 1)) * \<delta> (i - 1)) * f i ^ (\<delta> (i - 1) - 1)
         ))
      (F i)"
     unfolding BT_eq_30'[OF assms(1) nlt] **
               *[OF \<alpha>nz BT_lemma_2_22[OF assms]] smult_smult by (auto simp:ac_simps *** )
   also have "\<dots> = ?rhs" unfolding \<Theta>_def \<tau>_def
     using prod_combine[OF assms(1)] \<delta> assms
     by (auto simp:ac_simps exp_pow_int[symmetric] power_add ***** ****)
   finally show ?thesis.
 qed
 
 (* equation 26 in BT *)
 lemma fundamental_theorem_eq_7: assumes j: "j < n k" shows "R j = 0"
 proof -
   let ?P = "pseudo_divmod (F (k - 1)) (F k)"
   from F0[of k] k2 have Fk: "F k \<noteq> 0" by auto
   from pmod[of "Suc k"] k2 F0[of "Suc k"]
   have "pseudo_mod (F (k - 1)) (F k) = 0" by auto
   then obtain Q where "?P = (Q,0)"
     unfolding pseudo_mod_def by (cases ?P, auto)
   from pseudo_divmod(1)[OF Fk this] Fk obtain c where id: "smult c (F (k - 1)) = F k * Q"
     and c: "c \<noteq> 0" by auto
   from id have id: "smult c (F (k - 1)) = Q * F k" by auto
   from n_ge[unfolded n, of "k - 1"] k2 c have "degree (F k) \<le> degree (smult c (F (k - 1)))" by auto
   from subresultant_product[OF id this, unfolded subresultant_smult_left[OF c], of j] j
   have *:"subresultant j (F (k + 1 - 2)) (F (k + 1 - 1)) = 0" using c unfolding n by simp
   from assms have **:"j \<noteq> n 2"
     by (meson k2 n_ge_trans not_le one_le_numeral order_refl)
   from k2 assms have "3 \<le> k + 1" "k + 1 \<le> k + 1" "j < n (k + 1 - 1)" by auto
   from BT_eq_30[OF this,unfolded *] nonzero_alphaprod[OF le_refl] ** F1 F2
   show ?thesis by (auto simp:R_def F0 to_fract_hom.subresultant_hom[symmetric])
 qed
 
 
 definition "G i = R (n (i - 1) - 1)"
 definition "H i = R (n i)"
 
 lemma gamma_delta_beta_3: "\<gamma> 3 = (- 1) ^ (\<delta> 1 + 1) * \<beta> 3"
 proof -
   have "\<gamma> 3 = (- 1) ^ \<sigma> 3 * pow_int (f 2) (1 - int (\<delta> 2)) *
     (\<beta> 3 / (f 2 ^ Suc (\<delta> 1)) * f 2 ^ (\<delta> 1 + \<delta> 2))"
     unfolding \<gamma>_def \<delta> \<alpha>_def by (simp add: \<delta>)
   also have "f 2 ^ (\<delta> 1 + \<delta> 2) = pow_int (f 2) (int (\<delta> 1 + \<delta> 2))"
     unfolding pow_int_def nat_int by auto
   also have "int (\<delta> 1 + \<delta> 2) = int (Suc (\<delta> 1)) + (int (\<delta> 2) - 1)" by simp
   also have "pow_int (f 2) \<dots> = pow_int (f 2) (Suc (\<delta> 1)) * pow_int (f 2) (int (\<delta> 2) - 1)"
     by (rule pow_int_add, insert f20, auto)
   also have "pow_int (f 2) (Suc (\<delta> 1)) = f 2 ^ (Suc (\<delta> 1))" unfolding pow_int_def nat_int by simp
   also have "\<beta> 3 / (f 2 ^ Suc (\<delta> 1)) *
    (f 2 ^ Suc (\<delta> 1) * pow_int (f 2) (int (\<delta> 2) - 1))
     = (\<beta> 3 / (f 2 ^ Suc (\<delta> 1)) *  f 2 ^ Suc (\<delta> 1) * pow_int (f 2) (int (\<delta> 2) - 1))" by simp
   also have "\<beta> 3 / (f 2 ^ Suc (\<delta> 1)) * f 2 ^ Suc (\<delta> 1) = \<beta> 3" using f20 by auto
   finally have "\<gamma> 3 = ((- 1) ^ \<sigma> 3 * \<beta> 3) * (pow_int (f 2) (1 - int (\<delta> 2)) * pow_int (f 2) (int (\<delta> 2) - 1))"
     by simp
   also have "pow_int (f 2) (1 - int (\<delta> 2)) * pow_int (f 2) (int (\<delta> 2) - 1)
     = 1"
     by (subst pow_int_add[symmetric], insert f20, auto)
   finally have "\<gamma> 3 = (- 1) ^ \<sigma> 3 * \<beta> 3" by simp
   also have "\<sigma> 3 = (n 1 + n 2 + 1) * (n 2 + n 2 + 1)" unfolding \<sigma>_def
     by simp
   also have "(- (1 :: 'a fract)) ^ \<dots> = (- 1) ^ (n 1 - n 2 + 1)"
     by (rule minus_1_even_eqI, insert n12, auto)
   also have "\<dots> = (- 1)^(\<delta> 1 + 1)" unfolding \<delta> by (simp add: numeral_2_eq_2)
   finally show "\<gamma> 3 = (- 1) ^ (\<delta> 1 + 1) * \<beta> 3" .
 qed
 
 fun h :: "nat \<Rightarrow> 'a fract" where
   "h i = (if (i \<le> 1) then 1 else if i = 2 then (f 2 ^ \<delta> 1) else (f i ^ \<delta> (i - 1) / (h (i - 1) ^ (\<delta> (i - 1) - 1))))"
 
 lemma smult_inverse_sdiv_poly: assumes ffp: "p \<in> range ffp"
   and p: "p = smult (inverse x) q"
   and p': "p' = sdiv_poly q' x'"
   and xx: "x = ff x'"
   and qq: "q = ffp q'"
 shows "p = ffp p'"
 proof (rule poly_eqI)
   fix i
   have "coeff p i = coeff q i / x" unfolding p by (simp add: field_simps)
   also have "\<dots> = ff (coeff q' i) / ff x'" unfolding qq xx by simp
   finally have cpi: "coeff p i = ff (coeff q' i) / ff x'" .
   from ffp obtain r where pr: "p = ffp r" by auto
   from arg_cong[OF this, of "\<lambda> p. coeff p i", unfolded cpi]
   have "ff (coeff q' i) / ff x' \<in> range ff" by auto
   hence id: "ff (coeff q' i) / ff x' = ff (coeff q' i div x')"
     by (rule div_divide_to_fract, auto)
   show "coeff p i = coeff (ffp p') i" unfolding cpi id p'
     by (simp add: sdiv_poly_def coeff_map_poly)
 qed
 
 end
 
 locale subresultant_prs_locale2 = subresultant_prs_locale F n \<delta> f k \<beta> G1 G2 for
        F :: "nat \<Rightarrow> 'a :: idom_divide fract poly"
     and n :: "nat \<Rightarrow> nat"
     and \<delta> :: "nat \<Rightarrow> nat"
     and f :: "nat \<Rightarrow> 'a fract"
     and k :: nat
     and \<beta> :: "nat \<Rightarrow> 'a fract"
     and G1 G2 :: "'a poly" +
   assumes \<beta>3: "\<beta> 3 = (-1)^(\<delta> 1 + 1)"
   and \<beta>i: "\<And> i. 4 \<le> i \<Longrightarrow> i \<le> Suc k \<Longrightarrow> \<beta> i = (-1)^(\<delta> (i - 2) + 1) * f (i - 2) * h (i - 2) ^ (\<delta> (i - 2))"
 begin
 
 lemma B_eq_17_main: "2 \<le> i \<Longrightarrow> i \<le> k \<Longrightarrow>
     h i = (-1) ^ (n 1 + n i + i + 1) / f i
    * (\<Prod>l\<leftarrow>[3..< Suc (Suc i)]. (\<alpha> l / \<beta> l)) \<and> h i \<noteq> 0"
 proof (induct i rule: less_induct)
   case (less i)
   from less(2-) have fi0: "f i \<noteq> 0" using f0[of i] by simp
   have 1: "(- 1) \<noteq> (0 :: 'a fract)" by simp
   show ?case (is "h i = ?r i \<and> _")
   proof (cases "i = 2")
     case True
     have f20: "f 2 \<noteq> 0" using f20 by auto
     have hi: "h i = f 2 ^ \<delta> 1" unfolding True h.simps[of 2] by simp
     have id: "int (\<delta> 1) = int (n 1) - int (n 2)" using n12 unfolding \<delta> numeral_2_eq_2 by simp
     have "?r i = (- 1) ^ (1 + n 1 + n 2)
       * ((f 2 ^ Suc (\<delta> 1)) / (\<beta> 3)) / pow_int (f 2) 1" unfolding True \<alpha>_def by simp
     also have "\<beta> 3 = (- 1) ^ (\<delta> 1 + 1)" by (rule \<beta>3)
     also have "f 2 ^ Suc (\<delta> 1) / \<dots> = \<dots> * f 2 ^ Suc (\<delta> 1)" by simp
     finally have "?r i = ((- 1) ^ (1 + n 1 + n 2) * ((- 1) ^ (\<delta> 1 + 1))) *
         pow_int (f 2) (int (Suc (\<delta> 1)) + (-1))" (is "_ = ?a * _")
       unfolding pow_int_divide exp_pow_int power_add pow_int_add[OF f20] by (simp add: ac_simps pow_int_add)
     also have "?a = (-1)^(1 + n 1 + n 2 + \<delta> 1 + 1)" unfolding power_add by simp
     also have "\<dots> = (-1)^0"
       by (rule minus_1_even_eqI, insert n12, auto simp: \<delta> numeral_2_eq_2, presburger)
     finally have ri: "?r i = pow_int (f 2) (int (\<delta> 1))" by simp
     show ?thesis unfolding ri hi exp_pow_int[symmetric] using f20 by simp
   next
     case False
     hence i: "i \<ge> 3" and ii: "i - 1 < i" "2 \<le> i - 1" "i - 1 \<le> k" using less(2-) by auto
     from i less(2-) have cc: "4 \<le> Suc i" "Suc i \<le> Suc k" by auto
     define P where "P = (\<Prod>l\<leftarrow>[3..< Suc i]. \<alpha> l / \<beta> l)"
     define Q where "Q = P * pow_int (h (i - 1)) (- int (\<delta> (i - 1)))"
     define R where "R = f i ^ \<delta> (i - 1)"
     define S where "S = pow_int (f (i - 1)) (- 1)"
     note IH = less(1)[OF ii]
     hence hi0: "h (i - 1) \<noteq> 0" by auto
     have hii: "h i = f i ^ \<delta> (i - 1) / h (i - 1) ^ (\<delta> (i - 1) - 1)"
       unfolding h.simps[of i] using i by simp
     also have "\<dots> = f i ^ \<delta> (i - 1) * pow_int (h (i - 1)) (- int (\<delta> (i - 1) - 1))"
       unfolding exp_pow_int pow_int_divide by simp
     also have "int (\<delta> (i - 1) - 1) = int (\<delta> (i - 1)) - 1"
     proof -
       have "\<delta> (i - 1) > 0" unfolding \<delta>[of "i - 1"] using n_gt[OF ii(2)] less(2-) by auto
       thus ?thesis by simp
     qed
     also have "- (int (\<delta> (i - 1)) - 1) = 1 + (- int (\<delta> (i - 1)))" by simp
     finally have hi: "h i = (- 1) ^ (n 1 + n (i - 1) + i) * (R * Q * S)"
       unfolding pow_int_add[OF hi0] P_def Q_def pow_int_divide[symmetric] R_def S_def using IH i by (simp add: ac_simps)
     from i have id: "[3..<Suc (Suc i)] = [3 ..< Suc i] @ [Suc i]" by simp
     have "?r i = (- 1) ^ (n 1 + n i + i + 1)
       * pow_int (f i) (- 1) * P * \<alpha> (Suc i) / \<beta> (Suc i)"
       unfolding pow_int_divide[symmetric] P_def id Fract_conv_to_fract by simp
     also have "\<beta> (Suc i) = (- 1) ^ (\<delta> (i - 1) + 1) * f (i - 1) * h (i - 1) ^ \<delta> (i - 1)"
       using \<beta>i[OF cc] by simp
     also have "\<alpha> (Suc i) = f i ^ Suc (\<delta> (i - 1))" unfolding \<alpha>_def by simp
     finally have "?r i = (- 1) ^ (n 1 + n i + i + 1) * pow_int (f i) (- 1) * P *  (f i ^ Suc (\<delta> (i - 1))) /
       (- 1) ^ (\<delta> (i - 1) + 1) * pow_int (f (i - 1)) (- 1) / h (i - 1) ^ \<delta> (i - 1)"
       (is "_ = ?a1 * ?fi1 * P * ?fi2 / ?a2 * ?b / ?c")
       unfolding exp_pow_int pow_int_divide[symmetric] by simp
     also have "\<dots> = (?a1 / ?a2) * (?fi1 * ?fi2) * (P / ?c) * ?b" by (simp add: ac_simps)
     also have "?a1 / ?a2 = (- 1) ^ (n 1 + n i + i + 1 + \<delta> (i - 1) + 1)"
       by (simp add: power_add)
     also have "\<dots> = (-1) ^ (n 1 + n i + i + \<delta> (i - 1))"
       by (rule minus_1_even_eqI, auto)
     also have "n 1 + n i + i + \<delta> (i - 1) = n 1 + n (i - 1) + i"
       unfolding \<delta> using i less(2-) n_ge[of "i - 1"] by simp
     also have "?fi1 * ?fi2 = pow_int (f i) (-1 + int (Suc (\<delta> (i - 1))))"
       unfolding exp_pow_int pow_int_add[OF fi0] by simp
     also have "\<dots> = pow_int (f i) (int (\<delta> (i - 1)))" by simp
     also have "P / ?c = Q"  unfolding Q_def exp_pow_int pow_int_divide by simp
     also have "?b = S" unfolding S_def by simp
     finally have ri: "?r i = (-1)^(n 1 + n (i - 1) + i)
       * (R * Q * S)" by (simp add: exp_pow_int R_def)
     have id: "h i = ?r i" unfolding hi ri ..
     show ?thesis
       by (rule conjI[OF id], unfold hii, insert IH fi0, auto)
   qed
 qed
 
 lemma B_eq_17: "2 \<le> i \<Longrightarrow> i \<le> k \<Longrightarrow>
     h i = (-1) ^ (n 1 + n i + i + 1) / f i * (\<Prod>l\<leftarrow>[3..< Suc (Suc i)]. (\<alpha> l / \<beta> l))"
   using B_eq_17_main by blast
 
 lemma B_theorem_2: "3 \<le> i \<Longrightarrow> i \<le> Suc k \<Longrightarrow> \<gamma> i = 1"
 proof (induct i rule: less_induct)
   case (less i)
   show ?case
   proof (cases "i = 3")
     case True
     show ?thesis unfolding True unfolding gamma_delta_beta_3 \<beta>3 by simp
   next
     case False
     with less(2-)
     have i: "i \<ge> 4" and ii: "i - 1 < i" "3 \<le> i - 1" "i - 1 \<le> Suc k"
       and iii: "4 \<le> i" "i \<le> Suc k"
       and iv: "2 \<le> i - 2" "i - 2 \<le> k" by auto
     from less(1)[OF ii] have IH: "\<gamma> (i - 1) = 1" .
     define L where "L = [3..< i]"
     have id: "[3..<Suc (i - 1)] = L" "[3..<Suc i] = L @ [i]" "Suc (Suc (i - 2)) = i"
       unfolding L_def using i by auto
     define B where "B = (\<lambda> l. \<beta> l / \<alpha> l)"
     define A where "A = (\<lambda> l. \<alpha> l / \<beta> l)"
     define Q where "Q = (\<lambda> l. f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1)))"
     define R where "R = (\<lambda> i l. B l ^ (n (l - 1) - n (i - 1) + 1))"
     define P where "P = (\<lambda> i l. R i l * Q l)"
     have fi0: "f (i - 1) \<noteq> 0" using f0[of "i - 1"] less(2-) by auto
     have fi0': "f (i - 2) \<noteq> 0" using f0[of "i - 2"] less(2-) by auto
     {
       fix j
       assume "j \<in> set L"
       hence "j \<ge> 3" "j < i" unfolding L_def by auto
       with less(3) have j: "j - 1 \<noteq> 0" "j - 1 < k" by auto
       hence Q: "Q j \<noteq> 0" unfolding Q_def using f0[of "j - 1"] by auto
       from j \<alpha>0 \<beta>0[of j] have 0: "\<alpha> j \<noteq> 0" "\<beta> j \<noteq> 0" by auto
       hence "B j \<noteq> 0" "A j \<noteq> 0" unfolding B_def A_def by auto
       note Q this
     } note L0 = this
     let ?exp = "\<delta> (i - 2)"
     have "\<gamma> i = \<gamma> i / \<gamma> (i - 1)" unfolding IH by simp
     also have "\<dots> = (- 1) ^ \<sigma> i * pow_int (f (i - 1)) (1 - int (\<delta> (i - 1))) *
       (\<Prod>l\<leftarrow>L. P i l) * P i i /
       ((- 1) ^ \<sigma> (i - 1) * pow_int (f (i - 2)) (1 - int (\<delta> (i - 2))) *
        (\<Prod>l\<leftarrow>L. P (i - 1) l))"  (is "_ = ?a1 * ?f1 * ?L1 * P i i / (?a2 * ?f2 * ?L2)")
       unfolding \<gamma>_def id P_def Q_def R_def B_def by (simp add: numeral_2_eq_2)
     also have "\<dots> = (?a1 * ?a2) * (?f1 * P i i) / ?f2 * (?L1 / ?L2)" unfolding divide_prod_assoc by simp
     also have "?a1 * ?a2 = (-1)^(\<sigma> i + \<sigma> (i - 1))" (is "_ = ?a") unfolding power_add by simp
     also have "?L1 / ?L2 = (\<Prod>l\<leftarrow>L. R i l) / (\<Prod>l\<leftarrow>L. R (i - 1) l) * ((\<Prod>l\<leftarrow>L. Q l) / (\<Prod>l\<leftarrow>L. Q l))"
       unfolding P_def prod_list_multf divide_prod_assoc by simp
     also have "\<dots> = (\<Prod>l\<leftarrow>L. R i l) / (\<Prod>l\<leftarrow>L. R (i - 1) l)" (is "_ = ?L1 / ?L2")
     proof -
       have "(\<Prod>l\<leftarrow>L. Q l) \<noteq> 0" unfolding prod_list_zero_iff using L0 by auto
       thus ?thesis by simp
     qed
     also have "?f1 * P i i = (?f1 * pow_int (f (i - 1)) (int ?exp + int (\<delta> (i - 1)))) * R i i" unfolding P_def Q_def
       exp_pow_int by simp
     also have "?f1 * pow_int (f (i - 1)) (int ?exp + \<delta> (i - 1)) = pow_int (f (i - 1))
       (1 + int ?exp)" (is "_ = ?f1")
       unfolding pow_int_add[OF fi0, symmetric] by simp
     also have "R i i = \<beta> i / \<alpha> i" unfolding B_def R_def Fract_conv_to_fract by simp
     also have "\<alpha> i = f (i - 1) ^ Suc ?exp" unfolding \<alpha>_def by simp
     also have "\<beta> i / \<dots> = \<beta> i * pow_int (f (i - 1)) (- 1 - ?exp)"
       (is "_ = ?\<beta> * ?f12")
       unfolding exp_pow_int pow_int_divide by simp
     finally have "\<gamma> i = (?a * (?f1 * ?f12)) *  ?\<beta> / ?f2 * (?L1 / ?L2)"
       by simp
     also have "?a * (?f1 * ?f12) = ?a" unfolding pow_int_add[OF fi0, symmetric] by simp
     also have "?L1 / ?L2 = pow_int (\<Prod>l\<leftarrow>L. A l) (- ?exp)"
     proof -
       have id: "i - 1 - 1 = i - 2" by simp
       have "set L \<subseteq> {l. 3 \<le> l \<and> l \<le> k \<and> l < i}" unfolding L_def using less(3) by auto
       thus ?thesis unfolding R_def id
       proof (induct L)
         case (Cons l L)
         from Cons(2) have l: "3 \<le> l" "l \<le> k" "l < i" and L: "set L \<subseteq> {l. 3 \<le> l \<and> l \<le> k \<and> l < i}" by auto
         note IH = Cons(1)[OF L]
         from l \<alpha>0 \<beta>0[of l] have 0: "\<alpha> l \<noteq> 0" "\<beta> l \<noteq> 0" by auto
         hence B0: "B l \<noteq> 0" unfolding B_def by auto
         have "(\<Prod>l\<leftarrow>l # L. B l ^ (n (l - 1) - n (i - 1) + 1)) / (\<Prod>l\<leftarrow>l # L. B l ^ (n (l - 1) - n (i - 2) + 1))
           = (B l ^ (n (l - 1) - n (i - 1) + 1) * (\<Prod>l\<leftarrow>L. B l ^ (n (l - 1) - n (i - 1) + 1))) /
             (B l ^ (n (l - 1) - n (i - 2) + 1) * (\<Prod>l\<leftarrow>L. B l ^ (n (l - 1) - n (i - 2) + 1)))"
           (is "_ = (?l1 * ?L1) / (?l2 * ?L2)") by simp
         also have "\<dots> = (?l1 / ?l2) * (?L1 / ?L2)" by simp
         also have "?L1 / ?L2 = pow_int (prod_list (map A L)) (- int (\<delta> (i - 2)))" by (rule IH)
         also have "?l1 / ?l2 = pow_int (B l) (int (n (l - 1) - n (i - 1)) - int (n (l - 1) - n (i - 2)))" unfolding exp_pow_int pow_int_divide pow_int_add[OF B0, symmetric]
           by simp
         also have "int (n (l - 1) - n (i - 1)) - int (n (l - 1) - n (i - 2)) = int ?exp"
         proof -
           have "n (l - 1) \<ge> n (i - 2)" "n (l - 1) \<ge> n (i - 1)" "n (i - 2) \<ge> n (i - 1)"
             using i l less(3)
             by (intro n_ge_trans, auto)+
           hence id: "int (n (l - 1) - n (i - 1)) = int (n (l - 1)) - int (n (i - 1))"
                 "int (n (l - 1) - n (i - 2)) = int (n (l - 1)) - int (n (i - 2))"
                 "int (n (i - 2) - n (i - 1)) = int (n (i - 2)) - int (n (i - 1))"
             by simp_all
           have id2: "int ?exp = int (n (i - 2) - n (i - 1))"
             unfolding \<delta> using i by (cases i; cases "i - 1", auto)
           show ?thesis unfolding id2 unfolding id by simp
         qed
         also have "pow_int (B l) \<dots> = pow_int (inverse (B l)) (- \<dots>)" unfolding pow_int_def
           by (cases "int (\<delta> (i - 2))" rule: linorder_cases, auto simp: field_simps)
         also have "inverse (B l) = A l" unfolding B_def A_def by simp
         also have "pow_int (A l) (- int ?exp) * pow_int (prod_list (map A L)) (- int ?exp)
           = pow_int (prod_list (map A (l # L))) (- int ?exp)"
           by (simp add: pow_int_mult)
         finally show ?case .
       qed simp
     qed
     also have "\<beta> i = (- 1) ^ (?exp + 1) * f (i - 2) * h (i - 2) ^ ?exp"
       unfolding \<beta>i[OF iii] ..
     finally have "\<gamma> i =  (((- 1) ^ (\<sigma> i + \<sigma> (i - 1)) * (- 1) ^ (?exp + 1))) *
       (pow_int (f (i - 2)) 1 *
       pow_int (f (i - 2)) (int ?exp - 1)) *
       h (i - 2) ^ ?exp /
       (\<Prod>l\<leftarrow>L. A l) ^ ?exp" (is "_ = ?a * ?f1 * ?H / ?L") unfolding pow_int_divide exp_pow_int by simp
     also have "?f1 = pow_int (f (i - 2)) (int ?exp)" (is "_ = ?f1") unfolding pow_int_add[OF fi0', symmetric]
       by simp
     also have "h (i - 2) = (- 1) ^ (n 1 + n (i - 2) + (i - 2) + 1) / f (i - 2) *
       (\<Prod>l\<leftarrow>L. A l)" (is "_ = ?a2 / ?f2 * ?L") unfolding B_eq_17[OF iv] A_def id L_def by simp
     also have "((- (1 :: 'a fract)) ^ (\<sigma> i + \<sigma> (i - 1)) * (- 1) ^ (?exp + 1)) =
       ((- 1) ^ (\<sigma> i + \<sigma> (i - 1) + ?exp + 1))" (is "_ = ?a1") by (simp add: power_add)
     finally have "\<gamma> i = ?a1 * ?f1 * (?a2 / ?f2 * ?L) ^ ?exp / ?L ^ ?exp" by simp
     also have "\<dots> = (?a1 * ?a2^?exp) * (?f1 / ?f2 ^ ?exp) * (?L^?exp / ?L ^ ?exp)"
       unfolding power_mult_distrib power_divide by auto
     also have " ?L ^ ?exp / ?L ^ ?exp = 1"
     proof -
       have "?L \<noteq> 0" unfolding prod_list_zero_iff using L0 by auto
       thus ?thesis by simp
     qed
     also have "?f1 / ?f2 ^ ?exp = 1" unfolding exp_pow_int pow_int_divide
       pow_int_add[OF fi0', symmetric] by simp
     also have "?a2^?exp = (- 1) ^ ((n 1 + n (i - 2) + (i - 2) + 1) * ?exp)"
       by (rule semiring_normalization_rules)
     also have "?a1 * \<dots> = (- 1) ^ (\<sigma> i + \<sigma> (i - 1) + ?exp + 1 + (n 1 + n (i - 2) + (i - 2) + 1) * ?exp)"
       (is "_ = _ ^ ?e")
       by (simp add: power_add)
     also have "\<dots> = (-1)^0"
     proof -
       define e where "e = ?e"
       have *: "?e = (2 * ?exp + \<sigma> i + \<sigma> (i - 1) + 1 + (n 1 + n (i - 2) + (i - 2)) * ?exp)" by simp
       define A where "A = (\<lambda> i l. (n (l - 2) + n (i - 1) + 1) * (n (l - 1) + n (i - 1) + 1))"
       define B where "B = (\<lambda> i. (n (i - 1) + 1) * (n (i - 1) + 1))"
       define C where "C = (\<lambda> l. (n (l - 1) + n (l - 2) + n (l - 1) * n (l - 2)))"
       define D where "D = (\<lambda> l. n (l - 1) + n (l - 2))"
       define m2 where "m2 = n (i - 2)"
       define m1 where "m1 = n (i - 1)"
       define m0 where "m0 = n 1"
       define i3 where "i3 = i - 3"
       have m12: "m2 \<ge> m1" unfolding m2_def m1_def using n_ge[of "i - 2"] i less(3)
         by (cases i, auto)
       have idd: "Suc (i - 2) = i - 1" "i - 1 - 1 = i - 2" using i by auto
       have id4: "i - 2 = Suc i3" unfolding i3_def using i by auto
       from i have "3 < i" by auto
       hence "\<exists> k. sum_list (map D L) = n 1 + n (i - 2) + 2 * k" unfolding L_def
       proof (induct i rule: less_induct)
         case (less i)
         show ?case
         proof (cases "i = 4")
           case True
           thus ?thesis by (simp add: D_def)
         next
           case False
           obtain ii where i: "i = Suc ii" and ii: "ii < i" "3 < ii" using False less(2) by (cases i, auto)
           from less(1)[OF ii] obtain k where IH: "sum_list (map D [3 ..< ii]) = n 1 + n (ii - 2) + 2 * k" by auto
           have "map D [3 ..< i] = map D [3 ..< ii] @ [D ii]" unfolding i using ii by auto
           hence "sum_list (map D [3..<i]) = n 1 + n (ii - 2) + 2 * k + D ii" using IH by simp
           also have "\<dots> = n 1 + n (ii - 1) + 2 * (n (ii - 2) + k)" unfolding D_def by simp
           also have "n (ii - 1) = n (i - 2)" unfolding i by simp
           finally show ?thesis by blast
         qed
       qed
       then obtain kk where DL: "sum_list (map D L) = n 1 + n (i - 2) + 2 * kk" ..
       let ?l = "i - 3"
       have len: "length L = i - 3" unfolding L_def using i by auto
       have A: "A i l = B i + D l * n (i - 1) + C l" for i l
         unfolding A_def B_def C_def D_def ring_distribs by simp
       have id2: "[3..<Suc i] = 3 # [Suc 3 ..< Suc i]"
         unfolding L_def using i by (auto simp: upt_rec[of 3])
       have "even e = even ?e" unfolding e_def by simp
       also have "\<dots> = even ((1 + (n 1 + n (i - 2) + (i - 2)) * ?exp) + (\<sigma> i + \<sigma> (i - 1)))"
         (is "_ = even (?g + ?j)")
         unfolding * by (simp add: ac_simps)
       also have "?j = (\<Sum>l\<leftarrow>L @ [i]. A i l) + (\<Sum>l\<leftarrow>L. A (i - 1) l)"
         unfolding \<sigma>_def id A_def by simp
       also have "\<dots> = 2 * (\<Sum>l\<leftarrow>L. C l) + (Suc ?l) * B i + (\<Sum>l\<leftarrow>L @ [i]. D l * n (i - 1)) + C i +
           ?l * B (i - 1) + (\<Sum>l\<leftarrow>L. D l * n (i - 1 - 1))"
         unfolding A sum_list_addf by (simp add: sum_list_triv len)
       also have "\<dots> = ((Suc ?l * B i + C i +
           ?l * B (i - 1) + D i * n (i - 1)) + ((\<Sum>l\<leftarrow>L. D l) * (n (i - 1) + n (i - 2)) + 2 * (\<Sum>l\<leftarrow>L. C l)))"
         (is "_ = ?i + ?j")
         unfolding sum_list_mult_const by (simp add: ring_distribs numeral_2_eq_2)
       also have "?j =
           (n 1 + n (i - 2)) * (n (i - 1) + n (i - 2)) + 2 * (kk * (n (i - 1) + n (i - 2)) + (\<Sum>l\<leftarrow>L. C l))"
         (is "_ = ?h + 2 * ?f")
         unfolding DL by (simp add: ring_distribs)
       finally have "even e = even (?g + ?i + ?h + 2 * ?f)" by presburger
       also have "\<dots> = even (?g + ?i + ?h)" by presburger
       also have "?g + ?i + ?h =
          i3 * (m2 - m1 + m1 * m1 + m2 * m2)
          + (m2 - m1 + m1 + m2) * (m0 + m2)
          + (m1 + m2 + (m2 - m1))
          + 2 * (m1 * m2 + m1 * m1 + 1 + i3 + m1 * Suc i3 + m2 * i3)" unfolding idd B_def D_def C_def \<delta>
         m1_def[symmetric] m2_def[symmetric] m0_def[symmetric]
         unfolding i3_def[symmetric] id4
         by (simp add: ring_distribs)
       also have "(m1 + m2 + (m2 - m1)) = 2 * m2" using m12 by simp
       also have "(m2 - m1 + m1 + m2) * (m0 + m2) = 2 * (m2 * (m0 + m2))" using m12 by simp
       finally obtain l1 l2 l3 where
         "even e = even (i3 * (m2 - m1 + m1 * m1 + m2 * m2)  + 2 * l1 + 2 * l2 + 2 * l3)"
         by blast
       also have "\<dots> = even (i3 * (m2 - m1 + m1 * m1 + m2 * m2))" by simp
       also have "\<dots> = even (i3 * (2 * m1 + (m2 - m1 + m1 * m1 + m2 * m2)))" by simp
       also have "2 * m1 + (m2 - m1 + m1 * m1 + m2 * m2) = m1 + m2 + m1 * m1 + m2 * m2"
         using m12 by simp
       also have "even (i3 * \<dots>)" by auto
       finally have "even e" .
       thus ?thesis unfolding e_def
         by (intro minus_1_even_eqI, auto)
     qed
     finally show "\<gamma> i = 1" by simp
   qed
 qed
 
 context
   fixes i :: nat
   assumes i: "3 \<le> i" "i \<le> k"
 begin
 lemma B_theorem_3_b: "\<Theta> i * f i = ff (lead_coeff (H i))"
   using arg_cong[OF fundamental_theorem_eq_6[folded H_def, OF i], of lead_coeff] unfolding f[of i]
   lead_coeff_smult by simp
 
 lemma B_theorem_3_main: "\<Theta> i * f i / \<gamma> (i + 1) = (-1)^(n 1 + n i + i + 1) / f i * (\<Prod>l\<leftarrow>[3..< Suc (Suc i)]. (\<alpha> l / \<beta> l))"
 proof (cases "f i = 0")
   case True
   thus ?thesis by simp
 next
   case False note ff0 = this
   from i(1) have "Suc (Suc i) > 3" by auto
   hence id: "[3 ..< Suc (i + 1)] = [3 ..< Suc i] @ [Suc i]" "[3 ..< Suc (Suc i)] = [3 ..< Suc i] @ [Suc i]" by auto
   have cong: "\<And> a b c d. a = c \<Longrightarrow> b = d \<Longrightarrow> a * b = c * (d :: 'a fract)" by auto
   define AB where "AB = (\<lambda> l. \<beta> l / \<alpha> l)"
   define ABP where "ABP = (\<lambda> l. AB l ^ (n (l - 1) - n i) * f (l - 1) ^ (\<delta> (l - 2) + \<delta> (l - 1)))"
   define PR where "PR = (\<Prod>l\<leftarrow>[3..<Suc i]. ABP l)"
   define PR2 where "PR2 = (\<Prod>l\<leftarrow>[3..<Suc i]. AB l)"
   from F0[of i]
   have "\<Theta> i * f i / \<gamma> (i + 1) = (
   ((- 1) ^ \<tau> i * (- 1) ^ \<sigma> (i + 1)) * (pow_int (f i) (int (\<delta> (i - 1)) - 1) *
     PR * f i /
     pow_int (f i) (1 - int (\<delta> i)) / ((\<Prod>l\<leftarrow>[3..<Suc i]. ABP l * AB l) *
         AB (Suc i) * f i ^ (\<delta> (i - 1) + \<delta> i))))"
     unfolding id prod_list.append map_append \<Theta>_def \<gamma>_def divide_prod_assoc
     by (simp add: field_simps power_add AB_def ABP_def PR_def)
   also have "(- 1 :: 'a fract) ^ \<tau> i * (- 1) ^ \<sigma> (i + 1) = (- 1) ^ (\<tau> i + \<sigma> (i + 1))"
     unfolding power_add by (auto simp: field_simps)
   also have "\<dots> = (- 1) ^ (n 1 + n i + i + 1)"
   proof (cases "i = 2")
     case True
     show ?thesis unfolding \<tau>_def \<sigma>_def True by (auto, rule minus_1_even_eqI, auto)
   next
     case False
     define a where "a = (\<lambda> l. n (l - 2) + n i)"
     define b where "b = (\<lambda> l. n (l - 1) + n i)"
     define c where "c = (\<Sum>l\<leftarrow>[3..<Suc i]. (a l * b l + n i))"
     define d where "d = c + (\<Sum>l\<leftarrow>[3..<i]. n (l - 1))"
     define e where "e = (n (i - 1) + n i + 1) * n i"
     have "(\<tau> i + \<sigma> (i + 1)) =
       ((\<Sum>l\<leftarrow>[3..<Suc i]. (a l * b l) + (a l + 1) * (b l + 1))) + (a (Suc i) + 1) * (b (Suc i) + 1)"
       unfolding \<sigma>_def \<tau>_def id a_def b_def sum_list_addf by simp
     also have "(\<Sum>l\<leftarrow>[3..<Suc i]. (a l * b l) + (a l + 1) * (b l + 1)) =
        (\<Sum>l\<leftarrow>[3..<Suc i]. 2 * a l * b l + (a l + b l) + 1)"
       by (rule arg_cong, rule map_cong, auto)
     also have "\<dots> = (\<Sum>l\<leftarrow>[3..<Suc i]. 2 * (a l * b l + n i) + (n (l - 1) + n (l - 2)) + 1)"
       by (simp add: field_simps a_def b_def)
     also have "\<dots> = 2 * c + (\<Sum>l\<leftarrow>[3..<Suc i]. (n (l - 1) + n (l - 2))) + length [3 ..< Suc i]"
       unfolding sum_list_addf c_def sum_list_const_mult sum_list_triv by simp
     also have "(\<Sum>l\<leftarrow>[3..<Suc i]. (n (l - 1) + n (l - 2)))
       = (\<Sum>l\<leftarrow>[3..<Suc i]. n (l - 1)) + (\<Sum>l\<leftarrow>[3..<Suc i]. n (l - 2))"
       by (simp add: sum_list_addf)
     also have "(\<Sum>l\<leftarrow>[3..<Suc i]. n (l - 2)) = (\<Sum>l\<leftarrow>3 # [4..<Suc i]. n (l - 2))"
       by (rule arg_cong, rule map_cong, insert i False, auto simp: upt_rec[of 3])
     also have "\<dots> = n 1 + (\<Sum>l\<leftarrow>[(Suc 3)..<Suc i]. n (l - 2))" by auto
     also have "(\<Sum>l\<leftarrow>[(Suc 3)..<Suc i]. n (l - 2)) = (\<Sum>l\<leftarrow>[3..<i]. n (l - 1))"
     proof (rule arg_cong[of _ _ sum_list], rule nth_equalityI, force, auto simp: nth_append, goal_cases)
       case (1 j)
       hence "i - 2 = Suc (Suc j)" by simp
       thus ?case by simp
     qed
     also have "(\<Sum>l\<leftarrow>[3..<Suc i]. n (l - 1)) = (\<Sum>l\<leftarrow>[3..<i] @ [i]. n (l - 1))"
       by (rule arg_cong, rule map_cong, insert i False, auto)
     finally have "\<tau> i + \<sigma> (i + 1) =
       2 * d + n (i - 1) + n 1 +  length [3..<Suc i] + (a (Suc i) + 1) * (b (Suc i) + 1)"
       by (simp add: d_def)
     also have "length [3 ..< Suc i] = i - 2" using i by auto
     also have "(a (Suc i) + 1) * (b (Suc i) + 1) = 2 * e + n (i - 1) + n i + 1" unfolding a_def b_def e_def
       by simp
     finally have id: "\<tau> i + \<sigma> (i + 1) = 2 * (d + n (i - 1) + e) + n 1 + (i - 2) + n i + 1"
       by simp
     show ?thesis
       by (rule minus_1_even_eqI, unfold id, insert i, auto)
   qed
   also have "(\<Prod>l\<leftarrow>[3..<Suc i]. ABP l * AB l) = PR * PR2"
     unfolding PR_def prod_list_multf PR2_def by simp
   also have "(pow_int (f i) (int (\<delta> (i - 1)) - 1) * PR * f i / pow_int (f i) (1 - int (\<delta> i))
     / (PR * PR2 * AB (Suc i) * f i ^ (\<delta> (i - 1) + \<delta> i))) =
     ((pow_int (f i) (int (\<delta> (i - 1)) - 1) * pow_int (f i) 1 * pow_int (f i) (int (\<delta> i) - 1)
     / pow_int (f i) (int (\<delta> (i - 1) + \<delta> i)))) * (PR / PR / (PR2 * AB (Suc i)))"
     (is "\<dots> = ?x * ?y")
     unfolding exp_pow_int[symmetric] by (simp add: pow_int_divide ac_simps)
   also have "?x = pow_int (f i) (-1)"
     unfolding pow_int_divide pow_int_add[OF ff0, symmetric] by simp
   also have "\<dots> = 1 / (f i)"
     unfolding pow_int_def by simp
   also have "PR / PR = 1"
   proof -
     have "PR \<noteq> 0" unfolding PR_def prod_list_zero_iff set_map
     proof
       assume "0 \<in> ABP ` set [3 ..< Suc i]"
       then obtain j where j: "3 \<le> j" "j < Suc i" and 0: "ABP j = 0" by auto
       with i have jk: "j \<le> k" and j1: "j - 1 \<noteq> 0" "j - 1 < k" by auto
       hence 1: "\<alpha> j \<noteq> 0" "f (j - 1) \<noteq> 0" using \<alpha>0 f0 by auto
       with 0 have "AB j = 0" unfolding ABP_def by simp
       from this[unfolded AB_def] 1(1) \<beta>0[of j] show False by auto
     qed
     thus ?thesis by simp
   qed
   also have "PR2 * AB (Suc i) = (\<Prod>l\<leftarrow>[3..<Suc (Suc i)]. AB l)" unfolding id PR2_def by auto
   also have "1 / \<dots> = inverse \<dots>" by (simp add: inverse_eq_divide)
   also have "\<dots> = (\<Prod>l\<leftarrow>[3..<Suc (Suc i)]. \<alpha> l / \<beta> l)" unfolding AB_def
     inverse_prod_list map_map o_def
     by (auto cong: map_cong)
   finally show ?thesis by simp
 qed
 
 lemma B_theorem_3: "h i = \<Theta> i * f i" "h i = ff (lead_coeff (H i))"
 proof -
   have "\<Theta> i * f i = \<Theta> i * f i / \<gamma> (i + 1)"
     using B_theorem_2[of "i + 1"] i by auto
   also have "\<dots> = (- 1) ^ (n 1 + n i + i + 1) / f i *
     (\<Prod>l\<leftarrow>[3..<Suc (Suc i)]. \<alpha> l / \<beta> l)" by (rule B_theorem_3_main)
   also have "\<dots> = h i" using B_eq_17[of i] i by simp
   finally show "h i = \<Theta> i * f i" ..
   thus "h i = ff (lead_coeff (H i))" using B_theorem_3_b by auto
 qed
 end
 
 lemma h0: "i \<le> k \<Longrightarrow> h i \<noteq> 0"
 proof (induct i)
   case (Suc i)
   thus ?case unfolding h.simps[of "Suc i"] using f0 by (auto simp del: h.simps)
 qed auto
 
 lemma deg_G12: "degree G1 \<ge> degree G2" using n12
   unfolding n F1 F2 by auto
 
 lemma R0: shows "R 0 = [: resultant G1 G2 :]"
 proof(cases "n 2 = 0")
   case True
   hence d:"degree G2 = 0" unfolding n F2 by auto
   from degree0_coeffs[OF d] F2 F12 obtain a where
     G2: "G2 = [:a:]" and a: "a \<noteq> 0" by auto
   have "sdiv_poly [:a * a ^ degree G1:] a = [:a ^ degree G1:]" using a
     unfolding sdiv_poly_def by auto
   note dp = this
   show ?thesis using G2 F12
     unfolding R_def \<delta> n F1 F2 Suc_1 by (auto split:if_splits simp:mult.commute dp)
 next
   case False
   from False n12 have d:"degree G2 \<noteq> 0" "degree G2 \<le> degree G1" unfolding n F2 F1 by auto
   from False have "R 0 = subresultant 0 G1 G2" unfolding R_def by simp
   also have "\<dots> = [: resultant G1 G2 :]" unfolding subresultant_resultant by simp
   finally show ?thesis .
 qed
 
 context
   fixes div_exp :: "'a \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
   assumes div_exp_sound: "div_exp_sound div_exp"
 begin
 
 interpretation div_exp_sound div_exp by (rule div_exp_sound)
 
 lemma subresultant_prs_main: assumes "subresultant_prs_main Gi_1 Gi hi_1 = (Gk, hk)"
   and "F i = ffp Gi"
   and "F (i - 1) = ffp Gi_1"
   and "h (i - 1) = ff hi_1"
   and "i \<ge> 3" "i \<le> k"
 shows "F k = ffp Gk \<and> h k = ff hk \<and> (\<forall> j. i \<le> j \<longrightarrow> j \<le> k \<longrightarrow> F j \<in> range ffp \<and> \<beta> (Suc j) \<in> range ff)"
 proof -
   obtain m where m: "m = k - i" by auto
   show ?thesis using m assms
   proof (induct m arbitrary: Gi_1 Gi hi_1 i rule: less_induct)
     case (less m Gi_1 Gi hi_1 i)
     note IH = less(1)
     note m = less(2)
     note res = less(3)
     note id = less(4-6)
     note i = less(7-8)
     let ?pmod = "pseudo_mod Gi_1 Gi"
     let ?ni = "degree Gi"
     let ?ni_1 = "degree Gi_1"
     let ?gi = "lead_coeff Gi"
     let ?gi_1 = "lead_coeff Gi_1"
     let ?d1 = "?ni_1 - ?ni"
     obtain hi where hi: "hi = div_exp ?gi hi_1 ?d1" by auto
     obtain divisor where div: "divisor = (-1) ^ (?d1 + 1) * ?gi_1 * (hi_1 ^ ?d1)" by auto
     obtain G1_p1 where G1_p1: "G1_p1 = sdiv_poly ?pmod divisor" by auto
     note res = res[unfolded subresultant_prs_main.simps[of Gi_1] Let_def,
       folded hi, folded div, folded G1_p1]
     have h_i: "h i = f i ^ \<delta> (i - 1) / h (i - 1) ^ (\<delta> (i - 1) - 1)" unfolding h.simps[of i] using i by simp
     have hi_ff: "h i \<in> range ff" using B_theorem_3[OF _ i(2)] i by auto
     have d1: "\<delta> (i - 1) = ?d1" unfolding \<delta> n using id(1,2) using i by simp
     have fi: "f i = ff ?gi" unfolding f id by simp
     have fi1: "f (i - 1) = ff ?gi_1" unfolding f id by simp
     have eq': "h i = ff (lead_coeff Gi) ^ \<delta> (i - 1) / ff hi_1 ^ (\<delta> (i - 1) - 1)"
       unfolding h_i fi id ..
     have idh: "h i = ff hi" using hi_ff h_i fi id
       unfolding hi d1[symmetric]
       by (subst div_exp[of ?gi "\<delta> (i - 1)" hi_1], unfold eq'[symmetric], insert assms, blast+)
     have "\<beta> (Suc i) = (- 1) ^ (\<delta> (i - 1) + 1) * f (i - 1) * h (i - 1) ^ \<delta> (i - 1)"
       using \<beta>i[of "Suc i"] i by auto
     also have "\<dots> = ff ((- 1) ^ (\<delta> (i - 1) + 1) * lead_coeff Gi_1 * hi_1 ^ \<delta> (i - 1))"
       unfolding id f by (simp add: hom_distribs)
     also have "\<dots> \<in> range ff" by blast
     finally have beta: "\<beta> (Suc i) \<in> range ff" .
     have pm: "pseudo_mod (F (i - 1)) (F i) = ffp ?pmod"
       unfolding to_fract_hom.pseudo_mod_hom[symmetric] id by simp
     have eq: "(?pmod = 0) = (i = k)"
       using pm i pmod[of "Suc i"] F0[of "Suc i"] i \<beta>0[of "Suc i"] by auto
     show ?case
     proof (cases "i = k")
       case True
       with res eq have res: "Gk = Gi" "hk = hi" by auto
       with pmod
       have "F k = ffp Gk \<and> h k = ff hk" unfolding res idh[symmetric] id[symmetric] True by auto
       thus ?thesis using beta unfolding True by auto
     next
       case False
       with res eq have res:
          "subresultant_prs_main Gi G1_p1 hi = (Gk, hk)" by auto
       from m False i have m: "m - 1 < m" "m - 1 = k - Suc i" by auto
       have si: "Suc i - 1 = i" and ii: "3 \<le> Suc i" "Suc i \<le> k" and iii: "3 \<le> Suc i" "Suc i \<le> Suc k"
         using False i by auto
       have *: "(\<forall>j\<ge>Suc i. j \<le> k \<longrightarrow> F j \<in> range ffp \<and> \<beta> (Suc j) \<in> range ff) = (\<forall>j\<ge>i. j \<le> k \<longrightarrow> F j \<in> range ffp  \<and> \<beta> (Suc j) \<in> range ff)"
         by (rule for_all_Suc, insert id(1) beta, auto)
       show ?thesis
       proof (rule IH[OF m res, unfolded si, OF _ id(1) idh ii, unfolded *])
         have F_ffp: "F (Suc i) \<in> range ffp" using fundamental_theorem_eq_4[OF ii, symmetric] B_theorem_2[OF iii] by auto
         from pmod[OF iii] have "smult (\<beta> (Suc i)) (F (Suc i)) = pseudo_mod (F (i - 1)) (F i)"
           by simp
         from arg_cong[OF this, of "\<lambda> x. smult (inverse (\<beta> (Suc i))) x"]
         have Fsi: "F (Suc i) = smult (inverse (\<beta> (Suc i))) (pseudo_mod (F (i - 1)) (F i))"
           using \<beta>0[of "Suc i"] by auto
         show "F (Suc i) = ffp G1_p1"
         proof (rule smult_inverse_sdiv_poly[OF F_ffp Fsi G1_p1 _ pm])
           from i ii have iv: "4 \<le> Suc i" "Suc i \<le> Suc k" by auto
           have *: "Suc i - 2 = i - 1" by auto
           show "\<beta> (Suc i) = ff divisor" unfolding \<beta>i[OF iv] div d1 * fi1
             using id by (simp add: hom_distribs)
         qed
       qed
     qed
   qed
 qed
 
 lemma subresultant_prs: assumes res: "subresultant_prs G1 G2 = (Gk, hk)"
   shows "F k = ffp Gk \<and> h k = ff hk \<and> (i \<noteq> 0 \<longrightarrow> F i \<in> range ffp) \<and> (3 \<le> i \<longrightarrow> i \<le> Suc k \<longrightarrow> \<beta> i \<in> range ff)"
 proof -
   let ?pmod = "pseudo_mod G1 G2"
   have pm: "pseudo_mod (F 1) (F 2) = ffp ?pmod"
     unfolding to_fract_hom.pseudo_mod_hom[symmetric] F1 F2 by simp
   let ?g2 = "lead_coeff G2"
   let ?n2 = "degree G2"
   obtain d1 where d1: "d1 = degree G1 - ?n2" by auto
   obtain h2 where h2: "h2 = ?g2 ^ d1" by auto
   have "(?pmod = 0) = (pseudo_mod (F 1) (F 2) = 0)" using pm by auto
   also have "\<dots> = (k < 3)" using k2 pmod[of 3] F0[of 3] \<beta>0[of 3] by auto
   finally have eq: "?pmod = 0 \<longleftrightarrow> k = 2" using k2 by linarith
   note res = res[unfolded subresultant_prs_def Let_def eq, folded d1, folded h2]
   have idh2: "h 2 = ff h2" unfolding h2 d1 h.simps[of 2] \<delta> n F1
     using F2 by (simp add: numeral_2_eq_2 f hom_distribs)
   have main: "F k = ffp Gk \<and> h k = ff hk \<and> (i \<ge> 3 \<longrightarrow> i \<le> k \<longrightarrow> F i \<in> range ffp \<and> \<beta> (Suc i) \<in> range ff)" for i
   proof (cases "k = 2")
     case True
     with res have "Gk = G2" "hk = h2" by auto
     thus ?thesis using True idh2 F2 by auto
   next
     case False
     hence "(k = 2) = False" by simp
     note res = res[unfolded this if_False]
     have F_2: "F (3 - 1) = ffp G2" using F2 by simp
     have h2: "h (3 - 1) = ff h2" using idh2 by simp
     have n2: "degree G2 = n (3 - 1)" unfolding n using F2 by simp
     from False k2 have k3: "3 \<le> k" by auto
     have "F k = ffp Gk \<and> h k = ff hk \<and> (\<forall>j\<ge>3. j \<le> k \<longrightarrow> F j \<in> range ffp \<and> \<beta> (Suc j) \<in> range ff)"
     proof (rule subresultant_prs_main[OF res _ F_2 h2 le_refl k3])
       let ?pow = "(- 1) ^ (\<delta> 1 + 1) :: 'a fract"
       from pmod[of 3] k3
       have "smult (\<beta> 3) (F 3) = pseudo_mod (F 1) (F 2)" by simp
       also have "\<dots> = pseudo_mod (ffp G1) (ffp G2)" using F1 F2 by auto
       also have "\<dots> = ffp (pseudo_mod G1 G2)" unfolding to_fract_hom.pseudo_mod_hom by simp
       also have "\<beta> 3 = (- 1) ^ (\<delta> 1 + 1)" unfolding \<beta>3 by simp
       finally have "smult ((- 1) ^ (\<delta> 1 + 1)) (F 3) = ffp (pseudo_mod G1 G2)" by simp
       also have "smult ((- 1) ^ (\<delta> 1 + 1)) (F 3) = [: ?pow :] * F 3"
         by simp
       also have "[: ?pow :] = (- 1) ^ (\<delta> 1 + 1)" by (unfold hom_distribs, simp)
       finally have "(- 1) ^ (\<delta> 1 + 1) * F 3 = ffp (pseudo_mod G1 G2)" by simp
       from arg_cong[OF this, of "\<lambda> i. (- 1) ^ (\<delta> 1 + 1) * i"]
       have "F 3 = (- 1) ^ (\<delta> 1 + 1) * ffp (pseudo_mod G1 G2)" by simp
       also have "\<delta> 1 = d1" unfolding \<delta> n d1 using F1 F2 by (simp add: numeral_2_eq_2)
       finally show F3: "F 3 = ffp ((- 1) ^ (d1 + 1) * pseudo_mod G1 G2)" by (simp add: hom_distribs)
     qed
     thus ?thesis by auto
   qed
   show ?thesis
   proof (intro conjI impI)
     assume "i \<noteq> 0"
     then consider (12) "i = 1 \<or> i = 2" | (i3) "i \<ge> 3 \<and> i \<le> k" | (ik) "i > k" by linarith
     thus "F i \<in> range ffp"
     proof cases
       case 12
       thus ?thesis using F1 F2 by auto
     next
       case i3
       thus ?thesis using main by auto
     next
       case ik
       hence "F i = 0" using F0 by auto
       thus ?thesis by simp
     qed
   next
     assume "3 \<le> i" and "i \<le> Suc k"
     then consider (3) "i = 3" | (4) "3 \<le> i - 1" "i - 1 \<le> k" by linarith
     thus "\<beta> i \<in> range ff"
     proof (cases)
       case 3
       have "\<beta> i = ff ((- 1) ^ (\<delta> 1 + 1))" unfolding 3 \<beta>3 by (auto simp: hom_distribs)
       thus ?thesis by blast
     next
       case 4
       with main[of "i - 1"] show ?thesis by auto
     qed
   qed (insert main, auto)
 qed
 
 lemma resultant_impl_main: "resultant_impl_main G1 G2 = resultant G1 G2"
 proof -
   from F0[of 2] F12(2) have k2: "k \<ge> 2" by auto
   obtain Gk hk where sub: "subresultant_prs G1 G2 = (Gk, hk)" by force
   from subresultant_prs[OF this] have *: "F k = ffp Gk" "h k = ff hk" by auto
   have "resultant_impl_main G1 G2 = (if degree (F k) = 0 then hk else 0)"
     unfolding resultant_impl_main_def sub split * using F2 F12 by auto
   also have "\<dots> = resultant G1 G2"
   proof (cases "n k = 0")
     case False
     with fundamental_theorem_eq_7[of 0] show ?thesis unfolding n[of k] * R0 by auto
   next
     case True
     from H_def[of k, unfolded True] have R: "R 0 = H k" by simp
     show ?thesis
     proof (cases "k = 2")
       case False
       with k2 have k3: "k \<ge> 3" by auto
       from B_theorem_3[OF k3] R0 R have "h k = ff (resultant G1 G2)" by simp
       from this[folded *] * have "hk = resultant G1 G2" by simp
       with True show ?thesis unfolding n by auto
     next
       case 2: True
       have id: "(if degree (F k) = 0 then hk else 0) = hk" using True unfolding n by simp
       from F0[of 3, unfolded 2] have "F 3 = 0" by simp
       with pmod[of 3, unfolded 2] \<beta>0[of 3] have "pseudo_mod (F 1) (F 2) = 0" by auto
       hence pm: "pseudo_mod G1 G2 = 0" unfolding F1 F2 to_fract_hom.pseudo_mod_hom by simp
       from subresultant_prs_def[of G1 G2, unfolded sub Let_def this]
       have id: "Gk = G2" "hk = lead_coeff G2 ^ (degree G1 - degree G2)" by auto
       from F12 F1 F2 have "G1 \<noteq> 0" "G2 \<noteq> 0" by auto
       from resultant_pseudo_mod_0[OF pm deg_G12 this]
       have res: "resultant G1 G2 = (if degree G2 = 0 then lead_coeff G2 ^ degree G1 else 0)"
         by simp
       from True[unfolded 2 n F2] have "degree G2 = 0" by simp
       thus ?thesis unfolding res 2 F2 id by simp
     qed
   qed
   finally show ?thesis .
 qed
 end
 end
 
 text \<open>At this point, we have soundness of the resultant-implementation, provided that we can
   instantiate the locale by constructing suitable values of F, b, h, etc. Now we show the
   existence of suitable locale parameters by constructively computing them.\<close>
 
 context
   fixes G1 G2 :: "'a :: idom_divide poly"
 begin
 
 private function F and b and h where "F i = (if i = (0 :: nat) then 1
   else if i = 1 then map_poly to_fract G1 else if i = 2 then map_poly to_fract G2
   else (let G = pseudo_mod (F (i - 2)) (F (i - 1))
     in if F (i - 1) = 0 \<or> G = 0 then 0 else smult (inverse (b i)) G))"
 | "b i = (if i \<le> 2 then 1 else
    if i = 3 then (- 1) ^ (degree (F 1) - degree (F 2) + 1)
    else if F (i - 2) = 0 then 1 else (- 1) ^ (degree (F (i - 2)) - degree (F (i - 1)) + 1) * lead_coeff (F (i - 2)) *
          h (i - 2) ^ (degree (F (i - 2)) - degree (F (i - 1))))"
 | "h i = (if (i \<le> 1) then 1 else if i = 2 then (lead_coeff (F 2) ^ (degree (F 1) - degree (F 2))) else
     if F i = 0 then 1 else (lead_coeff (F i) ^ (degree (F (i - 1)) - degree (F i)) / (h (i - 1) ^ ((degree (F (i - 1)) - degree (F i)) - 1))))"
   by pat_completeness auto
 termination
 proof
   show "wf (measure (case_sum (\<lambda> fi. 3 * fi +1)  (case_sum (\<lambda> bi. 3 * bi) (\<lambda> hi. 3 * hi + 2))))" by simp
 qed (auto simp: termination_simp)
 
 declare h.simps[simp del] b.simps[simp del] F.simps[simp del]
 
 private lemma Fb0: assumes base: "G1 \<noteq> 0" "G2 \<noteq> 0"
   shows "(F i = 0 \<longrightarrow> F (Suc i) = 0) \<and> b i \<noteq> 0 \<and> h i \<noteq> 0"
 proof (induct i rule: less_induct)
   case (less i)
   note * [simp] = F.simps[of i] b.simps[of i] h.simps[of i]
   consider (0) "i = 0" | (1) "i = 1" | (2) "i \<ge> 2" by linarith
   thus ?case
   proof cases
     case 0
     show ?thesis unfolding * unfolding 0 by simp
   next
     case 1
     show ?thesis unfolding * unfolding 1 using assms by simp
   next
     case 2
     have F: "F i = 0 \<Longrightarrow> F (Suc i) = 0" unfolding F.simps[of "Suc i"] using 2 by simp
     from assms have F2: "F 2 \<noteq> 0" unfolding F.simps[of 2] by simp
     from 2 have "i - 1 < i" "i - 2 < i" by auto
     note IH = less[OF this(1)] less[OF this(2)]
     hence b: "b (i - 1) \<noteq> 0" and h: "h (i - 1) \<noteq> 0" "h (i - 2) \<noteq> 0" by auto
     from h have hi: "h i \<noteq> 0" unfolding h.simps[of i] using 2 F2 by auto
     have bi: "b i \<noteq> 0" unfolding b.simps[of i] using h(2) by auto
     show ?thesis using hi bi F by blast
   qed
 qed
 
 private definition "k = (LEAST i. F (Suc i) = 0)"
 
 private lemma k_exists: "\<exists> i. F (Suc i) = 0"
 proof -
   obtain n i where "i \<ge> 3" "length (coeffs (F (Suc i))) = n" by blast
   thus ?thesis
   proof (induct n arbitrary: i rule: less_induct)
     case (less n i)
     let ?ii = "Suc (Suc i)"
     let ?i = "Suc i"
     from less(2) have i: "?i \<ge> 3" by auto
     let ?mod = "pseudo_mod (F (?ii - 2)) (F ?i)"
     have Fi: "F ?ii = (if F ?i = 0 \<or> ?mod = 0 then 0 else smult (inverse (b ?ii)) ?mod)"
       unfolding F.simps[of ?ii] using i by auto
     show ?case
     proof (cases "F ?ii = 0")
       case False
       hence Fi: "F ?ii = smult (inverse (b ?ii)) ?mod" and mod: "?mod \<noteq> 0" and Fi1: "F ?i \<noteq> 0"
         unfolding Fi by auto
       from pseudo_mod[OF Fi1, of "F (?ii - 2)"] mod have "degree ?mod < degree (F ?i)" by simp
       hence deg: "degree (F ?ii) < degree (F ?i)" unfolding Fi by auto
       hence "length (coeffs (F ?ii)) < length (coeffs (F ?i))" unfolding degree_eq_length_coeffs by auto
       from less(1)[OF _ i refl, folded less(3), OF this] show ?thesis by auto
     qed blast
   qed
 qed
 
 private lemma k: "F (Suc k) = 0" "i < k \<Longrightarrow> F (Suc i) \<noteq> 0"
 proof -
   show "F (Suc k) = 0" unfolding k_def using k_exists by (rule LeastI2_ex)
   assume "i < k" from not_less_Least[OF this[unfolded k_def]] show "F (Suc i) \<noteq> 0" .
 qed
 
 lemma enter_subresultant_prs: assumes len: "length (coeffs G1) \<ge> length (coeffs G2)"
   and G2: "G2 \<noteq> 0"
 shows "\<exists> F n d f k b. subresultant_prs_locale2 F n d f k b G1 G2"
 proof (intro exI)
   from G2 len have G1: "G1 \<noteq> 0" by auto
   from len have deg_le: "degree (F 2) \<le> degree (F 1)"
     by (simp add: F.simps degree_eq_length_coeffs)
   from G2 G1 have F1: "F 1 \<noteq> 0" and F2: "F 2 \<noteq> 0" by (auto simp: F.simps)
   note Fb0 = Fb0[OF G1 G2]
   interpret s: subresultant_prs_locale F "\<lambda> i. degree (F i)" "\<lambda> i. degree (F i) - degree (F (Suc i))"
     "\<lambda> i. lead_coeff (F i)" k b G1 G2
   proof (unfold_locales, rule refl, rule refl, rule refl, rule deg_le, rule F1, rule F2)
     from k(1) F1 have k0: "k \<noteq> 0" by (cases k, auto)
     show Fk: "(F i = 0) = (k < i)" for i
     proof
       assume "F i = 0" with k(2)[of "i - 1"]
       have "\<not> (i - 1 < k)" by (cases i, auto simp: F.simps)
       thus "i > k" using k0 by auto
     next
       assume "i > k"
       then obtain j l where i: "i = j + l" and "j = Suc k" and "l = i - Suc k" and Fj: "F j = 0" using k(1)
         by auto
       with F1 F2 k0 have j2: "j \<ge> 2" by auto
       show "F i = 0" unfolding i
       proof (induct l)
         case (Suc l)
         thus ?case unfolding F.simps[of "j + Suc l"] using j2 by auto
       qed (auto simp: Fj)
     qed
     show b: "b i \<noteq> 0" for i using Fb0 by blast
     show "F 1 = map_poly to_fract G1" unfolding F.simps[of 1] by simp
     show "F 2 = map_poly to_fract G2" unfolding F.simps[of 2] by simp
     fix i
     let ?mod = "pseudo_mod (F (i - 2)) (F (i - 1))"
     assume i: "3 \<le> i" "i \<le> Suc k"
     from Fk[of "i - 1"] i have "F (i - 1) \<noteq> 0" by auto
     with i have Fi: "F i = (if ?mod = 0 then 0 else smult (inverse (b i)) ?mod)" unfolding F.simps[of i]
       Let_def by simp
     show "smult (b i) (F i) = ?mod"
     proof (cases "?mod = 0")
       case True
       thus ?thesis unfolding Fi by simp
     next
       case False
       with Fi have Fi: "F i = smult (inverse (b i)) ?mod" by simp
       from arg_cong[OF this, of "smult (b i)"] b[of i] show ?thesis by simp
     qed
   qed
   note s.h.simps[simp del]
   show "subresultant_prs_locale2 F (\<lambda> i. degree (F i)) (\<lambda> i. degree (F i) - degree (F (Suc i)))
     (\<lambda> i. lead_coeff (F i)) k b G1 G2"
   proof
     show "b 3 = (- 1) ^ (degree (F 1) - degree (F (Suc 1)) + 1)" unfolding b.simps numeral_2_eq_2 by simp
     fix i
     assume i: "4 \<le> i" "i \<le> Suc k"
     with s.F0[of "i - 2"] have "F (i - 2) \<noteq> 0" by auto
     hence bi: "b i = (- 1) ^ (degree (F (i - 2)) - degree (F (i - 1)) + 1) * lead_coeff (F (i - 2)) *
                     h (i - 2) ^ (degree (F (i - 2)) - degree (F (i - 1)))" unfolding b.simps
       using i by auto
     have "i < k \<Longrightarrow> s.h i = h i" for i
     proof (induct i)
       case 0
       thus ?case by (simp add: h.simps s.h.simps)
     next
       case (Suc i)
       from Suc(2) s.F0[of "Suc i"] have "F (Suc i) \<noteq> 0" by auto
       with Suc show ?case unfolding h.simps[of "Suc i"] s.h.simps[of "Suc i"] numeral_2_eq_2 by simp
     qed
     hence sh: "s.h (i - 2) = h (i - 2)" using i by simp
     from i have *: "Suc (i - 2) = i - 1" by auto
     show "b i = (- 1) ^ (degree (F (i - 2)) - degree (F (Suc (i - 2))) + 1) * lead_coeff (F (i - 2)) *
          s.h (i - 2) ^ (degree (F (i - 2)) - degree (F (Suc (i - 2))))"
       unfolding sh bi * ..
   qed
 qed
 end
 
 text \<open>Now we obtain the soundness lemma outside the locale.\<close>
 
 context div_exp_sound
 begin
 
 lemma resultant_impl_main: assumes len: "length (coeffs G1) \<ge> length (coeffs G2)"
   shows "resultant_impl_main G1 G2 = resultant G1 G2"
 proof (cases "G2 = 0")
   case G2: False
   from enter_subresultant_prs[OF len G2] obtain F n d f k b
     where "subresultant_prs_locale2 F n d f k b G1 G2" by auto
   interpret subresultant_prs_locale2 F n d f k b G1 G2 by fact
   show ?thesis by (rule resultant_impl_main, standard)
 next
   case G2: True
   show ?thesis unfolding G2
     resultant_impl_main_def using resultant_const(2)[of G1 0] by simp
 qed
 
 theorem resultant_impl: "resultant_impl = resultant"
 proof (intro ext)
   fix f g :: "'a poly"
   show "resultant_impl f g = resultant f g"
   proof (cases "length (coeffs f) \<ge> length (coeffs g)")
     case True
     thus ?thesis unfolding resultant_impl_def resultant_impl_main[OF True] by auto
   next
     case False
     hence "length (coeffs g) \<ge> length (coeffs f)" by auto
     from resultant_impl_main[OF this]
     show ?thesis unfolding resultant_impl_def resultant_swap[of f g] using False
       by (auto simp: Let_def)
   qed
 qed
 end
 
 subsection \<open>Code Equations\<close>
 
 text \<open>In the following code-equations, we only compute the required values, e.g., $h_k$
   is not required if $n_k > 0$, we compute $(-1)^{\ldots} * \ldots$ via a case-analysis,
   and we perform special cases for $\delta_i = 1$, which is the most frequent case.\<close>
 
 context div_exp_param
 begin
 
 partial_function(tailrec) subresultant_prs_main_impl where
   "subresultant_prs_main_impl f Gi_1 Gi ni_1 d1_1 hi_2 = (let
      gi_1 = lead_coeff Gi_1;
      ni = degree Gi;
      hi_1 = (if d1_1 = 1 then gi_1 else div_exp gi_1 hi_2 d1_1);
      d1 = ni_1 - ni;
      pmod = pseudo_mod Gi_1 Gi
     in (if pmod = 0 then f (Gi, (if d1 = 1 then lead_coeff Gi
       else div_exp (lead_coeff Gi) hi_1 d1)) else
     let
        gi = lead_coeff Gi;
        divisor = (-1) ^ (d1 + 1) * gi_1 * (hi_1 ^ d1) ;
        Gi_p1 = sdiv_poly pmod divisor
        in subresultant_prs_main_impl f Gi Gi_p1 ni d1 hi_1))"
 
 definition subresultant_prs_impl where
   "subresultant_prs_impl f G1 G2 = (let
     pmod = pseudo_mod G1 G2;
     n2 = degree G2;
     delta_1 = (degree G1 - n2);
     g2 = lead_coeff G2;
     h2 = g2 ^ delta_1
     in if pmod = 0 then f (G2,h2) else let
       G3 = (- 1) ^ (delta_1 + 1) * pmod;
       g3 = lead_coeff G3;
       n3 = degree G3;
       d2 = n2 - n3;
       pmod = pseudo_mod G2 G3
     in if pmod = 0 then f (G3, if d2 = 1 then g3 else div_exp g3 h2 d2)
     else let divisor = (- 1) ^ (d2 + 1) * g2 * h2 ^ d2; G4 = sdiv_poly pmod divisor
          in subresultant_prs_main_impl f G3 G4 n3 d2 h2
     )"
 end
 
 context div_exp_sound
 begin
 
 lemma div_exp_1: "div_exp g h (Suc 0) = g"
   using div_exp[of g "Suc 0" h] by simp
 
 lemma subresultant_prs_impl: "subresultant_prs_impl f G1 G2 = f (subresultant_prs G1 G2)"
 proof -
   define h2 where "h2 = lead_coeff G2 ^ (degree G1 - degree G2)"
   define G3 where "G3 = ((- 1) ^ (degree G1 - degree G2 + 1) * pseudo_mod G1 G2)"
   define G4 where "G4 = sdiv_poly (pseudo_mod G2 G3)
        ((- 1) ^ (degree G2 - degree G3 + 1) * lead_coeff G2 *
         h2 ^ (degree G2 - degree G3))"
   define d2 where "d2 = degree G2 - degree G3"
   have dl1: "(if d = 1 then (g :: 'a) else div_exp g h d) = div_exp g h d" for d g h
     by (cases "d = 1", auto simp: div_exp_1)
   show ?thesis
     unfolding subresultant_prs_impl_def subresultant_prs_def Let_def
       subresultant_prs_main.simps[of G2]
       if_distrib[of f] dl1
   proof (rule if_cong[OF refl refl if_cong[OF refl refl]], unfold h2_def[symmetric],
     unfold G3_def[symmetric], unfold G4_def[symmetric], unfold d2_def[symmetric])
     note simp = subresultant_prs_main_impl.simps[of f] subresultant_prs_main.simps
     show "subresultant_prs_main_impl f G3 G4 (degree G3) d2 h2 =
       f (subresultant_prs_main G3 G4 (div_exp (lead_coeff G3) h2 d2))"
     proof (induct G4 arbitrary: G3 d2 h2 rule: wf_induct[OF wf_measure[of degree]])
       case (1 G4 G3 d2 h2)
       let ?M = "pseudo_mod G3 G4"
       show ?case
       proof (cases "?M = 0")
         case True
         thus ?thesis unfolding simp[of G3] Let_def dl1 by simp
       next
         case False
         hence id: "(?M = 0) = False" by auto
         let ?c = "((- 1) ^ (degree G3 - degree G4 + 1) * lead_coeff G3 *
             (div_exp (lead_coeff G3) h2 d2) ^ (degree G3 - degree G4))"
         let ?N = "sdiv_poly ?M ?c"
         show ?thesis
         proof (cases "G4 = 0")
           case G4: False
           have "degree ?N \<le> degree ?M" unfolding sdiv_poly_def by (rule degree_map_poly_le)
           also have "\<dots> < degree G4" using pseudo_mod[OF G4, of G3] False by auto
           finally show ?thesis unfolding simp[of G3] Let_def id if_False dl1
             by (intro 1(1)[rule_format], auto)
         next
           case 0: True
           with False have "G3 \<noteq> 0" by auto
           show ?thesis unfolding 0 unfolding simp[of G3] Let_def unfolding dl1 simp[of 0] by simp
         qed
       qed
     qed
   qed
 qed
 
 definition
   "resultant_impl_rec = subresultant_prs_main_impl (\<lambda> (Gk,hk). if degree Gk = 0 then hk else 0)"
 definition 
   "resultant_impl_start = subresultant_prs_impl (\<lambda> (Gk,hk). if degree Gk = 0 then hk else 0)"
 
 lemma resultant_impl_start_code:
   "resultant_impl_start G1 G2 =
      (let pmod = pseudo_mod G1 G2;
           n2 = degree G2;
           n1 = degree G1;
           g2 = lead_coeff G2;
           d1 = n1 - n2
          in if pmod = 0 then if n2 = 0 then if d1 = 0 then 1 else if d1 = 1 then g2 else g2 ^ d1 else 0
             else let
                  G3 = if even d1 then - pmod else pmod;
                  n3 = degree G3;
                  pmod = pseudo_mod G2 G3
                  in if pmod = 0
                     then if n3 = 0 then
                      let d2 = n2 - n3;
                          g3 = lead_coeff G3
                         in (if d2 = 1 then g3 else
                             div_exp g3 (if d1 = 1 then g2 else g2 ^ d1) d2) else 0
                     else let
                            h2 = (if d1 = 1 then g2 else g2 ^ d1);
                            d2 = n2 - n3;
                            divisor = (if d2 = 1 then g2 * h2 else if even d2 then - g2 * h2 ^ d2 else g2 * h2 ^ d2);
                            G4 = sdiv_poly pmod divisor
                          in resultant_impl_rec G3 G4 n3 d2 h2)"
 proof -
   obtain d1 where d1: "degree G1 - degree G2 = d1" by auto
   have id1: "(if even d1 then - pmod else pmod) = (-1)^ (d1 + 1) * (pmod :: 'a poly)" for pmod by simp
   have id3: "(if d2 = 1 then g2 * h2 else if even d2 then - g2 * h2 ^ d2 else g2 * h2 ^ d2) =
     ((- 1) ^ (d2 + 1) * g2 * h2 ^ d2)"
     for d2 and g2 h2 :: 'a by auto
   show ?thesis
     unfolding resultant_impl_start_def subresultant_prs_impl_def resultant_impl_rec_def[symmetric] Let_def split
     unfolding d1
     unfolding id1
     unfolding id3
     by (rule if_cong[OF refl if_cong if_cong], auto simp: power2_eq_square)
 qed
 
 lemma resultant_impl_rec_code:
   "resultant_impl_rec Gi_1 Gi ni_1 d1_1 hi_2 = (
     let ni = degree Gi;
         pmod = pseudo_mod Gi_1 Gi
      in
      if pmod = 0
         then if ni = 0
           then
             let
               d1 = ni_1 - ni;
               gi = lead_coeff Gi
             in if d1 = 1 then gi else
               let gi_1 = lead_coeff Gi_1;
                   hi_1 = (if d1_1 = 1 then gi_1 else div_exp gi_1 hi_2 d1_1) in
                 div_exp gi hi_1 d1
           else 0
         else let
            d1 = ni_1 - ni;
            gi_1 = lead_coeff Gi_1;
            hi_1 = (if d1_1 = 1 then gi_1 else div_exp gi_1 hi_2 d1_1);
            divisor = if d1 = 1 then gi_1 * hi_1 else if even d1 then - gi_1 * hi_1 ^ d1 else gi_1 * hi_1 ^ d1;
            Gi_p1 = sdiv_poly pmod divisor
        in resultant_impl_rec Gi Gi_p1 ni d1 hi_1)"
   unfolding resultant_impl_rec_def subresultant_prs_main_impl.simps[of _ Gi_1] split Let_def
   unfolding resultant_impl_rec_def[symmetric]
   by (rule if_cong[OF _ if_cong _], auto)
 
 lemma resultant_impl_main_code: "resultant_impl_main G1 G2 =
   (if G2 = 0 then if degree G1 = 0 then 1 else 0
      else resultant_impl_start G1 G2)"
   unfolding resultant_impl_main_def
    resultant_impl_start_def subresultant_prs_impl by simp
 
 lemma resultant_impl_code: "resultant_impl f g =
   (if length (coeffs f) \<ge> length (coeffs g) then resultant_impl_main f g
      else let res = resultant_impl_main g f in
       if even (degree f) \<or> even (degree g) then res else - res)"
   unfolding resultant_impl_def resultant_impl_def ..
 
 lemma resultant_code: "resultant = resultant_impl" 
   using resultant_impl by fastforce
 
 lemmas resultant_code_lemmas = 
   resultant_impl_code 
   resultant_impl_main_code
   resultant_impl_start_code
   resultant_impl_rec_code
 end
 
 global_interpretation div_exp_Lazard: div_exp_sound "dichotomous_Lazard :: 'a :: factorial_ring_gcd \<Rightarrow> _" 
   defines 
     resultant_impl_Lazard = div_exp_Lazard.resultant_impl and
     resultant_impl_main_Lazard = div_exp_Lazard.resultant_impl_main and
     resultant_impl_start_Lazard = div_exp_Lazard.resultant_impl_start and
     resultant_impl_rec_Lazard = div_exp_Lazard.resultant_impl_rec
   by (rule dichotomous_Lazard)
 
 declare div_exp_Lazard.resultant_code_lemmas[code]
 
 text \<open>As default use Lazard-implementation, which implements
   resultants on factorial rings.\<close>
 declare div_exp_Lazard.resultant_code[code]
 
 text \<open>We also provide a second implementation without Lazard's 
   optimization, which works on integral domains.\<close>
 global_interpretation div_exp_basic: div_exp_sound basic_div_exp 
   defines 
     resultant_impl_basic = div_exp_basic.resultant_impl and
     resultant_impl_main_basic = div_exp_basic.resultant_impl_main and
     resultant_impl_start_basic = div_exp_basic.resultant_impl_start and
     resultant_impl_rec_basic = div_exp_basic.resultant_impl_rec
   by (rule basic_div_exp)
 
 declare div_exp_basic.resultant_code_lemmas[code]
 
 thm div_exp_basic.resultant_code
 
 
 end
\ No newline at end of file
diff --git a/thys/Winding_Number_Eval/Missing_Algebraic.thy b/thys/Winding_Number_Eval/Missing_Algebraic.thy
--- a/thys/Winding_Number_Eval/Missing_Algebraic.thy
+++ b/thys/Winding_Number_Eval/Missing_Algebraic.thy
@@ -1,371 +1,335 @@
 (*
     Author:     Wenda Li <wl302@cam.ac.uk / liwenda1990@hotmail.com>
 *)
 
 section \<open>Some useful lemmas in algebra\<close>
 
 theory Missing_Algebraic imports
   "HOL-Computational_Algebra.Polynomial_Factorial"
   "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
   "HOL-Complex_Analysis.Complex_Analysis"
   Missing_Topology
   "Budan_Fourier.BF_Misc"
 begin
 
 subsection \<open>Misc\<close>
 
 lemma poly_holomorphic_on[simp]:
   "(poly p) holomorphic_on s"
   apply (rule holomorphic_onI)
   apply (unfold field_differentiable_def)
   apply (rule_tac x="poly (pderiv p) x" in exI)
   by (simp add:has_field_derivative_at_within)
 
 lemma order_zorder:
   fixes p::"complex poly" and z::complex
   assumes "p\<noteq>0"
   shows "order z p = nat (zorder (poly p) z)"
 proof -
   define n where "n=nat (zorder (poly p) z)" 
   define h where "h=zor_poly (poly p) z"
   have "\<exists>w. poly p w \<noteq> 0" using assms poly_all_0_iff_0 by auto
   then obtain r where "0 < r" "cball z r \<subseteq> UNIV" and 
       h_holo: "h holomorphic_on cball z r" and
       poly_prod:"(\<forall>w\<in>cball z r. poly p w = h w * (w - z) ^ n \<and> h w \<noteq> 0)"
     using zorder_exist_zero[of "poly p" UNIV z,folded h_def] poly_holomorphic_on
     unfolding n_def by auto
   then have "h holomorphic_on ball z r"
     and "(\<forall>w\<in>ball z r. poly p w = h w * (w - z) ^ n)" 
     and "h z\<noteq>0"
     by auto
   then have "order z p = n" using \<open>p\<noteq>0\<close>
   proof (induct n arbitrary:p h)
     case 0
     then have "poly p z=h z" using \<open>r>0\<close> by auto 
     then have "poly p z\<noteq>0" using \<open>h z\<noteq>0\<close> by auto
     then show ?case using order_root by blast
   next
     case (Suc n)
     define sn where "sn=Suc n"
     define h' where "h'\<equiv> \<lambda>w. deriv h w * (w-z)+ sn * h w"
     have "(poly p has_field_derivative poly (pderiv p) w) (at w)" for w
       using poly_DERIV[of p w] .
     moreover have "(poly p has_field_derivative (h' w)*(w-z)^n ) (at w)" when "w\<in>ball z r" for w
     proof (subst DERIV_cong_ev[of w w "poly p" "\<lambda>w.  h w * (w - z) ^ Suc n" ],simp_all)
       show "\<forall>\<^sub>F x in nhds w. poly p x = h x * ((x - z) * (x - z) ^ n)"
         unfolding eventually_nhds using Suc(3) \<open>w\<in>ball z r\<close>
         apply (intro exI[where x="ball z r"])
         by auto
       next
         have "(h has_field_derivative deriv h w) (at w)" 
           using \<open>h holomorphic_on ball z r\<close> \<open>w\<in>ball z r\<close> holomorphic_on_imp_differentiable_at 
           by (simp add: holomorphic_derivI)
         then have "((\<lambda>w. h w * ((w - z) ^ sn)) 
                       has_field_derivative h' w * (w - z) ^ (sn - 1)) (at w)"
           unfolding h'_def
           apply (auto intro!: derivative_eq_intros simp add:field_simps)
           by (auto simp add:field_simps sn_def)
         then show "((\<lambda>w. h w * ((w - z) * (w - z) ^ n)) 
                       has_field_derivative h' w * (w - z) ^ n) (at w)"
           unfolding sn_def by auto
       qed
     ultimately have "\<forall>w\<in>ball z r. poly (pderiv p) w = h' w * (w - z) ^ n"
       using DERIV_unique by blast  
     moreover have "h' holomorphic_on ball z r"
       unfolding h'_def using \<open>h holomorphic_on ball z r\<close>
       by (auto intro!: holomorphic_intros)
     moreover have "h' z\<noteq>0" unfolding h'_def sn_def using \<open>h z \<noteq> 0\<close> of_nat_neq_0 by auto
     moreover have "pderiv p \<noteq> 0"  
     proof 
       assume "pderiv p = 0"
       obtain c where "p=[:c:]" using \<open>pderiv p = 0\<close> using pderiv_iszero by blast
       then have "c=0"
         using Suc(3)[rule_format,of z] \<open>r>0\<close> by auto
       then show False using \<open>p\<noteq>0\<close> using \<open>p=[:c:]\<close> by auto
     qed
     ultimately have "order z (pderiv p) = n" by (auto elim: Suc.hyps)
     moreover have "order z p \<noteq> 0"
       using Suc(3)[rule_format,of z] \<open>r>0\<close> order_root \<open>p\<noteq>0\<close> by auto
     ultimately show ?case using order_pderiv[OF \<open>pderiv p \<noteq> 0\<close>] by auto
   qed
   then show ?thesis unfolding n_def .
 qed  
 
 lemma pcompose_pCons_0:"pcompose p [:a:] = [:poly p a:]"
   apply (induct p)
   by (auto simp add:pcompose_pCons algebra_simps)       
    
 lemma pcompose_coeff_0:
   "coeff (pcompose p q) 0 = poly p (coeff q 0)"
   apply (induct p)
   by (auto simp add:pcompose_pCons coeff_mult)  
     
 lemma poly_field_differentiable_at[simp]:
   "poly p field_differentiable (at x within s)"
 apply (unfold field_differentiable_def)
 apply (rule_tac x="poly (pderiv p) x" in exI)
 by (simp add:has_field_derivative_at_within)  
   
 lemma deriv_pderiv:
   "deriv (poly p) = poly (pderiv p)"
 apply (rule ext)  
 apply (rule DERIV_imp_deriv)  
   using poly_DERIV . 
     
 lemma lead_coeff_map_poly_nz:
   assumes "f (lead_coeff p) \<noteq>0" "f 0=0"
   shows "lead_coeff (map_poly f p) = f (lead_coeff p) "
 proof -
   have "lead_coeff (Poly (map f (coeffs p))) = f (lead_coeff p)"
     by (metis (mono_tags, lifting) antisym assms(1) assms(2) coeff_0_degree_minus_1 coeff_map_poly 
         degree_Poly degree_eq_length_coeffs le_degree length_map map_poly_def)
   then show ?thesis
     by (simp add: map_poly_def)
 qed 
 
 lemma filterlim_poly_at_infinity:
   fixes p::"'a::real_normed_field poly"
   assumes "degree p>0"
   shows "filterlim (poly p) at_infinity at_infinity"
 using assms
 proof (induct p)
   case 0
   then show ?case by auto
 next
   case (pCons a p)
   have ?case when "degree p=0"
   proof -
     obtain c where c_def:"p=[:c:]" using \<open>degree p = 0\<close> degree_eq_zeroE by blast
     then have "c\<noteq>0" using \<open>0 < degree (pCons a p)\<close> by auto
     then show ?thesis unfolding c_def 
       apply (auto intro!:tendsto_add_filterlim_at_infinity)
       apply (subst mult.commute)
       by (auto intro!:tendsto_mult_filterlim_at_infinity filterlim_ident)
   qed
   moreover have ?case when "degree p\<noteq>0"
   proof -
     have "filterlim (poly p) at_infinity at_infinity"
       using that by (auto intro:pCons)
     then show ?thesis 
       by (auto intro!:tendsto_add_filterlim_at_infinity filterlim_at_infinity_times filterlim_ident)
   qed
   ultimately show ?case by auto
 qed  
        
 lemma poly_divide_tendsto_aux:
   fixes p::"'a::real_normed_field poly"
   shows "((\<lambda>x. poly p x/x^(degree p)) \<longlongrightarrow> lead_coeff p) at_infinity"  
 proof (induct p)
   case 0
   then show ?case by (auto intro:tendsto_eq_intros)
 next
   case (pCons a p)
   have ?case when "p=0"
     using that by auto
   moreover have ?case when "p\<noteq>0"
   proof -
     define g where "g=(\<lambda>x. a/(x*x^degree p))"
     define f where "f=(\<lambda>x. poly p x/x^degree p)"
     have "\<forall>\<^sub>Fx in at_infinity. poly (pCons a p) x / x ^ degree (pCons a p) = g x + f x"
     proof (rule eventually_at_infinityI[of 1])
       fix x::'a assume "norm x\<ge>1"
       then have "x\<noteq>0" by auto
       then show "poly (pCons a p) x / x ^ degree (pCons a p) = g x + f x"
         using that unfolding g_def f_def by (auto simp add:field_simps)
     qed
     moreover have "((\<lambda>x. g x+f x) \<longlongrightarrow>  lead_coeff (pCons a p)) at_infinity"
     proof -
       have "(g \<longlongrightarrow>  0) at_infinity"
         unfolding g_def using filterlim_poly_at_infinity[of "monom 1 (Suc (degree p))"]
         apply (auto intro!:tendsto_intros tendsto_divide_0 simp add: degree_monom_eq)
         apply (subst filterlim_cong[where g="poly (monom 1 (Suc (degree p)))"])
         by (auto simp add:poly_monom)
       moreover have "(f \<longlongrightarrow>  lead_coeff (pCons a p)) at_infinity"
         using pCons \<open>p\<noteq>0\<close> unfolding f_def by auto
       ultimately show ?thesis by (auto intro:tendsto_eq_intros)
     qed
     ultimately show ?thesis by (auto dest:tendsto_cong)  
   qed
   ultimately show ?case by auto  
 qed
   
 lemma filterlim_power_at_infinity:
   assumes "n\<noteq>0"
   shows "filterlim (\<lambda>x::'a::real_normed_field. x^n) at_infinity at_infinity" 
   using filterlim_poly_at_infinity[of "monom 1 n"] assms
   apply (subst filterlim_cong[where g="poly (monom 1 n)"])
   by (auto simp add:poly_monom degree_monom_eq)
    
 lemma poly_divide_tendsto_0_at_infinity: 
   fixes p::"'a::real_normed_field poly"
   assumes "degree p > degree q" 
   shows "((\<lambda>x. poly q x / poly p x) \<longlongrightarrow> 0 ) at_infinity" 
 proof -
   define pp where "pp=(\<lambda>x. x^(degree p) / poly p x)"    
   define qq where "qq=(\<lambda>x. poly q x/x^(degree q))"
   define dd where "dd=(\<lambda>x::'a. 1/x^(degree p - degree q))"
   have "\<forall>\<^sub>Fx in at_infinity.  poly q x / poly p x = qq x * pp x * dd x"
   proof (rule eventually_at_infinityI[of 1])
     fix x::'a assume "norm x\<ge>1"
     then have "x\<noteq>0" by auto
     then show "poly q x / poly p x = qq x * pp x * dd x"
       unfolding qq_def pp_def dd_def using assms 
       by (auto simp add:field_simps divide_simps power_diff) 
   qed
   moreover have "((\<lambda>x. qq x * pp x * dd x) \<longlongrightarrow> 0) at_infinity"
   proof -
     have "(qq \<longlongrightarrow> lead_coeff q) at_infinity" 
       unfolding qq_def using poly_divide_tendsto_aux[of q] .
     moreover have "(pp \<longlongrightarrow> 1/lead_coeff p) at_infinity"
     proof -
       have "p\<noteq>0" using assms by auto
       then show ?thesis
         unfolding pp_def using poly_divide_tendsto_aux[of p] 
         apply (drule_tac tendsto_inverse)
         by (auto simp add:inverse_eq_divide)
     qed  
     moreover have "(dd \<longlongrightarrow> 0) at_infinity" 
       unfolding dd_def
       apply (rule tendsto_divide_0)
       by (auto intro!: filterlim_power_at_infinity simp add:assms)
     ultimately show ?thesis by (auto intro:tendsto_eq_intros)
   qed
   ultimately show ?thesis by (auto dest:tendsto_cong)
 qed
     
 lemma lead_coeff_list_def:
   "lead_coeff p= (if coeffs p=[] then 0 else last (coeffs p))"
 by (simp add: last_coeffs_eq_coeff_degree)
   
 lemma poly_linepath_comp: 
   fixes a::"'a::{real_normed_vector,comm_semiring_0,real_algebra_1}"
   shows "poly p o (linepath a b) = poly (p \<circ>\<^sub>p [:a, b-a:]) o of_real"
   apply rule
   by (auto simp add:poly_pcompose linepath_def scaleR_conv_of_real algebra_simps)
 
 lemma poly_eventually_not_zero:
   fixes p::"real poly"
   assumes "p\<noteq>0"
   shows "eventually (\<lambda>x. poly p x\<noteq>0) at_infinity"
 proof (rule eventually_at_infinityI[of "Max (norm ` {x. poly p x=0}) + 1"])
   fix x::real assume asm:"Max (norm ` {x. poly p x=0}) + 1 \<le> norm x" 
   have False when "poly p x=0"
   proof - 
     define S where "S=norm `{x. poly p x = 0}"
     have "norm x\<in>S" using that unfolding S_def by auto
     moreover have "finite S" using \<open>p\<noteq>0\<close> poly_roots_finite unfolding S_def by blast
     ultimately have "norm x\<le>Max S" by simp
     moreover have "Max S + 1 \<le> norm x" using asm unfolding S_def by simp
     ultimately show False by argo
   qed
   then show "poly p x \<noteq> 0" by auto
 qed
     
 subsection \<open>More about @{term degree}\<close>
    
-lemma degree_div_less:
-  fixes x y::"'a::field poly"
-  assumes "degree x\<noteq>0" "degree y\<noteq>0"
-  shows "degree (x div y) < degree x"
-proof -
-  have "x\<noteq>0" "y\<noteq>0" using assms by auto
-  define q r where "q=x div y" and "r=x mod y"
-  have *:"eucl_rel_poly x y (q, r)" unfolding q_def r_def 
-    by (simp add: eucl_rel_poly)
-  then have "r = 0 \<or> degree r < degree y" using \<open>y\<noteq>0\<close> unfolding eucl_rel_poly_iff by auto
-  moreover have ?thesis when "r=0"
-  proof -
-    have "x = q * y" using * that unfolding eucl_rel_poly_iff by auto
-    then have "q\<noteq>0" using \<open>x\<noteq>0\<close> \<open>y\<noteq>0\<close> by auto
-    from degree_mult_eq[OF this \<open>y\<noteq>0\<close>] \<open>x = q * y\<close> 
-    have "degree x = degree q +degree y" by auto
-    then show ?thesis unfolding q_def using assms by auto
-  qed
-  moreover have ?thesis when "degree r<degree y"
-  proof (cases "degree y>degree x")
-    case True
-    then have "q=0" unfolding q_def using div_poly_less by auto
-    then show ?thesis unfolding q_def using assms(1) by auto
-  next
-    case False
-    then have "degree x>degree r" using that by auto
-    then have "degree x = degree (x-r)" using degree_add_eq_right[of "-r" x] by auto
-    have "x-r = q*y" using * unfolding eucl_rel_poly_iff by auto
-    then have "q\<noteq>0" using \<open>degree r < degree x\<close> by auto
-    have "degree x = degree q +degree y" 
-      using  degree_mult_eq[OF \<open>q\<noteq>0\<close> \<open>y\<noteq>0\<close>] \<open>x-r = q*y\<close> \<open>degree x = degree (x-r)\<close> by auto
-    then show ?thesis unfolding q_def using assms by auto
-  qed
-  ultimately show ?thesis by auto
-qed  
-  
 lemma map_poly_degree_eq:
   assumes "f (lead_coeff p) \<noteq>0"
   shows "degree (map_poly f p) = degree p"  
   using assms
   unfolding map_poly_def degree_eq_length_coeffs coeffs_Poly lead_coeff_list_def
   by (metis (full_types) last_conv_nth_default length_map no_trailing_unfold nth_default_coeffs_eq 
       nth_default_map_eq strip_while_idem)
   
 lemma map_poly_degree_less:
   assumes "f (lead_coeff p) =0" "degree p\<noteq>0"
   shows "degree (map_poly f p) < degree p" 
 proof -
   have "length (coeffs p) >1" 
     using \<open>degree p\<noteq>0\<close> by (simp add: degree_eq_length_coeffs)  
   then obtain xs x where xs_def:"coeffs p=xs@[x]" "length xs>0"  
     by (metis One_nat_def add.commute add_diff_cancel_left' append_Nil assms(2) 
         degree_eq_length_coeffs length_greater_0_conv list.size(3) list.size(4) not_less_zero
         rev_exhaust) 
   have "f x=0" using assms(1) by (simp add: lead_coeff_list_def xs_def(1))
   have "degree (map_poly f p) = length (strip_while ((=) 0) (map f (xs@[x]))) - 1" 
     unfolding map_poly_def degree_eq_length_coeffs coeffs_Poly
     by (subst xs_def,auto)
   also have "... = length (strip_while ((=) 0) (map f xs)) - 1"   
     using \<open>f x=0\<close> by simp
   also have "... \<le> length xs -1"
     using length_strip_while_le by (metis diff_le_mono length_map)
   also have "... < length (xs@[x]) - 1"
     using xs_def(2) by auto
   also have "... = degree p"
     unfolding degree_eq_length_coeffs xs_def by simp
   finally show ?thesis .
 qed
   
 lemma map_poly_degree_leq[simp]:
   shows "degree (map_poly f p) \<le> degree p"
   unfolding map_poly_def degree_eq_length_coeffs
   by (metis coeffs_Poly diff_le_mono length_map length_strip_while_le)  
     
 subsection \<open>roots / zeros of a univariate function\<close>
 
 definition roots_within::"('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
   "roots_within f s = {x\<in>s. f x = 0}"
   
 abbreviation roots::"('a \<Rightarrow> 'b::zero) \<Rightarrow> 'a set" where
   "roots f \<equiv> roots_within f UNIV"
 
 subsection \<open>The argument principle specialised to polynomials.\<close>
 
 lemma argument_principle_poly:
   assumes "p\<noteq>0" and valid:"valid_path g" and loop: "pathfinish g = pathstart g" 
     and no_proots:"path_image g \<subseteq> - proots p"  
   shows "contour_integral g (\<lambda>x. deriv (poly p) x / poly p x) = 2 * of_real pi * \<i> * 
             (\<Sum>x\<in>proots p. winding_number g x * of_nat (order x p))"  
 proof -
   have "contour_integral g (\<lambda>x. deriv (poly p) x / poly p x) = 2 * of_real pi * \<i> * 
           (\<Sum>x | poly p x = 0. winding_number g x * of_int (zorder (poly p) x))"
     apply (rule argument_principle[of UNIV "poly p" "{}" "\<lambda>_. 1" g,simplified,OF _ valid loop])
     using no_proots[unfolded proots_def] by (auto simp add:poly_roots_finite[OF \<open>p\<noteq>0\<close>] )
   also have "... =  2 * of_real pi * \<i> * (\<Sum>x\<in>proots p. winding_number g x * of_nat (order x p))"
   proof -
     have "nat (zorder (poly p) x) = order x p" when "x\<in>proots p" for x 
       using order_zorder[OF \<open>p\<noteq>0\<close>] that unfolding proots_def by auto
     then show ?thesis unfolding proots_def 
       apply (auto intro!:comm_monoid_add_class.sum.cong)
       by (metis assms(1) nat_eq_iff2 of_nat_nat order_root)
   qed
   finally show ?thesis . 
 qed  
   
 end